Require Import Specification Predicate Statement HoareWp Predicative.

Lemma pred_if_hoare :
  forall (T V : Type) (C : @Stmt T V) P Q, ValidHoareTriple P C Q -> ValidHoareTriple P ⟨pred C⟩ Q.
Proof.
  intros *.
  induction 1.
  { constructor; simpl in *; firstorder. }
  { constructor; simpl in *; firstorder; subst; eauto. }
  { constructor.
    pose proof (spec_inj IHValidHoareTriple1).
    pose proof (spec_inj IHValidHoareTriple2).
    clear -H1 H2.
    intros; split.
    { firstorder. }
    { destruct (H1 _ H).
      destruct H3 as (sx,H3).
      destruct (H2 _ (H0 _ H3)).
      destruct H5 as (s',H5).
      exists s'; split; eauto.
      firstorder.
    }
  }
  { constructor.
    intros; simpl in *.
    pose proof (spec_inj IHValidHoareTriple1).
    pose proof (spec_inj IHValidHoareTriple2).
    clear -H H2 H3 H4.
    split.
    { firstorder. }
    { simpl in *.
      destruct (H _ H2).
      { destruct (H3 _ (conj H0 H2)) as (_,(s',H5)).
        clear - H0 H5; eauto.
      }
      { destruct (H4 _ (conj H0 H2)) as (_,(s',H5)).
        clear - H0 H5; eauto.
      }
    }
  }
  { simpl in *.
    constructor.
    intros s HHPs.
    generalize (H1 _ HHPs).
    pose proof (fun v : W => spec_inj (H3 v)).
    simpl in *.
    clear - H H0 H1 H2 H3 H4 H5.
    pattern s.
    pose proof (Wfd.by_direct_functional_simulation _ _ V _ H0).
    apply (well_founded_ind H6).
    clear - H H1 H4 H5.
    intros s HHind HHI.
    split.
    { intros.
      apply while_destruct in H0.
      destruct H0 as [ (HHCs,((sx,(H11,H12)),H3)) | (HHnc,HHeq) ]; subst.
      { destruct (H5 _ _ (conj HHCs (conj HHI eq_refl))).
        destruct (H0 _ H11).
        destruct (HHind _ H7 H6).
        exact (H8 _ H12).
      }
      { exact (H4 _ HHnc HHI). }
    }
    { destruct (H _ HHI).
      {  destruct (H5 _ _ (conj H0 (conj HHI eq_refl))).
         destruct H3 as (sx,HHBssx).
         destruct (H2 _ HHBssx).
         destruct (HHind _ H6 H3).
         destruct H8 as (s',HHwhile).
         exists s'.
         apply while_construct; left; split; auto.
         split; eauto.
         clear -H2 HHind.
         firstorder.
      }
      { exists s; apply while_construct; right; auto. }
    }
  }
  { simpl in *.
    constructor; auto.
  }
  { simpl.
    constructor.
    pose proof (spec_inj IHValidHoareTriple).
    firstorder.
  }
  { simpl.
    constructor.
    pose proof (spec_inj IHValidHoareTriple1).
    pose proof (spec_inj IHValidHoareTriple2).
    clear - H1 H2.
    firstorder.
  }
Qed.

Lemma hoare_if_pred :
  forall (T V : Type) (C : @Stmt T V) P Q, ValidHoareTriple P (Statement.Spec (pred C)) Q -> ValidHoareTriple P C Q.
Proof.
  induction C as [ | | | | | | | ]; intros P Q; simpl.
  { intros HHtriple. pose proof (spec_inj HHtriple). clear HHtriple; simpl in *.
    constructor.
    intros.
    unfold not; intros.
    destruct (H _ H0).
    clear - H2; destruct H2.
    auto.
  }
  { intros HHtriple. pose proof (spec_inj HHtriple). clear HHtriple; simpl in *.
    constructor.
    firstorder.
  }
  { intros HHtriple. pose proof (spec_inj HHtriple). clear HHtriple; simpl in *.
    apply (Seq _ _ (fun s => (forall sx, (pred C2) s sx -> Q sx) /\ (exists sx, (pred C2) s sx))).
    { apply (IHC1 _ _); auto; constructor; firstorder. }
    { apply (IHC2 _ _); auto; constructor; firstorder. }
  }
  { intros HHtriple. pose proof (spec_inj HHtriple). clear HHtriple; simpl in *.
    constructor.
    { intros.
      destruct (H _ H0) as (_,(s',[(HHp,_) | (HHn,_) ])).
      { left; auto. }
      { right; auto. }
    }
    { apply (IHC1 _ _); auto; constructor; intros s (HHp1,HHp2); split; firstorder. }
    { apply (IHC2 _ _); auto; constructor; intros s (HHp1,HHp2); split; firstorder. }
  }
  { intros HHtriple. pose proof (spec_inj HHtriple). clear HHtriple; simpl in *.
    apply (While _ _ _ (fun s => (forall s', while p (pred C) s s' -> Q s') /\ exists s', while p (pred C) s s')
                 _ _ (fun s s' => p s' /\ pred C s' s /\ (exists r, (while p (pred C)) s' r))  (fun s => s)).
    { intros.
      destruct H0 as (_,(s',HHwhile)).
      apply while_destruct in HHwhile.
      destruct HHwhile as [ (HHp,_) | (HHn,_)]; unfold Decidable.decidable; auto.
    }
    { constructor.
      intros y [HHp [HHpred HHwhile]].
      generalize y HHp HHpred; clear y HHp HHpred.
      pattern a; apply (ex_while_ind _ _ _ _ HHwhile).
      intros.
      destruct H0; try contradiction.
      destruct H0.
      constructor; intros.
      destruct H2.
      destruct H3.
      apply (H1 y); auto.
    }
    { auto. }
    { intros.
      apply (IHC _ _); auto.
      constructor.
      intros.
      destruct H0 as (HH1,((HH2,(s',HH3)),HH)); subst v.
      apply while_destruct in HH3.
      destruct HH3 as [ (HH4,((sx,(HH51,HH52)),HH6)) | (HH4,HH5) ]; try contradiction.
      split; intros.
      { split; intros.
        { split; intros.
          { apply HH2.
            apply while_construct; left; split; auto.
            split.
            { exists s'0; firstorder. }
            { auto. }
          }
          { apply (HH6 _ H0). }
        }
        { split; auto.
          destruct (HH6 _ H0) as (s'',HH).
          split; auto.
          exists s''; apply while_construct; left; split; auto.
          split; eauto.
        }
      }
      { exists sx; auto. }
    }
    { intros.
      apply H1.
      apply while_construct; right; auto.
    }
  }
  { auto. }
  { intros.
    pose proof (spec_inj H).
    constructor.
    { firstorder. }
    { apply IHC.
      constructor.
      intros.
      firstorder.
    }
  }
  { intros.
    pose proof (spec_inj H).
    constructor.
    { apply IHC1.
      constructor.
      intros.
      firstorder.
      apply (H0 _ H1).
      firstorder.
    }
    { apply IHC2.
      constructor.
      intros.
      firstorder.
      apply (H0 _ H1).
      firstorder.
    }
  }
Qed.

Lemma hoare_pred :
  forall (T V : Type) (C : @Stmt T V) P Q, ValidHoareTriple P C Q <-> ValidHoareTriple P (Statement.Spec (pred C)) Q.
Proof.
  intros T V C P Q.
  split.
  { apply pred_if_hoare; auto. }
  { apply hoare_if_pred; auto. }
Qed.

Theorem hoare_rule_abort : forall T U (P : @Predicate T)(Q : @Predicate U), (forall s, ~ P s) -> P {: abort :} Q.
Proof. intros; constructor; firstorder. Qed.

Theorem hoare_rule_skip : forall T (P : @Predicate T), P {: Skip :} P.
Proof. intros; constructor; auto. Qed.

Theorem hoare_rule_of_consequence : forall T V (P P' : @Predicate T) (Q Q' : @Predicate V) (S : @Stmt T V),
    (forall s, P s -> P' s) -> P' {: S :} Q' -> (forall s, Q' s -> Q s) -> P {: S :} Q.
Proof.
  (* intros.
  induction H0.
  admit.
  admit.
  pose proof (IHValidHoareTriple1 _ Q0 H).
  pose proof (IHValidHoareTriple2 Q0).
  apply (Seq _ _ Q0).
  auto.
  auto.
  constructor.
  auto.
  apply IHValidHoareTriple1; auto.
  firstorder.
  apply IHValidHoareTriple2; auto.
  firstorder.
  Print ValidHoareTriple.
  apply (While _ _ Q I _ _ R V); auto. *)
 (* induction S.
  admit.
  admit.
  intros.
  inversion H0; subst; clear H0.
  inversion_sigma; simpl in *.
  rewrite H2 in *. *)
  intros.
  rewrite hoare_pred.
  rewrite hoare_pred in H0.
  pose proof (spec_inj H0).
  clear H0.
  constructor.
  firstorder.
Qed.

Lemma pred_refines_iff_hoare_refines : forall T V (Q R : T >> V),
    Predicative.refines (Statement.Spec Q) (Statement.Spec R) <-> HoareWp.refines (Statement.Spec Q) (Statement.Spec R).
Proof.
  unfold Predicative.refines, HoareWp.refines; intros; split; intros HHrefines; simpl in *.
  { intros K K' HHr.
    pose proof (spec_inj HHr).
    constructor.
    split; intros.
    { apply (H _ H0).
      apply HHrefines; auto.
      apply (H _ H0).
    }
    { apply HHrefines.
      apply (H _ H0).
    }
  }
  { intros.
    assert (ValidHoareTriple (fun r => r = s) (Statement.Spec R) (fun r' => R s r')).
    { constructor.
      intros r HHr.
      subst r.
      auto.
    }
    apply HHrefines in H0.
    pose proof (spec_inj H0).
    apply (H1 s (eq_refl s)).
  }
Qed.

Theorem hoare_refines_iff_pred_refines_simplified :
  forall T V (Q R : @Stmt T V), HoareWp.refines Q R <-> Predicative.refines Q R.
Proof.
  intros T V Q R.
  unfold HoareWp.refines.
  setoid_rewrite (hoare_pred _ _ _ _ _).
  setoid_rewrite (hoare_pred _ _ _ _ _).
  setoid_rewrite <- pred_refines_iff_hoare_refines.
  unfold Predicative.refines; simpl.
  reflexivity.
Qed.

Theorem pred_refines_if_hoare_refines :
  forall T V (Q R : @Stmt T V), HoareWp.refines Q R -> Predicative.refines Q R.
Proof.
  intros T V Q R; intros HHrefines.
  apply pred_refines_iff_hoare_refines.
  unfold HoareWp.refines in *.
  intros Pre Post HHprepost.
  apply hoare_if_pred in HHprepost; auto.
  apply HHrefines in HHprepost.
  apply (pred_if_hoare _ _ Q); auto.
Qed.

Theorem hoare_refines_if_pred_refines :
  forall T V (Q R : @Stmt T V), Predicative.refines Q R -> HoareWp.refines Q R.
Proof.
  intros T V Q R; intros HHrefines.
  unfold HoareWp.refines; intros Pre Post HHprepost.
  apply hoare_if_pred; auto.
  constructor.
  apply pred_if_hoare in HHprepost; auto.
  pose proof (spec_inj HHprepost).
  firstorder.
Qed.

Theorem hoare_refines_iff_pred_refines :
  forall T V (Q R : @Stmt T V), HoareWp.refines Q R <-> Predicative.refines Q R.
Proof.
  intros T V Q R.
  split; intros HHrefines.
  { apply pred_refines_iff_hoare_refines.
    unfold HoareWp.refines in *.
    intros Pre Post HHprepost.
    apply hoare_pred in HHprepost; auto.
    apply (hoare_pred _ _ Q); auto.
  }
  { unfold HoareWp.refines; intros Pre Post HHprepost.
    apply hoare_pred; auto.
    apply hoare_pred in HHprepost; auto.
    constructor.
    pose proof (spec_inj HHprepost).
    firstorder.
  }
Qed.

Notation "P {{: S :}} Q" := (forall e1, (fun e => e1 = e /\ P e ) {: S :} (fun e' => Q e1 e')) (at level 50).

Lemma hoare_pred' : forall T T' (S : @Stmt T T') P Q, P {: S :} Q  <->  forall e, P e -> (exists e', pred S e e') /\ forall e', pred S e e' -> Q e'.
Proof.
  intros *.
  setoid_rewrite (hoare_pred _ _ _ _ _).
  split; intros H.
  { pose proof (@spec_inj _ _ _ _ _ H) as H'; clear H.
    firstorder.
  }
  { constructor.
    firstorder.
  }
Qed.

Lemma triple_ext_triple : forall T T' (S : @Stmt T T') (P : T -> Prop) (Q : T' -> Prop), P {{: S :}} (fun _ e' => Q e') <-> P {: S :} Q.
Proof.
  intros *.
  setoid_rewrite (hoare_pred _ _ _ _ _) at 1.
  setoid_rewrite (hoare_pred' _ _ _ _ _) at 1; simpl.
  split; intros H.
  { apply hoare_pred; constructor.
    intros e Hp.
    pose proof (H e _ (conj (eq_refl _) Hp)).
    firstorder.
  }
  { intros * (HHeq,HHp); subst e1; generalize e HHp; clear e HHp.
    apply hoare_pred'; auto.
  }
Qed.

Theorem extended_definition_iff_simple_definition : forall T V (S1 S2 : @Stmt T V),
    (forall P Q, P {: S1 :} Q -> P {: S2 :} Q)
    <-> (forall P (Q : T -> V -> Prop), (forall r, (fun s => r = s /\ P s) {: S1 :} (Q r)) -> forall r, (fun s => r = s /\ P s) {: S2 :} (Q r)).
Proof.
  intros *.
  split.
  { intros.
    apply H.
    apply H0.
  }
  { intros.
    apply triple_ext_triple.
    apply H.
    intros.
    unshelve eapply (hoare_rule_of_consequence _ _ _ _ _ _ _ _ H0); simpl; auto.
    clear; firstorder.
  }
Qed.


Require Import Coq.Lists.List.

Require Import Category.Lib.
Require Import Category.Instance.Lambda.Ltac.
Require Import Category.Instance.Lambda.Ty.
Require Import Category.Instance.Lambda.Exp.
Require Import Category.Instance.Lambda.Value.
Require Import Category.Instance.Lambda.Sub.

From Equations Require Import Equations.
Set Equations With UIP.

Generalizable All Variables.

Set Transparent Obligations.

(** Evaluation contexts *)

Section Full.

Import ListNotations.

Open Scope Ty_scope.

(* A context defines a hole which, after substitution, yields an expression of
   the index type. *)
Inductive Frame Γ : Ty → Ty → Type :=
  | F_PairL {τ1 τ2}  : Exp Γ τ2 → Frame τ1 (τ1 × τ2)
  | F_PairR {τ1 τ2}  : Exp Γ τ1 → Frame τ2 (τ1 × τ2)
  | F_Fst {τ1 τ2}    : Frame (τ1 × τ2) τ1
  | F_Snd {τ1 τ2}    : Frame (τ1 × τ2) τ2
  | F_AppL {dom cod} : Exp Γ dom → Frame (dom ⟶ cod) cod
  | F_AppR {dom cod} : Exp Γ (dom ⟶ cod) → Frame dom cod.

Derive Signature NoConfusion Subterm for Frame.

Inductive Ctxt Γ : Ty → Ty → Type :=
  | C_Nil {τ}         : Ctxt τ τ
  | C_Cons {τ τ' τ''} : Frame Γ τ' τ → Ctxt τ'' τ' → Ctxt τ'' τ.

Derive Signature NoConfusion NoConfusionHom Subterm for Ctxt.

(* [Ctxt] forms a category with objects = types and morphisms = contexts. *)

Definition Ctxt_id {Γ τ} : Ctxt Γ τ τ := C_Nil _.
Arguments Ctxt_id {_ _} /.

Program Fixpoint Ctxt_comp {Γ τ τ' τ''}
        (C : Ctxt Γ τ' τ) (C' : Ctxt Γ τ'' τ') : Ctxt Γ τ'' τ :=
  match C with
  | C_Nil _      => C'
  | C_Cons _ f c => C_Cons _ f (Ctxt_comp c C')
  end.

Theorem Ctxt_id_left {Γ τ τ'} {C : Ctxt Γ τ' τ} :
  Ctxt_comp Ctxt_id C = C.
Proof. induction C; simpl; auto; now f_equal. Qed.

Theorem Ctxt_id_right {Γ τ τ'} {C : Ctxt Γ τ' τ} :
  Ctxt_comp C Ctxt_id = C.
Proof. induction C; simpl; auto; now f_equal. Qed.

Theorem Ctxt_comp_assoc {Γ τ τ' τ'' τ'''}
        {C : Ctxt Γ τ' τ} {C' : Ctxt Γ τ'' τ'} {C'' : Ctxt Γ τ''' τ''} :
  Ctxt_comp C (Ctxt_comp C' C'') = Ctxt_comp (Ctxt_comp C C') C''.
Proof. induction C; simpl; auto; now f_equal. Qed.

Inductive Redex {Γ} : ∀ {τ}, Exp Γ τ → Exp Γ τ → Type :=
  | R_Beta {dom cod} (e : Exp (dom :: Γ) cod) v :
    ValueP v →
    Redex (APP (LAM e) v) (SubExp {|| v ||} e)
  | R_Fst {τ1 τ2} (x : Exp Γ τ1) (y : Exp Γ τ2) :
    ValueP x →
    ValueP y →
    Redex (Fst (Pair x y)) x
  | R_Snd {τ1 τ2} (x : Exp Γ τ1) (y : Exp Γ τ2) :
    ValueP x →
    ValueP y →
    Redex (Snd (Pair x y)) y.

Derive Signature for Redex.

Unset Elimination Schemes.

Inductive Plug {Γ τ'} (e : Exp Γ τ') : ∀ {τ}, Ctxt Γ τ' τ → Exp Γ τ → Type :=
  | Plug_Hole : Plug (C_Nil _) e

  | Plug_PairL {τ1 τ2} {C : Ctxt Γ τ' τ1} {e' : Exp Γ τ1} {e2 : Exp Γ τ2} :
    Plug C e' →
    Plug (C_Cons _ (F_PairL _ e2) C) (Pair e' e2)

  | Plug_PairR {τ1 τ2} {C : Ctxt Γ τ' τ2} {e1 : Exp Γ τ1} {e' : Exp Γ τ2} :
    ValueP e1 →
    Plug C e' →
    Plug (C_Cons _ (F_PairR _ e1) C) (Pair e1 e')

  | Plug_Fst {τ1 τ2} {C : Ctxt Γ τ' (τ1 × τ2)} {e' : Exp Γ (τ1 × τ2)} :
    Plug C e' →
    Plug (C_Cons _ (F_Fst _) C) (Fst e')

  | Plug_Snd {τ1 τ2} {C : Ctxt Γ τ' (τ1 × τ2)} {e' : Exp Γ (τ1 × τ2)} :
    Plug C e' →
    Plug (C_Cons _ (F_Snd _) C) (Snd e')

  | Plug_AppL {dom cod} {C : Ctxt Γ τ' (dom ⟶ cod)}
              {e' : Exp Γ (dom ⟶ cod)} {e2 : Exp Γ dom} :
    Plug C e' →
    Plug (C_Cons _ (F_AppL _ e2) C) (APP e' e2)

  | Plug_AppR {dom cod} {C : Ctxt Γ τ' dom}
              {e' : Exp Γ dom} {e1 : Exp Γ (dom ⟶ cod)} :
    ValueP e1 →
    Plug C e' →
    Plug (C_Cons _ (F_AppR _ e1) C) (APP e1 e').

Derive Signature for Plug.

Set Elimination Schemes.

Scheme Plug_ind := Induction for Plug Sort Type.

(* [Plug] forms a category with objects = expressions and morphisms = plugs
   over existential contexts. *)

Definition Plug_id {Γ τ} {x : Exp Γ τ} : Plug x (C_Nil Γ) x := Plug_Hole _.
Arguments Plug_id {_ _ _} /.

Fixpoint Plug_comp {Γ τ τ' τ''}
         {x : Exp Γ τ''} {y : Exp Γ τ'} {z : Exp Γ τ}
         {C : Ctxt Γ τ' τ} {C' : Ctxt Γ τ'' τ'}
         (P : Plug x C' y) (P' : Plug y C z) :
  Plug x (Ctxt_comp C C') z :=
  match P' with
  | Plug_Hole _       => P
  | Plug_PairL _ p'   => Plug_PairL _ (Plug_comp P p')
  | Plug_PairR _ V p' => Plug_PairR _ V (Plug_comp P p')
  | Plug_Fst _ p'     => Plug_Fst _ (Plug_comp P p')
  | Plug_Snd _ p'     => Plug_Snd _ (Plug_comp P p')
  | Plug_AppL _ p'    => Plug_AppL _ (Plug_comp P p')
  | Plug_AppR _ V p'  => Plug_AppR _ V (Plug_comp P p')
  end.

(*
(* This should be provable, but the dependent types get in the way. *)
Theorem Plug_id_left {Γ τ τ'} {C : Ctxt Γ τ' τ} {x : Exp Γ τ'} {y : Exp Γ τ}
        (P : Plug x C y) :
  Plug_comp Plug_id P ~= P.
*)

Inductive Step {Γ τ} : Exp Γ τ → Exp Γ τ → Type :=
  | StepRule {τ'} {C : Ctxt Γ τ' τ} {e1 e2 : Exp Γ τ'} {e1' e2' : Exp Γ τ} :
    Plug e1 C e1' →
    Plug e2 C e2' →
    Redex e1 e2 →
    Step e1' e2'.

Notation " t '--->' t' " := (Step t t') (at level 40).

Derive Signature for Step.

#[local] Hint Constructors ValueP Plug Redex Step : core.

#[local] Hint Extern 7 (_ ---> _) => repeat econstructor : core.

Theorem strong_progress {τ} (e : Exp [] τ) :
  ValueP e ∨ ∃ e', e ---> e'.
Proof.
  dependent induction e; reduce.
  - now left; constructor.
  - destruct IHe1 as [V1|[e1' H1']];
    destruct IHe2 as [V2|[e2' H2']].
    + now left; constructor.
    + dependent elimination H2'; now eauto 6.
    + dependent elimination H1'; now eauto 6.
    + dependent elimination H1';
      dependent elimination H2'; now eauto 6.
  - destruct IHe as [V|[e' H']].
    + dependent elimination V;  now eauto 6.
    + dependent elimination H'; now eauto 6.
  - destruct IHe as [V|[e' H']].
    + dependent elimination V;  now eauto 6.
    + dependent elimination H'; now eauto 6.
  - now inv v.
  - now left; constructor.
  - right.
    destruct IHe1 as [V1|[e1' H1']];
    destruct IHe2 as [V2|[e2' H2']].
    + dependent elimination V1;  now eauto 6.
    + dependent elimination H2'; now eauto 6.
    + dependent elimination H1'; now eauto 6.
    + dependent elimination H1'; now eauto 6.
Qed.

(*
Lemma Plug_deterministic {Γ τ} e2 :
  ∀ τ' (C : Ctxt Γ τ' τ) e1 e1',
    Redex e1 e1' → Plug e1 C e2 →
  ∀ τ'' (C' : Ctxt Γ τ'' τ) f1 f1',
    Redex f1 f1' → Plug f1 C' e2 →
    τ' = τ'' ∧ C ~= C' ∧ e1 ~= f1.
*)

Lemma Plug_functional {Γ τ τ'} {C : Ctxt Γ τ' τ} e :
  ∀ e1, Plug e C e1 → ∀ e2, Plug e C e2 → e1 = e2.
Proof.
  intros.
  dependent induction H0.
  - now inv H.
  - dependent destruction H.
    now f_equal; auto.
  - dependent destruction H.
    now f_equal; auto.
  - dependent destruction H.
    now f_equal; auto.
  - dependent destruction H.
    now f_equal; auto.
  - dependent destruction H.
    now f_equal; auto.
  - dependent destruction H.
    now f_equal; auto.
Qed.

Lemma Plug_injective {Γ τ τ'} {C : Ctxt Γ τ' τ} e :
  ∀ e1, Plug e1 C e → ∀ e2, Plug e2 C e → e1 = e2.
Proof.
  intros.
  dependent induction H0.
  - now inv H.
  - dependent destruction H.
    now f_equal; auto.
  - dependent destruction H.
    now f_equal; auto.
  - dependent destruction H.
    now f_equal; auto.
  - dependent destruction H.
    now f_equal; auto.
  - dependent destruction H.
    now f_equal; auto.
  - dependent destruction H.
    now f_equal; auto.
Qed.

Lemma Redex_deterministic {Γ τ} {e : Exp Γ τ} :
  ∀ e', Redex e e' → ∀ e'', Redex e e'' → e' = e''.
Proof.
  intros.
  dependent induction H0;
  dependent elimination H; eauto.
Qed.

Lemma AppL_LAM {Γ dom cod} {e e' : Exp Γ (dom ⟶ cod)} {x : Exp Γ dom} :
  e ---> e' →
  APP e x ---> APP e' x.
Proof.
  intros.
  dependent induction H; now eauto 6.
Qed.

Lemma AppR_LAM {Γ dom cod} {e : Exp (dom :: Γ) cod} {x x' : Exp Γ dom} :
  x ---> x' →
  APP (LAM e) x ---> APP (LAM e) x'.
Proof.
  intros.
  dependent induction H; now eauto 6.
Qed.

Definition normal_form `(R : crelation X) (t : X) : Type :=
  ∀ t', ¬ R t t'.

Definition deterministic `(R : crelation X) : Type :=
  ∀ x y1 y2 : X, R x y1 → R x y2 → y1 = y2.

(*
Lemma value_is_nf {Γ τ} (v : Exp Γ τ) :
  ValueP v → normal_form Step v.
*)

End Full.

Notation " t '--->' t' " := (Step t t') (at level 40).


Require Import Lia.
Require Import RelationClasses.

From sflib Require Import sflib.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import DataStructure.
From PromisingLib Require Import DenseOrder.
From PromisingLib Require Import Event.
Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.

Set Implicit Arguments.

Module MemoryFacts.
  Lemma promise_time_lt
        promises1 mem1 loc from to msg promises2 mem2 kind
        (PROMISE: Memory.promise promises1 mem1 loc from to msg promises2 mem2 kind)
        (KIND: Memory.op_kind_is_cancel kind = false):
    Time.lt from to.
  Proof.
    inv PROMISE; ss.
    - inv MEM. inv ADD. auto.
    - inv MEM. inv SPLIT. auto.
    - inv MEM. inv LOWER. auto.
  Qed.

  Lemma write_time_lt
        promises1 mem1 loc from to msg promises2 mem2 kind
        (WRITE: Memory.write promises1 mem1 loc from to msg promises2 mem2 kind):
    Time.lt from to.
  Proof.
    exploit Memory.write_not_cancel; eauto. i.
    inv WRITE. eapply promise_time_lt; eauto.
  Qed.

  Lemma promise_get1_diff
        promises1 mem1 loc from to msg promises2 mem2 kind
        l t f m
        (PROMISE: Memory.promise promises1 mem1 loc from to msg promises2 mem2 kind)
        (GET: Memory.get l t mem1 = Some (f, m))
        (DIFF: (loc, to) <> (l, t)):
    exists f', Memory.get l t mem2 = Some (f', m).
  Proof.
    inv PROMISE.
    - erewrite Memory.add_o; eauto. condtac; ss.
      + des. subst. congr.
      + esplits; eauto.
    - erewrite Memory.split_o; eauto. repeat condtac; ss.
      + des. subst. congr.
      + guardH o. des. subst.
        exploit Memory.split_get0; try exact MEM. i. des.
        rewrite GET in *. inv GET1. esplits; eauto.
      + esplits; eauto.
    - erewrite Memory.lower_o; eauto. condtac; ss.
      + des. subst. congr.
      + esplits; eauto.
    - erewrite Memory.remove_o; eauto. condtac; ss.
      + des. subst. congr.
      + esplits; eauto.
  Qed.

  Lemma promise_get_inv_diff
        promises1 mem1 loc from to msg promises2 mem2 kind
        l t f m
        (PROMISE: Memory.promise promises1 mem1 loc from to msg promises2 mem2 kind)
        (GET: Memory.get l t mem2 = Some (f, m))
        (DIFF: (loc, to) <> (l, t)):
    exists f', Memory.get l t mem1 = Some (f', m).
  Proof.
    revert GET. inv PROMISE.
    - erewrite Memory.add_o; eauto. condtac; ss.
      + des. subst. congr.
      + i. inv GET. esplits; eauto.
    - erewrite Memory.split_o; eauto. repeat condtac; ss.
      + des. subst. congr.
      + guardH o. des. subst. i. inv GET.
        exploit Memory.split_get0; try exact MEM; eauto. i. des. esplits; eauto.
      + i. esplits; eauto.
    - erewrite Memory.lower_o; eauto. condtac; ss.
      + des. subst. congr.
      + i. inv GET. esplits; eauto.
    - erewrite Memory.remove_o; eauto. condtac; ss.
      i. esplits; eauto.
  Qed.

  Lemma promise_get_promises_inv_diff
        promises1 mem1 loc from to msg promises2 mem2 kind
        l t f m
        (PROMISE: Memory.promise promises1 mem1 loc from to msg promises2 mem2 kind)
        (GET: Memory.get l t promises2 = Some (f, m))
        (DIFF: (loc, to) <> (l, t)):
    exists f', Memory.get l t promises1 = Some (f', m).
  Proof.
    revert GET. inv PROMISE.
    - erewrite Memory.add_o; eauto. condtac; ss.
      + des. subst. congr.
      + i. inv GET. esplits; eauto.
    - erewrite Memory.split_o; eauto. repeat condtac; ss.
      + des. subst. congr.
      + guardH o. des. subst. i. inv GET.
        exploit Memory.split_get0; try exact PROMISES; eauto. i. des. esplits; eauto.
      + i. esplits; eauto.
    - erewrite Memory.lower_o; eauto. condtac; ss.
      + des. subst. congr.
      + i. inv GET. esplits; eauto.
    - erewrite Memory.remove_o; eauto. condtac; ss.
      i. esplits; eauto.
  Qed.

  Lemma remove_get_diff
        promises0 mem0 loc from to msg promises1
        l t
        (LOC: loc <> l)
        (LE: Memory.le promises0 mem0)
        (REMOVE: Memory.remove promises0 loc from to msg promises1):
    Memory.get l t promises1 = Memory.get l t promises0.
  Proof.
    erewrite Memory.remove_o; eauto. condtac; ss.
    des. subst. congr.
  Qed.

  Lemma remove_cell_diff
        promises0 loc from to msg promises1
        l
        (LOC: loc <> l)
        (REMOVE: Memory.remove promises0 loc from to msg promises1):
    promises1 l = promises0 l.
  Proof.
    apply Cell.ext. i. eapply remove_get_diff; eauto. refl.
  Qed.

  Lemma get_same_from_aux
        l f t1 t2 m msg1 msg2
        (GET1: Memory.get l t1 m = Some (f, msg1))
        (GET2: Memory.get l t2 m = Some (f, msg2))
        (LE: Time.le t1 t2)
        (T1: t1 <> Time.bot):
    t1 = t2 /\ msg1 = msg2.
  Proof.
    inv LE; cycle 1.
    { inv H. rewrite GET1 in GET2. inv GET2. ss. }
    destruct (Cell.WF (m l)). exfalso.
    assert (t1 <> t2).
    { ii. subst. eapply Time.lt_strorder. eauto. }
    eapply DISJOINT; try exact H0; eauto.
    - apply Interval.mem_ub. exploit VOLUME; try exact GET1; eauto. intros x. des; ss.
      inv x. congr.
    - econs; ss.
      + exploit VOLUME; try exact GET1; eauto. intros x. des; ss. inv x. congr.
      + left. ss.
  Qed.

  Lemma get_same_from
        l f t1 t2 m msg1 msg2
        (GET1: Memory.get l t1 m = Some (f, msg1))
        (GET2: Memory.get l t2 m = Some (f, msg2))
        (T1: t1 <> Time.bot)
        (T2: t2 <> Time.bot):
    t1 = t2 /\ msg1 = msg2.
  Proof.
    destruct (Time.le_lt_dec t1 t2).
    - eapply get_same_from_aux; eauto.
    - exploit get_same_from_aux; (try by left; eauto); eauto. i. des. ss.
  Qed.

  Lemma write_not_bot
        pm1 mem1 loc from to msg pm2 mem2 kind
        (WRITE: Memory.write pm1 mem1 loc from to msg pm2 mem2 kind):
    to <> Time.bot.
  Proof.
    ii. subst.
    exploit Memory.write_not_cancel; eauto. i.
    inv WRITE. inv PROMISE; ss.
    - inv MEM. inv ADD. inv TO.
    - inv MEM. inv SPLIT. inv TS12.
    - inv MEM. inv LOWER. inv TS0.
  Qed.

  Lemma add_remove_eq
        mem1 mem2 mem3 loc from from' to msg msg'
        (ADD: Memory.add mem1 loc from to msg mem2)
        (REMOVE: Memory.remove mem2 loc from' to msg' mem3):
    mem3 = mem1.
  Proof.
    apply Memory.ext. i.
    erewrite (@Memory.remove_o mem3); eauto.
    erewrite (@Memory.add_o mem2); eauto.
    condtac; ss. des. subst. symmetry.
    eapply Memory.add_get0. eauto.
  Qed.

  Lemma write_add_promises
        promises1 mem1 loc from to msg promises2 mem2
        (WRITE: Memory.write promises1 mem1 loc from to msg promises2 mem2 Memory.op_kind_add):
    promises2 = promises1.
  Proof.
    inv WRITE. inv PROMISE. eapply add_remove_eq; eauto.
  Qed.

  Lemma promise_exists_None
        promises1 mem1 loc from to val released
        (LE: Memory.le promises1 mem1)
        (GET: Memory.get loc to promises1 = Some (from, Message.concrete val released))
        (LT: Time.lt from to):
    exists promises2 mem2,
      Memory.promise promises1 mem1 loc from to (Message.concrete val None) promises2 mem2 (Memory.op_kind_lower (Message.concrete val released)).
  Proof.
    exploit (@Memory.lower_exists promises1 loc from to
                                  (Message.concrete val released) (Message.concrete val None)); eauto.
    { econs; eauto. refl. }
    i. des.
    exploit Memory.lower_exists_le; eauto. i. des.
    esplits. econs; eauto; ss. econs. apply Time.bot_spec.
  Qed.

  Lemma released_time_lt
        mem loc from to val released
        (CLOSED: Memory.closed mem)
        (GET: Memory.get loc to mem = Some (from, Message.concrete val (Some released))):
    Time.lt from to.
  Proof.
    destruct (Cell.WF (mem loc)). exploit VOLUME; eauto. intros x. des; ss. inv x.
    inv CLOSED. rewrite INHABITED in GET. inv GET.
  Qed.
End MemoryFacts.


From Coq.Init Require Import Notations Datatypes.
Require Import Coq.Program.Tactics.
From Coq.Logic Require Import FunctionalExtensionality.
From mathcomp Require Import ssreflect ssrfun seq.
From mathcomp Require Import eqtype choice fintype bigop generic_quotient tuple finfun.

Set Warnings "-parsing". (* Some weird bug in ssrbool throws out parsing warnings*)
  From mathcomp Require Import ssrbool ssrnat.
Set Warnings "parsing".

Set Warnings "-ambiguous-paths". (* Some weird bug in ssralg throws out coercion warnings*)
    From mathcomp Require Import ssralg.
Set Warnings "ambiguous-paths".

Open Scope ring_scope.
Set Implicit Arguments.
Unset Strict Implicit.
Include GRing.

Reserved Notation "\bigoplus_ i F"
(at level 41, F at level 41, i at level 50,
  right associativity,
        format "'[' \bigoplus_ i '/ ' F ']'").

Reserved Notation "\bigoplus F"
(at level 36, F at level 36,
  right associativity,
        format "'[' \bigoplus F ']'").

Reserved Notation "\bigoplus_ ( i : t ) F"
(at level 36, F at level 36, i at level 50,
        format "'[' \bigoplus_ ( i : t ) '/ ' F ']'").

Reserved Notation "\bigoplus_ ( i < n ) F"
(at level 36, F at level 36, i, n at level 50,
        format "'[' \bigoplus_ ( i < n ) F ']'").

Reserved Notation "\bigoplus_ ( i 'in' A ) F"
(at level 36, F at level 36, i, A at level 50,
        format "'[' \bigoplus_ ( i 'in' A ) '/ ' F ']'").

Reserved Notation "\proj^( I )_ f "
(at level 36, f at level 36, I at level 36,
  format "'[' \proj^( I )_ f ']'").

Reserved Notation "\inj^( I )_ f "
(at level 36, f at level 36, I at level 36,
  format "'[' \inj^( I )_ f ']'").

Reserved Notation "\proj_ f ^( I ) "
(at level 36, f at level 36, I at level 36,
  format "'[' \proj_ f '^(' I ) ']'").

Reserved Notation "\inj_ f ^( I )"
(at level 36, f at level 36, I at level 36,
  format "'[' \inj_ f '^(' I ) ']'").

Module BigOplus.
  Module Pair.
    Section Def.
    Variable (R : ringType).
    Section ClassDef.
      Variable (lmodExtra : Type) (make : lmodExtra -> lmodType R).
      Local Coercion make : lmodExtra >-> lmodType.

      Section Mixin.
        Variable (oplus : lmodExtra -> lmodExtra -> lmodExtra).
        Structure mixin := Mixin {
          incl1_raw : forall (m1 m2 : lmodExtra), m1 -> (oplus m1 m2);
          incl2_raw : forall (m1 m2 : lmodExtra), m2 -> (oplus m1 m2);
          proj1_raw : forall (m1 m2 : lmodExtra), (oplus m1 m2) -> m1;
          proj2_raw : forall (m1 m2 : lmodExtra), (oplus m1 m2) -> m2;
        }.
        Structure prop_mixin (mx : mixin) := PropMixin {
          incl1_lin : forall (m1 m2 : lmodExtra), linear (@incl1_raw mx m1 m2);
          incl1 := fun (m1 m2 : lmodExtra) => locked (Linear (@incl1_lin m1 m2));
          incl2_lin : forall (m1 m2 : lmodExtra), linear (@incl2_raw mx m1 m2);
          incl2 := fun (m1 m2 : lmodExtra) => locked (Linear (@incl2_lin m1 m2));
          proj1_lin : forall (m1 m2 : lmodExtra), linear (@proj1_raw mx m1 m2);
          proj1 := fun (m1 m2 : lmodExtra) => locked (Linear (@proj1_lin m1 m2));
          proj2_lin : forall (m1 m2 : lmodExtra), linear (@proj2_raw mx m1 m2);
          proj2 := fun (m1 m2 : lmodExtra) => locked (Linear (@proj2_lin m1 m2));
          proj1_incl1K_raw : forall (m1 m2 : lmodExtra) x, @proj1_raw mx m1 m2 (@incl1_raw mx m1 m2 x) = x;
          proj2_incl2K_raw : forall (m1 m2 : lmodExtra) x, @proj2_raw mx m1 m2 (@incl2_raw mx m1 m2 x) = x;
          proj1_incl20_raw : forall (m1 m2 : lmodExtra) x, @proj1_raw mx m1 m2 (@incl2_raw mx m1 m2 x) = 0;
          proj2_incl10_raw : forall (m1 m2 : lmodExtra) x, @proj2_raw mx m1 m2 (@incl1_raw mx m1 m2 x) = 0;
          incl_proj_sum_raw : forall (m1 m2 : lmodExtra) x, x = @incl1_raw mx m1 m2 (@proj1_raw mx m1 m2 x) + @incl2_raw mx m1 m2 (@proj2_raw mx m1 m2 x);
        }.
      End Mixin.

      Section Results.
        Variable (oplus : lmodExtra -> lmodExtra -> lmodExtra).
        Variable (mx : mixin oplus) (pmx : prop_mixin mx).
        Lemma proj1_incl1K : forall (m1 m2 : lmodExtra) x, proj1 pmx m1 m2 (incl1 pmx m1 m2 x) = x.
        Proof. rewrite/proj1/incl1=>m1 m2 x=>/=; unlock (locked _);
        by apply (proj1_incl1K_raw pmx). Qed.
        Lemma proj2_incl2K : forall (m1 m2 : lmodExtra) x, proj2 pmx m1 m2 (incl2 pmx m1 m2 x) = x.
        Proof. rewrite/proj2/incl2=>m1 m2 x=>/=; unlock (locked _);
        by apply (proj2_incl2K_raw pmx). Qed.
        Lemma proj1_incl20 : forall (m1 m2 : lmodExtra) x, proj1 pmx m1 m2 (incl2 pmx m1 m2 x) = 0.
        Proof. rewrite/proj1/incl2=>m1 m2 x=>/=; unlock (locked _);
        by apply (proj1_incl20_raw pmx). Qed.
        Lemma proj2_incl10 : forall (m1 m2 : lmodExtra) x, proj2 pmx m1 m2 (incl1 pmx m1 m2 x) = 0.
        Proof. rewrite/proj2/incl1=>m1 m2 x=>/=; unlock (locked _);
        by apply (proj2_incl10_raw pmx). Qed.
        Lemma incl_proj_sum : forall (m1 m2 : lmodExtra) x, x = incl1 pmx m1 m2 (proj1 pmx m1 m2 x) + incl2 pmx m1 m2 (proj2 pmx m1 m2 x).
        Proof. rewrite/proj1/incl1/proj2/incl2=>m1 m2 x=>/=; unlock (locked _);
        by apply (incl_proj_sum_raw pmx). Qed.
      End Results.

      Structure class := Class { oplus : _; mixin_of : mixin oplus; prop_mixin_of : prop_mixin mixin_of}.
    End ClassDef.

    Structure type := Pack { sort : Type; to_lmod : sort -> lmodType R ; class_of : class to_lmod}.
    End Def.

    Module Exports.
      Coercion sort : type >-> Sortclass.
      Coercion class_of : type >-> class.
      Coercion mixin_of : class >-> mixin.
      Coercion prop_mixin_of : class >-> prop_mixin.

      Infix "\oplus" := (oplus _) (at level 35).
      Notation "\proj1^( m1 , m2 )" := (proj1 _ m1 m2).
      Notation "\proj2^( m1 , m2 )" := (proj2 _ m1 m2).
      Notation "\incl1^( m1 , m2 )" := (incl1 _ m1 m2).
      Notation "\incl2^( m1 , m2 )" := (incl2 _ m1 m2).
    End Exports.
  End Pair.

  Module Seq.
    Section Def.
      Variable (R : ringType).
      Section ClassDef.
      Variable (lmodExtra : Type) (make : lmodExtra -> lmodType R) (lmodZero : lmodExtra).
      Local Coercion make : lmodExtra >-> lmodType.

      Section Mixin.
        Variable (oplus : lmodExtra -> lmodExtra -> lmodExtra).

        Definition Nth (T : eqType) (I : T -> lmodExtra) := (fun L n
        => match (seq.nth None (map Some L) n) with
        |Some t => I t
        |None => lmodZero
        end).

        Fixpoint DS (T : eqType) (I : T -> lmodExtra) (L : seq T) : lmodExtra
        := match L with
          |nil => lmodZero
          |a'::L' => oplus (I a') (DS I L')
        end.

        Structure mixin := Mixin {
          incl_raw : forall (T : eqType) (I : T -> lmodExtra) L n, Nth I L n -> DS I L;
          proj_raw : forall (T : eqType) (I : T -> lmodExtra) L n, DS I L -> Nth I L n;
        }.
        Structure prop_mixin (mx : mixin) := PropMixin {
          incl_lin : forall (T : eqType) (I : T -> lmodExtra) L n, linear (@incl_raw mx T I L n);
          incl := fun (T : eqType) (I : T -> lmodExtra) L n => locked (Linear (@incl_lin T I L n));
          proj_lin : forall (T : eqType) (I : T -> lmodExtra) L n, linear (@proj_raw mx T I L n);
          proj := fun (T : eqType) (I : T -> lmodExtra) L n => locked (Linear (@proj_lin T I L n));
          proj_inclK_raw : forall (T : eqType) (I : T -> lmodExtra) L n x, @proj_raw mx T I L n (@incl_raw mx T I L n x) = x;
          proj_incl0_raw : forall (T : eqType) (I : T -> lmodExtra) L n n' x, (n != n') -> @proj_raw mx T I L n (@incl_raw mx T I L n' x) = 0;
          incl_proj_sum_raw : forall (T : eqType) (I : T -> lmodExtra) L x, x = \sum_(n : 'I_(size L))@incl_raw mx T I L n (@proj_raw mx T I L n x);
        }.
      End Mixin.

      Section Results.
        Variable (oplus : lmodExtra -> lmodExtra -> lmodExtra).
        Variable (mx : mixin oplus) (pmx : prop_mixin mx).
        Lemma proj_inclK : forall (T : eqType) (I : T -> lmodExtra) L n x, proj pmx I L n (incl pmx I L n x) = x.
        Proof. rewrite/proj/incl=>T I L n x=>/=; unlock (locked _);
        by apply (proj_inclK_raw pmx). Qed.
        Lemma proj_incl0 : forall (T : eqType) (I : T -> lmodExtra) L n n' x, (n != n') -> proj pmx I L n (incl pmx I L n' x) = 0.
        Proof. rewrite/proj/incl=>T I L n n' x H=>/=; unlock (locked _);
        by apply (proj_incl0_raw pmx). Qed.
        Lemma incl_proj_sum : forall (T : eqType) (I : T -> lmodExtra) L x, x = \sum_(n : 'I_(size L))incl pmx I L n (proj pmx I L n x).
        Proof. rewrite/proj/incl=>T I L x=>/=.
        (have : forall (n : 'I_(size L)) (_ : true),
        locked (Linear (incl_lin pmx (I:=I) (L:=L) (n:=n))) (locked (Linear (proj_lin pmx (I:=I) (L:=L) n)) x)
         = incl_raw mx (I:=I) (L:=L) (n:=n) (proj_raw mx (I:=I) (L:=L) n x)
        by move=>n _; unlock (locked _)=>/=)=>H.
        by rewrite (eq_bigr _ H) -(incl_proj_sum_raw pmx). Qed.
      End Results.

      Structure class := Class { oplus : _;
        pair_mixin_of : Pair.mixin make oplus;
        pair_prop_mixin_of : Pair.prop_mixin pair_mixin_of;
        mixin_of : mixin oplus;
        prop_mixin_of : prop_mixin mixin_of}.
    End ClassDef.

    Structure type := Pack { sort : Type; zero : sort; to_lmod : sort -> lmodType R ; class_of : class to_lmod zero}.
    End Def.

    Module Exports.
      Coercion sort : type >-> Sortclass.
      Coercion class_of : type >-> class.
      Coercion mixin_of : class >-> mixin.
      Coercion prop_mixin_of : class >-> prop_mixin.
      Coercion pair_mixin_of : class >-> Pair.mixin.
      Coercion pair_prop_mixin_of : class >-> Pair.prop_mixin.

      Notation "\bigoplus_ ( i 'in' A ) F" := (DS (filter F (fun i => i \in A))).
    End Exports.
  End Seq.
  Module Fin.
    Section Def.
      Variable (R : ringType).
      Section ClassDef.
        Variable (lmodExtra : Type) (make : lmodExtra -> lmodType R) (lmodZero : lmodExtra).
        Local Coercion make : lmodExtra >-> lmodType.
        Section Mixin.
          Variable (oplus : lmodExtra -> lmodExtra -> lmodExtra).

          Definition DS (F : finType) (I : F -> lmodExtra) : lmodType R
           := @Seq.DS lmodExtra lmodZero oplus F I (enum F).

          Structure mixin := Mixin {
            incl_raw : forall (F : finType) (I : F -> lmodExtra) f, I f -> DS I;
            proj_raw : forall (F : finType) (I : F -> lmodExtra) f, DS I -> I f;
          }.
          Structure prop_mixin (mx : mixin) := PropMixin {
            incl_lin : forall (F : finType) (I : F -> lmodExtra) f, linear (@incl_raw mx F I f);
            incl := fun (F : finType) (I : F -> lmodExtra) f => locked (Linear (@incl_lin F I f));
            proj_lin : forall (F : finType) (I : F -> lmodExtra) f, linear (@proj_raw mx F I f);
            proj := fun (F : finType) (I : F -> lmodExtra) f => locked (Linear (@proj_lin F I f));
            proj_inclK_raw : forall (F : finType) (I : F -> lmodExtra) f x, @proj_raw mx F I f (@incl_raw mx F I f x) = x;
            proj_incl0_raw : forall (F : finType) (I : F -> lmodExtra) f f' x, (f != f') -> @proj_raw mx F I f (@incl_raw mx F I f' x) = 0;
            incl_proj_sum_raw : forall (F : finType) (I : F -> lmodExtra) x, x = \sum_(f : F)@incl_raw mx F I f (@proj_raw mx F I f x);
          }.
        End Mixin.

        Section Results.
        Variable (oplus : lmodExtra -> lmodExtra -> lmodExtra).
        Variable (mx : mixin oplus) (pmx : prop_mixin mx).
          Lemma proj_inclK : forall (F : finType) (I : F -> lmodExtra) f x, proj pmx I f (incl pmx I f x) = x.
          Proof. rewrite/proj/incl=>F I f x=>/=; unlock (locked _);
          by apply (proj_inclK_raw pmx). Qed.
          Lemma proj_incl0 : forall (F : finType) (I : F -> lmodExtra) f f' x, (f != f') -> proj pmx I f (incl pmx I f' x) = 0.
          Proof. rewrite/proj/incl=>F I f x=>/=; unlock (locked _);
          by apply (proj_incl0_raw pmx). Qed.
          Lemma incl_proj_sum : forall (F : finType) (I : F -> lmodExtra) x, x = \sum_(f : F)incl pmx I f (proj pmx I f x).
          Proof. rewrite/proj/incl=>F I x=>/=.
            (have : forall (f : F) (_ : true),
            locked (Linear (incl_lin pmx (I:=I) (f:=f))) (locked (Linear (proj_lin pmx (I:=I) f)) x)
            = incl_raw mx (I:=I) (f:=f) (proj_raw mx (I:=I) f x)
            by move=>n _; unlock (locked _)=>/=)=>H.
            by rewrite (eq_bigr _ H) -(incl_proj_sum_raw pmx). Qed.
        End Results.

        Structure class := Class { oplus : _;
                                  pair_mixin_of : Pair.mixin make oplus;
                                  pair_prop_mixin_of : Pair.prop_mixin pair_mixin_of;
                                  seq_mixin_of : Seq.mixin make lmodZero oplus;
                                  seq_prop_mixin_of : Seq.prop_mixin seq_mixin_of;
                                  mixin_of : mixin oplus;
                                  prop_mixin_of : prop_mixin mixin_of}.
      End ClassDef.
    End Def.

    Structure type := Pack { sort : Type; R : ringType; zero : sort; to_lmod : sort -> lmodType R ; class_of : class to_lmod zero}.
    Module Exports.
      Coercion sort : type >-> Sortclass.
      Coercion class_of : type >-> class.
      Coercion mixin_of : class >-> mixin.
      Coercion prop_mixin_of : class >-> prop_mixin.
      Coercion seq_mixin_of : class >-> Seq.mixin.
      Coercion seq_prop_mixin_of : class >-> Seq.prop_mixin.
      Coercion pair_mixin_of : class >-> Pair.mixin.
      Coercion pair_prop_mixin_of : class >-> Pair.prop_mixin.

      Notation "\bigoplus_ i F" := (DS (fun i => F i)).
      Notation "\bigoplus F" := (DS F).
      Notation "\bigoplus_ ( i : t ) F" := (DS (fun i : t => F i)).
      Notation "\proj^( I )_ f " := (proj I f).
      Notation "\inj^( I )_ f " := (incl I f).
      Notation "\proj_ f ^( I )" := (proj I f).
      Notation "\inj_ f ^( I )" := (incl I f).
    End Exports.
  End Fin.
End BigOplus.

Export BigOplus.Fin.Exports.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^336 - 3
Base: 32
***)

Definition curve : CurveParameters :=
  {|
    sz := 11%nat;
    base := 32;
    bitwidth := 32;
    s := 2^336;
    c := [(1, 3)];
    carry_chains := None;

    a24 := None;
    coef_div_modulus := None;

    goldilocks := None;
    karatsuba := None;
    montgomery := true;
    freeze := Some false;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Require Import Coq.Program.Tactics.

Require Import SpecCert.Utils.
Require Import SpecCert.x86.Architecture.MemoryController.MemoryController_rec.

Definition memory_controller_eq
           (m m': MemoryController) :=
  smramc m = smramc m'.

Lemma memory_controller_eq_eq
      (m m': MemoryController)
  : memory_controller_eq m m' -> m = m'.
Proof.
  induction m as [s].
  induction m' as [s'].
  unfold memory_controller_eq, smramc.
  intro Heq.
  rewrite Heq.
  reflexivity.
Qed.

Lemma eq_memory_controller_eq
      (m m': MemoryController)
      (Heq:  m = m')
  : memory_controller_eq m m'.
Proof.
  induction m as [s].
  induction m' as [s'].
  rewrite Heq.
  reflexivity.
Qed.

Program Definition memory_controller_eq_dec
        (m m': MemoryController)
  : { memory_controller_eq m m' } + { ~ memory_controller_eq m m' } :=
  decide_dec (smramc_eq_dec (smramc m) (smramc m')).
Next Obligation.
  unfold memory_controller_eq.
  apply smramc_eq_eq.
  trivial.
Defined.
Next Obligation.
  unfold memory_controller_eq.
  unfold not in H; unfold not.
  intro Hfalse.
  apply eq_smramc_eq in Hfalse.
  apply H in Hfalse.
  trivial.
Defined.


Require Import List.
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq tuple ssrfun.
From mathcomp Require Import choice path bigop fintype.

Require Import Lib.Base Ipdl.Exp Ipdl.Core String Ipdl.Lems Lib.TupleLems Ipdl.Tacs Lib.Dist Ipdl.Big Pars Lib.Set Ipdl.Approx Encodable.
Open Scope bool_scope.
Section AuthExample.
  Context (K D R : nat) (gen : Dist (K.-bv)) (H : K.-bv -> D.-bv -> R.-bv).

  Definition HashReal (i1 i2 : chan D.-bv) (k : chan (K.-bv)) (o : chan bool) :=
    pars [::
            k ::= Samp gen;
            o ::=
            (k <-- Read k;;
             x <-- Read i1;;
             y <-- Read i2 ;; Ret (H k x == H k y))].

  Definition HashIdeal (i1 i2 : chan D.-bv) (k : chan (K.-bv)) (o : chan bool) :=
    pars [::
            k ::= Samp gen;
            o ::=
            (_ <-- Read k ;; x <-- Read i1 ;; y <-- Read i2 ;; Ret (x == y))].

  Definition protocol (key : chan K.-bv) (xA xB : chan D.-bv) (ok : chan unit) :=
    diverge <- new unit;;
    b2a <- new R.-bv;;
    pars [::
            diverge ::= Read diverge;
            key ::= Samp gen;
            b2a ::= (k <-- Read key;; x <-- Read xB ;; Ret (H k x));
            ok ::= (k <-- Read key;; x <-- Read xA ;; v <-- Read b2a ;; if (H k x == v) then Ret tt else Read diverge)].

  Definition protocol_ideal (key : chan K.-bv) (xA xB : chan D.-bv) (ok : chan unit) :=
    diverge <- new unit;;
    pars [::
            diverge ::= Read diverge;
            key ::= Samp gen;
            ok ::= (x <-- Read xA ;; y <-- Read xB ;; if x == y then Ret tt else Read diverge) ].

  Lemma protocol_hybrid k xA xB ok :
    protocol k xA xB ok =p
                           (
                            diverge <- new unit ;;
                            b <- new bool ;;
                            pars [::
                                    diverge ::= Read diverge;
                                    HashReal xA xB k b;
                                    ok ::= (x <-- Read b ;; if x then Ret tt else Read diverge)]).
    rewrite /protocol.
    Intro => diverge.
    swap_tac 0 3.
    swap_tac 1 2.
    under_new swap_at 0 0 2; simpl.
    simpl.
    rewrite pars_fold.
    symmetry.
    rewrite /HashReal.
    swap_tac 0 1.
    setoid_rewrite pars_pars; simpl.
    swap_tac 0 3.
    rewrite pars_fold.
    align.
    apply EqCongReact.
    simp_rxn.
    symmetry; simp_rxn.
    r_swap 1 2.
    rewrite EqReadSame.
    r_swap 1 2.
    done.
 Qed.

  Definition protocol_err e ok :=
  ENew
    (fun diverge : chan unit =>
     ENew
       (fun b : chan bool =>
        EComp (e b) [|| ok ::= (x <-- Read b;; (if x then Ret tt else Read diverge));diverge ::= Read diverge])).

  Lemma protocol_secure k xA xB ok e :
    (forall xA xB k b, HashReal xA xB k b =a_(e xA xB k b) HashIdeal xA xB k b) ->
    protocol k xA xB ok =a_(protocol_err (e xA xB k) ok) protocol_ideal k xA xB ok.
    intros.
    etrans.
    apply protocol_hybrid.
    atrans.
    Intro => diverge.
    Intro => b.
    arewrite (H0 xA xB k b).
    apply AEq_zero; apply EqRefl.
    apply EqERefl.
    simpl.
    apply AEq_zero.
    rewrite /protocol_ideal.
    Intro => diverge.
    rewrite /HashIdeal.
    swap_tac 0 1.
    setoid_rewrite pars_pars; simpl.
    swap_tac 0 3.
    rewrite pars_fold.
    simp_at 0.
    swap_tac 1 2.
    rewrite -pars_mkdep //=.
    align.
    rewrite adde0.
    setoid_rewrite adde0.
    setoid_rewrite EqCompComp.
    setoid_rewrite pars_rcons; simpl.
    done.
  Qed.

Lemma encodable_prot k xa xb ok : EncodableIPDL (protocol k xa xb ok).
  rewrite /protocol.
  apply _.
Qed.

Require Import Typ Lib.SeqOps.

Lemma protocol_t k xA xB ok :
  ipdl_t [:: mkChan k; mkChan ok] (protocol k xA xB ok).
  rewrite /protocol; repeat type_tac.
  perm_match.
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program 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 Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Import Termes.
Require Import Conv.

Inductive Ered1 : term -> term -> Prop :=
  | Ebeta : forall M N T : term, Ered1 (App (Abs T M) N) (subst N M)
  | Eabs : forall M T : term, Ered1 (Abs T M) (Abs (Srt prop) M)
  | Eabs_red_l :
      forall M M' : term,
      Ered1 M M' -> forall N : term, Ered1 (Abs M N) (Abs M' N)
  | Eabs_red_r :
      forall M M' : term,
      Ered1 M M' -> forall N : term, Ered1 (Abs N M) (Abs N M')
  | Eapp_red_l :
      forall M1 N1 : term,
      Ered1 M1 N1 -> forall M2 : term, Ered1 (App M1 M2) (App N1 M2)
  | Eapp_red_r :
      forall M2 N2 : term,
      Ered1 M2 N2 -> forall M1 : term, Ered1 (App M1 M2) (App M1 N2)
  | Eprod_red_l :
      forall M1 N1 : term,
      Ered1 M1 N1 -> forall M2 : term, Ered1 (Prod M1 M2) (Prod N1 M2)
  | Eprod_red_r :
      forall M2 N2 : term,
      Ered1 M2 N2 -> forall M1 : term, Ered1 (Prod M1 M2) (Prod M1 N2).

Inductive Ered (M : term) : term -> Prop :=
  | Erefl : Ered M M
  | Etrans_red : forall P N : term, Ered M P -> Ered1 P N -> Ered M N.

Inductive Econv (M : term) : term -> Prop :=
  | Erefl_conv : Econv M M
  | Etrans_conv_red : forall P N : term, Econv M P -> Ered1 P N -> Econv M N
  | Etrans_conv_exp : forall P N : term, Econv M P -> Ered1 N P -> Econv M N.

Inductive Epar_red1 : term -> term -> Prop :=
  | Epar_beta :
      forall M M' : term,
      Epar_red1 M M' ->
      forall N N' : term,
      Epar_red1 N N' ->
      forall T : term, Epar_red1 (App (Abs T M) N) (subst N' M')
  | Epar_abs :
      forall M M' : term,
      Epar_red1 M M' ->
      forall T : term, Epar_red1 (Abs T M) (Abs (Srt prop) M')
  | Esort_par_red : forall s : sort, Epar_red1 (Srt s) (Srt s)
  | Eref_par_red : forall n : nat, Epar_red1 (Ref n) (Ref n)
  | Eabs_par_red :
      forall M M' : term,
      Epar_red1 M M' ->
      forall T T' : term, Epar_red1 T T' -> Epar_red1 (Abs T M) (Abs T' M')
  | Eapp_par_red :
      forall M M' : term,
      Epar_red1 M M' ->
      forall N N' : term, Epar_red1 N N' -> Epar_red1 (App M N) (App M' N')
  | Eprod_par_red :
      forall M M' : term,
      Epar_red1 M M' ->
      forall N N' : term, Epar_red1 N N' -> Epar_red1 (Prod M N) (Prod M' N').

  Definition Epar_red := clos_trans term Epar_red1.

  Definition Enormal (t : term) : Prop := forall u : term, ~ Ered1 t u.

Hint Resolve Erefl Ebeta Eabs Eabs_red_l Eabs_red_r Eapp_red_l Eapp_red_r
  Eprod_red_l Eprod_red_r: ecoc.

Hint Resolve Etrans_red: ecoc.
Hint Resolve Erefl_conv Etrans_conv_red Etrans_conv_exp: ecoc.
Hint Resolve Epar_beta Epar_abs Esort_par_red Eref_par_red Eabs_par_red
  Eapp_par_red Eprod_par_red: ecoc.

(* normal -> E *)
Lemma red1_Ered1 : forall M N : term, red1 M N -> Ered1 M N.
simple induction 1; auto with ecoc.
Qed.

Hint Resolve red1_Ered1: ecoc.

Lemma red_Ered : forall M N : term, red M N -> Ered M N.
simple induction 1; eauto with ecoc.
Qed.

Hint Resolve red_Ered: ecoc.

Lemma conv_Econv : forall M N : term, conv M N -> Econv M N.
simple induction 1; eauto with ecoc.
Qed.

Hint Resolve conv_Econv: ecoc.

(* Ered *)

Lemma trans_Ered_Ered : forall M N P : term, Ered M N -> Ered N P -> Ered M P.
intros.
generalize H0 M H.
simple induction 1; auto with ecoc coc core arith sets.
intros; apply Etrans_red with P0; auto with ecoc coc core arith sets.
Qed.

(* Epar_red1 *)
Lemma refl_Epar_red1 : forall M : term, Epar_red1 M M.
simple induction M; auto with coc ecoc core arith sets.
Qed.

Hint Resolve refl_Epar_red1: ecoc.

Lemma Epar_red1_Epar_red : forall M N : term, Epar_red1 M N -> Epar_red M N.
intros; unfold Epar_red in |- *; apply t_trans with M; auto with ecoc sets.
Qed.

Hint Resolve Epar_red1_Epar_red: ecoc.

Lemma Epar_red1_lift :
 forall (n : nat) (a b : term),
 Epar_red1 a b -> forall k : nat, Epar_red1 (lift_rec n a k) (lift_rec n b k).
simple induction 1; simpl in |- *; eauto with coc ecoc core arith sets.
intros.
rewrite distr_lift_subst; auto with coc ecoc core arith sets.
Qed.

Hint Resolve Epar_red1_lift: ecoc.

Lemma Epar_red1_subst :
 forall c d : term,
 Epar_red1 c d ->
 forall a b : term,
 Epar_red1 a b ->
 forall k : nat, Epar_red1 (subst_rec a c k) (subst_rec b d k).
simple induction 1; simpl in |- *; eauto with coc ecoc core arith sets;
 intros.
rewrite distr_subst; auto with coc ecoc core arith sets.

elim (lt_eq_lt_dec k n); auto with coc ecoc core arith sets; intro a0.
elim a0; intros; auto with coc ecoc core arith sets.
unfold lift in |- *; auto with ecoc.
Qed.

Hint Resolve Epar_red1_subst: ecoc.

Lemma inv_Epar_red_abs :
 forall (P : Prop) (T U x : term),
 Epar_red1 (Abs T U) x ->
 (forall T' U' : term, x = Abs T' U' -> Epar_red1 U U' -> P) -> P.
do 5 intro.
inversion_clear H; intros.
apply H with (Srt prop) M'; auto with ecoc.
apply H with T' M'; auto with ecoc.
Qed.

Lemma Ered1_Epar_red1 : forall M N : term, Ered1 M N -> Epar_red1 M N.
simple induction 1; eauto with ecoc coc core arith sets; intros.
Qed.

Hint Resolve Ered1_Epar_red1: ecoc.

Lemma Ered_Epar_red : forall M N : term, Ered M N -> Epar_red M N.
red in |- *; simple induction 1; intros; auto with ecoc coc core arith sets.
apply t_trans with P; auto with ecoc coc core arith sets.
Qed.

Lemma Ered_Ered_app :
 forall u u0 v v0 : term,
 Ered u u0 -> Ered v v0 -> Ered (App u v) (App u0 v0).
simple induction 1.
simple induction 1; intros; auto with ecoc coc core arith sets.
apply Etrans_red with (App u P); auto with ecoc coc core arith sets.

intros; apply Etrans_red with (App P v0); auto with ecoc coc core arith sets.
Qed.

Lemma Ered_Ered_abs :
 forall u u0 v v0 : term,
 Ered u u0 -> Ered v v0 -> Ered (Abs u v) (Abs u0 v0).
simple induction 1.
simple induction 1; intros; auto with ecoc coc core arith sets.
apply Etrans_red with (Abs u P); auto with ecoc coc core arith sets.

intros; apply Etrans_red with (Abs P v0); auto with ecoc coc core arith sets.
Qed.

Lemma Ered_Ered_prod :
 forall u u0 v v0 : term,
 Ered u u0 -> Ered v v0 -> Ered (Prod u v) (Prod u0 v0).
simple induction 1.
simple induction 1; intros; auto with ecoc coc core arith sets.
apply Etrans_red with (Prod u P); auto with ecoc coc core arith sets.

intros; apply Etrans_red with (Prod P v0); auto with ecoc coc core arith sets.
Qed.

Hint Resolve Ered_Ered_app Ered_Ered_abs Ered_Ered_prod: ecoc.

Lemma Epar_red_Ered : forall M N : term, Epar_red M N -> Ered M N.
simple induction 1.
simple induction 1; intros; eauto with ecoc coc core arith sets.

intros; apply trans_Ered_Ered with y; auto with ecoc coc core arith sets.
Qed.

Hint Resolve Ered_Epar_red Epar_red_Ered: ecoc.

(* Ered1 *)
Lemma Ered1_lift :
 forall u v : term,
 Ered1 u v -> forall n k : nat, Ered1 (lift_rec n u k) (lift_rec n v k).
simple induction 1; simpl in |- *; intros; auto with ecoc coc core arith sets.
rewrite distr_lift_subst; auto with ecoc coc core arith sets.
Qed.

Hint Resolve Ered1_lift: ecoc.

Lemma Ered1_subst_r :
 forall t u : term,
 Ered1 t u ->
 forall (a : term) (k : nat), Ered1 (subst_rec a t k) (subst_rec a u k).
simple induction 1; simpl in |- *; intros; auto with ecoc coc core arith sets.
rewrite distr_subst; auto with ecoc coc core arith sets.
Qed.

Lemma Ered1_subst_l :
 forall (a t u : term) (k : nat),
 Ered1 t u -> Ered (subst_rec t a k) (subst_rec u a k).
simple induction a; simpl in |- *; auto with ecoc coc core arith sets.
intros.
elim (lt_eq_lt_dec k n);
 [ intro a0 | intro b; auto with ecoc coc core arith sets ].
elim a0; auto with ecoc coc core arith sets.
unfold lift in |- *; auto with ecoc coc core arith sets.
Qed.

Hint Resolve Ered1_subst_l Ered1_subst_r: ecoc.

Lemma subst_rec_Ered1_r :
 forall N M M' : term,
 Ered1 M M' -> forall k : nat, Ered1 (subst_rec N M k) (subst_rec N M' k).
simple induction 1; simpl in |- *; intros; auto with ecoc.
rewrite distr_subst.
auto with ecoc.
Qed.

Lemma subst_Ered1_r :
 forall N M M' : term, Ered1 M M' -> Ered1 (subst N M) (subst N M').
unfold subst in |- *; intros; apply subst_rec_Ered1_r; trivial.
Qed.

(* church_rosser *)
Lemma str_confluence_Epar_red1 : str_confluent Epar_red1.
red in |- *; red in |- *.
simple induction 1; intros.
inversion_clear H4.
elim H1 with M'0; auto with ecoc coc core arith sets; intros.
elim H3 with N'0; auto with ecoc coc core arith sets; intros.
split with (subst x1 x0); unfold subst in |- *;
 auto with coc ecoc core arith sets.

inversion_clear H5.
elim H1 with M'1; auto with ecoc coc core arith sets; intros.
elim H3 with N'0; auto with ecoc coc core arith sets; intros.
split with (subst x1 x0); auto with ecoc coc core arith sets.
unfold subst in |- *; auto with ecoc coc core arith sets.

elim H1 with M'1; auto with ecoc coc core arith sets; intros.
elim H3 with N'0; auto with ecoc coc core arith sets; intros.
split with (subst x1 x0); auto with ecoc coc core arith sets.
unfold subst in |- *; auto with ecoc coc core arith sets.

inversion_clear H2.
elim H1 with M'0; auto with ecoc coc core arith sets; intros.
split with (Abs (Srt prop) x0); eauto with ecoc coc core arith sets; intros.

elim H1 with M'0; auto with ecoc coc core arith sets; intros.
split with (Abs (Srt prop) x0); eauto with ecoc coc core arith sets.

inversion_clear H0.
split with (Srt s); auto with ecoc coc core arith sets.

inversion_clear H0.
split with (Ref n); auto with ecoc coc core arith sets.

inversion_clear H4.
elim H1 with M'0; auto with ecoc coc core arith sets; intros.
split with (Abs (Srt prop) x0); eauto with ecoc coc core arith sets.

elim H1 with M'0; auto with ecoc coc core arith sets; intros.
elim H3 with T'0; auto with ecoc coc core arith sets; intros.
split with (Abs x1 x0); auto with ecoc coc core arith sets.

generalize H0 H1.
clear H0 H1.
inversion_clear H4.
intro.
inversion_clear H4.
intros.
elim H4 with (Abs (Srt prop) M'0); auto with coc core arith sets; intros.
elim H3 with N'0; auto with coc core arith sets; intros.
apply inv_Epar_red_abs with (Srt prop) M'1 x0; intros;
 auto with coc core arith sets.
rewrite H10 in H7; inversion_clear H7.
split with (subst x1 U'); auto with ecoc sets.
unfold subst in |- *; auto with ecoc coc core arith sets.

split with (subst x1 U'); auto with ecoc sets.
unfold subst in |- *; auto with ecoc coc core arith sets.

auto with ecoc sets.

intros.
elim H3 with N'0; auto with ecoc sets; intros.
elim H4 with (Abs T' M'0); auto with ecoc sets; intros.
apply inv_Epar_red_abs with T' M'0 x1; intros; auto with coc core arith sets.
rewrite H11 in H9; inversion_clear H9.
split with (subst x0 U'); auto with ecoc sets.
unfold subst in |- *; auto with ecoc coc core arith sets.

split with (subst x0 U'); auto with ecoc sets.
unfold subst in |- *; auto with ecoc coc core arith sets.

intros.
elim H5 with M'0; auto with ecoc sets; intros.
elim H3 with N'0; auto with ecoc sets; intros.
split with (App x0 x1); auto with ecoc sets.

inversion_clear H4.
elim H1 with M'0; auto with coc ecoc sets; intros.
elim H3 with N'0; auto with coc ecoc sets; intros.
split with (Prod x0 x1); auto with ecoc sets.
Qed.

Lemma strip_lemma_Epar_red1 : commut _ Epar_red (transp _ Epar_red1).
unfold commut, Epar_red in |- *; simple induction 1; intros.
elim str_confluence_Epar_red1 with z x0 y0;
 auto with ecoc coc core arith sets; intros.
split with x1; auto with ecoc coc core arith sets.

elim H1 with z0; auto with ecoc coc core arith sets; intros.
elim H3 with x1; intros; auto with ecoc coc core arith sets.
split with x2; auto with ecoc coc core arith sets.
apply t_trans with x1; auto with ecoc coc core arith sets.
Qed.

Lemma confluence_Epar_red : str_confluent Epar_red.
red in |- *; red in |- *.
simple induction 1; intros.
elim strip_lemma_Epar_red1 with z x0 y0; intros;
 auto with ecoc coc core arith sets.
split with x1; auto with ecoc coc core arith sets.

elim H1 with z0; intros; auto with ecoc coc core arith sets.
elim H3 with x1; intros; auto with ecoc coc core arith sets.
split with x2; auto with ecoc coc core arith sets.
red in |- *; apply t_trans with x1; auto with ecoc coc core arith sets.
Qed.

Lemma confluence_Ered : str_confluent Ered.
red in |- *; red in |- *.
intros.
elim confluence_Epar_red with x y z; auto with ecoc coc core arith sets;
 intros.
exists x0; auto with ecoc coc core arith sets.
Qed.

Theorem Econv_church_rosser :
 forall u v : term,
 Econv u v -> ex2 (fun t : term => Ered u t) (fun t : term => Ered v t).
simple induction 1; intros.
exists u; auto with ecoc coc core arith sets.

elim H1; intros.
elim confluence_Ered with x P N; auto with ecoc coc core arith sets; intros.
exists x0; auto with ecoc coc core arith sets.
apply trans_Ered_Ered with x; auto with ecoc coc core arith sets.

elim H1; intros.
exists x; auto with ecoc coc core arith sets.
apply trans_Ered_Ered with P; auto with ecoc coc core arith sets.
Qed.

(* Econv *)

Lemma one_step_Econv_exp : forall M N : term, Ered1 M N -> Econv N M.
intros.
apply Etrans_conv_exp with N; auto with ecoc coc core arith sets.
Qed.

Lemma Ered_Econv : forall M N : term, Ered M N -> Econv M N.
simple induction 1; auto with ecoc coc core arith sets.
intros; apply Etrans_conv_red with P; auto with ecoc coc core arith sets.
Qed.

Hint Resolve one_step_Econv_exp Ered_Econv: coc.

Lemma sym_Econv : forall M N : term, Econv M N -> Econv N M.
simple induction 1; auto with ecoc coc core arith sets.
simple induction 2; intros; auto with ecoc coc core arith sets.
apply Etrans_conv_red with P0; auto with ecoc coc core arith sets.

apply Etrans_conv_exp with P0; auto with ecoc coc core arith sets.

simple induction 2; intros; auto with ecoc coc core arith sets.
apply Etrans_conv_red with P0; auto with ecoc coc core arith sets.

apply Etrans_conv_exp with P0; auto with ecoc coc core arith sets.
Qed.

Hint Immediate sym_Econv: coc.

Lemma trans_Econv_Econv :
 forall M N P : term, Econv M N -> Econv N P -> Econv M P.
intros.
generalize M H; elim H0; intros; auto with ecoc coc core arith sets.
apply Etrans_conv_red with P0; auto with ecoc coc core arith sets.
apply Etrans_conv_exp with P0; auto with ecoc coc core arith sets.
Qed.

Lemma Econv_Econv_prod :
 forall a b c d : term, Econv a b -> Econv c d -> Econv (Prod a c) (Prod b d).
intros.
apply trans_Econv_Econv with (Prod a d).
elim H0; intros; auto with ecoc coc core arith sets.
apply Etrans_conv_red with (Prod a P); auto with ecoc coc core arith sets.

apply Etrans_conv_exp with (Prod a P); auto with ecoc coc core arith sets.

elim H; intros; auto with ecoc coc core arith sets.
apply Etrans_conv_red with (Prod P d); auto with ecoc coc core arith sets.

apply Etrans_conv_exp with (Prod P d); auto with ecoc coc core arith sets.
Qed.

Lemma Econv_Econv_app :
 forall a b c d : term, Econv a b -> Econv c d -> Econv (App a c) (App b d).
intros.
apply trans_Econv_Econv with (App a d).
elim H0; intros; auto with ecoc coc core arith sets.
apply Etrans_conv_red with (App a P); auto with ecoc coc core arith sets.

apply Etrans_conv_exp with (App a P); auto with ecoc coc core arith sets.

elim H; intros; auto with ecoc coc core arith sets.
apply Etrans_conv_red with (App P d); auto with ecoc coc core arith sets.

apply Etrans_conv_exp with (App P d); auto with ecoc coc core arith sets.
Qed.

Hint Resolve Econv_Econv_prod Econv_Econv_app: ecoc.

Lemma Ered_Enormal : forall u v : term, Ered u v -> Enormal u -> u = v.
simple induction 1; auto with ecoc coc core arith sets; intros.
absurd (Ered1 u N); auto with ecoc coc core arith sets.
absurd (Ered1 P N); auto with ecoc coc core arith sets.
elim (H1 H3).
unfold not in |- *; intro; apply (H3 N); auto with ecoc coc core arith sets.
Qed.

Lemma Ered_prod_prod :
 forall u v t : term,
 Ered (Prod u v) t ->
 forall P : Prop,
 (forall a b : term, t = Prod a b -> Ered u a -> Ered v b -> P) -> P.
simple induction 1; intros.
apply H0 with u v; auto with ecoc coc core arith sets.

apply H1; intros.
inversion_clear H4 in H2.
inversion H2.
apply H3 with N1 b; auto with ecoc coc core arith sets.
apply Etrans_red with a; auto with ecoc coc core arith sets.

apply H3 with a N2; auto with ecoc coc core arith sets.
apply Etrans_red with b; auto with ecoc coc core arith sets.
Qed.

Lemma Econv_sort_prod :
 forall (s : sort) (t u : term), ~ Econv (Srt s) (Prod t u).
red in |- *; intros.
elim Econv_church_rosser with (Srt s) (Prod t u);
 auto with ecoc coc core arith sets.
do 2 intro.
elim Ered_Enormal with (Srt s) x; auto with ecoc coc core arith sets.
intro.
apply Ered_prod_prod with t u (Srt s); auto with ecoc coc core arith sets;
 intros.
discriminate H2.

red in |- *; red in |- *; intros.
inversion_clear H1.
Qed.

Lemma Econv_abs : forall a b T : term, Econv a b -> Econv (Abs T a) (Abs T b).
intros.
elim H; intros; auto with ecoc coc core arith sets.
apply Etrans_conv_red with (Abs T P); auto with ecoc coc core arith sets.
apply Etrans_conv_exp with (Abs T P); auto with ecoc coc core arith sets.
Qed.

Hint Resolve Econv_abs: ecoc.

Lemma Econv_Type_abs :
 forall a b T T' : term, Econv a b -> Econv (Abs T a) (Abs T' b).
intros.
apply trans_Econv_Econv with (Abs (Srt prop) a); eauto with ecoc.
Qed.

Hint Resolve Econv_Type_abs: ecoc.

Lemma Econv_Econv_lift :
 forall (a b : term) (n k : nat),
 Econv a b -> Econv (lift_rec n a k) (lift_rec n b k).
intros.
elim H; intros; auto with ecoc coc core arith sets.
apply Etrans_conv_red with (lift_rec n P k);
 auto with ecoc coc core arith sets.

apply Etrans_conv_exp with (lift_rec n P k);
 auto with ecoc coc core arith sets.
Qed.

Lemma Econv_Econv_subst :
 forall (a b c d : term) (k : nat),
 Econv a b -> Econv c d -> Econv (subst_rec a c k) (subst_rec b d k).
intros.
apply trans_Econv_Econv with (subst_rec a d k).
elim H0; intros; auto with ecoc coc core arith sets.
apply Etrans_conv_red with (subst_rec a P k);
 auto with ecoc coc core arith sets.

apply Etrans_conv_exp with (subst_rec a P k);
 auto with ecoc coc core arith sets.

elim H; intros; auto with ecoc coc core arith sets.
apply trans_Econv_Econv with (subst_rec P d k);
 auto with ecoc coc core arith sets.

apply trans_Econv_Econv with (subst_rec P d k);
 auto with ecoc coc core arith sets.
apply sym_Econv; auto with ecoc coc core arith sets.
Qed.

Lemma inv_Econv_prod_l :
 forall a b c d : term, Econv (Prod a c) (Prod b d) -> Econv a b.
intros.
elim Econv_church_rosser with (Prod a c) (Prod b d); intros;
 auto with ecoc coc core arith sets.
apply Ered_prod_prod with a c x; intros; auto with ecoc coc core arith sets.
apply Ered_prod_prod with b d x; intros; auto with ecoc coc core arith sets.
apply trans_Econv_Econv with a0; auto with ecoc coc core arith sets.
apply sym_Econv.
generalize H2.
rewrite H5; intro.
injection H8.
simple induction 2; auto with ecoc coc core arith sets.
Qed.

Lemma inv_Econv_prod_r :
 forall a b c d : term, Econv (Prod a c) (Prod b d) -> Econv c d.
intros.
elim Econv_church_rosser with (Prod a c) (Prod b d); intros;
 auto with ecoc coc core arith sets.
apply Ered_prod_prod with a c x; intros; auto with ecoc coc core arith sets.
apply Ered_prod_prod with b d x; intros; auto with ecoc coc core arith sets.
apply trans_Econv_Econv with b0; auto with ecoc coc core arith sets.
apply sym_Econv.
generalize H2.
rewrite H5; intro.
injection H8.
simple induction 1; auto with ecoc coc core arith sets.
Qed.

Hint Resolve sym_Econv trans_Econv_Econv Econv_Econv_prod Econv_Econv_lift
  Econv_Econv_subst: ecoc.

Lemma Ered1_Ered_ind :
 forall (N : term) (P : term -> Prop),
 P N ->
 (forall M R : term, Ered1 M R -> Ered R N -> P R -> P M) ->
 forall M : term, Ered M N -> P M.
cut
 (forall M N : term,
  Ered M N ->
  forall P : term -> Prop,
  P N -> (forall M R : term, Ered1 M R -> Ered R N -> P R -> P M) -> P M).
intros.
apply (H M N); auto with ecoc coc core arith sets.

simple induction 1; intros; auto with ecoc coc core arith sets.
apply H1; auto with ecoc coc core arith sets.
apply H4 with N0; auto with ecoc coc core arith sets.

intros.
apply H4 with R; auto with ecoc coc core arith sets.
apply Etrans_red with P; auto with ecoc coc core arith sets.
Qed.

Lemma inv_Ered_Abs :
 forall T U x : term,
 Ered (Abs T U) x -> exists T' : term, (exists U' : term, x = Abs T' U').
simple induction 1.
split with T; split with U; trivial.
intros P N H0 (T', (U', H1)) H2.
rewrite H1 in H2.
inversion H2.
split with (Srt prop); split with U'; trivial.
split with M'; split with U'; trivial.
split with T'; split with M'; trivial.
Qed.

Lemma not_Ered_Abs_sort :
 forall (T M : term) (s : sort), ~ Ered (Abs T M) (Srt s).
unfold not in |- *; intros.
inversion H.
generalize (inv_Ered_Abs T M P H0).
intros (T', (U', H3)).
rewrite H3 in H1; inversion H1.
Qed.

Lemma Ered1_sort_mem :
 forall (t : term) (s : sort), Ered1 t (Srt s) -> mem_sort s t.
intros.
inversion H.
elim mem_sort_subst with M N 0 s; intros; auto with coc core arith sets.
unfold subst in H2; rewrite H2.
auto with coc.
Qed.

Inductive mem_sort2 (s : sort) : term -> Prop :=
  | mem_eq2 : mem_sort2 s (Srt s)
  | mem_prod_l2 : forall u v : term, mem_sort2 s u -> mem_sort2 s (Prod u v)
  | mem_prod_r2 : forall u v : term, mem_sort2 s v -> mem_sort2 s (Prod u v)
  | mem_abs_r2 : forall u v : term, mem_sort2 s v -> mem_sort2 s (Abs u v)
  | mem_app_l2 : forall u v : term, mem_sort2 s u -> mem_sort2 s (App u v)
  | mem_app_r2 : forall u v : term, mem_sort2 s v -> mem_sort2 s (App u v).

Hint Resolve mem_eq2 mem_prod_l2 mem_prod_r2 mem_abs_r2 mem_app_l2
  mem_app_r2: ecoc.

Lemma mem_sort2_lift :
 forall (t : term) (n k : nat) (s : sort),
 mem_sort2 s (lift_rec n t k) -> mem_sort2 s t.
simple induction t; simpl in |- *; intros; auto with ecoc coc core arith sets.
generalize H; elim (le_gt_dec k n); intros;
 auto with ecoc coc core arith sets.
inversion_clear H0.

inversion_clear H1.
apply mem_abs_r2; apply H0 with n (S k); auto with ecoc coc core arith sets.

inversion_clear H1.
apply mem_app_l2; apply H with n k; auto with ecoc coc core arith sets.

apply mem_app_r2; apply H0 with n k; auto with ecoc coc core arith sets.

inversion_clear H1.
apply mem_prod_l2; apply H with n k; auto with ecoc coc core arith sets.

apply mem_prod_r2; apply H0 with n (S k); auto with ecoc coc core arith sets.
Qed.

Lemma mem_sort2_subst :
 forall (b a : term) (n : nat) (s : sort),
 mem_sort2 s (subst_rec a b n) -> mem_sort2 s a \/ mem_sort2 s b.
simple induction b; simpl in |- *; intros; auto with ecoc coc core arith sets.
generalize H; elim (lt_eq_lt_dec n0 n); [ intro a0 | intro b0 ].
elim a0; intros.
inversion_clear H0.

left.
apply mem_sort2_lift with n0 0; auto with ecoc coc core arith sets.

intros.
inversion_clear H0.

inversion_clear H1.
elim H0 with a (S n) s; auto with ecoc coc core arith sets.

inversion_clear H1.
elim H with a n s; auto with ecoc coc core arith sets.

elim H0 with a n s; auto with ecoc coc core arith sets.

inversion_clear H1.
elim H with a n s; auto with ecoc coc core arith sets.

elim H0 with a (S n) s; intros; auto with ecoc coc core arith sets.
Qed.

Lemma Ered_sort_mem2 :
 forall (t : term) (s : sort), Ered t (Srt s) -> mem_sort2 s t.
intros.
pattern t in |- *.
apply Ered1_Ered_ind with (Srt s); auto with ecoc coc core arith sets.
do 4 intro.
elim H0; intros.
elim mem_sort2_subst with M0 N 0 s; intros;
 auto with ecoc coc core arith sets.

inversion H2; auto with ecoc.

inversion H4; auto with ecoc.

inversion H4; auto with ecoc.

inversion H4; auto with ecoc.

inversion H4; auto with ecoc.

inversion H4; auto with ecoc.

inversion H4; auto with ecoc.
Qed.

Lemma mem_sort2_mem_sort :
 forall (t : term) (s : sort), mem_sort2 s t -> mem_sort s t.
simple induction 1; auto with coc.
Qed.

Lemma Ered_sort_mem :
 forall (t : term) (s : sort), Ered t (Srt s) -> mem_sort s t.
intros; apply mem_sort2_mem_sort; apply Ered_sort_mem2; trivial.
Qed.


Require Import Toy.Imp.
Require Import Toy.Language_noderef.
Require Import Toy.Embeddings_noderef.
Require Import Toy.UnifySL.implementation.

Module BasicRulesSound.
Import Validity Assertion_Shallow Denote_Aexp Denote_Bexp Denote_Com.
Import tacticforOSA T.

Theorem hoare_skip_sound : forall P, valid P CSkip P falsep falsep.
Proof.
  unfold valid.
  intros P st1 st2 HP.
  split; try split; try split.
  + unfold not; simpl; tauto.
  + intros Hc. simpl in Hc; subst; tauto.
  + intros Hc. simpl in Hc; tauto.
  + intros Hc. simpl in Hc; tauto.
Qed.

Theorem hoare_break_sound : forall P, valid P CBreak falsep P falsep.
Proof.
  unfold valid.
  intros P st1 st2 HP.
  split; try split; try split.
  + unfold not; simpl; tauto.
  + intros Hc. simpl in Hc; tauto.
  + intros Hc. simpl in Hc; subst; tauto.
  + intros Hc. simpl in Hc; tauto.
Qed.

Theorem hoare_cont_sound : forall P, valid P CCont falsep falsep P.
Proof.
  intros P st1 st2 HP.
  split; try split; try split.
  + unfold not; simpl; tauto.
  + intros Hc. simpl in Hc; tauto.
  + intros Hc. simpl in Hc; tauto.
  + intros Hc. simpl in Hc; subst; tauto.
Qed.

Theorem hoare_seq_sound : forall P Q R Rb Rc c1 c2,
  valid P c1 Q Rb Rc ->
  valid Q c2 R Rb Rc ->
  valid P (CSeq c1 c2) R Rb Rc.
Proof.
  unfold valid.
  intros P Q R Rb Rc c1 c2 Hc1 Hc2.
  intros st1 st2 HP.
  split; try split; try split.
  + unfold not; intros.
    simpl in H; destruct H.
    - specialize (Hc1 st1 st2); tauto.
    - destruct H as [st3 [? ?]].
      specialize (Hc1 st1 st3 HP).
      destruct Hc1 as [? [? [? ?]]].
      specialize (H2 H).
      specialize (Hc2 st3 st2); tauto.
  + intros Hc.
    simpl in Hc. destruct Hc as [st3 [? ?]].
    specialize (Hc1 st1 st3 HP).
    destruct Hc1 as [? [? [? ?]]].
    specialize (H2 H).
    specialize (Hc2 st3 st2 H2); tauto.
  + intros Hc.
    simpl in Hc. destruct Hc as [? | [st3 [? ?]]].
    - specialize (Hc1 st1 st2); tauto.
    - specialize (Hc1 st1 st3 HP).
      specialize (Hc2 st3 st2). tauto.
  + intros Hc.
    simpl in Hc. destruct Hc as [? | [st3 [? ?]]].
    - specialize (Hc1 st1 st2); tauto.
    - specialize (Hc1 st1 st3 HP).
      specialize (Hc2 st3 st2). tauto.
Qed.

Lemma true_false_contradiction : forall b s,
  true_set (beval b) s ->
  false_set (beval b) s ->
  False.
Proof.
  induction b; intros.
  + inversion H0.
  + inversion H.
  + simpl in *.
    destruct (aeval a1 s), (aeval a2 s); tauto.
  + simpl in *.
    destruct (aeval a1 s), (aeval a2 s); tauto.
  + simpl in *.
    specialize (IHb s); tauto.
  + simpl in *.
    unfold Sets.intersect, Sets.union in *.
    specialize (IHb1 s); specialize (IHb2 s); tauto.
Qed.

Theorem hoare_if_sound : forall P Q Rb Rc b c1 c2,
  valid (andp P (inj b)) c1 Q Rb Rc ->
  valid (andp P (negp (inj b))) c2 Q Rb Rc ->
  valid (andp P (safeb b)) (CIf b c1 c2) Q Rb Rc.
Proof.
  unfold valid.
  intros P Q Rb Rc b c1 c2 HT HF.
  intros st1 st2 ?.
  unfold andp, safeb in H.
  destruct H as [HP HSafe].
  split; try split; try split.
  + unfold not; intros.
    simpl in H. destruct H as [? | [? | ?]].
    - tauto.
    - assert (andp P (inj b) st1).
      { unfold andp, inj. tauto. }
      specialize (HT st1 st2 H0); tauto.
    - assert (andp P (negp (inj b)) st1).
      { unfold andp, negp, inj.
        split; try tauto.
        unfold not; intros.
        eapply (true_false_contradiction b (fst st1)); tauto. }
      specialize (HF st1 st2 H0); tauto.
  + intros Hc.
    simpl in Hc.
    destruct Hc as [[Hc1 Hc2] | [Hc1 Hc2]].
    - assert (andp P (inj b) st1).
      { unfold andp, inj. tauto. }
      specialize (HT st1 st2). tauto.
    - assert (andp P (negp (inj b)) st1).
      { unfold andp, negp, inj.
        split; try tauto.
        unfold not; intros.
        eapply (true_false_contradiction b (fst st1)); tauto. }
      specialize (HF st1 st2); tauto.
  + intros Hc.
    simpl in Hc.
    destruct Hc as [[Hc1 Hc2] | [Hc1 Hc2]].
    - assert (andp P (inj b) st1).
      { unfold andp, inj. tauto. }
      specialize (HT st1 st2). tauto.
    - assert (andp P (negp (inj b)) st1).
      { unfold andp, negp, inj.
        split; try tauto.
        unfold not; intros.
        eapply (true_false_contradiction b (fst st1)); tauto. }
      specialize (HF st1 st2); tauto.
  + intros Hc.
    simpl in Hc.
    destruct Hc as [[Hc1 Hc2] | [Hc1 Hc2]].
    - assert (andp P (inj b) st1).
      { unfold andp, inj. tauto. }
      specialize (HT st1 st2). tauto.
    - assert (andp P (negp (inj b)) st1).
      { unfold andp, negp, inj.
        split; try tauto.
        unfold not; intros.
        eapply (true_false_contradiction b (fst st1)); tauto. }
      specialize (HF st1 st2); tauto.
Qed.

Theorem hoare_for_sound : forall P P' Q c ci,
  valid P c P' Q P' ->
  valid P' ci P falsep falsep ->
  valid P (CFor c ci) Q falsep falsep.
Proof.
  intros P P' Q c ci Hlb Hinc.
  unfold valid in *.
  intros st1 st2 HP.
  split; try split; try split.
  + unfold not; intros.
    simpl in H; destruct H as [n ?].
    revert st1 HP H; induction n.
    - intros st1 HP H.
      simpl in H. destruct H.
      * specialize (Hlb st1 st2); tauto.
      * destruct H as [st' ?].
        specialize (Hlb st1 st'); specialize (Hinc st' st2); tauto.
    - intros st1 HP H.
      simpl in H.
      destruct H as [st3 [[? | ?] ?]].
      * destruct H as [st4 [? ?]].
        specialize (Hlb st1 st4); specialize (Hinc st4 st3).
        specialize (IHn st3); tauto.
      * destruct H as [st4 [? ?]].
        specialize (Hlb st1 st4); specialize (Hinc st4 st3).
        specialize (IHn st3); tauto.
  + intros Hc.
    simpl in Hc; destruct Hc as [n Hc].
    revert st1 HP Hc; induction n.
    - intros st1 HP H.
      simpl in H; destruct H as [? | [st3 ?]].
      * specialize (Hlb st1 st2); tauto.
      * specialize (Hlb st1 st3); specialize (Hinc st3 st2); tauto.
    - intros st1 HP H.
      simpl in H; destruct H as [st3 [[[st4 [? ?]] | [st4 [? ?]]] ?]].
      * specialize (Hlb st1 st4); specialize (Hinc st4 st3).
        specialize (IHn st3); tauto.
      * specialize (Hlb st1 st4); specialize (Hinc st4 st3).
        specialize (IHn st3); tauto.
  + simpl; tauto.
  + simpl; tauto.
Qed.

Theorem hoare_consequence_sound : forall P P' Q Q' Rb Rb' Rc Rc' c,
  derives P P' ->
  valid P' c Q' Rb' Rc' ->
  derives Q' Q ->
  derives Rb' Rb ->
  derives Rc' Rc ->
  valid P c Q Rb Rc.
Proof.
  intros P P' Q Q' Rb Rb' Rc Rc' c HP Hc HQ HRb HRc.
  unfold valid in *.
  intros.
  specialize (Hc st1 st2).
  unfold derives in *.
  specialize (HP st1); specialize (HQ st2).
  specialize (HRb st2); specialize (HRc st2).
  tauto.
Qed.

Theorem hoare_set_sound : forall P X e v,
  derives P (eqp e v) ->
  valid (andp P (safea e)) (CAss_set X e) (andp (eqp (AId X) v) (exp (subst_set P X))) falsep falsep.
Proof.
  unfold valid. intros.
  unfold derives, eqp in H.
  unfold andp, safea in H0.
  destruct H0 as [? ?].
  specialize (H st1 H0).
  split.
  { unfold not; simpl; tauto. }
  split.
  { intros.
    unfold andp, eqp, exp, subst_set.
    simpl in H2. destruct H2. split.
    + simpl. rewrite <-H. tauto.
    + exists ((fst st1) X).
      remember (store_update (fst st2) X (Some (fst st1 X))) as s'.
      assert (forall X, s' X = (fst st1) X).
      { destruct H3. intros Y.
        unfold store_update in Heqs'.
        subst s'.
        destruct (Nat.eq_dec Y X).
        - rewrite e0. tauto.
        - specialize (H3 Y). specialize (H3 n). rewrite H3. tauto. }
      assert (store_update (fst st2) X (Some (fst st1 X)) = fst st1).
      { eapply FunctionalExtensionality.functional_extensionality_dep.
        subst. tauto. }
      subst.
      destruct H3.
      assert (st1 = (store_update (fst st2) X (Some (fst st1 X)), snd st2)).
      { destruct st1. unfold snd at 1 in H6. rewrite <- H6.
        unfold fst at 3 in H5. rewrite H5. tauto. }
      rewrite H7 in H0. tauto. }
  split; simpl; tauto.
Qed.

Theorem hoare_load_sound : forall P X e p v,
  derives P (andp (eqp e p) (mapsto p v)) ->
  valid P (CAss_load X e) (andp (eqp (AId X) v) (exp (subst_load P X))) falsep falsep.
Proof.
  unfold valid; intros.
  unfold derives, andp, eqp, mapsto in H.
  specialize (H st1 H0).
  destruct H as [? [? ?]].
  split.
  { unfold not; intros.
    simpl in H3.
    rewrite H, H1 in H3.  inversion H3. }
  split.
  { intros.
    unfold andp, eqp, exp; simpl.
    split.
    + simpl in H3.
      rewrite H in H3.
      destruct H3 as [? [? ?]].
      rewrite H3; tauto.
    + simpl in H3.
      rewrite H in H3.
      destruct H3 as [? [? ?]].
      exists ((fst st1) X).
      unfold subst_load.
      remember (store_update (fst st2) X (Some (fst st1 X))) as s'.
      assert (forall Y, s' Y = fst st1 Y).
      { intros. subst s'; unfold store_update.
        destruct (Nat.eq_dec Y X).
        + rewrite e0; tauto.
        + specialize (H4 Y n); tauto. }
      assert (s' = fst st1).
      { eapply FunctionalExtensionality.functional_extensionality_dep. tauto. }
      rewrite H7, <-H5.
      destruct st1.
      unfold fst, snd; tauto. }
  split; simpl; tauto.
Qed.

Theorem hoare_store_sound : forall P e1 e2 p v,
  derives P (andp (eqp e1 p) (eqp e2 v)) ->
  valid (sepcon P (mapsto_ p)) (CAss_store e1 e2) (sepcon P (mapsto p v)) falsep falsep.
Proof.
  unfold valid; intros.
  unfold derives, andp, eqp in H.
  UFsepcon.
  split.
  { unfold not; intros.
    destruct H0 as [st11 [st12 [? [? ?]]]].
    UFjoin. destruct H0 as [[? ?] ?].
    specialize (H st11 H2); destruct H.
    rewrite H0 in H, H6.
    simpl in H1. rewrite H, H6 in H1.
    unfold mapsto_ in H3.
    destruct H3 as [[v0 ?] ?].
    UFheapjoin. rewrite osajoin in H5.
    specialize (H5 p); destruct H5 as [? | [? | ?]].
    + destruct H5 as [? [? [? ?]]]. rewrite H9 in H1. inversion H1.
    + destruct H5 as [? [? [? ?]]]. rewrite H9 in H1. inversion H1.
    + destruct H5 as [? [? ?]]. rewrite H8 in H3. inversion H3. }
  split.
  { intros.
    destruct H0 as [st11 [st12 [? [? ?]]]].
    UFjoin. destruct H0 as [[? ?] ?].
    specialize (H st11 H2); destruct H.
    rewrite H0 in H, H6.
    simpl in H1. rewrite H, H6 in H1.
    destruct H1 as [? [? [? ?]]].
    exists st11, (fst st12, heap_update (snd st12) p (Some v)).
    split; split.
    + split; [rewrite H0; tauto |].
      unfold fst at 1. rewrite H4; tauto.
    + UFheapjoin. rewrite osajoin in *.
      remember (fst st12, heap_update (snd st12) p (Some v)) as st22.
      intros p0. specialize (H5 p0).
      destruct H5 as [? | [? | ?]].
      - destruct H5 as [v0 [? [? ?]]].
        left. exists v0. subst st22.
        unfold heap_update. unfold snd at 2.
        split; try tauto. split.
        * destruct (Z.eq_dec p p0).
          { unfold mapsto_ in H3.
            subst p0. destruct H3. destruct H3 as [v00 ?].
            rewrite H3 in H10. inversion H10. }
          tauto.
        * destruct (Z.eq_dec p p0).
          { unfold mapsto_ in H3.
            destruct H3. destruct H3 as [v00 ?].
            subst p. rewrite H3 in H10. inversion H10. }
          specialize (H8 p0 n). rewrite H8. tauto.
      - right. left.
        destruct H5 as [v0 [? [? ?]]].
        destruct (Z.eq_dec p p0).
        * exists v. subst p0.
          split; try tauto.
          split; try tauto.
          subst st22. unfold snd at 1. unfold heap_update.
          destruct (Z.eq_dec p p); try tauto.
        * exists v0. split; try split; try tauto.
          { subst st22. unfold snd at 1. unfold heap_update.
            destruct (Z.eq_dec p p0); try tauto. }
          specialize (H8 p0 n). rewrite H8. tauto.
      - right. right.
        split; try split; try tauto.
        * subst st22. unfold snd at 1. unfold heap_update.
          destruct (Z.eq_dec p p0).
          { subst p0. destruct H5 as [? [? ?]].
            rewrite H11 in H1; tauto. }
          unfold mapsto_ in H3.
          destruct H3. destruct H3.
          destruct H5 as [? [? ?]]. tauto.
        * destruct (Z.eq_dec p p0).
          { subst p0. unfold mapsto_ in H3.
            destruct H3 as [[v0 ?] ?].
            destruct H5 as [? [? ?]].
            rewrite H3 in H11. inversion H11. }
          specialize (H8 p0 n).
          rewrite H8. tauto.
    + tauto.
    + unfold mapsto. split.
      - unfold snd at 1.
        unfold heap_update.
        destruct (Z.eq_dec p p); try tauto.
      - intros p0 ?.
        unfold snd at 1. unfold heap_update.
        destruct (Z.eq_dec p p0); try tauto.
        unfold mapsto_ in H3.
        destruct H3.
        specialize (H11 p0 n). tauto. }
  split; simpl; tauto.
Qed.

(* Proof.
  unfold valid; intros.
  unfold derives, andp, eqp in H.
  unfold andp, sepcon, mapsto_ in H0.
  destruct H0 as [st11 [st12 [? [? [? ?]]]]].
  split.
  { unfold not; intros.
    unfold join in H0.
    destruct H0 as [? [? ?]].
    specialize (H st11 H1).
    destruct H.
    rewrite H0, H5 in H.
    rewrite H0, H5 in H7.
    simpl in H4.
    rewrite H, H7 in H4.
    destruct H2 as [v0 ?].
    unfold join_heap in H6.
    specialize (H6 p).
    destruct H6 as [? | [? | ?]].
    + destruct H6 as [? [? [? ?]]]. rewrite H9 in H4; inversion H4.
    + destruct H6 as [? [? [? ?]]]. rewrite H9 in H4; inversion H4.
    + destruct H6 as [? [? ?]].
      rewrite H8 in H2; inversion H2. }
  split.
  { intros.
    specialize (H st11 H1).
    destruct H.
    unfold join in H0.
    destruct H0 as [? [? ?]].
    rewrite H0, H6 in H.
    rewrite H0, H6 in H5.
    simpl in H4.
    rewrite H, H5 in H4.
    destruct H4 as [? [? [? ?]]].
    unfold sepcon, mapsto.
    remember (fst st12, (heap_update (snd st12) p (Some v))) as st22.
    exists st11, st22.
    split.
    { unfold join.
      split; try split.
      + subst st22. unfold fst at 2. tauto.
      + subst st22. unfold fst at 1.
        rewrite H6; tauto.
      + unfold join_heap in *.
        intros; specialize (H7 p0).
        destruct H7 as [? | [? | ?]].
        - left.
          subst st22; unfold heap_update.
          unfold snd at 2.
          destruct H7 as [v0 [? [? ?]]].
          destruct (Z.eq_dec p p0).
          { subst p0. destruct H2 as [v1 ?]. rewrite H2 in H11. inversion H11. }
          exists v0.
          split; try split; try tauto.
          specialize (H9 p0 n).
          rewrite H9. tauto.
        - right. left.
          destruct H7 as [v0 [? [? ?]]].
          subst st22; unfold heap_update.
          unfold snd at 2.
          destruct (Z.eq_dec p p0).
          * exists v; subst p0.
            split; try split; try tauto.
          * exists v0.
            specialize (H9 p0 n).
            rewrite H9; tauto.
        - right. right.
          subst st22; unfold heap_update.
          unfold snd at 2.
          destruct (Z.eq_dec p p0).
          { subst p0. tauto. }
          specialize (H9 p0 n).
          rewrite H9; tauto. }
      split; try tauto.
      split.
      { subst st22; unfold heap_update.
        unfold snd at 1.
        destruct (Z.eq_dec); try tauto. }
      intros.
      specialize (H3 p' H11).
      subst st22; unfold heap_update.
      unfold snd at 1.
      destruct (Z.eq_dec p p'); try tauto. }
  split; simpl; tauto.
Qed. *)

End BasicRulesSound.