(* :Title: Binary Trees *)

(* :Context: BinaryTrees` *)

(* :Author: Eric Rowland *)

(* :Date: {2010, 12, 29} *)

(* :Package Version: 1.03 *)

(* :Mathematica Version: 7.0 *)

(* :Discussion:
	BinaryTrees is a package for generating, visualizing, and manipulating binary trees.
	Documentation can be found at  http://math.tulane.edu/~erowland/packages.html .
*)


BeginPackage["BinaryTrees`"]

BareTreeForm::usage =
"BareTreeForm[expr] displays expr as an unlabeled tree with coloring to indicate instances of __ and ___."

BinaryTree::usage =
"BinaryTree[tree] gives the binary tree corresponding to a tree."

BinaryTreeQ::usage =
"BinaryTreeQ[expr] gives True if expr is a binary tree, and False otherwise."

BinaryTrees::usage =
"BinaryTrees[n] gives a list of all binary trees with n leaves."

CompleteBinaryTree::usage =
"CompleteBinaryTree[2^n] gives the binary tree with 2^n leaves, all on the lowest level."

DyckWord::usage =
"DyckWord[tree] gives the Dyck word corresponding to a tree."

DyckWordQ::usage =
"DyckWordQ[string] gives True if string is a Dyck word on {\"0\", \"1\"}, and False otherwise."

DyckWords::usage =
"DyckWords[n] gives a list of the length\[Hyphen]2n Dyck words on {\"0\", \"1\"}."

FromBinaryTree::usage =
"FromBinaryTree[binarytree] gives the tree corresponding to a binary tree."

FromDyckWord::usage =
"FromDyckWord[word] gives the tree corresponding to a Dyck word."

FromPathTree::usage =
"FromPathTree[pathtree] gives the {0,1}-tuple corresponding to a path tree."

FromTreeEdgeRules::usage =
"FromTreeEdgeRules[rules] constructs a tree from its list of parent-child relationships, where a vertex is represented by its position in the breadth-first traversal of the tree."

LeftCombTree::usage =
"LeftCombTree[n] gives the n\[Hyphen]leaf path tree in which only the left child of a vertex has children."

LeftCrookedTree::usage =
"LeftCrookedTree[n] gives the n\[Hyphen]leaf path tree in which alternate vertices on successive levels have children, beginning with the left child."

LeftTurnTree::usage =
"LeftTurnTree[n1, n2, \[Ellipsis], nk] gives the (n1 + n2 + \[CenterEllipsis] + nk)\[Hyphen]leaf path tree made up of combs of length ni, beginning with a left comb."

LevelHeight::usage =
"LevelHeight is an option for BareTreeForm that determines the height of each tree level."

PathTree::usage =
"PathTree[tuple] gives the path tree corresponding to a {0,1}-tuple."

PathTreeQ::usage =
"PathTreeQ[expr] gives True if expr is a path tree, and False otherwise."

PathTrees::usage =
"PathTrees[n] gives a list of all path trees with n leaves."

RandomBinaryTree::usage =
"RandomBinaryTree[n] gives a pseudorandom binary tree with n leaves."

RandomPathTree::usage =
"RandomPathTree[n] gives a pseudorandom path tree with n leaves."

RankBinaryTree::usage =
"RankBinaryTree[tree] gives the rank of an n\[Hyphen]leaf binary tree in BinaryTrees[n]."

RankTree::usage =
"RankTree[tree] gives the rank of an n\[Hyphen]vertex tree in Trees[n]."

RightCombTree::usage =
"RightCombTree[n] gives the n\[Hyphen]leaf path tree in which only the right child of a vertex has children."

RightCrookedTree::usage =
"RightCrookedTree[n] gives the n\[Hyphen]leaf path tree in which alternate vertices on successive levels have children, beginning with the right child."

RightTurnTree::usage =
"RightTurnTree[n1, n2, \[Ellipsis], nk] gives the (n1 + n2 + \[CenterEllipsis] + nk)\[Hyphen]leaf path tree made up of combs of length ni, beginning with a right comb."

TreeChop::usage =
"TreeChop[expr, d] replaces all subexpressions of expr at depth d with {}."

TreeEdgeRules::usage =
"TreeEdgeRules[tree] gives a list of parent-child relationships in a tree, where a vertex is represented by its position in the breadth-first traversal of the tree."

Trees::usage =
"Trees[n] gives a list of all rooted trees with n vertices.
Trees[n, degrees] gives a list of all rooted trees with n vertices such that the number of children of each vertex is a number in the list degrees."


Unprotect["BinaryTrees`*"]

Begin["`Private`"]

Occurrence[list : _[___], p_] := Position[list, p, {1}, 1, Heads -> False][[-1,1]]

StringReplaceRepeated[
	s_String,
	rules : _Rule | _RuleDelayed | {(_Rule | _RuleDelayed) ...},
	n : (_Integer | Infinity) : Infinity
] := FixedPoint[StringReplace[#, rules] &, s, n]

TopDownReplaceAll[expr_, rules_] :=
Module[{a},
	a[expr] //. {a[h_[body___]] :> a /@ Replace[h[body], rules], a[atom_?AtomQ] :> atom}
]

TreeQ[t_] := MatchQ[t, {___}] && And @@ TreeQ /@ t


BareTreeForm[tree_, opts : OptionsPattern[]] :=
TreeForm[
	tree /. {{Verbatim[__]} -> __, {Verbatim[___]} -> ___},
	ImageSize -> If[NumericQ[OptionValue[LevelHeight]],
		{Automatic, Max[Depth[tree] - 2, 1] OptionValue[LevelHeight]},
		OptionValue[ImageSize]
	],
	VertexRenderingFunction -> ({
		Switch[#2,
			HoldForm[Null], RGBColor[.5, 0, 0],
			HoldForm[Verbatim[__]], GrayLevel[.3],
			HoldForm[Verbatim[___]], GrayLevel[.6],
			_, RGBColor[0, 0, .7]
		],
		Point[#1]
	} &)
]
Options[BareTreeForm] = {ImageSize -> Automatic, LevelHeight -> 10}
SyntaxInformation[BareTreeForm] = {"ArgumentsPattern" -> {_, OptionsPattern[]}}

(* Can this be written in terms of BottomUpRelaceAll ? *)
BinaryTree[tree_?TreeQ] :=
Module[{a},
	(Map[a, tree /.{} -> {{}, {}}, {-2}] //.
		{body__a} :> a[{Fold[ReplacePart[#2, 2 -> #1] &, {}, Reverse[Identity @@@ {body}]], {}}]
	)[[1, 1]]
]
SyntaxInformation[BinaryTree] = {"ArgumentsPattern" -> {_}}

BinaryTreeQ[t_] := MatchQ[t, {} | {_, _}] && And @@ BinaryTreeQ /@ t
SyntaxInformation[BinaryTreeQ] = {"ArgumentsPattern" -> {_}}

binaryTrees[0] = {}
binaryTrees[1] = {{}}
binaryTrees[n_] := binaryTrees[n] =
	Join @@ Table[Flatten[Outer[List, binaryTrees[k], binaryTrees[n - k], 1], 1], {k, n - 1}]
BinaryTrees[n_Integer?NonNegative] := binaryTrees[n]
SyntaxInformation[BinaryTrees] = {"ArgumentsPattern" -> {_}}

CompleteBinaryTree[1] = {}
CompleteBinaryTree[n_Integer?Positive] :=
With[{l = Log[2, n]},
	Quiet[
		ReplaceRepeated[{}, {} -> {{}, {}}, MaxIterations -> l],
		ReplaceRepeated::rrlim
	] /; IntegerQ[l]
]
SyntaxInformation[CompleteBinaryTree] = {"ArgumentsPattern" -> {_}}

dyckWords[0] = {""}
dyckWords[1] = {"01"}
dyckWords[n_] := dyckWords[n] =
Join[
	("01" <> # &) /@ dyckWords[n - 1],
	("0" <> # <> "1" &) /@ dyckWords[n - 1],
	Flatten[Table[
		Outer["0" <> #1 <> "1" <> #2 &, dyckWords[i], dyckWords[n - 1 - i]],
		{i, n - 2}
	], 2]
]
DyckWords[n_Integer?NonNegative] := dyckWords[n]
SyntaxInformation[DyckWords] = {"ArgumentsPattern" -> {_}}

DyckWordQ[s_] := StringQ[s] && StringMatchQ[s, ("0" | "1") ...] &&
	MatchQ[Accumulate[Characters[s] /. {"0" -> 1, "1" -> -1}], {} | {_?NonNegative ..., 0}]
SyntaxInformation[DyckWordQ] = {"ArgumentsPattern" -> {_}}

DyckWord[tree_?TreeQ] :=
StringTake[
	StringReplace[
		ToString[tree],
		{"{" -> "0", "}" -> "1", _ -> ""}
	],
	{2, -2}
]
SyntaxInformation[DyckWord] = {"ArgumentsPattern" -> {_}}

FromBinaryTree[binarytree_?BinaryTreeQ] :=
Module[{g},
	{
		TopDownReplaceAll[binarytree, {l_, r_} :> g[{l}, r]] /.
			{g -> Sequence, {} -> Sequence[]}
	}
]
SyntaxInformation[FromBinaryTree] = {"ArgumentsPattern" -> {_}}

FromDyckWord[word_?DyckWordQ] :=
ToExpression["{" <> StringReplaceRepeated[
	word,
	{"0" -> "{", "1" -> "}", "}{" -> "},{"}
] <> "}"]
SyntaxInformation[FromDyckWord] = {"ArgumentsPattern" -> {_}}

FromPathTree[{{}, {}}] = {}
FromPathTree[tree_?PathTreeQ /; tree != {}] :=
Reap[NestWhile[
	Function[t, ((Sow[# - 1]; t[[#]]) &)[Position[t, Except[{}], {1}, Heads -> False][[1, 1]]]],
	tree,
	# != {{}, {}} &
]][[2, 1]]
SyntaxInformation[FromPathTree] = {"ArgumentsPattern" -> {_}}

(* uncommenting below causes things like BinaryTree[{{},{}}] to fail (well, when BinaryTree used to use FromTreeEdgeRules...) *)
FromTreeEdgeRules[{}] = {}
FromTreeEdgeRules[rules : {(*1 -> 2, _*)__Rule}] (*/; LessEqual @@ First /@ rules && Last /@ rules == Range[2, Length[rules] + 1]*) :=
	1 //. Table[n -> Cases[rules, (n -> child_) :> child], {n, rules[[-1, -1]]}]
SyntaxInformation[FromTreeEdgeRules] = {"ArgumentsPattern" -> {_}}

LeftCombTree[n_Integer?Positive] := Nest[{#, {}} &, {}, n - 1]
RightCombTree[n_Integer?Positive] := Nest[{{}, #} &, {}, n - 1]
SyntaxInformation[LeftCombTree] = {"ArgumentsPattern" -> {_}}
SyntaxInformation[RightCombTree] = {"ArgumentsPattern" -> {_}}

LeftCrookedTree[n_Integer /; n >= 2] := PathTree[Mod[Range[0, n - 3], 2]]
RightCrookedTree[n_Integer /; n >= 2] := PathTree[Mod[Range[n - 2], 2]]
SyntaxInformation[LeftCrookedTree] = {"ArgumentsPattern" -> {_}}
SyntaxInformation[RightCrookedTree] = {"ArgumentsPattern" -> {_}}

LeftTurnTree[nsequence : (_Integer?Positive ..)] /; Last[{nsequence}] >= 2 :=
PathTree[Join @@ MapIndexed[
	ConstantArray[Mod[First[#2] + 1, 2], #1] &,
	MapAt[# - 2 &, {nsequence}, -1]
]]
RightTurnTree[nsequence : (_Integer?Positive ..)] /; Last[{nsequence}] >= 2 :=
PathTree[Join @@ MapIndexed[
	ConstantArray[Mod[First[#2], 2], #1] &,
	MapAt[# - 2 &, {nsequence}, -1]
]]
SyntaxInformation[LeftTurnTree] = {"ArgumentsPattern" -> {__}}
SyntaxInformation[RightTurnTree] = {"ArgumentsPattern" -> {__}}

PathTree[tuple : {(0 | 1) ...}] :=
Module[{v},
	Fold[
		#1 /. If[#2 == 0, v -> {v, {}}, v -> {{}, v}] &,
		v,
		tuple
	] /. v -> {{}, {}}
]
SyntaxInformation[PathTree] = {"ArgumentsPattern" -> {_}}

PathTreeQ[tree_] := BinaryTreeQ[tree] && Depth[tree] == Count[tree, {}, {0, Infinity}] + 1
SyntaxInformation[PathTreeQ] = {"ArgumentsPattern" -> {_}}

PathTrees[n_Integer /; n >= 2] := PathTree /@ Tuples[{1, 0}, n - 2]
SyntaxInformation[PathTrees] = {"ArgumentsPattern" -> {_}}

(* This is an implementation of R\[EAcute]my's algorithm (as described in a paper by M\[ADoubleDot]kinen and Siltaneva). *)
RandomBinaryTree[n_Integer?Positive] :=
Module[{max = 1},
	Nest[
		# /. v : Blank[RandomInteger[{1, (max += 2) - 2}]] :>
			RandomChoice[{max[(max - 1)[], v], max[v, (max - 1)[]]}] &,
		1[], 
		n - 1
	] /. _Integer -> List
]
SyntaxInformation[RandomBinaryTree] = {"ArgumentsPattern" -> {_}}

RandomPathTree[n_Integer?Positive] := PathTree[RandomChoice[{0, 1}, n - 2]]
SyntaxInformation[RandomPathTree] = {"ArgumentsPattern" -> {_}}

RankBinaryTree[binarytree_?BinaryTreeQ] := Occurrence[BinaryTrees[Count[binarytree, {}, {0, Infinity}]], binarytree]
SyntaxInformation[RankBinaryTree] = {"ArgumentsPattern" -> {_}}

RankTree[tree_?TreeQ] := Occurrence[Trees[Count[tree, _List, {0, Infinity}]], tree]
SyntaxInformation[RankTree] = {"ArgumentsPattern" -> {_}}

TreeChop[tree_, depth_Integer?NonNegative] := Map[{} &, tree, {depth}]
SyntaxInformation[TreeChop] = {"ArgumentsPattern" -> {_, _}}

TreeEdgeRules[tree_?TreeQ] :=
Module[{i = 0, labeledtree},
	labeledtree = Fold[
		Replace[#1, List :> ++i, {#2}, Heads -> True] &,
		tree,
		Range[Depth[tree] - 1]
	];
	Join @@ Table[
		Thread[n -> First[Cases[labeledtree, n[children___] :> Head /@ {children}, {0, Infinity}, 1]]],
		{n, i}
	]
]
SyntaxInformation[TreeEdgeRules] = {"ArgumentsPattern" -> {_}}

(* The necessity of Union makes this not really optimal;
   but Permutations produces duplicates in some cases. *)
trees[0, _List : {}] := {}
trees[1, {___, 0, ___}] := {{}}
trees[1, _List] := {}
trees[n_, degrees_] := trees[n, degrees] =
Union[Join @@ Permutations /@ Join @@ (Flatten[Outer[List, ##, 1], Length[{##}] - 1] &) @@@
	Map[
		trees[#, degrees] &,
		Join @@ (IntegerPartitions[n - 1, {#}] &) /@ degrees,
		{2}
	]
]
Trees[n_Integer?NonNegative, degrees_List /; Unequal @@ degrees] := trees[n, degrees]
Trees[n_Integer?NonNegative] := trees[n, Range[0, n - 1]]
SyntaxInformation[Trees] = {"ArgumentsPattern" -> {_, _.}}


End[]

Protect["BinaryTrees`*"]

EndPackage[]