real, dimension(10) :: a, b real :: c a = 2.0 * b + cis evaluated in a way equivalent to:
do i = 1,10
a(i) = 2.0 * b(i) + c
enddo(to use a Fortran 90/95 example)I thought it might be nice to have this ability in Tcl as well ...For the sake of a simple example, I used the "all" function from Fortran:- It takes one argument, a logical expression using (one-dimensional) arrays, which can be viewed as an array itself.
- It returns true if all elements of that array are true (or if there are none)
if { [catch $expr result] } { ...instead of
if { [catch {$expr} result] } { ...The implicit eval done by catch caused the command to fail every single time (it tried to fill in the variables u and v and therefore failed). Now the note about [catch] is no longer valid: it was I who failed, not [catch].The moral: use [catch] with care - you may easily end up catching too many errors. # listexpr.tcl --
# Using [expr] on lists:
# if u and v are lists, then [all {$u > $v}]
# returns 1 if all elements of u are larger than the corresponding
# elements of v and 0 if there is at least one element for which
# the condition does not hold.
#
# makeListProc --
# Create a procedure that handles the list expression
# Arguments:
# expr The expression to be examined element by element
# body The body of the procedure (minus the preliminaries)
# Result:
# Name of the generated procedure
# Note:
# The body argument may contain the substrings EXPR and VARS
# - these are replaced by the expr argument and by the generated
# list of variables for use in the foreach construct.
#
# Limitations:
# The expression should not contain subcommands, that is:
# {$u > [splice $v 1]} would not be parsed properly.
#
proc makeListProc {expr body} {
set vars [lsort -unique [regexp -all -inline {\$[a-zA-Z0-9_]+} $expr]]
set eachlist ""
set decls ""
foreach name $vars {
set vname [string range $name 1 end]
if { [uplevel 2 "llength $name"] > 1 } {
append eachlist "$vname \$_$vname "
append decls "upvar 2 $vname _$vname\n"
} else {
append decls "upvar 2 $vname $vname\n"
}
}
set body [string map [list VARS $eachlist EXPR $expr] $body]
proc $expr {} $decls$body
return $expr
}
# all --
# Check if all elements in the lists referred to in an expression
# comply to that expression
# Arguments:
# expr Expression to be checked
# Result:
# 1 if all elements comply, 0 otherwise. If the lists are
# empty, return 1 too.
#
proc all {expr} {
if { [catch {$expr} result] } {
makeListProc $expr \
{
set result 1
foreach VARS {
if { !(EXPR) } {
set result 0
break
}
}
return $result }
set result [$expr]
}
return $result
}
proc all_simple {expr} {
upvar 1 u u
if { [llength $u] > 1 } {
return [$expr]
}
}
# main --
# Simple test case
#
set u {1 2 3 4}
set v {0 1 2 3}
puts "u > v? [all {$u>$v}]"
set u {2 3 4 1}
puts "u > v? [all {$u>$v}]"
# Measure the time ...
#
proc check {u v} {
set result 0
foreach u1 $u v1 $v {
if { ! ($u1 > $v1) } {
set result 0
break
}
}
return $result
}
puts "Do some timing ..."
set dummy [check $u $v]
foreach len {3 10 30 100 300 1000 3000 10000} \
times {10000 3000 1000 300 100 30 10 3 } {
set u {}
set v {}
for {set i 0} {$i < $len} {incr i} {
lappend u [expr {2+rand()}]
lappend v [expr {rand()}]
}
puts "Length = $len: [time {all {$u>$v}} $times] - [time {check $u $v} $times]"
}
# Note: all_simple breaks if we do this:
# set u 0
# all_simple {$u>$v}
#
puts "How about a combination of lists and scalar variables?"
set u 0.1
puts "v > 0.1? [all {$v>$u}]"
set u -0.1
puts "v > -0.1? [all {$v>$u}]"The output from the (revised) script:
u > v? 1 u > v? 0 Do some timing ... Length = 3: 5 microseconds per iteration - 3 microseconds per iteration Length = 10: 8 microseconds per iteration - 5 microseconds per iteration Length = 30: 14 microseconds per iteration - 12 microseconds per iteration Length = 100: 39 microseconds per iteration - 36 microseconds per iteration Length = 300: 104 microseconds per iteration - 105 microseconds per iteration Length = 1000: 332 microseconds per iteration - 353 microseconds per iteration Length = 3000: 1037 microseconds per iteration - 1034 microseconds per iteration Length = 10000: 3418 microseconds per iteration - 3458 microseconds per iteration How about a combination of lists and scalar variables? v > 0.1? 0 v > -0.1? 1
See also Vector arithmetics... and also fold, filter, map, and zip which are higher-order functions for invoking operations on every member of a list in this way. For instance, the "all" function above can be rewritten as:
proc invoke {cmd args} { uplevel #0 $cmd $args }
proc zipWith {op xs ys} {
set ret [list]
foreach x $xs y $ys { lappend ret [invoke $op $x $y] }
return $ret
}
proc foldl {op id xs} {
foreach x $xs { set id [invoke $op $id $x] }
return $id
}
proc > {a b} { expr {$a > $b} }
proc and {a b} { expr {$a && $b} }
proc all {op xs ys} { foldl and 1 [zipWith $op $xs $ys] }
# Then, e.g.:
all > $u $vAM Hm, the message I failed to convey here is that my [all] procedure works on all kinds of expressions as long as the variables referred to are either one-level lists of two or more elements or scalars. The construction with [catch] makes sure that [makeListProc] is called to (re)construct the underlying procedure, if this is the first time this particular expression is used or if the "type" of the variables has changed (causing [expr] to fail).So, [all {$u+$v>$w}] will work as well.But I have noted there are quite a few Wiki pages concerned with the subject. Is it time to consolidate this inside some Tcllib module?AM Yet another page on lists and operations on their elements: Looking at LISP's SERIES extension
schlenk There are some functions in tcllib for things like this, see the tcllib struct::list module.
'''one''' and '''all''' boolean operators
HaO 2011-05-02 An implementation (using the double-evaluation of expr of its argument) of one (true if one true) and all (true if all true) list operators.Given a list l with values interpreted as booleans:
set l {1 8 true no}a check for at least one true may be done by:expr [join $l ||]If the empty list should not cause an error:
expr [join [linsert $l end 0] ||]The same for any:
expr [join $l &&]and
expr [join [linsert $l end 1] &&]
