Perl: the Markov chain saw PerlMonks

### Seven by seven farming puzzle

by ambrus (Abbot)
 on Feb 03, 2010 at 21:30 UTC Need Help??

In 2007, I read the following task on an online puzzle site (exercise 5 here).

Cut a 6 times 6 chessboard to 18 black and 18 white squares. Assemble them to a 6 times 6 board in such a way that each row and column has 3 black and 3 white squares, every row is different, and every column is different. How many boards can you get this way? The rows and columns of the board are numbered, so boards that differ in rotation or flipping count as different.

As discussed on the J wiki, this puzzle is quite easy to solve with brute-force.

In 2008, we decided to post a larger variant of this puzzle on the first round of the Challenge24 contest. The (contest webpage has the full problem set downloadable, this is problem F.) The task was basically the following.

A seven by seven cell table has to be filled in such a way that each row and each column must have exactly two cells with a 0, two cells with a 1, and three cells with a 2 in them; no two rows can be exactly the same; and no two columns can be exactly the same. Given the contents of the first two rows, compute the number of ways the rest of the table can be filled.

With current computers, it's almost impossible to brute force this task by enumerating all possible solutions.

There is one simple observation that cuts down quite some time though.

However, brute forcing takes too much time even after knowing this trick. The first working perl program I wrote takes about twenty minutes on one input. Such a long running time would be unacceptable, as we want to give ten sample inputs, and the contestants would have five hours for the whole contest (reading the tasks, development, running the program, submitting the answer, all this for all eight tasks, with only three people in a team). I didn't despair though, for I already knew that that solution can be optimized a lot.

My final solution is more complicated and much faster: it runs on any one input in at most six seconds (that was back in 2008, computers are twice as fast now). That's fast enough, so we could post this problem. (In fact I was quite surprised on how much faster the program became.)

The remainder of this post explains how my solution works, and shows the code too. I've spoilered this in case you want to try to write a solution yourself.

Here follows the full code, with the inputs hardcoded in the DATA section. The code is a bit ugly, for I wrote it quick and dirty to simulate how a contestant could do it live in the contest.

There is one more notable point that surprised me when I found out during the preparations. This is that there are only fourteen (14) significantly different input data you can give in this problem. (This didn't help the contestants though, for we gave ten significantly different inputs, and this is the kind of contest where the contestants run their programs on their own computers and submit only the result.) There are thirteen possible outputs, for two of the inputs have an equal output for a reason unknown to me.

You may want to compute these fourteen inputs (pairs of two lines): this is much easier than solving the original problem. Here are them in canonical form in case you want to check.

Update: changed broken link from contest's old homepage to new homepage. Update 2015-11-26: fix typo.

Replies are listed 'Best First'.
Re: Seven by seven farming puzzle
by salva (Abbot) on Feb 04, 2010 at 12:17 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.

```% 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.

/*

Create A New User
Node Status?
node history
Node Type: perlmeditation [id://821272]
Approved by GrandFather
Front-paged by Arunbear
help
Chatterbox?
and all is quiet...

How do I use this? | Other CB clients
Other Users?
Others taking refuge in the Monastery: (9)
As of 2018-05-23 15:52 GMT
Sections?
Information?
Find Nodes?
Leftovers?
Voting Booth?
World peace can best be achieved by:

Results (171 votes). Check out past polls.

Notices?