Minkowski's Question Mark Function

Author

Eric W. Weisstein
January 6, 2023

This notebook downloaded from http://mathworld.wolfram.com/notebooks/SpecialFunctions/MinkowskisQuestionMarkFunction.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/MinkowskisQuestionMarkFunction.html.

©2023 Wolfram Research, Inc. except for portions noted otherwise

Code

From Sasha Pavlyk (ca. 2013?)

MQMSum[dig_List,e_:(1/2)]:=Module[{d=e^(Accumulate[dig]-1)},
If[Length[d]>=2,d[[2;;-1;;2]]*=-1];
Total[d]]

MyMinkowskiQuestionMark[x_?NumberQ/;x<0]:=-MyMinkowskiQuestionMark[-x]

MyMinkowskiQuestionMark[x:(_Rational|_Integer)]:=Module[{d},
d=ContinuedFraction[x];
First[d]+MQMSum[Rest[d]]
]

MyMinkowskiQuestionMark[x_?QuadraticIrrationalQ]:=Module[{d,res,per,f},
d=ContinuedFraction[x];
res=First[d];
per=Last[d];
d=Most[Rest[d]];
res+=MQMSum[d];
f=(-1)^Length[d] /(1-(-1)^Length[per]/2^Total[per])/2^(Total[d]);
res+f*MQMSum[per]
]

MyMinkowskiQuestionMark[x_?NumberQ /;x==0]:=x

MyMinkowskiQuestionMark[x_?InexactNumberQ]:=Module[{d},
d=ContinuedFraction[x];
SetAccuracy[First[d]+MQMSum[Rest[d],SetPrecision[1/2,Precision[x]]],
Log[10,2.]Total[d]]
]

Plot

GraphicsRow[Plot[#,{x,0,2},AxesLabel->{x,#},PlotStyle->Red,LabelStyle->Directive[Black,FontFamily->"Times"]]&/@{MinkowskiQuestionMark[x],HoldForm[MinkowskiQuestionMark[x]-x]},ImageSize->500,Alignment->Top]

Minimum

Plot[MinkowskiQuestionMark[x]-x,{x,0,1},PlotLabel->MinkowskiQuestionMark[x-x]]

Plot[MinkowskiQuestionMark[x]-x,{x,.15,.25},PlotLabel->MinkowskiQuestionMark[x-x]]

FindMinimum[{MinkowskiQuestionMark[x]-x,2/10<x<21/100},{x,.207},MaxIterations->500,WorkingPrecision->500]

NMinimize[{MinkowskiQuestionMark[x]-x,2/10<x<21/100},x]//Timing

NMinimize[{MinkowskiQuestionMark[x]-x,2/10<x<21/100},x,WorkingPrecision->50,PrecisionGoal->20]//Timing

From Ed Pegg, Jr., Jan. 5, 2023:

terms=Flatten[{0,Table[{Table[{4,1},{k}],{5,1}},{k,3,5}]}]

n=FromContinuedFraction[terms]

N[%,20]

terms=Flatten[{0,Table[{Table[{4,1},{k}],{5,1}},{k,3,10}]}]

n=FromContinuedFraction[terms]

N[%,20]

Special Values

TextGrid[{#,MinkowskiQuestionMark[#]}&/@{0,1/3,1/2,GoldenRatio-1,2/3,Sqrt[2]/2,Sqrt[3]/2,1},Dividers->All]//TraditionalForm

?((1/(k^n)))==(1/(2^((k^n)-1)))

MinkowskiQuestionMark[(1/(k^n))]//FunctionExpand

MinkowskiQuestionMark[1/(4^k)]//FunctionExpand

MinkowskiQuestionMark[1/(k^4)]//FunctionExpand

?(x) ==((n-1)/n)

Cf.

https://oeis.org/A065936
https://oeis.org/A065937

Solve[MinkowskiQuestionMark[x]==1/2&&0<x<1,x]

vals={1/2,1/2 (-1+Sqrt[5]),2/3,1/Sqrt[2],1/10 (5+Sqrt[5]),-1+Sqrt[3],3/4,1/6 (1+Sqrt[13]),1/7 (4+Sqrt[2]),1/4 (-1+Sqrt[17]),1/22 (15+Sqrt[5]),1/9 (1+Sqrt[37]),1/6 (3+Sqrt[3]),1/2 (-3+Sqrt[21]),4/5,1/4 (1+Sqrt[5]),1/18 (11+Sqrt[13]),1/16 (-7+Sqrt[401]),1/14 (10+Sqrt[2]),Sqrt[2/3],1/16 (9+Sqrt[17]),1/14 (-11+Sqrt[506]),1/38 (29+Sqrt[5]),1/45 (10+Sqrt[730]),1/28 (17+Sqrt[37]),1/34 (-9+Sqrt[1373]),1/13 (9+Sqrt[3]),1/202 (20+Sqrt[21610]),1/14 (7+Sqrt[21]),-2+2 Sqrt[2],5/6};

MinkowskiQuestionMark/@vals

vals//Column

?(((ϕ)^(-1)))

MyMinkowskiQuestionMark[1/GoldenRatio]

MinkowskiQuestionMark[1/GoldenRatio]

?(1/(Sqrt[2]))

MyMinkowskiQuestionMark[Sqrt[2]/2]

MinkowskiQuestionMark[Sqrt[2]/2]

?((Sqrt[3])/2)

MyMinkowskiQuestionMark[Sqrt[3]/2]

MinkowskiQuestionMark[Sqrt[3]/2]

Powers

Table[MinkowskiQuestionMark[1/2^n],{n,5}]

Table[1/2^(2^n-1),{n,5}]

Table[MinkowskiQuestionMark[1/3^n],{n,5}]

Table[MinkowskiQuestionMark[1/3^n]-1/2^(3^n-1),{n,5}]

Table[MinkowskiQuestionMark[1/4^n]-1/2^(4^n-1),{n,5}]

Large terms in continued fraction

From Ed Pegg Jr.
Jan 5, 2023:
"Values with "large" terms in the continued fraction, such as 20^(1/3) will cause ?(n) to have a large section of repeating 0's or 9's"

Clear[FormatDigitRuns]

FormatDigitRuns[x_,len_:5]:=Module[{digits,exp,blocks,groups},
{digits,exp}=RealDigits[x,10];
blocks=Split[Drop[digits,exp]];
groups=
Replace[blocks,l_List:>If[Length[l]<5,
FromDigits[l],
Underscript[
Underscript[Row[{l[[1]],"…",l[[1]]}],⏟],
Length[l]]],
{1}]//.
{a___,Longest[i:_Integer..],b___}:>{a,FromDigits[{i}],b};
Row[{FromDigits[Take[digits,exp]],".",Sequence@@groups}]
]

Feynman point:

FormatDigitRuns[N[Pi,770],5]

(Sqrt[3])

TextGrid[ReverseSortBy[Table[{n,Max[cf=ContinuedFraction[n^(1/3),10]],cf},{n,20}],#[[2]]&],Dividers->All]

ContinuedFraction[6^(1/3),10]

MinkowskiQuestionMark[N[6^(1/3),165]]//FormatDigitRuns

ContinuedFraction[20^(1/3),10]

MinkowskiQuestionMark[N[20^(1/3),60]]//FormatDigitRuns

π

ContinuedFraction[π,10]

MinkowskiQuestionMark[N[Pi,100]]//FormatDigitRuns