作者：杨超
本文地址：http://sokoban.ws/blog/?p=263
(4月24日和4月28日分别更新了一次)
推箱子关卡的答案通常用LURD文本格式来保存，而关卡则用XSB格式保存。更详细的介绍可参看XSB格式和LURD格式简介。一个有趣的事情是，仅凭一个有效的LURD答案可以还原关卡的初始状态（当然，有些“多余”的箱子和空位会变成墙体）。很多推箱子爱好者都编写过小工具来做这个从答案到关卡的转换，实现这类功能的程序通常都命名为lurd2xsb。如金优编写过一个具有很友好的图形界面的lurd2xsb。银河(skyivben)也提供了一个在线的lurd2xsb工具，并写了一篇博文介绍算法。
本文的目的是用函数式编程语言(Functional Programming Language) 编写一个命令行的lurd2xsb程序。函数式编程和命令式编程(imperative programming)的主要区别是：前者更接近数学，后者更接近机器语言。因此两者编程的思路差异比较大。Haskell 是比较流行的一种函数式编程语言，最早于1990年发布，从2009年起以下图作为标识(Logo)。Learn You a Haskell for Great Good! 是一个比较好的在线教程。
下面是全部代码。可复制存为一个lurd2xsb.hs文件，然后用ghc –make lurd2xsb.hs命令编译，会生成一个lurd2xsb可执行文件。之后用 ./lurd2xsb 或 cat [lurd file] | ./lurd2xsb 命令来运行。也可以用 runhaskell lurd2xsb.hs 直接即时编译并运行。
module Main where
import Data.List (transpose, intercalate)
import System.IO
type Sokoban = [[Char]]
type Solution = String
main = do
putStrLn "\nHaskell LURD2XSB\n\n\t usage: paste LURD solution in one line and press enter.\n"
lurd <- getLine
putStrLn $ intercalate "\n" $ reconstruct lurd
b = ["###", "#@#", "###"]
isLeftLeak :: Sokoban -> Bool
isLeftLeak = foldl (\acc xs -> if head xs /= '#' then True else acc) False
isRightLeak :: Sokoban -> Bool
isRightLeak = foldl (\acc xs -> if last xs /= '#' then True else acc) False
prePad :: Sokoban -> Sokoban
prePad s = if (isLeftLeak s) then map (\x -> ('#':x) ) s else s
sufPad :: Sokoban -> Sokoban
sufPad s = if (isRightLeak s) then map (\x -> x ++ "#") s else s
lastIsBox :: String -> Bool
lastIsBox xs = elem (last xs) "$*"
lastToMan :: String -> String
lastToMan xs = init xs ++ m
where m = (if last xs == '.' then "+" else "@")
headToFloor :: String -> String
headToFloor [] = []
headToFloor (x:xs) = (f:xs)
where f = (if x == '+' || x == '*' || x== '#' then '.' else ' ')
isMan :: Char -> Bool
isMan '@' = True
isMan '+' = True
isMan _ = False
undoRowL :: String -> String
undoRowL xs = if (elem '@' xs || elem '+' xs)
then lastToMan xs1 ++ headToFloor xs2
else xs
where (xs1,xs2) = span (not . isMan ) xs
undoRowPushL :: String -> String
undoRowPushL xs = if (elem '@' xs || elem '+' xs)
then lastToMan xs1 ++ b ++ headToFloor xs3
else xs
where (xs1,xs2@(h:xs3)) = span (not . isMan ) xs
b = (if h == '@' then "$" else "*" )
undoL :: Sokoban -> Sokoban
undoL s = prePad $ map undoRowL s
undoPushL :: Sokoban -> Sokoban
undoPushL s = prePad $ sufPad $ map undoRowPushL s
undo :: Sokoban -> Char -> Sokoban
undo s 'r' = undoL s
undo s 'R' = undoPushL s
undo s 'l' = map reverse $ undoL $ map reverse s
undo s 'L' = map reverse $ undoPushL $ map reverse s
undo s 'd' = transpose . undoL .transpose $ s
undo s 'D' = transpose . undoPushL . transpose $ s
undo s 'u' = transpose . (map reverse) . undoL . (map reverse) . transpose $ s
undo s 'U' = transpose . (map reverse) . undoPushL . (map reverse) . transpose $ s
reconstruct :: Solution -> Sokoban
reconstruct s = foldl (\acc x -> undo acc x) b $ reverse s
2012年4月24日更新：
今天换了一种实现方法，使得看上去更“数学”一些。主要是用 foldl 方法重新实现了 undoRowL 和 undoRowPushL 函数。另外输入输出改用 interact 函数，输入lurd串之后需要用 ctrl – D 执行。
module Main where
import Data.List (transpose, intercalate)
import System.IO (interact)
type Sokoban = [[Char]]
type Solution = String
main = interact $ (++"\n") . (intercalate "\n") . reconstruct
b = ["###", "#@#", "###"]
isLeftLeak :: Sokoban -> Bool
isLeftLeak = foldl (\acc xs -> if head xs /= '#' then True else acc) False
isRightLeak :: Sokoban -> Bool
isRightLeak = foldl (\acc xs -> if last xs /= '#' then True else acc) False
prePad :: Sokoban -> Sokoban
prePad s = if (isLeftLeak s) then map (\x -> ('#':x) ) s else s
sufPad :: Sokoban -> Sokoban
sufPad s = if (isRightLeak s) then map (\x -> x ++ "#") s else s
undoRowLStep :: String -> Char -> String
undoRowLStep (' ':xs) '@' = ' ':'@':xs
undoRowLStep ('.':xs) '@' = ' ':'+':xs
undoRowLStep ('#':xs) '@' = ' ':'@':xs
undoRowLStep (' ':xs) '+' = '.':'@':xs
undoRowLStep ('.':xs) '+' = '.':'+':xs
undoRowLStep ('#':xs) '+' = '.':'@':xs
undoRowLStep xs c = c:xs
undoRowPushLStep :: String -> Char -> String
undoRowPushLStep (' ':xs) '@' = '$':'@':xs
undoRowPushLStep ('.':xs) '@' = '$':'+':xs
undoRowPushLStep ('#':xs) '@' = '$':'@':xs
undoRowPushLStep (' ':xs) '+' = '*':'@':xs
undoRowPushLStep ('.':xs) '+' = '*':'+':xs
undoRowPushLStep ('#':xs) '+' = '*':'@':xs
undoRowPushLStep xs@('$':'@':ys) '$' = ' ':xs
undoRowPushLStep xs@('*':'@':ys) '$' = ' ':xs
undoRowPushLStep xs@('$':'+':ys) '$' = ' ':xs
undoRowPushLStep xs@('*':'+':ys) '$' = ' ':xs
undoRowPushLStep xs@('$':'@':ys) '*' = '.':xs
undoRowPushLStep xs@('*':'@':ys) '*' = '.':xs
undoRowPushLStep xs@('$':'+':ys) '*' = '.':xs
undoRowPushLStep xs@('*':'+':ys) '*' = '.':xs
undoRowPushLStep xs@('$':'@':ys) '#' = '.':xs
undoRowPushLStep xs@('*':'@':ys) '#' = '.':xs
undoRowPushLStep xs@('$':'+':ys) '#' = '.':xs
undoRowPushLStep xs@('*':'+':ys) '#' = '.':xs
undoRowPushLStep xs c = c:xs
undoRowL :: String -> String
undoRowL xs = reverse $ foldl undoRowLStep [] xs
undoRowPushL :: String -> String
undoRowPushL xs = reverse $ foldl undoRowPushLStep [] xs
undoL :: Sokoban -> Sokoban
undoL s = prePad $ map undoRowL s
undoPushL :: Sokoban -> Sokoban
undoPushL s = prePad $ sufPad $ map undoRowPushL s
undo :: Sokoban -> Char -> Sokoban
undo s 'r' = undoL s
undo s 'R' = undoPushL s
undo s 'l' = map reverse $ undoL $ map reverse s
undo s 'L' = map reverse $ undoPushL $ map reverse s
undo s 'd' = transpose . undoL .transpose $ s
undo s 'D' = transpose . undoPushL . transpose $ s
undo s 'u' = transpose . (map reverse) . undoL . (map reverse) . transpose $ s
undo s 'U' = transpose . (map reverse) . undoPushL . (map reverse) . transpose $ s
undo s _ = s
reconstruct :: Solution -> Sokoban
reconstruct s = foldl (\acc x -> undo acc x) b $ reverse s
2012年4月28日更新：
前面的实现都不考虑异常情况。事实上，并不是每一个lurd答案都能合法地还原成一个关卡。在利用答案逆推关卡过程中，有三种异常：一是撤销移动时，退回来的位置被箱子占领(如drrulL)；二是撤销推动时，退回来的位置被箱子占领(如LURD，这和第一种本质一样)；三是撤销推动时，要回退的箱子并不存在(如Rrr)。于是，重新修改了一下程序，使用了 Haskell 的 Maybe Monad 这一特性和 Monad 的 >>= 运算。当lurd答案合法有效时，返回 Just Sokoban，否则返回 Nothing 。
module Main where
import Data.List (transpose)
type Sokoban = [[Char]]
type Solution = String
main = do
putStrLn "\nHaskell LURD2XSB\n\n\t usage: paste LURD solution in one line and press enter.\n"
lurd <- getLine
putStrLn $ map reformat $ show $ reconstruct lurd
reformat :: Char -> Char
reformat '[' = '\n'
reformat ']' = '\n'
reformat ',' = '\n'
reformat '"' = ' '
reformat x = x
b = ["###", "#@#", "###"]
isLeftLeak :: Sokoban -> Bool
isLeftLeak = foldl (\acc xs -> if head xs /= '#' then True else acc) False
isRightLeak :: Sokoban -> Bool
isRightLeak = foldl (\acc xs -> if last xs /= '#' then True else acc) False
prePad :: Sokoban -> Sokoban
prePad s = if (isLeftLeak s) then map (\x -> ('#':x) ) s else s
sufPad :: Sokoban -> Sokoban
sufPad s = if (isRightLeak s) then map (\x -> x ++ "#") s else s
undoRowLStep :: String -> Char -> String
undoRowLStep (' ':xs) '@' = ' ':'@':xs
undoRowLStep ('.':xs) '@' = ' ':'+':xs
undoRowLStep ('#':xs) '@' = ' ':'@':xs
undoRowLStep ('$':xs) '@' = ' ':'e':xs
undoRowLStep ('*':xs) '@' = ' ':'e':xs
undoRowLStep (' ':xs) '+' = '.':'@':xs
undoRowLStep ('.':xs) '+' = '.':'+':xs
undoRowLStep ('#':xs) '+' = '.':'@':xs
undoRowLStep ('$':xs) '+' = ' ':'e':xs
undoRowLStep ('*':xs) '+' = ' ':'e':xs
undoRowLStep xs c = c:xs
undoRowPushLStep :: String -> Char -> String
undoRowPushLStep (' ':xs) '@' = '$':'@':xs
undoRowPushLStep ('.':xs) '@' = '$':'+':xs
undoRowPushLStep ('#':xs) '@' = '$':'@':xs
undoRowPushLStep ('$':xs) '@' = '$':'e':xs
undoRowPushLStep ('*':xs) '@' = '$':'e':xs
undoRowPushLStep (' ':xs) '+' = '*':'@':xs
undoRowPushLStep ('.':xs) '+' = '*':'+':xs
undoRowPushLStep ('#':xs) '+' = '*':'@':xs
undoRowPushLStep ('$':xs) '+' = '*':'e':xs
undoRowPushLStep ('*':xs) '+' = '*':'e':xs
undoRowPushLStep xs@('$':'@':ys) '$' = ' ':xs
undoRowPushLStep xs@('*':'@':ys) '$' = ' ':xs
undoRowPushLStep xs@('$':'+':ys) '$' = ' ':xs
undoRowPushLStep xs@('*':'+':ys) '$' = ' ':xs
undoRowPushLStep xs@('$':'@':ys) '*' = '.':xs
undoRowPushLStep xs@('*':'@':ys) '*' = '.':xs
undoRowPushLStep xs@('$':'+':ys) '*' = '.':xs
undoRowPushLStep xs@('*':'+':ys) '*' = '.':xs
undoRowPushLStep xs@('$':'@':ys) '#' = '.':xs
undoRowPushLStep xs@('*':'@':ys) '#' = '.':xs
undoRowPushLStep xs@('$':'+':ys) '#' = '.':xs
undoRowPushLStep xs@('*':'+':ys) '#' = '.':xs
undoRowPushLStep xs@('$':'@':ys) ' ' = 'e':xs
undoRowPushLStep xs@('*':'@':ys) ' ' = 'e':xs
undoRowPushLStep xs@('$':'+':ys) ' ' = 'e':xs
undoRowPushLStep xs@('*':'+':ys) ' ' = 'e':xs
undoRowPushLStep xs@('$':'@':ys) '.' = 'e':xs
undoRowPushLStep xs@('*':'@':ys) '.' = 'e':xs
undoRowPushLStep xs@('$':'+':ys) '.' = 'e':xs
undoRowPushLStep xs@('*':'+':ys) '.' = 'e':xs
undoRowPushLStep xs c = c:xs
undoRowL :: String -> String
undoRowL xs = reverse $ foldl undoRowLStep [] xs
undoRowPushL :: String -> String
undoRowPushL xs = reverse $ foldl undoRowPushLStep [] xs
undoL :: Sokoban -> Sokoban
undoL s = prePad $ map undoRowL s
undoPushL :: Sokoban -> Sokoban
undoPushL s = prePad $ sufPad $ map undoRowPushL s
undo :: Char -> Sokoban -> Sokoban
undo 'r' s = undoL s
undo 'R' s = undoPushL s
undo 'l' s = map reverse $ undoL $ map reverse s
undo 'L' s = map reverse $ undoPushL $ map reverse s
undo 'd' s = transpose . undoL .transpose $ s
undo 'D' s = transpose . undoPushL . transpose $ s
undo 'u' s = transpose . (map reverse) . undoL . (map reverse) . transpose $ s
undo 'U' s = transpose . (map reverse) . undoPushL . (map reverse) . transpose $ s
undo _ s = s
undo2 :: Char -> Sokoban -> Maybe Sokoban
undo2 x s =
let s' = undo x s
in if elem 'e' (concat s') then Nothing else Just s'
reconstruct :: Solution -> Maybe Sokoban
reconstruct [] = Just b
reconstruct (x:xs) = reconstruct xs >>= undo2 x