# Tcl Programming/Examples

Most of these example scripts first appeared in the Tclers\' Wiki
<http://wiki.tcl.tk> . The author (Richard Suchenwirth) declares them to
be fully in the public domain. The following scripts are plain Tcl, they
don\'t use the Tk GUI toolkit (there\'s a separate chapter for those).

### Sets as lists

Tcl\'s lists are well suited to represent sets. Here\'s typical set
operations. If you use the tiny testing framework explained earlier, the
*e.g.* lines make the self-test; otherwise they just illustrate how the
operations should work.

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` 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}
```

```{=html}
</div>
```
### Hex-dumping a file

The following example code opens a file, configures it to binary
translation (i.e. line-ends `\r\n` are not standardized to `\n` as usual
in C), and prints as many lines as needed which each contain 16 bytes in
hexadecimal notation, plus, where possible, the ASCII character.

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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
}
```

```{=html}
</div>
```
The \"main routine\" is a single line that dumps all files given on the
command line:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
foreach file $argv {file'hexdump $file}
```

```{=html}
</div>
```
Sample output, the script applied to itself:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` text
...> 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]..
...
```

```{=html}
</div>
```
### Roman numerals

Roman numerals are an additive (and partially subtractive) system with
the following letter values:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` text
I=1 V=5 X=10 L=50 C=100 D=500 M=1000; MCMXCIX = 1999
```

```{=html}
</div>
```
Here\'s some Tcl routines for dealing with Roman numerals.

**Sorting roman numerals:** I,V,X already come in the right order; for
the others we have to introduce temporary collation transformations,
which we\'ll undo right after sorting:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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
}
```

```{=html}
</div>
```
**Roman numerals from integer:**

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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
}
```

```{=html}
</div>
```
**Roman numerals parsed into integer:**

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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
}
```

```{=html}
</div>
```
### Custom control structures

As \"control structures\" are really nothing special in Tcl, just a set
of commands, it is easier than in most other languages to create one\'s
own. For instance, if you would like to simplify the **for** loop

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
for {set i 0} {$i < $max} {incr i} {...}
```

```{=html}
</div>
```
for the typical simple cases so you can write instead

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
loop i 0 $max {...}
```

```{=html}
</div>
```
here is an implementation that even returns a list of the results of
each iteration:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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
 }
```

```{=html}
</div>
```
using this, a *string reverse* function can be had as a one-liner:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
proc sreverse {str} {
   join [loop i 0 [string length $str] {string index $str end-$i}] ""
}
```

```{=html}
</div>
```
#### Range-aware switch

Another example is the following **range-aware switch** variation. A
range (numeric or strings) can be given as from..to, and the associated
scriptlet gets executed if the tested value lies inside that range.

Like in switch, fall-through collapsing of several cases is indicated by
\"-\", and \"default\" as final condition fires if none else did.
Different from switch, numbers are compared by numeric value, no matter
whether given as decimal, octal or hex.

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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)
}
```

```{=html}
</div>
```
Testing:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
% 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
```

```{=html}
</div>
```
#### The K combinator

A very simple control structure (one might also call it a result
dispatcher) is the **K combinator**, which is almost terribly simple:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
proc K {a b} {return $a}
```

```{=html}
</div>
```
It can be used in all situations where you want to deliver a result that
is not the last. For instance, reading a file in one go:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
proc readfile filename {
   set f [open $filename]
   set data [read $f]
   close $f
   return $data
}
```

```{=html}
</div>
```
can be simplified, without need for the *data* variable, to:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
proc readfile filename {
   K [read [set f [open $filename]]] [close $f]
}
```

```{=html}
</div>
```
Another example, popping a stack:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
proc pop _stack {
   upvar 1 $_stack stack
   K [lindex $stack end] [set stack [lrange $stack 0 end-1]]
}
```

```{=html}
</div>
```
This is in some ways similar to LISP\'s PROG1 construct: evaluate the
contained expressions, and return the result of the first one.

### Rational numbers

Rational numbers, a.k.a. fractions, can be thought of as pairs of
integers {numerator denominator}, such that their \"real\" numerical
value is numerator/denominator (and not in integer nor \"double\"
division!). They can be more precise than any \"float\" or \"double\"
numbers on computers, as those can\'t exactly represent any fractions
whose denominator isn\'t a power of 2 --- consider
 which can not at any precision be exactly
represented as floating-point number to base 2, nor as decimal fraction
(base 10), even if bignum.

An obvious string representation of a rational is of course \"n/d\". The
following \"constructor\" does that, plus it normalizes the signs,
reduces to lowest terms, and returns just the integer n if d==1:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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" }
}
```

```{=html}
</div>
```
Conversely, this \"deconstructor\" splits zero or more rational or
integer strings into num and den variables, such that \[ratsplit 1/3 a
b\] assigns 1 to a and 3 to b:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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]
}
```

```{=html}
</div>
```
Arithmetical helper functions can be wrapped with func if they only
consist of one call of *expr*:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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
```

```{=html}
</div>
```
### Docstrings

Languages like Lisp and Python have the docstring feature, where a
string in the beginning of a function can be retrieved for on-line (or
printed) documentation. Tcl doesn\'t have this mechanism built-in (and
it would be hard to do it exactly the same way, because everything is a
string), but a similar mechanism can easily be adopted, and it doesn\'t
look bad in comparison:

-   Common Lisp: (documentation \'foo \'function)
-   Python: foo.\_\_doc\_\_
-   Tcl: docstring foo

If the docstring is written in comments at the top of a proc body, it is
easy to parse it out. In addition, for all procs, even without
docstring, you get the \"signature\" (proc name and arguments with
defaults). The code below also serves as usage example: }

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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
}
```

```{=html}
</div>
```
Testing:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
% 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
```

```{=html}
</div>
```
### Factorial

Factorial (n!) is a popular function with super-exponential growth.
Mathematically put,

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
  0! = 1
  n! = n (n-1)! if n >0, else undefined
```

```{=html}
</div>
```
In Tcl, we can have it pretty similarly:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
proc fact n {expr {$n<2? 1: $n * [fact [incr n -1]]}}
```

```{=html}
</div>
```
But this very soon crosses the limits of integers, giving wrong results.

A math book showed me the Stirling approximation to `n!` for large `n`
(at Tcl\'s precisions, \"large\" is \> 20 \...), so I built that in:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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]]}
}
```

```{=html}
</div>
```
Just in case somebody needs approximated large factorials\... But for
`n>143` we reach the domain limit of floating point numbers. In fact,
the float limit is at `n>170`, so an intermediate result in the Stirling
formula must have busted at 144. For such few values it is most
efficient to just look them up in a pre-built table, as Tcllib\'s
`math::factorial` does.

### How big is A4?

Letter and Legal paper formats are popular in the US and other places.
In Europe and elsewhere, the most widely used paper format is called A4.
To find out how big a paper format is, one can measure an instance with
a ruler, or look up appropriate documentation. The A formats can also be
deduced from the following axioms:

-   A0 has an area of one square meter
-   `A(n)` has half the area of `A(n-1)`
-   The ratio between the longer and the shorter side of an A format is
    constant

How much this ratio is, can easily be computed if we consider that
`A(n)` is produced from `A(n-1)` by halving it parallel to the shorter
side, so

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
2a : b = b : a,
2 a2 = b2,
b=sqrt(2) a, hence
b : a = sqrt(2) : 1
```

```{=html}
</div>
```
So here is my Tcl implementation, which returns a list of height and
width in centimeters (10000 cm^2^ = 1 m^2^) with two fractional digits,
which delivers a sufficient precision of 1/10 mm: }

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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
```

```{=html}
</div>
```
### Bit vectors

Here is a routine for querying or setting single bits in vectors, where
bits are addressed by non-negative integers. Implementation is as a
\"little-endian\" list of integers, where bits 0..31 are in the first
list element, 32..63 in the second, etc.

Usage: **bit** *varName position ?bitval?*

If bitval is given, sets the bit at numeric position position to 1 if
bitval `!=` 0, else to 0; in any case returns the bit value at specified
position. If variable varName does not exist in caller\'s scope, it will
be created; if it is not long enough, it will be extended to hold at
least `$position+1` bits, e.g. bit foo 32 will turn foo into a list of
two integers, if it was only one before. All bits are initialized to 0.

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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
   }
}
```

```{=html}
</div>
```
This may be used for Boolean properties of numerically indexed sets of
items. Example: An existence map of ZIP codes between 00000 and 99999
can be kept in a list of 3125 integers (where each element requires
about 15 bytes overall), while implementing the map as an array would
take 100000 \* 42 bytes in worst case, but still more than a bit vector
if the population isn\'t extremely sparse --- in that case, a list of
1-bit positions, retrieved with `lsearch`, might be more efficient in
memory usage. Runtime of bit vector accesses is constant, except when a
vector has to be extended to much larger length.

Bit vectors can also be used to indicate set membership (set operations
would run faster if processing 32 bits on one go with bitwise operators
(`&`, `|`, `~`, `^`)) --- or pixels in a binary imary image, where each
row could be implemented by a bitvector.

Here\'s a routine that returns the numeric indices of all set bits in a
bit vector:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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
```

```{=html}
</div>
```
**Sieve of Erastothenes**: The following procedure exercises the bit
vector functions by letting bits represent integers, and unsetting all
that are divisible. The numbers of the bits finally still set are
supposed to be primes, and returned:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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
```

```{=html}
</div>
```
Here\'s code to count the number of 1-bits in a bit vector, represented
as an integer list. It does so by adding the values of the hex digits:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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
}
```

```{=html}
</div>
```
### Stacks and queues

Stacks and queues are containers for data objects with typical access
methods:

-   push: add one object to the container
-   pop: retrieve and remove one object from the container

In Tcl it is easiest to implement stacks and queues with lists, and the
push method is most naturally *lappend*, so we only have to code a
single generic line for all stacks and queues:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
interp alias {} push {} lappend
```

