用 Haskell 编写 LURD2XSB 程序

作者:杨超

本文地址: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
此条目发表在 推箱子, 编程 分类目录。将固定链接加入收藏夹。