Re^3: Seven by seven farming puzzle

And this code below solves the six by six puzzle the pure constraint programming way.

Notice how it first posts all constraints deterministically (without branching), and then the final labeling is the only thing that branches.

Runs in SWI prolog in 489 seconds (on a fast computer) and prints the correct answer.

% Six by six chessboard problem, see "http://www.perlmonks.org/?node_i
+d=821272"
% Finite domain constraint programming variaton

:- use_module(library(clpfd)).

row(R) :-
    length(R, 6), 
    R ins 0 .. 1,
    row1(R).
    
row1([X0, X1, X2, X3, X4, X5]) :-
    X0 + X1 + X2 + X3 + X4 + X5 #= 3.

/*
differ([X0, X1, X2, X3, X4, X5], [Y0, Y1, Y2, Y3, Y4, Y5], P) :-
    (X0 #\= Y0) #\/ (X1 #\= Y1) #\/ (X2 #\= Y2) #\/ ... % nah, I'll ty
+po this somewhere
*/
vdiffer(Xs, Ys) :-
    zip(lambda(arg(X, Y, N), N = (X #\= Y)), Xs, Ys, Ns),
    foldrz(lambda(arg(M, N, Q), Q = (M #\/ N)), 0, Ns, P),
    P.

pairwise_vdiffer([]).
pairwise_vdiffer([H | T]) :-
    for(lambda_close(H, Hi, arg(K), vdiffer(Hi, K)), T),
    pairwise_vdiffer(T).

boardp(B) :-
    length(B, 6),
    for(lambda(arg(R), row(R)), B), 
    transpose(B, BT),
    for(lambda(arg(C), row1(C)), BT),
    pairwise_vdiffer(B),
    pairwise_vdiffer(BT).

board(B) :- 
    boardp(B), 
    concat(B, Bfl), 
    [R0 | _] = B,
    labeling([leftmost], R0),
    write(board_debug0([R0])), nl,
    labeling([leftmost], Bfl).

nboard(N) :-
    findall(x, board(_B), L),
    length(L, N).

main :-
    nboard(N), write(N), nl.    


/*
[download]

*/

/*
Homegrown functional programming library for prolog
*/

:- use_module(library(lists)).

% Higher order programming

fcall(Fn, A) :- 
    copy_term(Fn, lambda(A, G)), !, call(G).
fcall(lambda_close(D, C, P, G), A) :- 
    copy_term(rec(C, P, G), rec(V, Pc, Gc)), V = D, Pc = A, call(Gc).

% List functions, higher order

map(_, [], []).
map(Fn, [Ah | At], [Bh | Bt]) :-
    fcall(Fn, arg(Ah, Bh)), map(Fn, At, Bt).

for(Fn, A) :-
    map(lambda_close(Fn, Fc, arg(X, _), fcall(Fc, arg(X))), A, _).

zip(Fn, A, B, C) :- 
    map(lambda(arg(X, rec(X, _)), true), A, P),
    map(lambda(arg(Y, rec(_, Y)), true), B, P),
    map(lambda_close(Fn, Fc, arg(rec(X, Y), Z), fcall(Fc, arg(X, Y, Z)
+)), P, C).

any(Fn, [X | _]) :- fcall(Fn, arg(X)).
any(Fn, [_ | R]) :- any(Fn, R).

first(Fn, L, R) :- 
    once(any(lambda_close(rec(Fn, Ro), rec(Fni, Ri), arg(X), (fcall(Fn
+i, arg(X)), Ri = X)), L)),
    R = Ro.

foldrs(_, U, [], U).
foldrs(Fn, U, [H | T], R) :- 
    foldrs(Fn, U, T, M), fcall(Fn, arg(H, M, R)).

foldrz(_, U, [], U).
foldrz(Fn, U, [H | T], R) :-
    fcall(Fn, arg(H, M, R)), foldrz(Fn, U, T, M).

foldl(_, U, [], U).
foldl(Fn, U, [H | T], R) :- 
    fcall(Fn, arg(U, H, M)), foldl(Fn, M, T, R).

filter(Fn, L, R) :-
    foldrz(
        lambda_close(Fn, Fni, arg(X, M, N), (fcall(Fni, arg(X)) -> N =
+ [X | M] ; N = M)), 
    [], L, R).

unfoldr(Fn, U, [H | T]) :- 
    fcall(Fn, arg(U, H, M)), !, unfoldr(Fn, M, T).
unfoldr(_, _, []).

% List functions, first order

concat(Ls, C) :- foldrz(lambda(arg(X,M,R), append(X,M,R)), [], Ls, C).

transpose([], []).
transpose(Ls, Rs) :- 
    [L1 | _] = Ls, map(lambda(arg(_, []), true), L1, Fi), 
    foldrz(
        lambda(arg(L, M, R), zip(lambda(arg(X, Y, [X | Y]), true), L, 
+M, R)), 
    Fi, Ls, Rs).

splitat(N, L, H, T) :- length(H, N), append(H, T, L), !.
splitat(N, L, L, []) :- length(L, M), M < N.

take(N, L, H) :- splitat(N, L, H, _).

drop(N, L, T) :- splitat(N, L, _, T).

iota(N, L) :- unfoldr(lambda(arg(H, H, F), (H < N, F is H + 1)), 0, L)
+.

slice(N, L, R) :-
    unfoldr(lambda(arg(C, H, T), (C = [_ | _], splitat(N, C, H, T))), 
+L, R).

infixes(N, L, R) :-
    length(H, N), append(H, _, L) ->
        R = [H | R1], [_ | L1] = L, infixes(N, L1, R1) ;
        length(L, M), M < N, R = [].

/* Examples.
| ?- zip(lambda(arg(X, Y, Z), Z is X * Y), [3,1,4], [10, 100, 1000], R
+).
R = [30,100,4000] ? ;
no
| ?- map(lambda_close(E, V, arg(X, V*X), true), [A, B, A+B], R).
R = [E*A,E*B,E*(A+B)] ? ;
no
| ?- any(lambda_close(R, Rho, arg(X), (5 < X, Rho = X)), [3,1,4,1,5,9,
+2,6]).
R = 9 ? ;
R = 6 ? ;
no
| ?- foldrz(lambda(arg(H, M, x(H, M)), true), 2, [3, 8, 5], R).
R = x(3,x(8,x(5,2))) ? ;
no
| ?- foldl(lambda(arg(M, H, x(M, H)), true), 2, [3, 8, 5], R).
R = x(x(x(2,3),8),5) ? ;
no
| ?- foldl(lambda(arg(M, H, R), R is M + H), 2, [3, 8, 5], R).
R = 18 ? ;
no
*/


% END
[download]

Comment on Re^3: Seven by seven farming puzzle Select or Download Code

Replies are listed 'Best First'.
Re^4: Seven by seven farming puzzle by salva (Canon) on Feb 07, 2010 at 11:15 UTC
The solution for the 7x7 problem using my combination of constraints and backtracking (I prefer to see it as just a custom labeling algorithm). The only optimization used is forcing the last five rows to be in lexicographic order. :- use_module(library(clpfd)). different_lists([A\|TA], [B\|TB]) :- ( A #\= B ; A #= B, different_lists(TA, TB) ). all_different_lists([]). all_different_lists([A\|T]) :- all_different_lists(T, A), all_different_lists(T). all_different_lists([], _). all_different_lists([B\|T], A) :- different_lists(A, B), all_different_lists(T, A). list_sequence([]). list_sequence([H\|T]) :- list_sequence(T, H). list_sequence([], _). list_sequence([B\|T], A) :- list_lt(A, B), list_sequence(T, B). list_lt([A\|TA], [B\|TB]) :- ( A #< B ; A #= B, list_lt(TA, TB) ). solve([Row1, Row2, Row3, Row4, Row5, Row6, Row7]) :- Row1 = [A1, A2, A3, A4, A5, A6, A7], Row2 = [B1, B2, B3, B4, B5, B6, B7], Row3 = [C1, C2, C3, C4, C5, C6, C7], Row4 = [D1, D2, D3, D4, D5, D6, D7], Row5 = [E1, E2, E3, E4, E5, E6, E7], Row6 = [F1, F2, F3, F4, F5, F6, F7], Row7 = [G1, G2, G3, G4, G5, G6, G7], Col1 = [A1, B1, C1, D1, E1, F1, G1], Col2 = [A2, B2, C2, D2, E2, F2, G2], Col3 = [A3, B3, C3, D3, E3, F3, G3], Col4 = [A4, B4, C4, D4, E4, F4, G4], Col5 = [A5, B5, C5, D5, E5, F5, G5], Col6 = [A6, B6, C6, D6, E6, F6, G6], Col7 = [A7, B7, C7, D7, E7, F7, G7], global_cardinality(Row1, [0-2, 1-2, 2-3]), global_cardinality(Row2, [0-2, 1-2, 2-3]), global_cardinality(Row3, [0-2, 1-2, 2-3]), global_cardinality(Row4, [0-2, 1-2, 2-3]), global_cardinality(Row5, [0-2, 1-2, 2-3]), global_cardinality(Row6, [0-2, 1-2, 2-3]), global_cardinality(Row7, [0-2, 1-2, 2-3]), global_cardinality(Col1, [0-2, 1-2, 2-3]), global_cardinality(Col2, [0-2, 1-2, 2-3]), global_cardinality(Col3, [0-2, 1-2, 2-3]), global_cardinality(Col4, [0-2, 1-2, 2-3]), global_cardinality(Col5, [0-2, 1-2, 2-3]), global_cardinality(Col6, [0-2, 1-2, 2-3]), global_cardinality(Col7, [0-2, 1-2, 2-3]), all_different_lists([Row3, Row4, Row5, Row6, Row7], Row1), all_different_lists([Row3, Row4, Row5, Row6, Row7], Row2), list_sequence([Row3, Row4, Row5, Row6, Row7]), all_different_lists([Col1, Col2, Col3, Col4, Col5, Col6, Col7] +), label([A1, A2, A3, A4, A5, A6, A7, B1, B2, B3, B4, B5, B6, B7, C1, C2, C3, C4, C5, C6, C7, D1, D2, D3, D4, D5, D6, D7, E1, E2, E3, E4, E5, E6, E7, F1, F2, F3, F4, F5, F6, F7, G1, G2, G3, G4, G5, G6, G7]). solve(R1, R2, L) :- findall(-, solve([R1, R2 \| _]), All), length(All, L). tryme([]). tryme([H\|T]) :- H = [R1, R2], write('searching...'), nl, time(solve(R1, R2, L)), L120 is L * 120, write(solve(R1, R2, L, L120)), nl, tryme(T). tryme :- tryme([[[2, 1, 0, 0, 2, 2, 1], [0, 2, 2, 1, 1, 0, 2]], [[2, 0, 0, 2, 2, 1, 1], [2, 0, 1, 2, 2, 1, 0]], [[2, 1, 0, 1, 2, 0, 2], [2, 2, 1, 1, 2, 0, 0]], [[2, 1, 0, 1, 2, 2, 0], [1, 2, 0, 2, 1, 2, 0]], [[0, 2, 0, 1, 2, 1, 2], [1, 2, 0, 2, 1, 0, 2]], [[2, 0, 0, 1, 2, 2, 1], [2, 1, 1, 0, 2, 2, 0]], [[1, 2, 2, 0, 0, 2, 1], [2, 0, 1, 0, 1, 2, 2]], [[2, 2, 1, 1, 0, 2, 0], [1, 0, 2, 1, 2, 0, 2]], [[2, 0, 1, 1, 2, 0, 2], [0, 1, 2, 2, 0, 1, 2]], [[0, 2, 2, 0, 1, 2, 1], [1, 0, 1, 2, 2, 2, 0]]]). [download] running it (on my several years old computer)... % 813,486,620 inferences, 296.670 CPU in 298.033 seconds (100% CPU, 27 +42059 Lips) solve([2, 1, 0, 0, 2, 2, 1], [0, 2, 2, 1, 1, 0, 2], 40916, 4909920) searching... % 76,087,028 inferences, 25.970 CPU in 26.092 seconds (100% CPU, 29298 +05 Lips) solve([2, 0, 0, 2, 2, 1, 1], [2, 0, 1, 2, 2, 1, 0], 4230, 507600) searching... % 126,148,718 inferences, 43.040 CPU in 43.119 seconds (100% CPU, 2930 +965 Lips) solve([2, 1, 0, 1, 2, 0, 2], [2, 2, 1, 1, 2, 0, 0], 6049, 725880) searching... % 177,009,601 inferences, 60.300 CPU in 60.680 seconds (99% CPU, 29354 +83 Lips) solve([2, 1, 0, 1, 2, 2, 0], [1, 2, 0, 2, 1, 2, 0], 8372, 1004640) searching... % 392,855,329 inferences, 132.700 CPU in 133.397 seconds (99% CPU, 296 +0477 Lips) solve([0, 2, 0, 1, 2, 1, 2], [1, 2, 0, 2, 1, 0, 2], 11227, 1347240) ... [download] So it is not too bad, specially considering that the program is almost a direct translation of the problem wording to prolog, fully declarative. Also, SWI-Prolog is not exactly the fastest prolog available and its clpfd module is not exactly the fastest CLP(FD) library either... I would not be surprised if some other prolog could run the same program more than an order of magnitude faster! BTW, it requires the git version of SWI-Prolog to run... there was a bug on the `global_cardinality/2` constraint.	[reply] [d/l] [select]
Re^5: Seven by seven farming puzzle by salva (Canon) on Feb 10, 2010 at 12:38 UTC
Also, SWI-Prolog is not exactly the fastest prolog available and its clpfd module is not exactly the fastest CLP(FD) library either... I would not be surprised if some other prolog could run the same program more than an order of magnitude faster! Here it goes the same program adapted for GNU Prolog. In my machine in runs on five seconds, finding the solutions for the ten pairs of input rows! different_lists([A\|TA], [B\|TB]) :- ( A #\= B ; A #= B, different_lists(TA, TB) ). all_different_lists([]). all_different_lists([A\|T]) :- all_different_lists(T, A), all_different_lists(T). all_different_lists([], _). all_different_lists([B\|T], A) :- different_lists(A, B), all_different_lists(T, A). list_sequence([]). list_sequence([H\|T]) :- list_sequence(T, H). list_sequence([], _). list_sequence([B\|T], A) :- list_lt(A, B), list_sequence(T, B). list_lt([A\|TA], [B\|TB]) :- ( A #< B ; A #= B, list_lt(TA, TB) ). domain_from_global_cardinality([], []). domain_from_global_cardinality([Val-_\|ET], [Val\|DT]) :- domain_from_global_cardinality(ET, DT). global_cardinality(L, Exactly) :- domain_from_global_cardinality(Exactly, Domain), fd_domain(L, Domain), global_cardinality1(Exactly, L). global_cardinality1([], _). global_cardinality1([Val-Rep\|T], L) :- fd_exactly(Rep, L, Val), global_cardinality1(T, L). solve([Row1, Row2, Row3, Row4, Row5, Row6, Row7]) :- Row1 = [A1, A2, A3, A4, A5, A6, A7], Row2 = [B1, B2, B3, B4, B5, B6, B7], Row3 = [C1, C2, C3, C4, C5, C6, C7], Row4 = [D1, D2, D3, D4, D5, D6, D7], Row5 = [E1, E2, E3, E4, E5, E6, E7], Row6 = [F1, F2, F3, F4, F5, F6, F7], Row7 = [G1, G2, G3, G4, G5, G6, G7], Col1 = [A1, B1, C1, D1, E1, F1, G1], Col2 = [A2, B2, C2, D2, E2, F2, G2], Col3 = [A3, B3, C3, D3, E3, F3, G3], Col4 = [A4, B4, C4, D4, E4, F4, G4], Col5 = [A5, B5, C5, D5, E5, F5, G5], Col6 = [A6, B6, C6, D6, E6, F6, G6], Col7 = [A7, B7, C7, D7, E7, F7, G7], global_cardinality(Row1, [0-2, 1-2, 2-3]), global_cardinality(Row2, [0-2, 1-2, 2-3]), global_cardinality(Row3, [0-2, 1-2, 2-3]), global_cardinality(Row4, [0-2, 1-2, 2-3]), global_cardinality(Row5, [0-2, 1-2, 2-3]), global_cardinality(Row6, [0-2, 1-2, 2-3]), global_cardinality(Row7, [0-2, 1-2, 2-3]), global_cardinality(Col1, [0-2, 1-2, 2-3]), global_cardinality(Col2, [0-2, 1-2, 2-3]), global_cardinality(Col3, [0-2, 1-2, 2-3]), global_cardinality(Col4, [0-2, 1-2, 2-3]), global_cardinality(Col5, [0-2, 1-2, 2-3]), global_cardinality(Col6, [0-2, 1-2, 2-3]), global_cardinality(Col7, [0-2, 1-2, 2-3]), all_different_lists([Row3, Row4, Row5, Row6, Row7], Row1), all_different_lists([Row3, Row4, Row5, Row6, Row7], Row2), list_sequence([Row3, Row4, Row5, Row6, Row7]), all_different_lists([Col1, Col2, Col3, Col4, Col5, Col6, Col7] +), fd_labeling([A1, A2, A3, A4, A5, A6, A7, B1, B2, B3, B4, B5, B6, B7, C1, C2, C3, C4, C5, C6, C7, D1, D2, D3, D4, D5, D6, D7, E1, E2, E3, E4, E5, E6, E7, F1, F2, F3, F4, F5, F6, F7, G1, G2, G3, G4, G5, G6, G7]). time(G) :- cpu_time(Start), call(G), cpu_time(End), S is End - Start, write(time(goal(G), ms(S))), nl. solve(R1, R2, L) :- findall(-, solve([R1, R2 \| _]), All), length(All, L). tryme([]). tryme([H\|T]) :- H = [R1, R2], write('searching...'), nl, time(solve(R1, R2, L)), L120 is L * 120, write(solve(R1, R2, L, L120)), nl, tryme(T). tryme :- tryme([[[2, 1, 0, 0, 2, 2, 1], [0, 2, 2, 1, 1, 0, 2]], [[2, 0, 0, 2, 2, 1, 1], [2, 0, 1, 2, 2, 1, 0]], [[2, 1, 0, 1, 2, 0, 2], [2, 2, 1, 1, 2, 0, 0]], [[2, 1, 0, 1, 2, 2, 0], [1, 2, 0, 2, 1, 2, 0]], [[0, 2, 0, 1, 2, 1, 2], [1, 2, 0, 2, 1, 0, 2]], [[2, 0, 0, 1, 2, 2, 1], [2, 1, 1, 0, 2, 2, 0]], [[1, 2, 2, 0, 0, 2, 1], [2, 0, 1, 0, 1, 2, 2]], [[2, 2, 1, 1, 0, 2, 0], [1, 0, 2, 1, 2, 0, 2]], [[2, 0, 1, 1, 2, 0, 2], [0, 1, 2, 2, 0, 1, 2]], [[0, 2, 2, 0, 1, 2, 1], [1, 0, 1, 2, 2, 2, 0]]]). [download]	[reply] [d/l]
Re^5: Seven by seven farming puzzle by ambrus (Abbot) on Feb 14, 2010 at 16:46 UTC
I ran this with Sicstus prolog 3, and wow it was fast. The ten cases together took only 68 seconds. (That's on a 2.4 GHz pentium 4 machine; and about 140 seconds on a slower 992 MHz pentium 3 machine with the newer Sicstus 4. Gave the correct results in both cases. I can't compare the speed with SWI prolog for I'm lazy to install a newer SWI, and I don't even have any SWI prolog and Sicstus running on the same machine.) Read more... (325 Bytes) I'm surprised how fast it is. I know that the optimization you mention (the one in the first spoiler block) helps a lot, and also that the constraint programming nature makes it so that the last row is always filled in and there aren't too many possibilities to iterate over in the sixth row either, and that also counts a great deal in time. Still, I didn't think it would be so fast after the results with my perl programs.	[reply] [d/l]
Re^5: Seven by seven farming puzzle by ambrus (Abbot) on Feb 14, 2010 at 18:06 UTC
I replaced your different_lists and list_sequence with pure constraint versions (instead of your nondeterministic versions), and the changed program runs in practically the same amount of time. Thus, even if I don't understand it, your custom labeling algorithm works well. Read more... (545 Bytes) If, however, you replace only list_sequence but keep your different_lists proceduce, the program gets somewhat faster (shows how the optimized library that comes with Sicstus is better than the proceduces I cobble together).	[reply] [d/l] [select]