```{=html}
</div>
```
It is pop operations in which stacks, queues, and priority queues
differ:

-   in a stack, the most recently pushed object is retrieved and removed
    (last in first out, LIFO)
-   in a (normal) queue, it is the least recently pushed object (first
    in first out, FIFO)
-   in a priority queue, the object with the highest priority comes
    first.

Priority (a number) has to be assigned at pushing time --- by pushing a
list of two elements, the item itself and the priority, e.g..

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
push toDo [list "go shopping" 2]
push toDo {"answer mail" 3}
push toDo {"Tcl coding" 1}  ;# most important thing to do
```

```{=html}
</div>
```
In a frequent parlage, priority 1 is the \"highest\", and the number
increases for \"lower\" priorities --- but you could push in an item
with 0 for \"ultrahigh\" ;-) Popping a stack can be done like this:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
proc pop name {
   upvar 1 $name stack
   set res [lindex $stack end]
   set stack [lrange $stack 0 end-1]
   set res
}
```

```{=html}
</div>
```
Popping a queue is similarly structured, but with so different details
that I found no convenient way to factor out things:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
proc qpop name {
   upvar 1 $name queue
   set res [lindex $queue 0]
   set queue [lrange $queue 1 end]
   set res
}
```

```{=html}
</div>
```
Popping a priority queue requires sorting out which item has highest
priority. Sorting can be done when pushing, or when popping, and since
our push is so nicely generic I prefer the second choice (as the number
of pushs and pops should be about equal, it does not really matter).
Tcl\'s lsort is stable, so items with equal priority will remain in the
order in which they were queued:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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
}
```

```{=html}
</div>
```
A practical application is e.g. in state space searching, where the kind
of container of the to-do list determines the strategy:

-   stack is depth-first
-   (normal) queue is breadth-first
-   priority queue is any of the more clever ways: A\*, Greedy, \...

**Recent-use lists:** A variation that can be used both in a stack or
queue fashion is a list of values in order of their last use (which may
come handy in an editor to display the last edited files, for instance).
Here, pushing has to be done by dedicated code because a previous
instance would have to be removed:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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
```

```{=html}
</div>
```
The first element is the least recently, the last the most recently
used. Elements are not removed by the popping, but (if necessary) when
re-pushing. (One might truncate the list at front if it gets too long).

### Functions

Functions in Tcl are typically written with the *proc* command. But I
notice more and more that, on my way to functional programming, my
*proc* bodies are a single call to *expr* which does all the rest (often
with the powerful `x?y:z` operator). So what about a thin abstraction
(wrapper) around this recurring pattern?

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
proc func {name argl body} {proc $name $argl [list expr $body]}
```

```{=html}
</div>
```
(I might have called it fun as well\... it sure is.) That\'s all. A
collateral advantage is that all expressions are braced, without me
having to care. But to not make the page look so empty, here\'s some
examples for func uses:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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
```

```{=html}
</div>
```
Pity we have to make *expr* explicit again, in nested calls like in
*gcd* \... But *func* isn\'t limited to math functions (which,
especially when recursive, come out nice), but for *expr* uses in
testing predicates as well:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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]}
```

```{=html}
</div>
```
Exposing *expr* binary arithmetic operators as Tcl commands goes quite
easy too:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
foreach op {+ * / %} {func $op {a b} "\$a $op \$b"}
```

```{=html}
</div>
```
For \"-\", we distinguish unary and binary form:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
func - {a {b ""}} {$b eq ""? -$a: $a-$b}
```

```{=html}
</div>
```
Having the modulo operator exposed, *gcd* now looks nicer:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
func gcd {u v} {$u? [gcd [% $v $u] $u]: abs($v)}
```

```{=html}
</div>
```
For unary not I prefer that name to \"!\", as it might also stand for
factorial --- and see the shortest function body I ever wrote :\^) :

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
func not x {!$x}
```

```{=html}
</div>
```
Without big mention, functions implemented by recursion have a pattern
for which func is well suited (see *fac* and *gcd* above). Another
example is this integer range generator (starts from 1, and is
inclusive, so `[iota1 5] == {1 2 3 4 5}`):

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
func iota1 n {$n == 1? 1: [concat [iota1 [- $n 1]] $n]}
```

```{=html}
</div>
```
### Experiments with Boolean functions

\"NAND is not AND.\" Here are some Tcl codelets to demonstrate how all
Boolean operations can be expressed in terms of the single NAND
operator, which returns true if not both his two inputs are true (NOR
would have done equally well). We have Boolean operators in *expr*, so
here goes:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
proc nand {A B} {expr {!($A && $B)}}
```

```{=html}
</div>
```
The only unary operator NOT can be written in terms of nand:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
proc not {A} {nand $A $A}
```

```{=html}
</div>
```
.. and everything else can be built from them too:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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]}
```

```{=html}
</div>
```
Here\'s some testing tools --- to see whether an implementation is
correct, look at its truth table, here done as the four results for A,B
combinations 0,0 0,1 1,0 1,1 --- side note: observe how easily functions
can be passed in as arguments:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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
```

```{=html}
</div>
```
To see how efficient the implementation is (in terms of NAND units
used), try this, which relies on the fact that Boolean functions contain
no lowercase letters apart from the operator names:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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 +]
}
```

```{=html}
</div>
```
As a very different idea, having nothing to do with NAND as elementary
function, the following generic code \"implements\" Boolean functions
very intuitively, by just giving their truth table for look-up at
runtime:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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}
```

```{=html}
</div>
```
### Solving cryptarithms

Cryptarithms are puzzles where digits are represented by letters, and
the task is to find out which. The following \"General Problem Solver\"
(for small values of General) uses heavy metaprogramming: it

-   builds up a nest of foreachs suiting the problem,
-   quick kills (with continue) to force unique values for the
    variables, and
-   returns the first solution found, or else an empty string:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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} /$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
}
```

```{=html}
</div>
```
This works fine on some well-known cryptarithms:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
% solve SEND+MORE=MONEY
9567+1085==10652

% solve SAVE+MORE=MONEY
9386+1076==10462

% solve YELLOW+YELLOW+RED=ORANGE
143329+143329+846==287504
```

```{=html}
</div>
```
### Database experiments

#### A simple array-based database

There are lots of complex databases around. Here I want to explore how a
database can be implemented in the Tcl spirit of simplicity, and how far
that approach takes us. Consider the following model:

-   A database is a set of records
-   A record is a nonempty set of fields with a unique ID
-   A field is a pair of tag and nonempty value, both being strings

Fields may well be implemented as array entries, so we could have an
array per record, or better one array for the whole database, where the
key is composed of ID and tag. Unique IDs can be had by just counting up
(incrementing the highest ID so far). The process of creating a simple
database consists only of setting an initial value for the ID:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
set db(lastid) 0
```

```{=html}
</div>
```
Let\'s consider a library application for an example. Adding a book to
the database can be simply done by

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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
```

```{=html}
</div>
```
Note that, as we never specified what fields a record shall contain, we
can add whatever we see fit. For easier handling, it\'s a good idea to
classify records somehow (we\'ll want to store more than books), so we
add

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
set db($id,isa) book
```

```{=html}
</div>
```
Retrieving a record is as easy as this (though the fields come in
undefined order):

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
array get db $id,*
```

```{=html}
</div>
```
and deleting a record is only slightly more convolved:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
foreach i [array names db $id,*] {unset db($i)}
```

```{=html}
</div>
```
or, even easier and faster from Tcl 8.3 on:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
array unset db $id,*
```

```{=html}
</div>
```
Here\'s how to get a \"column\", all fields of a given tag:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
array get db *,title
```

```{=html}
</div>
```
But real columns may have empty fields, which we don\'t want to store.
Retrieving fields that may not physically exist needs a tolerant access
function:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
proc db'get {_db id field} {
   upvar $_db db
   if {[array names db $id,$field]=="$id,$field"} {
       return $db($id,$field)
   } else {return ""}
}
```

```{=html}
</div>
```
In a classical database we have to define tables: which fields of what
type and of which width. Here we can do what we want, even retrieve
which fields we have used so far (using a temporary array to keep track
of field names):

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
proc db'fields {_db} {
  upvar $_db db
  foreach i [array names db *,*] {
     set tmp([lindex [split $i ,] 1]) ""
  }
  lsort [array names tmp]
}
```

```{=html}
</div>
```
Searching for records that meet a certain condition can be done
sequentially. For instance, we want all books printed before 1980:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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)"
   }
}
```

```{=html}
</div>
```
We might also store our patrons in the same database (here in a
different style):

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
set i [incr $db(lastid)]
array set db [list $i,name "John F. Smith" $i,tel (123)456-7890 $i,isa  patron}
```

```{=html}
</div>
```
Without a concept of \"tables\", we can now introduce structures like in
relational databases. Assume John Smith borrows \"The Tempest\". We have
the patron\'s and book\'s ID in variables and do double bookkeeping:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
lappend db($patron,borrowed) $book ;# might have borrowed other books
set db($book,borrower) $patron
set db($book,dueback) 2001-06-12
```

```{=html}
</div>
```
When he returns the book, the process is reversed:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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)
```

```{=html}
</div>
```
The dueback field (`%Y-%M-%d` format is good for sorting and comparing)
is useful for checking whether books have not been returned in time:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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)"
   }
}
```

```{=html}
</div>
```
Likewise, parts of the accounting (e.g. orders to, and bills from,
booksellers) can be added with little effort, and cross-related also to
external files (just set the value to the filename).

*Indexes:* As shown, we can retrieve all data by sequential searching
over array names. But if the database grows in size, it\'s a good idea
to create indexes which cross-reference tags and values to IDs. For
instance, here\'s how to make an authors\' index in four lines:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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]"
   }
}
```

