[KBK] (25 April 2002) -
In [Playing Prolog] and [Playing predicate logic], [RS] implies that Tcl is poor at doing backtracking searches.  In fact, it isn't all that difficult to write code that does backtracking, and Tcl's [upvar] and [uplevel] are just the things to manage the needed control structures.

Let's work out an example.  We wish to solve a cryptarithm (an arithmetic sum where the digits have been replaced with letters).  Examples include:

     S E N D       Y E L L O W
   + M O R E       Y E L L O W
   ---------- and      + R E D
   M O N E Y      -------------
                   O R A N G E

The usual rules for these problems include:

   * Each letter represents a different digit.
   * No digit is represented by more than one letter.
   * Leading digits (S and M in the first problem; Y, R, and O in the second) are nonzero.
   * The usual rules of arithmetic are followed.

When solving these problems by computer, it's usually easiest to guess the less significant digits first.
----

# We begin with a procedure that is used to make an arbitrary choice for a given digit (stored in the variable ''digitVar'' in caller's scope).  The possible choices are given in ''choices,'' and the ones not chosen are stored in the variable ''remainingVar'' in caller's scope.  For each possible choice, the script ''script'' is evaluated in the caller's scope.

 proc choose { digitVar choices remainingVar script } {
   upvar 1 $digitVar digit
   upvar 1 $remainingVar remaining
   set i -1
   foreach digit $choices {
     incr i
     set remaining [lreplace $choices $i $i]
     uplevel 1 $script
   }
 }

# Very often, part way through a problem, we know what the value of a given letter must be.  The next procedure assigns to the variable ''digitVar'' in the caller's scope the known value ''value.'' The value must be present in the list ''choices,'' and the remaining choices get stored in the variable ''remainingVar'' in the caller's scope.  If the value is present in the list, ''script'' is evaluated in caller's scope; otherwise, nothing further happens.

 proc let { digitVar value choices remainingVar script } {
   upvar 1 $digitVar digit
   upvar 1 $remainingVar remaining
   set i [lsearch -exact $choices $value]
   if { $i >= 0 } {
     set digit $value
     set remaining [lreplace $choices $i $i]
     uplevel 1 $script
   }
 }

# OK, let's turn these procedures loose on the cryptarithm YELLOW + YELLOW + RED = ORANGE
 
 puts [time {
   # Choose W and D arbitrarily
   choose w { 0 1 2 3 4 5 6 7 8 9 } r1 {
     choose d $r1 r2 {
       set sum1 [expr { $w + $w + $d }]
       # W and D determine E
       let e [expr { $sum1 % 10 }] $r2 r3 {
         set cy1 [expr { $sum1 / 10 }]
         # Choose O arbitrarily
         choose o $r3 r4 {
           # O must be non-zero because it's a leading digit
           if { $o != 0 } {
             set sum10 [expr { $o + $o + $e + $cy1 }]
             # The digits chosen so far determine G
             let g [expr { $sum10 % 10 }] $r4 r5 {
               set cy10 [expr { $sum10 / 10 }]
               # L and R are now chosen arbitrarily
               choose l $r5 r6 {
                 choose r $r6 r7 {
                   # R must not be zero because it's a leading digit
                   if { $r != 0 } {
                     set sum100 [expr { $l + $l + $r + $cy10 }]
                     # N is chosen arbitrarily
                     let n [expr { $sum100 % 10 }] $r7 r8 {
                       set cy100 [expr { $sum100 / 10 }]
                       set sum1000 [expr { $l + $l + $cy100 }]
                       # A is now determined by the other digits
                       let a [expr { $sum1000 % 10 }] $r8 r9 {
                         # Y is the digit that remains
                         choose y $r9 r10 {
                           # Y is a leading digit and may not be zero
                           if { $y != 0 } {
                             # At this point, it's easiest simply to
                             # check the arithmetic using [expr]
                             set yellow $y$e$l$l$o$w
                             set red $r$e$d
                             set orange $o$r$a$n$g$e
                             if { $yellow + $yellow + $red == $orange } {
                               puts [list yellow $yellow red $red orange $orange]
                             }
                           }
                         }
                       }
                     }
                   }
                 }
               }
             }
           }
         }
       }
     }
   }
 }]
 
# The solution of SEND + MORE = MONEY is similar:
 
 puts [time {
   choose d { 0 1 2 3 4 5 6 7 8 9 } r1 {
     choose e $r1 r2 {
       set sum1 [expr { $d + $e }]
       let y [expr { $sum1 % 10 }] $r2 r3 {
         set cy1 [expr { $sum1 / 10 }]
         choose n $r3 r4 {
           choose r $r4 r5 {
             set sum10 [expr { $n + $r + $cy1 }]
             if { $sum10 % 10 == $e } {
               set cy10 [expr { $sum10 / 10 }]
               choose o $r5 r6 {
                 set sum100 [expr { $e + $o + $cy10 }]
                 if { $sum100 % 10 == $n } {
                   set cy100 [expr { $sum100 / 10 }]
                   choose s $r6 r7 {
                     if { $s != 0 } {
                       choose m $r7 r8 {
                         if { $m != 0 } {
                           set send $s$e$n$d
                           set more $m$o$r$e
                           set money $m$o$n$e$y
                           if { $send + $more == $money } {
                             puts [list send $send more $more money $money]
                           }
                         }
                       }
                     }
                   }
                 }
               }
             }
           }
         }
       }
     }
   }
 }]

And, on a not-terribly fast Windows laptop in Tcl 8.3.4, we get the correct answers:

 yellow 143329 red 846 orange 287504
 2464000 microseconds per iteration
 send 9567 more 1085 money 10652
 1542000 microseconds per iteration
----
There is a lot of related work on [Control structures for backtracking search].