home *** CD-ROM | disk | FTP | other *** search
/ PC World 2002 May / PCWorld_2002-05_cd.bin / Software / TemaCD / activetcltk / ActiveTcl8.3.4.1-8.win32-ix86.exe / ActiveTcl8.3.4.1-win32-ix86 / demos / Snack / dbrec.tcl < prev    next >
Encoding:
Text File  |  2001-10-22  |  14.7 KB  |  577 lines
  1. #!/bin/sh
  2. # the next line restarts using wish \
  3. exec wish8.3 "$0" "$@"
  4.  
  5. # Prompted sentence recording application
  6.  
  7. package require -exact snack 2.1
  8.  
  9. set rate 16000
  10. snack::sound t -rate $rate
  11. snack::sound s -rate $rate
  12.  
  13.  
  14. # dbrec.tcl menus
  15.  
  16. set m [menu .menu]
  17. $m add cascade -label File -menu $m.file -underline 0
  18. menu $m.file -tearoff 0
  19. $m.file add command -label "New session..." -command [list NewSession]
  20. $m.file add command -label "Open script..." -command [list OpenScriptFile]
  21. $m.file add command -label "Database browser..." -command [list OpenBrowser]
  22. $m.file add command -label "Show speaker info..." -command OpenSpeakerDialog
  23. $m.file add command -label "Exit" -command exit
  24. $m add cascade -label Audio -menu $m.audio -underline 0
  25. menu $m.audio -tearoff 0
  26. $m.audio add command -label "Mixer..." -command snack::mixerDialog
  27. . config -menu $m
  28.  
  29.  
  30. # Initialize some global variables
  31.  
  32. set needsave 0
  33. set replay 1
  34. set fontsize 20
  35. set prompt "Please load a recording script and start a new session"
  36. set ::name ""
  37. set ::imax 0
  38.  
  39.  
  40. # Draw waveform and prompt boxes
  41.  
  42. pack [canvas .c -height 80 -width 1000 -relief sunken -bd 3]
  43. .c create waveform 0 0 -sound s -height 80 -width 1000 -limit 32768
  44. pack [frame .f2 -relief sunken -bd 3] -pady 15
  45. pack [label .f2.l1 -text Prompt: -anchor w] -fill x
  46. pack [label .f2.l2 -textvar prompt -font "Helvetica $fontsize bold"] \
  47.     -expand yes -fill x
  48.  
  49.  
  50. # Buttons, time, and level meter
  51.  
  52. snack::createIcons
  53. pack [frame .f1] -pady 5
  54. button .f1.bp -bitmap snackPlay -width 40 -command Play -state disabled
  55. #button .f1.bu -bitmap snackPause -command Pause
  56. #button .f1.bs -bitmap snackStop -command Stop
  57. button .f1.br -bitmap snackRecord -width 40 -fg red -state disabled
  58. button .f1.pr -text Prev -command Prev -state disabled
  59. button .f1.ne -text Next -command Next -state disabled
  60. checkbutton .f1.be -text replay -variable replay
  61. label .f1.time -text "00:00.0" -width 10
  62. snack::levelMeter .f1.lm -width 20 -length 200
  63. label .f1.level -textvariable level
  64.  
  65. # Arrow key descriptions
  66.  
  67. frame .f1.f
  68. grid [frame .f1.f.g]
  69. grid [label .f1.f.g.lc -text <Space>=Play -relief raised -bd 3] -row 2 -col 1 -padx 20
  70. grid [label .f1.f.g.lu -text <Up>=Record -relief raised -bd 3] -row 1 -col 3
  71. grid [label .f1.f.g.ll -text <Left>=Prev -relief raised -bd 3] -row 2 -col 2
  72. grid [label .f1.f.g.ld -text <Down>=Stop -relief raised -bd 3] -row 2 -col 3
  73. grid [label .f1.f.g.lr -text <Right>=Next -relief raised -bd 3] -row 2 -col 4
  74.  
  75. pack .f1.bp .f1.br .f1.pr .f1.ne .f1.be .f1.time .f1.lm .f1.level \
  76.     .f1.f -side left
  77. bind .f1.br <ButtonPress-1>   Record
  78. bind .f1.br <ButtonRelease-1> Stop
  79.  
  80.  
  81. # Database browser
  82.  
  83. frame .db -relief raised -bd 3
  84. pack [label .db.l -text "Note! Recording is disabled when the database browser is displayed."]
  85. pack [frame .db.f0] -expand true -fill x
  86. pack [label .db.f0.l1 -text Session: -anchor w] -side left -fill x \
  87.     -expand true
  88. pack [label .db.f0.l2 -text Sentence: -anchor w] -side left -fill x \
  89.     -expand true
  90. pack [frame .db.f1] -expand true -fill both
  91. pack [listbox .db.f1.l1 -yscrollcommand [list .db.f1.s1 set]] \
  92.     -side left -fill both -expand true
  93. pack [scrollbar .db.f1.s1 -orient vertical -command [list .db.f1.l1 yview]] \
  94.     -side left -fill y
  95. pack [listbox .db.f1.l2 -yscrollcommand [list .db.f1.s2 set]] \
  96.     -side left -fill both -expand true
  97. pack [scrollbar .db.f1.s2 -orient vertical -command [list .db.f1.l2 yview]] \
  98.     -side left -fill y
  99. bind .db.f1.l1 <ButtonRelease-1> BrowseSession
  100. bind .db.f1.l2 <ButtonRelease-1> BrowseSentence
  101. pack [button .db.f1.b -text Goto -command Goto] -side left
  102.  
  103. pack [frame .db.f2]
  104. pack [button .db.f2.b -text Save -command SaveTrans] -side right
  105. pack [entry .db.f2.e -width 100 -textvariable ::editprompt] -side right
  106. pack [button .db.b -text "Hide" -command CloseBrowser]
  107.  
  108.  
  109. # Message bar
  110.  
  111. pack [frame .bf] -side bottom -fill x
  112. entry .bf.lab -font {Helvetica 18 bold} -textvar msg -width 1 \
  113.     -relief sunken -bd 1 -state disabled
  114. pack .bf.lab -side left -expand yes -fill x
  115.  
  116. wm protocol . WM_DELETE_WINDOW exit
  117.  
  118. proc OpenBrowser {} {
  119.   wm geometry . {}
  120.   pack .db -before .bf -expand true -fill both
  121.   .f1.br configure -state disabled
  122.   bind . <KeyRelease-Up> {}
  123.   bind . <KeyPress-Down> {}
  124. }
  125.  
  126. proc CloseBrowser {} {
  127.   wm geometry . {}
  128.   pack forget .db
  129.   .f1.br configure -state normal
  130.   bind . <KeyRelease-Up> Record
  131.   bind . <KeyPress-Down> Stop
  132. }
  133.  
  134. proc BrowseSession {} {
  135.   set cur [.db.f1.l1 curselection]
  136.   if {$cur != ""} {
  137.     set ::bsession [lindex [split [.db.f1.l1 get $cur] :] 0]
  138.     set dir [format "sn%04d" $::bsession]
  139.     set filelist [lsort [glob -nocomplain [file join $dir sent???.wav]]]
  140.     .db.f1.l2 delete 0 end
  141.     foreach file $filelist {
  142.       .db.f1.l2 insert end $file
  143.     }
  144.     set ::msg "Recorded [llength $filelist]/$::imax"
  145.   }
  146. }
  147.  
  148. proc BrowseSentence {} {
  149.   set cur [.db.f1.l2 curselection]
  150.   if {$cur != ""} {
  151.     s read [.db.f1.l2 get $cur]
  152.     SetTime [s length -unit sec]
  153.     if [catch {open [file rootname [.db.f1.l2 get $cur]].txt} in] {
  154.       set msg $in
  155.     } else {
  156.       set ::editprompt [lindex [split [read $in] \n] 0]
  157.       close $in
  158.     }
  159.     Play
  160.   }
  161. }
  162.  
  163. proc SaveTrans {} {
  164.   set cur [.db.f1.l2 curselection]
  165.   if {$cur != ""} {
  166.     if [catch {open [file rootname [.db.f1.l2 get $cur]].txt w} out] {
  167.       error $out
  168.     } else {
  169.       puts $out $::editprompt
  170.       close $out
  171.     }
  172.   }
  173. }
  174.  
  175. proc Goto {} {
  176.   CloseBrowser
  177.   if {![info exists ::bsession]} return
  178.   set ::session $::bsession
  179.   GetSpeakerInfo $::session
  180.   DoOpenScriptFile $::script
  181.   set ::dir [format "sn%04d" $::session]
  182.   set cur [.db.f1.l2 curselection]
  183.   if {$cur != ""} {
  184.     scan [.db.f1.l2 get $cur] "sn%d/sent%d" dummy n
  185.     set ::sentence $n
  186.   } else {
  187.     set ::sentence 1
  188.   }
  189.   set ::prompt $::prompts($::sentence)
  190.   GetSentence
  191.   if {$::sentence == $::imax} {
  192.     ConfigPrev normal
  193.     ConfigNext disabled
  194.   } elseif {$::sentence == 1} {
  195.     ConfigPrev disabled
  196.     ConfigNext normal
  197.   } else {
  198.     ConfigPrev normal
  199.     ConfigNext normal
  200.   }
  201.   wm title . "Session $::session ($::script)"
  202.   set ::msg "Session $::session, sentence 1/$::imax"
  203. }
  204.  
  205. proc OpenSpeakerDialog {} {
  206.   set w .si
  207.   catch {destroy $w}
  208.   toplevel $w -class Dialog
  209.   GetSpeakerInfo $::session
  210.   pack [label $w.nl -text Name:]
  211.   pack [entry $w.ne -textvariable ::name -width 40]
  212.   pack [label $w.al -text Age:]
  213.   pack [entry $w.ae -textvariable ::age -width 4]
  214.   pack [label $w.rl -text Region:]
  215.   pack [entry $w.re -textvariable ::region -width 40]
  216.   pack [radiobutton $w.gf -text Female -value Female -variable ::gender] \
  217.       -anchor w
  218.   pack [radiobutton $w.gm -text Male -value Male -variable ::gender] \
  219.       -anchor w
  220.   pack [label $w.ol -text Other:]
  221.   pack [entry $w.oe -textvariable ::other -width 40]
  222.   pack [frame $w.bf -relief raised -bd 1] -expand yes -fill x
  223.   snack::makeDialogBox $w -title "Speaker information" -type ok
  224.   SaveSpeakerInfo
  225. }
  226.  
  227. proc GetSpeakerInfo {n} {
  228.   set ::name ""
  229.   set ::age ""
  230.   set ::region ""
  231.   set ::gender Female
  232.   set ::other ""
  233.   set dir [format "sn%04d" $n]
  234.   catch {source [file join $dir info.txt]}
  235. }
  236.  
  237. proc SaveSpeakerInfo {} {
  238.   set dir [format "sn%04d" $::session]
  239.   if {[catch {open [file join $dir info.txt] w} out]} {
  240.     error $out
  241.   } else {
  242.     puts $out "set ::name   \"$::name\""
  243.     puts $out "set ::age    \"$::age\""
  244.     puts $out "set ::region \"$::region\""
  245.     puts $out "set ::gender \"$::gender\""
  246.     puts $out "set ::other  \"$::other\""
  247.     puts $out "set ::script \"$::script\""
  248.     close $out
  249.   }
  250.   catch {destroy .si}
  251.   set i 0
  252.   while {[lindex [split [.db.f1.l1 get $i] :] 0] < $::session} {
  253.     if {[.db.f1.l1 get $i] == ""} break
  254.     incr i
  255.   }
  256.   .db.f1.l1 delete $i
  257.   .db.f1.l1 insert $i "$::session: $::name, d $::script"
  258. }
  259.  
  260. proc OpenScriptFile {} {
  261.   set types {
  262.     {{Script Files} {.scr}}
  263.     {{All Files}    *  }
  264.   }
  265.   set file [tk_getOpenFile -title "Open prompt file" -filetypes $types]
  266.   if {$file == ""} return
  267.   set ::script $file
  268.   if {$::name != ""} SaveSpeakerInfo
  269.   DoOpenScriptFile $file
  270.   wm title . "Session $::session ($::script)"
  271.   set msg "Session $::session, sentence 1/$::imax"
  272.   set ::sentence 1
  273.   GetSentence
  274.   ConfigNext normal
  275.   ConfigPrev disabled
  276. }
  277.  
  278. proc SetTime {t} {
  279.   set mmss [clock format [expr int($t)] -format "%M:%S"]
  280.   .f1.time config -text $mmss.[format "%d" [expr int(10*($t-int($t)))]]
  281. }
  282.  
  283. proc Update {} {
  284.   if {$::op == "p"} {
  285.     set t [audio elapsed]
  286.     set end   [expr int([s cget -rate] * $t)]
  287.     set start [expr $end - [s cget -rate] / 10]
  288.     if {$start < 0} { set start 0}
  289.     if {$end >= [s length]} { set end -1 }
  290.     if {[s length] > 0 && $start < [s length]} {
  291.       if [catch {set l [s max -start $start -end $end]}] {
  292.     puts [s length],$start,$end
  293.       }
  294.     } else {
  295.       set l 0
  296.     }
  297.   } else {
  298.     set l [t max]
  299.     t length 0
  300.     set t [s length -unit sec]
  301.     SetTime $t
  302.   }
  303.   .f1.lm configure -level $l
  304.   
  305.   after 100 Update
  306. }
  307.  
  308. proc Record {} {
  309.   if {$::op == "r"} return
  310.   ConfigPrev disabled
  311.   ConfigNext disabled
  312.   s stop
  313.   s record
  314.   t record
  315.   set ::op r
  316.   set ::needsave 1
  317.   .f1.bp configure -relief raised
  318. #  .f1.br configure -relief groove
  319.   .c itemconfig 1 -fill darkgreen
  320. }
  321.  
  322. proc Play {} {
  323.   t stop
  324.   s stop
  325.   s play -command Stop
  326.   set ::op p
  327.   .f1.bp configure -relief groove
  328. #  .f1.br configure -relief raised
  329.   ConfigPrev disabled
  330.   ConfigNext disabled
  331.   # .f1.bu configure -relief raised
  332. }
  333.  
  334. proc Stop {} {
  335.   if {$::op == "s"} return
  336.   s stop
  337.   t record
  338.   .f1.bp configure -relief raised
  339. #  .f1.br configure -relief raised
  340.  
  341.   if {[winfo ismapped .db] == 0} {
  342.     if {[info exists ::sentence] && $::sentence > 1} {
  343.       ConfigPrev normal
  344.     }
  345.     if {[info exists ::sentence] && $::sentence < $::imax} {
  346.       ConfigNext normal
  347.     }
  348.   }
  349.   if {$::op == "p"} {
  350.     set ::op s
  351.     if {[info exists ::sentence] && $::sentence == $::imax} {
  352.       tk_messageBox -message "The script is finished"
  353.     }
  354.     return
  355.   }
  356.   set ::op s
  357.   # .f1.bu configure -relief raised
  358.   if {[s length -unit sec] < 0.8} {
  359.     tk_messageBox -message "Note! Pressing the record button starts recording. Releasing it stops recording. You can not just click on it." -icon warning
  360.     return
  361.   }  
  362.   set arg [expr {[s max] / 32767.0}]
  363.   if {$arg < 0.00001} { set arg 0.00001 }
  364.   set ::level [format "%.1fdB" [expr {20.0 * log($arg)}]]
  365.   if {[s max] < 10000} {
  366.     .c itemconfig 1 -fill red
  367.     tk_messageBox -message "Low volume!" -icon warning
  368.   }
  369.   if {[s max] == 32767 || [s min] == -32768} {
  370.     .c itemconfig 1 -fill red
  371.     tk_messageBox -message "Signal clipped!" -icon warning
  372.   }
  373.   
  374.   if {$::needsave && [info exists ::dir]} {
  375.     s write [file join $::dir [format "sent%03d" $::sentence].wav]
  376.     if {[catch {open [file join $::dir [format "sent%03d" $::sentence].txt] \
  377.     w} out]} {
  378.       error $out
  379.     } else {
  380.       puts $out $::prompt
  381.       close $out
  382.     }
  383.     set ::needsave 0
  384.     if {$::replay} {
  385.       Play
  386.     } else {
  387.       if {$::sentence == $::imax} {
  388.     tk_messageBox -message "The script is finished"
  389.       }
  390.     }
  391.     .menu.file entryconfigure "Open script..." -state disabled
  392.   }
  393. }
  394.  
  395. proc Pause {} {
  396.   s pause
  397.   if {$::op != "s"} {
  398.     if {[.f1.bu cget -relief] == "raised"} {
  399.       .f1.bu configure -relief groove
  400.     } else {
  401.       .f1.bu configure -relief raised
  402.     }
  403.   }
  404. }
  405.  
  406. proc GetSentence {} {
  407.   if {[info exists ::dir]} {
  408.     if {[file exists [file join $::dir [format "sent%03d" $::sentence].wav]]} {
  409.       s read [file join $::dir [format "sent%03d" $::sentence].wav]
  410.       SetTime [s length -unit sec]
  411.     }
  412.   }
  413.   set ::prompt $::prompts($::sentence)
  414.   set ::msg "Session $::session, sentence $::sentence/$::imax"
  415.   
  416.   set size 20
  417.   while {[font measure "Helvetica $size bold" $::prompt] > 1024} {
  418.     incr size -2
  419.   }    
  420.   .f2.l2 configure -font "Helvetica $size bold"
  421. }
  422.  
  423. proc Next {} {
  424.   incr ::sentence
  425.   s flush
  426.   GetSentence
  427.   if {$::sentence == $::imax} {
  428.     ConfigNext disabled
  429.   }
  430.   ConfigPrev normal
  431. }
  432.  
  433. proc Prev {} {
  434.   incr ::sentence -1
  435.   s flush
  436.   GetSentence
  437.   if {$::sentence == 1} {
  438.     ConfigPrev disabled
  439.   }
  440.   ConfigNext normal
  441. }
  442.  
  443. proc DoOpenScriptFile {script} {
  444.   set i 1
  445.   if [catch {open $script} in] {
  446.     set ::msg $in
  447.   } else {
  448.     set promptfile [read $in]
  449.     close $in
  450.     foreach row [split $promptfile \n] {
  451.       if {$row != ""} {
  452.     set ::prompts($i) $row
  453.     incr i
  454.       }
  455.     }
  456.     set ::imax [expr $i - 1]
  457.   }
  458.   .f1.bp configure -state normal
  459.   bind . <space> Play
  460.   .f1.br configure -state normal
  461.   bind . <KeyRelease-Up> Record
  462.   bind . <KeyPress-Down> Stop
  463. }
  464.  
  465. proc FirstSession {} {
  466.   set declist [lsort -decreasing $::dirlist]
  467.   if {$::dirlist != ""} {
  468.     set lastdir [lindex $declist 0]
  469.     set lastsession [string trimleft $lastdir sn0]
  470.     if {[llength [glob -nocomplain [file join $lastdir sent???.wav]]] > 0} {
  471.       incr lastsession
  472.     }
  473.     set ::session $lastsession
  474.   } else {
  475.     set ::session 1
  476.   }
  477.   incr ::session -1
  478.   # Uncomment to make Speaker window pop-op immediately
  479.   #    NewSession
  480. }
  481.  
  482. set ::next(normal)   Next
  483. set ::next(disabled) ""
  484. set ::prev(normal)   Prev
  485. set ::prev(disabled) ""
  486.  
  487. proc ConfigNext { arg } {
  488.   .f1.ne configure -state $arg
  489.   bind . <Key-Right> $::next($arg)
  490. }
  491.  
  492. proc ConfigPrev { arg } {
  493.   .f1.pr configure -state $arg
  494.   bind . <Key-Left> $::prev($arg)
  495. }
  496.  
  497. proc NewSession {} {
  498.   set ::name ""
  499.   set ::age ""
  500.   set ::region ""
  501.   set ::gender Female
  502.   set ::other ""
  503.   incr ::session
  504.   set ::dir [format "sn%04d" $::session]
  505.   file mkdir $::dir
  506.   if {$::script != ""} {
  507.     set ::sentence 1
  508.     set ::prompt $::prompts($::sentence)
  509.     GetSentence
  510.     ConfigNext normal
  511.     ConfigPrev disabled
  512.   }
  513.   .menu.file entryconfigure "Open script..." -state normal
  514.   wm title . "Session $::session ($::script)"
  515.   set msg "Session $::session, sentence 1/$::imax"
  516.   update
  517.   OpenSpeakerDialog
  518.   #    while {$::name == ""} OpenSpeakerDialog
  519. }
  520.  
  521. # Create a list with all sessions so far
  522.  
  523. set dirlist [lsort [glob -type d -nocomplain {sn[0-9][0-9][0-9][0-9]}]]
  524. foreach sn $dirlist {
  525.   set n [string trimleft $sn sn0]
  526.   GetSpeakerInfo $n
  527.   set l $script
  528.   if {[string length $l] > 30} {
  529.     set l ...[string range $l [expr {[string length $l]-30}] end]
  530.   }
  531.   .db.f1.l1 insert end "$n: $::name, $::l"
  532. }
  533. set ::script ""
  534.  
  535.  
  536. # Uncomment these lines to open default script at start-up
  537. #set script tests2.txt
  538. #DoOpenScriptFile $script
  539.  
  540.  
  541. # Uncomment these line to use built-in script
  542. #set script "Built-in"
  543. #set sentlist [list \
  544. #    "This is sentence one" \
  545. #    "This is sentence two" \
  546. #    "This is sentence three" \
  547. #    "This is sentence four"
  548. #]
  549. #set i 0
  550. #foreach sent $sentlist { set prompts([incr i]) $sent }
  551. #set ::imax $i
  552. #.f1.bp configure -state normal
  553. #.f1.br configure -state normal
  554. #bind . <KeyRelease-Up> Record
  555. #bind . <KeyPress-Down> Stop
  556.  
  557.  
  558. # Use session number specified on command line, otherwise use next slot
  559.  
  560. if {[info exists argv] && $argv != ""} {
  561.   if {[string match "-b" [lindex $argv 0]]} {
  562.     OpenBrowser
  563.     set argv [lreplace $argv 0 0]
  564.   }
  565.   set session [lindex $argv end]
  566.   if {$session != ""} {
  567.     set ::dir [format "sn%04d" $session]
  568.     file mkdir $::dir
  569.   }
  570. } else {
  571.   FirstSession
  572. }
  573.  
  574. t record
  575. set op s
  576. Update
  577.