(**
Some useful lemmas, and axiomatization of Theorem 4.7 of "List object with
algebraic structure" (Fiore-Saville, extended version): [Thm47]
**)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.MoreFoundations.Tactics.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.

Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.

Require Import UniMath.CategoryTheory.Chains.Chains.
Require Import UniMath.CategoryTheory.Chains.Adamek.
Require Import UniMath.CategoryTheory.Chains.OmegaCocontFunctors.
Require Import UniMath.CategoryTheory.limits.graphs.colimits.
Require Import UniMath.CategoryTheory.limits.graphs.bincoproducts.
Require Import UniMath.CategoryTheory.limits.graphs.coequalizers.
Require Import UniMath.CategoryTheory.limits.bincoproducts.
Require Import UniMath.CategoryTheory.limits.initial.
Require Import UniMath.CategoryTheory.limits.graphs.eqdiag.
Require Import UniMath.CategoryTheory.FunctorAlgebras.
Require Import UniMath.CategoryTheory.coslicecat.

Local Open Scope cat.

(** Binary product of categories *)
Local Notation "C ⊠ D" := (category_binproduct C D) (at level 38).
Local Notation "( c , d )" := (make_catbinprod c d).
Local Notation "( f #, g )" := (catbinprodmor f g).

Local Infix "×" := pair_functor  : functor_scope .
Local Notation carrier := (alg_carrier _ ).

Delimit Scope functor_scope with F.

(** Theorem 4.7 of "List object with algebraic structure" (extended version)
as an axiom
 *)
