Require Import HoTT.
From HoTT.Categories Require Import
     Functor NaturalTransformation FunctorCategory.
From HoTT.Categories Require Import
     GroupoidCategory.
From GR.bicategories Require Import general_category.

Record BiCategory_d :=
  Build_BiCategory_d {
      Obj_d :> Type ;
      Hom_d : Obj_d -> Obj_d -> PreCategory ;
      id₁_d : forall (X : Obj_d), Hom_d X X ;
      hcomp_obj : forall {X Y Z : Obj_d},
          Hom_d Y Z * Hom_d X Y -> Hom_d X Z ;
      hcomp_hom : forall {X Y Z : Obj_d}
                        {f g : Hom_d Y Z * Hom_d X Y}
                        (η : morphism (Hom_d Y Z) (fst f) (fst g) *
                             morphism (Hom_d X Y) (snd f) (snd g)),
          morphism (Hom_d X Z) (hcomp_obj f) (hcomp_obj g) ;
      left_unit_d : forall {X Y : Obj_d}
                         (f : Hom_d X Y),
          morphism (Hom_d X Y) (hcomp_obj (id₁_d Y, f)) f ;
      left_unit_inv_d : forall {X Y : Obj_d}
                         (f : Hom_d X Y),
          morphism (Hom_d X Y) f (hcomp_obj (id₁_d Y, f)) ;
      right_unit_d : forall {X Y : Obj_d}
                         (f : Hom_d X Y),
          morphism (Hom_d X Y) (hcomp_obj (f, id₁_d X)) f ;
      right_unit_inv_d : forall {X Y : Obj_d}
                          (f : Hom_d X Y),
          morphism (Hom_d X Y) f (hcomp_obj (f, id₁_d X)) ;
      assoc_d : forall {W X Y Z : Obj_d}
                         (h : Hom_d Y Z)
                         (g : Hom_d X Y)
                         (f : Hom_d W X),
          morphism (Hom_d W Z)
                   (hcomp_obj (hcomp_obj (h, g), f))
                   (hcomp_obj (h, hcomp_obj (g, f))) ;
      assoc_inv_d : forall {W X Y Z : Obj_d}
                             (h : Hom_d Y Z)
                             (g : Hom_d X Y)
                             (f : Hom_d W X),
          morphism (Hom_d W Z)
                   (hcomp_obj (h, hcomp_obj (g, f)))
                   (hcomp_obj (hcomp_obj (h, g), f))
    }.

Ltac make_bicategory := simple refine (Build_BiCategory_d _ _ _ _ _ _ _ _ _ _ _).

Record is_bicategory (C : BiCategory_d)
  := Build_is_bicategory {
         hcomp_id_p :
           forall {X Y Z : C}
                  (f : Hom_d C Y Z * Hom_d C X Y),
           (hcomp_hom C (1 : morphism (Hom_d C Y Z * Hom_d C X Y) f f) = 1)%morphism ;
         hcomp_comp_p :
           forall {X Y Z : C}
                  {f g h : Hom_d C Y Z * Hom_d C X Y}
                  (η₂ : morphism (Hom_d C Y Z * Hom_d C X Y) g h)
                  (η₁ : morphism (Hom_d C Y Z * Hom_d C X Y) f g),
             (hcomp_hom C (η₂ o η₁) = hcomp_hom C η₂ o hcomp_hom C η₁)%morphism ;
         left_unit_natural_p :
           forall {X Y : C}
                  {f g : Hom_d C X Y}
                  (η : morphism (Hom_d C X Y) f g),
             ((left_unit_d C g)
                o @hcomp_hom C X Y Y (id₁_d C Y, f) (id₁_d C Y, g) (1,η)
              = η o left_unit_d C f)%morphism ;
         left_unit_inv_natural_p :
           forall {X Y : C}
                  {f g : Hom_d C X Y}
                  (η : morphism (Hom_d C X Y) f g),
             (left_unit_inv_d C g o η
              =
              (@hcomp_hom C X Y Y (id₁_d C Y, f) (id₁_d C Y, g) (1,η))
                o left_unit_inv_d C f)%morphism ;
         right_unit_natural_p :
           forall {X Y : C}
                  {f g : Hom_d C X Y}
                  (η : morphism (Hom_d C X Y) f g),
             ((right_unit_d C g)
                o @hcomp_hom C X X Y (f,id₁_d C X) (g,id₁_d C X) (η,1)
              = η o right_unit_d C f)%morphism ;
         right_unit_inv_natural_p :
           forall {X Y : C}
                  {f g : Hom_d C X Y}
                  (η : morphism (Hom_d C X Y) f g),
             (right_unit_inv_d C g o η
              =
              (@hcomp_hom C X X Y (f,id₁_d C X) (g,id₁_d C X) (η,1))
                o right_unit_inv_d C f)%morphism ;
         left_unit_left_p : forall {X Y : C}
                                 (f : Hom_d C X Y),
             (left_unit_d C f o left_unit_inv_d C f = 1)%morphism ;
         left_unit_right_p : forall {X Y : C}
                                 (f : Hom_d C X Y),
             (left_unit_inv_d C f o left_unit_d C f = 1)%morphism ;
         right_unit_left_p : forall {X Y : C}
                                 (f : Hom_d C X Y),
             (right_unit_d C f o right_unit_inv_d C f = 1)%morphism ;
         right_unit_right_p : forall {X Y : C}
                                 (f : Hom_d C X Y),
             (right_unit_inv_d C f o right_unit_d C f = 1)%morphism ;
         assoc_natural_p :
           forall {W X Y Z : C}
                  {h₁ h₂ : Hom_d C Y Z}
                  {g₁ g₂ : Hom_d C X Y}
                  {f₁ f₂ : Hom_d C W X}
                  (ηh : morphism (Hom_d C Y Z) h₁ h₂)
                  (ηg : morphism (Hom_d C X Y) g₁ g₂)
                  (ηf : morphism (Hom_d C W X) f₁ f₂),
             ((assoc_d C h₂ g₂ f₂)
                o (@hcomp_hom
                     C W X Z (_,f₁) (_,f₂)
                     (@hcomp_hom
                        C X Y Z (h₁,g₁) (h₂,g₂)
                        (ηh, ηg), ηf)) =
              (@hcomp_hom
                 C W Y Z (h₁,_) (h₂,_)
                 (ηh, @hcomp_hom
                        C W X Y (g₁,f₁) (g₂,f₂)
                        (ηg, ηf)))
                o assoc_d C h₁ g₁ f₁)%morphism ;
         assoc_inv_natural_p :
           forall {W X Y Z : C}
                  {h₁ h₂ : Hom_d C Y Z}
                  {g₁ g₂ : Hom_d C X Y}
                  {f₁ f₂ : Hom_d C W X}
                  (ηh : morphism (Hom_d C Y Z) h₁ h₂)
                  (ηg : morphism (Hom_d C X Y) g₁ g₂)
                  (ηf : morphism (Hom_d C W X) f₁ f₂),
             ((assoc_inv_d C h₂ g₂ f₂)
                o (@hcomp_hom
                     C W Y Z (h₁,_) (h₂,_)
                     (ηh, @hcomp_hom
                            C W X Y (g₁,f₁) (g₂,f₂)
                            (ηg, ηf))) =
              (@hcomp_hom
                 C W X Z (_,f₁) (_,f₂)
                 (@hcomp_hom
                    C X Y Z (h₁,g₁) (h₂,g₂)
                    (ηh, ηg), ηf))
                o assoc_inv_d C h₁ g₁ f₁)%morphism ;
         assoc_left_p :
           forall {W X Y Z : C}
                  (f : Hom_d C Y Z)
                  (g : Hom_d C X Y)
                  (h : Hom_d C W X),
             (assoc_d C f g h o assoc_inv_d C f g h = 1)%morphism ;
         assoc_right_p :
           forall {W X Y Z : C}
                  (f : Hom_d C Y Z)
                  (g : Hom_d C X Y)
                  (h : Hom_d C W X),
             (assoc_inv_d C f g h o assoc_d C f g h = 1)%morphism ;
         triangle_r_p :
           forall {X Y Z : C}
                  (g : Hom_d C Y Z)
                  (f : Hom_d C X Y),
             (@hcomp_hom
                C X Y Z (_,f) (g,f)
                (right_unit_d C g, 1) =
              (@hcomp_hom
                 C X Y Z (g,hcomp_obj C _) (g,f)
                (1, left_unit_d C f))
                o assoc_d C g (id₁_d C Y) f)%morphism ;
         pentagon_p :
           forall {V W X Y Z : C}
                  (k : Hom_d C Y Z) (h : Hom_d C X Y)
                  (g : Hom_d C W X) (f : Hom_d C V W),
             ((assoc_d C k h (hcomp_obj C (g, f)))
                o assoc_d C (hcomp_obj C (k, h)) g f
              =
              (@hcomp_hom
                 C V Y Z
                 (k,hcomp_obj C (hcomp_obj C (h, g), f))
                 (k,hcomp_obj C (h, hcomp_obj C (g, f)))
                 (1, assoc_d C h g f))
                o assoc_d C k (hcomp_obj C (h, g)) f
                o (@hcomp_hom
                     C _ _ _
                     (_,_) (_,_)
                     (assoc_d C k h g, 1)))%morphism
       }.

Ltac make_is_bicategory := simple refine (Build_is_bicategory _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _).

Arguments hcomp_id_p {C} _ {X Y Z} f.
Arguments hcomp_comp_p {C} _ {X Y Z f g h} _ _.
Arguments left_unit_natural_p {C} _ {X Y f g} η.
Arguments left_unit_inv_natural_p {C} _ {X Y f g} η.
Arguments left_unit_left_p {C} _ {X Y} f.
Arguments left_unit_right_p {C} _ {X Y} f.
Arguments right_unit_natural_p {C} _ {X Y f g} η.
Arguments right_unit_inv_natural_p {C} _ {X Y f g} η.
Arguments right_unit_left_p {C} _ {X Y} f.
Arguments right_unit_right_p {C} _ {X Y} f.
Arguments assoc_natural_p {C} _ {W X Y Z h₁ h₂ g₁ g₂ f₁ f₂} ηh ηg ηf.
Arguments assoc_inv_natural_p {C} _ {W X Y Z h₁ h₂ g₁ g₂ f₁ f₂} ηh ηg ηf.
Arguments assoc_left_p {C} _ {W X Y Z} f g h.
Arguments assoc_right_p {C} _ {W X Y Z} f g h.
Arguments triangle_r_p {C} _ {X Y Z} g f.
Arguments pentagon_p {C} _ {V W X Y Z} k h g f.

Definition BiCategory
  := {C : BiCategory_d & is_bicategory C}.

Delimit Scope bicategory_scope with bicategory.
Bind Scope bicategory_scope with BiCategory.
Open Scope bicategory_scope.

Definition Build_BiCategory
           (C : BiCategory_d)
           (HC : is_bicategory C)
  : BiCategory
  := (C;HC).

Definition Obj : BiCategory -> Type
  := fun C => Obj_d C.1.

Coercion Obj : BiCategory >-> Sortclass.

Definition Hom (C : BiCategory)
  : Obj C -> Obj C -> PreCategory
  := Hom_d C.1.

Notation "C ⟦ X , Y ⟧ " := (Hom C X Y) (at level 60) : bicategory_scope.
Notation "f ==> g" := (morphism (Hom _ _ _) f g) (at level 60) : bicategory_scope.

Definition vcomp
           {C : BiCategory}
           {X Y : C}
           {f g h : C⟦X,Y⟧}
           (η₂ : g ==> h)
           (η₁ : f ==> g)
  : f ==> h
  := (η₂ o η₁)%morphism.

Arguments vcomp {C X Y f g h} η₂%bicategory η₁%bicategory.
Notation "η₂ '∘' η₁" := (vcomp η₂ η₁) (at level 41, left associativity) : bicategory_scope.

Definition vcomp_assoc
           {C : BiCategory}
           {X Y : C}
           {f g h k : C⟦X,Y⟧}
           (η₃ : h ==> k)
           (η₂ : g ==> h)
           (η₁ : f ==> g)
  : (η₃ ∘ η₂) ∘ η₁ = η₃ ∘ (η₂ ∘ η₁).
Proof.
  apply associativity.
Defined.

Definition id₂
           {C : BiCategory}
           {X Y : C}
           (f : C⟦X,Y⟧)
  : f ==> f
  := 1%morphism.

Definition vcomp_left_identity
           {C : BiCategory}
           {X Y : C}
           {f g : C⟦X,Y⟧}
           (η : f ==> g)
  : id₂ g ∘ η = η
  := left_identity _ _ _ _.

Definition vcomp_right_identity
           {C : BiCategory}
           {X Y : C}
           {f g : C⟦X,Y⟧}
           (η : f ==> g)
  : η ∘ id₂ f = η
  := right_identity _ _ _ _.

