# How to generate a blank crossword sheet?

I attempted to generate a blank crossword sheet. My method is by combining the rows and columns as shown on the graph below. However, some of the across and down numbers then appeared out of place after combining. What is the better way to obtain a blank crossword sheet?

fillRow[i_] := (
startPos = RandomInteger[{1, randomStartPos}] ;
randomWordLen = RandomInteger[{minWordLen, dimX - startPos}];
endPos = startPos + randomWordLen - 1;
Do[cwSheet[[i, n]] = 0, {n, startPos, endPos}];
AppendTo[ hintNumPad, { counter++, {startPos, dimX - i}}]
If[endPos <= dimX/2,
randomWordLen = RandomInteger[{minWordLen, dimX - endPos - 1}];
Do[cwSheet[[i, n]] = 0, {n, dimX, dimX - randomWordLen + 1, -1}];
AppendTo[
hintNumPad, { counter++, {dimX - randomWordLen + 1, dimX - i}}];
]
);

fillCol[j_] := (
startPos = RandomInteger[{1, randomStartPos}] ;
randomWordLen = RandomInteger[{minWordLen, dimY - startPos}];
endPos = startPos + randomWordLen - 1;
Do[cwSheet[[   n , j]] = 0, {n, startPos, endPos}];
AppendTo[ hintNumPad, { counter++, { j, dimY - startPos  }}]
If[endPos <= dimX/2,
randomWordLen = RandomInteger[{minWordLen, dimX - endPos - 1}];
Do[cwSheet[[n, j]] = 0, {n, dimY, dimY - randomWordLen + 1, -1}];
AppendTo[ hintNumPad, { counter++, {j, randomWordLen - 1  }}];
]
);

minWordLen = 3;
{dimX, dimY} = {9, 9};
randomStartPos = 4;
Clear[cwSheet];

cwSheet = ConstantArray[1, {dimX, dimY}];

counter = 1;
Do[fillRow[k], {k, 1, dimY, 2}];

counter = 1;
Do[fillCol[k], {k, 1, dimX, 2}];

