(************** Content-type: application/mathematica **************
                     CreatedBy='Mathematica 5.0'

                    Mathematica-Compatible Notebook

This notebook can be used with any Mathematica-compatible
application, such as Mathematica, MathReader or Publicon. The data
for the notebook starts with the line containing stars above.

To get the notebook into a Mathematica-compatible application, do
one of the following:

* Save the data starting with the line of stars above into a file
  with a name ending in .nb, then open the file inside the
  application;

* Copy the data starting with the line of stars above to the
  clipboard, then use the Paste menu command inside the application.

Data for notebooks contains only printable 7-bit ASCII and can be
sent directly in email or through ftp in text mode.  Newlines can be
CR, LF or CRLF (Unix, Macintosh or MS-DOS style).

NOTE: If you modify the data for this notebook not in a Mathematica-
compatible application, you must delete the line below containing
the word CacheID, otherwise Mathematica-compatible applications may
try to use invalid cache data.

For more information on notebooks and Mathematica-compatible 
applications, contact Wolfram Research:
  web: http://www.wolfram.com
  email: info@wolfram.com
  phone: +1-217-398-0700 (U.S.)

Notebook reader applications are available free of charge from 
Wolfram Research.
*******************************************************************)

(*CacheID: 232*)


(*NotebookFileLineBreakTest
NotebookFileLineBreakTest*)
(*NotebookOptionsPosition[     55363,       1957]*)
(*NotebookOutlinePosition[     60768,       2152]*)
(*  CellTagsIndexPosition[     59803,       2110]*)
(*WindowFrame->Normal*)



