1# 2# Copyright (C) 1997-99 Kare Sjolander <kare@speech.kth.se> 3# 4# This file is part of the Snack sound extension for Tcl/Tk. 5# The latest version can be found at http://www.speech.kth.se/snack/ 6# 7# This program is free software; you can redistribute it and/or modify 8# it under the terms of the GNU General Public License as published by 9# the Free Software Foundation; either version 2 of the License, or 10# (at your option) any later version. 11# 12# This program is distributed in the hope that it will be useful, 13# but WITHOUT ANY WARRANTY; without even the implied warranty of 14# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15# GNU General Public License for more details. 16# 17# You should have received a copy of the GNU General Public License 18# along with this program; if not, write to the Free Software 19# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. 20# 21 22load [file join $dir snack.shlb] 23 24package provide snack 2.2 25 26# Set playback latency according to the environment variable PLAYLATENCY 27 28if {$::tcl_platform(platform) == "unix"} { 29 if {[info exists env(PLAYLATENCY)] && $env(PLAYLATENCY) > 0} { 30 snack::audio playLatency $env(PLAYLATENCY) 31 } 32} 33 34namespace eval snack { 35 namespace export gainBox get* add* menu* frequencyAxis timeAxis \ 36 createIcons mixerDialog sound audio mixer debug 37 38 # 39 # Gain control dialog 40 # 41 42 proc gainBox flags { 43 variable gainbox 44 45 catch {destroy .snackGainBox} 46 toplevel .snackGainBox 47 wm title .snackGainBox {Gain Control Panel} 48 49 if {[string match *p* $flags]} { 50 set gainbox(play) [snack::audio play_gain] 51 pack [scale .snackGainBox.s -label {Play volume} -orient horiz \ 52 -variable snack::gainbox(play) \ 53 -command {snack::audio play_gain} \ 54 -length 200] 55 } 56 57 if {[snack::mixer inputs] != ""} { 58 if {[string match *r* $flags]} { 59 set gainbox(rec) [snack::audio record_gain] 60 pack [scale .snackGainBox.s2 -label {Record gain} \ 61 -orient horiz \ 62 -variable snack::gainbox(rec) \ 63 -command {snack::audio record_gain} \ 64 -length 200] 65 } 66 } 67 pack [button .snackGainBox.exitB -text Close -command {destroy .snackGainBox}] 68 } 69 70 # 71 # Snack mixer dialog 72 # 73 74 proc flipScaleValue {scaleVar var args} { 75 set $var [expr 100-[set $scaleVar]] 76 } 77 78 proc mixerDialog {} { 79 set wi .snackMixerDialog 80 catch {destroy $wi} 81 toplevel $wi 82 wm title $wi "Mixer" 83 84# pack [frame $wi.f0] 85# label $wi.f0.l -text "Mixer device:" 86 87# set outDevList [snack::mixer devices] 88# eval tk_optionMenu $wi.f0.om mixerDev $outDevList 89# pack $wi.f0.l $wi.f0.om -side left 90 91 pack [frame $wi.f] -expand yes -fill both 92 foreach line [snack::mixer lines] { 93 pack [frame $wi.f.g$line -bd 1 -relief solid] -side left \ 94 -expand yes -fill both 95 pack [label $wi.f.g$line.l -text $line] 96 if {[snack::mixer channels $line] == "Mono"} { 97 snack::mixer volume $line snack::v(r$line) 98 } else { 99 snack::mixer volume $line snack::v(l$line) snack::v(r$line) 100 if {[info exists tile::version]} { 101 pack [ttk::scale $wi.f.g$line.e -from 0 -to 100 -show no -orient vertical \ 102 -var snack::v(lI$line) -command [namespace code [list flipScaleValue ::snack::v(lI$line) ::snack::v(l$line)]]] -side left -expand yes -fill y 103 set snack::v(lI$line) [expr 100-[lindex [snack::mixer volume $line] end]] 104 $wi.f.g$line.e set $snack::v(lI$line) 105 } else { 106 pack [scale $wi.f.g$line.e -from 100 -to 0 -show no -orient vertical \ 107 -var snack::v(l$line)] -side left -expand yes -fill both 108 } 109 } 110 if {[info exists tile::version]} { 111 pack [ttk::scale $wi.f.g$line.s -from 0 -to 100 -show no -orient vertical \ 112 -var snack::v(rI$line) -command [namespace code [list flipScaleValue ::snack::v(rI$line) ::snack::v(r$line)]]] -expand yes -fill y 113 set snack::v(rI$line) [expr 100-[lindex [snack::mixer volume $line] end]] 114 $wi.f.g$line.s set $snack::v(rI$line) 115 } else { 116 pack [scale $wi.f.g$line.s -from 100 -to 0 -show no -orient vertical \ 117 -var snack::v(r$line)] -expand yes -fill both 118 } 119 } 120 121 pack [frame $wi.f.f2] -side left 122 123 if {[snack::mixer inputs] != ""} { 124 pack [label $wi.f.f2.li -text "Input jacks:"] 125 foreach jack [snack::mixer inputs] { 126 snack::mixer input $jack [namespace current]::v(in$jack) 127 pack [checkbutton $wi.f.f2.b$jack -text $jack \ 128 -variable [namespace current]::v(in$jack)] \ 129 -anchor w 130 } 131 } 132 if {[snack::mixer outputs] != ""} { 133 pack [label $wi.f.f2.lo -text "Output jacks:"] 134 foreach jack [snack::mixer outputs] { 135 snack::mixer output $jack [namespace current]::v(out$jack) 136 pack [checkbutton $wi.f.f2.b$jack -text $jack \ 137 -variable [namespace current]::v(out$jack)] \ 138 -anchor w 139 } 140 } 141 pack [button $wi.b1 -text Close -command "destroy $wi"] 142 } 143 144 # 145 # Snack filename dialog 146 # 147 148 proc getOpenFile {args} { 149 upvar #0 __snack_args data 150 151 set specs { 152 {-title "" "" "Open file"} 153 {-initialdir "" "" "."} 154 {-initialfile "" "" ""} 155 {-multiple "" "" 0} 156 {-format "" "" "none"} 157 } 158 159 tclParseConfigSpec __snack_args $specs "" $args 160 161 if {$data(-format) == "none"} { 162 if {$data(-initialfile) != ""} { 163 set data(-format) [ext2fmt [file extension $data(-initialfile)]] 164 } else { 165 set data(-format) WAV 166 } 167 } 168 if {$data(-format) == ""} { 169 set data(-format) RAW 170 } 171 set data(-format) [string toupper $data(-format)] 172 if {$data(-initialdir) == ""} { 173 set data(-initialdir) "." 174 } 175 if {[string match Darwin $::tcl_platform(os)]} { 176 return [tk_getOpenFile -title $data(-title) \ 177 -multiple $data(-multiple) \ 178 -filetypes [loadTypes $data(-format)] \ 179 -defaultextension [fmt2ext $data(-format)] \ 180 -initialdir $data(-initialdir)] 181 } 182 # Later Tcl's allow multiple files returned as a list 183 if {$::tcl_version <= 8.3} { 184 set res [tk_getOpenFile -title $data(-title) \ 185 -filetypes [loadTypes $data(-format)] \ 186 -defaultextension [fmt2ext $data(-format)] \ 187 -initialdir $data(-initialdir) \ 188 -initialfile $data(-initialfile)] 189 } else { 190 set res [tk_getOpenFile -title $data(-title) \ 191 -multiple $data(-multiple) \ 192 -filetypes [loadTypes $data(-format)] \ 193 -defaultextension [fmt2ext $data(-format)] \ 194 -initialdir $data(-initialdir) \ 195 -initialfile $data(-initialfile)] 196 } 197 return $res 198 } 199 200 set loadTypes "" 201 202 proc addLoadTypes {typelist fmtlist} { 203 variable loadTypes 204 variable filebox 205 206 set loadTypes $typelist 207 set i 9 ; # Needs updating when adding new formats 208 foreach fmt $fmtlist { 209 set filebox(l$fmt) $i 210 incr i 211 } 212 } 213 214 proc loadTypes fmt { 215 variable loadTypes 216 variable filebox 217 218 if {$::tcl_platform(platform) == "windows"} { 219 set l [concat {{{MS Wav Files} {.wav}} {{Smp Files} {.smp}} {{Snd Files} {.snd}} {{AU Files} {.au}} {{AIFF Files} {.aif}} {{AIFF Files} {.aiff}} {{Waves Files} {.sd}} {{MP3 Files} {.mp3}} {{CSL Files} {.nsp}}} $loadTypes {{{All Files} * }}] 220 } else { 221 set l [concat {{{MS Wav Files} {.wav .WAV}} {{Smp Files} {.smp .SMP}} {{Snd Files} {.snd .SND}} {{AU Files} {.au .AU}} {{AIFF Files} {.aif .AIF}} {{AIFF Files} {.aiff .AIFF}} {{Waves Files} {.sd .SD}} {{MP3 Files} {.mp3 .MP3}} {{CSL Files} {.nsp .NSP}}} $loadTypes {{{All Files} * }}] 222 } 223 return [swapListElem $l $filebox(l$fmt)] 224 } 225 226 variable filebox 227 set filebox(RAW) .raw 228 set filebox(SMP) .smp 229 set filebox(AU) .au 230 set filebox(WAV) .wav 231 set filebox(SD) .sd 232 set filebox(SND) .snd 233 set filebox(AIFF) .aif 234 set filebox(MP3) .mp3 235 set filebox(CSL) .nsp 236 237 set filebox(lWAV) 0 238 set filebox(lSMP) 1 239 set filebox(lSND) 2 240 set filebox(lAU) 3 241 set filebox(lAIFF) 4 242 # skip 2 because of aif and aiff 243 set filebox(lSD) 6 244 set filebox(lMP3) 7 245 set filebox(lCSL) 8 246 set filebox(lRAW) end 247 # Do not forget to update indexes 248 set filebox(sWAV) 0 249 set filebox(sSMP) 1 250 set filebox(sSND) 2 251 set filebox(sAU) 3 252 set filebox(sAIFF) 4 253 # skip 2 because of aif and aiff 254 set filebox(sCSL) 6 255 set filebox(sRAW) end 256 257 proc fmt2ext fmt { 258 variable filebox 259 260 return $filebox($fmt) 261 } 262 263 proc addExtTypes extlist { 264 variable filebox 265 266 foreach pair $extlist { 267 set filebox([lindex $pair 0]) [lindex $pair 1] 268 } 269 } 270 271 proc getSaveFile args { 272 upvar #0 __snack_args data 273 274 set specs { 275 {-title "" "" "Save file"} 276 {-initialdir "" "" "."} 277 {-initialfile "" "" ""} 278 {-format "" "" "none"} 279 } 280 281 tclParseConfigSpec __snack_args $specs "" $args 282 283 if {$data(-format) == "none"} { 284 if {$data(-initialfile) != ""} { 285 set data(-format) [ext2fmt [file extension $data(-initialfile)]] 286 } else { 287 set data(-format) WAV 288 } 289 } 290 if {$data(-format) == ""} { 291 set data(-format) RAW 292 } 293 set data(-format) [string toupper $data(-format)] 294 if {$data(-initialdir) == ""} { 295 set data(-initialdir) "." 296 } 297 if {[string match macintosh $::tcl_platform(platform)]} { 298 set tmp [tk_getSaveFile -title $data(-title) \ 299 -initialdir $data(-initialdir) -initialfile $data(-initialfile)] 300 if {[string compare [file ext $tmp] ""] == 0} { 301 append tmp [fmt2ext $data(-format)] 302 } 303 return $tmp 304 } else { 305 return [tk_getSaveFile -title $data(-title) \ 306 -filetypes [saveTypes $data(-format)] \ 307 -defaultextension [fmt2ext $data(-format)] \ 308 -initialdir $data(-initialdir) -initialfile $data(-initialfile)] 309 } 310 } 311 312 set saveTypes "" 313 314 proc addSaveTypes {typelist fmtlist} { 315 variable saveTypes 316 variable filebox 317 318 set saveTypes $typelist 319 set j 7 ; # Needs updating when adding new formats 320 foreach fmt $fmtlist { 321 set filebox(s$fmt) $j 322 incr j 323 } 324 } 325 326 proc saveTypes fmt { 327 variable saveTypes 328 variable filebox 329 330 if {[info exists filebox(s$fmt)] == 0} { 331 set fmt RAW 332 } 333 if {$::tcl_platform(platform) == "windows"} { 334 set l [concat {{{MS Wav Files} {.wav}} {{Smp Files} {.smp}} {{Snd Files} {.snd}} {{AU Files} {.au}} {{AIFF Files} {.aif}} {{AIFF Files} {.aiff}} {{CSL Files} {.nsp}}} $saveTypes {{{All Files} * }}] 335 } else { 336 set l [concat {{{MS Wav Files} {.wav .WAV}} {{Smp Files} {.smp .SMP}} {{Snd Files} {.snd .SND}} {{AU Files} {.au .AU}} {{AIFF Files} {.aif .AIF}} {{AIFF Files} {.aiff .AIFF}} {{CSL Files} {.nsp .NSP}}} $saveTypes {{{All Files} * }}] 337 } 338 return [swapListElem $l $filebox(s$fmt)] 339 } 340 341 proc swapListElem {l n} { 342 set tmp [lindex $l $n] 343 set l [lreplace $l $n $n] 344 return [linsert $l 0 $tmp] 345 } 346 347 set filebox(.wav) WAV 348 set filebox(.smp) SMP 349 set filebox(.au) AU 350 set filebox(.raw) RAW 351 set filebox(.snd) SND 352 set filebox(.sd) SD 353 set filebox(.aif) AIFF 354 set filebox(.aiff) AIFF 355 set filebox(.mp3) MP3 356 set filebox(.nsp) CSL 357 set filebox() WAV 358 359 proc ext2fmt ext { 360 variable filebox 361 362 return $filebox($ext) 363 } 364 365 # 366 # Menus 367 # 368 369 proc menuInit { {m .menubar} } { 370 variable menu 371 372 menu $m 373 [winfo parent $m] configure -menu $m 374 set menu(menubar) $m 375 set menu(uid) 0 376 } 377 378 proc menuPane {label {u 0} {postcommand ""}} { 379 variable menu 380 381 if [info exists menu(menu,$label)] { 382 error "Menu $label already defined" 383 } 384 if {$label == "Help"} { 385 set name $menu(menubar).help 386 } else { 387 set name $menu(menubar).mb$menu(uid) 388 } 389 set m [menu $name -tearoff 1 -postcommand $postcommand] 390 $menu(menubar) add cascade -label $label -menu $name -underline $u 391 incr menu(uid) 392 set menu(menu,$label) $m 393 return $m 394 } 395 396 proc menuDelete {menuName label} { 397 variable menu 398 399 set m [menuGet $menuName] 400 if [catch {$m index $label} index] { 401 error "$label not in menu $menuName" 402 } 403 [menuGet $menuName] delete $index 404 } 405 406 proc menuDeleteByIndex {menuName index} { 407 [menuGet $menuName] delete $index 408 } 409 410 proc menuGet menuName { 411 variable menu 412 if [catch {set menu(menu,$menuName)} m] { 413 return -code error "No such menu: $menuName" 414 } 415 return $m 416 } 417 418 proc menuCommand {menuName label command} { 419 [menuGet $menuName] add command -label $label -command $command 420 } 421 422 proc menuCheck {menuName label var {command {}} } { 423 variable menu 424 425 [menuGet $menuName] add check -label $label -command $command \ 426 -variable $var 427 } 428 429 proc menuRadio {menuName label var {val {}} {command {}} } { 430 variable menu 431 432 if {[string length $val] == 0} { 433 set val $label 434 } 435 [menuGet $menuName] add radio -label $label -command $command \ 436 -value $val -variable $var 437 } 438 439 proc menuSeparator menuName { 440 variable menu 441 442 [menuGet $menuName] add separator 443 } 444 445 proc menuCascade {menuName label} { 446 variable menu 447 448 set m [menuGet $menuName] 449 if [info exists menu(menu,$label)] { 450 error "Menu $label already defined" 451 } 452 set sub $m.sub$menu(uid) 453 incr menu(uid) 454 menu $sub -tearoff 0 455 $m add cascade -label $label -menu $sub 456 set menu(menu,$label) $sub 457 return $sub 458 } 459 460 proc menuBind {what char menuName label} { 461 variable menu 462 463 set m [menuGet $menuName] 464 if [catch {$m index $label} index] { 465 error "$label not in menu $menuName" 466 } 467 set command [$m entrycget $index -command] 468 if {$::tcl_platform(platform) == "unix"} { 469 bind $what <Alt-$char> $command 470 $m entryconfigure $index -accelerator Alt-$char 471 } else { 472 bind $what <Control-$char> $command 473 set char [string toupper $char] 474 $m entryconfigure $index -accelerator Ctrl-$char 475 } 476 } 477 478 proc menuEntryOff {menuName label} { 479 variable menu 480 481 set m [menuGet $menuName] 482 if [catch {$m index $label} index] { 483 error "$label not in menu $menuName" 484 } 485 $m entryconfigure $index -state disabled 486 } 487 488 proc menuEntryOn {menuName label} { 489 variable menu 490 491 set m [menuGet $menuName] 492 if [catch {$m index $label} index] { 493 error "$label not in menu $menuName" 494 } 495 $m entryconfigure $index -state normal 496 } 497 498 # 499 # Vertical frequency axis 500 # 501 502 proc frequencyAxis {canvas x y width height args} { 503 array set a [list \ 504 -tags snack_y_axis \ 505 -font {Helvetica 8} \ 506 -topfr 8000 \ 507 -fill black \ 508 -draw0 0 509 ] 510 if {[string match unix $::tcl_platform(platform)] } { 511 set a(-font) {Helvetica 10} 512 } 513 array set a $args 514 515 if {$height <= 0} return 516 set ticklist [list 10 20 50 100 200 500 1000 2000 5000 \ 517 10000 20000 50000 100000 200000 500000 1000000] 518 set npt 10 519 set dy [expr {double($height * $npt) / $a(-topfr)}] 520 521 while {$dy < [font metrics $a(-font) -linespace]} { 522 foreach elem $ticklist { 523 if {$elem <= $npt} { 524 continue 525 } 526 set npt $elem 527 break 528 } 529 set dy [expr {double($height * $npt) / $a(-topfr)}] 530 } 531 532 if {$npt < 1000} { 533 set hztext Hz 534 } else { 535 set hztext kHz 536 } 537 538 if $a(-draw0) { 539 set i0 0 540 set j0 0 541 } else { 542 set i0 $dy 543 set j0 1 544 } 545 546 for {set i $i0; set j $j0} {$i < $height} {set i [expr {$i+$dy}]; incr j} { 547 set yc [expr {$height + $y - $i}] 548 549 if {$npt < 1000} { 550 set t [expr {$j * $npt}] 551 } else { 552 set t [expr {$j * $npt / 1000}] 553 } 554 if {$yc > [expr {8 + $y}]} { 555 if {[expr {$yc - [font metrics $a(-font) -ascent]}] > \ 556 [expr {$y + [font metrics $a(-font) -linespace]}] || 557 [font measure $a(-font) $hztext] < \ 558 [expr {$width - 8 - [font measure $a(-font) $t]}]} { 559 $canvas create text [expr {$x +$width - 8}] [expr {$yc-2}]\ 560 -text $t -fill $a(-fill)\ 561 -font $a(-font) -anchor e -tags $a(-tags) 562 } 563 $canvas create line [expr {$x + $width - 5}] $yc \ 564 [expr {$x + $width}]\ 565 $yc -tags $a(-tags) -fill $a(-fill) 566 } 567 } 568 $canvas create text [expr {$x + 2}] [expr {$y + 1}] -text $hztext \ 569 -font $a(-font) -anchor nw -tags $a(-tags) -fill $a(-fill) 570 571 return $npt 572 } 573 574 # 575 # Horizontal time axis 576 # 577 578 proc timeAxis {canvas ox oy width height pps args} { 579 array set a [list \ 580 -tags snack_t_axis \ 581 -font {Helvetica 8} \ 582 -starttime 0.0 \ 583 -fill black \ 584 -format time \ 585 -draw0 0 \ 586 -drawvisible 0 587 ] 588 if {[string match unix $::tcl_platform(platform)] } { 589 set a(-font) {Helvetica 10} 590 } 591 array set a $args 592 593 if {$pps <= 0.004} return 594 595 switch -- $a(-format) { 596 time - 597 seconds { 598 set deltalist [list .0001 .0002 .0005 .001 .002 .005 \ 599 .01 .02 .05 .1 .2 .5 1 2 5 \ 600 10 20 30 60 120 240 360 600 900 1800 3600 7200 14400] 601 } 602 "PAL frames" { 603 set deltalist [list .04 .08 .4 .8 2 4 \ 604 10 20 50 100 200 500 1000 2000 5000 10000 20000] 605 } 606 "NTSC frames" { 607 set deltalist [list .03333333333334 .0666666666667 \ 608 .3333333333334 .666666666667 1 2 4 \ 609 10 20 50 100 200 500 1000 2000 5000 10000 20000] 610 } 611 "10ms frames" { 612 set deltalist [list .01 .02 .05 .1 .2 .5 1 2 5 \ 613 10 20 50 100 200 500 1000 2000 5000 10000 20000] 614 } 615 } 616 617 set majTickH [expr {$height - [font metrics $a(-font) -linespace]}] 618 set minTickH [expr {$majTickH / 2}] 619 620# Create a typical time label 621 622 set maxtime [expr {double($width) / $pps + $a(-starttime)}] 623 if {$maxtime < 60} { 624 set wtime 00 625 } elseif {$maxtime < 3600} { 626 set wtime 00:00 627 } else { 628 set wtime 00:00:00 629 } 630 if {$pps > 50} { 631 append wtime .0 632 } elseif {$pps > 500} { 633 append wtime .00 634 } elseif {$pps > 5000} { 635 append wtime .000 636 } elseif {$pps > 50000} { 637 append wtime .0000 638 } 639 640# Compute the distance in pixels (and time) between tick marks 641 642 set dx [expr {10+[font measure $a(-font) $wtime]}] 643 set dt [expr {double($dx) / $pps}] 644 645 foreach elem $deltalist { 646 if {$elem <= $dt} { 647 continue 648 } 649 set dt $elem 650 break 651 } 652 set dx [expr {$pps * $dt}] 653 654 if {$dt < 0.00099} { 655 set ndec 4 656 } elseif {$dt < 0.0099} { 657 set ndec 3 658 } elseif {$dt < 0.099} { 659 set ndec 2 660 } else { 661 set ndec 1 662 } 663 664 if {$a(-starttime) > 0.0} { 665 set ft [expr {(int($a(-starttime) / $dt) + 1) * $dt}] 666 set fx [expr {$pps * ($ft - $a(-starttime))}] 667 } else { 668 set ft 0 669 set fx 0.0 670 } 671 672 set lx [expr {($ox + $width) * [lindex [$canvas xview] 0] - 50}] 673 set rx [expr {($ox + $width) * [lindex [$canvas xview] 1] + 50}] 674 675 set jinit 0 676 677 if {$a(-drawvisible)} { 678 set jinit [expr {int($lx/$dx)}] 679 set fx [expr {$fx + $jinit * $dx}] 680 } 681 682 for {set x $fx;set j $jinit} {$x < $width} \ 683 {set x [expr {$x+$dx}];incr j} { 684 685 if {$a(-drawvisible) && $x < $lx} continue 686 if {$a(-drawvisible) && $x > $rx} break 687 688 switch -- $a(-format) { 689 time { 690 set t [expr {$j * $dt + $ft}] 691 692 if {$maxtime < 60} { 693 set tmp [expr {int($t)}] 694 } elseif {$maxtime < 3600} { 695 set tmp x[clock format [expr {int($t)}] -format "%M:%S" -gmt 1] 696 regsub x0 $tmp "" tmp 697 regsub x $tmp "" tmp 698 } else { 699 set tmp [clock format [expr {int($t)}] -format "%H:%M:%S" -gmt 1] 700 } 701 if {$dt < 1.0} { 702 set t $tmp[string trimleft [format "%.${ndec}f" \ 703 [expr {($t-int($t))}]] 0] 704 } else { 705 set t $tmp 706 } 707 } 708 "PAL frames" { 709 set t [expr {int($j * $dt * 25.0 + $ft)}] 710 } 711 "NTSC frames" { 712 set t [expr {int($j * $dt * 30.0 + $ft)}] 713 } 714 "10ms frames" { 715 set t [expr {int($j * $dt * 100.0 + $ft)}] 716 } 717 seconds { 718 set t [expr {double($j * $dt * 1.0 + $ft)}] 719 } 720 } 721 if {$a(-draw0) == 1 || $j > 0 || $a(-starttime) > 0.0} { 722 $canvas create text [expr {$ox+$x}] [expr {$oy+$height}] \ 723 -text $t -font $a(-font) -anchor s -tags $a(-tags) \ 724 -fill $a(-fill) 725 } 726 $canvas create line [expr {$ox+$x}] $oy [expr {$ox+$x}] \ 727 [expr {$oy+$majTickH}] -tags $a(-tags) -fill $a(-fill) 728 729 if {[string match *5 $dt] || [string match 5* $dt]} { 730 set nt 5 731 } else { 732 set nt 2 733 } 734 for {set k 1} {$k < $nt} {incr k} { 735 set xc [expr {$k * $dx / $nt}] 736 $canvas create line [expr {$ox+$x+$xc}] $oy \ 737 [expr {$ox+$x+$xc}] [expr {$oy+$minTickH}]\ 738 -tags $a(-tags) -fill $a(-fill) 739 } 740 741 } 742 } 743 744 # 745 # Snack icons 746 # 747 748 variable icon 749 750 set icon(new) R0lGODlhEAAQALMAAAAAAMbGxv///////////////////////////////////////////////////////yH5BAEAAAEALAAAAAAQABAAAAQwMMhJ6wQ4YyuB+OBmeeDnAWNpZhWpmu0bxrKAUu57X7VNy7tOLxjIqYiapIjDbDYjADs= 751 752 set icon(open) R0lGODlhEAAQALMAAAAAAISEAMbGxv//AP///////////////////////////////////////////////yH5BAEAAAIALAAAAAAQABAAAAQ4UMhJq6Ug3wpm7xsHZqBFCsBADGTLrbCqllIaxzSKt3wmA4GgUPhZAYfDEQuZ9ByZAVqPF6paLxEAOw== 753 754 set icon(save) R0lGODlhEAAQALMAAAAAAISEAMbGxv///////////////////////////////////////////////////yH5BAEAAAIALAAAAAAQABAAAAQ3UMhJqwQ4a30DsJfwiR4oYt1oASWpVuwYm7NLt6y3YQHe/8CfrLfL+HQcGwmZSXWYKOWpmDSBIgA7 755 756 set icon(print) R0lGODlhEAAQALMAAAAAAISEhMbGxv//AP///////////////////////////////////////////////yH5BAEAAAIALAAAAAAQABAAAAQ5UMhJqwU450u67wCnAURYkZ9nUuRYbhKalkJoj1pdYxar40ATrxIoxn6WgTLGC4500J6N5Vz1roIIADs= 757 758# set icon(open) R0lGODlhFAATAOMAAAAAAFeEAKj/AYQAV5o2AP8BqP9bAQBXhC8AhJmZmWZmZszMzAGo/1sB/////9zc3CH5BAEAAAsALAAAAAAUABMAQARFcMlJq13ANc03uGAoTp+kACWpAUjruum4nAqI3hdOZVtz/zoS6/WKyY7I4wlnPKIqgB7waet1VqHoiliE+riw3PSXlEUAADs= 759 760# set icon(save) R0lGODlhFAATAOMAAAAAAAAAhAAA/wCEAACZmQD/AAD//4QAAISEAJmZmWZmZszMzP8AAP//AP///9zc3CH5BAEAAAsALAAAAAAUABMAQARBcMlJq5VACGDzvkAojiGocZWHUiopflcsL2p32lqu3+lJYrCZcCh0GVeTWi+Y5LGczY0RCtxZkVUXEEvzjbbEWQQAOw== 761 762# set icon(print) R0lGODlhFAATAOMAAAAAAAAAhAAA/wCEAACZmQD/AAD//4QAAISEAJmZmWZmZszMzP8AAP//AP///9zc3CH5BAEAAAsALAAAAAAUABMAQARHcMlJq53A6b2BEIAFjGQZXlTGdZX3vTAInmiNqqtGY3Ev76bgCGQrGo8toS3DdIycNWZTupMITbPUtfQBznyz6sLl84iRlAgAOw== 763 764# set icon(cut) R0lGODlhFAATAOMAAAAAAAAAhAAA/wCEAACZmQD/AAD//4QAAISEAJmZmWZmZszMzP8AAP//AP///9zc3CH5BAEAAAsALAAAAAAUABMAQAQ3cMlJq71LAYUvANPXVVsGjpImfiW6nK87aS8nS+x9gvvt/xgYzLUaEkVAI0r1ao1WMWSn1wNeIgA7 765 766# set icon(copy) R0lGODlhFAATAOMAAAAAAAAAhAAA/wCEAACZmQD/AAD//4QAAISEAJmZmWZmZszMzP8AAP//AP///9zc3CH5BAEAAAsALAAAAAAUABMAQARFcMlJq5XAZSB0FqBwjSTmnF45ASzbbZojqrTJyqgMjDAXwzNSaAiqGY+UVsuYQRGDluap49RcpLjcNJqjaqEXbxdJLkUAADs= 767 768# set icon(paste) R0lGODlhFAATAOMAAAAAAFeEAKj/AYQAV5o2AP8BqP9bAQBXhC8AhJmZmWZmZszMzAGo/1sB/////9zc3CH5BAEAAAsALAAAAAAUABMAQARTcMlJq11A6c01uFXjAGNJNpMCrKvEroqVcSJ5NjgK7tWsUr5PryNyGB04GdHE1PGe0OjrGcR8qkPPCwsk5nLCLu1oFCUnPk2RfHSqXms2cvetJyMAOw== 769 770# set icon(undo) R0lGODlhFAATAOMAAAAAAAAAhAAA/wCEAACZmQD/AAD//4QAAISEAJmZmWZmZszMzP8AAP//AP///9zc3CH5BAEAAAsALAAAAAAUABMAQAQ7cMlJq6UKALmpvmCIaWQJZqXidWJboWr1XSgpszTu7nyv1IBYyCSBgWyWjHAUnE2cnBKyGDxNo72sKwIAOw== 771 772 set icon(cut) R0lGODlhEAAQALMAAAAAAAAAhMbGxv///////////////////////////////////////////////////yH5BAEAAAIALAAAAAAQABAAAAQvUMhJqwUTW6pF314GZhjwgeXImSrXTgEQvMIc3ONtS7PV77XNL0isDGs9YZKmigAAOw== 773 774 set icon(copy) R0lGODlhEAAQALMAAAAAAAAAhMbGxv///////////////////////////////////////////////////yH5BAEAAAIALAAAAAAQABAAAAQ+UMhJqwA4WwqGH9gmdV8HiKYZrCz3ecG7TikWf3EwvkOM9a0a4MbTkXCgTMeoHPJgG5+yF31SLazsTMTtViIAOw== 775 776 set icon(paste) R0lGODlhEAAQALMAAAAAAAAAhISEAISEhMbGxv//AP///////////////////////////////////////yH5BAEAAAQALAAAAAAQABAAAARMkMhJqwUYWJlxKZ3GCYMAgCdQDqLKXmUrGGE2vIRK7usu94GgMNDqDQKGZDI4AiqXhkDOiMxEhQCeAPlUEqm0UDTX4XbHlaFaumlHAAA7 777 778 set icon(undo) R0lGODlhEAAQALMAAAAAhMbGxv///////////////////////////////////////////////////////yH5BAEAAAEALAAAAAAQABAAAAQgMMhJq704622BB93kUSAJlhUafJj6qaLJklxc33iuXxEAOw== 779 780 set icon(redo) R0lGODlhFAATAKEAAMzMzGZmZgAAAAAAACH5BAEAAAAALAAAAAAUABMAAAI4hI+py+0fhBQhPDCztCzSkzWS4nFJZCLTMqrGxgrJBistmKUHqmo3jvBMdC9Z73MBEZPMpvOpKAAAOw== 781 782 set icon(gain) R0lGODlhFAATAOMAAAAAAFpaWjMzZjMAmZlmmapV/729vY+Pj5mZ/+/v78zM/wAAAAAAAAAAAAAAAAAAACH5BAEAAAUALAAAAAAUABMAAARnsMhJqwU4a32T/6AHdF8WjhUAAoa6kqwhtyW8uUlG4Tl2DqoJjzUcIAIeyZAmAiBwyhUNADQCAsHCUoVBKBTERLQ0RRiftLGoPGgDk1qpC+N2qXPM5lscL/lAAj5CIYQ5gShaN4oVEQA7 783 784 set icon(zoom) R0lGODlhFAATAMIAAAAAAF9fXwAA/8zM/8zMzP///wAAAAAAACH5BAEAAAQALAAAAAAUABMAAAM/SLrc/jBKGYAFYapaes0U0I0VIIkjaUZo2q1Q68IP5r5UcFtgbL8YTOhS+mgWFcFAeCQEBMre8WlpLqrWrCYBADs= 785 786 set icon(zoomIn) R0lGODlhFAATAMIAAMzMzF9fXwAAAP///wAA/8zM/wAAAAAAACH5BAEAAAAALAAAAAAUABMAAANBCLrc/jBKGYQVYao6es2U0FlDJUjimFbocF1u+5JnhKldHAUB7mKom+oTupiImo2AUAAmAQECE/SMWp6LK3arSQAAOw== 787 788 set icon(zoomOut) R0lGODlhFAATAMIAAMzMzF9fXwAAAP///wAA/8zM/wAAAAAAACH5BAEAAAAALAAAAAAUABMAAANCCLrc/jBKGYQVYao6es2U0I2VIIkjaUbidQ0r1LrtGaRj/AQ3boEyTA6DCV1KH82iQigUlYAAoQlUSi3QBTbL1SQAADs= 789 790 set icon(play) R0lGODlhFQAVAKEAANnZ2QAAAP///////yH+FUNyZWF0ZWQgd2l0aCBUaGUgR0lNUAAh+QQBCgAAACwAAAAAFQAVAAACJISPqcvtD10IUc1Zz7157+h5Txg2pMicmESCqLt2VEbX9o1XBQA7 791 792 set icon(pause) R0lGODlhFQAVAKEAANnZ2QAAAP///////yH+FUNyZWF0ZWQgd2l0aCBUaGUgR0lNUAAh+QQBCgAAACwAAAAAFQAVAAACLISPqcvtD12Y09DKbrC3aU55HfBlY7mUqKKO6emycGjSa9LSrx1H/g8MCiMFADs= 793 set icon(stop) R0lGODlhFQAVAKEAANnZ2QAAAP///////yH+FUNyZWF0ZWQgd2l0aCBUaGUgR0lNUAAh+QQBCgAAACwAAAAAFQAVAAACJISPqcvtD12YtM5mc8C68n4xIPWBZXdqabZarSeOW0TX9o3bBQA7 794 795 set icon(record) R0lGODlhFQAVAKEAANnZ2f8AAP///////yH+FUNyZWF0ZWQgd2l0aCBUaGUgR0lNUAAh+QQBCgAAACwAAAAAFQAVAAACJoSPqcvtDyMINMhZM8zcuq41ICeOVWl6S0p95pNu4BVe9o3n+lIAADs= 796 797 proc createIcons {} { 798 variable icon 799 800 image create photo snackOpen -data $icon(open) 801 image create photo snackSave -data $icon(save) 802 image create photo snackPrint -data $icon(print) 803 image create photo snackCut -data $icon(cut) 804 image create photo snackCopy -data $icon(copy) 805 image create photo snackPaste -data $icon(paste) 806 image create photo snackUndo -data $icon(undo) 807 image create photo snackRedo -data $icon(redo) 808 image create photo snackGain -data $icon(gain) 809 image create photo snackZoom -data $icon(zoom) 810 image create photo snackZoomIn -data $icon(zoomIn) 811 image create photo snackZoomOut -data $icon(zoomOut) 812 image create photo snackPlay -data $icon(play) 813 image create photo snackPause -data $icon(pause) 814 image create photo snackStop -data $icon(stop) 815 image create photo snackRecord -data $icon(record) 816 } 817 818 # 819 # Support routines for shape files 820 # 821 822 proc deleteInvalidShapeFile {fileName} { 823 if {$fileName == ""} return 824 if ![file exists $fileName] return 825 set shapeName "" 826 if [file exists [file rootname $fileName].shape] { 827 set shapeName [file rootname $fileName].shape 828 } 829 if [file exists [file rootname [file tail $fileName]].shape] { 830 set shapeName [file rootname [file tail $fileName]].shape 831 } 832 if {$shapeName != ""} { 833 set fileTime [file mtime $fileName] 834 set shapeTime [file mtime $shapeName] 835 if {$fileTime > $shapeTime} { 836 837 # Delete shape file if older than sound file 838 839 file delete -force $shapeName 840 } else { 841 set s [snack::sound] 842 $s config -file $fileName 843 set soundSize [expr {200 * [$s length -unit seconds] * \ 844 [$s cget -channels]}] 845 set shapeSize [file size $shapeName] 846 if {[expr {$soundSize*0.95}] > $shapeSize || \ 847 [expr {$soundSize*1.05}] < $shapeSize} { 848 849 # Delete shape file with incorrect size 850 851 file delete -force $shapeName 852 } 853 $s destroy 854 } 855 } 856 } 857 858 proc makeShapeFileDeleteable {fileName} { 859 if {$::tcl_platform(platform) == "unix"} { 860 if [file exists [file rootname $fileName].shape] { 861 set shapeName [file rootname $fileName].shape 862 catch {file attributes $shapeName -permissions 0777} 863 } 864 if [file exists [file rootname [file tail $fileName]].shape] { 865 set shapeName [file rootname [file tail $fileName]].shape 866 catch {file attributes $shapeName -permissions 0777} 867 } 868 } 869 } 870 871 # 872 # Snack default progress callback 873 # 874 875 proc progressCallback {message fraction} { 876 set w .snackProgressDialog 877 878# if {$fraction == 0.0} return 879 if {$fraction == 1.0} { 880 881 # Task is finished close dialog 882 883 destroy $w 884 return 885 } 886 if {![winfo exists $w]} { 887 888 # Open progress dialog if not currently shown 889 890 toplevel $w 891 pack [label $w.l] 892 pack [canvas $w.c -width 200 -height 20 -relief sunken \ 893 -borderwidth 2] 894 $w.c create rect 0 0 0 20 -fill black -tags bar 895 pack [button $w.b -text Stop -command "destroy $w.b"] 896 wm title $w "Please wait..." 897 wm transient $w . 898 wm withdraw $w 899 set x [expr {[winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \ 900 - [winfo vrootx [winfo parent $w]]}] 901 set y [expr {[winfo screenheight $w]/2 - [winfo reqheight $w]/2 \ 902 - [winfo vrooty [winfo parent $w]]}] 903 wm geom $w +$x+$y 904 wm deiconify $w 905 update idletasks 906 } elseif {![winfo exists $w.b]} { 907 908 # User hit Stop button, close dialog 909 destroy $w 910 return -code error 911 } 912 switch -- $message { 913 "Converting rate" { 914 set message "Converting sample rate..." 915 } 916 "Converting encoding" { 917 set message "Converting sample encoding format..." 918 } 919 "Converting channels" { 920 set message "Converting number of channels..." 921 } 922 "Computing pitch" { 923 set message "Computing pitch..." 924 } 925 "Reading sound" { 926 set message "Reading sound..." 927 } 928 "Writing sound" { 929 set message "Writing sound..." 930 } 931 "Computing waveform" { 932 set message "Waveform is being precomputed and\ 933 stored on disk..." 934 } 935 "Reversing sound" { 936 set message "Reversing sound..." 937 } 938 "Filtering sound" { 939 set message "Filtering sound..." 940 } 941 } 942 $w.l configure -text $message 943 $w.c coords bar 0 0 [expr {$fraction * 200}] 20 944 update 945 } 946 947 # 948 # Convenience function to create dialog boxes, derived from tk_messageBox 949 # 950 951 proc makeDialogBox {toplevel args} { 952 variable tkPriv 953 954 set w tkPrivMsgBox 955 upvar #0 $w data 956 957 # 958 # The default value of the title is space (" ") not the empty string 959 # because for some window managers, a 960 # wm title .foo "" 961 # causes the window title to be "foo" instead of the empty string. 962 # 963 set specs { 964 {-default "" "" ""} 965 {-message "" "" ""} 966 {-parent "" "" .} 967 {-title "" "" " "} 968 {-type "" "" "okcancel"} 969 } 970 971 tclParseConfigSpec $w $specs "" $args 972 973 if {![winfo exists $data(-parent)]} { 974 error "bad window path name \"$data(-parent)\"" 975 } 976 977 switch -- $data(-type) { 978 abortretryignore { 979 set buttons { 980 {abort -width 6 -text Abort -under 0} 981 {retry -width 6 -text Retry -under 0} 982 {ignore -width 6 -text Ignore -under 0} 983 } 984 } 985 ok { 986 set buttons { 987 {ok -width 6 -text OK -under 0} 988 } 989 if {![string compare $data(-default) ""]} { 990 set data(-default) "ok" 991 } 992 } 993 okcancel { 994 set buttons { 995 {ok -width 6 -text OK -under 0} 996 {cancel -width 6 -text Cancel -under 0} 997 } 998 } 999 retrycancel { 1000 set buttons { 1001 {retry -width 6 -text Retry -under 0} 1002 {cancel -width 6 -text Cancel -under 0} 1003 } 1004 } 1005 yesno { 1006 set buttons { 1007 {yes -width 6 -text Yes -under 0} 1008 {no -width 6 -text No -under 0} 1009 } 1010 } 1011 yesnocancel { 1012 set buttons { 1013 {yes -width 6 -text Yes -under 0} 1014 {no -width 6 -text No -under 0} 1015 {cancel -width 6 -text Cancel -under 0} 1016 } 1017 } 1018 default { 1019 error "bad -type value \"$data(-type)\": must be abortretryignore, ok, okcancel, retrycancel, yesno, or yesnocancel" 1020 } 1021 } 1022 1023 if {[string compare $data(-default) ""]} { 1024 set valid 0 1025 foreach btn $buttons { 1026 if {![string compare [lindex $btn 0] $data(-default)]} { 1027 set valid 1 1028 break 1029 } 1030 } 1031 if {!$valid} { 1032 error "invalid default button \"$data(-default)\"" 1033 } 1034 } 1035 1036 # 2. Set the dialog to be a child window of $parent 1037 # 1038 # 1039 if {[string compare $data(-parent) .]} { 1040 set w $data(-parent)$toplevel 1041 } else { 1042 set w $toplevel 1043 } 1044 1045 # 3. Create the top-level window and divide it into top 1046 # and bottom parts. 1047 1048 # catch {destroy $w} 1049 # toplevel $w -class Dialog 1050 wm title $w $data(-title) 1051 wm iconname $w Dialog 1052 wm protocol $w WM_DELETE_WINDOW { } 1053 1054 # Message boxes should be transient with respect to their parent so that 1055 # they always stay on top of the parent window. But some window managers 1056 # will simply create the child window as withdrawn if the parent is not 1057 # viewable (because it is withdrawn or iconified). This is not good for 1058 # "grab"bed windows. So only make the message box transient if the parent 1059 # is viewable. 1060 # 1061 if { [winfo viewable [winfo toplevel $data(-parent)]] } { 1062 wm transient $w $data(-parent) 1063 } 1064 1065 if {![string compare $::tcl_platform(platform) "macintosh"]} { 1066 unsupported1 style $w dBoxProc 1067 } 1068 1069 frame $w.bot 1070 pack $w.bot -side bottom -fill both 1071 if {[string compare $::tcl_platform(platform) "macintosh"]} { 1072 $w.bot configure -relief raised -bd 1 1073 } 1074 1075 # 4. Fill the top part with bitmap and message (use the option 1076 # database for -wraplength and -font so that they can be 1077 # overridden by the caller). 1078 1079 option add *Dialog.msg.wrapLength 3i widgetDefault 1080 if {![string compare $::tcl_platform(platform) "macintosh"]} { 1081 option add *Dialog.msg.font system widgetDefault 1082 } else { 1083 option add *Dialog.msg.font {Times 18} widgetDefault 1084 } 1085 1086 1087 # 5. Create a row of buttons at the bottom of the dialog. 1088 1089 set i 0 1090 foreach but $buttons { 1091 set name [lindex $but 0] 1092 set opts [lrange $but 1 end] 1093 if {![llength $opts]} { 1094 # Capitalize the first letter of $name 1095 set capName [string toupper \ 1096 [string index $name 0]][string range $name 1 end] 1097 set opts [list -text $capName] 1098 } 1099 1100 eval button [list $w.$name] $opts [list -command \ 1101 [list set [namespace current]::tkPriv(button) $name]] 1102 1103 if {![string compare $name $data(-default)]} { 1104 $w.$name configure -default active 1105 } 1106 pack $w.$name -in $w.bot -side left -expand 1 -padx 3m -pady 2m 1107 1108 # create the binding for the key accelerator, based on the underline 1109 # 1110 set underIdx [$w.$name cget -under] 1111 if {$underIdx >= 0} { 1112 set key [string index [$w.$name cget -text] $underIdx] 1113 bind $w <Alt-[string tolower $key]> [list $w.$name invoke] 1114 bind $w <Alt-[string toupper $key]> [list $w.$name invoke] 1115 } 1116 incr i 1117 } 1118 1119 if {[string compare {} $data(-default)]} { 1120 bind $w <FocusIn> { 1121 if {0 == [string compare Button [winfo class %W]]} { 1122 %W configure -default active 1123 } 1124 } 1125 bind $w <FocusOut> { 1126 if {0 == [string compare Button [winfo class %W]]} { 1127 %W configure -default normal 1128 } 1129 } 1130 } 1131 1132 # 6. Create a binding for <Return> on the dialog 1133 1134 bind $w <Return> { 1135 if {0 == [string compare Button [winfo class %W]]} { 1136 if {$::tcl_version <= 8.3} { 1137 tkButtonInvoke %W 1138 } else { 1139 tk::ButtonInvoke %W 1140 } 1141 } 1142 } 1143 1144 # 7. Withdraw the window, then update all the geometry information 1145 # so we know how big it wants to be, then center the window in the 1146 # display and de-iconify it. 1147 1148 wm withdraw $w 1149 update idletasks 1150 set x [expr {[winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \ 1151 - [winfo vrootx [winfo parent $w]]}] 1152 set y [expr {[winfo screenheight $w]/2 - [winfo reqheight $w]/2 \ 1153 - [winfo vrooty [winfo parent $w]]}] 1154 wm geom $w +$x+$y 1155 wm deiconify $w 1156 1157 # 8. Set a grab and claim the focus too. 1158 1159 set oldFocus [focus] 1160 set oldGrab [grab current $w] 1161 if {[string compare $oldGrab ""]} { 1162 set grabStatus [grab status $oldGrab] 1163 } 1164 grab $w 1165 if {[string compare $data(-default) ""]} { 1166 focus $w.$data(-default) 1167 } else { 1168 focus $w 1169 } 1170 1171 # 9. Wait for the user to respond, then restore the focus and 1172 # return the index of the selected button. Restore the focus 1173 # before deleting the window, since otherwise the window manager 1174 # may take the focus away so we can't redirect it. Finally, 1175 # restore any grab that was in effect. 1176 1177 tkwait variable [namespace current]::tkPriv(button) 1178 1179 catch {focus $oldFocus} 1180 destroy $w 1181 if {[string compare $oldGrab ""]} { 1182 if {![string compare $grabStatus "global"]} { 1183 grab -global $oldGrab 1184 } else { 1185 grab $oldGrab 1186 } 1187 } 1188 return $tkPriv(button) 1189 } 1190 1191 # 1192 # Snack level meter implemented as minimal mega widget 1193 # 1194 1195 proc levelMeter {w args} { 1196 1197 array set a [list \ 1198 -oncolor red \ 1199 -offcolor grey10 \ 1200 -background black \ 1201 -width 6 \ 1202 -length 80 \ 1203 -level 0.0 \ 1204 -orient horizontal \ 1205 -type log \ 1206 ] 1207 array set a $args 1208 1209 # Widget specific storage 1210 1211 namespace eval [namespace current]::$w { 1212 variable levelmeter 1213 } 1214 upvar [namespace current]::${w}::levelmeter lm 1215 set lm(level) 0 1216 set lm(orient) $a(-orient) 1217 set lm(oncolor) $a(-oncolor) 1218 set lm(offcolor) $a(-offcolor) 1219 set lm(bg) $a(-background) 1220 set lm(type) $a(-type) 1221 if {[string match horiz* $lm(orient)]} { 1222 set lm(height) $a(-width) 1223 set lm(width) $a(-length) 1224 } else { 1225 set lm(height) $a(-length) 1226 set lm(width) $a(-width) 1227 } 1228 set lm(maxtime) [clock seconds] 1229 set lm(maxlevel) 0.0 1230 1231 proc drawLevelMeter {w} { 1232 upvar [namespace current]::${w}::levelmeter lm 1233 1234 set c ${w}_levelMeter 1235 $c configure -width $lm(width) -height $lm(height) 1236 $c delete all 1237 1238 $c create rectangle 0 0 $lm(width) $lm(height) \ 1239 -fill $lm(oncolor) -outline "" 1240 $c create rectangle 0 0 0 0 -outline "" -fill $lm(offcolor) \ 1241 -tag mask1 1242 $c create rectangle 0 0 0 0 -outline "" -fill $lm(offcolor) \ 1243 -tag mask2 1244 $c create rectangle 0 0 [expr $lm(width)-1] [expr $lm(height)-1] \ 1245 -outline $lm(bg) 1246 if {[string match horiz* $lm(orient)]} { 1247 $c coords mask1 [expr {$lm(level)*$lm(width)}] 0 \ 1248 $lm(width) $lm(height) 1249 $c coords mask2 [expr {$lm(level)*$lm(width)}] 0 \ 1250 $lm(width) $lm(height) 1251 for {set x 5} {$x < $lm(width)} {incr x 5} { 1252 $c create line $x 0 $x [expr $lm(width)-1] -fill black \ 1253 -width 2 1254 } 1255 } else { 1256 $c coords mask1 0 0 $lm(width) \ 1257 [expr {$lm(height)-$lm(level)*$lm(height)}] 1258 $c coords mask2 0 0 $lm(width) \ 1259 [expr {$lm(height)-$lm(level)*$lm(height)}] 1260 for {set y 5} {$y < $lm(height)} {incr y 5} { 1261 $c create line 0 [expr $lm(height)-$y] \ 1262 [expr $lm(width)-1] [expr $lm(height)-$y] \ 1263 -fill black -width 2 1264 } 1265 } 1266 } 1267 1268 proc levelMeterHandler {w cmd args} { 1269 upvar [namespace current]::${w}::levelmeter lm 1270 1271 if {[string match conf* $cmd]} { 1272 switch -- [lindex $args 0] { 1273 -level { 1274 set arg [lindex $args 1] 1275 if {$arg < 1} { set arg 1 } 1276 if {$lm(type)=="linear"} { 1277 set lm(level) [expr {$arg/32760.0}] 1278 } else { 1279 set lm(level) [expr {log($arg)/10.3972}] 1280 } 1281 if {[clock seconds] - $lm(maxtime) > 2} { 1282 set lm(maxtime) [clock seconds] 1283 set lm(maxlevel) 0.0 1284 } 1285 if {$lm(level) > $lm(maxlevel)} { 1286 set lm(maxlevel) $lm(level) 1287 } 1288 1289 if {[string match horiz* $lm(orient)]} { 1290 set l1 [expr {5*int($lm(level)*$lm(width)/5)}] 1291 set l2 [expr {5*int($lm(maxlevel)*$lm(width)/5)}] 1292 ${w}_levelMeter coords mask1 $l2 0 \ 1293 $lm(width) $lm(height) 1294 ${w}_levelMeter coords mask2 [expr {$l2-5}] 0 \ 1295 $l1 $lm(height) 1296 } else { 1297 set l1 [expr {5*int($lm(level)*$lm(height)/5)}] 1298 set l2 [expr {5*int($lm(maxlevel)*$lm(height)/5)}] 1299 ${w}_levelMeter coords mask1 0 0 $lm(width) \ 1300 [expr {$lm(height)-$l2}] 1301 ${w}_levelMeter coords mask2 0 [expr {$lm(height)-$l2+5}] \ 1302 $lm(width) [expr {$lm(height)-$l1}] 1303 } 1304 } 1305 -length { 1306 if {[string match horiz* $lm(orient)]} { 1307 set lm(width) [lindex $args 1] 1308 } else { 1309 set lm(height) [lindex $args 1] 1310 } 1311 drawLevelMeter $w 1312 } 1313 -width { 1314 if {[string match horiz* $lm(orient)]} { 1315 set lm(height) [lindex $args 1] 1316 } else { 1317 set lm(width) [lindex $args 1] 1318 } 1319 drawLevelMeter $w 1320 } 1321 default { 1322 error "unknown option \"[lindex $args 0]\"" 1323 } 1324 } 1325 } else { 1326 error "bad option \"$cmd\": must be configure" 1327 } 1328 } 1329 1330 # Create a canvas where the widget is to be rendered 1331 1332 canvas $w -highlightthickness 0 1333 1334 # Replave the canvas widget command 1335 1336 rename $w ${w}_levelMeter 1337 1338 # Draw level meter 1339 1340 drawLevelMeter $w 1341 1342 # Create level meter widget command 1343 1344 proc ::$w {cmd args} \ 1345 "return \[eval snack::levelMeterHandler $w \$cmd \$args\]" 1346 1347 return $w 1348 1349 } 1350} 1351