Difference between revisions of "Haskell Quiz/Sokoban/Solution Jethr0"
< Haskell Quiz | Sokoban
Jump to navigation
Jump to search
Tomjaguarpaw (talk | contribs) (Deleting page that hasn't been updated for over 10 years) |
m (Reverted edits by Tomjaguarpaw (talk) to last revision by JohannesAhlmann) |
||
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> |
Latest revision as of 15:19, 6 February 2021
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 ;)
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 #",
"# #. @#",
"# . #",
"#########"
]