Ex. 1

i1={{0.4,1.,1.},{0,0}};
i2={{0.4,1.,1.},{.2,.4}};
i3={{1.4,1.1,2.2},{.2,.99}};

{a,b,c}={.4,1.,1.};
{x0,y0}={.2,.4};

ex1v1[{{a_,b_,c_},{x0_,y0_}}]:=
ListPlot[NestList[{#[[2]]-Sign[#[[1]]] Sqrt[Abs[b #[[1]] - c]], a-#[[1]]}&,{x0,y0},10000],
Axes->False,
AspectRatio->Automatic
]

ex1v1[i3]

ex1v2[{{a_,b_,c_},{x0_,y0_}}]:=
Graphics[
{
PointSize[.004],
Point/@
NestList[
{#[[2]]-Sign[#[[1]]] Sqrt[Abs[b #[[1]] - c]], a-#[[1]]}&,
{x0,y0},10000]
}
]

ex1v2[i3]

ex1v3[{{a_,b_,c_},{x0_,y0_}}]:=
ListPlot[
RecurrenceTable[
{x[n+1]==y[n]-Sign[x[n]]*Sqrt[Abs[b*x[n]-c]],
y[n+1]==a-x[n],
x[0]==x0,
y[0]==y0},
{x,y},
{n,10000}],
Axes->False,
AspectRatio->Automatic
];

ex1v3[i3]

Ex. 2

Clear[a,b,c,x0,y0]

N[Pi,10]

?RealDigits

RealDigits[Pi,10,10]

(t=Table[1/(10.^j) *Count[First[RealDigits[Pi,10,10^j]],i],{i,0,9},{j,3,5}])//TableForm

(t=Table[1/(10.^j) *Count[Drop[First[RealDigits[N[π,10^j+1]]],-1],i],{i,0,9},{j,3,5}])//TableForm

Check result

Plus@@@Transpose[t]

Attention! Tally only counts what actually appears in the list.

Tally[
First[RealDigits[Pi,10,10]]
]

Map[#[[2]]&,Sort[Tally[First[RealDigits[Pi,10,100]]]]]

Ex. 3a

Clear[t]

in=RandomInteger[{1,8},{20,2}]

?DeleteDuplicates

DeleteDuplicates[in, #1==#2 ||Reverse[#1]==#2&]

noDup[list_]:=
Block[{l,p,a,b,m,r},
list //.{
{l___,p:{a_,b_},m___,{a_,b_},r___}->{l,p,m,r},
{l___,p:{a_,b_},m___,{b_,a_},r___}->{l,p,m,r}
}
]

noDup[in]

Ex. 3b

noDupSv1[list_]:=
Block[{l,p,a,b,m,r},
Sort[Sort/@(list //.{
{l___,p:{a_,b_},m___,{a_,b_},r___}->{l,p,m,r},
{l___,p:{a_,b_},m___,{b_,a_},r___}->{l,p,m,r}
})]
]

noDupSv1[in]

noDupSv2[list_]:=
Block[{l,p,a,b,m,r},
Map[Sort,list //.{
{l___,p:{a_,b_},m___,{a_,b_},r___}->{l,p,m,r},
{l___,p:{a_,b_},m___,{b_,a_},r___}->{l,p,m,r}
},{0,1}]
]

noDupSv2[in]

noDupSv3[list_]:=
Block[{l,p,p1,p2,a,a1,a2,b,b1,b2,m,r},
list //.{
{l___,{a_,b_},r___}/;a>b->{l,{b,a},r},(*sort pairs*)
{l___,p:{a_,b_},m___,{a_,b_},r___}->{l,p,m,r},(*delete duplicates*)
{l___,p1:{a1_,_},m___,p2:{a2_,_},r___}/;a1>a2->{l,p2,m,p1,r},(*sort list*)
{l___,p1:{a_,b1_},m___,p2:{a_,b2_},r___}/;b1>b2->{l,p2,m,p1,r}(*sort list*)
}
]

noDupSv3[in]

Ex. 4

Clear[in]

n=10;
inp=RandomSample[Range[n]]

Convert to {{1, a}, {2, b}, {3, c}… }

MapIndexed[f,{a,b,c,d}]

start=MapIndexed[
{#2[[1]],#1}&,
inp]

recursive function

Clear[cycles]

cycles[{l___,{a__,b_},m___,{b_,c_},r___}]:=cycles[{l,{a,b,c},m,r}]

cycles[{l___,{a_,b___,a_},r___}]:=
cycles[{l,{a,b},r}]

cycles[a_]:=a

cycles[start]

replacement rules

(start//.
{l___,{a__,b_},m___,{b_,c__},r___}:>
{l,{a,b,c},m,r})//.{e_,l___,e_}:>{e,l}

Ex. "Sequence"

functions

inDigits=IntegerDigits[98789777777777777]

in2=Tally[inDigits]

in3=Sort[in2]

in4=Reverse/@ in3

Attention! FromDigits[] carries over.

FromDigits[{7,11}]

in5=IntegerDigits/@in4

out=Flatten[in5]

Clear[iterRule]

iterRule[S_]:=
Flatten[IntegerDigits/@Reverse/@Sort[Tally[S]]]

iterRule[{4,2}]

Sn=123;

FromDigits/@FixedPointList[iterRule,IntegerDigits@Sn,50]

replacement rules

inDigits=IntegerDigits[98789777777777777]

Tally

pairs=inDigits/.a_Integer->{1,a}

counts=
Block[{l,c,r,a,n,m},
pairs//.
{l___,{n_,a_},c___,{m_,a_},r___}->{l,{n+m,a},c,r}
]

Sort

sorted=
Block[{l,e1,u,e2,v,r},
counts//.
{l___,e1:{_,u_},e2:{_,v_},r___}/;v<u->{l,e2,e1,r}
]

Flatten

outDigits=
Block[{l,a,b,r},
sorted//.
{l___,{a_,b_},r___}->{l,a,b,r}
]

Integerdigits

out=
Block[{l,n,r},
outDigits//.
{l___,n_,r___}/;n>9->{l,Quotient[n,10],Mod[n,10],r}
]

iterRule[x_]:=
Block[{a,b,c,l,n,m,r,e1,e2,u,v},
x/.a_Integer->{1,a}//.
{l___,{n_,a_},c___,{m_,a_},r___}->{l,{n+m,a},c,r}//.
{l___,e1:{_,u_},e2:{_,v_},r___}/;v<u->{l,e2,e1,r}//.
{l___,{a_,b_},r___}->{l,a,b,r}//.
{l___,n_,r___}/;n>9->{l,Quotient[n,10],Mod[n,10],r}
]

iterRule[{4,2}]

Sn=42;

Sn=98789777777777777;

Sn=205;

seq=FromDigits/@FixedPointList[iterRule,IntegerDigits@Sn,50]

Bonus

edges=DirectedEdge@@@DeleteDuplicates[Partition[seq,2,1]];
vertices=DeleteDuplicates[seq];
graph=Graph[
Property[#1,{
VertexSize-> 0.03*Log10[#1],
VertexStyle-> Hue[0.6,Rescale[N[Log10[#1]],{1,Log10[Max[vertices]]}],1]}
]&/@vertices,
edges,
GraphLayout->"SpringEmbedding",
VertexLabels->Placed["Name",Tooltip]
]

Plotting Polynomials

p[x_]:=x^7 - 2x^4 + x + 0.5

Roots

roots=NSolve[p[x]==0,x,Reals]

Local Extrema

localExtrema=Select[NSolve[p'[x] == 0, x, Reals], (p''[x] != 0) /.#&]

le={x,p[x]}/.localExtrema

Plotting

plot=Plot[p[x],{x,-1,1.5},AspectRatio->Automatic]

g1=Graphics[{PointSize->Large, Orange,Point/@le}]

Show[plot,g1]

g2=Graphics[
Text[NumberForm[#,5],#,{0,2}]&/@le
]

Show[plot,g1,g2]

Manipulate

Manipulate[
g3=Graphics[Point[{x,p[x]}]];
Show[plot,g3],
{x,-1,1.5}
]

normal = {Cos[ArcTan[p'[x]]+Pi/2],Sin[ArcTan[p'[x]]+Pi/2]};

Manipulate[
normal = {Cos[ArcTan[p'[x]]+Pi/2],Sin[ArcTan[p'[x]]+Pi/2]};
g4=Graphics[
Line[
{
0.2normal+{x,p[x]},
{x,p[x]}
}
]
];
Show[plot,g4],
{x,-1,1.5}
]

polyPlot[p_]:=Module[
{MinX,MaxX,MinY,MaxY,
InterestingXR,InterestingX,InterestingY,
Equal0,LocalExtrema,Saddle,EqualX,  GradientP1,  GradientN1,MarginX,MarginY,normal,tangent},

MakePoints[l_]:=DeleteDuplicates[Partition[Riffle[Last@@@l,p[x]/.l],2]];

HighlightsGraphic[l_]:=Graphics[
{PointSize->Large, Orange,Point@l}
];

PointsGraphic[l_]:=Graphics[
Point@l
];

PointLabelsGraphic[l_]:=Graphics[
Text[NumberForm[#,5],#,{1.1*Sign[#[[1]]-MaxX*0.8],1.1},Background->White]&/@l
];

SingleLabelsGraphic[l_]:=Graphics[
Text[NumberForm[#[[1]],5],#,{0,2},Background->White]&/@l
];

GradientGraphic[l_]:={Graphics[
{Gray,
Line[
{#+{1,Sign[p'[First[#]]]}*0.15,
#-{1,Sign[p'[First[#]]]}*0.15}&/@l
]}
],
HighlightsGraphic[l]
};

Equal0=NSolve[p[x]==0,x,Reals];

LocalExtrema=Select[NSolve[p'[x]==0,x,Reals],p''[Last@@#]!=0&];

Saddle=Select[NSolve[p'[x]==0,x,Reals],p''[Last@@#]==0&];

EqualX=NSolve[p[x]==x,x,Reals];

GradientP1 =NSolve[p'[x]==1 ,x,Reals];

GradientN1 =NSolve[p'[x]==-1 ,x,Reals];

InterestingXR=Join[Equal0,EqualX,LocalExtrema, Saddle,GradientP1,GradientN1];

InterestingX=Last@@@InterestingXR;

InterestingY=p[x]/.InterestingXR;

MinX=Min[InterestingX];
MaxX=Max[InterestingX];
MinY=Min[InterestingY];
MaxY=Max[InterestingY];

MarginX=(MaxX-MinX)*0.15;
MarginY=(MaxY-MinY)*0.15;

Manipulate[
normal = {Cos[ArcTan[p'[s]]+Pi/2],Sin[ArcTan[p'[s]]+Pi/2]};

tangent = {Cos[ArcTan[p'[s]]],Sin[ArcTan[p'[s]]]};

Show[
Pick[{
Plot[p[x],
{x,MinX-MarginX,MaxX+MarginX},
AspectRatio->Automatic,
PlotRange-> {MinY-MarginY,MaxY+MarginY}
,Ticks->Switch[
c1||c2||c3||c4||c5,
True,None,
False,Automatic
]
],

Plot[x,{x,MinX-MarginX,MaxX+MarginX},
PlotStyle-> {Dashed,Gray},
PlotRange->  {MinY-MarginY,MaxY+MarginY},
Ticks->None,Axes->None
],

PointsGraphic[MakePoints[InterestingXR]],

HighlightsGraphic[MakePoints[Equal0]],
SingleLabelsGraphic[MakePoints[Equal0]],

HighlightsGraphic[MakePoints[LocalExtrema]],
PointLabelsGraphic[MakePoints[LocalExtrema]],

HighlightsGraphic[MakePoints[Saddle]],
PointLabelsGraphic[MakePoints[Saddle]],

HighlightsGraphic[MakePoints[EqualX]],
PointLabelsGraphic[MakePoints[EqualX]],
Graphics[{
(*Osculating Circle*)
Point[{s,p[s]}],
With[{curvature=p''[s]/(1+p'[s]^2)^(3/2)},
(*Formula for curvature taken from http://mathworld.wolfram.com/Curvature.html*)
If[Abs[curvature]>0.03,
Circle[
(*center*)
{s,p[s]}+normal/curvature,
(*radius*)
Abs[1/curvature]
],
Line[{
{s,p[s]}+tangent*10(MaxX+MaxY),
{s,p[s]}+tangent*10(MinX+MinY)
}]
]
],
Line[{
{s,p[s]}+normal*0.1,
{s,p[s]}-normal*0.1
}]
}],
GradientGraphic[MakePoints[Join[GradientP1,GradientN1]]]
},
{True,c4,True,c1,c1,c2,c2,c3,c3,c4,c4,c6,c5}]
,ImagePadding->10
],
{{c1,False,"Roots"},{False, True} },
{{c2,False,"Local Extrema"},{False, True}},
{{c3,False,"Saddle Points"},{False, True}},
{{c4,False,"Intersections with y=x"},{False, True}},
{{c5,False,"p'[x]=1 or p'[x]=-1"},{False, True}},
{{s,MaxX-(MaxX-MinX)/2,"x"},MinX-MarginX,MaxX+MarginX},
{{c6,False,"Osculating Circle at {x,p[x]}"},{False, True}}]
]

polyPlot[p]