Definition id₁ {C : BiCategory}
  : forall (X : C), C⟦X,X⟧
  := id₁_d C.1.

Definition hcomp1 {C : BiCategory} {X Y Z : C}
  : C⟦Y,Z⟧ -> C⟦X,Y⟧ -> C⟦X,Z⟧
  := fun g f => hcomp_obj C.1 (g,f).

Arguments hcomp1 {C X Y Z} g%bicategory f%bicategory.
Notation "f '·' g" := (hcomp1 f g) (at level 41, left associativity) : bicategory_scope.

Definition hcomp2
           {C : BiCategory}
           {X Y Z : C}
           {f₁ g₁ : C⟦X,Y⟧}
           {f₂ g₂ : C⟦Y,Z⟧}
           (η₂ : f₂ ==> g₂)
           (η₁ : f₁ ==> g₁)
  : f₂ · f₁ ==> g₂ · g₁.
Proof.
  apply (hcomp_hom C.1) ; simpl.
  exact (η₂,η₁).
Defined.

Arguments hcomp2 {C X Y Z f₁ g₁ f₂ g₂} η₂%bicategory η₁%bicategory.
Notation "η₁ '*' η₂" := (hcomp2 η₁ η₂) (at level 40, left associativity) : bicategory_scope.

Definition interchange
           {C : BiCategory}
           {X Y Z : C}
           {f₁ g₁ h₁ : C⟦Y,Z⟧}
           {f₂ g₂ h₂ : C⟦X,Y⟧}
           (η₁ : f₁ ==> g₁) (η₂ : f₂ ==> g₂)
           (ε₁ : g₁ ==> h₁) (ε₂ : g₂ ==> h₂)
  : (ε₁ ∘ η₁) * (ε₂ ∘ η₂) = (ε₁ * ε₂) ∘ (η₁ * η₂)
  := @hcomp_comp_p _ C.2 X Y Z (f₁,f₂) (g₁,g₂) (h₁,h₂) (ε₁,ε₂) (η₁,η₂).

Definition hcomp_id₂
           {C : BiCategory}
           {X Y Z : C}
           (f₂ : C⟦Y, Z⟧) (f₁ : C⟦X,Y⟧)
  : id₂ f₂ * id₂ f₁ = id₂ (f₂ · f₁).
Proof.
  apply (hcomp_id_p C.2).
Defined.

Definition hcomp {C : BiCategory} (X Y Z : C)
  : Functor (Category.prod (C⟦Y,Z⟧) (C⟦X,Y⟧)) (C⟦X,Z⟧).
Proof.
  simple refine (Build_Functor _ _ _ _ _ _).
  - intros [g f].
    exact (g · f).
  - intros [f₁ f₂] [g₁ g₂] [η₁ η₂].
    exact (η₁ * η₂).
  - intros [f₁ f₂] [g₁ g₂] [h₁ h₂] [η₁ η₂] [ε₁ ε₂].
    cbn in *.
    apply interchange.
  - intros [f₁ f₂].
    cbn in *.
    apply hcomp_id₂.
Defined.

Definition left_unit
           {C : BiCategory}
           {X Y : C}
           (f : C⟦X, Y⟧)
  : id₁ Y · f ==> f
  := left_unit_d C.1 f.

Definition left_unit_natural
           {C : BiCategory}
           {X Y : C}
           {f g : C⟦X, Y⟧}
           (η : f ==> g)
  : left_unit g ∘ (id₂ (id₁ Y) * η) = η ∘ left_unit f
  := left_unit_natural_p C.2 η.

Definition left_unitor {C : BiCategory} (X Y : C)
  : NaturalTransformation
      (hcomp X Y Y o (const_functor (id₁ Y) * 1))
      1.
Proof.
  simple refine (Build_NaturalTransformation _ _ _ _).
  - exact left_unit.
  - intros ; apply left_unit_natural.
Defined.

Definition left_unit_inv
           {C : BiCategory}
           {X Y : C}
           (f : C⟦X, Y⟧)
  : f ==> id₁ Y · f
  := left_unit_inv_d C.1 f.

Definition left_unit_inv_natural
           {C : BiCategory}
           {X Y : C}
           {f g : C⟦X, Y⟧}
           (η : f ==> g)
  : left_unit_inv g ∘ η = (id₂ (id₁ Y) * η) ∘ left_unit_inv f
  := left_unit_inv_natural_p C.2 η.

Definition left_unitor_inv {C : BiCategory} (X Y : C)
  : NaturalTransformation
      1
      (hcomp X Y Y o (const_functor (id₁ Y) * 1)).
Proof.
  simple refine (Build_NaturalTransformation _ _ _ _).
  - exact left_unit_inv.
  - intros ; apply left_unit_inv_natural.
Defined.

Definition left_unit_left
           {C : BiCategory}
           {X Y : C}
           (f : C⟦X, Y⟧)
  : left_unit f ∘ left_unit_inv f = id₂ f
  := left_unit_left_p C.2 f.

Definition left_unitor_left `{Univalence} {C : BiCategory} (X Y : C)
  : (left_unitor X Y o left_unitor_inv X Y = 1)%natural_transformation.
Proof.
  apply path_natural_transformation.
  intros f ; cbn in *.
  exact (left_unit_left f).
Defined.

Definition left_unit_right
           {C : BiCategory}
           {X Y : C}
           (f : C⟦X, Y⟧)
  : left_unit_inv f ∘ left_unit f = id₂ (id₁ Y · f)
  := left_unit_right_p C.2 f.

Definition left_unitor_right `{Univalence} {C : BiCategory} (X Y : C)
  : (left_unitor_inv X Y o left_unitor X Y = 1)%natural_transformation.
Proof.
  apply path_natural_transformation.
  intros f ; cbn in *.
  exact (left_unit_right f).
Defined.

Definition right_unit
           {C : BiCategory}
           {X Y : C}
           (f : C⟦X, Y⟧)
  : f · id₁ X ==> f
  := right_unit_d C.1 f.

Definition right_unit_natural
           {C : BiCategory}
           {X Y : C}
           {f g : C⟦X, Y⟧}
           (η : f ==> g)
  : right_unit g ∘ (η * id₂ (id₁ X)) = η ∘ right_unit f
  := right_unit_natural_p C.2 η.

Definition right_unitor {C : BiCategory} (X Y : C)
  : NaturalTransformation
      (hcomp X X Y o (1 * const_functor (id₁ X)))
      1.
Proof.
  simple refine (Build_NaturalTransformation _ _ _ _).
  - exact right_unit.
  - intros ; apply right_unit_natural.
Defined.

Definition right_unit_inv
           {C : BiCategory}
           {X Y : C}
           (f : C⟦X, Y⟧)
  : f ==> f · id₁ X
  := right_unit_inv_d C.1 f.

Definition right_unit_inv_natural
           {C : BiCategory}
           {X Y : C}
           {f g : C⟦X, Y⟧}
           (η : f ==> g)
  : right_unit_inv g ∘ η = (η * id₂ (id₁ X)) ∘ right_unit_inv f
  := right_unit_inv_natural_p C.2 η.

Definition right_unitor_inv {C : BiCategory} (X Y : C)
  : NaturalTransformation
      1
      (hcomp X X Y o (1 * const_functor (id₁ X))).
Proof.
  simple refine (Build_NaturalTransformation _ _ _ _).
  - exact right_unit_inv.
  - intros ; apply right_unit_inv_natural.
Defined.

Definition right_unit_left
           {C : BiCategory}
           {X Y : C}
           (f : C⟦X, Y⟧)
  : right_unit f ∘ right_unit_inv f = id₂ f
  := right_unit_left_p C.2 f.

Definition right_unitor_left `{Univalence} {C : BiCategory} (X Y : C)
  : (right_unitor X Y o right_unitor_inv X Y = 1)%natural_transformation.
Proof.
  apply path_natural_transformation.
  intros f ; cbn in *.
  apply right_unit_left.
Qed.

Definition right_unit_right
           {C : BiCategory}
           {X Y : C}
           (f : C⟦X, Y⟧)
  : right_unit_inv f ∘ right_unit f = id₂ (f · id₁ X)
  := right_unit_right_p C.2 f.

Definition right_unitor_right `{Univalence} {C : BiCategory} (X Y : C)
  : (right_unitor_inv X Y o right_unitor X Y = 1)%natural_transformation.
Proof.
  apply path_natural_transformation.
  intros f ; cbn in *.
  apply right_unit_right.
Qed.

Definition assoc
           {C : BiCategory}
           {W X Y Z : C}
           (h : C⟦Y,Z⟧) (g : C⟦X,Y⟧) (f : C⟦W,X⟧)
  : (h · g) · f ==> h · (g · f)
  := assoc_d C.1 h g f.

Definition assoc_natural
           {C : BiCategory}
           {W X Y Z : C}
           {h₁ h₂ : C⟦Y,Z⟧} {g₁ g₂ : C⟦X,Y⟧} {f₁ f₂ : C⟦W,X⟧}
           (ηh : h₁ ==> h₂)
           (ηg : g₁ ==> g₂)
           (ηf : f₁ ==> f₂)
  : assoc h₂ g₂ f₂ ∘ ((ηh * ηg) * ηf) = (ηh * (ηg * ηf)) ∘ assoc h₁ g₁ f₁
  := assoc_natural_p C.2 ηh ηg ηf.

Definition associator {C : BiCategory} (W X Y Z : C)
  : NaturalTransformation
      (hcomp W X Z o (hcomp X Y Z,1))
      ((hcomp W Y Z)
         o (1,hcomp W X Y)
         o assoc_prod (Hom C Y Z) (Hom C X Y) (Hom C W X)).
Proof.
  simple refine (Build_NaturalTransformation _ _ _ _).
  - intros [[h g] f] ; simpl in *.
    apply assoc.
  - intros [[h₁ g₁] f₁] [[h₂ g₂] f₂] [[ηh ηg] ηf] ; simpl in *.
    apply assoc_natural.
Defined.

Definition assoc_inv
           {C : BiCategory}
           {W X Y Z : C}
           (h : C⟦Y,Z⟧) (g : C⟦X,Y⟧) (f : C⟦W,X⟧)
  : h · (g · f) ==> (h · g) · f
  := assoc_inv_d C.1 h g f.

Definition assoc_inv_natural
           {C : BiCategory}
           {W X Y Z : C}
           {h₁ h₂ : C⟦Y,Z⟧} {g₁ g₂ : C⟦X,Y⟧} {f₁ f₂ : C⟦W,X⟧}
           (ηh : h₁ ==> h₂)
           (ηg : g₁ ==> g₂)
           (ηf : f₁ ==> f₂)
  : assoc_inv h₂ g₂ f₂ ∘ (ηh * (ηg * ηf)) = ((ηh * ηg) * ηf) ∘ assoc_inv h₁ g₁ f₁
  := assoc_inv_natural_p C.2 ηh ηg ηf.

Definition associator_inv {C : BiCategory} (W X Y Z : Obj C)
  : NaturalTransformation
      ((hcomp W Y Z)
         o (1,hcomp W X Y)
         o assoc_prod (Hom C Y Z) (Hom C X Y) (Hom C W X))
      (hcomp W X Z o (hcomp X Y Z,1)).
Proof.
  simple refine (Build_NaturalTransformation _ _ _ _).
  - intros [[h g] f] ; simpl in *.
    apply assoc_inv.
  - intros [[h₁ g₁] f₁] [[h₂ g₂] f₂] [[ηh ηg] ηf] ; simpl in *.
    apply assoc_inv_natural.
Defined.

Definition assoc_left
           {C : BiCategory}
           {W X Y Z : C}
           (h : C⟦Y,Z⟧) (g : C⟦X,Y⟧) (f : C⟦W,X⟧)
  : assoc h g f ∘ assoc_inv h g f = id₂ (h · (g · f))
  := assoc_left_p C.2 h g f.

Definition associator_left `{Univalence} {C : BiCategory} (W X Y Z : C)
  : (associator W X Y Z o associator_inv W X Y Z = 1)%natural_transformation.
Proof.
  apply path_natural_transformation.
  intros f.
  apply assoc_left.
Qed.

Definition assoc_right
           {C : BiCategory}
           {W X Y Z : C}
           (h : C⟦Y,Z⟧) (g : C⟦X,Y⟧) (f : C⟦W,X⟧)
  : assoc_inv h g f ∘ assoc h g f = id₂ ((h · g) · f)
  := assoc_right_p C.2 h g f.

Definition associator_right `{Univalence} {C : BiCategory} (W X Y Z : C)
  : (associator_inv W X Y Z o associator W X Y Z = 1)%natural_transformation.
Proof.
  apply path_natural_transformation.
  intros f.
  apply assoc_right.
Qed.

Definition Build_IsIsomorphism_2cell
           {C : BiCategory}
           {X Y : C}
           {f g : C⟦X,Y⟧}
           {α : f ==> g}
           (α_inv : g ==> f)
           (sect : α_inv ∘ α = id₂ f)
           (retr : α ∘ α_inv = id₂ g)
  : IsIsomorphism α.
