P1

Ed Doolittle’s solution on ⌊k(Sqrt[2])⌋= (2^n)

Problem

Background: (Sqrt[2]) is irrational, the value k(Sqrt[2]) is never an integer for positive integer k. In this problems we are concerned with the sequence generated by the integer part ⌊k(Sqrt[2])⌋.

Table[With[{int=Floor[t*(Sqrt[2])]},If[BitAnd[int,int-1]==0,Highlighted[int],int]],{t,1,60}]

Show that this sequence contains infinite number of powers of 2 (notice that some powers of 2 may be skipped. For instance we do not have (2^6) = 64 in this sequence.)

Also related to “Miniature” coffee break 7: 
Determine if the last digit of Floor[((((Sqrt[2])))^k)] in decimal is periodic or not for all integer k.

ArrayPlot[Partition[Table[Mod[Floor[(Sqrt[2])^k],10],{k,10000}],100],ColorFunction->Hue]

Demonstrations:

Some useful functions for our application:

Display digits for a given real number rational or irrational

RealDigits[5/3]

RealDigits[3/5]

There is no simple repeating patterns for irrational number, the function returns unevaluated for these type of numbers.

RealDigits[(Sqrt[2])]

Instead, we must specify the number of digits we want to work with. For instance ten digits in base 10:

RealDigits[(Sqrt[2]),10,10]

(Sqrt[2.])

The key takeaway of this problem is to realize it is more convenient to work with base 2:

RealDigits[1/2,2,10]

{RealDigits[(Sqrt[2]),2,10],RealDigits[(Sqrt[2]),10,10]}

Floor function

Floor[(Sqrt[2])]

and we can quickly show that 64 is skipped because the sequence is non-decreasing:

{Floor[45*(Sqrt[2])],Floor[46*(Sqrt[2])]}

Add more terms to show that 256 and 512 also missing:

Table[With[{int=Floor[t*(Sqrt[2])]},If[BitAnd[int,int-1]==0,Highlighted[int],int]],{t,1,400}]//Short[#,12]&

Try more numbers

Do[With[{int=Floor[t*(Sqrt[2.])]},If[BitAnd[int,int-1]==0,int,Continue[]]],{t,1,2500000}];][[2]]//AbsoluteTiming

Log2[%[[1]]]

For even larger range, use compiled code for 2 billion numbers:

cf=FunctionCompile[ Function[{},
Native`UncheckedBlock@Block[{ds,int},
ds=TypeHint[CreateDataStructure["LinkedList"],"LinkedList"::["MachineInteger"]];
Do[
int=Floor[t*(Sqrt[2.])];If[BitAnd[int,int-1]==0,ds["Append",int],Continue[]],{t,1,2000000000}];
ds["Elements"]
]]
];

cf[]//AbsoluteTiming

ds=%[[2]];

ds["DropAll"]

Speed up by 2100+ times:

(2000000000/1.8)/(2500000/4.8)

Log2[%[[2]]]

We want to show that the Floor[k·(Sqrt[2])] contains Infinite number of (2^q) (not essentially all q). We need some observations:

(Sqrt[2]) has infinite 1’s in base 2. Otherwise, it would be rational because of the trailing repeating zeros. Use visualization to quickly verify:

ArrayPlot[Partition[RealDigits[(Sqrt[2]),2,160000][[1]],400],ColorRules->{1->Yellow,0->Lighter[Blue,0.3]}]

Thus there are infinity k such that {(2^k)*(Sqrt[2])} > 1/2 > 1- 1/(Sqrt[2]), or 0<(Sqrt[2])(1-{(2^k)*(Sqrt[2])})<1  because 1/2 is simply 0.1 in binary. Any thing start with 1 to the right hand side of the decimal point will be larger than this number.

Table[FractionalPart[(2^k)*(Sqrt[2.`300])]>1/2,{k,1,600}]//Short

ListPlot[%,ScalingFunctions->NominalScale[{True,False}],PlotHighlighting->None]

Table[(Sqrt[2])(1-FractionalPart[(2^k)*(Sqrt[2.`300])])<1,{k,1,600}]//Short

ListPlot[%,ScalingFunctions->NominalScale[{True,False}],PlotHighlighting->None]

Note that Floor[Integer +Fraction] = Integer , 
0<(Sqrt[2])(1-{(2^k)*(Sqrt[2])})<1 
⟶ Floor[(2^(k+1)) + (Sqrt[2])(1-{(2^k)*(Sqrt[2])}) ] =(2^(k+1)) 
⟶ Floor[ (Sqrt[2])((2^k)*(Sqrt[2])+1-{(2^k)*(Sqrt[2])}) ] =(2^(k+1)) 
and 1+(2^k)*(Sqrt[2])-{(2^k)*(Sqrt[2])} =1+ Floor[(2^k)*(Sqrt[2])] = Floor[1+(2^k)*(Sqrt[2])].

Therefore the list of  n = Floor[1+(2^k)*(Sqrt[2])] always generates with proper k (not ALL k!)

Table[If[(Sqrt[2])(1-FractionalPart[(2^k)*(Sqrt[2.`300])])<1,k,Nothing],{k,1,200}]

