(** Interpretation of polynomials in groupoids *)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Groupoids.

Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Base.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Map1Cells.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Map2Cells.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Identitor.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Compositor.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.Notations.

Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity.
Require Import UniMath.Bicategories.Core.Examples.OneTypes.

Require Import prelude.all.
Require Import signature.hit_signature.

Local Open Scope cat.

(** Action of polynomials on groupoids *)
Definition poly_act_rel
           (P : poly_code)
           {X : UU}
           (R : X → X → UU)
  : poly_act P X → poly_act P X → UU.
Proof.
  induction P as [A | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂].
  - exact (λ a b, a = b).
  - exact (λ x y, R x y).
  - intros x y.
    induction x as [x | x], y as [y | y].
    + exact (IHP₁ x y).
    + exact ∅.
    + exact ∅.
    + exact (IHP₂ x y).
  - exact (λ x y, IHP₁ (pr1 x) (pr1 y) × IHP₂ (pr2 x) (pr2 y)).
Defined.

Definition poly_act_rel_identity
           (P : poly_code)
           {X : UU}
           (R : X → X → UU)
           (r : ∏ (x : X), R x x)
           (x : poly_act P X)
  : poly_act_rel P R x x.
Proof.
  induction P as [A | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂].
  - exact (idpath x).
  - exact (r x).
  - induction x as [x | x].
    + exact (IHP₁ x).
    + exact (IHP₂ x).
  - exact (IHP₁ (pr1 x) ,, IHP₂ (pr2 x)).
Defined.

Definition poly_act_rel_inv
           (P : poly_code)
           {X : UU}
           (R : X → X → UU)
           (i : ∏ (x y : X), R x y → R y x)
           {x y : poly_act P X}
           (r : poly_act_rel P R x y)
  : poly_act_rel P R y x.
Proof.
  induction P as [A | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂].
  - exact (! r).
  - exact (i _ _ r).
  - induction x as [x | x], y as [y | y].
    + exact (IHP₁ _ _ r).
    + exact (fromempty r).
    + exact (fromempty r).
    + exact (IHP₂ _ _ r).
  - exact (IHP₁ _ _ (pr1 r) ,, IHP₂ _ _ (pr2 r)).
Defined.

Definition poly_act_rel_comp
           (P : poly_code)
           {X : UU}
           (R : X → X → UU)
           (c : ∏ (x y z : X), R x y → R y z → R x z)
           {x y z : poly_act P X}
           (r₁ : poly_act_rel P R x y)
           (r₂ : poly_act_rel P R y z)
  : poly_act_rel P R x z.
Proof.
  induction P as [A | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂].
  - exact (r₁ @ r₂).
  - exact (c _ _ _ r₁ r₂).
  - induction x as [x | x], y as [y | y].
    + induction z as [z | z].
      * exact (IHP₁ _ _ _ r₁ r₂).
      * exact (fromempty r₂).
    + exact (fromempty r₁).
    + exact (fromempty r₁).
    + induction z as [z | z].
      * exact (fromempty r₂).
      * exact (IHP₂ _ _ _ r₁ r₂).
  - exact (IHP₁ _ _ _ (pr1 r₁) (pr1 r₂) ,, IHP₂ _ _ _ (pr2 r₁) (pr2 r₂)).
Defined.

Definition poly_act_morphism
           (P : poly_code)
           (G : groupoid)
  : poly_act P G → poly_act P G → UU
  := poly_act_rel P (@precategory_morphisms G).

Definition poly_act_identity
           {P : poly_code}
           {G : groupoid}
  : ∏ (x : poly_act P G), poly_act_morphism P G x x
  := poly_act_rel_identity P (@precategory_morphisms G) identity.

Definition poly_act_inverse
           {P : poly_code}
           {G : groupoid}
  : ∏ {x y : poly_act P G},
    poly_act_morphism P G x y → poly_act_morphism P G y x
  := @poly_act_rel_inv
       P
       _
       (@precategory_morphisms G)
       (λ _ _ f, inv_from_z_iso (make_z_iso _ _ (pr2 G _ _ f))).

Definition poly_act_compose
           {P : poly_code}
           {G : groupoid}
  : ∏ {x y z : poly_act P G},
    poly_act_morphism P G x y
    → poly_act_morphism P G y z
    → poly_act_morphism P G x z
  := @poly_act_rel_comp
       P
       _
       (@precategory_morphisms G)
       (λ _ _ _ f g, f · g).

Definition poly_act_id_right
           {P : poly_code}
           {G : groupoid}
           {x y : poly_act P G}
           (f : poly_act_morphism P G x y)
  : poly_act_compose f (poly_act_identity y) = f.
Proof.
  induction P as [A | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂].
  - apply pathscomp0rid.
  - apply id_right.
  - induction x as [x | x], y as [y | y].
    + exact (IHP₁ x y f).
    + induction f.
    + induction f.
    + exact (IHP₂ x y f).
  - exact (pathsdirprod (IHP₁ _ _ (pr1 f)) (IHP₂ _ _ (pr2 f))).
Qed.

Definition poly_act_id_left
           {P : poly_code}
           {G : groupoid}
           {x y : poly_act P G}
           (f : poly_act_morphism P G x y)
  : poly_act_compose (poly_act_identity x) f = f.
Proof.
  induction P as [A | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂].
  - apply idpath.
  - apply id_left.
  - induction x as [x | x], y as [y | y].
    + exact (IHP₁ x y f).
    + induction f.
    + induction f.
    + exact (IHP₂ x y f).
  - exact (pathsdirprod (IHP₁ _ _ (pr1 f)) (IHP₂ _ _ (pr2 f))).
Qed.

Definition poly_act_assoc
           {P : poly_code}
           {G : groupoid}
           {w x y z : poly_act P G}
           (f : poly_act_morphism P G w x)
           (g : poly_act_morphism P G x y)
           (h : poly_act_morphism P G y z)
  : poly_act_compose f (poly_act_compose g h)
    =
    poly_act_compose (poly_act_compose f g) h.
Proof.
  induction P as [A | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂].
  - apply path_assoc.
  - apply assoc.
  - induction w as [w | w], x as [x | x].
    + induction y as [y | y].
      * induction z as [z | z].
        ** exact (IHP₁ w x y z f g h).
        ** induction h.
      * induction g.
    + induction f.
    + induction f.
    + induction y as [y | y].
      * induction g.
      * induction z as [z | z].
        ** induction h.
        ** exact (IHP₂ w x y z f g h).
  - exact (pathsdirprod
             (IHP₁ _ _ _ _ (pr1 f) (pr1 g) (pr1 h))
             (IHP₂ _ _ _ _ (pr2 f) (pr2 g) (pr2 h))).
Qed.

Definition poly_act_inv_right
           {P : poly_code}
           {G : groupoid}
           {x y : poly_act P G}
           (f : poly_act_morphism P G x y)
  : poly_act_compose f (poly_act_inverse f)
    =
    poly_act_identity x.
Proof.
  induction P as [A | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂].
  - apply pathsinv0r.
  - exact (z_iso_inv_after_z_iso (make_z_iso f _ (pr2 G x y f))).
  - induction x as [x | x], y as [y | y].
    + exact (IHP₁ x y f).
    + induction f.
    + induction f.
    + exact (IHP₂ x y f).
  - exact (pathsdirprod (IHP₁ _ _ (pr1 f)) (IHP₂ _ _ (pr2 f))).
Qed.

Definition poly_act_inv_left
           {P : poly_code}
           {G : groupoid}
           {x y : poly_act P G}
           (f : poly_act_morphism P G x y)
  : poly_act_compose (poly_act_inverse f) f
    =
    poly_act_identity y.
Proof.
  induction P as [A | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂].
  - apply pathsinv0l.
  - exact (z_iso_after_z_iso_inv (make_z_iso f _ (pr2 G x y f))).
  - induction x as [x | x], y as [y | y].
    + exact (IHP₁ x y f).
    + induction f.
    + induction f.
    + exact (IHP₂ x y f).
  - exact (pathsdirprod (IHP₁ _ _ (pr1 f)) (IHP₂ _ _ (pr2 f))).
Qed.

Definition poly_act_isaset_mor
           {P : poly_code}
           {G : groupoid}
  : ∏ (x y : poly_act P G), isaset (poly_act_morphism P G x y).
Proof.
  intros x y.
  induction P as [A | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂].
  - exact (one_type_isofhlevel A x y).
  - exact (homset_property G x y).
  - induction x as [x | x], y as [y | y].
    + exact (IHP₁ x y).
    + exact isasetempty.
    + exact isasetempty.
    + exact (IHP₂ x y).
  - exact (isasetdirprod _ _ (IHP₁ (pr1 x) (pr1 y)) (IHP₂ (pr2 x) (pr2 y))).
Qed.

Definition poly_act_groupoid
           (P : poly_code)
           (G : groupoid)
  : groupoid.
Proof.
  use make_grpd_bicat.
  - exact (poly_act P (pr1 G)).
  - exact (poly_act_morphism P G).
  - exact (@poly_act_identity P G).
  - exact (@poly_act_inverse P G).
  - exact (@poly_act_compose P G).
  - exact (@poly_act_id_right P G).
  - exact (@poly_act_id_left P G).
  - exact (@poly_act_assoc P G).
  - exact (@poly_act_inv_right P G).
  - exact (@poly_act_inv_left P G).
  - exact (@poly_act_isaset_mor P G).
Defined.

(** Action of polynomials on functors *)
Definition poly_act_functor_morphisms
           (P : poly_code)
           {G₁ G₂ : groupoid}
           (F : G₁ ⟶ G₂)
           {x y : poly_act P G₁}
  : poly_act_morphism P G₁ x y
    →
    poly_act_morphism P G₂ (poly_map P F x) (poly_map P F y).
