油売り算(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_] := 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}}}}}}

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