{-# LANGUAGE OverloadedStrings #-}
import Control.Monad
import Data.Char
import System.IO
main :: IO ()
main = exercise4
-- Lists
data List a = Empty | Entry a (List a) deriving Eq
infixr `Entry`
mapList :: (a -> b) -> List a -> List b
mapList _ Empty = Empty
mapList f (Entry c cs) = Entry (f c) (mapList f cs)
combine :: List Picture -> Picture
combine Empty = blank
combine (Entry p ps) = p & combine ps
allList :: List Bool -> Bool
allList Empty = True
allList (Entry b bs) = b && allList bs
elemList :: Eq a => a -> List a -> Bool
elemList _ Empty = False
elemList x (Entry y ys) | x == y = True
| otherwise = elemList x ys
appendList :: List a -> List a -> List a
appendList Empty ys = ys
appendList (Entry x xs) ys = Entry x (xs `appendList` ys)
listLength :: List a -> Integer
listLength Empty = 0
listLength (Entry _ xs) = 1 + listLength xs
nth :: List a -> Integer -> a
nth Empty _ = error "list too short"
nth (Entry x _) 1 = x
nth (Entry _ xs) n = nth xs (n-1)
filterList :: (a -> Bool) -> List a -> List a
filterList _ Empty = Empty
filterList p (Entry x xs) | p x = Entry x (filterList p xs)
| otherwise = filterList p xs
-- Graph Search
isGraphClosed :: Eq a => a -> (a -> List a) -> (a -> Bool) -> Bool
isGraphClosed initial adjacent isOk = go Empty (Entry initial Empty)
where
go _ Empty = True
go seen (Entry c todo) | c `elemList` seen = go seen todo
go _ (Entry c _) | not (isOk c) = False
go seen (Entry c todo) = go (Entry c seen) (adjacent c `appendList` todo)
-- Coordinates
data Coord = C Integer Integer
data Direction = R | U | L | D deriving Eq
eqCoord :: Coord -> Coord -> Bool
eqCoord (C x1 y1) (C x2 y2) = x1 == x2 && y1 == y2
instance Eq Coord where
C x1 y1 == C x2 y2 = x1 == x2 && y1 == y2
adjacentCoord :: Direction -> Coord -> Coord
adjacentCoord R (C x y) = C (x+1) y
adjacentCoord U (C x y) = C x (y+1)
adjacentCoord L (C x y) = C (x-1) y
adjacentCoord D (C x y) = C x (y-1)
moveFromTo :: Eq a => a -> a -> a -> a
moveFromTo c1 c2 c | c1 == c = c2
| otherwise = c
-- The maze
data Tile = Wall | Ground | Storage | Box | Blank deriving Eq
data Maze = Maze Coord (Coord -> Tile)
isClosed :: Maze -> Bool
isClosed (Maze c0 maze) = isGoodStart && isGraphClosed c0 adjacent isOk
where
isGoodStart = case maze c0 of
Ground -> True
Storage -> True
_ -> False
isOk c = case maze c of
Blank -> False
_ -> True
adjacent c = filterList check (mapList (\d -> adjacentCoord d c) allDirections)
where
check c = case maze c of
Wall -> False
_ -> True
allDirections :: List Direction
allDirections = Entry U (Entry L (Entry D (Entry R Empty)))
noBoxMaze :: (Coord -> Tile) -> Coord -> Tile
noBoxMaze maze c = case maze c of
Box -> Ground
t -> t
mazeWithBoxes :: (Coord -> Tile) -> List Coord -> Coord -> Tile
mazeWithBoxes maze Empty c' = noBoxMaze maze c'
mazeWithBoxes maze (Entry c cs) c'
| eqCoord c c' = Box
| otherwise = mazeWithBoxes maze cs c'
isOnStorage :: (Coord -> Tile) -> Coord -> Bool
isOnStorage maze c = case maze c of Storage -> True
_ -> False
gameWon :: (Coord -> Tile) -> List Coord -> Bool
gameWon maze cs = allList (mapList (isOnStorage maze) cs)
-- The state
data State = State Coord Direction (List Coord) Integer deriving Eq
initialBoxes :: (Coord -> Tile) -> List Coord
initialBoxes maze = go (-10) (-10)
where
go 11 11 = Empty
go x 11 = go (x+1) (-10)
go x y = case maze (C x y) of
Box -> Entry (C x y) (go x (y+1))
_ -> go x (y+1)
loadMaze :: Integer -> State
loadMaze n = State c R (initialBoxes maze) n
where (Maze c maze) = nth mazes n
initialState :: State
initialState = loadMaze 1
nthMaze :: Integer -> (Coord -> Tile)
nthMaze n = case nth mazes n of Maze _ maze -> maze
-- Event handling
tryGoTo :: State -> Direction -> State
tryGoTo (State from _ bx i) d
= case currentMaze to of
Box -> case currentMaze beyond of
Ground -> movedState
Storage -> movedState
_ -> didn'tMove
Ground -> movedState
Storage -> movedState
_ -> didn'tMove
where to = adjacentCoord d from
beyond = adjacentCoord d to
maze = nthMaze i
currentMaze = mazeWithBoxes maze bx
movedState = State to d movedBx i
movedBx = mapList (moveFromTo to beyond) bx
didn'tMove = State from d bx i
handleEvent :: String -> State -> State
handleEvent key (State _ _ bx i)
| gameWon (nthMaze i) bx
, i < listLength mazes
, key == " " = loadMaze (i+1)
handleEvent _ (State c d bx i)
| gameWon (nthMaze i) bx
= State c d bx i
handleEvent key s
| key == "Right" = tryGoTo s R
| key == "Up" = tryGoTo s U
| key == "Left" = tryGoTo s L
| key == "Down" = tryGoTo s D
handleEvent _ s = s
-- Our custom picture type
type DrawFun = Int -> Int -> Char
type Picture = DrawFun -> DrawFun
blank :: Picture
blank = id
(&) :: Picture -> Picture -> Picture
(&) = (.)
char :: Char -> Picture
char c f 0 0 = c
char _ f x y = f x y
translated :: Int -> Int -> Picture -> Picture
translated dx dy p f x y = p (\x y -> f (x + dx) (y + dy)) (x - dx) (y - dy)
text :: String -> Picture
text s f x y | x >= -nh
, x < -nh + n
, y == 0
= s !! (x + nh)
| x >= -nh-1 , x <= -nh + n
, y >= -1, y <= 1
= '+'
| otherwise
= f x y
where n = length s
nh = n `div` 2
renderPicture :: Picture -> String
renderPicture p = unlines [ [f x y | x <- [-10..10] ] | y <- [10,9 .. -10] ]
where f = p (\_ _ -> ' ')
-- Drawing
wall, ground, storage, box :: Picture
wall = char '#'
ground = blank
storage = char '*'
box = char 'H'
drawTile :: Tile -> Picture
drawTile Wall = wall
drawTile Ground = ground
drawTile Storage = storage
drawTile Box = box
drawTile Blank = blank
pictureOfMaze :: (Coord -> Tile) -> Picture
pictureOfMaze maze = draw21times (\r -> draw21times (\c -> drawTileAt maze (C r c)))
draw21times :: (Integer -> Picture) -> Picture
draw21times something = go (-10)
where
go :: Integer -> Picture
go 11 = blank
go n = something n & go (n+1)
drawTileAt :: (Coord -> Tile) -> Coord -> Picture
drawTileAt maze c = atCoord c (drawTile (noBoxMaze maze c))
atCoord :: Coord -> Picture -> Picture
atCoord (C x y) pic = translated (fromIntegral x) (fromIntegral y) pic
player :: Direction -> Picture
player R = char '→'
player L = char '←'
player U = char '↑'
player D = char '↓'
showWin :: State -> Picture
showWin (State _ _ cs i)
| gameWon (nthMaze i) cs
, i == listLength mazes
= text "Game Over!"
| gameWon (nthMaze i) cs
= text "Level done!"
| otherwise = blank
pictureOfBoxes :: List Coord -> Picture
pictureOfBoxes cs = combine (mapList (\c -> atCoord c (drawTile Box)) cs)
drawState :: State -> Picture
drawState (State c d boxes i)
= showWin (State c d boxes i)
& atCoord c (player d)
& pictureOfBoxes boxes
& pictureOfMaze (nthMaze i)
-- The complete interaction
sokoban :: Interaction State
sokoban = Interaction initialState handleEvent drawState
-- The general interaction type
data Interaction world = Interaction
world
(String -> world -> world)
(world -> Picture)
runInteraction :: Interaction s -> IO ()
runInteraction (Interaction state0 handle draw)
= do hSetBuffering stdin NoBuffering
blankScreen
putStr (renderPicture (draw state0))
go "" state0
where
go keys s = do
new_keys <- getAllInput
let (key,rest) = parse (keys ++ new_keys)
unless (key == "Q") $ do
let s' = handle key s
blankScreen
putStr (renderPicture (draw s'))
go rest s'
parse ('\ESC':'[':'C':r) = ("Right", r)
parse ('\ESC':'[':'D':r) = ("Left", r)
parse ('\ESC':'[':'A':r) = ("Up", r)
parse ('\ESC':'[':'B':r) = ("Down", r)
parse ('\ESC':r) = ("Esc", r)
parse (c:r) = ([toUpper c], r)
parse r = ([], r)
getAllInput :: IO String
getAllInput = nextChar
where
nextChar = do
c <- getChar
cs <- more
return (c:cs)
more = do
r <- hReady stdin
if r then nextChar else return []
blankScreen :: IO ()
blankScreen = putStr "\ESCc"
-- Resetable interactions
resetable :: Interaction s -> Interaction s
resetable (Interaction state0 handle draw)
= Interaction state0 handle' draw
where handle' key _ | key == "Esc" = state0
handle' e s = handle e s
-- Start screen
startScreen :: Picture
startScreen = text "Sokoban!"
data SSState world = StartScreen | Running world
instance Eq s => Eq (SSState s) where
StartScreen == StartScreen = True
Running s == Running s' = s == s'
_ == _ = False
withStartScreen :: Interaction s -> Interaction (SSState s)
withStartScreen (Interaction state0 handle draw)
= Interaction state0' handle' draw'
where
state0' = StartScreen
handle' key StartScreen | key == " " = Running state0
handle' _ StartScreen = StartScreen
handle' e (Running s) = Running (handle e s)
draw' StartScreen = startScreen
draw' (Running s) = draw s
-- Undoable interactions
-- We need to remember the current state, and all past states:
data WithUndo a = WithUndo a (List a)
withUndo :: Eq a => Interaction a -> Interaction (WithUndo a)
withUndo (Interaction state0 handle draw)
= Interaction state0' handle' draw'
where
state0' = WithUndo state0 Empty
handle' key (WithUndo s stack) | key == "U"
= case stack of Entry s' stack' -> WithUndo s' stack'
Empty -> WithUndo s Empty
handle' e (WithUndo s stack)
| s' == s = WithUndo s stack
| otherwise = WithUndo s' (Entry s stack)
where s' = handle e s
draw' (WithUndo s _) = draw s
-- The main function
exercise4 :: IO ()
exercise4 = runInteraction (resetable (withUndo (withStartScreen sokoban)))
mazes :: List Maze
mazes =
Entry (Maze (C 1 1) maze9) $
Entry (Maze (C 0 0) maze8) $
Entry (Maze (C (-3) 3) maze7) $
Entry (Maze (C (-2) 4) maze6) $
Entry (Maze (C 0 1) maze5) $
Entry (Maze (C 1 (-3)) maze4) $
Entry (Maze (C (-4) 3) maze3) $
Entry (Maze (C 0 1) maze1) $
Empty
maze1 :: Coord -> Tile
maze1 (C x y)
| abs x > 4 || abs y > 4 = Blank
| abs x == 4 || abs y == 4 = Wall
| x == 2 && y <= 0 = Wall
| x == 3 && y <= 0 = Storage
| x >= -2 && y == 0 = Box
| otherwise = Ground
maze3 :: Coord -> Tile
maze3 (C (-5) (-5)) = Wall
maze3 (C (-5) (-4)) = Wall
maze3 (C (-5) (-3)) = Wall
maze3 (C (-5) (-2)) = Wall
maze3 (C (-5) (-1)) = Wall
maze3 (C (-5) 0 ) = Wall
maze3 (C (-5) 1 ) = Wall
maze3 (C (-5) 2 ) = Wall
maze3 (C (-5) 3 ) = Wall
maze3 (C (-5) 4 ) = Wall
maze3 (C (-4) (-5)) = Wall
maze3 (C (-4) (-4)) = Ground
maze3 (C (-4) (-3)) = Ground
maze3 (C (-4) (-2)) = Ground
maze3 (C (-4) (-1)) = Ground
maze3 (C (-4) 0 ) = Ground
maze3 (C (-4) 1 ) = Ground
maze3 (C (-4) 2 ) = Ground
maze3 (C (-4) 3 ) = Ground
maze3 (C (-4) 4 ) = Wall
maze3 (C (-3) (-5)) = Wall
maze3 (C (-3) (-4)) = Ground
maze3 (C (-3) (-3)) = Wall
maze3 (C (-3) (-2)) = Wall
maze3 (C (-3) (-1)) = Wall
maze3 (C (-3) 0 ) = Wall
maze3 (C (-3) 1 ) = Ground
maze3 (C (-3) 2 ) = Wall
maze3 (C (-3) 3 ) = Ground
maze3 (C (-3) 4 ) = Wall
maze3 (C (-3) 5 ) = Wall
maze3 (C (-2) (-5)) = Wall
maze3 (C (-2) (-4)) = Box
maze3 (C (-2) (-3)) = Ground
maze3 (C (-2) (-2)) = Ground
maze3 (C (-2) (-1)) = Ground
maze3 (C (-2) 0 ) = Wall
maze3 (C (-2) 1 ) = Ground
maze3 (C (-2) 2 ) = Box
maze3 (C (-2) 3 ) = Box
maze3 (C (-2) 4 ) = Ground
maze3 (C (-2) 5 ) = Wall
maze3 (C (-1) (-6)) = Wall
maze3 (C (-1) (-5)) = Wall
maze3 (C (-1) (-4)) = Ground
maze3 (C (-1) (-3)) = Ground
maze3 (C (-1) (-2)) = Ground
maze3 (C (-1) (-1)) = Ground
maze3 (C (-1) 0 ) = Wall
maze3 (C (-1) 1 ) = Ground
maze3 (C (-1) 2 ) = Ground
maze3 (C (-1) 3 ) = Box
maze3 (C (-1) 4 ) = Ground
maze3 (C (-1) 5 ) = Wall
maze3 (C (-1) 6 ) = Wall
maze3 (C 0 (-6)) = Wall
maze3 (C 0 (-5)) = Ground
maze3 (C 0 (-4)) = Ground
maze3 (C 0 (-3)) = Ground
maze3 (C 0 (-2)) = Ground
maze3 (C 0 (-1)) = Ground
maze3 (C 0 0 ) = Wall
maze3 (C 0 1 ) = Wall
maze3 (C 0 2 ) = Wall
maze3 (C 0 3 ) = Wall
maze3 (C 0 4 ) = Ground
maze3 (C 0 5 ) = Ground
maze3 (C 0 6 ) = Wall
maze3 (C 1 (-6)) = Wall
maze3 (C 1 (-5)) = Ground
maze3 (C 1 (-4)) = Ground
maze3 (C 1 (-3)) = Ground
maze3 (C 1 (-2)) = Ground
maze3 (C 1 (-1)) = Ground
maze3 (C 1 0 ) = Wall
maze3 (C 1 1 ) = Storage
maze3 (C 1 2 ) = Storage
maze3 (C 1 3 ) = Storage
maze3 (C 1 4 ) = Ground
maze3 (C 1 5 ) = Ground
maze3 (C 1 6 ) = Wall
maze3 (C 2 (-6)) = Wall
maze3 (C 2 (-5)) = Wall
maze3 (C 2 (-4)) = Ground
maze3 (C 2 (-3)) = Ground
maze3 (C 2 (-2)) = Ground
maze3 (C 2 (-1)) = Ground
maze3 (C 2 0 ) = Wall
maze3 (C 2 1 ) = Wall
maze3 (C 2 2 ) = Wall
maze3 (C 2 3 ) = Wall
maze3 (C 2 4 ) = Wall
maze3 (C 2 5 ) = Wall
maze3 (C 2 6 ) = Wall
maze3 (C 3 (-5)) = Wall
maze3 (C 3 (-4)) = Ground
maze3 (C 3 (-3)) = Ground
maze3 (C 3 (-2)) = Storage
maze3 (C 3 (-1)) = Ground
maze3 (C 3 0 ) = Wall
maze3 (C 4 (-5)) = Wall
maze3 (C 4 (-4)) = Wall
maze3 (C 4 (-3)) = Wall
maze3 (C 4 (-2)) = Wall
maze3 (C 4 (-1)) = Wall
maze3 (C 4 0 ) = Wall
maze3 _ = Blank
maze4 :: Coord -> Tile
maze4 (C x y)
| abs x > 4 || abs y > 4 = Blank
| abs x == 4 || abs y == 4 = Wall
| x == 2 && y < 0 = Wall
| x >= -1 && y == 1 && x <= 2 = Wall
| x == -3 && y == 1 = Wall
| x == 0 && y == 3 = Wall
| x == 0 && y == 0 = Wall
| x == 3 && y == -3 = Storage
| x == 1 && y == 2 = Storage
| x == -3 && y == 2 = Storage
| x == 1 && y == -1 = Storage
| x == -2 && y == 1 = Box
| x == 2 && y == 2 = Box
| x <= 1 && y == -2 && x >= 0 = Box
| otherwise = Ground
maze5 :: Coord -> Tile
maze5 (C x y)
| abs x > 4 || abs y > 4 = Blank
| abs x == 4 || abs y == 4 = Wall
| x == 1 && y < 0 = Wall
| x == -3 && y == -2 = Wall
| x <= 1 && x > -2 && y == 0 = Wall
| x > -3 && x < 3 && y == 2 = Wall
| x == 3 && y > 1 = Storage
| y == -2 && x < 0 = Box
| y == -2 && x == 2 = Box
| y == 0 && x == 3 = Box
| y == -1 && x > 1 && x < 4 = Storage
| otherwise = Ground
maze6 :: Coord -> Tile
maze6 (C x y)
| abs x > 3 || abs y > 5 = Blank
| abs x == 3 || (abs y == 5 && abs x < 4) = Wall
| x == 0 && abs y < 4 = Storage
| x == -1 && (y == 0 || abs y == 2) = Box
| x == 1 && (abs y == 1 || abs y == 3) = Box
| x == (-2) && y == 1 = Wall
| otherwise = Ground
maze7 :: Coord -> Tile
maze7 (C x y)
| abs x > 4 || abs y > 4 = Blank
| abs x == 4 || abs y == 4 = Wall
| not (x == 2) && y == 2 = Wall
| not (x == -2) && y == -1 = Wall
| x == 3 && y == -3 = Storage
| x == 2 && y == 2 = Box
| otherwise = Ground
maze8 :: Coord -> Tile
maze8 (C x y)
| abs x > 10 || abs y > 10 = Blank
| x == 0 && y == 0 = Ground
| abs x == 9 && abs y == 9 = Wall
| abs x == 10 || abs y == 10 = Wall
| x == y = Storage
| abs x == abs y = Box
| x < 0 && x > (-9) && y == 0 = Box
| x > 0 && x < 9 && y == 0 = Storage
| otherwise = Ground
maze9 :: Coord -> Tile
maze9 (C x y)
| abs x > 4 || abs y > 4 = Blank
| abs x == 4 || abs y == 4 || x == -3 = Wall
| x == -2 && (y == 3 || y == 0) = Wall
| x == -1 && y == -1 = Wall
| x == -0 && y == 1 = Wall
| x == 3 && y == 0 = Wall
| x < 0 && (y == 2 || y == -3) = Storage
| x == -1 && y == 1 = Storage
| x == 0 && (y == 2 || y == 0 || y == -1) = Box
| x == 1 && y == -2 = Box
| x == 2 && y == -3 = Box
| otherwise = Ground