sokoban game. The maps can be downloaded from http://www.ne.jp/asahi/ai/yoshio/sokoban/auto52/index.html

sokoban.hs

import Data.Array (Array, array, bounds, elems, (!), (//))
import Utils (makeRows, arrayFindOnValBy)
import Control.Monad (unless)
import System.IO (stdin, hSetBuffering, BufferMode(NoBuffering))
import Data.IORef (IORef, newIORef, readIORef, writeIORef)

data Cell = Wall 
            | Box Bool
            | Player Bool
            | Empty Bool
              
type Board = Array Position Cell

data Game = Game Board

type Position = (Int, Int)

data Direction = UpDir | DownDir | LeftDir | RightDir 

data Action = Stay 
            | Push Position Position
            | Move Position Position

instance Show Cell where
    show Wall = "#"
    show (Box True) = "*"
    show (Box False) = "$"
    show (Player True) = "+"
    show (Player False) = "@"
    show (Empty True) = "."
    show (Empty  False) = " " 

instance Show Game  where
    show (Game board) = unlines . (map showRow) . makeRows rowLength $ elems board
         where
           rowLength =  (snd . snd $ bounds board) + 1
           showRow = concatMap show

cellOfChar :: Char -> Cell
cellOfChar '#' = Wall
cellOfChar '*' = Box True
cellOfChar '$' = Box False
cellOfChar '+' = Player True
cellOfChar '@' = Player False
cellOfChar '.' = Empty True
cellOfChar ' ' = Empty False
cellOfChar c = error $ "Unknnown input: " ++ [c]

moveDir :: Position -> Direction -> Position
moveDir (a, b) UpDir = (a - 1, b)
moveDir (a, b) DownDir = (a + 1, b)
moveDir (a, b) LeftDir = (a, b - 1)
moveDir (a, b) RightDir = (a, b + 1)

findTargets :: Game -> [Position]
findTargets (Game b) = arrayFindOnValBy isTarget b 
    where
      isTarget :: Cell -> Bool
      isTarget (Empty True) = True
      isTarget (Box True) = True
      isTarget (Player True) = True
      isTarget _ = False

findBoxes :: Game -> [Position]
findBoxes (Game b) = arrayFindOnValBy isBox b
    where
      isBox (Box _) = True
      isBox _ = False
    
findPlayer :: Game -> Position
findPlayer (Game b) = head $ arrayFindOnValBy isPlayer b
    where 
      isPlayer (Player _ ) = True
      isPlayer _ = False

win :: Game -> Bool
win g = findBoxes g == findTargets g

nextAction :: Game -> Direction -> Action
nextAction g@(Game b) dir = 
    case  b ! newPos of
      Empty _ -> Move oldPos newPos
      Box _ -> if isEmpty $ b ! moveDir newPos dir 
               then Push oldPos newPos
               else Stay
      _ -> Stay
    where 
      oldPos = findPlayer g 
      newPos = moveDir oldPos dir
      isEmpty (Empty _) = True
      isEmpty _ = False 

play :: Game -> Direction -> Game
play g@(Game b) dir = 
    case nextAction g dir of
      Stay -> g
      Move oldPos newPos -> Game $ b // [ (oldPos, playerLeave (b ! oldPos)),
                                          (newPos, playerEnter (b ! newPos))]
      Push oldPos newPos -> 
          let newBoxPos = moveDir newPos dir in
          Game $ b // [ (newPos, boxLeave (b ! newPos)),
                        (newBoxPos, boxEnter (b ! newBoxPos))]
                   // [ (oldPos, playerLeave (b ! oldPos)),
                        (newPos, playerEnter (b ! newPos))]
      where 
        playerEnter (Empty target) = Player target
        playerEnter (Box target)  = Player target
        playerEnter c = error $ "Player cannot enter cell" ++ show c
        boxEnter (Empty target) = Box target
        boxEnter c = error $ "Box cannot enter cell" ++ show c
        playerLeave (Player target) = Empty target
        playerLeave c  = error $ "Player cannot leave cell" ++ show c
        boxLeave (Box target) = Player target
        boxLeave c  = error $ "Box cannot leave cell" ++ show c

readGame :: String -> Game
readGame str = Game $ array arrayBounds indexedCells
    where
      boardAsList = map (map cellOfChar) . lines . filter (/= '\r') $ str
      arrayBounds = ((0, 0), (length boardAsList - 1,  
                              maximum [length r | r <- boardAsList] - 1))
      enumerateLine (n, row) = [((n, i), c) | (i, c) <- zip [0..] row]
      indexedCells = concatMap enumerateLine $ zip [0..] boardAsList

readDirection :: Char -> Maybe Direction
readDirection '4' = Just LeftDir
readDirection '6' = Just RightDir
readDirection '2' = Just DownDir
readDirection '8' = Just UpDir
readDirection _ = Nothing

repl :: IORef Game -> IO ()
repl refGame = do
  game <- readIORef refGame
  print game
  c <- getChar
  putStrLn ""
  case readDirection c of 
    Nothing -> repl refGame
    Just dir -> do
                 let newGame = play game dir
                 unless (win newGame) $ do
                         writeIORef refGame newGame
                         repl refGame
  

main :: IO ()
main = do
  hSetBuffering stdin NoBuffering
  content <- readFile "auto52/soko001.txt"
  let game = readGame content
  refGame <- newIORef game
  repl refGame
  putStrLn "You win!!"

Utils.hs

module Utils where

import Data.Array (Ix, Array, assocs)

makeRows :: Int -> [a] -> [[a]]
makeRows _ [] = []
makeRows len elts = 
    (take len elts) : makeRows len (drop len elts)


arrayFindOnValBy :: (Ix a) => (b-> Bool) -> Array a b -> [a]
arrayFindOnValBy p a = [k | (k,v) <- assocs a, p v]