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 crudely done in the below
code. 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.

[http://mini.net/files/tclmusic.jpg]

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 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 [after]s 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 variables

if 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 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
        }
 }

----
[Category Package] | [Category Multimedia] | [Arts and crafts of Tcl-Tk programming] | [Category Toys] | [Category Sound]