/usr/share/doc/tcl-snack-doc/examples/tcl/phonetogram.tcl is in tcl-snack-doc 2.2.10.20090623-dfsg-6.
This file is owned by root:root, with mode 0o755.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 | #!/bin/sh
# the next line restarts using wish \
exec wish8.5 "$0" "$@"
package require -exact snack 2.2
sound s
sound t
pack [frame .b] -side bottom
pack [button .b.r -bitmap snackRecord -command Start -fg red -width 40] \
-side left
pack [button .b.s -bitmap snackStop -command Stop -width 40] -side left
pack [button .b.p -bitmap snackPlay -command {Stop;s play} -width 40] \
-side left
pack [checkbutton .b.l -text "Erase dots" -variable erase] -side left
pack [frame .f] -side top -expand true -fill both
pack [canvas .f.c -bg white] -side left -expand true -fill both
.f.c create text 130 100 -text "Phonetogram plot (pitch and intensity)"
set samplePos 0
set erase 0
proc Stop {} {
s stop
after cancel Draw
}
proc Start {} {
Stop
s record
set ::samplePos 0
.f.c delete all
after 200 Draw
}
proc Draw {} {
if {$::erase} { .f.c delete all }
set length [s length]
while {$::samplePos < $length - 666-1*320} {
t copy s -start $::samplePos -end [expr {$::samplePos+665+1*320}]
t changed new
set pitch [lindex [lindex [t pitch -method esps] 2] 0]
set amplitude [t max]
if {$amplitude < 1} { set amplitude 1 }
set y [expr {[winfo height .f.c]*(2.0-log10($amplitude)/2.26)}]
set x [expr {[winfo width .f.c]*($pitch/300.0)}]
if {$pitch > 0.0} {
.f.c create oval [expr {$x-1}] [expr {$y-1}] [expr {$x+1}] [expr {$y+1}]
}
incr ::samplePos 160
}
after 50 Draw
if {[s length] > 320000} Stop
}
|