Chris Mears

Solving variant sudoku in MiniZinc

2024-06-08T00:00:00+10:00

It’s straightforward to model and solve a Sudoku puzzle using MiniZinc. But the modern Sudoku world (as can be seen on the Cracking the Cryptic Youtube channel) is full of variants with exotic constraints – let’s see how hard it is to model those.

(A small disclaimer: I’m trying to model these constraints in a simple way, not necessarily an efficient way!)

Normal sudoku rules apply

The standard rules of Sudoku are easy enough: an integer variable for each of the 81 cells, constrained to take a value from 1 to 9, and each row, column, and 3x3 box required to have no duplicates (to be “all different”).

include "globals.mzn";  % to get the alldifferent constraint

% The cells of the grid.
array [1..9, 1..9] of var 1..9 : x;

% Each row is alldifferent.
constraint forall (i in 1..9) (alldifferent(x[i, 1..9]));
% Each column is alldifferent.
constraint forall (j in 1..9) (alldifferent(x[1..9, j]));
% Each 3x3 box is alldifferent.
constraint forall (i in 0..2, j in 0..2) (
  alldifferent(x[3*i+1..3*i+3, 3*j+1..3*j+3])
);

Some easy variants

Above is our first example puzzle: Dune: The Mentat’s Diversion by HalfBakedLunatic, featured in this video.

(Little) Killer sudoku and extra regions

A killer sudoku clue requires a set of cells to sum to a given number. This is an easy case to model:

% The top-left killer clue in example puzzle 1, sum part
constraint sum([x[1,3],x[1,4],x[2,1],x[2,2],x[2,3]]) = 27;

Little killer clues can be modelled the same way. Regular killer clues also require the cage to act as an extra no-duplicates region, which can be modelled simply with an alldifferent constraint:

% The top-left killer clue in example puzzle 1, no-duplicate part
constraint alldifferent([x[1,3],x[1,4],x[2,1],x[2,2],x[2,3]]);

Thermometers

A thermometer requires the numbers along the line to increase from the bulb end, like the temperature markings on a thermometer. This is a conjunction of simple arithmetic constraints:

% The top-left thermometer in example puzzle 1
constraint x[4,1] < x[4,2]
        /\ x[4,2] < x[3,2]
        /\ x[3,2] < x[3,3];

In fact MiniZinc has a global constraint that does exactly this, called strictly_increasing:

% The top-left thermometer in example puzzle 1, again
constraint strictly_increasing([x[4,1], x[4,2], x[3,2], x[3,3]]);

There’s also the constraint increasing for “slow” thermometers.

Kropki dots

Black kropki dots require one number to be double the other:

% Top-left black kropki dot in example puzzle 1
constraint (x[1,1] = x[1,2]*2) \/ (x[1,2] = x[1,1]*2)

White kropki dots require the two numbers to be adjacent. There are two simple ways to write it:

% Top-left kropki dot in example puzzle 1, if we pretend it's white instead of black
constraint (x[1,1] = x[1,2]+1) \/ (x[1,2] = x[1,1]+1);
% or, state that the numbers are exactly 1 apart:
constraint abs(x[1,1] - x[1,2]) = 1;

Example puzzle 1 model

These constraints can be wrapped in predicates and put together to solve example puzzle 1. Chuffed 0.13.2 solves this in just over 200ms:

include "globals.mzn";
array [1..9, 1..9] of var 1..9 : x;
constraint forall (i in 1..9) (alldifferent(x[i, 1..9]));
constraint forall (j in 1..9) (alldifferent(x[1..9, j]));
constraint forall (i in 0..2, j in 0..2) (
  alldifferent(x[3*i+1..3*i+3, 3*j+1..3*j+3])
);

predicate black_kropki(var int: a, var int: b) = (a = b*2) \/ (b = a*2);
predicate thermo(array[int] of var int: xs) = strictly_increasing(xs);
predicate killer(int: clue, array[int] of var int: xs) =
  alldifferent(xs) /\ sum(xs) = clue;
  
constraint black_kropki(x[1,1], x[1,2]);
constraint black_kropki(x[1,8], x[1,9]);
constraint black_kropki(x[3,6], x[4,6]);
constraint black_kropki(x[6,4], x[7,4]);
constraint black_kropki(x[9,1], x[9,2]);
constraint black_kropki(x[9,8], x[9,9]);

constraint killer(27, [x[1,3],x[1,4],x[2,1],x[2,2],x[2,3]]);
constraint killer(30, [x[1,6],x[1,7],x[2,7],x[2,8],x[2,9]]);
constraint killer(25, [x[4,3],x[5,1],x[5,2],x[5,3],x[6,1]]);
constraint killer(25, [x[4,5],x[4,6],x[5,5],x[6,4],x[6,5]]);
constraint killer(25, [x[4,7],x[5,7],x[5,8],x[5,9],x[6,9]]);
constraint killer(30, [x[7,3],x[8,1],x[8,2],x[8,3],x[9,3]]);
constraint killer(19, [x[7,7],x[8,7],x[8,8],x[8,9],x[9,7]]);

constraint thermo([x[4,1],x[4,2],x[3,2],x[3,3]]);
constraint thermo([x[3,6],x[3,5],x[3,4],x[4,4]]);
constraint thermo([x[4,9],x[4,8],x[3,8],x[3,7]]);
constraint thermo([x[6,3],x[6,2],x[7,2],x[7,1]]);
constraint thermo([x[7,4],x[7,5],x[7,6],x[6,6]]);
constraint thermo([x[6,7],x[6,8],x[7,8],x[7,9]]);

More constraints and extra variables

Example puzzle 2, A puzzle of two halves by Arbitrary (featured in this video).

In this puzzle the magenta lines are “renban” lines, where the digits on the line must form a set of consecutive digits without repeats. The letters A-F represent six different digits, and a letter in a circle means that letter’s digit must appear in at least one of the four surrounding cells.

The single arrow constraint is the easiest to model:

constraint x[3,3] = x[4,4]+x[5,5];

The renban constraint is more complicated. We assert that all the digits along the line are different, and that the smallest and largest digit are exactly n-1 apart, where n is the number of digits on the line.

predicate renban(array[int] of var int: x) =
  alldifferent(x) /\ (max(x)-min(x) = length(x)-1);

To model the letters representing digits, we introduce six more variables and constrain them to be different:

var 1..9: a; var 1..9: b; var 1..9: c;
var 1..9: d; var 1..9: e; var 1..9: f;
constraint alldifferent([a,b,c,d,e,f]);

For the letter-in-circle (“quad”) we assert that either the first cell takes the given value, or the second one does, and so on. Note that in this case the value v is not a fixed value but another variable.

% At least one of the four cells, where (i,j) is the top-left cell,
% must take the value v.
predicate quad(int: i, int: j, var int: v) =
     x[i  ,j  ] = v
  \/ x[i  ,j+1] = v
  \/ x[i+1,j  ] = v
  \/ x[i+1,j+1] = v;

% The "D E F" clue in example puzzle 2
constraint quad(7,5, d);
constraint quad(7,5, e);
constraint quad(7,5, f);

Solving the model requires assigning values simultaneously to the Sudoku cell variables in the array x and the a,b,c,d,e,f variables. The full model, which Chuffed solves in about 270ms:

include "globals.mzn";

array [1..9, 1..9] of var 1..9 : x;

constraint forall (i in 1..9) (alldifferent(x[i, 1..9]));
constraint forall (i in 1..9) (alldifferent(x[1..9, i]));
constraint forall (i in 0..2, j in 0..2) (
  alldifferent(x[3*i+1..3*i+3, 3*j+1..3*j+3])
);

constraint x[3,3] = x[4,4]+x[5,5];

predicate renban(array[int] of var int: x) =
  alldifferent(x) /\ (max(x)-min(x) = length(x)-1);

constraint renban([x[1,4], x[1,5], x[2,4], x[2,5], x[3,5]]);
constraint renban([x[1,8], x[1,9], x[2,8], x[2,9], x[3,8]]);
constraint renban([x[4,1], x[4,2], x[5,1], x[5,2], x[5,3]]);
constraint renban([x[3,9], x[4,8], x[4,9], x[5,8], x[5,9]]);
constraint renban([x[8,1], x[8,2], x[8,3], x[9,1], x[9,2]]);
constraint renban([x[8,4], x[8,5], x[9,3], x[9,4], x[9,5]]);
constraint renban([x[6,1], x[6,2], x[7,1], x[7,2]]);
constraint renban([x[6,8], x[6,9], x[7,8], x[7,9]]);
constraint renban([x[8,8], x[8,9], x[9,8], x[9,9]]);
constraint renban([x[3,3], x[3,4], x[4,3]]);
constraint renban([x[4,5], x[4,6], x[5,7]]);
constraint renban([x[6,5], x[7,4]]);
constraint renban([x[6,6], x[7,5]]);
constraint renban([x[7,7], x[8,6]]);

var 1..9: a; var 1..9: b; var 1..9: c;
var 1..9: d; var 1..9: e; var 1..9: f;
constraint alldifferent([a,b,c,d,e,f]);

predicate quad(int: i, int: j, var int: v) =
  x[i,j] = v \/ x[i,j+1] = v \/ x[i+1,j] = v \/ x[i+1,j+1] = v;
  
constraint quad(1,2, a);
constraint quad(1,5, d);
constraint quad(8,1, c);
constraint quad(2,2, b);
constraint quad(2,2, e);
constraint quad(2,7, e);
constraint quad(2,8, b);
constraint quad(3,1, c);
constraint quad(3,7, a);
constraint quad(3,7, f);
constraint quad(4,8, c);
constraint quad(5,3, f);
constraint quad(5,6, d);
constraint quad(6,1, b);
constraint quad(7,5, d);
constraint quad(7,5, e);
constraint quad(7,5, f);
constraint quad(8,2, a);
constraint quad(8,2, e);
constraint quad(8,8, a);

Conditional constraints and finding connected regions

Example puzzle 3, Zippery When Wet by Marty Sears (featured in this video).

This puzzle is quite a bit more difficult, both to solve by hand and model in MiniZinc. It has a great variety of constraints and requires us to cover the grid in land and water. These are the rules, from the SudokuPad link where you can play the puzzle:

YIN-YANG:
• Each cell is either land or water.
• All cells of the same type must be orthogonally connected.
• No 2x2 area may be entirely land or entirely water.

