Require Import ExtensionalityAxioms.
Require Import MemoryRel.
Require Export SimrelDefinition.
Require Export SimrelEquivalence.
Require Export SimrelInitMem.
Require Import MemOpv.
Local Opaque mwd_ops.

(** * Categorical structure *)

(** ** Identity *)

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

  Definition simrel_id_ops: simrel_components D D :=
    {|
      simrel_world := unit;
      simrel_acc := {| le x y := True |};
      simrel_undef_matches_values_bool := false;
      simrel_undef_matches_block p b := False;
      simrel_new_glbl := nil;
      simrel_meminj p := inject_id;
      match_mem p := @eq (mwd D)
    |}.

  Lemma list_forall2_eq {A}:
    list_forall2 (@eq A) = eq.
  Proof.
    eapply eqrel_eq.
    split.
    - induction 1; congruence.
    - intros l1 l2 H.
      subst.
      induction l2; constructor; eauto.
  Qed.

  Lemma match_block_sameofs_simrel_id p:
    match_block_sameofs simrel_id_ops p = eq.
  Proof.
    apply eqrel_eq; split.
    - inversion 1.
      reflexivity.
    - intros b _ [].
      reflexivity.
  Qed.

  Lemma match_block_simrel_id p:
    match_block simrel_id_ops p = eq.
  Proof.
    apply eqrel_eq; split.
    - intros b1 b2 [ofs H].
      inversion H; congruence.
    - intros b _ [].
      exists 0%Z.
      reflexivity.
  Qed.

  Lemma match_ptr_simrel_id p:
    match_ptr simrel_id_ops p = eq.
  Proof.
    eapply eqrel_eq.
    split.
    - destruct 1.
      inversion H; subst.
      rewrite Z.add_0_r.
      reflexivity.
    - intros [b ofs] y [].
      rewrite <- (Z.add_0_r ofs) at 2.
      constructor.
      reflexivity.
  Qed.

  Lemma match_ptrbits_simrel_id p:
    match_ptrbits simrel_id_ops p = eq.
  Proof.
    apply eqrel_eq; split.
    - destruct 1.
      inversion H; subst.
      change (Ptrofs.repr 0) with Ptrofs.zero.
      rewrite Ptrofs.add_zero.
      reflexivity.
    - intros [b ofs] y [].
      rewrite <- (Ptrofs.add_zero ofs) at 2.
      change Ptrofs.zero with (Ptrofs.repr 0).
      constructor.
      reflexivity.
  Qed.

  Lemma match_ptrrange_simrel_id p:
    match_ptrrange simrel_id_ops p = eq.
  Proof.
    eapply eqrel_eq.
    split.
    - destruct 1.
      inversion H; subst.
      rewrite match_ptr_simrel_id in H.
      congruence.
    - intros [[b lo] hi] _ [].
      replace hi with (lo + (hi - lo))%Z by omega.
      constructor.
      rewrite match_ptr_simrel_id.
      reflexivity.
  Qed.

  Lemma match_val_simrel_id p:
    match_val simrel_id_ops p = eq.
  Proof.
    apply eqrel_eq; split.
    - destruct 1; try discriminate; try contradiction; try reflexivity.
      rewrite match_ptrbits_simrel_id in H.
      congruence.
    - intros v _ [].
      destruct v; repeat rstep.
      rewrite match_ptrbits_simrel_id.
      reflexivity.
  Qed.

  Lemma match_memval_simrel_id p:
    match_memval simrel_id_ops p = eq.
  Proof.
    apply eqrel_eq; split.
    - destruct 1; try discriminate; try contradiction; try reflexivity.
      rewrite match_val_simrel_id in H.
      congruence.
    - intros v _ [].
      destruct v; repeat rstep.
      rewrite match_val_simrel_id.
      reflexivity.
  Qed.

  Lemma simrel_option_le_id {A}:
    flex_option_le (false = true) (@eq A) = eq.
  Proof.
    apply eqrel_eq; split; intros x y H.
    - destruct H; try congruence.
    - subst.
      reflexivity.
  Qed.

  Lemma simrel_fundef_rel_id {F1 F2}:
    simrel_fundef_rel (F1:=F1) (F2:=F2) false =
    fun _ => option_rel ⊤%rel.
  Proof.
    apply functional_extensionality; intros i.
    unfold simrel_fundef_rel.
    apply eqrel_eq; split; intros x y H; destruct H; repeat constructor.
    discriminate.
  Qed.

  Lemma simrel_vardef_rel_id {V}:
    simrel_vardef_rel (V:=V) nil false =
    fun _ => eq.
  Proof.
    apply functional_extensionality; intros i.
    apply eqrel_eq; split; intros x y H.
    - destruct H; eauto.
      destruct H as [? | [? ?]]; try discriminate.
    - subst.
      destruct y; constructor; reflexivity.
  Qed.

  Hint Rewrite
    match_block_simrel_id
    match_block_sameofs_simrel_id
    match_ptr_simrel_id
    match_ptrbits_simrel_id
    match_ptrrange_simrel_id
    match_val_simrel_id
    match_memval_simrel_id
    @simrel_fundef_rel_id
    @simrel_vardef_rel_id
    : simrel.

  Global Instance simrel_id_init_mem {F1 F2 V}:
    InitMemSimrel (D1:=D) (D2:=D) (F1:=F1) (F2:=F2) (V:=V) nil false
      (fun _ _ _ _ => eq).
  Proof.
    assert (forall i, ~ simrel_newfun_ok nil false i).
    {
      intros i [H _].
      discriminate.
    }
    assert (forall i init, ~ simrel_newvar_ok nil false i init).
    {
      intros i init [|[? ?]]; discriminate.
    }
    split; intros.
    - reflexivity.
    - repeat rstep; subst; reflexivity.
    - exfalso; unfold not in *; eauto.
    - exfalso; unfold not in *; eauto.
    - repeat rstep; subst; reflexivity.
    - split; repeat intro; repeat rstep; subst; try reflexivity.
      + congruence.
      + erewrite (Genv.store_init_data_symbols_preserved x y) in H6.
        * congruence.
        * intro.
          rewrite !stencil_matches_symbols by eauto.
          reflexivity.
      + destruct H4.
        congruence.
  Qed.

  Local Instance simrel_id_prf:
    SimulationRelation simrel_id_ops.
  Proof.
    split; simpl; intros; autorewrite with simrel.

    (** Compatibility with order *)
    - repeat constructor.
    - solve_monotonic.
    - solve_monotonic.

    (** Properties of match_ptr *)
    - discriminate.
    - contradiction.
    - autorewrite with simrel in *. congruence.
    - autorewrite with simrel in *. congruence.
    - autorewrite with simrel in *. congruence.
    - constructor.

    (** [Genv.init_mem] *)
    - eapply genv_init_mem_simrel; try typeclasses eauto.
      simpl.
      intros ? ? [[] _].
      exists tt.
      reflexivity.

    (** [Mem.alloc] *)
    - exists tt.
      autorewrite with simrel.
      split; simpl; eauto.
      split; congruence.

    (** [Mem.free] *)
    - repeat rstep; subst.
      destruct (uncurry _ _); constructor.
      exists p; repeat constructor.

    (** [Mem.load] *)
    - repeat rstep; subst.
      destruct y0; simpl.
      rauto.

    (** [Mem.store] *)
    - repeat rstep; subst.
      destruct (uncurry _ _); constructor.
      exists p; repeat constructor.

    (** [Mem.loadbytes] *)
    - repeat rstep; subst.
      destruct y0; simpl.
      rauto.

    (** [Mem.storebytes] *)
    - repeat rstep; subst.
      rewrite @list_rel_eq in *.
      subst.
      destruct (uncurry _ _); constructor.
      exists p; repeat constructor.

    (** [Mem.perm] *)
    - repeat rstep; congruence.

    (** [Mem.valid_block] *)
    - unfold Mem.valid_block.
      repeat rstep; congruence.

    (** [Mem.different_pointers_inject] *)
    - inversion H3; clear H3; subst.
      inversion H4; clear H4; subst.
      tauto.

    (** [Mem.weak_valid_pointer_inject_val] *)
    - autorewrite with simrel in *.
      congruence.

    (** [weak_valid_pointer_address_inject_weak] *)
    - unfold inject_id in *.
      inversion H0; clear H0; subst.
      exists 0. intros.
      rewrite Ptrofs.add_zero.
      omega.

    (** [Mem.address_inject] *)
    - inversion H1; subst.
      rewrite Ptrofs.add_zero.
      omega.

    (** [Mem.aligned_area_inject] *)
    - inversion H5; subst.
      auto with zarith.

    (** [Mem.disjoint_or_equal_inject] *)
    - inversion H0; subst.
      inversion H1; subst.
      repeat rewrite Z.add_0_r.
      assumption.
  Qed.

  Definition simrel_id: simrel D D :=
    {|
      simrel_ops := simrel_id_ops
    |}.
End IDENTITY.

(** ** Composition *)

Require Import Decision.

Lemma list_rel_compose {A B C} (R: rel A B) (S: rel B C):
  list_rel (rel_compose R S) = rel_compose (list_rel R) (list_rel S).
Proof.
  eapply eqrel_eq; split.
  - intros l1 l3 H.
    induction H as [ | x1 x3 (x2 & Hx12 & Hx23) l1 l3 _ (l2 & Hl12 & Hl23)];
      ehtransitivity; constructor; eauto.
  - intros l1 l3 (l2 & Hl12 & Hl23).
    revert l3 Hl23.
    induction Hl12; inversion 1; clear Hl23; subst; constructor.
    + eexists; eauto.
    + eauto.
Qed.

