Cargar el paquete

Needs["qm`Dirac`"]

Caminante

Definitions
 (Timing 0 at 20170329. Subió a 0.016 después de cambios de Block a Module)

qm[
Timing[
(Subscript[(OverHat[h]), 1])=(((qmKet[(Subscript[0, 1])])(qmBra[(Subscript[0, 1])])+(qmKet[(Subscript[1, 1])])(qmBra[(Subscript[0, 1])])+(qmKet[(Subscript[0, 1])])(qmBra[(Subscript[1, 1])])-(qmKet[(Subscript[1, 1])])(qmBra[(Subscript[1, 1])]))/(Sqrt[2]));
(Subscript[(OverHat[s]), 1,2])=(qmKet[(Subscript[0, 1])])(qmBra[(Subscript[0, 1])])(∑_(j=-∞)^∞)(qmKet[(Subscript[(j-1), 2])])(qmBra[(Subscript[j, 2])]) + (qmKet[(Subscript[1, 1])])(qmBra[(Subscript[1, 1])])(∑_(j=-∞)^∞)(qmKet[(Subscript[(j+1), 2])])(qmBra[(Subscript[j, 2])]);
(qmBrkt[(Subscript[m_, 1]), (Subscript[n_, 1])]):=KroneckerDelta[m,n];
(qmBrkt[(Subscript[m_, 2]), (Subscript[n_, 2])]):=KroneckerDelta[m,n];
]
]

Evolución 
(Timing 15.3 at 20170329. Subió a 18.56 al cambiar algunos Block en Modules en 20170331.
Subió a 25.13 al hacer que la suma ordene sus argumentos con el mismo orden que usa qmArrangeProducts en 201704171355.
Bajó a 15.8 al hacer que la regla de ordenar argumentos de la suma se “apague” durante las transformaciones algebráicas como qmExpand, y se restaure al salir del comando
)

qm[
Timing[
(Subscript[(qmKet[ψ]), 0])=(qmKet[(Subscript[0, 1]),(Subscript[0, 2])]);
n=20;
Do[
(Subscript[(qmKet[ψ]), t])=qmExpandProducts[ (Subscript[(OverHat[s]), 1,2]) (Subscript[(OverHat[h]), 1]) (Subscript[(qmKet[ψ]), t-1]) ],
{t,1,n}];
(Subscript[(Ket[ψ]), n])
]
]

Cálculo de probabilidades (Timing 10.7 at 20170329. Subió a 12.95 al cambiar algunos Block en Modules. Subió a 18.7 al hacer que la suma ordene sus argumentos con el mismo orden que usa qmArrangeProducts en 201704171355.
Bajó a 12. al hacer que la regla de ordenar argumentos se “apague” durante las transformaciones algebráicas como qmExpand, y se restaure al salir del comando
)

qm[
Timing[
(Subscript[(OverHat[p]), 1,2])=(qmKet[(Subscript[0, 1]),(Subscript[k, 2])])(qmBra[(Subscript[0, 1]),(Subscript[k, 2])])+(qmKet[(Subscript[1, 1]),(Subscript[k, 2])])(qmBra[(Subscript[1, 1]),(Subscript[k, 2])]);
probabilities=
Table[{k,qmExpandProducts[(Subscript[(qmBra[ψ]), n])(Subscript[(OverHat[p]), 1,2])(Subscript[(qmKet[ψ]), n])]},
{k,-n,n}]
]
]

ListPlot[probabilities,Filling->Axis,PlotRange->All,FillingStyle->Thick]

qm[
(Subscript[(Ket[ψ]), 20])
] // TraditionalForm