Notebook[{
Cell["\[Copyright] 2004 K. Sutner ", "SmallText"],

Cell[CellGroupData[{

Cell["Permutations", "Title",
  Evaluatable->False,
  AspectRatioFixed->True,
  FontFamily->"Charter",
  CellTags->"c:1"],

Cell[CellGroupData[{

Cell["Code", "Subsection",
  Evaluatable->False,
  AspectRatioFixed->True,
  FontFamily->"Charter",
  CellTags->"c:2"],

Cell["\<\
KPermutations[L_List,k_Integer] := 
\tUnion@FlattenOne[ Permutations /@ PowerSet[L,k] ];
\
\>", "Input"],

Cell["\<\
PlotList[ A_List, num_Integer:8, opts___?OptionQ ] := 
With[ {R = Pairs[ Range[Length[A]], A ],
\t   n = Length[A]}, 
\t\tPlotTDGraph[ ToTDGraph[ Table[ R, {num} ], n ], n, opts ] ];

Clear[PlotPermutation];
PlotPermutation[L_List] := 
(
\tListPlot[ Pairs[ Range[0,Length[L]-1], L-1 ],
\tAspectRatio\[Rule]1, 
\tPlotStyle\[Rule]{PointSize[.035], Blue},
\tFrame\[Rule]True,
\tFrameTicks->None,
\tAxes->None,
\tBackground->Yellow]
);
plotsequence[L_List] := Map[PlotPermutation,L];\
\>", "Input"],

Cell["\<\
bubblesort[LL_List] := 
Block[{i,j,n=Length[LL],sort,go},
\tL=LL;
\tsort = {L};
\tgo=1;
\ti=0;
\tWhile[ go==1&&i<n-1,
\t\t\ti++;go=0;
\t\t\tDo[
\t\t\t\tIf[L\[LeftDoubleBracket]j\[RightDoubleBracket]>L\[LeftDoubleBracket]j+\
1\[RightDoubleBracket],
\t\t\t\t  {L\[LeftDoubleBracket]j\[RightDoubleBracket],L\[LeftDoubleBracket]j+\
1\[RightDoubleBracket]}={L\[LeftDoubleBracket]j+1\[RightDoubleBracket],L\
\[LeftDoubleBracket]j\[RightDoubleBracket]};go=1
\t\t\t\t ],
\t\t\t{j,1,n-i}];
\t\t\tAppendTo[sort,L];
\t];
\tsort
];\
\>", "Input"],

Cell["\<\
selectionsort[LL_List] := 
Block[{i,j,n=Length[LL],sort,go},
\tL=LL;
\tsort = {L};
\tFor[ i=0, i< n, i++, 
\t\t\tL1 = Take[L,i];
\t\t\tL2 = Drop[L,i];
\t\t\tx = Min[L2];
\t\t\tp = PositionOne[L2,x];
\t\t\tIf[ p!=1, 
\t\t\t\t{L2[[1]],L2[[p]]} = {x,L2[[1]]};
\t\t\t\tL = Join[ L1, L2 ];
\t\t\t\tAppendTo[sort,L]
\t\t\t];
\t];
\tsort
];\
\>", "Input"],

Cell["\<\
insertionsort[LL_List] := 
Block[{i,j,n=Length[LL],sort,go},
\tL=LL;
\tsort = {L};
\tFor[ i=0, i< n, i++, 
\t\t\tL1 = Take[L,i];
\t\t\tL2 = Drop[L,i];
\t\t\tL = Join[ Sort[Append[L1,L2[[1]]]], Rest[L2] ];
\t\t\tAppendTo[sort,L]
\t];
\tsort
];\
\>", "Input"],

Cell["\<\
NumberOfDerangements[0] = 1;
NumberOfDerangements[n_] := 
\tn NumberOfDerangements[n - 1] + (-1)^n;

DerangementQ[p_List] := 
\tAnd@@(#1 =!= p\[LeftDoubleBracket]#\[RightDoubleBracket]&) /@  \
Range[Length[p]];
Derangements[k_Integer] := 
\tSelect[Permutations[Range[k]], DerangementQ ];\
\>", "Input"],

Cell["\<\
LexPermutations[{a_}] := {{a}};
LexPermutations[{a_,b_}] := {{a,b},{b,a}};
LexPermutations[L_List] :=
Module[{i,n=Length[L]},
\tJoin@@Table[ 
\t\t\tMap[ Prepend[#,L\[LeftDoubleBracket]i\[RightDoubleBracket]]&, 
\t\t \t\t LexPermutations[ Complement[L,{L\[LeftDoubleBracket]i\
\[RightDoubleBracket]}] ] ],
\t\t  {i,n}]
];\
\>", "Input"],

Cell["\<\
RankPermutation[{1}] = 0;
RankPermutation[p_] := 
With[ { p1 = First[p], pp = Rest[p] },
\t(p1-1) Length[pp]! + 
\tRankPermutation[ Map[ If[#>p1,#-1,#]&, pp ] ] ];
\t
UnrankPermutation[ rr_Integer, l_Integer ] := 
Block[{k,r=rr,s=Range[l],i},
\tTable[
\t\tr = Mod[ r,(i+1)!];
\t\tk = s\[LeftDoubleBracket] Quotient[r,i!]+1 \[RightDoubleBracket];
\t\ts = Complement[s,{k}]; k,
\t\t{i,l-1,0,-1}]
]\
\>", "Input"],

Cell["\<\
Clear[rk,urk]
rk[n_,m_][{a_,b_}] := (a-1) m + b;
urk[n_,m_][x_] := With[ { b = Mod[x-1,m] }, {Quotient[x-b,m]+1,b+1} ];\
\>", \
"Input"],

Cell["\<\

Clear[ InShuffle ] 
InShuffle[ L_List ] := 
\tWith[ {n = Length[L]/2}, 
\t\tInShuffle[Take[L,n],Drop[L,n]] ]   /; EvenQ[Length[L]];
\t
InShuffle[ L_List, K_List ] :=  
\tFlatten[ Transpose[ {K,L} ], 1 ];
\t
InShuffle[n_Integer] := PositionList[InShuffle[Range[n]],Range[n]];


Clear[ shuffle, shufflPerm ] 
shufflePerm[n_] := shufflePerm[n] = 
\tFlatten[ Transpose[ {Range[n+1,2n],Range[n]} ], 1 ];
shuffle[ L_List ] := L[[ shufflePerm[Length[L]/2] ]];



sort1 = bubblesort;
sort2 = selectionsort;
sort3 = insertionsort;\
\>", "Input"]
}, Closed]],

Cell[CellGroupData[{

Cell["Generating Permutations via Lists", "Section",
  Evaluatable->False,
  FontFamily->"Charter",
  CellTags->"c:3"],

Cell[TextData[{
  "Throughout this notebook, we represent permutations simply as lists.\nThus \
  ",
  Cell[BoxData[
      \(TraditionalForm\`{b, a, c}\)]],
  "  is one of the 6 possible permutations of  ",
  Cell[BoxData[
      \(TraditionalForm\`a, \ b, \ c\)]],
  "."
}], "Text",
  Evaluatable->False],

Cell[BoxData[{
    \(Clear[a, b, c]\), "\n", 
    \(perm = Permutations[{a, b, c}]; \), "\n", 
    \(TableForm[perm]\)}], "Input"],

Cell[TextData[{
  "\nHow does one generate all permutations of some given objects ",
  Cell[BoxData[
      \(TraditionalForm\`a\_\(\(\ \)\(1\)\), \[Ellipsis], 
      a\_\(\(\ \)\(n\)\)\)]],
  "?\nThe easiest answer is to explicitely construct a list of all ",
  Cell[BoxData[
      \(TraditionalForm\`\(n!\)\)]],
  " permutations (see below for other approaches). \n\nAs one might suspect, \
recursion is the right answer here. \nFor ",
  Cell[BoxData[
      \(TraditionalForm\`n\  = \ 0\)]],
  " there is only one permutation: the empty permutation ",
  Cell[BoxData[
      \(TraditionalForm\`{}\)]],
  ". \n\nRight???  If you thought there was none, try again. The empty \
function  ",
  Cell[BoxData[
      \(TraditionalForm\`\[EmptySet]\  : \ \[EmptySet]\ \[LongRightArrow]\ \
\[EmptySet]\)]],
  "  is a bijection, just check all the properties. "
}], "Text",
  Evaluatable->False],

Cell[TextData[{
  "Now suppose we already have generated all permutations of ",
  Cell[BoxData[
      \(TraditionalForm\`a\_\(\(\ \)\(1\)\), \[Ellipsis], a\_\(n - 1\)\)]],
  ".  To get all permutations of  ",
  Cell[BoxData[
      \(TraditionalForm\`a\_\(\(\ \)\(1\)\), \[Ellipsis], a\_n\)]],
  ",  we can simply insert ",
  Cell[BoxData[
      \(TraditionalForm\`\(\(a\)\(\ \)\)\_n\)]],
  " into all possible places in each of these permutations. So, we need an \
insert operation, and we have to apply it to all given permutations, and in \
all possible places. "
}], "Text",
  Evaluatable->False],

Cell["\<\
This is easy using built-in list manipulation procedures. 
First, we define an insert function that inserts everywhere in just one list. \
\
\>", "Text",
  Evaluatable->False],

Cell[BoxData[
    \(\(insert[P_List, a_] := \ 
        Map[\ Insert[P, a, #] &, \ Range[Length[P] + 1]\ ];\)\)], "Input"],

Cell[BoxData[
    \(insert[{a, b, c}, d]\)], "Input"],

Cell["Second, we insert in all lists on a given list of lists.", "Text",
  Evaluatable->False],

Cell[BoxData[
    \(\(insertinall[L_List, x_] := 
        Flatten[\ Map[insert[#, x] &, \ L], 1];\)\)], "Input"],

Cell["Then we combine these two functions to get all permutations:", "Text",
  Evaluatable->False],

Cell[BoxData[{
    \(perms[{}] := {{}}; \), "\n", 
    \(perms[L_List] := 
      insertinall[perms[Drop[L, \(-1\)]], Last[L]]; \)}], "Input"],

Cell[BoxData[
    \(perms[{a, b, c}]\)], "Input"],

Cell[BoxData[
    \(Length[perms[Range[5]]]\)], "Input"],

Cell["\<\
Looks good. Our function works, but is slower than the built-in \
one. \
\>", "Text",
  Evaluatable->False],

Cell[BoxData[{
    \(\(perms[Range[7]];\)\  // \ Timing\), "\n", 
    \(\(Permutations[Range[7]];\)\  // \ Timing\)}], "Input"],

Cell["\<\
Another minor problem is that the permutations come out in ugly \
order, lexicographic or co-lex would be nicer. Needless to say, the system \
function is better behaved. \
\>", "Text",
  Evaluatable->False],

Cell["Permutations[Range[3]]", "Input"]
}, Closed]],

Cell[CellGroupData[{

Cell["Memoryless Permutations", "Section",
  Evaluatable->False,
  AspectRatioFixed->True,
  FontFamily->"Charter",
  CellTags->"c:4"],

Cell[TextData[{
  "Since there are superexponentially many permutations it is impossible to \
generate all of them even when ",
  Cell[BoxData[
      \(TraditionalForm\`n\)]],
  " is moderately large (even, say ",
  Cell[BoxData[
      \(TraditionalForm\`n\  = \ 20\)]],
  ").  Hence the question arises how to produce a few permutations without \
generating them all.\n\nBelow are two standard answers: one based on order, \
and the other on counting (establishing a clever and easily computable \
bijection between the set of permutations on ",
  Cell[BoxData[
      \(TraditionalForm\`\([n]\)\)]],
  ", and  ",
  Cell[BoxData[
      \(TraditionalForm\`\([\(n!\)]\)\)]],
  "). "
}], "Text"],

Cell[CellGroupData[{

Cell["  Using Order", "Subsection",
  Evaluatable->False,
  AspectRatioFixed->True,
  FontFamily->"Charter",
  CellTags->"c:5"],

Cell[TextData[{
  "There are several natural ways to order permutations on ",
  Cell[BoxData[
      \(TraditionalForm\`\([n]\)\)]],
  ".  We will use lexicographic order. For example, for ",
  Cell[BoxData[
      \(TraditionalForm\`n = 3\)]],
  " we organize the permutations thus:\n\n\t",
  Cell[BoxData[
      \(TraditionalForm\`{1, 2, 3}, {1, 3, 2}, {2, 1, 3}, {2, 3, 1}, {3, 1, 
        2}, {3, 2, 1}\)]],
  ".\n\t\nTo generate permutations, it suffices to produce the analogue of \
the successor function: given any permutation on the list, it produces the \
next in line (we will see how to deal with the last permutation).  Thus, we \
start with \n\n\t",
  Cell[BoxData[
      \(TraditionalForm\`a\_1 < a\_\(\(\ \)\(2\)\) < \ \[Ellipsis]\  < \ 
        a\_\(\(\ \)\(n\)\)\)]],
  ".\n\t\nand we stop when the reverse permutation is reached. There is a \
next permutation as long as there is some ",
  Cell[BoxData[
      \(TraditionalForm\`i\  < n\)]],
  " such that ",
  Cell[BoxData[
      \(TraditionalForm\`a\_\(\(\ \)\(i\)\) < a\_\(i + 1\)\)]],
  ".  When no such ",
  Cell[BoxData[
      \(TraditionalForm\`i\)]],
  " exists,  we have reached the permutation in reverse order and can either \
stop, or reset to the beginning. \nSuppose  ",
  Cell[BoxData[
      \(TraditionalForm\`i < n\)]],
  " is maximal such that  ",
  Cell[BoxData[
      \(TraditionalForm\`a\_\(\(\ \)\(i\)\) < a\_\(i + 1\)\)]],
  ":\n\n\t",
  Cell[BoxData[
      \(TraditionalForm\`\[Ellipsis]\ \ a\_\(\(\ \)\(i\)\) < a\_\(i + 1\) > \ 
        a\_\(\(\ \)\(i + 2\)\) > \[Ellipsis]\  > 
        a\_\(\(\(\ \)\(n\)\)\(\ \)\)\)]],
  "\n\nWe cannot simply swap ",
  Cell[BoxData[
      \(TraditionalForm\`a\_\(\(\ \)\(i\)\)\)]],
  " and ",
  Cell[BoxData[
      \(TraditionalForm\`a\_\(\(\ \)\(i + 1\)\)\)]],
  ", since this would only produce a permutation that is larger, but not  in \
general the next  largest.  Instead, determine ",
  Cell[BoxData[
      \(TraditionalForm\`j, \ i < j \[LessEqual] n\)]],
  ", such that ",
  Cell[BoxData[
      \(TraditionalForm\`a\_\(\(\ \)\(j\)\) > \ a\_\(\(\ \)\(i\)\)\)]],
  " but ",
  Cell[BoxData[
      \(TraditionalForm\`a\_\(\(\ \)\(j\)\) - a\_\(\(\ \)\(i\)\)\)]],
  "  is minimal. \n\n\t",
  Cell[BoxData[
      \(TraditionalForm\`\[Ellipsis]\ \ a\_\(\(\ \)\(i\)\) < a\_\(i + 1\) > \ 
        a\_\(\(\ \)\(i + 2\)\) > \[Ellipsis]\  > 
        a\_j > \ \[Ellipsis]\ a\_n\)]],
  "\n\nThen swap ",
  Cell[BoxData[
      \(TraditionalForm\`a\_\(\(\ \)\(i\)\)\)]],
  " and ",
  Cell[BoxData[
      \(TraditionalForm\`a\_\(\(\ \)\(j\)\)\)]],
  ", and reverse the part of the permutation after the ",
  Cell[BoxData[
      \(TraditionalForm\`\(\(i\)\(\ \)\)\)]],
  "th term.\n\nHere is the implementation.  Note that ",
  StyleBox["Mathematica",
    FontSlant->"Italic"],
  " is not really suitable for this kind of low-level fumbling. In this \
version, we return to the first permutation in the list when given the last  \
as input. "
}], "Text"],

Cell["\<\
nextPerm[ LL_List ] := 
Module[ {a,b,L,n,i,j,jj,LS},

\tLS = Sort[LL];
\tIf[ LL==Reverse[LS], Return[LS] ];

\tn = Length[LL];
\ti = -2;
\tWhile[ LL[[i]] > LL[[i+1]], i-- ];
\t
\ta = LL[[i]];
\tj = i+1;
\tWhile[ j <= -1 && a < LL[[j]], j++ ]; 
\t
\tj--;
\tb = LL[[j]];
\tL = ReplacePart[ ReplacePart[LL,a,j],b,i];
\tJoin[ Drop[L,i+1], Reverse[Take[L,i+1]] ]
];\
\>", "Input"],

Cell["\<\
TableForm[ NestList[ nextPerm, Range[4], 24 ], TableSpacing->1 \
]\
\>", "Input"],

Cell["\<\
This approach can also be used to generate a few permutations \
starting at some random initial permutation.\
\>", "Text"],

Cell[BoxData[{
    \(p = RandomPermutation[16]; \), "\n", 
    \(TableForm[NestList[nextPerm, p, 10], 
      TableSpacing \[Rule] 1]\)}], "Input"],

Cell[TextData[{
  "Is is obvious that it takes only ",
  Cell[BoxData[
      \(TraditionalForm\`O(n)\)]],
  " steps to produce the next  permutation. However, a more interesting \
question is how many steps does it take in total to run through all ",
  Cell[BoxData[
      \(TraditionalForm\`\(n!\)\)]],
  " permutations of ",
  Cell[BoxData[
      \(TraditionalForm\`\([n]\)\)]],
  "  using this method. The surprising answer turns out to be ",
  Cell[BoxData[
      \(TraditionalForm\`O(\(n!\))\)]],
  ", if we sum up the lengths of the tail ends that the algorithm is working \
on, and divide by ",
  Cell[BoxData[
      \(TraditionalForm\`\(n!\)\)]],
  ", we obtain ",
  Cell[BoxData[
      \(TraditionalForm\`\[ExponentialE]\  = 2.71828  \[Ellipsis]\)]],
  " in the limit."
}], "Text"]
}, Closed]],

Cell[CellGroupData[{

Cell["  Ranking Permutations", "Subsection",
  Evaluatable->False,
  AspectRatioFixed->True,
  FontFamily->"Charter",
  CellTags->"c:6"],

Cell[CellGroupData[{

Cell["Ranking", "Subsubsection",
  CellTags->"c:7"],

Cell[TextData[{
  "Enumerating elements in a large set is a standard problem in combinatorics \
and can frequently be solved using a method called ",
  StyleBox["ranking",
    FontColor->RGBColor[0, 0, 1]],
  " and ",
  StyleBox["unranking",
    FontColor->RGBColor[0, 0, 1]],
  ".\n\nSuppose we have a large set ",
  Cell[BoxData[
      \(TraditionalForm\`S\)]],
  " with ",
  Cell[BoxData[
      \(TraditionalForm\`N\)]],
  " elements. Then there is a bijection  ",
  Cell[BoxData[
      \(TraditionalForm\`f\  : \ S\ \[LongRightArrow]\ \([N]\)\)]],
  ". Many times, ",
  Cell[BoxData[
      \(TraditionalForm\`f\)]],
  " can be computed very naturally. It is then called a ",
  StyleBox["ranking function",
    FontColor->RGBColor[0, 0, 1]],
  " for ",
  Cell[BoxData[
      \(TraditionalForm\`S\)]],
  " and ",
  Cell[BoxData[
      \(TraditionalForm\`f(s)\)]],
  " is the ",
  StyleBox["rank",
    FontColor->RGBColor[0, 0, 1]],
  " of ",
  Cell[BoxData[
      \(TraditionalForm\`s\)]],
  ". \n\nActually, it is often more convenient to use ranking/unranking \
functions with   ",
  Cell[BoxData[
      \(TraditionalForm\`f\  : \ S\ \[LongRightArrow]\ \([0, N - 1]\)\)]],
  ".  \nClearly, this make essentially no difference, but one has to be \
careful with ",
  StyleBox["Mathematica",
    FontSlant->"Italic"],
  ": lists are always numbered starting at 1, so the first type is easier to \
deal with in ",
  StyleBox["Mathematica",
    FontSlant->"Italic"],
  " (and the second type is easier to deal with in C++). "
}], "Text"],

Cell[TextData[{
  "Here is a simple example:  ranking Cartesian products. \nWe need a simple \
function \n\n\t\t  ",
  Cell[BoxData[
      \(TraditionalForm\`f\  : \ \([n]\)\[Cross]\([m]\)\ \[LongRightArrow]\ \
\([n\[CenterDot]m]\)\)]],
  ".  \n\t\t  \nThat's not very hard.  ",
  Cell[BoxData[
      \(TraditionalForm\`f(\((a, b)\))\)]],
  " is the position of ",
  Cell[BoxData[
      \(TraditionalForm\`\((a, b)\)\)]],
  "  in the natural (lexicographic) ordering of  ",
  Cell[BoxData[
      \(TraditionalForm\`\([n]\)\[Cross]\([m]\)\)]],
  ".  For example,  ",
  Cell[BoxData[
      \(TraditionalForm\`f(\((1, 1)\))\  = \ 1\)]],
  "  and ",
  Cell[BoxData[
      \(TraditionalForm\`f(\((n, m)\))\  = \ n\[CenterDot]m\)]],
  ". A little arithmetic should be enough to define the ranking function."
}], "Text"],

Cell[BoxData[{
    \(S = CartesianProduct[3, 5]\), "\n", 
    \(Map[\ rk[3, 5], \ S\ ]\)}], "Input"],

Cell["How about unranking? This is just slightly harder. ", "Text"],

Cell["Map[urk[3,5], Range[15] ]", "Input"],

Cell[TextData[{
  "Convince yourself that, in this case, using   ",
  Cell[BoxData[
      \(TraditionalForm\`f\  : \ \(\([\)\(n\)\(]\)\)\[Cross]\(\([\)\(m\)\(]\)\
\)\ \[LongRightArrow]\ \(\([\)\(0, n\[CenterDot]m - 1\)\(]\)\)\)]],
  "  would be a little easier!  Also note that any ranking function   ",
  Cell[BoxData[
      \(TraditionalForm\`f\  : \ 
        S\ \[LongRightArrow]\ \(\([\)\(N\)\(]\)\)\)]],
  "   automatically establishes an order on ",
  Cell[BoxData[
      \(TraditionalForm\`S\)]],
  ": we can define ",
  Cell[BoxData[
      \(TraditionalForm\`x\  < y\)]],
  " by ",
  Cell[BoxData[
      \(TraditionalForm\`f(x)\  < \ f(y)\)]],
  ". But, unlike with the successor approach from above, we have to be able \
to directly compute the ",
  Cell[BoxData[
      \(TraditionalForm\`\(\(i\)\(\ \)\)\)]],
  "th element in this order, and not just be able to obtain it given the  ",
  Cell[BoxData[
      \(TraditionalForm\`i - 1\)]],
  " st. "
}], "Text"]
}, Closed]],

Cell[CellGroupData[{

Cell["Ranking Permutations", "Subsubsection",
  CellTags->"c:8"],

Cell[TextData[{
  "From now on we will consider only permutations of ",
  Cell[BoxData[
      \(TraditionalForm\`\([n]\)\  = \ {1, 2, \[Ellipsis], n}\)]],
  ". We are interested in  ",
  Cell[BoxData[
      \(TraditionalForm\`\(\(\(S\)\(\ \)\(=\)\)\(\ \)\)\)]],
  "all permutations on ",
  Cell[BoxData[
      \(TraditionalForm\`\([n]\)\)]],
  ", hence  ",
  Cell[BoxData[
      \(TraditionalForm\`N\  = \ \(n!\)\)]],
  ".  We will use a ranking function of the type    ",
  Cell[BoxData[
      \(TraditionalForm\`f\  : \ S\ \[LongRightArrow]\ \([0, N - 1]\)\)]],
  ".  "
}], "Text"],

Cell[BoxData[
    \(TableForm[\(\((10\ Range[5])\)!\)]\)], "Input"],

Cell[TextData[{
  "We could use ",
  StyleBox["perms",
    FontWeight->"Bold"],
  " to generate a list of permutations and then use the position in this list \
as its rank. \nUnfortunately, the order in which ",
  StyleBox["perms",
    FontWeight->"Bold"],
  " generates permutations is ugly. Here is a better method:"
}], "Text"],

Cell[BoxData[
    \(TableForm[LexPermutations[{a, b, c}]]\)], "Input"],

Cell[TextData[{
  "We will use this lexicographic ordering to get a ranking function:  ",
  Cell[BoxData[
      \(TraditionalForm\`f(p)\)]],
  " is the position of ",
  Cell[BoxData[
      \(TraditionalForm\`p\)]],
  " in this ordering. \nThe functions \n\t",
  Cell[BoxData[
      \(TraditionalForm\`\(\(RankPermutation[\ p\ ]\)\(\ \)\)\)]],
  "  and \n\t",
  Cell[BoxData[
      \(TraditionalForm\`UnrankPermutation[\ k\ ]\)]],
  "   \ncompute the rank and its inverse."
}], "Text"],

Cell[BoxData[
    \(lex = LexPermutations[{1, 2, 3, 4}]\)], "Input"],

Cell[TextData[{
  "Experiment with a few values for ",
  Cell[BoxData[
      \(TraditionalForm\`r\)]],
  "."
}], "Text"],

Cell[BoxData[{
    \(\(r = 8;\)\), "\n", 
    \(p = lex\[LeftDoubleBracket]r + 1\[RightDoubleBracket]\)}], "Input"],

Cell[BoxData[
    \(RankPermutation[p]\)], "Input"],

Cell[BoxData[
    \(UnrankPermutation[r, 4]\)], "Input"],

Cell[TextData[{
  "But  how does it work?  What is the simple function that computes the \
rank? The idea is to use the so-called factorial representation of numbers \
(which does not use powers of a base, multiplied by digits, but factorials, \
multiplied by numbers of suitable size). \n\n\t",
  Cell[BoxData[
      \(TraditionalForm\`rk(
          p)\  = \ \ \((p\_\(\(\ \)\(1\)\) - 
                1)\)\ \(n!\)\  + \ \((p\_\(\(\ \)\(2\)\) - 
                1)\)\ \(\((n - 1)\)!\)\  + \ \((p\_\(\(\ \)\(3\)\) - 
                1)\)\ \(\((n - 
                  2)\)!\)\  + \[Ellipsis] + \ \((p\_\(\(\ \)\(n\)\) - 
              1)\)\)]],
  ".\n\t\nThus, we are essentially treating the permutation as a number in \
factorial representation, and converting it into ordinary form.  It is a good \
exercise to figure out how to compute the opposite direction (i.e., compute \
the factorial representation of a number). "
}], "Text"]
}, Closed]]
}, Closed]]
}, Closed]],

Cell[CellGroupData[{

Cell["Graphical Representation ", "Section",
  Evaluatable->False,
  FontFamily->"Charter",
  CellTags->"c:9"],

Cell[CellGroupData[{

Cell["New Pictures", "Subsubsection",
  CellTags->"c:10"],

Cell[TextData[{
  "There are several ways we can use graphics to represent permutations of ",
  Cell[BoxData[
      \(TraditionalForm\`\([n]\)\)]],
  ". We have defined a little special purpose plotting routine ",
  StyleBox["PlotPermutation",
    FontWeight->"Bold"],
  ". The basic idea is to plot a point in position ",
  Cell[BoxData[
      \(TraditionalForm\`\((i, p(i))\)\)]],
  " for all ",
  Cell[BoxData[
      \(TraditionalForm\`i\  = \ 1,  ... , n\)]],
  ". Try to figure out ahead of time what the pictures of certain \
permutations will look like. "
}], "Text"],

Cell["\<\
Here are some pictures of permutations. The first three are very \
clearly ordered in some way or other. For the last two we use a function that \
generates a permutation at random. See how the picture represents a lack of \
order. \
\>", "Text"],

Cell[BoxData[
    \(\(PlotPermutation[Range[20]];\)\)], "Input"],

Cell[BoxData[
    \(\(PlotPermutation[Reverse[Range[20]]];\)\)], "Input"],

Cell[BoxData[
    \(\(PlotPermutation[RotateRight[Range[20], 10]];\)\)], "Input"],

Cell[BoxData[
    \(\(PlotPermutation[RandomPermutation[100]];\)\)], "Input"],

Cell[TextData[{
  "Clearly, if the picture of the identity permutation (1,2,...,n) is just \
the main diagonal. Note that this permutation is sorted.  A nearly sorted \
permutation (with a few elements out of order) will give a picture where \
points are located around the diagonal. Totally unsorted permutations are \
distributed at random over the whole square.\n\nWe can use a sorting \
algorithm to bring a random permutation into sorted. Here is the result for \
one such algorithm, called ",
  StyleBox["bubblesort",
    FontWeight->"Bold"],
  ". It produces as output a history of the sorting process (not just the \
sorted list as usual). Follow the movement of the various elements. "
}], "Text"],

Cell[BoxData[
    \(\(sort = bubblesort[RandomPermutation[10]];\)\)], "Input"],

Cell[BoxData[
    \(TableForm[sort, TableSpacing \[Rule] 2]\)], "Input"],

Cell["\<\

We can also plot the intermediate results and animate.
Open the following group, then animate the sequence 
(press ctrl-Y).\
\>", "Text"],

Cell[BoxData[{
    \(\(sort = bubblesort[RandomPermutation[40]];\)\), "\n", 
    \(\(plotsequence[sort];\)\)}], "Input"],

Cell[BoxData[{
    \(\(sort = selectionsort[RandomPermutation[40]];\)\), "\n", 
    \(\(plotsequence[sort];\)\)}], "Input"],

Cell[BoxData[{
    \(\(sort = insertionsort[RandomPermutation[40]];\)\), "\n", 
    \(\(plotsequence[sort];\)\)}], "Input"]
}, Closed]],

Cell[CellGroupData[{

Cell["Old Pictures", "Subsubsection",
  CellTags->"c:11"],

Cell["\<\
Of course, we can also  use the dots-and-lines pictures employed \
earlier to visualize general functions. We need to translate the list \
representation of a permutation into a real function (where application is \
defined). \
\>", "Text"],

Cell["p = RandomPermutation[20]", "Input"],

Cell[BoxData[
    \(\(PlotList[p, 1, LabelGrid \[Rule] Automatic];\)\)], "Input"],

Cell["This type of picture may be more convenient for iteration.", "Text"],

Cell[BoxData[
    \(\(PlotList[p, 6, LabelGrid \[Rule] Automatic];\)\)], "Input"],

Cell[BoxData[
    \(\(PlotList[p, 6, DoTrace \[Rule] {1, 2}];\)\)], "Input"]
}, Closed]],

Cell[CellGroupData[{

Cell["Which is Which?", "Subsubsection",
  CellTags->"c:11"],

Cell[BoxData[
    \(\(PlotPermutation[Range[20]];\)\)], "Input"],

Cell[BoxData[
    \(\(PlotPermutation[Reverse[Range[20]]];\)\)], "Input"],

Cell[BoxData[
    \(\(PlotPermutation[RotateRight[Range[20], 10]];\)\)], "Input"],

Cell[BoxData[
    \(\(PlotPermutation[RandomPermutation[100]];\)\)], "Input"],

Cell[BoxData[{
    \(\(sort = sort1[RandomPermutation[40]];\)\), "\n", 
    \(\(plotsequence[sort];\)\)}], "Input"],

Cell[BoxData[{
    \(\(sort = sort2[RandomPermutation[40]];\)\), "\n", 
    \(\(plotsequence[sort];\)\)}], "Input"],

Cell[BoxData[{
    \(\(sort = sort3[RandomPermutation[40]];\)\), "\n", 
    \(\(plotsequence[sort];\)\)}], "Input"]
}, Open  ]]
}, Open  ]],

Cell[CellGroupData[{

Cell["Shuffle", "Section",
  FontFamily->"Charter",
  CellTags->{"Shuffle", "c:12"}],

Cell[CellGroupData[{

Cell[" Riffle Shuffle", "Subsection",
  CellTags->"c:13"],

Cell[TextData[{
  StyleBox["Assume we have an even number of cards. In riffles shuffle (or \
perfect shuffle) the deck of cards is cut in half, and then cards are \
interleaved, in a striclty alternating fashion.  Hence, there are two \
versions, depending on which pile the first card is taken from:\n\n\toriginal\
\t\t",
    Evaluatable->False,
    AspectRatioFixed->True],
  Cell[BoxData[
      \(TraditionalForm\`{1, 2, 3, 4, 5, 6, 7, 8, 9, 10}\)]],
  StyleBox["\n\tin-shuffle\t",
    Evaluatable->False,
    AspectRatioFixed->True],
  Cell[BoxData[
      \(TraditionalForm\`{6, 1, 7, 2, 8, 3, 9, 4, 10, 5}\)]],
  StyleBox["\n\tout-shuffle\t",
    Evaluatable->False,
    AspectRatioFixed->True],
  Cell[BoxData[
      \(TraditionalForm\`{1, 6, 2, 7, 3, 8, 4, 9, 5, 10}\)]],
  StyleBox["\t\n\nIt is clear (?) that an out-shuffle keeps the first and \
last card fixed, but the remaining cards move according to an in-shuffle on a \
deck of size ",
    Evaluatable->False,
    AspectRatioFixed->True],
  Cell[BoxData[
      \(TraditionalForm\`n - 2\)]],
  ".  Thus, we will consider only in-shuffle, and refer to this operation \
simply as shuffle."
}], "Text"]
}, Closed]],

Cell[CellGroupData[{

Cell[TextData[StyleBox[" Implementing Shuffle",
  Evaluatable->False,
  AspectRatioFixed->True]], "Subsection",
  CellTags->"c:14"],

Cell[TextData[StyleBox["There are many ways to tackle the problem of defining \
a riffle shuffle in Mathematica. Here are some of them. ",
  Evaluatable->False,
  AspectRatioFixed->True]], "Text"],

Cell[CellGroupData[{

Cell["Solution 1:  Table", "Subsubsection",
  CellTags->"c:15"],

Cell[BoxData[{
    \(Clear[shuffle]\), "\n", 
    \(\(shuffle[L_List] := \[IndentingNewLine]\t
        With[{n = Length[L]/2}, shuffle[Take[L, n], Drop[L, n]]];\)\), "\n", 
    \(\(shuffle[L_List, K_List] := \[IndentingNewLine]\t
        Flatten[Table[{K\[LeftDoubleBracket]i\[RightDoubleBracket], 
              L\[LeftDoubleBracket]i\[RightDoubleBracket]}, {i, Length[L]}], 
          1];\)\)}], "Input"],

Cell["shuffle[ Range[10] ]", "Input"]
}, Closed]],

Cell[CellGroupData[{

Cell["Solution 2:  Recursion on Lists", "Subsubsection",
  CellTags->"c:16"],

Cell[BoxData[{
    \(Clear[shuffle]\), "\n", 
    \(\(shuffle[L_List] := \[IndentingNewLine]\t
        With[{n = Length[L]/2}, shuffle[Take[L, n], Drop[L, n]]];\)\), "\n", 
    \(\(shuffle[{}, {}] := {};\)\), "\n", 
    \(\(shuffle[L_List, K_List] := \[IndentingNewLine]\t
        Join[{First[K], First[L]}, shuffle[Rest[L], Rest[K]]];\)\)}], "Input"],

Cell["shuffle[ Range[10] ]", "Input"]
}, Closed]],

Cell[CellGroupData[{

Cell["Solution 3:  Recursion (with pattern matching)", "Subsubsection",
  CellTags->"c:17"],

Cell[BoxData[{
    \(Clear[shuffle]\), "\n", 
    \(\(shuffle[L_List] := \[IndentingNewLine]\t
        With[{n = Length[L]/2}, shuffle[Take[L, n], Drop[L, n]]];\)\), "\n", 
    \(\(shuffle[{}, {}] := {};\)\), "\n", 
    \(\(shuffle[{a_, x___}, {b_, y___}] := 
        Join[{b, a}, shuffle[{x}, {y}]];\)\)}], "Input"],

Cell["shuffle[ Range[10] ]", "Input"]
}, Closed]],

Cell[CellGroupData[{

Cell["Solution 4:  Transpose", "Subsubsection",
  CellTags->"c:18"],

Cell[BoxData[{
    \(Clear[shuffle]\), "\n", 
    \(\(shuffle[L_List] := \[IndentingNewLine]\t
        With[{n = Length[L]/2}, shuffle[Take[L, n], Drop[L, n]]];\)\), "\n", 
    \(\(shuffle[L_List, K_List] := 
        Flatten[Transpose[{K, L}], 1];\)\)}], "Input"],

Cell["shuffle[ Range[10] ]", "Input"]
}, Closed]],

Cell[CellGroupData[{

Cell["Solution 5:  Permutations", "Subsubsection",
  CellTags->"c:19"],

Cell[BoxData[{
    \(Clear[shuffle, shufflPerm]\), "\n", 
    \(\(shufflePerm[n_] := \[IndentingNewLine]\t\(shufflePerm[n] = 
          Flatten[Transpose[{Range[n + 1, 2\ n], Range[n]}], 
            1]\);\)\), "\n", 
    \(\(shuffle[L_List] := 
        L\[LeftDoubleBracket]shufflePerm[
            Length[L]/2]\[RightDoubleBracket];\)\)}], "Input"],

Cell["shuffle[ Range[20] ]", "Input"]
}, Closed]],

Cell[CellGroupData[{

Cell["Associated Function", "Subsubsection",
  CellTags->"c:20"],

Cell[BoxData[
    \(\(sh[n_]\)[x_] := 
      If[x \[LessEqual] n/2, 2\ x, 2\ \((x - n/2)\) - 1]\)], "Input"],

Cell[BoxData[
    \(sh[20] /@ Range[20]\)], "Input"],

Cell[BoxData[
    \(\(PlotFunction[sh[14], Range[14], 1\ ];\)\)], "Input"],

Cell[TextData[{
  Cell[BoxData[
      \(TraditionalForm\`n = 14\)]],
  "  produces three 4-cycles, and one 2-cycle. "
}], "Text"],

Cell[BoxData[
    \(CycleDecompositionT[T @@ \((sh[14] /@ Range[14])\)]\)], "Input"],

Cell[BoxData[
    \(\(PlotFunction[sh[14], Range[14], 8, 
        DoTrace \[Rule] First /@ %];\)\)], "Input"]
}, Closed]]
}, Closed]],

Cell[CellGroupData[{

Cell[TextData[StyleBox[" Iterated Shuffle",
  Evaluatable->False,
  AspectRatioFixed->True]], "Subsection",
  CellTags->"c:21"],

Cell[TextData[StyleBox["Iterating shuffle will introduce a certain amount of \
disorder in a deck of cards. However, we are quite far from anything \
resembling a random arrangement: more applications of shuffle always take us \
back to the initial deck.\n\nIn this section, we use the inverse of the \
shuffle permutation from above. This clearly makes no essential difference \
(we are just going backwards instead of forwards), but it turns out to be a \
little easier to understand in this case: it is easier to analyze the orbits. \
",
  Evaluatable->False,
  AspectRatioFixed->True]], "Text"],

Cell[BoxData[{
    \(shuffle[Range[10]]\), "\n", 
    \(InShuffle[10]\)}], "Input"],

Cell[BoxData[
    \(gr = plotsequence[NestList[InShuffle, Range[20], 6]]; \)], "Input"],

Cell[BoxData[
    \(ShowArray[gr, 3]; \)], "Input"],

Cell[BoxData[
    \(gr = plotsequence[NestList[InShuffle, Range[98], 29]]; \)], "Input"],

Cell[BoxData[
    \(ShowArray[gr, 5]; \)], "Input"],

Cell[TextData[{
  StyleBox["The orbits for ",
    Evaluatable->False,
    AspectRatioFixed->True],
  Cell[BoxData[
      \(TraditionalForm\`n = 20\)]],
  ". There are 5 cycles, of lengths 6, 3, 6, 2, 3."
}], "Text"],

Cell[BoxData[
    \(PlotList[InShuffle[20], 6, 
      DoTrace \[Rule] {1, 3, 5, 7, 9}]; \)], "Input"],

Cell[BoxData[
    \(CycleDecompositionT[T @@ InShuffle[20]]\)], "Input"],

Cell[TextData[{
  StyleBox["Hence, the LCM of the cycle lengths is 6, and we are back to the \
original deck after 6 applications. \n\nWhat is the length of these cycles in \
general?  Experiments show that the dependency on ",
    Evaluatable->False,
    AspectRatioFixed->True],
  Cell[BoxData[
      \(TraditionalForm\`n\)]],
  " seems to be rather complicated, there is no simple pattern.  Since the \
function in question is known to be a permutation we can use the option ",
  StyleBox["Permutation->True", "MR"],
  " in ",
  ButtonBox["AnalyzeOrbit",
    ButtonStyle->"AddOnsLink"],
  " to speed up the computation."
}], "Text"],

Cell[BoxData[
    \(AnalyzeOrbit[InShuffle, Range[500], 
      Permutation \[Rule] True]\)], "Input"],

Cell[TextData[StyleBox["We define a little macro.",
  Evaluatable->False,
  AspectRatioFixed->True]], "Text"],

Cell[BoxData[
    \(\(per[n_] := 
        Last@AnalyzeOrbit[InShuffle, Range[n], Permutation \[Rule] True] /; 
          EvenQ[n];\)\)], "Input"],

Cell[BoxData[{
    \(\(pp = per /@ Range[2, 400, 2];\)\  // \ Timing\), "\n", 
    \(\(ListPlot[pp, PlotStyle \[Rule] Blue];\)\)}], "Input"],

Cell["\<\
What's going on? We have to take a closer look at the permutations. \
\
\>", "Text"],

Cell[BoxData[
    \(InShuffle[20]\)], "Input"],

Cell[TextData[{
  "This really looks like multiplication by 2, but modulo ",
  Cell[BoxData[
      \(TraditionalForm\`n\)]],
  ".  We have to careful, though: the numbers are really ",
  Cell[BoxData[
      \(TraditionalForm\`1, \[Ellipsis], n\)]],
  " and the modulus is ",
  Cell[BoxData[
      \(TraditionalForm\`n + 1\)]],
  ". So, we need to calculate the least ",
  Cell[BoxData[
      \(TraditionalForm\`k\)]],
  " such that  ",
  Cell[BoxData[
      \(TraditionalForm\`2\^\(\(\ \)\(k\)\) = \ 1\ \((mod\ n + 1)\)\)]],
  ". "
}], "Text"],

Cell[BoxData[
    \(order[xx_] := 
      Module[{e = 1, z = 2}, If[EvenQ[xx], Return[0]]; 
        While[Mod[z, xx] \[NotEqual] 1, z *= 2; \(e++\)]; e]\)], "Input"],

Cell["A cautious test:", "Text"],

Cell["\<\
MultiplicativeOrder[2,21]
PowerMod[ 2, Range[6], 21 ]\
\>", "Input"],

Cell["\<\
MultiplicativeOrder[2,41]
PowerMod[ 2, Range[20], 41 ]\
\>", "Input"],

Cell["Time for a table and then we plot of a few more values:", "Text"],

Cell[BoxData[
    \(Table[{i, MultiplicativeOrder[2, i + 1], per[i]}, {i, 2, 40, 2}]\  // 
      TableForm\)], "Input"],

Cell[BoxData[{
    \(\(ord = \(MultiplicativeOrder[2, #] &\) /@ 
          Range[3, 400, 2];\)\), "\n", 
    \(\(ListPlot[ord, PlotStyle \[Rule] Blue];\)\)}], "Input"],

Cell[TextData[{
  "One might still ask for a better description of the least ",
  Cell[BoxData[
      \(TraditionalForm\`k\)]],
  " such that  ",
  Cell[BoxData[
      \(TraditionalForm\`2\^\(\(\ \)\(k\)\) = \ 1\ \((mod\ n + 1)\)\)]],
  ", as a function of ",
  Cell[BoxData[
      \(TraditionalForm\`n\)]],
  ", but that would lead us too far astray. "
}], "Text"]
}, Closed]],

Cell[CellGroupData[{

Cell[" Monge Shuffle", "Subsection",
  CellTags->"c:22"],

Cell[TextData[{
  StyleBox["In the Monge shuffle cards from the uncut but flippend deck are \
placed alternately at top an bottom of the new deck. \n\n\tMonge shuffle    ",
    
    Evaluatable->False,
    AspectRatioFixed->True],
  Cell[BoxData[
      \(TraditionalForm\`{1, 2, 3, 4, 5, 6, 7, 8, 9, 10}\)]],
  " ",
  Cell[BoxData[
      \(TraditionalForm\`\[LongRightArrow]\)]],
  StyleBox["\t",
    Evaluatable->False,
    AspectRatioFixed->True],
  Cell[BoxData[
      \(TraditionalForm\`{2, 4, 6, 8, 10, 9, 7, 5, 3, 1}\)]],
  "\n\t\nAgain, there is a second, less interesting version (second card goes \
on top of first).\n",
  StyleBox["\n\t\t\t",
    Evaluatable->False,
    AspectRatioFixed->True],
  Cell[BoxData[
      \(TraditionalForm\`{1, 3, 5, 7, 9, 10, 8, 6, 4, 2}\)]],
  StyleBox["\t",
    Evaluatable->False,
    AspectRatioFixed->True]
}], "Text"],

Cell[CellGroupData[{

Cell[TextData[StyleBox[" Implementing Monge Shuffle",
  Evaluatable->False,
  AspectRatioFixed->True]], "Subsubsection",
  CellTags->"c:23"],

Cell[TextData[StyleBox["Monge shuffle is also very easy to implement. ",
  Evaluatable->False,
  AspectRatioFixed->True]], "Text"],

Cell[BoxData[{
    \(\(MongeShuffle[
          L_List] := \[IndentingNewLine]Module[{A, 
            B}, \[IndentingNewLine]\t{A, B} = 
            Thread[Partition[L, 2]]; \[IndentingNewLine]\t
          Join[B, Reverse[A]]\[IndentingNewLine]];\)\), "\n", 
    \(\(MongeShuffle[n_Integer] := MongeShuffle[Range[n]];\)\)}], "Input"],

Cell["MongeShuffle[10]", "Input"],

Cell["In pictures:", "Text"],

Cell[BoxData[{
    \(t\  = \ T @@ MongeShuffle[12]\), "\[IndentingNewLine]", 
    \(tt\  = InverseT[t]\)}], "Input"],

Cell[BoxData[
    \(\(PlotT[\ \(\((13 - #)\) &\)\  /@ \ Reverse[tt], 1, 
        LabelGrid \[Rule] Reverse[Range[12]]\ ];\)\)], "Input"]
}, Closed]]
}, Closed]],

Cell[CellGroupData[{

Cell[TextData[StyleBox[" Iterated Monge Shuffle",
  Evaluatable->False,
  AspectRatioFixed->True]], "Subsection",
  CellTags->"c:24"],

Cell[TextData[StyleBox["Again, the picture for Monge shuffle is rather \
straightforward.",
  Evaluatable->False,
  AspectRatioFixed->True]], "Text"],

Cell[TextData[StyleBox["A movie of some iterates:",
  Evaluatable->False,
  AspectRatioFixed->True]], "Text"],

Cell[BoxData[
    \(\(gr = 
        plotsequence[NestList[MongeShuffle, Range[20], 10]];\)\)], "Input"],

Cell["And an overlay of all the pictures from the movie. ", "Text"],

Cell[BoxData[
    \(Show[gr]; \)], "Input"],

Cell[TextData[{
  StyleBox["What is the significance of this picture? It should look vaguely \
familiar.\n\nAgain, one would like to know what is the cycle length, \
preferably as a simple function of ",
    Evaluatable->False,
    AspectRatioFixed->True],
  Cell[BoxData[
      \(TraditionalForm\`n\)]],
  "."
}], "Text"],

Cell[BoxData[
    \(\(per[
          n_] := \[IndentingNewLine]With[\ {mon\  = \ 
                MongeShuffle[n]}, \[IndentingNewLine]Last@
              AnalyzeOrbit[#[\([mon]\)] &, Range[n], 
                Permutation \[Rule] True]] /; EvenQ[n];\)\)], "Input"],

Cell[BoxData[{
    \(\(pp = per /@ Range[2, 400, 2];\) // Timing\), "\n", 
    \(\(ListPlot[pp, PlotStyle \[Rule] Blue];\)\)}], "Input"],

Cell[TextData[{
  "Look familiar?  Take another look at the permutation. Again, this is \
really a multiplication by 2, but the modulus is ",
  Cell[BoxData[
      \(TraditionalForm\`2  n + 1\)]],
  " this time."
}], "Text"],

Cell[BoxData[
    \(MongeShuffle[20]\)], "Input"],

Cell[TextData[{
  "They key to determining cycle lengths is a function similar to the order \
function from the previous section, but this time we have to find the least \
",
  Cell[BoxData[
      \(TraditionalForm\`k\)]],
  "  such that  ",
  Cell[BoxData[
      \(TraditionalForm\`2\^\(\(\ \)\(k\)\) = \ \(\[PlusMinus]\ 
            1\)\ \ \((mod\ 2  n + 1)\)\)]],
  ". This is usually called the ",
  StyleBox["suborder",
    FontColor->RGBColor[0, 0, 1]],
  " of 2 modulo ",
  Cell[BoxData[
      \(TraditionalForm\`2  n + 1\)]],
  ". "
}], "Text"],

Cell[BoxData[
    \(suborder[
        xx_] := \[IndentingNewLine]Module[{e = 1, 
          z = 2}, \[IndentingNewLine]\t
        If[EvenQ[xx], Return[0]]; \[IndentingNewLine]\t
        While[\ Mod[z, xx] \[NotEqual] 1 && Mod[z, xx] \[NotEqual] xx - 1, 
          z *= 2; \(e++\)]; \[IndentingNewLine]\t
        e\[IndentingNewLine]]\)], "Input"],

Cell[BoxData[
    \(Table[{i, suborder[2\ i + 1], per[i]}, {i, 2, 40, 2}]\  // 
      TableForm\)], "Input"],

Cell[BoxData[{
    \(ord = suborder /@ Range[3, 400, 2]; \), "\n", 
    \(ListPlot[ord, PlotStyle \[Rule] Blue]; \)}], "Input"]
}, Closed]]
}, Closed]],

Cell[CellGroupData[{

Cell["Derangements", "Section",
  Evaluatable->False,
  FontFamily->"Charter",
  CellTags->"c:25"],

Cell[TextData[{
  "A ",
  StyleBox["derangement",
    FontColor->RGBColor[0, 0, 1]],
  " is a permutation that moves all points:   ",
  Cell[BoxData[
      \(TraditionalForm\`p(i)\  \[NotEqual] \ i\)]],
  "  for all ",
  Cell[BoxData[
      \(TraditionalForm\`i\)]],
  ". \nIn other words, the permutation has no fixed points. \n\nAn example is \
  ",
  Cell[BoxData[
      \(TraditionalForm\`{4, 3, 2, 1}\)]],
  ",  but ",
  Cell[BoxData[
      \(TraditionalForm\`{2, 3, 1, 4}\)]],
  " is not a derangement.\n\nBelow we use two functions \n\t",
  StyleBox["Derangements",
    FontFamily->"Courier",
    FontWeight->"Bold"],
  "\n\t",
  StyleBox["NumberOfDerangements",
    FontFamily->"Courier",
    FontWeight->"Bold"],
  "\nWe will see shortly how to implement these functions. "
}], "Text"],

Cell[CellGroupData[{

Cell["Counting Derangements", "Subsubsection",
  CellTags->"c:26"],

Cell["Here are all derangements on 5 elements.", "Text"],

Cell[BoxData[{
    \(Derangements[5]\), "\n", 
    \(Length[%]\)}], "Input"],

Cell[TextData[{
  "So there are 44 derangements out of ",
  Cell[BoxData[
      \(TraditionalForm\`\(5!\)\  = \ 120\)]],
  " possible permutations. Here is a function that computes this number \
directly (without generating the derangements first). "
}], "Text"],

Cell[BoxData[
    \(NumberOfDerangements[5]\)], "Input"],

Cell[BoxData[{
    \(tab = NumberOfDerangements /@ Range[20]; \), "\n", 
    \(TableForm[tab]\)}], "Input"],

Cell["\<\
Clearly grows at least exponentially. Lets look at the number of \
derangements divided by n!\
\>", "Text"],

Cell[BoxData[{
    \(\(tab1 = Table[NumberOfDerangements[i]/\(i!\), {i, 10}];\)\), "\n", 
    \(TableForm[N[tab1]]\)}], "Input"],

Cell[TextData[{
  "Surprise. The population of derangements seems to be about 36 percent for \
all ",
  Cell[BoxData[
      \(TraditionalForm\`n\)]],
  " larger than 3. \nIncidentally, remember that E or \[ExponentialE] denotes \
the base of the natural logarithm in ",
  StyleBox["Mathematica",
    FontSlant->"Italic"],
  ". Now"
}], "Text"],

Cell["N[1/\[ExponentialE]]", "Input"],

Cell[TextData[{
  "Indeed, we can use this compute the number of derangements on, say, ",
  Cell[BoxData[
      \(TraditionalForm\`n\  = \ 20\)]],
  ", as follows."
}], "Text"],

Cell["\<\
Round[20!/\[ExponentialE]]
NumberOfDerangements[20]\
\>", "Input"],

Cell[TextData[{
  "How can one compute the number of derangements without using ",
  Cell[BoxData[
      \(TraditionalForm\`\[ExponentialE]\)]],
  "?"
}], "Text"]
}, Closed]],

Cell[CellGroupData[{

Cell["Generating Derangements", "Subsubsection",
  CellTags->"c:27"],

Cell[TextData[{
  "Is there a way to produce all derangements, without having to generate all \
permutations first, and then select the ones without fixed points?  Perhaps \
one can recursively generate derangements on ",
  Cell[BoxData[
      \(TraditionalForm\`\([n]\)\)]],
  "  from derangements on ",
  Cell[BoxData[
      \(TraditionalForm\`\([n - 1]\)\)]],
  " ?  We could take any derangements on ",
  Cell[BoxData[
      \(TraditionalForm\`\([n - 1]\)\)]],
  ", and append ",
  Cell[BoxData[
      \(TraditionalForm\`n\)]],
  ". Then ",
  Cell[BoxData[
      \(TraditionalForm\`n\)]],
  " would be a fixed point, so we swap with one of the other elements.\n"
}], "Text"],

Cell[BoxData[{
    \(Clear[swap]\), "\n", 
    \(\(swap[L_List, i_Integer, j_Integer] := 
        Module[{LL = L}, {LL\[LeftDoubleBracket]j\[RightDoubleBracket], 
              LL\[LeftDoubleBracket]
                i\[RightDoubleBracket]} = {L\[LeftDoubleBracket]
                i\[RightDoubleBracket], 
              L\[LeftDoubleBracket]j\[RightDoubleBracket]}; 
          LL];\)\)}], "Input"],

Cell[BoxData[{
    \(Clear[deranged]\), "\n", 
    \(deranged[1] := {}; \), "\n", 
    \(deranged[2] := {{2, 1}}; \), "\n", 
    \(\(deranged[
          n_] := \[IndentingNewLine]Module[{d = 
              deranged[n - 1]}, \[IndentingNewLine]\t
          Flatten[\(Table[swap[Append[#1, n], i, n], {i, n - 1}] &\) /@ d, 
            1]\[IndentingNewLine]];\)\)}], "Input"],

Cell["We compare to our system function:", "Text"],

Cell[BoxData[{
    \(deranged[3]\), "\n", 
    \(Derangements[3]\)}], "Input"],

Cell["OK, except for order. ", "Text"],

Cell[BoxData[{
    \(deranged[4]\), "\n", 
    \(Derangements[4]\)}], "Input"],

Cell[TextData[{
  "Not OK, we are missing quite a few. Check carefully who was swapped with \
",
  Cell[BoxData[
      \(TraditionalForm\`n = 4\)]],
  ":"
}], "Text"],

Cell[BoxData[
    \(Complement[Derangements[4], deranged[4]]\)], "Input"],

Cell[TextData[{
  "Right, the previous permutations were near-derangements with exactly one \
fixed point, and we swapped ",
  Cell[BoxData[
      \(TraditionalForm\`\(\(n\)\(\ \)\)\)]],
  "with that fixed point. Unfortunately, we can't assume recursively that we \
already know these near-derangements. \nOr can we?  If we start with a \
derangement on ",
  Cell[BoxData[
      \(TraditionalForm\`\([n - 1]\)\)]],
  ", we can insert ",
  Cell[BoxData[
      \(TraditionalForm\`p\)]],
  " in position ",
  Cell[BoxData[
      \(TraditionalForm\`p\)]],
  ", and add 1 to all elements ",
  Cell[BoxData[
      \(TraditionalForm\`\(\(\[GreaterEqual]\)\(\ \)\(p\)\)\)]],
  ", right?  Here is a function that performs this increment operation."
}], "Text"],

Cell[BoxData[
    \(addOne[L_List, p_Integer] := \((If[#1 < p, #1, #1 + 1] &)\) /@ 
        L; \)], "Input"],

Cell["Now we can fix our deranged function. ", "Text"],

Cell[BoxData[{
    \(Clear[deranged]\), "\n", 
    \(deranged[1] := {}; \), "\n", 
    \(deranged[2] := {{2, 1}}; \), "\n", 
    \(deranged[
        n_] := \[IndentingNewLine]With[{d1 = deranged[n - 1], 
          d2 = deranged[n - 2]}, \[IndentingNewLine]\t
        Join[\[IndentingNewLine]\t
          FlattenOne[\(Table[swap[Append[#, n], i, n], {i, n - 1}] &\) /@ 
              d1], \[IndentingNewLine]\t
          FlattenOne[\(Table[
                  Append[Insert[addOne[#, p], n, p], p], {p, n - 1}] &\) /@ 
              d2]\[IndentingNewLine]\t]\[IndentingNewLine]]\)}], "Input"],

Cell["deranged[5]", "Input"],

Cell["\<\
% // Length
NumberOfDerangements[5]\
\>", "Input"],

Cell[TextData[{
  "Works.   But, even more importantly, we get a counting formula out of \
this. Let ",
  Cell[BoxData[
      \(TraditionalForm\`d(n)\)]],
  " be the number of derangements. \n\t\t",
  Cell[BoxData[
      \(TraditionalForm\`d(1)\  = \ 0\)]],
  "\n\t\t",
  Cell[BoxData[
      \(TraditionalForm\`d(2) = \ 1\)]],
  "\n\t\t",
  Cell[BoxData[
      \(TraditionalForm\`d(
          n)\  = \ \((n - 1)\) \((d(n - 1)\  + \ d(n - 2))\)\)]],
  ".\nLet's try."
}], "Text"],

Cell[BoxData[{
    \(Clear[nd]\), "\n", 
    \(nd[1] = 0; \), "\n", 
    \(nd[2] = 1; \), "\n", 
    \(nd[n_] := \(nd[
          n] = \((n - 1)\)\ \((nd[n - 1] + nd[n - 2])\)\); \)}], "Input"],

Cell["Map[ nd, Range[10] ]", "Input"],

Cell[TextData[{
  "With a little more work, the two recursive calls can be replaced by a \
single call:\n\n\t\t",
  Cell[BoxData[
      \(TraditionalForm\`d(n)\  = \ 
        n\ \(d(n - 1)\)\  + \ \((\(-1\))\)\^\(\(\ \)\(n\)\)\)]],
  ".\n\nFor this implementation one can do away with memoizing. "
}], "Text"],

Cell[BoxData[{
    \(Clear[nd]\), "\n", 
    \(nd[1] = 0; \), "\n", 
    \(nd[n_] := n\ nd[n - 1] + \((\(-1\))\)\^n; \)}], "Input"],

Cell[BoxData[{
    \(nd /@ Range[10]\), "\n", 
    \(nd /@ Range[10]/\(Range[10]!\)\), "\n", 
    \(N[%]\)}], "Input"]
}, Closed]]
}, Closed]],

Cell[CellGroupData[{

Cell["Composition as Multiplication", "Section",
  FontFamily->"Charter",
  CellTags->"c:28"],

Cell[TextData[{
  "Consider  functions  ",
  Cell[BoxData[
      \(TraditionalForm\`p\  : \ \([n]\)\ \ \[LongRightArrow]\ \([n]\)\)]],
  ".  For this section, the best way to represent such a function is a list \
of values (an array, if you like):\n\t",
  Cell[BoxData[
      \(TraditionalForm\`\((\ p(1), p(2), \[Ellipsis], p(n - 1), 
        p(n)\ )\)\)]],
  ".\nTo avoid confusion with ordinary lists, we will use a special header:  \
",
  ButtonBox["T",
    ButtonStyle->"AddOnsLink"],
  "  for transformation. \n\t",
  Cell[BoxData[
      \(TraditionalForm\`T[\ p(1), p(2), \[Ellipsis], p(n - 1), p(n)\ ]\)]],
  ".\nThus  ",
  StyleBox["T[1,3,2]", "MR"],
  " represents a permutation,  but ",
  StyleBox["T[1,1,3]", "MR"],
  " is just an ordinary function. Note that ",
  StyleBox["T[1,2,4]", "MR"],
  " is not a legitimate transformation. \n\nWe can implement composition of \
these functions by using ",
  ButtonBox["NonCommutativeMultiply",
    ButtonStyle->"RefGuideLink"],
  ", abbreviated ",
  StyleBox["**",
    FontFamily->"Courier",
    FontWeight->"Bold"],
  ".  Ordinary multiplication won't do, since this operation is not \
commutative."
}], "Text"],

Cell["\<\
t = T[1,3,2];
s = T[1,1,3];
s ** t
t ** s\
\>", "Input"],

Cell[TextData[{
  "Similarly we can use exponentiation for iteration.  How many \
transformations can be obtained from composing ",
  Cell[BoxData[
      \(TraditionalForm\`t\)]],
  " with itself? In other words, what is   ",
  Cell[BoxData[
      \(TraditionalForm\`\(\(t\)\(,\)\(\ \)\(t\^\(\(\ \)\(2\)\)\)\(,\)\(\ \
\)\(t\^\(\(\ \)\(3\)\)\)\(,\)\(\ \)\(\[Ellipsis]\)\(,\)\(\ \)\(t\^\(\(\ \)\(r\
\)\)\)\(,\)\(\ \)\(\[Ellipsis]\)\(\ \)\)\)]]
}], "Text"],

Cell["\<\
t
t^2
t^3
t^4\
\>", "Input"],

Cell["Or, more concisely:", "Text"],

Cell["t^Range[5]", "Input"],

Cell[TextData[{
  "Seems like  ",
  Cell[BoxData[
      \(TraditionalForm\`t\^\(\(\ \)\(r + 2\)\) = \ t\^\(\(\ \)\(r\)\)\)]],
  ".   Prove this claim by induction on ",
  Cell[BoxData[
      \(TraditionalForm\`r\)]],
  ".\nAnother example"
}], "Text"],

Cell["\<\
t  = T[2,3,4,5,1];
t^Range[5]\
\>", "Input"],

Cell["\<\
Which transformations can be obtained by computing arbitrary \
products of a given set of functions?
For example, consider\
\>", "Text"],

Cell["\<\
t = T[2,3,4,1];
s = T[2,1,3,4];\
\>", "Input"],

Cell[TextData[{
  "Taking powers of ",
  Cell[BoxData[
      \(TraditionalForm\`s\)]],
  " and ",
  Cell[BoxData[
      \(TraditionalForm\`t\)]],
  " alone only produces 5 different functions"
}], "Text"],

Cell["\<\
t^Range[5]
s^Range[5]\
\>", "Input"],

Cell["Union[%,%%]", "Input"],

Cell[TextData[{
  "But we can get more by composing  ",
  Cell[BoxData[
      \(TraditionalForm\`s\)]],
  "  and  ",
  Cell[BoxData[
      \(TraditionalForm\`t\)]],
  ":"
}], "Text"],

Cell["\<\
s ** t
t ** s \
\>", "Input"],

Cell["\<\
s ** t^2
t^2 ** s\
\>", "Input"],

Cell["\<\
s ** t^3
t^3 ** s\
\>", "Input"],

Cell["\<\
Clearly, this process is slightly tedious to do by hand. We can \
write a function that does all the work for us.
First, a helper function that computes all the products between two lists of \
transformations. \
\>", "Text"],

Cell[BoxData[
    \(prods[L_List, K_List] := \[IndentingNewLine]\t
      Union[Apply[NonCommutativeMultiply, 
          CartesianProduct[L, K], {1}]]\)], "Input"],

Cell["\<\
Time for an elegant fixed point constructioin: we keep producing \
products until nothing changes anymore. \
\>", "Text"],

Cell[BoxData[
    \(generate[gen_List] := 
      FixedPoint[# \[Union] prods[#, gen] &, gen]\)], "Input"],

Cell[BoxData[{
    \(generate[{s, t}]\), "\n", 
    \(Length[%]\)}], "Input"],

Cell["\<\
Looks like we have all permutations: since our generators are both \
permutations we cannot get anything put permutations, and, in fact, we are \
getting them all. 
Another test, using the analogous permutations of length 5 (good question: \
what does analogous mean?).\
\>", "Text"],

Cell[BoxData[
    \(generate[{T[2, 1, 3, 4, 5], T[2, 3, 4, 5, 1]}]\ \  // Length\)], "Input"],

Cell["\<\
Seems to work.  What do we need to get all functions, not just \
permutations? We could exploit the fact that with just 2 generators we can \
already obtain all permutations, and just  add some more functions.  As it \
turns out, just one other function suffices.\
\>", "Text"],

Cell[BoxData[
    \(generate[{T[2, 1, 3, 4], T[2, 3, 4, 1], T[1, 1, 3, 4]}]\ \  // 
      Length\)], "Input"]
}, Closed]],

Cell[CellGroupData[{

Cell["Problems", "Section",
  Evaluatable->False,
  AspectRatioFixed->True,
  FontFamily->"Charter",
  CellTags->"c:29"],

Cell[CellGroupData[{

Cell["Problem 1:", "Subsubsection",
  CellTags->"c:30"],

Cell[TextData[{
  "Prove that the function ",
  StyleBox["perms",
    FontWeight->"Bold"],
  " defined above really generates all permutations. \nYou probably will have \
to use induction for this."
}], "Text"]
}, Closed]],

Cell[CellGroupData[{

Cell["Problem 2:", "Subsubsection",
  CellTags->"c:31"],

Cell[TextData[{
  "Let ",
  Cell[BoxData[
      \(TraditionalForm\`d(n)\)]],
  " be the number of derangements. \n(1)  We know that\n\t\t",
  Cell[BoxData[
      \(TraditionalForm\`d(1)\  = \ 0\)]],
  "  and  ",
  Cell[BoxData[
      \(TraditionalForm\`d(2) = \ 1\)]],
  "\n\t\t",
  Cell[BoxData[
      \(TraditionalForm\`d(
          n)\  = \ \((n - 1)\) \((d(n - 1)\  + \ d(n - 2))\)\)]],
  ".\nProve that \n\t\t",
  Cell[BoxData[
      \(TraditionalForm\`d(n)\  = \ 
        n\ \(d(n - 1)\)\  + \ \((\(-1\))\)\^\(\(\ \)\(n\)\)\)]],
  ".\n(2)  [Hard]  \nUse the inclusion-exclusion principle to develop a \
formula for ",
  Cell[BoxData[
      \(TraditionalForm\`d(n)\)]],
  ". \t\t\t"
}], "Text"]
}, Closed]],

Cell[CellGroupData[{

Cell["Problem 3:", "Subsubsection",
  CellTags->"c:32"],

Cell[TextData[{
  "Find a way to compute the lexicographic rank of a permutation ",
  StyleBox["without",
    FontWeight->"Bold"],
  " generating the whole list first. You don't have to implement your method \
in ",
  StyleBox["Mathematica",
    FontSlant->"Italic"],
  ", just give a description. \nHint: for n = 0,1,2 this is easy. Suppose you \
can do it for n. Extend to n+1. \nLook at a lexicographic list of all \
permutations to see where element n+1 pops up. "
}], "Text"]
}, Closed]],

Cell[CellGroupData[{

Cell["Problem 4:", "Subsubsection",
  CellTags->"c:33"],

Cell["\<\
When we computed all transformations generated by t1 and t2 above \
we used a certain systematic approach. 
What is this approach?
Prove that it really generates all transformations that can be written as a \
composition of t1 and t2. 
Expand the method to k generators  t1,t2,...,tk. \
\>", "Text"]
}, Closed]],

Cell[CellGroupData[{

Cell["Problem 5:", "Subsubsection",
  CellTags->"c:34"],

Cell["\<\
Prove that for all n the collection of all transformations from [n] \
to [n] can be generated from just three transformations. I.e., with the \
proper choice of t1,t2 and t3 we have 
\tGenerate[t1,t2,t3] = all transformations on [n].
What are these generators?\
\>", "Text"]
}, Closed]],

Cell[CellGroupData[{

Cell["Problem 6:", "Subsubsection",
  CellTags->"c:35"],

Cell["\<\
Prove that for all n the collection of all permutations on [n] can \
be generated from just two permutations. 
I.e., with the proper choice of p and q we have 
\tGenerate[p,q] = all permutations on [n].
What are these generators?\
\>", "Text"]
}, Closed]],

Cell[CellGroupData[{

Cell["Problem 7:", "Subsubsection",
  CellTags->"c:36"],

Cell["\<\
Characterize idempotent transformations in terms of their images \
and kernels. 
Prove that your characteriztion is correct.\
\>", "Text"]
}, Closed]]
}, Closed]]
}, Open  ]]
},
FrontEndVersion->"5.0 for X",
ScreenRectangle->{{0, 1280}, {0, 1024}},
ScreenStyleEnvironment->"Working",
WindowToolbars->{},
CellGrouping->Automatic,
WindowSize->{1125, 944},
WindowMargins->{{Automatic, 1}, {Automatic, 0}},
PrintingStartingPageNumber->379,
PrivateNotebookOptions->{"ColorPalette"->{RGBColor, 128}},
ShowCellLabel->False,
ShowCellTags->False,
RenderingOptions->{"ObjectDithering"->True,
"RasterDithering"->False},
CharacterEncoding->Automatic,
Magnification->1.5,
StyleDefinitions -> "Classic.nb"
]

(*******************************************************************
Cached data follows.  If you edit this Notebook file directly, not
using Mathematica, you must remove the line containing CacheID at
the top of  the file.  The cache data will then be recreated when
you save this file from within Mathematica.
*******************************************************************)

(*CellTagsOutline
CellTagsIndex->{
  "c:1"->{
    Cell[1828, 55, 121, 4, 125, "Title",
      Evaluatable->False,
      CellTags->"c:1"]},
  "c:2"->{
    Cell[1974, 63, 118, 4, 45, "Subsection",
      Evaluatable->False,
      CellTags->"c:2"]},
  "c:3"->{
    Cell[5716, 230, 118, 3, 51, "Section",
      Evaluatable->False,
      CellTags->"c:3"]},
  "c:4"->{
    Cell[9249, 349, 134, 4, 51, "Section",
      Evaluatable->False,
      CellTags->"c:4"]},
  "c:5"->{
    Cell[10103, 377, 127, 4, 45, "Subsection",
      Evaluatable->False,
      CellTags->"c:5"]},
  "c:6"->{
    Cell[14800, 525, 136, 4, 31, "Subsection",
      Evaluatable->False,
      CellTags->"c:6"]},
  "c:7"->{
    Cell[14961, 533, 51, 1, 42, "Subsubsection",
      CellTags->"c:7"]},
  "c:8"->{
    Cell[18594, 649, 64, 1, 42, "Subsubsection",
      CellTags->"c:8"]},
  "c:9"->{
    Cell[21631, 748, 110, 3, 51, "Section",
      Evaluatable->False,
      CellTags->"c:9"]},
  "c:10"->{
    Cell[21766, 755, 57, 1, 42, "Subsubsection",
      CellTags->"c:10"]},
  "c:11"->{
    Cell[24394, 836, 57, 1, 28, "Subsubsection",
      CellTags->"c:11"],
    Cell[25110, 862, 60, 1, 28, "Subsubsection",
      CellTags->"c:11"]},
  "Shuffle"->{
    Cell[25880, 893, 84, 2, 92, "Section",
      CellTags->{"Shuffle", "c:12"}]},
  "c:12"->{
    Cell[25880, 893, 84, 2, 92, "Section",
      CellTags->{"Shuffle", "c:12"}]},
  "c:13"->{
    Cell[25989, 899, 57, 1, 42, "Subsection",
      CellTags->"c:13"]},
  "c:14"->{
    Cell[27249, 936, 131, 3, 42, "Subsection",
      CellTags->"c:14"]},
  "c:15"->{
    Cell[27604, 948, 63, 1, 42, "Subsubsection",
      CellTags->"c:15"]},
  "c:16"->{
    Cell[28153, 965, 76, 1, 42, "Subsubsection",
      CellTags->"c:16"]},
  "c:17"->{
    Cell[28660, 981, 91, 1, 42, "Subsubsection",
      CellTags->"c:17"]},
  "c:18"->{
    Cell[29147, 997, 67, 1, 42, "Subsubsection",
      CellTags->"c:18"]},
  "c:19"->{
    Cell[29557, 1012, 70, 1, 42, "Subsubsection",
      CellTags->"c:19"]},
  "c:20"->{
    Cell[30057, 1029, 64, 1, 42, "Subsubsection",
      CellTags->"c:20"]},
  "c:21"->{
    Cell[30744, 1059, 127, 3, 42, "Subsection",
      CellTags->"c:21"]},
  "c:22"->{
    Cell[35217, 1212, 56, 1, 42, "Subsection",
      CellTags->"c:22"]},
  "c:23"->{
    Cell[36165, 1245, 140, 3, 42, "Subsubsection",
      CellTags->"c:23"]},
  "c:24"->{
    Cell[37147, 1278, 133, 3, 42, "Subsection",
      CellTags->"c:24"]},
  "c:25"->{
    Cell[39970, 1374, 98, 3, 51, "Section",
      Evaluatable->False,
      CellTags->"c:25"]},
  "c:26"->{
    Cell[40890, 1409, 66, 1, 42, "Subsubsection",
      CellTags->"c:26"]},
  "c:27"->{
    Cell[42625, 1478, 68, 1, 42, "Subsubsection",
      CellTags->"c:27"]},
  "c:28"->{
    Cell[47592, 1644, 93, 2, 51, "Section",
      CellTags->"c:28"]},
  "c:29"->{
    Cell[52167, 1830, 120, 4, 51, "Section",
      Evaluatable->False,
      CellTags->"c:29"]},
  "c:30"->{
    Cell[52312, 1838, 55, 1, 42, "Subsubsection",
      CellTags->"c:30"]},
  "c:31"->{
    Cell[52617, 1852, 55, 1, 42, "Subsubsection",
      CellTags->"c:31"]},
  "c:32"->{
    Cell[53411, 1883, 55, 1, 42, "Subsubsection",
      CellTags->"c:32"]},
  "c:33"->{
    Cell[53986, 1902, 55, 1, 42, "Subsubsection",
      CellTags->"c:33"]},
  "c:34"->{
    Cell[54390, 1917, 55, 1, 42, "Subsubsection",
      CellTags->"c:34"]},
  "c:35"->{
    Cell[54769, 1931, 55, 1, 42, "Subsubsection",
      CellTags->"c:35"]},
  "c:36"->{
    Cell[55117, 1945, 55, 1, 42, "Subsubsection",
      CellTags->"c:36"]}
  }
*)

(*CellTagsIndex
CellTagsIndex->{
  {"c:1", 56306, 1984},
  {"c:2", 56409, 1988},
  {"c:3", 56516, 1992},
  {"c:4", 56621, 1996},
  {"c:5", 56726, 2000},
  {"c:6", 56835, 2004},
  {"c:7", 56944, 2008},
  {"c:8", 57029, 2011},
  {"c:9", 57114, 2014},
  {"c:10", 57221, 2018},
  {"c:11", 57308, 2021},
  {"Shuffle", 57472, 2026},
  {"c:12", 57566, 2029},
  {"c:13", 57660, 2032},
  {"c:14", 57744, 2035},
  {"c:15", 57829, 2038},
  {"c:16", 57916, 2041},
  {"c:17", 58003, 2044},
  {"c:18", 58090, 2047},
  {"c:19", 58177, 2050},
  {"c:20", 58265, 2053},
  {"c:21", 58353, 2056},
  {"c:22", 58439, 2059},
  {"c:23", 58524, 2062},
  {"c:24", 58613, 2065},
  {"c:25", 58699, 2068},
  {"c:26", 58807, 2072},
  {"c:27", 58895, 2075},
  {"c:28", 58983, 2078},
  {"c:29", 59065, 2081},
  {"c:30", 59174, 2085},
  {"c:31", 59262, 2088},
  {"c:32", 59350, 2091},
  {"c:33", 59438, 2094},
  {"c:34", 59526, 2097},
  {"c:35", 59614, 2100},
  {"c:36", 59702, 2103}
  }
*)

(*NotebookFileOutline
Notebook[{
Cell[1754, 51, 49, 0, 44, "SmallText"],

Cell[CellGroupData[{
Cell[1828, 55, 121, 4, 125, "Title",
  Evaluatable->False,
  CellTags->"c:1"],

Cell[CellGroupData[{
Cell[1974, 63, 118, 4, 45, "Subsection",
  Evaluatable->False,
  CellTags->"c:2"],
Cell[2095, 69, 114, 4, 90, "Input"],
Cell[2212, 75, 504, 18, 370, "Input"],
Cell[2719, 95, 544, 21, 370, "Input"],
Cell[3266, 118, 358, 18, 370, "Input"],
Cell[3627, 138, 267, 13, 270, "Input"],
Cell[3897, 153, 312, 10, 190, "Input"],
Cell[4212, 165, 345, 11, 210, "Input"],
Cell[4560, 178, 420, 15, 310, "Input"],
Cell[4983, 195, 146, 5, 90, "Input"],
Cell[5132, 202, 547, 23, 470, "Input"]
}, Closed]],

Cell[CellGroupData[{
Cell[5716, 230, 118, 3, 51, "Section",
  Evaluatable->False,
  CellTags->"c:3"],
Cell[5837, 235, 304, 10, 68, "Text",
  Evaluatable->False],
Cell[6144, 247, 130, 3, 97, "Input"],
Cell[6277, 252, 885, 22, 218, "Text",
  Evaluatable->False],
Cell[7165, 276, 599, 14, 93, "Text",
  Evaluatable->False],
Cell[7767, 292, 185, 5, 68, "Text",
  Evaluatable->False],
Cell[7955, 299, 121, 2, 51, "Input"],
Cell[8079, 303, 53, 1, 51, "Input"],
Cell[8135, 306, 94, 1, 43, "Text",
  Evaluatable->False],
Cell[8232, 309, 112, 2, 51, "Input"],
Cell[8347, 313, 98, 1, 43, "Text",
  Evaluatable->False],
Cell[8448, 316, 141, 3, 74, "Input"],
Cell[8592, 321, 49, 1, 51, "Input"],
Cell[8644, 324, 56, 1, 51, "Input"],
Cell[8703, 327, 117, 4, 43, "Text",
  Evaluatable->False],
Cell[8823, 333, 127, 2, 74, "Input"],
Cell[8953, 337, 217, 5, 68, "Text",
  Evaluatable->False],
Cell[9173, 344, 39, 0, 50, "Input"]
}, Closed]],

Cell[CellGroupData[{
Cell[9249, 349, 134, 4, 51, "Section",
  Evaluatable->False,
  CellTags->"c:4"],
Cell[9386, 355, 692, 18, 143, "Text"],

Cell[CellGroupData[{
Cell[10103, 377, 127, 4, 45, "Subsection",
  Evaluatable->False,
  CellTags->"c:5"],
Cell[10233, 383, 2971, 76, 668, "Text"],
Cell[13207, 461, 385, 20, 410, "Input"],
Cell[13595, 483, 91, 3, 50, "Input"],
Cell[13689, 488, 132, 3, 43, "Text"],
Cell[13824, 493, 146, 3, 74, "Input"],
Cell[13973, 498, 790, 22, 118, "Text"]
}, Closed]],

Cell[CellGroupData[{
Cell[14800, 525, 136, 4, 31, "Subsection",
  Evaluatable->False,
  CellTags->"c:6"],

Cell[CellGroupData[{
Cell[14961, 533, 51, 1, 42, "Subsubsection",
  CellTags->"c:7"],
Cell[15015, 536, 1536, 48, 268, "Text"],
Cell[16554, 586, 813, 22, 218, "Text"],
Cell[17370, 610, 100, 2, 74, "Input"],
Cell[17473, 614, 67, 0, 43, "Text"],
Cell[17543, 616, 42, 0, 50, "Input"],
Cell[17588, 618, 969, 26, 118, "Text"]
}, Closed]],

Cell[CellGroupData[{
Cell[18594, 649, 64, 1, 42, "Subsubsection",
  CellTags->"c:8"],
Cell[18661, 652, 583, 17, 68, "Text"],
Cell[19247, 671, 67, 1, 51, "Input"],
Cell[19317, 674, 330, 9, 68, "Text"],
Cell[19650, 685, 70, 1, 51, "Input"],
Cell[19723, 688, 484, 14, 143, "Text"],
Cell[20210, 704, 68, 1, 51, "Input"],
Cell[20281, 707, 120, 5, 43, "Text"],
Cell[20404, 714, 115, 2, 74, "Input"],
Cell[20522, 718, 51, 1, 51, "Input"],
Cell[20576, 721, 56, 1, 51, "Input"],
Cell[20635, 724, 935, 17, 243, "Text"]
}, Closed]]
}, Closed]]
}, Closed]],

Cell[CellGroupData[{
Cell[21631, 748, 110, 3, 51, "Section",
  Evaluatable->False,
  CellTags->"c:9"],

Cell[CellGroupData[{
Cell[21766, 755, 57, 1, 42, "Subsubsection",
  CellTags->"c:10"],
Cell[21826, 758, 574, 15, 93, "Text"],
Cell[22403, 775, 256, 5, 68, "Text"],
Cell[22662, 782, 64, 1, 51, "Input"],
Cell[22729, 785, 73, 1, 51, "Input"],
Cell[22805, 788, 81, 1, 51, "Input"],
Cell[22889, 791, 77, 1, 51, "Input"],
Cell[22969, 794, 706, 12, 193, "Text"],
Cell[23678, 808, 78, 1, 51, "Input"],
Cell[23759, 811, 72, 1, 51, "Input"],
Cell[23834, 814, 148, 5, 118, "Text"],
Cell[23985, 821, 120, 2, 74, "Input"],
Cell[24108, 825, 123, 2, 74, "Input"],
Cell[24234, 829, 123, 2, 74, "Input"]
}, Closed]],

Cell[CellGroupData[{
Cell[24394, 836, 57, 1, 28, "Subsubsection",
  CellTags->"c:11"],
Cell[24454, 839, 250, 5, 68, "Text"],
Cell[24707, 846, 42, 0, 50, "Input"],
Cell[24752, 848, 81, 1, 51, "Input"],
Cell[24836, 851, 74, 0, 43, "Text"],
Cell[24913, 853, 81, 1, 51, "Input"],
Cell[24997, 856, 76, 1, 51, "Input"]
}, Closed]],

Cell[CellGroupData[{
Cell[25110, 862, 60, 1, 28, "Subsubsection",
  CellTags->"c:11"],
Cell[25173, 865, 64, 1, 51, "Input"],
Cell[25240, 868, 73, 1, 51, "Input"],
Cell[25316, 871, 81, 1, 51, "Input"],
Cell[25400, 874, 77, 1, 51, "Input"],
Cell[25480, 877, 115, 2, 74, "Input"],
Cell[25598, 881, 115, 2, 74, "Input"],
Cell[25716, 885, 115, 2, 74, "Input"]
}, Open  ]]
}, Open  ]],

Cell[CellGroupData[{
Cell[25880, 893, 84, 2, 92, "Section",
  CellTags->{"Shuffle", "c:12"}],

Cell[CellGroupData[{
Cell[25989, 899, 57, 1, 42, "Subsection",
  CellTags->"c:13"],
Cell[26049, 902, 1163, 29, 293, "Text"]
}, Closed]],

Cell[CellGroupData[{
Cell[27249, 936, 131, 3, 42, "Subsection",
  CellTags->"c:14"],
Cell[27383, 941, 196, 3, 43, "Text"],

Cell[CellGroupData[{
Cell[27604, 948, 63, 1, 42, "Subsubsection",
  CellTags->"c:15"],
Cell[27670, 951, 406, 7, 143, "Input"],
Cell[28079, 960, 37, 0, 50, "Input"]
}, Closed]],

Cell[CellGroupData[{
Cell[28153, 965, 76, 1, 42, "Subsubsection",
  CellTags->"c:16"],
Cell[28232, 968, 351, 6, 166, "Input"],
Cell[28586, 976, 37, 0, 50, "Input"]
}, Closed]],

Cell[CellGroupData[{
Cell[28660, 981, 91, 1, 42, "Subsubsection",
  CellTags->"c:17"],
Cell[28754, 984, 316, 6, 143, "Input"],
Cell[29073, 992, 37, 0, 50, "Input"]
}, Closed]],

Cell[CellGroupData[{
Cell[29147, 997, 67, 1, 42, "Subsubsection",
  CellTags->"c:18"],
Cell[29217, 1000, 263, 5, 120, "Input"],
Cell[29483, 1007, 37, 0, 50, "Input"]
}, Closed]],

Cell[CellGroupData[{
Cell[29557, 1012, 70, 1, 42, "Subsubsection",
  CellTags->"c:19"],
Cell[29630, 1015, 350, 7, 120, "Input"],
Cell[29983, 1024, 37, 0, 50, "Input"]
}, Closed]],

Cell[CellGroupData[{
Cell[30057, 1029, 64, 1, 42, "Subsubsection",
  CellTags->"c:20"],
Cell[30124, 1032, 108, 2, 51, "Input"],
Cell[30235, 1036, 52, 1, 51, "Input"],
Cell[30290, 1039, 74, 1, 51, "Input"],
Cell[30367, 1042, 129, 4, 43, "Text"],
Cell[30499, 1048, 84, 1, 51, "Input"],
Cell[30586, 1051, 109, 2, 51, "Input"]
}, Closed]]
}, Closed]],

Cell[CellGroupData[{
Cell[30744, 1059, 127, 3, 42, "Subsection",
  CellTags->"c:21"],
Cell[30874, 1064, 598, 9, 168, "Text"],
Cell[31475, 1075, 83, 2, 74, "Input"],
Cell[31561, 1079, 87, 1, 51, "Input"],
Cell[31651, 1082, 51, 1, 51, "Input"],
Cell[31705, 1085, 88, 1, 51, "Input"],
Cell[31796, 1088, 51, 1, 51, "Input"],
Cell[31850, 1091, 215, 7, 43, "Text"],
Cell[32068, 1100, 101, 2, 51, "Input"],
Cell[32172, 1104, 72, 1, 51, "Input"],
Cell[32247, 1107, 635, 15, 143, "Text"],
Cell[32885, 1124, 101, 2, 51, "Input"],
Cell[32989, 1128, 109, 2, 43, "Text"],
Cell[33101, 1132, 145, 3, 74, "Input"],
Cell[33249, 1137, 140, 2, 74, "Input"],
Cell[33392, 1141, 94, 3, 43, "Text"],
Cell[33489, 1146, 46, 1, 51, "Input"],
Cell[33538, 1149, 543, 17, 68, "Text"],
Cell[34084, 1168, 164, 3, 74, "Input"],
Cell[34251, 1173, 32, 0, 43, "Text"],
Cell[34286, 1175, 78, 3, 70, "Input"],
Cell[34367, 1180, 79, 3, 70, "Input"],
Cell[34449, 1185, 71, 0, 43, "Text"],
Cell[34523, 1187, 119, 2, 74, "Input"],
Cell[34645, 1191, 167, 3, 74, "Input"],
Cell[34815, 1196, 365, 11, 68, "Text"]
}, Closed]],

Cell[CellGroupData[{
Cell[35217, 1212, 56, 1, 42, "Subsection",
  CellTags->"c:22"],
Cell[35276, 1215, 864, 26, 218, "Text"],

Cell[CellGroupData[{
Cell[36165, 1245, 140, 3, 42, "Subsubsection",
  CellTags->"c:23"],
Cell[36308, 1250, 130, 2, 43, "Text"],
Cell[36441, 1254, 332, 6, 166, "Input"],
Cell[36776, 1262, 33, 0, 50, "Input"],
Cell[36812, 1264, 28, 0, 43, "Text"],
Cell[36843, 1266, 116, 2, 74, "Input"],
Cell[36962, 1270, 136, 2, 51, "Input"]
}, Closed]]
}, Closed]],

Cell[CellGroupData[{
Cell[37147, 1278, 133, 3, 42, "Subsection",
  CellTags->"c:24"],
Cell[37283, 1283, 149, 3, 43, "Text"],
Cell[37435, 1288, 109, 2, 43, "Text"],
Cell[37547, 1292, 103, 2, 51, "Input"],
Cell[37653, 1296, 67, 0, 43, "Text"],
Cell[37723, 1298, 43, 1, 51, "Input"],
Cell[37769, 1301, 322, 9, 93, "Text"],
Cell[38094, 1312, 265, 5, 120, "Input"],
Cell[38362, 1319, 136, 2, 74, "Input"],
Cell[38501, 1323, 224, 6, 68, "Text"],
Cell[38728, 1331, 49, 1, 51, "Input"],
Cell[38780, 1334, 552, 17, 93, "Text"],
Cell[39335, 1353, 345, 7, 166, "Input"],
Cell[39683, 1362, 108, 2, 51, "Input"],
Cell[39794, 1366, 127, 2, 74, "Input"]
}, Closed]]
}, Closed]],

Cell[CellGroupData[{
Cell[39970, 1374, 98, 3, 51, "Section",
  Evaluatable->False,
  CellTags->"c:25"],
Cell[40071, 1379, 794, 26, 243, "Text"],

Cell[CellGroupData[{
Cell[40890, 1409, 66, 1, 42, "Subsubsection",
  CellTags->"c:26"],
Cell[40959, 1412, 56, 0, 43, "Text"],
Cell[41018, 1414, 76, 2, 74, "Input"],
Cell[41097, 1418, 262, 6, 68, "Text"],
Cell[41362, 1426, 56, 1, 51, "Input"],
Cell[41421, 1429, 107, 2, 74, "Input"],
Cell[41531, 1433, 117, 3, 43, "Text"],
Cell[41651, 1438, 128, 2, 74, "Input"],
Cell[41782, 1442, 343, 10, 68, "Text"],
Cell[42128, 1454, 37, 0, 50, "Input"],
Cell[42168, 1456, 176, 5, 43, "Text"],
Cell[42347, 1463, 76, 3, 70, "Input"],
Cell[42426, 1468, 162, 5, 43, "Text"]
}, Closed]],

Cell[CellGroupData[{
Cell[42625, 1478, 68, 1, 42, "Subsubsection",
  CellTags->"c:27"],
Cell[42696, 1481, 678, 19, 143, "Text"],
Cell[43377, 1502, 397, 8, 97, "Input"],
Cell[43777, 1512, 373, 8, 189, "Input"],
Cell[44153, 1522, 50, 0, 43, "Text"],
Cell[44206, 1524, 78, 2, 74, "Input"],
Cell[44287, 1528, 38, 0, 43, "Text"],
Cell[44328, 1530, 78, 2, 74, "Input"],
Cell[44409, 1534, 166, 6, 43, "Text"],
Cell[44578, 1542, 73, 1, 51, "Input"],
Cell[44654, 1545, 751, 20, 118, "Text"],
Cell[45408, 1567, 108, 2, 51, "Input"],
Cell[45519, 1571, 54, 0, 43, "Text"],
Cell[45576, 1573, 590, 12, 258, "Input"],
Cell[46169, 1587, 28, 0, 50, "Input"],
Cell[46200, 1589, 60, 3, 70, "Input"],
Cell[46263, 1594, 478, 16, 143, "Text"],
Cell[46744, 1612, 192, 5, 120, "Input"],
Cell[46939, 1619, 37, 0, 50, "Input"],
Cell[46979, 1621, 309, 7, 143, "Text"],
Cell[47291, 1630, 131, 3, 98, "Input"],
Cell[47425, 1635, 118, 3, 97, "Input"]
}, Closed]]
}, Closed]],

Cell[CellGroupData[{
Cell[47592, 1644, 93, 2, 51, "Section",
  CellTags->"c:28"],
Cell[47688, 1648, 1167, 32, 268, "Text"],
Cell[48858, 1682, 66, 5, 110, "Input"],
Cell[48927, 1689, 453, 10, 68, "Text"],
Cell[49383, 1701, 38, 5, 110, "Input"],
Cell[49424, 1708, 35, 0, 43, "Text"],
Cell[49462, 1710, 27, 0, 50, "Input"],
Cell[49492, 1712, 251, 8, 68, "Text"],
Cell[49746, 1722, 54, 3, 70, "Input"],
Cell[49803, 1727, 146, 4, 68, "Text"],
Cell[49952, 1733, 56, 3, 70, "Input"],
Cell[50011, 1738, 204, 8, 43, "Text"],
Cell[50218, 1748, 46, 3, 70, "Input"],
Cell[50267, 1753, 28, 0, 50, "Input"],
Cell[50298, 1755, 182, 8, 43, "Text"],
Cell[50483, 1765, 39, 3, 70, "Input"],
Cell[50525, 1770, 42, 3, 70, "Input"],
Cell[50570, 1775, 42, 3, 70, "Input"],
Cell[50615, 1780, 234, 5, 68, "Text"],
Cell[50852, 1787, 162, 3, 74, "Input"],
Cell[51017, 1792, 131, 3, 43, "Text"],
Cell[51151, 1797, 105, 2, 51, "Input"],
Cell[51259, 1801, 77, 2, 74, "Input"],
Cell[51339, 1805, 293, 6, 93, "Text"],
Cell[51635, 1813, 93, 1, 51, "Input"],
Cell[51731, 1816, 287, 5, 68, "Text"],
Cell[52021, 1823, 109, 2, 51, "Input"]
}, Closed]],

Cell[CellGroupData[{
Cell[52167, 1830, 120, 4, 51, "Section",
  Evaluatable->False,
  CellTags->"c:29"],

Cell[CellGroupData[{
Cell[52312, 1838, 55, 1, 42, "Subsubsection",
  CellTags->"c:30"],
Cell[52370, 1841, 210, 6, 68, "Text"]
}, Closed]],

Cell[CellGroupData[{
Cell[52617, 1852, 55, 1, 42, "Subsubsection",
  CellTags->"c:31"],
Cell[52675, 1855, 699, 23, 218, "Text"]
}, Closed]],

Cell[CellGroupData[{
Cell[53411, 1883, 55, 1, 42, "Subsubsection",
  CellTags->"c:32"],
Cell[53469, 1886, 480, 11, 118, "Text"]
}, Closed]],

Cell[CellGroupData[{
Cell[53986, 1902, 55, 1, 42, "Subsubsection",
  CellTags->"c:33"],
Cell[54044, 1905, 309, 7, 118, "Text"]
}, Closed]],

Cell[CellGroupData[{
Cell[54390, 1917, 55, 1, 42, "Subsubsection",
  CellTags->"c:34"],
Cell[54448, 1920, 284, 6, 118, "Text"]
}, Closed]],

Cell[CellGroupData[{
Cell[54769, 1931, 55, 1, 42, "Subsubsection",
  CellTags->"c:35"],
Cell[54827, 1934, 253, 6, 118, "Text"]
}, Closed]],

Cell[CellGroupData[{
Cell[55117, 1945, 55, 1, 42, "Subsubsection",
  CellTags->"c:36"],
Cell[55175, 1948, 148, 4, 68, "Text"]
}, Closed]]
}, Closed]]
}, Open  ]]
}
]
*)



(*******************************************************************
End of Mathematica Notebook file.
*******************************************************************)