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

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
+  else Just Puzzle { blank = b
-                     , blankPos = let (d, r) = (fromJust . elemIndex b $ xs) `divMod` n
+                   , blankPos = let (d, r) = (fromJust . elemIndex b $ xs) `divMod` n
-                                  in (d + 1, r + 1)
+                                in (d + 1, r + 1)
-                     , pzState = array ((1, 1), (n, n))
+                   , pzState = array ((1, 1), (n, n))
-                                 [((i, j), xs !! (n * (i - 1) + (j - 1)))
+                               [((i, j), xs !! (n * (i - 1) + (j - 1)))
-                                 | i <- range (1, n), j <- range (1, n)]
+                               | 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"
+  ('\n' :) . intercalate "\n"
-  . map (concat . intersperse " ") . splitEvery (puzzleSize pz)
+  . 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 ()
+nPuzzle :: Int -> Int -> Int -> IO ()
-fifteenPuzzle seed = do
+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
+  args <- fmap (map read) getArgs
-  fifteenPuzzle $ read (args !! 0)
+  nPuzzle (args !! 0) (args !! 1) (args !! 2)