Data commit

Task/Sokoban/Haskell/sokoban.hs

@@ -0,0 +1,132 @@
+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