Anomalous Cancellation

Author

Eric W. Weisstein
October 16, 2015

This notebook downloaded from http://mathworld.wolfram.com/notebooks/Arithmetic/AnomalousCancellation.nb.

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

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

Code

Clear[AnomalouslyCancelQ]

AnomalouslyCancelQ[{n_,n_},b_:10]:=False
AnomalouslyCancelQ[{n_,1},b_:10]:=False
AnomalouslyCancelQ[frac:{n_,d_},b_:10]:=Module[{digcounts=Transpose[DigitCount[#,b,Range[b-1]]&/@frac],deldig,res},

deldig=Flatten[Position[digcounts,_?(Max[#]>0&&Equal@@#&),1]];

If[deldig==={},False,

res={frac,FromDigits[DeleteCases[IntegerDigits[#,b],Alternatives@@deldig],b]&/@frac};
If[res[[2,2]]===0 (* after deletion, denominator is 0 *),False,Equal@@Divide@@@res]
]
]

If there are three 6's the numerator and two in the denominator, then two need to be deleted from the numerator, but which two?  Because of this ambiguity, do not consider these cases.

Checks

Table[{{n,d},AnomalouslyCancelQ[{n,d}]},{n,10},{d,3}]

Cases[Flatten[Table[{{n,d},Check[AnomalouslyCancelQ[{n,d}],"message"]},{n,99},{d,99}],1],{f_,"message"}:>f]

2-Digit in Different Bases

Using AnomalouslyCancelQ (slow)

TwoDigitInstances[b_]:=Cases[Flatten[Table[{BaseForm[#,b]&/@{n,d},AnomalouslyCancelQ[{n,d},b]},{n,b,b^2-1},{d,n+1,b^2-1}],1],{f_,True}:>f]

data=Monitor[Table[{b,Length[ins=TwoDigitInstances[b]],ins},{b,20}],b];//Timing

Grid[data,Alignment->{{Decimal,Decimal,Left},Automatic},Dividers->All]

data[[All,2]]

DeleteCases[%,0]

Reduce

Monitor[Table[If[Head[#]===Or,Length[#],1]&@Reduce[(x b+y)z==y(z b+x)&&0<x<b&&0<z<y<b,{x,y,z},Integers,Backsubstitution->True],{b,Select[Range[100],CompositeQ]}],b]//Timing

Digit enumeration (fast)

With[{b=4},Cases[Flatten[Table[{{x,y,z},(x b+y)/(z b+x)==y/z},{x,b},{y,b},{z,y-1}],2],{f_,True}:>f]]

With[{b=6},Cases[Flatten[Table[{{x,y,z},(x b+y)/(z b+x)==y/z},{x,b},{y,b},{z,y-1}],2],{f_,True}:>f]]

(data=Table[Count[Flatten[Table[(x b+y)z==y(z b+x),{x,b},{y,b},{z,y-1}],2],True],{b,Select[Range[115],CompositeQ]}])//Timing

Length[data]

A259981

Length[oeis={1,2,2,2,4,4,2,6,7,4,4,10,6,6,6,4,6,10,6,4,8,6,6,21,2,6,18,6,4,18,10,8,10,10,12,12,6,16,22,14,6,10,2,12,21,12,20,4,10,22,10,2,12,20,14,24,8,24,8,10,28,6,6,18,10,28,16,10,6,6,30,4,24,37,6,6,46,14,10,6,18,24,6,18}]

data==oeis

Base-10

1-digit

Cases[Flatten[Table[{{n,d},AnomalouslyCancelQ[{n,d}]},{n,2,9},{d,n+1,9}],1],{f_,True}:>f]//Timing

Length[%[[2]]]

2-digit

(anom2=Cases[Flatten[Table[{{n,d},AnomalouslyCancelQ[{n,d}]},{n,10,99},{d,n+1,99}],1],{f_,True}:>f])//Timing

Divide@@@Map[HoldForm,anom2,{2}]

Length[%]

2 or fewer digits

(anom2=Cases[Flatten[Table[{{n,d},AnomalouslyCancelQ[{n,d}]},{n,1,9},{d,n+1,99}],1],{f_/;Max[IntegerLength/@f]==2,True}:>f])//Timing

4+0

3-digit

(anom3=Cases[Flatten[Monitor[Table[{{n,d},AnomalouslyCancelQ[{n,d}]},{n,100,999},{d,n+1,999}],Row[{n,"/",d}]],1],{f_,True}:>f])//Timing

Divide@@@Map[HoldForm,anom3,{2}]

Length[%]

{106/265,10/25}

{116/464,11/44}

{124/217,4/7}

{792/891,72/81}

3 or fewer digits

(anom=Cases[Flatten[Monitor[Table[{{n,d},AnomalouslyCancelQ[{n,d}]},{n,1,99},{d,n+1,999}],Row[{n,"/",d}]],1],{f_/;Max[IntegerLength/@f]==3,True}:>f])//Timing

Divide@@@Map[HoldForm,anom,{2}]

Length[%]

161+4+25

(anom=Cases[Flatten[Monitor[Table[{{n,d},AnomalouslyCancelQ[{n,d}]},{n,1,999},{d,n+1,999}],Row[{n,"/",d}]],1],{f_,True}:>f])//Timing

Length[%]

4-digit

(anom4=Cases[Flatten[Monitor[Table[{{n,d},AnomalouslyCancelQ[{n,d}]},{n,1000,9999},{d,n+1,9999}],Row[{n,"/",d}]],1],{f_,True}:>f])//Timing

Divide@@@Map[HoldForm,anom4,{2}]

Length[%]

4 or fewer digits

(anom=Cases[Flatten[Monitor[Table[{{n,d},AnomalouslyCancelQ[{n,d}]},{n,1,999},{d,n+1,9999}],Row[{n,"/",d}]],1],{f_/;Max[IntegerLength/@f]==4,True}:>f])//Timing

Divide@@@Map[HoldForm,anom,{2}]

Length[%]

1851+161+4+25

(anom=Cases[Flatten[Monitor[Table[{{n,d},AnomalouslyCancelQ[{n,d}]},{n,1,9999},{d,n+1,9999}],Row[{n,"/",d}]],1],{f_,True}:>f])//Timing

Length[anom]