(* Credits for the next part of this file: Specification of "unrel" operator by Andrew W. Appel and Robert Dockins Definition of "unrel", and all the proofs about it, by Le Xuan Bach *)
Program Definition tree_decompose (ct : canonTree) :(canonTree * canonTree) :=
let (t, pf) := ct in
match t with
|Leaf b => (Leaf b, Leaf b)
|Node t1 t2 => (t1 ,t2)
end.
Next Obligation.
destruct pf. tauto.
Defined.
Next Obligation.
destruct pf. tauto.
Defined.
Instance decompose_tree : decomposible t :=
Decomposible tree_decompose.
Fixpoint tree_heightP (t : ShareTree) : nat :=
match t with
| Leaf b  => 0
| Node l r => (max (tree_heightP l) (tree_heightP r)) + 1
end.
Definition tree_height (t : canonTree) := tree_heightP (proj1_sig t).
Definition tree_height_zero (t : canonTree) : {tree_height t = 0} + {tree_height t <> 0}.
destruct t. destruct x.
left. reflexivity.
right. unfold tree_height. simpl. intro. rewrite plus_comm in H. inversion H.
Defined.
Instance tree_heightable : heightable t :=
Heightable tree_height tree_height_zero.
Function unrel (t1 : t) (t2 : t) {measure tree_height t1} : t :=
match t1 with
| exist _ (Leaf b) _ => t2
| _ => let (ltr1, rtr1) := decompose t1 in
let (ltr2, rtr2) := decompose t2 in
match ltr1 with
| exist _ (Leaf true) _ => ltr2
| exist _ (Leaf false) _ => unrel rtr1 rtr2
| _ => unrel ltr1 ltr2
end
end.

(* Specifications: *)
Lemma mkCanon_identity : forall t, canonicalTree t -> mkCanon t = t.
Lemma identity_tree: identity (exist (fun t0 => canonicalTree t0) (Leaf false) (canonTree_Leaf _)).
Lemma nonEmpty_nonidentity: forall x c,nonEmptyTree x -> nonidentity (exist _ x c).
Lemma unrel_rel: forall x sh,
nonidentity x -> unrel x (rel x sh) = sh.