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