diff --git a/extra/path-finding/path-finding-docs.factor b/extra/path-finding/path-finding-docs.factor index 46f1048ba7..a41959db69 100644 --- a/extra/path-finding/path-finding-docs.factor +++ b/extra/path-finding/path-finding-docs.factor @@ -3,7 +3,7 @@ USING: help.markup help.syntax ; IN: path-finding -{ } related-words +{ } related-words HELP: astar { $description "This tuple must be subclassed and its method " { $link cost } ", " @@ -65,6 +65,17 @@ HELP: "path finding algorithm which is a particular case of the general A* algorithm." } ; +HELP: +{ $values + { "costs" "an assoc" } +} +{ $description "Build an astar object from the " { $snippet "costs" } " assoc. " + "The assoc keys are edges of the graph, while the corresponding values are assocs whose keys are " + "the edges that can be reached and whose values are the costs to reach those edges. When used with " + { $link find-path } ", this astar tuple will use the Dijkstra path finding algorithm which is " + "a particular case of the general A* algorithm." +} ; + HELP: find-path { $values { "start" "a node" } diff --git a/extra/path-finding/path-finding-tests.factor b/extra/path-finding/path-finding-tests.factor index 11a047cb89..0e9b5289b1 100644 --- a/extra/path-finding/path-finding-tests.factor +++ b/extra/path-finding/path-finding-tests.factor @@ -120,3 +120,21 @@ MEMO: routes ( -- hash ) $[ { "ABD" "BC" "C" "DCE" "ECF" } [ unclip swap 2array [ f ] [ "FA" first2 routes find-path ] unit-test [ "DC" ] [ "DC" first2 routes find-path >string ] unit-test + +<< + +! Build the costs as expected by the dijkstra word. + +MEMO: costs ( -- costs ) + routes keys [ dup dup n [ dup [ c ] dip swap 2array ] with { } map-as >hashtable 2array ] map >hashtable ; + +: test3 ( fromto -- path considered ) + first2 costs [ find-path ] [ considered natural-sort >string ] bi ; + +>> + +! Check path from A to C -- all nodes but F must have been examined +[ "ADC" "ABCDE" ] [ "AC" test3 [ >string ] dip ] unit-test + +! No path from D to B -- all nodes reachable from D must have been examined +[ f "CDEF" ] [ "DB" test3 ] unit-test diff --git a/extra/path-finding/path-finding.factor b/extra/path-finding/path-finding.factor index cd63a5c8d5..4b11616c20 100644 --- a/extra/path-finding/path-finding.factor +++ b/extra/path-finding/path-finding.factor @@ -74,6 +74,11 @@ M: bfs cost 3drop 1 ; M: bfs heuristic 3drop 0 ; M: bfs neighbours neighbours>> at ; +TUPLE: dijkstra < astar costs ; +M: dijkstra cost costs>> swapd at at ; +M: dijkstra heuristic 3drop 0 ; +M: dijkstra neighbours costs>> at keys ; + PRIVATE> : find-path ( start target astar -- path/f ) @@ -87,3 +92,6 @@ PRIVATE> : ( neighbours -- astar ) [ bfs new ] dip >>neighbours ; + +: ( costs -- astar ) + [ dijkstra new ] dip >>costs ;