 ### Added strictness. Added generic nPuzzle function to be used as main. Abhinav Sarkar 8 years ago
parent
commit
432f5e2f15
1 changed files with 36 additions and 28 deletions
1. 36
28
chapter4/SlidingPuzzle.hs

#### + 36 - 28 chapter4/SlidingPuzzle.hsView File

 ``@@ -1,3 +1,5 @@`` 1 ``+{-# LANGUAGE BangPatterns #-}`` 2 ``+`` 1 3 `` -- Solves the sliding puzzle problem (http://en.wikipedia.org/wiki/Sliding_puzzle)`` 2 4 `` -- using A* algorithm`` 3 5 `` `` ``@@ -29,7 +31,10 @@ getRandomR limits = do`` 29 31 `` `` 30 32 `` -- Swap the contents of two array indices i and i' in array a`` 31 33 `` swap :: Ix a => a -> a -> Array a b -> Array a b`` 32 ``-swap i i' a = a // [(i, a ! i'), (i', a ! i)]`` 34 ``+swap i i' a = a // [(i, ai'), (i', ai)]`` 35 ``+ where`` 36 ``+ !ai' = a ! i'`` 37 ``+ !ai = a ! i`` 33 38 `` `` 34 39 `` -- Cost of a move`` 35 40 `` type Cost = Int`` ``@@ -56,24 +61,24 @@ astar initState goalState hueristic =`` 56 61 `` | otherwise = astar' pq'' seen' tracks'`` 57 62 `` where`` 58 63 `` -- Find the state with min f-cost`` 59 ``- (state, gcost) = snd . PQ.findMin \$ pq`` 64 ``+ !(state, gcost) = snd . PQ.findMin \$ pq`` 60 65 `` `` 61 66 `` -- Delete the state from open set`` 62 ``- pq' = PQ.deleteMin pq`` 67 ``+ !pq' = PQ.deleteMin pq`` 63 68 `` `` 64 69 `` -- Add the state to the closed set`` 65 ``- seen' = S.insert state seen`` 70 ``+ !seen' = S.insert state seen`` 66 71 `` `` 67 72 `` -- Find the successors (with their g and h costs) of the state`` 68 73 `` -- which have not been seen yet`` 69 ``- successors = filter (\(s, _, _) -> not \$ S.member s seen')`` 74 ``+ !successors = filter (\(s, _, _) -> not \$ S.member s seen')`` 70 75 `` \$ successorsAndCosts state gcost`` 71 76 `` `` 72 77 `` -- Insert the successors in the open set`` 73 ``- pq'' = foldl (\q (s, g, h) -> PQ.insert (g + h) (s, g) q) pq' successors`` 78 ``+ !pq'' = foldl' (\q (s, g, h) -> PQ.insert (g + h) (s, g) q) pq' successors`` 74 79 `` `` 75 80 `` -- Insert the tracks of the successors`` 76 ``- tracks' = foldl (\m (s, _, _) -> M.insert s state m) tracks successors`` 81 ``+ !tracks' = foldl' (\m (s, _, _) -> M.insert s state m) tracks successors`` 77 82 `` `` 78 83 `` -- Finds the successors of a given state and their costs`` 79 84 `` successorsAndCosts state gcost =`` ``@@ -92,7 +97,7 @@ type Point = (Int, Int)`` 92 97 `` -- blank : which item is considered blank`` 93 98 `` -- blankPos : position of blank`` 94 99 `` -- pzState : the current state of the puzzle`` 95 ``-data Puzzle a = Puzzle { blank :: a, blankPos :: Point, pzState :: Array Point a }`` 100 ``+data Puzzle a = Puzzle { blank :: !a, blankPos :: !Point, pzState :: !(Array Point a) }`` 96 101 `` deriving (Eq, Ord)`` 97 102 `` `` 98 103 `` -- Get puzzle size`` ``@@ -106,26 +111,26 @@ fromList :: Ord a => a -> Int -> [a] -> Maybe (Puzzle a)`` 106 111 `` fromList b n xs =`` 107 112 `` if (n * n /= length xs) || (b `notElem` xs)`` 108 113 `` then Nothing`` 109 ``- else Just \$ Puzzle { blank = b`` 110 ``- , blankPos = let (d, r) = (fromJust . elemIndex b \$ xs) `divMod` n`` 111 ``- in (d + 1, r + 1)`` 112 ``- , pzState = array ((1, 1), (n, n))`` 113 ``- [((i, j), xs !! (n * (i - 1) + (j - 1)))`` 114 ``- | i <- range (1, n), j <- range (1, n)]`` 115 ``- }`` 114 ``+ else Just Puzzle { blank = b`` 115 ``+ , blankPos = let (d, r) = (fromJust . elemIndex b \$ xs) `divMod` n`` 116 ``+ in (d + 1, r + 1)`` 117 ``+ , pzState = array ((1, 1), (n, n))`` 118 ``+ [((i, j), xs !! (n * (i - 1) + (j - 1)))`` 119 ``+ | i <- range (1, n), j <- range (1, n)]`` 120 ``+ }`` 116 121 `` `` 117 122 `` -- Shows the puzzle state as a string`` 118 123 `` showPuzzleState :: Show a => Puzzle a -> String`` 119 124 `` showPuzzleState pz =`` 120 ``- ('\n' :) . concat . intersperse "\n"`` 121 ``- . map (concat . intersperse " ") . splitEvery (puzzleSize pz)`` 125 ``+ ('\n' :) . intercalate "\n"`` 126 ``+ . map unwords . splitEvery (puzzleSize pz)`` 122 127 `` . map show . A.elems . pzState \$ pz`` 123 128 `` `` 124 129 `` -- Get the legal neighbouring positions`` 125 130 `` neighbourPos :: Int -> Point -> [Point]`` 126 131 `` neighbourPos len p@(x, y) =`` 127 132 `` filter (\(x',y') -> and [x' >= 1, y' >= 1, x' <= len, y' <= len])`` 128 ``- \$ [(x+1,y), (x-1,y), (x,y+1), (x,y-1)]`` 133 ``+ [(x+1,y), (x-1,y), (x,y+1), (x,y-1)]`` 129 134 `` `` 130 135 `` -- Get the next legal puzzle states`` 131 136 `` nextStates :: Ord a => Puzzle a -> [Puzzle a]`` ``@@ -140,7 +145,7 @@ instance Ord a => GameState (Puzzle a) where`` 140 145 `` `` 141 146 `` -- Make Puzzle an instance of Show for pretty printing`` 142 147 `` instance Show a => Show (Puzzle a) where`` 143 ``- show pz = showPuzzleState pz`` 148 ``+ show = showPuzzleState`` 144 149 `` `` 145 150 `` -- Shuffles a puzzle n times randomly to return a new (reachable) puzzle.`` 146 151 `` shufflePuzzle :: Ord a => Int -> Puzzle a -> RandomState (Puzzle a)`` ``@@ -154,9 +159,9 @@ shufflePuzzle n pz =`` 154 159 `` `` 155 160 `` -- Calculates the number of inversions in puzzle`` 156 161 `` inversions :: Ord a => Puzzle a -> Int`` 157 ``-inversions pz = sum . map (\l -> length . filter (\e -> e < head l) \$ (tail l))`` 162 ``+inversions pz = sum . map (\l -> length . filter (\e -> e < head l) \$ tail l)`` 158 163 `` . filter ((> 1). length) . tails`` 159 ``- . filter (not . (== (blank pz))) . A.elems . pzState \$ pz`` 164 ``+ . filter (not . (== blank pz)) . A.elems . pzState \$ pz`` 160 165 `` `` 161 166 `` -- Calculates the puzzle pairty. The puzzle pairty is invariant under legal moves.`` 162 167 `` puzzlePairty :: Ord a => Puzzle a -> Int`` ``@@ -181,7 +186,7 @@ solvePuzzle initState goalState hueristic =`` 181 186 `` -- Returns number of tiles in wrong position in given state compared to goal state`` 182 187 `` wrongTileCount :: Ord a => Puzzle a -> Puzzle a -> Cost`` 183 188 `` wrongTileCount givenState goalState =`` 184 ``- length . filter (\(a, b) -> a /= b)`` 189 ``+ length . filter (uncurry (/=))`` 185 190 `` \$ zip (A.elems . pzState \$ givenState) (A.elems . pzState \$ goalState)`` 186 191 `` `` 187 192 `` -- Calculates Manhattan distance between two points`` ``@@ -198,16 +203,19 @@ sumManhattanDistance givenState goalState =`` 198 203 `` revM = M.fromList . map (\(x, y) -> (y, x)) . A.assocs . pzState \$ goalState`` 199 204 `` `` 200 205 `` -- The classic 15 puzzle (http://en.wikipedia.org/wiki/Fifteen_puzzle)`` 206 ``+`` 207 ``+fifteenPuzzle = nPuzzle 4 50`` 208 ``+`` 201 209 `` -- seed : the seed for random generator`` 202 ``-fifteenPuzzle :: Int -> IO ()`` 203 ``-fifteenPuzzle seed = do`` 210 ``+nPuzzle :: Int -> Int -> Int -> IO ()`` 211 ``+nPuzzle n shuffles seed = do`` 204 212 `` -- Random generator`` 205 213 `` let gen = mkStdGen seed`` 206 214 `` `` 207 215 `` -- The goal`` 208 ``- let goalState = fromJust \$ fromList 0 4 [0..15]`` 216 ``+ let goalState = fromJust \$ fromList 0 n [0 .. (n * n -1)]`` 209 217 `` -- Shuffle the goal to get a random puzzle state`` 210 ``- let initState = evalState (shufflePuzzle 50 goalState) gen`` 218 ``+ let initState = evalState (shufflePuzzle shuffles goalState) gen`` 211 219 `` -- Solve using sum manhattan distance heuristic`` 212 220 `` let (cost, solution) = fromJust \$ solvePuzzle initState goalState sumManhattanDistance`` 213 221 `` `` ``@@ -219,5 +227,5 @@ fifteenPuzzle seed = do`` 219 227 `` -- The main`` 220 228 `` main :: IO ()`` 221 229 `` main = do`` 222 ``- args <- getArgs`` 223 ``- fifteenPuzzle \$ read (args !! 0)`` 230 ``+ args <- fmap (map read) getArgs`` 231 ``+ nPuzzle (args !! 0) (args !! 1) (args !! 2)``