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] ] 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:

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!