|
|
| Line 1: |
Line 1: |
| − | [[Category:Haskell Quiz solutions|Countdown]]
| |
| | | | |
| − | Obviously the most uncool kind of interface you could imagine. No readline, no clearscreen, you name it. But I was kinda reminded of the "good ole' days" when writing/playing this ;)
| |
| − |
| |
| − | <haskell>
| |
| − | module Main where
| |
| − |
| |
| − | import Prelude hiding (Either(..))
| |
| − | import qualified Data.List as L
| |
| − | import qualified Data.Char as C
| |
| − | import Control.Monad
| |
| − | import System.IO (getChar, hSetEcho, stdin)
| |
| − |
| |
| − | type Coord = (Int,Int)
| |
| − |
| |
| − | (|+|) :: Coord -> Coord -> Coord
| |
| − | (a,b) |+| (c,d) = (a+c, b+d)
| |
| − |
| |
| − | data Move = Up | Down | Left | Right deriving (Show,Eq)
| |
| − |
| |
| − | data SokoState = SokoState {sWalls, sCrates, sStorages :: [Coord]
| |
| − | ,sWorker :: Coord
| |
| − | ,sSteps :: Int}
| |
| − | deriving (Eq)
| |
| − |
| |
| − | modifyWalls f st = st{sWalls = f . sWalls $ st}
| |
| − | modifyCrates f st = st{sCrates = f . sCrates $ st}
| |
| − | modifyStorages f st = st{sStorages = f . sStorages $ st}
| |
| − | modifyWorker f st = st{sWorker = f . sWorker $ st}
| |
| − | modifySteps f st = st{sSteps = f . sSteps $ st}
| |
| − |
| |
| − | moveToCoord :: Move -> Coord
| |
| − | moveToCoord Up = ( 0,-1)
| |
| − | moveToCoord Down = ( 0, 1)
| |
| − | moveToCoord Left = (-1, 0)
| |
| − | moveToCoord Right = ( 1, 0)
| |
| − |
| |
| − |
| |
| − | -- given a move and a state, compute the next state
| |
| − | step :: Move -> SokoState -> SokoState
| |
| − | step move state
| |
| − | | isWall next1 = state
| |
| − | | isCrate next1 =
| |
| − | if isWall next2 || isCrate next2
| |
| − | then state
| |
| − | else modifyCrates ((next2:) . (filter (next1/=))) moveWorker
| |
| − | | otherwise = moveWorker
| |
| − | where SokoState{sWalls = walls, sCrates = crates, sWorker = worker} = state
| |
| − | moveCoord = moveToCoord move
| |
| − | next1 = worker |+| moveCoord
| |
| − | next2 = next1 |+| moveCoord
| |
| − | isCrate = (`elem` crates)
| |
| − | isWall = (`elem` walls)
| |
| − | moveWorker = modifySteps (+1) state{sWorker = next1}
| |
| − |
| |
| − |
| |
| − | -- check if a level is solved by comparing crate and storage locations
| |
| − | finished :: SokoState -> Bool
| |
| − | finished SokoState{sCrates = cs, sStorages = ss} =
| |
| − | L.sort cs == L.sort ss
| |
| − |
| |
| − |
| |
| − | ---
| |
| − |
| |
| − |
| |
| − | drawState :: SokoState -> [String]
| |
| − | drawState state@SokoState{sWalls = ws, sCrates = cs, sStorages = ss
| |
| − | ,sWorker = wrk, sSteps = steps} =
| |
| − | show steps : [[charRep (x,y) | x <- [0..maxX]] | y <- [0..maxY]]
| |
| − | where
| |
| − | maxX = maximum $ map fst ws
| |
| − | maxY = maximum $ map snd ws
| |
| − |
| |
| − | charRep coord
| |
| − | | isWorker && isStorage = '+'
| |
| − | | isCrate && isStorage = '*'
| |
| − | | isWorker = '@'
| |
| − | | isCrate = 'o'
| |
| − | | isStorage = '.'
| |
| − | | isWall = '#'
| |
| − | | otherwise = ' '
| |
| − | where isWorker = coord == wrk
| |
| − | isCrate = coord `elem` cs
| |
| − | isStorage = coord `elem` ss
| |
| − | isWall = coord `elem` ws
| |
| − |
| |
| − | instance Show SokoState where
| |
| − | show = unlines . drawState
| |
| − |
| |
| − |
| |
| − | -- recreate a level from its ascii representation
| |
| − | fromLevel :: [String] -> SokoState
| |
| − | fromLevel level = foldl newCell emptyState $ (concat cells)
| |
| − | where cells = map (\(y,xs) -> zipWith (\x c -> ((x,y),c)) [0..] xs)
| |
| − | (zip [0..] level)
| |
| − | newCell st (coord,char) =
| |
| − | case char of
| |
| − | '#' -> modifyWalls (coord:) st
| |
| − | 'o' -> modifyCrates (coord:) st
| |
| − | '.' -> modifyStorages (coord:) st
| |
| − | '*' -> modifyStorages (coord:) . modifyCrates (coord:) $ st
| |
| − | '+' -> modifyStorages (coord:) . modifyWorker (const coord) $ st
| |
| − | '@' -> modifyWorker (const coord) st
| |
| − | otherwise -> st
| |
| − |
| |
| − |
| |
| − | emptyState = SokoState {sWalls = []
| |
| − | ,sStorages = []
| |
| − | ,sCrates = []
| |
| − | ,sWorker = (0,0) -- *brr*
| |
| − | ,sSteps = 0
| |
| − | }
| |
| − |
| |
| − |
| |
| − | ---
| |
| − |
| |
| − |
| |
| − | -- ask for input until the level is solved
| |
| − | -- TODO: add key to quit
| |
| − | loop st = do
| |
| − | print st
| |
| − | c <- getChar
| |
| − | let move = case c of
| |
| − | 'j' -> step Left
| |
| − | 'k' -> step Down
| |
| − | 'l' -> step Right
| |
| − | 'i' -> step Up
| |
| − | otherwise -> id
| |
| − | st' = move st
| |
| − | if finished st'
| |
| − | then print st' >> print "you won"
| |
| − | else loop st'
| |
| − |
| |
| − |
| |
| − | main = do
| |
| − | hSetEcho stdin False
| |
| − | loop $ fromLevel level_1
| |
| − | hSetEcho stdin True
| |
| − |
| |
| − |
| |
| − | ---
| |
| − |
| |
| − |
| |
| − | level_1 = [
| |
| − | "#########",
| |
| − | "# #",
| |
| − | "# oo #",
| |
| − | "# #. @#",
| |
| − | "# . #",
| |
| − | "#########"
| |
| − | ]
| |
| − |
| |
| − | </haskell>
| |