根据计划求解Rush

Rush Hour是一款滑板游戏(这个词并不陌生,常见的滑板游戏还有华容道、八数码等)。规则很简单,看这里的图就明白了。

首先Breadth first search的解法是很容易想到的,但性能不够理想,而启发函数也很难设计。Pearls of Functional Algorithm Design里有一节介绍了一个根据计划求解的方法。

我们人在求解的时候,一般是这样想的:“要把0号车移动到终点,要先移开路上的6、7号车。”“要把6号车移开,可以通过移开5号车来实现,也可以移开8号车。”“要移开5号车,要先移开3、4号车。”等等。

求解这个问题时,我们可以让程序也按照人这样进行思考:要把0号车移动到终点,途中要依次经过19号格和20号格。19号格被6号车占据,可以让6号车依次经过26号格和33号格。26号格被8号车占据,可以把它移动到23号格来腾出位子……

类似于Depth first search使用栈维护候选状态,Breadth first search使用队列维护候选状态,该算法维护双端队列,可能如你所预料的,状态的扩展方式揉和了 DepthBreadth 两种方式。

一个状态不仅要表示棋盘布局,还要表示一个计划,计划中的每个步骤要依次执行。

比如游戏获胜的计划是把0号车移动到19,再把0号车移动到20(注意这两步有顺序),简记为(0,19) (0,20)。其中(0,19)的计划有两个,只要完成其中一个即可:

  • (6,26) (6,33)
  • (5,4) (5,3)

其中 (6,26) 的计划是:

  • (8,23)

其中 (6,33) 的计划是:

  • ……

……

该搜索算法的初始状态就是初始棋盘,计划是 (0,0当前位置右移1格) (0,0当前位置右移2格) (0,0当前位置右移3格)……直到 (0,出口)

每次从队列头部取出一个状态 p 进行扩展。其中一种扩展方式和 Breadth 几乎雷同,把一辆车移动一格,生成的状态 q 放入队列尾部。只是要注意 q 的计划依然是 (0,q中0的位置右移1格) (0,q中0位置右移2格) (0,q中0位置右移3格)……直到 (0,出口)。也就是说,p 的计划被完全忽略了。该过程对应代码中的 bsuccs

另外一种方式比较麻烦,需要考虑 p 的计划。
首先要知道计划是可以 变具体的,也就是说计划的第一步 s 如果没法直接达成(即不能通过把一辆车移动一格达到),
那么这个计划就可以 具体化。方法是看 s 可以由什么计划来达成(比如把另一辆车挪开腾出位子让 s 对应的车占据)。当然,这个 具体化 过程可能一步就能完成(只挪开一辆车),也可能需要很多步(要挪开很多车),相当于递归展开第一步。
我们要做的就是 具体化 s 使得新计划 s0 的第一步能够直接达成,把达成后得到的状态 s0' 放入队列头部。
当然,具体化 的方案可能不止一种,这种情况下我们要考虑所有 具体化 方案 s0 s1 s2……它们对应的转移
s0' s1' s2'……要全部放到队列头部。该过程对应代码中的 asuccs

代码几乎抄自 Pearls of Functional Algorithm Design

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
{-
An implementation of Planning solves the Rush Hour problem from
Pearls of Functional Algorithm Design by Richard Bird
grid
1,2,3,4,5,6
8,9,10,11,12,13
15,16,17,18,19,20
22,23,24,25,26,27
29,30,31,32,33,34
36,37,38,39,40,41
20 is the exit cell
(g1 :: State) represents the initial state
-}
import Control.Monad
import Data.List.Ordered (union, minus)
type Cell = Int
type State = [(Cell, Cell)]
type Vehicle = Int
type Move = (Vehicle, Cell)
type Path = ([Move],State,[Move])
solve :: State -> Maybe [Move]
solve g = psearch [] [] [([],g,goalmoves g)]
psearch :: (MonadPlus m) => [State] -> [Path] -> [Path] -> m [Move]
psearch closed [] [] = mzero
psearch closed rs [] = psearch closed [] rs
psearch closed rs (p@(ms,g,plan):ps)
| solved g = return $ reverse ms
| elem g closed = psearch closed rs ps
| otherwise = psearch (g:closed) (bsuccs p++rs) (asuccs p++ps)
where
asuccs (ms,q,plan) = [(ms++[m], move q m, plan ) | m:plan <- newplans q plan]
bsuccs (ms,q,_) = [(ms++[m], q', goalmoves q') | m <- moves q, let q' = move q m]
newplans :: State -> [Move] -> [[Move]]
newplans g [] = []
newplans g (m:ms) = mkplans (expand m++ms)
where
mkplans ms@(m:_)
| elem m (moves g) = [ms]
| otherwise = concat [ mkplans (pms++ms)
| pms <- premoves m
, all (`notElem` ms) pms
]
expand :: Move -> [Move]
expand (v,c)
| r > f-7 = if c > f then [(v,p) | p <- [f+1..c]]
else [(v,p) | p <- [r-1,r-2..c]]
| otherwise = if c > f then [(v,p) | p <- [f+7,f+14..c]]
else [(v,p) | p <- [r-7,r-14..c]]
where
(r,f) = g!!v
blocker :: Cell -> (Vehicle,(Cell,Cell))
blocker c = go (zip [0..] g)
where
go ((v,i):vis) = if covers i then (v,i) else go vis
covers (r,f) = r <= c && c <= f && (r > f-7 || (c-r)`mod`7 == 0)
premoves :: Move -> [[Move]]
premoves (v,c) = freeingmoves c (blocker c)
moves :: State -> [Move]
moves g = [(v,c) | (v,i) <- zip [0..] g
, c <- adjs i, elem c fs]
where
fs = allcells `minus` foldr (union . fillcells) [] g
adjs (r,f) = if r > f-7 then [f+1,r-1] else [f+7,r-7]
freeingmoves :: Cell -> (Vehicle,(Cell,Cell)) -> [[Move]]
freeingmoves c (v,(r,f))
| r > f-7 = [[(v,j) | j <- [f+1..c+n]] | c+n < k+7] ++ [[(v,j) | j <- [r-1, r-2..c-n]] | c-n > k]
| otherwise = [[(v,j) | j <- [r-7,r-14..c-m]] | c-m > 0] ++ [[(v,j) | j <- [f+7,f+14..c+m]] | c+m < 42]
where
(k,m,n) = (f-f`mod`7, f-r+7, f-r+1)
goalmoves :: State -> [Move]
goalmoves g = [(0,c) | c <- [snd (head g)+1..20]]
move :: State -> Move -> [Move]
move g (v,c) = g1++adjust i c:g2
where
(g1,i:g2) = splitAt v g
adjust (r , f ) c
| r > f-7 = if c > f then (r+1, c) else (c, f-1)
| otherwise = if c < r then (c, f-7) else (r+7, c)
allcells = concat [[i..i+5] | i <- [1,8..36]]
fillcells (r,f) = if r > f-7 then [r..f] else [r,r+7..f]
solved g = snd (head g) == 20
g1 = [(17, 18), (1, 15), (2, 9), (3, 10), (4, 11), (5, 6), (12, 19), (13, 27), (24, 26), (31, 38), (33, 34), (36, 37), (40, 41)] :: State
main = print $ solve g1