Weird Number

Author

Eric W. Weisstein
December 6, 2013

This notebook downloaded from http://mathworld.wolfram.com/notebooks/NumberTheoreticFunctions/WeirdNumber.nb.

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

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

Properties

Not prime (since prime are not abundant)

Mod 6

Mod[{70,836,4030,5830,7192,7912,9272,10430,10570,10792,10990,11410,11690,12110,12530,12670,13370,13510,13790,13930,14770,15610,15890,16030,16310,16730,16870,17272,17570,17990,18410,18830,18970,19390,19670},6]

Enumeration

Knapsack

Select[Range[1000],AbundantQ[#]&&!PseudoperfectQ[#,Method->"Subsets"]&]//Timing

Select[Range[1000],WeirdQ]//Timing

(l1=Select[Range[1000],AbundantQ[#]&&!PseudoperfectQ[#,Method->"KnapsackThenSubsets"]&])//Timing

PseudoperfectQ[12,Method->"Knapsack",Debug->True]

PseudoperfectQ[70,Method->"Knapsack",Debug->True]

PseudoperfectQ[56,Method->"Subsets"]

Select[l1,!PseudoperfectQ[#]&]//Timing

Select[Range[10^3],WeirdQ[#,Method->"Subsets"]&]//Timing

Select[Range[10^3],WeirdQ[#,Method->"Knapsack"]&]//Timing

Select[Range[10^3],WeirdQ[#,Method->"KnapsackThenSubsets"]&]//Timing

Working

56

PseudoperfectQ[56,Method->"Knapsack",Debug->True]

solns={{-1,0,0,-1,1,0,0,0},{-1,1,0,1,-1,0,0,0},{-1,-1,1,1,-1,0,0,0},{-1,-1,-1,1,0,0,0,0},{1,0,0,-1,-1,1,0,0},{1,0,0,-1,-1,-1,1,0},{-1,0,0,1,1,1,1,0}};

solns2=Flatten[Table[Select[Plus@@@Subsets[Flatten[Outer[Times,{-1,1},solns,1],1],{n}],Union[#]=={0,1}&],{n,Length[solns]}],1]//Union

Divisors[56]

Divisors[56].#&/@solns2

PseudoperfectQ[56,Method->"Subsets",Debug->True]

88

PseudoperfectQ[88,Method->"Knapsack",Debug->True]

solns={{-2,1,0,0,0,0,0,0},{0,-2,1,0,0,0,0,0},{1,0,-1,-1,1,0,0,0},{0,0,-2,1,0,0,0,0},{1,0,-1,-1,-1,1,0,0},{1,0,-1,-1,-1,-1,1,0},{-1,0,1,1,1,1,1,0}};

solns2=Flatten[Table[Select[Plus@@@Subsets[Flatten[Outer[Times,{-1,1},solns,1],1],{n}],Union[#]=={0,1}&],{n,Length[solns];3}],1]//Union

Divisors[88]

Divisors[88].#&/@solns2

PseudoperfectQ[88,Method->"Subsets",Debug->True]

Knapsack Parallel

DistributeDefinitions[WeirdQ];

(10^4)

Parallelize[Select[Range[10^4],WeirdQ[#,Method->"Knapsack"]&]]//AbsoluteTiming

(10^5)

Parallelize[Select[Range[10^5],WeirdQ[#,Method->"Knapsack"]&]]//AbsoluteTiming

Eric

Iterating Pick over k-Subsets

$Version

Select[Range[1000],WeirdQ]//Timing

Select[Range[5000],WeirdQ]//Timing

Select[Range[10^4],WeirdQ]//Timing

Eric Parallel

DistributeDefinitions[WeirdQ];

(10^4)

Parallelize[Select[Range[10^4],WeirdQ],Method->Automatic]//AbsoluteTiming

Parallelize[Select[Range[10^4],WeirdQ],Method->"CoarsestGrained"]//AbsoluteTiming

Parallelize[Select[Range[10^4],WeirdQ],Method->"FinestGrained"]//AbsoluteTiming

(10^5)

DistributeDefinitions[WeirdQ];

Parallelize[Select[Range[10^5],WeirdQ]]//AbsoluteTiming

ParallelEvaluate[MaxMemoryUsed[]]/10^9.

Robert Wilson

NthSubset

http://oeis.org/A006037

<<Combinatorica`

fQ[n_]:=Block[{d,l,t,i},If[DivisorSigma[1,n]>2n&&Mod[n,6]≠0,d=Most[Divisors[n]];l=2^Length[d];
t=Table[NthSubset[j,d],{j,l-1}];
i=1;
While[i<l&&Total@t[[i]]≠n,i++]
];
If[i==l,True,False]
]

Select[Range[1000],fQ]//Timing

Check

l={70,836,4030,5830,7192,7912,9272,10430,10570,10792,10990,11410,11690,12110,12530,12670,13370,13510,13790,13930,14770,15610,15890,16030,16310,16730,16870,17272,17570,17990,18410,18830,18970,19390,19670,19810,20510,21490,21770,21910,22190,23170,23590,24290,24430,24710,25130,25690,26110,26530,26810,27230,27790,28070,28630,29330,29470,30170,30310,30730,31010,31430,31990,32270,32410,32690,33530,34090,34370,34930,35210,35630,36470,36610,37870,38290,38990,39410,39830,39970,40390,41090,41510,41930,42070,42490,42910,43190,43330,44170,44870,45010,45290,45356,45710,46130,46270,47110,47390,47810,48370,49070,49630,50330,50890,51310,51730,52010,52570,52990,53270,53830,54110,55090,55790,56630,56770,57470,57610,57890,58030,58730,59710,59990,60130,60410,61390,61670,61810,62090,63490,63770,64330,65030,65590,65870,66290,66710,67690,67970,68390,68810,69370,69790,70630,70910,71330,71470,72170,72310,72730,73430,73570,73616,74270,74410,74830,76090,76370,76510,76790,77210,77630,78190,78610,79030,80570,80710,81410,81970,82670,83090,83312,83510,84070,84910,85190,85610,86030,86170,86590,87430,88130,89390,89530,89810,90230,90370,90790,91070,91210,91388,91490,92330,92470,92890,95270,95690,96110,96670,97930,98630,99610,99890};

$Version

WeirdQ/@And@@l//Timing

Large weird numbers

Mersenne-Based

MersennePrimeIndices

With[{Q=2^89},LogPlot[(((2^k)Q-(Q+1))/((Q+1)-(2^k))),{k,1,88}]]

With[{Q=2^107},LogPlot[(((2^k)Q-(Q+1))/((Q+1)-(2^k))),{k,1,106}]]

Monitor[With[{Q=(2^(#))-1},Print[{p=#,(k=1;While[k<#&&!PrimeQ[R=(((2^k)Q-(Q+1))/((Q+1)-(2^k)))],k++];If[k==#,$Failed,k])//Timing,If[k==#,$Failed,(2^(k-1))Q R]}]]&/@MersennePrimeIndices[[2;;10]],{p,k}];

Monitor[With[{Q=(2^(#))-1},Print[{p=#,(k=1;While[k<#&&!PrimeQ[R=(((2^k)Q-(Q+1))/((Q+1)-(2^k)))],k++];If[k==#,$Failed,k])//Timing,If[k==#,$Failed,IntegerLength[(2^(k-1))Q R]]}]]&/@MersennePrimeIndices,{p,k}];

Kravitz

IntegerLength[w0=(2^56)((2^61)-1)153722867280912929]

N[w0]

Module[{Q=(2^61)-1,k=1},While[!PrimeQ[(((2^k)Q-(Q+1))/((Q+1)-(2^k)))],k++];k]

{Q,R}/.{ToRules[With[{QR=((2^61)-1)153722867280912929,k=57},Reduce[{(2^(k-1))QR==w0,R((Q+1)-(2^k))==(2^k)Q-(Q+1),Q>0,R>0},{Q,R},Integers]]]}//Timing

Solve[{153722867280912929==(((2^k)Q-(Q+1))/((Q+1)-(2^k))),k-1==56},{k,Q}]

Module[{Q=2305843009213693951,k=57,R},
R=(((2^k)Q-(Q+1))/((Q+1)-(2^k)));
{PrimeQ/@{Q,R},Q==((2^61)-1),R}
]

DivisorSigma[0,w0]

WeirdQ[w0,Method->"Knapsack"]//Timing

WeirdQ[w0,Method->"Subsets",Debug->True]//Timing

13044788022...

http://www.kimatv.com/news/local/CWU-math-students--234496131.html

IntegerLength[w1=1304478802221037336898806955880590950108213611184211428152436309358286058099789749839735498620012494920476023972998095015247872]

FactorInteger[w1,2]

FactorInteger[w1]//Timing

PrimeQ[QR=4019735659225424761035091426238014196110839229872028935946714452918000310318497967396934841937]

Reduce[{(2^(k-1))QR==w1,R((Q+1)-(2^k))==(2^k)Q-(Q+1),k-1==108},{k,Q,R},Integers]//Timing

Log2[QR]//Ceiling

Monitor[Do[If[IntegerQ[QR/(2^k-1)],Print[k]],{k,2,311}],k]

...so not based on a Mersenne prime...

WeirdQ[w1,Debug->True]

70*149^200

http://www.kimatv.com/news/local/CWU-math-students--234496131.html

Not of the expected form; probably bogus (or something missing)

IntegerLength[w2=70*149^200]

FactorInteger[w2]

Length[Divisors[w2]]

IntegerLength/@(d=Rest[Divisors[w2]])//Union

Total[d]>w2

Total[Drop[d,-1]]>w2

Total[Drop[d,-2]]>w2

WeirdQ[w2,Method->"Knapsack"]//Timing

Knapsack didn’t find a pseudoperfet subset, so w2 could be, but is not necessarily, weird

WeirdQ[w2,Method->"Subsets",Debug->True]//Timing