Richard Suchenwirth - This weekend's fun project is a variation on Neil Madden's highly instructive State Space Searching in Tcl, whose continuation Heuristic Searches taught me how simple an A* search [L1 ] can be (in Tcl, at least ;-). The original heavyweight approach, with one namespace per node, was changed to one global array named solution (after all, namespaced variables are partially hidden globals). Paths are represented as lists, so splitting at "|" was avoided.
Stepping via [gets stdin] is not possible on a Microsoft Windows wish, so I changed that to a step counter that is incremented when the main window is clicked on, and the GeneralSearch proc vwaits for it. A cycle detection was added, and the possibility to find all solutions (by just not returning when one was found). By modifying costs in the maze map, I could verify that BestFirst (to tell the truth, its UniformCostSearch) can indeed be better than BreadthFirst. Giving a -command to lsort was replaced by -index sorting an augmented list (see Things British for why that performs better).
The value to sort is computed according to a formula passed into sortBest, which uses variables in sortBest scope - while compact in code, I'm not so happy with this dubious technique. But at least A* (which takes both the current cost, and the cost to goal estimated with city-block distance) is better than BestFirst (which prefers the lowest current costs) - A* found the best path in 31 vs. 42 steps. "Greedy" was in between with 36 steps.
The operators in the maze example were implemented as one template with four "instances" (hooray for interp alias!) This was not possible for the search strategies - they had to be "real" procs for the cute trick
[info proc $search*] problem
to work, where search may be an incomplete procedure name as long as it's unambiguous - otherwise you get the error
% main B invalid command name "BreadthFirst BestFirst"
when abbreviating too much (but Br or Be do the job already!)
proc main {{search DepthFirst}} {
variable solution
catch {console show}
#-- pose a problem: maze test - state {direction cost target...}
array set ::map {
A {e 0.1 B s 1 F}
B {w 1 A e 1 C}
C {w 1 B e 1 D}
D {w 1 C e 1 E s 1 I}
E {w 1 D s 1 J}
F {n 1 A s 1 K}
G {s 1 L}
H {e 1 I}
I {n 1 D w 1 H s 1 N}
J {n 1 E s 1 O}
K {n 1 F e 1 L s 1 P}
L {n 1 G w 1 K e 1 M}
M {w 1 L e 1 N}
N {n 1 I w 1 M s 1 S}
O {n 1 J s 1 T}
P {n 1 K}
Q {s 1 V}
R {s 1 W}
S {n 1 N}
T {n 1 O s 1 Y}
U {e 1 V}
V {n 1 Q w 1 U e 1 W}
W {n 1 R w 1 V e 1 X}
X {w 1 W e 1 Y}
Y {n 1 T w 1 X}
}
array set ::estimatedCost {
A 4 B 5 C 6 D 7 E 8
F 3 G 4 H 5 I 6 J 7
K 2 L 3 M 4 N 5 O 6
P 1 Q 2 R 3 S 4 T 5
U 0 V 1 W 2 X 3 Y 4
} ;# city-block distances to state U
#-- problem-specific operators: one prototype, four incarnations
proc _move {direction node} {
variable solution
set moves $::map($solution($node,state))
set parent $solution($node,parent)
set res ""
foreach {dir cost newState} $moves {
if {$dir==$direction && $newState != $parent} {
set pathCost [expr {$solution($node,cost)+$cost}]
set res [list $newState $pathCost]
break
}
}
set res
} ;# ... and now "instantiating" the incarnations:
foreach {proc code} {north n east e south s west w} {
interp alias {} $proc {} _move $code
}
array set problem {start A goal U operators {south north east west}}
catch {
label .0 -textvariable solution(steps) -relief raised
set ::searcher [lindex $::searchers 0]
eval pack [winfo children .] -fill x
# stepper for wish without stdin:
bind .0 <1> {incr solution(steps)}
bind .0 <3> {set solution(steps) -1}
}
[info proc $search*] problem
}
#------------------------------ begin generic routines
proc _GeneralSearch {qfunc _problem} {
upvar 1 $_problem problem
variable solution
set solution(steps) 0
set nodes [createNode Root starting $problem(start) 0]
while {[llength $nodes]} {
if {$solution(steps)<0} break
vwait solution(steps)
set current [lpop nodes]
puts -nonewline "\n$solution($current,state):"
if {$solution($current,state)==$problem(goal)} {
puts "\nSolution in $solution(steps) steps:\
[states $current] cost:$solution($current,cost)"
#return ;# if only first solution wanted
} else {
set res [expand $current $problem(operators)]
if {[llength $res]} {$qfunc $res nodes}
}
}
puts "no more solutions"
set solution(steps) -1
return ""
}
foreach {algorithm queuingStyle} {
AStar A*
BestFirst MinCost
BreadthFirst AtEnd
DepthFirst AtFront
Greedy MinEstimatedCost
} {
proc $algorithm _p "
upvar 1 \$_p p; _GeneralSearch enqueue$queuingStyle p"
lappend searchers $algorithm
} ;# must make procs here, so we can use [proc info] completion
proc createNode {name operator state cost} {
variable solution
puts -nonewline " $operator-($cost)->$state"
if {$operator=="starting"} {
set parent ""
} else {
set prefix [lrange $name 0 end-1]
set parent $solution($prefix,state)
}
set solution($name,state) $state
set solution($name,cost) $cost
set solution($name,operator) $operator
set solution($name,parent) $parent
set name
}
proc lpop _l {
upvar 1 $_l list
set res [lindex $list 0]
set list [lrange $list 1 end] ;# chop off first element...
set res ;# ...and return it
}
proc expand {node operators} {
set newNodes {}
set uniqueName 1
set states [states $node]
foreach op $operators {
set name [concat $node n$uniqueName]
set state ""
foreach {state cost} [$op $node] break
if {$state!=""} {
if {[lsearch -exact $states $state]>=0} {
puts -nonewline "cycle for $state in $states"
continue
}
lappend newNodes [createNode $name $op $state $cost]
incr uniqueName
set name [concat $node n$uniqueName]
}
}
set newNodes
}
#---------------- enqueuing routines: they control the strategy
proc enqueueAtEnd {newNodes _q} {
upvar 1 $_q queue
set queue [concat $queue $newNodes]
}
proc enqueueAtFront {newNodes _q} {
upvar 1 $_q queue
set queue [concat $newNodes $queue]
}
proc enqueueA* {newNodes _q} {
upvar 1 $_q queue
set queue [sortBest \
{$::estimatedCost($solution($i,state))+$solution($i,cost)} \
[concat $queue $newNodes]]
}
proc enqueueMinCost {newNodes _q} {
upvar 1 $_q queue
set queue [sortBest {$solution($i,cost)} \
[concat $queue $newNodes]]
}
proc enqueueMinEstimatedCost {newNodes _q} {
upvar 1 $_q queue
set queue [sortBest \
{$::estimatedCost($solution($i,state))} \
[concat $queue $newNodes]]
}
#----------------------------- generic formula-driven sorter
# NB. "formula" is expressed in terms of "sortBest" scope!
proc sortBest {formula nodes} {
variable solution
set tmp {}
foreach i $nodes {
lappend tmp [list [expr $formula] $i]
}
set res {}
foreach i [lsort -real -index 0 $tmp] {
lappend res [lindex $i 1]
}
set res
}
#------------------------------ path dumping routines
proc contents path {
variable solution
set res ""
set tpath ""
foreach i $path {
lappend tpath $i
foreach j {operator cost state} {
lappend res $solution($tpath,$j)
}
}
set res
}
proc states path {
variable solution
set res ""
set tpath ""
foreach i $path {
lappend tpath $i
lappend res $solution($tpath,state)
}
set res
}
######################################### self-test
if {[file tail [info script]]==[file tail $argv0]} main