(* monae: Monadic equational reasoning in Coq                                 *)
(* Copyright (C) 2020 monae authors, license: LGPL-2.1-or-later               *)
Ltac typeof X := type of X.

Require Import ssrmatching Reals.
From mathcomp Require Import all_ssreflect.
From mathcomp Require boolp.
From infotheo Require Import Reals_ext.
Require Import monae_lib.
From HB Require Import structures.

(******************************************************************************)
(*        A formalization of monadic effects over the category Set            *)
(*                                                                            *)
(* We consider the type Type of Coq as the category Set and define functors   *)
(* and a hierarchy of monads on top of functors. These monads are used to     *)
(* develop the basics of monadic equational reasoning. The file category.v    *)
(* provides a more generic definition of functors and monads as well as a     *)
(* bridge to this file.                                                       *)
(*                                                                            *)
(* Module FunctorLaws == map laws of a functor                                *)
(*            functor == type of functors                                     *)
(*              F # g == application of the functor F to the morphism g       *)
(*                FId == notation for the identity functor                    *)
(*             F ~> G == natural transformation from functor F to functor G   *)
(*            f ~~> g == forall A, f A -> g A, notation used for the          *)
(*                       components of a natural transformation               *)
(*   naturality F G f == the components f form a natural transformation       *)
(*                       F ~> G                                               *)
(*    Module JoinLaws == join laws of a monad                                 *)
(*            isMonad == mixin of monad                                       *)
(*                >>= == notation for the standard bind operator              *)
(*             m >> f := m >>= (fun _ => f)                                   *)
(*              monad == type of monads                                       *)
(*                Ret == natural transformation FId ~> M for a monad M        *)
(*               Join == natural transformation M \o M ~> M for a monad M     *)
(*    Module BindLaws == bind laws of a monad                                 *)
(*                                                                            *)
(* Failure and nondeterministic monads:                                       *)
(*          failMonad == failure monad                                        *)
(*        failR0Monad == fail is right zero of bind                           *)
(*           altMonad == monad with nondeterministic choice                   *)
(*       prePlusMonad == nondeterminism + failR0 + distributivity             *)
(*          plusMonad == preplusMonad + commutativity and idempotence         *)
(*         altCIMonad == monadAlt + commutativity + idempotence               *)
(*        nondetMonad == monadFail + monadAlt                                 *)
(*      nondetCIMonad == monadFail + monadAltCI                               *)
(*        exceptMonad == monadFail + catch                                    *)
(*                                                                            *)
(* Control monads (wip):                                                      *)
(*   contMonad, shiftresetMonad, jumpMonad                                    *)
(*                                                                            *)
(* State monads:                                                              *)
(*         stateMonad S == state monad with a state of type S                 *)
(*        stateRunMonad == state + RunStateT                                  *)
(*                         let N be a monad and S be the type of states, then *)
(*                         when m is a computation in the monad               *)
(*                         stateRunMonad S N, RunStateT m s runs m in a       *)
(*                         state s and returns a computation in the monad N   *)
(*  exceptStateRunMonad == stateRun + except                                  *)
(*           reifyMonad == reify interface                                    *)
(*      stateReifyMonad == monadState + reify                                 *)
(*  failStateReifyMonad == stateReify + fail                                  *)
(*     nondetStateMonad == backtrackable state                                *)
(*           arrayMonad == array monad                                        *)
(*      plusArrayMonad  == plus monad + array monad                           *)
(*                                                                            *)
(* Trace monads:                                                              *)
(*            traceMonad == trace monad                                       *)
(*       traceReifyMonad == trace + reify                                     *)
(*       stateTraceMonad == state + trace                                     *)
(*  stateTraceReifyMonad == stateTrace + reify                                *)
(*                                                                            *)
(* Probability monads:                                                        *)
(*         probaMonad == probabilistic choice and bind left-distributes over  *)
(*                       choice                                               *)
(*        probDrMonad == probaMonad + bind right-distributes over choice      *)
(*       altProbMonad == combined (probabilistic and nondeterministic) choice *)
(*    exceptProbMonad == exceptions + probabilistic choice                    *)
(*                                                                            *)
(* Freshness monads:                                                          *)
(*         freshMonad == monad with freshness                                 *)
(*     failFreshMonad == freshMonad + failure                                 *)
(*                                                                            *)
(* references:                                                                *)
(* - R. Affeldt, D. Nowak, Extending Equational Monadic Reasoning with Monad  *)
(* Transformers, https://arxiv.org/abs/2011.03463                             *)
(* - R. Affeldt, D. Nowak, T. Saikawa, A Hierarchy of Monadic Effects for     *)
(* Program Verification using Equational Reasoning, MPC 2019                  *)
(* - J. Gibbons, R. Hinze, Just do it: simple monadic equational reasoning,   *)
(* ICFP 2011                                                                  *)
(* - J. Gibbons, Unifying Theories of Programming with Monads, UTP 2012       *)
(******************************************************************************)

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Declare Scope do_notation.
Declare Scope mprog.
Declare Scope monae_scope.
Delimit Scope monae_scope with monae.
Declare Scope proba_monad_scope.

Reserved Notation "f (o) g" (at level 11).
Reserved Notation "m >> f" (at level 49).
Reserved Notation "'fmap' f" (at level 4).
Reserved Notation "x '[~]' y" (at level 50).
Reserved Notation "mx <| p |> my" (format "mx  <| p |>  my", at level 49).

Notation "f ~~> g" := (forall A, f A -> g A)
  (at level 51, only parsing) : monae_scope.

Local Open Scope monae_scope.

Notation UU1 := Type.
Notation UU0 := Type.

(* NB: not putting M in Set -> Set because of expressions like:
  M (A * (size s).-1.-tuple A)%type *)
Module FunctorLaws.
Section def.
Variable (F : UU0 -> UU0) (f : forall A B : UU0, (A -> B) -> F A -> F B).
Definition id := forall A : UU0, f id = id :> (F A -> F A).
Definition comp := forall (A B C : UU0) (g : B -> C) (h : A -> B),
  f (g \o h) = f g \o f h.
End def.
End FunctorLaws.

HB.mixin Record isFunctor (F : UU0 -> UU0) := {
  actm : forall A B : UU0, (A -> B) -> F A -> F B ;
  functor_id : FunctorLaws.id actm ;
  functor_o : FunctorLaws.comp actm }.

#[short(type=functor)]
HB.structure Definition Functor := {F of isFunctor F}.

Notation "F # g" := (@actm F _ _ g) : monae_scope.
Notation "'fmap' f" := (_ # f) : mprog.

Section functorid.
Let id_actm (A B : UU0) (f : A -> B) : idfun A -> idfun B := f.
Let id_id : FunctorLaws.id id_actm. Proof. by []. Qed.
Let id_comp : FunctorLaws.comp id_actm. Proof. by []. Qed.
HB.instance Definition _ := isFunctor.Build idfun id_id id_comp.
End functorid.

(* NB: consider eliminating? *)
Notation FId := [the functor of idfun].

Lemma FIdE (A B : UU0) (f : A -> B) : FId # f = f. Proof. by []. Qed.

Section functor_composition.
Variables f g : functor.

Let comp_actm (A B : UU0) (h : A -> B) : (f \o g) A -> (f \o g) B :=
  f # (g # h).

Let comp_id : FunctorLaws.id comp_actm.
Proof. by rewrite /FunctorLaws.id => A; rewrite /comp_actm 2!functor_id. Qed.

Let comp_comp : FunctorLaws.comp comp_actm.
Proof.
rewrite /FunctorLaws.comp => A B C g' h; rewrite /comp_actm.
by apply boolp.funext => m; rewrite [in RHS]compE 2!functor_o.
Qed.

HB.instance Definition _ := isFunctor.Build (f \o g) comp_id comp_comp.

End functor_composition.

Lemma FCompE (f g : functor) (A B : UU0) (k : A -> B) :
  [the functor of f \o g] # k = f # (g # k).
Proof. by []. Qed.

(* monadic counterpart of function composition:
   composes a pure function after a monadic function *)
Section fcomp.
Variable M : functor.

Definition fcomp (A B C : UU0) (f : A -> B) (g : C -> M A) :=
  locked ((M # f) \o g).
Arguments fcomp : simpl never.
Local Notation "f (o) g" := (fcomp f g).

Lemma fcomp_def (A B C : UU0) (f : A -> B) (g : C -> M A) :
  f (o) g = ((M # f)) \o g.
Proof. by rewrite /fcomp; unlock. Qed.

Lemma fcompE (A B C : UU0) (f : A -> B) (g : C -> M A) c :
  (f (o) g) c = (M # f) (g c).
Proof. by rewrite fcomp_def. Qed.

Lemma fcomp_comp (A B C D : UU0) (f : A -> B) (g : C -> A) (m : D -> M C) :
  (f \o g) (o) m = f (o) (g (o) m).
Proof. by rewrite 3!fcomp_def functor_o compA. Qed.

End fcomp.
Notation "f (o) g" := (fcomp f g) : mprog.
Arguments fcomp : simpl never.

Lemma functor_ext (F G : functor) :
  forall (H : Functor.sort F = Functor.sort G),
  @actm G =
  eq_rect _ (fun m : UU0 -> UU0 => forall A B : UU0, (A -> B) -> m A -> m B)
            (@actm F) _ H  ->
  G = F.
Proof.
move: F G => [F [[HF1 HF2 HF3]]] [G [[HG1 HG2 HG3]]] /= H.
subst F => /= H.
congr (Functor.Pack (Functor.Class _)).
have ? : HG1 = HF1.
  rewrite /actm /= in H.
  apply funext_dep => x.
  apply funext_dep => y.
  apply funext_dep => z.
  by move/(congr1 (fun i => i x y z)) : H.
subst HG1.
congr (isFunctor.Axioms_ _); exact/proof_irr.
Defined.

Definition naturality (F G : functor) (f : F ~~> G) :=
  forall (A B : UU0) (h : A -> B), (G # h) \o f A = f B \o (F # h).
Arguments naturality : clear implicits.

HB.mixin Record isNatural (F G : functor) (f : F ~~> G) := {
  natural : naturality F G f }.

#[short(type=nattrans)]
HB.structure Definition Nattrans (F G : functor) := {f of isNatural F G f}.
Arguments natural {F G} s.
Notation "f ~> g" := (nattrans f g) : monae_scope.

Section natrans_lemmas.
Variables (F G : functor) (phi : F ~> G).
Lemma nattrans_ext (f g : F ~> G) : f = g <-> forall a, (f a = g a :> (_ -> _)).
Proof.
split => [ -> // |]; move: f g => [f Hf] [g Hg] /= fg.
have ? : f = g by exact: funext_dep.
subst g.
suff : Hf = Hg by move=> ->.
case: Hf => -[Hf].
case: Hg => -[Hg].
do 2 f_equal.
exact: proof_irr.
Qed.
End natrans_lemmas.

(*Require Import Logic.Eqdep.

Lemma natural_ext (F G G' : functor) (t : F ~> G) (t' : F ~> G') :
  forall (H : G = G'),
  forall (K : forall X (x : F X), Natural.cpnt t' x = eq_rect _ (fun m : functor => m X) (Natural.cpnt t x) _ H),
  t' = eq_rect _ (fun m : functor => F ~> m) t _ H.
Proof.
move : t t' => [t t1] [t' t'1] /= H; subst G' => H /=.
have ? : t = t'.
  apply funext_dep => A; apply funext_dep => x.
  by rewrite H -[in RHS]eq_rect_eq.
subst t'.
congr Natural.Pack; exact/proof_irr.
Qed.

Lemma natural_ext2 (F F' : functor) (t : F \O F ~> F) (t' : F' \O F' ~> F') :
  forall (K : F = F'),
  forall L : (forall X (x : (F' \O F') X),
    Natural.cpnt t' x = eq_rect _ (fun m : functor => m X)
      (Natural.cpnt t (eq_rect _ (fun m : functor => (m \O m) X) x _ (esym K)))
      _ K),
  t' = eq_rect _ (fun m => m \O m ~> m) t _ K.
Proof.
move: t t' => [t t1] [t' t'1] /= H L; subst F.
rewrite -[in RHS]eq_rect_eq /=.
have ? : t = t'.
  apply funext_dep => A; apply funext_dep => x.
  by rewrite L -[in RHS]eq_rect_eq.
subst t'.
congr Natural.Pack; exact/proof_irr.
Qed.*)

Module JoinLaws.
Section join_laws.
Context {F : functor}.
Variables (ret : FId ~> F) (join : F \o F ~~> F).

Definition left_unit := forall A, @join A \o ret (F A) = id :> (F A -> F A).

Definition right_unit := forall A, @join A \o F # ret A = id :> (F A -> F A).

Definition associativity :=
  forall A, @join A \o F # @join A = @join A \o @join (F A) :> (F (F (F A)) -> F A).

End join_laws.
End JoinLaws.

HB.mixin Record isMonad (F : UU0 -> UU0) of Functor F := {
  ret : FId ~> [the functor of F] ;
  join : [the functor of F \o F] ~> [the functor of F] ;
  bind : forall (A B : UU0), F A -> (A -> F B) -> F B ;
  bindE : forall (A B : UU0) (f : A -> F B) (m : F A),
    bind A B m f = join B (([the functor of F] # f) m) ;
  joinretM : JoinLaws.left_unit ret join ;
  joinMret : JoinLaws.right_unit ret join ;
  joinA : JoinLaws.associativity join }.

#[short(type=monad)]
HB.structure Definition Monad := {F of isMonad F &}.

Notation Ret := (@ret _ _).
Notation Join := (@join _ _).
Arguments bind {s A B} : simpl never.
Notation "m >>= f" := (bind m f) : monae_scope.

Lemma eq_bind (M : monad) (A B : UU0) (m : M A) (f1 f2 : A -> M B) :
  f1 =1 f2 -> m >>= f1 = m >>= f2.
Proof. by move=> f12; congr bind; apply boolp.funext. Qed.

Section monad_lemmas.
Variable M : monad.

Lemma fmapE (A B : UU0) (f : A -> B) (m : M A) :
 (M # f) m = m >>= (ret B \o f).
Proof.
by rewrite bindE [in RHS]functor_o -[in RHS]compE compA joinMret.
Qed.

End monad_lemmas.

Module BindLaws.
Section bindlaws.
Variable F : UU0 -> UU0.
Variable b : forall (A B : UU0), F A -> (A -> F B) -> F B.
Local Notation "m >>= f" := (b m f).

Definition associative := forall A B C (m : F A) (f : A -> F B) (g : B -> F C),
  (m >>= f) >>= g = m >>= (fun x => f x >>= g).

Definition right_distributive (add : forall B, F B -> F B -> F B) :=
  forall A B (m : F A) (k1 k2 : A -> F B),
    m >>= (fun x => add _ (k1 x) (k2 x)) = add _ (m >>= k1) (m >>= k2).

Definition left_distributive (add : forall B, F B -> F B -> F B) :=
  forall A B (m1 m2 : F A) (k : A -> F B),
    (add _ m1 m2) >>= k = add _ (m1 >>= k) (m2 >>= k).

Definition left_zero (f : forall A, F A) :=
  forall (A B : UU0) (g : A -> F B), f A >>= g = f B.

Definition right_zero (f : forall A, F A) :=
  forall (A B : UU0) (g : F B), g >>= (fun _ => f A) = f A.

Definition left_neutral (r : forall A : UU0, A -> F A) :=
  forall (A B : UU0) (a : A) (f : A -> F B), r _ a >>= f = f a.

Definition right_neutral (r : forall A : UU0, A -> F A) :=
  forall A (m : F A), m >>= r _ = m.

Definition left_id (r : forall A, F A) (op : forall B, F B -> F B -> F B) :=
  forall A (m : F A), op _ (r _) m = m.

Definition right_id (r : forall A, F A) (op : forall B, F B -> F B -> F B) :=
  forall A (m : F A), op _ m (r _) = m.

End bindlaws.
End BindLaws.

Definition join_of_bind (F : functor)
    (b : forall (A B : UU0), F A -> (A -> F B) -> F B) : F \o F ~~> F :=
  fun A : UU0 => (b _ A)^~ id.

Definition bind_of_join (F : functor) (j : F \o F ~~> F)
    (A B : UU0) (m : F A) (f : A -> F B) : F B :=
  j B ((F # f) m).

Section from_join_laws_to_bind_laws.
Variable (F : functor) (ret : FId ~> F) (join : [the functor of F \o F] ~> F).

Hypothesis joinretM : JoinLaws.left_unit ret join.
Hypothesis joinMret : JoinLaws.right_unit ret join.
Hypothesis joinA : JoinLaws.associativity join.

Lemma bindretf_derived : BindLaws.left_neutral (bind_of_join join) ret.
Proof.
move=> A B a f; rewrite /bind_of_join -(compE (@join _)) -(compE _ (@ret _)).
by rewrite -compA (natural ret) compA joinretM compidf.
Qed.

Lemma bindmret_derived : BindLaws.right_neutral (bind_of_join join) ret.
Proof. by move=> A m; rewrite /bind_of_join -(compE (@join _)) joinMret. Qed.

Lemma bindA_derived : BindLaws.associative (bind_of_join join).
Proof.
move=> A B C m f g; rewrite /bind_of_join.
rewrite [LHS](_ : _ = ((@join _ \o (F # g \o @join _) \o F # f) m)) //.
rewrite (natural join) (compA (@join C)) -joinA -(compE (@join _)).
transitivity ((@join _ \o F # (@join _ \o (F # g \o f))) m) => //.
by rewrite -2!compA functor_o FCompE -[in LHS](@functor_o F).
Qed.

End from_join_laws_to_bind_laws.

HB.factory Record isMonad_ret_join (F : UU0 -> UU0) of isFunctor F := {
  ret : FId ~> [the functor of F] ;
  join : [the functor of F \o F] ~> [the functor of F] ;
  joinretM : JoinLaws.left_unit ret join ;
  joinMret : JoinLaws.right_unit ret join ;
  joinA : JoinLaws.associativity join }.

HB.builders Context M of isMonad_ret_join M.

Let F := [the functor of M].

Let bind (A B : UU0) (m : F A) (f : A -> F B) : F B :=
  bind_of_join join m f.

Let bindE (A B : UU0) (f : A -> M B) (m : M A) :
  bind m f = join B ((F # f) m).
Proof. by []. Qed.

HB.instance Definition _ := isMonad.Build M bindE joinretM joinMret joinA.
HB.end.

HB.factory Record isMonad_ret_bind (F : UU0 -> UU0) := {
  ret' : forall (A : UU0), A -> F A ;
  bind : forall (A B : UU0), F A -> (A -> F B) -> F B ;
  bindretf : BindLaws.left_neutral bind ret' ;
  bindmret : BindLaws.right_neutral bind ret' ;
  bindA : BindLaws.associative bind }.

HB.builders Context M of isMonad_ret_bind M.

Let actm (a b : UU0) (f : a -> b) m := bind m (@ret' _ \o f).

Let actm_id : FunctorLaws.id actm.
Proof.
move=> a.
rewrite /actm; apply: boolp.funext=> m /=.
by rewrite bindmret.
Qed.

Let actm_comp : FunctorLaws.comp actm.
Proof.
move=> a b c g h.
rewrite /actm; apply: boolp.funext => m /=.
rewrite bindA.
congr bind.
apply: boolp.funext => u /=.
by rewrite bindretf.
Qed.

HB.instance Definition _ := isFunctor.Build M actm_id actm_comp.
Let F := [the functor of M].
Local Notation FF := [the functor of F \o F].

Let ret'_naturality : naturality FId F ret'.
Proof.
move=> a b h.
rewrite FIdE /hierarchy.actm /= /actm; apply: boolp.funext => m /=.
by rewrite bindretf.
Qed.

HB.instance Definition _ :=
  isNatural.Build FId F (ret' : FId ~~> F) ret'_naturality.
Let ret := [the FId ~> F of ret'].

Let join' : FF ~~> F := fun _ m => bind m idfun.

Let actm_bind (a b c : UU0) (f : a -> b) m (g : c -> F a) :
  (actm f) (bind m g) = bind m (actm f \o g).
Proof. by rewrite /actm bindA. Qed.

Let join'_naturality : naturality FF F join'.
Proof.
move=> a b h.
rewrite /join' /=; apply: boolp.funext => mm /=.
rewrite /hierarchy.actm /= /isFunctor.actm /=.
rewrite actm_bind bindA /=.
congr bind.
apply: boolp.funext => m /=.
by rewrite bindretf /=.
Qed.

HB.instance Definition _ := isNatural.Build _ _ _ join'_naturality.
Let join := [the FF ~> F of join'].

Let bind_map (A B C : UU0) (f : A -> B) (m : M A) (g : B -> M C) :
  bind ((F # f) m) g = bind m (g \o f).
Proof.
rewrite bindA; congr bind.
by apply: boolp.funext => ?; rewrite bindretf.
Qed.

Let bindE (a b : UU0) (f : a -> M b) (m : M a) :
  bind m f = join b ((F # f) m).
Proof.
rewrite /join /= /hierarchy.actm /= /join' /=.
by rewrite bind_map.
Qed.

Let joinretM : JoinLaws.left_unit ret join.
Proof.
move=> a; apply: boolp.funext => m.
by rewrite /join /= /join' /= bindretf.
Qed.

Let joinMret : JoinLaws.right_unit ret join.
Proof.
move=> a; apply: boolp.funext => m.
rewrite /join /= /join'.
rewrite /hierarchy.actm /= /actm /=.
rewrite bindA /=.
rewrite [X in bind m X](_ : _ = fun x => ret' x) ?bindmret //=; apply: boolp.funext => ?.
by rewrite bindretf.
Qed.

Let joinA : JoinLaws.associativity join.
Proof.
move => a; apply: boolp.funext => m.
rewrite /join /= /join'.
rewrite /hierarchy.actm /= /actm.
rewrite !bindA.
congr bind.
apply: boolp.funext => u /=.
by rewrite bindretf.
Qed.

HB.instance Definition _ := isMonad.Build M bindE joinretM joinMret joinA.
HB.end.

Section monad_lemmas.
Variable M : monad.

Lemma bindretf : BindLaws.left_neutral (@bind M) ret.
Proof.
move: (@bindretf_derived M ret join joinretM).
rewrite (_ : bind_of_join _ = @bind M) //.
apply funext_dep => A; apply funext_dep => B.
apply funext_dep => m; apply funext_dep => f.
by rewrite bindE.
Qed.

Lemma bindmret : BindLaws.right_neutral (@bind M) ret.
Proof.
move: (@bindmret_derived M ret join joinMret).
rewrite (_ : bind_of_join _ = @bind M) //.
apply funext_dep => A; apply funext_dep => B.
apply funext_dep => m; apply funext_dep => f.
by rewrite bindE.
Qed.

Lemma bindA : BindLaws.associative (@bind M).
Proof.
move: (@bindA_derived M join joinA).
rewrite (_ : bind_of_join _ = @bind M) //.
apply funext_dep => A; apply funext_dep => B.
apply funext_dep => m; apply funext_dep => f.
by rewrite bindE.
Qed.

End monad_lemmas.

Notation "'do' x <- m ; e" := (bind m (fun x => e)) (only parsing) : do_notation.
Notation "'do' x : T <- m ; e" :=
  (bind m (fun x : T => e)) (only parsing) : do_notation.
Delimit Scope do_notation with Do.
Notation "m >> f" := (bind m (fun _ => f)) : monae_scope.

Fixpoint sequence (M : monad) A (s : seq (M A)) : M (seq A) :=
  (if s isn't h :: t then Ret [::] else
  do v <- h; do vs <- sequence t; Ret (v :: vs))%Do.

Lemma sequence_nil (M : monad) (A : UU0) :
  sequence [::] = Ret [::] :> M (seq A).
Proof. by []. Qed.

Lemma sequence_cons (M : monad) A h (t : seq (M A)) :
  (sequence (h :: t) = do x <- h ; do vs <- sequence t ; Ret (x :: vs))%Do.
Proof. by []. Qed.

Definition skip M := @ret M _ tt.
Arguments skip {M} : simpl never.

Ltac bind_ext :=
  let congr_ext m := ltac:(congr (bind m); apply boolp.funext) in
  match goal with
    | |- @bind _ _ _ ?m ?f1 = @bind _ _ _ ?m ?f2 =>
      congr_ext m
    | |- @bind _ _ _ ?m1 ?f1 = @bind _ _ _ ?m2 ?f2 =>
      first[ simpl m1; congr_ext m1 | simpl m2; congr_ext m2 ]
  end.

Section bindskip.
Lemma bindmskip (M : monad) (m : M unit) : m >> skip = m.
Proof. rewrite -[RHS]bindmret; bind_ext; by case. Qed.

Lemma bindskipf (M : monad) A (m : M A) : skip >> m = m.
Proof. exact: bindretf. Qed.
End bindskip.

(* experimental *)
Tactic Notation "With" tactic(tac) "Open" ssrpatternarg(pat) :=
  ssrpattern pat;
  let f := fresh "f" in
  intro f;
  let g := fresh "g" in
  let typ := typeof f in
  let x := fresh "x" in
  evar (g : typ);
  rewrite (_ : f = g);
  [rewrite {}/f {}/g|
   apply boolp.funext => x; rewrite {}/g {}/f; tac]; last first.

Tactic Notation "Open" ssrpatternarg(pat) :=
  With (idtac) Open pat.

Section fmap_and_join.
Variable M : monad.
Local Open Scope mprog.

Lemma bind_fmap (A B C : UU0) (f : A -> B) (m : M A) (g : B -> M C) :
  fmap f m >>= g = m >>= (g \o f).
Proof. by rewrite fmapE bindA; under eq_bind do rewrite bindretf. Qed.

Lemma fmap_if (A B : UU0) (f : A -> B) b (m : M A) a :
  fmap f (if b then m else Ret a) = if b then fmap f m else Ret (f a).
Proof. case: ifPn => Hb //; by rewrite fmapE bindretf. Qed.

Lemma fmap_bind (A B C : UU0) (f : A -> B) m (g : C -> M A) :
  fmap f (m >>= g) = m >>= (f (o) g).
Proof.
rewrite fcomp_def fmapE bindA; bind_ext => c.
by rewrite compE -/(fmap _ _) fmapE.
Qed.

Lemma skip_fmap (A B : UU0) (f : A -> B) (mb : M B) ma :
  mb >> (fmap f ma) = fmap f (mb >> ma).
Proof. by rewrite fmap_bind fcomp_def. Qed.

(*Lemma rev_map A B (f : A -> B) : rev \o map f = map f \o rev.
Proof.
apply functional_extensionality.
by elim=> // h t /= IH; rewrite !rev_cons IH map_rcons.
Qed.*)

Lemma joinE A (pp : M (M A)) : Join pp = pp >>= id.
Proof. rewrite bindE; congr Join; by rewrite functor_id. Qed.

Lemma join_fmap (A B : UU0) (f : A -> M B) (m : M A) : Join (fmap f m) = m >>= f.
Proof. by rewrite bindE. Qed.

End fmap_and_join.

Section kleisli.
Variable M : monad.
Implicit Types A B C D : UU0.

Definition kleisli A B C (m : B -> M C) (n : A -> M B) : A -> M C :=
  Join \o (M # m) \o n.
Local Notation "m <=< n" := (kleisli m n).
Local Notation "m >=> n" := (kleisli n m).

Lemma kleisli_def A B C (g : B -> M C) (f : A -> M B) :
  (f >=> g) = Join \o (M # g) \o f.
Proof. by []. Qed.

Lemma kleisliE A B C (g : B -> M C) (f : A -> M B) (a : A) :
  (f >=> g) a = (f a) >>= g.
Proof. by rewrite /kleisli /= join_fmap. Qed.

Lemma bind_kleisli A B C m (f : A -> M B) (g : B -> M C) :
  m >>= (f >=> g) = (m >>= f) >>= g.
Proof. by rewrite bindA; bind_ext => a; rewrite /kleisli !compE join_fmap. Qed.

Lemma ret_kleisli A B (k : A -> M B) : Ret >=> k = k.
Proof. by rewrite /kleisli -compA (natural ret) FIdE compA joinretM. Qed.

Local Open Scope mprog.
Lemma fcomp_kleisli A B C D (f : A -> B) (g : C -> M A) (h : D -> M C) :
  f (o) (g <=< h) = (f (o) g) <=< h.
Proof.
rewrite /kleisli 2!fcomp_def 2!(compA (fmap f)) natural [in RHS]functor_o.
by rewrite -compA.
Qed.

Lemma kleisli_fcomp A B C (f : A -> M B) (g : B -> A) (h : C -> M B) :
  ((f \o g) <=< h) = f <=< (g (o) h).
Proof. by rewrite /kleisli fcomp_def functor_o 2!compA. Qed.
Local Close Scope mprog.

Lemma kleisliA A B C D (f : A -> M B) (g : B -> M C) (h : C -> M D) :
  f >=> g >=> h = f >=> (g >=> h).
Proof.
apply: funext_dep => a; rewrite !kleisliE bindA.
by under [in RHS]eq_bind do rewrite kleisliE.
Qed.

End kleisli.
Notation "m <=< n" := (kleisli m n) : monae_scope.
Notation "m >=> n" := (kleisli n m) : monae_scope.

HB.mixin Record isMonadFail (M : UU0 -> UU0) of Monad M := {
  fail : forall A : UU0, M A;
    (* exceptions are left-zeros of sequential composition *)
  bindfailf : BindLaws.left_zero (@bind [the monad of M]) fail
    (* fail A >>= f = fail B *) }.

#[short(type=failMonad)]
HB.structure Definition MonadFail := {M of isMonadFail M & }.

Arguments bindfailf [_].
Arguments fail {_} {_}.

Section guard_assert.
Variable M : failMonad.

Definition guard (b : bool) : M unit := locked (if b then skip else fail).

Lemma guardPn (b : bool) : if_spec b skip fail (~~ b) b (guard b).
Proof. by rewrite /guard; unlock; case: ifPn => ?; constructor. Qed.

Lemma guardT : guard true = skip. Proof. by rewrite /guard; unlock. Qed.

Lemma guardF : guard false = fail. Proof. by rewrite /guard; unlock. Qed.

(* guard distributes over conjunction *)
Lemma guard_and a b : guard (a && b) = guard a >> guard b.
Proof.
move: a b => -[|] b /=; by [rewrite guardT bindskipf | rewrite guardF bindfailf].
Qed.

Definition assert {A : UU0} (p : pred A) (a : A) : M A :=
  locked (guard (p a) >> Ret a).

Lemma assertE {A : UU0} (p : pred A) (a : A) :
  assert p a = guard (p a) >> Ret a.
Proof. by rewrite /assert; unlock. Qed.

Lemma assertT {A : UU0} (a : A) : assert xpredT a = Ret a.
Proof. by rewrite assertE guardT bindskipf. Qed.

Lemma assertF {A : UU0} (a : A) : assert xpred0 a = fail.
Proof. by rewrite assertE guardF bindfailf. Qed.

Lemma assertPn {A : UU0} (p : pred A) (a : A) :
  if_spec (p a) (Ret a) fail (~~ (p a)) (p a) (assert p a).
Proof.
rewrite assertE; case: guardPn => pa;
  by [rewrite bindskipf; constructor | rewrite bindfailf; constructor].
Qed.

Definition bassert {A : UU0} (p : pred A) (m : M A) : M A := m >>= assert p.

(* follows from guards commuting with anything *)
Lemma commutativity_of_assertions A q :
  Join \o (M # (bassert q)) = bassert q \o Join :> (_ -> M A).
Proof.
by apply boolp.funext => x; rewrite !compE join_fmap /bassert joinE bindA.
Qed.

(* guards commute with anything *)
Lemma guardsC (HM : BindLaws.right_zero (@bind M) (@fail _)) b B (m : M B) :
  guard b >> m = m >>= assert (fun=> b).
Proof.
case: guardPn => Hb.
- rewrite bindskipf.
  under eq_bind do rewrite assertT.
  by rewrite bindmret.
- under [RHS]eq_bind do rewrite assertF.
  by rewrite bindfailf HM.
Qed.

End guard_assert.
Arguments assert {M} {A}.
Arguments guard {M}.

HB.mixin Record isMonadAlt (M : UU0 -> UU0) of Monad M := {
  alt : forall T : UU0, M T -> M T -> M T ;
  altA : forall T : UU0, associative (@alt T) ;
  (* composition distributes leftwards over choice *)
  alt_bindDl : BindLaws.left_distributive (@bind [the monad of M]) alt
(* in general, composition does not distribute rightwards over choice *)
(* NB: no bindDr to accommodate both angelic and demonic interpretations of
   nondeterminism *) }.

#[short(type=altMonad)]
HB.structure Definition MonadAlt := {M of isMonadAlt M & }.

Notation "a [~] b" := (@alt _ _ a b). (* infix notation *)

HB.mixin Record isMonadAltCI (M : UU0 -> UU0) of MonadAlt M := {
  altmm : forall A : UU0, idempotent (@alt [the altMonad of M] A) ;
  altC : forall A : UU0, commutative (@alt [the altMonad of M] A) }.

#[short(type=altCIMonad)]
HB.structure Definition MonadAltCI := {M of isMonadAltCI M & }.

Arguments altC {_} {_}.
Arguments altmm {_} {_}.

Section altci_lemmas.
Variable (M : altCIMonad).

Lemma altCA A : @left_commutative (M A) (M A) (fun x y => x [~] y).
Proof. by move=> x y z; rewrite altA altC altA altC (altC x). Qed.

Lemma altAC A : @right_commutative (M A) (M A) (fun x y => x [~] y).
Proof. move=> x y z; by rewrite altC altA (altC x). Qed.

Lemma altACA A : @interchange (M A) (fun x y => x [~] y) (fun x y => x [~] y).
Proof. move=> x y z t; rewrite !altA; congr (_ [~] _); by rewrite altAC. Qed.

End altci_lemmas.

HB.mixin Record isMonadNondet (M : UU0 -> UU0) of MonadFail M & MonadAlt M := {
  altfailm :
    @BindLaws.left_id [the functor of M] (@fail [the failMonad of M])
                                         (@alt [the altMonad of M]);
  altmfail :
    @BindLaws.right_id [the functor of M] (@fail [the failMonad of M])
                                          (@alt [the altMonad of M]) }.

#[short(type=nondetMonad)]
HB.structure Definition MonadNondet :=
  {M of isMonadNondet M & MonadFail M & MonadAlt M}.

#[short(type=nondetCIMonad)]
HB.structure Definition MonadCINondet := {M of MonadAltCI M & MonadNondet M}.

Section nondet_big.
Variables (M : nondetMonad) (A : UU0).
Canonical alt_monoid :=
  Monoid.Law (@altA M A) (@altfailm _ _) (@altmfail _ _).

Lemma test_bigop n : \big[(@alt _ _)/fail]_(i < n) (fail : M A) = fail.
Proof.
elim: n => [|n IH]; first by rewrite big_ord0.
by rewrite big_ord_recr /= IH altmfail.
Qed.

End nondet_big.

HB.mixin Record isMonadFailR0 (M : UU0 -> UU0) of MonadFail M :=
 { bindmfail : BindLaws.right_zero (@bind [the monad of M]) (@fail _) }.

#[short(type=failR0Monad)]
HB.structure Definition MonadFailR0 := {M of isMonadFailR0 M & }.

HB.mixin Record isMonadPrePlus (M : UU0 -> UU0)
    of MonadNondet M & MonadFailR0 M :=
  { alt_bindDr : BindLaws.right_distributive (@bind [the monad of M]) alt }.

#[short(type=prePlusMonad)]
HB.structure Definition MonadPrePlus := {M of isMonadPrePlus M & }.

#[short(type=plusMonad)]
HB.structure Definition MonadPlus := {M of MonadCINondet M & MonadPrePlus M}.

HB.mixin Record isMonadExcept (M : UU0 -> UU0) of MonadFail M := {
  catch : forall A, M A -> M A -> M A ;
  (* monoid *)
  catchmfail : forall A, right_id fail (@catch A) ;
  catchfailm : forall A, left_id fail (@catch A) ;
  catchA : forall A, associative (@catch A) ;
  (* unexceptional bodies need no handler *)
  catchret : forall A x, @left_zero (M A) (M A) (Ret x) (@catch A)
  (* NB: left-zero of sequential composition inherited from failMonad *) }.

#[short(type=exceptMonad)]
HB.structure Definition MonadExcept := {M of isMonadExcept M & }.

Arguments catch {_} {_}.

HB.mixin Record isMonadContinuation (M : UU0 -> UU0) of Monad M := {
(* NB: interface is wip *)
  callcc : forall A B : UU0, ((A -> M B) -> M A) -> M A;
  callcc0 : forall (A B : UU0) (g : (A -> M B) -> M A) (k : B -> M B),
    @callcc _ _ (fun f => g (fun x => f x >>= k)) = @callcc _ _ g
    (* see Sect. 7.2 of [Schrijvers, 19] *);
  callcc1 : forall (A B : UU0) (m : M B),
    @callcc _ _ (fun _ : B -> M A => m) = m
    (* see Sect. 3.3 of [Wadler, 94] *);
  callcc2 : forall (A B C : UU0) (m : M A) x (k : A -> B -> M C),
    @callcc _ _ (fun f : _ -> M _ => m >>= (fun a => f x >>= (fun b => k a b)))
    = @callcc _ _ (fun f : _ -> M _ => m >> f x) ;
  callcc3 : forall (A B : UU0) (m : M A) b,
    @callcc _ _ (fun f : B -> M B => m >> f b) =
    @callcc _ _ (fun _ : B -> M B => m >> Ret b) }.

#[short(type=contMonad)]
HB.structure Definition MonadContinuation := {M of isMonadContinuation M & }.
Arguments callcc {_} {_} {_}.

HB.mixin Record isMonadShiftReset (U : UU0) (M : UU0 -> UU0)
    of MonadContinuation M := {
  shift : forall A : UU0, ((A -> M U) -> M U) -> M A ;
  reset : M U -> M U ;
  shiftreset0 : forall (A : UU0) (m : M A), @shift _ (fun k => m >>= k) = m ;
    (* see Sect. 3.3 of [Wadler, 94] *)
  shiftreset1 : forall (A B : UU0) (h : (A -> M B) -> M A), callcc h =
    @shift _ (fun k' => h (fun x => @shift _ (fun k'' => k' x)) >>= k') ;
    (* see Sect. 3.3 of [Wadler, 94] *)
  shiftreset2 : forall (A : UU0) (c : A) (c': U) (k : A -> U -> _),
    (reset (do x <- Ret c; do y <- @shift _ (fun _ => Ret c'); k x y) =
     Ret c >> Ret c')%Do ;
  shiftreset3 : forall (c c' : U) (k : U -> U -> _),
    (reset (do x <- Ret c; do y <- @shift _ (fun f => do v <- f c'; f v);
            Ret (k x y)) =
     reset (do x <- Ret c; do y <- @shift _ (fun f => f c');
            Ret (k x (k x y))))%Do ;
  shiftreset4 : forall (c : U) k,
    (reset (do y <- @shift _ (@^~ c); Ret (k y)) = Ret (k c))%Do }.

#[short(type=shiftresetMonad)]
HB.structure Definition MonadShiftReset U := {M of isMonadShiftReset U M & }.
Arguments shift {_} {_} {_}.

(* NB: wip, no model *)
(* Sect. 7.2 of [Tom Schrijvers & al., Monad Transformers and Modular
Algebraic Eﬀects: What Binds Them Together, Haskell 2019] *)
HB.mixin Record isMonadJump (ref : UU0 -> UU0) (M : UU0 -> UU0) of Monad M := {
  jump : forall A B : UU0, ref A -> A -> M B;
  sub : forall A B : UU0, (ref A -> M B) -> (A -> M B) -> M B;
  jump0 : forall (A B : UU0) k x, @sub _ _ (fun r => @jump A B r x) k = k x ;
  jump1 : forall (A B : UU0) p k, @sub A B (fun _ => p) k = p;
  jump2 : forall (A B : UU0) p r', @sub _ _ p (@jump A B r') = p r';
  jump3 : forall (A B : UU0) (p : ref A -> ref B -> M B) (k1 : A -> M B) k2,
    @sub _ _ (fun r1 : ref A => @sub _ _ (fun r2 => p r1 r2) (k2 r1)) k1 =
    @sub _ _ (fun r2 : ref B => @sub _ _ (fun r1 => p r1 r2) k1)
             (fun x => @sub _ _ (k2^~ x) k1)
    (*NB: differs from [Schrijvers et al. 19]*);
  jump4 : forall (A B : UU0) r x k, (@jump A B r x) >>= k = @jump A B r x;
  jump5 : forall (A B : UU0) p q k,
    @sub A B p q >>= k = @sub A B (p >=> k) (q >=> k) }.

#[short(type=jumpMonad)]
HB.structure Definition MonadJump ref := {M of isMonadJump ref M & }.
Definition Jump ref (M : jumpMonad ref) := @jump ref M.
Arguments Jump {_} {_} {_} {_}.
Definition Sub ref (M : jumpMonad ref) := @sub ref M.
Arguments sub {_} {_} {_} {_}.

HB.mixin Record isMonadState (S : UU0) (M : UU0 -> UU0) of Monad M := {
  get : M S ;
  put : S -> M unit ;
  putput : forall s s', put s >> put s' = put s' ;
  putget : forall s, put s >> get = put s >> Ret s ;
  getputskip : get >>= put = skip ;
  getget : forall (A : UU0) (k : S -> S -> M A),
    get >>= (fun s => get >>= k s) = get >>= fun s => k s s }.

#[short(type=stateMonad)]
HB.structure Definition MonadState (S : UU0) := { M of isMonadState S M & }.

(*NB: explicit join newly added*)
#[short(type=failStateMonad)]
HB.structure Definition MonadFailState (S : UU0) :=
  { M of isMonadFail M & isMonadState S M & isMonad M & isFunctor M }.

(*NB: explicit join newly added*)
#[short(type=failR0StateMonad)]
HB.structure Definition MonadFailR0State (S : UU0) :=
  { M of isMonadFailR0 M & isMonadState S M & isMonadFail M & isMonad M &
         isFunctor M }.

#[short(type=nondetStateMonad)]
HB.structure Definition MonadNondetState (S : UU0) :=
  { M of MonadPrePlus M & MonadState S M }.

HB.mixin Record isMonadStateRun (S : UU0) (N : monad)
   (M : UU0 -> UU0) of MonadState S M := {
  runStateT : forall A : UU0, M A -> S -> N (A * S)%type ;
  runStateTret : forall (A : UU0) (a : A) (s : S),
    @runStateT _ (Ret a) s = Ret (a, s) ;
  runStateTbind : forall (A B : UU0) (m : M A) (f : A -> M B) (s : S),
    @runStateT _ (m >>= f) s =
    @runStateT _ m s >>= fun x => @runStateT _ (f x.1) x.2 ;
  runStateTget : forall s : S, @runStateT _ get s = Ret (s, s) ;
  runStateTput : forall s' s : S, @runStateT _ (put s') s = Ret (tt, s') }.

#[short(type=stateRunMonad)]
HB.structure Definition MonadStateRun (S : UU0) (N : monad) :=
  {M of isMonadStateRun S N M & }.

Arguments runStateT {_} {_} {_} {_}.

HB.mixin Record isMonadExceptStateRun
    (S : UU0) (N : exceptMonad) (M : UU0 -> UU0)
    of MonadStateRun S N M & MonadExcept M := Mixin {
  runStateTfail : forall (A : UU0) (s : S),
    runStateT (@fail [the exceptMonad of M] A) s = @fail N _ ;
  runStateTcatch : forall (A : UU0) (s : S) (m1 m2 : M A),
    runStateT (@catch [the exceptMonad of M] _ m1 m2) s =
    @catch N _ (runStateT m1 s) (runStateT m2 s) }.

#[short(type=exceptStateRunMonad)]
HB.structure Definition MonadExceptStateRun (S : UU0) (N : exceptMonad) :=
  {M of isMonadExceptStateRun S N M & }.

HB.mixin Record isMonadReify (S : UU0) (M : UU0 -> UU0) of Monad M := {
  reify : forall A : UU0, M A -> S -> option (A * S)%type ;
  reifyret : forall (A : UU0) (a : A) s, @reify _ (Ret a) s = Some (a, s) ;
  reifybind : forall (A B : UU0) (m : M A) (f : A -> M B) s,
      @reify _ (m >>= f) s = match @reify _ m s with
                             | Some a's' => @reify _ (f a's'.1) a's'.2
                             | None => None
                             end }.

#[short(type=reifyMonad)]
HB.structure Definition MonadReify (S : UU0) := {M of isMonadReify S M & }.
Arguments reify {_} {_} {_}.

HB.mixin Record isMonadStateReify (S : UU0) (M : UU0 -> UU0)
    of MonadReify S M & MonadState S M := {
  reifyget : forall s, reify (@get _ [the stateMonad S of M]) s = Some (s, s) ;
  reifyput : forall s s',
    reify (@put _ [the stateMonad S of M] s') s = Some (tt, s') }.

#[short(type=stateReifyMonad)]
HB.structure Definition MonadStateReify (S : UU0) :=
  {M of isMonadStateReify S M &}.

HB.mixin Record isMonadFailReify (S : UU0) (M : UU0 -> UU0)
    of MonadReify S M & MonadFail M :=
  { reifyfail : forall S' (s : S),
      reify (@fail [the failMonad of M] S') s = None }.

#[short(type=failReifyMonad)]
HB.structure Definition MonadFailReify (S : UU0) :=
  {M of isMonadFailReify S M & }.

#[short(type=failFailR0ReifyMonad)]
HB.structure Definition MonadFailFailR0Reify (S : UU0) :=
  {M of MonadFailReify S M & MonadFailR0 M}.

#[short(type=failStateReifyMonad)]
HB.structure Definition MonadFailStateReify (S : UU0) :=
  {M of MonadStateReify S M & MonadFailFailR0Reify S M}.

(* NB: this is experimental, may disappear, see rather foreach in
   monad_transformer because it is more general *)
HB.mixin Record isMonadStateLoop (S : UU0) (M : UU0 -> UU0)
    of MonadState S M := {
  foreach : nat -> nat -> (nat -> M unit) -> M unit ;
  loop0 : forall m body, foreach m m body = Ret tt ;
  loop1 : forall m n body,
    foreach (m.+1 + n) m body = (body (m + n)) >> foreach (m + n) m body }.

#[short(type=loopStateMonad)]
HB.structure Definition MonadStateLoop (S : UU0) :=
  {M of isMonadStateLoop S M & }.

HB.mixin Record isMonadArray (S : UU0) (I : eqType) (M : UU0 -> UU0)
    of Monad M := {
  aget : I -> M S ;
  aput : I -> S -> M unit ;
  aputput : forall i s s', aput i s >> aput i s' = aput i s' ;
  aputget : forall i s (A : UU0) (k : S -> M A), aput i s >> aget i >>= k =
      aput i s >> k s ;
  agetputskip : forall i, aget i >>= aput i = skip ;
  agetget : forall i (A : UU0) (k : S -> S -> M A),
    aget i >>= (fun s => aget i >>= k s) = aget i >>= fun s => k s s ;
  agetC : forall i j (A : UU0) (k : S -> S -> M A),
    aget i >>= (fun u => aget j >>= (fun v => k u v)) =
    aget j >>= (fun v => aget i >>= (fun u => k u v)) ;
  aputC : forall i j u v, (i != j) \/ (u = v) ->
    aput i u >> aput j v = aput j v >> aput i u ;
  aputgetC : forall i j u (A : UU0) (k : S -> M A), i != j ->
    aput i u >> aget j >>= k =
    aget j >>= (fun v => aput i u >> k v) }.

#[short(type=arrayMonad)]
HB.structure Definition MonadArray (S : UU0) (I : eqType) :=
  { M of isMonadArray S I M & isMonad M & isFunctor M }.

#[short(type=plusArrayMonad)]
HB.structure Definition MonadPlusArray (S : UU0) (I : eqType) :=
  { M of MonadPlus M & isMonadArray S I M}.

HB.mixin Record isMonadTrace (T : UU0) (M : UU0 -> UU0) of Monad M :=
 { mark : T -> M unit }.

#[short(type=traceMonad)]
HB.structure Definition MonadTrace (T : UU0) := {M of isMonadTrace T M & }.

HB.mixin Record isMonadTraceReify (T : UU0) (M : UU0 -> UU0)
    of MonadReify (seq T) M & MonadTrace T M := {
  reifytmark : forall t l,
    reify (@mark _ [the traceMonad T of M] t) l = Some (tt, rcons l t) }.

HB.mixin Record isMonadStateTrace (S T : UU0) (M : UU0 -> UU0) of Monad M := {
  st_get : M S ;
  st_put : S -> M unit ;
  st_mark : T -> M unit ;
  st_putput : forall s s', st_put s >> st_put s' = st_put s' ;
  st_putget : forall s, st_put s >> st_get = st_put s >> Ret s ;
  st_getputskip : st_get >>= st_put = skip ;
  st_getget : forall (A : UU0) (k : S -> S -> M A),
    st_get >>= (fun s => st_get >>= k s) = st_get >>= fun s => k s s ;
  st_putmark : forall s e, st_put s >> st_mark e = st_mark e >> st_put s ;
  st_getmark : forall e (k : _ -> M S),
    st_get >>= (fun v => st_mark e >> k v) = st_mark e >> st_get >>= k }.

#[short(type=stateTraceMonad)]
HB.structure Definition MonadStateTrace (S T : UU0) :=
  { M of isMonadStateTrace S T M & isMonad M & isFunctor M }.

HB.mixin Record isMonadStateTraceReify (S T : UU0) (M : UU0 -> UU0)
    of MonadReify (S * seq T)%type M & MonadStateTrace S T M := {
  reifystget : forall s l,
    reify (@st_get _ _ [the stateTraceMonad S T of M]) (s, l) =
    Some (s, (s, l)) ;
  reifystput : forall s l s',
    reify (@st_put _ _ [the stateTraceMonad S T of M] s') (s, l) =
    Some (tt, (s', l)) ;
  reifystmark : forall t s l,
    reify (@st_mark _ _ [the stateTraceMonad S T of M] t) (s, l) =
    Some (tt, (s, rcons l t)) }.

#[short(type=stateTraceReifyMonad)]
HB.structure Definition MonadStateTraceReify (S T : UU0) :=
  { M of isMonadStateTraceReify S T M & isFunctor M & isMonad M &
         isMonadReify S M & isMonadStateTrace S T M }.

Local Open Scope reals_ext_scope.
HB.mixin Record isMonadProb (M : UU0 -> UU0) of Monad M := {
  choice : forall (p : prob) (T : UU0), M T -> M T -> M T ;
  (* identity axioms *)
  choice0 : forall (T : UU0) (a b : M T), choice 0%:pr _ a b = b ;
  choice1 : forall (T : UU0) (a b : M T), choice 1%:pr _ a b = a ;
  (* skewed commutativity *)
  choiceC : forall (T : UU0) p (a b : M T),
    choice p _ a b = choice (p.~ %:pr) _ b a ;
  choicemm : forall (T : UU0) p, idempotent (@choice p T) ;
  (* quasi associativity *)
  choiceA : forall (T : UU0) (p q r s : prob) (a b c : M T),
    (p = r * s :> R /\ s.~ = p.~ * q.~)%R ->
    (*NB: needed to preserve the notation in the resulting choiceA lemma*)
    let bc := choice q _ b c in
    let ab := choice r _ a b in
    choice p _ a bc = choice s _ ab c;
  (* composition distributes leftwards over [probabilistic] choice *)
  choice_bindDl :
    forall p, BindLaws.left_distributive (@bind [the monad of M]) (choice p) }.

#[short(type=probMonad)]
HB.structure Definition MonadProb := {M of isMonadProb M & }.
Notation "a <| p |> b" := (choice p _ a b) : proba_monad_scope.
Arguments choiceA {_} {_} _ _ _ _ {_} {_} {_}.
Arguments choiceC {_} {_} _ _ _.
Arguments choicemm {_} {_} _.

HB.mixin Record isMonadProbDr (M : UU0 -> UU0) of MonadProb M := {
  (* composition distributes rightwards over [probabilistic] choice *)
  (* WARNING: this should not be asserted as an axiom in conjunction with
     distributivity of <||> over [] *)
  prob_bindDr : (* NB: not used *)
    forall p, BindLaws.right_distributive (@bind [the monad of M]) (choice p) }.

#[short(type=probDrMonad)]
HB.structure Definition MonadProbDr := {M of isMonadProbDr M & }.

HB.mixin Record isMonadAltProb (M : UU0 -> UU0) of MonadAltCI M & MonadProb M :=
  { choiceDr : forall T p, right_distributive
      (@choice [the probMonad of M] p T) (fun a b => a [~] b) }.

#[short(type=altProbMonad)]
HB.structure Definition MonadAltProb :=
  { M of isMonadAltProb M & isFunctor M & isMonad M & isMonadAlt M &
         isMonadAltCI M & isMonadProb M }.

Section altprob_lemmas.
Local Open Scope proba_monad_scope.
Variable (M : altProbMonad).
Lemma choiceDl A p :
  left_distributive (fun x y : M A => x <| p |> y) (fun x y => x [~] y).
Proof. by move=> x y z; rewrite !(choiceC p) choiceDr. Qed.
End altprob_lemmas.

HB.mixin Record isMonadExceptProb (M : UU0 -> UU0)
    of MonadExcept M & MonadProb M := {
  catchDl : forall (A : UU0) w,
    left_distributive (@catch [the exceptMonad of M] A) (choice w A) }.

#[short(type=exceptProbMonad)]
HB.structure Definition MonadExceptProb :=
  { M of isMonadExceptProb M & isFunctor M & isMonad M & isMonadFail M &
         isMonadExcept M & isMonadProb M }.

HB.mixin Record isMonadFresh (S : eqType) (M : UU0 -> UU0) of Monad M :=
  { fresh : M S }.

#[short(type=freshMonad)]
HB.structure Definition MonadFresh (S : eqType) := {M of isMonadFresh S M & }.

Module segment_closed.
Record t A := mk {
  p : pred (seq A) ;
  H : forall a b, p (a ++ b) -> p a /\ p b }.
End segment_closed.
Definition segment_closed_p A := @segment_closed.p A.
Coercion segment_closed_p : segment_closed.t >-> pred.

Definition symbols {S} {M : freshMonad S} :=
  fun n => sequence (nseq n (@fresh _ M)).

HB.mixin Record isMonadFailFresh (S : eqType) (M : UU0 -> UU0)
    of MonadFresh S M & MonadFail M := Mixin {
  (* generated symbols are indeed fresh (specification of fresh) *)
  distinct : segment_closed.t S ;
  bassert_symbols : bassert distinct \o (@symbols _ [the freshMonad S of M]) =
                    @symbols _ [the freshMonad S of M] ;
  (* failure is a right zero of composition (backtracking interpretation) *)
  failfresh_bindmfail : BindLaws.right_zero (@bind [the monad of M]) (@fail _)
}.

#[short(type=failFreshMonad)]
HB.structure Definition MonadFailFresh (S : eqType) :=
  { M of isMonadFailFresh S M & isFunctor M & isMonad M & isMonadFresh S M &
         isMonadFail M }.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^190 - 11
Base: 47.5
***)

Definition curve : CurveParameters :=
  {|
    sz := 4%nat;
    base := 47 + 1/2;
    bitwidth := 64;
    s := 2^190;
    c := [(1, 11)];
    carry_chains := Some [seq 0 (pred 4); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Require Import Iron.Language.SystemF2r.SubstTypeType.
Require Export Iron.Language.SystemF2r.Exp.
Require Export Iron.Language.SystemF2r.TyEnv.
Require Export Iron.Language.SystemF2r.KiJudge.

(* Builtin in types. *)
Definition tUnit
 := TCon (TyConData 0 KData).

Definition tFun (t1: ty) (t2: ty)
 := TApp (TApp (TCon TyConFun) t1) t2.
Hint Unfold tFun.

(* Type judgement assigns a type to an expression. *)
Inductive TYPE : env -> exp -> ty -> Prop :=
 | TYVar
   :  forall ix ev t
   ,  get ix (types ev) = Some t
   -> KIND (kinds ev) t KStar
   -> TYPE ev (XVar ix) t

 | TYLam
   :  forall ev x12 t11 t12
   ,  KIND (kinds ev) t11 KStar
   -> TYPE (withType ev t11)  x12 t12
   -> TYPE ev (XLam t11 x12) (tFun t11 t12)

 | TYApp
   :  forall ev x1 x2 t11 t12
   ,  TYPE ev x1 (tFun t11 t12)
   -> TYPE ev x2 t11
   -> TYPE ev (XApp x1 x2) t12

 | TYLAM
   :  forall ev ev' x1 t1
   ,  ev' = liftTypes 0 (withKind ev KStar)
   -> TYPE ev' x1 t1
   -> TYPE ev (XLAM x1) (TForall t1)

 | TYAPP
   :  forall ev x1 t1 t2
   ,  TYPE ev x1 (TForall t1)
   -> KIND (kinds ev) t2 KStar
   -> TYPE ev (XAPP x1 t2) (substTT 0 t2 t1).

Hint Constructors TYPE.

(* Invert all hypothesis that are compound typing statements. *)
Ltac inverts_type :=
 repeat
  (match goal with
   | [ H: TYPE _ (XVar _)   _  |- _ ] => inverts H
   | [ H: TYPE _ (XLam _ _) _  |- _ ] => inverts H
   | [ H: TYPE _ (XApp _ _) _  |- _ ] => inverts H
   | [ H: TYPE _ (XLAM _)   _  |- _ ] => inverts H
   | [ H: TYPE _ (XAPP _ _) _  |- _ ] => inverts H
   end).

(* The type produced by a type judgement is well kinded *)
Theorem type_kind
 :  forall ev x t
 ,  TYPE ev x t
 -> KIND (kinds ev) t KStar.
Proof.
 intros. gen ev t.
 induction x; intros; inverts_type; eauto.

 Case "TYLAM".
  apply KIForall.

 (*** EXTRA CODE ***)
 apply IHx in H2.
 apply KIForall. simpl in H2.
 unfold withKind in H2. destruct ev. simpl in H2.
 simpl. auto.

 Case "XAPP".
  apply IHx in H4. inverts H4.
  eapply subst_type_type; eauto.

 Case "XLam".
  unfold tFun. eauto.

 Case "XApp".
  apply IHx1 in H4.
  apply IHx2 in H6.
   unfold tFun in H4.
    inverts_kind. eauto.
Qed.

(* A well typed expression is well formed *)
Theorem type_wfX
 :  forall ke te x t
 ,  TYPE ke te x t
 -> wfX  (length ke) (length te) x.
Proof.
 intros. gen ke te t.
 induction x; intros; inverts_type; simpl; eauto.

 apply IHx in H3.
  simpl in H3. rewrite <- length_liftTE in H3. eauto.

 split.
  eapply kind_wfT. eauto.
  assert (length (te :> t) = S (length te)). eauto.
   rewrite <- H. eauto.
Qed.
Hint Resolve type_wfX.

(* Weakening Kind Env in TyJudge.
   We can insert a new kind into the kind environment of a type
   judgement, provided we lift existing references to kinds higher
   than this in the stack over the new one.

   References to existing elements of the kind environment may
   appear in the type environment, expression, as well as the
   resulting type -- so we must lift all of them. *)
Lemma type_kienv_insert
 :  forall ix ke te x1 t1 k2
 ,  TYPE ke                 te             x1             t1
 -> TYPE (insert ix k2 ke) (liftTE ix te) (liftTX ix x1) (liftTT 1 ix t1).
Proof.
 intros. gen ix ke te t1 k2.
 induction x1; intros; inverts_type; simpl; eauto.

 Case "XVar".
  apply TYVar.
  apply get_map. auto.
  apply kind_kienv_insert. auto.

 Case "XLAM".
  eapply TYLAM.
  rewrite insert_rewind.
   rewrite (liftTE_liftTE 0 ix).
   apply IHx1. auto.

 Case "XAPP".
  rewrite (liftTT_substTT' 0 ix). simpl.
  eapply TYAPP.
  eapply (IHx1 ix) in H4. simpl in H4. eauto.
  apply kind_kienv_insert. auto.

 Case "XLam".
  apply TYLam.
   apply kind_kienv_insert. auto.
   assert ( liftTE ix te :> liftTT 1 ix t
          = liftTE ix (te :> t)). auto. rewrite H. clear H.
   apply IHx1. auto.

 Case "XApp".
  eapply TYApp.
   eapply IHx1_1 in H4. simpl in H4. eauto.
   eapply IHx1_2 in H6. eauto.
Qed.

Lemma type_kienv_weaken
 :  forall ke te x1 t1 k2
 ,  TYPE ke                 te            x1              t1
 -> TYPE (ke :> k2)        (liftTE 0 te) (liftTX 0 x1)   (liftTT 1 0 t1).
Proof.
 intros.
 assert (ke :> k2 = insert 0 k2 ke).
  destruct ke; auto. rewrite H0.
  apply type_kienv_insert. auto.
Qed.

(* Weakening Type Env in TyJudge.
   We can insert a new type into the type environment of a type
   judgement, provided we lift existing references to types higher
   than this in the stack over the new one. *)
Lemma type_tyenv_insert
 :  forall ke te ix x1 t1 t2
 ,  TYPE ke  te                x1            t1
 -> TYPE ke (insert ix t2 te) (liftXX ix x1) t1.
Proof.
 intros. gen ix ke te t1 t2.
 induction x1; intros; simpl; inverts_type; eauto.

 Case "XVar".
  lift_cases; intros; auto.

 Case "XLAM".
  apply TYLAM. simpl.
  assert ( liftTE 0 (insert ix t2 te)
         = insert ix (liftTT 1 0 t2) (liftTE 0 te)).
   unfold liftTE. rewrite map_insert. auto.
  rewrite H; eauto.

 Case "XLam".
  eapply TYLam; eauto.
   rewrite insert_rewind. eauto.
Qed.

Lemma type_tyenv_weaken
 :  forall ke te x1 t1 t2
 ,  TYPE ke  te         x1           t1
 -> TYPE ke (te :> t2) (liftXX 0 x1) t1.
Proof.
 intros.
 assert (te :> t2 = insert 0 t2 te).
  destruct te; auto. rewrite H0.
  apply type_tyenv_insert. auto.
Qed.


(************************************************************************
 Morphisms in the slice bicategory

 We give characterizations for properties of morphisms in the slice
 bictegory. These characterizations only hold when the bicategory is
 locally groupoidal. If the bicategory is not locally groupoidal, there
 still are conditions for proving these properties.
 Note that for esos, we assume that the bicategory is locally groupoidal,
 so that the fully faithful 1-cells are characterized correctly.

 Contents:
 1. Proving properties of morphisms in the slice bicategory
 1.1 Faithful 1-cells
 1.2 Fully faithful 1-cells
 1.3 Conservative 1-cells
 1.4 Discrete 1-cells
 1.5 Pseudomonic 1-cells
 2. Characterizations
 2.1 Faithful 1-cells
 2.2 Fully faithful 1-cells
 3. Constructing esos in slice bicategory

 ************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.EquivToAdjequiv.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Slice.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.
Require Import UniMath.Bicategories.Morphisms.FullyFaithful.
Require Import UniMath.Bicategories.Morphisms.DiscreteMorphisms.
Require Import UniMath.Bicategories.Morphisms.Eso.

Local Open Scope cat.

(**
 1. Proving properties of morphisms in the slice bicategory
 *)
Section ToMorphismInSlice.
  Context {B : bicat}
          {b : B}
          {f₁ f₂ : slice_bicat b}
          (α : f₁ --> f₂).

  (**
   1.1 Faithful 1-cells
   *)
  Definition to_faithful_slice
             (Hα : faithful_1cell (pr1 α))
    : faithful_1cell α.
  Proof.
    intros g β₁ β₂ p₁ p₂ q.
    use eq_2cell_slice.
    apply Hα.
    exact (maponpaths pr1 q).
  Qed.

  (**
   1.2 Fully faithful 1-cells
   *)
  Definition to_fully_faithful_slice
             (Hα : fully_faithful_1cell (pr1 α))
    : fully_faithful_1cell α.
  Proof.
    use make_fully_faithful.
    - apply to_faithful_slice.
      exact (pr1 Hα).
    - intros g β₁ β₂ pf.
      simple refine ((_ ,, _) ,, _).
      + exact (fully_faithful_1cell_inv_map Hα (pr1 pf)).
      + abstract
          (cbn ;
           use (vcomp_rcancel (_ ◃ pr12 α)) ;
           [ is_iso ; apply property_from_invertible_2cell | ] ;
           rewrite !vassocl ;
           rewrite vcomp_whisker ;
           use (vcomp_rcancel (lassociator _ _ _)) ; [ is_iso | ] ;
           rewrite !vassocl ;
           rewrite <- rwhisker_rwhisker ;
           rewrite (fully_faithful_1cell_inv_map_eq Hα (pr1 pf)) ;
           refine (_ @ pr2 pf) ; cbn ;
           rewrite !vassocl ;
           apply idpath).
      + abstract
          (use eq_2cell_slice ; cbn ;
           apply (fully_faithful_1cell_inv_map_eq Hα (pr1 pf))).
  Defined.

  (**
   1.3 Conservative 1-cells
   *)
  Definition to_conservative_slice
             (Hα : conservative_1cell (pr1 α))
    : conservative_1cell α.
  Proof.
    intros g β₁ β₂ p Hp.
    apply is_invertible_2cell_in_slice_bicat.
    apply Hα.
    apply (from_is_invertible_2cell_in_slice_bicat Hp).
  Defined.

  (**
   1.4 Discrete 1-cells
   *)
  Definition to_discrete_slice
             (Hα : discrete_1cell (pr1 α))
    : discrete_1cell α.
  Proof.
    split.
    - apply to_faithful_slice.
      exact (pr1 Hα).
    - apply to_conservative_slice.
      exact (pr2 Hα).
  Defined.

  (**
   1.5 Pseudomonic 1-cells
   *)
  Definition to_pseudomonic_slice
             (Hα : pseudomonic_1cell (pr1 α))
    : pseudomonic_1cell α.
  Proof.
    use make_pseudomonic.
    - apply to_faithful_slice.
      exact (pr1 Hα).
    - intros g β₁ β₂ pf Hpf.
      simple refine ((_ ,, _) ,, _ ,, _).
      + refine (pseudomonic_1cell_inv_map Hα (pr1 pf) _).
        exact (from_is_invertible_2cell_in_slice_bicat Hpf).
      + abstract
          (cbn ;
           use (vcomp_rcancel (_ ◃ pr12 α)) ;
           [ is_iso ; apply property_from_invertible_2cell | ] ;
           rewrite !vassocl ;
           rewrite vcomp_whisker ;
           use (vcomp_rcancel (lassociator _ _ _)) ; [ is_iso | ] ;
           rewrite !vassocl ;
           rewrite <- rwhisker_rwhisker ;
           rewrite (pseudomonic_1cell_inv_map_eq Hα (pr1 pf)) ;
           refine (_ @ pr2 pf) ; cbn ;
           rewrite !vassocl ;
           apply idpath).
      + use is_invertible_2cell_in_slice_bicat.
        cbn.
        apply is_invertible_2cell_pseudomonic_1cell_inv_map.
      + abstract
          (use eq_2cell_slice ; cbn ;
           apply (pseudomonic_1cell_inv_map_eq Hα (pr1 pf))).
  Defined.
End ToMorphismInSlice.

(**
 2. Characterizations
 *)
Section FromMorphismInSlice.
  Context {B : bicat}
          (inv_B : locally_groupoid B)
          {b : B}
          {f₁ f₂ : slice_bicat b}
          (α : f₁ --> f₂).

  (**
   2.1. Faithful 1-cells
   *)
  Definition from_faithful_slice
             (Hα : faithful_1cell α)
    : faithful_1cell (pr1 α).
  Proof.
    intros x g₁ g₂ α₁ α₂ p.
    pose (f₀ := make_ob_slice (g₁ · pr2 f₁)).
    pose (β₁ := @make_1cell_slice
                  _ _
                  f₀ f₁
                  g₁
                  (id2_invertible_2cell _)).
    pose (β₂ := @make_1cell_slice
                  _ _
                  f₀ f₁
                  g₂
                  (@make_invertible_2cell _ _ _ _ _ (α₁ ▹ _) (inv_B _ _ _ _ _))).
    assert (r₁ : cell_slice_homot β₁ β₂ α₁).
    {
      unfold cell_slice_homot.
      cbn.
      rewrite id2_left.
      apply idpath.
    }
    pose (p₁ := @make_2cell_slice _ _ _ _ β₁ β₂ α₁ r₁).
    assert (r₂ : cell_slice_homot β₁ β₂ α₂).
    {
      unfold cell_slice_homot.
      cbn.
      rewrite id2_left.
      use (vcomp_rcancel (_ ◃ pr12 α)) ; [ is_iso ; apply property_from_invertible_2cell | ].
      rewrite !vcomp_whisker.
      apply maponpaths.
      use (vcomp_rcancel (lassociator _ _ _)) ; [ is_iso | ].
      rewrite <- !rwhisker_rwhisker.
      do 2 apply maponpaths.
      exact (!p).
    }
    pose (p₂ := @make_2cell_slice _ _ _ _ β₁ β₂ α₂ r₂).
    assert (r : p₁ ▹ α = p₂ ▹ α).
    {
      use eq_2cell_slice ; cbn.
      exact p.
    }
    exact (maponpaths pr1 (Hα f₀ β₁ β₂ p₁ p₂ r)).
  Qed.

  Definition faithful_weq_slice
    : faithful_1cell (pr1 α) ≃ faithful_1cell α.
  Proof.
    use weqimplimpl.
    - apply to_faithful_slice.
    - apply from_faithful_slice.
    - apply isaprop_faithful_1cell.
    - apply isaprop_faithful_1cell.
  Qed.

  (**
   2.2 Fully faithful 1-cells
   *)
  Section FromFullyFaithfulSlice.
    Context (Hα : fully_faithful_1cell α)
            {x : B}
            {g₁ g₂ : x --> pr1 f₁}
            (βf : g₁ · pr1 α ==> g₂ · pr1 α).

    Let h : slice_bicat b
      := make_ob_slice (g₁ · pr2 f₁).
    Let β₁ : h --> f₁
      := @make_1cell_slice _ _ h f₁ g₁ (id2_invertible_2cell _).
    Let γ : invertible_2cell (g₁ · pr2 f₁) (g₂ · pr2 f₁).
    Proof.
      use make_invertible_2cell.
      - exact ((_ ◃ pr12 α)
               • lassociator _ _ _
               • (βf ▹ _)
               • rassociator _ _ _
               • (_ ◃ (pr22 α)^-1)).
      - apply inv_B.
    Defined.
    Let β₂ : h --> f₁
      := @make_1cell_slice _ _ h f₁ g₂ γ.

    Local Lemma from_fully_faithful_slice_cell_homot
      : cell_slice_homot (β₁ · α) (β₂ · α) βf.
    Proof.
      unfold cell_slice_homot ; cbn.
      rewrite id2_left.
      rewrite !vassocl.
      do 2 apply maponpaths.
      refine (!_).
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !vassocr.
        rewrite lwhisker_vcomp.
        rewrite vcomp_linv.
        rewrite lwhisker_id2.
        apply id2_left.
      }
      rewrite rassociator_lassociator.
      apply id2_right.
    Qed.

    Let p : β₁ · α ==> β₂ · α
      := @make_2cell_slice
           _ _ _ _
           (β₁ · α) (β₂ · α)
           βf
           from_fully_faithful_slice_cell_homot.

    Definition from_fully_faithful_slice_cell
      : g₁ ==> g₂
      := pr1 (@fully_faithful_1cell_inv_map _ _ _ _ Hα h β₁ β₂ p).

    Definition from_fully_faithful_slice_cell_eq
      : from_fully_faithful_slice_cell ▹ pr1 α = βf
      := maponpaths pr1 (@fully_faithful_1cell_inv_map_eq _ _ _ _ Hα h β₁ β₂ p).
  End FromFullyFaithfulSlice.

  Definition from_fully_faithful_slice
             (Hα : fully_faithful_1cell α)
    : fully_faithful_1cell (pr1 α).
  Proof.
    use make_fully_faithful.
    - apply from_faithful_slice.
      exact (pr1 Hα).
    - intros x g₁ g₂ βf.
      simple refine (_ ,, _).
      + exact (from_fully_faithful_slice_cell Hα βf).
      + exact (from_fully_faithful_slice_cell_eq Hα βf).
  Defined.

  Definition fully_faithful_weq_slice
    : fully_faithful_1cell (pr1 α) ≃ fully_faithful_1cell α.
  Proof.
    use weqimplimpl.
    - apply to_fully_faithful_slice.
    - apply from_fully_faithful_slice.
    - apply isaprop_fully_faithful_1cell.
    - apply isaprop_fully_faithful_1cell.
  Qed.
End FromMorphismInSlice.

Section EsoSlice.
  Context {B : bicat}
          (HB : is_univalent_2_1 B)
          (inv_B : locally_groupoid B)
          {b : B}
          {f₁ f₂ : slice_bicat b}
          (α : f₁ --> f₂).

  (**
   3. Constructing esos in slice bicategory
   *)
  Section ToSliceEsoFull.
    Context (Hα : is_eso (pr1 α))
            {h₁ h₂ : slice_bicat b}
            {μ : h₁ --> h₂}
            (Hμ : fully_faithful_1cell μ)
            {β₁ β₂ : f₂ --> h₁}
            (p₁ : α · β₁ ==> α · β₂)
            (p₂ : β₁ · μ ==> β₂ · μ)
            (r : (p₁ ▹ μ) • rassociator α β₂ μ
                 =
                 rassociator α β₁ μ • (α ◃ p₂)).

    Definition to_eso_slice_lift_2_eq
      : cell_slice_homot
          β₁ β₂
          (is_eso_lift_2
             (pr1 α) Hα
             (from_fully_faithful_slice inv_B μ Hμ)
             (pr1 β₁) (pr1 β₂)
             (pr1 p₁) (pr1 p₂)
             (maponpaths pr1 r)).
    Proof.
      unfold cell_slice_homot.
      use (vcomp_rcancel (_ ◃ pr12 μ)).
      {
        is_iso.
        apply property_from_invertible_2cell.
      }
      rewrite !vassocl.
      rewrite vcomp_whisker.
      use (vcomp_rcancel (lassociator _ _ _)) ; [ is_iso | ].
      rewrite !vassocl.
      rewrite <- rwhisker_rwhisker.
      etrans.
      {
        do 4 apply maponpaths.
        apply is_eso_lift_2_right.
      }
      pose (r' := pr2 p₂).
      cbn in r'.
      rewrite !vassocl in r'.
      exact r'.
    Qed.

    Definition to_eso_slice_lift_2
      : β₁ ==> β₂.
    Proof.
      use make_2cell_slice.
      - exact (is_eso_lift_2
                 _
                 Hα
                 (from_fully_faithful_slice inv_B _ Hμ)
                 (pr1 β₁) (pr1 β₂)
                 (pr1 p₁) (pr1 p₂)
                 (maponpaths pr1 r)).
      - exact to_eso_slice_lift_2_eq.
    Defined.

    Definition to_eso_slice_lift_2_left
      : α ◃ to_eso_slice_lift_2 = p₁.
    Proof.
      use eq_2cell_slice.
      apply is_eso_lift_2_left.
    Qed.

    Definition to_eso_slice_lift_2_right
      : to_eso_slice_lift_2 ▹ μ = p₂.
    Proof.
      use eq_2cell_slice.
      apply is_eso_lift_2_right.
    Qed.
  End ToSliceEsoFull.

  Definition to_eso_full_slice
             (Hα : is_eso (pr1 α))
    : is_eso_full α
    := λ h₁ h₂ μ Hμ β₁ β₂ p₁ p₂ r,
       to_eso_slice_lift_2 Hα Hμ p₁ p₂ r
       ,,
       to_eso_slice_lift_2_left Hα Hμ p₁ p₂ r
       ,,
       to_eso_slice_lift_2_right Hα Hμ p₁ p₂ r.

  Definition to_eso_faithful_slice
             (Hα : is_eso (pr1 α))
    : is_eso_faithful α.
  Proof.
    intros h₁ h₂ μ Hμ β₁ β₂ p₁ p₂ r₁ r₂.
    use eq_2cell_slice.
    use (is_eso_lift_eq _ Hα (from_fully_faithful_slice inv_B _ Hμ)).
    - exact (maponpaths pr1 r₁).
    - exact (maponpaths pr1 r₂).
  Qed.

  Section ToSliceEsoEssentiallySurjective.
    Context (Hα : is_eso (pr1 α))
            {g₁ g₂ : slice_bicat b}
            {μ : g₁ --> g₂}
            (Hμ : fully_faithful_1cell μ)
            {β₁ : f₁ --> g₁}
            {β₂ : f₂ --> g₂}
            (p : invertible_2cell (β₁ · μ) (α · β₂)).

    Let γ : invertible_2cell (pr1 β₁ · pr1 μ) (pr1 α · pr1 β₂).
    Proof.
      use make_invertible_2cell.
      - exact (pr11 p).
      - apply inv_B.
    Defined.

    Definition to_eso_slice_lift_1
      : f₂ --> g₁.
    Proof.
      simple refine (_ ,, _).
      - exact (is_eso_lift_1
                 _ Hα
                 (from_fully_faithful_slice inv_B _ Hμ)
                 (pr1 β₁) (pr1 β₂)
                 γ).
      - pose (is_eso_lift_1_comm_right
                _ Hα
                (from_fully_faithful_slice inv_B _ Hμ)
                (pr1 β₁) (pr1 β₂)
                γ)
          as i.
        use make_invertible_2cell.
        + exact (pr12 β₂
                 • (i^-1 ▹ _)
                 • rassociator _ _ _
                 • (_ ◃ (pr22 μ)^-1)).
        + apply inv_B.
    Defined.

    Definition to_eso_slice_lift_1_left_eq
      : cell_slice_homot
          (α · to_eso_slice_lift_1)
          β₁
          (is_eso_lift_1_comm_left
             (pr1 α) Hα
             (from_fully_faithful_slice inv_B μ Hμ)
             (pr1 β₁) (pr1 β₂)
             γ).
    Proof.
      unfold cell_slice_homot.
      cbn -[is_eso_lift_1_comm_right is_eso_lift_1_comm_left].
      rewrite <- !lwhisker_vcomp.
      rewrite !vassocl.
      etrans.
      {
        do 4 apply maponpaths.
        rewrite !vassocr.
        rewrite lwhisker_lwhisker.
        rewrite !vassocl.
        rewrite <- vcomp_whisker.
        apply idpath.
      }
      rewrite !vassocr.
      use vcomp_move_R_Mp ; [ is_iso | ].
      cbn -[is_eso_lift_1_comm_right is_eso_lift_1_comm_left].
      rewrite !vassocl.
      pose (is_eso_lift_1_eq
              _ Hα
              (from_fully_faithful_slice inv_B _ Hμ)
              (pr1 β₁) (pr1 β₂)
              γ)
        as H.
      cbn -[is_eso_lift_1_comm_right is_eso_lift_1_comm_left] in H.
      use vcomp_move_R_pM ; [ apply property_from_invertible_2cell | ].
      use vcomp_move_R_pM ; [ is_iso ; apply property_from_invertible_2cell | ].
      use vcomp_move_R_pM ; [ is_iso | ].
      cbn -[is_eso_lift_1_comm_right is_eso_lift_1_comm_left].
      rewrite !vassocr.
      etrans.
      {
        apply maponpaths_2.
        rewrite lwhisker_hcomp.
        rewrite inverse_pentagon_5.
        rewrite <- rwhisker_hcomp.
        apply idpath.
      }
      rewrite !vassocl.
      use vcomp_move_R_pM ; [ is_iso | ].
      cbn -[is_eso_lift_1_comm_right is_eso_lift_1_comm_left].
      rewrite !vassocr.
      rewrite rwhisker_lwhisker_rassociator.
      rewrite !vassocl.
      use vcomp_move_R_pM ; [ is_iso | ].
      cbn -[is_eso_lift_1_comm_right is_eso_lift_1_comm_left].
      rewrite !vassocr.
      rewrite rwhisker_vcomp.
      rewrite <- H.
      rewrite !vassocl.
      rewrite <- rwhisker_vcomp.
      rewrite !vassocl.
      rewrite <- rwhisker_rwhisker_alt.
      apply maponpaths.
      clear H.
      pose (pr21 p) as H.
      cbn in H.
      rewrite !vassocr.
      use vcomp_move_L_Mp ; [ is_iso ; apply property_from_invertible_2cell | ].
      use vcomp_move_L_Mp ; [ apply property_from_invertible_2cell | ].
      use vcomp_move_L_Mp ; [ is_iso | ].
      cbn.
      use vcomp_move_R_pM ; [ is_iso | ].
      cbn.
      rewrite !vassocr.
      refine (!_).
      etrans.
      {
        do 2 apply maponpaths_2.
        rewrite !vassocl.
        rewrite !vassocl in H.
        exact H.
      }
      rewrite !vassocl.
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !vassocr.
        rewrite lassociator_rassociator.
        apply id2_left.
      }
      rewrite lwhisker_vcomp.
      rewrite vcomp_rinv.
      rewrite lwhisker_id2.
      apply id2_right.
    Qed.

    Definition to_eso_slice_lift_1_left
      : invertible_2cell
          (α · to_eso_slice_lift_1)
          β₁.
    Proof.
      use make_invertible_2cell.
      - use make_2cell_slice.
        + exact (is_eso_lift_1_comm_left
                   _ Hα
                   (from_fully_faithful_slice inv_B _ Hμ)
                   (pr1 β₁) (pr1 β₂)
                   γ).
        + exact to_eso_slice_lift_1_left_eq.
      - apply is_invertible_2cell_in_slice_bicat.
        apply inv_B.
    Defined.

    Definition to_eso_slice_lift_1_right_eq
      : cell_slice_homot
          (to_eso_slice_lift_1 · μ)
          β₂
          (is_eso_lift_1_comm_right
             (pr1 α) Hα
             (from_fully_faithful_slice inv_B μ Hμ)
             (pr1 β₁) (pr1 β₂)
             γ).
    Proof.
      unfold cell_slice_homot.
      cbn -[is_eso_lift_1_comm_right is_eso_lift_1_comm_left].
      rewrite !vassocl.
      etrans.
      {
        do 3 apply maponpaths.
        rewrite !vassocr.
        rewrite lwhisker_vcomp.
        rewrite vcomp_linv.
        rewrite lwhisker_id2.
        rewrite id2_left.
        apply idpath.
      }
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !vassocr.
        rewrite rassociator_lassociator.
        apply id2_left.
      }
      rewrite rwhisker_vcomp.
      rewrite vcomp_linv.
      rewrite id2_rwhisker.
      apply id2_right.
    Qed.

    Definition to_eso_slice_lift_1_right
      : invertible_2cell (to_eso_slice_lift_1 · μ) β₂.
    Proof.
      use make_invertible_2cell.
      - use make_2cell_slice.
        + exact (is_eso_lift_1_comm_right
                   _ Hα
                   (from_fully_faithful_slice inv_B _ Hμ)
                   (pr1 β₁) (pr1 β₂)
                   γ).
        + exact to_eso_slice_lift_1_right_eq.
      - apply is_invertible_2cell_in_slice_bicat.
        apply inv_B.
    Defined.

    Definition to_eso_slice_lift_1_eq
      : (to_eso_slice_lift_1_left ▹ μ) • p
        =
        rassociator _ _ _ • (α ◃ to_eso_slice_lift_1_right).
    Proof.
      use eq_2cell_slice.
      apply is_eso_lift_1_eq.
    Qed.
  End ToSliceEsoEssentiallySurjective.

  Definition to_eso_essentially_surjective_slice
             (Hα : is_eso (pr1 α))
    : is_eso_essentially_surjective α
    := λ g₁ g₂ μ Hμ β₁ β₂ p,
       to_eso_slice_lift_1 Hα Hμ p
       ,,
       to_eso_slice_lift_1_left Hα Hμ p
       ,,
       to_eso_slice_lift_1_right Hα Hμ p
       ,,
       to_eso_slice_lift_1_eq Hα Hμ p.

  Definition to_eso_slice
             (Hα : is_eso (pr1 α))
    : is_eso α.
  Proof.
    use make_is_eso.
    - use is_univalent_2_1_slice_bicat.
      exact HB.
    - exact (to_eso_full_slice Hα).
    - exact (to_eso_faithful_slice Hα).
    - exact (to_eso_essentially_surjective_slice Hα).
  Defined.
End EsoSlice.


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2010-2018 Sylvie Boldo
#<br />#
Copyright (C) 2010-2018 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

(** * Sterbenz conditions for exact subtraction *)

From Coq Require Import ZArith Reals.

Require Import Zaux Raux Defs Generic_fmt Operations.

Section Fprop_Sterbenz.

Variable beta : radix.
Notation bpow e := (bpow beta e).

Variable fexp : Z -> Z.
Context { valid_exp : Valid_exp fexp }.
Context { monotone_exp : Monotone_exp fexp }.
Notation format := (generic_format beta fexp).

Theorem generic_format_plus :
  forall x y,
  format x -> format y ->
  (Rabs (x + y) <= bpow (Z.min (mag beta x) (mag beta y)))%R ->
  format (x + y)%R.
Proof.
intros x y Fx Fy Hxy.
destruct (Req_dec (x + y) 0) as [Zxy|Zxy].
rewrite Zxy.
apply generic_format_0.
destruct (Req_dec x R0) as [Zx|Zx].
now rewrite Zx, Rplus_0_l.
destruct (Req_dec y R0) as [Zy|Zy].
now rewrite Zy, Rplus_0_r.
destruct Hxy as [Hxy|Hxy].
revert Hxy.
destruct (mag beta x) as (ex, Ex). simpl.
specialize (Ex Zx).
destruct (mag beta y) as (ey, Ey). simpl.
specialize (Ey Zy).
intros Hxy.
set (fx := Float beta (Ztrunc (scaled_mantissa beta fexp x)) (fexp ex)).
assert (Hx: x = F2R fx).
rewrite Fx at 1.
unfold cexp.
now rewrite mag_unique with (1 := Ex).
set (fy := Float beta (Ztrunc (scaled_mantissa beta fexp y)) (fexp ey)).
assert (Hy: y = F2R fy).
rewrite Fy at 1.
unfold cexp.
now rewrite mag_unique with (1 := Ey).
rewrite Hx, Hy.
rewrite <- F2R_plus.
apply generic_format_F2R.
intros _.
case_eq (Fplus fx fy).
intros mxy exy Pxy; simpl.
rewrite <- Pxy, F2R_plus, <- Hx, <- Hy.
unfold cexp.
replace exy with (fexp (Z.min ex ey)).
apply monotone_exp.
now apply mag_le_bpow.
replace exy with (Fexp (Fplus fx fy)) by exact (f_equal Fexp Pxy).
rewrite Fexp_Fplus.
simpl. clear -monotone_exp.
apply sym_eq.
destruct (Zmin_spec ex ey) as [(H1,H2)|(H1,H2)] ; rewrite H2.
apply Z.min_l.
now apply monotone_exp.
apply Z.min_r.
apply monotone_exp.
apply Zlt_le_weak.
now apply Z.gt_lt.
apply generic_format_abs_inv.
rewrite Hxy.
apply generic_format_bpow.
apply valid_exp.
case (Zmin_spec (mag beta x) (mag beta y)); intros (H1,H2);
   rewrite H2; now apply mag_generic_gt.
Qed.

Theorem generic_format_plus_weak :
  forall x y,
  format x -> format y ->
  (Rabs (x + y) <= Rmin (Rabs x) (Rabs y))%R ->
  format (x + y)%R.
Proof.
intros x y Fx Fy Hxy.
destruct (Req_dec x R0) as [Zx|Zx].
now rewrite Zx, Rplus_0_l.
destruct (Req_dec y R0) as [Zy|Zy].
now rewrite Zy, Rplus_0_r.
apply generic_format_plus ; try assumption.
apply Rle_trans with (1 := Hxy).
unfold Rmin.
destruct (Rle_dec (Rabs x) (Rabs y)) as [Hxy'|Hxy'].
rewrite Z.min_l.
destruct (mag beta x) as (ex, Hx).
apply Rlt_le; now apply Hx.
now apply mag_le_abs.
rewrite Z.min_r.
destruct (mag beta y) as (ex, Hy).
apply Rlt_le; now apply Hy.
apply mag_le_abs.
exact Zy.
apply Rlt_le.
now apply Rnot_le_lt.
Qed.

Lemma sterbenz_aux :
  forall x y, format x -> format y ->
  (y <= x <= 2 * y)%R ->
  format (x - y)%R.
Proof.
intros x y Hx Hy (Hxy1, Hxy2).
unfold Rminus.
apply generic_format_plus_weak.
exact Hx.
now apply generic_format_opp.
rewrite Rabs_pos_eq.
rewrite Rabs_Ropp.
rewrite Rmin_comm.
assert (Hy0: (0 <= y)%R).
apply Rplus_le_reg_r with y.
apply Rle_trans with x.
now rewrite Rplus_0_l.
now replace (y + y)%R with (2 * y)%R by ring.
rewrite Rabs_pos_eq with (1 := Hy0).
rewrite Rabs_pos_eq.
unfold Rmin.
destruct (Rle_dec y x) as [Hyx|Hyx].
apply Rplus_le_reg_r with y.
now ring_simplify.
now elim Hyx.
now apply Rle_trans with y.
now apply Rle_0_minus.
Qed.

Theorem sterbenz :
  forall x y, format x -> format y ->
  (y / 2 <= x <= 2 * y)%R ->
  format (x - y)%R.
Proof.
intros x y Hx Hy (Hxy1, Hxy2).
destruct (Rle_or_lt x y) as [Hxy|Hxy].
rewrite <- Ropp_minus_distr.
apply generic_format_opp.
apply sterbenz_aux ; try easy.
split.
exact Hxy.
apply Rcompare_not_Lt_inv.
rewrite <- Rcompare_half_r.
now apply Rcompare_not_Lt.
apply sterbenz_aux ; try easy.
split.
now apply Rlt_le.
exact Hxy2.
Qed.

End Fprop_Sterbenz.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable out_ : Universe -> Universe -> Universe -> Prop.
Variable midpoint_ : Universe -> Universe -> Universe -> Prop.
Variable lt_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable congA_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable defmidpoint_1 : (forall A B C : Universe, (midpoint_ A B C -> (betS_ A B C /\ cong_ A B B C))).
Variable defmidpoint2_2 : (forall A B C : Universe, ((betS_ A B C /\ cong_ A B B C) -> midpoint_ A B C)).
Variable defcollinear_3 : (forall A B C : Universe, (col_ A B C -> (A = B \/ (A = C \/ (B = C \/ (betS_ B A C \/ (betS_ A B C \/ betS_ A C B))))))).
Variable defcollinear2a_4 : (forall A B C : Universe, (A = B -> col_ A B C)).
Variable defcollinear2b_5 : (forall A B C : Universe, (A = C -> col_ A B C)).
Variable defcollinear2c_6 : (forall A B C : Universe, (B = C -> col_ A B C)).
Variable defcollinear2d_7 : (forall A B C : Universe, (betS_ B A C -> col_ A B C)).
Variable defcollinear2e_8 : (forall A B C : Universe, (betS_ A B C -> col_ A B C)).
Variable defcollinear2f_9 : (forall A B C : Universe, (betS_ A C B -> col_ A B C)).
Variable lemma_betweennotequal_10 : (forall A B C : Universe, (betS_ A B C -> (B <> C /\ (A <> B /\ A <> C)))).
Variable lemma_inequalitysymmetric_11 : (forall A B : Universe, (A <> B -> B <> A)).
Variable lemma_congruencesymmetric_12 : (forall A B C D : Universe, (cong_ B C A D -> cong_ A D B C)).
Variable lemma_congruenceflip_13 : (forall A B C D : Universe, (cong_ A B C D -> (cong_ B A D C /\ (cong_ B A C D /\ cong_ A B D C)))).
Variable lemma_doublereverse_14 : (forall A B C D : Universe, (cong_ A B C D -> (cong_ D C B A /\ cong_ B A D C))).
Variable deflessthan_15 : (forall A B C D : Universe, (exists X : Universe, (lt_ A B C D -> (betS_ C X D /\ cong_ C X A B)))).
Variable deflessthan2_16 : (forall A B C D X : Universe, ((betS_ C X D /\ cong_ C X A B) -> lt_ A B C D)).
Variable lemma_lessthancongruence_17 : (forall A B C D E F : Universe, ((lt_ A B C D /\ cong_ C D E F) -> lt_ A B E F)).
Variable cn_equalityreverse_18 : (forall A B : Universe, cong_ A B B A).
Variable lemma_lessthancongruence2_19 : (forall A B C D E F : Universe, ((lt_ A B C D /\ cong_ A B E F) -> lt_ E F C D)).
Variable cn_congruencereflexive_20 : (forall A B : Universe, cong_ A B A B).
Variable proposition_03_21 : (forall A B C D E F : Universe, (exists X : Universe, ((lt_ C D A B /\ cong_ E F A B) -> (betS_ E X F /\ cong_ E X C D)))).
Variable lemma_ray4_1_22 : (forall A B E : Universe, ((betS_ A E B /\ A <> B) -> out_ A B E)).
Variable lemma_ray4_2_23 : (forall A B E : Universe, ((E = B /\ A <> B) -> out_ A B E)).
Variable lemma_ray4_3_24 : (forall A B E : Universe, ((betS_ A B E /\ A <> B) -> out_ A B E)).
Variable axiom_betweennesssymmetry_25 : (forall A B C : Universe, (betS_ A B C -> betS_ C B A)).
Variable lemma_3_7a_26 : (forall A B C D : Universe, ((betS_ A B C /\ betS_ B C D) -> betS_ A C D)).
Variable defray_27 : (forall A B C : Universe, (exists X : Universe, (out_ A B C -> (betS_ X A C /\ betS_ X A B)))).
Variable defray2_28 : (forall A B C X : Universe, ((betS_ X A C /\ betS_ X A B) -> out_ A B C)).
Variable lemma_ray5_29 : (forall A B C : Universe, (out_ A B C -> out_ A C B)).
Variable lemma_layoffunique_30 : (forall A B C D : Universe, ((out_ A B C /\ (out_ A B D /\ cong_ A C A D)) -> C = D)).
Variable lemma_differenceofparts_31 : (forall A B C Xa Xb Xc : Universe, ((cong_ A B Xa Xb /\ (cong_ A C Xa Xc /\ (betS_ A B C /\ betS_ Xa Xb Xc))) -> cong_ B C Xb Xc)).
Variable cn_sumofparts_32 : (forall A B C E F G : Universe, ((cong_ A B E F /\ (cong_ B C F G /\ (betS_ A B C /\ betS_ E F G))) -> cong_ A C E G)).
Variable lemma_3_7b_33 : (forall A B C D : Universe, ((betS_ A B C /\ betS_ B C D) -> betS_ A B D)).
Variable axiom_innertransitivity_34 : (forall A B C D : Universe, ((betS_ A B D /\ betS_ B C D) -> betS_ A B C)).
Variable lemma_outerconnectivity_35 : (forall A B C D : Universe, ((betS_ A B C /\ (betS_ A B D /\ (~(betS_ B C D) /\ ~(betS_ B D C)))) -> C = D)).
Variable lemma_congruencetransitive_36 : (forall A B C D E F : Universe, ((cong_ A B C D /\ cong_ C D E F) -> cong_ A B E F)).
Variable lemma_extensionunique_37 : (forall A B E F : Universe, ((betS_ A B E /\ (betS_ A B F /\ cong_ B E B F)) -> E = F)).
Variable lemma_3_6a_38 : (forall A B C D : Universe, ((betS_ A B C /\ betS_ A C D) -> betS_ B C D)).
Variable proposition_15_39 : (forall A B C D E : Universe, ((betS_ A E B /\ (betS_ C E D /\ ~(col_ A E C))) -> (congA_ A E C D E B /\ congA_ C E B A E D))).
Variable lemma_equalanglesNC_40 : (forall A B C Xa Xb Xc : Universe, (congA_ A B C Xa Xb Xc -> ~(col_ Xa Xb Xc))).
Variable lemma_ABCequalsCBA_41 : (forall A B C : Universe, (~(col_ A B C) -> congA_ A B C C B A)).
Variable lemma_equalanglestransitive_42 : (forall A B C D E F P Q R : Universe, ((congA_ A B C D E F /\ congA_ D E F P Q R) -> congA_ A B C P Q R)).
Variable proposition_04_43 : (forall A B C Xa Xb Xc : Universe, ((cong_ A B Xa Xb /\ (cong_ A C Xa Xc /\ congA_ B A C Xb Xa Xc)) -> (cong_ B C Xb Xc /\ (congA_ A B C Xa Xb Xc /\ congA_ A C B Xa Xc Xb)))).

Theorem lemma_pointreflectionisometry_44 : (forall A B C P Q : Universe, ((midpoint_ A B C /\ (midpoint_ P B Q /\ A <> P)) -> cong_ A P C Q)).
Proof.
  time tac.
Qed.

End FOFProblem.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling    [*]              *)
(*             Jean-François Monin           [+]              *)
(*                                                            *)
(*           [*] Affiliation Univ. Lorraine - CNRS - LORIA    *)
(*           [+] Affiliation VERIMAG - Univ. Grenoble Alpes   *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*        CeCILL v2.1 FREE SOFTWARE LICENSE AGREEMENT         *)
(**************************************************************)

From Coq Require Import Utf8.

From MuRec Require Import sigma relations schemes computable_def.

Section prec_compute.

  Variables (X Y : Type)
            (F : X → Y → Prop)
            (Ffun : functional F)
            (Fcomp : ∀x, computable (F x))
            (G : X → nat → Y → Y → Prop)
            (Gfun : ∀ x n, functional (G x n))
            (Gcomp : ∀ x n y, computable (G x n y))
            (x : X).

  Section prim_rec_compute_props.

    Variables (n : nat) (e : ∃y, prim_rec F G x (S n) y).

    Local Fact prc_TC1 : ∃y, prim_rec F G x n y.
    Proof.
      destruct e as (? & yn₁ & ? & ?).
      now exists yn₁.
    Qed.

    Variables (yn : Y) (Hyn : prim_rec F G x n yn).

    Local Fact prc_TC2 : ∃y, G x n yn y.
    Proof.
      destruct e as (yn₁' & yn₁ & Hyn₁ & Hyn₁').
      exists yn₁'.
      now rewrite <- (prim_rec_fun Ffun Gfun Hyn₁ Hyn).
    Qed.

    Variables (yn' : Y) (Hyn' : G x n yn yn').

    Local Fact prc_PO1 : prim_rec F G x (S n) yn'.
    Proof. now exists yn. Qed.

  End prim_rec_compute_props.

  Arguments prc_TC1 {_} _.
  Arguments prc_TC2 {_} _ {_} _.
  Arguments prc_PO1 {_ _} _ {_} _.

  Fixpoint prim_rec_compute m : computable (prim_rec F G x m) :=
    match m with
      | 0   => λ e, Fcomp x e
      | S n => λ e, let (yn , y_yn)   := prim_rec_compute n (prc_TC1 e) in
                    let (yn', yn_yn') := Gcomp x n yn (prc_TC2 e y_yn) in
                    ⟪yn', prc_PO1 y_yn yn_yn'⟫
    end.

End prec_compute.

Arguments prim_rec_compute {X Y F} Ffun Fcomp {G} Gfun Gcomp x m.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Functor.Functor.
From Categories Require Import Cat.Cat.
From Categories Require Import Coq_Cats.Type_Cat.Type_Cat.

(* empty and singleton categories *)

(** The empty category – initial object of Cat. *)
Definition EmptyCat : Category :=
  {|
    Obj := (Empty : Type);
    Hom := fun _ _ => (unit : Type);
    compose := fun _ _ _ _ _ => tt;
    assoc := fun _ _ _ _ _ _ _ => eq_refl;
    assoc_sym := fun _ _ _ _ _ _ _ => eq_refl;
    id := fun _ => tt;
    id_unit_left :=
      fun _ _ h =>
        match h as u return (tt = u) with
        | tt => eq_refl
        end;
    id_unit_right :=
      fun _ _ h =>
        match h as u return (tt = u) with
        | tt => eq_refl
        end
  |}.

(** The singleton category – terminal object of Cat. *)
Definition SingletonCat : Category :=
  {|
    Obj := (unit : Type);
    Hom := fun _ _ => (unit : Type);
    compose := fun _ _ _ _ _ => tt;
    assoc := fun _ _ _ _ _ _ _ => eq_refl;
    assoc_sym := fun _ _ _ _ _ _ _ => eq_refl;
    id := fun _ => tt;
    id_unit_left :=
      fun _ _ h =>
        match h as u return (tt = u) with
        | tt => eq_refl
        end;
    id_unit_right :=
      fun _ _ h =>
        match h as u return (tt = u) with
        | tt => eq_refl
        end
  |}.

Notation "0" := (EmptyCat) : category_scope.
Notation "1" := (SingletonCat) : category_scope.

(* discrete categories in general *)
Section Discr.
  Context (obj : Type).

  (** Discrete category – one in which has no arrow but identitities.
Note that this definition is not necessarily a discrete cat in Coq as UIP is not
generally provable. We simply assume so by implicitly assuming object type to
have UIP. In HoTT terms, we assume obj to be a hSet. *)
  Program Definition Discr_Cat : Category :=
    {|
      Obj := obj;
      Hom := fun a b => a = b;
      compose := @eq_trans _;
      id := fun a => eq_refl
    |}.

End Discr.

Definition Type_n (n : nat) : Type := {x : nat| x < n}.

Notation "'Discr_n' n" :=
  (Discr_Cat (Type_n n)) (at level 200, n bigint) : category_scope.

(** Any discrete category is ismorphic to its dual. *)
Section Discr_Cat_Dual_Iso.
  Context (obj : Type).

  Local Hint Extern 1 => progress cbn.

  Program Definition Discr_Cat_Dual_Iso :
    (Discr_Cat obj ≃≃ (Discr_Cat obj)^op ::> Cat)%isomorphism%category
    :=
      {|
        iso_morphism := {|FO := fun x => x; FA := fun _ _ h => eq_sym h|};
        inverse_morphism := {|FO := fun x => x; FA := fun _ _ h => eq_sym h|}
      |}.

End Discr_Cat_Dual_Iso.

(** Any two isomorphic types form isomorphic discrete categories. *)
Section Discr_Cat_Iso.
  Context {obj obj' : Type} (I : (obj ≃≃ obj' ::> Type_Cat)%isomorphism).

  Program Definition Discr_Cat_Iso :
    ((Discr_Cat obj) ≃≃ (Discr_Cat obj') ::> Cat)%isomorphism
    :=
      {|
        iso_morphism :=
          {|
            FO := iso_morphism I;
            FA :=
              fun c d h =>
                match h in _ = y return
                      (iso_morphism I c) = (iso_morphism I y)
                with
                  eq_refl => eq_refl
                end
          |};
        inverse_morphism :=
          {|
            FO := inverse_morphism I;
            FA :=
              fun c d h =>
                match h in _ = y return
                      (inverse_morphism I c) = (inverse_morphism I y)
                with
                  eq_refl => eq_refl
                end
          |}
      |}.

  Next Obligation.
  Proof.
    Func_eq_simpl.
    {
      FunExt; cbn in *.
      match goal with
        [|- ?A = ?B] => destruct A
      end.
      apply JMeq_eq; auto.
    }
    {
      FunExt; cbn.
      cbn_rewrite (equal_f (left_inverse I)); trivial.
    }
  Qed.

  Next Obligation.
  Proof.
    Func_eq_simpl.
    {
      FunExt; cbn in *.
      match goal with
        [|- ?A = ?B] => destruct A
      end.
      apply JMeq_eq; auto.
    }
    {
      FunExt; cbn.
      cbn_rewrite (equal_f (right_inverse I)); trivial.
    }
  Qed.

End Discr_Cat_Iso.

(* Functor from SingletonCat to another category. *)
Section Func_From_SingletonCat.
  Context {C : Category} (Cobj : C).

  (** The functor from SingletonCat to C induced bo Cobj. *)
  Program Definition Func_From_SingletonCat : (SingletonCat –≻ C)%functor :=
    {|
      FO := fun _ => Cobj;
      FA := fun _ _ _ => id
    |}.

End Func_From_SingletonCat.

(* Discrete Functor *)
Section Discr_Func.
  Context {C : Category} {A : Type} (Omap : A → C).

  (** The discrete functor – a functor from a discrete category of type A
 to a category C based on a function from A to objects of C. *)
  Program Definition Discr_Func : ((Discr_Cat A) –≻ C)%functor :=
    {|
      FO := Omap;

      FA := fun (a b : A) (h : a = b) =>
              match h in _ = y return ((Omap a) –≻ (Omap y))%morphism with
              | eq_refl => id
              end
    |}.

  (** The discrete-opposite functor – a functor from the opposite of a
      discrete category of type A to a category C based on a function
      from A to objects of C. *)
  Program Definition Discr_Func_op : ((Discr_Cat A)^op –≻ C)%functor :=
    {|
      FO := Omap;
      FA := fun (a b : A) (h : b = a) =>
              match h in _ = y return ((Omap y) –≻ (Omap b))%morphism with
              | eq_refl => id
              end
    |}.

End Discr_Func.

Arguments Discr_Func {_ _} _, _ {_} _.
Arguments Discr_Func_op {_ _} _, _ {_} _.