Demonstrate how to find a solution to a given Sokoban level. For the purpose of this task (formally, a PSPACE-complete problem) any method may be used. However a move-optimal or push-optimal (or any other -optimal) solutions is preferred.

Sokoban levels are usually stored as a character array where

 space is an empty square
 # is a wall
 @ is the player
 $ is a box
 . is a goal
 + is the player on a goal
 * is a box on a goal
#######
#     #
#     #
#. #  #
#. $$ #
#.$$  #
#.#  @#
#######
Sokoban solutions are usually stored in the LURD format, where lowercase l, u, r and d represent a move in that (left, up, right, down) direction and capital LURD represents a push.

Please state if you use some other format for either the input or output, and why.

For more information, see the Sokoban wiki.



import Control.Monad (liftM)
import Data.Array
import Data.List (transpose)
import Data.Maybe (mapMaybe)
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import Prelude hiding (Left, Right)
 
data Field = Space | Wall | Goal
           deriving (Eq)
 
data Action = Up | Down | Left | Right | PushUp | PushDown | PushLeft | PushRight
 
instance Show Action where
  show Up        = "u"
  show Down      = "d"
  show Left      = "l"
  show Right     = "r"
  show PushUp    = "U"
  show PushDown  = "D"
  show PushLeft  = "L"
  show PushRight = "R"
 
type Index = (Int, Int)
type FieldArray = Array Index Field
type BoxArray = Array Index Bool
type PlayerPos = Index
type GameState = (BoxArray, PlayerPos)
type Game = (FieldArray, GameState)
 
toField :: Char -> Field
toField '#' = Wall
toField ' ' = Space
toField '@' = Space
toField '$' = Space
toField '.' = Goal
toField '+' = Goal
toField '*' = Goal
 
toPush :: Action -> Action
toPush Up    = PushUp
toPush Down  = PushDown
toPush Left  = PushLeft
toPush Right = PushRight
toPush n     = n
 
toMove :: Action -> Index
toMove PushUp    = ( 0, -1)
toMove PushDown  = ( 0,  1)
toMove PushLeft  = (-1,  0)
toMove PushRight = ( 1,  0)
toMove n = toMove $ toPush n
 
-- Parse the string-based game board into an easier-to-use format.
-- Assume that the board is valid (rectangular, one player, etc).
parseGame :: [String] -> Game
parseGame fieldStrs = (field, (boxes, player))
  where
    width     = length $ head fieldStrs
    height    = length fieldStrs
    bound     = ((0, 0), (width - 1, height - 1))
    flatField = concat $ transpose fieldStrs
    charField = listArray bound flatField
    field     = fmap toField charField
    boxes     = fmap (`elem` "$*") charField
    player    = fst $ head $ filter (flip elem "@+" . snd) $ assocs charField
 
add :: (Num a, Num b) => (a, b) -> (a, b) -> (a, b)
add (a, b) (x, y) = (a + x, b + y)
 
-- Attempt to perform an action, returning the updated game and adjusted
-- action if the action was legal.
tryAction :: Game -> Action -> Maybe (Game, Action)
tryAction (field, (boxes, player)) action
  | field ! vec == Wall = Nothing
  | boxes ! vec =
     if boxes ! vecB || field ! vecB == Wall
     then Nothing
     else Just ((field, (boxes // [(vec, False), (vecB, True)], vec)),
               toPush action)
  | otherwise = Just ((field, (boxes, vec)), action)
  where
    actionVec = toMove action
    vec       = player `add` actionVec
    vecB      = vec `add` actionVec
 
-- Search the game for a solution.
solveGame :: Game -> Maybe [Action]
solveGame (field, initState) =
  liftM reverse $ bfs (Seq.singleton (initState, [])) (Set.singleton initState)
  where
    goals           = map fst $ filter ((== Goal) . snd) $ assocs field
    isSolved st     = all (st !) goals
    possibleActions = [Up, Down, Left, Right]
 
    -- Breadth First Search of the game tree.
    bfs :: Seq.Seq (GameState, [Action]) -> Set.Set GameState -> Maybe [Action]
    bfs queue visited =
      case Seq.viewl queue of
        Seq.EmptyL -> Nothing
        (game@(boxes, _), actions) Seq.:< queueB ->
          if isSolved boxes
          then Just actions
          else
            let newMoves = filter (flip Set.notMember visited . fst) $
                           map (\((_, g), a) -> (g, a)) $
                           mapMaybe (tryAction (field, game)) possibleActions
                visitedB = foldl (flip Set.insert) visited $
                           map fst newMoves
                queueC   = foldl (Seq.|>) queueB $
                           map (\(g, a) -> (g, a:actions)) newMoves
            in bfs queueC visitedB
 
exampleA :: [String]
exampleA =
  ["#######"
  ,"#     #"
  ,"#     #"
  ,"#. #  #"
  ,"#. $$ #"
  ,"#.$$  #"
  ,"#.#  @#"
  ,"#######"]
 
main :: IO ()
main =
  case solveGame $ parseGame exampleA of
    Nothing       -> putStrLn "Unsolvable"
    Just solution -> do
      mapM_ putStrLn exampleA
      putStrLn ""
      putStrLn $ concatMap show solution