Message Boards Message Boards

Solving a KenKen puzzle using logic

GROUPS:
POSTED BY: Sander Huisman
Answer
2 years ago

All the code

hintstyle=Sequence[11,Red];
candstyle=Sequence[8,Gray];
fixedstyle=Sequence[22,Black];
linestyle=Sequence[Thickness[0.01],JoinForm["Round"],CapForm["Round"]];
thinlinestyle=Sequence[GrayLevel[0.85],Thickness[0.005],JoinForm["Round"],CapForm["Round"]];
opchars={Plus->"+",Minus->"-",Times->"*",Divide->"/"};

ClearAll[SquareSides,ClueText,DrawGrid]
SquareSides[n_,m_]:={{{n,-m},{n+1,-m}},{{n,-m},{n,-m-1}},{{n+1,-m},{n+1,-m-1}},{{n,-m-1},{n+1,-m-1}}}  
ClueText[cands_,{x_,y_}]:=Module[{center,r=0.2,cp}, 
    center={x+0.5,-y-0.5};
    If[Length[cands]==1,
        Text[Style[First[cands],fixedstyle],center]
    ,
        cp=CirclePoints[center,{r,\[Pi]/2},n];
        cp=MapThread[Text[Style[#1,candstyle],#2]&,{Range[n],cp}][[cands]];
        cp
    ]
]
DrawGrid[cands_List,hints_List]:=Module[{hor,ver,all,rem,boxborders,topleft,hinttext,candpos,candtext},
    hor=Flatten[Outer[List,Range[n],Range[n+1]],1];
    ver=Flatten[Outer[List,Range[n+1],Range[n]],1];
    all=Join[{#,#+{1,0}}&/@hor,{#,#+{0,1}}&/@ver]; 
    all[[All,All,2]]*=-1; 
    topleft=First[TakeSmallestBy[#,Total,1]]&/@hints[[All,3]];
    topleft+=0.08;
    topleft[[All,2]]*=-1;
    hinttext=ToString[#1]<>(#2/.opchars)&@@@hints; 
    hinttext=MapThread[Text[Style[#1,hintstyle],#2,{-1,1}]&,{hinttext,topleft}];
    boxborders=Apply[SquareSides,hints[[All,3]],{2}];
    boxborders=Flatten[#,1]&/@boxborders; 
    boxborders=Select[Tally[#],Last[#]==1&][[All,1]]&/@boxborders;
    boxborders=Flatten[boxborders,1]; 
    rem=Complement[all,boxborders]; 
    candpos=Tuples[Range[n],2]; 
    candtext=MapThread[ClueText,{Flatten[cands,1],candpos}]; 
    Graphics[{{thinlinestyle,Line/@rem},
        hinttext,
        {linestyle,Line[boxborders]},
        candtext
        },ImageSize->65n
    ]
]
ClearAll[ConvertHint,CandAssassin,CandAssassinHelper,ApplyHint]
ConvertHint[ans_,Divide,cells_]:={Log[ans],Abs[Log[#1/#2]]&,cells}
ConvertHint[ans_,Minus,cells_]:={ans,Abs[#1-#2]&,cells}
ConvertHint[ans_,op_,cells_]:={ans,op,cells}
ApplyHint[ans_Integer,op_,cells_List]:=ApplyHint[ConvertHint[ans,op, cells]]
ApplyHint[{ans_,op_,cells_List}]:=Module[{cns},
    cns=Extract[cands,cells];
    cns=Select[Tuples[cns],op@@#==ans&];
    cns=CandAssassin[cns,cells];
    cns=Union/@(cns\[Transpose]);
    MapThread[(Part[cands,Sequence@@#2]=#1)&,{cns,cells}]
]
CandAssassinHelper[cn_List,icell_List]:=AllTrue[icell,Unequal@@cn[[#]]&]
CandAssassin[cns_List,cells_List]:=Module[{icell,newcans},
    icell={Range[Length[cells]],cells}\[Transpose]; 
    icell=GatherBy[icell,#[[2,1]]&][[All,All,1]]; 
    newcans=Select[cns,CandAssassinHelper[#,icell]&];
    icell={Range[Length[cells]],cells}\[Transpose]; 
    icell=GatherBy[icell,#[[2,2]]&][[All,All,1]];
    Select[newcans,CandAssassinHelper[#,icell]&]
]
ClearAll[DeleteCands,NakedSubset,NakedSubsetCheck,NakedDelete]
DeleteCands[{n_,m_},del_]:=(Part[cands,n,m]=Complement[Part[cands,n,m],del])
NakedDelete[cells_List,samesubs_List]:=Module[{other,digits},
    other=Complement[cells,samesubs]; 
    digits=First[Extract[cands,samesubs[[{1}]]]]; 
    Do[DeleteCands[o,digits],{o,other}] 
]
NakedSubsetCheck[cells_List]:=Module[{celldata,n=Length[cells]},
    celldata=Extract[cands,cells];
    If[AllTrue[celldata,Length[#]<=n&],
        Length[Union@@celldata]==n 
    ,
        False
    ]
]
NakedSubset[m_Integer]:=Module[{cellgroups},
    cellgroups=Join[Outer[List,Range[n],Range[n]],Outer[List,Range[n],Range[n]]\[Transpose]]; 
    Do[NakedSubset[m,cg],{cg,cellgroups}] 
]
NakedSubset[m_Integer,cells_List]:=Module[{subsets},
    subsets=Subsets[cells,{m}]; 
    subsets=Select[subsets,NakedSubsetCheck];
    Do[NakedDelete[cells,ss],{ss,subsets}];
]
ClearAll[BoxBoxInteraction]
BoxBoxInteraction[]:=BoxBoxInteraction/@Apply[ConvertHint,Subsets[hints,{2}],{2}]
BoxBoxInteraction[hints_List]:=Module[{ans,ops,cellss,cns},
    {ans,ops,cellss}=Transpose[hints];
    cns=Extract[cands,#]&/@cellss; 
    cns=Tuples/@cns; 
    cns=Table[Select[cns[[\[Iota]]],ops[[\[Iota]]]@@#==ans[[\[Iota]]]&],{\[Iota],Length[hints]}];
    cns=MapThread[CandAssassin,{cns,cellss}]; 
    cns=Tuples[cns];
    cns=Flatten[cns,{{1},{2,3}}];
    cellss=Flatten[cellss,1];
    cns=CandAssassin[cns,cellss]; 
    cns=Union/@Transpose[cns];
    MapThread[(Part[cands,Sequence@@#2]=#1)&,{cns,cellss}]; 
]

Example 1

n=4;
hints={
    {12,Times,{{1,1},{2,1},{2,2}}},
    {2,Divide,{{3,1},{4,1}}},
    {11,Plus,{{1,2},{1,3},{1,4},{2,3}}},
    {2,Minus,{{3,2},{3,3}}},
    {2,Plus,{{4,2}}},
    {4,Plus,{{4,3},{4,4}}},
    {3,Minus,{{2,4},{3,4}}}
};
AbsoluteTiming[
    cands=ConstantArray[Range[n],{n,n}];
    old=False;
    While[old=!=cands,
        old=cands;
        ApplyHint@@@hints;
        NakedSubset/@Range[n];
        If[old==cands,
            BoxBoxInteraction[];
        ];
    ];
]
DrawGrid[cands,hints]

Example 2

n=6;
hints={{13,Plus,{{1,1},{1,2},{2,1},{2,2}}},
    {180,Times,{{3,1},{4,1},{5,1},{4,2}}},
    {9,Plus,{{6,1},{6,2},{6,3}}},
    {2,Plus,{{3,2}}},
    {20,Times,{{5,2},{5,3}}},
    {15,Plus,{{1,3},{1,4},{1,5}}},
    {6,Times,{{2,3},{3,3}}},
    {11,Plus,{{4,3},{4,4},{3,4}}},
    {3,Plus,{{2,4}}},
    {9,Plus,{{5,4},{6,4},{5,5},{4,5}}},
    {2,Divide,{{2,5},{3,5}}},
    {8,Plus,{{1,6},{2,6},{3,6}}},
    {18,Plus,{{4,6},{5,6},{6,6},{6,5}}}
};
AbsoluteTiming[
    cands=ConstantArray[Range[n],{n,n}];
    old=False;
    While[old=!=cands,
        old=cands;
        ApplyHint@@@hints;
        NakedSubset/@Range[n];
        If[old==cands,
            BoxBoxInteraction[];
        ];
    ];
]
DrawGrid[cands,hints]
POSTED BY: Sander Huisman
Answer
2 years ago

Here is a big puzzle:

n=9;
hints={{15,Times,{{1,1},{1,2},{1,3}}},{2,Divide,{{2,1},{2,2}}},{2,Divide,{{3,1},{3,2}}},{25,Plus,{{4,1},{5,1},{6,1},{7,1}}},{320,Times,{{8,1},{9,1},{9,2},{9,3}}},{11,Plus,{{4,2},{4,3}}},{5,Plus,{{5,2},{5,3}}},{1,Minus,{{6,2},{6,3}}},{3,Minus,{{7,2},{8,2}}},{45,Times,{{2,3},{2,4}}},{42,Times,{{3,3},{3,4}}},{2,Divide,{{7,3},{7,4}}},{14,Plus,{{8,3},{8,4},{9,4}}},{14,Times,{{1,4},{1,5}}},{80,Times,{{4,4},{5,4},{5,5}}},{5,Plus,{{6,4},{6,5}}},{12,Plus,{{2,5},{3,5},{4,5}}},{14,Times,{{7,5},{7,6},{7,7}}},{45,Times,{{8,5},{8,6}}},{2,Divide,{{9,5},{9,6}}},{2,Divide,{{1,6},{1,7}}},{13,Plus,{{2,6},{2,7}}},{1,Minus,{{3,6},{3,7}}},{1,Minus,{{4,6},{4,7}}},{14,Times,{{5,6},{6,6}}},{6,Minus,{{5,7},{6,7}}},{5,Minus,{{8,7},{9,7}}},{11,Plus,{{1,8},{2,8}}},{3,Divide,{{3,8},{3,9}}},{28,Times,{{4,8},{4,9}}},{4,Divide,{{5,8},{5,9}}},{11,Plus,{{6,8},{6,9}}},{3,Minus,{{7,8},{7,9}}},{5,Minus,{{1,9},{2,9}}},{1,Minus,{{8,8},{9,8}}},{1,Minus,{{8,9},{9,9}}}};
AbsoluteTiming[
    cands=ConstantArray[Range[n],{n,n}];
    old=False;
    While[old=!=cands,
        old=cands;
        ApplyHint@@@hints;
        NakedSubset/@Range[n];
        If[old==cands,
            BoxBoxInteraction[];
        ];
    ];
]
DrawGrid[cands,hints]

POSTED BY: Sander Huisman
Answer
2 years ago

very impressive! much nicer than the brute-force method I used.

POSTED BY: Frank Kampas
Answer
2 years ago

I improved and extended the code compared to a post in the thread you made. Thanks for introducing me to the problem!

POSTED BY: Sander Huisman
Answer
2 years ago

enter image description here - another post of yours has been selected for the Staff Picks group, congratulations!

We are happy to see you at the tops of the "Featured Contributor" board. Thank you for your wonderful contributions, and please keep them coming!

POSTED BY: Moderation Team
Answer
2 years ago

Group Abstract Group Abstract