LINE TYPES:
• Renban (pink) - Digits on a pink line don't repeat, and form a consecutive sequence, but these can be arranged in any order along the line.
• Nabner (yellow) - A digit on a yellow line cannot be consecutive with (or the same as) any other digit anywhere on the line.
• German Whisper (green) - Adjacent digits on a green line must have a difference of at least 5.
• Region Sum (blue) - Digits along a blue line must have the same total within each 3x3 box.
• Parity (red) - Digits along a red line must alternate between odd and even.
• Entropic (orange) - Any group of 3 adjacent digits on an orange line must contain a low digit (1, 2 or 3), a medium digit (4, 5 or 6), and a high digit (7, 8 or 9).
• Palindrome (grey) - A grey line must read the same in either direction.
• Same Difference (turquoise) - Each pair of adjacent digits along a turquoise line must have the same difference.

ZIPPERY WHEN WET:
• Any line that is completely wet (only enters water cells) loses the property of its presenting colour, and instead becomes a zipper line. Along a zipper line, each pair of digits that are the same distance from the line's central cell, sum to the digit in that centre cell.
• Any line that is completely dry (only enters land cells) behaves normally, as described in the list above. It does not behave like a zipper line.
• If a line is partly dry and partly wet, it retains its presenting property, but it is ALSO a zipper line as well.

New constraints

Most of the line constraints are easy to model; here are two examples:

% Zipper constraint
predicate zipper(array[int] of var int: a) =
  let { int : n = length(a);
        int : m = (n div 2) + 1 } in
  forall (i in 1..m-1) ( a[i] + a[n-i+1] = a[m] );

% German whisper constraint.
predicate german(array[int] of var int: a) =
  forall (i in 1..length(a)-1) ( abs(a[i]-a[i+1]) >= 5 );

Yin-yang (land and water)

The requirement to find two connected regions is another story. The first part is easy enough; introduce Boolean variables to enforce that each cell is either land or water, and that there are no 2x2 blocks all of the same type:

% Each cell is either land or water.
array [1..9, 1..9] of var bool : land;
array [1..9, 1..9] of var bool : water;
constraint forall (i,j in 1..9) ( land[i,j] != water[i,j] );
% No 2x2 blocks of all-land or all-water.
constraint forall (i,j in 1..8) (
  sum([land[i,j],land[i+1,j],land[i,j+1],land[i+1,j+1]]) in {1,2,3}
);

The tricky part is ensuring that all water (or land) cells are connected. To do this we arbitrarily assign one cell as the “source” cell, and imagine that the water flows from that cell into the other cells. We have a variable for each water cell’s distance from that source cell, and assert that if a cell has distance D from the source, one of its neighbouring water cells must have distance D - 1. This ensures that there is some path from each cell back to the source cell, and therefore that all cells are connected.

% The ugliest but most important part of the Yin-Yang constraint:
% ensuring dist[i,j] represents the length of some path back to
% the source cell.
constraint forall (i,j in 1..9) (
  if     [i,j] = [wi,wj] then dist[i,j] = 0  % Source cell has distance zero
  elseif [i,j] = [li,lj] then dist[i,j] = 0  % Source cell has distance zero
  else % If our distance is D, there must exist a neigbour, of the same type,
       % with distance D-1.
       (   ((land[i-1,j]=land[i,j]) /\ dist[i-1,j] = dist[i,j]-1) :: maybe_partial
        \/ ((land[i+1,j]=land[i,j]) /\ dist[i+1,j] = dist[i,j]-1) :: maybe_partial
        \/ ((land[i,j-1]=land[i,j]) /\ dist[i,j-1] = dist[i,j]-1) :: maybe_partial
        \/ ((land[i,j+1]=land[i,j]) /\ dist[i,j+1] = dist[i,j]-1) :: maybe_partial )
  endif
  );

We also add constraints to choose (arbitrarily) the top-left-most cell as the source cell, and force each cell’s distance value to be the smallest possible value. These constraints eliminate redundant solutions and reduce the search space.

Conditional constraints

The “zippery when wet” condition is then no problem:

% A clue in the puzzle translates to two conditional constraints:
%   "zippery when wet" and "ordinary when dry"
predicate purple(array[int,int] of int: coords) =
     (wet(coords) -> zipper(extract(x, coords)))
  /\ (dry(coords) -> renban(extract(x, coords)));

For the purple line, it means: if it’s a bit wet it must act as a zipper line, and if it’s a bit dry then it must act as a renban line. The wet and dry predicates check if any cell of the given coordinates is water or land.

Example puzzle 3 full model

The full model below finds the solution in 1.2 seconds. One curiosity is that including the “shortest distance” constraint – intended to eliminate redundant solutions and potentially improve performance – makes the solving slower by about half a second.

include "globals.mzn";

array [1..9, 1..9] of var 1..9 : x;

constraint forall (i in 1..9) (alldifferent(x[i, 1..9]));
constraint forall (i in 1..9) (alldifferent(x[1..9, i]));
constraint forall (i in 0..2, j in 0..2) (
  alldifferent(x[3*i+1..3*i+3, 3*j+1..3*j+3])
);

% Each cell is either land or water.
array [1..9, 1..9] of var bool : land;
array [1..9, 1..9] of var bool : water;
constraint forall (i,j in 1..9) ( land[i,j] != water[i,j] );

% No 2x2 blocks of all-land or all-water.
constraint forall (i,j in 1..8) (
  sum([land[i,j],land[i+1,j],land[i,j+1],land[i+1,j+1]]) in {1,2,3}
);

% Location of "source" water and land cells.
var 1..9 : wi; var 1..9 : wj;  constraint water[wi,wj];
var 1..9 : li; var 1..9 : lj;  constraint land[li,lj];

% Shortest distance from source cell.
array [1..9, 1..9] of var 0..80 : dist;

% Constrain source water cell to be "earliest" position.
constraint forall (i,j in 1..9) (
  if i < wi \/ (i==wi /\ j < wj) then water[i,j] = false else true endif
);
% Constrain source land cell to be "earliest" position.
constraint forall (i,j in 1..9) (
  if i < li \/ (i==li /\ j < lj) then land[i,j] = false else true endif
);

constraint forall (i,j in 1..9) (
  if     [i,j] = [wi,wj] then dist[i,j] = 0  % Source cell has distance zero
  elseif [i,j] = [li,lj] then dist[i,j] = 0  % Source cell has distance zero
  else % If our distance is D, there must exist a neigbour, of the same type,
       % with distance D-1.
       (   ((land[i-1,j]=land[i,j]) /\ dist[i-1,j] = dist[i,j]-1) :: maybe_partial
        \/ ((land[i+1,j]=land[i,j]) /\ dist[i+1,j] = dist[i,j]-1) :: maybe_partial
        \/ ((land[i,j-1]=land[i,j]) /\ dist[i,j-1] = dist[i,j]-1) :: maybe_partial
        \/ ((land[i,j+1]=land[i,j]) /\ dist[i,j+1] = dist[i,j]-1) :: maybe_partial )
  endif
  );

% Force dist to be the shortest distance (to eliminate potential redundant solutions).
constraint forall (i,j in 1..9) (
     if j<9 /\ land[i,j] = land[i,j+1] then abs(dist[i,j] - dist[i,j+1]) <= 1 endif
  /\ if i<9 /\ land[i,j] = land[i+1,j] then abs(dist[i,j] - dist[i+1,j]) <= 1 endif
);
  
% Puzzle clues.
constraint purple([|2,1|2,2|1,2|]);
constraint purple([|4,6|5,6|6,6|]);
constraint yellow([|1,7|1,6|1,5|2,5|3,5|]);
constraint yellow([|7,8|8,7|8,8|]);
constraint red([|5,4|6,3|7,4|8,4|9,4|]);
constraint red([|5,7|5,8|5,9|]);
constraint grey([|2,6|3,6|4,5|]);
constraint grey([|8,9|9,9|9,8|]);
constraint green([|2,4|3,4|3,3|4,3|4,2|]);
constraint green([|7,6|8,6|9,7|]);
constraint cyan([|3,7|3,8|4,8|]);
constraint cyan([|6,1|7,2|8,3|]);
constraint cyan([|6,4|7,5|8,5|]);
constraint blue([|1,4|2,3|3,2|]);
constraint blue([|5,2|5,3|4,4|5,5|6,5|]);
constraint orange([|2,7|2,8|2,9|3,9|4,9|]);
constraint orange([|6,7|6,8|7,7|]);

% A clue in the puzzle translates to two conditional constraints:
%   "zippery when wet" and "ordinary when dry"
predicate purple(array[int,int] of int: coords) =
  (wet(coords) -> zipper(extract(x, coords))) /\ (dry(coords) -> renban(extract(x, coords)));
predicate yellow(array[int,int] of int: coords) =
  (wet(coords) -> zipper(extract(x, coords))) /\ (dry(coords) -> nabner(extract(x, coords)));
predicate red(array[int,int] of int: coords) =
  (wet(coords) -> zipper(extract(x, coords))) /\ (dry(coords) -> parity(extract(x, coords)));
predicate grey(array[int,int] of int: coords) =
  (wet(coords) -> zipper(extract(x, coords))) /\ (dry(coords) -> palindrome(extract(x, coords)));
predicate green(array[int,int] of int: coords) =
  (wet(coords) -> zipper(extract(x, coords))) /\ (dry(coords) -> german(extract(x, coords)));
predicate cyan(array[int,int] of int: coords) =
  (wet(coords) -> zipper(extract(x, coords))) /\ (dry(coords) -> equidiff(extract(x, coords)));
predicate blue(array[int,int] of int: coords) =
  (wet(coords) -> zipper(extract(x, coords))) /\ (dry(coords) -> regionsum(coords));
predicate orange(array[int,int] of int: coords) =
  (wet(coords) -> zipper(extract(x, coords))) /\ (dry(coords) -> entropic(extract(x, coords)));

% A line is "wet" if any of its cells are water.
predicate wet(array[int,int] of int: coords) = exists(extract(water, coords));
% A line is "dry" if any of its cells are land.
predicate dry(array[int,int] of int: coords) = exists(extract(land, coords));
  
