|
(*This program counts, lists and displays the possible three - row centers \ of an n X n (n odd) crossword puzzle with rotational symmetry.*)
plotnice = ArrayPlot [ #, Frame -> False, Mesh -> True, MeshStyle -> \
GrayLevel [ 0 ] ] &;
For [ w = 1, w <= 7, w++,
n = 2w + 1;
t = n - 3;
arrangements = {};
For [ r = 0, r <= t, r++,
m = Compositions [ n - r, r + 1 ];
m2 = Select [ m, FreeQ [ #, 2 ] & ];
m1 = Select [ m2, FreeQ [ #, 1 ] & ];
arrangements = Join [ arrangements, m1 ] ];
possiblecolumns = {};
For [ j = 1, j <= Length [ arrangements ], j++,
original = arrangements [ [ j ] ];
new = {};
For [ i = 1, i <= Length [ original ], i++, new = Append [ new,
Join [ Table [ 0, {original [ [ i ] ]} ], {1} ] ] ];
new = Drop [ Flatten [ new ], -1 ];
possiblecolumns = Append [ possiblecolumns, new ] ];
symmetricrows =
Select [ possiblecolumns,
possiblecolumns [ [ # ] ] == Reverse [ possiblecolumns [ [ # ] ] ] & ];
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 ];
reversedlegalrows = Reverse /@ legalrows;
potentialcenters = Flatten [ Table [ {legalrows [ [ i ] ], symmetricrows [ [ j ] ],
reversedlegalrows [ [ i ] ]}, {i, 1,
Length [ legalrows ]}, {j, 1, Length [ symmetricrows ]} ], 1 ];
transposedpotentialcenters = Transpose /@ potentialcenters;
freeof101s = Function [ FreeQ [ #, {1, 0, 1} ] ];
transposedno101s = Select [ transposedpotentialcenters, freeof101s ];
almostcenters = Transpose /@ transposedno101s;
insertzerorows =
Function [ Append [ Prepend [ #, Table [ 0, {n} ] ], Table [ 0, {n} ] ] ];
almostcenterswithzeros = insertzerorows /@ almostcenters;
centers = {};
centercount = 0;
For [ v = 1, v <= Length [ almostcenterswithzeros ], v++,
puzzlegraph = Table [ almostcenterswithzeros [ [ 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, centercount = centercount + 1;
centers = Append [ centers, almostcenterswithzeros [ [ v ] ] ] ];
]
plotnice /@ centers;
Print [ "the number of center three-row arrangements in a ", n, " x ", n, " puzzle with rotational symmetry is ", centercount ];
Print [ " " ];
]
| 