(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*                                                                      *)
(* Micromega: A reflexive tactic using the Positivstellensatz           *)
(*                                                                      *)
(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
(*                                                                      *)
(************************************************************************)

Require Import ZArith.
Require Import Coq.Arith.Max.
Require Import List.
Set Implicit Arguments.

(* I have addded a Leaf constructor to the varmap data structure (/plugins/ring/Quote.v)
   -- this is harmless and spares a lot of Empty.
   This means smaller proof-terms.
   BTW, by dropping the  polymorphism, I get small (yet noticeable) speed-up.
*)

Section S.

  Variable D :Type.

  Definition Env := positive -> D.

  Definition jump  (j:positive) (e:Env) := fun x => e (Pplus x j).

  Definition nth  (n:positive) (e : Env ) := e n.

  Definition hd (x:D)  (e: Env)  := nth xH e.

  Definition tail (e: Env) := jump xH e.

  Lemma psucc : forall p,  (match p with
                              | xI y' => xO (Psucc y')
                              | xO y' => xI y'
                              | 1%positive => 2%positive
                            end) = (p+1)%positive.
  Proof.
    destruct p.
    auto with zarith.
    rewrite xI_succ_xO.
    auto with zarith.
    reflexivity.
  Qed.

  Lemma jump_Pplus : forall i j l,
    forall x, jump (i + j) l x = jump i (jump j l) x.
  Proof.
    unfold jump.
    intros.
    rewrite Pplus_assoc.
    reflexivity.
  Qed.

  Lemma jump_simpl : forall p l,
    forall x, jump p l x =
    match p with
      | xH => tail l x
      | xO p => jump p (jump p l) x
      | xI p  => jump p (jump p (tail l)) x
    end.
  Proof.
    destruct p ; unfold tail ; intros ;  repeat rewrite <- jump_Pplus.
    (* xI p = p + p + 1 *)
    rewrite xI_succ_xO.
    rewrite Pplus_diag.
    rewrite <- Pplus_one_succ_r.
    reflexivity.
    (* xO p = p + p *)
    rewrite Pplus_diag.
    reflexivity.
    reflexivity.
  Qed.

  Ltac jump_s :=
    repeat
      match goal with
        | |- context [jump xH ?e] => rewrite (jump_simpl xH)
        | |- context [jump (xO ?p) ?e] => rewrite (jump_simpl (xO p))
        | |- context [jump (xI ?p) ?e] => rewrite (jump_simpl (xI p))
      end.

  Lemma jump_tl : forall j l, forall x, tail (jump j l) x = jump j (tail l) x.
  Proof.
    unfold tail.
    intros.
    repeat rewrite <- jump_Pplus.
    rewrite Pplus_comm.
    reflexivity.
  Qed.

  Lemma jump_Psucc : forall j l,
    forall x, (jump (Psucc j) l x) = (jump 1 (jump j l) x).
  Proof.
    intros.
    rewrite <- jump_Pplus.
    rewrite Pplus_one_succ_r.
    rewrite Pplus_comm.
    reflexivity.
  Qed.

  Lemma jump_Pdouble_minus_one : forall i l,
    forall x, (jump (Pdouble_minus_one i) (tail l)) x = (jump i (jump i l)) x.
  Proof.
    unfold tail.
    intros.
    repeat rewrite <- jump_Pplus.
    rewrite <- Pplus_one_succ_r.
    rewrite Psucc_o_double_minus_one_eq_xO.
    rewrite Pplus_diag.
    reflexivity.
  Qed.

  Lemma jump_x0_tail : forall p l, forall x, jump (xO p) (tail l) x = jump (xI p) l x.
  Proof.
    intros.
    unfold jump.
    unfold tail.
    unfold jump.
    rewrite <- Pplus_assoc.
    simpl.
    reflexivity.
  Qed.

  Lemma nth_spec : forall p l x,
    nth p l =
    match p with
      | xH => hd x l
      | xO p => nth p (jump p l)
      | xI p => nth p (jump p (tail l))
    end.
  Proof.
    unfold nth.
    destruct p.
    intros.
    unfold jump, tail.
    unfold jump.
    rewrite Pplus_diag.
    rewrite xI_succ_xO.
    simpl.
    reflexivity.
    unfold jump.
    rewrite Pplus_diag.
    reflexivity.
    unfold hd.
    unfold nth.
    reflexivity.
  Qed.

  Lemma nth_jump : forall p l x, nth p (tail l) = hd x (jump p l).
  Proof.
    unfold tail.
    unfold hd.
    unfold jump.
    unfold nth.
    intros.
    rewrite Pplus_comm.
    reflexivity.
  Qed.

  Lemma nth_Pdouble_minus_one :
    forall p l, nth (Pdouble_minus_one p) (tail l) = nth p (jump p l).
  Proof.
    intros.
    unfold tail.
    unfold nth, jump.
    rewrite Pplus_diag.
    rewrite <- Psucc_o_double_minus_one_eq_xO.
    rewrite Pplus_one_succ_r.
    reflexivity.
  Qed.

End S.


From stdpp Require Export gmap.
Require Export String Ascii.

Section map_Filter.
  Context `{FinMap K M}.
  Context {A} (P : K * A → Prop) `{!∀ x, Decision (P x)}.
  Implicit Types m : M A.

  Lemma map_filter_lookup_None_insert i x m:
    filter P m !! i = None →
    ¬ P (i,x) →
    filter P (<[i:=x]> m) = filter P m.
  Proof.
    intros HNone Hneg.
    apply map_eq. intros j. apply option_eq; intros y.
    destruct (decide (j = i)) as [->|?].
    - split; intro.
      + rewrite map_filter_lookup_Some in H8. destruct H8 as [? Hc].
        rewrite lookup_insert in H8; simplify_eq. contradiction.
      + rewrite H8 in HNone. simplify_eq.
    - by rewrite !map_filter_lookup_Some, lookup_insert_ne.
  Qed.

End map_Filter.

Section fin_map_dom.
  Context `{FinMapDom K M D}.
  Context `{!LeibnizEquiv D}.

  Lemma dom_insert_Some {A} (m : M A) i (x y : A) :
    m !! i = Some x →
    dom D (<[i:=y]> m) = dom D m.
  Proof.
    intros.
    rewrite dom_insert_L.
    apply subseteq_union_1_L, elem_of_subseteq_singleton,
    elem_of_dom; eauto.
  Qed.

End fin_map_dom.


(** * EqmR Monad laws and associated typeclasses *)

(** This file contains an equational axiomatization of the monadic structures that
   arise from the construction of layered monadic interpreters.

   The base theory, [EqmR] is a framework for relational reasoning over monads.
   They are a generalization of the ITree equational theory on [eutt], and have
   a notion of [image] of a computation which capture the set of values possibly
   returned by a monadic computation.

   The well-formedness conditions capture standard monad laws.
   Roughly, they also characterize forming a bicartesian closed category (a
    cartesian closed category with finite coproducts).
   The laws also characterize inversion properties which consume relations over
   monads. *)

(* begin hide *)
From Coq Require Import
     Morphisms
     Program.

From ExtLib Require Import
     Structures.Functor
     Monad.

From Paco Require Import paco.

From ITree Require Import
     Basics.Basics
     Basics.CategoryOps
     Basics.HeterogeneousRelations
     Basics.Function
     Basics.FunctionFacts.

Set Primitive Projections.

Import FunctorNotation.
Import CatNotations.
Import MonadNotation.
Local Open Scope monad_scope.
Local Open Scope cat_scope.
(* end hide *)

Section EqmR.

  (** We consider heterogeneous relations on computations parameterized by a
     relation on the return types *)
  Class EqmR (m : Type -> Type) : Type :=
    { eqmR : forall {A B : Type} (R : relationH A B), relationH (m A) (m B) }.

End EqmR.
Infix "≈{ R  }" := (eqmR R) (at level 30) : cat_scope.
Notation "t1 ≋ t2" := (eqmR eq t1 t2) (at level 40) : cat_scope.

Arguments eqmR {m _ A B}.

Import RelNotations.
Local Open Scope relationH_scope.

