Require Import Unicode.Utf8 Program.
Require Import ssreflect.
Set Bullet Behavior "Strict Subproofs".

From ctt Require Import Notation Axioms Var.
From ctt Require Tactic.
Module T := Tactic.

Set Implicit Arguments.
Delimit Scope prog_scope with prog.
Delimit Scope subst_scope with subst.

Module Prog.
  Inductive t (Ψ : Ctx) :=
  | var : Var Ψ -> t Ψ
  | fst : t Ψ -> t Ψ
  | snd : t Ψ → t Ψ
  | app : t Ψ → t Ψ → t Ψ
  | kapp : t Ψ → 𝕂 → t Ψ
  | void : t Ψ
  | unit : t Ψ
  | bool : t Ψ
  | ax : t Ψ
  | tt : t Ψ
  | ff : t Ψ
  | prod : t Ψ -> t (S Ψ) -> t Ψ
  | arr : t Ψ -> t (S Ψ) -> t Ψ
  | pair : t Ψ -> t Ψ -> t Ψ
  | lam : t (S Ψ) → t Ψ
  | klam : (𝕂 → t Ψ) → t Ψ
  | ltr : 𝕂 -> t Ψ -> t Ψ
  | isect : (𝕂 → t Ψ) → t Ψ
  | karr : (𝕂 → t Ψ) → t Ψ
  | univ : nat -> t Ψ
  | fix_ : t (S Ψ) → t Ψ.

  Arguments void [Ψ].
  Arguments unit [Ψ].
  Arguments bool [Ψ].
  Arguments ax [Ψ].
  Arguments tt [Ψ].
  Arguments ff [Ψ].
  Arguments univ [Ψ] i.

  Module Notations.
    Notation "@0" := (var Fin.F1) : prog_scope.
    Notation "@1" := (var (Fin.FS Fin.F1)) : prog_scope.
    Notation "▶[ κ ] A" := (ltr κ A%prog) (at level 50) : prog_scope.
    Notation "'𝟚'" := bool : prog_scope.
    Notation "'𝟙'" := unit : prog_scope.
    Notation "'𝟘'" := void : prog_scope.
    Notation "★" := ax : prog_scope.
    Notation "M .1" := (fst M%prog) (at level 50) : prog_scope.
    Notation "M .2" := (snd M%prog) (at level 50) : prog_scope.
    Infix "×" := prod : prog_scope.
    Infix "⇒" := arr (at level 30) : prog_scope.
    Notation "⋂[ κ ] A" := (isect (fun κ => A%prog)) (at level 50) : prog_scope.
    Notation "⋂ A" := (isect A) (at level 50) : prog_scope.
    Notation "𝕌[ i ] " := (univ i%nat) : prog_scope.
    Notation "⟨ M1 , M2 ⟩" := (pair M1%prog M2%prog) : prog_scope.
    Notation "M1 ⋅ M2" := (app M1%prog M2%prog) (at level 50) : prog_scope.
    Notation "'𝛌{' M }" := (lam M%prog) (at level 50) : prog_scope.
    Notation "'𝛍{' M }" := (fix_ M%prog) (at level 50) : prog_scope.
  End Notations.

  Import Notations.

  Program Fixpoint map {Ψ1 Ψ2} (ρ : Ren.t Ψ1 Ψ2) (M : t Ψ1) : t Ψ2 :=
    match M with
    | var i => var (ρ i)
    | fst M => fst (map ρ M)
    | snd M => snd (map ρ M)
    | app M1 M2 => app (map ρ M1) (map ρ M2)
    | kapp M κ => kapp (map ρ M) κ
    | unit => unit
    | void => void
    | bool => bool
    | ax => ax
    | tt => tt
    | ff => ff
    | prod A B => prod (map ρ A) (map (Ren.cong ρ) B)
    | arr A B => arr (map ρ A) (map (Ren.cong ρ) B)
    | pair M1 M2 => pair (map ρ M1) (map ρ M2)
    | lam M => lam (map (Ren.cong ρ) M)
    | klam M => klam (fun κ => map ρ (M κ))
    | ltr κ A => ltr κ (map ρ A)
    | isect A => isect (fun κ => map ρ (A κ))
    | karr A => karr (fun κ => map ρ (A κ))
    | univ i => univ i
    | fix_ M => fix_ (map (Ren.cong ρ) M)
    end.

  Local Ltac rewrites_aux :=
    repeat f_equal;
    try (let x := fresh in T.eqcd => x);
    try (rewrite Ren.cong_id).

  Local Ltac rewrites :=
    T.rewrites_with rewrites_aux.

  Theorem map_id {Ψ} (M : t Ψ) : map id M = M.
  Proof.
    induction M; by rewrites.
  Qed.

  Program Instance syn_struct_term : Sub.syn_struct t :=
    {| Sub.var := var;
       Sub.map := @map |}.
  Next Obligation.
    apply: map_id.
  Qed.

  Module RenNotation.
    Notation "M .[ ρ ]" := (map ρ%ren M) (at level 50) : prog_scope.
  End RenNotation.

  Import RenNotation.

  Program Fixpoint subst {Ψ1 Ψ2} (σ : Sub.t Ψ1 Ψ2) (M : t Ψ1) : t Ψ2 :=
    match M with
    | var i => σ i
    | fst M => fst (subst σ M)
    | snd M => snd (subst σ M)
    | app M1 M2 => app (subst σ M1) (subst σ M2)
    | kapp M κ => kapp (subst σ M) κ
    | void => void
    | unit => unit
    | bool => bool
    | ax => ax
    | tt => tt
    | ff => ff
    | prod A B => prod (subst σ A) (subst (Sub.cong σ) B)
    | arr A B => arr (subst σ A) (subst (Sub.cong σ) B)
    | pair M1 M2 => pair (subst σ M1) (subst σ M2)
    | lam M => lam (subst (Sub.cong σ) M)
    | klam M => klam (fun κ => subst σ (M κ))
    | ltr κ A => ltr κ (subst σ A)
    | isect A => isect (fun κ => subst σ (A κ))
    | karr A => karr (fun κ => subst σ (A κ))
    | univ i => univ i
    | fix_ M => fix_ (subst (Sub.cong σ) M)
    end.

  Module SubstNotation.
    Notation "M ⫽ σ" := (subst σ%subst M%prog) (at level 20, left associativity) : prog_scope.
    Notation "σ' ◎ σ" := (subst σ'%subst ∘ σ%subst) (at level 50) : subst_scope.
  End SubstNotation.

  Import SubstNotation.

  (* TODO: make this part of the syntax-structure type class *)
  Theorem ren_coh {Ψ1 Ψ2 Ψ3} (ρ12 : Ren.t Ψ1 Ψ2) (ρ23 : Ren.t Ψ2 Ψ3) (M : t _) :
    M.[ρ12].[ρ23]%prog
    =
    M.[ρ23 ∘ ρ12]%prog.
  Proof.
    move: Ψ2 Ψ3 ρ12 ρ23.
    induction M; rewrites;
    by dependent induction H.
  Qed.

  (* TODO: derive this generally for any syntax *)
  Theorem ren_subst_cong_coh {Ψ1 Ψ2 Ψ3} (σ12 : Sub.t Ψ1 Ψ2) (ρ23 : Ren.t Ψ2 Ψ3) :
    map (Ren.cong ρ23) ∘ Sub.cong σ12
    =
    Sub.cong (map ρ23 ∘ σ12).
  Proof.
    T.eqcd => x; rewrite /compose; move: Ψ2 Ψ3 σ12 ρ23.
    dependent destruction x;
    T.rewrites_with ltac:(try rewrite ren_coh).
  Qed.

  Local Open Scope prog_scope.

  Theorem ren_subst_coh {Ψ1 Ψ2 Ψ3} (σ12 : Sub.t Ψ1 Ψ2) (ρ23 : Ren.t Ψ2 Ψ3) M :
    (M ⫽ σ12).[ρ23]
    =
    (M ⫽ (map ρ23 ∘ σ12)).
  Proof.
    move: Ψ2 Ψ3 σ12 ρ23.
    induction M; rewrites;
    by rewrite -ren_subst_cong_coh.
  Qed.

  Theorem subst_ren_coh {Ψ1 Ψ2 Ψ3} (ρ12 : Ren.t Ψ1 Ψ2) (σ23 : Sub.t Ψ2 Ψ3) M :
    M.[ρ12] ⫽ σ23
    =
    M ⫽ (σ23 ∘ ρ12).
  Proof.
    move: Ψ2 Ψ3 ρ12 σ23.
    induction M; rewrites;
    f_equal; f_equal;
    by dependent destruction H.
  Qed.

  Theorem subst_coh {Ψ1 Ψ2 Ψ3} (σ12 : Sub.t Ψ1 Ψ2) (σ23 : Sub.t Ψ2 Ψ3) (M : t _) :
    M ⫽ σ12 ⫽ σ23
    =
    M ⫽ (σ23 ◎ σ12).
  Proof.
    move: Ψ2 Ψ3 σ12 σ23.
    rewrite /compose.
    induction M; rewrites;
    dependent induction H; auto; simpl;
    by rewrite ren_subst_coh subst_ren_coh.
  Qed.

  Lemma cong_id {Ψ} : Sub.cong (@var Ψ) = @var (S Ψ).
  Proof.
    T.eqcd => x.
    dependent destruction x; auto.
  Qed.

  Theorem subst_ret {Ψ} M :
    M ⫽ (@var Ψ) = M.
  Proof.
    induction M; rewrites;
    by rewrite cong_id.
  Qed.

  Theorem subst_closed (σ : Sub.t 0 0) (M : t 0) :
    M ⫽ σ = M.
  Proof.
    rewrite -{2}(subst_ret M).
    f_equal.
    T.eqcd => x.
    dependent destruction x.
  Qed.

End Prog.

Export Prog.Notations Prog.RenNotation Prog.SubstNotation.

Hint Rewrite @Prog.subst_ren_coh @Prog.ren_subst_coh @Prog.subst_coh @Prog.subst_closed : syn_db.
Hint Unfold compose : syn_db.

Ltac simplify_subst_step :=
  simpl; autorewrite with syn_db; autounfold with syn_db.

Ltac simplify_subst :=
  repeat (simplify_eqs; f_equal; try T.eqcd; intros; simplify_subst_step).


Require Import Arith List TheoryList.

Require Import ListUtil Tactics Maps.
Require Import Pointer Machine AndersenModel AndersenSound.

Lemma incl_add : forall s a,
  AllocSet.incl s (AllocSet.add s a) = true.
  intros.
  generalize (AllocSet.In_add s a).
  generalize (AllocSet.incl_ok s (AllocSet.add s a)).
  intuition.
  apply H2; intros.
  generalize (H0 x); intuition.
Qed.

Lemma incl_add2 : forall s1 s2 a,
  AllocSet.incl s1 s2 = true
  -> AllocSet.incl (AllocSet.add s1 a) (AllocSet.add s2 a) = true.
  intros.
  generalize (AllocSet.incl_ok s1 s2).
  generalize (AllocSet.incl_ok (AllocSet.add s1 a) (AllocSet.add s2 a)).
  intuition.

  apply H3; intros.
  generalize (AllocSet.In_add s1 a x); intuition; subst.
  eauto.
  generalize (AllocSet.In_add s2 a x); intuition.
Qed.

Hint Resolve incl_add2.

Lemma incl_union2 : forall s1 s2 s3 s4,
  AllocSet.incl s1 s3 = true
  -> AllocSet.incl s2 s4 = true
  -> AllocSet.incl (AllocSet.union s1 s2)
  (AllocSet.union s3 s4) = true.
  intros.
  generalize (AllocSet.incl_ok s1 s3).
  generalize (AllocSet.incl_ok s2 s4).
  generalize (AllocSet.incl_ok (AllocSet.union s1 s2) (AllocSet.union s3 s4)).
  intuition.

  apply H5; intros.
  generalize (AllocSet.In_union H6); intuition eauto.
Qed.

Hint Resolve incl_union2.

Lemma incl_fold1 : forall (f : allocation_site -> AllocSet.set) x ls s,
  AllocSet.In x (fold_left
    (fun known site =>
      AllocSet.union known (f site))
    ls s) = true
  -> (AllocSet.In x s = true
    \/ exists y, In y ls /\ AllocSet.In x (f y) = true).
  induction ls; simpl; intuition.

  generalize (IHls (AllocSet.union s (f a))); intuition.
  destruct (AllocSet.In_union H0); intuition.
  right; eauto.

  destruct H0; intuition.
  right; eauto.
Qed.

Lemma incl_fold2 : forall (f : allocation_site -> AllocSet.set) x ls s,
  (AllocSet.In x s = true
    \/ exists y, In y ls /\ AllocSet.In x (f y) = true)
  -> AllocSet.In x (fold_left
    (fun known site =>
      AllocSet.union known (f site))
    ls s) = true.
  induction ls; simpl; intuition.

  firstorder.

  generalize (IHls (AllocSet.union s (f a))); intuition eauto.

  generalize (IHls (AllocSet.union s (f a))); intuition.
  destruct H0; intuition; subst.
  eauto.
  apply H2.
  eauto.
Qed.

Lemma incl_elems : forall t1 t2 y,
  AllocSet.incl t1 t2 = true
  -> In y (AllocSet.elems t1)
  -> In y (AllocSet.elems t2).
  intros.
  generalize (AllocSet.incl_ok t1 t2).
  generalize (AllocSet.elems_ok t1).
  generalize (AllocSet.elems_ok t2).
  intuition.

  generalize (H1 y).
  generalize (H2 y).
  intuition.
Qed.

Lemma incl_fold_read : forall (f1 f2 : allocation_site -> AllocSet.set) s1 s2 t1 t2,
  (forall a, AllocSet.incl (f1 a) (f2 a) = true)
  -> AllocSet.incl s1 s2 = true
  -> AllocSet.incl t1 t2 = true
  -> AllocSet.incl
  (fold_left
    (fun known site =>
      AllocSet.union known (f1 site))
    (AllocSet.elems t1) s1)
  (fold_left
    (fun known site =>
      AllocSet.union known (f2 site))
    (AllocSet.elems t2) s2) = true.
  intros.

  generalize (AllocSet.incl_ok
    (fold_left
      (fun (known : AllocSet.set) (site : allocation_site) =>
        AllocSet.union known (f1 site)) (AllocSet.elems t1) s1)
    (fold_left
      (fun (known : AllocSet.set) (site : allocation_site) =>
        AllocSet.union known (f2 site)) (AllocSet.elems t2) s2)); intuition.

  apply H4; intros.

  apply incl_fold2.
  destruct (incl_fold1 _ _ _ _ H2) as [Hcase | Hcase].

  eauto.

  destruct Hcase as [y [Helems Hin]].
  right; exists y; intuition.

  eapply incl_elems; eauto.

  eauto.
Qed.

Hint Resolve incl_fold_read.

Lemma incl_fold3' : forall a (f : allocation_site -> AllocSet.set) s ls h,
  AllocMap.sel h a = AllocSet.union (f a) s
  -> AllocMap.sel
  (fold_left (fun known site =>
    AllocMap.upd known site (AllocSet.union (f site) s))
  ls h) a = AllocSet.union (f a) s.
  induction ls; simpl; intuition.
  apply IHls.
  AllocMap_split.
Qed.

Lemma incl_fold3 : forall f s a ls h,
  if In_eq_dec eq_nat_dec a ls
    then AllocMap.sel (fold_left (fun known site =>
      AllocMap.upd known site (AllocSet.union (f site) s))
    ls h) a = AllocSet.union (f a) s
    else AllocMap.sel (fold_left (fun known site =>
      AllocMap.upd known site (AllocSet.union (f site) s))
    ls h) a = AllocMap.sel h a.
  induction ls; simpl; intuition.

  destruct (In_eq_dec eq_nat_dec a nil); trivial.
  inversion i.

  destruct (In_eq_dec eq_nat_dec a (a0 :: ls)).
  simpl in i; intuition; subst.

  apply incl_fold3'; auto.
  apply AllocMap.sel_upd_eq.

  destruct (In_eq_dec eq_nat_dec a ls); intuition.

  destruct (In_eq_dec eq_nat_dec a ls); intuition.

  wrong; intuition.

  rewrite IHls.
  apply AllocMap.sel_upd_neq.
  simpl in n.
  intuition.
Qed.

Lemma incl_fold_write : forall a s1 s2 t1 t2 h1 h2,
  AllocSet.incl (AllocMap.sel h1 a) (AllocMap.sel h2 a) = true
  -> AllocSet.incl s1 s2 = true
  -> AllocSet.incl t1 t2 = true
  -> AllocSet.incl
  (AllocMap.sel (fold_left (fun known site =>
    AllocMap.upd known site (AllocSet.union (AllocMap.sel h1 site) s1))
  (AllocSet.elems t1) h1) a)
  (AllocMap.sel (fold_left (fun known site =>
    AllocMap.upd known site (AllocSet.union (AllocMap.sel h2 site) s2))
  (AllocSet.elems t2) h2) a) = true.
  intros.

  generalize (incl_fold3 (AllocMap.sel h1) s1 a (AllocSet.elems t1) h1).
  generalize (incl_fold3 (AllocMap.sel h2) s2 a (AllocSet.elems t2) h2).
  destruct (In_eq_dec eq_nat_dec a (AllocSet.elems t1));
    destruct (In_eq_dec eq_nat_dec a (AllocSet.elems t2));
      intuition; rewrite H2; rewrite H3; auto.

  wrong.
  generalize (AllocSet.elems_ok t1 a).
  generalize (AllocSet.elems_ok t2 a).
  generalize (AllocSet.incl_ok t1 t2).
  intuition.

  apply AllocSet.incl_trans with (AllocMap.sel h2 a); auto.
Qed.

Hint Resolve incl_fold_write.

Definition ins_sites i :=
  match i with
    | AbsAllocate _ site => AllocSet.add AllocSet.empty site
    | _ => AllocSet.empty
  end.

Module VarSet : SET with Definition dom := var := AllocSet.

Definition ins_vars i :=
  match i with
    | AbsAllocate v _ => VarSet.add VarSet.empty v
    | AbsCopy v1 v2 => VarSet.add (VarSet.add VarSet.empty v1) v2
    | AbsRead v1 v2 => VarSet.add (VarSet.add VarSet.empty v1) v2
    | AbsWrite v1 v2 => VarSet.add (VarSet.add VarSet.empty v1) v2
  end.

Section prog.
  Variable program : list abstract_instruction.

  Definition pSites := fold_left AllocSet.union (map ins_sites program).
  Definition pVars := fold_left VarSet.union (map ins_vars program).
End prog.

Section fixed_point.
  Variable program : list abstract_instruction.

  Definition progSites := pSites program AllocSet.empty.
  Definition progVars := pVars program VarSet.empty.

  Record approx' (abs1 abs2 : abstract_state) : Prop := {
    approxVars : forall v, AllocSet.incl
      (VarMap.sel (avars abs1) v) (VarMap.sel (avars abs2) v) = true;
    approxHeap : forall a, AllocSet.incl
      (AllocMap.sel (aheap abs1) a) (AllocMap.sel (aheap abs2) a) = true
  }.

  Lemma increasing' : forall abs ins,
    approx' abs (abstract_exec ins abs).
    destruct ins; intuition; simpl.

    VarMap_split; apply incl_add.

    VarMap_split.

    VarMap_split; apply incl_fold_union.

    apply incl_write_bonanza.
  Qed.

  Lemma monotonic' : forall abs abs' ins,
    approx' abs abs'
    -> approx' (abstract_exec ins abs) (abstract_exec ins abs').
    destruct ins; intuition; simpl.

    destruct (eq_nat_dec v v0); subst.
    repeat rewrite VarMap.sel_upd_eq; eauto.
    repeat rewrite VarMap.sel_upd_neq; eauto.

    destruct (eq_nat_dec v v1); subst.
    repeat rewrite VarMap.sel_upd_eq; eauto.
    repeat rewrite VarMap.sel_upd_neq; eauto.

    destruct (eq_nat_dec v v1); subst.
    repeat rewrite VarMap.sel_upd_eq; eauto.
    repeat rewrite VarMap.sel_upd_neq; eauto.

    eauto.
  Qed.

  Lemma approx_refl' : forall s, approx' s s.
    intuition.
  Qed.

  Lemma approx_trans' : forall s1 s2 s3,
    approx' s1 s2 -> approx' s2 s3 -> approx' s1 s3.
    intuition.
    eapply AllocSet.incl_trans; eauto.
    eapply AllocSet.incl_trans; eauto.
  Qed.

  Lemma approx_init' : forall s, approx' abstract_initState s.
    unfold abstract_initState; intuition; simpl; intuition.
    rewrite VarMap.sel_init; apply AllocSet.incl_empty.
    rewrite AllocMap.sel_init; apply AllocSet.incl_empty.
  Qed.

  Record valid (abs : abstract_state) : Prop := {
    validVarsDom : forall v, VarSet.In v progVars = false
      -> AllocSet.incl (VarMap.sel (avars abs) v) AllocSet.empty = true;
    validHeapDom : forall a, AllocSet.In a progSites = false
      -> AllocSet.incl (AllocMap.sel (aheap abs) a) AllocSet.empty = true;
    validVars : forall v, AllocSet.incl (VarMap.sel (avars abs) v) progSites = true;
    validHeap : forall a, AllocSet.incl (AllocMap.sel (aheap abs) a) progSites = true
  }.

  Definition astate := sig valid.

  Definition approx (abs1 abs2 : astate) := approx' (proj1_sig abs1) (proj1_sig abs2).

  Record approxStrict (abs1 abs2 : astate) : Prop := {
    strictApprox : approx abs2 abs1;
    strictNe : (exists v, VarSet.In v progVars = true
      /\ AllocSet.incl (VarMap.sel (avars (proj1_sig abs1)) v)
      (VarMap.sel (avars (proj1_sig abs2)) v) = false)
    \/ exists a, AllocSet.In a progSites = true
      /\ AllocSet.incl (AllocMap.sel (aheap (proj1_sig abs1)) a)
      (AllocMap.sel (aheap (proj1_sig abs2)) a) = false
  }.

  Definition ainstruction := sig (fun ins => In ins program).

  Lemma fold_In_union : forall a ls s,
    AllocSet.In a s = true
    -> AllocSet.In a (fold_left AllocSet.union ls s) = true.
    induction ls; simpl; intuition eauto.
  Qed.

  Hint Resolve VarSet.incl_In VarSet.incl_union_left.

  Lemma fold_In_unionv : forall a ls s,
    VarSet.In a s = true
    -> VarSet.In a (fold_left VarSet.union ls s) = true.
    induction ls; simpl; intuition eauto.
  Qed.

  Lemma allocate_site : forall v a prog s,
    In (AbsAllocate v a) prog
      -> AllocSet.In a (pSites prog s) = true.
    unfold pSites.

    induction prog; simpl; intuition; subst.

    unfold pSites; simpl.
    apply fold_In_union; eauto.
  Qed.

  Lemma incl_add3 : forall x s1 s2,
    AllocSet.In x s2 = true
    -> AllocSet.incl s1 s2 = true
    -> AllocSet.incl (AllocSet.add s1 x) s2 = true.
    intros.
    generalize (AllocSet.incl_ok (AllocSet.add s1 x) s2); intuition.
    apply H3; intros.
    generalize (AllocSet.In_add s1 x x0);
      generalize (AllocSet.incl_ok s1 s2);
	intuition; subst; intuition.
  Qed.

  Lemma incl_union : forall s1 s2 s3,
    AllocSet.incl s1 s3 = true
    -> AllocSet.incl s2 s3 = true
    -> AllocSet.incl (AllocSet.union s1 s2) s3 = true.
    intros.
    generalize (AllocSet.incl_ok (AllocSet.union s1 s2) s3); intuition.
    apply H3; intros.
    generalize (AllocSet.incl_ok s1 s3);
      generalize (AllocSet.incl_ok s2 s3);
	generalize (AllocSet.In_union H1);
	  intuition.
  Qed.

  Lemma incl_valid_read : forall (f : allocation_site -> AllocSet.set) s2 ls s1,
    AllocSet.incl s1 s2 = true
    -> (forall site, AllocSet.incl (f site) s2 = true)
    -> AllocSet.incl
    (fold_left
      (fun known site => AllocSet.union known (f site))
      ls s1) s2 = true.
    induction ls; simpl; intuition.
    apply IHls; auto.
    apply incl_union; auto.
  Qed.

  Lemma incl_valid_write : forall a s1 s2 f ls h,
    AllocSet.incl s1 s2 = true
    -> (forall a, AllocSet.incl (f a) s2 = true)
    -> (forall a, AllocSet.incl (AllocMap.sel h a) s2 = true)
    -> AllocSet.incl
    (AllocMap.sel
      (fold_left
	(fun known site => AllocMap.upd known site
          (AllocSet.union (f site) s1))
	ls h) a)
    s2 = true.
    induction ls; simpl; intuition.

    apply IHls; intuition.
    AllocMap_split.
    apply incl_union; auto.
  Qed.

  Hint Resolve VarSet.In_add_eq VarSet.In_add_neq VarSet.incl_union_right.

  Lemma allocate_var : forall v a prog s,
    In (AbsAllocate v a) prog
      -> VarSet.In v (pVars prog s) = true.
    unfold pVars.

    induction prog; simpl; intuition; subst.

    unfold pVars; simpl.
    apply fold_In_unionv; eauto.
  Qed.

  Lemma copy_var : forall v a prog s,
    In (AbsCopy v a) prog
      -> VarSet.In v (pVars prog s) = true.
    unfold pVars.

    induction prog; simpl; intuition; subst.

    unfold pVars; simpl.
    apply fold_In_unionv.
    apply VarSet.incl_In with (VarSet.add (VarSet.add VarSet.empty v) a).
    eauto.
    destruct (eq_nat_dec v a); subst; eauto.
    rewrite VarSet.In_add_neq; auto.
  Qed.

  Lemma read_var : forall v a prog s,
    In (AbsRead v a) prog
      -> VarSet.In v (pVars prog s) = true.
    unfold pVars.

    induction prog; simpl; intuition; subst.

    unfold pVars; simpl.
    apply fold_In_unionv.
    apply VarSet.incl_In with (VarSet.add (VarSet.add VarSet.empty v) a).
    eauto.
    destruct (eq_nat_dec v a); subst; eauto.
    rewrite VarSet.In_add_neq; auto.
  Qed.

  Lemma write_var : forall v a prog s,
    In (AbsWrite v a) prog
      -> VarSet.In v (pVars prog s) = true.
    unfold pVars.

    induction prog; simpl; intuition; subst.

    unfold pVars; simpl.
    apply fold_In_unionv.
    apply VarSet.incl_In with (VarSet.add (VarSet.add VarSet.empty v) a).
    eauto.
    destruct (eq_nat_dec v a); subst; eauto.
    rewrite VarSet.In_add_neq; auto.
  Qed.

  Lemma sel_write_valid : forall f s a ls h,
    AllocMap.sel
    (fold_left (fun known site => AllocMap.upd known site
      (AllocSet.union (f site) s))
    ls h) a
    = if In_eq_dec eq_nat_dec a ls
      then AllocSet.union (f a) s
      else AllocMap.sel h a.
    induction ls; simpl; intuition;
      match goal with
	| [ |- context[if ?X then _ else _] ] => destruct X
      end; simpl in *; intuition; subst; intuition.

    apply incl_fold3'; apply AllocMap.sel_upd_eq.

    destruct (In_eq_dec eq_nat_dec a ls); intuition.

    destruct (In_eq_dec eq_nat_dec a ls); intuition.
    rewrite IHls.
    rewrite AllocMap.sel_upd_neq; auto.
  Qed.

  Lemma aexec' : forall ins abs, In ins program -> valid abs -> valid (abstract_exec ins abs).
    intros ins abs Hins Habs.
    destruct Habs.
    destruct ins; split; simpl; intuition.

    VarMap_split.
    wrong.
    unfold progVars in H; rewrite allocate_var with v0 a program VarSet.empty in H;
      auto; discriminate.

    VarMap_split.
    apply incl_add3; auto.
    unfold progSites; eapply allocate_site; eauto.

    VarMap_split.
    wrong.
    unfold progVars in H; rewrite copy_var with v1 v0 program VarSet.empty in H;
      auto; discriminate.

    VarMap_split.
    apply incl_union; auto.

    VarMap_split.
    unfold progVars in H; rewrite read_var with v1 v0 program VarSet.empty in H;
      auto; discriminate.

    VarMap_split.
    apply incl_valid_read; auto.

    rewrite sel_write_valid.
    match goal with
      | [ |- context[if ?X then _ else _] ] => destruct X
    end; auto.
    caseEq (VarSet.In v progVars); intro Hin.
    assert (false = true); [idtac | discriminate].
    rewrite <- H.
    apply AllocSet.incl_In with (VarMap.sel (avars abs) v); auto.
    generalize (AllocSet.elems_ok (VarMap.sel (avars abs) v)); intuition.
    generalize (H0 a); intuition.
    unfold progVars in Hin; rewrite write_var with v v0 program VarSet.empty in Hin;
      auto; discriminate.

    apply incl_valid_write; auto.
  Qed.

  Definition aexec : ainstruction -> astate -> astate.
    intros ins abs.
    destruct ins as [ins Hins].
    destruct abs as [abs Habs].
    exists (abstract_exec ins abs).
    apply aexec'; trivial.
  Defined.

  Definition ainitState : astate.
    exists abstract_initState.
    unfold abstract_initState.
    split; simpl; intuition.

    rewrite VarMap.sel_init; apply AllocSet.incl_empty.
    rewrite AllocMap.sel_init; apply AllocSet.incl_empty.
    rewrite VarMap.sel_init; apply AllocSet.incl_empty.
    rewrite AllocMap.sel_init; apply AllocSet.incl_empty.
  Defined.

  Lemma ainstr_widen : forall h t,
    {ins : abstract_instruction | In ins t}
    -> {ins : abstract_instruction | In ins (h :: t)}.
    intros.
    destruct H as [ins Hins].
    exists ins.
    intuition.
  Defined.

  Definition aprogram' : forall (prog : list abstract_instruction),
    list (sig (fun ins => In ins prog)).
    refine (fix aprogram' (prog : list abstract_instruction)
      : list (sig (fun ins => In ins prog)) :=
      match prog return list (sig (fun ins => In ins prog)) with
	| nil => nil
	| h :: t => exist _ h _ :: map (ainstr_widen _ _) (aprogram' t)
      end); intuition.
  Defined.

  Definition aprogram := aprogram' program.

  Theorem increasing : forall abs ins,
    approx abs (aexec ins abs).
    destruct abs as [abs Habs].
    destruct ins as [ins Hins].
    unfold approx.
    simpl.
    apply increasing'.
  Qed.

  Hint Resolve increasing.

  Theorem monotonic : forall abs abs' ins,
    approx abs abs'
    -> approx (aexec ins abs) (aexec ins abs').
    destruct abs as [abs Habs].
    destruct abs' as [abs' Habs'].
    destruct ins as [ins Hins].
    unfold approx.
    simpl.
    apply monotonic'.
  Qed.

  Hint Resolve monotonic.

  Theorem approx_refl : forall s, approx s s.
    destruct s as [s Hs].
    unfold approx.
    simpl.
    apply approx_refl'.
  Qed.

  Hint Resolve approx_refl.

  Theorem approx_trans : forall s1 s2 s3,
    approx s1 s2 -> approx s2 s3 -> approx s1 s3.
    destruct s1.
    destruct s2.
    destruct s3.
    unfold approx.
    simpl.
    apply approx_trans'.
  Qed.

  Hint Resolve approx_trans.

  Theorem approx_init : forall s, approx ainitState s.
    destruct s.
    unfold approx, ainitState.
    simpl.
    apply approx_init'.
  Qed.

  Hint Resolve approx_init.

  Hint Resolve AllocSet.incl_empty.

  Theorem approxStrict_approx : forall s1 s2,
    approx s2 s1
    -> ~approxStrict s1 s2
    -> approx s1 s2.
    destruct s1.
    destruct s2.
    intuition.
    destruct H.
    split; simpl in *; intuition.

    caseEq (AllocSet.incl (VarMap.sel (avars x) v1) (VarMap.sel (avars x0) v1)); intro Heq; trivial.
    wrong.
    apply H0.
    intuition.
    unfold approx; simpl; intuition.
    left.
    exists v1.
    intuition.

    inversion v.
    caseEq (VarSet.In v1 progVars); intro Heq'; trivial.
    rewrite <- Heq.
    apply AllocSet.incl_trans with AllocSet.empty; eauto.

    caseEq (AllocSet.incl (AllocMap.sel (aheap x) a) (AllocMap.sel (aheap x0) a));
    intro Heq; trivial.
    wrong.
    apply H0.
    intuition.
    unfold approx; simpl; intuition.
    right.
    exists a.
    intuition.

    inversion v.
    caseEq (AllocSet.In a progSites); intro Heq'; trivial.
    rewrite <- Heq.
    apply AllocSet.incl_trans with AllocSet.empty; eauto.
  Qed.

  Hint Resolve approxStrict_approx.

  Theorem approxStrict_trans : forall s1 s2 s3,
    approx s2 s1 -> approxStrict s2 s3 -> approxStrict s1 s3.
    destruct s1.
    destruct s2.
    destruct s3.
    unfold approx; simpl.
    intuition; unfold approx in *; simpl in *; intuition.

    eapply AllocSet.incl_trans; eauto.

    eapply AllocSet.incl_trans; eauto.

    left.
    destruct H as [v' [Hin Hincl]].
    exists v'; intuition.
    caseEq (AllocSet.incl (VarMap.sel (avars x) v') (VarMap.sel (avars x1) v')); trivial; intro Heq.
    rewrite <- Hincl.
    symmetry.
    eapply AllocSet.incl_trans; eauto.

    eapply AllocSet.incl_trans; eauto.
    eapply AllocSet.incl_trans; eauto.

    right.
    destruct H as [a [Hin Hincl]].
    exists a; intuition.
    caseEq (AllocSet.incl (AllocMap.sel (aheap x) a) (AllocMap.sel (aheap x1) a)); trivial; intro Heq.
    rewrite <- Hincl.
    symmetry.
    eapply AllocSet.incl_trans; eauto.
  Qed.

  Hint Resolve approxStrict_trans.

  Definition approx_dec : forall abs1 abs2, {approx abs1 abs2} + {~approx abs1 abs2}.
    destruct abs1 as [abs1 Habs1].
    destruct abs2 as [abs2 Habs2].

    assert (checkVar : forall v,
      {AllocSet.incl
	(VarMap.sel (avars abs1) v)
	(VarMap.sel (avars abs2) v) = true}
      + {~AllocSet.incl
	(VarMap.sel (avars abs1) v)
	(VarMap.sel (avars abs2) v) = true}).
    intro.
    destruct (AllocSet.incl (VarMap.sel (avars abs1) v)
      (VarMap.sel (avars abs2) v)); auto.

    assert (checkHeap : forall v,
      {AllocSet.incl
	(AllocMap.sel (aheap abs1) v)
	(AllocMap.sel (aheap abs2) v) = true}
      + {~AllocSet.incl
	(AllocMap.sel (aheap abs1) v)
	(AllocMap.sel (aheap abs2) v) = true}).
    intro.
    destruct (AllocSet.incl (AllocMap.sel (aheap abs1) v)
      (AllocMap.sel (aheap abs2) v)); auto.

    refine (match AllS_dec (fun v => AllocSet.incl
      (VarMap.sel (avars abs1) v)
      (VarMap.sel (avars abs2) v) = true)
    checkVar (VarSet.elems progVars) with
	      | left Hvars =>
		match AllS_dec (fun v => AllocSet.incl
		  (AllocMap.sel (aheap abs1) v)
		  (AllocMap.sel (aheap abs2) v) = true)
		checkHeap (AllocSet.elems progSites) with
		  | left Hheap => left _ _
		  | right Hheap => right _ _
		end
	      | right Hvars => right _ _
	    end); intuition.

    unfold approx in *; simpl in *; intuition.

    caseEq (VarSet.In v progVars); intro Heq.
    pattern v; eapply AllS_In; eauto.
    generalize (VarSet.elems_ok progVars); intuition.
    generalize (H v); intuition.

    inversion Habs1.
    apply AllocSet.incl_trans with AllocSet.empty; eauto.

    caseEq (AllocSet.In a progSites); intro Heq.
    pattern a; eapply AllS_In; eauto.
    generalize (AllocSet.elems_ok progSites); intuition.
    generalize (H a); intuition.

    inversion Habs1.
    apply AllocSet.incl_trans with AllocSet.empty; eauto.

    unfold approx in H; simpl in H; intuition.
    apply Hheap.
    apply AllS_deduce; auto.

    unfold approx in H; simpl in H; intuition.
    apply Hvars.
    apply AllS_deduce; auto.
  Qed.

  Definition approxStrict_dec : forall abs1 abs2, {approxStrict abs1 abs2} + {~approxStrict abs1 abs2}.
    destruct abs1 as [abs1 Habs1].
    destruct abs2 as [abs2 Habs2].

    assert (checkVar : forall v,
      {AllocSet.incl (VarMap.sel (avars abs1) v)
	(VarMap.sel (avars abs2) v) = true}
      + {~AllocSet.incl (VarMap.sel (avars abs1) v)
	(VarMap.sel (avars abs2) v) = true}).
    intros.
    match goal with
      [ |- {?X = true} + {_} ] => destruct X
    end; intuition.

    assert (checkHeap : forall v,
      {AllocSet.incl (AllocMap.sel (aheap abs1) v)
	(AllocMap.sel (aheap abs2) v) = true}
      + {~AllocSet.incl (AllocMap.sel (aheap abs1) v)
	(AllocMap.sel (aheap abs2) v) = true}).
    intros.
    match goal with
      [ |- {?X = true} + {_} ] => destruct X
    end; intuition.

    refine (match approx_dec (exist _ abs2 Habs2) (exist _ abs1 Habs1) with
	      | left Happrox =>
		match AllS_dec_some (fun v => AllocSet.incl (VarMap.sel (avars abs1) v)
		  (VarMap.sel (avars abs2) v) = true)
		checkVar (VarSet.elems progVars) with
		  | left Hvars =>
		    match AllS_dec_some (fun v => AllocSet.incl (AllocMap.sel (aheap abs1) v)
		      (AllocMap.sel (aheap abs2) v) = true)
		    checkHeap (AllocSet.elems progSites) with
		      | left Hheap => right _ _
		      | right Hheap => left _ _
		    end
		  | right Hvars => left _ _
		end
	      | right Happrox => right _ _
	    end); intuition; try (injection Heq; intros; subst; intuition).

    destruct H as [v [Hin Hincl]].
    simpl in *; idtac.
    rewrite (AllS_In Hvars) in Hincl; try discriminate.
    generalize (VarSet.elems_ok progVars); intuition.
    generalize (H v); intuition.

    destruct H as [a [Hin Hincl]].
    simpl in *; idtac.
    rewrite (AllS_In Hheap) in Hincl; try discriminate.
    generalize (AllocSet.elems_ok progSites); intuition.
    generalize (H a); intuition.

    right.
    destruct (AllS_not (f := fun v : AllocMap.dom =>
      AllocSet.incl (AllocMap.sel (aheap abs1) v)
      (AllocMap.sel (aheap abs2) v) = true) checkHeap H); intuition.
    destruct H1 as [x [Hin Hincl]].
    exists x; simpl; intuition.
    generalize (AllocSet.elems_ok progSites); intuition.
    generalize (H1 x); intuition.
    match goal with
      | [ |- ?X = _ ] => destruct X
    end; intuition.

    left.
    destruct (AllS_not (f := fun v : VarMap.dom =>
      AllocSet.incl (VarMap.sel (avars abs1) v)
      (VarMap.sel (avars abs2) v) = true) checkVar H); intuition.
    destruct H1 as [x [Hin Hincl]].
    exists x; simpl; intuition.
    generalize (VarSet.elems_ok progVars); intuition.
    generalize (H1 x); intuition.
    match goal with
      | [ |- ?X = _ ] => destruct X
    end; intuition.
  Qed.

  Hint Resolve approxStrict_dec.

  Fixpoint distinct (ls : list nat) : Prop :=
    match ls with
      | nil => True
      | h::t => AllS (fun x => x <> h) t
	/\ distinct t
    end.

  Definition cardinality_atLeast s n :=
    exists ls, distinct ls
      /\ length ls = n
      /\ AllS (fun x => AllocSet.In x s = true) ls.

  Definition cardinality s n :=
    cardinality_atLeast s n
    /\ forall n', cardinality_atLeast s n' -> n' <= n.

  Definition bound := length (AllocSet.elems progSites).

  Definition neq_nat_dec : forall (x y : nat), {x <> y} + {~x <> y}.
    intros.
    destruct (eq_nat_dec x y); auto.
  Defined.

  Definition distinctify : forall (ls : list allocation_site),
    {ls' : list allocation_site | distinct ls'
      /\ forall x, In x ls <-> In x ls'}.
    induction ls.

    exists (@nil allocation_site); simpl; intuition.

    destruct IHls as [ls' [Hdist Hin]].
    destruct (AllS_dec (fun x => x <> a) (fun x => neq_nat_dec x a) ls').
    exists (a :: ls'); simpl; firstorder.

    destruct (AllS_not_dec (f := fun x : allocation_site => x <> a)
      (fun x => neq_nat_dec x a) n) as [[x [Hin' Hnot]] | Heq].
    exists ls'; intuition.
    generalize (Hin x0); intuition.
    simpl in H; intuition; subst.
    replace x0 with x; auto.
    destruct (eq_nat_dec x x0); intuition.

    simpl; right.
    generalize (Hin x0); intuition.

    rewrite Heq in n.
    wrong.
    intuition.
  Qed.

  Lemma incl_S : forall (ls : list allocation_site) a,
    In a ls
    -> exists ls', length ls = S (length ls')
      /\ incl ls (a :: ls').
    induction ls; simpl; intuition; subst.
    firstorder.

    destruct (eq_nat_dec a0 a); subst.
    exists ls; intuition.

    destruct (IHls _ H0) as [ls' [Hlen Hincl]].
    rewrite Hlen.
    exists (a :: ls'); intuition.
    red; intros.
    red in Hincl.
    simpl in *; intuition.
    destruct (Hincl a1); intuition.
  Qed.

  Lemma incl_trans' : forall (a : allocation_site) ls1 ls2,
    distinct (a :: ls1)
    -> incl (a :: ls1) (a :: ls2)
    -> incl ls1 ls2.
    unfold incl; intuition.
    destruct (eq_nat_dec a0 a); subst.
    simpl in H; intuition.
    wrong.

    generalize H1 H2; clear_all.
    induction ls1; simpl; intuition; subst.
    generalize (AllS_In H2 a); intuition.
    apply H0.
    inversion H2; intuition.

    assert (In a0 (a :: ls2)).
    intuition.
    inversion H2; intuition.
    wrong; intuition.
  Qed.

  Lemma incl_length : forall (ls1 ls2 : list allocation_site),
    incl ls1 ls2
    -> distinct ls1
    -> length ls1 <= length ls2.
    induction ls1.

    destruct ls2; intuition.

    simpl; intuition.
    assert (exists ls', length ls2 = S (length ls')
      /\ incl ls2 (a :: ls')).
    apply incl_S; intuition.
    destruct H0 as [ls' [Hlen Hincl]].
    rewrite Hlen.
    generalize (IHls1 ls'); intuition.
    assert (incl ls1 ls').
    apply incl_trans' with a; simpl; intuition.
    red; intros.
    inversion H3; subst; intuition.

    intuition.
  Qed.

  Lemma card : forall s,
    AllocSet.incl s progSites = true
    -> {n : nat
      | n <= bound
	/\ cardinality s n}.
    intros.
    destruct (distinctify (AllocSet.elems s)) as [ls [Hdis Hin]].
    exists (length ls); intuition.

    unfold bound.
    generalize (AllocSet.elems_ok progSites).
    generalize (AllocSet.elems_ok s).
    generalize (AllocSet.incl_ok s progSites).
    intuition.
    apply incl_length; auto.
    red; intros.
    generalize (Hin a); intuition.
    generalize (H1 a).
    generalize (H0 a).
    generalize (H2 a).
    intuition.

    split.
    unfold cardinality_atLeast.
    exists ls; intuition.
    apply AllS_deduce; intuition.
    generalize (AllocSet.elems_ok s); intuition.
    generalize (H1 x); intuition.
    apply H3.
    generalize (Hin x); intuition.

    intros.
    destruct H0 as [ls' Hls']; intuition.
    rewrite <- H2.
    apply incl_length; auto.
    red; intros.
    generalize (AllS_In H3 _ H1); intro Hin'.
    generalize (AllocSet.elems_ok s).
    generalize (Hin a); intuition.
    apply H6.
    generalize (H5 a); intuition.
  Qed.

  Definition var_bounded : forall (abs : astate) (v : var),
    AllocSet.incl (VarMap.sel (avars (proj1_sig abs)) v) progSites = true.
    destruct abs as [abs Habs]; simpl.
    inversion Habs.
    eauto.
  Qed.

  Definition site_bounded : forall (abs : astate) (s : allocation_site),
    AllocSet.incl (AllocMap.sel (aheap (proj1_sig abs)) s) progSites = true.
    destruct abs as [abs Habs]; simpl.
    inversion Habs.
    eauto.
  Qed.

  Definition size (abs : astate) :=
    fold_right plus 0 (map (fun x => proj1_sig (card _ (var_bounded abs x)))
      (VarSet.elems progVars))
    + fold_right plus 0 (map (fun x => proj1_sig (card _ (site_bounded abs x)))
      (AllocSet.elems progSites)).

  Lemma mult_le : forall n x m y,
    x <= n * m
    -> y <= n
    -> y + x <= n * S m.
    intros.
    replace (n * S m) with (n + n * m).
    omega.

    clear_all.
    induction n; simpl; intuition.
  Qed.

  Lemma size_bounded : forall abs,
    size abs <= bound * (length (VarSet.elems progVars) + length (AllocSet.elems progSites)).
    unfold size.
    intros.
    induction (VarSet.elems progVars); simpl.

    induction (AllocSet.elems progSites); simpl; intuition.

    destruct (card (AllocMap.sel (aheap (proj1_sig abs)) a) (site_bounded abs a)); simpl; intuition.
    apply mult_le; trivial.

    destruct (card (VarMap.sel (avars (proj1_sig abs)) a) (var_bounded abs a)); simpl; intuition.
    generalize (mult_le _ _ _ _ IHl H).
    omega.
  Qed.

  Lemma fold_plus_ge : forall (A : Set) f1 f2 (ls : list A),
    AllS (fun x => f1 x >= f2 x) ls
    -> fold_right plus 0 (map f1 ls) >= fold_right plus 0 (map f2 ls).
    induction ls; simpl; intuition.
    inversion H; subst.
    intuition.
  Qed.

  Lemma fold_plus_gt : forall (A : Set) f1 f2 x,
    f1 x > f2 x
    -> forall (ls : list A), AllS (fun x => f1 x >= f2 x) ls
    -> In x ls
    -> fold_right plus 0 (map f1 ls) > fold_right plus 0 (map f2 ls).
    induction ls; simpl; intuition; subst.

    inversion H0; subst.
    generalize (fold_plus_ge _ _ _ _ H4).
    omega.

    inversion H0; subst.
    intuition.
  Qed.

  Lemma sum_plus1 : forall x1 y1 x2 y2,
    x1 > x2
    -> y1 >= y2
    -> x1 + y1 > x2 + y2.
    intros; omega.
  Qed.

  Lemma sum_plus2 : forall x1 y1 x2 y2,
    x1 >= x2
    -> y1 > y2
    -> x1 + y1 > x2 + y2.
    intros; omega.
  Qed.

  Lemma incl_cardinality' : forall s1 s2 c,
    AllocSet.incl s1 s2 = true
    -> cardinality_atLeast s1 c
    -> cardinality_atLeast s2 c.
    intros.
    destruct H0 as [ls]; intuition.
    exists ls; intuition.
    apply AllS_deduce; intros.
    apply AllocSet.incl_In with s1; auto.
    apply (AllS_In H3); auto.
  Qed.

  Lemma incl_cardinality : forall s1 s2 c1 c2,
    AllocSet.incl s1 s2 = true
    -> cardinality s1 c1
    -> cardinality s2 c2
    -> c1 <= c2.
    intros.
    destruct H0.
    destruct H1.
    destruct H1 as [ls2 Hls2].
    intuition.

    apply H3.
    eapply incl_cardinality'; eauto.
  Qed.

  Lemma incl_gt : forall (x : allocation_site) ls2 ls1,
    distinct ls1
    -> incl ls1 ls2
    -> ~In x ls1
    -> In x ls2
    -> length ls2 > length ls1.
    intros.

    assert (incl (x :: ls1) ls2).
    red; simpl; intuition; subst; trivial.

    assert (length (x :: ls1) <= length ls2).
    apply incl_length; trivial.
    split; intuition.
    apply AllS_deduce.
    intros; subst; auto.

    simpl in H4.
    unfold allocation_site in H4.
    omega.
  Qed.

  Lemma set_grew : forall s1 s2 c1 c2,
    AllocSet.incl s2 s1 = true
    -> AllocSet.incl s1 s2 = false
    -> cardinality s1 c1
    -> cardinality s2 c2
    -> c1 > c2.
    intros.

    destruct (AllocSet.incl_false H0) as [x [Hyes Hno]].

    destruct H1.
    destruct H2.
    destruct H1 as [ls1 Hls1].
    destruct H2 as [ls2 Hls2]; intuition.

    subst.
    apply incl_gt with x; eauto.

    red; intros.
    destruct (In_dec eq_nat_dec a ls1); trivial.
    wrong.
    assert (S (length ls1) <= length ls1).
    apply H3.
    exists (a :: ls1); simpl; intuition.
    apply AllS_deduce.
    intros; subst; auto.
    constructor; intuition.
    apply AllocSet.incl_In with s2; auto.
    apply (AllS_In H9); auto.
    omega.

    intro.
    assert (AllocSet.In x s2 = true).
    apply (AllS_In H9); auto.
    congruence.

    destruct (In_dec eq_nat_dec x ls1); trivial.
    wrong.
    assert (S (length ls1) <= length ls1).
    apply H3.
    exists (x :: ls1); simpl; intuition.
    apply AllS_deduce.
    intros; subst; auto.
    omega.
  Qed.

  Lemma size_approxStrict : forall abs abs',
    approxStrict abs abs'
    -> size abs > size abs'.
    destruct abs as [abs Habs].
    destruct abs' as [abs' Habs'].
    intros.
    destruct H; simpl in *; idtac.
    destruct strictNe0 as [[v [Hin Hincl]] | [a [Hin Hincl]]].

    unfold size; simpl.
    apply sum_plus1.

    apply fold_plus_gt with v.
    destruct (card (VarMap.sel (avars abs) v)
      (var_bounded (exist valid abs Habs) v)) as [c1 [Hlt1 Hc1]]; simpl.
    destruct (card (VarMap.sel (avars abs') v)
      (var_bounded (exist valid abs' Habs') v)) as [c2 [Hlt2 Hc2]]; simpl.
    apply set_grew with (VarMap.sel (avars abs) v) (VarMap.sel (avars abs') v); intuition.
    destruct strictApprox0.
    simpl in *; auto.

    apply AllS_deduce; intros.
    destruct (card (VarMap.sel (avars abs) x)
      (var_bounded (exist valid abs Habs) x)) as [c1 [Hlt1 Hc1]]; simpl.
    destruct (card (VarMap.sel (avars abs') x)
      (var_bounded (exist valid abs' Habs') x)) as [c2 [Hlt2 Hc2]]; simpl.
    assert (c2 <= c1); try omega.
    apply incl_cardinality with (VarMap.sel (avars abs') x) (VarMap.sel (avars abs) x); auto.
    destruct strictApprox0.
    simpl in *; auto.

    generalize (VarSet.elems_ok progVars); intuition.
    generalize (H v); intuition.

    apply fold_plus_ge.
    apply AllS_deduce; intros.
    destruct (card (AllocMap.sel (aheap abs) x)
      (site_bounded (exist valid abs Habs) x)) as [c1 [Hlt1 Hc1]]; simpl.
    destruct (card (AllocMap.sel (aheap abs') x)
        (site_bounded (exist valid abs' Habs') x)) as [c2 [Hlt2 Hc2]]; simpl.
    assert (c2 <= c1); try omega.
    apply incl_cardinality with (AllocMap.sel (aheap abs') x) (AllocMap.sel (aheap abs) x); auto.
    destruct strictApprox0.
    simpl in *; auto.

    unfold size; simpl.
    apply sum_plus2.

    apply fold_plus_ge.
    apply AllS_deduce; intros.
    destruct (card (VarMap.sel (avars abs) x)
      (var_bounded (exist valid abs Habs) x)) as [c1 [Hlt1 Hc1]]; simpl.
    destruct (card (VarMap.sel (avars abs') x)
        (var_bounded (exist valid abs' Habs') x)) as [c2 [Hlt2 Hc2]]; simpl.
    assert (c2 <= c1); try omega.
    apply incl_cardinality with (VarMap.sel (avars abs') x) (VarMap.sel (avars abs) x); auto.
    destruct strictApprox0.
    simpl in *; auto.

    apply fold_plus_gt with a.
    destruct (card (AllocMap.sel (aheap abs) a)
        (site_bounded (exist valid abs Habs) a)) as [c1 [Hlt1 Hc1]]; simpl.
    destruct (card (AllocMap.sel (aheap abs') a)
        (site_bounded (exist valid abs' Habs') a)) as [c2 [Hlt2 Hc2]]; simpl.
    apply set_grew with (AllocMap.sel (aheap abs) a) (AllocMap.sel (aheap abs') a); intuition.
    destruct strictApprox0.
    simpl in *; auto.

    apply AllS_deduce; intros.
    destruct (card (AllocMap.sel (aheap abs) x)
      (site_bounded (exist valid abs Habs) x)) as [c1 [Hlt1 Hc1]]; simpl.
    destruct (card (AllocMap.sel (aheap abs') x)
      (site_bounded (exist valid abs' Habs') x)) as [c2 [Hlt2 Hc2]]; simpl.
    assert (c2 <= c1); try omega.
    apply incl_cardinality with (AllocMap.sel (aheap abs') x) (AllocMap.sel (aheap abs) x); auto.
    destruct strictApprox0.
    simpl in *; auto.

    generalize (AllocSet.elems_ok progSites); intuition.
    generalize (H a); intuition.
  Qed.

  Lemma approxStrict_wf' : forall n a,
    bound * (length (VarSet.elems progVars) + length (AllocSet.elems progSites)) - size a <= n
    -> Acc approxStrict a.
    induction n; simpl; intuition.

    constructor; intros.
    wrong.
    generalize (size_approxStrict _ _ H0).
    generalize (size_bounded y).
    omega.

    constructor; intros.
    apply IHn.
    generalize (size_approxStrict _ _ H0).
    omega.
  Qed.

  Theorem approxStrict_wf : well_founded approxStrict.
    intro.
    eapply approxStrict_wf'; eauto.
  Qed.

  Hint Resolve approxStrict_wf.

  Definition fixed_point' : {fp : astate
    | forall s, reachable_flowInsensitive aprogram aexec ainitState s
      -> approx s fp}.
    apply fixed_point with (approxStrict := approxStrict)
      (1 := fun (_ : astate) => 0); eauto.
  Qed.

  Lemma In_map : forall (A B : Set) x (f : A -> B) ls,
    In x ls
    -> In (f x) (map f ls).
    induction ls; simpl; intuition.
    subst; auto.
  Qed.

  Lemma in_aprogram' : forall i prog,
    In i prog ->
    exists H : In i prog,
      In (exist (fun i0 => In i0 prog) i H)
      (aprogram' prog).
    induction prog; intros.

    inversion H.

    destruct H; subst.
    simpl.
    eauto.

    simpl.
    destruct (IHprog H) as [h Hh].
    caseEq (ainstr_widen a prog (exist (fun i => In i prog) _ h)); intros.
    simpl in H0.
    injection H0; intros; subst.
    exists (in_cons a x prog h); right.
    apply (In_map _ _ (exist (fun i0 : abstract_instruction => In i0 prog) x h)
      (ainstr_widen a prog)).
    trivial.
  Qed.

  Lemma in_aprogram : forall i,
    In i program
      -> exists H, In (exist (fun i => In i program) i H) aprogram.
    unfold aprogram; intros.
    apply in_aprogram'; trivial.
  Qed.

  Axiom valid_irrel : forall s (H1 H2 : valid s), H1 = H2.

  Lemma reachable_a : forall s1 (Hv1 : valid s1) s2,
    reachable_flowInsensitive program abstract_exec s1 s2
      -> exists Hv2 : valid s2,
	reachable_flowInsensitive aprogram aexec (exist _ _ Hv1) (exist _ _ Hv2).
    induction 1; intuition eauto.

    assert (valid (abstract_exec i s)).
    apply aexec'; trivial.
    destruct (IHreachable_flowInsensitive H1) as [Hv2 Hreach].
    exists Hv2.

    destruct (in_aprogram _ H) as [Hin HHin].

    apply Rfi_Step with (exist (fun i => In i program) i Hin); auto.

    unfold aexec at 2; simpl.
    rewrite (valid_irrel _ (aexec' i s Hin Hv1) H1).
    trivial.
  Qed.

  Definition fixed_point : {fp : abstract_state
    | forall s, reachable_flowInsensitive program abstract_exec abstract_initState s
      -> approx' s fp}.
    destruct fixed_point' as [[fp Hvalid] Hfp].
    exists fp; intros.

    assert (valid abstract_initState).
    unfold abstract_initState; intuition.
    split; simpl; intuition.
    rewrite VarMap.sel_init; eauto.
    rewrite AllocMap.sel_init; eauto.
    rewrite VarMap.sel_init; eauto.
    rewrite AllocMap.sel_init; eauto.

    destruct (reachable_a _ (proj2_sig ainitState) _ H).
    generalize (Hfp _ H1); intros.
    trivial.
  Qed.
End fixed_point.


Set Warnings "-extraction-opaque-accessed,-extraction".
Set Warnings "-notation-overridden,-parsing".

From QuickChick Require Import QuickChick.
Require Import Arith.

Require Import Foo.

(*! Section prop_plus_one *)(*! extends plus_one *)
Definition prop_plus_one x :=
  whenFail (show (x, plus_one x)) (x <? plus_one x).

(*! QuickChick prop_plus_one. *)

(*! Section prop_plus_one_two *)(*! extends plus_one plus_two *)
Definition prop_plus_one_two x :=
  whenFail (show (x, (plus_one x, plus_two x))) (plus_one x <? plus_two x).

(*! QuickChick prop_plus_one_two. *)


From DeepWeb Require Export
     Switch2.

Variant observeE : Type -> Set :=
  Observe__Send : observeE packetT
| Observe__Recv : observeE packetT.

Class Is__oE E `{failureE -< E} `{nondetE -< E}
      `{decideE -< E} `{logE -< E} `{observeE -< E}.
Notation oE := (failureE +' nondetE +' decideE +' logE +' observeE).
Instance oE_Is__oE : Is__oE oE. Defined.

Definition dualize {E R} `{Is__oE E} (e : switchE R) : itree E R :=
  match e in switchE R return _ R with
  | Switch__In    => trigger Observe__Send
  | Switch__Out p =>
    p0 <- trigger Observe__Recv;;
    if eqb_packet p p0
    then ret tt
    else throw ("Expect " ++ to_string p ++ ", but received " ++ to_string p0)
  end.

Definition observer {E R} `{Is__oE E} (m : itree sE R) : itree E R :=
  interp
    (fun _ e =>
       match e with
       | (ne|) =>
         match ne in nondetE R return _ R with
         | Or => trigger Decide
         end
       | (|le|) =>
         match le in logE R return _ R with
         | Log str => embed Log ("Network: " ++ str)
         end
       | (||e) => dualize e
       end) m.


(* License:
     "THE BEER-WARE LICENSE" (Revision 42):
     As long as you retain this notice you can do whatever you want with
     this stuff. If we meet some day, and you think this stuff is worth it,
     you can buy me a beer in return Harley Eades. *)

Require Import String.

Reserved Notation "m '>>=' f" (at level 40).
Reserved Notation "m '>>' f" (at level 40).

Class Monad (m : Type -> Type) := {
  (* Monad Core. *)

  (* bind - Used for chaining. *)
  bind : forall {a} {b}, m a -> (a -> m b) -> m b
    where "m '>>=' f" := (bind m f);

  (* return - The injector of our monad. *)
  ret : forall {a}, a -> m a;

  (* Monads Laws. *)

  (* Left identity. *)
  left_id : forall a b c (f : a -> m b),
    (ret c) >>= f = (f c);

  (* Right identity. *)
  right_id : forall (a : Type) (m' : m a),
    m' >>= ret = m';

  (* Associativity. *)
  assoc : forall (a b c : Type)  (i : m a) (f : a -> m b) (g : b -> m c),
    (i >>= f) >>= g = i >>= (fun x => ((f x) >>= g))
}.

(* Monads are functors. *)
Definition comp {a b c:Type} (f:b -> c) (g:a -> b) := fun x => f (g x).

Class Functor (f : Type -> Type) := {
  fmap : forall {a b}, (a -> b) -> f a -> f b;

  (* Functor Axioms. *)
  id : forall (a : Type), fmap (fun (x:a) => x) = (fun (x: f a) => x);

  compo : forall (a b c:Type) (p : b -> c) (q : a -> b), fmap (comp p q) = comp (fmap p) (fmap q)
}.

Instance Monad_Functor : forall m (i: Monad m), Functor m := {
  fmap a b f fa := bind fa (fun (x:a) => (ret (f x)))
}.

Require Import FunctionalExtensionality.
Proof.
  intros a.
  rewrite <- (eta_expansion ret).
  extensionality x.
  apply right_id.

  intros a b c p q.
  unfold comp.
  extensionality x.
  rewrite -> assoc.
  apply f_equal.
  extensionality x0.
  rewrite -> left_id.
  reflexivity.
Defined.


(* Using the construction to derive state *)

From Coq Require Import Utf8 RelationClasses.
From PDM Require Import util structures guarded PURE PDM StateSpec.

Set Default Goal Selector "!".
Set Printing Projections.
Set Universe Polymorphism.
Unset Universe Minimization ToSet.

Section State.

  Context (state : Type).

  (* Computation monad *)

  Definition M A :=
    state → G (state * A).

  Instance Monad_M : Monad M := {|
    ret A x := λ s₀, ret (s₀, x) ;
    bind A B c f := λ s₀, bind (c s₀) (λ '(s₁, x), f x s₁)
  |}.

  Instance ReqMonad_M : ReqMonad M := {|
    req p := λ s₀, bind (req p) (λ h, ret (s₀, h))
  |}.

  Definition getᴹ : M state :=
    λ s, ret (s, s).

  Definition putᴹ (s : state) : M unit :=
    λ s₀, ret (s, tt).

  (* Effect observation *)

  Definition θ' [A] (c : M A) : W' A :=
    λ post s₀,
      let '(p ; f) := c s₀ in
      ∃ (h : p), let '(s₁, x) := f h in post s₁ x.

  Instance θ_ismono : ∀ A (c : M A), Monotonous (θ' c).
  Proof.
    intros A c. intros P Q s₀ hPQ h.
    red. red in h. destruct (c s₀) as [p f].
    destruct h as [hp h]. exists hp.
    destruct (f hp) as [s₁ x]. apply hPQ. assumption.
  Qed.

  Definition θ [A] (c : M A) : W A :=
    as_wp (θ' c).

  Instance θ_lax : @LaxMorphism _ _ _ _ WStOrder θ.
  Proof.
    constructor.
    - intros A x. intros post s₀ h.
      cbn. exists I. red in h. assumption.
    - intros A B c f. intros post s₀ h.
      unfold bind. simpl. unfold θ'.
      unfold bind in h. simpl in h. unfold θ' in h.
      destruct (c s₀) as [p c']. clear c.
      destruct h as [hp h].
      simpl.
      unshelve eexists.
      { exists hp. destruct (c' hp) as [s₁ x]. destruct (f x s₁).
        simpl. destruct h. assumption.
      }
      simpl. destruct (c' hp) as [s₁ x]. destruct (f x s₁).
      simpl. destruct h. assumption.
  Qed.

  Instance θ_morph : @ReqLaxMorphism _ _ _ _ _ ReqMonad_W WStOrder θ _.
  Proof.
    constructor.
    intro p. intros post s₀ h.
    cbv. cbv in h.
    destruct h as [hp h].
    unshelve eexists.
    { exists hp. auto. }
    simpl. assumption.
  Qed.

  (* Partial Dijkstra monad *)

  Definition D A w :=
    PDM.D (θ := θ) (Word := WStOrder) A w.

  Instance DijkstraMonad_D : DijkstraMonad (Word := WStOrder) D :=
    PDM.DijkstraMonad_D WStMono θ_lax.

  Definition getᴰ : D state getᵂ.
  Proof.
    exists getᴹ.
    cbv. intros post s h. exists I. assumption.
  Defined.

  Definition putᴰ s : D unit (putᵂ s).
  Proof.
    exists (putᴹ s).
    cbv. intros post s₀ h. exists I. assumption.
  Defined.

  (* Lift from PURE *)

  Definition liftᴾ :=
    liftᴾ WStMono θ_lax θ_morph hlift.

  (* Laws *)

  Instance M_laws : MonadLaws M.
  Proof.
    constructor.
    - intros A B x f.
      simpl. (* Need funext *)
  Abort.

End State.


Extraction Language Haskell.
Set Extraction KeepSingleton.

Require Import Bool.
Require Import BinNums.
Require Import BinPos.
Require Import BinNat.

Extract Inductive unit => "()" ["()"].

Extract Inductive prod => "(,)" ["(,)"].
Extract Inductive sigT => "(,)" ["(,)"].
Extract Inductive sigT2 => "(,,)" ["(,,)"].
Extract Constant prod_rect    => "Prelude.uncurry".
Extract Constant prod_uncurry => "Prelude.curry".
Extract Constant sigT_rect    => "Prelude.uncurry".
Extract Constant fst          => "Prelude.fst".
Extract Constant snd          => "Prelude.snd".
Extract Constant projT1       => "Prelude.fst".
Extract Constant projT2       => "Prelude.snd".

Extract Inductive bool    => "Prelude.Bool" ["Prelude.True" "Prelude.False"].
Extract Inductive sumbool => "Prelude.Bool" ["Prelude.True" "Prelude.False"].
Extract Inductive reflect => "Prelude.Bool" ["Prelude.True" "Prelude.False"].
Extract Constant andb        => "(Prelude.&&)".
Extract Constant orb         => "(Prelude.||)".
Extract Constant xorb        => "(Prelude./=)".
Extract Constant negb        => "Prelude.not".
Extract Constant bool_choice => "Prelude.id".
Extract Constant bool_dec    => "(Prelude.==)".
Extract Constant eqb         => "(Prelude.==)".
Extract Constant iff_reflect => "Prelude.id".
Extract Constant reflect_dec => "Prelude.flip Prelude.const".

Extract Inductive option => "Prelude.Maybe" ["Prelude.Just" "Prelude.Nothing"].
Extract Inductive sumor  => "Prelude.Maybe" ["Prelude.Just" "Prelude.Nothing"].
Extract Constant option_rect    => "Prelude.flip Prelude.maybe".
Extract Constant option_map     => "Prelude.fmap".

Extract Inductive sum => "Prelude.Either" ["Prelude.Left" "Prelude.Right"].
Extract Constant sum_rect => "Prelude.either".

Extract Inductive list => "[]" ["[]" "(:)"].
Extract Constant length  => "Data.List.genericLength".
Extract Constant app     => "(Prelude.++)".
(* seq *)
Extract Constant length  => "Data.List.genericLength".

Extract Inductive comparison  => "Prelude.Ordering" ["Prelude.EQ" "Prelude.LT" "Prelude.GT"].
Extract Inductive CompareSpec => "Prelude.Ordering" ["Prelude.EQ" "Prelude.LT" "Prelude.GT"].
  (* Like `comparison`, but with proofs -- except those have been erased *)

Extract Inductive nat => "Prelude.Integer" ["(0 :: Prelude.Integer)" "(Prelude.+ 1)"]
                         "(\fO fS n -> if n Prelude.== 0 then fO () else fS (n Prelude.- 1))".
Extract Constant pred  => "\x -> Prelude.max (x Prelude.- 1) 0".
Extract Constant plus  => "(Prelude.+)".
Extract Constant minus => "\x y -> Prelude.max (x Prelude.- y) 0".
Extract Constant mult  => "(Prelude.*)".
Extract Constant max   => "Prelude.max".
Extract Constant min   => "Prelude.min".

Extract Inductive positive =>
  "Prelude.Integer"
  ["((Prelude.+ 1) Prelude.. (2 Prelude.*))"
   "(2 Prelude.*)"
   "(1 :: Prelude.Integer)"]
  "(\fxI fxO fxH p -> if p Prelude.== 1 then fxH p else (if Data.Bits.testBit p 0 then fxI else fxO) (p `Data.Bits.shiftR` 1))".
Extract Inductive N =>
  "Prelude.Integer" ["(0 :: Prelude.Integer)" "Prelude.id"]
  "(\fN0 fNpos n -> if n Prelude.== 0 then fN0 () else fNpos n)".
Extract Inductive Z =>
  "Prelude.Integer" ["(0 :: Prelude.Integer)" "Prelude.id" "Prelude.negate"]
  "(\fZ0 fZpos fZneg z -> case z `Prelude.compare` 0 of { Prelude.GT -> fZpos z ; Prelude.EQ -> fZ0 () ; Prelude.LT -> fZneg (- z) })".

Extract Constant Pos.succ         => "(Prelude.+ 1)".
Extract Constant Pos.add          => "(Prelude.+)".
Extract Constant Pos.add_carry    => "\x y -> x Prelude.+ y Prelude.+ 1".
Extract Constant Pos.pred_double  => "\x -> (2 Prelude.* x) Prelude.- 1".
Extract Constant Pos.pred         => "\x -> Prelude.max (x Prelude.- 1) 1".
Extract Constant Pos.pred_N       => "Prelude.subtract 1".
Extract Constant Pos.sub          => "\x y -> Prelude.max (x Prelude.- y) 1".
Extract Constant Pos.mul          => "(Prelude.*)".
Extract Constant Pos.pow          => "(Prelude.^)".
Extract Constant Pos.square       => "(Prelude.^ 2)".
Extract Constant Pos.div2         => "\x -> Prelude.max (x `Prelude.quot` 2) 1".
Extract Constant Pos.div2_up      => "\x -> (x Prelude.+ 1) `Prelude.quot` 2".
Extract Constant Pos.compare      => "Prelude.compare".
Extract Constant Pos.min          => "Prelude.min".
Extract Constant Pos.max          => "Prelude.max".
Extract Constant Pos.eqb          => "(Prelude.==)".
Extract Constant Pos.leb          => "(Prelude.<=)".
Extract Constant Pos.ltb          => "(Prelude.<)".
Extract Constant Pos.gcd          => "Prelude.gcd".
Extract Constant Pos.Nsucc_double => "\x -> 2 Prelude.* x Prelude.+ 1".
Extract Constant Pos.Ndouble      => "(2 Prelude.*)".
Extract Constant Pos.lor          => "(Data.Bits..|.)".
Extract Constant Pos.land         => "(Data.Bits..&.)".
Extract Constant Pos.ldiff        => "\x y -> x Data.Bits..&. Data.Bits.complement y".
Extract Constant Pos.lxor         => "Data.Bits.xor".
Extract Constant Pos.shiftl_nat   => "\x s -> x `Data.Bits.shiftL` (Prelude.fromInteger s)".
Extract Constant Pos.shiftr_nat   => "\x s -> Prelude.max (x `Data.Bits.shiftR` (Prelude.fromInteger s)) 1".
Extract Constant Pos.shiftl       => "\x s -> x `Data.Bits.shiftL` (Prelude.fromInteger s)".
Extract Constant Pos.shiftr       => "\x s -> Prelude.max (x `Data.Bits.shiftR` (Prelude.fromInteger s)) 1".
Extract Constant Pos.testbit_nat  => "\x b -> Data.Bits.testBit x (Prelude.fromInteger b)".
Extract Constant Pos.testbit      => "\x b -> Data.Bits.testBit x (Prelude.fromInteger b)".
Extract Constant Pos.to_nat       => "Prelude.id".
Extract Constant Pos.of_nat       => "Prelude.max 1".
Extract Constant Pos.of_succ_nat  => "(Prelude.+ 1)".
Extract Constant Pos.eq_dec       => "(Prelude.==)".

Extract Constant N.zero         => "0 :: Prelude.Integer".
Extract Constant N.one          => "1 :: Prelude.Integer".
Extract Constant N.two          => "2 :: Prelude.Integer".
Extract Constant N.succ_double  => "\x -> 2 Prelude.* x Prelude.+ 1".
Extract Constant N.double       => "(2 Prelude.*)".
Extract Constant N.succ         => "(Prelude.+ 1)".
Extract Constant N.pred         => "\x -> Prelude.max (x Prelude.- 1) 0".
Extract Constant N.succ_pos     => "(Prelude.+ 1)".
Extract Constant N.add          => "(Prelude.+)".
Extract Constant N.sub          => "\x y -> Prelude.max (x Prelude.- y) 0".
Extract Constant N.mul          => "(Prelude.*)".
Extract Constant N.compare      => "Prelude.compare".
Extract Constant N.eqb          => "(Prelude.==)".
Extract Constant N.leb          => "(Prelude.<=)".
Extract Constant N.ltb          => "(Prelude.<)".
Extract Constant N.min          => "Prelude.min".
Extract Constant N.max          => "Prelude.max".
Extract Constant N.div2         => "(`Prelude.quot` 2)".
Extract Constant N.even         => "Prelude.even".
Extract Constant N.odd          => "Prelude.odd".
Extract Constant N.pow          => "(Prelude.^)".
Extract Constant N.square       => "(Prelude.^ 2)".
Extract Constant N.pos_div_eucl => "\x y -> if y Prelude.== 0 then (0,x) else x `Prelude.quotRem` y".
Extract Constant N.div_eucl     => "\x y -> if y Prelude.== 0 then (0,x) else x `Prelude.quotRem` y".
Extract Constant N.div          => "Prelude.quot".
Extract Constant N.modulo       => "Prelude.rem".
Extract Constant N.gcd          => "Prelude.gcd".
Extract Constant N.lor          => "(Data.Bits..|.)".
Extract Constant N.land         => "(Data.Bits..&.)".
Extract Constant N.ldiff        => "\x y -> x Data.Bits..&. Data.Bits.complement y".
Extract Constant N.lxor         => "Data.Bits.xor".
Extract Constant N.shiftl_nat   => "\x s -> x `Data.Bits.shiftL` (Prelude.fromInteger s)".
Extract Constant N.shiftr_nat   => "\x s -> x `Data.Bits.shiftR` (Prelude.fromInteger s)".
Extract Constant N.shiftl       => "\x s -> x `Data.Bits.shiftL` (Prelude.fromInteger s)".
Extract Constant N.shiftr       => "\x s -> x `Data.Bits.shiftR` (Prelude.fromInteger s)".
Extract Constant N.testbit_nat  => "\x b -> Data.Bits.testBit x (Prelude.fromInteger b)".
Extract Constant N.testbit      => "\x b -> Data.Bits.testBit x (Prelude.fromInteger b)".
Extract Constant N.to_nat       => "Prelude.id".
Extract Constant N.of_nat       => "Prelude.id".
Extract Constant N.eq_dec       => "(Prelude.==)".
Extract Constant N.lcm          => "Prelude.lcm".
Extract Constant N.setbit       => "\x b -> Data.Bits.setBit x (Prelude.fromInteger b)".
Extract Constant N.clearbit     => "\x b -> Data.Bits.clearBit x (Prelude.fromInteger b)".

Require Import core.

(* Axioms *)
Extract Inlined Constant Char       => "Prelude.Char".
Extract Inlined Constant Int        => "Prelude.Int".
Extract Inlined Constant Rational   => "Prelude.Rational".
Extract Inlined Constant ByteString => "Data.ByteString.ByteString".

(* Synonyms/replacements from Haskell libraries *)
Extract Inductive FastString => "FastString.FastString"
                                ["error ""FastString is abstract"" (constructor)"]
                                "error ""FastString is abstract"" (case)".
Extract Inlined Constant fsLit => "FastString.fsLit".
Extract Inlined Constant mkFastString => "FastString.mkFastString".
Extract Inlined Constant String => "Prelude.String".
Extract Inductive IntMap => "Data.IntMap.IntMap"
                            ["error ""IntMap is abstract"" (constructor)"]
                            "error ""IntMap is abstract"" (case)".
Extract Inductive Array => "Data.Array.Array"
                           ["error ""Array is abstract"" (constructor)"]
                           "error ""Array is abstract"" (case)".

Recursive Extraction CoreBind.


From mathcomp Require Import all_ssreflect.

From mathcomp Require Import finmap.

From CKB Require Import Types Parameters Forest Setfs Messages States Network.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(* some local state has the chain as its main chain *)
Definition has_chain (bc : Blockchain) (us : UState) : Prop :=
  btBlockchain (btree us) == bc.

(* some local state has the block tree *)
Definition has_bt (bt : BlockTree) (us : UState) : Prop :=
  btree us == bt.

(* the main blockchain is valid wrt. the block tree *)
Definition valid_with_bc (bt : BlockTree) (bc : Blockchain) :=
  (forall h b, bt.[? h] = Some b -> h = #b b) /\
  bt.[? #b GenesisBlock] = Some GenesisBlock /\
  bc = btBlockchain bt.

(* get in flight blocks for a user
   all blocks should be valid in terms of its proof validity *)
Fixpoint blocks_for_rec (ps : seq Packet) :=
  match ps with
  | [::] => [::]
  | p :: ps' =>
    if (msg p) is BlkMsg b then
      if VAF b then b :: blocks_for_rec ps'
      else blocks_for_rec ps'
    else blocks_for_rec ps'
  end.

Definition blocks_for (u : UserId) (gs : GState) :=
  undup (blocks_for_rec [seq p <- inflight_msg gs | dst p == u]).

Lemma compute_blockchain_initBlockTree :
  forall (b : Block),
    #b b \in initBlockTree ->
    compute_blockchain initBlockTree b = [:: GenesisBlock].
Proof.
  move => b; rewrite /compute_blockchain.
  have D : #|` domf initBlockTree| = 1 by rewrite /initBlockTree /= fsetU0 cardfs1.
  move: GB_hash => P.
  rewrite /initBlockTree inE /= fsetU0 in_fset1 => /eqP /hashB_inj E.
  rewrite /compute_blockchain_rec cardfs1.
  rewrite E fset11 inE [domf [fmap].[_ <- _]]/= inE fset11 /orb P.
    by rewrite fnd_set !eqxx.
Qed.

Lemma btBlockchain_initBlockTree :
  btBlockchain initBlockTree = [:: GenesisBlock].
Proof.
  rewrite /initBlockTree /btBlockchain /good_blockchains /all_blockchains /=.
  rewrite fsetU0 /=.
  have H : get_block [fmap].[#b GenesisBlock <- GenesisBlock] (#b GenesisBlock)
           \in [seq get_block [fmap].[#b GenesisBlock <- GenesisBlock] k | k <- [fset #b GenesisBlock]].
    by apply: map_f; rewrite fset11.
  rewrite {1}/get_block fnd_set eqxx in H.
  have P : size [seq get_block [fmap].[#b GenesisBlock <- GenesisBlock] k | k <- [fset #b GenesisBlock]]
           = size [fset #b GenesisBlock].
    by apply: size_map.
  rewrite cardfs1 in P.
  have I : #b GenesisBlock \in initBlockTree.
    by rewrite /initBlockTree inE /= fsetU0 fset11.
  suff Hsuff : [seq get_block [fmap].[#b GenesisBlock <- GenesisBlock] k | k <- [fset #b GenesisBlock]]
                 = [:: GenesisBlock].
  rewrite Hsuff /= (compute_blockchain_initBlockTree I) /= eqxx init_valid_blockchain /=.
    by rewrite /take_better_bc; case: ifP => //.
  move: H P; set s := [seq get_block [fmap].[#b GenesisBlock <- GenesisBlock] k | k <- [fset #b GenesisBlock]].
  case: s => [|b s] H //=.
    by case => /size0nil S; move: H; rewrite S mem_seq1 => /eqP ->.
Qed.

Lemma in_undup {T : eqType} :
  forall (s : seq T) (x : T), x \in undup (x :: s).
Proof.
  elim => [|h s IH] x; first by rewrite inE.
  rewrite /=; case I: (x \in h :: s); last by rewrite inE; apply /orP; left.
  move: I.
  rewrite inE Bool.orb_true_iff; move => [H | H].
  move /eqP: H => <-; rewrite /= in IH.
  case In: (x \in s); last by rewrite inE; apply /orP; left.
    by move: (IH x) => /=; rewrite In.
  rewrite /= in IH; move: (IH x); rewrite H.
  case In: (h \in s); first by done.
    by rewrite inE => Hin; apply /orP; right.
Qed.

(* a lemma stating the above implementation is what we expected *)
Lemma b_in_blocks_for (p : Packet) (b : Block) (gs : GState) :
  VAF b -> p \in inflight_msg gs -> msg p = BlkMsg b -> b \in blocks_for (dst p) gs.
Proof.
  move => Hvaf Hflight Hmsg.
  rewrite /blocks_for.
  elim: (inflight_msg gs) Hflight => [|p' ps' IH] //.
  rewrite inE => /orP [Hp | Hin].
  move /eqP: Hp => <- /=.
  rewrite eqxx /blocks_for_rec Hmsg Hvaf.
    by rewrite in_undup.
  move: (IH Hin) => H.
  rewrite /=; case (dst p' == dst p); last by done.
  rewrite /=. case: (msg p'); [| by done | by done].
  move => b'; case E: (b' == b); case: (VAF b') => //.
    by move /eqP: E => ->; rewrite in_undup.
  rewrite /=; case I: (b' \in blocks_for_rec _); first by done.
    by rewrite inE; apply /orP; right.
Qed.

(* the blockchain is the main chain in the global system *)
Definition largest_chain (gs : GState) (bc : Blockchain) :=
  forall (u : UserId) (bc' : Blockchain),
    holds u gs (fun us => has_chain bc' us -> bc >=b bc').

(* define global stable state, i.e. no in flight packets, and all users have some same blockchain *)
Definition g_stable (gs : GState) :=
  inflight_msg gs = [::] /\
  exists (bc : Blockchain),
    forall (u : UserId), holds u gs (has_chain bc).

(* lemmas to deal with blocks_for_rec and cat *)
Lemma blocks_for_split :
  forall (p1 p2 : seq Packet),
    blocks_for_rec (p1 ++ p2) = blocks_for_rec p1 ++ blocks_for_rec p2.
Proof.
  elim => [|h p1 IH] p2; first by rewrite cat0s.
  rewrite cat_cons /=.
  case: (msg h) => b; try apply: IH.
  case V: (VAF b); last by apply: IH.
    by rewrite cat_cons IH.
Qed.

Lemma valid_blockchain_preserve :
  forall (bc pre : Blockchain) (b : Block),
    valid_blockchain_rec (rcons bc b) pre -> VAF b.
Proof.
  elim => [|a bc IH] pre b.
  - rewrite /valid_blockchain /valid_blockchain_rec /=.
      by move => /andP [/andP [V _] _].
  - rewrite rcons_cons /valid_blockchain /valid_blockchain_rec -!/valid_blockchain_rec.
    move => /andP [_ H].
    apply: IH H.
Qed.


Require Import Coq.Program.Basics.
Require Import Coq.Classes.Morphisms.
Require Import compcert.lib.Coqlib.
Require Import compcert.common.Values.
Require Import compcert.common.Memory.
Require Import compcertx.common.MemoryX.
Require Import liblayers.lib.Functor.
Require Import liblayers.lib.Monad.
Require Import liblayers.lib.Lens.
Require Export liblayers.lib.Lift.
Require Export liblayers.compcertx.LiftMem.

(** * Prerequisites *)

(** We're going to lift the memory operations and theorems from a base
  type [bmem] to a "richer" type [mem], which contains [bmem] as a
  component. Formally, this means that we have a [Lens mem bmem] which
  provides us with well-behaved accessors to the [bmem] component
  inside of [mem]. While this is enough to lift most of the memory
  operations and theorems, we also need to know the value of
  the empty memory state of the richer type [mem]; indeed there's no
  way we would be able to construct that just from [empty : bmem].
  However, the simpler memory state contained within this empty [mem]
  should correspond to the empty [bmem] from the base memory states. *)

Section LIFTMEM.
  Context mem bmem `{Hmem: LiftMemoryModel mem bmem}.

  Local Arguments fmap : simpl never.

  Global Instance liftmemx_spec:
    Mem.MemoryModelX bmem -> Mem.MemoryModelX mem.
  Proof.
    intros Hbmem; split.
    typeclasses eauto.
    lift π Mem.extends_extends_compose.
    lift π Mem.inject_extends_compose.
    lift π Mem.inject_compose.
    lift π Mem.extends_inject_compose.
    lift π Mem.inject_neutral_incr.
    lift π Mem.free_inject_neutral.
    lift π Mem.drop_perm_right_extends.
    lift π Mem.drop_perm_parallel_extends.
    lift π Mem.storebytes_inject_neutral.
    {
      lift_partial π Mem.free_range.
      destruct Hf; try tauto.
      right; eauto using lens_same_context_eq, eq_sym.
    }
    {
      lift_partial π Mem.storebytes_empty.
      eauto using lens_same_context_eq, eq_sym.
    }
    lift π Mem.unchanged_on_trans_strong.
  Qed.
End LIFTMEM.


Require Import NoQ.Monad.
Require Import NoQ.Traversable.
Require Import NoQ.List.
Require Import NoQ.Function.

Fixpoint list_tsequence {m} `{! Monad m } {A} (xUs:list (m A)) : m (list A) :=
  match xUs with
  | [] => ret []
  | xM::xMs =>
      x <- xM ;;
      monad_map (cons x) $ list_tsequence xMs
  end.
Instance List_Traversable : Traversable list :=
  { tsequence := @list_tsequence }.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D P Q C0 Q0 C1 : Universe, ((wd_ P C0 /\ (wd_ P Q /\ (wd_ P Q0 /\ (wd_ C0 Q0 /\ (wd_ A B /\ (wd_ B Q0 /\ (wd_ A Q0 /\ (wd_ C0 A /\ (wd_ C0 B /\ (wd_ Q C0 /\ (wd_ B Q /\ (wd_ A Q /\ (wd_ C D /\ (wd_ D P /\ (wd_ C P /\ (wd_ C A /\ (wd_ C B /\ (wd_ D A /\ (wd_ D B /\ (wd_ C1 C0 /\ (col_ A B P /\ (col_ C0 C D /\ (col_ Q P Q0 /\ (col_ C D C1 /\ (col_ P C0 A /\ col_ P C0 B))))))))))))))))))))))))) -> col_ C0 A B)).
Proof.
  time tac.
Qed.

End FOFProblem.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj16synthconj5 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural) (lv3 : natural), (@eq natural (Succ (plus lv0 (plus lv1 lv2))) (plus Zero lv3)).
Admitted.
QuickChick conj16synthconj5.


Require Import Coq.omega.Omega.
Require Import Bedrock.Platform.PreAutoSep Bedrock.Platform.Util Bedrock.Platform.Sys.
Export PreAutoSep Util Sys.

Set Implicit Arguments.

Ltac enterFunction :=
  match goal with
    | [ |- context[localsInvariant _ _ false _ ?ns _ _] ] =>
      match goal with
        | [ |- context[localsInvariant _ _ true _ ?ns'' _ _] ] =>
          let ns' := peelPrefix ns ns'' in
            intros;
              repeat match goal with
                       | [ H : interp _ _ |- _ ] =>
                         eapply localsInvariant_inEx; [ | apply H ];
                           clear H; simpl; intros
                     end;
              eapply (@localsInvariant_in ns'); [
                eassumption
                | simpl; omega
                | reflexivity
                | reflexivity
                | repeat constructor; simpl; intuition congruence
                | intros ? ? Hrew; repeat rewrite Hrew by (simpl; tauto); reflexivity
                | intros ? ? Hrew; repeat rewrite Hrew by (simpl; tauto); reflexivity ]
      end
  end.

Ltac sep hints := enterFunction || PreAutoSep.sep hints.

Ltac sep_auto := sep auto_ext.

(** * Help with higher-order VCs *)

Lemma tuple_predicate : forall A B pc state
  (P : A -> B -> PropX pc state) P' specs x y,
  interp specs (P x y)
  -> P' = (fun p => P (fst p) (snd p))
  -> interp specs (P' (x, y)).
  intros; subst; auto.
Qed.

Hint Extern 1 (interp _ _) =>
  eapply tuple_predicate; [ eassumption | reflexivity ].

(* avoid name conflict with Conditional.v *)
Definition And := PropX.And.
Definition Or := PropX.Or.

Fixpoint eatEasy pc state G (P : propX pc state G)
  : list (propX pc state G) * list (propX pc state G) :=
  match P in propX _ _ G return list (propX _ _ G) * list (propX _ _ G) with
    | Inj _ p => (Inj p :: nil, nil)
    | Cptr _ pc f => (Cptr pc f :: nil, nil)
    | PropX.And _ Q R => let (easy1, hard1) := eatEasy Q in
      let (easy2, hard2) := eatEasy R in
        (easy1 ++ easy2, hard1 ++ hard2)
    | PropX.Or _ Q R => (nil, Or Q R :: nil)
    | Imply _ Q R => (nil, Imply Q R :: nil)
    | Forall _ _ Q => (nil, Forall Q :: nil)
    | Exists _ _ Q => (nil, Exists Q :: nil)
    | Var0 _ _ v => (nil, Var0 v :: nil)
    | Lift _ _ Q => (nil, Lift Q :: nil)
    | ForallX _ _ Q => (nil, ForallX Q :: nil)
    | ExistsX _ _ Q => (nil, ExistsX Q :: nil)
  end.

Definition andify' pc state G (Ps : list (propX pc state G)) :=
  fold_left (@And _ _ _) Ps.

Definition andify pc state G (Ps : list (propX pc state G)) :=
  andify' Ps (Inj True).

Lemma eatEasy_right1 : forall pc state (P : PropX pc state) specs,
  interp specs ([|True|] /\ P ---> [|True|] ---> P)%PropX.
  intros.
  repeat apply Imply_I.
  eapply And_E2; apply Env; simpl; eauto.
Qed.

Lemma eatEasy_right2 : forall pc state (P : PropX pc state) specs,
  interp specs (andify nil ---> andify (P :: nil) ---> P)%PropX.
  unfold andify, andify'; simpl; intros.
  do 2 apply Imply_I.
  eapply And_E2; apply Env; simpl; eauto.
Qed.

Lemma andify1'' : forall pc state (Ps : list (PropX pc state)) R' R specs,
  interp specs (R' ---> R)
  -> interp specs (andify' Ps R' ---> R).
  unfold andify'; induction Ps; simpl; intuition.
  apply IHPs.
  apply Imply_I; eapply Imply_E; [ apply interp_weaken; apply H | ].
  eapply And_E1; apply Env; simpl; eauto.
Qed.

Lemma andify1' : forall pc state (Qs Ps : list (PropX pc state)) R specs,
  interp specs (andify' (Ps ++ Qs) R ---> andify' Ps R).
  unfold andify'; induction Ps; simpl; intuition.
  apply andify1''; apply Imply_refl.
Qed.

Lemma andify1 : forall pc state (Qs Ps : list (PropX pc state)) specs,
  interp specs (andify (Ps ++ Qs) ---> andify Ps).
  intros; apply andify1'.
Qed.

Lemma andify2''' : forall pc state (Ps : list (PropX pc state)) R' R specs,
  interp specs ((R' ---> R) ---> andify' Ps R' ---> andify' Ps R)%PropX.
  unfold andify'; induction Ps; simpl; intuition.
  apply Imply_refl.
  apply Imply_I.
  eapply Imply_E.
  apply interp_weaken; apply IHPs.
  apply Imply_I; apply And_I.
  eapply Imply_E.
  apply Env; simpl; eauto.
  eapply And_E1; apply Env; simpl; eauto.
  eapply And_E2; apply Env; simpl; eauto.
Qed.

Lemma andify2'' : forall pc state (Ps : list (PropX pc state)) R' R specs,
  interp specs (R' ---> R)
  -> interp specs (andify' Ps R' ---> andify' Ps R).
  intros; eapply Imply_E.
  apply andify2'''.
  auto.
Qed.

Lemma andify2' : forall pc state (Qs Ps : list (PropX pc state)) R specs,
  interp specs (andify' (Ps ++ Qs) R ---> andify' Qs R).
  unfold andify'; induction Ps; simpl; intuition.
  apply Imply_refl.
  eapply Imply_trans; try apply IHPs.
  apply andify2''.
  eapply Imply_I; eapply And_E1; apply Env; simpl; eauto.
Qed.

Lemma andify2 : forall pc state (Qs Ps : list (PropX pc state)) specs,
  interp specs (andify (Ps ++ Qs) ---> andify Qs).
  intros; apply andify2'.
Qed.

Lemma eatEasy_right' : forall pc state G (P : propX pc state G),
  match G return propX pc state G -> Prop with
    | nil => fun P => forall specs,
      let (easy, hard) := eatEasy P in
        interp specs (andify easy ---> andify hard ---> P)%PropX
    | _ => fun _ => True
  end P.
  induction P; destruct G; simpl; intuition;
    try (apply eatEasy_right1 || apply eatEasy_right2; eauto).

  intros.
  destruct (eatEasy P1).
  destruct (eatEasy P2).
  repeat apply Imply_I.
  apply And_I.
  eapply Imply_E; [ eapply Imply_E | ].
  apply interp_weaken; apply IHP1.
  eapply Imply_E; [ apply interp_weaken; apply andify1 | ].
  eapply Env; simpl; eauto.
  eapply Imply_E; [ apply interp_weaken; apply andify1 | ].
  eapply Env; simpl; eauto.
  eapply Imply_E.
  eapply Imply_E.
  apply interp_weaken; apply IHP2.
  eapply Imply_E; [ apply interp_weaken; apply andify2 | ].
  apply Env; simpl; eauto.
  eapply Imply_E; [ apply interp_weaken; apply andify2 | ].
  apply Env; simpl; eauto.
Qed.

Lemma eatEasy_left1 : forall pc state (P : PropX pc state) specs,
  interp specs (P ---> andify (P :: nil))%PropX.
  unfold andify, andify'; simpl; intros.
  apply Imply_I.
  apply And_I.
  apply Inj_I; auto.
  apply Env; simpl; eauto.
Qed.

Lemma eatEasy_left2 : forall pc state (P : PropX pc state) specs,
  interp specs (P ---> andify nil).
  intros; apply Imply_I; apply Inj_I; auto.
Qed.

Lemma andify_app' : forall pc state (Qs Ps : list (PropX pc state)) R specs,
  interp specs (andify' Ps R ---> andify Qs ---> andify' (Ps ++ Qs) R)%PropX.
  unfold andify, andify'; induction Ps; simpl; intuition.
  apply Imply_I.
  eapply Imply_E.
  apply interp_weaken; apply andify2'''.
  apply Imply_I; apply Env; simpl; eauto.
Qed.

Lemma andify_app : forall pc state (Qs Ps : list (PropX pc state)) specs,
  interp specs (andify Ps ---> andify Qs ---> andify (Ps ++ Qs))%PropX.
  unfold andify, andify'; induction Ps; simpl; intuition.
  apply Imply_I; apply interp_weaken; apply Imply_refl.
  apply andify_app'.
Qed.

Lemma eatEasy_left1' : forall pc state G (P : propX pc state G),
  match G return propX pc state G -> Prop with
    | nil => fun P => forall specs,
      let (easy, hard) := eatEasy P in
        interp specs (P ---> andify easy)%PropX
    | _ => fun _ => True
  end P.
  induction P; destruct G; simpl; intuition;
    try (apply eatEasy_left1 || apply eatEasy_left2).

  destruct (eatEasy P1); destruct (eatEasy P2).
  apply andL; do 2 apply Imply_I.
  eapply Imply_E.
  eapply Imply_E.
  apply interp_weaken; apply andify_app.
  eapply Imply_E.
  apply interp_weaken; apply IHP1; apply Env; simpl; auto.
  apply Env; simpl; auto.
  eapply Imply_E.
  apply interp_weaken; apply IHP2; apply Env; simpl; auto.
  apply Env; simpl; auto.
Qed.

Lemma eatEasy_left2' : forall pc state G (P : propX pc state G),
  match G return propX pc state G -> Prop with
    | nil => fun P => forall specs,
      let (easy, hard) := eatEasy P in
        interp specs (P ---> andify hard)%PropX
    | _ => fun _ => True
  end P.
  induction P; destruct G; simpl; intuition;
    try (apply eatEasy_left1 || apply eatEasy_left2).

  destruct (eatEasy P1); destruct (eatEasy P2).
  apply andL; do 2 apply Imply_I.
  eapply Imply_E.
  eapply Imply_E.
  apply interp_weaken; apply andify_app.
  eapply Imply_E.
  apply interp_weaken; apply IHP1; apply Env; simpl; auto.
  apply Env; simpl; auto.
  eapply Imply_E.
  apply interp_weaken; apply IHP2; apply Env; simpl; auto.
  apply Env; simpl; auto.
Qed.

Theorem eatEasy_simpl : forall pc state (P Q : PropX pc state) specs,
  (let (easy1, hard1) := eatEasy P in
    let (easy2, hard2) := eatEasy Q in
    interp specs (andify easy1 ---> andify hard1 ---> andify easy2 /\ andify hard2)%PropX)
  -> interp specs (P ---> Q)%PropX.
  intros.
  specialize (eatEasy_left1' P); specialize (eatEasy_left2' P); cbv beta iota; destruct (eatEasy P); intros.
  specialize (eatEasy_right' Q); cbv beta iota; destruct (eatEasy Q); intros.
  apply Imply_trans with (andify l0 /\ andify l)%PropX.
  apply andR; auto.
  eapply Imply_trans; try apply H2.
  apply andL; apply swap; eauto.
  apply andL; auto.
Qed.

Ltac big_imp := ((eapply Imply_sound; [ match goal with
                                          | [ H : _ |- _ ] => apply H
                                        end | ])
|| (eapply Imply_trans; [ | match goal with
                              | [ H : _ |- _ ] => apply H
                            end ])); cbv beta; simpl.

Ltac cptr := post; rewrite sepFormula_eq;
  repeat match goal with
           | [ H : interp _ (![_] _) |- _ ] => rewrite sepFormula_eq in H
         end; propxFo; descend; eauto;
  try big_imp.

Lemma jiggle : forall pc state (P Q R S : PropX pc state) specs,
  interp specs (P ---> (Q /\ S) /\ R)%PropX
  -> interp specs (P ---> (Q /\ R) /\ S)%PropX.
  intros.
  eapply Imply_trans; try apply H.
  intros; apply Imply_I.
  repeat apply And_I.
  eapply And_E1; eapply And_E1; apply Env; simpl; eauto.
  eapply And_E2; apply Env; simpl; eauto.
  eapply And_E2; eapply And_E1; apply Env; simpl; eauto.
Qed.

Ltac refl := try rewrite sepFormula_eq;
  apply Imply_refl || (apply jiggle; apply Imply_refl).

Ltac imp := rewrite sepFormula_eq; apply eatEasy_simpl;
  unfold andify, andify'; simpl;
    repeat (apply andL; apply swap; ((apply injL || apply cptrL); intro));
      apply injL; intro; apply andR; [
        apply Imply_I; apply interp_weaken
        | try refl ].

Lemma curry_predicate : forall A B pc state
  (P : A * B -> PropX pc state) P' specs x y,
  interp specs (P (x, y))
  -> P' = (fun x y => P (x, y))
  -> interp specs (P' x y).
  intros; subst; auto.
Qed.

Hint Extern 1 (simplify _ _ _) =>
  apply simplify_fwd; eapply curry_predicate; [ eassumption | reflexivity ].

Lemma substH_in2 : forall a b (P : hpropB (a :: b :: nil)) q1 q2,
  (fun stn sm => subst (G := a :: nil) (subst (P stn sm) q1) q2) = substH (substH P q1) q2.
reflexivity.
Qed.

Hint Rewrite substH_in2 : sepFormula.
Opaque mult.
Require Import Coq.Arith.Arith.

Lemma create_stack : forall ns ss sp,
  NoDup ns
  -> sp =?> (length ns + ss) ===> Ex vs, locals ns vs ss sp.
  intros; eapply Himp_trans; [ apply allocated_split | ].
  instantiate (1 := length ns); omega.
  eapply Himp_trans.
  eapply Himp_star_frame.
  apply behold_the_array; auto.
  apply Himp_refl.
  unfold locals, array.
  Opaque mult.
  sepLemma.
  apply allocated_shift_base.
  unfold natToW; rewrite mult_comm; words.
  omega.
Qed.

Transparent mult.

Notation Abort := (Goto "sys"!"abort")%SP.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University
  Copyright 2017 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Vincent Rahli

 *)

Require Export nuprl_props.
Require Export choice.
Require Export cvterm.

Lemma tequality_isect {p} :
  forall lib (A1 A2 : @CTerm p) v1 v2 B1 B2,
    tequality lib (mkc_isect A1 v1 B1)
              (mkc_isect A2 v2 B2)
    <=>
    (tequality lib A1 A2
     # forall a a', equality lib a a' A1 -> tequality lib (substc a v1 B1) (substc a' v2 B2)).
Proof.
  intros.
  sp_iff Case.

  - Case "->".
    intros teq.
    unfold tequality, nuprl in teq; exrepnd.
    inversion teq0; subst; try not_univ.

    one_dest_per_fam eqa feqb A3 A4 v3 v4 B3 B4 c1 c2 tsa tsb eqt.
    computes_to_value_isvalue.
    allfold (@nuprl p lib).
    dands.

    unfold tequality.
    exists eqa; sp.

    introv e.
    unfold tequality.
    unfold equality in e; exrepnd.
    generalize (nuprl_uniquely_valued lib A3 eqa eq0);
      intro k; repeat (dest_imp k hyp); try (complete (allapply @nuprl_refl; sp)).
    rw <- k in e0.
    generalize (tsb a a' e0); intro n.
    exists (feqb a a' e0); sp.

  - Case "<-".
    introv eqs.
    destruct eqs as [teqa teqb].
    unfold tequality in teqa; exrepnd.
    rename eq into eqa.

    generalize (choice_teq lib A1 v1 B1 v2 B2 teqb); intro n; exrepnd.

    exists (fun t1 t2 =>
              forall a1 a2 : CTerm,
              forall e : eqa a1 a2,
                f a1 a2
                  (eq_equality2 lib a1 a2 A1 A2 eqa e teqa0)
                  t1 t2).
    apply CL_isect; fold (@nuprl p lib).
    unfold per_isect.
    exists eqa.

    exists (fun a1 a2 e => f a1 a2 (eq_equality2 lib a1 a2 A1 A2 eqa e teqa0)); sp.

    exists A1 A2 v1 v2 B1 B2; sp;
    try (complete (spcast; apply computes_to_valc_refl; try (apply iscvalue_mkc_isect))).
Qed.

Lemma equality_isect {p} :
  forall lib (A1 A2 : @CTerm p) v1 v2 B1 B2 i,
    equality lib (mkc_isect A1 v1 B1)
             (mkc_isect A2 v2 B2)
             (mkc_uni i)
    <=>
    (equality lib A1 A2 (mkc_uni i)
     # forall a a',
         equality lib a a' A1
         -> equality lib (substc a v1 B1) (substc a' v2 B2) (mkc_uni i)).
Proof.
  introv.
  sp_iff Case.

  - Case "->".
    intros teq.
    unfold equality, nuprl in teq; exrepnd.
    inversion teq1; subst; try not_univ.
    duniv j h.
    allrw @univi_exists_iff; exrepd.
    computes_to_value_isvalue; GC.
    discover; exrepnd.
    rename eqa into eqi.
    ioneclose; subst; try not_univ.

    one_dest_per_fam eqa feqb A3 A4 v3 v4 B3 B4 c1 c2 tsa tsb eqt.
    computes_to_value_isvalue; GC.
    dands.

    exists eq; sp.
    allrw.
    exists eqa; sp.

    introv e.
    exists eq; sp.
    allfold (@nuprli p lib j0).
    allrw.
    unfold equality in e; exrepnd.
    generalize (nuprl_uniquely_valued lib A3 eqa eq0);
      intro k; repeat (dest_imp k hyp);
      try (complete (apply nuprli_implies_nuprl with (i := j0); sp;
                     allapply @nuprli_refl; sp)).
    rw <- k in e0.
    generalize (tsb a a' e0); intro n.
    exists (feqb a a' e0); sp.

  - Case "<-".
    intro eqs.
    destruct eqs as [eqa eqb].
    unfold equality in eqa; exrepnd.
    inversion eqa1; subst; try not_univ.
    duniv j h.
    allrw @univi_exists_iff; exrepd.
    computes_to_value_isvalue; GC.
    discover; exrepnd.
    allfold (@nuprli p lib j0).

    exists eq; sp.
    allrw.

    generalize (choice_teqi lib j0 A1 v1 B1 v2 B2 eqb); intro n; exrepnd.

    exists (fun t1 t2 =>
              forall a1 a2 : CTerm,
              forall e : eqa a1 a2,
                f a1 a2
                  (eq_equality3 lib a1 a2 A1 A2 eqa j0 e h0)
                  t1 t2).
    apply CL_isect; fold (@nuprli p lib j0).
    unfold per_isect.
    exists eqa.

    exists (fun a1 a2 e => f a1 a2 (eq_equality3 lib a1 a2 A1 A2 eqa j0 e h0)); sp.

    exists A1 A2 v1 v2 B1 B2; sp;
    try (complete (spcast; apply computes_to_valc_refl; try (apply iscvalue_mkc_isect))).
Qed.

Lemma equality_in_isect {p} :
  forall lib (t u : @CTerm p) A v B,
    equality lib t u (mkc_isect A v B)
    <=>
    (type lib A
     # (forall a a', equality lib a a' A -> tequality lib (substc a v B) (substc a' v B))
     # (forall a a',
          equality lib a a' A
          -> equality lib t u (substc a v B))).
Proof.
  sp; sp_iff Case; introv e.

  - Case "->".
    unfold equality in e; exrepd.
    inversion n; subst; try not_univ.
    one_dest_per_fam eqa feqb A1 A2 v1 v2 B1 B2 c1 c2 tsa tsb eqt.
    computes_to_value_isvalue.
    allfold (@nuprl p lib).
    dands.

    exists eqa; sp.

    introv ea.
    unfold equality in ea; exrepnd.
    assert (eq_term_equals eq0 eqa) as eqta
      by (apply (nuprl_uniquely_valued lib) with (t := A1); sp).
    unfold eq_term_equals in eqta.
    discover.
    generalize (tsb a a' h); sp.
    exists (feqb a a' h); sp.

    introv ea.
    unfold equality in ea; exrepnd.
    assert (eq_term_equals eq0 eqa) as eqta
      by (apply (nuprl_uniquely_valued lib) with (t := A1); sp).
    unfold eq_term_equals in eqta.
    discover.
    assert (eqa a a) as eqaa
      by (apply term_equality_refl with (t2 := a'); sp;
          try (complete (nts; apply nts_tes with (T := A1) (T' := A1); auto));
          try (complete (nts; apply nts_tet with (T := A1) (T' := A1); auto))).
    exists (feqb a a eqaa); sp.

  - Case "<-".
    repnd.
    unfold equality.
    unfold type, tequality in e0; exrepnd.
    rename eq into eqa.

    generalize (choice_eq lib A v B (fun a => t) (fun a => u) e);
      intro n; exrepnd.

    exists (fun t1 t2 =>
              forall a1 a2 : CTerm,
              forall e : eqa a1 a2,
                f a1 a2
                  (eq_equality1 lib a1 a2 A eqa e e2)
                  t1 t2); sp.

    unfold nuprl; apply CL_isect; fold @nuprl; unfold per_isect.
    exists eqa.

    exists (fun a1 a2 e => f a1 a2 (eq_equality1 lib a1 a2 A eqa e e2)); sp.

    unfold type_family.
    exists A A v v B B; sp;
    try (complete (spcast; apply computes_to_valc_refl; try (apply iscvalue_mkc_isect))).

    generalize (n0 a a' (eq_equality1 lib a a' A eqa e0 e2)); intro n; repnd.

    generalize (choice_teq lib A v B v B e1); intro m; exrepnd.
    generalize (m0 a a' (eq_equality1 lib a a' A eqa e0 e2)); intro m.

    apply nuprl_trans with (t2 := substc a v B)
                             (eq2 := f0 a a' (eq_equality1 lib a a' A eqa e0 e2)); sp.

    generalize (n0 a1 a2 (eq_equality1 lib a1 a2 A eqa e0 e2)); sp.
Qed.

Lemma tequality_mkc_ufun {p} :
  forall lib (A1 A2 B1 B2 : @CTerm p),
    tequality lib (mkc_ufun A1 B1) (mkc_ufun A2 B2)
    <=> (tequality lib A1 A2 # (inhabited_type lib A1 -> tequality lib B1 B2)).
Proof.
  introv.
  allrw <- @fold_mkc_ufun.
  rw @tequality_isect.
  split; intro k; repnd; dands; auto.

  introv i.
  unfold inhabited_type in i; exrepnd.
  generalize (k t t i0); intro teq.
  allrw @csubst_mk_cv; auto.

  introv e.
  allrw @csubst_mk_cv; auto.
  apply equality_refl in e.
  autodimp k hyp.
  exists a; auto.
Qed.

Lemma equality_in_isect2 {o} :
  forall lib (t u : @CTerm o) A v B,
    equality lib t u (mkc_isect A v B)
    <=>
    (type lib A
     # forall a a',
         equality lib a a' A
         -> (equality lib t u (substc a v B) # tequality lib (substc a v B) (substc a' v B))).
Proof.
  sp; rw @equality_in_isect; split; sp; discover; sp.
Qed.

Lemma member_in_isect {o} :
  forall lib (t : @CTerm o) A v B,
    member lib t (mkc_isect A v B)
    <=>
    (type lib A
     # forall a a',
         equality lib a a' A
         -> (member lib t (substc a v B) # tequality lib (substc a v B) (substc a' v B))).
Proof.
  sp; rw @equality_in_isect; split; sp; discover; sp.
Qed.

Lemma equality_in_ufun {p} :
  forall lib (f g A B : @CTerm p),
    equality lib f g (mkc_ufun A B)
    <=>
    (type lib A
     # (inhabited_type lib A -> type lib B)
     # (inhabited_type lib A -> equality lib f g B)).
Proof.
  introv.
  rw <- @fold_mkc_ufun.
  rw @equality_in_isect.
  split; intro k; repnd; dands; auto.

  - introv i.
    unfold inhabited_type in i; exrepnd.
    generalize (k1 t t); intro j; autodimp j hyp.
    repeat (rw @csubst_mk_cv in j); sp.

  - introv e.
    unfold inhabited_type in e; exrepnd.
    unfold member in e0.
    apply k in e0.
    repeat (rw @csubst_mk_cv in e0); sp.

  - introv e.
    repeat (rw @csubst_mk_cv); sp.
    autodimp k1 hyp.
    exists a; apply equality_refl in e; auto.

  - introv e.
    repeat (rw @csubst_mk_cv); sp.
    apply k.
    exists a; apply equality_refl in e; auto.
Qed.