diff --git a/chapter4/SlidingPuzzle.hs b/chapter4/SlidingPuzzle.hs index 0343aad..9183827 100644 --- a/chapter4/SlidingPuzzle.hs +++ b/chapter4/SlidingPuzzle.hs @@ -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)