Floor[Floor[1+2^#*(Sqrt[2.`300])]*(Sqrt[2])]&/@%

BitAnd[#,#-1]&/@%

Also answers the coffee break question. If the last digit is periodic in decimal, it must be periodic in binary.  
Because Floor[(2^k)(Sqrt[2])]  in base 2 simply means extract the binary digit, which of course is not periodic. 
Thus it is not periodic in decimal.

ArrayPlot[Partition[Table[Mod[Floor[(Sqrt[2])^k],2],{k,160000}],400],ColorRules->{1->Yellow,0->Lighter[Blue,0.3]}]

P2

Fractional parts of square roots (Ukraine)

Source: https://artofproblemsolving.com/community/c6h3046183p27437949

Visualization technique

Use ListPlot for a large amount data point would be slow. Instead, use pixel as point for rectangular region is simple:

data2=Transpose@(Reverse/@Table[With[{h=N@Min[
FractionalPart[(Sqrt[x^2+2*y])],FractionalPart[(Sqrt[y^2+2*x])]]},{h+0.4,If[x==y,0.,h+.1],1.}],{x,2,1200},{y,2,1200}]);

Sweeping through anti diagonals

dataAntiDiagnoal=Table[N@Min[
FractionalPart[(Sqrt[x^2+2*(800-x)])],FractionalPart[(Sqrt[(800-x)^2+2*x])]],{x,Drop[Range[800],{400}]}];

ListPlot[dataAntiDiagnoal]

Use proper hue bar to indicate the magnitudes of the target function:

Graphics[
{Table[{Hue[h+0.4,h+0.1,1.0],EdgeForm[Gray],Rectangle[{48 h,0}]},{h,0,1,1/48}],
Table[Text[i,{i+0.5,-.5}],{i,0,48,2}]}]

we should expect the largest value near this location:

29/48.

Image[data2,ColorSpace->"HSB",ImageSize->400,ImageResolution->800]

With[{x=200},DiscretePlot[Min[
FractionalPart[(Sqrt[x^2+2*y])],FractionalPart[(Sqrt[y^2+2*x])]],{y,1,400},RegionFunction->Function[{u,v},u!=200],AspectRatio->1/4,GridLines->{None, {0.618}},GridLinesStyle->Thick,PlotRange->{0,0.65}]
]

Manipulate[
With[{x=vert},DiscretePlot[Min[
FractionalPart[(Sqrt[x^2+2*y])],FractionalPart[(Sqrt[y^2+2*x])]],{y,1,400},RegionFunction->Function[{u,v},u!=vert],AspectRatio->1/4,GridLines->{None, {0.618}},GridLinesStyle->Thick,PlotRange->{0,0.63},Joined->False]
],
{vert,20,400,10},ControlPlacement->Top
]

P3

Generating functions

Concepts and motivation

Stanley has a dedicated chapter about this in enumerative comb.

Commonly used in probability and combinatorics

Usually only coefficients of the expression matter

Radius of convergence is not important

History: Euler’s identity for  even-odd partition

Riemann Zeta series and Expansion of Multiplicative function

expr1=(Sum[(Subscript[a, i])*(i^(-s)),{i,10}]*Sum[(Subscript[b, i])*(i^(-s)),{i,10}]//Expand)

A useful tool here is to flip the position of the base and exponent. It is easy to extract the base under (-s)

expr2=expr1/.Times[Power[b_,Times[p_,s]],e_]:>With[{pp=(1/(b^p))},s^(pp)*e];

Extract the coefficients:

With[{k=8},Coefficient[expr2,s,k]]//Expand

Well known Dirichlet transforms

DirichletTransform[n,n,s]

DirichletTransform[(Sqrt[n]),n,s]

DirichletTransform[Abs[MoebiusMu[n]],n,s]

DirichletTransform[EulerPhi[n],n,s]

Log is from the derivative of the Zeta s function

DirichletTransform[Log[n],n,s]

D[n^(-s),s]

DirichletTransform[DivisorSigma[#,n],n,s]&/@{1,2,3,4,5}

which can be derived from the following identity:

Sum[Sum[p^(2*i),{i,0,n}]*p^(s*n),{n,0,Infinity}]

Moebius inversion/Square Free/inclusion - exclusion principle

DirichletTransform[MoebiusMu[n],n,s]

expr1=(Sum[1*(i^(-s)),{i,10}]*Sum[(Subscript[b, i])*(i^(-s)),{i,10}]//Expand)

expr2=expr1/.Times[Power[b_,Times[p_,s]],e_]:>With[{pp=(1/(b^p))},s^(pp)*e];

With[{k=8},Coefficient[expr2,s,k]]//Expand

expr3=(Sum[(Subscript[a, i])*(i^(-s)),{i,30}]*Sum[MoebiusMu[i]*(i^(-s)),{i,30}]//Expand);
expr3//Short

expr4=expr3/.Times[Power[b_,Times[p_,s]],e_]:>With[{pp=(1/(b^p))},s^(pp)*e];

With[{k=8},Coefficient[expr4,s,k]]//Expand

With[{k=30},Coefficient[expr4,s,k]]//Expand

cyclotomic polynomial

Cyclotomic[6,\[FormalX]]

Cyclotomic[12,\[FormalX]]

Cyclotomic[6,\[FormalX]]

GF on simple sequences

Fibonacci

RecurrenceTable[{a[n+1]==a[n]+a[n-1],a[1]==a[2]==1},a,{n,1,10}]

GeneratingFunction[Fibonacci@n,n,z]

Collect[Sum[(Subscript[a, i])*x^i,{i,10}]*x+Sum[(Subscript[a, i])*x^i,{i,10}]*x^2,x]

Catalan

GeneratingFunction[CatalanNumber[n],n,x]

cf=Sum[(Subscript[c, i])*x^i,{i,0,10}]

Collect[cf^2,x]

Solve a combinatorics problem with GF

A sequence of   and  defined as

Question: find all  such that .

’s equivalence in boolean relation:

[Xor["(Subscript[A, n])","(Subscript[B, n])"]]

Analysis

Use cache to define the recurrence relation:

Clear[a,b]

a[1]={};
b[1]={0};
a[n_]:=a[n]=b[n-1]+1;
b[n_]:=b[n]=Complement[
Union[a[n-1],b[n-1]],
Intersection[a[n-1],b[n-1]]
];

Print the outcome

[
Table[Echo[a[i],"a["<>ToString[i]<>"]: "],{i,100}],
50];

[
Table[Echo[b[i],"b["<>ToString[i]<>"]: "],{i,1000}],
50];

Find {0} at these positions:

Position[b/@Range[3000],_?(#=={0}&)]//Flatten

With[{k=15},[{a[k],b[k]},"Labels"->ToString/@{a[k],b[k]}]]

Manipulate[
ResourceFunction["VennGraphPlot"][{a[i],b[i]},"Labels"->ToString/@{a[i],b[i]}],
{i,Range[300]},]

Use GF on mod 2 space:

sol=f/.RSolve[{f[n+1]==f[n]+x*f[n-1],f[0]==0,f[1]==1},f,n][[1]]

sol[10]//Simplify

Tabulate the generating function mod 2:

[
flist=NestList[{#[[2]],PolynomialMod[#.{x,1},2]}&,{0,1},32][[All,2]]//Expand,
"NumberColumn"->True,Alignment->Left]

Necessary condition

[
NestList[{#[[2]],PolynomialMod[#.{x,1},{2,x^2}]}&,{0,1},32][[All,2]]//Expand,
"NumberColumn"->True,Alignment->Left]

Notice the sequence of PolynomialMod and Mod. Similar to Mod of integer, in general, the order matters:

Mod[Mod[17,3],4]

Mod[Mod[17,4],3]

Mod[17,12]

Sufficient condition

sol[2n]/sol[n]//Simplify

solg=g/.RSolve[{g[n+1]==g[n]+x*g[n-1],g[0]==2,g[1]==1},g,n][[1]]

[
glist=NestList[{#[[2]],PolynomialMod[#.{x,1},2]}&,{2,1},32][[All,2]]//Expand,
"NumberColumn"->True,Alignment->Left]

glist===flist

Optional: The integral property of the binomial coefficient is equivalent to Kummer

Binomial[1/2,3]

(((1/2)*(1/2-1)*(1/2-2))/(1*2*3))

Clear[KummerpAdic]

SetAttributes[KummerpAdic,HoldFirst];

KummerpAdic[b_Binomial,base_:2]:=Enclose@Module[{},
If[!PrimeQ[base],
Echo["P-adic requires prime base p."];Abort[]
];
ConfirmQuiet@Dot[
Total[IntegerDigits[#,base]]&/@{(Unevaluated@b)[[2]],(Unevaluated@b)[[1]]-(Unevaluated@b)[[2]],(Unevaluated@b)[[1]]},
{1,1,-1}
]/(base-1)
]

KummerpAdic[Binomial[1749,355],5]

Bin(1749000,355) is a multiple of (5^3) but not (5^4) and so on

KummerpAdic[Binomial[1749000,355],5]

DiscretePlot[KummerpAdic[Binomial[1000,i],3],{i,1,500},Joined->False,PlotStyle->PointSize@Tiny]

P4

Thales Duo

Two circles K1 and K2 with center O1 and O2 and radii 1 and (Sqrt[2]), resp., intersect at A and . AC is the chord of K2 which is bisected by K1. Determine the length of AC, given that O1 and O2 are 2 units apart. (From Erdos to Kiev)

scene=GeometricScene[{o1->{0,0},o2->{2,0},a,b,c,d},{
CircleThrough[{a,d,b},o1,1],
CircleThrough[{a,b,c},o2,(Sqrt[2])],
Line[{a,d,c}],
d==Midpoint[{a,c}]
}];

rs=RandomInstance[scene]

[rs,ArcLength@Line[{a,c}]]

[rs,SquaredEuclideanDistance[a,c]]

Synthetic proof

See illustration.

Import["C:\\Users\\sheng\\OneDrive\\myDocuments\\Apowersoft\\Windows ApowerMirror\\20231102_185320.png"]

Medial triangle once: homothety of (Subscript[ADO, 2]) to ACQ at A

Thales theorem twice: in triangle APD and ACQ. To show AD is height and (Subscript[PDO, 2]) are collinear.

(Subscript[APO, 2]) is SAS, where A is from law of cosine in triangle A-(Subscript[O, 1])-(Subscript[O, 2])

Thus the computation is very short (thanks for wolfram math team to provide this handy function  )

tri=SASTriangle[1*2,[{1,2,(Sqrt[2])}][[2]],(Sqrt[2])]

2*TriangleMeasurement[tri,{"Height",tri[[1,3]]}]

N[%]

P5

Game and Group

https://math.la.asu.edu/~kawski/classes/mat444/444home.html

g1=PermutationGroup[{Cycles[{Range[20]}],Cycles[{{1,4},{2,3}}]}];

GroupOrder[g1]

20!

stabchain1=GroupStabilizerChain[g1];

stabchain/. group_PermutationGroup:>GroupOrder[group]//Column

g2=PermutationGroup[{Cycles[{Range[19]}],Cycles[{{1,4},{2,3}}]}];

GroupOrder[g2]/19!

stabchain2=GroupStabilizerChain[g2];

stabchain2/. group_PermutationGroup:>GroupOrder[group]//Column

Floor[19!/E]

44750731559645106/60822550204416000

g3=PermutationGroup[{Cycles[{Range[18]}],Cycles[{{1,4},{2,3}}]}];

GroupOrder[g3]

18!

g4=PermutationGroup[{Cycles[{Range[17]}],Cycles[{{1,4},{2,3}}]}];

GroupOrder[g4]/17!

stabchain1=GroupStabilizerChain[g4];

stabchain1/. group_PermutationGroup:>GroupOrder[group]//Column

stabchain=GroupStabilizerChain[g4]

P6

Example by Dr J. D. Cook: Moebius transformation over finite field

(Left: generated by WL, Right: Cook) 
FF used in the example:

ff=FiniteField[17];

Define the Moebius transformation and its infinity

Clear[mt]

mt[ffe_FiniteFieldElement]:=With[{a=3,b=8,c=6,d=5},
If[ffe["Index"]==2,Infinity,(a*ffe+b)/(c*ffe+d)]
]

Infinity is when the denominator is zero:

Reduce[ff[6]*x+ff[5]==0,x]

Also define the preimage of infinity:

mt[Infinity]:=With[{a=3,b=8,c=6,d=5},
ff[a]/ff[c]
]

mt[Infinity]

One-point compactification:

pre=Append[ff/@(Range[17]-1),Infinity]

image=mt/@pre

In total 18 items:

ele=Range[18];

Notice that we have two fixed points:

mt@*ff/@{1,10}

Use the following code to remove the self loops:

removeSelfLoops=EdgeDelete[#,(UndirectedEdge|DirectedEdge)[vv_,vv_,___]]&;
(*SE: 
https://mathematica.stackexchange.com/questions/257857/function-to-remove-self-loops-but-preserve-multiple-edges-in-graph*)

Generate the random permutation of 18 elements using the Moebius transform:

circleLayout[n_]:=Table[{Cos[2 π/n (i-1)],Sin[2 π/n (i-1)]},{i,n}];

removeSelfLoops@Graph[
Thread[ele->Flatten[Position[pre,#]&/@image]],
VertexCoordinates->Thread[ele->circleLayout[18]],VertexLabels->(v_:>Placed[pre[[v]],Above])]