Use a subclassed tuple with methods instead of quotations
parent
bda1c97d21
commit
1266383e4a
|
@ -3,7 +3,40 @@
|
|||
USING: help.markup help.syntax ;
|
||||
IN: astar
|
||||
|
||||
{ find-path <astar> considered } related-words
|
||||
HELP: astar
|
||||
{ $description "This tuple must be subclassed and its method " { $link cost } ", "
|
||||
{ $link heuristic } ", and " { $link neighbours } " must be implemented. "
|
||||
"Alternatively, the " { $link <astar> } " word can be used to build a non-specialized version." } ;
|
||||
|
||||
HELP: cost
|
||||
{ $values
|
||||
{ "from" "a node" }
|
||||
{ "to" "a node" }
|
||||
{ "astar" "an instance of a subclassed " { $link astar } " tuple" }
|
||||
{ "n" "a number" }
|
||||
}
|
||||
{ $description "Return the cost to go from " { $snippet "from" } " to " { $snippet "to" } ". "
|
||||
{ $snippet "to" } " is necessarily a neighbour of " { $snippet "from" } "."
|
||||
} ;
|
||||
|
||||
HELP: heuristic
|
||||
{ $values
|
||||
{ "from" "a node" }
|
||||
{ "to" "a node" }
|
||||
{ "astar" "an instance of a subclassed " { $link astar } " tuple" }
|
||||
{ "n" "a number" }
|
||||
}
|
||||
{ $description "Return the estimated (undervalued) cost to go from " { $snippet "from" } " to " { $snippet "to" } ". "
|
||||
{ $snippet "from" } " and " { $snippet "to" } " are not necessarily neighbours."
|
||||
} ;
|
||||
|
||||
HELP: neighbours
|
||||
{ $values
|
||||
{ "node" "a node" }
|
||||
{ "astar" "an instance of a subclassed " { $link astar } " tuple" }
|
||||
{ "seq" "a sequence of nodes" }
|
||||
}
|
||||
{ $description "Return the list of nodes reachable from " { $snippet "node" } "." } ;
|
||||
|
||||
HELP: <astar>
|
||||
{ $values
|
||||
|
@ -16,7 +49,8 @@ HELP: <astar>
|
|||
{ $snippet "neighbours" } " one builds the list of neighbours. The "
|
||||
{ $snippet "cost" } " and " { $snippet "heuristic" } " ones represent "
|
||||
"respectively the cost for transitioning from a node to one of its neighbour, "
|
||||
"and the underestimated cost for going from a node to the target."
|
||||
"and the underestimated cost for going from a node to the target. This solution "
|
||||
"may not be as efficient as subclassing the " { $link astar } " tuple."
|
||||
} ;
|
||||
|
||||
HELP: find-path
|
||||
|
|
|
@ -5,44 +5,48 @@ IN: astar
|
|||
|
||||
! This implements the A* algorithm. See http://en.wikipedia.org/wiki/A*
|
||||
|
||||
TUPLE: astar g in-closed-set ;
|
||||
GENERIC: cost ( from to astar -- n )
|
||||
GENERIC: heuristic ( from to astar -- n )
|
||||
GENERIC: neighbours ( node astar -- seq )
|
||||
|
||||
<PRIVATE
|
||||
|
||||
TUPLE: astar neighbours heuristic cost
|
||||
goal g origin in-open-set in-closed-set open-set ;
|
||||
TUPLE: (astar) astar goal origin in-open-set open-set ;
|
||||
|
||||
: (add-to-open-set) ( h node astar -- )
|
||||
2dup in-open-set>> at* [ over open-set>> heap-delete ] [ drop ] if
|
||||
[ swapd open-set>> heap-push* ] [ in-open-set>> set-at ] 2bi ;
|
||||
|
||||
: add-to-open-set ( node astar -- )
|
||||
[ g>> at ] 2keep
|
||||
[ [ goal>> ] [ heuristic>> call( n1 n2 -- c ) ] bi + ] 2keep
|
||||
[ astar>> g>> at ] 2keep
|
||||
[ [ goal>> ] [ astar>> heuristic ] bi + ] 2keep
|
||||
(add-to-open-set) ;
|
||||
|
||||
: ?add-to-open-set ( node astar -- )
|
||||
2dup in-closed-set>> key? [ 2drop ] [ add-to-open-set ] if ;
|
||||
2dup astar>> in-closed-set>> key? [ 2drop ] [ add-to-open-set ] if ;
|
||||
|
||||
: move-to-closed-set ( node astar -- )
|
||||
[ in-closed-set>> conjoin ] [ in-open-set>> delete-at ] 2bi ;
|
||||
[ astar>> in-closed-set>> conjoin ] [ in-open-set>> delete-at ] 2bi ;
|
||||
|
||||
: get-first ( astar -- node )
|
||||
[ open-set>> heap-pop drop dup ] [ move-to-closed-set ] bi ;
|
||||
|
||||
: set-g ( origin g node astar -- )
|
||||
[ [ origin>> set-at ] [ g>> set-at ] bi-curry bi-curry bi* ] [ ?add-to-open-set ] 2bi ;
|
||||
[ [ origin>> set-at ] [ astar>> g>> set-at ] bi-curry bi-curry bi* ] [ ?add-to-open-set ] 2bi ;
|
||||
|
||||
: cost-through ( origin node astar -- cost )
|
||||
[ cost>> call( n1 n2 -- c ) ] [ nip g>> at ] 3bi + ;
|
||||
[ astar>> cost ] [ nip astar>> g>> at ] 3bi + ;
|
||||
|
||||
: ?set-g ( origin node astar -- )
|
||||
[ cost-through ] 3keep [ swap ] 2dip
|
||||
3dup g>> at [ 1/0. ] unless* > [ 4drop ] [ set-g ] if ;
|
||||
3dup astar>> g>> at [ 1/0. ] unless* > [ 4drop ] [ set-g ] if ;
|
||||
|
||||
: build-path ( target astar -- path )
|
||||
[ over ] [ over [ [ origin>> at ] keep ] dip ] produce 2nip reverse ;
|
||||
|
||||
: handle ( node astar -- )
|
||||
dupd [ neighbours>> call( node -- neighbours ) ] keep [ ?set-g ] curry with each ;
|
||||
dupd [ astar>> neighbours ] keep [ ?set-g ] curry with each ;
|
||||
|
||||
: (find-path) ( astar -- path/f )
|
||||
dup open-set>> heap-empty? [
|
||||
|
@ -53,20 +57,25 @@ TUPLE: astar neighbours heuristic cost
|
|||
|
||||
: (init) ( from to astar -- )
|
||||
swap >>goal
|
||||
H{ } clone >>g
|
||||
H{ } clone over astar>> (>>g)
|
||||
H{ } clone over astar>> (>>in-closed-set)
|
||||
H{ } clone >>origin
|
||||
H{ } clone >>in-open-set
|
||||
H{ } clone >>in-closed-set
|
||||
<min-heap> >>open-set
|
||||
[ 0 ] 2dip [ (add-to-open-set) ] [ g>> set-at ] 3bi ;
|
||||
[ 0 ] 2dip [ (add-to-open-set) ] [ astar>> g>> set-at ] 3bi ;
|
||||
|
||||
TUPLE: astar-simple < astar cost heuristic neighbours ;
|
||||
M: astar-simple cost cost>> call( n1 n2 -- c ) ;
|
||||
M: astar-simple heuristic heuristic>> call( n1 n2 -- c ) ;
|
||||
M: astar-simple neighbours neighbours>> call( n -- neighbours ) ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: find-path ( start target astar -- path/f )
|
||||
[ (init) ] [ (find-path) ] bi ;
|
||||
(astar) new [ (>>astar) ] keep [ (init) ] [ (find-path) ] bi ;
|
||||
|
||||
: <astar> ( neighbours cost heuristic -- astar )
|
||||
astar new swap >>heuristic swap >>cost swap >>neighbours ;
|
||||
astar-simple new swap >>heuristic swap >>cost swap >>neighbours ;
|
||||
|
||||
: considered ( astar -- considered )
|
||||
in-closed-set>> keys ;
|
||||
|
|
Loading…
Reference in New Issue