```{=html}
</div>
```
gives us a books list of all authors matching the given glob pattern (we
reuse Tcl\'s functionality, instead of reinventing it\...). Indexes are
useful for repeated information that is likely to be searched.
Especially, indexing the isa field allows iterating over \"tables\"
(which we still don\'t explicitly have!;-):

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
regsub -all isa= [array names db isa=*] "" tables
foreach patron $db(isa=patron) {...}
```

```{=html}
</div>
```
And beyond industry-standard SQL, we can search multiple indices in one
query:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
array names db *=*MARK*
```

```{=html}
</div>
```
gives you all (case-independent) occurrences of MARK, be it in patron\'s
names, book\'s authors or titles. As versatile as good old grep\...

**Persistence:** Databases are supposed to exist between sessions, so
here\'s how to save a database to a file:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
set fp [open Library.db w]
puts $fp [list array set db [array get db]]
close $fp
```

```{=html}
</div>
```
and loading a database is even easier (on re-loading, better unset the
array before):

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
source Library.db
```

```{=html}
</div>
```
If you use characters outside your system encoding (no problem to write
Japanese book titles in Kanji), you\'ll have to fconfigure (e.g
-encoding utf-8) on saving and loading, but that\'s just a few more LOC.
Saving also goes a good way to what is ceremonially called
\"committing\" (you\'ll need write-locking for multi-user systems),
while loading (without saving before) might be called a \"one-level
rollback\", where you want to discard your latest changes.

Notice that so far we have only defined one short proc, all other
operations were done with built-in Tcl commands only. For clearer code,
it is advisable to factor out frequent operations into procs, e.g.

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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
}
```

```{=html}
</div>
```
Of course, with growing databases we may reach memory limits: arrays
need some extra storage for administration. On the other hand, the
present approach is pretty economic, since it does not use field widths
(all strings are \"shrink-wrapped\"), and omits empty fields, while at
the same time allowing to add whatever fields you wish. A further
optimization could be to tally value strings, and replace the frequent
ones with \"`@$id`\", where `db(@$id)` holds the value once, and only
db\'get has to be adapted to redirect the query.

Also, memory limits on modern computers are somewhere up high\... so
only at some time in the future you might have (but maybe not want) to
change to a complex database ;-)

**On the limits:** Tcl arrays may get quite large (one app was reported
to store 800000 keys in Greek characters), and at some point enumerating
all keys with array names db (which produces one long list) may exceed
your available memory, causing the process to swap. In that situation,
you can fall back to the (otherwise slower, and uglier) use of a
dedicated iterator:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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
```

```{=html}
</div>
```
But neither can you filter the keys you will get with a glob pattern,
nor may you add or delete array elements in the loop --- the search will
be immediately terminated.

#### Tables as lists of lists

Tables are understood here as rectangular (matrix) arrangements of data
in rows (one row per \"item\"/\"record\") and columns (one column per
\"field\"/\"element\"). They are for instance the building blocks of
relational databases and spreadsheets. In Tcl, a sensible implementation
for compact data storage would be as a list of lists. This way, they are
\"pure values\" and can be passed e.g. through functions that take a
table and return a table. No con-/destructors are needed, in contrast to
the heavierweight matrix in Tcllib. I know there are many table
implementations in Tcl, but like so often I wanted to build one \"with
my bare hands\" and as simple as possible. As you see below, many
functionalities can be \"implemented\" by just using Tcl\'s list
functions.

A nice table also has a header line, that specifies the field names. So
to create such a table with a defined field structure, but no contents
yet, one just assigns the header list:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
set tbl { {firstname lastname phone}}
```

```{=html}
</div>
```
Note the double bracing, which makes sure tbl is a 1-element list.
Adding \"records\" to the table is as easy as

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
lappend tbl {John Smith (123)456-7890}
```

```{=html}
</div>
```
Make sure the fields (cells) match those in the header. Here single
bracing is correct. If a field content contains spaces, it must be
quoted or braced too:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
lappend tbl {{George W} Bush 234-5678}
```

```{=html}
</div>
```
Sorting a table can be done with lsort -index, taking care that the
header line stays on top:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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
}
```

```{=html}
</div>
```
Removing a row (or contiguous sequence of rows) by numeric index is a
job for lreplace:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
set tbl [lreplace $tbl $from $to]
```

```{=html}
</div>
```
Simple printing of such a table, a row per line, is easy with

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
puts [join $tbl \n]
```

```{=html}
</div>
```
Accessing fields in a table is more fun with the field names than the
numeric indexes, which is made easy by the fact that the field names are
in the first row:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
proc t@ {tbl field} {lsearch [lindex $tbl 0] $field}
% t@ $tbl phone
2
```

```{=html}
</div>
```
You can then access cells:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
puts [lindex $tbl $rownumber [t@ $tbl lastname]]
```

```{=html}
</div>
```
and replace cell contents like this:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
lset tbl $rownumber [t@ $tbl phone] (222)333-4567
```

```{=html}
</div>
```
Here is how to filter a table by giving pairs of field name and
glob-style expression --- in addition to the header line, all rows that
satisfy at least one of those come through (you can force AND behavior
by just nesting such calls):

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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}
```

```{=html}
</div>
```
This filters (and, if wanted, rearranges) columns, sort of what is
called a \"view\":

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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
}
```

```{=html}
</div>
```
### Programming Languages Laboratory

In the following few chapters you\'ll see how easy it is to emulate or
explore other programming languages with Tcl.

#### GOTO: a little state machine

The GOTO \"jumping\" instruction is considered harmful in programming
for many years now, but still it might be interesting to experiment
with. Tcl has no *goto* command, but it can easily be created. The
following code was created in the Tcl chatroom, instigated by the quote:
\"A computer is a state machine. Threads are for people who can\'t
program state machines.\"

So here is one model of a state machine in ten lines of code. The
\"machine\" itself takes a list of alternating labels and state code; if
a state code does not end in a goto or break, the same state will be
repeated as long as not left, with goto or break (implicit endless
loop). The goto command is defined \"locally\", and deleted after
leaving the state machine --- it is not meaningfully used outside of it.
Execution starts at the first of the states.

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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 {}
}
```

```{=html}
</div>
```
Testing: a tiny state machine that greets you as often as you wish, and
ends if you only hit  on the \"how
often?\" question:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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}
}
```

```{=html}
</div>
```
#### Playing Assembler

In this weekend fun project to emulate machine language, I picked those
parts of Intel 8080A/8085 Assembler (because I had a detailed reference
handy) that are easily implemented and still somehow educational (or
nostalgic ;-).

Of course this is no real assembler. The memory model is constant-size
instructions (strings in array elements), which are implemented as Tcl
procs. So an \"assembler\" program in this plaything will run even
slower than in pure Tcl, and consume more memory --- while normally you
associate speed and conciseness with \"real\" assembler code. But it
looks halfway like the real thing: you get sort of an assembly listing
with symbol table, and can run it --- I\'d hardly start writing an
assembler in C, but in Tcl it\'s fun for a sunny Sunday afternoon\... }

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` 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}
}
```

```{=html}
</div>
```
Now testing:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` asm
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
}
```

```{=html}
</div>
```
The `mov b,INCR` part is an oversimplification. For a real 8080, one
would have to say

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` asm
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
```

```{=html}
</div>
```
Since the pseudo-register M can also be used for writing back, it cannot
be implemented by simply copying the value. Rather, one could use read
and write traces on variable M, causing it to load from, or store to,
mem(\$HL). Maybe another weekend\...

#### Functional programming (Backus 1977)

John Backus turned 80 these days. For creating FORTRAN and the BNF style
of language description, he received the ACM Turing Award in 1977. In
his Turing Award lecture,

*Can Programming Be Liberated from the von Neumann Style? A Functional
Style and Its Algebra of Programs. (Comm. ACM 21.8, Aug. 1978, 613-641)*

he developed an amazing framework for functional programming, from
theoretical foundations to implementation hints, e.g. for installation,
user privileges, and system self-protection. In a nutshell, his FP
system comprises

-   a set O of objects (atoms or sequences)
-   a set F of functions that map objects into objects (`f : O |-> O`}
-   an operation, application (very roughly, eval)
-   a set FF of functional forms, used to combine functions or objects
    to form new functions in F
-   a set D of definitions that map names to functions in F

I\'m far from having digested it all, but like so often, interesting
reading prompts me to do Tcl experiments, especially on weekends. I
started with Backus\' first Functional Program example,

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
Def Innerproduct = (Insert +) o (ApplyToAll x) o Transpose
```

```{=html}
</div>
```
and wanted to bring it to life --- slightly adapted to Tcl style,
especially by replacing the infix operator \"o\" with a Polish prefix
style:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
Def Innerproduct = {o {Insert +} {ApplyToAll *} Transpose}
```

```{=html}
</div>
```
Unlike procs or lambdas, more like APL or RPN, this definition needs no
variables --- it declares (from right to left) what to do with the
input; the result of each step is the input for the next step (to the
left of it). In an RPN language, the example might look like this:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
/Innerproduct {Transpose * swap ApplyToAll + swap Insert} def
```

```{=html}
</div>
```
which has the advantage that execution goes from left to right, but
requires some stack awareness (and some swaps to set the stack right
;\^)

Implementing Def, I took an easy route by just creating a proc that adds
an argument and leaves it to the \"functional\" to do the right thing
(with some quoting heaven :-) }

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
proc Def {name = functional} {
   proc $name x "\[$functional\] \$x"
}
```

```{=html}
</div>
```
For functional composition, where, say for two functions f and g,

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
[{o f g} $x] == [f [g $x]]
```

```{=html}
</div>
```
again a proc is created that does the bracket nesting:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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
}
```

```{=html}
</div>
```
Why Backus used Transpose on the input, wasn\'t first clear to me, but
as he (like we Tclers) represents a matrix as a list of rows, which are
again lists (also known as vectors), it later made much sense to me.
This code for transposing a matrix uses the fact that variable names can
be any string, including those that look like integers, so the column
contents are collected into variables named 0 1 2 \... and finally
turned into the result list:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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
}
```