Proof.
  simple refine (Build_IsIsomorphism _ _ _ _ _ _ _).
  - exact α_inv.
  - exact sect.
  - exact retr.
Defined.

(** * Two-cells that are isomorphisms *)
(** Inverse of a two-cell *)
Definition twoinverse
           {C : BiCategory}
           {X Y : C}
           {f g : C⟦X,Y⟧}
           (η : f ==> g)
           `{IsIsomorphism _ _ _ η}
  : g ==> f
  := morphism_inverse η.
(** We add this notion insted of using the notation for
    `morphism_inverse` because `morphism_inverse` is a projection out
    of the IsIsomorphism typeclass, which is often implicit, leading
    to goals containing term "_ ^-1". E.g. `Check left_inverse.` *)
Notation "η ^-1" := (twoinverse η) : bicategory_scope.

Definition vcomp_left_inverse
           {C : BiCategory}
           {X Y : C}
           {f g : C⟦X,Y⟧}
           (η : f ==> g)
           `{IsIsomorphism _ _ _ η}
  : η^-1 ∘ η = id₂ f.
Proof.
  apply left_inverse.
Defined.

Definition vcomp_right_inverse
           {C : BiCategory}
           {X Y : C}
           {f g : C⟦X,Y⟧}
           (η : f ==> g)
           `{IsIsomorphism _ _ _ η}
  : η ∘ η^-1 = id₂ g.
Proof.
  apply right_inverse.
Defined.

Instance iso_id₂
         {C : BiCategory}
         {X Y : C}
         (f : C⟦X,Y⟧)
  : IsIsomorphism (id₂ f)
  := _.

Instance iso_inverse
         {C : BiCategory}
         {X Y : C}
         {f g : C⟦X,Y⟧}
         (α : f ==> g)
         `{IsIsomorphism _ _ _ α}
  : IsIsomorphism α^-1
  := _.

Instance iso_vcomp
         {C : BiCategory}
         {X Y : C}
         {f g h : C⟦X,Y⟧}
         (α : f ==> g)
         (β : g ==> h)
         `{IsIsomorphism _ _ _ α}
         `{IsIsomorphism _ _ _ β}
  : IsIsomorphism (β ∘ α)
  := _.

Instance left_unit_iso
         {C : BiCategory}
         {X Y : C}
         (f : C⟦X,Y⟧)
  : IsIsomorphism (left_unit f).
Proof.
  simple refine (Build_IsIsomorphism_2cell _ _ _).
  - exact (left_unit_inv f).
  - apply left_unit_right.
  - apply left_unit_left.
Defined.

Instance left_unit_inv_iso
         {C : BiCategory}
         {X Y : C}
         (f : C⟦X,Y⟧)
  : IsIsomorphism (left_unit_inv f).
Proof.
  simple refine (Build_IsIsomorphism_2cell _ _ _).
  - exact (left_unit f).
  - apply left_unit_left.
  - apply left_unit_right.
Defined.

Instance left_unitor_iso `{Univalence} {C : BiCategory} (X Y : C)
  : @IsIsomorphism (_ -> _) _ _ (left_unitor X Y).
Proof.
  simple refine (Build_IsIsomorphism _ _ _ _ _ _ _).
  - exact (left_unitor_inv X Y).
  - apply left_unitor_right.
  - apply left_unitor_left.
Defined.

Definition inverse_of_left_unitor
           `{Univalence}
           {C : BiCategory}
           (X Y : C)
  : @morphism_inverse (_ -> _) _ _ (left_unitor X Y) _ = left_unitor_inv X Y
  := idpath.

Instance right_unit_iso
         {C : BiCategory}
         {X Y : C}
         (f : C⟦X,Y⟧)
  : IsIsomorphism (right_unit f).
Proof.
  simple refine (Build_IsIsomorphism_2cell _ _ _).
  - exact (right_unit_inv f).
  - apply right_unit_right.
  - apply right_unit_left.
Defined.

Instance right_unit_inv_iso
         {C : BiCategory}
         {X Y : C}
         (f : C⟦X,Y⟧)
  : IsIsomorphism (right_unit_inv f).
Proof.
  simple refine (Build_IsIsomorphism_2cell _ _ _).
  - exact (right_unit f).
  - apply right_unit_left.
  - apply right_unit_right.
Defined.

Instance right_unitor_iso `{Univalence} {C : BiCategory} (X Y : C)
  : @IsIsomorphism (_ -> _) _ _ (right_unitor X Y).
Proof.
  simple refine (Build_IsIsomorphism _ _ _ _ _ _ _).
  - exact (right_unitor_inv X Y).
  - apply right_unitor_right.
  - apply right_unitor_left.
Defined.

Definition inverse_of_right_unitor
           `{Univalence}
           {C : BiCategory}
           (X Y : C)
  : @morphism_inverse (_ -> _) _ _ (right_unitor X Y) _ = right_unitor_inv X Y
  := idpath.

Instance assoc_iso
         {C : BiCategory}
         {W X Y Z : C}
         (h : C⟦Y,Z⟧) (g : C⟦X,Y⟧) (f : C⟦W,X⟧)
  : IsIsomorphism (assoc h g f).
Proof.
  simple refine (Build_IsIsomorphism_2cell _ _ _).
  - exact (assoc_inv h g f).
  - apply assoc_right.
  - apply assoc_left.
Defined.

Instance assoc_inv_iso
         {C : BiCategory}
         {W X Y Z : C}
         (h : C⟦Y,Z⟧) (g : C⟦X,Y⟧) (f : C⟦W,X⟧)
  : IsIsomorphism (assoc_inv h g f).
Proof.
  simple refine (Build_IsIsomorphism_2cell _ _ _).
  - exact (assoc h g f).
  - apply assoc_left.
  - apply assoc_right.
Defined.

Instance associator_iso
         `{Univalence}
         {C : BiCategory}
         (W X Y Z : C)
  : @IsIsomorphism (_ -> _) _ _ (associator W X Y Z).
Proof.
  simple refine (Build_IsIsomorphism _ _ _ _ _ _ _).
  - exact (associator_inv W X Y Z).
  - apply associator_right.
  - apply associator_left.
Defined.

Definition inverse_of_associator
           `{Univalence}
           {C : BiCategory}
           (W X Y Z : C)
  : @morphism_inverse (_ -> _) _ _ (associator W X Y Z) _ = associator_inv W X Y Z
  := idpath.

Definition triangle_r
           {C : BiCategory}
           {X Y Z : C}
           (g : C⟦Y,Z⟧)
           (f : C⟦X,Y⟧)
  : right_unit g * id₂ f = (id₂ g * left_unit f) ∘ assoc g (id₁ Y) f
  := triangle_r_p C.2 g f.

Definition pentagon
           {C : BiCategory}
           {V W X Y Z : C}
           (k : C⟦Y,Z⟧) (h : C⟦X,Y⟧) (g : C⟦W,X⟧) (f : C⟦V,W⟧)
  : (assoc k h (g · f) ∘ assoc (k · h) g f)
    =
    (id₂ k * assoc h g f) ∘ assoc k (h · g) f ∘ (assoc k h g * id₂ f)
  := pentagon_p C.2 k h g f.

Global Instance hcomp_iso
       {C : BiCategory}
       {X Y Z : C}
       {f₁ g₁ : C⟦Y,Z⟧} {f₂ g₂ : C⟦X,Y⟧}
       (η₁ : f₁ ==> g₁) (η₂ : f₂ ==> g₂)
       `{IsIsomorphism _ _ _ η₁}
       `{IsIsomorphism _ _ _ η₂}
  : IsIsomorphism (η₁ * η₂).
Proof.
  simple refine (Build_IsIsomorphism_2cell _ _ _).
  - exact (η₁^-1 * η₂^-1).
  - rewrite <- interchange.
    rewrite !vcomp_left_inverse.
    apply hcomp_id₂.
  - rewrite <- interchange.
    rewrite !vcomp_right_inverse.
    apply hcomp_id₂.
Defined.

Definition bc_whisker_l
           {C : BiCategory}
           {X Y Z : C}
           {f₁ : C⟦X,Y⟧} {f₂ : C⟦X,Y⟧}
           (g : C⟦Y,Z⟧)
           (α : f₁ ==> f₂)
  : (g · f₁) ==> (g · f₂)
  := id₂ g * α.

Notation "g '◅' α" := (bc_whisker_l g α) (at level 40) : bicategory_scope.

Definition bc_whisker_l_id₂
           {C : BiCategory}
           {X Y Z : C}
           (f : C⟦X,Y⟧)
           (g : C⟦Y,Z⟧)
  : g ◅ (id₂ f) = id₂ (g · f)
  := hcomp_id₂ g f.

Definition bc_whisker_r
           {C : BiCategory}
           {X Y Z : C}
           {g₁ : C⟦Y,Z⟧} {g₂ : C⟦Y,Z⟧}
           (β : g₁ ==> g₂)
           (f : C⟦X,Y⟧)
  : (g₁ · f) ==> (g₂ · f)
  := β * id₂ f.

Notation "β '▻' f" := (bc_whisker_r β f) (at level 40) : bicategory_scope.

Definition bc_whisker_r_id₂
           {C : BiCategory}
           {X Y Z : C}
           (f : C⟦X,Y⟧)
           (g : C⟦Y,Z⟧)
  : (id₂ g) ▻ f = id₂ (g · f)
  := hcomp_id₂ g f.

Definition inverse_of_assoc
           {C : BiCategory}
           {W X Y Z : C}
           (h : C⟦Y,Z⟧) (g : C⟦X,Y⟧) (f : C⟦W,X⟧)
  : (assoc h g f)^-1 = assoc_inv h g f
  := idpath.

Definition inverse_of_left_unit
           {C : BiCategory}
           {X Y : C}
           (f : C⟦X,Y⟧)
  : (left_unit f)^-1 = left_unit_inv f
  := idpath.

Definition inverse_of_right_unit
           {C : BiCategory}
           {X Y : C}
           (f : C⟦X,Y⟧)
  : (right_unit f)^-1 = right_unit_inv f
  := idpath.

(** Properties of isomorphisms *)
Definition id₂_inverse
           {C : BiCategory}
           {X Y : C}
           (f : C⟦X,Y⟧)
  : (id₂ f)^-1 = id₂ f
  := idpath.

Definition vcomp_inverse
           {C : BiCategory}
           {X Y : C}
           {f g h : C⟦X,Y⟧}
           (η₁ : f ==> g) (η₂ : g ==> h)
           `{IsIsomorphism _ _ _ η₁}
           `{IsIsomorphism _ _ _ η₂}
  : (η₂ ∘ η₁)^-1 = η₁^-1 ∘ η₂^-1
  := idpath.

Definition hcomp_inverse
           {C : BiCategory}
           {X Y Z : C}
           {f₁ g₁ : C⟦Y,Z⟧} {f₂ g₂ : C⟦X,Y⟧}
           (η₁ : f₁ ==> g₁) (η₂ : f₂ ==> g₂)
           `{IsIsomorphism _ _ _ η₁}
           `{IsIsomorphism _ _ _ η₂}
  : (η₁ * η₂)^-1 = η₁^-1 * η₂^-1
  := idpath.

Definition vcomp_cancel_left
           {C : BiCategory}
           {X Y : C}
           {f g h : C⟦X,Y⟧}
           (ε : g ==> h)
           (η₁ η₂ : f ==> g)
           `{IsIsomorphism _ _ _ ε}
  : ε ∘ η₁ = ε ∘ η₂ -> η₁ = η₂.
Proof.
  intros Hhf.
  refine ((vcomp_left_identity _)^ @ _ @ vcomp_left_identity _).
  rewrite <- (vcomp_left_inverse ε).
  rewrite !vcomp_assoc.
  rewrite Hhf.
  reflexivity.
Defined.

Definition vcomp_cancel_right
           {C : BiCategory}
           {X Y : C}
           {f g h : C⟦X,Y⟧}
           (ε : f ==> g) (η₁ η₂ : g ==> h)
           `{IsIsomorphism _ _ _ ε}
  : η₁ ∘ ε = η₂ ∘ ε -> η₁ = η₂.
Proof.
  intros Hhf.
  refine ((vcomp_right_identity _)^ @ _ @ vcomp_right_identity _).
  rewrite <- (vcomp_right_inverse ε).
  rewrite <- !vcomp_assoc.
  rewrite Hhf.
  reflexivity.
Defined.

