# based on http://wiki.tcl.tk/3977
namespace eval music {
variable version 0.1 ;# well yes, with some iterations ;-)
variable A 440 ;# standard pitch
variable basicNames {c c# d d# e f f# g g# a bb b}
variable bpm 72
variable freqMap ;# array (notename) -> frequency
variable showNotes 0 ;# default for Tcl
variable last 0
}
proc music::getDuration {note} {
variable bpm
set res [expr {60000/$bpm}]
while {[regexp {(.+)[+]$} $note -> note]} {
set res [expr {$res*2}]
}
while {[regexp {(.+)[-]$} $note -> note]} {
set res [expr {$res/2}]
}
if {[regexp {(.+)[.]$} $note -> note]} {
set res [expr {round($res*1.5)}]
}
set res
}
proc music::getFrequency {note} {
variable freqMap
set pureName [string trimright $note {+-.}]
if {[info exists freqMap($pureName)]} {
return $freqMap($pureName)
}
return ""
}
proc music::_makeFreqMap {} {
variable A
variable basicNames
variable freqMap
set lda [expr {log($A)/log(2)}]
set i 3 ;# C is 3 half-tones above A
set freqMap(x) 0 ;# pause
foreach name $basicNames {
set f [expr {pow(2, $lda + $i/12.)}]
set freqMap($name) $f
set freqMap($name') [expr {$f*2}]
set freqMap($name'') [expr {$f*4}]
set uname [string toupper $name]
set freqMap($uname) [expr {$f/2.}]
set freqMap(${uname}1) [expr {$f/4.}]
set freqMap(${uname}2) [expr {$f/8.}]
incr i
}
}
music::_makeFreqMap ;# proc'ed only to hide local variables
proc music::freqToNote {freq} {
# Converts the given frequency to a midi note
# Midi notes range from 0 to 127 with the lowest note
# at a frequency of 8.175 Hz and the highest note at 12557 Hz
# Each octave consists of 12 notes and from one octave to the
# next, the frequency doubles
if {$freq == 0} {return 0}
return [expr round((log($freq/8.175)/log(2)) * 12)]
}
proc music::play {score {Tk 0}} {
set t 0
foreach item $score {
switch -- $item {
/ {}
< {}
> {}
default {
set dt [getDuration $item]
after $t music::playNote $item $dt $Tk
incr t $dt
}
}
}
}
proc music::playNote {note {duration ""} {Tk 0}} {
variable current $note
variable showNotes
set f [getFrequency $note]
if {$f==""} {
if {$Tk} {
set ::music::info "unknown note $note"
return
} else {
error "unknown note $note"
}
}
if {$duration==""} {set duration [getDuration $note]}
if {$duration} {set ::music::last [playBegin $f]}
if {$duration>=0} {
set cmd "music::playEnd $::music::last"
if {$Tk} {
keyboardHilite $note 1
append cmd "; music::keyboardHilite $note 0"
}
after [expr {$duration/2}] $cmd
}
if {$showNotes && $duration >= 0} {drawNote $note}
}
proc music::playBegin {freq} {
if {$freq == 0} {return 0}
set note [freqToNote $freq]
catch {muzic::playnote 0 $note 60 -1}
return $note
}
proc music::playEnd {{varName ""}} {
if {$varName==""} {set varName $::music::last}
if {$varName} {catch {muzic::playnote 0 $varName 0 0}}
}
#-----------------------------------------------Tk stuff: piano keyboard
proc music::drawKeyboard {c x0 y0 dx dy nkeys} {
variable current
variable kbdCanvas $c
set y1 [expr {$y0+$dy}]
set y05 [expr $y1*.67] ;# length of black keys
set dx2 [expr {$dx/2}] ;# offset of black keys
set nkey 0
foreach note [noteSequence] {
if {[incr nkey]>$nkeys} break
set keycolor [keyColor $note]
if {$keycolor=="black"} {
set x [expr {$x0 - $dx*.35}]
set id [$c create rect $x $y0 [expr {$x+$dx*0.6}] $y05 \
-fill $keycolor -tag [list $note black]]
} else {
set id [$c create rect $x0 $y0 [expr $x0+$dx] $y1 \
-fill $keycolor -tag $note]
incr x0 $dx; incr x0 1
}
$c bind $id <1> "music::TkOn $c $id $note" ;# sound on
$c bind $id <ButtonRelease-1> "music::TkOff $c $id $note";# sound off
$c bind $id <3> \
"set music::current {$note: [format %.1f [getFrequency $note]] Hz}"
$c bind $id <Enter> "set music::current $note"
$c bind $id <Leave> "set music::current {}"
}
$c raise black
set maxx [lindex [$c bbox all] 2]
if {[$c cget -width]<$maxx} {$c config -width [expr {$maxx}]}
set maxy [lindex [$c bbox all] 3]
if {[$c cget -height]<$maxy} {$c config -height [expr {$maxy}]}
}
proc music::TkOn {canvas id note} {
variable startTime [clock clicks -millisec]
playNote $note -1
$canvas move $id -1 -3 ;# animate the key to look depressed
}
proc music::TkOff {canvas id note} {
variable record; variable recorded
variable startTime
set dt [expr {[clock clicks -millisec] - $startTime}]
if {$dt<130} {
append note -
} elseif {$dt>600} {
append note ++
} elseif {$dt>300} {
append note +
}
playNote $note 0
if {$record} {lappend recorded $note}
$canvas move $id 1 3
}
proc music::keyboardHilite {note mode} {
variable kbdCanvas
set note [string trimright $note {+-.}]
set id [$kbdCanvas find withtag $note]
set fill [expr {$mode? "green": [keyColor $note]}]
$kbdCanvas itemconfig $id -fill $fill
}
proc music::keyColor {note} {
expr {[regexp -nocase "#|bb" $note]? "black" : "white"}
}
proc music::noteSequence {} {
variable basicNames
set ubasic [string toupper $basicNames]
foreach i $ubasic {lappend noteSequence ${i}2}
foreach i $ubasic {lappend noteSequence ${i}1}
foreach i $ubasic {lappend noteSequence ${i}}
foreach i $basicNames {lappend noteSequence $i}
foreach i $basicNames {lappend noteSequence $i'}
foreach i $basicNames {lappend noteSequence $i''}
set noteSequence ;# for conveniently creating the keyboard
}
#------------------------------------------- Tk stuff: Note rendering
proc music::drawLines {canvas x0 y0 x1 dy} {
variable noteMap
variable scoreCanvas $canvas
variable showNotes 1
set noteMap(topY) $y0
foreach i {1 2 3 4 5} {
$canvas create line $x0 $y0 $x1 $y0
incr y0 $dy
}
set noteMap(btmY) [expr {$y0-$dy}]
# position where new notes are inserted
set noteMap(newX) [expr {$x1 - 200}]
array set noteMap [makeNoteTable [expr $y0-$dy/2] [expr {$dy/2}]]
}
proc music::drawNote {name} {
variable noteMap
variable scoreCanvas
set c $scoreCanvas
regexp {([A-Ga-gx])([Bb#])?[12']*([-+.]*)} $name -> note sign length
if {$note=="x"} return ;# pause signs will come later
$c move note -30 0
set y $noteMap($note)
if {[string first 1 $name]>0} {incr y 42} ;# low note
if {[string first 2 $name]>0} {incr y 84} ;# very low note
while {[regexp (.+)' $name -> name]} {incr y -42} ;# high note
set newX $noteMap(newX)
set sx [expr {$newX+4}]
switch -- $sign {
# {$c create text $sx $y -text # -tag note;$c move note -14 0}
B - b {$c create text $sx $y -text b -tag note;$c move note -14 0}
}
set y2 [expr {(($y+6)/12)*12+5}]
set ax0 [expr {$newX-4}] ;#--------- auxiliary lines, above or below
set ax1 [expr {$newX+22}]
while {$y2 < $noteMap(topY)-1} {
if {$y<$y2} {$c create line $ax0 $y2 $ax1 $y2 -tag note}
incr y2 12
}
while {$y2 > $noteMap(btmY)} {
$c create line $ax0 $y2 $ax1 $y2 -tag note
incr y2 -12
}
set newX1 [expr {$newX+14}]
set fill black
if {[string first + $length]>=0} {set fill {}}
$c create oval $newX $y $newX1 [expr {$y+10}] -tag note \
-fill $fill
if {[string first . $length]>=0} {
$c create text $newX1 $y -anchor w -text " ," -tag note
}
if {[string first ++ $length]<0} {
set y0 [expr {$y>102? $y-40: $y+50}]
set x0 [expr {$y>102? $newX1: $newX}]
$c create line $x0 $y0 $x0 [incr y 6] -tag note
if {[string first - $length]>=0} {
set y1 [expr {($y0+$y)/2}]
$c create line $x0 $y0 [expr {$x0+10}] $y1 \
-width 1 -tag note
}
}
}
proc music::makeNoteTable {y0 dy} {
set basics {C D E F G A B}
foreach i "$basics [string tolower $basics]" {
lappend noteTable $i $y0
incr y0 -$dy
}
set noteTable
}
#-------------------------------------------- End of package contents
package provide music $music::version
#----------------------------------------------- Tk and pure-Tcl demos
proc music::makeGUI {top} {
wm title $top "Tclmusic $music::version demo"
if {$top eq "."} {
set w ""
} else {
set w $top
}
set android 0
catch {set android [sdltk android]}
if {$android} {
bind $top <Configure> {}
}
canvas $w.s -bg white -height 250
if {$android} {
set width [winfo screenwidth .]
music::drawLines $w.s 0 90 $width 12
} else {
music::drawLines $w.s 0 90 1200 12
}
frame $w.f
button $w.f.play -text Play -command {music::play $::music::tune 1}
button $w.f.x -text X -command {set ::music::tune ""}
checkbutton $w.f.record -text Record -variable music::record
checkbutton $w.f.notes -text Notes -variable music::showNotes
eval pack [winfo children $w.f] -side left -pady 0 -fill y
entry $w.e -textvar ::music::tune
bind $w.e <Return> {.f.play invoke}
bind $w.e <3> {catch {music::play [%W selection get] 1}}
trace variable ::music::recorded w {set ::music::tune $::music::recorded ;#}
canvas $w.c -height 10 ;# dummy small to make it shrinkwrapped
if {$android} {
set width [winfo screenwidth .]
incr width -40
set width [expr round($width / 36.0)]
set height [expr round($width * 6.25)]
music::drawKeyboard $w.c 10 5 $width $height 61
} else {
music::drawKeyboard $w.c 5 5 32 200 61
}
label $w.info -textvar ::music::info -width 80 -anchor w -relief sunken \
-borderwidth 1
set ::music::info "Welcome to TclMusic - enjoy the power of Tcl/Tk!"
trace variable ::music::current w {set ::music::info $::music::current ;#}
eval pack [winfo children $top] -fill x
if {$android} {
pack configure $w.c -side bottom
pack configure $w.info -side bottom -before .c -padx 10 -pady 5
eval pack configure [winfo children $w.f] -pady 10 -padx 10
pack configure $w.e -padx 10
bind $top <Key-Break> exit
} else {
wm resizable $top 0 0
bind $top <Escape> exit
bind $top ? {console show}
}
}
if {[file tail [info script]]==[file tail $argv0]} {
set ::music::tune {
e. d c c. A- A. G+ c e d+ e. d c c. A- A. G c B d c+ x
g. a g g. e- g. g+ a g d+ e. d c c. A- A. G c B d c++
}
catch {muzic::init}
if {[package provide Tk]!=""} {
option add *Button.padY 0
set android 0
catch {set android [sdltk android]}
if {$android} {
wm attributes . -fullscreen 1
borg screenorientation landscape
sdltk touchtranslate 0
# gross hack for potential orientation change
# otherwise screen width/height can be wrong
# for geometry computation
bind . <Configure> {
bind . <Configure> {}
after 500 {music::makeGUI .}
}
} else {
music::makeGUI .
}
} else {
puts "Pure-Tcl music package demo - will last 50 seconds"
after 50000 set awhile 1
trace variable music::current w {
puts -nonewline stderr "$::music::current " ;#}
music::play $::music::tune
vwait awhile
}
}