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