Packing
Mr. Wizard's solution is fast because it utilizes functions optimized for packed arrays. Above recursive solutions can, to some extend, also use packed arrays.
To take advantage of packing we must make sure that calls ending recursion return packed arrays, and replace unpacking Prepend[#] /@ ... with PadLeft. Adding some cosmetic changes and localization of memoisation we get:
ClearAll[pad, derangementsInternal, derangementsPacked]
pad[_, _]@{} = {};
pad[i_, x_]@l_ := PadLeft[l, {Length@l, i}, x];
derangementsInternal[1] =
If[Last@#1 === Last@#2, {}, Developer`ToPackedArray@{#1}]&;
derangementsInternal[i_][list_, orig_] := derangementsInternal[i][list, orig] =
Join @@
(pad[i, #]@derangementsInternal[i - 1][DeleteCases[list, #, 1, 1], orig]&) /@
Complement[list, orig[[-i ;; -i]]]
derangementsPacked[{}, _] = {{}};
derangementsPacked[list_List] := Internal`InheritedBlock[{derangementsInternal},
derangementsInternal[Length@list][list, list]
]
which is faster and more memory efficient than Pick-based solution:
s = Range@9;
(res1 = Pick[#, Unitize[Times @@ (#\[Transpose] - s)], 1] &@Permutations[s]) // MaxMemoryUsed // RepeatedTiming
(res2 = derangementsPacked@s) // MaxMemoryUsed // RepeatedTiming
res1 === res2
{0.051, 78384288}
{0.032, 34599000}
True
Advantage of this approach, over filtering ones, grows with number of duplicates:
s = Join[ConstantArray[1, 7], ConstantArray[2, 5], Range[3, 5]];
(res1 = Pick[#, Unitize[Times @@ (#\[Transpose] - s)], 1] &@Permutations[s]) // MaxMemoryUsed // RepeatedTiming
(res2 = derangementsPacked@s) // MaxMemoryUsed // RepeatedTiming
res1 === res2
{0.63, 778380768}
{0.0019, 824784}
True
For large enough number of duplicates it can beat library link filtering, which for above example is ten times slower: {0.016, 182984}.
