How to improve the speed of NMaximize function

Question

My problem is as follows: Consider a 5*5 matrix Obj with 0 and 1

Obj = Array[x, {5, 5}];     

The objective function is:

 r = Total[Obj, 2];

We need to maximise the objective function with the following constraint: $x_{i,j} + x_{j,k}+x_{k,z} < 2$ where $i,j,k,z \in \{1,2,3,4,5\}$ and $i \neq j \neq k \neq z$. Our coding is as follows:

 vars = Union@Cases[r, x[_, _], Infinity];
 t1 = Table[If[i != j, Obj[[i]][[j]], ex], {i, 1, 5}, {j, 1, 5}];

 fn1[γ_, p_] :=
 p1 = If[ Dimensions[p][[2]] == Dimensions[t1][[2]],  Drop[p, 0, {Flatten[Position[p, γ]][[1]]}], Drop[p, 0, {Flatten[ Position[p, t1[[Flatten[Position[t1, γ]][[2]]]][[ Flatten[Position[t1, γ]][[1]]]]] ][[2]]}] ]

fn2[γ_, p_] :=
Cases[fn1[γ, p][[Flatten[Position[t1, γ]][[2]]]], Except[ex]]  

fn3[i_, j_] := { Tuples[{{i}, {Flatten[fn2[i, t1]][[Flatten[Position[Flatten[fn2[i, t1]], j]][[1]]]]}, Flatten[fn2[j, fn1[i, t1]]]}] }

