%I A003681 M0659
%S A003681 2,3,5,7,11,13,17,107,197,3293,74057,1124491,1225063003,48403915086083,
%T A003681 229199690093487791653,139394989871393443893426292667,2310767115930351361890156080500119173238113,
%U A003681 521722354210765171422123515738862106081757768167379798858040637
%N A003681 a(n) = min ( p +- q > 1 : pq = Product a(k), k = 1.. n-1).
%D A003681 J. H. Conway, personal communication.
%D A003681 N. J. A. Sloane and Simon Plouffe, The Encyclopedia of Integer Sequences, 
               Academic Press, 1995 (includes this sequence).
%e A003681 a(4) = 7 because 2*3*5 = 30 whose divisors are 1, 2, 3, 5, 6, 10, 15 
               and 30. The closest p and q are 5 and 6 but its difference is 1 so 
               the next closest p and q are 3 and 10 whose difference is 7.
%t A003681 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]
%t A003681 (* 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
%t A003681 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++ ]
%Y A003681 Cf. A082125.
%Y A003681 Sequence in context: A016114 A053434 A061166 this_sequence A029732 A037950 
               A105049
%Y A003681 Adjacent sequences: A003678 A003679 A003680 this_sequence A003682 A003683 
               A003684
%K A003681 nonn,hard,nice
%O A003681 1,1
%A A003681 N. J. A. Sloane (njas(AT)research.att.com), Mira Bernstein (mira(AT)math.berkeley.edu)
%E A003681 a(15) from Robert G. Wilson v, Feb 26 1996
%E A003681 a(16) from Naohiro Nomoto (6284968128(AT)geocities.co.jp), Jun 25 2001
%E A003681 a(17) from Robert G. Wilson v Sep 15 2006
%E A003681 a(18) from Robert G. Wilson v Jul 20 2009