# Solving the UK Intelligence Agency's Christmas Puzzle

Posted 3 years ago
8070 Views
|
4 Replies
|
14 Total Likes
|

Dear All,

Just an hour ago I saw this post at Gizmodo:

## Can You Solve the UK Intelligence Agency's Christmas Puzzle?

I was intrigued! The puzzle was given as an image:

Where the numbers before each row/column denotes that there should be n consecutive blocks in that row. Between each block there must be at least one delimiter (a white cell). So I quickly made a solver, to solve this puzzle:

ClearAll[SpacesDistributeOverN, Possibilities, CheckCommons, FilterPossibilities, GetRow, GetColumn, SetRow, SetColumn, TryRow, TryColumn, ShowAdvancedGrid]
SpacesDistributeOverN[s_, p_] := Flatten[Permutations /@ (Join[#, ConstantArray[0, p - Length[#]]] & /@ IntegerPartitions[s, p]), 1]
Possibilities[hint_, len_] := Module[{p = hint, l = len, b = Length[hint]},
Spaces = # + (Prepend[Append[ConstantArray[1, b - 1], 0], 0]) & /@ (SpacesDistributeOverN[l - Total@p - (b - 1), b + 1]);
Flatten /@ (Riffle[#, Map[Table[1, {#}] &, p, {1}]] & /@ Map[Table[0, {#}] &, Spaces, {2}])
]
CheckCommons[possibilities_] := Module[{poss = possibilities, tmp = possibilities[[1]], len = (possibilities[[1]]) // Length, rowequals = Equal @@@ ( possibilities\[Transpose])},
Table[If[rowequals[[i]], tmp[[i]], Null], {i, 1, len}]
]
FilterPossibilities[possibilities_, knowns_] := Cases[possibilities, knowns /. Null -> _]

GetRow[grid_, row_] := grid[[row]]
GetColumn[grid_, column_] := (grid\[Transpose])[[column]]
SetRow[grid_, row_, newrow_] := Module[{tmp = grid}, tmp[[row]] = newrow; tmp]
SetColumn[grid_, column_, newcol_] := Module[{tmp = grid\[Transpose]},
tmp[[column]] = newcol;
tmp\[Transpose]
]

TryRow[grid_, row_, clues_] := Module[{},
tmprow = GetRow[grid, row];
newclues = clues[[row]];
tmppos = Possibilities[newclues, tmprow // Length];
tmpfilpos = FilterPossibilities[tmppos, tmprow];
newrow = CheckCommons[tmpfilpos];
SetRow[grid, row, newrow]
]
TryColumn[grid_, column_, clues_] := Module[{},
tmpcol = GetColumn[grid, column];
newclues = clues[[column]];
tmppos = Possibilities[newclues, tmpcol // Length];
tmpfilpos = FilterPossibilities[tmppos, tmpcol];
newcol = CheckCommons[tmpfilpos];
SetColumn[grid, column, newcol]
]
tmpgrid = grid /. {1 -> Graphics[{Black, Rectangle[]}, ImageSize -> 16],
Null -> Graphics[{Gray, Rectangle[]}, ImageSize -> 16],
0 -> Graphics[{White, Rectangle[]}, ImageSize -> 16]};
{dimy, dimx} = grid // Dimensions;
maxhlen = Max[Length /@ hc];
newhclues = Join[Table[Null, {maxhlen - Length[#]}], #] & /@ hc;
maxvlen = Max[Length /@ vc];
newvclues = Join[Table[{Null}, {maxhlen}], vc];
newvclues = Join[Table[Null, {maxvlen - Length[#]}], #] & /@ newvclues;
tmpgrid = Table[Join[newhclues[[i]], tmpgrid[[i]]], {i, 1, dimy}];
tmpgrid = tmpgrid\[Transpose];
tmpgrid = Table[Join[newvclues[[i]], tmpgrid[[i]]], {i, 1, dimx + maxhlen}];
tmpgrid = tmpgrid\[Transpose];
Grid[tmpgrid, Frame -> None, Alignment -> Center, ItemSize -> {1, 1}, Spacings -> {0, 0}]
]


Those are the helper and visualisation functions, now we need the clues and the simple algorithm to solve it:

hclues = {
{7, 3, 1, 1, 7},
{1, 1, 2, 2, 1, 1},
{1, 3, 1, 3, 1, 1, 3, 1},
{1, 3, 1, 1, 6, 1, 3, 1},
{1, 3, 1, 5, 2, 1, 3, 1},
{1, 1, 2, 1, 1},
{7, 1, 1, 1, 1, 1, 7},
{3, 3},
{1, 2, 3, 1, 1, 3, 1, 1, 2},
{1, 1, 3, 2, 1, 1},
{4, 1, 4, 2, 1, 2},
{1, 1, 1, 1, 1, 4, 1, 3},
{2, 1, 1, 1, 2, 5},
{3, 2, 2, 6, 3, 1},
{1, 9, 1, 1, 2, 1},
{2, 1, 2, 2, 3, 1},
{3, 1, 1, 1, 1, 5, 1},
{1, 2, 2, 5},
{7, 1, 2, 1, 1, 1, 3},
{1, 1, 2, 1, 2, 2, 1},
{1, 3, 1, 4, 5, 1},
{1, 3, 1, 3, 10, 2},
{1, 3, 1, 1, 6, 6},
{1, 1, 2, 1, 1, 2},
{7, 2, 1, 2, 5}
};
vclues = {{7, 2, 1, 1, 7},
{1, 1, 2, 2, 1, 1},
{1, 3, 1, 3, 1, 3, 1, 3, 1},
{1, 3, 1, 1, 5, 1, 3, 1},
{1, 3, 1, 1, 4, 1, 3, 1},
{1, 1, 1, 2, 1, 1},
{7, 1, 1, 1, 1, 1, 7},
{1, 1, 3},
{2, 1, 2, 1, 8, 2, 1},
{2, 2, 1, 2, 1, 1, 1, 2},
{1, 7, 3, 2, 1},
{1, 2, 3, 1, 1, 1, 1, 1},
{4, 1, 1, 2, 6},
{3, 3, 1, 1, 1, 3, 1},
{1, 2, 5, 2, 2},
{2, 2, 1, 1, 1, 1, 1, 2, 1},
{1, 3, 3, 2, 1, 8, 1},
{6, 2, 1},
{7, 1, 4, 1, 1, 3},
{1, 1, 1, 1, 4},
{1, 3, 1, 3, 7, 1},
{1, 3, 1, 1, 1, 2, 1, 1, 4},
{1, 3, 1, 4, 3, 3},
{1, 1, 2, 2, 2, 6, 1},
{7, 1, 3, 2, 1, 1}};
{hsize, vsize} = {vclues // Length, hclues // Length};

Total[Flatten[vclues]]
Total[Flatten[hclues]] (* should be equal! *)

(*initialize grid*)
grid = Table[Null, {vsize}, {hsize}] ;

(* these two hints are necessary not more... *)
grid[[9, -7]] = 1;
grid[[-9, 12]] = 1;

oldgrid =.;
RowColumn = 1;
first = 0;
While[! (grid === oldgrid),
If[first == 0,
Do[grid = TryRow[grid, i, hclues], {i, vsize}];
Do[grid = TryColumn[grid, i, vclues], {i, hsize}];
first = 1
];
oldgrid = grid;
RowColumn *= -1;
If[RowColumn == 1,
Do[grid = TryColumn[grid, i, vclues], {i, hsize}];,
Do[grid = TryRow[grid, i, hclues], {i, vsize}];
];
]


Giving:

So we solved it! Now let's see where this hint leads us:

BarcodeRecognize[(1 - grid) // Image]


www.gchq.gov.uk/puzz

At this moment the entire website is down, but as soon as it is up, the next puzzle should be there! Happy Puzzling!

4 Replies
Sort By:
Posted 3 years ago
 Note that 22 cells are given to help you out. As I found out; only 2 are necessary in order to have a unique solution.
Posted 3 years ago
 This works a bit faster for me; not sure about the algorithm.
 Most likely because he/she uses all the hints, I'm just using 2 of them. With all of the hints the solving is much easier of course... I actually solved it without hints first, then there are multiple solutions, which are pinned down' by supplying two hints.That code might have been inspired by mine--which is fine---as some of the choices are really similar and also the exact same options, in the same order, method is exactly the same. Code is just been rewritten in places Plus@@... instead of Total@..., and similar small changes. Especially the last line:BarcodeRecognize[(1 - constraintTable) // Image] gives it away... Could've been BarcodeRecognize@Image[1-constraintTable]` or such, but no exactly like mine ;-)