●経路の探索 (ハミルトン路)
あるグラフにおいて、すべての頂点をちょうど一回ずつ通る経路を「ハミルトン路 (Hamiltonian path)」といいます。また、すべての頂点を一回ずつ通って出発点に戻る経路を「ハミルトン閉路」といいます。任意のグラフがハミルトン路を持っているか否かを判定する方法は、現在では知られていません (NP 問題といわれています)。
今回は前回の経路図で A から I までのハミルトン路を求めてみましょう。経路図を再掲します。
●プログラムの作成
前回のプログラムは、スタートとゴール以外の頂点の制約条件で、つながる辺の本数を 0 or 2 に指定しました。今回はすべての頂点を通るので、辺の本数を 2 に指定すれば解けるような気がします。実際にプログラムを作って確かめてみましょう。
リスト : ハミルトン路を求める (No Good)
:- use_module(library(clpfd)).
% 辺の表示
print_edge([], []).
print_edge([1 | Xs], [Y | Ys]) :- writeln(Y), print_edge(Xs, Ys).
print_edge([0 | Xs], [_ | Ys]) :- print_edge(Xs, Ys).
check1(_, _, []).
check1(S, G, [S-Xs | As]) :-
sum(Xs, #=, 1), check1(S, G, As).
check1(S, G, [G-Xs | As]) :-
sum(Xs, #=, 1), check1(S, G, As).
check1(S, G, [_-Xs | As]) :-
sum(Xs, #=, 2), check1(S, G, As).
solver1 :-
Vars = [AB, BC, AD, BE, CF, DE,
EF, DG, EH, FI, GH, HI],
Name = ["A-B", "B-C", "A-D", "B-E", "C-F", "D-E",
"E-F", "D-G", "E-H", "F-I", "G-H", "H-I"],
Vars ins 0..1,
Adj = [a-[AB, AD], b-[AB, BC, BE], c-[BC, CF],
d-[AD, DE, DG], e-[BE, DE, EF, EH], f-[CF, EF, FI],
g-[DG, GH], h-[EH, GH, HI], i-[FI, HI]],
check1(a, i, Adj),
label(Vars),
writeln(Vars),
print_edge(Vars, Name).
述語 check1 において、最後の規則でつながる辺の本数を 2 に指定します。あとは、label で Vars の値を求めるだけです。
実行結果は次のようになりました。
?- solver1. [0,1,1,1,1,0,0,1,1,1,1,0] B-C A-D B-E C-F D-G E-H F-I G-H true ; [0,1,1,1,1,0,1,1,0,0,1,1] B-C A-D B-E C-F E-F D-G G-H H-I true ; false. ?-
A B--C A B--C | | | | | | D E F D E--F | | | | G--H I G--H--I
最初の解はハミルトン路になっていますが、次の解は閉路 (B - C - E - F) ができるため、ハミルトン路にはなりません。このように、頂点につながる辺の本数だけでは条件不足になるのです。
●閉路のチェック
閉路ができるのを防ぐため、今回は経路に沿って頂点に番号を順番に付けていくことにします。このとき、隣り合った頂点の差分は 1 になることに注意してください。閉路の場合、たとえば B - C - F - E で番号を 2, 3, 4, 5 と付けると、B と E は隣り合っているにもかかわらず差分が 3 になるため、この経路は除外されることになります。
プログラムは次のようになります。
リスト : ハミルトン路を求める (Good)
check2(E, X-Y) :- E #==> abs(X - Y) #= 1.
solver2 :-
Vars = [AB, BC, AD, BE, CF, DE,
EF, DG, EH, FI, GH, HI],
Name = ["A-B", "B-C", "A-D", "B-E", "C-F", "D-E",
"E-F", "D-G", "E-H", "F-I", "G-H", "H-I"],
Vars ins 0..1,
Adj = [a-[AB, AD], b-[AB, BC, BE], c-[BC, CF],
d-[AD, DE, DG], e-[BE, DE, EF, EH], f-[CF, EF, FI],
g-[DG, GH], h-[EH, GH, HI], i-[FI, HI]],
check1(a, i, Adj),
% 経路に沿って頂点に番号をつける
Node = [A, B, C, D, E, F, G, H, I],
Node ins 1..9,
Edge = [A-B, B-C, A-D, B-E, C-F, D-E,
E-F, D-G, E-H, F-I, G-H, H-I],
A #= 1,
I #= 9,
maplist(check2, Vars, Edge),
label(Vars),
writeln(Vars),
writeln(Node),
print_edge(Vars, Name).
リスト Node に頂点の表す変数を格納します。範囲は 1..9 で、A を 1 に、I を 9 に設定します。そして、辺の両端にある頂点の変数を組で表し、それを連想リスト Edge に格納します。辺の値が 1 ならば、両端の変数の差分が 1 であることを、述語 check2 と maplist で設定します。
●実行結果
それでは実行してみましょう。
?- solver2. [0,1,1,1,1,0,0,1,1,1,1,0] [1,6,7,2,5,8,3,4,9] B-C A-D B-E C-F D-G E-H F-I G-H true ; [1,1,0,0,1,1,1,1,0,0,1,1] [1,2,3,6,5,4,7,8,9] A-B B-C C-F D-E E-F D-G G-H H-I true ; false.
A B--C A--B--C | | | | D E F D--E--F | | | | G--H I G--H--I
2 通りの経路を求めることができました。
●有向グラフの場合
有向グラフの場合でも同様な問題が生じます。次のプログラムのように、スタートとゴール以外の頂点で、入力の辺と出力の辺が 1 であることを条件にすると、閉路が生じてしまいます。
リスト : ハミルトン路を求める (No Good)
% 制約条件
check1(_, _, _, [], []).
check1(S, S, G, [X | Xs], [Y | Ys]) :-
sum(X, #=, 1), % スタートは出る辺しかない
sum(Y, #=, 0),
N1 #= S + 1,
check1(N1, S, G, Xs, Ys).
check1(G, S, G, [X | Xs], [Y | Ys]) :-
sum(X, #=, 0), % ゴールは入る辺しかない
sum(Y, #=, 1),
N1 #= G + 1,
check1(N1, S, G, Xs, Ys).
check1(N, S, G, [X | Xs], [Y | Ys]) :-
sum(X, #=, 1), % 出る辺と入る辺の数が同じ (1)
sum(Y, #=, 1),
N1 #= N + 1,
check1(N1, S, G, Xs, Ys).
% A から I までのハミルトン路を求める
solver1 :-
adjacent(Xs),
flatten(Xs, Ys),
include(var, Ys, Vars), % 変数を集める
Vars ins 0..1,
transpose(Xs, Zs),
check1(1, 1, 9, Xs, Zs),
label(Vars),
print_edge(0, Xs).
プログラムの実行結果を示します。
?- solver1. A -> D B -> E C -> F D -> G E -> B F -> C G -> H H -> I true ; A -> D B -> E C -> B D -> G E -> F F -> C G -> H H -> I true ; A -> D B -> C C -> F D -> G E -> B F -> I G -> H H -> E true .
無向グラフと違って、2 つの頂点を行き来する閉路もあります。
この場合も経路に沿って頂点に番号をつけることで、閉路の生成を防ぐことができます。プログラムは次のようになります。
リスト : ハミルトン路を求める (Good)
check3(_, [], []).
check3(X, [Y | Ys], [N | Ns]) :-
var(Y), !, Y #==> X + 1 #= N, check3(X, Ys, Ns).
check3(X, [_ | Ys], [_ | Ns]) :-
check3(X, Ys, Ns).
check2([], [], _).
check2([N | Ns], [X | Xs], Node) :-
check3(N, X, Node),
check2(Ns, Xs, Node).
solver2 :-
adjacent(Xs),
flatten(Xs, Ys),
include(var, Ys, Vars), % 変数を集める
Vars ins 0..1,
transpose(Xs, Zs),
check1(1, 1, 9, Xs, Zs),
length(Node, 9),
Node ins 1..9,
check2(Node, Xs, Node),
element(1, Node, 1),
element(9, Node, 9),
label(Vars),
writeln(Node),
print_edge(0, Xs).
頂点を表す変数は length で生成し、述語 check2 で制約を設定します。第 1, 3 引数が頂点を表す変数のリスト、第 2 引数が隣接行列です。check2 では、変数と行を順番に取り出して check3 に渡します。check3 の第 1 引数が頂点で、第 2 引数が頂点につながる辺を格納したリスト、第 3 引数がもう一方の頂点になります。辺 Y が自由変数の場合、Y を選択したときは X から N に進むので X + 1 #= N を満たせばいいわけです。
あとは Node の先頭要素の値が 1 で、末尾要素の値が 9 であることを clpfd の述語 element/3 で指定します。
element(N, Xs, V)
element は nth1 と同様にリストの要素を 1 から数えます。そして、Xs の N 番目の要素が V であれば成功します。
簡単な例を示しましょう。
?- element(3, [10, 20, 30, 40, 50], 30). true. ?- element(4, [10, 20, 30, 40, 50], N). N = 40. ?- element(N, [10, 20, 30, 40, 50], 50). N = 5. ?- element(N, [10, 20, 30, 40, 50], M), label([N, M]). N = 1, M = 10 ; N = 2, M = 20 ; N = 3, M = 30 ; N = 4, M = 40 ; N = 5, M = 50. ?- length(Xs, 3), Xs ins 1..3, element(1, Xs, 3), label(Xs). Xs = [3, 1, 1] ; Xs = [3, 1, 2] ; Xs = [3, 1, 3] ; Xs = [3, 2, 1] ; Xs = [3, 2, 2] ; Xs = [3, 2, 3] ; Xs = [3, 3, 1] ; Xs = [3, 3, 2] ; Xs = [3, 3, 3].
●実行結果
実行結果は次のようになりました。
?- solver2. [1,6,7,2,5,8,3,4,9] A -> D B -> C C -> F D -> G E -> B F -> I G -> H H -> E true ; [1,2,3,6,5,4,7,8,9] A -> B B -> C C -> F D -> G E -> D F -> E G -> H H -> I true ; false. ?-
当然ですが 2 通りの経路が出力されます。
●プログラムリスト１
リスト : 経路の探索 (無向グラフ)
:- use_module(library(clpfd)).
% 辺の表示
print_edge([], []).
print_edge([1 | Xs], [Y | Ys]) :- writeln(Y), print_edge(Xs, Ys).
print_edge([0 | Xs], [_ | Ys]) :- print_edge(Xs, Ys).
check(_, _, []).
check(S, G, [S-Xs | As]) :-
sum(Xs, #=, 1), check(S, G, As).
check(S, G, [G-Xs | As]) :-
sum(Xs, #=, 1), check(S, G, As).
check(S, G, [_-Xs | As]) :-
sum(Xs, #=, K), K in 0 \/ 2, check(S, G, As).
solver :-
Vars = [AB, BC, AD, BE, CF, DE,
EF, DG, EH, FI, GH, HI],
Name = ["A-B", "B-C", "A-D", "B-E", "C-F", "D-E",
"E-F", "D-G", "E-H", "F-I", "G-H", "H-I"],
Vars ins 0..1,
Adj = [a-[AB, AD], b-[AB, BC, BE], c-[BC, CF],
d-[AD, DE, DG], e-[BE, DE, EF, EH], f-[CF, EF, FI],
g-[DG, GH], h-[EH, GH, HI], i-[FI, HI]],
check(a, i, Adj),
sum(Vars, #=, L),
labeling([min(L)], Vars),
writeln(Vars),
print_edge(Vars, Name).
% ハミルトン路を求める
check1(_, _, []).
check1(S, G, [S-Xs | As]) :-
sum(Xs, #=, 1), check1(S, G, As).
check1(S, G, [G-Xs | As]) :-
sum(Xs, #=, 1), check1(S, G, As).
check1(S, G, [_-Xs | As]) :-
sum(Xs, #=, 2), check1(S, G, As).
solver1 :-
Vars = [AB, BC, AD, BE, CF, DE,
EF, DG, EH, FI, GH, HI],
Name = ["A-B", "B-C", "A-D", "B-E", "C-F", "D-E",
"E-F", "D-G", "E-H", "F-I", "G-H", "H-I"],
Vars ins 0..1,
Adj = [a-[AB, AD], b-[AB, BC, BE], c-[BC, CF],
d-[AD, DE, DG], e-[BE, DE, EF, EH], f-[CF, EF, FI],
g-[DG, GH], h-[EH, GH, HI], i-[FI, HI]],
check1(a, i, Adj),
label(Vars),
writeln(Vars),
print_edge(Vars, Name).
check2(E, X-Y) :- E #==> abs(X - Y) #= 1.
solver2 :-
Vars = [AB, BC, AD, BE, CF, DE,
EF, DG, EH, FI, GH, HI],
Name = ["A-B", "B-C", "A-D", "B-E", "C-F", "D-E",
"E-F", "D-G", "E-H", "F-I", "G-H", "H-I"],
Vars ins 0..1,
Adj = [a-[AB, AD], b-[AB, BC, BE], c-[BC, CF],
d-[AD, DE, DG], e-[BE, DE, EF, EH], f-[CF, EF, FI],
g-[DG, GH], h-[EH, GH, HI], i-[FI, HI]],
check1(a, i, Adj),
%
Node = [A, B, C, D, E, F, G, H, I],
Node ins 1..9,
Edge = [A-B, B-C, A-D, B-E, C-F, D-E,
E-F, D-G, E-H, F-I, G-H, H-I],
A #= 1,
I #= 9,
maplist(check2, Vars, Edge),
label(Vars),
writeln(Vars),
writeln(Node),
print_edge(Vars, Name).
●プログラムリスト２
リスト : 経路の探索 (有向グラフ)
:- use_module(library(clpfd)).
% A B C D E F G H I
adjacent([[0,_,0, _,0,0, 0,0,0], % A
[_,0,_, 0,_,0, 0,0,0], % B
[0,_,0, 0,0,_, 0,0,0], % C
[_,0,0, 0,_,0, _,0,0], % D
[0,_,0, _,0,_, 0,_,0], % E
[0,0,_, 0,_,0, 0,0,_], % F
[0,0,0, _,0,0, 0,_,0], % G
[0,0,0, 0,_,0, _,0,_], % H
[0,0,0, 0,0,_, 0,_,0]]). % I
% 制約条件
check(_, _, _, [], []).
check(S, S, G, [X | Xs], [Y | Ys]) :-
sum(X, #=, 1), % スタートは出る辺しかない
sum(Y, #=, 0),
N1 #= S + 1,
check(N1, S, G, Xs, Ys).
check(G, S, G, [X | Xs], [Y | Ys]) :-
sum(X, #=, 0), % ゴールは入る辺しかない
sum(Y, #=, 1),
N1 #= G + 1,
check(N1, S, G, Xs, Ys).
check(N, S, G, [X | Xs], [Y | Ys]) :-
K in 0..1,
sum(X, #=, K), % 出る辺と入る辺の数が同じ (0 or 1)
sum(Y, #=, K),
N1 #= N + 1,
check(N1, S, G, Xs, Ys).
% 辺の表示
print_edge(_, []).
print_edge(N, [X | Xs]) :-
sumlist(X, 0),
N1 is N + 1,
print_edge(N1, Xs).
print_edge(N, [X | Xs]) :-
nth0(M, X, 1),
C1 is N + 0x41,
C2 is M + 0x41,
format('~c -> ~c~n', [C1, C2]),
N1 is N + 1,
print_edge(N1, Xs).
% A から I までの最短経路を求める
solver :-
adjacent(Xs),
flatten(Xs, Ys),
include(var, Ys, Vars), % 変数を集める
Vars ins 0..1,
transpose(Xs, Zs),
check(1, 1, 9, Xs, Zs),
sum(Vars, #=, L), % 経路長 L
labeling([min(L)], Vars),
maplist(writeln, Xs),
print_edge(0, Xs).
% 制約条件
check1(_, _, _, [], []).
check1(S, S, G, [X | Xs], [Y | Ys]) :-
sum(X, #=, 1), % スタートは出る辺しかない
sum(Y, #=, 0),
N1 #= S + 1,
check1(N1, S, G, Xs, Ys).
check1(G, S, G, [X | Xs], [Y | Ys]) :-
sum(X, #=, 0), % ゴールは入る辺しかない
sum(Y, #=, 1),
N1 #= G + 1,
check1(N1, S, G, Xs, Ys).
check1(N, S, G, [X | Xs], [Y | Ys]) :-
sum(X, #=, 1), % 出る辺と入る辺の数が同じ (1)
sum(Y, #=, 1),
N1 #= N + 1,
check1(N1, S, G, Xs, Ys).
% ハミルトン路を求める (No Good)
solver1 :-
adjacent(Xs),
flatten(Xs, Ys),
include(var, Ys, Vars), % 変数を集める
Vars ins 0..1,
transpose(Xs, Zs),
check1(1, 1, 9, Xs, Zs),
label(Vars),
maplist(writeln, Xs),
print_edge(0, Xs).
check3(_, [], []).
check3(X, [Y | Ys], [N | Ns]) :-
var(Y), !, Y #==> X + 1 #= N, check3(X, Ys, Ns).
check3(X, [_ | Ys], [_ | Ns]) :-
check3(X, Ys, Ns).
check2([], [], _).
check2([N | Ns], [X | Xs], Node) :-
check3(N, X, Node),
check2(Ns, Xs, Node).
% ハミルトン路を求める (Good)
solver2 :-
adjacent(Xs),
flatten(Xs, Ys),
include(var, Ys, Vars), % 変数を集める
Vars ins 0..1,
transpose(Xs, Zs),
check1(1, 1, 9, Xs, Zs),
length(Node, 9),
Node ins 1..9,
check2(Node, Xs, Node),
element(1, Node, 1),
element(9, Node, 9),
label(Vars),
maplist(writeln, Xs),
writeln(Node),
print_edge(0, Xs).
