Prologみたいなのではなく、ふつうの言語でやる場合、探索を自分で実装しなきゃいけないわけで（といってもあまり変わらないのは、私にProlog経験がないせいだということに）。
単純探索のためのテンプレートを利用する。解候補は{{m, s}, 履歴}の形式で表す。UMMでも動く。
search[fringe_, combiner_, findAll_] :=
If[fringe != {},
With[{x = First@fringe},
search[
If[goal@x, report@x; If[findAll, Rest@fringe, {}],
combiner[Rest@fringe, expand@x]],
combiner, findAll]]]
goal[x_] := Module[{a, b, c},
{a, b, c} = Last@x;
And[a == b, c == 0]]
report[x_] := Sow@Rest@x
expand[x_] := Module[{m, s, a, b, c},
{m, s} = First@x;
{a, b, c} = Last@x;
Select[
Append[x, #] & /@
{{0, a + b, c}, {a + b - m, m, c}, (* A to B *)
{0, b, a + c}, {a + c - s, b, s}, (* A to C *)
{a + b, 0, c}, (* B to A *)
{a, 0, b + c}, {a, b + c - s, s}, (* B to C *)
{a + c, b, 0}, (* C to A *)
{a, b + c, 0}, {a, m, b + c - m} (* A to B *)}, test]]
test[x_] := Module[{m, s, a, b, c},
{m, s} = First@x;
{a, b, c} = Last@x;
And[0 <= a, 0 <= b, b <= m, 0 <= c, c <= s, Not@MemberQ[Most@Rest@x, Last@x]]]
幅優先探索
AbsoluteTiming[Reap[search[{{{7, 3}, {10, 0, 0}}}, Join[#1, #2] &, False]]]
{0.0770098, {Null,
{{{{10, 0, 0}, {3, 7, 0}, {3, 4, 3}, {6, 4, 0}, {6, 1, 3},
{9, 1, 0}, {9, 0, 1}, {2, 7, 1}, {2, 5, 3}, {5, 5, 0}}}}}}
深さ優先探索
AbsoluteTiming[Reap[search[{{{7, 3}, {10, 0, 0}}}, Join[#2, #1] &, False]]]
{0.0060007, {Null,
{{{{10, 0, 0}, {3, 7, 0}, {0, 7, 3}, {7, 0, 3}, {7, 3, 0},
{4, 3, 3}, {4, 6, 0}, {1, 6, 3}, {1, 7, 2}, {8, 0, 2},
{8, 2, 0}, {5, 2, 3}, {5, 5, 0}}}}}}
ステップ数が少ない解が欲しいなら幅優先探索だが、深さ優先探索のほうが実行時間は短いかもしれない。
Related posts: