第18章

プランニングでラッシュアワー問題を解く

（やさしい版） Pearls of Functional Algorithm Design（関数プログラミングによるアルゴリズム設計の真珠）

どんな話？

この章は、有名なパズル ラッシュアワー（Rush Hour）を、関数型プログラミングで賢く解く、という話です。

ラッシュアワーとは？ 6 × 6 の駐車場に何台もの車がぎゅうぎゅうに詰まっていて、他の車を上下左右にずらしながら、自分の車（特別な車）を出口から脱出させるスライドブロック・パズル。Nob Yoshigahara（吉川乃ぶ）氏が考案し、Think Fun 社から発売されています。1
この章のねらい

パズルを抽象化する

状態と手の3つ組

まずはラッシュアワーに限らない、抽象的なパズルを考えます。状態の有限集合と手の有限集合を用意し、次の3つの関数を与えます。

moves :: State → [Move] move :: State → Move → State solved :: State → Bool
Dart // パズルの抽象インターフェース：状態 State と手 Move はジェネリック型 typedef Moves<S, M> = List<M> Function(S q); typedef MoveFn<S, M> = S Function(S q, M m); typedef Solved<S> = bool Function(S q);

この形で書けば、パズルは決定性有限オートマトンそのものです。「解く」とは、初期状態から solved になる状態まで手をつなぐ列を見つけることで、できれば最短のものが望ましい。

solve :: State → Maybe [Move]
Dart // solve は解が無ければ null、あれば手順のリストを返す typedef Solve<S, M> = List<M>? Function(S q);

solve q の値は、解が無ければ Nothing、あれば手順のリストを Just ms で返す。ここで ms は solved (foldl move q ms) を満たします。

方法1：幅優先探索（BFS）

基本の実装

まず、パス（今までの手の列と現在の状態のペア）と、それを待ち行列として並べたフロンティアを定義します。

type Path = ([Move], State) type Frontier = [Path]
Dart // Path は「これまでの手」と「現在の状態」の組 typedef Path<S, M> = (List<M> ms, S q); typedef Frontier<S, M> = List<Path<S, M>>;

幅優先探索は、フロンティアをキューとして使って、初期状態からの距離が短いパスから順に調べます。

bfsearch :: [State] → Frontier → Maybe [Move] bfsearch qs [ ] = Nothing bfsearch qs (p@(ms, q) : ps) | solved q = Just ms | q ∈ qs = bfsearch qs ps | otherwise = bfsearch (q : qs) (ps ++ succs p)
Dart // 基本の BFS。qs は訪問済み集合、ps はキュー List<M>? bfsearch<S, M>( List<S> qs, Frontier<S, M> ps, Moves<S, M> moves, MoveFn<S, M> move, Solved<S> solved, ) { while (ps.isNotEmpty) { final p = ps.removeAt(0); final (ms, q) = p; if (solved(q)) return ms; if (qs.contains(q)) continue; qs = [q, ...qs]; ps.addAll(succs(p, moves, move)); } return null; }
succs :: Path → [Path] succs (ms, q) = [(ms ++ [m], move q m) | m ← moves q]
Dart // 現在のパスから、合法手を1つ足した後続パスを列挙 List<Path<S, M>> succs<S, M>( Path<S, M> p, Moves<S, M> moves, MoveFn<S, M> move, ) { final (ms, q) = p; return [for (final m in moves(q)) ([...ms, m], move(q, m))]; }

やっていることを1文で言うと、パスの先頭を取り出し、

  1. ゴールならその手順を返す。
  2. すでに見た状態なら捨てる。
  3. そうでなければ後続パスをキュー末尾に足して続ける。
大事な性質 BFS は解があれば必ず最短の解を見つける。ただし現在のフロンティアが（DFS と比べて）指数関数的に長くなり得る点は要注意。

DFS との違いは1か所だけ

深さ優先探索（DFS）にしたいなら、後続を末尾ではなく先頭に足すだけ。つまり ps ++ succs p を succs p ++ ps に書き換える。フロンティアがスタック扱いになり、あるパスの子から先に潜っていきます。DFS も解があれば見つけますが、最短とは限りません。

速くするためのカギ：累積引数

