Derangements.

We defined in class a derangement of n elements to be a permutation which leaves no element in place. We can detect such a permutation by writing a permutation of {1,2,..., n} as a list of numbers in a different order and using PermutationSupport to return the list of numbers moved by the permutation.

DerangementQ[l_List] := Length@PermutationSupport[l] == Length[l]

Just to check:

DerangementQ[{3,1,2}]

DerangementQ[{1,3,2}]

Now Mathematica will generate random permutations with

RandomPermutation[7]

but they are in a weird notation. We can define:

RandomPermutationList[n_] := PermutationList[RandomPermutation[n],n]

to get something more like we expect:

RandomPermutationList[4]

Finally, we can collect some data:

DerangementFraction[n_,k_] := Count[
Table[DerangementQ@RandomPermutationList[n],k],
True]/k

and test it:

DerangementFraction[10,100]

Now we make a plot of the (experiment) fraction of permutations which are derangements for n from 1 to 30:

ListPlot[Table[DerangementFraction[n,10000],{n,1,30}]]

Surprisingly, this plot seems to have a horizontal asymptote! In fact,

Show[{ListPlot[Table[DerangementFraction[n,10000],{n,1,30}]],Plot[(1/E),{x,1,30}]},AxesOrigin->{0,0},PlotRange->All]