A sudoku-like collection puzzle

4

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?

Nico A

Posted 2018-03-07T00:15:41.690

Reputation: 3 404

2Please clarify: Can you "insert" the same integer value in different "slots", or must all $n l$ be distinct? – David G. Stork – 2018-03-07T00:36:05.727

@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. – Nico A – 2018-03-07T00:43:49.117

Answers

3

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.

wxffles

Posted 2018-03-07T00:15:41.690

Reputation: 13 711

Apologies, I was vague in my question. No number in the collections can be repeated - as is the case in this solution. – Nico A – 2018-03-07T00:53:53.253

@TreFox since you mentioned it is a sudoku like puzzle can the second term be equal to the first one? (ie ={{6,6},....} – Alucard – 2018-03-07T01:02:08.817

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. – David G. Stork – 2018-03-07T01:02:16.470

@Alucard Nope. Part of the puzzle is that each number from 1 to nl is to be used once. – Nico A – 2018-03-07T01:03:55.163

1

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];
      ]
     ];
    ];
   ];

wxffles

Posted 2018-03-07T00:15:41.690

Reputation: 13 711

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} – Alucard – 2018-03-07T03:27:24.073

1

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}}}

Anjan Kumar

Posted 2018-03-07T00:15:41.690

Reputation: 4 551