in reply to Seven by seven farming puzzle

Inspired by SWI-Prolog is a *blindingly* fast application component., I have done it using SWI-Prolog:
:- use_module(library(clpfd)). different_lists([A|TA], [B|TB]) :- ( 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). 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], Row1 = [0, 0, 1, 1, 2, 2, 2], Col1 = [0, 0, 1, 1, 2, 2, 2], 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(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([Row1, Row2, 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]). :- writeln('searching...'). :- time(solve(S)), writeln(S).
running it:
?- [g]. searching... % 9,048,776 inferences, 5.100 CPU in 5.109 seconds (100% CPU, 1774270 +Lips) [[0, 0, 1, 1, 2, 2, 2], [0, 2, 1, 2, 0, 1, 2], [1, 1, 0, 0, 2, 2, 2], +[1, 2, 0, 0, 2, 2, 1], [2, 0, 2, 2, 0, 1, 1], [2, 1, 2, 2, 1, 0, 0], +[2, 2, 2, 1, 1, 0, 0]] % g compiled 5.10 sec, 832 bytes true.

So, in half an hour I have been able to craft a program that solves it in 5 seconds... not too bad ;-)

BTW, the only optimization I have done is fixing the first row and the first column as [0, 0, 1, 1, 2, 2, 2].

update: oops, wrong problem...

Replies are listed 'Best First'.
Re^2: Seven by seven farming puzzle
by salva (Canon) on Feb 04, 2010 at 12:42 UTC

      Okay, so after the criticism of your code I guess I must show an example of what I mean.

      The code below solves the six by six problem, for as I said in the original node, the seven by seven is not so easy.

      It's quite straightforward brute forcing: it tries all possibilities. It is not using the trick in the first spoiler block (which would make it faster). After filling each row, it checks that there are no two identical rows. Also, instead of iterating over all possible last rows, we compute its elements so that the columns are right. (In addittion, we don't need to check if the last row is right, for if each column and each other row has three white and three black squares each then the last column does too automatically.) A similar trick is used for the fifth row: instead of iterating through all possible fifth rows, we fill the fifth cell of each column in such a way that the column doesn't have more than three white or more than three black cells, and then check if the fifth row we've got is correct. We check that there are no two identical columns at the end, after filling the whole table.

      The code runs in SWI prolog in 107 seconds (on a fast computer), and produces the correct answer (194400). (Start with the goal main; some debugging lines are printed to show progress.)

      I hope my prolog coding style isn't too strange for you to follow.

      % Six by six chessboard problem, see "http://www.perlmonks.org/?node_i +d=821272" % Logical programming variant row(R) :- length(R, 6), rowpart(6, R). rowpart(T, R) :- rowpart(3, 3, T, R). rowpart(X, Y, 0, _) :- 0 =< X, 0 =< Y. rowpart(X, Y, T, [b | R]) :- succ(Xp, X), succ(Tp, T), rowpart(Xp, Y, +Tp, R). rowpart(X, Y, T, [w | R]) :- succ(Yp, Y), succ(Tp, T), rowpart(X, Yp, +Tp, R). board(B) :- B = [R0, R1, R2, R3, R4, R5], for(lambda(arg(R), length(R, 6)), B), transpose(B, BT), row(R0), write(board_debug0([R0])), nl, row(R1), R0 \== R1, row(R2), for(lambda(arg(R), R \== R2), [R0, R1]), row(R3), for(lambda(arg(R), R \== R3), [R0, R1, R2]), for(lambda(arg(C), rowpart(5, C)), BT), row(R4), for(lambda(arg(R), R \== R4), [R0, R1, R2, R3]), for(lambda(arg(C), row(C)), BT), %row(R5), % automatically true for(lambda(arg(R), R \== R5), [R0, R1, R2, R3, R4]), iota(6, I6), for(lambda(arg(M), ( take(M, BT, CB), nth0(M, BT, C), for(lambda(arg(U), U \== C), CB))), I6). nboard(N) :- findall(x, board(_B), L), length(L, N). main :- nboard(N), write(N), nl. /*

      Sadly you have to find the number of solutions, not just find one solution.

      Given the contents of the first two rows, compute the number of ways the rest of the table can be filled.

      For example, for the input you consider above, [[2, 1, 0, 0, 2, 2, 1], [0, 2, 2, 1, 1, 0, 2]], the output should be 4909920 because that's the number of solutions.

      Finding just one solution (for each of the ten inputs) would be much easier done by hand than by a program.

      In addittion, this part looks very inefficient to me:

      different_lists([A|TA], [B|TB]) :- ( A #\= B ; different_lists(TA, TB)).
      wouldn't this backtrack multiple times for any two lists that differ in more than one place? Wouldn't it cause to return a single solution multiple times?

      It seems like a bad idea to me to mix constraint programming with this kind of early backtracking. If I had to write this program, I'd either not use any constraint programming and backtrack over everything, or post everything as constraints and backtrack only once at the end with label.

      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. /*
        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]]]).
        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) ...
        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.