Definition vcomp_move_L_Vp
           {C : BiCategory}
           {X Y : C}
           {f g h : C⟦X,Y⟧}
           (η₁ : f ==> g) (η₂ : f ==> h) (ε : g ==> h)
           `{IsIsomorphism _ _ _ ε}
  : ε ∘ η₁ = η₂ -> η₁ = ε^-1 ∘ η₂.
Proof.
  intros ?.
  rewrite <- (vcomp_left_identity η₁).
  rewrite <- (vcomp_left_inverse ε).
  rewrite vcomp_assoc.
  apply ap.
  assumption.
Qed.

Definition vcomp_move_L_pV
           {C : BiCategory}
           {X Y : C}
           {f g h : C⟦X,Y⟧}
           (η₁ : g ==> h) (η₂ : f ==> h) (ε : f ==> g)
           `{IsIsomorphism _ _ _ ε}
  : η₁ ∘ ε = η₂ -> η₁ = η₂ ∘ ε^-1.
Proof.
  intros Hη.
  rewrite <- (vcomp_right_identity η₁).
  rewrite <- (vcomp_right_inverse ε).
  rewrite <- vcomp_assoc.
  rewrite Hη.
  reflexivity.
Qed.

Definition vcomp_move_R_Mp
           {C : BiCategory}
           {X Y : C}
           {f g h : C⟦X,Y⟧}
           (η₁ : f ==> g) (η₂ : f ==> h) (ε : g ==> h)
           `{IsIsomorphism _ _ _ ε}
  : η₁ = ε^-1 ∘ η₂ -> ε ∘ η₁ = η₂.
Proof.
  intros ?.
  rewrite <- (vcomp_left_identity η₂).
  rewrite <- (vcomp_right_inverse ε).
  rewrite vcomp_assoc.
  apply ap.
  assumption.
Qed.

Definition vcomp_move_R_pM
           {C : BiCategory}
           {X Y : C}
           {f g h : C⟦X,Y⟧}
           (η₁ : g ==> h) (η₂ : f ==> h) (ε : f ==> g)
           `{IsIsomorphism _ _ _ ε}
  : η₁ = η₂ ∘ ε^-1 -> η₁ ∘ ε = η₂.
Proof.
  intros Hη.
  rewrite <- (vcomp_right_identity η₂).
  rewrite <- (vcomp_left_inverse ε).
  rewrite <- vcomp_assoc.
  rewrite Hη.
  reflexivity.
Qed.

Definition vcomp_move_L_Mp
           {C : BiCategory}
           {X Y : C}
           {f g h : C⟦X,Y⟧}
           (η₁ : f ==> h) (η₂ : f ==> g) (ε : g ==> h)
           `{IsIsomorphism _ _ _ ε}
  : ε^-1 ∘ η₁ = η₂ -> η₁ = ε ∘ η₂.
Proof.
  intros ?.
  rewrite <- (vcomp_left_identity η₁).
  rewrite <- (vcomp_right_inverse ε).
  rewrite vcomp_assoc.
  apply ap.
  assumption.
Qed.

Definition vcomp_move_L_pM
           {C : BiCategory}
           {X Y : C}
           {f g h : C⟦X,Y⟧}
           (η₁ : f ==> h) (η₂ : g ==> h) (ε : f ==> g)
           `{IsIsomorphism _ _ _ ε}
  : η₁ ∘ ε^-1 = η₂ -> η₁ = η₂ ∘ ε.
Proof.
  intros Hη.
  rewrite <- (vcomp_right_identity η₁).
  rewrite <- (vcomp_left_inverse ε).
  rewrite <- vcomp_assoc.
  rewrite Hη.
  reflexivity.
Qed.

Definition path_inverse_2cell
           {C : BiCategory}
           {X Y : C}
           {f g : C⟦X,Y⟧}
           (η₁ η₂ : f ==> g)
           {Hη₁ : IsIsomorphism η₁}
           {Hη₂ : IsIsomorphism η₂}
  : η₁ = η₂ -> η₁^-1 = η₂^-1.
Proof.
  intros p.
  rewrite <- (vcomp_right_identity (η₁^-1)%bicategory).
  rewrite <- (vcomp_left_identity (η₂^-1)%bicategory).
  rewrite <- (vcomp_right_inverse η₂).
  rewrite <- vcomp_assoc.
  f_ap.
  rewrite <- p.
  apply vcomp_left_inverse.
Defined.

