Kaprekar Routine

Author

Eric W. Weisstein
November 11, 2004

This notebook downloaded from http://mathworld.wolfram.com/notebooks/IntegerSequences/KaprekarRoutine.nb.

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

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

Code

Kaprekar[{n_,pad_},b_:10]:=Subtract@@(FromDigits[#,b]&/@Function[d,{Reverse[d],d}][Sort[IntegerDigits[n,b,pad]]])

Kaprekar[n_,b_:10]:=Subtract@@(FromDigits[#,b]&/@Function[d,{Reverse[d],d}][Sort[IntegerDigits[n,b]]])

KaprekarList[{n_,pad_},b_:10]:=NestWhileList[Kaprekar[{#,pad},b]&,n,UnsameQ,All]
KaprekarList[n_,b_:10]:=NestWhileList[Kaprekar[#,b]&,n,UnsameQ,All]

KaprekarRoutine[{n_,pad_},b_:10]:=NestWhile[Kaprekar[{#,pad},b]&,n,UnsameQ,All]
KaprekarRoutine[n_,b_:10]:=NestWhile[Kaprekar[#,b]&,n,UnsameQ,All]

Fixed Points

(period1=Position[Kaprekar[#]-#&/@Range[10^6],0,1]//Flatten)//Timing

(period2=Position[Kaprekar[Kaprekar[#]]-#&/@Range[10^6],0,1]//Flatten)//Timing

(period2=Position[Kaprekar[Kaprekar[#]]-#&/@Range[10^7],0,1]//Flatten)//Timing

Complement[period2,period1]

Complement[Union[KaprekarRoutine/@Range[10^6]],period1]//Timing

Base 10

KaprekarRoutine/@Range[110]

Plot

ListDensityPlot[Partition[Length[KaprekarList[{#,4}]]-1&/@Range[0,10^4],100],AspectRatio->Automatic,ColorFunction->(Hue[#]&),ImageSize->400,MeshRange->{{0,99},{0,99}}-.5,FrameLabel->TraditionalForm/@{Mod[n,100],Floor[n/100]}]//Timing

2-digit

kaprekar2=9+Position[KaprekarRoutine/@Range[10,99],0]//Flatten

Complement[Range[10,99],%]

KaprekarList[12]

3-digit

Union[KaprekarRoutine/@Range[100,999]]

kaprekar3=99+Position[KaprekarRoutine/@Range[100,999],0]//Flatten

Length[kaprekar3]

Union[Length/@KaprekarList/@Complement[Range[100,999],kaprekar3]]-1

4-digit

Union[KaprekarRoutine/@Range[1000,9999]]

kaprekar4=999+Position[KaprekarRoutine/@Range[1000,9999],0]//Flatten

Length[kaprekar4]

Union[Length/@KaprekarList/@Complement[Range[1000,9999],kaprekar4]]-1

5-digit

Union[Kaprekar/@Range[10000,99999]]

Union[Kaprekar/@Range[10000,99999,2]]

Union[Kaprekar/@Range[10001,99999,2]]

kaprekar5=9999+Position[Kaprekar/@Range[10000,99999],0]//Flatten

Length[kaprekar5]

Union[Length/@KaprekarList/@Complement[Range[10000,99999],kaprekar5]]-1