Find position without iterating

Question

The code below solves for the four value of $m_i$ for a given pair of $(N_m,M_m)$.

where $$ m_1+m_2+m_3+m_4 = M_m\\ |m_1|+|m_2|+|m_3|+|m_4| = N_m $$

---

Edit 2

New Sorting

I have now realised that the sorting I used was not ideal. So I have changed it slightly.

 sol2[Nm_, Mm_] :=
 SortBy[{m1, m2, m3, 
 m4} /. (Solve[
 m1 + m2 + m3 + m4 == Mm && 
  Abs[m1] + Abs[m2] + Abs[m3] + Abs[m4] == Nm, {m1, m2, m3, m4}, 
 Integers]), {Count[#, _?Negative] &,Select[#, NonNegative] &,Negative}]

So now with this sorting a few example solutions are as follows:

 sol2[1, -1]
 (*{{0, 0, 0, -1}, {0, 0, -1, 0}, {0, -1, 0, 0}, {-1, 0, 0, 0}}*)


 sol2[3,-1]
 (*{{0, 0, 1, -2}, {0, 0, -2, 1}, {0, -2, 0, 1}, {-2, 0, 0, 1}, {0, 1, 0, -2}, {0, 1, -2, 0}, {0, -2, 1, 0}, {-2, 0, 1, 0}, {1, 0, 0, -2}, {1, 0, -2, 0}, {1, -2, 0, 0}, {-2, 1, 0, 0}, {0, 1, -1, -1}, {0, -1, 1, -1}, {0, -1, -1, 1}, {-1, 0, 1, -1}, {-1, 0, -1, 1}, {-1, -1, 0, 1}, {1, 0, -1, -1}, {1, -1, 0, -1}, {1, -1, -1, 0}, {-1, 1, 0, -1}, {-1, 1, -1, 0}, {-1, -1, 1, 0}}*)

  sol2[3,1]
(*{{0, 0, 2, -1}, {0, 0, -1, 2}, {0, -1, 0, 2}, {-1, 0, 0, 2}, {0, 1, 1, -1}, {0, 1, -1, 1}, {0, -1, 1, 1}, {-1, 0, 1, 1}, {0, 2, 0, -1}, {0, 2, -1, 0}, {0, -1, 2, 0}, {-1, 0, 2, 0}, {1, 0, 1, -1}, {1, 0, -1, 1}, {1, -1, 0, 1}, {-1, 1, 0, 1}, {1, 1, 0, -1}, {1, 1, -1, 0}, {1, -1, 1, 0}, {-1, 1, 1, 0}, {2, 0, 0, -1}, {2, 0, -1, 0}, {2, -1, 0, 0}, {-1, 2, 0, 0}}*)

 sol2[2,2]
 (*{{0, 0, 0, 2}, {0, 0, 1, 1}, {0, 0, 2, 0}, {0, 1, 0, 1}, {0, 1, 1, 0}, {0, 2, 0, 0}, {1, 0, 0, 1}, {1, 0, 1, 0}, {1, 1, 0, 0}, {2, 0, 0, 0}}*)

 sol2[2,-2]
(*{{0, 0, 0, -2}, {0, 0, -2, 0}, {0, -2, 0, 0}, {-2, 0, 0, 0}, {0, 0, -1, -1}, {0, -1, 0, -1}, {0, -1, -1, 0}, {-1, 0, 0, -1}, {-1, 0, -1, 0}, {-1, -1, 0, 0}}*)

 sol2[3,-3]
(*{{0, 0, 0, -3}, {0, 0, -3, 0}, {0, -3, 0, 0}, {-3, 0, 0, 0}, {0, 0, -2, -1}, {0, 0, -1, -2}, {0, -2, 0, -1}, {0, -1, 0, -2}, {0, -2, -1, 0}, {0, -1, -2, 0}, {-2, 0, 0, -1}, {-1, 0, 0, -2}, {-2, 0, -1, 0}, {-1, 0, -2, 0}, {-2, -1, 0, 0}, {-1, -2, 0, 0}, {0, -1, -1, -1}, {-1, 0, -1, -1}, {-1, -1, 0, -1}, {-1, -1, -1, 0}}*)

---

Original Sorting

sol[Nm_, Mm_] :=
 SortBy[{m1, m2, m3, 
 m4} /. (Solve[
 m1 + m2 + m3 + m4 == Mm && 
  Abs[m1] + Abs[m2] + Abs[m3] + Abs[m4] == Nm, {m1, m2, m3, m4}, 
 Integers]), Negative]

---

I would like to have a function (findPosition) which gives the position of the solution given the four $m_i$ values without going over all the solutions.

For e.g.

Based on the original sorting used in sol

findPosition[{0, 0, -1, 0}] = 2
findPosition[{0, 0, 1, 1}] = 2  (* see sol[2,2]*)
findPosition[{0, 0, -1, -1}] = 3 (* see sol[2,-2]*)
findPosition[{0, 0, -2, -1}] = 3  (* see sol[3,-3]*)

Based on the new sorting in sol2

findPosition[{0, 0, -1, 0}] = 2
findPosition[{0, 0, 1, 1}] = 2  (* see sol2[2,2]*)
findPosition[{0, 0, -1, -1}] = 5 (* see sol2[2,-2]*)
findPosition[{0, 0, -2, -1}] = 5  (* see sol2[3,-3]*)

$m_i$ are integers.

---

Edit 1

Also I'm looking for an answer that should be somewhat faster than the trivial approach shown below where you simply scan over all the results and find the match.

  solf[Nm_, Mm_] := 
  SortBy[Partition[
  Flatten[Permutations /@ 
  Select[IntegerPartitions[Mm, {4}, 
   Range[-Nm - 1, 
    Nm + 1]], (Abs[#[[1]]] + Abs[#[[2]]] + Abs[#[[3]]] + 
      Abs[#[[4]]] == Nm) &]], 4], {Count[#, _?Negative] &, Select[#, NonNegative] &, Negative}]


 findPosition[mlist_] := 
 Position[solf[
 Abs[mlist[[1]]] + Abs[mlist[[2]]] + Abs[mlist[[3]]] + 
 Abs[mlist[[4]]], Total[mlist]], mlist];

 findPosition[{-1, 0, -1, 1}] // AbsoluteTiming
 (*{0.000282, {{17}}} *)

Answer 1

REWRITE for EDIT 2

First, turns out the sort can be ambiguous, so to make it total, add a criteria

sol2[Nm_, Mm_] := SortBy[
           (Solve[m1 + m2 + m3 + m4 == Mm && 
           Abs[m1] + Abs[m2] + Abs[m3] + Abs[m4] == Nm, {m1, m2, m3, m4}, 
           Integers]//Values), 
       {
       Count[#, _?Negative] &,
       Select[#, NonNegative] &,
       Negative, 
       Select[#, Negative] & (* this breaks some ties *)
       }]

For the data sets, as noted, you are sorting on the criteria in order (each criteria is used to break ties from the prior one):

1. the number of negative numbers first, then
2. the subset of just the nonnegative elements (using canonical ordering for lists), then
3. the set gained when you replace negative terms with a '1' and nonnegative with a '0'
4. the subset of just the negative elements (using canonical ordering for lists)

An index can then be constructed by counting things. We need some intermediate results. First, number of permutations in a problem where negative terms add to neg, nonnegative add to pos, and you have k negative terms, From https://mathematica.stackexchange.com/a/188718/47314

nc[neg_, pos_, k_] := Binomial[4, k]
                    * NumberOfCompositions[neg-k, k] 
                    * NumberOfCompositions[pos, 4-k];

From @ciao, with a set of X values {m1,m2,...,mX} all positive, it gives you the index value. Note that it works for X other than 4, and includes 0 values. https://mathematica.stackexchange.com/a/188126/47314

f = With[{s = Accumulate@Reverse@# + 1, r = Range[Length@# - 1]},  
    Tr[(Pochhammer[Rest@s, r] - Pochhammer[Most@s, r])/r!] + 1] &;

In the case where we do not allow zero values, we can get another indexing

fNZ[s_] := f@(s - 1)

Now write the function that indexes the {m1,m2,m3,m4}

indexCalc[prob_] := Module[{
    k = Count[prob, _?Negative],
    negEls = -Select[prob, Negative],
    posEls = Select[prob, NonNegative],
    mask = Negative[prob] // Boole,
    index = 0,
    neg = 0,
    pos = 0,
    shuff = 0
    },

   neg = negEls // Total;
   pos = posEls // Total;

   (* determine the position of the mask in the perm order *)
   shuff = Position[Sort[Permutations[mask]], mask] // Flatten // First;

    (* number of terms prior to k *)
   index = Sum[nc[neg, pos, i], {i, 1, k - 1}];

    (* With k, count up through the permutations of nonnegative elements *)
   index += (f@posEls - 1)*NumberOfCompositions[neg - k, k]*Binomial[4, k];

   (* with k and nonneg perm, count up through the arrangements of the negative numbers *)
   index += (shuff - 1)*NumberOfCompositions[neg - k, k];

   (* now count down from indexing of subset of negatives, since negative values *) 
   index += (NumberOfCompositions[neg - k, k] + 1) - fNZ[negEls];

   index

   ];

* TESTS *

nn = 10; mm = 0;
res = sol2[nn, mm];
Length[res]
AbsoluteTiming[ Range[Length[res]] == Map[indexCalc, res]]

252

{0.021, True}

nn = 100; mm = 0;
res = sol2[nn, mm];
Length[res]
AbsoluteTiming[ Range[Length[res]] == Map[indexCalc, res]]

25002

{1.90, True}

nn = 200; mm = -2;
res = sol2[nn, mm];
Length[res]
AbsoluteTiming[ Range[Length[res]] == Map[indexCalc, res]]

100000

{7.74, True}

So about 0.0000774 seconds per indexing.

Answer 2

I don't have a solution for you but perhaps some useful thoughts. You can express sol using FrobeniusSolve, or IntegerPartitions and Permutations:

sol2[Nm_, Mm_] := FrobeniusSolve[{1, 1, 1, 1}, Nm] Sign[Mm] // SortBy[Negative]

sol3[Nm_, Mm_] := Permutations /@
    PadRight[Sign[Mm] IntegerPartitions[Nm, 4], {Automatic, 4}] // Catenate // 
  SortBy[Negative]

sol[5, -5] === sol2[5, -5] === sol3[5, -5]   (* True *)

It seems to me that your goal is a kind of permutation ranking, and I believe one could, with enough trouble, figure out an algorithm for that based on the integer partitions. I think however that I would first seek to re-implement FrobeniusSolve as that would likely inform of the implicit iteration, which should be useful in crafting a ranking algorithm.

Answer 3

OK, I've solved one of the simplest cases, namely, when all but one of the elements are zero. Here's the implementation (excuse my procedural style, I'm relatively new to Mathematica).

First, we define this helper function:

num[n_, pos_] := 
 If[n > 0, 1/n!  Pochhammer[pos, n], 
  1/(-n)! Pochhammer[pos - 1, -n] + 1 ]

where n is the non-zero element, and pos is its position (from right to left, starting from 1).

Notice that this works for positive and negative integers. Now it's a matter of computing n and pos, and call num[n, pos]:

findPosition[s_] := Module[{n , pos},
  On[Assert];
  n = Cases[s, n_ /; n != 0];
  Assert[Length[n] == 1];
  pos = 5 - Flatten[Position[s, n_ /; n != 0]];
  num[n[[1]], pos[[1]]]
  ]

Some results:

Table[{findPosition[{0, 0, 0, a}], findPosition[{0, 0, a, 0}], 
  findPosition[{0, a, 0, 0}], findPosition[{a, 0, 0, 0}]}, {a, 1, 4} ]

{{1, 2, 3, 4}, {1, 3, 6, 10}, {1, 4, 10, 20}, {1, 5, 15, 35}}

Table[{findPosition[{0, 0, 0, a}], findPosition[{0, 0, a, 0}], 
  findPosition[{0, a, 0, 0}], 
  findPosition[{a, 0, 0, 0}]}, {a, -1, -4, -1} ]

{{1, 2, 3, 4}, {1, 2, 4, 7}, {1, 2, 5, 11}, {1, 2, 6, 16}}

To solve the other cases, it's also a matter of inspecting the sequences, and coming up with the right combination of formulas to compute the solution's position, in the list of possible solutions.

For reference, here's the brute force function I'm using to check the values:

findPositionB[s_] := Module[{},
  Flatten[Position[sol[Total[Abs /@ s], Total[s]], s]][[1]]
  ]