Difference between revisions of "Haskell Quiz/Sokoban/Solution Jethr0"

From HaskellWiki
Jump to: navigation, search
(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 #",
  "#  #.  @#",
  "#    .  #",
  "#########"
  ]