Set Warnings "-extraction-opaque-accessed,-extraction".
Set Warnings "-notation-overridden,-parsing".
(* end randomSplitAssumption *)
CoInductive RandomSeedTree :=
| RstNode : RandomSeed -> RandomSeedTree -> RandomSeedTree -> RandomSeedTree.
Definition root_rst (rst : RandomSeedTree) : RandomSeed :=
match rst with
| RstNode root _ _ => root
end.
Definition left_rst (rst : RandomSeedTree) : RandomSeedTree :=
match rst with
| RstNode _ t1 _ => t1
end.
Definition right_rst (rst : RandomSeedTree) : RandomSeedTree :=
match rst with
| RstNode _ _ t2 => t2
end.
Inductive PrefixFree : list SplitPath -> Prop :=
| FreeNil : PrefixFree []
| FreeCons : forall (p : SplitPath) (l : list SplitPath),
PrefixFree l ->
(forall (p' : SplitPath), In p' l ->
(forall p1 p2, p' ++ p1 = p ++ p2-> False)) ->
PrefixFree (p :: l).
intro.
apply FreeCons.
+ apply FreeNil.
+ intros. inversion H.
Qed.
intros.
destruct l; auto.
inversion H.
subst.
pose proof H3 l.
assert (In l (l :: l0)) by (left; auto).
eapply H0 in H1. inversion H1.
instantiate (2 := []). rewrite app_nil_r; simpl; eauto.
Qed.
Inductive correspondingSeedTree (l : list SplitPath) (f : SplitPath -> RandomSeed)
(st : SeedTree) : Prop :=
| Corresponding : (forall (p : SplitPath) s, varySeed' st p = Some s -> In p l) ->
(forall (p : SplitPath), In p l -> varySeed' st p = Some (f p)) ->
PrefixFree l ->
correspondingSeedTree l f st.
intro f.
apply Corresponding.
+ intros p s Contra.
inversion Contra.
+ intros p InNil. inversion InNil.
+ apply FreeNil.
Qed.
Ltac fireInLeft name :=
match goal with
| [H : In ?X (?X :: ?XS) -> _ |- _ ] =>
assert (In X (X :: XS)) as name by (left; auto); apply H in name; clear H
end.
intros l f Corr.
inversion Corr as [Vary_In In_Vary Pref]; clear Corr.
destruct l as [ | p ps]; auto.
clear Vary_In Pref.
pose proof (In_Vary p) as Contra; clear In_Vary.
fireInLeft Hyp.
inversion Hyp.
Qed.
intros.
inversion H; subst.
destruct l eqn:L; auto.
pose proof (H3 l0).
assert (In l0 (l0 :: l1)) by (left; auto).
eapply H0 in H1.
+ inversion H1.
+ instantiate (1 := l0). instantiate (1 := []). rewrite app_nil_r. auto.
Qed.
intros s l f Corr.
inversion Corr as [Vary_In In_Vary Pref]; clear Corr.
pose proof (Vary_In [] s) as Hyp; clear Vary_In.
simpl in Hyp.
assert (InNilL : In [] l) by (apply Hyp; auto); clear Hyp.
split.
+ destruct l eqn:L.
- inversion InNilL.
- destruct s0 eqn : S0.
* apply PrefixFreeWithNil in Pref; subst; auto.
* pose proof (In_Vary (s1 :: s2)) as Hyp; clear In_Vary.
+ inversion Pref.
fireInLeft Hyp'. simpl in Hyp'. inversion Hyp'.
+ pose proof In_Vary [] as Hyp; clear In_Vary.
apply Hyp in InNilL; clear Hyp.
simpl in *.
congruence.
Qed.
unfold not; intros st1 st2 l p f Corr InPL PNil; subst.
inversion Corr as [_ In_Vary _]; clear Corr.
pose proof (In_Vary []) as Hyp; clear In_Vary.
apply Hyp in InPL; clear Hyp.
simpl in InPL.
inversion InPL.
Qed.
Hint Resolve corrEmptyUndef.
Hint Resolve corrNodeNonEmpty.
Definition Direction_eq_dec : forall (d1 d2 : SplitDirection),
{d1 = d2} + {d1 <> d2}.
decide equality.
Qed.
Definition eq_dir_b (d1 d2 : SplitDirection) : bool :=
match d1,d2 with
| Left, Left => true
| Right, Right => true
| _, _ => false
end.
intros.
unfold eq_dir_b.
destruct d1; destruct d2; split; auto; intro Contra; inversion Contra.
Qed.
Definition refineList (d : SplitDirection) (l : list SplitPath) : list SplitPath :=
map (@tl SplitDirection) (filter (fun p => match hd_error p with
| Some d' => eq_dir_b d d'
| _       => false
end) l).
intros d l p.
unfold refineList.
rewrite in_map_iff.
intros.
inversion H; clear H.
inversion H0; clear H0.
generalize H1; clear H1.
rewrite filter_In.
intros.
inversion H0; clear H0.
unfold tl in H.
destruct x eqn:X.
+ simpl in H2. inversion H2.
+ simpl in H2. apply eq_dir_b_eq in H2. subst. auto.
Qed.
intros.
unfold refineList.
apply in_map_iff.
exists (d :: p).
split; auto.
apply filter_In.
split; simpl; auto.
unfold eq_dir_b; destruct d; auto.
Qed.
intros.
induction l.
- unfold refineList; constructor.
- destruct a eqn:A; subst.
* apply prefixFreeEmpty in H. subst. unfold refineList. simpl. constructor.
* destruct s eqn:S; destruct d; subst.
+ unfold refineList; simpl.
eapply FreeCons.
- apply IHl. inversion H; auto.
- intros. inversion H; subst; clear H.
apply in_map_iff in H0.
inversion H0; subst; clear H0.
inversion H; subst; clear H.
apply filter_In in H2. inversion H2; subst; clear H2.
destruct x eqn:X; simpl in *. inversion H0.
destruct s eqn:S; simpl in *.
pose proof H5 (Left :: l0).
eapply H2 in H; auto.
simpl. instantiate (1 := p2). instantiate (1:= p1). rewrite H1. auto.
inversion H0.
+ unfold refineList; simpl. apply IHl.
inversion H. auto.
+ unfold refineList; simpl. apply IHl.
inversion H. auto.
+ unfold refineList; simpl.
eapply FreeCons.
- apply IHl. inversion H; auto.
- intros. inversion H; subst; clear H.
apply in_map_iff in H0.
inversion H0; subst; clear H0.
inversion H; subst; clear H.
apply filter_In in H2. inversion H2; subst; clear H2.
destruct x eqn:X; simpl in *. inversion H0.
destruct s eqn:S; simpl in *.
inversion H0.
pose proof H5 (Right :: l0).
eapply H2 in H; auto.
simpl. instantiate (1 := p2). instantiate (1:= p1). rewrite H1. auto.
Qed.
Definition refineFunction (f : SplitPath -> RandomSeed) (d : SplitDirection) (arg : SplitPath) :
RandomSeed :=
f (d :: arg).
auto.
Qed.
Hint Rewrite refineFunCorrect.
Hint Unfold refineFunction.
Program Fixpoint addToTree (st : SeedTree) (p : SplitPath) (f : SplitPath -> RandomSeed)
(l : list SplitPath)
(Corr : correspondingSeedTree l f st)
(Pref : forall p', In p' l -> (forall p1 p2, p ++ p1 = p' ++ p2 -> False))
: SeedTree :=
match st with
| SeedTreeUndef =>
match p with
| [] => SeedTreeLeaf (f p)
| Left  :: p' => SeedTreeNode (addToTree SeedTreeUndef p' (refineFunction f Left) [] _ _) SeedTreeUndef
| Right :: p' => SeedTreeNode SeedTreeUndef (addToTree SeedTreeUndef p' (refineFunction f Right) [] _ _)
end
| SeedTreeLeaf s => _  (* Contradiction! *)
| SeedTreeNode st1 st2 =>
match p with
| [] => SeedTreeLeaf (f p)
| Left  :: p' => SeedTreeNode (addToTree st1 p' (refineFunction f Left) (refineList Left l) _ _) st2
| Right :: p' => SeedTreeNode st1 (addToTree st2 p' (refineFunction f Right) (refineList Right l) _ _)
end
end.
Next Obligation.
apply corrEmptyLeaf in Corr. inversion Corr; clear Corr; subst.
pose proof (Pref []).
exfalso.
eapply H.
+ left; auto.
+ instantiate (2 := []). rewrite app_nil_r. simpl. eauto.
Qed.
Next Obligation.
eapply Corresponding; intros.
+ apply refineCorrect'.
inversion Corr as [Vary_In _ _ ]; clear Corr.
pose proof (Vary_In (Left :: p) s) as Hyp; clear Vary_In.
auto.
+ apply refineCorrect in H.
inversion Corr as [_ In_Vary _]; clear Corr.
pose proof (In_Vary (Left :: p)) as Hyp; clear In_Vary.
apply Hyp in H; clear Hyp.
simpl in H.
unfold refineFunction; auto.
+ inversion Corr.
apply refinePreservesPrefixFree.
auto.
Qed.
Next Obligation.
eapply Pref.
instantiate (1:= Left :: p'0).
apply refineCorrect; auto.
instantiate (1:= p2). instantiate (1:=p1). simpl. rewrite H0. auto.
Qed.
Next Obligation.
eapply Corresponding; intros.
+ apply refineCorrect'.
inversion Corr as [Vary_In _ _ ]; clear Corr.
pose proof (Vary_In (Right :: p) s) as Hyp; clear Vary_In.
auto.
+ apply refineCorrect in H.
inversion Corr as [_ In_Vary _]; clear Corr.
pose proof (In_Vary (Right :: p)) as Hyp; clear In_Vary.
apply Hyp in H; clear Hyp.
simpl in H.
unfold refineFunction; auto.
+ inversion Corr.
apply refinePreservesPrefixFree.
auto.
Qed.
Next Obligation.
eapply Pref.
instantiate (1:= Right :: p'0).
apply refineCorrect; auto.
instantiate (1:= p2). instantiate (1:=p1). simpl. rewrite H0. auto.
Qed.
intros st p.
generalize dependent st.
induction p.
+ intros st f l Corr Pref.
unfold addToTree.
destruct st.
- auto.
- exfalso.
apply corrEmptyLeaf in Corr.
inversion Corr; clear Corr.
subst.
pose proof Pref [] as Contra; clear Pref.
eapply Contra; clear Contra.
* left; auto.
* instantiate (1 := []). instantiate (1 := []). auto.
- simpl. auto.
+ intros.
destruct st; destruct a; simpl; auto.
- rewrite refineFunCorrect.
apply IHp.
- rewrite refineFunCorrect; apply IHp.
- exfalso. eapply corrEmptyLeaf in Corr; inversion Corr; subst; clear Corr.
pose proof (Pref []).
eapply H.
- subst; left; auto.
- simpl. instantiate (2:= []); rewrite app_nil_r. instantiate (1 := Left ::p); auto.
- exfalso. eapply corrEmptyLeaf in Corr; inversion Corr; subst; clear Corr.
pose proof (Pref []).
eapply H.
- subst; left; auto.
- simpl. instantiate (2:= []); rewrite app_nil_r. instantiate (1 := Right ::p); auto.
- rewrite refineFunCorrect; apply IHp.
- rewrite refineFunCorrect; apply IHp.
Qed.

Lemma addToTreeCorrect2 : forall (st : SeedTree) (p : SplitPath)
(f : SplitPath -> RandomSeed)
(l : list SplitPath) (Corr : correspondingSeedTree l f st)
(Pref : forall p', In p' l -> (forall p1 p2, p ++ p1 = p' ++ p2 -> False)),
forall p' seed, varySeed' st p' = Some seed ->
varySeed' (addToTree st p f l Corr Pref) p' = Some seed.