(* -*- coding: utf-8 -*- *)
(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*                                                                      *)
(* Micromega: A reflexive tactic using the Positivstellensatz           *)
(*                                                                      *)
(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
(*                                                                      *)
(************************************************************************)

Require Import ZArith.
Require Import Coq.Arith.Max.
Require Import List.
Set Implicit Arguments.

(*
 * This adds a Leaf constructor to the varmap data structure (plugins/quote/Quote.v)
 * --- it is harmless and spares a lot of Empty.
 * It also means smaller proof-terms.
 * As a side note, by dropping the polymorphism, one gets small, yet noticeable, speed-up.
 *)

Section MakeVarMap.

  Variable A : Type.
  Variable default : A.

  Inductive t  : Type :=
  | Empty : t
  | Leaf : A -> t
  | Node : t  -> A -> t  -> t .

  Fixpoint find (vm : t) (p:positive) {struct vm} : A :=
    match vm with
      | Empty => default
      | Leaf i => i
      | Node l e r => match p with
                        | xH => e
                        | xO p => find l p
                        | xI p => find r p
                      end
    end.

  Fixpoint singleton (x:positive) (v : A) : t :=
    match x with
    | xH => Leaf v
    | xO p => Node (singleton p v) default Empty
    | xI p => Node Empty default (singleton p v)
    end.

  Fixpoint vm_add (x: positive) (v : A) (m : t) {struct m} : t :=
    match m with
    | Empty   => singleton x v
    | Leaf vl =>
      match x with
      | xH => Leaf v
      | xO p => Node (singleton p v) vl Empty
      | xI p => Node Empty vl (singleton p v)
      end
    | Node l o r =>
      match x with
      | xH => Node l v r
      | xI p => Node l o (vm_add p v r)
      | xO p => Node (vm_add p v l) o r
      end
    end.

End MakeVarMap.


(*
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 * http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 *)

Require Import String.
Require Import List.
Require Import Sorting.
Require Import Eqdep_dec.
Require Import Bool.
Require Import EquivDec.
Require Import Morphisms.
Require Import Utils.
Require Import BrandRelation.
Require Import ForeignType.
Require Import RType.

Section RTypeNorm.
  (** Syntax of types. Note that there is no guarantee yet that records are well formed. i.e., having distinct fields. *)

  Context {ftype:foreign_type}.
  Context {br:brand_relation}.

  Fixpoint normalize_rtype₀ (r:rtype₀) : rtype₀ :=
    match r with
    | Bottom₀ => Bottom₀
    | Top₀ => Top₀
    | Unit₀ => Unit₀
    | Nat₀ => Nat₀
    | Float₀ => Float₀
    | Bool₀ => Bool₀
    | String₀ => String₀
    | Coll₀ r' => Coll₀ (normalize_rtype₀ r')
    | Rec₀ k srl => Rec₀ k (rec_sort (map (fun sr => ((fst sr), (normalize_rtype₀ (snd sr)))) srl))
    | Either₀ tl tr => Either₀ (normalize_rtype₀ tl) (normalize_rtype₀ tr)
    | Arrow₀ tin tout => Arrow₀ (normalize_rtype₀ tin) (normalize_rtype₀ tout)
    | Brand₀ bl => Brand₀ (canon_brands brand_relation_brands bl)
    | Foreign₀ ft => Foreign₀ ft
    end.

  Lemma exists_normalized_in_rec_sort x r:
    In x
       (rec_sort
          (map
             (fun sr : string * rtype₀ =>
                (fst sr, normalize_rtype₀ (snd sr))) r)) ->
    exists y,
      (In y r /\
       snd x = (normalize_rtype₀ (snd y))).
  Proof.
    intros.
    induction r.
    - contradiction.
    - simpl in *.
      destruct a; simpl in *.
      assert (x = (s, normalize_rtype₀ r0) \/ In x (rec_sort
              (map
                 (fun sr : string * rtype₀ =>
                    (fst sr, normalize_rtype₀ (snd sr))) r))) by
          (apply in_rec_sort_insert; assumption).
      elim H0; clear H0; intros.
      + exists (s, r0).
        split; [left;reflexivity|].
        rewrite H0; reflexivity.
      + elim (IHr H0); intros.
        elim H1; clear H1; intros.
        exists x0.
        split; [right;assumption|assumption].
  Qed.

  Lemma normalize_rtype₀_wf (r:rtype₀) :
    wf_rtype₀ (normalize_rtype₀ r) = true.
  Proof.
    induction r; try reflexivity; simpl; try assumption.
    - apply andb_true_intro; split.
      + apply (@rec_sort_pf string ODT_string).
      + rewrite Forall_forall in H.
        rewrite forallb_forall; intros.
        elim (exists_normalized_in_rec_sort x r H0); intros.
        elim H1; clear H1; intros.
        rewrite H2.
        apply (H x0 H1).
    - apply andb_true_intro; split; assumption.
    - apply andb_true_intro; split; assumption.
    - destruct (is_canon_brands_dec brand_relation_brands
                                    (canon_brands brand_relation_brands b)).
      + reflexivity.
      + generalize (canon_brands_is_canon_brands brand_relation_brands b); intros.
        congruence.
  Qed.

  Program Definition normalize_rtype₀_to_rtype (r₀:rtype₀) : rtype :=
    exist _ (normalize_rtype₀ r₀) _.
  Next Obligation.
    apply normalize_rtype₀_wf.
  Defined.

End RTypeNorm.


Set Implicit Arguments.

Require Import Bedrock.Platform.Cito.ADT.
Require Import Bedrock.Platform.Cito.RepInv.

Module Make (Import E : ADT) (Import M : RepInv E).

  Require Import Bedrock.Platform.Cito.Inv.
  Module Import InvMake := Make E.
  Module Import InvMake2 := Make M.

  Require Import Bedrock.Platform.Cito.SyntaxFunc.
  Require Import Coq.Strings.String.
  Require Import Bedrock.Platform.Malloc.

  Section TopSection.

    Variable func : FuncCore.

    Definition spec_without_funcs_ok fs : assert :=
      st ~> ExX, internal_spec _ fs func st.

    Definition spec : assert :=
      st ~> Ex fs,
      let stn := fst st in
      funcs_ok stn fs /\
      spec_without_funcs_ok fs st.

    Definition imply (pre new_pre: assert) := forall specs x, interp specs (pre x) -> interp specs (new_pre x).

    Definition verifCond pre := imply pre spec :: nil.

  End TopSection.

End Make.


Require Import Axioms.
Require Import Tactics.
Require Import Sigma.
Require Import Equality.
Require Import Relation.
Require Import Syntax.
Require Import SimpSub.
Require Import Dynamic.
Require Import Ofe.
Require Import Spaces.
Require Import Uniform.
Require Import Urelsp.
Require Import Intensional.
Require Import Ordinal.
Require Import Candidate.
Require Import Model.
Require Import Truncate.
Require Import Standard.
Require Import System.
Require Import Semantics.
Require Import Extend.
Require Import SemanticsEqual.
Require Import Ceiling.
Require Import MapTerm.
Require Import Hygiene.
Require Import ExtendTruncate.
Require Import Equivalence.
Require Import SemanticsMu.
Require Import SemanticsPositive.

(* These two are needed for raise_robust.  The later could be dispensed with,
   with some work, by basing robust on step instead of reduce.
*)
Require Import ProperClosed.
Require Import ProperEquiv.

Section semantics.

Variable system : System.

Lemma interp_kext_fun :
  forall pg i m K K',
    interp_kext pg i m K
    -> interp_kext pg i m K'
    -> K = K'.
