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 [
1] 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.
Edit:
Now I find
Control structures for backtracking search!
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]
if {$kibi eq "male"} { assert [not $kibilied] }
if {$kibilied} {
assert [distinct $kibiselfdesc $kibi]
} else {
assert [eqv? $kibiselfdesc $kibi]
}
if {$parent1 eq "male"} {
assert [and [eqv? $kibiselfdesc "male"] \
[xor [and [eqv? $kibi "female"] \
[eqv? $kibilied 1]] \
[and [eqv? $kibi "male"] \
[eqv? $kibilied 0]]]]
} else {
assert [and [eqv? $kibi "female"] [eqv? $kibilied 1]]
}
puts "SOLUTION:"
puts "parent1 = $parent1, parent2 = $parent2"
puts "kibi = $kibi"
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} }And finally, put it all together:
choose {solve-kalotan-puzzle $parent1 $parent2 $kibi $kibiselfdesc $kibilied} {
parent1 {male female}
parent2 {male female}
kibi {male female}
kibiselfdesc {male female}
kibilied {0 1}
}Which gives:
SOLUTION:
parent1 = female, parent2 = male
kibi = female
female male female male 1
So, kibi lied and is female. (Fixed the code to give the right answer!)
Hope you enjoy it.