% Extract a set of variables with given coordinates from a 2d array of variables.
function array[int] of var $T : extract(array[int,int] of var $T : v, array[int,int] of int: cs) =
  [ v[cs[c,1],cs[c,2]] | c in index_set_1of2(cs) ];

% Zipper constraint
predicate zipper(array[int] of var int: a) =
  let { int : n = length(a);
        int : m = (n div 2) + 1 } in
  forall (i in 1..m-1) ( a[i] + a[n-i+1] = a[m] );

% Renban constraint
predicate renban(array[int] of var int: a) =
  alldifferent(a) /\ (max(a)-min(a) = length(a)-1);

% Nabner constraint
predicate nabner(array[int] of var int: a) =
  forall(i,j in index_set(a) where i<j) (abs(a[i]-a[j]) >= 2);

% Parity (odd-even) constraint
predicate parity(array[int] of var int: a) =
  forall (i in 1..length(a)-1) ( a[i] mod 2 != a[i+1] mod 2 );

% Palindrome constraint.
predicate palindrome(array[int] of var int: a) =
  let { int : n = length(a);
        int : m = (n div 2) + 1 } in
  forall (i in 1..m-1) ( a[i] = a[n-i+1] );

% German whisper constraint.
predicate german(array[int] of var int: a) =
  forall (i in 1..length(a)-1) ( abs(a[i]-a[i+1]) >= 5 );

% Equal-difference constraint.
predicate equidiff(array[int] of var int: a) =
  forall (i in 1..length(a)-2) ( abs(a[i]-a[i+1]) = abs(a[i+1]-a[i+2]) );

% Region-sum constraint.
predicate regionsum(array[int,int] of int: coords) =
  % Introduce the "sum value" for this line.
  let { var int : sum } in
  % Start walking the line.
  regionsum2(coords, x[coords[1,1],coords[1,2]], sum, 2);
  
predicate regionsum2(array[int,int] of int : coords, var int : runningsum, var int : sum, int : i) =
  % At the end of the line, close the current box.
  if i > card(index_set_1of2(coords)) then runningsum = sum
  % We've crossed a box border, so close the current box and recurse with a new running sum.
  elseif box(coords[i,1],coords[i,2]) != box(coords[i-1,1],coords[i-1,2])
       then runningsum = sum /\ regionsum2(coords, x[coords[i,1],coords[i,2]], sum, i+1)
  % We're still in the same box, so just add to the running sum.
  else regionsum2(coords, x[coords[i,1],coords[i,2]]+runningsum, sum, i+1)
  endif;

% Map coordinate -> box number.
function int: box(int: i,int: j) = ((i-1) div 3) * 3 + ((j-1) div 3) + 1;

% Entropic line constraint.
predicate entropic(array[int] of var int : a) =
  forall(i in 1..length(a)-2) (
       (a[i]-1) div 3 != (a[i+1]-1) div 3
    /\ (a[i]-1) div 3 != (a[i+2]-1) div 3 );

solve satisfy;

output [show(x[i,j]) ++ if j=9 then "\n" else "" endif | i,j in 1..9];
output [if fix(water[i,j]) then "~" else "#" endif ++ if j=9 then "\n" else "" endif | i,j in 1..9];

Möbius Front ‘83 Solitaire Cribbage solver

2021-09-06T00:00:00+10:00

Zachtronics’s recent game Möbius Front ‘83 – like most of their offerings – contains an optional card game inside. This time it’s a solitaire version of cribbage, where you get points for playing cards in sets and combos. It rewards careful thinking and planning ahead, which sounds like a lot of work; let’s get the computer to do it instead.

You start with a standard deck of 52 cards dealt in 4 piles. You can play the top card of any pile onto a stack, but the stack’s total value can’t go over 31. You get points when the stack meets certain conditions: if the stack’s value is exactly 15 or 31, or if you play 2/3/4 of a kind in a row, or if the last few cards in the stack can be arranged into a run of consecutive values. When you can’t play any more cards without exceeding 31, you throw the stack away and start with a fresh, empty stack. The aim is to get as many points as possible.

One approach to an automatic solver for the game is a greedy one: look at the position you’re in, find the best possible “stack” of moves, and commit to it. Then continue doing this until all the cards are played. In my experiments this proved not very good, usually failing to reach the game’s target score of 61 points. The problem is that making the “best” move right now might prevent us from scoring even more points later on.

A simple modification of this approach is to introduce some randomness: instead of always choosing the highest-scoring move, choose a “good” move at random. With a bit of randomness, we can repeatedly run the algorithm in the hope of chancing upon a high-scoring combination of moves. This modification can be done by putting all the moves in order (highest-scoring first), then walking along them and flipping a weighted coin. If the coin comes up heads, commit to that move; otherwise, continue to the next move.

Roughly speaking, the algorithm is:

void probe(GameState state) {
    if all cards are played
      if this is the best score, print it out and remember it
    else
      compute all the possible moves
      pick a good one and execute it
      probe(new state)
}

This approach in practice gives good-enough solutions very fast. But if we want really big scores, we can use a complete algorithm that will always find the best possible score.

A key property of the game is that what you did before doesn’t influence what you should do next. That is, if I play the first half of the game and then you take over, you don’t need to know exactly what I did or even how many points I scored – you only need to know which cards are left for you to play. This property suggests a dynamic programming approach.

Dynamic programming as applied to this game works as follows. From a given position, we can calculate the best total score we can possibly get. Let’s say we are in position \(P\) and we’re considering move \(M\). Move \(M\) will gain us \(S_M\) score immediately, and leave us in a new position \(P_M\). The function \(f(P)\) gives the best score attainable from position \(P\), and is defined as:

\[f(P) = \max(\{ S_M + f(P_M) \mid M \in \mathit{moves}(P)\})\]

That is, the best score is via whichever move gives the highest sum of “points gained from that move” and “points available from the position we’re in after the move”.

We can keep the definition of “position” simple by assuming that the current stack is always empty. That means each move must be a whole stack’s worth of play. Then a position can be described by just four numbers: how many cards have we used up from each pile so far? This position is the key into a cache where we record the answers so they can be reused when we inevitably encounter the same sub-positions again.

So the algorithm is:

Score get(Position p) {
    if p is the end position, return 0
    if p is in the cache, return the cached score
    compute all the moves from p
    find the one that maximises score(move) + get(position-after-move)
    store that maximum score in cache
    return that score
}

According to some very non-rigorous tests, my implementation of this approach takes about 30 seconds to find the optimal solution. Some basic profiling suggests the slowest part is in the scoring of runs of consecutive digits, where there is definitely opportunity for improvement.

Both methods are implemented in Java in this GitHub repository. The first method is in the probe function in Search.java, and the dynamic programming method is in the get function in Dynamic.java.

Rubiks Race Re-rolling

2019-10-07T00:00:00+11:00

My son recently picked up a copy of Rubiks Race, a kids’ board game that’s essentially a slide puzzle turned into a two-player showdown. You first generate a random target pattern by rolling nine six-coloured dice in a little container, and then each player slides their tiles around to match the pattern. Sometimes the target pattern is invalid – when it has 5 or more of the same colour – but how often exactly?

The fact that you have to re-roll the dice occasionally is hardly a big inconvenience, but it’s a fun exercise to think about the chance of it happening. We tried to guess the rate and we came up with the broad range of somewhere between 1% and 20%.

Random sampling

One simple way to estimate the rate is to (virtually) roll the dice a lot of times and count how often it happens.

import Control.Monad
import Data.List
import System.Environment
import System.Random
import Text.Printf

data Colour = Red | Green | Blue | Yellow | White | Orange
  deriving (Eq, Ord, Enum, Bounded)

-- Roll a single die.
die :: IO Colour
die = toEnum <$> randomRIO (0,5)

-- Roll all the dice together.
roll :: IO [Colour]
roll = replicateM 9 die

-- "Categorise" a roll: how many occurrences are there of the most
-- common colour?
categorise :: [Colour] -> [Int]
categorise = sort . map length . group . sort

-- Roll the dice N times and count the results.
main :: IO ()
main = do
  n <- read . head <$> getArgs
  observations <- replicateM n (last . categorise <$> roll)
  let groups = (map (\xs -> (head xs, length xs)) . group . sort) observations
  forM_ groups $ \(x,y) -> printf "%d,%d\n" x y

Running this with 10,000 rolls gives these results:

So we can see that 505 times out of 10,000 we would have to re-roll, about 5% of the time. More than half of the time, the most common colour will be showing on exactly 3 dice.

Exhaustive counting

Can we get a more precise answer? We could of course sample more, but in this case there are not that many combinations in total – only 6^9, or about 10 million – so we can simply try them all.

import Control.Monad
import Data.List
import Text.Printf

data Colour = Red | Green | Blue | Yellow | White | Orange
  deriving (Eq, Ord, Enum, Bounded)

-- "Categorise" a roll: how many occurrences are there of the most
-- common colour?
categorise :: [Colour] -> [Int]
categorise = sort . map length . group . sort

-- All possible 9-die rolls.
allRolls :: [[Colour]]
allRolls = replicateM 9 [minBound..maxBound]

main :: IO ()
main = do
  let observations = (last . categorise <$> allRolls)
  let groups = (map (\xs -> (head xs, length xs)) . group . sort) observations
  forM_ groups $ \(x,y) -> printf "%d,%d\n" x y

And we get the exact answers:

So exactly 541176/10077696 times we’ll have to re-roll (about 5.73%).

The only problem remaining with this program is that it’s slow: on my laptop it took about 22 seconds to run. How can we make it faster?

Faster

One way to make it faster is to observe that the colours are interchangeable so we’re counting separately patterns that look superficially different but are actually the same. (For example, the pattern with 6 reds, 2 greens and 1 blue is spiritually the same as the one with 6 greens, 2 yellows and 1 orange.) We can avoid some of the repetition by forcing the first die to come up, say, Red.

-- All possible 9-die rolls that start with a Red.
allRolls :: [[Colour]]
allRolls = map (Red:) (replicateM 8 [minBound..maxBound])

main :: IO ()
main = do
  let observations = (last . categorise <$> allRolls)
  let groups = (map (\xs -> (head xs, length xs)) . group . sort) observations
  forM_ groups $ \(x,y) -> printf "%d,%d\n" x (y*6)

Then we multiply the resulting counts by 6 to get the full total. As expected, the running time is now just 1/6 of before, about 3.5 seconds.

