TclMusic
if 0 {Richard Suchenwirth 2002-09-01 - Everything is a string - so why not music? Last summer I demonstrated how a simple, ASCII-based (string) input language can be interpreted and rendered as notes on a canvas. But music is most of all auditory - one wants to hear it too. As every note allows calculation of its pitch (frequency) and length in time units, it is comparably easy to convert a note-string to instructions for sound output, e.g. with Snack. One can also directly link mouseclicks to sound output, as in A toy piano - if playing with one stiff finger is enough for you... What was missing still, was the ability to "quantize" the piano keyclicks, to determine their length in terms of eighth/quarter/half/full bar note, which is done in the code below. Then one has the possibility of clicking a melody together, recording the quantized notes, editing the resulting string, and replay it, save it as "sheet music", whatever - round-trip conversion from sounds to strings and back.
Piecewise refinements on a toy piano (see Playing with sound effects) led to many new features, but also to untidy code. Thus it was time for a redesign under the name of TclMusic, which started with the following sketchy spec of the music package:}
if 0 {
music::drawKeyboard <canvas> <keywidth> <keyheight> <nkeys>
music::drawNoteLines <canvas> <x0> <y0> <dy> <width>
music::drawNote <canvas> <note>
music::getFrequency <note>
music::play <string> ;# (a list of notes and other markup)
music::playNote <note> <ms>
}if 0 {If ms is -1, the note starts playing (e.g. after pressing a key). The sound is turned off again by calling with ms = 0. "Note" above refers to a string consisting of maximally four parts:
- base note: [A-Ga-g], cover two octaves; x for pause
- optional sign: [#bB]: b only after b, B only after B
- optional octave marker: 1,2 go down, one to three 's go up
- optional length marker: + double, - half, .: 1.5 times
"Scores" or "tunes" are lists of such notes, plus
- "x" for pauses
- ">", "<" for piano/forte (low or high amplitude) changes
- "/" signs (bars) have no effect, except of aiding the reader
Test the UI demo, which comes up if this file is toplevel script, with the sample tune in the entry widget, and try to guess which popular song I meant ;-) Portions of the tune can also be played by selecting them, and right-clicking. Activating "Record" will copy the names of played notes into the entry for editing (lengths must be fixed manually) and replay. As additional educational goodie, the currently replayed note is highlighted in green on the keyboard. Right-clicking on a piano key displays its frequency in the bottom info label, in addition to the note name that is always shown.
The canvas note display still leaves wishes open. #/b signs are just drawn as text, the little "factor 1.5" dots as commas (periods were too small). Very high or low notes just wander out of the picture.. This was just yet another weekend project, but I hope that some of you can enjoy it, and improve on it. Care was taken to isolate Tcl-based music processing from Tk widgetry, so the demo at end runs also in a tclsh - it plays the tune and displays the current note on stderr.
A final "note": I don't know if it's Snack or the many afters that I'm planting, but this plaything did not so rarely hang or crash on my W95 box, when keyboard or mouse events occur while sounds are playing. Looks like this is sort of a stress test. Be warned, and ready to kill the thing in order to stop runaway sounds. }
package require sound ;# snack without Tk
namespace eval music {
variable version 0.1 ;# well yes, with some iterations ;-)
variable A 440 ;# standard pitch
variable amplitude 20000
variable basicNames {c c# d d# e f f# g g# a bb b}
variable bpm 72
variable dampInterval 100 ;# ms for damping steps
variable dampConstant 0.3
variable freqMap ;# array (notename) -> frequency
variable showNotes 0 ;# default for Tcl
variable snackRate 22050 ;# sampling of sound objects
variable snackShape 0.5
variable snackType sine ;# could also be rectangle or triangle
}#--------------------------------------------------- Sound rendering
proc music::play {score {Tk 0}} {
variable amplitude
set t 0
foreach item $score {
switch -- $item {
/ {# bar ignored}
< {after $t set music::amplitude [expr {$music::amplitude*2}]}
> {after $t set music::amplitude [expr {$music::amplitude/2.}]}
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==""} {error "unknown note $note"}
if {$duration==""} {set duration [getDuration $note]}
if {$duration} {set ::last [playBegin $f]}
if {$duration>=0} {
set cmd "music::playEnd $::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} {
variable amplitude; variable snackShape; variable snackType
variable snackRate
set shape [expr {$freq<700? 0.95: $snackShape}]
set soundname [snack::sound -rate $snackRate]
variable $soundname; upvar 0 $soundname sound
set filter [snack::filter generator $freq $amplitude\
$shape $snackType]
if {$freq} {$soundname play -filter $filter}
set sound [list $filter $freq $amplitude]
set soundname
}
proc music::playEnd {{varName ""}} {
variable dampConstant
variable dampInterval
if {$varName==""} {set varName $::last}
variable $varName; upvar 0 $varName sound
foreach {filter freq ampl} $sound break
set a $ampl
set dt $dampInterval
set t 0 ;# abstract integer units
if {$dampConstant <= 0} {set dampConstant 0.1} ;# avoid lock/crash
while {$a > 50} {
set a [expr {$ampl * exp(-$dampConstant * $t)}]
after [expr {$t*$dt}] [list $filter configure $freq $a]
incr t 1
}
after [expr {$t*$dt}] "
$varName stop
$filter destroy
$varName destroy
unset music::$varName"
}
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)]} {
set freqMap($pureName)
} ;# otherwise implicitly returns an empty string
}
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 variablesif 0 { #--------------------------Alternate midi-based music generator
Brian Theado 14Aug04 - Here is an alternate music generator that makes use of the tclmidi package (see midi) which works in Windows. On my computer, the midi synthesizer in the sound card sounds excellent (to my untrained ear). The default instrument is a piano.
}
if {![catch {
package require midi
midi::openout 0
}]} {
proc 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
return [expr round((log($freq/8.175)/log(2)) * 12)]
}
proc music::playBegin {freq} {
set note [freqToNote $freq]
# Channel 1 note on at volume 60
midi::sendshort 144 $note 60
return $note
}
proc music::playEnd {{varName ""}} {
if {$varName==""} {set varName $::last}
# Channel 1 note off and release the note relatively slowly (the
# 5 could be as high as 127 for a quick release of the sound)
midi::sendshort 128 $varName 5
}
}#-----------------------------------------------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]
$canvas move $id -1 -1 ;# animate the key to look depressed
playNote $note -1
}
proc music::TkOff {canvas id note} {
variable record; variable recorded
variable startTime
$canvas move $id 1 1
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}
}
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}]
set noteMap(newX) 600 ;# position where new notes are inserted
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
foreach i {1 2} { ;# This is slightly wasteful, but makes the
$c move note -9 0 ;# movement of notes better visible.
update idletasks ;# Move once by 16 if this causes problems.
}
set y $noteMap($note)
if {[string first 1 $name]>0} {incr y 21} ;# low note
if {[string first 2 $name]>0} {incr y 42} ;# very low note
while {[regexp (.+)' $name -> name]} {incr y -21} ;# high note
set newX $noteMap(newX)
set sx [expr {$newX+2}]
switch -- $sign {
# {$c create text $sx $y -text # -tag note;$c move note -8 0}
B - b {$c create text $sx $y -text b -tag note;$c move note -8 0}
}
set y2 [expr {(($y+3)/6)*6+1}]
set ax0 [expr {$newX-2}] ;#--------- auxiliary lines, above or below
set ax1 [expr {$newX+11}]
while {$y2 < $noteMap(topY)-1} {
if {$y<$y2} {$c create line $ax0 $y2 $ax1 $y2 -tag note}
incr y2 6
}
while {$y2 > $noteMap(btmY)} {
$c create line $ax0 $y2 $ax1 $y2 -tag note
incr y2 -6
}
set newX1 [expr {$newX+8}]
set fill black
if {[string first + $length]>=0} {set fill {}}
$c create oval $newX $y $newX1 [expr {$y+5}] -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>30? $y-20: $y+25}]
set x0 [expr {$y>30? $newX1: $newX}]
$c create line $x0 $y0 $x0 [incr y 3] -tag note
if {[string first - $length]>=0} {
set y1 [expr {($y0+$y)/2}]
$c create line $x0 $y0 [expr {$x0+5}] $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
if {[file tail [info script]]==[file tail $argv0]} {
set 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++
}
if {[package provide Tk]!=""} {
option add *Button.padY 0
wm title . "Tclmusic $music::version demo"
canvas .s -bg white -height 80
music::drawLines .s 0 20 1000 6
frame .f
button .f.play -text Play -command {music::play $tune 1}
button .f.x -text X -command {set tune ""}
checkbutton .f.record -text Record -variable music::record
checkbutton .f.notes -text Notes -variable music::showNotes
eval pack [winfo children .f] -side left -pady 0 -fill y
entry .e -textvar tune
bind .e <Return> {.f.play invoke}
bind .e <3> {catch {music::play [selection get] 1}}
trace add variable music::recorded write {set ::tune $::music::recorded ;#}
canvas .c -height 10 ;# dummy small to make it shrinkwrapped
music::drawKeyboard .c 5 5 16 100 61
label .info -textvar info -width 80 -anchor w -relief sunken \
-borderwidth 1
set info "Welcome to TclMusic - enjoy the power of Tcl/Tk/Snack!"
trace add variable music::current write {set ::info $::music::current ;#}
eval pack [winfo children .] -fill x
wm resizable . 0 0
bind . <Escape> {exec wish $argv0 &; exit}
bind . ? {console show}
} else {
puts "Pure-Tcl music package demo - will last 50 seconds"
after 50000 set awhile 1
trace add variable music::current write {
puts -nonewline stderr "$::music::current " ;#}
music::play $tune
vwait awhile
}
}Kroc - ready to use starkit available at http://web.archive.org/web/https://www.zolli.fr/fichiers/TclMusic.zip
[ Category Package | Arts and crafts of Tcl-Tk programming | Category Toys | Category Sound | Category Music ]