Binary Tree

Author

Eric W. Weisstein
May 27, 2004

This notebook downloaded from http://mathworld.wolfram.com/notebooks/GraphTheory/BinaryTree.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/BinaryTree.html.

©2005 Wolfram Research, Inc. except for portions noted otherwise

Counts

RSolve[{a[n+1]==a[n]^2+a[n]+a[n]Sqrt[4a[n]-3],a[0]==1},a[n],n]

a[1]:=1
a[n_]:=a[n]=a[n-1]^2+a[n-1]+a[n-1]Sqrt[4a[n-1]-3]

a/@Range[6]

Enumeration

Dumb Version

BinarySequence[n_]:=BinarySequence[n]=Rest[Flatten[Outer[List,Sequence@@Table[{0,1},{2^(n-1)}]],2^(n-1)-1]]
BinaryTreeCandidates[n_]:=Flatten[Outer[List,Sequence@@(BinarySequence/@Range[n]),1],n-1]
PadTree[l_]:=Module[{n=Length[l]},
Flatten/@Table[l[[i,j]],{i,n},{j,2^(i-1)},{2^(n-i)}]
]
BinaryTrees[n_]:=Select[BinaryTreeCandidates[n],FreeQ[Transpose[PadTree[#]],{__,0,1,___}]&]

ColumnForm[#,Center]&/@(b1=BinaryTreeCandidates[3])

ColumnForm[#,Center]&/@(b2=BinaryTrees[3])

ColumnForm[#,Center]&/@Complement[b1,b2]

Length/@BinaryTrees/@Range[4]//Timing

MaxMemoryUsed[]/1024.^2 Megabyte

Length/@BinaryTrees/@Range[5]//Timing

Smart Version

BinarySequence[n_]:=BinarySequence[n]=Rest[Flatten[Outer[List,Sequence@@Table[{0,1},{2^(n-1)}]],2^(n-1)-1]]
BinaryTreeCandidates[n_]:=Flatten[Outer[Append,BinaryTrees[n-1],BinarySequence[n],1],1]
PadTree[l_]:=Module[{n=Length[l]},
Flatten/@Table[l[[i,j]],{i,n},{j,2^(i-1)},{2^(n-i)}]
]
BinaryTrees[1]:={{{1}}}
BinaryTrees[n_]:=BinaryTrees[n]=Select[BinaryTreeCandidates[n],FreeQ[Transpose[PadTree[#]],{__,0,1,___}]&]

Length/@BinaryTrees/@Range[4]//Timing

MaxMemoryUsed[]/1024.^2 Megabyte

BinaryTrees[2]

Length/@BinaryTrees/@Range[5]//Timing

Graphic

<<Graphics`Colors`

pos[{i_,1}]:={0,0}
pos[{i_,2}]:={2i-3,-1}
pos[{i_,3}]:={If[i<3,-1+.5(2i-3),1+.5(2i-7)],-2}

BinaryTreePlot[t_]:=Module[{p=Position[t,1]},
{
Line[{pos[Reverse[#]],pos[{Quotient[1+#[[2]],2],#[[1]]-1}]}]&/@Rest[p],
{Red,AbsolutePointSize[5],Point[pos[Reverse[#]]]&/@p}
}
]

Show[GraphicsArray[
Flatten[Partition[#,7,7,{1,1},{}]&/@
Map[Graphics[BinaryTreePlot[#],PlotRange->{{-1,1}2,{.2,-Length[#]}}]&,BinaryTrees/@Range[3],{2}],
1]
]]

BinaryTreeGraph[t_]:=Module[{p=Position[t,1],v},
v=pos[Reverse[#]]&/@p;
Graph[
List/@({pos[Reverse[#]],pos[{Quotient[1+#[[2]],2],#[[1]]-1}]}&/@Rest[p]/.Thread[v->Range[Length[v]]]),List/@v
]
]

ShowGraphArray[Flatten[
Partition[#,7,7,{1,1},{}]&/@Map[BinaryTreeGraph,BinaryTrees/@Range[3],{2}],1],
VertexStyle->Disk[.15]
]

Nodes

binarytrees=Map[BinaryTreeGraph,BinaryTrees/@Range[4],{2}];

Length/@Split[Sort[Flatten[Map[V,binarytrees,{2}]]]]

<<NumberTheory`NumberTheoryFunctions`

CatalanNumber[Range[10]]

Length/@Split[Sort[Flatten[binarytrees],V[#1]<V[#2]&],V[#1]==V[#2]&]

Length/@Split[Sort[Flatten[BinaryTrees/@Range[4],1],Count[#1,1,{2}]<Count[#2,1,{2}]&],Count[#1,1,{2}]==Count[#2,1,{2}]&]

Show[GraphicsArray[
Map[Graphics[BinaryTreePlot[#],PlotRange->{{-1,1}2,{.5,-Length[#]}}]&,
Take[Split[Sort[Flatten[BinaryTrees/@Range[3],1],Count[#1,1,{2}]<Count[#2,1,{2}]&],Count[#1,1,{2}]==Count[#2,1,{2}]&],4],
{2}]
]]

Heights

Height[g_Graph]:=Max[Distances[g,1]]

Union/@Map[Height,binarytrees,{2}]

Length/@Split[Sort[Flatten[Map[Height,binarytrees,{2}]]]]

This is supposed to be 1, 1, 3, 21, 651, ... (Sloane's A001699), but is not

heights=Map[Max[Distances[#,1]]&,binarytrees,{2}];

Transpose[{First[#],Last[#]}&/@(Sort/@heights)]

Solve[n==2^h,h]

Table[Log[2,n],{n,10}]//Floor

Internal Nodes

InternalNodes[g_Graph]:=Count[Rest[Degrees[g]],_?(#>1&)]

Map[InternalNodes,binarytrees,{2}]

Length/@Split[Sort[Flatten[Map[InternalNodes,binarytrees,{2}]]]]