Find position without iterating
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):
- the number of negative numbers first, then
- the subset of just the nonnegative elements (using canonical ordering for lists), then
- the set gained when you replace negative terms with a '1' and nonnegative with a '0'
- 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.
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.
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]]
]