Section Theorem47.

  Context {D C B A : category}
          (hsC := homset_property C)(OC : Initial C)(chC : Colims_of_shape nat_graph C)
          (hsA := homset_property A)(chA : Colims_of_shape nat_graph A)
          {J : C ⟶ A}(OJ : isInitial _ (J (InitialObject OC)))
          (omegaJ : is_omega_cocont J)
          {F : D ⊠ C ⟶ C}
          (omegaF : ∏ d , is_omega_cocont (functor_fix_fst_arg _ _ _ F d))
          {G : B ⊠ A ⟶ A}
          (omegaG : ∏ b , is_omega_cocont (functor_fix_fst_arg _ _ _ G b))
          {K : D ⟶ B} (h : F ∙ J ⟹ (K × J)%F ∙ G).

  Let OA : Initial A := make_Initial _ OJ.
  (* (alg_map _ (InitialObject (colimAlgInitial hsV O (Fromega Z) (Vch (initChain O _))))) *)

  Context {a : A}{d : D}(α : A ⟦ G (K d , a) , a ⟧).

  Let iniChd := (initChain OC (functor_fix_fst_arg D C C F d)).

  Let μFd := (InitialObject (colimAlgInitial OC (omegaF d) (chC iniChd))).

  Lemma Thm47 : ∃! (β : A ⟦ J (carrier μFd) , a ⟧),
                h (d , carrier μFd) · # G ( identity _ #, β ) · α  =
                # J (alg_map _ μFd) · β.
  Admitted.

  Definition Thm47_mor : A ⟦ J (carrier μFd) , a ⟧ := pr1 (pr1 Thm47).

  Definition Thm47_commutes
    : h (d , carrier μFd) · # G ( identity _ #, Thm47_mor ) · α  =
      # J (alg_map _ μFd) · Thm47_mor
        := pr2 (pr1 Thm47).

  Lemma Thm47_unique
        {β}
        (eq : h (d , carrier μFd) · # G (identity _ #, β) · α  = # J (alg_map _ μFd) · β)
    : β = Thm47_mor.
  Proof.
    apply path_to_ctr.
    exact eq.
  Qed.

  Lemma Thm47_eq
        {β} (eq : h (d , carrier μFd) · # G ( identity _ #, β ) · α  = # J (alg_map _ μFd) · β)
        {β'} (eq' : h (d , carrier μFd) · # G ( identity _ #, β' ) · α  = # J (alg_map _ μFd) · β')
        : β = β'.
  Proof.
    eapply pathscomp0;[exact (Thm47_unique eq)|].
    apply pathsinv0, (Thm47_unique eq').
  Qed.

End Theorem47.

(** The rest of this file consists of useful lemmas that should be uploaded
 to UniMath at some point. *)

Local Infix ",," := bindelta_pair_functor  : functor_scope .

(** id + id = id *)
Lemma BinCoproductOfIdentities
           {C : category}   {a b : C}
           (ccab : BinCoproduct a b) :
  identity ccab = BinCoproductOfArrows _ ccab ccab (identity a) (identity b).
Proof.
  apply BinCoproduct_endo_is_identity.
  - etrans;[apply BinCoproductOfArrowsIn1|apply id_left].
  - etrans;[apply BinCoproductOfArrowsIn2|apply id_left].
Qed.

(* A version of BinCoproductOfArrows with given bincoproducts
TODO: upload in Unimath
 *)
Definition BinCoproductOfArrows_comp'
           {C : category}   {a b c d x y : C}
           (ccab : BinCoproduct a b)(cccd : BinCoproduct c d)
           (ccxy : BinCoproduct x y)
           (f : C ⟦ a, c ⟧) (f' : C ⟦ b, d ⟧)
(g : C ⟦ c, x ⟧) (g' : C ⟦ d, y ⟧)
  : BinCoproductOfArrows _ ccab cccd f f' ·
    BinCoproductOfArrows _ _ _ g g'
    =
    BinCoproductOfArrows _ _ ccxy (f · g) (f' · g').
Proof.
  apply BinCoproductArrowUnique.
  - rewrite assoc.
    rewrite BinCoproductOfArrowsIn1.
    rewrite <- assoc.
    rewrite BinCoproductOfArrowsIn1.
    apply assoc.
  - rewrite assoc.
    rewrite BinCoproductOfArrowsIn2.
    rewrite <- assoc.
    rewrite BinCoproductOfArrowsIn2.
    apply assoc.
Qed.

Lemma binprod_functor_combine_morphisms {C D E : category} (F : C ⊠ D ⟶ E)
      {c c'} (f : C ⟦ c , c' ⟧)
      {d d'} (g : D ⟦ d , d' ⟧)
  : # F (f #, identity _) · # F (identity _ #, g) = # F (f #, g).
Proof.
  etrans; [apply pathsinv0, functor_comp|].
  apply maponpaths.
  apply dirprod_paths;[apply id_right|apply id_left].
Qed.

Lemma binprod_functor_combine_morphisms_reverse {C D E : category}
      (F : C ⊠ D ⟶ E)
      {c c'} (f : C ⟦ c , c' ⟧)
      {d d'} (g : D ⟦ d , d' ⟧)
  : # F (identity _ #, g) · # F (f #, identity _)  = # F (f #, g).
Proof.
  etrans; [apply pathsinv0, functor_comp|].
  apply maponpaths.
  apply dirprod_paths;[apply id_left|apply id_right].
Qed.

Lemma binprod_functor_swap_morphisms {C D E : category} (F : C ⊠ D ⟶ E)
      {c c'} (f : C ⟦ c , c' ⟧)
      {d d'} (g : D ⟦ d , d' ⟧)
  : # F (f #, identity _) · # F (identity _ #, g) =
    # F (identity _ #, g) · # F (f #, identity _)  .
Proof.
  etrans;[apply binprod_functor_combine_morphisms|].
  apply pathsinv0, binprod_functor_combine_morphisms_reverse.
Qed.

(** ** A pair of functors (F,G) : A  -> C * D is omega cocontinuous if F and G are *)
Section delta_pairfunctors.
(* TODO: upload this to UniMath (omegacocontfunctors)

This is adapted from the section pair_functor
 *)
Context {A C D : category} (F : functor A C) (G : functor A D)
        (hsA := homset_property A)  (hsC := homset_property C) (hsD := homset_property D).
Lemma isColimCocone_delta_pair_functor {gr : graph}
  (HF : ∏ (d : diagram gr A) (c : A) (cc : cocone d c) (h : isColimCocone d c cc),
        isColimCocone _ _ (mapcocone F d cc))
  (HG : ∏ (d : diagram gr A) (c : A) (cc : cocone d c) (h : isColimCocone d c cc),
        isColimCocone _ _ (mapcocone G d cc)) :
  ∏ (d : diagram gr A) (cd : A ) (cc : cocone d cd),
  isColimCocone _ _ cc ->
  isColimCocone _ _ (mapcocone (bindelta_pair_functor F G) d cc).
Proof.
intros cAB ml ccml Hccml xy ccxy.
transparent assert (cFAX : (cocone (mapdiagram F cAB) (pr1 xy))).
{ use make_cocone.
  - intro n; apply (pr1 (pr1 ccxy n)).
  - abstract (intros m n e; apply (maponpaths dirprod_pr1 (pr2 ccxy m n e))).
}
transparent assert (cGBY : (cocone (mapdiagram G cAB) (pr2 xy))).
{ use make_cocone.
  - intro n; apply (pr2 (pr1 ccxy n)).
  - abstract (intros m n e; apply (maponpaths dirprod_pr2 (pr2 ccxy m n e))).
}
destruct (HF _ _ _ Hccml _ cFAX) as [[f hf1] hf2].
destruct (HG _ _ _ Hccml _ cGBY) as [[g hg1] hg2].
simpl in *.
use tpair.
- apply (tpair _ (f,,g)).
  (intro n; unfold catbinprodmor, compose; simpl;
  clear hf2 hg2;
   specialize (hf1 n);
   specialize (hg1 n);
   cbn in hf1, hg1;

  rewrite hf1, hg1; apply idpath).
- abstract (intro t; apply subtypePath; simpl;
             [ intro x; apply impred; intro; apply isaset_dirprod; [ apply hsC | apply hsD ]
             | induction t as [[f1 f2] p]; simpl in *; apply pathsdirprod;
               [ apply (maponpaths pr1 (hf2 (f1,, (λ n, maponpaths pr1 (p n)))))
               | apply (maponpaths pr1 (hg2 (f2,, (λ n, maponpaths dirprod_pr2 (p n)))))]]).
Defined.

Lemma is_cocont_delta_pair_functor (HF : is_cocont F) (HG : is_cocont G) :
  is_cocont (bindelta_pair_functor F G).
Proof.
intros gr cAB ml ccml Hccml.
now apply isColimCocone_delta_pair_functor; [apply HF|apply HG|].
Defined.

Lemma is_omega_cocont_delta_pair_functor (HF : is_omega_cocont F) (HG : is_omega_cocont G) :
  is_omega_cocont (bindelta_pair_functor F G).
Proof.
now intros cAB ml ccml Hccml; apply isColimCocone_delta_pair_functor.
Defined.

End delta_pairfunctors.

Definition functor_fix_fst_arg'  (C D E : category) (F : C ⊠ D ⟶ E) (c : C) : D ⟶ E :=
  ((constant_functor _ _ c ,, functor_identity _ )%F ∙ F).
Definition functor_fix_snd_arg'  (C D E : category) (F : C ⊠ D ⟶ E) (d : D) : C ⟶ E :=
  ((functor_identity _  ,, constant_functor _ _ d  )%F ∙ F).

Section FunctorFixCocont.
  Context {C D E : category}
          (hsD := homset_property D)
          (hsC := homset_property C)
          (hsE := homset_property E)
         {F :  C ⊠ D ⟶ E}(omegaF : is_omega_cocont F).

Lemma is_omega_cocont_fix_fst_arg' c : is_omega_cocont (functor_fix_fst_arg' _ _ _ F c).
Proof.
  apply is_omega_cocont_functor_composite.
  - apply is_omega_cocont_delta_pair_functor.
    + apply is_omega_cocont_constant_functor.
    + apply is_omega_cocont_functor_identity.
  - exact omegaF.
Qed.

Definition is_omega_cocont_fix_fst_arg c : is_omega_cocont (functor_fix_fst_arg _ _ _ F c) :=
  is_omega_cocont_fix_fst_arg' c.

Lemma is_omega_cocont_fix_snd_arg' c : is_omega_cocont (functor_fix_snd_arg' _ _ _ F c).
Proof.
  apply is_omega_cocont_functor_composite.
  - apply is_omega_cocont_delta_pair_functor.
    + apply is_omega_cocont_functor_identity.
    + apply is_omega_cocont_constant_functor.
  - exact omegaF.
Qed.

Definition is_omega_cocont_fix_snd_arg c : is_omega_cocont (functor_fix_snd_arg _ _ _ F c) :=
  is_omega_cocont_fix_snd_arg' c.

End  FunctorFixCocont.

Lemma cocont_preserves_isBinCoproduct
      {C : category}
      {D : category}
      {F : functor C D}
      (cocontF : is_cocont F)
      {A B : C} (ccAB : BinCoproduct A B) :
  isBinCoproduct D (F A) (F B) (F ccAB)
                 (# F (BinCoproductIn1 ccAB))
                 (# F (BinCoproductIn2 ccAB)).
Proof.
  set (Io := pr2 ccAB).
  cbn in Io.
  red in cocontF.
  transparent assert (h : (BinCoproductCocone (F A) (F B))).
  {
    red.
    eapply (eq_diag_liftcolimcocone (C := D)).
    - unshelve apply mapdiagram_bincoproduct_eq_diag.
    - eapply make_ColimCocone.
      eapply cocontF.
      apply limits_isBinCoproductCocone_from_isBinCoproduct.
      + exact (isBinCoproduct_BinCoproduct _ ccAB).
  }
  apply limits_isBinCoproduct_from_isBinCoproductCocone.
  red.
  generalize (pr2 h).
  cbn.
  apply transportf.
  apply cocone_paths.
  use bool_rect; apply idpath.
Qed.

Lemma cocont_preserves_isInitial
      {C : category}
      {D : category}
      {F : functor C D}
      (cocontF : is_cocont F)
      {o : C}(Io : isInitial _ o) : isInitial D (F o).
Proof.
  transparent assert (h : (initial.Initial D)).
  {
    eapply (eq_diag_liftcolimcocone (C := D)).
    - eapply (graphs.initial.empty_graph_eq_diag ).
    - eapply make_ColimCocone.
      apply initial.equiv_isInitial1 in Io.
      eapply cocontF in Io.
      exact Io.
  }
  apply initial.equiv_isInitial2.
  exact (initial.isInitial_Initial h).
Qed.

(* TODO: upload in UniMath coslicecat *)
Section coslice_precat_theory.

Context {C : category}  (x : C)(sets : ∏ y, isaset (x --> y)).

Local Notation "X / C" := (coslice_precat C X sets).
(** The forgetful functor from C/x to C *)
Definition coslicecat_to_cat : (x / C) ⟶ C.
Proof.
  use make_functor.
  + use tpair.
    - apply pr1.
    - intros a b; apply pr1.
  + abstract ( split; [intro; apply idpath | red; intros; apply idpath] ).
Defined.

End coslice_precat_theory.

(* TODO: move to complememts, and use it more often
 for example for the swap stuff in Complements *)
Lemma binprod_change_mor {C D E : category }
      (F : C ⊠ D ⟶ E)
      {c1 c2 c2' c3 : C}
      (f : c1 --> c2)(g : c2 --> c3)
      (f' : c1 --> c2')(g' : c2' --> c3)
      {d1 d2 d2' d3 : D}
      (u : d1 --> d2)(v : d2 --> d3)
      (u' : d1 --> d2')(v' : d2' --> d3)
      (eqc : f · g = f' · g')
      (eqd : u · v = u' · v')
  :
    # F (f #, u) ·
    # F (g #, v)
    =
    # F (f' #, u') ·
    # F (g' #, v').
Proof.
  do 2 rewrite <- (functor_comp F (_ #, _)).
  cbn.
  rewrite eqc , eqd.
  apply idpath.
Qed.


(* File: Derivations.v  (last edited on 1/11/2000) (c) Klaus Weich  *)

Require Export Forms.

(*******   Derivations    *****************************************)

Inductive proof_term : Set :=
  | Var : nat -> proof_term
  | Efq : proof_term -> form -> proof_term
  | Abs : form -> proof_term -> proof_term
  | App : form -> proof_term -> proof_term -> proof_term
  | Pair : proof_term -> proof_term -> proof_term
  | PrL : form -> proof_term -> proof_term
  | PrR : form -> proof_term -> proof_term
  | OrFL : proof_term -> form -> proof_term
  | OrFR : proof_term -> form -> proof_term
  | Cas :
      form -> form -> proof_term -> proof_term -> proof_term -> proof_term
  | Shift : proof_term -> proof_term.

Inductive derives : flist -> proof_term -> form -> Prop :=
  | ByAssumption :
      forall (context : flist) (n : nat) (a : form),
      my_nth form n context a -> derives context (Var n) a
  | ByAbsurdity :
      forall (context : flist) (t : proof_term) (a : form),
      derives context t Falsum -> derives context (Efq t a) a
  | ImpIntro :
      forall (context : flist) (a : form) (r : proof_term) (b : form),
      derives (a :: context) r b -> derives context (Abs a r) (Imp a b)
  | ImpElim :
      forall (context : flist) (r s : proof_term) (a b : form),
      derives context r (Imp a b) ->
      derives context s a -> derives context (App a r s) b
  | AndFIntro :
      forall (context : flist) (r s : proof_term) (a b : form),
      derives context r a ->
      derives context s b -> derives context (Pair r s) (AndF a b)
  | AndFElimL :
      forall (context : flist) (r : proof_term) (a b : form),
      derives context r (AndF a b) -> derives context (PrL b r) a
  | AndFElimR :
      forall (context : flist) (r : proof_term) (a b : form),
      derives context r (AndF a b) -> derives context (PrR a r) b
  | OrFIntroL :
      forall (context : flist) (r : proof_term) (a b : form),
      derives context r a -> derives context (OrFL r b) (OrF a b)
  | OrFIntroR :
      forall (context : flist) (r : proof_term) (a b : form),
      derives context r b -> derives context (OrFR r a) (OrF a b)
  | OrFElim :
      forall (context : flist) (r s t : proof_term) (a b c : form),
      derives context r (OrF a b) ->
      derives (a :: context) s c ->
      derives (b :: context) t c -> derives context (Cas a b r s t) c
  | ShiftIntro :
      forall (context : flist) (r : proof_term) (a b : form),
      derives context r b -> derives (a :: context) (Shift r) b.

Lemma derives_rec :
 forall P : flist -> proof_term -> form -> Set,
 (forall (context : flist) (n : nat) (a : form),
  my_nth form n context a -> P context (Var n) a) ->
 (forall (context : flist) (t : proof_term) (a : form),
  derives context t Falsum -> P context t Falsum -> P context (Efq t a) a) ->
 (forall (context : flist) (a : form) (r : proof_term) (b : form),
  derives (a :: context) r b ->
  P (a :: context) r b -> P context (Abs a r) (Imp a b)) ->
 (forall (context : flist) (r s : proof_term) (a b : form),
  derives context r (Imp a b) ->
  P context r (Imp a b) ->
  derives context s a -> P context s a -> P context (App a r s) b) ->
 (forall (context : flist) (r s : proof_term) (a b : form),
  derives context r a ->
  P context r a ->
  derives context s b -> P context s b -> P context (Pair r s) (AndF a b)) ->
 (forall (context : flist) (r : proof_term) (a b : form),
  derives context r (AndF a b) ->
  P context r (AndF a b) -> P context (PrL b r) a) ->
 (forall (context : flist) (r : proof_term) (a b : form),
  derives context r (AndF a b) ->
  P context r (AndF a b) -> P context (PrR a r) b) ->
 (forall (context : flist) (r : proof_term) (a b : form),
  derives context r a -> P context r a -> P context (OrFL r b) (OrF a b)) ->
 (forall (context : flist) (r : proof_term) (a b : form),
  derives context r b -> P context r b -> P context (OrFR r a) (OrF a b)) ->
 (forall (context : flist) (r s t : proof_term) (a b c : form),
  derives context r (OrF a b) ->
  P context r (OrF a b) ->
  derives (a :: context) s c ->
  P (a :: context) s c ->
  derives (b :: context) t c ->
  P (b :: context) t c -> P context (Cas a b r s t) c) ->
 (forall (context : flist) (r : proof_term) (a b : form),
  derives context r b -> P context r b -> P (a :: context) (Shift r) b) ->
 forall (context : flist) (t : proof_term) (a : form),
 derives context t a -> P context t a.
intros P var efq abs app pari prl prr orl orr cas shift context t.
generalize context; clear context.
elim t; clear t.

intros n context a der.
apply var.
inversion_clear der; assumption.

intros t ih a context b der.
cut (a = b).
intros eq_a;  rewrite eq_a.
apply efq.
inversion_clear der; assumption.
apply ih.
inversion_clear der; assumption.
inversion_clear der; trivial.

intros a t ih context b.
case b; clear b.
intros der_t; elimtype False; inversion_clear der_t.
intros i der_t; elimtype False; inversion_clear der_t.
intros b0 b1 der_t; elimtype False; inversion_clear der_t.
intros b0 b1 der_t; elimtype False; inversion_clear der_t.
intros b0 b1 der_t.
cut (a = b0).
intros eq_a;  rewrite eq_a.
apply abs.
inversion_clear der_t; assumption.
apply ih.
inversion_clear der_t; assumption.
inversion_clear der_t; trivial.

intros a s ih_s t ih_t context b der.
apply app.
inversion_clear der; assumption.
apply ih_s.
inversion_clear der; assumption.
inversion_clear der; assumption.
apply ih_t.
inversion_clear der; assumption.

intros s ih_s t ih_t context a.
case a; clear a.
intros der; elimtype False; inversion_clear der.
intros i der; elimtype False; inversion_clear der.
intros a0 a1 der.
apply pari.
inversion_clear der; assumption.
apply ih_s.
inversion_clear der; assumption.
inversion_clear der; assumption.
apply ih_t.
inversion_clear der; assumption.
intros a0 a1 der; elimtype False; inversion_clear der.
intros a0 a1 der; elimtype False; inversion_clear der.

intros a s ih context b der.
apply prl.
inversion_clear der; assumption.
apply ih.
inversion_clear der; assumption.

intros a s ih context b der.
apply prr.
inversion_clear der; assumption.
apply ih.
inversion_clear der; assumption.

intros s ih a context b.
case b; clear b.
intros der; elimtype False; inversion_clear der.
intros i der; elimtype False; inversion_clear der.
intros b0 b1 der; elimtype False; inversion_clear der.
intros b0 b1 der.
cut (a = b1).
intros eq_a;  rewrite eq_a.
apply orl.
inversion_clear der; assumption.
apply ih.
inversion_clear der; assumption.
inversion_clear der; trivial.
intros b0 b1 der; elimtype False; inversion_clear der.

intros s ih a context b.
case b; clear b.
intros der; elimtype False; inversion_clear der.
intros i der; elimtype False; inversion_clear der.
intros b0 b1 der; elimtype False; inversion_clear der.
intros b0 b1 der.
cut (a = b0).
intros eq_a;  rewrite eq_a.
apply orr.
inversion_clear der; assumption.
apply ih.
inversion_clear der; assumption.
inversion_clear der; trivial.
intros b0 b1 der; elimtype False; inversion_clear der.

intros a b r ih_r s ih_s t ih_t context c der.
apply cas.
inversion_clear der; assumption.
apply ih_r.
inversion_clear der; assumption.
inversion_clear der; assumption.
apply ih_s.
inversion_clear der; assumption.
inversion_clear der; assumption.
apply ih_t.
inversion_clear der; assumption.

intros t ih context a.
case context; clear context.
intros der; elimtype False; inversion_clear der.
intros b context der.
apply shift.
inversion_clear der; assumption.
apply ih.
inversion_clear der; assumption.
Qed.


(** Camera of discardable fractions.

    This is a generalisation of the fractional camera where elements can
    represent both ownership of a fraction (as in the fractional camera) and the
    knowledge that a fraction has been discarded.

    Ownership of a fraction is denoted [DfracOwn q] and behaves identically to
    [q] of the fractional camera.

    Knowledge that a fraction has been discarded is denoted [DfracDiscarded].
    This elements is its own core, making ownership persistent.

    One can make a frame preserving update from _owning_ a fraction to _knowing_
    that the fraction has been discarded.

    Crucially, ownership over 1 is an exclusive element just as it is in the
    fractional camera. Hence owning 1 implies that no fraction has been
    discarded. Conversely, knowing that a fraction has been discarded implies
    that no one can own 1. And, since discarding is an irreversible operation,
    it also implies that no one can own 1 in the future *)
From Coq.QArith Require Import Qcanon.
From iris.algebra Require Export cmra.
From iris.algebra Require Import proofmode_classes updates frac.
From iris Require Import options.

(** An element of dfrac denotes ownership of a fraction, knowledge that a
    fraction has been discarded, or both. Note that [DfracBoth] can be written
    as [DfracOwn q ⋅ DfracDiscarded]. This should be used instead
    of [DfracBoth] which is for internal use only. *)
Inductive dfrac :=
  | DfracOwn : Qp → dfrac
  | DfracDiscarded : dfrac
  | DfracBoth : Qp → dfrac.

Global Instance DfracOwn_inj : Inj (=) (=) DfracOwn.
Proof. by injection 1. Qed.

Global Instance DfracBoth_inj : Inj (=) (=) DfracBoth.
Proof. by injection 1. Qed.

Section dfrac.

  Canonical Structure dfracO := leibnizO dfrac.

  Implicit Types p q : Qp.

  Implicit Types x y : dfrac.

  (** An element is valid as long as the sum of its content is less than one. *)
  Instance dfrac_valid : Valid dfrac := λ x,
    match x with
    | DfracOwn q => q ≤ 1%Qp
    | DfracDiscarded => True
    | DfracBoth q => q < 1%Qp
    end%Qc.

  (** As in the fractional camera the core is undefined for elements denoting
     ownership of a fraction. For elements denoting the knowledge that a fraction has
     been discarded the core is the identity function. *)
  Instance dfrac_pcore : PCore dfrac := λ x,
    match x with
    | DfracOwn q => None
    | DfracDiscarded => Some DfracDiscarded
    | DfracBoth q => Some DfracDiscarded
    end.

  (** When elements are combined, ownership is added together and knowledge of
     discarded fractions is combined with the max operation. *)
  Instance dfrac_op : Op dfrac := λ x y,
    match x, y with
    | DfracOwn q, DfracOwn q' => DfracOwn (q + q')
    | DfracOwn q, DfracDiscarded => DfracBoth q
    | DfracOwn q, DfracBoth q' => DfracBoth (q + q')
    | DfracDiscarded, DfracOwn q' => DfracBoth q'
    | DfracDiscarded, DfracDiscarded => DfracDiscarded
    | DfracDiscarded, DfracBoth q' => DfracBoth q'
    | DfracBoth q, DfracOwn q' => DfracBoth (q + q')
    | DfracBoth q, DfracDiscarded => DfracBoth q
    | DfracBoth q, DfracBoth q' => DfracBoth (q + q')
    end.

  Lemma dfrac_op_own q p : DfracOwn p ⋅ DfracOwn q = DfracOwn (p + q).
  Proof. done. Qed.

  Lemma dfrac_op_discarded :
    DfracDiscarded ⋅ DfracDiscarded = DfracDiscarded.
  Proof. done. Qed.

  Lemma dfrac_own_included q p : DfracOwn q ≼ DfracOwn p ↔ (q < p)%Qc.
  Proof.
    rewrite Qp_lt_sum. split.
    - rewrite /included /op /dfrac_op. intros [[o| |?] [= ->]]. by exists o.
    - intros [o ->]. exists (DfracOwn o). by rewrite dfrac_op_own.
  Qed.

  (* [dfrac] does not have a unit so reflexivity is not for granted! *)
  Lemma dfrac_discarded_included :
    DfracDiscarded ≼ DfracDiscarded.
  Proof. exists DfracDiscarded. done. Qed.

  Definition dfrac_ra_mixin : RAMixin dfrac.
  Proof.
    split; try apply _.
    - intros [?| |?] y cx <-; intros [= <-]; eexists _; done.
    - intros [?| |?] [?| |?] [?| |?];
        rewrite /op /dfrac_op 1?assoc 1?assoc; done.
    - intros [?| |?] [?| |?];
        rewrite /op /dfrac_op 1?(comm Qp_plus); done.
    - intros [?| |?] cx; rewrite /pcore /dfrac_pcore; intros [= <-];
        rewrite /op /dfrac_op; done.
    - intros [?| |?] ? [= <-]; done.
    - intros [?| |?] [?| |?] ? [[?| |?] [=]] [= <-]; eexists _; split; try done;
        apply dfrac_discarded_included.
    - intros [q| |q] [q'| |q']; rewrite /op /dfrac_op /valid /dfrac_valid; try done.
      * apply (Qp_plus_weak_r _ _ 1).
      * apply Qclt_le_weak.
      * move=> /Qclt_le_weak. apply Qcle_trans. etrans; last apply Qp_le_plus_l. done.
      * apply Qclt_trans. apply Qp_lt_sum. eauto.
      * apply Qclt_trans. apply Qp_lt_sum. eauto.
  Qed.
  Canonical Structure dfracR := discreteR dfrac dfrac_ra_mixin.

  Global Instance dfrac_cmra_discrete : CmraDiscrete dfracR.
  Proof. apply discrete_cmra_discrete. Qed.

  Global Instance dfrac_full_exclusive : Exclusive (DfracOwn 1).
  Proof.
    intros [q| |q];
      rewrite /op /cmra_op -cmra_discrete_valid_iff /valid /cmra_valid /=.
    - apply (Qp_not_plus_ge 1 q).
    - intros []%(irreflexivity _).
    - move=> /Qclt_le_weak. apply (Qp_not_plus_ge 1 q).
  Qed.

  Global Instance dfrac_cancelable q : Cancelable (DfracOwn q).
  Proof.
    apply: discrete_cancelable.
    intros [q1| |q1] [q2| |q2] _; rewrite /op /cmra_op; simpl;
      try by intros [= ->].
    - by intros ->%(inj _)%(inj _).
    - done.
    - intros Hq%(inj _). symmetry in Hq. apply Qp_plus_id_free in Hq. done.
    - by intros Hq%(inj _)%Qp_plus_id_free.
    - by intros ->%(inj _)%(inj _).
  Qed.

  Global Instance frac_id_free q : IdFree (DfracOwn q).
  Proof.
    intros [q'| |q'] _; rewrite /op /cmra_op; simpl; try by intros [=].
    by intros [= ?%Qp_plus_id_free].
  Qed.

  Global Instance dfrac_discarded_core_id : CoreId DfracDiscarded.
  Proof. by constructor. Qed.

  Lemma dfrac_valid_own p : ✓ DfracOwn p ↔ (p ≤ 1%Qp)%Qc.
  Proof. done. Qed.

  Lemma dfrac_valid_discarded p : ✓ DfracDiscarded.
  Proof. done. Qed.

  Lemma dfrac_valid_own_discarded q :
    ✓ (DfracOwn q ⋅ DfracDiscarded) ↔ (q < 1%Qp)%Qc.
  Proof. done. Qed.

  Global Instance dfrac_is_op q q1 q2 :
    IsOp q q1 q2 →
    IsOp' (DfracOwn q) (DfracOwn q1) (DfracOwn q2).
  Proof. rewrite /IsOp' /IsOp dfrac_op_own=>-> //. Qed.

  (** Discarding a fraction is a frame preserving update. *)
  Lemma dfrac_discard_update q : DfracOwn q ~~> DfracDiscarded.
  Proof.
    intros n [[q'| |q']|];
      rewrite /op /cmra_op -!cmra_discrete_valid_iff /valid /cmra_valid /=.
    - intros [Hq|Hq]%Qcle_lt_or_eq.
      + etrans; last eassumption. change (q' < (q + q')%Qp)%Qc. apply Qp_lt_sum.
        rewrite {1}comm. eauto.
      + change (q' < 1%Qp)%Qc. apply Qp_lt_sum. exists q.
        rewrite (comm Qp_plus). apply Qp_eq. simpl. rewrite Hq. done.
    - done.
    - apply Qclt_trans. change (q' < (q + q')%Qp)%Qc. apply Qp_lt_sum.
      rewrite {1}comm. eauto.
    - done.
  Qed.

End dfrac.


(** MMaps Library : the demo *)

(** Author : Pierre Letouzey (Université de Paris - INRIA),
    adapted from earlier works in Coq Standard Library, see README.md.
    Licence : LGPL 2.1, see file LICENSE. *)

From Coq Require Import ZArith String Orders List.
From Tries.MMaps Require Import Tries.MMaps.

Set Implicit Arguments.
Open Scope string.
Open Scope Z.
Import ListNotations.

(** This MMaps library provides finite maps (e.g. key/value structure).
    It is an improved version of the former FMaps library, which is
    itself derived from the OCaml Map library.
    The "M" in the current name is for Module (and to be different
    from FMaps), nothing to see with the unix system call "mmap". *)

(** In these maps, we associate keys to values.
    The key type is rigidly fixed at the creation of the module
    (usually by giving an OrderedType module to the creating functor).
    while the value type is polymorphic and may vary from map to map,
    even in the same MMaps instance. *)

(** The OrderedType notion is the one of Coq Stdlib,
    already used in [MSets]. The main function is [compare],
    which has a ternary [comparison] output, and is specified
    w.r.t. an equivalence [eq] and a strict order [lt]. *)

Print Orders.OrderedType.
Print comparison.
Print CompareSpec.

(** Many datatype modules of Coq are already implementing OrderedType.
    For instance, let's build some maps with [nat] numbers as keys,
    and then maps with [Z] numbers as keys. *)

Module NatMaps := Tries.MMaps.RBT.Make(Nat).
Module ZM := Tries.MMaps.RBT.Make(Z).

(* Let's play with them : *)

Definition map1 :=
  ZM.add 3 "yes" (ZM.add 0 "no" (ZM.add 2 "foo" ZM.empty)).
Definition map2 :=
  ZM.add 3 [1;2] (ZM.add 0 [3;4;5] (ZM.add 7 [] ZM.empty)).

Compute ZM.find 3 map1.
Compute ZM.find 3 map2.
Compute ZM.bindings map1.
Compute ZM.bindings (ZM.remove 0 map1).

(* Some examples of more advanced operations : *)

Compute ZM.fold (fun _ => String.append) map1 "".

Compute ZM.bindings (ZM.map (@List.length Z) map2).

Definition reconciliate(z:Z)(o:option string)(o':option (list Z)) :=
 match o,o' with None, Some _ => Some "new" | _,_ => o end.

Definition map3 := ZM.merge reconciliate map1 map2.
Compute ZM.bindings map3.

(* ZM also provides some basic properties, for instance: *)

Check (ZM.cardinal_spec map1).
(* The number of bindings in [map1] is the length of [bindings map1]. *)

Check (ZM.bindings_spec2 map1).
(* bindings always returns a sorted list
   with respect to the underlying order on keys. *)

(* The ZM.t type for maps is meant to be used as an abstract type
   since it will vary among the different implementations of Tries.MMaps.
   An ZM.t can and should always be inspected by using [find],
   [bindings], etc.
   But for once, let's have a look at the raw aspect of a map: *)
Compute map1.
(* Here for RBT (Red-Black-Tree), a map is a record combining
   a tree (field ZM.this) and a proof (field ZM.ok). *)

(* Note that the proof part will grow at each operation of the map.
   In order to avoid that, we can work on the underlying "raw"
   datatype (i.e. without built-in invariants). *)

Module R:=ZM.Raw.

Definition raw1 := R.add 3 "yes" (R.add 0 "no" (R.add 2 "foo" (R.empty _))).

Compute raw1.
Compute (R.bindings raw1).

(* But then proving properties is a bit more complex. *)

Check (@R.bindings_spec2 _ raw1 _).

(* The second "_" is a proof that raw1 is "Ok". Fortunately, the system
   has infered it here via some class resolution, and it should be
   the case when using the provided operations. If you have built
   your own map without using the provided operations, you could
   consider the "isok" boolean function to check it, and [Mkt_bool]
   to "repack" it into a map with correctness proof. *)

Compute R.isok raw1.
Check (eq_refl : R.isok raw1 = true).
Check (@ZM.Mkt_bool _ raw1 eq_refl).

(** * Some more intense tests. *)

Fixpoint multiples (m:Z)(start:Z)(n:nat) {struct n} : list Z :=
  match n with
   | O => nil
   | S n => start::(multiples m (m+start) n)
  end.

Eval compute in (multiples 2 0 200%nat).

Definition bigmap1 :=
  fold_right (fun z => ZM.add z z) ZM.empty (multiples 2 0 400%nat).
Definition bigmap2 :=
  fold_right (fun z => ZM.add z z) ZM.empty (multiples 3 0 400%nat).

Definition both (z:Z)(o:option Z)(o':option Z) :=
 match o,o' with Some _, Some _ => o | _,_=>None end.
Time Compute ZM.bindings (ZM.merge both bigmap1 bigmap2).

Definition bigmap3 :=
  fold_right (fun z => ZM.add z z) ZM.empty (multiples 2 0 (100*100)%nat).
Definition bigmap4 :=
  fold_right (fun z => ZM.add z z) ZM.empty (multiples 3 0 (100*100)%nat).
Time Compute ZM.bindings (ZM.merge both bigmap3 bigmap4).

(** * the Facts *)

(* The properties provided by ZM are deliberately minimalistic.
   They correspond to the minimal specifications present in Interface.S.
   This way, building new implementations is relatively simple.
   Now, lots of additional facts can be derived from this common interface. *)

Module ZMF := Tries.MMaps.Facts.Properties Z ZM.

(* It contains mainly rephrasing of the specifications. *)
Check ZMF.add_1.
Check ZMF.add_b.

(* And some basic things about the operations. *)
Check ZMF.cardinal_notin_add.

(* Also useful: induction principles *)
Check ZMF.map_induction.

(* And lot of stuff concerning the hard-to-handle [fold] function *)
Check ZMF.fold_add.

(* Concerning [compare], we need a ternary decidable comparison
 over datas. We hence diverge slightly apart from Ocaml, by placing
 this [compare] in a separate functor requiring 2 [OrderedType],
 one for the keys and one for the datas, see Interface.Sord
 and for instance RBT.Make_ord *)

(** * The Weak Maps *)

(* Sometimes, one may need finite sets and maps over a base type
   that does not come with a decidable order. As long as this type
   can still be equipped with a decidable equality, the weak
   interface [Interface.WS] and its implementation [Tries.MMaps.WeakList]
   provide such structures.
*)

Module W := Tries.MMaps.WeakList.Make(Z).

(* Of course, we cannot provide efficient functions anymore : the
   underlying structure is unsorted lists (but without redundancies). *)

Compute W.bindings (W.add 1 "yes" (W.add 3 "no" (W.add 2 "foo" W.empty))).

(* For now, [Interface.WS] provides the same operations as [Interface.S]
   (minus [compare]), and the only different specification concerns [bindings],
   which isn't sorted, but only without redundancies. *)


Require Import Gappa_common.
Require Import Gappa_pred_nzr.

Lemma Rabs_def2b :
  forall x a : R, (Rabs x <= a)%R -> (-a <= x <= a)%R.
Proof.
intros x a H.
split.
case (Rcase_abs x); intros.
rewrite Rabs_left with (1 := r) in H.
rewrite <- (Ropp_involutive x).
apply Ropp_le_contravar with (1 := H).
apply Rle_trans with R0.
rewrite <- Ropp_0.
apply Ropp_le_contravar.
apply Rle_trans with (2 := H).
apply Rabs_pos.
apply Rge_le with (1 := r).
apply Rle_trans with (2 := H).
apply RRle_abs.
Qed.

Theorem neg_a :
  forall x : R, forall zi : FF,
  ABS x zi ->
  ABS (-x) zi.
Proof.
intros x zi Hx.
unfold ABS.
now rewrite Rabs_Ropp.
Qed.

Definition bnd_of_abs_helper (xi zi : FF) :=
 Fle2 (lower zi) (Fopp2 (upper xi)) &&
 Fle2 (upper xi) (upper zi).

Theorem bnd_of_abs :
 forall x : R, forall xi zi : FF,
 ABS x xi ->
 bnd_of_abs_helper xi zi = true ->
 BND x zi.
Proof.
intros x xi zi Hx Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fle2_correct _ _ H1). rewrite Fopp2_correct. fold float2R. clear H1. intro H1.
generalize (Fle2_correct _ _ H2). clear H2. intro H2.
assert (H : (-(upper xi) <= x <= (upper xi))%R).
apply (Rabs_def2b _ _ (proj2 (proj2 Hx))).
split.
apply Rle_trans with (1 := H1) (2 := proj1 H).
apply Rle_trans with (1 := proj2 H) (2 := H2).
Qed.

Theorem abs_of_uabs :
 forall x : R, forall zi : FF,
 BND (Rabs x) zi ->
 Fpos0 (lower zi) = true ->
 ABS x zi.
Proof.
intros x zi Hx Hb.
generalize (Fpos0_correct _ Hb). clear Hb. intro H1.
exact (conj H1 Hx).
Qed.

Theorem uabs_of_abs :
 forall x : R, forall zi : FF,
 ABS x zi ->
 BND (Rabs x) zi.
Proof.
intros x zi (_,Hx2).
exact Hx2.
Qed.

Definition abs_of_bnd_p_helper (xi zi : FF) :=
 Fpos0 (lower zi) &&
 Fle2 (lower zi) (lower xi) &&
 Fle2 (upper xi) (upper zi).

Theorem abs_of_bnd_p :
 forall x : R, forall xi zi : FF,
 BND x xi ->
 abs_of_bnd_p_helper xi zi = true ->
 ABS x zi.
Proof.
intros x xi zi Hx Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fpos0_correct _ H1). clear H1. intro H1.
generalize (Fle2_correct _ _ H2). clear H2. intro H2.
generalize (Fle2_correct _ _ H3). clear H3. intro H3.
split.
exact H1.
apply IRabs_p with (2 := H2) (3 := H3) (4 := Hx).
apply Rle_trans with (1 := H1) (2 := H2).
Qed.

Definition abs_of_bnd_o_helper (xi zi : FF) :=
 Fis0 (lower zi) &&
 Fle2 (upper xi) (upper zi) &&
 Fle2 (Fopp2 (lower xi)) (upper zi).

Theorem abs_of_bnd_o :
 forall x : R, forall xi zi : FF,
 BND x xi ->
 abs_of_bnd_o_helper xi zi = true ->
 ABS x zi.
Proof.
intros x xi zi Hx Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fis0_correct _ H1). clear H1. intro H1.
generalize (Fle2_correct _ _ H2). clear H2. intro H2.
generalize (Fle2_correct _ _ H3). rewrite Fopp2_correct. clear H3. intro H3.
split.
rewrite H1.
apply Rle_refl.
apply IRabs_o with (2 := H3) (3 := H2) (4 := Hx).
rewrite H1.
apply Rle_refl.
Qed.

Definition abs_of_bnd_n_helper (xi zi : FF) :=
 Fpos0 (lower zi) &&
 Fle2 (lower zi) (Fopp2 (upper xi)) &&
 Fle2 (Fopp2 (lower xi)) (upper zi).

Theorem abs_of_bnd_n :
 forall x : R, forall xi zi : FF,
 BND x xi ->
 abs_of_bnd_n_helper xi zi = true ->
 ABS x zi.
Proof.
intros x xi zi Hx Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fpos0_correct _ H1). clear H1. intro H1.
generalize (Fle2_correct _ _ H2). rewrite Fopp2_correct. clear H2. intro H2.
generalize (Fle2_correct _ _ H3). rewrite Fopp2_correct. clear H3. intro H3.
split.
exact H1.
apply IRabs_n with (2 := H2) (3 := H3) (4 := Hx).
apply Ropp_le_cancel.
rewrite Ropp_0.
apply Rle_trans with (1 := H1) (2 := H2).
Qed.

Definition abs_subset_helper (xi zi : FF) :=
 Fpos0 (lower zi) &&
 Fle2 (lower zi) (lower xi) &&
 Fle2 (upper xi) (upper zi).

Theorem abs_subset :
 forall x : R, forall xi zi : FF,
 ABS x xi ->
 abs_subset_helper xi zi = true ->
 ABS x zi.
Proof.
intros x xi zi (Hx1,Hx2) Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fpos0_correct _ H1). clear H1. intro H1.
generalize (Fle2_correct _ _ H2). clear H2. intro H2.
generalize (Fle2_correct _ _ H3). clear H3. intro H3.
split.
exact H1.
apply IRsubset with (1 := H2) (2 := H3) (3 := Hx2).
Qed.

Definition intersect_aa_helper (xf yf : float2) (zi : FF) :=
 Fpos0 (lower zi) &&
 Fle2 (lower zi) yf &&
 Fle2 xf (upper zi).

Theorem intersect_aa :
 forall z : R, forall xi yi zi : FF,
 ABS z xi -> ABS z yi ->
 intersect_aa_helper (upper xi) (lower yi) zi = true ->
 ABS z zi.
Proof.
intros z xi yi zi Hx Hy Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fpos0_correct _ H1). clear H1. intro H1.
generalize (Fle2_correct _ _ H2). clear H2. intro H2.
generalize (Fle2_correct _ _ H3). clear H3. intro H3.
split.
exact H1.
split.
apply Rle_trans with (1 := H2) (2 := proj1 (proj2 Hy)).
apply Rle_trans with (1 := proj2 (proj2 Hx)) (2 := H3).
Qed.

Theorem absurd_intersect_aa :
 forall z : R, forall xi yi : FF,
 ABS z xi -> ABS z yi ->
 Flt2 (upper xi) (lower yi) = true ->
 False.
Proof.
intros z xi yi Hx Hy Hb.
generalize (Flt2_correct _ _ Hb). clear Hb. intro H.
generalize (Rle_lt_trans _ _ _ (proj2 (proj2 Hx)) H). clear H. intro H.
generalize (Rlt_le_trans _ _ _ H (proj1 (proj2 Hy))). clear H. intro H.
elim (Rlt_irrefl _ H).
Qed.

Definition mul_aa_helper (xi yi zi : FF) :=
 Fpos0 (lower zi) &&
 Fle2 (lower zi) (Fmult2 (lower xi) (lower yi)) &&
 Fle2 (Fmult2 (upper xi) (upper yi)) (upper zi).

Theorem mul_aa :
 forall x y : R, forall xi yi zi : FF,
 ABS x xi -> ABS y yi ->
 mul_aa_helper xi yi zi = true ->
 ABS (x * y) zi.
Proof.
intros x y xi yi zi Hx Hy Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fpos0_correct _ H1). clear H1. intro H1.
generalize (Fle2_correct _ _ H2). rewrite Fmult2_correct. clear H2. intro H2.
generalize (Fle2_correct _ _ H3). rewrite Fmult2_correct. clear H3. intro H3.
unfold ABS in *.
split.
exact H1.
rewrite Rabs_mult.
apply IRmult_pp with (lower xi) (upper xi) (lower yi) (upper yi)
 ; intuition.
Qed.

Definition div_aa_helper (xi yi zi : FF) :=
 Fpos (lower yi) &&
 Fpos0 (lower zi) &&
 Fle2 (Fmult2 (upper yi) (lower zi)) (lower xi) &&
 Fle2 (upper xi) (Fmult2 (lower yi) (upper zi)).

Theorem div_aa :
 forall x y : R, forall xi yi zi : FF,
 ABS x xi -> ABS y yi ->
 div_aa_helper xi yi zi = true ->
 ABS (x / y) zi.
Proof.
intros x y xi yi zi Hx Hy Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H4).
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H2).
generalize (Fpos_correct _ Hb). intro H1.
generalize (Fpos0_correct _ H2). clear H2. intro H2.
generalize (Fle2_correct _ _ H3). rewrite Fmult2_correct. clear H3. intro H3.
generalize (Fle2_correct _ _ H4). rewrite Fmult2_correct. clear H4. intro H4.
split.
exact H2.
replace (Rabs (x / y)) with (Rabs x / Rabs y)%R.
unfold ABS in *.
apply IRdiv_pp with (lower xi) (upper xi) (lower yi) (upper yi)
 ; intuition.
unfold Rdiv.
rewrite Rabs_mult.
rewrite Rabs_Rinv.
apply refl_equal.
apply nzr_of_abs with (1 := Hy) (2 := Hb).
Qed.

Definition add_aa_p_helper (xi yi zi : FF) :=
 Fpos0 (lower zi) &&
 Fle2 (lower zi) (Fminus2 (lower xi) (upper yi)) &&
 Fle2 (Fplus2 (upper xi) (upper yi)) (upper zi).

Theorem add_aa_p :
 forall x y : R, forall xi yi zi : FF,
 ABS x xi -> ABS y yi ->
 add_aa_p_helper xi yi zi = true ->
 ABS (x + y) zi.
Proof.
intros x y xi yi zi Hx Hy Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fpos0_correct _ H1). clear H1. intro H1.
generalize (Fle2_correct _ _ H2). rewrite Fminus2_correct. clear H2. intro H2.
generalize (Fle2_correct _ _ H3). rewrite Fplus2_correct. clear H3. intro H3.
split.
exact H1.
split.
apply Rle_trans with (Rabs x - Rabs y)%R.
apply Rle_trans with (1 := H2).
unfold Rminus.
apply Rplus_le_compat with (1 := proj1 (proj2 Hx)).
apply Ropp_le_contravar with (1 := proj2 (proj2 Hy)).
replace (x + y)%R with (x - -y)%R. 2: ring.
rewrite<- (Rabs_Ropp y).
apply Rabs_triang_inv.
apply Rle_trans with (Rabs x + Rabs y)%R.
apply Rabs_triang.
apply Rle_trans with (2 := H3).
apply Rplus_le_compat with (1 := proj2 (proj2 Hx)) (2 := proj2 (proj2 Hy)).
Qed.

