#!/bin/sh
# The next line restarts with tclsh.\
exec tclsh "$0" ${1+"$@"}

set interp [interp create -safe]

$interp eval {
    set notes {}
    set notevars {
        time
        duration
        pitch
        pan
        phase
        volume
        voice
        tag
    }
    set stack {}
    set stackvars {
        beat
        pan
        phase
        tempo
        time
        transpose
        voice
        volume
        tag
    }

    proc push {} {
        foreach var $::stackvars {
            lappend frame [set ::$var]
        }
        lappend ::stack $frame
    }

    proc pop {} {
        set ::stack [lassign $::stack frame]
        foreach var $::stackvars val $frame {
            set ::$var $val
        }
    }

    proc group {script} {
        push
        uplevel 1 $script
        pop
    }

    proc note {duration pitch args} {
        foreach var $::stackvars {
            set $var [set ::$var]
        }
        foreach {key val} $args {
            if {[string index $key 0] ne "-"} {
                error "bad option \"$key\""
            }
            set key [string range $key 1 end]
            if {$key ni $::stackvars || $key eq "time"} {
                error "bad option \"-$key\""
            }
            set $key $val
        }
        set pitch [expr {220 * 2 ** (($pitch + $transpose) / 12.0)}]
        set duration [expr {[expr $duration] * 60 / $tempo / [expr $beat]}]
        foreach var $::notevars {
            lappend note [set $var]
        }
        lappend ::notes $note
        set ::time [expr {$time + $duration}]
        incr ::tag
    }

    proc rest {duration args} {
        foreach var {time tempo beat} {
            set $var [set ::$var]
        }
        foreach {key val} $args {
            if {[string index $key 0] ne "-"} {
                error "bad option \"$key\""
            }
            set key [string range $key 1 end]
            if {$key ni {tempo beat}} {
                error "bad option \"-$key\""
            }
            set $key $val
        }
        set duration [expr $duration]
        set ::time [expr {$time + $duration * 60 / $tempo / [expr $beat]}]
    }
}

$interp eval {
    set volume 0.5
    set pan 0.5
    set phase 0
    set tempo 75
    set beat 1/4.
    set transpose 0
    set voice square
    set time 0
    set tag 0

    proc treble {} {
        group {
            note 1/16. -2; note 1/16.  1; note 1/16.  5; note 1/16.  6
            note 1/16. -2; note 1/16.  1; note 1/16.  5; note 1/16.  6
            note 1/16. -2; note 1/16.  1; note 1/16.  5; note 1/16.  6
            note 1/16. -2; note 1/16.  1; note 1/16.  5; note 1/16.  6

            note 1/16. -3; note 1/16.  0; note 1/16.  5; note 1/16.  6
            note 1/16. -3; note 1/16.  0; note 1/16.  5; note 1/16.  6
            note 1/16. -3; note 1/16.  0; note 1/16.  5; note 1/16.  6
            note 1/16. -3; note 1/16.  0; note 1/16.  5; note 1/16.  6

            note 1/16. -4; note 1/16. -1; note 1/16.  5; note 1/16.  6
            note 1/16. -4; note 1/16. -1; note 1/16.  5; note 1/16.  6
            note 1/16. -4; note 1/16. -1; note 1/16.  5; note 1/16.  6
            note 1/16. -4; note 1/16. -1; note 1/16.  5; note 1/16.  6

            note 1/16. -5; note 1/16. -2; note 1/16.  5; note 1/16.  6
            note 1/16. -5; note 1/16. -2; note 1/16.  5; note 1/16.  6
            note 1/16. -5; note 1/16. -2; note 1/16.  5; note 1/16.  7
            note 1/16. -5; note 1/16. -2; note 1/16.  5; note 1/16.  7

            note 1/16. -6; note 1/16. -2; note 1/16.  3; note 1/16.  5
            note 1/16. -6; note 1/16. -2; note 1/16.  3; note 1/16.  5
            note 1/16. -6; note 1/16. -2; note 1/16.  3; note 1/16.  5
            note 1/16. -6; note 1/16. -2; note 1/16.  3; note 1/16.  5

            note 1/16. -7; note 1/16. -2; note 1/16.  3; note 1/16.  5
            note 1/16. -7; note 1/16. -2; note 1/16.  3; note 1/16.  5
            note 1/16. -7; note 1/16. -2; note 1/16.  3; note 1/16.  5
            note 1/16. -7; note 1/16. -2; note 1/16.  3; note 1/16.  5

            note 1/16. -9; note 1/16. -3; note 1/16.  0; note 1/16.  3
            note 1/16. -3; note 1/16.  0; note 1/16.  3; note 1/16.  6
            note 1/16.  0; note 1/16.  3; note 1/16.  6; note 1/16.  3
            note 1/16.  6; note 1/16.  9; note 1/16.  6; note 1/16.  9
            note 1/16. 12; note 1/16.  9; note 1/16. 12; note 1/16. 15
        }
    }

    proc base {} {
        group {
            note 1/4.  -14
            rest 1/4. 
            note 1/4.  -11
            note 1/4.   -7

            note 1/4.   -8
            note 1/4.  -15
            rest 1/2. 
            note 1/4.  -16
            rest 1/4.
            note 1/8.  -16
            rest 1/16.
            note 1/16. -13
            rest 1/8.

            note 1/8.   -8
            note 1/4.   -9
            note 1/4.  -16
            rest 1/2.

            note 1/16. -17
            note 1/16. -18
            note 1/4.  -17
            rest 1/8.

            note 1/8.  -14
            rest 1/16.
            note 1/16.  -6
            rest 1/8.

            note 1/8.   -7
            note 1/16. -18
            note 1/16. -19
            note 1/4.  -18
            rest 1/8.

            note 1/8.  -14
            rest 1/16.
            note 1/16.  -7
            rest 1/8.
            note 1/8.   -8

            note 1/16. -18; note 1/16. -15; note 1/16. -12; note 1/16. -15
            note 1/16. -12; note 1/16.  -9; note 1/16. -12; note 1/16.  -9
            note 1/16.  -6; note 1/16. -10; note 1/16.  -6; note 1/16.  -3
            note 1/16.   0; note 1/16.  -3; note 1/16.  -6; note 1/16. -10
            note 1/16.  -6; note 1/16. -10; note 1/16. -12; note 1/16. -15
        }
    }

    for {set i 0} {$i <= 1} {set i [expr {$i + 0.2}]} {
        set phase $i
        set pan $i

        set transpose [expr {$i - 0.5 + 12}]
        set volume 0.125
        set voice triangle
        treble

        set transpose [expr {$i - 0.5}]
        set volume 0.075
        set voice saw
        base
    }
}