```{=html}
</div>
```
An integer range generator produces the variable names, e.g
`iota 3 => {0 1 2}`

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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
}
```

```{=html}
</div>
```
\...and Insert is better known as fold, I suppose. My oversimple
implementation assumes that the operator is one that expr understands:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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}}]
```

```{=html}
</div>
```
which returns 28 just as Dr. Backus ordered (= 1\*6 + 2\*5 + 3\*4). Ah,
the joys of weekend Tcl\'ing\... --- and belatedly, Happy Birthday,
John! :)

Another example, cooked up by myself this time, computes the average of
a list. For this we need to implement the construction operator, which
is sort of inverse mapping --- while mapping a function over a sequence
of inputs produces a sequence of outputs of that function applied to
each input, Backus\' construction maps a sequence of functions over one
input to produce a sequence of results of each function to that input,
e.g.

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
f,g == <f(x),g(x)>
```

```{=html}
</div>
```
Of course I can\'t use circumfix brackets as operator name, so let\'s
call it constr:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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}]
```

```{=html}
</div>
```
which returns correctly 3. However, as integer division takes place, it
would be better to make that

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
proc double x {expr {double($x)}}

Def mean    = {o {Insert /} {constr {Insert +} dlength}}
Def dlength = {o double llength}

puts [mean {1 2 3 4}]
```

```{=html}
</div>
```
giving the correct result 2.5. However, the auxiliary definition for
dlength cannot be inlined into the definition of mean --- so this needs
more work\... But this version, that maps double first, works:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
Def mean = {o {Insert /} {constr {Insert +} llength} {ApplyToAll double}}
```

```{=html}
</div>
```
One more experiment, just to get the feel:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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}]
```

```{=html}
</div>
```
which gives 5.0. Compared to an RPN language, hypot would be

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
/hypot {dup * swap dup * + sqrt} def
```

```{=html}
</div>
```
which is shorter and simpler, but meddles more directly with the stack.

An important functional form is the conditional, which at Backus looks
like

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` text
p1 -> f; p2 -> g; h
```

```{=html}
</div>
```
meaning, translated to Tcl,

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
if {[p1 $x]} then {f $x} elseif {[p2 $x]} then {g $x} else {h $x}
```

```{=html}
</div>
```
Let\'s try that, rewritten Polish-ly to:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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}
```

```{=html}
</div>
```
#### Reusable functional components

Say you want to make a multiplication table for an elementary school kid
near you. Easily done in a few lines of Tcl code:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` 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
}
```

```{=html}
</div>
```
The code does not directly puts its results, but returns them as a
string --- you might want to do other things with it, e.g. save it to a
file for printing. Testing:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
% 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
```

```{=html}
</div>
```
Or print the result directly from wish:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
 catch {console show}
 puts "[multable 3 10]"
```

```{=html}
</div>
```
Here\'s a different way to do it à la functional programming:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
proc multable2 {rows cols} {
   formatMatrix %4d [outProd * [iota 1 $rows] [iota 1 $cols]]
}
```

```{=html}
</div>
```
The body is nice and short, but consists of all unfamiliar commands.
They are however better reusable than the *multable* proc above. The
first formats a matrix (a list of lists to Tcl) with newlines and
aligned columns for better display:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
proc formatMatrix {fm matrix} {
   join [lmap row $matrix {join [lmap i $row {format $fm $i}] ""}] \n
}
```

```{=html}
</div>
```
Short again, and slightly cryptic, as is the \"outer product\" routine,
which takes a function f and two vectors, and produces a matrix where f
was applied to every pair of a x b --- in APL they had special compound
operators for this job, in this case \"°.x\":

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
proc outProd {f a b} {
   lmap i $a {lmap j $b {$f $i $j}}
}
```

```{=html}
</div>
```
Again, lmap (the collecting foreach) figures prominently, so here it is
in all its simplicity:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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
}
```

```{=html}
</div>
```
With these parts in place, we can see that *multable2* works as we want:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
% 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
```

```{=html}
</div>
```
So why write six procedures, where one did the job already? A matter of
style and taste, in a way --- *multable* is 10 LOC and depends on
nothing but Tcl, which is good; *multable2* describes quite concisely
what it does, and builds on a few other procs that are highly reusable.

Should you need a unit matrix (where the main diagonal is 1, and the
rest is 0), just call outProd with a different function (equality, ==):

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
% 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}
```

```{=html}
</div>
```
which just requires expr\'s equality to be exposed too:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
proc == {a b} {expr {$a == $b}}
```

```{=html}
</div>
```
One of the fascinations of functional programming is that one can do the
job in a simple and clear way (typically a one-liner), while using a
collection of reusable building-blocks like lmap and iota. And
*formatMatrix* and *outProd* are so general that one might include them
in some library, while the task of producing a multiplication table may
not come up any more for a long time\...

#### Modelling an RPN language

Tcl follows strictly the Polish notation, where an operator or function
always precedes its arguments. It is however easy to build an
interpreter for a language in Reverse Polish Notation (RPN) like Forth,
Postscript, or Joy, and experiment with it.

The \"runtime engine\" is just called \"r\" (not to be confused with the
R language), and it boils down to a three-way switch done for each word,
in eleven lines of code:

-   \"tcl\" evaluates the top of stack as a Tcl script
-   known words in the `::C` array are recursively evaluated in \"r\"
-   other words are just pushed

Joy\'s rich quoting for types (\[list\], {set}, \"string\", \'char)
conflict with the Tcl parser, so lists in \"r\" are {braced} if their
length isn\'t 1, and (parenthesized) if it is --- but the word shall not
be evaluated now. This looks better to me than /slashing as in
Postscript.

As everything is a string, and to Tcl \"a\" is {a} is a , Joy\'s
polymorphy has to be made explicit. I added converters between
characters and integers, and between strings and lists (see the
dictionary below). For Joy\'s sets I haven\'t bothered yet --- they are
restricted to the domain 0..31, probably implemented with bits in a
32-bit word.

Far as this is from Joy, it was mostly triggered by the examples in
Manfred von Thun\'s papers, so I tongue-in-cheek still call it \"Pocket
Joy\" --- it was for me, at last, on the iPaq\... The test suite at end
should give many examples of what one can do in \"r\". }

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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
}
```

```{=html}
</div>
```
\# That\'s it. Stack (list) and Command array are global variables:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
set S {}; unset C
```

```{=html}
</div>
```
#\-- A tiny switchable debugger:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
proc d+ {} {proc dputs s {puts $s}}
proc d- {}  {proc dputs args {}}
d- ;#-- initially, debug mode off
```

```{=html}
</div>
```
Definitions are in Forth style --- \":\" as initial word, as they look
much more compact than Joy\'s *DEFINE n == args;*

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
proc : {n args} {set ::C($n) $args}
```

```{=html}
</div>
```
*expr* functionality is exposed for binary operators and one-arg
functions:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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  !=
```

```{=html}
</div>
```
Helper functions written in Tcl:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` 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
```

```{=html}
</div>
```
#### Tacit programming

The J programming language is the \"blessed successor\" to APL, where
\"every function is an infix or prefix operator\", `x?y` (dyadic) or
`?y` (monadic), for `?` being any pre- or user-defined function).

\"Tacit programming\" (*tacit*: implied; indicated by necessary
connotation though not expressed directly) is one of the styles possible
in J, and means coding by combining functions, without reference to
argument names. This idea may have been first brought up in Functional
programming (Backus 1977), if not in Forth and Joy, and it\'s an
interesting simplification compared to the lambda calculus.

For instance, here\'s a breathtakingly short J program to compute the
mean of a list of numbers:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` text
mean=.+/%#
```

```{=html}
</div>
```
Let\'s chew this, byte by byte :)

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` text
=.   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]
```

```{=html}
</div>
```
Only implicitly present is a powerful function combinator called
\"fork\". When J parses three operators in a row, gfh, where f is dyadic
and g and h are monadic, they are combined like the following Tcl
version does:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
proc fork {f g h x} {$f [$g $x] [$h $x]}
```

```{=html}
</div>
```
In other words, f is applied to the results of applying g and h to the
single argument. Note that `+/` is considered one operator, which
applies the \"adverb\" folding to the \"verb\" addition (one might well
call it \"sum\"). When two operands occur together, the \"hook\" pattern
is implied, which might in Tcl be written as:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
proc hook {f g x} {$f $x [$g $x]}
```

```{=html}
</div>
```
As KBK pointed out in the Tcl chatroom, the \"hook\" pattern corresponds
to Schönfinkel/Curry\'s S combinator (see Hot Curry and Combinator
Engine), while \"fork\" is called S\' there.

Unlike in earlier years when I was playing APL, this time my aim was not
to parse and emulate J in Tcl --- I expected hard work for a dubitable
gain, and this is a weekend fun project after all. I rather wanted to
explore some of these concepts and how to use them in Tcl, so that in
slightly more verbose words I could code (and call)

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
Def mean = fork /. sum llength
```

```{=html}
</div>
```
following Backus\' FP language with the \"Def\" command. So let\'s get
the pieces together. My \"Def\" creates an interp alias, which is a good
and simple Tcl way to compose partial scripts (the definition, here)
with one or more arguments, also known as \"currying\":

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
proc Def {name = args} {eval [list interp alias {} $name {}] $args}
```

```{=html}
</div>
```
The second parameter, \"=\", is for better looks only and evidently
never used.

Testing early and often is a virtue, as is documentation --- to make the
following code snippets clearer, I tuned my little tester for better
looks, so that the test cases in the source code also serve as well
readable examples --- they look like comments but are code! The cute
name \"e.g.\" was instigated by the fact that in J, \"NB.\" is used as
comment indicator, both being well known Latin abbreviations:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
proc e.g. {cmd -> expected} {
   catch {uplevel 1 $cmd} res
   if {$res != $expected} {puts "$cmd -> $res, not $expected"}
}
```

```{=html}
</div>
```
Again, the \"`->`\" argument is for eye-candy only --- but it feels
better to me at least. See the examples soon to come.

For recursive functions and other arithmetics, func makes better
reading, by accepting expr language in the body:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
proc func {name argl body} {proc $name $argl [list expr $body]}
```

