(* Definition of the trees and operations on them *)

  Inductive ShareTree : Set :=
  | Leaf : bool -> ShareTree
  | Node : ShareTree -> ShareTree -> ShareTree
  .(* Definition of the trees and operations on them *)

  Inductive ShareTree : Set :=
  | Leaf : bool -> ShareTree
  | Node : ShareTree -> ShareTree -> ShareTree
  .(* Definition of the trees and operations on them *)

  Inductive ShareTree : Set :=
  | Leaf : bool -> ShareTree
  | Node : ShareTree -> ShareTree -> ShareTree
  .Fixpoint nonFullTree (x:ShareTree) : Prop :=
   match x with
   | Leaf b   => b = false
   | Node l r => nonFullTree l \/ nonFullTree r
   end.Fixpoint nonEmptyTree (x:ShareTree) : Prop :=
   match x with
   | Leaf b   => b = true
   | Node l r => nonEmptyTree l \/ nonEmptyTree r
   end.Fixpoint canonicalTree (x:ShareTree) : Prop :=
   match x with
   | Leaf _   => True
   | Node l r => nonFullTree x /\ nonEmptyTree x /\
                 canonicalTree l /\ canonicalTree r
   end.Fixpoint union_tree (x y:ShareTree) { struct x } : ShareTree :=
    match x with
    | Leaf true  => Leaf true
    | Leaf false => y
    | Node l1 r1 =>
       match y with
       | Leaf true  => Leaf true
       | Leaf false => x
       | Node l2 r2 =>
            Node (union_tree l1 l2) (union_tree r1 r2)
       end
    end.Fixpoint intersect_tree (x y:ShareTree) { struct x } : ShareTree :=
    match x with
    | Leaf false => Leaf false
    | Leaf true  => y
    | Node l1 r1 =>
       match y with
       | Leaf false => Leaf false
       | Leaf true  => x
       | Node l2 r2 =>
            Node (intersect_tree l1 l2) (intersect_tree r1 r2)
       end
    end.Fixpoint comp_tree (x:ShareTree) : ShareTree :=
    match x with
    | Leaf b => Leaf (negb b)
    | Node l r => Node (comp_tree l) (comp_tree r)
    end.Fixpoint mkCanon (x:ShareTree) : ShareTree :=
    match x with
    | Leaf b => Leaf b
    | Node l r =>
       let l' := mkCanon l in
       let r' := mkCanon r in
       match l', r' with
       | Leaf b1, Leaf b2 =>
          if bool_dec b1 b2
             then Leaf b1
             else Node l' r'
       | _, _ => Node l' r'
       end
    end.Fixpoint relativ_tree (z a:ShareTree) {struct z} : ShareTree :=
    match z with
    | Leaf true  => a
    | Leaf false => Leaf false
    | Node l r   => Node (relativ_tree l a) (relativ_tree r a)
    end.(* The ordering relation on trees, and its induced isomorphism. *)

  Inductive shareTreeOrd : ShareTree -> ShareTree -> Prop :=
  | Leaf_Ord : forall b1 b2, implb b1 b2 = true ->
       shareTreeOrd (Leaf b1) (Leaf b2)
  | LeafNode_Ord : forall b l r,
       shareTreeOrd (Node (Leaf b) (Leaf b)) (Node l r) ->
       shareTreeOrd (Leaf b) (Node l r)
  | NodeLeaf_Ord : forall b l r,
       shareTreeOrd (Node l r) (Node (Leaf b) (Leaf b)) ->
       shareTreeOrd (Node l r) (Leaf b)
  | Node_Ord : forall l1 l2 r1 r2,
       shareTreeOrd l1 l2 ->
       shareTreeOrd r1 r2 ->
       shareTreeOrd (Node l1 r1) (Node l2 r2)
  .(* The ordering relation on trees, and its induced isomorphism. *)

  Inductive shareTreeOrd : ShareTree -> ShareTree -> Prop :=
  | Leaf_Ord : forall b1 b2, implb b1 b2 = true ->
       shareTreeOrd (Leaf b1) (Leaf b2)
  | LeafNode_Ord : forall b l r,
       shareTreeOrd (Node (Leaf b) (Leaf b)) (Node l r) ->
       shareTreeOrd (Leaf b) (Node l r)
  | NodeLeaf_Ord : forall b l r,
       shareTreeOrd (Node l r) (Node (Leaf b) (Leaf b)) ->
       shareTreeOrd (Node l r) (Leaf b)
  | Node_Ord : forall l1 l2 r1 r2,
       shareTreeOrd l1 l2 ->
       shareTreeOrd r1 r2 ->
       shareTreeOrd (Node l1 r1) (Node l2 r2)
  .(* The ordering relation on trees, and its induced isomorphism. *)

  Inductive shareTreeOrd : ShareTree -> ShareTree -> Prop :=
  | Leaf_Ord : forall b1 b2, implb b1 b2 = true ->
       shareTreeOrd (Leaf b1) (Leaf b2)
  | LeafNode_Ord : forall b l r,
       shareTreeOrd (Node (Leaf b) (Leaf b)) (Node l r) ->
       shareTreeOrd (Leaf b) (Node l r)
  | NodeLeaf_Ord : forall b l r,
       shareTreeOrd (Node l r) (Node (Leaf b) (Leaf b)) ->
       shareTreeOrd (Node l r) (Leaf b)
  | Node_Ord : forall l1 l2 r1 r2,
       shareTreeOrd l1 l2 ->
       shareTreeOrd r1 r2 ->
       shareTreeOrd (Node l1 r1) (Node l2 r2)
  .(* The ordering relation on trees, and its induced isomorphism. *)

  Inductive shareTreeOrd : ShareTree -> ShareTree -> Prop :=
  | Leaf_Ord : forall b1 b2, implb b1 b2 = true ->
       shareTreeOrd (Leaf b1) (Leaf b2)
  | LeafNode_Ord : forall b l r,
       shareTreeOrd (Node (Leaf b) (Leaf b)) (Node l r) ->
       shareTreeOrd (Leaf b) (Node l r)
  | NodeLeaf_Ord : forall b l r,
       shareTreeOrd (Node l r) (Node (Leaf b) (Leaf b)) ->
       shareTreeOrd (Node l r) (Leaf b)
  | Node_Ord : forall l1 l2 r1 r2,
       shareTreeOrd l1 l2 ->
       shareTreeOrd r1 r2 ->
       shareTreeOrd (Node l1 r1) (Node l2 r2)
  .(* The ordering relation on trees, and its induced isomorphism. *)

  Inductive shareTreeOrd : ShareTree -> ShareTree -> Prop :=
  | Leaf_Ord : forall b1 b2, implb b1 b2 = true ->
       shareTreeOrd (Leaf b1) (Leaf b2)
  | LeafNode_Ord : forall b l r,
       shareTreeOrd (Node (Leaf b) (Leaf b)) (Node l r) ->
       shareTreeOrd (Leaf b) (Node l r)
  | NodeLeaf_Ord : forall b l r,
       shareTreeOrd (Node l r) (Node (Leaf b) (Leaf b)) ->
       shareTreeOrd (Node l r) (Leaf b)
  | Node_Ord : forall l1 l2 r1 r2,
       shareTreeOrd l1 l2 ->
       shareTreeOrd r1 r2 ->
       shareTreeOrd (Node l1 r1) (Node l2 r2)
  .Definition shareTreeEq (x y:ShareTree) :=
      shareTreeOrd x y /\ shareTreeOrd y x.Ltac destruct_bool :=
    repeat (match goal with [ b:bool |- _ ] => destruct b end).Ltac invert_ord :=
    repeat (
    match goal with
    | [ H:shareTreeEq _ _ |- _ ] => destruct H
    | [ H:shareTreeOrd (Leaf _) (Leaf _) |- _ ] => inversion H; clear H
    | [ H:shareTreeOrd (Leaf _) (Node _ _) |- _ ] => inversion H; clear H
    | [ H:shareTreeOrd (Node _ _) (Leaf _) |- _ ] => inversion H; clear H
    | [ H:shareTreeOrd (Node _ _) (Node _ _) |- _ ] => inversion H; clear H
    end; subst).

Lemma relativ_almost_canon : forall a x, canonicalTree a -> canonicalTree x -> nonEmptyTree x -> canonicalTree (relativ_tree a x).