上の bfsearch は ps ++ succs p のところで、フロンティアの長さに比例した時間がかかってしまう。そこで累積引数を1つ足して bfsearch′ を作ります。

bfsearch′ qs pss ps = bfsearch qs (ps ++ concat (reverse pss))
Dart // 累積引数版の定義式：pss を逆順に連結して ps の末尾に足すと元の bfsearch と一致 List<M>? bfsearchPrimeSpec<S, M>( List<S> qs, List<Frontier<S, M>> pss, Frontier<S, M> ps, Moves<S, M> moves, MoveFn<S, M> move, Solved<S> solved, ) { final tail = [for (final fr in pss.reversed) ...fr]; return bfsearch([...qs], [...ps, ...tail], moves, move, solved); }

簡単な計算で、次の形が得られます。

bfsearch′ :: [State] → [Frontier] → Frontier → Maybe [Move] bfsearch′ qs [ ] [ ] = Nothing bfsearch′ qs pss [ ] = bfsearch′ qs [ ] (concat (reverse pss)) bfsearch′ qs pss (p@(ms, q) : ps) | solved q = Just ms | q ∈ qs = bfsearch′ qs pss ps | otherwise = bfsearch′ (q : qs) (succs p : pss) ps
Dart // pss（後続フロンティアの束）を溜めておき、ps が尽きたら平坦化してリセットする版 List<M>? bfsearchPrime1<S, M>( List<S> qs, List<Frontier<S, M>> pss, Frontier<S, M> ps, Moves<S, M> moves, MoveFn<S, M> move, Solved<S> solved, ) { while (true) { if (ps.isEmpty) { if (pss.isEmpty) return null; ps = [for (final fr in pss.reversed) ...fr]; pss = []; continue; } final p = ps.removeAt(0); final (ms, q) = p; if (solved(q)) return ms; if (qs.contains(q)) continue; qs = [q, ...qs]; pss = [succs(p, moves, move), ...pss]; } }

もっとシンプルに、累積引数の型を [Frontier] ではなく Frontier にしてしまう版もあります。

bfsearch′ :: [State] → Frontier → Frontier → Maybe [Move] bfsearch′ qs [ ] [ ] = Nothing bfsearch′ qs rs [ ] = bfsearch′ qs [ ] rs bfsearch′ qs rs (p@(ms, q) : ps) | solved q = Just ms | q ∈ qs = bfsearch′ qs rs ps | otherwise = bfsearch′ (q : qs) (succs p ++ rs) ps
Dart // より簡潔な版：累積は単一の Frontier rs。ps が空になったら rs を新 ps に List<M>? bfsearchPrime<S, M>( List<S> qs, Frontier<S, M> rs, Frontier<S, M> ps, Moves<S, M> moves, MoveFn<S, M> move, Solved<S> solved, ) { while (true) { if (ps.isEmpty) { if (rs.isEmpty) return null; ps = rs; rs = []; continue; } final p = ps.removeAt(0); final (ms, q) = p; if (solved(q)) return ms; if (qs.contains(q)) continue; qs = [q, ...qs]; rs = [...succs(p, moves, move), ...rs]; } }

この版は、隣り合うフロンティアを「左→右」と「右→左」で交互にたどるという動きをしますが、それでも解があれば最短解を見つけます。

最後にラッパを1つ。

bfsolve q = bfsearch′ [ ] [ ] [([ ], q)]
Dart // エントリ関数：初期状態から空手順で開始 List<M>? bfsolveGeneric<S, M>( S q, Moves<S, M> moves, MoveFn<S, M> move, Solved<S> solved, ) { return bfsearchPrime(<S>[], <Path<S, M>>[], [(<M>[], q)], moves, move, solved); }

方法2：プランニング

「片っ端から試す」の限界

BFS は結局のところ「あらゆる手の並びをしらみつぶしに試す」戦略です。これは人間の解き方ではありません。人間はプラン（計画）を立てます。ここでは、うまく実行できればゴールに至るような手の列をプランと呼ぶことにします。

type Plan = [Move]
Dart // プランは「これから指すつもりの手の列」 typedef Plan<M> = List<M>;
プランの決まりごと

準備手：premoves

