3
$\begingroup$

I wrote the following code:

u = {{{7, 3}, {4, 1}, {2, 8}, {6, 5}},
     {{1, 4}, {5, 2}, {3, 1}, {8, 6}},
     {{7, 3}, {6, 3}, {4, 2}, {1, 8}},
     {{2, 6}, {8, 4}, {5, 3}, {2, 1}},
     {{7, 8}, {1, 1}, {6, 4}, {3, 2}},
     {{2, 1}, {2, 6}, {2, 5}, {4, 3}},
     {{7, 2}, {3, 8}, {1, 6}, {5, 4}}};

v = Table[If[u[[j, k, 1]] == i || u[[j, k, 2]] == i, 1, 0], 
          {i, 8}, {j, 7}, {k, 4}];

w = Table[Sum[v[[i, j, k]], {k, 4}], {i, 8}, {j, 7}];

x = Table[Sum[v[[i, j, k]], {i, 8}], {j, 7}, {k, 4}];

y = Table[Sum[v[[i1, j, k]] v[[i2, j, k]], {j, 7}, {k, 4}], 
          {i1, 8}, {i2, i1 + 1, 8}];

z = Table[Sum[(v[[i1, j, 2 l - 1]] + v[[i1, j, 2 l]]) 
              (v[[i2, j, 2 l - 1]] + v[[i2, j, 2 l]]), 
              {j, 7}, {l, 2}], {i1, 8}, {i2, i1 + 1, 8}];

Total[Flatten[Abs[{w - 1, x - 2, y - 1, z - 3}]]]

which reproduces correct results as the numbers in u vary.

Question:

Can it be optimized by making the most of Mathematica's capabilities?

Improve this question
$\endgroup$

2 Answers 2

Reset to default
2
$\begingroup$

Here is a proposal how to write w,x,y,z without "Sum":

Plus @@ Transpose[v, {2, 3, 1}] == w
Plus @@ v == x
Table[Total[v[[i1]] v[[i2]], 3], {i1, 8}, {i2, i1 + 1, 8}] == y
Table[Total[(v[[i1, ;; , {1, 3}]] + v[[i1, ;; , {2, 4}]]) (v[[i2, ;; , {1, 3}]] + v[[i2, ;; , {2, 4}]]), 2], {i1, 8}, {i2, i1 + 1, 8}]  == z

True
True
True
True
Improve this answer
$\endgroup$
1
$\begingroup$ 
w = Total[v, {3}];

x = Total[v, {1}];

y = With[{vv = Flatten[v, {{1}, {2, 3}}]},
  Table[vv[[i1]] . vv[[i2]], {i1, 8}, {i2, i1 + 1, 8}]
  ]

v = ConstantArray[0, {8, 7, 4}];
Do[
  v[[u[[k, l, 1]], k, l]] = 1;
  v[[u[[k, l, 2]], k, l]] = 1;
  , {k, 1, 7}, {l, 1, 4}];

We can assemble v also as a sparse matrix by using the following helper function (whose functionality really should be built into the language, IMHO).

(* This function allows us to create SparseArrays with duplicated \
pattern entries handled by the function reducer. E.g., additive \
assembly can be done with sparseArray[rules,dims,Total,0].
*)
sparseArray[rules_, dims_, reducer_ : Total, background_ : 0] : =   
  With[{spopt = SystemOptions["SparseArrayOptions"]},
   Internal`WithLocalSettings[
    SetSystemOptions[
     "SparseArrayOptions" -> {"TreatRepeatedEntries" -> reducer}],
    SparseArray[rules, dims, background],
    SetSystemOptions[spopt]
    ]
   ];

Now we can generate the nonzero pattern for v and assemble it

pattern = Join[
  Partition[Flatten[u], 1], 
  Riffle[#, #] &@Tuples[{Range[7], Range[4]}], 
  2
];

v = sparseArray[pattern -> 1, {8, 7, 4}, Max, 0];
Improve this answer
$\endgroup$
2
  • $\begingroup$ Just to say that I didn't vote you as the best answer because it goes beyond my limited knowledge of Mathematica. But I wanted to tell you that I still appreciate your free advice in this forum, many times through the search function I ended up in your old answers and they were pure gold. Thanks from Italy. $\endgroup$ Commented Feb 14 at 22:36
  • 2
    $\begingroup$ Hehe. No worries! This kind of feedback makes me way happier than points could ever do. Greetings from Athens, Georgia, USA. $\endgroup$ Commented Feb 14 at 23:07