From VLSM.Lib Require Import Itauto.
From stdpp Require Import prelude finite.
From Coq Require Import FinFun RIneq.
From VLSM.Lib Require Import Preamble FinSetExtras.
From VLSM.Lib Require Import RealsExtras Measurable.
From VLSM.Core Require Import VLSM VLSMProjections MessageDependencies Composition Equivocation.
From VLSM.Core Require Import Equivocation.FixedSetEquivocation.
From VLSM.Core Require Import Equivocation.TraceWiseEquivocation.
From VLSM.Core Require Import Equivocation.WitnessedEquivocation.

(** * VLSM Limited Message Equivocation

  In this section we define the notion of limited (message-based) equivocation.

  This notion is slightly harder to define than that of fixed-set equivocation,
  because, while for the latter we fix a set and let only the nodes belonging to
  that set to equivocate, in the case of limited equivocation, the set of nodes
  equivocating can change dynamically, each node being virtually allowed to
  equivocate as long as the weight of all nodes currently equivocating does
  not pass a certain threshold.

  As we need to be able to measure the amount of equivocation in a given state
  to design a composition constraint preventing equivocation weight from passing
  the threshold, we need an appropriate measure of equivocation.
  We here choose [is_equivocating_tracewise] as this measure.

  Moreover, to further limit the amount of equivocation allowed when producing
  a message, we assume a full-node-like  condition to be satisfied by all nodes.
  This  guarantees that whenever a message not-previously send is received in a
  state, the amount of equivocation would only grow with the weight of the
  sender of the message (if that wasn't already known as an equivocator).
*)

Section sec_limited_message_equivocation.

Context
  {message : Type}
  `{EqDecision index}
  (IM : index -> VLSM message)
  (threshold : R)
  `{ReachableThreshold validator Cv threshold}
  (equivocating : composite_state IM -> validator -> Prop)
  (Hno_initial_equivocation :
    forall s, composite_initial_state_prop IM s ->
    forall v, ~ equivocating s v)
  .

Inductive LimitedEquivocationProp (s : composite_state IM) : Prop :=
| limited_equivocation :
    forall (vs : Cv)
      (Heqv_vs : forall v, equivocating s v -> v ∈ vs)
      (Hlimited : (sum_weights vs <= threshold)%R),
      LimitedEquivocationProp s.

Definition limited_equivocation_constraint
  (l : composite_label IM)
  (som : composite_state IM * option message)
  : Prop :=
  LimitedEquivocationProp (composite_transition IM l som).1.

Definition limited_equivocation_composite_vlsm : VLSM message :=
  composite_vlsm IM limited_equivocation_constraint.

Lemma limited_equivocation_valid_state s
  : valid_state_prop limited_equivocation_composite_vlsm s ->
    LimitedEquivocationProp s.
Proof.
  intros Hs; apply valid_state_prop_iff in Hs
    as [[[is His] ->] | (l & [s' om'] & om & [(_ & _ & _ & Hv) Ht])]; simpl.
  - exists ∅.
    + by intros v Hv; contradict Hv; apply Hno_initial_equivocation.
    + rewrite sum_weights_empty; [| done].
      by apply (rt_positive (H6 := H6)).
  - by cbv in Hv, Ht; rewrite Ht in Hv.
Qed.

End sec_limited_message_equivocation.

Section sec_basic_limited_message_equivocation.

Context
  {message : Type}
  `{EqDecision index}
  `{EqDecision validator}
  (IM : index -> VLSM message)
  `{BasicEquivocation (composite_state IM) validator}
  .

Definition basic_limited_equivocation_constraint :=
  limited_equivocation_constraint IM threshold is_equivocating (Cv := Cv).

Definition basic_limited_equivocation_composite_vlsm : VLSM message :=
  limited_equivocation_composite_vlsm IM threshold is_equivocating (Cv := Cv).

Lemma LimitedEquivocationProp_impl_not_heavy :
  forall s, LimitedEquivocationProp (Cv := Cv) IM threshold is_equivocating s -> not_heavy s.
Proof.
  intros s [].
  apply Rle_trans with (sum_weights vs); [| done].
  apply sum_weights_subseteq; intros v Hv.
  apply elem_of_filter in Hv as [Hvsl Hvsr].
  by apply Heqv_vs, Hvsl.
Qed.

Definition basic_equivocation_state_validators_comprehensive_prop : Prop :=
  forall s v, is_equivocating s v -> v ∈ state_validators s.

Lemma not_heavy_impl_LimitedEquivocationProp
  (Hcomprehensive : basic_equivocation_state_validators_comprehensive_prop)
  : forall s, not_heavy s -> LimitedEquivocationProp (Cv := Cv) IM threshold is_equivocating s.
Proof.
  intros s Hs.
  exists (equivocating_validators s); [| done].
  intros v Hv; apply elem_of_filter.
  split; [done |].
  by apply Hcomprehensive.
Qed.

End sec_basic_limited_message_equivocation.

Section sec_tracewise_limited_message_equivocation.

Context
  {message index : Type}
  (IM : index -> VLSM message)
  (threshold : R)
  `{EqDecision index}
  `{forall i, HasBeenSentCapability (IM i)}
  `{forall i, HasBeenReceivedCapability (IM i)}
  (Free := free_composite_vlsm IM)
  `{finite.Finite validator}
  `{ReachableThreshold validator Cv threshold}
  (A : validator -> index)
  (sender : message -> option validator)
  `{RelDecision _ _ (is_equivocating_tracewise_no_has_been_sent IM A sender)}
  (Htracewise_BasicEquivocation : BasicEquivocation (composite_state IM) validator Cv threshold
    := equivocation_dec_tracewise IM threshold A sender)
  .

Existing Instance Htracewise_BasicEquivocation.

Lemma tracewise_basic_equivocation_state_validators_comprehensive_prop :
  basic_equivocation_state_validators_comprehensive_prop IM.
Proof. by intros s v _; cbn; apply elem_of_list_to_set, elem_of_enum. Qed.

Definition tracewise_limited_equivocation_constraint :=
  basic_limited_equivocation_constraint IM.

Definition tracewise_limited_equivocation_vlsm_composition : VLSM message :=
  basic_limited_equivocation_composite_vlsm IM.

Lemma full_node_limited_equivocation_valid_state_weight s
  : valid_state_prop tracewise_limited_equivocation_vlsm_composition s ->
    LimitedEquivocationProp (Cv := Cv) IM threshold is_equivocating s.
Proof.
  eapply limited_equivocation_valid_state; [done |].
  by intros; apply initial_state_not_is_equivocating_tracewise.
Qed.

Lemma tracewise_not_heavy_LimitedEquivocationProp_iff :
  forall s, not_heavy s <-> LimitedEquivocationProp (Cv := Cv) IM threshold is_equivocating s.
Proof.
  intros; split.
  - by apply not_heavy_impl_LimitedEquivocationProp,
      tracewise_basic_equivocation_state_validators_comprehensive_prop.
  - by apply LimitedEquivocationProp_impl_not_heavy.
Qed.

End sec_tracewise_limited_message_equivocation.

Section sec_fixed_limited_message_equivocation.

(** ** Fixed Message Equivocation implies Limited Message Equivocation

  In this section we show that if the set of allowed equivocators for a fixed
  equivocation constraint is of weight smaller than the threshold accepted for
  limited message equivocation, then any valid trace for the fixed equivocation
  constraint is also a trace under the limited equivocation constraint.
*)

Context
  {message index : Type}
  (IM : index -> VLSM message)
  (threshold : R)
  `{FinSet index Ci}
  `{!finite.Finite index}
  `{forall i, HasBeenSentCapability (IM i)}
  `{forall i, HasBeenReceivedCapability (IM i)}
  (Free := free_composite_vlsm IM)
  `{finite.Finite validator}
  `{ReachableThreshold validator Cv threshold}
  (A : validator -> index)
  `{! Inj (=) (=) A}
  (sender : message -> option validator)
  (eqv_validators : Cv)
  (equivocators := fin_sets.set_map A eqv_validators : Ci)
  (Hlimited : (sum_weights eqv_validators <= threshold)%R )
  (Hsender_safety : sender_safety_alt_prop IM A sender)
  `{RelDecision _ _ (is_equivocating_tracewise_no_has_been_sent IM A sender)}
  (Fixed := fixed_equivocation_vlsm_composition IM equivocators)
  (StrongFixed := strong_fixed_equivocation_vlsm_composition IM equivocators)
  (PreFree := pre_loaded_with_all_messages_vlsm Free)
  (Limited : VLSM message := tracewise_limited_equivocation_vlsm_composition (Cv := Cv) IM threshold A sender)
  (Htracewise_BasicEquivocation : BasicEquivocation (composite_state IM) validator Cv threshold
    := equivocation_dec_tracewise IM threshold A sender)
  (tracewise_not_heavy := not_heavy (1 := Htracewise_BasicEquivocation))
  (tracewise_equivocating_validators := equivocating_validators (1 := Htracewise_BasicEquivocation))
  .

Lemma StrongFixed_valid_state_not_heavy s
  (Hs : valid_state_prop StrongFixed s)
  : tracewise_not_heavy s.
Proof.
  cut (tracewise_equivocating_validators s ⊆ eqv_validators).
  {
    intro Hincl; unfold tracewise_not_heavy, not_heavy.
    by etransitivity; [apply sum_weights_subseteq |].
  }
  assert (StrongFixedinclPreFree : VLSM_incl StrongFixed PreFree).
  {
    apply VLSM_incl_trans with (machine Free).
    - by apply (constraint_free_incl IM (strong_fixed_equivocation_constraint IM equivocators)).
    - by apply vlsm_incl_pre_loaded_with_all_messages_vlsm.
  }
  apply valid_state_has_trace in Hs as [is [tr Htr]].
  apply (VLSM_incl_finite_valid_trace_init_to StrongFixedinclPreFree) in Htr as Hpre_tr.
  intros v Hv.
  apply equivocating_validators_is_equivocating_tracewise_iff in Hv as Hvs'.
  specialize (Hvs' _ _ Hpre_tr).
  destruct Hvs' as [m0 [Hsender0 [pre [item [suf [Heqtr [Hm0 Heqv]]]]]]].
  rewrite Heqtr in Htr.
  destruct Htr as [Htr Hinit].
  change (pre ++ item :: suf) with (pre ++ [item] ++ suf) in Htr.
  apply (finite_valid_trace_from_to_app_split StrongFixed) in Htr.
  destruct Htr as [Hpre Hitem].
  apply (VLSM_incl_finite_valid_trace_from_to StrongFixedinclPreFree) in Hpre as Hpre_pre.
  apply valid_trace_last_pstate in Hpre_pre as Hs_pre.
  apply (finite_valid_trace_from_to_app_split StrongFixed), proj1 in Hitem.
  inversion Hitem; subst; clear Htl Hitem. simpl in Hm0. subst.
  destruct Ht as [(_ & _ & _ & Hc) _].
  destruct Hc as [(i & Hi & Hsenti) | Hemit].
  + assert (Hsent : composite_has_been_sent IM (finite_trace_last is pre) m0)
      by (exists i; done).
    apply (composite_proper_sent IM) in Hsent; [| done].
    by specialize (Hsent _ _ (conj Hpre_pre Hinit)).
  + apply (SubProjectionTraces.sub_can_emit_sender IM (elements equivocators)
      A sender Hsender_safety _ _ v), elem_of_elements in Hemit; [| done].
    by revert Hemit; apply elem_of_set_map_inj.
Qed.

Lemma StrongFixed_incl_Limited : VLSM_incl StrongFixed Limited.
Proof.
  apply constraint_subsumption_incl.
  intros [i li] [s om] Hpv.
  unfold limited_equivocation_constraint.
  destruct (composite_transition _ _ _) as [s' om'] eqn: Ht.
  by eapply tracewise_not_heavy_LimitedEquivocationProp_iff,
    StrongFixed_valid_state_not_heavy, input_valid_transition_destination.
Qed.

Lemma Fixed_incl_Limited : VLSM_incl Fixed Limited.
Proof.
  destruct (Fixed_eq_StrongFixed IM equivocators) as [Heq _].
  apply VLSM_incl_trans with (machine StrongFixed).
  - by apply Heq.
  - by apply StrongFixed_incl_Limited.
Qed.

End sec_fixed_limited_message_equivocation.

Section sec_has_limited_equivocation.

(** ** Limited Equivocation derived from Fixed Equivocation

  We say that a trace has the [fixed_limited_equivocation_prop]erty if it is
  valid for the composition using a [generalized_fixed_equivocation_constraint]
  induced by a subset of indices whose weight is less than the allowed
  [ReachableThreshold].
*)

Context
  {message}
  `{FinSet index Ci}
  `{!finite.Finite index}
  (IM : index -> VLSM message)
  (threshold : R)
  `{finite.Finite validator}
  `{ReachableThreshold validator Cv threshold}
  (A : validator -> index)
  `{!Inj (=) (=) A}
  (sender : message -> option validator)
  `{forall i, HasBeenSentCapability (IM i)}
  `{forall i, HasBeenReceivedCapability (IM i)}
  .

Definition fixed_limited_equivocation_prop
  (s : composite_state IM)
  (tr : list (composite_transition_item IM))
  : Prop
  :=
    exists equivocators : Cv,
      (sum_weights equivocators <= threshold)%R /\
      finite_valid_trace (fixed_equivocation_vlsm_composition (Ci := Ci) IM (fin_sets.set_map A equivocators)) s tr.

Context
  `{FinSet message Cm}
  (message_dependencies : message -> Cm)
  `{RelDecision _ _ (is_equivocating_tracewise_no_has_been_sent IM A sender)}
  (Limited : VLSM message := tracewise_limited_equivocation_vlsm_composition (Cv := Cv) IM threshold A sender)
  .

(**
  Traces with the [fixed_limited_equivocation_prop]erty are valid for the
  composition using a [limited_equivocation_constraint].
*)
Lemma traces_exhibiting_limited_equivocation_are_valid
  (Hsender_safety : sender_safety_alt_prop IM A sender)
  : forall s tr, fixed_limited_equivocation_prop s tr -> finite_valid_trace Limited s tr.
Proof.
  intros s tr [equivocators [Hlimited Htr]].
  eapply VLSM_incl_finite_valid_trace; [| done].
  by eapply Fixed_incl_Limited.
Qed.

(**
  Traces having the [strong_trace_witnessing_equivocation_prop]erty, which
  are valid for the free composition and whose final state is [not_heavy] have
  the [fixed_limited_equivocation_prop]erty.
*)
Lemma traces_exhibiting_limited_equivocation_are_valid_rev
  (Hke : WitnessedEquivocationCapability IM threshold A sender (Cv := Cv))
  `{!Irreflexive (msg_dep_happens_before message_dependencies)}
  `{forall i, MessageDependencies (IM i) message_dependencies}
  (Hfull : forall i, message_dependencies_full_node_condition_prop (IM i) message_dependencies)
  (no_initial_messages_in_IM : no_initial_messages_in_IM_prop IM)
  (can_emit_signed : channel_authentication_prop IM A sender)
  (Htracewise_basic_equivocation : BasicEquivocation (composite_state IM) validator Cv threshold
    := equivocation_dec_tracewise IM threshold A sender)
  (tracewise_not_heavy := not_heavy (1 := Htracewise_basic_equivocation) (Cv := Cv))
  : forall is s tr, strong_trace_witnessing_equivocation_prop IM threshold A sender is tr (Cv := Cv) ->
    finite_valid_trace_init_to (free_composite_vlsm IM) is s tr ->
    tracewise_not_heavy s ->
    fixed_limited_equivocation_prop is tr.
Proof.
  intros is s tr Hstrong Htr Hnot_heavy.
  exists (equivocating_validators s).
  split; cycle 1.
  - by eapply valid_trace_forget_last, strong_witness_has_fixed_equivocation.
  - by replace (sum_weights _) with (equivocation_fault s).
Qed.

(**
  Traces with the [strong_trace_witnessing_equivocation_prop]erty, which are
  valid for the composition using a [limited_equivocation_constraint]
  have the [fixed_limited_equivocation_prop]erty.
*)
Lemma limited_traces_exhibiting_limited_equivocation_are_valid_rev
  (Hke : WitnessedEquivocationCapability IM threshold A sender (Cv := Cv))
  `{!Irreflexive (msg_dep_happens_before message_dependencies)}
  `{forall i, MessageDependencies (IM i) message_dependencies}
  (Hfull : forall i, message_dependencies_full_node_condition_prop (IM i) message_dependencies)
  (no_initial_messages_in_IM : no_initial_messages_in_IM_prop IM)
  (can_emit_signed : channel_authentication_prop IM A sender)
  : forall s tr, strong_trace_witnessing_equivocation_prop IM threshold A sender s tr (Cv := Cv) ->
    finite_valid_trace Limited s tr -> fixed_limited_equivocation_prop s tr.
Proof.
  intros s tr Hstrong Htr.
  eapply traces_exhibiting_limited_equivocation_are_valid_rev; [done.. | |].
  - apply valid_trace_add_default_last.
    eapply VLSM_incl_finite_valid_trace; [| done].
    by apply constraint_free_incl.
  - by apply tracewise_not_heavy_LimitedEquivocationProp_iff,
      full_node_limited_equivocation_valid_state_weight,
      finite_valid_trace_last_pstate with (X := Limited), Htr.
Qed.

(**
  Any state which is valid for limited equivocation can be produced by
  a trace having the [fixed_limited_equivocation_prop]erty.
*)

Lemma limited_valid_state_has_trace_exhibiting_limited_equivocation
  (Hke : WitnessedEquivocationCapability IM threshold A sender (Cv := Cv))
  `{!Irreflexive (msg_dep_happens_before message_dependencies)}
  `{forall i, MessageDependencies (IM i) message_dependencies}
  (Hfull : forall i, message_dependencies_full_node_condition_prop (IM i) message_dependencies)
  (no_initial_messages_in_IM : no_initial_messages_in_IM_prop IM)
  (can_emit_signed : channel_authentication_prop IM A sender)
  : forall s, valid_state_prop Limited s ->
    exists is tr, finite_trace_last is tr = s /\ fixed_limited_equivocation_prop is tr.
Proof.
  intros s Hs.
  assert (Hfree_s : valid_state_prop (free_composite_vlsm IM) s)
    by (revert Hs; apply VLSM_incl_valid_state, constraint_free_incl).
  destruct
    (free_has_strong_trace_witnessing_equivocation_prop IM threshold A sender _ s Hfree_s)
    as (is & tr & Htr & Heqv).
  exists is, tr.
  apply valid_trace_get_last in Htr as Hlst.
  split; [done |].
  eapply traces_exhibiting_limited_equivocation_are_valid_rev; [done.. |].
  by apply tracewise_not_heavy_LimitedEquivocationProp_iff,
    full_node_limited_equivocation_valid_state_weight.
Qed.

End sec_has_limited_equivocation.


(* Cyclone Semantics using TLC/LN in Coq Version 4 *)
(* "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".   Daniel Grossman, August 2003 *)
(* Lemmas for WFC  *)
(* Brian Milnes 2016 *)
Set Implicit Arguments.
Require Export Cyclone_Formal_Syntax Cyclone_Static_Semantics_Kinding_And_Context_Well_Formedness.
Require Export Cyclone_Static_Semantics_Typing_Heap_Objects.
Require Export Cyclone_Classes Cyclone_Inductions Cyclone_LN_Tactics Cyclone_LN_Extra_Lemmas_And_Automation.
Close Scope list_scope.
Import LibEnvNotations.
Import LVPE.LibVarPathEnvNotations.

Lemma WFU_ok_upsilon:
  forall u,
    WFU u ->
    LVPE.okp u.
Proof.
  intros.
  inversion H.
  constructor.
  constructor.
  assumption.
  apply LVPE.get_none_inv.
  assumption.
Qed.

Ltac WFU_ok_upsilon :=
  match goal with
    | H : WFU ?u |- LVPE.okp ?u => apply WFU_ok_upsilon
  end.
Hint Extern 1 (LVPE.okp _) => try WFU_ok_upsilon.

Lemma WFDG_ok_delta:
  forall d g,
    WFDG d g ->
    ok d.
Proof.
  intros.
  inversion* H.
Qed.

Ltac WFDG_ok_delta :=
  match goal with
    | H : WFDG ?d ?g' |- ok ?d => apply WFDG_ok_delta with (g:= g')
  end.
