20
$\begingroup$

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?

enter image description here

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;
hintNumPad = {};
{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}] & /@ 
     hintNumPad}]

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

enter image description here

$\endgroup$
3
  • 1
    $\begingroup$ 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. $\endgroup$ Sep 6 '14 at 3:09
  • 1
    $\begingroup$ 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 ? $\endgroup$ Sep 6 '14 at 10:46
  • $\begingroup$ @High Performance Mark Thanks for pointing out my mistakes. $\endgroup$
    – Putterboy
    Sep 6 '14 at 14:10
22
$\begingroup$

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] &@
        ArrayPad[#, -1] &@del@Transpose@del@ArrayPad[#, 1] &@
    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]]

enter image description here

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

enter image description here

$\endgroup$
3
  • $\begingroup$ Thank you so much. To tell the true, looking at your code, Mathematica suddenly became a complete foreign language to me! :) $\endgroup$
    – Putterboy
    Sep 6 '14 at 13:31
  • 1
    $\begingroup$ @Putterboy It was the same for me two years ago. There is a nice guide: What the @#%^&*?! do all those funny signs mean?. $\endgroup$
    – ybeltukov
    Sep 6 '14 at 13:40
  • $\begingroup$ @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. $\endgroup$
    – ubpdqn
    Sep 7 '14 at 1:20
9
$\begingroup$

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

Mathematica graphics

$\endgroup$
1
  • 1
    $\begingroup$ +1 Mathematica has function for everything :) $\endgroup$
    – ybeltukov
    Sep 7 '14 at 6:20
4
$\begingroup$

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

enter image description here

or static version:

enter image description here

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"])]

enter image description here

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.