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 / xs.tcl < prev   
Encoding:
Text File  |  2001-10-22  |  131.1 KB  |  4,737 lines
  1. #!/bin/sh
  2. # the next line restarts using wish \
  3. exec wish8.3 "$0" "$@"
  4.  
  5. package require -exact snack 2.1
  6. # Try to load optional file format handlers
  7. catch { package require snacksphere }
  8. catch { package require snackogg }
  9. package require http
  10.  
  11. set debug 0
  12. snack::debug $debug
  13. snack::sound snd -debug $debug
  14. snack::sound cbs -debug $debug
  15.  
  16. set tcl_precision 7
  17. set f(prog) [info script]
  18. set f(labfile) ""
  19. set f(sndfile) ""
  20. set f(lpath)   ""
  21. set f(header)  ""
  22. set mexhome "~/snack/"
  23. catch {source $mexhome/ipa_tmh.tcl}
  24. set f(ipapath) $mexhome/ipa_xbm
  25. set local 0
  26. if $local {
  27.     set v(labfmt) TIMIT
  28.     set v(smpfmt) WAV
  29.     set v(ashost) ior.speech.kth.se
  30. } else {
  31.     set v(labfmt) TIMIT
  32.     set v(smpfmt) WAV
  33.     set v(ashost) localhost
  34. }
  35. set labels {}
  36. set undo {}
  37. set v(labchanged) 0
  38. set v(smpchanged) 0
  39. set v(width) 600
  40. set v(toth) 286
  41. set v(msg) "Press right mouse button for menu"
  42. set v(timeh) 20
  43. set v(yaxisw) 40
  44. set v(labelh) 20
  45. set v(psfilet) {tmp$N.ps}
  46. set v(psfile)  ""
  47. set v(vchan)   -1
  48. #set v(offset) 0
  49. #set v(zerolabs) 0
  50. set v(startsmp) 0
  51. set v(lastmoved) -1
  52. set v(p_version) 2.1
  53. set v(s_version) 2.1
  54. set v(plugins) {}
  55. set v(scroll) 1
  56. set v(rate) 16000
  57. set v(sfmt) Lin16
  58. set v(chan) 1
  59. set v(topfr) 8000
  60. set v(rp_sock) ""
  61. #set v(propflag) 0
  62. set v(pause) 0
  63. set v(recording) 1
  64. set v(activerec) 0
  65. set v(cmap) grey
  66. set v(grey) " "
  67. #set v(color1) {#000 #006 #00B #00F #03F #07F #0BF #0FF #0FB #0F7 \
  68.           #0F0 #3F0 #7F0 #BF0 #FF0 #FB0 #F70 #F30 #F00}
  69. set v(color1) {#000 #004 #006 #00A #00F \
  70.             #02F #04F #06F #08F #0AF #0CF #0FF #0FE \
  71.            #0FC #0FA #0F8 #0F6 #0F4 #0F2 #0F0 #2F0 \
  72.            #4F0 #6F0 #8F0 #AF0 #CF0 #FE0 #FC0 #FA0 \
  73.            #F80 #F60 #F40 #F20 #F00}
  74. set v(color2) {#FFF #BBF #77F #33F #00F #07F #0BF #0FF #0FB #0F7 \
  75.           #0F0 #3F0 #7F0 #BF0 #FF0 #FB0 #F70 #F30 #F00}
  76. set v(contrast) 0
  77. set v(brightness) 0
  78. set v(showspeg) 0
  79. set v(remspegh) 200
  80. set v(remote) 0
  81. set v(asport) 23654
  82. set v(handle) ""
  83. set v(s0) 0
  84.  
  85. set z(zoomwinh) 200
  86. set z(zoomwinw) 600
  87. set z(zoomwinx) 200
  88. set z(zoomwiny) 200
  89. set z(zoomwavh) 0
  90. set z(zoomwavw) 0
  91. set z(f) 1
  92.  
  93. set s(sectwinh) 400
  94. set s(sectwinw) 400
  95. set s(sectwinx) 200
  96. set s(sectwiny) 200
  97. set s(secth) 400
  98. set s(sectw) 400
  99. set s(rx) -1
  100.  
  101. proc SetDefaultVars {} {
  102.     global f v s local
  103.  
  104.     set v(waveh) 50
  105.     set v(spegh) 0
  106.     set v(scrw) 32767
  107.     set v(pps) 400
  108.     set v(opps) 400
  109.     set v(fftlen) 256
  110.     set v(winlen) 128
  111.     set v(anabw) 125
  112.     set v(preemph) 0.97
  113.     set v(ipa) 0
  114.     set v(autoload) 0
  115.     set v(ch) 0
  116.     set v(slink) 0
  117.     set v(mlink) 0
  118.     if {$::tcl_platform(platform) == "unix"} {
  119.     set v(printcmd)  {lpr $FILE}
  120.     set v(gvcmd)     {ghostview $FILE}
  121.     set v(psfilecmd) {cp -f _xspr$n.ps $v(psfile)}
  122.     if $local {
  123.         set v(pluginfiles) {~/snack/xsplug/dataplot.plg ~/snack/xsplug/generator.plg ~/snack/xsplug/transcribe.plg ~/snack/xsplug/cutter.plg ~/snack/xsplug/pitch.plg}
  124.     } else {
  125.         set v(pluginfiles) [glob -nocomplain *.plg]
  126.     }
  127. #    set v(browser) "netscape"
  128.     if {$::tcl_platform(os) == "HP-UX"} {
  129.         option add *font {Helvetica 10 bold}
  130.     } else {
  131.         option add *font {Helvetica 12 bold}
  132.     }
  133.     } else {
  134.     set v(printcmd)  {C:/gs/gs6.50/bin/gswin32 "-IC:\gs\gs6.50;C:\gs\gs6.50\fonts" -sDEVICE=laserjet -dNOPAUSE $FILE -c quit}
  135.     set v(gvcmd)     {C:/ghostgum/gsview/gsview32 $FILE}
  136.     set v(psfilecmd) {command.com /c copy _xspr$n.ps $v(psfile)}
  137.     if $local {
  138. #        set v(pluginfiles) {H:/tcl/mexd/dataplot.plg H:/tcl/mexd/generator.plg H:/tcl/mexd/pitch.plg}
  139.             set v(pluginfiles) {}
  140.     } else {
  141.         set v(pluginfiles) [glob -nocomplain *.plg]
  142.     }
  143. #    set v(browser) "c:/program files/netscape/communicator/program/netscape.exe"
  144.     }
  145.     set v(ipafmt) TMH
  146.     set v(labalign) w
  147.     set v(fg) black
  148.     set v(bg) [. cget -bg]
  149.     if [string match macintosh $::tcl_platform(platform)] {
  150.     set v(fillmark) 0
  151.     } else {
  152.     set v(fillmark) 1
  153.     }
  154.     set v(font)  {Courier 10}
  155.     set v(sfont) {Helvetica 8 bold}
  156.     set v(gridfspacing) 0
  157.     set v(gridtspacing) 0
  158.     set v(gridcolor) red
  159.     set v(cmap) grey
  160.     set v(showspeg) 0
  161.     set v(remspegh) 200
  162.     set v(linkfile) 0
  163.     set f(skip) 0
  164.     set f(byteOrder) ""
  165.     set f(ipath) ""
  166.     set f(ihttp) "http://www.speech.kth.se/~kare/ex1.wav"
  167.     #"http://www.speech.kth.se/cgi-bin/TransAll?this_is_an_example+am"
  168.  
  169.     set s(fftlen) 512
  170.     set s(anabw)  31.25
  171.     set s(ref)    -110.0
  172.     set s(range)  110.0
  173.     set s(wintype) Hamming
  174.     set s(atype) FFT
  175.     set s(lpcorder) 20
  176.  
  177.     if {[info exists snack::snackogg]} {
  178.       set ::ogg(nombr) 128000
  179.       set ::ogg(maxbr) -1
  180.       set ::ogg(minbr) -1
  181.       set ::ogg(com)   ""
  182.       set ::ogg(query) 1
  183.     }
  184. }
  185.  
  186. SetDefaultVars
  187. catch { source [file join ~ .xsrc] }
  188. catch { source [file join ~ .xsrf] }
  189.  
  190. snd config -rate $v(rate)
  191. snd config -encoding $v(sfmt)
  192. snd config -channels $v(chan)
  193.  
  194. set filt(f) [snack::filter map 0.0]
  195.  
  196. set echo(f) [snack::filter echo 0.6 0.6 30 0.4]
  197. set echo(n) 1
  198. set echo(drain) 1
  199. set echo(iGain) 60
  200. set echo(oGain) 60
  201.  
  202. set mix(f) [snack::filter map 0.0]
  203.  
  204. set amplify(f) [snack::filter map 1.0]
  205. set amplify(v) 100.0
  206. set amplify(db) 0
  207.  
  208. set normalize(f) [snack::filter map 1.0]
  209. set normalize(v) 100.0
  210. set normalize(db) 0
  211. set normalize(allEqual) 1
  212.  
  213. set remdc(f) [snack::filter iir -numerator "0.99 -0.99" -denominator "1 -0.99"]
  214.  
  215. set f(spath) $f(ipath)
  216. set f(http) $f(ihttp)
  217. set f(urlToken) ""
  218.  
  219. if {$v(p_version) != $v(s_version)} {
  220.      set v(msg) "Warning, you have saved settings from an older version of xs!"
  221.     SetDefaultVars
  222. }
  223.  
  224. # Put custom settings between the lines below
  225. # Custom settings start here
  226. # Custom settings end here
  227.  
  228. snack::menuInit
  229. snack::menuPane File
  230. snack::menuCommand File {Open...} GetOpenFileName
  231. snack::menuBind . o File {Open...}
  232. snack::menuCommand File {Get URL...} OpenGetURLWindow
  233. snack::menuCommand File Save Save
  234. snack::menuBind . s File Save
  235. snack::menuCommand File {Save As...} SaveAs
  236. snack::menuCommand File Close Close
  237. snack::menuSeparator File
  238. snack::menuCommand File Print... {Print .cf.fc.c -1}
  239. snack::menuCommand File Info {set v(msg) [InfoStr nopath]}
  240. snack::menuSeparator File
  241. if [info exists recentFiles] {
  242.     foreach e $recentFiles {
  243.     snack::menuCommand File $e [list OpenFiles $e]
  244.     }
  245.     snack::menuSeparator File
  246. }
  247. snack::menuCommand File Exit Exit
  248.  
  249. snack::menuPane Edit 0 ConfigEditMenu
  250. snack::menuCommand Edit Undo Undo
  251. snack::menuEntryOff Edit Undo
  252. snack::menuSeparator Edit
  253. snack::menuCommand Edit Cut Cut
  254. snack::menuBind . x Edit Cut
  255. snack::menuCommand Edit Copy Copy
  256. snack::menuBind . c Edit Copy
  257. snack::menuCommand Edit Paste Paste
  258. snack::menuBind . v Edit Paste
  259. snack::menuCommand Edit Crop Crop
  260. snack::menuCommand Edit {Mark All} MarkAll
  261. snack::menuCommand Edit {Zero Cross Adjust} ZeroXAdjust
  262.  
  263. set n [snack::menuPane Audio]
  264. bind $n <<MenuSelect>> { snack::mixer update }
  265. snack::menuCommand Audio {Play range} PlayMark
  266. snack::menuCommand Audio {Play All} PlayAll
  267. snack::menuBind . p Audio {Play All}
  268. snack::menuCommand Audio {Stop Play} StopPlay
  269. #snack::menuCommand Audio {Gain Control...} {snack::gainBox rp}
  270. snack::menuCommand Audio Mixer... snack::mixerDialog
  271. #if {[snack::mixer inputs] != ""} {
  272. #    snack::menuCascade Audio Input
  273. #    foreach jack [snack::mixer inputs] {
  274. #    snack::mixer input $jack v(in$jack)
  275. #    snack::menuCheck Input $jack v(in$jack)
  276. #    }
  277. #}
  278. #if {[snack::mixer outputs] != ""} {
  279. #    snack::menuCascade Audio Output
  280. #    foreach jack [snack::mixer outputs] {
  281. #    snack::mixer output $jack v(out$jack)
  282. #    snack::menuCheck Output $jack v(out$jack)
  283. #    }
  284. #}
  285. snack::menuCascade Audio {Audio Settings}
  286. snack::menuCascade {Audio Settings} {Set Sample Rate}
  287. set rateList [snack::audio rates]
  288. if {$rateList == ""} {
  289.     set rateList {11025 22050 44100}
  290. }
  291. foreach fr $rateList {
  292.     snack::menuRadio {Set Sample Rate} $fr v(rate) $fr SetRaw
  293. }
  294. snack::menuCascade {Audio Settings} {Set Encoding}
  295. foreach fo [snack::audio encodings] {
  296.     snack::menuRadio {Set Encoding} $fo v(sfmt) $fo SetRaw
  297. }
  298. snack::menuCascade {Audio Settings} {Set Channels}
  299. snack::menuRadio {Set Channels} Mono   v(chan) 1 SetRaw
  300. snack::menuRadio {Set Channels} Stereo v(chan) 2 SetRaw
  301.  
  302. snack::menuPane Transform 0 ConfigTransformMenu
  303. snack::menuCascade Transform Conversions
  304. snack::menuCascade Conversions {Convert Sample Rate}
  305. foreach fr $rateList {
  306.     snack::menuCommand {Convert Sample Rate} $fr "Convert {} $fr {}"
  307. }
  308. snack::menuCascade Conversions {Convert Encoding}
  309. foreach fo [snack::audio encodings] {
  310.     snack::menuCommand {Convert Encoding} $fo "Convert $fo {} {}"
  311. }
  312. snack::menuCascade Conversions {Convert Channels}
  313. snack::menuCommand {Convert Channels} Mono   "Convert {} {} Mono"
  314. snack::menuCommand {Convert Channels} Stereo "Convert {} {} Stereo"
  315. snack::menuCommand Transform Amplify... Amplify
  316. snack::menuCommand Transform Normalize... Normalize
  317. #snack::menuCommand Transform Normalize... Normalize
  318. snack::menuCommand Transform Echo... Echo
  319. snack::menuCommand Transform {Mix Channels...} MixChan
  320. snack::menuCommand Transform Invert Invert
  321. snack::menuCommand Transform Reverse Reverse
  322. snack::menuCommand Transform Silence Silence
  323. snack::menuCommand Transform {Remove DC} RemoveDC
  324.  
  325. snack::menuPane Tools
  326.  
  327. snack::menuPane Options 0 ConfigOptionsMenu
  328. snack::menuCommand Options Settings... Settings
  329. if {[info exists snack::snackogg]} {
  330.   snack::menuCommand Options "Ogg Vorbis..." [list OggSettings Close]
  331. }
  332. snack::menuCommand Options Plug-ins... Plugins
  333. snack::menuCascade Options {Label File Format}
  334. snack::menuRadio {Label File Format} TIMIT v(labfmt) TIMIT {Redraw quick}
  335. snack::menuRadio {Label File Format} HTK v(labfmt) HTK {Redraw quick}
  336. snack::menuRadio {Label File Format} WAVES v(labfmt) WAVES {Redraw quick}
  337. snack::menuRadio {Label File Format} MIX v(labfmt) MIX {Redraw quick}
  338. if $local {
  339.     snack::menuCascade Options {IPA Translation}
  340.     snack::menuRadio {IPA Translation} TMH v(ipafmt) TMH {source $mexhome/ipa_tmh.tcl;Redraw quick}
  341.     snack::menuRadio {IPA Translation} CMU v(ipafmt) CMU {source $mexhome/ipa_cmu.tcl;Redraw quick}
  342. }
  343. snack::menuCascade Options {Label Alignment}
  344. snack::menuRadio {Label Alignment} left v(labalign)   w {Redraw quick}
  345. snack::menuRadio {Label Alignment} center v(labalign) c {Redraw quick}
  346. snack::menuRadio {Label Alignment} right v(labalign)  e {Redraw quick}
  347. snack::menuCascade Options {View Channel}
  348. snack::menuRadio {View Channel} both v(vchan) -1 { Redraw;DrawZoom 1;DrawSect }
  349. snack::menuRadio {View Channel} left v(vchan) 0  { Redraw;DrawZoom 1;DrawSect }
  350. snack::menuRadio {View Channel} right v(vchan) 1 { Redraw;DrawZoom 1;DrawSect }
  351. snack::menuSeparator Options
  352. if $local {
  353.     snack::menuCheck Options {IPA Transcription} v(ipa) {Redraw quick}
  354. }
  355. snack::menuCheck Options {Record Button} v(recording) ToggleRecording
  356. snack::menuCheck Options {Show Spectrogram} v(showspeg) ToggleSpeg
  357. snack::menuCheck Options {Auto Load} v(autoload)
  358. snack::menuCheck Options {Cross Hairs} v(ch) DrawCrossHairs
  359. snack::menuCheck Options {Fill Between Marks} v(fillmark) {$c coords mfill -1 -1 -1 -1 ; Redraw quick}
  360. snack::menuCheck Options {Link to Disk File} v(linkfile) Link2File
  361. if {$tcl_platform(platform) == "unix"} {
  362.     snack::menuCheck Options {Link Scroll} v(slink)
  363.     snack::menuCheck Options {Link Marks} v(mlink)
  364. }
  365. #snack::menuCheck Options {Align x-axis/first label} v(offset) {Redraw quick}
  366. #snack::menuCheck Options {Show zero length labels} v(zerolabs) {Redraw quick}
  367. snack::menuSeparator Options
  368. snack::menuCommand Options {Set default options} {SetDefaultVars ; Redraw}
  369. snack::menuCommand Options {Save options} SaveSettings
  370.  
  371. snack::menuPane Window
  372. snack::menuCommand Window {New Window} NewWin
  373. snack::menuBind . n Window {New Window}
  374. snack::menuCommand Window Refresh Redraw
  375. snack::menuBind . r Window Refresh
  376. snack::menuCommand Window {Waveform Zoom} OpenZoomWindow
  377. snack::menuCommand Window {Spectrum Section} OpenSectWindow
  378. #snack::menuCommand Window {WaveSurfer} WS
  379.  
  380. snack::menuPane Help
  381. snack::menuCommand Help Version Version
  382. snack::menuCommand Help Manual  {Help http://www.speech.kth.se/snack/xs.html}
  383.  
  384. # Put custom menus between the lines below
  385. # Custom menus start here
  386. # Custom menus end here
  387.  
  388. #bind Menu <<MenuSelect>> {
  389. #    global v
  390. #    if {[catch {%W entrycget active -label} label]} {
  391. #    set label ""
  392. #    }
  393. #    set v(msg) $label
  394. #    update idletasks
  395. #}
  396.  
  397. if {$tcl_platform(platform) == "windows"} {
  398.     set border 1
  399. } else {
  400.     set border 0
  401. }
  402.  
  403. snack::createIcons
  404. pack [frame .tb -highlightthickness 1] -anchor w
  405. pack [button .tb.open -command GetOpenFileName -image snackOpen -highlightthickness 0 -border $border] -side left
  406.  
  407. pack [button .tb.save -command Save -image snackSave -highlightthickness 0 -border $border] -side left
  408. pack [button .tb.print -command {Print .cf.fc.c -1} -image snackPrint -highlightthickness 0 -border $border] -side left
  409.  
  410. pack [frame .tb.f1 -width 1 -height 20 -highlightth 1] -side left -padx 5
  411. pack [button .tb.cut -command Cut -image snackCut -highlightthickness 0 -border $border] -side left
  412. pack [button .tb.copy -command Copy -image snackCopy -highlightthickness 0 -border $border] -side left
  413. pack [button .tb.paste -command Paste -image snackPaste -highlightthickness 0 -border $border] -side left
  414.  
  415. pack [frame .tb.f2 -width 1 -height 20 -highlightth 1] -side left -padx 5
  416. pack [button .tb.undo -command Undo -image snackUndo -highlightthickness 0 -border $border -state disabled] -side left
  417.  
  418. pack [frame .tb.f3 -width 1 -height 20 -highlightth 1] -side left -padx 5
  419. pack [button .tb.play -command PlayMark -bitmap snackPlay -fg blue3 -highlightthickness 0 -border $border] -side left
  420. bind .tb.play <Enter> {SetMsg "Play mark"}
  421. pack [button .tb.pause -command PausePlay -bitmap snackPause -fg blue3 -highlightthickness 0 -border $border] -side left
  422. bind .tb.pause <Enter> {SetMsg "Pause"}
  423. pack [button .tb.stop -command StopPlay -bitmap snackStop -fg blue3 -highlightthickness 0 -border $border] -side left
  424. bind .tb.stop <Enter> {SetMsg "Stop"}
  425. pack [button .tb.rec -command Record -bitmap snackRecord -fg red -highlightthickness 0 -border $border] -side left
  426. bind .tb.rec <Enter> {SetMsg "Record"}
  427. #pack [button .tb.gain -command {snack::gainBox rp} -image snackGain -highlightthickness 0 -border $border] -side left
  428. pack [button .tb.gain -command snack::mixerDialog -image snackGain -highlightthickness 0 -border $border] -side left
  429. bind .tb.gain <Enter> {SetMsg "Open gain control panel"}
  430.  
  431. pack [frame .tb.f4 -width 1 -height 20 -highlightth 1] -side left -padx 5
  432. pack [button .tb.zoom -command OpenZoomWindow -image snackZoom -highlightthickness 0 -border $border] -side left
  433. bind .tb.zoom <Enter> {SetMsg "Open zoom window"}
  434.  
  435. frame .of
  436. pack [canvas .of.c -width $v(width) -height 30 -bg $v(bg)] -fill x -expand true
  437. pack [scrollbar .of.xscroll -orient horizontal -command ScrollCmd] -fill x -expand true
  438. bind .of.xscroll <ButtonPress-1> { set v(scroll) 1 }
  439. bind .of.xscroll <ButtonRelease-1> RePos
  440. bind .of.c <1> {OverPlay %x}
  441.  
  442. pack [ frame .bf] -side bottom -fill x
  443. entry .bf.lab -textvar v(msg) -width 1 -relief sunken -bd 1 -state disabled
  444. pack .bf.lab -side left -expand yes -fill x
  445.  
  446. set v(toth) [expr $v(waveh) + $v(spegh) + $v(timeh)+ $v(labelh)]
  447. pack [ frame .cf] -fill both -expand true
  448. pack [ frame .cf.fyc] -side left -anchor n
  449. canvas .cf.fyc.yc2 -height 0 -width $v(yaxisw) -highlightthickness 0
  450. pack [ canvas .cf.fyc.yc -width $v(yaxisw) -height $v(toth) -highlightthickness 0 -bg $v(bg)]
  451.  
  452. pack [ frame .cf.fc] -side left -fill both -expand true
  453. set c [canvas .cf.fc.c -width $v(width) -height $v(toth) -xscrollcommand [list .cf.fc.xscroll set] -yscrollcommand [list .cf.fc.yscroll set] -closeenough 5 -highlightthickness 0 -bg $v(bg)]
  454. scrollbar .cf.fc.xscroll -orient horizontal -command [list $c xview]
  455. scrollbar .cf.fc.yscroll -orient vertical -command yScroll
  456. #pack .cf.fc.xscroll -side bottom -fill x
  457. #pack .cf.fc.yscroll -side right -fill y
  458. pack $c -side left -fill both -expand true
  459.  
  460. proc yScroll {args} {
  461.     global c
  462.  
  463.     eval .cf.fyc.yc yview $args
  464.     eval $c yview $args
  465. }
  466.  
  467. $c create rect -1 -1 -1 -1 -tags mfill -fill yellow -stipple gray25
  468. $c create line -1 0 -1 $v(toth) -width 1 -tags [list mark [expr 0 * $v(rate)/$v(pps)] m1] -fill $v(fg)
  469. $c create line -1 0 -1 $v(toth) -width 1 -tags [list mark [expr 0 * $v(rate)/$v(pps)] m2] -fill $v(fg)
  470.  
  471. bind all <Control-l> {
  472.     set n 0
  473.     if {$labels == {}} return
  474.     while {[lindex [$c coords lab$n] 0] < [expr $v(width) * [lindex [$c xview] 0]]} { incr n }
  475.  
  476.     $c focus lab$n
  477.     focus $c
  478.     $c icursor lab$n 0
  479.     set i 0
  480.     SetMsg [lindex $labels $i] $i
  481.     SetUndo $labels
  482. }
  483.  
  484. $c bind text <Control-p> {
  485.     set __x [lindex [%W coords [%W focus]] 0]
  486.     set __y [lindex [%W coords [%W focus]] 1]
  487.     set __n [lindex [$c gettags [$c find closest $__x $__y]] 0]
  488.     PlayNthLab $__n
  489.     break
  490. }
  491.  
  492. $c bind text <Button-1> {
  493.     %W focus current
  494.     %W icursor current @[$c canvasx %x],[$c canvasy %y]
  495.     set i [lindex [$c gettags [%W focus]] 0]
  496.     SetMsg [lindex $labels $i] $i
  497.     SetUndo $labels
  498. }
  499.  
  500. event add <<Delete>> <Delete>
  501. catch {event add <<Delete>> <hpDeleteChar>}
  502.  
  503. $c bind text <<Delete>> {
  504.     if {[%W focus] != {}} {
  505.     %W dchars [%W focus] insert
  506.     SetLabelText [lindex [$c gettags [%W focus]] 0] [$c itemcget [%W focus] -text]
  507.     set i [lindex [$c gettags [%W focus]] 0]
  508.     SetMsg [lindex $labels $i] $i
  509.     }
  510. }
  511.  
  512. $c bind text <BackSpace> {
  513.     if {[%W focus] != {}} {
  514.     set _tmp [%W focus]
  515.     set _ind [expr [%W index $_tmp insert]-1]
  516.     if {$_ind >= 0} {
  517.         %W icursor $_tmp $_ind
  518.         %W dchars $_tmp insert
  519.         SetLabelText [lindex [$c gettags [%W focus]] 0] [$c itemcget [%W focus] -text]
  520.         set i [lindex [$c gettags [%W focus]] 0]
  521.         SetMsg [lindex $labels $i] $i
  522.     }
  523.     unset _tmp _ind
  524.     }
  525. }
  526.  
  527. $c bind text <Return> {
  528.     %W insert current insert ""
  529.     %W focus {}
  530. }
  531.  
  532. $c bind text <Enter> {
  533.     %W insert current insert ""
  534.     %W focus {}
  535. }
  536.  
  537. $c bind text <Control-Any-Key> { break }
  538.  
  539. $c bind text <Any-Key> {
  540.     if {[%W focus] != {}} {
  541.     %W insert [%W focus] insert %A
  542.     SetLabelText [lindex [$c gettags [%W focus]] 0] [$c itemcget [%W focus] -text]
  543.     set i [lindex [$c gettags [%W focus]] 0]
  544.     SetMsg [lindex $labels $i] $i
  545.     }
  546.     set v(labchanged) 1
  547. }
  548.  
  549. $c bind text <space> {
  550.     if {[%W focus] != {}} {
  551.     %W insert [%W focus] insert _
  552.     SetLabelText [lindex [$c gettags [%W focus]] 0] [$c itemcget [%W focus] -text]
  553.     set i [lindex [$c gettags [%W focus]] 0]
  554.     SetMsg [lindex $labels $i] $i
  555.     }
  556. }
  557.  
  558. $c bind text <Key-Right> {
  559.     if {[%W focus] != {}} {
  560.     set __index [%W index [%W focus] insert]
  561.     %W icursor [%W focus] [expr $__index + 1]
  562.     if {$__index == [%W index [%W focus] insert]} {
  563.             set __focus [expr [lindex [$c gettags [%W focus]] 0] + 1]
  564.         %W focus lab$__focus
  565.         %W icursor lab$__focus 0
  566.         set i [lindex [$c gettags [%W focus]] 0]
  567.         SetMsg [lindex $labels $i] $i
  568.         while {[expr $v(width) * [lindex [$c xview] 1] -10] < [lindex [%W coords [%W focus]] 0] && [lindex [$c xview] 1] < 1} {
  569.         $c xview scroll 1 unit
  570.         }
  571.     }
  572.     }
  573. }
  574.  
  575. $c bind text <Key-Left> {
  576.     if {[%W focus] != {}} {
  577.     set __index [%W index [%W focus] insert]
  578.     %W icursor [%W focus] [expr [%W index [%W focus] insert] - 1]
  579.     if {$__index == [%W index [%W focus] insert]} {
  580.             set __focus [expr [lindex [$c gettags [%W focus]] 0] - 1]
  581.         %W focus lab$__focus
  582.         %W icursor lab$__focus end
  583.         set i [lindex [$c gettags [%W focus]] 0]
  584.         SetMsg [lindex $labels $i] $i
  585.         while {[expr $v(width) * [lindex [$c xview] 0] +10] > [lindex [%W coords [%W focus]] 0] && [lindex [$c xview] 0] > 0} {
  586.         $c xview scroll -1 unit
  587.         }
  588.     }
  589.     }
  590. }
  591.  
  592. set _mx 1
  593. set _mb 0
  594. #$c bind bound  <B1-Motion> { MoveBoundary %x }
  595. $c bind bound  <ButtonRelease-1> { set _mb 0 ; Redraw quick }
  596. $c bind m1     <B1-Motion> { PutMarker m1 %x %y 1 }
  597. $c bind m2     <B1-Motion> { PutMarker m2 %x %y 1 }
  598. $c bind m1     <ButtonPress-1>   { set _mx 0 }
  599. $c bind m2     <ButtonPress-1>   { set _mx 0 }
  600. $c bind obj    <ButtonPress-1> { PutMarker m1 %x %y 1 }
  601. $c bind obj    <B1-Motion>     { PutMarker m2 %x %y 1 }
  602. $c bind m1     <ButtonRelease-1> { SendPutMarker m1 %x ; set _mx 0 }
  603. $c bind m2     <ButtonRelease-1> { SendPutMarker m2 %x ; set _mx 0 }
  604. $c bind bound  <Any-Enter> { BoundaryEnter %x }
  605. $c bind mark   <Any-Enter> { MarkerEnter %x }
  606. $c bind bound  <Any-Leave> { BoundaryLeave %x }
  607. $c bind mark   <Any-Leave> { MarkerLeave %x }
  608.  
  609. bind $c <ButtonPress-1>   {
  610.     if {%y > [expr $v(waveh)+$v(spegh)+$v(timeh)]} {
  611.     } else {
  612.     PutMarker m1 %x %y 1
  613.     SendPutMarker m1 %x
  614.     set _mx 1
  615.     }
  616. }
  617.  
  618. bind $c <ButtonRelease-1> {
  619.     set _mb 0
  620.     if {%y > [expr $v(waveh)+$v(spegh)+$v(timeh)]} {
  621.     focus %W
  622.     if {[%W find overlapping [expr [$c canvasx %x]-2] [expr [$c canvasy %y]-2] [expr [$c canvasx %x]+2] [expr [$c canvasy %y]+2]] == {}} {
  623.         %W focus {}
  624.     }
  625.     } else {
  626.     PutMarker m2 %x %y 1
  627.     SendPutMarker m2 %x
  628.     set _mx 1
  629.     }
  630. }
  631. bind $c <Delete> Cut
  632. bind $c <Motion> { PutCrossHairs %x %y }
  633. bind $c <Leave>  {
  634.     $c coords ch1 -1 -1 -1 -1
  635.     $c coords ch2 -1 -1 -1 -1
  636. }
  637.  
  638. if [string match macintosh $::tcl_platform(platform)] {
  639.  bind $c <Control-1> { PopUpMenu %X %Y %x %y }
  640. } else {
  641.  bind $c <3> { PopUpMenu %X %Y %x %y }
  642. }
  643.  
  644. bind .cf.fc.xscroll <ButtonRelease-1> SendXScroll
  645. bind .bf.lab <Any-KeyRelease> { InputFromMsgLine %K }
  646. bind all <Control-c> Exit
  647. wm protocol . WM_DELETE_WINDOW Exit
  648. bind .cf.fc.c <Configure> { if {"%W" == ".cf.fc.c"} Reconf }
  649. bind $c <F1> { PlayToCursor %x }
  650. bind $c <2>  { PlayToCursor %x }
  651. focus $c
  652.  
  653. proc RecentFile fn {
  654.     global recentFiles
  655.  
  656.     if {$fn == ""} return
  657.     if [info exists recentFiles] {
  658.     foreach e $recentFiles {
  659.         snack::menuDelete File $e
  660.     }
  661.     snack::menuDeleteByIndex File 10
  662.     } else {
  663.     set recentFiles {}
  664.     }
  665.     snack::menuDelete File Exit
  666.     set index [lsearch -exact $recentFiles $fn]
  667.     if {$index != -1} {
  668.     set recentFiles [lreplace $recentFiles $index $index]
  669.     }
  670.     set recentFiles [linsert $recentFiles 0 $fn]
  671.     if {[llength $recentFiles] > 6} {
  672.     set recentFiles [lreplace $recentFiles 6 end]
  673.     }
  674.     foreach e $recentFiles {
  675.     snack::menuCommand File $e [list OpenFiles $e]
  676.     }
  677.     snack::menuSeparator File
  678.     snack::menuCommand File Exit Exit
  679.     if [catch {open [file join ~ .xsrf] w} out] {
  680.     } else {
  681.     puts $out "set recentFiles \[list $recentFiles\]"
  682.     close $out
  683.     }
  684. }
  685.  
  686. set extTypes  [list {TIMIT .phn} {MIX .smp.mix} {HTK .lab} {WAVES .lab}]
  687. set loadTypes [list {{MIX Files} {.mix}} {{HTK Label Files} {.lab}} {{TIMIT Label Files} {.phn}} {{TIMIT Label Files} {.wrd}} {{Waves Label Files} {.lab}}]
  688. set loadKeys [list MIX HTK TIMIT WAVES]
  689. set saveTypes {}
  690. set saveKeys  {}
  691.  
  692. if {[info exists snack::snacksphere]} {
  693.     lappend extTypes {SPHERE .sph} {SPHERE .wav}
  694.     lappend loadTypes {{SPHERE Files} {.sph}} {{SPHERE Files} {.wav}}
  695.     lappend loadKeys SPHERE SPHERE
  696. }
  697. if {[info exists snack::snackogg]} {
  698.   lappend extTypes  {OGG .ogg}
  699.   lappend loadTypes {{Ogg Vorbis Files} {.ogg}}
  700.   lappend loadKeys  OGG
  701.   lappend saveTypes {{Ogg Vorbis Files} {.ogg}}
  702.   lappend saveKeys  OGG
  703.   
  704.   proc OggSettings {text} {
  705.     set w .ogg
  706.     catch {destroy $w}
  707.     toplevel $w
  708.     wm title $w "Ogg Vorbis Settings"
  709.  
  710.     pack [frame $w.f1] -anchor w
  711.     pack [label $w.f1.l -text "Nominal bitrate:" -widt 16 -anchor w] -side left
  712.     pack [entry $w.f1.e -textvar ::ogg(nombr) -wi 7] -side left
  713.  
  714.     pack [frame $w.f2] -anchor w
  715.     pack [label $w.f2.l -text "Max bitrate:" -width 16 -anchor w] -side left
  716.     pack [entry $w.f2.e -textvar ::ogg(maxbr) -wi 7] -side left
  717.  
  718.     pack [frame $w.f3] -anchor w
  719.     pack [label $w.f3.l -text "Min bitrate:" -width 16 -anchor w] -side left
  720.     pack [entry $w.f3.e -textvar ::ogg(minbr) -wi 7] -side left
  721.     
  722.     pack [frame $w.f4] -anchor w
  723.     pack [label $w.f4.l -text "Comment:" -width 16 -anchor w] -side left
  724.     pack [entry $w.f4.e -textvar ::ogg(com) -wi 40] -side left
  725.  
  726.     pack [frame $w.f5] -anchor w
  727.     pack [checkbutton $w.f5.b -text "Query settings before saving" \
  728.     -variable ::ogg(query) -anchor w] -side left
  729.  
  730.     pack [frame $w.fb] -side bottom -fill x
  731.     pack [button $w.fb.cb -text $text -command "destroy $w"] -side top
  732.   }
  733. }
  734.  
  735. snack::addExtTypes $extTypes
  736. snack::addLoadTypes $loadTypes $loadKeys
  737.  
  738. proc GetOpenFileName {} {
  739.     global f v
  740.  
  741.     if {$v(smpchanged) || $v(labchanged)} {
  742.     if {[tk_messageBox -message "You have unsaved changes.\n Do you \
  743.         really want to close?" -type yesno \
  744.         -icon question] == "no"} return
  745.     }
  746.  
  747.     set gotfn [snack::getOpenFile -initialdir $f(spath) \
  748.         -initialfile $f(sndfile) -format $v(smpfmt)]
  749.  
  750.     # Ugly hack for Tk8.0
  751.     if {$gotfn != ""} {
  752.     set tmp [file split $gotfn]
  753.     if {[lindex $tmp 0] == [lindex $tmp 1]} {
  754.         set tmp [lreplace $tmp 0 0]
  755.         set gotfn [eval file join $tmp]
  756.     }
  757.     }
  758.     update
  759.     if [string compare $gotfn ""] {
  760.     OpenFiles $gotfn
  761.     }
  762. }
  763.  
  764. proc GetSaveFileName {title} {
  765.     global f v labels
  766.  
  767.     if {$labels != {} && [string compare $title "Save sample file"] != 0} {  
  768.     switch $v(labfmt) {
  769.         MIX {
  770.           lappend ::saveTypes {{MIX Files} {.mix}}
  771.           lappend ::saveKeys  MIX
  772.         }
  773.         HTK {
  774.           lappend ::saveTypes {{HTK Label Files} {.lab}}
  775.           lappend ::saveKeys  HTK
  776.         }
  777.         TIMIT {
  778.           lappend ::saveTypes {{TIMIT Label Files} {.phn}} {{TIMIT Label Files} {.wrd}}
  779.           lappend ::saveKeys  TIMIT
  780.         }
  781.         WAVES {
  782.           lappend ::saveTypes {{Waves Label Files} {.lab}}
  783.           lappend ::saveKeys  WAVES
  784.         }
  785.         default
  786.     }
  787.     snack::addSaveTypes $::saveTypes $::saveKeys
  788.  
  789.     set gotfn [snack::getSaveFile -initialdir $f(lpath) -initialfile $f(labfile) -format $v(labfmt) -title $title]
  790.  } else {
  791.     snack::addSaveTypes $::saveTypes $::saveKeys
  792.  
  793.     set gotfn [snack::getSaveFile -initialdir $f(spath) -initialfile $f(sndfile) -format $v(smpfmt) -title $title]
  794.     }
  795. #    set tmp [string trimright $f(lpath) /].
  796. #    if {[regexp $tmp $gotfn] == 1 && $tmp != "."} {
  797. #    return ""
  798. #    }
  799.     update
  800.     return $gotfn
  801. }
  802.  
  803. proc SaveAs {} {
  804.     set gotfn [GetSaveFileName ""]
  805.     if {[string compare $gotfn ""] != 0} {
  806.     SaveFile $gotfn
  807.     }
  808. }
  809.  
  810. proc Save {} {
  811.     global f v
  812.  
  813.     set fn $f(spath)$f(sndfile)
  814.     if {[string compare $f(spath)$f(sndfile) ""] == 0} {
  815.     set fn [GetSaveFileName "Save sample file"]
  816.     }
  817.     if {$fn != "" && $v(smpchanged)} {
  818.     SaveFile $fn
  819.     }
  820.     if $v(labchanged) {
  821.     set fn $f(lpath)$f(labfile)
  822.     if {[string compare $f(lpath)$f(labfile) ""] == 0} {
  823.         set fn [GetSaveFileName "Save label file"]
  824.     }
  825.     if {$fn != ""} {
  826.         SaveFile $fn
  827.     }
  828.     }
  829. }
  830.  
  831. proc SaveFile {{fn ""}} {
  832.   global f v labels
  833.  
  834.   SetCursor watch
  835.   set strip_fn [lindex [file split [file rootname $fn]] end]
  836.   set ext  [file extension $fn]
  837.   if [string match macintosh $::tcl_platform(platform)] {
  838.     set path [file dirname $fn]:
  839.   } else {
  840.     set path [file dirname $fn]/
  841.   }
  842.   if {$path == "./"} { set path ""}
  843.   if {![IsLabelFile $fn]} {
  844.     if {[info exists snack::snackogg]} {
  845.       if {$::ogg(query) && [string match -nocase .ogg $ext]} {
  846.     OggSettings Continue
  847.     tkwait window .ogg
  848.       }
  849.       if [catch {snd write $fn -progress snack::progressCallback \
  850.       -nominalbitrate $::ogg(nombr) -maxbitrate $::ogg(maxbr) \
  851.       -minbitrate $::ogg(minbr) -comment $::ogg(com)} msg] {
  852.     SetMsg "Save cancelled: $msg"
  853.       }
  854.     } else {
  855.       if [catch {snd write $fn -progress snack::progressCallback} msg] {
  856.     SetMsg "Save cancelled: $msg"
  857.       }
  858.     }
  859.     if {$v(linkfile)} {
  860.     snd configure -file $fn
  861.     }
  862.     set v(smpchanged) 0
  863.     wm title . "xs: $fn"
  864.     set f(spath) $path
  865.     set f(sndfile) $strip_fn$ext
  866.   } elseif {$labels != {}} {
  867.     SaveLabelFile $labels $fn
  868.     set v(labchanged) 0
  869.     wm title . "xs: $f(spath)$f(sndfile) - $fn"
  870.     set f(lpath) $path
  871.     set f(labfile) $strip_fn$ext
  872.   }
  873.   SetCursor ""
  874. }
  875.  
  876. proc IsLabelFile {fn} {
  877.     set ext [file extension $fn]
  878.     if {$ext == ".lab"} { return 1 }
  879.     if {$ext == ".mix"} { return 1 }
  880.     if {$ext == ".phn"} { return 1 }
  881.     if {$ext == ".wrd"} { return 1 }
  882.     return 0
  883. }
  884.  
  885. proc OpenFiles {fn} {
  886.     global c labels v f
  887.  
  888.  
  889.     if {![file readable $fn]} {
  890.     tk_messageBox -icon warning -type ok -message "No such file: $fn"
  891.     return
  892.     }
  893.     SetCursor watch
  894.     set strip_fn [lindex [file split [file rootname $fn]] end]
  895.     set ext  [file extension $fn]
  896.     if [string match macintosh $::tcl_platform(platform)] {
  897.     set path [file dirname $fn]:
  898.     } else {
  899.     set path [file dirname $fn]/
  900.     }
  901.     if {$path == "./"} { set path ""}
  902.  
  903.     if [IsLabelFile $fn] {
  904.     set type "lab"
  905.     set f(lpath) $path
  906.     } else {
  907.     set type "smp"
  908.     set f(spath) $path
  909.     }
  910.  
  911.     switch $ext {
  912.     .mix {
  913.         set f(labfile) "$strip_fn.mix"
  914.         set v(labfmt) MIX
  915.         if $v(autoload) {
  916.         set f(sndfile) "$strip_fn"
  917.         if {$f(spath) == ""} { set f(spath) $f(lpath) }
  918.         if {[file exists $f(spath)$f(sndfile)] == 0} {
  919.             set f(sndfile) "$strip_fn.smp"
  920.         }
  921.         }
  922.     }
  923.     .lab {
  924.         set f(labfile) "$strip_fn.lab"
  925.         if {$v(smpfmt) == "SD"} {
  926.         set v(labfmt) WAVES
  927.         set v(labalign) e
  928.         if $v(autoload) {
  929.             set f(sndfile) "$strip_fn.sd"
  930.             if {$f(spath) == ""} { set f(spath) $f(lpath) }
  931.         }
  932.         } else {
  933.         set v(labfmt) HTK
  934.         if $v(autoload) {
  935.             set f(sndfile) "$strip_fn.smp"
  936.             if {$f(spath) == ""} { set f(spath) $f(lpath) }
  937.         }
  938.         }
  939.     }
  940.     .phn {
  941.         set f(labfile) "$strip_fn.phn"
  942.         set v(labfmt) TIMIT
  943.         if $v(autoload) {
  944.         set f(sndfile) "$strip_fn.wav"
  945.         if {$f(spath) == ""} { set f(spath) $f(lpath) }
  946.         }
  947.     }
  948.     .wrd {
  949.         set f(labfile) "$strip_fn.wrd"
  950.         set v(labfmt) TIMIT
  951.         if $v(autoload) {
  952.         set f(sndfile) "$strip_fn.wav"
  953.         if {$f(spath) == ""} { set f(spath) $f(lpath) }
  954.         }
  955.     }
  956.     .smp {
  957.         set f(sndfile) "$strip_fn.smp"
  958.         set v(labfmt) MIX
  959.         if $v(autoload) {
  960.         set f(labfile) "$strip_fn.smp.mix"
  961.         if {$f(lpath) == ""} { set f(lpath) $f(spath) }
  962.         if {[file exists $f(lpath)$f(labfile)] == 0} {
  963.             set f(labfile) "$strip_fn.mix"
  964.         }
  965.         }
  966.     }
  967.     .wav {
  968.         set f(sndfile) "$strip_fn.wav"
  969.         set v(labfmt) TIMIT
  970.         if $v(autoload) {
  971.         set f(labfile) "$strip_fn.phn"
  972.         if {$f(lpath) == ""} { set f(lpath) $f(spath) }
  973.         }
  974.     }
  975.     .sd {
  976.         set f(sndfile) "$strip_fn.sd"
  977.         set v(labfmt) WAVES
  978.         if $v(autoload) {
  979.         set f(labfile) "$strip_fn.lab"
  980.         if {$f(lpath) == ""} { set f(lpath) $f(spath) }
  981.         }
  982.     }
  983.     .bin {
  984.         set f(sndfile) "$strip_fn.bin"
  985.         set v(labfmt) HTK
  986.         if $v(autoload) {
  987.         set f(labfile) "$strip_fn.lab"
  988.         if {$f(lpath) == ""} { set f(lpath) $f(spath) }
  989.         }
  990.     }
  991.     default {
  992.         if {$type == "smp"} {
  993.         set f(sndfile) "$strip_fn$ext"
  994.         if $v(autoload) {
  995.             set f(labfile) "$strip_fn$ext.mix"
  996.             set v(labfmt) MIX
  997.             if {$f(lpath) == ""} { set f(lpath) $f(spath) }
  998.         }
  999.         } else {
  1000.         set f(labfile) "$strip_fn$ext"
  1001.         if $v(autoload) {
  1002.             set f(sndfile) "$strip_fn.smp"
  1003.             if {$f(spath) == ""} { set f(spath) $f(lpath) }
  1004.         }
  1005.         }
  1006.     }
  1007.     }
  1008.  
  1009.     if {($v(autoload) == 1) || ($type == "smp")} {
  1010.     $c delete wave speg
  1011.     .of.c delete overwave
  1012.     catch {.sect.c delete sect}
  1013.     StopPlay
  1014.  
  1015.     set f(byteOrder) [snd cget -byteorder]
  1016.     set tmps [snack::sound -debug $::debug]
  1017.     set ffmt [$tmps read $f(spath)$f(sndfile) -end 1 -guessproperties 1]
  1018.     if {$ffmt == "RAW"} {
  1019.         set v(rate)      [$tmps cget -rate]
  1020.         set v(sfmt)      [$tmps cget -encoding]
  1021.         set v(chan)      [$tmps cget -channels]
  1022.         set f(byteOrder) [$tmps cget -byteorder]
  1023.         if {[InterpretRawDialog] == "cancel"} {
  1024.         $tmps destroy
  1025.         SetCursor ""
  1026.         return
  1027.         }
  1028.     }
  1029.     $tmps destroy
  1030.     if {$v(linkfile)} {
  1031.         if [catch {snd configure -file $f(spath)$f(sndfile) \
  1032.             -skip $f(skip) -byteorder $f(byteOrder) \
  1033.             -rate $v(rate) -encoding $v(sfmt) -channels $v(chan) \
  1034.                  } ret] {
  1035.          SetMsg "$ret"
  1036.          return
  1037.          }
  1038.          set v(smpfmt) [lindex [snd info] 6]
  1039.     } else {
  1040.         if [catch {set v(smpfmt) [snd read $f(spath)$f(sndfile) \
  1041.             -skip $f(skip) -byteorder $f(byteOrder) \
  1042.             -rate $v(rate) -encoding $v(sfmt) -channels $v(chan) \
  1043.             -progress snack::progressCallback]} ret] {
  1044.         SetMsg "$ret"
  1045.         return
  1046.         }
  1047.     }
  1048.     set v(rate) [snd cget -rate]
  1049.     set v(sfmt) [snd cget -encoding]
  1050.     set v(chan) [snd cget -channels]
  1051.     set v(startsmp) 0
  1052.     if {[snd cget -channels] == 1} {
  1053.         set v(vchan) -1
  1054.     }
  1055.     set v(smpchanged) 0
  1056.     .tb.undo config -state disabled
  1057.     if {![regexp $v(rate) [snack::audio rates]]} {
  1058.         tk_messageBox -icon warning -type ok -message "You need to \
  1059.             convert this sound\nif you want to play it"
  1060.     }
  1061.     }
  1062.     if {($v(autoload) == 1) || ($type == "lab")} {
  1063.     set labels [OpenLabelFile $f(lpath)$f(labfile)]
  1064.     if {$labels == {}} { set f(labfile) "" }
  1065.     }
  1066.     if {$labels == {}} {
  1067.     wm title . "xs: $f(spath)$f(sndfile)"
  1068.     } else {
  1069.     wm title . "xs: $f(spath)$f(sndfile) - $f(lpath)$f(labfile)"
  1070.     }
  1071.  
  1072.     if {[snd length -unit seconds] > 50 && $v(pps) > 100} {
  1073.     set v(pps) [expr $v(pps)/10]
  1074.     }
  1075.     if {[snd length -unit seconds] < 50 && $v(pps) < 100} {
  1076.     set v(pps) [expr $v(pps)*10]
  1077.     }
  1078.     wm geometry . {}
  1079.     Redraw
  1080.     event generate .cf.fc.c <Configure>
  1081.     SetMsg [InfoStr nopath]
  1082. #    MarkAll
  1083.     RecentFile $f(spath)$f(sndfile)
  1084. }
  1085.  
  1086. proc InterpretRawDialog {} {
  1087.     global f v
  1088.  
  1089.     set w .rawDialog
  1090.     toplevel $w -class Dialog
  1091.     frame $w.q
  1092.     pack $w.q -expand 1 -fill both -side top
  1093.     pack [frame $w.q.f1] -side left -anchor nw -padx 3m -pady 2m
  1094.     pack [frame $w.q.f2] -side left -anchor nw -padx 3m -pady 2m
  1095.     pack [frame $w.q.f3] -side left -anchor nw -padx 3m -pady 2m
  1096.     pack [frame $w.q.f4] -side left -anchor nw -padx 3m -pady 2m
  1097.     pack [label $w.q.f1.l -text "Sample Rate"]
  1098.     foreach e [snack::audio rates] {
  1099.     pack [radiobutton $w.q.f1.r$e -text $e -val $e -var ::v(rate)]\
  1100.         -anchor w
  1101.     }
  1102.     pack [label $w.q.f2.l -text "Sample Encoding"]
  1103.     foreach e [snack::audio encodings] {
  1104.     pack [radiobutton $w.q.f2.r$e -text $e -val $e -var ::v(sfmt)]\
  1105.         -anchor w
  1106.     }
  1107.     pack [label $w.q.f3.l -text Channels]
  1108.     pack [radiobutton $w.q.f3.r1 -text Mono -val 1 -var ::v(chan)] -anchor w
  1109.     pack [radiobutton $w.q.f3.r2 -text Stereo -val 2 -var ::v(chan)] -anchor w
  1110.     pack [radiobutton $w.q.f3.r4 -text 4 -val 4 -var ::v(chan)] -anchor w
  1111.     pack [entry $w.q.f3.e -textvariable ::v(chan) -width 3] -anchor w
  1112.     pack [label $w.q.f4.l -text "Byte Order"]
  1113.     pack [radiobutton $w.q.f4.ri -text "Little Endian\n(Intel)" \
  1114.         -value littleEndian -var ::f(byteOrder)] -anchor w
  1115.     pack [radiobutton $w.q.f4.rm -text "Big Endian\n(Motorola)" \
  1116.         -value bigEndian -var ::f(byteOrder)] -anchor w
  1117.     pack [label $w.q.f4.l2 -text "\nRead Offset (bytes)"]
  1118.     pack [entry $w.q.f4.e -textvar f(skip) -wi 6]
  1119.     snack::makeDialogBox $w -title "Interpret Raw File As" -type okcancel \
  1120.     -default ok
  1121. }
  1122.  
  1123. proc Link2File {} {
  1124.     global f v
  1125.  
  1126.     StopPlay
  1127.     if {$v(smpchanged)} {
  1128.     if {[tk_messageBox -message "You have unsaved changes.\n Do you \
  1129.         really want to loose them?" -type yesno \
  1130.         -icon question] == "no"} return
  1131.     }
  1132.     set v(smpchanged) 0
  1133.     if {$v(linkfile)} {
  1134.     .of.c delete overwave
  1135.     catch {.sect.c delete sect}
  1136.     if {$f(sndfile) == ""} {
  1137.         snd configure -file _xs[pid].wav
  1138.     } else {
  1139.         snd configure -file $f(spath)$f(sndfile)
  1140.     }
  1141.     cbs configure -file ""
  1142.     } else {
  1143.     if {$f(sndfile) == ""} {
  1144.         snd config -load ""
  1145.     } else {
  1146.         snd config -load $f(spath)$f(sndfile)
  1147.     }
  1148.     cbs config -load ""
  1149.     }
  1150. }
  1151.  
  1152. proc ConfigEditMenu {} {
  1153.     global v
  1154.  
  1155.     if {$v(linkfile)} {
  1156.     snack::menuEntryOff Edit Cut
  1157.     snack::menuEntryOff Edit Copy
  1158.     snack::menuEntryOff Edit Paste
  1159.     snack::menuEntryOff Edit Crop
  1160.     } else {
  1161.     snack::menuEntryOn Edit Cut
  1162.     snack::menuEntryOn Edit Copy
  1163.     snack::menuEntryOn Edit Paste
  1164.     snack::menuEntryOn Edit Crop
  1165.     }
  1166.     if {$v(smpchanged)} {
  1167.     snack::menuEntryOn Edit Undo
  1168.     } else {
  1169.     snack::menuEntryOff Edit Undo
  1170.     }
  1171. }
  1172.  
  1173. proc ConfigTransformMenu {} {
  1174.     global v
  1175.  
  1176.     if {$v(linkfile)} {
  1177.     snack::menuEntryOff Transform Conversions
  1178.     snack::menuEntryOff Transform Amplify...
  1179.     snack::menuEntryOff Transform Normalize...
  1180.     snack::menuEntryOff Transform Echo...
  1181.     snack::menuEntryOff Transform {Mix Channels...}
  1182.     snack::menuEntryOff Transform Invert
  1183.     snack::menuEntryOff Transform Reverse
  1184.     snack::menuEntryOff Transform Silence
  1185.     snack::menuEntryOff Transform {Remove DC}
  1186.     } else {
  1187.     snack::menuEntryOn Transform Conversions
  1188.     snack::menuEntryOn Transform Amplify...
  1189.     snack::menuEntryOn Transform Normalize...
  1190.     snack::menuEntryOn Transform Echo...
  1191.     snack::menuEntryOn Transform {Mix Channels...}
  1192.     snack::menuEntryOn Transform Invert
  1193.     snack::menuEntryOn Transform Reverse
  1194.     snack::menuEntryOn Transform Silence
  1195.     snack::menuEntryOn Transform {Remove DC}
  1196.     }
  1197.     if {[snd cget -channels] == 1} {
  1198.     snack::menuEntryOff Transform {Mix Channels...}
  1199.     }
  1200. }
  1201.  
  1202. proc ConfigOptionsMenu {} {
  1203.     global v
  1204.     
  1205.     if {[snd cget -channels] == 1} {
  1206.     snack::menuEntryOff Options {View Channel}
  1207.     } else {
  1208.     snack::menuEntryOn Options {View Channel}
  1209.     }
  1210. }
  1211.  
  1212. proc OpenLabelFile {fn} {
  1213.     global f v undo
  1214.  
  1215.     if [catch {open $fn} in] {
  1216.     SetMsg $in
  1217.     return {}
  1218.     } else {
  1219.     if [catch {set labelfile [read $in]}] { return {} }
  1220.     set l {}
  1221.     set undo {}
  1222.     set v(labchanged) 0
  1223.     .tb.undo config -state disabled
  1224.     close $in
  1225.     switch $v(labfmt) {
  1226.         TIMIT -
  1227.         HTK {
  1228.         foreach row [split $labelfile \n] {
  1229.             set rest ""
  1230.             if {[scan $row {%d %d %s %[^º]} start stop label rest] >= 3} {
  1231.             lappend l "$start\n$stop\n$label\n$rest"
  1232.             }
  1233.         }
  1234.         }
  1235.         MIX {
  1236.         set f(header) ""
  1237.         set getHead 1
  1238.         foreach row [split $labelfile \n] {
  1239.             if [string match FR* $row] {
  1240.             set getHead 0
  1241.             set rest ""
  1242.             if {[scan $row {%s %d %s %[^º]} junk start label rest] >= 3} {
  1243.                 lappend l "$start\n$label\n$rest"
  1244.             }
  1245.             } else {
  1246.             if {$getHead == 1} {
  1247.                 set f(header) [lappend f(header) $row]
  1248.             }
  1249.             }
  1250.         }
  1251.         }
  1252.         WAVES {
  1253.         set f(header) ""
  1254.         set getHead 1
  1255.         foreach row [split $labelfile \n] {
  1256.             if {$getHead == 1} {
  1257.             set f(header) [lappend f(header) $row]
  1258.             if [string match # $row] { set getHead 0 }
  1259.             continue
  1260.             }
  1261.             set rest ""
  1262.             if {[scan $row {%f %d %s %[^º]} end color label rest] >= 3} {
  1263.             lappend l "$end\n$color\n$label\n$rest"
  1264.             }
  1265.         }
  1266.         }
  1267.     }
  1268.     }
  1269.     return $l
  1270. }
  1271.  
  1272. proc SaveLabelFile {labels fn} {
  1273.     global f v
  1274.  
  1275.     if {$fn == "" || [regexp /$ $fn] == 1 || $labels == {}} return
  1276.     set f(labfile) [file tail $fn]
  1277.     if [string match macintosh $::tcl_platform(platform)] {
  1278.     set f(lpath) [file dirname $fn]:
  1279.     } else {
  1280.     set f(lpath) [file dirname $fn]/
  1281.     }
  1282.     catch {file copy $fn $fn~}
  1283.     if [catch {open $fn w} out] {
  1284.     SetMsg $out
  1285.         return
  1286.     } else {
  1287.     set v(labchanged) 0
  1288.     fconfigure $out -translation {auto lf}
  1289.     switch $v(labfmt) {
  1290.         TIMIT -
  1291.         HTK {
  1292.         foreach row $labels {
  1293.             puts $out [join $row " "]
  1294.         }
  1295.         }
  1296.         MIX {
  1297.         if {$f(header) != ""} {
  1298.             puts $out [join $f(header) \n]
  1299.         } else {
  1300.             puts $out "NOLABELS\nTEXT: \nCT 1"
  1301.         }
  1302.         foreach row $labels {
  1303.             set t4 [split $row \n]
  1304.             set lab [lindex $t4 1]
  1305.             if {[string compare $lab "OK"] == 0} {
  1306.             } elseif {[string index $lab 0] == "$"} {
  1307.             } elseif {[string index $lab 0] == "#"} {
  1308.             } else {
  1309.             set t4 [lreplace $t4 1 1 "\$$lab"]
  1310.             }
  1311.             set t5 [join $t4 "\t"]
  1312.             puts $out "FR\t$t5"
  1313.         }
  1314.         }
  1315.         WAVES {
  1316.         if {$f(header) != ""} {
  1317.             puts $out [join $f(header) \n]
  1318.         } else {
  1319.             set name [lindex [file split [file rootname $fn]] end]
  1320.             set date [clock format [clock seconds] -format "%a %b %d %H:%M:%S %Y"]
  1321.             puts $out "signal $name"
  1322.             puts $out "type 0\ncolor 121"
  1323.             puts $out "comment created using xs $date"
  1324.             puts $out "font -misc-*-bold-*-*-*-15-*-*-*-*-*-*-*"
  1325.             puts $out "separator ;\nnfields 1\n#"
  1326.         }
  1327.         foreach row $labels {
  1328.             set rest ""
  1329.             scan $row {%f %d %s %[^º]} end color label rest
  1330.             puts $out [format "    %.6f  %d %s %s" $end $color $label $rest]
  1331.         }
  1332.         }
  1333.     }
  1334.     close $out
  1335.     }
  1336.     SetMsg "Saved: $fn"
  1337. }
  1338.  
  1339. proc SaveMark {} {
  1340.     global f v labels
  1341.  
  1342.     set start [Marker2Sample m1]
  1343.     set end   [Marker2Sample m2]
  1344.  
  1345.     set gotfn [snack::getSaveFile -initialdir $f(spath) -format $v(smpfmt)]
  1346.  
  1347.     if [string compare $gotfn ""] {
  1348.     SetMsg "Saving range: $start $end"
  1349.  
  1350.     set ext [file extension $gotfn]
  1351.     set root [file rootname $gotfn]
  1352.     if {$root == $gotfn} {
  1353.         set fn $root[file extension $f(sndfile)]
  1354.     } else {
  1355.         set fn $gotfn
  1356.     }
  1357.     if [catch {snd write $fn -start $start -end $end \
  1358.         -progress snack::progressCallback}] {
  1359.         SetMsg "Save cancelled"
  1360.     }
  1361.     if {$labels != {}} {
  1362.         set fn $root[file extension $f(labfile)]
  1363.         switch $v(labfmt) {
  1364.         WAVES -
  1365.         HTK {
  1366.             SaveLabelFile [CropLabels [Marker2Time m1] [Marker2Time m2]] $fn
  1367.         }
  1368.         TIMIT -
  1369.         MIX {
  1370.             SaveLabelFile [CropLabels $start $end] $fn
  1371.         }
  1372.         }
  1373.     }
  1374.     }
  1375. }
  1376.  
  1377. proc Close {} {
  1378.     global labels f v c
  1379.  
  1380.     if {$v(smpchanged) || $v(labchanged)} {
  1381.     if {[tk_messageBox -message "You have unsaved changes.\n Do you \
  1382.         really want to close?" -type yesno \
  1383.         -icon question] == "no"} return
  1384.     }
  1385.     StopPlay
  1386.     set labels {}
  1387.     set v(smpchanged) 0
  1388.     set v(labchanged) 0
  1389.     set undo {}
  1390.     .tb.undo config -state disabled
  1391.     set f(labfile) ""
  1392.     set f(sndfile) ""
  1393.     wm title . "xs:"
  1394.     if {$v(linkfile)} {
  1395.     catch {file delete -force _xs[pid].wav}
  1396.     snd configure -file _xs[pid].wav
  1397.     } else {
  1398.     snd flush
  1399.     }
  1400.     Redraw
  1401. }
  1402.  
  1403. proc Exit {} {
  1404.     global v
  1405.  
  1406.     if {$v(smpchanged) || $v(labchanged)} {
  1407.     if {[tk_messageBox -message \
  1408.         "You have unsaved changes.\n Do you really want to quit?" \
  1409.         -type yesno -icon question] == "no"} {
  1410.         return
  1411.     }
  1412.     }
  1413.     catch {file delete -force _xs[pid].wav}
  1414.     exit
  1415. }
  1416.  
  1417. proc OpenGetURLWindow {} {
  1418.     global f v
  1419.  
  1420.     if {$v(linkfile)} {
  1421.     tk_messageBox -icon warning -type ok -message "This function not \
  1422.         available\nwhen using link to disk file."
  1423.     return
  1424.     }
  1425.  
  1426.     set w .geturl
  1427.     catch {destroy $w}
  1428.     toplevel $w
  1429.     wm title $w {Get URL}
  1430.     wm geometry $w [xsGetGeometry]
  1431.  
  1432.     set f(url) $f(http)
  1433.     pack [frame $w.f]
  1434.     pack [label $w.f.l -text {Enter the World Wide Web location (URL):}]
  1435.     pack [entry $w.f.e -width 60 -textvar f(url)]
  1436.     pack [frame $w.f2]
  1437.     pack [button $w.f2.b1 -text Get -command GetURL] -side left
  1438.     bind $w.f.e <Key-Return> GetURL
  1439.     pack [button $w.f2.b2 -text Stop -command StopURL] -side left
  1440.     pack [button $w.f2.b3 -text Close -command [list destroy $w]] -side left
  1441. }
  1442.  
  1443. proc GetURL {} {
  1444.     global c f
  1445.  
  1446.     SetCursor watch
  1447.     $c delete wave speg tran
  1448.     StopPlay
  1449.     StopURL
  1450.     set f(urlToken) [::http::geturl $f(url) -command URLcallback -progress Progress]
  1451.     set c .cf.fc.c
  1452.     SetMsg "Fetching: $f(url)"
  1453. }
  1454.  
  1455. proc Progress {token total current} {
  1456.     if {$total > 0} {
  1457.     set p [expr {int(100 * $current/$total)}]
  1458.     SetMsg "Fetched $current bytes ($p%)"
  1459.     } else {
  1460.     SetMsg "Fetched $current bytes"
  1461.     }
  1462. }
  1463.  
  1464. proc URLcallback {token} {
  1465.     global f v labels
  1466.     upvar #0 $token state
  1467.  
  1468.     SetCursor ""
  1469.     if {$state(status) != "ok"} {
  1470.     return
  1471.     }
  1472.     if {[string match *200* [::http::code $token]] == 1} {
  1473.     snd data [::http::data $token]
  1474.     set f(sndfile) ""
  1475.     set f(labfile) ""
  1476.     set v(rate) [snd cget -rate]
  1477.     set v(sfmt) [snd cget -encoding]
  1478.     set v(startsmp) 0
  1479.     set labels {}
  1480.     wm title . "xs: $f(url)"
  1481.     Redraw
  1482.     event generate .cf.fc.c <Configure>
  1483.     MarkAll
  1484.     SetMsg [InfoStr nopath]
  1485.     } else {
  1486.     SetMsg [::http::code $token]
  1487.     }
  1488.     set f(urlToken) ""
  1489. }
  1490.  
  1491. proc StopURL {} {
  1492.     global f v
  1493.     
  1494.     if {$f(urlToken) != ""} {
  1495.     ::http::reset $f(urlToken)
  1496.     }
  1497.     set f(urlToken) ""
  1498.     SetMsg "Transfer interrupted."
  1499.     SetCursor ""
  1500. }
  1501.  
  1502. proc Crop {} {
  1503.     global labels v
  1504.  
  1505.     set start [Marker2Sample m1]
  1506.     set end   [Marker2Sample m2]
  1507.     if {$start == $end} return
  1508.     SetMsg "Cropping to range: $start $end"
  1509.  
  1510.     cbs copy snd -end [expr {$start - 1}]
  1511.     cbs insert snd [cbs length] -start [expr {$end + 1}]
  1512.     snd crop $start $end
  1513.  
  1514.     set v(undoc) "snd insert cbs 0 -end [expr {$start-1}];snd insert cbs [expr {$end+1}] -start $start"
  1515.     set v(redoc) "snd crop $start $end"
  1516.     set v(smpchanged) 1
  1517.  
  1518.     if {[llength $labels] != 0} {
  1519.     switch $v(labfmt) {
  1520.         WAVES -
  1521.         HTK {
  1522.         set labels [CropLabels [Marker2Time m1] [Marker2Time m2]]
  1523.         }
  1524.         TIMIT -
  1525.         MIX {
  1526.         set labels [CropLabels $start $end]
  1527.         }
  1528.     }
  1529.     set v(labchanged) 1
  1530.     }
  1531.     PutMarker m1 [DTime2Time 0.0] 0 0
  1532.     PutMarker m2 [DTime2Time [snd length -unit seconds]] 0 0
  1533.     .tb.undo config -state normal
  1534.     DrawOverAxis
  1535.     Redraw
  1536. }
  1537.  
  1538. proc Reverse {} {
  1539.     global v
  1540.  
  1541.     if {[Marker2Sample m1] == [Marker2Sample m2]} MarkAll
  1542.     set start [Marker2Sample m1]
  1543.     set end   [Marker2Sample m2]
  1544.     SetMsg "Reversing range: $start $end"
  1545.  
  1546.     cbs copy snd
  1547.     if [catch {snd reverse -start $start -end $end \
  1548.         -progress snack::progressCallback}] {
  1549.     SetMsg "Reverse cancelled"
  1550.     snd copy cbs
  1551.     return
  1552.     }
  1553.  
  1554.     set v(undoc) "snd reverse -start $start -end $end"
  1555.     set v(redoc) "snd reverse -start $start -end $end"
  1556.     set v(smpchanged) 1
  1557.     .tb.undo config -state normal
  1558.     Redraw
  1559. }
  1560.  
  1561. proc Invert {} {
  1562.     global v filt
  1563.  
  1564.     if {[Marker2Sample m1] == [Marker2Sample m2]} MarkAll
  1565.     set start [Marker2Sample m1]
  1566.     set end   [Marker2Sample m2]
  1567.     SetMsg "Inverting range: $start $end"
  1568.  
  1569.     $filt(f) configure -1.0
  1570.  
  1571.     cbs copy snd
  1572.     if [catch {snd filter $filt(f) -start $start -end $end \
  1573.         -progress snack::progressCallback}] {
  1574.     SetMsg "Invert cancelled"
  1575.     snd copy cbs
  1576.     return
  1577.     }
  1578.  
  1579.     set v(undoc) "snd swap cbs"
  1580.     set v(redoc) "snd swap cbs"
  1581.     set v(smpchanged) 1
  1582.     .tb.undo config -state normal
  1583.     Redraw
  1584. }
  1585.  
  1586. proc Silence {} {
  1587.     global v filt
  1588.  
  1589.     set start [Marker2Sample m1]
  1590.     set end   [Marker2Sample m2]
  1591.     if {$start == $end} return
  1592.     SetMsg "Silencing range: $start $end"
  1593.  
  1594.     $filt(f) configure 0.0
  1595.  
  1596.     cbs copy snd
  1597.     if [catch {snd filter $filt(f) -start $start -end $end \
  1598.         -progress snack::progressCallback}] {
  1599.     SetMsg "Silence cancelled"
  1600.     snd copy cbs
  1601.     return
  1602.     }
  1603.  
  1604.     set v(undoc) "snd swap cbs"
  1605.     set v(redoc) "snd swap cbs"
  1606.     set v(smpchanged) 1
  1607.     .tb.undo config -state normal
  1608.     Redraw
  1609. }
  1610.  
  1611. proc RemoveDC {} {
  1612.     global v remdc
  1613.  
  1614.     if {[Marker2Sample m1] == [Marker2Sample m2]} MarkAll
  1615.     set start [Marker2Sample m1]
  1616.     set end   [Marker2Sample m2]
  1617.     if {$start == $end} return
  1618.     SetMsg "Removing DC for range: $start $end"
  1619.  
  1620.     cbs copy snd
  1621.     if [catch {snd filter $remdc(f) -start $start -end $end \
  1622.         -progress snack::progressCallback -continuedrain 0}] {
  1623.     SetMsg "Remove DC cancelled"
  1624.     snd copy cbs
  1625.     return
  1626.     }
  1627.  
  1628.     set v(undoc) "snd swap cbs"
  1629.     set v(redoc) "snd swap cbs"
  1630.     set v(smpchanged) 1
  1631.     .tb.undo config -state normal
  1632.     Redraw
  1633. }
  1634.  
  1635. proc ConfAmplify {flag} {
  1636.     global amplify
  1637.  
  1638.     set w .amp
  1639.     if {$amplify(db) == 1} {
  1640.     $w.f.l configure -text dB
  1641.     set tmp [expr {20.0*log10(($amplify(v)+0.000000000000000001)/100.0)}]
  1642.     $w.f.s1 configure -from -96.0 -to 24.0
  1643.     } else {
  1644.     $w.f.l configure -text %
  1645.     set tmp [expr {100.0*pow(10,$amplify(v)/20.0)}]
  1646.     $w.f.s1 configure -from 0.0 -to 300.0
  1647.     }
  1648.     if {$flag} {
  1649.     set amplify(v) $tmp
  1650.     }
  1651. }
  1652.  
  1653. proc DoAmplify {} {
  1654.     global v amplify
  1655.  
  1656.     set start [Marker2Sample m1]
  1657.     set end   [Marker2Sample m2]
  1658.     if {$start == $end} return
  1659.     SetMsg "Amplifying range: $start $end"
  1660.  
  1661.     if {$amplify(db) == 1} {
  1662.     set tmp [expr {pow(10,$amplify(v)/20.0)}]
  1663.     } else {
  1664.     set tmp [expr {$amplify(v) / 100.0}]
  1665.     }
  1666.     $amplify(f) configure $tmp
  1667.  
  1668.     cbs copy snd
  1669.     if [catch {snd filter $amplify(f) -start $start -end $end \
  1670.         -progress snack::progressCallback}] {
  1671.     SetMsg "Amplify cancelled"
  1672.     snd copy cbs
  1673.     return
  1674.     }
  1675.  
  1676.     set v(undoc) "snd swap cbs"
  1677.     set v(redoc) "snd swap cbs"
  1678.     set v(smpchanged) 1
  1679.     .tb.undo config -state normal
  1680.     Redraw
  1681. }
  1682.  
  1683. proc Amplify {} {
  1684.     global amplify
  1685.  
  1686.     if {[Marker2Sample m1] == [Marker2Sample m2]} MarkAll
  1687.     set w .amp
  1688.     catch {destroy $w}
  1689.     toplevel $w
  1690.     wm title $w {Amplify}
  1691.  
  1692.     pack [ label $w.l -text "Amplify by:"]
  1693.     pack [ frame $w.f] -fill both -expand true
  1694.     pack [ scale $w.f.s1 -command "" -orient horizontal \
  1695.         -resolution .1 -showvalue 0 \
  1696.         -variable amplify(v)] -side left
  1697.     pack [entry $w.f.e -textvariable amplify(v) -width 5] -side left
  1698.     pack [label $w.f.l -text xx -width 2] -side left
  1699.     pack [checkbutton $w.cb -text "Decibels" -variable amplify(db) \
  1700.         -command [list ConfAmplify 1]]
  1701.     pack [ frame $w.f3]
  1702.     pack [ button $w.f3.b1 -text OK -width 6 \
  1703.         -command "DoAmplify;destroy $w"] -side left
  1704.     pack [ button $w.f3.b2 -text Cancel -command "destroy $w"] -side left
  1705.     ConfAmplify 0
  1706. }
  1707.  
  1708. proc ConfNormalize {flag} {
  1709.     global normalize
  1710.  
  1711.     set w .norm
  1712.     if {$normalize(db) == 1} {
  1713.     $w.f.l configure -text dB
  1714.     set tmp [expr {20.0*log10(($normalize(v)+0.000000000000000001)/100.0)}]
  1715.     $w.f.s1 configure -from -96.0 -to 0.0
  1716.     } else {
  1717.     $w.f.l configure -text %
  1718.     set tmp [expr {100.0*pow(10,$normalize(v)/20.0)}]
  1719.     $w.f.s1 configure -from 0.0 -to 100.0
  1720.     }
  1721.     if {$flag} {
  1722.     set normalize(v) $tmp
  1723.     }
  1724.     if {[snd cget -channels] == 1} {
  1725.     $w.cb2 configure -state disabled
  1726.     } else {
  1727.     $w.cb2 configure -state normal
  1728.     }
  1729. }
  1730.  
  1731. proc DoNormalize {} {
  1732.     global v normalize
  1733.  
  1734.     set start [Marker2Sample m1]
  1735.     set end   [Marker2Sample m2]
  1736.     if {$start == $end} return
  1737.     SetMsg "Normalizing range: $start $end"
  1738.   
  1739.     if {$normalize(db) == 1} {
  1740.     set tmp [expr {pow(10,$normalize(v)/20.0)}]
  1741.     } else {
  1742.     set tmp [expr {$normalize(v) / 100.0}]
  1743.     }
  1744.     if {[string match [snd cget -encoding] Lin8]} {
  1745.     set smax 255.0
  1746.     } elseif {[string match [snd cget -encoding] Lin24]} {
  1747.         set smax 8388608.0
  1748.     } else {
  1749.     set smax 32767.0
  1750.     }
  1751.     for {set c 0} {$c < [snd cget -channels]} {incr c} {
  1752.     if {$normalize(allEqual)} {
  1753.          set max [snd max -start $start -end $end]
  1754.          set min [snd min -start $start -end $end]
  1755.     } else {
  1756.        set max [snd max -start $start -end $end -channel $c]
  1757.      set min [snd min -start $start -end $end -channel $c]
  1758.     }
  1759.     if {$max < -$min} {
  1760.         set max [expr {-$min}]
  1761.         if {$max > $smax} {
  1762.         set max $smax
  1763.         }
  1764.     }
  1765.     if {$max == 0} {
  1766.         set max 1.0
  1767.     }
  1768.     set factor [expr {$tmp * $smax / $max}]
  1769.     lappend factors $factor
  1770.     if {$normalize(allEqual)} break
  1771.     if {$c < [expr {[snd cget -channels] - 1}]} {
  1772.         for {set i 0} {$i < [snd cget -channels]} {incr i} {
  1773.             lappend factors 0.0
  1774.         }
  1775.     }
  1776.     }
  1777.     eval $normalize(f) configure $factors
  1778.  
  1779.     cbs copy snd
  1780.     if [catch {snd filter $normalize(f) -start $start -end $end \
  1781.         -progress snack::progressCallback}] {
  1782.     SetMsg "Normalize cancelled"
  1783.     snd copy cbs
  1784.     return
  1785.     }
  1786.  
  1787.     set v(undoc) "snd swap cbs"
  1788.     set v(redoc) "snd swap cbs"
  1789.     set v(smpchanged) 1
  1790.     .tb.undo config -state normal
  1791.     Redraw
  1792. }
  1793.  
  1794. proc Normalize {} {
  1795.     global normalize
  1796.  
  1797.     if {[Marker2Sample m1] == [Marker2Sample m2]} MarkAll
  1798.     set w .norm
  1799.     catch {destroy $w}
  1800.     toplevel $w
  1801.     wm title $w {Normalize}
  1802.  
  1803.     pack [ label $w.l -text "Normalize to:"]
  1804.     pack [ frame $w.f] -fill both -expand true
  1805.     pack [ scale $w.f.s1 -command "" -orient horizontal \
  1806.         -resolution .1 -showvalue 0 \
  1807.         -variable normalize(v)] -side left
  1808.     pack [entry $w.f.e -textvariable normalize(v) -width 5] -side left
  1809.     pack [label $w.f.l -text xx -width 2] -side left
  1810.     pack [checkbutton $w.cb1 -text "Decibels" -variable normalize(db) \
  1811.         -command [list ConfNormalize 1] -anchor w] -fill both -expand true
  1812.     pack [checkbutton $w.cb2 -text "Normalize all channels equally" \
  1813.         -variable normalize(allEqual) -anchor w] -fill both -expand true
  1814.     pack [ frame $w.f3]
  1815.     pack [ button $w.f3.b1 -text OK -width 6 \
  1816.         -command "DoNormalize;destroy $w"] -side left
  1817.     pack [ button $w.f3.b2 -text Cancel -command "destroy $w"] -side left
  1818.     ConfNormalize 0
  1819. }
  1820.  
  1821. proc ConfEcho {args} {
  1822.     global echo
  1823.  
  1824.     set iGain [expr {0.01 * $echo(iGain)}]
  1825.     set oGain [expr {0.01 * $echo(oGain)}]
  1826.     set values "$iGain $oGain "
  1827.     for {set i 1} {$i <= $echo(n)} {incr i} {
  1828.     set decay [expr {0.01 * $echo(decay$i)}]
  1829.     append values "$echo(delay$i) $decay "
  1830.     }
  1831.  
  1832.     eval $echo(f) configure $values
  1833. }
  1834.  
  1835. proc DoEcho {} {
  1836.     global v echo
  1837.  
  1838.     set start [Marker2Sample m1]
  1839.     set end   [Marker2Sample m2]
  1840.     if {$start == $end} return
  1841.     SetMsg "Applying echo filter to range: $start $end"
  1842.  
  1843.     ConfEcho
  1844.  
  1845.     cbs copy snd
  1846.     if [catch {snd filter $echo(f) -start $start -end $end \
  1847.         -continuedrain $echo(drain) \
  1848.         -progress snack::progressCallback}] {
  1849.     SetMsg "Echo filter cancelled"
  1850.     snd copy cbs
  1851.     return
  1852.     }
  1853.  
  1854.     set v(undoc) "snd swap cbs"
  1855.     set v(redoc) "snd swap cbs"
  1856.     set v(smpchanged) 1
  1857.     .tb.undo config -state normal
  1858.     Redraw
  1859. }
  1860.  
  1861. proc PlayEcho {} {
  1862.     global echo
  1863.  
  1864.     set start [Marker2Sample m1]
  1865.     set end   [Marker2Sample m2]
  1866.     if {$start == $end} return
  1867.  
  1868.     ConfEcho
  1869.  
  1870.     snd stop
  1871.     snd play -filter $echo(f) -start $start -end $end
  1872. }
  1873.  
  1874. proc AddEcho {} {
  1875.     global echo
  1876.  
  1877.     if {$echo(n) > 9} return
  1878.     set w .proc
  1879.     incr echo(n)
  1880.     AddEchoW $echo(n)
  1881. }
  1882.  
  1883. proc AddEchoW {n} {
  1884.     global echo
  1885.  
  1886.     set w .proc
  1887.     set f [expr {$n + 2}]
  1888.     pack [frame $w.f.f$f -relief raised -bd 1] -side left -before $w.f.hidden
  1889.     if {![info exists echo(delay$n)]} {
  1890.     set echo(delay$n) 30.0
  1891.     }
  1892.     pack [label $w.f.f$f.l -text "Echo $n"] -side top
  1893.     pack [frame $w.f.f$f.f1] -side left
  1894.     pack [scale $w.f.f$f.f1.s -label "" -from 250.0 -to 10.0 \
  1895.         -variable echo(delay$n) -command "" -showvalue 0 -command ConfEcho]
  1896.     pack [frame $w.f.f$f.f1.f]
  1897.     pack [entry $w.f.f$f.f1.f.e -textvariable echo(delay$n) -width 3] \
  1898.         -side left
  1899.     pack [label $w.f.f$f.f1.f.l -text ms] -side left
  1900.  
  1901.     if {![info exists echo(decay$n)]} {
  1902.     set echo(decay$n) 40
  1903.     }
  1904.     pack [frame $w.f.f$f.f2] -side left
  1905.     pack [scale $w.f.f$f.f2.s -label "" -from 100 -to 0 -resolution 1 \
  1906.         -variable echo(decay$n) -command "" -showvalue 0 -command ConfEcho]
  1907.     pack [frame $w.f.f$f.f2.f]
  1908.     pack [entry $w.f.f$f.f2.f.e -textvariable echo(decay$n) -width 3] \
  1909.         -side left
  1910.     pack [label $w.f.f$f.f2.f.l -text %] -side left
  1911. }
  1912.  
  1913. proc RemEcho {} {
  1914.     global echo
  1915.  
  1916.     if {$echo(n) < 2} return
  1917.  
  1918.     set w .proc
  1919.     set f [expr {$echo(n) + 2}]
  1920.     destroy $w.f.f$f
  1921.     incr echo(n) -1
  1922. }
  1923.  
  1924. proc Echo {} {
  1925.     global echo
  1926.  
  1927.     if {[Marker2Sample m1] == [Marker2Sample m2]} MarkAll
  1928.     set w .proc
  1929.     catch {destroy $w}
  1930.     toplevel $w
  1931.     wm title $w {Echo}
  1932.  
  1933.     pack [frame $w.f]
  1934.     
  1935.     pack [frame $w.f.f1] -side left
  1936.     pack [label $w.f.f1.l -text In]
  1937.     pack [scale $w.f.f1.s -label "" -from 100 -to 0 -resolution 1 \
  1938.         -variable echo(iGain) -command "" -showvalue 0 -command ConfEcho]
  1939.     pack [frame $w.f.f1.f]
  1940.     pack [entry $w.f.f1.f.e -textvariable echo(iGain) -width 3] -side left
  1941.     pack [label $w.f.f1.f.l -text %] -side left
  1942.  
  1943.     pack [frame $w.f.f2] -side left
  1944.     pack [label $w.f.f2.l -text Out]
  1945.     pack [scale $w.f.f2.s -label "" -from 100 -to 0 -resolution 1 \
  1946.         -variable echo(oGain) -command "" -showvalue 0 -command ConfEcho]
  1947.     pack [frame $w.f.f2.f]
  1948.     pack [entry $w.f.f2.f.e -textvariable echo(oGain) -width 3] -side left
  1949.     pack [label $w.f.f2.f.l -text %] -side left
  1950.  
  1951.     pack [frame $w.f.fe] -side left
  1952.     pack [button $w.f.fe.1 -text + -command AddEcho]
  1953.     pack [button $w.f.fe.2 -text - -command RemEcho]
  1954.  
  1955.     pack [frame $w.f.hidden] -side left
  1956.     for {set i 1} {$i <= $echo(n)} {incr i} {
  1957.      AddEchoW $i
  1958.     }
  1959.  
  1960.     pack [checkbutton $w.cb -text "Drain beyond selection" \
  1961.         -variable echo(drain)] -anchor w
  1962.  
  1963.     pack [ frame $w.f3] -pady 10 -anchor w
  1964.     pack [ button $w.f3.b1 -bitmap snackPlay -command PlayEcho] -side left
  1965.     pack [ button $w.f3.b2 -bitmap snackStop -command "Stop snd"] -side left
  1966.     pack [ button $w.f3.b3 -text OK -width 6 -command "DoEcho;destroy $w"] \
  1967.         -side left
  1968.     pack [ button $w.f3.b4 -text Cancel -command "destroy $w"] -side left
  1969. }
  1970.  
  1971. proc ConfMix {args} {
  1972.     global mix
  1973.  
  1974.     set n [snd cget -channels]
  1975.     for {set i 0} {$i < $n} {incr i} {
  1976.     for {set j 0} {$j < $n} {incr j} {
  1977.         set val [expr {0.01 * $mix($i,$j)}]
  1978.         append values "$val "
  1979.     }
  1980.     }
  1981.     eval $mix(f) configure $values
  1982. }
  1983.  
  1984. proc DoMix {} {
  1985.     global v mix
  1986.  
  1987.     set start [Marker2Sample m1]
  1988.     set end   [Marker2Sample m2]
  1989.     if {$start == $end} return
  1990.     SetMsg "Mixing channels in range: $start $end"
  1991.  
  1992.     ConfMix
  1993.  
  1994.     cbs copy snd
  1995.     if [catch {snd filter $mix(f) -start $start -end $end \
  1996.         -progress snack::progressCallback}] {
  1997.     SetMsg "Mix channels cancelled"
  1998.     snd copy cbs
  1999.     return
  2000.     }
  2001.  
  2002.     set v(undoc) "snd swap cbs"
  2003.     set v(redoc) "snd swap cbs"
  2004.     set v(smpchanged) 1
  2005.     .tb.undo config -state normal
  2006.     Redraw
  2007. }
  2008.  
  2009. proc PlayMix {} {
  2010.     global mix
  2011.  
  2012.     set start [Marker2Sample m1]
  2013.     set end   [Marker2Sample m2]
  2014.     if {$start == $end} return
  2015.  
  2016.     ConfMix
  2017.  
  2018.     snd stop
  2019.     snd play -filter $mix(f) -start $start -end $end
  2020. }
  2021.  
  2022. proc MixChan {} {
  2023.     global mix
  2024.  
  2025.     if {[Marker2Sample m1] == [Marker2Sample m2]} MarkAll
  2026.     set w .mix
  2027.     catch {destroy $w}
  2028.     toplevel $w
  2029.     wm title $w {Mix Channels}
  2030.  
  2031.     pack [frame $w.f]
  2032.  
  2033.     label $w.f.l -text "New channel"
  2034.     grid $w.f.l
  2035.  
  2036.     set n [snd cget -channels]
  2037.  
  2038.     for {set i 0} {$i < $n} {incr i} {
  2039.     if {$i == 0} {
  2040.         set label Left
  2041.     } elseif {$i == 1} {
  2042.         set label Right
  2043.     } else {
  2044.         set label [expr {$i + 1}]
  2045.     }
  2046.     label $w.f.ly$i -text $label
  2047.     grid $w.f.ly$i -row [expr {$i + 1}] -column 0
  2048.     label $w.f.lx$i -text "Channel $label"
  2049.     grid $w.f.lx$i -row 0 -column [expr {$i + 1}]
  2050.     for {set j 0} {$j < $n} {incr j} {
  2051.         if {![info exists mix($i,$j)]} {
  2052.         if {$i == $j} {
  2053.             set mix($i,$j) 100
  2054.         } else {
  2055.             set mix($i,$j) 0
  2056.         }
  2057.         }
  2058.         frame $w.f.f$i-f$j -relief raised -bd 1
  2059.         grid $w.f.f$i-f$j -row [expr {$i + 1}] -column [expr {$j + 1}]
  2060.         pack [scale $w.f.f$i-f$j.s -command "" -orient horizontal \
  2061.             -from -100 -to 100 -showvalue 0 -command ConfMix \
  2062.             -variable mix($i,$j)]
  2063.         pack [frame $w.f.f$i-f$j.f]      
  2064.         pack [entry $w.f.f$i-f$j.f.e -textvariable mix($i,$j) -width 4] \
  2065.             -side left
  2066.         pack [label $w.f.f$i-f$j.f.l -text %] -side left
  2067.     }
  2068.     }
  2069.  
  2070.     pack [ frame $w.f3] -pady 10
  2071.     pack [ button $w.f3.b1 -bitmap snackPlay -command PlayMix] -side left
  2072.     pack [ button $w.f3.b2 -bitmap snackStop -command "Stop snd"] -side left
  2073.     pack [ button $w.f3.b3 -text OK -width 6 -command "DoMix;destroy $w"] \
  2074.         -side left
  2075.     pack [ button $w.f3.b4 -text Cancel -command "destroy $w"] -side left
  2076. }
  2077.  
  2078. proc Cut {} {
  2079.     global c v
  2080.  
  2081.     set start [Marker2Sample m1]
  2082.     set end   [Marker2Sample m2]
  2083.     if {$start == $end} return
  2084.     SetMsg "Cutting range: $start $end"
  2085.     cbs copy snd -start $start -end $end
  2086.     snd cut $start $end
  2087.     set v(undoc) "snd insert cbs $start"
  2088.     set v(redoc) "snd cut $start $end"
  2089.  
  2090.     PutMarker m2 [Marker2Time m1] 0 0
  2091.     set v(smpchanged) 1
  2092.     .tb.undo config -state normal
  2093.     DrawOverAxis
  2094.     Redraw
  2095. }
  2096.  
  2097. proc Copy {} {
  2098.     set start [Marker2Sample m1]
  2099.     set end   [Marker2Sample m2]
  2100.     if {$start == $end} return
  2101.     SetMsg "Copying range: $start $end"
  2102.     cbs copy snd -start $start -end $end
  2103. }
  2104.  
  2105. proc Paste {} {
  2106.     global c v
  2107.  
  2108.     set start [Marker2Sample m1]
  2109.     set startt [Marker2Time m1]
  2110.     if {$start > [snd length]} {
  2111.     set start [snd length]
  2112.     set startt [snd length -unit seconds]
  2113.     }
  2114.     SetMsg "Inserting at: $start"
  2115.     snd insert cbs $start
  2116.  
  2117.     set tmp [expr {$start + [cbs length] - 1}]
  2118.     set v(undoc) "snd cut $start $tmp"
  2119.     set v(redoc) "snd insert cbs $start"
  2120.  
  2121.     PutMarker m2 [expr {$startt + [DTime2Time [cbs length -unit seconds]]}] 0 0
  2122.     set v(smpchanged) 1
  2123.     .tb.undo config -state normal
  2124.     DrawOverAxis
  2125.     Redraw
  2126. }
  2127.  
  2128. proc SendXScroll {} {
  2129.     global c v
  2130.  
  2131.     if $v(slink) {
  2132.     foreach prg [winfo interps] {
  2133.         if [regexp .*xs.* $prg] {
  2134.         if {[winfo name .] != $prg} {
  2135.             send $prg RecvXScroll [Coord2Time [expr [lindex [.cf.fc.xscroll get] 0] * $v(width)]]
  2136.         }
  2137.         }
  2138.     }
  2139.     }
  2140. }
  2141.  
  2142. proc RecvXScroll {a} {
  2143.     global c v
  2144.  
  2145.     set f [Time2Coord [expr double($a / $v(width))]]
  2146.     eval $c xview moveto $f
  2147. }
  2148.  
  2149. proc Redraw {args} {
  2150.     global c labels f v
  2151.  
  2152.     SetCursor watch
  2153.     set length [snd length]
  2154.     if {$args != "quick"} {
  2155.     $c delete obj
  2156.     $c config -bg $v(bg)
  2157.     .cf.fyc.yc config -bg $v(bg)
  2158.     .of.c config -bg $v(bg)
  2159.     if {$length == 0} { set length 1 }
  2160.     set v(endsmp) [expr $v(startsmp) + $v(rate) * $v(scrw) / $v(pps)]
  2161.     if {$v(endsmp) > $length} {
  2162.         set v(endsmp) $length
  2163.     }
  2164.  
  2165.     if {[expr int(double($length * $v(pps)) / $v(rate))] < $v(scrw)} {
  2166.         if [winfo exist .of] { pack forget .of }
  2167.         set v(startsmp) 0
  2168.         set v(endsmp) $length
  2169.     } else {
  2170.         pack .of -side top -fill x -before .cf
  2171.         if {$::tcl_platform(platform) == "windows"} {
  2172.         DrawOverAxis
  2173.         }
  2174.     }
  2175.     .of.xscroll set [expr double($v(startsmp)) / $length] [expr double($v(endsmp)) / $length]
  2176.  
  2177.     .cf.fyc.yc delete axis
  2178.     if {$v(waveh) > 0} {
  2179.         if {$v(linkfile) && $f(sndfile) != ""} {
  2180.         snack::deleteInvalidShapeFile [file tail $f(spath)$f(sndfile)]
  2181.         $c create waveform 0 0 -sound snd -height $v(waveh) \
  2182.             -pixels $v(pps) -tags [list obj wave] \
  2183.             -start $v(startsmp) -end $v(endsmp) \
  2184.             -channel $v(vchan) -debug $::debug -fill $v(fg) \
  2185.     -shapefile [file rootname [file tail $f(spath)$f(sndfile)]].shape\
  2186.             -progress snack::progressCallback
  2187.         snack::makeShapeFileDeleteable [file tail $f(spath)$f(sndfile)]
  2188.         } else {
  2189.         $c create waveform 0 0 -sound snd -height $v(waveh) \
  2190.             -pixels $v(pps) -tags [list obj wave] \
  2191.             -start $v(startsmp) -end $v(endsmp) \
  2192.             -channel $v(vchan) -debug $::debug -fill $v(fg)
  2193.         }
  2194.         $c lower wave
  2195.         .cf.fyc.yc create text $v(yaxisw) 2 -text [snd max]\
  2196.             -font $v(sfont) -anchor ne -tags axis -fill $v(fg)
  2197.         .cf.fyc.yc create text $v(yaxisw) $v(waveh) -text [snd min]\
  2198.             -font $v(sfont) -anchor se -tags axis -fill $v(fg)
  2199.         .cf.fyc.yc create line 0 [expr $v(waveh)+0] $v(yaxisw) \
  2200.             [expr $v(waveh)+0] -tags axis -fill $v(fg)  
  2201.     }
  2202.     if {$v(topfr) > [expr $v(rate)/2]} {
  2203.         set v(topfr) [expr $v(rate)/2]
  2204.     }
  2205.     if {$v(spegh) > 0} {
  2206.         set v(winlen) [expr int($v(rate) / $v(anabw))]
  2207.         if {$v(winlen) > $v(fftlen)} {
  2208.           set v(winlen) $v(fftlen)
  2209.         }
  2210.         $c create spectrogram 0 $v(waveh) -sound snd -fftlen $v(fftlen) \
  2211.             -winlen $v(winlen) -height $v(spegh) -pixels $v(pps) \
  2212.             -preemph $v(preemph) -topfr $v(topfr) -tags [list obj speg] \
  2213.             -start $v(startsmp) -end $v(endsmp)\
  2214.             -contrast $v(contrast) -brightness $v(brightness)\
  2215.             -gridtspacing $v(gridtspacing) \
  2216.             -gridfspacing $v(gridfspacing) -channel $v(vchan) \
  2217.             -colormap $v($v(cmap)) -gridcol $v(gridcolor) \
  2218.             -progress snack::progressCallback -debug $::debug
  2219.         $c lower speg
  2220.         snack::frequencyAxis .cf.fyc.yc 0 $v(waveh) $v(yaxisw) $v(spegh)\
  2221.             -topfrequency $v(topfr) -tags axis -fill $v(fg)\
  2222.             -font $v(sfont)
  2223.         .cf.fyc.yc create line 0 [expr $v(spegh) + $v(waveh)+0] \
  2224.             $v(yaxisw) [expr $v(spegh) + $v(waveh)+0] -tags axis\
  2225.             -fill $v(fg)
  2226.     }
  2227.  
  2228.     set v(width) [expr int($v(pps) * double($v(endsmp) - $v(startsmp)) / $v(rate))]
  2229.     if {$v(width) == 0} { set v(width) 600 } 
  2230.     $c create line 0 0 $v(width) 0 -tags obj -fill $v(fg)
  2231.     $c create line 0 $v(waveh) $v(width) $v(waveh) -tags obj -fill $v(fg)
  2232.  
  2233.     }
  2234.  
  2235.     $c delete tran axis
  2236.     set y [expr $v(waveh) + $v(spegh)]
  2237.     $c create line 0 $y $v(width) $y -tags axis -fill $v(fg)
  2238.  
  2239.     snack::timeAxis $c 0 $y $v(width) $v(timeh) $v(pps)\
  2240.         -tags axis -starttime [expr double($v(startsmp)) / $v(rate)]\
  2241.         -fill $v(fg) -font $v(sfont)
  2242.     incr y $v(timeh)
  2243.     $c create line 0 $y $v(width) $y -tags axis -fill $v(fg)
  2244.  
  2245.     .cf.fyc.yc configure -height $y
  2246.     set tlab t
  2247.     .cf.fyc.yc create text 5 [expr $v(waveh) + $v(spegh) + 2] -text $tlab \
  2248.         -font $v(sfont) -anchor nw -tags axis -fill $v(fg)
  2249.  
  2250.     if $v(ipa) {
  2251.     incr y [DrawLabels $y $labels ipa]
  2252.     }
  2253.     incr y [DrawLabels $y $labels lab]
  2254.  
  2255.     foreach p $v(plugins) {
  2256.     incr y [namespace inscope $p Redraw $y]
  2257.     }
  2258.  
  2259.     set v(toth) $y
  2260.     $c configure -height $v(toth) -width $v(width) -scrollregion "0 0 $v(width) $v(toth)"
  2261.     .cf.fyc.yc configure -height $v(toth) -scrollregion "0 0 $v(yaxisw) $v(toth)"
  2262.  
  2263. # Someday in a perfect universe
  2264.  
  2265.     if {$::tcl_platform(os) == "Linux" || \
  2266.     $::tcl_platform(platform) == "macintosh"} {
  2267.       set maxw [lindex [wm maxsize .] 0]
  2268.       if {$v(width) > $maxw} {
  2269.     if [winfo exist .of] {
  2270.       . config -width $maxw -height [expr $v(toth) + 130]
  2271.     } else {
  2272.       . config -width $maxw -height [expr $v(toth) + 40]
  2273.     }
  2274.     pack propagate . 0
  2275.       } else {
  2276.     pack propagate . 1
  2277.       }
  2278.     }
  2279.     if {$::tcl_platform(platform) == "windows"} {
  2280.       set maxw [lindex [wm maxsize .] 0]
  2281.       if {$v(width) > $maxw} {
  2282.     if {[expr int(double($length * $v(pps)) / $v(rate))] >= $v(scrw)} {
  2283.       wm geometry . [expr $maxw - 15]x[expr $v(toth) + 120]
  2284.     } else {
  2285.       wm geometry . [expr $maxw - 15]x[expr $v(toth) + 70]
  2286.     }
  2287.       }
  2288.     }
  2289.  
  2290.     catch {PutMarker m1 [Marker2Time m1] 0 0}
  2291.     catch {PutMarker m2 [Marker2Time m2] 0 0}
  2292.     SetCursor ""
  2293. }
  2294.  
  2295. proc DrawLabels {y labels type} {
  2296.     global c v f ipa
  2297.  
  2298.     if {[llength $labels] == 0} {
  2299.     return 0
  2300.     } else {
  2301.     $c create line 0 [expr $y + $v(labelh)]    [expr $v(width) -1] \
  2302.         [expr $y + $v(labelh)] -tags obj -fill $v(fg)
  2303.     set start 0
  2304.     set end   0
  2305.     set label ""
  2306.     set i 0
  2307.     foreach row $labels {
  2308.         switch $v(labfmt) {
  2309.         TIMIT -
  2310.         HTK {
  2311.             scan $row {%d %d %s} start end label
  2312.             set lx [Time2Coord $start]
  2313. #            if {!$v(zerolabs) && $end == $start} continue
  2314.         }
  2315.         MIX {
  2316.             scan $row {%d %s} start label
  2317.             set lx [Time2Coord $start]
  2318.             set end [Coord2Time $v(width)]
  2319.             scan [lindex $labels [expr $i+1]] {%d} end
  2320.         }
  2321.         WAVES {
  2322.             scan $row {%f %d %s} end color label
  2323.             set lx [Time2Coord $end]
  2324.             set start 0
  2325.             scan [lindex $labels [expr $i-1]] {%f} start
  2326.         }
  2327.         }
  2328.         if {$lx >= 0 && $lx <= $v(width)} {
  2329.         if {$v(labalign) == "c"} {
  2330.             set tx [Time2Coord [expr ($start+$end)/2]]
  2331.         } elseif {$v(labalign) == "w"} {
  2332.             set tx [expr [Time2Coord $start] + 2] 
  2333.         } else {
  2334.             set tx [Time2Coord $end]
  2335.         }
  2336.         if {$type == "lab"} {
  2337.             $c create text $tx [expr $y+12] -text $label\
  2338.                 -font $v(font) -anchor $v(labalign)\
  2339.                 -tags [list $i obj text lab$i tran] -fill $v(fg)
  2340.             $c create line $lx $y $lx [expr $y+$v(labelh)] \
  2341.                 -tags [list b$i obj bound tran] -fill $v(fg)
  2342.         } else {
  2343.             if {$v(labfmt) == "MIX"} {
  2344.             regsub -all {\$} $label "" t1
  2345.             regsub -all {\"} $t1    "" t2
  2346.             regsub -all # $t2       "" t3
  2347.             regsub -all {\`} $t3    "" t4
  2348.             regsub -all {\'} $t4    "" tmp
  2349.             set label $tmp
  2350.             }
  2351. #        catch {$c create image $tx [expr $y+2] \
  2352. #           -image [image create photo -file $f(ipapath)/$ipa($label)] \
  2353. #           -anchor n -tags [list obj tran]}
  2354.             if {$::tcl_platform(platform) == "windows"} {
  2355.             $c create text $tx [expr $y+12] \
  2356.                 -text $label -font IPAKiel -fill $v(fg)\
  2357.                 -anchor $v(labalign) -tags [list obj tran]
  2358.             } else {
  2359.             catch {$c create bitmap $tx [expr $y+2] \
  2360.                 -bitmap @$f(ipapath)/$ipa($label) \
  2361.                 -anchor n -tags [list obj tran]}
  2362.             }
  2363.             $c create line $lx [expr $y] $lx [expr $y+$v(labelh)] \
  2364.                 -tags [list obj tran] -fill $v(fg)
  2365.         }
  2366.         }
  2367.         incr i
  2368.     }
  2369.     }
  2370.     return $v(labelh)
  2371. }
  2372.  
  2373. proc ScrollCmd {args} {
  2374.     global v
  2375.  
  2376.     if {[lindex $args 0] == "moveto"} {
  2377.     set delta [expr [lindex [.of.xscroll get] 1] - [lindex [.of.xscroll get] 0]]
  2378.     set pos [lindex $args 1]
  2379.     if {$pos < 0.0} { set pos 0.0 }
  2380.     if {$pos > [expr 1.0 - $delta]} { set pos [expr 1.0 - $delta] }
  2381.     .of.xscroll set $pos [expr $pos + $delta]
  2382.     } elseif {[lindex $args 0] == "scroll" && $v(scroll) == 1} {
  2383.     set pos [expr double($v(startsmp)) / [snd length]]
  2384.     set delta [expr double($v(endsmp)) / [snd length] - $pos]
  2385.     if {[lindex $args 1] > 0} {
  2386.             set pos [expr $pos + $delta]
  2387.         if {$pos > [expr 1.0 - $delta]} { set pos [expr 1.0 - $delta] }
  2388.     }
  2389.     if {[lindex $args 1] < 0} {
  2390.             set pos [expr $pos - $delta]
  2391.             if {$pos < 0.0} { set pos 0.0 }
  2392.     }
  2393.     .of.xscroll set $pos [expr $pos + $delta]
  2394.     set v(scroll) 0
  2395.     }
  2396. }
  2397.  
  2398. proc RePos {args} {
  2399.     global v c
  2400.  
  2401.     set v(startsmp) [expr int ([lindex [.of.xscroll get] 0] * [snd length])]
  2402.     set v(endsmp)   [expr int ([lindex [.of.xscroll get] 1] * [snd length])]
  2403.     $c xview moveto 0
  2404.     Redraw
  2405. }
  2406.  
  2407. proc DrawOverAxis {} {
  2408.   global v
  2409.   
  2410.   set totw [winfo width .]
  2411.   set scrh [winfo height .of.xscroll]
  2412.   set width [expr $totw - 2 * $scrh]
  2413.   set length [snd length -unit seconds]
  2414.   if {$length > 0} {
  2415.     set v(opps) [expr $width/$length]
  2416.   } else {
  2417.     set v(opps) 400
  2418.   }
  2419.   .of.c delete overaxis
  2420.   snack::timeAxis .of.c $scrh 20 $width 11 $v(opps) -tags overaxis \
  2421.       -fill $v(fg)
  2422. }
  2423.  
  2424. proc OverPlay {x} {
  2425.     global v
  2426.     
  2427.     set start [expr int($v(rate)*(($x - [winfo height .of.xscroll]) * 1000 / $v(opps)))]
  2428.     set end   [snd length]
  2429.     Stop snd
  2430.     if {$start < 0} { set start 0 }
  2431.     set v(s0) $start
  2432.     set v(s1) $end
  2433.     Play snd $start $end
  2434.     .of.c create poly -1 -1 -1 -1 -1 -1 -fill red -tags playmark
  2435.     after cancel PutPlayMarker
  2436.     after 50 PutPlayMarker
  2437. }
  2438.  
  2439. proc Reconf {} {
  2440.     global c v f
  2441.  
  2442.     set dox 0
  2443.     set doy 0
  2444.     if {[$c xview] == "0 1"} { set dox 1 }
  2445.     if {[$c yview] == "0 1"} { set doy 1 }
  2446.  
  2447.     if {$dox} {
  2448.     pack forget .cf.fc.xscroll
  2449.     pack forget .cf.fyc.yc2
  2450.     } else {
  2451.     pack .cf.fc.xscroll -side bottom -fill x -before $c
  2452.     .cf.fyc.yc2 config -height [winfo height .cf.fc.xscroll]
  2453.     pack .cf.fyc.yc2 -side bottom -fill x -before .cf.fyc.yc
  2454.     }
  2455.     if {$doy} {
  2456.     pack forget .cf.fc.yscroll
  2457.     } else {
  2458.     pack .cf.fc.yscroll -side right -fill y -before $c
  2459.     }
  2460.  
  2461.     set ww [.of.c itemcget overwave -width]
  2462.     set v(scrh) [winfo height .of.xscroll]
  2463.     set totw [expr [winfo width .] - 2 * $v(scrh)]
  2464.     if {$ww != $totw && ![catch {pack info .of}]} {
  2465.     .of.c delete overwave
  2466.         if {$v(linkfile) && $f(sndfile) != ""} {
  2467.         .of.c create waveform $v(scrh) 0 -sound snd -height 20 \
  2468.             -width $totw -tags overwave -fill $v(fg) -debug $::debug \
  2469.         -shapefile [file rootname [file tail $f(spath)$f(sndfile)]].shape
  2470.     } else {
  2471.         .of.c create waveform $v(scrh) 0 -sound snd -height 20 \
  2472.             -width $totw -tags overwave -fill $v(fg) -debug $::debug
  2473.     }
  2474.     .of.c create rectangle -1 -1 -1 -1 -tags mark -fill yellow -stipple gray25
  2475.     }
  2476.     if {[snd length] > 0} DrawOverAxis
  2477. #    if {$::tcl_platform(platform) == "unix"} {
  2478. #    if {$v(propflag) > 1} { pack propagate . 0 }
  2479. #    }
  2480. #    if {$dox && $doy} { incr v(propflag) }
  2481. }
  2482.  
  2483. proc SetMsg {msg args} {
  2484.     global v
  2485.  
  2486.     if {$args == ""} {
  2487.     set v(msg) $msg
  2488.     .bf.lab config -state disabled
  2489.     } elseif {$args == "mark"} {
  2490.     set v(msg) $msg
  2491.     set v(currline) -1
  2492.     .bf.lab config -state normal
  2493.     } else {
  2494.     set v(msg) $msg
  2495.     set v(currline) $args
  2496.     .bf.lab config -state normal
  2497.     }
  2498.     SetCursor ""
  2499. }
  2500.  
  2501. proc InputFromMsgLine {key} {
  2502.     global v labels
  2503.     
  2504.     if {$key == "BackSpace"} return
  2505.     if {$v(currline) >= 0} {
  2506.     set labels [lreplace $labels $v(currline) $v(currline) $v(msg)]
  2507.     Redraw quick
  2508.     } else {
  2509.     if {[scan $v(msg) {From: %s to: %s length: %s ( %f - %f , %f} t0 t1 t2 t3 t4 t5] == 6} {
  2510.         if {$t0 != [lindex $v(fromto) 0]} {
  2511.         PutMarker m1 $t0 0 0
  2512.         }
  2513.         if {$t1 != [lindex $v(fromto) 1]} {
  2514.         set t2 [expr $t1-$t0]
  2515.         PutMarker m2 $t1 0 0
  2516.         }
  2517.         if {$t2 != [lindex $v(fromto) 2]} {
  2518.         set t1 [expr $t0+$t2]
  2519.         PutMarker m2 $t1 0 0
  2520.         }
  2521.         if {$t3 != [lindex $v(fromto) 3]} {
  2522.         set t0 [DTime2Time $t3]
  2523.         PutMarker m1 $t0 0 0
  2524.         }
  2525.         if {$t4 != [lindex $v(fromto) 4]} {
  2526.         set t1 [expr [DTime2Time $t4]-[DTime2Time $t3]]
  2527.         PutMarker m2 [DTime2Time $t4] 0 0
  2528.         }
  2529.         if {$t5 != [lindex $v(fromto) 5]} {
  2530.         set t1 [expr [DTime2Time $t3]+[DTime2Time $t5]]
  2531.         PutMarker m2 $t1 0 0
  2532.         }
  2533.         set t3 [format "%.3f" [Time2DTime $t0]]
  2534.         set t4 [format "%.3f" [Time2DTime $t1]]
  2535.         set t5 [format "%.3f" [expr $t4 - $t3]]
  2536.         SetMsg [format "From: %9s to: %9s length: %9s\t(%.3f - %.3f, %.3f)"\
  2537.             $t0 $t1 $t2 $t3 $t4 $t5] mark
  2538.         set v(fromto) [list $t0 $t1 $t2 $t3 $t4 $t5]
  2539.     }
  2540.     }
  2541. }
  2542.  
  2543. proc PlayToCursor {x} {
  2544.     global c f v
  2545.  
  2546.     Stop snd
  2547.     if {[snd length] == 0} return
  2548.     set start [Marker2Sample m1]
  2549.     set s [Coord2Sample [$c canvasx $x]]
  2550.     if {$s < $start} {
  2551.     set end $start
  2552.     set start $s
  2553.     } else {
  2554.     set end $s
  2555.     }
  2556.     SetMsg "Playing range: $start $end"
  2557.     set v(s0) $start
  2558.     set v(s1) $end
  2559.     Play snd $start $end
  2560.     set v(pause) 0
  2561.     .of.c create poly -1 -1 -1 -1 -1 -1 -fill red -tags playmark
  2562.     $c create poly -1 -1 -1 -1 -1 -1 -fill red -tags playmark
  2563.     after 50 PutPlayMarker
  2564. }
  2565.  
  2566. proc PlayMark {args} {
  2567.     global c f v
  2568.  
  2569.     Stop snd
  2570.     if {[snd length] == 0} return
  2571.     set start [Marker2Sample m1]
  2572.     set end   [Marker2Sample m2]
  2573.     if {$start > [snd length]} return
  2574.     if {[llength $args] > 0} {
  2575.     set x [Coord2Sample [$c canvasx [lindex $args 0]]]
  2576.     if {$x < $start} {
  2577.         set end $start
  2578.         set start 0
  2579.     }
  2580.     if {$x > $end} {
  2581.         set start $end
  2582.         set end [snd length]
  2583.     }
  2584.     }
  2585.     if {$start == $end} {
  2586.     set start $end
  2587.     set end [snd length]
  2588.     }
  2589.     SetMsg "Playing range: $start $end"
  2590.     set v(s0) $start
  2591.     set v(s1) $end
  2592.     Play snd $start $end
  2593.     set v(pause) 0
  2594.     .of.c create poly -1 -1 -1 -1 -1 -1 -fill red -tags playmark
  2595.     $c create poly -1 -1 -1 -1 -1 -1 -fill red -tags playmark
  2596.     after 50 PutPlayMarker
  2597. }
  2598.  
  2599. proc PlayAll {} {
  2600.     global c v
  2601.  
  2602.     Stop snd
  2603.     SetMsg "Playing all samples"
  2604.     set v(s0) 0
  2605.     set v(s1) [snd length]
  2606.     Play snd
  2607.     set v(pause) 0
  2608.     .of.c create poly -1 -1 -1 -1 -1 -1 -fill red -tags playmark
  2609.     $c create poly -1 -1 -1 -1 -1 -1 -fill red -tags playmark
  2610.     after 50 PutPlayMarker
  2611. }
  2612.  
  2613. proc Play {s {start 0} {end -1}} {
  2614.     global v
  2615.  
  2616.     if !$v(remote) {
  2617.     $s play -start $start -end $end
  2618.     } else {
  2619.     set sock [socket $v(ashost) $v(asport)]
  2620.     if {$end == -1} {
  2621.         set end [snd length]
  2622.     }
  2623.     set v(rp_s) $s
  2624.     set v(rp_sock) $sock
  2625.     set end2 $end
  2626.     if {$end2 > [expr $start + 10000]} {
  2627.         set end2 [expr $start + 10000]
  2628.     }
  2629.     set v(rp_next) $end2
  2630.     set v(rp_end) $end
  2631.     fconfigure $sock -translation binary -blocking 0
  2632.     puts -nonewline $sock play
  2633.     flush $sock
  2634.     set handle [gets $sock]
  2635.     set v(handle) $handle
  2636.     puts -nonewline $sock [$s data -fileformat au -start $start -end $end2]
  2637.     fileevent $sock writable PlayHandler
  2638.     }
  2639. }
  2640.  
  2641. proc PlayHandler {} {
  2642.     global v
  2643.  
  2644.     if {$v(rp_next) < $v(rp_end)} {
  2645.     set end2 $v(rp_end)
  2646.     if {$end2 > [expr $v(rp_next) + 10000]} {
  2647.         set end2 [expr $v(rp_next) + 10000]
  2648.     }
  2649.     puts -nonewline $v(rp_sock) [$v(rp_s) data -fileformat raw -start $v(rp_next) -end $end2 -byteorder bigEndian]
  2650.     set v(rp_next) $end2
  2651.     } else {
  2652.     close $v(rp_sock)
  2653.     }
  2654. }
  2655.  
  2656. proc Stop {s} {
  2657.     global v
  2658.  
  2659.     if !$v(remote) {
  2660.     $s stop
  2661.     } else {
  2662.     catch {close $v(rp_sock)}
  2663.     catch {set sock [socket $v(ashost) $v(asport)]}
  2664.     if ![info exists sock] return
  2665.     fconfigure $sock -translation binary
  2666.     puts -nonewline $sock stop
  2667.     puts $sock $v(handle)
  2668.     close $sock
  2669.     }
  2670. }
  2671.  
  2672. proc StopPlay {} {
  2673.     global c v
  2674.  
  2675.     after cancel PutPlayMarker
  2676.     Stop snd
  2677.     set v(pause) 0
  2678.     set v(s1) 0
  2679.     .of.c delete playmark
  2680.     $c delete playmark
  2681.     if $v(activerec) {
  2682.     after cancel UpdateRec
  2683.     Redraw
  2684.     event generate .cf.fc.c <Configure>
  2685.     MarkAll
  2686.     set v(activerec) 0
  2687.     }
  2688. }
  2689.  
  2690. proc PausePlay {} {
  2691.     global c v
  2692.  
  2693.     if $v(activerec) {
  2694.     snd pause
  2695.     return
  2696.     }
  2697.     set v(pause) [expr 1 - $v(pause)]
  2698.     if $v(pause) {
  2699.     after cancel PutPlayMarker
  2700.     set v(s0) [expr $v(s0) + int([snack::audio elapsedTime] * $v(rate))]
  2701.     Stop snd
  2702.     } else {
  2703.     after 50 PutPlayMarker
  2704.     Play snd $v(s0) $v(s1)
  2705.     }
  2706. }
  2707.  
  2708. proc PutPlayMarker {} {
  2709.     global v c
  2710.  
  2711.     if $v(pause) return
  2712.  
  2713.     set time [expr [snack::audio elapsedTime] + double($v(s0)) / $v(rate)]
  2714.     if {$time > [expr double($v(s1)) / $v(rate)] || ![snack::audio active]} {
  2715.     .of.c delete playmark
  2716.     $c delete playmark
  2717.     return
  2718.     }
  2719.     SetMsg "Playing at [format "%.2f" $time]"
  2720.     set ox [expr $v(scrh) + $time * $v(opps) / 1000.0]
  2721.     set x [expr ($time - double($v(startsmp)) / $v(rate)) * $v(pps)]
  2722.     set y [expr $v(waveh) + $v(spegh) + 4]
  2723.     .of.c coords playmark $ox 22 [expr $ox-5] 30 [expr $ox+5] 30 
  2724.     $c coords playmark $x $y [expr $x-5] [expr $y+10] [expr $x+5] [expr $y+10]
  2725.     update idletasks
  2726.     after 50 PutPlayMarker
  2727. }
  2728.  
  2729. proc InfoStr {arg} {
  2730.     global f v labels
  2731.  
  2732.     set samps [snd length]
  2733.     set time  [snd length -unit seconds]
  2734.     if {$arg == "path"} {
  2735.     set snd "$f(spath)$f(sndfile)"
  2736.     set lab "$f(lpath)$f(labfile)"
  2737.     } else {
  2738.     set snd $f(sndfile)
  2739.     set lab $f(labfile)
  2740.     }
  2741.     set info [format "Sample file: %s (%s)  %d samples %.2f seconds" $snd $v(smpfmt) $samps $time]
  2742.     if {$labels != {}} {
  2743.     set info "$info  Label file: $lab  ($v(labfmt))"
  2744.     }
  2745.     return $info
  2746. }
  2747.  
  2748. proc xsGetGeometry {} {
  2749.     scan [wm geometry .] "%dx%d+%d+%d" w h x y
  2750.     if {$::tcl_platform(platform) == "windows"} {
  2751.     return +$x+[expr $y+$h+40]
  2752.     } else {
  2753.     return +$x+[expr $y+$h+68]
  2754.     }
  2755. }
  2756.  
  2757. proc ToggleSpeg {} {
  2758.     global v
  2759.  
  2760.     if [snack::audio active] return
  2761.     if $v(showspeg) {
  2762.         set v(spegh) $v(remspegh)
  2763.     } else {
  2764.         set v(remspegh) $v(spegh)
  2765.         set v(spegh) 0
  2766.     }
  2767.     Redraw
  2768. }
  2769.  
  2770. proc ToggleRecording {} {
  2771.     global v
  2772.  
  2773.     if $v(recording) {
  2774.     .tb.rec config -state normal
  2775.     } else {
  2776.     .tb.rec config -state disabled
  2777.     }
  2778.  
  2779. }
  2780.  
  2781. proc Record {} {
  2782.     global c v rec
  2783.  
  2784.     StopPlay
  2785.     set v(smpchanged) 1
  2786.     if [winfo exist .of] { pack forget .of }
  2787.     $c delete obj
  2788.     .of.c delete overwave
  2789.     set width [winfo width $c]
  2790.     $c xview moveto 0
  2791.     if {$v(waveh) > 0} {
  2792.     $c create waveform 0 0 -sound snd -height $v(waveh) -pixels $v(pps) \
  2793.         -width $width -tags [list obj recwave] -channel $v(vchan) \
  2794.         -debug $::debug -fill red
  2795.     }
  2796.     if {$v(spegh) > 0} {
  2797.     $c create spectrogram 0 $v(waveh) -sound snd -height $v(spegh) \
  2798.         -pixels $v(pps) \
  2799.         -width $width -tags [list obj recwave] -channel $v(vchan) \
  2800.         -colormap $v($v(cmap)) -debug $::debug
  2801.     }
  2802.     if {$v(linkfile)} {
  2803.     catch {file delete -force _xs[pid].wav}
  2804.     snd configure -file _xs[pid].wav
  2805.     }
  2806.     snd record
  2807.     set v(activerec) 1
  2808.     after 100 UpdateRec
  2809. }
  2810.  
  2811. proc UpdateRec {} {
  2812.     global c v
  2813.  
  2814.     if {$v(activerec) == 0} return
  2815.     set secs [expr int([snd length -unit seconds])]
  2816.     set dec [format "%.2d" [expr int(100*([snd length -unit seconds] - $secs))]]
  2817.     set time [clock format $secs -format "Length: %M:%S.$dec"]
  2818. #    if {$secs > 9} {
  2819. #    $c delete recwave rectext
  2820. #    $c create text [expr [lindex [$c xview] 0] * $v(width) + 60] 20 \
  2821. #        -fill red -text $time -tags [list obj rectext]
  2822. #    update
  2823. #    }
  2824.     SetMsg $time
  2825.     after 100 UpdateRec
  2826. }
  2827.  
  2828. proc MoveBoundary {x} {
  2829.     global c labels v
  2830.  
  2831.     set coords [$c coords current]
  2832.     set x [$c canvasx $x]
  2833.     if {$x < 0} { set x 0 }
  2834.     set i [string trim [lindex [$c gettags current] 0] b]
  2835.     if [string match [$c type current] text] return
  2836.     if {$i == "obj" || $i == "mark" || $i == "axis" || $i == ""} {
  2837.     return
  2838.     }
  2839.  
  2840.     set h [expr $i - 1]
  2841.     set j [expr $i + 1]
  2842.  
  2843.     if {$v(lastmoved) != $i} {
  2844.     set v(labchanged) 1
  2845.     SetUndo $labels
  2846.     set v(lastmoved) $i
  2847.     }
  2848.  
  2849.     $c raise current
  2850.     set px 0
  2851.     set nx $v(width)
  2852.     set pb [$c find withtag b$h]
  2853.     set nb [$c find withtag b$j]
  2854.     if {$pb != ""} { set px [lindex [$c coords $pb] 0]}
  2855.     if {$nb != ""} { set nx [lindex [$c coords $nb] 0]}
  2856.  
  2857.     if {$x <= $px} { set x [expr $px + 1] }
  2858.     if {$nx <= $x} { set x [expr $nx - 1] }
  2859.  
  2860.     $c coords current $x [lindex $coords 1] $x [lindex $coords 3]
  2861.     set rest ""
  2862.  
  2863.     switch $v(labfmt) {
  2864.     TIMIT -
  2865.     HTK {
  2866.         scan [lindex $labels $i] {%d %d %s %[^º]} start stop label rest
  2867.         if {$j == [llength $labels]} { set length [expr $stop - $start] }
  2868.         set start [Coord2Time $x]
  2869.         if {$j == [llength $labels]} { set stop [expr $start + $length] }
  2870.         set labels [lreplace $labels $i $i "$start\n$stop\n$label\n$rest"]
  2871.         if {$h <= 0} return
  2872.         while {[lindex [lindex $labels $h] 0] == [lindex [lindex $labels $h] 1]} {
  2873.         set hlabel [lindex [lindex $labels $h] 2]
  2874.         set hrest [lindex [lindex $labels $h] 3]
  2875.         set labels [lreplace $labels $h $h "$start\n$start\n$hlabel\n$hrest"]
  2876.         incr h -1
  2877.         }
  2878.         set rest ""
  2879.         scan [lindex $labels $h] {%d %d %s %[^º]} start stop label rest
  2880.         if {$v(labfmt) == "HTK"} {
  2881.         set stop [expr [Coord2Time $x]-(10000000/$v(rate))]
  2882.         } else {
  2883.         set stop [Coord2Time $x]
  2884.         }
  2885.         set labels [lreplace $labels $h $h "$start\n$stop\n$label\n$rest"]
  2886.     }
  2887.     MIX {
  2888.         scan [lindex $labels $i] {%d %s %[^º]} start label rest
  2889.         set start [Coord2Time $x]
  2890.         set labels [lreplace $labels $i $i "$start\n$label\n$rest"]
  2891.     }
  2892.     WAVES {
  2893.         scan [lindex $labels $i] {%f %d %s %[^º]} end color label rest
  2894.         set end [Coord2Time $x]
  2895.         set labels [lreplace $labels $i $i "$end\n$color\n$label\n$rest"]
  2896.     }
  2897.     }
  2898.     SetMsg [Coord2Time $x]
  2899. }
  2900.  
  2901. proc SetLabelText {i label} {
  2902.     global labels v
  2903.  
  2904.     set rest ""
  2905.     switch $v(labfmt) {
  2906.     TIMIT -
  2907.     HTK {
  2908.         scan [lindex $labels $i] {%d %d %s %[^º]} start stop junk rest
  2909.         set labels [lreplace $labels $i $i "$start\n$stop\n$label\n$rest"]
  2910.     }
  2911.     MIX {
  2912.         scan [lindex $labels $i] {%d %s %[^º]} start junk rest
  2913.         set labels [lreplace $labels $i $i "$start\n$label\n$rest"]
  2914.     }
  2915.     WAVES {
  2916.         scan [lindex $labels $i] {%f %d %s %[^º]} end color junk rest
  2917.         set labels [lreplace $labels $i $i "$end\n$color\n$label\n$rest"]
  2918.     }
  2919.     }
  2920. }
  2921.  
  2922. proc Undo {} {
  2923.     global c v labels undo
  2924.  
  2925.     if {[cbs length] != 0} {
  2926.     eval $v(undoc)
  2927.     set tmp $v(undoc)
  2928.     set v(undoc) $v(redoc)
  2929.     set v(redoc) $tmp
  2930.     DrawOverAxis
  2931.     Redraw
  2932.     } else {
  2933.     set tmp $labels
  2934.     set labels $undo
  2935.     set undo $tmp
  2936.     Redraw quick
  2937.     }
  2938.     SetMsg ""
  2939. }
  2940.  
  2941. proc SetUndo {l} {
  2942.     global undo
  2943.  
  2944.     set undo $l
  2945.     .tb.undo config -state normal
  2946. }
  2947.  
  2948. proc MarkAll {} {
  2949.     global v
  2950.  
  2951.     PutMarker m1 0 0 0
  2952.     PutMarker m2 [Coord2Time $v(width)] 0 0
  2953. }
  2954.  
  2955. proc ZeroXAdjust {} {
  2956.     global v
  2957.     
  2958.     foreach m {m1 m2} {
  2959.     set start [Marker2Sample $m]
  2960.     snd sample [expr $start-100] ;# to fill sample buffer with leftmost
  2961.     for {set i 0} {$i < 100} {incr i} {
  2962.         set j [expr {$start + $i}]
  2963.         if {$j >= [snd length]} break
  2964.         if {$v(vchan) == 1} {
  2965.         set sample [lindex [snd sample $j] 1]
  2966.         set psample [lindex [snd sample [expr {$j-1}]] 1]
  2967.         } else {
  2968.         set sample [lindex [snd sample $j] 0]
  2969.         set psample [lindex [snd sample [expr {$j-1}]] 0]
  2970.         }
  2971.         if {[expr {$sample*$psample}] < 0} break
  2972.         set j [expr {$start - $i}]
  2973.         if {$j < 0} break
  2974.         if {$v(vchan) == 1} {
  2975.         set sample [lindex [snd sample $j] 1]
  2976.         set psample [lindex [snd sample [expr {$j-1}]] 1]
  2977.         } else {
  2978.         set sample [lindex [snd sample $j] 0]
  2979.         set psample [lindex [snd sample [expr {$j-1}]] 0]
  2980.         }
  2981.         if {[expr {$sample*$psample}] < 0} break
  2982.     }
  2983.     if {$i < 100} {
  2984.         PutMarker $m [Sample2Time $j] 0 0
  2985.     }
  2986.  
  2987.     }
  2988.     # Copied from PutMarker
  2989.     DrawZoom 1
  2990.     DrawSect
  2991.     set t1 [Marker2Time m1]
  2992.     set t2 [Marker2Time m2]
  2993.     set l  [expr $t2 - $t1]
  2994.     set tt1 [Time2DTime $t1]
  2995.     set tt2 [Time2DTime $t2]
  2996.     set ll  [expr $tt2 - $tt1]
  2997.     SetMsg [format "From: %9s to: %9s length: %9s\t(%.3f - %.3f, %.3f)"\
  2998.         $t1 $t2 $l $tt1 $tt2 $ll] mark
  2999.     set v(fromto) [list $t1 $t2 $l $tt1 $tt2 $ll]
  3000. }
  3001.  
  3002. proc InsertLabel {x y} {
  3003.     global c v labels
  3004.  
  3005.     set v(labchanged) 1
  3006.     SetUndo $labels
  3007.     InsertLabelEntry [Coord2Time [$c canvasx $x]]
  3008.  
  3009.     $c delete bound text
  3010.     Redraw quick
  3011. }
  3012.  
  3013. proc InsertLabelEntry {t} {
  3014.     global labels v
  3015.  
  3016.     set i 0
  3017.     switch $v(labfmt) {
  3018.     TIMIT -
  3019.     HTK {
  3020.         foreach l $labels {
  3021.         if {([lindex $l 0] < $t) && ([lindex $l 1] > $t)} { break }
  3022.         incr i
  3023.         }
  3024.         if {[llength $labels] == $i} { incr i -1 }
  3025.         if {$labels == ""} {
  3026.         set sto [DTime2Time [snd length -unit seconds]]
  3027.         set labels [list "$t\n$sto\nx"]
  3028.         } elseif {$t < [lindex [lindex $labels 0] 0]} {
  3029.         set sto [lindex [lindex $labels 0] 0]
  3030.         set labels [linsert $labels 0 "$t\n$sto\nx"]
  3031.         } elseif {[llength $labels] == [expr $i+1]} {
  3032.         set sta1 [lindex [lindex $labels $i] 0]
  3033.         set sto1 $t
  3034.         set lab1 [lindex [lindex $labels $i] 2]
  3035.         set sta2 $t
  3036.         set sto2 [lindex [lindex $labels $i] 1]
  3037.         set lab2 x
  3038.         set labels [lreplace $labels $i $i "$sta1\n$sto1\n$lab1" "$sta2\n$sto2\n$lab2"]
  3039.             } else {
  3040.         SetMsg [lindex [lindex $labels $i] 2]
  3041.         set sta1 [lindex [lindex $labels $i] 0]
  3042.         set sto1 $t
  3043.         set lab1 [lindex [lindex $labels $i] 2]
  3044.         set sta2 $t
  3045.         set sto2 [lindex [lindex $labels [expr $i+1]] 0]
  3046.         set lab2 x
  3047.         set labels [lreplace $labels $i $i "$sta1\n$sto1\n$lab1" "$sta2\n$sto2\n$lab2"]
  3048.             }
  3049.     }
  3050.     MIX {
  3051.         foreach l $labels {
  3052.         if {[lindex $l 0] > $t} { break }
  3053.         incr i
  3054.         }
  3055.         SetMsg [lindex [lindex $labels $i] 1]
  3056.         set labels [linsert $labels $i "$t\nx"]
  3057.     }
  3058.     WAVES {
  3059.         foreach l $labels {
  3060.         if {[lindex $l 0] > $t} { break }
  3061.         incr i
  3062.         }
  3063.         SetMsg [lindex [lindex $labels $i] 1]
  3064.         set labels [linsert $labels $i "$t\n121\nx"]
  3065.     }
  3066.     }
  3067. }
  3068.  
  3069. proc DeleteLabel {x y} {
  3070.     global c v labels
  3071.  
  3072.     set v(labchanged) 1
  3073.     SetUndo $labels
  3074.     if {[string compare [lindex [$c gettags [$c find closest\
  3075.         [$c canvasx $x] [$c canvasy $y]]] 2] text] == 0} {
  3076.     set i [lindex [$c gettags [$c find closest\
  3077.         [$c canvasx $x] [$c canvasy $y]]] 0]
  3078.     RemoveLabelEntry $i
  3079.  
  3080.     $c delete bound text
  3081.     Redraw quick
  3082.     }
  3083. }
  3084.  
  3085. proc RemoveLabelEntry {i} {
  3086.     global labels v
  3087.  
  3088.     switch $v(labfmt) {
  3089.     TIMIT -
  3090.     HTK {
  3091.         set start [lindex [lindex $labels [expr $i-1]] 0]
  3092.         set stop  [lindex [lindex $labels $i] 1]
  3093.         set label [lindex [lindex $labels [expr $i-1]] 2]
  3094.         set labels [lreplace $labels [expr $i-1] $i "$start\n$stop\n$label"]
  3095.     }
  3096.     WAVES -
  3097.     MIX {
  3098.         set labels [lreplace $labels $i $i]
  3099.     }
  3100.     }
  3101. }
  3102.  
  3103. # if called by clicking on the text of a label, this label will be aligned to 
  3104. # the selection
  3105. # FIXME: but this isn't foolproofed because if there is another label between 
  3106. # the one to change and the selection only the selected label 
  3107. # (and with HTK-format the right neighbour) will be changed ...
  3108.  
  3109. proc AlignLabel {x y} {
  3110.     global c v labels
  3111.  
  3112.     set v(labchanged) 1
  3113.     SetUndo $labels
  3114.     if {[string compare [lindex [$c gettags [$c find closest\
  3115.         [$c canvasx $x] [$c canvasy $y]]] 2] text] == 0} {
  3116.     set i [lindex [$c gettags [$c find closest\
  3117.         [$c canvasx $x] [$c canvasy $y]]] 0]
  3118.  
  3119.     SetUndo $labels
  3120.     set start [Marker2Time m1]
  3121.     set end   [Marker2Time m2]
  3122.     set rest ""
  3123.  
  3124.     switch $v(labfmt) {
  3125.         TIMIT -
  3126.         HTK {
  3127.         scan [lindex $labels $i] {%d %d %s %[^º]} junk junk label rest
  3128.         set labels [lreplace $labels $i $i "$start\n$end\n$label\n$rest"]
  3129.         set rest ""
  3130.         set j [expr $i-1]
  3131.         if {$j >= 0} {
  3132.             scan [lindex $labels $j] {%d %d %s %[^º]} st junk label rest
  3133.             set labels [lreplace $labels $j $j "$st\n$start\n$label\n$rest"]
  3134.         }
  3135.         set rest ""
  3136.         set j [expr $i+1]
  3137.         if {$j < [llength $labels]} {
  3138.             scan [lindex $labels $j] {%d %d %s %[^º]} junk st label rest
  3139.             set labels [lreplace $labels $j $j "$end\n$st\n$label\n$rest"]
  3140.         }
  3141.         }
  3142.         MIX {
  3143.         scan [lindex $labels $i] {%d %s %[^º]} junk label rest
  3144.         set labels [lreplace $labels $i $i "$start\n$label\n$rest"]
  3145.         set rest ""
  3146.         set j [expr $i+1]
  3147.         catch {scan [lindex $labels $j] {%d %s %[^º]} junk label rest}
  3148.         catch {set labels [lreplace $labels $j $j "$end\n$label\n$rest"]}
  3149.         }
  3150.         WAVES {
  3151.         scan [lindex $labels $i] {%f %d %s %[^º]} junk color label rest
  3152.         set labels [lreplace $labels $i $i "$end\n$color\n$label\n$rest"]
  3153.         set rest ""
  3154.         set j [expr $i-1]
  3155.         if {$j >= 0} {
  3156.             scan [lindex $labels $j] {%f %d %s %[^º]} junk color label rest
  3157.             set labels [lreplace $labels $j $j "$start\n$color\n$label\n$rest"]
  3158.         }
  3159.         }
  3160.     }
  3161.  
  3162.     $c delete bound text
  3163.     Redraw quick
  3164.     } else {
  3165.     puts "AlignLabel error: x=$x; y=$y"
  3166.     } 
  3167. }
  3168.  
  3169. proc CropLabels {cstart cend} {
  3170.     global labels v
  3171.  
  3172.     set l {}
  3173.     switch $v(labfmt) {
  3174.     TIMIT -
  3175.     HTK {
  3176.         foreach row $labels {
  3177.         set rest ""
  3178.         scan $row {%d %d %s %[^º]} start stop label rest]
  3179.         if {$cend < $start} {
  3180.         } elseif {$cend > $start && $cend < $stop} {
  3181.             set start [expr $start - $cstart]
  3182.             set stop  [expr $cend - $cstart]
  3183.             lappend l "$start\n$stop\n$label\n$rest"
  3184.         } elseif {$cstart > $start && $cstart < $stop} {
  3185.             set start 0
  3186.             set stop  [expr $stop  - $cstart]
  3187.             lappend l "$start\n$stop\n$label\n$rest"
  3188.         } elseif {$cstart < $start} {
  3189.             set start [expr $start - $cstart]
  3190.             set stop  [expr $stop  - $cstart]
  3191.             lappend l "$start\n$stop\n$label\n$rest"
  3192.         }
  3193.         }
  3194.     }
  3195.     MIX {
  3196.         foreach row $labels {
  3197.         set rest ""
  3198.         scan $row {%d %s %[^º]} start label rest
  3199.         if {$cend < $start} {
  3200.         } elseif {$cstart > $start} {
  3201.             set l [list "0\n$label\n$rest"]
  3202.         } elseif {$cstart < $start} {
  3203.             set start [expr $start - $cstart]
  3204.             lappend l "$start\n$label\n$rest"
  3205.         }
  3206.         }
  3207.     }
  3208.     WAVES {
  3209.         set flag 0
  3210.         foreach row $labels {
  3211.         set rest ""
  3212.         scan $row {%f %d %s %[^º]} end color label rest
  3213.         if {$cend < $end && $flag} {
  3214.             set end [expr $cend - $cstart]
  3215.             lappend l "$end\n$color\n$label\n$rest"
  3216.             break
  3217.         }
  3218.         if {$cstart < $end} {
  3219.             set end [expr $end - $cstart]
  3220.             lappend l "$end\n$color\n$label\n$rest"
  3221.             set flag 1
  3222.         }
  3223.         }
  3224.     }
  3225.     }
  3226.     return $l
  3227. }
  3228.  
  3229. # moves the startpoint of the right label to the cursorposition
  3230.  
  3231. proc GetRightLabel {x y} {
  3232.     global c labels v
  3233.  
  3234.     set t [Coord2Time [$c canvasx $x]]
  3235.     set i 0
  3236.     set v(labchanged) 1
  3237.     SetUndo $labels
  3238.     set rest ""
  3239.     switch $v(labfmt) {
  3240.     TIMIT -
  3241.     HTK {
  3242.         foreach l $labels {
  3243.         if {$t < [lindex $l 0]} { break }
  3244.         if {([lindex $l 0] < $t) && ([lindex $l 1] > $t)} { break }
  3245.         incr i
  3246.         }
  3247.         if {[llength $labels] <= [expr $i+1]} return
  3248.         if {$t < [lindex [lindex $labels 0] 0]} {
  3249.         set sto [lindex [lindex $labels 0] 1]
  3250.         set lab [lindex [lindex $labels 0] 2]
  3251.         set labels [lreplace $labels 0 0 "$t\n$sto\n$lab"]
  3252.         } elseif {[llength $labels] == [expr $i-1]} {
  3253.         set sta1 [lindex [lindex $labels $i] 0]
  3254.         set sto1 $t
  3255.         set lab1 [lindex [lindex $labels $i] 2]
  3256.         set labels [lreplace $labels $i $i "$sta1\n$sto1\n$lab1"]
  3257.         SetMsg [lindex [lindex $labels $i] 2]        
  3258.             } else {
  3259.         set sta1 [lindex [lindex $labels $i] 0]
  3260.         set sto1 $t
  3261.         set lab1 [lindex [lindex $labels $i] 2]
  3262.         set sta2 $t
  3263.         set sto2 [lindex [lindex $labels [expr $i+1]] 1]
  3264.         set lab2 [lindex [lindex $labels [expr $i+1]] 2]
  3265.         set labels [lreplace $labels $i [expr $i+1] "$sta1\n$sto1\n$lab1" "$sta2\n$sto2\n$lab2"]
  3266.         SetMsg [lindex [lindex $labels $i] 2]
  3267.             }
  3268.         }
  3269.     MIX {
  3270.         foreach l $labels {
  3271.         if {[lindex $l 0] > $t} { break }
  3272.         incr i
  3273.         }
  3274.         if {$i == [llength $labels]} return
  3275.         scan [lindex $labels $i] {%d %s %[^º]} junk label rest
  3276.         set labels [lreplace $labels $i $i "$t\n$label\n$rest"]
  3277.         SetMsg [lindex [lindex $labels $i] 1]
  3278.     }
  3279.     WAVES {
  3280.         foreach l $labels {
  3281.         if {([lindex $l 0] > $t)} { break }
  3282.         incr i
  3283.         }
  3284.         if {$i == [llength $labels]} return
  3285.         scan [lindex $labels $i] {%f %d %s %[^º]} junk color label rest
  3286.         set labels [lreplace $labels $i $i "$t\n$color\n$label\n$rest"]
  3287.         SetMsg [lindex [lindex $labels $i] 1]
  3288.     }
  3289.     }
  3290.     $c delete bound text
  3291.     Redraw quick
  3292. }
  3293.  
  3294. proc PlayLabel {x y} {
  3295.     global c labels v
  3296.  
  3297.     set t [Coord2Time [$c canvasx $x]]
  3298.     set i 0
  3299.     switch $v(labfmt) {
  3300.     TIMIT -
  3301.     HTK {
  3302.         foreach l $labels {
  3303.         if {([lindex $l 0] < $t) && ([lindex $l 1] > $t)} { break }
  3304.         incr i
  3305.         }
  3306.         if {[llength $labels] == $i} { incr i -1 }
  3307.     }
  3308.     MIX {
  3309.         foreach l $labels {
  3310.         if {[lindex $l 0] > $t} { break }
  3311.         incr i
  3312.         }
  3313.         incr i -1
  3314.     }
  3315.     WAVES {
  3316.         foreach l $labels {
  3317.         if {[lindex $l 0] > $t} { break }
  3318.         incr i
  3319.         }
  3320.     }
  3321.     }
  3322.     PlayNthLab $i
  3323. }
  3324.  
  3325. proc PlayNthLab {n} {
  3326.     global labels v
  3327.     
  3328.     switch $v(labfmt) {
  3329.     TIMIT -
  3330.     HTK {
  3331.         set start [lindex [lindex $labels $n] 0]
  3332.         set stop  [lindex [lindex $labels $n] 1]
  3333.         Play snd [Time2Sample $start] [Time2Sample $stop]
  3334.     }
  3335.     MIX {
  3336.         set start [lindex [lindex $labels $n] 0]
  3337.         if {$n == -1} { set start 0 }
  3338.         catch {set stop  [lindex [lindex $labels [expr $n + 1]] 0]}
  3339.         if {$stop == ""} { set stop [Coord2Time $v(width)] }
  3340.         Play snd [Time2Sample $start] [Time2Sample $stop]
  3341.     }
  3342.     WAVES {
  3343.         set start [lindex [lindex $labels [expr $n - 1]] 0]
  3344.         if {$start == ""} { set start 0 }
  3345.         set stop  [lindex [lindex $labels $n] 0]
  3346.         Play snd [Time2Sample $start] [Time2Sample $stop]
  3347.     }
  3348.     }
  3349. }
  3350.  
  3351. proc MarkLabel {x y} {
  3352.     global c labels v
  3353.  
  3354.     set t [Coord2Time [$c canvasx $x]]
  3355.     set i 0
  3356.     switch $v(labfmt) {
  3357.       TIMIT -
  3358.       HTK {
  3359.           foreach l $labels {
  3360.               if {([lindex $l 0] < $t) && ([lindex $l 1] > $t)} { break }
  3361.               incr i
  3362.           }
  3363.           if {[llength $labels] == $i} { incr i -1 }
  3364.       }
  3365.       MIX {
  3366.           foreach l $labels {
  3367.               if {[lindex $l 0] > $t} { break }
  3368.               incr i
  3369.           }
  3370.           incr i -1
  3371.       }
  3372.       WAVES {
  3373.           foreach l $labels {
  3374.               if {[lindex $l 0] > $t} { break }
  3375.               incr i
  3376.           }
  3377.       }
  3378.     }
  3379.     MarkNthLab $i
  3380. }
  3381.  
  3382. proc MarkNthLab {n} {
  3383.     global labels v
  3384.     
  3385.     switch $v(labfmt) {
  3386.       TIMIT -
  3387.       HTK {
  3388.           set start [lindex [lindex $labels $n] 0]
  3389.           set stop  [lindex [lindex $labels $n] 1]
  3390.       }
  3391.       MIX {
  3392.           set start [lindex [lindex $labels $n] 0]
  3393.           if {$n == -1} { set start 0 }
  3394.           catch {set stop  [lindex [lindex $labels [expr $n + 1]] 0]}
  3395.           if {$stop == ""} { set stop [Coord2Time $v(width)] }
  3396.       }
  3397.       WAVES {
  3398.           set start [lindex [lindex $labels [expr $n - 1]] 0]
  3399.           if {$start == ""} { set start 0 }
  3400.           set stop  [lindex [lindex $labels $n] 0]
  3401.       }
  3402.       default {
  3403.           puts "Wrong Labelformat $v(labfmt)"
  3404.           return
  3405.       }
  3406.     }
  3407.     # cause the left marker is always m1 we have to move the marker
  3408.     # in the right order
  3409.     if {$start > [Marker2Time m2]} {
  3410.       PutMarker m2 $stop 0 0
  3411.       SendPutMarker m2 [Time2Coord $stop]
  3412.       PutMarker m1 $start 0 0
  3413.       SendPutMarker m1 [Time2Coord $start]
  3414.     } else {
  3415.       PutMarker m1 $start 0 0
  3416.       SendPutMarker m1 [Time2Coord $start]
  3417.       PutMarker m2 $stop 0 0
  3418.       SendPutMarker m2 [Time2Coord $stop]
  3419.     }
  3420. }
  3421.  
  3422.  
  3423. proc SetRaw {} {
  3424.     global v
  3425.  
  3426.     StopPlay
  3427.     set v(smpchanged) 1
  3428.     snd config -rate $v(rate) -encoding $v(sfmt) -channels $v(chan)
  3429.     Redraw
  3430.     Reconf
  3431. }
  3432.  
  3433. proc Convert {encoding rate channels} {
  3434.     global v c
  3435.  
  3436.     SetCursor watch    
  3437.     StopPlay
  3438.     $c delete speg wave
  3439.     cbs copy snd
  3440.     if [catch {
  3441.     if {$rate != ""} {
  3442.         SetMsg "Converting sample rate [snd cget -rate] -> $rate"
  3443.         snd convert -rate $rate -progress snack::progressCallback
  3444.         set v(rate) [snd cget -rate]
  3445.         set v(undoc) "snd copy cbs"
  3446.         set v(redoc) "snd convert -rate $rate -progress snack::progressCallback"
  3447.     }
  3448.     if {$encoding != ""} {
  3449.         SetMsg "Converting sample encoding [snd cget -encoding] -> $encoding"
  3450.         snd convert -encoding $encoding -progress snack::progressCallback
  3451.         set v(sfmt) [snd cget -encoding]
  3452.         set v(undoc) "snd copy cbs"
  3453.         set v(redoc) "snd convert -encoding $encoding -progress snack::progressCallback"
  3454.     }
  3455.     if {$channels != ""} {
  3456.         SetMsg "Converting number of channels [snd cget -channels] -> $channels"
  3457.         snd convert -channels $channels -progress snack::progressCallback
  3458.         set v(chan) [snd cget -channels]
  3459.         set v(undoc) "snd copy cbs"
  3460.         set v(redoc) "snd convert -channels $channels -progress snack::progressCallback"
  3461.     }
  3462.     }] {
  3463.     SetMsg "Convert cancelled"
  3464.     }
  3465.  
  3466.     Redraw
  3467.     set v(smpchanged) 1
  3468.     .tb.undo config -state normal
  3469. }
  3470.  
  3471. proc Time2Sample {t} {
  3472.     global v
  3473.  
  3474.     switch $v(labfmt) {
  3475.     HTK {
  3476.         expr {int($t/(10000000/$v(rate)))}
  3477.     }
  3478.     TIMIT -
  3479.     MIX {
  3480.         expr {int($t)}
  3481.     }
  3482.     WAVES {
  3483.         expr {int($t*$v(rate))}
  3484.     }
  3485.     }
  3486. }
  3487.  
  3488. proc Sample2Time {s} {
  3489.     global v
  3490.  
  3491.     switch $v(labfmt) {
  3492.     HTK {
  3493.         expr {int($s*(10000000.0/$v(rate)))}
  3494.     }
  3495.     TIMIT -
  3496.     MIX {
  3497.         set s
  3498.     }
  3499.     WAVES {
  3500.         expr {double($s)/$v(rate)}
  3501.     }
  3502.     }
  3503. }
  3504.  
  3505. proc TimeRound {t} {
  3506.     global v
  3507.  
  3508.     switch $v(labfmt) {
  3509.     HTK -
  3510.     TIMIT -
  3511.     MIX {
  3512.         expr {int($t)}
  3513.     }
  3514.     WAVES {
  3515.         expr {$t}
  3516.     }
  3517.     }
  3518. }
  3519.  
  3520. proc Time2Coord {t} {
  3521.     global v
  3522.  
  3523.     switch $v(labfmt) {
  3524.     HTK {
  3525.         expr {(($t-10000000*(double($v(startsmp))/$v(rate)))/((10000000.0/$v(rate))*$v(rate)/$v(pps)))}
  3526.     }
  3527.     TIMIT -
  3528.     MIX {
  3529.         expr {(($t - $v(startsmp)) / (double($v(rate))/$v(pps)))}
  3530.     }
  3531.     WAVES {
  3532.         expr {(($t - (double($v(startsmp))/$v(rate)) )*$v(pps))}
  3533.     }
  3534.     }
  3535. }
  3536.  
  3537. proc Time2DTime {t} {
  3538.     global v
  3539.  
  3540.     switch $v(labfmt) {
  3541.     HTK {
  3542.         expr {($t/10000000.0)}
  3543.     }
  3544.     WAVES {
  3545.         expr {$t}
  3546.     }
  3547.     TIMIT -
  3548.     MIX -
  3549.     default {
  3550.         expr {double($t)/$v(rate)}
  3551.     }
  3552.     }
  3553. }
  3554.  
  3555. proc DTime2Time {t} {
  3556.     global v
  3557.  
  3558.     switch $v(labfmt) {
  3559.     HTK {
  3560.         expr {int($t*10000000.0)}
  3561.     }
  3562.     WAVES {
  3563.         expr {$t}
  3564.     }
  3565.     TIMIT -
  3566.     MIX -
  3567.     default {
  3568.         expr {int($t*$v(rate))}
  3569.     }
  3570.     }
  3571. }
  3572.  
  3573. proc Coord2Time {x} {
  3574.     global v
  3575.  
  3576.     switch $v(labfmt) {
  3577.     HTK {
  3578.         expr {int(($x*$v(rate)/$v(pps)+$v(startsmp))*(10000000.0/$v(rate)))}
  3579.     }
  3580.     WAVES {
  3581.         expr {double($x)/$v(pps)+double($v(startsmp))/$v(rate)}
  3582.     }
  3583.     TIMIT -
  3584.     MIX -
  3585.     default {
  3586.         expr {int($v(startsmp)+$x*(double($v(rate))/$v(pps)))}
  3587.     }
  3588.     }
  3589. }
  3590.  
  3591. proc Coord2Sample {x} {
  3592.     global v
  3593.  
  3594.     expr {int($v(startsmp)+$x*double($v(rate))/$v(pps))}
  3595. }
  3596.  
  3597. proc BoundaryEnter {x} {
  3598.     global c _mb
  3599.  
  3600.     set _mb 1
  3601.     $c itemconfig current -fill red
  3602.     $c configure -cursor sb_h_double_arrow
  3603. }
  3604.  
  3605. proc BoundaryLeave {x} {
  3606.     global c v
  3607.  
  3608.     $c itemconfig current -fill $v(fg)
  3609.     $c configure -cursor {}
  3610. }
  3611.  
  3612. proc MarkerEnter {x} {
  3613.     global c
  3614.  
  3615.     $c itemconfig current -fill red
  3616.     $c configure -cursor sb_h_double_arrow
  3617. }
  3618.  
  3619. proc MarkerLeave {x} {
  3620.     global c v
  3621.  
  3622.     $c itemconfig current -fill $v(fg)
  3623.     $c configure -cursor {}
  3624. }
  3625.  
  3626. proc PutMarker {m x y f} {
  3627.     global c v _mx _mb
  3628.  
  3629.     if {$_mx == 0} return
  3630.     if {$y > [expr $v(waveh) + $v(spegh) + $v(timeh)]} {
  3631.     if {$_mb == 1 && $f == 1} {
  3632.         MoveBoundary $x
  3633.     }
  3634.     return
  3635.     }
  3636.     if {$f == 1} {
  3637.     if {$x < 0 && [lindex [$c xview] 0] > 0} {
  3638.         $c xview scroll -1 unit
  3639.         update
  3640.         SendXScroll
  3641.     }
  3642.     if {$x >= [winfo width $c]} {
  3643.         $c xview scroll 1 unit
  3644.         update
  3645.         SendXScroll
  3646.     }
  3647.  
  3648.     set xc [$c canvasx $x]
  3649.  
  3650.     if {$xc < 0} { set xc 0 }
  3651.     if {$xc > $v(width)} { set xc $v(width) }
  3652.  
  3653.     set t [Coord2Time $xc]
  3654.     } else {
  3655.     set xc [Time2Coord $x]
  3656.     set t $x
  3657.     }
  3658.     if {$t >= [snd length]} {
  3659.       set t [expr {[snd length]-1}]
  3660.     }
  3661.     $c itemconf $m -tags [list mark $t $m]
  3662.     $c coords $m $xc 0 $xc $v(toth)
  3663.  
  3664.     if {$m == "m1"} {
  3665.     set tm2 [Marker2Time m2]
  3666.     if {$t > $tm2} {
  3667.         $c itemconf m2 -tags [list mark $tm2 m3]
  3668.         $c itemconf m1 -tags [list mark $t m2]
  3669.         $c itemconf m3 -tags [list mark [Marker2Time m3] m1]
  3670.     }
  3671.     } else {
  3672.     set tm1 [Marker2Time m1]
  3673.     if {$t < $tm1} {
  3674.         $c itemconf m1 -tags [list mark $tm1 m3]
  3675.         $c itemconf m2 -tags [list mark $t m1]
  3676.         $c itemconf m3 -tags [list mark [Marker2Time m3] m2]
  3677.     }
  3678.     }
  3679.  
  3680.     if {$v(fillmark)} {
  3681.     $c coords mfill [Time2Coord [Marker2Time m1]] 0 \
  3682.                 [Time2Coord [Marker2Time m2]] $v(toth)
  3683.     }
  3684.  
  3685.     set ox1 [expr $v(scrh) + [Time2DTime [Marker2Time m1]] * $v(opps) / 1000.0]
  3686.     set ox2 [expr $v(scrh) + [Time2DTime [Marker2Time m2]] * $v(opps) / 1000.0]
  3687.     .of.c coords mark $ox1 2 $ox2 30
  3688.  
  3689.     if {$f == 1} {
  3690.     DrawZoom 1
  3691.     DrawSect
  3692.     set t1 [Marker2Time m1]
  3693.     set t2 [Marker2Time m2]
  3694.     set l  [expr $t2 - $t1]
  3695.     set tt1 [Time2DTime $t1]
  3696.     set tt2 [Time2DTime $t2]
  3697.     set ll  [expr $tt2 - $tt1]
  3698.     SetMsg [format "From: %9s to: %9s length: %9s\t(%.3f - %.3f, %.3f)"\
  3699.         $t1 $t2 $l $tt1 $tt2 $ll] mark
  3700.     set v(fromto) [list $t1 $t2 $l $tt1 $tt2 $ll]
  3701.     }
  3702.  
  3703.     foreach p $v(plugins) {
  3704.     namespace inscope $p Putmark $m
  3705.     }
  3706.     update
  3707. }
  3708.  
  3709. proc SendPutMarker {m x} {
  3710.     global c v
  3711.  
  3712.     set xc [$c canvasx $x]
  3713.     if {$v(mlink) == 1} {
  3714.     foreach prg [winfo interps] {
  3715.         if [regexp .*xs.* $prg] {
  3716.         if {[winfo name .] != $prg} {
  3717.             set t [Coord2Time $xc]
  3718.             send $prg PutMarker $m $t 0 0
  3719.         }
  3720.         }
  3721.     }
  3722.     }
  3723. }
  3724.  
  3725. proc Marker2Sample {m} {
  3726.     global c
  3727.  
  3728.     Time2Sample [lindex [$c gettags $m] 1]
  3729. }
  3730.  
  3731. proc Marker2Time {m} {
  3732.     global c
  3733.  
  3734.     lindex [$c gettags $m] 1
  3735. }
  3736.  
  3737. proc DrawCrossHairs {} {
  3738.     global c v
  3739.  
  3740.     if {$v(ch)} {
  3741.     $c delete ch1 ch2
  3742.     if {$::tcl_platform(platform) == "windows"} {
  3743. #        $c create line 0 0 0 0 -width 2 -stipple gray50 -tags [list ch1]\
  3744. #            -fill $v(gridcolor)
  3745. #        $c create line 0 0 0 0 -width 2 -stipple gray50 -tags [list ch2]\
  3746. #            -fill $v(gridcolor)
  3747.         $c create line 0 0 0 0 -width 1 -tags [list ch1]\
  3748.             -fill $v(gridcolor)
  3749.         $c create line 0 0 0 0 -width 1 -tags [list ch2]\
  3750.             -fill $v(gridcolor)
  3751.     } else {
  3752.         $c create line 0 0 0 0 -width 1 -stipple gray50 -tags [list ch1]\
  3753.             -fill $v(gridcolor)
  3754.         $c create line 0 0 0 0 -width 1 -stipple gray50 -tags [list ch2]\
  3755.             -fill $v(gridcolor)
  3756.     }
  3757.     $c lower ch1 m1
  3758.     $c lower ch2 m1
  3759.     } else {
  3760.     $c delete ch1 ch2
  3761.     }
  3762. }
  3763.  
  3764. proc PutCrossHairs {x y} {
  3765.     global c v
  3766.  
  3767.     set xc [$c canvasx $x]
  3768.     set yc [$c canvasy $y]
  3769.     set f 0.0
  3770.     catch { set f [expr $v(topfr) * ($v(spegh) - ($yc - $v(waveh))) / $v(spegh)]}
  3771.     if {$f < 0.0} { set f 0.0 }
  3772.     if {$f > 0.5*$v(rate)} { set f [expr 0.5*$v(rate)] }
  3773.  
  3774.     if {$v(ch)} {
  3775.     $c coords ch1 $xc 0 $xc $v(toth)
  3776.     $c coords ch2 0 $yc $v(width) $yc
  3777.     set s [Coord2Time $xc]
  3778.     set t [expr double($xc) / $v(pps)]
  3779.  
  3780.     SetMsg "time: $t\tsample: $s\tfrequency: $f"
  3781.     } else {
  3782.     $c coords ch1 -1 -1 -1 -1
  3783.     $c coords ch2 -1 -1 -1 -1
  3784.     }
  3785.     if [winfo exists .sect] { DrawSectMarks f $f }
  3786. }
  3787.  
  3788. proc OpenSectWindow {} {
  3789.     global s v
  3790.  
  3791.     catch {destroy .sect}
  3792.     toplevel .sect -width $s(sectwinw) -height $s(sectwinh)
  3793.     wm title .sect "Spectrum section plot"
  3794.     wm geometry .sect +$s(sectwinx)+$s(sectwiny)
  3795.     pack propagate .sect 0
  3796.  
  3797.     set s(ostart) ""
  3798.  
  3799.     pack [frame .sect.f] -side bottom -fill x
  3800.     label .sect.f.lab -width 1 -relief sunken -bd 1 -anchor w
  3801.     pack .sect.f.lab -side left -expand yes -fill x
  3802.     pack [button .sect.f.exitB -text Close -command {destroy .sect}] -side left
  3803.     pack [canvas .sect.c -closeenough 5 -cursor draft_small -bg $v(bg)] -fill both -expand true
  3804.  
  3805.     pack [frame .sect.f1]
  3806.     label .sect.f1.l1 -text "FFT points:" -anchor w
  3807. #    pack [entry .sect.f2.e1 -textvar s(fftlen) -wi 6] -side left
  3808.     tk_optionMenu .sect.f1.m1 s(fftlen) 64 128 256 512 1024 2048 4096 8192 16384
  3809.     for {set n 0} {$n < 7} {incr n} {
  3810.       .sect.f1.m1.menu entryconfigure $n -command DrawSect
  3811.     }
  3812.     label .sect.f1.l2 -text "Window:"
  3813.     tk_optionMenu .sect.f1.m2 s(wintype) \
  3814.     Hamming Hanning Bartlett Blackman Rectangle
  3815.     pack .sect.f1.l1 .sect.f1.m1 .sect.f1.l2 .sect.f1.m2 -side left
  3816. #    pack [label .sect.f2.l2 -text "Preemphasis:" -anchor w] -side left
  3817. #    pack [entry .sect.f2.e2 -textvar s(ref) -wi 6] -side left
  3818.  
  3819.     pack [frame .sect.f2]
  3820.     label .sect.f2.l1 -text "Analysis:"
  3821.     tk_optionMenu .sect.f2.m1 s(atype) FFT LPC
  3822.     .sect.f2.m1.menu entryconfigure 0 -command [list LPCcontrols disabled]
  3823.     .sect.f2.m1.menu entryconfigure 1 -command [list LPCcontrols normal]
  3824.     label .sect.f2.l2 -text "Order:"
  3825.     entry .sect.f2.e -textvariable s(lpcorder) -width 3
  3826.     scale .sect.f2.s -variable s(lpcorder) -from 1 -to 40 -orient horiz \
  3827.     -length 80 -show no
  3828.     bind .sect.f2.s <Button1-Motion> DrawSect
  3829.     pack .sect.f2.l1 .sect.f2.m1 .sect.f2.l2 .sect.f2.e .sect.f2.s -side left
  3830.     if {$s(atype) != "LPC"} { LPCcontrols disabled }
  3831.     if {$s(lpcorder) < 1} { set s(lpcorder) 20 }
  3832.  
  3833.     pack [frame .sect.f3]
  3834.     pack [label .sect.f3.l2 -text "Reference:" -anchor w] -side left
  3835.     pack [entry .sect.f3.e2 -textvar s(ref) -wi 6] -side left
  3836.     pack [label .sect.f3.u1 -text "dB" -anchor w] -side left
  3837.     pack [label .sect.f3.l3 -text "Range:" -anchor w] -side left
  3838.     pack [entry .sect.f3.e3 -textvar s(range) -wi 5] -side left
  3839.     pack [label .sect.f3.u2 -text "dBfs" -anchor w] -side left
  3840.  
  3841. #    label $w.r.f11.l -text "Analysis bandwidth (Hz):" -width 25 -anchor w
  3842. #    entry $w.r.f11.e -textvar s(anabw) -wi 6
  3843. #    pack $w.r.f11.l $w.r.f11.e -side left
  3844.  
  3845.     pack [frame .sect.f4]
  3846.     pack [button .sect.f4.lockB -text Lock -command {set s(ostart) $s(start);set s(oend) $s(end)}] -side left
  3847.     pack [button .sect.f4.printB -text Print... -command {Print .sect.c $s(sectwinh)}] -side left
  3848.     pack [button .sect.f4.exportB -text Export... -command Export] -side left
  3849.  
  3850.     update idletasks
  3851.     DrawSect
  3852.  
  3853.     bind .sect <Configure> DrawSect
  3854.     bind .sect <Any-Key> DrawSect
  3855.     bind .sect.c <ButtonPress-1>  { set s(rx) %x; set s(ry) %y ;.sect.c coords relmark 0 0 0 0;.sect.c coords df -10 -10;.sect.c coords db -10 -10}
  3856.     bind .sect.c <ButtonRelease-1>  { set s(rx) -1 }
  3857.     bind .sect.c <Motion>  {DrawSectMarks %x %y}
  3858.     bind .sect.c <Leave>  {.sect.c coords sx -1 -1 -1 -1;.sect.c coords sy -1 -1 -1 -1}
  3859. }
  3860.  
  3861. proc LPCcontrols {state} {
  3862.   .sect.f2.e configure -state $state
  3863.   .sect.f2.s configure -state $state
  3864. }
  3865.  
  3866. proc DrawSect {} {
  3867.     global c s v
  3868.  
  3869.     if [winfo exists .sect] {
  3870.     set geom [lindex [split [wm geometry .sect] +] 0]
  3871.     set s(sectwinw) [lindex [split $geom x] 0]
  3872.     set s(sectwinh) [lindex [split $geom x] 1]
  3873.         set s(sectwinx) [lindex [split [wm geometry .sect] +] 1]
  3874.         set s(sectwiny) [lindex [split [wm geometry .sect] +] 2]
  3875.     set s(sectw) [expr [winfo width .sect.c] - 25]
  3876.     set s(secth) [expr [winfo height .sect.c] - 20]
  3877.     set s(sectcw) [winfo width .sect.c]
  3878.     set s(sectch) [winfo height .sect.c]
  3879.  
  3880.     set s(start) [Marker2Sample m1]
  3881.     set s(end)   [Marker2Sample m2]
  3882.     if {$s(start) == $s(end)} { set s(start) [expr $s(end) - 1]}
  3883.     .sect.c delete sect
  3884.         set s(top) [expr int(($s(ref) + $s(range)) / 10.0)]
  3885.         set s(bot) [expr int($s(ref) / 10.0 )]
  3886.  
  3887. catch {
  3888.     if {$s(ostart) != ""} {
  3889.         .sect.c create section 25 0 -sound snd -height $s(secth)\
  3890.             -width $s(sectw) -maxvalue [expr 10.0*$s(top)] \
  3891.             -minvalue [expr 10.0*$s(bot)] \
  3892.             -start $s(ostart) -end $s(oend) -tags sect \
  3893.             -fftlen $s(fftlen) -analysistype $s(atype) \
  3894.             -lpcorder $s(lpcorder) \
  3895.             -winlen $s(fftlen) -channel $v(vchan) -fill red \
  3896.             -topfr $v(topfr) -windowtype $s(wintype)
  3897.     }
  3898.     .sect.c create section 25 0 -sound snd -height $s(secth) \
  3899.         -width $s(sectw) -maxvalue [expr 10.0*$s(top)] \
  3900.         -minval [expr 10.0*$s(bot)] \
  3901.         -start $s(start) -end $s(end) -tags sect -fftlen $s(fftlen) \
  3902.         -winlen $s(fftlen) -channel $v(vchan) -frame 1 \
  3903.         -debug $::debug -fill $v(fg) -analysistype $s(atype) \
  3904.         -lpcorder $s(lpcorder) -topfr $v(topfr) -windowtype $s(wintype)
  3905.     }
  3906.     .sect.c create text -10 -10 -text df: -font $v(sfont) -tags df \
  3907.         -fill blue
  3908.     .sect.c create text -10 -10 -text "0 db" -font $v(sfont) -tags db \
  3909.         -fill red
  3910.     set pps [expr int(double($s(sectw))/($v(topfr)/1000.0) + .5)]
  3911.     snack::timeAxis .sect.c 25 $s(secth) $s(sectw) 20 $pps \
  3912.         -tags sect -fill $v(fg) -font $v(sfont)
  3913.  
  3914.     for {set i $s(top)} {$i > $s(bot)} {incr i -1} {
  3915.         set lab [expr 10 * $i]
  3916.         .sect.c create text 0 \
  3917.            [expr ($i - $s(top)) * $s(secth) / ($s(bot) - $s(top))] \
  3918.             -text $lab \
  3919.             -tags sect -font $v(sfont) -anchor w -fill $v(fg)
  3920.     }
  3921.  
  3922.     .sect.c create text 2 2 -text dB -font $v(sfont) -tags sect -anchor nw\
  3923.         -fill $v(fg)
  3924.     .sect.c create text $s(sectw) $s(secth) -text kHz -font $v(sfont)\
  3925.         -tags sect -anchor nw -fill $v(fg)
  3926.     }
  3927. }
  3928.  
  3929. proc Export {} {
  3930.     global s v f
  3931.  
  3932.     set s(start) [Marker2Sample m1]
  3933.     set s(end)   [Marker2Sample m2]
  3934.  
  3935.     if {$s(start) == $s(end)} { set s(start) [expr $s(end) - 1]}
  3936.  
  3937.     set ps [snd dBPowerSpectrum -start $s(start) -end $s(end) \
  3938.         -fftlen $s(fftlen) -windowlen $s(fftlen) -channel $v(vchan) \
  3939.         -windowtype $s(wintype) -analysistype $s(atype) \
  3940.         -lpcorder $s(lpcorder)]
  3941.  
  3942.     set file [tk_getSaveFile -title "Export spectral data" -initialfile spectrum.txt]
  3943.     if {$file == ""} return
  3944.     if {[catch {open $file w} out]} {
  3945.     return $out
  3946.     } else {
  3947.     set df [expr {([snd cget -rate] / 2.0) / $s(fftlen)}]
  3948.     set freq [expr {$df / 2.0}]
  3949.     puts $out "File: $f(sndfile) $s(start)-$s(end)"
  3950.     puts $out "$s(wintype) window, $s(fftlen) points"
  3951.     puts $out "Frequency (Hz) Level (dB)"
  3952.     foreach e $ps {
  3953.         puts $out [format "%f\t%f" $freq $e]
  3954.         set freq [expr {$freq + $df}]
  3955.     }
  3956.     close $out
  3957.     }
  3958. }
  3959.  
  3960. proc DrawSectMarks {x y} {
  3961.     global s v
  3962.  
  3963.     if {[.sect.c find withtag sm] == ""} {
  3964.     if {$::tcl_platform(platform) == "windows"} {
  3965. #        .sect.c create line 0 0 0 $s(sectch) -width 2 -stipple gray50 -tags [list sx sm] -fill $v(fg)
  3966. #        .sect.c create line 0 0 $s(sectcw) 0 -width 2 -stipple gray50 -tags [list sy sm] -fill $v(fg)
  3967. #        .sect.c create line 0 0 0 0 -width 2 -stipple gray50 -tags [list relmark] -fill $v(fg)
  3968.         .sect.c create line 0 0 0 $s(sectch) -width 1 -tags [list sx sm] -fill $v(fg)
  3969.         .sect.c create line 0 0 $s(sectcw) 0 -width 1 -tags [list sy sm] -fill $v(fg)
  3970.         .sect.c create line 0 0 0 0 -width 1 -tags [list relmark] -fill $v(fg)
  3971.     } else {
  3972.         .sect.c create line 0 0 0 $s(sectch) -width 1 -stipple gray50 -tags [list sx sm] -fill $v(fg)
  3973.         .sect.c create line 0 0 $s(sectcw) 0 -width 1 -stipple gray50 -tags [list sy sm] -fill $v(fg)
  3974.         .sect.c create line 0 0 0 0 -width 1 -stipple gray50 -tags [list relmark relmarkux] -arrow both -fill $v(fg)
  3975.     }
  3976.     }
  3977.  
  3978.     if {$x != "f"} {
  3979.     set xc [.sect.c canvasx $x]
  3980.     set yc [.sect.c canvasx $y]
  3981.     } else {
  3982.     set xc [expr 25+int($s(sectw) * $y / $v(topfr))]
  3983.     set yc [lindex [.sect.c coords sy] 1]
  3984.     }
  3985.     .sect.c coords sx $xc 0 $xc $s(sectch)
  3986.     .sect.c coords sy 0 $yc $s(sectcw) $yc
  3987.     set f [expr int(double($v(topfr)) * ($xc - 25) / $s(sectw) + .5)]
  3988.     if {$f < 0} { set f 0 }
  3989.     set db [format "%.1f" [expr 10.0 * ($s(bot) - $s(top)) * double($yc) / $s(secth) + 10.0 * $s(top)]]
  3990.  
  3991.     if {$s(rx) != -1} {
  3992.     set rx [.sect.c canvasx $s(rx)]
  3993.     set ry [.sect.c canvasy $s(ry)]
  3994.     .sect.c coords relmark $rx $ry $xc $yc
  3995.     .sect.c coords df [expr $rx + ($xc-$rx)/2] $ry
  3996.     .sect.c coords db $rx [expr $ry + ($yc-$ry)/2]
  3997.  
  3998.     set df [expr abs(int($v(topfr) * ($rx - $xc)/ $s(sectw)))]
  3999.     .sect.c itemconf df -text "df: $df" 
  4000.     set ddb [format "%.1f" [expr $s(range) * ($ry - $yc) / $s(secth)]]
  4001.     .sect.c itemconf db -text "db: $ddb" 
  4002.     } else {
  4003. #    .sect.c coords relmark 0 0 0 0
  4004. #    .sect.c coords df -10 -10
  4005. #    .sect.c coords db -10 -10
  4006.     }
  4007.  
  4008.     .sect.f.lab config -text "Frequency: $f Hz, amplitude: $db dB"
  4009. }
  4010.  
  4011. proc OpenZoomWindow {} {
  4012.     global z v
  4013.  
  4014.     catch {destroy .zoom}
  4015.     catch {destroy .zmenu}
  4016.     toplevel .zoom -width $z(zoomwinw) -height $z(zoomwinh)
  4017.     wm title .zoom "Zoom view"
  4018.     wm geometry .zoom +$z(zoomwinx)+$z(zoomwiny)
  4019.     pack propagate .zoom 0
  4020.  
  4021.     frame .zoom.f
  4022.     label .zoom.f.lab -text "Press right mouse button for menu" -width 1 -relief sunken -bd 1 -anchor w
  4023.     pack .zoom.f.lab -side left -expand yes -fill x
  4024.     pack [button .zoom.f.xzoomB -text X-zoom -command {DrawZoom 1}] -side left
  4025.     pack [button .zoom.f.yizoomB -text "Y-zoom in" -command {DrawZoom 2}] -side left
  4026.     pack [button .zoom.f.yozoomB -text "Y-zoom out" -command {DrawZoom .5}] -side left
  4027.     pack [button .zoom.f.exitB -text Close -command {destroy .zoom}] -side left
  4028.     pack .zoom.f -side bottom -fill x
  4029.     pack [canvas .zoom.c -closeenough 5 -bg $v(bg)] -fill both -expand true
  4030.  
  4031.     update idletasks
  4032.     DrawZoom 1
  4033.  
  4034.     menu .zmenu -tearoff false
  4035.     .zmenu add command -label "Play Range" -command PlayMark
  4036.     .zmenu add command -label "Mark Start" -command {PutZMarker zm1 $x}
  4037.     .zmenu add command -label "Mark End" -command {PutZMarker zm2 $x}
  4038.     if [string match macintosh $::tcl_platform(platform)] {
  4039.     bind $c <Control-1> \
  4040.         {set x %x; set y %y; catch {tk_popup .zmenu %X %Y 0}}
  4041.     } else {
  4042.     bind .zoom.c <3> {set x %x; set y %y; catch {tk_popup .zmenu %X %Y 0}}
  4043.     }
  4044.     bind .zoom <Configure> { DrawZoom 1 }
  4045. }
  4046.  
  4047. proc DrawZoom {factor} {
  4048.     global z v f
  4049.  
  4050.     if [winfo exists .zoom] {
  4051.     set geom [lindex [split [wm geometry .zoom] +] 0]
  4052.     set z(zoomwinw) [lindex [split $geom x] 0]
  4053.     set z(zoomwinh) [lindex [split $geom x] 1]
  4054.         set z(zoomwinx) [lindex [split [wm geometry .zoom] +] 1]
  4055.         set z(zoomwiny) [lindex [split [wm geometry .zoom] +] 2]
  4056.     set z(zoomwavw) [winfo width .zoom.c]
  4057.     set z(zoomwavh) [winfo height .zoom.c]
  4058.     set z(f) [expr $z(f) * $factor]
  4059.  
  4060.     set start [Marker2Sample m1]
  4061.     set end   [Marker2Sample m2]
  4062.  
  4063.     if {$start == $end} { set end [expr $start + 1]}
  4064.     set zoompps [expr double($z(zoomwavw)) * $v(rate) / ($end - $start)]
  4065.  
  4066.     .zoom.c delete zoomwave zm1 zm2
  4067.     if {$v(linkfile) && $f(sndfile) != ""} {
  4068.         .zoom.c create waveform 0 [expr $z(zoomwavh)/2] -sound snd \
  4069.             -height [expr int($z(zoomwavh) * $z(f))] \
  4070.             -start $start -end $end -channel $v(vchan) \
  4071.             -pixels $zoompps -tags zoomwave -anchor w -fill $v(fg) \
  4072.         -shapefile [file rootname [file tail $f(spath)$f(sndfile)]].shape
  4073.     } else {
  4074.         .zoom.c create waveform 0 [expr $z(zoomwavh)/2] -sound snd \
  4075.             -height [expr int($z(zoomwavh) * $z(f))] \
  4076.             -start $start -end $end    -channel $v(vchan) \
  4077.             -pixels $zoompps -tags zoomwave -anchor w -fill $v(fg)
  4078.     }
  4079.     .zoom.c create line 1 0 1 $z(zoomwavh) -width 1 -tags zm1 -fill $v(fg)
  4080.     .zoom.c create line [expr $z(zoomwavw) - 1] 0 [expr $z(zoomwavw) - 1] $z(zoomwavh) -width 1 -tags zm2 -fill $v(fg)
  4081.     .zoom.c bind zm1 <B1-Motion> { PutZMarker zm1 %x }
  4082.     .zoom.c bind zm2 <B1-Motion> { PutZMarker zm2 %x }
  4083.     .zoom.c bind zm1 <ButtonPress-1> { set _mx 0 }
  4084.     .zoom.c bind zm2 <ButtonPress-1> { set _mx 0 }
  4085.     .zoom.c bind zm1 <ButtonRelease-1> { set _mx 0 }
  4086.     .zoom.c bind zm2 <ButtonRelease-1> { set _mx 0 }
  4087.     bind .zoom.c <ButtonPress-1>   { PutZMarker zm1 %x; set _mx 1 }
  4088.     bind .zoom.c <ButtonRelease-1> { PutZMarker zm2 %x; set _mx 1}
  4089.     set z(zoomt1) [Marker2Time m1]
  4090.     set z(zoomt2) [Marker2Time m2]
  4091.     }
  4092. }
  4093.  
  4094. proc PutZMarker {m x} {
  4095.     global z _mx
  4096.  
  4097.     if {$_mx == 0} return
  4098.  
  4099.     set xc [.zoom.c canvasx $x]
  4100.     if {$xc < 0} { set xc 0 }
  4101.     if {$xc > $z(zoomwavw)} { set xc $z(zoomwavw) }
  4102.     .zoom.c coords $m $xc 0 $xc $z(zoomwavh)
  4103.  
  4104.     set t [TimeRound [expr $z(zoomt1) + ($z(zoomt2) - $z(zoomt1)) * double($xc) / $z(zoomwavw)]]
  4105.     set n [Time2Sample $t]
  4106.     set s [snd sample $n]
  4107.     if {$m == "zm1"} {
  4108.     .zoom.f.lab config -text "Marker 1 at $n ($s)"
  4109.     PutMarker m1 $n 0 0
  4110.     } else {
  4111.     .zoom.f.lab config -text "Marker 2 at $n ($s)"
  4112.     PutMarker m2 $n 0 0
  4113.     }
  4114. }
  4115.  
  4116. proc WS {} {
  4117.     catch {destroy .ws}
  4118.     toplevel .ws
  4119.     wm title .ws "WaveSurfer window"
  4120.  
  4121.     lappend ::auto_path /afs/tmh.kth.se/tmh/home/speech/kare/wavesurfer/src
  4122.     
  4123.     package require -exact wsurf 1.0
  4124.     
  4125.     set w [wsurf .ws.ws -collapser 0 -title ""]    
  4126.     pack $w -expand 0 -fill both
  4127.     $w configure -sound snd
  4128.     $w configure -configuration ../wavesurfer/src/configurations/Spectrogram.conf
  4129.     update idletasks
  4130.     $w xzoom 0.4 0.6
  4131.     $w xscroll moveto 0.4
  4132. }
  4133.  
  4134. proc Version {} {
  4135.     global c v
  4136.  
  4137.     SetMsg "xs version $v(p_version), settings for $v(s_version)"
  4138.     catch {::http::geturl http://www.speech.kth.se/snack/xs.html\
  4139.         -command VersionMore}
  4140.     set c .cf.fc.c
  4141. }
  4142.  
  4143. proc VersionMore {token} {
  4144.     global v
  4145.  
  4146.     set data [::http::data $token]
  4147.     regexp {version is ([0-9].[0-9])} $data junk version
  4148.     SetMsg "xs version $v(p_version), settings for $v(s_version), current download version is $version"
  4149. }
  4150.  
  4151. #
  4152. # Miscellaneous subroutines
  4153. #
  4154.  
  4155. proc Help {url} {
  4156.     global v lab_path
  4157.     
  4158.     if {$::tcl_platform(platform) == "windows"} {
  4159.     if {[string match $::tcl_platform(os) "Windows NT"]} {
  4160.         exec $::env(COMSPEC) /c start $url &
  4161.     } {
  4162.         exec start $url &
  4163.     }
  4164.     } else {
  4165.     if [catch {exec sh -c "netscape -remote 'openURL($url)' -raise"} res] {
  4166.         if [string match *netscape* $res] {
  4167.         exec sh -c "netscape $url" &
  4168.         }
  4169.     }
  4170.     }
  4171. }
  4172.  
  4173. proc NewWin {} {
  4174.     global f
  4175.  
  4176.     if {$::tcl_platform(platform) == "windows"} {
  4177.     exec [info nameofexecutable] $f(prog) &
  4178.     } else {
  4179.     exec $f(prog) -geometry [xsGetGeometry] &
  4180.     }
  4181. }
  4182.  
  4183. proc Reset {} {
  4184.     global v f s v_copy f_copy s_copy
  4185.  
  4186.     array set v $v_copy
  4187.     array set f $f_copy
  4188.     array set s $s_copy
  4189. }
  4190.  
  4191. proc Settings {} {
  4192.     global v c f s v_copy f_copy s_copy
  4193.  
  4194.     StopPlay
  4195.     set w .dim
  4196.     catch {destroy $w}
  4197.     toplevel $w
  4198.     wm title $w {Settings}
  4199.  
  4200.     set start [Coord2Sample [$c canvasx [expr [winfo width .cf.fc]/2 - 100]]]
  4201.     set end   [Coord2Sample [$c canvasx [expr [winfo width .cf.fc]/2 + 100]]]
  4202.  
  4203.     set v_copy [array get v]
  4204.     set f_copy [array get f]
  4205.     set s_copy [array get s]
  4206.  
  4207.     pack [frame $w.ll] -side left -anchor e
  4208.     pack [canvas $w.ll.c -height [expr $v(waveh)+$v(spegh)] -width 200 \
  4209.         -highlightthickness 0]    
  4210.  
  4211.     pack [frame $w.l] -side left -anchor n -fill y
  4212.     pack [label $w.l.l1 -text Appearance:]
  4213.  
  4214.     pack [frame $w.l.f3]
  4215.     pack [label $w.l.f3.l -text "Time scale (pixels/second):" -width 25 -anchor w] -side left
  4216.     pack [entry $w.l.f3.e -textvar v(pps) -wi 6] -side left
  4217.     pack [scale $w.l.f3.s -variable v(pps) -orient horiz -from 1 -to 1000 -command "$w.ll.c itemconf both -width 200 -start $start -pixels " -showvalue no] -side left
  4218.  
  4219.     pack [frame $w.l.f1]
  4220.     pack [label $w.l.f1.l -text "Waveform height:" -width 25 -anchor w] -side left
  4221.     pack [entry $w.l.f1.e -textvar v(waveh) -wi 6] -side left
  4222.     pack [scale $w.l.f1.s -variable v(waveh) -orient horiz -from 0 -to 1000 -showvalue no -command {.dim.ll.c configure -height [expr $v(waveh) + $v(spegh)];.dim.ll.c coords speg 0 $v(waveh);.dim.ll.c itemconf wave -height }] -side left
  4223.  
  4224.     pack [frame $w.l.f2]
  4225.     pack [label $w.l.f2.l -text "Spectrogram height:" -width 25 -anchor w] -side left
  4226.     pack [entry $w.l.f2.e -textvar v(spegh) -wi 6] -side left
  4227.     pack [scale $w.l.f2.s -variable v(spegh) -orient horiz -from 0 -to 1000 -command {.dim.ll.c configure -height [expr $v(waveh) + $v(spegh)];.dim.ll.c itemconf speg -height } -showvalue no] -side left
  4228.  
  4229.     pack [frame $w.l.f20]
  4230.     pack [label $w.l.f20.l -text "Cut spectrogram at freq:" -width 25 -anchor w] -side left
  4231.     pack [entry $w.l.f20.e -textvar v(topfr) -wi 6] -side left
  4232.     pack [scale $w.l.f20.s -variable v(topfr) -orient horiz -from 0 -to [expr $v(rate)/2] -command "DrawSect;$w.ll.c itemconf speg -topfreq " -showvalue no] -side left
  4233.  
  4234.     pack [frame $w.l.f30]
  4235.     pack [label $w.l.f30.l -text "Brightness" -width 25 -anchor w] -side left
  4236.     pack [entry $w.l.f30.e -textvar v(brightness) -wi 6] -side left
  4237.     pack [scale $w.l.f30.b -variable v(brightness) -showvalue no \
  4238.         -orient horiz -command "$w.ll.c itemconf speg -brightness " \
  4239.         -from -100 -to 100 -res 0.1]
  4240.  
  4241.     pack [frame $w.l.f31]
  4242.     pack [label $w.l.f31.l -text "Contrast" -width 25 -anchor w] -side left
  4243.     pack [entry $w.l.f31.e -textvar v(contrast) -wi 6] -side left
  4244.     pack [scale $w.l.f31.c -variable v(contrast) -showvalue no\
  4245.         -orient horiz -command "$w.ll.c itemconf speg -contrast" \
  4246.         -from -100 -to 100 -res 0.1]
  4247.  
  4248. #    pack [frame $w.l.f21]
  4249. #    label $w.l.f21.l -text "Scroll area width:" -width 25 -anchor w
  4250. #    entry $w.l.f21.e -textvar v(scrw) -wi 6
  4251. #    pack $w.l.f21.l $w.l.f21.e -side left
  4252.  
  4253.     pack [frame $w.l.f41]
  4254.     label $w.l.f41.l -text "Foreground color:" -width 25 -anchor w
  4255.     entry $w.l.f41.e -textvar v(fg) -wi 6
  4256.     pack $w.l.f41.l $w.l.f41.e -side left
  4257.     bind $w.l.f41.e <Key-Return> {.dim.ll.c itemconf wave -fill $v(fg)}
  4258.  
  4259.     pack [frame $w.l.f41b]
  4260.     label $w.l.f41b.l -text "Background color:" -width 25 -anchor w
  4261.     entry $w.l.f41b.e -textvar v(bg) -wi 6
  4262.     pack $w.l.f41b.l $w.l.f41b.e -side left
  4263.     bind $w.l.f41b.e <Key-Return> {$c config -bg $v(bg); .cf.fyc.yc config -bg $v(bg); catch {.zoom.c config -bg $v(bg)}; catch {.sect.c config -bg $v(bg)}}
  4264.  
  4265.     pack [frame $w.l.f42]
  4266.     label $w.l.f42.l -text "Grid frequency spacing (Hz):" -width 25 -anchor w
  4267.     entry $w.l.f42.e -textvar v(gridfspacing) -wi 6
  4268.     pack $w.l.f42.l $w.l.f42.e -side left
  4269.     bind $w.l.f42.e <Key-Return> {.dim.ll.c itemconf speg -gridf $v(gridfspacing)}
  4270.  
  4271.     pack [frame $w.l.f43]
  4272.     label $w.l.f43.l -text "Grid time spacing: (s)" -width 25 -anchor w
  4273.     entry $w.l.f43.e -textvar v(gridtspacing) -wi 6
  4274.     pack $w.l.f43.l $w.l.f43.e -side left
  4275.     bind $w.l.f43.e <Key-Return> {.dim.ll.c itemconf speg -gridt $v(gridtspacing)}
  4276.  
  4277.     pack [frame $w.l.f44]
  4278.     label $w.l.f44.l -text "Grid color:" -width 25 -anchor w
  4279.     entry $w.l.f44.e -textvar v(gridcolor) -wi 6
  4280.     pack $w.l.f44.l $w.l.f44.e -side left
  4281.     bind $w.l.f44.e <Key-Return> {DrawCrossHairs;.dim.ll.c itemconf speg -gridc $v(gridcolor)}
  4282.  
  4283.     pack [frame $w.l.f45]
  4284.     label $w.l.f45.l -text "Spectrogram color:" -width 25 -anchor w
  4285.     tk_optionMenu $w.l.f45.cm v(cmap) grey color1 color2
  4286.     $w.l.f45.cm.menu entryconfigure 0 -command {.dim.ll.c itemconf speg -col $v($v(cmap))}
  4287.     $w.l.f45.cm.menu entryconfigure 1 -command {.dim.ll.c itemconf speg -col $v($v(cmap))}
  4288.     $w.l.f45.cm.menu entryconfigure 2 -command {.dim.ll.c itemconf speg -col $v($v(cmap))}
  4289.     pack $w.l.f45.l $w.l.f45.cm -side left
  4290.  
  4291.     pack [frame $w.r] -side left -anchor n -fill y -expand true
  4292.  
  4293.     pack [label $w.r.l2 -text "Spectrogram analysis:"]
  4294.  
  4295.     pack [frame $w.r.f1]
  4296.     label $w.r.f1.l -text "FFT window length (points):" -width 25 -anchor w
  4297.     entry $w.r.f1.e -textvar v(fftlen) -wi 6
  4298.     pack $w.r.f1.l $w.r.f1.e -side left
  4299.     bind $w.r.f1.e <Key-Return> {.dim.ll.c itemconf speg -fftlen $v(fftlen)}
  4300.  
  4301.     pack [frame $w.r.f2]
  4302.     label $w.r.f2.l -text "Analysis bandwidth (Hz):" -width 25 -anchor w
  4303.     entry $w.r.f2.e -textvar v(anabw) -wi 6
  4304.     pack $w.r.f2.l $w.r.f2.e -side left
  4305.     bind $w.r.f2.e <Key-Return> {.dim.ll.c itemconf speg -winlen [expr int($v(rate) / $v(anabw))]}
  4306.  
  4307.     pack [frame $w.r.f3]
  4308.     label $w.r.f3.l -text "Preemphasis factor:" -width 25 -anchor w
  4309.     entry $w.r.f3.e -textvar v(preemph) -wi 6
  4310.     pack $w.r.f3.l $w.r.f3.e -side left
  4311.     bind $w.r.f3.e <Key-Return> {.dim.ll.c itemconf speg -preem $v(preemph)}
  4312.  
  4313. #    pack [label $w.r.l3 -text "Spectrum section analysis:"] -pady 10
  4314.  
  4315. #    pack [frame $w.r.f10]
  4316. #    label $w.r.f10.l -text "FFT window length (points):" -width 25 -anchor w
  4317. #    entry $w.r.f10.e -textvar s(fftlen) -wi 6
  4318. #    pack $w.r.f10.l $w.r.f10.e -side left
  4319.  
  4320. #    pack [frame $w.r.f11]
  4321. #    label $w.r.f11.l -text "Analysis bandwidth (Hz):" -width 25 -anchor w
  4322. #    entry $w.r.f11.e -textvar s(anabw) -wi 6
  4323. #    pack $w.r.f11.l $w.r.f11.e -side left
  4324.  
  4325. ##    pack [button $w.r.sectB -text Apply -command DrawSect] -pady 5
  4326. #    bind $w.r.f10.e <Key-Return> DrawSect
  4327. #    bind $w.r.f11.e <Key-Return> DrawSect
  4328.  
  4329. #    pack [frame $w.r.f5]
  4330. #    label $w.r.f5.l -text "Label font:" -width 11 -anchor w
  4331. #    entry $w.r.f5.e -textvar v(font) -wi 20
  4332. #    pack $w.r.f5.l $w.r.f5.e -side left
  4333.  
  4334. #    pack [frame $w.r.f6]
  4335. #    label $w.r.f6.l -text "Axes font:" -width 11 -anchor w
  4336. #    entry $w.r.f6.e -textvar v(sfont) -wi 20
  4337. #    pack $w.r.f6.l $w.r.f6.e -side left
  4338. #    bind $w.r.f6.e <Key-Return> DrawSect
  4339.  
  4340. #    pack [label $w.r.l4 -text "Raw/unknown file input:"] -pady 10
  4341. #    pack [frame $w.r.f12]
  4342. #    label $w.r.f12.l -text "Unknown file header size:" -width 25 -anchor w
  4343. #    entry $w.r.f12.e -textvar f(skip) -wi 6
  4344. #    pack $w.r.f12.l $w.r.f12.e -side left
  4345.  
  4346. #    pack [frame $w.r.f9]
  4347. #    label $w.r.f9.l -text "Byte order of sample data:" -width 25 -anchor w
  4348. #    entry $w.r.f9.e -textvar f(byteOrder) -wi 12
  4349. #    pack $w.r.f9.l $w.r.f9.e -side left
  4350.  
  4351.     pack [checkbutton $w.r.b5 -text "Use audio server at:" -var v(remote)] -pady 10
  4352.     pack [frame $w.r.f13]
  4353.     label $w.r.f13.l1 -text "Host" -width 4
  4354.     entry $w.r.f13.e1 -textvar v(ashost) -wi 20
  4355.     label $w.r.f13.l2 -text "Port" -width 4
  4356.     entry $w.r.f13.e2 -textvar v(asport) -wi 5
  4357.     pack $w.r.f13.l1 $w.r.f13.e1 $w.r.f13.l2 $w.r.f13.e2 -side left
  4358.  
  4359. #    pack [label $w.r.l5 -text "Browser command:"] -pady 5
  4360. #    pack [frame $w.r.f16]
  4361. #    entry $w.r.f16.e -textvar v(browser) -wi 30
  4362. #    pack $w.r.f16.e -side left
  4363.  
  4364.     pack [label $w.r.l6 -text "Initial path:"]
  4365.     pack [frame $w.r.f14]
  4366.     entry $w.r.f14.e -textvar f(ipath) -wi 30
  4367.     pack $w.r.f14.e -side left
  4368.  
  4369.     pack [label $w.r.l7 -text "Initial http:"]
  4370.     pack [frame $w.r.f15]
  4371.     entry $w.r.f15.e -textvar f(ihttp) -wi 30
  4372.     pack $w.r.f15.e -side left
  4373.  
  4374.     pack [frame $w.r.f] -anchor e -pady 5 -padx 5 -side bottom
  4375.     pack [button $w.r.f.okB -text OK -wi 6 -command {Redraw;destroy .dim}] -side right
  4376.     pack [button $w.r.f.appB -text Apply -wi 6 -command Redraw] -side right
  4377.     pack [button $w.r.f.exitB -text Cancel -command {Reset;DrawSect;Redraw;destroy .dim}] -side right
  4378.     update
  4379.  
  4380.     if {$v(linkfile) && $f(sndfile) != ""} {
  4381.     .dim.ll.c create waveform 0 0 -sound snd -height $v(waveh) -width 200 \
  4382.         -pixels $v(pps) -tags [list wave both] -start $start \
  4383.         -channel $v(vchan) -fill $v(fg) -frame yes -debug 0 \
  4384.     -shapefile [file rootname [file tail $f(spath)$f(sndfile)]].shape
  4385.     } else {
  4386.     .dim.ll.c create waveform 0 0 -sound snd -height $v(waveh) -width 200 \
  4387.         -pixels $v(pps) -tags [list wave both] -start $start \
  4388.         -channel $v(vchan) -fill $v(fg) -frame yes -debug 0
  4389.     }
  4390.     if {$v(spegh) > 0} {
  4391.     .dim.ll.c create spectrogram 0 $v(waveh) -sound snd -fftlen $v(fftlen)\
  4392.         -height $v(spegh) -width 200 -pixels $v(pps) \
  4393.         -preemph $v(preemph) -topfr $v(topfr) \
  4394.         -start $start -tags [list speg both] \
  4395.         -contrast $v(contrast) \
  4396.         -brightness $v(brightness) -gridtspacing $v(gridtspacing) \
  4397.         -gridfspacing $v(gridfspacing) -channel $v(vchan) \
  4398.         -colormap $v($v(cmap)) -gridcol $v(gridcolor)
  4399.     }
  4400. }
  4401.  
  4402. proc Plugins {} {
  4403.     global v
  4404.  
  4405.     set w .plugins
  4406.     catch {destroy $w}
  4407.     toplevel $w
  4408.     wm title $w {Plug-ins}
  4409.  
  4410.     pack [ label $w.lPlugins -text "Installed plug-ins:"]
  4411.     pack [ frame $w.f] -fill both -expand true
  4412.     pack [ scrollbar $w.f.scroll -command "$w.f.list yview"] -side right -fill y
  4413.     listbox $w.f.list -yscroll "$w.f.scroll set" -setgrid 1 -height 6 -width 50
  4414.     pack $w.f.list -side left -expand true -fill both
  4415.     foreach e $v(pluginfiles) {
  4416.     $w.f.list insert end $e
  4417.     }
  4418.  
  4419.     pack [ label $w.lDesc -text Description:]
  4420.     pack [ frame $w.f2] -fill x
  4421.     pack [ text $w.f2.text -height 4 -wrap word] -fill x -expand true
  4422.  
  4423.     pack [ frame $w.f3]
  4424.     pack [ button $w.f3.b1 -text Load... -command "PluginsAdd $w"] -side left
  4425.     pack [ button $w.f3.b2 -text Unload -command "PluginsRemove $w"] -side left
  4426.     pack [ button $w.f3.b3 -text Close -command [list destroy $w]] -side left
  4427.  
  4428.     bind $w.f.list <ButtonRelease-1> {.plugins.f2.text delete 0.0 end;.plugins.f2.text insert end [namespace inscope [lindex $v(plugins) [.plugins.f.list curselection]] Describe]}
  4429. }
  4430.  
  4431. proc PluginsAdd {w} {
  4432.     global v
  4433.  
  4434.     set types {
  4435.     {{xs Plug-in Files} {.plg}}
  4436.     {{Tcl Files} {.tcl}}
  4437.     {{All Files}    *  }
  4438.     }
  4439.     set file [tk_getOpenFile -title "Select plug-in" -filetypes $types]
  4440.     if {$file == ""} return
  4441.     if {[source $file] == "fail"} return
  4442.     $w.f.list insert end $file
  4443.     set v(pluginfiles) [$w.f.list get 0 end]
  4444. }
  4445.  
  4446. proc PluginsRemove {w} {
  4447.     global v
  4448.  
  4449.     set i [$w.f.list curselection]
  4450.     namespace inscope [lindex $v(plugins) $i] Unload
  4451.     set v(plugins) [lreplace $v(plugins) $i $i]
  4452.     catch {$w.f.list delete $i}
  4453.     set v(pluginfiles) [$w.f.list get 0 end]
  4454.     $w.f2.text delete 0.0 end
  4455. }
  4456.  
  4457. proc Print {canvas h} {
  4458.     global v
  4459.  
  4460.     set w .print
  4461.     catch {destroy $w}
  4462.     toplevel $w
  4463.     wm title $w {Printer setup}
  4464.  
  4465.     set v(lastpage) [expr int(($v(width)+999)/1000)]
  4466.     set v(firstpage) 1
  4467.  
  4468.     frame $w.f1
  4469.     label $w.f1.l1 -text "Pages:"
  4470.     entry $w.f1.e1 -textvar v(firstpage) -width 3
  4471.     label $w.f1.l2 -text "to"
  4472.     entry $w.f1.e2 -textvar v(lastpage) -width 3
  4473.     pack $w.f1.l1 $w.f1.e1 $w.f1.l2 $w.f1.e2 -side left
  4474.  
  4475.     frame $w.f2
  4476.     label $w.f2.l1 -text "Print command:" -wi 16
  4477.     entry $w.f2.e1 -textvar v(printcmd)   -wi 40
  4478.     button $w.f2.b1 -text Print -command [list DoPrint print $canvas $h] -wi 8
  4479.     pack $w.f2.l1 $w.f2.e1 $w.f2.b1 -side left
  4480.     bind $w.f2.e1 <Key-Return> [list DoPrint print $canvas $h]
  4481.  
  4482.     frame $w.f3
  4483.     label $w.f3.l1 -text "Preview command:" -wi 16
  4484.     entry $w.f3.e1 -textvar v(gvcmd)        -wi 40
  4485.     button $w.f3.b1 -text Preview -command [list DoPrint preview $canvas $h] \
  4486.         -wi 8
  4487.     pack $w.f3.l1 $w.f3.e1 $w.f3.b1 -side left
  4488.     bind $w.f3.e1 <Key-Return> [list DoPrint preview $canvas $h]
  4489.  
  4490.     frame $w.f4
  4491.     label $w.f4.l1 -text "Save to ps-file:" -wi 16
  4492.     entry $w.f4.e1 -textvar v(psfilet)       -wi 40
  4493.     button $w.f4.b1 -text Save -command [list DoPrint save $canvas $h] -wi 8
  4494.     pack $w.f4.l1 $w.f4.e1 $w.f4.b1 -side left
  4495.     bind $w.f4.e1 <Key-Return> [list DoPrint save $canvas $h]
  4496.  
  4497.     frame $w.f
  4498.     label $w.f.lab -text "" -width 1 -relief sunken -bd 1 -anchor w
  4499.     pack $w.f.lab -side left -expand yes -fill x
  4500.     button $w.f.exitB -text Close -command [list destroy $w]
  4501.     pack $w.f.exitB -side left
  4502.     pack $w.f1 $w.f2 $w.f3 $w.f4 $w.f -side top -fill x
  4503. }
  4504.  
  4505. proc DoPrint {type c canvh} {
  4506.     global v
  4507.  
  4508.     set n 0
  4509.     set pageno 0
  4510.     set x 0
  4511.     if {$c == ".sect.c"} {
  4512.     set w 1000
  4513.     } else {
  4514.     set w $v(width)
  4515.     }
  4516.     set title [InfoStr path]
  4517.     set time [clock format [clock seconds] -format "%a %b %d %T"]
  4518.     set width 1020
  4519.     set skip  1000
  4520.  
  4521.     if {$canvh == -1} {
  4522.     set canvh $v(toth)
  4523.     }
  4524.     
  4525.     $c delete ch1 ch2 sm
  4526.     $c itemconf relmarkux -stipple ""
  4527.  
  4528.     while {$w > 0} {
  4529.     incr pageno
  4530.     if {$pageno >= $v(firstpage)} {
  4531.         if {$pageno > $v(lastpage)} break
  4532.         $c create text [expr $x + 10] -10 -text "$title   Page: $pageno of $v(lastpage)   Printed: $time" -anchor w -tags decor
  4533.         if {$c != ".sect.c"} {
  4534.         $c create line $x 0 $x $canvh -tags decor
  4535.         if {$w < $width} {
  4536.             set ww [expr $x + $w]
  4537.         } else {
  4538.             set ww [expr $x + $width]
  4539.         }
  4540.         $c create line $ww 0 $ww $canvh -tags decor
  4541.         snack::frequencyAxis $c $x [expr $v(waveh)-1] $v(yaxisw) \
  4542.             $v(spegh)\
  4543.             -topfrequency $v(topfr) -tags decor -fill $v(fg)
  4544.         }
  4545.         $c postscript -file _xspr$n.ps -colormode mono -rotate true -x $x -y -20 -width $width -height [expr $canvh + 20] -pagewidth 26c
  4546.         
  4547.             switch $type {
  4548.         print {
  4549.             regsub {\$FILE} $v(printcmd) _xspr$n.ps cmd
  4550.         }
  4551.         preview {
  4552.             regsub {\$FILE} $v(gvcmd) _xspr$n.ps cmd
  4553.         }
  4554.         save {
  4555.             regsub {\$FILE} $v(psfilecmd) _xspr$n.ps cmd
  4556.             regsub {\$N} $v(psfilet) $n v(psfile)
  4557.         }
  4558.         }
  4559.         eval exec $cmd
  4560.         file delete _xspr$n.ps
  4561.         incr n
  4562.         $c delete decor
  4563.     }
  4564.     incr x $skip
  4565.     incr w -$skip
  4566.     }
  4567.     if {$n == 1} {
  4568.     SetMsg "Printed 1 page"
  4569.     } else {
  4570.     SetMsg "Printed $n pages"
  4571.     }
  4572.     DrawCrossHairs
  4573.     $c itemconf relmarkux -stipple gray50
  4574. }
  4575.  
  4576. menu .popmenu -tearoff false
  4577. proc PopUpMenu {X Y x y} {
  4578.     global v
  4579.  
  4580.     .popmenu delete 0 end
  4581.  
  4582.     if {$y < [expr $v(waveh) + $v(spegh) + $v(timeh)]} {
  4583.     .popmenu add command -label "Play Range" -command [list PlayMark $x]
  4584.     } else {
  4585.     .popmenu add command -label "Play Label" -command [list PlayLabel $x $y]
  4586.     .popmenu add command -label "Mark Label" -command [list MarkLabel $x $y]
  4587.     }
  4588.     .popmenu add command -label "Save Range" -command SaveMark
  4589.     .popmenu add command -label "Mark Start" -command "PutMarker m1 $x 0 1;SendPutMarker m1 $x"
  4590.     .popmenu add command -label "Mark End" -command "PutMarker m2 $x 0 1;SendPutMarker m2 $x"
  4591.     .popmenu add command -label "Zoom" -command OpenZoomWindow
  4592.     if {$y > [expr $v(waveh) + $v(spegh) + $v(timeh)]} {
  4593.     .popmenu add command -label "Insert Label" -command [list InsertLabel $x $y]
  4594.     .popmenu add command -label "Delete Label" -command [list DeleteLabel $x $y]
  4595.     .popmenu add command -label "Align Label" -command [list AlignLabel $x $y]
  4596.     .popmenu add command -label "Get Right Label" -command [list GetRightLabel $x $y]
  4597.     }
  4598.     catch {tk_popup .popmenu $X $Y 0}
  4599. }
  4600.  
  4601. proc SaveSettings {} {
  4602.     global v f s
  4603.  
  4604.     if [catch {open [file join ~ .xsrc] w} out] {
  4605.     SetMsg $out
  4606.     } else {
  4607.     puts $out "set v(s_version) $v(p_version)"
  4608.     puts $out "set v(waveh) $v(waveh)"
  4609.     puts $out "set v(spegh) $v(spegh)"
  4610. #    puts $out "set v(scrw) $v(scrw)"
  4611.     puts $out "set v(pps) $v(pps)"
  4612.     puts $out "set v(fftlen) $v(fftlen)"
  4613.     puts $out "set v(winlen) $v(winlen)"
  4614.     puts $out "set v(anabw) $v(anabw)"
  4615.     puts $out "set v(preemph) $v(preemph)"
  4616.     puts $out "set v(ipa) $v(ipa)"
  4617.     puts $out "set v(autoload) $v(autoload)"
  4618.     puts $out "set v(ch) $v(ch)"
  4619.     puts $out "set v(slink) $v(slink)"
  4620.     puts $out "set v(mlink) $v(mlink)"
  4621.     puts $out "set v(printcmd) \{$v(printcmd)\}"
  4622.     puts $out "set v(gvcmd) \{$v(gvcmd)\}"
  4623.     puts $out "set v(pluginfiles) {$v(pluginfiles)}"
  4624. #    puts $out "set v(browser) \{$v(browser)\}"
  4625.     puts $out "set v(rate) $v(rate)"
  4626.     puts $out "set v(sfmt) $v(sfmt)"
  4627.     puts $out "set v(chan) $v(chan)"
  4628. #    puts $out "set v(offset) $v(offset)"
  4629. #    puts $out "set v(zerolabs) $v(zerolabs)"
  4630.     puts $out "set v(ipafmt) $v(ipafmt)"
  4631.     puts $out "set v(labalign) $v(labalign)"
  4632.     puts $out "set v(fg) $v(fg)"
  4633.     puts $out "set v(bg) $v(bg)"
  4634.     puts $out "set v(fillmark) $v(fillmark)"
  4635.     puts $out "set v(font) \{$v(font)\}"
  4636.     puts $out "set v(sfont) \{$v(sfont)\}"
  4637.     puts $out "set v(gridfspacing) $v(gridfspacing)"
  4638.     puts $out "set v(gridtspacing) $v(gridtspacing)"
  4639.     puts $out "set v(gridcolor) $v(gridcolor)"
  4640.     puts $out "set v(remote) \{$v(remote)\}"
  4641.     puts $out "set v(ashost) \{$v(ashost)\}"
  4642.     puts $out "set v(asport) \{$v(asport)\}"
  4643.     puts $out "set v(recording) \{$v(recording)\}"
  4644.     puts $out "set v(cmap) \{$v(cmap)\}"
  4645.     puts $out "set v(showspeg) \{$v(showspeg)\}"
  4646.     puts $out "set v(linkfile) \{$v(linkfile)\}"
  4647.  
  4648.     puts $out "set f(skip)  $f(skip)"
  4649.     puts $out "set f(ipath) $f(ipath)"
  4650.     puts $out "set f(ihttp) $f(ihttp)"
  4651.  
  4652.     puts $out "set s(fftlen)  $s(fftlen)"
  4653.     puts $out "set s(anabw)   $s(anabw)"
  4654.     puts $out "set s(wintype) $s(wintype)"
  4655.     puts $out "set s(ref)     $s(ref)"
  4656.     puts $out "set s(range)   $s(range)"
  4657.     puts $out "set s(atype)   $s(atype)"
  4658.     puts $out "set s(lpcorder) $s(lpcorder)"
  4659.       
  4660.       if {[info exists snack::snackogg]} {
  4661.     puts $out "set ogg(nombr) $::ogg(nombr)"
  4662.     puts $out "set ogg(maxbr) $::ogg(maxbr)"
  4663.     puts $out "set ogg(minbr) $::ogg(minbr)"
  4664.     puts $out "set ogg(com)   $::ogg(com)"
  4665.     puts $out "set ogg(query) $::ogg(query)"
  4666.       }
  4667.  
  4668.     close $out
  4669.     }
  4670. }
  4671.  
  4672. proc SetCursor {flag} {
  4673.     foreach widget [winfo children .] {
  4674.     $widget config -cursor $flag
  4675.     }
  4676.     update idletasks
  4677. }
  4678.  
  4679. # Put custom procedures between the lines below
  4680. # Custom procs start here
  4681. # Custom procs end here
  4682.  
  4683. foreach plug [split $v(pluginfiles)] {
  4684.     source $plug
  4685. }
  4686.  
  4687. DrawCrossHairs
  4688. ToggleRecording
  4689. Link2File
  4690.  
  4691. if {$tcl_platform(platform) == "windows"} {
  4692.     update idletasks
  4693.     Redraw
  4694. }
  4695.  
  4696. proc GetStdin {} {
  4697.     global v pipevar
  4698.  
  4699.     append pipevar [read -nonewline stdin]
  4700.     if [eof stdin] { 
  4701.     fileevent stdin readable ""
  4702.     if {$pipevar != ""} {
  4703.         snd data $pipevar
  4704.         set v(rate) [snd cget -rate]
  4705.         set v(sfmt) [snd cget -encoding]
  4706.         set v(chan) [snd cget -channels]
  4707.         wm geometry . {}
  4708.         Redraw
  4709.         event generate .cf.fc.c <Configure>
  4710.         MarkAll
  4711.         PlayAll
  4712.     }
  4713.     }
  4714. }
  4715.  
  4716. if [info exists demoFlag] {
  4717.     OpenFiles [file join [pwd] ex2.wav]
  4718.     OpenFiles [file join [pwd] ex2.phn]
  4719.     return
  4720. }
  4721. if {$argv == "-"} {
  4722.     fconfigure stdin -translation binary -blocking 0
  4723.     if {$tcl_version > 8.0} {
  4724.     fconfigure stdin -encoding binary
  4725.     }
  4726.     fileevent stdin readable GetStdin
  4727. } elseif [llength $argv] {
  4728.     if {[llength $argv] > 1} { set v(autoload) 0 }
  4729.     foreach file $argv {
  4730.     OpenFiles $file
  4731.     }
  4732. } else {
  4733.     if [string compare macintosh $::tcl_platform(platform)] {
  4734.     GetOpenFileName
  4735.     }
  4736. }
  4737.