(* Generic tools for proving properties of (privileged) concrete machine code. *)

Require Import ZArith.
Require Import Lia.
Require Import List.
Require Import Utils.
Require Import LibTactics.
Import ListNotations.

Require Utils.
Require Import Instr Memory.
Require Import Lattices.
Require Import Concrete.
Require Import CodeGen.
Require Import ConcreteMachine.
Require Import Coq.Arith.Compare_dec.
Require Import ConcreteExecutions.
Require Import EquivDec.
Require Import CodeTriples.

Local Notation val := (val privilege).
Local Notation Atom := (Atom val privilege).
Local Notation memory := (Mem.t Atom privilege).
Local Notation PcAtom := (PcAtom val).
Local Notation block := (block privilege).
Definition HProp := memory -> stack -> Prop.

Definition extension_comp (P : HProp) :=
  forall m1 m2 s, P m1 s -> extends m1 m2 -> P m2 s.

Ltac go_match :=
  try match goal with
    | H1: extends ?m1 ?m2,
      H2: extends ?m2 ?m3 |- _ => assert (Hext_trans: extends m1 m3) by (unfold extends in *; eauto)
  end;
  let H := fresh "H" in
  try (simpl; intros ? ? H);
    repeat match goal with
             | [H: match ?sss with _ => _ end |- _ ] =>
               destruct sss ; intuition ;
               try (substs; eauto)
           end.

Ltac split_vc :=
  (simpl;
   match goal with
   | H: exists X,_ |- _ => (destruct H; split_vc)
   | H: ?P /\ ?Q |- _ => (destruct H; split_vc)
   | |- forall P, _ => (intro; try subst; split_vc)
   | |- exists X, _ => (eexists; split_vc)
   | |- ?P /\ ?Q => (split; [(eauto; try (zify; lia);fail) | split_vc])
   | _ => (eauto; try (zify; lia))
   end).

