Sokoban.hs

{-
  Terminal-based Sokoban in Haskell
  Author: Franklin P. Dyer
  Run in the same directory as a text file of Sokoban levels
    entitled "levels.txt". These should be encoded in the usual way:
    # - wall
      - empty (whitespace)
    $ - crate
    . - goal
    * - crate on goal
    @ - player
    + - player on goal
-}

import System.IO

data TileDict = TileDict {
  tilechars :: [(String, Char)],
  tile0 :: String,
  char0 :: Char
} deriving (Eq, Show)

tileToChar :: TileDict -> String -> Char
tileToChar td tile = maybe (char0 td) id (lookup tile $ tilechars td)

charToTile :: TileDict -> Char -> String
charToTile td c = maybe (tile0 td) id (lookup c $ map (\(x,y) -> (y,x)) $ tilechars td)

emptyTileDict :: TileDict
emptyTileDict = TileDict {
  tilechars = [],
  tile0 = "empty",
  char0 = ' '
}

defaultTileReader :: TileDict
defaultTileReader = TileDict {
  tilechars = [
    ("wall", '#'),
    ("player", '@'),
    ("empty", ' '),
    ("box", '$'),
    ("goal", '.'),
    ("boxgoal", '*'),
    ("playergoal", '+')
  ],
  tile0 = "empty",
  char0 = ' '
}

defaultTileDisplay :: TileDict
defaultTileDisplay = TileDict {
  tilechars = [
    ("wall", '#'),
    ("player", 'þ'),
    ("empty", ' '),
    ("box", '©'),
    ("goal", '•'),
    ("boxgoal", 'ø'),
    ("playergoal", 'þ')
  ],
  tile0 = "empty",
  char0 = ' '
}

buildTileReader :: TileDict -> Handle -> IO TileDict
buildTileReader td fh 
  = do
      line <- hGetLine fh
      let parts = span (/= ' ') line
      if (length (fst parts) > 1 && length (snd parts) > 1) 
        then (buildTileReader (addToDict td (fst parts) ((snd parts) !! 1)) fh) 
        else return td
  where addToDict :: TileDict -> String -> Char -> TileDict
        addToDict td tile c = td {tilechars = (tile, c):(tilechars td)}

data Level = Level {
  len :: Int,
  wid :: Int,
  iniPos :: (Int, Int),
  iniBox :: [(Int, Int)],
  readDict :: TileDict,
  layout :: [[Char]]
}

-- Hard coded level, for testing only
defaultLevel :: Level
defaultLevel = Level {
  len = 9,
  wid = 6,
  iniPos = (6, 4),
  iniBox = [(6, 2), (6, 3)],
  readDict = defaultTileReader,
  layout = [
    "#########",
    "###  ####",
    "#       #",
    "# #  #  #",
    "# g g#  #",
    "#########"
  ]
}

readNextLevel :: Handle -> IO [String]
readNextLevel fh
  = do
      firstLine <- nextValidLine
      restLines <- consecValidLines
      return (firstLine : restLines)
  where validLine :: String -> Bool
        validLine str = (length str >= 2) && (str !! 0 /= ';') 
        nextValidLine :: IO String
        nextValidLine = do
          line <- hGetLine fh
          (if validLine line
             then return (line ++ "\n")
             else nextValidLine)
        consecValidLines :: IO [String]
        consecValidLines = do
          line <- hGetLine fh
          (if validLine line
            then consecValidLines >>= (return . (:) line)
            else return [])

getPositions :: (Char -> Bool) -> [String] -> [(Int, Int)]
getPositions p rows
  = (map fst)
    $ (filter (p . snd))
    $ (foldr (++) [])
    $ (map (\(i, ls) -> map (\(j, c) -> ((j, i), c)) (zip [0..] ls)))
    $ (zip [0..] rows)

processLevel :: TileDict -> [String] -> Level
processLevel td rows
  = Level {
      len = l,
      wid = w,
      iniPos = playerPos !! 0,
      iniBox = boxes,
      readDict = td,
      layout = rows''
    }
  where l = foldr max 0 (map length rows)
        w = length rows
        pad :: String -> String
        pad str = str ++ (replicate (l - length str) (char0 td))
        rows' = map pad rows
        tr = tileToChar td
        playerPos 
          = getPositions
              (\c -> c == tr "player" || c == tr "playergoal")
              rows'
        boxes 
          = getPositions
              (\c -> c == tr "box" || c == tr "boxgoal")
              rows'
        rows''
          = map
              (map (\c -> if c == tr "boxgoal" || c == tr "playergoal" 
                          then tr "goal"
                          else if c == tr "player" || c == tr "box"
                          then tr "empty"
                          else c))
              rows'

data GameMetadata = GameMetadata {
  header :: String,
  numMoves :: Int,
  numRestarts :: Int
}

data GameState = GameState {
  mdata :: GameMetadata,
  pX :: Int,
  pY :: Int,
  levelMap :: Level,
  boxList :: [(Int, Int)]
}

initLevel :: Level -> GameState
initLevel level = GameState {
  mdata = GameMetadata {
    header = "SOKOBAN",
    numMoves = 0,
    numRestarts = 0
  },
  pX = fst $ iniPos level,
  pY = snd $ iniPos level,
  levelMap = level,
  boxList = iniBox level
}

getMapPos :: Level -> Int -> Int -> Char
getMapPos level m n = ((layout level) !! n) !! m

layeredMap :: GameState -> String
layeredMap state 
  = [
    if (x, y) == (pX state, pY state) then tileToChar td "player"
    else if elem (x, y) (boxList state) then 
      (if (getMapPos level x y) == tileToChar td "goal" 
          then tileToChar td "boxgoal" 
          else tileToChar td "box")
    else getMapPos level x y  
      | y <- [0..(wid level - 1)], x <- [0..(len level - 1)]
    ] where level = levelMap state
            td = readDict level