Definition is_21 `{Funext} (C : BiCategory)
  : hProp
  := BuildhProp (forall (X Y : C), IsGroupoid (C⟦X,Y⟧)).


Theorem Ex036 (A B : Prop): (A -> B) -> A -> B.
Proof.
  intros.
  apply H.
  exact H0.
Qed.


From mathcomp Require Import ssreflect ssrbool ssrnat ssrfun.

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

(**
Exercise 7.2 Partially-ordered sets

Mathcomp ライブラリに命名規則をあわせた。
ModuleとSectionの階層を削除して、シンプルな構成にする。
 (* see. ssr_pnp_deprecords_3.v *)
*)

Module Poset.

(**
Mixinの定義
*)
  Record posetMixin (T : Type) :=
    PosetMixin {
        valid : T -> bool;
        rel : T -> T -> bool;
        refl (x : T) : rel x x;
        asym (x y : T) : rel x y -> rel y x -> x = y;
        trans (y x z : T) : rel x y -> rel y z -> rel x z
      }.
  (**
Packの定義
*)
  Structure posetType : Type :=
    PosetType {
        sort :> Type;
        m : posetMixin sort
      }.
  Print Graph.   (* [sort] : posetType >-> Sortclass *)
(*  Local Coercion sort : posetType >-> Sortclass. *)

(*
  Variable cT: posetType.

  Print posetType.
  Definition poset_struct : posetMixin cT := (* Coercion cT *)
    let: PosetType _ c := cT return posetMixin cT in c.
  Definition valid_op := valid poset_struct.
  Definition rel_op := rel poset_struct.
*)
  Definition valid_op {cT : posetType} := @valid cT (m cT).
  Definition rel_op {cT : posetType} := @rel cT (m cT).

  Notation "x <== y" := (rel_op x y) (at level 70, no associativity).
  (* rel ではない！ *)
  Notation Rel := @rel_op.
  Notation Valid := @valid_op.

  Section POSETLemmas.
    Variable T : posetType.

    Lemma poset_refl (x : T) : x <== x.
    Proof.
      case: T x => tp [rel Hv Href Hasym Htrans x].
        by apply: Href.
    Qed.

    Lemma poset_asym (x y : T) : x <== y -> y <== x -> x = y.
    Proof.
      case: T x y => tp [rel Hv Href Hasym Htrans x y].
        by apply Hasym.
    Qed.

    Lemma poset_trans (y x z : T) : x <== y -> y <== z -> x <== z.
    Proof.
      case: T x y z => tp [rel Hv Href Hasym Htrans x y z].
        by apply Htrans.
    Qed.
  End POSETLemmas.

(**
自然数のPOSETを定義する。
 *)
  Check leqnn : forall n : nat, n <= n.

  Lemma eqn_leq' : forall m n : nat, m <= n -> n <= m -> m = n.
  Proof.
    move=> m n.
    elim: m n => [|m IHm] [|n] //.
    move=> H1 H2; congr (_ .+1); move: H1 H2.
      by apply (IHm n).
  Qed.

  Check leq_trans : forall n m p : nat, m <= n -> n <= p -> m <= p.

  Definition nat_posetMixin :=
    PosetMixin
      (fun _ => id true)                    (* valid *)
      leqnn                                 (* ref *)
      eqn_leq'                              (* asym *)
      leq_trans.                            (* trans *)

  Canonical nat_posetType := @PosetType nat nat_posetMixin.
  Print Canonical Projections. (* nat <- POSETDef.sort ( nat_posetType ) *)

  Compute 1 <== 1.                          (* true *)
  Compute 1 <== 2.                          (* true *)
  Compute 2 <== 1.                          (* false *)

  Section PosetExamples.
    Variables x y z : nat.

    Check Rel : forall cT : posetType, cT -> cT -> bool.
    About "_ <== _".                          (* Rel := POSET.rel_op *)

    Goal x <== x.
    Proof.
        by apply: poset_refl.
    Qed.

    Goal x <== y -> y <== x -> x = y.
    Proof.
        by apply: poset_asym.
    Qed.

    Goal x <== y -> y <== z -> x <== z.
    Proof.
        by apply: poset_trans.
    Qed.
  End PosetExamples.
End Poset.

(* END *)


From Coq Require Import
  PeanoNat.
From DEZ Require Export
  Init.
From DEZ.Is Require Import
  TotalOrder Semiring MonoidHomomorphism.

Module Equivalence.

Instance nat_has_eqv : HasEqv nat := Nat.eq.

Instance nat_is_reflexive : IsReflexive Nat.eq := {}.
Proof. intros x. reflexivity. Qed.

Instance nat_is_symmetric : IsSymmetric Nat.eq := {}.
Proof. intros x y p. symmetry; auto. Qed.

Instance nat_is_transitive : IsTransitive Nat.eq := {}.
Proof. intros x y z p q. transitivity y; auto. Qed.

Instance nat_is_setoid : IsSetoid Nat.eq := {}.

End Equivalence.

Module Order.

Instance nat_has_ord : HasOrd nat := Nat.le.

Instance nat_is_antisymmetric : IsAntisymmetric Nat.le := {}.
Proof. intros x y p q. apply Nat.le_antisymm; auto. Qed.

Instance nat_is_transitive : IsTransitive Nat.le := {}.
Proof. intros x y z p q. transitivity y; auto. Qed.

Instance nat_is_connex : IsConnex Nat.le := {}.
Proof. intros x y. apply Nat.le_ge_cases. Qed.

Instance nat_is_total_order : IsTotalOrder Nat.le := {}.
Proof. cbv -[Nat.le]. apply Nat.le_wd. Qed.

End Order.

Module Additive.

Instance nat_has_opr : HasOpr nat := Nat.add.

Instance nat_is_associative : IsAssociative Nat.add := {}.
Proof. intros x y z. apply Nat.add_assoc. Qed.

Instance nat_is_semigroup : IsSemigroup Nat.add := {}.
Proof. cbv -[Nat.add]. apply Nat.add_wd. Qed.

Instance nat_has_idn : HasIdn nat := Nat.zero.

Instance nat_is_left_identifiable : IsLeftIdentifiable Nat.add Nat.zero := {}.
Proof. intros x. apply Nat.add_0_l. Qed.

Instance nat_is_right_identifiable :
  IsRightIdentifiable Nat.add Nat.zero := {}.
Proof. intros x. apply Nat.add_0_r. Qed.

Instance nat_is_identifiable : IsBiidentifiable Nat.add Nat.zero := {}.

Instance nat_is_monoid : IsMonoid Nat.add Nat.zero := {}.

Instance nat_is_commutative : IsCommutative Nat.add := {}.
Proof. intros x y. apply Nat.add_comm. Qed.

Instance nat_is_commutative_monoid :
  IsCommutativeMonoid Nat.add Nat.zero := {}.

End Additive.

Module Multiplicative.

Instance nat_has_opr : HasOpr nat := Nat.mul.

Instance nat_is_associative : IsAssociative Nat.mul := {}.
Proof. intros x y z. apply Nat.mul_assoc. Qed.

Instance nat_is_semigroup : IsSemigroup Nat.mul := {}.
Proof. cbv -[Nat.mul]. apply Nat.mul_wd. Qed.

Instance nat_has_idn : HasIdn nat := Nat.one.

Instance nat_is_left_identifiable : IsLeftIdentifiable Nat.mul Nat.one := {}.
Proof. intros x. apply Nat.mul_1_l. Qed.

Instance nat_is_right_identifiable : IsRightIdentifiable Nat.mul Nat.one := {}.
Proof. intros x. apply Nat.mul_1_r. Qed.

Instance nat_is_identifiable : IsBiidentifiable Nat.mul Nat.one := {}.

Instance nat_is_monoid : IsMonoid Nat.mul Nat.one := {}.

Instance nat_is_commutative : IsCommutative Nat.mul := {}.
Proof. intros x y. apply Nat.mul_comm. Qed.

Instance nat_is_commutative_monoid : IsCommutativeMonoid Nat.mul Nat.one := {}.

End Multiplicative.

Instance nat_has_add : HasAdd nat := Nat.add.
Instance nat_has_mul : HasMul nat := Nat.mul.

Instance nat_has_zero : HasZero nat := Nat.zero.
Instance nat_has_one : HasOne nat := Nat.one.

Instance nat_is_left_distributive : IsLeftDistributive Nat.add Nat.mul := {}.
Proof. intros x y z. apply Nat.mul_add_distr_l. Qed.

Instance nat_is_right_distributive : IsRightDistributive Nat.add Nat.mul := {}.
Proof. intros x y z. apply Nat.mul_add_distr_r. Qed.

Instance nat_is_distributive : IsBidistributive Nat.add Nat.mul := {}.

Instance nat_is_semiring : IsSemiring Nat.add Nat.zero Nat.mul Nat.one := {}.

Definition natexp (x : nat) : nat := 2 ^ x.

Instance nat_has_hom : HasHom nat nat := natexp.

Instance nat_is_setoid_homomorphism : IsSetoidHomomorphism natexp := {}.
Proof. cbv -[Nat.pow]. apply Nat.pow_wd. reflexivity. Qed.

Instance nat_is_semigroup_homomorphism :
  IsSemigroupHomomorphism Nat.add Nat.mul natexp := {}.
Proof. intros x y. apply Nat.pow_add_r. Qed.

Instance nat_is_monoid_homomorphism :
  IsMonoidHomomorphism Nat.add Nat.zero Nat.mul Nat.one natexp := {}.
Proof. reflexivity. Qed.


Require Import Tapl.DSub.Base.

Inductive type : Set :=
  | ty_top  : type (* ⊤ *)
  | ty_bot  : type (* ⊥ *)
  | ty_decl : type → type → type (* {A : S .. T *)
  | ty_proj : nat → type (* x.A *)
  | ty_dep_fun : type → type → type. (* ∀(x:S) T *)

Inductive term : Set :=
  | tm_var : nat → term
  | tm_tag : type → term
  | tm_abs : type → term → term
  | tm_app : term → term → term
  | tm_let : term → type → term → term.

Definition context := list type.
Inductive wfT : context → type → Prop :=
  | wfT_top : ∀ Γ, wfT Γ ty_top
  | wfT_bot : ∀ Γ, wfT Γ ty_bot
  | wfT_decl : ∀ Γ S T,
      wfT Γ S → wfT Γ T →
      wfT Γ (ty_decl S T)
  | wfT_proj : ∀ Γ i,
      (∃ T, get i Γ = Some T) →
      wfT Γ (ty_proj i)
  | wfT_dep_fun : ∀ Γ S T,
      wfT Γ S →
      wfT (S :: Γ) T →
      wfT Γ (ty_dep_fun S T)
.

Inductive wfX : context → term → Prop :=
  | wfX_var : ∀ Γ i,
      (∃ T, get i Γ = Some T) →
      wfX Γ (tm_var i)
  | wfX_tag : ∀ Γ T,
      wfT Γ T →
      wfX Γ (tm_tag T)
  | wfX_abs : ∀ Γ T t,
      wfT Γ T →
      wfX (T :: Γ) t →
      wfX Γ (tm_abs T t)
  | wfX_app : ∀ Γ t1 t2,
      wfX Γ t1 →
      wfX Γ t2 →
      wfX Γ (tm_app t1 t2)
  | wfX_let : ∀ Γ t1 T t2,
      wfX Γ t1 →
      wfX (T :: Γ) t2 →
      wfX Γ (tm_let t1 T t2).

Definition closed := wfX nil.


Module Evote.

  Require Import Notations.
  Require Import Coq.Lists.List.
  Require Import Coq.Arith.Le.
  Require Import Coq.Numbers.Natural.Peano.NPeano.
  Require Import Coq.Arith.Compare_dec.
  Require Import Coq.omega.Omega.
  Require Import Bool.Sumbool.
  Require Import Bool.Bool.
  Import ListNotations.

  (* type level existential quantifier *)
  Notation "'existsT' x .. y , p" :=
    (sigT (fun x => .. (sigT (fun y => p)) ..))
      (at level 200, x binder, right associativity,
       format "'[' 'existsT'  '/  ' x  ..  y ,  '/  ' p ']'")
    : type_scope.

  (* candidates are a finite type with decidable equality *)
  Parameter cand : Type.
  Parameter cand_all : list cand.
  Hypothesis cand_fin : forall c: cand, In c cand_all.
  Hypothesis dec_cand : forall n m : cand, {n = m} + {n <> m}.

  (* edge is the margin in Schulze counting, i.e. edge c d is the number of
     voters that perfer c over d *)
  (* TODO: possibly rename? *)
  Parameter edge: cand -> cand -> nat.

  (* prop-level path *)
  Inductive Path (k: nat) : cand -> cand -> Prop :=
  | unit c d : edge c d >= k -> Path k c d
  | cons  c d e : edge c d >= k -> Path k d e -> Path k c e.

  (* type-level path *)
  Inductive PathT (k: nat) : cand -> cand -> Type :=
  | unitT : forall c d, edge c d >= k -> PathT k c d
  | consT : forall c d e, edge c d >= k -> PathT k d e -> PathT k c e.

  (* winning condition in Schulze counting *)
  Definition wins (c: cand) :=
    forall d : cand, exists k : nat,
        ((Path k c d) /\ (forall l, Path l d c -> l <= k)).

  (* auxilary functions: all pairs that can be formed from a list *)
  Fixpoint all_pairs {A: Type} (l: list A): list (A * A) :=
    match l with
    |   [] => []
    |    c::cs => (c, c)::(all_pairs cs) ++ (map (fun x => (c, x)) cs)
                       ++ (map (fun x => (x, c)) cs)
    end.

  (* boolean equality on candidates derived from decidable equality *)
  Definition cand_eqb (c d: cand) := proj1_sig (bool_of_sumbool (dec_cand c d)).

  Lemma cand_eqb_prop (c d: cand) : cand_eqb c d = true -> c = d.
  Proof.
    intro H. unfold cand_eqb in H. destruct (dec_cand c d). assumption. simpl in H. inversion H.
  Qed.

  (* boolean membership in lists of pairs *)
  Definition bool_in (p: (cand * cand)%type) (l: list (cand * cand)%type) :=
    existsb (fun q => (andb (cand_eqb (fst q) (fst p))) ((cand_eqb (snd q) (snd p)))) l.

  (* towards the definition of co-closed sets *)
  (* el is a boolean function that returns true if the edge between two cands is <= k *)
  Definition el (k: nat) (p: (cand * cand)%type) := Compare_dec.leb (edge (fst p) (snd p)) k.

  (* mp k (a, c) l (for midpoint) returns true if there's a midpoint b st. either the edge between
     a and b is <= k or else the pair (b, c) is in l *)
  Definition mp (k: nat) (p: (cand * cand)%type) (l: list (cand *cand)%type) :=
    let a := fst p in
    let c := snd p in
    fold_left (fun x => fun b => andb x (orb (bool_in (b, c) l) (el k (a,b)))) cand_all true.

  (* W k is the dual of the operator the least fixpoint of which inductively defines paths *)
  (* W_k (l) = {(a, c) : edge a c <= k /\ forall b: (b, c) \in l \/edge a c <= k } *)
  (* Wf is the boolean predicate that expresses the operator *)
  Definition Wf k l :=  (fun p => andb (el k p)  (mp k p l) ).
  Definition W (k: nat) : list (cand * cand)%type -> list (cand *cand)%type :=
    fun l => filter (Wf k l) (all_pairs cand_all).

  (* a k-coclosed set is a set that is co-closed under W_k *)
  (* idea: the greatest co-closed (and indeed any co-closed set) only *)
  (* contains pairs (x, y) s.t. there's no path of strength >= k between x and y *)
  Definition coclosed (k: nat) (l: list (cand * cand)%type) :=
    forall x, In x l -> In x (W k l).

  (* evidence for winning a Schulze election. *)
  Definition ev (c: cand) := forall d : cand, existsT (k: nat),
    (PathT k c d) * (existsT (l: list (cand * cand)%type), In (d, c)l /\ coclosed k l).

  (* type-level paths allow to construct evidence for the existence of paths *)
  (* TODO: change name of lemma? *)
  Lemma equivalent : forall c d k , PathT k c d -> Path k c d.
  Proof.
    intros. induction X. apply unit. assumption.
    apply cons with (d := d). assumption.
    assumption.
  Qed.

  (* logical interpretation of the midpoint function *)
  (* TODO: change name of lemma? *)
  Lemma edge_prop : forall a b k, el k (a, b) = true -> edge a b <= k.
  Proof.
    intros a b k H; unfold el in H; simpl in H;
      apply leb_complete in H; assumption.
  Qed.

  Lemma boolin_prop :  forall a b l, bool_in (a, b) l = true -> In (a, b) l.
  Proof.
    intros a b l H. unfold bool_in in H; simpl in H.
    rewrite existsb_exists in H. destruct H. destruct x. simpl in H.
    destruct H. apply andb_true_iff in H0.
    destruct H0. apply cand_eqb_prop in H0.
    apply cand_eqb_prop in H1. rewrite H0 in H. rewrite H1 in H.
    assumption.
  Qed.

  Lemma fold_left_uni :
    forall (A : Type) (f : A -> bool) l a,
      fold_left (fun x y => andb x (f y)) l a = true -> a = true /\ List.Forall (fun a => f a = true) l.
  Proof.
    induction l; simpl; intros.
    - auto.
    - apply IHl in H. destruct H.
      apply andb_true_iff in H.
      intuition.
  Qed.

  Lemma fold_left_andb :
    forall (A : Type) (f : A -> bool) l a,
      fold_left (fun x y => andb x (f y)) l a = true -> List.Forall (fun a => f a = true) l.
  Proof. apply fold_left_uni. Qed.

  Lemma fold_left_true :
    forall (p : cand * cand) (l : list (cand * cand)) (k : nat),
      fold_left (fun (x : bool) (b : cand) =>
                   andb x (orb (bool_in (b, snd p) l)
                               (el k (fst p, b)))) cand_all true = true ->
      forall c, (bool_in (c, snd p) l) = true \/ (el k (fst p, c)) = true.
  Proof.
    intros. apply fold_left_andb in H.
    rewrite Forall_forall in H.
    rewrite <- orb_true_iff.
    apply H. apply cand_fin.
  Qed.

  Lemma forthemoment : forall k p l, mp k p l = true ->
                                forall b, In (b, snd p) l \/ edge (fst p) b <= k.
  Proof.
    intros k (u, v) l H b. unfold mp in H.
    apply fold_left_true with (c := b) in H.
    simpl in H; simpl. destruct H as [H | H].
    apply boolin_prop in H. left; assumption.
    apply edge_prop in H. right; assumption.
  Qed.

  (* generic property of coclosed sets as commented above *)
  Lemma coclosednow : forall k l, coclosed k l -> forall s x y,
        Path s x y -> In (x, y) l -> s <= k.
  Proof.
    intros k l Hcc.
    intros s x y.
    intro p.
    induction p.
    (* path of length one *)
    intro Hin.
    unfold coclosed in Hcc.
    specialize (Hcc (c, d)).
    specialize (Hcc Hin).
    unfold W in Hcc.
    Check filter_In.
    assert (HW: In (c, d) (all_pairs cand_all) /\  (Wf k l)  (c, d) = true).
    apply filter_In.
    assumption.
    destruct HW as [HW1 HW2].
    unfold Wf in HW2.

    assert ( el k (c, d) = true /\ mp k (c, d) l = true).
    apply andb_true_iff. assumption.
    destruct H0 as [He Hc].
    unfold el in He.
    simpl in He.
    assert (Hle: edge c d <= k). apply leb_complete. assumption.
    omega.
    (* non-unit path *)
    intro Hin.
    unfold coclosed in Hcc.
    specialize (Hcc (c, e)).   specialize (Hcc Hin).
    unfold W in Hcc.
    assert (HW: In (c, e) (all_pairs cand_all) /\  (Wf k l)  (c, e) = true).
    apply filter_In. assumption.
    destruct HW as [HW1 HW2].
    unfold Wf in HW2.
    assert ( el k (c, e) = true /\ mp k (c, e) l = true).
    apply andb_true_iff. assumption.
    destruct H0 as [He Hc].
    unfold el in He.
    simpl in He.
    assert (Hle: edge c e <= k). apply leb_complete. assumption.
    (*  forall b, In (b, snd p) l \/ edge (fst p) b <= k. *)
    assert (Hmp: forall m, In (m, (snd (c, e))) l \/ edge (fst (c, e)) m <= k).
    apply  forthemoment. assumption.
    simpl in Hmp.
    specialize (Hmp d).
    destruct Hmp as [Hm1 | Hm2].
    (* case 2nd part of path in coclosed list *)
    specialize (IHp Hm1).
    assumption.
    (* case first edge of small weight *)
    omega.
  Qed.

  Theorem th1: forall c, ev c -> wins c.
  Proof.
    intros c H.
    unfold wins. unfold ev in H.
    intro d.
    specialize (H d).
    destruct H as [k H].
    destruct H as [Hp Hc].
    exists k.
    split.
    apply equivalent. assumption.
    intros s p.
    destruct Hc as [l Hc].
    destruct Hc as [Hin Hcc].
    apply coclosednow with (x := d) (y := c) (l := l).
    assumption.
    assumption.
    assumption.
  Qed.

  (* reverse process. Create evidence from winner *)

  Definition geb (a b : nat) :=
    match ge_dec a b with
    | left _ => true
    | right _ => false
    end.

  Theorem geb_true : forall a b,
      geb a b = true <-> a >= b.
  Proof.
    split; intros. unfold geb in H. destruct ge_dec in H. assumption. inversion H.
    unfold geb. destruct ge_dec. reflexivity. congruence.
  Qed.

  (* elg is boolean function returns true if the edge between two candidates
     of >= k. *)
  Definition elg (k : nat) (p : (cand * cand)) : bool :=
    geb (edge (fst p) (snd p)) k.

  (* mp k (a, c) l (for midpoint) returns true if there's a midpoint b st.
     the edge between a and b is >= k /\ the pair (b, c) is in l *)
  Definition mpg (k : nat) (p : (cand * cand)) (l : list (cand * cand)) :=
    let a := fst p in
    let c := snd p in
    fold_left (fun x => fun b => andb x (andb (elg k (a, b)) (bool_in (b, c) l))) cand_all true.

  Definition Of k l  := (fun p => orb (elg k p) (mpg k p l)).
  Definition O k : list (cand * cand) -> list (cand * cand) :=
    fun l => filter (Of k l) (all_pairs cand_all).

  Lemma mpg_true : forall k p l,
      mpg k p l = true <-> exists b, elg k (fst p, b) = true /\ In (b, snd p) l.
  Proof. Admitted.

  Lemma in_list : forall c d, In c cand_all ->  In d cand_all -> In (c, d) (all_pairs cand_all).
  Proof. Admitted.

  Lemma gebedge_true : forall c d k, edge c d >= k <->  geb (edge c d) k = true.
  Proof.
    split; intros. apply geb_true. assumption.
    apply geb_true. assumption.
  Qed.

  Fixpoint iterfun {A : Type} (f : A -> A) (n : nat) (a : A) : A :=
    match n with
    | 0 => a
    | S n' => f (iterfun f n' a)
    end.

  Theorem wins_evi_1: forall k c d, Path k c d -> exists (n : nat), In (c, d) (iterfun (O k) n []).
  Proof.
    induction 1.
    exists 1. simpl. unfold O, Of.
    apply filter_In. split. apply in_list; repeat (apply cand_fin).
    apply orb_true_iff. left. apply gebedge_true. simpl.
    assumption.

    destruct IHPath.
    exists (S x). simpl. apply filter_In. split. apply in_list; repeat (apply cand_fin).
    unfold Of. rewrite orb_true_iff. right. apply mpg_true.
    simpl. exists d. split. unfold elg. simpl. apply gebedge_true. assumption.
    assumption.
  Qed.

  Theorem wins_evi_2 : forall k n c d, In (c, d) (iterfun (O k) n []) -> Path k c d.
  Proof.
    intros k n. induction n. simpl. intros c d H; inversion H.
    intros c d H. simpl in H. unfold O in H. apply filter_In in H.
    destruct H as [H1 H2]. unfold Of in H2. apply orb_true_iff in H2.
    destruct H2 as [H2 | H2]. unfold elg in H2; simpl in H2. apply gebedge_true in H2.
    constructor 1. assumption.
    apply mpg_true in H2. simpl in H2. destruct H2 as [m H2]. destruct H2 as [H3 H4].
    apply cons with (d := m). unfold elg in H3; simpl in H3. apply gebedge_true in H3.
    assumption.  apply (IHn m d). fold (O k) in H4. assumption.
  Qed.
End Evote.


Require Coq.Init.Datatypes.
Import Coq.Init.Notations.
Notation "A -> B" := (forall (_ : A), B) : type_scope.
Require Import Coq.Program.Tactics.
Require Import inductionAndFunctionsSolutions.

Section lemmasExamples.

  Definition twicePlusOneIsPlusTwo:
    forall x:ThreeElementSet,
      plusOneModThree (plusOneModThree x) = plusTwoModThree x.
  Proof.
  intros. induction x.
  - simpl. reflexivity.
  - simpl. reflexivity.
  - simpl. reflexivity.
  Defined.

  Definition thirdLostAfterRounding:
    forall x y z:ThreeElementSet,
      roundToPair (triple x y z) = pair x y.
  Proof.
  intros. simpl. reflexivity.
  Defined.

  Definition testAppend {x y z:ThreeElementSet} {l:Lst}:
    append (cons x nil) (cons y (cons z l)) =
    cons x (cons y (cons z l)).
  Proof.
  simpl. reflexivity.
  Defined.

  Definition appendAssoc (l m n:Lst):
    append (append l m) n = append l (append m n).
  Proof.
    induction l.
    - simpl. reflexivity.
    - simpl. rewrite IHl. reflexivity.
  Defined.

End lemmasExamples.

Section lemmasExercises.

  Definition constantModThree:
    forall x:FourElementSet,
      fourModThree (constantAtZero4 x) =
      constantAtZero (fourModThree x).
  Proof.
  intros. simpl. reflexivity.
  Defined.

  Definition doubleModThreeIdempotent:
    forall x:ThreeElementSet,
      doubleModThree (doubleModThree x) = x.
  Proof.
  intros. induction x.
  - simpl. reflexivity.
  - simpl. reflexivity.
  - simpl. reflexivity.
  Defined.

  Definition lengthDoubleCons:
    forall x y:ThreeElementSet,
    forall l:Lst,
      length (cons y (cons x l)) = succ (succ (length l)).
  Proof.
  intros. induction l.
  - simpl. reflexivity.
  - simpl. reflexivity.
  Defined.

  Definition appendHigherAssoc (l1 l2 l3 l4:Lst):
  append l1 (append l2 (append l3 l4)) =
  append (append(append l1 l2) l3) l4.
  Proof.
  rewrite appendAssoc. rewrite appendAssoc. reflexivity.
  Defined.

  Definition lengthLemma (l1 l2:Lst) (x:ThreeElementSet):
  length (append l1 (append (cons x nil) l2)) =
  succ ( length (append l1 l2)).
  Proof.
  simpl. induction l1.
  - simpl. reflexivity.
  - simpl. rewrite IHl1. reflexivity.
  Defined.

End lemmasExercises.


From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq fintype.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(** * Exercise: Define equality type for the following datatype *)
Inductive tri :=
| Yes | No | Maybe.

Print eq_op.
About eq_op.
(* rel T := T -> T -> bool *)
Print Equality.type.
(*
Definition tri_eq : tri -> tri -> bool :=
    fun a b =>
        match a, b with
        | Yes, Yes | No, No | Maybe, Maybe => true
        | _, _ => false
        end.
Lemma tri_eq_proof : Equality.axiom tri_eq.
Proof.
by case; case; constructor.
Qed.

Canonical tri_eqType :=
    EqType tri (EqMixin tri_eq_proof).

Check (1, Yes) == (1, Maybe).
Check erefl : (1, Yes) == (1, Maybe) = false.
*)

Check 'I_3. (* [0..n) *)
Print ordinal.

Definition tri_to_ord (t : tri) : 'I_3 :=
    match t with
    | Yes => inord 0
    | No => inord 1
    | Maybe => inord 2
    end.
Print inord.

Definition ord_tri (o : 'I_3) : tri :=
    match (o : nat) with
    | 0 => Yes
    | 1 => No
    | _ => Maybe
    end.

Lemma ord_triK : cancel tri_to_ord ord_tri.
Proof.
by case ; rewrite /ord_tri /tri_to_ord inordK.
Qed.

Definition tri_eqMixin := CanEqMixin ord_triK.
Canonical tri_eqType := EqType tri tri_eqMixin.

Check (1, Yes) == (1, Maybe).
(* Check erefl : (1, Yes) == (1, Maybe) = false. *)

Record record : predArgType := Mk_record {
    A : nat;
    B : bool;
    C : nat * nat;
}.

Definition record_to_triple (r : record) : (nat * bool * (nat * nat)).
Proof. move: r ; by case. Defined.
Definition triple_to_record (t : (nat * bool * (nat * nat))) : record :=
    match t with
    | (a, b, c) => Mk_record a b c
    end.
Lemma record_tripleK : cancel record_to_triple triple_to_record.
Proof.
by case.
Qed.

Definition record_eqMixin := CanEqMixin record_tripleK.
Canonical record_eqType := EqType record record_eqMixin.

Variable test : record.
Check (test == test).
Compute (Mk_record 1 true (2, 3)) == (Mk_record 2 true (2, 3)).

(* Odd and even numbers *)

Structure odd_nat := Odd {
    oval :> nat;
    oprop : odd oval
}.
Check @Odd 3 erefl.
Compute odd 3.

Lemma oddP (n : odd_nat) : odd n.
Proof.
by case: n.
Qed.

Structure even_nat := Even {
    eval :> nat;
    eprop : ~~ (odd eval)
}.
Definition e2 := Even (erefl (~~ (odd 2))).
Compute e2 + 3.
Lemma evenP (n : even_nat) : ~~ (odd n).
Proof. by case: n. Qed.

(** Part 1: Arithmetics **)

Example test_odd (n : odd_nat) :
    ~~ (odd 6) && odd (n * 3).
Proof. Fail by rewrite oddP evenP. Abort.

Canonical even_0 : even_nat := @Even 0 isT.

Lemma oddS n : ~~ (odd n) -> odd n.+1.
Proof. done. Qed.

Lemma evenS n : (odd n) -> ~~ (odd n.+1).
Proof.
case: n => // n /= ; by rewrite negbK.
Qed.

Canonical odd_even (m : even_nat) : odd_nat :=
    @Odd m.+1 (oddS (eprop m)).
Canonical even_odd (m : odd_nat) : even_nat :=
    @Even m.+1 (evenS (oprop m)).

Lemma foo (m : even_nat) : odd m.+1.
Proof.
(* будет строить инстанс odd_nat, чтобы прийти к цели *)
(* который построится благодаря канонам *)
(* oddP : forall n : odd_nat, odd (oval n) *)
(*                            odd S m *)
(* oval ?n === S m  => triggers odd_even *)
(* ?n = odd_even ?m *)
by rewrite oddP.
Qed.

Lemma foo' (m : even_nat) : odd m.+3.
Proof.
by rewrite oddP.
Qed.

Lemma odd_mulP (n m : odd_nat) : odd (n * m).
Proof.
case: n => /= n n0 ; case: m => /= m m0.
by rewrite oddM ; apply/andP.
Qed.

Example test_odd (n : odd_nat) :
  ~~ (odd 6) && odd (n * 3).
Proof.
apply/andP ; split => //.
by rewrite odd_mulP.
Qed.


(* infotheo (c) AIST. R. Affeldt, M. Hagiwara, J. Senizergues. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat div seq choice fintype.
From mathcomp Require Import tuple finfun bigop finset.
Require Import Reals Fourier.
Require Import Reals_ext Ranalysis_ext ssr_ext Rssr log2 ln_facts Rbigop proba.
Require Import divergence variation_dist pinsker_function partition_inequality.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Local Open Scope divergence_scope.
Local Open Scope variation_distance_scope.
Local Open Scope reals_ext_scope.

Section Pinsker_2_bdist.

Variables p q : R.
Hypothesis p01 : 0 <= p <= 1.
Hypothesis q01 : 0 <= q <= 1.
Variable A : finType.
Hypothesis card_A : #|A| = 2%nat.

Let P := bdist card_A p01.
Let Q := bdist card_A q01.

Hypothesis P_dom_by_Q : P << Q.

Lemma pinsker_fun_p_eq c : pinsker_fun p c q = D(P || Q) - c * d(P , Q) ^ 2.
Proof.
pose A_0 := Two_set.val0 card_A.
pose A_1 := Two_set.val1 card_A.
set pi := P A_0.
set pj := P A_1.
set qi := Q A_0.
set qj := Q A_1.
have Hpi : pi = 1 - p.
  rewrite /pi /= ffunE.
  case: ifP => //; by rewrite eqxx.
have Hqi : qi = 1 - q.
  rewrite /qi /= ffunE.
  case: ifP => //; by rewrite eqxx.
have Hpj : pj = p.
  rewrite /pj /= ffunE /Two_set.val1.
  case: ifP => //; by move/eqP/enum_val_inj.
have Hqj : qj = q.
  rewrite /qj /= ffunE /Two_set.val1.
  case: ifP => //; by move/eqP/enum_val_inj.
transitivity (D(P || Q) - c * (Rabs (p - q) + Rabs ((1 - p) - (1 - q))) ^ 2).
  rewrite /pinsker_fun /div /index_enum -enumT Two_set.enum big_cons big_cons big_nil addR0.
  rewrite -/pi -/pj -/qi -/qj Hpi Hpj Hqi Hqj.
  have -> : Two_set.val0 card_A \in A by apply enum_valP.
  have -> : Two_set.val1 card_A \in A by apply enum_valP.
  set tmp := (Rabs (_) + _) ^ 2.
  have -> : tmp = 4 * (p - q) ^ 2.
    rewrite /tmp (_ : 1 - p - (1 - q) = q - p); last by field.
    rewrite id_rem_plus.
    have -> : Rabs (q - p) = Rabs (p - q).
      rewrite -Rabs_Ropp.
      f_equal; by field.
    rewrite -mulRA (_ : Rabs _ * Rabs _ = (Rabs (p - q))^2); last by rewrite /= mulR1.
    rewrite Rabs_sq; by field.
  rewrite [X in _ = _ + _ - X]mulRA.
  rewrite [in X in _ = _ + _ - X](mulRC c).
  f_equal.
  case: p01 => Hp1 Hp2.
  case: q01 => Hq1 Hq2.
  case/Rle_lt_or_eq_dec : Hp1 => Hp1; last first.
    rewrite -Hp1 !mul0R Rminus_0_r addR0 add0R !mul1R log_1 /Rdiv.
    case/Rle_lt_or_eq_dec : Hq2 => Hq2; last first.
      move: (@P_dom_by_Q (Two_set.val0 card_A)).
      rewrite -/pi -/qi => abs.
      rewrite Hqi Hq2 Rminus_diag_eq // in abs.
      move: {abs}(abs Logic.eq_refl).
      rewrite Hpi -Hp1 Rminus_0_r.
      move=> abs. suff : False by done. fourier.
    rewrite log_mult; last 2 first.
      fourier.
      apply Rinv_0_lt_compat; fourier.
      rewrite log_Rinv; last by fourier.
      rewrite log_1; by field.
  case/Rle_lt_or_eq_dec : Hq1 => Hq1; last first.
    move: (@P_dom_by_Q (Two_set.val1 card_A)).
    rewrite -/pj -/qj Hqj -Hq1.
    move/(_ Logic.eq_refl).
    rewrite Hpj => abs.
    rewrite abs in Hp1.
    by apply Rlt_irrefl in Hp1.
  rewrite /div_fct /comp /= (_ : id q = q) //.
  case/Rle_lt_or_eq_dec : Hp2 => Hp2; last first.
    rewrite Hp2 Rminus_diag_eq // !mul0R /Rdiv log_mult; last 2 first.
      fourier.
      apply Rinv_0_lt_compat; fourier.
    rewrite log_1 Rmult_1_l log_Rinv //; by field.
  rewrite log_mult //; last by apply Rinv_0_lt_compat.
  rewrite log_Rinv //.
  case/Rle_lt_or_eq_dec : Hq2 => Hq2; last first.
    move: (@P_dom_by_Q (Two_set.val0 card_A)).
    rewrite -/pi -/qi Hqi -Hq2 Rminus_diag_eq //.
    move/(_ Logic.eq_refl).
    rewrite Hpi => abs.
    suff : False by done. fourier.
  rewrite /Rdiv log_mult; last 2 first.
    fourier.
    apply Rinv_0_lt_compat; fourier.
  rewrite log_Rinv; last by fourier.
  by field.
do 2 f_equal.
rewrite /var_dist /index_enum -enumT Two_set.enum big_cons big_cons big_nil addR0.
by rewrite -/pi -/pj -/qi -/qj Hpi Hpj Hqi Hqj addRC.
Qed.

Lemma Pinsker_2_inequality_bdist : / (2 * ln 2) * d(P , Q) ^ 2 <= D(P || Q).
Proof.
set lhs := _ * _.
set rhs := D(_ || _).
suff : 0 <= rhs - lhs by move=> ?; fourier.
rewrite -pinsker_fun_p_eq.
apply pinsker_fun_pos with p01 q01 A card_A => //.
split.
  apply Rlt_le, Rinv_0_lt_compat, Rmult_lt_0_compat.
  fourier.
  by apply ln_2_pos.
by apply Rle_refl.
Qed.

End Pinsker_2_bdist.

Section Pinsker_2.

Variable A : finType.
Variables P Q : dist A.
Hypothesis card_A : #|A| = 2%nat.
Hypothesis P_dom_by_Q : P << Q.

Lemma Pinsker_2_inequality : / (2 * ln 2) * d(P , Q) ^ 2 <= D(P || Q).
Proof.
move: (charac_bdist P card_A) => [r1 [Hr1 Hp]].
move: (charac_bdist Q card_A) => [r2 [Hr2 Hq]].
rewrite Hp Hq.
apply Pinsker_2_inequality_bdist.
by rewrite /dom_by -Hp -Hq.
Qed.

End Pinsker_2.

Section Pinsker.

Variable A : finType.
Variables P Q : dist A.
Hypothesis P_dom_by_Q : P << Q.

Local Open Scope Rb_scope.

Local Notation "0" := (false).
Local Notation "1" := (true).

(** * Pinsker's Inequality *)

Lemma Pinsker_inequality : / (2 * ln 2) * d(P , Q) ^ 2 <= D(P || Q).
Proof.
pose A0 := [set a | Q a <b= P a].
pose A1 := [set a | P a <b Q a].
pose A_ := fun b => match b with 0 => A0 | 1 => A1 end.
have cov : A_ 0 :|: A_ 1 = setT.
  rewrite /= /A0 /A1.
  have -> : [set x | P x <b Q x] = ~: [set x | Q x <b= P x].
    apply/setP => a; by rewrite in_set in_setC in_set RltNge.
  by rewrite setUCr.
have dis : A_ 0 :&: A_ 1 = set0.
  rewrite /A_ /A0 /A1.
  have -> : [set x | P x <b Q x] = ~: [set x | Q x <b= P x].
    apply/setP => a; by rewrite in_set in_setC in_set RltNge.
  by rewrite setICr.
pose P_A := bipart dis cov P.
pose Q_A := bipart dis cov Q.
have step1 : D(P_A || Q_A) <= D(P || Q) by apply partition_inequality; exact P_dom_by_Q.
suff : / (2 * ln 2) * d(P , Q) ^2 <= D(P_A || Q_A).
  move=> ?; apply Rle_trans with (D(P_A || Q_A)) => //; by apply Rge_le.
have step2 : d( P , Q ) = d( P_A , Q_A ).
  rewrite /var_dist.
  transitivity (\rsum_(a | a \in A0) Rabs (P a - Q a) + \rsum_(a | a \in A1) Rabs (P a - Q a)).
    rewrite -(@rsum_union _ _ _ (A0 :|: A1)) //; last by rewrite -setI_eq0 -dis /A_ setIC.
    apply eq_bigl => a; by rewrite cov in_set.
  transitivity (Rabs (P_A 0 - Q_A 0) + Rabs (P_A 1 - Q_A 1)).
    f_equal.
    - rewrite /P_A /Q_A /bipart /= /bipart_pmf /=.
      transitivity (\rsum_(a | a \in A0) (P a - Q a)).
        apply eq_bigr => a; rewrite /A0 in_set => Ha.
        rewrite Rabs_pos_eq //.
        move/RleP in Ha; by fourier.
      rewrite big_split /= Rabs_pos_eq; last first.
        suff : \rsum_(a | a \in A0)Q a <= \rsum_(a | a \in A0) P a.
          move=> ?; by fourier.
        apply: Rle_big_P_f_g => a.
        rewrite inE; by move/RleP.
      rewrite -(big_morph _ morph_Ropp Ropp_0) //; by field.
    - rewrite /P_A /Q_A /bipart /= /bipart_pmf /=.
      have [A1_card | A1_card] : #|A1| = O \/ (0 < #|A1|)%nat.
        destruct (#|A1|); [tauto | by right].
      + move/eqP : A1_card; rewrite cards_eq0; move/eqP => A1_card.
        rewrite A1_card !big_set0 Rabs_pos_eq //; [by field | fourier].
      + transitivity (\rsum_(a | a \in A1) - (P a - Q a)).
          apply eq_bigr => a; rewrite /A1 in_set => Ha.
          rewrite Rabs_left //.
          move/RltP in Ha; by fourier.
        rewrite -(big_morph _  morph_Ropp Ropp_0) // big_split /= Rabs_left; last first.
          suff : \rsum_(a | a \in A1) P a < \rsum_(a | a \in A1) Q a by move=> ?; fourier.
          apply: Rlt_big_f_g_X => // a.
          rewrite /A1 in_set; by move/RltP.
        by rewrite -(big_morph _ morph_Ropp Ropp_0).
  rewrite /index_enum -enumT Two_set.enum /=.
    symmetry; by rewrite card_bool.
  move=> HX.
  rewrite /bipart_pmf big_cons /= big_cons /= big_nil /= addR0.
  set i0 := Two_set.val0 HX.
  set i1 := Two_set.val1 HX.
  have : i0 <> i1.
    apply/eqP.
    by apply Two_set.val0_neq_val1.
  wlog : i0 i1 / (i0 == false) && (i1 == true).
    move=> Hwlog i0i1.
    have : ((i0, i1) == (true, false)) || ((i0, i1) == (false, true)).
      move: i0 i1 i0i1; by case; case.
    case/orP; case/eqP => -> ->.
    - by rewrite (Hwlog false true) // addRC.
    - by apply Hwlog.
  case/andP => /eqP ? /eqP ?; by subst i0 i1.
rewrite step2.
apply (Pinsker_2_inequality card_bool) => /= b.
rewrite /bipart_pmf => H.
have {H}H : 0%R = bipart_pmf A_ Q b. done.
move: (@Req_0_rmul_inv A (fun x => x \in A_ b) (pmf Q) (Rle0f Q) H) => {H}H.
transitivity (\rsum_(a | a \in A_ b) 0%R).
  apply eq_bigr => // a Ha.
  apply P_dom_by_Q; by rewrite -H.
by rewrite big_const iter_Rplus mulR0.
Qed.

Lemma Pinsker_inequality_weak : d(P , Q) <= sqrt (2 * D(P || Q)).
Proof.
rewrite -(sqrt_Rsqr (d(P , Q))); last by apply pos_var_dist.
apply sqrt_le_1_alt.
apply (Rmult_le_reg_l (/ 2)); first by apply Rinv_0_lt_compat; fourier.
apply Rle_trans with (D(P || Q)); last first.
  rewrite mulRA Rinv_l; last by move=> ?; fourier.
  rewrite mul1R; by apply Rle_refl.
eapply Rle_trans; last by apply Pinsker_inequality.
rewrite (_ : forall x, Rsqr x = x ^ 2); last by move=> ?; rewrite /Rsqr /pow; field.
apply Rmult_le_compat_r; first by apply le_sq.
apply Rle_Rinv; [ | fourier| ].
- apply Rmult_lt_0_compat; [fourier | exact ln_2_pos].
- rewrite -[X in _ <= X]mulR1.
  apply Rmult_le_compat_l; first by fourier.
  rewrite [X in _ <= X](_ : 1%R = ln (exp 1)); last by rewrite ln_exp.
  apply ln_increasing_le; [fourier | exact two_e].
Qed.

End Pinsker.


Require Import Reals Interval.Tactic.

Goal forall x, (-1 / 3 <= x - x <= 1 / 7)%R.
Proof.
intros x.
interval with (i_autodiff x).
Qed.


Require Import Cring.
From mathcomp Require Import all_ssreflect all_algebra.

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

Local Open Scope ring_scope.
Import GRing.Theory.

Section Terre.

(* Un corps quelconque                                                        *)
Variable R : fieldType.

(* Le nombre Pi                                                               *)

Variable Pi : R.

Hypothesis NZPi : Pi != 0.
Hypothesis NZP2 : 2%:R != 0 :> R.

Definition length (r : R) := 2%:R * Pi * r.

Definition delta := 1 / (2%:R * Pi).

Lemma delta_length r1 r2 k  : length r1 - length r2 = k -> r1 = r2 + k * delta.
Proof.
rewrite /length /delta => Hd.
have P2D0 : 2%:R * Pi != 0 by rewrite mulf_eq0 negb_or NZP2.
apply: (mulfI P2D0); rewrite mulrDr [k * _]mulrA mulr1.
by rewrite [X in _ = _ + X]mulrC divfK // addrC -Hd subrK.
Qed.

Fact result r1 r2 :  length r1 - length r2 = 6%:R -> r1 = r2 + 3%:R / Pi.
Proof.
have->: 6%:R = (3%:R * 2%:R) :> R by rewrite -natrM.
by move/delta_length->; rewrite !mulrA mulr1 invfM mulrA mulfK.
Qed.

End Terre.


Require Import ct24.

Section PermSplitPivot.

Variable A : Type.
Variable le: A -> A -> Prop.
Variable le_dec: forall (x y: A), {le x y} + {~le x y}.
Implicit Type l : list A.

Lemma Permutation_split_pivot: forall (a : A) l,
  Permutation (fst (split_pivot A le le_dec a l)
    ++ snd (split_pivot A le le_dec a l)) l.
Proof.
induction l; simpl; auto.
destruct (split_pivot A le le_dec a l); simpl in *.
destruct (le_dec a0 a); simpl; auto;
rewrite <- Permutation_middle; constructor; auto.
Defined.

End PermSplitPivot.

Lemma permutation_split_pivot : forall (a : nat) (l : list nat),
  Permutation (fst (split_pivot nat le le_dec a l)
    ++ snd (split_pivot nat le le_dec a l)) l.
Proof.
apply Permutation_split_pivot.
Defined.


(* -*- mode: coq; mode: visual-line -*-  *)
Require Import Basics Types.
Require Import HoTT.Truncations.
Require Import Spaces.BAut Spaces.BAut.Rigid.
Require Import ExcludedMiddle.

Local Open Scope trunc_scope.
Local Open Scope path_scope.

(** * The universe *)

(** ** Automorphisms of the universe *)

(** See "Parametricity, automorphisms of the universe, and excluded middle" by Booij, Escardo, Lumsdaine, Shulman. *)

(** If two inequivalent types have equivalent automorphism oo-groups, then assuming LEM we can swap them and leave the rest of the universe untouched. *)
Section SwapTypes.
  (** Amusingly, this does not actually require univalence!  But of course, to verify [BAut A <~> BAut B] in any particular example does require univalence. *)
  Context `{Funext} `{ExcludedMiddle}.
  Context (A B : Type) (ne : ~(A <~> B)) (e : BAut A <~> BAut B).

  Definition equiv_swap_types : Type <~> Type.
  Proof.
    refine (((equiv_decidable_sum (fun X:Type => merely (X=A)))^-1)
              oE _ oE
              (equiv_decidable_sum (fun X:Type => merely (X=A)))).
    refine ((equiv_functor_sum_l
               (equiv_decidable_sum (fun X => merely (X.1=B)))^-1)
              oE _ oE
              (equiv_functor_sum_l
                 (equiv_decidable_sum (fun X => merely (X.1=B))))).
    refine ((equiv_sum_assoc _ _ _)
              oE _ oE
              (equiv_sum_assoc _ _ _)^-1).
    apply equiv_functor_sum_r.
    assert (q : BAut B <~> {x : {x : Type & ~ merely (x = A)} &
                                merely (x.1 = B)}).
    { refine (equiv_sigma_assoc _ _ oE _).
      apply equiv_functor_sigma_id; intros X.
      apply equiv_iff_hprop.
      - intros p.
        refine (fun q => _ ; p).
        strip_truncations.
        destruct q.
        exact (ne (equiv_path X B p)).
      - exact pr2. }
    refine (_ oE equiv_sum_symm _ _).
    apply equiv_functor_sum'.
    - exact (e^-1 oE q^-1).
    - exact (q oE e).
  Defined.

  Definition equiv_swap_types_swaps : merely (equiv_swap_types A = B).
  Proof.
    assert (ea := (e (point _)).2). cbn in ea.
    strip_truncations; apply tr.
    unfold equiv_swap_types.
    apply moveR_equiv_V.
    rewrite (equiv_decidable_sum_l
               (fun X => merely (X=A)) A (tr 1)).
    assert (ne' : ~ merely (B=A))
      by (intros p; strip_truncations; exact (ne (equiv_path A B p^))).
    rewrite (equiv_decidable_sum_r
               (fun X => merely (X=A)) B ne').
    cbn.
    apply ap, path_sigma_hprop; cbn.
    exact ea.
  Defined.

  Definition equiv_swap_types_not_id
    : equiv_swap_types <> equiv_idmap.
  Proof.
    intros p.
    assert (q := equiv_swap_types_swaps).
    strip_truncations.
    apply ne.
    apply equiv_path.
    rewrite p in q; exact q.
  Qed.

End SwapTypes.

(** In particular, we can swap any two distinct rigid types. *)

Definition equiv_swap_rigid `{Univalence} `{ExcludedMiddle}
           (A B : Type) `{IsRigid A} `{IsRigid B} (ne : ~(A <~> B))
  : Type <~> Type.
Proof.
  refine (equiv_swap_types A B ne _).
  apply equiv_contr_contr.
Defined.

(** Such as [Empty] and [Unit]. *)

Definition equiv_swap_empty_unit `{Univalence} `{ExcludedMiddle}
  : Type <~> Type
  := equiv_swap_rigid Empty Unit (fun e => e^-1 tt).

(** In this case we get an untruncated witness of the swapping. *)

Definition equiv_swap_rigid_swaps `{Univalence} `{ExcludedMiddle}
           (A B : Type) `{IsRigid A} `{IsRigid B} (ne : ~(A <~> B))
  : equiv_swap_rigid A B ne A = B.
Proof.
  unfold equiv_swap_rigid, equiv_swap_types.
  apply moveR_equiv_V.
  rewrite (equiv_decidable_sum_l
             (fun X => merely (X=A)) A (tr 1)).
  assert (ne' : ~ merely (B=A))
    by (intros p; strip_truncations; exact (ne (equiv_path A B p^))).
  rewrite (equiv_decidable_sum_r
             (fun X => merely (X=A)) B ne').
  cbn.
  apply ap, path_sigma_hprop; cbn.
  exact ((path_contr (center (BAut B)) (point (BAut B)))..1).
Defined.

(** We can also swap the products of two rigid types with another type [X], under a connectedness/truncatedness assumption. *)

Definition equiv_swap_prod_rigid  `{Univalence} `{ExcludedMiddle}
           (X A B : Type) (n : trunc_index) (ne : ~(X*A <~> X*B))
           `{IsRigid A} `{IsConnected n.+1 A}
           `{IsRigid B} `{IsConnected n.+1 B}
           `{IsTrunc n.+1 X}
  : Type <~> Type.
