| <<DiscreteMath`Combinatorica`
(*This program counts, lists and displays the possible 3 - row patterns in an n x n crossword puzzle*)
plotnice = ArrayPlot [ #, Frame -> False, Mesh -> True, MeshStyle -> \
GrayLevel [ 0 ] ] &;
For [ n = 3, n <= 7, n++,
usablemods = {0, 1, 3, 7};
usablenumbers = Function [ MemberQ [ usablemods, Mod [ #, 8 ] ] ];
goodnumbers = Union [ Table [ k, {k, 0, 2^(n - 3) - 1} ], Table [ k, {k,
2^(n - 1), 2^n - 2} ] ];
numbers = Select [ goodnumbers, usablenumbers ];
rows = Table [ PadLeft [ IntegerDigits [ numbers [ [ j ] ],
2 ], n ], {j, 1, Length [ numbers ]} ];
no101s = Function [ FreeQ [ Partition [ #1, 3, 1 ], {1, 0, 1} ] ];
no1001s = Function [ FreeQ [ Partition [ #1, 4, 1 ], {1, 0, 0, 1} ] ];
legalrows = Select [ Select [ rows, no1001s ], no101s ];
threerows = Tuples [ legalrows, 3 ];
transposedthreerows = Transpose /@ threerows;
freeof101s = Function [ FreeQ [ #, {1, 0, 1} ] ];
transposedno101s = Select [ transposedthreerows, freeof101s ];
legalthreerows = Transpose /@ transposedno101s;
insertzerorows = Function [ Append [ Prepend [ #, Table [ 0, {n} ] ], Table [ 0, {n} ] ] ];
legalthreerowswithzeros = insertzerorows /@ legalthreerows;
finalthreerows = {};
legalthreerowscount = 0;
For [ v = 1, v <= Length [ legalthreerowswithzeros ], v++,
puzzlegraph = Table [ legalthreerowswithzeros [ [ v, r, s ] ], {r,
1, 5}, {s, 1, n} ];
verts = {};
For [ i2 =
1, i2 <= 5, i2++, For [ j2 = 1, j2
<= n, j2++, If [ puzzlegraph [ [ i2, j2 ] ] == 1, verts = Append [
verts, j2 + 5n - n*i2 ] ] ] ];
thegraph = DeleteVertices [ GridGraph [ n, 5 ], verts ];
If [ ConnectedQ [ thegraph ] == True, connectedcount = connectedcount + 1 ];
(*graph = ShowGraph [ thegraph, DisplayFunction -> Identity ];
thepuzzle = ArrayPlot [ legalthreerowswithzeros [ [ v ] ], Frame -> False,
Mesh -> True, MeshStyle -> GrayLevel [
0 ], DisplayFunction -> Identity ]; *)
(*Show [ GraphicsArray [ {thepuzzle, graph} ] ]; *)
(*Print [ ConnectedQ [ thegraph ] ]; *)
If [ ConnectedQ [ thegraph ] == True, legalthreerowscount = \
legalthreerowscount +
1; finalthreerows = Append [ finalthreerows, legalthreerows [ [ v ] ] ] ];
]
plotnice /@ finalthreerows;
Print [ "the number of threerow arrangements in a ", n, " x ", n, " puzzle is ", legalthreerowscount ] ]
| 