Proof.
intros pg i m K K' Hint Hint'.
destruct Hint as (Q & h & _ & Hsteps & _ & Heq).
destruct Hint' as (Q' & h' & _ & Hsteps' & _ & Heq').
so (determinism_eval _#4 (conj Hsteps value_ext) (conj Hsteps' value_ext)) as H.
injectionc H.
intro H.
injection (objin_inj _ _ _ H); clear H.
intros <-.
exact (eqtrans (eqsymm Heq) Heq').
Qed.

Lemma interp_uext_fun :
  forall pg i m R R',
    interp_uext pg i m R
    -> interp_uext pg i m R'
    -> R = R'.
Proof.
intros pg i m R R' Hint Hint'.
destruct Hint as (w & A & h & _ & Hsteps & _ & Heq).
destruct Hint' as (w' & A' & h' & _ & Hsteps' & _ & Heq').
so (determinism_eval _#4 (conj Hsteps value_ext) (conj Hsteps' value_ext)) as H.
injectionc H.
intro H.
injection (objin_inj _ _ _ H); clear H.
intros H <-.
injectionT H.
intros <-.
exact (eqtrans (eqsymm Heq) Heq').
Qed.

Lemma eval_bite_invert :
  forall object (m n p q : term object),
    eval (bite m n p) q
    -> (star step m btrue /\ star step n q)
       \/ (star step m bfalse /\ star step p q).
Proof.
intros object m n p q Heval.
destruct Heval as (Hsteps & Hval).
remember (bite m n p) as r eqn:Heq.
revert m Heq Hval.
induct Hsteps.

(* refl *)
{
intros q m -> Hval.
invert Hval.
intro H.
invert H.
}

(* step *)
{
intros x s q Hstep Hsteps IH m -> Hval.
invert Hstep.
  {
  intros m' Hstepm <-.
  so (IH m' (eq_refl _) Hval) as [(Hstepsm & Hstepsq) | (Hstepsm & Hstepsq)].
    {
    left.
    split; auto.
    eapply star_step; eauto.
    }

    {
    right.
    split; auto.
    eapply star_step; eauto.
    }
  }

  {
  intros <- <-.
  left.
  split; auto using star_refl.
  }

  {
  intros <- <-.
  right.
  split; auto using star_refl.
  }
}
Qed.

Definition exttin w X h :=
  @extt (obj stop) (objin (objsome (expair (qtype w) (iubase X)) h)).

Lemma subst_exttin :
  forall s w X h, subst s (exttin w X h) = exttin w X h.
Proof.
intros s w X h.
unfold exttin.
simpsub.
reflexivity.
Qed.

Hint Rewrite subst_exttin : subst.

Lemma subst_under_extt_hygiene :
  forall object a k (x y : object) s,
    hygiene clo (subst (compose (under k (dot (extt x) id)) s) a)
    -> hygiene clo (subst (compose (under k (dot (extt y) id)) s) a).
Proof.
intros object a k x y s Hcla.
so (hygiene_subst_invert _#4 Hcla) as H.
eapply hygiene_subst; eauto; clear H.
intros i Hi.
cbn in Hi.
rewrite -> project_compose in Hi |- *.
so (Nat.lt_trichotomy i k) as [Hik | [H | Hki]].
  {
  rewrite -> project_under_lt in Hi |- *; auto.
  }

  {
  subst i.
  rewrite -> project_under_eq.
  simpsub.
  apply hygiene_auto; cbn; auto.
  }

  {
  rewrite -> project_under_geq in Hi |- *; try omega.
  replace (i - k) with (S (i - k - 1)) in Hi |- * by omega.
  simpsub.
  simpsubin Hi.
  auto.
  }
Qed.

Lemma raise_robust_functional_ih :
  forall pg z i j A s b v w X Y (hv : v << stop) (hw : w << stop) F,
    v <<= cin pg
    -> w <<= cin pg
    -> extend_urel v stop X = extend_urel w stop Y
    -> (forall i s B,
          basic system pg z i (subst (compose (under (S j) (dot (exttin v X hv) id)) s) b) B
          -> basic system pg z i (subst (compose (under (S j) (dot (exttin w Y hw) id)) s) b) B)
    -> functional system pg z i A (subst (dot (var 0) (compose (under j (dot (exttin v X hv) id)) (compose s sh1))) b) F
    -> functional system pg z i A (subst (dot (var 0) (compose (under j (dot (exttin w Y hw) id)) (compose s sh1))) b) F.
Proof.
intros pg z i k A s b v w X Y hv hw F Hvpg Hwpg Heq IH Hfunct.
invert Hfunct.
intros Hhyg Hceil Hact.
apply functional_i; auto.
  {
  so (hygiene_subst_invert _#4 Hhyg) as Hhygi.
  eapply hygiene_subst; eauto.
  cbn.
  intros x Hx.
  destruct x as [| x].
    {
    simpsub.
    apply hygiene_var.
    split.
    }
  simpsub.
  simpsubin Hx.
  so (Nat.lt_trichotomy x k) as [Hxk | [H | Hkx]].
    {
    rewrite -> project_under_lt in Hx |- *; auto.
    }

    {
    subst x.
    rewrite -> project_under_eq.
    simpsub.
    apply hygiene_auto; cbn; auto.
    }

    {
    rewrite -> project_under_geq in Hx |- *; try omega.
    replace (x - k) with (S (x - k - 1)) in Hx |- * by omega.
    simpsub.
    simpsubin Hx.
    auto.
    }
  }
intros j m p Hj Hmp.
simpsub.
so (Hact _#3 Hj Hmp) as Hint.
simpsubin Hint.
rewrite -> split_dot.
change (varx (obj stop) 0) with (@var (obj stop) 0).
exploit (IH j (dot (if z then m else p) s) (pi1 F (urelspinj A j m p Hmp))) as H.
  {
  simpsub.
  auto.
  }
simpsubin H.
simpsub.
auto.
Qed.

Lemma raise_robust :
  forall pg s i a v w X Y (hv : v << stop) (hw : w << stop) A,
    v <<= cin pg
    -> w <<= cin pg
    -> extend_urel v stop X = extend_urel w stop Y
    -> robust 0 a
    -> basic system pg s i (subst1 (exttin v X hv) a) A
    -> basic system pg s i (subst1 (exttin w Y hw) a) A.
Proof.
intros pg z i a v w X Y hv hw A Hv Hw HeqXY Hrobust Hint.
assert (basic system pg z i (subst (compose (under 0 (dot (exttin v X hv) id)) id) a) A) as Hint'.
  {
  simpsub.
  exact Hint.
  }
renameover Hint' into Hint.
cut (basic system pg z i (subst (compose (under 0 (dot (exttin w Y hw) id)) id) a) A).
  {
  intro H; simpsubin H.
  exact H.
  }
set (j := 0) in Hrobust, Hint |- *.
set (s := id) in Hint at 2 |- * at 2.
clearbody j s.
revert i s A Hint.
induct Hrobust.

(* var *)
{
intros k i s A Hint.
simpsub.
simpsubin Hint.
rewrite -> project_under_eq in Hint |- *.
simpsub.
simpsubin Hint.
invert (basic_value_inv _#6 value_extt Hint).
intros u R hu Hu Heq <-.
so (objin_inj _ _ _ Heq) as Heq'.
clear Heq.
injectionc Heq'.
intros Heq ->.
injectionT Heq.
intros ->.
so (proof_irrelevance _ hv hu); subst hu.
clear Hint.
so (interp_extt system pg z i w (iubase Y) hw Hw) as H.
rewrite -> iutruncate_iubase in H |- *.
rewrite -> extend_iubase in H |- *.
rewrite <- ceiling_extend_urel in H |- *.
rewrite -> HeqXY.
apply interp_eval_refl.
exact H.
}

(* const *)
{
intros k a i s A Hint.
rewrite <- subst_compose in Hint |- *.
rewrite <- compose_assoc in Hint |- *.
rewrite <- compose_under in Hint |- *.
simpsub.
simpsubin Hint.
exact Hint.
}

(* prod *)
{
intros k a b _ IH1 _ IH2 i s R Hint.
simpsub.
simpsubin Hint.
invert (basic_value_inv _#6 value_prod Hint).
intros A B Ha Hb <-.
apply interp_eval_refl.
apply interp_prod; eauto.
}

(* pi *)
{
intros j a b _ IH1 _ IH2 i s R Hint.
simpsub.
simpsubin Hint.
invert (basic_value_inv _#6 value_pi Hint).
intros A B Ha Hb <-.
apply interp_eval_refl.
apply interp_pi; eauto.
exact (raise_robust_functional_ih _#14 Hv Hw HeqXY IH2 Hb).
}

(* sigma *)
{
intros j a b _ IH1 _ IH2 i s R Hint.
simpsub.
simpsubin Hint.
invert (basic_value_inv _#6 value_sigma Hint).
intros A B Ha Hb <-.
apply interp_eval_refl.
apply interp_sigma; eauto.
exact (raise_robust_functional_ih _#14 Hv Hw HeqXY IH2 Hb).
}

(* mu *)
{
intros j a _ IH i s R Hint.
simpsub.
simpsubin Hint.
invert (basic_value_inv _#6 value_mu Hint).
intros u F Hu Hact Hne Hmono Hrobust <-.
apply interp_eval_refl.
eapply interp_mu; eauto.
  {
  intros Z h.
  so (Hact Z h) as HintZ.
  exploit (IH i (dot (exttin u Z h) s) (extend_iurel (lt_ord_impl_le_ord u stop h) (F Z))) as H.
    {
    simpsub.
    simpsubin HintZ.
    auto.
    }
  simpsub.
  simpsubin H.
  auto.
  }

  {
  set (o1 := (objin (objsome (expair (qtype v) (iubase X)) hv))).
  set (o2 := (objin (objsome (expair (qtype w) (iubase Y)) hw))).
  set (f := fun x => match x with | Some y => y | None => o1 end).
  set (g := fun x => match x with | Some y => y | None => o2 end).
  replace
    (subst (dot (var 0) (compose (under j (dot (exttin v X hv) id)) (compose s sh1))) a)
    with
    (map_term f
       (subst
          (dot (var 0) (compose
                          (under j (dot (extt None) id))
                          (compose (map_sub Some s) sh1)))
          (map_term Some a))) in Hrobust.
  2:{
    simpmap.
    rewrite -> map_sub_compose.
    rewrite -> map_term_compose.
    subst f.
    cbn.
    rewrite -> map_sub_id.
    rewrite -> map_term_id.
    auto.
    }
  so (map_robust_conv _#5 Hrobust) as Hrobust'.
  so (map_robust _#3 g _ Hrobust') as H.
  simpmapin H.
  rewrite -> map_sub_compose in H.
  rewrite -> map_term_compose in H.
  subst g.
  cbn.
  rewrite -> map_sub_id in H.
  rewrite -> map_term_id in H.
  auto.
  }
}

(* bite *)
{
intros k m a b _ IH1 _ IH2 i s R Hint.
simpsub.
simpsubin Hint.
invertc Hint.
intros c Hhyg Hsteps Hint.
so (basicv_value _#6 Hint) as Hval.
so (hygiene_invert_auto _#5 Hhyg) as H; cbn in H.
destruct H as (Hclm & Hcla & Hclb & _).
assert (hygiene clo (subst (compose (under k (dot (exttin w Y hw) id)) s) a)) as Hcla'.
  {
  eapply subst_under_extt_hygiene; eauto.
  }
assert (hygiene clo (subst (compose (under k (dot (exttin w Y hw) id)) s) b)) as Hclb'.
  {
  eapply subst_under_extt_hygiene; eauto.
  }
so (eval_bite_invert _#5 (conj Hsteps Hval)) as [(Hstepm & Hstepsa) | (Hstepm & Hstepsb)].
  {
  assert (basic system pg z i (subst (compose (under k (dot (exttin v X hv) id)) s) a) R) as Hintv.
    {
    eapply interp_eval; eauto.
    }
  so (IH1 _#3 Hintv) as Hintw.
  refine (basic_unstep _#7 _ _ Hintw).
    {
    apply hygiene_auto; cbn.
    do2 3 split; auto.
    rewrite <- compose_assoc in Hclm |- *.
    rewrite <- compose_under in Hclm |- *.
    simpsub.
    simpsubin Hclm.
    exact Hclm.
    }

    {
    rewrite <- compose_assoc in Hstepm |- *.
    rewrite <- compose_under in Hstepm |- *.
    simpsub.
    simpsubin Hstepm.
    eapply star_trans.
      {
      apply (star_map' _ _ (fun Z => bite Z _ _)); eauto using step_bite1.
      }
    apply star_one.
    apply step_bite2.
    }
  }

  {
  assert (basic system pg z i (subst (compose (under k (dot (exttin v X hv) id)) s) b) R) as Hintv.
    {
    eapply interp_eval; eauto.
    }
  so (IH2 _#3 Hintv) as Hintw.
  refine (basic_unstep _#7 _ _ Hintw).
    {
    apply hygiene_auto; cbn.
    do2 3 split; auto.
    rewrite <- compose_assoc in Hclm |- *.
    rewrite <- compose_under in Hclm |- *.
    simpsub.
    simpsubin Hclm.
    exact Hclm.
    }

    {
    rewrite <- compose_assoc in Hstepm |- *.
    rewrite <- compose_under in Hstepm |- *.
    simpsub.
    simpsubin Hstepm.
    eapply star_trans.
      {
      apply (star_map' _ _ (fun Z => bite Z _ _)); eauto using step_bite1.
      }
    apply star_one.
    apply step_bite3.
    }
  }
}

(* weaken *)
{
intros k a _ IH i s A Hint.
simpsub.
simpsubin Hint.
rewrite <- compose_assoc in Hint |- *.
rewrite -> compose_sh_under_eq in Hint |- *.
simpsub.
simpsubin Hint.
exploit (IH i (compose (sh k) s) A) as H.
  {
  simpsub; auto.
  }
simpsubin H.
auto.
}

(* reduce *)
{
intros k a b Hab _ IH i s R Hint.
so (basic_closed _#6 Hint) as Hclas.
so (reduce_hygiene _#4 (reduce_subst _#4 Hab) Hclas) as Hclbs.
exploit (IH i s R) as H.
  {
  eapply basic_equiv; eauto.
  apply equiv_subst.
  apply reduce_equiv; auto.
  }
refine (basic_equiv _#7 _ _ H).
  {
  eapply subst_under_extt_hygiene; eauto.
  }

  {
  apply equiv_subst.
  apply equiv_symm.
  apply reduce_equiv; auto.
  }
}
Qed.

Lemma semantics_fun :
  (forall pg s i a X X',
     kbasic system pg s i a X
     -> kbasic system pg s i a X'
     -> X = X')
  /\
  (forall pg s i a X X',
     cbasic system pg s i a X
     -> cbasic system pg s i a X'
     -> X = X')
  /\
  (forall pg s i a X X',
     basic system pg s i a X
     -> basic system pg s i a X'
     -> X = X')
  /\
  (forall pg s i A a X X',
     functional system pg s i A a X
     -> functional system pg s i A a X'
     -> X = X').
Proof.
exploit
  (semantics_ind system
     (fun pg s i a X => forall X', kbasicv system pg s i a X' -> X = X')
     (fun pg s i a X => forall X', cbasicv system pg s i a X' -> X = X')
     (fun pg s i a X => forall X', basicv system pg s i a X' -> X = X')
     (fun pg s i a X => forall X', kbasic system pg s i a X' -> X = X')
     (fun pg s i a X => forall X', cbasic system pg s i a X' -> X = X')
     (fun pg s i a X => forall X', basic system pg s i a X' -> X = X')
     (fun pg s i A a X => forall X', functional system pg s i A a X' -> X = X')) as Hind;
try (intros;
     match goal with
     | H : kbasicv _ _ _ _ _ _ |- _ => invert H
     | H : cbasicv _ _ _ _ _ _ |- _ => invert H
     | H : basicv _ _ _ _ _ _ |- _ => invert H
     end;
     intros; subst; f_equal; eauto;
     done).

(* ktarrow *)
{
intros pg s i a k A K HA IH1 _ IH2 X HX.
invertc HX.
intros A' K' Ha Hk <-.
so (IH1 _ Ha) as Heq.
so (extend_iurel_inj _#5 Heq); subst A'.
so (IH2 _ Hk); subst K'.
reflexivity.
}

(* ext *)
{
intros pg s i Q h _ X HX.
invert HX.
intros Q' h' _ Heq <-.
so (f_equal objout Heq) as Heq'.
rewrite -> !objout_objin in Heq'.
injection Heq'.
intros ->.
reflexivity.
}

(* clam *)
{
intros pg s i k a K L A h HeqL Hk _ IH X HX.
invertc HX.
intros K' L' A' h' HeqL' Hk' Ha <-.
so (interp_kext_fun _#5 Hk Hk'); subst K'.
so (proof_irrelevance _ h h'); subst h'.
so (space_inhabitant (approx i K)) as x.
injection (IH i (le_refl _) _ _ (Ha i (le_refl _) x)).
intros _ HeqLs.
clear x.
so (eqtrans HeqL (eq_trans HeqLs (eqsymm HeqL'))); subst L'.
unfold stdc.
cbn.
f_equal.
rewrite -> std_arrow_is.
cbn.
apply nearrow_extensionality.
intro x.
cbn.
fold (std (S i) L).
fold (std (S i) K).
injection (IH i (le_refl _) _ _ (Ha i (le_refl _) (proj i K (std (S i) K x)))).
intros H.
injectionT H.
intros Heq.
setoid_rewrite <- std_idem at 1 2.
so (proj_eq_dist _#4 Heq) as Heq'.
setoid_rewrite -> proj_std in Heq'; auto.
setoid_rewrite -> embed_std in Heq'; auto.
rewrite -> std_idem in Heq'.
setoid_rewrite <- embed_std in Heq'; auto.
rewrite <- proj_std in Heq'; auto.
apply std_collapse.
eapply dist_trans.
  {
  apply std_nonexpansive.
  apply (pi2 A).
  apply dist_symm.
  apply embed_proj.
  }
eapply dist_trans.
  {
  exact Heq'.
  }
apply std_nonexpansive.
apply (pi2 A').
apply embed_proj.
}

(* capp *)
{
intros pg s i a b K L A B _ IH1 _ IH2 X HX.
invertc HX.
intros K' L' A' B' Ha Hb <-.
so (IH1 _ Ha) as Heq1.
injection Heq1.
intros <- <-.
so (expair_injection_2 _#5 Heq1).
subst A'.
so (expair_injection_2 _#5 (IH2 _ Hb)).
subst B'.
reflexivity.
}

(* ctlam *)
{
intros pg s i a b k K A f B _ Ha Hk _ IH Hf X HX.
invertc HX.
intros K' A' f' B' _ Ha' Hk' Hb Hf' <-.
so (interp_uext_fun _#5 Ha Ha'); subst A'.
so (interp_kext_fun _#5 Hk Hk'); subst K'.
f_equal.
apply nearrow_extensionality.
intros C.
so (urelsp_eta _ _ C) as (j & m & p & Hmp & ->).
so (cin_stop pg) as Hlstop.
set (l := cin pg) in Hlstop.
assert (rel (extend_urel l stop A) j (map_term (extend l stop) m) (map_term (extend l stop) p)) as Hmp'.
  {
  cbn.
  rewrite -> !extend_term_cancel; auto.
  }
so (Hf _ _ _ Hmp') as H.
rewrite -> (urelspinj_equal _#4 m _ p _ Hmp) in H.
2:{
  rewrite -> extend_term_cancel; auto.
  }
rewrite -> H; clear H.
so (Hf' _ _ _ Hmp') as H.
rewrite -> (urelspinj_equal _#4 m _ p _ Hmp) in H.
2:{
  rewrite -> extend_term_cancel; auto.
  }
rewrite -> H; clear H.
f_equal.
so (IH _#3 Hmp' _ (Hb _#3 Hmp')) as Heq'.
eapply expair_injection_2; eauto.
}

(* ctapp *)
{
intros pg s i b m l A K B n p Hnp Hm _ IH X HX.
invertc HX.
intros l' A' K' B' n' p' Hnp' Hm' Hb <-.
so (IH _ Hb) as Heq.
injection Heq.
intros <- H <-.
injectionT H.
intros <-.
injectionT Heq.
intros <-.
rewrite -> Hm' in Hm.
f_equal.
f_equal.
apply urelspinj_equal.
destruct s; subst; eapply urel_zigzag; eauto.
}

(* cpair *)
{
intros pg s i a b K L x y _ IH1 _ IH2 X HX.
invertc HX.
intros K' L' x' y' Ha Hb <-.
injection (IH1 _ Ha).
intros H <-.
injectionT H.
intros <-.
injection (IH2 _ Hb).
intros H <-.
injectionT H.
intros <-.
reflexivity.
}

(* cpi1 *)
{
intros pg s i a K L x _ IH X HX.
invertc HX.
intros K' L' x' Ha <-.
injection (IH _ Ha).
intros H <- <-.
injectionT H.
intros <-.
reflexivity.
}

(* cpi2 *)
{
intros pg s i a K L x _ IH X HX.
invertc HX.
intros K' L' x' Ha <-.
injection (IH _ Ha).
intros H <- <-.
injectionT H.
intros <-.
reflexivity.
}

(* cnext *)
{
intros pg s i a K x _ IH X HX.
invertc HX.
intros K' x' Ha <-.
so (IH _ Ha) as Heq.
injectionc Heq.
intros H <-.
injectionT H.
intros <-.
reflexivity.
}

(* cprev *)
{
intros pg s i a K x _ IH X HX.
invertc HX.
intros K' x' Ha <-.
so (IH _ Ha) as Heq.
injectionc Heq.
intros H <-.
injectionT H.
intros <-.
reflexivity.
}

(* cty *)
{
intros pg s i a R _ IH X HX.
invertc HX.
intros R' Ha <-.
so (IH _ Ha) as Heq.
so (extend_iurel_inj _#5 Heq); subst R'.
reflexivity.
}

(* con *)
{
intros pg s i lv a gpg R Hlv _ _ IH X HX.
invertc HX.
intros gpg' R' Hlv' _ Ha <-.
so (pginterp_fun _#3 Hlv Hlv'); subst gpg'.
so (IH _ Ha) as Heq.
injectionT Heq.
intros <-.
reflexivity.
}

(* pi *)
{
intros pg s i a b A B _ IH1 _ IH2 X HX.
invertc HX.
intros A' B' Ha Hb <-.
so (IH1 _ Ha); subst A'.
so (IH2 _ Hb); subst B'.
reflexivity.
}

(* intersect *)
{
intros pg s i a b A B _ IH1 _ IH2 X HX.
invertc HX.
intros A' B' Ha Hb <-.
so (IH1 _ Ha); subst A'.
so (IH2 _ Hb); subst B'.
reflexivity.
}

(* sigma *)
{
intros pg s i a b A B _ IH1 _ IH2 X HX.
invertc HX.
intros A' B' Ha Hb <-.
so (IH1 _ Ha); subst A'.
so (IH2 _ Hb); subst B'.
reflexivity.
}

(* set *)
{
intros pg s i a b A B _ IH1 _ IH2 X HX.
invertc HX.
intros A' B' Ha Hb <-.
so (IH1 _ Ha); subst A'.
so (IH2 _ Hb); subst B'.
reflexivity.
}

(* quotient *)
{
intros pg s i a b A B hs ht _ IH1 _ IH2 X HX.
invertc HX.
intros A' B' hs' ht' Ha Hb <-.
so (IH1 _ Ha); subst A'.
so (IH2 _ Hb); subst B'.
so (proof_irrelevance _ hs hs'); subst hs'.
so (proof_irrelevance _ ht ht'); subst ht'.
reflexivity.
}

(* guard *)
{
intros pg s i a b A B _ IH1 _ IH2 X HX.
invertc HX.
intros A' B' Ha Hb <-.
so (IH1 _ Ha).
subst A'.
f_equal.
apply IH2; auto.
}

(* wt *)
{
intros pg s i a b A B _ IH1 _ IH2 X HX.
invertc HX.
intros A' B' Ha Hb <-.
so (IH1 _ Ha); subst A'.
so (IH2 _ Hb); subst B'.
reflexivity.
}

(* equal *)
{
intros pg s i a m n p q A Hmp Hnq _ IH X HX.
invertc HX.
intros p' q' A' Hmp' Hnq' Ha' <-.
so (IH _ Ha'); subst A'.
apply iuequal_equal; auto.
}

(* all *)
{
intros pg s i lv k a gpg K A h Hlv _ IH1 _ _ IH2 X HX.
invertc HX.
intros gpg' K' A' h' Hlv' Hk _ Ha <-.
so (pginterp_fun _#3 Hlv Hlv'); subst gpg'.
so (IH1 _ Hk); subst K'.
so (proof_irrelevance _ h h'); subst h'.
f_equal.
rewrite -> std_arrow_is; cbn.
apply nearrow_extensionality.
intro x.
cbn.
change (std (S i) (qtype stop) (pi1 A (std (S i) K x))
        =
        std (S i) (qtype stop) (pi1 A' (std (S i) K x))).
rewrite -> std_type_is.
so (IH2 i (le_refl _) (proj i K x) _ (Ha i (le_refl _) (proj i K x))) as Heq.
etransitivity.
  {
  etransitivity.
  2:{ exact Heq. }
  symmetry.
  f_equal.
  f_equal.
  apply std_collapse.
  apply embed_proj.
  }

  {
  f_equal.
  f_equal.
  apply std_collapse.
  apply embed_proj.
  }
}

(* alltp *)
{
intros pg s i a A _ IH X HX.
invertc HX.
intros A' Ha <-.
f_equal.
apply nearrow_extensionality.
intro X.
exact (IH i (le_refl _) X _ (Ha i (le_refl _) X)).
}

(* exist *)
{
intros pg s i lv k a gpg K A h Hlv _ IH1 _ _ IH2 X HX.
invertc HX.
intros gpg' K' A' h' Hlv' Hk _ Ha <-.
so (pginterp_fun _#3 Hlv Hlv'); subst gpg'.
so (IH1 _ Hk); subst K'.
so (proof_irrelevance _ h h'); subst h'.
f_equal.
rewrite -> std_arrow_is; cbn.
apply nearrow_extensionality.
intro x.
cbn.
change (std (S i) (qtype stop) (pi1 A (std (S i) K x))
        =
        std (S i) (qtype stop) (pi1 A' (std (S i) K x))).
rewrite -> std_type_is.
so (IH2 i (le_refl _) (proj i K x) _ (Ha i (le_refl _) (proj i K x))) as Heq.
etransitivity.
  {
  etransitivity.
  2:{ exact Heq. }
  symmetry.
  f_equal.
  f_equal.
  apply std_collapse.
  apply embed_proj.
  }

  {
  f_equal.
  f_equal.
  apply std_collapse.
  apply embed_proj.
  }
}

(* extt *)
{
intros pg s i w R h Hw X HX.
invertc HX.
intros w' R' h' Hw' Heq <-.
so (objin_inj _ _ _ Heq) as Heq'.
injectionc Heq'; clear Heq.
intros Heq ->.
injectionT Heq.
intros ->.
so (proof_irrelevance _ h h'); subst h'.
reflexivity.
}

(* mu *)
{
intros pg v s i a F Hv _ IH Hne HmonoF Hrobust X HX.
invertc HX.
intros w G Hw Hact _ HmonoG _ <-.
assert (v << stop) as hv.
  {
  eapply le_lt_ord_trans; eauto.
  apply (le_lt_ord_trans _ top); auto using cin_top.
  apply succ_increase.
  }
assert (w << stop) as hw.
  {
  eapply le_lt_ord_trans; eauto.
  apply (le_lt_ord_trans _ top); auto using cin_top.
  apply succ_increase.
  }
so (le_lt_ord_dec v w) as [Hvw | Hlt].
  {
  assert (forall X,
            extend_urel v w (den (F X))
            =
            den (G (extend_urel v w X))) as Heq.
    {
    intro X.
    rewrite <- (den_extend_iurel _ _ Hvw).
    f_equal.
    so (Hact (extend_urel v w X) hw) as Hint.
    fold (exttin w (extend_urel v w X) hw) in Hint.
    exploit (IH X hv (extend_iurel (lt_ord_impl_le_ord _ _ hw) (G (extend_urel v w X)))) as Heq.
      {
      fold (exttin v X hv).
      eapply raise_robust; eauto.
      rewrite <- extend_urel_compose_up; eauto.
      }
    replace (lt_ord_impl_le_ord _ _ hv) with (le_ord_trans _#3 Hvw (lt_ord_impl_le_ord _ _ hw)) in Heq.
    2:{
      apply proof_irrelevance.
      }
    rewrite -> extend_iurel_compose in Heq.
    exact (extend_iurel_inj _#5 Heq).
    }
  rewrite -> (extend_urel_compose_up v w stop); auto.
  do 2 f_equal.
  rewrite -> extend_mu; auto.
  transitivity (mu_urel w (fun X => den (G (blur v w X)))).
    {
    f_equal.
    fextensionality 1.
    intro X.
    apply Heq.
    }
  apply (blur_vanish _ _ (fun X => den (G X))); auto.
  intro X.
  unfold blur.
  rewrite <- !Heq.
  rewrite <- (extend_urel_compose_up v w); auto.
  rewrite -> extend_urel_id; auto.
  }

  {
  rename v into u; rename w into v; rename u into w.
  rename Hv into Hu; rename Hw into Hv; rename Hu into Hw.
  rename hv into hu; rename hw into hv; rename hu into hw.
  rename F into H; rename G into F; rename H into G.
  rename HmonoF into HmonoH; rename HmonoG into HmonoF; rename HmonoH into HmonoG.
  so (lt_ord_impl_le_ord _ _ Hlt) as Hvw; clear Hlt.
  assert (forall X,
            extend_urel v w (den (F (extend_urel w v X)))
            =
            den (G (blur v w X))) as Heq.
    {
    intro X.
    rewrite <- (den_extend_iurel _ _ Hvw).
    f_equal.
    so (Hact (extend_urel w v X) hv) as Hint.
    fold (exttin v (extend_urel w v X) hv) in Hint.
    exploit (IH (blur v w X) hw (extend_iurel (lt_ord_impl_le_ord _ _ hv) (F (extend_urel w v X)))) as Heq.
      {
      fold (exttin w (blur v w X) hw).
      eapply raise_robust; eauto.
      rewrite -> (extend_urel_compose_up v w stop); auto.
      }
    replace (lt_ord_impl_le_ord _ _ hv) with (le_ord_trans _#3 Hvw (lt_ord_impl_le_ord _ _ hw)) in Heq.
    2:{
      apply proof_irrelevance.
      }
    rewrite -> extend_iurel_compose in Heq.
    symmetry.
    exact (extend_iurel_inj _#5 Heq).
    }
  rewrite -> (extend_urel_compose_up v w stop); auto.
  do 2 f_equal.
  rewrite -> extend_mu; auto.
  symmetry.
  transitivity (mu_urel w (fun X => den (G (blur v w X)))).
    {
    f_equal.
    fextensionality 1.
    auto.
    }
  apply (blur_vanish _ _ (fun X => den (G X))); auto.
  intro X.
  rewrite <- !Heq.
  unfold blur.
  rewrite <- (extend_urel_compose_up v w); auto.
  rewrite -> extend_urel_id; auto.
  }
}

(* univ *)
{
intros pg s i m gpg Hm _ _ X HX.
invertc HX.
intros gpg' Hm' _ _ <-.
so (pginterp_fun _#3 Hm Hm'); subst gpg'.
reflexivity.
}

(* kuniv *)
{
intros pg s i m gpg h Hm _ X HX.
invertc HX.
intros gpg' h' Hm' _ <-.
so (pginterp_fun _#3 Hm Hm'); subst gpg'.
so (proof_irrelevance _ h h'); subst h'.
reflexivity.
}

(* kbasic *)
{
intros pg s i k l K _ Hsteps Hl IH X HX.
invertc HX.
intros l' _ Hsteps' Hl'.
so (determinism_eval _#4 (conj Hsteps (kbasicv_value _#6 Hl)) (conj Hsteps' (kbasicv_value _#6 Hl'))).
subst l'.
apply IH; auto.
}

(* cbasic *)
{
intros pg s i c d Q _ Hsteps Hd IH Q' H.
invertc H.
intros d' _ Hsteps' Hd'.
so (determinism_eval _#4 (conj Hsteps (cbasicv_value _#6 Hd)) (conj Hsteps' (cbasicv_value _#6 Hd'))).
subst d'.
apply IH; auto.
}

(* basic *)
{
intros pg s i c d R _ Hsteps Hd IH R' H.
invertc H.
intros d' _ Hsteps' Hd'.
so (determinism_eval _#4 (conj Hsteps (basicv_value _#6 Hd)) (conj Hsteps' (basicv_value _#6 Hd'))).
subst d'.
eapply IH; eauto.
}

(* functional *)
{
intros pg s i A b B _ Hcoarse Hb IH B' H.
revert B Hcoarse Hb IH.
cases H.
intros pg s i A b B' _ _ Hb' B Hcoarse Hb IH.
apply nearrow_extensionality.
intros C.
so (urelsp_eta _ A C) as (j & m & p & Hmp & ->).
destruct (transport Hcoarse (fun R => rel R j m p) Hmp) as (Hj & _).
apply IH; auto.
  {
  omega.
  }
apply Hb'.
omega.
}

(* wrapup *)
{
do 6 (destruct Hind as (? & Hind)).
do2 3 split; intros; eauto.
}
Qed.

Lemma kbasic_fun :
  forall pg s i k K K',
    kbasic system pg s i k K
    -> kbasic system pg s i k K'
    -> K = K'.
Proof.
exact (semantics_fun andel).
Qed.

Lemma cbasic_fun :
  forall pg s i a Q Q',
    cbasic system pg s i a Q
    -> cbasic system pg s i a Q'
    -> Q = Q'.
Proof.
exact (semantics_fun anderl).
Qed.

Lemma basic_fun :
  forall pg s i a R R',
    basic system pg s i a R
    -> basic system pg s i a R'
    -> R = R'.
Proof.
exact (semantics_fun anderrl).
Qed.

Lemma functional_fun :
  forall pg s i A b B B',
    functional system pg s i A b B
    -> functional system pg s i A b B'
    -> B = B'.
Proof.
exact (semantics_fun anderrr).
Qed.

End semantics.


(*
 * SPDX-License-Identifier: MIT
 *
 *)
From Coq Require Import
     List
     Morphisms
     Eqdep
.

From SPICY Require Import
     MyPrelude
     Maps
     ChMaps
     Messages
     MessageEq
     Keys
     AdversaryUniverse
.

From SPICY Require
     IdealWorld
     RealWorld.

Import IdealWorld.IdealNotations
       RealWorld.RealWorldNotations
       .

Set Implicit Arguments.

Section IdealDefiniions.

  Import IdealWorld.

  Definition istepSilent {A} (U1 U2 : universe A) :=
    lstep_universe U1 Silent U2.

  Inductive indexedIdealStep {A} (uid : user_id) (lbl : label) (U1 U2 : universe A) : Prop :=
  | IndexedIdealStep : forall u proto chans prms,
      U1.(users) $? uid = Some u
      -> lstep_user uid lbl (U1.(channel_vector), u.(protocol), u.(perms)) (chans, proto, prms)
      -> U2 = construct_universe
               chans
               (U1.(users) $+ (uid, {| protocol := proto ; perms := prms |}))
      -> indexedIdealStep uid lbl U1 U2.

  Lemma indexedIdealStep_ideal_step :
    forall A uid lbl U1 U2,
      @indexedIdealStep A uid lbl U1 U2
      -> lstep_universe U1 lbl U2.
  Proof. intros * IND; invert IND; econstructor; eauto. Qed.

End IdealDefiniions.

Section RealDefinitions.
  Import RealWorld.

  Inductive indexedRealStep {A B} (uid : user_id) (lbl : label) (U1 U2 : universe A B) : Prop :=
  | IndexedRealStep : forall userData usrs adv cs gks ks qmsgs mycs froms sents cur_n (cmd : user_cmd (Base A)),
      U1.(users) $? uid = Some userData
      -> step_user lbl (Some uid)
                  (build_data_step U1 userData)
                  (usrs, adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, cmd)
      -> U2 = buildUniverse usrs adv cs gks uid {| key_heap  := ks
                                                   ; msg_heap  := qmsgs
                                                   ; protocol  := cmd
                                                   ; c_heap    := mycs
                                                   ; from_nons := froms
                                                   ; sent_nons := sents
                                                   ; cur_nonce := cur_n |}
      -> indexedRealStep uid lbl U1 U2.

  Lemma indexedRealStep_real_step :
    forall A B uid lbl U1 U2,
      @indexedRealStep A B uid lbl U1 U2
      -> step_universe (Some uid) U1 (mkULbl lbl uid) U2.
  Proof. intros * IND; invert IND; econstructor; eauto. Qed.

End RealDefinitions.

Inductive chan_key : Set :=
| Public (ch_id : IdealWorld.channel_id)
| Auth (ch_id : IdealWorld.channel_id): forall k,
    k.(keyUsage) = Signing -> chan_key
| Enc  (ch_id : IdealWorld.channel_id) : forall k,
    k.(keyUsage) = Encryption -> chan_key
| AuthEnc (ch_id : IdealWorld.channel_id) : forall k1 k2,
      k1.(keyUsage) = Signing
    -> k2.(keyUsage) = Encryption
    -> chan_key
.

Inductive action_matches (cs : RealWorld.ciphers) (gks : keys) :
  RealWorld.uaction -> IdealWorld.action -> Prop :=

| InpSig : forall t (m__rw : RealWorld.crypto t) (msg__rw : RealWorld.message.message t) (m__iw : IdealWorld.message.message t)
          kid uid seq froms p cid ch_id chans ps,
    m__rw = RealWorld.SignedCiphertext cid
    -> cs $? cid = Some (RealWorld.SigCipher kid uid seq msg__rw)
    -> content_eq msg__rw m__iw gks
    -> action_matches cs gks (uid, RealWorld.Input m__rw p froms) (IdealWorld.Input m__iw uid ch_id chans ps)
| InpEnc : forall t (m__rw : RealWorld.crypto t) (msg__rw : RealWorld.message.message t) (m__iw : IdealWorld.message.message t)
          kid1 kid2 uid seq froms p cid ch_id chans ps,
    m__rw = RealWorld.SignedCiphertext cid
    -> cs $? cid = Some (RealWorld.SigEncCipher kid1 kid2 uid seq msg__rw)
    -> content_eq msg__rw m__iw gks
    -> action_matches cs gks (uid, RealWorld.Input m__rw p froms) (IdealWorld.Input m__iw uid ch_id chans ps)
| OutSig : forall t (m__rw : RealWorld.crypto t) (msg__rw : RealWorld.message.message t) (m__iw : IdealWorld.message.message t)
          kid seq to from sents cid ch_id chans ps,
    m__rw = RealWorld.SignedCiphertext cid
    -> cs $? cid = Some (RealWorld.SigCipher kid to seq msg__rw)
    -> content_eq msg__rw m__iw gks
    -> action_matches cs gks (from, RealWorld.Output m__rw (Some from) (Some to) sents) (IdealWorld.Output m__iw from ch_id chans ps)
| OutEnc : forall t (m__rw : RealWorld.crypto t) (msg__rw : RealWorld.message.message t) (m__iw : IdealWorld.message.message t)
          kid1 kid2 seq to from sents cid ch_id chans ps,
    m__rw = RealWorld.SignedCiphertext cid
    -> cs $? cid = Some (RealWorld.SigEncCipher kid1 kid2 to seq msg__rw)
    -> content_eq msg__rw m__iw gks
    -> action_matches cs gks (from, RealWorld.Output m__rw (Some from) (Some to) sents) (IdealWorld.Output m__iw from ch_id chans ps)
.

Section RealWorldUniverseProperties.
  Import RealWorld.

  Variable honestk : key_perms.

  Definition permission_heap_honest (perms : key_perms) :=
    forall k_id p,
     perms $? k_id = Some p
      -> honestk $? k_id = Some true.

  Definition permission_heap_good (ks : keys) (perms : key_perms) :=
    forall k_id p,
      perms $? k_id = Some p
      -> exists k, ks $? k_id = Some k.

  (* Syntactic Predicates *)
  Definition keys_and_permissions_good {A} (ks : keys) (usrs : honest_users A) (adv_heap : key_perms): Prop :=
    (forall k_id k,
          ks $? k_id = Some k
        -> keyId k = k_id)
    /\ Forall_natmap (fun u => permission_heap_good ks u.(key_heap)) usrs
    /\ permission_heap_good ks adv_heap.

  Definition user_cipher_queue_ok (cs : ciphers) (honestk : key_perms) :=
    Forall (fun cid => exists c, cs $? cid = Some c
                       /\ cipher_honestly_signed honestk c = true).

  Definition user_cipher_queues_ok {A} (cs : ciphers) (honestk : key_perms) (usrs : honest_users A) :=
    Forall_natmap
      (fun u => user_cipher_queue_ok cs honestk u.(c_heap)) usrs.

  Definition adv_cipher_queue_ok {A} (cs : ciphers) (usrs : honest_users A) :=
    Forall (fun cid => exists new_cipher,
                cs $? cid = Some new_cipher
                /\ ( cipher_honestly_signed (findUserKeys usrs) new_cipher = false
                  \/ ( cipher_honestly_signed (findUserKeys usrs) new_cipher = true
                    /\ exists u_id u rec_u,
                      fst (cipher_nonce new_cipher) = Some u_id
                      /\ usrs $? u_id = Some u
                      /\ u_id <> cipher_to_user new_cipher
                      /\ List.In (cipher_nonce new_cipher) u.(sent_nons)
                      /\ usrs $? cipher_to_user new_cipher = Some rec_u
                      /\ ( List.In (cipher_nonce new_cipher) rec_u.(from_nons)
                        \/ Exists (fun sigM => match sigM with
                                           | existT _ _ m =>
                                             msg_signed_addressed (findUserKeys usrs) cs (Some (cipher_to_user new_cipher)) m = true
                                           /\ msg_nonce_same new_cipher cs m
                                           end) rec_u.(msg_heap))))
           ).

  Inductive encrypted_cipher_ok (cs : ciphers) (gks : keys): cipher -> Prop :=
  | SigCipherHonestOk : forall {t} (msg : message t) msg_to nonce k kt,
      honestk $? k = Some true
      -> gks $? k = Some {| keyId := k; keyUsage := Signing; keyType := kt |}
      (* only send honest public keys *)
      -> (forall k_id kp, findKeysMessage msg $? k_id = Some kp -> honestk $? k_id = Some true /\ kp = false)
      -> encrypted_cipher_ok cs gks (SigCipher k msg_to nonce msg)
  | SigCipherNotHonestOk : forall {t} (msg : message t) msg_to nonce k kt,
      honestk $? k <> Some true
      -> gks $? k = Some {| keyId := k; keyUsage := Signing; keyType := kt |}
      -> encrypted_cipher_ok cs gks (SigCipher k msg_to nonce msg)
  | SigEncCipherAdvSignedOk :  forall {t} (msg : message t) msg_to nonce k__s k__e kt__s kt__e,
      honestk $? k__s <> Some true
      -> gks $? k__s = Some {| keyId := k__s; keyUsage := Signing; keyType := kt__s |}
      -> gks $? k__e = Some {| keyId := k__e; keyUsage := Encryption; keyType := kt__e |}
      -> (forall k kp, findKeysMessage msg $? k = Some kp
                 -> exists v, gks $? k = Some v
                      /\ (kp = true -> honestk $? k <> Some true))
      -> encrypted_cipher_ok cs gks (SigEncCipher k__s k__e msg_to nonce msg)
  | SigEncCipherHonestSignedEncKeyHonestOk : forall {t} (msg : message t) msg_to nonce k__s k__e kt__s kt__e,
      honestk $? k__s = Some true
      -> honestk $? k__e = Some true
      -> gks $? k__s = Some {| keyId := k__s; keyUsage := Signing; keyType := kt__s |}
      -> gks $? k__e = Some {| keyId := k__e; keyUsage := Encryption; keyType := kt__e |}
      (* only send honest keys *)
      -> (forall k_id kp, findKeysMessage msg $? k_id = Some kp -> honestk $? k_id = Some true)
      -> encrypted_cipher_ok cs gks (SigEncCipher k__s k__e msg_to nonce msg).

  Definition encrypted_ciphers_ok (cs : ciphers) (gks : keys) :=
    Forall_natmap (encrypted_cipher_ok cs gks) cs.

  Definition message_no_adv_private {t} (cs : ciphers) (msg : crypto t) :=
    forall k p, findKeysCrypto cs msg $? k = Some p -> honestk $? k = Some true /\ p = false.

  Definition adv_message_queue_ok {A} (usrs : honest_users A)
             (cs : ciphers) (gks : keys) (msgs : queued_messages) :=
    Forall (fun sigm => match sigm with
                     | (existT _ _ m) =>
                       (forall cid, msg_cipher_id m = Some cid -> cs $? cid <> None)
                     /\ (forall k kp,
                           findKeysCrypto cs m $? k = Some kp
                           -> gks $? k <> None /\ (kp = true -> (findUserKeys usrs) $? k <> Some true))
                     /\ (forall k,
                           msg_signing_key cs m = Some k
                           -> gks $? k <> None)
                     /\ (forall c_id, List.In c_id (findCiphers m)
                                -> exists c, cs $? c_id = Some c
                                     /\ ( cipher_honestly_signed (findUserKeys usrs) c = false
                                       \/ ( cipher_honestly_signed (findUserKeys usrs) c = true
                                         /\ exists uid u rec_u,
                                           fst (cipher_nonce c) = Some uid
                                           /\ usrs $? uid = Some u
                                           /\ uid <> cipher_to_user c
                                           /\ List.In (cipher_nonce c) u.(sent_nons)
                                           /\ usrs $? cipher_to_user c = Some rec_u
                                           /\ ( List.In (cipher_nonce c) rec_u.(from_nons)
                                             \/ Exists (fun sigM =>
                                                         match sigM with
                                                         | existT _ _ m =>
                                                           msg_signed_addressed (findUserKeys usrs) cs (Some (cipher_to_user c)) m = true
                                                           /\ msg_nonce_same c cs m
                                                         end) rec_u.(msg_heap)))))
                     end
           ) msgs.

  Definition message_queue_ok (cs : ciphers) (msgs : queued_messages) (gks : keys) :=
    Forall (fun sigm => match sigm with
                     | (existT _ _ m) =>
                       (forall k kp, findKeysCrypto cs m $? k = Some kp -> gks $? k <> None)
                     /\ (forall cid,
                           msg_cipher_id m = Some cid
                           -> cs $? cid <> None)
                     /\ (forall k,
                           msg_signing_key cs m = Some k
                           -> gks $? k <> None
                           /\ ( honest_key honestk k
                             -> message_no_adv_private cs m)
                       )
                     end) msgs.

  Definition adv_no_honest_keys (advk : key_perms) : Prop :=
    forall k_id,
      (  honestk $? k_id = None
      \/  honestk $? k_id = Some false
      \/ (honestk $? k_id = Some true /\ advk $? k_id <> Some true)
      ).

  Definition honest_users_only_honest_keys {A} (usrs : honest_users A) :=
    forall u_id u,
      usrs $? u_id = Some u
      -> forall k_id kp,
        u.(key_heap) $? k_id = Some kp
        -> findUserKeys usrs $? k_id = Some true.

  Definition honest_nonce_tracking_ok (cs : ciphers) (honestk : key_perms)
             (me : option user_id) (my_sents : sent_nonces) (my_cur_n : nat)
             (to_usr : user_id) (to_froms : recv_nonces) (to_msgs : queued_messages) :=

      (* Forall (fun non => snd non < my_cur_n) my_sents *)
      Forall (fun non => fst non = me -> snd non < my_cur_n) to_froms
    /\ Forall (fun '(existT _ _ msg) =>
                forall c_id c,
                  msg = SignedCiphertext c_id
                  -> cs $? c_id = Some c
                  -> honestk $? (cipher_signing_key c) = Some true
                  -> cipher_to_user c = to_usr
                  -> fst (cipher_nonce c) = me
                  -> snd (cipher_nonce c) < my_cur_n
             ) to_msgs
    /\ forall c_id c,
        cs $? c_id = Some c
      -> honestk $? (cipher_signing_key c) = Some true
      -> fst (cipher_nonce c) = me (* if cipher created by me *)
      (* -> snd (cipher_nonce c) < my_cur_n *)
      -> cipher_to_user c = to_usr
      -> ~ List.In (cipher_nonce c) my_sents (* and hasn't yet been sent *)
      -> ~ List.In (cipher_nonce c) to_froms (* then it hasn't been read by destination user *)
        /\ Forall (fun '(existT _ _ msg) => (* and isn't in destination user's message queue *)
                    msg_honestly_signed  honestk cs msg = true
                    -> msg_to_this_user cs (Some to_usr) msg = false
                      \/ msg_nonce_not_same c cs msg) to_msgs.

  Definition honest_user_nonces_ok (cs : ciphers) (honestk : key_perms)
             (me : option user_id) (my_sents : sent_nonces) (my_cur_n : nat) :=
    (forall c_id c,
      cs $? c_id = Some c
      -> honestk $? (cipher_signing_key c) = Some true
      -> fst (cipher_nonce c) = me (* if cipher created by me *)
      -> snd (cipher_nonce c) < my_cur_n)
  /\ Forall (fun non => snd non < my_cur_n) my_sents
  .

  Definition honest_nonces_unique (cs : ciphers) (honestk : key_perms) :=
    (forall cid1 cid2 c1 c2,
        cid1 <> cid2
        -> cs $? cid1 = Some c1
        -> cs $? cid2 = Some c2
        -> honestk $? (cipher_signing_key c1) = Some true
        -> honestk $? (cipher_signing_key c2) = Some true
        -> cipher_nonce c1 <> cipher_nonce c2).

  Definition action_adversary_safe (honestk : key_perms) (cs : ciphers) (a : action) : Prop :=
    match a with
    | Input  msg pat froms    => msg_pattern_safe honestk pat
                              /\ exists c_id c, msg = SignedCiphertext c_id
                                        /\ cs $? c_id = Some c
                                        /\ ~ List.In (cipher_nonce c) froms
    | Output msg msg_from msg_to sents => msg_honestly_signed honestk cs msg = true
                                       /\ msg_to_this_user cs msg_to msg = true
                                       /\ exists c_id c, msg = SignedCiphertext c_id
                                                 /\ cs $? c_id = Some c
                                                 /\ fst (cipher_nonce c) = msg_from  (* only send my messages *)
                                                 /\ ~ List.In (cipher_nonce c) sents
    end.

End RealWorldUniverseProperties.

Section SafeActions.
  Import RealWorld.

  Inductive nextAction : forall {A B}, user_cmd A -> user_cmd B -> Prop :=
  | NaReturn : forall A (a : << A >>),
      nextAction (Return a) (Return a)
  | NaGen :
      nextAction Gen Gen
  | NaSend : forall t uid (msg : crypto t),
      nextAction (Send uid msg) (Send uid msg)
  | NaRecv : forall t pat,
      nextAction (@Recv t pat) (@Recv t pat)
  | NaSignEncrypt : forall t k__s k__e u_id (msg : message t),
      nextAction (SignEncrypt k__s k__e u_id msg) (SignEncrypt k__s k__e u_id msg)
  | NaDecrypt : forall t (msg : crypto t),
      nextAction (Decrypt msg) (Decrypt msg)
  | NaSign : forall t k u_id (msg : message t),
      nextAction (Sign k u_id msg) (Sign k u_id msg)
  | NaVerify : forall t k (msg : crypto t),
      nextAction (Verify k msg) (Verify k msg)
  | NaGenKey : forall kt usg,
      nextAction (GenerateKey kt usg) (GenerateKey kt usg)
  | NaBind : forall A B r (c : user_cmd B) (c1 : user_cmd r) (c2 : << r >> -> user_cmd A),
      nextAction c1 c
      -> nextAction (Bind c1 c2) c
  .

  Lemma nextAction_couldBe :
    forall {A B} (c1 : user_cmd A) (c2 : user_cmd B),
      nextAction c1 c2
      -> match c2 with
        | Return _ => True
        | Gen => True
        | Send _ _ => True
        | Recv _ => True
        | SignEncrypt _ _ _ _ => True
        | Decrypt _ => True
        | Sign _ _ _ => True
        | Verify _ _ => True
        | GenerateKey _ _ => True
        (* | GenerateAsymKey _ => True *)
        (* | GenerateSymKey _ => True *)
        | Bind _ _ => False
        end.
  Proof.
    induction 1; eauto.
  Qed.

  Definition next_cmd_safe (honestk : key_perms) (cs : ciphers) (u_id : user_id)
             (froms : recv_nonces) (sents : sent_nonces) {A} (cmd : user_cmd A) :=
    forall B (cmd__n : user_cmd B),
      nextAction cmd cmd__n
      -> match cmd__n with
        | Return _ => True
        | Gen => True
        | Send msg_to msg =>
          msg_honestly_signed honestk cs msg = true
          /\ msg_to_this_user cs (Some msg_to) msg = true
          /\ (exists c_id c, msg = SignedCiphertext c_id
                       /\ cs $? c_id = Some c
                       /\ fst (cipher_nonce c) = (Some u_id)  (* only send my messages *)
                       /\ ~ List.In (cipher_nonce c) sents)
        | Recv pat =>
          msg_pattern_safe honestk pat
        | SignEncrypt k__sign k__enc msg_to msg =>
          honestk $? k__enc = Some true
          /\ (forall k_id kp, findKeysMessage msg $? k_id = Some kp -> honestk $? k_id = Some true)
        | Decrypt _ => True
        | Sign _ _ msg =>
          (forall k_id kp, findKeysMessage msg $? k_id = Some kp -> honestk $? k_id = Some true /\ kp = false)
        | Verify _ _ => True
        | GenerateKey _ _ => True
        | Bind _ _ => False
        end.

  Definition honest_cmds_safe {A B} (U : universe A B) : Prop :=
    forall u_id u honestk,
      honestk = findUserKeys U.(users)
      -> U.(users) $? u_id = Some u
      (* -> forall lbl bd, step_user lbl (Some u_id) (build_data_step U u) bd *)
      -> next_cmd_safe (findUserKeys U.(users)) U.(all_ciphers) u_id u.(from_nons) u.(sent_nons) u.(protocol).

  Definition label_safe (honestk : key_perms) (cs : ciphers) (lbl : label) : Prop :=
    match lbl with
    | Silent   => True
    | Action a => action_adversary_safe honestk cs a
    end.

End SafeActions.

Section FinalValue.

    Inductive final_value : Set :=
    | FAccess
    | FBool (b : bool)
    | FNat (n : nat)
    | FUnit
    | FPair (fv1 fv2 : final_value).

    Section IdealFV.
      Import IdealWorld.
      Import IdealWorld.IdealNotations.

      Fixpoint Iret_val_to_val { t : type } :
        forall (rv : << Base t >>), final_value :=
        match t with
        | Nat => (fun n => FNat n)
        | Bool => (fun b => FBool b)
        | Unit => (fun _ => FUnit)
        | Access => (fun _ => FAccess)
        | TPair t1 t2 => (fun '(f, s) => FPair (Iret_val_to_val f) (Iret_val_to_val s))
        end.

    End IdealFV.

    Section RealFV.
      Import RealWorld.
      Import RealWorld.RealWorldNotations.

      Fixpoint Rret_val_to_val { t : type } :
        forall (rv : << Base t >>), final_value :=
        match t with
        | Nat => (fun n => FNat n)
        | Bool => (fun b => FBool b)
        | Unit => (fun _ => FUnit)
        | Access => (fun _ => FAccess)
        | TPair t1 t2 => (fun '(f, s) => FPair (Rret_val_to_val f) (Rret_val_to_val s))
        end.

    End RealFV.

End FinalValue.

Definition message_queues_ok {A} (cs : RealWorld.ciphers) (usrs : RealWorld.honest_users A) (gks : keys) :=
  Forall_natmap (fun u => message_queue_ok (RealWorld.findUserKeys usrs) cs u.(RealWorld.msg_heap) gks) usrs.

Definition honest_nonces_ok {A} (cs : RealWorld.ciphers) (usrs : RealWorld.honest_users A) :=
    honest_nonces_unique cs (RealWorld.findUserKeys usrs)
  /\ ( forall uid u,
        usrs $? uid = Some u
        -> honest_user_nonces_ok cs (RealWorld.findUserKeys usrs) (Some uid)
                                u.(RealWorld.sent_nons)
                                u.(RealWorld.cur_nonce) )
  /\ (forall u_id u rec_u_id rec_u,
        u_id <> rec_u_id
        -> usrs $? u_id = Some u
        -> usrs $? rec_u_id = Some rec_u
        -> honest_nonce_tracking_ok cs (RealWorld.findUserKeys usrs)
                                   (Some u_id)
                                   u.(RealWorld.sent_nons)
                                   u.(RealWorld.cur_nonce)
                                   rec_u_id rec_u.(RealWorld.from_nons)
                                   rec_u.(RealWorld.msg_heap)).

Definition universe_ok {A B} (U : RealWorld.universe A B) : Prop :=
  let honestk := RealWorld.findUserKeys U.(RealWorld.users)
  in  encrypted_ciphers_ok honestk U.(RealWorld.all_ciphers) U.(RealWorld.all_keys)
    /\ keys_and_permissions_good U.(RealWorld.all_keys) U.(RealWorld.users) U.(RealWorld.adversary).(RealWorld.key_heap)
    /\ user_cipher_queues_ok U.(RealWorld.all_ciphers) honestk U.(RealWorld.users)
    /\ message_queues_ok U.(RealWorld.all_ciphers) U.(RealWorld.users) U.(RealWorld.all_keys)
    /\ adv_cipher_queue_ok U.(RealWorld.all_ciphers) U.(RealWorld.users) U.(RealWorld.adversary).(RealWorld.c_heap)
    /\ adv_message_queue_ok U.(RealWorld.users) U.(RealWorld.all_ciphers) U.(RealWorld.all_keys) U.(RealWorld.adversary).(RealWorld.msg_heap)
    /\ adv_no_honest_keys honestk U.(RealWorld.adversary).(RealWorld.key_heap)
    /\ honest_nonces_ok U.(RealWorld.all_ciphers) U.(RealWorld.users)
    /\ honest_users_only_honest_keys U.(RealWorld.users).

Section Simulation.
  Variable A B : type.
  Variable advP : RealWorld.user_data B -> Prop.
  Variable R : RealWorld.simpl_universe A -> IdealWorld.universe A -> Prop.

  Definition simulates_silent_step :=
    forall (U__r : RealWorld.universe A B) U__i,
      R (RealWorld.peel_adv U__r) U__i
    -> universe_ok U__r
    -> advP U__r.(RealWorld.adversary)
    -> forall suid U__r',
        RealWorld.step_universe suid U__r Silent U__r'
        -> exists U__i',
          istepSilent ^* U__i U__i'
        /\ R (RealWorld.peel_adv U__r') U__i'.

  Definition simulates_labeled_step :=
    forall (U__r : RealWorld.universe A B) U__i,
      R (RealWorld.peel_adv U__r) U__i
    -> universe_ok U__r
    -> advP U__r.(RealWorld.adversary)
    -> forall uid U__r' ra,
        indexedRealStep uid (Action ra) U__r U__r'
        -> exists ia U__i' U__i'',
            (indexedIdealStep uid Silent) ^* U__i U__i'
            /\ indexedIdealStep uid (Action ia) U__i' U__i''
            /\ action_matches U__r.(RealWorld.all_ciphers) U__r.(RealWorld.all_keys) (uid,ra) ia
            /\ R (RealWorld.peel_adv U__r') U__i''.

  Definition honest_actions_safe :=
    forall (U__r : RealWorld.universe A B) U__i,
        R (RealWorld.peel_adv U__r) U__i
      -> universe_ok U__r
      -> honest_cmds_safe U__r.

  Definition ri_final_actions_align :=
    forall (U__r : RealWorld.universe A B) U__i,
      R (RealWorld.peel_adv U__r) U__i
      -> universe_ok U__r
      -> (forall uid lbl U__r', RealWorld.step_universe (Some uid) U__r lbl U__r' -> False)
      -> forall uid ud__r r__r,
          U__r.(RealWorld.users) $? uid = Some ud__r
          -> ud__r.(RealWorld.protocol) = RealWorld.Return r__r
          -> exists (U__i' : IdealWorld.universe A) ud__i r__i,
              istepSilent ^* U__i U__i'
              /\ U__i'.(IdealWorld.users) $? uid = Some ud__i
              /\ ud__i.(IdealWorld.protocol) = IdealWorld.Return r__i
              /\ Rret_val_to_val r__r = Iret_val_to_val r__i.

  Definition simulates (U__r : RealWorld.universe A B) (U__i : IdealWorld.universe A) :=

    (* conditions for simulation steps *)
    simulates_silent_step
  /\ simulates_labeled_step
  /\ honest_actions_safe
  /\ ri_final_actions_align

  (* conditions for start *)
  /\ R (RealWorld.peel_adv U__r) U__i
  /\ universe_ok U__r
  .

End Simulation.

Section IISimulation.
  Import IdealWorld.

  Variable A : type.
  Variable R : universe A -> universe A -> Prop.

  Definition ii_final_labels_align (U__i U__is : universe A) :=
    (forall lbl U__i', ~ lstep_universe U__i lbl U__i')
    -> exists (U__is' U__is'' : universe A),
      trc3 lstep_universe (fun _ => True) U__is U__is'
      /\ (forall lbl U__is'', ~ lstep_universe U__is' lbl U__is'')
      /\ forall uid ud__i r,
          U__i.(users) $? uid = Some ud__i
          -> ud__i.(protocol) = Return r
          -> exists ud__is,
            U__is'.(users) $? uid = Some ud__is
          /\ ud__is.(protocol) = Return r.

  Definition ii_step :=
    forall (U__i : universe A) U__is,
      R U__i U__is
      -> forall lbl U__i',
        lstep_universe U__i lbl U__i'
        -> exists U__is',
          trc3 lstep_universe (fun _ => True) U__is U__is'
          /\ ii_final_labels_align U__i' U__is'
          /\ R U__i' U__is'.

  Definition ii_simulates (U__i U__is : universe A) :=
    ii_step
    /\ R U__i U__is.

End IISimulation.

Definition refines {A B} (advP : RealWorld.user_data B -> Prop) (U1 : RealWorld.universe A B) (U2 : IdealWorld.universe A) :=
  exists R, simulates advP R U1 U2.

Notation "u1 <| u2 \ p " := (refines p u1 u2) (no associativity, at level 70).

Definition lameAdv {B} (b : RealWorld.denote (RealWorld.Base B)) :=
  fun adv => adv.(RealWorld.protocol) = @RealWorld.Return (RealWorld.Base B) b.

Definition awesomeAdv : forall B, RealWorld.user_data B -> Prop :=
  fun _ _ => True.


Require Import Coq.Lists.List.
Require Import Coq.Strings.String.
Require Import Crypto.CLI.
Require Export Crypto.StandaloneHaskellMain.
Require Import Crypto.Bedrock.Field.Stringification.Stringification.
Import ListNotations.
Local Open Scope string_scope.
Local Open Scope list_scope.

(** N.B. We put bedrock2 first so that the default for these binaries
    is bedrock2 *)
Local Instance bedrock2_supported_languages : ForExtraction.supported_languagesT
  := [("bedrock2", OutputBedrock2API)]
       ++ ForExtraction.default_supported_languages.

Module UnsaturatedSolinas.
  Definition main : IO_unit
    := main_gen ForExtraction.UnsaturatedSolinas.PipelineMain.
End UnsaturatedSolinas.

Module WordByWordMontgomery.
  Definition main : IO_unit
    := main_gen ForExtraction.WordByWordMontgomery.PipelineMain.
End WordByWordMontgomery.

Module SaturatedSolinas.
  Definition main : IO_unit
    := main_gen ForExtraction.SaturatedSolinas.PipelineMain.
End SaturatedSolinas.

Module BaseConversion.
  Definition main : IO_unit
    := main_gen ForExtraction.BaseConversion.PipelineMain.
End BaseConversion.


Require Import Nat.
Require Import String.
Require Import List.
Require Import Coq.Init.Datatypes PArray.
From mathcomp Require Import all_ssreflect all_algebra.
From LF Require Export lang_declassify.

Set Implicit Arguments.

(********************************************************)

(* Syntax of language *)

(********************************************************)

(* Example 1 *)
(* fn (length) {
   if (inbound(length) { //attacker can pass any value of length which might not be in bound
      x := a[length] ; //speculatively processor goes her...lead to access to unbound index (secret memory)
      a[y] := x;  // loads data from secret memory
      for (i = 0 ; i <= length; i++) { //based on conditional
          a[i] := 0; // writes in secret memory
      }
   }
*)
(* During sequential execution, this is not a problem but it might be a problem in speculative execution *)
(* One solution is to put fence after line 2 but the drawback of fence is they stop speculation of
   all instructions, not only the instructions that might leak *)
(* Another solution: protect ==> it only stops speculation along certain path, memory load is guarded by protect *)

(* Example 2 *)
(* x := a[i1]
   y := a[i2]
   z := x + y
   w := b[z] *)

(* Example 3: Use of protect : Protects all the public loads so that attacker doesn't use it to get the secret data *)
(* x := a[i] // where a is public and i is always public
   a[j] := x // storing the value x in the memory *)
(* x := a[i]  x: Transient
   x := protect(x) RHS: x: Transient LHS: x: Public
   a[j] := x *)

(* Instructions *)
Inductive instr : Type :=
| Iempty : instr
| Iassgn : var -> declassify -> expr -> instr (* assignemnt x := d e *)
| Iload : var -> declassify -> arr_access -> instr (* x := d a[e] *)
| Istore : arr_access -> declassify -> expr -> instr  (* a[e] := d e *)
| Iif : bexpr -> seq instr -> seq instr -> instr (* conditional if b i i *)
| Iprotect : var -> var -> instr (* we will protect the var which gets value from public load *).

Definition cmd := seq instr.

(* State *)
Record state := State {
  scmd : cmd;
  rmap : regmap;
  mmap  : mem;
  ms : bool
}.

(* Semantic of expressions *)
Fixpoint sem_expr_spec (s:state) (e:expr) : value :=
  match e with
  | Evar x => (rmap s) x
  | Ebop o e e' => eval_bop o (sem_expr_spec s e) (sem_expr_spec s e')
  end.

(* Directives *)
Inductive directive : Type :=
| Dstep : directive
| Dforce : bool -> directive
| Dload : varr -> nat -> directive
| Dstore : varr -> nat -> directive.

(* Semantics of instructions with speculation *)
Inductive sem_instr_spec : state -> directive -> seq leakage -> state -> Prop :=
| Iempty_sem_spec : forall s c,
  s.(scmd) = Iempty :: c ->
  sem_instr_spec s
  Dstep
  [::]
  {| scmd := c; rmap := rmap s; mmap := mmap s; ms := ms s |}
| Iassgn_sem_spec : forall s x d e c,
  s.(scmd) = Iassgn x d e :: c ->
  sem_instr_spec s
  Dstep
  (if d then [:: Ldeclassify (Some (sem_expr_spec s e))] else [:: Lempty])
  {| scmd := c;
     rmap := update_rmap s.(rmap) x (sem_expr_spec s e);
     mmap := s.(mmap);
     ms := s.(ms) |}
| Iif_sem_spec : forall s bop e1 e2 bf i1 i2 v1 v2 b' c,
  s.(scmd) = Iif (Ebool bop e1 e2) i1 i2 :: c ->
  sem_expr_spec s e1 = v1 ->
  sem_expr_spec s e2 = v2 ->
  eval_bool_op bop v1 v2 = b' ->
  sem_instr_spec s
  (Dforce bf)
  [::(Lbool b')]
  {| scmd := (if bf then i1 else i2) ++ c;
     rmap := s.(rmap);
     mmap := s.(mmap);
     ms := if b' == bf then s.(ms) else true (*s.ms || b' != bf*)|}
| Iload_sem_spec : forall s x d a e c,
  s.(scmd) = Iload x d (AA a e) :: c ->
  sem_instr_spec s
  (Dload a (sem_expr_spec s e))
  (if d then [:: Lindex (sem_expr_spec s e);
                 Ldeclassify (Some (Array.get (mmap s a) (sem_expr_spec s e)))]
        else [:: Lindex (sem_expr_spec s e)])
  {| scmd := c;
     rmap := update_rmap s.(rmap) x (Array.get (s.(mmap) a) (sem_expr_spec s e));
     mmap := s.(mmap);
     ms := s.(ms) |}
| Istore_sem_spec : forall s a e d e' c,
  s.(scmd) = Istore (AA a e) d e' :: c ->
  sem_instr_spec s (Dstore a (sem_expr_spec s e))
  (if d then [:: Lindex (sem_expr_spec s e); Ldeclassify (Some (sem_expr_spec s e'))]
        else [:: Lindex (sem_expr_spec s e)])
  {| scmd := c;
     rmap := s.(rmap);
     mmap := update_mem s.(mmap) a (sem_expr_spec s e) (sem_expr_spec s e');
     ms := s.(ms) |}
| Iprotect_sem_spec : forall s x y c,
  s.(scmd) = Iprotect x y :: c ->
  sem_instr_spec s
  Dstep
  [:: Lempty]
  {| scmd := c;
     rmap := if s.(ms) then update_rmap s.(rmap) x 0 else update_rmap s.(rmap) x (s.(rmap) y);
     mmap := s.(mmap);
     ms := s.(ms) |}.

(* Multi step for instructions with spec *)
Inductive multi_step_spec : state -> seq directive -> seq (seq leakage) -> nat -> state -> Prop :=
| sem_empty_spec : forall s, multi_step_spec s nil nil 0 s
| sem_seq_spec : forall s d l s' d' l' s'' n,
  sem_instr_spec s d l s' ->
  multi_step_spec s' d' l' n s'' ->
  multi_step_spec s (d :: d') (l :: l') (n + 1) s''.

Definition final_state_spec (s:state) : bool :=
match s.(scmd) with
| [::] => true
| _ => false
end.

Definition safe_state (s:state) :=
final_state_spec s = true \/ exists d l s', sem_instr_spec s d l s'.


Require Import DirName.
Require Import Balloc.
Require Import Prog.
Require Import BasicProg.
Require Import Bool.
Require Import Word.
Require Import BFile Bytes Rec Inode.
Require Import String.
Require Import FSLayout.
Require Import Pred PredCrash.
Require Import Arith.
Require Import GenSepN.
Require Import List ListUtils.
Require Import Hoare.
Require Import Log.
Require Import SepAuto.
Require Import Array.
Require Import FunctionalExtensionality.
Require Import AsyncDisk.
Require Import DiskSet.
Require Import SyncedMem.
Require Import GenSepAuto.
Require Import BFileCrash.
Require Import Omega.
Require Import DirTreeDef.
Require Import DirTreeRep.
Require Import DirTreePred.
Require Import DirTreeNames.
Require Import DirTreeInodes.

Import ListNotations.

Module SDIR := DirCache.CacheOneDir.

Set Implicit Arguments.

Module DTCrash.

  Definition file_crash (f f' : dirfile) : Prop :=
    exists c c',
    BFILE.file_crash (BFILE.mk_bfile (DFData f) (DFAttr f) c)
                     (BFILE.mk_bfile (DFData f') (DFAttr f') c').

  Inductive tree_crash : dirtree -> dirtree -> Prop :=
    | TCFile : forall inum f f',
               file_crash f f' ->
               tree_crash (TreeFile inum f) (TreeFile inum f')
    | TCDir  : forall inum st st',
               map fst st = map fst st' ->
               Forall2 tree_crash (map snd st) (map snd st') ->
               tree_crash (TreeDir inum st) (TreeDir inum st').

  Theorem tree_crash_trans : forall t1 t2 t3,
    tree_crash t1 t2 ->
    tree_crash t2 t3 ->
    tree_crash t1 t3.
  Proof.
    induction t1 using dirtree_ind2; simpl; intros.
    inversion H; subst. inversion H0; subst. econstructor.
      unfold file_crash in *. repeat deex. do 2 eexists. eapply file_crash_trans; eauto.
    inversion H0; subst. inversion H1; subst. constructor. congruence.
    generalize dependent st'. generalize dependent st'0.
    induction tree_ents; simpl; intros.
    - destruct st'; simpl in *; try congruence.
    - destruct st'; destruct st'0; simpl in *; try congruence.
      inversion H6. inversion H8. inversion H. inversion H4. inversion H5. subst; simpl in *.
      constructor; eauto.
      eapply IHtree_ents. eauto.
      all: try match goal with | [ |- Forall2 _ _ _ ] => eauto end.
      all: eauto.
      constructor; eauto.
      constructor; eauto.
  Qed.

  Lemma flist_crash_xform_dirlist_pred : forall tree_ents p,
    Forall
      (fun t => flist_crash_xform (p t) =p=> exists t', [[ tree_crash t t' ]] * p t')
      (map snd tree_ents) ->
    flist_crash_xform (dirlist_pred p tree_ents) =p=>
      exists tree_ents',
      [[ Forall2 tree_crash (map snd tree_ents) (map snd tree_ents') ]] *
      [[ map fst tree_ents = map fst tree_ents' ]] *
      dirlist_pred p tree_ents'.
  Proof.
    induction tree_ents; simpl; intros.
    - rewrite flist_crash_xform_emp. cancel.
      eassign (@nil (string * dirtree)); cancel.
      constructor.
      constructor.
    - destruct a. rewrite flist_crash_xform_sep_star.
      inversion H; subst.
      rewrite H2.
      rewrite IHtree_ents by eauto.
      cancel.
      eassign ((s, t') :: tree_ents').
      cancel.
      constructor; eauto.
      simpl; congruence.
  Qed.

  Lemma tree_dir_names_pred'_unchanged : forall tree_ents tree_ents',
    map fst tree_ents = map fst tree_ents' ->
    map (fun e => dirtree_inum e) (map snd tree_ents) = map (fun e => dirtree_inum e) (map snd tree_ents') ->
    map (fun e => dirtree_isdir e) (map snd tree_ents) = map (fun e => dirtree_isdir e) (map snd tree_ents') ->
    tree_dir_names_pred' tree_ents =p=> tree_dir_names_pred' tree_ents'.
  Proof.
    induction tree_ents; intros; destruct tree_ents'; simpl in *; try congruence.
    destruct a; destruct p; simpl in *.
    inversion H; clear H.
    inversion H0; clear H0.
    inversion H1; clear H1.
    subst.
    rewrite IHtree_ents; eauto.
  Qed.

  Lemma flist_crash_xform_tree_dir_names_pred : forall tree_ents tree_ents' xp inum,
    map fst tree_ents = map fst tree_ents' ->
    map (fun e => dirtree_inum e) (map snd tree_ents) = map (fun e => dirtree_inum e) (map snd tree_ents') ->
    map (fun e => dirtree_isdir e) (map snd tree_ents) = map (fun e => dirtree_isdir e) (map snd tree_ents') ->
    flist_crash_xform (tree_dir_names_pred xp inum tree_ents) =p=>
      tree_dir_names_pred xp inum tree_ents'.
  Proof.
    unfold tree_dir_names_pred; intros.
    rewrite flist_crash_xform_exists. norml; unfold stars; simpl.
    rewrite flist_crash_xform_exists. norml; unfold stars; simpl.
    repeat rewrite flist_crash_xform_sep_star.
    repeat rewrite flist_crash_xform_lift_empty.
    rewrite flist_crash_xform_ptsto.
    cancel.
    eapply SDIR.crash_rep; eauto.
    pred_apply.
    apply tree_dir_names_pred'_unchanged; eauto.
  Qed.

  Lemma tree_crash_preserves_dirtree_inum : forall t t',
    tree_crash t t' ->
    dirtree_inum t = dirtree_inum t'.
  Proof.
    inversion 1; auto.
  Qed.

  Lemma tree_crash_preserves_dirtree_isdir : forall t t',
    tree_crash t t' ->
    dirtree_isdir t = dirtree_isdir t'.
  Proof.
    inversion 1; auto.
  Qed.

  Lemma flist_crash_xform_tree_pred : forall xp t,
    flist_crash_xform (tree_pred xp t) =p=> exists t', [[ tree_crash t t' ]] * tree_pred xp t'.
  Proof.
    induction t using dirtree_ind2; simpl; intros.
    - rewrite flist_crash_xform_exists.
      setoid_rewrite flist_crash_xform_sep_star.
      setoid_rewrite flist_crash_xform_ptsto.
      setoid_rewrite flist_crash_xform_lift_empty.
      norml. destruct f'. cancel.
      instantiate (t' := TreeFile inum (mk_dirfile _ _)). cbn. cancel.
      econstructor; eauto.
      unfold file_crash. do 2 eexists. eauto.
    - rewrite flist_crash_xform_sep_star.
      rewrite flist_crash_xform_dirlist_pred by eauto.
      cancel.
      eassign (TreeDir inum tree_ents').
      cancel.
      apply flist_crash_xform_tree_dir_names_pred; eauto.
      eapply Forall2_to_map_eq. apply tree_crash_preserves_dirtree_inum. eauto.
      eapply Forall2_to_map_eq. apply tree_crash_preserves_dirtree_isdir. eauto.
      constructor; eauto.
  Qed.

  Lemma flist_crash_xform_freelist : forall (FP : BFILE.bfile -> Prop) xp frees freepred ms,
    (forall f f', BFILE.file_crash f f' -> FP f -> FP f') ->
    IAlloc.Alloc.rep FP xp frees freepred ms =p=>
      IAlloc.Alloc.rep FP xp frees freepred ms *
      [[ flist_crash_xform freepred =p=> freepred ]].
  Proof.
    unfold IAlloc.Alloc.rep, IAlloc.Alloc.Alloc.rep; intros.
    cancel.
    match goal with H: _ <=p=> _ |- _ => rewrite H end.
    repeat match goal with
      Hb: context [BFILE.file_crash],
      Hother: _ |- _ => clear Hother
    end.
    induction frees; simpl.
    rewrite flist_crash_xform_emp; auto.
    rewrite flist_crash_xform_sep_star. rewrite flist_crash_xform_exists.
    rewrite IHfrees.
    norml; unfold stars; simpl.
    rewrite flist_crash_xform_sep_star.
    rewrite flist_crash_xform_lift_empty.
    rewrite flist_crash_xform_ptsto. cancel. eauto.
  Qed.

  Lemma xform_tree_rep : forall xp F t ilist frees ms msll' sm,
     crash_xform (rep xp F t ilist frees ms sm) =p=>
     exists t',
      [[ tree_crash t t' ]] *
      rep xp (flist_crash_xform F) t' ilist frees (BFILE.ms_empty msll') sm_synced.
  Proof.
    unfold rep; intros.
    xform_norm.
    rewrite BFILE.xform_rep.
    rewrite IAlloc.xform_rep.
    rewrite flist_crash_xform_freelist.
    norml; unfold stars; simpl.
    eapply flist_crash_flist_crash_xform in H0; eauto.
    apply flist_crash_xform_sep_star in H0. rewrite flist_crash_xform_sep_star in H0.
    rewrite flist_crash_xform_tree_pred in H0.
    destruct_lift H0.
    unfold IAlloc.rep; cancel.
    rewrite <- BFILE.rep_clear_freelist.
    rewrite <- BFILE.rep_clear_icache.
    rewrite <- IAlloc.rep_clear_cache.
    cancel.
    eauto.
    pred_apply.
    cancel; auto.
    intros; eapply BFILE.freepred_file_crash; eauto.
  Grab Existential Variables.
    all: exact (LOG.mk_memstate0 (Cache.BUFCACHE.cache0 1)).
  Qed.

  Theorem tree_crash_find_name :
    forall fnlist t t' subtree,
    tree_crash t t' ->
    find_subtree fnlist t = Some subtree ->
    exists subtree',
    find_subtree fnlist t' = Some subtree' /\
    tree_crash subtree subtree'.
  Proof.
    induction fnlist.
    - simpl; intros.
      eexists; intuition eauto.
      inversion H0; subst; auto.
    - intros.
      inversion H0.
      destruct t; try congruence.
      inversion H; subst.
      generalize dependent st'.
      induction l; intros.
      + simpl in *. congruence.
      + destruct st'; try solve [ simpl in *; congruence ].
        destruct p.
        unfold find_subtree_helper in H2 at 1.
        destruct a0.
        simpl in H2.
        destruct (string_dec s0 a).
        * subst.
          edestruct IHfnlist.
          2: apply H2.
          inversion H6; eauto.
          eexists.
          intuition eauto.
          inversion H4; subst.
          simpl; destruct (string_dec s s); try congruence.
        * edestruct IHl.

          eauto.
          eauto.
          all: try solve [ inversion H4; exact H5 ].
          all: try solve [ inversion H6; eauto ].

          constructor. inversion H4; eauto.
          inversion H. inversion H8; eauto.

          exists x. intuition.
          simpl.
          inversion H4; subst. destruct (string_dec s a); try congruence.
          apply H3.
  Qed.

  Theorem tree_crash_find_none :
    forall fnlist t t',
    tree_crash t t' ->
    find_subtree fnlist t = None ->
    find_subtree fnlist t' = None.
  Proof.
    induction fnlist.
    - simpl; intros.
      congruence.
    - intros.
      inversion H0. rewrite H2.
      destruct t; inversion H; subst.
      eauto.

      generalize dependent st'.
      induction l; intros.
      + destruct st'; simpl in *; try congruence.
      + destruct st'; try solve [ simpl in *; congruence ].
        destruct p.
        unfold find_subtree_helper in H2 at 1.
        destruct a0.
        simpl in H2.
        destruct (string_dec s0 a).
        * subst.
          edestruct IHfnlist.
          2: apply H2.
          inversion H6; eauto.
          inversion H4; subst.
          simpl; destruct (string_dec s s); try congruence.
        * edestruct IHl.

          eauto.
          eauto.
          all: try solve [ inversion H4; exact H5 ].
          all: try solve [ inversion H6; eauto ].

          constructor. inversion H4; eauto.
          inversion H. inversion H8; eauto.

          simpl.
          inversion H4; subst. destruct (string_dec s a); try congruence.
  Qed.

  Lemma tree_crash_find_subtree_root: forall t t' inum,
    tree_crash t t' ->
    (exists elem, find_subtree [] t = Some (TreeDir inum elem)) ->
    (exists elem', find_subtree [] t' = Some (TreeDir inum elem')).
  Proof.
    intros.
    destruct t.
    - destruct H0.
      inversion H0.
    - destruct H0.
      unfold find_subtree in *. simpl in *.
      destruct t'.
      inversion H0.
      inversion H0.
      subst; simpl.
      exfalso.
      inversion H.
      inversion H0.
      subst; simpl.
      inversion H.
      subst; simpl; eauto.
  Qed.

  Lemma tree_crash_find_name_root: forall t t' inum,
    tree_crash t t' ->
    find_name [] t = Some (inum, true) ->
    find_name [] t' = Some (inum, true).
  Proof.
    intros.
    destruct t.
    - unfold find_name in H0; subst; simpl.
      unfold find_subtree in H0.
      inversion H0.
    - destruct t'.
      unfold find_name in H0.
      destruct (find_subtree [] (TreeDir n l)).
      destruct d.
      inversion H0.
      inversion H0.
      subst; simpl.
      exfalso.
      inversion H.
      congruence.
      inversion H.
      subst; simpl; eauto.
  Qed.

  Theorem file_crash_exists : forall file, exists file',
    BFILE.file_crash file file'.
  Proof.
    unfold BFILE.file_crash; intros.
    eexists.
    exists (map fst (BFILE.BFData file)).
    intuition.
    split; intros.
    rewrite map_length; eauto.
    unfold vsmerge. constructor.
    erewrite selN_map; eauto.
  Qed.

  Theorem tree_crash_exists : forall tree, exists tree',
    tree_crash tree tree'.
  Proof.
    induction tree using dirtree_ind2; intros.
    edestruct file_crash_exists as [ [] H].
    eexists (TreeFile _ (mk_dirfile _ _)).
    econstructor; cbn. unfold file_crash. do 2 eexists. eauto.
    induction tree_ents.
    eexists; constructor; eauto. constructor.
    destruct a; simpl in *.
    inversion H.
    edestruct IHtree_ents; eauto.
    inversion H4.
    repeat deex.
    exists (TreeDir inum ((s, tree') :: st')).
    constructor. simpl; f_equal; auto.
    constructor; auto.
  Unshelve.
    exact None.
  Qed.

  Theorem tree_crash_update_subtree' :
    forall pn tree subtree tree' subtree',
    tree_crash tree tree' ->
    tree_crash subtree subtree' ->
    tree_crash (update_subtree pn subtree tree) (update_subtree pn subtree' tree').
  Proof.
    induction pn; simpl; intros; eauto.
    destruct tree; simpl in *.
    - inversion H; subst. eauto.
    - inversion H; subst. constructor; eauto.
      + generalize dependent st'.
        induction l; simpl; intros; destruct st'; simpl in *; try congruence.
        inversion H; subst.
        inversion H6; subst.
        inversion H7; subst.
        f_equal.
        destruct a0; destruct p; simpl in *. rewrite H2 in *; clear H2.
        destruct (string_dec s0 a); subst; simpl in *; auto.
        apply IHl; try eassumption. constructor; eauto.
      + generalize dependent st'.
        induction l; simpl; intros; destruct st'; simpl in *; try congruence.
        inversion H; subst.
        inversion H6; subst.
        inversion H7; subst.
        constructor.
        destruct a0; destruct p; simpl in *. rewrite H2 in *; clear H2.
        destruct (string_dec s0 a); subst; simpl in *; auto.
        eapply IHl; try eassumption. constructor; eauto.
  Qed.

  Theorem tree_crash_tree_names_distinct : forall t t',
    tree_crash t t' ->
    tree_names_distinct t ->
    tree_names_distinct t'.
  Proof.
    induction t using dirtree_ind2; simpl in *; intros.
    inversion H; constructor.
    inversion H0; subst.
    inversion H1; subst.
    constructor; try congruence.
    eapply forall_forall2_l in H; try ( eapply forall2_length; eauto ).
    eapply forall_forall2_l in H5; try ( eapply forall2_length; eauto ).
    eapply forall2_forall_r; try ( eapply forall2_length; eauto ).
    eapply forall2_impl. apply H.
    eapply forall2_impl. apply H5.
    eapply forall2_impl. apply H6.
    apply forall2_lift; try ( eapply forall2_length; eauto ).
    intros; eauto.
  Qed.

  Theorem tree_crash_tree_inodes_permutation : forall t t',
    tree_crash t t' ->
    permutation addr_eq_dec (tree_inodes t) (tree_inodes t').
  Proof.
    induction t using dirtree_ind2; simpl; intros.
    - inversion H; subst. constructor.
    - inversion H0; subst.
      generalize dependent st'.
      induction tree_ents; intros; destruct st'; simpl in *; try congruence.
      destruct a. destruct p.
      inversion H5; subst.
      inversion H; subst.
      repeat rewrite cons_app with (l := app _ _).
      eapply permutation_trans. apply permutation_app_comm. rewrite <- app_assoc.
      eapply permutation_trans. 2: apply permutation_app_comm. rewrite <- app_assoc.
      eapply permutation_app_split. eauto.
      eapply permutation_trans. apply permutation_app_comm.
      eapply permutation_trans. 2: apply permutation_app_comm.
      eapply IHtree_ents; eauto.
      constructor; eauto.
      inversion H0; subst. inversion H10; subst. eauto.
      inversion H0; subst. inversion H10; subst. eauto.
  Qed.

  Theorem tree_crash_tree_inodes_distinct : forall t t',
    tree_crash t t' ->
    tree_inodes_distinct t ->
    tree_inodes_distinct t'.
  Proof.
    unfold tree_inodes_distinct; intros.
    eapply NoDup_incl_count; eauto.
    eapply permutation_incl_count.
    apply permutation_comm.
    eapply tree_crash_tree_inodes_permutation; eauto.
  Qed.

  Theorem tree_crash_update_subtree :
    forall pn tree subtree updated_tree_crashed,
    tree_names_distinct tree ->
    tree_crash (update_subtree pn subtree tree) updated_tree_crashed ->
    exists tree_crashed subtree_crashed,
    tree_crash tree tree_crashed /\
    tree_crash subtree subtree_crashed /\
    updated_tree_crashed = update_subtree pn subtree_crashed tree_crashed.
  Proof.
    induction pn; simpl; intros.
    {
      edestruct (tree_crash_exists tree). do 2 eexists; intuition eauto.
    }
    destruct tree; simpl in *.
    {
      inversion H0; subst.
      edestruct (tree_crash_exists subtree). do 2 eexists; intuition eauto.
    }
    inversion H0; clear H0; subst.
    generalize dependent st'.
    induction l; simpl; intros; destruct st'; simpl in *; try congruence.
    {
      edestruct (tree_crash_exists subtree). do 2 eexists; intuition eauto.
      constructor; eauto. auto.
    }
    destruct a0; destruct p; simpl in *.
    inversion H3; clear H3; subst.
    inversion H5; clear H5; subst.
    destruct (string_dec s a); subst; simpl in *.
    {
      clear IHl.
      edestruct IHpn. 2: eauto. eauto. deex.
      exists (TreeDir n ((a, x) :: st')). simpl. destruct (string_dec a a); try congruence. eexists.
      inversion H. inversion H8. subst.
      rewrite update_subtree_notfound with (l := l) in *; eauto.
      intuition eauto.
      constructor; simpl. f_equal; eauto. eauto.

      rewrite update_subtree_notfound; eauto.
      eapply tree_crash_tree_names_distinct in H.
      2: eapply TCDir with (st' := (a, x) :: st').
      inversion H. inversion H10; eauto.
      simpl. f_equal. eauto.
      constructor. eauto. eauto.
    }
    {
      clear IHpn.
      edestruct IHl; clear IHl; eauto. deex.
      destruct x; simpl in *; try congruence.
      exists (TreeDir n ((s, d0) :: l0)). eexists.
      inversion H1; subst.
      intuition eauto. constructor; simpl. f_equal. auto. constructor; eauto.
      simpl. destruct (string_dec s a); try congruence.
    }
  Qed.

  Lemma file_crash_data_length : forall f f',
    file_crash f f' -> length (DFData f) = length (DFData f').
  Proof.
    unfold file_crash; intros.
    repeat deex.
    eapply BFILE.file_crash_data_length in H; simpl in *.
    eauto.
  Qed.

  Lemma file_crash_synced : forall f f',
    file_crash (synced_dirfile f) f' ->
    f' = synced_dirfile f.
  Proof.
    unfold file_crash, synced_dirfile; intros.
    repeat deex.
    edestruct BFILE.file_crash_synced; eauto.
    pose proof (BFILE.fsynced_synced_file (BFILE.mk_bfile (DFData f) (DFAttr f) c)).
    unfold BFILE.synced_file in H0; simpl in *.
    eauto.

    destruct f'; simpl in *.
    subst; eauto.
  Qed.

  Lemma dirfile_crash_exists : forall f, exists f',
    file_crash f f'.
  Proof.
    unfold file_crash; intros.
    edestruct (file_crash_exists (BFILE.mk_bfile (DFData f) (DFAttr f) None)).
    destruct x.
    exists (mk_dirfile BFData BFAttr).
    do 2 eexists.
    simpl; eauto.
  Qed.

End DTCrash.


(**************************************************************************)
(*  This file is part of CertrBPF,                                        *)
(*  a formally verified rBPF verifier + interpreter + JIT in Coq.         *)
(*                                                                        *)
(*  Copyright (C) 2022 Inria                                              *)
(*                                                                        *)
(*  This program is free software; you can redistribute it and/or modify  *)
(*  it under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation; either version 2 of the License, or     *)
(*  (at your option) any later version.                                   *)
(*                                                                        *)
(*  This program is distributed in the hope that it will be useful,       *)
(*  but WITHOUT ANY WARRANTY; without even the implied warranty of        *)
(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the         *)
(*  GNU General Public License for more details.                          *)
(*                                                                        *)
(**************************************************************************)

From bpf.comm Require Import MemRegion State Monad.
From bpf.monadicmodel Require Import rBPFInterpreter.
From dx.Type Require Import Bool.
From dx Require Import IR.
From Coq Require Import List ZArith.
From compcert Require Import Integers Values Clight Memory AST.
From compcert Require Import Coqlib.
Import ListNotations.

From bpf.clightlogic Require Import clight_exec Clightlogic CorrectRel CommonLemma.

From bpf.clight Require Import interpreter.

From bpf.simulation Require Import MatchState InterpreterRel.

(**
Check get_block_perm.

get_block_perm
     : memory_region -> DxMonad.M permission
*)

Section Get_block_perm.
  Context {S: special_blocks}.
  (** The program contains our function of interest [fn] *)
  Definition p : Clight.program := prog.

  (* [Args,Res] provides the mapping between the Coq and the C types *)
  (* Definition Args : list CompilableType := [stateCompilableType].*)
  Definition args : list Type := [(memory_region:Type)].
  Definition res : Type := (permission:Type).

  (* [f] is a Coq Monadic function with the right type *)
  Definition f : arrow_type args (M State.state res) := get_block_perm.

  (* [fn] is the Cligth function which has the same behaviour as [f] *)
  Definition fn: Clight.function := f_get_block_perm.

  (* [match_arg] relates the Coq arguments and the C arguments *)
  Definition match_arg_list : DList.t (fun x => x -> Inv _) args :=
    (dcons (statefull (match_region st_blk mrs_blk ins_blk))
       (DList.DNil _)).

  (* [match_res] relates the Coq result and the C result *)
  Definition match_res : res -> Inv State.state := stateless perm_correct.

  Instance correct_function_get_block_perm : forall a, correct_function _ p args res f fn ModNothing true match_state match_arg_list match_res a.
  Proof.
    correct_function_from_body args.
    correct_body.
    (** how to use correct_* *)
    unfold INV.
    unfold f.
    repeat intro.
    get_invariant _mr.

    unfold match_region in c0.
    destruct c0 as (o & Hptr & Hmatch).
    unfold match_region_at_ofs in Hmatch.
    destruct Hmatch as (_ & _ & (vperm & Hperm_load & Hinj) & _).
    subst.

    (**according to the type:
         static unsigned long long getMemRegion_start_addr(struct memory_region *mr1)
       1. return value should be  `Vlong vaddr`
       2. the memory is same
      *)
    exists (Vint vperm), m, Events.E0.

    split_and; unfold step2.
    -
      repeat forward_star.
      unfold align, Ctypes.alignof; simpl. change (64 / 8)%Z with 8%Z.
      unfold Mem.loadv in Hperm_load.
      rewrite Hperm_load; reflexivity.

      reflexivity.
    - unfold eval_inv,match_res. simpl. unfold correct_perm in Hinj. unfold perm_correct.
      destruct (block_perm c); rewrite Hinj; reflexivity.
    - constructor. reflexivity.
    - auto.
    - apply unmodifies_effect_refl.
  Qed.

End Get_block_perm.

Existing Instance correct_function_get_block_perm.