```{=html}
</div>
```
We\'ll use this to turn expr\'s infix operators into dyadic functions,
plus the \"slashdot\" operator that makes division always return a real
number, hence the dot :

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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}
```

```{=html}
</div>
```
For \"fold\", this time I devised a recursive version:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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
```

```{=html}
</div>
```
Tacit enough (one might have picked fancier names like +/ for \"sum\"
and \# as alias for llength), but in principle it is equivalent to the J
version, and doesn\'t name a single argument. Also, the use of llength
demonstrates that any good old Tcl command can go in here, not just the
artificial Tacit world that I\'m just creating\...

In the next step, I want to reimplement the \"median\" function, which
for a sorted list returns the central element if its length is odd, or
the mean of the two elements adjacent to the (virtual) center for even
length. In J, it looks like this:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` text
median=.(mean@:\{~medind@#)@sortu
medind=.((<.,>.)@half) ` half @.(2&|)
half=.-:@<:                        NB. halve one less than rt. argument
sortu=.\{~/:                       NB. sort upwards
```

```{=html}
</div>
```
which may better explain why I wouldn\'t want to code in J :\^) J has
ASCIIfied the zoo of APL strange character operators, at the cost of
using braces and brackets as operators too, without regard for
balancing, and extending them with dots and colons, so e.g.

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` text
-   monadic: negate; dyadic: minus
-.  monadic: not
-:  monadic: halve
```

```{=html}
</div>
```
J code sometimes really looks like an accident in a keyboard factory\...
I won\'t go into all details of the above code, just some:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` text
@ ("atop") is strong linkage, sort of functional composition
<. (monadic) is floor()
>. (monadic) is ceil()
```

```{=html}
</div>
```
(\<.,\>.) is building a list of the floor and the ceiling of its single
argument, the comma being the concatenation operator here, comparable to
Backus\' \"construction\" or Joy\'s cleave. The pattern

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` text
a ` b @. c
```

```{=html}
</div>
```
is a kind of conditional in J, which could in Tcl be written

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
if {[$c $x]} {$a $x} else {$b $x}
```

```{=html}
</div>
```
but my variant of the median algorithm doesn\'t need a conditional ---
for lists of odd length it just uses the central index twice, which is
idempotent for \"mean\", even if a tad slower.

J\'s \"from\" operator `{` takes zero or more elements from a list,
possibly repeatedly. For porting this, lmap is a good helper, even
though not strictly functional:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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}
```

```{=html}
</div>
```
We furtheron borrow some more content from expr:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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}
```

```{=html}
</div>
```
We\'ll need functional composition, and here\'s a recursive de-luxe
version that takes zero or more functions, hence the name `o*`:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
func o* {functions x} {
   $functions eq []? $x
   : [[head $functions] [o* [tail $functions] $x]]
}
e.g. {o* {} hello,world} -> hello,world
```

```{=html}
</div>
```
Evidently, identity as could be written

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
proc I x {set x}
```

```{=html}
</div>
```
is the neutral element of variadic functional composition, when called
with no functions at all.

If composite functions like \'fork\' are arguments to o\*, we\'d better
let unknown know that we want auto-expansion of first word:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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]]}
}
```

```{=html}
</div>
```
Also, we need a numeric sort that\'s good for integers as well as reals
(\"Def\" serves for all kinds of aliases, not just combinations of
functions):

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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
```

```{=html}
</div>
```
As this file gets tacitly sourced, I am pretty confident that I\'ve
reached my goal for this weekend --- even though my median doesn\'t
remotely look like the J version: it is as \"wordy\" as Tcl usually is.
But the admittedly still very trivial challenge was met in truly
function-level style, concerning the definitions of median, center and
mean --- no variable left behind. And that is one, and not the worst,
Tcl way of Tacit programming\...

### Vector arithmetics

APL and J (see Tacit programming) have the feature that arithmetics can
be done with vectors and arrays as well as scalar numbers, in the
varieties (for any operator @):

-   scalar @ scalar → scalar (like expr does)
-   vector @ scalar → vector
-   scalar @ vector → vector
-   vector @ vector → vector (all of same dimensions, element-wise)

Here\'s experiments how to do this in Tcl. First lmap is a collecting
foreach --- it maps the specified body over a list:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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}"}
```

```{=html}
</div>
```
The following generic wrapper takes one binary operator (could be any
suitable function) and two arguments, which may be scalars, vectors, or
even matrices (lists of lists), as it recurses as often as needed. Note
that as my lmap above only takes one list, the two-list case had to be
made explicit with foreach.

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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]"}
}
```

```{=html}
</div>
```
Tests are done with this minimal \"framework\":

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
proc e.g. {cmd -> expected} {
    catch $cmd res
    if {$res ne $expected} {puts "$cmd -> $res, not $expected"}
}
```

```{=html}
</div>
```
Scalar + Scalar

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
e.g. {vec + 1 2} -> 3
```

```{=html}
</div>
```
Scalar + Vector

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
e.g. {vec + 1 {1 2 3 4}} -> {2 3 4 5}
```

```{=html}
</div>
```
Vector / Scalar

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
e.g. {vec / {1 2 3 4} 2.} -> {0.5 1.0 1.5 2.0}
```

```{=html}
</div>
```
Vector + Vector

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
e.g. {vec + {1 2 3} {4 5 6}} -> {5 7 9}
```

```{=html}
</div>
```
Matrix \* Scalar

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
e.g. {vec * {{1 2 3} {4 5 6}} 2} -> {{2 4 6} {8 10 12}}
```

```{=html}
</div>
```
Multiplying a 3x3 matrix with another:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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}}
```

```{=html}
</div>
```
The dot product of two vectors is a scalar. That\'s easily had too,
given a sum function:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
proc sum list {expr [join $list +]+0}
sum [vec * {1 2} {3 4}]
```

```{=html}
</div>
```
should result in 11 (= (1\*3)+(2\*4)).

Here\'s a little application for this: a vector factorizer, that
produces the list of divisors for a given integer. For this we again
need a 1-based integer range generator:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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}
```

```{=html}
</div>
```
At this point, a number is prime if the sum of the latest vector is 2.
But we can also multiply out the 1s with the divisors from the i ndex
vector:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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}
```

```{=html}
</div>
```
So 6 is divisible by 2 and 3; non-zero elements in (lrange \$divisors 1
end-1) gives the \"proper\" divisors. And three nested calls to vec are
sufficient to produce the divisors list :)

Just for comparison, here\'s how it looks in J:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
   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
```

```{=html}
</div>
```
### Integers as Boolean functions

Boolean functions, in which arguments and result are in the domain
{true, false}, or {1, 0} as expr has it, and operators are e.g. {AND,
OR, NOT} resp. {&&, \|\|, !}, can be represented by their truth table,
which for example for {\$a && \$b} looks like:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
a b  a&&b
0 0  0
1 0  0
0 1  0
1 1  1
```

```{=html}
</div>
```
As all but the last column just enumerate all possible combinations of
the arguments, first column least-significant, the full representation
of a&&b is the last column, a sequence of 0s and 1s which can be seen as
binary integer, reading from bottom up: `1 0 0 0 == 8`. So 8 is the
associated integer of `a&&b`, but not only of this --- we get the same
integer for `!(!a || !b)`, but then again, these functions are
equivalent.

To try this in Tcl, here\'s a truth table generator that I borrowed from
a little proving engine, but without the lsort used there --- the order
of cases delivered makes best sense when the first bit is least
significant: }

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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
}
```

```{=html}
</div>
```
Now we can write n(f), which, given a Boolean function of one or more
arguments, returns its characteristic number, by iterating over all
cases in the truth table, and setting a bit where appropriate:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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
}
```

```{=html}
</div>
```
Experimenting:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
% 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
```

```{=html}
</div>
```
So the characteristic integer is not the same as the Goedel number of a
function, which would encode the structure of operators used there.

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
% n(f) {!($a || $b)} ;#-- interesting: same as unary NOT
1
% n(f) {!$a && !$b}
1
```

```{=html}
</div>
```
Getting more daring, let\'s try a distributive law:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
% n(f) {$p && ($q || $r)}
168
% n(f) {($p && $q) || ($p && $r)}
168
```

```{=html}
</div>
```
Daring more: what if we postulate the equivalence?

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
% n(f) {(($p && $q) || ($p && $r)) == ($p && ($q || $r))}
255
```

```{=html}
</div>
```
Without proof, I just claim that every function of n arguments whose
characteristic integer is `2^(2^n)` --- 1 is a tautology (or a true
statement --- all bits are 1). Conversely, postulating non-equivalence
turns out to be false in all cases, hence a contradiction:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
% n(f) {(($p && $q) || ($p && $r)) != ($p && ($q || $r))}
0
```

```{=html}
</div>
```
So again, we have a little proving engine, and simpler than last time.

In the opposite direction, we can call a Boolean function by its number
and provide one or more arguments --- if we give more than the function
can make sense of, non-false excess arguments lead to constant falsity,
as the integer can be considered zero-extended:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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))
}
```

```{=html}
</div>
```
Trying again, starting at OR (14):

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
% f(n) 14 0 0
0
% f(n) 14 0 1
1
% f(n) 14 1 0
1
% f(n) 14 1 1
1
```

```{=html}
</div>
```
So f(n) 14 indeed behaves like the OR function --- little surprise, as
its truth table (the results of the four calls), read bottom-up, 1110,
is decimal 14 (8 + 4 + 2). Another test, inequality:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
% 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
```

```{=html}
</div>
```
Trying to call 14 (OR) with more than two args:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
% f(n) 14 0 0 1
0
% f(n) 14 0 1 1
0
53 % f(n) 14 1 1 1
0
```

