diff --git a/extra/astar/astar-docs.factor b/extra/astar/astar-docs.factor index b8da237ed6..b43f2aba1c 100644 --- a/extra/astar/astar-docs.factor +++ b/extra/astar/astar-docs.factor @@ -3,7 +3,40 @@ USING: help.markup help.syntax ; IN: astar -{ find-path 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 } " 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: { $values @@ -16,7 +49,8 @@ HELP: { $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 diff --git a/extra/astar/astar.factor b/extra/astar/astar.factor index 1912b6af21..45f8aaa86e 100644 --- a/extra/astar/astar.factor +++ b/extra/astar/astar.factor @@ -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 ) + > 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 >>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 ; : ( 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 ;