1 ! Copyright (C) 2010 Samuel Tardieu.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: arrays assocs combinators hashtables kernel literals math math.functions
4 math.vectors memoize path-finding sequences sorting splitting strings tools.test ;
7 ! Use a 10x9 maze (see below) to try to go from s to e, f or g.
8 ! X means that a position is unreachable.
10 ! - going up costs 5 points
11 ! - going down costs 1 point
12 ! - going left or right costs 2 points
18 : reachable? ( pos -- ? )
19 first2 [ 2 * 5 + ] [ 2 + ] bi* $[
30 8 X X X X X X X X X X"
31 "\n" split ] nth nth CHAR: X = not ;
36 { [ 1 + 2array ] [ 1 - 2array ] [ [ 1 + ] dip 2array ] [ [ 1 - ] dip 2array ] } 2cleave
38 [ reachable? ] filter ;
41 drop v- [ abs ] [ + ] map-reduce ;
44 drop 2dup [ first ] same? [ [ second ] bi@ > 1 5 ? ] [ 2drop 2 ] if ;
46 : test1 ( to -- path considered )
47 { 1 1 } swap maze new [ find-path ] [ considered ] bi ;
50 ! Existing path from s to f
73 ! Check that only the right positions have been considered in the s to f path
74 [ 7 ] [ { 7 1 } test1 nip length ] unit-test
76 ! Non-existing path from s to g -- all positions must have been considered
77 [ f 26 ] [ { 1 7 } test1 length ] unit-test
79 ! Look for a path between A and C. The best path is A --> D --> C. C will be placed
80 ! in the open set early because B will be examined first. This checks that the evaluation
81 ! of C is correctly replaced in the open set.
83 ! We use no heuristic here and always return 0.
93 ! A ---> D ---------> E ---> F
98 ! In this version, we will use the quotations-aware version through <astar>.
100 MEMO: routes ( -- hash ) $[ { "ABD" "BC" "C" "DCE" "ECF" } [ unclip swap 2array ] map >hashtable ] ;
102 : n ( pos -- neighbours )
105 : c ( from to -- cost )
106 "" 2sequence H{ { "AB" 1 } { "AD" 2 } { "BC" 5 } { "DC" 2 } { "DE" 1 } { "EC" 2 } { "EF" 1 } } at ;
108 : test2 ( fromto -- path considered )
109 first2 [ n ] [ c ] [ 2drop 0 ] <astar> [ find-path ] [ considered natural-sort >string ] bi ;
112 ! Check path from A to C -- all nodes but F must have been examined
113 [ "ADC" "ABCDE" ] [ "AC" test2 [ >string ] dip ] unit-test
115 ! No path from D to B -- all nodes reachable from D must have been examined
116 [ f "CDEF" ] [ "DB" test2 ] unit-test
118 ! Find a path using BFS. There are no path from F to A, and the path from D to
119 ! C does not include any other node.
121 [ f ] [ "FA" first2 routes <bfs> find-path ] unit-test
122 [ "DC" ] [ "DC" first2 routes <bfs> find-path >string ] unit-test
126 ! Build the costs as expected by the dijkstra word.
128 MEMO: costs ( -- costs )
129 routes keys [ dup dup n [ dup [ c ] dip swap 2array ] with { } map-as >hashtable 2array ] map >hashtable ;
131 : test3 ( fromto -- path considered )
132 first2 costs <dijkstra> [ find-path ] [ considered natural-sort >string ] bi ;
136 ! Check path from A to C -- all nodes but F must have been examined
137 [ "ADC" "ABCDE" ] [ "AC" test3 [ >string ] dip ] unit-test
139 ! No path from D to B -- all nodes reachable from D must have been examined
140 [ f "CDEF" ] [ "DB" test3 ] unit-test
144 { 1 H{ { 2 0 } { 3 0 } } }
145 { 2 H{ { 3 0 } { 1 0 } { 4 0 } } }
148 } <dijkstra> find-path