Hint Extern 1 (ok _) => try WFDG_ok_delta.

Lemma WFDG_ok_gamma:
  forall d g,
    WFDG d g ->
    ok g.
Proof.
  intros.
  inversion H; subst.
  constructor.
  constructor.
  assumption.
  apply* get_none_inv.
Qed.
Ltac WFDG_ok_gamma :=
  match goal with
    | H : WFDG ?d' ?g |- ok ?g => apply WFDG_ok_gamma with (d:=d')
  end.
Hint Extern 1 (ok _) => try WFDG_ok_gamma.

Lemma WFC_ok_delta:
  forall d u g,
    WFC d u g ->
    ok d.
Proof.
  intros.
  inversion* H.
Qed.
Ltac WFC_ok_delta :=
  match goal with
    | H : WFC ?d ?u' ?g'|- ok ?d => apply WFC_ok_delta with (u:=u') (g:=g')
  end.
Hint Extern 1 (ok _) => try WFC_ok_delta.

Lemma WFC_ok_gamma:
  forall d u g,
    WFC d u g ->
    ok g.
Proof.
  intros*.
  inversion* H; subst.
Qed.
Ltac WFC_ok_gamma :=
  match goal with
    | H : WFC ?d' ?u' ?g|- ok ?g => apply WFC_ok_gamma with (d:= d') (u:=u')
  end.