Why is this correct? Think of it this way: we’ve counted all the different patterns that start with a red. But there’s nothing special about red; if we repeated the exercise using blue instead we’d get exactly the same counts. So the counts are correct for every starting colour, we just have to add them up to get the true counts.

A direct approach

So far we haven’t used any real mathematical knowledge other than counting. (A bit of programming knowledge and spare CPU time can make up for a lot of mathematical ignorance.) If we just want to know how often we’d have to re-roll – without getting the distribution of “number of the most commonly occurring colour” – we can apply some high-school probability theory.

~~~{.haskell}
import Data.Ratio

factorial :: Integer -> Integer
factorial n = product [1..n]

choose :: Integer -> Integer -> Integer
n `choose` r = factorial n `div` (factorial r * factorial (n-r))

prob :: Rational -> Integer -> Integer -> Rational
prob p n t = p^n * (1-p)^(t-n) * fromIntegral (t `choose` n)

rerollProb :: Rational
rerollProb = 6 * sum [ prob (1%6) n 9 | n <- [5..9] ]

main :: IO ()
main = print rerollProb

That is, we compute the probability of getting 5, 6, 7, 8 or 9 “red” faces from a roll of 9 dice, then add those up. We multiply the final result by 6 for the same reason as before.

The answer is 22549 % 419904, which is the same as before in reduced form.

Dynamic Programming

But what if you really, truly, want the distribution of the number of the most commonly occurring colour, and you’re not willing to wait a few seconds to get it? Another approach is dynamic programming:

import Control.Monad
import Control.Monad.Trans.State
import Data.Function
import Data.List
import Data.Map (Map)
import qualified Data.Map as M
import Data.Ord
import Text.Printf

-- A sequence of colour counts.
-- E.g. if we've rolled [Red,Red,Green,Red,Blue], the pattern is [1,1,3]
--   (1 of one colour, 1 of another colour, and 3 of another colour)
-- Always kept in ascending order.
type Pattern = [Integer]

-- From a given pattern, what other patterns can we reach with a
-- single die roll?
-- Always returns a list of length 6, representing the six possible
-- outcomes of the roll.  (Note that two rolls may lead to the same
-- result.)
extend :: Pattern -> [Pattern]
extend [] = replicate 6 [1]
extend xs =
    -- Either you roll a new colour...
    (replicate (6-length xs) (1:xs))
    ++
    -- or you get another occurrence of an existing colour.
    ([ sort (inc i xs) | i <- [0..length xs-1]])


-- Increment an element in a list.
-- Inefficient use of list as array.
inc :: Int -> [Integer] -> [Integer]
inc i xs = take i xs ++ [(xs!!i) + 1] ++ drop (i+1) xs

-- Execute the dynamic programming algorithm.
-- A breadth-first traversal of the graph defined by "extend", rooted
-- at the empty pattern [].  Stops when it gets to 9 rolls.
-- The result is the Map in the State, which maps each pattern
-- to the number of ways there are to reach it.
loop :: [Pattern] -> State (Map Pattern Integer) ()
loop [] = pure ()
loop (p:ps) = do
  -- How mayn ways are there to get to p?
  ways <- (M.! p) <$> get
  -- Where do we go from p?
  let extensions = filter ((<=9) . sum) (extend p)
  -- For each out-going edge...
  forM_ extensions $ \e -> do
    -- ... there are now "ways" more ways to get there.
    modify (\m -> M.insertWith (+) e ways m)
  -- Continue the traversal.
  loop (nub (ps ++ extensions))

main :: IO ()
main = do
  let -- Get the mapping.
      m = execState (loop [[]]) (M.fromList [([], 1)])
      -- Keep only the 9-die patterns.
      pairs1 = filter ((==9) . sum . fst) (M.toList m)
      -- Classify them by their most commonly occurring colour (the
      -- last number in the pattern).
      pairs2 = map (\(p,n) -> (last p,n)) pairs1
      -- Group them by their classification.
      groups = groupBy ((==) `on` fst) $ sortBy (comparing fst) $ pairs2
      -- Sum up the counts in each group.
      counts = map (\g -> (fst (head g), sum (map snd g))) groups
  forM_ counts $ \(x,y) -> printf "%d,%d\n" x y

This gives the same result as the exhaustive counting from earlier, but in the more acceptable running time of a couple of milliseconds.

Greater-than Sudoku in MiniZinc

2015-01-06T00:00:00+11:00

Greater-than Sudoku is like an ordinary Sudoku puzzle, but the number clues are replaced with less-than and greater-than relations.

Sergii Dymchenko showed how to solve it with ECLiPSe, and Hakan Kjellerstrand translated that to Picat, so I couldn’t resist trying to model it in MiniZinc.

array[int,int] of string : horizontal;
array[int,int] of string : vertical;

horizontal =
  [| ">","<",">","<","<",">",
   | ">","<","<","<",">",">",
   | "<",">","<",">",">","<",
   | ">","<",">","<","<","<",
   | "<","<","<",">",">","<",
   | ">",">",">","<","<",">",
   | ">",">","<",">",">","<",
   | "<",">","<",">","<",">",
   | "<",">",">","<","<",">" |];

vertical =
  [| "^","v","^","v","v","^","^","^","^"
   | "v","^","^","^","^","v","^","v","^"
   | "v","^","^","v","^","v","^","v","v"
   | "v","v","v","^","v","^","v","^","^"
   | "v","^","v","^","^","^","v","^","v"
   | "^","^","^","v","v","^","v","v","v" |];

array [1..9, 1..9] of var 1..9: x;

% Standard Sudoku constraints.
constraint forall (i in 1..9) (alldifferent([x[i,j] | j in 1..9]));
constraint forall (i in 1..9) (alldifferent([x[j,i] | j in 1..9]));
constraint forall (i,j in 1..3)
  ( alldifferent(p,q in 1..3)( x[3*(i-1)+p, 3*(j-1)+q] ));

% Horizontal comparisons.
constraint forall (row in 1..9, c in 0..2)
  (  h(x[row,3*c+1], x[row,3*c+2], horizontal[row,2*c+1])
  /\ h(x[row,3*c+2], x[row,3*c+3], horizontal[row,2*c+2]) ) ;

% Vertical comparisons.
constraint forall (col in 1..9, r in 0..2)
  (  v(x[3*r+1,col], x[3*r+2,col], vertical[2*r+1,col])
  /\ v(x[3*r+2,col], x[3*r+3,col], vertical[2*r+2,col]) ) ;

% Convert a "<" or ">" string into a constraint.
predicate h(var int : a, var int : b, string : op) =
  if op = "<" then a < b
  elseif op = ">" then a > b
  else abort("invalid horizontal operator")
  endif;

% Convert a "v" or "^" string into a constraint.
predicate v(var int : a, var int : b, string : op) =
  if op = "v" then a > b
  elseif op = "^" then a < b
  else abort("invalid vertical operator")
  endif;

solve satisfy;

output [ " " ++ show(x[i,j]) ++ (if j = 9 then "\n" else "" endif)
       | i,j in 1..9];

Because MiniZinc doesn’t support ragged arrays like ECLiPSe and Picat, I had to separate the horizontal and vertical clues.

Using Gecode as the solver, we get the nice result that it finds the unique solution without having to do any search.

$ mzn-gecode -s -n 0 gts.mzn
 8 3 4 9 6 7 2 5 1
 9 1 5 2 3 8 7 6 4
 2 7 6 4 5 1 8 3 9
 6 5 7 3 2 9 1 4 8
 4 8 9 1 7 5 6 2 3
 3 2 1 8 4 6 5 9 7
 7 4 3 5 8 2 9 1 6
 1 6 2 7 9 3 4 8 5
 5 9 8 6 1 4 3 7 2
----------
==========
%%  runtime:       0.001 (1.731 ms)
%%  solvetime:     0.000 (0.332 ms)
%%  solutions:     1
%%  variables:     81
%%  propagators:   0
%%  propagations:  776
%%  nodes:         1
%%  failures:      0
%%  restarts:      0
%%  peak depth:    0

Template Haskell for faster linear interpolation

2014-07-09T00:00:00+10:00

An application I’m writing requires a lot of linear interpolation of a function. There’s so much of it, in fact, that it was the biggest single contributor to the running time. In this article I show how I used Template Haskell to make it much faster and cut the overall running time of the application by about a third.

To be clear about the problem, we have a list of points (which I’ll call the “table”) like this:

(0.00, 0.00)
(0.50, 0.48)
(1.00, 0.84)
(1.50, 1.00)
(2.00, 0.91)
(2.50, 0.60)
(3.00, 0.14)
(3.50, -0.35)
(4.00, -0.76)
(4.50, -0.98)
(5.00, -0.96)
(5.50, -0.71)
(6.00, -0.28)
(6.50, 0.22)
(7.00, 0.66)
(7.50, 0.94)
(8.00, 0.99)
(8.50, 0.80)
(9.00, 0.41)
(9.50, -0.08)
(10.00, -0.54)

These points are input-output pairs for some function f, and we want to define the points in the middle by joining the dots with straight lines. For example, since f(0.5) = 0.4 and f(1.0) = 0.84, we want to have that f(0.75) = 0.66 because it’s halfway between those two points.

So, for a given input value x, we have to find the two points (a,av) and (b,bv) such that x is between a and b, and the result should be calculated like this:

-- Compute the linear interpolation of "x" between the points (a,av)
-- and (b,bv).
interpolate (a,av) (b,bv) x = av + (x-a)*(bv-av)/(b-a)

All we need to do is find those two neighbouring points. For any values that are outside of the range of the table, we just use the nearest value; e.g. for the sample table above, f(100) = -0.54.

Linear lookup

A lot of the time, you might write a simple linear traversal of the table like this and call it a day:

-- Ordinary linear traversal of the table.
linearLookup :: [ (Double,Double) ] -> Double -> Double
linearLookup [] x = error "linearLookup: empty table"
linearLookup ((a,av):rest) x | x <= a = av
                             | otherwise = loop ((a,av):rest)
  where -- At the end of the table, so use the last value.
        loop [(a,av)] = av
        loop ((a,av):(b,bv):rest)
             -- We've found the target range; do the interpolation.
             | x <= b = interpolate (a,av) (b,bv) x
             -- Otherwise, keep looking.
             | otherwise = loop ((b,bv):rest)

