3
$\begingroup$

I want to create "number walls" of a user-defined number of rows with mathematica. (They look similar to a CompleteKaryTree.)

  • Each pair of 2 values in a lower row adds up to a sum in the row above.

  • All numbers should be >0.

(1) How would you build up such a wall and (2) how can one remove randomly all "unnecessary" numbers so that the wall is still solvable?

Here is an example for a random wall consisting of 4 rows:

enter image description here

The solved wall is:

enter image description here

I started with the following code to create a wall:

makeWall[n_] := Module[{},
  data = RandomInteger[10, n];
  Print[data];
  l = Length@data;

  While[
   l > 1,
   data = Total[#] & /@ Partition[data, 2, 1];
   l = Length@data;
   Print[data];
   ];
  ]

SeedRandom[1];
makeWall[4]

{1,4,0,7}

{5,4,7}

{9,11}

{20}

How can be from a created wall a minimal number of wall values selected (in the example black), so that the wall can still be solved (red values)?

$\endgroup$
  • $\begingroup$ @Kuba: Each pair of 2 values in a lower row adds up to a sum in the row above. For 4 rows 4 starting numbers are sufficient to solve the wall, but they have to be placed properly. See: somos.crg4.com/nwic.html. I read this stackoverflow.com/questions/32681236/… and tried to rebuild the idea with mma, but was not successfull to find a general solution for the position of the starting values. $\endgroup$ – lio Mar 19 '17 at 17:30
  • $\begingroup$ @Kuba: please excuse me for the misunderstanding, I added a sentence in the question. $\endgroup$ – lio Mar 19 '17 at 17:34
  • $\begingroup$ @Kuba: Yes, the input would be the number of rows and the result should be any random solvable wall. $\endgroup$ – lio Mar 19 '17 at 17:51
  • $\begingroup$ You probably should include the definition of 'solvable' too, and a requirement to return those positions, right? $\endgroup$ – Kuba Mar 19 '17 at 17:55
6
$\begingroup$

You can specify blanks with Null and construct the equations for Solve:

{{Null}, {28,}, {, 20,}, {2, , , 14}} /. Null :> Unique[];
% /. Solve[ListCorrelate[{1, 1}, #2] == #1 & @@@ Partition[%, 2, 1]]

(* {{{76}, {28, 48}, {8, 20, 28}, {2, 6, 14, 14}}} *)

EDIT

You can put maximum of n(n - 1)/2 blanks in order for wall to be uniquely (ok, sometimes, see below) solvable. This would construct a random wall with specified number of blanks with n(n - 1)/2 as default:

makeWall[n_, OptionsPattern[{Blanks -> n (n - 1)/2}]] := 
 Reverse@ReplacePart[#, 
     RandomSample[Position[#, _Integer], OptionValue[Blanks]] -> 
      Null] &@NestList[ListCorrelate[{1, 1}, #] &, 
   RandomInteger[10, n], n - 1]

And to wrap up the above solution:

solveWall = 
  With[{wall = # /. Null :> Unique[]}, 
    wall /. Solve[
      ListCorrelate[{1, 1}, #2] == #1 & @@@ Partition[wall, 2, 1], 
      Integers]] &;

Some examples:

makeWall[4]
solveWall@%

(*{{Null}, {18, 14}, {Null, 8, Null}, {3, Null, 1, Null}}*)
(*{{{32}, {18, 14}, {10, 8, 6}, {3, 7, 1, 5}}}*)

makeWall[5, Blanks -> 4]
solveWall@%

(*{{114}, {Null, 55}, {31, Null, 27}, {17, 14, Null, 13}, {10, Null, 7, 7, 6}}*)
(*{{{114}, {59, 55}, {31, 28, 27}, {17, 14, 14, 13}, {10, 7, 7, 7, 6}}}*)

Sometimes (depends on the positions of Nulls) there can be infinite number of solutions, parameterized with free variable C[1] to C[n(n+1)/2] (if you choose to fill the whole wall with Nulls):

makeWall[4]
solveWall@%

(*{{Null}, {14, Null}, {Null, Null, 14}, {Null, Null, 6, 8}}*)
(*{{{ConditionalExpression[C[1], C[1] \[Element] Integers]}, 
 {14, ConditionalExpression[-14 + C[1], C[1] \[Element] Integers]},
{ConditionalExpression[42 - C[1], C[1] \[Element] Integers], 
   ConditionalExpression[-28 + C[1], C[1] \[Element] Integers], 
   14}, 
{ConditionalExpression[76 - 2 C[1], C[1] \[Element] Integers],
    ConditionalExpression[-34 + C[1], C[1] \[Element] Integers], 6, 8}}}*)

You can pick possible values for these variables with:

% /. FindInstance[AllTrue[Flatten@%, # >= 0 &], C[1]]

(*{{{{35}, {14, 21}, {7, 7, 14}, {6, 1, 6, 8}}}, {{{37}, {14, 23}, {5, 
9, 14}, {2, 3, 6, 8}}}}*)
|improve this answer|||||
$\endgroup$
  • $\begingroup$ Very concise +1. $\endgroup$ – Anjan Kumar Mar 20 '17 at 0:06
  • $\begingroup$ Thank you: please see my question ind the comment to Ali Hashmi. $\endgroup$ – lio Mar 20 '17 at 8:33
  • $\begingroup$ @lio See my edit $\endgroup$ – swish Mar 20 '17 at 9:05
  • $\begingroup$ This solution is perfect. Thanks a lot for your help. $\endgroup$ – lio Mar 20 '17 at 10:56
  • $\begingroup$ @swish +1 for this ! $\endgroup$ – Ali Hashmi Mar 20 '17 at 14:44
3
$\begingroup$

Creating a random wall for a given number of rows.

  generateWall[n_] := Module[{vars, eqns, sol},
  vars = Table[Subscript[x, i, j], {i, n}, {j, i}];
  eqns = #1 + #3 == #2 & @@@ Partition[Riffle @@ Reverse[#], 3, 2] & /@
      Partition[vars, 2, 1] // Flatten;
  sol = FindInstance[Join @@ {eqns, Thread[Variables[vars] > 0]}, 
    Variables[vars], Integers];
  vars /. sol~Flatten~1]

For n = 5, we get

{{56}, {21, 35}, {8, 13, 22}, {3, 5, 8, 14}, {1, 2, 3, 5, 9}}
|improve this answer|||||
$\endgroup$
  • $\begingroup$ I don't find much difference between my answer and the one you posted just now ! $\endgroup$ – Ali Hashmi Mar 19 '17 at 23:33
  • $\begingroup$ I was just trying to show another way of defining eqns. I don't know if this is accepted practice or not. If it is not, please let me know. $\endgroup$ – Anjan Kumar Mar 19 '17 at 23:34
  • $\begingroup$ @AnjanKumar since those are not exact duplicates you can just metion other posters for parts of your answer that really overlap with theirs. $\endgroup$ – Kuba Mar 20 '17 at 6:55
  • $\begingroup$ @AnjanKumar its fine by me. $\endgroup$ – Ali Hashmi Mar 20 '17 at 8:50
  • $\begingroup$ @AliHashmi Thank you for replying. I apologize for any inconvenience. $\endgroup$ – Anjan Kumar Mar 20 '17 at 9:36
3
$\begingroup$

Function to solve a wall with unknown parameters

solveWall[list_List] := With[{sym = Cases[list, _Symbol, {2}]},
FindInstance[#, sym, 
  Integers] &@(And @@ Map[x \[Function] First@x == Last@x, #] &@
  Flatten[Table[
    Thread[{Total /@ Partition[list[[i]], 2, 1], 
      list[[i + 1]]}], {i, 1, Length@list - 1}], 1])];

Borrowing the elegant approach from @swish except that I am using Symbol rather than Null.

makeWall[n_, OptionsPattern[{syms -> n (n - 1)/2}]] := With[
{base = RandomInteger[10, n]},
Module[{list}, 
list = NestList[Total /@ Partition[#, 2, 1] &, base, n - 1];
ReplacePart[list, Thread[RandomChoice[Position[list, _Integer],
OptionValue@syms] -> Table[Module[{x}, x], {OptionValue@syms}]]]
]]

test

wall = makeWall[4];
(* {{x$28197, 2, x$28202, 10}, {8, 7, x$28198}, {15, x$28200}, {37}} *)

wall /. First@solveWall[wall]
(* {{6, 2, 5, 10}, {8, 7, 15}, {15, 22}, {37}} *)
|improve this answer|||||
$\endgroup$
  • $\begingroup$ Thank you: How would you find any possible starting list which can be solved, not only the one which I showed? $\endgroup$ – lio Mar 20 '17 at 8:28
  • 1
    $\begingroup$ @lio i will work on it today or tomorrow $\endgroup$ – Ali Hashmi Mar 20 '17 at 8:47
  • $\begingroup$ @ilo i added the makeWall which is a slightly modified version of the one provided by swish. It creates temporary symbols which is in spirit with my earlier answer $\endgroup$ – Ali Hashmi Mar 20 '17 at 17:05

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.