132 lines
3.9 KiB
Haskell
132 lines
3.9 KiB
Haskell
import Control.Monad (liftM)
|
|
import Data.Array
|
|
import Data.List (transpose)
|
|
import Data.Maybe (mapMaybe)
|
|
import qualified Data.Sequence as Seq
|
|
import qualified Data.Set as Set
|
|
import Prelude hiding (Left, Right)
|
|
|
|
data Field = Space | Wall | Goal
|
|
deriving (Eq)
|
|
|
|
data Action = Up | Down | Left | Right | PushUp | PushDown | PushLeft | PushRight
|
|
|
|
instance Show Action where
|
|
show Up = "u"
|
|
show Down = "d"
|
|
show Left = "l"
|
|
show Right = "r"
|
|
show PushUp = "U"
|
|
show PushDown = "D"
|
|
show PushLeft = "L"
|
|
show PushRight = "R"
|
|
|
|
type Index = (Int, Int)
|
|
type FieldArray = Array Index Field
|
|
type BoxArray = Array Index Bool
|
|
type PlayerPos = Index
|
|
type GameState = (BoxArray, PlayerPos)
|
|
type Game = (FieldArray, GameState)
|
|
|
|
toField :: Char -> Field
|
|
toField '#' = Wall
|
|
toField ' ' = Space
|
|
toField '@' = Space
|
|
toField '$' = Space
|
|
toField '.' = Goal
|
|
toField '+' = Goal
|
|
toField '*' = Goal
|
|
|
|
toPush :: Action -> Action
|
|
toPush Up = PushUp
|
|
toPush Down = PushDown
|
|
toPush Left = PushLeft
|
|
toPush Right = PushRight
|
|
toPush n = n
|
|
|
|
toMove :: Action -> Index
|
|
toMove PushUp = ( 0, -1)
|
|
toMove PushDown = ( 0, 1)
|
|
toMove PushLeft = (-1, 0)
|
|
toMove PushRight = ( 1, 0)
|
|
toMove n = toMove $ toPush n
|
|
|
|
-- Parse the string-based game board into an easier-to-use format.
|
|
-- Assume that the board is valid (rectangular, one player, etc).
|
|
parseGame :: [String] -> Game
|
|
parseGame fieldStrs = (field, (boxes, player))
|
|
where
|
|
width = length $ head fieldStrs
|
|
height = length fieldStrs
|
|
bound = ((0, 0), (width - 1, height - 1))
|
|
flatField = concat $ transpose fieldStrs
|
|
charField = listArray bound flatField
|
|
field = fmap toField charField
|
|
boxes = fmap (`elem` "$*") charField
|
|
player = fst $ head $ filter (flip elem "@+" . snd) $ assocs charField
|
|
|
|
add :: (Num a, Num b) => (a, b) -> (a, b) -> (a, b)
|
|
add (a, b) (x, y) = (a + x, b + y)
|
|
|
|
-- Attempt to perform an action, returning the updated game and adjusted
|
|
-- action if the action was legal.
|
|
tryAction :: Game -> Action -> Maybe (Game, Action)
|
|
tryAction (field, (boxes, player)) action
|
|
| field ! vec == Wall = Nothing
|
|
| boxes ! vec =
|
|
if boxes ! vecB || field ! vecB == Wall
|
|
then Nothing
|
|
else Just ((field, (boxes // [(vec, False), (vecB, True)], vec)),
|
|
toPush action)
|
|
| otherwise = Just ((field, (boxes, vec)), action)
|
|
where
|
|
actionVec = toMove action
|
|
vec = player `add` actionVec
|
|
vecB = vec `add` actionVec
|
|
|
|
-- Search the game for a solution.
|
|
solveGame :: Game -> Maybe [Action]
|
|
solveGame (field, initState) =
|
|
liftM reverse $ bfs (Seq.singleton (initState, [])) (Set.singleton initState)
|
|
where
|
|
goals = map fst $ filter ((== Goal) . snd) $ assocs field
|
|
isSolved st = all (st !) goals
|
|
possibleActions = [Up, Down, Left, Right]
|
|
|
|
-- Breadth First Search of the game tree.
|
|
bfs :: Seq.Seq (GameState, [Action]) -> Set.Set GameState -> Maybe [Action]
|
|
bfs queue visited =
|
|
case Seq.viewl queue of
|
|
Seq.EmptyL -> Nothing
|
|
(game@(boxes, _), actions) Seq.:< queueB ->
|
|
if isSolved boxes
|
|
then Just actions
|
|
else
|
|
let newMoves = filter (flip Set.notMember visited . fst) $
|
|
map (\((_, g), a) -> (g, a)) $
|
|
mapMaybe (tryAction (field, game)) possibleActions
|
|
visitedB = foldl (flip Set.insert) visited $
|
|
map fst newMoves
|
|
queueC = foldl (Seq.|>) queueB $
|
|
map (\(g, a) -> (g, a:actions)) newMoves
|
|
in bfs queueC visitedB
|
|
|
|
exampleA :: [String]
|
|
exampleA =
|
|
["#######"
|
|
,"# #"
|
|
,"# #"
|
|
,"#. # #"
|
|
,"#. $$ #"
|
|
,"#.$$ #"
|
|
,"#.# @#"
|
|
,"#######"]
|
|
|
|
main :: IO ()
|
|
main =
|
|
case solveGame $ parseGame exampleA of
|
|
Nothing -> putStrLn "Unsolvable"
|
|
Just solution -> do
|
|
mapM_ putStrLn exampleA
|
|
putStrLn ""
|
|
putStrLn $ concatMap show solution
|