Module BAF := BA_Facts BA.
Include BAF.
(* Now, we prove the axioms about relativization. Again, this mostly involves packing and unpacking the canonTree type and pushing around mkCanon. *)
Definition rel (a x:t) : t.
case_eq (proj1_sig x); intros.
destruct b.
exact a.
exact (exist (fun t => canonicalTree t) (Leaf false) I).
refine (exist _ (relativ_tree (proj1_sig a) (proj1_sig x)) _).
apply relativ_almost_canon.
apply (proj2_sig a).
apply (proj2_sig x).
destruct x; simpl in *; subst; simpl in *; intuition.
Defined.
(* Axioms about splittability. These follow easily from relativization. *)
Definition leftTree : canonTree.
exists (Node (Leaf true) (Leaf false)).
simpl; intuition.
Defined.
Definition rightTree : canonTree.
exists (Node (Leaf false) (Leaf true)).
simpl; intuition.
Defined.
Definition split (x:canonTree) := (rel x leftTree, rel x rightTree).
(* Token Factory definitions and proofs. We specify token factories and tokens inductively on trees, which makes the proofs fairly straightforward. *)
Inductive isTokenFactory' : ShareTree -> nat -> Prop :=
| isTokFac_0 : isTokenFactory' (Leaf true) O
| isTokFac_S_true : forall t n,
isTokenFactory' t (S n) ->
isTokenFactory' (Node (Leaf true) t) (S n)
| isTokFac_S_false : forall t n,
isTokenFactory' t n ->
isTokenFactory' (Node (Leaf false) t) (S n).
Inductive isToken' : ShareTree -> nat -> Prop :=
| isTok_0 : isToken' (Leaf false) O
| isTok_S_true : forall t n,
isToken' t n ->
isToken' (Node (Leaf true) t) (S n)
| isTok_S_false : forall t n,
isToken' t (S n) ->
isToken' (Node (Leaf false) t) (S n).
Definition isTokenFactory (x:t) (n:nat) := isTokenFactory' (proj1_sig x) n.
Definition isToken (x:t) (n:nat) := isToken' (proj1_sig x) n.
Fixpoint split_tok1 (n:nat) (x:ShareTree) {struct x} : ShareTree :=
match x with
| Node (Leaf true)  t2 =>
match n with
| O    => Node (Leaf true) (Leaf false)
| S n' => Node (Leaf true) (split_tok1 n' t2)
end
| Node (Leaf false) t2 => Node (Leaf false) (split_tok1 n t2)
| _ => Leaf false
end.
Fixpoint split_tok2 (n:nat) (x:ShareTree) {struct x} : ShareTree :=
match x with
| Node (Leaf true)  t2 =>
match n with
| O    => Node (Leaf false) t2
| S n' => Node (Leaf false) (split_tok2 n' t2)
end
| Node (Leaf false) t2 => Node (Leaf false) (split_tok2 n t2)
| _ => x
end.
Definition split_token (n:nat) (tok:t) : t * t :=
match n with
| O => (bot,tok)
| S n' =>
(exist (fun x => canonicalTree x) (mkCanon (split_tok1 n' (proj1_sig tok))) (mkCanon_correct _)
,exist (fun x => canonicalTree x) (mkCanon (split_tok2 n' (proj1_sig tok))) (mkCanon_correct _)
)
end.
Fixpoint new_fac (n:nat) {struct n} : ShareTree :=
match n with
| O => Node (Leaf false) (Leaf true)
| S n' => Node (Leaf false) (new_fac n')
end.
Fixpoint create_tok1 (n:nat) (x:ShareTree) {struct x} : ShareTree :=
match x with
| Node (Leaf true)  t2 =>
match n with
| O    => Node (Leaf false) t2
| S n' => Node (Leaf false) (create_tok1 n' t2)
end
| Node (Leaf false) t2 => Node (Leaf false) (create_tok1 n t2)
| Leaf true => new_fac n
| _  => x
end.
Fixpoint create_tok2 (n:nat) (x:ShareTree) {struct x} : ShareTree :=
match x with
| Node (Leaf true)  t2 =>
match n with
| O    => Node (Leaf true) (Leaf false)
| S n' => Node (Leaf true) (create_tok2 n' t2)
end
| Node (Leaf false) t2 => Node (Leaf false) (create_tok2 n t2)
| Leaf true => comp_tree (new_fac n)
| _ => Leaf false
end.
Definition create_token (n:nat) (fac:t) : t*t :=
match n with
| O => (fac,bot)
| S n' =>
(exist (fun x => canonicalTree x) (mkCanon (create_tok1 n' (proj1_sig fac))) (mkCanon_correct _),
exist (fun x => canonicalTree x) (mkCanon (create_tok2 n' (proj1_sig fac))) (mkCanon_correct _))
end.
Local Open Scope nat_scope.
Instance EqDec_share : EqDec t := EqDec_canonTree.
(* 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.
Definition Lsh  : Share.t := fst (Share.split Share.top).
Definition Rsh  : Share.t := snd (Share.split Share.top).
Definition splice (a b: t) : t := Share.lub (rel Lsh a) (rel Rsh b).
(*START HERE*)
Fixpoint fullTreeP (t : ShareTree) (d  : nat): Prop :=
match t with
| Leaf b => d = 0
| Node l r => (d > 0) /\ (fullTreeP l (d - 1)) /\ (fullTreeP r (d - 1))
end.
Definition fullTree (t : ShareTree) : Prop :=
fullTreeP t (tree_heightP t).
Fixpoint mkFull (d : nat)  (t : ShareTree) : option ShareTree :=
match d with
|0 => match t with
|Leaf b => Some (Leaf b)
|Node l r => None
end
|S n => match t with
|Leaf b => match (mkFull n (Leaf b)) with
| Some t => Some (Node t t)
|_ => None
end
|Node l r => match (mkFull n l, mkFull n r) with
| (Some t1, Some t2) => Some (Node t1 t2)
|_ => None
end
end
end.
Fixpoint tree_round_leftP (n : nat) (t : ShareTree) : option ShareTree :=
match n with
| 0 => None
| 1 => match t with
| Node (Leaf b1) (Leaf b2) => Some (Leaf b1)
|_=> None
end
| S n' => match t with
| Leaf b => Some (Leaf b)
| Node t1 t2 => match (tree_round_leftP n' t1, tree_round_leftP n' t2) with
| (Some t1', Some t2') => Some (Node t1' t2')
| _ => None
end
end
end.
Definition tree_round_left (n : nat) (t : canonTree) : option canonTree:=
match mkFull n (proj1_sig t) with
| Some t' => match tree_round_leftP n t' with
| Some t'' => Some (exist (fun t => canonicalTree t) (mkCanon t'') (mkCanon_correct _))
| None => None
end
| None => None
end.
Instance  roundableL_tree : roundableLeft t :=
RoundableLeft tree_round_left.
Fixpoint tree_round_rightP (n : nat) (t : ShareTree) : option ShareTree :=
match n with
| 0 => None
| 1 => match t with
| Node (Leaf b1) (Leaf b2) => Some (Leaf b2)
|_=> None
end
| S n' => match t with
| Leaf b => Some (Leaf b)
| Node t1 t2 => match (tree_round_rightP n' t1, tree_round_rightP n' t2) with
| (Some t1', Some t2') => Some (Node t1' t2')
| _ => None
end
end
end.
Definition tree_round_right (n : nat) (t : canonTree) : option canonTree:=
match mkFull n (proj1_sig t) with
| Some t' => match tree_round_rightP n t' with
| Some t'' => Some (exist (fun t => canonicalTree t) (mkCanon t'') (mkCanon_correct _))
| None => None
end
| None => None
end.
Instance  roundableR_tree : roundableRight t :=
RoundableRight tree_round_right.
Fixpoint tree_avgP (t1 t2 : ShareTree) : option ShareTree :=
match (t1,t2) with
|(Leaf b1, Leaf b2) => Some (Node (Leaf b1) (Leaf b2))
|(Node t11 t12, Node t21 t22) => match (tree_avgP t11 t21, tree_avgP t12 t22) with
|(Some t1', Some t2') => Some (Node t1' t2')
|_ => None
end
|_ => None
end.
Definition tree_avg (n : nat) (t1 t2 : canonTree) : option canonTree :=
match n with
|0 => None
|S n' => match (mkFull n' (proj1_sig t1), mkFull n' (proj1_sig t2)) with
|(Some t1', Some t2') => match (tree_avgP t1' t2') with
|Some t' => Some (exist (fun t => canonicalTree t) (mkCanon t') (mkCanon_correct _))
|None => None
end
|_ => None
end
end.
Instance avgable_tree : avgable t :=
Avgable tree_avg.
Definition recompose (tt : (canonTree*canonTree)): canonTree :=
let (t1, t2) := tt in
let (x1, c1) := t1 in
let (x2, c2) := t2 in
match x1 as s return (canonicalTree s -> canonTree) with
| Leaf b1 =>
fun c3 : canonicalTree (Leaf b1) =>
match x2 as s return (canonicalTree s -> canonTree) with
| Leaf b2 =>
fun c4 : canonicalTree (Leaf b2) =>
match bool_dec b1 b2 with
| left e =>
let H :=
eq_rec b1
(fun b3 : bool => canonicalTree (Leaf b3) -> canonTree)
(fun _ : canonicalTree (Leaf b1) =>
exist (fun t : ShareTree => canonicalTree t) (Leaf b1) c3)
b2 e in
H c4
| right n =>
exist (fun t : ShareTree => canonicalTree t)
(Node (Leaf b1) (Leaf b2)) (compose_canon1 b1 b2 n c3 c4)
end
| Node x21 x22 =>
fun c4 : canonicalTree (Node x21 x22) =>
exist (fun t : ShareTree => canonicalTree t)
(Node (Leaf b1) (Node x21 x22)) (compose_canon2 b1 x21 x22 c3 c4)
end c2
| Node x11 x12 =>
fun c3 : canonicalTree (Node x11 x12) =>
match x2 as s return (canonicalTree s -> canonTree) with
| Leaf b2 =>
fun c4 : canonicalTree (Leaf b2) =>
exist (fun t : ShareTree => canonicalTree t)
(Node (Node x11 x12) (Leaf b2)) (compose_canon3 x11 x12 b2 c3 c4)
| Node x21 x22 =>
fun c4 : canonicalTree (Node x21 x22) =>
exist (fun t : ShareTree => canonicalTree t)
(Node (Node x11 x12) (Node x21 x22))
(compose_canon4 x11 x12 x21 x22 c3 c4)
end c2
end c1.
(*End Definition*)

Lemma mkFull_correct : forall n t t', mkFull n t = Some t' -> fullTree t'.