Definition add_aa_o_helper (xi yi zi : FF) :=
 Fis0 (lower zi) &&
 Fle2 (Fplus2 (upper xi) (upper yi)) (upper zi).

Theorem add_aa_o :
 forall x y : R, forall xi yi zi : FF,
 ABS x xi -> ABS y yi ->
 add_aa_o_helper xi yi zi = true ->
 ABS (x + y) zi.
Proof.
intros x y xi yi zi Hx Hy Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fis0_correct _ H1). clear H1. intro H1.
generalize (Fle2_correct _ _ H2). rewrite Fplus2_correct. clear H2. intro H2.
split.
auto with real.
split.
rewrite H1.
apply Rabs_pos.
apply Rle_trans with (Rabs x + Rabs y)%R.
apply Rabs_triang.
apply Rle_trans with (2 := H2).
apply Rplus_le_compat with (1 := proj2 (proj2 Hx)) (2 := proj2 (proj2 Hy)).
Qed.

Definition add_aa_n_helper (xi yi zi : FF) :=
 Fpos0 (lower zi) &&
 Fle2 (lower zi) (Fminus2 (lower yi) (upper xi)) &&
 Fle2 (Fplus2 (upper xi) (upper yi)) (upper zi).

Theorem add_aa_n :
 forall x y : R, forall xi yi zi : FF,
 ABS x xi -> ABS y yi ->
 add_aa_n_helper xi yi zi = true ->
 ABS (x + y) zi.