Section COMPOSE.
  Context `{Hmem: BaseMemoryModel}.
  Context {D1 D2 D3: layerdata}.

  Definition simrel_compose_ops
      (R12: simrel_components D1 D2)
      (R23: simrel_components D2 D3) :=
    {|
      simrel_world :=
        simrel_world R12 * simrel_world R23;
      simrel_acc :=
        {| le := ((≤) * (≤))%rel |};
      simrel_undef_matches_values_bool :=
        simrel_undef_matches_values_bool R12 ||
        simrel_undef_matches_values_bool R23;
      simrel_undef_matches_block p b :=
        (exists b',
           simrel_undef_matches_block R12 (fst p) b' /\
           match_block R23 (snd p) b' b) \/
        simrel_undef_matches_block R23 (snd p) b;
      simrel_new_glbl :=
        simrel_new_glbl R12 ++ simrel_new_glbl R23;
      simrel_meminj p :=
        compose_meminj
          (simrel_meminj R12 (fst p))
          (simrel_meminj R23 (snd p));
      match_mem p :=
        rel_compose
          (match_mem R12 (fst p))
          (match_mem R23 (snd p))
    |}.

  Hint Extern 2 (rel_compose ?R12 ?R23 ?x ?z) => eexists; split.
  Hint Resolve @match_ptrbits_block.

  Lemma simrel_undef_matches_values_compose R12 R23:
    simrel_undef_matches_values (simrel_compose_ops R12 R23) =
    (simrel_undef_matches_values R12 \/ simrel_undef_matches_values R23).
  Proof.
    unfold simrel_undef_matches_values; simpl.
    apply prop_ext.
    apply orb_true_iff.
  Qed.

  Lemma simrel_undef_matches_values_compose_introl R12 R23:
    simrel_undef_matches_values R12 ->
    simrel_undef_matches_values (simrel_compose_ops R12 R23).
  Proof.
    rewrite simrel_undef_matches_values_compose; eauto.
  Qed.

  Lemma simrel_undef_matches_values_compose_intror R12 R23:
    simrel_undef_matches_values R23 ->
    simrel_undef_matches_values (simrel_compose_ops R12 R23).
  Proof.
    rewrite simrel_undef_matches_values_compose; eauto.
  Qed.

  Hint Rewrite simrel_undef_matches_values_compose : simrel.
  Hint Immediate simrel_undef_matches_values_compose_introl.
  Hint Immediate simrel_undef_matches_values_compose_intror.

  Local Instance compose_meminj_inject_incr:
    Monotonic
      (@compose_meminj)
      ((- ==> option_le eq) ++> (- ==> option_le eq) ++> (- ==> option_le eq)).
  Proof.
    unfold compose_meminj.
    solve_monotonic.
  Qed.

  (** This only works one way, because a block may be shifted by [R12],
    and shifted back the same amount by [R23]. *)

  Global Instance match_block_sameofs_simrel_compose R12 R23 p12 p23:
    HTransitive
      (match_block_sameofs R12 p12)
      (match_block_sameofs R23 p23)
      (match_block_sameofs (simrel_compose_ops R12 R23) (p12, p23)).
  Proof.
    unfold match_block_sameofs; simpl.
    intros b1 b2 b3 Hb12 Hb23.
    unfold compose_meminj.
    rewrite Hb12.
    rewrite Hb23.
    reflexivity.
  Qed.

  Lemma match_block_simrel_compose R12 R23 p12 p23:
    match_block (simrel_compose_ops R12 R23) (p12, p23) =
    rel_compose
      (match_block R12 p12)
      (match_block R23 p23).
  Proof.
    apply eqrel_eq; split.
    - intros b1 b3 [delta H].
      simpl in H; unfold compose_meminj in H.
      destruct (simrel_meminj R12 _ _) as [[b2 d12]|] eqn:H12; try discriminate.
      destruct (simrel_meminj R23 _ _) as [[x3 d23]|] eqn:H23; try discriminate.
      inversion H; clear H; subst.
      exists b2.
      unfold match_block.
      eauto.
    - intros b1 b3 (b2 & [d12 H12] & [d23 H23]).
      exists (d12 + d23).
      simpl; unfold compose_meminj.
      rewrite H12, H23.
      reflexivity.
  Qed.

  Lemma match_ptr_simrel_compose R12 R23 p12 p23:
    match_ptr (simrel_compose_ops R12 R23) (p12, p23) =
    rel_compose
      (match_ptr R12 p12)
      (match_ptr R23 p23).
  Proof.
    apply eqrel_eq; split.
    - intros _ _ [b1 ofs1 b3 delta H].
      simpl in H; unfold compose_meminj in H.
      destruct (simrel_meminj R12 _ _) as [[b2 d12]|] eqn:H12; try discriminate.
      destruct (simrel_meminj R23 _ _) as [[x3 d23]|] eqn:H23; try discriminate.
      inversion H; clear H; subst.
      exists (b2, ofs1 + d12); split.
      + constructor; eauto.
      + replace (ofs1 + (d12 + d23)) with ((ofs1 + d12) + d23) by omega.
        constructor; eauto.
    - intros ptr1 ptr3 (ptr2 & H12 & H23).
      destruct H12 as [b1 ofs1 b2 d12 H12].
      inversion H23 as [b2' ofs2 b3 d23 H23']; clear H23; subst.
      replace (ofs1 + d12 + d23) with (ofs1 + (d12 + d23)) by omega.
      constructor.
      simpl; unfold compose_meminj.
      rewrite H12, H23'.
      reflexivity.
  Qed.

  Lemma match_ptrbits_simrel_compose R12 R23 p12 p23:
    match_ptrbits (simrel_compose_ops R12 R23) (p12, p23) =
    rel_compose
      (match_ptrbits R12 p12)
      (match_ptrbits R23 p23).
  Proof.
    apply eqrel_eq; split.
    - intros _ _ [b1 ofs1 b3 delta H].
      simpl in H; unfold compose_meminj in H.
      destruct (simrel_meminj R12 _ _) as [[b2 d12]|] eqn:H12; try discriminate.
      destruct (simrel_meminj R23 _ _) as [[x3 d23]|] eqn:H23; try discriminate.
      inversion H; clear H; subst.
      exists (b2, Ptrofs.add ofs1 (Ptrofs.repr d12)); split.
      + constructor; eauto.
      + replace (Ptrofs.add ofs1 (Ptrofs.repr (d12 + d23)))
           with (Ptrofs.add (Ptrofs.add ofs1 (Ptrofs.repr d12)) (Ptrofs.repr d23)).
        * constructor; eauto.
        * rewrite Ptrofs.add_assoc.
          f_equal.
          auto using add_repr.
    - intros ptr1 ptr3 (ptr2 & Hptr12 & Hptr23).
      destruct Hptr12 as [b1 ofs1 b2 d12 H12].
      inversion Hptr23 as [x2 ofs2 b3 d23 H23]; clear Hptr23; subst.
      rewrite Ptrofs.add_assoc.
      rewrite <- add_repr.
      constructor; eauto.
      simpl; unfold compose_meminj.
      rewrite H12.
      rewrite H23.
      reflexivity.
  Qed.

  Lemma match_ptrrange_simrel_compose R12 R23 p12 p23:
    SimulationRelation R23 ->
    match_ptrrange (simrel_compose_ops R12 R23) (p12, p23) =
    rel_compose (match_ptrrange R12 p12) (match_ptrrange R23 p23).
  Proof.
    intros.
    eapply eqrel_eq.
    split.
    - intros r1 r3 Hr.
      destruct Hr as [b1 ofs1 b3 ofs3 sz H13].
      rewrite match_ptr_simrel_compose in H13.
      destruct H13 as ([b2 ofs2] & H12 & H23).
      exists (b2, ofs2, ofs2+sz); split; constructor; eauto.
    - intros r1 r3 (r2 & Hr12 & Hr23).
      destruct Hr12; inversion Hr23; clear Hr23; subst.
      assert (sz0 = sz) by xomega; subst.
      constructor.
      rewrite match_ptr_simrel_compose.
      eexists; eauto.
  Qed.

  Lemma match_val_intro_simrel_compose R12 R23 p12 p23 v1 v2 v3:
    SimulationRelation R23 ->
    match_val R12 p12 v1 v2 ->
    match_val R23 p23 v2 v3 ->
    match_val (simrel_compose_ops R12 R23) (p12, p23) v1 v3.
  Proof.
    intros HR23 H12 H23.
    destruct H12; inversion H23; clear H23; subst;
    constructor; simpl; eauto 10.
    rewrite match_ptrbits_simrel_compose; eauto.
  Qed.

  Lemma match_val_elim_simrel_compose R12 R23 p12 p23 v1 v3:
    SimulationRelation R23 ->
    match_val (simrel_compose_ops R12 R23) (p12, p23) v1 v3 ->
    exists v2,
      match_val R12 p12 v1 v2 /\
      match_val R23 p23 v2 v3.
  Proof.
    intros HR23.
    destruct 1;
    try solve [ eexists; split; econstructor; eauto ].
    - rewrite match_ptrbits_simrel_compose in *.
      destruct H as ([b ofs] & ? & ?).
      eexists; split; econstructor; eauto.
    - autorewrite with simrel in H.
      destruct H.
      + eexists; split; [ | constructor]; constructor; eauto.
      + exists Vundef; split; constructor; eauto.
    - autorewrite with simrel in H.
      destruct H.
      + eexists; split; [ | constructor]; constructor; eauto.
      + exists Vundef; split; constructor; eauto.
    - autorewrite with simrel in H.
      destruct H.
      + eexists; split; [ | constructor]; constructor; eauto.
      + exists Vundef; split; constructor; eauto.
    - autorewrite with simrel in H.
      destruct H.
      + eexists; split; [ | constructor]; constructor; eauto.
      + exists Vundef; split; constructor; eauto.
    - simpl in H.
      destruct H as [H|H].
      + destruct H as (b' & Hb' & Hb).
        destruct Hb as [delta Hb].
        exists (Vptr b' (Ptrofs.sub ofs (Ptrofs.repr delta))).
        split; constructor; eauto.
        pattern ofs at 2.
        replace ofs with (Ptrofs.add (Ptrofs.sub ofs (Ptrofs.repr delta)) (Ptrofs.repr delta)).
        * constructor; eauto.
        * rewrite Ptrofs.sub_add_opp.
          rewrite Ptrofs.add_assoc.
          rewrite (Ptrofs.add_commut (Ptrofs.neg _) _).
          rewrite Ptrofs.add_neg_zero.
          rewrite Ptrofs.add_zero.
          reflexivity.
      + exists Vundef.
        split; constructor; eauto.
  Qed.

  Lemma match_val_simrel_compose R12 R23 p12 p23:
    SimulationRelation R23 ->
    match_val (simrel_compose_ops R12 R23) (p12, p23) =
    rel_compose (match_val R12 p12) (match_val R23 p23).
  Proof.
    intros.
    eapply eqrel_eq.
    split.
    - intros x z.
      apply match_val_elim_simrel_compose; eauto.
    - intros x z (y & Hxy & Hyz).
      eapply match_val_intro_simrel_compose; eauto.
  Qed.

  Lemma match_memval_intro_simrel_compose R12 R23 p12 p23 v1 v2 v3:
    SimulationRelation R23 ->
    match_memval R12 p12 v1 v2 ->
    match_memval R23 p23 v2 v3 ->
    match_memval (simrel_compose_ops R12 R23) (p12, p23) v1 v3.
  Proof.
    intros HR23 H12 H23.
    destruct H12; inversion H23; subst; constructor; simpl;
    eauto 10;
    rewrite match_val_simrel_compose; eauto.
    exists Vundef; split; rauto.
  Qed.

  Lemma match_memval_elim_simrel_compose R12 R23 p12 p23 v1 v3:
    SimulationRelation R23 ->
    match_memval (simrel_compose_ops R12 R23) (p12, p23) v1 v3 ->
    exists v2,
      match_memval R12 p12 v1 v2 /\
      match_memval R23 p23 v2 v3.
  Proof.
    intros HR23.
    destruct 1;
    try solve [ eexists; split; econstructor; eauto ].
    - rewrite match_val_simrel_compose in *; eauto.
      destruct H as (? & ? & ?).
      eexists; split; econstructor; eauto.
    - autorewrite with simrel in H.
      destruct H.
      + exists (Byte b); split; constructor; eauto.
      + exists Undef; split; constructor; eauto.
    - autorewrite with simrel in H.
      rewrite match_val_simrel_compose in *; eauto.
      destruct H0 as (x & ? & ?).
      destruct H.
      + exists (Fragment x q n); split; constructor; eauto.
      + exists Undef; split; simpl; constructor; auto.
        inv H0; inv H1; try constructor; auto.
        eapply simrel_undef_matches_values_also_block; eauto.
  Qed.

  Lemma match_memval_simrel_compose R12 R23 p12 p23:
    SimulationRelation R23 ->
    match_memval (simrel_compose_ops R12 R23) (p12, p23) =
    rel_compose (match_memval R12 p12) (match_memval R23 p23).
  Proof.
    intros.
    eapply eqrel_eq.
    split.
    - intros x z.
      apply match_memval_elim_simrel_compose; eauto.
    - intros x z (y & Hxy & Hyz).
      eapply match_memval_intro_simrel_compose; eauto.
  Qed.

  Lemma match_memvals_intro_simrel_compose R12 R23 p12 p23 vs1 vs2 vs3:
    SimulationRelation R23 ->
    list_forall2 (match_memval R12 p12) vs1 vs2 ->
    list_forall2 (match_memval R23 p23) vs2 vs3 ->
    list_forall2 (match_memval (simrel_compose_ops R12 R23) (p12, p23)) vs1 vs3.
  Proof.
    intros HR23 Hvs12 Hvs23.
    revert vs3 Hvs23.
    induction Hvs12 as [ | v1 vs1 v2 vs2 Hv12 Hvs12 IHvs12];
    inversion 1 as [ | v2' vs2' v3 vs3' Hv23 Hvs23'];
    subst.
    - constructor.
    - constructor; simpl; eauto.
      eapply match_memval_intro_simrel_compose; eauto.
  Qed.

  Lemma match_memvals_elim_simrel_compose R12 R23 p12 p23 vs1 vs3:
    SimulationRelation R23 ->
    list_forall2 (match_memval (simrel_compose_ops R12 R23) (p12,p23)) vs1 vs3 ->
    exists vs2,
      list_forall2 (match_memval R12 p12) vs1 vs2 /\
      list_forall2 (match_memval R23 p23) vs2 vs3.
  Proof.
    intros HR23 Hvs13.
    induction Hvs13 as [ | v1 vs1 v3 vs3 Hv13 Hvs13 IHvs13].
    - exists nil.
      split; constructor.
    - apply match_memval_elim_simrel_compose in Hv13; eauto.
      destruct Hv13 as (v2 & Hv12 & Hv23).
      destruct IHvs13 as (v2s & Hvs12 & Hvs23).
      exists (v2 :: v2s).
      split; constructor; assumption.
  Qed.

  Lemma match_memvals_simrel_compose R12 R23 p12 p23:
    SimulationRelation R23 ->
    list_forall2 (match_memval (simrel_compose_ops R12 R23) (p12, p23)) =
    rel_compose
      (list_forall2 (match_memval R12 p12))
      (list_forall2 (match_memval R23 p23)).
  Proof.
    intros.
    eapply eqrel_eq.
    split.
    - intros x z.
      apply match_memvals_elim_simrel_compose; eauto.
    - intros x z (y & Hxy & Hyz).
      eapply match_memvals_intro_simrel_compose; eauto.
  Qed.

  Hint Rewrite
      match_block_simrel_compose
      match_block_sameofs_simrel_compose
      match_ptr_simrel_compose
      match_ptrbits_simrel_compose
      match_ptrrange_simrel_compose
      match_val_simrel_compose
      match_memval_simrel_compose
      match_memvals_simrel_compose
    using eassumption : simrel.

  (** To prove initialization, we need to construct an intermediate
    program [p2], so that if [p1] and [p3] are related by the
    composite relation, then [p1]/[p2], and [p2]/[p3], are related by
    the respective components. *)

  Section UNCOMPOSE_PROGRAMS.
    Context {F1 F3 V : Type}.
    Context (ng12: list (ident * list AST.init_data)) (b12: bool).
    Context (ng23: list (ident * list AST.init_data)) (b23: bool).

    Lemma filter_app {A} p l1 l2:
      @filter A p (l1 ++ l2) = filter p l1 ++ filter p l2.
    Proof.
      induction l1.
      - reflexivity.
      - simpl.
        rewrite IHl1.
        destruct (p a); reflexivity.
    Qed.

    Program Instance simrel_vardef_not_new_glbl_dec i:
      Decision (simrel_not_new_glbl ng23 i) :=
        match (simrel_new_glbl_for ng23 i) with
          | nil => left _
          | _ => right _
        end.
    Next Obligation.
      red.
      congruence.
    Qed.

    Notation simrel_undef_matches_variable ng b i :=
      (b = true \/ In i (map fst ng)).

    Lemma simrel_newvar_ok_compose i init:
      simrel_newvar_ok (ng12 ++ ng23) (b12 || b23) i init ->
      (simrel_newvar_ok ng12 b12 i init /\ simrel_not_new_glbl ng23 i) \/
      (simrel_not_new_glbl ng12 i /\ simrel_newvar_ok ng23 b23 i init).
    Proof.
      intros [Hng | [Hng Hb]].
      - unfold simrel_new_glbl_for in Hng.
        rewrite filter_app in Hng.
        apply app_eq_unit in Hng.
        unfold simrel_newvar_ok, simrel_not_new_glbl.
        destruct Hng as [[H12 H23] | [H12 H23]]; eauto.
      - apply orb_true_iff in Hb.
        unfold simrel_newvar_ok, simrel_not_new_glbl.
        unfold simrel_new_glbl_for in *.
        rewrite filter_app in Hng.
        apply app_eq_nil in Hng.
        destruct Hng as [? ?], Hb as [?|?]; eauto.
    Qed.

    Lemma simrel_undef_matches_new_glbl ng b i init:
      simrel_newvar_ok ng b i init ->
      simrel_undef_matches_variable ng b i.
    Proof.
      unfold simrel_newvar_ok, simrel_new_glbl_for.
      induction ng; simpl.
      - intros [?|[? ?]]; left; congruence.
      - unfold test at 1 4.
        destruct (decide _); subst; eauto.
        intro.
        edestruct IHng; eauto.
    Qed.

    Lemma simrel_undef_matches_not_new_glbl ng b i:
      simrel_not_new_glbl ng i ->
      simrel_undef_matches_variable ng b i ->
      b = true.
    Proof.
      intros Hi [Hglbl|Hundef]; eauto.
      unfold simrel_not_new_glbl in Hi.
      unfold simrel_new_glbl_for in Hi.
      exfalso.
      induction ng; simpl in *; eauto.
      unfold test at 1 in Hi.
      destruct (decide _).
      - discriminate.
      - destruct Hundef; try contradiction.
        eauto.
    Qed.

    Lemma simrel_not_new_glbl_compose i:
      simrel_not_new_glbl (ng12 ++ ng23) i ->
      simrel_not_new_glbl ng12 i /\
      simrel_not_new_glbl ng23 i.
    Proof.
      intros H.
      unfold simrel_not_new_glbl in H.
      unfold simrel_new_glbl_for in H.
      simpl in H.
      rewrite filter_app in H.
      apply app_eq_nil in H.
      destruct H as [H12 H23]; eauto.
    Qed.

    Definition simrel_uncompose_fundef (f1: option F1) (f3: option F3) :=
      match f1, f3 with
        | Some f1, Some f3 => Some f3
        | None, Some f3 => if b12 then Some f3 else None
        | _, _ => None
      end.

    Lemma simrel_fundef_rel_compose i f1 f3:
      simrel_fundef_rel (b12 || b23) i f1 f3 ->
      simrel_fundef_rel b12 i f1 (simrel_uncompose_fundef f1 f3) /\
      simrel_fundef_rel b23 i (simrel_uncompose_fundef f1 f3) f3.
    Proof.
      unfold simrel_fundef_rel.
      intros Hf.
      destruct Hf; simpl.
      - repeat constructor.
      - repeat constructor.
      - autorewrite with simrel in H.
        destruct b12.
        + split; repeat constructor; eauto.
          destruct y; repeat constructor.
        + destruct y; repeat constructor.
          assumption.
    Qed.

    Definition simrel_uncompose_vardef i (v1 v3: option (globvar V)) :=
      match v1, v3 with
        | Some v1, Some v3 => Some v3
        | None, Some v3 =>
          if decide (simrel_undef_matches_variable ng12 b12 i /\
                     simrel_not_new_glbl ng23 i) then Some v3 else None
        | _, _ =>
          None
      end.

    Lemma simrel_vardef_rel_compose i v1 v3:
      simrel_vardef_rel (ng12 ++ ng23) (b12 || b23) i v1 v3 ->
      simrel_vardef_rel ng12 b12 i v1 (simrel_uncompose_vardef i v1 v3) /\
      simrel_vardef_rel ng23 b23 i (simrel_uncompose_vardef i v1 v3) v3.
    Proof.
      intros [Hng | v Hng | v init Hng Hinit].
      - eapply simrel_not_new_glbl_compose in Hng.
        destruct Hng.
        split; constructor; eauto.
      - eapply simrel_not_new_glbl_compose in Hng.
        destruct Hng.
        split; constructor; eauto.
      - eapply simrel_newvar_ok_compose in Hng.
        simpl.
        destruct Hng as [[H12 H23] | [H12 H23]].
        + destruct (decide _) as [[H12u _] | H].
          * repeat (constructor; eauto).
          * elim H.
            split; eauto using simrel_undef_matches_new_glbl.
        + destruct (decide _) as [[H12u H23n] | H].
          * eapply simrel_undef_matches_not_new_glbl in H12u; eauto.
            split; constructor; eauto.
            right.
            eauto.
          * repeat (constructor; eauto).
    Qed.

    Definition simrel_uncompose_def i (d1: _ (globdef F1 V)) (d3: _ (globdef F3 V)) :=
      match d1, d3 with
        | None, None => None
        | Some (Gfun f1), Some (Gfun f3) => Some (Gfun f3)
        | Some (Gvar v1), Some (Gvar v3) => Some (Gvar v3)
        | None, Some (Gfun f3) =>
          if b12 then Some (Gfun f3) else None
        | None, Some (Gvar v3) =>
          if decide (simrel_undef_matches_variable ng12 b12 i /\
                     simrel_not_new_glbl ng23 i) then Some (Gvar v3) else None
        | _, _ => None
      end.

    Lemma simrel_globdef_rel_uncompose i d1 d3:
      globdef_rel
        (simrel_fundef_rel (F1:=F1) (F2:=F3) (b12 || b23))
        (simrel_vardef_rel (V:=V) (ng12 ++ ng23) (b12 || b23))
        i d1 d3 ->
      globdef_rel
        (simrel_fundef_rel (F1:=F1) (F2:=F3) b12)
        (simrel_vardef_rel (V:=V) ng12 b12)
        i d1 (simrel_uncompose_def i d1 d3) /\
      globdef_rel
        (simrel_fundef_rel (F1:=F3) (F2:=F3) b23)
        (simrel_vardef_rel (V:=V) ng23 b23)
        i (simrel_uncompose_def i d1 d3) d3.
    Proof.
      unfold globdef_rel, rel_inter, rel_pull.
      intros [Hf Hv].
      apply simrel_fundef_rel_compose in Hf.
      destruct Hf as [Hf12 Hf23].
      apply simrel_vardef_rel_compose in Hv.
      destruct Hv as [Hv12 Hv23].
      destruct d1 as [[f1|v1]|] eqn:Hd1, d3 as [[f3|v3]|] eqn:Hd3;
      simpl; monad_norm; simpl in *; eauto.
      - inversion Hf12.
      - destruct b12; eauto.
        inversion Hv12.
      - destruct b12; eauto.
      - destruct (decide _); eauto.
    Qed.

    Fixpoint simrel_uncompose_defs (l1 l3: list (ident * option (globdef _ _))) :=
      match l1, l3 with
        | (i, d1) :: l1', (_, d3) :: l3' =>
          (i, simrel_uncompose_def i d1 d3) :: simrel_uncompose_defs l1' l3'
        | _, _ => nil
      end.

    Lemma simrel_globdefs_rel_uncompose l1 l3:
      globdefs_rel
        (simrel_fundef_rel (F1:=F1) (F2:=F3) (b12 || b23))
        (simrel_vardef_rel (V:=V) (ng12 ++ ng23) (b12 || b23))
        glob_threshold
        l1 l3 ->
      globdefs_rel
        (simrel_fundef_rel (F1:=F1) (F2:=F3) b12)
        (simrel_vardef_rel (V:=V) ng12 b12)
        glob_threshold
        l1 (simrel_uncompose_defs l1 l3) /\
      globdefs_rel
        (simrel_fundef_rel (F1:=F3) (F2:=F3) b23)
        (simrel_vardef_rel (V:=V) ng23 b23)
        glob_threshold
        (simrel_uncompose_defs l1 l3) l3.
    Proof.
      rewrite !globdefs_fw_bw_rel_eq.
      induction 1 as [ | i def1 def2 Hdef defs1 defs2 Hdefs IHdefs]; simpl.
      - split; constructor.
      - destruct IHdefs as [H12 H23].
        split; constructor; eauto;
        eapply simrel_globdef_rel_uncompose; eauto.
    Qed.

    Definition simrel_uncompose_prog p1 p3 :=
      {|
        prog_defs := simrel_uncompose_defs (prog_defs p1) (prog_defs p3);
        prog_public := prog_public p1;
        prog_main := prog_main p1
      |}.

    Lemma simrel_program_rel_uncompose p1 p3:
      program_rel
        (simrel_fundef_rel (F1:=F1) (F2:=F3) (b12 || b23))
        (simrel_vardef_rel (V:=V) (ng12 ++ ng23) (b12 || b23))
        p1 p3 ->
      program_rel
        (simrel_fundef_rel (F1:=F1) (F2:=F3) b12)
        (simrel_vardef_rel (V:=V) ng12 b12)
        p1 (simrel_uncompose_prog p1 p3) /\
      program_rel
        (simrel_fundef_rel (F1:=F3) (F2:=F3) b23)
        (simrel_vardef_rel (V:=V) ng23 b23)
        (simrel_uncompose_prog p1 p3) p3.
    Proof.
      intros H13.
      destruct H13 as [H13 HRF HRV].
      destruct H13 as [defs1 defs3 Hdefs main].
      split.
      - constructor.
        + constructor.
          apply simrel_globdefs_rel_uncompose; eauto.
        + intros i Hi.
          specialize (HRF i Hi).
          apply simrel_fundef_rel_compose in HRF.
          simpl in HRF.
          destruct HRF.
          assumption.
        + intros i Hi.
          specialize (HRV i Hi).
          apply simrel_vardef_rel_compose in HRV.
          simpl in HRV.
          destruct HRV.
          assumption.
        + simpl in *.
          assumption.
      - constructor.
        + constructor.
          apply simrel_globdefs_rel_uncompose; eauto.
        + intros i Hi.
          specialize (HRF i Hi).
          apply simrel_fundef_rel_compose in HRF.
          simpl in HRF.
          destruct HRF.
          assumption.
        + intros i Hi.
          specialize (HRV i Hi).
          apply simrel_vardef_rel_compose in HRV.
          simpl in HRV.
          destruct HRV.
          assumption.
        + simpl in *.
          subst main.
          apply globdefs_fw_bw_rel in Hdefs.
          induction Hdefs; simpl; eauto.
          rewrite IHHdefs.
          reflexivity.
    Qed.
  End UNCOMPOSE_PROGRAMS.

  Local Instance simrel_compose_prf R12 R23:
    SimulationRelation R12 ->
    SimulationRelation R23 ->
    SimulationRelation (simrel_compose_ops R12 R23).
  Proof.
    intros HR12 HR23.
    split.

    (** [≤] is a preorder *)
    - simpl.
      typeclasses eauto.

    (** [simrel_undef_matches_block] is compatible *)
    - intros [p1 p2] [p1' p2'] [Hp Hp'] v.
      simpl in *.
      rauto.

    (** [simrel_meminj] is compatible with the carrier order *)
    - intros [p1 p2] [p1' p2'] [Hp Hp'].
      simpl in *.
      solve_monotonic.

    (** [simrel_undef_matches_values] implies [simrel_undef_matches_block] *)
    - intros [p1 p2] ptr1 b3 ofs3.
      autorewrite with simrel.
      intros Hmv ([b2 ofs2] & Hptr12 & Hptr23).
      simpl in *.
      destruct Hmv as [Hmv12 | Hmv23];
      eauto 10 using @simrel_undef_matches_values_also_block.

    (** [simrel_undef_matches_block] implies [simrel_undef_matches_values] *)
    - intros [p1 p2] b3 Hmb.
      simpl in *.
      rewrite simrel_undef_matches_values_compose.
      destruct Hmb as [(b2 & Hb12 & Hb23) | ];
      eauto 10 using @simrel_undef_matches_block_also_values.

    (** [simrel_undef_matches_block] or at most one block injects. *)
    - simpl.
      intros [p12 p23] b3 b1 b1' H H0 H1.
      autorewrite with simrel in *.
      destruct H0 as (b2 & H12 & H23).
      destruct H1 as (b2' & H12' & H23').
      simpl.
      destruct (peq b2' b2).
      + subst.
        left.
        esplit.
        split; eauto.
        eapply (simrel_undef_matches_block_or_injective p12); eauto.
      + right.
        eapply (simrel_undef_matches_block_or_injective p23); eauto.

    (** [simrel_undef_matches_block] for non weakly valid pointers *)
    - simpl.
      intros [p12 p23] m1 m3 b1 ofs1 b3 ofs3.
      autorewrite with simrel.
      simpl.
      intros (m2 & Hm12 & Hm23) INVAL1.
      intros [[b2 ofs2] [Hb12 Hb23]].
      intros VAL3.
      destruct (Mem.weak_valid_pointer m2 b2 (Ptrofs.unsigned ofs2)) eqn:VAL2.
      + left.
        esplit.
        split; eauto.
        eapply simrel_undef_matches_block_invalid_weak; eauto.
      + right.
        eapply simrel_undef_matches_block_invalid_weak; eauto.

    (** [simrel_undef_matches_block] for invalid pointers *)
    - simpl.
      intros [p12 p23] m1 m3 b1 ofs1 b3 ofs3.
      autorewrite with simrel.
      simpl.
      intros (m2 & Hm12 & Hm23) INVAL1.
      intros [[b2 ofs2] [Hb12 Hb23]].
      intros VAL3.
      destruct (Mem.valid_pointer m2 b2 (Ptrofs.unsigned ofs2)) eqn:VAL2.
      + left.
        esplit.
        split; eauto.
        eapply simrel_undef_matches_block_invalid; eauto.
      + right.
        eapply simrel_undef_matches_block_invalid; eauto.

    (** [match_block] for global blocks *)
    - intros [p1 p2] b Hb.
      pose proof (match_global_block_sameofs p1 b Hb) as H1.
      pose proof (match_global_block_sameofs p2 b Hb) as H2.
      unfold Proper, match_block_sameofs in *.
      simpl; unfold compose_meminj.
      rewrite H1, H2.
      reflexivity.

    (** [Genv.init_mem] *)
    - intros F V p1 p3 Hp.
      red in Hp.
      simpl in Hp.
      apply simrel_program_rel_uncompose in Hp.
      destruct Hp as [Hp12 Hp23].
      apply simrel_init_mem in Hp12.
      apply simrel_init_mem in Hp23.
      destruct Hp12 as [ | m1 m2 [p12 Hm12]]; [constructor | ].
      inversion Hp23 as [ | xm2 m3 [p23 Hm23] Hxm2 Hm3]; clear Hp23 Hm3; subst.
      constructor.
      exists (p12, p23).
      eexists; split; eauto.

    (** [Mem.alloc] *)
    - intros [p12 p23] m1 m3 (m2 & Hm12 & Hm23) lo hi.
      edestruct (simrel_alloc p23) as (p23' & Hp23' & Hm23' & Hb23'); eauto.
      edestruct (simrel_alloc p12) as (p12' & Hp12' & Hm12' & Hb12'); eauto.
      exists (p12', p23').
      simpl.
      split; split; eauto.
      ehtransitivity; eauto.

    (** [Mem.free] *)
    - intros [p12 p23] m1 m3 (m2 & Hm12 & Hm23).
      repeat rstep.
      destruct x as [[x1 x2] x3].
      destruct y as [[y1 y2] y3].
      simpl in *.
      rewrite match_ptrrange_simrel_compose in H; eauto.
      destruct H as ([[z1 z2] z3] & H12 & H23).
      destruct (Mem.free m1 _ _ _) as [m1'|] eqn:Hm1'; [|constructor].
      transport Hm1'.
      transport H.
      rewrite H1.
      rstep.
      reexists; repeat rstep.
      ehtransitivity; eauto.

    (** [Mem.load] *)
    - intros [p12 p23] chunk.
      autorewrite with simrel.
      intros m1 m3 (m2&Hm12&Hm23) p1 p3 (p2 & Hp12 & Hp23).
      destruct p1 as [b1 ofs1], p2 as [b2 ofs2], p3 as [b3 ofs3].
      simpl in *.
      ehtransitivity; solve_monotonic.

    (** [Mem.store] *)
    - intros [p12 p23] chunk.
      autorewrite with simrel.
      intros m1 m3 (m2 & Hm12 & Hm23).
      intros [b1 ofs1] [b3 ofs3] ([b2 ofs2] & Hp12 & Hp23).
      intros v1 v3 (v2 & Hv12 & Hv23).
      simpl in *.
      destruct (Mem.store _ m1 _ _ _) as [m1'|] eqn:Hm1'; [|constructor].
      transport Hm1'.
      transport H.
      rewrite H1.
      constructor.
      reexists; repeat rstep.
      ehtransitivity; eauto.

    (** [Mem.loadbytes] *)
    - intros [p12 p23] m1 m3 (m2 & Hm12 & Hm23).
      autorewrite with simrel.
      intros [b1 ofs1] [b3 ofs3]([b2 ofs2] & Hp12 & Hp23) n.
      simpl in *.
      rewrite list_rel_compose.
      ehtransitivity; solve_monotonic.

    (** [Mem.storebytes] *)
    - intros [p12 p23] m1 m3 (m2 & Hm12 & Hm23).
      autorewrite with simrel.
      intros [b1 ofs1] [b3 ofs3]([b2 ofs2] & Hp12 & Hp23) v1 v3 Hv.
      rewrite @list_rel_compose in * by eauto.
      destruct Hv as (v2 & Hv12 & Hv23).
      simpl in *.
      destruct (Mem.storebytes m1 _ _ _) as [m1'|] eqn:Hm1'; [|constructor].
      transport Hm1'.
      transport H.
      rewrite H1.
      constructor.
      reexists; repeat rstep.
      ehtransitivity; eauto.

    (** [Mem.perm] *)
    - intros [p12 p23] m1 m3 (m2 & Hm12 & Hm23).
      autorewrite with simrel.
      intros [b1 ofs1] [b3 ofs3] ([b2 ofs2] & Hp12 & Hp23) k p.
      simpl in *.
      ehtransitivity; solve_monotonic.

    (** [Mem.valid_block] antitonic *)
    - intros [p12 p23] m1 m3 (m2 & Hm12 & Hm23) b1 b3.
      rewrite match_block_simrel_compose.
      intros (b2 & Hb12 & Hb23).
      etransitivity; solve_monotonic.

    (** [Mem.different_pointers_inject] *)
    - intros [p12 p23] m1 m3 b1 ofs1 b1' ofs1' b3 delta13 b3' delta13'.
      simpl.
      unfold compose_meminj.
      intros (m2 & Hm12 & Hm23) DIFF VAL VAL' J J'.
      destruct (simrel_meminj R12 p12 b1) as [ [b2 delta12] | ] eqn:J12;
        try discriminate.
      destruct (simrel_meminj R23 p23 b2) as [ [b3_ delta23] | ] eqn:J23;
        try discriminate.
      inversion J; clear J; subst.
      destruct (simrel_meminj R12 p12 b1') as [ [b2' delta12'] | ] eqn:J12';
        try discriminate.
      destruct (simrel_meminj R23 p23 b2') as [ [b3'_ delta23'] | ] eqn:J23';
        try discriminate.
      inversion J'; clear J'; subst.
      destruct (peq b2 b2').
      {
        subst.
        exploit (simrel_different_pointers_inject p12); eauto.
        intro DIFF12.
        destruct DIFF12 as [ | DIFF12 ] ; try congruence.
        right.
        replace b3' with b3 in * by congruence.
        replace delta23' with delta23 in * by congruence.
        repeat rewrite add_repr.
        repeat rewrite <- Ptrofs.add_assoc.
        intro ABSURD.
        apply (f_equal Ptrofs.repr) in ABSURD.
        repeat rewrite Ptrofs.repr_unsigned in ABSURD.
        apply (f_equal (fun z => Ptrofs.add z (Ptrofs.neg (Ptrofs.repr delta23))))
        in ABSURD.
        repeat rewrite Ptrofs.add_assoc in ABSURD.
        rewrite Ptrofs.add_neg_zero in ABSURD.
        repeat rewrite Ptrofs.add_zero in ABSURD.
        congruence.
      }
      repeat rewrite add_repr.
      repeat rewrite <- Ptrofs.add_assoc.
      eapply (simrel_different_pointers_inject p23); eauto.
      + rewrite Mem.valid_pointer_nonempty_perm.
        rewrite Mem.valid_pointer_nonempty_perm in VAL.
        change (Mem.permv m2 (Vptr b2 (Ptrofs.add ofs1 (Ptrofs.repr delta12))) Nonempty).
        eapply (simrel_permv p12); eauto.
        {
          econstructor.
          econstructor.
          eassumption.
        }
        assumption.
      + rewrite Mem.valid_pointer_nonempty_perm.
        rewrite Mem.valid_pointer_nonempty_perm in VAL'.
        change (Mem.permv m2 (Vptr b2' (Ptrofs.add ofs1' (Ptrofs.repr delta12'))) Nonempty).
        eapply (simrel_permv p12); eauto.
        {
          econstructor.
          econstructor.
          eassumption.
        }
        assumption.

    (** [Mem.weak_valid_pointer_inject_val] *)
    - intros [p12 p23] m1 m3 b1 ofs1 b3 ofs3
             (m2 & Hm12 & Hm23) V1.
      autorewrite with simrel.
      simpl in Hm12, Hm23.
      intros [[b2 o2] [Hv12 Hv23]].
      eapply (simrel_weak_valid_pointer_inject_val p23); eauto.
      eapply (simrel_weak_valid_pointer_inject_val p12); eauto.

    (** [weak_valid_pointer_address_inject_weak] *)
    - simpl.
      intros [p12 p23] m1 m3 b1 b3 delta13.
      simpl.
      intros (m2 & Hm12 & Hm23).
      unfold compose_meminj.
      destruct (simrel_meminj R12 _ _) as [ [ b2 delta12 ] | ]
      eqn:INJ12;
        try discriminate.
      destruct (simrel_meminj R23 _ _) as [ [ b3_ delta23 ] | ]
      eqn:INJ23;
        try discriminate.
      intro K.
      inversion K; clear K; subst.
      generalize (simrel_weak_valid_pointer_address_inject_weak _ _ _ _ _ _ Hm12 INJ12).
      destruct 1 as (delta12' & Hdelta12').
      generalize (simrel_weak_valid_pointer_address_inject_weak _ _ _ _ _ _ Hm23 INJ23).
      destruct 1 as (delta23' & Hdelta23').
      exists (delta12' + delta23').
      intros ofs1 H.
      rewrite add_repr.
      rewrite <- Ptrofs.add_assoc.
      rewrite Hdelta23'.
      * rewrite Hdelta12' by assumption.
        omega.
      * eapply (simrel_weak_valid_pointer_inject_val p12); eauto.
        constructor.
        assumption.

    (** [Mem.address_inject] *)
    - intros [p12 p23] m1 m3 b1 ofs1 b3 delta13 pe (m2 & Hm12 & Hm23).
      intros PERM.
      simpl.
      intros INJ.
      simpl in *.
      unfold compose_meminj in INJ.
      destruct (simrel_meminj R12 p12 b1) as [ [b2 delta12] | ] eqn:INJ12 ; try discriminate.
      destruct (simrel_meminj R23 p23 b2) as [ [b3_ delta23] | ] eqn:INJ23; try discriminate.
      inversion INJ; clear INJ; subst.
      rewrite Z.add_assoc.
      generalize (simrel_address_inject _ _ _ _ _ _ _ _ Hm12 PERM INJ12).
      intro EQ12.
      rewrite <- EQ12.
      assert (match_ptr R12 p12 (b1, Ptrofs.unsigned ofs1) (b2, Ptrofs.unsigned ofs1 + delta12)) as MATCH12.
      {
        constructor.
        assumption.
      }
      generalize (simrel_perm _ _ _ Hm12 _ _ MATCH12 _ _ PERM).
      intro PERM2.
      simpl in PERM2.
      rewrite <- EQ12 in PERM2.
      generalize (simrel_address_inject _ _ _ _ _ _ _ _ Hm23 PERM2 INJ23).
      intro EQ23.
      rewrite <- EQ23.
      f_equal.
      rewrite Ptrofs.add_assoc.
      f_equal.
      rewrite Ptrofs.add_unsigned.
      auto using Ptrofs.eqm_samerepr,
      Ptrofs.eqm_add, Ptrofs.eqm_unsigned_repr.

    (** [Mem.aligned_area_inject] *)
    - intros (p12 & p23) m m' b ofs al sz b' delta (m2 & Hm12 & Hm23) H0 H1 H2 H3 H4 H5.
      simpl in H5.
      unfold compose_meminj in H5.
      destruct (simrel_meminj R12 p12 b) as [ [b2 delta12] | ] eqn:INJ12; try discriminate.
      destruct (simrel_meminj R23 p23 b2) as [ [b3 delta23] | ] eqn:INJ23; try discriminate.
      inversion H5; clear H5; subst.
      rewrite Z.add_assoc.
      generalize (simrel_aligned_area_inject _ _ _ _ _ _ _ _ _ Hm12 H0 H1 H2 H3 H4 INJ12).
      intro ALIGN2.
      assert (Mem.range_perm m2 b2 (ofs + delta12) (ofs + delta12 + sz) Cur Nonempty) as PERM2.
      {
        red.
        intros ofs0 H.
        replace ofs0 with (ofs0 - delta12 + delta12) by omega.
        apply (simrel_perm _ _ _ Hm12 (b, ofs0 - delta12) (b2, ofs0 - delta12 + delta12)).
        {
          econstructor; eauto.
        }
        red.
        eapply H3.
        omega.
      }
      exact (simrel_aligned_area_inject _ _ _ _ _ _ _ _ _ Hm23 H0 H1 H2 PERM2 ALIGN2 INJ23).

    (** [Mem.disjoint_or_equal_inject] *)
    - intros p m_1 m_3 b1 b1' delta1 b2 b2' delta2 ofs1 ofs2 sz (m_2 & Hm_12 & Hm_23) H0 H1 H2 H3 H4 H5.
      simpl in H0, H1.
      unfold compose_meminj in H0, H1.
      destruct (simrel_meminj R12 (fst p) b1) as [ [b1_2 delta1_12] | ] eqn:INJ1_12 ; try discriminate.
      destruct (simrel_meminj R23 (snd p) b1_2) as [ [b1_3 delta1_23] | ] eqn:INJ1_23 ; try discriminate.
      inversion H0; clear H0; subst.
      destruct (simrel_meminj R12 (fst p) b2) as [ [b2_2 delta2_12] | ] eqn:INJ2_12 ; try discriminate.
      destruct (simrel_meminj R23 (snd p) b2_2) as [ [b2_3 delta2_23] | ] eqn:INJ2_23 ; try discriminate.
      inversion H1; clear H1; subst.
      repeat rewrite Z.add_assoc.
      generalize (simrel_disjoint_or_equal_inject
      _ _ _ _ _ _ _ _ _ _ _ _ Hm_12 INJ1_12 INJ2_12 H2 H3 H4 H5).
      intro DOE.
      assert (Mem.range_perm m_2 b1_2 (ofs1 + delta1_12) (ofs1 + delta1_12 + sz) Max Nonempty) as PERM1_2.
      {
        red. intros.
        replace ofs with (ofs - delta1_12 + delta1_12) by omega.
        apply (simrel_perm _ _ _ Hm_12 (b1, ofs - delta1_12) (_, _)).
        {
          constructor.
          assumption.
        }
        simpl. apply H2. omega.
      }
      assert (Mem.range_perm m_2 b2_2 (ofs2 + delta2_12) (ofs2 + delta2_12 + sz) Max Nonempty) as PERM2_2.
      {
        red. intros.
        replace ofs with (ofs - delta2_12 + delta2_12) by omega.
        apply (simrel_perm _ _ _ Hm_12 (b2, ofs - delta2_12) (_, _)).
        {
          constructor.
          assumption.
        }
        simpl. apply H3. omega.
      }
      exact (simrel_disjoint_or_equal_inject
      _ _ _ _ _ _ _ _ _ _ _ _ Hm_23 INJ1_23 INJ2_23 PERM1_2 PERM2_2 H4 DOE).
  Qed.

  Definition simrel_compose: simrel D1 D2 -> simrel D2 D3 -> simrel D1 D3 :=
    fun R12 R23 =>
      {|
        simrel_ops := simrel_compose_ops R12 R23
      |}.

  Global Instance simrel_compose_equiv:
    Monotonic
      simrel_compose
      (simrel_equiv ++> simrel_equiv ++> simrel_equiv).
  Proof.
    clear.
    intros R12 S12 [f Hf] R23 S23 [g Hg].
    exists
      (Build_simrel_equiv_maps
         (simrel_compose R12 R23)
         (simrel_compose S12 S23)
         (fun p => match p with
                     | (p12, p23) =>
                       (simrel_equiv_fw f p12, simrel_equiv_fw g p23)
                   end)
         (fun q => match q with
                     | (q12, q23) =>
                       (simrel_equiv_bw f q12, simrel_equiv_bw g q23)
                   end)).
    split;
    try destruct p as [p12 p23];
    try destruct q as [q12 q23];
    simpl;
    simrel_equiv_rewrite;
    try reflexivity;
    repeat rstep;
    try (destruct H; destruct x; destruct y; rauto).
    - simpl.
      intros b [(b' & SUMB & Hb)|SUMB]; auto.
      left; eexists; split; eauto.
      eapply simrel_equiv_undef_matches_block_fw; eauto.
      eapply match_block_simrel_equiv_fw; eauto.
      right; eapply simrel_equiv_undef_matches_block_fw; eauto.
    - simpl.
      intros b [(b' & SUMB & Hb)|SUMB]; auto.
      left; eexists; split; eauto.
      eapply simrel_equiv_undef_matches_block_bw; eauto.
      eapply match_block_simrel_equiv_bw; eauto.
      right; eapply simrel_equiv_undef_matches_block_bw; eauto.
    - apply match_mem_simrel_equiv_fw.
    - apply match_mem_simrel_equiv_fw.
    - apply match_mem_simrel_equiv_bw.
    - apply match_mem_simrel_equiv_bw.
    - intros.
      unfold compose_meminj.
      generalize (simrel_equiv_meminj_fw p12 b).
      inversion 1; try constructor. subst.
      destruct y.
      generalize (simrel_equiv_meminj_fw p23 b0).
      inversion 1; try constructor. subst.
      destruct y. constructor; auto.
    - intros.
      unfold compose_meminj.
      generalize (simrel_equiv_meminj_bw p12 b).
      inversion 1; try constructor. subst.
      destruct y.
      generalize (simrel_equiv_meminj_bw p23 b0).
      inversion 1; try constructor. subst.
      destruct y. constructor; auto.
    - intros (p12 & p23).
      split; simpl; apply simrel_bw_fw_le.
    - intros (p12 & p23).
      split; simpl; apply simrel_fw_bw_le.
  Qed.
End COMPOSE.

Global Instance: Params (@simrel_compose) 2.

(** ** Categorical properties *)

Section CATEGORY.
  Context `{Hmem: BaseMemoryModel}.
  Context {D1 D2 D3 D4: layerdata}.

  Lemma simrel_compose_id_left (R: simrel D1 D2):
    simrel_equiv (simrel_compose R simrel_id) R.
  Proof.
    exists
      (Build_simrel_equiv_maps (simrel_compose R simrel_id) R
         (fun p => fst p)
         (fun q => (q, tt))).
    split; try destruct p as [p []]; simpl;
      rewrite ?orb_false_r;
      try reflexivity;
      try now solve_monotonic.
    - symmetry. apply app_nil_end.
    - rewrite match_block_simrel_id.
      intro b.
      intros [(b' & Hb' & Hb)|H]; try tauto.
      congruence.
    - rewrite match_block_simrel_id.
      intros p b SUMB. eauto.
    - apply rel_compose_id_left.
    - intros; apply rel_compose_id_left.
    - intro b.
      unfold compose_meminj, inject_id.
      destruct (simrel_meminj _ _ _) as [[? ?]|]; constructor; eauto.
      replace (z+0) with z by omega; eauto.
    - intros.
      unfold compose_meminj, inject_id.
      destruct (simrel_meminj _ _ _) as [[? ?]|]; constructor; eauto.
      replace (z+0) with z by omega; eauto.
  Qed.

  Lemma simrel_compose_id_right (R: simrel D1 D2):
    simrel_equiv (simrel_compose simrel_id R) R.
  Proof.
    exists
      (Build_simrel_equiv_maps (simrel_compose simrel_id R) R
         (fun p => snd p)
         (fun q => (tt, q))).
    split; try destruct p as [[] p]; simpl;
      rewrite ?orb_false_l;
      try reflexivity;
      try now solve_monotonic.
    - intros b [(b' & Hb' & Hb)|H]; try tauto.
    - intros p b A. eauto.
    - apply rel_compose_id_right.
    - intros; apply rel_compose_id_right.
    - unfold compose_meminj, inject_id.
      intros; destruct (simrel_meminj _ _ _) as [[? ?]|]; constructor; eauto.
    - unfold compose_meminj, inject_id.
      intros; destruct (simrel_meminj _ _ _) as [[? ?]|]; constructor; eauto.
  Qed.

  Hint Extern 2 (rel_compose ?R12 ?R23 ?x ?z) => eexists; split.

  Lemma simrel_compose_assoc:
    forall (R12: simrel D1 D2) (R23: simrel D2 D3) (R34: simrel D3 D4),
      simrel_equiv
        (simrel_compose (simrel_compose R12 R23) R34)
        (simrel_compose R12 (simrel_compose R23 R34)).
  Proof.
    intros.
    exists
      (Build_simrel_equiv_maps
         (simrel_compose (simrel_compose R12 R23) R34)
         (simrel_compose R12 (simrel_compose R23 R34))
         (fun p => match p with ((p1, p2), p3) => (p1, (p2, p3)) end)
         (fun q => match q with (q1, (q2, q3)) => ((q1, q2), q3) end)).
    split;
      try destruct p as [[p1 p2] p3];
      try destruct q as [q1 [q2 q3]];
      simpl; clear; try firstorder.
    - repeat rstep;
      destruct x as [ [ ? ? ] ? ];
      destruct y as [ [ ? ? ] ? ];
      firstorder.
    - repeat rstep;
      destruct x as [ ? [ ? ? ] ];
      destruct y as [ ? [ ? ? ] ];
      firstorder.
    - rewrite match_block_simrel_compose.
      intros [[b' [[(? & ? & ?)|?] ?]] | ?]; eauto 10.
    - destruct p. destruct p. simpl.
      rewrite match_block_simrel_compose.
      intros [(b' & Hb & Hb1)|[(b' & Hb & Hb1)|Hb]]; eauto 10.
      unfold rel_compose in Hb1. destruct Hb1 as (b'' & Hb1 & Hb2). eauto 10.
    - intros. destruct p. destruct p. simpl. apply rel_compose_assoc.
    - unfold compose_meminj.
      destruct (simrel_meminj R12 _ _) as [[? ?]|]; try constructor; eauto.
      destruct (simrel_meminj R23 _ _) as [[? ?]|]; try constructor; eauto.
      destruct (simrel_meminj R34 _ _) as [[? ?]|]; try constructor; eauto.
      rewrite Z.add_assoc.
      reflexivity.
    - unfold compose_meminj. simpl. destruct p. destruct p.
      destruct (simrel_meminj R12 _ _) as [[? ?]|]; try constructor; eauto.
      destruct (simrel_meminj R23 _ _) as [[? ?]|]; try constructor; eauto.
      destruct (simrel_meminj R34 _ _) as [[? ?]|]; try constructor; eauto.
      rewrite Z.add_assoc.
      reflexivity.
    - destruct w as ((p12 & p23) & p34); simpl. reflexivity.
    - destruct w as ((p12 & p23) & p34); simpl. reflexivity.
    - destruct w as ((p12 & p23) & p34); simpl. reflexivity.
    - destruct w as (p12 & p23 & p34); simpl. reflexivity.
    - destruct w as (p12 & p23 & p34); simpl. reflexivity.
    - destruct w as (p12 & p23 & p34); simpl. reflexivity.
  Qed.
End CATEGORY.

(** ** [simrel] is a [Category] *)

Section SIMREL.
  Context `{Hmem: BaseMemoryModel}.

  Global Instance simrel_cat_ops: CategoryOps layerdata simrel :=
    {
      cat_equiv D1 D2 := {| equiv := simrel_equiv |};
      cat_id D := {| id := simrel_id |};
      cat_compose D1 D2 D3 := {| compose := simrel_compose |}
    }.

  Global Instance simrel_cat_prf: Category layerdata simrel.
  Proof.
    split; try typeclasses eauto; intros; simpl.
    - apply simrel_compose_id_left.
    - apply simrel_compose_id_right.
    - apply simrel_compose_assoc.
  Qed.
End SIMREL.


(** ******************************************

Binary coproducts defined as a colimit

Written by: Benedikt Ahrens, March 2015

*********************************************)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.

Require Import UniMath.MoreFoundations.Tactics.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.limits.graphs.colimits.
Require Import UniMath.CategoryTheory.limits.graphs.eqdiag.
Require Import UniMath.CategoryTheory.limits.bincoproducts.

Local Open Scope cat.

(** * Definition of binary coproduct of objects in a precategory *)

Definition two_graph : graph.
Proof.
  exists bool.
  exact (λ _ _, empty).
Defined.

Definition bincoproduct_diagram {C : category} (a b : C) : diagram two_graph C.
Proof.
  exists (λ x : bool, if x then a else b).
  intros u v F.
  induction F.
Defined.

Definition CopCocone {C : category} {a b : C} {c : C} (ac : a --> c) (bc : b --> c) :
   cocone (bincoproduct_diagram a b) c.
Proof.
  use tpair.
+ intro v.
  induction v; simpl.
  - exact ac.
  - exact bc.
+ intros u v e; induction e.
Defined.

Section bincoproduct_def.

Variable C : category.

Definition isBinCoproductCocone (a b co : C) (ia : a --> co) (ib : b --> co) :=
  isColimCocone (bincoproduct_diagram a b) co (CopCocone ia ib).

Definition make_isBinCoproductCocone (hsC : has_homsets C)(a b co : C) (ia : a --> co) (ib : b --> co) :
   (∏ (c : C) (f : a --> c) (g : b --> c),
    ∃! k : C ⟦co, c⟧,
      ia · k = f ×
      ib · k = g)
   →
   isBinCoproductCocone a b co ia ib.
Proof.
  intros H c cc.
  set (H':= H c (coconeIn cc true) (coconeIn cc false)).
  use tpair.
  - exists (pr1 (pr1 H')).
    set (T := pr2 (pr1 H')). simpl in T.
    abstract (intro u; induction u;
              [ apply (pr1 T) | apply (pr2 T)]).
  - simpl. intros. abstract (intros;
              apply subtypePath;
              [ intro; apply impred; intro; apply hsC
              | apply path_to_ctr; split; [ apply (pr2 t true) | apply (pr2 t false)] ]).
Defined.

Definition BinCoproductCocone (a b : C) :=
  ColimCocone (bincoproduct_diagram a b).

Definition make_BinCoproductCocone (a b : C) :
  ∏ (c : C) (f : a --> c) (g : b --> c),
   isBinCoproductCocone _ _ _ f g →  BinCoproductCocone a b.
Proof.
  intros.
  use tpair.
  - exists c.
    apply (CopCocone f g).
  - apply X.
Defined.

Definition BinCoproducts := ∏ (a b : C), BinCoproductCocone a b.
Definition hasBinCoproducts := ∏ (a b : C), ∥ BinCoproductCocone a b ∥.

Definition BinCoproductObject {a b : C} (CC : BinCoproductCocone a b) : C := colim CC.
Definition BinCoproductIn1 {a b : C} (CC : BinCoproductCocone a b): a --> BinCoproductObject CC
  := colimIn CC true.

Definition BinCoproductIn2 {a b : C} (CC : BinCoproductCocone a b) : b --> BinCoproductObject CC
  := colimIn CC false.

Definition BinCoproductArrow {a b : C} (CC : BinCoproductCocone a b) {c : C} (f : a --> c) (g : b --> c) :
      BinCoproductObject CC --> c.
Proof.
  apply (colimArrow CC).
  use make_cocone.
  + intro v. induction v.
    - apply f.
    - apply g.
  + simpl. intros ? ? e; induction e.
Defined.

Lemma BinCoproductIn1Commutes (a b : C) (CC : BinCoproductCocone a b):
     ∏ (c : C) (f : a --> c) g, BinCoproductIn1 CC · BinCoproductArrow CC f g  = f.
Proof.
  intros c f g.
  unfold BinCoproductIn1.
  set (H:=colimArrowCommutes CC  _ (CopCocone f g) true).
  apply H.
Qed.

Lemma BinCoproductIn2Commutes (a b : C) (CC : BinCoproductCocone a b):
     ∏ (c : C) (f : a --> c) g, BinCoproductIn2 CC · BinCoproductArrow CC f g = g.
Proof.
  intros c f g.
  unfold BinCoproductIn1.
  set (H:=colimArrowCommutes CC  _ (CopCocone f g) false).
  apply H.
Qed.

Lemma BinCoproductArrowUnique (a b : C) (CC : BinCoproductCocone a b) (x : C)
    (f : a --> x) (g : b --> x) (k : BinCoproductObject CC --> x) :
    BinCoproductIn1 CC · k = f → BinCoproductIn2 CC · k = g →
      k = BinCoproductArrow CC f g.
Proof.
  intros H1 H2.
  use colimArrowUnique.
  simpl. intro u; induction u; simpl.
  - apply H1.
  - apply H2.
Qed.

Lemma BinCoproductArrowEta (a b : C) (CC : BinCoproductCocone a b) (x : C)
    (f : BinCoproductObject CC --> x) :
    f = BinCoproductArrow CC (BinCoproductIn1 CC · f) (BinCoproductIn2 CC · f).
Proof.
  apply BinCoproductArrowUnique;
  apply idpath.
Qed.

Definition BinCoproductOfArrows {a b : C} (CCab : BinCoproductCocone a b) {c d : C}
    (CCcd : BinCoproductCocone c d) (f : a --> c) (g : b --> d) :
          BinCoproductObject CCab --> BinCoproductObject CCcd :=
    BinCoproductArrow CCab (f · BinCoproductIn1 CCcd) (g · BinCoproductIn2 CCcd).

Lemma BinCoproductOfArrowsIn1 {a b : C} (CCab : BinCoproductCocone a b) {c d : C}
    (CCcd : BinCoproductCocone c d) (f : a --> c) (g : b --> d) :
    BinCoproductIn1 CCab · BinCoproductOfArrows CCab CCcd f g = f · BinCoproductIn1 CCcd.
Proof.
  unfold BinCoproductOfArrows.
  apply BinCoproductIn1Commutes.
Qed.

Lemma BinCoproductOfArrowsIn2 {a b : C} (CCab : BinCoproductCocone a b) {c d : C}
    (CCcd : BinCoproductCocone c d) (f : a --> c) (g : b --> d) :
    BinCoproductIn2 CCab · BinCoproductOfArrows CCab CCcd f g = g · BinCoproductIn2 CCcd.
Proof.
  unfold BinCoproductOfArrows.
  apply BinCoproductIn2Commutes.
Qed.

Lemma precompWithBinCoproductArrow {a b : C} (CCab : BinCoproductCocone a b) {c d : C}
    (CCcd : BinCoproductCocone c d) (f : a --> c) (g : b --> d)
    {x : C} (k : c --> x) (h : d --> x) :
        BinCoproductOfArrows CCab CCcd f g · BinCoproductArrow CCcd k h =
         BinCoproductArrow CCab (f · k) (g · h).
Proof.
  apply BinCoproductArrowUnique.
  - rewrite assoc. rewrite BinCoproductOfArrowsIn1.
    rewrite <- assoc, BinCoproductIn1Commutes.
    apply idpath.
  - rewrite assoc, BinCoproductOfArrowsIn2.
    rewrite <- assoc, BinCoproductIn2Commutes.
    apply idpath.
Qed.

Lemma postcompWithBinCoproductArrow {a b : C} (CCab : BinCoproductCocone a b) {c : C}
    (f : a --> c) (g : b --> c) {x : C} (k : c --> x)  :
       BinCoproductArrow CCab f g · k = BinCoproductArrow CCab (f · k) (g · k).
Proof.
  apply BinCoproductArrowUnique.
  -  rewrite assoc, BinCoproductIn1Commutes;
     apply idpath.
  -  rewrite assoc, BinCoproductIn2Commutes;
     apply idpath.
Qed.

End bincoproduct_def.

Arguments BinCoproductCocone [_] _ _.
Arguments BinCoproductObject [_ _ _] _ .
Arguments BinCoproductArrow [_ _ _] _ [_] _ _.
Arguments BinCoproductIn1 [_ _ _] _.
Arguments BinCoproductIn2 [_ _ _] _.

(** * Proof that coproducts are unique when the precategory [C] is a univalent_category *)

Section coproduct_unique.

Variable C : category.
Hypothesis H : is_univalent C.

Variables a b : C.

Definition from_BinCoproduct_to_BinCoproduct (CC CC' : BinCoproductCocone a b)
  : BinCoproductObject CC --> BinCoproductObject CC'.
Proof.
  apply (BinCoproductArrow CC  (BinCoproductIn1 _ ) (BinCoproductIn2 _ )).
Defined.

Lemma BinCoproduct_endo_is_identity (CC : BinCoproductCocone a b)
  (k : BinCoproductObject CC --> BinCoproductObject CC)
  (H1 : BinCoproductIn1 CC · k = BinCoproductIn1 CC)
  (H2 : BinCoproductIn2 CC · k = BinCoproductIn2 CC)
  : identity _ = k.
Proof.
(*  apply pathsinv0. *)
  use colim_endo_is_identity.
  intro u; induction u; simpl; assumption.
Defined.

Lemma is_z_iso_from_BinCoproduct_to_BinCoproduct (CC CC' : BinCoproductCocone a b)
  : is_z_isomorphism (from_BinCoproduct_to_BinCoproduct CC CC').
Proof.
  exists (from_BinCoproduct_to_BinCoproduct CC' CC).
  split; simpl.
  - apply pathsinv0.
    apply BinCoproduct_endo_is_identity.
    + rewrite assoc. unfold from_BinCoproduct_to_BinCoproduct.
      rewrite BinCoproductIn1Commutes.
      rewrite BinCoproductIn1Commutes.
      apply idpath.
    + rewrite assoc. unfold from_BinCoproduct_to_BinCoproduct.
      rewrite BinCoproductIn2Commutes.
      rewrite BinCoproductIn2Commutes.
      apply idpath.
  - apply pathsinv0.
    apply BinCoproduct_endo_is_identity.
    + rewrite assoc; unfold from_BinCoproduct_to_BinCoproduct.
      repeat rewrite BinCoproductIn1Commutes; apply idpath.
    + rewrite assoc; unfold from_BinCoproduct_to_BinCoproduct.
      repeat rewrite BinCoproductIn2Commutes; apply idpath.
Defined.

Definition z_iso_from_BinCoproduct_to_BinCoproduct (CC CC' : BinCoproductCocone a b)
  : z_iso (BinCoproductObject CC) (BinCoproductObject CC')
  := make_z_iso' _ (is_z_iso_from_BinCoproduct_to_BinCoproduct CC CC').

(* should be an instance of a lemma about colimits *)
(*
Lemma isaprop_BinCoproductCocone : isaprop (BinCoproductCocone a b).
Proof.
  apply invproofirrelevance.
  intros CC CC'.
  apply subtypePath.
  + intros.
    unfold isColimCocone.
    do 2 (apply impred; intro); apply isapropiscontr.
  + apply (total2_paths_f (isotoid _ H (iso_from_BinCoproduct_to_BinCoproduct CC CC'))).
    rewrite transportf_dirprod.
    rewrite transportf_isotoid'. simpl.
    rewrite transportf_isotoid'.
    destruct CC as [CC bla].
    destruct CC' as [CC' bla']; simpl in *.
    destruct CC as [CC [CC1 CC2]].
    destruct CC' as [CC' [CC1' CC2']]; simpl in *.
    unfold from_BinCoproduct_to_BinCoproduct.
    rewrite BinCoproductIn1Commutes.
    rewrite BinCoproductIn2Commutes.
    apply idpath.
Qed.
*)

End coproduct_unique.

Definition limits_isBinCoproductCocone_from_isBinCoproduct (C : category) {a b c}
           (u : C ⟦ a, c⟧)(v : C ⟦ b, c⟧) :
  limits.bincoproducts.isBinCoproduct C a b c u v -> isBinCoproductCocone _ _ _ _ u v :=
  make_isBinCoproductCocone _ C _ _ _ _ _.

Lemma limits_isBinCoproduct_from_isBinCoproductCocone (C : category) {a b c}
      (u : C ⟦ a, c⟧)(v : C ⟦ b, c⟧) :
  isBinCoproductCocone _ _ _ _ u v -> limits.bincoproducts.isBinCoproduct C a b c u v.
Proof.
  intro h.
  set (CC := make_BinCoproductCocone _ _ _ _ _ _ h); simpl.
  intros x f g.
  (* set (CCfg := (bincoproducts.BinCoproductArrow C CC f g)). *)
  use unique_exists; simpl.
  - apply (bincoproducts.BinCoproductArrow CC f g).
  - abstract (split;
              [ apply (bincoproducts.BinCoproductIn1Commutes  _ _ _ CC)
              | apply (bincoproducts.BinCoproductIn2Commutes  _ _ _ CC)]).
  - abstract (intros h'; apply isapropdirprod; apply C).
  - intros h' [H1 H2].
    eapply (bincoproducts.BinCoproductArrowUnique _ _ _ CC).
    + exact H1.
    + exact H2.
Defined.

Lemma BinCoproducts_from_Colims (C : category) :
  Colims_of_shape two_graph C -> BinCoproducts C.
Proof.
now intros H a b; apply H.
Defined.

(** Post-composing a bincoproduct diagram with a functor yields a
     bincoproduct diagram. *)
Lemma mapdiagram_bincoproduct_eq_diag {C : category}{D : category}
      (F : functor C D)(a b : C)  :
  eq_diag (C := D)
          (mapdiagram F (bincoproducts.bincoproduct_diagram a b))
          (bincoproducts.bincoproduct_diagram (F a) (F b)).
Proof.
  use tpair.
  - use bool_rect; apply idpath.
  - intros ??; use empty_rect.
Defined.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D O Oprime M C1 D1 : Universe, ((wd_ O M /\ (wd_ Oprime M /\ (wd_ A B /\ (wd_ B C1 /\ (wd_ A C1 /\ (wd_ B Oprime /\ (wd_ A Oprime /\ (wd_ B D /\ (wd_ A D /\ (wd_ B O /\ (wd_ A O /\ (wd_ B C /\ (wd_ A C /\ (wd_ M A /\ (wd_ M B /\ (wd_ Oprime D1 /\ (wd_ M D1 /\ (wd_ O C1 /\ (wd_ M C1 /\ (wd_ A D1 /\ (wd_ B D1 /\ (col_ O Oprime M /\ (col_ M A B /\ (col_ D1 Oprime M /\ col_ C1 O M)))))))))))))))))))))))) -> col_ C1 D1 M)).
Proof.
  time tac.
Qed.

End FOFProblem.


(** * Definition of Context Free Grammars *)
Require Import Coq.Strings.String Coq.Lists.List Coq.Program.Program.
Require Export ParsingParses.Parsers.StringLike.

Set Implicit Arguments.
Local Set Boolean Equality Schemes.
Local Set Decidable Equality Schemes.

Delimit Scope string_like_scope with string_like.

Section cfg.
  Variable CharType : Type.

  Section definitions.
    (** An [item] is the basic building block of a context-free
        grammar; it is either a terminal ([CharType]-literal) or a
        nonterminal ([string]). *)
    Inductive item :=
    | Terminal (_ : CharType)
    | NonTerminal (_ : string).

    (** A [productions] is a list of possible [production]s; a
        [production] is a list of [item]s.  A string matches a
        [production] if it can be broken up into components that match
        the relevant element of the [production]. *)
    Definition production := list item.
    Definition productions := list production.

    Definition production_dec (CharType_eq_dec : forall x y : CharType, {x = y} + {x <> y})
               (x y : production) : {x = y} + {x <> y}.
    Proof.
      repeat (apply list_eq_dec; intros);
      decide equality.
      apply string_dec.
    Defined.

    Definition productions_dec (CharType_eq_dec : forall x y : CharType, {x = y} + {x <> y})
               (x y : productions) : {x = y} + {x <> y}.
    Proof.
      apply list_eq_dec; intros; apply production_dec; assumption.
    Defined.

    (** A [grammar] consists of [productions] to match a string
        against, and a function mapping names to [productions]. *)
    (** TODO(jgross): look up notations for specifying these nicely *)
    Record grammar :=
      {
        Start_symbol :> string;
        Lookup :> string -> productions;
        Start_productions :> productions := Lookup Start_symbol;
        Valid_nonterminals : list string;
        Valid_productions : list productions := map Lookup Valid_nonterminals
      }.
  End definitions.

  Section parse.
    Variable String : string_like CharType.
    Variable G : grammar.
    (** A parse of a string into [productions] is a [production] in
        that list, together with a list of substrings which cover the
        original string, each of which is a parse of the relevant
        component of the [production]. *)
    Inductive parse_of : String -> productions -> Type :=
    | ParseHead : forall str pat pats, parse_of_production str pat
                                       -> parse_of str (pat::pats)
    | ParseTail : forall str pat pats, parse_of str pats
                                       -> parse_of str (pat::pats)
    with parse_of_production : String -> production -> Type :=
    | ParseProductionNil : parse_of_production (Empty _) nil
    | ParseProductionCons : forall str pat strs pats,
                           parse_of_item str pat
                           -> parse_of_production strs pats
                           -> parse_of_production (str ++ strs) (pat::pats)
    with parse_of_item : String -> item -> Type :=
    | ParseTerminal : forall x, parse_of_item [[ x ]]%string_like (Terminal x)
    | ParseNonTerminal : forall nt str, parse_of str (Lookup G nt)
                                        -> parse_of_item str (NonTerminal nt).

    Definition ParseProductionSingleton str it (p : parse_of_item str it) : parse_of_production str [ it ].
    Proof.
      rewrite <- (RightId _ str).
      constructor; assumption || constructor.
    Defined.

    Definition ParseProductionApp str1 str2 p1 p2 (pop1 : parse_of_production str1 p1) (pop2 : parse_of_production str2 p2)
    : parse_of_production (str1 ++ str2) (p1 ++ p2)%list.
    Proof.
      induction pop1; simpl.
      { rewrite LeftId; assumption. }
      { rewrite Associativity.
        constructor; assumption. }
    Defined.

    Definition ParseApp str1 str2 p1 p2 (po1 : parse_of str1 [ p1 ]) (po2 : parse_of str2 [ p2 ])
    : parse_of (str1 ++ str2) [ (p1 ++ p2)%list ].
    Proof.
      inversion_clear po1; inversion_clear po2;
      try match goal with
            | [ H : parse_of _ [] |- _ ] => exfalso; revert H; clear; intro H; abstract inversion H
          end.
      { constructor. apply ParseProductionApp; assumption. }
    Defined.
  End parse.

  Definition parse_of_grammar (String : string_like CharType) (str : String) (G : grammar) :=
    parse_of String G str G.
End cfg.

Arguments parse_of _%type_scope _ _ _%string_like _.
Arguments parse_of_item _%type_scope _ _ _%string_like _.
Arguments parse_of_production _%type_scope _ _ _%string_like _.
Arguments parse_of_grammar _%type_scope _ _%string_like _.

Local Hint Extern 0 => match goal with H : S _ = 0 |- _ => destruct (NPeano.Nat.neq_succ_0 _ H) end.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

  Getting the heap really right including issues of searching
  through the heap, assigning into the heap and getting an
  address in the heap.

  Alpha conversion can probably be ignored here.

*)

Require Import List.
Export ListNotations.
Require Import ZArith.
Require Import Init.Datatypes.

Require Export FormalSyntax.
Require Export DynamicSemanticsTypeSubstitution.
Require Export DynamicSemanticsHeapObjects.
Require Export DynamicSemantics.
Require Export Tacticals.

Require Export TestUtilities.

Example assign_int :
 S ([] ++ [(x, (i_e (i_i 0)))] ++ [])
   (seq (e_s (assign (p_e x []) (i_e (i_i 1)))) (retn (p_e x [])))
   ([] ++ [(x, (i_e (i_i 1)))] ++ [])
   (seq (e_s (i_e (i_i 1))) (retn (p_e x []))).
Proof.
  apply S_seq_3_10.
  apply S_exp_3_9_1.
  apply R_assign_3_2;
  eauto with Chapter3.
Qed.

Example assign_int_no_nils :
 S [(x, (i_e (i_i 0)))]
   (seq (e_s (assign (p_e x []) (i_e (i_i 1)))) (retn (p_e x [])))
   [(x, (i_e (i_i 1)))]
   (seq (e_s (i_e (i_i 1))) (retn (p_e x []))).
Proof.
 eauto 20 with Chapter3.
Qed.

Example assign_x_gets_address_y :
 S [(x, (i_e (i_i 0))); (y, (i_e (i_i 0)))]
   (e_s (assign (p_e x []) (amp (p_e y []))))
   [(x, (amp (p_e y []))); (y, (i_e (i_i 0)))]
   (e_s (amp (p_e y []))).
Proof.
  debug eauto 20 with Chapter3.
  apply S_exp_3_9_1.
  debug eauto 20 with Chapter3.
  (*   apply R_assign_3_2. *)
Admitted.


Require Export PredMonad.Ordered5.OrderedType.

Import OTNotations.

(***
 *** The monad typeclass
 ***)

Class MonadOps `(M: OTypeF) : Type :=
  { returnM : forall `{ValidOType}, A -o> M @t@ A;
    bindM : forall `{ValidOType} `{B:OType} {_:ValidOType B},
        M @t@ A -o> (A -o> M @t@ B) -o> M @t@ B }.

Class Monad `(MOps:MonadOps) : Prop :=
  {
    monad_ValidOTypeF :> ValidOTypeF M;

    monad_return_bind :
      forall `(A:OType) `(B:OType) `(@ValidOType T A) `(@ValidOType T0 B)
             (f: A -o> M @t@ B) x,
        bindM @o@ (returnM @o@ x) @o@ f =o= f @o@ x;

    monad_bind_return :
      forall `(A:OType) `(@ValidOType T A) m,
        bindM @o@ m @o@ returnM =o= m;

    monad_assoc :
      forall `(A:OType) `(B:OType) `(C:OType)
             `(@ValidOType T A) `(@ValidOType T0 B) `(@ValidOType T1 C)
             m (f: A -o> M @t@ B) (g: B -o> M @t@ C),
        bindM @o@ (bindM @o@ m @o@ f) @o@ g
        =o=
        bindM @o@ m @o@ (mkOTerm _ (fun x => bindM @o@ (f @o@ x) @o@ g));
  }.

(* Helpful bind notation *)
Notation "'do' x <- m1 ; m2" :=
  (bindM @o@ m1 (mkOTerm _ (fun x => m2))) (at level 60, right associativity).

(***
 *** OTHasType Typing Rules
 ***)

(* Typing for returnM *)
Instance OTHasType_returnM `(Monad) `(A:OType) (_:ValidOType A) :
  OTHasType (A -o> M @t@ A) (ot_R (OTarrow A (M @t@ A))) returnM returnM.
Proof.
  apply OTHasType_Proper. unfold Proper. reflexivity.
Defined.

(* Typing for bindM *)
Instance OTHasType_bindM `(Monad) `(A:OType) `(B:OType)
         (_:ValidOType A) (_:ValidOType B) :
  OTHasType (M @t@ A -o> (A -o> M @t@ B) -o> M @t@ B)
            (ot_R (OTarrow (M @t@ A) ((A -o> M @t@ B) -o> M @t@ B)))
            bindM bindM.
Proof.
  apply OTHasType_Proper. unfold Proper. reflexivity.
Defined.

(***
 *** The Identity Monad
 ***)

Instance Identity : OTypeF (fun `(A:OType) => T) :=
  fun `(A:OType) => A.

Instance Valid_Identity : ValidOTypeF Identity.
Proof. constructor; typeclasses eauto. Qed.

Instance IdMonad_MonadOps : MonadOps Identity :=
  { returnM := fun `{ValidOType} =>
                 mkOTerm (A -o> Identity @t@ A) (fun x => x);
    bindM := fun `{ValidOType} `{B:OType} `{@ValidOType T0 B} =>
               mkOTerm (A -o> (A -o> B) -o> B)
                       (fun m (f:Pfun A B) => f @o@ m) }.

Instance IdMonad : Monad IdMonad_MonadOps.
Proof.
  refine ({| monad_ValidOTypeF:=Valid_Identity |}); intros; simpl; reflexivity.
Qed.


From Undecidability Require Import TM.Util.TM_facts.
Require Import Undecidability.Shared.Libs.PSL.FiniteTypes.DepPairs EqdepFacts.

Section While.

  Variable n : nat.
  Variable sig : finType.

  Variable F : finType.
  (* Label [None] indicates continueing, [Some f] means breaking out of the loop and terminating in the label [f]. *)
  Variable pM : pTM sig (option F) n.

  Definition While_trans :
    (TM.state (projT1 pM)) * Vector.t (option sig) n ->
    (TM.state (projT1 pM)) * Vector.t (option sig * move) n :=
    fun '(q,s) =>
      if halt q
      then (start (projT1 pM), nop_action)
      else trans (q,s).

  Definition WhileTM : TM sig n :=
    Build_TM While_trans (start (projT1 pM))
              (fun q => halt q && match projT2 pM q with
                               | Some _ => true
                               | None => false
                               end).

  Hypothesis (defF : inhabitedC F).

  Definition While_part : state (projT1 pM) -> F :=
    fun q =>
      match projT2 pM q with
      | Some y => y
      | None => default
      end.

  Definition While : pTM sig F n :=
    (WhileTM; While_part).

  Local Arguments loopM {_ _} _ _ _.
  Local Arguments halt {_ _} _ _.
  Local Arguments step {_ _} _ _.

  Lemma step_comp (c : mconfig sig (state (projT1 pM)) n) :
    haltConf c = false ->
    step (projT1 pM) c = step WhileTM c.
  Proof.
    intros HHalt. unfold haltConf in HHalt.
    destruct c as [q t]. cbn in *.
    cbv [step]. cbn. rewrite HHalt. reflexivity.
  Qed.

  Lemma halt_comp (c : mconfig sig (state (projT1 pM)) n) :
    haltConf (M := projT1 pM) c = false ->
    haltConf (M := WhileTM)     c = false.
  Proof.
    intros HHalt. cbn in *.
    destruct c as [q t]. cbn in *.
    apply andb_false_iff. now left.
  Qed.

  Lemma While_trans_repeat (c : mconfig sig (state WhileTM) n) :
    haltConf (M := projT1 pM) c = true ->
    projT2 pM (cstate c) = None ->
    step WhileTM c = initc (WhileTM) (ctapes c).
  Proof.
    intros HHalt HRepeat. unfold haltConf in HHalt.
    destruct c as [q t]; cbn in *.
    unfold step. cbn -[doAct_multi] in *. rewrite HHalt. unfold initc. f_equal. apply doAct_nop.
  Qed.

  Lemma While_split k (c1 c3 : mconfig sig (state (projT1 pM)) n) :
    loopM WhileTM c1 k = Some c3 ->
    exists k1 k2 c2,
      loopM (projT1 pM) c1 k1 = Some c2 /\
      loopM WhileTM c2 k2 = Some c3 /\
      k1 + k2 <= k.
  Proof.
    unfold loopM. intros HLoop.
    apply loop_split with (h := haltConf (M := projT1 pM)) in HLoop as (k1&c2&k2&HLoop&HLoop'&Hk).
    - exists k1, k2, c2. repeat split; eauto.
      apply loop_lift with (lift := id) (f' := step (projT1 pM)) (h' := haltConf (M := projT1 pM)) in HLoop.
      + apply HLoop.
      + auto.
      + apply step_comp.
    - apply halt_comp.
  Qed.

  Lemma While_split_repeat k (c1 c2 : mconfig sig (state WhileTM) n) :
    loopM WhileTM c1 k = Some c2 ->
    haltConf (M := projT1 pM) c1 = true ->
    projT2 pM (cstate c1) = None ->
    exists k' : nat,
      k = S k' /\
      loopM WhileTM (initc WhileTM (ctapes c1)) k' = Some c2.
  Proof.
    intros HLoop HHalt HRepeat. unfold haltConf in HHalt.
    destruct k as [ | k']; cbn in *.
    - rewrite HHalt, HRepeat in HLoop. cbn in HLoop. inv HLoop.
    - rewrite HHalt, HRepeat in HLoop. cbn in HLoop. exists k'. split. reflexivity.
      now rewrite While_trans_repeat in HLoop by auto.
  Qed.

  Lemma While_split_term k (c1 c2 : mconfig sig (state WhileTM) n) (f : F) :
    loopM WhileTM c1 k = Some c2 ->
    haltConf (M := projT1 pM) c1 = true ->
    projT2 pM (cstate c1) = Some f ->
    c2 = c1.
  Proof.
    intros HLoop HHalt HTerm. unfold loopM in *.
    eapply loop_eq_0. 2: apply HLoop. unfold haltConf in *. cbn in *. now rewrite HHalt, HTerm.
  Qed.

  Lemma While_merge_repeat k1 k2 (c1 c2 c3 : mconfig sig (state WhileTM) n) :
    loopM (projT1 pM) c1 k1 = Some c2 ->
    (projT2 pM) (cstate c2) = None ->
    loopM WhileTM (initc WhileTM (ctapes c2)) k2 = Some c3 ->
    loopM WhileTM c1 (k1+(1+k2)) = Some c3.
  Proof.
    intros HLoop1 HRepeat HLoop2. unfold loopM in *.
    eapply loop_lift with (lift := id) (f' := step (WhileTM)) (h' := haltConf (M := projT1 pM)) in HLoop1; cbv [id] in *; cbn; auto; cycle 1.
    { intros. symmetry. now apply step_comp. }
    apply loop_merge with (h := haltConf (M := projT1 pM)) (a2 := c2).
    - apply halt_comp.
    - apply HLoop1.
    - cbn [loop plus]. rewrite While_trans_repeat; auto. 2: apply (loop_fulfills HLoop1).
      cbn in *. setoid_rewrite (loop_fulfills HLoop1). now rewrite HRepeat.
  Qed.

  Lemma While_merge_term k1 (c1 c2 : mconfig sig (state WhileTM) n) (f : F) :
    loopM (projT1 pM) c1 k1 = Some c2 ->
    (projT2 pM) (cstate c2) = Some f ->
    loopM WhileTM c1 k1 = Some c2.
  Proof.
    intros HLoop HTerm. unfold loopM in *.
    eapply loop_lift with (lift := id) (f' := step (WhileTM)) (h' := haltConf (M := projT1 pM)) in HLoop; cbv [id] in *; cbn; auto; cycle 1.
    { intros. symmetry. now apply step_comp. }
    unfold loopM.
    replace k1 with (k1 + 0) by lia.
    apply loop_merge with (h := haltConf (M := projT1 pM)) (a2 := c2).
    - apply halt_comp.
    - apply HLoop.
    - cbn in *. setoid_rewrite (loop_fulfills HLoop). rewrite HTerm. cbn. reflexivity.
  Qed.

  (* ** Correctness of [While] *)

  Variable R : pRel sig (option F) n.

  Inductive While_Rel : pRel sig F n :=
  | While_Rel''_one :
      forall tin yout tout, R tin (Some yout, tout) -> While_Rel tin (yout, tout)
  | While_Rel''_loop :
      forall tin tmid yout tout,
        R tin (None, tmid) ->
        While_Rel tmid (yout, tout) ->
        While_Rel tin (yout, tout).

  Lemma While_Realise :
    pM ⊨ R -> While ⊨ While_Rel.
  Proof.
    intros HRel. hnf in HRel; hnf. intros t k; revert t. apply complete_induction with (x := k); clear k; intros k IH. intros tin c3 HLoop.
    apply While_split in HLoop as (k1&k2&c2&HLoop1&HLoop2&Hk).
    destruct (projT2 pM (cstate c2)) as [ f | ] eqn:E; cbn in *; [ clear IH | ].
    - apply While_split_term with (f := f) in HLoop2 as ->; auto. 2: apply (loop_fulfills HLoop1). unfold While_part. rewrite E.
      constructor 1. specialize HRel with (1 := HLoop1). now rewrite E in HRel.
    - apply While_split_repeat in HLoop2 as (k2'&->&HLoop2); auto. 2: apply (loop_fulfills HLoop1).
      specialize IH with (2 := HLoop2); spec_assert IH by lia.
      econstructor 2.
      + specialize HRel with (1 := HLoop1). rewrite E in HRel. eassumption.
      + apply IH.
  Qed.

  (* ** Termination of [While] *)
  Section While_TerminatesIn.
    Variable (T T' : Rel (tapes sig n) nat).

    Lemma While_TerminatesIn_ind :
      pM ⊨ R ->
      projT1 pM ↓ T' ->
      (forall (tin : tapes sig n) (k : nat),
          T tin k ->
          exists k1,
            T' tin k1 /\
            (forall ymid tmid, R tin (Some ymid, tmid) -> k1 <= k) /\
            (forall tmid, R tin (None, tmid) -> exists k2, T tmid k2 /\ 1 + k1 + k2 <= k)) ->
      WhileTM ↓T.
    Proof.
      intros Realise_M Term_M Hyp tin i. revert tin. apply complete_induction with (x:=i); clear i; intros i IH tin.
      intros (i1&HT1&HT2&HT3) % Hyp. (* todo: i *)
      pose proof (Term_M _ _ HT1) as (oconf&Hloop).
      specialize (Realise_M _ _ _ Hloop).
      destruct (projT2 pM (cstate oconf)) as [ ymid | ] eqn:E1.
      - specialize HT2 with (1 := Realise_M).
        exists oconf. eapply loop_monotone; eauto. eapply While_merge_term; eauto.
      - specialize HT3 with (1 := Realise_M) as (i2&HT3&Hi).
        specialize (IH i2 ltac:(lia) _ HT3) as (oconf2&Hloop2).
        exists oconf2. apply loop_monotone with (k1 := i1 + (1 + i2)). 2: lia.
        eapply While_merge_repeat; eauto.
    Qed.

  End While_TerminatesIn.

  (* Alternative for [While_TerminatesIn] using co-induction *)
  Section While_TerminatesIn_coind.
    Variable (T : Rel (tapes sig n) nat).

    CoInductive While_T : tRel sig n :=
    | While_T_intro tin k k1 :
        T tin k1 ->
        (forall tmid ymid,
            R tin (Some ymid, tmid) -> k1 <= k) ->
        (forall tmid,
            R tin (None, tmid) ->
            exists k2, While_T tmid k2 /\ 1 + k1 + k2 <= k) ->
        While_T tin k.

    Lemma While_TerminatesIn :
      pM ⊨ R ->
      projT1 pM ↓ T ->
      WhileTM ↓ While_T.
    Proof.
      intros HRel HTerm. eapply While_TerminatesIn_ind; eauto.
      intros tin k' HCoInd. destruct HCoInd as [ t k k1 H1 H2 H3 ]. eauto.
    Qed.

  End While_TerminatesIn_coind.

End While.

Arguments While : simpl never.
Arguments While {n sig F} pM {defF}.

(* Deprecated name *)
Notation WHILE := While (only parsing).

(* ** (Co-) Induction Principle for Correctness (Running Time) of [While] *)

Section WhileInduction.
  Variable (sig : finType) (n : nat) (F : finType).

  Variable R1 : pRel sig (option F) n.
  Variable R2 : pRel sig F n.

  Lemma WhileInduction :
    (forall tin yout tout (HLastStep: R1 tin (Some yout, tout)), R2 tin (yout, tout)) ->
    (forall tin tmid tout yout
       (HStar : R1 tin (None, tmid)) (HLastStep : R2 tmid (yout, tout)), R2 tin (yout, tout)) ->
    While_Rel R1 <<=2 R2.
  Proof. intros H1 H2. intros tin tout. induction 1; eauto. Qed.

End WhileInduction.

Section WhileCoInduction.
  Variable (sig : finType) (n : nat) (F : finType).

  Variable R : pRel sig (option F) n.
  Variable T T' : tRel sig n.

  Lemma WhileCoInduction :
    (forall (tin : tapes sig n) (k : nat) (HT : T tin k),
        exists k1,
          T' tin k1 /\
          forall (ymid : option F) tmid,
            R tin (ymid, tmid) ->
            match ymid with
            | Some _ => k1 <= k
            | None => exists k2, T tmid k2 /\ 1 + k1 + k2 <= k
            end) ->
    T <<=2 While_T R T'.
  Proof.
    intros. cofix IH. intros tin k HT. specialize H with (1 := HT) as (k1&H1&H2). econstructor; eauto.
    - intros tmid ymid HR. specialize (H2 (Some ymid) tmid); cbn in *. auto.
    - intros tmid HR. specialize (H2 None tmid) as (k2&H3&H4); eauto.
  Qed.

End WhileCoInduction.

(* Alternative definition of [While_Rel] *)
Section OtherWhileRel.

  Variable (sig : finType) (n : nat) (F : finType).

  Variable R : Rel (tapes sig n) (option F * tapes sig n).

  Definition While_Rel' : pRel sig F n :=
    (star (R |_ None)) ∘ ⋃_y (R |_(Some y)) ||_y.

  Goal While_Rel R =2 While_Rel'.
  Proof.
    unfold While_Rel'. split.
    {
      apply WhileInduction; intros; cbn in *.
      - eexists. split. constructor. exists yout. auto.
      - destruct HLastStep as (y&IH1&?&<-&IH2); cbn in *.
        eexists. split; eauto. econstructor; eauto.
    }
    {
      intros tin (yout, tout) H.  cbn in H. destruct H as (tmid&HStar&HLastStep).
      induction HStar as [ tin | tin tmid tmid2 HS1 HS2 IH].
      - destruct HLastStep as (?&<-&H). now constructor.
      - spec_assert IH by assumption.
        destruct HLastStep as (?&<-&H).
        econstructor 2.
        + apply HS1.
        + apply IH.
    }
  Qed.

End OtherWhileRel.


Require Import Coq.Program.Syntax.
Require Export ZArith.
Require Import Coq.Program.Basics.
Require Import SetoidTactics.
Require Import SetoidClass.
Require Import Coq.Strings.String.
Require Import Coq.Strings.Ascii.
Require Import Coq.Lists.List.

Require Import HDI.Util.
Require Import HDI.CoInduction.
Require Import HDI.Syntax.
Require Import HDI.Heap.
Require Import HDI.OpSem.
Require Import HDI.Bisimulation.
Require Import HDI.SafetyI.
Require Export HDI.Predicates.

Local Open Scope Z.
Local Open Scope stmt.

  Definition in_inv (I: predicate heap->stmt->Prop) x s :=
    exists y s', x |-- y /\ bisimilar s s' /\ I y s'.

  Definition incl_inv (I1 I2: predicate heap->stmt->Prop) :=
    forall x s, I1 x s -> I2 x s.

  Definition inv_union (I1 I2: predicate heap -> stmt -> Prop) : predicate heap -> stmt -> Prop :=
    fun x s => I1 x s \/ I2 x s.

  Lemma incl_inv_in: forall I1 I2 x s,
    incl_inv I1 I2 ->
    in_inv I1 x s ->
    in_inv I2 x s.
  Proof. firstorder. Qed.
  Global Hint Resolve incl_inv_in : safe.

  Lemma in_inv_eq: forall (I: predicate heap->stmt->Prop) x s,
    I x s ->
    in_inv I x s.
  Proof. firstorder. Qed.
  Global Hint Resolve in_inv_eq : safe.

  Lemma incl_inv_refl: forall I,
    incl_inv I I.
  Proof. firstorder. Qed.
  Global Hint Immediate incl_inv_refl : safe.

  Lemma in_inv_entails: forall (I: predicate heap->stmt->Prop) x y s,
    in_inv I y s ->
    x |-- y ->
    in_inv I x s.
  Proof. firstorder. Qed.
  Global Hint Resolve in_inv_entails : safe.

  Lemma in_inv_bisim: forall (I: predicate heap->stmt->Prop) x s1 s2,
    in_inv I x s2 ->
    bisimilar s1 s2 ->
    in_inv I x s1.
  Proof.
    unfold in_inv; intuition auto.
    setoid_rewrite H0.
    auto.
  Qed.
  Global Hint Resolve in_inv_bisim : safe.

  Lemma incl_inv_union1: forall I1 I2,
    incl_inv I1 (inv_union I1 I2).
  Proof. firstorder. Qed.

  Lemma incl_inv_union2: forall I1 I2,
    incl_inv I2 (inv_union I1 I2).
  Proof. firstorder. Qed.
  Hint Resolve incl_inv_union1 incl_inv_union2 : safe.

  Lemma in_inv_forall: forall B (b:B) I x s,
    in_inv I (x b) s ->
    in_inv I (All_ b:B, x b) s.
  Proof. firstorder. Qed.
  Global Hint Resolve in_inv_forall : safe.

  Lemma in_inv_exists: forall I h x s,
    in_inv I x s ->
    h |= x ->
    exists y s', h|=y /\ bisimilar s s' /\ I y s'.
  Proof. firstorder. Qed.
  Global Hint Resolve in_inv_exists : safe.

  Add Parametric Morphism : in_inv
    with signature eq ==> equiv ==> bisimilar ==> iff
    as in_inv_m.
  Proof.
    split; intros; [ symmetry in H0 | symmetry in H];
      (eapply in_inv_entails;
        [ eapply in_inv_bisim | rewrite <-H; reflexivity ];
        eauto).
  Qed.

  Add Parametric Morphism : in_inv
    with signature incl_inv ++> entails --> eq ==> impl
    as in_inv_d.
  Proof. firstorder. Qed.

  Add Parametric Morphism : inv_union
    with signature incl_inv ++> incl_inv ++> incl_inv
    as inv_union_d.
  Proof. firstorder. Qed.

  Global Instance incl_inv_preorder : PreOrder incl_inv.
  Proof. firstorder. Qed.

  Lemma in_inv_union: forall I1 I2 x s,
    in_inv (inv_union I1 I2) x s ->
    in_inv I1 x s \/ in_inv I2 x s.
  Proof. firstorder. Qed.

  Lemma or_dup: forall P,
    (P \/ P) <-> P.
  Proof. intuition idtac. Qed.

  Lemma incl_inv_union_dup: forall I,
    incl_inv (inv_union I I) I.
  Proof. firstorder. Qed.

  Definition hoare_double (I: predicate heap->stmt->Prop) (x: predicate heap) (s: stmt) :=
    forall h, h |= x ->
      safeI (fun h s => exists y s', h |= y /\ bisimilar s s' /\ I y s') h s.

  Definition hoare_double_gen (I1 I2: predicate heap->stmt->Prop) :=
    forall (x: predicate heap) (s: stmt),
      I1 x s ->
      hoare_double I2 x s.

  Definition hoare_double' (I: predicate heap->stmt->Prop) (x: predicate heap) (s: stmt) :=
    in_inv I x s \/ hoare_double I x s.

  Notation "I ||- {{ x }} s" :=
    (hoare_double I x%pred s%stmt)
    (no associativity, at level 65, s at level 42).

  Notation "I ||= {{ x }} s" :=
    (hoare_double' I x%pred s%stmt)
    (no associativity, at level 65, s at level 42).

  Lemma hd_bisim: forall I x s1 s2,
    bisimilar s1 s2 ->
    I ||- {{x}}  s1 ->
    I ||- {{x}}  s2.
  Proof.
    unfold hoare_double, incl_inv.
    intuition auto.
    eapply safeI_bisim; eauto.
    simpl_relation.
    setoid_rewrite H3 at 1.
    reflexivity.
  Qed.

  Lemma hd'_bisim: forall I x s1 s2,
    bisimilar s1 s2 ->
    I ||= {{x}}  s1 ->
    I ||= {{x}}  s2.
  Proof.
    unfold hoare_double'.
    intuition eauto using hd_bisim.
    left; rewrite <-H; auto.
  Qed.

  Lemma hd_weaken: forall I1 I2 x y s,
    I1 ||- {{y}}  s ->
    x |-- y ->
    incl_inv I1 I2 ->
    I2 ||- {{x}}  s.
  Proof.
    unfold hoare_double, incl_inv.
    intuition auto.
    eapply safeI_weaken; intros; eauto.
    destruct H3 as [z[s1[?[??]]]]; eauto 8.
  Qed.

  Lemma hd_weaken': forall I x y s,
    I ||- {{y}}  s ->
    x |-- y ->
    I ||- {{x}}  s.
  Proof.
    intros; eapply hd_weaken; eauto; reflexivity.
  Qed.

  Lemma hd'_weaken: forall I1 I2 x y s,
    I1 ||= {{y}}  s ->
    x |-- y ->
    incl_inv I1 I2 ->
    I2 ||= {{x}}  s.
  Proof.
    unfold hoare_double'.
    intuition eauto using hd_weaken.
    left; firstorder.
  Qed.

  Lemma hd'_weaken': forall I x y s,
    I ||= {{y}}  s ->
    x |-- y ->
    I ||= {{x}}  s.
  Proof.
    intros; eapply hd'_weaken; eauto; reflexivity.
  Qed.

  Add Parametric Morphism : hoare_double
    with signature eq ==> equiv ==> bisimilar ==> iff
    as hoare_double_m.
  Proof.
    split; intros;
      eapply hd_bisim, hd_weaken;
      eauto;
      try solve
      [ apply equiv_sub_entails; eauto with pred
      | reflexivity
      | symmetry; assumption
      ].
  Qed.

  Add Parametric Morphism : hoare_double'
    with signature eq ==> equiv ==> bisimilar ==> iff
    as hoare_double'_m.
  Proof.
    split; intros;
      eapply hd'_bisim, hd'_weaken;
      eauto;
      try solve
      [ apply equiv_sub_entails; eauto with pred
      | reflexivity
      | symmetry; assumption
      ].
  Qed.

  Add Parametric Morphism : hoare_double
    with signature incl_inv ++> entails --> eq ==> impl
    as hoare_double_d.
  Proof.
    unfold impl; eauto using hd_weaken.
  Qed.

  Add Parametric Morphism : hoare_double'
    with signature incl_inv ++> entails --> eq ==> impl
    as hoare_double'_d.
  Proof.
    unfold impl; eauto using hd'_weaken.
  Qed.

  Lemma hd_exists: forall A I x s,
    (forall a:A, I ||-{{x a}}  s) ->
    I ||-{{Ex_ a:A, x a}}  s.
  Proof. firstorder. Qed.
  Global Hint Resolve hd_exists : safe.

  Lemma hd_forall: forall A (a:A) I x s,
    I ||-{{x a}}  s ->
    I ||-{{All_ a:A, x a}}  s.
  Proof. firstorder. Qed.
  Global Hint Resolve hd_forall : safe.

  Lemma hd'_inv: forall I x s,
    in_inv I x s ->
    I ||= {{x}}  s.
  Proof. left; auto. Qed.
  Global Hint Resolve hd'_inv : safe.

  Lemma hd'_safe: forall I x s,
    I ||- {{x}}  s ->
    I ||= {{x}}  s.
  Proof. right; auto. Qed.
  Global Hint Resolve hd'_safe : safe.

  Lemma hd'_forall: forall A (a:A) I x s,
    I ||={{x a}}  s ->
    I ||={{All_ a:A, x a}}  s.
  Proof. firstorder. Qed.
  Global Hint Resolve hd'_forall : safe.

  Lemma hd_coind: forall (I I': predicate heap -> stmt -> Prop) x s,
    (forall x s,
      I' x s ->
      inv_union I I' ||- {{x}}  s) ->
    in_inv I' x s ->
    I ||- {{x}}  s.
  Proof.
    intros ? ? ? ? Hsafe_ Hin.
    assert (Hsafe: forall x s, in_inv I' x s -> inv_union I I' ||- {{x}}  s).
    { intros.
      destruct H as [y[s1[Hy[Hbisim ?]]]].
      rewrite Hy, Hbisim; eauto.
    }
    clear Hsafe_.
    unfold hoare_double.
    intros h Hx.
    cut (in_inv I' x s
        \/ safeI (fun h' s' => exists y s'', h'|=y /\ bisimilar s' s'' /\ (inv_union I I') y s'') h s);
      [ | solve[auto with safe] ].
    clear Hin.
    revert h x s Hx.
    cofix; intros.
    destruct H as [Hin|Hsafe2].
    * specialize (Hsafe x s Hin h Hx).
    inversion Hsafe; subst; clear Hsafe.
    - constructor.
    - constructor.
    destruct H as [h'[s'[Hstep Hsafe']]].
    specialize (hd_coind h' (just h')).
    exists h' s'; split; auto.
    destruct Hsafe' as [ [z[s0[Hz[Hbisim [Hin'|Hin']]]]] | Hsafe'];
      eauto 7;
      solve [right; eapply hd_coind; eauto 7 with safe pred].
    * inversion Hsafe2; subst; clear Hsafe2.
    - constructor.
    - constructor.
    destruct H as [h'[s'[Hstep Hsafe']]].
    specialize (hd_coind h' (just h')).
    exists h' s'; split; auto.
    destruct Hsafe' as [ [z[s0[Hz[Hbisim [Hin'|Hin']]]]] | Hsafe'];
      eauto 7;
      solve [right; eapply hd_coind; eauto 7 with safe pred].
  Qed.

  Lemma hd'_coind: forall (I I': predicate heap -> stmt -> Prop) x s,
    (forall x s,
      I' x s ->
      inv_union I I' ||- {{x}}  s) ->
    in_inv I' x s ->
    I ||= {{x}}  s.
  Proof.
    eauto using hd_coind with safe.
  Qed.

  Lemma hd_coindI: forall (I I': predicate heap -> stmt -> Prop) x s,
    (forall I'' x s,
      I' x s ->
      incl_inv I I'' ->
      incl_inv I' I'' ->
      I'' ||- {{x}}  s) ->
    in_inv I' x s ->
    I ||- {{x}}  s.
  Proof.
    eauto using hd_coind with safe.
  Qed.

  Lemma hd'_coindI: forall (I I': predicate heap -> stmt -> Prop) x s,
    (forall I'' x s,
      I' x s ->
      incl_inv I I'' ->
      incl_inv I' I'' ->
      I'' ||- {{x}}  s) ->
    in_inv I' x s ->
    I ||= {{x}}  s.
  Proof.
    eauto using hd_coind with safe.
  Qed.

  Lemma in_inv_hoare_double: forall I x s,
    in_inv (hoare_double I) x s <-> hoare_double I x s.
  Proof.
    split; [ intros [y[s'[H1[H2 ?]]]] | intros ].
    rewrite H1, H2; assumption.
    exists x s; split; try split; try reflexivity; auto.
  Qed.

  Lemma in_inv_hoare_double': forall I x s,
    in_inv (hoare_double' I) x s <-> hoare_double' I x s.
  Proof.
    split; [ intros [y[s'[H1[H2 ?]]]] | intros ].
    rewrite H1, H2; assumption.
    exists x s; split; try split; try reflexivity; auto.
  Qed.

  Lemma hoare_double_coind_principle: forall (I1 I2: predicate heap -> stmt -> Prop) x s,
    I2 x s ->
    hoare_double_gen I2 (inv_union I1 I2) ->
    hoare_double I1 x s.
  Proof.
    intros I1 I2 x s HI2 Hsafe.
    eapply hd_coindI;
      [ clear x s HI2; intros I'' x s HI2 Hincl1 Hincl2
      | apply in_inv_eq; eauto ].
    apply Hsafe in HI2; clear Hsafe.
    hnf; intros.
    eapply safeI_weaken; eauto.
    simpl; intros.
    destruct H0 as [y[s'[Hy[Hbisim Hsafe']]]].
    destruct Hsafe' as [Hsafe'|Hsafe'];
      eauto 7 with safe.
  Qed.

  Lemma hoare_double_gen_hd_intro: forall (I1 I2: predicate heap -> stmt -> Prop),
    (forall I3: _ -> _ -> Prop,
      (forall x s,
        I1 x s ->
        hoare_double' I3 x s) ->
      incl_inv I2 I3 ->
      hoare_double_gen I1 I3) ->
    hoare_double_gen I1 (inv_union I2 I1).
  Proof.
    unfold hoare_double_gen; intuition auto.
    eapply H; intros; eauto;
    intuition eauto with safe.
  Qed.

  Lemma hoare_double_coind: forall (I1 I2: predicate heap -> stmt -> Prop),
    (forall I3: _ -> _ -> Prop,
      (forall x s, I2 x s -> hoare_double' I3 x s) ->
(*      (forall x s, I1 x s -> hoare_double' I3 x s) ->*)
      incl_inv I1 I3 ->
      hoare_double_gen I2 I3) ->
    forall x s,
    I2 x s ->
    hoare_double I1 x s.
  Proof.
    intros.
    apply (hoare_double_coind_principle I1 I2 x s); auto.
    apply hoare_double_gen_hd_intro.
    intros; eauto.
  Qed.

  Global Instance coind_hoare_double {I} `{co_rel:CoRelation _}  {x s}
    : CoIndRelation (hoare_double I x s) | 100 :=
    {| coind_rel:= coind_co_rel (x,s) |}.

  Global Program Instance hoare_double_cind (I1 I2: predicate heap -> stmt -> Prop) x s
    : CoIndPrinciple I2 (hoare_double I1 x s) :=
    {| coind_principle := fun H1 H2 =>
        hoare_double_coind I1 I2 H2 x s H1
    |}.

  Ltac hd_coind_ :=
    let G:= thegoal in
    (* rephrase in a friendler way: provide helper lemmas to solve gen relations *)
    coind_ ltac:(fun names =>
      (**)
      try match thegoal with
      | hoare_double_gen ?I1 ?I2 =>
        try intro_relation_with_names names
      | _ =>
        try intro_relation_with_names names
      end).

  Tactic Notation "hd_coind" :=
    hd_coind_.

  Lemma ret_ok: forall I v F,
    I ||-{{F}}  ret v.
  Proof.
    unfold hoare_double; intros.
    eauto with safe.
  Qed.

  Lemma ret_bind_ok: forall I v F k,
    I ||={{F}}  k v ->
    I ||-{{F}}  x <- ret v; k x.
  Proof.
    unfold hoare_double; intros.
    destruct H; eauto with safe.
  Qed.

  Hint Resolve ret_ok ret_bind_ok : safe.

  Lemma read_ok: forall I a v F k,
    I ||= {{a |-> v && F}}  k v ->
    I ||- {{a |-> v && F}}  x <- read a; k x.
  Proof.
    unfold hoare_double; intros.
    destruct H; eauto with safe pred.
  Qed.

  Lemma read_str0_0_ok: forall I a v F k,
    I ||= {{a |->0 v && F}}  k (match v with String c _ => Z_of_ascii c | _ => 0 end) ->
    I ||- {{a |->0 v && F}}  x <- read a; k x.
  Proof.
    unfold getd; intros.
    destruct v; simpl in *.
    * rewrite str0_empty in *.
    apply read_ok; auto.
    * rewrite str0_cons in *.
    rewrite <-inter_assoc in H |- *.
    apply read_ok; auto.
  Qed.

  Lemma write_ok: forall I a v v0 F k,
    pred_free F a ->
    I ||= {{a |-> v && F}}  k 1 ->
    I ||- {{a |-> v0 && F}}  write a v >>= k.
  Proof.
    unfold hoare_double; intros.
    eapply safeI_write; eauto with safe pred.
    destruct H0; eauto with safe pred.
    - eapply safeI_bind_ret'; eauto with safe pred.
    apply in_inv_exists with (x:=(a|->v && F)%pred); auto.
    firstorder.
    - eapply safeI_bind_ret; eauto with safe pred.
    firstorder.
  Qed.

  Ltac step :=
    match goal with
    | |- _ ||= {{_}} _ => apply hd'_safe; step
    | |- ?I ||- {{?x}} ?s =>
      match s with
      | ret _ => apply ret_ok
      | bind (ret _) _ => apply ret_bind_ok
      | _ <- act (read ?a); _ =>
        match x with
        | appcontext[pts a ?v'] =>
          eapply hd_weaken'; [apply read_ok with (v:=v') | try reflexivity]
        | appcontext[str0 a ?v'] =>
          eapply hd_weaken'; [apply read_str0_0_ok with (v:=v') | try reflexivity]
        | _ =>
          eapply hd_weaken'; [apply read_ok | try reflexivity]
        end
      | _ <- act (write _); _ => eapply hd_weaken'; [apply write_ok | try reflexivity]
      | bind (bind _ _) _ => rewrite !bisim_bind_assoc; step
      end
    end.