Help with a very ugly piece of code [duplicate]

Question

In orden to list all derangements of five elements, I wrote the following (very ugly) code:

elementos = {Red, Blue, Green, Orange, Black};
permutaciones = Permutations[elementos];
desarreglos = Select[permutaciones, #[[1]]!=elementos[[1]]&&#[[2]]!=elementos[[2]]&&#[[3]]!=elementos[[3]]&&#[[4]]!=elementos[[4]]&&#[[5]]!=elementos[[5]]&]; 
Length[desarreglos];
desarreglos//Grid

I am unable to figure out how to avoid writing all the #[[i]]!=elementos[[i]] stuff.

Any help would be highly appreciated.

TIA.

Answer 1

You can use MapThread like this:

elementos = {Red, Blue, Green, Orange, Black};
permutaciones = Permutations[elementos];
desarreglos = Select[permutaciones,And @@ MapThread[Not@*Equal, {elementos, #}] &];
Length[desarreglos]
desarreglos // Grid

Answer 2

a slightly longer dfs method

(* Define the DFS-based derangement finder *)
FindDerangementsDFS[elements_List] := Module[
  {n = Length[elements], used, currentPerm, derangements, dfs},
  
  used = Table[False, {n}];
  currentPerm = {};
  derangements = {};
  
  dfs[pos_] := Module[{},
    (* If we've built a complete permutation *)
    If[pos == n + 1,
      AppendTo[derangements, currentPerm];
      Return[]
    ];
    
    (* Try placing each element at the current position *)
    Do[
      (* Skip if element is already used or would be in original position *)
      If[!used[[i]] && i != pos,
        used[[i]] = True;
        AppendTo[currentPerm, elements[[i]]];
        dfs[pos + 1];
        currentPerm = Most[currentPerm];
        used[[i]] = False;
      ],
      {i, 1, n}
    ];
  ];
  
  dfs[1];
  derangements
];

(* Example usage *)
elementos = {Red, Blue, Green, Orange, Black};
desarreglos = FindDerangementsDFS[elementos];

(* Print results *)
Print["Number of derangements: ", Length[desarreglos]];
Print["\nAll derangements:"];
desarreglos

Answer 3

Community Wiki

Wolfram Mathworld gives an interesting function for Derangement, which uses PermutationSupport, a modification of which is the following:

(With[{x = Length@elementos}, {y = Permutations[Range[x]]}, 
 Pick[y, Length@*PermutationSupport /@ y, x]] // Map[elementos[[#]] &])

---

Original code

elementos[[#]]& /@ Pick[#, Length@*PermutationSupport /@ #, Length@elementos]&
 @Permutations[Range@Length@elementos]

---

In addition

There is also PermutationLength, which should work just as well?

(With[{x = Length@elementos}, {y = Permutations[Range[x]]}, 
 Pick[y, PermutationLength /@ y, x]] // Map[elementos[[#]] &])

---