(* vendored from https://github.com/tchajed/iris-named-props *)
From iris.proofmode Require Import string_ident.
From iris.proofmode Require Import tactics environments intro_patterns (*monpred*).

Set Default Proof Using "Type".

(* NamedProps implements [name ∷ P], which is equivalent to P but knows to
   name itself [name] when destructed. The syntax is intended to be analogous
   to in Gallina where you might write [forall (Hfoo: 3 < 4), ...] for a
   hypothesis that would be introduced as [Hfoo] using automatic names.

  To use this library, write your definitions with [name ∷ P] for each conjunct.
  Then, use [iNamed "H"] to destruct an invariant "H" into its conjuncts, using
  their specified names. [iNamed] also introduces existentials with the names
  for the Coq binders.

  The names in a named proposition are not actually names but full-blown Iris intro
  patterns. This means you can write [#H] to automatically introduce to the
  persistent context, [%H] to name a pure fact (using string_to_ident), or even
  something crazy like ["[<- H]"] to destruct the hypothesis and rewrite by the
  first conjunct.

  There are a several top-level tactics provided to work with named
  propositions:
  - [iNamed "H"] names a single hypothesis. This is the most common usage.
  - [iNamed 1] on a wand introduces and destructs the premise.
  - [iNamed] names any anonymous hypotheses (without destructing them).
  - [iNamedAccu] is like [iAccu] - it solves a goal which is an evar with the
    conjunction of all the hypotheses - but produces a conjunction of named
    hypotheses. This is especially useful when that evar ?Q shows up as a
    premise in a wand, [?Q -∗ ...], at which point you can do [iNamed 1] to
    restore the context, including all the names.
  - [iFrameNamed] is a work-in-progress tactic to frame a goal with named
    conjuncts with the hypotheses using the names. This is intended to be much
    faster than framing the entire persistent and spatial contexts.

  Note that this library provides general support for propositions and is not
  specific to definitions. You can use named hypotheses in Hoare logic
  preconditions (to make the first iIntros more stable), in the postcondition
  (to make it easier for the caller to re-introduce hypotheses), or in loop
  invariants (to serve both of these purposes). If they ever get in the way you
  can always [rewrite /named] to get rid of the names.
 *)

(* Named props are defined to be the underlying prop. We used to have this
sealed, but it turns out that this inconveniently required many forwarding
typeclass instances (for things like [IntoPure], [Persistent], and framing) and
we didn't run into any issues making it completely transparent.

For efficiency reasons, we don't have [(PROP:bi) (P:PROP)], since this requires
a coercion to the carrier of [PROP]. *)
Definition named {A} (name: string) (P: A): A := P.

Section named.
  Context `{SI: indexT}.
  Context {PROP:bi}.

  Theorem to_named name (P: PROP) : P -∗ named name P.
  Proof. auto. Qed.
  Theorem from_named name (P: PROP) : named name P -∗ P.
  Proof. auto. Qed.

  (* Implementation of [iNamedAccu]; the soundness proof basically shows these
  definitions are equivalent to the ones used in the [iAccu] implementation,
  since we can simply unfold [named]. *)

  Fixpoint env_to_named_prop_go (acc : PROP) (Γ : env PROP) : PROP :=
    match Γ with
    | Enil => acc
    | Esnoc Γ (INamed name) P => env_to_named_prop_go (named name P ∗ acc)%I Γ
    | Esnoc Γ _ P => env_to_named_prop_go (named "?" P ∗ acc)%I Γ
    end.
  Definition env_to_named_prop (Γ : env PROP) : PROP :=
    match Γ with
    | Enil => emp%I
    | Esnoc Γ (INamed name) P => env_to_named_prop_go (named name P) Γ
    | Esnoc Γ _ P => env_to_named_prop_go (named "?" P) Γ
    end.

  Theorem env_to_named_prop_go_unname (acc: PROP) Γ :
    env_to_named_prop_go acc Γ = env_to_prop_go acc Γ.
  Proof.
    revert acc.
    induction Γ; simpl; auto; intros.
    rewrite IHΓ.
    destruct i; simpl; auto.
  Qed.

  Theorem env_to_named_prop_unname (Γ: env PROP) :
    env_to_named_prop Γ = env_to_prop Γ.
  Proof.
    destruct Γ; auto.
    destruct i; simpl; rewrite env_to_named_prop_go_unname //.
  Qed.

  Theorem env_to_named_prop_sound (Γ: env PROP) :
    env_to_named_prop Γ ≡ ([∗] Γ)%I.
  Proof.
    rewrite env_to_named_prop_unname env_to_prop_sound //.
  Qed.

  Lemma tac_named_accu Δ (P: PROP) :
    env_to_named_prop (env_spatial Δ) = P →
    envs_entails Δ P.
  Proof.
    rewrite env_to_named_prop_unname.
    apply coq_tactics.tac_accu.
  Qed.

  Lemma tac_delay_split (R P Q: PROP) :
    (P ∗ R) -∗ (R -∗ Q) -∗ P ∗ Q.
  Proof.
    iIntros "[$ R] Hwand".
    iApply ("Hwand" with "R").
  Qed.

End named.

Ltac to_pm_ident H :=
  lazymatch type of H with
  | string => constr:(INamed H)
  | ident => constr:(H)
  end.

Local Ltac iDeex_as i x :=
  let x' := fresh x in
  iDestructHyp i as (x') i.

Ltac iDeex :=
  repeat match goal with
         | |- context[Esnoc _ ?i (bi_exist (fun x => _))] =>
           iDeex_as i x
         end.

(** [IsExistential] identifies propositions that should be destructed as
existentials by [iDeex]. *)
Class IsExistential `{SI: indexT} {PROP:bi} (P: PROP) := is_existential {}.
Global Arguments is_existential {SI PROP P} : assert.
Global Instance is_existential_exist `{SI: indexT} {PROP:bi} {A} (Φ: A → PROP) :
  IsExistential (bi_exist Φ).
Proof. Qed.

(** [IsSplittable] identifies separating conjunction-like propositions that
should be split by [iNamed] as it traverses a proposition for named conjuncts.
*)
Class IsSplittable `{SI: indexT} {PROP:bi} (P: PROP) := is_splittable {}.
Global Arguments IsSplittable {_ _} _%I : assert.
Global Arguments is_splittable {SI PROP P} : assert.
Global Instance is_splittable_sep `{SI: indexT} {PROP:bi} (P Q: PROP) :
  IsSplittable (P ∗ Q).
Proof. Qed.

(*
Lemma make_monPred_at_named {I : biIndex} {PROP : bi} name (i : I) (P : monPred I PROP) (𝓟 : PROP) :
  MakeMonPredAt i P 𝓟 →
  MakeMonPredAt i (named name P) (named name 𝓟).
Proof. done. Qed.

(* This is not an instance since Coq would try and apply the instance at every
step in the type class resolution since [named name P] unfolds to just [P].
Instead we register a hint that only applies when the goal contains [named]. *)
Global Hint Extern 0 (MakeMonPredAt _ (named _ _) _) => apply make_monPred_at_named : typeclass_instances.
*)

(** tc_is_inhabited succeeds if P is an inhabited typeclass and fails otherwise.
*)
Ltac tc_is_inhabited P :=
  first [ let _ := constr:(ltac:(tc_solve) : P) in idtac
        | fail 1 "could not satisfy" P ].

Ltac iDeex_one H :=
  lazymatch iTypeOf H with
  | Some (_, ?P) => lazymatch P with
                    | named _ _ => idtac
                    | _ => tc_is_inhabited (IsExistential P);
                           iDestruct H as (?) H
                    end
  | None => fail 1 "iDeexHyp:" H "not found"
  end.

(* iDeexHyp is like [iDestruct "H" as (?) "H"] except that it preserves the name
of the binder and repeats while the goal is an existential *)
Ltac iDeexHyp H :=
  iDeex_one H; repeat iDeex_one H.

Lemma tac_name_replace `{SI: indexT} {PROP:bi} (i: ident) Δ p (P: PROP) Q name :
  envs_lookup i Δ = Some (p, named name P) →
  match envs_simple_replace i p (Esnoc Enil (INamed name) P) Δ with
  | Some Δ' => envs_entails Δ' Q
  | None => False
  end →
  envs_entails Δ Q.
Proof. rewrite /named. apply coq_tactics.tac_rename. Qed.

Local Ltac iNameReplace i name :=
  eapply (tac_name_replace i _ _ _ _ name);
  [ first [ reduction.pm_reflexivity
          | fail 1 "iNamed: could not find" i ]
  | reduction.pm_reduce;
    lazymatch goal with
    | |- False => fail 1 "iNamed: name in not fresh" i
    | _ => idtac
    end
  ].

Lemma tac_name_intuitionistic `{SI: indexT} {PROP:bi} Δ i i' p (P P' Q: PROP) name :
  envs_lookup i Δ = Some (p, named name P) →
  IntoPersistent p P P' →
  (if p then TCTrue else TCOr (Affine P) (Absorbing Q)) →
  match envs_replace i p true (Esnoc Enil i' P') Δ with
  | Some Δ' => envs_entails Δ' Q
  | None => False
  end →
  envs_entails Δ Q.
Proof.
  rewrite /named.
  rewrite ?envs_entails_eq ?envs_entails_unseal => ? HP' HPQ HQ.
  destruct (envs_replace _ _ _ _ _) as [Δ'|] eqn:Hrep; last done.
  rewrite envs_replace_singleton_sound //.
  rewrite HQ.

  destruct p; simpl.
  - iIntros "[#HP HQ]".
    iApply "HQ".
    iApply "HP".
  - iIntros "[#HP HQ]".
    iApply "HQ"; iFrame "#".
Qed.

Local Ltac iNameIntuitionistic i i' :=
  eapply (tac_name_intuitionistic _ i i' _ _ _ _ _);
  [ reduction.pm_reflexivity
  | tc_solve
  | simpl; tc_solve
  | reduction.pm_reduce
  ].

Local Ltac iNamePure i name :=
  let id := string_to_ident name in
  let id := fresh id in
  iPure i as id.

(* iNameHyp implements naming a hypothesis of the form [H: name ∷ P].

   The complete tactic is mutually recursive with iNamed_go for * patterns; this
   self-contained version takes iNamed_go as a parameter *)
Local Ltac iNameHyp_go_rx H iNamed_go :=
  let i := to_pm_ident H in
  lazymatch goal with
  | |- context[Esnoc _ i (named ?name ?P)] =>
    (* we check for some simple special-cases: *)
    let pat := intro_pat.parse_one name in
    lazymatch pat with
    | IIdent (INamed ?name) =>
      (* just rename one hypothesis *)
      iNameReplace i name
    | IIntuitionistic (IIdent ?i') =>
      iNameIntuitionistic i i'
    (* pure intros need to be freshened (otherwise they block using iNamed) *)
    | IPure (IGallinaNamed ?name) =>
      iNamePure i name
    (* the token "*" causes iNamed to recurse *)
    | IForall => change (Esnoc ?Δ i (named name P)) with (Esnoc Δ i P); iNamed_go i
    | _ =>
       (* we now do this only for backwards compatibility, which is a completely
       safe but inefficient sequence that handles persistent/non-persistent
       things correctly (most likely few patterns not covered above should even
       be supported) *)
       let Htmp := iFresh in
       iRename i into Htmp;
       iDestruct (from_named with Htmp) as pat;
       try iClear Htmp
    end
  | |- context[Esnoc _ i _] =>
    fail "iNameHyp: hypothesis" H "is not a named"
  | _ => fail 1 "iNameHyp: hypothesis" H "not found"
  end.

(* The core of iNamed is destructing a spine of separating conjuncts and naming
  each conjunct with iNameHyp; the implementation currently just calls iDestruct
  and then attempts to name the new anonymous hypotheses, but it would be better
  to parametrize the splitting and naming into a typeclass. *)
Ltac iNamedDestruct_go_rx H iNameHyp :=
  (* we track the original name H0 here so that at the very end we can name the
  last conjunct if it isn't named (this is what PropRestore runs into - it can
  be destructed until a final Restore hypothesis) *)
  let rec go H0 H :=
      first [ iNameHyp H
            | lazymatch iTypeOf H with
              | Some (_, ?P) => tc_is_inhabited (IsSplittable P)
              | None => fail 1 "iNamed: hypothesis" H "not found"
              end;
              let Htmp1 := iFresh in
              let Htmp2 := iFresh in
              let pat := constr:(IList [[IIdent Htmp1; IIdent Htmp2]]) in
              iDestruct H as pat;
              iNameHyp Htmp1; go H0 Htmp2
            | (* reaching here means the last conjunct could not be named with
              iNameHyp; rather than leave it anonymous, restore the original
              name (note this could fail if that name was used by one of the
              inner names, which we don't handle here) *)
              iRename H into H0 ] in
  go H H.

(* this declaration defines iNamed by tying together all the mutual recursion *)
Local Ltac iNamed_go H :=
  lazymatch H with
  | 1%Z => let i := iFresh in iIntros i; iNamed_go i
  | 1%nat => let i := iFresh in iIntros i; iNamed_go i
  | _ =>
    (* first destruct the existentials, then split the conjuncts (but
    importantly only these two levels; the user must explicitly opt-in to
    destructing more existentials for conjuncts) *)
    try iDeexHyp H;
    iNamedDestruct_go H
  end with
  (* Ltac *) iNameHyp_go H :=
  iNameHyp_go_rx H iNamed_go with
  (* Ltac *) iNamedDestruct_go H := iNamedDestruct_go_rx H iNameHyp_go.

Tactic Notation "iNamedDestruct" constr(H) := iNamedDestruct_go H.
Tactic Notation "iNamed" constr(H) := iNamed_go H.

(* iNamed names any hypotheses that are anonymous but have a name. This is
primarily useful when you for some reason need to introduce using ? and then
separately name (this can arise if [iNamed] isn't doing the right thing, or
wouldn't work for all the conjuncts) *)
Tactic Notation "iNamed" :=
  repeat match goal with
         | |- context[Esnoc _ ?i (named ?name ?P)] =>
           iNameHyp_go i
         (* TODO: debug this for destructing anonymous composites *)
         (* | |- context[Esnoc _ ?i ?P] =>
           lazymatch P with
           | context[named _ _] => progress iNamed i
           end *)
         end.

(* iNameHyp only introduces names for a single hypothesis (and is usually not
useful on its own) *)
Ltac iNameHyp H := iNameHyp_go H.

Tactic Notation "iNamedAccu" :=
  iStartProof; eapply tac_named_accu; [ (* only one goal should spawn *)
    first [
        cbv [ env_to_named_prop env_to_named_prop_go ];
        reduction.pm_reflexivity
      | fail 1 "iNamedAccu: not an evar"
      ]
  ].

Ltac iFrameNamed :=
  lazymatch goal with
  | [ |- envs_entails _ ?g ] =>
    repeat match g with
           | context[named ?p ?P] =>
             let pat := intro_patterns.intro_pat.parse_one p in
             lazymatch pat with
             | IIdent ?name => iFrame name
             | IIntuitionistic (IIdent ?name) => iFrame name
             | IPure (IGallinaNamed ?name) =>
               let name := string_to_ident name in
               iFrame (name)
             end
           end
  end.

(* this is crucially placed just below level 80, which is where ∗ is, so that
you can change [P ∗ Q] to ["HP" ∷ P ∗ "HQ" ∷ Q] without adding parentheses to
attach the names correctly *)
Notation "name ∷ P" := (named name P%I) (at level 79).

(* Enable eauto to solve goals where the top-level is [named] *)
Global Hint Extern 0 (environments.envs_entails _ (named _ _)) => unfold named : core.

Ltac iSplitDelay :=
  let PROP := iBiOfGoal in
  let R := fresh "remainder" in
  evar (R:PROP.(bi_car));
  iApply (tac_delay_split R with "[-] []");
  subst R.


Require Import list_examples.

Definition heap_fun' (R : Spec kcfg) (deps : list Defn) (d:Defn) (y : Exp) :
  forall (args : list KResult) (init_heap : MapPattern k k)
    (ret : Z -> MapPattern k k), Prop :=
  match d with FunDef name formals body =>
    fun args init_heap ret =>
      forall krest store stack heap funs mark otherfuns,
      funs ~= fundefs deps (name s|-> KDefn d) :* otherfuns ->
      (mark > 0)%Z ->
      forall frame,
      heap |= (init_heap :* litP frame) ->
      R (KCfg (kra (ECall name (map KResultToExp args) + y)%code krest)
              store stack heap funs mark)
        (fun _ => False)
  end.

(* Nonterminating program. Note loading the value "x" has the potential to get
   stuck but the program will not reach that point *)

Definition inf_rec := FunDef "sum_recursive_inf" ["x"]
 (SIf (BCon false)
   (SReturn 0)
   (SReturn (ECall "sum_recursive_inf" [ECon 1] + arr_val "x"))).

Inductive inf_rec_spec : Spec kcfg :=
  rec_claim : forall H x' x, heap_fun' inf_rec_spec nil inf_rec x' [Int x]
    H
    (fun r => constraint False).

Lemma inf_rec_proof : sound kstep inf_rec_spec.
Proof.
  apply proved_sound. intros. inversion H. simpl in H4. subst. simpl.
  eapply sstep. step_solver.
  eapply dstep. step_solver.
  eapply dstep. step_solver.
  eapply dstep. step_solver.
  eapply dtrans.
  econstructor. trans_solver. assumption. eassumption. trans_solver.
Qed.

(* Trivial nonterminating iterative program. Analogous iterative program as
   above gets stuck loading array value and thus is terminating *)

Definition inf_it := FunDef "sum_inf" ["x"]
 {{Decl "s";"s"<-0
  ;SWhile (BCon true) {{"s"<-"s"+1}}
  ;SReturn "s"}}.

Inductive inf_it_spec : Spec kcfg :=
  inf_claim : forall k H l x, heap_loop inf_it_spec
  inf_it 0 ("s" s|-> KInt k :* "x" s|-> KInt x)
    (asP H (rep_list l x))
    (fun r => constraint False).

Lemma inf_it_proof : sound kstep inf_it_spec.
Proof. list_solver. Qed.


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2015   --   INRIA - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require list.List.

(* Why3 goal *)
Definition hd: forall {a:Type} {a_WT:WhyType a}, (list a) -> a.
intros a a_WT [|h _].
exact why_inhabitant.
exact h.
Defined.

(* Why3 goal *)
Lemma hd_cons : forall {a:Type} {a_WT:WhyType a}, forall (x:a) (r:(list a)),
  ((hd (Init.Datatypes.cons x r)) = x).
Proof.
now intros a a_WT x r.
Qed.

(* Why3 goal *)
Definition tl: forall {a:Type} {a_WT:WhyType a}, (list a) -> (list a).
intros a a_WT [|_ t].
exact nil.
exact t.
Defined.

(* Why3 goal *)
Lemma tl_cons : forall {a:Type} {a_WT:WhyType a}, forall (x:a) (r:(list a)),
  ((tl (Init.Datatypes.cons x r)) = r).
Proof.
now intros a a_WT x r.
Qed.


Require Import compcert.lib.Coqlib.
Require Import compcert.lib.Maps.
Require Import compcert.lib.Integers.
Require Import compcert.lib.Axioms.

Require Import compcert.common.Values.
Require Import compcert.common.Memory.
Require Import compcert.common.Events.
Require Import compcert.common.AST.
Require Import compcert.common.Globalenvs.
Require Import msl.Extensionality.

Require Import sepcomp.mem_lemmas.
Require Import sepcomp.semantics.

Require Import msl.Coqlib2.

(********************* Lemmas and definitions related to mem_step ********)

Lemma mem_step_refl m: mem_step m m.
  apply (mem_step_freelist _ _ nil); trivial.
Qed.

Lemma mem_step_free:
      forall m b lo hi m', Mem.free m b lo hi = Some m' -> mem_step m m'.
Proof.
 intros. eapply (mem_step_freelist _ _ ((b,lo,hi)::nil)).
 simpl. rewrite H; reflexivity.
Qed.

Lemma mem_step_store:
      forall m ch b a v m', Mem.store ch m b a v = Some m' -> mem_step m m'.
Proof.
 intros. eapply mem_step_storebytes. eapply Mem.store_storebytes; eassumption.
Qed.

Record memstep_preserve (P:mem -> mem -> Prop) :=
  {
    preserve_trans: forall m1 m2 m3, P m1 m2 -> P m2 m3 -> P m1 m3;
    preserve_mem: forall m m', mem_step m m' -> P m m'
  }.

Lemma preserve_refl {P} (HP: memstep_preserve P): forall m, P m m.
Proof. intros. eapply (preserve_mem _ HP). apply mem_step_refl. Qed.

Lemma preserve_free {P} (HP: memstep_preserve P):
      forall m b lo hi m', Mem.free m b lo hi = Some m' -> P m m'.
Proof.
 intros. eapply (preserve_mem _ HP). eapply mem_step_free; eauto. Qed.

Theorem preserve_conj {P Q} (HP:memstep_preserve P) (HQ: memstep_preserve Q):
        memstep_preserve (fun m m' => P m m' /\ Q m m').
Proof.
intros. constructor.
+ intros. destruct H; destruct H0. split. eapply HP; eauto. eapply HQ; eauto.
+ intros; split. apply HP; trivial. apply HQ; trivial.
Qed.

(*opposite direction appears not to hold*)
Theorem preserve_impl {A} (P:A -> mem -> mem -> Prop) (Q:A->Prop):
        (forall a, Q a -> memstep_preserve (P a)) -> memstep_preserve (fun m m' => forall a, Q a -> P a m m').
Proof.
intros.
constructor; intros.
+ eapply H; eauto.
+ apply H; eauto.
Qed.

Lemma preserve_exensional {P Q} (HP:memstep_preserve P) (PQ:P=Q): memstep_preserve Q.
subst; trivial. Qed.

(*opposite direction appears not to hold*)
Theorem preserve_univ {A} (P:A -> mem -> mem -> Prop):
        (forall a, memstep_preserve (P a)) -> memstep_preserve (fun m m' => forall a, P a m m').
Proof. intros.
eapply preserve_exensional.
eapply (@preserve_impl A (fun a m m'=> P a m m') (fun a=>True)).
intros. apply H. extensionality m. extensionality m'. apply prop_ext. intuition.
Qed.

Theorem mem_forward_preserve: memstep_preserve mem_forward.
Proof.
constructor.
+ apply mem_forward_trans.
+ intros. induction H.
  eapply storebytes_forward; eassumption.
  eapply alloc_forward; eassumption.
  eapply freelist_forward; eassumption.
  eapply mem_forward_trans; eassumption.
Qed.

Theorem readonly_preserve b: memstep_preserve (fun m m' => mem_forward m m' /\ (Mem.valid_block m b -> readonly m b m')).
Proof.
constructor.
+ intros. destruct H; destruct H0.
  split; intros. eapply mem_forward_trans; eassumption.
  eapply readonly_trans; eauto. apply H2. apply H. eassumption.
+ intros; induction H.
  - split; intros. eapply storebytes_forward; eassumption.
    eapply storebytes_readonly; eassumption.
  - intros.
    split; intros. eapply alloc_forward; eassumption.
    eapply alloc_readonly; eassumption.
  - intros.
    split; intros. eapply freelist_forward; eassumption.
    eapply freelist_readonly; eassumption.
  - destruct IHmem_step1; destruct IHmem_step2.
    split. eapply mem_forward_trans; eassumption.
    intros. eapply readonly_trans. eauto. apply H4. apply H1; eassumption.
Qed.

Theorem readonly_preserve':
   memstep_preserve (fun m m' => mem_forward m m' /\ (forall b, Mem.valid_block m b -> readonly m b m')).
Proof.
eapply preserve_exensional.
eapply preserve_univ; intros. apply (readonly_preserve a).
  extensionality m. extensionality m'. apply prop_ext.
  split; intros. split. eapply H. apply xH. intros. eapply (H b). trivial.
  destruct H. split; eauto.
Qed.

Lemma storebytes_unch_loc_unwritable b ofs: forall l m m' (L: Mem.storebytes m b ofs l = Some m'),
      Mem.unchanged_on (loc_not_writable m) m m'.
Proof.
intros.
split; intros.
+ rewrite (Mem.nextblock_storebytes _ _ _ _ _ L); apply Ple_refl.
+ split; intros.
  eapply Mem.perm_storebytes_1; eassumption.
  eapply Mem.perm_storebytes_2; eassumption.
+ rewrite (Mem.storebytes_mem_contents _ _ _ _ _ L).
  apply Mem.storebytes_range_perm in L.
  destruct (eq_block b0 b); subst.
  - destruct (zle ofs ofs0).
      destruct (zlt ofs0 (ofs + Z.of_nat (length l))).
        elim H. eapply Mem.perm_max. apply L. omega.
      rewrite PMap.gss. apply Mem.setN_other. intros. omega.
    rewrite PMap.gss. apply Mem.setN_other. intros. omega.
  - rewrite PMap.gso; trivial.
Qed.

Lemma unch_on_loc_not_writable_trans m1 m2 m3
        (Q : Mem.unchanged_on (loc_not_writable m1) m1 m2)
        (W : Mem.unchanged_on (loc_not_writable m2) m2 m3)
        (F:mem_forward m1 m2):
     Mem.unchanged_on (loc_not_writable m1) m1 m3.
Proof.
  destruct Q as [Q0 Q1 Q2]. destruct W as [W0 W1 W2].
  split; intros.
  - eapply Ple_trans; eassumption.
  - cut (Mem.perm m2 b ofs k p <-> Mem.perm m3 b ofs k p).
      specialize (Q1 _ _ k p H H0). intuition.
    apply W1; clear W1. intros N. apply H. apply Q1; trivial. apply F; trivial.
  -  rewrite W2; clear W2.
       apply Q2; trivial.
     intros N; apply H. apply F; trivial. eapply Mem.perm_valid_block; eassumption.
     apply Q1; trivial. eapply Mem.perm_valid_block; eassumption.
Qed.

Theorem loc_not_writable_preserve:
   memstep_preserve (fun m m' => mem_forward m m' /\ Mem.unchanged_on (loc_not_writable m) m m').
Proof.
constructor.
+ intros. destruct H as [F1 Q]; destruct H0 as [F2 W].
  split; intros. eapply mem_forward_trans; eassumption. clear F2.
  eapply unch_on_loc_not_writable_trans; eassumption.
+ intros; induction H.
  - split; intros. eapply storebytes_forward; eassumption.
    eapply storebytes_unch_loc_unwritable; eassumption.
  - split; intros. eapply alloc_forward; eassumption.
    eapply Mem.alloc_unchanged_on; eassumption.
  - split; intros. eapply freelist_forward; eassumption.
    generalize dependent m.
    induction l; simpl; intros. inv H. apply Mem.unchanged_on_refl.
    destruct a. destruct p.
    remember (Mem.free m b z0 z) as w. destruct w; inv H. symmetry in Heqw.
    eapply unch_on_loc_not_writable_trans.
      eapply Mem.free_unchanged_on. eassumption.
        intros i I N. elim N; clear N.
        eapply Mem.perm_max. eapply Mem.perm_implies. eapply Mem.free_range_perm; eassumption. constructor.
      apply IHl; eassumption.
      eapply free_forward; eassumption.
  - destruct IHmem_step1; destruct IHmem_step2.
    split. eapply mem_forward_trans; eassumption.
    intros. clear H H0 H3. eapply unch_on_loc_not_writable_trans; eassumption.
Qed.

Lemma freelist_perm: forall l m m' (L : Mem.free_list m l = Some m') b (B: Mem.valid_block m b)
      ofs (P': Mem.perm m' b ofs Max Nonempty) k p,
      Mem.perm m b ofs k p <-> Mem.perm m' b ofs k p.
Proof. induction l; simpl; intros.
+ inv L; split; trivial.
+ destruct a. destruct p0.
  remember (Mem.free m b0 z0 z) as w. symmetry in Heqw.
  destruct w; inv L.
  specialize (IHl _ _  H0 _ (Mem.valid_block_free_1 _ _ _ _ _ Heqw _ B) _ P' k p).
  assert (P: Mem.perm m b ofs k p <-> Mem.perm m0 b ofs k p).
  { clear IHl. destruct (Mem.perm_free_list _ _ _ _ _ _ _ H0 P') as [P ?]; clear H0 P'.
    destruct (eq_block b0 b); subst.
    - destruct (zlt ofs z0).
      * split; intros. apply (Mem.perm_free_1 _ _ _ _ _ Heqw) in H0; eauto.
        eapply Mem.perm_free_3; eassumption.
      * destruct (zle z ofs).
        split; intros. apply (Mem.perm_free_1 _ _ _ _ _ Heqw) in H0; eauto.
                       eapply Mem.perm_free_3; eassumption.
        split; intros.
          eelim (Mem.perm_free_2 _ _ _ _ _ Heqw ofs Max Nonempty); clear Heqw; trivial. omega.
        eelim (Mem.perm_free_2 _ _ _ _ _ Heqw ofs Max Nonempty); clear Heqw. omega.
          eapply Mem.perm_implies. eapply Mem.perm_max. eassumption. constructor.
    - split; intros.
      * eapply (Mem.perm_free_1 _ _ _ _ _ Heqw); trivial. intuition.
      * eapply (Mem.perm_free_3 _ _ _ _ _ Heqw); trivial.
  }
  intuition.
Qed.

Theorem perm_preserve:
   memstep_preserve (fun m m' =>  mem_forward m m' /\ forall b, Mem.valid_block m b -> forall ofs, Mem.perm m' b ofs Max Nonempty ->
                                  forall k p, Mem.perm m b ofs k p <-> Mem.perm m' b ofs k p).
Proof.
constructor.
+ intros; split. eapply mem_forward_trans. apply H. apply H0.
  destruct H; destruct H0. intros.
  assert (M: Mem.perm m1 b ofs k p <-> Mem.perm m2 b ofs k p).
  - clear H2. apply H1; trivial. apply H0; trivial. apply H; trivial.
  - clear H1.
    assert (VB2: Mem.valid_block m2 b). apply H; trivial.
    destruct (H2 _ VB2 _ H4 k p); destruct M. split; intros; eauto.
+ intros; induction H.
  - split; intros. eapply storebytes_forward; eassumption.
    split; intros. eapply Mem.perm_storebytes_1; eassumption.
    eapply Mem.perm_storebytes_2; eassumption.
  - split; intros. eapply alloc_forward; eassumption.
    split; intros. eapply Mem.perm_alloc_1; eassumption.
    eapply Mem.perm_alloc_4; try eassumption.
    intros N; subst b'. elim (Mem.fresh_block_alloc _ _ _ _ _ H H0).
  - intros; split. eapply freelist_forward; eassumption.
    apply (freelist_perm _ _ _ H).
  - clear H H0. destruct IHmem_step1; destruct IHmem_step2.
    split. eapply mem_forward_trans; eassumption.
    intros.
    assert (M: Mem.perm m b ofs k p <-> Mem.perm m'' b ofs k p).
    * clear H2. apply H0; trivial. apply H1; trivial. apply H; trivial.
    * clear H0.
      assert (VB2: Mem.valid_block m'' b). apply H; trivial.
      destruct (H2 _ VB2 _ H4 k p); destruct M. split; intros; eauto.
Qed.

Lemma mem_step_forward m m': mem_step m m' -> mem_forward m m'.
intros. apply preserve_mem; trivial.
eapply mem_forward_preserve; trivial.
Qed.

Lemma freelist_perm_inv: forall l m m' (L : Mem.free_list m l = Some m') b (B: Mem.valid_block m b)
      ofs k p (P: Mem.perm m b ofs k p),
      Mem.perm m b ofs Max Freeable \/ Mem.perm m' b ofs k p.
Proof. induction l; simpl; intros.
+ inv L. right; trivial.
+ destruct a. destruct p0.
  remember (Mem.free m b0 z0 z) as w. symmetry in Heqw.
  destruct w; inv L.
  exploit Mem.perm_free_inv; eauto. intros [[HHx HH] | HH]; try subst b0.
  - left. eapply Mem.perm_max.  eapply Mem.free_range_perm; eassumption.
  - destruct (IHl _ _  H0 _ (Mem.valid_block_free_1 _ _ _ _ _ Heqw _ B) _ _ _ HH); clear IHl.
    2: right; trivial.
    left. eapply Mem.perm_free_3; eauto.
Qed.

Theorem preserves_max_eq_or_free:
   memstep_preserve (fun m m' =>  mem_forward m m' /\
                                  forall b (VB: Mem.valid_block m b) ofs,
                                   (forall k p, Mem.perm m b ofs k p <-> Mem.perm m' b ofs k p) \/
                                   (Mem.perm m b ofs Max Freeable /\
                                    Mem.perm_order'' None ((Mem.mem_access m') !! b ofs Max))).
Proof.
constructor.
+ intros; split. eapply mem_forward_trans. apply H. apply H0.
  destruct H; destruct H0. intros.
  assert (VB2: Mem.valid_block m2 b). { apply H; trivial. }
  destruct (H1 _ VB ofs) as [K1 | [K1 L1]]; destruct (H2 _ VB2 ofs) as [K2 | [K2 L2]]; clear H1 H2.
  - left; intros. specialize (K1 k p); specialize (K2 k p). intuition.
  - right; split; trivial. apply K1; trivial.
  - right; split; trivial. simpl in *. specialize (K2 Max).
    unfold Mem.perm in *.
    remember ((Mem.mem_access m3) !! b ofs Max) as w; destruct w; trivial.
    destruct ((Mem.mem_access m2) !! b ofs Max); try contradiction.
    destruct (K2 p); simpl in *. apply H2. apply perm_refl.
  - right; split; trivial.
+ intros; induction H.
  - split; intros. eapply storebytes_forward; eassumption.
    left; intros. split; intros.
    * eapply Mem.perm_storebytes_1; eassumption.
    * eapply Mem.perm_storebytes_2; eassumption.
  - split; intros. eapply alloc_forward; eassumption.
    left; intros. split; intros.
    * eapply Mem.perm_alloc_1; eassumption.
    * eapply Mem.perm_alloc_4; try eassumption.
      intros N; subst. eapply Mem.fresh_block_alloc; eassumption.
  - split; intros. eapply freelist_forward; eassumption.
    destruct (Mem.perm_dec m' b ofs Max Nonempty).
    * left; intros. eapply freelist_perm; eassumption.
    * destruct (Mem.perm_dec m b ofs Max Freeable); trivial.
       right; split; trivial. unfold Mem.perm in n; simpl in *.
       destruct ((Mem.mem_access m') !! b ofs Max); trivial.
       elim n; clear n. constructor.
      left; intros.
      split; intros. 2: eapply perm_freelist; eassumption.
      exploit freelist_perm_inv; eauto. intros [X | X]; trivial; contradiction.
  - clear H H0. destruct IHmem_step1; destruct IHmem_step2.
    split. eapply mem_forward_trans; eassumption.
    intros.
    assert (VB2 : Mem.valid_block m'' b). { apply H; trivial. }
    specialize (H0 _ VB ofs). specialize (H2 _ VB2 ofs).
    destruct H0 as [K | [K1 K2]]; destruct H2 as [L | [L1 L2]].
    * left; intros. split; intros. apply L. apply K; trivial.
      apply K. apply L; trivial.
    * right. split; trivial. apply K; trivial.
    * right. split; trivial.
      clear K1. unfold Mem.perm in *. simpl in *. specialize (L Max).
      remember ((Mem.mem_access m') !! b ofs Max) as d; destruct d; trivial.
      destruct ((Mem.mem_access m'') !! b ofs Max); try contradiction.
      specialize (L p); simpl in *. apply L. apply perm_refl.
    * right. split; trivial.
Qed.

Theorem mem_step_max_eq_or_free m m' (STEP: mem_step m m') b (VB: Mem.valid_block m b) ofs:
       (forall k p, Mem.perm m b ofs k p <-> Mem.perm m' b ofs k p) \/
       (Mem.perm m b ofs Max Freeable /\ None = ((Mem.mem_access m') !! b ofs Max)).
Proof. intros.
exploit preserve_mem. apply preserves_max_eq_or_free. eassumption.
simpl; intros [A B]. destruct (B _ VB ofs). left; trivial. right.
  destruct H; split; trivial.
  destruct ((Mem.mem_access m') !! b ofs Max); trivial; contradiction.
Qed.

Lemma memsem_preserves {G C} (s: @MemSem G C) P (HP:memstep_preserve P):
      forall g c m c' m', corestep s g c m c' m'-> P m m'.
Proof. intros.
  apply corestep_mem in H.
  eapply preserve_mem; eassumption.
Qed.

Lemma corestep_fwd {C G} (s:@MemSem G C) g c m c' m'
   (CS:corestep s g c m c' m' ): mem_forward m m'.
Proof.
eapply memsem_preserves; try eassumption. apply mem_forward_preserve.
Qed.

Lemma corestep_rdonly {C G} (s:@MemSem G C) g c m c' m'
   (CS:corestep s g c m c' m') b (VB:Mem.valid_block m b): readonly m b m'.
Proof.
eapply (memsem_preserves s _ readonly_preserve'); eassumption.
Qed.

Lemma mem_step_nextblock:  memstep_preserve (fun m m' => Mem.nextblock m <= Mem.nextblock m')%positive.
constructor.
+ intros. xomega.
+ induction 1.
 - apply Mem.nextblock_storebytes in H;
   rewrite H; xomega.
 - apply Mem.nextblock_alloc in H.
   rewrite H. clear. xomega.
 - apply nextblock_freelist in H.
   rewrite H; xomega.
 - xomega.
Qed.

Lemma mem_step_nextblock':
  forall m m',
     mem_step m m' ->
   (Mem.nextblock m <= Mem.nextblock m')%positive.
Proof. apply mem_step_nextblock. Qed.

(*E-step: Axiomatization of external steps - potentially useful when Memory interface is hardened
Inductive e_step m m' : Prop :=
    mem_step_estep: mem_step m m' -> e_step m m'
  | drop_perm_estep: forall b lo hi p,
      Mem.drop_perm m b lo hi p = Some m' -> e_step m m'
  | change_cur_estep:
      (forall b ofs, (Mem.mem_access m) !! b ofs Max = (Mem.mem_access m') !! b ofs Max) ->
      Mem.unchanged_on (loc_not_writable m) m m' ->
      (Mem.mem_contents m = Mem.mem_contents m') ->
      Mem.nextblock m = Mem.nextblock m' -> e_step m m'
  | estep_trans: forall m'',
       e_step m m'' -> e_step m'' m' -> e_step m m'.

Lemma e_step_refl m: e_step m m.
Proof. apply mem_step_estep. apply mem_step_refl. Qed.

Lemma estep_forward m m' (E:e_step m m'): mem_forward m m'.
Proof.
induction E.
apply mem_forward_preserve; eassumption.
+ split; intros.
    eapply Mem.drop_perm_valid_block_1; eassumption.
    eapply Mem.perm_drop_4; eassumption.
+ split; intros.
  unfold Mem.valid_block in *. rewrite H2 in *; assumption.
  unfold Mem.perm. rewrite H. apply H4.
+ eapply mem_forward_trans; eassumption.
Qed.

Lemma estep_unch_on_loc_not_writable m m' (E:e_step m m'): Mem.unchanged_on (loc_not_writable m) m m'.
Proof.
induction E.
+ apply loc_not_writable_preserve in H. apply H.
+ unfold Mem.drop_perm in H.
  destruct (Mem.range_perm_dec m b lo hi Cur Freeable); inv H; simpl in *.
  split; simpl; trivial.
  intros. red in H.
  unfold Mem.perm; simpl. rewrite PMap.gsspec.
  destruct (peq b0 b); subst; simpl. 2: intuition.
  destruct (zle lo ofs); simpl. 2: intuition.
  destruct (zlt ofs hi); simpl. 2: intuition.
  elim H. eapply Mem.perm_max. eapply Mem.perm_implies. apply r. omega. constructor.
+ trivial.
+ eapply unch_on_loc_not_writable_trans; try eassumption. eapply estep_forward; eassumption.
Qed.
*)
(*
Theorem loadbytes_drop m b lo hi p m' (D:Mem.drop_perm m b lo hi p = Some m'):
  forall b' ofs,
  b' <> b \/ ofs < lo \/ hi <= ofs \/ perm_order p Readable ->
  Mem.loadbytes m' b' ofs 1 = Mem.loadbytes m b' ofs 1.
Proof.
  intros.
Transparent Mem.loadbytes.
  unfold Mem.loadbytes.
  destruct (Mem.range_perm_dec m b' ofs (ofs + 1) Cur Readable).
  rewrite pred_dec_true.
  unfold Mem.drop_perm in D. destruct (Mem.range_perm_dec m b lo hi Cur Freeable); inv D. simpl. auto.
  red; intros. specialize (Mem.perm_drop_1 _ _ _ _ _ _ D ofs0 Cur); intros.
    destruct (eq_block b' b); subst.
      destruct H. eapply Mem.perm_drop_3. eassumption. left; trivial. apply r. trivial.
      destruct (zlt ofs lo). eapply Mem.perm_drop_3. eassumption. right. omega. apply r. trivial.
      destruct H. omega.
      destruct (zle hi ofs). eapply Mem.perm_drop_3. eassumption. right. omega. apply r. trivial.
      destruct H. omega.
      eapply Mem.perm_implies. apply H1. omega. trivial.
   eapply Mem.perm_drop_3. eassumption. left; trivial. apply r. omega.

  destruct (Mem.range_perm_dec m' b' ofs (ofs + 1) Cur Readable); trivial.
  elim n; clear n. red; intros. eapply Mem.perm_drop_4. eassumption. apply r. trivial.
Qed.
*)

Lemma mem_step_obeys_cur_write:
  forall m b ofs m',
    Mem.valid_block m b ->
   ~ Mem.perm m b ofs Cur Writable ->
   mem_step m m' ->
 ZMap.get ofs (PMap.get b (Mem.mem_contents m)) =
 ZMap.get ofs (PMap.get b (Mem.mem_contents m')).
Proof.
 intros.
 induction H1.
* revert m ofs0 H H0 H1; induction bytes; intros.
 Transparent Mem.storebytes.
 unfold Mem.storebytes in H1.
 destruct (Mem.range_perm_dec m b0 ofs0
         (ofs0 + Z.of_nat (length nil)) Cur Writable);
  inv H1; simpl.
 destruct (peq b b0). subst b0.
 rewrite PMap.gss. auto.
 rewrite PMap.gso; auto.
 change (a::bytes) with ((a::nil)++bytes) in H1.
 apply Mem.storebytes_split in H1.
 destruct H1 as [m1 [? ?]].
 etransitivity.
 2: eapply IHbytes; try apply H2.
 clear H2 IHbytes.
 unfold Mem.storebytes in H1.
Opaque Mem.storebytes.
 destruct (Mem.range_perm_dec m b0 ofs0
         (ofs0 + Z.of_nat (length (a :: nil))) Cur Writable);
 inv H1; simpl.
 destruct (peq b b0). subst b0.
 rewrite PMap.gss.
 destruct (zeq ofs0 ofs). subst.
 contradiction H0. apply r. simpl. omega.
 rewrite ZMap.gso; auto.
 rewrite PMap.gso; auto.
 clear - H H1.
 eapply Mem.storebytes_valid_block_1; eauto.
 contradict H0. clear - H1 H0.
 eapply Mem.perm_storebytes_2; eauto.
*
 apply AllocContentsOther with (b':=b) in H1.
 rewrite H1. auto. intro; subst.
 apply Mem.alloc_result in H1; unfold Mem.valid_block in H.
 subst. apply Plt_strict in H; auto.
*
 revert m H H0 H1; induction l; simpl; intros.
 inv H1; auto.
 destruct a. destruct p.
 destruct (Mem.free m b0 z0 z) eqn:?; inv H1.
 rewrite <- (IHl m0); auto.
 eapply free_contents; eauto.
 intros [? ?]. subst b0. apply H0.
 apply Mem.free_range_perm in Heqo.
   specialize (Heqo ofs).
   eapply Mem.perm_implies. apply Heqo. omega. constructor.
 clear - H Heqo.
 unfold Mem.valid_block in *.
 apply Mem.nextblock_free in Heqo. rewrite Heqo.
 auto.
 clear - H0 Heqo.
 contradict H0.
 eapply Mem.perm_free_3; eauto.
*
 assert (Mem.valid_block m'' b). {
   apply mem_step_nextblock in H1_.
   unfold Mem.valid_block in *.
   eapply Plt_le_trans; eauto.
 }
 erewrite IHmem_step1 by auto. apply IHmem_step2; auto.
 contradict H0.
 clear - H H1_ H0.
 revert H H0; induction H1_; intros.
 eapply Mem.perm_storebytes_2; eauto.
 pose proof (Mem.perm_alloc_inv _ _ _ _ _ H _ _ _ _ H1).
 destruct (eq_block b b'); subst; trivial.
 - pose proof (Mem.alloc_result _ _ _ _ _ H).
   subst. apply Plt_strict in H0. contradiction.
 - eapply Mem.perm_free_list in H; try apply H1.
   destruct H; auto.
 - eapply IHH1_1; auto. eapply IHH1_2; eauto.
   apply mem_step_nextblock in H1_1.
   unfold Mem.valid_block in *.
   eapply Plt_le_trans; eauto.
Qed.

Lemma ple_load m ch a v
            (LD: Mem.loadv ch m a = Some v)
            m1 (PLE: perm_lesseq m m1):
           Mem.loadv ch m1 a = Some v.
Proof.
unfold Mem.loadv in *.
destruct a; auto.
Transparent Mem.load.
unfold Mem.load in *.
Opaque Mem.load.
destruct PLE.
if_tac in LD; [ | inv LD].
rewrite if_true.
rewrite <- LD; clear LD.
f_equal. f_equal.
destruct H.
rewrite size_chunk_conv in H.
clear - H perm_le_cont.
forget (size_chunk_nat ch) as n.
forget (Int.unsigned i) as j.
revert j H; induction n; intros; simpl; f_equal.
apply perm_le_cont.
apply (H j).
rewrite inj_S.
omega.
apply IHn.
rewrite inj_S in H.
intros ofs ?; apply H. omega.
clear - H perm_le_Cur.
destruct H; split; auto.
intros ? ?. specialize (H ofs H1).
hnf in H|-*.
specialize (perm_le_Cur b ofs).
destruct ((Mem.mem_access m) !! b ofs Cur); try contradiction.
destruct ((Mem.mem_access m1) !! b ofs Cur);
inv perm_le_Cur; auto; try constructor; try inv H.
Qed.

Lemma ple_store:
  forall ch m v1 v2 m' m1
   (PLE: perm_lesseq m m1),
   Mem.storev ch m v1 v2 = Some m' ->
   exists m1', perm_lesseq m' m1' /\ Mem.storev ch m1 v1 v2 = Some m1'.
Proof.
intros.
unfold Mem.storev in *.
destruct v1; try discriminate.
Transparent Mem.store.
unfold Mem.store in *.
Opaque Mem.store.
destruct (Mem.valid_access_dec m ch b (Int.unsigned i)  Writable); inv H.
destruct (Mem.valid_access_dec m1 ch b (Int.unsigned i)
      Writable).
*
eexists; split; [ | reflexivity].
destruct PLE.
constructor; simpl; auto.
intros. unfold Mem.perm in H. simpl in H.
forget (Int.unsigned i) as z.
destruct (eq_block b0 b). subst.
rewrite !PMap.gss.
forget (encode_val ch v2) as vl.
assert (z <= ofs < z + Z.of_nat (length vl) \/ ~ (z <= ofs < z + Z.of_nat (length vl))) by omega.
destruct H0.
clear - H0.
forget ((Mem.mem_contents m1) !! b) as mA.
forget ((Mem.mem_contents m) !! b) as mB.
revert z mA mB H0; induction vl; intros; simpl.
simpl in H0; omega.
simpl length in H0; rewrite inj_S in H0.
destruct (zeq z ofs).
subst ofs.
rewrite !Mem.setN_outside by omega. rewrite !ZMap.gss; auto.
apply IHvl; omega.
rewrite !Mem.setN_outside by omega.
apply perm_le_cont. auto.
rewrite !PMap.gso by auto.
apply perm_le_cont. auto.
*
contradiction n; clear n.
destruct PLE.
unfold Mem.valid_access in *.
destruct v; split; auto.
hnf in H|-*; intros.
specialize (H _ H1).
clear - H perm_le_Cur.
specialize (perm_le_Cur b ofs).
hnf in H|-*.
destruct ((Mem.mem_access m) !! b ofs Cur); try contradiction.
inv H;
destruct ((Mem.mem_access m1) !! b ofs Cur);
inv perm_le_Cur; auto; try constructor; try inv H.
Qed.

Lemma free_access_inv m b lo hi m' (FR: Mem.free m b lo hi = Some m') b' ofs k p
  (P: (Mem.mem_access m') !! b' ofs k = Some p):  (Mem.mem_access m) !! b' ofs k = Some p.
Proof.
apply Mem.free_result in FR; subst. simpl in *.
rewrite PMap.gsspec in P.
destruct (peq b' b); subst; trivial.
destruct (zle lo ofs && zlt ofs hi); inv P; trivial.
Qed.

Lemma free_access_inv_None m b lo hi m' (FR: Mem.free m b lo hi = Some m') b' ofs k
  (P: (Mem.mem_access m') !! b' ofs k = None):
  (b' = b /\ Z.le lo ofs /\ Z.lt ofs hi /\  (Mem.mem_access m) !! b' ofs k = Some Freeable) \/
  ((b' <> b \/ Z.lt ofs lo \/ Z.le hi ofs) /\ (Mem.mem_access m) !! b' ofs k = None).
Proof.
specialize (Mem.free_result _ _ _ _ _ FR). intros; subst. simpl in *.
rewrite PMap.gsspec in P.
destruct (peq b' b); subst.
+ remember (zle lo ofs && zlt ofs hi) as q.
  destruct q; inv P.
  - left. split; trivial. destruct (zle lo ofs); simpl in *; try discriminate.
    split; trivial. destruct (zlt ofs hi); simpl in *; try discriminate.
    split; trivial.
    assert (RP: Mem.perm m b ofs Cur Freeable). apply (Mem.free_range_perm _ _ _ _ _ FR ofs); omega.
    destruct k.
    * eapply Mem.perm_max in RP.
      unfold Mem.perm in RP. destruct ((Mem.mem_access m) !! b ofs Max); simpl in *; try discriminate.
      destruct p; simpl in *; try inv RP; simpl; trivial. contradiction.
    * unfold Mem.perm in RP. destruct ((Mem.mem_access m) !! b ofs Cur); simpl in *; try discriminate.
      destruct p; simpl in *; try inv RP; simpl; trivial. contradiction.
  - right; split; trivial. right.
    destruct (zle lo ofs); destruct (zlt ofs hi); simpl in *; try discriminate; try omega.
+ right; split; trivial. left; trivial.
Qed.

Lemma ple_free: forall m m' b lo hi (FL: Mem.free m b lo hi = Some m') m1 (PLE:perm_lesseq m m1),
      exists m1', Mem.free m1 b lo hi = Some m1' /\ perm_lesseq m' m1'.
Proof. intros.
  specialize (Mem.free_range_perm _ _ _ _ _ FL). intros.
  assert (RF: Mem.range_perm m1 b lo hi Cur Freeable).
  { destruct PLE. red; intros.
    specialize (perm_le_Cur b ofs). specialize (H _ H0). unfold Mem.perm in *.
    destruct ((Mem.mem_access m) !! b ofs Cur); simpl in *; try contradiction.
    destruct ((Mem.mem_access m1) !! b ofs Cur); simpl in *; try contradiction.
    eapply perm_order_trans; eassumption.
  }
  destruct (Mem.range_perm_free m1 b lo hi RF) as [mm MM].
  exists mm; split; trivial.
  destruct PLE.
  split; intros.
  - specialize (perm_le_Cur b0 ofs); clear perm_le_Max perm_le_cont.
    remember ((Mem.mem_access mm) !! b0 ofs Cur) as q; symmetry in Heqq.
      destruct q; simpl in *.
      * rewrite (free_access_inv _ _ _ _ _ MM _ _ _ _ Heqq) in *.
        remember ((Mem.mem_access m') !! b0 ofs Cur) as w; symmetry in Heqw.
         destruct w; trivial.
         rewrite (free_access_inv _ _ _ _ _ FL _ _ _ _ Heqw) in *. simpl in *; trivial.
      * remember ((Mem.mem_access m') !! b0 ofs Cur) as w; symmetry in Heqw.
        destruct w; trivial.
        rewrite (free_access_inv _ _ _ _ _ FL _ _ _ _ Heqw) in *.
        destruct (free_access_inv_None _ _ _ _ _ MM _ _ _ Heqq).
        ++ destruct H0 as [? [? [? ?]]]; subst.
           rewrite (Mem.free_result _ _ _ _ _ FL) in *. simpl in *.
           rewrite PMap.gss in Heqw.
           remember (zle lo ofs&& zlt ofs hi ) as t; destruct t; simpl in *; try discriminate.
           destruct (zle lo ofs); destruct (zlt ofs hi); simpl in *; try discriminate; omega.
        ++ destruct H0 as [? ?]. rewrite H1 in *; simpl in *; contradiction.
  - specialize (perm_le_Max b0 ofs); clear perm_le_Cur perm_le_cont.
    remember ((Mem.mem_access mm) !! b0 ofs Max) as q; symmetry in Heqq.
      destruct q; simpl in *.
      * rewrite (free_access_inv _ _ _ _ _ MM _ _ _ _ Heqq) in *.
        remember ((Mem.mem_access m') !! b0 ofs Max) as w; symmetry in Heqw.
         destruct w; trivial.
         rewrite (free_access_inv _ _ _ _ _ FL _ _ _ _ Heqw) in *. simpl in *; trivial.
      * remember ((Mem.mem_access m') !! b0 ofs Max) as w; symmetry in Heqw.
        destruct w; trivial.
        rewrite (free_access_inv _ _ _ _ _ FL _ _ _ _ Heqw) in *.
        destruct (free_access_inv_None _ _ _ _ _ MM _ _ _ Heqq).
        ++ destruct H0 as [? [? [? ?]]]; subst.
           rewrite (Mem.free_result _ _ _ _ _ FL) in *. simpl in *.
           rewrite PMap.gss in Heqw.
           remember (zle lo ofs&& zlt ofs hi ) as t; destruct t; simpl in *; try discriminate.
           destruct (zle lo ofs); destruct (zlt ofs hi); simpl in *; try discriminate; omega.
        ++ destruct H0 as [? ?]. rewrite H1 in *; simpl in *; contradiction.
  - rewrite (Mem.free_result _ _ _ _ _ FL). rewrite (Mem.free_result _ _ _ _ _ MM).
    simpl. apply perm_le_cont. eapply Mem.perm_free_3; eassumption.
  - rewrite (Mem.free_result _ _ _ _ _ FL). rewrite (Mem.free_result _ _ _ _ _ MM).
    simpl; trivial.
Qed.

Lemma ple_freelist: forall l m m' (FL: Mem.free_list m l = Some m') m1 (PLE:perm_lesseq m m1),
      exists m1', Mem.free_list m1 l = Some m1' /\ perm_lesseq m' m1'.
Proof. induction l; simpl; intros.
+ inv FL;  exists m1; split; trivial.
+ destruct a as [[b lo] hi]. remember (Mem.free m b lo hi) as q. destruct q; inv FL.
  symmetry in Heqq.
  destruct (ple_free _ _ _ _ _ Heqq _ PLE) as [mm [MMF MM]]. rewrite MMF. eauto.
Qed.

Lemma ple_storebytes:
  forall m b ofs bytes m' m1
   (PLE: perm_lesseq m m1),
   Mem.storebytes m b ofs bytes = Some m' ->
   exists m1', perm_lesseq m' m1' /\ Mem.storebytes m1 b ofs bytes = Some m1'.
Proof.
intros. Transparent Mem.storebytes. unfold Mem.storebytes in *. Opaque Mem.storebytes.
remember (Mem.range_perm_dec m b ofs (ofs + Z.of_nat (length bytes)) Cur Writable ) as d.
destruct d; inv H.
destruct (Mem.range_perm_dec m1 b ofs (ofs + Z.of_nat (length bytes)) Cur Writable).
+ clear Heqd.
  eexists; split. 2: reflexivity.
  destruct PLE.
  split; intros; simpl.
  - simpl. apply perm_le_Cur.
  - simpl. apply perm_le_Max.
  - simpl in *. rewrite PMap.gsspec. rewrite PMap.gsspec.
    destruct (peq b0 b); subst.
    * destruct (zlt ofs0 ofs).
      ++ rewrite Mem.setN_outside. 2: left; trivial.  rewrite Mem.setN_outside. 2: left; trivial.  apply perm_le_cont. apply H.
      ++ destruct (zle (ofs+Z.of_nat (length bytes)) ofs0).
         rewrite Mem.setN_outside. 2: right; xomega.  rewrite Mem.setN_outside. 2: right; xomega.  apply perm_le_cont. apply H.
         clear - g g0.
         remember ((Mem.mem_contents m1) !! b) as mA. clear HeqmA.
         remember ((Mem.mem_contents m) !! b) as mB. clear HeqmB.
         revert ofs mA mB g g0; induction bytes; intros; simpl.
         -- simpl in *; omega.
         -- simpl length in g0; rewrite inj_S in g0.
            destruct (zeq ofs ofs0).
            ** subst ofs0. rewrite !Mem.setN_outside by omega. rewrite !ZMap.gss; auto.
            ** apply IHbytes; omega.
    * apply perm_le_cont. apply H.
  - assumption .
+ elim n; clear - PLE r. destruct PLE.
  red; intros. specialize (r _ H). specialize (perm_le_Cur b ofs0).
  unfold Mem.perm in *.
  destruct ((Mem.mem_access m1) !! b ofs0 Cur).
  destruct ((Mem.mem_access m) !! b ofs0 Cur). simpl in *. eapply perm_order_trans; eassumption.
  inv r.
  destruct ((Mem.mem_access m) !! b ofs0 Cur); inv perm_le_Cur. inv r.
Qed.

Lemma ple_loadbytes m b ofs n bytes
            (LD: Mem.loadbytes m b ofs n = Some bytes)
            m1 (PLE: perm_lesseq m m1) (N: 0 <= n):
            Mem.loadbytes m1 b ofs n = Some bytes.
Proof.
Transparent Mem.loadbytes.
unfold Mem.loadbytes.
Opaque Mem.loadbytes.
apply loadbytes_D in LD. destruct LD as [RP1 CONT].
destruct PLE.
destruct (Mem.range_perm_dec m1 b ofs (ofs + n) Cur Readable).
+ rewrite CONT; f_equal. eapply Mem.getN_exten.
  intros. apply perm_le_cont. apply RP1. rewrite nat_of_Z_eq in H; omega.
+ elim n0; clear - RP1 perm_le_Cur.
  red; intros. specialize (RP1 _ H). specialize (perm_le_Cur b ofs0).
  unfold Mem.perm in *.
  destruct ((Mem.mem_access m1) !! b ofs0 Cur).
  destruct ((Mem.mem_access m) !! b ofs0 Cur). simpl in *. eapply perm_order_trans; eassumption.
  inv RP1.
  destruct ((Mem.mem_access m) !! b ofs0 Cur); inv perm_le_Cur. inv RP1.
Qed.

Lemma alloc_access_inv m b lo hi m' (ALLOC: Mem.alloc m lo hi = (m', b)) b' ofs k p
  (P: (Mem.mem_access m') !! b' ofs k = Some p):
  (b'=b /\ Z.le lo ofs /\ Z.lt ofs hi) \/
  (b' <> b /\ (Mem.mem_access m) !! b' ofs k = Some p).
Proof.
Transparent Mem.alloc. unfold Mem.alloc in ALLOC. Opaque Mem.alloc. inv ALLOC; simpl in *.
rewrite PMap.gsspec in P.
destruct (peq b' (Mem.nextblock m)); subst; trivial.
+ left; split; trivial.
  remember (zle lo ofs && zlt ofs hi) as q. destruct q; inv P; trivial.
  destruct (zle lo ofs); destruct (zlt ofs hi); simpl in *; try discriminate; omega.
+ right; split; trivial.
Qed.

Lemma alloc_access_inv_None m b lo hi m' (ALLOC: Mem.alloc m lo hi = (m', b)) b' ofs k
  (P: (Mem.mem_access m') !! b' ofs k = None): (Mem.mem_access m) !! b' ofs k = None.
Proof.
Transparent Mem.alloc. unfold Mem.alloc in ALLOC. Opaque Mem.alloc. inv ALLOC; simpl in *.
rewrite PMap.gsspec in P.
destruct (peq b' (Mem.nextblock m)); subst; trivial.
apply Mem.nextblock_noaccess. xomega.
Qed.

Lemma alloc_inc_perm: forall m lo hi m' b
      (M: Mem.alloc m lo hi = (m',b)) m1 (PLE: perm_lesseq m m1),
      exists m1' : mem, Mem.alloc m1 lo hi =(m1',b) /\ perm_lesseq m' m1'.
Proof. intros.
  remember (Mem.alloc m1 lo hi). destruct p; symmetry in Heqp.
  assert (B: b0=b).
     apply Mem.alloc_result  in M. apply Mem.alloc_result  in Heqp.
     destruct PLE. rewrite perm_le_nb in *; subst. trivial.
  subst b0.
  eexists m0; split; trivial.
  Transparent Mem.alloc. unfold Mem.alloc in *. Opaque Mem.alloc. inv M; inv Heqp. simpl in *.
  destruct PLE.
  split; simpl; intros.
  + specialize (perm_le_Cur b ofs); clear perm_le_Max perm_le_cont.
    rewrite perm_le_nb, PMap.gsspec.  rewrite PMap.gsspec.
    destruct (peq b (Mem.nextblock m1)); subst; trivial.
    destruct (if zle lo ofs && zlt ofs hi then Some Freeable else None); simpl; trivial. apply perm_refl.
  + specialize (perm_le_Max b ofs); clear perm_le_Cur perm_le_cont.
    rewrite perm_le_nb, PMap.gsspec.  rewrite PMap.gsspec.
    destruct (peq b (Mem.nextblock m1)); subst; trivial.
    destruct (if zle lo ofs && zlt ofs hi then Some Freeable else None); simpl; trivial. apply perm_refl.
  + unfold Mem.perm in H; simpl in H.
    rewrite PMap.gsspec in H.
    destruct (peq b (Mem.nextblock m)); subst.
    - rewrite perm_le_nb. do 2 rewrite PMap.gss. trivial.
    - rewrite PMap.gso; try rewrite H1; trivial. rewrite PMap.gso; trivial. apply perm_le_cont. apply H.
  + rewrite H1; trivial.
Qed.

Lemma perm_lesseq_refl:
  forall m, perm_lesseq m m.
Proof.
intros.
 constructor; intros; auto.
 match goal with |- Mem.perm_order'' ?A _ => destruct A; constructor end.
 match goal with |- Mem.perm_order'' ?A _ => destruct A; constructor end.
Qed.

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

Definition corestep_fun {G C M : Type} (sem : @CoreSemantics G C M) :=
  forall (m m' m'' : M) ge c c' c'',
  corestep sem ge c m c' m' ->
  corestep sem ge c m c'' m'' ->
  c'=c'' /\ m'=m''.

(**  Multistepping *)

Section corestepN.
  Context {G C M E:Type} (Sem:@CoreSemantics G C M) (ge:G).

  Fixpoint corestepN (n:nat) : C -> M -> C -> M -> Prop :=
    match n with
      | O => fun c m c' m' => (c,m) = (c',m')
      | S k => fun c1 m1 c3 m3 => exists c2, exists m2,
        corestep Sem ge c1 m1 c2 m2 /\
        corestepN k c2 m2 c3 m3
    end.

  Lemma corestepN_add : forall n m c1 m1 c3 m3,
    corestepN (n+m) c1 m1 c3 m3 <->
    exists c2, exists m2,
      corestepN n c1 m1 c2 m2 /\
      corestepN m c2 m2 c3 m3.
  Proof.
    induction n; simpl; intuition.
    firstorder. firstorder.
    inv H. auto.
    decompose [ex and] H. clear H.
    destruct (IHn m x x0 c3 m3).
    apply H in H2.
    decompose [ex and] H2. clear H2.
    repeat econstructor; eauto.
    decompose [ex and] H. clear H.
    exists x1. exists x2; split; auto.
    destruct (IHn m x1 x2 c3 m3).
    eauto.
  Qed.

  Definition corestep_plus c m c' m' :=
    exists n, corestepN (S n) c m c' m'.

  Definition corestep_star c m c' m' :=
    exists n, corestepN n c m c' m'.

  Lemma corestep_plus_star : forall c1 c2 m1 m2,
    corestep_plus c1 m1 c2 m2 -> corestep_star c1 m1 c2 m2.
  Proof. intros. destruct H as [n1 H1]. eexists. apply H1. Qed.

  Lemma corestep_plus_trans : forall c1 c2 c3 m1 m2 m3,
    corestep_plus c1 m1 c2 m2 -> corestep_plus c2 m2 c3 m3 ->
    corestep_plus c1 m1 c3 m3.
  Proof. intros. destruct H as [n1 H1]. destruct H0 as [n2 H2].
    destruct (corestepN_add (S n1) (S n2) c1 m1 c3 m3) as [_ H].
    eexists. apply H. exists c2. exists m2. split; assumption.
  Qed.

  Lemma corestep_star_plus_trans : forall c1 c2 c3 m1 m2 m3,
    corestep_star c1 m1 c2 m2 -> corestep_plus c2 m2 c3 m3 ->
    corestep_plus c1 m1 c3 m3.
  Proof. intros. destruct H as [n1 H1]. destruct H0 as [n2 H2].
    destruct (corestepN_add n1 (S n2) c1 m1 c3 m3) as [_ H].
    rewrite <- plus_n_Sm in H.
    eexists. apply H.  exists c2. exists m2.  split; assumption.
  Qed.

  Lemma corestep_plus_star_trans: forall c1 c2 c3 m1 m2 m3,
    corestep_plus c1 m1 c2 m2 -> corestep_star c2 m2 c3 m3 ->
    corestep_plus c1 m1 c3 m3.
  Proof. intros. destruct H as [n1 H1]. destruct H0 as [n2 H2].
    destruct (corestepN_add (S n1) n2 c1 m1 c3 m3) as [_ H].
    rewrite plus_Sn_m in H.
    eexists. apply H.  exists c2. exists m2.  split; assumption.
  Qed.

  Lemma corestep_star_trans: forall c1 c2 c3 m1 m2 m3,
    corestep_star c1 m1 c2 m2 -> corestep_star c2 m2 c3 m3 ->
    corestep_star c1 m1 c3 m3.
  Proof. intros. destruct H as [n1 H1]. destruct H0 as [n2 H2].
    destruct (corestepN_add n1 n2 c1 m1 c3 m3) as [_ H].
    eexists. apply H.  exists c2. exists m2.  split; assumption.
  Qed.

  Lemma corestep_plus_one: forall c m c' m',
    corestep  Sem ge c m c' m' -> corestep_plus c m c' m'.
  Proof. intros. unfold corestep_plus, corestepN. simpl.
    exists O. exists c'. exists m'. eauto.
  Qed.

  Lemma corestep_plus_two: forall c m c' m' c'' m'',
    corestep  Sem ge c m c' m' -> corestep  Sem ge c' m' c'' m'' ->
    corestep_plus c m c'' m''.
  Proof. intros.
    exists (S O). exists c'. exists m'. split; trivial.
    exists c''. exists m''. split; trivial. reflexivity.
  Qed.

  Lemma corestep_star_zero: forall c m, corestep_star  c m c m.
  Proof. intros. exists O. reflexivity. Qed.

  Lemma corestep_star_one: forall c m c' m',
    corestep  Sem ge c m c' m' -> corestep_star c m c' m'.
  Proof. intros.
    exists (S O). exists c'. exists m'. split; trivial. reflexivity.
  Qed.

  Lemma corestep_plus_split: forall c m c' m',
    corestep_plus c m c' m' ->
    exists c'', exists m'', corestep  Sem ge c m c'' m'' /\
      corestep_star c'' m'' c' m'.
  Proof. intros.
    destruct H as [n [c2 [m2 [Hstep Hstar]]]]. simpl in*.
    exists c2. exists m2. split. assumption. exists n. assumption.
  Qed.

End corestepN.

Section memstepN.
  Context {G C:Type} (M:@MemSem G C) (g:G).

Lemma corestepN_mem n: forall c m c' m', corestepN M g n c m c' m' -> mem_step m m'.
induction n; intros; inv H.
  apply mem_step_refl.
  destruct H0 as [m'' [CS CSN]]. eapply mem_step_trans.
  eapply corestep_mem; eassumption.
  eapply IHn; eassumption.
Qed.

Lemma corestep_plus_mem c m c' m' (H:corestep_plus M g c m c' m'): mem_step m m'.
destruct H as [n H]. eapply corestepN_mem; eassumption. Qed.

Lemma corestep_star_mem c m c' m' (H:corestep_star M g c m c' m'): mem_step m m'.
destruct H as [n H]. eapply corestepN_mem; eassumption. Qed.

Lemma memsem_preservesN P (HP: memstep_preserve P)
      n c m c' m' (H: corestepN M g n c m c' m'): P m m'.
apply corestepN_mem in H. apply HP; trivial. Qed.

Lemma memsem_preserves_plus P (HP:memstep_preserve P)
      c m c' m' (H: corestep_plus M g c m c' m'): P m m'.
destruct H. apply (memsem_preservesN _ HP) in H; trivial. Qed.

Lemma memsem_preserves_star P (HP:memstep_preserve P)
      c m c' m' (H: corestep_star M g c m c' m'): P m m'.
destruct H. apply (memsem_preservesN _ HP) in H; trivial. Qed.

Lemma corestepN_fwd n  c m c' m'
   (CS:corestepN M g n c m c' m'): mem_forward m m'.
Proof.
eapply memsem_preservesN; try eassumption. apply mem_forward_preserve.
Qed.

Lemma corestep_plus_fwd c m c' m'
   (CS:corestep_plus M g c m c' m'): mem_forward m m'.
Proof.
destruct CS. eapply corestepN_fwd; eassumption.
Qed.

Lemma corestep_star_fwd c m c' m'
   (CS:corestep_star M g c m c' m'): mem_forward m m'.
Proof.
destruct CS. eapply corestepN_fwd; eassumption.
Qed.

Lemma corestepN_rdonly n c m c' m'
    (CS:corestepN M g n c m c' m') b (VB:Mem.valid_block m b): readonly m b m'.
Proof.
eapply (memsem_preservesN _ readonly_preserve'); eassumption.
Qed.

Lemma corestep_plus_rdonly c m c' m'
   (CS:corestep_plus M g c m c' m') b (VB:Mem.valid_block m b): readonly m b m'.
Proof.
destruct CS. eapply corestepN_rdonly; eassumption.
Qed.

Lemma corestep_star_rdonly c m c' m'
   (CS:corestep_star M g c m c' m')b (VB:Mem.valid_block m b): readonly m b m'.
Proof.
destruct CS. eapply corestepN_rdonly; eassumption.
Qed.

End memstepN.


From Hammer Require Import Hammer.

Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Structure.Bicartesian.
Require Export Category.Structure.Cartesian.Closed.
Require Export Category.Structure.Distributive.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Section BiCCC.

Context {C : Category}.
Context `{@Cartesian C}.
Context `{@Cocartesian C}.
Context `{@Closed C _}.

Global Program Instance prod_coprod_l {x y z : C} :

(y + z) × x ≅ y × x + z × x := {
to   := uncurry (curry inl ▽ curry inr);
from := first inl ▽ first inr
}.
Next Obligation.
rewrite <- !merge_comp.
rewrite <- eval_first.
rewrite <- !comp_assoc.
rewrite <- !first_comp; cat.
Qed.
Next Obligation.
rewrite uncurry_comp_r.
apply curry_inj.
rewrite curry_uncurry.
rewrite <- merge_comp.
rewrite <- !curry_comp; cat.
rewrite <- !curry_id.
rewrite merge_comp; cat.
Qed.

Hint Rewrite @prod_coprod_l : isos.

Lemma uncurry_merge {x y z w : C} (f : x ~> y^z) (g : w ~> y^z) :
uncurry (f ▽ g) ≈ uncurry f ▽ uncurry g ∘ to prod_coprod_l.
Proof. hammer_hook "BiCCC" "BiCCC.uncurry_merge".
simpl.
apply curry_inj; cat.
rewrite curry_comp; cat.
rewrite <- merge_comp.
apply merge_inv; split;
rewrite <- curry_comp; cat.
Qed.

Corollary unmerge_uncurry {x y z w : C} (f : x ~> y^z) (g : w ~> y^z) :
uncurry f ▽ uncurry g ≈ uncurry (f ▽ g) ∘ from prod_coprod_l.
Proof. hammer_hook "BiCCC" "BiCCC.unmerge_uncurry".
rewrite uncurry_merge.
rewrite <- comp_assoc.
rewrite iso_to_from; cat.
Qed.

Global Program Instance prod_coprod_r {x y z : C} :

x × (y + z) ≅ x × y + x × z := {
to   := uncurry (curry (inl ∘ swap) ▽ curry (inr ∘ swap)) ∘ swap;
from := second inl ▽ second inr
}.
Next Obligation.
rewrite <- !comp_assoc.
rewrite <- !merge_comp.
rewrite <- eval_first.
rewrite <- !comp_assoc.
rewrite !swap_second.
rewrite !(comp_assoc (first _)).
rewrite <- !first_comp; cat.
rewrite !(comp_assoc eval).
rewrite !eval_first; cat.
rewrite <- !comp_assoc; cat.
Qed.
Next Obligation.
rewrite uncurry_merge. simpl.
rewrite !comp_assoc; cat.
rewrite <- merge_comp.
rewrite !comp_assoc; cat.
rewrite <- !swap_first.
rewrite merge_comp.
rewrite <- !comp_assoc.
apply swap_inj_l, swap_inj_r.
rewrite comp_assoc.
rewrite swap_invol, id_left, id_right.
rewrite <- !comp_assoc.
rewrite swap_invol, id_right.
rewrite uncurry_comp_r.
rewrite <- merge_comp.
apply curry_inj.
rewrite curry_uncurry.
rewrite <- !curry_comp; cat.
rewrite <- !curry_id.
rewrite merge_comp; cat.
Qed.

Hint Rewrite @prod_coprod_r : isos.

Global Program Instance exp_coprod {x y z : C} :
x^(y + z) ≅ x^y × x^z := {
to   := curry (eval ∘ second inl) △ curry (eval ∘ second inr);
from := curry (uncurry exl ▽ uncurry exr ∘ to prod_coprod_r)
}.
Next Obligation.
rewrite <- fork_comp.
rewrite <- fork_exl_exr.
apply fork_inv; split;
rewrite curry_comp_l;
rewrite <- comp_assoc;
rewrite <- first_second;
rewrite comp_assoc;
rewrite eval_first;
rewrite uncurry_curry;
rewrite <- !comp_assoc;
rewrite swap_second;
rewrite curry_comp;
rewrite <- !eval_first;
rewrite <- comp_assoc;
rewrite (comp_assoc (first _));
rewrite <- first_comp; cat;
rewrite !eval_first;
rewrite (comp_assoc eval);
rewrite !eval_first; cat;
rewrite <- comp_assoc; cat;
rewrite <- curry_comp; cat.
Qed.
Next Obligation.
remember (_ △ _) as p.
enough (∀ {w : C} (f g : w ~> x^(y + z)), p ∘ f ≈ p ∘ g -> f ≈ g) as HA.
apply HA.
rewrite comp_assoc.
rewrite Heqp.
rewrite exp_coprod_obligation_1; cat.
intros ??? e.
rewrite Heqp in e.
rewrite <- !fork_comp in e.
apply fork_inv in e.
destruct e as [HA HB].
rewrite !curry_comp_l in HA.
rewrite !curry_comp_l in HB.
apply curry_inj in HA.
apply curry_inj in HB.
rewrite <- !comp_assoc in HA.
rewrite <- !comp_assoc in HB.
rewrite <- !first_second in HA.
rewrite <- !first_second in HB.
rewrite !comp_assoc in HA.
rewrite !comp_assoc in HB.
apply uncurry_inj.
rewrite <- !eval_first.
enough (∀ {w : C} (f g : w × (y + z) ~> x),
f ∘ second inl ≈ g ∘ second inl ->
f ∘ second inr ≈ g ∘ second inr -> f ≈ g) as HC.
exact (HC _ _ _ HA HB).
intros ? h i HD HE.
unfold second in HD, HE.
rewrite <- id_right.
rewrite <- (id_right i).
rewrite <- (iso_from_to prod_coprod_r).
simpl.
rewrite !comp_assoc.
rewrite <- !merge_comp.
rewrites.
reflexivity.
Qed.

Hint Rewrite @exp_coprod : isos.

Context `{@Initial C}.

Global Program Instance prod_zero_l {x : C} :
0 × x ≅ 0 := {
to   := uncurry zero;
from := zero
}.
Next Obligation. apply curry_inj; simpl; cat. Qed.

Hint Rewrite @prod_zero_l : isos.

Global Program Instance prod_zero_r {x : C} :
x × 0 ≅ 0 := {
to   := uncurry zero ∘ swap;
from := zero
}.
Next Obligation. apply swap_inj_r, curry_inj; simpl; cat. Qed.

Hint Rewrite @prod_zero_r : isos.

Context `{@Terminal C}.

Global Program Instance exp_zero {x : C} :
x^0 ≅ 1 := {
to   := one;
from := curry (zero ∘ to prod_zero_r)
}.
Next Obligation.
apply uncurry_inj.
apply swap_inj_r.
apply curry_inj; simpl; cat.
Qed.

End BiCCC.

Program Instance BiCCC_Distributive {C : Category}
`{@Cartesian C} `{@Cocartesian C} `{@Closed C _} `{@Initial C} :
@Distributive C _ _ _.


Require Import Mtac2.Mtac2.

Goal True.
MProof.
  (M.evar nat;; M.evar bool;; M.ret _)%MC. (* FIXME: why are all evars shelved when we do this in the tactic monad? *)
  Unshelve.
  M.ret _.
  Unshelve.
  M.ret _.
  Unshelve.
  M.ret true.
  Unshelve.
  M.ret I.
  M.ret 0.
Qed.

Definition ThrowANat (n : nat) : Exception. exact exception. Qed.
Definition test n : M nat :=
  mmatch n with
  | [? n'] S n' => M.raise (ThrowANat n')
  | _ => M.ret 0
  end.

Goal True.
MProof.
  M.mtry' (test 1;; M.ret I) (fun _=> M.ret I).
Qed.

Goal {n:nat| n = n}.
MProof.
  (mtry test 1;; M.raise exception
  with [? n'] ThrowANat n' => M.ret (exist _ n' _) end)%MC.
Abort.

Goal {n:nat| n = n}.
MProof.
  (mmatch 2 + 4 with
  | [? n] n + n => M.ret (exist _ (n + n) eq_refl)
  | [? n] n + n => M.ret (exist _ (n + n) eq_refl)
  | [? n] n + n => M.ret (exist _ (n + n) eq_refl)
  | [? n] n + n => M.ret (exist _ (n + n) eq_refl)
  | [? n m] n + m => M.ret (exist (fun n=>n=n) (n + m) eq_refl)
  end)%MC.
Qed.


Require Import Ctl.Paths.
Require Import Ctl.Definition.
Require Import Ctl.Basic.
Open Scope tprop_scope.

Require Import Setoid.
Require Import Glib.Glib.

Ltac tentails :=
  match goal with
  | |- ?R @?s ⊨ ⟨?P⟩ => change_no_check (P s)
  end.

Tactic Notation "tentails!" :=
  cbn;
  repeat match goal with
  | |- ?R @?s ⊨ ?P => unfold P
  end;
  change_no_check (?R @?s ⊨ ⟨?P⟩) with (P s);
  cbn.

Tactic Notation "tentails" "in" hyp(H) :=
  change (?R @?s ⊨ ⟨?P⟩) with (P s) in H.

Tactic Notation "tentails!" "in" hyp(H) :=
  cbn in H;
  repeat match type of H with
  | ?R @?s ⊨ ?P => unfold P in H
  end;
  progress change (?R @?s ⊨ ⟨?P⟩) with (P s) in H;
  cbn in H.

Tactic Notation "tentails" "in" "*" :=
  tentails;
  repeat match goal with
  | H : _ |- _ => tentails in H
  end.

Tactic Notation "tentails!" "in" "*" :=
  tentails!;
  repeat match goal with
  | H : _ |- _ => tentails! in H
  end.

(*
Tactic Notation "unfold_timpl" :=
  progress change_no_check (?R @?s ⊨ ?p ⟶ ?q) with (R @s ⊨ p -> R @s ⊨ q).
Tactic Notation "unfold_timpl" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ ?p ⟶ ?q) with (R @s ⊨ p -> R @s ⊨ q) in H.

Tactic Notation "unfold_tnot" :=
  progress change_no_check (?R @?s ⊨ ¬?P) with (R @s ⊭ P).
Tactic Notation "unfold_tnot" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ ¬?P) with (R @s ⊭ P) in H.

Tactic Notation "unfold_tconj" :=
  progress change_no_check (?R @?s ⊨ ?P ∧ ?Q) with (R @s ⊨ P /\ R @s ⊨ Q).
Tactic Notation "unfold_tconj" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ ?P ∧ ?Q) with (R @s ⊨ P /\ R @s ⊨ Q) in H.

Tactic Notation "unfold_tbiimpl" :=
  progress change_no_check (?R @?s ⊨ ?P ⟷ ?Q) with (R @s ⊨ P <-> R @s ⊨ Q).
Tactic Notation "unfold_tbiimpl" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ ?P ⟷ ?Q) with (R @s ⊨ P <-> R @s ⊨ Q) in H.

Tactic Notation "unfold_AX" :=
  progress change_no_check (?R @?s ⊨ AX ?P) with (forall s', R s s' -> R @s' ⊨ P).
Tactic Notation "unfold_AX" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ AX ?P) with (forall s', R s s' -> R @s' ⊨ P) in H.

Tactic Notation "unfold_AG" :=
  progress change_no_check (?R @?s ⊨ AG ?P) with
    (forall n (p: path R n s) s', in_path s' p -> R @s' ⊨ P).
Tactic Notation "unfold_AG" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ AG ?P) with
    (forall n (p: path R n s) s', in_path s' p -> R @s' ⊨ P) in H.
*)

Tactic Notation "unfold_timpl" :=
  progress change_no_check (?R @?s ⊨ ?p ⟶ ?q) with (R @s ⊨ p -> R @s ⊨ q) +
  rewrite rew_timpl +
  setoid_rewrite rew_timpl.
Tactic Notation "unfold_timpl" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ ?p ⟶ ?q) with (R @s ⊨ p -> R @s ⊨ q) in H +
  rewrite rew_timpl in H +
  setoid_rewrite rew_timpl in H.

Tactic Notation "unfold_tnot" :=
  progress change_no_check (?R @?s ⊨ ¬?P) with (R @s ⊭ P) +
  rewrite rew_tnot +
  setoid_rewrite rew_tnot.
Tactic Notation "unfold_tnot" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ ¬?P) with (R @s ⊭ P) in H +
  rewrite rew_tnot in H +
  setoid_rewrite rew_tnot in H.

Tactic Notation "unfold_tconj" :=
  progress change_no_check (?R @?s ⊨ ?P ∧ ?Q) with (R @s ⊨ P /\ R @s ⊨ Q) +
  rewrite rew_tconj +
  setoid_rewrite rew_tconj.
Tactic Notation "unfold_tconj" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ ?P ∧ ?Q) with (R @s ⊨ P /\ R @s ⊨ Q) in H +
  rewrite rew_tconj in H +
  setoid_rewrite rew_tconj in H.

Tactic Notation "unfold_tdisj" :=
  progress change_no_check (?R @?s ⊨ ?P ∨ ?Q) with (R @s ⊨ P \/ R @s ⊨ Q) +
  rewrite rew_tdisj +
  setoid_rewrite rew_tdisj.
Tactic Notation "unfold_tdisj" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ ?P ∨ ?Q) with (R @s ⊨ P ∨ R @s ⊨ Q) in H +
  rewrite rew_tdisj in H +
  setoid_rewrite rew_tdisj in H.

Tactic Notation "unfold_tbiimpl" :=
  progress change_no_check (?R @?s ⊨ ?P ⟷ ?Q) with (R @s ⊨ P <-> R @s ⊨ Q) +
  rewrite rew_tbiimpl +
  setoid_rewrite rew_tbiimpl.
Tactic Notation "unfold_tbiimpl" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ ?P ⟷ ?Q) with (R @s ⊨ P <-> R @s ⊨ Q) in H +
  rewrite rew_tbiimpl in H +
  setoid_rewrite rew_tbiimpl in H.

