5
$\begingroup$

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}}} *)
$\endgroup$
  • $\begingroup$ Just to be clear, for a given call to findPosition, you don't know ahead of time what the Nm and Mm are, and you want to avoid manually searching all possible values for them? $\endgroup$ – Jason B. Dec 28 '18 at 15:23
  • $\begingroup$ Actually Nm and Mm are known as soon as you get the four values of mi by definition. I was looking for something which does not use Solve, FindInstance and other such commands. $\endgroup$ – Hubble07 Dec 28 '18 at 17:26
  • $\begingroup$ This question is a more general form of this one link. Here we include the negative integers also. $\endgroup$ – Hubble07 Dec 28 '18 at 18:05
  • 3
    $\begingroup$ Since you don't want solutions using Solve, FindInstance, Reduce, or any other Mathematica built-ins that could solve this, it might be better to ask this first on computer science Stack Exchange to get the right algorithm, and then ask here for the implementation. Someone here could know what the right algorithm is, but it's more unlikely here than on computer science Stack Exchange. $\endgroup$ – C. E. Jan 1 at 11:07
  • 1
    $\begingroup$ Hubble, a problem is in your SortBy[ ] function call, using Negative[ ] as the criteria results in a lot of ties between terms (since Negative only gives True or False) that then get broken in a way that makes it hard to come up with a counting scheme. Try Map[Negative, sol[3,-3]] // Boole // TableForm and you can see how it is just walking up through the binary numbers, with lots of ties to be broken. Recommend you make the implicit explicit by writing `SortBy[list, {Negative, f2,...}] to make it up front and clear and help sort out a counting scheme. $\endgroup$ – MikeY Jan 3 at 16:06
4
+100
$\begingroup$

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.

$\endgroup$
  • $\begingroup$ But is there a way to get the correct ordering otherwise how would I use this code. Maybe there is a mapping from your ordering to what I want which holds for any (N_m, M_m) value. Also see my edit in the question. Please check your speed with the naive approach. I would like a solution that firstly gives the actual position and secondly it should be considerably faster than the trivial method I have shown. Anyway I really appreciate the time and effort you have shown. Thank you very much. I will wait to see if someone can provide an answer that meets my criteria. $\endgroup$ – Hubble07 Jan 3 at 6:53
  • 1
    $\begingroup$ By using my ordering, I was able to count my way through to a closed form for ordering and indexing. It also offers a path to creating the solutions that doesn’t involve a Solve[ ]. I didn’t see an obvious counting scheme in your SortBy[ ] ordering, but the approach of decomposing the problem I figured could inspire you. This is similar to a problem I have, and working on yours helped me quite a bit, so, thanks for posing it! $\endgroup$ – MikeY Jan 3 at 12:03
  • $\begingroup$ Note that for the case when Nm = Mm although it returns the correct value , it throws in some error. But its OK since for Nm = Mm @ciao function directly works fine. $\endgroup$ – Hubble07 Jan 7 at 8:20
  • $\begingroup$ OK, I'll declare success. Again, thanks for the interesting problem, it gave me insight on my own. $\endgroup$ – MikeY Jan 7 at 13:36
2
$\begingroup$

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.

$\endgroup$
  • $\begingroup$ But sol[3, -1] != sol2[3, -1] $\endgroup$ – Hubble07 Jan 1 at 14:27
  • $\begingroup$ @Hubble07 Hm... none of your examples demonstrated that asymmetry and I overlooked that possibility. Shall I delete this answer? $\endgroup$ – Mr.Wizard Jan 1 at 14:37
2
$\begingroup$

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]]
  ]
$\endgroup$
  • $\begingroup$ Good. This looks promising. But unless it can be generalized to the case of 2-zero and 1-zero I won't be able to use this. Anyway at-least we have something to think on. $\endgroup$ – Hubble07 Jan 2 at 14:58
  • $\begingroup$ I'm now working in the 2-zero case which, despite its variants, looks generalizable. $\endgroup$ – Mauro Lacy Jan 2 at 15:25

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.