Message Boards Message Boards

Solving a KenKen puzzle using logic

POSTED BY: Sander Huisman
5 Replies

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

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

POSTED BY: Frank Kampas

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

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

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
Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract