8
$\begingroup$

A fun combinatoric puzzle that's popped up in my work that I think would be cute to have a Mathematica solution to, if anyone wants to give it a go. It's basically a ladder climbing/descending problem so probably has a nice Graph solution. It is worth noting that my ladder can descend into the basement (i.e. my integer values can go below $0$)

Starting at $0$, over $k$ steps of $\pm1$, what are the paths that will land on the integer $n$, assuming of course that $k \ge n$.

I don't mind if this question gets closed for lack of effort on my part (I'm currently working out an analytic solution) and would actually be very happy if this were closed as a duplicate/if someone could point me to the proper name for this problem. But I thought Mathematica.SE might enjoy a quick, easy problem to break the "solve my integro-differential equation for me" drudgery.

$\endgroup$
4
  • $\begingroup$ At first sight, the solution only exists when m = (k - n) / 2 is an integer number, and then the total number of such distinct paths should just be C(k, m) = k!/(m!(k-m)!). $\endgroup$ Oct 18 '20 at 17:53
  • $\begingroup$ @LeonidShifrin yep only possible if k and m are both even/odd. I'm working on getting the paths themselves, not just the number of them, unfortunately. $\endgroup$
    – b3m2a1
    Oct 18 '20 at 18:10
  • $\begingroup$ But there will be a lot of them in general, and the formula above - assuming it is correct - makes it pretty clear how to get them all. Do you want them all just listed as lists of steps, or do something with them (like plotting or performing some further computation on them)? $\endgroup$ Oct 18 '20 at 18:53
  • $\begingroup$ I’m actually using them basically in a factorial (well I’m hoping to work out a simplification that avoids actually using them) but I’d take an answer that just lists them $\endgroup$
    – b3m2a1
    Oct 18 '20 at 18:59
5
$\begingroup$

Update:

Per my reread and your comments, the following will generate all paths. It dramatically outperforms the existing answers, and is about two orders of magnitude faster on the ${k,n}={25,7}$ test than the compiled version using $gosperc$.

Join @@ Permutations /@ IntegerPartitions[n, {k}, {-1, 1}]

The direct count is given by:

(1 - Mod[n + k, 2]) Binomial[k, Floor[(k - n)/2]]

Timing comparison for a slightly larger case:

{n, k} = {9, 29};

ClearAll[r, me, ls]
ClearSystemCache[]

(* This *)
me = Join @@ Permutations /@ IntegerPartitions[n, {k}, {-1, 1}]; // 
  AbsoluteTiming // First

