Haskell Quiz/Sokoban/Solution Jethr0

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