プランの先頭手 m が今の状態でそのまま指せるなら指す。指せないなら、先に片づけておかないといけない準備手を挙げる関数 premoves :: State → Move → [[Move]] を使う。premoves q m の各要素 pms は「この pms をまず全部やれば m を指せる」という候補の集まりです。

pms の中の手にもさらに準備手が要るかもしれないので、premoves を繰り返し適用してプランを拡張していきます。

newplans :: State → Plan → [Plan] newplans q ms = mkplans ms where mkplans ms | null ms = [ ] | m ∈ qms = [ms] | otherwise = concat [mkplans (pms ++ ms) | pms ← premoves q m, all (∉ ms) pms] where m = head ms; qms = moves q
Dart // 抽象版：先頭手が合法になるまで premoves で前置して展開 typedef PreMoves<S, M> = List<List<M>> Function(S q, M m); List<Plan<M>> newplansGeneric<S, M>( S q, Plan<M> ms, Moves<S, M> moves, PreMoves<S, M> premoves, ) { final qms = moves(q); List<Plan<M>> mkplans(Plan<M> ms) { if (ms.isEmpty) return []; final m = ms.first; if (qms.contains(m)) return [ms]; return [ for (final pms in premoves(q, m)) if (pms.every((x) => !ms.contains(x))) ...mkplans([...pms, ...ms]), ]; } return mkplans(ms); }

newplans q ms は、「先頭の手が今の状態で必ず指せる」非空プランのリストを返します（空リストの場合もあり）。

探索のスタートには、状態 q における「ゴールに向かうたたき台のプラン」goalmoves q（型は State → Plan）が与えられていると仮定します。

拡張パスと探索本体

プランを持ち歩くために、パスの三つ組を用意します。

type APath = ([Move], State, Plan) type AFrontier = [APath]
Dart // APath は「これまでの手」「現在の状態」「残りのプラン」の3組 typedef APath<S, M> = (List<M> ms, S q, Plan<M> plan); typedef AFrontier<S, M> = List<APath<S, M>>;

三つ組の中身は「これまでに指した手」「現在の状態」「残りの手のプラン」です。探索本体は、プランのどれかが成功するか全滅するまで、順に調べます。

psearch :: [State] → AFrontier → Maybe [Move] psearch qs [ ] = Nothing psearch qs (p@(ms, q, plan) : ps) | solved q = Just ms | q ∈ qs = psearch qs ps | otherwise = psearch (q : qs) (asuccs p ++ ps ++ bsuccs p)
Dart // プランニング付き探索の骨格：asuccs を先頭に、bsuccs を末尾に配置 List<M>? psearchGeneric<S, M>( List<S> qs, AFrontier<S, M> ps, List<APath<S, M>> Function(APath<S, M>) asuccs, List<APath<S, M>> Function(APath<S, M>) bsuccs, Solved<S> solved, ) { while (ps.isNotEmpty) { final p = ps.removeAt(0); final (ms, q, _) = p; if (solved(q)) return ms; if (qs.contains(q)) continue; qs = [q, ...qs]; ps = [...asuccs(p), ...ps, ...bsuccs(p)]; } return null; }
asuccs, bsuccs :: APath → [APath] 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]
Dart // asuccs：プランを延ばして進む／bsuccs：合法手を1つ指してプランを立て直す typedef GoalMoves<S, M> = Plan<M> Function(S q); List<APath<S, M>> asuccsGeneric<S, M>( APath<S, M> p, MoveFn<S, M> move, List<Plan<M>> Function(S, Plan<M>) newplans, ) { final (ms, q, plan) = p; return [ for (final np in newplans(q, plan)) if (np.isNotEmpty) ([...ms, np.first], move(q, np.first), np.sublist(1)), ]; } List<APath<S, M>> bsuccsGeneric<S, M>( APath<S, M> p, Moves<S, M> moves, MoveFn<S, M> move, GoalMoves<S, M> goalmoves, ) { final (ms, q, _) = p; return [ for (final m in moves(q)) (() { final qp = move(q, m); return ([...ms, m], qp, goalmoves(qp)); })(), ]; }
なぜ bsuccs が要るの？ asuccs は「今のプランを延ばして進む」動き、bsuccs は「合法手を1つ指してプランを立て直す」動きです。プランは貪欲に実行されるので、解があってもプランだけで通せるとは限りません。bsuccs を混ぜておくことで、探索の完全性（解があれば必ず見つける）を保てます。

