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
- "x" for pauses
- ">", "<" for piano/forte (low or high amplitude) changes
- "/" signs (bars) have no effect, except of aiding the reader
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 generatorBrian 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 variable music::recorded w {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 variable music::current w {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 variable music::current w {
puts -nonewline stderr "$::music::current " ;#}
music::play $tune
vwait awhile
}
}Kroc - ready to use starkit available at http://www.zolli.fr/fichiers/TclMusic.zip
[ Category Package | Arts and crafts of Tcl-Tk programming | Category Toys | Category Sound | Category Music ]