showState :: TileDict -> GameState -> String
showState dispd state
  = (header metadat) ++ "\ESC[0K" ++ "\n" ++
    ("Moves: " ++ (show $ numMoves metadat)) ++ "\ESC[0K" ++ "\n" ++
    ("Restarts: " ++ (show $ numRestarts metadat)) ++ "\ESC[0K" ++ "\n" ++
    (addNewlines (len $ levelMap state) (translator $ layeredMap state)) ++
    "\ESC[0J"
  where addNewlines :: Int -> String -> String
        addNewlines n "" = ""
        addNewlines n str 
          = (take n str) ++ "\ESC[0K\n" ++ addNewlines n (drop n str)
        translator :: String -> String
        translator 
          = map ((tileToChar dispd) . (charToTile $ readDict $ levelMap state))
        metadat = mdata state

inBounds :: Level -> Int -> Int -> Bool
inBounds level x y
 = (x < l) && (x >= 0) && (y < w) && (y >= 0) 
   && (grid !! y) !! x /= tileToChar td "wall"
 where l = len level
       w = wid level
       grid = layout level
       td = readDict level

moveBox :: (Int, Int) -> (Int, Int) -> GameState -> GameState
moveBox (x0, y0) (x1, y1) state = state {
  boxList = map (\pt -> if pt == (x0, y0) then (x1, y1) else pt) $ boxList state
}

tryMoveBox :: GameState 
              -> (Int, Int) -> (Int, Int) 
              -> Maybe GameState
tryMoveBox state (x0, y0) (dx, dy)
  = if inBounds level x1 y1
    then
      if elem (x1, y1) $ boxList state
      then Nothing
           -- NOTE: uncomment the following to enable multiple-box pushing
           -- maybe Nothing
           --      (Just . moveBox (x0, y0) (x1, y1))
           --      (tryMoveBox ckey state (x1, y1) (dx, dy))
      else Just (state {
        boxList = (x1, y1) : (filter (/= (x0, y0)) $ boxList state)
      })
    else Nothing
    where level = levelMap state
          grid = layout level
          l = len level
          w = wid level
          x1 = x0 + dx
          y1 = y0 + dy

movePlayer :: (Int, Int) -> GameState -> GameState
movePlayer pos state = state {pX = fst pos, pY = snd pos}

tryMovePlayer :: GameState
                 -> (Int, Int)
                 -> Maybe GameState
tryMovePlayer state (dx, dy)
  = if inBounds level x1 y1
    then
      if elem (x1, y1) $ boxList state
      then maybe Nothing 
                 (Just . movePlayer (x1, y1))
                 (tryMoveBox state (x1, y1) (dx, dy))
      else Just (movePlayer (x1, y1) state)
    else Nothing
  where level = levelMap state
        x0 = pX state
        y0 = pY state
        x1 = x0 + dx
        y1 = y0 + dy

restartLevel :: GameState -> GameState
restartLevel state = state {
  pX = fst $ iniPos $ levelMap state,
  pY = snd $ iniPos $ levelMap state,
  boxList = iniBox $ levelMap state,
  mdata = (mdata state) {
    numMoves = 0,
    numRestarts = 1 + (numRestarts $ mdata state)
  }
}

incrementMoves :: GameState -> GameState
incrementMoves state
  = state {
      mdata = (mdata state) {
        numMoves = numMoves (mdata state) + 1
      }
    }

processMove :: GameState -> Char -> GameState
processMove state c
  = if c == 'r' then restartLevel state
    else maybe 
      state
      id
      ((
        if c == 'w' then Just (0, -1)
        else if c == 's' then Just (0, 1)
        else if c == 'a' then Just (-1, 0)
        else if c == 'd' then Just (1, 0)
        else Nothing
      ) >>= tryMovePlayer state')
  where x = pX state
        y = pY state
        state' = incrementMoves state

levelFinished :: GameState -> Bool
levelFinished state
  = and $ map (`elem` boxes) goals
  where td = readDict $ levelMap state
        boxes = boxList state
        goals = getPositions (== tileToChar td "goal") (layout $ levelMap state)

resetCursor :: GameState -> IO ()
resetCursor state = putStr "\ESC[0;0H"

evtLoop :: TileDict -> Handle -> GameState -> IO ()
evtLoop td fh state = do
  putStr "\ESC[?25l" -- Hide cursor to avoid flickering
  resetCursor state
  putStr (showState defaultTileDisplay state)
  putStr "\ESC[?25h" -- Show cursor again
  if (levelFinished state) 
  then do 
    putStr "Level complete! Press any key to continue."
    getChar
    newGrid <- readNextLevel fh
    let newLevel = processLevel td newGrid
        newState = initLevel newLevel
    evtLoop td fh newState
  else return ()
  getChar >>= (\c -> evtLoop td fh (processMove state c))

main :: IO ()
main = do
  fhLevels <- openFile "levels.txt" ReadMode
  td <- buildTileReader emptyTileDict fhLevels
  let td' = if (length $ tilechars td) == 0 then defaultTileReader else td
  levelstr <- readNextLevel fhLevels
  let level = processLevel td' levelstr
      state = initLevel level

  hSetEcho stdin False             -- Don't echo user inputs
  hSetBuffering stdin NoBuffering  -- Don't require newlines to flush
  putStr "\ESC[2J"                 -- Clear the console
 
  putStr "\ESC[0;0H" 
  putStr "--- SOKOBAN ---\n Press any key to continue"
  getChar

  evtLoop td' fhLevels state