steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Also test the derivation variant of astar

db4
Samuel Tardieu 2010-03-16 09:28:51 +01:00
parent 604ccb0a3a
commit db106486f1
1 changed files with 19 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
extra/astar/astar-tests.factor
View File

@ -4,8 +4,6 @@ USING: arrays assocs astar combinators hashtables kernel literals math math.func
math.vectors sequences sorting splitting strings tools.test ; math.vectors sequences sorting splitting strings tools.test ;
IN: astar.tests IN: astar.tests
<<
! Use a 10x9 maze (see below) to try to go from s to e, f or g. ! Use a 10x9 maze (see below) to try to go from s to e, f or g.
! X means that a position is unreachable. ! X means that a position is unreachable.
! The costs model is: ! The costs model is:
@ -13,6 +11,10 @@ IN: astar.tests
! - going down costs 1 point ! - going down costs 1 point
! - going left or right costs 2 points ! - going left or right costs 2 points
<<
TUPLE: maze < astar ;
: reachable? ( pos -- ? ) : reachable? ( pos -- ? )
first2 [ 2 * 5 + ] [ 2 + ] bi* $[ first2 [ 2 * 5 + ] [ 2 + ] bi* $[
" 0 1 2 3 4 5 6 7 8 9 " 0 1 2 3 4 5 6 7 8 9
@ -28,20 +30,21 @@ IN: astar.tests
8 X X X X X X X X X X" 8 X X X X X X X X X X"
"\n" split ] nth nth CHAR: X = not ; "\n" split ] nth nth CHAR: X = not ;
: neighbours ( pos -- neighbours ) M: maze neighbours
first2 drop
{ [ 1 + 2array ] [ 1 - 2array ] [ [ 1 + ] dip 2array ] [ [ 1 - ] dip 2array ] } 2cleave first2
4array { [ 1 + 2array ] [ 1 - 2array ] [ [ 1 + ] dip 2array ] [ [ 1 - ] dip 2array ] } 2cleave
[ reachable? ] filter ; 4array
[ reachable? ] filter ;
: heuristic ( from to -- cost ) M: maze heuristic
v- [ abs ] [ + ] map-reduce ; drop v- [ abs ] [ + ] map-reduce ;
: cost ( from to -- cost ) M: maze cost
2dup [ first ] bi@ = [ [ second ] bi@ > 1 5 ? ] [ 2drop 2 ] if ; drop 2dup [ first ] bi@ = [ [ second ] bi@ > 1 5 ? ] [ 2drop 2 ] if ;
: test1 ( to -- path considered ) : test1 ( to -- path considered )
{ 1 1 } swap [ neighbours ] [ cost ] [ heuristic ] <astar> [ find-path ] [ considered ] bi ; { 1 1 } swap maze new [ find-path ] [ considered ] bi ;
>> >>
! Existing path from s to f ! Existing path from s to f
@ -73,8 +76,6 @@ IN: astar.tests
! Non-existing path from s to g -- all positions must have been considered ! Non-existing path from s to g -- all positions must have been considered
[ f 26 ] [ { 1 7 } test1 length ] unit-test [ f 26 ] [ { 1 7 } test1 length ] unit-test
<<
! Look for a path between A and C. The best path is A --> D --> C. C will be placed ! Look for a path between A and C. The best path is A --> D --> C. C will be placed
! in the open set early because B will be examined first. This checks that the evaluation ! in the open set early because B will be examined first. This checks that the evaluation
! of C is correctly replaced in the open set. ! of C is correctly replaced in the open set.
@ -92,6 +93,10 @@ IN: astar.tests
! A ---> D ---------> E ---> F ! A ---> D ---------> E ---> F
! (2) (1) (1) ! (2) (1) (1)
<<
! In this version, we will use the quotations-aware version through <astar>.
: n ( pos -- neighbours ) : n ( pos -- neighbours )
$[ { "ABD" "BC" "C" "DCE" "ECF" } [ unclip swap 2array ] map >hashtable ] at ; $[ { "ABD" "BC" "C" "DCE" "ECF" } [ unclip swap 2array ] map >hashtable ] at ;