#!/usr/bin/wish
# (find-es "tcl" "snack")
# (find-es "tcl" "piano.tcl")
# Copied from a Tcler's Wiki page by Richard Suchenwirth, with no changes.
# "A toy piano": http://wiki.tcl.tk/3948
# (find-bgprocess "~/TCL/piano.tcl")

# Bug:
#   Could not gain access to /dev/sound/dsp for writing.
#   Could not gain access to /dev/sound/dsp for writing.
#       while executing
#   "$::snd play -filter $::filter"
#       invoked from within
#   "if $freq {
#          $c move $id 1 1
#          $::filter configure $freq
#          $::snd play -filter $::filter
#          $::filter2 configure [expr {$freq/2.}] ..."
#       (procedure "play" line 2)
#       invoked from within
#   "play .c 22 440.0"
#       (command bound to event)

package require Tk     ;# to make Starkit'ting this easier
package require sound  ;# we don't yet use the Tk goodies of snack
set snd  [snack::sound -rate 22050]
set snd2 [snack::sound -rate 22050] ;# second sound to add volume
set filter  [snack::filter generator 1000 30000 0.7 sine]
set filter2 [snack::filter generator 1000 30000 0.0 sine]

# compute sound frequencies, given a' = 440 Hz
set a 440
# Logarithm to base 2 allows us to proceed linearly in 1/12 steps
set lda [expr {log($a)/log(2)}]

# But this list starts from c'', so we have to add 3/12
set names {c c# d d# e f f# g g# a bb b}
set freqs {}
for {set i 0} {$i<12} {incr i} {
   lappend freqs [expr {pow(2, $lda + (3+$i)/12.)}]
}
proc play {c id freq} {
   if $freq {
       $c move $id 1 1
       $::filter configure $freq
       $::snd play -filter $::filter
       $::filter2 configure [expr {$freq/2.}] ;# one octave lower
       $::snd2 play -filter $::filter2
   } else {
       $c move $id -1 -1
       after  20 $::snd stop
       after 120 $::snd2 stop
   }
}
proc nameof {name factor} {
   if {$factor==0.25} {set name [string toupper $name]}
   while {$factor>=1} {
       append name '
       set factor [expr {$factor/2.}]
   }
   set name
}
set x0 5; set y0 5      ;# top left corner to start
set y1 100              ;# length of white keys
set y05 [expr $y1*.67]  ;# length of black keys
set dx 18               ;# width of white keys
set dx2 [expr {$dx/2}]  ;# offset of black keys
set c [canvas .c -bg brown -height [expr $y1+5] -width [expr $dx*31]]
$c config -cursor hand2 ;# so we see the single finger that plays
pack $c
wm resizable . 0 0      ;# keep the window fixed-size
foreach factor {0.25 0.5 1 2 4} {
   foreach name $names freq $freqs {
       set f [expr {$freq * $factor}]
       if {[string length $name] == 1} {
           set id [$c create rect $x0 $y0 [expr {$x0+$dx}] $y1 -fill white]
           incr x0 $dx; incr x0 1
       } else {
           set x [expr {$x0 - $dx*.35}]
           set id [$c create rect $x $y0 [expr {$x + $dx*0.65}] $y05 \
               -fill black -tag black]
       }
       $c bind $id <1>               "play $c $id $f" ;# sound on
       $c bind $id <ButtonRelease-1> "play $c $id 0"  ;# sound off
       $c bind $id <Enter> \
         [list wm title . "piano: [nameof $name $factor] [format %.1f $f]"]
       if {$factor == 4 && $name == "c"} break ;# extra c key at right
   }
}
$c raise black ;# otherwise half-hidden by next white key