```{=html}
</div>
```
The constant 0 result is a subtle indication that we did something wrong
:)

Implication (if a then b, `a -> b`) can in expr be expressed as
`$a <= $b` --- just note that the \"arrow\" seems to point the wrong
way. Let\'s try to prove \"Modus Barbara\" --- \"if a implies b and b
implies c, then a implies c\":

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
% n(f) {(($a <= $b) && ($b <= $c)) <= ($a <= $c)}
255
```

```{=html}
</div>
```
With less abstract variable names, one might as well write

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
% n(f) {(($Socrates <= $human) && ($human <= $mortal)) <= ($Socrates <= $mortal)}
255
```

```{=html}
</div>
```
But this has been verified long ago, by Socrates\' death :\^)

### Let unknown know

To extend Tcl, i.e. to make it understand and do things that before
raised an error, the easiest way is to write a proc. Any proc must
however be called in compliance with Tcl\'s fundamental syntax: first
word is the command name, then the arguments separated by whitespace.
Deeper changes are possible with the unknown command, which is called if
a command name is, well, unknown, and in the standard version tries to
call executables, to auto-load scripts, or do other helpful things (see
the file `init.tcl`). One could edit that file (not recommended), or
rename unknown to something else and provide one\'s own unknown handler,
that falls through to the original proc if unsuccessful, as shown in
Radical language modification.

Here is a simpler way that allows to extend unknown \"in place\" and
incrementally: We let unknown \"know\" what action it shall take under
what conditions. The know command is called with a condition that should
result in an integer when given to expr, and a body that will be
executed if cond results in nonzero, returning the last result if not
terminated with an explicit return. In both cond and body you may use
the variable args that holds the problem command unknown was invoked
with.

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
proc know what {
   if ![info complete $what] {error "incomplete command(s) $what"}
   proc unknown args $what\n[info body unknown]
} ;# RS
```

```{=html}
</div>
```
The extending code *what* is prepended to the previous unknown body.
This means that subsequent calls to know stack up, last condition being
tried first, so if you have several conditions that fire on the same
input, let them be \"known\" from generic to specific.

Here\'s a little debugging helper, to find out why \"know\" conditions
don\'t fire:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
proc know? {} {puts [string range [info body unknown] 0 511]}
```

```{=html}
</div>
```
Now testing what new magic this handful of code allows us to do. This
simple example invokes expr if the \"command\" is digestible for it:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
% know {if {![catch {expr $args} res]} {return $res}}
% 3+4
7
```

```{=html}
</div>
```
### If we had no if

Imagine the makers of Tcl had failed to provide the if command. All the
rest would be there. Doing more steps towards functional programming, I
came upon this interesting problem, and will shortly demonstrate that it
can easily be solved in pure-Tcl.

We still have the canonical truth values 0 and 1 as returned from expr
with a comparison operator. The idea in the paper I read is to use them
as names of very simple functions:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
proc 0 {then else} {uplevel 1 $else}
proc 1 {then else} {uplevel 1 $then} ;# the famous K combinator
```

```{=html}
</div>
```
Glory be to the 11 rules of man Tcl that this is already a crude though
sufficient reimplementation:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
set x 42
[expr $x<100] {puts Yes} {puts No}
```

```{=html}
</div>
```
The bracketed expr command is evaluated first, returning 0 or 1 as
result of the comparison. This result (0 or 1) is substituted for the
first word of this command. The other words (arguments) are not
substituted because they\'re curly-braced, so either 0 or 1 is invoked,
and does its simple job. (I used uplevel instead of eval to keep all
side effects in caller\'s scope). Formally, what happened to the
bracketed call is that it went through \"applicative order\" evaluation
(i.e., do it now), while the braced commands wait for \"normal order\"
evaluation (i.e., do when needed, maybe never --- the need is expressed
through eval/upvar or similar commands).

Though slick at first sight, we actually have to type more. As a second
step, we create the If command that wraps the expr invocation:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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"}
```

```{=html}
</div>
```
This again passes impromptu tests, and adds the feature that any
non-zero value counts as true and returns 1 --- if we neglect the other
syntactic options of if, especially the elseif chaining. However, this
is no fundamental problem --- consider that

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
if A then B elseif C then D else E
```

```{=html}
</div>
```
can be rewritten as

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
if A then B else {if C then D else E}
```

```{=html}
</div>
```
so the two-way If is about as mighty as the real thing, give or take a
few braces and redundant keywords (then, else).

Luckily we have an if in Tcl (and it certainly fares better in byte-code
compilation), but on leisurely evenings it\'s not the microseconds that
count (for me at least) --- it\'s rather reading on the most surprising
(or fundamental) ideas, and demonstrating how easily Tcl can bring them
to life\...

### Brute force meets Goedel

Never afraid of anything (as long as everything is a string), a
discussion in the Tcl chatroom brought me to try the following: let the
computer write (\"discover\") its own software, only given
specifications of input and output. In truly brute force, up to half a
million programs are automatically written and (a suitable subset of
them) tested to find the one that passes the tests.

To make things easier, this flavor of \"software\" is in a very simple
RPN language similar to, but much smaller than, the one presented in
Playing bytecode: stack-oriented like Forth, each operation being one
byte (ASCII char) wide, so we don\'t even need whitespace in between.
Arguments are pushed on the stack, and the result of the \"software\",
the stack at end, is returned. For example, in

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
ebc ++ 1 2 3
```

```{=html}
</div>
```
execution of the script \"++\" should sum its three arguments (1+(2+3)),
and return 6.

Here\'s the \"bytecode engine\" (ebc: execute byte code), which
retrieves the implementations of bytecodes from the global array cmd:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
proc ebc {code argl} {
   set ::S $argl
   foreach opcode [split $code ""] {
       eval $::cmd($opcode)
   }
   set ::S
}
```

```{=html}
</div>
```
Let\'s now populate the bytecode collection. The set of all defined
bytecodes will be the alphabet of this little RPN language. It may be
interesting to note that this language has truly minimal syntax --- the
only rule is: each script (\"word\") composed of any number of bytecodes
is well-formed. It just remains to check whether it does what we want.

Binary expr operators can be treated generically:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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]}
```

```{=html}
</div>
```
Instead of enumerating all possible bytecode combinations beforehand
(which grows exponentially by alphabet and word length), I use this code
from Mapping words to integers to step over their sequence, uniquely
indexed by an increasing integer. This is something like the Goedel
number of the corresponding code. Note that with this mapping, all valid
programs (bytecode sequences) correspond to one unique non-negative
integer, and longer programs have higher integers associated:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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
}
```

```{=html}
</div>
```
Now out for discovery! The toplevel proc takes a paired list of inputs
and expected output. It tries in brute force all programs up to the
specified maximum Goedel number and returns the first one that complies
with all tests:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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}
   }
}
```

```{=html}
</div>
```
But iterating over many words is still pretty slow, at least on my 200
MHz box, and many useless \"programs\" are tried. For instance, if the
test has two inputs and wants one output, the stack balance is -1 (one
less out than in). This is provided e.g. by one the binary operators
+-\*/. But the program \"dd\" (which just duplicates the top of stack
twice) has a stack balance of +2, and hence can never pass the example
test. So, on a morning dogwalk, I thought out this strategy:

-   measure the stack balance for each bytecode
-   iterate once over very many possible programs, computing their stack
    balance
-   partition them (put into distinct subsets) by stack balance
-   perform each \'discovery\' call only on programs of matching stack
    balance

Here\'s this version. Single bytecodes are executed, only to measure
their effect on the stack. The balance of longer programs can be
computed by just adding the balances of their individual bytecodes:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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
}
```

```{=html}
</div>
```
The partitioning will run for some seconds (depending on nmax --- I
tried with several ten thousand), but it\'s needed only once. The size
of partitions is further reduced by excluding programs which contain
redundant code, that will have no effect, like swapping the stack twice,
or swapping before an addition or multiplication. A program without such
extravaganzas is shorter and yet does the same job, so it will have been
tested earlier anyway.

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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
}
```

```{=html}
</div>
```
The discoverer, Second Edition, determines the stack balance of the
first text, and tests only those programs of the same partition:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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}
   }
}
```

```{=html}
</div>
```
But now for the trying. The partitioning helps very much in reducing the
number of candidates. For the 1000 programs with Goedel numbers 1..1000,
it retains only a fraction for each stack balance:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
-2: 75
-1: 155 (this and 0 will be the most frequently used)
0: 241
1: 274
2: 155
3: 100
```

```{=html}
</div>
```
Simple starter --- discover the successor function (add one):

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
% discover 5 6  7 8
dd/+
```

```{=html}
</div>
```
Not bad: duplicate the number twice, divide by itself to get the
constant 1, and add that to the original number. However, it fails to
work if we add the successor of 0 as another test case:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
% discover 5 6  7 8  0 1
```

```{=html}
</div>
```
Nothing coming --- because zero division made the last test fail. If we
give only this test, another solution is found:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
% discover 0 1
d^
```

```{=html}
</div>
```
\"Take x to the x-th\" power\" --- `pow(0,0)` gives indeed 1, but
that\'s not the generic successor function.

More experiments to discover the hypot() function:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
% discover {4 3} 5
d/+
```

```{=html}
</div>
```
Hm --- the 3 is duplicated, divided by itself (=1), which is added to 4.
Try to swap the inputs:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
% discover {3 4} 5
q+
```

```{=html}
</div>
```
Another dirty trick: get square root of 4, add to 3 --- presto, 5. The
correct `hypot()` function would be

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
d*sd*+q
```

```{=html}
</div>
```
but my program set (nmax=30000) ends at 5-byte codes, so even by giving
another test to force discovery of the real thing, it would never reach
a 7-byte code. OK, I bite the bullet, set nmax to 500000, wait 5 minutes
for the partitioning, and then:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
% discover {3 4} 5  {11 60}  61
sd/+
```

