Require Import Coq.Program.Basics.
Require Import LogicalRelations.
Require Import SimulationRelation.
Require Import Structures.
Require Import OptionOrders.
Require Import compcert.lib.Floats.
Require Import compcert.common.Values.
Require Import liblayers.compcertx.CompcertStructures.
Local Opaque mwd_ops.

(** * [inject] as a simulation relation *)

Lemma Ple_lub a b:
  (forall c, Plt c a -> Plt c b) ->
  Ple a b.
Proof.
  intros H.
  destruct (peq a 1) as [ | NE ]; try xomega.
  generalize (Ppred_Plt _ NE). intro LT.
  specialize (H _ LT).
  revert LT.
  replace a with (Pos.succ (Pos.pred a)) at 2 3; [ xomega | ] .
  apply Pos.succ_pred.
  assumption.
Qed.

Record simrel_inject_world: Type :=
  {
    simrel_inject_meminj :> block -> option (block * Z);
    nextblock_high: block;
    nextblock_low: block;
    simrel_inject_meminj_valid b1 b2 o:
      simrel_inject_meminj b1 = Some (b2, o) ->
      Plt b1 nextblock_high /\ Plt b2 nextblock_low;
    simrel_inject_globals b:
      block_is_global b -> simrel_inject_meminj b = Some (b, 0);
  }.

Lemma simrel_inject_world_eq j1 j2:
  simrel_inject_meminj j1 = simrel_inject_meminj j2 ->
  nextblock_high j1 = nextblock_high j2 ->
  nextblock_low j1 = nextblock_low j2 ->
  j1 = j2.
Proof.
  intros H H0 H1.
  destruct j1; destruct j2; simpl in * |- * ; subst.
  f_equal;
  apply ProofIrrelevance.proof_irrelevance.
Qed.

Record simrel_inject_acc (j1 j2: simrel_inject_world): Prop :=
  simrel_inject_acc_intro
    {
      simrel_inject_acc_carrier :> Values.inject_incr j1 j2;
      nextblock_high_le: Ple (nextblock_high j1) (nextblock_high j2);
      nextblock_low_le: Ple (nextblock_low j1) (nextblock_low j2);
      simrel_inject_acc_separated:
        forall b1 b2 delta,
          j1 b1 = None ->
          j2 b1 = Some (b2, delta) ->
          ~ Plt b1 (nextblock_high j1) /\
          ~ Plt b2 (nextblock_low j1)
    }.

Hint Resolve simrel_inject_acc_carrier.

Local Instance simrel_inject_acc_refl: Reflexive simrel_inject_acc.
Proof.
  red. intro j.
  constructor; auto using Ple_refl; congruence.
Qed.

Local Instance simrel_inject_acc_trans: Transitive simrel_inject_acc.
Proof.
  red. intros j1 j2 j3.
  inversion 1.
  inversion 1.
  constructor; eauto using Values.inject_incr_trans, Ple_trans.
  intros b1 b2 delta H1 H2.
  destruct (j2 b1) as [[ b12 ? ] | ]  eqn:J2.
  {
    exploit simrel_inject_acc_separated0; eauto.
    specialize (simrel_inject_acc_carrier1 _ _ _ J2).
    replace b12 with b2 in * by congruence.
    xomega.
  }
  exploit simrel_inject_acc_separated1; eauto.
  xomega.
Qed.

Global Instance simrel_inject_world_preserves_globals_incr:
  Monotonic
    Events.meminj_preserves_globals
    (forallr -, forallr -, - ==> simrel_inject_acc ++> impl).
Proof.
  repeat red.
  intros v v0 a x y H H0.
  unfold Events.meminj_preserves_globals in H0.
  destruct H0 as (DOMAIN1 & DOMAIN2 & IMAGE).
  split; [|split].
  {
    intros id b H1.
    apply H.
    eauto.
  }
  {
    intros id b H1.
    apply H.
    eauto.
  }
  {
    intros b1 b2 delta gv H0 H1.
    destruct (x b1) as [ [ ? ? ] | ] eqn:X.
    {
      erewrite ((H: Values.inject_incr _ _) _ _ _ X) in H1; eauto.
      inversion H1; clear H1; subst.
      eauto.
    }
    exploit simrel_inject_acc_separated; eauto.
    destruct 1.
    exploit DOMAIN2; eauto.
    intros H4.
    clear H1.
    exploit simrel_inject_meminj_valid; eauto.
    tauto.
  }
Qed.

