Message Boards Message Boards

GROUPS:

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: enter image description here

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]
]
ShowAdvancedGrid[grid_, hc_, vc_] := Module[{},
  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}];
  ];
 ]
ShowAdvancedGrid[grid, hclues, vclues]

Giving:

enter image description here

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

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.

POSTED BY: R L
Answer

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 ;-)

enter image description here - another post of yours has been selected for the Staff Picks group, congratulations !

We are happy to see you at the tops of the "Featured Contributor" board. Thank you for your wonderful contributions, and please keep them coming!

Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract