Searching A Star In Space

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 [1 ] 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