Section INJECT_SIMREL.
  Context `{Hmem: BaseMemoryModel}.
  Context {D: layerdata}.

  Record simrel_inject_match_mem j (m1 m2: mwd D) :=
    {
      simrel_inject_match_mem_base :> Mem.inject (simrel_inject_meminj j) m1 m2;
      nextblock_high_match: nextblock_high j = Mem.nextblock m1;
      nextblock_low_match: nextblock_low j = Mem.nextblock m2
    }.

  Hint Resolve simrel_inject_match_mem_base.

  Lemma simrel_inject_acc_inject_separated j1 m1 m2 j2:
    simrel_inject_match_mem j1 m1 m2 ->
    simrel_inject_acc j1 j2 ->
    Events.inject_separated j1 j2 m1 m2.
  Proof.
    inversion 1.
    inversion 1.
    red.
    unfold Mem.valid_block.
    rewrite <- nextblock_high_match0.
    rewrite <- nextblock_low_match0.
    assumption.
  Qed.

  Lemma inject_separated_inject_incr j1 m1 m2 j2 m1_ m2_:
    simrel_inject_match_mem j1 m1 m2 ->
    Values.inject_incr j1 j2 ->
    Events.inject_separated j1 j2 m1 m2 ->
    Mem.inject j2 m1_ m2_ ->
    (forall b, Mem.valid_block m1 b -> Mem.valid_block m1_ b) ->
    (forall b, Mem.valid_block m2 b -> Mem.valid_block m2_ b) ->
    { j3: simrel_inject_world | j2 = j3 /\
                   simrel_inject_match_mem j3 m1_ m2_ /\
                   simrel_inject_acc j1 j3
    }.
  Proof.
    intros H H0 H1 H2 H3 H4.
    inversion H.
    apply Ple_lub in H3.
    apply Ple_lub in H4.
    unfold Events.inject_separated in H1.
    unfold Mem.valid_block in H1.
    eexists {| simrel_inject_meminj := _ |}; simpl.
    split.
    { reflexivity. }
    split; econstructor; simpl; eauto; try congruence.
    rewrite nextblock_low_match0.
    rewrite nextblock_high_match0.
    assumption.
  Grab Existential Variables.
    {
      intros b H5.
      apply (simrel_inject_globals j1) in H5.
      eauto.
    }
    {
      intros b1 b2 o H5.
      split.
      {
        eapply Mem.valid_block_inject_1; eauto.
      }
      eapply Mem.valid_block_inject_2; eauto.
    }
  Qed.

  Lemma inject_same_nextblock j m1 m2 m1_ m2_:
    simrel_inject_match_mem j m1 m2 ->
    Mem.inject j m1_ m2_ ->
    Mem.nextblock m1_ = Mem.nextblock m1 ->
    Mem.nextblock m2_ = Mem.nextblock m2 ->
    simrel_inject_match_mem j m1_ m2_.
  Proof.
    inversion 1.
    intros H0 H1 H2.
    constructor; congruence.
  Qed.

  Lemma simrel_inject_exists ge (j: Values.meminj) m1 m2:
    stencil_matches ge ->
    (forall id b, Senv.find_symbol ge id = Some b -> j b = Some (b, 0)) ->
    Mem.inject j m1 m2 ->
    { j_ | simrel_inject_match_mem j_ m1 m2 /\
           j = j_ }.
  Proof.
    intros H H0 H1.
    eexists {| simrel_inject_meminj := _ |}.
    split; simpl; eauto.
    econstructor; simpl; eauto.
  Grab Existential Variables.
    {
      intros b H2.
      apply block_is_global_find_symbol in H2.
      destruct H2 as [i Hi].
      eapply H0.
      erewrite stencil_matches_find_symbol by eauto.
      eassumption.
    }
    {
      split.
      {
        eapply Mem.valid_block_inject_1; eauto.
      }
      eapply Mem.valid_block_inject_2; eauto.
    }
  Qed.

  Definition simrel_inject_ops :=
    {|
      simrel_world := simrel_inject_world;
      simrel_acc := {| Structures.le := simrel_inject_acc |};
      simrel_undef_matches_values_bool := true;
      simrel_undef_matches_block p b := True;
      simrel_new_glbl := nil;
      simrel_meminj p := p;
      match_mem := simrel_inject_match_mem
    |}.

  Require Import ExtensionalityAxioms.

  Lemma match_val_simrel_inject:
    match_val simrel_inject_ops = Val.inject.
  Proof.
    eapply functional_extensionality; intro p.
    eapply functional_extensionality; intro v1.
    eapply functional_extensionality; intro v2.
    eapply prop_ext.
    split.
    - destruct 1; simpl in *; subst; try constructor.
      inversion H; subst.
      econstructor; eauto.
    - destruct 1; try constructor.
      + subst.
        constructor.
        assumption.
      + destruct v; constructor; constructor.
  Qed.

  Lemma match_memval_simrel_inject:
    match_memval simrel_inject_ops = memval_inject.
  Proof.
    eapply functional_extensionality; intro p.
    eapply functional_extensionality; intro v1.
    eapply functional_extensionality; intro v2.
    eapply prop_ext.
    split.
    - destruct 1; simpl in *; subst; try constructor.
      rewrite match_val_simrel_inject in H.
      assumption.
    - destruct 1.
      + constructor.
      + subst.
        constructor.
        rewrite match_val_simrel_inject.
        assumption.
      + destruct mv; constructor; try constructor.
        rewrite match_val_simrel_inject.
        constructor.
  Qed.

  Theorem free_parallel_inject:
    forall f (m1 m2: mwd D) b b' lo hi m1' delta,
      Mem.inject f m1 m2 ->
      f b = Some (b', delta) ->
      Mem.free m1 b lo hi = Some m1' ->
      exists m2',
        Mem.free m2 b' (lo + delta) (hi + delta)  = Some m2'
        /\ Mem.inject f m1' m2'.
  Proof.
    intros until delta.
    intros MEM_INJ BLOCK_INJ FREE_SRC.
    generalize (Mem.free_range_perm _ _ _ _ _ FREE_SRC). intro PERM_SRC.
    generalize (Mem.range_perm_inject _ _ _ _ _ _ _ _ _ _ BLOCK_INJ MEM_INJ PERM_SRC). intro PERM_TGT.
    destruct (Mem.range_perm_free _ _ _ _ PERM_TGT) as [? FREE_TGT].
    rewrite FREE_TGT.
    esplit. split.
    reflexivity.
    eapply Mem.free_right_inject.
    eapply Mem.free_left_inject.
    eassumption.
    eassumption.
    eassumption.
    intros b1 delta1 ofs1 k1 p1 BLOCK_INJ1 PERM1 RANGE1.
    destruct (peq b1 b).
    subst.
    replace delta1 with delta in * by congruence.
    eapply (Mem.perm_free_2 (mem := mwd D)). eexact FREE_SRC. 2: eassumption. omega.
    eapply Mem.perm_free_3 in PERM1; eauto.
    exploit (Mem.inject_no_overlap (mem := mwd D)).
    eexact MEM_INJ.
    eassumption.
    eassumption.
    eassumption.
    eapply Mem.perm_max. eapply Mem.perm_implies. eassumption. constructor.
    eapply Mem.perm_max. eapply Mem.perm_implies. eapply PERM_SRC. instantiate (1 := ofs1 + delta1 - delta).
    omega. constructor.
    intros; elim H; intros; apply H0; trivial.
    xomega.
  Qed.

  (** For the initial memory, we cannot use SimrelInitMem, because in
      between the construction of an initial memory, no memory
      injection can be proven. However, CompCert proves that an
      initial memory always injects into itself. On the other hand, we
      prove that simrel_program_rel introduces memory extensions
      between initial memory states, so we can compose this extension
      with the self-injection of initial memory states to obtain
      memory injection. Thus, we need: *)

  Require SimrelLessdef.
  Require InitMem.

  (** Relation with inject_neutral for the initial memory state. *)

  Lemma neutral_inject m:
    Mem.inject_neutral (Mem.nextblock m) m ->
    (forall b, block_is_global b -> Mem.valid_block m b) ->
    {j | simrel_inject_match_mem j m m /\
         Mem.flat_inj (Mem.nextblock m) = j
    }.
  Proof.
    intros H H0.
    apply Mem.neutral_inject in H.
    eexists {| simrel_inject_meminj := _ |}; simpl.
    split; [ | reflexivity ].
    econstructor; simpl; eauto.
  Grab Existential Variables.
    {
    intros b H1.
    unfold Mem.valid_block in H0.
    apply H0 in H1.
    unfold Mem.flat_inj.
    destruct (plt b (Mem.nextblock m)); tauto.
    }
    {
      intros b1 b2 o H1.
      unfold Mem.flat_inj in H1.
      destruct (plt b1 (Mem.nextblock m)); try discriminate.
      inversion H1; subst; auto.
    }
  Qed.

  Global Instance simrel_inject_prf:
    SimulationRelation simrel_inject_ops.
  Proof.
    assert (Heqsub: forall A B, subrel (@eqrel A B) (@subrel A B)).
    {
      intros A B x y H.
      repeat red in H.
      tauto.
    }
    constructor.

    (** Compatibility with order *)
    - constructor; typeclasses eauto.
    - constructor.
    - repeat red.
      intros x y H a.
      simpl.
      destruct (x a) as [ [ ] | ] eqn:EQ; try now constructor.
      apply H in EQ.
      rewrite EQ.
      reflexivity.

    (** Properties of [simrel_meminj] *)
    - constructor.
    - constructor.
    - simpl; trivial.
    - simpl; trivial.
    - simpl; trivial.
    - exact simrel_inject_globals.

    (** [Genv.init_mem] *)
    - intros F V p1 p2 Hp.
      generalize Hp. intro Hp' .
      apply genv_globalenv_rel in Hp.
      generalize Hp. intro Hp2.
      apply genv_le_stencil_matches_l in Hp.
      apply genv_le_stencil_matches_r in Hp2.
      apply (simrel_init_mem (D1:=D) (D2:=D) (SimulationRelation := SimrelLessdef.simrel_lessdef_prf)) in Hp'.
      inversion Hp' ; clear Hp' ; subst; try now constructor.
      match goal with
        K: (rexists w: simrel_world SimrelLessdef.simrel_lessdef_ops, match_mem _ w)%rel ?x ?y |- _ =>
        destruct K as [w Hm];
          rename x into m1;
          rename y into m2
      end.
      simpl in Hm.
      assert (Mem.nextblock m1 = glob_threshold) as NEXT1.
      {
        apply stencil_matches_genv_next in Hp.
        rewrite <- Hp.
        symmetry.
        apply Genv.init_mem_genv_next.
        congruence.
      }
      assert (Mem.nextblock m2 = glob_threshold) as NEXT2.
      {
        apply stencil_matches_genv_next in Hp2.
        rewrite <- Hp2.
        symmetry.
        apply Genv.init_mem_genv_next.
        congruence.
      }
      assert (Mem.inject_neutral (Mem.nextblock m1) m1) as INJ.
      {
        eapply InitMem.Genv.initmem_inject_neutral.
        symmetry.
        eassumption.
      }
      apply neutral_inject in INJ.
      {
        destruct INJ as (j & INJ & Hj).
        constructor.
        exists j.
        inversion INJ.
        constructor; try congruence.
        eapply Mem.inject_extends_compose; eauto.
      }
      intros b Hb.
      apply block_is_global_find_symbol in Hb.
      destruct Hb as (i & Hi).
      erewrite <- stencil_matches_symbols in Hi by eexact Hp.
      apply Genv.genv_symb_range in Hi.
      erewrite (Genv.init_mem_genv_next (mem := mwd D)) in Hi by (symmetry; eassumption).
      assumption.

    (** [Mem.alloc] *)
    - repeat red.
      intros p x y H a a0.
      destruct (Mem.alloc x _ _) eqn:Halloc1.
      edestruct (Mem.alloc_parallel_inject (mem := mwd D)) as (j2 & ? & ? & Halloc2 & INJ & INCR & J & ?); try eassumption; try reflexivity; eauto.
      edestruct inject_separated_inject_incr as  (j3 & ? & INJ_ & INCR_); eauto using (Mem.valid_block_alloc (mem := mwd D)).
      {
        red.
        intros b1 b2 delta H1 H2.
        destruct (peq b1 b) as [ | NE ].
        {
          subst.
          rewrite J in H2. inversion H2; clear H2; subst.
          eauto using (Mem.fresh_block_alloc (mem := mwd D)).
        }
        apply H0 in NE.
        congruence.
      }
      subst j2.
      rewrite Halloc2.
      econstructor; eauto.
      split; simpl; eauto.
      split; eauto.

    (** [Mem.free] *)
    - repeat red.
      simpl.
      intros p x y H x0 y0 H0.
      inversion H0; subst.
      inversion H1; subst.
      simpl.
      destruct (Mem.free x _ _ _) eqn:Hfree1; try constructor.
      edestruct free_parallel_inject as (? & Hfree2 & INJ); eauto.
      replace (ofs1 + delta + sz) with (ofs1 + sz + delta) by omega.
      rewrite Hfree2.
      constructor.
      exists p.
      split; try reflexivity.
      eapply inject_same_nextblock; eauto using (Mem.nextblock_free (mem := mwd D)).

    (** [Mem.load] *)
    - rewrite match_val_simrel_inject.
      repeat red.
      simpl.
      intros p a x y H x0 y0 H0.
      inversion H0; subst.
      simpl.
      destruct (Mem.load _ x _ _) eqn:Hload; try constructor.
      edestruct (Mem.load_inject (mem := mwd D)) as (? & Hload2 & ?); eauto.
      simpl in * |- * .
      rewrite Hload2.
      constructor; assumption.

    (** [Mem.store] *)
    - rewrite match_val_simrel_inject.
      repeat red.
      simpl.
      intros p a x y H x0 y0 H0 x1 y1 H1.
      inversion H0; subst.
      simpl.
      destruct (Mem.store _ x _ _ _) eqn:Hstore1; try constructor.
      simpl in * |- * .
      edestruct (Mem.store_mapped_inject (mem := mwd D)) as (? & Hstore2 & ?); eauto.
      rewrite Hstore2.
      constructor.
      exists p.
      split; try reflexivity.
      eapply inject_same_nextblock; eauto using (Mem.nextblock_store (mem := mwd D)).

    (** [Mem.loadbytes] *)
    - rewrite match_memval_simrel_inject.
      repeat red.
      simpl.
      intros p x y H x0 y0 H0 a.
      inversion H0; subst.
      simpl.
      destruct (Mem.loadbytes x _ _ _) eqn:Hlb1; try constructor.
      edestruct (Mem.loadbytes_inject (mem := mwd D)) as (? & Hlb2 & ?); eauto.
      rewrite Hlb2.
      constructor.
      rewrite <- CompcertStructures.list_forall2_list_rel; assumption.

    (** [Mem.storebytes] *)
    - rewrite match_memval_simrel_inject.
      simpl.
      repeat red.
      intros p x y H x0 y0 H0 x1 y1 H1.
      inversion H0; subst.
      simpl.
      destruct (Mem.storebytes x _ _ _) eqn:Hsb1; try constructor.
      edestruct (Mem.storebytes_mapped_inject (mem := mwd D)) as (? & Hsb2 & ?); eauto.
      { rewrite CompcertStructures.list_forall2_list_rel; eassumption. }
      rewrite Hsb2.
      constructor.
      exists p.
      split; try reflexivity.
      eapply inject_same_nextblock; eauto using (Mem.nextblock_storebytes (mem := mwd D)).

    (** [Mem.perm] *)
    - repeat red.
      intros p x y H x0 y0 H0 a a0 H1.
      inversion H0; subst.
      simpl in * |- * .
      eapply Mem.perm_inject; eauto.

    (** [Mem.valid_block] *)
    - intros p m1 m2 Hm b1 b2 [delta Hb].
      simpl in *.
      split; intro H.
      + eapply Mem.valid_block_inject_2; eauto.
      + eapply Mem.valid_block_inject_1; eauto.

    (** [Mem.different_pointers_inject] *)
    - eauto using (Mem.different_pointers_inject (mem := mwd D)).

    (** [Mem.weak_valid_pointer_inject_val] *)
    - inversion 3; subst.
      eapply Mem.weak_valid_pointer_inject_val; eauto.

    (** [Mem.weak_valid_pointer_address_inject_weak] *)
    - intros p m1 m2 b1 b2 delta H H0.
      inversion H; clear H; subst.
      simpl in H0.
      exists (Ptrofs.unsigned (Ptrofs.repr delta)).
      intros ofs1 H.
      rewrite Ptrofs.add_unsigned.
      apply Ptrofs.unsigned_repr.
      eapply (Mem.weak_valid_pointer_inject_no_overflow (mem := mwd D)); eauto.

    (** [Mem.address_inject] *)
    - intro.
      eauto using (Mem.address_inject (mem := mwd D)).

    (** [Mem.aligned_area_inject] *)
    - intro.
      eauto using (Mem.aligned_area_inject (mem := mwd D)).

    (** [Mem.disjoint_or_equal_inject] *)
    - intro.
      eauto using (Mem.disjoint_or_equal_inject (mem := mwd D)).
  Qed.

  Definition inj :=
    {|
      simrel_ops := simrel_inject_ops
    |}.

End INJECT_SIMREL.

  (* Internal composition. *)

  Lemma compose_meminj_exists (j1 j2: simrel_inject_world):
    { j: simrel_inject_world | Values.compose_meminj j1 j2 = j /\
                  nextblock_high j = nextblock_high j1 /\
                  nextblock_low j = nextblock_low j2
    }.
  Proof.
    eexists {| simrel_inject_meminj := _ |}; simpl.
    intuition reflexivity.
  Grab Existential Variables.
    {
    intros b H.
    unfold compose_meminj.
    erewrite simrel_inject_globals by eassumption.
    erewrite simrel_inject_globals by eassumption.
    reflexivity.
    }
    {
      unfold compose_meminj.
      intros b1 b2 o H.
      destruct (j1 b1) as [ [ b12 ?] | ] eqn:J1 ; try discriminate.
      destruct (j2 b12) as [ [ ? ? ] | ] eqn:J2 ; try discriminate.
      inversion H; subst.
      apply simrel_inject_meminj_valid in J1.
      apply simrel_inject_meminj_valid in J2.
      intuition congruence.
    }
  Qed.

  Definition compose_meminj j1 j2 :=
    let (j, _) := compose_meminj_exists j1 j2 in j.

  Lemma compose_meminj_correct_strong (j1 j2: simrel_inject_world):
    Values.compose_meminj j1 j2 = compose_meminj j1 j2 /\
    nextblock_high (compose_meminj j1 j2) = nextblock_high j1 /\
    nextblock_low (compose_meminj j1 j2) = nextblock_low j2.
  Proof.
    unfold compose_meminj.
    destruct compose_meminj_exists.
    assumption.
  Qed.

  Lemma compose_meminj_correct (j1 j2: simrel_inject_world):
    Values.compose_meminj j1 j2 = compose_meminj j1 j2.
  Proof.
    apply compose_meminj_correct_strong.
  Qed.

(* # The following is wrong due to inject_separated.
  Global Instance compose_meminj_incr:
    Proper
      (simrel_inject_acc ++>
       simrel_inject_acc ++>
       simrel_inject_acc)
      compose_meminj.
   # However, we have the following weaker form,
   # which is true because nextblock_low j12 = nextblock_high j23.
 *)

Section INJECT_COMPOSE.
  Context `{Hmem: BaseMemoryModel}.
  Context {D: layerdata}.

  Lemma compose_meminj_incr j12 j23 (m1 m2 m3: mwd D) j12_ j23_ (m1_ m2_ m3_: mwd D):
    simrel_inject_match_mem j12 m1 m2 ->
    simrel_inject_match_mem j23 m2 m3 ->
    simrel_inject_match_mem j12_ m1_ m2_ ->
    simrel_inject_match_mem j23_ m2_ m3_ ->
    simrel_inject_acc j12 j12_ ->
    simrel_inject_acc j23 j23_ ->
    simrel_inject_acc (compose_meminj j12 j23) (compose_meminj j12_ j23_).
  Proof.
    intros H H0 H1 H2 H3 H4.
    inversion H.
    inversion H0.
    inversion H1.
    inversion H2.
    inversion H3.
    inversion H4.
    generalize (compose_meminj_correct_strong j12 j23). intros (EQ & ? & ?).
    generalize (compose_meminj_correct_strong j12_ j23_). intros (EQ_ & ? & ?).
    constructor; try congruence.
    {
      red.
      intros b1 b3 delta.
      rewrite <- EQ.
      rewrite <- EQ_.
      unfold Values.compose_meminj.
      destruct (j12 b1) as [ [ b2 ? ] | ] eqn:X; try discriminate.
      rewrite (simrel_inject_acc_carrier0 _ _ _ X).
      destruct (j23 b2) as [ [ ? ? ] | ] eqn:Y; try discriminate.
      rewrite (simrel_inject_acc_carrier1 _ _ _ Y).
      tauto.
    }
    intros b1 b3_ delta.
    rewrite <- EQ.
    rewrite <- EQ_.
    unfold Values.compose_meminj.
    destruct (j12 b1) as [ [ b2 ? ] | ] eqn:X.
    {
      rewrite (simrel_inject_acc_carrier0 _ _ _ X).
      destruct (j23 b2) as [ [ ? ? ] | ] eqn:Y; try discriminate.
      destruct (j23_ b2) as [ [ ? ? ] | ] eqn:Z; try discriminate.
      inversion 2; subst.
      exploit simrel_inject_acc_separated1; eauto.
      eapply (Mem.valid_block_inject_2 (mem := mwd D)) in X; eauto.
      unfold Mem.valid_block in X.
      intuition congruence.
    }
    destruct (j12_ b1) as [ [ b2 ? ] | ] eqn:Y; try discriminate.
    destruct (j23_ b2) as [ [ ? ? ] | ] eqn:Z; try discriminate.
    inversion 2; subst.
    exploit simrel_inject_acc_separated0; eauto.
    clear X.
    destruct 1.
    destruct (j23 b2) as [ [ b3 ? ] | ] eqn:NONE.
    {
      eapply (Mem.valid_block_inject_1 (mem := mwd D)) in NONE; eauto.
      unfold Mem.valid_block in NONE.
      congruence.
    }
    exploit simrel_inject_acc_separated1; eauto.
    intuition congruence.
  Qed.

  Lemma inject_compose p12 p23 (m1 m2 m3: mwd D):
    simrel_inject_match_mem p12 m1 m2 ->
    simrel_inject_match_mem p23 m2 m3 ->
    simrel_inject_match_mem (compose_meminj p12 p23) m1 m3.
  Proof.
    intros H H0.
    inversion H.
    inversion H0.
    generalize (compose_meminj_correct_strong p12 p23).
    intros (EQ & ? & ?).
    constructor; try congruence.
    rewrite <- EQ.
    eapply Mem.inject_compose; eauto.
  Qed.

  (* Relation with inject_neutral, to connect the CompCert caller's
     memory state with the target memory state via simulation. *)

  Lemma flat_inj_compose (m1 m2: mwd D) j1 j2:
    simrel_inject_match_mem j1 m1 m1 ->
    Mem.flat_inj (Mem.nextblock m1) = j1 ->
    simrel_inject_match_mem j2 m1 m2 ->
    compose_meminj j1 j2 = j2.
  Proof.
    intros H H0 H1.
    inversion H.
    inversion H1.
    generalize (compose_meminj_correct_strong j1 j2).
    intros (EQ & ? & ?).
    apply simrel_inject_world_eq; try congruence.
    rewrite <- EQ.
    apply functional_extensionality.
    intro b.
    unfold Values.compose_meminj.
    rewrite <- H0.
    unfold Mem.flat_inj.
    destruct (plt b (Mem.nextblock m1)) as [ | INVAL ].
    {
      destruct (j2 b) as [ [ ? ? ] | ] ; simpl; auto.
    }
    symmetry.
    destruct (j2 b) as [ [ ? ? ] | ] eqn:J2; auto.
    destruct INVAL.
    eapply Mem.valid_block_inject_1; eauto.
  Qed.

  (** XXX: it's not clear that this is used, but in any case it's
    broken at them moment. *)
  (*
  Lemma flat_inj_preserves_globals m:
    (forall b, block_is_global b -> Mem.valid_block m b) ->
    forall {F V: Type} (ge: Globalenvs.Genv.t F V),
      stencil_matches ge ->
      Events.meminj_preserves_globals ge (Mem.flat_inj (Mem.nextblock m)).
  Proof.
    intros H0 F V ge H1.
    red.
    split.
    {
      intros b H2.
      unfold Mem.flat_inj.
      destruct (plt b (Mem.nextblock m)) as [ | NE ]; auto.
      destruct NE.
      apply H0.
      erewrite stencil_matches_genv_next in H2; eauto.
      assumption.
    }
    intros b1 b2 delta H2 H3.
    unfold Mem.flat_inj in H3.
    destruct (plt b1 (Mem.nextblock m)); congruence.
  Qed.
   *)

