A334238 Rows n in A334184 that are not unimodal.

57, 63, 171, 258, 266, 294, 301, 329, 342, 343, 354, 361, 377, 378, 379, 381, 387, 399, 423, 437, 441, 462, 463, 469, 474, 481, 483, 489, 506, 513, 529, 567, 603, 621, 642, 643, 689, 798, 817, 889, 903, 931, 978, 1026, 1083, 1141, 1143, 1161, 1169, 1197, 1204

Offset: 1

Author

Michael De Vlieger, Peter Kagey, Antti Karttunen, Apr 19 2020

Keywords

• nonn

Comments

Consider the mappings k -> (k - (k/p)), across primes p | k. a(n) = rank levels of antichains in the poset resulting from taking distinct terms generated by the mapping and preserving the order of their generation.

We deem a series of rank levels, such as those of n = 15, i.e., row 15 of A334184 = [1, 2, 3, 2, 1, 1], as unimodal, as the terms increase to a point, then decrease.

Early terms may suggest that 2^i +/- 1 appear often in a(n). Given 10000 terms, the only such instances are {63, 513, 2047, 16383} for i = {6, 9, 11, 14}.

a(n) for 1 <= n <= 710 are bimodal. Are there rows n > 710 in A334184 that increase and decrease more than twice?

Examples

			Example: n = 57 is the smallest number for which rank levels of antichains is not unimodal, under the poset formed from distinct terms resulting from the mapping f(n) := n -> n - n/p across primes p | n.
    Hasse diagram     Row 57 of A334184
    -------------     -----------------
        57            1
        | \
        |  \
        54  38        2
        | \/  \
        | /\   \
        36  27  19    3
        | \ |  /
        |  \| /
       24   18        2
       /|  /|
      / | / |
    16  12  9         3
     | /|  /
     |/ |_/
     8  6             2
     | /|
     |/ |
     4  3             2
     | /
     |/
     2                1
     |
     |
     1                1
		

Links

• Peter Kagey, Table of n, a(n) for n = 1..10000
• Michael De Vlieger Hasse diagrams of the 24 least terms of this sequence.

Crossrefs

Cf. A334184.

Programs

Mathematica

Select[Range[2, 600], Function[k, Which[IntegerQ@ Log2@ k, False, And[PrimeQ@ k, IntegerQ@ Log2[k - 1]], False, True, ! AllTrue[Drop[#,  FirstPosition[#, _?(# < 0 &)][[1]] - 1 ], # <= 0 &] &@ Sign@ Differences@ Map[Length@ Union@ # &, Transpose@ If[k == 1, {{1}}, NestWhile[If[Length[#] == 0, Map[{k, #} &, # - # /FactorInteger[#][[All, 1]] ], Union[Join @@  Map[Function[{w, n}, Map[Append[w, If[n == 0, 0, n - n/#]] &, FactorInteger[n][[All, 1]] ]] @@ {#, Last@ #} &, #]] ] &, k, If[ListQ[#], AllTrue[#, Last[#] > 1 &], # > 1] &]]]]]]