[NEM] 9Jan05: Here's a little play with implementing an automatic non-deterministic backtracking search control structure (phew!). The new command "choose" takes a script and a [dict] of varname/choice options. It searches through different combinations of the variable choices until it finds a combination which causes the script to succeed. Failure is indicated by a call to "fail". If none of the options succeed, then the choose command itself fails. This is modelled on the "amb" operator proposed by John McCarthy, and in particular on the implementation (and example) in the Teach Yourself Scheme in Fixnum Days [http://www.ccs.neu.edu/home/dorai/t-y-scheme/t-y-scheme-Z-H-16.html#node_chap_14] tutorial. In that tutorial, the control operator is implemented using [continuations]. Tcl doesn't have continuations (yet...), so I've had to rearrange things a bit to exploit what tcl does have: namely exceptions (errors). The fail command simply generates an exception with a special exception code, which triggers the backtracking. Please note: this code isn't very well tested, and certainly isn't very efficient.

The choose command:

 proc choose {script arglist} {
   set len [llength $arglist]
   set scr ""
   set indent 0
   foreach {var options} $arglist {
     iappend $indent scr "foreach $var [list $options] \{"
     incr indent 2
   }
   iappend $indent scr "set rc \[catch {$script} ret\]"
   iappend $indent scr "if {\$rc != 3245} { return -code \$rc -errorinfo \$::errorInfo \$ret }"
   append scr [string repeat "\}" [expr {$len/2}]]
   #puts "scr = \n$scr"
   eval $scr
   fail
 }
 # Pretty-printing: useful for debug
 proc iappend {indent var str} {
   upvar 1 $var v
   append v [string repeat " " $indent]
   append v $str\n
 }
 
 # 3245 is "fail" on a telephone keypad
 proc fail {} { return -code 3245 "search tree exhausted" }
 proc assert {val} { if {!$val} { fail } }
 proc assertif {expr body} {
   uplevel 1 [list if $expr "assert \[$body\]"]
 }

The example is based on a pretty direct translation of the scheme code. There's quite a bit of extra stuff here to support the scheme-like operations. It's all implemented in a functional style. Well, why not?

First, the actual problem. Read the scheme site for what this is actually about. Basically, it's a logic problem encoded as a set of assertions. If the inputs satisfy all the assertions then we have a solution:

 proc solve-kalotan-puzzle {parent1 parent2 kibi kibiselfdesc kibilied} {
   assert [distinct $parent1 $parent2]
   assertif {$kibi eq "male"} { not $kibilied }
   assertif {$kibilied} {
     xor [and [eqv? $kibiselfdesc "male"] \
              [eqv? $kibi "female"]] \
         [and [eqv? $kibiselfdesc "female"] \
              [eqv? $kibi "male"]] 
   }
   assertif {[not $kibilied]} {
     xor [and [eqv? $kibiselfdesc "male"] \
              [eqv? $kibi "male"]] \
         [and [eqv? $kibiselfdesc "female"] \
              [eqv? $kibi "female"]] 
   }
   assertif {[eqv? $parent1 "male"]} {
     and [eqv? $kibiselfdesc "male"] \
         [xor [and [eqv? $kibi "female"] \
                   [eqv? $kibilied 0]] \
              [and [eqv? $kibi "male"] \
                   [eqv? $kibilied 1]]] 
   }
   assertif {[eqv? $parent1 "female"]} {
     and [eqv? $kibi "female"] [eqv? $kibilied 1] 
   }
   puts "SOLUTION:"
   puts "parent1 = $parent1, parent2 = $parent2"
   puts "kibi = $kibi == $kibiselfdesc ? [expr {$kibilied ? yes : no}]"
   return [list $parent1 $parent2 $kibi $kibiselfdesc $kibilied]
 }

Now, the helper procedures:

 proc not {arg} { expr {!$arg} }
 # Check all items are distinct
 proc distinct {args} {
   foreach item $args { if {[count $item $args] > 1} { return 0 } }
   return 1
 }
 proc count {item list} {
   set ret 0; foreach el $list { if {$el eq $item} { incr ret } }
   return $ret
 }
 # Exactly 1 item should be true (takes advantage of the fact that true=1,false=0)
 proc xor {args} {
   expr {[sum $args] != 1}
 }
 proc and {args} {
   expr {[sum $args] == [llength $args]}
 }
 proc sum {list} {
   foldr + 0 $list
 }
 # Classic foldr pattern for recursion - here's an imperative version
 proc foldr {op init list} {
   set acc $init
   foreach item [reverse $list] {
     set acc [uplevel 1 $op $item $acc]
   }
   return $acc
 }
 # Reverse a list for foldr - not actually necessary in this case, but
 # for completeness...
 proc reverse {list} {
   set ret [list]
   for {set i 0} {$i < [llength $list]} {incr i} {
     lappend ret [lindex $list end-$i]
   }
   return $ret
 }
 proc eqv? {a b} { string equal $a $b }
 proc + {a b} { expr {$a + $b} }

Hope you enjoy it.
----
Category?