if 0 {

See also [video babbleback machine].

[Brian Theado] - 21Oct03
I have been reading Win Wenger's fascinating ''Einstein Factor'' [http://www.amazon.com/exec/obidos/tg/detail/-/076150186X/qid=1066784962].  This book is full of fascinating creativity and problem solving techniques.  The author's website (http://winwenger.com) contains dozens and dozens of articles about topics similar that found in the ''Einstein Factor'' (http://winwenger.com/winsight.htm is a good starting point).  One article [http://www.winwenger.com/part27.htm] gives details for a Babble-Back Machine in which two reel-to-reel tape recorders are rigged together to record and then play back the same sound with a few seconds delay.  Read http://www.winwenger.com/feed1.htm for more details on learning from feedback from your own output.

I decided the power of the [snack] sound extension would make implementing a similar device in Tcl easy.  Below is the resulting code.  It plays back all sound received on a computer's microphone with a 2 second delay.  The delay can be changed to 1 second (for example) by hitting F2 to bring up the console and typing 'set delay 1000'.  The units for the delay variable is in microseconds.

I introduced this program to my 2 year old daughter and she is utterly thrilled with it.  She laughed, squealed, talked and babbled for over an hour and a half and still wanted more.

I have packaged this code along with snack together into a Windows starpack at http://tkoutline.sourceforge.net/babbleback.exe.

[Brian Theado] - Update 23Oct03 - I ran this on a computer that has a very small amount of RAM (32MB) and found out that there are memory leaks.  After about 15 minutes it would crash due to exhausted memory.  This may be a bug in [snack]?  I found that if I destroy the sound in the next event loop (using the "after 0" below) instead of in the play completion callback, then the memory doesn't leak.

Also on this older computer, I've found that the echo effect (from the microphone picking up sound from the speaker) is more annoying as is the static sound and I've found it harder to get the output volume adjusted so you can still hear it, but it doesn't enter a feedback loop.
}

[Brian Theado] - Update 08Nov03 - Creating and destroying new sound objects each cycle seems to be causing an occasional crash on an old Windows95 laptop I have.  I captured a  debug log from the crash and sent it to the author of [snack].  See below for a new version that recycles the same two sound objects each time.

if 0 {
 package require Tk
 package require sound
 proc play s {
    $s stop
    $s play -command "after 0 $s destroy"
    record
 }
 proc record {} {
    set s [snack::sound]
    $s record
    after $::delay "play $s"
    }
 proc createGui {} {
    wm title . "The Babbleback Machine"
    pack [label .label -text "Speak into the microphone"]
    pack [button .exit -text Exit -command exit] -fill both
    bind . <F2> "console show"
 }
 set delay 1000
 if {$argc == 1} {set delay [lindex $argv 0]}
 createGui
 record
}

New version which recycles the same 2 sound objects over and over.  This works around the crash I mention above.  In addition, I added visual display of the sound's waveform.  The right side of the waveform display shows the sound as it is being recorded and the left side of the waveform display shows the sound that is being played.  There are two waveform canvas items involved in the display, but some gymnastics gives the illusion that there is a single continuous waveform.

# Periodic execution
    proc recur {frequency script} {
        eval $script
        after $frequency [list recur $frequency $script]
        }
    proc cancelRecur {frequency cancelScript} {
        foreach tmr [after info] {
            set afterScript [lindex [after info $tmr] 0]
            if {[list recur $frequency $cancelScript] == $afterScript} {
                after cancel $tmr
            }
        }
        }

# Minimal object system inspired by http://wiki.tcl.tk/1225
    proc object name {
        set name [string map {:::: ::} [uplevel 1 namespace current]::$name]
        proc $name args "namespace eval $name \$args"
        return $name
        }
    proc my args {uplevel namespace eval \[namespace current] [list $args]}
    proc self {} {uplevel namespace current}

# Babbleback sound procedures
    set bb [object babbleback]
    $bb proc init {delay} {
        my set delay $delay
        my set recording [snack::sound]
        my set playing [snack::sound]
        }
    $bb proc swapsounds {} {
        variable recording
        variable playing
        set temp $recording
        set recording $playing
        set playing $temp
        $recording stop
        $recording record
        $playing stop
        $playing play
        }
    $bb proc start {} {
        my swapsounds
        my set tmrId [recur [my set delay] [list [self] swapsounds]]
        my set toggleCmd Stop
        }
    $bb proc stop {} {
        cancelRecur [my set delay] [list [self] swapsounds]
        [my set recording] stop
        [my set playing] stop
        my set toggleCmd Start
        }
    $bb proc toggle {} {
        [string tolower [my set toggleCmd]]
        }

# Babbleback gui procedures
    $bb proc swapWaveforms {} {
        variable canvas
        $canvas itemconfigure playing -tag temp
        $canvas itemconfigure recording -tag playing
        $canvas itemconfigure temp -tag recording
        }
    $bb proc positionWaveforms {} {
        variable recording
        variable delay
        variable canvas
        
        # The sound that is being played contains a full waveform graphic.  The sound that is being
        # recorded starts empty and grows as sound is added.  Here, the two waveform positions 
        # are constrained such that the sound that is being recorded at any given time appears to the
        # far right and the sound being played appears at the far left.  Even though there are two 
        # waveforms, the illusion of a single continuous waveform is maintained.
        set ms [expr [$recording length -units seconds] * 1000]
        set pixels [expr - ($ms / $delay) * [my set width]]
        $canvas coords recording 0 0
        $canvas coords playing $pixels 0
        }
    $bb proc destroyWaveforms {} {
        destroy [my set canvas]
        cancelRecur 50 [list [self] positionWaveforms]
        my trace vdelete recording w "[self] swapWaveforms;#"
        my trace vdelete delay w "[self] destroyWaveforms; [self] createWaveforms;#"
        }
    $bb proc createWaveforms {} {
        variable width
        variable height
        variable canvas .waves
        package require snack
        set pixelspersecond [expr $width / ([my set delay] / 1000.0)]
        pack [canvas $canvas -width $width -height $height] -before .label
        
        # One waveform for the playing sound and one for the recording sound
        $canvas create waveform 0 0 -tag playing -sound [my set playing] -width $width -pixelspersecond $pixelspersecond -height $height -limit 15000
        $canvas create waveform 0 0 -tag recording -sound [my set recording] -width $width -pixelspersecond $pixelspersecond -height $height -limit 15000
        recur 50 "[self] positionWaveforms"
        my trace variable recording w "[self] swapWaveforms;#"
        my trace variable delay w "[self] destroyWaveforms; [self] createWaveforms;#"
        }
    $bb proc toggleWaveforms {} {
        catch {my destroyWaveforms}
        if {[my set showWaveforms]} {
            my createWaveforms
        }
    }
    $bb proc createGui {} {
        wm title . "The Babbleback Machine"
        pack [label .label -text "Speak into the microphone"]
        pack [checkbutton .showwave -text "Show waveform" -variable [self]::showWaveforms]
        pack [frame .buttons]
        my set width 300
        my set height 100
        my trace variable showWaveforms w "[self] toggleWaveforms;#"
        my set showWaveforms 1
        pack [button .buttons.toggle -textvariable [self]::toggleCmd -command [list [self] toggle]] -side left
        pack [button .buttons.exit -text Exit -command exit] -side right
        bind . <F2> "console show"
        }

# The main code
    package require sound
    set dly 2000
    if {$argc == 1} {set dly [lindex $argv 0]}
    $bb init $dly
    $bb start
    if {![catch {package require Tk}]} {
        $bb createGui
    } else {
        puts "Speak into the microphone"
        puts "Ctrl-c to exit"
        vwait forever
    }