累積引数バージョンとエントリ関数

psearch′ :: [State] → AFrontier → AFrontier → Maybe [Move] psearch′ qs [ ] [ ] = Nothing psearch′ qs rs [ ] = psearch′ qs [ ] rs psearch′ qs rs (p@(ms, q, plan) : ps) | solved q = Just (reverse ms) | q ∈ qs = psearch′ qs rs ps | otherwise = psearch′ (q : qs) (bsuccs p ++ rs) (asuccs p ++ ps)
Dart // 累積引数版：asuccs は現行 ps に先付け、bsuccs は次回用 rs に溜める List<M>? psearchPrime<S, M>( List<S> qs, AFrontier<S, M> rs, AFrontier<S, M> ps, List<APath<S, M>> Function(APath<S, M>) asuccs, List<APath<S, M>> Function(APath<S, M>) bsuccs, Solved<S> solved, ) { while (true) { if (ps.isEmpty) { if (rs.isEmpty) return null; ps = rs; rs = []; continue; } final p = ps.removeAt(0); final (ms, q, _) = p; if (solved(q)) return ms; // Haskell の reverse は実装上不要（末尾追加のため） if (qs.contains(q)) continue; qs = [q, ...qs]; rs = [...bsuccs(p), ...rs]; ps = [...asuccs(p), ...ps]; } }
psolve :: State → Maybe [Move] psolve q = psearch′ [ ] [ ] [([ ], q, goalmoves q)]
Dart // 抽象版のエントリ：初期プランは goalmoves(q) List<M>? psolveGeneric<S, M>( S q, List<APath<S, M>> Function(APath<S, M>) asuccs, List<APath<S, M>> Function(APath<S, M>) bsuccs, Solved<S> solved, GoalMoves<S, M> goalmoves, ) { return psearchPrime( <S>[], <APath<S, M>>[], [(<M>[], q, goalmoves(q))], asuccs, bsuccs, solved, ); }

psolve はプランニングで solve を実装したもの。プランを幅優先に調べる版も作れますが、詳細は読者への宿題です。解があれば必ず見つけますが、最短の保証はありません。

ラッシュアワーを実装する

盤面と車両の表し方

ラッシュアワーの盤面は 6 × 6 の 36 マス。マスには乗用車（2 マス）かトラック（3 マス）が乗っています。横向きの車は左右、縦向きの車は上下にしか動けません。盤面右辺の上から3マス目が出口マスで、その左隣に置かれた特別な車（車両 0）を出口へ動かすのが目的です。

     ·  |  |  |  ·  ·
     ·  |  |  |  •—•
     ·  •  •—•  |  ·
     ·  ·  •—•  |  ·
     ·  ·  ·  ·  ·  ·
     ·  ·  |  ·  •—•
     •—•  |  ·  •—•
図 18.1 ラッシュアワーの盤面の例

マス番号の付け方（7 の倍数を壁に使う小技）

マスを 2 次元座標ではなく、次のように飛び番号で並べます。

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 です。

盤面の状態は、車両ごとに「後端マスと前端マスのペア」を並べたリスト。リスト内の位置がそのまま車両番号で、先頭は特別な車両 0 です。図 18.1 の盤面は次のようになります。

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)]
Dart // 図 18.1 の初期盤面（先頭は特別な車両 0） final Grid 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), ];
type Cell = Int type Grid = [(Cell, Cell)] type Vehicle = Int type Move = (Vehicle, Cell) type State = Grid
Dart // ラッシュアワー用の型別名 typedef Cell = int; typedef Grid = List<(Cell r, Cell f)>; typedef Vehicle = int; typedef RMove = (Vehicle v, Cell c); // Move は組み込み型と紛らわしいので RMove

占有マス／空きマス／合法手

各車両が占めるマスを埋めていき、マージすれば占有マスの昇順リスト。

