### Added strictness. Added generic nPuzzle function to be used as main.

This commit is contained in:
parent 86924ea7cf
commit 432f5e2f15
1 changed files with 36 additions and 28 deletions

#### 64 chapter4/SlidingPuzzle.hs View File

 `@ -1,3 +1,5 @@` `{-# LANGUAGE BangPatterns #-}` ``` ``` `-- Solves the sliding puzzle problem (http://en.wikipedia.org/wiki/Sliding_puzzle)` `-- using A* algorithm` ``` ``` `@ -29,7 +31,10 @@ getRandomR limits = do` ``` ``` `-- Swap the contents of two array indices i and i' in array a` `swap :: Ix a => a -> a -> Array a b -> Array a b` `swap i i' a = a // [(i, a ! i'), (i', a ! i)]` `swap i i' a = a // [(i, ai'), (i', ai)]` ` where` ` !ai' = a ! i'` ` !ai = a ! i` ``` ``` `-- Cost of a move` `type Cost = Int` `@ -56,24 +61,24 @@ astar initState goalState hueristic =` ` | otherwise = astar' pq'' seen' tracks'` ` where` ` -- Find the state with min f-cost` ` (state, gcost) = snd . PQ.findMin \$ pq` ` !(state, gcost) = snd . PQ.findMin \$ pq` ``` ``` ` -- Delete the state from open set` ` pq' = PQ.deleteMin pq` ` !pq' = PQ.deleteMin pq` ``` ``` ` -- Add the state to the closed set` ` seen' = S.insert state seen` ` !seen' = S.insert state seen` ``` ``` ` -- Find the successors (with their g and h costs) of the state` ` -- which have not been seen yet` ` successors = filter (\(s, _, _) -> not \$ S.member s seen')` ` !successors = filter (\(s, _, _) -> not \$ S.member s seen')` ` \$ successorsAndCosts state gcost` ``` ``` ` -- Insert the successors in the open set` ` pq'' = foldl (\q (s, g, h) -> PQ.insert (g + h) (s, g) q) pq' successors` ` !pq'' = foldl' (\q (s, g, h) -> PQ.insert (g + h) (s, g) q) pq' successors` ``` ``` ` -- Insert the tracks of the successors` ` tracks' = foldl (\m (s, _, _) -> M.insert s state m) tracks successors` ` !tracks' = foldl' (\m (s, _, _) -> M.insert s state m) tracks successors` ``` ``` ` -- Finds the successors of a given state and their costs` ` successorsAndCosts state gcost =` `@ -92,7 +97,7 @@ type Point = (Int, Int)` `-- blank : which item is considered blank` `-- blankPos : position of blank` `-- pzState : the current state of the puzzle` `data Puzzle a = Puzzle { blank :: a, blankPos :: Point, pzState :: Array Point a }` `data Puzzle a = Puzzle { blank :: !a, blankPos :: !Point, pzState :: !(Array Point a) }` ` deriving (Eq, Ord)` ``` ``` `-- Get puzzle size` `@ -106,26 +111,26 @@ fromList :: Ord a => a -> Int -> [a] -> Maybe (Puzzle a)` `fromList b n xs =` ` if (n * n /= length xs) || (b `notElem` xs)` ` then Nothing` ` else Just \$ Puzzle { blank = b` ` , blankPos = let (d, r) = (fromJust . elemIndex b \$ xs) `divMod` n` ` in (d + 1, r + 1)` ` , pzState = array ((1, 1), (n, n))` ` [((i, j), xs !! (n * (i - 1) + (j - 1)))` ` | i <- range (1, n), j <- range (1, n)]` ` }` ` else Just Puzzle { blank = b` ` , blankPos = let (d, r) = (fromJust . elemIndex b \$ xs) `divMod` n` ` in (d + 1, r + 1)` ` , pzState = array ((1, 1), (n, n))` ` [((i, j), xs !! (n * (i - 1) + (j - 1)))` ` | i <- range (1, n), j <- range (1, n)]` ` }` ``` ``` `-- Shows the puzzle state as a string` `showPuzzleState :: Show a => Puzzle a -> String` `showPuzzleState pz =` ` ('\n' :) . concat . intersperse "\n"` ` . map (concat . intersperse " ") . splitEvery (puzzleSize pz)` ` ('\n' :) . intercalate "\n"` ` . map unwords . splitEvery (puzzleSize pz)` ` . map show . A.elems . pzState \$ pz` ``` ``` `-- Get the legal neighbouring positions` `neighbourPos :: Int -> Point -> [Point]` `neighbourPos len p@(x, y) =` ` filter (\(x',y') -> and [x' >= 1, y' >= 1, x' <= len, y' <= len])` ` \$ [(x+1,y), (x-1,y), (x,y+1), (x,y-1)]` ` [(x+1,y), (x-1,y), (x,y+1), (x,y-1)]` ``` ``` `-- Get the next legal puzzle states` `nextStates :: Ord a => Puzzle a -> [Puzzle a]` `@ -140,7 +145,7 @@ instance Ord a => GameState (Puzzle a) where` ``` ``` `-- Make Puzzle an instance of Show for pretty printing` `instance Show a => Show (Puzzle a) where` ` show pz = showPuzzleState pz` ` show = showPuzzleState` ``` ``` `-- Shuffles a puzzle n times randomly to return a new (reachable) puzzle.` `shufflePuzzle :: Ord a => Int -> Puzzle a -> RandomState (Puzzle a)` `@ -154,9 +159,9 @@ shufflePuzzle n pz =` ``` ``` `-- Calculates the number of inversions in puzzle` `inversions :: Ord a => Puzzle a -> Int` `inversions pz = sum . map (\l -> length . filter (\e -> e < head l) \$ (tail l))` `inversions pz = sum . map (\l -> length . filter (\e -> e < head l) \$ tail l)` ` . filter ((> 1). length) . tails` ` . filter (not . (== (blank pz))) . A.elems . pzState \$ pz` ` . filter (not . (== blank pz)) . A.elems . pzState \$ pz` ``` ``` `-- Calculates the puzzle pairty. The puzzle pairty is invariant under legal moves.` `puzzlePairty :: Ord a => Puzzle a -> Int` `@ -181,7 +186,7 @@ solvePuzzle initState goalState hueristic =` `-- Returns number of tiles in wrong position in given state compared to goal state` `wrongTileCount :: Ord a => Puzzle a -> Puzzle a -> Cost` `wrongTileCount givenState goalState =` ` length . filter (\(a, b) -> a /= b)` ` length . filter (uncurry (/=))` ` \$ zip (A.elems . pzState \$ givenState) (A.elems . pzState \$ goalState)` ``` ``` `-- Calculates Manhattan distance between two points` `@ -198,16 +203,19 @@ sumManhattanDistance givenState goalState =` ` revM = M.fromList . map (\(x, y) -> (y, x)) . A.assocs . pzState \$ goalState` ``` ``` `-- The classic 15 puzzle (http://en.wikipedia.org/wiki/Fifteen_puzzle)` ``` ``` `fifteenPuzzle = nPuzzle 4 50` ``` ``` `-- seed : the seed for random generator` `fifteenPuzzle :: Int -> IO ()` `fifteenPuzzle seed = do` `nPuzzle :: Int -> Int -> Int -> IO ()` `nPuzzle n shuffles seed = do` ` -- Random generator` ` let gen = mkStdGen seed` ``` ``` ` -- The goal` ` let goalState = fromJust \$ fromList 0 4 [0..15]` ` let goalState = fromJust \$ fromList 0 n [0 .. (n * n -1)]` ` -- Shuffle the goal to get a random puzzle state` ` let initState = evalState (shufflePuzzle 50 goalState) gen` ` let initState = evalState (shufflePuzzle shuffles goalState) gen` ` -- Solve using sum manhattan distance heuristic` ` let (cost, solution) = fromJust \$ solvePuzzle initState goalState sumManhattanDistance` ``` ``` `@ -219,5 +227,5 @@ fifteenPuzzle seed = do` `-- The main` `main :: IO ()` `main = do` ` args <- getArgs` ` fifteenPuzzle \$ read (args !! 0)` ` args <- fmap (map read) getArgs` ` nPuzzle (args !! 0) (args !! 1) (args !! 2)`