Skip to content

Commit f57288d

Browse files
abhin4vabhin4v
committed
Switched to hash based collections, added quickcheck tests
1. Moved to hash set and hash map from tree set and tree map because it does not make sense that the search nodes must be ordered which is a constraint imposed by tree set and tree map. 2. Added quickcheck property based tests.
1 parent 94f6862 commit f57288d

2 files changed

Lines changed: 97 additions & 46 deletions

File tree

‎A_Star_Search/Haskell/abhin4v/AStarSearch.hs‎

Lines changed: 26 additions & 25 deletions
Original file line numberDiff line numberDiff line change
@@ -1,35 +1,36 @@
11
module AStarSearch where
22

33
import qualified Data.PQueue.Prio.Min as PQ
4-
import qualified Data.Set as S
5-
import qualified Data.Map as M
4+
import qualified Data.HashSet as Set
5+
import qualified Data.HashMap.Strict as Map
6+
import Data.Hashable (Hashable)
67
import Data.List (foldl')
78
import Data.Maybe (fromJust)
89

910
-- A* search: Finds the shortest path from a start node to a goal node using a heuristic function.
10-
astarSearch :: (Ord a, Ord b, Num b) =>
11-
a -- startNode: the node to start the search from
12-
-> (a -> Bool) -- isGoalNode: a function to test if a node is the goal node
13-
-> (a -> [(a, b)]) -- nextNodeFn: a function which calculates the next nodes for a current node
14-
-- along with the costs of moving from the current node to the next nodes
15-
-> (a -> b) -- heuristic: a function which calculates the (approximate) cost of moving
16-
-- from a node to the nearest goal node
17-
-> Maybe (b, [a]) -- result: Nothing is no path is found else
18-
-- Just (path cost, path as a list of nodes)
11+
astarSearch :: (Eq a, Hashable a) =>
12+
a -- startNode: the node to start the search from
13+
-> (a -> Bool) -- isGoalNode: a function to test if a node is the goal node
14+
-> (a -> [(a, Int)]) -- nextNodeFn: a function which calculates the next nodes for a current node
15+
-- along with the costs of moving from the current node to the next nodes
16+
-> (a -> Int) -- heuristic: a function which calculates the (approximate) cost of moving
17+
-- from a node to the nearest goal node
18+
-> Maybe (Int, [a]) -- result: Nothing is no path is found else
19+
-- Just (path cost, path as a list of nodes)
1920
astarSearch startNode isGoalNode nextNodeFn heuristic =
20-
astar' (PQ.singleton (heuristic startNode) (startNode, 0))
21-
S.empty (M.singleton startNode 0) M.empty
21+
astar (PQ.singleton (heuristic startNode) (startNode, 0))
22+
Set.empty (Map.singleton startNode 0) Map.empty
2223
where
2324
-- pq: open set, seen: closed set, tracks: tracks of states
24-
astar' pq seen gscore tracks
25+
astar pq seen gscore tracks
2526
-- If open set is empty then search has failed. Return Nothing
2627
| PQ.null pq = Nothing
2728
-- If goal node reached then construct the path from the tracks and node
2829
| isGoalNode node = Just (gcost, findPath tracks node)
2930
-- If node has already been seen then discard it and continue
30-
| S.member node seen = astar' pq' seen gscore tracks
31+
| Set.member node seen = astar pq' seen gscore tracks
3132
-- Else expand the node and continue
32-
| otherwise = astar' pq'' seen' gscore' tracks'
33+
| otherwise = astar pq'' seen' gscore' tracks'
3334
where
3435
-- Find the node with min f-cost
3536
(node, gcost) = snd . PQ.findMin $ pq
@@ -38,31 +39,31 @@ astarSearch startNode isGoalNode nextNodeFn heuristic =
3839
pq' = PQ.deleteMin pq
3940

4041
-- Add the node to the closed set
41-
seen' = S.insert node seen
42+
seen' = Set.insert node seen
4243

4344
-- Find the successors (with their g and h costs) of the node
4445
-- which have not been seen yet
4546
successors =
4647
filter (\(s, g, _) ->
47-
not (S.member s seen') &&
48-
(not (s `M.member` gscore)
49-
|| g < (fromJust . M.lookup s $ gscore)))
50-
$ successorsAndCosts node gcost
48+
not (Set.member s seen') &&
49+
(not (s `Map.member` gscore)
50+
|| g < (fromJust . Map.lookup s $ gscore)))
51+
$ successorsAndCosts node gcost
5152

5253
-- Insert the successors in the open set
5354
pq'' = foldl' (\q (s, g, h) -> PQ.insert (g + h) (s, g) q) pq' successors
5455

55-
gscore' = foldl' (\m (s, g, _) -> M.insert s g m) gscore successors
56+
gscore' = foldl' (\m (s, g, _) -> Map.insert s g m) gscore successors
5657

5758
-- Insert the tracks of the successors
58-
tracks' = foldl' (\m (s, _, _) -> M.insert s node m) tracks successors
59+
tracks' = foldl' (\m (s, _, _) -> Map.insert s node m) tracks successors
5960

6061
-- Finds the successors of a given node and their costs
6162
successorsAndCosts node gcost =
6263
map (\(s, g) -> (s, gcost + g, heuristic s)) . nextNodeFn $ node
6364

6465
-- Constructs the path from the tracks and last node
6566
findPath tracks node =
66-
if M.member node tracks
67-
then findPath tracks (fromJust . M.lookup node $ tracks) ++ [node]
67+
if Map.member node tracks
68+
then findPath tracks (fromJust . Map.lookup node $ tracks) ++ [node]
6869
else [node]

‎A_Star_Search/Haskell/abhin4v/AStarSearch_test.hs‎

Lines changed: 71 additions & 21 deletions
Original file line numberDiff line numberDiff line change
@@ -1,15 +1,26 @@
1+
{-# LANGUAGE TemplateHaskell #-}
2+
13
module AStarSearchTest where
24

35
import AStarSearch
6+
import Data.List (foldl')
47
import Data.Maybe (fromJust)
8+
import Data.Sequence ((|>))
9+
import Test.QuickCheck
10+
import Test.QuickCheck.All
11+
import qualified Data.HashMap.Strict as Map
12+
import qualified Data.Sequence as Seq
513

614
-- We use A* search to find the shortest path (path with least number of moves) of a knight
715
-- from a start square to a goal square on a chess board.
816

17+
type Square = (Int, Int)
18+
type Path = [Square]
19+
920
-- Finds the next squares a knight can move to from a given square
1021
nextKnightPos (x, y) =
11-
zip (filter isValidMove . map (\(dx, dy) -> (x + dx, y + dy)) $ moves) (repeat 1)
12-
where
22+
filter isValidMove . map (\(dx, dy) -> (x + dx, y + dy)) $ moves
23+
where
1324
moves = [(1,2), (1,-2), (-1,2), (-1,-2), (2,1), (2,-1), (-2,1), (-2,-1)]
1425
isValidMove (x, y) = and [x > 0, x < 9, y > 0, y < 9]
1526

@@ -18,23 +29,62 @@ nextKnightPos (x, y) =
1829
mkHeuristic (gx, gy) (x, y) = max (abs (x-gx)) (abs (y-gy)) `div` 2
1930

2031
-- Finds the shortest path of the knight
21-
knightsShortestPath :: (Int, Int) -> (Int, Int) -> [(Int, Int)]
32+
knightsShortestPath :: Square -> Square -> Path
2233
knightsShortestPath initSq goalSq =
23-
snd . fromJust $ astarSearch initSq (== goalSq) nextKnightPos (mkHeuristic goalSq)
24-
25-
-- example runs
26-
main :: IO ()
27-
main = do
28-
print $ knightsShortestPath (1,1) (2,2)
29-
-- prints [(1,1),(3,2),(5,3),(4,1),(2,2)]
30-
print $ knightsShortestPath (4,1) (7,2)
31-
-- prints [(4,1),(5,3),(7,2)]
32-
print $ knightsShortestPath (4,1) (8,7)
33-
-- prints [(4,1),(6,2),(5,4),(7,5),(8,7)]
34-
print $ knightsShortestPath (8,1) (7,8)
35-
-- prints [(8,1),(7,3),(8,5),(6,6),(7,8)]
36-
print $ knightsShortestPath (1,1) (8,8)
37-
-- prints [(1,1),(2,3),(3,5),(4,3),(5,5),(7,6),(8,8)]
38-
print $ knightsShortestPath (1,1) (1,1)
39-
-- prints [(1,1)]
40-
return ()
34+
snd . fromJust
35+
$ astarSearch initSq (== goalSq) (flip zip (repeat 1) . nextKnightPos) (mkHeuristic goalSq)
36+
37+
-- Finds the shortest path using breadth first search. Used for checking if the path returned by
38+
-- A* search is indeed shortest.
39+
bfs :: Square -> Square -> Path
40+
bfs startSq goalSq =
41+
bfs' goalSq (Map.singleton startSq noSuchSq) (Seq.singleton startSq)
42+
where
43+
noSuchSq = (-1,-1)
44+
45+
bfs' goalSq tracks open = let
46+
(first, rest) = Seq.splitAt 1 open
47+
currentSq = Seq.index first 0
48+
in if currentSq == goalSq
49+
then consPath currentSq
50+
else let
51+
nextSqs = filter (not . flip Map.member tracks) . nextKnightPos $ currentSq
52+
tracks' = foldl' (\t s -> Map.insert s currentSq t) tracks nextSqs
53+
in bfs' goalSq tracks' (foldl (|>) rest nextSqs)
54+
where
55+
consPath square =
56+
if Map.member square tracks
57+
then consPath (fromJust . Map.lookup square $ tracks) ++ [square]
58+
else []
59+
60+
-- Setup to generate arbitrary squares for testing
61+
newtype TestSquare = TestSquare { sq :: Square } deriving (Show)
62+
63+
instance Arbitrary TestSquare where
64+
arbitrary = do
65+
x <- choose (1, 8)
66+
y <- choose (1, 8)
67+
return $ TestSquare (x, y)
68+
69+
-- Properties to test
70+
prop_path_starts_with_start_square startSq goalSq =
71+
head (knightsShortestPath (sq startSq) (sq goalSq)) == sq startSq
72+
73+
prop_path_ends_with_goal_square startSq goalSq =
74+
last (knightsShortestPath (sq startSq) (sq goalSq)) == sq goalSq
75+
76+
prop_path_consists_of_valid_knights_moves startSq goalSq =
77+
let path = knightsShortestPath (sq startSq) (sq goalSq)
78+
in all isValidKnightsMove $ zip path (tail path)
79+
where
80+
isValidKnightsMove (sqFrom, sqTo) = sqTo `elem` nextKnightPos sqFrom
81+
82+
prop_path_is_shortest startSq goalSq =
83+
let path = knightsShortestPath (sq startSq) (sq goalSq)
84+
in length path == length (bfs (sq startSq) (sq goalSq))
85+
86+
-- Tests all the properties 1000 times each
87+
testAllProps = $forAllProperties $ quickCheckWithResult (stdArgs {maxSuccess = 1000})
88+
89+
-- main function runs the tests. Type `runhaskell AStarSearch_test.hs` on command line to run the tests.
90+
main = testAllProps >> return ()

0 commit comments

Comments
 (0)