作者:杨超
本文地址: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