# 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 "music::TkOff $c $id $note";# sound off $c bind $id <3> \ "set music::current {$note: [format %.1f [getFrequency $note]] Hz}" $c bind $id "set music::current $note" $c bind $id "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 {} } 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 {.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 exit } else { wm resizable $top 0 0 bind $top 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 . { bind . {} 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 } }