[dzach] What: A Voice Operated Switch / Recorder package Description: Written in pure tcl, uses Snack, triggers user's callback procedure on "voice on" and "voice off" conditions. License : BSD Created: 13-Mar-2005 The vox tcl package is written in pure tcl and uses the [Snack] Sound Toolkit to provide "sound on" and "sound off" triggers from an incoming sound. To create these triggers, a frame logic is used in the following manner: Starting from an "sound off" condition, a sound portion of length offframe samples is examined, and if the value of any sample exceeds the desired squelch level value then the "sound on" trigger is created at the end of the frame and a user callback procedure oncommand is called. While in the "sound on" condition, frames of onframe length are examined. If all samples in an onframe have values lower than the squelch level, the "sound off" trigger is created and the user callback procedure offcommand is called. All offframes but the last are cut out of the sound object by default. [http://wiki.tcl.tk/_repo/images/vox.png?format=plain] A sample application : '''voxrecorder.tcl''' creates a minimal voice operated recorder that saves wav files for each utterance. package require snack package require Tk package require vox package require tile snack::sound ss label .l -text "Ready to record" -width 20 -anchor w -bg white \ -textvariable ::level pack .l -side top -anchor nw -fill x ttk::button .b -text "Start" -command Rec -padding 0 pack .b -side top -anchor nw -fill both -expand 1 ttk::scale .s -orient horizontal -length 125 -from 0 -to 32768 \ -variable ::sq -command setSq pack .s -side top -anchor nw -fill both # Start/Stop sound recording proc Rec {} { if {$::stopped} { set ::stopped 0 vox::record ss -sqvariable ::sq -slvariable ::level -offcommand save .b configure -bg red -text "Stop" } else { set ::stopped 1 vox::stop ss .b configure -bg green -text "Start" .l configure -bg white } } # procedure to call when sound goes off: Save sound and clear sound object proc save {snd start end} { ss write [clock seconds].wav -start $start -end $end vox::clear ss } # procedure called when the squelch value changes proc setSq {v} { set ::sq $v } # set initial squelch level set ::sq 2500 .s set $::sq set ::stopped 1 bind . Rec Here is how it looks in winXP and [tile] [http://wiki.tcl.tk/_repo/images/vox_tile.png] **Package code** # vox.tcl # Voice Operated Switch/Recorder package # (C) 2004-2005 Dimitrios Zachariadis # Licensed under a BSD license package provide vox 0.1 if {[catch {package req snack}]} { error "package snack is required by vox" } namespace eval vox { proc createVox {w} { namespace eval [namespace current]::${w} { variable var } array set [namespace current]::${w}::var [list \ -onframe 4000 \ -offframe 400 \ -oncommand "vox::dummy" \ -offcommand "vox::dummy" \ -sqvariable "[namespace current]::${w}::var(squelch)" \ -slvariable "[namespace current]::${w}::var(slevel)" \ frlen 0 \ s0 0 \ on 0 \ clear 0 \ recording 0 \ squelch 2500 \ after {} ] } proc record {snd args} { createVox $snd upvar vox::${snd}::var a array set a $args if {$a(-sqvariable) != "vox::${snd}::var(squelch)"} { # user has supplied a -sqvariable. Use it. set a(squelch) [set $a(-sqvariable)] } else { # set the default variable in a(-sqvariable) i.e. vox::${snd}::var(squelch) # to the squelch value set $a(-sqvariable) $a(squelch) } if {!$a(recording)} { $snd flush # start with scanning input every offframe samples set a(frlen) $a(-offframe) set a(recording) 1 $snd record set a(after) [after 0 [list vox::detect $snd 0 0]] } } # stops vox and gets last piece of sound left proc stop {snd args} { upvar [namespace current]::${snd}::var a $snd stop set a(recording) 0 after cancel $a(after) set slen [expr {[$snd length]-1}] # get last piece of sound detect $snd $a(s0) $slen set slen [expr {[$snd length]-1}] if {!$a(on) && $slen>0} { # these are the last off frames, throw them away $snd cut $a(s0) [expr {[$snd length]-1}] } # do what the user wants here if {$args!={}} {namespace eval :: [list $args]} # reset pointers set a(s0) 0 set a(on) 0 } # empty vox sound. Avoids timing problems in cutting out sound proc clear {snd} { upvar [namespace current]::${snd}::var a set a(clear) 1 } # detect a sound in the microphone and serve vox callbacks proc detect {snd s1 s} { upvar [namespace current]::${snd}::var a set slen [$snd length] while {$slen>$a(frlen) && $s < $slen} { set __slev [$snd max -start $s1 -end $s ] if {($__slev < $a(squelch)) || !$a(recording)} { # sound has been below squelch level before last frame or we just stopped recording if {$a(on)} { if {$a(recording)} { # Sound just dropped below squelch level before this frame $snd cut [expr {$s1+1}] $s } else { # stopped recording while sound was on set s1 $s } # use only sound that lasts for at least one onframe if {[expr {$s1-$a(s0)}]>=$a(-onframe)} { # a(s0) is the start of the previous frame that just completed set s $s1 # offcommand callback namespace eval :: [list $a(-offcommand) $snd $a(s0) $s1] if {[$snd length]==0} { # user cleared sound set s1 0 set s 0 } set a(s0) $s1 set a(frlen) $a(-offframe) if {$a(recording)} {set a(on) 0} } } else { # sound below squelch during last two frames if {$a(clear)} { # reset pointers set a(clear) 0 set a(s0) 0 set s1 0 set s 0 # clear sound $snd cut 0 [expr {[$snd length]-1}] } else { # cut last offframe $snd cut $a(s0) $s # adjust s set s [expr {$a(s0) + $a(-offframe)}] } } } else { # sound is coming in or we just started recording if {!$a(on)} { # sound raised above squelch level in last frame # oncommand callback namespace eval :: [list $a(-oncommand) $snd $a(s0) $s1] # advance s to the new frame start set s [expr {$a(s0) + $a(-offframe)}] # we are now working on an onframe sample length set a(frlen) $a(-onframe) # sound is on set a(on) 1 } else { # sound remained above squelch level during last two frames } } # notify outer world about sound level set $a(-slvariable) $__slev # advance s1 set s1 $s # advance s by a frlen set s [expr {$s1 + $a(frlen)}] set slen [$snd length] set a(squelch) [set $a(-sqvariable)] } if {$a(recording)} {set a(after) [after [expr {$a(frlen)/16}] [list vox::detect $snd $s1 $s]]} } proc dummy {snd s0 s1} { } } # pkgIndex.tcl package ifneeded vox 0.1 [list source [file join $dir vox.tcl]] ---- <> [HJG] 2013-12-21 - That page is offline. archive.org has the last version, from [https://web.archive.org/web/20080421225231/http://users.hol.gr/~dzach/vox/vox.html%|%2008-04%|%] [dzach] 2013-12-22 - Just checked. The page is online and viewable. [HJG] 2013-12-24 - Website not reachable: === traceroute to users.hol.gr (194.30.193.61), 30 hops max, 60 byte packets 1 static.33.75.46.78.clients.your-server.de (78.46.75.33) 3.976 ms 3.974 ms 3.968 ms 2 hos-tr2.juniper1.rz12.hetzner.de (213.239.228.161) 0.251 ms hos-tr4.juniper2.rz12.hetzner.de (213.239.228.225) 0.215 ms hos-tr3.juniper2.rz12.hetzner.de (213.239.228.193) 0.222 ms 3 core21.hetzner.de (213.239.245.77) 11.850 ms core22.hetzner.de (213.239.245.117) 0.220 ms core21.hetzner.de (213.239.245.77) 0.216 ms 4 core12.hetzner.de (213.239.245.214) 2.820 ms 2.833 ms 2.831 ms 5 juniper4.rz2.hetzner.de (213.239.245.26) 2.827 ms 2.824 ms 2.819 ms 6 nbg-s1-rou-1001.DE.eurorings.net (134.222.107.20) 7.597 ms 7.471 ms 7.582 ms 7 ffm-s1-rou-1102.DE.eurorings.net (134.222.227.117) 7.439 ms 7.444 ms 7.431 ms 8 ffm-s2-rou-1041.DE.eurorings.net (134.222.229.74) 7.359 ms 7.326 ms 7.308 ms 9 * * * 10 xe-2-0-0.atene7.ate.seabone.net (213.144.178.204) 75.824 ms 75.154 ms 75.145 ms 11 79.140.91.3 (79.140.91.3) 66.004 ms hol.atene7.ate.seabone.net (213.144.178.142) 71.657 ms 195.22.193.26 (195.22.193.26) 57.509 ms 12 tengigaeth00-01-00-02.adr00.ccr.hol.gr (62.38.96.29) 70.930 ms 62.38.96.149 (62.38.96.149) 63.001 ms tengigaeth00-01-00-02.adr00.ccr.hol.gr (62.38.96.29) 70.872 ms 13 tengigaeth01-00-00.adr00.ssw.hol.gr (62.38.96.34) 76.043 ms 77.047 ms 77.033 ms 14 62.38.96.197 (62.38.96.197) 86.070 ms 74.964 ms 87.517 ms 15 62.38.36.78 (62.38.36.78) 75.980 ms 63.399 ms 75.872 ms 16 * * * ... 30 * * * traceroute to users.hol.gr (194.30.193.61), 30 hops max, 60 byte packets 1 swiCS5-V108.switch.ch (130.59.108.5) 0.591 ms 0.620 ms 0.653 ms 2 swiZH2-10GE-3-1.switch.ch (130.59.36.138) 8.714 ms 9.014 ms 9.005 ms 3 swiIX1-10GE-3-3.switch.ch (130.59.36.129) 62.907 ms 62.906 ms 62.888 ms 4 zch-b1-geth3-1.telia.net (213.248.79.189) 0.538 ms 0.627 ms 0.603 ms 5 ffm-bb1-link.telia.net (213.155.133.214) 11.715 ms ffm-bb2-link.telia.net (80.91.249.115) 11.717 ms 11.698 ms 6 ffm-b7-link.telia.net (80.91.249.107) 11.684 ms ffm-b7-link.telia.net (80.91.254.249) 11.914 ms ffm-b7-link.telia.net (80.91.249.107) 11.912 ms 7 globalcrossing-ic-130855-ffm-b7.c.telia.net (213.248.89.182) 12.314 ms 12.350 ms ethernet7-1.ar4.fra4.gblx.net (64.208.110.85) 12.265 ms 8 ae8.scr4.FRA4.gblx.net (67.16.145.241) 12.133 ms 12.191 ms ae8.scr3.FRA4.gblx.net (67.16.145.237) 12.187 ms 9 so2-0-0-2488M.ar5.LON3.gblx.net (67.16.130.146) 24.452 ms 24.604 ms 24.586 ms 10 ote-international-solutions-s-a.so-2-2-0.ar5.lon3.gblx.net (64.210.19.38) 167.206 ms 167.205 ms 164.960 ms 11 tengigaeth00-01-00-02.med00.ccr.hol.gr (62.38.97.29) 100.890 ms 100.556 ms 100.522 ms 12 tengigaeth09-00-00.adr01.ssw.hol.gr (62.38.97.38) 78.600 ms 78.595 ms 78.447 ms 13 62.38.96.201 (62.38.96.201) 97.124 ms 97.288 ms 97.155 ms 14 62.38.36.70 (62.38.36.70) 78.976 ms 79.052 ms 78.983 ms 15 * * * 16 * * * ... [dzach] 2013-12-24 I'm not sure the above traceroute proves that the site is unreachable. But as I re-checked the page, the server seems to be slow to respond, and maybe that is causing timeouts to routers or browsers? In any case, I'll try to move the code here. [dzach] 2013-12-24 Changed the license to from GPL to BSD === <> Sound