Proof.
intros x y xi yi zi Hx Hy Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fpos0_correct _ H1). clear H1. intro H1.
generalize (Fle2_correct _ _ H2). rewrite Fminus2_correct. clear H2. intro H2.
generalize (Fle2_correct _ _ H3). rewrite Fplus2_correct. clear H3. intro H3.
split.
exact H1.
split.
apply Rle_trans with (Rabs y - Rabs x)%R.
apply Rle_trans with (1 := H2).
unfold Rminus.
apply Rplus_le_compat with (1 := proj1 (proj2 Hy)).
apply Ropp_le_contravar with (1 := proj2 (proj2 Hx)).
replace (x + y)%R with (y - -x)%R. 2: ring.
rewrite<- (Rabs_Ropp x).
apply Rabs_triang_inv.
apply Rle_trans with (Rabs x + Rabs y)%R.
apply Rabs_triang.
apply Rle_trans with (2 := H3).
apply Rplus_le_compat with (1 := proj2 (proj2 Hx)) (2 := proj2 (proj2 Hy)).
Qed.

Theorem sub_aa_p :
 forall x y : R, forall xi yi zi : FF,
 ABS x xi -> ABS y yi ->
 add_aa_p_helper xi yi zi = true ->
 ABS (x - y) zi.
Proof.
intros x y xi yi zi Hx Hy Hb.
unfold Rminus.
apply add_aa_p with xi yi.
exact Hx.
unfold ABS.
rewrite Rabs_Ropp.
exact Hy.
exact Hb.
Qed.

Theorem sub_aa_o :
 forall x y : R, forall xi yi zi : FF,
 ABS x xi -> ABS y yi ->
 add_aa_o_helper xi yi zi = true ->
 ABS (x - y) zi.
Proof.
intros x y xi yi zi Hx Hy Hb.
unfold Rminus.
apply add_aa_o with xi yi.
exact Hx.
unfold ABS.
rewrite Rabs_Ropp.
exact Hy.
exact Hb.
Qed.

Theorem sub_aa_n :
 forall x y : R, forall xi yi zi : FF,
 ABS x xi -> ABS y yi ->
 add_aa_n_helper xi yi zi = true ->
 ABS (x - y) zi.
Proof.
intros x y xi yi zi Hx Hy Hb.
unfold Rminus.
apply add_aa_n with xi yi.
exact Hx.
unfold ABS.
rewrite Rabs_Ropp.
exact Hy.
exact Hb.
Qed.

Definition bnd_of_bnd_abs_p_helper (xi yi zi : FF) :=
 Flt2 (Fopp2 (lower yi)) (lower xi) &&
 Fle2 (lower zi) (lower yi) &&
 Fle2 (upper xi) (upper zi).

Theorem bnd_of_bnd_abs_p :
 forall x : R, forall xi yi zi : FF,
 BND x xi -> ABS x yi ->
 bnd_of_bnd_abs_p_helper xi yi zi = true ->
 BND x zi.
Proof.
intros x xi yi zi Hx Hy Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Flt2_correct _ _ H1). rewrite Fopp2_correct. fold float2R. clear H1. intro H1.
generalize (Fle2_correct _ _ H2). clear H2. intro H2.
generalize (Fle2_correct _ _ H3). clear H3. intro H3.
case (Rcase_abs x) ; intro H.
unfold ABS in Hy.
rewrite (Rabs_left _ H) in Hy.
elim (Rlt_not_le (lower xi) x). 2: exact (proj1 Hx).
apply Rle_lt_trans with (2 := H1).
apply Ropp_le_cancel.
rewrite Ropp_involutive.
exact (proj1 (proj2 Hy)).
unfold ABS in Hy.
rewrite (Rabs_right _ H) in Hy.
split.
apply Rle_trans with (1 := H2) (2 := proj1 (proj2 Hy)).
apply Rle_trans with (1 := proj2 Hx) (2 := H3).
Qed.

Definition bnd_of_bnd_abs_n_helper (xi yi zi : FF) :=
 Flt2 (upper xi) (lower yi) &&
 Fle2 (lower zi) (lower xi) &&
 Fle2 (Fopp2 (lower yi)) (upper zi).

Theorem bnd_of_bnd_abs_n :
 forall x : R, forall xi yi zi : FF,
 BND x xi -> ABS x yi ->
 bnd_of_bnd_abs_n_helper xi yi zi = true ->
 BND x zi.
Proof.
intros x xi yi zi Hx Hy Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Flt2_correct _ _ H1). clear H1. intro H1.
generalize (Fle2_correct _ _ H2). clear H2. intro H2.
generalize (Fle2_correct _ _ H3). rewrite Fopp2_correct. fold float2R. clear H3. intro H3.
case (Rcase_abs x) ; intro H.
unfold ABS in Hy.
rewrite (Rabs_left _ H) in Hy.
split.
apply Rle_trans with (1 := H2) (2 := proj1 Hx).
apply Rle_trans with (2 := H3).
apply Ropp_le_cancel.
rewrite Ropp_involutive.
exact (proj1 (proj2 Hy)).
unfold ABS in Hy.
rewrite (Rabs_right _ H) in Hy.
elim (Rlt_not_le x (upper xi)). 2: exact (proj2 Hx).
apply Rlt_le_trans with (1 := H1) (2 := proj1 (proj2 Hy)).
Qed.