Proof.
  induction P as [A | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂].
  - exact (λ p, p).
  - exact (λ f, #F f).
  - induction x as [x | x], y as [y | y].
    + exact (IHP₁ x y).
    + exact fromempty.
    + exact fromempty.
    + exact (IHP₂ x y).
  - exact (λ f, IHP₁ _ _ (pr1 f) ,, IHP₂ _ _ (pr2 f)).
Defined.

Definition poly_act_functor_data
           (P : poly_code)
           {G₁ G₂ : groupoid}
           (F : G₁ ⟶ G₂)
  : functor_data (poly_act_groupoid P G₁) (poly_act_groupoid P G₂).
Proof.
  use make_functor_data.
  - exact (poly_map P F).
  - exact (@poly_act_functor_morphisms P _ _ F).
Defined.

Definition poly_act_functor_is_functor
           (P : poly_code)
           {G₁ G₂ : groupoid}
           (F : G₁ ⟶ G₂)
  : is_functor (poly_act_functor_data P F).
Proof.
  split.
  - intros x.
    induction P as [A | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂].
    + exact (idpath _).
    + exact (functor_id F x).
    + induction x as [x | x].
      * exact (IHP₁ x).
      * exact (IHP₂ x).
    + exact (pathsdirprod (IHP₁ (pr1 x)) (IHP₂ (pr2 x))).
  - intros x y z.
    induction P as [A | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂].
    + exact (λ f g, idpath _).
    + exact (functor_comp F).
    + induction x as [x | x], y as [y | y].
      * induction z as [z | z].
        ** exact (IHP₁ x y z).
        ** intros f g ; induction g.
      * intro f ; induction f.
      * intro f ; induction f.
      * induction z as [z | z].
        ** intros f g ; induction g.
        ** exact (IHP₂ x y z).
    + exact (λ f g, pathsdirprod
                      (IHP₁ _ _ _ (pr1 f) (pr1 g))
                      (IHP₂ _ _ _ (pr2 f) (pr2 g))).
Qed.

Definition poly_act_functor
           (P : poly_code)
           {G₁ G₂ : groupoid}
           (F : G₁ ⟶ G₂)
  : poly_act_groupoid P G₁ ⟶ poly_act_groupoid P G₂.
Proof.
  use make_functor.
  - exact (@poly_act_functor_data P G₁ G₂ F).
  - exact (@poly_act_functor_is_functor P G₁ G₂ F).
Defined.

(** Action of polynomials on natural transformations *)
Definition poly_act_nat_trans_data_help
           (P : poly_code)
           {X : UU} {G : groupoid}
           {f g : X → G}
           (α : ∏ (x : X), G ⟦ f x , g x ⟧)
  : ∏ (x : poly_act P X),
    poly_act_morphism P G (poly_map P f x) (poly_map P g x).
Proof.
  intro x.
  induction P as [A | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂].
  - exact (idpath x).
  - exact (α x).
  - induction x as [x | x].
    + exact (IHP₁ x).
    + exact (IHP₂ x).
  - exact (IHP₁ (pr1 x) ,, IHP₂ (pr2 x)).
Defined.

Definition poly_act_nat_trans_data
           (P : poly_code)
           {G₁ G₂ : groupoid}
           {F₁ F₂ : G₁ ⟶ G₂}
           (α : F₁ ⟹ F₂)
  : nat_trans_data (poly_act_functor P F₁) (poly_act_functor P F₂).
Proof.
  exact (poly_act_nat_trans_data_help P α).
Defined.

Definition poly_act_nat_trans_is_nat_trans
           (P : poly_code)
           {G₁ G₂ : groupoid}
           {F₁ F₂ : G₁ ⟶ G₂}
           (α : F₁ ⟹ F₂)
  : is_nat_trans _ _ (poly_act_nat_trans_data P α).
Proof.
  intros x y.
  induction P as [A | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂].
  - exact pathscomp0rid.
  - exact (λ f, pr2 α _ _ f).
  - induction x as [x | x], y as [y | y].
    + exact (IHP₁ x y).
    + intro f ; induction f.
    + intro f ; induction f.
    + exact (IHP₂ x y).
  - exact (λ f, pathsdirprod (IHP₁ _ _ (pr1 f)) (IHP₂ _ _ (pr2 f))).
Qed.

Definition poly_act_nat_trans
           (P : poly_code)
           {G₁ G₂ : groupoid}
           {F₁ F₂ : G₁ ⟶ G₂}
           (α : F₁ ⟹ F₂)
  : poly_act_functor P F₁ ⟹ poly_act_functor P F₂.
Proof.
  use make_nat_trans.
  - exact (poly_act_nat_trans_data P α).
  - exact (poly_act_nat_trans_is_nat_trans P α).
Defined.

(** Action on identity *)
Definition poly_act_functor_identity_data
           (P : poly_code)
           (G : groupoid)
  : nat_trans_data
      (functor_identity (poly_act_groupoid P G))
      (poly_act_functor P (functor_identity G)).
Proof.
  induction P as [A | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂].
  - exact idpath.
  - exact identity.
  - intro x ; induction x as [x | x].
    + exact (IHP₁ x).
    + exact (IHP₂ x).
  - exact (λ x, IHP₁ (pr1 x) ,, IHP₂ (pr2 x)).
Defined.

Definition poly_act_functor_identity_is_nat_trans
           (P : poly_code)
           (G : groupoid)
  : is_nat_trans _ _ (poly_act_functor_identity_data P G).
Proof.
  intros x y.
  induction P as [A | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂].
  - exact pathscomp0rid.
  - exact (λ f, id_right f @ !(id_left f)).
  - induction x as [x | x], y as [y | y].
    + exact (IHP₁ x y).
    + intro f ; induction f.
    + intro f ; induction f.
    + exact (IHP₂ x y).
  - exact (λ f, pathsdirprod (IHP₁ _ _ (pr1 f)) (IHP₂ _ _ (pr2 f))).
Qed.

Definition poly_act_functor_identity
           (P : poly_code)
           (G : groupoid)
  : (functor_identity (poly_act_groupoid P G))
      ⟹
      poly_act_functor P (functor_identity G).
Proof.
  use make_nat_trans.
  - exact (poly_act_functor_identity_data P G).
  - exact (poly_act_functor_identity_is_nat_trans P G).
Defined.

(** Action on composition *)
Definition poly_act_functor_composition_data
           (P : poly_code)
           {G₁ G₂ G₃ : groupoid}
           (F₁ : G₁ ⟶ G₂) (F₂ : G₂ ⟶ G₃)
  : nat_trans_data
      (poly_act_functor P F₁ ∙ poly_act_functor P F₂)
      (poly_act_functor P (F₁ ∙ F₂)).
Proof.
  intro x.
  induction P as [A | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂].
  - exact (idpath x).
  - exact (identity _).
  - induction x as [x | x].
    + exact (IHP₁ x).
    + exact (IHP₂ x).
  - exact (IHP₁ (pr1 x) ,, IHP₂ (pr2 x)).
Defined.

Definition poly_act_functor_composition_is_nat_trans
           (P : poly_code)
           {G₁ G₂ G₃ : groupoid}
           (F₁ : G₁ ⟶ G₂) (F₂ : G₂ ⟶ G₃)
  : is_nat_trans _ _ (poly_act_functor_composition_data P F₁ F₂).
Proof.
  intros x y.
  induction P as [A | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂].
  - exact pathscomp0rid.
  - exact (λ f, id_right _ @ !(id_left _)).
  - induction x as [x | x], y as [y | y].
    + exact (IHP₁ x y).
    + intro f ; induction f.
    + intro f ; induction f.
    + exact (IHP₂ x y).
  - exact (λ f, pathsdirprod (IHP₁ _ _ (pr1 f)) (IHP₂ _ _ (pr2 f))).
Qed.

Definition poly_act_functor_composition
           (P : poly_code)
           {G₁ G₂ G₃ : groupoid}
           (F₁ : G₁ ⟶ G₂) (F₂ : G₂ ⟶ G₃)
  : (poly_act_functor P F₁ ∙ poly_act_functor P F₂)
      ⟹
      poly_act_functor P (F₁ ∙ F₂).
Proof.
  use make_nat_trans.
  - exact (poly_act_functor_composition_data P F₁ F₂).
  - exact (poly_act_functor_composition_is_nat_trans P F₁ F₂).
Defined.

(** Putting it all together *)
Definition sem_poly_grpd_data
           (P : poly_code)
  : psfunctor_data grpd_bicat grpd_bicat.
Proof.
  use make_psfunctor_data.
  - exact (poly_act_groupoid P).
  - exact (@poly_act_functor P).
  - exact (@poly_act_nat_trans P).
  - exact (@poly_act_functor_identity P).
  - exact (@poly_act_functor_composition P).
Defined.

Definition sem_poly_grpd_laws
           (P : poly_code)
  : psfunctor_laws (sem_poly_grpd_data P).
Proof.
  repeat split ; induction P as [A | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂].
  - intros G₁ G₂ F.
    use nat_trans_eq.
    { apply homset_property. }
    intro.
    apply idpath.
  - intros G₁ G₂ F.
    use nat_trans_eq.
    { apply homset_property. }
    intro.
    apply idpath.
  - intros G₁ G₂ F.
    use nat_trans_eq.
    { apply homset_property. }
    intro x.
    induction x as [x | x].
    + exact (nat_trans_eq_pointwise (IHP₁ _ _ _) x).
    + exact (nat_trans_eq_pointwise (IHP₂ _ _ _) x).
  - intros G₁ G₂ F.
    use nat_trans_eq.
    { apply homset_property. }
    intro x.
    exact (pathsdirprod
              (nat_trans_eq_pointwise (IHP₁ _ _ _) (pr1 x))
              (nat_trans_eq_pointwise (IHP₂ _ _ _) (pr2 x))).
  - intros G₁ G₂ F₁ F₂ F₃ α β.
    use nat_trans_eq.
    { apply homset_property. }
    intro.
    apply idpath.
  - intros G₁ G₂ F₁ F₂ F₃ α β.
    use nat_trans_eq.
    { apply homset_property. }
    intro.
    apply idpath.
  - intros G₁ G₂ F₁ F₂ F₃ α β.
    use nat_trans_eq.
    { apply homset_property. }
    intro x.
    induction x as [x | x].
    + exact (nat_trans_eq_pointwise (IHP₁ _ _ _ _ _ _ _) x).
    + exact (nat_trans_eq_pointwise (IHP₂ _ _ _ _ _ _ _) x).
  - intros G₁ G₂ F₁ F₂ F₃ α β.
    use nat_trans_eq.
    { apply homset_property. }
    intro x.
    exact (pathsdirprod
             (nat_trans_eq_pointwise (IHP₁ _ _ _ _ _ _ _) (pr1 x))
             (nat_trans_eq_pointwise (IHP₂ _ _ _ _ _ _ _) (pr2 x))).
  - intros G₁ G₂ F.
    use nat_trans_eq.
    { apply homset_property. }
    intro.
    apply idpath.
  - intros G₁ G₂ F.
    use nat_trans_eq.
    { apply homset_property. }
    intro x.
    refine (!_).
    exact (id_right _ @ id_right _ @ functor_id _ _).
  - intros G₁ G₂ F.
    use nat_trans_eq.
    { apply homset_property. }
    intro x.
    induction x as [x | x].
    + exact (nat_trans_eq_pointwise (IHP₁ _ _ _) x).
    + exact (nat_trans_eq_pointwise (IHP₂ _ _ _) x).
  - intros G₁ G₂ F.
    use nat_trans_eq.
    { apply homset_property. }
    intro x.
    exact (pathsdirprod
             (nat_trans_eq_pointwise (IHP₁ _ _ _) (pr1 x))
             (nat_trans_eq_pointwise (IHP₂ _ _ _) (pr2 x))).
  - intros G₁ G₂ F.
    use nat_trans_eq.
    { apply homset_property. }
    intro.
    apply idpath.
  - intros G₁ G₂ F.
    use nat_trans_eq.
    { apply homset_property. }
    intro.
    refine (!_).
    exact (id_right _ @ id_right _).
  - intros G₁ G₂ F.
    use nat_trans_eq.
    { apply homset_property. }
    intro x.
    induction x as [x | x].
    + exact (nat_trans_eq_pointwise (IHP₁ _ _ _) x).
    + exact (nat_trans_eq_pointwise (IHP₂ _ _ _) x).
  - intros G₁ G₂ F.
    use nat_trans_eq.
    { apply homset_property. }
    intro x.
    exact (pathsdirprod
             (nat_trans_eq_pointwise (IHP₁ _ _ _) (pr1 x))
             (nat_trans_eq_pointwise (IHP₂ _ _ _) (pr2 x))).
  - intros G₁ G₂ G₃ F₁ F₂ F₃ F₄.
    use nat_trans_eq.
    { apply homset_property. }
    intro.
    apply idpath.
  - intros G₁ G₂ G₃ F₁ F₂ F₃ F₄.
    use nat_trans_eq.
    { apply homset_property. }
    intro ; cbn.
    exact (id_right _ @ id_right _ @ !(id_right _ @ id_left _ @ functor_id _ _)).
  - intros G₁ G₂ G₃ F₁ F₂ F₃ F₄.
    use nat_trans_eq.
    { apply homset_property. }
    intro x.
    induction x as [x | x].
    + exact (nat_trans_eq_pointwise (IHP₁ _ _ _ _ _ _ _) x).
    + exact (nat_trans_eq_pointwise (IHP₂ _ _ _ _ _ _ _) x).
  - intros G₁ G₂ G₃ F₁ F₂ F₃ F₄.
    use nat_trans_eq.
    { apply homset_property. }
    intro x.
    exact (pathsdirprod
             (nat_trans_eq_pointwise (IHP₁ _ _ _ _ _ _ _) (pr1 x))
             (nat_trans_eq_pointwise (IHP₂ _ _ _ _ _ _ _) (pr2 x))).
  - intros G₁ G₂ G₃ F₁ F₂ F₃ α.
    use nat_trans_eq.
    { apply homset_property. }
    intro.
    apply idpath.
  - intros G₁ G₂ G₃ F₁ F₂ F₃ α.
    use nat_trans_eq.
    { apply homset_property. }
    intro.
    exact (id_left _ @ !(id_right _)).
  - intros G₁ G₂ G₃ F₁ F₂ F₃ α.
    use nat_trans_eq.
    { apply homset_property. }
    intro x.
    induction x as [x | x].
    + exact (nat_trans_eq_pointwise (IHP₁ _ _ _ _ _ _ _) x).
    + exact (nat_trans_eq_pointwise (IHP₂ _ _ _ _ _ _ _) x).
  - intros G₁ G₂ G₃ F₁ F₂ F₃ α.
    use nat_trans_eq.
    { apply homset_property. }
    intro x.
    exact (pathsdirprod
             (nat_trans_eq_pointwise (IHP₁ _ _ _ _ _ _ _) (pr1 x))
             (nat_trans_eq_pointwise (IHP₂ _ _ _ _ _ _ _) (pr2 x))).
  - intros G₁ G₂ G₃ F₁ F₂ F₃ F₄.
    use nat_trans_eq.
    { apply homset_property. }
    intro.
    apply idpath.
  - intros G₁ G₂ G₃ F₁ F₂ F₃ α.
    use nat_trans_eq.
    { apply homset_property. }
    intro.
    exact (id_left _ @ !(id_right _)).
  - intros G₁ G₂ G₃ F₁ F₂ F₃ α.
    use nat_trans_eq.
    { apply homset_property. }
    intro x.
    induction x as [x | x].
    + exact (nat_trans_eq_pointwise (IHP₁ _ _ _ _ _ _ _) x).
    + exact (nat_trans_eq_pointwise (IHP₂ _ _ _ _ _ _ _) x).
  - intros G₁ G₂ G₃ F₁ F₂ F₃ α.
    use nat_trans_eq.
    { apply homset_property. }
    intro x.
    exact (pathsdirprod
             (nat_trans_eq_pointwise (IHP₁ _ _ _ _ _ _ _) (pr1 x))
             (nat_trans_eq_pointwise (IHP₂ _ _ _ _ _ _ _) (pr2 x))).
Qed.

Definition sem_poly_grpd
           (P : poly_code)
  : psfunctor grpd_bicat grpd_bicat.
Proof.
  use make_psfunctor.
  - exact (sem_poly_grpd_data P).
  - exact (sem_poly_grpd_laws P).
  - split ; intros ; apply grpd_bicat_is_invertible_2cell.
Defined.

Notation "⦃ P ⦄" := (sem_poly_grpd P).


(*
    Copyright (C) 2012  G. Gonthier, B. Ziliani, A. Nanevski, D. Dreyer

    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 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 General Public License
    along with this program.  If not, see <http://www.gnu.org/licenses/>.
*)

From mathcomp
Require Import ssreflect ssrbool ssrnat ssrfun seq eqtype.
From LemmaOverloading
Require Import heaps rels hprop stmod.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Delimit Scope stsep_scope with stsep.
Open Scope stsep_scope.

Definition lolli (p : _ -> Prop) q i m :=
  forall i1 h, i = i1 :+ h -> def i -> p i1 ->
    exists m1, m = m1 :+ h /\ def m /\ q i1 m1.

Notation "p '--o' q"   := (lolli p q) (at level 75) : stsep_scope.

Lemma antiframe p q i m h :
        def (i :+ h) -> (p --o q) (i :+ h) (m :+ h) -> (p --o q) i m.
Proof.
move=>D1 H i2 m2 E D2 H1; rewrite {i}E in H D1 D2 *.
move: (H i2 (m2 :+ h)); rewrite unA; case/(_ (erefl _) D1 H1)=>h2 [E][D3].
rewrite unA in E; exists h2; rewrite (unKhl D3 E).
by rewrite E in D3; rewrite (defUnl D3).
Qed.

(* p --o q is local *)
Lemma locality p q i1 m h :
        def (i1 :+ h) -> (p # top) i1 -> (p --o q) (i1 :+ h) m ->
          exists m1, m = m1 :+ h /\ def m /\ (p --o q) i1 m1.
Proof.
move=>D [h1][h2][E][H1] _ H2; rewrite {i1}E in D H2 *.
move: (H2 h1 (h2 :+ h)); rewrite unA; case/(_ (erefl _) D H1)=>m1 [E][D2].
rewrite {m}E unA in H2 D2 *; exists (m1 :+ h2); do !split=>//.
by apply: antiframe D H2.
Qed.

Lemma fr_pre p i j : (p # top) i -> (p # top) (i :+ j).
Proof.
by case=>i1 [i2][->][H] _; rewrite -unA; exists i1; exists (i2 :+ j).
Qed.

(********************)
(* Separation monad *)
(********************)

Definition fr A (s : spec A) : spec A :=
  (s.1 # top, fun x => s.1 --o s.2 x).

Prenex Implicits fr.

Notation "[ s ]" := (fr s).

Definition STsep A (s : spec A) := ST [s].

Section SepReturn.
Variable (A : Type) (x : A).

Definition ret_s : spec A := (emp, fun y i m => m = i /\ y = Val x).

Lemma retP : Model.conseq (Model.ret_s x) [ret_s].
Proof.
move=>i /= H1 D1; split=>// y m [->] -> _ i1 i2 -> D ->.
by exists empty; rewrite un0h (defUnr D).
Qed.

Definition ret := Model.Do (Model.ret x) retP.

End SepReturn.

Section SepBind.
Variables (A B : Type) (s1 : spec A) (s2 : A -> spec B).
Variables (e1 : STsep s1) (e2 : forall x, STsep (s2 x)).

Definition bind_s : spec B :=
  (Model.bind_pre [s1] (fr \o s2), Model.bind_post [s1] (fr \o s2)).

Lemma bindP : Model.conseq (Model.bind_s [s1] (fr \o s2)) [bind_s].
Proof.
move=>i H D; split=>[|{H D}].
- case: H D=>i1 [i2][->][[H S]] _ D.
  split=>[|y m]; first by apply: fr_pre.
  by case/(locality D H)=>m1 [->][_]; move/S; apply: fr_pre.
move=>y m H _ i1 i2 E D1 [H1 S1]; rewrite {i}E in H D1 *.
case: H=>[[x][h][]|[e][->]]; case/(locality D1 H1)=>h1 [->][D2] T2.
- move/S1: (T2)=>H2; case/(locality D2 H2)=>m1 [->][D3] T3.
  by exists m1; do !split=>//; left; exists x; exists h1.
by exists h1; do !split=>//; right; exists e.
Qed.

Definition bind : STsep bind_s := Model.Do (Model.bind e1 e2) bindP.

End SepBind.

Definition verify' A (s : spec A) i (r : ans A -> heap -> Prop) :=
  def i -> s.1 i /\ forall y m, s.2 y i m -> def m -> r y m.

Notation verify s i r := (@verify' _ [s] i r).

Section SepFrame.
Variables (A : Type) (s : spec A).

Lemma frame i j (r : ans A -> heap -> Prop) :
        verify s i (fun y m => def (m :+ j) -> r y (m :+ j)) ->
        verify s (i :+ j) r.
Proof.
move=>H D; case: (H (defUnl D))=>H1 H2.
split=>[|y m]; first by apply: fr_pre.
case/(locality D H1)=>m1 [->][D1]; move/H2.
by apply; apply: defUnl D1.
Qed.

Lemma frame0 i r : verify' s i r -> verify s i r.
Proof.
move=>H D; case: (H D)=>H1 H2.
split=>[|y m]; first by exists i; exists empty; rewrite unh0.
move/(_ i empty); rewrite unh0; case/(_ (erefl _) D H1)=>m1.
by rewrite unh0=>[[<-]][_]; apply: H2.
Qed.

Lemma frame1 i (r : ans A -> heap -> Prop) :
        verify' s empty (fun y m => def (m :+ i) -> r y (m :+ i)) ->
        verify s i r.
Proof. by move=>H; rewrite -[i]un0h; apply: frame; apply: frame0. Qed.

End SepFrame.

Definition conseq A (s : spec A) (p : pre) (q : post A) :=
  forall i, p i -> verify s i (fun y m => q y i m).

Local Notation conseq1 :=
  (fun A (s1 s2 : spec A) =>
     conseq s1 (let 'pair x _ := s2 in x)
               (let 'pair _ x := s2 in x)).

Lemma conseq_refl A (s : spec A) : conseq1 A s s.
Proof. by case: s=>s1 s2 i H; apply: frame0. Qed.

Hint Resolve conseq_refl : core.

Section SepConseq.
Variables (A : Type) (s1 s2 : spec A) (e : STsep s1).
Variables (pf : conseq1 A s1 s2).

Lemma doP : Model.conseq [s1] [s2].
Proof.
move=>i H D; split=>[|y m {H D} /=].
- case: H D=>i1 [i2][->][H] _ D.
  by case: (@pf i1 H (defUnl D))=>H1 _; apply: fr_pre.
move=>S D i1 i2 E D2 H2; rewrite {i}E in D S D2 H2.
case: (@pf i1 H2 (defUnl D2))=>H1 T1.
case: (locality D2 H1 S)=>m1 [->][D3] {S}.
by move/T1; move/(_ (defUnl D3))=>T2; exists m1.
Qed.

Definition do' : STsep s2 := Model.Do e doP.

End SepConseq.

Notation "'Do' e" := (do' e _) (at level 80).

Section SepRead.
Variables (A : Type) (x : ptr).

Definition read_s : spec A :=
  (fun i => exists v : A, i = x :-> v,
   fun y i m => i = m /\ forall v, i = x :-> v -> y = Val v).

Lemma readP : Model.conseq (Model.read_s A x) [read_s].
Proof.
move=>i H D; split=>[|{H D} y _ [->] H _ i1 h E1 D E2].
- case: H D=>i1 [i2][->][[v]] -> _ D /=.
  rewrite domPtUn inE /= D eq_refl; split=>//.
  by exists v; rewrite lookPtUn.
move: E1 E2 H D=>-> [v ->] H D; exists (x :-> v); do 3!split=>//.
move=>w; move/(pts_inj (defUnl D))=><-; apply: H.
by rewrite lookPtUn.
Qed.

Definition read : STsep read_s := Model.Do (Model.read A x) readP.

End SepRead.

Section SepWrite.
Variables (A : Type) (x : ptr) (v : A).

Definition write_s : spec unit :=
  (fun i => exists B : Type, exists y : B, i = x :-> y,
   fun y i m => y = Val tt /\ m = x :-> v).

Lemma writeP : Model.conseq (Model.write_s x v) [write_s].
Proof.
move=>i H D; split=>[|{H D} y m [->] <- D1 i1 h E1 D2 [B][w] E2].
- case: H D=>i1 [i2][->][[B]][y] -> _ D /=.
  by rewrite domPtUn inE /= D eq_refl.
move: E1 E2 D1 D2=>->->-> D; exists (x :-> v).
by rewrite updUnl domPt inE /= eq_refl (defPt_null D) /= updU eq_refl.
Qed.

Definition write : STsep write_s := Model.Do (Model.write x v) writeP.

End SepWrite.

Section SepAlloc.
Variables (A : Type) (v : A).

Definition alloc_s : spec ptr :=
  (emp, fun y i m => exists x, y = Val x /\ m = x :-> v).

Lemma allocP : Model.conseq (Model.alloc_s v) [alloc_s].
Proof.
move=>i H D; split=>[|{H D} y m [x][H1][->][H2] <- D1 i1 h E1 D E2].
- by case: H D=>i1 [i2][->][->].
move: E1 E2 H2 D D1=>-> ->; rewrite {1 2}un0h=>H2 D D1.
exists (x :-> v); rewrite updUnr (negbTE H2) defPtUn H1 H2 D.
by do !split=>//; exists x.
Qed.

Definition alloc : STsep alloc_s := Model.Do (Model.alloc v) allocP.

End SepAlloc.

Section SepBlockAlloc.
Variables (A : Type) (v : A) (n : nat).

Definition allocb_s : spec ptr :=
  (emp, fun y i m => exists x:ptr, y = Val x /\ m = updi x (nseq n v)).

Lemma allocbP : Model.conseq (Model.allocb_s v n) [allocb_s].
Proof.
move=>i H D; split=>[|y m].
  by case: H D=>i1 [i2][->][->][]; rewrite unC.
case=>x [->] -> D1 i1 h E1 D2 E2.
move: E1 E2 D1 D2=>->->; rewrite un0h {2}unC=>D1 D2.
by exists (updi x (nseq n v)); do !split=>//; exists x.
Qed.

Definition allocb : STsep allocb_s := Model.Do (Model.allocb v n) allocbP.

End SepBlockAlloc.

Section SepDealloc.
Variable x : ptr.

Definition dealloc_s : spec unit :=
  (fun i => exists A : Type, exists v:A, i = x :-> v,
   fun y i m => y = Val tt /\ m = empty).

Lemma deallocP : Model.conseq (Model.dealloc_s x) [dealloc_s].
Proof.
move=>i H D; split=>[|{H D} y m [->] <- D1 i1 h E1 D2 [A][v] E2].
- case: H D=>i1 [i2][->][[A]][v]-> _ D /=.
  by rewrite domPtUn inE /= D eq_refl.
move: E1 E2 D1 D2=>->->->; rewrite defPtUn; case/and3P=>H1 _ H2.
by exists empty; rewrite freeUnr // freeU eq_refl (negbTE H1) free0.
Qed.

Definition dealloc : STsep dealloc_s := Model.Do (Model.dealloc x) deallocP.

End SepDealloc.

Section SepThrow.
Variables (A : Type) (e : exn).

Definition throw_s : spec A :=
  (emp, fun y i m => m = i /\ y = Exn e).

Lemma throwP : Model.conseq (Model.throw_s A e) [throw_s].
Proof.
move=>i H D; split=>{H D} // y m [->] -> _ i1 h -> D ->.
by exists empty; rewrite un0h; do !split=>//; apply: defUnr D.
Qed.

Definition throw : STsep throw_s := Model.Do (Model.throw A e) throwP.

End SepThrow.

Section SepTry.
Variables (A B : Type) (s : spec A) (s1 : A -> spec B) (s2 : exn -> spec B).
Variables (e : STsep s) (e1 : forall x, STsep (s1 x)).
Variables (e2 : forall e, STsep (s2 e)).

Definition try_s : spec B :=
  (Model.try_pre [s] (fr \o s1) (fr \o s2),
   Model.try_post [s] (fr \o s1) (fr \o s2)).

Lemma tryP : Model.conseq (Model.try_s [s] (fr \o s1) (fr \o s2)) [try_s].
Proof.
move=>i H D; split=>[|{H D} y m H1 D1 i1 h E1 D2 /= [H2][H3] H4].
- case: H D=>i1 [i2][->][[H [S1 S2]]] _ D.
  split; first by apply: fr_pre.
  split=>y m; case/(locality D H)=>m1 [->][_]; [move/S1 | move/S2];
  by apply: fr_pre.
rewrite {i}E1 /= in H1 D2.
case: H1=>[[x]|[x]][h1][];
case/(locality D2 H2)=>m1 [->][D3] T1; move: (T1);
[move/H3 | move/H4]=>T'; case/(locality D3 T')=>m2 [->][D4] T2;
exists m2; do 2!split=>//; [left | right];
by exists x; exists m1.
Qed.

Definition try : STsep try_s := Model.Do (Model.try e e1 e2) tryP.

End SepTry.

Section SepFix.
Variables (A : Type) (B : A -> Type) (s : forall x, spec (B x)).
Notation tp := (forall x, STsep (s x)).

Definition Fix (f : tp -> tp) : tp := Model.ffix f.

End SepFix.

(* Conditionals for various types *)

Section CondBool.
Variables (A : Type) (b : bool) (s1 s2 : spec A).

Program
Definition If (e1 : STsep s1) (e2 : STsep s2) : STsep (if b then s1 else s2) :=
  match b with true => Do e1 | false => Do e2 end.

End CondBool.

Section CondOption.
Variable (A B : Type) (x : option A) (s1 : spec B) (s2 : A -> spec B).

Program
Definition Match_opt (e1 : STsep s1) (e2 : forall v, STsep (s2 v)) :
             STsep (match x with Some v => s2 v | None => s1 end) :=
  match x with Some v => Do (e2 v) | None => Do e1 end.

End CondOption.

Section CondDecide.
Variable (A : Type) (p1 p2 : Prop) (b : {p1} + {p2})
         (s1 : p1 -> spec A) (s2 : p2 -> spec A).

Program
Definition Match_dec (e1 : forall x, STsep (s1 x))
                     (e2 : forall x, STsep (s2 x)) :
             STsep (match b with left x => s1 x | right x => s2 x end) :=
  match b with left x => Do (e1 x) | right x => Do (e2 x) end.

End CondDecide.

Section CondNat.
Variable (A : Type) (n : nat) (s1 : spec A) (s2 : nat -> spec A).

Program
Definition Match_nat (e1 : STsep s1) (e2 : forall n, STsep (s2 n)) :
             STsep (match n with 0 => s1 | m.+1 => s2 m end) :=
  match n with 0 => Do e1 | m.+1 => Do (e2 m) end.

End CondNat.

Section CondSeq.
Variable (A B : Type) (s : seq A) (s1 : spec B) (s2 : A -> seq A -> spec B).

Program
Definition Match_seq (e1 : STsep s1) (e2 : forall hd tl, STsep (s2 hd tl)) :
             STsep (match s with [::] => s1 | hd::tl => s2 hd tl end) :=
  match s with [::] => Do e1 | hd::tl => Do (e2 hd tl) end.

End CondSeq.

(******************************************)
(* Lemmas for pulling out ghost variables *)
(******************************************)

Section Ghosts.
Variables (A : Type) (s : spec A) (p : pre).

Lemma allC (B1 B2 : Type) (q : B1 -> B2 -> post A) :
       conseq s p (fun y i m => forall x1 x2, q x1 x2 y i m) <->
       conseq s p (fun y i m => forall x, q x.1 x.2 y i m).
Proof.
split=>H1 i H2 D1; case: (H1 i H2 D1)=>S1 S2.
- by split=>// y m H D [x1 x2]; apply: S2.
by split=>// y m H D x1 x2; apply: (S2 y m H D (x1, x2)).
Qed.

Lemma impC (B : Type) (q1 q2 : heap -> B -> Prop) (r : B -> post A) :
        conseq s p (fun y i m => forall x, q1 i x -> q2 i x -> r x y i m) <->
        conseq s p (fun y i m => forall x, q1 i x /\ q2 i x -> r x y i m).
Proof.
split=>H1 i H2 D1; case: (H1 i H2 D1)=>S1 S2.
- by split=>// y m H D x []; apply: S2.
by split=>// *; apply: S2.
Qed.

Lemma ghE (B : Type) (q : heap -> B -> Prop) (r : B -> post A) :
        (forall i, p i -> def i -> exists x, q i x) ->
        (forall i x, q i x -> p i -> def i ->
           verify s i (fun y m => r x y i m)) ->
        conseq s p (fun y i m => forall x, q i x -> r x y i m).
Proof.
move=>H1 H2 i H3 D1; case: (H1 i H3 D1)=>x H4.
case: (H2 i x H4 H3 D1 D1)=>H5 _; split=>// y m H6 D2 z H7.
by case: (H2 i z H7 H3 D1 D1)=>_; apply.
Qed.

End Ghosts.

Definition gh := (allC, impC).

Notation "x '<--' c1 ';' c2" := (bind c1 (fun x => c2))
  (at level 78, right associativity) : stsep_scope.
Notation "c1 ';;' c2" := (bind c1 (fun _ => c2))
  (at level 78, right associativity) : stsep_scope.
Notation "'!' x" := (read _ x) (at level 50) : stsep_scope.
Notation "e1 '::=' e2" := (write e1 e2) (at level 60) : stsep_scope.
Notation "'throw' [ t ] E" := (throw t E)
  (at level 70, no associativity) : stsep_scope.
Notation "'ttry' E 'then' [ r ] E1 'else' [ x ] E2" :=
  (try E (fun r => E1) (fun x => E2)) (at level 80) : stsep_scope.
Notation "'ttry' E 'then' [ r ] E1 'else' E2" :=
  (try E (fun r => E1) (fun _ => E2)) (at level 80) : stsep_scope.
Notation "'ttry' E 'then' E1 'else' [ x ] E2" :=
  (try E (fun _ => E1) (fun x => E2)) (at level 80) : stsep_scope.
Notation "'ttry' E 'then' E1 'else' E2" :=
  (try E (fun _ => E1) (fun _ => E2)) (at level 80) : stsep_scope.
Notation "'match_opt' E 'then' E1 'else' [ x ] E2" :=
  (Match_opt E E1 (fun x => E2)) (at level 80) : stsep_scope.
Notation "'match_opt' E 'then' E1 'else' [ x ] E2" :=
  (Match_opt E E1 (fun x => E2)) (at level 80) : stsep_scope.
Notation "'If' E 'then' E1 'else' E2" :=
  (If E E1 E2) (at level 80) : stsep_scope.


Require Export Fiat.Common.Coq__8_4__8_5__Compat.
(** * Mapping predicates over [StringLike] things *)
Require Import Coq.ZArith.ZArith.
Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Fiat.Parsers.StringLike.Core.
Require Import Fiat.Parsers.StringLike.Properties.
Require Import Fiat.Parsers.StringLike.ForallChars.
Require Import Fiat.Parsers.StringLike.LastChar.
Require Import Fiat.Common.

Set Implicit Arguments.
Local Open Scope string_like_scope.

Local Arguments min !_ !_.
Local Arguments minus !_ !_.

Section is_after_last_char_such_that.
  Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char}.

  Definition is_after_last_char_such_that
             (*(might_be_empty : Prop)*)
             (str : String)
             (n : nat)
             P
    := forall_chars (drop n str) (fun ch => ~P ch)
       /\ for_last_char (take n str) P (*/\ 0 < min n (length str))
           \/ (might_be_empty /\ min n (length str) = 0))*).

  Lemma unfold_is_after_last_char_such_that str n P
  : is_after_last_char_such_that str n P
    <-> (forall_chars (drop n str) (fun ch => ~P ch)
         /\ for_last_char (take n str) P).
  Proof.
    reflexivity.
  Qed.

  Lemma after_last_char_such_that_nil
        (str : String)
        (n : nat)
        P
        (Hlen : length str = 0)
  : is_after_last_char_such_that str n P.
  Proof.
    unfold is_after_last_char_such_that.
    split; [ apply forall_chars_nil | apply for_last_char_nil ];
    rewrite ?take_length, ?drop_length;
    try apply Min.min_case_strong; omega.
  Qed.

  Lemma after_last_char_such_that_0
        (*might_be_empty : Prop*)
        (str : String)
        P
  : is_after_last_char_such_that (*might_be_empty*) str 0 P
    <-> forall_chars str (fun ch => ~P ch).
  Proof.
    unfold is_after_last_char_such_that.
    rewrite drop_0.
    split.
    { intros; destruct_head and.
      assumption. }
    { split; [ assumption | ].
      apply for_last_char_nil.
      rewrite take_length; reflexivity. }
  Qed.

  Lemma after_last_char_such_that_after_end
        (*{might_be_empty : Prop}*)
        {str : String}
        {P}
        {n}
        (Hle : length str <= n)
  : is_after_last_char_such_that (*might_be_empty*) str n P
    <-> for_last_char str P(* /\ (might_be_empty \/ 0 < length str))*).
  Proof.
    unfold is_after_last_char_such_that.
    rewrite take_long by omega.
    split; intro;
    destruct_head_hnf and;
    destruct_head_hnf or;
    destruct_head_hnf and; repeat split; trivial;
      try rewrite Min.min_idempotent in *;
      try solve [ left; assumption
                | right; omega
                | apply for_last_char_nil; omega
                | apply forall_chars_nil; rewrite ?drop_length, ?take_length; try apply Min.min_case_strong; intros; omega
                | destruct (length str);
                  try solve [ left; repeat split; eauto; omega
                            | right; repeat split; eauto; omega ] ].
  Qed.

  Lemma after_last_char_such_that_end
        (*{might_be_empty : Prop}*)
        {str : String}
        {P}
  : is_after_last_char_such_that (*might_be_empty*) str (length str) P
    <-> for_last_char str P(* /\ (might_be_empty \/ 0 < length str))*).
  Proof.
    apply after_last_char_such_that_after_end; reflexivity.
  Qed.

  Lemma is_after_last_char_such_that_drop
        (*(might_be_empty : Prop)*)
        (str : String)
        (n : nat)
        P
  : is_after_last_char_such_that (*might_be_empty*) str (S n) P
    -> is_after_last_char_such_that (*might_be_empty*) (drop 1 str) n P(* \/ ((*might_be_empty /\*) length str <= 1))*).
  Proof.
    revert dependent str; induction n as [|n IHn]; intros;
      unfold is_after_last_char_such_that in *;
      [
      | specialize (IHn (drop 1 str));
        rewrite (forall_chars__split _ _ 1) ];
      repeat match goal with
             | _ => assumption
             | _ => intro
             | _ => progress destruct_head and
             | _ => progress destruct_head iff
             | [ H : ?A -> ?B, H' : ?A |- _ ] => specialize (H H')
             | _ => progress simpl in *
             | [ H : ?x < ?y |- _ \/ (_ /\ ?y <= ?x) ] => left

             | [ H : ?x = 0 |- context[?x] ] => rewrite H
             | _ => apply forall_chars_nil; rewrite ?take_length, ?drop_length; reflexivity
             | _ => omega
             | [ H : ?A /\ ?B -> ?C |- _ ] => specialize (fun x y => H (conj x y))
             | [ H : _ -> ?A /\ ?B -> ?C |- _ ] => specialize (fun a x y => H a (conj x y))
             | [ H : _ |- _ ] => progress rewrite ?drop_0, ?drop_drop, ?take_take, ?drop_length, ?take_length, ?take_drop, ?Nat.add_1_r, ?Nat.le_sub_le_add_r, <- ?(Plus.plus_comm 2), <- ?Nat.lt_add_lt_sub_r in H
             | _ => progress rewrite ?drop_0, ?drop_drop, ?take_take, ?drop_length, ?take_length, ?take_drop, ?Nat.add_1_r, ?Nat.le_sub_le_add_r, <- ?(Plus.plus_comm 2), <- ?Nat.lt_add_lt_sub_r
             | _ => progress destruct_head or
             | [ |- _ /\ _ ] => split
             | [ |- _ <-> _ ] => split
             | _ => left; repeat split; trivial; omega
             | _ => right; repeat split; trivial; omega

             | [ H : for_last_char ?str ?P |- for_last_char (drop ?n ?str) ?P ]
               => eapply for_last_char__add_drop; eexact H

             | [ H : for_last_char (drop _ _) _ |- _ ]
               => rewrite <- for_last_char__drop in H by (rewrite ?take_length; apply Min.min_case_strong; omega)
             | [ |- forall_chars (drop _ (take _ _)) _ ]
               => rewrite drop_take, <- minus_Sn_m, minus_diag by omega; simpl;
                    apply (proj1 (forall_chars_take _ _))
             | [ H : forall_chars (drop ?n ?str) ?P |- forall_chars (drop (S ?n) ?str) ?P ]
               => rewrite <- (drop_drop str 1 n); apply (proj1 (forall_chars_drop _ _)); assumption
             end.
  Qed.

  Global Instance is_after_last_char_such_that_Proper
  : Proper ((*impl ==> *)beq ==> eq ==> pointwise_relation _ iff ==> impl) is_after_last_char_such_that.
  Proof.
    repeat intro; subst.
    unfold is_after_last_char_such_that in *.
    setoid_subst_rel beq.
    setoid_subst_rel impl.
    setoid_subst_rel (pointwise_relation Char iff).
    assumption.
  Qed.

  Global Instance is_after_last_char_such_that_Proper_flip
  : Proper ((*flip impl ==> *)beq ==> eq ==> pointwise_relation _ iff ==> flip impl) is_after_last_char_such_that.
  Proof.
    repeat intro; subst.
    unfold is_after_last_char_such_that in *.
    setoid_subst_rel beq.
    setoid_subst_rel (pointwise_relation Char iff).
    unfold flip in *.
    setoid_subst_rel impl.
    assumption.
  Qed.

  Global Instance is_after_last_char_such_that_Proper_iff
  : Proper ((*iff ==> *)beq ==> eq ==> pointwise_relation _ iff ==> iff) is_after_last_char_such_that.
  Proof.
    repeat intro; subst.
    unfold is_after_last_char_such_that in *.
    setoid_subst_rel beq.
    setoid_subst_rel iff.
    setoid_subst_rel (pointwise_relation Char iff).
    reflexivity.
  Qed.

  Lemma is_after_last_char_such_that_eq_nat_iff
        (*(might_be_empty : Prop)*)
        (str : String)
        (n n' : nat)
        P
        (H0 : is_after_last_char_such_that (*might_be_empty*) str n P)
        (H1 : is_after_last_char_such_that (*might_be_empty*) str n' P)
  : n = n' \/ (n >= length str /\ n' >= length str).
  Proof.
    revert dependent n'; revert dependent str; induction n; intros;
      [ destruct n'; intros;
        [ left; reflexivity
        | ]
      | destruct n'; intros;
        [ right; intros
        | ] ];
      [ unfold is_after_last_char_such_that in *;
        repeat match goal with
               | _ => assumption
               | [ H : and _ _ |- _ ] => destruct H
               | [ H : ?A -> ?B, H' : ?A |- _ ] => specialize (H H')
               | [ H : _ |- _ ] => rewrite drop_0 in H
               | [ H : forall_chars _ _, H' : for_last_char _ _ |- ?T ]
                 => apply (forall_chars_for_last_char_overlap (R := T) H H'); solve [ omega | tauto | exfalso; tauto ]
               | [ H : ?x = 0 |- context[?x] ] => rewrite H
               | _ => omega
               | _ => progress destruct_head and
               | [ H : context[_ - 0] |- _ ] => rewrite Nat.sub_0_r in H
               | _ => progress destruct_head or
               | [ |- _ /\ _ ] => split
               | [ |- 0 = S _ \/ _ ] => right
               | [ H : for_last_char (take 0 _) _ |- _ ] => clear H
               | [ H : forall_chars ?str ?P, H' : forall_chars (drop _ ?str) ?P |- _ ] => clear H'
               | [ H : forall_chars ?str ?P, H' : forall_chars (take _ ?str) ?P |- _ ] => clear H'
               | _ => right; repeat split; solve [ assumption | omega ]
               | [ H : forall_chars ?str ?P, H' : for_last_char (take (S ?n) ?str) ?P' |- ?R ]
                 => rewrite forall_chars_take in H; specialize (H n); apply forall_chars__impl__for_last_char in H
               | [ H : for_last_char ?s ?P, H' : for_last_char ?s ?P' |- ?T' ]
                 => destruct (fun pf => for_last_char_combine (T := T') pf H H'); [ cbv beta; tauto | | ];
                    clear H H'
               | [ H : length (take _ _) = 0 |- _ ] => rewrite take_length in H
               | [ H : min ?x ?y = 0 |- _ ] => revert H; apply (Min.min_case_strong x y)
               | _ => intro
               end..
      | let H := fresh in
        edestruct IHn as [H|H];
        [ solve [ eauto using is_after_last_char_such_that_drop ]..
        | left; omega
        | right; rewrite drop_length in H; destruct_head and; omega ] ].
  Qed.
End is_after_last_char_such_that.

Global Opaque is_after_last_char_such_that.

Definition find_after_last_char_such_that' {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char}
           (P : Char -> bool)
           (len : nat)
           (str : String)
  : nat
  := nat_rect
       (fun _ => nat)
       0
       (fun len' otherwise
        => match get len' str with
             | Some ch => if P ch
                          then S len'
                          else otherwise
             | None => otherwise
           end)
       len.

Lemma find_after_last_char_such_that'_S {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char}
      (P : Char -> bool)
      (len : nat)
      (str : String)
  : find_after_last_char_such_that' P (S len) str
    = let v := S (find_after_last_char_such_that' P len (drop 1 str)) in
      match get 0 str with
        | Some ch => match find_after_last_char_such_that' P len (drop 1 str) with
                       | 0 => if P ch then 1 else 0
                       | _ => v
                     end
        | None => 0
      end.
Proof.
  cbv zeta.
  revert str; induction len as [|len IHlen]; intros.
  { reflexivity. }
  { simpl in *.
    rewrite IHlen; clear IHlen.
    repeat match goal with
             | [ |- context[get ?n'] ]
               => not constr_eq n' 0; rewrite (get_drop (n := n'))
             | [ H : context[get ?n'] |- _ ]
               => not constr_eq n' 0; setoid_rewrite (get_drop (n := n')) in H
           end.
    replace (get 0 (drop len (drop 1 str))) with (get 0 (drop (S len) str))
      by (rewrite drop_drop; do 2 f_equal; omega).
    destruct (get 0 str) eqn:Hg0.
    { destruct (get 0 (drop (S len) str)) eqn:Hg1; [ | reflexivity ].
      edestruct P; reflexivity. }
    { apply no_first_char_empty in Hg0.
      rewrite has_first_char_nonempty
        by (rewrite drop_length, Hg0; reflexivity).
      reflexivity. } }
Qed.

Definition find_after_last_char_such_that {Char} {HSLM} {HSL} str P
  := @find_after_last_char_such_that' Char HSLM HSL P (length str) str.

Lemma find_after_last_char_such_that_drop {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char}
      (str : String)
      (P : Char -> bool)
  : find_after_last_char_such_that str P
    = let v := S (find_after_last_char_such_that (drop 1 str) P) in
      match get 0 str with
        | Some ch => match find_after_last_char_such_that (drop 1 str) P with
                       | 0 => if P ch then 1 else 0
                       | _ => v
                     end
        | None => 0
      end.
Proof.
  unfold find_after_last_char_such_that.
  destruct (length str) eqn:Hlen.
  { rewrite has_first_char_nonempty by assumption; simpl; reflexivity. }
  { rewrite find_after_last_char_such_that'_S; simpl.
    rewrite drop_length, Hlen; simpl.
    rewrite Nat.sub_0_r.
    reflexivity. }
Qed.

Lemma is_after_last_char_such_that__find_after_last_char_such_that {Char} {HSLM HSL} {HSLP : @StringLikeProperties Char HSLM HSL} str P
      (*might_be_empty*)
      (H : exists n, is_after_last_char_such_that (*might_be_empty*) str n (fun ch => is_true (P ch)))
: is_after_last_char_such_that (*might_be_empty*) str (@find_after_last_char_such_that Char HSLM HSL str P) (fun ch => is_true (P ch)).
Proof.
  destruct H as [n H].
  rewrite unfold_is_after_last_char_such_that in H |- *.
  destruct H as [H0 H1].
  generalize dependent str.
  induction n as [|n IHn]; intros.
  { cut (find_after_last_char_such_that str P = 0);
    [ intro Heq; rewrite Heq; split; assumption
    | ].
    rewrite drop_0 in H0.
    unfold find_after_last_char_such_that, find_after_last_char_such_that'.
    induction (length str) as [|len IHlen]; simpl;
    [ reflexivity | rewrite IHlen; clear IHlen ].
    rewrite forall_chars_get in H0.
    specialize (H0 len).
    edestruct get; [ | reflexivity ].
    specialize (H0 _ eq_refl).
    edestruct P; simpl in *; intuition. }
  { specialize (IHn (drop 1 str)).
    rewrite !drop_drop, !take_drop, !Nat.add_1_r in IHn.
    specialize_by assumption.
    specialize_by (apply for_last_char__add_drop; assumption).
    rewrite find_after_last_char_such_that_drop; simpl.
    destruct (get 0 str) eqn:Hg0.
    { destruct (find_after_last_char_such_that (drop 1 str) P) eqn:Hf.
      { destruct_head and.
        destruct (P c) eqn:Hp.
        { split; try assumption; [].
          rewrite <- for_last_char_singleton; [ | apply get_0 ]; eassumption. }
        { rewrite drop_0.
          split; [ | apply for_last_char_nil; rewrite take_length; reflexivity ].
          apply (forall_chars__split _ _ 1); split; try assumption; [].
          rewrite <- forall_chars_singleton; [ | apply get_0; eassumption ].
          congruence. } }
      { destruct_head and; split; try assumption; [].
        rewrite for_last_char__drop; [ eassumption | ].
        rewrite take_length; simpl.
        destruct (length str) as [|[|]] eqn:Hlen;
          [ exfalso
          | exfalso
          | ].
        { rewrite has_first_char_nonempty in Hg0 by assumption; congruence. }
        { move Hf at bottom.
          unfold find_after_last_char_such_that in Hf.
          rewrite drop_length, Hlen in Hf.
          simpl in Hf.
          congruence. }
        { simpl; omega. } } }
    { rewrite drop_0.
      apply no_first_char_empty in Hg0.
      split; [ apply forall_chars_nil | apply for_last_char_nil ];
      rewrite ?take_length, Hg0; reflexivity. } }
Qed.


From iris.algebra Require Export updates local_updates frac agree.
From iris.algebra Require Import proofmode_classes big_op.
From iris.prelude Require Import options.

(** The view camera with fractional authoritative elements *)
(** The view camera, which is reminiscent of the views framework, is used to
provide a logical/"small-footprint" "view" of some "large-footprint" piece of
data, which can be shared in the separation logic sense, i.e., different parts
of the data can be separately owned by different functions or threads. This is
achieved using the two elements of the view camera:

- The authoritative element [●V a], which describes the data under consideration.
- The fragment [◯V b], which provides a logical view of the data [a].

To enable sharing of the fragments, the type of fragments is equipped with a
camera structure so ownership of fragments can be split. Concretely, fragments
enjoy the rule [◯V (b1 ⋅ b2) = ◯V b1 ⋅ ◯V b2].

To enable sharing of the authoritative element [●V{q} a], it is equipped with a
fraction [q]. Updates are only possible with the full authoritative element
[●V a] (syntax for [●V{1} a]]), while fractional authoritative elements have
agreement, i.e., [✓ (●V{p1} a1 ⋅ ●V{p2} a2) → a1 ≡ a2]. *)

(** * The view relation *)
(** To relate the authoritative element [a] to its possible fragments [b], the
view camera is parametrized by a (step-indexed) relation [view_rel n a b]. This
relation should be a.) closed under smaller step-indexes [n], b.) non-expansive
w.r.t. the argument [a], c.) closed under smaller [b] (which implies
non-expansiveness w.r.t. [b]), and d.) ensure validity of the argument [b].

Note 1: Instead of requiring both a step-indexed and a non-step-indexed version
of the relation (like cameras do for validity), we use [∀ n, view_rel n] as the
non-step-indexed version. This is anyway necessary when using [≼{n}] as the
relation (like the authoritative camera does) as its non-step-indexed version
is not equivalent to [∀ n, x ≼{n} y].

Note 2: The view relation is defined as a canonical structure so that given a
relation [nat → A → B → Prop], the instance with the laws can be inferred. We do
not use type classes for this purpose because cameras themselves are represented
using canonical structures. It has proven fragile for a canonical structure
instance to take a type class as a parameter (in this case, [viewR] would need
to take a class with the view relation laws). *)
Structure view_rel (A : ofe) (B : ucmra) := ViewRel {
  view_rel_holds :> nat → A → B → Prop;
  view_rel_mono n1 n2 a1 a2 b1 b2 :
    view_rel_holds n1 a1 b1 →
    a1 ≡{n2}≡ a2 →
    b2 ≼{n2} b1 →
    n2 ≤ n1 →
    view_rel_holds n2 a2 b2;
  view_rel_validN n a b :
    view_rel_holds n a b → ✓{n} b;
  view_rel_unit n :
    ∃ a, view_rel_holds n a ε
}.
Global Arguments ViewRel {_ _} _ _.
Global Arguments view_rel_holds {_ _} _ _ _ _.
Global Instance: Params (@view_rel_holds) 4 := {}.

Global Instance view_rel_ne {A B} (rel : view_rel A B) n :
  Proper (dist n ==> dist n ==> iff) (rel n).
Proof.
  intros a1 a2 Ha b1 b2 Hb.
  split=> ?; (eapply view_rel_mono; [done|done|by rewrite Hb|done]).
Qed.
Global Instance view_rel_proper {A B} (rel : view_rel A B) n :
  Proper ((≡) ==> (≡) ==> iff) (rel n).
Proof. intros a1 a2 Ha b1 b2 Hb. apply view_rel_ne; by apply equiv_dist. Qed.

Class ViewRelDiscrete {A B} (rel : view_rel A B) :=
  view_rel_discrete n a b : rel 0 a b → rel n a b.

(** * Definition of the view camera *)
(** To make use of the lemmas provided in this file, elements of [view] should
always be constructed using [●V] and [◯V], and never using the constructor
[View]. *)
Record view {A B} (rel : nat → A → B → Prop) :=
  View { view_auth_proj : option (frac * agree A) ; view_frag_proj : B }.
Add Printing Constructor view.
Global Arguments View {_ _ _} _ _.
Global Arguments view_auth_proj {_ _ _} _.
Global Arguments view_frag_proj {_ _ _} _.
Global Instance: Params (@View) 3 := {}.
Global Instance: Params (@view_auth_proj) 3 := {}.
Global Instance: Params (@view_frag_proj) 3 := {}.

Definition view_auth {A B} {rel : view_rel A B} (q : Qp) (a : A) : view rel :=
  View (Some (q, to_agree a)) ε.
Definition view_frag {A B} {rel : view_rel A B} (b : B) : view rel := View None b.
Typeclasses Opaque view_auth view_frag.

Global Instance: Params (@view_auth) 3 := {}.
Global Instance: Params (@view_frag) 3 := {}.

Notation "●V{ q } a" := (view_auth q a) (at level 20, format "●V{ q }  a").
Notation "●V a" := (view_auth 1 a) (at level 20).
Notation "◯V a" := (view_frag a) (at level 20).

(** * The OFE structure *)
(** We omit the usual [equivI] lemma because it is hard to state a suitably
general version in terms of [●V] and [◯V], and because such a lemma has never
been needed in practice. *)
Section ofe.
  Context {A B : ofe} (rel : nat → A → B → Prop).
  Implicit Types a : A.
  Implicit Types ag : option (frac * agree A).
  Implicit Types b : B.
  Implicit Types x y : view rel.

  Local Instance view_equiv : Equiv (view rel) := λ x y,
    view_auth_proj x ≡ view_auth_proj y ∧ view_frag_proj x ≡ view_frag_proj y.
  Local Instance view_dist : Dist (view rel) := λ n x y,
    view_auth_proj x ≡{n}≡ view_auth_proj y ∧
    view_frag_proj x ≡{n}≡ view_frag_proj y.

  Global Instance View_ne : NonExpansive2 (@View A B rel).
  Proof. by split. Qed.
  Global Instance View_proper : Proper ((≡) ==> (≡) ==> (≡)) (@View A B rel).
  Proof. by split. Qed.
  Global Instance view_auth_proj_ne: NonExpansive (@view_auth_proj A B rel).
  Proof. by destruct 1. Qed.
  Global Instance view_auth_proj_proper :
    Proper ((≡) ==> (≡)) (@view_auth_proj A B rel).
  Proof. by destruct 1. Qed.
  Global Instance view_frag_proj_ne : NonExpansive (@view_frag_proj A B rel).
  Proof. by destruct 1. Qed.
  Global Instance view_frag_proj_proper :
    Proper ((≡) ==> (≡)) (@view_frag_proj A B rel).
  Proof. by destruct 1. Qed.

  Definition view_ofe_mixin : OfeMixin (view rel).
  Proof. by apply (iso_ofe_mixin (λ x, (view_auth_proj x, view_frag_proj x))). Qed.
  Canonical Structure viewO := Ofe (view rel) view_ofe_mixin.

  Global Instance View_discrete ag b :
    Discrete ag → Discrete b → Discrete (View ag b).
  Proof. by intros ?? [??] [??]; split; apply: discrete. Qed.
  Global Instance view_ofe_discrete :
    OfeDiscrete A → OfeDiscrete B → OfeDiscrete viewO.
  Proof. intros ?? [??]; apply _. Qed.
End ofe.

(** * The camera structure *)
Section cmra.
  Context {A B} (rel : view_rel A B).
  Implicit Types a : A.
  Implicit Types ag : option (frac * agree A).
  Implicit Types b : B.
  Implicit Types x y : view rel.

  Global Instance view_auth_ne q : NonExpansive (@view_auth A B rel q).
  Proof. solve_proper. Qed.
  Global Instance view_auth_proper q : Proper ((≡) ==> (≡)) (@view_auth A B rel q).
  Proof. solve_proper. Qed.
  Global Instance view_frag_ne : NonExpansive (@view_frag A B rel).
  Proof. done. Qed.
  Global Instance view_frag_proper : Proper ((≡) ==> (≡)) (@view_frag A B rel).
  Proof. done. Qed.

  Global Instance view_auth_dist_inj n :
    Inj2 (=) (dist n) (dist n) (@view_auth A B rel).
  Proof.
    intros p1 a1 p2 a2 [Hag ?]; inversion Hag as [?? [??]|]; simplify_eq/=.
    split; [done|]. by apply (inj to_agree).
  Qed.
  Global Instance view_auth_inj : Inj2 (=) (≡) (≡) (@view_auth A B rel).
  Proof.
    intros p1 a1 p2 a2 [Hag ?]; inversion Hag as [?? [??]|]; simplify_eq/=.
    split; [done|]. by apply (inj to_agree).
  Qed.
  Global Instance view_frag_dist_inj n : Inj (dist n) (dist n) (@view_frag A B rel).
  Proof. by intros ?? [??]. Qed.
  Global Instance view_frag_inj : Inj (≡) (≡) (@view_frag A B rel).
  Proof. by intros ?? [??]. Qed.

  Local Instance view_valid_instance : Valid (view rel) := λ x,
    match view_auth_proj x with
    | Some (q, ag) =>
       ✓ q ∧ (∀ n, ∃ a, ag ≡{n}≡ to_agree a ∧ rel n a (view_frag_proj x))
    | None => ∀ n, ∃ a, rel n a (view_frag_proj x)
    end.
  Local Instance view_validN_instance : ValidN (view rel) := λ n x,
    match view_auth_proj x with
    | Some (q, ag) =>
       ✓{n} q ∧ ∃ a, ag ≡{n}≡ to_agree a ∧ rel n a (view_frag_proj x)
    | None => ∃ a, rel n a (view_frag_proj x)
    end.
  Local Instance view_pcore_instance : PCore (view rel) := λ x,
    Some (View (core (view_auth_proj x)) (core (view_frag_proj x))).
  Local Instance view_op_instance : Op (view rel) := λ x y,
    View (view_auth_proj x ⋅ view_auth_proj y) (view_frag_proj x ⋅ view_frag_proj y).

  Local Definition view_valid_eq :
    valid = λ x,
      match view_auth_proj x with
      | Some (q, ag) =>
         ✓ q ∧ (∀ n, ∃ a, ag ≡{n}≡ to_agree a ∧ rel n a (view_frag_proj x))
      | None => ∀ n, ∃ a, rel n a (view_frag_proj x)
      end := eq_refl _.
  Local Definition view_validN_eq :
    validN = λ n x,
      match view_auth_proj x with
      | Some (q, ag) => ✓{n} q ∧ ∃ a, ag ≡{n}≡ to_agree a ∧ rel n a (view_frag_proj x)
      | None => ∃ a, rel n a (view_frag_proj x)
      end := eq_refl _.

  Lemma view_cmra_mixin : CmraMixin (view rel).
  Proof.
    apply (iso_cmra_mixin_restrict
      (λ x : option (frac * agree A) * B, View x.1 x.2)
      (λ x, (view_auth_proj x, view_frag_proj x))); try done.
    - intros [x b]. by rewrite /= pair_pcore !cmra_pcore_core.
    - intros n [[[q ag]|] b]; rewrite /= view_validN_eq /=.
      + intros (?&a&->&?). repeat split; simpl; [done|]. by eapply view_rel_validN.
      + intros [a ?]. repeat split; simpl. by eapply view_rel_validN.
    - rewrite view_validN_eq.
      intros n [x1 b1] [x2 b2] [Hx ?]; simpl in *;
        destruct Hx as [[q1 ag1] [q2 ag2] [??]|]; intros ?; by ofe_subst.
    - rewrite view_valid_eq view_validN_eq.
      intros [[[q aa]|] b]; rewrite /= ?cmra_valid_validN; naive_solver.
    - rewrite view_validN_eq=> n [[[q ag]|] b] /=.
      + intros [? (a&?&?)]; split; [done|].
        exists a; split; [by eauto using dist_S|].
        apply view_rel_mono with (S n) a b; auto with lia.
      + intros [a ?]. exists a. apply view_rel_mono with (S n) a b; auto with lia.
    - rewrite view_validN_eq=> n [[[q1 ag1]|] b1] [[[q2 ag2]|] b2] /=.
      + intros [?%cmra_validN_op_l (a & Haga & ?)]. split; [done|].
        assert (ag1 ≡{n}≡ ag2) as Ha12 by (apply agree_op_invN; by rewrite Haga).
        exists a. split; [by rewrite -Haga -Ha12 agree_idemp|].
        apply view_rel_mono with n a (b1 ⋅ b2); eauto using cmra_includedN_l.
      + intros [? (a & Haga & ?)]. split; [done|]. exists a; split; [done|].
        apply view_rel_mono with n a (b1 ⋅ b2); eauto using cmra_includedN_l.
      + intros [? (a & Haga & ?)]. exists a.
        apply view_rel_mono with n a (b1 ⋅ b2); eauto using cmra_includedN_l.
      + intros [a ?]. exists a.
        apply view_rel_mono with n a (b1 ⋅ b2); eauto using cmra_includedN_l.
  Qed.
  Canonical Structure viewR := Cmra (view rel) view_cmra_mixin.

  Global Instance view_auth_discrete q a :
    Discrete a → Discrete (ε : B) → Discrete (●V{q} a : view rel).
  Proof. intros. apply View_discrete; apply _. Qed.
  Global Instance view_frag_discrete b :
    Discrete b → Discrete (◯V b : view rel).
  Proof. intros. apply View_discrete; apply _. Qed.
  Global Instance view_cmra_discrete :
    OfeDiscrete A → CmraDiscrete B → ViewRelDiscrete rel →
    CmraDiscrete viewR.
  Proof.
    split; [apply _|]=> -[[[q ag]|] b]; rewrite view_valid_eq view_validN_eq /=.
    - rewrite -cmra_discrete_valid_iff.
      setoid_rewrite <-(discrete_iff _ ag). naive_solver.
    - naive_solver.
  Qed.

  Local Instance view_empty_instance : Unit (view rel) := View ε ε.
  Lemma view_ucmra_mixin : UcmraMixin (view rel).
  Proof.
    split; simpl.
    - rewrite view_valid_eq /=. apply view_rel_unit.
    - by intros x; constructor; rewrite /= left_id.
    - do 2 constructor; [done| apply (core_id_core _)].
  Qed.
  Canonical Structure viewUR := Ucmra (view rel) view_ucmra_mixin.

  (** Operation *)
  Lemma view_auth_frac_op p1 p2 a : ●V{p1 + p2} a ≡ ●V{p1} a ⋅ ●V{p2} a.
  Proof.
    intros; split; simpl; last by rewrite left_id.
    by rewrite -Some_op -pair_op agree_idemp.
  Qed.
  Global Instance view_auth_frac_is_op q q1 q2 a :
    IsOp q q1 q2 → IsOp' (●V{q} a) (●V{q1} a) (●V{q2} a).
  Proof. rewrite /IsOp' /IsOp => ->. by rewrite -view_auth_frac_op. Qed.

  Lemma view_frag_op b1 b2 : ◯V (b1 ⋅ b2) = ◯V b1 ⋅ ◯V b2.
  Proof. done. Qed.
  Lemma view_frag_mono b1 b2 : b1 ≼ b2 → ◯V b1 ≼ ◯V b2.
  Proof. intros [c ->]. rewrite view_frag_op. apply cmra_included_l. Qed.
  Lemma view_frag_core b : core (◯V b) = ◯V (core b).
  Proof. done. Qed.
  Global Instance view_frag_core_id b : CoreId b → CoreId (◯V b).
  Proof. do 2 constructor; simpl; auto. by apply core_id_core. Qed.
  Global Instance view_frag_is_op b b1 b2 :
    IsOp b b1 b2 → IsOp' (◯V b) (◯V b1) (◯V b2).
  Proof. done. Qed.
  Global Instance view_frag_sep_homomorphism :
    MonoidHomomorphism op op (≡) (@view_frag A B rel).
  Proof. by split; [split; try apply _|]. Qed.

  Lemma big_opL_view_frag {C} (g : nat → C → B) (l : list C) :
    (◯V [^op list] k↦x ∈ l, g k x) ≡ [^op list] k↦x ∈ l, ◯V (g k x).
  Proof. apply (big_opL_commute _). Qed.
  Lemma big_opM_view_frag `{Countable K} {C} (g : K → C → B) (m : gmap K C) :
    (◯V [^op map] k↦x ∈ m, g k x) ≡ [^op map] k↦x ∈ m, ◯V (g k x).
  Proof. apply (big_opM_commute _). Qed.
  Lemma big_opS_view_frag `{Countable C} (g : C → B) (X : gset C) :
    (◯V [^op set] x ∈ X, g x) ≡ [^op set] x ∈ X, ◯V (g x).
  Proof. apply (big_opS_commute _). Qed.
  Lemma big_opMS_view_frag `{Countable C} (g : C → B) (X : gmultiset C) :
    (◯V [^op mset] x ∈ X, g x) ≡ [^op mset] x ∈ X, ◯V (g x).
  Proof. apply (big_opMS_commute _). Qed.

  (** Validity *)
  Lemma view_auth_frac_op_invN n p1 a1 p2 a2 :
    ✓{n} (●V{p1} a1 ⋅ ●V{p2} a2) → a1 ≡{n}≡ a2.
  Proof.
    rewrite /op /view_op_instance /= left_id -Some_op -pair_op view_validN_eq /=.
    intros (?&?& Eq &?). apply (inj to_agree), agree_op_invN. by rewrite Eq.
  Qed.
  Lemma view_auth_frac_op_inv p1 a1 p2 a2 : ✓ (●V{p1} a1 ⋅ ●V{p2} a2) → a1 ≡ a2.
  Proof.
    intros ?. apply equiv_dist. intros n.
    by eapply view_auth_frac_op_invN, cmra_valid_validN.
  Qed.
  Lemma view_auth_frac_op_inv_L `{!LeibnizEquiv A} p1 a1 p2 a2 :
    ✓ (●V{p1} a1 ⋅ ●V{p2} a2) → a1 = a2.
  Proof. by intros ?%view_auth_frac_op_inv%leibniz_equiv. Qed.

  Lemma view_auth_frac_validN n q a : ✓{n} (●V{q} a) ↔ (q ≤ 1)%Qp ∧ rel n a ε.
  Proof.
    rewrite view_validN_eq /=. apply and_iff_compat_l. split; [|by eauto].
    by intros [? [->%(inj to_agree) ?]].
  Qed.
  Lemma view_auth_validN n a : ✓{n} (●V a) ↔ rel n a ε.
  Proof. rewrite view_auth_frac_validN. naive_solver. Qed.

  Lemma view_auth_frac_op_validN n q1 q2 a1 a2 :
    ✓{n} (●V{q1} a1 ⋅ ●V{q2} a2) ↔ (q1 + q2 ≤ 1)%Qp ∧ a1 ≡{n}≡ a2 ∧ rel n a1 ε.
  Proof.
    split.
    - intros Hval. assert (a1 ≡{n}≡ a2) as Ha by eauto using view_auth_frac_op_invN.
      revert Hval. rewrite Ha -view_auth_frac_op view_auth_frac_validN. naive_solver.
    - intros (?&->&?). by rewrite -view_auth_frac_op view_auth_frac_validN.
  Qed.
  Lemma view_auth_op_validN n a1 a2 : ✓{n} (●V a1 ⋅ ●V a2) ↔ False.
  Proof. rewrite view_auth_frac_op_validN. naive_solver. Qed.

  Lemma view_frag_validN n b : ✓{n} (◯V b) ↔ ∃ a, rel n a b.
  Proof. done. Qed.

  Lemma view_both_frac_validN n q a b :
    ✓{n} (●V{q} a ⋅ ◯V b) ↔ (q ≤ 1)%Qp ∧ rel n a b.
  Proof.
    rewrite view_validN_eq /=. apply and_iff_compat_l.
    setoid_rewrite (left_id _ _ b). split; [|by eauto].
    by intros [?[->%(inj to_agree)]].
  Qed.
  Lemma view_both_validN n a b : ✓{n} (●V a ⋅ ◯V b) ↔ rel n a b.
  Proof. rewrite view_both_frac_validN. naive_solver. Qed.

  Lemma view_auth_frac_valid q a : ✓ (●V{q} a) ↔ (q ≤ 1)%Qp ∧ ∀ n, rel n a ε.
  Proof.
    rewrite view_valid_eq /=. apply and_iff_compat_l. split; [|by eauto].
    intros H n. by destruct (H n) as [? [->%(inj to_agree) ?]].
  Qed.
  Lemma view_auth_valid a : ✓ (●V a) ↔ ∀ n, rel n a ε.
  Proof. rewrite view_auth_frac_valid. naive_solver. Qed.

  Lemma view_auth_frac_op_valid q1 q2 a1 a2 :
    ✓ (●V{q1} a1 ⋅ ●V{q2} a2) ↔ (q1 + q2 ≤ 1)%Qp ∧ a1 ≡ a2 ∧ ∀ n, rel n a1 ε.
  Proof.
    rewrite !cmra_valid_validN equiv_dist. setoid_rewrite view_auth_frac_op_validN.
    split; last naive_solver. intros Hv.
    split; last naive_solver. apply (Hv 0).
  Qed.
  Lemma view_auth_op_valid a1 a2 : ✓ (●V a1 ⋅ ●V a2) ↔ False.
  Proof. rewrite view_auth_frac_op_valid. naive_solver. Qed.

  Lemma view_frag_valid b : ✓ (◯V b) ↔ ∀ n, ∃ a, rel n a b.
  Proof. done. Qed.

  Lemma view_both_frac_valid q a b : ✓ (●V{q} a ⋅ ◯V b) ↔ (q ≤ 1)%Qp ∧ ∀ n, rel n a b.
  Proof.
    rewrite view_valid_eq /=. apply and_iff_compat_l.
    setoid_rewrite (left_id _ _ b). split; [|by eauto].
    intros H n. by destruct (H n) as [?[->%(inj to_agree)]].
  Qed.
  Lemma view_both_valid a b : ✓ (●V a ⋅ ◯V b) ↔ ∀ n, rel n a b.
  Proof. rewrite view_both_frac_valid. naive_solver. Qed.

  (** Inclusion *)
  Lemma view_auth_frac_includedN n p1 p2 a1 a2 b :
    ●V{p1} a1 ≼{n} ●V{p2} a2 ⋅ ◯V b ↔ (p1 ≤ p2)%Qp ∧ a1 ≡{n}≡ a2.
  Proof.
    split.
    - intros [[[[qf agf]|] bf]
        [[?%(discrete_iff _ _) ?]%(inj Some) _]]; simplify_eq/=.
      + split; [apply Qp_le_add_l|]. apply to_agree_includedN. by exists agf.
      + split; [done|]. by apply (inj to_agree).
    - intros [[[q ->]%frac_included| ->]%Qp_le_lteq ->].
      + rewrite view_auth_frac_op -assoc. apply cmra_includedN_l.
      + apply cmra_includedN_l.
  Qed.
  Lemma view_auth_frac_included p1 p2 a1 a2 b :
    ●V{p1} a1 ≼ ●V{p2} a2 ⋅ ◯V b ↔ (p1 ≤ p2)%Qp ∧ a1 ≡ a2.
  Proof.
    intros. split.
    - split.
      + by eapply (view_auth_frac_includedN 0), cmra_included_includedN.
      + apply equiv_dist=> n.
        by eapply view_auth_frac_includedN, cmra_included_includedN.
    - intros [[[q ->]%frac_included| ->]%Qp_le_lteq ->].
      + rewrite view_auth_frac_op -assoc. apply cmra_included_l.
      + apply cmra_included_l.
  Qed.
  Lemma view_auth_includedN n a1 a2 b :
    ●V a1 ≼{n} ●V a2 ⋅ ◯V b ↔ a1 ≡{n}≡ a2.
  Proof. rewrite view_auth_frac_includedN. naive_solver. Qed.
  Lemma view_auth_included a1 a2 b :
    ●V a1 ≼ ●V a2 ⋅ ◯V b ↔ a1 ≡ a2.
  Proof. rewrite view_auth_frac_included. naive_solver. Qed.

  Lemma view_frag_includedN n p a b1 b2 :
    ◯V b1 ≼{n} ●V{p} a ⋅ ◯V b2 ↔ b1 ≼{n} b2.
  Proof.
    split.
    - intros [xf [_ Hb]]; simpl in *.
      revert Hb; rewrite left_id. by exists (view_frag_proj xf).
    - intros [bf ->]. rewrite comm view_frag_op -assoc. apply cmra_includedN_l.
  Qed.
  Lemma view_frag_included p a b1 b2 :
    ◯V b1 ≼ ●V{p} a ⋅ ◯V b2 ↔ b1 ≼ b2.
  Proof.
    split.
    - intros [xf [_ Hb]]; simpl in *.
      revert Hb; rewrite left_id. by exists (view_frag_proj xf).
    - intros [bf ->]. rewrite comm view_frag_op -assoc. apply cmra_included_l.
  Qed.

  (** The weaker [view_both_included] lemmas below are a consequence of the
  [view_auth_included] and [view_frag_included] lemmas above. *)
  Lemma view_both_frac_includedN n p1 p2 a1 a2 b1 b2 :
    ●V{p1} a1 ⋅ ◯V b1 ≼{n} ●V{p2} a2 ⋅ ◯V b2 ↔ (p1 ≤ p2)%Qp ∧ a1 ≡{n}≡ a2 ∧ b1 ≼{n} b2.
  Proof.
    split.
    - intros. rewrite assoc. split.
      + rewrite -view_auth_frac_includedN. by etrans; [apply cmra_includedN_l|].
      + rewrite -view_frag_includedN. by etrans; [apply cmra_includedN_r|].
    - intros (?&->&?bf&->). rewrite (comm _ b1) view_frag_op assoc.
      by apply cmra_monoN_r, view_auth_frac_includedN.
  Qed.
  Lemma view_both_frac_included p1 p2 a1 a2 b1 b2 :
    ●V{p1} a1 ⋅ ◯V b1 ≼ ●V{p2} a2 ⋅ ◯V b2 ↔ (p1 ≤ p2)%Qp ∧ a1 ≡ a2 ∧ b1 ≼ b2.
  Proof.
    split.
    - intros. rewrite assoc. split.
      + rewrite -view_auth_frac_included. by etrans; [apply cmra_included_l|].
      + rewrite -view_frag_included. by etrans; [apply cmra_included_r|].
    - intros (?&->&?bf&->). rewrite (comm _ b1) view_frag_op assoc.
      by apply cmra_mono_r, view_auth_frac_included.
  Qed.
  Lemma view_both_includedN n a1 a2 b1 b2 :
    ●V a1 ⋅ ◯V b1 ≼{n} ●V a2 ⋅ ◯V b2 ↔ a1 ≡{n}≡ a2 ∧ b1 ≼{n} b2.
  Proof. rewrite view_both_frac_includedN. naive_solver. Qed.
  Lemma view_both_included a1 a2 b1 b2 :
    ●V a1 ⋅ ◯V b1 ≼ ●V a2 ⋅ ◯V b2 ↔ a1 ≡ a2 ∧ b1 ≼ b2.
  Proof. rewrite view_both_frac_included. naive_solver. Qed.

  (** Updates *)
  Lemma view_update a b a' b' :
    (∀ n bf, rel n a (b ⋅ bf) → rel n a' (b' ⋅ bf)) →
    ●V a ⋅ ◯V b ~~> ●V a' ⋅ ◯V b'.
  Proof.
    intros Hup; apply cmra_total_update=> n [[[q ag]|] bf] [/=].
    { by intros []%(exclusiveN_l _ _). }
    intros _ (a0 & <-%(inj to_agree) & Hrel). split; simpl; [done|].
    exists a'; split; [done|]. revert Hrel. rewrite !left_id. apply Hup.
  Qed.

  Lemma view_update_alloc a a' b' :
    (∀ n bf, rel n a bf → rel n a' (b' ⋅ bf)) →
    ●V a ~~> ●V a' ⋅ ◯V b'.
  Proof.
    intros Hup. rewrite -(right_id _ _ (●V a)).
    apply view_update=> n bf. rewrite left_id. apply Hup.
  Qed.
  Lemma view_update_dealloc a b a' :
    (∀ n bf, rel n a (b ⋅ bf) → rel n a' bf) →
    ●V a ⋅ ◯V b ~~> ●V a'.
  Proof.
    intros Hup. rewrite -(right_id _ _ (●V a')).
    apply view_update=> n bf. rewrite left_id. apply Hup.
  Qed.

  Lemma view_update_auth a a' b' :
    (∀ n bf, rel n a bf → rel n a' bf) →
    ●V a ~~> ●V a'.
  Proof.
    intros Hup. rewrite -(right_id _ _ (●V a)) -(right_id _ _ (●V a')).
    apply view_update=> n bf. rewrite !left_id. apply Hup.
  Qed.
  Lemma view_update_frag b b' :
    (∀ a n bf, rel n a (b ⋅ bf) → rel n a (b' ⋅ bf)) →
    ◯V b ~~> ◯V b'.
  Proof.
    rewrite !cmra_total_update view_validN_eq=> ? n [[[q ag]|] bf]; naive_solver.
  Qed.

  Lemma view_update_frac_alloc q a b :
    (∀ n bf, rel n a bf → rel n a (b ⋅ bf)) →
    ●V{q} a ~~> ●V{q} a ⋅ ◯V b.
  Proof.
    intros Hup. apply cmra_total_update=> n [[[p ag]|] bf] [/=].
    - intros ? (a0 & Hag & Hrel). split; simpl; [done|].
      exists a0; split; [done|]. revert Hrel.
      assert (to_agree a ≼{n} to_agree a0) as <-%to_agree_includedN.
      { by exists ag. }
      rewrite !left_id. apply Hup.
    - intros ? (a0 & <-%(inj to_agree) & Hrel). split; simpl; [done|].
      exists a; split; [done|]. revert Hrel. rewrite !left_id. apply Hup.
  Qed.

  Lemma view_local_update a b0 b1 a' b0' b1' :
    (b0, b1) ~l~> (b0', b1') →
    (∀ n, view_rel_holds rel n a b0 → view_rel_holds rel n a' b0') →
    (●V a ⋅ ◯V b0, ●V a ⋅ ◯V b1) ~l~> (●V a' ⋅ ◯V b0', ●V a' ⋅ ◯V b1').
  Proof.
    rewrite !local_update_unital.
    move=> Hup Hrel n [[[q ag]|] bf] /view_both_validN Hrel' [/=].
    - rewrite right_id -Some_op -pair_op frac_op=> /Some_dist_inj [/= H1q _].
      by destruct (Qp_add_id_free 1 q).
    - rewrite !left_id=> _ Hb0.
      destruct (Hup n bf) as [? Hb0']; [by eauto using view_rel_validN..|].
      split; [apply view_both_validN; by auto|]. by rewrite -assoc Hb0'.
  Qed.
End cmra.

(** * Utilities to construct functors *)
(** Due to the dependent type [rel] in [view] we cannot actually define
instances of the functor structures [rFunctor] and [urFunctor]. Functors can
only be defined for instances of [view], like [auth]. To make it more convenient
to define functors for instances of [view], we define the map operation
[view_map] and a bunch of lemmas about it. *)
Definition view_map {A A' B B'}
    {rel : nat → A → B → Prop} {rel' : nat → A' → B' → Prop}
    (f : A → A') (g : B → B') (x : view rel) : view rel' :=
  View (prod_map id (agree_map f) <$> view_auth_proj x) (g (view_frag_proj x)).
Lemma view_map_id {A B} {rel : nat → A → B → Prop} (x : view rel) :
  view_map id id x = x.
Proof. destruct x as [[[]|] ]; by rewrite // /view_map /= agree_map_id. Qed.
Lemma view_map_compose {A A' A'' B B' B''}
    {rel : nat → A → B → Prop} {rel' : nat → A' → B' → Prop}
    {rel'' : nat → A'' → B'' → Prop}
    (f1 : A → A') (f2 : A' → A'') (g1 : B → B') (g2 : B' → B'') (x : view rel) :
  view_map (f2 ∘ f1) (g2 ∘ g1) x
  =@{view rel''} view_map f2 g2 (view_map (rel':=rel') f1 g1 x).
Proof. destruct x as [[[]|] ];  by rewrite // /view_map /= agree_map_compose. Qed.
Lemma view_map_ext  {A A' B B' : ofe}
    {rel : nat → A → B → Prop} {rel' : nat → A' → B' → Prop}
    (f1 f2 : A → A') (g1 g2 : B → B')
    `{!NonExpansive f1, !NonExpansive g1} (x : view rel) :
  (∀ a, f1 a ≡ f2 a) → (∀ b, g1 b ≡ g2 b) →
  view_map f1 g1 x ≡@{view rel'} view_map f2 g2 x.
Proof.
  intros. constructor; simpl; [|by auto].
  apply option_fmap_equiv_ext=> a; by rewrite /prod_map /= agree_map_ext.
Qed.
Global Instance view_map_ne {A A' B B' : ofe}
    {rel : nat → A → B → Prop} {rel' : nat → A' → B' → Prop}
    (f : A → A') (g : B → B') `{Hf : !NonExpansive f, Hg : !NonExpansive g} :
  NonExpansive (view_map (rel':=rel') (rel:=rel) f g).
Proof.
  intros n [o1 bf1] [o2 bf2] [??]; split; simpl in *; [|by apply Hg].
  apply option_fmap_ne; [|done]=> pag1 pag2 ?.
  apply prod_map_ne; [done| |done]. by apply agree_map_ne.
Qed.

Definition viewO_map {A A' B B' : ofe}
    {rel : nat → A → B → Prop} {rel' : nat → A' → B' → Prop}
    (f : A -n> A') (g : B -n> B') : viewO rel -n> viewO rel' :=
  OfeMor (view_map f g).
Lemma viewO_map_ne {A A' B B' : ofe}
    {rel : nat → A → B → Prop} {rel' : nat → A' → B' → Prop} :
  NonExpansive2 (viewO_map (rel:=rel) (rel':=rel')).
Proof.
  intros n f f' Hf g g' Hg [[[p ag]|] bf]; split=> //=.
  do 2 f_equiv. by apply agreeO_map_ne.
Qed.

Lemma view_map_cmra_morphism {A A' B B'}
    {rel : view_rel A B} {rel' : view_rel A' B'}
    (f : A → A') (g : B → B') `{!NonExpansive f, !CmraMorphism g} :
  (∀ n a b, rel n a b → rel' n (f a) (g b)) →
  CmraMorphism (view_map (rel:=rel) (rel':=rel') f g).
Proof.
  intros Hrel. split.
  - apply _.
  - rewrite !view_validN_eq=> n [[[p ag]|] bf] /=;
      [|naive_solver eauto using cmra_morphism_validN].
    intros [? [a' [Hag ?]]]. split; [done|]. exists (f a'). split; [|by auto].
    by rewrite -agree_map_to_agree -Hag.
  - intros [o bf]. apply Some_proper; rewrite /view_map /=.
    f_equiv; by rewrite cmra_morphism_core.
  - intros [[[p1 ag1]|] bf1] [[[p2 ag2]|] bf2];
      try apply View_proper=> //=; by rewrite cmra_morphism_op.
Qed.


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

(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************)
(*           The Calculus of Inductive Constructions            *)
(*                       COQ v5.10                              *)
(*                                                              *)
(* Laurent Arditi.  Laboratoire I3S. CNRS ura 1376.             *)
(* Universite de Nice - Sophia Antipolis                        *)
(* arditi@unice.fr, http://wwwi3s.unice.fr/~arditi/lolo.html    *)
(*                                                              *)
(* date: may 1995                                               *)
(* file: Lists_compl.v                                          *)
(* contents: definitions and lemmas on polymorphic lists,       *)
(* length, append, map, reverse, list_constant                  *)
(* decidability of equality on lists *** TO BE PROVED ***       *)
(****************************************************************)

Require Export List.
Require Export Arith_compl.

Section Lists_compl.
Variable A B : Set.

Lemma length_eq1 : length (nil:list A) = 0.
auto with arith. Qed.
Lemma length_eq2 :
 forall (x : A) (l : list A), length (x :: l) = S (length l).
auto with arith. Qed.

Lemma app_eq1 : forall l' : list A, nil ++ l' = l'.
auto with arith. Qed.
Lemma app_eq2 : forall (x : A) (l l' : list A), (x :: l) ++ l' = x :: l ++ l'.
auto with arith. Qed.

Inductive len : list A -> nat -> Prop :=
 (************)
  | len_nil : len nil 0
  | len_cons :
      forall (b : A) (v : list A) (l : nat), len v l -> len (b :: v) (S l).
Hint Resolve len_nil len_cons.

Lemma nil_cons : forall (b : A) (v : list A), nil <> b :: v.
(*************)
intros. discriminate.
Qed.

Lemma not_cons_eq : forall (v : list A) (b : A), v <> b :: v.
(****************)
simple induction v. intro. discriminate.
intros. injection. intros. absurd (l = a :: l). apply H.
exact H1.
Qed.

Lemma app_v_nil : forall v : list A, v ++ nil = v.
(**************)
intro.
rewrite <- app_nil_end; trivial with arith.
Qed. Hint Resolve app_v_nil.

Lemma app_v_nil_idem : forall v v' : list A, v = v' -> v ++ nil = v'.
(********************)
intros. inversion H. apply app_v_nil.
Qed.

Lemma app_v_nil_inv : forall v1 v2 : list A, v1 ++ v2 = v1 -> v2 = nil.
(******************)
simple induction v1. simpl in |- *. trivial with arith.
intros. generalize H0. rewrite app_eq2. intros. injection H1. intro. apply H. exact H2.
Qed.

Lemma app_v_nil_sym : forall v1 v2 : list A, v1 = nil -> v1 ++ v2 = v2 ++ v1.
(******************)
simple induction v2. intro. rewrite H. trivial with arith.
intros. rewrite H0. auto with arith.
Qed.

Definition app_assoc_r := app_ass.
(*********************)
Definition app_assoc_l := ass_app.
(*********************)

Lemma len_cons_not_O :
 forall (b : A) (v : list A) (l : nat),
 (*******************)
 len (b :: v) l -> l <> 0.
simple induction v. intros. inversion H. discriminate.
intros. inversion H0. discriminate.
Qed.

Lemma len_nil_inv : forall l : nat, len nil l -> l = 0.
(****************)
intros; inversion H; trivial with arith.
Qed.

Lemma not_len_nil_Sn : forall l : nat, ~ len nil (S l).
(*******************)
simple induction l. red in |- *. intro. inversion H. unfold not in |- *. intros. inversion H0.
Qed.

Lemma len_app :
 forall (l1 l2 : nat) (v1 v2 : list A),
 (************)
 len v1 l1 -> len v2 l2 -> len (v1 ++ v2) (l1 + l2).
simple induction l1. simpl in |- *. intros. inversion H. simpl in |- *. assumption.
intros. inversion H0. simpl in |- *. apply len_cons. apply H. exact H4.
exact H1.
Qed.

Lemma len_length : forall v : list A, len v (length v).
(***************)
simple induction v. auto with arith.
intros. rewrite length_eq2. apply len_cons. exact H.
Qed. Hint Resolve len_length.

Lemma length_eq : forall v1 v2 : list A, v1 = v2 -> length v1 = length v2.
(**************)
intros. rewrite H. trivial with arith.
Qed.

Lemma not_nil : forall v : list A, length v <> 0 -> v <> nil.
(************)
simple induction v. simpl in |- *; intro. absurd (0 <> 0). unfold not in |- *; auto with arith. exact H.
simpl in |- *. intros. discriminate.
Qed.

Lemma length_app :
 forall v1 v2 : list A,
 (***************)
 length (v1 ++ v2) = length v1 + length v2.
simple induction v1. simpl in |- *. trivial with arith.
intros. simpl in |- *. rewrite H. trivial with arith.
Qed.

Lemma v_not_nil_length :
 forall v : list A,
 (*********************)
 v <> nil -> 1 <= length v.
simple induction v. intro. absurd (nil <> nil :>list A). unfold not in |- *. auto with arith.
exact H.
intros. simpl in |- *. apply le_n_S. auto with arith.
Qed.

Lemma le_SO_length_v :
 forall v : list A,
 (*******************)
 length v <> 0 -> 1 <= length v.
intros. apply v_not_nil_length. apply not_nil. exact H.
Qed.

(****************************************************************)
(* Rend une liste de longueur n dont tous les elements sont x *)

Fixpoint list_const (n : nat) : A -> list A :=

 (*****************)
 fun x : A =>
 match n return (list A) with
 | O => nil
 | S n' => x :: list_const n' x
 end.

Lemma list_const_eq1 : forall x : A, list_const 0 x = nil.
auto with arith. Qed.
Lemma list_const_eq2 :
 forall (n' : nat) (x : A), list_const (S n') x = x :: list_const n' x.
auto with arith. Qed.

Lemma len_list_const : forall (n : nat) (x : A), len (list_const n x) n.
(*******************)
simple induction n. auto with arith. intros. simpl in |- *. auto with arith.
Qed. Hint Resolve len_list_const.

Lemma length_list_const :
 forall (n : nat) (x : A), length (list_const n x) = n.
(**********************)
simple induction n. auto with arith. intros. simpl in |- *. auto with arith.
Qed. Hint Resolve length_list_const.

(****************************************************************)
(* rev: renverse une liste *)

Fixpoint rev (l : list A) : list A :=

 (************************)
 match l return (list A) with
 | nil => nil
 | b :: l' => rev l' ++ b :: nil
 end.

Lemma rev_eq1 : rev nil = nil.
auto with arith. Qed.
Lemma rev_eq2 :
 forall (b : A) (l' : list A), rev (b :: l') = rev l' ++ b :: nil.
auto with arith. Qed.

Lemma rev_eq : forall l n : list A, l = n -> rev l = rev n.
(***********)
intros; replace l with n; auto with arith.
Qed.

Lemma rev_app : forall l n : list A, rev (l ++ n) = rev n ++ rev l.
(************)
simple induction l; auto with arith. intros. simpl in |- *. rewrite H. apply app_assoc_r.
Qed.

Lemma rev_rev : forall l : list A, rev (rev l) = l.
(************)
simple induction l; auto with arith. intros; simpl in |- *. rewrite rev_app. rewrite H. auto with arith.
Qed.

Lemma length_rev : forall l : list A, length (rev l) = length l.
(***************)
simple induction l; auto with arith. intros. simpl in |- *.
rewrite length_app. simpl in |- *. rewrite plus_n_SO. rewrite H. trivial with arith.
Qed.

(****************************************************************)
(* map *)

Fixpoint map (l : list A) : (A -> B) -> list B :=

 (************************)
 fun f : A -> B =>
 match l return (list B) with
 | nil => nil
 | b :: l' => f b :: map l' f
 end.

Lemma length_map :
 forall (l : list A) (f : A -> B), length (map l f) = length l.
simple induction l. auto with arith.
intros. simpl in |- *. rewrite H. trivial with arith.
Qed.

(****************************************************************)
(* Decidabilite *)

Lemma eq_cons :
 forall (l1 l2 : list A) (a1 a2 : A), a1 :: l1 = a2 :: l2 -> l1 = l2.
intros.
change (tail (a1 :: l1) = tail (a2 :: l2)) in |- *.
apply (f_equal (A:=list A)).
exact H.
Qed.
Hint Immediate eq_cons.

(*
Lemma eq_cons2 : (l1,l2:(list A))(a1,a2:A)
		(cons a1 l1)=(cons a2 l2) -> a1=a2.
*)

Lemma not_eq_cons :
 forall (l1 l2 : list A) (a1 a2 : A), l1 <> l2 -> a1 :: l1 <> a2 :: l2.
red in |- *. intros. absurd (l1 = l2). exact H.
apply (eq_cons l1 l2 a1 a2). exact H0.
Qed.

Axiom eq_list_dec : forall l m : list A, {l = m} + {l <> m}.

(*
(Induction l;Induction m). Auto with arith.
(Right;Discriminate).(Right;Discriminate). Intros.
*)

End Lists_compl.