Proof.
  refine (equiv_swap_types (X*A) (X*B) ne _).
  transitivity (BAut X).
  - symmetry; exact (baut_prod_rigid_equiv X A n).
  - exact (baut_prod_rigid_equiv X B n).
Defined.

(** Conversely, from some nontrivial automorphisms of the universe we can deduce nonconstructive consequences. *)

Definition lem_from_aut_type_unit_empty `{Univalence}
           (f : Type <~> Type) (eu : f Unit = Empty)
  : ExcludedMiddle_type.
Proof.
  apply DNE_to_LEM, DNE_from_allneg; intros P ?.
  exists (f P); split.
  - intros p.
    assert (Contr P) by (apply contr_inhabited_hprop; assumption).
    assert (q : Unit = P)
      by (apply path_universe_uncurried, equiv_contr_contr).
    destruct q.
    rewrite eu.
    auto.
  - intros nfp.
    assert (q : f P = Empty)
      by (apply path_universe_uncurried, equiv_to_empty, nfp).
    rewrite <- eu in q.
    apply ((ap f)^-1) in q.
    rewrite q; exact tt.
Defined.

Lemma equiv_hprop_idprod `{Univalence}
      (A : Type) (P : Type) (a : merely A) `{IsHProp P}
  : P <-> (P * A = A).
Proof.
  split.
  - intros p; apply path_universe with snd.
    apply isequiv_adjointify with (fun a => (p,a)).
    + intros x; reflexivity.
    + intros [p' x].
      apply path_prod; [ apply path_ishprop | reflexivity ].
  - intros q.
    strip_truncations.
    apply equiv_path in q.
    exact (fst (q^-1 a)).
Defined.

Definition lem_from_aut_type_inhabited_empty `{Univalence}
           (f : Type <~> Type)
           (A : Type) (a : merely A) (eu : f A = Empty)
  : ExcludedMiddle_type.
