14
$\begingroup$

I have a blank grid whose dimension is 5*5.

Mathematica graphics

I want to fill it with some number using 1, 2, 3 and 4. But in every blank space if you fill 2, its neighbor (include four direction, such as left, right, top and bottom) must have a 1 at least. If you fill 3, its neighbor must have a 2 and a 1 at least. If you fill 4, its neighbor must have a 3, a 2 and a 1 at least. I think the total maybe is near to 50.

Mean@Table[
  Total[RandomChoice[{.4, .3, .2, .1} -> {1., 2, 3, 4}, {5, 5}], 2], 
  1000000]

50.0017

But I really don't know how to fill the blank grid to make its total of all number to be largest?


There is sample filled grid from @Quantum_Oli's answer but its the total isn't largest

img

As the @Bill 's comment,I made a boolean expression name as GoodQ,It is ulgly,But anyway,It works

neighborNum[mat_, num_, nei_] := 
 And @@ ((And @@ (Function[tem, MemberQ[#, tem]] /@ 
         nei)) & /@ (Extract[
        mat, #] & /@ (Select[#, 
          And @@ Thread[
             1 <= # <= 5] &] & /@ ((Table[{#, #2}, 
              4] + (Join[#, -#] &[IdentityMatrix[2]])) & @@@ 
          Position[mat, num]))))
GoodQ[list_] := 
 And @@ MapThread[
   neighborNum[list, #, #2] &, {{2, 3, 4}, {{1}, {1, 2}, {1, 2, 3}}}]

We can check the matrix in the @Quantum_Oli's answer and in the @garej's comment

m = {{3, 2, 1, 2, 3}, {1, 4, 2, 4, 1}, {2, 3, 1, 3, 2}, {1, 4, 2, 4, 
    1}, {3, 2, 1, 2, 3}};
m2 = {{1, 4, 2, 4, 1}, {2, 3, 1, 3, 2}, {1, 4, 2, 4, 1}, {2, 3, 1, 3, 
    2}, {1, 4, 2, 4, 1}};
m3 = {{2, 1, 2, 1, 2}, {4, 3, 4, 3, 4}, {1, 2, 1, 2, 1}, {4, 3, 4, 3, 
    4}, {2, 1, 2, 1, 2}};
GoodQ /@ {m, m2, m3}

{True, True, True}

$\endgroup$
  • 1
    $\begingroup$ Why the downvote?could you give a reason? $\endgroup$ – yode Apr 2 '16 at 14:32
  • $\begingroup$ Although I am not the down voter, I do find the question quite unclear. For instance, how do you calculate the total? Row totals? Column totals? Perhaps you could show an example of a completed square for clarity. Also, what have you tried so far? $\endgroup$ – MarcoB Apr 2 '16 at 14:42
  • $\begingroup$ @MarcoB Sorry,Actually I don't know how to start this question.If I have some progress,I must will show in the post. $\endgroup$ – yode Apr 2 '16 at 14:59
  • 2
    $\begingroup$ An essential part of the solution will be a boolean expression which is True if the matrix satisfies your conditions and False otherwise. Can you write out such an expression? $\endgroup$ – Bill Apr 2 '16 at 15:58
  • $\begingroup$ @Bill I made a boolean expression,but a little ulgly. $\endgroup$ – yode Apr 2 '16 at 17:32
19
+250
$\begingroup$

Below is given a solution derived with ILP combinatorial optimization: The total of the assigned values to the $5 \times 5$ table is $61$.

I called in the comments this approach to be "brute force" because of the generation of a larger number of variables and conditions and pushing them to Maximize or LinearProgramming. Same approach was used for my answer in the discussion "Refining subset relations".

Integer programming formulation

Set-up parameters

Dimensions of the $m \times n$ table:

{m, n} = {5, 5};

We consider placing the integers $[1,\dots,d_{max}]$, $d_{max} = 4$ in the $m \times n$ table.

dmax = 4;

Variables

Let us make the binary variables $x(k,i,j)=x_{k,i,j}$, $k \in [1,\dots,d_{max}]$, $i \in [1,\dots,m]$, $j \in [1,\dots,n]$ in the following way: $x(k,i,j) = 1$ if the integer $k$ is placed at position $(i,j)$ and it is 0 otherwise.

ClearAll[vars, x]
vars = Flatten[Array[x, {dmax, m, n}]];

Neighbor conditions

Let us define a function (as described in the question) that brings a set of index pairs for the neighbors of given cell $(i,j)$:

$ninds(i,j):= \{ 0 < p_1 \leq m, 0 < p_2 \leq n : p \in \{ (i-1,j),(i+1,j),(i,j-1),(i,j+1)\} \}$ .

NeighborIndexes[{i_, j_}] := {{i - 1, j}, {i + 1, j}, {i, j - 1}, {i, j + 1}};
NeighborIndexes[{i_?NumberQ, j_?NumberQ}, {m_, n_}] := 
  Select[{{i - 1, j}, {i + 1, j}, {i, j - 1}, {i, j + 1}}, 
   0 < #[[1]] <= m && 0 < #[[2]] <= n &];

For each cell $(i,j)$ and an integer $k > 1$ placed on that cell we have the conditions:

$\sum_{p \in ninds(i,j)} x(d,p_1,p_2) \geq 1, d \in [1,\dots,k-1]$.

For example, for the integer 4 and $(i,j)$ such that $ninds(i,j)$ has all four neigbors we have :

enter image description here

Note that by the nature of the definition of the variables $x(k,i,j)$ we can re-write the neighbor conditions as:

$\sum_{p \in ninds(i,j)} x(d,p_1,p_2) \geq x(k,i,j), d \in [1,\dots,k-1]$.

(This is a very convenient way to keep the maximization problem linear.)

Neighbor conditions generation

Let us generate the conditions. This can be done in several ways.

CellConditions[k_, {i_, j_}, {m_, n_}] := 
  Table[Total[Map[x @@ Prepend[#, d] &, NeighborIndexes[{i, j}, {m, n}]]] - x[k, i, j] >= 0, {d, 1, k - 1}];

Example of this function:

CellConditions[4, {3, 3}, {m, n}]

(* {
 x[1, 2, 3] + x[1, 3, 2] + x[1, 3, 4] + x[1, 4, 3] - x[4, 3, 3] >= 0, 
 x[2, 2, 3] + x[2, 3, 2] + x[2, 3, 4] + x[2, 4, 3] - x[4, 3, 3] >= 0, 
 x[3, 2, 3] + x[3, 3, 2] + x[3, 3, 4] + x[3, 4, 3] - x[4, 3, 3] >= 0}
*)

Generating all neighbor conditions:

neighborConds = 
  Flatten@Table[
    CellConditions[d, {i, j}, {m, n}], {d, 2, dmax}, {i, 1, m}, {j, 1,
      n}];
neighborConds // Length

(* 150 *)

Other constraints

In order to finish the formulation two other types of constraints have to be added.

1. Uniqueness constraints. (Only one integer is assigned per cell.)

uniqueConstraints = 
  Map[Total[Cases[vars, x[_, #[[1]], #[[2]]]]] == 1 &, 
   Flatten[Table[{i, j}, {i, 1, m}, {j, 1, n}], 1]];
uniqueConstraints // Length

(* 25 *)

2. Positivity / bounded-ness constraints:

varConstraints = Map[0 <= # <= 1 &, vars];

Because of the uniqueness constraints we do not need to specify $\leq 1$, but I have put it there as a reminder.

Solution with Maximize (too slow)

At this point we can find the solution with Maximize:

sol = Maximize[
  Join[{vars.vars[[All, 1]]}, neighborConds, uniqueConstraints, 
   varConstraints], vars, Integers]

Using Maximize though is too slow. I was able to get solutions only for smaller tables and number of integer values to be assigned, e.g. a $3 \times 4$ table and $d_{max} = 3$.

To get the solutions faster we can formulate the problem through vectors and matrices and use LinearProgramming.

Integer Linear Programming formulation

Convert from symbolic to matrix formulation

{zeroMat, neighborCondsMat} = 
  CoefficientArrays[neighborConds[[All, 1]], vars];
Dimensions[neighborCondsMat]

(* {150, 100} *)

{zeroMat, uniquenessCondsMat} = 
  CoefficientArrays[uniqueConstraints[[All, 1]], vars];
Dimensions[uniquenessCondsMat]

(* {25, 100} *)

bVec =
  Join[
   Table[{0, 1}, {Dimensions[neighborCondsMat][[1]]}], 
   Table[{1, 0}, {Dimensions[uniquenessCondsMat][[1]]}]
   ];

condMat = 
 Join[Normal[neighborCondsMat], Normal[uniquenessCondsMat]];
MatrixQ[condMat]

(* True *)

Solution with LinearProgramming

Using Table[{0, 1}, {Length[vars]}] as a fourth argument is not necessary because of the uniquness conditions.

AbsoluteTiming[
 lpSol = LinearProgramming[-vars[[All, 1]], condMat, bVec, 0, Integers]
]

(* Out[74]= {44.4484, {1, 0, 0, 0, 1, 0, 0, 1, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 1, 
  0, 0, 0, 0, 0, 1, 0, 0, 1, 0, 0, 0, 1, 0, 0, 1, 0, 0, 1, 0, 0, 0, 0, 0, 0, 
  0, 1, 0, 0, 0, 0, 1, 0, 0, 1, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 1, 0, 0, 1, 0, 
  0, 0, 1, 0, 1, 0, 0, 0, 0, 0, 0, 1, 0, 0, 1, 0, 0, 1, 0, 1, 0, 0, 0, 0, 0, 
  1, 0, 0}} *)

lpSol = Thread[vars -> lpSol];

vars[[All, 1]].lpSol[[All, 2]]

(* 61 *)

Visualize the solution

pSol = Select[lpSol, #[[2]] == 1 &];
solMat = SparseArray[Map[Rest[#] -> First[#] &, List @@@ pSol[[All,1]]]];
MatrixPlotWithValues[solMat]

enter image description here

(The definition of the function MatrixPlotWithValues is given below.)

Other solutions

$5 \times 6$ table

I tried the code above for a $5 \times 6$ table and got the following result after 422 seconds (10 times longer than for $5 \times 5$) on the same computer:

enter image description here

The total is $74$.

$6 \times 6$ table

Because of a comment by @garej I computed the layout for a $6 \times 6$ table (7182 seconds on the same computer):

enter image description here

The total is $90$.

Solution visualization function

Here is the function used for the plots above:

MatrixPlotWithValues[mat_?MatrixQ] :=
  Block[{gr, m, n},
   {m, n} = Dimensions[mat];
   gr = MatrixPlot[mat];
   Graphics[{gr[[1]], 
     MapThread[
      Text, {Flatten[Transpose@Reverse@mat], 
       Flatten[Table[{i, j} - 1/2, {i, n}, {j, m}], 1]}]}, 
    Frame -> True, 
    FrameTicks -> {Table[{i - 1/2, i}, {i, n}], 
      Table[{j - 1/2, m - j + 1}, {j, m}]}]
   ];

Generalizations

The solution can be easily adapted for possible generalizations of the problem formulation with tables that are one of:

  1. 3D cube,
  2. surface of a 3D cube,
  3. cylinder,
  4. torus,
  5. Mobius strip.
$\endgroup$
  • $\begingroup$ Very cool (+1). Can you say whether this is guaranteed to be the global maximum or not? $\endgroup$ – Rahul Apr 9 '16 at 6:54
  • $\begingroup$ @Rahul Thanks! I am not sure what LinearProgramming does for when the domain is Integers. If Branch-and-bound is used with relaxation to standard linear programming then finding the minimum is guaranteed. (Similarly for Maximize.) $\endgroup$ – Anton Antonov Apr 9 '16 at 10:56
  • $\begingroup$ @yode, so it is sparse :))) Interesting also that it has six 4's and six (!) 3's. When in comes to 6 X 6 what should be the range 1..4 or 1..5? $\endgroup$ – garej Apr 10 '16 at 9:22
  • $\begingroup$ @garej For the integers set 1..5 we still have $\leq 4$ defined neighbors, but only free to use permutations of 1..4 for them. I was thinking that for 1..5, 1..6, and 1..7 we have to go to 3D. $\endgroup$ – Anton Antonov Apr 10 '16 at 12:24
8
$\begingroup$

EDIT: Verification function:

    ValidMatrixQ[m_] := 
     With[{labelling = Flatten@m}, 
      AllTrue[Range[25], 
       ContainsAll[labelling[[AdjacencyList[GridGraph[{5, 5}], #]]], 
         Range[labelling[[#]] - 1]] &]
    ]

Is this a valid example? EDIT, Take 3: Grid courtesy of garej

m = {
  {3, 2, 1, 2, 3},
  {1, 4, 2, 4, 1},
  {2, 3, 1, 3, 2},
  {1, 4, 2, 4, 1},
  {3, 2, 1, 2 , 3}
 }

enter image description here

In which case perhaps adding it to your question will help clarify what you are after. Also the total is 57...

No guarantees this is maximised!

$\endgroup$
  • $\begingroup$ it should be something like m = {{3, 2, 1, 2, 3}, {1, 4, 2, 4, 1}, {2, 3, 1, 3, 2}, {1, 4, 2, 4, 1}, {3, 2, 1, 2 , 3}} $\endgroup$ – garej Apr 2 '16 at 16:42
  • 1
    $\begingroup$ Ha, yes! Harder than it looks! Thanks. $\endgroup$ – Quantum_Oli Apr 2 '16 at 16:50
  • $\begingroup$ @yode, to get 59 try {{2, 1, 2, 1, 2}, {4, 3, 4, 3, 4}, {1, 2, 1, 2, 1}, {4, 3, 4, 3, 4}, {2, 1, 2, 1, 2}}... $\endgroup$ – garej Apr 2 '16 at 17:27
  • $\begingroup$ @garej Thanks a lot. $\endgroup$ – yode Apr 2 '16 at 17:31
  • 1
    $\begingroup$ Beautifully ValidMatrixQ $\endgroup$ – yode Apr 2 '16 at 17:49

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.