|
|
|
@ -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) |
|
|
|
|