# Drawing the schematic diagram of algorithm

The B-Spline function used the alogrithm as shown below: I would like to draw it in Mathematica (Although this is my first time to use TreePlot)

 TreePlot[
{1 -> 2, 1 -> 3, 2 -> 4, 2 -> 5, 3 -> 5, 3 -> 6, 4 -> 7, 4 -> 8, 5 -> 8, 5 -> 9,
6 -> 9, 6 -> 10}, Right, VertexLabeling -> True,
EdgeRenderingFunction -> (Arrow[#1, 0.1] &)] ### Question:

1.Is it possible to use some option to replace the tags like "1","2"... to the $N_{0,3},N_{0,2}...$? 2.How to make the treeplot looks symmetrically?

Update: functions to generate the edge list, indices and labels:

ClearAll[layersF, edgesF, subscF, indicesF];

layersF = Module[{k = 1}, Table[k++, {i, #}, {j, i}]] &;
Partition[layersF[#], 2, 1], 2] &;
indicesF = Reverse[Thread /@ Thread[{Reverse@Range[0, Range[0, # - 1]], Range[0, # - 1]}]] &;
subscF = Style[Subscript[N, ## & @@ ##], 16, "Panel", Background -> None] & /@ # &;
labelF = Flatten[subscF /@ indicesF[#]] &;


Examples:

edgesF@4


{1 -> 2, 1 -> 3, 2 -> 4, 2 -> 5, 3 -> 5, 3 -> 6, 4 -> 7, 4 -> 8, 5 -> 8, 5 -> 9, 6 -> 9, 6 -> 10}

vlabels = labelF@4


$\left\{N_{0,3},N_{0,2},N_{1,2},N_{0,1},N_{1,1},N_{2,1},N_{0,0},N_{1,0},N_{2,0},N_{3, 0}\right\}$

el = edgesF@4;
vl = Flatten[layersF@4];
lbls = labelF@4;
vlabels = Thread[vl -> (Placed[#, Center] & /@ lbls)];
options = {VertexShapeFunction -> "Square", VertexSize -> {0.25, 0.25}, ImagePadding -> 20,
VertexStyle -> Hue[0.125, 0.7, 0.9], ImageSize -> 400, BaseStyle -> Arrowheads[Large]};


By reversing the VertexList and the setting of "VertexPartition" suboption (credit: @MichaelE2) we can change orientation of the graph without the need for Rotation:

Graph[Reverse@vl, el, options, VertexLabels -> vlabels,
GraphLayout -> {"MultipartiteEmbedding", "VertexPartition" -> Reverse[Range]}] Update 2: functions to generate vertex coordinates

Although we can easily get Left and Right orientations easily using "MultipartiteEmbedding", a function to generate similar vertex coordinates may be useful to get all four orientations. Such a function would also be useful for TreePlot and GraphPlot that do not provide similar layouts.

The following two functions both take an integer (representing the number of layers) as input:

 vcoordsF = {1, .5} # & /@ SparseArray[
CellularAutomaton[{Unitize[#[] + #[]] &, {}, 1},{{1}, 0}, #-1]]["NonzeroPositions"] &;


or

vcoordsF2 = With[{n = #-1}, Reverse@Flatten[Thread /@
({#, Range[2 n + 1][[# ;; -# ;; 2]]} & /@ Range[n + 1]), 1]] &;


Examples:

gF1 = Graph[edgesF@#, ImageSize -> #2, options,
VertexLabels -> Thread[Range@(# (# + 1)/2) -> (Placed[#, Center] & /@ (labelF@#))],
VertexCoordinates -> (-vcoordsF[#])] &;

Row[gF1 @@ # & /@ {{3, 250}, {5, 400}, {6, 500}}] gF2 = Graph[edgesF@#, ImageSize -> #2, options,
VertexLabels -> Thread[Range@(# (# + 1)/2) -> (Placed[#, Center] & /@ (labelF@#))],
VertexCoordinates -> (Reverse /@ vcoordsF[#])] &;

Row[gF2 @@ # & /@ {{3, 250}, {5, 400}, {6, 500}}] Using with TreePlot (without subscripted labels)

TreePlot[edgesF@#, ImageSize -> #2, DirectedEdges -> True, VertexLabeling -> True,
VertexCoordinateRules -> (vcoordsF2[#])] & @@ # & /@
{{3, 250}, {5, 400}, {12, 500}} // Row Previous version

First, a helper function to get the subscript indices:

indicesF = Reverse[Thread /@ Inner[List, Reverse@Range[0, Range[0, #]], Range[0, #], List]] &;


And another to style and rotate indexed labels:

rssF = Rotate[Style[Subscript[N, #[], #[]], 16, "Panel", Background -> None], -Pi] &;

rlabels = Flatten[rss /@ # & /@ indicesF];
vlabels = Table[i -> Placed[rlabels[[i]], Center], {i, Length@labels}];


Use the "MultipartiteEmbedding" suboption of the option GraphLayout to get the vertex coordinates as desired:

edgelist = {1->2, 1->3, 2->4, 2->5, 3->5, 3->6, 4->7, 4->8, 5->8, 5->9, 6->9, 6->10};
Rotate[Graph[edgelist, VertexShapeFunction -> "Square", VertexStyle -> Hue[0.125, 0.7, 0.9],
VertexSize -> {.25, .25},  VertexLabels -> vlabels, ImagePadding -> 20,
GraphLayout -> {"MultipartiteEmbedding", "VertexPartition" -> {1, 2, 3, 4}}], Pi] • This answer is very closely to what I need, I think I could finish the subscript according to your solution :-) – xyz Oct 18 '14 at 10:44
• @ShutaoTang, updated with the subscript indices. – kglr Oct 18 '14 at 16:05
• So surprised！+2,,:-) – xyz Oct 20 '14 at 6:18
• @thank_you, thank you, thank you:) – kglr Feb 16 '17 at 18:11

## Creating the edge list

The index and edges can be worked out like this:

step[list_, n_] := Block[
{
ln1 = list[]
, ln2 = list[]
},
Join[
If[ln2 < n ,
{{ln1, ln2 + 1} -> {ln1, ln2}}, {}],
If[ln2 < n,
{{ln1, ln2 + 1} ->  {ln1 + 1, ln2  }}, {}],
If[ln1 + ln2 + 1 < n,
step[{ln1, ln2 + 1}, n], {}],
If[ln1 + ln2 + 1 < n,
step[{ln1 + 1, ln2}, n], {}]
]]

edgelist = DeleteDuplicates@step[{0, 0}, 3]

{{0, 1} -> {0, 0}, {0, 1} -> {1, 0}, {0, 2} -> {0, 1}, {0, 2} -> {1,    1}, {0, 3} -> {0, 2}, {0, 3} -> {1, 2}, {0, 4} -> {0, 3}, {0, 4} -> {1, 3}, {1, 3} -> {1, 2}, {1, 3} -> {2, 2}, {1, 2} -> {1, 1}, {1, 2} -> {2, 1}, {2, 2} -> {2, 1}, {2, 2} -> {3, 1}, {1, 1} -> {1, 0}, {1, 1} -> {2, 0}, {2, 1} -> {2, 0}, {2, 1} -> {3, 0}, {3, 1} -> {3, 0}, {3, 1} -> {4, 0}}


The main difference is that I'm using both indexes as vertex, and generating the graphs programatically by a recursion, allowing any arbitrary length, but unfortunately with duplicates.

## Visualizing the graph

Building up from @kguler i.e copying shamelessly

edgelist = DeleteDuplicates@step[{0, 0}, 4];
vl = VertexList@Graph@edgelist;

{{0, 1}, {0, 0}, {1, 0}, {0, 2}, {1, 1}, {0, 3}, {1, 2}, {0, 4}, {1, 3}, {2, 2}, {2, 1}, {3, 1}, {2, 0}, {3, 0}, {4, 0}}

labels = Style[Subscript[N, #[], #[]], 16, "Title", Background -> None] & /@ vl ;
vlabels = #1 -> Placed[#2, Center] & @@@ Transpose[{vl, labels}];
Graph[
edgelist
, VertexLabels -> vlabels
, VertexSize -> .5
, VertexCoordinates -> ({#2, -#1 - #2/2} & @@@ vl )
] Another difference is that I'm defining the VertexCoordinates explicitly based on the index.

A function to recursively generate the edges:

n[_, 0] := {};
n[x : 0, y_Integer] /; y > 0 :=
{{x, y} -> {x, y - 1}, {x, y} -> {x + 1, y - 1}, n[x + 1, y - 1], n[x, y - 1]};
n[x_Integer, y_Integer] /; y > 0 :=
{{x, y} -> {x, y - 1}, {x, y} -> {x + 1, y - 1}, n[x + 1, y - 1]};


We have to sort the vertices so that the "MultipartiteEmbedding" method can partition the vertices into groups with the right order.

With[{edges = Flatten@n[0, 3]},
Graph[
SortBy[VertexList@Graph@edges, Last],
edges,
VertexSize -> {0.22, 0.22},
VertexLabels -> (idx_ :> Placed[Subscript[N, Sequence @@ idx], Center]),
EdgeShapeFunction -> GraphElementData["FilledArrow", "ArrowSize" -> 0.04],
EdgeStyle -> Directive[Opacity, RGBColor[0.4, 0.4, 0.8]],
GraphLayout -> {"MultipartiteEmbedding", "VertexPartition" -> {4, 3, 2, 1}}]
] Update for V8

The setting "MultipartiteEmbedding" was introduced in V9. It seems to be simply ignored in V8. Also rendering is different. In V8, one can get the above result by explicitly computing the coordinates and using the default edge rendering. The height and width can be adjusted in the ncoords code by multiplying Range[0, y] by a number or adding a number other than 1 in First[#] + 1, respectively.

ncoords[x_Integer, y_Integer] :=
NestList[{First[#] + 1, MovingAverage[Last@#, 2]} &, {0, Range[0, y]}, y],
1];

With[{edges = Flatten@n[0, 3], coords = ncoords[0, 3]},
Graph[SortBy[VertexList@Graph@edges, Last], edges,
VertexSize -> {0.22, 0.22},
VertexLabels -> (idx_ :> Placed[Subscript[N, Sequence @@ idx], Center]),
EdgeStyle -> Directive[Opacity, RGBColor[0.4, 0.4, 0.8]],
VertexCoordinates -> coords]]

• Thanks a lot! BTW, why the graph that generated by your code in V8 is different from what you have given? – xyz Oct 19 '14 at 7:24
• @ShutaoTang The setting "MultipartiteEmbedding" was introduced in V9. I've updated my answer with a V8 solution. – Michael E2 Oct 19 '14 at 13:16
• @ShutaoTang You're welcome. :) – Michael E2 Oct 19 '14 at 14:05

Just use TreePlot with VertexCoordinateRules. I have tried like this.

treePlot[k_] := Module[{grp, pos},
grp = DeleteCases[Flatten@Table[
{n[j, i - j] -> n[j, i - 1 - j],
n[j, i - j] -> n[j + 1, i - 1 - j]},
{i, k}, {j, 0, i}], n[__] -> n[_, _?(# < 0 &)]];
pos = Flatten@Table[n[j, i - j] -> {(j + i)/3, i - j}, {i, 0, k}, {j, 0, i}];
TreePlot[grp, Right, n[0, k], ImageSize -> 70 k,
VertexLabeling -> True, VertexCoordinateRules -> pos,
EdgeRenderingFunction -> ({Arrowheads -> Small, Arrow[#, 0.3]} &)]
] /. n[a_, b_] -> Subscript[N, a, b]


Test

Manipulate[treePlot[k], {{k, 3}, 1, 10, 1},
ContentSize -> {300, 200}, SaveDefinitions -> True]
` 