```{=html}
</div>
```
Hm.. cheap trick again --- it was discovered that the solution is just
the successor of the second argument. Like in real life, test cases have
to be carefully chosen. So I tried with another a\^2+b\^2=c\^2 set, and
HEUREKA! (after 286 seconds):

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
% discover {3 4} 5  {8 15} 17
d*sd*+q
```

```{=html}
</div>
```
After partitioning, 54005 programs had the -1 stack balance, and the
correct result was on position 48393 in that list\...

And finally, with the half-million set of programs, here\'s a solution
for the successor function too:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
% discover  0 1  4711 4712
ddd-^+
```

```{=html}
</div>
```
\"d-\" subtracts top of stack from itself, pushing 0; the second
duplicate to the 0-th power gives 1, which is added to the original
argument. After some head-scratching, I find it plausible, and possibly
it is even the simplest possible solution, given the poorness of this
RPN language.

Lessons learned:

-   Brute force is simple, but may demand very much patience (or faster
    hardware)
-   The sky, not the skull is the limit what all we can do with Tcl :)

### Object orientation

OO (Object Orientation) is a style in programming languages popular
since Smalltalk, and especially C++, Java, etc. For Tcl, there have been
several OO extensions/frameworks (*incr Tcl*, *XOTcl*, *stooop*, *Snit*
to name a few) in different flavors, but none can be considered as
standard followed by a majority of users. However, most of these share
the features

-   classes can be defined, with variables and methods
-   objects are created as instances of a class
-   objects are called with messages to perform a method

Of course, there are some who say: \"Advocating object-orientated
programming is like advocating pants-oriented clothing: it covers your
behind, but often doesn\'t fit best\" \...

#### Bare-bones OO

Quite a bunch of what is called OO can be done in pure Tcl without a
\"framework\", only that the code might look clumsy and distracting.
Just choose how to implement instance variables:

-   in global variables or namespaces
-   or just as parts of a transparent value, with TOOT

The task of frameworks, be they written in Tcl or C, is just to hide
away gorey details of the implementation --- in other words, sugar it :)
On the other hand, one understands a clockwork best when it\'s outside
the clock, and all parts are visible --- so to get a good understanding
of OO, it might be most instructive to look at a simple implementation.

As an example, here\'s a Stack class with *push* and *pop* methods, and
an instance variable *s* --- a list that holds the stack\'s contents:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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
}
```

```{=html}
</div>
```
The *interp alias* makes sure that calling the object\'s name, like

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
::Stack::1 push hello
```

```{=html}
</div>
```
is understood and rerouted as a call to the dispatcher below:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
::Stack::do ::Stack::1 push hello
```

```{=html}
</div>
```
The dispatcher imports the object\'s variables (only *s* here) into
local scope, and then switches on the method name:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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}
```

```{=html}
</div>
```
A framework would just have to make sure that the above code is
functionally equivalent to, e.g. (in a fantasy OO style):

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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]]
   }
}
```

```{=html}
</div>
```
which, I admit, reads definitely better. But bare-bones has its
advantages too: in order to see how a clockwork works, you\'d better
have all parts visible :)

Now testing in an interactive tclsh:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
% 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"
```

```{=html}
</div>
```
#### TOOT: transparent OO for Tcl

Transparent OO for Tcl, or TOOT for short, is a very amazing combination
of Tcl\'s concept of transparent values, and the power of OO concepts.
In TOOT, the values of objects are represented as a list of length 3:
the class name (so much for \"runtime type information\" :-), a \"\|\"
as separator and indicator, and the values of the object, e.g.

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
{class | {values of the object}}
```

```{=html}
</div>
```
Here\'s my little take on toot in a nutshell. Classes in C++ started out
as structs, so I take a minimal struct as example, with generic get and
set methods. We will export the *get* and *set* methods:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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
}
```

```{=html}
</div>
```
The two generic accessor functions will be inherited by \"struct\"s

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
proc toot::get {class value member} {
   lindex $value [${class}::@ $member]
}
```

```{=html}
</div>
```
The set method does not change the instance (it couldn\'t, as it sees it
only \"by value\") --- it just returns the new composite toot object,
for the caller to do with it what he wants:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
proc toot::set {class value member newval} {
   ::set pos [${class}::@ $member]
   list $class | [lreplace $value $pos $pos $newval]
}
```

```{=html}
</div>
```
For the whole thing to work, here\'s a simple overloading of unknown ---
see \"Let unknown know\". It augments the current unknown code, at the
top, with a handler for

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
{class | values} method args
```

```{=html}
</div>
```
patterns, which converts it to the form

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
::toot::(class)::(method) (class) (values) (args)
```

```{=html}
</div>
```
and returns the result of calling that form:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
proc know what {proc unknown args $what\n[info body unknown]}
```

```{=html}
</div>
```
Now to use it (I admit the code is no easy reading):

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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]]
   }
}
```

```{=html}
</div>
```
Testing: we define a \"struct\" named foo, with two obvious members:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
toot::struct foo {bar grill}
```

```{=html}
</div>
```
Create an instance as pure string value:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
set x {foo | {hello world}}
puts [$x get bar] ;# -> hello (value of the "bar" member)
```

```{=html}
</div>
```
Modify part of the foo, and assign it to another variale:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
set y [$x set grill again]
puts $y ;# -> foo | {hello again}
```

```{=html}
</div>
```
Struct-specific methods can be just procs in the right namespace. The
first and second arguments are the class (disregarded here, as the dash
shows) and the value, the rest is up to the coder. This silly example
demonstrates member access and some string manipulation:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
proc toot::foo::upcase {- values which string} {
   string toupper [lindex $values [@ $which]]$string
}

puts [$y upcase grill !] ;# -> AGAIN!
```

```{=html}
</div>
```
### A little deterministic Turing machine

At university, I never learned much about Turing machines. Only decades
later, a hint in the Tcl chatroom pointed me to
<http://csc.smsu.edu/~shade/333/project.txt> , an assignment to
implement a Deterministic Turing Machine (i.e. one with at most one rule
per state and input character), which gives clear instructions and two
test cases for input and output, so I decided to try my hand in Tcl.

Rules in this little challenge are of the form a bcD e, where

-   a is the state in which they can be applied
-   b is the character that must be read from tape if this rule is to
    apply
-   c is the character to write to the tape
-   D is the direction to move the tape after writing (R(ight) or
    L(eft))
-   e is the state to transition to after the rule was applied

Here\'s my naive implementation, which takes the tape just as the string
it initially is. I only had to take care that when moving beyond its
ends, I had to attach a space (written as \_) on that end, and adjust
the position pointer when at the beginning. Rules are also taken as
strings, whose parts can easily be extracted with string index --- as
it\'s used so often here, I alias it to @. }

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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
```

```{=html}
</div>
```
Test data from <http://csc.smsu.edu/~shade/333/project.txt>

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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 _
```

```{=html}
</div>
```
Testing:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
foreach tape $tapes {puts [dtm $rules $tape]}
puts *
puts [dtm $rules2 $tapes2]
```

```{=html}
</div>
```
reports the results as wanted in the paper, on stdout:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
>tclsh turing.tcl
[_]1
1[0]100
[_]10000
*
1111[1]1
```

```{=html}
</div>
```
### Streams

Streams are a powerful concept in (not only functional) programming. In
SICP chapter 3.5, streams are introduced as data structures
characterized as \"delayed lists\", whose elements are produced and
returned only on demand (deferred evaluation). This way, a stream can
promise to be a potentially endless source of data, while taking only
finite time to process and deliver what\'s really wanted. Other streams
may provide a finite but very large number of elements, which would be
impractical to process in one go. In Tcl, the two ways of reading a file
are a good example:

-   read `$fp` returns the whole contents, which then can be processed;
-   while `{[gets $fp line]>-1} {...}` reads line by line, interleaved
    with processing

The second construct may be less efficient, but is robust for
gigabyte-sized files. A simpler example is pipes in Unix/DOS (use TYPE
for cat there):

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` bash
cat foo.bar | more
```

```{=html}
</div>
```
where the \"cat\" delivers lines of the file as long as \"more\" will
take them, and waits otherwise (after all, stdin and stdout are just
streams\...). Such process chains can be emulated in Tcl with the
following rules:

A stream is modelled here as a procedure that returns one stream item on
each call. The special item \"\" (the empty string) indicates that the
stream is exhausted. Streams are interesting if they don\'t deliver the
same result on every call, which requires them to maintain state between
calls e.g. in static variables (here implemented with the fancy remember
proc) --- examples are intgen that delivers ever increasing integers, or
gets `$fp` where the file pointer advances at each call, so potentially
all lines of the file are returned over time.

A filter takes one or more streams, and possibly other arguments, and
reacts like a stream too. Hence, streams can be (and typically are)
nested for processing purposes. If a filter meets end-of-stream, it
should return that too. Filters may be characterized as \"selectors\"
(who may return only part of their input, like \"grep\") and/or
\"appliers\" who call a command on their input and return the result.
Note that on infinite streams, selectors may never return, e.g. if you
want the second even prime\... Streams in general should not be written
in brackets (then the Tcl parser would eagerly evaluate them before
evaluating the command), but braced, and stream consumers eval the
stream at their discretion.

Before we start, a word of warning: maintaining state of a procedure is
done with default arguments that may be rewritten. To prevent bugs from
procedures whose defaults have changed, I\'ve come up with the following
simple architecture --- procs with static variables are registered as
\"sproc\"s, which remembers the initial defaults, and with a reset
command you can restore the initial values for one or all sprocs:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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]
   }
}
```

```{=html}
</div>
```
Now let\'s start with a simple stream source, \"cat\", which as a
wrapper for gets returns the lines of a file one by one until exhausted
(EOF), in which case an empty string is returned (this requires that
empty lines in the files, which would look similarly, are represented as
a single blank):

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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
   }
}
```

