# Doing a KenKen in Wolfram Language

Posted 7 years ago
13290 Views
|
20 Replies
|
27 Total Likes
|
 Here's today's New York Times 4x4 KenKen solved in Mathematica. The approach is to first construct all possible arrays with different numbers in each row, from that select all arrays that have different numbers in each column, then apply the constraints on various cells. For this particular example, it was not necessary to apply all the constraints to get the unique answer. It is necessary to take the absolute value of some difference and ratio constraints, since it the order of the difference or ratio is not known. Dimensions[p4 = Permutations[Range[4]]] Out[1]= {24, 4} Dimensions[a1 = Flatten[Outer[List, p4, p4, p4, p4, 1], 3]] Out[2]= {331776, 4, 4} Dimensions[ a2 = Select[ a1, (And @@ (And @@ Unequal[Sequence @@ #] &) /@ Transpose[#]) &]] Out[3]= {576, 4, 4} Dimensions[a3 = Select[a2, #[[1, 1]]*#[[1, 2]]*#[[2, 2]] == 12 &]] Out[4]= {112, 4, 4} Dimensions[a4 = Select[a3, Abs[Log[#[[1, 3]]/#[[1, 4]]]] == Log[2] &]] Out[5]= {64, 4, 4} In[6]:= Dimensions[ a5 = Select[ a4, #[[2, 1]] + #[[3, 1]] + #[[3, 2]] + #[[4, 1]] == 11 &]] Out[6]= {8, 4, 4} In[7]:= Dimensions[a6 = Select[a5, Abs[#[[2, 3]] - #[[3, 3]]] == 2 &]] Out[7]= {6, 4, 4} In[8]:= Dimensions[a7 = Select[a6, #[[2, 4]] == 2 &]] Out[8]= {1, 4, 4} In[10]:= a7 Out[10]= {{{1, 3, 2, 4}, {3, 4, 1, 2}, {4, 2, 3, 1}, {2, 1, 4, 3}}} 
20 Replies
Sort By:
Posted 7 years ago
 Very cool, Frank. Is there a link or an image of what you are solving?
Posted 7 years ago
Posted 7 years ago
 Very interesting, it's like sudoku, but a little bit more sophisticated. I added an extra step to your code which speeds it up 5X. start=AbsoluteTime[]; Dimensions[p4=Permutations[Range[4]]] Dimensions[a1=Flatten[Outer[List,p4,p4,p4,p4,1],3]] Dimensions[a1=Select[a1,Total[#]=={10,10,10,10}&]] Dimensions[a2=Select[a1,(And@@(And@@Unequal[Sequence@@#]&)/@Transpose[#])&]] Dimensions[a3=Select[a2,#[[1,1]]*#[[1,2]]*#[[2,2]]==12&]] Dimensions[a4=Select[a3,Abs[Log[#[[1,3]]/#[[1,4]]]]==Log[2]&]] Dimensions[a5=Select[a4,#[[2,1]]+#[[3,1]]+#[[3,2]]+#[[4,1]]==11&]] Dimensions[a6=Select[a5,Abs[#[[2,3]]-#[[3,3]]]==2&]] Dimensions[a7=Select[a6,#[[2,4]]==2&]] a7 AbsoluteTime[]-start Note that I overwrite a1 on line 4. This substantially reduces the number of grids and the operation is very fast.
Posted 7 years ago
 Alternatively, one can reorder your 'filters': a1 = Select[a1, #[[2, 4]] == 2 &]; a1 = Select[a1, #[[1, 1]]*#[[1, 2]]*#[[2, 2]] == 12 &]; a1 = Select[a1, Abs[#[[2, 3]] - #[[3, 3]]] == 2 &]; a1 = Select[a1, #[[2, 1]] + #[[3, 1]] + #[[3, 2]] + #[[4, 1]] == 11 &]; a1 = Select[a1, (And @@ (And @@ Unequal[Sequence @@ #] &) /@ Transpose[#]) &]; a1 = Select[a1, Abs[Log[#[[1, 3]]/#[[1, 4]]]] == Log[2] &]; They 6 filters reduce all the sets to the right one. The order can be changed resulting in the same answer. I tried all possible permutations of these 6 filters, the above one is the fastest order. (around 0.80 seconds on my computer, while the order given by Frank gives me over 5 seconds.)
Posted 7 years ago
 O btw, you can simply one of your filters: Unequal[Sequence @@ #] can be Unequal @@ # Very nice idea though, but I don't think this will work for a 6*6 grid or even larger...
Posted 7 years ago
 I've done Sudoku, doing it one row at a time, rather than generating all possible grids at the start.I think that approach would also work for larger KenKen.http://library.wolfram.com/infocenter/MathSource/7784/
Posted 7 years ago
 Can the puzzle itself be automatically and randomly generated ? Then a generated puzzle and its solution would make a complete application like an app at Demonstration Project.
Posted 7 years ago
 Updated code: In[11]:= Timing @ Dimensions[p4 = Permutations[Range[4]]] Out[11]= {0., {24, 4}} In[12]:= Timing @ Dimensions[a1 = Tuples[p4, 4]] Out[12]= {0., {331776, 4, 4}} In[13]:= Timing @ Dimensions[a2 = Select[a1, Total[#] == {10, 10, 10, 10} &]] Out[13]= {0.578125, {2520, 4, 4}} In[14]:= Timing @ Dimensions[ a3 = Select[a2, And @@ (And @@ ( Unequal @@ #) &) /@ Transpose[#] &]] Out[14]= {0.015625, {576, 4, 4}} In[15]:= Timing @ Dimensions[a4 = Select[a3, #[[1, 1]]*#[[1, 2]]*#[[2, 2]] == 12 &]] Out[15]= {0., {112, 4, 4}} In[16]:= Timing @ Dimensions[a5 = Select[a4, Abs[Log[#[[1, 3]]/#[[1, 4]]]] == Log[2] &]] Out[16]= {0., {64, 4, 4}} In[17]:= Timing @ Dimensions[ a6 = Select[ a5, #[[2, 1]] + #[[3, 1]] + #[[3, 2]] + #[[4, 1]] == 11 &]] Out[17]= {0., {8, 4, 4}} In[18]:= Timing @ Dimensions[a7 = Select[a6, Abs[#[[2, 3]] - #[[3, 3]]] == 2 &]] Out[18]= {0., {6, 4, 4}} In[19]:= Timing @ Dimensions[a8 = Select[a7, #[[2, 4]] == 2 &]] Out[19]= {0., {1, 4, 4}} In[20]:= a8[[1]] Out[20]= {{1, 3, 2, 4}, {3, 4, 1, 2}, {4, 2, 3, 1}, {2, 1, 4, 3}} 
Posted 7 years ago
 I made a little solver that seems to work (tested 2 different grids), but might not solve all grids. Here is the code: hintstyle = Sequence[11, Red]; candstyle = Sequence[8, Gray]; fixedstyle = Sequence[22]; opchars = {Plus -> "+", Minus -> "-", Times -> "\[Times]", Divide -> "\[Divide]"}; ClearAll[SquareSides, ClueText, DrawGrid] SquareSides[n_, m_] := Module[{}, {{{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[{{Gray, Thickness[0.005], Line /@ rem}, hinttext, {Thickness[0.01], Line[boxborders]}, candtext }, ImageSize -> 65 n] ] ClearAll[ApplyHint, DivideFunc, MinusFunc] DivideFunc[x_, y_] := Abs[Log[x/y]] MinusFunc[x_, y_] := Abs[x - y] ApplyHint[ans_Integer, op : Divide | Minus, cells_List] := Module[{cns}, If[Length[cells] == 2, Switch[op, Divide, ApplyHint[Log[ans], DivideFunc, cells], Minus, ApplyHint[ans, MinusFunc, cells] ] , Print["Divide/Minus should have 2 cells!!"]; Abort[]; ] ] ApplyHint[ans_, op : (Times | Plus | DivideFunc | MinusFunc), cells_List] := Module[{cns}, cns = Extract[cands, cells]; cns = Select[Tuples[cns], op @@ # == ans &]; (* TODO: not only should the 'ans' match, but also we can not have the same values in the same row/column, filter for that here\[Ellipsis] *) cns = DeleteDuplicates /@ (cns\[Transpose]); MapThread[(Part[cands, Sequence @@ #2] = #1) &, {cns, cells}] ] ClearAll[DeleteCands] DeleteCands[{n_, m_}, del_] := (Part[cands, n, m] = Complement[Part[cands, n, m], del]) ClearAll[NakedSubset, SameValsCorrectnQ, NakedDelete] SameValsCorrectnQ[cells_, n_Integer] := Module[{celldata}, celldata = Extract[cands, cells]; If[AllTrue[celldata, Length[#] == n &], Equal @@ (Sort /@ celldata) , 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, SameValsCorrectnQ[#, m] &]; Do[NakedDelete[cells, ss], {ss, subsets}] ] NakedDelete[cells_List, samesubs_List] := Module[{other, digits}, other = Complement[cells, samesubs]; digits = First[Extract[cands, samesubs[[{1}]]]]; Do[DeleteCands[o, digits], {o, other}] ] A puzzle has a size and some hints, and then we solve it: n = 6; hints = { {3, Plus, {{1, 1}}}, {7, Plus, {{2, 1}, {1, 2}, {2, 2}}}, {4, Minus, {{3, 1}, {4, 1}}}, {16, Plus, {{5, 1}, {5, 2}, {6, 2}}}, {2, Plus, {{6, 1}}}, {60, Times, {{3, 2}, {4, 2}, {4, 3}}}, {3, Minus, {{1, 3}, {1, 4}}}, {108, Times, {{3, 3}, {2, 3}, {2, 4}}}, {5, Plus, {{5, 3}}}, {5, Plus, {{6, 3}, {6, 4}}}, {11, Plus, {{3, 4}, {3, 5}, {4, 5}}}, {2, Divide, {{4, 4}, {5, 4}}}, {20, Times, {{1, 5}, {2, 5}, {2, 6}}}, {9, Times, {{5, 5}, {5, 6}, {6, 5}}}, {6, Plus, {{1, 6}}}, {2, Divide, {{3, 6}, {4, 6}}}, {5, Plus, {{6, 6}}} }; AbsoluteTiming[ cands = ConstantArray[Range[n], {n, n}]; old = False; While[old =!= cands, old = cands; AbsoluteTiming[ApplyHint @@@ hints;]; NakedSubset /@ Range[Ceiling[n/2]]; ]; ] DrawGrid[cands, hints] Giving:Or for the original problems: 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; AbsoluteTiming[ApplyHint @@@ hints;]; NakedSubset /@ Range[Ceiling[n/2]]; ]; ] DrawGrid[cands, hints] Giving:Solves it within 10 milliseconds for me. It by no means solves all the KenKen puzzles, once should add the Hidden Subsets technique and eliminate possibilities that I commented in the code.Cheers!
Posted 7 years ago
 Note that this solution works in a totally different way than the original. While the original creates all the possible solutions for the entire grid, and filter by crossing out solutions for the entire grid, this implementation find all the possible candidates for each cells. And filters the candidates for each cell until only 1 candidate is left for each cell. Also note that this implementation is much more memory efficient.Enjoy!
Posted 7 years ago
 Hidden Subsets can also be implemented by just looking for naked subsets larger than n/2. Change the line:  NakedSubset /@ Range[Ceiling[n/2]]; to:  NakedSubset /@ Range[n]; in order to 'implement' 'hidden subsets' (we are looking for large naked subsets, which is equivalent, might be slower though...).
Posted 7 years ago
 Your method is an impressive implementation in Mathematica of how KenKen is done "by hand".
Posted 7 years ago
 Thanks Frank! BTW: You can see the intermediate' steps by changing the code a little: 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, Print[DrawGrid[cands, hints]]; old = cands; AbsoluteTiming[ApplyHint @@@ hints;]; NakedSubset /@ Range[Ceiling[n/2]]; ]; ] Enjoy!
Posted 7 years ago
 I've come up with a faster way to generate all the 4x4 arrays with different numbers in each row and column. See In[3] In[1]:= Timing @ Dimensions[p4 = Permutations[Range[4]]] Out[1]= {0., {24, 4}} In[2]:= Timing @ Dimensions[a1 = Tuples[p4, 4]] Out[2]= {0.015625, {331776, 4, 4}} In[3]:= Timing @ Dimensions[a2 = Intersection[a1, Transpose /@ a1]] Out[3]= {0.09375, {576, 4, 4}} In[4]:= Timing @ Dimensions[a3 = Select[a2, #[[1, 1]]*#[[1, 2]]*#[[2, 2]] == 12 &]] Out[4]= {0., {112, 4, 4}} In[5]:= Timing @ Dimensions[a4 = Select[a3, Abs[Log[#[[1, 3]]/#[[1, 4]]]] == Log[2] &]] Out[5]= {0., {64, 4, 4}} In[6]:= Timing @ Dimensions[ a5 = Select[ a4, #[[2, 1]] + #[[3, 1]] + #[[3, 2]] + #[[4, 1]] == 11 &]] Out[6]= {0., {8, 4, 4}} In[7]:= Timing @ Dimensions[a6 = Select[a5, Abs[#[[2, 3]] - #[[3, 3]]] == 2 &]] Out[7]= {0., {6, 4, 4}} In[8]:= Timing @ Dimensions[a7 = Select[a6, #[[2, 4]] == 2 &]] Out[8]= {0., {1, 4, 4}} In[9]:= a7[[1]] Out[9]= {{1, 3, 2, 4}, {3, 4, 1, 2}, {4, 2, 3, 1}, {2, 1, 4, 3}} 
Posted 7 years ago
 This is indeed a lot faster; how about the memory consumption? The {331776, 4, 4} - array should take up some memory...
Posted 7 years ago
 In[1]:= MemoryInUse[] Out[1]= 28876504 In[2]:= Timing @ Dimensions[p4 = Permutations[Range[4]]] Out[2]= {0., {24, 4}} In[3]:= MemoryInUse[] Out[3]= 38100432 In[4]:= Timing @ Dimensions[a1 = Tuples[p4, 4]] Out[4]= {0.015625, {331776, 4, 4}} In[5]:= MemoryInUse[] Out[5]= 80572336 In[7]:= Timing @ Dimensions[a2 = Intersection[a1, Transpose /@ a1]] Out[7]= {0.078125, {576, 4, 4}} In[8]:= MemoryInUse[] Out[8]= 80657696 In[9]:= Clear[a1] In[10]:= MemoryInUse[] Out[10]= 41259120 
Posted 7 years ago
 Not bad! 41 Megabytes! But it will be problematic for 6*6 grids or larger I'm afraid. Did you try to adapt your script to 6x6 grids?
Posted 7 years ago
 I haven't tried 6*6 grids with my approach as I suspect your approach is superior. I've also been wondering what's the best way to generate a Latin Square (different elements in all rows and columns) in Mathematica. I was thinking about starting with the upper left corner and then adding a row and a column element at a time, restricting the added value to be different from the other values its row and column, and then adding another row and column, etc.
 I've been able to speed up my code for doing the 4x4 KenKen by doing it row at a time In[1]:= n = 4; In[2]:= rn = Range[n]; In[3]:= colUnequal[l_List] := Select[l, And @@ (UnsameQ @@@ Transpose[#]) &] In[4]:= addRow[l_List, p_List] := Join[#[[1]], {#[[2]]}] & /@ Tuples[{l, p}] In[5]:= Timing @ Dimensions[p = Permutations[rn]] Out[5]= {0., {24, 4}} In[6]:= Timing @ Dimensions[ps = Select[p, Abs[Log[#[[3]]/#[[4]]]] == Log[2] &]] Out[6]= {0., {8, 4}} In[7]:= Timing @ Dimensions[a2 = Tuples[{ps, p}] ] Out[7]= {0., {192, 2, 4}} In[8]:= Timing @ Dimensions[a2s = colUnequal[a2]] Out[8]= {0., {72, 2, 4}} In[9]:= Timing @ Dimensions[a2s1 = Select[a2s, #[[2, 4]] == 2 &]] Out[9]= {0., {12, 2, 4}} In[10]:= Timing @ Dimensions[a2s2 = Select[a2s1, #[[1, 1]]*#[[1, 2]]*#[[2, 2]] == 12 &]] Out[10]= {0., {4, 2, 4}} In[11]:= Timing @ Dimensions[a3 = addRow[a2s2, p]] Out[11]= {0., {96, 3, 4}} In[12]:= Timing @ Dimensions[a3s = colUnequal[a3]] Out[12]= {0., {8, 3, 4}} In[13]:= Timing @ Dimensions[a3s1 = Select[a3s, Abs[#[[2, 3]] - #[[3, 3]]] == 2 &]] Out[13]= {0., {3, 3, 4}} In[14]:= Timing @ Dimensions[a4 = addRow[a3s, p]] Out[14]= {0., {192, 4, 4}} In[15]:= Timing @ Dimensions[a4s = colUnequal[a4]] Out[15]= {0., {8, 4, 4}} In[16]:= Timing @ Dimensions[ a4s1 = Select[ a4s, #[[2, 1]] + #[[3, 1]] + #[[3, 2]] + #[[4, 1]] == 11 &]] Out[16]= {0., {1, 4, 4}} In[17]:= a4s1[[1]] Out[17]= {{1, 3, 2, 4}, {3, 4, 1, 2}, {4, 2, 3, 1}, {2, 1, 4, 3}} `