根據計劃求解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