package require emu-script

#-----------------------------------------------------------------------------#
#bound_ip_IP_u     (toip toIP) 
#25.04.2003 
#
#for a hierarchy like Utterance > Intonational > Intermediate > Boundary ...
#
#+copies labels at Boundary level to labels at Intermediate level  (toip)
#-links that to a label at Intonational level (toIP)
#-links that to a label at Utterance level


# HierLabel marks each pitch-accented word (a word 
# that dominates any material at the tone level) as A
proc HierLabel {hierarchy plevel clevel lablevel {ltype1 U} {ltype2 A}} {

# list the elements at the parent level
set wd [$hierarchy segments $plevel]

# if an element at the plevel does not dominate
# an element at the clevel, then make
# the corresponding element at lablevel U
# otherwise make it A. 
# example: Hierlabel h Word Tone Accent
# makes all Accent elements U if Word doesn't
# dominate Tone, otherwise A
# Hierlabel h Word Tone Accent un ac
# as above, but instead of U and A you get un and ac
foreach j $wd {
set num [$hierarchy seginfo $j children $clevel]
if {[llength $num] == 0} {
$hierarchy seginfo $j label $lablevel $ltype1
} else {
$hierarchy seginfo $j label $lablevel $ltype2
}
}
}




proc bound_ip_IP_u {hier} {
  global bsegnolist ipsegnolist IPsegnolist
  set bsegnolist ""
  set ipsegnolist ""
  set IPsegnolist ""

   #get all segnos
   set allsegnos [$hier segments Boundary]

   foreach segno $allsegnos {
      #rules
	switch -glob [$hier seginfo $segno label Boundary] {
	   "H-" 	{lappend bsegnolist $segno; 	toip "H-" $hier}
	   "L-" 	{lappend bsegnolist $segno; 	toip "L-" $hier}
	   "L-%" 	{lappend bsegnolist $segno; 	toip "L-" $hier; toIP "L%" $hier}
	   "H-%" 	{lappend bsegnolist $segno; 	toip "H-" $hier; toIP "L%" $hier}
	   "L-H%" 	{lappend bsegnolist $segno; 	toip "L-" $hier; toIP "H%" $hier}
	   "H-^H%" 	{lappend bsegnolist $segno; 	toip "H-" $hier; toIP "H%" $hier}
	   "!H-%" 	{lappend bsegnolist $segno; 	toip "!H-" $hier; toIP "L%" $hier}
	   default 	{lappend bsegnolist $segno}

	}
  }

   #add utterance knot
   set utonesegno [$hier append Utterance]

   #add children
   $hier seginfo $utonesegno children Utterance $IPsegnolist
}



proc toip {iptone hier} {
global bsegnolist ipsegnolist temp


	#insert iptone label at Intermediate level
	set iptonesegno [$hier append Intermediate]
	$hier seginfo $iptonesegno label Intermediate $iptone 
	
	#add children
	$hier seginfo $iptonesegno children Intermediate $bsegnolist

	lappend ipsegnolist $iptonesegno
	set bsegnolist ""
}

proc toIP {IPtone hier} {
global ipsegnolist IPsegnolist temp $hier

	#insert IPtone label at Intonational level
	set IPtonesegno [$hier append Intonational]
	$hier seginfo $IPtonesegno label Intonational $IPtone

	#add children
	$hier seginfo $IPtonesegno children Intonational $ipsegnolist

	lappend IPsegnolist $IPtonesegno
	
	set ipsegnolist ""
}
#-----------------------------------------------------------------------------#



proc AutoBuildInit {templ} {
global bsegnolist ipsegnolist IPsegnolist

set bsegnolist ""
set ipsegnolist ""
set IPsegnolist ""
}


proc AutoBuild {temp hier} {
	LinkFromTimes $hier Word Tone
	bound_ip_IP_u $hier
HierLabel $hier Word Tone Accent U A

}



