Set Implicit Arguments.
Set Bullet Behavior "Strict Subproofs".

Require Import String Lists.List.
Import ListNotations.
Open Scope string.
Open Scope list.
From Utils Require Import Utils.
From Pyrosome Require Import Core.

(*TODO: should this be split differently? Model_ok for core should be in Core.v*)
Section WithVar.
  Context (V : Type)
          {V_Eqb : Eqb V}
          {V_Eqb_ok : Eqb_ok V_Eqb}
          {V_default : WithDefault V}.

  Section WithLang.
    Context (l : lang V)
            (wfl : wf_lang l).
    Notation core_model := (core_model l).

    (*TODO: reorder fields on Model_ok to match core Inductives? *)
    Instance core_model_ok : Model_ok core_model :=
      {
        term_substable_ok := substable_term_ok (V:=V);
        sort_substable_ok := substable_sort_ok (V:=V);
        eq_sort_subst := ltac:(intros; eapply eq_sort_subst with (l:=l); eassumption);
        eq_sort_refl := eq_sort_refl (l:=l);
        eq_sort_trans := eq_sort_trans (l:=l);
        eq_sort_sym := eq_sort_sym (l:=l);
        eq_term_subst := ltac:(intros; eapply eq_term_subst with (l:=l); eassumption);
        eq_term_refl := eq_term_refl (l:=l);
        eq_term_trans := eq_term_trans (l:=l);
        eq_term_sym := eq_term_sym (l:=l);
        eq_term_conv := ltac:(intros; eapply eq_term_conv with (l:=l); eassumption);
        wf_term_conv := wf_term_conv (l:=l);
        wf_term_var := wf_term_var l;
        wf_sort_subst_monotonicity := wf_sort_subst_monotonicity wfl;
        wf_term_subst_monotonicity := wf_term_subst_monotonicity wfl;
        wf_sort_implies_ws := wf_sort_implies_ws ltac:(eauto with lang_core);
        wf_term_implies_ws := wf_term_implies_ws ltac:(eauto with lang_core);
      }.

  End WithLang.

  (*TODO: implement (is this defined in multicompilers.v?*)
  Axiom Eqb_list :forall {A}, Eqb A -> Eqb (list A).
  Existing Instance Eqb_list.

  Section Multicompilers.
    Context (l : lang (list V))
            (wfl : wf_lang l).

    Context (fn_names : list V).

    Notation named_list := (@named_list (list V)).
    Notation named_map := (@named_map (list V)).
    Notation term := (@term (list V)).
    Notation var := (@var (list V)).
    Notation con := (@con (list V)).
    Notation ctx := (@ctx (list V)).
    Notation sort := (@sort (list V)).
    Notation subst := (@subst (list V)).
    Notation rule := (@rule (list V)).
    Notation lang := (@lang (list V)).

    Notation Model := (@Model (list V) (list term) (list sort)).

    Let arity := length fn_names.

    Definition flatten_ctx : named_list (list sort) -> ctx :=
      flat_map (fun '(n,t) =>
                  map (fun '(fn, t) =>(fn::n,t)) (combine fn_names t)).

    (*TODO: double check this*)
    Fixpoint split_subst (s : named_list (list term)) : list (named_list term) :=
      match s with
      | [] => repeat [] arity
      | (n,e)::s =>
          map (fun '(e,s) => (n,e)::s) (combine e (split_subst s))
      end.

    Definition expand_args : list (list V) -> list (list V) :=
      flat_map (fun n =>
                  map (fun fn =>fn::n) fn_names).

    Instance list_term_subst : Substable0 (list V) (list term) :=
      {
        inj_var x := map (fun n => var (n::x)) fn_names;
        apply_subst0 s e := map (fun '(e,s) => e[/s/]) (combine e (split_subst s));
        well_scoped0 args e :=
        length e = arity /\
          all (well_scoped (expand_args args))  e
      }.

    (* TODO
    Instance list_term_subst_ok : Substable0_ok (list term).
    Proof.
      constructor.
      all: basic_goal_prep; basic_core_crush.
      {
        unfold Substable.subst_lookup.
        induction s;
          basic_goal_prep; basic_term_crush.
        {
          subst arity.
          induction fn_names;
            basic_goal_prep; basic_term_crush.
        }
        {
          case_match;
          basic_utils_crush.
        }
        simpl.

      }
      {
        inj_var x := map (fun n => var (n::x)) fn_names;
        apply_subst0 s e := map (fun '(e,s) => e[/s/]) (combine e (split_subst s));
        well_scoped0 args e :=
        length e = arity /\
          all (well_scoped (expand_args args))  e
      }.

    Instance list_sort_subst : Substable (list term) (list sort) :=
      {
        apply_subst s t := map (fun '(t,s) => t[/s/]) (combine t (split_subst s));
        well_scoped args t :=
        length t = arity /\
          all (well_scoped (expand_args args))  t
      }.

    (* TODO: move to Utils.v
       TODO: use this or all3?
     *)
    Inductive Forall3 (A B C : Type) (R : A -> B -> C -> Prop)
      : list A -> list B -> list C -> Prop :=
    | Forall3_nil : Forall3 R [] [] []
    | Forall3_cons : forall (x : A) (y : B) (z : C)
                            (l : list A) (l' : list B) (l'' : list C),
        R x y z -> Forall3 R l l' l'' -> Forall3 R (x :: l) (y :: l') (z :: l'').

     Instance multi_model : Model :=
      {
        term_substable := list_term_subst;
        sort_substable := list_sort_subst;
        eq_sort c t1 t2 :=
        (length t1 = arity) /\
          (length t2 = arity) /\
          (Forall2 (eq_sort l (flatten_ctx c)) t1 t2);
        eq_term c t e1 e2 :=
        (length t = arity) /\
          (length e1 = arity) /\
          (length e2 = arity) /\
          (Forall3 (eq_term l (flatten_ctx c)) t e1 e2);
        wf_sort c t :=
        (length t = arity) /\
          (Forall (wf_sort l (flatten_ctx c)) t);
        wf_term c e t :=
        (length e = arity) /\
        (length t = arity) /\
          (Forall2 (wf_term l (flatten_ctx c)) e t);
      }.

    Instance multi_model_ok : Model_ok multi_model.
    constructor.
    -
    try typeclasses eauto.

    Qed.
      :=
      {
        term_substable_ok := substable_term_ok (V:=V);
        sort_substable_ok := substable_sort_ok (V:=V);
        eq_sort_subst := eq_sort_subst (l:=l);
        eq_sort_refl := eq_sort_refl (l:=l);
        eq_sort_trans := eq_sort_trans (l:=l);
        eq_sort_sym := eq_sort_sym (l:=l);
        eq_term_subst := eq_term_subst (l:=l);
        eq_term_refl := eq_term_refl (l:=l);
        eq_term_trans := eq_term_trans (l:=l);
        eq_term_sym := eq_term_sym (l:=l);
        eq_term_conv := eq_term_conv (l:=l);
        wf_term_conv := wf_term_conv (l:=l);
        wf_term_var := wf_term_var l;
        wf_sort_subst_monotonicity := wf_sort_subst_monotonicity wfl;
        wf_term_subst_monotonicity := wf_term_subst_monotonicity wfl;
        wf_sort_implies_ws := wf_sort_implies_ws ltac:(eauto with lang_core);
        wf_term_implies_ws := wf_term_implies_ws ltac:(eauto with lang_core);
      }.
     *)

    End Multicompilers.

  End WithVar.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.
Require Import TableAux.Spec.

Local Open Scope Z_scope.

Section SpecLow.

  Fixpoint table_walk_lock_unlock_loop0 (n: nat) (l: Z) (tbl: Pointer) (last_tbl: Pointer) (map_addr: Z) (adt: RData) :=
    match n with
    | O => Some (l, tbl, last_tbl, adt)
    | S n' =>
      match table_walk_lock_unlock_loop0 n' l tbl last_tbl map_addr adt with
      | Some (l, tbl, last_tbl, adt) =>
        rely is_int l;
        when null == is_null_spec tbl adt;
        rely is_int null;
        if null =? 0 then
          when' idx == addr_to_idx_spec (VZ64 map_addr) (VZ64 l) adt;
          rely is_int64 idx;
          when tbl, adt == find_next_level_idx_spec tbl (VZ64 idx) adt;
          when null == is_null_spec tbl adt;
          rely is_int null;
          if null =? 0 then
            when adt == granule_lock_spec tbl adt;
            when adt == granule_unlock_spec last_tbl adt;
            Some (l + 1, tbl, tbl, adt)
          else
            when adt == granule_unlock_spec last_tbl adt;
            Some (l + 1, tbl, last_tbl, adt)
        else Some (l + 1, tbl, last_tbl, adt)
      | _ => None
      end
    end.

  Definition table_walk_lock_unlock_spec0 (g_rd: Pointer) (map_addr: Z64) (level: Z64) (adt: RData) : option RData :=
    match map_addr, level with
    | VZ64 map_addr, VZ64 level =>
      when rd, adt == granule_map_spec g_rd SLOT_RD adt;
      when g_root == get_rd_g_rtt_spec rd adt;
      when adt == buffer_unmap_spec rd adt;
      when adt == granule_lock_spec g_root adt;
      match table_walk_lock_unlock_loop0 (Z.to_nat level) 0 g_root g_root map_addr adt with
      | Some (l, tbl, last_tb, adt) =>
        rely is_int l;
        when adt == set_wi_g_llt_spec tbl adt;
        when' idx == addr_to_idx_spec (VZ64 map_addr) (VZ64 level) adt;
        rely is_int64 idx;
        when adt == set_wi_index_spec (VZ64 idx) adt;
        Some adt
      | _ => None
      end
    end.

End SpecLow.


From isla Require Import opsem.

Definition a7408 : isla_trace :=
  Smt (DeclareConst 49%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "R0" [] (RegVal_Base (Val_Symbolic 49%Z)) Mk_annot :t:
  Smt (DefineConst 50%Z (Val (Val_Symbolic 49%Z) Mk_annot)) Mk_annot :t:
  Smt (DefineConst 73%Z (Manyop (Bvmanyarith Bvor) [Val (Val_Bits (BV 64%N 0x0%Z)) Mk_annot; Manyop (Bvmanyarith Bvand) [Manyop (Bvmanyarith Bvor) [Val (Val_Bits (BV 64%N 0x0%Z)) Mk_annot; Manyop (Bvmanyarith Bvand) [Manyop (Bvmanyarith Bvor) [Binop ((Bvarith Bvlshr)) (Val (Val_Symbolic 50%Z) Mk_annot) (Val (Val_Bits (BV 64%N 0x1a%Z)) Mk_annot) Mk_annot; Binop ((Bvarith Bvshl)) (Val (Val_Symbolic 50%Z) Mk_annot) (Val (Val_Bits (BV 64%N 0x26%Z)) Mk_annot) Mk_annot] Mk_annot; Val (Val_Bits (BV 64%N 0xffffffffffffffff%Z)) Mk_annot] Mk_annot] Mk_annot; Val (Val_Bits (BV 64%N 0x3fffffffff%Z)) Mk_annot] Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "R0" [] (RegVal_Base (Val_Symbolic 73%Z)) Mk_annot :t:
  Smt (DeclareConst 74%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "_PC" [] (RegVal_Base (Val_Symbolic 74%Z)) Mk_annot :t:
  Smt (DefineConst 75%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 74%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "_PC" [] (RegVal_Base (Val_Symbolic 75%Z)) Mk_annot :t:
  tnil
.


From iris_logrel.F_mu_ref_conc Require Export lang.

Inductive type :=
  | TUnit : type
  | TNat : type
  | TBool : type
  | TProd : type → type → type
  | TSum : type → type → type
  | TArrow : type → type → type
  | TRec (τ : {bind 1 of type})
  | TVar (x : var)
  | TForall (τ : {bind 1 of type})
  | Tref (τ : type).

Instance Ids_type : Ids type. derive. Defined.
Instance Rename_type : Rename type. derive. Defined.
Instance Subst_type : Subst type. derive. Defined.
Instance SubstLemmas_typer : SubstLemmas type. derive. Qed.

Fixpoint binop_res_type (op : binop) : type :=
  match op with
  | Add => TNat | Sub => TNat
  | Eq => TBool | Le => TBool | Lt => TBool
  end.

Inductive EqType : type → Prop :=
  | EqTUnit : EqType TUnit
  | EqTNat : EqType TNat
  | EqTBool : EqType TBool
  | EqTProd τ τ' : EqType τ → EqType τ' → EqType (TProd τ τ')
  | EqSum τ τ' : EqType τ → EqType τ' → EqType (TSum τ τ').

Reserved Notation "Γ ⊢ₜ e : τ" (at level 74, e, τ at next level).

Inductive typed (Γ : list type) : expr → type → Prop :=
  | Var_typed x τ : Γ !! x = Some τ → Γ ⊢ₜ Var x : τ
  | Unit_typed : Γ ⊢ₜ Unit : TUnit
  | Nat_typed n : Γ ⊢ₜ #n n : TNat
  | Bool_typed b : Γ ⊢ₜ #♭ b : TBool
  | BinOp_typed op e1 e2 :
     Γ ⊢ₜ e1 : TNat → Γ ⊢ₜ e2 : TNat → Γ ⊢ₜ BinOp op e1 e2 : binop_res_type op
  | Pair_typed e1 e2 τ1 τ2 : Γ ⊢ₜ e1 : τ1 → Γ ⊢ₜ e2 : τ2 → Γ ⊢ₜ Pair e1 e2 : TProd τ1 τ2
  | Fst_typed e τ1 τ2 : Γ ⊢ₜ e : TProd τ1 τ2 → Γ ⊢ₜ Fst e : τ1
  | Snd_typed e τ1 τ2 : Γ ⊢ₜ e : TProd τ1 τ2 → Γ ⊢ₜ Snd e : τ2
  | InjL_typed e τ1 τ2 : Γ ⊢ₜ e : τ1 → Γ ⊢ₜ InjL e : TSum τ1 τ2
  | InjR_typed e τ1 τ2 : Γ ⊢ₜ e : τ2 → Γ ⊢ₜ InjR e : TSum τ1 τ2
  | Case_typed e0 e1 e2 τ1 τ2 τ3 :
     Γ ⊢ₜ e0 : TSum τ1 τ2 → τ1 :: Γ ⊢ₜ e1 : τ3 → τ2 :: Γ ⊢ₜ e2 : τ3 →
     Γ ⊢ₜ Case e0 e1 e2 : τ3
  | If_typed e0 e1 e2 τ :
     Γ ⊢ₜ e0 : TBool → Γ ⊢ₜ e1 : τ → Γ ⊢ₜ e2 : τ → Γ ⊢ₜ If e0 e1 e2 : τ
  | Rec_typed e τ1 τ2 :
     TArrow τ1 τ2 :: τ1 :: Γ ⊢ₜ e : τ2 → Γ ⊢ₜ Rec e : TArrow τ1 τ2
  | App_typed e1 e2 τ1 τ2 :
     Γ ⊢ₜ e1 : TArrow τ1 τ2 → Γ ⊢ₜ e2 : τ1 → Γ ⊢ₜ App e1 e2 : τ2
  | TLam_typed e τ :
     subst (ren (+1)) <$> Γ ⊢ₜ e : τ → Γ ⊢ₜ TLam e : TForall τ
  | TApp_typed e τ τ' : Γ ⊢ₜ e : TForall τ → Γ ⊢ₜ TApp e : τ.[τ'/]
  | TFold e τ : Γ ⊢ₜ e : τ.[TRec τ/] → Γ ⊢ₜ Fold e : TRec τ
  | TUnfold e τ : Γ ⊢ₜ e : TRec τ → Γ ⊢ₜ Unfold e : τ.[TRec τ/]
  | TFork e : Γ ⊢ₜ e : TUnit → Γ ⊢ₜ Fork e : TUnit
  | TAlloc e τ : Γ ⊢ₜ e : τ → Γ ⊢ₜ Alloc e : Tref τ
  | TLoad e τ : Γ ⊢ₜ e : Tref τ → Γ ⊢ₜ Load e : τ
  | TStore e e' τ : Γ ⊢ₜ e : Tref τ → Γ ⊢ₜ e' : τ → Γ ⊢ₜ Store e e' : TUnit
  | TCAS e1 e2 e3 τ :
     EqType τ → Γ ⊢ₜ e1 : Tref τ → Γ ⊢ₜ e2 : τ → Γ ⊢ₜ e3 : τ →
     Γ ⊢ₜ CAS e1 e2 e3 : TBool
where "Γ ⊢ₜ e : τ" := (typed Γ e τ).

Lemma typed_subst_invariant Γ e τ s1 s2 :
  Γ ⊢ₜ e : τ → (∀ x, x < length Γ → s1 x = s2 x) → e.[s1] = e.[s2].
Proof.
  intros Htyped; revert s1 s2.
  assert (∀ x Γ, x < length (subst (ren (+1)) <$> Γ) → x < length Γ).
  { intros ??. by rewrite fmap_length. }
  assert (∀ {A} `{Ids A} `{Rename A} (s1 s2 : nat → A) x,
    (x ≠ 0 → s1 (pred x) = s2 (pred x)) → up s1 x = up s2 x).
  { intros A H1 H2. rewrite /up=> s1 s2 [|x] //=; auto with f_equal omega. }
  induction Htyped => s1 s2 Hs; f_equal/=; eauto using lookup_lt_Some with omega.
Qed.
Lemma n_closed_invariant n (e : expr) s1 s2 :
  (∀ f, e.[upn n f] = e) → (∀ x, x < n → s1 x = s2 x) → e.[s1] = e.[s2].
Proof.
  intros Hnc. specialize (Hnc (ren (+1))).
  revert n Hnc s1 s2.
  induction e => m Hmc s1 s2 H1; asimpl in *; try f_equal;
    try (match goal with H : _ |- _ => eapply H end; eauto;
         try inversion Hmc; try match goal with H : _ |- _ => by rewrite H end;
         fail).
  - apply H1. rewrite iter_up in Hmc. destruct lt_dec; try omega.
    asimpl in *. cbv in x. replace (m + (x - m)) with x in Hmc by omega.
    inversion Hmc; omega.
  - unfold upn in *.
    change (e.[up (up (upn m (ren (+1))))]) with
    (e.[iter (S (S m)) up (ren (+1))]) in *.
    apply (IHe (S (S m))).
    + inversion Hmc; match goal with H : _ |- _ => (by rewrite H) end.
    + intros [|[|x]] H2; [by cbv|by cbv |].
      asimpl; rewrite H1; auto with omega.
  - change (e1.[up (upn m (ren (+1)))]) with
    (e1.[iter (S m) up (ren (+1))]) in *.
    apply (IHe0 (S m)).
    + inversion Hmc; match goal with H : _ |- _ => (by rewrite H) end.
    + intros [|x] H2; [by cbv |].
      asimpl; rewrite H1; auto with omega.
  - change (e2.[up (upn m (ren (+1)))]) with
    (e2.[upn (S m) (ren (+1))]) in *.
    apply (IHe1 (S m)).
    + inversion Hmc; match goal with H : _ |- _ => (by rewrite H) end.
    + intros [|x] H2; [by cbv |].
      asimpl; rewrite H1; auto with omega.
Qed.

Definition env_subst (vs : list val) (x : var) : expr :=
  from_option id (Var x) (of_val <$> vs !! x).

Lemma typed_n_closed Γ τ e : Γ ⊢ₜ e : τ → (∀ f, e.[upn (length Γ) f] = e).
Proof.
  intros H. induction H => f; asimpl; simpl in *; auto with f_equal.
  - apply lookup_lt_Some in H. rewrite iter_up. destruct lt_dec; auto with omega.
  - f_equal. apply IHtyped.
  - by f_equal; rewrite map_length in IHtyped.
Qed.

Lemma n_closed_subst_head_simpl n e w ws :
  (∀ f, e.[upn n f] = e) →
  S (length ws) = n →
  e.[of_val w .: env_subst ws] = e.[env_subst (w :: ws)].
Proof.
  intros H1 H2.
  rewrite /env_subst. eapply n_closed_invariant; eauto=> /= -[|x] ? //=.
  destruct (lookup_lt_is_Some_2 ws x) as [v' Hv]; first omega; simpl.
  by rewrite Hv.
Qed.

Lemma typed_subst_head_simpl Δ τ e w ws :
  Δ ⊢ₜ e : τ → length Δ = S (length ws) →
  e.[of_val w .: env_subst ws] = e.[env_subst (w :: ws)].
Proof. eauto using n_closed_subst_head_simpl, typed_n_closed. Qed.

Lemma n_closed_subst_head_simpl_2 n e w w' ws :
  (∀ f, e.[upn n f] = e) → (S (S (length ws))) = n →
  e.[of_val w .: of_val w' .: env_subst ws] = e.[env_subst (w :: w' :: ws)].
Proof.
  intros H1 H2.
  rewrite /env_subst. eapply n_closed_invariant; eauto => /= -[|[|x]] H3 //=.
  destruct (lookup_lt_is_Some_2 ws x) as [v' Hv]; first omega; simpl.
  by rewrite Hv.
Qed.

Lemma typed_subst_head_simpl_2 Δ τ e w w' ws :
  Δ ⊢ₜ e : τ → length Δ = 2 + length ws →
  e.[of_val w .: of_val w' .: env_subst ws] = e.[env_subst (w :: w' :: ws)].
Proof. eauto using n_closed_subst_head_simpl_2, typed_n_closed. Qed.

Lemma empty_env_subst e : e.[env_subst []] = e.
Proof. change (env_subst []) with (@ids expr _). by asimpl. Qed.

(** Weakening *)
Lemma context_gen_weakening ξ Γ' Γ e τ :
  Γ' ++ Γ ⊢ₜ e : τ →
  Γ' ++ ξ ++ Γ ⊢ₜ e.[upn (length Γ') (ren (+ (length ξ)))] : τ.
Proof.
  intros H1.
  remember (Γ' ++ Γ) as Ξ. revert Γ' Γ ξ HeqΞ.
  induction H1 => Γ1 Γ2 ξ HeqΞ; subst; asimpl in *; eauto using typed.
  - rewrite iter_up; destruct lt_dec as [Hl | Hl].
    + constructor. rewrite lookup_app_l; trivial. by rewrite lookup_app_l in H.
    + asimpl. constructor. rewrite lookup_app_r; auto with omega.
      rewrite lookup_app_r; auto with omega.
      rewrite lookup_app_r in H; auto with omega.
      match goal with
        |- _ !! ?A = _ => by replace A with (x - length Γ1) by omega
      end.
  - econstructor; eauto. by apply (IHtyped2 (_::_)). by apply (IHtyped3 (_::_)).
  - constructor. by apply (IHtyped (_ :: _ :: _)).
  - constructor.
    specialize (IHtyped
      (subst (ren (+1)) <$> Γ1) (subst (ren (+1)) <$> Γ2) (subst (ren (+1)) <$> ξ)).
    asimpl in *. rewrite ?map_length in IHtyped.
    repeat rewrite fmap_app. apply IHtyped.
    by repeat rewrite fmap_app.
Qed.

Lemma context_weakening ξ Γ e τ :
  Γ ⊢ₜ e : τ → ξ ++ Γ ⊢ₜ e.[(ren (+ (length ξ)))] : τ.
Proof. eapply (context_gen_weakening _ []). Qed.

Lemma closed_context_weakening ξ Γ e τ :
  (∀ f, e.[f] = e) → Γ ⊢ₜ e : τ → ξ ++ Γ ⊢ₜ e : τ.
Proof. intros H1 H2. erewrite <- H1. by eapply context_weakening. Qed.


(* (c) Copyright 2006-2018 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat seq.
From fourcolor Require Import cfmap cfreducible configurations.

(******************************************************************************)
(* Reducibility of configurations number 1 to 106, whose indices in           *)
(* the_configs range over segment [0, 106).                                   *)
(******************************************************************************)

Lemma red000to106 : reducible_in_range 0 106 the_configs.
Proof. CheckReducible. Qed.


From Tealeaves.Classes Require Import
  Monad
  Applicative.

(** * Monadic applicative functors *)
(******************************************************************************)
Section Applicative_Monad.

  #[local] Generalizable Variable T.

  Import Applicative.Notations.

  Context
    `{Classes.Monad.Monad T}.

  Import Monad.ToKleisli.Operation.
  Import Monad.ToKleisli.Instance.

  #[global] Instance Pure_Monad : Pure T := @ret T _.

  #[global] Instance Mult_Monad : Mult T :=
    fun A B (p : T A * T B) =>
      match p with (ta, tb) =>
                   bind T (fun a => strength T (a, tb)) ta
      end.

  Theorem app_pure_natural_Monad : forall (A B : Type) (f : A -> B) (x : A),
      fmap T f (pure T x) = pure T (f x).
  Proof.
    intros. unfold_ops @Pure_Monad.
    compose near x. now rewrite (natural (ϕ := @ret T _)).
  Qed.

  Theorem app_mult_natural_Monad : forall (A B C D : Type) (f : A -> C) (g : B -> D) (x : T A) (y : T B),
      fmap T f x ⊗ fmap T g y = fmap T (map_tensor f g) (x ⊗ y).
  Proof.
    intros. unfold_ops @Mult_Monad.
    compose near x.
    rewrite (bind_fmap T), (fmap_bind T).
    fequal. ext c; unfold compose; cbn. compose near y.
    now rewrite 2(fun_fmap_fmap T).
  Qed.

  Theorem app_assoc_Monad : forall (A B C : Type) (x : T A) (y : T B) (z : T C),
      fmap T α ((x ⊗ y) ⊗ z) = x ⊗ (y ⊗ z).
  Proof.
    intros. unfold_ops @Mult_Monad.
    compose near x on left. rewrite (kmon_bind2 T).
    compose near x on left. rewrite (fmap_bind T).
    fequal. ext a; unfold compose; cbn.
    compose near y on right. rewrite (fmap_bind T).
    unfold compose; cbn. compose near z on right.
    unfold kcompose. unfold compose; cbn.
    compose near y on left.
    rewrite (bind_fmap T). compose near y on left.
    rewrite (fmap_bind T). fequal. ext b. unfold compose; cbn.
    compose near z. now do 2 (rewrite (fun_fmap_fmap T)).
  Qed.

  Theorem app_unital_l_Monad : forall (A : Type) (x : T A),
      fmap T left_unitor (pure T tt ⊗ x) = x.
  Proof.
    intros. unfold_ops @Mult_Monad @Pure_Monad.
    compose near tt. rewrite (mon_bind_comp_ret T).
    unfold strength. compose near x.
    rewrite (fun_fmap_fmap T). change (left_unitor ∘ pair tt) with (@id A).
    now rewrite (fun_fmap_id T).
  Qed.

  Theorem app_unital_r_Monad : forall (A : Type) (x : T A),
      fmap T right_unitor (x ⊗ pure T tt) = x.
  Proof.
    intros. unfold_ops @Mult_Monad @Pure_Monad.
    compose near x. rewrite (fmap_bind T).
    replace (fmap T right_unitor ∘ (fun a : A => strength T (a, ret T tt)))
      with (ret T (A := A)).
    now rewrite (mon_bind_id T).
    ext a; unfold compose; cbn. compose near (ret T tt).
    rewrite (fun_fmap_fmap T). compose near tt.
    rewrite (natural (ϕ := @ret T _ )). now unfold compose; cbn.
  Qed.

  Theorem app_mult_pure_Monad : forall (A B : Type) (a : A) (b : B),
      pure T a ⊗ pure T b = pure T (a, b).
  Proof.
    intros. intros. unfold_ops @Mult_Monad @Pure_Monad.
    compose near a. rewrite (mon_bind_comp_ret T).
    now rewrite (strength_return).
  Qed.

  #[global] Instance Applicative_Monad : Applicative T :=
  { app_mult_pure := app_mult_pure_Monad;
    app_pure_natural := app_pure_natural_Monad;
    app_mult_natural := app_mult_natural_Monad;
    app_assoc := app_assoc_Monad;
    app_unital_l := app_unital_l_Monad;
    app_unital_r := app_unital_r_Monad;
  }.

End Applicative_Monad.


Set Universe Polymorphism.
Section foo.
  Universe i.
  Context (foo : Type@{i}) (bar : Type@{i}).
  Definition qux@{i} (baz : Type@{i}) := foo -> bar.
End foo.
Set Printing Universes.
Print qux. (* qux@{Top.42 Top.43} =
fun foo bar _ : Type@{Top.42} => foo -> bar
     : Type@{Top.42} -> Type@{Top.42} -> Type@{Top.42} -> Type@{Top.42}
(* Top.42 Top.43 |=  *)
(* This is wrong; the first two types are equal, but the last one is not *)

qux is universe polymorphic
Argument scopes are [type_scope type_scope type_scope]
 *)
Check qux nat nat nat : Set.
Check qux nat nat Set : Set. (* Error:
The term "qux@{Top.50 Top.51} ?T ?T0 Set" has type "Type@{Top.50}" while it is
expected to have type "Set"
(universe inconsistency: Cannot enforce Top.50 = Set because Set < Top.50). *)


Require Import Fiat.QueryStructure.Automation.MasterPlan.
Require Import Fiat.Narcissus.Examples.NetworkStack.IPv4Header.
Require Import Fiat.Narcissus.Examples.NetworkStack.TCP_Packet.
Require Import Fiat.Narcissus.Formats.ByteBuffer.

Definition GuardDataSchema :=
  Query Structure Schema [
    relation "connections" has schema
      <"src_addr" :: string, "src_port" :: nat,
       "dst_addr" :: string, "dst_port" :: nat>
  ] enforcing [].

Notation bytes := { n: nat & ByteBuffer.t n }.

Definition bytes_of_ByteBuffer {n} (bb: ByteBuffer.t n) : bytes :=
  existT _ n bb.

Definition GuardSig : ADTSig := ADTsignature {
  Constructor "Init" : rep,
  Method "ProcessPacket" : rep * bytes -> rep * bool
}.

Definition ACCEPT := true.
Definition REJECT := false.

(* FIXME *)
Definition is_conn_start (pkt: TCP_Packet) : bool := pkt.(SYN).
Definition is_conn_end (pkt: TCP_Packet) : bool := pkt.(FIN).
Definition MAX_OPEN_CONNECTIONS := 50.

Require Import Bedrock.Word.
Require Import Fiat.Narcissus.BinLib.Core.

Definition WrapDecoder {A B C} (f: forall n, ByteBuffer.t n -> option (A * B * C)) :=
  fun (bs: bytes) =>
    match f _ (projT2 bs) with
    | Some (pkt, _, _) => Some pkt
    | None => None
    end.

Definition ipv4_decode :=
  WrapDecoder (@IPv4_decoder_impl).

Definition ipv4Split {A} (k: forall (w1 w2 w3 w4: word 8), A) (addr: word 32) : A :=
  let w1 := split2 24 8 addr in
  let w2 := split1 8 8 (split2 16 16 addr) in
  let w3 := split1 8 16 (split2 8 24 addr) in
  let w4 := split1 8 24 addr in
  k w1 w2 w3 w4.

Definition ipv4ToList :=
  ipv4Split (fun w1 w2 w3 w4 => [w1; w2; w3; w4]).

Definition ipv4ToByteBuffer :=
  ipv4Split (fun w1 w2 w3 w4 => ByteBuffer.of_list [w1; w2; w3; w4]: ByteBuffer.t 4).

Compute (ipv4ToByteBuffer (WO~0~0~0~0~1~1~1~1~0~1~0~1~0~1~0~1~0~0~1~1~0~0~1~1~0~1~1~1~0~1~1~1)).

Definition ipv4ToString (addr: word 32) :=
  List.fold_right
    (fun (w: char) str => String (ascii_of_nat (wordToNat w)) str)
    EmptyString (ipv4ToList addr).

Compute (ipv4ToString (WO~0~0~0~0~1~1~1~1~0~1~0~1~0~1~0~1~0~0~1~1~0~0~1~1~0~1~1~1~0~1~1~1)).

Definition tcp_decode (hdr: IPv4_Packet) :=
  let src := ipv4ToByteBuffer hdr.(SourceAddress) in
  let dst := ipv4ToByteBuffer hdr.(DestAddress) in
  let offset := 20 + 4 * List.length hdr.(IPv4Header.Options) in
  let tcpLen := wordToNat hdr.(TotalLength) - offset in
  fun bs =>
    let bs' := AlignedByteBuffer.bytebuffer_of_bytebuffer_range offset tcpLen (projT2 bs) in
    WrapDecoder (@TCP_decoder_impl src dst (natToWord 16 tcpLen)) bs'.

Definition port_to_nat (port: word 16) :=
  wordToNat port.

Definition GuardSpec : ADT GuardSig := Eval simpl in Def ADT {
  rep := QueryStructure GuardDataSchema,

  Def Constructor0 "Init" : rep := empty,,

  Def Method1 "ProcessPacket" (db : rep) (bs : bytes) : rep * bool :=
    Ifopt ipv4_decode bs as hdr Then
      let src_addr := ipv4ToString hdr.(SourceAddress) in
      let dst_addr := ipv4ToString hdr.(DestAddress) in
      Ifopt tcp_decode hdr bs as pkt Then
        let src_port := port_to_nat (pkt.(SourcePort)) in
        let dst_port := port_to_nat (pkt.(DestPort)) in
        count <- Count (For (conn in db!"connections")
                       Where (conn!"src_addr" = src_addr)
                       Where (conn!"dst_addr" = dst_addr)
                       Return ());
        If is_conn_end pkt Then (
          `(db, _) <- Delete conn from db!"connections"
                       where (conn!"src_addr" = src_addr /\
                              conn!"dst_addr" = dst_addr /\
                              conn!"src_port" = src_port /\
                              conn!"dst_port" = dst_port);
          ret (db, ACCEPT)
        ) Else If count <? MAX_OPEN_CONNECTIONS Then (
          If is_conn_start pkt Then (
            `(db, _) <- Insert <"src_addr" :: src_addr, "src_port" :: src_port,
                               "dst_addr" :: dst_addr, "dst_port" :: dst_port>
                         into db!"connections"; (* FIXME *)
            ret (db, ACCEPT)
          ) Else
            ret (db, ACCEPT)
        ) Else
          ret (db, REJECT)
      Else
        ret (db, REJECT)
    Else
      ret (db, REJECT)

}%methDefParsing.

Notation IndexType sch :=
  (@ilist3 RawSchema (fun sch : RawSchema =>
                        list (string * Attributes (rawSchemaHeading sch)))
           (numRawQSschemaSchemas sch) (qschemaSchemas sch)).

(* Definition empty_index : IndexType GuardDataSchema := *)
(*   {| prim_fst := []; *)
(*      prim_snd := () |}. *)

Definition slow_index : IndexType GuardDataSchema :=
  {| prim_fst := [("EqualityIndex", "src_port" # "connections" ## GuardDataSchema);
                  ("EqualityIndex", "dst_port" # "connections" ## GuardDataSchema)];
     prim_snd := () |}.

Definition fast_index : IndexType GuardDataSchema :=
  {| prim_fst := [("EqualityIndex", "src_addr" # "connections" ## GuardDataSchema);
                  ("EqualityIndex", "dst_addr" # "connections" ## GuardDataSchema)];
     prim_snd := () |}.

Definition indexes := slow_index.

Ltac FindAttributeUses := EqExpressionAttributeCounter.
Ltac BuildEarlyIndex := ltac:(LastCombineCase6 BuildEarlyEqualityIndex).
Ltac BuildLastIndex := ltac:(LastCombineCase5 BuildLastEqualityIndex).
Ltac IndexUse := EqIndexUse.
Ltac createEarlyTerm := createEarlyEqualityTerm.
Ltac createLastTerm := createLastEqualityTerm.
Ltac IndexUse_dep := EqIndexUse_dep.
Ltac createEarlyTerm_dep := createEarlyEqualityTerm_dep.
Ltac createLastTerm_dep := createLastEqualityTerm_dep.
Ltac BuildEarlyBag := BuildEarlyEqualityBag.
Ltac BuildLastBag := BuildLastEqualityBag.
Ltac PickIndex := ltac:(fun makeIndex => let attrlist' := eval compute in indexes in makeIndex attrlist').

Theorem SharpenedGuard :
  FullySharpened GuardSpec.

Proof.
  start sharpening ADT.

  match goal with
  |- context [@BuildADT (QueryStructure ?Rep) _ _ _ _ _ _] =>
    hone representation using (@DropQSConstraints_AbsR Rep)
  end.

  - apply Constructor_DropQSConstraints.
  - etransitivity; [ eapply refine_If_Opt_Then_Else_Bind | ].
    etransitivity; [ eapply refine_If_Opt_Then_Else | ]; swap 1 3.
    (* setoid_rewrite refine_If_Opt_Then_Else_Bind. *)
    (* setoid_rewrite refine_If_Opt_Then_Else; swap 2 3. *)
    + higher_order_reflexivity.
    + simplify with monad laws.
      refine pick val _; [ | reflexivity ].
      simplify with monad laws; simpl.
      match goal with
      | [ H: DropQSConstraints_AbsR _ _ |- _ ] => red in H; rewrite !H
      end;
        higher_order_reflexivity.
    + intro.
      (* Why not setoid_rewrite? *)
      etransitivity; [ eapply refine_If_Opt_Then_Else_Bind | ].
      etransitivity; [ eapply refine_If_Opt_Then_Else | ]; swap 1 3.
      * higher_order_reflexivity.
      * simplify with monad laws.
        refine pick val _; [ | reflexivity ].
        simplify with monad laws; simpl.
        match goal with
        | [ H: DropQSConstraints_AbsR _ _ |- _ ] => red in H; rewrite !H
        end;
          higher_order_reflexivity.
      * intro.
        simplify with monad laws.

        etransitivity.
        -- setoid_rewrite DropQSConstraintsQuery_In. (* drop_constraints_from_query *)
           try simplify with monad laws; cbv beta; simpl;
             repeat match goal with
                      H : DropQSConstraints_AbsR _ _ |- _ =>
                      unfold DropQSConstraints_AbsR in H; rewrite H
                    end. (*pose_string_hyps; pose_heading_hyps; *)
           finish honing.
        -- etransitivity; [ eapply refine_bind | ]; cycle -1.
           ++ higher_order_reflexivity.
           ++ higher_order_reflexivity.
           ++ intro.
              (* Why not setoid_rewrite? *)
              etransitivity; [ eapply refine_If_Then_Else_Bind | ].
              etransitivity; [ eapply refine_If_Then_Else | ]; swap 1 3.
              ** higher_order_reflexivity.
              ** etransitivity; [ eapply refine_If_Then_Else_Bind | ].
                 etransitivity; [ eapply refine_If_Then_Else | ]; swap 1 3.
                 --- higher_order_reflexivity.
                 --- simplify with monad laws.
                     refine pick val _; [ | reflexivity ].
                     simplify with monad laws; simpl.
                     match goal with
                     | [ H: DropQSConstraints_AbsR _ _ |- _ ] => red in H; rewrite !H
                     end;
                       higher_order_reflexivity.
                 --- etransitivity; [ eapply refine_If_Then_Else_Bind | ].
                     etransitivity; [ eapply refine_If_Then_Else | ]; swap 1 3.
                     +++ higher_order_reflexivity.
                     +++ simplify with monad laws.
                         refine pick val _; [ | reflexivity ].
                         simplify with monad laws; simpl.
                         match goal with
                         | [ H: DropQSConstraints_AbsR _ _ |- _ ] => red in H; rewrite !H
                         end;
                           higher_order_reflexivity.
                     +++ unfold Bind2; simplify with monad laws.
                         simpl.

                         Lemma refine_bind_bind_dep X X' Y Z (f : X -> Comp Y) (g : Y -> Comp Z) (k: X -> X') x
                           : refine (Bind x (fun x0 => Bind (f x0) (fun u => g u)))
                                    (Bind (Bind x (fun x0 => Bind (f x0) (fun u => ret (u, (k x0)))))
                                          (fun x0u => g (fst x0u))).
                         Proof.
                           red; intros.
                           computes_to_inv; subst.
                           eauto using @BindComputes.
                         Qed.

                         Lemma refine_bind_bind_dep' X Y Z (f : X -> Comp Y) (g : Y -> X -> Comp Z) x
                           : refine (Bind x (fun x0 => Bind (f x0) (fun u => g u x0)))
                                    (Bind (Bind x (fun x0 => Bind (f x0) (fun u => ret (u, x0))))
                                          (fun x0u => g (fst x0u) (snd x0u))).
                         Proof.
                           red; intros.
                           computes_to_inv; subst.
                           eauto using @BindComputes.
                         Qed.

                         rewrite refine_bind_bind_dep with (k := snd).
                         setoid_rewrite refine_bind.
                         *** higher_order_reflexivity.
                         *** (* remove trivial insertion checks *)
                           (* Pull out the relation we're inserting into and then
                              rewrite [QSInsertSpec] *)
                           lazymatch goal with
                             H : DropQSConstraints_AbsR _ ?r_n
                             |- context [(QSInsert _ ?R ?n)%QuerySpec] =>
                             let H' := fresh in
                             (* If we try to eapply [QSInsertSpec_UnConstr_refine] directly
                                after we've drilled under a bind, this tactic will fail because
                                typeclass resolution breaks down. Generalizing and applying gets
                                around this problem for reasons unknown. *)
                             let H' := fresh in
                             pose (@QSInsertSpec_UnConstr_refine_opt _ r_n _ R n H) as H';
                               cbv beta delta [tupleConstraints attrConstraints map app relName schemaHeading] iota in H';
                               simpl in H'; fold_heading_hyps_in H'; fold_string_hyps_in H'; exact H'
                           end.
                         *** intro.
                             finish honing.
              ** unfold Bind2; simplify with monad laws.
                 simpl.
                 rewrite refine_bind_bind_dep with (k := snd).
                 setoid_rewrite refine_bind.

                 --- higher_order_reflexivity.
                 --- (* drop_constraints_from_delete. *)
                   (* Pull out the relation we're inserting into and then
                      rewrite [QSInsertSpec] *)
                   match goal with
                       H : DropQSConstraints_AbsR ?r_o ?r_n
                       |- context [QSDelete ?qs ?R ?P] =>
                       (* If we try to eapply [QSInsertSpec_UnConstr_refine] directly
                                  after we've drilled under a bind, this tactic will fail because
                                  typeclass resolution breaks down. Generalizing and applying gets
                                  around this problem for reasons unknown. *)
                       let H' := fresh "H'" in
                       pose proof (@QSDeleteSpec_UnConstr_refine_opt
                                     _ r_n R P r_o H) as H';
                         simpl in H'; fold_heading_hyps_in H'; fold_string_hyps_in H';
                         apply H'
                   end.
                 --- intro.
                     finish honing.

  -
    PickIndex ltac:(fun attrlist =>
                      make_simple_indexes attrlist BuildEarlyIndex BuildLastIndex).

    plan CreateTerm EarlyIndex LastIndex makeClause_dep EarlyIndex_dep LastIndex_dep.

    etransitivity; [ eapply refine_If_Opt_Then_Else_Bind | ].
    eapply refine_If_Opt_Then_Else; swap 1 2.
    (* setoid_rewrite refine_If_Opt_Then_Else_Bind. *)
    (* setoid_rewrite refine_If_Opt_Then_Else; swap 2 3. *)
    + simplify with monad laws.
      simpl; refine pick val _; [ | eauto ].
      simplify with monad laws; simpl.
      higher_order_reflexivity.
    + intro.
      (* Why not setoid_rewrite? *)
      etransitivity; [ eapply refine_If_Opt_Then_Else_Bind | ].
      eapply refine_If_Opt_Then_Else; swap 1 2.
      * simplify with monad laws.
        simpl; refine pick val _; [ | eauto ].
        higher_order_reflexivity.
      * intro.
        simplify with monad laws.
        apply refine_bind.
        -- implement_Query IndexUse createEarlyTerm createLastTerm
                           IndexUse_dep createEarlyTerm_dep createLastTerm_dep.
           simpl; repeat first [setoid_rewrite refine_bind_unit
                               | setoid_rewrite refine_bind_bind ];
           cbv beta; simpl.
           finish honing.
        -- intro.
              (* Why not setoid_rewrite? *)
              etransitivity; [ eapply refine_If_Then_Else_Bind | ].
              etransitivity; [ eapply refine_If_Then_Else | ]; swap 1 2.
              ** etransitivity; [ eapply refine_If_Then_Else_Bind | ].
                 etransitivity; [ eapply refine_If_Then_Else | ]; swap 1 2.
                 --- simplify with monad laws.
                     refine pick val _; [ | eauto ].
                     simplify with monad laws; simpl.
                     higher_order_reflexivity.
                 --- etransitivity; [ eapply refine_If_Then_Else_Bind | ].
                     etransitivity; [ eapply refine_If_Then_Else | ]; swap 1 2.
                     +++ simplify with monad laws.
                         refine pick val _; [ | eauto ].
                         simplify with monad laws; simpl.
                         higher_order_reflexivity.
                     +++ unfold Bind2; simplify with monad laws.
                         simpl.
                         insertion IndexUse createEarlyTerm createLastTerm IndexUse_dep createEarlyTerm_dep createLastTerm_dep.
                     +++ higher_order_reflexivity.
                 --- higher_order_reflexivity.
              ** unfold Bind2; simplify with monad laws.
                 simpl.
                 deletion IndexUse createEarlyTerm createLastTerm IndexUse_dep createEarlyTerm_dep createLastTerm_dep.
              ** higher_order_reflexivity.

    + simpl.
      hone representation using eq; simpl; subst.
      * refine pick eq; simplify with monad laws; simpl.
        finish honing.
      * refine pick eq; simplify with monad laws; simpl.
        etransitivity; [ eapply refine_If_Opt_Then_Else_Bind | ].
        eapply refine_If_Opt_Then_Else; swap 1 2.
        -- simplify with monad laws; simpl.
           higher_order_reflexivity.
        -- intro.
           (* Why not setoid_rewrite? *)
           etransitivity; [ eapply refine_If_Opt_Then_Else_Bind | ].
           eapply refine_If_Opt_Then_Else; swap 1 2.
           ++ simplify with monad laws; simpl.
              higher_order_reflexivity.
           ++ intro.
              simplify with monad laws.
              repeat change (true && ?x) with x.
              apply refine_bind.
              ** finish honing.
              ** intro.
                 (* Why not setoid_rewrite? *)
                 etransitivity; [ eapply refine_If_Then_Else_Bind | ].
                 etransitivity; [ eapply refine_If_Then_Else | ]; swap 1 3.
                 --- higher_order_reflexivity.
                 --- repeat rewrite ?map_length, ?app_nil_r.
                     etransitivity; [ eapply refine_If_Then_Else_Bind | ].
                     etransitivity; [ eapply refine_If_Then_Else | ]; swap 1 3.
                     +++ higher_order_reflexivity.
                     +++ simplify with monad laws; simpl.
                         higher_order_reflexivity.
                     +++ etransitivity; [ eapply refine_If_Then_Else_Bind | ].
                         etransitivity; [ eapply refine_If_Then_Else | ]; swap 1 3.
                         *** higher_order_reflexivity.
                         *** simplify with monad laws; simpl.
                             higher_order_reflexivity.
                         *** simplify with monad laws; simpl.
                             higher_order_reflexivity.
                 --- simplify with monad laws; simpl.
                     (* FIXME delete unused bind? *)
                     finish honing.

      *  Implement_Bags BuildEarlyBag BuildLastBag.
Defined.

Definition GuardImpl :=
  Eval simpl in projT1 SharpenedGuard.


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)
Require Import securite.

Lemma POinvprel1 :
 forall (l l0 : list C) (k k0 k1 k2 : K) (c c0 c1 c2 : C)
   (d d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d12 d13 d14 d15 d16 d17 d18 d19
    d20 : D),
 inv0
   (ABSI (MBNaKab d7 d8 d9 k0) (MANbKabCaCb d4 d5 d6 k c c0)
      (MABNaNbKeyK d d0 d1 d2 d3) l) ->
 inv1
   (ABSI (MBNaKab d7 d8 d9 k0) (MANbKabCaCb d4 d5 d6 k c c0)
      (MABNaNbKeyK d d0 d1 d2 d3) l) ->
 invP
   (ABSI (MBNaKab d7 d8 d9 k0) (MANbKabCaCb d4 d5 d6 k c c0)
      (MABNaNbKeyK d d0 d1 d2 d3) l) ->
 rel1
   (ABSI (MBNaKab d7 d8 d9 k0) (MANbKabCaCb d4 d5 d6 k c c0)
      (MABNaNbKeyK d d0 d1 d2 d3) l)
   (ABSI (MBNaKab d18 d19 d20 k2) (MANbKabCaCb d15 d16 d17 k1 c1 c2)
      (MABNaNbKeyK d10 d11 d12 d13 d14) l0) ->
 invP
   (ABSI (MBNaKab d18 d19 d20 k2) (MANbKabCaCb d15 d16 d17 k1 c1 c2)
      (MABNaNbKeyK d10 d11 d12 d13 d14) l0).

Proof.
do 32 intro.
unfold invP, rel1 in |- *; intros Inv0 Inv1 know_Kab and1.
elim and1; intros eq_l0 t1.
clear Inv0 Inv1 and1 t1.
rewrite eq_l0.
unfold quad in |- *.
apply D2.
simpl in |- *.
repeat apply C2 || apply C3 || apply C4.
apply D1; assumption.
discriminate.
discriminate.
discriminate.
discriminate.
discriminate.
discriminate.
discriminate.
discriminate.
discriminate.
discriminate.
discriminate.
discriminate.
discriminate.
discriminate.
Qed.


From spec Require Import Maps.
From spec Require Import Lang.
From spec Require Import programs.
From spec Require Import semantics.
Require Import List.
Require Import String.
Import ListNotations.

(* Initial Memory should be bottom t_empty ⊥. Jumps to other locations not in the program
and are not bottom are not correctly handled. But it works for bottom
*)
(*|
================
Simple Examples
================

Here, we include the examples for each of the speculative semanitcs: for branch instructions,
for store instructions and for return instructions.
|*)
Definition init_state (st : state): SState :=
     [ {|
    State := st;
    Ctr := 0;
    RhoStack := [];
    Rsb := [];
    Id := none;
    Window := ⊥  (* Should be bottom but window is a nat right now* Since it is 0 riht now *)
    |} ].

(* sp needs to be set to somethign that has to be high, since memory written with sp can be overwritten*)
Definition exampl_b := {|Program := prog_b;
Config := {|Pc := 0;
            Mem := 1000 !-> 53; N 5000 !-> 2; t_empty ⊥; (* Need one N constructor for correct type inference*)
            Regs := y !-> 0; A !-> 1000; t_empty 0
        |}
|}.

Definition empty_F : (Functions) := t_empty None.
(*The program speculatively leaks 53 * 512 *)
Compute (S_execute_tr empty_F (init_state exampl_b) semanticV1 100). (* 53 * 512 = 27136*)

Definition exampl_s := {|Program := prog_s;
Config := {|Pc := 0;
            Mem := 1000 !-> 53; N 5000 !-> 2; t_empty ⊥; (* Need one N constructor for correct type inference*)
            Regs := public !-> 0; secret !-> 53; t_empty 0
        |}
|}.

(* The program speculatively leaks 53 * 512 *)
Compute (S_execute_tr empty_F (init_state exampl_s) semanticV4 1000). (* 53 * 512 = 27136*)

Definition exampl_r := {|Program := prog_r;
Config := {|Pc := 7;
            Mem := 1000 !-> 53; N 5000 !-> 2; t_empty ⊥ ; (* Need one N constructor for correct type inference*)
            Regs := sp !-> 100; public !-> 0; secret !-> 53; t_empty 0
        |}
|}.
Print Functions.
Definition F_map : (Functions) := "Manip_Stack" !-> Some 0; "Speculate" !-> Some 2; t_empty None.
(* Leaks 53*)
Compute (S_execute_tr F_map (init_state exampl_r) semanticV5 1000).

(*|
=============================
Composed Examples (Section 5)
=============================

We always give the traces of the source semantics first to show that they do not leak
the secret value. Then, we show the trace under the combined semantics of the respective version.

|*)

(*|
Combination B + R
=================
|*)
Definition exampl_br := {|Program := prog_br;
Config := {|Pc := 9;
            Mem := 1000 !-> 53; N 5000 !-> 2; t_empty ⊥; (* Need one N constructor for correct type inference*)
            Regs := sp !-> 100; public !-> 0; secret !-> 53; t_empty 0
        |}
|}.

Definition F_map_br : (Functions) := F_map.

(*|
The traces of the source semantics for branch and return speculation.
Under these semantics the program prog_br is secure because the secret is not leaked
|*)
Compute (S_execute_tr F_map_br (init_state exampl_br) semanticV1 1000).
Compute (S_execute_tr F_map_br (init_state exampl_br) semanticV5 1000).
(* Leaks secret with value 53 *)
Compute (S_execute_tr F_map_br (init_state exampl_br) semanticV15 1000).

(*|
Combination B + S
=================
|*)
Definition exampl_bs := {|Program := prog_bs;
Config := {|Pc := 0;
            Mem := 1000 !-> 53; N 5000 !-> 2; t_empty 0; (* Need one N constructor for correct type inference*)
            Regs := sp !-> 100; public !-> 0; secret !-> 53; t_empty 0
        |}
|}.

Compute (S_execute_tr F_map (init_state exampl_bs) semanticV1 100).
Compute (S_execute_tr F_map (init_state exampl_bs) semanticV4 100).
(* Leaks the secret 53 *)
Compute (S_execute_tr F_map (init_state exampl_bs) semanticV14 100).

(*|
Combination S + R
=================
|*)
Definition exampl_sr := {|Program := prog_sr;
Config := {|Pc := 8;
            Mem := t_empty ⊥ ; (* Need one N constructor for correct type inference*)
            Regs := sp !-> 100; public !-> 0; secret !-> 53; t_empty 0
        |}
|}.

Definition F_map_sr : (Functions) := F_map.

Compute (S_execute_tr F_map_sr (init_state exampl_sr) semanticV4 100).
Compute (S_execute_tr F_map_sr (init_state exampl_sr) semanticV5 100).

(* Leaks 53 *)
Compute (S_execute_tr F_map_sr (init_state exampl_sr) semanticV45 100).

(*|
Combination B + S + R
======================
|*)
Definition exampl_bsr := {|Program := prog_bsr;
Config := {|Pc :=9;
            Mem := 1000 !-> 53; N 5000 !-> 2; t_empty ⊥; (* Need one N constructor for correct type inference*)
            Regs := sp !-> 100; public !-> 0; secret !-> 53; t_empty 0
        |}
|}.

Definition F_map_bsr : (Functions) := F_map.

Compute (S_execute_tr F_map_bsr (init_state exampl_bsr) semanticV1 200).
Compute (S_execute_tr F_map_bsr (init_state exampl_bsr) semanticV4 200).
Compute (S_execute_tr F_map_bsr (init_state exampl_bsr) semanticV5 200).
(* Leaks secret value 53 in the trace *)
Compute (S_execute_tr F_map_bsr (init_state exampl_bsr) semanticV145 200).


(** * Limits of chains and cochains in the precategory of types *)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.NaturalNumbers.
Require Import UniMath.MoreFoundations.Notations.
Require Import UniMath.MoreFoundations.PartA.
Require Import UniMath.MoreFoundations.Univalence.
Require Import UniMath.MoreFoundations.WeakEquivalences.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.categories.Type.Core.
Require Import UniMath.CategoryTheory.categories.Type.Limits.

Require Import UniMath.CategoryTheory.Chains.Chains.
Require Import UniMath.CategoryTheory.Chains.Cochains.
Require Import UniMath.CategoryTheory.limits.graphs.limits.
Require Import UniMath.CategoryTheory.limits.terminal.
Require Import UniMath.CategoryTheory.limits.graphs.colimits.
Require Import UniMath.Induction.FunctorCoalgebras_legacy.

Require Import UniMath.Induction.PolynomialFunctors.
Require Import UniMath.Induction.M.Limits.
Require Import UniMath.Induction.M.Core.

(** The shifted chain (X', π') from (X, π) is one where Xₙ' = Xₙ₊₁ and πₙ' = πₙ₊₁. *)
Definition shift_chain (cha : chain type_precat) : chain type_precat.
Proof.
  use tpair.
  - exact (dob cha ∘ S).
  - exact (λ _ _ path, dmor cha (maponpaths S path)).
Defined.

(** The shifted cochain (X', π') from (X, π) is one where Xₙ' = Xₙ₊₁ and πₙ' = πₙ₊₁. *)
Definition shift_cochain {C : precategory} (cochn : cochain C) : cochain C.
Proof.
  use cochain_weq; use tpair.
  - exact (dob cochn ∘ S).
  - intros n; cbn.
    apply (dmor cochn).
    exact (idpath _).
Defined.

(** Interaction between transporting over (maponpaths S ed) and shifting the cochain *)
Definition transport_shift_cochain :
  ∏ cochn ver1 ver2 (ed : ver1 = ver2)
    (stdlim_shift : standard_limit (shift_cochain cochn)),
  transportf (dob cochn) (maponpaths S ed) (pr1 stdlim_shift ver1) =
  transportf (dob (shift_cochain cochn)) ed (pr1 stdlim_shift ver1).
Proof.
  intros cochn ver1 ver2 ed stdlim_shift.
  induction ed.
  reflexivity.
Defined.

(** Ways to prove that [dmor]s are equal on cochains *)
Lemma cochain_dmor_paths {C : precategory} {ver1 ver2 : vertex conat_graph}
      (cochn : cochain C) (p1 p2 : edge ver1 ver2) : dmor cochn p1 = dmor cochn p2.
Proof.
  apply maponpaths, proofirrelevance, isasetnat.
Defined.

(** More ways to prove that [dmor]s are equal on cochains *)
Lemma cochain_dmor_paths_type {ver1 ver2 ver3 : vertex conat_graph}
  (cochn : cochain type_precat) (p1 : edge ver1 ver3) (p2 : edge ver2 ver3)
  (q1 : ver1 = ver2) :
  ∏ v1 : dob cochn ver1, dmor cochn p1 v1 = dmor cochn p2 (transportf _ q1 v1).
Proof.
  intro v1; cbn in *.
  induction q1.
  cbn.
  exact (toforallpaths _ _ _ (cochain_dmor_paths cochn p1 p2) v1).
Defined.

(** We use the following tactic notations to mirror the "equational style" of
    reasoning used in Ahrens, Capriotti, and Spadotti. *)
Local Tactic Notation "≃" constr(H) "by" tactic(t) := intermediate_weq H; [t|].
Local Tactic Notation "≃'" constr(H) "by" tactic(t) := intermediate_weq H; [|t].
Local Tactic Notation "≃" constr(H) := intermediate_weq H.
Local Tactic Notation "≃'" constr(H) := apply invweq; intermediate_weq H.

Local Lemma combine_over_nat_basic {X Y Z : nat → UU} :
  X 0 ≃ Z 0 → (∏ n : nat, Y (S n) ≃ Z (S n)) →
  (X 0 × ∏ n : nat, Y (S n)) ≃ ∏ n : nat, Z n.
Proof.
  intros x0z0 yszs.
  ≃ (Z 0 × (∏ n : nat, Z (S n))).
  - apply weqdirprodf; [apply x0z0|].
    apply weqonsecfibers, yszs.
  - use weq_iso.
    + intros z0zs.
      intros n; induction n.
      * exact (dirprod_pr1 z0zs).
      * apply (dirprod_pr2 z0zs).
    + intros xs; use make_dirprod.
      * apply xs.
      * exact (xs ∘ S).
    + reflexivity.
    + intros xs.
      apply funextsec; intros n.
      induction n; reflexivity.
Defined.

Local Lemma combine_over_nat {X : nat → UU} {P : (X 0 × (∏ n : nat, X (S n))) → UU} :
  (∑ x0 : X 0, ∑ xs : ∏ n : nat, X (S n), P (make_dirprod x0 xs)) ≃
  (∑ xs : ∏ n : nat, X n, P (make_dirprod (xs 0) (xs ∘ S))).
Proof.
  ≃ (∑ pair : (X 0 × ∏ n : nat, X (S n)), P pair) by apply weqtotal2asstol.
  use weqbandf.
  - apply (@combine_over_nat_basic X X X); intros; apply idweq.
  - intros x0xs; cbn.
    apply idweq.
Defined.

Local Lemma combine_over_nat' {X : nat → UU} {P : X 0 → (∏ n : nat, X (S n)) → UU} :
  (∑ x0 : X 0, ∑ xs : ∏ n : nat, X (S n), P x0 xs) ≃
  (∑ xs : ∏ n : nat, X n, P (xs 0) (xs ∘ S)).
Proof.
  ≃ (∑ (x0 : X 0) (xs : ∏ n : nat, X (S n)), (uncurry (Z := λ _, UU) P)
                                             (make_dirprod x0 xs)) by apply idweq.
  ≃' (∑ xs : ∏ n : nat, X n, uncurry P (Z := λ _, UU)
                                     (make_dirprod (xs 0) (xs ∘ S))) by apply idweq.
  apply combine_over_nat.
Defined.

(** If the base type is contractible, so is the type of sections over it. *)
Definition weqsecovercontr_uncurried {X : UU} {Y : X -> UU}
           (P : ∏ x : X, Y x -> UU) (isc : iscontr (∑ x : X, Y x)) :
  (∏ (x : X) (y : Y x), P x y) ≃ (P (pr1 (iscontrpr1 isc)) (pr2 (iscontrpr1 isc))).
Proof.
  ≃ (∏ pair : (∑ x : X, Y x), uncurry (Z := λ _, UU) P pair) by
    apply invweq, weqsecovertotal2.
  ≃' (uncurry (Z := λ _, UU) P (iscontrpr1 isc)) by (apply idweq).
  apply weqsecovercontr.
Defined.

(** Shifted cochains have equivalent limits.
    (Lemma 12 in Ahrens, Capriotti, and Spadotti) *)

Definition shifted_limit (cocha : cochain type_precat) :
  standard_limit (shift_cochain cocha) ≃ standard_limit cocha.
Proof.
  pose (X := dob cocha); cbn in X.
  pose (π n := (@dmor _ _ cocha (S n) n (idpath _))).
  unfold standard_limit, shift_cochain; cbn.

  assert (isc : ∏ x : ∏ v : nat, dob cocha (S v),
                iscontr (∑ x0 : X 0, (π 0 (x 0)) = x0)).
  {
    intros x.
    apply iscontr_paths_from.
  }

  (** Step (2) *)
  (** This is the direct product with the type proven contractible above *)
  ≃ (∑ xs : ∏ v : nat, X (S v),
    (∏ (u v : nat) (e : S v = u),
    (dmor cocha (idpath (S (S v)))
      ∘ transportf (λ o : nat, X (S o) → X (S (S v))) e
      (idfun (X (S (S v))))) (xs u) = xs v)
    × (∑ x0 : X 0, (π 0 (xs 0)) = x0)) by
    (apply weqfibtototal; intro; apply dirprod_with_contr_r; apply isc).

  (** Now, we swap the components in the direct product. *)
  ≃ (∑ xs : ∏ v : nat, X (S v),
    (∑ x0 : X 0, π 0 (xs 0) = x0) ×
    (∏ (u v : nat) (e : S v = u),
      (dmor cocha (idpath (S (S v)))
      ∘ transportf (λ o : nat, X (S o) → X (S (S v))) e
      (idfun (X (S (S v))))) (xs u) = xs v)) by
    (apply weqfibtototal; intro; apply weqdirprodcomm).

  (** Using associativity of Σ-types, *)
  ≃ (∑ xs : ∏ v : nat, X (S v),
     ∑ x0 : X 0,
     (π 0 (xs 0) = x0) ×
     (∏ (u v : nat) (e : S v = u),
       (dmor cocha (idpath (S (S v)))
       ∘ transportf (λ o : nat, X (S o) → X (S (S v))) e
       (idfun (X (S (S v))))) (xs u) = xs v)) by
    (apply weqfibtototal; intro; apply weqtotal2asstor).

  (** And again by commutativity of ×, we swap the first components *)
  ≃ (∑ x0 : X 0,
     ∑ xs : ∏ n : nat, X (S n),
     (π 0 (xs 0) = x0) ×
     (∏ (u v : nat) (e : S v = u),
       (dmor cocha (idpath (S (S v)))
       ∘ transportf (λ o : nat, X (S o) → X (S (S v))) e
       (idfun (X (S (S v))))) (xs u) = xs v)) by (apply weqtotal2comm).

  (** Step 3: combine the first bits *)
  ≃ (∑ xs : ∏ n : nat, X n,
      (π 0 (xs 1) = xs 0) ×
      (∏ (u v : nat) (e : S v = u),
        (dmor cocha (idpath (S (S v)))
        ∘ transportf (λ o : nat, dob cocha (S o) → dob cocha (S (S v))) e
        (idfun (dob cocha (S (S v))))) (xs (S u)) = xs (S v))).
  apply (@combine_over_nat' X
        (λ x0 xs,
        π 0 (xs 0) = x0
        × (∏ (u v : nat) (e : S v = u),
            (dmor cocha (idpath (S (S v)))
            ∘ transportf (λ o : nat, X (S o) → X (S (S v))) e (idfun (X (S (S v)))))
              (xs u) = xs v))).

  (** Now the first component is the same. *)
  apply weqfibtototal; intros xs.

  ≃ (π 0 (xs 1) = xs 0
    × (∏ (v u : nat) (e : S v = u),
      (dmor cocha (idpath (S (S v)))
        ∘ transportf (λ o : nat, dob cocha (S o) → dob cocha (S (S v))) e
            (idfun (dob cocha (S (S v))))) (xs (S u)) = xs (S v))) by
    apply weqdirprodf; [apply idweq|apply flipsec_weq].

  ≃' (∏ (v u : nat) (e : S v = u), dmor cocha e (xs u) = xs v) by
    apply flipsec_weq.

  (** Split into cases on n = 0 or n > 0. *)
  (** Coq is bad about coming up with these implicit arguments, so we have to be
      very excplicit. *)
  apply (@combine_over_nat_basic
           (λ n, π n (xs (S n)) = xs n)
           (λ v, ∏ (u : nat) (e : v = u),
             (dmor cocha (idpath (S v))
               ∘ _ (idfun (dob cocha (S v)))) (xs (S u)) = xs v)
           (λ v, ∏ (u : nat) (e : S v = u), dmor cocha e (xs u) = xs v)).

  (** We use the following fact over and over to simplify the remaining types:
      for any x : X, the type ∑ y : X, x = y is contractible. *)
  - apply invweq.
    apply (@weqsecovercontr_uncurried
             nat (λ n, 1 = n) (λ _ _, _ = xs 0) (iscontr_paths_from 1)).
  - intros u.
    ≃ ((dmor cocha (idpath (S (S u)))
            ∘ transportf (λ o : nat, dob cocha (S o) → dob cocha (S (S u)))
                (idpath (S u)) (idfun (dob cocha (S (S u))))) (xs (S (S u))) =
          xs (S u)).
    + apply (@weqsecovercontr_uncurried
               nat (λ n, (S u) = n) (λ _ _, _ _ = xs (S u)) (iscontr_paths_from _)).
    + cbn.
      apply invweq.
      apply (@weqsecovercontr_uncurried
               nat (λ n, (S (S u)) = n) (λ _ _, _ = xs (S u)) (iscontr_paths_from _)).
Defined.

(** Lemma 11 in Ahrens, Capriotti, and Spadotti *)
Local Definition Z X l :=
 ∑ (x : ∏ n, X n), ∏ n, x (S n) = l n (x n).
Local Lemma lemma_11 (X : nat -> UU) (l : ∏ n, X n -> X (S n)) : Z X l ≃ X 0.
Proof.
 set (f (xp : Z X l) := pr1 xp 0).
 transparent assert (g : (X 0 -> Z X l)). {
   intros x.
   exists (nat_rect _ x l).
   exact (λ n, idpath _).
 }
 apply (make_weq f).
 apply (isweq_iso f g).
 - cbn.
   intros xp; induction xp as [x p].
   transparent assert ( q : (nat_rect X (x 0) l ~ x )). {
     intros n; induction n; cbn.
     * reflexivity.
     * exact (maponpaths (l n) IHn @ !p n).
   }
   set (q' := funextsec _ _ _ q).
   use total2_paths_f; cbn.
   + exact q'.
   + rewrite transportf_sec_constant. apply funextsec; intros n.
     intermediate_path (!maponpaths (λ x, x (S n)) q' @
                         maponpaths (λ x, l n (x n)) q'). {
       use transportf_paths_FlFr.
     }
     intermediate_path (!maponpaths (λ x, x (S n)) q' @
                         maponpaths (l n) (maponpaths (λ x, x n) q')). {
       apply maponpaths. symmetry. use maponpathscomp.
     }
     intermediate_path (! q (S n) @ maponpaths (l n) (q n)). {
       unfold q'.
       repeat rewrite maponpaths_funextsec.
       reflexivity.
     }
     intermediate_path (! (maponpaths (l n) (q n) @ ! p n) @
                          maponpaths (l n) (q n)). {
       reflexivity.
     }
     rewrite pathscomp_inv.
     rewrite <- path_assoc.
     rewrite pathsinv0l.
     rewrite pathsinv0inv0.
     rewrite pathscomp0rid.
     reflexivity.
 - cbn.
   reflexivity.
Defined.

(* Maybe easier to apply in Lemma *)
Local Definition lemma_11_unfolded (X : nat -> UU) (l : ∏ n, X n -> X (S n)) :
  (∑ (x : ∏ n, X n), ∏ n, x (S n) = l n (x n)) ≃ X 0 := lemma_11 X l.

Lemma cochain_limit_standard_limit_weq (cha cha' : cochain type_precat) :
  cochain_limit cha ≃ cochain_limit cha' → standard_limit cha ≃ standard_limit cha'.
Proof.
  intro f.
  apply (weqcomp (invweq (lim_equiv _))).
  apply (weqcomp f).
  apply (lim_equiv _).
Defined.

(* There is a simpler way to give cones over the terminal cochain. *)
Local Open Scope cat.
Section CochainCone.

  Context (A C : UU) (B : A -> UU).

  Definition terminal_cochain  : cochain type_precat :=
    termCochain (TerminalType) (polynomial_functor A B).

  Definition m_type  := standard_limit terminal_cochain.

  Definition apply_on_chain (cha : cochain type_precat) : cochain type_precat :=
    mapcochain (polynomial_functor A B) cha.

  (* Shifting the terminal cochain is equivalent to applying
    the polynomial functor once *)
  Definition terminal_cochain_shifted_lim :
    standard_limit (shift_cochain terminal_cochain) ≃
                  standard_limit (apply_on_chain terminal_cochain).
  Proof.
    apply cochain_limit_standard_limit_weq.
    unfold shift_cochain, apply_on_chain, cochain_limit.
    apply weqfibtototal;intros.
    apply weqonsecfibers; intro n.
    apply idweq.
  Defined.

  Let W n := iter_functor (polynomial_functor A B) n unit.
  Let Cone0' := λ n : nat, C → W n.
  Let Cone0 := ∏ n : nat, Cone0' n.
  Let π := λ n : nat, dmor terminal_cochain (idpath (S n)).

  Definition simplified_cone : UU :=
    (∑ (u : Cone0), ∏ n : nat, (π n ∘ u (S n))%functions = u n).

  Lemma simplify_cochain_cone :
    cone terminal_cochain C ≃ simplified_cone.
  Proof.
    unfold cone, Cone0.
    apply weqfibtototal; intro f.
    intermediate_weq (
      (∏ (u v : vertex conat_graph) (e0 : edge u v),
      f _ · dmor terminal_cochain e0 ~ f v)
      ). {
      do 3 (apply weqonsecfibers; intro).
      apply invweq.
      apply weqfunextsec.
    }
    apply invweq.
    intermediate_weq (∏ u, (π u ∘ f (S u))%functions ~ f u). {
      apply invweq.
      apply weqonsecfibers; intro.
      apply weqfunextsec.
    }
    unfold homotsec.
    apply invweq.
    intermediate_weq (
      (∏ (u v : vertex conat_graph) (c : C) (e0 : edge u v),
       (f u · dmor terminal_cochain e0) c = f v c)). {
      do 2 (apply weqonsecfibers; intro).
      apply flipsec_weq.
    }
    intermediate_weq (
      (∏ (c : C) (u v : vertex conat_graph) (e0 : edge u v),
       (f u · dmor terminal_cochain e0) c = f v c)). {
      intermediate_weq (
        (∏ (u : vertex conat_graph) (c : C) (v : vertex conat_graph) (e0 : edge u v),
        (f u · dmor terminal_cochain e0) c = f v c)). {
        apply weqonsecfibers; intro.
        apply flipsec_weq.
      }
      apply flipsec_weq.
    }
    apply invweq.
    intermediate_weq ((∏ (x : C) (u : nat), (π u ∘ f (S u))%functions x = f u x));
      [apply flipsec_weq|].
    apply weqonsecfibers; intro c.
    apply invweq.
    use weq_iso.
    - intros eq; intro; apply eq.
    - intros eq.
      intros ? ? e.
      induction e; apply eq.
    - abstract ( intro;
      do 2 (apply funextsec; intro);
      apply funextsec; intro e;
      induction e;
      reflexivity ).
    - abstract ( intro; apply funextsec; intro; reflexivity ).
  Defined.

End CochainCone.


Require Import String.

Require Import core.utils.Utils.
Require Import core.Model.
Require Import core.Syntax.
Require Import core.EqDec.
Require Import Bool.
Require Import Arith.
Require Import TransformationConfiguration.
Require Import Expressions.
Scheme Equality for list.

Section Semantics.

Context {tc: TransformationConfiguration}.

(** * Instantiate **)

Definition matchRuleOnPattern (r: Rule) (sm : SourceModel) (sp: list SourceModelElement) : bool :=
  match evalGuardExpr r sm sp with Some true => true | _ => false end.

Definition matchPattern (tr: Transformation) (sm : SourceModel) (sp: list SourceModelElement) : list Rule :=
  filter (fun (r:Rule) => matchRuleOnPattern r sm sp) (Transformation_getRules tr).

Definition instantiateElementOnPattern (o: OutputPatternElement) (sm: SourceModel) (sp: list SourceModelElement) (iter: nat)
  : option TargetModelElement :=
  evalOutputPatternElementExpr sm sp iter o.

Definition instantiateIterationOnPattern (r: Rule) (sm: SourceModel) (sp: list SourceModelElement) (iter: nat) :  list TargetModelElement :=
  flat_map (fun o => optionToList (instantiateElementOnPattern o sm sp iter))
    (Rule_getOutputPatternElements r).

Definition instantiateRuleOnPattern (r: Rule) (sm: SourceModel) (sp: list SourceModelElement) :  list TargetModelElement :=
  flat_map (instantiateIterationOnPattern r sm sp)
    (seq 0 (evalIteratorExpr r sm sp)).

Definition instantiatePattern (tr: Transformation) (sm : SourceModel) (sp: list SourceModelElement) : list TargetModelElement :=
  flat_map (fun r => instantiateRuleOnPattern r sm sp) (matchPattern tr sm sp).

Definition instantiateRuleOnPatternIterName (r: Rule) (sm: SourceModel) (sp: list SourceModelElement) (iter: nat) (name: string): option (TargetModelElement) :=
  match (Rule_findOutputPatternElement r name) with
  | Some o =>  instantiateElementOnPattern o sm sp iter
  | None => None
  end.

(** * Trace **)

Definition traceElementOnPattern (o: OutputPatternElement) (sm: SourceModel) (sp: list SourceModelElement) (iter: nat)
  : option TraceLink :=
  match (instantiateElementOnPattern o sm sp iter) with
  | Some e => Some (buildTraceLink (sp, iter, OutputPatternElement_getName o) e)
  | None => None
  end.

Definition traceIterationOnPattern (r: Rule) (sm: SourceModel) (sp: list SourceModelElement) (iter: nat) :  list TraceLink :=
  flat_map (fun o => optionToList (traceElementOnPattern o sm sp iter))
    (Rule_getOutputPatternElements r).

Definition traceRuleOnPattern (r: Rule) (sm: SourceModel) (sp: list SourceModelElement) :  list TraceLink :=
  flat_map (traceIterationOnPattern r sm sp)
    (seq 0 (evalIteratorExpr r sm sp)).

Definition tracePattern (tr: Transformation) (sm : SourceModel) (sp: list SourceModelElement) : list TraceLink :=
  flat_map (fun r => traceRuleOnPattern r sm sp) (matchPattern tr sm sp).

Definition maxArity (tr: Transformation) : nat := Transformation_getArity tr.

Definition allTuples (tr: Transformation) (sm : SourceModel) :list (list SourceModelElement) :=
  tuples_up_to_n (allModelElements sm) (maxArity tr).

Definition trace (tr: Transformation) (sm : SourceModel) : list TraceLink :=
  flat_map (tracePattern tr sm) (allTuples tr sm).

Definition resolveIter (tls: list TraceLink) (sm: SourceModel) (name: string)
            (sp: list SourceModelElement)
            (iter : nat) : option TargetModelElement :=
let tl := find (fun tl: TraceLink =>
  (list_beq SourceModelElement SourceElement_eqb (TraceLink_getSourcePattern tl) sp) &&
  ((TraceLink_getIterator tl) =? iter) &&
  ((TraceLink_getName tl) =? name)%string) tls in
match tl with
  | Some tl' => Some (TraceLink_getTargetElement tl')
  | None => None
end.

Definition resolve (tr: list TraceLink) (sm: SourceModel) (name: string)
  (sp: list SourceModelElement) : option TargetModelElement :=
  resolveIter tr sm name sp 0.

Definition resolveAllIter (tr: list TraceLink) (sm: SourceModel) (name: string)
  (sps: list(list SourceModelElement)) (iter: nat)
  : option (list TargetModelElement) :=
  Some (flat_map (fun l:(list SourceModelElement) => optionToList (resolveIter tr sm name l iter)) sps).

Definition resolveAll (tr: list TraceLink) (sm: SourceModel) (name: string)
  (sps: list(list SourceModelElement)) : option (list TargetModelElement) :=
  resolveAllIter tr sm name sps 0.

Definition maybeResolve (tr: list TraceLink) (sm: SourceModel) (name: string)
  (sp: option (list SourceModelElement)) : option TargetModelElement :=
  match sp with
  | Some sp' => resolve tr sm name sp'
  | None => None
  end.

Definition maybeResolveAll (tr: list TraceLink) (sm: SourceModel) (name: string)
  (sp: option (list (list SourceModelElement))) : option (list TargetModelElement) :=
  match sp with
  | Some sp' => resolveAll tr sm name sp'
  | None => None
  end.

(** * Apply **)

Definition applyElementOnPattern
            (ope: OutputPatternElement)
            (tr: Transformation)
            (sm: SourceModel)
            (sp: list SourceModelElement) (iter: nat) : list TargetModelLink :=
  match (evalOutputPatternElementExpr sm sp iter ope) with
  | Some l => optionListToList (evalOutputPatternLinkExpr sm sp l iter (trace tr sm) ope)
  | None => nil
  end.

Definition applyIterationOnPattern (r: Rule) (tr: Transformation) (sm: SourceModel) (sp: list SourceModelElement) (iter: nat) : list TargetModelLink :=
  flat_map (fun o => applyElementOnPattern o tr sm sp iter)
    (Rule_getOutputPatternElements r).

Definition applyRuleOnPattern (r: Rule) (tr: Transformation) (sm: SourceModel) (sp: list SourceModelElement): list TargetModelLink :=
  flat_map (applyIterationOnPattern r tr sm sp)
    (seq 0 (evalIteratorExpr r sm sp)).

Definition applyPattern (tr: Transformation) (sm : SourceModel) (sp: list SourceModelElement) : list TargetModelLink :=
  flat_map (fun r => applyRuleOnPattern r tr sm sp) (matchPattern tr sm sp).

(** * Execute **)

Definition execute (tr: Transformation) (sm : SourceModel) : TargetModel :=
  Build_Model
    (* elements *) (flat_map (instantiatePattern tr sm) (allTuples tr sm))
    (* links *) (flat_map (applyPattern tr sm) (allTuples tr sm)).

End Semantics.


(** Heavily annotated for a tutorial introduction.
 ** See the Makefile for how to strip the annotations
 **)

(** First, import the entire Floyd proof automation system, which
 ** includes the VeriC program logic and the MSL theory of separation logic
 **)
Require Import floyd.proofauto.

(** Import the theory of list segments.  This is not, strictly speaking,
 ** part of the Floyd system.  In principle, any user of Floyd can build
 ** theories of new data structures (list segments, trees, doubly linked
 ** lists, trees with cross edges, etc.).  We emphasize this by putting
 ** list_dt in the progs directory.   "dt" stands for "dependent types",
 ** as the theory uses Coq's dependent types to handle user-defined
 ** record fields.
 **)
Require Import progs.list_dt. Import LsegSpecial.

(** Import the [reverse.v] file, which is produced by CompCert's clightgen
 ** from reverse.c.   The file reverse.v defines abbreviations for identifiers
 ** (variable names, etc.) of the C program, such as _head, _reverse.
 ** It also defines "prog", which is the entire abstract syntax tree
 ** of the C program in the reverse.c file.
 **)
Require Import progs.reverse.

(* The C programming language has a special namespace for struct
** and union identifiers, e.g., "struct foo {...}".  Some type-based operators
** in the program logic need access to an interpretation of this namespace,
** i.e., the meaning of each struct-identifier such as "foo".  The next
** line (which looks identical for any program) builds this
** interpretation, called "CompSpecs" *)
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

(** The reverse.c program uses the linked list structure [struct list].
 ** This satisfies the linked-list pattern, in that it has one self-reference
 ** field (in this case, called [tail]) and arbitrary other fields.  The [Instance]
 ** explains (and proves) how [struct list] satisfies the [listspec] pattern.
 **)
Instance LS: listspec _list _tail (fun _ _ => emp).
Proof. eapply mk_listspec; reflexivity. Defined.

(**  An auxiliary definition useful in the specification of [sumlist] *)
Definition sum_int := fold_right Int.add Int.zero.

Definition t_struct_list := Tstruct _list noattr.

(** Specification of the [sumlist] function from reverse.c.  All the functions
 ** defined in the file, AND extern functions imported by the .c file,
 ** must be declared in this way.
 **)
Definition sumlist_spec :=
 DECLARE _sumlist
  WITH sh : share, contents : list int, p: val
  PRE [ _p OF (tptr t_struct_list) ]
     PROP(readable_share sh)
     LOCAL (temp _p p)
     SEP (lseg LS sh (map Vint contents) p nullval)
  POST [ tint ]
     PROP()
     LOCAL(temp ret_temp (Vint (sum_int contents)))
     SEP (lseg LS sh (map Vint contents) p nullval).

Definition reverse_spec :=
 DECLARE _reverse
  WITH sh : share, contents : list val, p: val
  PRE  [ _p OF (tptr t_struct_list) ]
     PROP (writable_share sh)
     LOCAL (temp _p p)
     SEP (lseg LS sh contents p nullval)
  POST [ (tptr t_struct_list) ]
    EX p:val,
     PROP () LOCAL (temp ret_temp p)
     SEP (lseg LS sh (rev contents) p nullval).

(** The "main" function is special, since its precondition includes
 ** the spatial (SEP) resource describing all the extern initialized
 ** global variables.  That resource is calculated automatically
 ** from the program (prog) by the "main_pre" operator.  **)
Definition main_spec :=
 DECLARE _main
  WITH u : unit
  PRE  [] main_pre prog nil u
  POST [ tint ] main_post prog nil u.

(** Declare all the functions, in exactly the same order as they
 ** appear in reverse.c (and in reverse.v).
 **)
Definition Gprog : funspecs :=   ltac:(with_library prog [
    sumlist_spec; reverse_spec; main_spec]).

(** A little equation about the list_cell predicate *)
Lemma list_cell_eq: forall sh i p ,
   sepalg.nonidentity sh ->
   field_compatible t_struct_list [] p ->
   list_cell LS sh (Vint i) p =
   field_at sh t_struct_list (DOT _head) (Vint i) p.
Proof.
  intros.
  unfold list_cell, field_at; simpl.
  rewrite !prop_true_andp by auto with field_compatible.
  reflexivity.
Qed.

(** Here's a loop invariant for use in the body_sumlist proof *)
Definition sumlist_Inv (sh: share) (contents: list int) (p: val) : environ->mpred :=
          (EX cts1: list int, EX cts2: list int, EX t: val,
            PROP (contents = cts1++cts2)
            LOCAL (temp _t t; temp _s (Vint (sum_int cts1)))
            SEP ( lseg LS sh (map Vint cts1) p t ; lseg LS sh (map Vint cts2) t nullval)).

Lemma sum_int_app:
  forall a b, sum_int (a++b) = Int.add (sum_int a) (sum_int b).
Proof.
intros.
induction a; simpl. rewrite Int.add_zero_l; auto.
rewrite IHa. rewrite Int.add_assoc. auto.
Qed.

(** For every function definition in the C program, prove that the
 ** function-body (in this case, f_sumlist) satisfies its specification
 ** (in this case, sumlist_spec).
 **)
Lemma body_sumlist: semax_body Vprog Gprog f_sumlist sumlist_spec.
Proof.
(** Here is the standard way to start a function-body proof:  First,
 ** start-function; then forward.
 **)
start_function.
forward.  (* s = 0; *)
forward.  (* t = p; *)
forward_while (sumlist_Inv sh contents p).
* (* Prove that current precondition implies loop invariant *)
Exists (@nil int) contents p.
entailer!. cancel.
* (* Prove that loop invariant implies typechecking condition *)
entailer!.
* (* Prove that loop body preserves invariant *)
focus_SEP 1; apply semax_lseg_nonnull; [ | intros h' r y ? ?].
entailer!.
destruct cts2; inversion H0; clear H0; subst_any.
simpl. (* this line not necessary, but makes things look nicer *)
assert_PROP (field_compatible t_struct_list nil t) as FC by entailer!.
rewrite list_cell_eq by auto.
forward.  (* h = t->head; *)
forward.  (*  t = t->tail; *)
forward.  (* s = s + h; *)
Exists (cts1++[i],cts2,y).
entailer.
apply andp_right.
apply prop_right.
split.
rewrite app_ass; reflexivity.
 f_equal. rewrite sum_int_app. f_equal. simpl. apply Int.add_zero.
rewrite map_app. simpl map.
eapply derives_trans; [ | apply (lseg_cons_right_list LS) with (y:=t); auto].
rewrite list_cell_eq by auto.
cancel.
* (* After the loop *)
forward.  (* return s; *)
destruct cts2; [| inversion H]. rewrite <- app_nil_end.
entailer!.
Qed.

Definition reverse_Inv (sh: share) (contents: list val) : environ->mpred :=
          (EX cts1: list val, EX cts2 : list val, EX w: val, EX v: val,
            PROP (contents = rev cts1 ++ cts2)
            LOCAL (temp _w w; temp _v v)
            SEP (lseg LS sh cts1 w nullval;
                   lseg LS sh cts2 v nullval)).

Lemma body_reverse: semax_body Vprog Gprog f_reverse reverse_spec.
Proof.
start_function.
forward.  (* w = NULL; *)
forward.  (* v = p; *)
forward_while (reverse_Inv sh contents).
* (* precondition implies loop invariant *)
Exists (@nil val) contents nullval p.
rewrite lseg_eq by (simpl; auto).
entailer!.
* (* loop invariant implies typechecking of loop condition *)
entailer!.
* (* loop body preserves invariant *)
focus_SEP 1; apply semax_lseg_nonnull;
        [entailer | intros h r y ? ?; simpl].
subst cts2.
forward. (* t = v->tail; *)
forward. (* v->tail = w; *)
(* The following line is optional, the proof works without it. *)
replace_SEP 2 (field_at sh t_struct_list (DOT _tail) w v) by entailer!.
forward.  (*  w = v; *)
forward.  (* v = t; *)
(* at end of loop body, re-establish invariant *)
Exists (h::cts1,r,v,y).
entailer!.  (* smt_test verif_reverse_example2 *)
 - rewrite app_ass. auto.
 - rewrite (lseg_unroll _ sh (h::cts1)).
   apply orp_right2.
   unfold lseg_cons.
   apply andp_right.
   + apply prop_right.
      destruct v; try contradiction; intro Hx; inv Hx.
   + Exists h cts1 w.
      entailer!.
* (* after the loop *)
forward.  (* return w; *)
Exists w; entailer!.
rewrite <- app_nil_end, rev_involutive.
auto.
Qed.

(** The next lemma concerns the extern global initializer,
 ** struct list three[] = {{1, three+1}, {2, three+2}, {3, NULL}};
 ** This is equivalent to a linked list of three elements [1,2,3].
 ** The proof is not very beautiful at present; it would be helpful
 ** to have a nicer proof theory for reasoning about this kind of thing.
 **)

Lemma setup_globals:
 forall Delta x,
  (glob_types Delta) ! _three = Some (tarray t_struct_list 3) ->
  ENTAIL Delta, PROP  ()
   LOCAL  (gvar _three x)
   SEP
   (mapsto Ews tuint (offset_val 0 x) (Vint (Int.repr 1));
    mapsto Ews (tptr t_struct_list) (offset_val 4 x)
        (offset_val 8 x);
   mapsto Ews tuint (offset_val 8 x) (Vint (Int.repr 2));
   mapsto Ews (tptr t_struct_list) (offset_val 12 x)
       (offset_val 16 x);
   mapsto Ews tuint (offset_val 16 x) (Vint (Int.repr 3));
   mapsto Ews tuint (offset_val 20 x) (Vint (Int.repr 0)))
  |-- PROP() LOCAL(gvar _three x)
        SEP (lseg LS Ews (map Vint (Int.repr 1 :: Int.repr 2 :: Int.repr 3 :: nil))
                  x nullval).
Proof.
 intros.
  go_lower.
  rewrite !prop_true_andp by auto.
  rewrite <- (sepcon_emp (mapsto _ _ (offset_val 20 _) _)).
  assert (FC: field_compatible (tarray t_struct_list 3) [] x)
    by (hnf; repeat apply conj; auto; compute; auto).
  (* apply field_compatible_offset_zero in FC. *)
  match goal with |- ?A |-- _ => set (a:=A) end.
  replace x with (offset_val 0 x) by normalize.
  subst a.

  repeat
    match goal with |- _ * (mapsto _ _ _ ?q * _) |-- lseg _ _ _ (offset_val ?n _) _ =>
    assert (FC': field_compatible t_struct_list [] (offset_val n x));
      [apply (@field_compatible_nested_field CompSpecs (tarray t_struct_list 3)
         [ArraySubsc (n/8)] x);
       simpl;
       unfold field_compatible in FC |- *; simpl in FC |- *;
       assert (0 <= n/8 < 3) by (cbv [Z.div]; simpl; omega);
       tauto
      |];
    apply @lseg_unroll_nonempty1 with q;
      [destruct x; try contradiction; intro Hx; inv Hx | normalize; reflexivity | ];
    rewrite list_cell_eq by auto;
    do 2 (apply sepcon_derives;
      [ unfold field_at; rewrite prop_true_andp by auto with field_compatible;
        unfold data_at_rec, at_offset; simpl; normalize | ]);
    clear FC'
    end.

  rewrite mapsto_tuint_tptr_nullval; auto.
  rewrite @lseg_nil_eq.
  rewrite prop_true_andp; auto.
  split; reflexivity.
Qed.

Lemma body_main:  semax_body Vprog Gprog f_main main_spec.
Proof.
name three _three.
start_function.
change (Tstruct _ _) with t_struct_list.
fold noattr. fold (tptr t_struct_list).
eapply semax_pre; [
  eapply ENTAIL_trans; [ | apply (setup_globals Delta three); auto ] | ].
 entailer!.
forward_call (*  r = reverse(three); *)
  (Ews, map Vint [Int.repr 1; Int.repr 2; Int.repr 3], three).
Intros r'.
rewrite <- map_rev. simpl rev.
forward_call  (* s = sumlist(r); *)
   (Ews, Int.repr 3 :: Int.repr 2 :: Int.repr 1 :: nil, r').
forward.  (* return s; *)
Qed.

Existing Instance NullExtension.Espec.

Lemma all_funcs_correct:
  semax_func Vprog Gprog (prog_funct prog) Gprog.
Proof.
unfold Gprog, prog, prog_funct; simpl.
semax_func_cons body_sumlist.
semax_func_cons body_reverse.
semax_func_cons body_main.
Qed.


Require Import Mem0 Mem1 HoareDef STB SimModSem.
Require Import Coqlib.
Require Import ImpPrelude.
Require Import Skeleton.
Require Import PCM.
Require Import ModSem Behavior.
Require Import Relation_Definitions.

(*** TODO: export these in Coqlib or Universe ***)
Require Import Relation_Operators.
Require Import RelationPairs.
From ITree Require Import
     Events.MapDefault.
From ExtLib Require Import
     Core.RelDec
     Structures.Maps
     Data.Map.FMapAList.
Require Import HTactics ProofMode.

Set Implicit Arguments.

Local Open Scope nat_scope.

(*** black + delta --> new_black ***)
Definition add_delta_to_black `{M: URA.t} (b: Auth.t M) (w: Auth.t _): Auth.t _ :=
  match b, w with
  | Auth.excl e _, Auth.frag f1 => Auth.excl (e ⋅ f1) URA.unit
  | _, _ => Auth.boom
  end
.

(*** TODO: move to Coqlib ***)
Lemma repeat_nth_some
      X (x: X) sz ofs
      (IN: ofs < sz)
  :
    nth_error (repeat x sz) ofs = Some x
.
Proof.
  ginduction sz; ii; ss.
  - lia.
  - destruct ofs; ss. exploit IHsz; et. lia.
Qed.

Lemma repeat_nth_none
      X (x: X) sz ofs
      (IN: ~(ofs < sz))
  :
    nth_error (repeat x sz) ofs = None
.
Proof.
  generalize dependent ofs. induction sz; ii; ss.
  - destruct ofs; ss.
  - destruct ofs; ss. { lia. } hexploit (IHsz ofs); et. lia.
Qed.

Lemma repeat_nth
      X (x: X) sz ofs
  :
    nth_error (repeat x sz) ofs = if (ofs <? sz) then Some x else None
.
Proof.
  des_ifs.
  - eapply repeat_nth_some; et. apply_all_once Nat.ltb_lt. ss.
  - eapply repeat_nth_none; et. apply_all_once Nat.ltb_ge. lia.
Qed.

Ltac Ztac := all_once_fast ltac:(fun H => first[apply Z.leb_le in H|apply Z.ltb_lt in H|apply Z.leb_gt in H|apply Z.ltb_ge in H|idtac]).

Lemma _points_to_hit: forall b ofs v, (_points_to (b, ofs) [v] b ofs) = (Some v).
Proof. i. rewrite unfold_points_to. ss. des_ifs; bsimpl; des; des_sumbool; subst; Ztac; try lia. rewrite Z.sub_diag. ss. Qed.

Lemma _points_to_miss: forall b ofs b' ofs' (MISS: b <> b' \/ ofs <> ofs') v, (_points_to (b, ofs) [v] b' ofs') = ε.
Proof. i. rewrite unfold_points_to. ss. des_ifs; bsimpl; des; des_sumbool; subst; Ztac; try lia. Qed.

Lemma _points_to_disj: forall b0 ofs0 v0 b1 ofs1 v1,
    URA.wf (_points_to (b0, ofs0) [v0] ⋅ _points_to (b1, ofs1) [v1]) -> b0 <> b1 \/ ofs0 <> ofs1.
Proof.
  ii. do 2 ur in H. specialize (H b0 ofs0). rewrite _points_to_hit in H.
  rewrite unfold_points_to in H. ss. ur in H. des_ifs_safe. des_ifs; bsimpl; des; des_sumbool; subst; Ztac; try lia.
  assert(ofs0 = ofs1) by lia. subst. rewrite Z.sub_diag in *. ss.
Qed.

Lemma dec_true: forall X `{Dec X} (x0 x1: X), x0 = x1 -> ((dec x0 x1): bool) = true.
Proof. ii. subst. unfold dec. destruct H; ss. Qed.

Lemma dec_false: forall X `{Dec X} (x0 x1: X), x0 <> x1 -> ((dec x0 x1): bool) = false.
Proof. ii. subst. unfold dec. destruct H; ss. Qed.
(* Lemma local_update_same *)
(*       `{M: URA.t} *)
(*       x0 y0 x1 y1 *)
(*       (SAME: x0 ⋅ y0 = x1 ⋅ y1) *)
(*   : *)
(*     URA.local_update x0 y0 x1 y1 *)
(* . *)
(* Proof. *)
(*   r. ii. des. subst. esplits; et. *)
(*   - *)
(* Qed. *)

Section SIMMODSEM.

  Context `{Σ: GRA.t}.
  Context `{@GRA.inG Mem1.memRA Σ}.

  (* Eval compute in (@RA.car (RA.excl Mem.t)). *)
  Eval compute in (@URA.car Mem1._memRA).
  Inductive sim_loc: URA.car (t:=(Excl.t _)) -> option val -> Prop :=
  | sim_loc_present v: sim_loc (Some v) (Some v)
  | sim_loc_absent: sim_loc ε None
  .
  Hint Constructors sim_loc: core.

  Let W: Type := Any.t * Any.t.
  (* Let wf: W -> Prop := *)
  (*   @mk_wf *)
  (*     _ *)
  (*     Mem.t *)
  (*     (fun mem_tgt _ mp_tgt => (∃ mem_src, (OwnM ((Auth.black mem_src): URA.car (t:=Mem1.memRA))) *)
  (*                                            ** *)
  (*                                            (⌜forall b ofs, sim_loc ((mem_tgt.(Mem.cnts)) b ofs) (mem_src b ofs)⌝) *)
  (*                                            ** *)
  (*                                            (⌜mp_tgt = mem_tgt↑ /\ forall b ofs v, mem_tgt.(Mem.cnts) b ofs = Some v -> <<NB: b < mem_tgt.(Mem.nb)>>⌝) *)
  (*                              )%I) *)
  (*     top4 *)
  (* . *)

  Definition mem_wf (m0: Mem.t): Prop :=
    forall b ofs v, m0.(Mem.cnts) b ofs = Some v -> <<NB: b < m0.(Mem.nb)>>
  .

  Let wf: _ -> W -> Prop :=
    @mk_wf
      _ unit
      (fun _ _ _mem_tgt0 =>
         (∃ (mem_tgt0: Mem.t) (memk_src0: URA.car (t:=Mem1._memRA)),
             (⌜(<<TGT: _mem_tgt0 = mem_tgt0↑>>) /\
              (<<SIM: forall b ofs, sim_loc (memk_src0 b ofs) (mem_tgt0.(Mem.cnts) b ofs)>>) /\
              (<<WFTGT: mem_wf mem_tgt0>>)⌝) ∧ (*** TODO: put it inside Mem.t? ***)
             (OwnM ((Auth.black memk_src0): URA.car (t:=Mem1.memRA)))
         )%I)
  .

  Hint Resolve sim_itree_mon: paco.

  Opaque URA.unit.

  Ltac renamer :=
    let tmp := fresh "_tmp_" in

    match goal with
    | H: context[OwnM (Auth.black ?x)] |- _ =>
      rename x into tmp; let name := fresh "memk_src0" in rename tmp into name
    end;

    match goal with
    | |- gpaco8 _ _ _ _ _ _ _ _ _ _ _ ((?mp_tgt↑), _) =>

      repeat multimatch mp_tgt with
             | context[?g] =>
               match (type of g) with
               | Mem.t =>
                 rename g into tmp; let name := fresh "mem_tgt0" in rename tmp into name
               | _ => fail
               end
             end
    end
  .

  Variable csl: gname -> bool.

  Theorem correct_modsem: forall sk, ModSemPair.sim (SModSem.to_tgt (to_stb [])
                                           (Mem1.SMemSem (negb ∘ csl) sk)) (Mem0.MemSem csl sk).
  Proof.
   econstructor 1 with (wf:=wf) (le:=top2); et; swap 2 3.
   { ss. }
    { ss. eexists. econs; ss. eapply to_semantic.
      iIntros "H". iSplits; ss; et.
      { iPureIntro. ii. unfold Mem.load_mem, initial_mem_mr.
        cbn. uo. des_ifs; et; try (by econs; et). }
      { iPureIntro. ii. ss. uo. des_ifs.
        apply nth_error_Some. ii. clarify. }
    }

    econs; ss.
    { unfold allocF. init.
      harg. fold wf. steps. hide_k. rename x into sz.
      { mDesAll; ss. des; subst.
        des_ifs_safe (mDesAll; ss). des; subst. clarify. rewrite Any.upcast_downcast in *. clarify.
        steps. unhide_k. steps. des_ifs; clarify.
        2:{ bsimpl; des; ss; apply sumbool_to_bool_false in Heq; try lia. }
        steps. astart 0. astop.
        renamer.
        set (blk := mem_tgt0.(Mem.nb) + x).

        mAssert _ with "INV" as "INV".
        { iApply (OwnM_Upd with "INV").
          eapply Auth.auth_alloc2.
          instantiate (1:=(_points_to (blk, 0%Z) (repeat (Vundef) sz))).
          mOwnWf "INV".
          clear - WF0 WFTGT SIM.
          ss. do 2 ur. ii. rewrite unfold_points_to. des_ifs.
          - bsimpl. des. des_sumbool. subst. hexploit (SIM blk k0); et. intro T.
            inv T; eq_closure_tac.
            + exploit WFTGT; et. i; des. lia.
            + rewrite URA.unit_idl. Ztac. rewrite repeat_length in *. rewrite Z.sub_0_r. rewrite repeat_nth_some; [|lia]. ur. ss.
          - rewrite URA.unit_id. do 2 eapply lookup_wf. eapply Auth.black_wf; et.
        }
        mUpd "INV". mDesOwn "INV". steps.

        force_l. eexists. steps. hret _; ss. iModIntro. iSplitR "A"; cycle 1.
        { iSplitL; ss. iExists _. iSplitR; ss. }
        iExists _, _. iSplitR; ss. iPureIntro. esplits; et.
        - i. destruct (mem_tgt0.(Mem.cnts) blk ofs) eqn:T.
          { exfalso. exploit WFTGT; et. i; des. lia. }
          ss. do 2 ur.
          exploit SIM; et. rewrite T. intro U. inv U. rewrite unfold_points_to. ss. rewrite repeat_length.
          destruct (dec b blk); subst; ss.
          * unfold update. des_ifs_safe. rewrite <- H1. rewrite URA.unit_idl.
            rewrite Z.sub_0_r. rewrite Z.add_0_l. des_ifs.
            { bsimpl. des. Ztac. rewrite repeat_nth_some; try lia. econs. }
          * rewrite URA.unit_id. unfold update. des_ifs.
        - clear - WFTGT. ii. ss. unfold update in *. des_ifs. exploit WFTGT; et. i; des. r. lia.
      }
    }

    econs; ss.
    { unfold freeF. init.
      harg. fold wf. steps. hide_k.
      { des_ifs_safe (mDesAll; ss). des; subst.
        des_ifs; mDesAll; ss. des; subst. clarify. rewrite Any.upcast_downcast in *. clarify.
        steps. unhide_k. steps. astart 0. astop.
        renamer. rename n into b. rename z into ofs.
        rename a into v. rename WF into SIMWF.
        mCombine "INV" "A". mOwnWf "INV".
        assert(HIT: memk_src0 b ofs = (Some v)).
        { clear - WF.
          dup WF. eapply Auth.auth_included in WF. des. eapply pw_extends in WF. eapply pw_extends in WF.
          spc WF. rewrite _points_to_hit in WF.
          eapply Excl.extends in WF; ss. do 2 eapply lookup_wf. eapply Auth.black_wf. eapply URA.wf_mon; et.
        }
        set (memk_src1 := fun _b _ofs => if dec _b b && dec _ofs ofs
                                         then (ε: URA.car (t:=Excl.t _)) else memk_src0 _b _ofs).
        assert(WF': URA.wf (memk_src1: URA.car (t:=Mem1._memRA))).
        { clear - WF. unfold memk_src1. do 2 ur. ii. eapply URA.wf_mon in WF. ur in WF. des.
          des_ifs; et.
          - rp; [eapply URA.wf_unit|ss].
          - do 2 eapply lookup_wf; et.
        }
        hexploit (SIM b ofs); et. rewrite HIT. intro B. inv B.
        force_r.
        { unfold Mem.free in *. des_ifs. }
        rename t into mem_tgt1.

        mAssert _ with "INV" as "INV".
        { iApply (OwnM_Upd with "INV").
          Local Transparent points_to.
          eapply Auth.auth_dealloc.
          instantiate (1:=memk_src1).
          clear - WF'.

          r. i. rewrite URA.unit_idl.
          Local Opaque Mem1._memRA.
          ss. destruct H; clear H. (*** coq bug; des infloops ***) des. clarify.
          esplits; et.
          Local Transparent Mem1._memRA.
          unfold memk_src1. ss.
          apply func_ext. intro _b. apply func_ext. intro _ofs.
          des_ifs.
          - bsimpl; des; des_sumbool; subst.
            subst memk_src1. do 2 ur in WF'. do 2 spc WF'. des_ifs; bsimpl; des; des_sumbool; ss.
            clear - H0.
            do 2 ur in H0.
            specialize (H0 b ofs). rewrite _points_to_hit in H0. eapply Excl.wf in H0. des; ss.
          - rewrite unfold_points_to in *. do 2 ur. do 2 ur in H0.
            bsimpl. des_ifs; bsimpl; des; des_sumbool; subst; Ztac; try lia; try rewrite URA.unit_idl; try refl.
        }
        mUpd "INV".
        steps. force_l. eexists. steps. hret _; ss. iModIntro. iSplitL; cycle 1.
        { iPureIntro. ss. }
        iExists _, _. iSplitR "INV"; et. iPureIntro. esplits; ss; et.
        - { i. unfold Mem.free in _UNWRAPU. des_ifs. ss.
            subst memk_src1. ss.
            destruct (classic (b = b0 /\ ofs = ofs0)); des; clarify.
            - unfold update. des_ifs.
            - des_ifs.
              { Psimpl. bsimpl; des; des_sumbool; ss; clarify. }
              replace (update (Mem.cnts mem_tgt0) b (update (Mem.cnts mem_tgt0 b) ofs None) b0 ofs0) with
                  (Mem.cnts mem_tgt0 b0 ofs0); cycle 1.
              { unfold update. des_ifs. Psimpl. des_ifs; bsimpl; des; des_sumbool; ss; clarify. }
              et.
          }
        - clear - _UNWRAPU WFTGT. ii. unfold Mem.free in *. des_ifs. ss.
          unfold update in *. des_ifs; eapply WFTGT; et.
      }
    }

    econs; ss.
    { unfold loadF. init.
      harg. fold wf. steps. hide_k.
      { des_ifs_safe (mDesAll; ss). des; subst. clarify. rewrite Any.upcast_downcast in *. clarify.
        steps. unhide_k. steps. astart 0. astop.
        renamer. rename n into b. rename z into ofs.
        rename WF into SIMWF.
        mCombine "INV" "A". mOwnWf "INV".
        assert(T: memk_src0 b ofs = (Some v)).
        { clear - WF.
          dup WF.
          eapply Auth.auth_included in WF. des.
          eapply pw_extends in WF. eapply pw_extends in WF. spc WF. rewrite _points_to_hit in WF. des; ss.
          eapply Excl.extends in WF; ss. do 2 eapply lookup_wf. eapply Auth.black_wf. eapply URA.wf_mon; et.
        }
        hexploit SIM; et. intro U. rewrite T in U. inv U; ss. unfold Mem.load.
        mDesOwn "INV".
        force_r; ss. clarify. steps. force_l. esplits. steps.
        hret _; ss. iModIntro. iFrame. iSplitL; et.
      }
    }

    econs; ss.
    { unfold storeF. init.
      harg. fold wf. steps. hide_k.
      { des_ifs_safe (mDesAll; ss). des; subst. clarify. rewrite Any.upcast_downcast in *. clarify.
        steps. unhide_k. steps. astart 0. astop.
        renamer.
        rename n into b. rename z into ofs. rename v into v1.
        rename a into v0. rename WF into SIMWF.
        steps.
        mCombine "INV" "A". mOwnWf "INV".
        assert(T: memk_src0 b ofs = (Some v0)).
        { clear - WF.
          dup WF.
          eapply Auth.auth_included in WF. des.
          eapply pw_extends in WF. eapply pw_extends in WF. spc WF. rewrite _points_to_hit in WF.
          des; ss.
          eapply Excl.extends in WF; ss. do 2 eapply lookup_wf. eapply Auth.black_wf. eapply URA.wf_mon; et.
        }
        hexploit SIM; et. intro U. rewrite T in U. inv U; ss. unfold Mem.store. des_ifs. steps.
        set (memk_src1 := fun _b _ofs => if dec _b b && dec _ofs ofs then (Some v1: URA.car (t:=Excl.t _)) else memk_src0 _b _ofs).
        assert(WF': URA.wf (memk_src1: URA.car (t:=Mem1._memRA))).
        { clear - WF. unfold memk_src1. do 2 ur. ii. eapply URA.wf_mon in WF. ur in WF. des.
          des_ifs; et.
          - bsimpl; des; des_sumbool; subst. ur; ss.
          - do 2 eapply lookup_wf; et.
        }
        mAssert _ with "INV" as "INV".
        { iApply (OwnM_Upd with "INV").
          eapply Auth.auth_update with (a':=memk_src1) (b':=_points_to (b, ofs) [v1]); et.
          clear - wf WF'. ii. des. subst. esplits; et.
          do 2 ur in WF'. do 2 spc WF'.
          subst memk_src1. ss. des_ifs; bsimpl; des; des_sumbool; ss.
          do 2 ur. do 2 (apply func_ext; i). des_ifs.
          - bsimpl; des; des_sumbool; subst. rewrite _points_to_hit.
            do 2 ur in WF. do 2 spc WF. rewrite _points_to_hit in WF. eapply Excl.wf in WF. rewrite WF. ur; ss.
          - bsimpl; des; des_sumbool; rewrite ! _points_to_miss; et.
        }
        mUpd "INV". mDesOwn "INV".

        mEval ltac:(fold (points_to (b,ofs) [v1])) in "A".
        force_l. eexists. steps.
        hret _; ss. iModIntro. iFrame. iSplitL; ss; et.
        iExists _, _. iSplitR "INV"; et. iPureIntro. esplits; ss; et.
        - ii. cbn. des_ifs.
          + bsimpl; des; des_sumbool; subst. do 2 spc SIM. rewrite T in *. inv SIM.
            unfold memk_src1. rewrite ! dec_true; ss. econs.
          + replace (memk_src1 b0 ofs0) with (memk_src0 b0 ofs0); et.
            unfold memk_src1. des_ifs; bsimpl; des; des_sumbool; clarify; ss.
        - ii. ss. des_ifs.
          + bsimpl; des; des_sumbool; subst. eapply WFTGT; et.
          + eapply WFTGT; et.
      }
    }

    econs; ss.
    { unfold cmpF. init.
      harg. fold wf. steps. hide_k.
      { des_ifs_safe (mDesAll; ss). des; subst. clarify.
        steps. unhide_k. steps. astart 0. astop.
        renamer.
        rename b into result. rename c into resource. rename WF into SIMWF.
        assert (VALIDPTR: forall b ofs v (WF: URA.wf ((Auth.black (memk_src0: URA.car (t:=Mem1._memRA))) ⋅ ((b, ofs) |-> [v]))),
                   Mem.valid_ptr mem_tgt0 b ofs = true).
        { clear - SIM. i. cut (memk_src0 b ofs = Some v).
          - i. unfold Mem.valid_ptr.
            specialize (SIM b ofs). rewrite H in *. inv SIM. ss.
          - clear - WF.
            dup WF.
            eapply Auth.auth_included in WF. des.
            eapply pw_extends in WF. eapply pw_extends in WF. spc WF. rewrite _points_to_hit in WF.
            des; ss.
            eapply Excl.extends in WF; ss. do 2 eapply lookup_wf. eapply Auth.black_wf. eapply URA.wf_mon; et.
        }
        steps.
        mCombine "INV" "A". mOwnWf "INV". Fail mDesOwn "INV". (*** TODO: BUG!! FIXME ***)

        mDesOr "PRE".
        { mDesAll; subst. rewrite Any.upcast_downcast in *. clarify. steps.
          erewrite VALIDPTR; et. ss. steps.
          force_l. eexists. steps. hret _; ss. iModIntro. iDestruct "INV" as "[INV A]". iSplitR "A"; ss; et.
        }
        mDesOr "PRE".
        { mDesAll; subst. rewrite Any.upcast_downcast in *. clarify. steps.
          erewrite VALIDPTR; et. ss. steps.
          force_l. eexists. steps. hret _; ss. iModIntro. iDestruct "INV" as "[INV A]". iSplitR "A"; ss; et.
        }
        mDesOr "PRE".
        { mDesAll; subst. rewrite Any.upcast_downcast in *. clarify. steps.
          erewrite VALIDPTR; et; cycle 1.
          { rewrite URA.add_assoc in WF. eapply URA.wf_mon in WF; et. }
          erewrite VALIDPTR; et; cycle 1.
          { erewrite URA.add_comm with (a:=(a, a0) |-> [a1]) in WF.
            rewrite URA.add_assoc in WF. eapply URA.wf_mon in WF; et. }
          rewrite URA.add_comm in WF. eapply URA.wf_mon in WF. ur in WF; ss. steps.
          replace (dec a a2 && dec a0 a3 ) with false; cycle 1.
          { clear - WF.
            exploit _points_to_disj; et. intro NEQ. des; try (by rewrite dec_false; ss).
            erewrite dec_false with (x0:=a0); ss. rewrite andb_false_r; ss.
          }
          steps. force_l. eexists. steps. hret _; ss. iModIntro. iDestruct "INV" as "[INV A]". iSplitR "A"; ss; et.
        }
        mDesOr "PRE".
        { mDesAll; subst. rewrite Any.upcast_downcast in *. clarify. steps.
          erewrite VALIDPTR; et. ss. steps. rewrite ! dec_true; ss. steps.
          force_l. eexists. steps. hret _; ss. iModIntro. iDestruct "INV" as "[INV A]". iSplitR "A"; ss; et.
        }
        { mDesAll; subst. des; subst. rewrite Any.upcast_downcast in *. clarify. steps.
          force_l. eexists. steps. hret _; ss. iModIntro. iDestruct "INV" as "[INV A]". iSplitR "A"; ss; et.
        }
      }
    }
  Unshelve.
    all: ss. all: try exact 0.
  Qed.

  Theorem correct: refines2 [Mem0.Mem csl] [Mem1.Mem (negb ∘ csl)].
  Proof.
    eapply adequacy_local2. econs; ss; et. i. eapply correct_modsem.
  Qed.

End SIMMODSEM.