4
$\begingroup$

I have a puzzle. I'm given a collection of $n$ lists, all of equal (but arbitrary) length $l$. These lists are made up of 0s and a few filled in numbers, like so:

{ {0, 2}, {0,0}, {6, 0}, {0,0} }

The puzzle is to replace those $0$s with integers $1$ through $n l$ such that:

  • The sum of the first elements in the lists is equal to the sum of the second elements in the lists is equal to the sum of the third elements, etc.
  • The sum of the elements in each list is the same.

  • No number is repeated

I know I can do this through pure brute force with Permutations, but for as simple as an example above I'm already checking 40,320 combinations, and ideally, a solution would work up to $n=l=10$.

How can I accomplish this efficiently in Mathematica?

$\endgroup$
  • 2
    $\begingroup$ Please clarify: Can you "insert" the same integer value in different "slots", or must all $n l$ be distinct? $\endgroup$ – David G. Stork Mar 7 '18 at 0:36
  • $\begingroup$ @DavidG.Stork Of course, I'm sorry I forgot to mention it! All must be distinct. I will add it to the question. Thank you. $\endgroup$ – TreFox Mar 7 '18 at 0:43
3
$\begingroup$

You could replace all the values with unknowns, construct the appropriate set of equations, and ask Mathematica to solve it:

puzzle = {{0, 2}, {0, 0}, {6, 0}, {0, 0}};