(** * [EqmR_OK] : Well-formedness properties of EqmR. *)
Section EqmRRel.
  Context (m : Type -> Type).
  Context {EqMR : EqmR m} {Mm : Monad m}.

  (* [eqmR] should transport elementary structures of the relation [R] *)
  Class TransportEquiv : Prop :=
    equiv : forall {A : Type} (R : relationH A A), Equivalence R -> Equivalence (eqmR R).

  Class TransportPER : Prop :=
    per : forall {A : Type} (R : relationH A A), PER R -> PER (eqmR R).

  Class TransportReflexive : Prop :=
    refl : forall {A : Type} (R : relationH A A), Reflexive R -> Reflexive (eqmR R).

  Class TransportSymmetric : Prop :=
    symm : forall {A : Type} (R : relationH A A), Symmetric R -> Symmetric (eqmR R).

  Class TransportTransitive : Prop :=
    trans : forall {A : Type} (R : relationH A A), Transitive R -> Transitive (eqmR R).

  Class LiftTranspose : Prop :=
    lift_transpose :
      forall {A B : Type} (R : relationH A B) , eq_rel (eqmR †R) (†(eqmR R)).

  (* Product rules *)
  Class FmapFst : Prop :=
    fmap_fst :
      forall {A1 A2 B1 B2: Type} (RA : relationH A1 A2) (RB : relationH B1 B2)
        (m1 : m (A1 * B1)) (m2: m (A2 * B2)),
        eqmR (RA ⊗ RB) m1 m2 ->
        eqmR RA (fst <$> m1) (fst <$> m2).

  Class FmapSnd : Prop :=
    fmap_snd :
      forall {A1 A2 B1 B2: Type} (RA : relationH A1 A2) (RB : relationH B1 B2)
        (m1 : m (A1 * B1)) (m2: m (A2 * B2)),
        eqmR (RA ⊗ RB) m1 m2 ->
        eqmR RB (snd <$> m1) (snd <$> m2).

  Class RelProd : Prop :=
    rel_prod :
      forall {A1 A2 B1 B2: Type} (RA : relationH A1 A2) (RB : relationH B1 B2)
        (m1 : m (A1 * B1)) (m2: m (A2 * B2)),
        eqmR RA (fst <$> m1) (fst <$> m2) ->
        eqmR RB (snd <$> m1) (snd <$> m2) ->
        eqmR (RA ⊗ RB) m1 m2.

  (* Sum rules *)
  Class FmapInl : Prop :=
    fmap_inl :
      forall {A1 A2 B1 B2: Type} (RA : relationH A1 A2) (RB : relationH B1 B2)
        (m1 : m A1) (m2: m A2),
        eqmR RA m1 m2 ->
        eqmR (RA ⊕ RB) (inl <$> m1) (inl <$> m2).

  Class FmapInr : Prop :=
    fmap_inr :
      forall {A1 A2 B1 B2: Type} (RA : relationH A1 A2) (RB : relationH B1 B2)
        (m1 : m B1) (m2: m B2),
        eqmR RB m1 m2 ->
        eqmR (RA ⊕ RB) (inr <$> m1) (inr <$> m2).

  Class RelSum : Prop :=
    rel_sum :
      forall {A1 A2 B1 B2: Type} (RA : relationH A1 A2) (RB : relationH B1 B2)
        (m1 : m (A1 + B1)) (m2: m (A2 + B2)),
        eqmR (RA ⊕ RB) m1 m2 <->
        (forall (C1 C2 : Type) (f1 : A1 -> C1) (f2 : A2 -> C2) (g1 : B1 -> C1) (g2 : B2 -> C2) (RC : relationH C1 C2),
        ProperH (RA ~~> RC) f1 f2 ->
        ProperH (RB ~~> RC) g1 g2 ->
        eqmR RC ((fun a => match a with
                        | inl a => f1 a
                        | inr b => g1 b
                        end) <$> m1)
                 ((fun a => match a with
                        | inl a => f2 a
                        | inr b => g2 b
                        end) <$> m2)).

  (* [eqmR] composes by composing the underlying relationHs *)
  Class RelComp : Prop :=
    rel_comp :
      forall {A B C : Type} (R1 : relationH A B) (R2 : relationH B C)
        (ma : m A) (mb : m B) (mc : m C),
        eqmR R1 ma mb ->
        eqmR R2 mb mc ->
        eqmR (R2 ∘ R1) ma mc.

  Class RelConj : Prop :=
    rel_conj :
      forall {A B : Type} (R R': relationH A B) (ma : m A) (mb : m B),
        eqmR R ma mb ->
        eqmR R' ma mb ->
        eqmR (R /2\ R') ma mb.

  (* Requirements of well-formedness of [eqmR] *)
  Class EqmR_OK : Type :=
    {
    eqmR_transport_refl :> TransportReflexive;
    eqmR_transport_PER :> TransportPER;

    eqmR_lift_transpose :> LiftTranspose;
    (* product rules *)
    eqmR_fmap_fst :> FmapFst;
    eqmR_fmap_snd :> FmapSnd;
    eqmR_rel_prod :> RelProd;
    (* sum rules *)
    eqmR_fmap_inl :> FmapInl;
    eqmR_fmap_inr :> FmapInr;
    eqmR_rel_sum :> RelSum;
    (* other relational rules *)
    eqmR_rel_comp :> RelComp;
    eqmR_rel_conj :> RelConj;

    (* [eqmR] respects extensional equality of the underlying relationH
        and [eqm] on both arguments over the monad *)
    Proper_eqmR :> forall {A B : Type}, Proper (@eq_rel A B ==> eq_rel) eqmR;
    (* [eqmR] is monotone as a morphism on relationHs *)
    Proper_eqmR_mono :> forall {A B}, Proper ((@subrelationH _ _) ==> (@subrelationH _ _)) (@eqmR m _ A B);
    }.

End EqmRRel.

Arguments equiv {m _ _ _} [_].
Arguments per {m _ _ _} [_].
Arguments rel_comp {m _ _} [_ _ _].
Arguments lift_transpose {m _ _} [_ _].
Arguments fmap_fst {m _ _ _} [_ _ _ _].
Arguments fmap_snd {m _ _ _} [_ _ _ _].
Arguments rel_prod {m _ _ _} [_ _ _ _].
Arguments fmap_inl {m _ _ _} [_ _ _ _].
Arguments fmap_inr {m _ _ _} [_ _ _ _].
Arguments rel_sum {m _ _ _} [_ _ _ _].
Arguments rel_conj {m _ _ _} [_ _ _ _].
Arguments Proper_eqmR {m _ _ _} [_ _].
Arguments Proper_eqmR_mono {m _ _ _} [_ _].

Section PER.

  Context {m : Type -> Type}.
  Context {Mm : Monad m}.
  Context {E : EqmR m}.
  Context {E_OK : EqmR_OK m}.

  Global Instance Refl_eqmR_eq {A} :
    Reflexive (eqmR (@eq A)).
  Proof.
    repeat intro. eapply eqmR_transport_refl; typeclasses eauto.
  Qed.

  Global Instance Equivalence_eqmR_eq {A} :
    Equivalence (eqmR (@eq A)).
  Proof.
    repeat intro. constructor; destruct E_OK;
    repeat intro;
      specialize (eqmR_transport_PER0 A eq _);
      [ reflexivity | symmetry; auto | etransitivity; eauto].
  Qed.

  Global Instance Equivalence_eqmR_R {A} (R : relationH A A) `{Equivalence A R} :
    Equivalence (eqmR R).
  Proof.
    repeat intro. destruct H; try typeclasses eauto.
    assert (PER R) by (constructor; auto).
    destruct E_OK; constructor;
    repeat intro;
      specialize (eqmR_transport_PER0 A R H);
      [ | symmetry; auto | etransitivity; eauto].
    eapply eqmR_transport_refl; auto.
  Qed.

  Global Instance Symm_eqmR_PER {A} {R : relationH A A} `{PER A R}:
    Symmetric (eqmR R).
  Proof.
    repeat intro. eapply eqmR_transport_PER; auto.
  Qed.

  Global Instance Trans_eqmR_PER {A} {R : relationH A A} `{PER A R}:
    Transitive (eqmR R).
  Proof.
    repeat intro. pose proof (eqmR_transport_PER m _ R H).
    destruct H2. etransitivity; eauto.
  Qed.

  Global Instance PER_eqmR_PER {A} {R : relationH A A} `{PER A R}:
    PER (eqmR R).
  Proof.
    split. red. apply Symm_eqmR_PER.
    red. apply Trans_eqmR_PER.
  Qed.

  Global Instance Proper_eqmR_PER {A} {R : relationH A A} `{PER A R}:
      Proper (eqmR R ==> eqmR R ==> iff) (eqmR R).
  Proof.
    repeat intro.
    split; intros.
    etransitivity.
    symmetry. apply H0. etransitivity. apply H2. apply H1.
    etransitivity. apply H0.
    etransitivity. apply H2. symmetry. apply H1.
  Qed.

  Global Instance Proper_eqmR_eq {A}:
      Proper (eqmR (@eq A) ==> eqmR (@eq A) ==> iff) (eqmR (@eq A)).
  Proof.
    repeat intro.
    split; intros.
    etransitivity.
    symmetry. apply H. etransitivity. apply H1. apply H0.
    etransitivity. apply H.
    etransitivity. apply H1. symmetry. apply H0.
  Qed.

  Global Instance Proper_eqmR_cong {A B} {R : relationH A B}:
      Proper (eqmR (@eq A) ==> eqmR (@eq B) ==> iff) (eqmR R).
  Proof.
    repeat intro.
    split.
    - repeat intro.
      pose proof @eqmR_rel_comp.
      specialize (H2 m _ _ _ _ _ _ (@eq A) R y x x0).
      symmetry in H. specialize (H2 H H1).
      pose proof @eqmR_rel_comp.
      specialize (H3 m _ _ _ _ _ _ R (@eq B) y x0 y0).
      eapply Proper_eqmR in H2. 2 : eauto.
      2 : { rewrite eq_id_l. reflexivity. }
      specialize (H3 H2 H0).
      eapply Proper_eqmR in H3. 2 : eauto.
      2 : { rewrite eq_id_r. reflexivity. }
      eauto.
    - repeat intro.
      pose proof @eqmR_rel_comp.
      specialize (H2 m _ _ _ _ _ _ (@eq A) R x y y0).
      specialize (H2 H H1).
      pose proof @eqmR_rel_comp.
      specialize (H3 m _ _ _ _ _ _ R (@eq B) x y0 x0).
      eapply Proper_eqmR in H2. 2 : eauto.
      2 : { rewrite eq_id_l. reflexivity. }
      symmetry in H0.
      specialize (H3 H2 H0).
      eapply Proper_eqmR in H3. 2 : eauto.
      2 : { rewrite eq_id_r. reflexivity. }
      eauto.
  Qed.

  Global Instance Proper_eqmR_impl {A B} {R : relationH A B}:
    Proper (eqmR (@eq A) ==> eqmR (@eq B) ==> impl) (eqmR R).
  Proof.
    repeat intro.
    edestruct @Proper_eqmR_cong; cycle 2.
    eapply H2; eauto. all : eauto.
  Qed.

  Global Instance Proper_eqmR_flip_impl {A B} {R : relationH A B}:
    Proper (eqmR (@eq A) ==> eqmR (@eq B) ==> flip impl) (eqmR R).
  Proof.
    repeat intro.
    edestruct @Proper_eqmR_cong; cycle 2.
    eapply H3; eauto. all : eauto.
  Qed.

End PER.

Arguments Proper_eqmR_cong {_ _ _ _} [_ _ _].

(** * Image : the set of possible return values of a monad  *)
Section Image.
  Context (m : Type -> Type).
  Context {Mm : Monad m}.
  Context {EqMR : EqmR m} {EqmROKm : EqmR_OK m}.

  (** An _image_ is a (unary) logical predicate that specifies the intersection
   of PER's that a monadic value satisfies. Intuitively, what this entails is
   the possible set of elements of the specified Type [A] that a monadic
   value can return. In this sense, it is an "image" as in set theory,
   indicating the set of all output values that a monad may produce.
   Notice the definition of _image_ takes the universal quantification over
   all PER's satisfying [EQ], giving the smallest relation which will
   describe the set of elements that a monadic value may return.
    Consider [image spin] in ITrees, or more simply, [image Nothing] for the
   option monad, where the carrier Typee is [A].

   There exists no PER over any carrier Type that this option monad may have
   in which [Nothing] can give an image to, i.e. the smallest relation over
   [Nothing] cannot say anything about values of Type [A].
   *)
  (** Elements contained in the least specification that relates two monadic
     computations. *)
  Definition imageH {A1 A2 :Type} (ma1 : m A1) (ma2 : m A2) : relationH (A1 * A2) (A1 * A2) :=
    fun '(a1, a2) '(a1', a2') =>
      forall (RA : relationH A1 A2)
        (EQA : eqmR (m := m) RA ma1 ma2)
        (H : Zigzag RA), RA a1 a2 /\ RA a1' a2'.

  Definition imageH_Z {A1 A2 :Type} (ma1 : m A1) (ma2 : m A2) : relationH A1 A2 :=
    fun a1 a2 =>
      forall (RA : relationH A1 A2)
        (EQA : eqmR (m := m) RA ma1 ma2)
        (H : Zigzag RA), RA a1 a2.

  Definition mayRetH {A1 A2 : Type} (ma1 : m A1) (ma2 : m A2): A1 * A2 -> Prop :=
    fun '(x, y) => imageH ma1 ma2 (x, y) (x, y).

  Definition imageH_diag {A : Type} (ma : m A) : relationH A A :=
    fun x y => imageH ma ma (x, y) (y, x) /\ imageH ma ma (x, x) (y, y).

  Definition mayRetH_diag {A : Type} (ma : m A) : A -> Prop :=
    fun a => imageH_diag ma a a.

  (* NB: Every PER is difunctional, but the converse does not hold. *)
  Definition image_ {A:Type} (ma ma': m A) : relationH A A :=
    fun x y =>
      forall (R : relationH A A) (PH : PER R)
        (EQR: eqmR R ma ma'), R x y.

  Definition image {A:Type} (ma:m A):= image_ ma ma.

  (* Using [image] we can define the [mayRet] predicate, which identifies
   * the subset of A on which the computation [ma] can halt with
   * a [ret x]. (When we characterize monadic computations, we use [mayRet]
   * and we only care about this unary form.) *)
  Definition mayRet {A:Type} (ma : m A) : A -> Prop :=
    (fun (a:A) => image ma a a).

  Notation "a1 ∈ ma" := (mayRet ma a1) (at level 40) : cat_scope.
  Notation "a1 ∈̂ ma" := (mayRetH_diag ma a1) (at level 40) : cat_scope.

  Definition eqmR_bind_ProperH_homo := forall (A1 A2 B1 B2 : Type)
                            (RA : relationH A1 A2)
                            (RB : relationH B1 B2)
                            ma1 ma2
          (k1 : A1 -> m B1) (k2 : A2 -> m B2),
        ma1 ≈{RA} ma2 ->
        (forall (a1 : A1), a1 ∈ ma1 ->
                      forall a2, RA a1 a2 -> k1 a1 ≈{RB} k2 a2) ->
        (forall (a2 : A2), a2 ∈ ma2 ->
                      forall a1, RA a1 a2 -> k1 a1 ≈{RB} k2 a2) ->
        bind ma1 k1 ≈{RB} bind ma2 k2.

  Definition eqmR_bind_ProperH_hetero := forall (A1 A2 B1 B2 : Type)
                            (RA : relationH A1 A2)
                            (RB : relationH B1 B2)
                            ma1 ma2
          (k1 : A1 -> m B1) (k2 : A2 -> m B2),
        ma1 ≈{RA} ma2 ->
        (forall (a1 : A1), a1 ∈̂ ma1 ->
                      forall a2, RA a1 a2 -> k1 a1 ≈{RB} k2 a2) ->
        (forall (a2 : A2), a2 ∈̂ ma2 ->
                      forall a1, RA a1 a2 -> k1 a1 ≈{RB} k2 a2) ->
        bind ma1 k1 ≈{RB} bind ma2 k2.

  Lemma transpose_eq {A} (R : relationH A A) (x:A) :
    R x x <-> (transpose R) x x.
  Proof.
    split; intros; assumption.
  Qed.

  Global Instance image_PER {A} (ma : m A) : PER (image ma).
  Proof.
    constructor.
    - red.
      intros a.
      repeat intro.
      apply per_symm.
      apply H; auto.
    - red.
      intros.
      repeat intro. subst. unfold image in *.
      specialize (H R _ EQR). specialize (H0 R _ EQR).
      pose proof (per_trans x y z).
      cbn in H1.
      apply H1. apply H; assumption.
      apply H0; assumption.
  Qed.

  Global Instance imageH_PER {A1 A2} (m1 : m A1) (m2 : m A2) : PER (imageH m1 m2).
  Proof.
    split; repeat intro.
    - destruct x, y.
      red in H. repeat intro.
      specialize (H RA EQA H0).
      destruct H.
      split; auto.
    - destruct x, y, z.
      red in H, H0. repeat intro.
      specialize (H RA EQA H1). destruct H.
      specialize (H0 RA EQA H1). destruct H0.
      split; auto.
  Qed.

  Definition imageH_refl {A} ma x y := @imageH A A ma ma (x, y) (x, y).

  Lemma imageH_refl_subrel_image:
    forall A (ma : m A) x y,
      @imageH_refl A ma x y -> image ma x y.
  Proof.
    unfold image, imageH_diag. intros.
    repeat intro. edestruct H. eauto. eapply PER_is_ZZC; eauto.
    eauto.
  Qed.

  Global Instance imageHZ_ZZC {A1 A2} (m1 : m A1) (m2 : m A2) : Zigzag (imageH_Z m1 m2).
  Proof.
    repeat intro.
    eapply H0.
    destruct H as (? & ? & ?).
    destruct H as (? & ? & ?).
    esplit; split.
    esplit; split.
    unfold imageH_Z in *. eapply H; eauto. eapply H2; eauto.
    eapply H1; eauto.
  Qed.

  Lemma image_Reflexive_l {A:Type} (ma : m A) (a1 a2:A)
    (H : image ma a1 a2) : image ma a1 a1.
  Proof.
    assert (image ma a2 a1).
    { apply per_symm in H. apply H. }
    eapply per_trans in H. apply H in H0. apply H0.
  Qed.

  Lemma image_Reflexive_r {A:Type} (ma : m A) (a1 a2:A)
    (H : image ma a1 a2) : image ma a2 a2.
  Proof.
    assert (image ma a2 a1).
    { apply per_symm in H. apply H. }
    eapply per_trans in H0. apply H0 in H. apply H.
  Qed.

  Lemma image_least {A} (ma : m A)
        (R : relationH A A) (PH : PER R)
        (G: eqmR R ma ma)
    : (image ma) ⊑ R.
  Proof.
    intros x y D.
    unfold image in D.
    cbn in *.
    apply D; assumption.
  Qed.

  Global Instance Proper_image {A} :
    Proper (@eq (m A) ==> eq_rel) image.
  Proof.
    do 2 red.
    intros x y EQR.
    split.
    - red. intros a b H.
      repeat red.
      intros.
      repeat red in H.
      rewrite <- EQR in EQR0.
      specialize (H R PH EQR0).
      apply H.
    - red. intros a b H.
      repeat red.
      intros.
      repeat red in H.
      rewrite  EQR in EQR0.
      specialize (H R PH EQR0).
      apply H.
  Qed.

  Global Instance Proper_image2 {A}  :
    Proper (@eq (m A) ==> @eq A ==> @eq A ==> iff) (fun ma => (image ma)).
  Proof.
    do 3 red.
    intros.
    split; intros; cbn in *;  intros.
    - repeat intro. inversion H0; subst. apply H2. eauto. apply EQR.
    - repeat intro. inversion H0; subst. subst. apply H2. eauto. apply EQR.
  Qed.

  Global Instance Proper_image3 {A}  :
    Proper (@eq (m A) ==> (@eq2 Type Fun _ _ _)) image.
  Proof.
    do 3 red.
    repeat intro.
    rewrite H; reflexivity.
  Qed.

  Global Instance Proper_mayRet {A:Type} :
    Proper (@eq (m A) ==> (@eq A) ==> iff) (fun ma => (mayRet ma)).
  Proof.
    do 3 red.
    intros x y H x0 y0 H0.
    split; intros; cbn in *; intros.
    - rewrite <- H0. subst; auto.
    - rewrite H0. subst; auto.
  Qed.

  Global Instance Proper_mayRet2 {A}  :
    Proper (@eq (m A) ==> (@eq2 Type Fun _ _ _)) mayRet.
  Proof.
    repeat intro. subst; reflexivity.
  Qed.

  Lemma imageH_subrel_image_diag :
    forall A (ma : m A), imageH_diag ma ⊑ image ma.
  Proof.
    unfold image, imageH_diag. intros.
    red. intros * EQ.
    repeat intro. edestruct EQ. edestruct H.  eauto. eapply PER_is_ZZC; eauto. auto.
  Qed.

  Lemma imageH_diag_PER {A} (ma : m A) : (PER (imageH_diag ma)).
  Proof.
    split; repeat intro.
    - unfold imageH_diag in H.
      destruct H.
      red in H. split; repeat intro. specialize (H _ EQA H1). destruct H. eauto.
      specialize (H0 _ EQA H1). destruct H0. eauto.
    - unfold imageH_diag in H, H0.
      destruct H, H0. split; repeat intro.
      red in H, H1, H0, H2.
      specialize (H _ EQA H3). destruct H. eauto.
      specialize (H0 _ EQA H3). destruct H0.
      specialize (H1 _ EQA H3). destruct H1.
      specialize (H2 _ EQA H3). destruct H2.
      split; eapply H3. esplit; split. esplit; split.
      apply H. apply H6. auto.
      esplit; split. esplit; split.
      apply H5. apply H2. auto.
      specialize (H _ EQA H3). destruct H. eauto.
      specialize (H0 _ EQA H3). destruct H0.
      specialize (H1 _ EQA H3). destruct H1.
      specialize (H2 _ EQA H3). destruct H2.
      split; eapply H3. esplit; split. esplit; split.
      apply H. apply H6. auto.
      esplit; split. esplit; split.
      apply H5. apply H2. auto.
  Qed.

  Lemma image_subrel_imageH_diag :
    forall A (ma : m A),
      ma ≈{imageH_diag ma} ma ->
      image ma ⊑ imageH_diag ma.
  Proof.
    unfold image, imageH_diag. intros.
    repeat intro.
    pose proof @imageH_diag_PER.
    specialize (H1 A ma).
    specialize (H0 _ H1).
    apply H0; auto.
  Qed.

  Lemma imageH_image_eq :
    forall A (ma : m A),
      ma ≈{imageH_diag ma} ma ->
      eq_rel (image ma) (imageH_diag ma).
  Proof.
    intros.
    split. eapply image_subrel_imageH_diag; auto.
    apply imageH_subrel_image_diag.
  Qed.

  Lemma image_subset {A:Type} (ma : m A) :
    eqmR (image ma) ⊑ eqmR (@eq A).
  Proof.
    intros x y D.
    eapply Proper_eqmR_mono; eauto.
    eapply image_least. typeclasses eauto. reflexivity.
  Qed.

  Lemma image_inv:
    forall {A : Type} (ma : m A) (a1 a2 : A),
      image ma a1 a2  ->
      forall (R : relationH A A) (H : PER R), ma ≈{R} ma -> R a1 a2.
  Proof.
    repeat intro. unfold image in *.
    cbn in H. apply H; eauto.
  Qed.

  Global Instance Proper_image_eqmR {A} :
    Proper (eqmR eq ==> @eq A ==> @eq A ==> iff) image.
  Proof.
    intros x y EQ a1 a2 EQ' a3 a4 EQ''.
    subst. split; intros H.
    - red. unfold image_. intros.
      eapply H; eauto. rewrite EQ. auto.
    - red. unfold image_. intros.
      eapply H; eauto. rewrite <- EQ. auto.
  Qed.

  Global Instance Proper_mayRet_eqmR {A} :
    Proper (eqmR eq ==> @eq A ==> iff) mayRet.
  Proof.
    repeat intro. apply Proper_image_eqmR; eauto.
  Qed.

  Definition map_to_domain {A B} : relationH A B -> relationH A A :=
    fun R a1 a2 => a1 = a2 /\ exists (b : B), R a1 b.

  Lemma eqmR_property:
    forall A B (R : relationH A B) (ma : m A) (mb : m B),
      ma ≈{R} mb ->
      ma ≈{map_to_domain R} ma -> (forall x x', image ma x x' -> map_to_domain R x x').
  Proof.
    intros* EQ MAP x x' IMG.
    unfold map_to_domain in *.
    split. apply IMG. split; red; intuition; subst; auto.
    eapply Proper_eqmR_mono; eauto. repeat intro. destruct H. auto.
    eapply image_inv in MAP ; cycle 1. apply IMG.
    {
      split; red; intuition; subst; auto.
    } destruct MAP. auto.
  Qed.

End Image.

Notation "a1 ∈ ma" := (mayRet _ ma a1) (at level 40) : cat_scope.
Arguments image {_ _ _}.
Arguments imageH_diag {_ _ _}.

Section EqmRMonadLaws.
  Context (m : Type -> Type).
  Context {EqMRm : EqmR m}.
  Context {Mm : Monad m}.

  Class MayRetL : Prop :=
    mayRet_l : forall {A1 A2 : Type} (RA : relationH A1 A2) (ma1 : m A1) (ma2 : m A2)
                 (EQH : ma1 ≈{RA} ma2),
      forall a1, a1 ∈ ma1 -> exists a2, RA a1 a2 /\ a2 ∈ ma2.

  Class MayRetR : Prop :=
    mayRet_r : forall {A1 A2 : Type} (RA : relationH A1 A2) (ma1 : m A1) (ma2 : m A2)
                 (EQH : ma1 ≈{RA} ma2),
        forall a2, a2 ∈ ma2 -> exists a1, RA a1 a2 /\ a1 ∈ ma1.

  Class RetFinal : Prop :=
    final : forall {A1 A2 : Type} (RA : relationH A1 A2) (a1:A1) (a2:A2),
        RA a1 a2 -> ret a1 ≈{RA} ret a2.

  Class ImageEqmR : Prop :=
    image_eqmR : forall A (ma : m A), ma ≈{image ma} ma.

  Class ImagePost :=
    image_post :
      forall {A1 A2 : Type} (RR : relationH A1 A2) ma1 ma2,
        ma1 ≈{RR} ma2 -> ma1 ≈{fun x y => RR x y /\ x ∈ ma1 /\ y ∈ ma2 } ma2.

  Class ProperBind : Prop :=
    Proper_bind:
      forall {A1 A2 B1 B2 : Type} (RR : relationH A1 A2) (RB : relationH B1 B2)
        ma1 ma2 k1 k2,
      ma1 ≈{RR} ma2 ->
      (forall (a1 : A1) (a2 : A2), RR a1 a2 -> k1 a1 ≈{RB} k2 a2) ->
      bind ma1 k1 ≈{RB} bind ma2 k2.

  (* Monad laws *)
  Class BindRetL : Prop :=
    bind_ret_l : forall {A B : Type} (f : A -> m B) (a : A),
      bind (ret a) f ≈{eq} f a.

  Class BindRetR : Prop :=
    bind_ret_r : forall {A : Type} (ma : m A),
      bind ma ret ≈{eq} ma.

  Class BindBind : Prop :=
    bind_bind : forall {A B C : Type} (ma : m A) (f : A -> m B) (g : B -> m C),
      bind (bind ma f) g ≈{eq} bind ma (fun x => bind (f x) g).

  (* Generalization of monadic laws.
     These are of two quite distinct natures:
     * Heterogeneous generalizations of the usual three monad laws
     * Reasoning principles relating [eqmR R] to [R]
     *)
  Class EqmRMonadLaws :=
    {
    eqmR_mayRet_l :> MayRetL;
    eqmR_mayRet_r :> MayRetR;
    eqmR_image :> ImageEqmR;
    eqmR_ret :> RetFinal;
    eqmR_bind_ProperH :> ProperBind;
    eqmR_bind_ret_l :> BindRetL;
    eqmR_bind_ret_r :> BindRetR;
    eqmR_bind_bind :> BindBind
    }.

End EqmRMonadLaws.

Global Instance Proper_bind_pointwise {m : Type -> Type} {m_EqmR : EqmR m} {m_Monad : Monad m} {m_EqmR_OK : EqmR_OK m} {m_EqmRMonadLaws : EqmRMonadLaws m} : forall {A B},
    (@Proper (m A -> (A -> m B) -> m B)
             (eqmR eq ==> pointwise_relation _ (eqmR eq) ==> eqmR eq) bind).
Proof.
  repeat intro. eapply Proper_bind with (RR := eq); eauto; intros; subst; eauto. typeclasses eauto.
Qed.

Arguments mayRet_l {m _ _} [_ _].
Arguments mayRet_r {m _ _} [_ _].
Arguments final {m _ _ _} [_ _].
Arguments bind_ret_l {m _ _ _} [_ _].
Arguments bind_ret_r {m _ _ _} [_].
Arguments bind_bind {m _ _ _} [_ _ _].
Arguments Proper_bind {m _ _ _} [_ _ _ _].
Arguments Proper_bind_pointwise {m _ _ _ _} [_ _].

Section EqmRInversion.
  Context (m : Type -> Type).
  Context {Mm : Monad m}.
  Context {EqMR : EqmR m} {EqmRm: EqmRMonadLaws m} {EqmROKm : EqmR_OK m}.

  Definition mayRet_rel {A B} (ma : m A) (mb : m B) :=
    fun x y => x ∈ ma /\ y ∈ mb.

  Class RetInv : Prop :=
    ret_inv :
      forall {A1 A2 : Type} (RA : relationH A1 A2) (a1:A1) (a2:A2),
        ret a1 ≈{RA} ret a2 -> RA a1 a2.

  Class MayRetBindInv : Prop :=
    mayRet_bind_inv :
      forall (A B:Type) (ma:m A) (k:A -> m B),
      forall b, b ∈ bind ma k -> exists a, a ∈ ma /\ b ∈ k a.

  Class FmapInvRet : Prop :=
    fmap_inv_ret :
      forall (A B:Type) (ma :m A) (f f' :A -> B) (R:relationH B B),
        (f <$> ma) ≈{ R } (f' <$> ma) ->
        forall a : A, a ∈ ma -> ret (f a) ≈{ R } ret (f' a).

  Class BindInv : Prop :=
    bind_inv : forall (A1 A2 B1 B2: Type) (R : relationH B1 B2)
      (ma1 : m A1) (ma2 : m A2) (k1 : A1 -> m B1) (k2 : A2 -> m B2),
      (x <- ma1;; k1 x) ≈{ R } (x <- ma2;; k2 x) ->
      ma1 ≈{ fun x y => k1 x ≈{ R } k2 y } ma2.

  Class FmapInv_mayRet :=
    fmap_inv_mayRet :
      forall (A1 A2 B1 B2:Type) (R : relationH B1 B2)
        (f1 : A1 -> B1) (f2 :A2 -> B2) (ma1 : m A1) (ma2:m A2),
        (f1 <$> ma1) ≈{ R } (f2 <$> ma2) ->
        ma1 ≈{ fun a1 a2 => mayRet_rel ma1 ma2 a1 a2 /\ R (f1 a1) (f2 a2)} ma2.

  Class EqmRInv :=
    eqmR_inv : forall A (R : A -> A -> Prop) (ma : m A),
        ma ≈{R} ma -> forall a, a ∈ ma -> R a a.

  Class FmapInv :=
    fmap_inv :
      forall (A1 A2 B1 B2:Type) (R : relationH B1 B2)
        (f1 : A1 -> B1) (f2 :A2 -> B2) (ma1 : m A1) (ma2:m A2),
        (f1 <$> ma1) ≈{ R } (f2 <$> ma2) ->
        ma1 ≈{ fun a1 a2 => R (f1 a1) (f2 a2)} ma2.

  (* This is the key lemma that checks whether or not the monad has computations
     which are impure and has an observable step.

     Notably, the state monad does not respect this property (see [bind_ret_inv_counterexample]
     in [Monads/State.v]) which means that two impure computations can be
     composed to form a pure computation. This is especially true for states
     where you can "undo" what's been done.
   *)
  Class BindRetInv :=
    bind_ret_inv:
      forall {A B : Type} (ma : m A) (kb : A -> m B) (b : B),
        bind ma kb ≈{eq} ret b -> exists a : A, ma ≈{eq} ret a /\ kb a ≈{eq} ret b.

  Class EqmRInversionProperties :=
    {
      eqmR_ret_inv :> RetInv;
      eqmR_mayRet_bind_inv :> MayRetBindInv;
      eqmR_fmap_inv :> FmapInv;
      eqmR_inv_ :> EqmRInv
    }.

End EqmRInversion.

#[global]
 Instance FmapInv_ m  `{EqmR_OK m} {m_FmapInv_mayRet : FmapInv_mayRet m} : FmapInv m.
Proof.
  repeat intro. eapply fmap_inv_mayRet in H0; eauto.
  unfold mayRet_rel in H0.
  eapply Proper_eqmR_mono; eauto.
  repeat intro. destruct H1 as (?&?). auto.
Qed.

Arguments ret_inv {m _ _ _} [_ _].
Arguments mayRet_bind_inv {m _ _ _} [_ _].
Arguments fmap_inv_ret {m _ _ _} [_ _].
Arguments fmap_inv {m _ _ _} [_ _ _ _].

(* Notions of computational purity based on image. *)
Section Comp.

  Context {m : Type -> Type}.

  Context {Mm : Monad m}.
  Context {EqMR : EqmR m} {EqmRm: EqmRMonadLaws m} {EqmROKm : EqmR_OK m} {EqmRMonadInverses : EqmRInversionProperties m}.

  Import RelNotations.
  Local Open Scope relationH_scope.

  (* A sanity check about the images: *)
  Definition singletonR {A:Type} (x:A) : relationH A A :=
    fun a b => a = b /\ a = x.

  Lemma singletonR_SymmetricH {A:Type} (x:A) : SymmetricH (singletonR x).
  Proof.
    repeat red. intros a1 a2 H. unfold singletonR in H. cbn in *.
    destruct H. split; symmetry. tauto. rewrite <- H. symmetry. assumption.
  Qed.

  Lemma singletonR_TransitiveH {A:Type} (x:A) : TransitiveH (singletonR x).
  Proof.
    repeat red.
    intros.
    unfold singletonR in *. cbn in *.
    destruct H0, H; split; etransitivity; eauto. subst. auto.
  Qed.

  Lemma ret_image {A:Type} (x:A) : image (ret x) ≡ singletonR x.
  Proof.
    split.
    - repeat red. intros.
      unfold image in H. cbn in *.
      specialize (H (singletonR x)).
      assert (PER (singletonR x)).
      { split. apply singletonR_SymmetricH.
        apply singletonR_TransitiveH. }
      specialize (H H0).
      assert (eqmR (singletonR x) (ret x) (ret x)).
      { apply eqmR_ret. typeclasses eauto.  auto. esplit; reflexivity. }
      apply H in H1. repeat red in H2. assumption.
    - do 2 red. intros.
      unfold singletonR in H. destruct H. cbn in *.
      rewrite <- H. rewrite H0.
      subst.
      repeat intro.
      eapply eqmR_ret_inv; eauto...
  Qed.

  Lemma ret_mayRet {A : Type} : forall (a : A), a ∈ ret a.
  Proof.
    intros; unfold mayRet. apply ret_image. split; eauto.
  Qed.

  (* Under these well-formedness conditions of EqmR, eqmR eq and
    eqmR (image ma) coincides.*)
  Lemma image_eq {A} (ma ma': m A):
    eqmR eq ma ma' <-> eqmR (image ma) ma ma'.
  Proof.
    split.
    - repeat intro. eapply Proper_eqmR_cong; eauto...
      reflexivity. rewrite <- H. apply image_eqmR. typeclasses eauto.
    - eapply image_subset; eauto...
  Qed.

End Comp.

Section EqmRConsequences.

  Context (m : Type -> Type).
  Context {Mm : Monad m}.
  Context {EqMR : EqmR m} {EqmRm: EqmRMonadLaws m} {EqmROKm : EqmR_OK m} {EqmRMonadInverses : EqmRInversionProperties m}.

  Lemma eqmR_bind_ProperH_simple : forall {A1 A2 B1 B2 : Type}
                                     (RA : relationH A1 A2)
                                     (RB : relationH B1 B2)
                                     (ma1 : m A1) (ma2 : m A2)
                                     (k1 : A1 -> m B1) (k2 : A2 -> m B2),
      ma1 ≈{RA} ma2 ->
      (forall a1 a2, RA a1 a2 -> k1 a1 ≈{RB} k2 a2) ->
      bind ma1 k1 ≈{RB} bind ma2 k2.
  Proof.
    intros. apply Proper_bind with (RR := RA); auto.
  Qed.

  Global Instance Proper_eqmR_eq_impl :
    forall {m : Type -> Type} {Mm : Monad m} {E : EqmR m},
      EqmR_OK m -> forall A : Type,
        Proper (eqmR (@eq A) ==> eqmR eq ==> Basics.flip Basics.impl) (eqmR eq).
  Proof.
    repeat intro.
    symmetry.
    etransitivity; eauto.
    etransitivity; eauto.
    symmetry; eauto. symmetry; auto.
  Qed.

  Instance imageH_diag_Zigzag {A} (ma : m A) : Zigzag (imageH_diag ma).
  Proof.
    pose proof @imageH_diag_PER.
    eapply PER_is_ZZC; eauto.
  Qed.

  Lemma image_bind_eq {A B:Type} (ma : m A) (k1 k2 : A -> m B)
        (HK : forall (a1 a2 : A), image ma a1 a2 -> k1 a1 ≈{eq} k2 a2) :
    bind ma k1 ≈{eq} bind ma k2.
  Proof.
    eapply eqmR_bind_ProperH with (RR := image ma); auto...
    eapply image_eqmR. typeclasses eauto.
  Qed.

  Lemma image_ret_bind {A:Type} (ma : m A) (k : A -> m A) :
    (forall (a1 a2 : A), image ma a1 a2 -> k a1 ≈{eq} ret a2) ->
      bind ma k ≈{eq} bind ma ret.
  Proof.
    intros H.
    apply image_bind_eq. intros.
    apply H. assumption.
  Qed.

  Lemma mayRet_image1 {A:Type} (ma : m A) (a1 a2 : A) (HI : image ma a1 a2) :
    a1 ∈ ma.
  Proof.
    repeat red.
    intros.
    specialize (HI R PH EQR).
    change (R a1 a1).
    PER_reflexivityH.
  Qed.

  Lemma mayRet_image2 {A:Type} (ma : m A) (a1 a2 : A) (HI : image ma a1 a2) :
    a2 ∈ ma.
  Proof.
    repeat red.
    intros.
    specialize (HI R PH EQR).
    change (R a2 a2).
    PER_reflexivityH.
  Qed.

  Lemma image_ma_eq :
    forall A (ma1 : m A),
      ma1 ≈{fun x y => x = y /\ x ∈ ma1} ma1.
  Proof.
    intros. eapply eqmR_rel_conj; eauto. reflexivity.
    eapply Proper_eqmR_mono. 2 : eapply image_eqmR.
    intros ? ?. eapply mayRet_image1. typeclasses eauto.
  Qed.

  #[global] Instance image_post' : ImagePost m.
  Proof.
    repeat intro.
    pose proof (eqmR_rel_comp m). red in H0.
    specialize (H0 _ _ _ _ _ _ _ _ (image_ma_eq _ ma1) H). unfold rel_compose in H.
    pose proof (eqmR_rel_comp m). red in H1.
    specialize (H1 _ _ _ _ _ _ _ _ H0 (image_ma_eq _ ma2)). unfold rel_compose in H.
    eapply Proper_eqmR_mono; eauto.
    repeat intro. unfold rel_compose in H2. destruct H2 as (?&?&?).
    destruct H2 as (?&?&?). destruct H2, H3. subst. econstructor; eauto.
  Qed.

  Lemma clo_bind_gen :
    forall {A1 A2 B1 B2 : Type} (RR : relationH A1 A2) (RB : relationH B1 B2)
      ma1 ma2 k1 k2,
    ma1 ≈{RR} ma2 ->
    (forall (a1 : A1) (a2 : A2), a1 ∈ ma1 -> a2 ∈ ma2 -> RR a1 a2 -> k1 a1 ≈{RB} k2 a2) ->
    bind ma1 k1 ≈{RB} bind ma2 k2.
  Proof.
    intros. eapply Proper_bind. eapply image_post; eauto.
    typeclasses eauto. intros ? ? (?&?&?); eauto.
  Qed.

End EqmRConsequences.

Section InversionFacts.
  Context (m : Type -> Type).
  Context {Mm : Monad m}.
  Context {EqMR : EqmR m} {EqmRm: EqmRMonadLaws m} {EqmROKm : EqmR_OK m} {EqmRMonadInverses : EqmRInversionProperties m}.

  Instance FmapInvRet': FmapInvRet m.
  Proof.
  repeat intro.
  eapply fmap_inv in H. eapply eqmR_inv in H; eauto. 2 : typeclasses eauto.
  apply eqmR_ret; eauto.
  Qed.

  Instance FmapInvMayRet' : FmapInv_mayRet m.
  Proof.
    repeat intro.
    eapply fmap_inv in H. unfold mayRet_rel.
    eapply image_post in H; try typeclasses eauto.
    eapply Proper_eqmR_mono; eauto.
    repeat intro. destruct H0 as (?&?&?); repeat constructor; eauto.
  Qed.

  Lemma mayRet_fmap_inv {A B: Type} (ma : m A) (k : A -> B) (a:A) (b:B) :
    a ∈ ma ->
    b ∈ ret (k a) ->
    b ∈ (k <$> ma).
  Proof.
    intros HM HK.
    repeat red.
    intros.
    eapply fmap_inv_ret in EQR ; eauto.
    apply ret_inv in EQR.
    eapply HK; eauto. apply final; eauto.
  Qed.

  Lemma fmap_image :
    forall A B (x : B) (f : A -> B) (ma : m A),
      x ∈ (f <$> ma) <-> (exists y, y ∈ ma /\ (f y) = x).
  Proof.
    repeat intro. split; repeat intro; eauto.
    - eapply mayRet_bind_inv in H; eauto.
      destruct H as (? & ? & ?).
      eexists. unfold mayRet in H0.
      apply ret_image in H0.
      red in H0. destruct H0; subst; eauto.
    - destruct H as (? & ? & ?).
      apply fmap_inv in EQR; eauto...
      eapply eqmR_mayRet_l in EQR; eauto...
      specialize (EQR _ H). destruct EQR as (? & ? & ?). subst; auto.
      PER_reflexivityH.
  Qed.

  Lemma eqmR_fmap_R {A} (ma : m A) :
    (forall B (mb : m B) (f : B -> A) (R : A -> A -> Prop),
        ma ≈{(fun x y => R x (f y))} mb -> ma ≈{R} fmap f mb).
  Proof.
    repeat intro; eauto; intros.
    assert ((x <- ma;; ret x) ≈{R} (x <- mb;; ret (f x))).

    eapply eqmR_bind_ProperH; eauto; repeat intro...
    1: apply eqmR_ret; eauto...
    eapply Proper_eqmR_cong; eauto.
    rewrite bind_ret_r. reflexivity. unfold fmap. reflexivity.
  Qed.

End InversionFacts.

Class EQM (M : Type -> Type) {Monad_M : Monad M} (EQM_EqmR : EqmR M):= {
  EQM_EqmR_OK :> EqmR_OK M;
  EQM_EqmRMonad :> EqmRMonadLaws M;
  EQM_EqmRMonadInverses :> EqmRInversionProperties M
}.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(**********************************************************************)
(*                Abstraction_Tactics.v                               *)
(*                                                                    *)
(*                     Barry Jay                                      *)
(*                                                                    *)
(**********************************************************************)

(*
Add LoadPath ".." as IntensionalLib.
*)
Require Import Arith Omega.
Require Import IntensionalLib.SF_calculus.General.
Require Import IntensionalLib.Tree_calculus.Abstraction_Terms.

Definition termred := Abs_Term -> Abs_Term -> Prop.

Definition preserve (R : termred) (P : Abs_Term -> Prop) :=
  forall x : Abs_Term, P x -> forall y : Abs_Term, R x y -> P y.

Inductive multi_step : termred -> termred :=
  | zero_red : forall red M, multi_step red M M
  | succ_red : forall (red: Abs_Term-> Abs_Term -> Prop) M N P,
                   red M N -> multi_step red N P -> multi_step red M P
.

Inductive sequential : termred -> termred -> termred :=
  | seq_red : forall (red1 red2 : termred) M N P,
                red1 M N -> red2 N P -> sequential red1 red2 M P.

Hint Resolve zero_red succ_red seq_red
.

Definition reflective red := forall (M: Abs_Term), red M M.

Lemma refl_multi_step : forall (red: termred), reflective (multi_step red).
Proof. red; split_all. Qed.

Lemma refl_seq : forall (red1 red2: termred),
                   reflective red1 -> reflective red2 -> reflective(sequential red1 red2).
Proof. red; split_all; eapply2 seq_red. Qed.

Ltac reflect := match goal with
| |- reflective (multi_step _) => eapply2 refl_multi_step
| |- multi_step _ _ _ => try (eapply2 refl_multi_step)
| |- reflective (sequential _) => eapply2 refl_seq; reflect
| |- sequential _ _ _ _ => try (eapply2 refl_seq)
| _ => split_all
end.

Ltac one_step :=
match goal with
| |- multi_step _ _ ?N => apply succ_red with N; auto; try red; try reflect
end.

Ltac seq_l :=
match goal with
| |- sequential _ _ ?M ?N => apply seq_red with N; auto; red; reflect
end.

Ltac seq_r :=
match goal with
| |- sequential _ _ ?M ?N => apply seq_red with M; auto; red; reflect
end.

Definition transitive red := forall (M N P: Abs_Term), red M N -> red N P -> red M P.

Lemma transitive_red : forall red, transitive (multi_step red).
Proof. red; induction 1; split_all.
apply succ_red with N; auto.
Qed.

Definition preserves_app (red : termred) :=
forall M M' N N', red M M' -> red N N' -> red (App M N) (App M' N').

Lemma preserves_app_multi_step : forall (red: termred), reflective red -> preserves_app red -> preserves_app (multi_step red).
Proof.
red. induction 3; split_all. generalize H0; induction 1.
reflect.
apply succ_red with (App M N); auto.
assert( transitive (multi_step red)) by eapply2 transitive_red.
apply X0 with (App N0 N); auto.
one_step.
Qed.

Lemma preserves_app_seq : forall (red1 red2: termred), preserves_app red1 -> preserves_app red2 -> preserves_app (sequential red1 red2).
Proof.
red; split_all.
inversion H1; inversion H2.
apply seq_red with (App N0 N1); auto.
Qed.

Hint Resolve preserves_app_multi_step preserves_app_seq .

Ltac eelim_for_equal :=
match goal with
| H: forall _, _ = _ -> _  |- _ => eelim H; clear H; subst; eelim_for_equal
| _ => split_all
end.

Ltac inv1 prop :=
match goal with
| H: prop (App  _ _) |- _ => inversion H; clear H; inv1 prop
| H: prop Op _ |- _ => inversion H; clear H; inv1 prop
| _ => split_all
 end.

Definition implies_red (red1 red2: termred) := forall M N, red1 M N -> red2 M N.

Lemma implies_red_multi_step: forall red1 red2, implies_red red1  (multi_step red2) ->
                                                implies_red (multi_step red1) (multi_step red2).
Proof. red.
intros red1 red2 IR M N R; induction R; split_all.
apply transitive_red with N; auto.
Qed.
Lemma implies_red_seq:
 forall red1 red2 red3,
  implies_red red1  (multi_step red3)  ->
  implies_red red2 (multi_step red3) ->
  implies_red (sequential red1 red2) (multi_step red3) .
Proof.
red; split_all. inversion H1. apply transitive_red with N0; auto.
Qed.

Ltac inv red :=
match goal with
| H: multi_step red (App _ _) _ |- _ => inversion H; clear H; inv red
| H: multi_step red (Op _) _ |- _ => inversion H; clear H; inv red
| H: red (App _ _) _ |- _ => inversion H; clear H; inv red
| H: red (Op _) _ |- _ => inversion H; clear H; inv red
| H: multi_step red _ (App _ _) |- _ => inversion H; clear H; inv red
| H: multi_step red _ (Op _) |- _ => inversion H; clear H; inv red
| H: red _ (App _ _) |- _ => inversion H; clear H; inv red
| H: red _ (Op _) |- _ => inversion H; clear H; inv red
| _ => subst; split_all
 end.

Definition diamond (red1 red2 : termred) :=
forall M N, red1 M N -> forall P, red2 M P -> exists Q, red2 N Q /\ red1 P Q.

Lemma diamond_flip: forall red1 red2, diamond red1 red2 -> diamond red2 red1.
Proof.
unfold diamond; split_all. elim (H M P H1 N H0); split_all.
inversion H2; exist x; split; auto. Qed.

Lemma diamond_strip :
forall red1 red2, diamond red1 red2 -> diamond red1 (multi_step red2).
Proof. intros.
eapply2 diamond_flip.
red; induction 1; split_all.
exist P.
elim (H M P0 H2 N); split_all.
elim(IHmulti_step H x); split_all.
inversion H3; inversion H4;
exist x0; split; auto.
apply succ_red with x; auto.
inversion H3; auto.
Qed.

Definition diamond_star (red1 red2: termred) := forall  M N, red1 M N -> forall P, red2 M P ->
  exists Q, red1 P Q /\ multi_step red2 N Q.

Lemma diamond_star_strip: forall red1 red2, diamond_star red1 red2 -> diamond (multi_step red2) red1 .
Proof.
red. induction 2; split_all.
exist P.
elim(H M P0 H2 N H0); split_all. inversion H3.
elim(IHmulti_step H x); split_all.  inversion H6.
exist x0; split; auto.
apply transitive_red with x; auto.
Qed.

Lemma diamond_tiling :
forall red1 red2, diamond red1 red2 -> diamond (multi_step red1) (multi_step red2).
Proof.
red.  induction 2; split_all.
exist P.
elim(diamond_strip red red2 H M N H0 P0); split_all. inversion H3.
elim(IHmulti_step H x H4); split_all. inversion H6; auto.
exist x0; split; auto.
apply succ_red with x; auto.
Qed.

Hint Resolve diamond_tiling.

Lemma diamond_seq: forall red red1 red2, diamond red red1 -> diamond red red2 -> diamond red (sequential red1 red2).
Proof. unfold diamond; split_all.
inversion H2.
elim(H M N H1 N0); split_all. inversion H9.
elim(H0 N0 x H11 P); split_all. inversion H12.
exist x0; split; auto.
apply seq_red with x; auto.
Qed.

Fixpoint rank (M: Abs_Term ) :=
match M with
| Op _ => 1
| App M1 M2 => S((rank M1) + (rank M2))
end.

Lemma rank_positive: forall M, rank M > 0.
Proof.
induction M; split_all.  omega.
Qed.

Ltac split_all := simpl; intros;
match goal with
| H : _ /\ _ |- _ => inversion_clear H; split_all
| H : exists _, _ |- _ => inversion H; clear H; split_all
| _ =>  try (split; split_all); try contradiction
end; try congruence; auto.


From Undecidability.FOL.Syntax Require Import Core Facts.

Require Import Coq.Classes.Init.
Require Import Relation_Definitions.
Require Export Coq.Classes.RelationClasses.
Require Import Coq.Classes.Morphisms.
Require Export Setoid.

Section Asimpl.
  Context {Σf : funcs_signature} {Σp : preds_signature}.
  Context {ops : operators}.
  Context {ff : falsity_flag}.

  Definition feq {A} {B} (s t : A -> B) := forall x, s x = t x.
  #[local] Notation "a ≡ b" := (feq a b) (at level 51).
  #[local] Notation id := (fun x => x).
  #[global]
  Program Instance feq_reflexive {A} {B}  : Reflexive (@feq A B) | 1.
  Next Obligation. now intros ?. Qed.
  #[global]
  Program Instance feq_symmetrive {A} {B}  : Symmetric (@feq A B) | 1.
  Next Obligation. now intros ?. Qed.
  #[global]
  Program Instance feq_transitive {A} {B}  : Transitive (@feq A B) | 1.
  Next Obligation. intros ?. now rewrite H, H0. Qed.

  #[global]
  Add Parametric Relation A B : (A -> B) (@feq A B)
    reflexivity proved by (feq_reflexive (A:=A))
    symmetry proved by (feq_symmetrive (A:=A))
    transitivity proved by (feq_transitive (A:=A))
    as eq_set_rel.

  #[global]
  Add Parametric Morphism X: (@scons X)
    with signature (@eq X) ==> (@feq nat X) ==> (@feq nat X) as scons_feq.
  Proof.
    intros t x2 y2 H2. intros [|n]; try easy. cbn. now rewrite H2.
  Qed.

  #[global]
  Add Parametric Morphism A B C: (@funcomp A B C)
    with signature (@feq B C) ==> (@feq A B) ==> (@feq A C) as funcomp_feq.
  Proof.
    intros x1 y1 H1 x2 y2 H2. intros k. unfold funcomp. now rewrite H2, H1.
  Qed.

  #[global]
  Add Parametric Morphism : (subst_term)
    with signature (@feq nat term) ==> (@feq term term) as subst_term_feq.
  Proof.
    intros x1 y1 H1. intros x2. apply subst_term_ext, H1.
  Qed.

  #[global]
  Add Parametric Morphism : (subst_term)
    with signature (@feq nat term) ==> (@eq term) ==> (@eq term) as subst_term_feq_eq.
  Proof.
    intros x1 y1 H1. intros x2. apply subst_term_ext, H1.
  Qed.

  #[global]
  Add Parametric Morphism : (subst_form)
    with signature (@feq nat term) ==> (@eq form) ==> (@eq form) as subst_form_feq_eq.
  Proof.
    intros x1 y1 H1. intros x2. apply subst_ext, H1.
  Qed.

  (* Interaction on terms *)
  Lemma asimpl_t_var x s : (var x)`[s] = s x.
  Proof. reflexivity. Qed.
  Lemma asimpl_t_func t v s : (func t v)`[s] = (func t (Vector.map (subst_term s) v)).
  Proof. reflexivity. Qed.
  Lemma asimpl_t_id t : t`[var] = t.
  Proof. now apply subst_term_id. Qed.
  Lemma asimpl_t_comp t s1 s2 : t`[s1]`[s2] = t`[s1 >> subst_term s2].
  Proof. apply subst_term_comp. Qed.
  Lemma asimpl_t_ext t s1 s2 : s1 ≡ s2 -> t`[s1] = t`[s2].
  Proof. apply subst_term_ext. Qed.

  (* Interaction on forms *)
  Lemma asimpl_f_falsity s : falsity[s] = falsity.
  Proof. easy. Qed.
  Lemma asimpl_f_atom P v s : (atom P v)[s] = atom P (Vector.map (subst_term s) v).
  Proof. easy. Qed.
  Lemma asimpl_f_bin b f1 f2 s : (bin b f1 f2)[s] = bin b (f1[s]) (f2[s]).
  Proof. easy. Qed.
  Lemma asimpl_f_quant q f s : (quant q f)[s] = quant q (f[$0 .: (s >> subst_term (S >> var))]).
  Proof. easy. Qed.
  Lemma asimpl_f_id t : t[var] = t.
  Proof. now apply subst_id. Qed.
  Lemma asimpl_f_comp t s1 s2 : t[s1][s2] = t[s1 >> subst_term s2].
  Proof. apply subst_comp. Qed.
  Lemma asimpl_f_ext t s1 s2 : s1 ≡ s2 -> t[s1] = t[s2].
  Proof. apply subst_ext. Qed.

  (* Interaction on forms and terms both uses *)
  Lemma asimpl_vector_nil A B (f:A -> B) : Vector.map f (Vector.nil A) = Vector.nil B.
  Proof. easy. Qed.
  Lemma asimpl_vector_cons A B (f:A -> B) t n v : Vector.map f (@Vector.cons A t n v) = @Vector.cons B (f t) n (Vector.map f v).
  Proof. easy. Qed.

  (* Sigma calculus laws
     Rewritten such that they are always applicable from left to right,
     and so that composition associativity does not affect them ("ca" lemmas)

     Note that they are just given for completeness.
     Since some of them are computational equivalences, we do not actually use them to
     construct the asimpl tactic. *)
  Lemma asimpl_var_id_l s : var >> subst_term s ≡ s.
  Proof. easy. Qed.
  Lemma asimpl_var_id_l_ca X s (t:term -> X) : var >> (subst_term s >> t) ≡ s >> t.
  Proof. easy. Qed.
  Lemma asimpl_subst_merge (t r : nat -> term) : subst_term t >> subst_term r ≡ subst_term (t >> subst_term r).
  Proof. intros n; unfold funcomp. now rewrite subst_term_comp. Qed.
  Lemma asimpl_var_id_r (s : nat->term) : s >> subst_term var ≡ s.
  Proof. intros n. apply asimpl_t_id. Qed.
  Lemma asimpl_id_id_l X Y (f : X -> Y) : id >> f ≡ f.
  Proof. intros x; easy. Qed.
  Lemma asimpl_id_id_r X Y (f : X -> Y) : f >> id ≡ f.
  Proof. intros x; easy. Qed.
  Lemma asimpl_funcomp_assoc X Y Z W (f:X->Y) (g:Y->Z) (h:Z->W) : (f >> g) >> h ≡ f >> (g >> h).
  Proof. intros x; easy. Qed.
  Lemma asimpl_scons_comp Z t s (f : term -> Z) : (t .: s) >> f ≡ ((f t) .: (s >> f)).
  Proof. intros [|n]; easy. Qed.
  Lemma asimpl_up_scons X (t:X) s : S >> (t .: s) ≡ s.
  Proof. now intros [|n]. Qed.
  Lemma asimpl_scons_up : (0 .: S) ≡ id.
  Proof. now intros [|n]. Qed.
  Lemma asimpl_scons_up_f B (f : nat -> B) : (f 0 .: (S >> f)) ≡ f.
  Proof. now intros [|n]. Qed.
End Asimpl.

(* asimpl_pre pushed down substitutions and composes them *)
#[global] Create HintDb asimpl_pre.
#[global] Hint Rewrite -> @asimpl_vector_nil : asimpl_pre.
#[global] Hint Rewrite -> @asimpl_vector_cons : asimpl_pre.

#[global] Hint Rewrite -> @asimpl_t_var : asimpl_pre.
#[global] Hint Rewrite -> @asimpl_t_func : asimpl_pre.
#[global] Hint Rewrite -> @asimpl_t_id : asimpl_pre.
#[global] Hint Rewrite -> @asimpl_t_comp : asimpl_pre.

#[global] Hint Rewrite -> @asimpl_f_falsity : asimpl_pre.
#[global] Hint Rewrite -> @asimpl_f_atom : asimpl_pre.
#[global] Hint Rewrite -> @asimpl_f_bin : asimpl_pre.
#[global] Hint Rewrite -> @asimpl_f_quant : asimpl_pre.
#[global] Hint Rewrite -> @asimpl_f_id : asimpl_pre.
#[global] Hint Rewrite -> @asimpl_f_comp : asimpl_pre.

(* Step 1: Simplify with asimpl_pre *)
#[global] Ltac asimpl_pre := try autorewrite with asimpl_pre.
#[global] Ltac asimpl_pre_in H := try autorewrite with asimpl_pre in H.

#[global] Ltac print_goal := match goal with |- ?g => idtac (* "goal:" g*) end.
#[global] Tactic Notation "debug_idtac" string(x) := idtac (*x*).

(* Step 2: find a place where we use a substitution, and replace it with an evar.
           Bonus asimpl_pre to replace foo[var] with foo (using subst_id) *)
#[global]
Ltac asimpl_match t := (match goal with
    |- context[?phi[?sigma]] => progress (print_goal; erewrite (@asimpl_f_ext _ _ _ _ phi sigma); [|t]; asimpl_pre)
  | |- context[?tt`[?sigma]] => progress (print_goal; erewrite (@asimpl_t_ext _ tt sigma); [|t]; asimpl_pre) end).

(* Use constr_eq_strict to ensure we are working within the correct goal.
   Otherwise, we modify the goal order, and `progress` thinks we made progress.
   This leads to an endless loop *)
#[global]
Ltac asimpl_match_goal t H := (match goal with
    H' : context[?phi[?sigma]] |- _ => progress (constr_eq_strict H' H; erewrite (@asimpl_f_ext _ _ _ _ phi sigma) in H; [|t]; try asimpl_pre_in H)
  | H' : context[?tt`[?sigma]] |- _ => progress (constr_eq_strict H' H; erewrite (@asimpl_t_ext _ tt sigma) in H; [|t]; try asimpl_pre_in H) end).

(* Step 3: Simplify the substitution, using the normalizing complete sigma calculus rewrite rules
           Carefully tune the order such that things are fast. *)
#[global]
Ltac asimpl_on_goal := (cbn; unfold up;
  (match goal with
| |- context[(?a >> ?b) >> ?c] =>
    debug_idtac "asimpl_funcomp_assoc";
    change ((a >> b) >> c) with (a >> (b >> c))
| |- context[var >> subst_term ?s] =>
    debug_idtac "asimpl_var_id_l";
    change (var >> subst_term s) with s
| |- context[var >> (subst_term ?s >> ?t)] =>
    debug_idtac "asimpl_var_id_l_ca";
    change (var >> (subst_term s >> t)) with (s >> t)
| |- context[id >> ?f] =>
    debug_idtac "asimpl_id_id_l";
    change (id >> f) with f
| |- context[?f >> id] =>
    debug_idtac "asimpl_id_id_r";
    change (f >> id) with f
| |- context[?s >> subst_term var] =>
    debug_idtac "!asimpl_var_id_r";
    rewrite !(@asimpl_var_id_r _ s)
| |- context[subst_term ?t >> subst_term ?r] =>
    debug_idtac "!asimpl_subst_merge";
    rewrite !(@asimpl_subst_merge _ t r)
| |- context[S >> (?t .: ?s)] =>
    debug_idtac "!asimpl_up_scons";
    rewrite !(@asimpl_up_scons _ t s)
| |- context[(0 .: S)] =>
    debug_idtac "!asimpl_scons_up";
    rewrite ! (@asimpl_scons_up)
| |- context[(?tt .: (S >> ?f))] =>
    debug_idtac "!asimpl_scons_up_f";
    rewrite !(@asimpl_scons_up_f _ f)
| |- context[(?t .: ?s) >> ?f] =>
    debug_idtac "asimpl_scons_comp";
    rewrite (@asimpl_scons_comp _ _ t s f) end)).

(* Do step 3, and resolve the evar with it *)
#[global]
Ltac asimpl_on_goal' := cbn; unfold up; (repeat asimpl_on_goal); reflexivity.

(* General asimpl: Repeat the matching until nothing changes anymore *)
#[global]
Ltac asimpl_base := asimpl_pre; repeat progress asimpl_match (asimpl_on_goal').
#[global]
Ltac asimpl_hyp H := asimpl_pre_in H; repeat progress asimpl_match_goal (asimpl_on_goal') H.

#[global]
Tactic Notation "asimpl" := asimpl_base.
#[global]
Tactic Notation "asimpl" "in" hyp(H) := asimpl_hyp H.

Section Test.
  Context {Σf : funcs_signature} {Σp : preds_signature}.
  Context {ff : falsity_flag}.
  Import FragmentSyntax.

  #[local]
  Lemma asimpl_test_1 phi t sigma :
    phi[up sigma][t..] = phi[t.:sigma].
  Proof.
    asimpl. reflexivity.
  Qed.

  #[local]
  Lemma asimpl_test_1_ctx phi t sigma :
    phi[up sigma][t..] = phi[t.:sigma] -> (phi[t.:sigma] = phi[t.:sigma]).
  Proof.
    intros H. asimpl in H. apply H.
  Qed.

  #[local]
  Lemma asimpl_test_2 phi :
    phi[up ↑][up (up ↑)][up $0..] = phi[$0 .: S >> ↑].
  Proof.
    asimpl. reflexivity.
  Qed.

  #[local]
  Lemma asimpl_test_3 phi t sigma :
    phi`[up ↑]`[t.:sigma] = phi`[t.:S>>sigma].
  Proof.
    asimpl. reflexivity.
  Qed.

  #[local]
  Lemma asimpl_test_4 phi t sigma :
    phi[up ↑][t.:sigma] = phi[t.:S>>sigma].
  Proof.
    asimpl. reflexivity.
  Qed.

  #[local]
  Lemma asimpl_test_5 phi :
    phi[$0.:↑] = phi.
  Proof.
    asimpl. reflexivity.
  Qed.

  #[local]
  Lemma asimpl_test_6 phi x :
    phi[up ↑][up $x..] = phi.
  Proof.
    asimpl. reflexivity.
  Qed.

  #[local]
  Lemma asimpl_test_7 phi :
    phi[up ↑][$0..] = phi.
  Proof.
    asimpl. reflexivity.
  Qed.

  #[local]
  Lemma asimpl_test_8 phi x :
    phi[up ↑][up $x..][up ↑][up $x..] = phi[up ↑][up $x..][up ↑][up $x..][up ↑][up $x..].
  Proof.
    asimpl. reflexivity.
  Qed.

  #[local]
  Lemma asimpl_test_9 phi :
    phi[up ↑][up (up ↑)][up $0..][up ↑][up (up ↑)][up $0..] = phi[$0 .: S >> S >> ↑].
  Proof.
    asimpl. reflexivity.
  Qed.

End Test.


From StorelessMachine Require Import Maps.

Definition varlist := list string.
Definition state := total_map nat.

Definition empty_state : state :=
  t_empty 0.

Inductive aexp : Type :=
| ANum : nat -> aexp
| AId : id -> aexp
| APlus (a1 a2: aexp)
| AMinus (a1 a2: aexp)
| AMul (a1 a2: aexp).

Inductive bexp : Type :=
| BTrue : bexp
| BFalse : bexp
| BEq : aexp -> aexp -> bexp
| BLe : aexp -> aexp -> bexp
| BNot : bexp -> bexp
| BAnd : bexp -> bexp -> bexp.

Inductive com : Type :=
| CSkip
| CAss (x : string) (a : aexp)
| CSeq (c1 c2 : com)
| CIf (b : bexp) (c1 c2 : com)
| CWhile (b : bexp) (c : com).

Definition X := ("X"%string).
Definition Y := ("Y"%string).
Definition Z := ("Z"%string).
Definition W := ("W"%string).

Notation "'SKIP'" :=
  CSkip.
Notation "x '::=' a" :=
  (CAss x a) (at level 60).
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'IFB' c1 'THEN' c2 'ELSE' c3 'FI'" :=
  (CIf c1 c2 c3) (at level 80, right associativity).

Coercion Id : string >-> id.
Coercion AId : id >-> aexp.
Coercion ANum : nat >-> aexp.
Definition bool_to_bexp (b : bool) : bexp :=
  if b then BTrue else BFalse.
Coercion bool_to_bexp : bool >-> bexp.
Bind Scope imp_scope with aexp.
Bind Scope imp_scope with bexp.
Delimit Scope imp_scope with imp.
Notation "x + y" := (APlus x y) (at level 50, left associativity) : imp_scope.
Notation "x - y" := (AMinus x y) (at level 50, left associativity) : imp_scope.
Notation "x * y" := (AMul x y) (at level 40, left associativity) : imp_scope.
Notation "x <= y" := (BLe x y) (at level 70, no associativity) : imp_scope.
Notation "x = y" := (BEq x y) (at level 70, no associativity) : imp_scope.
Notation "x && y" := (BAnd x y) (at level 40, left associativity) : imp_scope.
Notation "'~' b" := (BNot b) (at level 75, right associativity) : imp_scope.
Definition example_aexp := (3 + (X * 2))%imp : aexp.
Definition example_bexp := (true && ~(X <= 4))%imp : bexp.

Inductive instruction: Type :=
| Iconst (n:nat)                (*Push integer 'n' to stack*)
| Iget (i:nat)                  (*push value of the i-th stack slot*)
| Iset (i:nat)                  (*Pop an integer, assign it to the i-th stack slot*)
| Iadd                          (*pop n2, pop n1 and push back n1+n2*)
| Isub                          (*pop n2, pop n1, push back n1-n2*)
| Imul                          (* pop n2, pop n1, push back n1*n2 *)
| Ibranch_forward (ofs:nat)     (*skip ofs instructions forward*)
| Ibranch_backward (ofs:nat)    (*skip ofs instructions backward*)
| Ibeq(ofs:nat)                 (*pop n2, pop n1, skip ofs if n1=n2*)
| Ibne(ofs:nat)                 (*pop n2, pop n1, skip ofs if n1<>n2*)
| Ible(ofs:nat)                 (*pop n2, pop n1, skip ofs if n1<=n2*)
| Ibgt(ofs:nat)                 (*pop n2, pop n1, skip ofs if n1>n2*)
| Ihalt                         (*terminate execution successfully*)
.

Definition code := list instruction.
Definition stack := list nat.
Definition configuration := (nat * stack)%type.

Fixpoint code_at (C:code) (pc: nat) : option instruction :=
  match C, pc with
  | nil, _ => None
  | i::C', O => Some i
  | i::C', S pc' => code_at C' pc'
  end.

Inductive codeseq_at: code -> nat -> code -> Prop :=
  | codeseq_at_intro: forall C1 C2 C3 pc,
      pc = length C1 ->
      codeseq_at (C1 ++ C2 ++ C3) pc C2.

Fixpoint find (var : id) (vlist : varlist) : option nat :=
  match vlist with
  | nil => None
  | u::vlist' => if beq_id (Id u) var then
               Some O
             else
               match find var vlist' with
               | None => None
               | Some n => Some (S n)
               end
  end.

Fixpoint gen_vlist (c:com) (ivlist: varlist): varlist :=
  match c with
  | c1 ;; c2 => let v1 := gen_vlist c1 ivlist in
                gen_vlist c2 v1
  | IFB b THEN c1 ELSE c2 FI => let v1 := gen_vlist c1 ivlist in
                                gen_vlist c2 v1
  | WHILE b DO c1 END => gen_vlist c1 ivlist
  | x ::= a => match find (Id x) ivlist with
                | None => x::ivlist
                | _ => ivlist
                end
  | CSkip => ivlist
  end.

Fixpoint get_nth_slot (stk:stack) (n:nat) : option nat :=
  match stk with
  | nil => None
  | v :: stk' =>
    match n with
    | O => Some v
    | S n' => get_nth_slot stk' n'
    end
  end.

Fixpoint set_nth_slot (stk:stack) (n:nat) (val:nat): option stack :=
  match stk with
  | nil => None
  | s :: stk'  =>
    match n with
    | O => Some (val :: stk')
    | S n' => match set_nth_slot stk' n' val with
              | None => None
              | Some ans => Some (s :: ans)
              end
    end
  end.

Inductive transition (C: code): configuration -> configuration -> Prop :=

| trans_const: forall pc stk n, code_at C pc = Some(Iconst n) ->
                                transition C (pc, stk) (pc + 1, n :: stk)

| trans_get: forall pc stk n v, code_at C pc = Some(Iget n) ->
                                get_nth_slot stk n = Some v ->
                                transition C (pc, stk) (pc + 1, v :: stk)

| trans_set: forall pc stk n v stk', code_at C pc = Some(Iset n) ->
                                     set_nth_slot stk n v = Some stk' ->
                                     transition C (pc, v :: stk) (pc + 1, stk')

| trans_add: forall pc stk n1 n2,  code_at C pc = Some(Iadd) ->
                                   transition C (pc, n2 :: n1 :: stk) (pc + 1, (n1 + n2) :: stk)

| trans_sub: forall pc stk n1 n2, code_at C pc = Some(Isub) ->
                                  transition C (pc, n2 :: n1 :: stk) (pc + 1, (n1 - n2) :: stk)

| trans_mul: forall pc stk n1 n2, code_at C pc = Some(Imul) ->
                                  transition C (pc, n2 :: n1 :: stk) (pc + 1, (n1 * n2) :: stk)

| trans_branch_forward: forall pc stk ofs pc', code_at C pc = Some(Ibranch_forward ofs) ->
                                               pc' = pc + 1 + ofs ->
                                               transition C (pc, stk) (pc', stk)

| trans_branch_backward: forall pc stk ofs pc', code_at C pc = Some(Ibranch_backward ofs) ->
                                                pc' = pc + 1 - ofs ->
                                                transition C (pc, stk) (pc', stk)

| trans_beq: forall pc stk ofs n1 n2 pc', code_at C pc = Some(Ibeq ofs) ->
                                          pc' = (if beq_nat n1 n2 then pc + 1 + ofs else pc + 1) ->
                                          transition C (pc, n2 :: n1 :: stk) (pc', stk)

| trans_bne: forall pc stk ofs n1 n2 pc', code_at C pc = Some(Ibne ofs) ->
                                          pc' = (if beq_nat n1 n2 then pc + 1 else pc + 1 + ofs) ->
                                          transition C (pc, n2 :: n1 :: stk) (pc', stk)

| trans_ble: forall pc stk ofs n1 n2 pc', code_at C pc = Some(Ible ofs) ->
                                          pc' = (if Nat.leb n1 n2 then pc + 1 + ofs else pc + 1) ->
                                          transition C (pc, n2 :: n1 :: stk) (pc', stk)

| trans_bgt: forall pc stk ofs n1 n2 pc', code_at C pc = Some(Ibgt ofs) ->
                                          pc' = (if Nat.leb n1 n2 then pc + 1 else pc + 1 + ofs) ->
                                          transition C (pc, n2 :: n1 :: stk) (pc', stk).


(****************************************************************************)
(*      Logically atomic specification of the Treiber stack algorithm       *)
(*                                                                          *)
(*         by Rodolphe Lepigre (with a lot of help from Ralf Jung)          *)
(*          see https://gitlab.mpi-sws.org/lepigre/treiber_stack            *)
(****************************************************************************)

From iris.program_logic Require Import atomic.
From iris.base_logic.lib Require Import invariants.
From iris.heap_lang Require Import proofmode notation.
From iris.algebra Require Import excl auth list.

(** * Definition of the functions *******************************************)

(** A stack is (physically) represented as a pointer to a linked list. When we
    create a new stack, it initially points to an empty list. And there is, of
    course, no potential race condition here since only the current thread can
    now the value of the freshly allocated pointer. *)
Definition new_stack : val :=
  λ: <>, ref NONEV.

(** To push an element on a stack we remember the old head of the pointed list
    list, create a new cell containing both the element and the old head,  and
    then we perform a CAS (Compare And Set). We thus (atomically) test whether
    the stack still points to the old head, and if that is indeed the case, we
    simultaneously set the stack to point to the newly created cell. Note that
    if the CAS was successful, then the element has been added to the list. If
    it failed, we start over from scratch with a recursive call. *)
Definition push_stack : val :=
  rec: "push" "elt" "stack" :=
    let: "old_head" := !"stack" in
    let: "cell" := ("elt", "old_head") in
    if: CAS "stack" "old_head" (SOME (ref "cell")) then #()
    else "push" "elt" "stack".

(** To pop an element from the stack, we first remember the head of the linked
    list, and then we match on its value. If it is the end of the list (NONE),
    then the function returns NONE. If the list is non-empty, we load the cell
    containing both: the head element and the pointer to the tail of the list.
    We then perform a CAS: if the stack still points to the (previous) head of
    the list, then we set it to point to the tail. If the CAS is successful we
    return the element (wrapped in a SOME). Otherwise we start over. Note that
    in the case where the pointed list is empty the linearization point occurs
    on the first access to the stack. Otherwise it occurs at the CAS. *)
Definition pop_stack : val :=
  rec: "pop" "stack" :=
    let: "old_top" := !"stack" in
    match: "old_top" with
      NONE     => NONE
    | SOME "p" =>
       let: "cell" := !"p" in
       if: CAS "stack" "old_top" (Snd "cell") then SOME (Fst "cell")
       else "pop" "stack"
    end.

(** * Definition of the required camera *************************************)

Class stackG Σ := StackG {
  stack_tokG :> inG Σ (authR (optionUR (exclR (listO valO)))) }.

Definition stackΣ : gFunctors :=
  #[GFunctor (authR (optionUR (exclR (listO valO))))].

Instance subG_stackΣ {Σ} : subG stackΣ Σ → stackG Σ.
Proof. solve_inG. Qed.

(* Put some things in the context. *)
Section treiber_stack.
Context `{!heapG Σ, !stackG Σ}.
Context (N : namespace).
Notation iProp := (iProp Σ).

(** * Representation relations and invariant used in the specification ******)

(** Utility function injecting (optional) locations into values. *)
Definition to_val (lopt : option loc) : val :=
  match lopt with
  | None   => NONEV
  | Some ℓ => SOMEV #ℓ
  end%I.

(** Representation relation for lists: the (optional) location [lopt] (in fact
    [to_val lopt]) physically represents the (Coq) list [xs]. *)
Fixpoint phys_list (lopt : option loc) (xs : list val) : iProp :=
  match (lopt, xs) with
  | (None  , []     ) => True
  | (None  , _ :: _ ) => False
  | (Some _, []     ) => False
  | (Some ℓ, x :: xs) => ∃r q, ℓ ↦{q} (x, to_val r) ∗ phys_list r xs
  end%I.

(** Representation relation for stacks: the location [ℓ] physically represents
    a stack whose elements are those of [xs]. More precisely, [ℓ] is a pointer
    to a linked list, representing [xs]. *)
Definition phys_stack (ℓ : loc) (xs : list val) : iProp :=
  (∃ r, ℓ ↦ to_val r ∗ phys_list r xs)%I.

(** Statement of the invariant maintained for a stack pointed to by (location)
    [ℓ], and uniquely identified by the global name [γ]. Intuitively, there is
    a coq list [xs] such that [ℓ] physically represents [xs], and the value of
    [xs] is stored in ghost state whose authoritative  part  is  (exclusively)
    owned by the invariants.  This always keeps the ghost state in  sync  with
    the physical state, meaning that the ownership of a fragment [own γ (◯ _)]
    actually becomes meaningful to make statements about the list because both
    are tied together by this invariant. *)
Definition stack_inv (ℓ : loc) (γ : gname) : iProp :=
  (∃ xs, phys_stack ℓ xs ∗ own γ (● (Some ((Excl xs)))))%I.

(** Invariant assertion for a stack pointed to by [ℓ], and uniquely identified
    by the global name [γ].  Note that the namespace [N] is quantified over in
    the whole section. It can thus be instantiated to fit any particular need,
    when using this module as a library. *)
Definition is_stack (ℓ : loc) (γ : gname) : iProp :=
  inv N (stack_inv ℓ γ).

(** Local view of the contents [xs] of the stack that is (uniquely) identified
    by the global name [γ]. Note that this proposition is independent from the
    particular location at which the stack is stored,  which can only be owned
    by one particular thread at a time. *)
Definition stack_cont (γ : gname) (xs : list val) : iProp :=
  (own γ (◯ (Some ((Excl xs)))))%I.

(** * Useful lemmas and typeclass instances *********************************)

(** Injectivity of [to_val]. *)
Instance to_val_inj : Inj (=) (=) to_val.
Proof.
  intros l1 l2 H. case l1, l2; try done. inversion H. reflexivity.
Qed.

(** Duplicability of the [phys_list] relation. *)
Lemma phys_list_dup l xs : phys_list l xs -∗ phys_list l xs ∗ phys_list l xs.
Proof.
  iInduction xs as [|x xs] "IH" forall (l); destruct l as [l|]; try done.
  simpl. iIntros "H".
  iDestruct "H" as (r q) "[[Hl1 Hl2] HPhys]".
  iDestruct ("IH" with "HPhys") as "[HPhys1 HPhys2]".
  iSplitL "Hl1 HPhys1"; eauto with iFrame.
Qed.

(** Timelessness of the [phys_list] relation. *)
Global Instance phys_list_timeless l xs : Timeless (phys_list l xs).
Proof.
  revert l. induction xs; apply _.
Qed.

(** The following two lemmas have been borrowed from the POPL 18 Iris tutorial
    (see https://gitlab.mpi-sws.org/iris/tutorial-popl18). *)

(** The view of the authority agrees with the local view. *)
Lemma auth_agree γ xs ys :
  own γ (● (Excl' xs)) -∗ own γ (◯ (Excl' ys)) -∗ ⌜xs = ys⌝.
Proof.
  iIntros "Hγ● Hγ◯". by iDestruct (own_valid_2 with "Hγ● Hγ◯")
    as %[<-%Excl_included%leibniz_equiv _]%auth_both_valid.
Qed.

(** The view of the authority can be updated together with the local view. *)
Lemma auth_update γ ys xs1 xs2 :
  own γ (● (Excl' xs1)) -∗ own γ (◯ (Excl' xs2)) ==∗
    own γ (● (Excl' ys)) ∗ own γ (◯ (Excl' ys)).
Proof.
  iIntros "Hγ● Hγ◯".
  iMod (own_update_2 _ _ _ (● Excl' ys ⋅ ◯ Excl' ys)
    with "Hγ● Hγ◯") as "[$$]".
  { by apply auth_update, option_local_update, exclusive_local_update. }
  done.
Qed.

(** * Automation hints for [eauto] ******************************************)

(** The following hints allow [eauto] to work with the above definitions. When
    a simple goal involving only framing and the instantiation of existentials
    is encoutered, we can usually conclude with [eauto with iFrame]. The hints
    are mainly useful for unfolding definitions and instantiating existentials
    with a reasonable choice of head constructor. *)

Local Hint Extern 0 (environments.envs_entails _
  (phys_stack _ [])) => iExists None : core.

Local Hint Extern 0 (environments.envs_entails _
  (phys_stack _ (_ :: _))) => iExists (Some _) : core.

Local Hint Extern 10 (environments.envs_entails _
  (phys_stack _ _)) => unfold phys_stack : core.

Local Hint Extern 0 (environments.envs_entails _
  (stack_inv _ _)) => unfold stack_inv : core.

Local Hint Extern 0 (environments.envs_entails _
  (phys_list None [])) => simpl : core.

Local Hint Extern 0 (environments.envs_entails _
  (phys_list (Some _) (_ :: _))) => simpl : core.

(** * Specification *********************************************************)

(** The specification of [new_stack] is straightforward: with no precondition,
    the creation of a new stack yields a location that is pointing to a stack,
    and it is initially empty. The only interesting thing to note here is that
    an existential quantifier is used in the postcondition to obtain a (fresh)
    name [γ] for the created stack. This ensures that different stacks will be
    given different names. *)
Lemma new_stack_spec :
  {{{ True }}}
    new_stack #()
  {{{ ℓ γ, RET #ℓ; is_stack ℓ γ ∗ stack_cont γ [] }}}.
Proof.
  (* Introduce things into the Coq and Iris contexts. Throw away the [True]
     precondition. *)
  iIntros (Φ) "_ HΦ".
  (* We introduce the fancy update modality in our WP (necessary later). *)
  iApply wp_fupd.
  (* We step through the program: β-reduce and allocate a location [ℓ]. *)
  wp_lam. wp_alloc ℓ as "Hl". (* We have full ownership of [ℓ] in [Hl]. *)
  (* We now need to establish the invariant. First, we allocate an instance of
     our camera named [γ], containing the empty list. This step (and the next)
     requires the fancy update modality that was introduced earlier. *)
  iMod (own_alloc (● (Some (Excl [])) ⋅ ◯ (Some (Excl []))))
    as (γ) "[Hγ● Hγ◯]";
    (* Validity is trivial. *) first by apply auth_both_valid.
  (* We can then allocate the invariant (with mask [N]).  Note that we can use
     [eauto 10 with iFrame] to prove [▷ stack_inv ℓ γ]. *)
  iMod (inv_alloc N _ (stack_inv ℓ γ) with "[Hl Hγ●]")
    as "#Inv"; first eauto 10 with iFrame.
  (* We can now eliminate the modality and establish the postcondition. *)
  iModIntro. iApply "HΦ". eauto with iFrame.
Qed.

(** The specification of [push_stack] depends on a location [ℓ] and a name [γ]
    assumed to correspond to a stack (created using [new_stack]),  and a value
    [v] that is being pushed. A logically atomic Hoare triple is used in order
    to ensure linearizability (i.e., the existence of a linearization point in
    the execution of the push operation). As a consequence the precondition of
    the triple can only be accessed during a physically atomic operation,  and
    the knowledge gained must then either be forgotten (abort operation) or it
    should lead to a one shot update (commit operation) during the same atomic
    operation where the precondition was accessed. In this second case we lose
    the possibility of accessing the precondition again, unlike with abort. *)
Lemma push_stack_spec (ℓ : loc) (γ : gname) (v : val) :
  is_stack ℓ γ -∗
  <<< ∀ (xs : list val), stack_cont γ xs >>>
    push_stack v #ℓ @ ⊤ ∖ ↑N
  <<< stack_cont γ (v :: xs) , RET #() >>>.
Proof.
  (* Introduce things into the Coq and Iris contexts, and use induction. *)
  iIntros "#HInv" (Φ) "AU". iLöb as "IH".
  (* Evaluate the first steps of the program, and focus on the load. *)
  wp_lam. wp_let. wp_bind (! _)%E.
  (* Since an atomic operation is in focus we can access the invariant. Hence,
     we will be able to learn that [ℓ] actually points to something. *)
  iInv "HInv" as (xs) ">[HPhys Hγ●]".
  unfold phys_stack. iDestruct "HPhys" as (w) "[Hl HPhys]".
  (* We can now perform the load, and get rid of the modality. *)
  wp_load. iModIntro. iSplitL "Hl Hγ● HPhys"; first by eauto 10 with iFrame.
  (* We then resume stepping through the program, and focus on the CAS. *)
  wp_alloc r as "Hr". wp_inj. wp_bind (CmpXchg _ _ _)%E.
  (* Now, we need to use the invariant again to gain information on [ℓ]. *)
  iInv "HInv" as (ys) ">[HPhys Hγ●]". iDestruct "HPhys" as (u) "[Hl HPhys]".
  (* We now reason by case on the success/failure of the CAS. *)
  destruct (decide (u = w)) as [[= ->]|NE].
  - (* The CAS succeeded. *)
    wp_cmpxchg_suc. { case w; left; done. (* Administrative stuff. *) }
    (* This was the linearization point. We access the preconditon. *)
    iMod "AU" as (zs) "[Hγ◯ [_ HClose]]".
    (* Use agreement on ressource [γ] to learn [zs = ys]. *)
    iDestruct (auth_agree with "Hγ● Hγ◯") as %->.
    (* Update the value of [γ] to [v::zs]. *)
    iMod (auth_update γ (v::zs) with "Hγ● Hγ◯") as "[Hγ● Hγ◯]".
    (* Commit operation. *)
    iMod ("HClose" with "Hγ◯") as "H".
    (* We can eliminate the modality. *)
    iModIntro. iSplitR "H"; first by eauto 10 with iFrame.
    (* And conclude the proof easily, after some computation steps. *)
    wp_pures. iExact "H".
  - (* The CAS failed. *)
    wp_cmpxchg_fail. { exact: not_inj.  }
    { case u, w; simpl; eauto. (* Administrative stuff. *) }
    (* We can eliminate the modality. *)
    iModIntro. iSplitL "Hγ● Hl HPhys"; first by eauto 10 with iFrame.
    (* And conclude the proof by induction hypothesis. *)
    wp_pures. iApply "IH". iExact "AU".
Qed.

(** As for [push_stack] the specification of [pop_stack] depends on a location
    [ℓ] and a name [γ] (corresponding to some stack). A logically atomic Hoare
    triple is again used to ensure linearizability, but it must be accessed in
    a slightly more complicated way. In particular, the linearization point is
    not in the same place depending on the emptiness of the stack.  Of course,
    the postcondition also depends on the emptiness of the stack. *)
Lemma pop_stack_spec (ℓ : loc) (γ : gname) :
  is_stack ℓ γ -∗
  <<< ∀ (xs : list val), stack_cont γ xs >>>
    pop_stack #ℓ @ ⊤ ∖ ↑N
  <<< stack_cont γ (match xs with [] => [] | _::xs => xs end)
    , RET (match xs with [] => NONEV | v::_ => SOMEV v end) >>>.
Proof.
  (* As for [push_stack], we need to use induction and the focus on a load. *)
  iIntros "#HInv" (Φ) "AU". iLöb as "IH". wp_lam. wp_bind (! _)%E.
  (* We can then use the invariant to be able to perform the load. *)
  iInv "HInv" as (xs) ">[HPhys Hγ●]".
  iDestruct "HPhys" as (w) "[Hl HPhys]". wp_load.
  (* We now duplicate [phys_list w xs] as we will need two copies. *)
  iDestruct (phys_list_dup with "HPhys") as "[HPhys1 HPhys2]".
  (* We then inspect the contents of the stack and the optional location. They
     must agree, otherwise the proof is trivial. *)
  destruct w as [w|], xs as [|x xs]; try done; simpl.
  - (* The stack is non-empty, we eliminate the modality. *)
    iModIntro. iSplitL "Hl Hγ● HPhys1"; first by eauto 10 with iFrame.
    (* We continue stepping through the program, and focus on the CAS. *)
    wp_let. wp_match. iDestruct "HPhys2" as (r q) "[Hw HP]".
    wp_load. wp_let. wp_proj. wp_bind (CmpXchg _ _ _)%E.
    (* We need to use the invariant again to gain information on [ℓ]. *)
    iInv "HInv" as (ys) ">[H Hγ●]".
    unfold phys_stack. iDestruct "H" as (u) "[Hl HPhys]".
    (* We get rid of useless hypotheses to cleanup the context. *)
    iClear "HP". clear xs.
    (* We reason by case on the success/failure of the CAS. *)
    destruct (decide (u = Some w)) as [[= ->]|Hx].
    * (* The CAS succeeded, so this is the linearization point. *)
      wp_cmpxchg_suc.
      (* The list [ys] must be non-empty, otherwise the proof is trivial. *)
      destruct ys; first done.
      (* We access the precondition, prior to performing an update. *)
      iMod "AU" as (zs) "[Hγ◯ [_ HClose]]". unfold stack_cont.
      (* Use agreement on ressource [γ] to learn [v :: ys = zs]. *)
      iDestruct (auth_agree with "Hγ● Hγ◯") as %<-.
      (* Update the value of [γ] to [ys] (the tail of previous value). *)
      iMod (auth_update γ ys with "Hγ● Hγ◯") as "[Hγ● Hγ◯]".
      (* We need to learn that [r = u] (true since mapsto must agree). *)
      iDestruct "HPhys" as (u q') "[Hw' HPhys]".
      iDestruct (mapsto_agree with "Hw Hw'") as %[=-> ->%to_val_inj].
      (* Perform the commit. *)
      iMod ("HClose" with "Hγ◯") as "HΦ".
      (* Eliminate the modality. *)
      iModIntro. iSplitR "HΦ"; first by eauto 10 with iFrame.
      (* And conclude the proof. *)
      wp_pures. iExact "HΦ".
    * (* The CAS failed. *)
      wp_cmpxchg_fail. { intro H. apply Hx. destruct u; inversion H; done. }
      (* We can eliminate the modality. *)
      iModIntro. iSplitR "AU"; first by eauto 10 with iFrame.
      (* And conclude the proof using the induction hypothesis. *)
      wp_pures. iApply "IH". iExact "AU".
  - (* The stack is empty, the load was the linearization point,  we can hence
       commit (without updating the stack). So we access the precondition. *)
    iClear "HPhys1 HPhys2". iMod "AU" as (xs) "[Hγ◯ [_ HClose]]".
    (* Thanks to agreement, we learn that [xs] must be the empty list. *)
    iDestruct (auth_agree with "Hγ● Hγ◯") as %<-.
    (* And we can commit (we are still at the linearization point). *)
    iMod ("HClose" with "Hγ◯") as "HΦ".
    (* We finally eliminate the modality and conclude the proof by taking some
       computation steps, and using our hypothesis. *)
    iModIntro. iSplitR "HΦ"; first by eauto 10 with iFrame.
    wp_pures. iExact "HΦ".
Qed.

End treiber_stack.

(** Make the exported Iris terms "Typeclass Opaque", so that clients using the
    library won't look into these definitions. *)
Typeclasses Opaque is_stack stack_cont.