232 lines
8.0 KiB
Haskell
232 lines
8.0 KiB
Haskell
{# LANGUAGE BangPatterns #}




 Solves the sliding puzzle problem (http://en.wikipedia.org/wiki/Sliding_puzzle)


 using A* algorithm




module SlidingPuzzle where




import Data.Ix


import qualified Data.Array as A


import Data.Array (Array, array, (//), (!))


import Data.List


import Data.List.Split


import Data.Maybe


import qualified Data.Set as S


import qualified Data.Map as M


import qualified Data.PQueue.Prio.Min as PQ


import System.Random


import System.Environment


import Control.Monad.State




 A State with a ramdom generator


type RandomState = State StdGen




 Generates a random element between given limits inside State monad


getRandomR :: Random a => (a, a) > RandomState a


getRandomR limits = do


gen < get


let (val, gen') = randomR limits gen


put gen'


return val




 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, ai'), (i', ai)]


where


!ai' = a ! i'


!ai = a ! i




 Cost of a move


type Cost = Int




 A state in the game


class Ord a => GameState a where


succs :: a > [(a, Cost)]




 A* algorithm: Find a path from initial state to goal state using heuristic


 Returns Nothing if no path found. Else returns Just (path cost, path).


astar :: GameState a => a > a > (a > a > Cost) > Maybe (Cost, [a])


astar initState goalState hueristic =


astar' (PQ.singleton (hueristic initState goalState) (initState, 0)) S.empty M.empty


where


 pq: open set, seen: closed set, tracks: tracks of states


astar' pq seen tracks


 If goal state reached then construct the path from the tracks and state


 state == goalState = Just (gcost, findPath tracks state)


 If open set is empty then search has failed. Return Nothing


 PQ.null pq = Nothing


 If state has already been seen then discard it and continue


 S.member state seen = astar' pq' seen tracks


 Else expand the state and continue


 otherwise = astar' pq'' seen' tracks'


where


 Find the state with min fcost


!(state, gcost) = snd . PQ.findMin $ pq




 Delete the state from open set


!pq' = PQ.deleteMin pq




 Add the state to the closed set


!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')


$ 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




 Insert the tracks of the 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 =


map (\(s,g) > (s, gcost + g, hueristic s goalState)) . succs $ state




 Constructs the path from the tracks and last state


findPath tracks state =


if M.member state tracks


then findPath tracks (fromJust . M.lookup state $ tracks) ++ [state]


else [state]




 A point in 2d


type Point = (Int, Int)




 A sliding puzzle


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


deriving (Eq, Ord)




 Get puzzle size


puzzleSize :: Puzzle a > Int


puzzleSize = fst . snd . A.bounds . pzState




 Create a puzzle give the blank, the puzzle size and the puzzle state as a list,


 left to right, top to bottom.


 Return Just puzzle if valid, Nothing otherwise


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


}




 Shows the puzzle state as a string


showPuzzleState :: Show a => Puzzle a > String


showPuzzleState 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), (x1,y), (x,y+1), (x,y1)]




 Get the next legal puzzle states


nextStates :: Ord a => Puzzle a > [Puzzle a]


nextStates pz = map (\p > Puzzle (blank pz) p (swap p blankAt (pzState pz)))


$ neighbourPos (puzzleSize pz) blankAt


where


blankAt = blankPos pz




 Make Puzzle an instance of GameState with unit step cost


instance Ord a => GameState (Puzzle a) where


succs pz = zip (nextStates pz) (repeat 1)




 Make Puzzle an instance of Show for pretty printing


instance Show a => Show (Puzzle a) where


show = showPuzzleState




 Shuffles a puzzle n times randomly to return a new (reachable) puzzle.


shufflePuzzle :: Ord a => Int > Puzzle a > RandomState (Puzzle a)


shufflePuzzle n pz =


if n == 0


then return pz


else do


let s = nextStates pz


i < getRandomR (0, length s  1)


shufflePuzzle (n  1) (s !! i)




 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)


. filter ((> 1). length) . tails


. 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


puzzlePairty pz =


if odd w


then (w + i) `mod` 2


else (w + i + 1  b) `mod` 2


where w = puzzleSize pz


i = inversions pz


b = fst . blankPos $ pz




 Solves a sliding puzzle from initial state to goal state using the given heuristic.


 Return Nothing if the goal state is not reachable from initial state


 else returns Just (cost, path).


solvePuzzle :: Ord a => Puzzle a > Puzzle a


> (Puzzle a > Puzzle a > Cost) > Maybe (Cost, [Puzzle a])


solvePuzzle initState goalState hueristic =


if puzzlePairty initState /= puzzlePairty goalState


then Nothing


else astar 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 (uncurry (/=))


$ zip (A.elems . pzState $ givenState) (A.elems . pzState $ goalState)




 Calculates Manhattan distance between two points


manhattanDistance :: Point > Point > Int


manhattanDistance (x1, y1) (x2, y2) = abs (x1  x2) + abs (y1  y2)




 Calculates the sum of Manhattan distances of tiles between positions in


 given state and goal state


sumManhattanDistance :: Ord a => Puzzle a > Puzzle a > Cost


sumManhattanDistance givenState goalState =


sum . map (\(p, t) > manhattanDistance p (fromJust . M.lookup t $ revM))


. A.assocs . pzState $ givenState


where


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


nPuzzle :: Int > Int > Int > IO ()


nPuzzle n shuffles seed = do


 Random generator


let gen = mkStdGen seed




 The goal


let goalState = fromJust $ fromList 0 n [0 .. (n * n 1)]


 Shuffle the goal to get a random puzzle state


let initState = evalState (shufflePuzzle shuffles goalState) gen


 Solve using sum manhattan distance heuristic


let (cost, solution) = fromJust $ solvePuzzle initState goalState sumManhattanDistance




 Print the solution


forM_ solution $ \s > print s




putStrLn ("Cost: " ++ show cost)




 The main


main :: IO ()


main = do


args < fmap (map read) getArgs


nPuzzle (args !! 0) (args !! 1) (args !! 2)
