Browse Source

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.hs View 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)

Loading…
Cancel
Save