|
%I #8 Apr 28 2016 12:40:45
%S 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,
%T 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,
%U 2,40,26,18,3,2,45,33,19,5,2,51,41,20,8,2,57
%N 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.
%C The partition graph G(n) is defined at A241150 as follows: the nodes are the partitions of n, and nodes p and q have an edge if one of them can be obtained from the other by a substitution x -> x-1,1 for some part x. Let R be the set of partitions (nodes) of n that contain a repeated part and let E be the set of edges of G(n) that have a node in R. Removing R and E from G(n) leaves a graph G'(n) whose nodes are the strict partitions of n, as in A000009. For n >= 5, G'(n) is disconnected.
%e The first 18 rows of T are represented here:
%e row 1: 1
%e row 2: 1
%e row 3: 2
%e row 4: 2
%e row 5: 2 1
%e row 6: 2 2
%e row 7: 3 2
%e row 8: 4 2
%e row 9: 5 2 1
%e row 10: 6 2 2
%e row 11: 7 3 2
%e row 12: 8 5 2
%e row 13: 9 7 2
%e row 14: 10 9 2 1
%e row 15: 12 11 2 2
%e row 16: 15 12 3 2
%e row 17: 18 13 5 2
%e row 18: 22 14 8 2
%e 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.
%t (* The first program generates terms of A241900 and A241901. *)
%t 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]}];
%t 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 *)
%t Map[#[[1]] &, subGLengths] (* A241901, _Peter J. C. Moses_, Apr 30 2014 *)
%t (* The next program shows the graph G'(z) for user-chosen z. *)
%t 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 *)
%Y Cf. A241901, A241150, A000041, A000009.
%K nonn,easy,tabf
%O 1,3
%A _Clark Kimberling_, May 01 2014
|