g = MatrixPlot[cwSheet , Mesh -> All,
Frame -> False,
ColorFunction -> "Monochrome",
Epilog -> {Text[Style[#[[1]], 9], #[[2]] + {-0.9, 0.8}] & /@


The correct positions of the hint numbers should look like this:

• They look in-place to me, given the original rows and columns; seems like you need to tweak the algorithm that generates the original rows and columns themselves. – Andrew Cheong Sep 6 '14 at 3:09
• It looks entirely wrong to me, even after the movements of numbers indicated in your final drawing. In crosswords I am familiar with (UK, occasionally US) there would be a 2 where you have 4 in the first row, a 3 where you have 2 in the first column, 4 where you have 2 in the third column, etc. Perhaps number the solution spaces after assembling the grid ? – High Performance Mark Sep 6 '14 at 10:46
• @High Performance Mark Thanks for pointing out my mistakes. – Putterboy Sep 6 '14 at 14:10

One can use CellularAutomaton and apply only one rule: do not allow 4 white cells together!

ClearAll[f];
f@{{1, 1, _}, {1, _, _}, {_, _, _}} = 0;
f@{{_, 1, 1}, {_, _, 1}, {_, _, _}} = 0;
f@{{_, _, _}, {_, _, 1}, {_, 1, 1}} = 0;
f@{{_, _, _}, {1, _, _}, {1, 1, _}} = 0;
f@{_, {_, x_, _}, _} := If[Random[] < 0.1, 1, x];


Here 0 and 1 mark black and white cells respectively. These rules are so simple so we have to introduce an enhancement: delete words of length 2 and select large morphological components.

del = # //. {x___, 0, 1, 1, 0, z___} :> {x, 0, 0, 0, 0, z} &;

ca = Unitize@SelectComponents[#, Large] &@
MorphologicalComponents[#, CornerNeighbors -> False] &@
CellularAutomaton[{f[#] &, {}, {1, 1}}, #, {{200}}][[1]] &;


Now we can apply ca several times to obtain better result

res = Nest[ca, ConstantArray[0, {12, 12}], 4];


It remains to find labels and show the result

labels = Position[#, {_, {0, 1, 1}, _} | {{_, 0, _}, {_, 1, _}, {_, 1, _}},
{2}] &@Partition[#, {3, 3}, 1] &@ ArrayPad[res, 1];

ArrayPlot[1 - res, Mesh -> All, Frame -> False, MeshStyle -> Black,
Epilog -> MapIndexed[Text[Style[#2[[1]], 9],
{#[[2]] - 0.95, Length@res - #[[1]] + 0.95}, {-1, 1}] &, labels]]


P.S. There is a small probability to obtain incorrect field.

CellularAutomaton apply rules with periodic boundary conditions. One can treat it as the torus topology of the crossword (code):

• Thank you so much. To tell the true, looking at your code, Mathematica suddenly became a complete foreign language to me! :) – Putterboy Sep 6 '14 at 13:31
• @Putterboy It was the same for me two years ago. There is a nice guide: What the @#%^&*?! do all those funny signs mean?. – ybeltukov Sep 6 '14 at 13:40
• @ybeltukov +1 thanks for a this very instructive post and creative use of cellular automata, particularly nice to have random component and constraint word length > 2. – ubpdqn Sep 7 '14 at 1:20

By Using HitMissTransform[] to detect "words" of length > 1

(*Generate a symmetric Puzzle**)
n = 15;
f = Unitize@(# + Transpose@#) &;
i = f@BlockRandom[RandomChoice[{0, 1}, {n, n}]];

(*Calculate*)
k = {{-1, 1, 1}};
p = Position[f@ImageData@HitMissTransform[Image@i, k, Padding -> 0], 1];

(* Print *)
ArrayPlot[i - 1, Mesh -> All,
Epilog -> MapIndexed[Text[#2[[1]],#1] &, SortBy[p/.{a_,b_}:>{b -.8, n-a +.8}, -#[[2]] &]]]


• +1 Mathematica has function for everything :) – ybeltukov Sep 7 '14 at 6:20

The following generates square crosswords. It has a number of limitations.

cw[rv_] :=
Module[{lg, sa, val, a, d, i, sel, text},
lg = Length[rv[[1]]];
sa = SparseArray[rv];
val = Complement[Tuples[Range[lg], 2], sa["NonzeroPositions"]];
a[list_, x_] := And[Not[MemberQ[list, x + {0, -1}]],
MemberQ[list, x + {0, 1}]
];
d[list_, x_] :=
And[Not[MemberQ[list, x + {-1, 0}]], MemberQ[list, x + {1, 0}]];
i[list_, x_] :=
And @@ (Not@MemberQ[list, x + #] & /@ {{-1, 0}, {1,
0}, {0, -1}, {0, 1}});
sel = Select[val, Or[a[val, #], d[val, #], i[val, #]] &];
text = MapIndexed[
Text[First@#2, {Last@#1, lg - First@#1} - {0.8, -0.8}] &, sel];
ArrayPlot[rv, Mesh -> All, Epilog -> text]]


Examples:

anim = cw[RandomVariate[BernoulliDistribution[0.4], #]] & /@ {{4,
4}, {5, 5}, {6, 6}, {7, 7}, {8, 8}, {9, 9}, {10, 10}};


or static version:

If you happened to have your square crossword, e.g. this rather uninspiring one:

mat = {{0, "C", "R", "O", "S", "S", 0},
{0, "A", 0, 0, "E", 0, "H"},
{0, "N", "O", "T", "E", 0, "E"},
{0, 0, 0, 0, 0, 0, "L"},
{"T", "O", "E", 0, "H", "O", "P"},
{"A", 0, "R", 0, "A", 0, "S"},
{"P", "L", "A", "N", "T", 0, 0}
};
cw[mat /. {_String :> 0, 0 -> 1}]
Show[cw[mat /. {_String :> 0, 0 -> 1}],
Graphics@Text[
Style[Extract[mat, #], Red,
20], {Last@#, 7 - First@#} + {-0.5, 0.5}] & /@ (SparseArray[
mat]["NonzeroPositions"])]