Require Import Cryptol.Semantics.
Require Import Cryptol.Eager.
Require Import Cryptol.EagerEvalInd.
Require Import List.
Require Import Cryptol.AST.
Require Import Cryptol.Lib.

(* The two different eval_type relations should be merged *)
Lemma eager_to_strict_lazy_type :
  forall t tv ge TE,
    eager_eval_type ge TE t tv ->
    eval_type ge TE t tv.
Proof.
  induction 1 using eager_eval_type_ind_useful; intros;
    econstructor; eauto.
Qed.

Lemma Forall2_strict_eval_inv :
  forall ge TE E l vs,
    Forall2 (strict_eval_expr ge TE E) l vs ->
    exists lv,
      Forall2 (eval_expr ge TE E) l lv /\
      Forall2 (strict_eval_val ge) lv vs.
Proof.
  induction 1; intros.
  exists nil. split; eauto.
  destruct IHForall2. inversion H.
  destruct H1. subst.
  eexists; split; econstructor; eauto.
Qed.

Lemma nth_error_Forall2 :
  forall {A B : Type} l R l',
    Forall2 R l' l ->
    forall n (v : A),
      nth_error l n = Some v ->
      exists (v' : B),
        nth_error l' n = Some v' /\ R v' v.
Proof.
  induction 1; intros.
  destruct n; simpl in H; congruence.
  destruct n; simpl in H1. inversion H1. subst.
  exists x. split; eauto.
  eapply IHForall2 in H1.
  destruct H1. exists x0.
  destruct H1.
  split; simpl; auto.
Qed.

Lemma map_fst_combine :
  forall {A B : Type} (l : list A) (l' : list B),
    length l = length l' ->
    map fst (combine l l') = l.
Proof.
  induction l; intros; destruct l'; simpl in *; try congruence.
  f_equal. eauto.
Qed.

Lemma map_snd_combine :
  forall {A B : Type} (l : list A) (l' : list B),
    length l = length l' ->
    map snd (combine l l') = l'.
Proof.
  induction l; intros; destruct l'; simpl in *; try congruence.
  f_equal. eauto.
Qed.

Lemma Forall2_length :
  forall {A B} (P : A -> B -> Prop) l l',
    Forall2 P l l' ->
    length l = length l'.
Proof.
  induction 1; intros; simpl; eauto.
Qed.

Lemma lookup_Forall2_back :
  forall {A B : Type} (X : list A) (Y : list B) (P : A -> B -> Prop),
    Forall2 P X Y ->
    forall str strs v',
      lookup str (combine strs Y) = Some v' ->
      exists v,
        lookup str (combine strs X) = Some v /\ P v v'.
Proof.
  induction 1; intros;
    destruct strs; try solve [simpl in *; congruence].
  simpl in H1.
  destruct (String.string_dec str s) eqn:?.
  inversion H1. subst. eexists. simpl.
  rewrite Heqs0. eauto.
  simpl. rewrite Heqs0.
  eapply IHForall2 in H1; eauto.
Qed.

Lemma combine_map_fst_map_snd :
  forall {A B : Type} (l : list (A * B)),
    combine (map fst l) (map snd l) = l.
Proof.
  induction l; intros; simpl; eauto.
  destruct a; simpl; f_equal; eauto.
Qed.

Lemma strict_eval_list :
  forall ge x vs,
    Forall2 (strict_eval_val ge) x vs ->
    strict_eval_val ge (Values.thunk_list x) (strict_list vs).
Proof.
  induction 1; intros.
  econstructor; eauto.

  simpl. econstructor; eauto.
  econstructor. simpl. reflexivity.
Qed.

Lemma fst_to_val_list_pair :
  forall f,
    map fst (to_val_list_pair f) = map fst (to_sval_list_pair f).
Proof.
  induction f; intros; simpl; auto.
  destruct a. simpl. f_equal. eauto.
Qed.

Lemma strict_eval_list_pair :
  forall ge f,
    Forall (fun e => strict_eval_val ge (to_val e) (to_sval e)) (map snd f) ->
    Forall2 (strict_eval_val ge) (map snd (to_val_list_pair f)) (map snd (to_sval_list_pair f)).
Proof.
  induction f; intros. simpl in *. econstructor.
  simpl in H. inversion H. subst.
  eapply IHf in H3.
  simpl. destruct a. simpl. econstructor; eauto.
Qed.

Lemma strict_eval_ext_val :
  forall ge e,
    strict_eval_val ge (to_val e) (to_sval e).
Proof.
  induction e using ext_val_ind_mut; intros.
  * simpl. econstructor; eauto.
  * simpl. eapply strict_eval_list.
    induction H; econstructor; eauto.
  * simpl. econstructor.
    induction H; econstructor; eauto.
  * induction f. simpl in *. econstructor; eauto. simpl. econstructor.
    destruct a. simpl. fold to_val_list_pair. fold to_sval_list_pair.
    simpl in H. inversion H.
    subst. econstructor. simpl. econstructor. eauto.
    instantiate (1 := map snd (to_sval_list_pair f)).
    eapply strict_eval_list_pair; eauto.
    simpl. f_equal.
    rewrite fst_to_val_list_pair.
    rewrite combine_map_fst_map_snd.
    reflexivity.
Qed.

Lemma eager_to_strict_lazy :
  forall exp ge TE SE sv,
    eager_eval_expr ge TE SE exp sv ->
    forall E,
      match_env ge E SE ->
      strict_eval_expr ge TE E exp sv.
Proof.
  (* TODO *)
  remember (fun ge TE SE llm llidv =>
              eager_par_match ge TE SE llm llidv ->
              forall E,
                match_env ge E SE ->
                exists E',
                  par_match ge TE E 0 llm E') as Ppm.
  (* TODO *)
  remember (fun ge TE SE lm llidv =>
              eager_index_match ge TE SE lm llidv ->
              forall E,
                match_env ge E SE ->
                True) as Pm.

  induction 1 using eager_eval_expr_ind_useful with (Pm := Pm) (Ppm := Ppm); intros.

  * assert (Forall2 (strict_eval_expr ge TE E0) l vs). {
      eapply Forall2_implies_1. eapply H0. simpl. eauto.
    } idtac.
    eapply Forall2_strict_eval_inv in H2. destruct H2.
    destruct H2.
    econstructor; econstructor; eauto.

  * eapply IHeager_eval_expr in H1.
    inversion H1. subst.
    inversion H3. subst.
    eapply nth_error_Forall2 in H0; eauto. destruct H0.
    destruct H0.

    econstructor; [econstructor | eassumption]; eassumption.
  * assert (Forall2 (strict_eval_expr ge TE E0) (map snd l) vs).
    eapply Forall2_implies_1. eapply H0. simpl. eauto.
    eapply Forall2_strict_eval_inv in H2.
    destruct H2.
    destruct H2.
    econstructor. econstructor; eauto.
    econstructor.
    rewrite map_snd_combine. eauto.
    rewrite map_length.
    eapply Forall2_length in H2.
    rewrite map_length in *.
    eassumption.

    rewrite map_fst_combine. eauto.
    rewrite map_length.
    eapply Forall2_length in H2.
    rewrite map_length in *.
    eassumption.

  * eapply IHeager_eval_expr in H1. inversion H1.
    subst. inversion H3. subst.

    eapply lookup_Forall2_back in H0; eauto.

    destruct H0. destruct H0.
    rewrite combine_map_fst_map_snd in H0.

    econstructor. econstructor; eauto.
    assumption.

  * assert (match_env (bind_decl_groups decls ge) (erase_decl_groups decls E0) (erase_decl_groups decls E)).
    admit.
    (* This case could be our downfall *)
    eapply IHeager_eval_expr in H1.
    inversion H1.
    subst.
    econstructor. econstructor; eauto.
    (* Here we run into the unfortunate reality that Where uses the global environment *)
    (* making the ge not static *)
    admit.

  * specialize (IHeager_eval_expr1 _ H1).
    specialize (IHeager_eval_expr2 _ H1).
    inversion IHeager_eval_expr1.
    inversion IHeager_eval_expr2.
    inversion H3.
    subst.

    econstructor; eauto. econstructor; eauto.
  * unfold match_env in *.
    specialize (H0 id). rewrite H in H0. inversion H0.
    econstructor.
    econstructor; eauto.
    eauto.
  * specialize (IHeager_eval_expr _ H2). inversion IHeager_eval_expr. subst.
    unfold match_env in *.
    specialize (H2 id). rewrite H in H2. inversion H2.

    econstructor.
    eapply eval_global_var; eauto.
    eauto.

  * econstructor. econstructor; eauto. econstructor; eauto.
  * econstructor. econstructor; eauto. econstructor; eauto.
  * specialize (IHeager_eval_expr1 _ H2).
    specialize (IHeager_eval_expr2 _ H2).
    inversion IHeager_eval_expr1.
    inversion IHeager_eval_expr2.
    subst.
    inversion H4. subst.
    assert (match_env ge (extend E1 id v1) (extend E' id av)) by admit.
    specialize (IHeager_eval_expr3 _ H5).
    inversion IHeager_eval_expr3.
    econstructor. econstructor; eauto.
    eauto.
  * specialize (IHeager_eval_expr1 _ H2).
    inversion IHeager_eval_expr1. subst.
    inversion H4. subst.
    assert (match_env ge E1 E') by admit.
    specialize (IHeager_eval_expr2 _ H5).
    inversion IHeager_eval_expr2.
    subst.

    econstructor; eauto.
    econstructor; eauto.
    eapply eager_to_strict_lazy_type; eauto.

  * econstructor. econstructor; eauto.
    subst.
    eapply strict_eval_ext_val.

  *
    assert (Forall2 (strict_eval_expr ge TE E0) l vs).
    eapply Forall2_implies_1. eapply H0. simpl. eauto.
    eapply Forall2_strict_eval_inv in H3.
    destruct H3. destruct H3.
    econstructor.
    econstructor; eauto.
    subst v.
    eapply strict_eval_list; eauto.
  *
    subst Ppm.
    subst v.
    specialize (IHeager_eval_expr H _ H3).
    destruct IHeager_eval_expr.
    econstructor.

    econstructor.
    econstructor; eauto.

    (* What's the strategy here? *)
    (* Essentially we know that *)
    admit. admit.

  * admit. (* builtins aren't even close to matching at the moment *)

  * admit. (* dummy prop *)
  * admit. (* dummy prop *)
  * admit. (* dummy prop *)
  * admit. (* dummy prop *)

Admitted.


Require Export BoilerplateSemantics.
Set Implicit Arguments.

(******************************************************************************)
(* Weakening lemmas                                                           *)
(******************************************************************************)

Lemma shift_value {t} :
  ∀ {c}, Value t → Value (shiftTm c t).
Proof.
  induction t; simpl; intros; try contradiction; destruct_conjs; auto.
Qed.

Lemma tshift_value {t} :
  ∀ {c}, Value t → Value (tshiftTm c t).
Proof.
  induction t; simpl; intros; try contradiction; destruct_conjs; auto.
Qed.

Lemma weaken_value u :
  ∀ {t}, Value t → Value (weakenTm t u).
Proof.
  induction u; simpl; eauto using shift_value, tshift_value.
Qed.

(******************************************************************************)
(* Progress                                                                   *)
(******************************************************************************)

Lemma can_form_tarr {Γ t T1 T2} (v: Value t) (wt: Typing Γ t (tarr T1 T2)) :
  ∃ t2, t = abs T1 t2.
Proof.
  depind wt; try contradiction; exists t; reflexivity.
Qed.

Lemma can_form_tall {Γ t T} (v: Value t) (wt: Typing Γ t (tall T)) :
  ∃ t1, t = tabs t1.
Proof.
  depind wt; try contradiction; exists t; reflexivity.
Qed.

Lemma can_form_tprod {Γ t T1 T2} (v: Value t) (wt: Typing Γ t (tprod T1 T2)) :
  ∃ t1 t2, t = prod t1 t2 ∧ Typing Γ t1 T1 ∧ Typing Γ t2 T2.
Proof.
  depind wt; try contradiction; exists t1, t2; split; auto.
Qed.

Lemma can_form_texist {Γ t T} (v: Value t) (wt: Typing Γ t (texist T)) :
  ∃ T11 t12, t = pack T11 t12 (texist T).
Proof.
  depind wt; try contradiction; exists U, t2; reflexivity.
Qed.

Lemma matching_defined {Γ p T1 Δ} (wp: PTyping Γ p T1 Δ) :
  ∀ {t1}, Value t1 → Typing Γ t1 T1 → ∀ t2, ∃ t2', Match p t1 t2 t2'.
Proof.
  induction wp; intros t1 v1 wt1 t2.
  - exists (substTm HO t1 t2).
    refine M_Var.
  - destruct (can_form_tprod v1 wt1) as (t11 & t12 & eq & wt11 & wt12); subst.
    destruct v1 as [v11 v12].
    apply (weaken_typing Δ1) in wt12.
    assert (val12' : Value (weakenTm t12 (dom Δ1)))
       by (apply weaken_value; auto).
    destruct (IHwp2 (weakenTm t12 (dom Δ1)) val12' wt12 t2) as [t2' m2].
    destruct (IHwp1 _ v11 wt11 t2') as [t2'' m1].
    rewrite <- (PTyping_bindPat_dom wp1) in m2.
    exists t2''.
    exact (M_Prod m2 m1).
Qed.

Lemma progress {t U} (wt: Typing empty t U) :
  Value t ∨ ∃ t', red t t'.
Proof with try (subst; eauto using red).
  depind wt; simpl; auto.
  - inversion H.
  - destruct IHwt1 as [v1|[t1' r1]]...
    destruct IHwt2 as [v2|[t2' r2]]...
    destruct (can_form_tarr v1 wt1)...
  - destruct IHwt as [vt|[t1' r1]]...
    destruct (can_form_tall vt wt)...
  - destruct IHwt as [v1|[t1' r1]]...
  - destruct IHwt1 as [v1|[t1' r1]]...
    destruct (can_form_texist v1 wt1) as [? [? ?]]...
  - destruct IHwt1 as [v1|[t1' r1]]...
    destruct IHwt2 as [v2|[t2' r2]]...
  - destruct IHwt1 as [v1|[t1' r1]]...
    destruct (matching_defined H v1 wt1 t2)...
Qed.

(******************************************************************************)
(* Preservation                                                               *)
(******************************************************************************)

Lemma local_preservation_lett {p t1 t2 t2'} (m: Match p t1 t2 t2') :
  ∀ {Γ T1 T2 Δ}, PTyping Γ p T1 Δ → Typing Γ t1 T1 →
    Typing (append Γ Δ) t2 (weakenTy T2 (dom Δ)) → Typing Γ t2' T2.
Proof.
  induction m; intros Γ T1 T2 Δ wp wt1 wt2.
  - dependent destruction wp.
    eauto using subst_evar_typing, subst_evar.
  - dependent destruction wp.
    dependent destruction wt1.
    rewrite (PTyping_bindPat_dom wp1) in *.
    rewrite append_assoc, dom_append, weakenTy_hplus in wt2.
    refine (IHm2 _ _ _ _ wp1 wt1_1 (IHm1 _ _ _ _ wp2 _ wt2)).
    now apply weaken_typing.
Qed.

Lemma preservation {Γ t U} (wt: Typing Γ t U) :
  ∀ {t'}, red t t' → Typing Γ t' U.
Proof.
  induction wt; intros t' r; inversion r; subst; eauto using Typing.
  - dependent destruction wt1; eauto using subst_evar_typing.
  - dependent destruction wt; eauto using subst_etvar_typing.
  - inversion wt1; subst; clear wt1; rewrite tsubstTm_substTm0_comm; isimpl.
    eapply subst_evar_typing; eauto.
    generalize (@subst_etvar_typing T11 _ _ _ wt2 (HSm HO) (evar Γ (tsubstTy HO T11 T12))).
    isimpl; eauto.
  - eapply local_preservation_lett; eauto.
Qed.


(* randomly generated positive definite matrix *)

From Bignums Require Import BigZ.
Require Import mathcomp.ssreflect.seq.
Require Import Interval.Float.Specific_bigint.
Require Import Interval.Float.Basic.
Require Import Interval.Float.Specific_ops.
Require Import CoqEAL.refinements.seqmx.
Require Import CoqEAL.refinements.refinements.
Require Import CoqEAL.refinements.hrel.
Require Import CoqEAL.refinements.seqmx_complements.
From ValidSDP Require Import cholesky_prog iteri_ord posdef_check.
Import Refinements.Op.
Require Import Floats.

Module F := SpecificFloat BigIntRadix2.

From FloatBench Require Import §mat§.

(* Profile floating-point arithmetic operations. *)

(* Tip to avoid the pretty-printing overhead when doing "Time Eval" *)
Lemma qed A (t : A) : unit.
exact tt.
Qed.
Notation "§" := (@qed _ _).

Definition select_intvl (a b : F.type) := a.
Definition select_float (a b : float) := a.

Notation doubling1 f := (let r1 := (f) in
                        let r2 := (f) in
                        select_intvl r1 r2) (only parsing).

Notation no_doubling1 f := (f) (only parsing).

Section test_CoqInterval.
Local Notation T := F.type (only parsing).
Definition two := Eval compute in
      let one := Float 1%bigZ 0%bigZ in
      F.add_slow rnd_NE 53%bigZ one one.

Instance : add_of T := fun a b => no_doubling1 (F.add_slow rnd_NE 53%bigZ a b).
Instance : mul_of T := fun a b => no_doubling1 (F.mul rnd_NE 53%bigZ a b).
Instance : sqrt_of T := fun a => (F.sqrt rnd_NE 53%bigZ a).
Instance : div_of T := fun a b => (F.div rnd_NE 53%bigZ a b).
Instance : opp_of T := fun a => (F.neg a).
Instance : zero_of T := F.zero.
Instance : one_of T := Float 1%bigZ 0%bigZ.

Time Eval vm_compute in qed _ (cholesky_seqmx (n := seq.size matrix) matrix).
End test_CoqInterval.


Require Import CSet Util Map.
Require Import Envs IL Alpha Annotation RenamedApart SetOperations.
Require Import LabelsDefined PairwiseDisjoint RenameApart FreshGen.

Set Implicit Arguments.

Lemma rename_apart_alpha' {Fi} (FG:FreshGen var Fi) (FGS:FreshGenSpec FG) fi ϱ ϱ' s
  : lookup_set ϱ (freeVars s) ⊆ domain FG fi
  -> inverse_on (freeVars s) ϱ ϱ'
  -> alpha ϱ' ϱ (snd (renameApart FG fi ϱ s)) s.
Proof.
  revert fi ϱ ϱ'.
  induction s using stmt_ind'; simpl; intros; repeat let_pair_case_eq; subst;
  simpl in * |- *; eauto using alpha.

  - econstructor. eapply alpha_exp_sym. eapply alpha_exp_rename_injective.
    eapply inverse_on_incl; try eassumption. eauto with cset.
    eapply IHs; eauto.
    + rewrite <- fresh_domain_spec; eauto.
      rewrite <- H. rewrite lookup_set_update_in_union; eauto.
      rewrite <- lookup_set_union_incl; eauto; try reflexivity.
      cset_tac.
    + eapply inverse_on_update_inverse. intuition.
      eapply inverse_on_incl; try eassumption. cset_tac; eauto.
      assert (lookup_set ϱ (freeVars s \ {{x}}) ⊆
                         lookup_set ϱ ((freeVars s \ {{x}}) ∪ Exp.freeVars e)).
      rewrite lookup_set_union; cset_tac; intuition.
      rewrite H1, H. eapply fresh_spec; eauto.
  - econstructor; eauto.
    + eapply alpha_op_sym. eapply alpha_op_rename_injective.
      eapply inverse_on_incl; try eassumption. eapply incl_right.
    + eapply IHs1; eauto.
      * eapply Subset_trans; try eassumption. eapply lookup_set_incl; [intuition|].
        rewrite union_assoc, union_comm. eapply incl_right.
      * eapply inverse_on_incl; try eassumption.
        rewrite union_assoc, union_comm. eapply incl_right.
    + eapply IHs2; eauto.
      * rewrite <- domain_incl_renameApart; eauto.
        rewrite <- H. repeat rewrite lookup_set_union; cset_tac; intuition.
      * eapply inverse_on_incl; try eassumption.
        cset_tac; intuition.
  - econstructor. rewrite map_length; eauto.
    intros. edestruct map_get_4; eauto; dcr; get_functional; subst.
    eapply alpha_op_sym. eapply alpha_op_rename_injective.
    eapply inverse_on_incl; try eassumption. eapply incl_list_union; try reflexivity.
    eapply map_get_1; eauto.

  - econstructor; eauto. eapply alpha_op_sym.
    eapply alpha_op_rename_injective.
    eapply inverse_on_incl; try eassumption. reflexivity.
  - econstructor.
    + rewrite rev_length, renameApartF_length; eauto.
    + intros. inv_get. len_simpl. inv_get. rewrite fresh_list_len; eauto.
    + intros. inv_get; len_simpl. inv_get.
      * eapply H; eauto.
        -- rewrite lookup_set_update_with_list_in_union_length; eauto.
           rewrite <- fresh_list_domain_spec; eauto.
           rewrite union_comm. eapply incl_union_lr; eauto.
           rewrite <- domain_incl_renameApartFRight; eauto.
           rewrite <- H0.
           eapply lookup_set_incl; eauto.
           eapply incl_union_left.
           eapply incl_list_union. eapply map_get_1; eauto. reflexivity.
           rewrite fresh_list_len; eauto.
        -- eapply inverse_on_update_fresh; eauto.
           eapply inverse_on_incl; try eassumption. eauto.
           eapply incl_union_left.
           eapply incl_list_union. eapply map_get_1; eauto. reflexivity.
           eapply fresh_list_nodup; eauto.
           rewrite fresh_list_len; eauto.
           symmetry. eapply disj_1_incl; eauto.
           eapply fresh_list_disj; eauto.
           rewrite <- domain_incl_renameApartFRight; eauto.
           rewrite <- H0. eapply lookup_set_incl; eauto.
           eapply incl_union_left.
           eapply incl_list_union. eapply map_get_1; eauto. reflexivity.
    + eapply IHs; eauto.
      * rewrite <- domain_incl_renameApartF; eauto.
        rewrite <- H0 at 1.
        rewrite lookup_set_union; eauto with cset.
      * eapply inverse_on_incl; try eassumption. eauto.
Qed.

Lemma rename_apart_alpha {Fi} (FG:FreshGen var Fi) (FGS:FreshGenSpec FG) s
  : alpha id id (rename_apart FG s) s.
Proof.
  eapply rename_apart_alpha'; eauto.
  + eapply lookup_set_on_id. rewrite <- domain_add_spec; eauto with cset.
  + eapply inverse_on_id.
Qed.


From discprob.prob Require Import double rearrange.
From discprob.prob Require Import prob finite stochastic_order.
From discprob.prob Require Export countable.
From discprob.basic Require Import base sval order monad bigop_ext.
From discprob.basic Require Export classic_proof_irrel.
From discprob.prob Require Export countable dep_prod.
Require Import Reals Psatz.
Require ClassicalEpsilon.
From mathcomp Require Import ssrfun ssreflect eqtype ssrbool seq fintype choice bigop.
Global Set Bullet Behavior "Strict Subproofs".

Local Open Scope R_scope.

Record mdist X :=
  {
    mdist_idx : countType;
    mdist_distrib : distrib mdist_idx;
    mdist_ind : mdist_idx → X;
  }.

Arguments mdist_idx {_} _.
Arguments mdist_distrib {_} _.
Arguments mdist_ind {_} _.

Definition gen_eqP (X: Type) :
  Equality.axiom (fun x y: X => ClassicalEpsilon.excluded_middle_informative (x = y) ).
Proof. move => x y. apply sumboolP. Qed.

Definition gen_eqMixin (X: Type) := EqMixin (gen_eqP X).
Definition gen_eqType (X : Type) := Eval hnf in EqType _ (gen_eqMixin X).

Definition rvar_of_mdist {X} (md: mdist X) : rvar (mdist_distrib md) (gen_eqType X).
  refine (mkRvar (mdist_distrib md) _).
  { apply mdist_ind. }
Defined.

Definition In_support {X: Type} (x: X) (I : mdist X) :=
  ∃ i, mdist_ind I i = x ∧ (pmf (mdist_distrib I) i > 0).
Definition msupport {X} I := { x : X | In_support x I }.

Definition eq_mdist {X} (I1 I2: mdist X) :=
  (∀ x, pr_eq (rvar_of_mdist I1) x = pr_eq (rvar_of_mdist I2) x).

Lemma eq_mdist_refl {X} (I: mdist X): eq_mdist I I.
Proof. intros ?; eauto. Qed.

Lemma eq_mdist_sym {X} (I1 I2: mdist X): eq_mdist I1 I2 → eq_mdist I2 I1.
Proof. intros Heq x. symmetry. apply Heq. Qed.

Lemma eq_mdist_trans {X} (I1 I2 I3: mdist X): eq_mdist I1 I2 → eq_mdist I2 I3 → eq_mdist I1 I3.
Proof. intros Heq1 Heq2 x. etransitivity; first eapply Heq1. apply Heq2. Qed.

(* TODO: move *)
(* TODO: should we just use { x :unit | false} as empty ? *)
Lemma eqeP : Equality.axiom (λ x y : Empty_set, true).
Proof. intros []. Qed.

Canonical empty_eqMixin := EqMixin eqeP.
Canonical empty_eqType := Eval hnf in EqType Empty_set empty_eqMixin.

Fact empty_choiceMixin: choiceMixin Empty_set.
Proof.
  exists (λ P n, None).
  - intros ?? [].
  - intros ? [[]].
  - intros ?? ? x. done.
Qed.
Canonical empty_choiceType := Eval hnf in ChoiceType Empty_set empty_choiceMixin.

Definition empty_pickle (x: Empty_set) := Empty_set_rect (λ x, nat) x.
Definition empty_unpickle (n: nat) : option Empty_set := None.
Lemma empty_pickleK : pcancel empty_pickle empty_unpickle.
Proof. intros []. Qed.

Definition empty_countMixin := CountMixin (empty_pickleK).
Canonical empty_countType := Eval hnf in CountType Empty_set empty_countMixin.

Lemma empty_enumP : @Finite.axiom [eqType of Empty_set] [::].
Proof. intros []. Qed.
Definition empty_finMixin := Eval hnf in FinMixin empty_enumP.
Canonical empty_finType := Eval hnf in FinType Empty_set empty_finMixin.

Global Instance eq_mdist_Transitivite {Y}: Transitive (@eq_mdist Y).
Proof. intros ???. apply eq_mdist_trans. Qed.
Global Instance eq_mdist_Reflexive {Y}: Reflexive (@eq_mdist Y).
Proof. intros ?. apply eq_mdist_refl. Qed.
Global Instance eq_mdist_Symmetry {Y}: Symmetric (@eq_mdist Y).
Proof. intros ??. apply eq_mdist_sym. Qed.
Global Instance eq_mdist_Equivalence {Y}: Equivalence (@eq_mdist Y).
Proof. split; apply _. Qed.

Ltac abs_simpl :=
  match goal with
  | [ H: context [ Rabs ?p ] |- _ ]  =>
    rewrite (Rabs_right p) in H; last by nra
  | [ |- context [ Rabs ?p ] ] =>
    rewrite (Rabs_right p); last by nra
  end.

Definition dirac_unit : distrib [finType of unit].
  refine {| pmf := λ _, 1 |}.
  { abstract (intros; nra). }
  { abstract (apply SeriesF_is_seriesC'; rewrite big_const card_unit //=; nra). }
Defined.

Global Instance mdist_ret: MRet mdist.
refine(λ A x, {| mdist_idx := [finType of unit]; mdist_distrib := dirac_unit; mdist_ind := (λ _, x)|}).
Defined.

Definition mdist_bind_idx  {A B} (f: A → mdist B) (I : mdist A) :=
  [countType of { i: mdist_idx I & mdist_idx (f (mdist_ind I i)) }].

Definition mdist_bind_pmf {A B} (f : A → mdist B) (I: mdist A) : mdist_bind_idx f I → R :=
  (λ ip, pmf (mdist_distrib I) (projT1 ip)
                           * pmf (mdist_distrib (f (mdist_ind I (projT1 ip)))) (projT2 ip)).

Lemma mdist_bind_pmf_nonneg {A B} (f: A → mdist B) (I : mdist A) :
  ∀ a : mdist_bind_idx f I, mdist_bind_pmf f I a >= 0.
Proof.
  intros a. rewrite /mdist_bind_pmf. apply Rle_ge.
  apply Rmult_le_pos; apply Rge_le, pmf_pos.
Qed.

Lemma mdist_bind_series_1 {A B} (f: A → mdist B) (I : mdist A) :
  is_series (countable_sum (mdist_bind_pmf f I)) 1.
Proof.
  rewrite /mdist_bind_pmf.
  eapply is_series_ext; last first.
  { unshelve (eapply (dep_prod.prod_pmf_pos_sum1 (mdist_idx I))).
    { intros i. apply (mdist_idx (f (mdist_ind I i))). }
    { apply (mdist_distrib I). }
    { intros i. apply (mdist_distrib (f (mdist_ind I i))). }
  }
  rewrite /dep_prod_pmf. eauto.
Qed.

Definition mdist_bind_distrib {A B} (f: A → mdist B) (I : mdist A) : distrib (mdist_bind_idx f I).
  refine ({| pmf := mdist_bind_pmf f I |}).
  - apply mdist_bind_pmf_nonneg.
  - apply mdist_bind_series_1.
Defined.

Global Instance mdist_bind: MBind mdist :=
  λ A B f I,
  {| mdist_idx := mdist_bind_idx f I;
     mdist_ind := (λ ip, mdist_ind (f (mdist_ind I (projT1 ip))) (projT2 ip));
     mdist_distrib := mdist_bind_distrib f I;
  |}.

Global Instance mdist_join: MJoin mdist :=
  λ A I, mbind (λ x, x) I.

Lemma mdist_left_id {A B: Type} (x: A) (f: A → mdist B):
  eq_mdist (mbind f (mret x)) (f x).
Proof. Admitted.

Lemma mdist_right_id {A: Type} (m: mdist A):
  eq_mdist (mbind mret m) m.
Proof. Admitted.

Lemma mdist_assoc {A B C} (m: mdist A) (f: A → mdist B) (g: B → mdist C) :
  eq_mdist (mbind g (mbind f m)) (mbind (λ x, mbind g (f x)) m).
Proof. Admitted.

Lemma mdist_bind_congr {A B} (m1 m2: mdist A) (f1 f2: A → mdist B) :
  eq_mdist m1 m2 →
  (∀ a, eq_mdist (f1 a) (f2 a)) →
  eq_mdist (mbind f1 m1) (mbind f2 m2).
Proof. Admitted.

Global Instance ibind_proper {X Y}:
  Proper ((pointwise_relation _ (@eq_mdist Y)) ==> @eq_mdist X ==> @eq_mdist Y) (@mbind mdist _ X Y).
Proof. intros ?? ? ?? ?. apply mdist_bind_congr; eauto. Qed.

Lemma mdist_bind_comm_aux {A1 A2} (I1: mdist A1) (I2: mdist A2) :
  eq_mdist (x ← I1; y ← I2; mret (x, y)) (y ← I2; x ← I1; mret (x, y)).
Proof. Admitted.

Lemma mdist_bind_comm {A1 A2 A3} (I1: mdist A1) (I2: mdist A2) (f: A1 → A2 → mdist A3):
  eq_mdist (x ← I1; y ← I2; f x y) (y ← I2; x ← I1; f x y).
Proof.
  transitivity (xy ← (x ← I1; y ← I2; mret (x, y)); f (fst xy) (snd xy)).
  - setoid_rewrite mdist_assoc.
    eapply mdist_bind_congr; first by reflexivity.
    intros x.
    setoid_rewrite mdist_assoc.
    eapply mdist_bind_congr; first by reflexivity.
    intros y.
    setoid_rewrite mdist_left_id; reflexivity.
  - setoid_rewrite mdist_bind_comm_aux.
    setoid_rewrite mdist_assoc.
    eapply mdist_bind_congr; first by reflexivity.
    intros x.
    setoid_rewrite mdist_assoc.
    eapply mdist_bind_congr; first by reflexivity.
    intros y.
    setoid_rewrite mdist_left_id; reflexivity.
Qed.


(* Natural Deduction for First-Order Intuitionistic Logic *)

From Coq Require Import Wf_nat Lia.
From OLlibs Require Import List_more.
From Quantifiers Require Export foformulas_vec.

Set Implicit Arguments.

(** * Proofs *)

Section Proofs.

Context {vatom : DecType} {tatom fatom : Type}.
Context {tarity : tatom -> nat} {farity : fatom -> nat}.
Arguments tvar {_} {_} {_} {T} _.

Notation term := (@term vatom tatom tarity nat).
Notation closed t := (tvars t = nil).
Notation rclosed r := (forall n, closed (r n)).
Notation "↑ r" := (felift (evar 0) r) (at level 25, format "↑ r").
Notation "v ⇓" := (fesubs v) (at level 18, format "v ⇓").
Notation "A ⟦ r ⟧" := (esubs r A) (at level 8, left associativity, format "A ⟦ r ⟧").
Notation "A [ u // x ]" := (subs x u A) (at level 8, format "A [ u // x ]").
Notation "⇑" := fup.
Notation "A ↑" := (A⟦⇑⟧) (at level 8, format "A ↑").
Notation "l ⇈" := (map (fun F => F↑) l) (at level 8, format "l ⇈").

Inductive FQcon := frl_con.
Notation frl := (fqtf frl_con).

Notation formula := (@formula vatom tatom tarity fatom farity Nocon Nocon Icon FQcon nat).

Hint Rewrite (@fsize_esubs vatom tatom tarity fatom farity Nocon Nocon Icon FQcon) : term_db.
Hint Rewrite (@fsize_subs vatom tatom tarity fatom farity Nocon Nocon Icon FQcon nat) : term_db.
Hint Rewrite (@tvars_tesubs_closed vatom tatom tarity) using intuition; fail : term_db.
Hint Rewrite (@subs_esubs vatom tatom tarity fatom farity Nocon Nocon Icon FQcon nat)
                         using intuition; fail : term_db.
Hint Rewrite (@felift_esubs vatom tatom tarity fatom farity Nocon Nocon Icon FQcon) : term_db.
Hint Rewrite (@esubs_fup vatom tatom tarity fatom farity Nocon Nocon Icon FQcon) : term_db.

Hint Resolve closed_felift : term_db.
Hint Resolve closed_fesubs : term_db.

(** Proofs *)
Inductive prove : list formula -> formula -> Type :=
| ax l1 l2 A : prove (l1 ++ A :: l2) A
| impi l A B : prove (A :: l) B -> prove l (imp A B)
| impe l B A : prove l (imp A B) -> prove l A -> prove l B
| frli x l A : prove l⇈ A↑[evar 0//x] -> prove l (frl x A)
| frle x l A u : closed u -> prove l (frl x A) -> prove l (subs x u A).
Hint Constructors prove : term_db.
Global Arguments impe { l B }.

(* This [weakening] lemma is not required in the development, see rather [rweakening] below *)
(* It is given here for comparison with alternative formalizations of Natural Deduction *)
Lemma weakening l A : prove l A -> forall l0, prove (l ++ l0) A.
Proof.
intros pi; induction pi; intros; subst;
  try (econstructor; rewrite_all map_app; rewrite ? app_comm_cons; intuition; fail).
rewrite <- app_assoc, <- app_comm_cons; intuition.
Qed.
(* an alternative slightly more general statement:
Lemma weakening_middle : forall l A,
  prove l A -> forall l0 l1 l2, l = l1 ++ l2 -> prove (l1 ++ l0 ++ l2) A.
Proof.
intros l A pi; induction pi; intros; subst;
  try (econstructor; rewrite_all map_app; rewrite ? app_comm_cons; intuition; fail).
destruct (elt_eq_app _ _ _ _ _ H) as [ [? [? ?]] | [? [? ?]] ]; subst;
  rewrite ? (app_assoc _ _ (A::_)), <- ? (app_assoc _ (A::_)), <- ? app_comm_cons;
  intuition.
Qed.
*)

(** Normal Forms *)
Inductive nprove : list formula -> formula -> Type := (* neutral terms *)
| nax l1 l2 A : nprove (l1 ++ A :: l2) A
| nimpe l B A : nprove l (imp A B) -> rprove l A -> nprove l B
| nfrle x l A u : closed u -> nprove l (frl x A) -> nprove l (subs x u A)
with rprove : list formula -> formula -> Type := (* normal forms *)
| rninj l A : nprove l A -> rprove l A
| rimpi l A B : rprove (A :: l) B -> rprove l (imp A B)
| rfrli x l A : rprove l⇈ A↑[evar 0//x] -> rprove l (frl x A).
Hint Constructors nprove rprove : term_db.
Global Arguments rfrli { x l A }.
Global Arguments nimpe { l B }.

Scheme nrprove_rect := Induction for nprove Sort Type
  with rnprove_rect := Induction for rprove Sort Type.
Combined Scheme rnprove_mutrect from nrprove_rect, rnprove_rect.

Fixpoint nsize {l A} (pi : nprove l A) : nat :=
match pi with
| nax _ _ _  => 1
| nimpe _ pi1 pi2 => S (nsize pi1 + rsize pi2)
| nfrle _ _ pi0 => S (nsize pi0)
end
with rsize {l A} (pi : rprove l A) : nat :=
match pi with
| rninj pi0 => S (nsize pi0)
| rimpi pi0 => S (rsize pi0)
| rfrli pi0 => S (rsize pi0)
end.

Theorem denormalization :
   (forall l A, nprove l A -> prove l A)
 * (forall l A, rprove l A -> prove l A).
Proof. now apply rnprove_mutrect; intros; try (econstructor; eassumption). Qed.

(** * Normalization *)

(** apply [r] on normal form *)
Theorem rnpesubs r (Hc : rclosed r) {l A} :
   (nprove l A -> nprove (map (esubs r) l) A⟦r⟧)
 * (rprove l A -> rprove (map (esubs r) l) A⟦r⟧).
Proof.
revert l A.
enough ((forall l A, nprove l A -> forall r, rclosed r -> nprove (map (esubs r) l) A⟦r⟧)
      * (forall l A, rprove l A -> forall r, rclosed r -> rprove (map (esubs r) l) A⟦r⟧))
  as He by (split; intros; apply He; assumption).
clear r Hc; apply rnprove_mutrect; intros; (try simpl in X);
  (try assert (IH1 := X r H)); (try assert (IH2 := X0 r H));
  (try (econstructor; (eassumption + intuition); fail)).
- rewrite map_app; apply nax.
- rcauto; rnow apply nfrle.
- specialize X with (↑r0).
  revert X; rcauto.
  rewrite map_map, (map_ext _ _ (felift_esubs (evar 0) _)), <- map_map in X. intuition.
Qed.

Lemma rpsubsz {l A x u} : closed u -> rprove l⇈ A↑[evar 0//x] -> rprove l (subs x u A).
Proof.
intros Hc pi.
apply (rnpesubs (u⇓)) in pi; [ | intuition ].
rnow simpl in pi then simpl in pi.
now rewrite map_map, (map_ext _ _ (esubs_fup _)), map_id in pi.
Qed.

Lemma rweakening :
   (forall l A, nprove l A -> forall l0 l1 l2, l = l1 ++ l2 -> nprove (l1 ++ l0 ++ l2) A)
 * (forall l A, rprove l A -> forall l0 l1 l2, l = l1 ++ l2 -> rprove (l1 ++ l0 ++ l2) A).
Proof.
apply rnprove_mutrect; intros; subst;
  try (econstructor; rewrite_all map_app; rewrite ? app_comm_cons; intuition; fail).
destruct (dichot_elt_app_inf _ _ _ _ _ H) as [ [? [? ?]] | [? [? ?]] ]; subst;
  rewrite ? (app_assoc _ _ (A::_)), <- ? (app_assoc _ (A::_)), <- ? app_comm_cons;
  intuition.
Qed.

Lemma substitution l A B : rprove l A -> rprove (A :: l) B -> rprove l B.
Proof.
pose (IH := (fun n m =>
 forall A, fsize A = n ->
   (forall B l1 l2 (pi : nprove (l1 ++ A :: l2) B),
      nsize pi < m -> fsize A < fsize B -> rprove (l1 ++ l2) A -> nprove (l1 ++ l2) B)
 * (forall B l1 l2 (pi : nprove (l1 ++ A :: l2) B),
      nsize pi < m -> rprove (l1 ++ l2) A -> rprove (l1 ++ l2) B)
 * (forall B l1 l2 (pi : rprove (l1 ++ A :: l2) B),
      rsize pi < m -> rprove (l1 ++ l2) A -> rprove (l1 ++ l2) B))).
enough (forall n m, IH n m) as Hsub.
{ intros pi1 pi2.
  rewrite <- (app_nil_l (A :: l)) in pi2; rewrite <- (app_nil_l l).
  refine (snd (Hsub _ (S (rsize pi2)) _ _) _ _ _ _ _ _); intuition. }
clear l A B.
apply lt_wf_double_rect; unfold IH; clear IH; simpl;
 intros n m IHn IHm A HA; (split; [ split | ] ); subst;
 intros B l1 l2 pi2 Hpi; [ intros HF | | ]; intros pi1;
 remember (l1 ++ A :: l2) as ll; destruct pi2; subst; simpl in Hpi.
(* first statement *)
- destruct (dichot_elt_app_inf _ _ _ _ _ Heqll)
    as [ (l' & Heq0 & Heq) | (l' & Heq0 & Heq) ]; subst.
  + rewrite <- app_assoc; apply nax.
  + destruct l'; inversion Heq; subst.
    * exfalso; lia.
    * rewrite app_assoc; apply nax.
- assert (nsize pi2 < S (nsize pi2 + rsize r)) as IH1 by lia.
  assert (rsize r < S (nsize pi2 + rsize r)) as IH2 by lia.
  eapply nimpe; eapply (IHm (S (nsize pi2 + rsize r))); simpl; eauto; lia.
- apply nfrle; auto.
  rnow eapply (IHm _ Hpi).
(* second statement *)
- enough (forall l l1 l2, l0 ++ A0 :: l3 = l1 ++ A :: l2 ->
      rprove (l ++ l1 ++ l2) A -> rprove (l ++ l1 ++ l2) A0)
    as HI by (eapply (HI nil); eassumption) ; clear.
  induction l0; intros l l1 l2 Heq pi; destruct l1; inversion Heq; subst; auto.
  + rewrite <- app_comm_cons; apply rninj, nax.
  + rewrite 2 app_assoc; apply rninj, nax.
  + rewrite <- app_comm_cons, <- (app_nil_l l1), <- app_assoc, app_comm_cons, app_assoc.
    apply IHl0; auto.
    now rewrite <- ? app_assoc, <- app_comm_cons.
- assert (nsize pi2 < S (nsize pi2 + rsize r)) as IH1 by lia.
  assert (rsize r < S (nsize pi2 + rsize r)) as IH2 by lia.
  eapply IHm in IH2; eauto.
  assert ({fsize (imp A0 B) <= fsize A} + {fsize A < fsize (imp A0 B)}) as [ Ho | Ho ]
    by (case (CompareSpec2Type (Nat.compare_spec (fsize (imp A0 B)) (fsize A))); intros Ho;
          [ left | left | right ]; lia); simpl in Ho.
  + eapply IHm in IH1; eauto.
    inversion_clear IH1 as [ l' A' pi1' | l' A' B' pi1' | ].
    * apply rninj; eapply nimpe; eauto.
    * rewrite <- (app_nil_l _) in pi1'.
      refine (snd (IHn (fsize A0) (S (rsize pi1')) _ _ _) _ _ _ pi1' _ IH2); lia.
  + apply rninj, (nimpe A0); auto.
    eapply IHm; eauto; lia.
- assert (nsize pi2 < S (nsize pi2)) as IH1 by lia.
  apply IHm in IH1; auto.
  inversion_clear IH1.
  + now apply rninj, nfrle.
  + now apply rpsubsz.
(* third statement *)
- refine (snd (fst (IHm _ _ _ _)) _ _ _ n _ _); auto; lia.
- revert pi2 Hpi; rewrite app_comm_cons; intros pi2 Hpi.
  apply rimpi.
  refine (snd (IHm _ _ _ _) _ _ _ pi2 _ _); auto; try lia.
  rewrite <- app_comm_cons, <- (app_nil_l (l1 ++ l2)), app_comm_cons, <- (app_nil_l _).
  eapply rweakening; eauto.
- apply rfrli; rewrite map_app.
  apply (rnpesubs ⇑) in pi1; intuition.
  revert pi1 pi2 Hpi; rewrite ? map_app; simpl; intros pi1 pi2 Hpi.
  rnow (refine (snd (IHm _ _ _ _) _ _ _ pi2 _ _); auto).
Qed.

Theorem normalization : forall l A, prove l A -> rprove l A.
Proof.
intros l A pi; induction pi; try (econstructor; (idtac + econstructor); eassumption).
- inversion_clear IHpi1.
  + apply rninj; eapply nimpe; eassumption.
  + eapply substitution; eassumption.
- inversion_clear IHpi.
  + apply rninj; now eapply nfrle.
  + now apply rpsubsz.
Qed.

End Proofs.

(** * Examples *)
Section Examples.

Context { vatom : DecType } { tatom fatom : Type }.

Variable f : tatom.
Variable x : vatom.
Variable P : fatom.
Definition tarity : tatom -> nat := fun _ => 1.
Definition farity : fatom -> nat := fun _ => 1.

Notation frl := (fqtf frl_con).
Notation formula := (@formula vatom tatom tarity fatom farity Nocon Nocon Icon FQcon nat).

(* Apply all (reversible) introduction rules *)
Ltac rev_intros := repeat (repeat apply rimpi; repeat (apply rfrli; simpl)); apply rninj.

Goal rprove nil
  (imp (frl x (fvar P (Vector.cons _ (tconstr f (Vector.cons _ (tvar _ x) _ (Vector.nil _))) _ (Vector.nil _))))
       (frl x (fvar P (Vector.cons _ (tconstr f
                      (Vector.cons _ (tconstr f (Vector.cons _ (tvar _ x) _ (Vector.nil _))) _
                                                                            (Vector.nil _))) _ (Vector.nil _))))).
Proof.
rnow rev_intros.
rewrite if_eq_dt_dec_refl.
replace (fvar P (Vector.cons _ (tconstr f
        (Vector.cons _ (tconstr f (Vector.cons _ (evar 0) 0 (Vector.nil _))) 0 (Vector.nil _))) 0 (Vector.nil _)))
   with (subs x (tconstr f (Vector.cons _ (evar 0) 0 (Vector.nil _)))
        (fvar P (Vector.cons _ (tconstr f (Vector.cons _ (tvar _ x) _ (Vector.nil _))) _ (Vector.nil _)))
         : formula)
  by rcauto.
apply nfrle; [ auto | ].
rewrite <- (app_nil_l (_ :: _)). apply nax.
Qed.

End Examples.


Require Import Unicode.Utf8.

(*
  Welcome. Here is some code:
 *)

Inductive bool : Type :=
| true : bool
| false : bool
.

(* Here is a theorem: *)

Theorem bools_are_true_or_false : ∀ b, b = true \/ b = false.
Proof.
  intro. destruct b.
  { left. reflexivity. }
  { right. reflexivity. }
Qed.

Theorem bools_are_not_true_and_false :
  ∀ b, ¬ (b = true ∧ b = false).
Proof.
  intro. intro. destruct H. destruct b. inversion H0. inversion H.
Qed.

(* Yet another theorem: *)

Theorem t : False.
Proof.
Admitted.


(*+ CSL to progress and preservation *)

(* In this file, we use the same notion of thread safety as in the
rest of VST, which is defined using specifications for external
functions. In the rest of VST, we derive safety of the concurrent
(juicy) machine from [progress] and [preservation] of an invariant.

We give a toy version of those definitions and proofs here,
simplifying greatly problems related to step indexing, external calls
and spawning. *)

(* standard files distributed with Coq *)
Require Import List Arith Omega Setoid String.
Require Import Coq.Logic.FunctionalExtensionality.

(* local file *)
Require Import resourcemaps.

Definition interp_lock := resourcemaps.interp_lock.

Definition islock (l : nat) (R : map -> Prop) (m : map) :=
  exists lock, m l = Some (inr lock) /\ interp_lock lock = R.

Lemma islock_inj : forall v R1 R2 m, islock v R1 m -> islock v R2 m -> R1 = R2.
  intros v R1 R2 m [lock1 [E1 H1]] [lock2 [E2 H2]].
  congruence.
Qed.

(*+ Core steps *)

Variable C' : Set.

Variable corestep : C' -> map -> C' -> map -> Prop.

Variable corestep_fun : forall c m c1 m1 c2 m2,
    corestep c m c1 m1 ->
    corestep c m c2 m2 ->
    c1 = c2 /\ m1 = m2.

Variable corestep_sameperms : forall c m c' m', corestep c m c' m' -> sameperms m m'.

Variable corestep_samelocks : forall c m c' m' l lock,
    corestep c m c' m' -> (m l = Some (inr lock) <-> m' l = Some (inr lock)).

Variable cancellative : forall m1 m1' m2 m3, join m1 m2 m3 -> join m1' m2 m3 -> m1 = m1'.

(** Concurrent instructions are built on top of those [C'] *)

Inductive C : Set :=
  | acquire : nat -> C -> C
  | release : nat -> C -> C
  | normal : C' -> C.

(*+ Joinability hypotheses *)

(* Those lemmas can be proved if the support set of maps is finite.
We omit those for conveninence, here. *)

Variable jointo : forall {A} (maps : A -> map) (m : map), Prop.

Axiom selfjoins_jointo : forall {A} (maps : A -> map),
    selfjoins maps -> exists m, jointo maps m.

Axiom jointo_selfjoins : forall {A} (maps : A -> map) m,
    jointo maps m -> selfjoins maps.

Axiom jointo_det : forall {A} (maps : A -> map) m1 m2,
    jointo maps m1 -> jointo maps m2 -> m1 = m2.

Axiom jointo_Some : forall {A} (maps : A -> map) m a addr v,
    jointo maps m -> maps a addr = Some v -> m addr = Some v.

Axiom jointo_Some_inv : forall {A} (maps : A -> map) m addr v,
    jointo maps m -> m addr = Some v -> exists a, maps a addr = Some v.

Lemma join_Some m1 m2 m addr v :
  join m1 m2 m ->
  m1 addr = Some v ->
  m addr = Some v.
Proof.
  intros J E; specialize (J addr).
  rewrite E in J.
  destruct (m2 addr); simpl in *; auto; congruence.
Qed.

Axiom jointo_swapped :
  forall {A} {m1 m2 : A -> map} (Adec:forall x y:A,{x=y}+{x<>y})
    i j Phi e a b a' b',
    swapped m1 m2 i j a b a' b' ->
    join a b e ->
    join a' b' e ->
    jointo m1 Phi ->
    jointo m2 Phi.

(*+ Definition of safety *)

(* We define safety based on specification of externals (acquire and
release) *)

(* no need for an oracle, so it is unit *)
Definition Z := unit.

Record ext : Type := mkext {
    ext_type : Type;
    Pre : ext_type -> Z -> map -> Prop;
    Post : ext_type -> Z -> map -> Prop
  }.

Definition after_external : C -> option C :=
  fun c =>
    match c with
    | acquire _ k => Some k
    | release _ k => Some k
    | _ => None
    end.

(* [Hrel] is related to step indexing levels, and specify that the
PURE of the maps coincide, which is always implied by joinability *)
Variable Hrel : nat -> map -> map -> Prop.
Axiom join_Hrel1 : forall m1 m2 m3 n, join m1 m2 m3 -> Hrel n m3 m1.
Axiom join_Hrel2 : forall m1 m2 m3 n, join m1 m2 m3 -> Hrel n m1 m3.

Inductive safeN_ (at_ext : C -> option ext) : nat -> Z -> C -> map -> Prop :=
    safeN_0 : forall (z : Z) (c : C) (m : map), safeN_ at_ext 0 z c m
  | safeN_step : forall (n : nat) (z : Z) (c c' : C') (m m' : map),
      corestep c m c' m' ->
      safeN_ at_ext n z (normal c') m' ->
      safeN_ at_ext (S n) z (normal c) m
  | safeN_external : forall (n : nat) (z : Z) (c : C) (m : map) (e : ext) (x : ext_type e),
      at_ext c = Some e ->
      Pre e x z m ->
      (forall (m' : map) (z' : Z) (n' : nat),
          n' <= n ->
          Hrel n' m m' ->
          Post e x z' m' ->
          exists c' : C,
            after_external c = Some c' /\
            safeN_ at_ext n' z' c' m') ->
      safeN_ at_ext (S n) z c m.

Lemma safeN_S at_ext n z c m : safeN_ at_ext (S n) z c m -> safeN_ at_ext n z c m.
Proof.
  revert z c m; induction n; intros z c m.
  - intros _. constructor.
  - intros H; inversion H; subst.
    + econstructor; eauto.
    + econstructor; eauto.
Qed.

Lemma strong_nat_ind (P : nat -> Prop) (IH : forall n, (forall i, i < n -> P i) -> P n) n : P n.
Proof.
  apply IH; induction n; intros i li; inversion li; eauto.
Qed.

(*+ Specifications *)

Definition acquire_spec l : ext :=
  mkext
    (nat * (map -> Prop))
    (fun x Ω m =>
       match x with
       | (lx, Rx) =>
         lx = l /\
         islock l Rx m
       end)
    (fun x Ω m =>
       exists m1 m2,
         join m1 m2 m /\
         match x with
         | (lx, Rx) =>
           islock lx Rx m1 /\
           Rx m2
         end).

Definition release_spec l : ext :=
  mkext
    (nat * (map -> Prop))
    (fun x Ω m =>
       exists m1 m2,
         join m1 m2 m /\
         match x with
         | (lx, Rx) =>
           lx = l /\
           islock l Rx m1 /\
           precise Rx /\
           Rx m2
         end)
    (fun x Ω m =>
       match x with
       | (lock, Rx) =>
         islock lock Rx m
       end).

Definition at_ext : C -> option ext :=
  fun c =>
    match c with
    | acquire l _ => Some (acquire_spec l)
    | release l _ => Some (release_spec l)
    | _ => None
    end.

(*+ Concurrent machine *)

(** Semantics of the collection of all threads. Thread and locked
    locks each have their own map. *)

Definition schedule := list nat.

Definition threads := list (map * C).

Definition lockpool := nat -> option (option map).

Definition config := (schedule * threads * lockpool)%type.

Reserved Notation " c1 ===> c2 " (at level 50).

Definition there_is_a_lock_at (m : map) (l : nat) :=
  exists lock,
    m l = Some (inr lock).

Definition map_matches_lock_at (m : map) (l : nat) (mlock : map) :=
  exists lock,
    m l = Some (inr lock) /\
    interp_lock lock mlock.

Inductive machine : config -> config -> Prop :=
  | machine_outofschedule thd pool :
      (nil, thd, pool) ===>
      (nil, thd, pool)
  | machine_scheduleoutofbound i sch thd pool :
      nth thd i = None ->
      (i :: sch, thd, pool) ===>
      (sch, thd, pool)
  | machine_core i sch thd c c' m m' pool :
      corestep c m c' m' ->
      nth thd i = Some (m, normal c) ->
      (i :: sch, thd, pool) ===>
      (i :: sch, nth_upd thd i (m', normal c'), pool)
  | machine_release i sch thd m mlock m' l p pool :
      pool l <> None ->
      nth thd i = Some (m, release l p) ->
      (* mlock |= resinvs l -> *)
      map_matches_lock_at m l mlock ->
      join m' mlock m ->
      (i :: sch, thd, pool) ===>
      (sch, nth_upd thd i (m', p), upd pool l (Some (Some mlock)))
  | machine_acquire_failure i sch thd m l p pool :
      nth thd i = Some (m, acquire l p) ->
      pool l = Some (None) (* locked *) ->
      (i :: sch, thd, pool) ===>
      (sch, thd, pool)
  | machine_acquire_success i sch thd m mlock m' l p pool :
      nth thd i = Some (m, acquire l p) ->
      pool l = Some (Some mlock) (* unlocked *) ->
      join m mlock m' ->
      (i :: sch, thd, pool) ===>
      (i :: sch, nth_upd thd i (m', p), upd pool l (Some None))
where
" c1 ===> c2 " := (machine c1 c2).

Hint Constructors machine.

(*+ Proving machine safety from the invariant *)

Definition reindex (thd:threads) pool : _ -> map :=
  fun x : nat + nat =>
           match x with
           | inl n =>
             match nth thd n with
             | Some (m, _) => m
             | None => emptymap
             end
           | inr n =>
             match pool n with
             | Some (Some m) => m
             | Some None => emptymap
             | None => emptymap
             end
           end.

Definition lockpool_matches_map (pool : lockpool) (Phi : map) :=
  forall l,
    match pool l with
    | Some (Some mlock) => map_matches_lock_at Phi l mlock
    | Some None => there_is_a_lock_at Phi l
    | None => True
    end.

Definition map_matches_lockpool (pool : lockpool) (Phi : map) :=
  forall l lock,
    Phi l = Some (inr lock) ->
    pool l <> None.

Definition invariant n (x : config) :=
  match x with (_, thd, pool) =>
    exists Phi,
      jointo (reindex thd pool) Phi /\
      lockpool_matches_map pool Phi /\
      map_matches_lockpool pool Phi /\
      (forall i oracle m p,
          nth thd i = Some (m, p) ->
          safeN_ at_ext n oracle p m)
  end.

Theorem progress n x : invariant (S n) x -> exists y, x ===> y.
Proof.
  destruct x as (([|i sch], thd), pool). eexists; constructor.
  intros (Phi & J & PM & MP & Safe).
  destruct (nth thd i) as [[m p]|] eqn:E; [ | eauto].
  destruct p as [v c | v c | c].

  - (* Case for acquire *)

    (* The precondition for acquire tells us there is a lock in the
    global map, which means by our invariant that the lock pool has a
    lock there. *)
    pose proof (Safe i tt _ _ E) as Sa.
    inversion Sa as [ | | n0 z c0 m0 ex x atex PRE POST]; subst.
    inversion atex; subst.
    destruct x as [vx Rx].
    simpl in PRE.
    destruct PRE as (-> & isl).
    specialize (MP v).
    destruct isl as [lock [Ev At]].
    assert (EPhiv : Phi v = Some (inr lock)). {
      eapply jointo_Some with (a := inl i); eauto.
      simpl. rewrite E; auto.
    }
    specialize (MP lock EPhiv).
    destruct (pool v) as [ [ mlock | ] | ] eqn:Epoolv; [ | | congruence ].

    + (* In the case the lock is unlocked, [acquire] succeeds *)
      apply jointo_selfjoins in J.
      destruct (J (inl i) (inr v)) as [m' J']. congruence.
      simpl in J'. rewrite E in J'. rewr (pool v) in J'.
      eexists.
      eapply machine_acquire_success.
      now apply E.
      now apply Epoolv.
      now apply J'.

    + (* In the case the lock is locked, [acquire] fails *)
      eexists.
      eapply machine_acquire_failure. now apply E.
      assumption.

  - (* Case for release *)

    (* To determine the next state, we need to use [release]'s
    precondition which provides one possible subheap [m2] of the
    thread's heap.  (By [release]'s precondition, we also know that
    this subheap is unique, which will be useful in the preservation
    theorem.) *)
    pose proof (Safe i tt _ _ E) as Sa.
    inversion Sa as [ | | n0 z c0 m0 ex x atex PRE POST]; subst.
    inversion atex; subst.
    destruct x as [vx Rx].
    simpl in PRE.
    destruct PRE as (m1 & m2 & J12 & -> & isl & Rm2).

    (* Using this [m2] we prove that the global map, we prove that the
    lock pool indeed has a lock there. *)
    specialize (MP v).
    destruct isl as [lock [Ev At]].
    pose proof (J12 v) as J12v.
    rewr (m1 v) in J12v. destruct (m2 v); inversion J12v.
    assert (EPhiv : Phi v = Some (inr lock)). {
      eapply jointo_Some with (a := inl i); eauto.
      simpl. rewrite E. auto.
    }
    simpl.
    specialize (MP lock EPhiv).

    (* We now can apply the release machine step *)
    eexists.
    match goal with |- _ ===> ?y => pose y end.
    eapply machine_release; [ apply MP | apply E | .. ].
    + unfold map_matches_lock_at.
      exists lock. split; auto.
      subst Rx.
      apply Rm2.
    + apply J12.

  - (* Case for corestep *)
    pose proof (Safe i tt _ _ E) as Sa.
    inversion Sa; subst.
    + eexists; eapply machine_core; eassumption.
    + discriminate.

Qed.

Theorem preservation n x y : x ===> y -> invariant (S n) x -> invariant n y.
Proof.
  destruct x as (([|i sch], thd), pool);
    intros xy; inversion xy; subst; intros (Phi & J & PM & MP & Sa); simpl fst in *; simpl snd in *.
  - (* out of schedule *)
    hnf; intuition; eauto.
    exists Phi; intuition.
    eapply safeN_S.
    eapply Sa; eauto.

  - (* schedule out of bound *)
    hnf; intuition; eauto.
    exists Phi; intuition.
    eapply safeN_S.
    eapply Sa; eauto.

  - (* Case of a corestep *)
    assert (SJ : selfjoins (reindex (nth_upd thd i (m', normal c')) pool)). {
      apply jointo_selfjoins in J.
      eapply selfjoins_sameperms_compat; [..|apply J]; intros [k|]; simpl; eauto.
      erewrite nth_nth_upd; [|eassumption].
      ifeq; subst; auto.
      rewr (nth thd k).
      eapply corestep_sameperms; eassumption.
    }
    apply selfjoins_jointo in SJ.
    destruct SJ as [Phi' J'].
    exists Phi'.
    repeat split; auto.
    + intros l. specialize (PM l).
      destruct (pool l) as [[mlock|]|].
      * destruct PM as [lock [E asd]].
        exists lock; intuition.
        {
          destruct (jointo_Some_inv _ _ _ _ J E) as [ [x | x] Ex ]; simpl in Ex.
          - destruct (nth thd x) as [[m0 c0] | ] eqn:Emx.
            + destruct (eq_nat_dec i x).
              * subst x. assert (m0 = m) by congruence; subst m0.
                eapply (jointo_Some _ _ (inl i)). eassumption.
                simpl; erewrite nth_nth_upd; eauto.
                ifeq; eauto.
                rewrite <-corestep_samelocks; eauto.
              * eapply (jointo_Some _ _ (inl x)). eassumption. simpl.
                erewrite nth_nth_upd. ifeq. tauto. rewrite Emx. auto. eauto.
            + inversion Ex.
          - eapply (jointo_Some _ _ (inr x)). eassumption. simpl. auto.
        }
      * destruct PM as [lock E].
        exists lock; intuition.
        {
          destruct (jointo_Some_inv _ _ _ _ J E) as [ [x | x] Ex ]; simpl in Ex.
          - destruct (nth thd x) as [[m0 c0] | ] eqn:Emx.
            + destruct (eq_nat_dec i x).
              * subst x. assert (m0 = m) by congruence; subst m0.
                eapply (jointo_Some _ _ (inl i)). eassumption.
                simpl; erewrite nth_nth_upd; eauto.
                ifeq; eauto.
                rewrite <-corestep_samelocks; eauto.
              * eapply (jointo_Some _ _ (inl x)). eassumption. simpl.
                erewrite nth_nth_upd. ifeq. tauto. rewrite Emx. auto. eauto.
            + inversion Ex.
          - eapply (jointo_Some _ _ (inr x)). eassumption. simpl. auto.
        }
      * auto.
    + intros l lock AT. apply (MP _ lock).
      destruct (jointo_Some_inv _ _ _ _ J' AT) as [ [ x | x ] Ex ]; simpl in Ex.
      * erewrite nth_nth_upd in Ex; [ | eassumption ].
        {
          destruct (nth thd x) as [[m0 c0] | ] eqn:Emx.
          - destruct (eq_nat_dec i x).
            + subst x. assert (m0 = m) by congruence; subst m0.
              eapply (jointo_Some _ _ (inl i)). eassumption.
              simpl. rewr (nth thd i).
              revert Ex.
              match goal with |- ?P -> ?Q => cut (Q <-> P); [ intuition | ] end.
              eapply corestep_samelocks. eauto.
            + eapply (jointo_Some _ _ (inl x)). eassumption. simpl.
              rewr (nth thd x) in *. auto.
          - destruct (eq_nat_dec i x).
            + congruence.
            + inversion Ex.
        }
      * eapply (jointo_Some _ _ (inr x)). eassumption. simpl. auto.
    + intros j oracle; specialize (Sa j oracle).
      erewrite nth_nth_upd; [|eassumption].
      ifeq; subst; auto.
      * specialize (Sa _ _ H5).
        intros. rewr.
        intros <- <- .
        inversion Sa; subst. 2:inversion H1.
        destruct (corestep_fun _ _ _ _ _ _ H4 H2) as [<- <-].
        assumption.
      * intros; apply safeN_S; eauto.

  - (* Case of release *)
    exists Phi. intuition.
    + (* First, we prove joinability *)
      assert (Empl : match pool l with None => False | Some None => True | Some (Some ml) => empty ml end). {
        destruct (pool l) as [[ml|]|] eqn:E; auto.
        cut (empty ml /\ empty mlock);[intuition|].
        destruct H6 as [lock [Eml SAT]].

        (* We need preciseness, which we get it thanks to the precondition *)
        assert (PR : precise (interp_lock lock)). {
          specialize (Sa i tt _ _ H5).
          inversion Sa as [ | | n0 z c m0 ex x ae PRE POST]; subst.
          assert (A:Hrel n m m') by (eapply join_Hrel1; eauto).
          inversion ae; subst.
          destruct x as [vx Rx].
          destruct PRE as (m1 & m2 & J12 & -> & isl & PreciseRx & Rm2).
          destruct isl as [lock' [Em1l <-]].
          assert (m l = Some (inr lock')). {
            specialize (J12 l).
            rewrite Em1l in *.
            simpl in J12.
            destruct (m2 l); congruence.
          }
          replace lock' with lock in * by congruence.
          assumption.
        }

        apply precise_join with (interp_lock lock); eauto.
        - specialize (PM l); rewrite E in PM; auto.
          hnf in PM.
          destruct PM as [lock' [El SAT']].
          assert (lock = lock'). {
            assert (Phi l = Some (inr lock)). {
              eapply jointo_Some with (a := inl i); eauto; simpl.
              rewr (nth thd i). auto.
            }
            congruence.
          }
          subst lock'.
          apply SAT'.
        - assert (D:inl i <> inr l) by congruence.
          apply jointo_selfjoins in J.
          specialize (J _ _ D); simpl in J.
          rewr (nth thd i) in J.
          rewr (pool l) in J.
          pose proof (join_joins_distrib m' mlock m H7 ml); intuition eauto.
      }
      eapply (jointo_swapped natnateqdec (inl i) (inr l) Phi); [ .. | eapply J].
      * unfold swapped, reindex, upd; repeat split.
        {
          intros [|] a b; [ | ifeq ].
          - erewrite nth_nth_upd;[|eassumption].
            ifeq; congruence.
          - subst. tauto.
          - destruct (pool n); reflexivity.
        }
      * apply join_empty; simpl.
        destruct (pool l) as [[ml|]|]; unfold empty; auto.
      * erewrite nth_nth_upd;[|eassumption].
        ifeq; ifeq.
        rewr; eauto.
    + intros k; unfold upd; ifeq; subst; auto.
      * hnf.
        destruct H6 as [lock [El SAT]].
        exists lock; intuition.
        eapply jointo_Some with (a := inl i); eauto; simpl.
        rewr (nth thd i). auto.
      * specialize (PM k); auto.
    + intros k lock Ek. unfold upd; ifeq.
      * congruence.
      * apply (MP k lock Ek).
    + erewrite nth_nth_upd in H. 2:eassumption.
      ifeq; [ | apply safeN_S; eapply Sa; eauto ].
      subst i0.
      specialize (Sa i tt _ _ H5). injection H as <- <-.
      inversion Sa as [ | | n0 z c m0 ex x ae PRE POST]; subst.
      assert (A:Hrel n m m') by (eapply join_Hrel1; eauto).
      specialize (POST m' oracle n (le_n _) A).
      destruct POST as [c' [E Sa']].
      * inversion ae; subst.
        destruct x as [vx Rx].
        simpl in PRE |- *.
        destruct PRE as (m1 & m2 & J12 & E & isl & PreciseRx & Rm2).
        intuition.
        subst.
        (* Here, we need preciseness in the specification of release *)
        assert (m2 = mlock). {
          apply eqmap_eq.
          eapply PreciseRx; auto.
          - destruct H6 as [lock [Eml SAT]].
            destruct isl as [lock' [Em1l' <-]].
            assert (m l = Some (inr lock')). {
              eapply join_Some; eauto.
            }
            replace lock' with lock in * by congruence.
            auto.
          - exists m1. apply join_comm. apply J12.
          - exists m'. apply join_comm. assumption.
        }
        subst m2.
        assert (m' = m1) by (eapply cancellative; eauto).
        congruence.
      * inversion ae; subst.
        inversion E; subst.
        apply Sa'.

  - (* acquire (locked) *)
    exists Phi; intuition.
    apply safeN_S.
    eapply Sa; eauto.

  - (* acquire (unlocked) *)
    exists Phi; intuition.
    + eapply (jointo_swapped natnateqdec (inl i) (inr l) Phi); [ .. | apply J].
      * unfold swapped, reindex, upd; repeat split.
        intros [|] a b; try (ifeq; (congruence || subst; tauto)).
        erewrite nth_nth_upd;[|eassumption].
        ifeq; congruence.
      * rewr. rewr. eauto.
      * rewr. ifeq.
        erewrite nth_nth_upd;[|eassumption].
        ifeq. auto.
    + intros k; unfold upd; ifeq; subst; auto.
      * specialize (PM k). rewr (pool k) in PM. destruct PM as [lock []]; exists lock. assumption.
      * apply (PM k).
    + intros k lock Ek. unfold upd; ifeq.
      * subst k. specialize (PM l). congruence.
      * apply (MP k lock Ek).
    + erewrite nth_nth_upd in H. 2:eassumption.
      ifeq; [ | now apply safeN_S; eapply Sa; eauto ].
      subst i0.
      injection H as <- <-.
      specialize (Sa _ tt _ _ H4).
      inversion Sa as [ | | n0 z c m0 ex x ae PRE POST]; subst.
      assert (A:Hrel n m m') by (eapply join_Hrel2; eauto).
      specialize (POST m' oracle n (le_n _) A).
      destruct POST as [c' [E Sa']].
      * inversion ae; subst.
        destruct x as [vx Rx].
        simpl in PRE |- *.
        destruct PRE as [-> isl].
        exists m, mlock; intuition.
        destruct isl as [lock [Eml <-]].
        specialize (PM l). rewr (pool l) in PM.
        destruct PM as [lock' [E' SAT]].
        assert (Phi l = Some (inr lock)). {
          eapply jointo_Some with (a := inl i); eauto; simpl.
          rewr (nth thd i). auto.
        }
        congruence.
      * inversion ae; subst.
        inversion E; subst.
        apply Sa'.
Qed.

Inductive csafe : nat -> config -> Prop :=
| csafe_0 sch thd pool : csafe 0 (sch, thd, pool)
| csafe_halted n thd pool : csafe n (nil, thd, pool)
| csafe_core n sch thd pool thd' pool' :
    machine (sch, thd, pool) (sch, thd', pool') ->
    csafe n (sch, thd', pool') ->
    csafe (S n) (sch, thd, pool)
| csafe_sch n i sch thd pool thd' pool' :
    machine (i :: sch, thd, pool) (sch, thd', pool') ->
    (forall sch', csafe n (sch', thd', pool')) ->
    csafe (S n) (i :: sch, thd, pool).

Lemma safety_invariant n state :
  invariant n state -> csafe n state.
Proof.
  assert (forall n s s' t p, invariant n (s, t, p) -> invariant n (s', t, p))
    by (clear; intros n s s' t p (Phi & J & PM & MP & Safe); exists Phi; intuition).
  revert state; induction n; intros ((sch, thd), pool) Inv.
  now constructor.
  destruct (progress _ _ Inv) as (x, step).
  assert (pre : forall y, (sch, thd, pool) ===> y -> invariant n y)
    by (intros; eapply preservation; eauto).
  inversion Inv as (Phi & J & PM & MP & Safe).
  inversion step; subst.
  - constructor.
  - eapply csafe_sch; [ now eapply step | ]; eauto.
  - eapply csafe_core; eauto.
  - eapply csafe_sch; [ now eapply step | ]; eauto.
  - eapply csafe_sch; [ now eapply step | ]; eauto.
  - eapply csafe_core; eauto.
Qed.