Keith Number

Author

Eric W. Weisstein
August 26, 2009

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

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

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

Additional Authors

Knapsack search code by
Daniel Lichtblau
IMS2004

Reverse Keith number search by
Anton Vrba
antonvrba@yahoo.com
Dec 28, 2006

Initialization

KeithNumberQ[n_Integer?Positive]:=(Last[KeithSequence[n]]==n)
KeithSequence[n_Integer?Positive]:=Module[{d=IntegerDigits[n],l},l=Length[d];
NestWhile[Append[#,Total[Take[#,-l]]]&,d,#[[-1]]<n&]]

Reversal[n_Integer,b_:10]:=FromDigits[Reverse[IntegerDigits[n,b]],b]
ReverseKeithNumberQ[n_Integer?Positive]:=(Reversal[Last[ReverseKeithSequence[n]]]==n)
ReverseKeithSequence[n_Integer?Positive]:=Module[{d=IntegerDigits[n],l},l=Length[d];
NestWhile[Append[#,Plus@@Take[#,-l]]&,d,#[[-1]]<Reversal[n]&]]

Keith Number

Select[Range[10,10^5],KeithNumberQ]//Timing

30- and 31-digit numbers from
Daniel Lichtblau
Tue, 23 Jun 2009 09:10:18

32- through 34- digits numbers from
Daniel Lichtblau
Aug 25, 2009
Some appear to be wrong

Length[keith={14,19,28,47,61,75,197,742,1104,1537,2208,2580,3684,4788,7385,7647,7909,31331,34285,34348,55604,62662,86935,93993,120284,129106,147640,156146,174680,183186,298320,355419,694280,925993,1084051,7913837,11436171,33445755,44121607,129572008,251133297,24769286411,96189170155,171570159070,202366307758,239143607789,296658839738,1934197506555,8756963649152,43520999798747,74596893730427,97295849958669,120984833091531,270585509032586,754788753590897,3621344088074041,3756915124022254,4362827422508274,11812665388886672,14508137312404344,16402582054271374,69953250322018194,73583709853303061,119115440241433462,166308721919462318,301273478581322148,1362353777290081176,3389041747878384662,5710594497265802190,5776750370944624064,6195637556095764016,12763314479461384279,27847652577905793413,45419266414495601903,855191324330802397989,7657230882259548723593,26842994422637112523337,36899277593852609997403,61333853602129819189668,229146413136585558461227,9838678687915198599200604,18354972585225358067718266,19876234926457288511947945,98938191214220718050301312,153669354455482560987178342,154677881401007799974564336,133118411174059688391045955,154140275428339949899922650,295768237361291708645227474,956633720464114515890318410,988242310393860390066911414,9493976840390265868522067200,41796205765147426974704791528,70267375510207885242218837404,
(* 30 digits *)
127304146123884420932123248317,389939548933846065763772833753,344669719564188054170496150677,756672276587447504826932994366,534139807526361917710268232010,
(* 31 digits *)
1598187483427964679092074853838,2405620130870553672640058975437,
(* 32 *)
41030306579725050560909919549414,47824404246899742508216679149392,42983394195992223818343905028410,89980815134051887612993101615858,
(* 33 *)
172451142646837728336412943204299,193962639439026709638083447831059,381933008901296879565658130750756,359253598248137147666007355623218,303294117104027490007126494842828,312736110821858321305917486145434,
(* 34 *)
1876178467884883559985053635963437,2787674840304510129398176411111966,5752090994058710841670361653731519
}]

KeithNumberQ/@keith//Union

s=({First[#],Length[#]}&/@Split[Length/@IntegerDigits/@keith]);
c=Complement[Range[Max[#]],#]&[First/@s];
counts=Last/@Sort[Join[s,{#,0}&/@c]]

Primes

Select[keith,PrimeQ]

Search Code

From Dan Lichtblau's 2004 IMS talk

keithEquations[len_Integer /; len > 0] := Module[
{rmat, res = list[], vecs},
rmat = Table[If[j == k - 1, 1, 0], {j, len - 1}, {k, len}];
rmat = Append[rmat, Table[1, {len}]];
mat = rmat;
While[9*Apply[Plus, mat[[len]]] < 10^(len - 1),
mat = mat.rmat];
While[mat[[len, 1]] <= 10^(len - 1),
res = list[res, Last[mat]];
mat = mat.rmat];
vecs = Apply[List, Flatten[res, Infinity, list]];
vecs = Map[(# - 10^Range[len - 1, 0, -1]) &, vecs];
vecs
]

Needs["LinearAlgebra`MatrixManipulation`"]

integerLinearSolve[mat_?MatrixQ,rhs_?VectorQ]/;Length[rhs]==Length[mat]:=
Module[{newmat,hnf,j=1,len=Length[mat],zeros,solvec,nullvecs},
newmat=Prepend[Transpose[mat],rhs];
newmat=AppendRows[newmat,IdentityMatrix[Length[newmat]]];
hnf=Last[Developer`HermiteNormalForm[newmat]];
zeros=Table[0,{len}];
While[j<=Length[hnf]&&Take[hnf[[j]],len]=!=zeros,j++];
solvec=Drop[hnf[[j]],len+1]/-hnf[[j,len+1]];
nullvecs=LatticeReduce[Map[Drop[#,len+1]&,Drop[hnf,j]]];
nullvecs]

keithVector[nulls_] := Module[
{len = Length[nulls], vars, x, vecs, constraints, program, min, vals},
vars = Array[x, len];
vecs = vars.nulls;
constraints =
Join[{Element[vars, Integers], 1 <= First[vecs] <= 9},
Map[0 <= # <= 9 &, Rest[vecs]]];
program = {1, constraints};
{min, vals} = NMinimize[program, vars, MaxIterations -> 200];
{vals, vecs /. vals}
]

18

(k=Last/@(keithVector[integerLinearSolve[{#},{0}]]&/@keithEquations[18]))//Timing

19

(k=Last/@(keithVector[integerLinearSolve[{#},{0}]]&/@keithEquations[19]))//Timing

20

v5.2

Length[keith20=keithEquations[20]]

(soln=Last/@(keithVector[integerLinearSolve[{#},{0}]]&/@keith20))//Timing

Timing[keithVector[integerLinearSolve[{keith20[[3]]},{0}]]]

FromDigits[%6[[-1,-1]]]

KeithNumberQ[%]

v6

Timing[keithVector[integerLinearSolve[{keithEquations[20][[3]]},{0}]]]

...bad...

Reverse Keith Number

ReverseKeithSequence[341]

ReverseKeithNumberQ[341]

Select[Range[10,10^5],ReverseKeithNumberQ]//Timing

And@@ReverseKeithNumberQ/@(rkn={12,24,36,48,52,71,341,682,1285,5532,8166,17593,28421,74733,90711,759664,901921,1593583,4808691,6615651,6738984,8366363,8422611,26435142,54734431,57133931,79112422,351247542,428899438,489044741,578989902,3207761244,4156222103,5426705064,5785766973,6336657062,48980740972,51149725354,83626284302,94183600081,98665175305,1935391095868,6002181268035,6334708806271,12348924235856,27488180694681,76365591939888,309217509306732,352062080376812,714692062325732,723735537269331,2437358882180001,6792079280704301,62244424802562056,203414193894268461,217049132946408803,415499563488189604,561624665953167171})

Select[rkn,PrimeQ]

Search

From Anton Vrba
antonvrba@yahoo.com
Dec 28, 2006

For[j=1,j≤35,j++,{
k=rkn[[j]],
x=IntegerDigits[k],
l=Length[x],
i=1,r=0,z=0,
While[r≠k,{
x=Append[x,r=(∑_(z=i)^(i+l-1))x[[z]]],i++,r=FromDigits[Reverse[IntegerDigits[r]]],
If[r>k,z++],
If[z==5,Break[]],
}],
Print[k,If[r-k==0," is a"," is NOT a"]," reverse Kieth number"]
}]