Hint Extern 1 (ok _) => try WFC_ok_gamma.

Lemma WFU_K:
  forall u xp tau,
   WFU (u &p xp ~p tau) ->
    K empty tau A.
Proof.
  introv WFUd.
  induction u.
  inversion WFUd.
  apply LVPE.empty_push_inv in H0.
  inversion H0.
  rewrite <- LVPE.V.empty_def in H.
  apply LVPE.eq_push_inv in H.
  inversion H.
  inversion H5.
  subst.
  assumption.
  inversion WFUd.
  apply LVPE.empty_push_inv in H0.
  inversion H0.
  apply LVPE.eq_push_inv in H.
  inversion H.
  inversion H5.
  subst.
  assumption.
Qed.
Ltac WFU_K :=
  match goal with
    | H : WFU (?u' &p ?xp' ~p ?tau') |- K empty ?tau' A =>
    apply WFU_K with (u:= u') (xp:=xp') (tau:=tau')
  end.
Hint Extern 1 (K empty _ A) => WFU_K.

Lemma WFDG_K:
  forall d g,
    WFDG d g ->
    forall x tau,
      get x g = Some tau ->
      K d tau A.
Proof.
  intros.
  induction H.
  rewrite get_empty in H0.
  inversion H0.
  rewrite get_push in H0.
  case_var.
  inversion H0; subst.
  assumption.
  apply IHWFDG.
  assumption.
Qed.
Ltac WFDG_K :=
  match goal with
    | H : WFDG ?d' ?g', I: get ?x' ?g' = Some ?tau' |- K ?d' ?tau' A =>
      apply WFDG_K with (d:=d') (g:=g') (x:= x') (tau:=tau')
  end.
Hint Extern 1 (K _ _ A) => WFDG_K.

Lemma WFC_K:
  forall d u g,
    WFC d u g ->
    forall x tau,
      get x g = Some tau ->
      K d tau A.
Proof.
  intros.
  inversion H; subst.
  auto.
Qed.
Ltac WFC_K :=
  match goal with
    | H : WFC ?d' ?u' ?g', I: get ?x' ?g' = Some ?tau' |- K ?d' ?tau' A =>
      apply WFC_K with (d:=d') (g:=g') (x:= x') (tau:=tau')
  end.
Hint Extern 1 (K _ _ A) => WFC_K.


From iris.proofmode Require Import tactics environments.
From Perennial.Helpers Require Import NamedProps.

(** * Caching and re-using Iris proofs.

    Tactics for saving an Iris proof using a collection of hypotheses.

    Usage:

    [iCache P with "H1 H2..."] asks the user to prove [P] using hypotheses H1
    H2... from the context. It creates a cached proof in the persistent context.

    Later, [iFromCache] attempts to prove the goal using a matching cache and
    the exact same hypotheses (including names).
 *)

(** Implementation details:

    A cache [c] for a result [R] remembers an [env] ([c.(cache_prop)]) and a
    list of names used, and the persistent statement in the context is:

    □ ([∗] c -∗ R)

    Constructing the proof just involves setting up this statement. It uses
    [iNamed] to serialize/deserialize the hypotheses while retaining names. See
    [cached_make] for where the naming comes from, and [iCache_go] for some
    cleanup after iApplying that theorem.

    To restore the cache, we just split the environment with [envs_split] using
    the list of names in the cache and match exactly with the cache's
    environment. This works well because it uses a canonical order specified in
    the cache, so after splitting we can look for equality. See
    [tac_cached_use].

    Finally, we use a cute trick to make the caches look pleasant: a
    printing-only notation in [cache_hide_scope] that doesn't print the
    environment and only shows the goal and hypotheses. It's possible to hide
    things using implicits instead, but this solution has some advantages:

    - Caches are displayed as [cache_for!], which tells you something funny is
      going on.
    - We have a little more control over the display (for example, it says
      [cache_for! ... with ...] as a hint for what the second argument means).
    - Caches can be temporarily displayed with [Local Close Scope cache_hide_scope].

 *)

Section bi.
  Context {PROP: bi}.
  Context `{!BiAffine PROP}.

  Record cache (R: PROP) :=
    Cache { cache_prop :> env PROP;
            cache_names: list ident; }.

  Arguments cache_names {R} c.
  Arguments cache_prop {R} c.

  Definition cached_def {R} (c: cache R): PROP :=
    (□ ([∗] c -∗ R))%I.
  Definition cached_aux : seal (@cached_def). by eexists. Qed.
  Definition cached := unseal cached_aux.
  Definition cached_eq : @cached = @cached_def := seal_eq cached_aux.
  Arguments cached {R} c.

  Ltac unseal := rewrite cached_eq /cached_def.

  Global Instance cached_Persistent {R} c : Persistent (@cached R c).
  Proof. unseal. apply _. Qed.

  Lemma cached_elim R (c: cache R) Δs :
    Δs.(env_spatial) = c.(cache_prop) →
    cached c -∗
    of_envs Δs -∗
    R.
  Proof.
    unseal.
    iIntros (Hsubenv) "#Hcache HΔ".
    iDestruct (envs_clear_spatial_sound with "HΔ") as "(HΔ'&HΔs)".
    iApply "Hcache".
    rewrite -Hsubenv.
    iAssumption.
  Qed.

  Local Theorem tac_cached_use {Δ: envs PROP} i {R} (c: cache R) :
    envs_lookup i Δ = Some (true, cached c) →
    match envs_split base.Left c.(cache_names) Δ with
    | Some (Γs, _) => Γs.(env_spatial) = c.(cache_prop)
    | None => False
    end →
    envs_entails Δ R.
  Proof.
    iIntros (Hlookup Hsubenv).
    destruct_with_eqn (envs_split base.Left c.(cache_names) Δ); [ | contradiction ].
    destruct p as [Γs Γ'].
    rewrite envs_entails_unseal.
    iIntros "HΔ".
    iDestruct (envs_lookup_intuitionistic_sound _ _ _ Hlookup with "HΔ") as
        "[#Hcache HΔ]".
    iDestruct (envs_split_sound with "HΔ") as "[HΔ1 HΔ2]"; eauto.
    iApply (cached_elim with "Hcache HΔ1"); auto.
  Qed.

  Local Theorem cached_make R (c: cache R) :
    □ (env_to_named_prop c -∗ R) -∗
    cached c.
  Proof.
    unseal.
    iIntros "#HR !>".
    rewrite env_to_named_prop_sound //.
  Qed.
End bi.

Arguments cached {PROP R} c.
Arguments cache_names {PROP R} c.
Arguments cache_prop {PROP R} c.

(* following the pattern from proofmode/reduction.v *)
Declare Reduction cached_eval :=
  cbv [ env_to_named_prop env_to_named_prop_go cache_prop ].
Ltac cached_eval t :=
  eval cached_eval in t.
Ltac cached_reduce :=
  match goal with |- ?u => let v := cached_eval u in change_no_check v end.

Ltac iCache_go P Hs pat :=
  let Hs := words Hs in
  let Hs := (eval vm_compute in (INamed <$> Hs)) in
  let Δ := iGetCtx in
  let js := reduction.pm_eval (envs_split base.Left Hs Δ) in
  match js with
  | Some (?Δ, _) => let Γs := (eval cbv [env_spatial] in Δ.(env_spatial)) in
                    iAssert (cached (Cache P Γs Hs)) as pat;
                    [ iApply cached_make; iModIntro;
                      cached_reduce;
                      iNamed 1
                    | ]
  | None => fail 1 "hypotheses not found"
  end.

Tactic Notation "iCache" constr(P) "with" constr(Hs) :=
  iCache_go P Hs "#?".

Ltac iFromCache :=
  lazymatch goal with
  | [ |- envs_entails (Envs ?Γp _ _) ?P ] =>
    first [ match Γp with
            | context[Esnoc _ ?i (@cached _ P ?c)] =>
              apply (tac_cached_use i c);
              [ reflexivity (* lookup should always succeed, found by context match *)
              | reduction.pm_reduce;
                reflexivity ]
            end
          | lazymatch Γp with
            | context[Esnoc _ _ (@cached _ P _)] =>
              fail 1 "iFromCache: could not find hypotheses for any cache"
            | _ =>
              fail 1 "iFromCache: no matching caches"
            end
          ]
  end.

Declare Scope cache_hide_scope.
Notation "'cache_for!' P 'with' Hs" := (cached (Cache P _ Hs))
                                         (at level 29, only printing) : cache_hide_scope.
Open Scope cache_hide_scope.

Module examples.
  Section bi.
    Context {PROP:bi} `{!BiAffine PROP}.
    Context (P P1 P2 Q R: PROP).
    Context (HP: P -∗ P1 ∗ P2).
    Context (HQ: P1 -∗ Q).

    Example make_and_use_cache :
      P -∗
      P1 ∗ (P -∗ P1).
    Proof.
      iIntros "HP".
      iCache P1 with "HP".
      { iDestruct (HP with "HP") as "[$ _]". }
      iSplitL "HP".
      - iFromCache.
      - iIntros "HP".
        iFromCache.
    Qed.

    Example multiple_caches_for_goal :
      P ∗ Q -∗
      Q ∗ Q.
    Proof.
      iIntros "[HP HQ]".
      iCache Q with "HP".
      { iDestruct (HP with "HP") as "[HP1 _]".
        iDestruct (HQ with "HP1") as "$". }
      iCache Q with "HQ".
      { auto. }
      iSplitL "HP".
      (* these goals are identical, so one of them requires backtracking on
      which cache to use *)
      - iFromCache.
      - iFromCache.
    Qed.

    Example reordered_hypotheses :
      P ∗ Q -∗
      Q ∗ P.
    Proof.
      iIntros "[HP HQ]".
      iCache (Q ∗ P)%I with "HQ HP".
      { iFrame. }
      (* we need to grab the goals from the context in the opposite order that
      they appear; the current implementation uses envs_split driven by a list
      of hypotheses in the cache itself to guide the splitting and order *)
      iFromCache.
    Qed.

    Example fail_no_hyps :
      P -∗ P.
    Proof.
      iIntros "HP".
      iCache P with "HP"; first by iFrame.
      iRename "HP" into "HP'".
      Fail iFromCache. (* this should report a useful error *)
    Abort.

    Example fail_wrong_hyps :
      P ∗ Q -∗ P.
    Proof.
      iIntros "[HP HQ]".
      iCache P with "HP"; first by iFrame.
      iClear "HP". iRename "HQ" into "HP".
      Fail iFromCache. (* this should report a useful error *)
    Abort.

    Example fail_no_cache :
      P -∗ P.
    Proof.
      iIntros "HP".
      Fail iFromCache. (* this should report a useful error *)
    Abort.

  End bi.
End examples.


(* 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.