Climbing/Descending the Integer Ladder

Question

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.

Answer 1

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.

Answer 2

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.

Answer 3

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).

Answer 4

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]
    ]]
  ]