```{=html}
</div>
```
Usage example:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
more {cat streams.tcl}
```

```{=html}
</div>
```
which crudely emulates the Unix/DOS pipe mentioned above (you\'ll have
to hit  after every line, and
 to quit..).
more is the most important \"end-user\" of streams, especially if they
are infinite. Note however that you need stdin for this implementation,
which excludes wishes on Windows (one might easily write a UI-more that
reacts on mouse clicks, though).

A more generic filter takes a condition and a stream, and on each call
returns an element of the input stream where the condition holds --- if
ever one comes along:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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}}
```

```{=html}
</div>
```
Friends of syntactic sugar might prefer shell style:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` bash
$ cat streams.tcl | grep this | more
```

```{=html}
</div>
```
and guess what, we can have that in Tcl too (and not in Scheme !-), by
writing a proc, that also resets all sprocs, with the fancy name \"\$\"
(in Unix, this could be the shell prompt that you don\'t type, but for
Tcl we always have to have the command name as first word):

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` 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]
}
```

```{=html}
</div>
```
To prove that we haven\'t cheated by using exec, let\'s introduce a line
counter filter:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
sproc -n {stream {n 0}} {
   set res [eval $stream]
   if {$res!=""} {set res [remember n [incr n]]:$res}
}
```

```{=html}
</div>
```
This can be added to filter chains, to count lines in the original file,
or only the results from grep:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
$ cat streams.tcl | -n | grep this | more
$ cat streams.tcl | grep this | -n | more
```

```{=html}
</div>
```
We further observe that more has a similar structure to filter, so we
could also rewrite it in terms of that:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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
}
```

```{=html}
</div>
```
The sort filter is unusual in that it consumes its whole (finite!)
input, sorts it, and acts as a stream source on the output:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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}
```

```{=html}
</div>
```
Now for the example in SICP: find the second prime in the interval
between 10000 and 1000000.

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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
```

```{=html}
</div>
```
Another idea from SICP is a \"smoothing\" function, that averages each
pair of values from the input stream. For this we need to introduce a
short-term memory also in the filter:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
sproc average {stream {previous {}} } {
   if {$previous==""} {set previous [eval $stream]}
   remember previous [set current [eval $stream]]
   if {$current!=""} {expr {($previous+$current)/2.}}
}
```

```{=html}
</div>
```
which, tested on a n-element stream, returns n-1 averages:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
collect {average {streamlist {1 2 3 4 5}}} ==> 1.5 2.5 3.5 4.5
```

```{=html}
</div>
```
Yet another challenge was to produce an infinite stream of pairs `{i j}`
of positive integers, `i <= j`, ordered by their sum, so that more pairs
produces consecutively

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
{1 1} {1 2} {1 3} {2 2} {1 4} {2 3} {1 5} {2 4} {3 3} {1 6} ...
```

```{=html}
</div>
```
Here\'s my solution which does that:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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
}
```

```{=html}
</div>
```
**Ramanujan numbers**: The pairs generator can be used to find Ramanujan
numbers, which can be represented as the sum of two integer cubes in
more than one way. Here I use a global array for recording results:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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
```

```{=html}
</div>
```
delivers in hardly noticeable time the R. numbers 1729, 4104, 13832\...
Or, how\'s this infinite Fibonacchi number generator, which on more fibo
produces all the F.numbers (0,1,1,2,3,5,8,13,21\...) you might want?

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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]
   }
}
```

```{=html}
</div>
```
**Discussion**: With the above code, it was possible to reproduce quite
some behavior of streams as documented in SICP, not as data structures
but with Tcl procs (though procs are data too, in some sense\...).
What\'s missing is the capability to randomly address parts of a stream,
as is possible in Scheme (and of course their claim to do without
assignment, or mutable data\...) Tcl lists just don\'t follow LISP\'s
CAR/CDR model (though KBK demonstrated in Tcl and LISP that this
structure can be emulated, also with procs), but rather C\'s flat
`*TclObject[]` style. The absence of lexical scoping also led to
constructs like sproc/reset, which stop a gap but aren\'t exactly
elegant --- but Tcl\'s clear line between either local or global
variables allows something like closures only by rewriting default
arguments like done in remember (or like in Python).

Don\'t take this as a fundamental critique of Tcl, though --- its
underlying model is far more simple and elegant than LISP\'s (what with
\"special forms\", \"reader macros\"\...), and yet powerful enough to do
just about everything possible\...

### Playing with Laws of Form

After many years, I re-read

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
G. Spencer-Brown, "Laws of Form". New York: E.P. Dutton 1979
```

```{=html}
</div>
```
which is sort of a mathematical thriller, if you will. Bertrand Russell
commented that the author \"has revealed a new calculus, of great power
and simplicity\" (somehow sounds like Tcl ;\^). In a very radical
simplification, a whole world is built up by two operators,
juxtaposition without visible symbol (which could be likened to or) and
a overbar-hook (with the meaning of not) that I can\'t type here ---
it\'s a horizontal stroke over zero or more operands, continued at right
by a vertical stroke going down to the baseline. In these Tcl
experiments, I use \"\" for \"\" and angle-brackets \<\> for the
overbar-hook (with zero or more operands in between).

One point that was new for me is that the distinction between operators
and operands is not cast in stone. Especially constants (like \"true\"
and \"false\" in Boolean algebras) can be equally well expressed as
neutral elements of operators, if these are considered variadic, and
having zero arguments. This makes sense, even in Tcl, where one might
implement them as

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` 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
}
```

```{=html}
</div>
```
which, when called with no arguments, return 1 or 0, respectively. So
\[or\] == 0 and \[and\] == 1. In Spencer-Brown\'s terms, \[\] (which is
\"\", the empty string with no arguments) is false (\"nil\" in LISP),
and \[\<\>\] is the negation of \"\", i.e. true. His two axioms are:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
<><> == <> "to recall is to call       -- (1 || 1) == 1"
<<>> ==    "to recross is not to cross -- !!0 == 0"
```

```{=html}
</div>
```
and these can be implemented by a string map that is repeated as long as
it makes any difference (sort of a trampoline) to simplify any
expression consisting only of operators and constants (which are
operators with zero arguments):

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
proc lf'simplify expression {
   while 1 {
       set res [string map {<><> <> <<>> ""} $expression]
       if {$res eq $expression} {return $res}
       set expression $res
   }
}
```

```{=html}
</div>
```
Testing:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
% lf'simplify <<><>><>
<>
```

```{=html}
</div>
```
which maps \<\>\<\> to \<\>, \<\<\>\> to \"\", and returns \<\> for
\"true\".

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
% lf'simplify <a>a
<a>a
```

```{=html}
</div>
```
In the algebra introduced here, with a variable \"a\", no further
simplification was so far possible. Let\'s change that --- \"a\" can
have only two values, `""` or `<>`, so we might try to solve the
expression by assuming all possible values for a, and see if they
differ. If they don\'t, we have found a fact that isn\'t dependent on
the variable\'s value, and the resulting constant is returned, otherwise
the unsolved expression:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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
}
```

```{=html}
</div>
```
with a helper function in that reports containment of an element in a
list:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
proc in {list element} {expr {[lsearch -exact $list $element] >= 0}}
```

```{=html}
</div>
```
Testing:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
% lf'solve <a>a a
<>
```

```{=html}
</div>
```
which means, in expr terms, {(!\$a \|\| \$a) == 1}, for all values of a.
In other words, a tautology. All of Boole\'s algebra can be expressed in
this calculus:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
* (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
```

```{=html}
</div>
```
We can test it with the classic \"ex contradictione quodlibet\" (ECQ)
example --- \"if p and not p, then q\" for any q:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
% lf'solve <<p><<p>>>q p
q
```

```{=html}
</div>
```
So formally, q is true, whatever it is :) If this sounds overly
theoretic, here\'s a tricky practical example in puzzle solving, Lewis
Carroll\'s last sorites (pp. 123f.). The task is to conclude something
from the following premises:

-   The only animals in this house are cats
-   Every animal is suitable for a pet, that loves to gaze at the moon
-   When I detest an animal, I avoid it
-   No animals are carnivorous, unless they prowl at night
-   No cat fail to kill mice
-   No animals ever take to me, except what are in this house
-   Kangaroos are not suitable for pets
-   None but carnivora kill mice
-   I detest animals that do not take to me
-   Animals that prowl at night always love to gaze at the moon

These are encoded to the following one-letter predicates:

a: avoided by me\
c: cat\
d: detested by me\
h: house, in this\
k: kill mice\
m: moon, love to gaze at\
n: night, prowl at\
p: pet, suitable for\
r: (kanga)roo\
t: take to me\
v: (carni)vorous

So the problem set can be restated, in Spencer-Brown\'s terms, as

    <h>c <m>p <d>a <v>n <c>k <t>h <r><p> <k>v td <n>m

I first don\'t understand why all premises can be just written in a row,
which amounts to implicit \"or\", but it seems to work out well. As
we\'ve seen that `<x>`{=html}`x` is true for any `x`, we can cancel out
such tautologies. For this, we reformat the expression to a list of
values of type `x` or `!x`, that is in turn dumped into a local array
for existence checking. And when both `x` and `!x` exist, they are
removed from the expression:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
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}]
```

```{=html}
</div>
```
which results in:

-   a `<r>`{=html}

translated back: \"I avoid it, or it\'s not a kangaroo\", or, reordered,
\"`<r>`{=html} a\" which by (4) means, \"All kangaroos are avoided by
me\".

### A little IRC chat bot

Here is a simple example of a \"chat bot\" --- a program that listens on
an IRC chatroom, and sometimes also says something, according to its
programming. The following script

-   connects to channel #tcl on IRC
-   listens to what is said
-   if someone mentions its name (minibot), tries to parse the message
    and answer.

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` tcl
#!/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
```

```{=html}
</div>
```
Examples from the chat:

```{=html}
<div style="margin:0;padding-top:0.5em;padding-bottom:0.5em">
```
``` text
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
```

```{=html}
</div>
```