Tcl 编程/示例
这些示例脚本中的大多数最初出现在 Tclers' Wiki http://wiki.tcl.tk 。作者（Richard Suchenwirth）声明它们完全属于公有领域。以下脚本是纯 Tcl，它们不使用 Tk GUI 工具包（关于 Tk GUI 工具包有一个单独的章节）。
Tcl 的列表非常适合表示集合。以下是一些典型的集合操作。如果你使用前面解释过的小型测试框架，例如 行将进行自测；否则它们只是说明这些操作应该如何工作。
proc set'contains {set el} {expr {[lsearch -exact $set $el]>=0}}
e.g. {set'contains {A B C} A} -> 1
e.g. {set'contains {A B C} D} -> 0
proc set'add {_set args} {
upvar 1 $_set set
foreach el $args {
if {![set'contains $set $el]} {lappend set $el}
}
set set
}
set example {1 2 3}
e.g. {set'add example 4} -> {1 2 3 4}
e.g. {set'add example 4} -> {1 2 3 4}
proc set'remove {_set args} {
upvar 1 $_set set
foreach el $args {
set pos [lsearch -exact $set $el]
set set [lreplace $set $pos $pos]
}
set set
}
e.g. {set'remove example 3} -> {1 2 4}
proc set'intersection {a b} {
foreach el $a {set arr($el) ""}
set res {}
foreach el $b {if {[info exists arr($el)]} {lappend res $el}}
set res
e.g. {set'intersection {1 2 3 4} {2 4 6 8}} -> {2 4}
proc set'union {a b} {
foreach el $a {set arr($el) ""}
foreach el $b {set arr($el) ""}
lsort [array names arr]
}
e.g. {set'union {1 3 5 7} {2 4 6 8}} -> {1 2 3 4 5 6 7 8}
proc set'difference {a b} {
eval set'remove a $b
}
e.g. {set'difference {1 2 3 4 5} {2 4 6}} -> {1 3 5}
以下示例代码打开一个文件，将其配置为二进制翻译（即，行结束符 \r\n 未标准化为 \n，如 C 中通常的做法），并打印所需的尽可能多的行，每行包含 16 个字节的十六进制表示，以及，如果可能，ASCII 字符。
proc file'hexdump filename {
set fp [open $filename]
fconfigure $fp -translation binary
set n 0
while {![eof $fp]} {
set bytes [read $fp 16]
regsub -all {[^\x20-\xfe]} $bytes . ascii
puts [format "%04X %-48s %-16s" $n [hexdump $bytes] $ascii]
incr n 16
}
close $fp
}
proc hexdump string {
binary scan $string H* hex
regexp -all -inline .. $hex
}
"主程序" 是一行代码，它会转储命令行中给定的所有文件。
foreach file $argv {file'hexdump $file}
示例输出，脚本应用于自身。
...> tclsh hexdump.tcl hexdump.tcl
0000 0d 0a 20 70 72 6f 63 20 66 69 6c 65 27 68 65 78 .. proc file'hex
0010 64 75 6d 70 20 66 69 6c 65 6e 61 6d 65 20 7b 0d dump filename {.
0020 0a 20 20 20 20 73 65 74 20 66 70 20 5b 6f 70 65 . set fp [ope
0030 6e 20 24 66 69 6c 65 6e 61 6d 65 5d 0d 0a 20 20 n $filename]..
...
罗马数字是一个加法（部分减法）系统，字母值如下
I=1 V=5 X=10 L=50 C=100 D=500 M=1000; MCMXCIX = 1999
以下是一些处理罗马数字的 Tcl 例程。
排序罗马数字： I、V、X 已经按正确的顺序排列；对于其他的，我们需要引入临时整理转换，这些转换将在排序后立即撤销。
proc roman:sort list {
set map {IX VIIII L Y XC YXXXX C Z D {\^} ZM {\^ZZZZ} M _}
foreach {from to} $map {
regsub -all $from $list $to list
}
set list [lsort $list]
foreach {from to} [lrevert $map] {
regsub -all $from $list $to list
}
set list
}
从整数生成罗马数字
proc roman:numeral {i} {
set res ""
foreach {value roman} {
1000 M 900 CM 500 D 400 CD 100 C 90 XC 50 L 40 XL
10 X 9 IX 5 V 4 IV 1 I} {
while {$i>=$value} {
append res $roman
incr i -$value
}
}
set res
}
将罗马数字解析为整数
proc roman:get {s} {
array set r_v {M 1000 D 500 C 100 L 50 X 10 V 5 I 1}
set last 99999; set res 0
foreach i [split [string toupper $s] ""] {
if [catch {set val $r_v($i)}] {
error "un-Roman digit $i in $s"
}
incr res $val
if {$val>$last} {incr res [expr -2*$last]}
set last $val
}
set res
}
由于在 Tcl 中，“控制结构”实际上没什么特别之处，只是一组命令，因此与大多数其他语言相比，创建自己的控制结构更容易。例如，如果你想简化 for 循环
for {set i 0} {$i < $max} {incr i} {...}
对于典型的简单情况，你就可以改为写
loop i 0 $max {...}
以下是一个实现，它甚至会返回每次迭代结果的列表。
proc loop {_var from to body} {
upvar 1 $_var var
set res {}
for {set var $from} {$var < $to} {incr var} {lappend res [uplevel 1 $body]}
return $res
}
使用它，字符串反转 函数可以作为单行代码编写。
proc sreverse {str} {
join [loop i 0 [string length $str] {string index $str end-$i}] ""
}
另一个示例是以下 范围感知开关 变体。可以给出范围（数字或字符串）作为 from..to，如果测试值位于该范围内，则会执行关联的脚本片段。
与开关类似，多个 case 的贯穿折叠用 “-” 表示，"default" 作为最后一个条件，如果其他条件都不满足则会触发。与开关不同的是，数字是按数值进行比较，无论它们是十进制、八进制还是十六进制表示。
proc rswitch {value body} {
set go 0
foreach {cond script} $body {
if {[regexp {(.+)\.\.(.+)} $cond -> from to]} {
if {$value >= $from && $value <= $to} {incr go}
} else {
if {$value == $cond} {incr go}
}
if {$go && $script ne "-"} { #(2)
uplevel 1 $script
break
}
}
if {$cond eq "default" && !$go} {uplevel 1 $script} ;#(1)
}
测试
% foreach i {A K c z 0 7} {
puts $i
rswitch $i {
A..Z {puts upper}
a..z {puts lower}
0..9 {puts digit}
}
}
A
upper
K
upper
c
lower
z
lower
0
digit
7
digit
% rswitch 0x2A {42 {puts magic} default {puts df}}
magic
一个非常简单的控制结构（也可以称为结果分派器）是 K 组合子，它非常简单。
proc K {a b} {return $a}
它可以用于所有需要返回非最后一个结果的情况。例如，一次性读取文件
proc readfile filename {
set f [open $filename]
set data [read $f]
close $f
return $data
}
可以简化为，不需要 data 变量，
proc readfile filename {
K [read [set f [open $filename]]] [close $f]
}
另一个示例，弹出堆栈
proc pop _stack {
upvar 1 $_stack stack
K [lindex $stack end] [set stack [lrange $stack 0 end-1]]
}
这在某些方面类似于 LISP 的 PROG1 结构：计算包含的表达式，并返回第一个表达式的结果。
有理数，又称分数，可以看作是整数对 {分子 分母}，因此它们的“真实”数值为分子/分母（而不是整数或“双精度”除法！）。它们可能比计算机上的任何“浮点数”或“双精度数”都更精确，因为这些数不能准确地表示分母不是 2 的幂的分数——考虑 1⁄3，即使是 bignum，它也不能以任何精度准确地表示为以 2 为底的浮点数，也不能表示为十进制分数（以 10 为底）。
有理数的一个明显字符串表示当然是 "n/d"。以下的“构造函数”会执行此操作，并标准化符号，简化为最简形式，如果 d==1，则仅返回整数 n。
proc rat {n d} {
if {!$d} {error "denominator can't be 0"}
if {$d<0} {set n [- $n]; set d [- $d]}
set g [gcd $n $d]
set n [/ $n $g]
set d [/ $d $g]
expr {$d==1? $n: "$n/$d" }
}
相反，这个“解构函数”会将一个或多个有理数或整数字符串拆分为 num 和 den 变量，使得 [ratsplit 1/3 a b] 将 1 分配给 a，将 3 分配给 b。
proc ratsplit args {
foreach {r _n _d} $args {
upvar 1 $_n n $_d d
foreach {n d} [split $r /] break
if {$d eq ""} {set d 1}
}
}
#-- Four-species math on "rats":
proc rat+ {r s} {
ratsplit $r a b $s c d
rat [+ [* $a $d] [* $c $b]] [* $b $d]
}
proc rat- {r s} {
ratsplit $r a b $s c d
rat [- [* $a $d] [* $c $b]] [* $b $d]
}
proc rat* {r s} {
ratsplit $r a b $s c d
rat [* $a $c] [* $b $d]
}
proc rat/ {r s} {
ratsplit $r a b $s c d
rat [* $a $d] [* $b $c]
}
如果算术辅助函数仅包含对 expr 的一次调用，则可以使用 func 包裹它们。
proc func {name argl body} {proc $name $argl [list expr $body]}
#-- Greatest common denominator:
func gcd {u v} {$u? [gcd [% $v $u] $u]: abs($v)}
#-- Binary expr operators exported:
foreach op {+ * / %} {func $op {a b} \$a$op\$b}
#-- "-" can have 1 or 2 operands:
func - {a {b ""}} {$b eq ""? -$a: $a-$b}
#-- a little tester reports the unexpected:
proc ? {cmd expected} {
catch {uplevel 1 $cmd} res
if {$res ne $expected} {puts "$cmd -> $res, expected $expected"}
}
#-- The test suite should silently pass when this file is sourced:
? {rat 42 6} 7
? {rat 1 -2} -1/2
? {rat -1 -2} 1/2
? {rat 1 0} "denominator can't be 0"
? {rat+ 1/3 1/3} 2/3
? {rat+ 1/2 1/2} 1
? {rat+ 1/2 1/3} 5/6
? {rat+ 1 1/2} 3/2
? {rat- 1/2 1/8} 3/8
? {rat- 1/2 1/-8} 5/8
? {rat- 1/7 1/7} 0
? {rat* 1/2 1/2} 1/4
? {rat/ 1/4 1/4} 1
? {rat/ 4 -6} -2/3
Lisp 和 Python 等语言具有文档字符串功能，其中函数开头的字符串可以被检索用于在线（或打印）文档。Tcl 没有内置此机制（而且很难完全以相同的方式实现，因为一切都只是字符串），但可以轻松地采用类似的机制，并且与之相比它看起来并不差。
- 通用 Lisp： (documentation 'foo 'function)
- Python： foo.__doc__
- Tcl： docstring foo
如果文档字符串以 proc 主体的开头注释的形式编写，则很容易将其解析出来。此外，对于所有 proc，即使没有文档字符串，你也会获得“签名”（proc 名称和参数，以及默认值）。下面的代码也用作使用示例： }
proc docstring procname {
# reports a proc's args and leading comments.
# Multiple documentation lines are allowed.
set res "{usage: $procname [uplevel 1 [list info args $procname]]}"
# This comment should not appear in the docstring
foreach line [split [uplevel 1 [list info body $procname]] \n] {
if {[string trim $line] eq ""} continue
if ![regexp {\s*#(.+)} $line -> line] break
lappend res [string trim $line]
}
join $res \n
}
proc args procname {
# Signature of a proc: arguments with defaults
set res ""
foreach a [info args $procname] {
if [info default $procname $a default] {
lappend a $default
}
lappend res $a
}
set res
}
测试
% docstring docstring
usage: docstring procname
reports a proc's args and leading comments.
Multiple documentation lines are allowed.
% docstring args
usage: args procname
Signature of a proc: arguments with defaults
阶乘 (n!) 是一个流行的函数，具有超指数增长。数学上讲，
0! = 1
n! = n (n-1)! if n >0, else undefined
在 Tcl 中，我们可以以非常相似的方式获得它。
proc fact n {expr {$n<2? 1: $n * [fact [incr n -1]]}}
但这很快就会超出整数的范围，导致结果错误。
一本数学书向我展示了对大 n 的 n! 的斯特林近似值（在 Tcl 的精度范围内，“大”意味着 > 20 ...），所以我把它构建了进去。
proc fact n {expr {
$n<2? 1:
$n>20? pow($n,$n)*exp(-$n)*sqrt(2*acos(-1)*$n):
wide($n)*[fact [incr n -1]]}
}
以防有人需要近似的大阶乘... 但对于n>143，我们达到了浮点数的域限制。事实上，浮点数的限制在n>170，所以斯特林公式中的中间结果必须在144处失效。对于这么少的数值，最有效的方法是直接从预先构建的表中查找，就像Tcllib的math::factorial一样。
信纸和法律文件纸张格式在美国和其他地方很流行。在欧洲和其他地方，最广泛使用的纸张格式被称为A4。要想知道纸张格式有多大，可以用尺子测量一个实例，或者查找相应的文档。A系列格式也可以从以下公理推断出来
- A0的面积为一平方米
A(n)的面积是A(n-1)的一半- A系列格式的长边与短边之间的比率是恒定的
如果我们考虑到A(n)是从A(n-1)通过平行于短边的一半产生的，就可以很容易地计算出这个比率是多少，所以
2a : b = b : a,
2 a2 = b2,
b=sqrt(2) a, hence
b : a = sqrt(2) : 1
所以这里是我的Tcl实现，它返回以厘米为单位的高度和宽度列表（10000平方厘米 = 1平方米），保留两位小数，这足以提供1/10毫米的精度：}
proc paperA n {
set w [expr {sqrt(10000/(pow(2,$n) * sqrt(2)))}]
set h [expr {$w * sqrt(2)}]
format "%.2f %.2f" $h $w
}
% paperA 4
29.73 21.02
这里有一个查询或设置向量中单个位的例程，其中位由非负整数寻址。实现是一个“小端”整数列表，其中位0..31在第一个列表元素中，32..63在第二个列表元素中，等等。
用法：bit varName position ?bitval?
如果给定了bitval，则将位置position处的位设置为1（如果bitval != 0），否则设置为0；无论哪种情况，都返回指定位置处的位值。如果变量varName在调用者的作用域中不存在，它将被创建；如果它不够长，它将被扩展以至少容纳$position+1个位，例如 bit foo 32 会将 foo 变成一个包含两个整数的列表，如果它之前只有一个整数。所有位都被初始化为0。
proc bit {varName pos {bitval {}}} {
upvar 1 $varName var
if {![info exist var]} {set var 0}
set element [expr {$pos/32}]
while {$element >= [llength $var]} {lappend var 0}
set bitpos [expr {1 << $pos%32}]
set word [lindex $var $element]
if {$bitval != ""} {
if {$bitval} {
set word [expr {$word | $bitpos}]
} else {
set word [expr {$word & ~$bitpos}]
}
lset var $element $word
}
expr {($word & $bitpos) != 0}
}
#---------------------- now testing...
if {[file tail [info script]] == [file tail $argv0]} {
foreach {test expected} {
{bit foo 5 1} 1
{set foo} 32
{bit foo 32 1} {32 1}
} {
catch {eval $test} res
puts $test:$res/$expected
}
}
这可以用于按数值索引的项目集的布尔属性。例如，邮政编码在00000和99999之间的存在映射可以保存在一个包含3125个整数的列表中（其中每个元素总共需要大约15字节），而将映射实现为数组在最坏情况下需要100000 * 42字节，但如果人口不是非常稀疏，仍然比位向量多——在这种情况下，一个包含1位位置的列表，使用lsearch检索，在内存使用方面可能更有效。位向量访问的运行时间是恒定的，除非向量必须扩展到更大的长度。
位向量还可以用于指示集合成员资格（如果使用位运算符（&, |, ~, ^）一次处理32位，集合操作将运行得更快）——或者二进制图像中的像素，其中每一行都可以由一个位向量实现。
这是一个返回位向量中所有置位位的数字索引的例程
proc bits bitvec {
set res {}
set pos 0
foreach word $bitvec {
for {set i 0} {$i<32} {incr i} {
if {$word & 1<<$i} {lappend res $pos}
incr pos
}
}
set res
}
% bit foo 47 1
1
% bit foo 11 1
1
% set foo
2048 32768
% bits $foo
11 47
埃拉托斯特尼筛法：下面的过程通过让位表示整数，并取消设置所有可被整除的位，来练习位向量函数。最终仍然置位的位的数字应该是素数，并被返回
proc sieve max {
set maxroot [expr {sqrt($max)}]
set primes [string repeat " 0xFFFFFFFF" [expr {($max+31)/32}]]
bit primes 0 0; bit primes 1 0
for {set i [expr $max+1]} {$i<=(($max+31)/32)*32} {incr i} {
bit primes $i 0 ;# mask out excess bits
}
for {set i 2} {$i<=$maxroot} {incr i} {
if {[bit primes $i]} {
for {set j [expr $i<<1]} {$j<=$max} {incr j $i} {
bit primes $j 0
}
}
}
bits $primes
}
% time {set res [sieve 10000]}
797000 microseconds per iteration
这里是一段代码，用于计算位向量中1位的数量，用整数列表表示。它通过将十六进制数字的值相加来实现
proc bitcount intlist {
array set bits {
0 0 1 1 2 1 3 2 4 1 5 2 6 2 7 3
8 1 9 2 a 2 b 3 c 2 d 3 e 3 f 4
}
set sum 0
foreach int $intlist {
foreach nybble [split [format %x $int] ""] {
incr sum $bits($nybble)
}
}
set sum
}
堆栈和队列是用于数据对象的容器，具有典型的访问方法
- push：将一个对象添加到容器中
- pop：检索并从容器中移除一个对象
在Tcl中，使用列表来实现堆栈和队列是最容易的，而push方法最自然的是lappend，所以我们只需要为所有堆栈和队列编写一行通用的代码
interp alias {} push {} lappend
堆栈、队列和优先级队列的不同之处在于pop操作
- 在堆栈中，检索并移除最后压入的对象（后进先出，LIFO）
- 在（普通）队列中，检索并移除最先压入的对象（先进先出，FIFO）
- 在优先级队列中，优先级最高的项目排在最前面。
优先级（一个数字）必须在压入时分配——通过压入一个包含两个元素的列表，即项目本身和优先级，例如。
push toDo [list "go shopping" 2]
push toDo {"answer mail" 3}
push toDo {"Tcl coding" 1} ;# most important thing to do
在常见的用法中，优先级1是“最高”，而数字对于“更低”的优先级会增加——但你可以压入一个优先级为0的项目，表示“超高”；-) 弹出堆栈可以这样实现
proc pop name {
upvar 1 $name stack
set res [lindex $stack end]
set stack [lrange $stack 0 end-1]
set res
}
弹出队列的结构类似，但细节差异很大，以至于我找不到方便的方法来将它们分解出来
proc qpop name {
upvar 1 $name queue
set res [lindex $queue 0]
set queue [lrange $queue 1 end]
set res
}
弹出优先级队列需要确定哪个项目具有最高的优先级。排序可以在压入时进行，也可以在弹出时进行，由于我们的压入方法是如此通用，我更喜欢第二种选择（因为压入和弹出的数量应该大致相等，因此没有本质区别）。Tcl的lsort是稳定的，因此具有相同优先级的项目将按照它们入队的顺序保留下来
proc pqpop name {
upvar 1 $name queue
set queue [lsort -real -index 1 $queue]
qpop queue ;# fall back to standard queue, now that it's sorted
}
一个实际的应用例子是状态空间搜索，其中待办事项列表的容器类型决定了策略
- 堆栈是深度优先
- （普通）队列是广度优先
- 优先级队列是任何更聪明的方法：A*、贪心算法，等等
最近使用列表：一种既可以以堆栈方式使用也可以以队列方式使用的变体是按最后使用顺序排列的值列表（例如，这在编辑器中非常有用，用于显示最后编辑的文件）。在这里，压入必须由专用代码完成，因为必须移除以前的实例
proc rupush {listName value} {
upvar 1 $listName list
if {![info exist list]} {set list {}}
set pos [lsearch $list $value]
set list [lreplace $list $pos $pos]
lappend list $value
}
% rupush tmp hello
hello
% rupush tmp world
hello world
% rupush tmp again
hello world again
% rupush tmp world
hello again world
第一个元素是最久未使用的，最后一个元素是最新的使用的。元素不会被弹出移除，而是在（如果需要）重新压入时移除。（如果列表过长，可以从前面截断它）。
Tcl中的函数通常用proc命令编写。但我注意到，在我走向函数式编程的道路上，我的proc主体越来越多地是单个对expr的调用，它完成所有其他的工作（通常使用强大的x?y:z运算符）。那么，围绕这种重复模式建立一个薄抽象（包装器）怎么样呢？
proc func {name argl body} {proc $name $argl [list expr $body]}
（我可能也把它叫做fun... 它确实很有趣。）就是这样。一个附带的优势是所有表达式都被括起来，我无需关心。但是，为了不使页面看起来过于空旷，这里有一些func使用的示例
func fac n {$n<2? 1: $n*[fac [incr n -1]]}
func gcd {u v} {$u? [gcd [expr $v%$u] $u]: $v}
func min {a b} {$a<$b? $a: $b}
func sgn x {($x>0)-($x<0)} ;# courtesy rmax
遗憾的是，我们必须再次明确地使用expr，在像gcd这样的嵌套调用中... 但是func不限于数学函数（尤其是递归的数学函数，它们看起来很漂亮），而是用于expr在测试谓词中的使用
func atomar list {[lindex $list 0] eq $list}
func empty list {[llength $list] == 0}
func in {list element} {[lsearch -exact $list $element] >= 0}
func limit {x min max} {$x<$min? $min: $x>$max? $max: $x}
func ladd {list e} {[in $list $e]? $list: [lappend list $e]}
将expr二元算术运算符公开为Tcl命令非常容易
foreach op {+ * / %} {func $op {a b} "\$a $op \$b"}
对于“ - ”，我们区分一元形式和二元形式
func - {a {b ""}} {$b eq ""? -$a: $a-$b}
公开了取模运算符后，gcd现在看起来更漂亮了
func gcd {u v} {$u? [gcd [% $v $u] $u]: abs($v)}
对于一元非，我更喜欢这个名字而不是“!”，因为它也可能代表阶乘——看看我写过的最短的函数主体；-)
func not x {!$x}
没有过多提及，由递归实现的函数具有一种适合使用func的模式（参见上面的fac和gcd）。另一个例子是这个整数范围生成器（从1开始，并且是包含的，所以[iota1 5] == {1 2 3 4 5}）
func iota1 n {$n == 1? 1: [concat [iota1 [- $n 1]] $n]}
"NAND 非 AND"。这里是一些Tcl代码片段，用于演示如何用单个NAND运算符来表示所有布尔运算，该运算符在两个输入都不为真时返回真（NOR也能很好地做到这一点）。我们在expr中拥有布尔运算符，所以我们开始吧
proc nand {A B} {expr {!($A && $B)}}
唯一的单目运算符NOT可以用nand表示
proc not {A} {nand $A $A}
... 以及其他所有东西都可以用它们构建
proc and {A B} {not [nand $A $B]}
proc or {A B} {nand [not $A] [not $B]}
proc nor {A B} {not [or $A $B]}
proc eq {A B} {or [and $A $B] [nor $A $B]}
proc ne {A B} {nor [and $A $B] [nor $A $B]}
这里有一些测试工具——要查看实现是否正确，请查看它的真值表，这里用 A、B 的四种组合 0,0 0,1 1,0 1,1 来完成——旁注：注意函数是如何容易地作为参数传入的
proc truthtable f {
set res {}
foreach A {0 1} {
foreach B {0 1} {
lappend res [$f $A $B]
}
}
set res
}
% truthtable and
0 0 0 1
% truthtable nand
1 1 1 0
% truthtable or
0 1 1 1
% truthtable nor
1 0 0 0
% truthtable eq
1 0 0 1
要查看实现的效率（就使用的NAND单元而言），请尝试以下方法，它依赖于这样一个事实，即布尔函数不包含除运算符名称以外的小写字母
proc nandcount f {
regsub -all {[^a-z]} [info body $f] " " list
set nums [string map {nand 1 not 1 and 2 nor 4 or 3 eq 6} $list]
expr [join $nums +]
}
作为一个截然不同的想法，与NAND作为基本函数无关，以下通用代码非常直观地“实现”了布尔函数，只需给出它们的真值表，并在运行时进行查找
proc booleanFunction {truthtable a b} {
lindex $truthtable [expr {!!$a+!!$a+!!$b}]
}
interp alias {} and {} booleanFunction {0 0 0 1}
interp alias {} or {} booleanFunction {0 1 1 1}
interp alias {} nand {} booleanFunction {1 1 1 0}
字母算术是一种谜题，其中数字用字母表示，任务是找出每个字母代表的数字。以下“通用问题求解器”（适用于少量通用问题）使用大量元编程：它
- 构建一个适合问题的嵌套 foreach 结构,
- 快速杀死（使用 continue）以强制变量具有唯一值，以及
- 返回找到的第一个解，否则返回空字符串
proc solve {problem {domain0 {0 1 2 3 4 5 6 7 8 9}}} {
set vars [lsort -u [split [regsub -all {[^A-Z]} $problem ""] ""]]
set map {= ==}
set outers {}
set initials [regexp -all -inline {[^A-Z]([A-Z])} /$problem]
set pos [lsearch $domain0 0]
set domain1 [lreplace $domain0 $pos $pos]
foreach var $vars {
append body "foreach $var \$domain[expr [lsearch $initials $var]>=0] \{\n"
lappend map $var $$var
foreach outer $outers {
append body "if {$$var eq $$outer} continue\n"
}
lappend outers $var
append epilog \}
}
set test [string map $map $problem]
append body "if {\[expr $test\]} {return \[subst $test\]}" $epilog
if 1 $body
}
这在一些众所周知的字母算术问题中效果良好
% solve SEND+MORE=MONEY
9567+1085==10652
% solve SAVE+MORE=MONEY
9386+1076==10462
% solve YELLOW+YELLOW+RED=ORANGE
143329+143329+846==287504
有很多复杂的数据库。在这里，我想探讨如何以 Tcl 的简洁精神实现数据库，以及这种方法能带我们走多远。考虑以下模型
- 数据库是一组记录
- 记录是一组非空字段，具有唯一 ID
- 字段是一对标签和非空值，两者都是字符串
字段可以很好地实现为数组条目，因此我们可以为每个记录创建一个数组，或者更好的是，为整个数据库创建一个数组，其中键由 ID 和标签组成。唯一 ID 可以通过简单地向上计数（递增迄今为止的最高 ID）来获得。创建简单数据库的过程仅包括为 ID 设置初始值
set db(lastid) 0
让我们考虑一个图书馆应用程序作为示例。向数据库添加一本书可以通过以下方式简单完成
set id [incr db(lastid)]
set db($id,author) "Shakespeare, William"
set db($id,title) "The Tempest"
set db($id,printed) 1962
set db($id,label) S321-001
请注意，由于我们从未指定记录应包含哪些字段，因此我们可以根据需要添加任何字段。为了便于处理，最好对记录进行分类（我们想要存储的不仅仅是书籍），因此我们添加
set db($id,isa) book
检索记录很简单（尽管字段的顺序不确定）
array get db $id,*
删除记录稍微复杂一点
foreach i [array names db $id,*] {unset db($i)}
或者，从 Tcl 8.3 开始，更简单、更快速
array unset db $id,*
以下是获取“列”（给定标签的所有字段）的方法
array get db *,title
但是，真实的列可能包含空字段，我们不想存储这些字段。检索可能不存在的物理字段需要一个容错访问函数
proc db'get {_db id field} {
upvar $_db db
if {[array names db $id,$field]=="$id,$field"} {
return $db($id,$field)
} else {return ""}
}
在传统数据库中，我们必须定义表：哪些类型的字段，以及它们的宽度。在这里，我们可以随心所欲，甚至检索迄今为止使用过的字段（使用临时数组来跟踪字段名称）
proc db'fields {_db} {
upvar $_db db
foreach i [array names db *,*] {
set tmp([lindex [split $i ,] 1]) ""
}
lsort [array names tmp]
}
可以对满足特定条件的记录进行顺序搜索。例如，我们想要所有 1980 年之前出版的书籍
foreach i [array names *,printed] {
if {$db($i)<1980} {
set id [lindex [split $i ,] 0]
puts "[db'get db $id author]: [db'get db $id title] $db($i)"
}
}
我们也可以将我们的赞助人存储在同一个数据库中（这里以不同的方式）
set i [incr $db(lastid)]
array set db [list $i,name "John F. Smith" $i,tel (123)456-7890 $i,isa patron}
没有“表”的概念，我们现在可以引入类似于关系数据库中的结构。假设 John Smith 借阅了“The Tempest”。我们有赞助人和书籍的 ID 在变量中，并进行双重簿记
lappend db($patron,borrowed) $book ;# might have borrowed other books
set db($book,borrower) $patron
set db($book,dueback) 2001-06-12
当他归还书籍时，该过程会反转
set pos [lsearch $db($patron,borrowed) $book]
set db($patron,borrowed) [lreplace $db($patron,borrowed) $pos $pos]
unset db($book,borrower) ;# we're not interested in empty fields
unset db($book,dueback)
dueback 字段（%Y-%M-%d 格式适合排序和比较）对于检查书籍是否没有按时归还很有用
set today [clock format [clock seconds] -format %Y-%M-%d]]
foreach i [array names db *,dueback] {
if {$db($i)<$today} {
set book [lindex [split $i ,] 0] ;# or: set book [idof $i] - see below
set patron $db($book,borrower)
#write a letter
puts "Dear $db($patron,name), "
puts "please return $db($book,title) which was due on\
$db($book,dueback)"
}
}
同样，会计的部分内容（例如，对书商的订单和发票）可以轻松添加，并且也可以与外部文件交叉关联（只需将值设置为文件名即可）。
索引：如所示，我们可以通过对数组名称进行顺序搜索来检索所有数据。但是，如果数据库的大小不断增长，那么创建交叉引用标签和值到 ID 的索引是个好主意。例如，以下是如何在四行中创建作者索引
foreach i [array names db *,author] {
set book [lindex [split $i ,] 0]
lappend db(author=[string toupper $db($i)]) $book
}
# and then..
foreach i [lsort [array names db author=SHAK*]] {
puts "[lindex [split $i =] 1]:" ;# could be wrapped as 'valueof'
foreach id $db($i) {
puts "[db'get db $id title] - [db'get db $id label]"
}
}
这会为我们提供所有与给定 glob 模式匹配的作者的书籍列表（我们重用 Tcl 的功能，而不是重新发明它……）。索引对于重复的信息很有用，这些信息很可能会被搜索。特别是，对 isa 字段进行索引允许遍历“表”（我们仍然没有明确地拥有它们！;-）
regsub -all isa= [array names db isa=*] "" tables
foreach patron $db(isa=patron) {...}
除了行业标准 SQL 之外，我们还可以在一个查询中搜索多个索引
array names db *=*MARK*
这会为您提供 MARK 的所有（不区分大小写）匹配项，无论是在赞助人姓名、书籍作者还是标题中。就像古老的 grep 一样通用……
持久性：数据库应该存在于会话之间，因此以下是将数据库保存到文件的方法
set fp [open Library.db w]
puts $fp [list array set db [array get db]]
close $fp
加载数据库更简单（重新加载时，最好先取消设置数组）
source Library.db
如果您使用的是系统编码之外的字符（在 Kanji 中写入日语书名没问题），则在保存和加载时必须使用 fconfigure（例如 -encoding utf-8），但这只是一些额外的 LOC。保存也可以很好地完成所谓的“提交”（对于多用户系统，您需要写入锁定），而加载（在保存之前没有保存）可能被称为“一级回滚”，您希望丢弃最新的更改。
请注意，到目前为止，我们只定义了一个简短的 proc，所有其他操作都是使用内置的 Tcl 命令完成的。为了使代码更清晰，建议将频繁的操作分解为 proc，例如
proc idof {index} {lindex [split $index ,] 0}
proc db'add {_db data} {
upvar $_db db
set id [incr db(lastid)]
foreach {tag value} $data {set db($id,$tag) $value}
# might also update indexes here
}
proc db'tablerow {_db id tags} {
upvar $_db db
set res {}
foreach tag $tags {lappend res [db'get db $id $tag]}
set res
}
当然，随着数据库的增长，我们可能会遇到内存限制：数组需要一些额外的存储空间用于管理。另一方面，目前的方法非常经济，因为它不使用字段宽度（所有字符串都是“收缩包装”的），并且省略了空字段，同时允许您添加任何您想要的字段。进一步的优化可以统计值字符串，并将频繁出现的字符串替换为“@$id”，其中 db(@$id) 存储一次值，并且只有 db'get 需要进行调整以重定向查询。
此外，现代计算机的内存限制非常高……因此，只有在将来的某个时间您才可能遇到（但可能不想）更改为复杂的数据库 ;-）
关于限制：Tcl 数组可能变得非常大（据报道一个应用程序在希腊字符中存储了 800000 个键），在某个时候，使用数组名称 db 枚举所有键（生成一个很长的列表）可能会超过您的可用内存，导致进程进行交换。在这种情况下，您可以回退到（否则更慢、更丑陋的）专用迭代器
set search [array startsearch db]
while {[array anymore db $search]} {
set key [array nextelement db $search]
# now do something with db($key) - but see below!
}
array donesearch db $search
但是，您既不能使用 glob 模式过滤要获取的键，也不能在循环中添加或删除数组元素——搜索将立即终止。
这里将表理解为数据的矩形（矩阵）排列，以行（每个“项”/“记录”一行）和列（每个“字段”/“元素”一列）排列。例如，它们是关系数据库和电子表格的构建块。在 Tcl 中，用于紧凑数据存储的明智实现将是列表的列表。这样，它们是“纯值”，并且可以例如通过接受表并返回表的函数传递。与 Tcllib 中更重量级的矩阵相比，不需要构造函数/析构函数。我知道 Tcl 中有很多表实现，但就像通常一样，我想用“赤手空拳”构建一个尽可能简单的表。正如您在下面看到的，许多功能可以通过简单地使用 Tcl 的列表函数来“实现”。
一个不错的表还有一个标题行，用于指定字段名称。因此，要创建具有定义的字段结构但尚未包含内容的表，只需分配标题列表
set tbl { {firstname lastname phone}}
请注意双重括号，它确保 tbl 是一个包含 1 个元素的列表。向表添加“记录”就像这样简单
lappend tbl {John Smith (123)456-7890}
确保字段（单元格）与标题中的字段匹配。这里单括号是正确的。如果字段内容包含空格，则也必须对其进行引用或括号。
lappend tbl {{George W} Bush 234-5678}
可以使用 lsort -index 对表进行排序，确保标题行位于顶部
proc tsort args {
set table [lindex $args end]
set header [lindex $table 0]
set res [eval lsort [lrange $args 0 end-1] [list [lrange $table 1 end]]]
linsert $res 0 $header
}
使用 lreplace 删除一行（或连续的行序列）
set tbl [lreplace $tbl $from $to]
使用以下方法可以轻松地简单打印这样的表，每行一行
puts [join $tbl \n]
使用字段名称而不是数字索引访问表中的字段更有趣，这可以通过字段名称位于第一行这一事实来轻松实现
proc t@ {tbl field} {lsearch [lindex $tbl 0] $field}
% t@ $tbl phone
2
然后您可以访问单元格
puts [lindex $tbl $rownumber [t@ $tbl lastname]]
并像这样替换单元格内容
lset tbl $rownumber [t@ $tbl phone] (222)333-4567
以下是通过给出字段名称和 glob 风格表达式的对来过滤表的方法——除了标题行之外，所有满足至少一个条件的行都会通过（您可以通过嵌套这样的调用来强制使用 AND 行为）
proc trows {tbl args} {
set conditions {}
foreach {field condition} $args {
lappend conditions [t@ $tbl $field] $condition
}
set res [list [lindex $tbl 0]]
foreach row [lrange $tbl 1 end] {
foreach {index condition} $conditions {
if [string match $condition [lindex $row $index]] {
lappend res $row
break; # one hit is sufficient
}
}
}
set res
}
% trows $tbl lastname Sm*
{firstname lastname} phone {John Smith (123)456-7890}
这会过滤（如果需要，还会重新排列）列，有点类似于所谓的“视图”
proc tcols {tbl args} {
set indices {}
foreach field $args {lappend indices [t@ $tbl $field]}
set res {}
foreach row $tbl {
set newrow {}
foreach index $indices {lappend newrow [lindex $row $index]}
lappend res $newrow
}
set res
}
在接下来的几章中，您将看到用 Tcl 模拟或探索其他编程语言是多么容易。
多年来，GOTO “跳转”指令一直被认为是编程中的有害指令，但对其进行实验仍然很有趣。Tcl 没有goto 命令，但可以轻松创建它。以下代码是在 Tcl 聊天室中创建的，由以下引文引发：“计算机是状态机。线程是为不会编程状态机的人准备的。”
因此，这里有一个十行代码的状态机模型。“机器”本身接收交替的标签和状态代码的列表；如果状态代码没有以 goto 或 break 结束，则该状态将重复，直到离开，使用 goto 或 break（隐式无限循环）。goto 命令是“本地”定义的，并在离开状态机后删除——它在状态机之外没有意义。执行从第一个状态开始。
proc statemachine states {
array set S $states
proc goto label {
uplevel 1 set this $label
return -code continue
}
set this [lindex $states 0]
while 1 {eval $S($this)}
rename goto {}
}
测试：一个微小的状态机，它会根据你的意愿向你问好，如果你在“问候频率”问题上只按 返回 键，它就会结束。
statemachine {
1 {
puts "how often?"
gets stdin nmax
if {$nmax eq ""} {goto 3}
set n 0
goto 2
} 2 {
if {[incr n] > $nmax} {goto 1}
puts "hello"
} 3 {puts "Thank you!"; break}
}
在这个周末的娱乐项目中，我模拟了 Intel 8080A/8085 汇编语言的一部分（因为我手头有一份详细的参考资料），这些部分很容易实现，并且仍然具有一定的教育意义（或者怀旧意义 ;-）。
当然，这不是真正的汇编器。内存模型是固定大小的指令（数组元素中的字符串），这些指令被实现为 Tcl 过程。因此，在这个玩具中的“汇编器”程序运行速度甚至比纯 Tcl 还慢，并且会消耗更多内存——而通常情况下，人们将速度和简洁性与“真正的”汇编代码联系起来。但它看起来有点像真东西：你会得到一个带有符号表的汇编清单，并且可以运行它——我不会用 C 语言编写汇编器，但在 Tcl 中，用它来消磨一个阳光明媚的周日下午很有趣... }
namespace eval asm {
proc asm body {
variable mem
catch {unset mem} ;# good for repeated sourcing
foreach line [split $body \n] {
foreach i {label op args} {set $i ""}
regexp {([^;]*);} $line -> line ;# strip off comments
regexp {^ *(([A-Z0-9]+):)? *([A-Z]*) +(.*)} [string toupper $line]\
-> - label op args
puts label=$label,op=$op,args=$args
if {$label!=""} {set sym($label) $PC}
if {$op==""} continue
if {$op=="DB"} {set mem($PC) [convertHex $args]; incr PC; continue}
if {$op=="EQU"} {set sym($label) [convertHex $args]; continue}
if {$op=="ORG"} {set PC [convertHex $args]; continue}
regsub -all ", *" $args " " args ;# normalize commas
set mem($PC) "$op $args"
incr PC
}
substituteSymbols sym
dump sym
}
proc convertHex s {
if [regexp {^([0-9A-F]+)H$} [string trim $s] -> s] {set s [expr 0x$s]}
set s
}
proc substituteSymbols {_sym} {
variable mem
upvar $_sym sym
foreach i [array names mem] {
set tmp [lindex $mem($i) 0]
foreach j [lrange $mem($i) 1 end] {
if {[array names sym $j] eq $j} {set j $sym($j)}
lappend tmp $j
}
set mem($i) $tmp
}
}
proc dump {_sym} {
variable mem
upvar $_sym sym
foreach i [lsort -integer [array names mem]] {
puts [format "%04d %s" $i $mem($i)]
}
foreach i [lsort [array names sym]] {
puts [format "%-10s: %04x" $i $sym($i)]
}
}
proc run { {pc 255}} {
variable mem
foreach i {A B C D E Z} {set ::$i 0}
while {$pc>=0} {
incr pc
#puts "$mem($pc)\tA:$::A B:$::B C:$::C D:$::D E:$::E Z:$::Z"
eval $mem($pc)
}
}
#----------------- "machine opcodes" implemented as procs
proc ADD {reg reg2} {set ::Z [incr ::$reg [set ::$reg2]]}
proc ADI {reg value} {set ::Z [incr ::$reg $value]}
proc CALL {name} {[string tolower $name] $::A}
proc DCR {reg} {set ::Z [incr ::$reg -1]}
proc INR {reg} {set ::Z [incr ::$reg]}
proc JMP where {uplevel 1 set pc [expr $where-1]}
proc JNZ where {if $::Z {uplevel 1 JMP $where}}
proc JZ where {if !$::Z {uplevel 1 JMP $where}}
proc MOV {reg adr} {variable mem; set ::$reg $mem($adr)}
proc MVI {reg value} {set ::$reg $value}
}
现在进行测试
asm::asm {
org 100 ; the canonical start address in CP/M
jmp START ; idiomatic: get over the initial variable(s)
DONE: equ 0 ; warm start in CP/M ;-)
MAX: equ 5
INCR: db 2 ; a variable (though we won't vary it)
;; here we go...
START: mvi c,MAX ; set count limit
mvi a,0 ; initial value
mov b,INCR
LOOP: call puts ; for now, fall back to Tcl for I/O
inr a
add a,b ; just to make adding 1 more complicated
dcr c ; counting down..
jnz LOOP ; jump on non-zero to LOOP
jmp DONE ; end of program
end
}
mov b,INCR 部分过于简化了。对于真正的 8080，你必须这样说
LXI H,INCR ; load double registers H+L with the address INCR
MOV B,M ; load byte to register B from the address pointed to in HL
由于伪寄存器 M 也可用于回写，因此不能通过简单地复制值来实现它。相反，你可以使用变量 M 的读写跟踪，使它从 mem($HL) 加载，或者存储到 mem($HL) 中。也许另一个周末可以实现... }
约翰·巴克斯最近迎来了 80 岁生日。他因创建 FORTRAN 和 BNF 语言描述风格而获得了 1977 年的 ACM 图灵奖。在他的图灵奖演讲中，
编程可以从冯·诺依曼风格中解放出来吗？一种函数式风格及其程序代数。(Comm. ACM 21.8, Aug. 1978, 613-641)
他为函数式编程开发了一个惊人的框架，从理论基础到实现提示，例如安装、用户权限和系统自保护。简而言之，他的 FP 系统包含以下部分：
- 一组对象 O（原子或序列）
- 一组函数 F，这些函数将对象映射到对象 (
f : O |-> O) - 一个运算符，应用程序（大致相当于 eval）
- 一组函数形式 FF，用于组合函数或对象以在 F 中形成新的函数
- 一组定义 D，这些定义将名称映射到 F 中的函数
我还没有完全消化它，但像往常一样，有趣的阅读会促使我进行 Tcl 实验，尤其是在周末。我从巴克斯的第一个函数式程序示例开始，
Def Innerproduct = (Insert +) o (ApplyToAll x) o Transpose
并且想要将其变为现实——稍微调整到 Tcl 风格，特别是用波兰前缀风格替换中缀运算符“o”
Def Innerproduct = {o {Insert +} {ApplyToAll *} Transpose}
与过程或 lambda 表达式不同，更像 APL 或 RPN，这个定义不需要变量——它（从右到左）声明了对输入的操作；每个步骤的结果是下一个步骤的输入（在其左侧）。在 RPN 语言中，这个示例可能看起来像这样
/Innerproduct {Transpose * swap ApplyToAll + swap Insert} def
它的优点是执行过程是从左到右进行的，但需要一些堆栈意识（以及一些交换操作来调整堆栈 ;-）
在实现 Def 时，我选择了一条简单的路径，只是创建了一个过程来添加一个参数，并将其留给“函数式”来做正确的事情（使用了一些引号 ;-）}
proc Def {name = functional} {
proc $name x "\[$functional\] \$x"
}
对于函数组合，例如，对于两个函数 f 和 g，
[{o f g} $x] == [f [g $x]]
同样创建一个过程来完成括号嵌套
proc o args {
set body return
foreach f $args {append body " \[$f"}
set name [info level 0]
proc $name x "$body \$x [string repeat \] [llength $args]]"
set name
}
为什么巴克斯在输入上使用 Transpose，一开始对我来说并不清楚，但他（就像我们 Tcl 程序员一样）将矩阵表示为行列表，这些行又是列表（也称为向量），后来我明白了其中的道理。这段用于转置矩阵的代码利用了变量名称可以是任何字符串的事实，包括那些看起来像整数的字符串，因此列内容被收集到名为 0 1 2 ... 的变量中，最后变成结果列表
proc Transpose matrix {
set cols [iota [llength [lindex $matrix 0]]]
foreach row $matrix {
foreach element $row col $cols {
lappend $col $element
}
}
set res {}
foreach col $cols {lappend res [set $col]}
set res
}
一个整数范围生成器生成变量名称，例如 iota 3 => {0 1 2}
proc iota n {
set res {}
for {set i 0} {$i<$n} {incr i} {lappend res $i}
set res
}
#-- This "functional form" is mostly called map in more recent FP:
proc ApplyToAll {f list} {
set res {}
foreach element $list {lappend res [$f $element]}
set res
}
...而 Insert 应该更广为人知的是 fold，我想。我这个过于简单的实现假设运算符是 expr 理解的运算符
proc Insert {op arguments} {expr [join $arguments $op]}
#-- Prefix multiplication comes as a special case of this:
interp alias {} * {} Insert *
#-- Now to try out the whole thing:
Def Innerproduct = {o {Insert +} {ApplyToAll *} Transpose}
puts [Innerproduct {{1 2 3} {6 5 4}}]
它返回 28，正如巴克斯博士要求的那样 (= 1*6 + 2*5 + 3*4)。啊，周末 Tcl 编程的乐趣...——并迟到的，生日快乐，约翰！:)
另一个示例，是我自己这次编写的，计算列表的平均值。为此，我们需要实现构造运算符，它有点像反向映射——当将一个函数映射到一个输入序列上时，会生成一个包含该函数应用于每个输入的输出的输出序列，而巴克斯的构造将一个函数序列映射到一个输入上，以生成每个函数对该输入的结果序列，例如
[f,g](x) == <f(x),g(x)>
当然，我不能使用圆周括号作为运算符名称，所以我们将其称为 constr
proc constr args {
set functions [lrange $args 0 end-1]
set x [lindex $args end]
set res {}
foreach f $functions {lappend res [eval $f [list $x]]}
set res
}
#-- Testing:
Def mean = {o {Insert /} {constr {Insert +} llength}}
puts [mean {1 2 3 4 5}]
它正确地返回 3。但是，由于发生了整数除法，最好改为
proc double x {expr {double($x)}}
Def mean = {o {Insert /} {constr {Insert +} dlength}}
Def dlength = {o double llength}
puts [mean {1 2 3 4}]
这样会得到正确的结果 2.5。但是，dlength 的辅助定义不能内联到 mean 的定义中——因此这需要更多工作... 但是这个版本，先映射 double，可以正常工作
Def mean = {o {Insert /} {constr {Insert +} llength} {ApplyToAll double}}
再做一个实验，只是为了感受一下
Def hypot = {o sqrt {Insert +} {ApplyToAll square}}
Def square = {o {Insert *} {constr id id}}
proc sqrt x {expr {sqrt($x)}}
proc id x {set x}
puts [hypot {3 4}]
它会得到 5.0。与 RPN 语言相比，hypot 会是
/hypot {dup * swap dup * + sqrt} def
它更短更简单，但更直接地干预堆栈。
一个重要的函数形式是条件，它在巴克斯的代码中看起来像这样
p1 -> f; p2 -> g; h
意思是，翻译成 Tcl，
if {[p1 $x]} then {f $x} elseif {[p2 $x]} then {g $x} else {h $x}
让我们试试这个，重写成波兰风格
cond p1 f p2 g h
proc cond args {
set body ""
foreach {condition function} [lrange $args 0 end-1] {
append body "if {\[$condition \$x\]} {$function \$x} else"
}
append body " {[lindex $args end] \$x}"
set name [info level 0]
proc $name x $body
set name
}
#-- Testing, with K in another role as Konstant function :)
Def abs = {cond {> 0} -- id}
proc > {a b} {expr {$a>$b}}
proc < {a b} {expr {$a<$b}}
proc -- x {expr -$x}
puts [abs -42],[abs 0],[abs 42]
Def sgn = {cond {< 0} {K 1} {> 0} {K -1} {K 0}}
proc K {a b} {set a}
puts [sgn 42]/[sgn 0]/[sgn -42]
#--Another famous toy example, reading a file's contents:
Def readfile = {o 1 {constr read close} open}
#--where Backus' selector (named just as integer) is here:
proc 1 x {lindex $x 0}
假设你想要为你附近的一位小学生制作一个乘法表。在几行 Tcl 代码中就可以轻松实现
proc multable {rows cols} {
set res ""
for {set i 1} {$i <= $rows} {incr i} {
for {set j 1} {$j <= $cols} {incr j} {
append res [format %4d [expr {$i*$j}]]
}
append res \n
}
set res
}
这段代码不会直接输出结果，而是将其作为字符串返回——你可能想要用它做其他事情，例如将它保存到文件中以便打印。测试
% multable 3 10
1 2 3 4 5 6 7 8 9 10
2 4 6 8 10 12 14 16 18 20
3 6 9 12 15 18 21 24 27 30
或者直接从 wish 中打印结果
catch {console show}
puts "[multable 3 10]"
以下是使用函数式编程的另一种方法
proc multable2 {rows cols} {
formatMatrix %4d [outProd * [iota 1 $rows] [iota 1 $cols]]
}
主体简洁明了，但包含所有不熟悉的命令。然而，它们比上面的 multable 过程更易于重用。第一个将矩阵（一个列表列表到 Tcl）格式化为带换行符和对齐列的字符串，以便更好地显示
proc formatMatrix {fm matrix} {
join [lmap row $matrix {join [lmap i $row {format $fm $i}] ""}] \n
}
同样简洁，略带神秘，就像“外积”例程一样，它接受一个函数 f 和两个向量，并生成一个矩阵，其中 f 应用于 a 和 b 的每一对——在 APL 中，他们为此任务专门使用复合运算符，在本例中为“°.x”
proc outProd {f a b} {
lmap i $a {lmap j $b {$f $i $j}}
}
再次，lmap（收集 foreach）非常突出，因此它在所有简单性中显而易见
proc lmap {_var list body} {
upvar 1 $_var var
set res {}
foreach var $list {lappend res [uplevel 1 $body]}
set res
}
#-- We need multiplication from expr exposed as a function:
proc * {a b} {expr {$a * $b}}
#-- And finally, iota is an integer range generator:
proc iota {from to} {
set res {}
while {$from <= $to} {lappend res $from; incr from}
set res
}
有了这些部分，我们可以看到 multable2 按预期工作
% multable2 3 10
1 2 3 4 5 6 7 8 9 10
2 4 6 8 10 12 14 16 18 20
3 6 9 12 15 18 21 24 27 30
那么为什么要编写六个过程，而一个过程就可以完成这项工作呢？从某种程度上来说，这是一个风格和品味问题——multable 有 10 行代码，并且只依赖于 Tcl，这很好；multable2 清晰地描述了它的功能，并且构建在几个高度可重用的其他过程中。
如果你需要一个单位矩阵（主对角线为 1，其余为 0），只需调用 outProd 使用不同的函数（相等，==）即可
% outProd == [iota 1 5] [iota 1 5]
{1 0 0 0 0} {0 1 0 0 0} {0 0 1 0 0} {0 0 0 1 0} {0 0 0 0 1}
这只需要将 expr 的相等性也暴露出来
proc == {a b} {expr {$a == $b}}
函数式编程的魅力之一是，你可以用一种简单明了的方式（通常是一行代码）完成这项工作，同时使用像 lmap 和 iota 这样的可重用构建块。而 formatMatrix 和 outProd 非常通用，你可以将它们包含在某个库中，而生成乘法表的任务可能很长时间都不会再出现了... }
Tcl 严格遵循波兰表示法，其中运算符或函数始终位于其参数之前。但是，很容易构建一个用于反波兰表示法（RPN）语言（如 Forth、Postscript 或 Joy）的解释器，并对其进行实验。
“运行时引擎”称为“r”（不要与 R 语言混淆），它归结为对每个单词进行的三路开关，只有 11 行代码
- “tcl”将堆栈的顶层评估为 Tcl 脚本
::C数组中的已知单词在“r”中递归地进行评估- 其他单词只会被压入堆栈
Joy 的丰富类型引号（[list]、{set}、"string"、'char'）与 Tcl 解析器冲突，因此“r”中的列表如果其长度不为 1，则使用 {花括号} 括起来，如果为 1，则使用 (圆括号) 括起来——但现在不会评估该词。这对我来说比 Postscript 中的 /斜杠更好看。
由于一切都是字符串，而对于 Tcl，“a”与 {a} 与 a 相同，因此 Joy 的多态性必须明确。我添加了字符和整数之间的转换器，以及字符串和列表之间的转换器（参见下面的字典）。对于 Joy 的集合，我还没有费心去处理——它们被限制在 0..31 的域中，可能是使用 32 位字中的位来实现的。
这离 Joy 还很远，它主要是由曼弗雷德·冯·通的论文中的示例触发的，因此我半开玩笑地仍然称它为“Pocket Joy”——它对我来说，终于在 iPaq 上实现了... 最后的测试套件应该给出许多关于在“r”中可以做什么的示例。}
proc r args {
foreach a $args {
dputs [info level]:$::S//$a
if {$a eq "tcl"} {
eval [pop]
} elseif [info exists ::C($a)] {
eval r $::C($a)
} else {push [string trim $a ()]}
}
set ::S
}
# 就这样。堆栈（列表）和命令数组是全局变量
set S {}; unset C
#-- 一个微小的可切换调试器
proc d+ {} {proc dputs s {puts $s}}
proc d- {} {proc dputs args {}}
d- ;#-- initially, debug mode off
定义采用 Forth 风格——以“:”作为初始单词，因为它们看起来比 Joy 的 DEFINE n == args; 更紧凑
proc : {n args} {set ::C($n) $args}
expr 功能被暴露给二元运算符和一元函数
proc 2op op {
set t [pop]
push [expr {[pop]} $op {$t}]
}
foreach op {+ - * / > >= != <= <} {: $op [list 2op $op] tcl}
: = {2op ==} tcl
proc 1f f {push [expr $f\([pop])]}
foreach f {abs double exp int sqrt sin cos acos tan} {: $f [list 1f $f] tcl}
interp alias {} pn {} puts -nonewline
#----- The dictionary has all one-liners:
: . {pn "[pop] "} tcl
: .s {puts $::S} tcl
: ' {push [scan [pop] %c]} tcl ;# char -> int
: ` {push [format %c [pop]]} tcl ;# int -> char
: and {2op &&} tcl
: at 1 - swap {push [lindex [pop] [pop]]} tcl
: c {set ::S {}} tcl ;# clear stack
: choice {choice [pop] [pop] [pop]} tcl
: cleave {cleave [pop] [pop] [pop]} tcl
: cons {push [linsert [pop] 0 [pop]]} tcl
: dup {push [set x [pop]] $x} tcl
: dupd {push [lindex $::S end-1]} tcl
: emit {pn [format %c [pop]]} tcl
: even odd not
: explode {push [split [pop] ""]} tcl ;# string -> char list
: fact 1 (*) primrec
: filter split swap pop
: first {push [lindex [pop] 0]} tcl
: fold {rfold [pop] [pop] [pop]} tcl
: gcd swap {0 >} {swap dupd rem swap gcd} (pop) ifte
: has swap in
: i {eval r [pop]} tcl
: ifte {rifte [pop] [pop] [pop]} tcl
: implode {push [join [pop] ""]} tcl ;# char list -> string
: in {push [lsearch [pop] [pop]]} tcl 0 >=
: map {rmap [pop] [pop]} tcl
: max {push [max [pop] [pop]]} tcl
: min {push [min [pop] [pop]]} tcl
: newstack c
: not {1f !} tcl
: odd 2 rem
: of swap at
: or {2op ||} tcl
: pop (pop) tcl
: pred 1 -
: primrec {primrec [pop] [pop] [pop]} tcl
: product 1 (*) fold
: qsort (lsort) tcl
: qsort1 {lsort -index 0} tcl
: rem {2op %} tcl
: rest {push [lrange [pop] 1 end]} tcl
: reverse {} swap (swons) step
: set {set ::[pop] [pop]} tcl
: $ {push [set ::[pop]]} tcl
: sign {0 >} {0 <} cleave -
: size {push [llength [pop]]} tcl
: split {rsplit [pop] [pop]} tcl
: step {step [pop] [pop]} tcl
: succ 1 +
: sum 0 (+) fold
: swap {push [pop] [pop]} tcl
: swons swap cons
: xor !=
用 Tcl 编写的辅助函数
proc rifte {else then cond} {
eval r dup $cond
eval r [expr {[pop]? $then: $else}]
}
proc choice {z y x} {
push [expr {$x? $y: $z}]
}
proc cleave { g f x} {
eval [list r $x] $f [list $x] $g
}
proc max {x y} {expr {$x>$y?$x:$y}}
proc min {x y} {expr {$x<$y? $x:$y}}
proc rmap {f list} {
set res {}
foreach e $list {
eval [list r $e] $f
lappend res [pop]
}
push $res
}
proc step {f list} {
foreach e $list {eval [list r ($e)] $f}
}
proc rsplit {f list} {
foreach i {0 1} {set $i {}}
foreach e $list {
eval [list r $e] $f
lappend [expr {!![pop]}] $e
}
push $0 $1
}
proc primrec {f init n} {
if {$n>0} {
push $n
while {$n>1} {
eval [list r [incr n -1]] $f
}
} else {push $init}
}
proc rfold {f init list} {
push $init
foreach e $list {eval [list r $e] $f}
}
#------------------ Stack routines
proc push args {
foreach a $args {lappend ::S $a}
}
proc pop {} {
if [llength $::S] {
K [lindex $::S end] \
[set ::S [lrange $::S 0 end-1]]
} else {error "stack underflow"}
}
proc K {a b} {set a}
#------------------------ The test suite:
proc ? {cmd expected} {
catch {uplevel 1 $cmd} res
if {$res ne $expected} {puts "$cmd->$res, not $expected"}
}
? {r 2 3 +} 5
? {r 2 *} 10
? {r c 5 dup *} 25
: sqr dup *
: hypot sqr swap sqr + sqrt
? {r c 3 4 hypot} 5.0
? {r c {1 2 3} {dup *} map} { {1 4 9}}
? {r size} 3
? {r c {2 5 3} 0 (+) fold} 10
? {r c {3 4 5} product} 60
? {r c {2 5 3} 0 {dup * +} fold} 38
? {r c {1 2 3 4} dup sum swap size double /} 2.5
? {r c {1 2 3 4} (sum) {size double} cleave /} 2.5
: if0 {1000 >} {2 /} {3 *} ifte
? {r c 1200 if0} 600
? {r c 600 if0} 1800
? {r c 42 sign} 1
? {r c 0 sign} 0
? {r c -42 sign} -1
? {r c 5 fact} 120
? {r c 1 0 and} 0
? {r c 1 0 or} 1
? {r c 1 0 and not} 1
? {r c 3 {2 1} cons} { {3 2 1}}
? {r c {2 1} 3 swons} { {3 2 1}}
? {r c {1 2 3} first} 1
? {r c {1 2 3} rest} { {2 3}}
? {r c {6 1 5 2 4 3} {3 >} filter} { {6 5 4}}
? {r c 1 2 {+ 20 * 10 4 -} i} {60 6}
? {r c 42 succ} 43
? {r c 42 pred} 41
? {r c {a b c d} 2 at} b
? {r c 2 {a b c d} of} b
? {r c 1 2 pop} 1
? {r c A ' 32 + succ succ `} c
? {r c {a b c d} reverse} { {d c b a}}
? {r c 1 2 dupd} {1 2 1}
? {r c 6 9 gcd} 3
? {r c true yes no choice} yes
? {r c false yes no choice} no
? {r c {1 2 3 4} (odd) split} { {2 4} {1 3}}
? {r c a {a b c} in} 1
? {r c d {a b c} in} 0
? {r c {a b c} b has} 1
? {r c {a b c} e has} 0
? {r c 3 4 max} 4
? {r c 3 4 min} 3
? {r c hello explode reverse implode} olleh
: palindrome dup explode reverse implode =
? {r c hello palindrome} 0
? {r c otto palindrome} 1
#-- reading (varname $) and setting (varname set) global Tcl vars
set tv 42
? {r c (tv) $ 1 + dup (tv) set} 43
? {expr $tv==43} 1
J 编程语言是 APL 的“公认继任者”，其中“每个函数都是一个中缀或前缀运算符”，x?y（二元）或 ?y（一元），对于 ? 来说是任何预定义或用户定义的函数）。
“无名编程”（无名：隐含的；通过必要的内涵表示，但没有直接表达出来）是 J 中可能的风格之一，意味着通过组合函数来编码，而无需引用参数名称。这个想法可能首先在函数式编程 (Backus 1977) 中被提出，如果不是在 Forth 和 Joy 中被提出的话，并且与 lambda 演算相比，它是一种有趣的简化。
例如，以下是一个极其简短的 J 程序，用于计算数字列表的平均值。
mean=.+/%#
让我们逐字节地分析它 :)。
=. is assignment to a local variable ("mean") which can be called
+/%# is the "function body"
+ (dyadic) is addition
/ folds the operator on its left over the list on its right
+/ hence being the sum of a list
% (dyadic) is division, going double on integer arguments when needed
# (monadic) is tally, like Tcl's [llength] resp. [string length]
隐式地存在一个强大的函数组合器，称为“分叉”。当 J 解析三个连续的操作符 gfh 时，其中 f 是二元运算符，g 和 h 是一元运算符，它们将按照以下 Tcl 版本的组合方式进行组合。
proc fork {f g h x} {$f [$g $x] [$h $x]}
换句话说，f 应用于将 g 和 h 应用于单个参数的结果。请注意，+/ 被视为一个操作符，它将“副词”折叠应用于“动词”加法（有人可能将其称为“求和”）。当两个操作数一起出现时，会隐式地使用“钩子”模式，这在 Tcl 中可能写成
proc hook {f g x} {$f $x [$g $x]}
正如 KBK 在 Tcl 聊天室中指出的那样，“钩子”模式对应于 Schönfinkel/Curry 的 S 组合器（参见 Hot Curry 和 Combinator Engine），而“分叉”在那里被称为 S'。
与我以前玩 APL 的时候不同，这次我的目标不是解析和模拟 J 在 Tcl 中 - 我预料到这是一项艰苦的工作，回报可疑，毕竟这是一个周末的娱乐项目。我更希望探索其中的一些概念，以及如何在 Tcl 中使用它们，以便用更冗长的语言，我可以编写（并调用）
Def mean = fork /. sum llength
遵循 Backus 的 FP 语言，使用“Def”命令。所以，让我们把这些部分组合起来。我的“Def”创建了一个 interp 别名，这是一种简单有效的方式，可以将部分脚本（定义，这里）与一个或多个参数组合在一起，也称为“柯里化”。
proc Def {name = args} {eval [list interp alias {} $name {}] $args}
第二个参数“=”仅为了美观，显然从未使用过。
及早测试并经常测试是一种美德，文档也是如此 - 为了使以下代码片段更清晰，我调整了我的小型测试器，以获得更好的外观，以便源代码中的测试用例也可以作为可读性强的示例 - 它们看起来像注释，但实际上是代码！可爱的名称“e.g.”的启发来自于在 J 中，“NB.”被用作注释指示符，两者都是众所周知的拉丁缩写。
proc e.g. {cmd -> expected} {
catch {uplevel 1 $cmd} res
if {$res != $expected} {puts "$cmd -> $res, not $expected"}
}
同样，“->”参数也仅仅是为了美观 - 但至少在我看来，它感觉更好。请参阅即将出现的示例。
对于递归函数和其他算术运算，func 通过在主体中接受 expr 语言，可以使阅读更加方便。
proc func {name argl body} {proc $name $argl [list expr $body]}
我们将使用它将 expr 的中缀运算符转换为二元函数，再加上“斜杠点”运算符，它使得除法始终返回一个实数，因此是点。
foreach op {+ — * /} {func $op {a b} "\$a $op \$b"}
e.g. {+ 1 2} -> 3
e.g. {/ 1 2} -> 0 ;# integer division
func /. {a b} {double($a)/$b}
e.g. {/. 1 2} -> 0.5 ;# "real" division
#-- Two abbreviations for frequently used list operations:
proc head list {lindex $list 0}
e.g. {head {a b c}} -> a
proc tail list {lrange $list 1 end}
e.g. {tail {a b c}} -> {b c}
对于“折叠”，这次我设计了一个递归版本。
func fold {neutral op list} {
$list eq [] ? $neutral
: [$op [head $list] [fold $neutral $op [tail $list]]]
}
e.g. {fold 0 + {1 2 3 4}} -> 10
#-- A "Def" alias does the same job:
Def sum = fold 0 +
e.g. {sum {1 2 3 4}} -> 10
#-- So let's try to implement "mean" in tacit Tcl!
Def mean = fork /. sum llength
e.g. {mean {1 2 3 40}} -> 11.5
足够简洁（有人可能选择了更花哨的名称，比如 +/ 用于“求和”和 # 作为 llength 的别名），但原则上它等同于 J 版本，并且没有命名单个参数。此外，llength 的使用表明，任何旧的 Tcl 命令都可以在这里使用，不仅仅是我正在创建的这个人工的简洁世界...。
在下一步中，我想重新实现“中位数”函数，该函数对于已排序的列表，如果其长度为奇数，则返回中心元素；如果其长度为偶数，则返回与（虚拟）中心相邻的两个元素的平均值。在 J 中，它看起来像这样。
median=.(mean@:\{~medind@#)@sortu
medind=.((<.,>.)@half) ` half @.(2&|)
half=.-:@<: NB. halve one less than rt. argument
sortu=.\{~/: NB. sort upwards
这或许可以更好地解释为什么我不想用 J 编写代码 :^) J 使用了 ASCII 字符，将 APL 中各种奇怪的字符运算符“动物园”化了，但代价是也将大括号和方括号用作运算符，而不考虑平衡，并用点和冒号对其进行了扩展，例如
- monadic: negate; dyadic: minus
-. monadic: not
-: monadic: halve
J 代码有时确实看起来像是键盘工厂的意外事故... 我不会详细介绍以上代码的所有细节，只是其中一些。
@ ("atop") is strong linkage, sort of functional composition
<. (monadic) is floor()
>. (monadic) is ceil()
(<.,>.) 正在构建一个列表，其中包含其单个参数的向下取整和向上取整，这里逗号是连接运算符，类似于 Backus 的“构造”或 Joy 的 cleave。模式
a ` b @. c
是 J 中的一种条件表达式，在 Tcl 中可以写成
if {[$c $x]} {$a $x} else {$b $x}
但我对中位数算法的变体不需要条件表达式 - 对于奇数长度的列表，它只是两次使用中心索引，这对于“平均值”来说是幂等的，即使稍微慢一些。
J 的“从”运算符 { 从列表中获取零个或多个元素，可能重复。为了移植它，lmap 是一个很好的助手，即使它不是严格的函数式。
proc lmap {_v list body} {
upvar 1 $_v v
set res {}
foreach v $list {lappend res [uplevel 1 $body]}
set res
}
e.g. {lmap i {1 2 3 4} {* $i $i}} -> {1 4 9 16}
#-- So here's my 'from':
proc from {indices list} {lmap i $indices {lindex $list $i}}
e.g. {from {1 0 0 2} {a b c}} -> {b a a c}
我们进一步从 expr 中借用了一些内容。
func ceil x {int(ceil($x))}
func floor x {int(floor($x))}
e.g. {ceil 1.5} -> 2
e.g. {floor 1.5} -> 1
e.g. {fork list floor ceil 1.5} -> {1 2}
我们将需要函数组合，这里有一个递归豪华版本，它可以接受零个或多个函数，因此命名为 o*。
func o* {functions x} {
$functions eq []? $x
: [[head $functions] [o* [tail $functions] $x]]
}
e.g. {o* {} hello,world} -> hello,world
显然，身份可以写成
proc I x {set x}
是可变函数组合的中性元素，当不使用任何函数调用它时。
如果像“分叉”这样的复合函数是 o* 的参数，我们最好让 unknown 知道我们希望自动扩展第一个词。
proc know what {proc unknown args $what\n[info body unknown]}
know {
set cmd [head $args]
if {[llength $cmd]>1} {return [eval $cmd [tail $args]]}
}
此外，我们还需要一个数值排序，它对整数和实数都有效（“Def”适用于各种别名，而不仅仅是函数的组合）。
Def sort = lsort -real
e.g. {sort {2.718 10 1}} -> {1 2.718 10}
e.g. {lsort {2.718 10 1}} -> {1 10 2.718} ;# lexicographic
#-- And now for the median test:
Def median = o* {mean {fork from center sort}}
Def center = o* {{fork list floor ceil} {* 0.5} -1 llength}
func -1 x {$x — 1}
e.g. {-1 5} -> 4 ;# predecessor function, when for integers
#-- Trying the whole thing out:
e.g. {median {1 2 3 4 5}} -> 3
e.g. {median {1 2 3 4}} -> 2.5
由于这个文件被隐式地引入，我很有信心我已经达到了这个周末的目标 - 即使我的中位数与 J 版本完全不同：它像 Tcl 一样“冗长”。但不可否认，仍然很小的挑战以真正的函数级风格得到了解决，涉及中位数、中心和平均值的定义 - 没有留下任何变量。而这是一种，并非最糟糕的，Tcl 进行简洁编程的方式...。
向量算术
[edit | edit source]APL 和 J（参见简洁编程）具有以下特性：算术运算可以针对向量和数组以及标量数字进行，形式如下（对于任何运算符 @）：
- 标量 @ 标量 → 标量（就像 expr 所做的那样）
- 向量 @ 标量 → 向量
- 标量 @ 向量 → 向量
- 向量 @ 向量 → 向量（所有维度相同，逐元素）
以下是如何在 Tcl 中进行此操作的实验。首先，lmap 是一个收集型的 foreach - 它将指定的代码体映射到一个列表上。
proc lmap {_var list body} {
upvar 1 $_var var
set res {}
foreach var $list {lappend res [uplevel 1 $body]}
set res
}
#-- We need basic scalar operators from expr factored out:
foreach op {+ - * / % ==} {proc $op {a b} "expr {\$a $op \$b}"}
以下通用包装器接受一个二元运算符（可以是任何合适的函数）和两个参数，它们可以是标量、向量，甚至是矩阵（列表的列表），因为它会根据需要递归调用。请注意，由于我上面的 lmap 只接受一个列表，因此必须用 foreach 明确地处理两个列表的情况。
proc vec {op a b} {
if {[llength $a] == 1 && [llength $b] == 1} {
$op $a $b
} elseif {[llength $a]==1} {
lmap i $b {vec $op $a $i}
} elseif {[llength $b]==1} {
lmap i $a {vec $op $i $b}
} elseif {[llength $a] == [llength $b]} {
set res {}
foreach i $a j $b {lappend res [vec $op $i $j]}
set res
} else {error "length mismatch [llength $a] != [llength $b]"}
}
使用以下最小“框架”进行测试。
proc e.g. {cmd -> expected} {
catch $cmd res
if {$res ne $expected} {puts "$cmd -> $res, not $expected"}
}
标量 + 标量
e.g. {vec + 1 2} -> 3
标量 + 向量
e.g. {vec + 1 {1 2 3 4}} -> {2 3 4 5}
向量 / 标量
e.g. {vec / {1 2 3 4} 2.} -> {0.5 1.0 1.5 2.0}
向量 + 向量
e.g. {vec + {1 2 3} {4 5 6}} -> {5 7 9}
矩阵 * 标量
e.g. {vec * {{1 2 3} {4 5 6}} 2} -> {{2 4 6} {8 10 12}}
将一个 3x3 矩阵乘以另一个矩阵。
e.g. {vec * {{1 2 3} {4 5 6} {7 8 9}} {{1 0 0} {0 1 0} {0 0 1}}} -> \
{{1 0 0} {0 5 0} {0 0 9}}
两个向量的点积是一个标量。鉴于求和函数，这一点也很容易得到。
proc sum list {expr [join $list +]+0}
sum [vec * {1 2} {3 4}]
应该得到 11（= (1*3)+(2*4)）。
以下是一个小的应用：一个向量分解器，它为给定的整数生成除数列表。为此，我们再次需要一个从 1 开始的整数范围生成器。
proc iota1 x {
set res {}
for {set i 1} {$i<=$x} {incr i} {lappend res $i}
set res
}
e.g. {iota1 7} -> {1 2 3 4 5 6 7}
#-- We can compute the modulo of a number by its index vector:
e.g. {vec % 7 [iota1 7]} -> {0 1 1 3 2 1 0}
#-- and turn all elements where the remainder is 0 to 1, else 0:
e.g. {vec == 0 [vec % 7 [iota1 7]]} -> {1 0 0 0 0 0 1}
此时，如果最新向量的总和为 2，则该数字为质数。但是，我们也可以将 1 与来自索引向量的除数相乘。
e.g. {vec * [iota1 7] [vec == 0 [vec % 7 [iota1 7]]]} -> {1 0 0 0 0 0 7}
#-- Hence, 7 is only divisible by 1 and itself, hence it is a prime.
e.g. {vec * [iota1 6] [vec == 0 [vec % 6 [iota1 6]]]} -> {1 2 3 0 0 6}
因此，6 可以被 2 和 3 整除；(lrange $divisors 1 end-1) 中的非零元素给出了“真”除数。并且三次嵌套调用 vec 就足以生成除数列表 :)。
为了比较，以下是 J 中的写法。
iota1=.>:@i.
iota1 7
1 2 3 4 5 6 7
f3=.iota1*(0&=@|~iota1)
f3 7
1 0 0 0 0 0 7
f3 6
1 2 3 0 0 6
整数作为布尔函数
[edit | edit source]布尔函数，其中参数和结果的域为 {true, false} 或 {1, 0}，正如 expr 所具有的那样，运算符例如为 {AND, OR, NOT}，分别为 {&&, ||, !}，可以用它们的真值表来表示，例如对于 {$a && $b}，看起来像这样。
a b a&&b
0 0 0
1 0 0
0 1 0
1 1 1
由于除了最后一列之外，所有列都只是列举了参数的所有可能组合，第一列是最低有效位，因此 a&&b 的完整表示是最后一列，它是一个 0 和 1 的序列，可以被视为二进制整数，从下向上读取：1 0 0 0 == 8。所以 8 是 a&&b 的相关整数，但不仅是它 - 我们会为 !(!a || !b) 获取相同的整数，但再次，这些函数是等效的。
为了在 Tcl 中尝试这一点，这里有一个真值表生成器，我从一个小型证明引擎中借用而来，但没有使用那里的 lsort - 传递的用例顺序在第一个位是最低有效位时最有意义：}
proc truthtable n {
# make a list of 2**n lists, each with n truth values 0|1
set res {}
for {set i 0} {$i < (1<<$n)} {incr i} {
set case {}
for {set j 0} {$j <$n} {incr j } {
lappend case [expr {($i & (1<<$j)) != 0}]
}
lappend res $case
}
set res
}
现在我们可以编写 n(f)，它在给定一个或多个参数的布尔函数时，返回其特征数字，方法是对真值表中的所有情况进行迭代，并在适当的位置设置一位。
proc n(f) expression {
set vars [lsort -unique [regsub -all {[^a-zA-Z]} $expression " "]]
set res 0
set bit 1
foreach case [truthtable [llength $vars]] {
foreach $vars $case break
set res [expr $res | ((($expression)!=0)*$bit)]
incr bit $bit ;#-- <<1, or *2
}
set res
}
实验
% n(f) {$a && !$a} ;#-- contradiction is always false
0
% n(f) {$a || !$a} ;#-- tautology is always true
3
% n(f) {$a} ;#-- identity is boring
2
% n(f) {!$a} ;#-- NOT
1
% n(f) {$a && $b} ;#-- AND
8
% n(f) {$a || $b} ;#-- OR
14
% n(f) {!($a && $b)} ;#-- de Morgan's laws:
7
% n(f) {!$a || !$b} ;#-- same value = equivalent
7
因此，特征整数与函数的哥德尔数不同，哥德尔数将对那里使用的运算符的结构进行编码。
% n(f) {!($a || $b)} ;#-- interesting: same as unary NOT
1
% n(f) {!$a && !$b}
1
更大胆一点，让我们尝试一下分配律。
% n(f) {$p && ($q || $r)}
168
% n(f) {($p && $q) || ($p && $r)}
168
更大胆：如果我们假设等价性会怎样？
% n(f) {(($p && $q) || ($p && $r)) == ($p && ($q || $r))}
255
没有证明，我只是声称，任何具有特征整数 2^(2^n) - 1 的 n 个参数的函数都是重言式（或真命题 - 所有位都是 1）。相反，假设不等价性在所有情况下都被证明是错误的，因此是一个矛盾。
% n(f) {(($p && $q) || ($p && $r)) != ($p && ($q || $r))}
0
所以，我们再次拥有一个小型证明引擎，而且比上次更简单。
相反，我们可以通过数字调用布尔函数并提供一个或多个参数 - 如果我们提供的参数比函数可以理解的更多，非假值的额外参数会导致恒假，因为整数可以被视为零扩展。
proc f(n) {n args} {
set row 0
set bit 1
foreach arg $args {
set row [expr {$row | ($arg != 0)*$bit}]
incr bit $bit
}
expr !!($n &(1<<$row))
}
再次尝试，从 OR（14）开始。
% f(n) 14 0 0
0
% f(n) 14 0 1
1
% f(n) 14 1 0
1
% f(n) 14 1 1
1
因此，f(n) 14 的行为确实像 OR 函数 - 毫不奇怪，因为它的真值表（四次调用的结果），从下向上读，是 1110，十进制为 14 (8 + 4 + 2)。另一个测试，不等式。
% n(f) {$a != $b}
6
% f(n) 6 0 0
0
% f(n) 6 0 1
1
% f(n) 6 1 0
1
% f(n) 6 1 1
0
尝试使用超过两个参数调用 14 (OR)
% f(n) 14 0 0 1
0
% f(n) 14 0 1 1
0
53 % f(n) 14 1 1 1
0
常量 0 结果是一个微妙的迹象，表明我们做错了什么 :)
蕴涵（如果 a 则 b，a -> b）可以在表达式中表示为 $a <= $b - 请注意，“箭头”似乎指向了错误的方向。让我们尝试证明“巴罗门式推理” - “如果 a 蕴涵 b，并且 b 蕴涵 c，则 a 蕴涵 c”
% n(f) {(($a <= $b) && ($b <= $c)) <= ($a <= $c)}
255
使用不太抽象的变量名称，也可以写成
% n(f) {(($Socrates <= $human) && ($human <= $mortal)) <= ($Socrates <= $mortal)}
255
但很久以前，苏格拉底之死就验证了这一点 :^)
要扩展 Tcl，即让它理解并执行以前会导致错误的操作，最简单的方法是编写一个过程。但是，任何过程都必须符合 Tcl 的基本语法调用：第一个词是命令名称，然后是空格分隔的参数。更深层的更改可以通过 unknown 命令实现，如果命令名称未知，就会调用该命令，并且在标准版本中会尝试调用可执行文件，自动加载脚本或执行其他有用的操作（参见文件 init.tcl）。可以编辑该文件（不推荐），或者将 unknown 重命名为其他内容并提供自己的 unknown 处理程序，如果失败，则会继续使用原始过程，如 Radical 语言修改中所示。
这里有一个更简单的方法，可以“就地”且逐步扩展 unknown：我们让 unknown “知道”它在什么条件下应该采取什么行动。know 命令以一个条件调用，该条件在传递给 expr 时应该产生一个整数，以及一个主体，如果 cond 的结果为非零，则将执行该主体，如果未以显式 return 终止，则返回最后一个结果。在 cond 和 body 中，可以使用 args 变量，该变量保存 unknown 被调用时出现的问题命令。
proc know what {
if ![info complete $what] {error "incomplete command(s) $what"}
proc unknown args $what\n[info body unknown]
} ;# RS
扩展代码 what 被附加到之前的 unknown 主体。这意味着对 know 的后续调用会堆叠起来，最后一个条件首先尝试，因此，如果你有几个在相同输入上触发的条件，让他们从通用到特定“已知”。
这里有一个小调试助手，用于找出为什么“知道”条件没有触发
proc know? {} {puts [string range [info body unknown] 0 511]}
现在测试这少量代码允许我们做哪些新魔法。这个简单的例子在“命令”可被 expr 消化的情况下调用 expr
% know {if {![catch {expr $args} res]} {return $res}}
% 3+4
7
想象一下，如果 Tcl 的制造商没有提供 if 命令。所有其他功能都将存在。为了更多地进行面向函数的编程，我遇到了这个问题，并且很快就会证明，它可以在纯 Tcl 中轻松解决。
我们仍然拥有来自带有比较运算符的 expr 的规范真值 0 和 1。我在阅读的论文中的想法是将它们用作非常简单的函数的名称
proc 0 {then else} {uplevel 1 $else}
proc 1 {then else} {uplevel 1 $then} ;# the famous K combinator
赞美人类 Tcl 的 11 条规则，这已经是粗糙的，但足够的重新实现
set x 42
[expr $x<100] {puts Yes} {puts No}
方括号中的 expr 命令首先计算，返回比较结果的 0 或 1。该结果（0 或 1）将替换为该命令的第一个词。其他词（参数）不会被替换，因为它们用大括号括起来，因此 0 或 1 会被调用并完成其简单的任务。（我使用 uplevel 而不是 eval 以将所有副作用保留在调用者的范围内）。正式来说，方括号内的调用所发生的事情是它经过了“应用顺序”计算（即立即执行），而大括号内的命令则等待“正常顺序”计算（即在需要时执行，可能永远不会 - 需要通过 eval/upvar 或类似命令表示）。
虽然乍一看很巧妙，但我们实际上要键入更多内容。作为第二步，我们创建了 If 命令，它包装了 expr 调用
proc If {cond then else} {
[uplevel 1 [list expr ($cond)!=0]] {uplevel 1 $then} {uplevel 1 $else}
}
If {$x>40} {puts Indeed} {puts "Not at all"}
这再次通过了临时测试，并添加了这样一个功能，即任何非零值都算作真并返回 1 - 如果我们忽略 if 的其他语法选项，特别是 elseif 链。但是，这不是一个根本问题 - 考虑一下
if A then B elseif C then D else E
可以改写为
if A then B else {if C then D else E}
因此，双向 If 几乎和真实 If 一样强大，只是多了几个大括号和冗余关键字（then、else）。
幸运的是，我们在 Tcl 中有一个 if（它在字节码编译中肯定做得更好），但在闲暇的夜晚，并不是微秒数很重要（至少对我来说） - 相反，是阅读最令人惊讶（或最基本）的想法，并展示 Tcl 如何轻松地将它们变为现实...
无所畏惧（只要一切都是字符串），在 Tcl 聊天室中的讨论促使我尝试以下操作：让计算机编写（发现）自己的软件，只给定输入和输出的规范。在真正的蛮力下，最多可自动编写 50 万个程序，并对（其中合适的子集）进行测试，以找到通过测试的程序。
为了使事情变得更容易，这种类型的“软件”采用了一种非常简单的 RPN 语言，类似于，但远小于 Playing bytecode 中介绍的语言，每个操作都是一个字节（ASCII 字符）宽，因此我们甚至不需要空格。参数被压入堆栈，而“软件”的结果（最终的堆栈）被返回。例如，在
ebc ++ 1 2 3
脚本“++”的执行应该将它的三个参数求和（1+(2+3)），并返回 6。
以下是“字节码引擎”（ebc：执行字节码），它从全局数组 cmd 中检索字节码的实现
proc ebc {code argl} {
set ::S $argl
foreach opcode [split $code ""] {
eval $::cmd($opcode)
}
set ::S
}
现在让我们填充字节码集合。所有已定义字节码的集合将是这种小型 RPN 语言的字母表。有趣的是，这种语言的语法真正最小 - 唯一的规则是：由任意数量字节码组成的每个脚本（“词”）都是格式良好的。它只是需要检查它是否符合我们的要求。
二元表达式运算符可以通用地处理
foreach op {+ - * /} {
set cmd($op) [string map "@ $op" {swap; push [expr {[pop] @ [pop]}]}]
}
#-- And here's some more hand-crafted bytecode implementations
set cmd(d) {push [lindex $::S end]} ;# dup
set cmd(q) {push [expr {sqrt([pop])}]}
set cmd(^) {push [swap; expr {pow([pop],[pop])}]}
set cmd(s) swap
#-- The stack routines imply a global stack ::S, for simplicity
interp alias {} push {} lappend ::S
proc pop {} {K [lindex $::S end] [set ::S [lrange $::S 0 end-1]]}
proc K {a b} {set a}
proc swap {} {push [pop] [pop]}
我没有事先枚举所有可能的字节码组合（它会随着字母表和词长的增加呈指数增长），而是使用 Mapping words to integers 中的这段代码来遍历它们的序列，由一个递增的整数唯一地索引。这有点像对应代码的哥德尔数。请注意，使用这种映射，所有有效的程序（字节码序列）都对应一个唯一的非负整数，而更长的程序具有更高的关联整数
proc int2word {int alphabet} {
set word ""
set la [llength $alphabet]
while {$int > 0} {
incr int -1
set word [lindex $alphabet [expr {$int % $la}]]$word
set int [expr {$int/$la}]
}
set word
}
现在开始发现！toplevel 过程接受一对输入和预期输出的列表。它以蛮力尝试高达指定最大哥德尔数的所有程序，并返回第一个符合所有测试的程序
proc discover0 args {
set alphabet [lsort [array names ::cmd]]
for {set i 1} {$i<10000} {incr i} {
set code [int2word $i $alphabet]
set failed 0
foreach {inputs output} $args {
catch {ebc $code $inputs} res
if {$res != $output} {incr failed; break}
}
if {!$failed} {return $code}
}
}
但是，遍历许多词语仍然相当缓慢，至少在我的 200 MHz 机器上是这样，并且尝试了大量无用的“程序”。例如，如果测试有两个输入并希望一个输出，那么堆栈余额为 -1（输出比输入少一个）。这可以通过二元运算符 +-*/ 中的一个提供。但是程序“dd”（它只是将堆栈顶部的元素复制两次）的堆栈余额为 +2，因此它永远无法通过示例测试。所以，在早上遛狗的时候，我想出了这个策略
- 测量每个字节码的堆栈余额
- 遍历大量可能的程序，计算它们的堆栈余额
- 将它们进行分区（放入不同的子集）
- 仅对具有匹配堆栈余额的程序执行每个“发现”调用
这里就是这个版本。单字节码被执行，只是为了测量它们对堆栈的影响。更长程序的余额可以通过简单地添加其各个字节码的余额来计算
proc bc'stack'balance bc {
set stack {1 2} ;# a bytecode will consume at most two elements
expr {[llength [ebc $bc $stack]]-[llength $stack]}
}
proc stack'balance code {
set res 0
foreach bc [split $code ""] {incr res $::balance($bc)}
set res
}
分区将运行几秒钟（取决于 nmax - 我尝试过几万个），但只需运行一次。分区的大小通过排除包含冗余代码的程序进一步减少，这些代码不会产生任何效果，例如交换堆栈两次，或者在加法或乘法之前进行交换。没有这种奢侈的程序更短，但执行相同的工作，因此它将被提前测试。
proc partition'programs nmax {
global cmd partitions balance
#-- make a table of bytecode stack balances
set alphabet [array names cmd]
foreach bc $alphabet {
set balance($bc) [bc'stack'balance $bc]
}
array unset partitions ;# for repeated sourcing
for {set i 1} {$i<=$nmax} {incr i} {
set program [int2word $i $alphabet]
#-- "peephole optimizer" - suppress code with redundancies
set ok 1
foreach sequence {ss s+ s*} {
if {[string first $sequence $program]>=0} {set ok 0}
}
if {$ok} {
lappend partitions([stack'balance $program]) $program
}
}
set program ;# see how far we got
}
发现者第二版确定第一个文本的堆栈余额，并仅测试同一分区的那些程序
proc discover args {
global partitions
foreach {in out} $args break
set balance [expr {[llength $out]-[llength $in]}]
foreach code $partitions($balance) {
set failed 0
foreach {input output} $args {
catch {ebc $code $input} res
if {$res != $output} {incr failed; break}
}
if {!$failed} {return $code}
}
}
但现在让我们尝试一下。分区在很大程度上减少了候选者的数量。对于哥德尔数为 1..1000 的 1000 个程序，它只为每个堆栈余额保留一小部分
-2: 75
-1: 155 (this and 0 will be the most frequently used)
0: 241
1: 274
2: 155
3: 100
简单的入门 - 发现后继函数（加一）
% discover 5 6 7 8
dd/+
还不错：将数字复制两次，用自身除以得到常数 1，然后将其加到原始数字上。但是，如果我们将 0 的后继作为另一个测试用例添加，它将无法工作
% discover 5 6 7 8 0 1
什么也没有 - 因为零除导致了最后一个测试失败。如果我们只给出此测试，则会找到另一个解决方案
% discover 0 1
d^
“将 x 乘以 x 次幂” - pow(0,0) 确实给出 1，但这并不是通用的后继函数。
更多实验以发现 hypot() 函数
% discover {4 3} 5
d/+
嗯 - 3 被复制，用自身除以（=1），然后加到 4 上。尝试交换输入
% discover {3 4} 5
q+
另一个肮脏的技巧：获取 4 的平方根，加到 3 上 - 立即得到 5。正确的 hypot() 函数应该是
d*sd*+q
但我的程序集（nmax=30000）以 5 字节代码结束，因此即使给出另一个测试以强制发现真实情况，它也永远不会达到 7 字节代码。好吧，我忍痛将 nmax 设置为 500000，等待 5 分钟进行分区，然后
% discover {3 4} 5 {11 60} 61
sd/+
嗯.. 又是廉价的技巧 - 发现解决方案只是第二个参数的后继。就像现实生活中一样，测试用例必须仔细选择。所以，我尝试了另一个 a^2+b^2=c^2 集，并且 HEUREKA！（286 秒后）
% discover {3 4} 5 {8 15} 17
d*sd*+q
分区后，54005 个程序的堆栈余额为 -1，而正确的结果位于该列表中的第 48393 位...
最后，对于包含50万个程序的集合，这里给出了继任函数的解决方案。
% discover 0 1 4711 4712
ddd-^+
“d-” 从栈顶减去自身，压入 0；将第二个副本乘以 0 次方得到 1，将其加到原始参数上。经过一番苦思冥想，我发现它似乎可行，并且可能是最简单的解决方案，考虑到这种 RPN 语言的不足。
经验教训
- 蛮力法很简单，但可能需要极大的耐心（或更快的硬件）
- 天空才是极限，而不是头脑，我们用 Tcl 可以做所有事情：)
OO（面向对象）是一种编程语言风格，自 Smalltalk 以来流行，尤其是在 C++、Java 等语言中。对于 Tcl，已经出现了一些 OO 扩展/框架（如 incr Tcl、XOTcl、stooop、Snit 等），它们有不同的风格，但没有一种可以被认为是大多数用户遵循的标准。然而，大多数框架都具有以下特性：
- 可以定义类，包括变量和方法
- 对象被创建为类的实例
- 通过向对象发送消息来调用方法
当然，也有人说：“提倡面向对象编程就像提倡裤子式服装：它能遮住你的屁股，但往往不是最合适的……”
许多被称作 OO 的东西可以在纯 Tcl 中完成，无需“框架”，只是代码可能看起来很笨拙且分散注意力。只需选择如何实现实例变量即可：
- 在全局变量或命名空间中
- 或者作为透明值的组成部分，使用 TOOT
框架的任务，无论它们是用 Tcl 还是 C 编写的，只是隐藏实现的细节——换句话说，就是给它加糖：)。另一方面，当齿轮从时钟中取出，所有部件都可见时，人们才能最好地理解时钟的运作原理——因此，为了更好地理解 OO，最具指导意义的做法可能是查看一个简单的实现。
例如，这里有一个具有 _push_ 和 _pop_ 方法的 Stack 类，以及一个实例变量 _s_——一个用于保存栈内容的列表
namespace eval Stack {set n 0}
proc Stack::Stack {} { #-- constructor
variable n
set instance [namespace current]::[incr n]
namespace eval $instance {variable s {}}
interp alias {} $instance {} ::Stack::do $instance
}
_interp alias_ 确保调用对象的名称，例如
::Stack::1 push hello
会被理解并重定向到下面的调度器
::Stack::do ::Stack::1 push hello
调度器将对象的变量（这里只有 _s_）导入到本地作用域，然后根据方法名称进行切换
proc Stack::do {self method args} { #-- Dispatcher with methods
upvar #0 ${self}::s s
switch -- $method {
push {eval lappend s $args}
pop {
if ![llength $s] {error "stack underflow"}
K [lindex $s end] [set s [lrange $s 0 end-1]]
}
default {error "unknown method $method"}
}
}
proc K {a b} {set a}
框架只需要确保上面的代码在功能上等效于，例如（在幻想的 OO 风格中）：
class Stack {
variable s {}
method push args {eval lappend s $args}
method pop {} {
if ![llength $s] {error "stack underflow"}
K [lindex $s end] [set s [lrange $s 0 end-1]]
}
}
我承认，这看起来确实更清晰。但基础 OO 也有一些优点：为了了解时钟的运作原理，最好让所有部件都可见：)
现在在交互式 tclsh 中进行测试
% set s [Stack::Stack] ;#-- constructor
::Stack::1 ;#-- returns the generated instance name
% $s push hello
hello
% $s push world
hello world
% $s pop
world
% $s pop
hello
% $s pop
stack underflow ;#-- clear enough error message
% namespace delete $s ;#-- "destructor"
适用于 Tcl 的透明 OO，简称 TOOT，是 Tcl 中的透明值概念和 OO 概念的强大结合。在 TOOT 中，对象的取值被表示为长度为 3 的列表：类名（因此有“运行时类型信息”：-)，一个 "|" 作为分隔符和指示符，以及对象的取值，例如：
{class | {values of the object}}
以下是我对 toot 的简要概述。C++ 中的类最初是结构体，所以我以一个简单的结构体为例，使用通用的 get 和 set 方法。我们将导出 _get_ 和 _set_ 方法
namespace eval toot {namespace export get set}
proc toot::struct {name members} {
namespace eval $name {namespace import -force ::toot::*}
#-- membership information is kept in an alias:
interp alias {} ${name}::@ {} lsearch $members
}
两个通用的访问器函数将由“结构体”继承
proc toot::get {class value member} {
lindex $value [${class}::@ $member]
}
set 方法不会改变实例（它无法改变，因为它只“按值”查看它）——它只是返回新的复合 toot 对象，供调用者根据需要进行操作
proc toot::set {class value member newval} {
::set pos [${class}::@ $member]
list $class | [lreplace $value $pos $pos $newval]
}
为了使整个过程正常工作，这里对 unknown 进行了一个简单的重载——请参阅“让 unknown 知道”。它在当前 unknown 代码的开头添加了一个针对
{class | values} method args
模式的处理程序，它将模式转换为
::toot::(class)::(method) (class) (values) (args)
的形式并返回该形式的调用结果
proc know what {proc unknown args $what\n[info body unknown]}
现在来使用它（我承认代码不容易阅读）
know {
set first [lindex $args 0]
if {[llength $first]==3 && [lindex $first 1] eq "|"} {
set class [lindex $first 0]
return [eval ::toot::${class}::[lindex $args 1] \
$class [list [lindex $first 2]] [lrange $args 2 end]]
}
}
测试：我们定义一个名为 foo 的“结构体”，它有两个明显的成员
toot::struct foo {bar grill}
创建一个纯字符串取值的实例
set x {foo | {hello world}}
puts [$x get bar] ;# -> hello (value of the "bar" member)
修改 foo 的一部分，并将其赋值给另一个变量
set y [$x set grill again]
puts $y ;# -> foo | {hello again}
特定于结构体的方法可以是位于正确命名空间中的 proc。第一个和第二个参数是类（这里忽略了，因为横线表示）和值，其余由编码者决定。这个简单的例子演示了成员访问和一些字符串操作
proc toot::foo::upcase {- values which string} {
string toupper [lindex $values [@ $which]]$string
}
puts [$y upcase grill !] ;# -> AGAIN!
在大学里，我对图灵机了解不多。直到几十年后，Tcl 聊天室的一条提示才让我注意到 http://csc.smsu.edu/~shade/333/project.txt，这是一个实现确定性图灵机（即每个状态和输入字符最多只有一个规则的图灵机）的作业，其中提供了清晰的说明和两个输入输出测试用例，所以我决定用 Tcl 试一试。
在这个小挑战中，规则采用 a bcD e 的形式，其中：
- a 是可以应用规则的状态
- b 是如果要应用此规则，则必须从磁带上读取的字符
- c 是要写入磁带的字符
- D 是写入后移动磁带的方向（R(ight) 或 L(eft)）
- e 是应用规则后要转换到的状态
这是我天真的实现，它将磁带视为最初的字符串。我只需要注意，当超出磁带的末端时，需要在该末端附加一个空格（用 _ 表示），并且在开头时调整位置指针。规则也以字符串的形式给出，其各部分可以轻松地使用 string index 提取——由于这里经常使用它，所以我将其别名为 @。
proc dtm {rules tape} {
set state 1
set pos 0
while 1 {
set char [@ $tape $pos]
foreach rule $rules {
if {[@ $rule 0] eq $state && [@ $rule 2] eq $char} {
#puts rule:$rule,tape:$tape,pos:$pos,char:$char
#-- Rewrite tape at head position.
set tape [string replace $tape $pos $pos [@ $rule 3]]
#-- Move tape Left or Right as specified in rule.
incr pos [expr {[@ $rule 4] eq "L"? -1: 1}]
if {$pos == -1} {
set pos 0
set tape _$tape
} elseif {$pos == [string length $tape]} {
append tape _
}
set state [@ $rule 6]
break
}
}
if {$state == 0} break
}
#-- Highlight the head position on the tape.
string trim [string replace $tape $pos $pos \[[@ $tape $pos]\]] _
}
interp alias {} @ {} string index
来自 http://csc.smsu.edu/~shade/333/project.txt 的测试数据
set rules {
{1 00R 1}
{2 01L 0}
{1 __L 2}
{2 10L 2}
{2 _1L 0}
{1 11R 1}
}
set tapes {
0
10011
1111
}
set rules2 {
{3 _1L 2}
{1 _1R 2}
{1 11L 3}
{2 11R 2}
{3 11R 0}
{2 _1L 1}
}
set tapes2 _
测试
foreach tape $tapes {puts [dtm $rules $tape]}
puts *
puts [dtm $rules2 $tapes2]
将结果报告为论文中要求的，在标准输出上
>tclsh turing.tcl
[_]1
1[0]100
[_]10000
*
1111[1]1
流是（不仅仅是函数式）编程中的一个强大概念。在 SICP 第 3.5 章中，流被引入作为数据结构，其特点是“延迟列表”，其元素仅在需要时才生成和返回（延迟求值）。这样，流可以承诺成为一个潜在无限的数据源，同时只占用有限的时间来处理和交付真正需要的内容。其他流可以提供有限但非常大量的元素，一次性处理这些元素是不切实际的。在 Tcl 中，读取文件的两种方式是一个很好的例子
read $fp返回整个内容，然后可以对其进行处理；- 而
{[gets $fp line] > -1} {...}逐行读取，并在处理之间交错
第二种构造可能效率较低，但对于千兆字节大小的文件来说是健壮的。一个更简单的例子是 Unix/DOS 中的管道（在 DOS 中使用 TYPE 代替 cat）
cat foo.bar | more
其中，“cat” 只要“more” 接受就会逐行交付文件的内容，否则就会等待（毕竟，stdin 和 stdout 只是流……）。这样的进程链可以用 Tcl 中的以下规则进行模拟
这里将流模拟为一个过程，它在每次调用时返回一个流项。特殊项 ""（空字符串）表示流已耗尽。如果流在每次调用时返回的结果不同，则流会很有趣，这要求它们在调用之间维护状态，例如在静态变量中（这里使用 fancy remember proc 实现）——例如 intgen 会不断递增整数，或者 gets $fp，其中文件指针在每次调用时都会前进，因此，随着时间的推移，可能会返回文件的全部行。
过滤器接受一个或多个流，以及可能的其他参数，并像流一样做出反应。因此，流可以（通常也确实）嵌套用于处理目的。如果过滤器遇到流的末尾，它也应该返回它。过滤器可以被描述为“选择器”（它们可能只返回输入的一部分，例如“grep”）和/或“应用器”，它们对输入调用一个命令并返回结果。请注意，在无限流上，选择器可能永远不会返回，例如，如果您想要第二个偶数素数……。一般来说，流不应放在括号中（这样 Tcl 解析器会在评估命令之前急切地评估它们），而应放在大括号中，并且流消费者会根据自己的意愿评估流。
在开始之前，需要提醒您：维护过程的状态是使用可以被重写的默认参数来完成的。为了防止默认值发生变化而导致过程出现错误，我提出了以下简单的架构——具有静态变量的过程被注册为“sproc”，它会记住初始默认值，并使用 reset 命令，您可以恢复一个或所有 sproc 的初始值
proc sproc {name head body} {
set ::sproc($name) $head
proc $name $head $body
}
proc reset { {what *}} {
foreach name [array names ::sproc $what] {
proc $name $::sproc($name) [info body $name]
}
}
现在让我们从一个简单的流源“cat”开始，它作为 gets 的包装器，逐行返回文件的行，直到耗尽（EOF），在这种情况下返回一个空字符串（这要求文件中空行以单个空格表示，看起来很像）。
sproc cat {filename {fp {}} } {
if {$fp==""} {
remember fp [set fp [open $filename]]
}
if {[gets $fp res]<0} {
remember fp [close $fp] ;# which returns an empty string ;-)
} elseif {$res==""} {set res " "} ;# not end of stream!
set res
}
proc remember {argn value} {
# - rewrite a proc's default arg with given value
set procn [lindex [info level -1] 0] ;# caller's name
set argl {}
foreach arg [info args $procn] {
if [info default $procn $arg default] {
if {$arg==$argn} {set default $value}
lappend argl [list $arg $default]
} else {
lappend argl $arg
}
}
proc $procn $argl [info body $procn]
set value
}
# This simple but infinite stream source produces all positive integers:
sproc intgen { {seed -1}} {remember seed [incr seed]}
# This produces all (well, very many) powers of 2:
sproc powers-of-2 { {x 0.5}} {remember x [expr $x*2]}
# A filter that reads and displays a stream until user stops it:
proc more {stream} {
while 1 {
set res [eval $stream]
if {$res==""} break ;# encountered end of stream
puts -nonewline $res; flush stdout
if {[gets stdin]=="q"} break
}
}
用法示例
more {cat streams.tcl}
粗略地模拟了上面提到的 Unix/DOS 管道（您需要在每行之后按 ↵ Enter，并按 q↵ Enter 退出）。more 是流最重要的“最终用户”，尤其是在无限流的情况下。但是，请注意，此实现需要 stdin，这排除了 Windows 上的愿望（尽管可以轻松编写一个对鼠标点击做出反应的 UI-more）。
一个更通用的过滤器接受一个条件和一个流，并在每次调用时返回输入流中满足条件的元素——如果存在的话。
proc filter {cond stream} {
while 1 {
set res [eval $stream]
if {$res=="" || [$cond $res]} break
}
set res
}
# Here is a sample usage with famous name:
proc grep {re stream} {
filter [lambda [list x [list re $re]] {regexp $re $x}] $stream
}
#.... which uses the (less) famous function maker:
proc lambda {args body} {
set name [info level 0]
proc $name $args $body
set name
}
# Usage example: more {grep this {cat streams.tcl}}
喜欢语法糖的朋友可能会更喜欢 shell 风格。
$ cat streams.tcl | grep this | more
猜猜看，我们也可以在 Tcl 中实现（而在 Scheme 中不行！），方法是编写一个 proc，它也会重置所有 sprocs，并取名为 "$"（在 Unix 中，这可能是你不会输入的 shell 提示符，但对于 Tcl，我们总是必须将命令名作为第一个词）。
proc $ args {
reset
set cmd {}
foreach arg $args {
if {$arg != "|"} {
lappend tmp $arg
} else {
set cmd [expr {$cmd==""? $tmp: [lappend tmp $cmd]}]
set tmp {}
}
}
uplevel 1 [lappend tmp $cmd]
}
为了证明我们没有通过使用 exec 作弊，让我们引入一个行计数过滤器。
sproc -n {stream {n 0}} {
set res [eval $stream]
if {$res!=""} {set res [remember n [incr n]]:$res}
}
这可以添加到过滤器链中，用来计算原始文件中的行数，或者只计算 grep 的结果中的行数。
$ cat streams.tcl | -n | grep this | more
$ cat streams.tcl | grep this | -n | more
我们进一步观察到 more 具有与 filter 相似的结构，因此我们也可以用它来重写 more。
proc more2 stream {
filter [lambda x {
puts -nonewline $x; flush stdout
expr {[gets stdin]=="q"}
}] $stream
}
# Here is another stream producer that returns elements from a list:
sproc streamlist {list {todo {}} {firstTime 1} } {
if $firstTime {set todo $list; remember firstTime 0}
remember todo [lrange $todo 1 end]
lindex $todo 0
}
# This one repeats its list endlessly, so better use it with 'more':
sproc infinite-streamlist {list {todo {}} } {
initially todo $list
remember todo [lrange $todo 1 end]
lindex $todo 0
}
# This is sugar for first-time assignment of static variables:
proc initially {varName value} {
upvar 1 $varName var
if {$var==""} {set var $value}
}
# But for a simple constant stream source, just use [subst]:
# more {subst 1} ;# will produce as many ones as you wish
# This filter collects its input (should be finite ;-) into a list:
proc collect stream {
set res {}
while 1 {
set element [eval $stream]
if {$element==""} break
lappend res $element
}
set res
}
sort 过滤器不同寻常，因为它会消耗整个（有限的！）输入，对其进行排序，并作为输出流的源。
sproc sort {stream {todo {}} {firstTime 1}} {
if $firstTime {
set todo [lsort [collect $stream]]
remember firstTime 0
}
remember todo [lrange $todo 1 end]
lindex $todo 0
}
# $ streamlist {foo bar grill a} | sort | collect => a bar foo grill
proc apply {f stream} {$f [eval $stream]}
#... This can be plugged into a filter chain to see what's going on:
proc observe stream {apply [lambda y {puts $y; set y}] $stream}
# ... or, to get a stream of even numbers, starting from 0:
more {apply [lambda x {expr $x*2}] intgen}
现在让我们看一个 SICP 中的例子：找出 10000 和 1000000 之间的第二个素数。
sproc interval {from to {current {}} } {
initially current $from
if {$current<=$to} {
remember current [expr $current+1]
}
}
proc prime? x {
if {$x<2} {return 0}
set max [expr sqrt($x)]
set try 2
while {$try<=$max} {
if {$x%$try == 0} {return 0}
incr try [expr {2-($try==2)}]
}
return 1
}
proc stream-index {stream index} {
for {set i 0} {$i<=$index} {incr i} {
set res [eval $stream]
}
set res
}
sproc stream-range {stream from to {pos 0}} {
while {$pos<$from} {
set res [eval $stream] ;# ignore elements before 'from'
if {$res==""} return ;# might be end-of-stream
incr pos
}
if {$to!="end" && $pos > $to} return
remember pos [incr pos]
eval $stream
}
stream-index {filter prime? {interval 10000 1000000}} 1 ==> 10009
另一个来自 SICP 的想法是“平滑”函数，它对输入流中的每对值进行平均。为此，我们需要在过滤器中引入短期记忆。
sproc average {stream {previous {}} } {
if {$previous==""} {set previous [eval $stream]}
remember previous [set current [eval $stream]]
if {$current!=""} {expr {($previous+$current)/2.}}
}
在 n 个元素的流上测试，返回 n-1 个平均值。
collect {average {streamlist {1 2 3 4 5}}} ==> 1.5 2.5 3.5 4.5
另一个挑战是生成一个无限的正整数对流 {i j}，其中 i <= j，并按它们的和排序，以便生成更多对。
{1 1} {1 2} {1 3} {2 2} {1 4} {2 3} {1 5} {2 4} {3 3} {1 6} ...
这是我的解决方案，它实现了这一点。
sproc pairs { {last {}} } {
if {$last==""} {
set last [list 1 1] ;# start of iteration
} else {
foreach {a b} $last break
if {$a >= $b-1} {
set last [list 1 [expr {$a+$b}]] ;# next sum level
} else {
set last [list [incr a] [incr b -1]]
}
}
remember last $last
}
拉马努金数：对生成器可以用来寻找拉马努金数，拉马努金数可以表示为两个整数立方和的多种方式。这里我使用一个全局数组来记录结果。
sproc Ramanujan {stream {firstTime 1}} {
if $firstTime {unset ::A; remember firstTime 0}
while 1 {
set pair [eval $stream]
foreach {a b} $pair break
set n [expr {$a*$a*$a + $b*$b*$b}]
if [info exists ::A($n)] {
lappend ::A($n) $pair
break
} else {set ::A($n) [list $pair]}
}
list $n $::A($n)
}
more {Ramanujan pairs} ;# or: $ pairs | Ramanujan | more
它以几乎不可察觉的时间输出了拉马努金数 1729、4104、13832... 或者，看看这个无限的斐波那契数生成器，它在 more fibo 上输出所有你可能想要的斐波那契数 (0,1,1,2,3,5,8,13,21...)？
sproc fibo { {a ""} {b ""}} {
if {$a==""} {
remember a 0
} elseif {$b==""} {
remember b 1
} else {
if {$b > 1<<30} {set b [expr double($b)]}
remember a $b
remember b [expr $a+$b]
}
}
讨论：使用上面的代码，可以再现 SICP 中记录的相当多的流行为，不是作为数据结构，而是用 Tcl proc（尽管 proc 在某种意义上也是数据）。缺少的是随机访问流中部分内容的能力，就像在 Scheme 中那样（当然还有他们声称无需赋值或可变数据...）。Tcl 列表并不遵循 LISP 的 CAR/CDR 模型（尽管 KBK 在 Tcl 和 LISP 中证明了这种结构可以通过 proc 模拟，包括 proc），而是 C 的扁平 *TclObject[] 风格。缺乏词法作用域也导致了 sproc/reset 这样的结构，它填补了空白，但并不完全优雅——但 Tcl 在局部变量或全局变量之间的清晰界限允许类似闭包的东西，只是通过像 remember 中那样重写默认参数（或者像在 Python 中那样）。
不过，不要将这视为对 Tcl 的根本批评——它底层的模型比 LISP 的简单优雅得多（有“特殊形式”、“阅读器宏”...），而且功能强大到可以做几乎所有事情...。
多年以后，我重新阅读了
G. Spencer-Brown, "Laws of Form". New York: E.P. Dutton 1979
这本书有点像数学惊悚片，如果你愿意的话。伯特兰·罗素评论说，作者“揭示了一种新的演算，它既强大又简单”（听起来有点像 Tcl ;^）。在极端的简化中，一个完整的世界是由两个运算符构建起来的，一个是没有任何可见符号的并置（可以比作或），另一个是一个横线钩（意思是非），我在这里无法输入——它是在零个或多个操作数之上画的一条水平线，在右侧继续画一条向下到达基线的垂直线。在这些 Tcl 实验中，我使用 "" 来表示 ""，使用尖括号 <> 来表示横线钩（中间有零个或多个操作数）。
我新发现的一点是，运算符和操作数之间的区别不是一成不变的。特别是常量（如布尔代数中的“真”和“假”）可以同样好地表示为运算符的中性元素，如果这些运算符被认为是可变的，并且没有参数。这很有道理，即使在 Tcl 中也是如此，我们可能会将它们实现为
proc and args {
foreach arg $args {if {![uplevel 1 expr $arg]} {return 0}}
return 1
}
proc or args {
foreach arg $args {if {[uplevel 1 expr $arg]} {return 1}}
return 0
}
当不带任何参数调用时，它们分别返回 1 或 0。因此 [or] == 0 且 [and] == 1。用斯宾塞-布朗的术语来说，[]（也就是 ""，不带参数的空字符串）是假（在 LISP 中是“nil”），而 [<>] 是 "" 的否定，即真。他的两个公理是
<><> == <> "to recall is to call -- (1 || 1) == 1"
<<>> == "to recross is not to cross -- !!0 == 0"
它们可以通过一个字符串映射来实现，该映射只要有必要就重复（有点像蹦床），以简化任何只包含运算符和常量（即不带参数的运算符）的表达式。
proc lf'simplify expression {
while 1 {
set res [string map {<><> <> <<>> ""} $expression]
if {$res eq $expression} {return $res}
set expression $res
}
}
测试
% lf'simplify <<><>><>
<>
它将 <><> 映射到 <>，将 <<>> 映射到 ""，并为“真”返回 <>。
% lf'simplify <a>a
<a>a
在本文介绍的代数中，使用一个变量“a”，到目前为止还没有进一步简化。让我们改变一下——“a”只能取两个值，"" 或 <>，所以我们可以尝试通过假设“a”的所有可能值来求解表达式，并查看它们是否不同。如果它们没有不同，我们就找到了一个不依赖于变量值的事实，并返回结果常量，否则返回未解决的表达式。
proc lf'solve {expression var} {
set results {}
foreach value {"" <>} {
set res [lf'simplify [string map [list $var $value] $expression]]
if {![in $results $res]} {lappend results $res}
if {[llength $results] > 1} {return $expression}
}
set results
}
使用一个辅助函数来报告元素是否包含在列表中。
proc in {list element} {expr {[lsearch -exact $list $element] >= 0}}
测试
% lf'solve <a>a a
<>
这意味着，用 expr 术语来说，{(!$a || $a) == 1}，对于“a”的所有值都成立。换句话说，这是一个重言式。布尔代数的所有内容都可以用这种演算来表达。
* (1) not a == !$a == <a>
* (2) a or b == $a || $b == ab
* (3) a and b == $a && $b == <<a><b>>
* (4) a implies b == $a <= $b == <a>b
我们可以用经典的“ex contradictione quodlibet”（ECQ）例子来测试它——“如果 p 且非 p，则 q”，对于任何 q 都成立。
% lf'solve <<p><<p>>>q p
q
所以形式上，q 是真的，无论它是什么 :) 如果这听起来过于理论化，下面是一个在解谜中的棘手实际例子，刘易斯·卡罗尔的最后一个连锁推理（第 123f 页）。任务是从以下前提中得出结论。
- 这所房子里的唯一动物是猫。
- 每种动物都适合作为宠物，它们喜欢凝视月亮。
- 当我厌恶一种动物时，我会避开它。
- 没有动物是食肉动物，除非它们在晚上出没。
- 没有猫不能杀死老鼠。
- 除了在这所房子里的动物之外，没有动物喜欢我。
- 袋鼠不适合作为宠物。
- 只有食肉动物才能杀死老鼠。
- 我厌恶不喜欢我的动物。
- 在晚上出没的动物总是喜欢凝视月亮。
这些被编码为以下一个字母的谓词。
- a
- 被我避开
- c
- 猫
- d
- 被我厌恶
- h
- 在这所房子里
- k
- 杀死老鼠
- m
- 喜欢凝视月亮
- n
- 在晚上出没
- p
- 适合作为宠物
- r
- (袋)鼠
- t
- 喜欢我
- v
- (食肉)动物
因此，问题集可以用斯宾塞-布朗的术语重新表述为
<h>c <m>p <d>a <v>n <c>k <t>h <r><p> <k>v td <n>m
我一开始不明白为什么所有前提都可以简单地写成一行，这相当于隐含的“或”，但它似乎运作良好。正如我们已经看到 <x>x 对于任何 x 都是真的，我们可以取消掉这样的重言式。为此，我们将表达式重新格式化为一个 x 或 !x 类型的列表，该列表反过来又转储到一个局部数组中以进行存在性检查。当 x 和 !x 都存在时，它们将从表达式中删除。
proc lf'cancel expression {
set e2 [string map {"< " ! "> " ""} [split $expression ""]]
foreach term $e2 {if {$term ne ""} {set a($term) ""}}
foreach var [array names a ?] {
if [info exists a(!$var)] {
set expression [string map [list <$var> "" $var ""] $expression]
}
}
set expression
}
puts [lf'cancel {<h>c <m>p <d>a <v>n <c>k <t>h <r><p> <k>v td <n>m}]
这将产生以下结果：
- a <r>
翻译回来：“我避开它，或者它不是袋鼠”，或者，重新排序，"<r> a"，根据 (4)，这意味着，“所有的袋鼠都被我避开”。
这是一个简单的“聊天机器人”示例——一个监听 IRC 聊天室的程序，它有时也会说些话，根据其编程。以下脚本
- 连接到 IRC 的 #tcl 频道。
- 监听所说的话。
- 如果有人提到它的名字（minibot），它会尝试解析消息并回答。
#!/usr/bin/env tclsh
set ::server irc.freenode.org
set ::chan #tcl
set ::me minibot
proc recv {} {
gets $::fd line
puts $line
# handle PING messages from server
if {[lindex [split $line] 0] eq "PING"} {
send "PONG [info hostname] [lindex [split $line] 1]"; return
}
if {[regexp {:([^!]*)![^ ].* +PRIVMSG ([^ :]+) +(.*[Mm]inibot)(.+)} $line -> \
nick target msg cmd]} {
if {$nick eq "ijchain"} {regexp {<([^>]+)>(.+)} $msg -> nick msg}
set hit 0
foreach pattern [array names ::patterns] {
if [string match "*$pattern*" $cmd] {
set cmd [string trim $cmd {.,:? }]
if [catch {mini eval $::patterns($pattern) $cmd} res] {
set res $::errorInfo
}
foreach line [split $res \n] {
send "PRIVMSG $::chan :$line"
}
incr hit
break
}
}
if !$hit {send "PRIVMSG $::chan :Sorry, no idea."}
}
}
#----------- Patterns for response:
set patterns(time) {clock format [clock sec] ;#}
set patterns(expr) safeexpr
proc safeexpr args {expr [string map {\[ ( \] ) expr ""} $args]}
set patterns(eggdrop) {set _ "Please check http://wiki.tcl.tk/6601" ;#}
set patterns(toupper) string
set patterns(Windows) {set _ "I'd prefer not to discuss Windows..." ;#}
set {patterns(translate "good" to Russian)} {set _ \u0425\u043E\u0440\u043E\u0448\u043E ;#}
set patterns(Beijing) {set _ \u5317\u4EAC ;#}
set patterns(Tokyo) {set _ \u4E1C\u4EAC ;#}
set {patterns(your Wiki page)} {set _ http://wiki.tcl.tk/20205 ;#}
set patterns(zzz) {set _ "zzz well!" ;#}
set patterns(man) safeman
proc safeman args {return http://www.tcl.tk/man/tcl8.4/TclCmd/[lindex $args 1].htm}
set {patterns(where can I read about)} gotowiki
proc gotowiki args {return "Try http://wiki.tcl.tk/[lindex $args end]"}
set patterns(thank) {set _ "You're welcome." ;#}
set patterns(worry) worry
proc worry args {
return "Why do [string map {I you my your your my you me} $args]?"
}
#-- let the show begin... :^)
interp create -safe mini
foreach i {safeexpr safeman gotowiki worry} {
interp alias mini $i {} $i
}
proc in {list element} {expr {[lsearch -exact $list $element]>=0}}
proc send str {puts $::fd $str;flush $::fd}
set ::fd [socket $::server 6667]
fconfigure $fd -encoding utf-8
send "NICK minibot"
send "USER $::me 0 * :PicoIRC user"
send "JOIN $::chan"
fileevent $::fd readable recv
vwait forever
来自聊天的示例
suchenwi minibot, which is your Wiki page?
<minibot> http://wiki.tcl.tk/20205
suchenwi ah, thanks
suchenwi minibot expr 6*7
<minibot> 42
suchenwi minibot, what's your local time?
<minibot> Sun Oct 21 01:26:59 (MEZ) - Mitteleurop. Sommerzeit 2007