<<DiscreteMath`Combinatorica` (*This program counts and displays the possible n x n crossword puzzles \ containing 1 black square per row and column.*) For[n=6,n≤7,n++, k=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++, orig=arrangements[[j]]; new={}; For[i=1,i≤Length[ orig],i++,new=Append[new,Join[Table[0,{orig[[i]]}],{1}]]]; new=Drop[Flatten[new],-1]; possiblecolumns=Append[possiblecolumns,new]]; m=Compositions[n-k,k+1]; m2=Select[m,FreeQ[#,2]&]; m1=Select[m2,FreeQ[#,1]&]; zerosones={}; For[j=1,j≤Length[m1],j++, original=m1[[j]]; new={}; For[i=1,i≤Length[original],i++,new=Append[new,Join[Table[0,{original[[ i]]}],{1}]]]; new=Drop[Flatten[new],-1]; zerosones=Append[zerosones,new]]; middlerows=Partition[Select[zerosones,zerosones[[#]]==Reverse[zerosones[[#]]\ ]&],1]; rowcombinations=Tuples[zerosones,Floor[n/2]]; If[EvenQ[n]\[Equal]False,topofpuzzle=Partition[Flatten[Tuples[{\ rowcombinations,middlerows}],2],Floor[n/2]+1],topofpuzzle=rowcombinations]; bottomofpuzzle=Reverse[Reverse/@rowcombinations]; puzzles=Table[Join[topofpuzzle[[i]],bottomofpuzzle[[i]]],{i,Length[\ topofpuzzle]}]; transposedpuzzles=Transpose/@puzzles; connectedcount=0; legalcolumncount=0; legalpuzzlecount=0; legalpuzzles={}; For[k=1,k≤Length[puzzles],k++, puzzlegraph=Table[puzzles[[k,r,s]],{r,1,n},{s,1,n}]; verts={}; For[i2=1,i2≤n,i2++,For[j2= 1,j2≤n,j2++,If[puzzlegraph[[i2,j2]]\[Equal]1,verts=Append[verts,j2+n^2-\ n*i2]]]]; thegraph=DeleteVertices[GridGraph[n,n],verts]; If[ConnectedQ[thegraph]\[Equal]True,connectedcount=connectedcount+1]; graph=ShowGraph[thegraph,DisplayFunction\[Rule]Identity]; thepuzzle=ArrayPlot[puzzles[[k]],Frame\[Rule]False,Mesh\[Rule]True,\ MeshStyle\[Rule]GrayLevel[0],DisplayFunction\[Rule]Identity]; legalcolumn[x_]:=MemberQ[possiblecolumns,x]; If[ConnectedQ[thegraph]\[Equal]True&&Union[legalcolumn/@\ transposedpuzzles[[ k]]]\[Equal]{True},legalpuzzlecount=legalpuzzlecount+1; legalpuzzles=Append[legalpuzzles,thepuzzle ] ] ] Print["When n = ",n," there are ",legalpuzzlecount," puzzles with exactly one black square in each row."] Show[GraphicsArray[Partition[legalpuzzles,{2}],DisplayFunction\[Rule]$\ DisplayFunction]] ]