(*
 * This code was developped by IDEALX (http://IDEALX.org/) and
 * contributors (their names can be found in the CONTRIBUTORS file). It
 * is released under the terms of the BSD license (see LICENCE file
 * for details).
*)

(******************************************************************
 *                OPTION TYPE V0.1 (April 2001)
 *
 *
 ******************************************************************
 *
 * The option type allows a function to have an error condition, a
 * way of making a partial function become total.
 *
 ******************************************************************)

Inductive option (A : Set) : Set :=
  | none : option A
  | some : A -> option A.

Lemma option_sum :
 forall (A : Set) (o : option A), {y : A | o = some A y} + {o = none A}.
Proof.
intro.
simple induction o.
right.
auto.
left.
exists a.
auto.
Qed.


(* ----------------------------------------------------------------------------------- *)
(** Discrete displayed bicategories

    Given a displayed category on some bicategory, we construct a displayed bicategory
    from it. The 2-cells are from the unit type.                                       *)
(* ----------------------------------------------------------------------------------- *)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.PartA.
Require Import UniMath.MoreFoundations.Propositions.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Constructions.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Examples.Initial.
Require Import UniMath.Bicategories.Core.Examples.Final.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles.
Require Import UniMath.Bicategories.DisplayedBicats.DispAdjunctions.
Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence.

Local Open Scope cat.
Local Open Scope mor_disp_scope.

Definition is_chaotic
           {C : bicat}
           (D : disp_bicat C)
  : UU
  := ∏ (a b : C) (f g : a --> b) (α : f ==> g)
       (aa : D a) (bb : D b)
       (ff : aa -->[ f ] bb) (gg : aa -->[ g ] bb),
     iscontr (ff ==>[ α ] gg).

Definition isaprop_is_chaotic
           {C : bicat}
           (D : disp_bicat C)
  : isaprop (is_chaotic D).
Proof.
  repeat (apply impred ; intro).
  apply isapropiscontr.
Qed.

Section Disp_Prebicat_Cells_Unit.
  Context {C : bicat} (D : disp_cat_data C).

  Definition disp_prebicat_cells_unit
    : disp_prebicat_1_id_comp_cells C.
  Proof.
    exists D. red. intros. exact unit.
  Defined.

  Definition disp_prebicat_cells_unit_ops
    : disp_prebicat_ops disp_prebicat_cells_unit.
  Proof.
    repeat use tpair; cbn; intros; exact tt.
  Defined.

  Definition disp_prebicat_cells_unit_data : disp_prebicat_data C
    := _ ,, disp_prebicat_cells_unit_ops.

  Lemma disp_prebicat_cells_unit_laws
    : disp_prebicat_laws disp_prebicat_cells_unit_data.
  Proof.
    repeat use tpair; red; intros; apply (proofirrelevance _ isapropunit).
  Qed.

  Definition disp_cell_unit_prebicat : disp_prebicat C
    := _ ,, disp_prebicat_cells_unit_laws.

  Definition disp_cell_unit_bicat : disp_bicat C.
  Proof.
    refine (disp_cell_unit_prebicat ,, _).
    intros a b f g x aa bb ff gg.
    apply isasetunit.
  Defined.

  (** Local Univalence *)
  Definition disp_cell_unit_bicat_univalent_2_1
             (H : ∏ (a b : C)
                    (f : a --> b)
                    (aa : D a) (bb : D b),
                  isaprop (aa -->[ f] bb))
    : disp_univalent_2_1 disp_cell_unit_bicat.
  Proof.
    intros a b f g p aa bb ff gg.
    use isweqimplimpl.
    - cbn in *.
      intros.
      apply H.
    - apply isasetaprop.
      exact (H a b g aa bb).
    - simple refine (isaprop_total2 (_ ,, _) (λ η , _ ,, _)).
      + exact isapropunit.
      + apply (@isaprop_is_disp_invertible_2cell C disp_cell_unit_bicat).
  Defined.

  (** Global Univalence *)
  Definition disp_cell_unit_bicat_is_disp_invertible_2cell
             {a b : C}
             {f : a --> b} {g : a --> b}
             (x : invertible_2cell f g)
             {aa : disp_cell_unit_bicat a}
             {bb : disp_cell_unit_bicat b}
             {ff : aa -->[ f ] bb}
             {gg : aa -->[ g ] bb}
             (xx : ff ==>[ x ] gg)
    : is_disp_invertible_2cell x xx.
  Proof.
    use tpair.
    - exact tt.
    - split ; apply isapropunit.
  Defined.

  Definition disp_cell_unit_bicat_left_adjoint_equivalence
             {a b : C}
             (f : adjoint_equivalence a b)
             {aa : disp_cell_unit_bicat a}
             {bb : disp_cell_unit_bicat b}
             (ff : aa -->[ f] bb)
    : bb -->[ left_adjoint_right_adjoint f] aa
      →
      disp_left_adjoint_equivalence f ff.
  Proof.
    intros gg.
    use tpair.
    - use tpair.
      + exact gg.
      + exact (tt ,, tt).
    - split ; split ; cbn.
      + apply isapropunit.
      + apply isapropunit.
      + exact (disp_cell_unit_bicat_is_disp_invertible_2cell
                  (left_adjoint_unit f ,, _)
                  tt).
      + exact (disp_cell_unit_bicat_is_disp_invertible_2cell
                 (left_adjoint_counit f ,, _)
                 tt).
  Defined.

  Definition disp_cell_unit_bicat_left_adjoint_equivalence_inv
             {a b : C}
             (f : adjoint_equivalence a b)
             {aa : disp_cell_unit_bicat a}
             {bb : disp_cell_unit_bicat b}
             (ff : aa -->[ f] bb)
    : disp_left_adjoint_equivalence f ff
      →
      bb -->[ left_adjoint_right_adjoint f] aa.
  Proof.
    intros H.
    apply H.
  Defined.

  Definition disp_cell_unit_bicat_disp_cellset : has_disp_cellset disp_cell_unit_bicat.
  Proof.
    intro ; intros.
    apply isasetunit.
  Defined.

  Definition disp_cell_unit_bicat_left_adjoint_equivalence_weq
             {a b : C}
             (f : adjoint_equivalence a b)
             {aa : disp_cell_unit_bicat a}
             {bb : disp_cell_unit_bicat b}
             (ff : aa -->[ f] bb)
    : (bb -->[ left_adjoint_right_adjoint f] aa)
        ≃
        disp_left_adjoint_equivalence f ff.
  Proof.
    refine (disp_cell_unit_bicat_left_adjoint_equivalence f ff ,, _).
    use isweq_iso.
    - exact (disp_cell_unit_bicat_left_adjoint_equivalence_inv f ff).
    - reflexivity.
    - intros y.
      use subtypePath.
      + intro.
        do 2 apply isapropdirprod.
        * apply disp_cell_unit_bicat_disp_cellset.
        * apply disp_cell_unit_bicat_disp_cellset.
        * apply isaprop_is_disp_invertible_2cell.
        * apply isaprop_is_disp_invertible_2cell.
      + cbn.
        unfold disp_cell_unit_bicat_left_adjoint_equivalence_inv.
        use total2_paths_b.
        * reflexivity.
        * use total2_paths_b ; apply isapropunit.
  Defined.

  Definition disp_cell_unit_bicat_adjoint_equivalent
             {a b : C}
             (f : adjoint_equivalence a b)
             (aa : disp_cell_unit_bicat a)
             (bb : disp_cell_unit_bicat b)
    : (aa -->[ f] bb × bb -->[ left_adjoint_right_adjoint f] aa)
        ≃
        disp_adjoint_equivalence f aa bb.
  Proof.
    use weqfibtototal ; cbn.
    intro.
    apply disp_cell_unit_bicat_left_adjoint_equivalence_weq.
  Defined.

  Definition disp_cell_unit_bicat_idtoiso
             {a b : C}
             (p : a = b)
             (aa : disp_cell_unit_bicat a)
             (bb : disp_cell_unit_bicat b)
    : transportf disp_cell_unit_bicat p aa = bb
      →
      (aa -->[ idtoiso_2_0 _ _ p ] bb)
        ×
        (bb -->[ left_adjoint_right_adjoint (idtoiso_2_0 _ _ p)] aa).
  Proof.
    induction p ; cbn.
    intros pp.
    induction pp ; cbn.
    split ; apply id_disp.
  Defined.

  Definition disp_cell_unit_bicat_univalent_2_0
             (HC : is_univalent_2_1 C)
             (HDP : ∏ (a b : C)
                     (f : a --> b)
                     (aa : D a) (bb : D b),
                   isaprop (aa -->[ f] bb))
             (Dset : ∏ (a : C), isaset (D a))
             (inv : ∏ (a : C) (aa bb : disp_cell_unit_bicat a),
                    (aa -->[ id₁ a ] bb × bb -->[ id₁ a ] aa)
                    →
                    aa = bb)
    : disp_univalent_2_0 disp_cell_unit_bicat.
  Proof.
    apply fiberwise_univalent_2_0_to_disp_univalent_2_0.
    intros a aa bb.
    use isweqimplimpl.
    - intro η ; cbn.
      apply inv.
      exact (invmap (disp_cell_unit_bicat_adjoint_equivalent
                       (idtoiso_2_0 a a (idpath a))
                       aa bb) η).
    - apply (Dset a).
    - apply (isofhlevelweqf 1 (disp_cell_unit_bicat_adjoint_equivalent _ _ _)).
      apply isapropdirprod ; apply HDP.
  Defined.

  Definition disp_cell_unit_bicat_univalent_2
             (HC : is_univalent_2_1 C)
             (HDP : ∏ (a b : C)
                     (f : a --> b)
                     (aa : D a) (bb : D b),
                   isaprop (aa -->[ f] bb))
             (Dset : ∏ (a : C), isaset (D a))
             (inv : ∏ (a : C) (aa bb : disp_cell_unit_bicat a),
                    (aa -->[ id₁ a ] bb × bb -->[ id₁ a ] aa)
                    →
                    aa = bb)
    : disp_univalent_2 disp_cell_unit_bicat.
  Proof.
    split.
    - apply disp_cell_unit_bicat_univalent_2_0; assumption.
    - apply disp_cell_unit_bicat_univalent_2_1; assumption.
  Defined.
End Disp_Prebicat_Cells_Unit.

Definition is_chaotic_disp_bicat_cells_unit
           {C : bicat}
           (D : disp_cat_data C)
  : is_chaotic (disp_cell_unit_bicat D).
Proof.
  intro ; intros.
  apply iscontrunit.
Defined.

Definition disp_2cells_isaprop_cell_unit_bicat
           {C : bicat}
           (D : disp_cat_data C)
  : disp_2cells_isaprop (disp_cell_unit_bicat D).
Proof.
  intro; intros.
  apply isapropifcontr.
  apply (is_chaotic_disp_bicat_cells_unit D).
Qed.

Definition disp_locally_groupoid_cell_unit_bicat
           {C : bicat}
           (D : disp_cat_data C)
  : disp_locally_groupoid (disp_cell_unit_bicat D).
Proof.
  use make_disp_locally_groupoid.
  - intro; intros; exact tt.
  - exact (disp_2cells_isaprop_cell_unit_bicat D).
Qed.

Lemma isaprop_disp_left_adjoint_data_cell_unit_bicat
      {C : bicat}
      {D : disp_cat_data C}
      {a b : C} {f : C⟦ a, b ⟧}
      (l : left_adjoint_data f)
      {aa : (disp_cell_unit_bicat D) a} {bb : (disp_cell_unit_bicat D) b}
      (ff : aa -->[ f] bb)
  : isaprop (bb -->[ left_adjoint_right_adjoint l] aa)
    -> isaprop (disp_left_adjoint_data l ff).
Proof.
  intro p.
  use isaproptotal2.
  - intro ; apply isapropdirprod ; apply isapropunit.
  - intro ; intros ; apply p.
Qed.

Lemma isaprop_disp_left_adjoint_axioms_cell_unit_bicat
  {C : bicat}
  {D : disp_cat_data C}
  {a b : C} {f : C⟦ a, b ⟧}
  (j : left_adjoint f)
  {aa : (disp_cell_unit_bicat D) a} {bb : (disp_cell_unit_bicat D) b}
  {ff : aa -->[ f] bb}
  (jj : disp_left_adjoint_data j ff)
  : isaprop (disp_left_adjoint_axioms j jj).
Proof.
  apply isapropdirprod ; apply isasetaprop, isapropunit.
Qed.

(* To be moved more upstream *)
Lemma isaprop_disp_left_equivalence_axioms
  {C : bicat}
  {D : disp_cat_data C}
  {a b : C}
  {aa : (disp_cell_unit_bicat D) a} {bb : (disp_cell_unit_bicat D) b}
  {f : C⟦ a, b ⟧}
  {j : left_equivalence f}
  {ff : aa -->[ f] bb}
  (jj : disp_left_adjoint_data j ff)
    : isaprop (disp_left_equivalence_axioms j jj).
  Proof.
    apply isapropdirprod ; apply isaprop_is_disp_invertible_2cell.
  Qed.

Lemma isaprop_disp_left_adjoint_equivalence_cell_unit_bicat
  {C : bicat}
  {D : disp_cat_data C}
  {a b : C}
  {aa : (disp_cell_unit_bicat D) a} {bb : (disp_cell_unit_bicat D) b}
  (f : adjoint_equivalence a b)
  (ff : aa -->[ f ] bb)
  : isaprop (bb -->[ left_adjoint_right_adjoint f] aa)
    -> isaprop (disp_left_adjoint_equivalence f ff).
Proof.
  intro p.
  use isaproptotal2.
  - intro.
    apply isapropdirprod.
    + apply isaprop_disp_left_adjoint_axioms_cell_unit_bicat.
    + apply isaprop_disp_left_equivalence_axioms.
  - do 4 intro.
    apply isaprop_disp_left_adjoint_data_cell_unit_bicat, p.
Qed.

Lemma isaprop_disp_adjoint_equivalence_cell_unit_bicat
  {C : bicat}
  {D : disp_cat_data C}
  {a b : C}
  {aa : (disp_cell_unit_bicat D) a} {bb : (disp_cell_unit_bicat D) b}
  {f : adjoint_equivalence a b}
  (ff : aa -->[ f ] bb)
  : isaprop (bb -->[left_adjoint_right_adjoint f] aa)
    -> isaprop (aa -->[ f] bb)
    -> isaprop (disp_adjoint_equivalence f aa bb).
Proof.
  exact (λ p q, isaprop_total2 (_,,q) (λ _ , _ ,, isaprop_disp_left_adjoint_equivalence_cell_unit_bicat _ _ p)).
Qed.


Require Import ProofIrrelevance.
Require Export Coend LimitFunctors LimitFunctors FunctorCategory ProductInducedFunctors FunctorialComposition.
Require Import Common Notations.

Set Implicit Arguments.

Generalizable All Variables.

Set Asymmetric Patterns.

Set Universe Polymorphism.

Local Open Scope type_scope.

Section Coend.
  Context `(C : @SpecializedCategory objC).

  Let COp := OppositeCategory C.

  Definition CoendFunctor_Index_Object := { ds : objC * objC & Morphism C (snd ds) (fst ds) } + objC.

  Global Arguments CoendFunctor_Index_Object /.

  Definition CoendFunctor_Index_Morphism (s d : CoendFunctor_Index_Object) : Set :=
    match (s, d) with
      | (inl sdm, inr c) => (fst (projT1 sdm) = c) + (snd (projT1 sdm) = c)
      | _ => (s = d)
    end.

  Global Arguments CoendFunctor_Index_Morphism s d /.

  Definition CoendFunctor_Index_Identity x : CoendFunctor_Index_Morphism x x :=
    match x as s return (CoendFunctor_Index_Morphism s s) with
      | inl s => eq_refl
      | inr s => eq_refl
    end.

  Global Arguments CoendFunctor_Index_Identity x /.

  Ltac inj H := injection H; clear H; intros; subst.

  Definition CoendFunctor_Index_Compose s d d' :
    CoendFunctor_Index_Morphism d d'
    -> CoendFunctor_Index_Morphism s d
    -> CoendFunctor_Index_Morphism s d'.
  Proof.
    destruct s, d, d'; simpl; intros;
    match goal with
      | [ H : _ + _ |- _ ] => destruct H; [ left | right ];
                              abstract congruence
      | _ => abstract congruence
    end.
  Defined.

  Definition CoendFunctor_Index : SpecializedCategory CoendFunctor_Index_Object.
  Proof.
    refine (@Build_SpecializedCategory _
                                       CoendFunctor_Index_Morphism
                                       CoendFunctor_Index_Identity
                                       CoendFunctor_Index_Compose
                                       _
                                       _
                                       _);
    abstract (
        simpl; intros;
        repeat (match goal with
                  | [ x : _ + _ |- _ ] => destruct x; simpl in *
                                                    | _ => apply proof_irrelevance
                                                    | _ => congruence
                                                    | _ => f_equal
                end)
      ).
  Defined.

  Definition CoendFunctor_Diagram_ObjectOf_pre : CoendFunctor_Index -> (COp * C) :=
    fun x => match x with
               | inl c0c1 => (projT1 c0c1)
               | inr c => (c, c)
             end.

  Global Arguments CoendFunctor_Diagram_ObjectOf_pre _ /.

  Hint Extern 1 (Morphism _ ?X ?X) => apply Identity : morphism.
(*  Hint Extern 1 (Morphism _ _ _) => hnf. *)

  Definition CoendFunctor_Diagram_MorphismOf_pre s d :
    CoendFunctor_Index_Morphism s d
    -> Morphism (COp * C) (CoendFunctor_Diagram_ObjectOf_pre s) (CoendFunctor_Diagram_ObjectOf_pre d).
  Proof.
    destruct s, d; simpl in *; intros; split;
    repeat match goal with
             | _ => discriminate
             | _ => assumption
             | [ H : inl _ = inl _ |- _ ] => inj H
             | [ H : inr _ = inr _ |- _ ] => inj H
             | [ H : sigT _ |- _ ] => destruct H; simpl in *
             | [ H : _ + _ |- _ ] => destruct H; subst
           end;
    apply Identity.
  Defined.

  Ltac inj' H :=
    match type of H with
      | ?X = ?X => fail 1
      | _ => injection H; intros; subst
    end.

  Definition CoendFunctor_Diagram_pre : SpecializedFunctor CoendFunctor_Index (COp * C).
  Proof.
    refine (Build_SpecializedFunctor
      CoendFunctor_Index (COp * C)
      CoendFunctor_Diagram_ObjectOf_pre
      CoendFunctor_Diagram_MorphismOf_pre
      _
      _);
    abstract (
      repeat match goal with
               | [ |- forall x : CoendFunctor_Index_Object, _ ] =>
                 destruct x
             end; simpl; intros;
      repeat match goal with
               | _ => discriminate
               | _ => progress (subst; unfold eq_rect_r)
               | [ H : inl _ = inl _ |- _ ] => inj' H
               | [ H : inr _ = inr _ |- _ ] => inj' H
               | [ x : sigT _ |- _ ] => destruct x; simpl in *
               | [ H : _ + _ |- _ ] => destruct H
               | _ => rewrite <- eq_rect_eq
               | _ => apply injective_projections; simpl
             end; auto with category
    ).
  Defined.
End Coend.

Section CoendFunctor.
  Context `(C : @SpecializedCategory objC).
  Context `(D : @SpecializedCategory objD).

  Let COp := OppositeCategory C.

  Hypothesis HasColimits : forall F : SpecializedFunctor (CoendFunctor_Index C) D, Colimit F.

  Let CoendFunctor_post := ColimitFunctor HasColimits.

  Let o := (FunctorialComposition (CoendFunctor_Index C) (COp * C) D).
  Let CoendFunctor_pre := (o ⟨ - , (CoendFunctor_Diagram_pre C) ⟩)%functor.

  Definition CoendFunctor := ComposeFunctors CoendFunctor_post CoendFunctor_pre.
End CoendFunctor.


Require Export BoilerplateSemantics.
Set Implicit Arguments.

(******************************************************************************)
(* Progress                                                                   *)
(******************************************************************************)

Lemma can_form_tarr {Γ t T1 T2} (v: Value t) (wt: Typing Γ t (tarr T1 T2)) :
  ∃ t2, t = abs T1 t2.
Proof.
  depind wt; try contradiction; exists t; reflexivity.
Qed.

Lemma can_form_tall {Γ t T} (v: Value t) (wt: Typing Γ t (tall T)) :
  ∃ t1, t = tabs t1.
Proof.
  depind wt; try contradiction; exists t; reflexivity.
Qed.

Lemma progress {t U} (wt: Typing empty t U) :
  Value t ∨ ∃ t', red t t'.
Proof with try (subst; eauto using red).
  depind wt; simpl; auto.
  - inversion H.
  - destruct IHwt1 as [v1|[t1' r1]]...
    destruct IHwt2 as [v2|[t2' r2]]...
    destruct (can_form_tarr v1 wt1)...
  - destruct IHwt as [vt|[t1' r1]]...
    destruct (can_form_tall vt wt)...
Qed.

(******************************************************************************)
(* Preservation                                                               *)
(******************************************************************************)

Lemma preservation {Γ t U} (wt: Typing Γ t U) :
  ∀ {t'}, red t t' → Typing Γ t' U.
Proof.
  induction wt; intros t' r; inversion r; subst; eauto using Typing.
  - dependent destruction wt1; eauto using subst_evar_typing.
  - dependent destruction wt; eauto using subst_etvar_typing.
Qed.


Require Import Undecidability.L.Datatypes.LNat.
Require Import Undecidability.L.Datatypes.List.List_in Undecidability.L.Datatypes.List.List_basics.
Require Import Undecidability.L.Functions.Unenc.
Require Import Undecidability.Shared.ListAutomation.
Require Import Undecidability.Shared.embed_nat.

Require Import Undecidability.L.Datatypes.List.List_extra Undecidability.L.Datatypes.LProd.
Require Import Undecidability.L.Datatypes.LTerm Undecidability.L.Functions.Eval.

Import ListNotations ListAutomationNotations EmbedNatNotations.

Definition L_nat := (fix f n := match n with 0 => [0] | S n0 => f n0 ++ [S n0] end).

Instance L_T_nat_computable : computable L_nat.
Proof.
  unfold L_nat. cbn.
  extract.
Qed.

Fixpoint list_enumerator_term (n : nat) : list term :=
  match n with
  | 0 => []
  | S n => list_enumerator_term n ++ [var m | m ∈ L_nat n] ++ [ lam s | s ∈ list_enumerator_term n ] ++ [ L.app s t | (s,t) ∈ (list_enumerator_term n × list_enumerator_term n) ]
  end.

Definition app' '(s,t) := L.app s t.

Instance app'_computable : computable app'.
Proof.
  extract.
Qed.

Instance list_enumerator_term_computable : computable list_enumerator_term.
Proof.
  change (computable (fix FFF (n : nat) : list term :=
  match n with
  | 0 => []
  | S n => FFF n
           ++ map var (L_nat n)
           ++ map lam (FFF n)
           ++ map app' (list_prod (FFF n) (FFF n))
  end)). extract.
Qed.

Definition unembed' := (fix F (k : nat) :=
  match k with 0 => (0,0) | S n => match fst (F n) with 0 => (S (snd (F n)), 0) | S x => (x, S (snd (F n))) end end).

Instance unembed_computable : computable unembed.
Proof.
  eapply computableExt with (x := unembed'). 2:extract.
  intros n. cbn. induction n; cbn.
  - reflexivity.
  - fold (unembed n). rewrite IHn. now destruct (unembed n).
Qed.

Definition enum_term := (fun! ⟨n,m⟩ => nth_error (list_enumerator_term n) m).

Instance enum_term_computable : computable enum_term.
Proof.
  extract.
Qed.

Definition T_L (c : nat) (x : nat) (n : nat) :=
   match enum_term c with
   | Some t => match eva n (L.app t (enc x)) with
               | Some t => nat_unenc t
               | None => None
               end
   | None => None
   end.

Instance T_L_computable : computable T_L.
Proof.
  extract.
Qed.

Require Import Undecidability.Axioms.axioms.
Require Import Undecidability.L.Util.L_facts Undecidability.L.Computability.Seval.
Require Import Undecidability.Synthetic.ListEnumerabilityFacts Undecidability.Synthetic.EnumerabilityFacts Undecidability.Synthetic.DecidabilityFacts.
Require Import Undecidability.Shared.ListAutomation Undecidability.Shared.Dec.

Lemma list_enumerator_term_correct : list_enumeratorᵗ list_enumerator_term term.
Proof with (try eapply cum_ge'; eauto; lia).
  intros t. induction t as [m | t1 [n1 IH1] t2 [n2 IH2] | t [n IH]].
  - destruct (el_T m) as [n Hn]. exists (S n). cbn. in_app 2. eauto.
  - exists (1 + n1 + n2). cbn. in_app 4.
    in_collect (t1, t2)...
  - exists (1 + n). cbn. in_app 3. eauto.
Qed.

Instance L_model_of_computation : model_of_computation.
Proof.
  unshelve econstructor.
  exact T_L.
  intros c x n1 res H1 n2 Hle. unfold T_L in *.
  destruct _ eqn:E1; try congruence.
  destruct eva eqn:E; try congruence.
  eapply eva_le in E; eauto.
  now rewrite E.
Defined.

Lemma datatype_term : {I | retraction I enum_term term nat}.
  eapply enumerator_retraction.
  2: abstract eapply list_enumeratorᵗ_enumeratorᵗ, list_enumerator_term_correct.
  unshelve eapply DecidabilityFacts.dec_decider; intros [t1 t2]; eapply term_eq_dec.
Defined.

Definition I_term := proj1_sig datatype_term.

Lemma I_term_correct s : enum_term (I_term s) = Some s.
Proof.
  unfold I_term. destruct datatype_term as [? H]. eapply H.
Qed.

(* Lemma SMN_T : exists s_1_1, forall c x y v, (exists n, T c ⟨x,y⟩ n = Some v) <-> (exists n, T (s_1_1 c y) y n = Some v). *)
(* Proof. *)
(*   exists (fun c x => if enum_term c is Some s then I_term (L.lam (L.app s (enc x)) *)

Section assume_CT.

Variable ct : @CT L_model_of_computation.

Local Definition ea : EA := (exist _ φ (CT_to_EA' ct)).
Local Definition W := W ea.

Lemma enumerator_W_code f (p : nat -> Prop) :
  enumerator f p -> computable f -> { c | forall x, W c x <-> p x}.
Proof.
  intros Hf Hcomp.
  assert (computable (fun n => if f n is Some x then S x else 0)) as [s [Hp Hs]] by extract.
  exists (I_term s). intros x. cbn in Hs.
  unfold W, axioms.W, ea, φ. cbn. unfold T_L. split.
  - intros [nm Hnm]. destruct (unembed nm) as [n m]. cbn in *.
    destruct (enum_term) eqn:E1; try congruence.
    destruct (eva) eqn:E2; try congruence.
    destruct (nat_unenc) as [[] | ] eqn:E3; try congruence.
    inv Hnm.
    eapply Hf. exists n. rewrite I_term_correct in E1.
    specialize E1 as [= ->].
    eapply unenc_correct2 in E3 as <-.
    eapply eva_equiv in E2.
    specialize (Hs n _ eq_refl) as (? & E4 & ->). rewrite E4 in E2.
    eapply unique_normal_forms in E2. 2:Lproc. 2:Lproc.
    change (LNat.nat_enc (S x)) with (enc (S x)) in E2.
    eapply inj_enc in E2 as [= E2].
    now destruct (f n); inv E2.
  - intros [n Hn] % Hf.
    specialize (Hs n _ eq_refl) as (? & H & ->).
    edestruct equiv_eva with (s := L.app s (enc n)) as [m Hm].
    2: now rewrite H. 1: now Lproc.
    exists ⟨n,m⟩. now rewrite embedP, I_term_correct, Hm, unenc_correct, Hn.
Qed.

Lemma SMN : exists s, forall c x y, W (s c x) y <-> W c ⟨x,y⟩.
Proof.
  unshelve eexists.
  - intros c x. edestruct (enumerator_W_code) with (p := fun y => W c ⟨x,y⟩) as [r Hr].
    Unshelve. 4:{
      exact (fun! ⟨n,m ⟩ => if T c n m is Some (S xy) then (fun! ⟨x',y⟩ => if Nat.eqb x x' then Some y else None) xy else None). }
    + intros y. unfold W, axioms.W, ea, φ. cbn. unfold T_L. split.
      * intros [nm H]. exists nm. destruct (unembed nm) as [n m].
        destruct enum_term; try congruence.
        destruct eva; try congruence.
        destruct nat_unenc; try congruence.
        destruct n0; try congruence. inv H.
        rewrite embedP. now rewrite Nat.eqb_refl.
      * intros [nm H]. exists nm. destruct (unembed nm) as [n m].
        destruct enum_term; try congruence.
        destruct eva; try congruence.
        destruct nat_unenc; try congruence.
        destruct n0; try congruence. destruct (unembed n0) eqn:E.
        destruct (Nat.eqb_spec x n1); try congruence. subst. inv H.
        f_equal. eapply (f_equal embed) in E.
        now rewrite unembedP in E.
    +  unfold T, L_model_of_computation. extract.
    + exact r.
  - cbn. intros. destruct enumerator_W_code. eapply i.
Qed.

End assume_CT.

Theorem CT_to_EA_SMN :
  @CT L_model_of_computation ->

  exists e : nat -> nat -> option nat,                                (*  This is EA  *)
    (forall f : nat -> option nat, exists c : nat, e c≡{ran} f) /\

  let W c x := exists n, e c n = Some x in                      (* This is SMN *)
    exists s, forall c x y, W (s c x) y <-> W c ⟨x,y⟩.
Proof.
  intros ct. exists φ. split.
  - now eapply CT_to_EA'.
  - now unshelve eapply SMN.
Qed.

(* Definition I_l := projT1 datatype_list_nat. *)
(* Definition R_l := proj1_sig (projT2 datatype_list_nat). *)

(* Lemma datatype_list_nat : {I & {R | retraction I R (list nat) nat}}. *)
(* Proof. *)
(*   edestruct enumerator_retraction with (X := list nat) as (I & H). *)
(*   2: exact _. *)
(*   - unshelve eapply DecidabilityFacts.dec_decider. *)
(*     intros [l1 l2]. red. repeat decide equality. *)
(*   - eauto. *)
(* Defined. *)

(* Lemma computable_has_code (f : nat -> nat) : computable f -> {c | axioms.computes c f}. *)
(* Proof. *)
(*   intros [s [Hp Hs]]. cbn in Hs. *)
(*   exists (I_term s). intros x. specialize (Hs x _ eq_refl) as (? & H & ->). *)
(*   edestruct equiv_eva with (s := L.app s (enc x)) as [n Hn]. *)
(*   2: now rewrite H. 1: now Lproc. *)
(*   exists n. unfold T, L_model_of_computation. unfold T_L. *)
(*   now rewrite I_term_correct, Hn, unenc_correct. *)
(* Qed. *)

(* Lemma List_id (l : list nat) : { c_l | forall x, W c_l x <-> List.In x l}. *)
(* Proof. *)
(*   eapply enumerator_W_code. eapply decider_enumerator. *)
(*   intros x. red. symmetry. eapply list_in_decb_iff. intros a b. eapply (decider_eq_nat (a,b)). exact _. *)
(*   cbn. extract. *)
(* Qed. *)

(* Import L_Notations_app.  *)

(* Lemma computable_iff (f : nat -> nat) : (exists c, axioms.computes c f) <-> inhabited (computable f). *)
(* Proof. *)
(*   split. *)
(*   - intros [c H]. econstructor. *)
(*     destruct (enum_term c) as [t | ] eqn:E. *)
(*     + exists (lam (L.app (ext nat_unenc) (L.app Eval (L.app (L.app (ext L.app) (enc t)) (L.app (ext (@enc nat _)) #0))) (lam #0) (enc 0))). *)
(*       cbn. split. unfold Eval. cbn. Lproc. *)
(*       intros x ? ->. exists (enc (f x)). split. 2:reflexivity. *)
(*       specialize (H x) as [n Hn]. *)
(*       Lsimpl. eapply equiv_lambda. Lproc. *)
(*       change (enc (L.app t (enc x))) with (ext (L.app t (enc x))). *)
(*       rewrite eval_Eval with (t := enc (f x)). Lsimpl. rewrite unenc_correct. Lsimpl. *)
(*       eapply seval_eval with (n := n), eva_seval. *)
(*       unfold T, L_model_of_computation, T_L in Hn. *)
(*       rewrite E in Hn. destruct (eva); try congruence. *)
(*       eapply unenc_correct2 in Hn. subst. reflexivity. *)
(*     + exfalso. specialize (H 0) as [n Hn]. cbn in Hn. unfold T_L in Hn. rewrite E in Hn. congruence. *)
(*   - intros [[c H] % computable_has_code]. eauto. Unshelve. *)
(*   unfold Eval. Lproc. *)
(* Qed. *)

(* Lemma all_computable (f : nat -> nat) : inhabited (computable f). *)
(* Proof. *)
(*   eapply computable_iff, ct. *)
(* Qed. *)

(* Lemma SMN' : forall f, exists k, forall c x, W (k c) x <-> W c (f x). *)
(* Proof. *)
(*   intros f. destruct (all_computable f) as [s [Hp H]]. *)
(*   unshelve eexists. *)
(*   - intros c. edestruct (enumerator_W_code) with (p := fun x => W c (f x)) as [r Hr]. shelve. shelve. exact r. *)
(*   - intros c x. cbn. destruct _. eapply i. *)
(*   Unshelve. *)
(*   exact (fun! ⟨n,mx⟩ => (fun! ⟨m,x⟩ => if T c n m is Some fx then if Nat.eqb (S (f x)) fx then Some x else None else None) mx). *)
(*   + intros x. unfold W, axioms.W, ea, φ. cbn. unfold T_L. split. *)
(*     * intros [nm H]. destruct (unembed nm) as [n m]. *)
(*       destruct enum_term eqn:E1; try congruence. *)
(*       destruct eva eqn:E2; try congruence. *)
(*       destruct nat_unenc as [ [] | ] eqn:E3; try congruence. *)
(*       inv H. *)
(*       eapply unenc_correct2 in E3 as <-. *)
(*       exists ⟨n, ⟨m,x⟩⟩. now rewrite !embedP, E2, unenc_correct, Nat.eqb_refl. *)
(*     * intros [nmx H]. destruct (unembed nmx) as [n mx]. *)
(*       destruct (unembed mx) as [m x']. *)
(*       destruct enum_term eqn:E1; try congruence. *)
(*       destruct eva eqn:E2; try congruence. *)
(*       destruct nat_unenc eqn:E3; try congruence. *)
(*       destruct (Nat.eqb_spec (S (f x')) n0); try congruence. subst. *)
(*       inv H. *)
(*       exists ⟨n,m⟩. now rewrite embedP, E2, E3. *)
(*   + unfold T, L_model_of_computation. extract. *)
(* Qed. *)

(* Print Assumptions SMN'. *)

(* Require Import Undecidability.Synthetic.truthtables. *)

(* Lemma bla {X} f  : decider f (fun x : X => f x = true). *)
(* Proof. *)
(*   firstorder. *)
(* Qed. *)

(* Lemma TT'' :  *)
(*   forall f : nat -> { Q : list nat & truthtable (length Q)},  *)
(*     inhabited (forall l, {c_l | forall x, W c_l x <-> eval_tt (projT2 (f x)) (map (fun x => negb (inb (uncurry Nat.eqb) x l)) (projT1 (f x))) = true}). *)
(* Proof. *)
(*   intros f. econstructor. intros l. *)
(*   eapply enumerator_W_code. *)
(*   - eapply decider_enumerator. 2:exact _. eapply bla. *)
(*   -  *)
(* Admitted. *)

(* Lemma TT' :  *)
(*   forall f : nat -> { Q : list nat & truthtable (length Q)},  *)
(*     exists c : list nat -> nat, forall l x, W (c l) x <-> eval_tt (projT2 (f x)) (map (fun x => negb (inb (uncurry Nat.eqb) x l)) (projT1 (f x))) = true. *)
(* Proof. *)
(*   intros f. pose proof (TT'' f) as [F]. *)
(*   exists (fun l => proj1_sig (F l)). intros. destruct F. cbn. eapply i. *)
(* Qed. *)

(* Definition neg_tt : forall n, truthtable n -> truthtable n := fun n T => mk_tt (fun l => negb (eval_tt T l)). *)

(* Lemma neg_tt_spec n l (T : truthtable n) : *)
(*   length l = n -> *)
(*   eval_tt (neg_tt T) l = negb (eval_tt T l). *)
(* Proof. *)
(*   intros <-.  *)
(*   unfold neg_tt. *)
(*   now rewrite eval_tt_mk_tt. *)
(* Qed. *)

(* Lemma TT :  *)
(*   forall f : nat -> { Q : list nat & truthtable (length Q)},  *)
(*     exists c : list nat -> nat, forall l x, W (c l) x <-> eval_tt (projT2 (f x)) (map (fun x => negb (inb (uncurry Nat.eqb) x l)) (projT1 (f x))) = false. *)
(* Proof. *)
(*   intros f. destruct (TT' (fun n => existT (projT1 (f n)) (neg_tt (projT2 (f n))))) as [c H]. *)
(*   exists c. intros l x. *)
(*   rewrite H. destruct (f x) as [Q T]. cbn. rewrite neg_tt_spec. 2: now rewrite map_length. *)
(*   now rewrite negb_true_iff. *)
(* Qed. *)


Require Import VST.floyd.proofauto.
Require Import VST.progs.even.

Instance CompSpecs : compspecs.
Proof. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Local Open Scope assert.

Definition odd_spec :=
 DECLARE _odd
  WITH z : Z, b: unit
  PRE [ tuint]
    PROP(0 <= z <= Int.max_signed) PARAMS(Vint (Int.repr z)) SEP()
  POST [ tint ]
    PROP() RETURN(Vint (if Z.odd z then Int.one else Int.zero)) SEP().

Definition even_spec :=
 DECLARE _even
  WITH z : Z
  PRE [ tuint]
    PROP(0 <= z <= Int.max_signed) PARAMS(Vint (Int.repr z)) SEP()
  POST [ tint ]
    PROP() RETURN (Vint (if Z.even z then Int.one else Int.zero)) SEP().

Definition main_spec :=
 DECLARE _main
  WITH gv : globals
  PRE  [] main_pre prog tt gv
  POST [ tint ]
    PROP() RETURN (Vint (if Z.even 42 then Int.one else Int.zero)) SEP(has_ext tt).


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e489m21_19limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e444m17_18limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


(* -*- mode: coq; mode: visual-line -*-  *)
Require Import HoTT.Basics HoTT.Types.
Require Import EquivalenceVarieties Idempotents.
Require Import Spaces.BAut Spaces.BAut.Bool.

Local Open Scope path_scope.

(** * An incoherent quasi-idempotent on [BAut (BAut Bool)]. *)

Section IncoherentQuasiIdempotent.
  Context `{Univalence}.

  (** We use the identity map, and the nontrivial 2-central element of [BAut (BAut Bool)]. *)
  Definition nontrivial_qidem_baut_baut_bool
  : IsQuasiIdempotent (preidem_idmap (BAut (BAut Bool)))
    := negb_center2_baut_baut_bool.

  Let s := retract_sect (splitting_preidem_retractof_qidem (preidem_idmap (BAut (BAut Bool)))).
  Let r := retract_retr (splitting_preidem_retractof_qidem (preidem_idmap (BAut (BAut Bool)))).
  Let issect := retract_issect (splitting_preidem_retractof_qidem (preidem_idmap (BAut (BAut Bool)))) : r o s == idmap.

  (** Since the space of splittings of the identity pre-idempotent is contractible, nontriviality of this 2-central element implies that not every quasi-idempotence witness of the identity is recoverable from its own splitting. *)
  Definition splitting_preidem_notequiv_qidem_baut_baut_bool
  : ~ (s o r == idmap).
  Proof.
    intros oops.
    assert (p := oops nontrivial_qidem_baut_baut_bool).
    assert (q := oops (isqidem_idmap (BAut (BAut Bool)))); clear oops.
    apply nontrivial_negb_center_baut_baut_bool.
    refine (p^ @ ap s _ @ q).
    pose (contr_splitting_preidem_idmap (BAut (BAut Bool))).
    apply path_contr.
  Defined.

  (** Therefore, not every quasi-idempotence witness is obtainable from *any* splitting, i.e. it may not have any coherentification. *)
  Definition not_all_coherent_qidem_baut_baut_bool
  : ~ (forall q : IsQuasiIdempotent (preidem_idmap (BAut (BAut Bool))),
         { S : Splitting_PreIdempotent (preidem_idmap _) & s S = q }).
  Proof.
    intros oops.
    assert (IsEquiv s).
    { apply isequiv_biinv; split.
      - exists r; exact issect.
      - exists (fun q => (oops q).1).
        exact (fun q => (oops q).2). }
    apply splitting_preidem_notequiv_qidem_baut_baut_bool; intros q.
    refine (ap s (ap r (eisretr s q)^) @ _).
    refine (ap s (issect (s^-1 q)) @ _).
    apply eisretr.
  Defined.

  (** These results show only that not *every* quasi-idempotence witness is coherent.  "Clearly" the nontrivial quasi-idempotence witness [nontrivial_qidem_baut_baut_bool] should be the one that is not coherent.  To show this, we would probably need to show that [isqidem_idmap] *is* in the image of [s], and this seems rather annoying to do based on our construction of [splitting_preidem_retractof_qidem]. *)

End IncoherentQuasiIdempotent.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e488m17_19limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e291m19_12limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


(* These are the definitions from classical logic, which we cannot prove
in Coq, bit we addd these to Coq for later use in semantics!*)

Module classical.

  (* Excluded middle *)
  Axiom exluded_middle: forall P:Prop, ~P \/ P.

  (* Implication to or like used in ocaml compiler! *)
  Axiom impl_or: forall P Q: Prop, (P -> Q) -> (~P \/ Q).

  Theorem eq : forall P Q:Prop, (P -> Q) -> (~P \/ Q) -> (~P \/ P).
  Proof.
    intros P Q H H0.
    apply exluded_middle.
  Qed.

  Theorem eq2: forall P Q:Prop, (~P \/ P) -> (P -> Q) -> (~P \/ Q).
  Proof.
    intros P Q H H0.
    apply impl_or. apply H0.
  Qed.
End classical.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e401m31_17limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


Require Import Circuit.
Import Circuit_Tactics.

Require Import List.
Import ListNotations.
Open Scope list_scope.
Require Import Monad.

Require Import PeanoNat.
Infix "<?" := (Nat.ltb).

Existing Instance event_eq_dec.
Existing Instance latch_eq_dec.

Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Equality.
Require Import Omega.

(** * Definition of fall-decoupled marked graph *)
Section FallDecoupled.

  Context (even odd : Set).
  Context `{Heven : eq_dec even} `{Hodd : eq_dec odd}.
  Variable c : circuit even odd.
  Variable init_st : state (latch even odd).

  Inductive fd_place : event (latch even odd) bool -> event (latch even odd) bool -> Set :=

  | latch_fall l : fd_place (Rise l) (Fall l)
  | latch_rise l : fd_place (Fall l) (Rise l)
  (* E+ → O+ for (E,O) *)
  (* O+ → E+ for (O,E) *)
  | neighbor_rise_rise l l' : neighbor c l l' ->
                              fd_place (Rise l) (Rise l')
  (* O- → E+ for (E,O) *)
  (* E- → O+ for (O,E) *)
  | neighbor_fall_rise l l' : neighbor c l l' ->
                              fd_place (Fall l') (Rise l)
  .

  Definition fall_decoupled
           : marked_graph (event (latch even odd) bool) :=
    {| place := fd_place
     ; init_marking := fun t1 t2 p => match p with
                                      | neighbor_rise_rise (Odd _) (Even _) _ => 1
                                      | latch_rise (Even _) => 1
                                      | latch_fall (Odd _) => 1
                                      | _ => 0
                                      end
   |}.

(** * Specialized is_enabled predicate *)
Inductive is_enabled_FD : event (latch even odd) bool -> marking fall_decoupled -> Prop :=

| fall_enabled_FD l (m : marking fall_decoupled) :
    0 < m _ _ (latch_fall l) ->
    is_enabled_FD (Fall l) m

| rise_enabled_RD l (m : marking fall_decoupled) :
    0 < m _ _ (latch_rise l) ->
    (forall l0 (pf : neighbor c l0 l),
        0 < m _ _ (neighbor_rise_rise l0 l pf)) ->
    (forall l' (pf : neighbor c l l'),
        0 < m _ _ (neighbor_fall_rise l l' pf)) ->
    is_enabled_FD (Rise l) m.

Lemma FD_is_enabled_equiv : forall e m,
    is_enabled_FD e m -> is_enabled fall_decoupled e m.
Proof.
  destruct e as [[O | E] [ | ]];
    intros m; inversion 1; subst;
    intros e0 p;
    simpl in p;
    dependent destruction p;
    auto.
Qed.

Lemma is_enabled_FD_equiv : forall e m,
    is_enabled fall_decoupled e m ->
    is_enabled_FD e m.
Proof.
  intros e m Henabled.
  unfold is_enabled in *.
  destruct e as [[O | E] [ | ]];
    constructor; intros; apply Henabled; eexists; try (econstructor; eauto; fail).
Qed.

Ltac get_enabled_constraints :=
  try match goal with
  | [ H : is_enabled fall_decoupled _ _ |- _ ] => apply is_enabled_FD_equiv in H; inversion H; subst
  end; specialize_enabled_constraints.

(** * Helper lemmas *)
Section loop_lemmas.

  Variable t : trace (latch even odd) bool.
  Variable m : marking fall_decoupled.

  Hypothesis fd_t_m : [fall_decoupled]⊢ t ↓ m.

  Lemma fd_loop : forall l,
    m _ _ (latch_fall l) + m _ _ (latch_rise l) = 1.
  Proof.
    intros. solve_loop. destruct l; auto.
    (*
    induction fd_t_m; intros [O | E]; try reflexivity.
    + specialize (IHm0 m0 (Odd O)).
      subst; unfold fire;
      repeat compare_next; get_enabled_constraints; try omega.
    + specialize (IHm0 m0 (Even E)).
      subst; unfold fire;
      repeat compare_next; get_enabled_constraints; try omega.
    *)
  Qed.

  Lemma fd_loop_neighbor : forall l l' (pf : neighbor c l l'),
      m _ _ (latch_fall l') + m _ _ (neighbor_fall_rise _ _ pf)
                            + m _ _ (neighbor_rise_rise _ _ pf) = 1.
  Proof.
    intros.
    solve_loop.
    destruct pf; auto.
(*
    induction fd_t_m; intros [O | E] [O' | E'] pf;
      try reflexivity;
      find_event_contradiction;
      subst; unfold fire;
      repeat (compare_next; find_event_contradiction);
        get_enabled_constraints;
        simpl in *;
        try omega.
*)
  Qed.

End loop_lemmas.

Section fd_lemmas.

  Variable t : trace (latch even odd) bool.
  Variable m : marking fall_decoupled.

  Hypothesis fd_t_m : [fall_decoupled]⊢ t ↓ m.

  Lemma marking_fall : forall l,
    m _ _ (latch_fall l) = match transparent t l with
                         | Opaque => 0
                         | Transparent => 1
                         end.
  Proof.
    induction fd_t_m; intros l; auto.
    * destruct l; auto.
    * simpl.
      set (loop := fd_loop t' m m0 l);
      subst. unfold fire.
      repeat compare_next.
      { get_enabled_constraints. omega. }
      { get_enabled_constraints. omega. }
      { rewrite IHm0; auto. }
  Qed.

  Lemma marking_rise : forall l,
    m _ _ (latch_rise l) = match transparent t l with
                         | Opaque => 1
                         | Transparent => 0
                         end.
  Proof.
    induction fd_t_m; intros l; auto.
    * destruct l; auto.
    * simpl.
      set (loop := fd_loop t' m m0 l).
      subst. unfold fire.
      repeat compare_next.
      { get_enabled_constraints. omega. }
      { get_enabled_constraints. omega. }
      { rewrite IHm0; auto. }
  Qed.

  Lemma odd_num_events : forall O,
    ( m _ _ (latch_rise (Odd O)) > 0 ->
      num_events (Fall (Odd O)) t = 1+num_events (Rise (Odd O)) t)
    /\
    ( m _ _ (latch_fall (Odd O)) > 0 ->
      num_events (Fall (Odd O)) t = num_events (Rise (Odd O)) t).
  Proof.
    induction fd_t_m; intros O; split; intros Hrise; auto.
    { contradict Hrise. simpl. inversion 1. }
    { simpl in *.
      set (loop := fd_loop t' m m0 (Odd O)).
      specialize (IHm0 m0 O).
      destruct IHm0 as [IH1 IH2].
      subst; unfold fire in Hrise.
      repeat compare_next; reduce_eqb.
      { rewrite IH2; auto. }
      { contradict Hrise. omega. }
      { apply IH1; auto. }
    }
    { simpl in *.
      set (loop := fd_loop t' m m0 (Odd O)).
      specialize (IHm0 m0 O).
      destruct IHm0 as [IH1 IH2].
      subst; unfold fire in Hrise.
      repeat compare_next; reduce_eqb.
      { contradict Hrise. omega. }
      { rewrite IH1; auto. }
      { apply IH2; auto. }
    }
  Qed.

  Lemma even_num_events : forall E,
    ( m _ _ (latch_rise (Even E)) > 0 ->
      num_events (Rise (Even E)) t = num_events (Fall (Even E)) t)
    /\
    ( m _ _ (latch_fall (Even E)) > 0 ->
      num_events (Rise (Even E)) t = 1+num_events (Fall (Even E)) t).
  Proof.
    induction fd_t_m; intros E; split; intros Hrise; auto.
    { contradict Hrise. simpl. inversion 1. }
    { simpl in *.
      set (loop := fd_loop t' m m0 (Even E)).
      specialize (IHm0 m0 E).
      destruct IHm0 as [IH1 IH2].
      subst; unfold fire in Hrise.
      repeat compare_next; reduce_eqb.
      { contradict Hrise. omega. }
      { rewrite IH2; auto. }
      { rewrite IH1; auto. }
    }
    { simpl in *.
      set (loop := fd_loop t' m m0 (Even E)).
      specialize (IHm0 m0 E).
      destruct IHm0 as [IH1 IH2].
      subst; unfold fire in Hrise.
      repeat compare_next; reduce_eqb.
      { rewrite IH1; auto. }
      { contradict Hrise. omega. }
      { apply IH2; auto. }
    }
  Qed.

  Lemma opaque_num_events : forall l,
    transparent t l = Opaque ->
    num_events (Fall l) t = match l with
                            | Odd _ => 1+num_events (Rise l) t
                            | Even _ => num_events (Rise l) t
                            end.
  Proof.
    intros [O | E] Hopaque.
    * destruct (odd_num_events O) as [H _].
      rewrite H; auto.
      rewrite marking_rise.
      rewrite Hopaque.
      auto.
    * destruct (even_num_events E) as [H _].
      rewrite H; auto.
      rewrite marking_rise.
      rewrite Hopaque.
      auto.
  Qed.

  Lemma transparent_num_events : forall l,
    transparent t l = Transparent ->
    num_events (Rise l) t = match l with
                            | Odd _ => num_events (Fall l) t
                            | Even _ => 1+num_events (Fall l) t
                            end.
  Proof.
    intros [O | E] Htransparent.
    * destruct (odd_num_events O) as [_ H].
      rewrite H; auto.
      rewrite marking_fall.
      rewrite Htransparent.
      auto.
    * destruct (even_num_events E) as [_ H].
      rewrite H; auto.
      rewrite marking_fall.
      rewrite Htransparent.
      auto.
  Qed.

  Section even_odd.
    Variable E : even.
    Variable O : odd.
    Hypothesis Hin : neighbor c (Even E) (Odd O).

    Lemma even_odd_num_events :
       (m _ _ (latch_fall (Odd O)) > 0 ->
        num_events (Rise (Even E)) t = num_events (Rise (Odd O)) t)
    /\ (m _ _ (neighbor_fall_rise _ _ Hin) > 0 ->
        num_events (Rise (Even E)) t = num_events (Rise (Odd O)) t)
    /\ (m _ _ (neighbor_rise_rise _ _ Hin) > 0 ->
        num_events (Rise (Even E)) t = 1+num_events (Rise (Odd O)) t).
    Proof.
      induction fd_t_m;
        try set (Hloop := fd_loop_neighbor t' m m0 _ _ Hin);
        try destruct (IHm0 m0) as [IH1 [IH2 IH3]];
        repeat split; intros Hgt; simpl in *; auto;
        find_contradiction;
        subst; unfold fire in Hgt;
        try (repeat compare_next; auto;
             get_enabled_constraints; contradict Hgt; omega).
    Qed.
  End even_odd.

  Section odd_even.
    Variable O : odd.
    Variable E : even.
    Hypothesis Hin : neighbor c (Odd O) (Even E).

    Lemma odd_even_num_events :
       (m _ _ (latch_fall (Even E)) > 0 ->
        num_events (Rise (Even E)) t = 1+num_events (Rise (Odd O)) t)
    /\ (m _ _ (neighbor_fall_rise _ _ Hin) > 0 ->
        num_events (Rise (Even E)) t = 1+ num_events (Rise (Odd O)) t)
    /\ (m _ _ (neighbor_rise_rise _ _ Hin) > 0 ->
        num_events (Rise (Even E)) t = num_events (Rise (Odd O)) t).
    Proof.
      induction fd_t_m;
        try set (Hloop := fd_loop_neighbor t' m m0 _ _ Hin);
        try destruct (IHm0 m0) as [IH1 [IH2 IH3]];
        repeat split; intros Hgt; simpl in *; auto;
        find_contradiction;
        subst; unfold fire in Hgt;
        try (repeat compare_next; auto;
             get_enabled_constraints; contradict Hgt; omega).
  Qed.
  End odd_even.

  Lemma transparent_neighbor_num_events : forall l,
    transparent t l = Transparent ->
    forall l' (pf : neighbor c l' l),
      num_events (Rise l) t = match l with
                              | Even _ => 1+num_events (Rise l') t
                              | Odd _ => num_events (Rise l') t
                              end.
  Proof.
    intros [O | E] Htransparent l' pf; inversion pf; subst.
    * destruct (even_odd_num_events _ _ pf) as [H _].
      rewrite H; auto.
      rewrite marking_fall.
      rewrite Htransparent.
      auto.

    * destruct (odd_even_num_events _ _ pf) as [H _].
      rewrite H; auto.
      rewrite marking_fall.
      rewrite Htransparent.
      auto.
  Qed.

End fd_lemmas.

  (** * Flow equivalence proof *)

  (** Induction invariant *)
  Lemma fall_decoupled_strong : forall l t o v,
    ⟨ c , init_st ⟩⊢ t ↓ l ↦{ o } v ->
      forall m, [fall_decoupled]⊢ t ↓ m ->
      forall n,
      n = match l with
          | Odd _  => 1+num_events (Rise l) t
          | Even _ => num_events (Rise l) t
          end ->
      v = sync_eval c init_st n l.
  Proof.
    intros l t O v Hrel.
    induction Hrel; intros m Hm n Hn.
    * (* Because l is opaque in the initial marking, l must be even. *)
      inversion Hm; subst. auto.
    * (* l is transparent *)
      rewrite H2.

      assert (n > 0).
      { (* n > 0 *)
        subst.
        destruct l as [O | E]; try omega.
        erewrite transparent_num_events; eauto.
        omega.
      }

      erewrite sync_eval_gt; eauto.

    intros l' Hl'.
    erewrite H1; eauto.

    transitivity (sync_eval c init_st (num_events (Rise l) t) l').
    2:{ inversion Hl'; f_equal; subst; omega. }

    f_equal.
    erewrite transparent_neighbor_num_events with (l := l); eauto.
    inversion Hl'; auto.

  * inversion Hm; subst.
    simpl in *.
    compare_next.
    erewrite IHHrel; eauto.

  * inversion Hm.
    assert (n > 0).
    { subst. destruct l as [O | E]; try omega.
      set (Hopaque := opaque_num_events _ _ Hm (Even E)).
      simpl in Hopaque.
      compare_next.
      specialize (Hopaque eq_refl).
      simpl.
      compare_next.
      rewrite <- Hopaque; omega.
    }

    erewrite sync_eval_gt; eauto.
    intros l' Hl'.

    inversion Hm; subst.

    erewrite H1; eauto.

    assert (transparent t' l = Transparent).
    { get_enabled_constraints.
      rewrite marking_fall with (t := t') in *; auto.
      destruct (transparent t' l); auto; find_contradiction.
    }
    simpl.
    transitivity (sync_eval c init_st (num_events (Rise l) t') l').
    2:{ destruct l; compare_next; simpl; f_equal; omega. }

    f_equal.
    erewrite transparent_neighbor_num_events with (l := l) (l' := l'); eauto.
    inversion Hl'; auto.
Qed.

  (** Main theorem statement *)
  Theorem fall_decoupled_flow_equivalence :
    flow_equivalence fall_decoupled c init_st.
  Proof.
    intros l t v [m Hm] Heval.
    erewrite (fall_decoupled_strong l t Opaque v Heval m Hm); eauto.
    erewrite opaque_num_events; eauto.
    { eapply async_b; eauto. }
  Qed.

End FallDecoupled.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e413m21_17limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e189m25_8limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.