content: 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
  