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 #",
  "#  #.  @#",
  "#    .  #",
  "#########"
  ]