Module Share <: SHARE_MODEL.
(* 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)
.
Hint Constructors shareTreeOrd : core.
Definition shareTreeEq (x y:ShareTree) :=
shareTreeOrd x y /\ shareTreeOrd y x.
Hint Unfold shareTreeEq : core.
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).
(* Utility lemmas about full and empty trees, and the top and bottom elements. *)
Hint Resolve geTrueFull leFalseEmpty emptyLeFalse fullGeTrue
falseLeaf_bottom trueLeaf_top : core.
Hint Resolve eqFalseLeaf_empty eqTrueLeaf_full emptyTree_canonical_falseLeaf
fullTree_canonical_trueLeaf : core.
(* Show that shareTreeOrd is a preorder (reflexive and transitive). *)
(* Show that shareTreeEq is an equivalance relation. *)
(* Show that mkCanon generates canonical trees that are equivalant to the original. *)
Hint Resolve mkCanon_nonEmpty mkCanon_correct mkCanon_eq : core.
(* Show that union and intersection are the LUB and GLB for the lattice, respectively. *)
(* Now prove a few other utility lemmas about union and intersection. *)
(* Demonstrate that intersection distributes over union and vice-versa. *)
(* Demonstrate that union and intersection are congruences WRT the shareTreeEq relation. *)
(* Some basic facts about the relativization operation: It is injective when a is nonempty; a number of facts about nonemptyness, nonfullness and canonical trees; it commutes with union, intersection, mkCanon; and it is an associative operation. *)
Hint Resolve relativ_empty relativ_empty1 relativ_empty2
relativ_full relativ_full1 relativ_full2 relativ_inv : core.
(* Here we have an unfortunate detour to develop a theory of many-hole contexts, which allows us to prove that relativization is injective on the left. *)
Inductive Sctx : Set :=
| NodeB : Sctx -> Sctx -> Sctx
| NodeR : ShareTree -> Sctx -> Sctx
| NodeL : Sctx -> ShareTree -> Sctx
| Hole : Sctx
.
Fixpoint Sctx_app (c1 c2:Sctx) {struct c1} : Sctx :=
match c1 with
| NodeB l r => NodeB (Sctx_app l c2) (Sctx_app r c2)
| NodeR l r => NodeR l (Sctx_app r c2)
| NodeL l r => NodeL (Sctx_app l c2) r
| Hole      => c2
end.
Fixpoint fill (c:Sctx) (x:ShareTree) {struct c} : ShareTree :=
match c with
| NodeR l r => Node l (fill r x)
| NodeL l r => Node (fill l x) r
| NodeB l r => Node (fill l x) (fill r x)
| Hole      => x
end.
Definition to_Sctx (a:ShareTree) : nonEmptyTree a -> Sctx.
revert a.
refine (fix f (a:ShareTree)  {struct a} : nonEmptyTree a -> Sctx :=
match a as a' return nonEmptyTree a' -> Sctx with
| Leaf true => fun H => Hole
| Leaf false => fun H => False_rec _ _
| Node l r => fun H =>
match nonEmpty_dec l, nonEmpty_dec r with
| left  Hl, left Hr => NodeB (f l Hl) (f r Hr)
| left  Hl, right _  => NodeL (f l Hl) r
| right _ , left  Hr => NodeR l (f r Hr)
| right Hl, right Hr => False_rec _ _
end
end).
simpl in H; discriminate.
simpl in H; intuition.
Defined.

Lemma relativ_to_Sctx : forall a x H,
relativ_tree a x = fill (to_Sctx a H) x.