vars3 = Flatten[ Total[Table[Map[fn3[i, #] & , Flatten[fn2[i, t1]]], {i, 
 Flatten[Cases[Flatten[t1], Except[ex]]]}], {-1}]]

The result from the above functions is that:

 {x[1, 2] + x[2, 3] + x[3, 4], x[1, 2] + x[2, 3] + x[3, 5], 
  x[1, 2] + x[2, 4] + x[4, 3], x[1, 2] + x[2, 4] + x[4, 5], 
 x[1, 2] + x[2, 5] + x[5, 3], x[1, 2] + x[2, 5] + x[5, 4], 
 x[1, 3] + x[2, 4] + x[3, 2], x[1, 3] + x[2, 5] + x[3, 2], 
 x[1, 3] + x[3, 4] + x[4, 2], x[1, 3] + x[3, 4] + x[4, 5], 
 x[1, 3] + x[3, 5] + x[5, 2], x[1, 3] + x[3, 5] + x[5, 4], 
 x[1, 4] + x[2, 3] + x[4, 2], x[1, 4] + x[2, 5] + x[4, 2], 
 x[1, 4] + x[3, 2] + x[4, 3], x[1, 4] + x[3, 5] + x[4, 3], 
 x[1, 4] + x[4, 5] + x[5, 2], x[1, 4] + x[4, 5] + x[5, 3], 
 x[1, 5] + x[2, 3] + x[5, 2], x[1, 5] + x[2, 4] + x[5, 2], 
 x[1, 5] + x[3, 2] + x[5, 3], x[1, 5] + x[3, 4] + x[5, 3], 
 x[1, 5] + x[4, 2] + x[5, 4], x[1, 5] + x[4, 3] + x[5, 4], 
 x[1, 3] + x[2, 1] + x[3, 4], x[1, 3] + x[2, 1] + x[3, 5], 
 x[1, 4] + x[2, 1] + x[4, 3], x[1, 4] + x[2, 1] + x[4, 5], 
 x[1, 5] + x[2, 1] + x[5, 3], x[1, 5] + x[2, 1] + x[5, 4], 
 x[1, 4] + x[2, 3] + x[3, 1], x[1, 5] + x[2, 3] + x[3, 1], 
 x[2, 3] + x[3, 4] + x[4, 1], x[2, 3] + x[3, 4] + x[4, 5], 
 x[2, 3] + x[3, 5] + x[5, 1], x[2, 3] + x[3, 5] + x[5, 4], 
 x[1, 3] + x[2, 4] + x[4, 1], x[1, 5] + x[2, 4] + x[4, 1], 
 x[2, 4] + x[3, 1] + x[4, 3], x[2, 4] + x[3, 5] + x[4, 3], 
 x[2, 4] + x[4, 5] + x[5, 1], x[2, 4] + x[4, 5] + x[5, 3], 
 x[1, 3] + x[2, 5] + x[5, 1], x[1, 4] + x[2, 5] + x[5, 1], 
 x[2, 5] + x[3, 1] + x[5, 3], x[2, 5] + x[3, 4] + x[5, 3], 
 x[2, 5] + x[4, 1] + x[5, 4], x[2, 5] + x[4, 3] + x[5, 4], 
 x[1, 2] + x[2, 4] + x[3, 1], x[1, 2] + x[2, 5] + x[3, 1], 
 x[1, 4] + x[3, 1] + x[4, 2], x[1, 4] + x[3, 1] + x[4, 5], 
 x[1, 5] + x[3, 1] + x[5, 2], x[1, 5] + x[3, 1] + x[5, 4], 
 x[1, 4] + x[2, 1] + x[3, 2], x[1, 5] + x[2, 1] + x[3, 2], 
 x[2, 4] + x[3, 2] + x[4, 1], x[2, 4] + x[3, 2] + x[4, 5], 
 x[2, 5] + x[3, 2] + x[5, 1], x[2, 5] + x[3, 2] + x[5, 4], 
 x[1, 2] + x[3, 4] + x[4, 1], x[1, 5] + x[3, 4] + x[4, 1], 
 x[2, 1] + x[3, 4] + x[4, 2], x[2, 5] + x[3, 4] + x[4, 2], 
 x[3, 4] + x[4, 5] + x[5, 1], x[3, 4] + x[4, 5] + x[5, 2], 
 x[1, 2] + x[3, 5] + x[5, 1], x[1, 4] + x[3, 5] + x[5, 1], 
 x[2, 1] + x[3, 5] + x[5, 2], x[2, 4] + x[3, 5] + x[5, 2], 
 x[3, 5] + x[4, 1] + x[5, 4], x[3, 5] + x[4, 2] + x[5, 4], 
 x[1, 2] + x[2, 3] + x[4, 1], x[1, 2] + x[2, 5] + x[4, 1], 
 x[1, 3] + x[3, 2] + x[4, 1], x[1, 3] + x[3, 5] + x[4, 1], 
 x[1, 5] + x[4, 1] + x[5, 2], x[1, 5] + x[4, 1] + x[5, 3], 
 x[1, 3] + x[2, 1] + x[4, 2], x[1, 5] + x[2, 1] + x[4, 2], 
 x[2, 3] + x[3, 1] + x[4, 2], x[2, 3] + x[3, 5] + x[4, 2], 
 x[2, 5] + x[4, 2] + x[5, 1], x[2, 5] + x[4, 2] + x[5, 3], 
 x[1, 2] + x[3, 1] + x[4, 3], x[1, 5] + x[3, 1] + x[4, 3], 
 x[2, 1] + x[3, 2] + x[4, 3], x[2, 5] + x[3, 2] + x[4, 3], 
 x[3, 5] + x[4, 3] + x[5, 1], x[3, 5] + x[4, 3] + x[5, 2], 
 x[1, 2] + x[4, 5] + x[5, 1], x[1, 3] + x[4, 5] + x[5, 1], 
 x[2, 1] + x[4, 5] + x[5, 2], x[2, 3] + x[4, 5] + x[5, 2], 
 x[3, 1] + x[4, 5] + x[5, 3], x[3, 2] + x[4, 5] + x[5, 3], 
 x[1, 2] + x[2, 3] + x[5, 1], x[1, 2] + x[2, 4] + x[5, 1], 
 x[1, 3] + x[3, 2] + x[5, 1], x[1, 3] + x[3, 4] + x[5, 1], 
 x[1, 4] + x[4, 2] + x[5, 1], x[1, 4] + x[4, 3] + x[5, 1], 
 x[1, 3] + x[2, 1] + x[5, 2], x[1, 4] + x[2, 1] + x[5, 2], 
 x[2, 3] + x[3, 1] + x[5, 2], x[2, 3] + x[3, 4] + x[5, 2], 
 x[2, 4] + x[4, 1] + x[5, 2], x[2, 4] + x[4, 3] + x[5, 2], 
 x[1, 2] + x[3, 1] + x[5, 3], x[1, 4] + x[3, 1] + x[5, 3], 
 x[2, 1] + x[3, 2] + x[5, 3], x[2, 4] + x[3, 2] + x[5, 3], 
 x[3, 4] + x[4, 1] + x[5, 3], x[3, 4] + x[4, 2] + x[5, 3], 
 x[1, 2] + x[4, 1] + x[5, 4], x[1, 3] + x[4, 1] + x[5, 4], 
 x[2, 1] + x[4, 2] + x[5, 4], x[2, 3] + x[4, 2] + x[5, 4], 
 x[3, 1] + x[4, 3] + x[5, 4], x[3, 2] + x[4, 3] + x[5, 4]}

Then, we use the NMaximise to solve this problem:

       Incsolution[r_] := NMaximize[{r, And @@ Map[GreaterEqual[ 1, #, 0] &, vars] 
      && vars ∈ Integers
      && And @@ Map[GreaterEqual[2, #] &, vars3]}, vars];

     solution= Incsolution[r][[1]];

Our problem is that when we try 25*25 matrix, the speed is very slow. Is there any solution to solve this problem like using Compile function (using C)? I have tried Compile but failed.

Answer 1

First, notice that any nxn array of binary numbers corresponds to exactly one integer between 0 and (2^n)^2 - 1. You could, for example, use

Partition[
  IntegerDigits[415, 2, 5^2],
  5
]

to generate the 5x5 matrix which corresponds to the number 415. Thus, you actually have only one single integer input parameter n, with 0 <= n <= 33554431.

You can use a compiled function to test a given number n for your constraint. A very naive implementation could be

testfun = With[{rank = 5},
  Compile[{{n, _Integer}},
   Module[{good = True, i, j, k, z},
    (* generate the list of binary digits of n *)
    With[{q = IntegerDigits[n, 2, rank^2]},
     good = True;
     (* test the condition for all combinations of i,j,k,z *)
     Do[
      If[
       DuplicateFreeQ[{i, j, k, z}] && (q[[(i - 1) rank + j]] + q[[(j - 1) rank + k]] + q[[(k - 1) rank + z]] >= 2),
       (* if a (i,j,k,z)-tuple is encountered for which 
       the condition does not hold, abort *)
       good = False; Return[]
       ],
      {i, 1, rank}, {j, 1, rank}, {k, 1, rank}, {z, 1, rank}
      ];
     (* if this input is good, return the generating number; 
     otherwise return 0 *)
     If[good, n, 0]
     ]
    ],
   RuntimeAttributes -> Listable
   ]
  ]

Here I worked directly with the list of digits (a 1-dimensional array), instead of the partitioned 2-dimensional array, but you may use Partition, as shown above.

Using this compiled function, you can just test all the numbers from 0 to 33554431, and then pick the one for which your objective function Total[IntegerDigits[#,2]]& is maximal. For example

(* find all numbers which survive the test *)
goodNumbers = testfun[Range[0, 33554431]] /. (0) -> Nothing;

MaximalBy[goodNumbers, Total[IntegerDigits[#, 2]] &]

Due to my naive implementation of the test function this is still extremely slow! But I suppose this should give you a good starting point.

Addendum

I just realized that your objective function is proportional to the integer n itself. So you should start with the largest one, (2^n)^2 - 1, and apply the test to lower and lower numbers. The first number for which the test succeeds, is the maximum. the binary digit sum of n. You may be able to use this to your advantage.