(* eyorble compiled C *)
up = (n + k)/2;
r = Map[cvlist[k, #] &, 
     NestList[gosperc, 2^up - 1, Binomial[k, up] - 1]]; // 
  AbsoluteTiming // First

(* Leonid *)
ls = paths[n, k]; // AbsoluteTiming // First

Length /@ {r, me, ls}
Sort[me] == Sort[r] == Sort[ls]

1.45388

153.622

104.509

{20030010, 20030010, 20030010}

True

Original post:

I presume that when at "0", a step of -1 leaves one still at "0". You're on the ground or not...

This then is a bounded random walk on the integers, easily represented as a Markov process.

pathsm = PDF[
     DiscreteMarkovProcess[1, 
       SparseArray[{{#1 + 1, #1 + 1} -> 1, {1, 1} -> 1/2, 
         Band[{2, 1}, {#1, #1 + 1}] -> 1/2, 
         Band[{1, 2}] -> 1/2}, {#1 + 1, #1 + 1}]][#1], #2 + 1]*2^#1 &;

Usage: pathsm[k, n]

A comparison of timings of this, Leonid's and eyorble's on ${k,n}={30,10}$ gives 0.0007, 159.9, and 359.9 seconds.

The direct result for counts is Binomial[k, Floor[(k - n)/2]].

N.B.: in rereading the question, this may not be responsive, as it counts paths vs enumerating them. Nonetheless, it may be useful in your investigation, so I'll keep it here unless you comment otherwise.

$\endgroup$
3
  • $\begingroup$ These are intended to be displacements, so I do expect to be able to get to negative numbers, but definitely a cool approach and probably has a connection to my actual problem of interest. $\endgroup$
    – b3m2a1
    Oct 18 '20 at 21:53
  • $\begingroup$ @b3m2a1 - glad it has some use to you. In the case of allowing negatives you can just extend the markov chain as a mirror, and start in the middle state. (you might want to edit the question - perhaps a ladder in a well where it has +/- steps rungs, run 0 at ground) $\endgroup$
    – ciao
    Oct 18 '20 at 22:01
  • $\begingroup$ @b3m2a1 - see update please. $\endgroup$
    – ciao
    Oct 19 '20 at 3:57
5
$\begingroup$

Here is one way to get the paths:

ClearAll[paths]
paths[n_, k_]  := With[{m = (k - n)/2},
  ReplaceAll[
    Flatten @ paths[{}, k - m , m], 
    list -> Sequence
  ] /; m >= 0 &&  IntegerQ[m]
]
paths[accum_, 0, n_] := list[Join[accum, ConstantArray[-1, n]]]
paths[accum_, n_, 0] := list[Join[accum, ConstantArray[1, n]]]
paths[accum_ , forwardLeft_, backwardLeft_] := {
  paths[Append[accum, 1], forwardLeft - 1, backwardLeft],
  paths[Append[accum, -1], forwardLeft, backwardLeft - 1]
}

For example

paths[3, 5]

(* 
   {
     {1, 1, 1, 1, -1}, {1, 1, 1, -1, 1}, {1, 1, -1, 1, 1}, 
     {1, -1, 1, 1, 1}, {-1, 1, 1, 1, 1}
   }
*)

There probably are more efficient ways to do that, given that this boils down to combinations C(k, m), where m = (k - n) / 2, so this is basically a problem of picking m -1s and k + m 1s in all possible distinct ways.

$\endgroup$
2
  • $\begingroup$ Yeah I probably should have tossed it in the question that you can get them by doing something like Map[Accumulate, Select[Tuples[{-1, 1}, 5], Total[#] == 3 &]]. I figure it's still a fun little problem and some flavor of direct approach would definitely be of interest to me. $\endgroup$
    – b3m2a1
    Oct 18 '20 at 19:33
  • $\begingroup$ @b3m2a1 May be. I have interpreted it as asking for non-accumulated paths, but that doesn't really matter. I think my approach is pretty direct, in that it doesn't generate extra combinations which must be then deleted. $\endgroup$ Oct 18 '20 at 19:36
4
$\begingroup$

Assuming $n$ is the target number and $k$ is the number of steps, the number of upward steps is: $u=\frac{k+n}{2}$. Thus, we need to distribute $u$ positive values and $d=k-u$ negative values into a list.

Let's work with them using characteristic vectors, where a 1-bit means an upward movement and a 0-bit means a downward movement.

The first such vector is trivially $2^u-1$. Then use Gosper's hack to calculate the rest of them, given that we know how many there are to begin with.

Example code:

gosper[x_] := With[{u = BitAnd[x, -x], v = x + BitAnd[x, -x]},
   v + BitShiftRight[Floor[BitXor[v, x]/u], 2]];
cvlist[l_, v_] := PadLeft[IntegerDigits[v, 2], l] /. {0 -> -1};
   (* convert a characteristic vector to a list representation *)

n = 3;
k = 5;
up = (n + k)/2;
Map[cvlist[k, #] &, NestList[gosper, 2^up - 1, Binomial[k, up] - 1]]

To test this for efficiency, for n = 7; k = 25;, this solution takes 16.7 seconds on my machine to go through the 2,042,975 combinations by AbsoluteTiming.

This can be tremendously sped up with Compile:

gosperc = 
  Compile[{{x, _Integer}}, 
   x + BitAnd[-x, x] + 
    BitShiftRight[Floor[BitXor[x, x + BitAnd[-x, x]]/BitAnd[-x, x]], 
     2], CompilationTarget -> "C"];

This can perform the prior test, n = 7; k = 25; in 10.5 seconds in NestList on my machine. The limitation of compiling this way is that $k$ must be less than a machine sized integer (likely 64, maybe 32 depending on your system).

$\endgroup$
2
  • $\begingroup$ If you can work with the indices instead of the list form, this answer is much faster. IntegerDigits is surprisingly slow. $\endgroup$
    – eyorble
    Oct 18 '20 at 21:20
  • $\begingroup$ Very nice! Clever approach $\endgroup$
    – b3m2a1
    Oct 18 '20 at 21:53
0
$\begingroup$

Here's my dumb approach, based off of the fact that (assuming $k>=0$) the number of downward steps is (n-k)/2

paths[n_, m_] :=
 If[! EvenQ[n - m],
  {},
  Permutations[Join[
    Sign[m]*ConstantArray[-1, (n - Abs[m])/2],
    Sign[m]*ConstantArray[1, n - (n - Abs[m])/2]
    ]]
  ]
$\endgroup$

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.