A241900 Irregular triangular array: T(n,k) = number of partitions (nodes) in the k-th component of the graph G'(n) obtained from the partition graph G(n) by deleting all partitions having repeated parts; G and G' are defined in Comments.
1, 1, 2, 2, 2, 1, 2, 2, 3, 2, 4, 2, 5, 2, 1, 6, 2, 2, 7, 3, 2, 8, 5, 2, 9, 7, 2, 10, 9, 2, 1, 12, 11, 2, 2, 15, 12, 3, 2, 18, 13, 5, 2, 22, 14, 8, 2, 26, 15, 11, 2, 30, 16, 15, 2, 1, 35, 20, 17, 2, 2, 40, 26, 18, 3, 2, 45, 33, 19, 5, 2, 51, 41, 20, 8, 2, 57
Offset: 1
Examples
The first 18 rows of T are represented here: row 1: 1 row 2: 1 row 3: 2 row 4: 2 row 5: 2 1 row 6: 2 2 row 7: 3 2 row 8: 4 2 row 9: 5 2 1 row 10: 6 2 2 row 11: 7 3 2 row 12: 8 5 2 row 13: 9 7 2 row 14: 10 9 2 1 row 15: 12 11 2 2 row 16: 15 12 3 2 row 17: 18 13 5 2 row 18: 22 14 8 2 The 10 nodes and 7 edges of G'(10) are shown here: [10] - [9,1], [8,2] - [7,2,1], [7,3] - [6,3,1], [7,3] - [7,2,1], [6,4] - [5,4,1], [6,4] - [6,3,1], [5,3,2] - [4,3,2,1]; the three components are as follows: [8,2] - [7,2,1] - [7,3] - [6,3,1] - [6,4] - [5,4,1] (6 nodes); [4,3,2,1] - [5,3,2] (2 nodes); [9,1] - [10]] (2 nodes). Thus, row 10 of the array is 6 2 2.
Programs
-
Mathematica
(* The first program generates terms of A241900 and A241901. *) z = 30; spawn[part_] := Map[Reverse[Sort[Flatten[ReplacePart[part, {# - 1, 1}, Position[part, #, 1, 1][[1]][[1]]]]]] &, DeleteCases[DeleteDuplicates[part], 1]]; findComponent[start_] := Reap[BreadthFirstScan[g, start, {"DiscoverVertex" -> ((PropertyValue[{g, #1}, "Visited"] = True; Sow[#1]) &)}]][[2, 1]]; subGLengths = Join[{{1}}, Table[parts = Select[IntegerPartitions[k], DeleteDuplicates[#] == # &]; graph = Flatten[Table[part = parts[[n]]; Map[{part, #} &, Select[spawn[part], DeleteDuplicates[#] == # &]], {n, 1, Length[parts]}], 1]; isolated = Map[{#, #} &, Map[#[[1]] &, Cases[Map[{#, MemberQ[Flatten[graph, 1], #]} &, parts], {{_}, False}]]]; graph = Join[graph, isolated]; {graph, isolated} = Map[Map[FromDigits[#[[1]]] <-> FromDigits[#[[2]]] &, #] &, {graph, isolated}]; g = Graph[graph]; Do[PropertyValue[{g, v}, "Visited"] = False, {v, VertexList[g]}]; vlists = Reap[Do[If[! PropertyValue[{g, start}, "Visited"], Sow[findComponent[start]]], {start, VertexList[g]}]][[2, 1]]; Reverse[Sort[Map[Length, vlists]]], {k, 2, z}]]; Flatten[%] (* A241900 *) Map[#[[1]] &, subGLengths] (* A241901, Peter J. C. Moses, Apr 30 2014 *) (* The next program shows the graph G'(z) for user-chosen z. *) z = 18; spawn[part_] := Map[Reverse[Sort[Flatten[ReplacePart[part, {# - 1, 1}, Position[part, #, 1, 1][[1]][[1]]]]]] &, DeleteCases[DeleteDuplicates[part], 1]]; findComponent[start_] := Reap[BreadthFirstScan[g, start, {"DiscoverVertex" -> ((PropertyValue[{g, #1}, "Visited"] = True; Sow[#1]) &)}]][[2, 1]]; parts = Select[IntegerPartitions[z], DeleteDuplicates[#] == # &]; graph = Flatten[Table[part = parts[[n]]; Map[{part, #} &, Select[spawn[part], DeleteDuplicates[#] == # &]], {n, 1, Length[parts]}], 1]; isolated = Map[{#, #} &, Map[#[[1]] &, Cases[Map[{#, MemberQ[Flatten[graph, 1], #]} &, parts], {{_}, False}]]]; graph = Join[graph, isolated]; graph = Map[FromDigits[#[[1]]] <-> FromDigits[#[[2]]] &, graph]; isolated = Map[FromDigits[#[[1]]] <-> FromDigits[#[[2]]] &, isolated]; g = Graph[graph, VertexLabels -> "Name", ImageSize -> 500, ImagePadding -> 20, If[Length[isolated] > 0, Apply[EdgeStyle -> {# -> White} &, isolated], EdgeStyle -> "Default"], GraphLayout -> "SpringElectricalEmbedding"] (* Peter J. C. Moses, Apr 30 2014 *)
Comments