roland@sics.se (Roland Karlsson) (09/05/89)
This is a Prolog program that solves the 2 orthogonal latin squares
problem. Using several algorithms most squares are found. For some sizes
no solution are found (2, 6, 14, 18, 26, ...). Of those 2 and 6 are shown
in fact to have no solutions.
I would appreciate if any of you can tell me if you know of solutions to
14, 18, 26 ... . The program text comments show you how to get a
complete listing of unknown sizes.
You may have to remove lines that declare parallel predicates.
Roland Karlsson
#!/bin/sh
# shar: Shell Archiver (v1.22)
#
# Run the following text with /bin/sh to create:
# regof.pl
#
sed 's/^X//' << 'SHAR_EOF' > regof.pl &&
X% regof.pl
X
X/*
X Once upon a time in a since long forgotten land there lived a king
X with a very peculiar sense of order. On day the ruler of said kingdom
X pronounced:
X
X - Let it hence be known that we in our role as head of our armed
X forces will set a limit upon its size. Each year shall a great
X festival be held in the fields outside our castle. There shall
X officers from all regiments gather. From each regiment there shall be
X one officer of each rank. The number of ranks shall be the same as the
X number of regiments. We then says that there shall be no more
X regiments in this land then the side of a square consisting of those
X officers. To ensure that the number of regiments is held low we
X decide that there shall not be officers of same regiment and rank in
X neither row nor column.
X
X At those ancient times they knew nothing of computers and
X absolutely nil about prolog programming so their war machine stayed
X quite small. A rumour says that they managed to have five regiments
X but that they never got their sixth. Today things have changed though.
X This program would have gived the land means of a fantastic military
X expansion. Be glad this country is no more.
X
X
X ======================================================================
X
X This problem is known as two orthogonal latin squares.
X
X The regiments (with name X) are called 1, 2, ...
X The ranks (with name Y) are called 1, 2, ...
X The columns (with name C) are called 1, 2, ...
X The rows (with name R) are called 1, 2, ...
X
X Solutions are divided in:
X
X * Odd.
X * 2^n (n > 1).
X * 4+3k where 1+k has solution (k >= 0).
X * Factorizeable in above.
X * Rest (2+4n that is not one of above).
X
X For all but last group this program have deterministic algorithms.
X In the last group you can, in reasonable time, show that 2 and 6 have
X no solutions. Some 2+4n are unknown. Those are 14, 18, 26 ...
X The non deterministic search algorithm have so far neither found any
X solution for those nor shown that there are no solution. If you know
X of solutions you are very welcome to tell me. (To get a complete
X list of numbers that I do not know of any solution try the query
X write_all_solutions. Numbers that are unknown are marked as unknown.)
X
X PS. I have been told that all sizes except 2 and 6 has
X solutions. I shall not let this stop me to get another answer.
X
X - roland */
X
X
X/* Usage:
X regof(N) Gives a solution for NxN square.
X regof_naive(N Tries the naive algorithm.
X regof_odd(N) Tries the odd algorithm.
X regof_pow2(N) Tries the odd algorithm.
X regof_factor(N,L) N is factorizeable acc. to list L.
X regof_unknown(N) Do not know any algorithm.
X dotest(X) Test solutions (yes or no).
X get_factors(N,L) Get factors of N in list L.
X write_all_factors Write factors for numbers from 1 to 255.
X write_all_factors_proper Same as above but more complete.
X
X You may have to take away the parallel declarations if your
X Prolog system do not like them. Quintus just gives a warning
X and then ignores them.
X
X - roland */
X
X
X% -- Top queries. --
X% Also a chooser for algorithm.
X
X:- dynamic i_shall_test/0.
X
Xdotest(yes) :- assert(i_shall_test), write('I shall test.'), nl.
Xdotest(no) :- retractall(i_shall_test), write('No testing.'), nl.
X
Xregof(N) :- regof(N, _), !.
Xregof_naive(N) :- regof_naive(N, _), !.
Xregof_pow2(N) :- regof_pow2(N, _), !.
Xregof_odd(N) :- regof_odd(N, _), !.
Xregof_unknown(N) :- regof_unknown(N, _), !.
Xregof_factor(N, List) :- regof_factor(N, _, List), !.
X'regof_4+3k'(N, [Na,Nb]) :- 'regof_4+3k'(N, _, Na, Nb), !.
X
Xregof(N, _) :- var(N), !,
X write('Variable size?'), nl, fail.
Xregof(N, _) :- \+integer(N), !,
X write('Non integer size?'), nl, fail.
Xregof(N, _) :- N > 255, !,
X write('Square can not be bigger than 255 by 255.'), nl, fail.
Xregof(N, _) :- N < 0, !,
X write('Negative numbers of columns and rows?'), nl, fail.
Xregof(1, b(r(m(1,1)))) :- !,
X write('A one by one square is not very interresting.'), nl.
Xregof(N, Board) :- is_factor(odd, N, _, first), !,
X write('Odd numbers are very simple!'), nl,
X regof_odd(N, Board).
Xregof(_,_) :- write('Not odd.'), nl, fail.
Xregof(N, Board) :- is_factor(pow2, N, _, first), !,
X write('Simple! This type is 2^n.'), nl,
X regof_pow2(N, Board).
Xregof(_,_) :- write('Not 2^n.'), nl, fail.
Xregof(N, Board) :- is_factor('4+3k',N, [Na,Nb], first), !,
X write('Easy. This type is 4 + 3k.'), nl,
X 'regof_4+3k'(N, Board, Na, Nb).
Xregof(_,_) :- write('Not 4 + 3k.'), nl, fail.
Xregof(N, Board) :- is_factor(factor, N, ListOfN, first),
X ListOfN = [_,_|_], !,
X write('Can be factorized.'), nl,
X regof_factor(N, Board, ListOfN).
Xregof(_,_) :- write('Not factorizeable.'), nl, fail.
Xregof(N, Board) :-
X write('I will do it the hard way. Not knowing anything.'), nl,
X regof_unknown(N, Board).
X
Xwrite_all_factors :-
X get_number(1, 255, 1, N),
X (get_factors(N, Fs) ->
X findall(X, get_factors(N,_,X), T), sort(T, Types),
X write(N), write(': '), write([Fs|Types]), nl, fail
X ; write(N), write(': '), write(unknown), nl, fail).
X
Xwrite_all_factors_proper :-
X get_number(1, 255, 1, N),
X findall([T,F], get_factors(N,F,T), B), sort(B,SB),
X write(N=SB), nl, fail.
X
X
X% -- Odd. --
X% Very simple. (OBS! Zero numbering and non negative modulo.)
X% X is (C + R)%N.
X% Y is (C - R)%N. (or (C + 2*R)%n)
X
Xis_factor(odd, N, _, _) :- (N mod 2) =\= 0, N > 1.
X
Xregof_odd(N, Board) :-
X initialize(Men, _, _, N, Board),
X make_odd(N, N, Board),
X test_this_solution(Men, N, Board).
X
Xmake_odd(0, _, _). % For all rows ..
Xmake_odd(R, N, B) :- R > 0, NextR is R - 1,
X make2_odd(N, R, N, B),
X make_odd(NextR, N, B).
X
Xmake2_odd(0, _, _, _). % .. and columns ..
Xmake2_odd(C, R, N, B) :- C > 0, NextC is C - 1,
X X is ((N + (R-1) + (C-1)) mod N) + 1,
X Y is ((N - (R-1) + (C-1)) mod N) + 1,
X position(C, R, B, m(X,Y)), % .. set value.
X make2_odd(NextC, R, N, B).
X
X
X% -- 2^N. --
X% Almost as simple. (OBS! Se odd above.)
X% X is (C + ((-1)^(C+R))*R)%N.
X% Y is (C + ((-1)^(C+(R+1)//2))*(R*(R+1)//2))%N.
X
Xis_factor(pow2, 4, _, _).
Xis_factor(pow2, N1, _, _) :- N1 > 1, N2 is N1//2, N1 is N2*2,
X is_factor(pow2, N2, _, recursive).
X
Xregof_pow2(N, Board) :-
X initialize(Men, _, _, N, Board),
X make_pow2(N, N, Board),
X test_this_solution(Men, N, Board).
X
Xmake_pow2(0, _, _). % For all rows ..
Xmake_pow2(R, N, B) :- R > 0, NextR is R - 1,
X make2_pow2(N, R, N, B),
X make_pow2(NextR, N, B).
X
Xmake2_pow2(0, _, _, _). % .. and columns ..
Xmake2_pow2(C, R, N, B) :- C > 0, NextC is C - 1,
X ((((C-1+R-1) mod 2) =:= 0) -> SX = 1 ; SX = -1),
X ((((C-1+(R//2)) mod 2) =:= 0) -> SY = 1 ; SY = -1),
X X is 1 + ( (N + (C-1) - SX*(R-1)) mod N),
X Y is 1 + ( (N*N + (C-1) + SY*(((R-1)*R)//2)) mod N),
X position(C, R, B, m(X,Y)), % .. set value.
X make2_pow2(NextC, R, N, B).
X
X
X% 4+3k where 1+k has a solution.
X% This is the algorithm (10 as an example):
X
X/*
X Make a 3x3 and a 7x7 square.
X 1,1 2,2 3,3 _,_ _,_ _,_ _,_ _,_ _,_ _,_
X 2,3 3,1 1,2 _,_ _,_ _,_ _,_ _,_ _,_ _,_
X 3,2 1,3 2,1 _,_ _,_ _,_ _,_ _,_ _,_ _,_
X _,_ _,_ _,_ 4,4 5,5 6,6 7,7 8,8 9,9 a,a
X _,_ _,_ _,_ 5,a 6,4 7,5 8,6 9,7 a,8 4,9
X _,_ _,_ _,_ 6,9 7,a 8,4 9,5 a,6 4,7 5,8
X _,_ _,_ _,_ 7,8 8,9 9,a a,4 4,5 5,6 6,7
X _,_ _,_ _,_ 8,7 9,8 a,9 4,a 5,4 6,5 7,6
X _,_ _,_ _,_ 9,6 a,7 4,8 5,9 6,a 7,4 8,5
X _,_ _,_ _,_ a,5 4,6 5,7 6,8 7,9 8,a 9,4
X
X Rearrange the 7x7 square.
X 1,1 2,2 3,3 4,4 5,5 6,6 7,7 8,8 9,9 a,a
X 2,3 3,1 1,2 5,a 6,4 7,5 8,6 9,7 a,8 4,9
X 3,2 1,3 2,1 6,9 7,a 8,4 9,5 a,6 4,7 5,8
X a,5 9,6 8,7 7,8 _,_ _,_ _,_ _,_ _,_ _,_
X 4,6 a,7 9,8 _,_ 8,9 _,_ _,_ _,_ _,_ _,_
X 5,7 4,8 a,9 _,_ _,_ 9,a _,_ _,_ _,_ _,_
X 6,8 5,9 4,a _,_ _,_ _,_ a,4 _,_ _,_ _,_
X 7,9 6,a 5,4 _,_ _,_ _,_ _,_ 4,5 _,_ _,_
X 8,a 7,4 6,5 _,_ _,_ _,_ _,_ _,_ 5,6 _,_
X 9,4 8,5 7,6 _,_ _,_ _,_ _,_ _,_ _,_ 6,7
X
X Fill in diagonals from {1,2,3}.
X 1,1 2,2 3,3 4,4 5,5 6,6 7,7 8,8 9,9 a,a
X 2,3 3,1 1,2 5,a 6,4 7,5 8,6 9,7 a,8 4,9
X 3,2 1,3 2,1 6,9 7,a 8,4 9,5 a,6 4,7 5,8
X a,5 9,6 8,7 7,8 _,3 3,_ _,2 2,_ _,1 1,_
X 4,6 a,7 9,8 1,_ 8,9 _,3 3,_ _,2 2,_ _,1
X 5,7 4,8 a,9 _,1 1,_ 9,a _,3 3,_ _,2 2,_
X 6,8 5,9 4,a 2,_ _,1 1,_ a,4 _,3 3,_ _,2
X 7,9 6,a 5,4 _,2 2,_ _,1 1,_ 4,5 _,3 3,_
X 8,a 7,4 6,5 3,_ _,2 2,_ _,1 1,_ 5,6 _,3
X 9,4 8,5 7,6 _,3 3,_ _,2 2,_ _,1 1,_ 6,7
X
X Fill in diagonals from {4,5,6,7,8,9,a}.
X 1,1 2,2 3,3 4,4 5,5 6,6 7,7 8,8 9,9 a,a
X 2,3 3,1 1,2 5,a 6,4 7,5 8,6 9,7 a,8 4,9
X 3,2 1,3 2,1 6,9 7,a 8,4 9,5 a,6 4,7 5,8
X a,5 9,6 8,7 7,8 4,3 3,9 5,2 2,a 6,1 1,4
X 4,6 a,7 9,8 1,5 8,9 5,3 3,a 6,2 2,4 7,1
X 5,7 4,8 a,9 8,1 1,6 9,a 6,3 3,4 7,2 2,5
X 6,8 5,9 4,a 2,6 9,1 1,7 a,4 7,3 3,5 8,2
X 7,9 6,a 5,4 9,2 2,7 a,1 1,8 4,5 8,3 3,6
X 8,a 7,4 6,5 3,7 a,2 2,8 4,1 1,9 5,6 9,3
X 9,4 8,5 7,6 a,3 3,8 4,2 2,9 5,1 1,a 6,7
X
X */
X
X
Xis_factor('4+3k', N, [Na,Nb], _) :-
X Na is (N-1)//3, N is 3*Na + 1, (is_factor(_, Na, _, first) ; Na == 1),
X Nb is 2*Na+1.
X
X'regof_4+3k'(N, B, Na, Nb) :-
X write(('Divided in two squares: ' = [Na,Nb])), nl,
X write(Na), write(': '), regof(Na, Ba), % Make square a.
X write(Nb), write(': '), regof(Nb, Bb), % Make square b.
X initialize(M, _, _, N, B),
X 'move_a_4+3k'(Na, Na, Na, Ba, B), % Move square a to board.
X 'move_b_4+3k'(Nb, Nb, Nb, Na, Bb, B), % Move square b to board.
X 'diagonals_a_4+3k'(Na, N, Na, Nb, N, B), % Fill diagonals from set a.
X 'diagonals_b_4+3k'(N, Na, Nb, B), % Fill diagonals from set b.
X test_this_solution(M, N, B),
X true.
X
X'move_a_4+3k'(0, _, _, _, _) :- !.
X'move_a_4+3k'(C, 0, Na, Ba, B) :- !, NextC is C - 1,
X 'move_a_4+3k'(NextC, Na, Na, Ba, B).
X'move_a_4+3k'(C, R, Na, Ba, B) :- !, NextR is R - 1,
X position(C, R, Ba, P), position(C, R, B , P),
X 'move_a_4+3k'(C, NextR, Na, Ba, B).
X
X'move_b_4+3k'(0, _, _, _, _, _) :- !.
X'move_b_4+3k'(Cb, 0, Nb, Na, Bb, B) :- !, NextCb is Cb - 1,
X 'move_b_4+3k'(NextCb, Nb, Nb, Na, Bb, B).
X'move_b_4+3k'(Cb, Rb, Nb, Na, Bb, B) :- !, NextRb is Rb - 1,
X position(Cb, Rb, Bb, m(Xb,Yb)),
X 'convert_cr_4+3k'(Cb, Rb, Na, C, R), X is Xb+Na, Y is Yb+Na,
X position(C, R, B, m(X,Y)),
X 'move_b_4+3k'(Cb, NextRb, Nb, Na, Bb, B).
X
X'convert_cr_4+3k'(Cb, Rb, Na, C, R) :- Rb < Na+1,
X C is Cb + Na, R is Rb.
X'convert_cr_4+3k'(Cb, Rb, Na, C, R) :- Rb =:= Na+1,
X C is Cb + Na, R is C.
X'convert_cr_4+3k'(Cb, Rb, Na, C, R) :- Rb > Na+1,
X C is (2*Na+1) - (Rb-1), R is Cb + Na.
X
X'diagonals_a_4+3k'(0, _, _, _, _, _) :- !.
X'diagonals_a_4+3k'(XY, C, Na, Nb, N, B) :- C =< Na, !, NextXY is XY - 1,
X 'diagonals_a_4+3k'(NextXY, N, Na, Nb, N, B).
X'diagonals_a_4+3k'(XY, C, Na, Nb, N, B) :- !, NextC is C - 1,
X Rx is Na + 1 + ((Nb + 2*(XY-1) + (C-1) - Na + 1) mod Nb),
X Ry is Na + 1 + ((Nb + 2*(XY-1) + (C-1) - Na + 2) mod Nb),
X position(C, Rx, B, m(XY,_)), position(C, Ry, B, m(_,XY)),
X 'diagonals_a_4+3k'(XY, NextC, Na, Nb, N, B).
X
X'diagonals_b_4+3k'(CR, Na, _, _) :- CR =< Na, !.
X'diagonals_b_4+3k'(CR, Na, Nb, B) :- NextCR is CR - 1,
X position(CR, CR, B, m(X,Y)),
X 'short_diagonals_b_4+3k'(Na, CR, X, Y, Na, Nb, B),
X 'diagonals_b_4+3k'(NextCR, Na, Nb, B).
X
X'short_diagonals_b_4+3k'(0, _, _, _, _, _, _) :- !.
X'short_diagonals_b_4+3k'(D, CR, X, Y, Na, Nb, B) :- NextD is D - 1,
X Cx is Na + 1 + ((Nb + (CR-D) - (Na+1)) mod Nb), Ry is Cx,
X Rx is Na + 1 + ((Nb + (CR+D) - (Na+1)) mod Nb), Cy is Rx,
X position(Cx, Rx, B, m(X,_)), position(Cy, Ry, B, m(_,Y)),
X 'short_diagonals_b_4+3k'(NextD, CR, X, Y, Na, Nb, B).
X
X
X% -- Factorizeable. --
X% If you can factorize the size in known solutions then you can
X% use the solutions recursively to get an answer.
X
Xis_factor(factor, 1, Fs, _) :- !, Fs = [].
Xis_factor(factor, N, [F|Fs], first) :- N > 1,
X get_number(N, 2, -1, F), NextN is N // F, N is NextN * F, F > 1,
X ((N == F) -> T = recursive ; T = first),
X is_factor(_, F, _, T),
X is_factor(factor, NextN, Fs, first).
X
Xget_factors(N, Fs) :- is_factor(factor, N, Fs, first).
Xget_factors(N, R, Type) :-
X is_factor(Type, N, Fs, first),
X ((Type == factor) -> Fs = [_,_|_], sorted(Fs), R = Fs ; R = [N]).
X
Xregof_factor(N, B, [N1|Ns]) :-
X write('Factors are: '), write([N1|Ns]), nl,
X regof_for_each_factor([N1|Ns], [B1|Bs]), % Solve for all factors ..
X combine_all(Ns, Bs, N1, B1, B), % .. and combine them.
X initialize(Men, _, _, N, _),
X test_this_solution(Men, N, B).
X
Xregof_for_each_factor([], []).
Xregof_for_each_factor([N|Ns], [B|Bs]) :-
X write(N), write(': '),
X regof(N, B),
X regof_for_each_factor(Ns, Bs).
X
Xcombine_all([], _, _, B, B).
Xcombine_all([N|Ns], [B|Bs], Nin, Bin, Ball) :-
X Nout is N * Nin, functor(Bout, b, Nout), make_board(Nout, Nout, Bout),
X combine_two(N, N, N, Nin, Nin, Nin, Nout, B, Bin, Bout),
X combine_all(Ns, Bs, Nout, Bout, Ball).
X
Xcombine_two(0, _, _, _, _, _, _, _, _, _) :- !.
Xcombine_two(C, 0, N, Cin, Rin, Nin, Nout, B, Bin, Bout) :- !, NextC is C - 1,
X combine_two(NextC, N, N, Cin, Rin, Nin, Nout, B, Bin, Bout).
Xcombine_two(C, R, N, 0, Rin, Nin, Nout, B, Bin, Bout) :- !, NextR is R - 1,
X combine_two(C, NextR, N, Nin, Rin, Nin, Nout, B, Bin, Bout).
Xcombine_two(C, R, N, Cin, 0, Nin, Nout, B, Bin, Bout) :- !, NextCin is Cin - 1,
X combine_two(C, R, N, NextCin, Nin, Nin, Nout, B, Bin, Bout).
Xcombine_two(C, R, N, Cin, Rin, Nin, Nout, B, Bin, Bout) :- NextRin is Rin - 1,
X position(C, R, B, m(X,Y)),
X position(Cin, Rin, Bin, m(Xin,Yin)),
X Rout is N*(Rin-1) + R, Cout is N*(Cin-1) + C,
X Xout is N*(Xin-1) + X, Yout is N*(Yin-1) + Y,
X position(Cout, Rout, Bout, m(Xout,Yout)),
X combine_two(C, R, N, Cin, NextRin, Nin, Nout, B, Bin, Bout).
X
X
X
X% -- Unknown (Currently some 2*odd). --
X
X/* As naming is arbitrary you can start with first row as:
X 1/1, 2/2, 3/3, 4/4, 5/5, 6/6.
X
X As the order of rows is of no moment you can start with the first
X column as:
X 1/1,
X 2/_,
X 3,_,
X 4/_,
X 5/_,
X 6/_.
X
X As you always can swap columns/rows and rename types you can start with:
X 1/1, 2/2, 3/3, 4/4, 5/5, 6/6
X 2/6, _/_, _/_, _/_, _/_, _/_
X 3/5, _/_, _/_, _/_, _/_, _/_
X 4/_, _/_, _/_, _/_, _/_, _/_
X 5/_, _/_, _/_, _/_, _/_, _/_
X 6/_, _/_, _/_, _/_, _/_, _/_
X proof: You can choose 2/6 because /3 -> /6 are interchangeable.
X . Then you can choose 3/5 because /4 -> /5 are interchangeable. */
X
Xregof_unknown(N, Board) :-
X initialize(Men, Xs, Ys, N, Board),
X first_row(Men, Xs, Ys, N, N, Board, M2),
X Split is N//2 + 1,
X first_col_det(M2, Xs, Ys, N, 2, Split, Board, M3),
X !,
X first_col_nondet(M3, Xs, Ys, N, Split, Board, M4),
X search(M4, Xs, Ys, Board),
X write_nice(1, 1, N, Board).
X
Xfirst_row(M1, Xs, Ys, N, C, B, M2) :- C > 0, NextC is C - 1,
X M = m(C,C), % (C is nonvar)
X delete(M, M1, M3), % Fetch one man (C,C) ..
X put_one_man(M, Xs, Ys, B, p(C,1)), % .. and put him at (C,1).
X first_row(M3, Xs, Ys, N, NextC, B, M2).
Xfirst_row(M, _, _, _, 0, _, M).
X
Xfirst_col_det(M1, Xs, Ys, N, R, S, B, M2) :- R < S, NextR is R + 1,
X Y is N - R + 2,
X M = m(R,Y), % (R and Y is nonvar)
X delete(M, M1, M3), % Fetch one man (R,Y) ..
X put_one_man(M, Xs, Ys, B, p(1,R)), % .. and put him at (1,R).
X first_col_det(M3, Xs, Ys, N, NextR, S, B, M2).
Xfirst_col_det(M, _, _, _, R, S, _, M) :- R > S - 1.
X
Xfirst_col_nondet(M1, Xs, Ys, N, R, B, M2) :- R =< N, NextR is R + 1,
X M = m(R,_), % (R is nonvar, Y is var)
X deleteP(M, M1, M3), % Fetch one man (R,Y) ..
X put_one_man(M, Xs, Ys, B, p(1,R)), % .. and put him at (1,R).
X first_col_nondet(M3, Xs, Ys, N, NextR, B, M2).
Xfirst_col_nondet(M, _, _, N, R, _, M) :- R > N.
X
X
X% -- Naive algorithm, initialization and standard search routine. --
X
Xregof_naive(N, Board) :-
X initialize(Men, Xs, Ys, N, Board),
X search(Men, Xs, Ys, Board),
X write_nice(1, 1, N, Board).
X
Xinitialize(Men, Xs, Ys, N, Board) :-
X functor(Board, b, N), % Make columns and ..
X make_board(N, N, Board), % .. rows of board.
X men(N, N, N, Men), % Make a list of all men.
X functor(Xs, x, N), set_up(N, N, Xs), % Make lists of free ..
X functor(Ys, y, N), set_up(N, N, Ys), % .. cols and rows.
X ! /* To cut down at environment size */.
X
Xmake_board(0, _, _).
Xmake_board(C, N, Board) :- C > 0, NextC is C - 1,
X arg(C, Board, RR), functor(RR, r, N),
X make_board(NextC, N, Board).
X
Xmen(_, 0, _, []) :- !.
Xmen(0, Y, N, Ms) :- !, NextY is Y - 1,
X men(N, NextY, N, Ms).
Xmen(X, Y, N, [m(X,Y)|Ms]) :- NextX is X - 1,
X men(NextX, Y, N, Ms).
X
Xset_up(XY, N, F) :- XY > 0, NextXY is XY - 1,
X arg(XY, F, free(C,R)),
X empty_list(N, C), empty_list(N, R),
X set_up(NextXY, N, F).
Xset_up(0, _, _).
X
Xsearch([], _, _, _). % Until last man ..
Xsearch([M|Ms], Xs, Ys, B) :- % .. try to put him on board.
X put_one_man(M, Xs, Ys, B, p(_,_)),
X search(Ms, Xs, Ys, B).
X
Xput_one_man(m(X,Y), Xs, Ys, B, p(C,R)) :-
X arg(X, Xs, free(XC, XR)), % Fetch list of free rows ..
X arg(Y, Ys, free(YC, YR)), % .. and cols for this man.
X pair_member(m(X,Y), XC, YC, 1, C), % Fetch a col.
X pair_member(m(X,Y), XR, YR, 1, R), % Fetch a row.
X position(C, R, B, m(X,Y)). % Can I put him here?
X
Xposition(C, R, B, P) :- arg(R, B, RR), arg(C, RR, P).
X
X
X% -- Testing of solutions --
X
Xtest_this_solution(Men, N, Board) :-
X write_nice(1, 1, N, Board),
X (i_shall_test -> test(Men, N, Board) % Test only on demand!
X ; write('Do not test'), nl).
X
Xtest(Ms, N, B) :-
X write('testing ...'), nl,
X sort(Ms, SortedMs),
X test_men(SortedMs, N, B, Flag), % Test if all men on board.
X numbered_list(N, L), sort(L, SortedL),
X test_cols(N, N, N, B, SortedL, [], [], Flag), % Test if columns and ..
X test_rows(N, N, N, B, SortedL, [], [], Flag), % .. rows are right.
X var(Flag), !, write('OK'), nl.
Xtest(_, _, _) :-
X write('... found not OK, what a mistake!'), nl, fail.
X
Xtest_men(Ms, N, B, Flag) :-
X which_is_on_board(N, N, N, B, W),
X test_lists(Ms, W, men, Flag).
X
Xtest_lists(SortedOld, New, Com, Flag) :-
X sort(New, SortedNew),
X ((SortedOld == SortedNew) -> true
X ; write(Com), write(' is wrong.'), nl, Flag = nonvar).
X
Xwhich_is_on_board(0, _, _, _, []) :- !.
Xwhich_is_on_board(C, 0, N, B, W) :- !, NextC is C - 1,
X which_is_on_board(NextC, N, N, B, W).
Xwhich_is_on_board(C, R, N, B, W) :- NextR is R - 1,
X position(C, R, B, m(X,Y)),
X ((var(X) ; var(Y)) -> NextW = W ; [m(X,Y)|NextW] = W),
X which_is_on_board(C, NextR, N, B, NextW).
X
Xtest_cols(0, _, _, _, _, _, _, _) :- !.
Xtest_cols(C, 0, N, B, L, Xs, Ys, Flag) :- !, NextC is C - 1,
X test_lists(L, Xs, xcol(C), Flag),
X test_lists(L, Ys, ycol(C), Flag),
X test_cols(NextC, N, N, B, L, [], [], Flag).
Xtest_cols(C, R, N, B, L, Xs, Ys, Flag) :- !, NextR is R - 1,
X position(C, R, B, m(X,Y)),
X test_cols(C, NextR, N, B, L, [X|Xs], [Y|Ys], Flag).
X
Xtest_rows(0, _, _, _, _, _, _, _) :- !.
Xtest_rows(R, 0, N, B, L, Xs, Ys, Flag) :- !, NextR is R - 1,
X test_lists(L, Xs, xrow(R), Flag),
X test_lists(L, Ys, yrow(R), Flag),
X test_rows(NextR, N, N, B, L, [], [], Flag).
Xtest_rows(R, C, N, B, L, Xs, Ys, Flag) :- !, NextC is C - 1,
X position(C, R, B, m(X,Y)),
X test_rows(R, NextC, N, B, L, [X|Xs], [Y|Ys], Flag).
X
X
X% -- Member and other help stuff. --
X
Xget_number(Cnt, _, _, Cnt).
Xget_number(Cnt, Stop, Incr, Num) :- Cnt \== Stop, NextCnt is Cnt + Incr,
X get_number(NextCnt, Stop, Incr, Num).
X
Xpair_member(X, L1, L2, N1, N2) :- var(N2), !, % Parallel or sequential?
X pair_memberP(X, L1, L2, N1, N2).
Xpair_member(X, L1, L2, N1, N2) :-
X pair_memberS(X, L1, L2, N1, N2).
X
X:- parallel pair_memberP/5.
Xpair_memberP(X, [X|_], [X|_], N ,N).
Xpair_memberP(X, [_|T1], [_|T2], Cnt, N) :- NextCnt is Cnt + 1,
X pair_memberP(X, T1, T2, NextCnt, N).
X
Xpair_memberS(X, [X|_], [X|_], N ,N).
Xpair_memberS(X, [_|T1], [_|T2], Cnt, N) :- NextCnt is Cnt + 1,
X pair_memberS(X, T1, T2, NextCnt, N).
X
Xdelete(m(X,Y), L1, L2) :- (var(X) ; var(Y)), !, % Parallel or sequential?
X deleteP(m(X,Y), L1, L2).
Xdelete(M, L1, L2) :-
X deleteS(M, L1, L2).
X
X:- parallel deleteP/3.
XdeleteP(X, [X|T], T).
XdeleteP(X, [H|T1], [H|T2]) :- deleteP(X, T1, T2).
X
XdeleteS(X, [X|T], T).
XdeleteS(X, [H|T1], [H|T2]) :- deleteS(X, T1, T2).
X
Xempty_list(N, [_|T]) :- N > 0, NextN is N - 1, empty_list(NextN, T).
Xempty_list(0, []).
X
Xnumbered_list(N, [N|T]) :- N > 0, NextN is N - 1, numbered_list(NextN, T).
Xnumbered_list(0, []).
X
Xsorted(L) :- sort(L, L).
X
Xwrite_nice(C, R, N, B) :- % Locking if parallel!
X (predicate_property(bc_lock(_), _) -> bc_lock(5) ; true),
X write_nice2(C, R, N, B),
X (predicate_property(bc_lock(_), _) -> bc_unlock(5) ; true).
X
Xwrite_nice2(_, R, N, _) :- R > N, !, nl.
Xwrite_nice2(C, R, N, B) :- C > N, !, nl, NextR is R + 1,
X write_nice2(1, NextR, N, B).
Xwrite_nice2(C, R, N, B) :- NextC is C + 1,
X position(C, R, B, m(X,Y)), write_nice4(X, Y),
X write_nice2(NextC, R, N, B).
X
Xwrite_nice3(N) :- var(N), !, write('_').
Xwrite_nice3(N) :- (N > 9, N < 36), !,
X C is 0'a + N - 10, name(A, [C]), write(A).
Xwrite_nice3(N) :- (N > 35, N < 62), !,
X C is 0'A + N - 36, name(A, [C]), write(A).
Xwrite_nice3(N) :- write(N).
X
Xwrite_nice4(X, Y) :- write_nice3(X), write(','), write_nice3(Y), write(' ').
SHAR_EOF
chmod 0664 regof.pl || echo "restore of regof.pl fails"
exit 0
--
Roland Karlsson
SICS, PO Box 1263, S-164 28 KISTA, SWEDEN Internet: roland@sics.se
Tel: +46 8 752 15 40 Ttx: 812 61 54 SICS S Fax: +46 8 751 72 30