occupied :: Grid → [Cell] occupied = foldr (merge · fillcells) [ ] fillcells (r, f) = if r > f−7 then [r .. f] else [r, r+7 .. f]
Dart // 車両1台が占めるマスを列挙。横向きは連番、縦向きは +7 刻み List<Cell> fillcells((Cell, Cell) rf) { final (r, f) = rf; if (r > f - 7) { return [for (var c = r; c <= f; c++) c]; // 横向き } else { return [for (var c = r; c <= f; c += 7) c]; // 縦向き } } List<Cell> occupied(Grid g) { final s = <Cell>{}; for (final rf in g) { s.addAll(fillcells(rf)); } final xs = s.toList()..sort(); return xs; }

ここで「(r, f) が横向き」なのは r > f−7 のとき、「縦向き」なのは r ≤ f−7 のとき。

freecells :: Grid → [Cell] freecells g = allcells \\ occupied g
Dart // 1..41 のうち 7 の倍数（右壁）を除いた全マス final List<Cell> allcells = [ for (var c = 1; c <= 41; c++) if (c % 7 != 0) c, ]; List<Cell> freecells(Grid g) { final occ = occupied(g).toSet(); return [for (final c in allcells) if (!occ.contains(c)) c]; }

ここで allcells = [c | c ← [1..41], c mod 7 ≠ 0]。merge と順序付きリストの差 \\ は標準的なので省略します。

moves :: Grid → [Move] moves g = [(v, c) | (v, i) ← zip [0..] g, c ← adjs i, c ∈ fs] where fs = freecells g adjs (r, f) = if r > f−7 then [f+1, r−1] else [f+7, r−7]
Dart // 各車両の隣接マス（横向きは前後、縦向きは上下） List<Cell> adjs((Cell, Cell) rf) { final (r, f) = rf; return (r > f - 7) ? [f + 1, r - 1] : [f + 7, r - 7]; } List<RMove> movesGrid(Grid g) { final fs = freecells(g).toSet(); return [ for (var v = 0; v < g.length; v++) for (final c in adjs(g[v])) if (fs.contains(c)) (v, c), ]; }

手 (v, c) が合法なのは、マス c が空いていて、しかも車両 v の現在位置に正しい軸方向で隣接しているとき、その時のみ。1 手はちょうど 1 マス動かす操作です。

手を打つ／盤面を更新する

move g (v, c) = g1 ++ adjust i c : g2 where (g1, i : g2) = splitAt v g
Dart // 車両 v の区間を adjust で書き換えた新しい Grid を返す（純関数的） Grid moveGrid(Grid g, RMove m) { final (v, c) = m; return [ ...g.sublist(0, v), adjust(g[v], c), ...g.sublist(v + 1), ]; }
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)
Dart // 車両の区間 (r,f) を、目標マス c の側へ1マスだけずらす (Cell, Cell) adjust((Cell, Cell) rf, Cell c) { final (r, f) = rf; if (r > f - 7) { // 横向き return (c > f) ? (r + 1, c) : (c, f - 1); } else { // 縦向き return (c < r) ? (c, f - 7) : (r + 7, c); } }

算術は素直なので詳細は省きます。ゴール条件は「車両 0 の前端が出口マス 20 に来た」。

solved :: Grid → Bool solved g = snd (head g) == 20
Dart // 車両 0（先頭）の前端 f が出口マス 20 に来た bool solvedGrid(Grid g) => g.first.$2 == 20;
bfsolve :: Grid → Maybe [Move] bfsolve g = bfsearch′ [ ] [ ] [([ ], g)]
Dart // ラッシュアワー用のエントリ関数 List<RMove>? bfsolve(Grid g) { return bfsolveGeneric<Grid, RMove>(g, movesGrid, moveGrid, solvedGrid); }

ゴールプランと「じゃま者どかし」

psearch を使うには、goalmoves と premoves を用意すればよい。goalmoves は簡単で、「車両 0 を今いる位置から出口まで一歩ずつ前進させる手のリスト」。

goalmoves :: Grid → Plan goalmoves g = [(0, c) | c ← [snd (head g) + 1 .. 20]]
Dart // 車両 0 を今の前端から出口 20 まで、1マスずつ前進させる手順 Plan<RMove> goalmoves(Grid g) { final start = g.first.$2 + 1; return [for (var c = start; c <= 20; c++) (0, c)]; }