When I was writing the application in question, I was struck by the feeling that this was not “Haskelly” enough – there’s direct recursion, and it doesn’t even have any monoids. So I wrote this instead:

-- Use the First monoid to "hide" the recursion.
monoidalLookup :: [ (Double, Double) ] -> Double -> Double
monoidalLookup table x =
    case (firstJust . map f . tails) table of
      Just (ap,bp) -> interpolate ap bp x
      Nothing -> if x < fst (head table)
                 then snd (head table)
                 else snd (last table)
  where f ((a,av):(b,bv):_) | a <= x && x <= b = Just ((a,av),(b,bv))
        f _ = Nothing

-- Get the first "Just" value from a list.
firstJust :: [Maybe a] -> Maybe a
firstJust = getFirst . mconcat . map First

It’s the same linear-traversal strategy, but written so that it’s harder to understand. (It occurred to me in writing this article that it might be clearer to use a fold directly instead of the First monoid, but I didn’t try this.) The only thing you could say in its defense is that the “selection” part (called “f” there) is separated from the rest of the algorithm.

Map lookup

A linear traversal is simple, but has the drawback that to get to values near the end of the table we have to traverse the whole table. Profiling my application suggested that this monoidal lookup was spectacularly slow. Maybe we can use a Map instead?

-- Find the points to interpolate between using a map.
mapLookup :: Map Double Double -> Double -> Double
mapLookup m x =
    case (lookupLE x m, lookupGE x m) of
      (Just (a,av), Just (b,bv)) ->
        if a == b
        then av
        else interpolate (a,av) (b,bv) x
      (Nothing, Just (b,bv)) -> bv
      (Just (a,av), Nothing) -> av
      _ -> error "mapLookup"

The first argument to mapLookup is just the table converted to a Map; e.g. Data.Map.fromList table. This approach reduces the worst case from \(O(N)\) to \(O(\log N)\), but hurts the best case and introduces some overhead in general. It also seems a bit inefficient to do two lookups (the lookupLE and lookupGE) when they are both really looking for the same spot in the tree.

In my application, I used this mapLookup function for a long time, until improvements in other parts of the program meant that interpolation was again the bottleneck.

My next approach was to encode the lookup as a series of <= / > comparisons, essentially the same as how a Map would work internally. The table is encoded as a tree, where each entry in the table becomes a node with two children, or a leaf.

data SplitTree = Leaf
               | Node (Double, Double) SplitTree SplitTree
  deriving (Show)

makeTree :: [(Double,Double)] -> SplitTree
makeTree [] = Leaf
makeTree [p] = Node p Leaf Leaf
makeTree ps = let n = length ps
                  m = n `div` 2
                  (left, (middle:right)) = splitAt m ps
              in Node middle (makeTree left) (makeTree right)

The makeTree function turns a table into a tree, evenly distributing the table entries to the left and right. Doing the lookup is similar to a standard binary search, with the addition of keeping track of the most recent times we took left and right branches.

treeLookup :: SplitTree -> Double -> Double
treeLookup t x = loop Nothing Nothing t
  where
    loop lb ub Leaf =
      case (lb,ub) of
        (Nothing, Nothing) -> error "can't interpolate on empty tree"
        (Just (l,lv), Nothing) -> lv
        (Nothing, Just (u,uv)) -> uv
        (Just (l,lv), Just (u,uv)) -> interpolate (l,lv) (u,uv) x
    loop lb ub (Node (n,nv) left right) =
      case compare x n of
        EQ -> nv
        LT -> loop lb (Just (n,nv)) left
        GT -> loop (Just (n,nv)) ub right

Static Compilation

The point of the treeLookup function above is that we can easily “unroll” the loop, turning it into a series of nested comparisons. For example, for the simple table [(1,1), (2,4), (3,9)], we’d like to get as a result a function like this:

littleLookup x =
  case compare x 2 of
    EQ -> 4
    LT -> case compare x 1 of
            EQ -> 1
            LT -> 1
            GT -> 1 + (((x - 1) * (4 - 1)) / (2 - 1))
    GT -> case compare x 3 of
            EQ -> 9
            LT -> 4 + (((x - 2) * (9 - 4)) / (3 - 2))
            GT -> 9

The nice thing is that via Template Haskell we can do this with only some small modification of the treeLookup function above. The structure of the function stays essentially the same; the main work is in annotating which parts should be evaluated statically, and which parts are in the resulting “unrolled” function.

unrollLookupTree :: SplitTree -> ExpQ
unrollLookupTree t = do
  x <- newName "x"
  body <- loop (varE x) Nothing Nothing t
  return $ LamE [VarP x] body

loop :: ExpQ -> Maybe (Double,Double) -> Maybe (Double,Double)
    -> SplitTree -> ExpQ
loop x lb ub Leaf =
    case (lb,ub) of
      (Nothing, Nothing) -> error "can't interpolate on empty tree"
      (Just (l,lv), Nothing) -> ld lv
      (Nothing, Just (u,uv)) -> ld uv
      (Just (l,lv), Just (u,uv)) ->
        [| $(ld lv) + ($x - $(ld l)) * ($(ld uv) - $(ld lv))
                               /  ($(ld u) - $(ld l))           |]
loop x lb ub (Node (n,nv) left right) =
    [| case compare $x $(ld n) of
         EQ -> $(ld nv)
         LT -> $(loop x lb (Just (n,nv)) left)
         GT -> $(loop x (Just (n,nv)) ub right)
    |]

-- Lift a Double to an ExpQ
ld :: Double -> ExpQ
ld = litE . rationalL . realToFrac

One hiccup is that Template Haskell won’t automatically lift a Double value to an expression — apparently, only integers and rationals are allowed. As a consequence I used the little function ld to turn a Double into a rational literal.

You can also unroll the linear lookup version:

unrollLinearLookup [] = error "linearLookup: empty table"
unrollLinearLookup table = do
  x <- newName "x"
  body <- linearLoop (varE x) Nothing table
  return $ LamE [VarP x] body

linearLoop :: ExpQ -> Maybe (Double,Double)
           -> [(Double,Double)] -> ExpQ
linearLoop x Nothing [] = error "absolutely cannot happen"
linearLoop x (Just (a,av)) [] = ld av
linearLoop x previous ((b,bv):rest) =
    let val = case previous of
                Just (a,av) ->
                  [| $(ld av) + ($x - $(ld a)) * ($(ld bv) - $(ld av))
                                         /  ($(ld b) - $(ld a))     |]
                Nothing -> ld bv
    in [| case compare $x $(ld b) of
            GT -> $(linearLoop x (Just (b,bv)) rest)
            _ -> $val
       |]

Performance Comparison

We could debate which of these methods is the most elegant, but at least we can easily address the question of which one is the fastest.

(If you want to see the full source code to reproduce these results, or just for fun, see this repository on GitHub.)

I measured each method, looking up a value at the start, middle and end of the table; the table has 21 entries. Here are the results, courtesy of the criterion library:

(Click on the image above to get the full report and all the exciting details.) As we expected, linear lookups are fast when the target is at the front, but get slower as the target gets towards the end. Also, the binary lookups take about the same time no matter where the target is.

The monoidal lookup is impressively inefficient. The statically unrolled lookups are noticeably faster than their regular versions, so it’s a worthwhile transformation if the table is known at compile time.

For a bigger table (101 entries) the results are basically the same, but with the end-of-the-table-linear-lookup effect magnified. Note that the scale on the horizontal axis has changed.

Finally, I measured the effect that actually matters: how much faster my application runs. Here is a short sample run using the mapLookup function with some GHC and timing statistics:

   2,743,929,608 bytes allocated in the heap
[...]
  MUT     time    2.55s  (  2.64s elapsed)
  GC      time    0.33s  (  0.26s elapsed)
[...]
  Total   time    2.88s  (  2.91s elapsed)
[...]
./SimpleMain newp02-bin +RTS -s  2.89s user 0.02s system 99% cpu 2.912 total

And using the statically unrolled tree lookup:

     974,367,480 bytes allocated in the heap
[...]
  MUT     time    1.70s  (  1.72s elapsed)
  GC      time    0.20s  (  0.20s elapsed)
[...]
  Total   time    1.90s  (  1.92s elapsed)
[...]
./SimpleMain newp02-bin +RTS -s  1.90s user 0.02s system 99% cpu 1.922 total

There’s a reduction in allocation, but more importantly the running time of the program as a whole is reduced by about one third.

Conclusion

In the end this was a worthwhile exercise: I got a faster program and learnt about Template Haskell along the way.

Whether the same trick is useful in other places depends on the circumstances. The static compilation of the lookup was only useful because it is called so very often – maybe the algorithm could be changed at a higher level to avoid making so many lookups.

Diagrams + Cairo + Gtk + Mouse picking

2014-02-20T00:00:00+11:00

Diagrams is the best library for drawing diagrams in Haskell. But can it be used as part of a user interface so you can interact with parts of a diagram?

The answer is: yes.

In this article we walk through a simple example that combines Diagrams, its Cairo backend and Gtk, to show a diagram and determine which parts of the diagram the mouse is over.

The full source code for this example is at the bottom of this article, but we’ll also look at some excerpts in detail.

Let’s start with the diagram to be shown. It’s a simple picture of a house that a child might draw. The only special thing we do here is tag parts of the diagram with the value function. Each part – the wall, door, handle, roof, chimney and smoke – has a single string attached to it.

-- The diagram to be drawn, with features tagged by strings.
prettyHouse :: QDiagram Cairo R2 [String]
prettyHouse =
    let smoke = mconcat [ circle 0.05 # moveTo (p2(x,y))
                        | (x,y) <- [ (0.75,1.85), (0.8,2) ] ]
                  # stroke # fc grey
        roof = fromVertices [p2(0,1), p2(0.5,1.75), p2(1,1)]
                 # mapLoc closeTrail # pathFromLocTrail # stroke
                 # fc blue
        chimney = fromVertices [p2(0.7,1.45), p2(0.7,1.7),
                                p2(0.8,1.7),  p2(0.8,1.3)]
                 # mapLoc closeTrail # pathFromLocTrail # stroke
                 # fc green
        wall = square 1 # stroke # fc yellow
                 # alignBL # moveTo (p2(0,0))
        door = rect 0.2 0.4 # stroke # fc red
                 # alignBL # moveTo (p2(0.4,0))
        handle = circle 0.02 # stroke # fc black
                 # moveTo (p2(0.55,0.2))
    in mconcat [ smoke   # value ["smoke"]
               , roof    # value ["roof"]
               , chimney # value ["chimney"]
               , handle  # value ["handle"]
               , door    # value ["door"]
               , wall    # value ["wall"]
               ]

