# This short example extracts phoneme and word timing information from
# a SOB file (as created by BaldiSync)
# 1999-09-01 Jacques@deVilliers.com
# 2000-04-05 glob update

package require Rtcl
package require Wave

########### define constants ###########
set num_visemes 2
set num_params_per_viseme 1

# mapping of worldbet symbols onto parameters

array set wb_viseme_map {\
	i: E \
	I E \
	E A \
	@ E \
	I_x I \
	u_x U \
	& A \
	&0 U \
	5 O \
	u U \
	U U \
	^ O \
	> A \
	A A \
	3r U \
	&r U \
	ei O \
	aI I \
	>i O \
	iU U \
	aU O \
	oU U \
	i& E \
	e& A \
	u& O \
	ph MBP \
	th Th \
	kh Th \
	b MBP \
	d NONVOWEL \
	g Th\
	m MBP \
	n Th \
	N Th\
	th_( Th\
	d_( Th\
	f FV \
	T Th \
	s NONVOWEL \
	S NONVOWEL \
	h NONVOWEL \
	v FV \
	D Th \
	z NONVOWEL \
	Z NONVOWEL \
	tS NONVOWEL \
	dZ NONVOWEL\
	l L \
	9r WQ \
	j WQ \
	w WQ \
	m= MBP \
	n= Th \
	N= Th \
	l= L \
	pc MBP \
	tc Th \
	kc Th \
	bc MBP \
	dc Th \
	gc Th \
	tSc NONVOWEL \
	dZc NONVOWEL \
	+ MBP \
	.pau REST}

array set viseme_param_map {\
	WQ {5 0 0 0 0  0 0.01 -0.015 0 0 0 -0.03 0 0 -0.03 0.01 0.01 0.01 0 0.03 0.03 0.04} \
	WQ,early 0 \
	A {15 0 0 0 0 0 0.01 0 0 0 0 0 0 0 0 0.01 0 0.05 0.05 0.03 0.03 0.02} \
	A,early 0 \
	E { 0 0 0 0.02 0 0 0.04 0.035 0 0 0.04 -0.01 0 0.05 -0.01 0 -0.01 -0.01 0 -0.026 -0.023 -0.02} \
	E,early 0 \
	U {0.005 0 0.01 0.02 0 0 0.045 -0.05 -0.03 0.03 0.05 -0.03 0 0.0712 -0.039 0.03 -0.03 0 -0.01 -0.025 -0.03 -0.03} \
	U,early 0 \
	REST {-0.5 0 0 0.00670219 0 0 0.0288841 0 0 0 0.0229465 0 0 0.0233635 0 0 0 -0.0267606 0.020504 -0.0372015 -0.0345186 -0.00849802} \
	REST,early 0 \
	NONVOWEL {0.886626 0 0 0.010852 0 0 0.0288841 0 0 0 0.0229465 0 0 0.0233635 0 0 0 -0.0267606 -0.00239376 -0.0215096 -0.0187036 -0.00849802} \
	NONVOWEL,early 0 \
	I {15 0 0 0 0 0 0.05 0 0 0 0 0 0 0 0 0.01 0 0.05 0.05 0.05 0.05 0.05} \
	I,early 0 \
	FV {0 0 0 0.01 0 0 0.05 0 0 0 0.014 0 0 0.03 0 0.04 0 0 0.035 0.02 0.02 0.02} \
	FV,early 1 \
	Th {-0.5 0 0 -0.0166558 0.0731049 -0.0712704 0.0713169 0 0 0 -0.021751 0 0 -0.000647611 0.0565474 0.0565474 -0.0296133 -0.0267606 -0.00876434 -0.0301976 -0.0345186 -0.00849802} \
	Th,early 0 \
	L {8 0 0 0 0 0 0.05 0 0 0 0 0 0 0 0 0.04 0 0 0 0.01 0 0 } \
	L,early 0 \
	O {13 0 0.01 0 0 0 0 -0.04 0 0 0.01 -0.03 0 0.01 -0.03 0.01 0 0.05 0 0.01 0.01 0} \
	O,early 0 \
	MBP {-0.5 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0.01 0.01 0 } \
	MBP,early 1}

set params_used { p4  p14 p16 p17 l63 r63 p64 p65 l66 r66 p67 p68 p69 p70 p71 p72 p73 p74 p75 p76 p77 p78 }

# this fn by Jacques deVilliers
proc writephn {file list} {
 set f [open $file w]
 puts $f "MillisecondsPerFrame: 1.0"
 puts $f "END OF HEADER"
 foreach l $list {
  foreach {start stop label} $l break
  puts $f [format "%1.0f %1.0f %s" $start $stop $label]
 }
 close $f
}

proc msecToFrame { msec fps } {    
    return [expr int(((double($msec)/1000)*$fps))]
}

proc writeOneFrame { f data } {
    global params_used

    for {set i 0} {$i < [llength $params_used]} {incr i} {
	puts $f "[lindex $params_used $i] [lindex $data $i]"
    }
}

proc writeLERPFile {file list} {
    global wb_viseme_map viseme_param_map

#    console show
    
    # create our list of keyframes
    # the key_list will look like:
    # {{0 {.5 .5 0 0 ...}} {12 {.95 .5 0 .5 ...}} ...}
    # where each element is a pair, consisting of the frame where
    # that parameter reaches its target, and the values of the parameters
    # for that target..
    set key_list {}

    #start with the .pau viseme (at-rest mouth)
    # should we be doing this?
    lappend key_list [list 0 .pau]
    foreach l $list {
	foreach {start stop label} $l break

	# if this phoneme has early onset	
	if {$viseme_param_map($wb_viseme_map($label),early)} {
	    lappend key_list [list [msecToFrame $start 30] $label]

	    # if not early onset
	} else {
	    set center_frame [msecToFrame [expr ($start + $stop)/2] 30]
	    lappend key_list [list $center_frame $label]
	}
	#puts "$label: [lindex $key_list end]"
    }
    
    set isLastKey 0
    set interp_begin [lindex $key_list 0]

    set i 1
    set f [open $file w]
    while !$isLastKey {

	# the first time through, interp_begin is set to the .pau
	# key that we artificially inserted, and interp_end gets set to
	# the one right after that (probably a .pau which the .phn file
	# had there anyway
	set interp_end [lindex $key_list $i]

	# grab the frame number for the beginning and end of this phoneme
	set first_frame [lindex $interp_begin 0]
	set last_frame [lindex $interp_end 0]

	set wb_symbol_first [lindex $interp_begin 1]
	set wb_symbol_last [lindex $interp_end 1]	
	# grab the values which we will want to be hitting at the
	# beginning and end of this segment, respectively
	set first_frame_params $viseme_param_map($wb_viseme_map($wb_symbol_first))
	set last_frame_params $viseme_param_map($wb_viseme_map($wb_symbol_last))
	
	# note, we iterate while j is strictly less than last_frame,
	# so that the next time through we begin with last_frame without
	# duplicating frames..
	for {set j $first_frame} {$j < $last_frame} {incr j} {
	    set t [expr double($j - $first_frame)/($last_frame - $first_frame)]
	    puts $f "k"
	    writeOneFrame $f [linterp $first_frame_params $last_frame_params $t]
	}
	
	incr i
	if {[llength $key_list] > $i} {
	    set interp_begin $interp_end
	} else {
	    set isLastKey 1
	}
    }
    puts "wrote $last_frame frames"
    close $f

#    console show
#    foreach key $key_list {
#	puts $key
#    }
}

proc linterp { start_vec end_vec t } {
    set result {}    
    foreach p_start $start_vec p_end $end_vec {
	lappend result [expr (1 - $t)*$p_start + $t*$p_end]
    }
    return $result
}

# this fn by Jacques deVilliers
proc sob2phn basefn {
    set fh [obfile open $basefn.sob]
    set pl [raw set [set r [obfile read $fh phoneLabel.0]]]; nuke $r
    #set wl [raw set [set r [obfile read $fh wordLabel.0]]]; nuke $r
    set w [obfile read $fh wave.0]
    obfile close $fh
    writeLERPFile $basefn.lips $pl
    wave write $w $basefn.lips.wav

    # un-comment either of the following 2 to cause the script to
    # output the .phn and .wrd files, respectively..
    #writephn $basefn.phn $pl
    #writephn $basefn.wrd $wl
}

proc getSaveFile {} {    
    set types {
	{{phn Files}        {.phn}        }
	{{wrd Files}        {.wrd}        }
	{{All Files}        *             }
    }
    
    set filename [tk_getSaveFile -filetypes $types -initialdir .]
    if {$filename!=""} {set currentDir [file dirname $filename]}
    return $filename
    # if nothing is selected, filename will be ""
}

proc saveText {textwidget} {
    set filename [getSaveFile]
    if [llength filename] {
	set f [open $filename w]
	puts $f [$textwidget get 0.0 end]
	close $f
    } else {
	
    }
}

proc viewtext {file secondarg} {
    set counter 0
    while 1 {if {![winfo exists .view$counter]} {break} else {incr counter}}
    set w [toplevel .view$counter]
    wm title $w $file
    text $w.text -relief sunken -bd 2 -yscrollcommand \
	    "$w.scroll set" -setgrid 1 -height 30
    
    scrollbar $w.scroll -command "$w.text yview"
    button $w.save -command "saveText $w.text" -text "Save Text"
    button $w.dismiss -command "destroy $w" -text "Dismiss window"
    
    pack $w.save $w.dismiss -side bottom
    pack $w.scroll -side right -fill y
    pack $w.text -expand yes -fill both
    
    if $file {    
	set f [open $secondarg r]
	set contents [read $f]
	close $f
    } else {
	set contents $secondarg
    }
    
    $w.text insert 0.0 "$contents"
}

catch {wm withdraw .}
set sobfile [tk_getOpenFile -filetypes \
	{{{.sob Files} {.sob}} {{All Files} *}} \
	-initialdir .]
if [llength $sobfile] {
    sob2phn [file rootname $sobfile]
}
#exit
