油売り算(Mathematica)

Prologみたいなのではなく、ふつうの言語でやる場合、探索を自分で実装しなきゃいけないわけで（といってもあまり変わらないのは、私にProlog経験がないせいだということに）

単純探索のためのテンプレートを利用する。

解候補は{{m, s}, 履歴}の形式で表す。

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_] := MapIndexed[Print[First@#2 - 1, ": ", #1] &, 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[search[{{{7, 3}, {10, 0, 0}}}, Join[#1, #2] &, False]]

0: {10,0,0}
1: {3,7,0}
2: {3,4,3}
3: {6,4,0}
4: {6,1,3}
5: {9,1,0}
6: {9,0,1}
7: {2,7,1}
8: {2,5,3}
9: {5,5,0}

{0.1054620, Null}

深さ優先探索

AbsoluteTiming[search[{{{7, 3}, {10, 0, 0}}}, Join[#2, #1] &, False]]

0: {10,0,0}
1: {3,7,0}
2: {0,7,3}
3: {7,0,3}
4: {7,3,0}
5: {4,3,3}
6: {4,6,0}
7: {1,6,3}
8: {1,7,2}
9: {8,0,2}
10: {8,2,0}
11: {5,2,3}
12: {5,5,0}

{0.0078120, Null}

ステップ数が少ない解が欲しいなら幅優先探索だが、深さ優先探索のほうが実行時間は短いかもしれない。