premoves は、指したい手 m の目標マス c がすでに他の車両で埋まっているときに使う。そのとき、c を含む区間を持つ車両 (v, i) は唯一存在します。それを見つけるのが blocker。

blocker :: Grid → Cell → (Vehicle, (Cell, Cell)) blocker g c = search (zip [0..] g) c search ((v, i) : vis) c = if covers c i then (v, i) else search vis c covers c (r, f) = r ≤ c ∧ c ≤ f ∧ (r > f−7 ∨ (c−r) mod 7 == 0)
Dart // マス c を含む車両（唯一）を探す bool covers(Cell c, (Cell, Cell) rf) { final (r, f) = rf; return r <= c && c <= f && (r > f - 7 || (c - r) % 7 == 0); } (Vehicle, (Cell, Cell)) blocker(Grid g, Cell c) { for (var v = 0; v < g.length; v++) { if (covers(c, g[v])) return (v, g[v]); } throw StateError('no blocker at $c'); }

じゃま者 v（区間 i = (r, f)）は、マス c を空けるまで左か右、あるいは上か下に必要な手数だけ動かせばよい。それを列挙するのが freeingmoves。

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)
Dart // じゃま者を c から追い出す準備手の候補（右／左、上／下）を列挙 List<List<RMove>> freeingmoves(Cell c, (Vehicle, (Cell, Cell)) blk) { final (v, rf) = blk; final (r, f) = rf; final result = <List<RMove>>[]; if (r > f - 7) { // 横向き：長さ n final n = f - r + 1; final k = f - f % 7; // 同じ行の右端の壁の左（7 の倍数） if (c + n < k + 7) { result.add([for (var j = f + 1; j <= c + n; j++) (v, j)]); // 右へ } if (c - n > k) { result.add([for (var j = r - 1; j >= c - n; j--) (v, j)]); // 左へ } } else { // 縦向き：長さ m = 7*n final m = f - r + 7; if (c - m > 0) { result.add([for (var j = r - 7; j >= c - m; j -= 7) (v, j)]); // 上へ } if (c + m < 42) { result.add([for (var j = f + 7; j <= c + m; j += 7) (v, j)]); // 下へ } } return result; }
premoves :: Grid → Move → [[Move]] premoves g (v, c) = freeingmoves c (blocker g c)
Dart // 手 (v, c) を指すために、マス c を先に空けるための準備手 List<List<RMove>> premoves(Grid g, RMove m) { final (_, c) = m; return freeingmoves(c, blocker(g, c)); }

要注意：ラッシュアワー用に newplans を作り直す

なぜ改造が必要？ ゴール手が [(0, 19), (0, 20)] だとして、車両 0 が今 [17, 18] にいるとします。(0, 19) の準備手 pms の中に(0, 16)（車両 0 を1マス左に動かす）が混ざっているかもしれない。pms を全部実行したあと、車両 0 は [15, 16] にいるので、(0, 19) は「2 マス一気に前へ」となりもう 1 手では実行不能。だから (0, 19) を [(0, 18), (0, 19)] のように1 マスずつの手に展開し直す必要があります。
newplans :: Grid → Plan → [Plan] newplans g [ ] = [ ] newplans g (m : ms) = mkplans (expand g m ++ ms) where mkplans ms = if m ∈ gms then [ms] else concat [mkplans (pms ++ ms) | pms ← premoves g m, all (∉ ms) pms] where m = head ms; gms = moves g
Dart // ラッシュアワー版：先頭手を expand で 1マス刻みに展開してから mkplans List<Plan<RMove>> newplans(Grid g, Plan<RMove> plan) { if (plan.isEmpty) return []; final head = plan.first; final tail = plan.sublist(1); final expanded = [...expand(g, head), ...tail]; final gms = movesGrid(g); List<Plan<RMove>> mkplans(Plan<RMove> ms) { if (ms.isEmpty) return []; final m = ms.first; if (gms.contains(m)) return [ms]; return [ for (final pms in premoves(g, m)) if (pms.every((x) => !ms.contains(x))) ...mkplans([...pms, ...ms]), ]; } return mkplans(expanded); }

「無効かもしれない手」を「1 マスずつの有効な手の列」に展開するのが expand。

expand :: Grid → Move → [Move] expand g (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
Dart List<RMove> expand(Grid g, RMove m) { final (v, c) = m; final (r, f) = g[v]; if (r > f - 7) { // 横向き車両: 1 マスずつ if (c > f) { return [for (var p = f + 1; p <= c; p++) (v, p)]; } else { return [for (var p = r - 1; p >= c; p--) (v, p)]; } } else { // 縦向き車両: 7 マスずつ if (c > f) { return [for (var p = f + 7; p <= c; p += 7) (v, p)]; } else { return [for (var p = r - 7; p >= c; p -= 7) (v, p)]; } } }
psolve :: Grid → Maybe [Move] psolve g = psearch′ [ ] [ ] [([ ], g, goalmoves g)]

ここで psearch′ は前節そのままで、ただし newplans だけ上の改訂版に差し替えます。

実験結果

   |  |  |  |  ·  ·       ·  ·  ·  |  ·  ·
   |  |  |  •—•  ·       ·  ·  •  |  ·  ·
   ·  ·  •—•  ·  ·       ·  •—•  |  ·  ·
   ·  ·  ·  ·  ·  ·       ·  ·  ·  ·  ·  ·
   •—•  ·  ·  ·  •       ·  ·  ·  ·  •—•
   ·  ·  |  ·  ·  •       ·  ·  ·  |  ·  ·
   ·  ·  •—•  ·  •       •—•  ·  •  ·  ·


   |  •—•  ·  ·  ·       |  ·  |  ·  ·  ·
   |  ·  •  |  ·  ·       |  ·  |  ·  •—•
   ·  ·  •—•  ·  ·       ·  ·  ·  ·  •—•
   ·  ·  ·  ·  ·  ·       •—•  ·  ·  ·  ·
   ·  |  •  ·  ·  ·       ·  ·  ·  ·  ·  ·
   •—•  |  •  ·  ·       ·  ·  ·  ·  ·  ·
   ·  ·  ·  ·  ·  ·       •—•  •—•  ·  ·
図 18.2 4 つのラッシュアワー問題
表 18.1 4 つのラッシュアワー問題を解くのに要した時間
問題 bfsolve 手数 psolve 手数 dfsolve 手数
19.11340.23383.961228
24.71180.04273.752126
31.70550.91750.97812
49.84812.36932.251305
実測から分かること
Dart // 動作確認: 簡易な盤面（車両0が(18,19)にいて、あと1マス右にずらせば // 出口マス20に到達）を作り、bfsolve を呼び出す。 void main() { // 盤面: 車両0 = 出口の1マス手前（18-19）。他の車両なし。 // セル番号は 1..41 の 6x7 座標系（7の倍数は右壁で除外）、出口=20。 final Grid g0 = [(18, 19)]; print('初期盤面: $g0'); print('解けている？ ${solvedGrid(g0)}'); // false: まだ出口ではない final moves = bfsolve(g0); print('BFS 解: $moves'); // [(0, 20)]: 車両0を20へ動かす1手 if (moves != null) { var g = g0; for (final m in moves) { g = moveGrid(g, m); } print('最終盤面: $g, 解けた? ${solvedGrid(g)}'); // true } }

むすび

ラッシュアワーが PSPACE 完全である、という結果は Flake and Baum (2002) にあります。著者は 2008 年の Advanced Functional Programming Summer School（Jones, 2008）でラッシュアワーを知り、Mark Jones の講義で「関数的な考え方の威力」に触れたそうです。Jones は BFS 解を示したうえで「もっと速い解を作ってみないか」と参加者に投げかけ、この章はその挑戦への回答として生まれました。

参考文献

Flake, G. W. and Baum, E. B. (2002). Rush Hour is PSPACE-complete, or “Why you should generously tip parking lot attendants”. Theoretical Computer Science 270 (1), 895–911.

Jones, M. P. (2008). Functional thinking. Advanced Functional Programming Summer School, Boxmeer, The Netherlands.

1 ラッシュアワーは http://www.puzzles.com/products/rushhour.htm から入手できます。