Module[{i = 0, a, q, n = Length@puzzle, k = Length@First@puzzle},
 q = puzzle /. 0 :> a[++i];
 q /. First@FindInstance[
   (Equal @@ Total /@ q) && (* Subtotals are the same *)
    And @@ (1 <= a[#] <= n k & /@ Range[i]) && (* Inserted values from 1 to nk *)
    Unequal @@ (a /@ Range[i]) (* Don't repeat values *)
   , a /@ Range[i], Integers]
 ]

{{6, 2}, {1, 7}, {6, 2}, {3, 5}}

But it might not be more efficient.

Edit: Don't repeat any numbers:

Module[{i = 0, a, q, existing, vars, n = Length@puzzle, 
  k = Length@First@puzzle},
 existing = Select[Union@Flatten@puzzle, # > 0 &];
 q = puzzle /. 0 :> a[++i];
 vars = a /@ Range@i;
 q /. First@FindInstance[
    (Equal @@ Total /@ q) &&(* Subtotals are the same *)
     And @@ (1 <= # <= n k & /@ vars) &&(* 
     Inserted values from 1 to nk *)
     Unequal @@ vars &&(* Don't repeat values *)
     And @@ Flatten@Outer[Unequal, vars, existing] (* Don't use existing numbers *)
    , a /@ Range[i], Integers]
 ]

$Aborted

I got bored waiting for a result. This is perhaps a hint that it really isn't efficient.

$\endgroup$
  • $\begingroup$ Apologies, I was vague in my question. No number in the collections can be repeated - as is the case in this solution. $\endgroup$ – TreFox Mar 7 '18 at 0:53
  • $\begingroup$ @TreFox since you mentioned it is a sudoku like puzzle can the second term be equal to the first one? (ie ={{6,6},....} $\endgroup$ – Alucard Mar 7 '18 at 1:02
  • $\begingroup$ Nice solution wxffles (+1), but as you suspect, it does not scale well. I tried an $8 \times 4$ puzzle and it is still computing after 15 minutes. I suspect a $10 \times 10$ puzzle would take an extraordinarily long time. $\endgroup$ – David G. Stork Mar 7 '18 at 1:02
  • $\begingroup$ @Alucard Nope. Part of the puzzle is that each number from 1 to nl is to be used once. $\endgroup$ – TreFox Mar 7 '18 at 1:03
1
$\begingroup$

Here's another solution. It recursively tries filling in the zeros until a solution is reached. A few ideas are used to speed the process up:

  • Stop if it's never going to work.
  • If we know the target total for the sublists, fill in any single zeros.
  • Target the biggest total sublist for trials.
  • Don't trial any numbers that are obviously too big.

Example:

pseudoku[puzzle] // Reap // Last // Last

{{{7, 2}, {1, 8}, {6, 3}, {4, 5}}, {{7, 2}, {1, 8}, {6, 3}, {5, 4}}, {{7, 2}, {4, 5}, {6, 3}, {1, 8}}, {{7, 2}, {4, 5}, {6, 3}, {8, 1}}, {{7, 2}, {5, 4}, {6, 3}, {1, 8}}, {{7, 2}, {5, 4}, {6, 3}, {8, 1}}, {{7, 2}, {8, 1}, {6, 3}, {4, 5}}, {{7, 2}, {8, 1}, {6, 3}, {5, 4}}}

This does only 75 calls to the routine.

The code:

ClearAll@pseudoku;
pseudoku[p_] :=
  Module[{n = Length@p, k = Length@First@p,
    available, complete, partial, target, big, bigi, zeroi, c, q, trial
    },
   available = Complement[Range[n k], Flatten@Union@p];
   complete = Select[p, Min@# > 0 &];
   If[Length@complete == Length@p && SameQ @@ Total /@ p,
    Sow@p,(* Got a solution *)
    partial = Select[p, Min@# == 0 &];
    If[Length@complete > 0 && ! SameQ @@ Total /@ complete,
     (* fail *),
     target = n k^2; c = 0;
     If[Length@complete > 0,
      target = Total@First@complete;
      (* Fill in the sublist with only one zero *)
      q = p /. a : {_Integer ..} /; 
          Count[a, 0] == 1 && 
           MemberQ[available, target - Total@a] :> (++c; (a /. 
            0 -> target - Total@a));
      (* Could do some smarter possibilities with IntegerPartitions of the remainder *)
      ];
     If[c > 0, pseudoku[q],
      (* Try some more possibilities *)
      big = Last@SortBy[partial, Total];
      bigi = First@First@Position[p, big];
      zeroi = First@First@Position[big, 0];
      trial = Select[available, # <= target - Total@big &];
      If[Length@trial > 0,
       pseudoku[ReplacePart[p, {bigi, zeroi} -> #]] & /@ trial];
      ]
     ];
    ];
   ];
$\endgroup$
  • $\begingroup$ if you find the difference between the max and the minimum scalar in the list (6-2=4) you can remove some possibilities: 2 can mix only with {5,7,8} and 6 only with {1,3,4} $\endgroup$ – Alucard Mar 7 '18 at 3:27
1
$\begingroup$

This approach uses IntegerPartitions. The following code matches the partitions of a number for a specific length to that of the puzzle.

puzzleP[lst_, num_] := 
  Module[{i = 0, j = 0, k = 0, l = Length[First@lst], yVar, yVal, listVars, pattern},
   yVar = ToExpression["y" <> ToString[#] <> "_Integer"] &;
   yVal = ToExpression["y" <> ToString[#]] &;
   listVars = lst /. {0 :> yVal[++i]} // Flatten;
   pattern = OrderlessPatternSequence[___, Sequence @@ (lst /. {0 :> yVar[++j]})];
   ReplaceList[
    IntegerPartitions[num, {l}], {pattern} :> 
      (Evaluate@If[Unequal @@ (listVars), (Evaluate@(lst /. {0 :> yVal[++k]})), Nothing])]
   ];
puzzle[lst_, limit_] := 
 Module[{num = 1, n = Length[lst], l = Length[First@lst]},
  While[puzzleP[lst, num] == {} && num < limit, ++num];
  puzzleP[lst, num]
 ]

Test

For the purpose of testing, I chose random patterns which contain few elements.

p1 = {{0, 2}, {0, 0}, {6, 0}, {0, 0}};
p2 = {{0, 2, 1}, {0, 0, 5}, {10, 0, 4}};
p3 = {{0, 2, 1}, {18, 0, 3}, {14, 0, 0}, {0, 8, 0}};
puzzle[p1, 30]
puzzle[p2, 30]
puzzle[p3, 30] (*This takes a few more seconds compared to others*)

{{{7, 2}, {5, 4}, {6, 3}, {8, 1}}, {{7, 2}, {8, 1}, {6, 3}, {5, 4}}}

{{{17, 2, 1}, {8, 7, 5}, {10, 6, 4}}}

{{{22, 2, 1}, {18, 4, 3}, {14, 6, 5}, {10, 8, 7}}}

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.