根据计划求解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使用队列维护候选状态，该算法维护双端队列，可能如你所预料的，状态的扩展方式揉和了 Depth 与 Breadth 两种方式。

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

比如游戏获胜的计划是把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