NEM 2004-06-24: As a related item, here is a little toy proc for making a foreach loop run asynchronously. Needs work to be really useful, and could benefit from some form of lambda, but somebody might find it useful as a version of the pattern used above:
proc async-foreach {var list body} {
proc async-body [list $var args] [string map [list %BODY $body] {
%BODY
if {[llength $args] > 0} { after idle [list after 0 [linsert $args 0 async-body]] }
}]
after idle [linsert $list 0 async-body]
}And a usage example:
async-foreach item {1 2 3 4 5} { puts "Item = $item" }
vwait forever ;# ->
# item = 1
# item = 2
# item = 3
# item = 4
# item = 5The above implementation has the following limitations:
Extensions are possible, but that needs some work
Lars H: It is perfectly possible to make do without lambdas and unique-name schemes.
proc async-foreach {vars list body {final ""}} {
if {[llength $vars] && [llength $list]} then {
foreach $vars $list {break}
set list [lrange $list [llength $vars] end]
if 1 then $body
after idle [list after 0 [list async-foreach $vars $list $body $final]]
} else $final
}(The if 1 then $body rather than eval $body here is to have $body byte-compiled.) This form adds a second body, $final, which is evaluated after the last iteration. It also supports multiple loop variables. Example:
% async-foreach {item item2} {1 2 3 4 5} { puts "Items = ($item,$item2)" } {puts "That's all, folks!"}
Items = (1,2)
after#28
% Items = (3,4)
Items = (5,)
That's all, folks!Note the slight asynchronicity that the return value from the command (after#28, produced by after) and the following prompt are printed by the command loop between the first and second iteration of the asynch-foreach.
One problem with the above procedure is that you mustn't use the variable names vars, list, body, or final in the body. In a production environment, they should rather be given names like __vars, __list, __body, and __final to avoid unintended overwritings.
Lars H 2008-08-05:
Revisiting this page, I came up with the following braintwister of an implementation that permits arbitrary variable names by having done all substitutions of the special variables vars, list, body, and final before the foreach:
proc async-foreach {vars list body {final ""}} {
if {[llength $vars] && [llength $list]} then {
foreach $vars $list [
set list [lrange $list [llength $vars] end]
list for $body 1 return [
list after idle [list after 0 [
list async-foreach $vars $list $body $final
]]
]
]
} else $final
}(The body of foreach is a for command, and the next script of that for is a return that terminates both loops.) To demonstrate that it works:
% async-foreach {vars list body final} {1 2 3 4 5 6 7} {puts "$vars $list $body $final"} {puts "That's all, folks!"}
1 2 3 4
% 5 6 7
That's all, folks!NEM: Nice improvement. The reason I suggested lambda was precisely to avoid having to have specially named variables. For instance, see the absurd lengths I go to to achieve this at More functional programming. I like the "final" clause - could be useful. Here's another version which handles (I think) all the forms of foreach, allows for cleanup, and allows you to cancel a loop at any time:
namespace eval async { variable id 0; variable data }
# async::foreach --
#
# Usage: async::foreach varlist list ?varlist list...? ?-interval ms|idle? ?-finally script? body
proc async::foreach {varlist list args} {
variable id; variable data
set usage "async::foreach varlist list ?varlist list...? ?-interval ms|idle? ?-finally script? body"
if {[llength $args] < 1 || ([llength $args] % 2) != 1} {
return -code error "wrong # args: should be \"$usage\""
}
set curid [incr id]
set body [lindex $args end]
set data($curid,final) ""
set data($curid,interval) idle
set vars $varlist
set data($curid,lengths) [list [llength $varlist]]
set lists [list $list]
::foreach {key value} [lrange $args 0 end-1] {
if {$key eq "-interval"} {
set data($curid,interval) $value
} elseif {$key eq "-finally"} {
set data($curid,final) $value
} else {
eval lappend vars $key
lappend data($curid,lengths) [llength $key]
lappend lists $value
}
}
# Create a proc for this body
proc body$curid $vars $body
set data($curid,event) [after $data($curid,interval) [list ::async::do $curid $lists]]
return $curid
}
# Proc to actually run the body of the foreach
proc async::do {id lists} {
variable data
set call [list ::async::body$id]; set remainder [list]
for {set i 0} {$i < [llength $data($id,lengths)]} {incr i} {
set clist [lindex $lists $i]; set clen [lindex $data($id,lengths) $i]
eval lappend call [lrange $clist 0 [expr {$clen -1}]]
lappend remainder [lrange $clist $clen end]
}
if {[llength $call] == 1} {
# Finished
cancel $id
} else {
# Evaluate
uplevel 1 $call
set data($id,event) [after $data($id,interval) [list after idle [list ::async::do $id $remainder]]]
}
}
# Cancel a running loop
proc async::cancel id {
variable data
after cancel $data($id,event)
set final $data($id,final)
::foreach key [array names data $id,*] { unset data($key) }
rename ::async::body$id {}
# Run -finally script, if any
uplevel 1 $final
}And a usage example:
set id [async::foreach name {Neil Pete Jon} age {23 42 12} -interval 1000 -finally { puts "Done!" } {
puts "Name = $name Age = $age"
}]
after 2100 [list ::async::cancel $id]
vwait async::data($id,final)
# Produces:
# Name = Neil Age = 23
# Name = Pete Age = 42
# Done!schlenk: How about moving this async foreach into the control module of tcllib? Could help in the effort to make POP3/IMAP4/NNTP protocols in tcllib capable of async operation.
NEM: OK. I've just spotted a bug though (doesn't handle the foreach a {1 2} b {1} ... case). I'll fix it up and get someone to add it in. async versions of for and while would probably be good too.
schlenk: Here is an asynchronous for loop. It evaluates the $start, $test and $next expressions in the namespace given by the -ns option.
proc async::for {start test next args} {
variable id; variable data
set usage "async::for start test next ?-interval ms|idle? ?-ns namespace? ?-finally script? body"
if {[llength $args] < 1 || ([llength $args] %2) != 1} {
return -code error "wrong # args: should be \"$usage\""
}
set curid [incr id]
set body [lindex $args end]
set data($curid,final) ""
set data($curid,interval) idle
set data($curid,test) $test
set data($curid,next) $next
set data($curid,namespace) [uplevel 1 namespace current]
::foreach {key value} [lrange $args 0 end-1] {
if {$key eq "-interval"} {
set data($curid,interval) $value
} elseif {$key eq "-finally"} {
set data($curid,final) $value
} elseif {$key eq "-ns"} {
set data($curid,namespace) $value
} else {
return -code error "wrong # args: should be \"$usage\""
}
}
proc body$curid {} $body
# evaluate start code in global scope
namespace inscope $data($curid,namespace) $start
set data($curid,event) [after $data($curid,interval) [list ::async::dofor $curid]]
return $curid
}
proc async::dofor id {
variable data
set call [list ::async::body$id]
set test [namespace inscope $data($id,namespace) expr $data($id,test)]
if {$test} {
namespace inscope $data($id,namespace) $data($id,next)
uplevel 1 $call
set data($id,event) [after $data($id,interval) [list after idle [list ::async::dofor $id]]]
} else {
cancel $id
}
}
proc async::wait id {
vwait ::async::data($id,final)
}And a usage example:
namespace eval ::scratch { variable i }
set id [async::for {set i 0} {$i < 100} {incr i} -ns ::scratch -interval 100 -finally {puts Done} \
{upvar 0 ::scratch::i i; puts $i}]
after 2500 [list ::async::cancel $id]
async::wait $idLV: Given the features in Tcl 8.5 and 8.6, is there a way to take the above idea and marry it with Tcl's coroutines to get a foreach that would work with generators?
NEM 2008-03-12:
proc async-foreach args {
set body [lindex $args end]
set id ::loop[incr ::loopid]
set body "$body;after idle $id;yield"
coroutine $id foreach {*}[lrange $args 0 end-1] $body
return $id
}LV: So, what would an example of using it look like? Trying to pattern after the examples above, I guess:
puts "example of async-foreach"
set id [async-foreach item {1 2 3 4 5 10 20 30 100} { puts "Item = $item" }]
after 2500 [list ::async::cancel $id]
async::wait $id
puts Done!I'm not certain about this though. The above uses a fixed list, rather than a generator. I'm uncertain how to express the generator.
[PYK] 206-04-03: Added `after 0 ... after idle ...` idiom to all the code examples on this page that stood to benefit from it.