abhin4v
/
russel-norvig-ai-problems
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

master
Abhinav Sarkar 2012-01-22 18:02:13 +05:30
parent 86924ea7cf
commit 432f5e2f15
1 changed files with 36 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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)