|
MATHEMATICA
|
f[n_List] := (a = n; p = Apply[Times, a]; d = Divisors[p]; l = Length[d]; If[l > 2, If[ EvenQ[l], d = Take[d, {l/2 - 1, l/2 + 2 } ]; l = 4, d = Take[d, {l/2 - 0.5, l/2 + 1.5}]; l = 3]]; Switch[l, 2, If[d[[2]] - d[[1]] == 1, AppendTo[a, d[[1]] + d[[2]]], AppendTo[a, d[[2]] - d[[1]]]], 3, AppendTo[a, d[[3]] - d[[1]]], 4, If[d[[3]] - d[[2]] == 1, AppendTo[a, d[[4]] - d[[1]]], AppendTo[a, d[[3]] - d[[2]]]]]; Return[a]); Nest[f, {2}, 15]
(* first do *) Needs["DiscreteMath`Combinatorica`"] (* then *) f[s_List] := Block[{prod = Times @@ s, fwr = Table[ #[[1]], {#[[2]]}] & /@ FactorInteger[Times @@ s] // Flatten, diffmin = Infinity, adiff, p}, len = 2^Length@fwr; Do[p = Times @@ NthSubset[i, fwr]; adiff = Min@Select[{Abs[prod/p - p], Abs[prod/p + p]}, # > 1 &]; If[adiff < diffmin, diffmin = adiff], {i, 2^len}]; Append[s, diffmin]]; Nest[f, {}, 17] - from Robert G. Wilson v Sep 15 2006
for a(18) Needs["Combinatorica`"]; p = Product(k=1..17, a(k) ); t = Transpose[ FactorInteger@ p][[1]]; d = Infinity; k = 1; While[k < 2^32, b = Times @@ NthSubset[k, t]; c = Abs[a/b - b]; If[c < d, d = c; Print[{k, c}]]; k++ ]
|
