Require Export PnV.Prelude.SfLib.
Require Export PnV.Prelude.Notations.
Require Export Coq.Arith.Compare_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Bool.Bool.
Require Export Coq.Classes.RelationClasses.
Require Export Coq.Lists.List.
Require Export Coq.micromega.Lia.
Require Export Coq.Program.Basics.
Require Export Coq.Program.Utils.
Require Export Coq.Relations.Relation_Definitions.
Require Export Coq.Relations.Relation_Operators.
Require Export Coq.Setoids.Setoid.
Create HintDb simplication_hints.
#[global] Hint Rewrite forallb_app orb_true_iff orb_false_iff andb_true_iff andb_false_iff negb_true_iff negb_false_iff Nat.eqb_eq Nat.eqb_neq not_true_iff_false not_false_iff_true : simplication_hints.
Ltac obs_eqb n m :=
let H_OBS := fresh "H_OBS" in destruct (Nat.eqb n m) as [ | ] eqn: H_OBS; [rewrite Nat.eqb_eq in H_OBS | rewrite Nat.eqb_neq in H_OBS].
#[local] Obligation Tactic := idtac.
Ltac property X :=
eapply (proj2_sig X).
Tactic Notation "rewrite!" :=
autorewrite with simplication_hints in *.
#[universes(polymorphic=yes)]
Definition reify@{u v} {A : Type@{u}} {B : Type@{v}} {P : A -> B -> Prop} (f : forall x : A, { y : B | P x y }) : { f : A -> B | forall x, P x (f x) } :=
@exist (A -> B) (fun f => forall x, P x (f x)) (fun x => proj1_sig (f x)) (fun x => proj2_sig (f x)).
#[universes(polymorphic=yes)]
Definition reify_lemma@{u v} {A : Type@{u}} {B : Type@{u}} {P : A -> B -> Prop} (f : forall x : A, { y : B | P x y }) : forall x, P x (proj1_sig (@reify@{u v} A B P f) x) :=
proj2_sig (@reify@{u v} A B P f).
(** Section SETOID. *)
Class isSetoid (A : Type) : Type :=
{ eqProp (lhs : A) (rhs : A) : Prop
; eqProp_Equivalence :: Equivalence eqProp
}.
Infix "==" := eqProp : type_scope.
#[global, program]
Instance Prop_isSetoid : isSetoid Prop :=
{ eqProp := iff
; eqProp_Equivalence := iff_equivalence
}.
#[global, program]
Instance pi_isSetoid {A : Type} {B : A -> Type} `(SETOID : forall x : A, isSetoid (B x)) : isSetoid (forall x : A, B x) :=
{ eqProp f g := forall x, f x == g x }.
Next Obligation.
split.
- intros f1 x. reflexivity.
- intros f1 f2 EQ x. symmetry; exact (EQ x).
- intros f1 f2 f3 EQ EQ' x. transitivity (f2 x); [exact (EQ x) | exact (EQ' x)].
Qed.
#[program]
Definition mkSetoidFromPreOrder {A : Type} {leProp : A -> A -> Prop} `(leProp_PreOrder : @PreOrder A leProp) : isSetoid A :=
{| eqProp (x : A) (y : A) := leProp x y /\ leProp y x |}.
Next Obligation.
split; ii.
- exact (conj (@PreOrder_Reflexive A leProp leProp_PreOrder x) (@PreOrder_Reflexive A leProp leProp_PreOrder x)).
- exact (conj (proj2 H) (proj1 H)).
- exact (conj (@PreOrder_Transitive A leProp leProp_PreOrder x y z (proj1 H) (proj1 H0)) (@PreOrder_Transitive A leProp leProp_PreOrder z y x (proj2 H0) (proj2 H))).
Defined.
Class isSetoid1 (F : Type -> Type) : Type :=
liftSetoid1 (X : Type) `(SETOID : isSetoid X) : isSetoid (F X).
Definition mkSetoid_from_eq {A : Type} : isSetoid A :=
{| eqProp := @eq A; eqProp_Equivalence := eq_equivalence |}.
#[global]
Instance fromSetoid1 {F : Type -> Type} {A : Type} `(SETOID1 : isSetoid1 F) : isSetoid (F A) :=
liftSetoid1 A mkSetoid_from_eq.
#[universes(polymorphic=yes)]
Definition binary_relation_on_image@{u_A u_B} {A : Type@{u_A}} {B : Type@{u_B}} (R : B -> B -> Prop) (f : A -> B) lhs rhs : Prop :=
R (f lhs) (f rhs).
#[local]
Instance relation_on_image_liftsEquivalence {A : Type} {B : Type} {eqProp : B -> B -> Prop}
(isEquivalence : Equivalence eqProp)
: forall f : A -> B, Equivalence (binary_relation_on_image eqProp f).
(** End FUNCTOR. *)
(** Section MONAD. *)
Class isMonad (M : Type -> Type) : Type :=
{ bind {A : Type} {B : Type} (m : M A) (k : A -> M B) : M B
; pure {A : Type} : A -> M A
}.
Class MonadLaws (M : Type -> Type) `{SETOID1 : isSetoid1 M} `{MONAD : isMonad M} : Prop :=
{ bind_compatWith_eqProp_l {A : Type} {B : Type} (m1 : M A) (m2 : M A) (k : A -> M B)
(m_EQ : m1 == m2)
: bind m1 k == bind m2 k
; bind_compatWith_eqProp_r {A : Type} {B : Type} (m : M A) (k1 : A -> M B) (k2 : A -> M B)
(k_EQ : k1 == k2)
: bind m k1 == bind m k2
; bind_assoc {A : Type} {B : Type} {C : Type} (m : M A) (k : A -> M B) (k' : B -> M C)
: bind m (fun x => bind (k x) k') == bind (bind m k) k'
; bind_pure_l {A : Type} {B : Type} (k : A -> M B) (x : A)
: bind (pure x) k == k x
; bind_pure_r {A : Type} (m : M A)
: bind m pure == m
}.
#[global]
Add Parametric Morphism {M : Type -> Type} `{SETOID1 : isSetoid1 M} `{MONAD : isMonad M} {A: Type} {B: Type}
`(MONAD_LAWS : @MonadLaws M SETOID1 MONAD)
: (@bind M MONAD A B) with signature (eqProp ==> eqProp ==> eqProp)
as bind_compatWith_eqProp.
Definition mkFunctorFromMonad {M : Type -> Type} `(MONAD : isMonad M) : isFunctor M :=
fun A : Type => fun B : Type => fun f : A -> B => fun m : M A => bind m (fun x : A => pure (f x)).

Lemma mkFunctorFromMonad_good {M : Type -> Type} `{SETOID1 : isSetoid1 M} `{MONAD : isMonad M}
`(MONAD_LAWS : @MonadLaws M SETOID1 MONAD)
: @FunctorLaws M SETOID1 (mkFunctorFromMonad MONAD).