Looking for a New Year’s gift going into this next Dragon year 2024? How about trying the Dragon Fjord A-Puzzle-A-Day, available directly or from momath? There’s no reason to wait another Zodiac cycle, we already have the tools now to solve every configuration, and check the original Author’s claim that: “There are almost 120 thousand ways the pieces fit in the frame”.
To solve the puzzle using Mathematica, we essentially only need one more function, which converts date values into a puzzle space:
In[]:=
Emptiness[nowPass_:True]:=With[{​​now=If[TrueQ[nowPass],DateValue[{"Month","Day"}],​​nowPass],​​emptiness=SparseArray[Join[​​{#,7}->1&/@Range[2],​​{7,#}->1&/@Range[4,7]],{7,7}]},​​ReplacePart[Normal[emptiness],{​​{1+Quotient[First[now],6,1],Mod[First[now],6,1]}->1,​​{3+Quotient[Last[now],7,1],Mod[Last[now],7,1]}->1​​}]​​]
Today, Dec. 23, the puzzle space looks like this:
In[]:=
FixGraphicsScale[]@ResourceFunction["PolyominoPlot"][Emptiness[]]
Out[]=
Into this space we are asked to place 7 of 12 pentominoes, and one additional hexomino:
Out[]=

,
,
,
,
,
,
,

The problem encoder in “PlaceOne” mode then gets us a cover matrix to input:
calendarProblem=PolyominoCoverEncoding[​​Emptiness[],forms,"PlaceOne"->True];
Just for fun, let’s check to see that secondary methods are inefficient:
In[]:=
TimeConstrained[​​PolyominoCoverDecode[​​Emptiness[],​​ResourceFunction["FindExactCover"][​​calendarProblem,Method->#],​​"PlaceOne"->True​​],1]&/@{"BranchAndPrune","CliqueToCover"}
Out[]=
{$Aborted,$Aborted}
The default method takes less than a second to solve today’s puzzle
In[]:=
AbsoluteTiming[​​decodedSolution=PolyominoCoverDecode[​​Emptiness[],​​ResourceFunction["FindExactCover"][​​calendarProblem,Method->"DancingLinksX"],​​"PlaceOne"->True​​];​​]
Out[]=
{0.163218,Null}
Other than colors, the depiction below is the same as the solution above, no coincidence there:
In[]:=
ResourceFunction["PolyominoPlot"][​​decodedSolution,ColorFunction->Function[​​If[SameQ[#,0],Black,​​Hue[#/15]]]]
Out[]=
After about 30 seconds more calculation, we find 115 solutions in total:
AbsoluteTiming[​​allSols=ResourceFunction["FindExactCover"][​​calendarProblem,All];​​]
Out[]=
{24.9935,Null}
In[]:=
Length[allSols]
Out[]=
115
They are all depicted here:
In[]:=
With[{res=ResourceFunction["PolyominoPlot"][​​PolyominoCoverDecode[​​Emptiness[],#,​​"PlaceOne"->True​​],ColorFunction->Function[If[​​SameQ[#,0],Black,​​Hue[#/15]]]​​]&/@allSols},​​GraphicsGrid[Partition[res,UpTo[10]],​​ImageSize->{600,Automatic}]​​]
Out[]=
Today seems to be a normal day, like any other day, but how does that feeling correlate with statistics we can possibly derive after about 30 minutes of computing?
Well, first of all, if today was an ordinary day, we could certainly have another statistical disagreement, and it looks like instead of “120 thousand ways”, we ended up with only about 25,000. This is troublesome, but it’s difficult for us to self-doubt when we get the same results by a different algorithm:
Of course, there is a possibility that PolyominoCoverEncoding has a bug, but let’s worry about that later. For now we can take what statistics we have, and check to see that, as far as we know, today is a day with more possibilities than usual, but not diverging by any more than 1.25 sigma:
Maybe when winter school gets here in a week or two we can loop back around to this mysterious discrepancy, and do another round of Quality Assurance on some of the unpublished code we’re using here. It would also be interesting to see if there are any geometric patterns, which correlate to puzzle difficulty as measured by solution count. Should be fun!

Code

PolyominoArrays

PolyominoPlot

PolyominoCoverEncoding

PolyominoCoverDecode

CITE THIS NOTEBOOK

Solving MoMath's A-Puzzle-A-Day by DragonFjord​
by Brad Klee​
Wolfram Community, STAFF PICKS, December 24, 2023
​https://community.wolfram.com/groups/-/m/t/3089870