Now we can query the points in the diagram to see what’s there.

λ: sample prettyHouse (p2(0,0)) 
["wall"]
λ: sample prettyHouse (p2(0,1)) 
["roof"]
λ: sample prettyHouse (p2(0.55,0.2)) 
["wall","door","handle"]
λ: sample prettyHouse (p2(2,0.2)) 
[]

With this we’re actually most of the way there. However, the coordinate system of the diagram is not the same as the mouse coordinates we’ll get from Gtk. We could take the mouse coordinates and transform them into diagram coordinates, but let’s do it the other way around and make the diagram coordinates as close to the mouse coordinates as possible.

Gtk’s mouse coordinates have the origin (0,0) at the top left of the canvas. So first we move the diagram’s origin to the top left:

alignTL $ prettyHouse

Then we scale the diagram so that it’s the same width as the canvas:

scaleUToX 250 . freeze . alignTL $ prettyHouse

(The freeze makes the line widths scale up too.)

Now we are almost done: our mouse and diagram coordinates are the same size. The last wrinkle is that in diagrams-land positive Y-coordinates go up, but in Gtk-land positive Y-coordinates go down. We could reflect the diagram before we sample from it, but I found it easier just to negate the Y-coordinate.

λ: sample (scaleUToX 250 . freeze . alignTL $ prettyHouse) (p2 (100,-200))
["roof"]
λ: sample (scaleUToX 250 . freeze . alignTL $ prettyHouse) (p2 (100,-300))
["wall"]

And we’re done! The rest of the program is basically just Gtk plumbing.

Here’s the whole program.

import Control.Monad (void)
import Control.Monad.IO.Class (liftIO)
import Data.List (intercalate)
import Diagrams.Backend.Cairo
import Diagrams.Backend.Cairo.Internal
import Diagrams.Prelude
import Graphics.UI.Gtk

main :: IO ()
main = do
  -- Ordinary Gtk setup.
  void initGUI
  w <- windowNew
  da <- drawingAreaNew
  w `containerAdd` da
  void $ w `on` deleteEvent $ liftIO mainQuit >> return True

  -- Take our diagram, move the origin to the top left, and scale it
  -- to the size of the drawing area.
  let scaledHouse = scaleUToX 250 . freeze . alignTL $ prettyHouse

  -- Render the diagram on the drawing area.
  void $ da `on` exposeEvent $ liftIO $ do
    dw <- widgetGetDrawWindow da
    let (_,r) = renderDia Cairo
                          (CairoOptions "" (Width 250) PNG False)
                          scaledHouse
    renderWithDrawable dw r
    return True

  -- When the mouse moves, show the coordinates and the objects under
  -- the pointer.
  void $ da `on` motionNotifyEvent $ do
    (x,y) <- eventCoordinates
    liftIO $ do
      -- We negate the "y" coordinate when sampling because in Gtk the
      -- "down" direction is positive, but in our diagram the "up"
      -- direction is positive.
      putStrLn $ show (x,y) ++ ": "
                   ++ intercalate " " (sample scaledHouse (p2(x,-y)))
      return True

  -- Run the Gtk main loop.
  da `widgetAddEvents` [PointerMotionMask]
  widgetShowAll w
  mainGUI

-- The diagram to be drawn, with features tagged by strings.
prettyHouse :: QDiagram Cairo R2 [String]
prettyHouse =
    let smoke = mconcat [ circle 0.05 # moveTo (p2(x,y))
                        | (x,y) <- [ (0.75,1.85), (0.8,2) ] ]
                  # stroke # fc grey
        roof = fromVertices [p2(0,1), p2(0.5,1.75), p2(1,1)]
                 # mapLoc closeTrail # pathFromLocTrail # stroke
                 # fc blue
        chimney = fromVertices [p2(0.7,1.45), p2(0.7,1.7),
                                p2(0.8,1.7),  p2(0.8,1.3)]
                 # mapLoc closeTrail # pathFromLocTrail # stroke
                 # fc green
        wall = square 1 # stroke # fc yellow
                 # alignBL # moveTo (p2(0,0))
        door = rect 0.2 0.4 # stroke # fc red
                 # alignBL # moveTo (p2(0.4,0))
        handle = circle 0.02 # stroke # fc black
                 # moveTo (p2(0.55,0.2))
    in mconcat [ smoke   # value ["smoke"]
               , roof    # value ["roof"]
               , chimney # value ["chimney"]
               , handle  # value ["handle"]
               , door    # value ["door"]
               , wall    # value ["wall"]
               ]

Sequence, full laziness, space leak

2013-04-28T00:00:00+10:00

Recently I was surprised by the behaviour of a Haskell program I wrote. This simple example demonstrates the problem:

-- Simple.hs
import System.Environment
main = do
  n <- fmap (read . head) getArgs
  print (length (sequence (replicate n "abc")))

This computes the length of the list formed by every n-sized combination of the letters “a”, “b” and “c”. For example, if n is 4, the first few elements of the list are “aaaa”, “aaab”, “aaac”, “aaba”. (In other words, it’s a slow way to compute 3 to the power of n.) I expected this program to take near-constant space, even though the list might be very long, because it can be consumed by length as it is produced by sequence.

However, as n increases the space required grows exponentially.

For example:

$ ghc Simple
[1 of 1] Compiling Main             ( Simple.hs, Simple.o )
Linking Simple ...

$ ./Simple 10 +RTS -t
59049
<<ghc: 17814600 bytes, 35 GCs, 586672/1241512 avg/max bytes residency
(4 samples), 4M in use, 0.00 INIT (0.00 elapsed), 0.01 MUT (0.01
elapsed), 0.02 GC (0.02 elapsed) :ghc>>

$ ./Simple 11 +RTS -t
177147
<<ghc: 53244416 bytes, 102 GCs, 1740492/3603424 avg/max bytes
residency (6 samples), 11M in use, 0.00 INIT (0.00 elapsed), 0.02 MUT
(0.02 elapsed), 0.11 GC (0.14 elapsed) :ghc>>

The “in use” value is the interesting one: 4MB for n=10, and 11MB for n=11.

Even more surprising is what happens when you give your own definition of sequence:

-- Simple2.hs
import System.Environment
main = do
  n <- fmap (read . head) getArgs
  print (length (mySequence (replicate n "abc")))

mySequence [] = return []
mySequence (y:ys) = do
  x <- y
  xs <- mySequence ys
  return (x:xs)

Now the same examples as before:

$ ghc Simple2
[1 of 1] Compiling Main             ( Simple2.hs, Simple2.o )
Linking Simple2 ...

$ ./Simple2 10 +RTS -t
59049
<<ghc: 54185632 bytes, 105 GCs, 52976/61536 avg/max bytes residency (2
samples), 1M in use, 0.00 INIT (0.00 elapsed), 0.02 MUT (0.03
elapsed), 0.00 GC (0.00 elapsed) :ghc>>

$ ./Simple2 11 +RTS -t
177147
<<ghc: 176535256 bytes, 340 GCs, 52940/61464 avg/max bytes residency
(2 samples), 1M in use, 0.00 INIT (0.00 elapsed), 0.06 MUT (0.06
elapsed), 0.01 GC (0.01 elapsed) :ghc>>

This time we get constant space. Then take the same program, and turn on optimization:

$ ghc Simple2 -O
[1 of 1] Compiling Main             ( Simple2.hs, Simple2.o )
Linking Simple2 ...

$ ./Simple2 10 +RTS -t
59049
<<ghc: 7151368 bytes, 14 GCs, 696204/1274720 avg/max bytes residency
(4 samples), 5M in use, 0.00 INIT (0.01 elapsed), 0.01 MUT (0.01
elapsed), 0.03 GC (0.03 elapsed) :ghc>>

$ ./Simple2 11 +RTS -t
177147
<<ghc: 21323424 bytes, 41 GCs, 1615464/3571488 avg/max bytes residency
(5 samples), 10M in use, 0.00 INIT (0.00 elapsed), 0.01 MUT (0.02
elapsed), 0.08 GC (0.09 elapsed) :ghc>>

And memory use is high again — optimization has made it worse. What is going on?

The explanation is that GHC has tried to make our definition of mySequence faster, but at the expense of using more memory. It has observed that the value of mySequence ys does not depend on what value is chosen for x, and moved it out of the loop. In effect, it has transformed our definition into:

mySequence [] = return []
mySequence (y:ys) =
    let mSys = mySequence ys
    in do
      x <- y
      xs <- mSys
      return (x:xs)

The result for our combination-counting program is that to compute the big list of n-sized combinations, it first computes the list of (n-1)-sized combinations and keeps this sub-list in memory so that it can put an “a”, “b” or “c” on the front of each element. That is, while exploring all the combinations that start with “a”, the sub-list stays in memory so it doesn’t have to be computed again later to make all the combinations that start with “b” and “c”. The sub-list is pretty big, and that’s the cause of the high memory use.

This optimization is called “full laziness”, and you can turn it off:

$ ghc Simple2 -O -fno-full-laziness

$ ./Simple2 10 +RTS -t
59049
<<ghc: 54152416 bytes, 105 GCs, 31114/44416 avg/max bytes residency
(11 samples), 2M in use, 0.00 INIT (0.00 elapsed), 0.02 MUT (0.02
elapsed), 0.03 GC (0.03 elapsed) :ghc>>

$ ./Simple2 11 +RTS -t
177147
<<ghc: 176502040 bytes, 340 GCs, 30356/44416 avg/max bytes residency
(34 samples), 2M in use, 0.00 INIT (0.00 elapsed), 0.05 MUT (0.05
elapsed), 0.06 GC (0.06 elapsed) :ghc>>

With the optimization turned off, memory use is constant again.

When I first encountered this problem I had no idea what the cause was. After some searching I found this discussion on Stack Overflow, which explains what is going on and a couple of ways to work around it (apart from just turning off the full laziness optimization).

A second problem

A variation of the problem comes courtesy of Albert Lai. In this program, we also get exponential memory use, but changing the optimization level doesn’t fix it. Here is the program in question:

