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