Tactic Notation "unfold_tlift" :=
  progress change_no_check (?R @?s ⊨ ⟨?P⟩) with (P s) +
  rewrite rew_tlift +
  setoid_rewrite rew_tlift.
Tactic Notation "unfold_tlift" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ ⟨?P⟩) with (P s) in H +
  rewrite rew_tlift in H +
  setoid_rewrite rew_tlift in H.

Tactic Notation "unfold_AX" :=
  progress change_no_check (?R @?s ⊨ AX ?P) with (forall s', R s s' -> R @s' ⊨ P) +
  rewrite rew_AX +
  setoid_rewrite rew_AX.
Tactic Notation "unfold_AX" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ AX ?P) with (forall s', R s s' -> R @s' ⊨ P) in H +
  rewrite rew_AX in H +
  setoid_rewrite rew_AX in H.

Tactic Notation "unfold_EX" :=
  progress change_no_check (?R @?s ⊨ EX ?P) with (exists s', R s s' /\ R @s' ⊨ P) +
  rewrite rew_EX +
  setoid_rewrite rew_EX.
Tactic Notation "unfold_EX" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ EX ?P) with (exists s', R s s' /\ R @s' ⊨ P) in H +
  rewrite rew_EX in H +
  setoid_rewrite rew_EX in H.

Tactic Notation "unfold_AG" :=
  progress change_no_check (?R @?s ⊨ AG ?P) with
    (forall (p: path R s) s', in_path s' p -> R @s' ⊨ P) +
  rewrite rew_AG +
  setoid_rewrite rew_AG.
Tactic Notation "unfold_AG" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ AG ?P) with
    (forall (p: path R s) s', in_path s' p -> R @s' ⊨ P) in H +
  rewrite rew_AG in H +
  setoid_rewrite rew_AG in H.

Tactic Notation "unfold_EG" :=
  progress change_no_check (?R @?s ⊨ EG ?P) with
    (exists p: path R s, forall s', in_path s' p -> R @s' ⊨ P) +
  rewrite rew_EG +
  setoid_rewrite rew_EG.
Tactic Notation "unfold_EG" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ EG ?P) with
    (exists p: path R s, forall s', in_path s' p -> R @s' ⊨ P) in H +
  rewrite rew_EG in H +
  setoid_rewrite rew_EG in H.

Tactic Notation "unfold_AF" :=
  progress change_no_check (?R @?s ⊨ AF ?P) with
    (forall p: path R s, exists s', in_path s' p /\ R @s' ⊨ P) +
  rewrite rew_AF +
  setoid_rewrite rew_AF.
Tactic Notation "unfold_AF" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ AF ?P) with
    (forall p: path R s, exists s', in_path s' p /\ R @s' ⊨ P) in H +
  rewrite rew_AF in H +
  setoid_rewrite rew_AF in H.

Tactic Notation "unfold_EF" :=
  progress change_no_check (?R @?s ⊨ EF ?P) with
    (exists (p: path R s) s', in_path s' p /\ R @s' ⊨ P) +
  rewrite rew_EF +
  setoid_rewrite rew_EF.
Tactic Notation "unfold_EF" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ EF ?P) with
    (exists (p: path R s) s', in_path s' p /\ R @s' ⊨ P) in H +
  rewrite rew_EF in H +
  setoid_rewrite rew_EF in H.

Tactic Notation "unfold_AU" :=
  progress change_no_check (?R @?s ⊨ A[?P U ?Q]) with
    (forall p: path R s, exists sQ i,
      in_path_at sQ i p /\
      (forall sP, in_path_before sP i p -> R @sP ⊨ P) /\
      R @sQ ⊨ Q) +
  rewrite rew_AU +
  setoid_rewrite rew_AU.
Tactic Notation "unfold_AU" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ A[?P U ?Q]) with
    (forall p: path R s, exists sQ i,
      in_path_at sQ i p /\
      (forall sP, in_path_before sP i p -> R @sP ⊨ P) /\
      R @sQ ⊨ Q) in H +
  rewrite rew_AU in H +
  setoid_rewrite rew_AU in H.

Tactic Notation "unfold_EU" :=
  progress change_no_check (?R @?s ⊨ E[?P U ?Q]) with
    (exists (p: path R s) sQ i,
      in_path_at sQ i p /\
      (forall sP, in_path_before sP i p -> R @sP ⊨ P) /\
      R @sQ ⊨ Q) +
  rewrite rew_EU +
  setoid_rewrite rew_EU.
Tactic Notation "unfold_EU" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ E[?P U ?Q]) with
    (exists (p: path R s) sQ i,
      in_path_at sQ i p /\
      (forall sP, in_path_before sP i p -> R @sP ⊨ P) /\
      R @sQ ⊨ Q) in H +
  rewrite rew_EU in H +
  setoid_rewrite rew_EU in H.

Tactic Notation "unfold_AW" :=
  progress change_no_check (?R @?s ⊨ A[?P W ?Q]) with
    (forall p: path R s,
      (forall s', in_path s' p -> R @s' ⊨ P ∧ ¬Q) \/
      (exists sQ i,
        in_path_at sQ i p /\
        (forall sP, in_path_before sP i p -> R @sP ⊨ P) /\
        R @sQ ⊨ Q)) +
  rewrite rew_AW +
  setoid_rewrite rew_AW.
Tactic Notation "unfold_AW" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ A[?P W ?Q]) with
    (forall p: path R s,
      (forall s', in_path s' p -> R @s' ⊨ P ∧ ¬Q) \/
      (exists sQ i,
        in_path_at sQ i p /\
        (forall sP, in_path_before sP i p -> R @sP ⊨ P) /\
        R @sQ ⊨ Q)) in H +
  rewrite rew_AW in H +
  setoid_rewrite rew_AW in H.

(* tintro - intro a timpl *)

Tactic Notation "tintro" :=
  match goal with
  | |- _ @_ ⊨ ¬_ => unfold_tnot; intro
  | |- _ @_ ⊨ _ ⟶ _ => unfold_timpl; intro
  end.

Tactic Notation "tintro" ident(x) :=
  match goal with
  | |- _ @_ ⊨ ¬_ => unfold_tnot; intro x
  | |- _ @_ ⊨ _ ⟶ _ => unfold_timpl; intro x
  end.

Tactic Notation "tintros" :=
  repeat tintro.
Tactic Notation "tintros" ident(x1) :=
  tintro x1.
Tactic Notation "tintros" ident(x1) ident(x2) :=
  tintro x1; tintros x2.
Tactic Notation "tintros" ident(x1) ident(x2) ident(x3) :=
  tintro x1; tintros x2 x3.
Tactic Notation "tintros" ident(x1) ident(x2) ident(x3) ident(x4) :=
  tintro x1; tintros x2 x3 x4.
Tactic Notation "tintros" ident(x1) ident(x2) ident(x3) ident(x4) ident(x5) :=
  tintro x1; tintros x2 x3 x4 x5.
Tactic Notation "tintros" ident(x1) ident(x2) ident(x3) ident(x4) ident(x6) :=
  tintro x1; tintros x2 x3 x4 x5 x6.

(* tsimpl - simple a tprop *)

Tactic Notation "tsimpl_step" :=
  unfold_timpl +
  unfold_tbiimpl +
  unfold_tnot +
  unfold_AX +
  unfold_EX +
  unfold_AG +
  unfold_EG +
  unfold_AF +
  unfold_EF +
  unfold_AU +
  unfold_EU +
  unfold_AW.

Tactic Notation "tsimpl_step" "in" hyp(H) :=
  unfold_timpl in H +
  unfold_tbiimpl in H +
  unfold_tnot in H +
  unfold_AX in H +
  unfold_EX in H +
  unfold_AG in H +
  unfold_EG in H +
  unfold_AF in H +
  unfold_EF in H +
  unfold_AU in H +
  unfold_EU in H +
  unfold_AW in H.

Tactic Notation "tsimpl" := repeat tsimpl_step.
Tactic Notation "tsimpl" "in" hyp(H) := repeat tsimpl_step in H.
Tactic Notation "tsimpl" "in" "*" :=
  try tsimpl;
  repeat match goal with
  | H: _ @_ ⊨ _ |- _ => tsimpl in H
  end.

(* tapply: carefully unfolds TProp hypothesis just enough to use apply *)

Ltac _tapply_unfold_step H :=
  match type of H with
  | _ @_ ⊨ _ ⟶ _ =>
      unfold_timpl in H
  | _ @_ ⊨ ¬ _ =>
      unfold_tnot in H
  | _ @_ ⊨ _ ⟷ _ =>
      unfold_tbiimpl in H
  | _ @_ ⊨ AX _ =>
      unfold_AX in H
  | _ @_ ⊨ AG _ =>
      unfold_AG in H
  end +
  unfold_timpl in H +
  unfold_tnot in H +
  unfold_tbiimpl in H +
  unfold_AX in H +
  unfold_AG in H.

Ltac _tapply_aux H :=
  apply H + (_tapply_unfold_step H; _tapply_aux H).

Ltac _tapply_aux_in H H2 :=
  apply H in H2 + (_tapply_unfold_step H; _tapply_aux_in H H2).

Ltac _etapply_aux H :=
  eapply H + (_tapply_unfold_step H; _etapply_aux H).

Ltac _etapply_aux_in H H2 :=
  eapply H in H2 + (_tapply_unfold_step H; _etapply_aux_in H H2).

Tactic Notation "tapply" uconstr(c) :=
  let Htemp := fresh in
  eset (Htemp := c);
  _tapply_aux Htemp;
  clear Htemp.

Tactic Notation "tapply" uconstr(c) "in" hyp(H) :=
  let Htemp := fresh in
  eset (Htemp := c);
  _tapply_aux_in Htemp H;
  clear Htemp.

Tactic Notation "etapply" uconstr(c) :=
  let Htemp := fresh in
  eset (Htemp := c);
  _etapply_aux Htemp;
  clear Htemp.

Tactic Notation "etapply" uconstr(c) "in" hyp(H) :=
  let Htemp := fresh in
  eset (Htemp := c);
  _etapply_aux_in Htemp H;
  clear Htemp.

Tactic Notation "tapplyc" hyp(H) :=
  tapply H; clear H.
Tactic Notation "tapplyc" hyp(H) "in" hyp(H2) :=
  tapply H in H2; clear H.
Tactic Notation "etapplyc" hyp(H) :=
  etapply H; clear H.
Tactic Notation "etapplyc" hyp(H) "in" hyp(H2) :=
  etapply H in H2; clear H.

Close Scope tprop_scope.


(*
 * 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 Equivalence.
Require Import Morphisms.
Require Import Setoid.
Require Import EquivDec.
Require Import Program.
Require Import String.
Require Import List.
Require Import Arith.
Require Import Utils.
Require Import DataRuntime.
Require Import DData.
Require Import DDataNorm.
Require Import DNNRCBase.

Section DNNRCBaseEq.
  Context {fruntime:foreign_runtime}.
  Context {A plug_type:Set}.
  Context {eqdec:EqDec A eq}.
  Context {plug:AlgPlug plug_type}.

  (** Equivalence between expressions in the
      Distributed Nested Relational Calculus *)

  Definition dnnrc_base_eq (e1 e2:@dnnrc_base _ A plug_type) : Prop :=
    forall (h:brand_relation_t) (dcenv denv:dbindings),
      Forall (ddata_normalized h) (map snd dcenv) ->
      Forall (ddata_normalized h) (map snd denv) ->
      dnnrc_base_eval h dcenv denv e1 = dnnrc_base_eval h dcenv denv e2.

  Global Instance dnnrc_base_equiv : Equivalence dnnrc_base_eq.
  Proof.
    constructor.
    - unfold Reflexive, dnnrc_base_eq.
      intros; reflexivity.
    - unfold Symmetric, dnnrc_base_eq.
      intros; rewrite (H _ dcenv denv) by trivial; reflexivity.
    - unfold Transitive, dnnrc_base_eq.
      intros; rewrite (H _ dcenv denv) by trivial;
      rewrite (H0 _ dcenv denv) by trivial; reflexivity.
  Qed.

  (* all the dnnrc_base constructors are proper wrt. equivalence *)

  (* DNNRCGetConstant *)
  Global Instance dgetconstant_proper : Proper (eq ==> eq ==> dnnrc_base_eq) DNNRCGetConstant.
  Proof.
    unfold Proper, respectful, dnnrc_base_eq.
    intros; subst; reflexivity.
  Qed.

  (* DNNRCVar *)
  Global Instance dvar_proper : Proper (eq ==> eq ==> dnnrc_base_eq) DNNRCVar.
  Proof.
    unfold Proper, respectful, dnnrc_base_eq.
    intros; subst; reflexivity.
  Qed.

  (* DNNRCConst *)

  Global Instance dconst_proper : Proper (eq ==> eq ==> dnnrc_base_eq) DNNRCConst.
  Proof.
    unfold Proper, respectful, dnnrc_base_eq.
    intros; subst; reflexivity.
  Qed.

  (* DNNRCBinop *)

  Global Instance dbinary_op_proper : Proper (eq ==> binary_op_eq ==> dnnrc_base_eq ==> dnnrc_base_eq ==> dnnrc_base_eq) DNNRCBinop.
  Proof.
    unfold Proper, respectful, dnnrc_base_eq.
    intros; simpl. subst.
    rewrite H1 by trivial.
    rewrite H2 by trivial.
    case_eq (dnnrc_base_eval h dcenv denv y1);
      case_eq (dnnrc_base_eval h dcenv denv y2); intros; simpl; trivial.
    destruct d0; destruct d; try reflexivity; simpl.
    rewrite H0; [reflexivity| | ].
    apply (dnnrc_base_eval_normalized_local h dcenv denv y1); try assumption.
    apply (dnnrc_base_eval_normalized_local h dcenv denv y1); try assumption.
  Qed.

  (* DNNRCUnnop *)

  Global Instance dunary_op_proper : Proper (eq ==> unary_op_eq ==> dnnrc_base_eq ==> dnnrc_base_eq) DNNRCUnop.
  Proof.
    unfold Proper, respectful, dnnrc_base_eq.
    intros; simpl. subst.
    rewrite H1 by trivial.
    case_eq (dnnrc_base_eval h dcenv denv y1); simpl; trivial; intros.
    destruct d; try reflexivity; simpl.
    rewrite H0; [reflexivity| ].
    apply (dnnrc_base_eval_normalized_local h dcenv denv y1); try assumption.
  Qed.

  (* DNNRCLet *)

  Global Instance dlet_proper : Proper (eq ==> eq ==> dnnrc_base_eq ==> dnnrc_base_eq ==> dnnrc_base_eq) DNNRCLet.
  Proof.
    unfold Proper, respectful, dnnrc_base_eq.
    intros; simpl. rewrite H0; clear H0; rewrite H1 by trivial; clear H1.
    case_eq (dnnrc_base_eval h dcenv denv y1); simpl; trivial; intros.
    rewrite H2; eauto.
    constructor; eauto.
    simpl.
    eapply (dnnrc_base_eval_normalized h dcenv denv y1); eauto.
  Qed.

  (* DNNRCFor *)

  Hint Resolve data_normalized_dcoll_in : qcert.

  Global Instance dfor_proper : Proper (eq ==> eq ==> dnnrc_base_eq ==> dnnrc_base_eq ==> dnnrc_base_eq) DNNRCFor.
  Proof.
    unfold Proper, respectful, dnnrc_base_eq.
    intros; simpl. rewrite H1 by trivial; clear H1. subst.
    case_eq (dnnrc_base_eval h dcenv denv y1); simpl; trivial; intros.
    destruct d; try reflexivity; simpl.
    { destruct d; try reflexivity; simpl.
      f_equal.
      apply lift_map_ext; intros.
      rewrite H2; simpl; eauto.
      constructor; [|assumption].
      assert (ddata_normalized h (Dlocal (dcoll l))).
      - eapply (dnnrc_base_eval_normalized _ dcenv denv); eauto.
      - inversion H1; subst; clear H1.
        econstructor.
        inversion H6; subst; clear H6.
        rewrite Forall_forall in H5.
        auto. }
    { f_equal.
      apply lift_map_ext; intros.
      rewrite H2; simpl; eauto.
      constructor; [|assumption].
      assert (ddata_normalized h (Ddistr l)).
      - eapply (dnnrc_base_eval_normalized _ dcenv denv); eauto.
      - inversion H1; subst; clear H1.
        constructor.
        rewrite Forall_forall in H6.
        auto. }
  Qed.

  (* DNNRCIf *)

  Global Instance dif_proper : Proper (eq ==> dnnrc_base_eq ==> dnnrc_base_eq ==> dnnrc_base_eq ==> dnnrc_base_eq) DNNRCIf.
  Proof.
    unfold Proper, respectful, dnnrc_base_eq.
    intros; simpl. subst. rewrite H0 by trivial; clear H0.
    case_eq (dnnrc_base_eval h dcenv denv y0); simpl; trivial; intros.
    destruct d; try reflexivity; simpl.
    destruct d; try reflexivity; simpl.
    destruct b; eauto.
  Qed.

  (* DNNRCEither *)
  Global Instance deither_proper : Proper (eq ==> dnnrc_base_eq ==> eq ==> dnnrc_base_eq ==> eq ==> dnnrc_base_eq ==> dnnrc_base_eq) DNNRCEither.
  Proof.
    unfold Proper, respectful, dnnrc_base_eq.
    intros; simpl. subst.
    rewrite H0 by trivial.
    match_case; intros ? eqq1. match_destr.
    - apply H2; simpl; eauto.
      rewrite Forall_forall; intros.
      inversion H; subst.
      unfold olift, checkLocal in eqq1.
      case_eq (dnnrc_base_eval h dcenv denv y0); intros; rewrite H1 in eqq1; try congruence;
      destruct d0; try congruence; inversion eqq1; subst.
      assert (ddata_normalized h (Dlocal (dleft d))).
      apply (@dnnrc_base_eval_normalized _ _ _ h dcenv _ denv y0); assumption.
      inversion H3; subst; clear H3.
      inversion H8; subst; clear H8.
      constructor; assumption.
      rewrite Forall_forall in H6. auto.
    - apply H4; simpl; eauto.
      rewrite Forall_forall; intros.
      inversion H; subst.
      unfold olift, checkLocal in eqq1.
      case_eq (dnnrc_base_eval h dcenv denv y0); intros; rewrite H1 in eqq1; try congruence;
      destruct d0; try congruence; inversion eqq1; subst.
      assert (ddata_normalized h (Dlocal (dright d))).
      apply (@dnnrc_base_eval_normalized _ _ _ h dcenv plug denv y0); assumption.
      inversion H3; subst; clear H3.
      inversion H8; subst; clear H8.
      constructor; assumption.
      rewrite Forall_forall in H6. auto.
  Qed.

  (* DNNRCGroupBy *)
  Global Instance dgroupby_proper : Proper (eq ==> eq ==> eq ==> dnnrc_base_eq ==>dnnrc_base_eq) DNNRCGroupBy.
  Proof.
    unfold Proper, respectful, dnnrc_base_eq.
    intros; simpl; subst.
    trivial.
  Qed.

  (* DNNRCCollect *)
  Global Instance dcollect_proper : Proper (eq ==> dnnrc_base_eq ==> dnnrc_base_eq) DNNRCCollect.
  Proof.
    unfold Proper, respectful, dnnrc_base_eq.
    intros; simpl. subst.
    rewrite H0 by trivial.
    reflexivity.
  Qed.

  (* DNNRCDispatch *)
  Global Instance ddispatch_proper : Proper (eq ==> dnnrc_base_eq ==> dnnrc_base_eq) DNNRCDispatch.
  Proof.
    unfold Proper, respectful, dnnrc_base_eq.
    intros; simpl. subst.
    rewrite H0 by trivial.
    reflexivity.
  Qed.

  Global Instance dalg_proper : Proper (eq ==> eq ==> Forall2 (fun n1 n2  => fst n1 = fst n2 /\ dnnrc_base_eq (snd n1) (snd n2)) ==> dnnrc_base_eq) DNNRCAlg.
  Proof.
    unfold Proper, respectful, dnnrc_base_eq.
    intros; simpl; subst.
    cut ((map
         (fun x : string * @dnnrc_base _ A plug_type =>
          match dnnrc_base_eval h dcenv denv (snd x) with
          | Some (Dlocal _) => None
          | Some (Ddistr coll) => Some (fst x, coll)
          | None => None
          end) x1) = (map
         (fun x : string * @dnnrc_base _ A plug_type =>
          match dnnrc_base_eval h dcenv denv (snd x) with
          | Some (Dlocal _) => None
          | Some (Ddistr coll) => Some (fst x, coll)
          | None => None
          end) y1)); [intros eqq; rewrite eqq; trivial | ].
    dependent induction H1; simpl; trivial.
    rewrite IHForall2 by trivial.
    destruct H as [eqq1 eqq2].
    rewrite eqq1, eqq2 by trivial.
    trivial.
  Qed.

End DNNRCBaseEq.

Notation "X ≡ᵈ Y" := (dnnrc_base_eq X Y) (at level 90) : dnnrc_scope.                             (* ≡ = \equiv *)