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.

Lemma absorbToken : forall fac fac' tok x n,
isTokenFactory fac' (n+x) ->
isToken tok n ->
join fac' tok fac ->
isTokenFactory fac x.