Difference between revisions of "Haskell Quiz/Sokoban/Solution Jethr0"
< Haskell Quiz | Sokoban
Jump to navigation
Jump to search
m |
Tomjaguarpaw (talk | contribs) (Deleting page that hasn't been updated for over 10 years) |
||
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> |