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 / pitch.tcl < prev    next >
Encoding:
Text File  |  2001-10-22  |  2.1 KB  |  86 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.  
  7. sound s
  8. sound t
  9.  
  10. pack [frame .b] -side bottom
  11. pack [button .b.r -bitmap snackRecord -command Start -fg red -width 40] \
  12.     -side left  
  13. pack [button .b.s -bitmap snackStop -command Stop -width 40] -side left
  14. pack [button .b.p -bitmap snackPlay -command {Stop;s play} -width 40] \
  15.     -side left
  16. pack [label .b.l -text "Draw speed:"] -side left
  17. tk_optionMenu .b.om pixpsec 25 50 100 200
  18. pack .b.om -side left
  19. pack [label .b.l2 -text "pixels per second"] -side left
  20. pack [frame .f] -side top -expand true -fill both
  21. pack [canvas .f.d -width 40 -bg white] -side left -fill y
  22. pack [canvas .f.c -bg white] -side left -expand true -fill both
  23. .f.c create text 150 100 -text "Pitch plot of microphone signal"
  24.  
  25. set pixpsec 25
  26. set samplePos 0
  27. #.c create spectrogram 0 0 -sound s -height 200 -pixelspersec $pixpsec
  28.  
  29. proc Stop {} {
  30.   s stop
  31.   after cancel Draw
  32. }
  33.  
  34. proc Start {} {
  35.   Stop
  36.   s record
  37.   set ::samplePos 0
  38.   set ::ox  0
  39.   set ::oy  0
  40.   .f.c delete all
  41.   .f.c create line 0 $::ty 1280 $::ty -tags target
  42.   after 200 Draw
  43. }
  44.  
  45. proc Draw {} {
  46.   set length [s length]  
  47.   while {$::samplePos < $length - 666-0*320} {
  48.     t copy s -start $::samplePos -end [expr {$::samplePos+665+0*320}]
  49.     set val [lindex [t pitch] 2]
  50.     set x [expr {$::ox + 0.01 * $::pixpsec}]
  51.     set y [expr {[winfo height .f.c]*((300-$val)/300.0)}]
  52.     if {$::oy == 0} { set ::oy $y }
  53.     if {$val > 0.0 && abs($::oy-$y) < 10} {
  54.       .f.c create oval [expr {$x-1}] [expr {$y-1}] [expr {$x+1}] [expr {$y+1}]
  55.     }
  56.     incr ::samplePos 160
  57.     set ::ox $x
  58.     set ::oy $y
  59.     if {$x > [winfo width .f.c]} Stop
  60.   }
  61.   after 50 Draw
  62. }
  63.  
  64. bind . <Configure> Configure
  65.  
  66. proc Configure {} {
  67.   .f.d delete all
  68.   snack::frequencyAxis .f.d 0 0 40 [winfo height .f.c] -topfr 300
  69. }
  70.  
  71. set ty 150
  72. .f.c create line 0 $::ty 1280 $::ty -tags target
  73. bind .f.c <1> [list initDrag %x %y]
  74. bind .f.c <B1-Motion> [list Drag %x %y]
  75.  
  76. proc initDrag {x y} {
  77.   set ::ty [.f.c canvasy $y]
  78.   .f.c coords target 0 $::ty 1280 $::ty
  79. }
  80.  
  81. proc Drag {x y} {
  82.   set y [.f.c canvasy $y]
  83.   .f.c coords target 0 $::ty 1280 $::ty
  84.   set ::ty $y
  85. }
  86.