End INJECT_COMPOSE.

(** * Wrap [simrel_inject] into a stronger version, for [ec_mem_inject] *)

Section STRONG_INJECT.
  Context `{Hmem: BaseMemoryModel}.
  Context {D: layerdata}.

  Record strong_inject_world: Type :=
    mk_strong_inject_world
      {
        strong_inject_meminj: simrel_inject_world;
        strong_inject_high: mwd D;
        strong_inject_low: mwd D;
        strong_inject_prop: simrel_inject_match_mem strong_inject_meminj strong_inject_high strong_inject_low
      }.

  Lemma strong_inject_world_eq mm1 mm2:
    strong_inject_meminj mm1 = strong_inject_meminj mm2 ->
    strong_inject_high mm1 = strong_inject_high mm2 ->
    strong_inject_low mm1 = strong_inject_low mm2 ->
    mm1 = mm2.
  Proof.
    intros H H0 H1.
    destruct mm1; destruct mm2; simpl in * |- * ; subst.
    f_equal;
      apply ProofIrrelevance.proof_irrelevance.
  Qed.

  Definition strong_inject (mm: strong_inject_world) (m m': mwd D): Prop :=
    m = strong_inject_high mm /\
    m' = strong_inject_low mm.

  Lemma strong_inject_intro' j m m' :
    simrel_inject_match_mem j m m' ->
    {
      mm | strong_inject mm m m' /\
           strong_inject_meminj mm = j
    }.
  Proof.
    intros H.
    exists (mk_strong_inject_world _ _ _ H).
    simpl.
    split; auto.
    split; auto.
  Qed.

  Lemma strong_inject_intro ge (j: Values.meminj) m1 m2:
    stencil_matches ge ->
    (forall id b, Senv.find_symbol ge id = Some b -> j b = Some (b, 0)) ->
    Mem.inject j m1 m2 ->
    { j_ | strong_inject j_ m1 m2 /\
           j = strong_inject_meminj j_ }.
  Proof.
    intros H H0 H1.
    generalize (simrel_inject_exists _ _ _ _  H H0 H1).
    destruct 1 as (j_ & INJ & EQ).
    subst.
    destruct (strong_inject_intro' _ _ _ INJ) as (? & ? & EQ).
    symmetry in EQ.
    esplit.
    split; eauto.
    (* coercion *) f_equal; eauto.
  Qed.

  Lemma strong_inject_elim' mm m m':
    strong_inject mm m m' ->
    simrel_inject_match_mem (strong_inject_meminj mm) m m'.
  Proof.
    destruct 1; subst.
    destruct mm; auto.
  Qed.

  Hint Resolve simrel_inject_match_mem_base strong_inject_elim' .

  Record strong_inject_acc (mm1 mm2: strong_inject_world): Prop :=
    strong_inject_acc_intro'
    {
      strong_inject_acc_elim' : simrel_inject_acc (strong_inject_meminj mm1) (strong_inject_meminj mm2);
      strong_inject_acc_unmapped: Mem.unchanged_on (Events.loc_unmapped (strong_inject_meminj mm1)) (strong_inject_high mm1) (strong_inject_high mm2);
      strong_inject_acc_out_of_reach: Mem.unchanged_on (Events.loc_out_of_reach (strong_inject_meminj mm1) (strong_inject_high mm1)) (strong_inject_low mm1) (strong_inject_low mm2);
      (* the following is necessary for the transitivity of Mem.unchanged_on *)
      strong_inject_acc_max_perm:
        forall b o p,
          Mem.valid_block (strong_inject_high mm1) b ->
          Mem.perm (strong_inject_high mm2) b o Max p ->
          Mem.perm (strong_inject_high mm1) b o Max p
    }.

  Local Instance strong_inject_acc_refl: Reflexive strong_inject_acc.
  Proof.
    constructor; try reflexivity; auto using (Mem.unchanged_on_refl (mem := mwd D)).
  Qed.

  Local Instance strong_inject_acc_trans: Transitive strong_inject_acc.
  Proof.
    red.
    intros x y z H H0.
    inversion H; subst.
    inversion H0; subst.
    constructor.
    + etransitivity; eauto.
    + eapply Mem.unchanged_on_trans_strong with (Q := Events.loc_unmapped (strong_inject_meminj y)); eauto.
      unfold Events.loc_unmapped.
      intros b H1 o H2.
      destruct ((strong_inject_meminj y) b) as [ [ ] | ] eqn:INJ ; auto.
      exfalso.
      exploit (simrel_inject_acc_separated (strong_inject_meminj x) (strong_inject_meminj y)); eauto.
      erewrite nextblock_high_match by apply strong_inject_prop.
      revert H1. clear. tauto.
    + eapply Mem.unchanged_on_trans_strong with (Q := Events.loc_out_of_reach (strong_inject_meminj y) (strong_inject_high y)); eauto.
      unfold Events.loc_out_of_reach.
      intros b H1 o H2 b0 delta H3.
      destruct ((strong_inject_meminj x) b0) as [ [ ] | ] eqn:INJ.
      - generalize INJ. intro INJ_.
        apply strong_inject_acc_elim'0 in INJ_.
        rewrite INJ_ in H3.
        inversion H3; clear H3; subst.
        intro ABSURD.
        eapply H2; eauto.
        eapply strong_inject_acc_max_perm0; eauto.
        clear INJ_.
        eapply Mem.valid_block_inject_1; eauto using strong_inject_prop.
      - intros _.
        exploit (simrel_inject_acc_separated (strong_inject_meminj x) (strong_inject_meminj y)); eauto.
        erewrite nextblock_low_match by apply strong_inject_prop.
        revert H1. clear. tauto.
    + intros b o p H1 H2.
      eapply strong_inject_acc_max_perm0; eauto.
      eapply strong_inject_acc_max_perm1; eauto.
      generalize (nextblock_high_le _ _ (strong_inject_acc_elim' _ _ H)).
      repeat erewrite nextblock_high_match by apply strong_inject_prop.
      unfold Mem.valid_block in *.
      xomega.
  Qed.

  Lemma strong_inject_acc_intro mm1 m1 m'1 (j2: Values.meminj) m2 m'2:
    strong_inject mm1 m1 m'1 ->
    Values.inject_incr (strong_inject_meminj mm1) j2 ->
    Events.inject_separated (strong_inject_meminj mm1) j2 m1 m'1 ->
    Mem.inject j2 m2 m'2 ->
    (forall b, Mem.valid_block m1 b -> Mem.valid_block m2 b) ->
    (forall b, Mem.valid_block m'1 b -> Mem.valid_block m'2 b) ->
    Mem.unchanged_on (Events.loc_unmapped (strong_inject_meminj mm1)) m1 m2 ->
    Mem.unchanged_on (Events.loc_out_of_reach (strong_inject_meminj mm1) m1) m'1 m'2 ->
    (forall b o p,
       Mem.valid_block m1 b ->
       Mem.perm m2 b o Max p ->
       Mem.perm m1 b o Max p) ->
    { mm2 |
      j2 = strong_inject_meminj mm2 /\
      strong_inject mm2 m2 m'2 /\
      strong_inject_acc mm1 mm2 }.
  Proof.
    intros H H0 H1 H2 H3 H4 H5 H6 H7.
    inversion H; subst.
    generalize (inject_separated_inject_incr _ _ _ _ _ _ (strong_inject_prop mm1) H0 H1 H2 H3 H4).
    destruct 1 as (j2_ & ? & INJ & INCR); subst.
    apply strong_inject_intro' in INJ.
    destruct INJ as (mm2 & INJ & ?); subst.
    esplit.
    split; eauto.
    split; auto.
    inversion INJ; subst.
    constructor; auto.
  Qed.

  Lemma strong_inject_acc_elim mm1 m1 m'1 mm2 m2 m'2:
    strong_inject mm1 m1 m'1 ->
    strong_inject mm2 m2 m'2 ->
    strong_inject_acc mm1 mm2 ->
    Values.inject_incr (strong_inject_meminj mm1) (strong_inject_meminj mm2) /\
    Events.inject_separated (strong_inject_meminj mm1) (strong_inject_meminj mm2) m1 m'1 /\
    (forall b, Mem.valid_block m1 b -> Mem.valid_block m2 b) /\
    (forall b, Mem.valid_block m'1 b -> Mem.valid_block m'2 b) /\
    Mem.unchanged_on (Events.loc_unmapped (strong_inject_meminj mm1)) m1 m2 /\
    Mem.unchanged_on (Events.loc_out_of_reach (strong_inject_meminj mm1) m1) m'1 m'2 /\
    (forall b o p,
       Mem.valid_block m1 b ->
       Mem.perm m2 b o Max p ->
       Mem.perm m1 b o Max p).
  Proof.
    intros H H0 H1.
    inversion H; subst.
    inversion H0; subst.
    inversion H1; subst.
    inversion strong_inject_acc_elim'0; subst.
    split; auto.
    split.
    { eapply simrel_inject_acc_inject_separated; eauto. }
    repeat erewrite nextblock_low_match in nextblock_low_le0 by apply strong_inject_prop.
    repeat erewrite nextblock_high_match in nextblock_high_le0 by apply strong_inject_prop.
    split.
    { unfold Mem.valid_block. intro. xomega. }
    split; auto.
    unfold Mem.valid_block. intro. xomega.
  Qed.

  Definition simrel_strong_inject_ops :=
    {|
      simrel_world := strong_inject_world;
      simrel_acc := {| Structures.le := strong_inject_acc |};
      simrel_undef_matches_values_bool := true;
      simrel_undef_matches_block p b := True;
      simrel_new_glbl := nil;
      simrel_meminj := strong_inject_meminj;
      match_mem := strong_inject
    |}.

  Lemma match_ptr_strong_inject'  p:
    match_ptr simrel_strong_inject_ops p =
    match_ptr (simrel_inject_ops (D:=D)) (strong_inject_meminj p).
  Proof.
    eapply functional_extensionality; intros [b1 o1].
    eapply functional_extensionality; intros [b2 o2].
    eapply prop_ext.
    split; inversion 1; subst; constructor; auto.
  Qed.

  Lemma match_ptrbits_strong_inject'  p:
    match_ptrbits simrel_strong_inject_ops p =
    match_ptrbits (simrel_inject_ops (D:=D)) (strong_inject_meminj p).
  Proof.
    eapply functional_extensionality; intros [b1 o1].
    eapply functional_extensionality; intros [b2 o2].
    eapply prop_ext.
    split; inversion 1; subst; constructor; auto.
  Qed.

  Lemma match_block_strong_inject'  p:
    match_block simrel_strong_inject_ops p =
    match_block (simrel_inject_ops (D:=D)) (strong_inject_meminj p).
  Proof.
    reflexivity.
  Qed.

  Lemma match_val_strong_inject' p:
    match_val simrel_strong_inject_ops p =
    match_val (simrel_inject_ops (D:=D)) (strong_inject_meminj p).
  Proof.
    eapply functional_extensionality; intro v1.
    eapply functional_extensionality; intro v2.
    eapply prop_ext.
    split; inversion 1; subst; constructor; eauto.
    + rewrite <- match_ptrbits_strong_inject'. assumption.
    + rewrite -> match_ptrbits_strong_inject'. assumption.
  Qed.

  Lemma match_val_strong_inject p:
    match_val simrel_strong_inject_ops p =
    Val.inject (strong_inject_meminj p).
  Proof.
    rewrite match_val_strong_inject'.
    rewrite match_val_simrel_inject.
    reflexivity.
  Qed.

  Lemma match_memval_strong_inject' p:
    match_memval simrel_strong_inject_ops p =
    match_memval (simrel_inject_ops (D:=D)) (strong_inject_meminj p).
  Proof.
    eapply functional_extensionality; intro v1.
    eapply functional_extensionality; intro v2.
    eapply prop_ext.
    split; inversion 1; subst; constructor;
    rewrite ?match_val_strong_inject' in *; eauto.
  Qed.

  Lemma match_memval_strong_inject p:
    match_memval simrel_strong_inject_ops p =
    memval_inject (strong_inject_meminj p).
  Proof.
    rewrite match_memval_strong_inject'.
    rewrite match_memval_simrel_inject.
    reflexivity.
  Qed.

  Global Instance simrel_strong_inject_prf:
    SimulationRelation simrel_strong_inject_ops.
  Proof.
    assert (Heqsub: forall A B, subrel (@eqrel A B) (@subrel A B)).
    {
      intros A B x y H.
      repeat red in H.
      tauto.
    }
    constructor.

    (** Compatibility with order *)
    - constructor; typeclasses eauto.
    - simpl.
      solve_monotonic.
    - repeat red.
      intros x y H a.
      simpl.
      destruct ((strong_inject_meminj x) a) as [ [ ] | ] eqn:EQ; try now constructor.
      apply H in EQ.
      rewrite EQ.
      reflexivity.

    (** Properties of [simrel_meminj] *)
    - constructor.
    - constructor.
    - simpl; trivial.
    - simpl; trivial.
    - simpl; trivial.
    - intro. apply simrel_inject_globals.

    (** [Genv.init_mem]: reuse the proof of simrel_inject *)
    - intros F V p1 p2 Hp.
      apply (simrel_init_mem (D1:=D) (D2:=D) (SimulationRelation := simrel_inject_prf)) in Hp.
      inversion Hp ; clear Hp ; subst; try now constructor.
      match goal with
        K: (rexists w: simrel_world simrel_inject_ops, match_mem _ w)%rel ?x ?y |- _ =>
        destruct K as [w Hm];
          rename x into m1;
          rename y into m2
      end.
      apply strong_inject_intro' in Hm.
      destruct Hm as (j & INJ & Hj).
      subst.
      constructor.
      exists j.
      assumption.

    (** [Mem.alloc]: redo the proof, because of stronger [le] *)
    - repeat red.
      intros p x y H a a0.
      destruct (Mem.alloc x _ _) eqn:Halloc1.
      edestruct (Mem.alloc_parallel_inject (mem := mwd D)) as (j2 & ? & ? & Halloc2 & INJ & INCR & J & ?); try eassumption; try reflexivity; eauto.
      edestruct strong_inject_acc_intro as  (mm2 & ? & INJ_ & INCR_);
      eauto using (Mem.valid_block_alloc (mem := mwd D)).
      + red.
        intros b1 b2 delta H1 H2.
        destruct (peq b1 b) as [ | NE ].
        {
          subst.
          rewrite J in H2. inversion H2; clear H2; subst.
          eauto using (Mem.fresh_block_alloc (mem := mwd D)).
        }
        apply H0 in NE.
        congruence.
      + eapply Mem.alloc_unchanged_on; eauto.
      + eapply Mem.alloc_unchanged_on; eauto.
      + intros.
        eapply Mem.perm_alloc_4; eauto.
        intro; subst.
        eapply (Mem.fresh_block_alloc x); eauto.
      + subst j2.
        rewrite Halloc2.
        econstructor; eauto.
        split; simpl; eauto.
        split; eauto.

    (** [Mem.free]: redo the proof, because of stronger [le] *)
    - simpl.
      intros p x y H x0 y0 H0.
      inversion H0; subst.
      inversion H1; subst.
      simpl.
      destruct (Mem.free x _ _ _) eqn:Hfree1; try now solve_monotonic.
      edestruct (free_parallel_inject (D:=D)) as (? & Hfree2 & INJ); eauto.
      replace (ofs1 + delta + sz) with (ofs1 + sz + delta) by omega.
      rewrite Hfree2.
      edestruct strong_inject_acc_intro as  (mm2 & ? & INJ_ & INCR_);
      eauto using (Mem.valid_block_free_1 (mem := mwd D)).
      + red. intros; congruence.
      + eapply Mem.free_unchanged_on; eauto.
        intros i H2.
        unfold Events.loc_unmapped.
        simpl in *.
        congruence.
      + eapply Mem.free_unchanged_on; eauto.
        intros i H2.
        unfold Events.loc_out_of_reach.
        intro ABSURD.
        eapply ABSURD; eauto.
        apply Mem.perm_cur_max.
        eapply Mem.perm_implies; [ eapply Mem.free_range_perm; eauto; omega | ].
        constructor.
      + eauto using (Mem.perm_free_3 (mem := mwd D)).
      + solve_monotonic.

    (** [Mem.load]: reuse the proof of simrel_inject *)
    - intros p a x y H.
      rewrite match_ptr_strong_inject'.
      rewrite match_val_strong_inject'.
      eapply (simrel_load (R := inj) (strong_inject_meminj p)); eauto.
      apply strong_inject_elim'; auto.

    (** [Mem.store]: redo the proof, because of stronger [le] *)
    - intro p.
      rewrite match_val_strong_inject.
      simpl.
      intros a x y H x0 y0 H0 x1 y1 H1.
      inversion H0; subst.
      simpl.
      destruct (Mem.store _ x _ _ _) eqn:Hstore1; try now solve_monotonic.
      simpl in * |- * .
      edestruct (Mem.store_mapped_inject (mem := mwd D)) as (? & Hstore2 & INJ); eauto.
      rewrite Hstore2.
      edestruct strong_inject_acc_intro as  (mm2 & ? & INJ_ & INCR_);
      eauto using (Mem.store_valid_block_1 (mem := mwd D)).
      + red. intros; congruence.
      + eapply Mem.store_unchanged_on; eauto.
        intros i H3.
        unfold Events.loc_unmapped.
        congruence.
      + eapply Mem.store_unchanged_on; eauto.
        intros i H3.
        unfold Events.loc_out_of_reach.
        intro ABSURD.
        eapply ABSURD; eauto.
        apply Mem.perm_cur_max.
        eapply Mem.perm_implies; [ eapply Mem.store_valid_access_3; eauto; omega | ].
        constructor.
      + eauto using (Mem.perm_store_2 (mem := mwd D)).
      + solve_monotonic.

    (** [Mem.loadbytes]: reuse the proof of simrel_inject *)
    - intros p a x y H.
      rewrite match_ptr_strong_inject'.
      rewrite match_memval_strong_inject'.
      eapply (simrel_loadbytes (R := inj) (strong_inject_meminj p)); eauto.
      apply strong_inject_elim'; auto.

    (** [Mem.storebytes]: redo the proof, because of stronger [le] *)
    - intro p.
      rewrite match_memval_strong_inject.
      simpl.
      intros x y H x0 y0 H0 x1 y1 H1.
      inversion H0; subst.
      simpl.
      destruct (Mem.storebytes x _ _ _) eqn:Hsb1; try now solve_monotonic.
      edestruct (Mem.storebytes_mapped_inject (mem := mwd D)) as (? & Hsb2 & INJ); eauto.
      { rewrite CompcertStructures.list_forall2_list_rel; eassumption. }
      rewrite Hsb2.
      assert (length x1 = length y1) as LEN by solve_monotonic.
      edestruct strong_inject_acc_intro as  (mm2 & ? & INJ_ & INCR_);
      eauto using (Mem.storebytes_valid_block_1 (mem := mwd D)).
      + red. intros; congruence.
      + eapply Mem.storebytes_unchanged_on; eauto.
        unfold Events.loc_unmapped.
        simpl in *.
        intros; congruence.
      + eapply Mem.storebytes_unchanged_on; eauto.
        rewrite <- LEN.
        intros i H3.
        unfold Events.loc_out_of_reach.
        intro ABSURD.
        eapply ABSURD; eauto.
        apply Mem.perm_cur_max.
        eapply Mem.perm_implies; [ eapply Mem.storebytes_range_perm; eauto; omega | ].
        constructor.
      + eauto using (Mem.perm_storebytes_2 (mem := mwd D)).
      + solve_monotonic.

    (** [Mem.perm]: reuse the proof of simrel_inject *)
    - intros p x y H.
      rewrite match_ptr_strong_inject'.
      eapply (simrel_perm (R := inj) (strong_inject_meminj p)); simpl in *; eauto.

    (** [Mem.valid_block]: reuse the proof of simrel_inject *)
    - intros p x y H.
      rewrite match_block_strong_inject'.
      eapply (simrel_valid_block (R := inj) (strong_inject_meminj p)); simpl in *; eauto.

    (** [Mem.different_pointers_inject] *)
    - eauto using (Mem.different_pointers_inject (mem := mwd D)).

    (** [Mem.weak_valid_pointer_inject_val] *)
    - inversion 3; subst.
      eapply Mem.weak_valid_pointer_inject_val; eauto.

    (** [Mem.weak_valid_pointer_address_inject_weak] *)
    - intros p m1 m2 b1 b2 delta H H0.
      exists (Ptrofs.unsigned (Ptrofs.repr delta)).
      intros ofs1 K.
      rewrite Ptrofs.add_unsigned.
      apply Ptrofs.unsigned_repr.
      eapply (Mem.weak_valid_pointer_inject_no_overflow (mem := mwd D)); eauto.

    (** [Mem.address_inject] *)
    - intro.
      eauto using (Mem.address_inject (mem := mwd D)).

    (** [Mem.aligned_area_inject] *)
    - intro.
      eauto using (Mem.aligned_area_inject (mem := mwd D)).

    (** [Mem.disjoint_or_equal_inject] *)
    - intro.
      eauto using (Mem.disjoint_or_equal_inject (mem := mwd D)).
  Qed.

  Definition simrel_strong_inject :=
    {|
      simrel_ops := simrel_strong_inject_ops
    |}.

End STRONG_INJECT.


(* Copyright (c) 2017, the Dart project authors.  Please see the AUTHORS file
 * for details. All rights reserved. Use of this source code is governed by a
 * BSD-style license that can be found in the LICENSE file. *)

Require Import Utf8.
Require Import ClassTestTypes.
Require Import InvariantVoidnessPreservation.

Module MyVoidnessPreservation :=
  InvariantVoidnessPreservation.VoidnessPreservationBase
    Dynamics.NormalDynamics.
Import MyVoidnessPreservation.

(* -------------------- Examples from email threads -------------------- *)

(* A<Object> x = new A<void>(); // No *)
Goal ~(VoidnessPreserves dt_A_void dt_A_Object).
  unfold not. intro H. inversion H.
  - inversion H2. inversion H5.
    + inversion H8. intuition H14.
    + inversion H8.
      * inversion H14. inversion H20.
      * inversion H13. inversion H17.
Qed.

(* A<dynamic> x = new A<void>(); // Yes *)
Goal VoidnessPreserves dt_A_void dt_A_dynamic.
  apply vp_class. apply vctsp_cons.
  - apply vctp_some; apply vctps_first; auto.
  - apply vctsp_cons; auto.
    apply vctp_some; apply vctps_rest; apply vctps_first; auto.
Qed.

(* A<Object> x = new A<dynamic>(); // Yes *)
Goal VoidnessPreserves dt_A_dynamic dt_A_Object.
  apply vp_class. apply vctsp_cons.
  - apply vctp_some; apply vctps_first; auto.
  - apply vctsp_cons; auto.
    apply vctp_some. apply vctps_rest. apply vctps_first; auto.
Qed.

(* A<void> x = new A<dynamic>(); // voidV = dynamicV, Yes *)
Goal VoidnessPreserves dt_A_dynamic dt_A_void.
  apply vp_class. apply vctsp_cons.
  - apply vctp_some. apply vctps_first; auto.
  - apply vctsp_cons; auto.
    apply vctp_some. apply vctps_rest. apply vctps_first; auto.
Qed.

(* A<void> x = new A<Object>(); // voidV = objectV, No *)
Goal ~(VoidnessPreserves dt_A_Object dt_A_void).
  intro H. inversion H.
  - inversion H2. inversion H5.
    + inversion H8. intuition H14.
    + inversion H8.
      * inversion H16. inversion H20.
      * inversion H13. inversion H17.
Qed.

(* dynamic x = new A<void>(); // Yes *)
Goal VoidnessPreserves dt_A_void dt_dynamic.
  auto.
Qed.

(* Object x = new A<void>(); // Yes *)
Goal VoidnessPreserves dt_A_void dt_Object.
  apply vp_class. apply vctsp_cons.
  - apply vctp_gone. apply vctg_cons. discriminate. apply vctg_nil.
  - apply vctsp_cons; auto.
    apply vctp_some. apply vctps_first; auto.
Qed.

(* Iterable<void> x = new List<void>(); // Yes *)
Goal VoidnessPreserves dt_List_void dt_Iterable_void.
  apply vp_class. apply vctsp_cons.
  - apply vctp_gone; apply vctg_cons. discriminate.
    apply vctg_cons. discriminate.
    auto.
  - apply vctsp_cons.
    + apply vctp_some. apply vctps_first. auto. auto.
    + apply vctsp_cons; auto. apply vctp_some. apply vctps_rest.
      apply vctps_first; auto.
Qed.

(* List<void> x = new Iterable<void>(); // Yes *)
Goal VoidnessPreserves dt_Iterable_void dt_List_void.
  apply vp_class. apply vctsp_cons.
  - apply vctp_some. apply vctps_rest. apply vctps_first; auto.
  - apply vctsp_cons; auto.
    apply vctp_some. apply vctps_rest. apply vctps_rest.
    apply vctps_first; auto.
Qed.

(* Iterable<Object> x = new List<void>(); // No *)
Goal ~(VoidnessPreserves dt_List_void dt_Iterable_Object).
  intro H. inversion H.
  - inversion H2. inversion H7. inversion H10.
    + inversion H13. intuition H19.
    + inversion H13.
      * inversion H19. inversion H25.
      * inversion H18. inversion H22.
Qed.

(* List<Object> x = new Iterable<void>(); // No *)
Goal ~(VoidnessPreserves dt_Iterable_void dt_List_Object).
  intro H. inversion H.
  - inversion H2. inversion H5.
    + inversion H8. inversion H17. intuition H21.
    + inversion H8. inversion H13.
      * inversion H18. inversion H24.
      * inversion H17. inversion H21.
Qed.


From sflib Require Import sflib.
Require Import Coq.Classes.RelationClasses.
From Fairness Require Import Axioms NatStructsLarge.
From Fairness Require Import PCM.
Require Import String Lia Program.

Set Implicit Arguments.

Module NatMapRALarge.
  Section MAP.
    Variable A: Type.

    Definition car := option (NatMap.t A).

    Definition unit: car := Some (NatMap.empty A).

    Definition add (m0 m1: car): car :=
      match m0, m1 with
      | Some m0, Some m1 =>
          if (NatStructsLarge.disjoint m0 m1) then Some (NatMapP.update m0 m1) else None
      | _, _ => None
      end.

    Definition wf (m: car): Prop :=
      match m with
      | None => False
      | _ => True
      end.

    Definition core (m: car): car := unit.

    Global Program Instance t: URA.t := {
        car := car;
        unit := unit;
        _add := add;
        _wf := wf;
        core := core;
      }
    .
    Next Obligation.
      unfold add. des_ifs.
      { f_equal. apply disjoint_union_comm. apply disjoint_true_iff; auto. }
      { rewrite disjoint_comm in Heq. clarify. }
      { rewrite disjoint_comm in Heq. clarify. }
    Qed.
    Next Obligation.
      unfold add. des_ifs.
      { f_equal. rewrite union_assoc. auto. }
      { rewrite disjoint_true_iff in *.
        apply Disjoint_union in Heq0. des.
        hexploit (proj2 (Disjoint_union t2 t t3)).
        { split.
          { apply NatMapP.Disjoint_sym. auto. }
          { apply NatMapP.Disjoint_sym. auto. }
        }
        i. apply NatMapP.Disjoint_sym in H.
        apply disjoint_true_iff in H. clarify.
      }
      { rewrite disjoint_true_iff in *.
        apply Disjoint_union in Heq0. des.
        apply disjoint_true_iff in Heq0. clarify.
      }
      { rewrite disjoint_true_iff in *.
        apply NatMapP.Disjoint_sym in Heq2.
        apply Disjoint_union in Heq2. des.
        hexploit (proj2 (Disjoint_union t t3 t2)).
        { split; auto. apply NatMapP.Disjoint_sym. auto. }
        i. apply disjoint_true_iff in H. clarify.
      }
      { rewrite disjoint_true_iff in *.
        apply NatMapP.Disjoint_sym in Heq1.
        apply Disjoint_union in Heq1. des.
        apply NatMapP.Disjoint_sym in Heq3.
        apply disjoint_true_iff in Heq3. clarify.
      }
    Qed.
    Next Obligation.
      unseal "ra". unfold add, unit. des_ifs.
      hexploit Disjoint_empty. i.
      apply disjoint_true_iff in H. rewrite H in *. clarify.
    Qed.
    Next Obligation.
      unseal "ra". ss.
    Qed.
    Next Obligation.
      unseal "ra". unfold add in *. des_ifs.
    Qed.
    Next Obligation.
      unseal "ra". ss. des_ifs. f_equal.
      rewrite union_empty. auto.
    Qed.
    Next Obligation.
      exists unit. unseal "ra". unfold add, core, unit. des_ifs.
    Qed.

    Definition singleton (k: nat) (a: A): car := Some (NatMap.add k a (NatMap.empty A)).

    Lemma singleton_unique k0 a0 k1 a1
          (WF: URA.wf (singleton k0 a0 ⋅ singleton k1 a1))
      :
      k0 <> k1.
    Proof.
      ii. ur in WF. des_ifs.
      rewrite disjoint_true_iff in *.
      eapply Heq. split.
      { apply NatMapP.F.add_in_iff. eauto. }
      { apply NatMapP.F.add_in_iff. eauto. }
    Qed.

    Lemma extends_iff m0 m1
      :
      URA.extends (Some m0) (Some m1)
      <->
        (forall k a (FIND: NatMap.find k m0 = Some a), NatMap.find k m1 = Some a).
    Proof.
      split.
      { ii. rr in H. des. ur in H. des_ifs.
        apply NatMap.find_1. apply NatMapP.update_mapsto_iff.
        apply NatMap.find_2 in FIND. right. split; auto.
        apply disjoint_true_iff in Heq.
        ii. eapply Heq; eauto. split; eauto.
        apply NatMapP.F.in_find_iff. apply NatMap.find_1 in FIND. ii. clarify.
      }
      { i. exists (Some (NatMapP.diff m1 m0)).
        ur. des_ifs.
        { f_equal. apply nm_eq_is_equal.
          apply NatMapP.F.Equal_mapsto_iff. i.
          rewrite NatMapP.update_mapsto_iff.
          rewrite NatMapP.diff_mapsto_iff. split; i; des; auto.
          { apply NatMap.find_2. eapply H.
            apply NatMap.find_1. auto.
          }
          { destruct (NatMap.find k m0) eqn:FIND.
            { apply NatMap.find_1 in H0.
              hexploit H; eauto. i. clarify.
              right. split; auto.
              { apply NatMap.find_2; auto. }
              { ii. apply NatMapP.diff_in_iff in H0. des.
                eapply H2. apply NatMapP.F.in_find_iff. ii. clarify.
              }
            }
            { left. split; auto. ii.
              apply NatMapP.F.in_find_iff in H1. ss.
            }
          }
        }
        { apply disjoint_false_iff in Heq.
          exfalso. eapply Heq. ii. des.
          apply NatMapP.diff_in_iff in H1. des. ss.
        }
      }
    Qed.

    Lemma extends_singleton_iff m k a
      :
      URA.extends (singleton k a) (Some m)
      <->
        (NatMap.find k m = Some a).
    Proof.
      unfold singleton. rewrite extends_iff. split; i.
      { eapply H. apply nm_find_add_eq. }
      { rewrite NatMapP.F.add_o in FIND. des_ifs. }
    Qed.

    Lemma add_local_update m k a
          (NONE: NatMap.find k m = None)
      :
      Auth.local_update (Some m) unit (Some (NatMap.add k a m)) (singleton k a).
    Proof.
      ii. des. ur in FRAME. des_ifs. split; ss.
      { ur. ss. }
      rr. ur. des_ifs.
      { apply disjoint_true_iff in Heq.
        apply NatMapP.Disjoint_sym in Heq.
        apply Disjoint_add in Heq. des.
        f_equal. eapply eq_ext_is_eq. ii.
        rewrite ! NatMapP.F.add_mapsto_iff.
        rewrite ! NatMapP.update_mapsto_iff.
        rewrite ! NatMapP.F.add_mapsto_iff.
        rewrite NatMapP.F.empty_mapsto_iff.
        rewrite <- NatMapP.F.not_find_in_iff in NONE.
        rewrite NatMapP.update_in_iff in NONE.
        split; i; des; subst; auto.
        right. split; auto. ii. subst.
        eapply Heq. apply NatMapP.F.in_find_iff.
        apply NatMap.find_1 in H. ii. clarify.
      }
      { exfalso. apply disjoint_false_iff in Heq. apply Heq.
        apply NatMapP.Disjoint_sym.
        eapply Disjoint_add. split.
        { apply NatMapP.F.not_find_in_iff in NONE.
          rewrite NatMapP.update_in_iff in NONE.
          ii. eapply NONE; eauto.
        }
        { apply Disjoint_empty. }
      }
    Qed.

    Lemma remove_local_update m k a
      :
      Auth.local_update (Some m) (singleton k a) (Some (NatMap.remove k m)) unit.
    Proof.
      ii. des. ur in FRAME. des_ifs. split; ss.
      { ur. ss. }
      rr. unfold unit. ur. f_equal.
      apply disjoint_true_iff in Heq.
      apply NatMapP.Disjoint_sym in Heq.
      apply Disjoint_add in Heq. des.
      eapply eq_ext_is_eq. ii.
      rewrite ! NatMapP.F.remove_mapsto_iff.
      rewrite ! NatMapP.update_mapsto_iff.
      rewrite ! NatMapP.F.add_mapsto_iff.
      rewrite NatMapP.F.empty_mapsto_iff.
      split; i; des; subst; auto.
      { splits; auto. ii. subst. eapply Heq.
        apply NatMapP.F.in_find_iff.
        apply NatMap.find_1 in H. ii. clarify.
      }
      { split; auto. right; auto. }
    Qed.
  End MAP.
End NatMapRALarge.


Require Import Coq.Lists.List.
Set Implicit Arguments.
Generalizable All Variables.
Local Open Scope list_scope.

CoInductive stream X := cons (x : X) (xs : stream X).

Fixpoint stream_nth {X} (ls : stream X) (n : nat) : X
  := match n, ls with
       | 0, cons x xs => x
       | S n', cons x xs => stream_nth xs n'
     end.

Fixpoint take {X} (n : nat) (ls : stream X) : list X
  := match n, ls with
       | 0, _ => nil
       | S n', cons x xs => x::take n' xs
     end.

Inductive BotResult := C | D.
Definition opposite_result (x : BotResult) : BotResult
  := match x with C => D | D => C end.

Inductive MBot :=
| MC
| MD
| MODAL_BASED_ON (tests : list ((*test_bot:*)MBot * (*on_bot:*) MBot))
                 (on_results : list BotResult -> BotResult)
| OtherMBot (delay : nat)
| SelfMBot (delay : nat)
| CompleteMBot (b : MBot)
| WaitMBot (b : MBot).

Fixpoint iter {X} (n : nat) (f : X -> X) : X -> X
  := fun x => match n with
                | 0 => x
                | S n' => f (iter n' f x)
              end.

Fixpoint replace_self_other_with (with_self_b with_other_b in_b : MBot) : MBot
  := match in_b with
       | MC => MC
       | MD => MD
       | MODAL_BASED_ON tests f
         => MODAL_BASED_ON (List.map (fun b1b2 =>
                                        (replace_self_other_with with_self_b with_other_b (fst b1b2),
                                         replace_self_other_with with_self_b with_other_b (snd b1b2))) tests) f
       | OtherMBot delay => iter delay WaitMBot with_other_b
       | SelfMBot delay => iter delay WaitMBot with_self_b
       | CompleteMBot b' => CompleteMBot b'
       | WaitMBot b => WaitMBot (replace_self_other_with with_self_b with_other_b b)
     end.

Fixpoint fold_and_res (ls : list BotResult) : BotResult
  := match ls with
       | nil => C
       | C::xs => fold_and_res xs
       | D::_ => D
     end.

Delimit Scope mbot_scope with mbot.
Bind Scope mbot_scope with MBot.
Local Open Scope mbot_scope.

Definition MKripkeFrame'
           (MKripkeFrame : nat -> MBot -> MBot -> BotResult * BotResult)
           (frame_index : nat)
           (b1 : MBot) (b2 : MBot)
: BotResult * BotResult
  := match frame_index with
       | 0 => (C, C)
       | S n' =>
         (match b1 with
            | MC => C
            | MD => D
            | SelfMBot delay
              => match delay with
                   | 0 => fst (MKripkeFrame n' b1 b2)
                   | S d' => fst (MKripkeFrame n' (SelfMBot d') b2)
                 end
            | OtherMBot delay
              => match delay with
                   | 0 => snd (MKripkeFrame n' b1 b2)
                   | S d' => fst (MKripkeFrame n' (OtherMBot d') b2)
                 end
            | MODAL_BASED_ON ls f =>
              f (List.map
                   (fun b1b2 =>
                      fst (MKripkeFrame
                             n'
                             (replace_self_other_with b1 b2 (fst b1b2))
                             (replace_self_other_with b1 b2 (snd b1b2))))
                   ls)
            | CompleteMBot b => fst (MKripkeFrame n' (replace_self_other_with b1 b2 b) b2)
            | WaitMBot b => fst (MKripkeFrame n' (replace_self_other_with b1 b2 b) b2)
          end,
          match b2 with
            | MC => C
            | MD => D
            | SelfMBot delay
              => match delay with
                   | 0 => fst (MKripkeFrame n' b2 b1)
                   | S d' => fst (MKripkeFrame n' (SelfMBot d') b1)
                 end
            | OtherMBot delay
              => match delay with
                   | 0 => snd (MKripkeFrame n' b2 b1)
                   | S d' => fst (MKripkeFrame n' (OtherMBot d') b1)
                 end
            | MODAL_BASED_ON ls f =>
              f (List.map
                   (fun b1b2 =>
                      fst (MKripkeFrame
                             n'
                             (replace_self_other_with b2 b1 (fst b1b2))
                             (replace_self_other_with b2 b1 (snd b1b2))))
                   ls)
            | CompleteMBot b => fst (MKripkeFrame n' (replace_self_other_with b2 b1 b) b1)
            | WaitMBot b => fst (MKripkeFrame n' (replace_self_other_with b2 b1 b) b1)
          end)
     end.

Fixpoint MKripkeFrame (frame_index : nat) (b1 : MBot) (b2 : MBot)
: BotResult * BotResult
  := MKripkeFrame' MKripkeFrame frame_index b1 b2.

Lemma MKripkeFrame_sym
: forall n b1 b2,
    MKripkeFrame n b1 b2 = ((fun x => (snd x, fst x)) (MKripkeFrame n b2 b1)).
Proof.
  induction n; [ reflexivity | ].
  pose proof (fun b1 b2 => f_equal (@fst _ _) (IHn b1 b2)) as IHn'.
  simpl in IHn'.
  destruct b1, b2; simpl; try reflexivity; try rewrite IHn'; try reflexivity.
Qed.

CoFixpoint MKripkeFrames_from (n : nat) (b1 : MBot) (b2 : MBot) : stream (BotResult * BotResult)
  := cons (MKripkeFrame n b1 b2) (MKripkeFrames_from (S n) b1 b2).

Definition CooperateMBot : MBot := CompleteMBot MC.
Definition DefectMBot : MBot := CompleteMBot MD.
Definition OppositeMBotOf (b : MBot) : MBot := MODAL_BASED_ON
                                                 ((b, SelfMBot 0)::nil)
                                                 (fun res => opposite_result (fold_and_res res)).
Definition OppositeMBot := CompleteMBot (OppositeMBotOf (OtherMBot 0)).
Notation "B0 /\\ B1 /\\ .. /\\ Bn"
  := (MODAL_BASED_ON
        (Datatypes.cons B0%mbot (Datatypes.cons B1%mbot .. (Datatypes.cons Bn%mbot nil) .. ))
        fold_and_res)
       (at level 80, right associativity)
     : mbot_scope.

Notation CmB := CooperateMBot.
Notation DmB := DefectMBot.
Notation "~ B" := (OppositeMBotOf B) : mbot_scope.
Definition FairMBot : MBot := CompleteMBot (OtherMBot 0).
Notation FmB := FairMBot.
Definition PrudentMBot : MBot := CompleteMBot ((OtherMBot 0, SelfMBot 0) /\\ (~OtherMBot 1, DmB)).
Definition TrollMBot : MBot := CompleteMBot (MODAL_BASED_ON
                                               ((OtherMBot 0, DmB)::nil)
                                               (fun res => opposite_result (fold_and_res res))).

Definition IsEventually (b : MBot * MBot) (r : BotResult * BotResult)
  := exists n, forall m, MKripkeFrame (n + m) (fst b) (snd b) = r.

Definition IsEventually_fst (b : MBot * MBot) (r : BotResult)
  := exists n, forall m, fst (MKripkeFrame (n + m) (fst b) (snd b)) = r.

Definition IsUnexploitable (b : MBot)
  := forall b', ~IsEventually (b, b') (C, D).
Definition IsHappy (b : MBot)
  := IsEventually (b, b) (C, C).
Definition IsGood (b : MBot)
  := IsUnexploitable b /\ IsHappy b
     /\ IsEventually (b, PrudentMBot) (C, C)
     /\ IsEventually (b, FairMBot) (C, C).

Lemma CmB_C : forall b, IsEventually_fst (CmB, b) C.
Proof. intro b; exists 1; intro m; revert b; induction m; reflexivity. Qed.
Lemma DmB_D : forall b, IsEventually_fst (DmB, b) D.
Proof. intro b; exists 2; intro m; revert b; induction m; reflexivity. Qed.

Lemma Lob (b1 b2 : MBot)
: (forall m, MKripkeFrame m b1 b2 = (C, C) -> MKripkeFrame (S m) b1 b2 = (C, C))
  -> forall m, MKripkeFrame m b1 b2 = (C, C).
Proof.
  intro IH; induction m.
  { reflexivity. }
  { apply IH, IHm. }
Qed.

Lemma helper x y : (forall m, MKripkeFrame m x y = (C, C)) -> (forall m, (fst (MKripkeFrame m x y), fst (MKripkeFrame m x y)) = (C, C)).
Proof.
  intros H m; rewrite !H; reflexivity.
Qed.

Lemma FairMBot_Happy : IsHappy FairMBot.
Proof.
  exists 3; simpl.
  apply helper.
  induction m; simpl in *; trivial; rewrite IHm; reflexivity.
Qed.

Eval compute in MKripkeFrame 2 PrudentMBot PrudentMBot.
Eval compute in MKripkeFrame 2 PrudentMBot DmB.

Goal nat -> True.
  intro m.
  pose (MKripkeFrame (3 + m) PrudentMBot PrudentMBot) as p.
  simpl in p.
  destruct m.
  change (MKripkeFrame ?x) with (MKripkeFrame' MKripkeFrame x) in p.
  unfold MKripkeFrame' in p.

(*Class ClassOfMBots := is_good_bot : MBot -> Prop.
Existing Class is_good_bot.
Class IsGoodClass (C : ClassOfMBots)
  := bot_result : forall b, `{is_good_bot b} -> stream MBotResult.