-- BadMemory.hs
import System.Environment(getArgs)
main = do
   n <- (read . head) `fmap` getArgs
   print (length (mysequence (replicate n "012")))
mysequence ms = foldr k (return []) ms where
   k m m' = do
     x <- m
     xs <- m'
     return (x:xs)

On the surface it looks similar to the previous programs. In particular, the definition of k is very close to mySequence above and so you might expect that the full laziness optimization is again the culprit. But turning off optimization here doesn’t help.

In this case the foldr is the problem. Recall the behaviour of foldr:

foldr f z [a,b,c,d,e] = f a (f   b (f   c (f   d (f   e     z))))
                      =   a `f` (b `f` (c `f` (d `f` (e `f` z))))

In the misbehaving problem, we have:

mysequence ms = foldr k (return []) ms
              = m0 `k` (m1 `k` (m2 `k` ... (mn `k` return []) ... ))

where ms = [m0, m1, ... mn]. If we examine the outermost call to k more closely, we get:

  m0 `k`                    (m1 `k` (m2 `k` ... (mn `k` return []) ... ))
= k                      m0 (m1 `k` (m2 `k` ... (mn `k` return []) ... ))
  (\m m' -> <body of k>) m0 (m1 `k` (m2 `k` ... (mn `k` return []) ... ))

This is equivalent in behaviour to:

let m  = m0
    m' = (m1 `k` (m2 `k` ... (mn `k` return []) ... ))
in <body of k>

The function k has done the same thing that full laziness did: it’s given a name (here m') to the big sub-list, causing it to be shared across the loop over the choice of the first element (the x <- m).

Diagrams internals

2012-11-18T00:00:00+11:00

This article covers a small part of the internals of Diagrams, a Haskell library for drawing static and animated diagrams. In particular, I give an overview of how a diagram is represented, how paths work, and how attributes are applied to diagrams. The Diagrams library has a lot in it, so not everything can be covered in great detail in such a short article.

Understanding the internals of Diagrams is not necessary for using it effectively – you can make complex diagrams without knowing any of how it works. You might be interested in the internals if you want to extend the library, or add a new rendering backend, or just fix a bug or add documentation. This material might also be of interest to people who want to see examples of type classes, existential types and heterogeneous lists.

Example

Throughout we’ll have a running example:

d :: Diagram SVG R2
d = unitSquare # fc red # clipBy (circle 0.3)

go = writeFile "example.svg" $ renderSvg $
       renderDia SVG (SVGOptions (Width 200)) d

Let’s ignore the renderSvg and writeFile parts, because they are just for producing the SVG format after the diagram has been rendered. For brevity’s sake let’s ignore renderDia, and concentrate on the diagram itself.

d = unitSquare # fc red # clipBy (circle 0.3)

The unit square is defined as a 4-sided polygon with radius sqrt(2)/2, oriented along the X-axis.

unitSquare = polygon with { polyType   = PolyRegular 4 (sqrt 2 / 2)
                          , polyOrient = OrientH }

This polygon ends up being defined as a closed path of straight lines between the corners of the square at points (±0.5, ±0.5).

Paths, trails and segments

To understand how this is represented, we need some Diagrams terminology. A “segment” is either a straight line or a Bézier curve, and doesn’t have any fixed position in space, which means translating a segment has no effect. A “trail” is a sequence of segments connected end-to-end. These still don’t have any fixed position, so can’t be translated. Trails can be open or closed. Finally, a “path” is a list of trails, plus a starting point for each trail. Because each trail in a path is fixed in some position, a path can be translated and one path can be placed on top of another.

So, our polygon above is a path with a single trail. The trail’s starting point is (0.5, -0.5), and the trail has three straight-line segments, defined by the vectors (0,1), (-1,0) and (0,-1). The trail is closed, so there is an implicit connection from the end of the trail back to the starting point.

Because it is being passed to renderDia, and the fc and clipBy modifications don’t alter its type, unitSquare must have the type Diagram b v. In this case, the backend b will be SVG and the vector space v will be R2. A diagram can be made from a path via the stroke function.

stroke and its friend stroke' deal with several things we’re not going to consider here: envelopes, traces, names and queries. For our purposes, all stroke does is wrap the path in a Prim type, and pass it mkQD, which makes a diagram from a single primitive.

Diagram representation

The basic diagram type QDiagram is a wrapper around a DUAL tree. A DUAL tree is an n-ary tree with data at the leaves and annotations that travel either up or down the tree. (A DUAL tree can also have data in the internal nodes, but Diagrams currently doesn’t use this feature.) For Diagrams, the primitives are the leaf data, transformations and styles are the downwards-travelling annotations, and envelopes, traces, names and queries are the upwards-travelling annotations. Here we will only concern ourselves with the leaves and the down-annotations, the L and D in DUAL.

Because all we have is a primitive – our path – we have only some leaf data and no annotations. The path is passed to the leaf function, which makes a leaf node. Now we have a diagram (tree) which consists of a single primitive (leaf node).

Attributes and styles

Now that we have a diagram, let’s consider next unitSquare # fc red. fc is defined, via fillColor as:

fillColor :: (Color c, HasStyle a) => c -> a -> a
fc = fillColor = applyAttr . FillColor . Last . SomeColor

Because Diagram is a member of the HasStyle type class, you can read the type informally as c -> Diagram -> Diagram. SomeColor is a wrapper that contains a value whose type is a member of the Color type class. The Last semigroup just keeps the “last” value: Last a <> Last b <> Last c == Last c. Finally, FillColor is a wrapper indicating which attribute we’re setting.

applyAttr is defined like this:

applyAttr :: (AttributeClass a, HasStyle d) => a -> d -> d
applyAttr = applyStyle . attrToStyle

attrToStyle converts an attribute into a Style. A Style is a container for carrying several attributes together: a Style value is just a Map from Strings to Attribute values:

newtype Style v = Style (M.Map String (Attribute v))

where an Attribute value is of some type in the AttributeClass type class – in this case, that type is FillColor. Let’s look at the definition of attrToStyle:

attrToStyle :: forall a v. AttributeClass a => a -> Style v
attrToStyle a =
  Style (M.singleton (show . typeOf $ (undefined :: a)) (mkAttr a))

The argument a is something like FillColor (Last (SomeColor red)). Starting from the left, you can see we are making a new Style value of a map containing a single key-value pair. The key is a string representation of whatever type a has – in this example it’s FillColor. The value part is a itself, wrapped up in type Attribute.

Note that there are two kinds of Attribute: transformable and non-transformable. FillColor is one of the non-transformable kind: transformations like scaling and translation don’t affect a diagram’s fill colour.

Now the style we have created needs to be applied to the diagram. The instance of HasStyle for a diagram defines applyStyle like this:

applyStyle =
    over QD . D.applyD . inj
    . (inR :: Style v -> Split (Transformation v) :+: Style v)

Intuitively, we know that applying a style to a diagram must somehow insert the style into the diagram tree as a down-annotation. The type of a down-annotation is:

type DownAnnots v = (Split (Transformation v) :+: Style v)
                ::: Name
                ::: ()

This is a heterogeneous list – you can think of ::: as a cons, like :, but at the type level. The Transformation type represents an affine transformation. The Split type is just like a regular monoid, but allows us to split the accumulated values into two halves. In Diagrams, this is used to separate the transformations into the frozen and unfrozen transformations. The :+: operator represents a monoid coproduct – we will skip the details, but here it means that we have an interleaving of the transformation pairs with style values, and every transformation acts on all the styles that follow it.

The definition of applyStyle can be read as: take the style, put it the right part of the coproduct (inR), put that into a DownAnnots value (inj), and insert the the DownAnnots value into the tree at the root (D.applyD). The “over QD” part just means to do all this inside the QD wrapper around the tree.

Let’s now apply the clipBy attribute.

unitSquare # fc red # clipBy (circle 0.3)

This is like the fill colour attribute, except the clip path is transformable. A circle is a like a unitSquare, except instead of being a path made of straight lines, it’s a path made of curves. The clipping attribute means that the only part of the square that will be shown is whatever overlaps with the circle. In this case, it’s like looking at the square through a circle-shaped hole.

Conclusion

Here I’ve only scratched the surface of Diagrams. If you want to learn more, the source code is easy to read once you’ve learned your way around the types and modules.

Automatic Minesweeper Solver

2012-06-15T00:00:00+10:00

The game Minesweeper is a fun diversion, but even more fun would be to get the computer to solve it for us. I’ve written a basic solver for the version of Minesweeper from Simon Tatham’s excellent Portable Puzzle Collection, called Mines. My solver interacts with the game just like a human player would: by reading the screen’s contents and moving and clicking the mouse.

Here is a video of the solver in action.

Reading the screen

Reading the screen has two parts: getting the screen’s contents, and then interpreting them. The first part is simple in X, by using xdotool to find the window with the right name, xwddump to dump the window’s contents to a file, and Imagemagick’s convert to convert the image format into PNG.

Interpreting the contents is trickier. I followed the policy of “least robustness” — the reading will break if the window is too small, and relies on the specific way that Mines draws its board. Essentially, the steps are:

Find the grid within the window by sending out a line diagonally from the top-left corner of the window until it hits the dark top or left edge. When we hit it, follow the edge back to the top-left corner of the grid.
From the top-left grid corner, move into the top-left cell of the grid. Figure out its width by tracing the top edge of the cell until we hit the border of the cell to the right. Do this repeatedly until we hit the end of the grid. Now we know how many cells across are in the grid, and where they are positioned in the window.
Do step 2 again, but in the vertical direction.
Now we know where all the cells are in the window, and we can figure out where the numbers and flags are. We do this by looking at the colours of the pixels in the cells; fortunately each number has a unique colour. For example, if a cell has lots of blue pixels, then it contains the number “1”.

Working out where to move

The next step is to figure out which squares contain mines and which ones are safe. Other people have already come up with clever ways to do this (for example, see the Mines source code which contains a solver). I wanted something fast enough to watch, but simple and powerful. I first modelled the problem in MiniZinc.

int : width;
int : height;
int : w = width-1;
int : h = height-1;

% Does the cell contain a mine?
array [0..w, 0..h] of var bool : mined;

% Each clues is a triple (x,y,n), which means the cell at location
% (x,y) contains the number n.  If n is -1, then the cell contains a
% flag.
int : nclues;
array [1..nclues, 1..3] of int : clues;

constraint
  forall (c in 1..nclues)
    ( let { int : x = clues[c,1],
            int : y = clues[c,2],
            int : n = clues[c,3] }
      in if n == -1
         then mined[x,y] = true
         else mined[x,y] = false /\
              sum( [ bool2int(mined[x+i,y+j]) | i,j in [-1,0,1] ] ) == n
         endif );

I was pleased that the model is so simple. Now, to figure out if a cell is safe to click on, we “guess” that the cell has a mine in it. If the solver says that the problem is now unsolvable, then the guess was wrong which means that the cell is safe. The same thing can be done in the other direction: guess that the cell is safe, and if that’s impossible, then the cell must have a mine.

One truly wonderful feature of Mines that is not usually present in Minesweeper games is that it can generate “guaranteed solvable” puzzles. This is great for testing the solver, because it should be able to solve any puzzle that it’s faced with.

Making moves

Simulating mouse movement and clicking is easy with xdotool. A sample command looks like:

xdotool search --onlyvisible --name Mines
  mousemove --window %1 763 81 click 1
  mousemove --window %1 763 108 click 1
  mousemove --window %1 763 135 click 1
  mousemove --window %1 763 162 click 1

which means “find the window called Mines, move to pixel 763,81 in that window, then click, then move to 763,108 and click”, etc.

Going faster

With this set up, the solver can finish puzzles in about the same that it would take me to do it by hand. This is not good enough for me, so I tried to find the slowest part of the program and improve it.

A lot of time is spent in the thinking part, and a large component of that is due to the way I am using MiniZinc. For every cell that I test, I compile the MiniZinc program from scratch, and this is really slow.

Also, I’m not making good use of one of constraint programming’s strengths: constraint propagation. We’d be able to learn many safe and mined squares just by propagating the constraints without doing any search. Unfortunately this is currently impossible in MiniZinc.

I translated the model to be used with Gecode. With Gecode I can compile the program once, and I can ask it to do only propagation without search. I used the strategy of trying propagation first, and only if that learns nothing does the solver resort to a full search. The result is a much faster solver!

Conclusions, limitations and ideas

The end result is a solver that can usually finish a 30x16 grid with 99 mines (roughly equivalent to Windows Minesweeper expert mode) in about 20-30 seconds. However, there are some limitations.

The solver doesn’t know how many mines are in the puzzle. This means that in some situations it gets stuck.
At some window sizes it can’t read the grid properly.
The interface is a bit rough around the edges and might crash if it sees something it isn’t expecting. Once it gets going and starts moving the mouse around and clicking madly, it can be difficult to interrupt.

The first limitation can be overcome by parsing the “Marked” line in the status bar at the bottom of the window. The other two could be fixed by a bit of programming effort.

The solver could be made faster by calling X library functions directly instead of dumping the window’s contents to a file and reading it back in. Also, the thinking part could be faster if it included some basic Minesweeper logic instead of always relying on the external constraint solver.

Get the source

The source code is available at GitHub. To compile it you will need GHC (and some packages from Cabal) and Gecode. To run it you will also need xdotool, xwddump and Imagemagick.

Solving Hexiom using Constraint Programming

2012-05-03T00:00:00+10:00

A few months ago, Laurent Vaucher wrote a couple of articles (starting with this one) about solving the puzzle game Hexiom using search algorithms and hand-crafted constraint propagation. It looked like an interesting puzzle, and I was curious about how well a generic constraint solver would perform and how to model the problem. Here I describe how I used MiniZinc and Gecode to tackle it.

(If you’re unfamiliar with the rules of Hexiom, the best way to learn is to try playing it, which you can do on Kongregate.)

Modelling

I modelled the game with one integer variable for each cell on the board. Each cell’s variable takes a value from 0 to 7: values 0 to 6 represent a tile numbered 0 to 6, and value 7 means that the cell is empty.

Each level has a hexagonal board of varying size. One step of modelling this problem is to map the hexagonal coordinates of the board onto rectangular coordinates. First, I added a few “dummy” cells to make the board more rectangular. The rows can be numbered in an obvious way, but the columns are trickier; I numbered the leftmost and next-to-leftmost columns as 1, the next two columns 2, and so on. This is perhaps not the best numbering, because it makes calculating the neighbours of a cell harder.

Here are examples of the numbering. The # characters represent the dummy cells that are not part of the original puzzle, but fill out the rows. With these added, the cells form a “square” of size (2*size-1).

                                       Size 4        
          Size 3                                           
                                  1  # * * * * # #   
       1 # * * * #                2 # * * * * * #    
       2  * * * * #               3  * * * * * * #   
Row    3 * * * * *          Row   4 * * * * * * *    
       4  * * * * #               5  * * * * * * #   
       5 # * * * #                6 # * * * * * #    
         1122334455               7  # * * * * # #   
                                    11223344556677   
          Column                                     
                                       Column

With this numbering scheme, calculating the neighbours of a given cell is not simple. It took me a while to realise that it depends on both the row and the size of the grid. Here is the formula, where i and j are the row and column respectively:

neighbours(i,j) =  { (i, j±1),
                     (i±1, j-1+(size+i) mod 2),
                     (i±1, j+(size+i) mod 2) }

A level is specified by a few components:

the size of the board
the number of each kind of tile
the positions of the fixed tiles

For example, level 10 looks like this in Laurent’s format:

3
  +.+. .
 +. 0 . 2
 . 1+2 1 .
  2 . 0+.
   .+.+.

This level has a board of size 3, two “0” tiles, two “1” tiles, three “2” tiles and many “blank” tiles. The seven tiles that are prefixed by “+” symbols are fixed in place.

Hexiom comes with a set of 40 levels, which Laurent has kindly made available in a machine-readable format. My first task was to translate these from Laurent’s format into one that can be used with MiniZinc. The program itself is not very interesting, but here is the output for level 10:

size = 3;
counttiles = array1d(0..7, [2,2,3,0,0,0,0,18]);
numfixed = 13;
fixedrow = [1,1,1,1,2,2,3,4,4,5,5,5,5];
fixedcol = [1,2,3,5,1,5,3,4,5,1,3,4,5];
fixedval = [7,7,7,7,7,7,2,7,7,7,7,7,7];

Note that the dummy tiles are included here; they are counted as blanks, and are fixed in their positions.

MiniZinc model

Here I describe some of the interesting parts of the MiniZinc model. The whole thing is available here.

The rows and columns are numbered from 1 to 2*size-1 – I call this range “r”.

% The dimensions of the square array that encloses the hexagon.
set of int : r = 1..2*size-1;

There are two sets of decision variables.

% The decision variables.  If x[i,j]=v, then we place a tile marked
% "v" at position (i,j).  Value 7 represents "no tile".
array [r,r] of var 0..7 : x;

% Auxiliary decision variables.  We have t[i,j]=1 if and only if
% x[i,j] < 7.  In other words, t[i,j]=1 if and only if there is a
% tile at position (i,j).
array [r,r] of var 0..1 : t;

% Link x and t variables.
constraint forall (i,j in r) (t[i,j] = bool2int(x[i,j] < 7));

The rest of the model follows in a straightforward manner. I tried not to make it complicated. One awkward part is calculating the number of neighbouring cells that contain tiles, because we have to check that the coordinates refer to a cell on the board before accessing the variable at those coordinates.

% The primary constraint of the puzzle.  Each cell either has a
% tile or it does not.  If it does not, then it has value 7 and
% there are no further constraints.  If there is a tile, then the
% number of tiles among its neighbouring cells is equal to the
% value on the tile.
%
% The constraint looks more complicated than it is, due to the way
% we force a Hexiom to look like a square, and that we have to
% check the bounds of every array access.
constraint
  forall (i,j in r)
       ( (t[i,j] = 0) \/
         (x[i,j] =
           sum([ if j+1 in r then t[i,j+1] else 0 endif
               , if j-1 in r then t[i,j-1] else 0 endif
               , if i-1 in r /\ j-1+((size+i) mod 2) in r
                   then t[i-1,j-1+((size+i) mod 2)] else 0 endif
               , if i-1 in r /\ j+((size+i) mod 2) in r
                   then t[i-1,j+((size+i) mod 2)] else 0 endif
               , if i+1 in r /\ j-1+((size+i) mod 2) in r
                   then t[i+1,j-1+((size+i) mod 2)] else 0 endif
               , if i+1 in r /\ j+((size+i) mod 2) in r
                   then t[i+1,j+((size+i) mod 2)] else 0 endif
               ])) );

The other two constraints are simple; they ensure that we have placed the right number of each kind of tile, and that the fixed tiles are in their place.

% There must be the specified number of each value of tile.
constraint forall (v in 0..7)
  (count([x[i,j] | i,j in r], v, counttiles[v]));

% Put each specified fixed tile in its place.
constraint forall (i in 1..numfixed)
             ( x[fixedrow[i], fixedcol[i]] = fixedval[i] );

Finally, the search heuristic is crucial. Here I follow Laurent’s advice, which is to pick the cells in order, and try high value tiles first. In MiniZinc terms, I interleave the t variables with the x variables, and try larger values first (indomain_max).

solve :: int_search([ if k = 0 then t[i,j] else x[i,j] endif
    | i,j in r, k in 0..1], input_order, indomain_max, complete)
satisfy;

Results

Without the heuristic above, the results are mixed. Most of the levels can be solved quickly, but levels 38 and 40 in particular take a very long time. However, with the heuristic the results are much better. Level 40 is now trivial, and level 38 takes about 15 seconds. In fact, the times can be summarised as follows:

Level 38	~15 seconds
Level 36	~120 milliseconds
All other levels	< 20 milliseconds

(These are just for running Gecode to find a solution, and don’t include the level translation or MiniZinc parsing.)

Other notes

Before I used Laurent’s heuristic, I experimented briefly with singleton arc consistency, a strong but very expensive kind of constraint propagation. It improved performance on some levels, but not to the degree I got just by changing the search.

Laurent has also tried applying Gecode to this problem (directly, rather than via MiniZinc) and got even better results! It would be interesting to see how his model differs from mine.

I tried a lazy clause generation solver with my model, but it performed worse than Gecode. I had expected LCG to perform well on this problem, so I’m curious to figure out why it didn’t work.