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