(* Glaesers Dominos *) (* Mathematica program by Oliver Knill, 31. December 2005 *) (* Fit the 28 Dominos {i,j},0 <=i0 && Product[pn[[j]],{j,kk+1,Length[pn]}] >0,Do[ solution[[kk]]=ll; qqq=pp[[ll]]; Print[PN[AA,B]]; Print[10^40+ll*10^(Length[B]-kk)," ",count]; AAA=RemoveDomino[AA,qqq]; FindSolution[AAA,kk+1], {ll,1,K}],count=count+1; (*,else no solution found *) ] ] Start:=Module[{}, count=0; Print["\n"]; FindSolution[A,1] ]; PlotSolution:=Module[{}, s={}; eps={0.05,0.05}; solution0={3,1,2,2,1,1,3,1,1,4,1,1,1,1,2,1,1,1,1,2,1,1,1,1,1,1,1,1}; nm=Length[solution0]; A1=A; Do[{bb,pp}=FitDomino[A1,B[[kkkk]]]; PP={bb,pp}; qqq=pp[[solution0[[kkkk]]]]; A2=RemoveDomino[A1,qqq]; A1=A2; Print[MatrixForm[A1]];Print["\n"]; qqqq={ {qqq[[1,2]],nm-qqq[[1,1]]},{qqq[[2,2]],nm-qqq[[2,1]]}}; qqq=qqqq; (* matrix -> descartes*) If[qqq[[1,1]]>qqq[[2,1]] || qqq[[1,2]]> qqq[[2,2]], qqqq={qqq[[2]],qqq[[1]]}; qqq=qqqq]; (*order*) s=Append[s,{RGBColor[0,0,0],Rectangle[qqq[[1]],qqq[[2]]+{1,1}]}]; s=Append[s,{Hue[kkkk/nm],Rectangle[qqq[[1]]+eps,qqq[[2]]+{1,1}-eps]}], {kkkk,nm}]; A1=A; Do[{bb,pp}=FitDomino[A1,B[[kkkk]]]; PP={bb,pp}; qqq=pp[[solution0[[kkkk]]]]; A2=RemoveDomino[A1,qqq]; A1=A2; qqqq={ {qqq[[1,2]],nm-qqq[[1,1]]},{qqq[[2,2]],nm-qqq[[2,1]]}}; qqq=qqqq; (* matrix -> descartes*) s=Append[s,{RGBColor[0,0,0],{Text[bb[[1]],qqq[[1]]+{1,1}/2], Text[bb[[2]],qqq[[2]]+{1,1}/2]}}], {kkkk,nm}]; S=Show[Graphics[s],AspectRatio->1,Frame->False,Axes->False]; \$TextStyle={FontFamily ->"Swiss721BT-Roman", FontSize->24}; Display["glaesersdomino.ps",S,"EPS"]; \$TextStyle={FontFamily ->"Swiss721BT-Roman", FontSize->72}; Display["glaesersdomino.gif",S,"GIF",ImageSize->1200]]; GifName[n_]:=Block[{u,v,w}, u=IntegerDigits[n]+48; v=ToCharacterCode["domino"]; w=ToCharacterCode[".gif"]; FromCharacterCode[Join[v,u,w]]]; PlotDominos:=Module[{}, eps={0.05,0.05}; nm=Length[B]; \$TextStyle={FontFamily ->"Swiss721BT-Roman", FontSize->24}; Do[ s={}; (* s={{RGBColor[0,0,0],Rectangle[{0,-1},{1,0} ]}}; s=Append[s,{RGBColor[0,0,0],Rectangle[{1,-1},{2,0} ]}]; *) s=Append[s,{Hue[kkk/nm], Rectangle[{0,-1}+eps,{1,0}-eps]}]; (* s=Append[s,{Hue[kkk/nm], Rectangle[{1,-1}+eps,{2,0}-eps]}]; s=Append[s,{RGBColor[0,0,0],{Text[B[[kkk,1]],{0,-1}+{1,1}/2], Text[B[[kkk,2]],{1,-1}+{1,1}/2]}}]; *) S=Show[Graphics[s],AspectRatio->0.5,Frame->False,Axes->False,Background->Hue[kkk/nm]]; Display[GifName[1000+kkk],S,"GIF", ImageSize->10], {kkk,1,nm}]; ]; PlotProblem:=Module[{}, s={}; eps={0.05,0.05}; s={RGBColor[0,0,0],Table[Text[A[[i,j]],{j,Length[A]-i}+{1,1}/2],{j,Length[A[[1]]]},{i,Length[A]}]}; S=Show[Graphics[s],AspectRatio->1,Frame->False,Axes->False]; \$TextStyle={FontFamily ->"Swiss721BT-Roman", FontSize->24}; Display["glaesersproblem.ps",S,"EPS"]; \$TextStyle={FontFamily ->"Swiss721BT-Roman", FontSize->72}; Display["glaesersproblem.gif",S,"GIF",ImageSize->1200]]; Timing[Start] (* PlotProblem PlotDominos PlotSolution *)