Arguments bot_result {C _} b {_}.

Definition action_on_frame `{@IsGoodClass cls} (b : MBot) {g : is_good_bot b}
         (frame_index : nat) : MBotResult
  := stream_nth (bot_result b _) frame_index.

(*| BASED_ON (test_bot : Bot) (on_bot : Bot)
           (using_results : stream BotResult -> Bot)
| BASED_ON_PREFIX_THEN (test_bot : Bot) (on_bot : Bot) (first_n : nat)
                       (using_results : list BotResult -> Bot)*)
*)


From stdpp Require Import tactics.
From iris.bi Require Import bi.
From iris.prelude Require Import options.
From transfinite.base_logic Require Import upred bi iprop.

Section persistent_pred.
  Context `{SI: indexT}.
  Context (A : Type) (PROP : bi).
  Context `{Hcont : @BoundedLimitPreserving _ _ _ (@Persistent SI PROP)}.

  (* The domain of semantic types: persistent Iris predicates type A. *)
  Record persistent_pred := PersPred {
    pers_pred_car :> A → PROP;
    pers_pred_persistent x : Persistent (pers_pred_car x)
  }.
  Local Arguments PersPred _%I {_}.
  Global Existing Instances pers_pred_persistent.

  Local Instance persistent_pred_equiv : Equiv persistent_pred :=
    λ Φ Φ', ∀ x, Φ x ≡ Φ' x.
  Local Instance persistent_pred_dist : Dist persistent_pred :=
    λ n Φ Φ', ∀ x, Φ x ≡{n}≡ Φ' x.
  Definition persistent_pred_ofe_mixin : OfeMixin persistent_pred.
  Proof. by apply (iso_ofe_mixin (pers_pred_car : _ → A -d> _)). Qed.
  Canonical Structure persistent_predO :=
    Ofe persistent_pred persistent_pred_ofe_mixin.

  Global Instance persistent_pred_cofe : Cofe persistent_predO.
  Proof using Hcont.
    unshelve eapply (iso_cofe_subtype' (λ Φ : A -d> PROP, ∀ w, Persistent (Φ w))
      PersPred pers_pred_car)=> //.
    - apply _.
    - apply limit_preserving_forall=> w.
      by apply bi.limit_preserving_Persistent=> n ??.
    - eapply bounded_limit_preserving_forall=>x.
      eapply bounded_limit_preserving_fun_app.
      eapply Hcont.
  Qed.

  Global Instance persistent_pred_car_ne n :
    Proper (dist n ==> (=) ==> dist n)
      pers_pred_car.
  Proof. by intros ? ? ? ? ? ->. Qed.
  Global Instance persistent_pred_car_proper :
    Proper ((≡) ==> (=) ==> (≡)) pers_pred_car.
  Proof. by intros ? ? ? ? ? ->. Qed.

  Lemma persistent_pred_ext (f g : persistent_pred) : f ≡ g ↔ ∀ x, f x ≡ g x.
  Proof. done. Qed.

  Global Instance: Inhabited persistent_pred := populate (PersPred (λ _, True))%I.

End persistent_pred.

Global Arguments PersPred {_ _ _} _%I {_}.
Global Arguments pers_pred_car {_ _ _} !_ _.
Global Instance: Params (@pers_pred_car) 3 := {}.


Require Export CatSem.CAT.rmonad_gen.
Require Export CatSem.CAT.rmodule_TYPE.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Transparent Obligations.
Unset Automatic Introduction.

(** pullback of rmodule along gen. monad morphisms
    commutes with derivation *)

(** we take two monads
    - P : Set/T -> PO/T (F:=SM_ipo)
    - Q : Set/U -> PO/U (F:=SM_ipo)

   and an rmodule
    - M : RMOD Q E
*)

Section fix_types.

Variables T U : Type.
Variable f : T -> U.

Section term_to_term.
Variable P : RMonad (IDelta T).
Variable Q : RMonad (IDelta U).
Variable M : colax_RMonad_Hom P Q
	      (G1:=RETYPE (fun t => f t))
	      (G2:=RETYPE_PO (fun t => f t))
              (RT_NT (fun t => f t)).

Section lemmata.
Variables (c d : ITYPE T).

Variable h : c ---> d.

Variable (g : ipo_mor (sm_ipo (T:=T) c) (P d)).
Variable (t : T).
Variable y : P c t.

Lemma gen_rh_rkl :
(M d) (f t) (ctype (fun t => f t) (V:=P d) (t:=t)
 ((rkleisli (RMonad_struct := P)(a:=c) (b:=d) g) t y)) =
     (rkleisli (RMonad_struct := Q)(a:=retype _ c) (b:=retype _ d)
        (ipo_comp
           (ipo_comp (id_cc _ c)
              (retype_po_mor (fun t => f t) (V:=sm_ipo (T:=T) c) (W:=P d) g)) (M d)))
       (f t) ((M c) (f t) (ctype (fun t => f t) (V:=P c) (t:=t) y)).
Proof.
  assert (H:=gen_rmonad_hom_rkl M).
  simpl in H.
  assert (H':= H _ _ g _ (ctype _ y)).
  simpl in H'.
  auto.
Qed.

Variable z : c t.

Lemma gen_rh_rweta :
(M c) (f t) (ctype (fun t => f t) (V:=P c) (t:=t)
((rweta (RMonad_struct := P)c) t z)) =
     (rweta (RMonad_struct := Q) (retype _ c))
        (f t) (ctype (fun t => f t) (V:=c) (t:=t) z).
Proof.
  assert (H:=gen_rmonad_hom_rweta M).
  simpl in H.
  assert (H':= H _ _ (ctype _ z)).
  simpl in H'.
  auto.
Qed.

Lemma gen_rh_rlift :
(rlift Q (a:=retype (fun t : T => f t) c)
        (b:=retype (fun t : T => f t) d) (retype_map (W:=d) h)) (f t)
       ((M c) (f t) (ctype (fun t : T => f t) (V:=P c) (t:=t) y)) =
     (M d) (f t)
       (ctype (fun t : T => f t) (V:=P d) (t:=t)
          ((rlift P (a:=c) (b:=d) h) t y)).
Proof.
  assert (H3 := NTcomm M).
  simpl in H3.
  assert (H4:= H3 _ _ h _ (ctype _ y)).
  simpl in H4.
  auto.
Qed.

End lemmata.

Program Instance unit_rmod_s : RModule_Hom_struct
  (M:= Term (C:=RMOD P Ord)) (N:= colax_PbRMod M (Term (C:=RMOD Q Ord)))
  (fun V => id PO_TERM).

Definition unit_rmod :
  Term (C:=RMOD P Ord) ---> colax_PbRMod M (Term (C:=RMOD Q Ord)) :=
     Build_RModule_Hom unit_rmod_s.

End term_to_term.

Section gen_pb_der.

Variable P : RMonad (IDelta T).
Variable Q : RMonad (IDelta U).
Variable h : colax_RMonad_Hom P Q
              (G1:=RETYPE (fun t => f t))
	      (G2:=RETYPE_PO (fun t => f t)) (RT_NT (fun t => f t)).

Variable u : T.

Variable obE : Type.
Variable morE : obE -> obE -> Type.
Variable E : Cat_struct morE.

Variable N : RMOD Q E.

Obligation Tactic := idtac.

Program Instance gen_pb_der_s : RModule_Hom_struct
   (M:= DER_RMOD _ _ u (colax_PbRMod h N))
   (N:= colax_PbRMod h (DER_RMOD _ _ (f u) N))
   (fun c => rmlift N (@der_comm _ _ _ _ c)).
Next Obligation.
Proof.
  simpl.
  intros V W g.
  rewrite (rmkleisli_rmlift).
  rewrite (rmlift_rmkleisli).
  apply (rmkl_eq).
  simpl.
  intros t z.
  destruct z as [t z];
  simpl.
  destruct z as [t z | ];
  simpl.
  assert (H:= NTcomm (colax_RMonad_Hom_NatTrans h)).
  simpl in H.
  generalize (g t z).
  clear z.
  intro z.
  destruct g as [g gax];
  simpl.

  assert (H':= H W (opt u W) (some u (A:=W)) _ (ctype _ z)).
  simpl in H'.
  rewrite <- H'.
  assert (H2 :=rlift_rlift Q).
  simpl in H2.
  rewrite H2.
  apply (rlift_eq Q).
  simpl;
  intros t0 y;
  destruct y as [t0 y];
  simpl; auto.

  assert (H:=gen_rmonad_hom_rweta h).
  simpl in H.
  assert (H':= H (opt u W) (f u) (ctype _ (none u W))).
  simpl in H'.
  rewrite H'.
  clear H' H.

  assert (H:=rlift_rweta Q).
  simpl in H.
  rewrite H.
  simpl.
  auto.
Qed.

Definition gen_pb_der : DER_RMOD _ _ u (colax_PbRMod h N) --->
         colax_PbRMod h (DER_RMOD _ _ (f u) N) :=
 Build_RModule_Hom gen_pb_der_s.

End gen_pb_der.

Section gen_pb_fib_and_eq.

Variables obC obD obC' obD': Type.
Variable morC : obC -> obC -> Type.
Variable morD : obD -> obD -> Type.
Variable morC' : obC' -> obC' -> Type.
Variable morD' : obD' -> obD' -> Type.
Variable C : Cat_struct morC.
Variable D : Cat_struct morD.
Variable C' : Cat_struct morC'.
Variable D' : Cat_struct morD'.

Variable F : Functor C D.
Variable F' : Functor C' D'.

Variable P : RMonad F.
Variable Q : RMonad F'.

(** for a monad hom we need two functors *)

Variable G1 : Functor C C'.
Variable G2 : Functor D D'.

Variable N : NT (CompF G1 F') (CompF F G2).

Variable h : colax_RMonad_Hom P Q N.

Variable t : T.

Variable M : RMOD Q (IPO T).

Program Instance gen_pb_fib_s : RModule_Hom_struct
  (M:= FIB_RMOD _ t (colax_PbRMod h M))
  (N:= colax_PbRMod h (FIB_RMOD _ t M))
  (fun c => id _ ).

Definition colax_Pb_Fib : FIB_RMOD _ t (colax_PbRMod h M) --->
          colax_PbRMod h (FIB_RMOD _ t M) := Build_RModule_Hom gen_pb_fib_s.

Program Instance gen_fib_pb_s : RModule_Hom_struct
  (M:=colax_PbRMod h (FIB_RMOD _ t M))
  (N:= FIB_RMOD _ t (colax_PbRMod h M))
  (fun c => id _ ).

Definition colax_Fib_Pb : colax_PbRMod h (FIB_RMOD _ t M) --->
   FIB_RMOD _ t (colax_PbRMod h M)
       := Build_RModule_Hom gen_fib_pb_s.

Variable u : T.
Hypothesis H : u = t.

Obligation Tactic := idtac.

Program Instance eq_rect_po_s c:
 PO_mor_struct
 (a:=(FIB_RMOD Q u) M c) (b:=(FIB_RMOD Q t) M c)
 ((eq_rect u (fun t : T => forall c : obC', (M c) u -> (M c) t)
  (fun (c : obC') (y : (M c) u) => y) t H) c).
Next Obligation.
Proof.
  intros;
  unfold Proper;
  red; subst;
  simpl; auto.
Qed.

Definition eq_rect_po c:=Build_PO_mor (eq_rect_po_s c).

Program Instance FIB_RMOD_eq_s : RModule_Hom_struct
 (M:=FIB_RMOD _ u M) (N:=FIB_RMOD _ t M)
 eq_rect_po.
Next Obligation.
Proof.
  intros;
  simpl;
  subst;
  simpl.
  auto.
Qed.

Definition FIB_RMOD_eq :
    FIB_RMOD _ u M ---> FIB_RMOD _ t M :=
 Build_RModule_Hom FIB_RMOD_eq_s.

End gen_pb_fib_and_eq.

Section der_fibre.

Variable P : RMonad (IDelta T).
Variable Q : RMonad (IDelta U).
Variable M : colax_RMonad_Hom P Q
                 (G1:=RETYPE (fun t => f t))
	      (G2:=RETYPE_PO (fun t => f t))
                  (RT_NT (fun t => f t) ).
Variables s r : T.
(*
Definition der_fib_hom_noeq_d c:
(ipo_proj (P (opt r c)) s ->
  ipo_proj (Q (opt (f r) (retype (fun t : T => f t) c))) (f s)).
simpl.
intros c y.
set (z := ctype (fun t => f t) y).
simpl in *.
set (z':= M _ _ z).
simpl in *.
apply (rlift Q (@der_comm _ _ _ _ _ ) _ (M _ _ (ctype (fun t => f t) y))).
apply (rlift Q (@der_comm _ _ _ _ _ ) _ z'). _ (gen_rmonad_hom M) _ _ (ctype _ y)).
*)

Obligation Tactic := idtac.

Program Instance der_fib_hom_noeq_car c :
PO_mor_struct (a:=ipo_proj (P (opt r c)) s)
  (b:=ipo_proj (Q (opt (f r) (retype (fun t : T => f t) c))) (f s))
  (fun y => rlift Q (@der_comm _ _ _ _ _ ) _
              (M _ _ (ctype (fun t => f t) y))).
Next Obligation.
Proof.
  intros.
  unfold Proper;
  red.
  simpl.
  intros x y H.
  apply (rlift Q (@der_comm _ _ (fun t => f t) _ _ )).
  destruct M as [Md Mx].
  apply Md.
  simpl in *.
  constructor;
  auto.
Qed.

Definition der_fib_hom_noeq_d:
(forall c : ITYPE T,
  ((FIB_RMOD P s) ((DER_RMOD (IPO T) P r) P)) c --->
  ((FIB_RMOD P (f s)) (colax_PbRMod M ((DER_RMOD (IPO U) Q (f r)) Q))) c):=
 fun c => Build_PO_mor (der_fib_hom_noeq_car c).

Obligation Tactic := idtac.

Program Instance der_fib_hom_noeq_s : RModule_Hom_struct
  (M:=FIB_RMOD _ s (DER_RMOD _ _ r P))
  (N:=FIB_RMOD _ (f s) (colax_PbRMod M (DER_RMOD _ _ (f r) Q)))
  der_fib_hom_noeq_d.
Next Obligation.
Proof.
  simpl.
  intros c d g x.
  assert (H:=gen_rmonad_hom_rkl M).
  simpl in H.
  rew (H _ _ (sshift r g) _ (ctype _ x)).
  clear H.
  rew (rkleisli_rlift (M:=Q)).
  rew (rlift_rkleisli (M:=Q)).
  apply (rkl_eq Q).
  simpl.
  intros t z.
  destruct z as [t z];
  simpl.
  destruct z as [t z | ];
  simpl.

  assert (H2:= NTcomm M).
  simpl in H2.
  generalize (g t z).
  clear z.
  intro z.
  rerew (H2 _ _ (some r (A:=d)) _ (ctype _ z)).
  rew (rlift_rlift Q).
  apply (rlift_eq Q).
  simpl.
  intros t0 x0;
  destruct x0;
  simpl; auto.

  rew (gen_rmonad_hom_rweta M _ _ (ctype _ (none r d))).
  rew (rlift_rweta Q).
Qed.

Definition DerFib_RMod_Hom :
  FIB_RMOD _ s (DER_RMOD _ _ r P) --->
     FIB_RMOD _ (f s) (colax_PbRMod M (DER_RMOD _ _ (f r) Q)) :=
     Build_RModule_Hom der_fib_hom_noeq_s.

Variable r' : U.
Hypothesis H : f r = r'.

Program Instance der_fib_hom_d c : PO_mor_struct
  (a:=((FIB_RMOD P s) ((DER_RMOD (IPO T) P r) P)) c)
  (b:=((FIB_RMOD P (f s)) (colax_PbRMod M ((DER_RMOD (IPO U) Q r') Q))) c)
  (fun x => eq_rect (f r)
             (fun r' : U => Q (opt r' (RETYPE _ c)) (f s))
  (rlift Q (@der_comm _ _ _ _ _) _
       (((*gen_rmonad_hom*) M) _ _ (ctype (fun t => f t) x))) r' H).
Next Obligation.
Proof.
  unfold Proper;
  red.
  subst.
  simpl.
  intros c x y H.
  apply (rlift Q (@der_comm _ _ (fun t => f t) _ _ )).
  destruct M as [Md Mx].
  apply Md.
  simpl in *.
  constructor;
  auto.
Qed.

Definition der_fib_hom_e c :
  ((FIB_RMOD P s) ((DER_RMOD (IPO T) P r) P)) c --->
  ((FIB_RMOD P (f s)) (colax_PbRMod M ((DER_RMOD (IPO U) Q r') Q))) c :=
  Build_PO_mor (der_fib_hom_d c).

Obligation Tactic := idtac.

Program Instance der_fib_hom_s : RModule_Hom_struct
   (M:=FIB_RMOD _ s (DER_RMOD _ _ r P))
   (N:=FIB_RMOD _ (f s) (colax_PbRMod M (DER_RMOD _ _ r' Q)))
   der_fib_hom_e.
Next Obligation.
Proof.
  simpl.
  subst.
  simpl.
  intros c d g x.
  assert (H:=gen_rmonad_hom_rkl M).
  simpl in H.
  rew (H _ _ (sshift r g) _ (ctype _ x)).
  clear H.
  rew (rkleisli_rlift (M:=Q)).
  rew (rlift_rkleisli (M:=Q)).
  apply (rkl_eq Q).
  simpl.
  intros t z.
  destruct z as [t z];
  simpl.
  destruct z as [t z | ];
  simpl.

  assert (H2:= NTcomm M).
  simpl in H2.
  generalize (g t z).
  clear z.
  intro z.
  rerew (H2 _ _ (some r (A:=d)) _ (ctype _ z)).
  rew (rlift_rlift Q).
  apply (rlift_eq Q).
  simpl.
  intros t0 x0;
  destruct x0;
  simpl; auto.

  rew (gen_rmonad_hom_rweta M _ _ (ctype _ (none r d))).
  rew (rlift_rweta Q).
Qed.

Definition der_fib_hom :
  FIB_RMOD _ s (DER_RMOD _ _ r P) --->
     FIB_RMOD _ (f s) (colax_PbRMod M (DER_RMOD _ _ r' Q)) :=
     Build_RModule_Hom der_fib_hom_s.

End der_fibre.

End fix_types.