Ltac split_vc' :=
  (try subst; simpl;
   match goal with
   | H: exists X,_ |- _ => (destruct H; split_vc')
   | H: ?P /\ ?Q |- _ => (destruct H; split_vc')
   | |- exists X, _ => (eexists; split_vc')
   | |- ?P /\ ?Q => (split; [(eauto; try (zify; lia);fail) | split_vc'])
   | _ => (eauto; try (zify; lia))
   end).

Ltac run1 L := eapply rte_step; eauto; eapply L; eauto.

Section CodeSpecs.
Local Open Scope Z_scope.

Variable cblock : block.
Variable stamp_cblock : Mem.stamp cblock = Kernel.
Variable table : CSysTable.

Notation cstep := (cstep cblock table).
Notation runsToEscape := (runsToEscape cblock table).
Notation HT := (HT cblock table).
Notation HTEscape := (HTEscape cblock table).

(* To stop struggling with [replace]s *)
Lemma cstep_branchnz_p' : forall m fh i s pcv pcl offv av al pc',
       read_m pcv fh = Some (BranchNZ offv) ->
       pc' = (if av =? 0 then pcv + 1 else pcv + offv) ->
       cstep (CState m fh i ((Vint av, al) ::: s) (pcv, pcl) true) Silent
             (CState m fh i s (pc',handlerTag) true).
Proof.
  intros. subst.
  [> once (econstructor; solve [eauto]) ..].
Qed.

Definition imemory : Type := list Instr.
Definition stack : Type := list CStkElmt.
Definition code := list Instr.
Definition state := CS.

(* ================================================================ *)
(* Specs for concrete code *)

Ltac nil_help :=   replace (@nil CEvent) with (op_cons Silent (@nil CEvent)) by reflexivity.

Lemma add_spec : forall Q,
  HT [Add]
     (fun m0 s0 =>
        exists v1 t1 v2 t2 vr s,
          s0 = (v1,t1) ::: (v2,t2) ::: s /\
          add v1 v2 = Some vr /\
          Q m0 ((vr,handlerTag) ::: s))
     Q.
Proof.
  unfold CodeTriples.HT; split_vc; subst; run1 cstep_add_p.
Qed.

Lemma sub_spec : forall Q,
  HT [Sub]
     (fun m0 s0 =>
        exists v1 t1 v2 t2 vr s,
          s0 = (v1,t1) ::: (v2,t2) ::: s /\
          Memory.sub v1 v2 = Some vr /\
          Q m0 ((vr,handlerTag) ::: s))
     Q.
Proof.
  unfold CodeTriples.HT; split_vc; subst; run1 cstep_sub_p.
Qed.

Lemma dup_spec:
  forall n Q,
  HT [Dup n]
     (fun m s => exists x, index_list n s = Some x /\ Q m (x :: s))
     Q.
Proof.
  unfold CodeTriples.HT; split_vc; subst; run1 cstep_dup_p.
Qed.

Lemma swap_spec: forall n Q,
  HT [Swap n]
     (fun m s => exists y s0 x s', s = y::s0 /\
                                   index_list n s = Some x /\
                                   update_list n y (x::s0) = Some s' /\
                                   Q m s')
     Q.
Proof.
  unfold CodeTriples.HT; split_vc; subst; run1 cstep_swap_p.
Qed.

Lemma push_spec: forall v Q,
  HT [Push v]
     (fun m s => Q m (CData (Vint v,handlerTag) :: s))
     Q.
Proof.
  unfold CodeTriples.HT; split_vc; subst; run1 cstep_push_p.
Qed.

Lemma PushCachePtr_spec : forall Q,
  HT [PushCachePtr]
     (fun m s =>
        Q m (CData (Vptr (cblock, 0),handlerTag) :: s))
     Q.
Proof.
  unfold CodeTriples.HT; split_vc; subst; run1 cstep_push_cache_ptr_p.
Qed.

Lemma load_spec : forall Q,
  HT [Load]
     (fun m s0 => exists p t x s,
                    s0 = (Vptr p,t) ::: s /\
                    Mem.stamp (fst p) = Kernel /\
                    load p m = Some x /\
                    Q m (x ::: s))
     Q.
Proof.
  unfold CodeTriples.HT; split_vc; subst; run1 cstep_load_p.
Qed.

Lemma unpack_spec : forall Q,
  HT [Unpack]
     (fun m s => exists x l s0,
                   s = (x,l):::s0 /\
                   Q m ((l,handlerTag):::(x,handlerTag):::s0))
     Q.
Proof.
  unfold CodeTriples.HT; split_vc; subst; run1 cstep_unpack_p.
Qed.

Lemma pack_spec : forall Q,
  HT [Pack]
     (fun m s => exists x t l l0 s0,
                   s = (l,t):::(x,l0):::s0 /\
                   Q m ((x,l):::s0))
     Q.
Proof.
  unfold CodeTriples.HT; split_vc; subst; run1 cstep_pack_p.
Qed.

Lemma pop_spec: forall Q,
  HT [Pop]
     (fun m s => exists v vl s0, s = (v,vl):::s0 /\ Q m s0)
     Q.
Proof.
  unfold CodeTriples.HT; split_vc; subst; run1 cstep_pop_p.
Qed.

Lemma nop_spec: forall Q, HT [Noop] Q Q.
Proof.
  unfold CodeTriples.HT; split_vc; subst; run1 cstep_nop_p.
Qed.

Lemma store_spec : forall Q,
  HT [Store]
     (fun (m0 : memory) (s0 : stack) =>
        exists p al v m s,
          Mem.stamp (fst p) = Kernel /\
          s0 = (Vptr p, al) ::: v ::: s /\ store p v m0 = Some m /\ Q m s)
     Q.
Proof.
  unfold CodeTriples.HT; split_vc; subst; run1 cstep_store_p.
Qed.

Lemma alloc_spec : forall Q : _ -> _ -> Prop,
  HT [Alloc]
     (fun m0 s0 => exists s t xv xl cnt,
                     s0 = (Vint cnt,t) ::: (xv, xl) ::: s /\
                     cnt >= 0 /\
                     (forall b m,
                        c_alloc Kernel cnt (xv,xl) m0 = Some (b, m) ->
                        Q m ((Vptr (b, 0),handlerTag):::s)))
     Q.
Proof.
  intros. unfold CodeTriples.HT. intros.
  inv H.
  destruct H0 as (s & t & xv & xl & cnt & ? & ? & ?).
  assert (ALLOC: exists b m',
                   c_alloc Kernel cnt (xv,xl) mem0 = Some(b,m')).
  { unfold c_alloc, alloc, zreplicate.
    destruct (Z_lt_dec cnt 0); try lia.
    match goal with
      | |- context [Some ?p = Some _] => destruct p
    end.
    eauto. }
  split_vc; subst; run1 cstep_alloc_p.
Qed.

Lemma getoff_spec : forall Q : _ -> _ -> Prop,
  HT [GetOff]
     (fun m s =>
        exists p t s0,
          s = (Vptr p, t) ::: s0 /\
          forall t', Q m ((Vint (snd p), t') ::: s0))
     Q.
Proof.
  unfold CodeTriples.HT; split_vc; subst; run1 cstep_getoff_p.
Qed.

Lemma genEq_spec : forall Q,
  HT genEq
     (fun m s => exists v1 t1 v2 t2 s0 ,
                   s = (v1,t1):::(v2,t2):::s0 /\
                   Q m ((val_eq v1 v2,handlerTag):::s0))
     Q.
Proof.
  unfold genEq. unfold CodeTriples.HT; split_vc; run1 cstep_eq_p.
Qed.

Ltac apply_wp :=
  try unfold pop, nop, push, dup, swap, sub, genEq;
  try eapply add_spec;
  try eapply sub_spec;
  try eapply genEq_spec;
  try eapply dup_spec;
  try eapply swap_spec;
  try eapply push_spec;
  try eapply pop_spec;
  try eapply PushCachePtr_spec;
  try eapply alloc_spec;
  try eapply load_spec;
  try eapply store_spec;
  try eapply unpack_spec;
  try eapply pack_spec;
  try eapply getoff_spec;
  simpl.

Ltac build_vc wptac :=
  let awp := (try apply_wp; try wptac) in
  try (eapply HT_compose_flip; [(build_vc wptac; awp)| (awp; eapply HT_strengthen_premise; awp)]).

Lemma push_cptr_spec :
  forall v Q,
    HT (push_cptr v)
       (fun m s => Q m ((Vptr (cblock, v), handlerTag) ::: s))
       Q.
Proof.
  unfold push_cptr.
  intros.
  build_vc ltac:(idtac).
  split_vc.
  replace (v + 0) with v by lia. auto.
Qed.

Lemma loadFromCache_spec: forall ofs (Q : _ -> _ -> Prop),
  HT (loadFromCache ofs)
     (fun m s =>
        exists v,
          value_on_cache cblock m ofs v /\
          forall t, Q m (CData (v, t) :: s))
     Q.
Proof.
  intros.
  unfold loadFromCache.
  build_vc ltac:(try eapply push_cptr_spec).
  split_vc'.
  intros m s (? & [] & POST).
  split_vc.
Qed.

Lemma storeAt_spec: forall a Q,
  HT (storeAt a)
     (fun m0 s0 => exists vl s m,
                     s0 = vl ::: s /\
                     store (cblock, a) vl m0 = Some m /\
                     Q m s)
     Q.
Proof.
  intros.
  unfold storeAt.
  build_vc ltac:(try eapply push_cptr_spec).
  split_vc; subst.
  intuition; eauto. (* split_vc can't quite manage the order *)
Qed.

Lemma skipNZ_continuation_spec_NZ: forall c P v,
  v <> 0 ->
  HT   (skipNZ (length c) ++ c)
       (fun m s => (exists s' l, s = CData (Vint v,l) :: s'
                                 /\ P m s'))
       P.
Proof.
  unfold CodeTriples.HT; split_vc.

  (* massage to match the rule we want to run *)
  match goal with
    | |- context[n + ?z] =>
      replace (n + z) with (if v =? 0 then n + 1 else n + z)
  end.
  run1 cstep_branchnz_p.
  rewrite <- Z.eqb_neq in H. rewrite H. auto.
Qed.

Lemma skipNZ_spec_Z: forall n P v,
  v = 0 ->
  HT   (skipNZ n)
       (fun m s => (exists s' l, s = CData (Vint v,l) :: s'
                                 /\ P m s'))
       P.
Proof.
  unfold CodeTriples.HT; split_vc; run1 cstep_branchnz_p.
Qed.

Lemma skipNZ_continuation_spec_Z: forall c P Q v,
  v = 0 ->
  HT   c P Q  ->
  HT   (skipNZ (length c) ++ c)
       (fun m s => (exists s' l, s = CData (Vint v,l) :: s'
                                 /\ P m s'))
       Q.
Proof.
  intros c P Q v l Hv HTc.
  eapply HT_compose.
  eapply skipNZ_spec_Z; auto.
  auto.
Qed.

Lemma skip_spec: forall c P,
  HT   (skip (length c) ++ c)
       P
       P.
Proof.
  intros c P.
  eapply HT_strengthen_premise.
  { unfold skip.
    rewrite app_ass.
    eapply HT_compose; try eapply push_spec.
    eapply skipNZ_continuation_spec_NZ with (v:= 1); lia. }
  simpl. intros.
  repeat eexists. auto.
Qed.

Lemma ifNZ_spec_Z: forall v t f P Q,
  HT   f P Q ->
  v = 0 ->
  HT   (ifNZ t f)
       (fun m s => (exists s' l, s = CData (Vint v,l) :: s' /\ P m s'))
       Q.
Proof.
  intros v l t f P Q HTf Hveq0.
  unfold ifNZ.
  rewrite app_ass.
  eapply HT_compose.

  apply skipNZ_spec_Z; auto.

  eapply HT_compose; eauto.

  apply skip_spec.
Qed.

Lemma ifNZ_spec_NZ: forall v t f P Q,
  HT   t P Q ->
  v <> 0 ->
  HT   (ifNZ t f)
       (fun m s => (exists s' l, s = CData (Vint v,l) :: s' /\ P m s'))
       Q.
Proof.
  intros v l t f P Q HTt Hveq0.
  unfold ifNZ.
  rewrite <- app_ass.
  eapply HT_compose; eauto.
  apply skipNZ_continuation_spec_NZ; auto.
Qed.

Lemma ifNZ_spec_helper: forall v t f Pt Pf Q,
  HT   t Pt Q ->
  HT   f Pf Q ->
  HT   (ifNZ t f)
       (fun m s => ((v <> 0 -> exists s' l, s = CData (Vint v,l) :: s' /\ Pt m s') /\
                    (v =  0 -> exists s' l, s = CData (Vint v,l) :: s' /\ Pf m s')))
       Q.
Proof.
  intros v l t f Pt Pf Q HTt HTf.
  eapply HT_decide_join' with (D := fun v => v = 0).
  apply ifNZ_spec_NZ.
  apply ifNZ_spec_Z.
  intros; lia.
  auto.
  auto.
Qed.

Lemma ifNZ_spec: forall t f Pt Pf Q,
  HT   t Pt Q ->
  HT   f Pf Q ->
  HT   (ifNZ t f)
       (fun m s => (exists v l s', s = CData (Vint v,l) :: s' /\
                                   (v <> 0 -> Pt m s') /\
                                   (v =  0 -> Pf m s')))
       Q.
Proof.
  intros t f Pt Pf Q HTt HTf.
  eapply HT_forall_exists. intros v.
  eapply HT_forall_exists. intros l.
  eapply HT_forall_exists. intros s'.
  eapply HT_strengthen_premise.
  eapply ifNZ_spec_helper; eauto.
  intros m s (? & H1 & H2). subst.
  destruct (dec_eq v 0); subst; intuition;
    eexists; intuition eauto.
Qed.

Lemma ite_spec: forall c t f (P Pt Pf: HProp) Q,
  let P' := fun m s => exists v l s', s = (Vint v,l) ::: s' /\
                                      (v <> 0 -> Pt m s') /\
                                      (v =  0 -> Pf m s') in
  HT   c P P' ->
  HT   t Pt Q ->
  HT   f Pf Q ->
  HT   (ite c t f) P Q.
Proof.
  intros c t f P Pt Pf Q P' HTc HTt HTf.
  unfold ite.
  eapply HT_compose.
  apply HTc.
  apply ifNZ_spec.
  auto.
  auto.
Qed.

Lemma cases_spec_base: forall d P Q,
  HT   d P Q -> HT   (cases nil d) P Q.
Proof.
  auto.
Qed.

Lemma cases_spec_step: forall c b cbs d P (Pt Pf Q: HProp),
  let P' := fun m s => exists v l s', s = (Vint v,l) ::: s' /\
                                      (v <> 0 -> Pt m s') /\
                                      (v =  0 -> Pf m s') in
  HT   c P P' ->
  HT   b Pt Q ->
  HT   (cases cbs d) Pf Q ->
  HT   (cases ((c,b)::cbs) d) P Q.
Proof.
  intros.
  eapply ite_spec; eauto.
Qed.

(* [HProp] with ghost variables *)
Definition GProp := memory -> stack -> HProp.
(* Ghost prop Hoare triple *)
Definition GT (c: code) (P: HProp) (Q: GProp) := forall m0 s0,
  HT c (fun m s => P m0 s0 /\ m = m0 /\ s = s0)
       (Q m0 s0).

Lemma GT_consequence':
  forall (c : code) (P' P: HProp) (Q Q': GProp),
    GT c P Q ->
    (forall m s, P' m s -> P m s) ->
    (forall m0 s0 m s, P m0 s0 -> Q m0 s0 m s -> Q' m0 s0 m s) ->
    GT c P' Q'.
Proof.
  unfold GT; intros.
  eapply HT_consequence'; jauto.
Qed.

Definition HFun  := memory -> stack -> Z.

Lemma cases_spec_base_GT_specialized: forall cnil P Qnil,
  GT cnil P Qnil ->
  GT (cases [] cnil) P Qnil.
Proof.
unfold GT; intros; eapply cases_spec_base.
  eapply HT_strengthen_premise; eauto.
Qed.

Definition GT_push_v (c: code) (P: HProp) (v: HFun): Prop :=
  GT c P (fun m0 s0 m s => P m0 s0 /\
                           m = m0 /\
                           exists t, s = CData (Vint (v m0 s0), t) :: s0).
Definition GT_guard_v (b: code) (P: HProp) (v: HFun) (Q: GProp): Prop :=
  GT b (fun m s => P m s /\ v m s <> 0) Q.

Lemma cases_spec_step_GT_specialized: forall c v b cbs cnil P Qb Qcbs,
  GT_push_v c P v ->
  GT_guard_v b P v Qb ->
  GT (cases cbs cnil) P Qcbs ->
  GT (cases ((c,b)::cbs) cnil)
     P
     (fun m0 s0 m s => (v m0 s0 <> 0 -> Qb m0 s0 m s) /\
                       (v m0 s0 = 0 -> Qcbs m0 s0 m s)).
Proof.
  intros c vc b cbs d P Qb Qcbs Hc Hb Hcbs.
  intros m0 s0.
  pose (Hc m0 s0) as Hcm0s0.
  eapply ite_spec with (Pt := (fun m s => P m0 s0 /\ m = m0 /\ s = s0 /\ vc m0 s0 <> 0))
                       (Pf := (fun m s => P m0 s0 /\ m = m0 /\ s = s0 /\ vc m0 s0 =  0)).
  eapply HT_weaken_conclusion.
  exact Hcm0s0.

  intros m s (POST & ? & t & ?). subst.
  exists (vc m0 s0).
  exists t.
  exists s0.
  intuition; subst; auto.

  apply (HT_consequence' _ _ _ _ _ _ _ (Hb m0 s0)); intuition.
  elimtype False; jauto.

  fold cases.
  apply (HT_consequence' _ _ _ _ _ _ _ (Hcbs m0 s0)); intuition.
  elimtype False; jauto.
Qed.

Section IndexedCasesSpec.

Variable cnil: code.
Variable Qnil: GProp.
Variable I: Type.
Variable genC genB: I -> code.
Variable genQ: I -> GProp.
Variable genV: I -> HFun.

(* XXX: make these folds ? *)
Definition indexed_post: (list I) -> GProp :=
  fix f (indices: list I) :=
    fun m0 s0 m s =>
      match indices with
      | []            => Qnil m0 s0 m s
      | i :: indices' => (genV i m0 s0 <> 0 -> genQ i m0 s0 m s) /\
                         (genV i m0 s0 =  0 -> f indices' m0 s0 m s)
      end.

Variable P: HProp.
Definition indexed_hyps: (list I) -> Prop :=
  fix f (indices: list I) :=
    match indices with
    | []            => True
    | i :: indices' => GT_push_v (genC i) P (genV i) /\
                       GT_guard_v (genB i) P (genV i) (genQ i) /\
                       f indices'
    end.

Lemma indexed_cases_spec: forall is,
  GT cnil P Qnil ->
  indexed_hyps is ->
  GT (indexed_cases cnil genC genB is)
     P
     (indexed_post is).
Proof.
  induction is; intros.
  - eapply cases_spec_base_GT_specialized; eauto.
  - simpl in *.
    eapply cases_spec_step_GT_specialized; iauto.
Qed.

End IndexedCasesSpec.

Section GT_ext.

Definition GT_ext (c: code) (P: HProp) (Q: GProp) :=
  forall m0 s0,
    HT c
       (fun m s => P m0 s0 /\ extends m0 m /\ s = s0)
       (Q m0 s0).

Lemma GT_consequence'_ext:
  forall (c : code) (P' P: HProp) (Q Q': GProp),
    GT_ext c P Q ->
    (forall m s, P' m s -> P m s) ->
    (forall m0 s0 m s, P m0 s0 -> Q m0 s0 m s -> Q' m0 s0 m s) ->
    GT_ext c P' Q'.
Proof.
  unfold GT_ext; intros.
  eapply HT_consequence'; jauto.
Qed.

Lemma cases_spec_base_GT_ext_specialized: forall cnil P Qnil,
  GT_ext cnil P Qnil ->
  GT_ext (cases [] cnil) P Qnil.
Proof.
unfold GT_ext; intros; eapply cases_spec_base.
  eapply HT_strengthen_premise; eauto.
Qed.

Definition GT_push_v_ext (c: code) (P: HProp) (v: HFun): Prop :=
  GT_ext c P (fun m0 s0 m s => exists t, P m0 s0 /\
                               extends m0 m /\
                               s = CData (Vint (v m0 s0), t) :: s0).
Definition GT_guard_v_ext (b: code) (P: HProp) (v: HFun) (Q: GProp): Prop :=
  GT_ext b (fun m s => P m s /\ v m s <> 0) Q.

Lemma cases_spec_step_GT_ext_specialized: forall c v b cbs cnil P Qb Qcbs,
  GT_push_v_ext c P v ->
  GT_guard_v_ext b P v Qb ->
  GT_ext (cases cbs cnil) P Qcbs ->
  GT_ext (cases ((c,b)::cbs) cnil)
     P
     (fun m0 s0 m s =>   (v m0 s0 <> 0 -> Qb m0 s0 m s)
                         /\ (v m0 s0 = 0 -> Qcbs m0 s0 m s)).
Proof.
  intros c vc b cbs d P Qb Qcbs Hc Hb Hcbs.
  intros m0 s0.
  pose (Hc m0 s0) as Hcm0s0.
  eapply ite_spec with (Pt := (fun m s => P m0 s0 /\ extends m0 m /\ s = s0 /\ vc m0 s0 <> 0))
                       (Pf := (fun m s => P m0 s0 /\ extends m0 m /\ s = s0 /\ vc m0 s0 =  0)).
  - eapply HT_weaken_conclusion.
    eapply Hc.
    go_match.
    split_vc.
  - eapply HT_consequence'.
    + eapply Hb; eauto.
    + intros. intuition.
      * eapply H0.
      * elimtype False; jauto.
      * auto.
      * auto.
    + intros.
      destruct H as [m' [s' [HPm0s0 [Hextm0 [Hs' Hcond]]]]]. substs.
      split; eauto.
      intuition.
  - fold cases.
    eapply HT_consequence'.
    eapply Hcbs.
    simpl. iauto.
    intros. intuition.
    elimtype False; jauto.
Qed.

Section IndexedCasesSpec_EXT.

Variable cnil: code.
Variable Qnil: GProp.
Variable I: Type.
Variable genC genB: I -> code.
Variable genQ: I -> GProp.
Variable genV: I -> HFun.

(* XXX: make these folds ? *)
Definition indexed_post_ext: (list I) -> GProp :=
  fix f (indices: list I) :=
    fun m0 s0 m s =>
      match indices with
      | []            => Qnil m0 s0 m s
      | i :: indices' =>
                         (genV i m0 s0 <> 0 -> genQ i m0 s0 m s) /\
                         (genV i m0 s0 =  0 -> f indices' m0 s0 m s)
      end.

Variable P: HProp.
Definition indexed_hyps_ext: (list I) -> Prop :=
  fix f (indices: list I) :=
    match indices with
    | []            => True
    | i :: indices' => GT_push_v_ext (genC i) P (genV i) /\
                       GT_guard_v_ext (genB i) P (genV i) (genQ i) /\
                       f indices'
    end.

Lemma indexed_cases_spec_ext: forall is,
  GT_ext cnil P Qnil ->
  indexed_hyps_ext is ->
  GT_ext (indexed_cases cnil genC genB is)
     P
     (indexed_post_ext is).
Proof.
  induction is; intros.
  - eapply cases_spec_base_GT_ext_specialized; eauto.
  - simpl in *.
    eapply cases_spec_step_GT_ext_specialized; iauto.
Qed.

End IndexedCasesSpec_EXT.

End GT_ext.

Lemma some_spec:
  forall c P Q,
    HT c P (fun m s => Q m ((Vint 1,handlerTag) ::: s)) ->
    HT (some c) P Q.
Proof.
  intros.
  unfold some.
  eapply HT_compose; eauto.
  eapply push_spec.
Qed.

Definition none_spec     := push_spec.
Definition genTrue_spec  := push_spec.
Definition genFalse_spec := push_spec.

Definition ZtoBool (z:Z) :=  negb (z =? 0).
Definition valToBool (v : val) :=
  match v with
    | Vint 0 => false
    | _ => true
  end.

Lemma val_eq_int :
  forall z1 z2,
    val_eq (Vint z1) (Vint z2) = Vint (boolToZ (z1 =? z2)).
Proof.
  unfold val_eq.
  intros.
  destruct (equiv_dec (Vint z1) (Vint z2)) as [E | E].
  - inv E. rewrite Z.eqb_refl. reflexivity.
  - assert (E' : z1 <> z2) by congruence.
    rewrite <- Z.eqb_neq in E'.
    rewrite E'. reflexivity.
Qed.

Definition andv (v1 v2 : val) : val :=
  if valToBool v1 then v2 else Vint 0.

Lemma genAnd_spec: forall (Q:memory -> stack -> Prop),
  HT genAnd
     (fun m s => exists v1 t1 v2 t2 s0,
                   s = (v1,t1):::(v2,t2):::s0 /\
                   forall t, Q m ((andv v1 v2,t):::s0))
     Q.
Proof.
  intros.
  eapply HT_forall_exists.  intro v1.
  eapply HT_forall_exists.  intro t1.
  eapply HT_forall_exists.  intro v2.
  eapply HT_forall_exists.  intro t2.
  eapply HT_forall_exists.  intro s0.
  unfold genAnd, andv.
  destruct (valToBool v1) eqn:E.
  - assert (v1 <> Vint 0). { intro. subst. unfold valToBool in E. congruence. }
    eapply HT_strengthen_premise.
    + eapply HT_compose; try eapply push_spec.
      eapply HT_compose; try eapply genEq_spec.
      eapply ifNZ_spec_Z with (v:=0); eauto.
      apply nop_spec.
    + split_vc.  subst. split_vc. split; eauto.
      unfold val_eq. destruct (equiv_dec (Vint 0) v1).  congruence. eauto.
  - assert (v1 = Vint 0). { unfold valToBool in E. destruct v1 as [[]|]; congruence. }
    eapply HT_strengthen_premise.
    + eapply HT_compose; try eapply push_spec.
      eapply HT_compose; try eapply genEq_spec.
      eapply ifNZ_spec_NZ with (v:=1); try lia.
      eapply HT_compose; try eapply pop_spec.
      eapply genFalse_spec.
    + split_vc. subst. rewrite val_eq_int.
      split; eauto. split_vc.
Qed.

Definition orv (v1 v2 : val) : val :=
  if valToBool v1 then Vint 1 else v2.

Lemma genOr_spec : forall (Q:memory -> stack -> Prop),
  HT genOr
     (fun m s => exists v1 t1 v2 t2 s0,
                   s = (v1,t1):::(v2,t2):::s0 /\
                   forall t, Q m ((orv v1 v2,t):::s0))
     Q.
Proof.
  intros.
  eapply HT_forall_exists.  intro v1.
  eapply HT_forall_exists.  intro t1.
  eapply HT_forall_exists.  intro v2.
  eapply HT_forall_exists.  intro t2.
  eapply HT_forall_exists.  intro s0.
  intros.
  unfold genOr, orv.
  destruct (valToBool v1) eqn:E.
  - assert (v1 <> Vint 0). { intro. subst. unfold valToBool in E. congruence. }
    eapply HT_strengthen_premise.
    + eapply HT_compose; try eapply push_spec.
      eapply HT_compose; try eapply genEq_spec.
      eapply ifNZ_spec_Z with (v:=0); eauto.
      eapply HT_compose; try eapply pop_spec.
      eapply genTrue_spec.
    + split_vc. subst. split_vc. split; eauto.
      unfold val_eq. destruct (equiv_dec (Vint 0) v1).  congruence. eauto.
  - assert (v1 = Vint 0). { unfold valToBool in E. destruct v1 as [[]|]; congruence. }
    eapply HT_strengthen_premise.
    + eapply HT_compose; try eapply push_spec.
      eapply HT_compose; try eapply genEq_spec.
      eapply ifNZ_spec_NZ with (v:=1); try lia.
      eapply nop_spec.
    + split_vc. subst. rewrite val_eq_int. split; eauto.
Qed.

Lemma genNot_spec : forall Q : _ -> _ -> Prop,
  HT genNot
     (fun m s => exists v t s0,
                   s = (Vint v, t) ::: s0 /\
                   forall t', Q m ((Vint (boolToZ (v =? 0)),t') ::: s0))
     Q.
Proof.
  intros Q.
  eapply HT_forall_exists. intros v.
  eapply HT_forall_exists. intros t.
  eapply HT_forall_exists. intros s0.
  intros.
  unfold genNot.
  cases (0 =? v) as Heq.
  - apply Z.eqb_eq in Heq. subst.
    eapply HT_strengthen_premise.
    + eapply HT_compose; try eapply push_spec.
      eapply genEq_spec.
    + split_vc. subst. split_vc. rewrite val_eq_int. simpl. auto.
  - eapply HT_strengthen_premise.
    + eapply HT_compose; try eapply push_spec.
      eapply genEq_spec.
    + split_vc. subst. split_vc. rewrite val_eq_int. rewrite Z.eqb_sym. eauto.
Qed.

Lemma genTestEqual_spec:
  forall c1 c2 (P Q R : HProp),
    HT c2 Q (fun m s => exists v1 t1 v2 t2 s0,
                          s = (v1,t1) ::: (v2,t2) ::: s0 /\
                          forall t',
                            R m ((val_eq v1 v2, t') ::: s0)) ->
    HT c1 P Q ->
    HT (genTestEqual c1 c2) P R.
Proof.
  intros.
  unfold genTestEqual.
  eapply HT_compose; eauto.
  eapply HT_compose; eauto.
  eapply HT_strengthen_premise; try eapply genEq_spec.
  intros m s (v1 & t1 & v2 & t2 & s0 & ? & ?). subst.
  repeat eexists. eauto.
Qed.

(* ********* Specifications for loops **************** *)

Lemma genLoop_spec: forall c I,
(forall i, 0 < i ->
  HT c
     (fun m s => exists s' t, s = CData (Vint i,t) :: s' /\ I m s)
     (fun m s => exists i' s' t, s = CData (Vint i',t) :: s' /\ I m (CData (Vint i',t) :: s') /\ 0 <= i' < i)) ->
HT (genLoop c)
     (fun m s => exists i, 0 < i /\ exists s' t, s = CData (Vint i,t) :: s' /\ I m s)
     (fun m s => exists s' t, s = CData (Vint 0,t) :: s' /\ I m s).
Proof.
  intros c I P.
  eapply HT_forall_exists. intros i.
  eapply HT_fold_constant_premise. intros H.
  unfold genLoop, dup.
  assert (0 <= i) by lia. generalize dependent H.
  set (Q := fun i => 0 < i ->
   HT (c ++ [Dup 0] ++ [BranchNZ (- Z.of_nat (length (c ++ [Dup 0])))])
     (fun (m : memory) (s : stack) => exists s' t, s = (Vint i, t) ::: s' /\ I m s)
     (fun (m : memory) (s : stack) => exists s' t, s = (Vint 0, t) ::: s' /\ I m s)).
  generalize dependent i.
  eapply (Zlt_0_ind Q); unfold Q; clear Q.
  intros i.
  unfold CodeTriples.HT in *. intros.
  destruct H3 as [s' [t' [P1 P2]]].

  edestruct P as [stk1 [cache1 [[i' [s'' [t'' [Q1 [Q2 Q3]]]]] Q4]]].
  eauto.
  eapply code_at_compose_1; eauto.
  eexists. eexists. split. eauto. subst stk0.  eauto. eauto.
  subst stk1.
  replace (@nil CEvent) with (@nil CEvent ++ @nil CEvent) by auto.
  pose proof (code_at_compose_2 _ _ _ _ H2).
  pose proof (code_at_compose_1 _ _ _ _ H3).
  pose proof (code_at_compose_2 _ _ _ _ H3).
  clear H3.
  unfold code_at in H5,H6. intuition.
  rewrite app_length in H4, H5. simpl in H4, H5.

  destruct (i =? 0) eqn:EQ.

  (* impossible *)
  apply Z.eqb_eq in EQ. subst i. inv H1.  clear EQ.

  destruct (i' =? 0) eqn: EQ.

  - (* no loop *)
  apply Z.eqb_eq in EQ. subst i'.
  eexists. eexists. split. eexists. eexists. split. eauto. eauto.
  eapply runsToEnd_trans.
  eapply Q4. clear Q4.

  eapply runsToEnd_trans.
  eapply rte_step; eauto.
  eapply cstep_dup_p; eauto.  simpl. eauto.
  subst.
  eapply rte_step; eauto.
  eapply cstep_branchnz_p'; eauto.
  destruct (0 =? 0) eqn:E.
     eapply rte_refl; eauto.
     inv E.
  replace (n + Z.of_nat (length c) + 1 + 1) with (n + Z.of_nat (length c + 2)) by (zify; lia). subst n'. eauto.

  - (* loop *)
  assert (i' <> 0).  eapply Z.eqb_neq;  eauto.
  edestruct H as [stk3 [cache3 [[s''' [t''' [R1 R2]]] R3]]].
  instantiate (1:= i').  lia.
  zify; lia.
  eauto.
  exists s''.  eauto. eauto.
  eexists.  eexists. split. eexists. eexists. split. eauto. eauto.
  eapply runsToEnd_trans.
  eapply Q4.  clear Q4.
  repeat rewrite app_length in *. simpl in R3.
  eapply runsToEnd_trans.
  eapply rte_step.  eauto.
  eapply cstep_dup_p; eauto.
  simpl; eauto.
  eapply rte_step; eauto.
  eapply cstep_branchnz_p'; eauto.
  rewrite EQ. zify ; lia.
  subst.
  eapply rte_refl; auto.

Qed.

Lemma genFor_spec :
  forall I c (Q : HProp)
         (HTc : forall i,
                  i > 0 ->
                  exists Pc,
                    HT c Pc
                       (fun m s => exists t s', s = (Vint i, t) ::: s' /\ I Q m s' (Z.pred i)) /\
                    forall m s t, I Q m s i -> Pc m ((Vint i,t):::s))
         (VC : forall m s t, I Q m s 0 -> Q m ((Vint 0,t):::s)),
    HT (genFor c)
       (fun m s => exists i t s',
                     s = (Vint i,t) ::: s' /\
                     i >= 0 /\
                     I Q m s' i)
       Q.
Proof.
  intros.
  unfold genFor.
  eapply HT_strengthen_premise.
  { eapply HT_compose; try eapply dup_spec.
    eapply ifNZ_spec; try eapply nop_spec.
    eapply HT_weaken_conclusion; try eapply genLoop_spec
                                     with (I := fun m s =>
                                                  exists i ti s',
                                                    s = (Vint i, ti) ::: s' /\
                                                    I Q m s' i).
    { intros.
      assert (POS : i > 0) by lia.
      specialize (HTc i POS). clear POS.
      destruct HTc as (Pc & HTc & POST).
      eapply HT_strengthen_premise.
      { unfold push.
        eapply HT_compose; try eapply HTc.
        eapply HT_strengthen_premise.
        { eapply HT_compose; try eapply push_spec.
          eapply add_spec. }
        intros m s (? & s' & ? & INV). subst.
        do 6 eexists. split; eauto.
        split; [reflexivity|].
        replace (-1 + i) with (Z.pred i) by lia.
        do 3 eexists. split; eauto.
        split; eauto.
        lia. }
      intros m s (s' & t & ? & i' & ? & s'' & ? & ?). subst.
      assert (i' = i) by congruence.
      assert (s'' = s') by congruence. subst. eauto. }
    intros m s (s' & t & ? & i & ? & s'' & ? & ?).
    assert (i = 0) by congruence.
    assert (s'' = s') by congruence. subst. eauto. }

  intros m s (i & t & s' & ? & ? & ?). subst. simpl.
  eexists. split; eauto.
  do 3 eexists. split; eauto. split.
  - intros. eexists. split; [|do 2 eexists; split; eauto]. lia.
  - intros. subst. eauto.
Qed.

Lemma ret_specEscape: forall raddr (Q: memory -> stack -> Prop * Outcome),
  HTEscape raddr [Ret]
    (fun m s => exists s', s = (CRet raddr false false::s') /\
                           let (prop, outcome) := Q m s' in
                           prop /\ outcome = Success)
    Q.
Proof.
  intros. cases raddr; subst.
  unfold CodeTriples.HTEscape.
  intros imem stk0 mem0 fh n CODE (s' & ? & H). subst.
  eexists s', mem0. destruct (Q mem0 s') as [prop outcome].
  intuition. subst.
  repeat eexists.
  eauto.

  (* Load an instruction *)
  subst.
  unfold code_at in *. intuition.

  (* Run an instruction *)
  eapply rte_success; auto.
  eapply ruu_end; simpl; eauto.
  eapply cstep_ret_p; eauto.
  eapply cptr_done.
Qed.

Lemma jump_specEscape_Failure: forall raddr (Q: memory -> stack -> Prop * Outcome),
  HTEscape raddr [Jump]
           (fun m s => exists tag s0, (Vint (-1), tag) ::: s0 = s /\
                                      let (prop, outcome) := Q m s0 in
                                      prop /\ outcome = Failure)
           Q.
Proof.
  intros.
  unfold CodeTriples.HTEscape.
  intros imem stk0 mem0 fh n CODE (tag & s0 & ? & H). subst.
  eexists s0, mem0.
  destruct (Q mem0 s0) as [prop outcome]. destruct H; subst.
  simpl.
  repeat eexists.
  eauto.

  (* Load an instruction *)
  subst.
  unfold code_at in *. intuition.

  (* Run an instruction *)
  eapply rte_fail; auto.
  eapply rte_step; eauto.
  eapply cstep_jump_p; eauto.
  simpl; eauto; lia.
Qed.

Lemma skipNZ_specEscape: forall r c1 c2 v P1 P2 Q,
  (v =  0 -> HTEscape r c1 P1 Q) ->
  (v <> 0 -> HTEscape r c2 P2 Q) ->
  HTEscape r ((skipNZ (length c1) ++ c1) ++ c2)
           (fun m s => exists s0 l, s = (Vint v, l) ::: s0 /\
                                    (v =  0 -> P1 m s0) /\
                                    (v <> 0 -> P2 m s0))
           Q.
Proof.
  intros.
  unfold skipNZ.
  destruct (dec_eq v 0); subst.
  - eapply HTEscape_append.
    eapply HTEscape_compose.
    eapply skipNZ_spec_Z; auto.
    eapply HTEscape_strengthen_premise; iauto.
  - eapply HTEscape_compose.
    eapply skipNZ_continuation_spec_NZ; auto.
    eapply HTEscape_strengthen_premise; iauto.
Qed.

Lemma ifNZ_specEscape: forall r t f v Pt Pf Q,
  (v <> 0 -> HTEscape r t Pt Q) ->
  (v =  0 -> HTEscape r f Pf Q) ->
  HTEscape r (ifNZ t f)
           (fun m s => exists s0 t, s = (Vint v, t) ::: s0 /\
                                    (v <> 0 -> Pt m s0) /\
                                    (v =  0 -> Pf m s0))
           Q.
Proof.
  intros.
  unfold ifNZ.
  rewrite <- app_ass.
  eapply HTEscape_strengthen_premise.
  eapply skipNZ_specEscape with (v:=v).
  - intros.
    eapply HTEscape_append; eauto.
  - intros.
    eauto.
  - jauto.
Qed.

Lemma genSysRet_specEscape_Some: forall raddr (Q: memory -> stack -> Prop * Outcome),
  HTEscape raddr genSysRet
           (fun m s =>
              exists s0,
              s = (Vint 1, handlerTag) ::: CRet raddr false false :: s0 /\
              let (prop, outcome) := Q m s0 in
              prop /\ outcome = Success)
           Q.
Proof.
  intros.
  unfold genSysRet.
  eapply HTEscape_strengthen_premise.
  - eapply ifNZ_specEscape with (v:=1) (Pf:=fun m s => True); intros; try assumption.
    eapply ret_specEscape; try assumption.
    false.
  - subst.
    intuition. split_vc.
Qed.

Lemma genError_specEscape: forall raddr (P: memory -> stack -> Prop * Outcome),
  HTEscape raddr genError
           (fun m s => let (prop, outcome) := P m s in
                       prop /\ outcome = Failure)
           P.
Proof.
  intros.
  unfold genError.
  eapply HTEscape_strengthen_premise.
  { eapply HTEscape_compose; try eapply push_spec.
    eapply jump_specEscape_Failure. }
  simpl.
  intros m s H.
  repeat eexists; eauto.
Qed.

Lemma genSysRet_specEscape_None: forall raddr s0 m0,
 HTEscape raddr genSysRet
   (fun m s => (extends m0 m /\ s = (Vint 0, handlerTag) ::: s0))
   (fun m s => (extends m0 m /\ s = s0, Failure)).
Proof.
  intros.
  unfold genSysRet.
  eapply HTEscape_strengthen_premise.
  - eapply ifNZ_specEscape with (v := 0) (Pt := fun m s => True); intros; try assumption.
    + intuition.
    + eapply genError_specEscape.
  - intros.
    subst.
    intuition.
    jauto_set_goal; eauto.
Qed.

Lemma genSysVRet_spec :
  forall raddr (Q : memory -> stack -> Prop * Outcome),
    HTEscape raddr genSysVRet
             (fun m s =>  (exists t atom s0,
                             s = (Vint 1, t) ::: atom ::: CRet raddr true false :: s0 /\
                             let (prop, outcome) := Q m (atom ::: s0) in
                             prop /\ outcome = Success) \/
                          (exists t s0, s = (Vint 0, t) ::: s0 /\
                                        let (prop, outcome) := Q m s0 in
                                        prop /\ outcome = Failure))
             Q.
Proof.
  intros.
  unfold genSysVRet.
  destruct raddr as [pcret pcrett].
  intros code stk0 mem0 fh n code_at [H | H].
  - destruct H as (t & [resv resl] & s0 & STK & POST).
    simpl in *. destruct code_at as (H1 & H2 & H3 & H4 & H5 & H6 & _).
    eexists ((resv, resl) ::: s0), mem0. repeat eexists.
    destruct (Q mem0 ((resv, resl) ::: s0)) as [prop outcome]. destruct POST.
    simpl in *. subst. simpl. repeat (split; auto).
    eapply rte_success.
    eapply ruu_step; eauto.
    { eapply cstep_branchnz_p'; eauto. } simpl.
    replace (n + 5) with (n + 1 + 1 + 1 + 1 + 1) by ring.
    eapply ruu_end; eauto.
    eapply cstep_vret_p; eauto.
    eapply cptr_done.
  - destruct H as (t & s0 & STK & POST).
    simpl in *. destruct code_at as (H1 & H2 & H3 & H4 & H5 & H6 & _).
    eexists s0, mem0. repeat eexists.
    destruct (Q mem0 s0) as [prop outcome]. destruct POST.
    simpl in *. subst. simpl. repeat (split; auto).
    eapply rte_fail; simpl; try lia.
    eapply rte_step; try reflexivity.
    { eapply cstep_branchnz_p'; eauto. } simpl.
    eapply rte_step; try reflexivity.
    { clear H4. eapply cstep_push_p; eauto. }
    eapply rte_step; try reflexivity.
    { eapply cstep_jump_p; eauto. }
    eauto.
Qed.

End CodeSpecs.


(* ************************************************************************** *)
(*                                                                            *)
(* Verified Flash Translation Layer                                           *)
(*                                                                            *)
(*                                                                            *)
(*   Author: Yu Guo <guoyu@ustc.edu.cn>                                       *)
(*                          School of Computer Science and Technology, USTC   *)
(*                                                                            *)
(*           Bihong Zhang <sa614257@mail.ustc.edu.cn>                         *)
(*                                     School of Software Engineering, USTC   *)
(*                                                                            *)
(* ************************************************************************** *)

Definition PAGE_DATA_SIZE := 32.

Definition PAGE_OOB_SIZE := 8.

Definition ECC_IN_OOB_SIZE := 4.

Definition PAGE_SPARE_AREA_SIZE := 2.

Definition BLOCKS := 16.

Definition NUM_OF_BLOCKS := BLOCKS.

Definition PAGES_PER_BLOCK := 16.

Definition SECTOR_DATA_SIZE := PAGE_DATA_SIZE.

Definition MAX_PHYSICAL_BLOCKS := BLOCKS.

Definition MAX_LOGICAL_BLOCKS := 4.

Definition MIN_FREE_BLOCKS := 3.

Definition GC_THRESHOLD := 4.

Definition NUM_OF_SECTORS := MAX_LOGICAL_BLOCKS * PAGES_PER_BLOCK.

Definition CMT_LENGTH := 16.

Definition TRANS_RECORD_SIZE := 4.

Definition RECORD_PER_TRANS := 8.

Definition GTD_LENGTH := 32.


(*
 * © 2020 Massachusetts Institute of Technology.
 * MIT Proprietary, Subject to FAR52.227-11 Patent Rights - Ownership by the Contractor (May 2014)
 * SPDX-License-Identifier: MIT
 *
 *)
From Coq Require Import
     List.

From SPICY Require Import
     MyPrelude
     Maps
     ChMaps
     Messages
     Keys
     Automation
     Tactics
     Simulation
     SyntacticallySafe
     AdversaryUniverse

     ModelCheck.Commutation
     ModelCheck.ModelCheck
     ModelCheck.ProtocolFunctions
     ModelCheck.SilentStepElimination
     ModelCheck.SteppingTactics
     ModelCheck.InvariantSearch
     ModelCheck.UniverseInversionLemmas
.

From protocols Require Import
     SecureDNS.

From SPICY Require IdealWorld RealWorld.

Import IdealWorld.IdealNotations
       RealWorld.RealWorldNotations
       SimulationAutomation.

Set Implicit Arguments.

Open Scope protocol_scope.

Module SecureDNSProtocolSecure <: AutomatedSafeProtocolSS.

  Import SecureDNSProtocol.

  (* Some things may need to change here.  t__hon is where we place the
   * type that the protocol computes.  It is set to Nat now, because we
   * return a natual number.
   *)
  Definition t__hon := Nat.
  Definition t__adv := Unit.
  Definition b    := tt.

  (* These two variables hook up the starting points for both specification and
   * implementation universes.  If you followed the template above, this shouldn't
   * need to be changed.
   *)
  Definition iu0  := ideal_univ_start.
  Definition ru0  := real_univ_start.

  Import Gen Tacs.

  (* These are here to help the proof automation.  Don't change. *)
  #[export] Hint Unfold t__hon t__adv b ru0 iu0 ideal_univ_start real_univ_start : core.
  #[export] Hint Unfold
       mkiU mkiUsr mkrU mkrUsr
       mkKeys
    : core.

  Lemma realServerbrt_bodybrt :
    forall t n (cmd : RealWorld.user_cmd t),
      boundRunningTime cmd n
      -> forall (tv : RealWorld.denote t) n__iter,
        exists n__server, boundRunningTime (realServer n__iter tv cmd) n__server.
  Proof.
    induction n__iter; intros.
    - rewrite realserver_done.
      eexists; find_runtime.
    - erewrite unroll_realserver_step; eauto.
      split_ex.
      eexists; find_runtime.

      Unshelve.
      exact 0.
  Qed.

  Lemma finitelyRuns : exists n, runningTimeMeasure ru0 n.
  Proof.
    autounfold; simpl.
    repeat
      match goal with
      | [ |- context [realServer _ _ ?cmd] ] =>
        match goal with
        | [ H : exists _, boundRunningTime cmd _ |- _ ] => fail 1
        | _ => let BRT := fresh "BRT" in
              assert (exists n, boundRunningTime cmd n) as BRT by (eexists; simpl; find_runtime)
        end
      end
    ; split_ex
    ; repeat
        match goal with
        | [ H : boundRunningTime ?cmd _ |- context [ realServer ?n ?dv ?cmd ] ] =>
          pose proof (realServerbrt_bodybrt H dv n); clear H
        end
    ; split_ex.

    eexists; econstructor; simpl; find_runtime; eauto.

    Unshelve.
    all: exact 0.
  Qed.

  Lemma realServerss_bodyss :
    forall t uid uids ctx (cmd : RealWorld.user_cmd (RealWorld.Base t)) cs (usrs : RealWorld.honest_users t) sty,
      syntactically_safe uid uids ctx cmd sty
      -> typingcontext_sound ctx usrs cs uid
      -> forall tv n,
          exists sty__s ctx__s,
            List.Forall (fun styp => List.In styp ctx__s) ctx
            /\ syntactically_safe uid uids ctx__s (realServer n tv cmd) sty__s
            /\ typingcontext_sound ctx__s usrs cs uid.
  Proof.
    induct n; intros.
    - rewrite realserver_done.
      (do 2 eexists); eauto.
    - erewrite unroll_realserver_step; eauto.
      split_ex.
      (do 2 eexists); repeat simple apply conj; eauto.
      econstructor; intros; eauto using syntactically_safe_add_ctx.
  Qed.

  Lemma typechecks : syntactically_safe_U ru0.
  Proof.
    unfold syntactically_safe_U; intros.
    autounfold
    ; subst
    ; simpl in *.

    unfold compute_ids; simpl.

    focus_user; simpl
    ; try solve [ do 2 eexists; split
                  ; [ unshelve (repeat typechecks1)
                      ; match goal with
                        | [ |- bool ] => exact true
                        | [ |- list safe_typ ] => exact []
                        end
                    | repeat verify_context_soundness ] ].

    match goal with
    | [ |- exists _ _, syntactically_safe ?uid ?uids _ (realServer ?n ?tv ?cmd) _
               /\ typingcontext_sound _ ?usrs ?cs ?uid ] =>
      assert (exists sty ctx, syntactically_safe uid uids ctx cmd sty
                         /\ typingcontext_sound ctx usrs cs uid)
    end.

    do 2 eexists; split
    ; [ unshelve (repeat typechecks1)
        ; match goal with
          | [ |- bool ] => exact true
          | [ |- list safe_typ ] => exact []
          end
      | repeat verify_context_soundness ].

    split_ex.

    match goal with
    | [ SS : syntactically_safe _ _ _ ?cmd _, TCS : typingcontext_sound _ _ _ _
        |- context [ realServer ?n ?tv ?cmd ]
      ] =>
      pose proof ( realServerss_bodyss SS TCS tv n)
      ; clear SS TCS
      ; split_ex
    end
    ; (do 2 eexists); split; eauto.

    Unshelve.
    all: exact true.
  Qed.

  Lemma summarizable : exists summaries, summarize_univ ru0 summaries.
  Proof.
    autounfold; unfold summarize_univ; simpl; intros.
    unshelve (
        eexists; intros; focus_user; simpl
        ; (exists useless_summary; split; [ build_summary |]; eauto using useless_summary_summarizes)
      ) ; exact $0.
  Qed.

  Lemma lameness : @lameAdv t__adv b (RealWorld.adversary ru0).
  Proof.
    unfold lameAdv; autounfold; simpl; eauto.
  Qed.

  Set Ltac Profiling.

  Lemma safe_invariant :
    invariantFor
      {| Initial := {(ru0, iu0, true)}; Step := @stepSS t__hon t__adv  |}
      (@noresends_inv t__hon t__adv).
  Proof.
    unfold invariantFor
    ; unfold Initial, Step
    ; intros
    ; simpl in *
    ; split_ors
    ; try contradiction
    ; subst.

    autounfold in H0
    ; unfold fold_left, fst, snd in *.

    time (
        repeat transition_system_step
      ).

    Unshelve.
    all: exact 0 || auto.
  Qed.

  Show Ltac Profile.
  (* Show Ltac Profile "churn2". *)

  Lemma U_good : @universe_starts_sane _ Unit b ru0.
  Proof.
    autounfold;
      unfold universe_starts_sane; simpl.
    repeat (apply conj); intros; eauto.
    - focus_user; auto.
    - econstructor.
    - unfold AdversarySafety.keys_honest; rewrite Forall_natmap_forall; intros.
      unfold mkrUsr; simpl.
      rewrite !findUserKeys_add_reduce, findUserKeys_empty_is_empty; simpl in *; eauto.
    - unfold lameAdv; simpl; eauto.
  Qed.

  Lemma universe_starts_safe : universe_ok ru0.
  Proof.
    pose proof (adversary_is_lame_adv_univ_ok_clauses U_good).

    unfold universe_ok
    ; autounfold
    ; simpl
    ; intuition eauto
    .

    - econstructor; eauto.
    - unfold keys_and_permissions_good; solve_simple_maps; intuition eauto.
      solve_simple_maps; eauto.

      rewrite Forall_natmap_forall; intros.

      solve_simple_maps; simpl
      ; unfold permission_heap_good; intros;
        solve_simple_maps; solve_concrete_maps; eauto.

    - unfold user_cipher_queues_ok.
      rewrite Forall_natmap_forall; intros.
      focus_user
      ; simpl in *; econstructor; eauto.

    - unfold honest_nonces_ok, honest_user_nonces_ok, honest_nonces_ok
      ; repeat simple apply conj
      ; intros
      ; clean_map_lookups
      ; intros
      ; focus_user
      ; try contradiction; try discriminate; simpl;
        repeat (apply conj); intros; clean_map_lookups; eauto.

    - unfold honest_users_only_honest_keys; intros.
      focus_user;
        subst;
        simpl in *;
        clean_map_lookups;
        unfold mkrUsr; simpl;
          rewrite !findUserKeys_add_reduce, findUserKeys_empty_is_empty;
          eauto;
          simpl in *;
          solve_concrete_perm_merges;
          solve_concrete_maps;
          solve_simple_maps;
          eauto.
  Qed.

End SecureDNSProtocolSecure.


Require Import Semantics.
(* type_remove *)
Require Import Semantics_Conv.
Require Import OptionMap2.
Require Import FMapFacts.
Require Import AccessRights.
Require Import AccessRightSets.
Require Import References.
Require Import RefSets.
Require Import Capabilities.
Require Import Indices.
Require Import Objects.
Require Import SystemState.
Require Import SemanticsDefinitions.
Require Import Semantics.

Module MakeSemanticsConv (Ref:ReferenceType) (RefS: RefSetType Ref) (Cap:CapabilityType Ref) (Ind:IndexType) (Obj:ObjectType Ref Cap Ind) (Sys:SystemStateType Ref Cap Ind Obj) (SemDefns: SemanticsDefinitionsType Ref Cap Ind Obj Sys) (Sem: SemanticsType Ref RefS Cap Ind Obj Sys SemDefns) : SemanticsConv Ref RefS Cap Ind Obj Sys SemDefns Sem.

Require Import SystemState_ConvImpl.

  Module SC := SemDefns.SC.
  Module OC := SC.OC.
  Module CC := SC.CC.

  Module CIL_Facts := SC.CIL_Facts.
  (* type_remove *)
  Module Sys_MapEquiv := SC.Sys_MapEquiv.

  (* type_remove *)
  Definition SysEQ := SC.SysEQ.
  (* type_remove *)
  Definition CapEQ := CC.CapEQ.
  (* type_remove *)
  Definition ObjEQ := OC.ObjEQ.
  (* type_remove *)
  Definition RefEQ := CC.RefEQ.
  (* type_remove *)
  Definition IndEQ := OC.IndEQ.
  (* type_remove *)
  Definition PEQ := SC.PEQ.

  Hint Resolve SC.addCap_eq.
  Hint Resolve ARSet.eq_refl.
  Hint Resolve Cap.mkCap_eq.
  Hint Immediate Sys.eq_sym.

  Theorem do_store_eq : forall a a' t t' c c' i i' s s',
    Sys.eq s s' ->
    Ref.eq a a' ->
    Ind.eq t t' ->
    Ind.eq c c' ->
    Ind.eq i i' ->
    Sys.eq (Sem.do_store a t c i s) (Sem.do_store a' t' c' i' s').
  Proof.
    intros.
    case (SemDefns.store_preReq_dec a t s); simpl; intros.

    (* case where preReq occurs *)
    eapply Sys.eq_trans. eapply Sem.store_valid; auto.
    eapply SemDefns.store_preReq_eq_iff in s0;
      [
      |apply Ref.eq_sym in H0; apply H0
      |apply Ind.eq_sym in H1; apply H1
      |apply Sys.eq_sym in H; apply H].
    eapply Sys.eq_sym. eapply Sys.eq_trans. eapply Sem.store_valid; auto.

    apply option_map1_Equiv with
      (EqA := RefEQ)
      (EqB := SysEQ); try apply SemDefns.option_target_eq; try apply Ref.eq_sym; eauto.
    (* probably a new theorem here *)
    unfold option_map1_compat_op.
    intros.
    unfold SC.copyCap.
    eapply option_map1_Equiv with
      (EqA := CapEQ)
      (EqB := SysEQ); try apply SC.getCap_eq; try apply Ref.eq_sym; auto.
    (* probably a new theorem here *)
    unfold option_map1_compat_op.
    intros.
    unfold SC.addCap.
    eapply option_map1_Equiv with
      (EqA := ObjEQ)
      (EqB := SysEQ); try apply SC.getObj_eq; auto.
    (* probably a new theorem here *)
    unfold option_map1_compat_op.
    intros.
    unfold SC.updateObj.
    eapply option_map1_Equiv with
      (EqA := PEQ)
      (EqB := SysEQ); try apply SC.getObjTuple_eq; eauto.
    (* probably a new theroem here *)
    unfold option_map1_compat_op.
    intros.
    (* And here is the meat of the theorem *)
    unfold SC.addObjTuple.
    unfold SC.update_pair_object.
    repeat progress (destruct a3; destruct a'3).
    repeat progress (destruct p; destruct p0).
    simpl in *.
    repeat progress destruct H7.
    apply SC.addObjTuple_eq; auto.
    unfold Sys.P.eq.
    simpl.
    repeat progress (split; auto).
    apply OC.addCap_eq; auto.
    (* and the case where things are not equal *)
    eapply Sys.eq_trans. eapply Sem.store_invalid; auto.
    eapply Sys.eq_sym. eapply Sys.eq_trans;[ eapply Sem.store_invalid; auto|auto].
    intro n'. apply n.
    eapply SemDefns.store_preReq_eq_iff in n'; eauto.
  Qed.

  Theorem do_send_eq : forall a a' t t' cil cil' op_i op_i' s s',
    Sys.eq s s' ->
    Ref.eq a a' ->
    Ind.eq t t' ->
    CIL_Facts.cil_eq cil cil' ->
    option_map_eq Ind.eq op_i op_i' ->
    Sys.eq (Sem.do_send a t cil op_i s) (Sem.do_send a' t' cil' op_i' s').
  Proof.
    intros.
    case (SemDefns.send_preReq_dec a t s); simpl; intros.
    eapply Sys.eq_trans. eapply Sem.send_valid; auto.
    eapply SemDefns.send_preReq_eq_iff in s0;
      [
      |apply Ref.eq_sym in H0; apply H0
      |apply Ind.eq_sym in H1; apply H1
      |apply Sys.eq_sym in H; apply H].
    eapply Sys.eq_sym. eapply Sys.eq_trans. eapply Sem.send_valid; auto.

    Ltac apply_cil_sym := let cil_sym := fresh "cil_sym" in
        destruct CIL_Facts.cil_Equiv as [_ cil_sym _]; unfold Symmetric in cil_sym; apply cil_sym.

    Hint Extern 1 (CIL_Facts.cil_eq _ _) => apply_cil_sym.

    eapply option_map1_Equiv with
      (EqA := RefEQ)
      (EqB := SysEQ); try apply SemDefns.option_target_eq; try apply Ref.eq_sym; auto.
    (* probably a new theorem here *)
    unfold option_map1_compat_op.
    intros.
    apply SC.copyCapList_eq; try apply Ref.eq_sym; eauto.
    destruct op_i; destruct op_i'.
    simpl in *.
    unfold SC.addCap.
    eapply option_map1_Equiv with
      (EqA := ObjEQ)
      (EqB := SysEQ); try apply SC.getObj_eq; auto.
    unfold option_map1_compat_op; intros.
    unfold SC.updateObj.
    eapply option_map1_Equiv with
      (EqA := PEQ)
      (EqB := SysEQ); simpl in *;  try apply SC.getObjTuple_eq; auto.
    (*case 1*)
    unfold option_map1_compat_op; intros.
    apply SC.addObjTuple_eq; auto.
    repeat progress destruct a2; destruct a'2.
    repeat progress destruct p0.
    repeat progress destruct p.
    repeat progress destruct H6.
    unfold Sys.P.eq; simpl.
    simpl in *.
    repeat progress split; auto.
    apply OC.addCap_eq; auto.
    apply CC.mkCap_equiv; try apply Ref.eq_sym; auto.

    (* next 3 cases *)
    unfold option_map_eq in H3; simpl in H3; contradiction.
    unfold option_map_eq in H3; simpl in H3; contradiction.
    simpl; auto.

    (* and the case where things are not equal *)
    eapply Sys.eq_trans. eapply Sem.send_invalid; auto.
    eapply Sys.eq_sym. eapply Sys.eq_trans;[ eapply Sem.send_invalid; auto|auto].
    intro n'. apply n.
    eapply SemDefns.send_preReq_eq_iff in n'; eauto.
  Qed.

Theorem do_revoke_eq : forall a a' t t' c c' s s',
    Sys.eq s s' ->
    Ref.eq a a' ->
    Ind.eq t t' ->
    Ind.eq c c' ->
    Sys.eq (Sem.do_revoke a t c s) (Sem.do_revoke a' t' c' s').
  Proof.
    intros.
    case (SemDefns.revoke_preReq_dec a t s); simpl; intros.
    eapply Sys.eq_trans. eapply Sem.revoke_valid; auto.
    eapply SemDefns.revoke_preReq_eq_iff in r;
      [|apply Ref.eq_sym in H0; apply H0
       |apply Ind.eq_sym in H1; apply H1
       |apply Sys.eq_sym in H; apply H].
    eapply Sys.eq_sym. eapply Sys.eq_trans. eapply Sem.revoke_valid; auto.

    eapply option_map1_Equiv with
      (EqA := RefEQ)
      (EqB := SysEQ); try apply SemDefns.option_target_eq; try apply Ref.eq_sym; auto.
    (* probably a new theorem here *)
    unfold option_map1_compat_op.
    intros.
    unfold SC.rmCap.
    eapply option_map1_Equiv with
      (EqA := ObjEQ)
      (EqB := SysEQ); try apply SC.getObj_eq; auto.
    (* probably a new theorem here *)
    unfold option_map1_compat_op.
    intros.
    unfold SC.updateObj.
    eapply option_map1_Equiv with
      (EqA := PEQ)
      (EqB := SysEQ); simpl;  try apply SC.getObjTuple_eq; auto.
    (* probably a new theorem here *)
    unfold option_map1_compat_op.
    intros.
    (* And here is the meat of the theorem *)
    apply SC.addObjTuple_eq; auto.
    unfold SC.update_pair_object.
    repeat progress destruct a2; destruct a'2.
    repeat progress destruct p0.
    repeat progress destruct p.
    repeat progress destruct H5.
    unfold Sys.P.eq.
    simpl in *.
    repeat progress split; auto.
    apply OC.removeCap_eq; auto.
    (* and the case where things are not equal *)
    eapply Sys.eq_trans. eapply Sem.revoke_invalid; auto.
    eapply Sys.eq_sym. eapply Sys.eq_trans;[ eapply Sem.revoke_invalid; auto|auto].
    intro n'. apply n.
    eapply SemDefns.revoke_preReq_eq_iff in n'; eauto.
  Qed.

  Theorem do_destroy_eq : forall a a' t t' s s',
    Sys.eq s s' ->
    Ref.eq a a' ->
    Ind.eq t t' ->
    Sys.eq (Sem.do_destroy a t s) (Sem.do_destroy a' t' s').
  Proof.
    intros.
    case (SemDefns.destroy_preReq_dec a t s); simpl; intros.
    eapply Sys.eq_trans. eapply Sem.destroy_valid; auto.
    eapply SemDefns.destroy_preReq_eq_iff in d;
      [|apply Ref.eq_sym in H0; apply H0
       |apply Ind.eq_sym in H1; apply H1
       |apply Sys.eq_sym in H; apply H].
    eapply Sys.eq_sym. eapply Sys.eq_trans. eapply Sem.destroy_valid; auto.
    eapply option_map1_Equiv with
      (EqA := RefEQ)
      (EqB := SysEQ); try apply SemDefns.option_target_eq; try apply Ref.eq_sym; auto.
    unfold option_map1_compat_op.
    intros.
    (* probably a new theorem here *)
    unfold SC.set_dead.
    unfold SC.set_label.
    eapply option_map1_Equiv with
      (EqA:=PEQ)
      (EqB:=SysEQ); try apply SC.getObjTuple_eq; auto.
    (* the meat of the theorem *)
    unfold option_map1_compat_op.
    intros.
    apply SC.addObjTuple_eq; auto.
    unfold SC.update_pair_label.
    repeat progress destruct a1; destruct a'1.
    repeat progress destruct p0.
    repeat progress destruct p.
    repeat progress destruct H3.
    (* TODO: really want a remove and relabel eq *)
    unfold Sys.P.eq.
    simpl in *.
    repeat progress split; auto.
    (* and the case where things are not equal *)
    eapply Sys.eq_trans. eapply Sem.destroy_invalid; auto.
    eapply Sys.eq_sym. eapply Sys.eq_trans;[ eapply Sem.destroy_invalid; auto|auto].
    intro n'. apply n.
    eapply SemDefns.destroy_preReq_eq_iff in n'; eauto.
  Qed.

  Theorem do_read_eq : forall a a' t t' s s',
    Sys.eq s s' ->
    Ref.eq a a' ->
    Ind.eq t t' ->
    Sys.eq (Sem.do_read a t s) (Sem.do_read a' t' s').
  Proof.
    intros.
    eapply Sys.eq_trans. eapply Sem.read_spec; auto.
    eapply Sys.eq_sym. eapply Sys.eq_trans. eapply Sem.read_spec; auto.
    eapply Sys.eq_sym; auto.
  Qed.

  Theorem do_write_eq : forall a a' t t' s s',
    Sys.eq s s' ->
    Ref.eq a a' ->
    Ind.eq t t' ->
    Sys.eq (Sem.do_write a t s) (Sem.do_write a' t' s').
  Proof.
    intros.
    eapply Sys.eq_trans. eapply Sem.write_spec; auto.
    eapply Sys.eq_sym. eapply Sys.eq_trans. eapply Sem.write_spec; auto.
    eapply Sys.eq_sym; auto.
  Qed.

Theorem do_fetch_eq : forall a a' t t' c c' i i' s s',
    Sys.eq s s' ->
    Ref.eq a a' ->
    Ind.eq t t' ->
    Ind.eq c c' ->
    Ind.eq i i' ->
    Sys.eq (Sem.do_fetch a t c i s) (Sem.do_fetch a' t' c' i' s').
  Proof.
    intros.
    case (SemDefns.fetch_preReq_dec a t s); simpl; intros.
    (* case where preReq occurs *)
    generalize f; intros [Hf Hf'].
    case (SemDefns.option_hasRight_dec (SC.getCap t a s) rd); intros Hread.
    (* read case *)
    eapply Sys.eq_trans. eapply Sem.fetch_read; auto.
    eapply SemDefns.fetch_preReq_eq_iff in f;
      [|apply Ref.eq_sym in H0; apply H0
       |apply Ind.eq_sym in H1; apply H1
       |apply Sys.eq_sym in H; apply H].
    eapply Sys.eq_sym. eapply Sys.eq_trans. eapply Sem.fetch_read; auto.
    eapply SemDefns.option_hasRight_eq;
     [eapply Ind.eq_sym; eauto | apply Ref.eq_sym; eauto | apply Sys.eq_sym; eauto | apply AccessRight.eq_refl | eauto].

    eapply option_map1_Equiv with
      (EqA := RefEQ)
      (EqB := SysEQ); try apply SemDefns.option_target_eq; try apply Ref.eq_sym; auto.
    (* probably a new theorem here *)
    unfold option_map1_compat_op.
    intros.
    unfold SC.copyCap.
    eapply option_map1_Equiv with
      (EqA := CapEQ)
      (EqB := SysEQ); try apply SC.getCap_eq; auto.
    (* probably a new theorem here *)
    unfold option_map1_compat_op.
    intros.
    unfold SC.addCap.
    eapply option_map1_Equiv with
      (EqA := ObjEQ)
      (EqB := SysEQ); try apply SC.getObj_eq; try apply Ref.eq_sym; auto.
    (* probably a new theorem here *)
    unfold option_map1_compat_op.
    intros.
    unfold SC.updateObj.
    eapply option_map1_Equiv with
      (EqA := PEQ)
      (EqB := SysEQ); try apply SC.getObjTuple_eq; try apply Ref.eq_sym; auto.
    (* probably a new theroem here *)
    unfold option_map1_compat_op.
    intros.
    (* And here is the meat of the theorem *)
    unfold SC.addObjTuple.
    unfold SC.update_pair_object.
    repeat progress destruct a3; destruct a'3.
    repeat progress destruct p0.
    repeat progress destruct p.
    repeat progress destruct H7.
    apply SC.addObjTuple_eq; try apply Ref.eq_sym; auto.
    simpl in *.
    unfold Sys.P.eq.
    simpl.
    repeat progress split; auto.
    apply OC.addCap_eq; auto.
    (* now the weak case *)
    destruct Hf' as [Hf'|Hf']; try contradiction.

    eapply Sys.eq_trans. eapply Sem.fetch_weak; auto.
    eapply SemDefns.fetch_preReq_eq_iff in f;
      [|apply Ref.eq_sym in H0; apply H0
       |apply Ind.eq_sym in H1; apply H1
       |apply Sys.eq_sym in H; apply H].
    eapply Sys.eq_sym. eapply Sys.eq_trans. eapply Sem.fetch_weak; auto.
    intro n; apply Hread.
    eapply SemDefns.option_hasRight_eq; try apply AccessRight.eq_refl; eauto.
    eapply SemDefns.option_hasRight_eq;
      [eapply Ind.eq_sym; eauto | apply Ref.eq_sym; eauto | apply Sys.eq_sym; eauto | apply AccessRight.eq_refl | auto].

    eapply option_map1_Equiv with
      (EqA := RefEQ)
      (EqB := SysEQ); try apply SemDefns.option_target_eq; try apply Ref.eq_sym; auto.
    (* probably a new theorem here *)
    unfold option_map1_compat_op.
    intros.
    unfold SC.copyCap.
    eapply option_map1_Equiv with
      (EqA := CapEQ)
      (EqB := SysEQ); try apply SC.getCap_eq; try apply Ref.eq_sym; auto.
    (* probably a new theorem here *)
    unfold option_map1_compat_op.
    intros.
    unfold SC.addCap.
    eapply option_map1_Equiv with
      (EqA := ObjEQ)
      (EqB := SysEQ); try apply SC.getObj_eq; try apply Ref.eq_sym; auto.
    (* probably a new theorem here *)
    unfold option_map1_compat_op.
    intros.
    unfold SC.updateObj.
    eapply option_map1_Equiv with
      (EqA := PEQ)
      (EqB := SysEQ); try apply SC.getObjTuple_eq; try apply Ref.eq_sym; auto.
    (* probably a new theroem here *)
    unfold option_map1_compat_op.
    intros.
    (* And here is the meat of the theorem *)
    unfold SC.addObjTuple.
    unfold SC.update_pair_object.
    repeat progress destruct a3; destruct a'3.
    repeat progress destruct p0.
    repeat progress destruct p.
    repeat progress destruct H7.
    apply SC.addObjTuple_eq; try apply Ref.eq_sym; auto.
    unfold Sys.P.eq.
    simpl in *.
    repeat progress split; auto.
    apply OC.addCap_eq; auto.
    (* need a weaken_eq theorem *)
    apply CC.weaken_equiv; auto.
    (* and the case where things are not equal *)
    eapply Sys.eq_trans. eapply Sem.fetch_invalid; auto.
    eapply Sys.eq_sym. eapply Sys.eq_trans;[ eapply Sem.fetch_invalid; auto|auto].
    intro n'. apply n.
    eapply SemDefns.fetch_preReq_eq_iff in n'; eauto.
  Qed.

  Theorem do_allocate_eq : forall a a' n n' i i' cil cil' s s',
    Sys.eq s s' ->
    Ref.eq a a' ->
    Ref.eq n n' ->
    Ind.eq i i' ->
    CIL_Facts.cil_eq cil cil' ->
    Sys.eq (Sem.do_allocate a n i cil s) (Sem.do_allocate a' n' i' cil' s').
  Proof.
    intros.
    case (SemDefns.allocate_preReq_dec a n s); simpl; intros.

    (* case where preReq occurrs *)
    eapply Sys.eq_trans. eapply Sem.allocate_valid; auto.
    eapply SemDefns.allocate_preReq_eq_iff in a0;
      [|apply Ref.eq_sym in H0; apply H0
       |apply Ref.eq_sym in H1; apply H1
       |apply Sys.eq_sym in H; apply H].
    eapply Sys.eq_sym.  eapply Sys.eq_trans.  eapply Sem.allocate_valid; auto.
    unfold SC.set_alive.
    unfold SC.set_label.

    Hint Resolve SC.addCap_eq.
    Hint Resolve ARSet.eq_refl.
    Hint Resolve Cap.mkCap_eq.

    apply SC.addCap_eq; try apply Ref.eq_sym; auto.  eapply Cap.mkCap_eq; split.
    eapply Ref.eq_trans.
      eapply Ref.eq_trans.
        eapply Ref.eq_sym; apply H1.
        apply Ref.eq_sym; eapply CC.mkCap_target.
      auto.
    eapply ARSet.eq_trans.
      eapply ARSet.eq_sym. eapply CC.mkCap_rights.
      auto.
    apply SC.copyCapList_eq; try apply Ref.eq_sym; auto. (* generalize CIL_Facts.cil_Equiv; intros [_ sym _].  apply sym. auto. *)

    (* apply SC.copyCapList_eq; auto.
       apply SC.addCap_eq; auto;  [eapply Cap.mkCap_eq; split; [rewrite CC.mkCap_target]| rewrite mkCap_rights]; eauto|]. *)

    apply option_map1_Equiv with
      (EqA:=PEQ)
      (EqB:=SysEQ); try solve [apply SC.updateObj_eq; try apply Obj.eq_refl; eauto].

    (* option_map1_compat_op case *)
    unfold option_map1_compat_op; intros.
    apply SC.addObjTuple_eq; try apply SC.copyCapList_eq; try apply Ref.eq_sym; eauto.
    unfold SC.update_pair_label.
    repeat progress destruct a1; destruct a'0.
    repeat progress destruct H4.
    repeat progress destruct p0.
    repeat progress destruct p.
    unfold Sys.P.eq.
    simpl in *.
    repeat progress split; auto.
    Hint Immediate Sys.eq_sym.
    apply SC.updateObj_eq; try apply Obj.eq_refl; try apply SC.rmCapsByTarget_eq; try apply Ref.eq_sym; eauto.
    apply SC.updateObj_eq; try apply Obj.eq_refl; try apply SC.rmCapsByTarget_eq; try apply Ref.eq_sym; eauto.

(*    apply SC.updateObj_eq; try apply Obj.eq_refl; try apply SC.rmCapsByTarget_eq; eauto. *)
    (* option_map_eq case *)
    eapply Sys_MapEquiv.find_eq; eauto.
    eapply SC.updateObj_eq; try apply Obj.eq_refl; try apply SC.rmCapsByTarget_eq; try apply Ref.eq_sym; eauto.

    (* and the case where things are not equal *)
    eapply Sys.eq_trans. eapply Sem.allocate_invalid; auto.
    assert (~ SemDefns.allocate_preReq a' n' s'). intro. eapply n0.

    eapply SemDefns.allocate_preReq_eq_iff in H4; eauto.
    eapply Sys.eq_sym.  eapply Sys.eq_trans.  eapply Sem.allocate_invalid; auto. apply Sys.eq_sym; auto.
  Qed.

  Theorem do_op_eq : forall op s s',
    Sys.eq s s' -> Sys.eq (Sem.do_op op s) (Sem.do_op op s').
  Proof.
    intros.
    destruct op; auto;
     first [apply do_read_eq | apply do_write_eq | apply do_fetch_eq | apply do_store_eq | apply do_revoke_eq | apply do_send_eq | apply do_allocate_eq | apply do_destroy_eq]; auto; try apply Ref.eq_refl;
    try (destruct CIL_Facts.cil_Equiv as [refl _ _]; apply refl);
      try (destruct (option_map_eq_Equiv Ind.eq IndEQ) as [refl _ _]; apply refl).
  Qed.

  Import RefS.

  Theorem Proper_read_from_def: Proper (Sys.eq ==> eq ==> RefSet.eq ==> impl) Sem.read_from_def.
  Proof.
    unfold Proper; unfold respectful; unfold impl.
    intros s s' Hs op op' Hop r r' Hr Hrf.

    Require Import OptionSumbool.

    (* Heq = H0 , HpreReq = H Hempty = H0 *)
    (* The first two cases solve the branches of odd constructors, the last two for even *)
    Ltac solve_occurrance op_preReq_eq_iff Hr Heq a t s s' Hs HpreReq Hempty:= solve
      [ eapply op_preReq_eq_iff; eauto; try apply Ref.eq_refl
        | eapply RefSet.eq_trans; [| apply Hr];
          eapply RefSet.eq_trans; [| apply Heq];
            try apply RefSet.eq_refl;
              unfold Sem.add_option_target;
                let Hcap := fresh "Hcap" in
                  let Hcase := fresh "Hcase" in
                    let Hcase' := fresh "Hcase'" in
                      generalize (SC.getCap_eq _ _ _ _ _ _ Hs (Ind.eq_refl t) (Ref.eq_refl a)); intros Hcap;
                        case (option_sumbool (SC.getCap t a s));intros Hcase;
                          [|destruct Hcase as [cap Hcase]];rewrite Hcase in *;
                            (case (option_sumbool (SC.getCap t a s'));intros Hcase';
                              [|destruct Hcase' as [cap' Hcase']];rewrite Hcase' in *);
                            simpl in *; try solve
                              [apply RefSet.eq_refl
                                | contradiction
                                | apply Cap.target_eq in Hcap; rewrite Hcap; apply RefSet.eq_refl]
        | intros Hnot; apply HpreReq; eapply op_preReq_eq_iff; eauto; try apply Ref.eq_refl
        | eapply RefSetFacts.Empty_m; [apply RefSet.eq_sym; apply Hr| apply Hempty]
      ].
    destruct Hrf; rewrite <- Hop in *;
      [ constructor 1; solve_occurrance SemDefns.read_preReq_eq_iff Hr H0 a t s s' Hs H H0
        | constructor 2; solve_occurrance SemDefns.read_preReq_eq_iff Hr H0 a t s s' Hs H H0
        | constructor 3; solve_occurrance SemDefns.write_preReq_eq_iff Hr H0 a t s s' Hs H H0
        | constructor 4; solve_occurrance SemDefns.write_preReq_eq_iff Hr H0 a t s s' Hs H H0
        | constructor 5; solve_occurrance SemDefns.fetch_preReq_eq_iff Hr H0 a t s s' Hs H H0
        | constructor 6; solve_occurrance SemDefns.fetch_preReq_eq_iff Hr H0 a t s s' Hs H H0
        | constructor 7; solve_occurrance SemDefns.store_preReq_eq_iff Hr H0 a t s s' Hs H H0
        | constructor 8; solve_occurrance SemDefns.store_preReq_eq_iff Hr H0 a t s s' Hs H H0
        | constructor 9; solve_occurrance SemDefns.revoke_preReq_eq_iff Hr H0 a t s s' Hs H H0
        | constructor 10; solve_occurrance SemDefns.revoke_preReq_eq_iff Hr H0 a t s s' Hs H H0
        | constructor 11; solve_occurrance SemDefns.send_preReq_eq_iff Hr H0 a t s s' Hs H H0
        | constructor 12; solve_occurrance SemDefns.send_preReq_eq_iff Hr H0 a t s s' Hs H H0
        | constructor 13; solve_occurrance SemDefns.allocate_preReq_eq_iff Hr H0 a t s s' Hs H H0
        | constructor 14; solve_occurrance SemDefns.allocate_preReq_eq_iff Hr H0 a t s s' Hs H H0
        | constructor 15; solve_occurrance SemDefns.destroy_preReq_eq_iff Hr H0 a t s s' Hs H H0
        | constructor 16; solve_occurrance SemDefns.destroy_preReq_eq_iff Hr H0 a t s s' Hs H H0
      ].
  Qed.

  Theorem Proper_wrote_to_def: Proper (Sys.eq ==> eq ==> RefSet.eq ==> impl) Sem.wrote_to_def.
  Proof.
    unfold Proper; unfold respectful; unfold impl.
    intros s s' Hs op op' Hop w w' Hw Hwt.
    destruct Hwt; rewrite <- Hop in *;
      [ constructor 1; solve_occurrance SemDefns.read_preReq_eq_iff Hw H0 a t s s' Hs H H0
        | constructor 2; solve_occurrance SemDefns.read_preReq_eq_iff Hw H0 a t s s' Hs H H0
        | constructor 3; solve_occurrance SemDefns.write_preReq_eq_iff Hw H0 a t s s' Hs H H0
        | constructor 4; solve_occurrance SemDefns.write_preReq_eq_iff Hw H0 a t s s' Hs H H0
        | constructor 5; solve_occurrance SemDefns.fetch_preReq_eq_iff Hw H0 a t s s' Hs H H0
        | constructor 6; solve_occurrance SemDefns.fetch_preReq_eq_iff Hw H0 a t s s' Hs H H0
        | constructor 7; solve_occurrance SemDefns.store_preReq_eq_iff Hw H0 a t s s' Hs H H0
        | constructor 8; solve_occurrance SemDefns.store_preReq_eq_iff Hw H0 a t s s' Hs H H0
        | constructor 9; solve_occurrance SemDefns.revoke_preReq_eq_iff Hw H0 a t s s' Hs H H0
        | constructor 10; solve_occurrance SemDefns.revoke_preReq_eq_iff Hw H0 a t s s' Hs H H0
        | constructor 11; solve_occurrance SemDefns.send_preReq_eq_iff Hw H0 a t s s' Hs H H0
        | constructor 12; solve_occurrance SemDefns.send_preReq_eq_iff Hw H0 a t s s' Hs H H0
        | constructor 13; solve_occurrance SemDefns.allocate_preReq_eq_iff Hw H0 a t s s' Hs H H0
        | constructor 14; solve_occurrance SemDefns.allocate_preReq_eq_iff Hw H0 a t s s' Hs H H0
        | constructor 15; solve_occurrance SemDefns.destroy_preReq_eq_iff Hw H0 a t s s' Hs H H0
        | constructor 16; solve_occurrance SemDefns.destroy_preReq_eq_iff Hw H0 a t s s' Hs H H0
      ].
  Qed.

End MakeSemanticsConv.


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2011-2018 Sylvie Boldo
#<br />#
Copyright (C) 2011-2018 Guillaume Melquiond

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

This library 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
COPYING file for more details.
*)

From Coq Require Import ZArith Lia Zquot.

Require Import SpecFloatCompat.

Notation cond_Zopp := cond_Zopp (only parsing).
Notation iter_pos := iter_pos (only parsing).

Section Zmissing.

(** About Z *)
Theorem Zopp_le_cancel :
  forall x y : Z,
  (-y <= -x)%Z -> Z.le x y.
Proof.
intros x y Hxy.
apply Zplus_le_reg_r with (-x - y)%Z.
now ring_simplify.
Qed.

Theorem Zgt_not_eq :
  forall x y : Z,
  (y < x)%Z -> (x <> y)%Z.
Proof.
intros x y H Hn.
apply Z.lt_irrefl with x.
now rewrite Hn at 1.
Qed.

End Zmissing.

Section Proof_Irrelevance.

Scheme eq_dep_elim := Induction for eq Sort Type.

Definition eqbool_dep P (h1 : P true) b :=
  match b return P b -> Prop with
  | true => fun (h2 : P true) => h1 = h2
  | false => fun (h2 : P false) => False
  end.

Lemma eqbool_irrelevance : forall (b : bool) (h1 h2 : b = true), h1 = h2.
Proof.
assert (forall (h : true = true), refl_equal true = h).
apply (eq_dep_elim bool true (eqbool_dep _ _) (refl_equal _)).
intros b.
case b.
intros h1 h2.
now rewrite <- (H h1).
intros h.
discriminate h.
Qed.

End Proof_Irrelevance.

Section Even_Odd.

Theorem Zeven_ex :
  forall x, exists p, x = (2 * p + if Z.even x then 0 else 1)%Z.
Proof.
intros [|[n|n|]|[n|n|]].
now exists Z0.
now exists (Zpos n).
now exists (Zpos n).
now exists Z0.
exists (Zneg n - 1)%Z.
change (2 * Zneg n - 1 = 2 * (Zneg n - 1) + 1)%Z.
ring.
now exists (Zneg n).
now exists (-1)%Z.
Qed.

End Even_Odd.

Section Zpower.

Theorem Zpower_plus :
  forall n k1 k2, (0 <= k1)%Z -> (0 <= k2)%Z ->
  Zpower n (k1 + k2) = (Zpower n k1 * Zpower n k2)%Z.
Proof.
intros n k1 k2 H1 H2.
now apply Zpower_exp ; apply Z.le_ge.
Qed.

Theorem Zpower_Zpower_nat :
  forall b e, (0 <= e)%Z ->
  Zpower b e = Zpower_nat b (Z.abs_nat e).
Proof.
intros b [|e|e] He.
apply refl_equal.
apply Zpower_pos_nat.
elim He.
apply refl_equal.
Qed.

Theorem Zpower_nat_S :
  forall b e,
  Zpower_nat b (S e) = (b * Zpower_nat b e)%Z.
Proof.
intros b e.
rewrite (Zpower_nat_is_exp 1 e).
apply (f_equal (fun x => x * _)%Z).
apply Zmult_1_r.
Qed.

Theorem Zpower_pos_gt_0 :
  forall b p, (0 < b)%Z ->
  (0 < Zpower_pos b p)%Z.
Proof.
intros b p Hb.
rewrite Zpower_pos_nat.
induction (nat_of_P p).
easy.
rewrite Zpower_nat_S.
now apply Zmult_lt_0_compat.
Qed.

Theorem Zeven_Zpower_odd :
  forall b e, (0 <= e)%Z -> Z.even b = false ->
  Z.even (Zpower b e) = false.
Proof.
intros b e He Hb.
destruct (Z_le_lt_eq_dec _ _ He) as [He'|He'].
rewrite <- Hb.
now apply Z.even_pow.
now rewrite <- He'.
Qed.

(** The radix must be greater than 1 *)
Record radix := { radix_val :> Z ; radix_prop : Zle_bool 2 radix_val = true }.

Theorem radix_val_inj :
  forall r1 r2, radix_val r1 = radix_val r2 -> r1 = r2.
Proof.
intros (r1, H1) (r2, H2) H.
simpl in H.
revert H1.
rewrite H.
intros H1.
apply f_equal.
apply eqbool_irrelevance.
Qed.

Definition radix2 := Build_radix 2 (refl_equal _).

Variable r : radix.

Theorem radix_gt_0 : (0 < r)%Z.
Proof.
apply Z.lt_le_trans with 2%Z.
easy.
apply Zle_bool_imp_le.
apply r.
Qed.

Theorem radix_gt_1 : (1 < r)%Z.
Proof.
destruct r as (v, Hr). simpl.
apply Z.lt_le_trans with 2%Z.
easy.
now apply Zle_bool_imp_le.
Qed.

Theorem Zpower_gt_1 :
  forall p,
  (0 < p)%Z ->
  (1 < Zpower r p)%Z.
Proof.
intros [|p|p] Hp ; try easy.
simpl.
rewrite Zpower_pos_nat.
generalize (lt_O_nat_of_P p).
induction (nat_of_P p).
easy.
intros _.
rewrite Zpower_nat_S.
assert (0 < Zpower_nat r n)%Z.
clear.
induction n.
easy.
rewrite Zpower_nat_S.
apply Zmult_lt_0_compat with (2 := IHn).
apply radix_gt_0.
apply Z.le_lt_trans with (1 * Zpower_nat r n)%Z.
rewrite Zmult_1_l.
now apply (Zlt_le_succ 0).
apply Zmult_lt_compat_r with (1 := H).
apply radix_gt_1.
Qed.

Theorem Zpower_gt_0 :
  forall p,
  (0 <= p)%Z ->
  (0 < Zpower r p)%Z.
Proof.
intros p Hp.
rewrite Zpower_Zpower_nat with (1 := Hp).
induction (Z.abs_nat p).
easy.
rewrite Zpower_nat_S.
apply Zmult_lt_0_compat with (2 := IHn).
apply radix_gt_0.
Qed.

Theorem Zpower_ge_0 :
  forall e,
  (0 <= Zpower r e)%Z.
Proof.
intros [|e|e] ; try easy.
apply Zlt_le_weak.
now apply Zpower_gt_0.
Qed.

Theorem Zpower_le :
  forall e1 e2, (e1 <= e2)%Z ->
  (Zpower r e1 <= Zpower r e2)%Z.
Proof.
intros e1 e2 He.
destruct (Zle_or_lt 0 e1)%Z as [H1|H1].
replace e2 with (e2 - e1 + e1)%Z by ring.
rewrite Zpower_plus with (2 := H1).
rewrite <- (Zmult_1_l (r ^ e1)) at 1.
apply Zmult_le_compat_r.
apply (Zlt_le_succ 0).
apply Zpower_gt_0.
now apply Zle_minus_le_0.
apply Zpower_ge_0.
now apply Zle_minus_le_0.
clear He.
destruct e1 as [|e1|e1] ; try easy.
apply Zpower_ge_0.
Qed.

Theorem Zpower_lt :
  forall e1 e2, (0 <= e2)%Z -> (e1 < e2)%Z ->
  (Zpower r e1 < Zpower r e2)%Z.
Proof.
intros e1 e2 He2 He.
destruct (Zle_or_lt 0 e1)%Z as [H1|H1].
replace e2 with (e2 - e1 + e1)%Z by ring.
rewrite Zpower_plus with (2 := H1).
rewrite Zmult_comm.
rewrite <- (Zmult_1_r (r ^ e1)) at 1.
apply Zmult_lt_compat2.
split.
now apply Zpower_gt_0.
apply Z.le_refl.
split.
easy.
apply Zpower_gt_1.
clear -He ; omega.
apply Zle_minus_le_0.
now apply Zlt_le_weak.
revert H1.
clear -He2.
destruct e1 ; try easy.
intros _.
now apply Zpower_gt_0.
Qed.

Theorem Zpower_lt_Zpower :
  forall e1 e2,
  (Zpower r (e1 - 1) < Zpower r e2)%Z ->
  (e1 <= e2)%Z.
Proof.
intros e1 e2 He.
apply Znot_gt_le.
intros H.
apply Zlt_not_le with (1 := He).
apply Zpower_le.
clear -H ; omega.
Qed.

Theorem Zpower_gt_id :
  forall n, (n < Zpower r n)%Z.
Proof.
intros [|n|n] ; try easy.
simpl.
rewrite Zpower_pos_nat.
rewrite Zpos_eq_Z_of_nat_o_nat_of_P.
induction (nat_of_P n).
easy.
rewrite inj_S.
change (Zpower_nat r (S n0)) with (r * Zpower_nat r n0)%Z.
unfold Z.succ.
apply Z.lt_le_trans with (r * (Z_of_nat n0 + 1))%Z.
clear.
apply Zlt_0_minus_lt.
replace (r * (Z_of_nat n0 + 1) - (Z_of_nat n0 + 1))%Z with ((r - 1) * (Z_of_nat n0 + 1))%Z by ring.
apply Zmult_lt_0_compat.
cut (2 <= r)%Z. omega.
apply Zle_bool_imp_le.
apply r.
apply (Zle_lt_succ 0).
apply Zle_0_nat.
apply Zmult_le_compat_l.
now apply Zlt_le_succ.
apply Z.le_trans with 2%Z.
easy.
apply Zle_bool_imp_le.
apply r.
Qed.

End Zpower.

Section Div_Mod.

Theorem Zmod_mod_mult :
  forall n a b, (0 < a)%Z -> (0 <= b)%Z ->
  Zmod (Zmod n (a * b)) b = Zmod n b.
Proof.
intros n a [|b|b] Ha Hb.
now rewrite 2!Zmod_0_r.
rewrite (Zmod_eq n (a * Zpos b)).
rewrite Zmult_assoc.
unfold Zminus.
rewrite Zopp_mult_distr_l.
apply Z_mod_plus.
easy.
apply Zmult_gt_0_compat.
now apply Z.lt_gt.
easy.
now elim Hb.
Qed.

Theorem ZOmod_eq :
  forall a b,
  Z.rem a b = (a - Z.quot a b * b)%Z.
Proof.
intros a b.
rewrite (Z.quot_rem' a b) at 2.
ring.
Qed.

Theorem ZOmod_mod_mult :
  forall n a b,
  Z.rem (Z.rem n (a * b)) b = Z.rem n b.
Proof.
intros n a b.
assert (Z.rem n (a * b) = n + - (Z.quot n (a * b) * a) * b)%Z.
rewrite <- Zopp_mult_distr_l.
rewrite <- Zmult_assoc.
apply ZOmod_eq.
rewrite H.
apply Z_rem_plus.
rewrite <- H.
apply Zrem_sgn2.
Qed.

Theorem Zdiv_mod_mult :
  forall n a b, (0 <= a)%Z -> (0 <= b)%Z ->
  (Z.div (Zmod n (a * b)) a) = Zmod (Z.div n a) b.
Proof.
intros n a b Ha Hb.
destruct (Zle_lt_or_eq _ _ Ha) as [Ha'|Ha'].
destruct (Zle_lt_or_eq _ _ Hb) as [Hb'|Hb'].
rewrite (Zmod_eq n (a * b)).
rewrite (Zmult_comm a b) at 2.
rewrite Zmult_assoc.
unfold Zminus.
rewrite Zopp_mult_distr_l.
rewrite Z_div_plus by now apply Z.lt_gt.
rewrite <- Zdiv_Zdiv by easy.
apply sym_eq.
apply Zmod_eq.
now apply Z.lt_gt.
now apply Zmult_gt_0_compat ; apply Z.lt_gt.
rewrite <- Hb'.
rewrite Zmult_0_r, 2!Zmod_0_r.
apply Zdiv_0_l.
rewrite <- Ha'.
now rewrite 2!Zdiv_0_r, Zmod_0_l.
Qed.

Theorem ZOdiv_mod_mult :
  forall n a b,
  (Z.quot (Z.rem n (a * b)) a) = Z.rem (Z.quot n a) b.
Proof.
intros n a b.
destruct (Z.eq_dec a 0) as [Za|Za].
rewrite Za.
now rewrite 2!Zquot_0_r, Zrem_0_l.
assert (Z.rem n (a * b) = n + - (Z.quot (Z.quot n a) b * b) * a)%Z.
rewrite (ZOmod_eq n (a * b)) at 1.
rewrite Zquot_Zquot.
ring.
rewrite H.
rewrite Z_quot_plus with (2 := Za).
apply sym_eq.
apply ZOmod_eq.
rewrite <- H.
apply Zrem_sgn2.
Qed.

Theorem ZOdiv_small_abs :
  forall a b,
  (Z.abs a < b)%Z -> Z.quot a b = Z0.
Proof.
intros a b Ha.
destruct (Zle_or_lt 0 a) as [H|H].
apply Z.quot_small.
split.
exact H.
now rewrite Z.abs_eq in Ha.
apply Z.opp_inj.
rewrite <- Zquot_opp_l, Z.opp_0.
apply Z.quot_small.
generalize (Zabs_non_eq a).
omega.
Qed.

Theorem ZOmod_small_abs :
  forall a b,
  (Z.abs a < b)%Z -> Z.rem a b = a.
Proof.
intros a b Ha.
destruct (Zle_or_lt 0 a) as [H|H].
apply Z.rem_small.
split.
exact H.
now rewrite Z.abs_eq in Ha.
apply Z.opp_inj.
rewrite <- Zrem_opp_l.
apply Z.rem_small.
generalize (Zabs_non_eq a).
omega.
Qed.

Theorem ZOdiv_plus :
  forall a b c, (0 <= a * b)%Z ->
  (Z.quot (a + b) c = Z.quot a c + Z.quot b c + Z.quot (Z.rem a c + Z.rem b c) c)%Z.
Proof.
intros a b c Hab.
destruct (Z.eq_dec c 0) as [Zc|Zc].
now rewrite Zc, 4!Zquot_0_r.
apply Zmult_reg_r with (1 := Zc).
rewrite 2!Zmult_plus_distr_l.
assert (forall d, Z.quot d c * c = d - Z.rem d c)%Z.
intros d.
rewrite ZOmod_eq.
ring.
rewrite 4!H.
rewrite <- Zplus_rem with (1 := Hab).
ring.
Qed.

End Div_Mod.

Section Same_sign.

Theorem Zsame_sign_trans :
  forall v u w, v <> Z0 ->
  (0 <= u * v)%Z -> (0 <= v * w)%Z -> (0 <= u * w)%Z.
Proof.
intros [|v|v] [|u|u] [|w|w] Zv Huv Hvw ; try easy ; now elim Zv.
Qed.

Theorem Zsame_sign_trans_weak :
  forall v u w, (v = Z0 -> w = Z0) ->
  (0 <= u * v)%Z -> (0 <= v * w)%Z -> (0 <= u * w)%Z.
Proof.
intros [|v|v] [|u|u] [|w|w] Zv Huv Hvw ; try easy ; now discriminate Zv.
Qed.

Theorem Zsame_sign_imp :
  forall u v,
  (0 < u -> 0 <= v)%Z ->
  (0 < -u -> 0 <= -v)%Z ->
  (0 <= u * v)%Z.
Proof.
intros [|u|u] v Hp Hn.
easy.
apply Zmult_le_0_compat.
easy.
now apply Hp.
replace (Zneg u * v)%Z with (Zpos u * (-v))%Z.
apply Zmult_le_0_compat.
easy.
now apply Hn.
rewrite <- Zopp_mult_distr_r.
apply Zopp_mult_distr_l.
Qed.

Theorem Zsame_sign_odiv :
  forall u v, (0 <= v)%Z ->
  (0 <= u * Z.quot u v)%Z.
Proof.
intros u v Hv.
apply Zsame_sign_imp ; intros Hu.
apply Z_quot_pos with (2 := Hv).
now apply Zlt_le_weak.
rewrite <- Zquot_opp_l.
apply Z_quot_pos with (2 := Hv).
now apply Zlt_le_weak.
Qed.

End Same_sign.

(** Boolean comparisons *)

Section Zeq_bool.

Inductive Zeq_bool_prop (x y : Z) : bool -> Prop :=
  | Zeq_bool_true_ : x = y -> Zeq_bool_prop x y true
  | Zeq_bool_false_ : x <> y -> Zeq_bool_prop x y false.

Theorem Zeq_bool_spec :
  forall x y, Zeq_bool_prop x y (Zeq_bool x y).
Proof.
intros x y.
generalize (Zeq_is_eq_bool x y).
case (Zeq_bool x y) ; intros (H1, H2) ; constructor.
now apply H2.
intros H.
specialize (H1 H).
discriminate H1.
Qed.

Theorem Zeq_bool_true :
  forall x y, x = y -> Zeq_bool x y = true.
Proof.
intros x y.
apply -> Zeq_is_eq_bool.
Qed.

Theorem Zeq_bool_false :
  forall x y, x <> y -> Zeq_bool x y = false.
Proof.
intros x y.
generalize (proj2 (Zeq_is_eq_bool x y)).
case Zeq_bool.
intros He Hn.
elim Hn.
now apply He.
now intros _ _.
Qed.

End Zeq_bool.

Section Zle_bool.

Inductive Zle_bool_prop (x y : Z) : bool -> Prop :=
  | Zle_bool_true_ : (x <= y)%Z -> Zle_bool_prop x y true
  | Zle_bool_false_ : (y < x)%Z -> Zle_bool_prop x y false.

Theorem Zle_bool_spec :
  forall x y, Zle_bool_prop x y (Zle_bool x y).
Proof.
intros x y.
generalize (Zle_is_le_bool x y).
case Zle_bool ; intros (H1, H2) ; constructor.
now apply H2.
destruct (Zle_or_lt x y) as [H|H].
now specialize (H1 H).
exact H.
Qed.

Theorem Zle_bool_true :
  forall x y : Z,
  (x <= y)%Z -> Zle_bool x y = true.
Proof.
intros x y.
apply (proj1 (Zle_is_le_bool x y)).
Qed.

Theorem Zle_bool_false :
  forall x y : Z,
  (y < x)%Z -> Zle_bool x y = false.
Proof.
intros x y Hxy.
generalize (Zle_cases x y).
case Zle_bool ; intros H.
elim (Z.lt_irrefl x).
now apply Z.le_lt_trans with y.
apply refl_equal.
Qed.

End Zle_bool.

Section Zlt_bool.

Inductive Zlt_bool_prop (x y : Z) : bool -> Prop :=
  | Zlt_bool_true_ : (x < y)%Z -> Zlt_bool_prop x y true
  | Zlt_bool_false_ : (y <= x)%Z -> Zlt_bool_prop x y false.

Theorem Zlt_bool_spec :
  forall x y, Zlt_bool_prop x y (Zlt_bool x y).
Proof.
intros x y.
generalize (Zlt_is_lt_bool x y).
case Zlt_bool ; intros (H1, H2) ; constructor.
now apply H2.
destruct (Zle_or_lt y x) as [H|H].
exact H.
now specialize (H1 H).
Qed.

Theorem Zlt_bool_true :
  forall x y : Z,
  (x < y)%Z -> Zlt_bool x y = true.
Proof.
intros x y.
apply (proj1 (Zlt_is_lt_bool x y)).
Qed.

Theorem Zlt_bool_false :
  forall x y : Z,
  (y <= x)%Z -> Zlt_bool x y = false.
Proof.
intros x y Hxy.
generalize (Zlt_cases x y).
case Zlt_bool ; intros H.
elim (Z.lt_irrefl x).
now apply Z.lt_le_trans with y.
apply refl_equal.
Qed.

Theorem negb_Zle_bool :
  forall x y : Z,
  negb (Zle_bool x y) = Zlt_bool y x.
Proof.
intros x y.
case Zle_bool_spec ; intros H.
now rewrite Zlt_bool_false.
now rewrite Zlt_bool_true.
Qed.

Theorem negb_Zlt_bool :
  forall x y : Z,
  negb (Zlt_bool x y) = Zle_bool y x.
Proof.
intros x y.
case Zlt_bool_spec ; intros H.
now rewrite Zle_bool_false.
now rewrite Zle_bool_true.
Qed.

End Zlt_bool.

Section Zcompare.

Inductive Zcompare_prop (x y : Z) : comparison -> Prop :=
  | Zcompare_Lt_ : (x < y)%Z -> Zcompare_prop x y Lt
  | Zcompare_Eq_ : x = y -> Zcompare_prop x y Eq
  | Zcompare_Gt_ : (y < x)%Z -> Zcompare_prop x y Gt.

Theorem Zcompare_spec :
  forall x y, Zcompare_prop x y (Z.compare x y).
Proof.
intros x y.
destruct (Z_dec x y) as [[H|H]|H].
generalize (Zlt_compare _ _ H).
case (Z.compare x y) ; try easy.
now constructor.
generalize (Zgt_compare _ _ H).
case (Z.compare x y) ; try easy.
constructor.
now apply Z.gt_lt.
generalize (proj2 (Zcompare_Eq_iff_eq _ _) H).
case (Z.compare x y) ; try easy.
now constructor.
Qed.

Theorem Zcompare_Lt :
  forall x y,
  (x < y)%Z -> Z.compare x y = Lt.
Proof.
easy.
Qed.

Theorem Zcompare_Eq :
  forall x y,
  (x = y)%Z -> Z.compare x y = Eq.
Proof.
intros x y.
apply <- Zcompare_Eq_iff_eq.
Qed.

Theorem Zcompare_Gt :
  forall x y,
  (y < x)%Z -> Z.compare x y = Gt.
Proof.
intros x y.
apply Z.lt_gt.
Qed.

End Zcompare.

Section cond_Zopp.

Theorem cond_Zopp_negb :
  forall x y, cond_Zopp (negb x) y = Z.opp (cond_Zopp x y).
Proof.
intros [|] y.
apply sym_eq, Z.opp_involutive.
easy.
Qed.

Theorem abs_cond_Zopp :
  forall b m,
  Z.abs (cond_Zopp b m) = Z.abs m.
Proof.
intros [|] m.
apply Zabs_Zopp.
apply refl_equal.
Qed.

Theorem cond_Zopp_Zlt_bool :
  forall m,
  cond_Zopp (Zlt_bool m 0) m = Z.abs m.
Proof.
intros m.
apply sym_eq.
case Zlt_bool_spec ; intros Hm.
apply Zabs_non_eq.
now apply Zlt_le_weak.
now apply Z.abs_eq.
Qed.

End cond_Zopp.

Section fast_pow_pos.

Fixpoint Zfast_pow_pos (v : Z) (e : positive) : Z :=
  match e with
  | xH => v
  | xO e' => Z.square (Zfast_pow_pos v e')
  | xI e' => Zmult v (Z.square (Zfast_pow_pos v e'))
  end.

Theorem Zfast_pow_pos_correct :
  forall v e, Zfast_pow_pos v e = Zpower_pos v e.
Proof.
intros v e.
rewrite <- (Zmult_1_r (Zfast_pow_pos v e)).
unfold Z.pow_pos.
generalize 1%Z.
revert v.
induction e ; intros v f ; simpl.
- rewrite <- 2!IHe.
  rewrite Z.square_spec.
  ring.
- rewrite <- 2!IHe.
  rewrite Z.square_spec.
  apply eq_sym, Zmult_assoc.
- apply eq_refl.
Qed.

End fast_pow_pos.

Section faster_div.

Lemma Zdiv_eucl_unique :
  forall a b,
  Z.div_eucl a b = (Z.div a b, Zmod a b).
Proof.
intros a b.
unfold Z.div, Zmod.
now case Z.div_eucl.
Qed.

Fixpoint Zpos_div_eucl_aux1 (a b : positive) {struct b} :=
  match b with
  | xO b' =>
    match a with
    | xO a' => let (q, r) := Zpos_div_eucl_aux1 a' b' in (q, 2 * r)%Z
    | xI a' => let (q, r) := Zpos_div_eucl_aux1 a' b' in (q, 2 * r + 1)%Z
    | xH => (Z0, Zpos a)
    end
  | xH => (Zpos a, Z0)
  | xI _ => Z.pos_div_eucl a (Zpos b)
  end.

Lemma Zpos_div_eucl_aux1_correct :
  forall a b,
  Zpos_div_eucl_aux1 a b = Z.pos_div_eucl a (Zpos b).
Proof.
intros a b.
revert a.
induction b ; intros a.
- easy.
- change (Z.pos_div_eucl a (Zpos b~0)) with (Z.div_eucl (Zpos a) (Zpos b~0)).
  rewrite Zdiv_eucl_unique.
  change (Zpos b~0) with (2 * Zpos b)%Z.
  rewrite Z.rem_mul_r by easy.
  rewrite <- Zdiv_Zdiv by easy.
  destruct a as [a|a|].
  + change (Zpos_div_eucl_aux1 a~1 b~0) with (let (q, r) := Zpos_div_eucl_aux1 a b in (q, 2 * r + 1)%Z).
    rewrite IHb. clear IHb.
    change (Z.pos_div_eucl a (Zpos b)) with (Z.div_eucl (Zpos a) (Zpos b)).
    rewrite Zdiv_eucl_unique.
    change (Zpos a~1) with (1 + 2 * Zpos a)%Z.
    rewrite (Zmult_comm 2 (Zpos a)).
    rewrite Z_div_plus_full by easy.
    apply f_equal.
    rewrite Z_mod_plus_full.
    apply Zplus_comm.
  + change (Zpos_div_eucl_aux1 a~0 b~0) with (let (q, r) := Zpos_div_eucl_aux1 a b in (q, 2 * r)%Z).
    rewrite IHb. clear IHb.
    change (Z.pos_div_eucl a (Zpos b)) with (Z.div_eucl (Zpos a) (Zpos b)).
    rewrite Zdiv_eucl_unique.
    change (Zpos a~0) with (2 * Zpos a)%Z.
    rewrite (Zmult_comm 2 (Zpos a)).
    rewrite Z_div_mult_full by easy.
    apply f_equal.
    now rewrite Z_mod_mult.
  + easy.
- change (Z.pos_div_eucl a 1) with (Z.div_eucl (Zpos a) 1).
  rewrite Zdiv_eucl_unique.
  now rewrite Zdiv_1_r, Zmod_1_r.
Qed.

Definition Zpos_div_eucl_aux (a b : positive) :=
  match Pos.compare a b with
  | Lt => (Z0, Zpos a)
  | Eq => (1%Z, Z0)
  | Gt => Zpos_div_eucl_aux1 a b
  end.

Lemma Zpos_div_eucl_aux_correct :
  forall a b,
  Zpos_div_eucl_aux a b = Z.pos_div_eucl a (Zpos b).
Proof.
intros a b.
unfold Zpos_div_eucl_aux.
change (Z.pos_div_eucl a (Zpos b)) with (Z.div_eucl (Zpos a) (Zpos b)).
rewrite Zdiv_eucl_unique.
case Pos.compare_spec ; intros H.
now rewrite H, Z_div_same, Z_mod_same.
now rewrite Zdiv_small, Zmod_small by (split ; easy).
rewrite Zpos_div_eucl_aux1_correct.
change (Z.pos_div_eucl a (Zpos b)) with (Z.div_eucl (Zpos a) (Zpos b)).
apply Zdiv_eucl_unique.
Qed.

Definition Zfast_div_eucl (a b : Z) :=
  match a with
  | Z0 => (0, 0)%Z
  | Zpos a' =>
    match b with
    | Z0 => (0, 0)%Z
    | Zpos b' => Zpos_div_eucl_aux a' b'
    | Zneg b' =>
      let (q, r) := Zpos_div_eucl_aux a' b' in
      match r with
      | Z0 => (-q, 0)%Z
      | Zpos _ => (-(q + 1), (b + r))%Z
      | Zneg _ => (-(q + 1), (b + r))%Z
      end
    end
  | Zneg a' =>
    match b with
    | Z0 => (0, 0)%Z
    | Zpos b' =>
      let (q, r) := Zpos_div_eucl_aux a' b' in
      match r with
      | Z0 => (-q, 0)%Z
      | Zpos _ => (-(q + 1), (b - r))%Z
      | Zneg _ => (-(q + 1), (b - r))%Z
      end
    | Zneg b' => let (q, r) := Zpos_div_eucl_aux a' b' in (q, (-r)%Z)
    end
  end.

Theorem Zfast_div_eucl_correct :
  forall a b : Z,
  Zfast_div_eucl a b = Z.div_eucl a b.
Proof.
unfold Zfast_div_eucl.
intros [|a|a] [|b|b] ; try rewrite Zpos_div_eucl_aux_correct ; easy.
Qed.

End faster_div.

Section Iter.

Context {A : Type}.
Variable (f : A -> A).

Fixpoint iter_nat (n : nat) (x : A) {struct n} : A :=
  match n with
  | S n' => iter_nat n' (f x)
  | O => x
  end.

Lemma iter_nat_plus :
  forall (p q : nat) (x : A),
  iter_nat (p + q) x = iter_nat p (iter_nat q x).
Proof.
induction q.
now rewrite plus_0_r.
intros x.
rewrite <- plus_n_Sm.
apply IHq.
Qed.

Lemma iter_nat_S :
  forall (p : nat) (x : A),
  iter_nat (S p) x = f (iter_nat p x).
Proof.
induction p.
easy.
simpl.
intros x.
apply IHp.
Qed.

Lemma iter_pos_nat :
  forall (p : positive) (x : A),
  iter_pos f p x = iter_nat (Pos.to_nat p) x.
Proof.
induction p ; intros x.
rewrite Pos2Nat.inj_xI.
simpl.
rewrite plus_0_r.
rewrite iter_nat_plus.
rewrite (IHp (f x)).
apply IHp.
rewrite Pos2Nat.inj_xO.
simpl.
rewrite plus_0_r.
rewrite iter_nat_plus.
rewrite (IHp x).
apply IHp.
easy.
Qed.

End Iter.