Subir / bajar la escalera de enteros

Question

Un divertido rompecabezas combinatorio que apareció en mi trabajo y que creo que sería lindo tener una solución de Mathematica, si alguien quiere intentarlo. Es básicamente un problema de subir / bajar escaleras, por lo que probablemente tenga una buena Graphsolución. Vale la pena señalar que mi escalera puede descender al sótano (es decir, mis valores enteros pueden ir por debajo$0$)

A partir de $0$, encima $k$ pasos de $\pm1$, ¿cuáles son los caminos que aterrizarán en el entero $n$, asumiendo por supuesto que $k \ge n$.

No me importa si esta pregunta se cierra por falta de esfuerzo de mi parte (actualmente estoy trabajando en una solución analítica) y en realidad estaría muy feliz si esto se cerrara como un duplicado / si alguien pudiera señalarme el adecuado nombre para este problema. Pero pensé que Mathematica.SE podría disfrutar de un problema rápido y fácil para romper la monotonía de "resolver mi ecuación integro-diferencial".

Answer 1

Actualizar:

Según mi releer y sus comentarios, lo siguiente generará todas las rutas. Supera dramáticamente las respuestas existentes, y es aproximadamente dos órdenes de magnitud más rápido en el${k,n}={25,7}$ prueba que la versión compilada usando $gosperc$.

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

El recuento directo viene dado por:

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

Comparación de tiempos para un caso un poco más grande:

{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}

Cierto

Publicación original:

Supongo que cuando está en "0", un paso de -1 deja a uno todavía en "0". Estás en el suelo o no ...

Este es entonces un paseo aleatorio acotado sobre los números enteros, fácilmente representado como un proceso de Markov.

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 &;

Uso: pathsm[k, n]

Una comparación de los tiempos de este, Leonid y eyorble en ${k,n}={30,10}$ da 0,0007, 159,9 y 359,9 segundos.

El resultado directo de los recuentos es Binomial[k, Floor[(k - n)/2]].

NB: al releer la pregunta, esto puede no responder, ya que cuenta rutas frente a enumerarlas. No obstante, puede ser útil en su investigación, así que lo guardaré aquí a menos que comente lo contrario.

Answer 2

Aquí hay una forma de obtener los caminos:

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

Por ejemplo

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}
   }
*)

Probablemente haya formas más eficientes de hacer eso, dado que esto se reduce a combinaciones C(k, m), donde m = (k - n) / 2, por lo tanto, esto es básicamente un problema de elegir m -1sy k + m 1s de todas las formas posibles distintas.

Answer 3

Asumiendo $n$ es el número objetivo y $k$ es el número de pasos, el número de pasos ascendentes es: $u=\frac{k+n}{2}$. Por lo tanto, necesitamos distribuir$u$ valores positivos y $d=k-u$ valores negativos en una lista.

Trabajemos con ellos usando vectores característicos, donde un bit 1 significa un movimiento hacia arriba y un bit 0 significa un movimiento hacia abajo.

El primer vector de este tipo es trivialmente $2^u-1$. Luego use el truco de Gosper para calcular el resto de ellos, dado que sabemos cuántos hay para empezar.

Código de ejemplo:

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

Para probar esto para la eficiencia, n = 7; k = 25;esta solución toma 16.7 segundos en mi máquina para pasar por las 2,042,975 combinaciones AbsoluteTiming.

Esto se puede acelerar tremendamente con Compile:

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

Esto puede realizar la prueba anterior, n = 7; k = 25;en 10,5 segundos en NestListmi máquina. La limitación de compilar de esta manera es que$k$ debe ser menor que un número entero del tamaño de una máquina (probablemente 64, tal vez 32 dependiendo de su sistema).

Answer 4

Este es mi enfoque tonto, basado en el hecho de que (asumiendo $k>=0$) el número de pasos hacia abajo es (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]
    ]]
  ]