extra/path-finding/path-finding-tests.factor

   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 ;
   5 IN: path-finding.tests
   6
   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.
   9 ! The costs model is:
  10 !   - going up costs 5 points
  11 !   - going down costs 1 point
  12 !   - going left or right costs 2 points
  13
  14 <<
  15
  16 TUPLE: maze < astar ;
  17
  18 : reachable? ( pos -- ? )
  19     first2 [ 2 * 5 + ] [ 2 + ] bi* $[
  20 "    0 1 2 3 4 5 6 7 8 9
  21
  22   0  X X X X X X X X X X
  23   1  X s           f X X
  24   2  X X X X   X X X X X
  25   3  X X X X   X X X X X
  26   4  X X X X   X       X
  27   5  X X       X   X   X
  28   6  X X X X   X   X e X
  29   7  X g   X           X
  30   8  X X X X X X X X X X"
  31         split-lines ] nth nth CHAR: X = not ;
  32
  33 M: maze neighbors
  34     drop
  35     first2
  36     { [ 1 + 2array ] [ 1 - 2array ] [ [ 1 + ] dip 2array ] [ [ 1 - ] dip 2array ] } 2cleave
  37     4array
  38     [ reachable? ] filter ;
  39
  40 M: maze heuristic
  41     drop v- [ abs ] [ + ] map-reduce ;
  42
  43 M: maze cost
  44     drop 2dup [ first ] same? [ [ second ] bi@ > 1 5 ? ] [ 2drop 2 ] if ;
  45
  46 : test1 ( to -- path considered )
  47     { 1 1 } swap maze new [ find-path ] [ considered ] bi ;
  48 >>
  49
  50 ! Existing path from s to f
  51 {
  52     {
  53         { 1 1 }
  54         { 2 1 }
  55         { 3 1 }
  56         { 4 1 }
  57         { 4 2 }
  58         { 4 3 }
  59         { 4 4 }
  60         { 4 5 }
  61         { 4 6 }
  62         { 4 7 }
  63         { 5 7 }
  64         { 6 7 }
  65         { 7 7 }
  66         { 8 7 }
  67         { 8 6 }
  68     }
  69 } [
  70     { 8 6 } test1 drop
  71 ] unit-test
  72
  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
  75
  76 ! Non-existing path from s to g -- all positions must have been considered
  77 { f 26 } [ { 1 7 } test1 length ] unit-test
  78
  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.
  82 !
  83 ! We use no heuristic here and always return 0.
  84 !
  85 !       (5)
  86 !     B ---> C <--------
  87 !                        \ (2)
  88 !     ^      ^            |
  89 !     |      |            |
  90 ! (1) |      | (2)        |
  91 !     |      |            |
  92 !
  93 !     A ---> D ---------> E ---> F
  94 !       (2)       (1)       (1)
  95
  96 <<
  97
  98 ! In this version, we will use the quotations-aware version through <astar>.
  99
 100 MEMO: routes ( -- hash ) $[ { "ABD" "BC" "C" "DCE" "ECF" } [ unclip swap 2array ] map >hashtable ] ;
 101
 102 : n ( pos -- neighbors )
 103     routes at ;
 104
 105 : c ( from to -- cost )
 106     "" 2sequence H{ { "AB" 1 } { "AD" 2 } { "BC" 5 } { "DC" 2 } { "DE" 1 } { "EC" 2 } { "EF" 1 } } at ;
 107
 108 : test2 ( fromto -- path considered )
 109     first2 [ n ] [ c ] [ 2drop 0 ] <astar> [ find-path ] [ considered natural-sort >string ] bi ;
 110 >>
 111
 112 ! Check path from A to C -- all nodes but F must have been examined
 113 { "ADC" "ABCDE" } [ "AC" test2 [ >string ] dip ] unit-test
 114
 115 ! No path from D to B -- all nodes reachable from D must have been examined
 116 { f "CDEF" } [ "DB" test2 ] unit-test
 117
 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.
 120
 121 { f } [ "FA" first2 routes <bfs> find-path ] unit-test
 122 { "DC" } [ "DC" first2 routes <bfs> find-path >string ] unit-test
 123
 124 <<
 125
 126 ! Build the costs as expected by the dijkstra word.
 127
 128 MEMO: costs ( -- costs )
 129     routes keys [ dup dup n [ dup [ c ] dip swap 2array ] with { } map-as >hashtable 2array ] map >hashtable ;
 130
 131 : test3 ( fromto -- path considered )
 132     first2 costs <dijkstra> [ find-path ] [ considered natural-sort >string ] bi ;
 133
 134 >>
 135
 136 ! Check path from A to C -- all nodes but F must have been examined
 137 { "ADC" "ABCDE" } [ "AC" test3 [ >string ] dip ] unit-test
 138
 139 ! No path from D to B -- all nodes reachable from D must have been examined
 140 { f "CDEF" } [ "DB" test3 ] unit-test
 141
 142 { { 1 3 } } [
 143     1 3 H{
 144         { 1 H{ { 2 0 } { 3 0 } } }
 145         { 2 H{ { 3 0 } { 1 0 } { 4 0 } } }
 146         { 3 H{ { 4 0 } } }
 147         { 4 H{ } }
 148     } <dijkstra> find-path
 149 ] unit-test