Proof.
  apply DNE_to_LEM, DNE_from_allneg; intros P ?.
  exists (f (P * A)); split.
  - intros p.
    assert (q := fst (equiv_hprop_idprod A P a) p).
    apply (ap f) in q.
    rewrite eu in q.
    rewrite q; auto.
  - intros q.
    apply equiv_to_empty in q.
    apply path_universe_uncurried in q.
    rewrite <- eu in q.
    apply ((ap f)^-1) in q.
    exact (snd (equiv_hprop_idprod A P a) q).
Defined.

(** If you can derive a constructive taboo from an automorphism of the universe such that [g X <> X], then you get [X]-many beers; see <https://groups.google.com/d/msg/homotopytypetheory/8CV0S2DuOI8/blCo7x-B7aoJ>. *)

Definition zero_beers `{Univalence}
           (g : Type <~> Type) (ge : g Empty <> Empty)
  : ~~ExcludedMiddle_type.
Proof.
  pose (f := equiv_inverse g).
  intros nlem.
  apply ge.
  apply path_universe_uncurried, equiv_to_empty; intros gz.
  apply nlem.
  apply (lem_from_aut_type_inhabited_empty f (g Empty) (tr gz)).
  unfold f; apply eissect.
Defined.

Definition lem_beers `{Univalence}
           (g : Type <~> Type) (ge : g ExcludedMiddle_type <> ExcludedMiddle_type)
  : ~~ExcludedMiddle_type.
Proof.
  intros nlem.
  pose (nlem' := equiv_to_empty nlem).
  apply path_universe_uncurried in nlem'.
  rewrite nlem' in ge.
  apply (zero_beers g) in ge.
  exact (ge nlem).
Defined.


(*
http://ccvanishing.hateblo.jp/entry/2013/01/06/212707
https://gist.github.com/y-taka-23/4466805A
 *)
Require Import subset.

Class TopSpace (X : Set) (Open : Subset X -> Prop) :=
  {
    TS_whole : Open (whole X);
    TS_empty : Open (empty X);
    TS_intsec : forall U1 U2 : Subset X,
        Open U1 -> Open U2 -> Open (intsec U1 U2);
    TS_union : forall (I : Set) (index : I -> Subset X),
        (forall i : I, Open (index i)) -> Open (bigcup I index)
  }.
Class Continuous (X : Set) (XOpen : Subset X -> Prop)
      (Y : Set) (YOpen : Subset Y -> Prop)
      (f : X -> Y) :=
  {
    Conti_TopSpace_l :>
                     TopSpace X XOpen;
    Conti_TopSpace_r :>
                     TopSpace Y YOpen;
    Conti_preim :
      forall V : Subset Y, YOpen V -> XOpen (preimage f V)
  }.
Class Connected (X : Set) (Open : Subset X -> Prop) (S : Subset X) :=
  {
    Conn_TopSpace :> TopSpace X Open;
    Conn_insep :
      forall U1 U2 : Subset X,
        Open U1 -> Open U2 -> incl S (union U1 U2) ->
        (exists x1 : X, (intsec S U1) x1) ->
        (exists x2 : X, (intsec S U2) x2) ->
        exists x : X, intsec S (intsec U1 U2) x
  }.
Definition identity (X : Set) : X -> X := fun (x : X) => x.

Class Homeomorphism (X Y : Set) (XOpen : Subset X -> Prop) (YOpen : Subset Y -> Prop) (f : X -> Y) :=
  {
    Homeo_conti :> Continuous X XOpen Y YOpen f;
    Homeo_bijec :
      exists g : Y -> X,
        composite g f = identity X ->
        composite f g = identity Y ->
        Continuous Y YOpen X XOpen g
  }.
(*
Class Locally_homeo (X Y : Set) (XOpen : Subset X -> Prop) (YOpen : Subset Y -> Prop) (f : X -> Y) :=
  {
    LH_conti :> Continuous X XOpen Y YOpen f;
    LH_locinv :
      forall x : X, exists U : Subset X, U x -> XOpen U -> Homeomophism U (image (restr f U))
*)
Section Connectedness.

Variables X Y : Set.
Variable XOpen : Subset X -> Prop.
Variable YOpen : Subset Y -> Prop.
Hypothesis X_TopSpace : TopSpace X XOpen.
Hypothesis Y_TopSpace : TopSpace Y YOpen.
Variable f : X -> Y.
Hypothesis f_Continuous : Continuous X XOpen Y YOpen f.
Variable U : Subset X.
Hypothesis U_Connected : Connected X XOpen U.

Instance image_Connected : Connected Y YOpen (image f U).
Proof.
  apply Build_Connected.
  apply Y_TopSpace.
  intros.
  destruct H2.
  destruct H3.
  assert (exists x : X, (intsec U (intsec (preimage f U1) (preimage f U2)) x)).
  apply Conn_insep.
  apply f_Continuous.
  apply H.
  apply f_Continuous.
  apply H0.
  assert (incl U (preimage f (image f U))).
  apply im_preim.
  assert (incl (preimage f (image f U)) (preimage f (union U1 U2))).
  apply preim_incl.
  apply H1.
  assert (preimage f (union U1 U2) = union (preimage f U1) (preimage f U2)).
  apply preim_union.
  rewrite <- H6.
  apply (incl_trans U (preimage f (image f U)) (preimage f (union U1 U2))).
  apply H4.
  apply H5.
  apply intsec_and in H2.
  unfold image in H2.
  destruct H2.
  destruct H2.
  exists x1.
  apply intsec_and.
  intuition.
  unfold preimage.
  subst.
  apply H4.
  apply intsec_and in H3.
  unfold image in H3.
  destruct H3.
  destruct H3.
  exists x1.
  apply intsec_and.
  intuition.
  unfold preimage.
  subst.
  apply H4.
  destruct H4.
  exists (f x1).
  apply intsec_and.
  apply intsec_and in H4.
  destruct H4.
  apply intsec_and in H5.
  unfold preimage in H5.
  split.
  unfold image.
  exists x1.
  intuition.
  apply intsec_and.
  apply H5.
Qed.

End Connectedness.