$interp eval {
    set notes [lsort -real -index 0 $notes]
}

proc render {filename notes rate} {
    set chan [open output.au wb]
    fconfigure $chan -encoding binary

    puts -nonewline $chan [binary format I6 [list\
            0x2e736e64 24 0xffffffff 3 [expr {int($rate)}] 2]]

    for {set index 0} {$index < [llength $notes]} {incr index} {
        lset notes $index 0 [expr {entier([lindex $notes $index 0] * $rate)}]
        lset notes $index 1 [expr {entier([lindex $notes $index 1] * $rate)}]
    }

    set bufsize 16384
    set buffer ""
    set active {}
    set now 0
    set lmin 0
    set lmax 0
    set rmin 0
    set rmax 0
    set maxpoly 0
    while {[llength $notes] != 0 || [llength $active] != 0} {
        while {[llength $notes] != 0 && [lindex $notes 0 0] <= $now} {
            puts -nonewline [format "\rNotes:%6d; min:%8.4f/%8.4f; max:%8.4f/%8.4f; poly:%3d"\
                    [llength $notes] $lmin $rmin $lmax $rmax $maxpoly]
            flush stdout
            lappend active [lindex $notes 0]
            set notes [lrange $notes 1 end]
        }

        set left 0.0
        set right 0.0
        set index 0
        set poly 0
        foreach note $active {
            lassign $note time duration freq pan phase volume voice

            if {$time + $duration <= $now} {
                set active [lreplace $active $index $index]
                continue
            }

            set period [expr {$rate / $freq}]

            switch -- $voice {
            sine {
                set sample [expr {$volume * sin(($now / $period + $phase) * 2 * acos(-1))}]
            } saw {
                set sample [expr {
                    $volume * (fmod($now / $period + $phase, 1) * 2 - 1)
                }]
            } square {
                if {fmod($now + $phase * $period, $period) > $period / 2} {
                    set sample $volume
                } else {
                    set sample [expr {-$volume}]
                }
            } triangle {
                if {fmod($now + $phase * $period, $period) > $period / 2} {
                    set sample [expr {$volume * (fmod(-2 * ($now / $period + $phase), 1) * 2 + 1)}]
                } else {
                    set sample [expr {$volume * (fmod(2 * ($now / $period + $phase) - 1, 1) * 2 - 1)}]
                }
            }}

            set left  [expr {$left + $sample * sqrt(1 - $pan)}]
            set right [expr {$right + $sample * sqrt($pan)}]

            if {$left < $lmin} {
                set lmin $left
            } elseif {$left > $lmax} {
                set lmax $left
            }

            if {$right < $rmin} {
                set rmin $right
            } elseif {$right > $rmax} {
                set rmax $right
            }

            incr poly
            if {$poly > $maxpoly} {
                set maxpoly $poly
            }

            incr index
        }
        append buffer [binary format S2 [list\
                [expr {int($left  * 32767)}] [expr {int($right * 32767)}]]]
        if {[string length $buffer] >= $bufsize} {
            puts -nonewline $chan $buffer
            set buffer ""
        }

        incr now
    }

    puts -nonewline $chan $buffer

    puts ""
    close $chan
}

render output.au [$interp eval {set notes}] 44100

# vim: set ts=4 sts=4 sw=4 tw=80 et ft=tcl: