Artifact Content
Not logged in

Artifact 5e178cdc6d4b25834775a0f57a0126db8ecffd92:


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