import tactic pal.basics pal.dynamic

namespace pal_logic

def pal_reduce1 {α agent : Type} (ϕ : sentence α agent) :
  sentence α agent → sentence α agent
| ⟦p⟧      := ϕ ↣ ⟦p⟧
| ⊥       := ϕ ↣ ⊥
| (ψ ↣ γ) := (pal_reduce1 ψ) ↣ (pal_reduce1 γ)
| □(i:ψ)   := ϕ ↣ □(i : (pal_reduce1 ψ))
| [!ψ]γ    := ⊥

def pal_reduce {α agent : Type} :
  sentence α agent → sentence α agent
| ⟦p⟧      := ⟦p⟧
| ⊥       := ⊥
| (ψ ↣ γ) := (pal_reduce ψ) ↣ (pal_reduce γ)
| □(i:ψ)   := □(i : pal_reduce ψ)
| [!ψ]γ    := pal_reduce1 (pal_reduce ψ) (pal_reduce γ)

lemma reduction1_static {α agent : Type} (ϕ ψ : sentence α agent) :
    static ϕ → static ψ → static (pal_reduce1 ϕ ψ) :=
begin
  intros a₁ a₂,
  induction ψ,
  { unfold pal_reduce1, apply static.imply, assumption, assumption },
  { unfold pal_reduce1, apply static.imply, assumption, assumption },
  {
    unfold pal_reduce1 at *, cases a₂, apply static.imply,
    tauto, tauto
  },
  {
    unfold pal_reduce1 at *, cases a₂, apply static.imply,
    tauto, apply static.box, tauto
  },
  {
    unfold pal_reduce1 at *, apply static.perp
  }
end

lemma reduction1_sound {α agent : Type} (ϕ ψ : sentence α agent) :
    static ψ → ([!ϕ]ψ) ≡ pal_reduce1 ϕ ψ :=
begin
  intros st,
  induction ψ,
  { unfold pal_reduce1 sem_equiv, tauto },
  { unfold pal_reduce1 sem_equiv, tauto },
  {
    cases st,
    unfold pal_reduce1 sem_equiv at *,
    intros W M s, split,
    {
      intros a₁ a₂,
      apply (ψ_ih_a_1 st_a_1 W M s).mp,
      apply (recursion_imply ϕ ψ_a ψ_a_1 W M s).mp a₁,
      exact (ψ_ih_a st_a W M s).mpr a₂
    },
    {
      intros a₁,
      apply (recursion_imply ϕ ψ_a ψ_a_1 W M s).mpr,
      intros a₂,
      apply (ψ_ih_a_1 st_a_1 W M s).mpr,
      apply a₁,
      exact (ψ_ih_a st_a W M s).mp a₂
    }
  },
  {
    cases st,
    unfold pal_reduce1 sem_equiv at *,
    intros W M s, split,
    {
      intros a₁ a₂ t a₃,
      apply (ψ_ih st_a_1 W M t).mp,
      exact ((recursion_box ψ_a ϕ ψ_a_1 W M s).mp a₁ a₂ _ a₃)
    },
    {
      intros a₁,
      apply (recursion_box ψ_a ϕ ψ_a_1 W M s).mpr,
      intros a₂ t a₃,
      apply (ψ_ih st_a_1 W M t).mpr,
      exact a₁ a₂ t a₃
    }
  },
  { cases st }
end

lemma reduction_sound {α agent : Type} (ϕ : sentence α agent) :
    pal_reduce ϕ ≡ ϕ ∧ static (pal_reduce ϕ)  :=
begin
  induction ϕ,
  { split, unfold pal_reduce, apply static.atom },
  { split, unfold pal_reduce, apply static.perp },
  {
    unfold pal_reduce, cases ϕ_ih_a, cases ϕ_ih_a_1, split,
    { apply equiv_imply, assumption, assumption },
    { apply static.imply, assumption, assumption }
  },
  {
    unfold pal_reduce, cases ϕ_ih, split,
    { apply equiv_box, assumption },
    { apply static.box, assumption }
  },
  {
    unfold pal_reduce, cases ϕ_ih_a, cases ϕ_ih_a_1, split,
    {
      apply sem_equiv_trans,
      { apply sem_equiv_symm, apply reduction1_sound, assumption },
      { apply equiv_announce, assumption, assumption }
    },
    {
      apply reduction1_static,
      assumption, assumption
    }
  }
end

end pal_logic


/-
Copyright (c) 2022 Matthias Uschold. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Matthias Uschold.
-/

import .aux_lemmas_iso_range
import .quotient
import topology.continuous_function.bounded
import topology.continuous_function.basic

/-!
# Subgroups of Amenable groups

In this file, we prove that subgroups of amenable groups are again amenable

## Main Statements
- `amenable_of_subgroup`  : Subgroups of amenable Groups are amenable.
- `amenable_of_subgroup'` : alternative formulation for injective group homomorphisms

## Notations

We use the local notation `rrel` for the relation
defined by the right cosets of a subgroup H of G.

## References
* <https://en.wikipedia.org/wiki/Amenable_group>
* [C. Löh, *Geometric Group Theory*, Proposition 9.1.6 (1)][loeh17]
* [A.L.T. Paterson, *Amenability*, Proposition 0.16 (1)][Paterson1988]

## Tags
subgroup, inclusion, amenable, amenability
-/

open classical
open function

variables
{G:Type*}
[group G]
(H: subgroup G)

namespace amenable_subgroup

/-The right relation -/
local notation `rrel` := (quotient_group.right_rel H)

/--Choose one representative for each right coset-/
noncomputable def choose_rep
  : G → G
:=   (@quotient.out' G rrel) ∘ (@quotient.mk' G rrel)

lemma choos_rep_rel'
  {h :H} {g : G}
  : g*(h*g)⁻¹ ∈ H
:= by simp

/--related elements have the same image under choose_rep-/
lemma choose_rep_rel
  {h :H} {g : G}
  : choose_rep H (h*g) = choose_rep H g
:= begin
  unfold choose_rep,
  have : @quotient.mk' _ rrel (h*g)
      = @quotient.mk' _ rrel g,
  {
    have : (@setoid.r _ rrel) (h*g) g,
    {
      rw quotient_group.right_rel_apply,
      by simp,
    },
    exact quotient.eq'.mpr this,
  },
  by finish,
end

open setoid

lemma choose_rep_prop'
  (g:G)
  : (@setoid.r _ rrel) (@choose_rep G _ H g) g
:= begin
  have : (@quotient.mk' G rrel) (@choose_rep G _ H g) = (@quotient.mk' G rrel) g,
  {
    dsimp[choose_rep],
    simp,
    exact quotient.eq'.mp rfl,
  },
  exact quotient.eq'.mp this,
end

/-- Every element can be translated to its representative-/
lemma choose_rep_prop
  (g:G)
  : ∃(h:H), (h:G) * (choose_rep H g) = g
:= begin
  have : (@setoid.r _ rrel) (@choose_rep G _ H g) g
      := choose_rep_prop' H g,
  rw quotient_group.right_rel_apply at this,
  let h : H := ⟨g*(@choose_rep G _ H g)⁻¹, this⟩,
  use h,
  dsimp[h],
  by group,
end

/-- choose an element of H (the one we have to translate by to obtain
the representative)-/
noncomputable def choose_repH
  : G → H
:= (λ g, classical.some (choose_rep_prop H g))

lemma choose_repH_prop
  {g:G}
  : (choose_repH H g :G) * (choose_rep H g) = g
:= classical.some_spec (choose_rep_prop H g)

lemma choose_repH_lin
  (h :H) (g : G)
  : choose_repH H (h*g) = h*(choose_repH H g)
:= begin
  have : (choose_repH H (h*g) :G) * choose_rep H (h*g) = (h*(choose_repH H (g))) * choose_rep H (h*g),
  {
    calc  (choose_repH H (h*g) :G) * choose_rep H (h*g)
        = h*g
          : by exact choose_repH_prop H
    ... = h * ((choose_repH H g :G) * choose_rep H g)
          : by simp [choose_repH_prop]
    ... = (h * (choose_repH H g :G)) * choose_rep H g
          : by group
    ... = (h * (choose_repH H g :G)) * choose_rep H (h*g)
          : by simp[choose_rep_rel H],
  },
  -- Then, use uniqueness
  have eq_G: (choose_repH H (h*g):G) = (h*(choose_repH H g) :G)
        := (mul_left_inj (choose_rep H (↑h * g))).mp this,
  by exact subtype.ext eq_G,
end

open mean

/--We push forward the mean via the choose_repH-map-/
noncomputable def extend_mean
  (m : mean G)
  : mean H
:= mean_pushforward (choose_repH H) m

/--This mean is left-invariant.-/
lemma extend_inv_mean_inv
  (m : left_invariant_mean G)
  : ∀(h:H), ∀(f: bounded_continuous_function H ℝ),
      (extend_mean H m) (left_translate h f)
    = (extend_mean H m) f
:= begin
  assume h:H,
  assume  f: bounded_continuous_function H ℝ,
  -- left-translate commutes with pullback
  have pullb_left_transl
        : pull_bcont (choose_repH H) (left_translate h f)
        = left_translate h (pull_bcont (choose_repH H) f),
  {
    ext (x:G),
    calc    pull_bcont (choose_repH H) (left_translate h f) x
        = (left_translate h f) (choose_repH H x)
            : by tauto
    ... = f (h⁻¹ * (choose_repH H x))
            : by tauto
    ... = f (choose_repH H (h⁻¹*x))
            : by simp [(choose_repH_lin H h⁻¹ x).symm]
    ... = left_translate (h:G) (pull_bcont (choose_repH H) f) x
            : by tauto,
  },
  calc  (extend_mean H m) (left_translate h f)
      = m (pull_bcont (choose_repH H) (left_translate h f))
        : by tauto
  ... = m (left_translate h (pull_bcont (choose_repH H) f))
        : by rw pullb_left_transl
  ... = m (pull_bcont (choose_repH H) f)
        : by exact m.left_invariance _ _
  ... = (extend_mean H m) f
        : by tauto,
end

/--left-invariant mean for the subgroup-/
noncomputable def extend_inv_mean
  (m : left_invariant_mean G)
  : left_invariant_mean H
:= left_invariant_mean.mk (extend_mean H m) (extend_inv_mean_inv H m)

end amenable_subgroup

/--Subgroups of amenable groups are amenable-/
theorem amenable_of_subgroup
  (H : subgroup G)
  (G_am : amenable G)
  : amenable H
:= amenable_of_invmean (amenable_subgroup.extend_inv_mean H (invmean_of_amenable G_am))

/--Alternative formulation involving injective group homs-/
theorem amenable_of_subgroup'
  {H : Type*} [group H]
  {i : H →* G}
  (i_inj: injective i)
  (G_am : amenable G)
  : amenable H
:= begin
  have H_iso_range: H ≃* i.range
      := iso_range_of_injective i_inj,
  have i_range_am : amenable i.range
      := amenable_of_subgroup i.range G_am,
  exact amenable_of_iso H_iso_range.symm i_range_am,
end


import data.int.basic

lemma fact_le_of_add_one_le (q : ℤ) (m : ℤ) [h : fact (q + 1 ≤ m)] : fact (q ≤ m) :=
⟨(int.le_add_one le_rfl).trans h.out⟩

instance fact_two_pow_pos (N : ℕ) : fact (0 < 2 ^ N) :=
⟨pow_pos zero_lt_two _⟩


import data.real.basic
import .affine_coordinate_framed_space_update_lib
--import .real_affine_coordinate_space_lib

noncomputable theory

open aff_lib
--create R3 with an explicit standard frame.
--points and vectors expressed in standar frame
def R3 := aff_lib.affine_coord_space.mk_with_standard ℝ 3

--define one origin and 3 basis vectors in R3
def R3_pt1 := aff_lib.affine_coord_space.mk_point R3 ⟨[0,0,0], by refl⟩
def R3_vec1 := aff_lib.affine_coord_space.mk_vec R3 ⟨[1,0,0], by refl⟩
def R3_vec2 := aff_lib.affine_coord_space.mk_vec R3 ⟨[0,1,0], by refl⟩
def R3_vec3 := aff_lib.affine_coord_space.mk_vec R3 ⟨[0,0,1], by refl⟩

--get origin of R3 - which is the origin of the standard frame
def origin : _ := affine_coord_space.origin R3

#check origin

--get basis of R3 - basis of standard frame
def basis := affine_coord_space.basis R3

--test various torsor over vector space operations operations
#check origin
#check basis 1 -ᵥ basis 2 --expected : pass
#check basis 1 +ᵥ basis 2 --expected : pass
#check origin +ᵥ origin --expected : fail
#check origin -ᵥ origin --expected : pass
#check basis 1
#check basis 1 -ᵥ origin --expected : fail
#check origin -ᵥ basis 2 --expected : pass?
#check origin +ᵥ basis 2 --expected : pass

--create another, different set of vectors and a point in R3
def R3_pt1' := aff_lib.affine_coord_space.mk_point R3 ⟨[1,1,1], by refl⟩
def R3_vec1' := aff_lib.affine_coord_space.mk_vec R3 ⟨[2,0,0], by refl⟩
def R3_vec2' := aff_lib.affine_coord_space.mk_vec R3 ⟨[0,2,0], by refl⟩
def R3_vec3' := aff_lib.affine_coord_space.mk_vec R3 ⟨[0,0,2], by refl⟩

--create a derived frame using the point and set of vectors
def der_fr := affine_coord_space.mk_frame
    R3
    R3_pt1'
    (λ i : fin 3, vector.nth (⟨[R3_vec1', R3_vec3', R3_vec2'], sorry⟩ : vector _ 3) i)
    sorry

#check option

--create a new isomorphic space to R3 with standard frame, by equipping R3
--with a derived frame of the standard frame, yielding a new coordinate space
def der_sp :=
    affine_coord_space.mk_derived_from_coords R3 (affine_coord_frame.get_coords der_fr)

--get the origin and basis of the newly derived space which are the origin and
--basis of the derived frame
def der_origin := affine_coord_space.origin der_sp
def der_basis := affine_coord_space.basis der_sp

--test various torsor operations - different frames should not be added
--coordinatized vs. coordinate free
#check der_basis 1 +ᵥ basis 2
#check der_basis 2 +ᵥ der_basis 2
#check der_basis 1 -ᵥ basis 1
#check der_origin -ᵥ der_origin
#check der_origin -ᵥ origin

--get the base frame of R3 equipped with standard frame, which is the standard frame
def base_R3_fr := affine_coord_frame.base_frame
                    (affine_coord_space.frame R3)

--base frame of der_sp is the frame of (R3 equipped with standard frame)
def base_der_sp_fr := affine_coord_frame.base_frame
                    (affine_coord_space.frame der_sp)
--base space of std R3 is std R3 (equal up to computation)
def base_R3 := affine_coord_space.get_base_space R3

/-
R3 base space -> make derived space "der_sp" from derived frame
-> get base space OF der_sp, again R3
base_der_sp == R3
-/
def base_der_sp := affine_coord_space.get_base_space der_sp
--def base_der_sp_fr := affine_coord_space.frame base_der_sp
def R3_fr := affine_coord_space.frame R3

--tests show equivalent spaces and frames are equal up to computation
def base_vec := affine_coord_space.mk_vec base_der_sp ⟨[0,0,0], by refl⟩
lemma eqsp : R3 = base_der_sp := by refl
lemma eqs : R3_fr = base_der_sp_fr -- expected pass
    := by refl
lemma eqs : der_fr = base_der_sp_fr --expected fail
    := by refl
/-
base_vec ∈ base_der_sp.
basis 2 ∈ R3
however, R3 == base_der_sp
-/

#check (affine_coord_space.frame base_der_sp)
#check (affine_coord_space.frame R3)
lemma eqfr : (affine_coord_space.frame base_der_sp) = (affine_coord_space.frame R3) := by refl

-- issue here demonstrates that equal frames up to computation are not
-- necessarily equal values. this should be revisited.
def base_vec_R3 := affine_coord_space.mk_vec R3 ⟨[0,0,0], by refl⟩
#check has_vadd.vadd base_vec /-+ᵥ-/ base_vec_R3 -- expected: pass or no??
/-
none of the overloads are applicable
error for aff_fr.pt_plus_vec
type mismatch at application
  aff_fr.pt_plus_vec base_vec
term
-/
#check (affine_coord_space.frame base_der_sp)
--#reduce (affine_coord_space.frame base_der_sp)

def R3_pt1'' := aff_lib.affine_coord_space.mk_point R3 ⟨[1,-1,1], by refl⟩
def R3_vec1'' := aff_lib.affine_coord_space.mk_vec R3 ⟨[0,1,0], by refl⟩
def R3_vec2'' := aff_lib.affine_coord_space.mk_vec R3 ⟨[0,0,1], by refl⟩
def R3_vec3'' := aff_lib.affine_coord_space.mk_vec R3 ⟨[1,0,0], by refl⟩
--combine derived frame func into mk derived space

def other_der_fr := affine_coord_space.mk_frame
    R3
    R3_pt1''
    (λ i : fin 3, vector.nth (⟨[R3_vec1'', R3_vec3'', R3_vec2''], sorry⟩ : vector _ 3) i)
    sorry

def other_der_sp := affine_coord_space.mk_derived_from_coords R3 (affine_coord_frame.get_coords other_der_fr)

def der_to_other_der_path := affine_coord_space.find_transform_path
    der_sp other_der_sp

#check der_to_other_der_path.from_
#check der_to_other_der_path.to_

--create a "base space", R1 with a standard frame
def sp1 := aff_lib.affine_coord_space.mk_with_standard ℝ 1
--create a point and vector in that space to turn into a frame
def pt1' := aff_lib.affine_coord_space.mk_point sp1 ⟨[1], by refl⟩
def vec1' := aff_lib.affine_coord_space.mk_vec sp1 ⟨[2], by refl⟩
--create a derived frame using the point and set of vectors
def derived_fr := affine_coord_space.mk_frame
    sp1
    pt1'
    (affine_coord_space.mk_basis sp1 ⟨[vec1'], sorry⟩)
    sorry
--create a space equipped with a new frame
def derived_sp := affine_coord_space.mk_derived_from_coords
    sp1
    (affine_coord_frame.get_coords derived_fr)
--get the base space equipped with the base frame
--THIS IS THE SAME AS sp1
def base_sp  := affine_coord_space.get_base_space derived_sp

/-
Note that the class command, as discussed in Section 4.10, does more than simply assign
the attribute. There are attributes that control how eagerly definitions are unfolded
during elaboration:

[reducible] : unfold freely
[semireducible] : unfold when inexpensive (the default)
[irreducible] : do not unfold

Note:
def affine_coord_frame.base_frame
    {K : Type v}
    {n : ℕ}
    [inhabited K]
    [field K]
: affine_coord_frame K n → affine_coord_frame K n
| (affine_coord_frame.tuple base) := affine_coord_frame.standard K n
| (affine_coord_frame.derived _ _ _ fr) := fr

-/

-- example : base_sp = sp1 := eq.refl sp1

--make a point in this base space, WHICH IS THE SAME AS SP1
def base_vec1 := aff_lib.affine_coord_space.mk_vec base_sp ⟨[1], by refl⟩
--add to vectors together which are EXPLICITLY in sp1
#check vec1' +ᵥ vec1'
--add to vectors together which are expressed in the same frame
-- but frames do not pass dependent type check
-- ERROR : frames are not "equal equal", only "equal up to computation"
/-
error for has_vadd.vadd
failed to synthesize type class instance for
⊢ has_vadd (aff_fr.aff_coord_vec ℝ 1 (affine_coord_frame.standard ℝ 1))
    (aff_fr.aff_coord_vec ℝ 1
       (affine_coord_frame.base_frame
          (aff_fr.affine_coord_frame.derived (affine_coord_frame.get_coords derived_fr).origin
             (λ (i : fin 1), (affine_coord_frame.get_coords derived_fr).basis i)
             derived_sp._proof_1
-/
/-
frame #1 type == (affine_coord_frame.standard ℝ 1)

frame #2 type ==
(affine_coord_frame.base_frame
          (aff_fr.affine_coord_frame.derived
            (affine_coord_frame.get_coords derived_fr).origin
             (λ (i : fin 1), (affine_coord_frame.get_coords derived_fr).basis i)
             derived_sp._proof_1
             (affine_coord_frame.standard ℝ 1))
)
{b : frame}, E b : newframe
a : frame
b =/= a
E b = E a
-/

example :   (affine_coord_frame.standard ℝ 1) =
            (affine_coord_frame.base_frame
                (aff_fr.affine_coord_frame.derived
                (affine_coord_frame.get_coords derived_fr).origin
                (λ (i : fin 1), (affine_coord_frame.get_coords derived_fr).basis i)
                derived_sp._proof_1
                (affine_coord_frame.standard ℝ 1))) :=
            rfl

#check vec1' +ᵥ base_vec1
--correctly equal up to computation
#check (by refl :
            affine_coord_space.frame sp1 =
            affine_coord_space.frame base_sp)
-- ERROR : correctly NOT equal up to computation
#check (by refl :
            affine_coord_space.frame sp1 =
            affine_coord_space.frame derived_sp)

/-
RELEVANT TYPE DEFINITIONS:
SPACE, FRAME, POINT, VECTOR
variables
    (K : Type v)
    (n : ℕ)
    [inhabited K]
    [field K]
    --(fr : affine_tuple_coord_frame K n)
    (fr : affine_coord_frame K n)

def affine_coord_space :=
    affine_space_type
        (aff_coord_pt K n fr)
        K
        (aff_coord_vec K n fr)

structure affine_tuple_coord_frame
(K : Type w)
(n : ℕ)
[inhabited K]
[field K]  :=
mk ::
    (origin : aff_pt_coord_tuple K n)
    (basis : (fin n) → aff_vec_coord_tuple K n)
    (proof_is_basis : is_basis K basis)

inductive affine_coord_frame
(K : Type w)
(n : ℕ)
[inhabited K]
[field K]
| tuple (base : affine_tuple_coord_frame K n)
: affine_coord_frame
| derived
    (origin : aff_pt_coord_tuple K n)
    (basis : (fin n) → aff_vec_coord_tuple K n)
    (proof_is_basis : is_basis K basis)
(base : affine_coord_frame)
: affine_coord_frame

structure aff_coord_pt (fr : affine_coord_frame K n)
            extends aff_pt_coord_tuple K n :=
   mk ::
structure aff_coord_vec (fr : affine_coord_frame K n)
            extends aff_vec_coord_tuple K n  :=
   mk ::
-/


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.limits.preserves.basic
import Mathlib.PostPort

universes v u₁ u₂ l u₃

namespace Mathlib

namespace category_theory

/--
Define the lift of a cone: For a cone `c` for `K ⋙ F`, give a cone for `K`
which is a lift of `c`, i.e. the image of it under `F` is (iso) to `c`.

We will then use this as part of the definition of creation of limits:
every limit cone has a lift.

Note this definition is really only useful when `c` is a limit already.
-/
structure liftable_cone {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v} [small_category J] (K : J ⥤ C) (F : C ⥤ D) (c : limits.cone (K ⋙ F))
where
  lifted_cone : limits.cone K
  valid_lift : functor.map_cone F lifted_cone ≅ c

/--
Define the lift of a cocone: For a cocone `c` for `K ⋙ F`, give a cocone for
`K` which is a lift of `c`, i.e. the image of it under `F` is (iso) to `c`.

We will then use this as part of the definition of creation of colimits:
every limit cocone has a lift.

Note this definition is really only useful when `c` is a colimit already.
-/
structure liftable_cocone {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v} [small_category J] (K : J ⥤ C) (F : C ⥤ D) (c : limits.cocone (K ⋙ F))
where
  lifted_cocone : limits.cocone K
  valid_lift : functor.map_cocone F lifted_cocone ≅ c

/--
Definition 3.3.1 of [Riehl].
We say that `F` creates limits of `K` if, given any limit cone `c` for `K ⋙ F`
(i.e. below) we can lift it to a cone "above", and further that `F` reflects
limits for `K`.

If `F` reflects isomorphisms, it suffices to show only that the lifted cone is
a limit - see `creates_limit_of_reflects_iso`.
-/
class creates_limit {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v} [small_category J] (K : J ⥤ C) (F : C ⥤ D)
extends limits.reflects_limit K F
where
  lifts : (c : limits.cone (K ⋙ F)) → limits.is_limit c → liftable_cone K F c

/--
`F` creates limits of shape `J` if `F` creates the limit of any diagram
`K : J ⥤ C`.
-/
class creates_limits_of_shape {C : Type u₁} [category C] {D : Type u₂} [category D] (J : Type v) [small_category J] (F : C ⥤ D)
where
  creates_limit : {K : J ⥤ C} → creates_limit K F

/-- `F` creates limits if it creates limits of shape `J` for any small `J`. -/
class creates_limits {C : Type u₁} [category C] {D : Type u₂} [category D] (F : C ⥤ D)
where
  creates_limits_of_shape : {J : Type v} → {𝒥 : small_category J} → creates_limits_of_shape J F

/--
Dual of definition 3.3.1 of [Riehl].
We say that `F` creates colimits of `K` if, given any limit cocone `c` for
`K ⋙ F` (i.e. below) we can lift it to a cocone "above", and further that `F`
reflects limits for `K`.

If `F` reflects isomorphisms, it suffices to show only that the lifted cocone is
a limit - see `creates_limit_of_reflects_iso`.
-/
class creates_colimit {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v} [small_category J] (K : J ⥤ C) (F : C ⥤ D)
extends limits.reflects_colimit K F
where
  lifts : (c : limits.cocone (K ⋙ F)) → limits.is_colimit c → liftable_cocone K F c

/--
`F` creates colimits of shape `J` if `F` creates the colimit of any diagram
`K : J ⥤ C`.
-/
class creates_colimits_of_shape {C : Type u₁} [category C] {D : Type u₂} [category D] (J : Type v) [small_category J] (F : C ⥤ D)
where
  creates_colimit : {K : J ⥤ C} → creates_colimit K F

/-- `F` creates colimits if it creates colimits of shape `J` for any small `J`. -/
class creates_colimits {C : Type u₁} [category C] {D : Type u₂} [category D] (F : C ⥤ D)
where
  creates_colimits_of_shape : {J : Type v} → {𝒥 : small_category J} → creates_colimits_of_shape J F

/- Interface to the `creates_limit` class. -/

/-- `lift_limit t` is the cone for `K` given by lifting the limit `t` for `K ⋙ F`. -/
def lift_limit {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v} [small_category J] {K : J ⥤ C} {F : C ⥤ D} [creates_limit K F] {c : limits.cone (K ⋙ F)} (t : limits.is_limit c) : limits.cone K :=
  liftable_cone.lifted_cone (creates_limit.lifts c t)

/-- The lifted cone has an image isomorphic to the original cone. -/
def lifted_limit_maps_to_original {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v} [small_category J] {K : J ⥤ C} {F : C ⥤ D} [creates_limit K F] {c : limits.cone (K ⋙ F)} (t : limits.is_limit c) : functor.map_cone F (lift_limit t) ≅ c :=
  liftable_cone.valid_lift (creates_limit.lifts c t)

/-- The lifted cone is a limit. -/
def lifted_limit_is_limit {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v} [small_category J] {K : J ⥤ C} {F : C ⥤ D} [creates_limit K F] {c : limits.cone (K ⋙ F)} (t : limits.is_limit c) : limits.is_limit (lift_limit t) :=
  limits.reflects_limit.reflects (limits.is_limit.of_iso_limit t (iso.symm (lifted_limit_maps_to_original t)))

/-- If `F` creates the limit of `K` and `K ⋙ F` has a limit, then `K` has a limit. -/
theorem has_limit_of_created {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v} [small_category J] (K : J ⥤ C) (F : C ⥤ D) [limits.has_limit (K ⋙ F)] [creates_limit K F] : limits.has_limit K :=
  limits.has_limit.mk
    (limits.limit_cone.mk (lift_limit (limits.limit.is_limit (K ⋙ F)))
      (lifted_limit_is_limit (limits.limit.is_limit (K ⋙ F))))

/--
If `F` creates limits of shape `J`, and `D` has limits of shape `J`, then
`C` has limits of shape `J`.
-/
theorem has_limits_of_shape_of_has_limits_of_shape_creates_limits_of_shape {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v} [small_category J] (F : C ⥤ D) [limits.has_limits_of_shape J D] [creates_limits_of_shape J F] : limits.has_limits_of_shape J C :=
  limits.has_limits_of_shape.mk fun (G : J ⥤ C) => has_limit_of_created G F

/-- If `F` creates limits, and `D` has all limits, then `C` has all limits. -/
theorem has_limits_of_has_limits_creates_limits {C : Type u₁} [category C] {D : Type u₂} [category D] (F : C ⥤ D) [limits.has_limits D] [creates_limits F] : limits.has_limits C :=
  limits.has_limits.mk
    fun (J : Type v) (I : small_category J) => has_limits_of_shape_of_has_limits_of_shape_creates_limits_of_shape F

/- Interface to the `creates_colimit` class. -/

/-- `lift_colimit t` is the cocone for `K` given by lifting the colimit `t` for `K ⋙ F`. -/
def lift_colimit {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v} [small_category J] {K : J ⥤ C} {F : C ⥤ D} [creates_colimit K F] {c : limits.cocone (K ⋙ F)} (t : limits.is_colimit c) : limits.cocone K :=
  liftable_cocone.lifted_cocone (creates_colimit.lifts c t)

/-- The lifted cocone has an image isomorphic to the original cocone. -/
def lifted_colimit_maps_to_original {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v} [small_category J] {K : J ⥤ C} {F : C ⥤ D} [creates_colimit K F] {c : limits.cocone (K ⋙ F)} (t : limits.is_colimit c) : functor.map_cocone F (lift_colimit t) ≅ c :=
  liftable_cocone.valid_lift (creates_colimit.lifts c t)

/-- The lifted cocone is a colimit. -/
def lifted_colimit_is_colimit {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v} [small_category J] {K : J ⥤ C} {F : C ⥤ D} [creates_colimit K F] {c : limits.cocone (K ⋙ F)} (t : limits.is_colimit c) : limits.is_colimit (lift_colimit t) :=
  limits.reflects_colimit.reflects (limits.is_colimit.of_iso_colimit t (iso.symm (lifted_colimit_maps_to_original t)))

/-- If `F` creates the limit of `K` and `K ⋙ F` has a limit, then `K` has a limit. -/
theorem has_colimit_of_created {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v} [small_category J] (K : J ⥤ C) (F : C ⥤ D) [limits.has_colimit (K ⋙ F)] [creates_colimit K F] : limits.has_colimit K :=
  limits.has_colimit.mk
    (limits.colimit_cocone.mk (lift_colimit (limits.colimit.is_colimit (K ⋙ F)))
      (lifted_colimit_is_colimit (limits.colimit.is_colimit (K ⋙ F))))

/--
If `F` creates colimits of shape `J`, and `D` has colimits of shape `J`, then
`C` has colimits of shape `J`.
-/
theorem has_colimits_of_shape_of_has_colimits_of_shape_creates_colimits_of_shape {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v} [small_category J] (F : C ⥤ D) [limits.has_colimits_of_shape J D] [creates_colimits_of_shape J F] : limits.has_colimits_of_shape J C :=
  limits.has_colimits_of_shape.mk fun (G : J ⥤ C) => has_colimit_of_created G F

/-- If `F` creates colimits, and `D` has all colimits, then `C` has all colimits. -/
theorem has_colimits_of_has_colimits_creates_colimits {C : Type u₁} [category C] {D : Type u₂} [category D] (F : C ⥤ D) [limits.has_colimits D] [creates_colimits F] : limits.has_colimits C :=
  limits.has_colimits.mk
    fun (J : Type v) (I : small_category J) => has_colimits_of_shape_of_has_colimits_of_shape_creates_colimits_of_shape F

/--
A helper to show a functor creates limits. In particular, if we can show
that for any limit cone `c` for `K ⋙ F`, there is a lift of it which is
a limit and `F` reflects isomorphisms, then `F` creates limits.
Usually, `F` creating limits says that _any_ lift of `c` is a limit, but
here we only need to show that our particular lift of `c` is a limit.
-/
structure lifts_to_limit {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v} [small_category J] (K : J ⥤ C) (F : C ⥤ D) (c : limits.cone (K ⋙ F)) (t : limits.is_limit c)
extends liftable_cone K F c
where
  makes_limit : limits.is_limit (liftable_cone.lifted_cone _to_liftable_cone)

/--
A helper to show a functor creates colimits. In particular, if we can show
that for any limit cocone `c` for `K ⋙ F`, there is a lift of it which is
a limit and `F` reflects isomorphisms, then `F` creates colimits.
Usually, `F` creating colimits says that _any_ lift of `c` is a colimit, but
here we only need to show that our particular lift of `c` is a colimit.
-/
structure lifts_to_colimit {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v} [small_category J] (K : J ⥤ C) (F : C ⥤ D) (c : limits.cocone (K ⋙ F)) (t : limits.is_colimit c)
extends liftable_cocone K F c
where
  makes_colimit : limits.is_colimit (liftable_cocone.lifted_cocone _to_liftable_cocone)

/--
If `F` reflects isomorphisms and we can lift any limit cone to a limit cone,
then `F` creates limits.
In particular here we don't need to assume that F reflects limits.
-/
def creates_limit_of_reflects_iso {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v} [small_category J] {K : J ⥤ C} {F : C ⥤ D} [reflects_isomorphisms F] (h : (c : limits.cone (K ⋙ F)) → (t : limits.is_limit c) → lifts_to_limit K F c t) : creates_limit K F :=
  creates_limit.mk fun (c : limits.cone (K ⋙ F)) (t : limits.is_limit c) => lifts_to_limit.to_liftable_cone (h c t)

/--
When `F` is fully faithful, and `has_limit (K ⋙ F)`, to show that `F` creates the limit for `K`
it suffices to exhibit a lift of the chosen limit cone for `K ⋙ F`.
-/
-- Notice however that even if the isomorphism is `iso.refl _`,

-- this construction will insert additional identity morphisms in the cone maps,

-- so the constructed limits may not be ideal, definitionally.

def creates_limit_of_fully_faithful_of_lift {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v} [small_category J] {K : J ⥤ C} {F : C ⥤ D} [full F] [faithful F] [limits.has_limit (K ⋙ F)] (c : limits.cone K) (i : functor.map_cone F c ≅ limits.limit.cone (K ⋙ F)) : creates_limit K F :=
  creates_limit_of_reflects_iso
    fun (c' : limits.cone (K ⋙ F)) (t : limits.is_limit c') =>
      lifts_to_limit.mk (liftable_cone.mk c (i ≪≫ limits.is_limit.unique_up_to_iso (limits.limit.is_limit (K ⋙ F)) t))
        (limits.is_limit.of_faithful F (limits.is_limit.of_iso_limit (limits.limit.is_limit (K ⋙ F)) (iso.symm i))
          (fun (s : limits.cone K) =>
            functor.preimage F
              (limits.is_limit.lift (limits.is_limit.of_iso_limit (limits.limit.is_limit (K ⋙ F)) (iso.symm i))
                (functor.map_cone F s)))
          sorry)

/--
When `F` is fully faithful, and `has_limit (K ⋙ F)`, to show that `F` creates the limit for `K`
it suffices to show that the chosen limit point is in the essential image of `F`.
-/
-- Notice however that even if the isomorphism is `iso.refl _`,

-- this construction will insert additional identity morphisms in the cone maps,

-- so the constructed limits may not be ideal, definitionally.

def creates_limit_of_fully_faithful_of_iso {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v} [small_category J] {K : J ⥤ C} {F : C ⥤ D} [full F] [faithful F] [limits.has_limit (K ⋙ F)] (X : C) (i : functor.obj F X ≅ limits.limit (K ⋙ F)) : creates_limit K F :=
  creates_limit_of_fully_faithful_of_lift
    (limits.cone.mk X (nat_trans.mk fun (j : J) => functor.preimage F (iso.hom i ≫ limits.limit.π (K ⋙ F) j)))
    (limits.cones.ext i sorry)

/-- `F` preserves the limit of `K` if it creates the limit and `K ⋙ F` has the limit. -/
protected instance preserves_limit_of_creates_limit_and_has_limit {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v} [small_category J] (K : J ⥤ C) (F : C ⥤ D) [creates_limit K F] [limits.has_limit (K ⋙ F)] : limits.preserves_limit K F :=
  limits.preserves_limit.mk
    fun (c : limits.cone K) (t : limits.is_limit c) =>
      limits.is_limit.of_iso_limit (limits.limit.is_limit (K ⋙ F))
        (iso.symm (lifted_limit_maps_to_original (limits.limit.is_limit (K ⋙ F))) ≪≫
          functor.map_iso (limits.cones.functoriality K F)
            (limits.is_limit.unique_up_to_iso (lifted_limit_is_limit (limits.limit.is_limit (K ⋙ F))) t))

/-- `F` preserves the limit of shape `J` if it creates these limits and `D` has them. -/
protected instance preserves_limit_of_shape_of_creates_limits_of_shape_and_has_limits_of_shape {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v} [small_category J] (F : C ⥤ D) [creates_limits_of_shape J F] [limits.has_limits_of_shape J D] : limits.preserves_limits_of_shape J F :=
  limits.preserves_limits_of_shape.mk
    fun (K : J ⥤ C) => category_theory.preserves_limit_of_creates_limit_and_has_limit K F

/-- `F` preserves limits if it creates limits and `D` has limits. -/
protected instance preserves_limits_of_creates_limits_and_has_limits {C : Type u₁} [category C] {D : Type u₂} [category D] (F : C ⥤ D) [creates_limits F] [limits.has_limits D] : limits.preserves_limits F :=
  limits.preserves_limits.mk
    fun (J : Type v) (𝒥 : small_category J) =>
      category_theory.preserves_limit_of_shape_of_creates_limits_of_shape_and_has_limits_of_shape F

/--
If `F` reflects isomorphisms and we can lift any limit cocone to a limit cocone,
then `F` creates colimits.
In particular here we don't need to assume that F reflects colimits.
-/
def creates_colimit_of_reflects_iso {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v} [small_category J] {K : J ⥤ C} {F : C ⥤ D} [reflects_isomorphisms F] (h : (c : limits.cocone (K ⋙ F)) → (t : limits.is_colimit c) → lifts_to_colimit K F c t) : creates_colimit K F :=
  creates_colimit.mk
    fun (c : limits.cocone (K ⋙ F)) (t : limits.is_colimit c) => lifts_to_colimit.to_liftable_cocone (h c t)

/-- `F` preserves the colimit of `K` if it creates the colimit and `K ⋙ F` has the colimit. -/
protected instance preserves_colimit_of_creates_colimit_and_has_colimit {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v} [small_category J] (K : J ⥤ C) (F : C ⥤ D) [creates_colimit K F] [limits.has_colimit (K ⋙ F)] : limits.preserves_colimit K F :=
  limits.preserves_colimit.mk
    fun (c : limits.cocone K) (t : limits.is_colimit c) =>
      limits.is_colimit.of_iso_colimit (limits.colimit.is_colimit (K ⋙ F))
        (iso.symm (lifted_colimit_maps_to_original (limits.colimit.is_colimit (K ⋙ F))) ≪≫
          functor.map_iso (limits.cocones.functoriality K F)
            (limits.is_colimit.unique_up_to_iso (lifted_colimit_is_colimit (limits.colimit.is_colimit (K ⋙ F))) t))

/-- `F` preserves the colimit of shape `J` if it creates these colimits and `D` has them. -/
protected instance preserves_colimit_of_shape_of_creates_colimits_of_shape_and_has_colimits_of_shape {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v} [small_category J] (F : C ⥤ D) [creates_colimits_of_shape J F] [limits.has_colimits_of_shape J D] : limits.preserves_colimits_of_shape J F :=
  limits.preserves_colimits_of_shape.mk
    fun (K : J ⥤ C) => category_theory.preserves_colimit_of_creates_colimit_and_has_colimit K F

/-- `F` preserves limits if it creates limits and `D` has limits. -/
protected instance preserves_colimits_of_creates_colimits_and_has_colimits {C : Type u₁} [category C] {D : Type u₂} [category D] (F : C ⥤ D) [creates_colimits F] [limits.has_colimits D] : limits.preserves_colimits F :=
  limits.preserves_colimits.mk
    fun (J : Type v) (𝒥 : small_category J) =>
      category_theory.preserves_colimit_of_shape_of_creates_colimits_of_shape_and_has_colimits_of_shape F

/-- If `F` creates the limit of `K` and `F ≅ G`, then `G` creates the limit of `K`. -/
def creates_limit_of_nat_iso {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v} [small_category J] {K : J ⥤ C} {F : C ⥤ D} {G : C ⥤ D} (h : F ≅ G) [creates_limit K F] : creates_limit K G :=
  creates_limit.mk
    fun (c : limits.cone (K ⋙ G)) (t : limits.is_limit c) =>
      liftable_cone.mk
        (lift_limit (coe_fn (equiv.symm (limits.is_limit.postcompose_inv_equiv (iso_whisker_left K h) c)) t))
        (limits.is_limit.unique_up_to_iso
          (limits.is_limit.map_cone_equiv h
            (limits.is_limit.of_iso_limit
              (coe_fn (equiv.symm (limits.is_limit.postcompose_inv_equiv (iso_whisker_left K h) c)) t)
              (iso.symm
                (lifted_limit_maps_to_original
                  (coe_fn (equiv.symm (limits.is_limit.postcompose_inv_equiv (iso_whisker_left K h) c)) t)))))
          t)

/-- If `F` creates limits of shape `J` and `F ≅ G`, then `G` creates limits of shape `J`. -/
def creates_limits_of_shape_of_nat_iso {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v} [small_category J] {F : C ⥤ D} {G : C ⥤ D} (h : F ≅ G) [creates_limits_of_shape J F] : creates_limits_of_shape J G :=
  creates_limits_of_shape.mk fun (K : J ⥤ C) => creates_limit_of_nat_iso h

/-- If `F` creates limits and `F ≅ G`, then `G` creates limits. -/
def creates_limits_of_nat_iso {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D} (h : F ≅ G) [creates_limits F] : creates_limits G :=
  creates_limits.mk fun (J : Type v) (𝒥₁ : small_category J) => creates_limits_of_shape_of_nat_iso h

/-- If `F` creates the colimit of `K` and `F ≅ G`, then `G` creates the colimit of `K`. -/
def creates_colimit_of_nat_iso {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v} [small_category J] {K : J ⥤ C} {F : C ⥤ D} {G : C ⥤ D} (h : F ≅ G) [creates_colimit K F] : creates_colimit K G :=
  creates_colimit.mk
    fun (c : limits.cocone (K ⋙ G)) (t : limits.is_colimit c) =>
      liftable_cocone.mk
        (lift_colimit (coe_fn (equiv.symm (limits.is_colimit.precompose_hom_equiv (iso_whisker_left K h) c)) t))
        (limits.is_colimit.unique_up_to_iso
          (limits.is_colimit.map_cocone_equiv h
            (limits.is_colimit.of_iso_colimit
              (coe_fn (equiv.symm (limits.is_colimit.precompose_hom_equiv (iso_whisker_left K h) c)) t)
              (iso.symm
                (lifted_colimit_maps_to_original
                  (coe_fn (equiv.symm (limits.is_colimit.precompose_hom_equiv (iso_whisker_left K h) c)) t)))))
          t)

/-- If `F` creates colimits of shape `J` and `F ≅ G`, then `G` creates colimits of shape `J`. -/
def creates_colimits_of_shape_of_nat_iso {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v} [small_category J] {F : C ⥤ D} {G : C ⥤ D} (h : F ≅ G) [creates_colimits_of_shape J F] : creates_colimits_of_shape J G :=
  creates_colimits_of_shape.mk fun (K : J ⥤ C) => creates_colimit_of_nat_iso h

/-- If `F` creates colimits and `F ≅ G`, then `G` creates colimits. -/
def creates_colimits_of_nat_iso {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D} (h : F ≅ G) [creates_colimits F] : creates_colimits G :=
  creates_colimits.mk fun (J : Type v) (𝒥₁ : small_category J) => creates_colimits_of_shape_of_nat_iso h

-- For the inhabited linter later.

/-- If F creates the limit of K, any cone lifts to a limit. -/
def lifts_to_limit_of_creates {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v} [small_category J] (K : J ⥤ C) (F : C ⥤ D) [creates_limit K F] (c : limits.cone (K ⋙ F)) (t : limits.is_limit c) : lifts_to_limit K F c t :=
  lifts_to_limit.mk (liftable_cone.mk (lift_limit t) (lifted_limit_maps_to_original t)) (lifted_limit_is_limit t)

-- For the inhabited linter later.

/-- If F creates the colimit of K, any cocone lifts to a colimit. -/
def lifts_to_colimit_of_creates {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v} [small_category J] (K : J ⥤ C) (F : C ⥤ D) [creates_colimit K F] (c : limits.cocone (K ⋙ F)) (t : limits.is_colimit c) : lifts_to_colimit K F c t :=
  lifts_to_colimit.mk (liftable_cocone.mk (lift_colimit t) (lifted_colimit_maps_to_original t))
    (lifted_colimit_is_colimit t)

/-- Any cone lifts through the identity functor. -/
def id_lifts_cone {C : Type u₁} [category C] {J : Type v} [small_category J] {K : J ⥤ C} (c : limits.cone (K ⋙ 𝟭)) : liftable_cone K 𝟭 c :=
  liftable_cone.mk (limits.cone.mk (limits.cone.X c) (limits.cone.π c ≫ iso.hom (functor.right_unitor K)))
    (limits.cones.ext
      (iso.refl
        (limits.cone.X
          (functor.map_cone 𝟭 (limits.cone.mk (limits.cone.X c) (limits.cone.π c ≫ iso.hom (functor.right_unitor K))))))
      sorry)

/-- The identity functor creates all limits. -/
protected instance id_creates_limits {C : Type u₁} [category C] : creates_limits 𝟭 :=
  creates_limits.mk
    fun (J : Type v) (𝒥 : small_category J) =>
      creates_limits_of_shape.mk
        fun (F : J ⥤ C) => creates_limit.mk fun (c : limits.cone (F ⋙ 𝟭)) (t : limits.is_limit c) => id_lifts_cone c

/-- Any cocone lifts through the identity functor. -/
def id_lifts_cocone {C : Type u₁} [category C] {J : Type v} [small_category J] {K : J ⥤ C} (c : limits.cocone (K ⋙ 𝟭)) : liftable_cocone K 𝟭 c :=
  liftable_cocone.mk (limits.cocone.mk (limits.cocone.X c) (iso.inv (functor.right_unitor K) ≫ limits.cocone.ι c))
    (limits.cocones.ext
      (iso.refl
        (limits.cocone.X
          (functor.map_cocone 𝟭
            (limits.cocone.mk (limits.cocone.X c) (iso.inv (functor.right_unitor K) ≫ limits.cocone.ι c)))))
      sorry)

/-- The identity functor creates all colimits. -/
protected instance id_creates_colimits {C : Type u₁} [category C] : creates_colimits 𝟭 :=
  creates_colimits.mk
    fun (J : Type v) (𝒥 : small_category J) =>
      creates_colimits_of_shape.mk
        fun (F : J ⥤ C) =>
          creates_colimit.mk fun (c : limits.cocone (F ⋙ 𝟭)) (t : limits.is_colimit c) => id_lifts_cocone c

/-- Satisfy the inhabited linter -/
protected instance inhabited_liftable_cone {C : Type u₁} [category C] {J : Type v} [small_category J] {K : J ⥤ C} (c : limits.cone (K ⋙ 𝟭)) : Inhabited (liftable_cone K 𝟭 c) :=
  { default := id_lifts_cone c }

protected instance inhabited_liftable_cocone {C : Type u₁} [category C] {J : Type v} [small_category J] {K : J ⥤ C} (c : limits.cocone (K ⋙ 𝟭)) : Inhabited (liftable_cocone K 𝟭 c) :=
  { default := id_lifts_cocone c }

/-- Satisfy the inhabited linter -/
protected instance inhabited_lifts_to_limit {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v} [small_category J] (K : J ⥤ C) (F : C ⥤ D) [creates_limit K F] (c : limits.cone (K ⋙ F)) (t : limits.is_limit c) : Inhabited (lifts_to_limit K F c t) :=
  { default := lifts_to_limit_of_creates K F c t }

protected instance inhabited_lifts_to_colimit {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v} [small_category J] (K : J ⥤ C) (F : C ⥤ D) [creates_colimit K F] (c : limits.cocone (K ⋙ F)) (t : limits.is_colimit c) : Inhabited (lifts_to_colimit K F c t) :=
  { default := lifts_to_colimit_of_creates K F c t }

protected instance comp_creates_limit {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v} [small_category J] {K : J ⥤ C} {E : Type u₃} [ℰ : category E] (F : C ⥤ D) (G : D ⥤ E) [creates_limit K F] [creates_limit (K ⋙ F) G] : creates_limit K (F ⋙ G) :=
  creates_limit.mk
    fun (c : limits.cone (K ⋙ F ⋙ G)) (t : limits.is_limit c) =>
      liftable_cone.mk (lift_limit (lifted_limit_is_limit t))
        (functor.map_iso (limits.cones.functoriality (K ⋙ F) G)
            (lifted_limit_maps_to_original (lifted_limit_is_limit t)) ≪≫
          lifted_limit_maps_to_original t)

protected instance comp_creates_limits_of_shape {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v} [small_category J] {E : Type u₃} [ℰ : category E] (F : C ⥤ D) (G : D ⥤ E) [creates_limits_of_shape J F] [creates_limits_of_shape J G] : creates_limits_of_shape J (F ⋙ G) :=
  creates_limits_of_shape.mk infer_instance

protected instance comp_creates_limits {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [ℰ : category E] (F : C ⥤ D) (G : D ⥤ E) [creates_limits F] [creates_limits G] : creates_limits (F ⋙ G) :=
  creates_limits.mk infer_instance

protected instance comp_creates_colimit {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v} [small_category J] {K : J ⥤ C} {E : Type u₃} [ℰ : category E] (F : C ⥤ D) (G : D ⥤ E) [creates_colimit K F] [creates_colimit (K ⋙ F) G] : creates_colimit K (F ⋙ G) :=
  creates_colimit.mk
    fun (c : limits.cocone (K ⋙ F ⋙ G)) (t : limits.is_colimit c) =>
      liftable_cocone.mk (lift_colimit (lifted_colimit_is_colimit t))
        (functor.map_iso (limits.cocones.functoriality (K ⋙ F) G)
            (lifted_colimit_maps_to_original (lifted_colimit_is_colimit t)) ≪≫
          lifted_colimit_maps_to_original t)

protected instance comp_creates_colimits_of_shape {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v} [small_category J] {E : Type u₃} [ℰ : category E] (F : C ⥤ D) (G : D ⥤ E) [creates_colimits_of_shape J F] [creates_colimits_of_shape J G] : creates_colimits_of_shape J (F ⋙ G) :=
  creates_colimits_of_shape.mk infer_instance

protected instance comp_creates_colimits {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [ℰ : category E] (F : C ⥤ D) (G : D ⥤ E) [creates_colimits F] [creates_colimits G] : creates_colimits (F ⋙ G) :=
  creates_colimits.mk infer_instance


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Bhavik Mehta
-/
import category_theory.adjunction.reflective
import category_theory.monad.algebra

/-!
# Adjunctions and monads

We develop the basic relationship between adjunctions and monads.

Given an adjunction `h : L ⊣ R`, we have `h.to_monad : monad C` and `h.to_comonad : comonad D`.
We then have
`monad.comparison (h : L ⊣ R) : D ⥤ h.to_monad.algebra`
sending `Y : D` to the Eilenberg-Moore algebra for `L ⋙ R` with underlying object `R.obj X`,
and dually `comonad.comparison`.

We say `R : D ⥤ C` is `monadic_right_adjoint`, if it is a right adjoint and its `monad.comparison`
is an equivalence of categories. (Similarly for `monadic_left_adjoint`.)

Finally we prove that reflective functors are `monadic_right_adjoint`.
-/

namespace category_theory
open category

universes v₁ v₂ u₁ u₂ -- morphism levels before object levels. See note [category_theory universes].

variables {C : Type u₁} [category.{v₁} C] {D : Type u₂} [category.{v₂} D]
variables {L : C ⥤ D} {R : D ⥤ C}

namespace adjunction

/--
For a pair of functors `L : C ⥤ D`, `R : D ⥤ C`, an adjunction `h : L ⊣ R` induces a monad on
the category `C`.
-/
@[simps]
def to_monad (h : L ⊣ R) : monad C :=
{ to_functor := L ⋙ R,
  η' := h.unit,
  μ' := whisker_right (whisker_left L h.counit) R,
  assoc' := λ X, by { dsimp, rw [←R.map_comp], simp },
  right_unit' := λ X, by { dsimp, rw [←R.map_comp], simp } }

/--
For a pair of functors `L : C ⥤ D`, `R : D ⥤ C`, an adjunction `h : L ⊣ R` induces a comonad on
the category `D`.
-/
@[simps]
def to_comonad (h : L ⊣ R) : comonad D :=
{ to_functor := R ⋙ L,
  ε' := h.counit,
  δ' := whisker_right (whisker_left R h.unit) L,
  coassoc' := λ X, by { dsimp, rw ← L.map_comp, simp },
  right_counit' := λ X, by { dsimp, rw ← L.map_comp, simp } }

/-- The monad induced by the Eilenberg-Moore adjunction is the original monad.  -/
@[simps]
def adj_to_monad_iso (T : monad C) : T.adj.to_monad ≅ T :=
monad_iso.mk (nat_iso.of_components (λ X, iso.refl _) (by tidy))
  (λ X, by { dsimp, simp })
  (λ X, by { dsimp, simp })

/-- The comonad induced by the Eilenberg-Moore adjunction is the original comonad. -/
@[simps]
def adj_to_comonad_iso (G : comonad C) : G.adj.to_comonad ≅ G :=
comonad_iso.mk (nat_iso.of_components (λ X, iso.refl _) (by tidy))
  (λ X, by { dsimp, simp })
  (λ X, by { dsimp, simp })

end adjunction

/--
Gven any adjunction `L ⊣ R`, there is a comparison functor `category_theory.monad.comparison R`
sending objects `Y : D` to Eilenberg-Moore algebras for `L ⋙ R` with underlying object `R.obj X`.

We later show that this is full when `R` is full, faithful when `R` is faithful,
and essentially surjective when `R` is reflective.
-/
@[simps]
def monad.comparison (h : L ⊣ R) : D ⥤ h.to_monad.algebra :=
{ obj := λ X,
  { A := R.obj X,
    a := R.map (h.counit.app X),
    assoc' := by { dsimp, rw [← R.map_comp, ← adjunction.counit_naturality, R.map_comp], refl } },
  map := λ X Y f,
  { f := R.map f,
    h' := by { dsimp, rw [← R.map_comp, adjunction.counit_naturality, R.map_comp] } } }.

/--
The underlying object of `(monad.comparison R).obj X` is just `R.obj X`.
-/
@[simps]
def monad.comparison_forget (h : L ⊣ R) :
  monad.comparison h ⋙ h.to_monad.forget ≅ R :=
{ hom := { app := λ X, 𝟙 _, },
  inv := { app := λ X, 𝟙 _, } }

lemma monad.left_comparison (h : L ⊣ R) : L ⋙ monad.comparison h = h.to_monad.free := rfl

instance [faithful R] (h : L ⊣ R) :
  faithful (monad.comparison h) :=
{ map_injective' := λ X Y f g w, R.map_injective (congr_arg monad.algebra.hom.f w : _) }

instance (T : monad C) : full (monad.comparison T.adj) :=
{ preimage := λ X Y f, ⟨f.f, by simpa using f.h⟩ }

instance (T : monad C) : ess_surj (monad.comparison T.adj) :=
{ mem_ess_image := λ X,
  ⟨{ A := X.A, a := X.a, unit' := by simpa using X.unit, assoc' := by simpa using X.assoc },
    ⟨monad.algebra.iso_mk (iso.refl _) (by simp)⟩⟩ }

/--
Gven any adjunction `L ⊣ R`, there is a comparison functor `category_theory.comonad.comparison L`
sending objects `X : C` to Eilenberg-Moore coalgebras for `L ⋙ R` with underlying object
`L.obj X`.
-/
@[simps]
def comonad.comparison (h : L ⊣ R) : C ⥤ h.to_comonad.coalgebra :=
{ obj := λ X,
  { A := L.obj X,
    a := L.map (h.unit.app X),
    coassoc' := by { dsimp, rw [← L.map_comp, ← adjunction.unit_naturality, L.map_comp], refl } },
  map := λ X Y f,
  { f := L.map f,
    h' := by { dsimp, rw ← L.map_comp, simp } } }

/--
The underlying object of `(comonad.comparison L).obj X` is just `L.obj X`.
-/
@[simps]
def comonad.comparison_forget {L : C ⥤ D} {R : D ⥤ C} (h : L ⊣ R) :
  comonad.comparison h ⋙ h.to_comonad.forget ≅ L :=
{ hom := { app := λ X, 𝟙 _, },
  inv := { app := λ X, 𝟙 _, } }

lemma comonad.left_comparison (h : L ⊣ R) : R ⋙ comonad.comparison h = h.to_comonad.cofree := rfl

instance comonad.comparison_faithful_of_faithful [faithful L] (h : L ⊣ R) :
  faithful (comonad.comparison h) :=
{ map_injective' := λ X Y f g w, L.map_injective (congr_arg comonad.coalgebra.hom.f w : _) }

instance (G : comonad C) : full (comonad.comparison G.adj) :=
{ preimage := λ X Y f, ⟨f.f, by simpa using f.h⟩ }

instance (G : comonad C) : ess_surj (comonad.comparison G.adj) :=
{ mem_ess_image := λ X,
  ⟨{ A := X.A, a := X.a, counit' := by simpa using X.counit, coassoc' := by simpa using X.coassoc },
    ⟨comonad.coalgebra.iso_mk (iso.refl _) (by simp)⟩⟩ }

/--
A right adjoint functor `R : D ⥤ C` is *monadic* if the comparison functor `monad.comparison R`
from `D` to the category of Eilenberg-Moore algebras for the adjunction is an equivalence.
-/
class monadic_right_adjoint (R : D ⥤ C) extends is_right_adjoint R :=
(eqv : is_equivalence (monad.comparison (adjunction.of_right_adjoint R)))

/--
A left adjoint functor `L : C ⥤ D` is *comonadic* if the comparison functor `comonad.comparison L`
from `C` to the category of Eilenberg-Moore algebras for the adjunction is an equivalence.
-/
class comonadic_left_adjoint (L : C ⥤ D) extends is_left_adjoint L :=
(eqv : is_equivalence (comonad.comparison (adjunction.of_left_adjoint L)))

noncomputable instance (T : monad C) : monadic_right_adjoint T.forget :=
⟨(equivalence.of_fully_faithfully_ess_surj _ : is_equivalence (monad.comparison T.adj))⟩

noncomputable instance (G : comonad C) : comonadic_left_adjoint G.forget :=
⟨(equivalence.of_fully_faithfully_ess_surj _ : is_equivalence (comonad.comparison G.adj))⟩

-- TODO: This holds more generally for idempotent adjunctions, not just reflective adjunctions.
instance μ_iso_of_reflective [reflective R] : is_iso (adjunction.of_right_adjoint R).to_monad.μ :=
by { dsimp, apply_instance }

attribute [instance] monadic_right_adjoint.eqv
attribute [instance] comonadic_left_adjoint.eqv

namespace reflective

instance [reflective R] (X : (adjunction.of_right_adjoint R).to_monad.algebra) :
  is_iso ((adjunction.of_right_adjoint R).unit.app X.A) :=
⟨⟨X.a, ⟨X.unit, begin
    dsimp only [functor.id_obj],
    rw ← (adjunction.of_right_adjoint R).unit_naturality,
    dsimp only [functor.comp_obj, adjunction.to_monad_coe],
    rw [unit_obj_eq_map_unit, ←functor.map_comp, ←functor.map_comp],
    erw X.unit,
    simp,
  end⟩⟩⟩

instance comparison_ess_surj [reflective R] :
  ess_surj (monad.comparison (adjunction.of_right_adjoint R)) :=
begin
  refine ⟨λ X, ⟨(left_adjoint R).obj X.A, ⟨_⟩⟩⟩,
  symmetry,
  refine monad.algebra.iso_mk _ _,
  { exact as_iso ((adjunction.of_right_adjoint R).unit.app X.A) },
  dsimp only [functor.comp_map, monad.comparison_obj_a, as_iso_hom, functor.comp_obj,
    monad.comparison_obj_A, monad_to_functor_eq_coe, adjunction.to_monad_coe],
  rw [←cancel_epi ((adjunction.of_right_adjoint R).unit.app X.A), adjunction.unit_naturality_assoc,
      adjunction.right_triangle_components, comp_id],
  apply (X.unit_assoc _).symm,
end

instance comparison_full [full R] [is_right_adjoint R] :
  full (monad.comparison (adjunction.of_right_adjoint R)) :=
{ preimage := λ X Y f, R.preimage f.f }

end reflective

-- It is possible to do this computably since the construction gives the data of the inverse, not
-- just the existence of an inverse on each object.
/-- Any reflective inclusion has a monadic right adjoint.
    cf Prop 5.3.3 of [Riehl][riehl2017] -/
@[priority 100] -- see Note [lower instance priority]
noncomputable instance monadic_of_reflective [reflective R] : monadic_right_adjoint R :=
{ eqv := equivalence.of_fully_faithfully_ess_surj _ }

end category_theory


/-
Copyright (c) 2020 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon, Patrick Massot, Yury Kudryashov
-/
import algebra.group.opposite
import algebra.group_with_zero.units.basic
import algebra.hom.units

/-!
# Monoid, group etc structures on `M × N`

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

In this file we define one-binop (`monoid`, `group` etc) structures on `M × N`. We also prove
trivial `simp` lemmas, and define the following operations on `monoid_hom`s:

* `fst M N : M × N →* M`, `snd M N : M × N →* N`: projections `prod.fst` and `prod.snd`
  as `monoid_hom`s;
* `inl M N : M →* M × N`, `inr M N : N →* M × N`: inclusions of first/second monoid
  into the product;
* `f.prod g : `M →* N × P`: sends `x` to `(f x, g x)`;
* `f.coprod g : M × N →* P`: sends `(x, y)` to `f x * g y`;
* `f.prod_map g : M × N → M' × N'`: `prod.map f g` as a `monoid_hom`,
  sends `(x, y)` to `(f x, g y)`.

## Main declarations

* `mul_mul_hom`/`mul_monoid_hom`/`mul_monoid_with_zero_hom`: Multiplication bundled as a
  multiplicative/monoid/monoid with zero homomorphism.
* `div_monoid_hom`/`div_monoid_with_zero_hom`: Division bundled as a monoid/monoid with zero
  homomorphism.
-/

variables {A : Type*} {B : Type*} {G : Type*} {H : Type*} {M : Type*} {N : Type*} {P : Type*}

namespace prod

@[to_additive]
instance [has_mul M] [has_mul N] : has_mul (M × N) := ⟨λ p q, ⟨p.1 * q.1, p.2 * q.2⟩⟩

@[simp, to_additive]
lemma fst_mul [has_mul M] [has_mul N] (p q : M × N) : (p * q).1 = p.1 * q.1 := rfl
@[simp, to_additive]
lemma snd_mul [has_mul M] [has_mul N] (p q : M × N) : (p * q).2 = p.2 * q.2 := rfl
@[simp, to_additive]
lemma mk_mul_mk [has_mul M] [has_mul N] (a₁ a₂ : M) (b₁ b₂ : N) :
  (a₁, b₁) * (a₂, b₂) = (a₁ * a₂, b₁ * b₂) := rfl
@[simp, to_additive]
lemma swap_mul [has_mul M] [has_mul N] (p q : M × N) : (p * q).swap = p.swap * q.swap := rfl
@[to_additive]
lemma mul_def [has_mul M] [has_mul N] (p q : M × N) : p * q = (p.1 * q.1, p.2 * q.2) := rfl

@[to_additive]
lemma one_mk_mul_one_mk [monoid M] [has_mul N] (b₁ b₂ : N) :
  ((1 : M), b₁) * (1, b₂) = (1, b₁ * b₂) :=
by rw [mk_mul_mk, mul_one]

@[to_additive]
lemma mk_one_mul_mk_one [has_mul M] [monoid N] (a₁ a₂ : M) :
  (a₁, (1 : N)) * (a₂, 1) = (a₁ * a₂, 1) :=
by rw [mk_mul_mk, mul_one]

@[to_additive]
instance [has_one M] [has_one N] : has_one (M × N) := ⟨(1, 1)⟩

@[simp, to_additive]
lemma fst_one [has_one M] [has_one N] : (1 : M × N).1 = 1 := rfl
@[simp, to_additive]
lemma snd_one [has_one M] [has_one N] : (1 : M × N).2 = 1 := rfl
@[to_additive]
lemma one_eq_mk [has_one M] [has_one N] : (1 : M × N) = (1, 1) := rfl
@[simp, to_additive]
lemma mk_eq_one [has_one M] [has_one N] {x : M} {y : N} : (x, y) = 1 ↔ x = 1 ∧ y = 1 :=
mk.inj_iff
@[simp, to_additive]
lemma swap_one [has_one M] [has_one N] : (1 : M × N).swap = 1 := rfl

@[to_additive]
lemma fst_mul_snd [mul_one_class M] [mul_one_class N] (p : M × N) :
  (p.fst, 1) * (1, p.snd) = p :=
ext (mul_one p.1) (one_mul p.2)

@[to_additive]
instance [has_inv M] [has_inv N] : has_inv (M × N) := ⟨λp, (p.1⁻¹, p.2⁻¹)⟩

@[simp, to_additive]
lemma fst_inv [has_inv G] [has_inv H] (p : G × H) : (p⁻¹).1 = (p.1)⁻¹ := rfl
@[simp, to_additive]
lemma snd_inv [has_inv G] [has_inv H] (p : G × H) : (p⁻¹).2 = (p.2)⁻¹ := rfl
@[simp, to_additive]
lemma inv_mk [has_inv G] [has_inv H] (a : G) (b : H) : (a, b)⁻¹ = (a⁻¹, b⁻¹) := rfl
@[simp, to_additive]
lemma swap_inv [has_inv G] [has_inv H] (p : G × H) : (p⁻¹).swap = p.swap⁻¹ := rfl

@[to_additive]
instance [has_involutive_inv M] [has_involutive_inv N] : has_involutive_inv (M × N) :=
{ inv_inv := λ a, ext (inv_inv _) (inv_inv _),
  ..prod.has_inv }

@[to_additive]
instance [has_div M] [has_div N] : has_div (M × N) := ⟨λ p q, ⟨p.1 / q.1, p.2 / q.2⟩⟩

@[simp, to_additive] lemma fst_div [has_div G] [has_div H] (a b : G × H) : (a / b).1 = a.1 / b.1 :=
rfl
@[simp, to_additive] lemma snd_div [has_div G] [has_div H] (a b : G × H) : (a / b).2 = a.2 / b.2 :=
rfl
@[simp, to_additive] lemma mk_div_mk [has_div G] [has_div H] (x₁ x₂ : G) (y₁ y₂ : H) :
  (x₁, y₁) / (x₂, y₂) = (x₁ / x₂, y₁ / y₂) := rfl
@[simp, to_additive] lemma swap_div [has_div G] [has_div H] (a b : G × H) :
  (a / b).swap = a.swap / b.swap := rfl

instance [mul_zero_class M] [mul_zero_class N] : mul_zero_class (M × N) :=
{ zero_mul := assume a, prod.rec_on a $ λa b, mk.inj_iff.mpr ⟨zero_mul _, zero_mul _⟩,
  mul_zero := assume a, prod.rec_on a $ λa b, mk.inj_iff.mpr ⟨mul_zero _, mul_zero _⟩,
  .. prod.has_zero, .. prod.has_mul }

@[to_additive]
instance [semigroup M] [semigroup N] : semigroup (M × N) :=
{ mul_assoc := assume a b c, mk.inj_iff.mpr ⟨mul_assoc _ _ _, mul_assoc _ _ _⟩,
  .. prod.has_mul }

@[to_additive]
instance [comm_semigroup G] [comm_semigroup H] : comm_semigroup (G × H) :=
{ mul_comm := assume a b, mk.inj_iff.mpr ⟨mul_comm _ _, mul_comm _ _⟩,
  .. prod.semigroup }

instance [semigroup_with_zero M] [semigroup_with_zero N] : semigroup_with_zero (M × N) :=
{ .. prod.mul_zero_class, .. prod.semigroup }

@[to_additive]
instance [mul_one_class M] [mul_one_class N] : mul_one_class (M × N) :=
{ one_mul := assume a, prod.rec_on a $ λa b, mk.inj_iff.mpr ⟨one_mul _, one_mul _⟩,
  mul_one := assume a, prod.rec_on a $ λa b, mk.inj_iff.mpr ⟨mul_one _, mul_one _⟩,
  .. prod.has_mul, .. prod.has_one }

@[to_additive]
instance [monoid M] [monoid N] : monoid (M × N) :=
{ npow := λ z a, ⟨monoid.npow z a.1, monoid.npow z a.2⟩,
  npow_zero' := λ z, ext (monoid.npow_zero' _) (monoid.npow_zero' _),
  npow_succ' := λ z a, ext (monoid.npow_succ' _ _) (monoid.npow_succ' _ _),
  .. prod.semigroup, .. prod.mul_one_class }

@[to_additive prod.sub_neg_monoid]
instance [div_inv_monoid G] [div_inv_monoid H] : div_inv_monoid (G × H) :=
{ div_eq_mul_inv := λ a b, mk.inj_iff.mpr ⟨div_eq_mul_inv _ _, div_eq_mul_inv _ _⟩,
  zpow := λ z a, ⟨div_inv_monoid.zpow z a.1, div_inv_monoid.zpow z a.2⟩,
  zpow_zero' := λ z, ext (div_inv_monoid.zpow_zero' _) (div_inv_monoid.zpow_zero' _),
  zpow_succ' := λ z a, ext (div_inv_monoid.zpow_succ' _ _) (div_inv_monoid.zpow_succ' _ _),
  zpow_neg' := λ z a, ext (div_inv_monoid.zpow_neg' _ _) (div_inv_monoid.zpow_neg' _ _),
  .. prod.monoid, .. prod.has_inv, .. prod.has_div }

@[to_additive]
instance [division_monoid G] [division_monoid H] : division_monoid (G × H) :=
{ mul_inv_rev := λ a b, ext (mul_inv_rev _ _) (mul_inv_rev _ _),
  inv_eq_of_mul := λ a b h, ext (inv_eq_of_mul_eq_one_right $ congr_arg fst h)
    (inv_eq_of_mul_eq_one_right $ congr_arg snd h),
  .. prod.div_inv_monoid, .. prod.has_involutive_inv }

@[to_additive subtraction_comm_monoid]
instance [division_comm_monoid G] [division_comm_monoid H] : division_comm_monoid (G × H) :=
{ .. prod.division_monoid, .. prod.comm_semigroup }

@[to_additive]
instance [group G] [group H] : group (G × H) :=
{ mul_left_inv := assume a, mk.inj_iff.mpr ⟨mul_left_inv _, mul_left_inv _⟩,
  .. prod.div_inv_monoid }

@[to_additive]
instance [left_cancel_semigroup G] [left_cancel_semigroup H] :
  left_cancel_semigroup (G × H) :=
{ mul_left_cancel := λ a b c h, prod.ext (mul_left_cancel (prod.ext_iff.1 h).1)
    (mul_left_cancel (prod.ext_iff.1 h).2),
  .. prod.semigroup }

@[to_additive]
instance [right_cancel_semigroup G] [right_cancel_semigroup H] :
  right_cancel_semigroup (G × H) :=
{ mul_right_cancel := λ a b c h, prod.ext (mul_right_cancel (prod.ext_iff.1 h).1)
    (mul_right_cancel (prod.ext_iff.1 h).2),
  .. prod.semigroup }

@[to_additive]
instance [left_cancel_monoid M] [left_cancel_monoid N] : left_cancel_monoid (M × N) :=
{ .. prod.left_cancel_semigroup, .. prod.monoid }

@[to_additive]
instance [right_cancel_monoid M] [right_cancel_monoid N] : right_cancel_monoid (M × N) :=
{ .. prod.right_cancel_semigroup, .. prod.monoid }

@[to_additive]
instance [cancel_monoid M] [cancel_monoid N] : cancel_monoid (M × N) :=
{ .. prod.right_cancel_monoid, .. prod.left_cancel_monoid }

@[to_additive]
instance [comm_monoid M] [comm_monoid N] : comm_monoid (M × N) :=
{ .. prod.comm_semigroup, .. prod.monoid }

@[to_additive]
instance [cancel_comm_monoid M] [cancel_comm_monoid N] : cancel_comm_monoid (M × N) :=
{ .. prod.left_cancel_monoid, .. prod.comm_monoid }

instance [mul_zero_one_class M] [mul_zero_one_class N] : mul_zero_one_class (M × N) :=
{ .. prod.mul_zero_class, .. prod.mul_one_class }

instance [monoid_with_zero M] [monoid_with_zero N] : monoid_with_zero (M × N) :=
{ .. prod.monoid, .. prod.mul_zero_one_class }

instance [comm_monoid_with_zero M] [comm_monoid_with_zero N] : comm_monoid_with_zero (M × N) :=
{ .. prod.comm_monoid, .. prod.monoid_with_zero }

@[to_additive]
instance [comm_group G] [comm_group H] : comm_group (G × H) :=
{ .. prod.comm_semigroup, .. prod.group }

end prod

namespace mul_hom

section prod

variables (M N) [has_mul M] [has_mul N] [has_mul P]

/-- Given magmas `M`, `N`, the natural projection homomorphism from `M × N` to `M`.-/
@[to_additive "Given additive magmas `A`, `B`, the natural projection homomorphism
from `A × B` to `A`"]
def fst : (M × N) →ₙ* M := ⟨prod.fst, λ _ _, rfl⟩

/-- Given magmas `M`, `N`, the natural projection homomorphism from `M × N` to `N`.-/
@[to_additive "Given additive magmas `A`, `B`, the natural projection homomorphism
from `A × B` to `B`"]
def snd : (M × N) →ₙ* N := ⟨prod.snd, λ _ _, rfl⟩

variables {M N}

@[simp, to_additive] lemma coe_fst : ⇑(fst M N) = prod.fst := rfl
@[simp, to_additive] lemma coe_snd : ⇑(snd M N) = prod.snd := rfl

/-- Combine two `monoid_hom`s `f : M →ₙ* N`, `g : M →ₙ* P` into
`f.prod g : M →ₙ* (N × P)` given by `(f.prod g) x = (f x, g x)`. -/
@[to_additive prod "Combine two `add_monoid_hom`s `f : add_hom M N`, `g : add_hom M P` into
`f.prod g : add_hom M (N × P)` given by `(f.prod g) x = (f x, g x)`"]
protected def prod (f : M →ₙ* N) (g : M →ₙ* P) : M →ₙ* (N × P) :=
{ to_fun := pi.prod f g,
  map_mul' := λ x y, prod.ext (f.map_mul x y) (g.map_mul x y) }

@[to_additive coe_prod]
lemma coe_prod (f : M →ₙ* N) (g : M →ₙ* P) : ⇑(f.prod g) = pi.prod f g := rfl

@[simp, to_additive prod_apply]

@[simp, to_additive fst_comp_prod]
lemma fst_comp_prod (f : M →ₙ* N) (g : M →ₙ* P) : (fst N P).comp (f.prod g) = f :=
ext $ λ x, rfl

@[simp, to_additive snd_comp_prod]
lemma snd_comp_prod (f : M →ₙ* N) (g : M →ₙ* P) : (snd N P).comp (f.prod g) = g :=
ext $ λ x, rfl

@[simp, to_additive prod_unique]
lemma prod_unique (f : M →ₙ* (N × P)) :
  ((fst N P).comp f).prod ((snd N P).comp f) = f :=
ext $ λ x, by simp only [prod_apply, coe_fst, coe_snd, comp_apply, prod.mk.eta]

end prod

section prod_map

variables {M' : Type*} {N' : Type*} [has_mul M] [has_mul N] [has_mul M'] [has_mul N'] [has_mul P]
  (f : M →ₙ* M') (g : N →ₙ* N')

/-- `prod.map` as a `monoid_hom`. -/
@[to_additive prod_map "`prod.map` as an `add_monoid_hom`"]
def prod_map : (M × N) →ₙ* (M' × N') := (f.comp (fst M N)).prod (g.comp (snd M N))

@[to_additive prod_map_def]
lemma prod_map_def : prod_map f g = (f.comp (fst M N)).prod (g.comp (snd M N)) := rfl

@[simp, to_additive coe_prod_map]
lemma coe_prod_map : ⇑(prod_map f g) = prod.map f g := rfl

@[to_additive prod_comp_prod_map]
lemma prod_comp_prod_map (f : P →ₙ* M) (g : P →ₙ* N)
  (f' : M →ₙ* M') (g' : N →ₙ* N') :
  (f'.prod_map g').comp (f.prod g) = (f'.comp f).prod (g'.comp g) :=
rfl

end prod_map

section coprod

variables [has_mul M] [has_mul N] [comm_semigroup P] (f : M →ₙ* P) (g : N →ₙ* P)

/-- Coproduct of two `mul_hom`s with the same codomain:
`f.coprod g (p : M × N) = f p.1 * g p.2`. -/
@[to_additive "Coproduct of two `add_hom`s with the same codomain:
`f.coprod g (p : M × N) = f p.1 + g p.2`."]
def coprod : (M × N) →ₙ* P := f.comp (fst M N) * g.comp (snd M N)

@[simp, to_additive]
lemma coprod_apply (p : M × N) : f.coprod g p = f p.1 * g p.2 := rfl

@[to_additive]
lemma comp_coprod {Q : Type*} [comm_semigroup Q]
  (h : P →ₙ* Q) (f : M →ₙ* P) (g : N →ₙ* P) :
  h.comp (f.coprod g) = (h.comp f).coprod (h.comp g) :=
ext $ λ x, by simp

end coprod

end mul_hom

namespace monoid_hom

variables (M N) [mul_one_class M] [mul_one_class N]

/-- Given monoids `M`, `N`, the natural projection homomorphism from `M × N` to `M`.-/
@[to_additive "Given additive monoids `A`, `B`, the natural projection homomorphism
from `A × B` to `A`"]
def fst : M × N →* M := ⟨prod.fst, rfl, λ _ _, rfl⟩

/-- Given monoids `M`, `N`, the natural projection homomorphism from `M × N` to `N`.-/
@[to_additive "Given additive monoids `A`, `B`, the natural projection homomorphism
from `A × B` to `B`"]
def snd : M × N →* N := ⟨prod.snd, rfl, λ _ _, rfl⟩

/-- Given monoids `M`, `N`, the natural inclusion homomorphism from `M` to `M × N`. -/
@[to_additive "Given additive monoids `A`, `B`, the natural inclusion homomorphism
from `A` to `A × B`."]
def inl : M →* M × N :=
⟨λ x, (x, 1), rfl, λ _ _, prod.ext rfl (one_mul 1).symm⟩

/-- Given monoids `M`, `N`, the natural inclusion homomorphism from `N` to `M × N`. -/
@[to_additive "Given additive monoids `A`, `B`, the natural inclusion homomorphism
from `B` to `A × B`."]
def inr : N →* M × N :=
⟨λ y, (1, y), rfl, λ _ _, prod.ext (one_mul 1).symm rfl⟩

variables {M N}

@[simp, to_additive] lemma coe_fst : ⇑(fst M N) = prod.fst := rfl
@[simp, to_additive] lemma coe_snd : ⇑(snd M N) = prod.snd := rfl

@[simp, to_additive] lemma inl_apply (x) : inl M N x = (x, 1) := rfl
@[simp, to_additive] lemma inr_apply (y) : inr M N y = (1, y) := rfl

@[simp, to_additive] lemma fst_comp_inl : (fst M N).comp (inl M N) = id M := rfl
@[simp, to_additive] lemma snd_comp_inl : (snd M N).comp (inl M N) = 1 := rfl
@[simp, to_additive] lemma fst_comp_inr : (fst M N).comp (inr M N) = 1 := rfl
@[simp, to_additive] lemma snd_comp_inr : (snd M N).comp (inr M N) = id N := rfl

section prod

variable [mul_one_class P]

/-- Combine two `monoid_hom`s `f : M →* N`, `g : M →* P` into `f.prod g : M →* N × P`
given by `(f.prod g) x = (f x, g x)`. -/
@[to_additive prod "Combine two `add_monoid_hom`s `f : M →+ N`, `g : M →+ P` into
`f.prod g : M →+ N × P` given by `(f.prod g) x = (f x, g x)`"]
protected def prod (f : M →* N) (g : M →* P) : M →* N × P :=
{ to_fun := pi.prod f g,
  map_one' := prod.ext f.map_one g.map_one,
  map_mul' := λ x y, prod.ext (f.map_mul x y) (g.map_mul x y) }

@[to_additive coe_prod]
lemma coe_prod (f : M →* N) (g : M →* P) : ⇑(f.prod g) = pi.prod f g := rfl

@[simp, to_additive prod_apply]
lemma prod_apply (f : M →* N) (g : M →* P) (x) : f.prod g x = (f x, g x) := rfl

@[simp, to_additive fst_comp_prod]
lemma fst_comp_prod (f : M →* N) (g : M →* P) : (fst N P).comp (f.prod g) = f :=
ext $ λ x, rfl

@[simp, to_additive snd_comp_prod]
lemma snd_comp_prod (f : M →* N) (g : M →* P) : (snd N P).comp (f.prod g) = g :=
ext $ λ x, rfl

@[simp, to_additive prod_unique]
lemma prod_unique (f : M →* N × P) :
  ((fst N P).comp f).prod ((snd N P).comp f) = f :=
ext $ λ x, by simp only [prod_apply, coe_fst, coe_snd, comp_apply, prod.mk.eta]

end prod

section prod_map

variables {M' : Type*} {N' : Type*} [mul_one_class M'] [mul_one_class N'] [mul_one_class P]
  (f : M →* M') (g : N →* N')

/-- `prod.map` as a `monoid_hom`. -/
@[to_additive prod_map "`prod.map` as an `add_monoid_hom`"]
def prod_map : M × N →* M' × N' := (f.comp (fst M N)).prod (g.comp (snd M N))

@[to_additive prod_map_def]
lemma prod_map_def : prod_map f g = (f.comp (fst M N)).prod (g.comp (snd M N)) := rfl

@[simp, to_additive coe_prod_map]
lemma coe_prod_map : ⇑(prod_map f g) = prod.map f g := rfl

@[to_additive prod_comp_prod_map]
lemma prod_comp_prod_map (f : P →* M) (g : P →* N) (f' : M →* M') (g' : N →* N') :
  (f'.prod_map g').comp (f.prod g) = (f'.comp f).prod (g'.comp g) :=
rfl

end prod_map

section coprod

variables [comm_monoid P] (f : M →* P) (g : N →* P)

/-- Coproduct of two `monoid_hom`s with the same codomain:
`f.coprod g (p : M × N) = f p.1 * g p.2`. -/
@[to_additive "Coproduct of two `add_monoid_hom`s with the same codomain:
`f.coprod g (p : M × N) = f p.1 + g p.2`."]
def coprod : M × N →* P := f.comp (fst M N) * g.comp (snd M N)

@[simp, to_additive]
lemma coprod_apply (p : M × N) : f.coprod g p = f p.1 * g p.2 := rfl

@[simp, to_additive]
lemma coprod_comp_inl : (f.coprod g).comp (inl M N) = f :=
ext $ λ x, by simp [coprod_apply]

@[simp, to_additive]
lemma coprod_comp_inr : (f.coprod g).comp (inr M N) = g :=
ext $ λ x, by simp [coprod_apply]

@[simp, to_additive] lemma coprod_unique (f : M × N →* P) :
  (f.comp (inl M N)).coprod (f.comp (inr M N)) = f :=
ext $ λ x, by simp [coprod_apply, inl_apply, inr_apply, ← map_mul]

@[simp, to_additive] lemma coprod_inl_inr {M N : Type*} [comm_monoid M] [comm_monoid N] :
  (inl M N).coprod (inr M N) = id (M × N) :=
coprod_unique (id $ M × N)

@[to_additive]
lemma comp_coprod {Q : Type*} [comm_monoid Q] (h : P →* Q) (f : M →* P) (g : N →* P) :
  h.comp (f.coprod g) = (h.comp f).coprod (h.comp g) :=
ext $ λ x, by simp

end coprod

end monoid_hom

namespace mul_equiv

section
variables {M N} [mul_one_class M] [mul_one_class N]

/-- The equivalence between `M × N` and `N × M` given by swapping the components
is multiplicative. -/
@[to_additive prod_comm "The equivalence between `M × N` and `N × M` given by swapping the
components is additive."]
def prod_comm : M × N ≃* N × M :=
{ map_mul' := λ ⟨x₁, y₁⟩ ⟨x₂, y₂⟩, rfl, ..equiv.prod_comm M N }

@[simp, to_additive coe_prod_comm] lemma coe_prod_comm :
  ⇑(prod_comm : M × N ≃* N × M) = prod.swap := rfl

@[simp, to_additive coe_prod_comm_symm] lemma coe_prod_comm_symm :
  ⇑((prod_comm : M × N ≃* N × M).symm) = prod.swap := rfl

variables {M' N' : Type*} [mul_one_class M'] [mul_one_class N']

/--Product of multiplicative isomorphisms; the maps come from `equiv.prod_congr`.-/
@[to_additive prod_congr "Product of additive isomorphisms; the maps come from `equiv.prod_congr`."]
def prod_congr (f : M ≃* M') (g : N ≃* N') : M × N ≃* M' × N' :=
{ map_mul' := λ x y, prod.ext (f.map_mul _ _) (g.map_mul _ _),
  ..f.to_equiv.prod_congr g.to_equiv }

/--Multiplying by the trivial monoid doesn't change the structure.-/
@[to_additive unique_prod "Multiplying by the trivial monoid doesn't change the structure."]
def unique_prod [unique N] : N × M ≃* M :=
{ map_mul' := λ x y, rfl,
  ..equiv.unique_prod M N }

/--Multiplying by the trivial monoid doesn't change the structure.-/
@[to_additive prod_unique "Multiplying by the trivial monoid doesn't change the structure."]
def prod_unique [unique N] : M × N ≃* M :=
{ map_mul' := λ x y, rfl,
  ..equiv.prod_unique M N }

end

section
variables {M N} [monoid M] [monoid N]

/-- The monoid equivalence between units of a product of two monoids, and the product of the
    units of each monoid. -/
@[to_additive prod_add_units "The additive monoid equivalence between additive units of a product
of two additive monoids, and the product of the additive units of each additive monoid."]
def prod_units : (M × N)ˣ ≃* Mˣ × Nˣ :=
{ to_fun := (units.map (monoid_hom.fst M N)).prod (units.map (monoid_hom.snd M N)),
  inv_fun := λ u, ⟨(u.1, u.2), (↑u.1⁻¹, ↑u.2⁻¹), by simp, by simp⟩,
  left_inv := λ u, by simp,
  right_inv := λ ⟨u₁, u₂⟩, by simp [units.map],
  map_mul' := monoid_hom.map_mul _ }

end

end mul_equiv

namespace units

open mul_opposite

/-- Canonical homomorphism of monoids from `αˣ` into `α × αᵐᵒᵖ`.
Used mainly to define the natural topology of `αˣ`. -/
@[to_additive "Canonical homomorphism of additive monoids from `add_units α` into `α × αᵃᵒᵖ`.
Used mainly to define the natural topology of `add_units α`.", simps]
def embed_product (α : Type*) [monoid α] : αˣ →* α × αᵐᵒᵖ :=
{ to_fun := λ x, ⟨x, op ↑x⁻¹⟩,
  map_one' := by simp only [inv_one, eq_self_iff_true, units.coe_one, op_one, prod.mk_eq_one,
    and_self],
  map_mul' := λ x y, by simp only [mul_inv_rev, op_mul, units.coe_mul, prod.mk_mul_mk] }

@[to_additive]
lemma embed_product_injective (α : Type*) [monoid α] : function.injective (embed_product α) :=
λ a₁ a₂ h, units.ext $ (congr_arg prod.fst h : _)

end units

/-! ### Multiplication and division as homomorphisms -/

section bundled_mul_div
variables {α : Type*}

/-- Multiplication as a multiplicative homomorphism. -/
@[to_additive "Addition as an additive homomorphism.", simps]
def mul_mul_hom [comm_semigroup α] : (α × α) →ₙ* α :=
{ to_fun := λ a, a.1 * a.2,
  map_mul' := λ a b, mul_mul_mul_comm _ _ _ _ }

/-- Multiplication as a monoid homomorphism. -/
@[to_additive "Addition as an additive monoid homomorphism.", simps]
def mul_monoid_hom [comm_monoid α] : α × α →* α :=
{ map_one' := mul_one _,
  .. mul_mul_hom }

/-- Multiplication as a multiplicative homomorphism with zero. -/
@[simps]
def mul_monoid_with_zero_hom [comm_monoid_with_zero α] : α × α →*₀ α :=
{ map_zero' := mul_zero _,
  .. mul_monoid_hom }

/-- Division as a monoid homomorphism. -/
@[to_additive "Subtraction as an additive monoid homomorphism.", simps]
def div_monoid_hom [division_comm_monoid α] : α × α →* α :=
{ to_fun := λ a, a.1 / a.2,
  map_one' := div_one _,
  map_mul' := λ a b, mul_div_mul_comm _ _ _ _ }

/-- Division as a multiplicative homomorphism with zero. -/
@[simps]
def div_monoid_with_zero_hom [comm_group_with_zero α] : α × α →*₀ α :=
{ to_fun := λ a, a.1 / a.2,
  map_zero' := zero_div _,
  map_one' := div_one _,
  map_mul' := λ a b, mul_div_mul_comm _ _ _ _ }

end bundled_mul_div


/-
Copyright (c) 2020 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Mario Carneiro, Yury G. Kudryashov
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.order.basic
import Mathlib.PostPort

universes u l u_1 v

namespace Mathlib

/-!
# Unbundled relation classes

In this file we prove some properties of `is_*` classes defined in `init.algebra.classes`. The main
difference between these classes and the usual order classes (`preorder` etc) is that usual classes
extend `has_le` and/or `has_lt` while these classes take a relation as an explicit argument.

-/

theorem is_refl.swap {α : Type u} (r : α → α → Prop) [is_refl α r] : is_refl α (function.swap r) :=
  is_refl.mk (refl_of r)

theorem is_irrefl.swap {α : Type u} (r : α → α → Prop) [is_irrefl α r] : is_irrefl α (function.swap r) :=
  is_irrefl.mk (irrefl_of r)

theorem is_trans.swap {α : Type u} (r : α → α → Prop) [is_trans α r] : is_trans α (function.swap r) :=
  is_trans.mk fun (a b c : α) (h₁ : function.swap r a b) (h₂ : function.swap r b c) => trans_of r h₂ h₁

theorem is_antisymm.swap {α : Type u} (r : α → α → Prop) [is_antisymm α r] : is_antisymm α (function.swap r) :=
  is_antisymm.mk fun (a b : α) (h₁ : function.swap r a b) (h₂ : function.swap r b a) => antisymm h₂ h₁

theorem is_asymm.swap {α : Type u} (r : α → α → Prop) [is_asymm α r] : is_asymm α (function.swap r) :=
  is_asymm.mk fun (a b : α) (h₁ : function.swap r a b) (h₂ : function.swap r b a) => asymm_of r h₂ h₁

theorem is_total.swap {α : Type u} (r : α → α → Prop) [is_total α r] : is_total α (function.swap r) :=
  is_total.mk fun (a b : α) => or.swap (total_of r a b)

theorem is_trichotomous.swap {α : Type u} (r : α → α → Prop) [is_trichotomous α r] : is_trichotomous α (function.swap r) := sorry

theorem is_preorder.swap {α : Type u} (r : α → α → Prop) [is_preorder α r] : is_preorder α (function.swap r) :=
  is_preorder.mk

theorem is_strict_order.swap {α : Type u} (r : α → α → Prop) [is_strict_order α r] : is_strict_order α (function.swap r) :=
  is_strict_order.mk

theorem is_partial_order.swap {α : Type u} (r : α → α → Prop) [is_partial_order α r] : is_partial_order α (function.swap r) :=
  is_partial_order.mk

theorem is_total_preorder.swap {α : Type u} (r : α → α → Prop) [is_total_preorder α r] : is_total_preorder α (function.swap r) :=
  is_total_preorder.mk

theorem is_linear_order.swap {α : Type u} (r : α → α → Prop) [is_linear_order α r] : is_linear_order α (function.swap r) :=
  is_linear_order.mk

protected theorem is_asymm.is_antisymm {α : Type u} (r : α → α → Prop) [is_asymm α r] : is_antisymm α r :=
  is_antisymm.mk fun (x y : α) (h₁ : r x y) (h₂ : r y x) => false.elim (asymm h₁ h₂)

protected theorem is_asymm.is_irrefl {α : Type u} {r : α → α → Prop} [is_asymm α r] : is_irrefl α r :=
  is_irrefl.mk fun (a : α) (h : r a a) => asymm h h

/- Convert algebraic structure style to explicit relation style typeclasses -/

protected instance has_le.le.is_refl {α : Type u} [preorder α] : is_refl α LessEq :=
  is_refl.mk le_refl

protected instance ge.is_refl {α : Type u} [preorder α] : is_refl α ge :=
  is_refl.swap fun (b a : α) => b ≤ a

protected instance has_le.le.is_trans {α : Type u} [preorder α] : is_trans α LessEq :=
  is_trans.mk le_trans

protected instance ge.is_trans {α : Type u} [preorder α] : is_trans α ge :=
  is_trans.swap fun (b a : α) => b ≤ a

protected instance has_le.le.is_preorder {α : Type u} [preorder α] : is_preorder α LessEq :=
  is_preorder.mk

protected instance ge.is_preorder {α : Type u} [preorder α] : is_preorder α ge :=
  is_preorder.mk

protected instance has_lt.lt.is_irrefl {α : Type u} [preorder α] : is_irrefl α Less :=
  is_irrefl.mk lt_irrefl

protected instance gt.is_irrefl {α : Type u} [preorder α] : is_irrefl α gt :=
  is_irrefl.swap fun (b a : α) => b < a

protected instance has_lt.lt.is_trans {α : Type u} [preorder α] : is_trans α Less :=
  is_trans.mk lt_trans

protected instance gt.is_trans {α : Type u} [preorder α] : is_trans α gt :=
  is_trans.swap fun (b a : α) => b < a

protected instance has_lt.lt.is_asymm {α : Type u} [preorder α] : is_asymm α Less :=
  is_asymm.mk lt_asymm

protected instance gt.is_asymm {α : Type u} [preorder α] : is_asymm α gt :=
  is_asymm.swap fun (b a : α) => b < a

protected instance has_lt.lt.is_antisymm {α : Type u} [preorder α] : is_antisymm α Less :=
  is_asymm.is_antisymm Less

protected instance gt.is_antisymm {α : Type u} [preorder α] : is_antisymm α gt :=
  is_asymm.is_antisymm gt

protected instance has_lt.lt.is_strict_order {α : Type u} [preorder α] : is_strict_order α Less :=
  is_strict_order.mk

protected instance gt.is_strict_order {α : Type u} [preorder α] : is_strict_order α gt :=
  is_strict_order.mk

protected instance preorder.is_total_preorder {α : Type u} [preorder α] [is_total α LessEq] : is_total_preorder α LessEq :=
  is_total_preorder.mk

protected instance has_le.le.is_antisymm {α : Type u} [partial_order α] : is_antisymm α LessEq :=
  is_antisymm.mk le_antisymm

protected instance ge.is_antisymm {α : Type u} [partial_order α] : is_antisymm α ge :=
  is_antisymm.swap fun (b a : α) => b ≤ a

protected instance has_le.le.is_partial_order {α : Type u} [partial_order α] : is_partial_order α LessEq :=
  is_partial_order.mk

protected instance ge.is_partial_order {α : Type u} [partial_order α] : is_partial_order α ge :=
  is_partial_order.mk

protected instance has_le.le.is_total {α : Type u} [linear_order α] : is_total α LessEq :=
  is_total.mk le_total

protected instance ge.is_total {α : Type u} [linear_order α] : is_total α ge :=
  is_total.swap fun (b a : α) => b ≤ a

protected instance linear_order.is_total_preorder {α : Type u} [linear_order α] : is_total_preorder α LessEq :=
  preorder.is_total_preorder

protected instance ge.is_total_preorder {α : Type u} [linear_order α] : is_total_preorder α ge :=
  is_total_preorder.mk

protected instance has_le.le.is_linear_order {α : Type u} [linear_order α] : is_linear_order α LessEq :=
  is_linear_order.mk

protected instance ge.is_linear_order {α : Type u} [linear_order α] : is_linear_order α ge :=
  is_linear_order.mk

protected instance has_lt.lt.is_trichotomous {α : Type u} [linear_order α] : is_trichotomous α Less :=
  is_trichotomous.mk lt_trichotomy

protected instance gt.is_trichotomous {α : Type u} [linear_order α] : is_trichotomous α gt :=
  is_trichotomous.swap fun (b a : α) => b < a

protected instance order_dual.is_total_le {α : Type u} [HasLessEq α] [is_total α LessEq] : is_total (order_dual α) LessEq :=
  is_total.swap fun (x y : α) => x ≤ y

theorem ne_of_irrefl {α : Type u} {r : α → α → Prop} [is_irrefl α r] {x : α} {y : α} : r x y → x ≠ y := sorry

theorem trans_trichotomous_left {α : Type u} {r : α → α → Prop} [is_trans α r] [is_trichotomous α r] {a : α} {b : α} {c : α} : ¬r b a → r b c → r a c := sorry

theorem trans_trichotomous_right {α : Type u} {r : α → α → Prop} [is_trans α r] [is_trichotomous α r] {a : α} {b : α} {c : α} : r a b → ¬r c b → r a c := sorry

/-- Construct a partial order from a `is_strict_order` relation -/
def partial_order_of_SO {α : Type u} (r : α → α → Prop) [is_strict_order α r] : partial_order α :=
  partial_order.mk (fun (x y : α) => x = y ∨ r x y) r sorry sorry sorry

/-- This is basically the same as `is_strict_total_order`, but that definition is
  in Type (probably by mistake) and also has redundant assumptions. -/
class is_strict_total_order' (α : Type u) (lt : α → α → Prop)
extends is_trichotomous α lt, is_strict_order α lt
where

/-- Construct a linear order from an `is_strict_total_order'` relation -/
def linear_order_of_STO' {α : Type u} (r : α → α → Prop) [is_strict_total_order' α r] [(x y : α) → Decidable (¬r x y)] : linear_order α :=
  linear_order.mk partial_order.le partial_order.lt sorry sorry sorry sorry
    (fun (x y : α) => decidable_of_iff (¬r y x) sorry) Mathlib.decidable_eq_of_decidable_le
    Mathlib.decidable_lt_of_decidable_le

theorem is_strict_total_order'.swap {α : Type u} (r : α → α → Prop) [is_strict_total_order' α r] : is_strict_total_order' α (function.swap r) :=
  is_strict_total_order'.mk

protected instance has_lt.lt.is_strict_total_order' {α : Type u} [linear_order α] : is_strict_total_order' α Less :=
  is_strict_total_order'.mk

/-- A connected order is one satisfying the condition `a < c → a < b ∨ b < c`.
  This is recognizable as an intuitionistic substitute for `a ≤ b ∨ b ≤ a` on
  the constructive reals, and is also known as negative transitivity,
  since the contrapositive asserts transitivity of the relation `¬ a < b`.  -/
class is_order_connected (α : Type u) (lt : α → α → Prop)
where
  conn : ∀ (a b c : α), lt a c → lt a b ∨ lt b c

theorem is_order_connected.neg_trans {α : Type u} {r : α → α → Prop} [is_order_connected α r] {a : α} {b : α} {c : α} (h₁ : ¬r a b) (h₂ : ¬r b c) : ¬r a c := sorry

theorem is_strict_weak_order_of_is_order_connected {α : Type u} {r : α → α → Prop} [is_asymm α r] [is_order_connected α r] : is_strict_weak_order α r :=
  is_strict_weak_order.mk

protected instance is_order_connected_of_is_strict_total_order' {α : Type u} {r : α → α → Prop} [is_strict_total_order' α r] : is_order_connected α r :=
  is_order_connected.mk
    fun (a b c : α) (h : r a c) =>
      or.imp_right (fun (o : a = b ∨ r b a) => or.elim o (fun (e : a = b) => e ▸ h) fun (h' : r b a) => trans h' h)
        (trichotomous a b)

protected instance is_strict_total_order_of_is_strict_total_order' {α : Type u} {r : α → α → Prop} [is_strict_total_order' α r] : is_strict_total_order α r :=
  is_strict_total_order.mk

protected instance has_lt.lt.is_strict_total_order {α : Type u} [linear_order α] : is_strict_total_order α Less :=
  Mathlib.is_strict_total_order_of_is_strict_total_order'

protected instance has_lt.lt.is_order_connected {α : Type u} [linear_order α] : is_order_connected α Less :=
  Mathlib.is_order_connected_of_is_strict_total_order'

protected instance has_lt.lt.is_incomp_trans {α : Type u} [linear_order α] : is_incomp_trans α Less :=
  is_strict_weak_order.to_is_incomp_trans

protected instance has_lt.lt.is_strict_weak_order {α : Type u} [linear_order α] : is_strict_weak_order α Less :=
  Mathlib.is_strict_weak_order_of_linear_order

/-- An extensional relation is one in which an element is determined by its set
  of predecessors. It is named for the `x ∈ y` relation in set theory, whose
  extensionality is one of the first axioms of ZFC. -/
class is_extensional (α : Type u) (r : α → α → Prop)
where
  ext : ∀ (a b : α), (∀ (x : α), r x a ↔ r x b) → a = b

protected instance is_extensional_of_is_strict_total_order' {α : Type u} {r : α → α → Prop} [is_strict_total_order' α r] : is_extensional α r :=
  is_extensional.mk
    fun (a b : α) (H : ∀ (x : α), r x a ↔ r x b) =>
      or.resolve_right (or.resolve_left (trichotomous a b) (mt (iff.mpr (H a)) (irrefl a))) (mt (iff.mp (H b)) (irrefl b))

/-- A well order is a well-founded linear order. -/
class is_well_order (α : Type u) (r : α → α → Prop)
extends is_strict_total_order' α r
where
  wf : well_founded r

protected instance is_well_order.is_strict_total_order {α : Type u_1} (r : α → α → Prop) [is_well_order α r] : is_strict_total_order α r :=
  Mathlib.is_strict_total_order_of_is_strict_total_order'

protected instance is_well_order.is_extensional {α : Type u_1} (r : α → α → Prop) [is_well_order α r] : is_extensional α r :=
  Mathlib.is_extensional_of_is_strict_total_order'

protected instance is_well_order.is_trichotomous {α : Type u_1} (r : α → α → Prop) [is_well_order α r] : is_trichotomous α r :=
  is_strict_total_order'.to_is_trichotomous

protected instance is_well_order.is_trans {α : Type u_1} (r : α → α → Prop) [is_well_order α r] : is_trans α r :=
  is_strict_order.to_is_trans

protected instance is_well_order.is_irrefl {α : Type u_1} (r : α → α → Prop) [is_well_order α r] : is_irrefl α r :=
  is_strict_order.to_is_irrefl

protected instance is_well_order.is_asymm {α : Type u_1} (r : α → α → Prop) [is_well_order α r] : is_asymm α r :=
  Mathlib.is_asymm_of_is_trans_of_is_irrefl

/-- Construct a decidable linear order from a well-founded linear order. -/
def is_well_order.linear_order {α : Type u} (r : α → α → Prop) [is_well_order α r] : linear_order α :=
  let _inst : (x y : α) → Decidable (¬r x y) := fun (x y : α) => classical.dec (¬r x y);
  linear_order_of_STO' r

protected instance empty_relation.is_well_order {α : Type u} [subsingleton α] : is_well_order α empty_relation :=
  is_well_order.mk (well_founded.intro fun (a : α) => acc.intro a fun (y : α) => false.elim)

protected instance nat.lt.is_well_order : is_well_order ℕ Less :=
  is_well_order.mk nat.lt_wf

protected instance sum.lex.is_well_order {α : Type u} {β : Type v} {r : α → α → Prop} {s : β → β → Prop} [is_well_order α r] [is_well_order β s] : is_well_order (α ⊕ β) (sum.lex r s) :=
  is_well_order.mk (sum.lex_wf is_well_order.wf is_well_order.wf)

protected instance prod.lex.is_well_order {α : Type u} {β : Type v} {r : α → α → Prop} {s : β → β → Prop} [is_well_order α r] [is_well_order β s] : is_well_order (α × β) (prod.lex r s) :=
  is_well_order.mk (prod.lex_wf is_well_order.wf is_well_order.wf)

/-- An unbounded or cofinal set -/
/-- A bounded or final set -/
def unbounded {α : Type u} (r : α → α → Prop) (s : set α) :=
  ∀ (a : α), ∃ (b : α), ∃ (H : b ∈ s), ¬r b a

def bounded {α : Type u} (r : α → α → Prop) (s : set α) :=
  ∃ (a : α), ∀ (b : α), b ∈ s → r b a

@[simp] theorem not_bounded_iff {α : Type u} {r : α → α → Prop} (s : set α) : ¬bounded r s ↔ unbounded r s := sorry

@[simp] theorem not_unbounded_iff {α : Type u} {r : α → α → Prop} (s : set α) : ¬unbounded r s ↔ bounded r s :=
  eq.mpr (id (Eq._oldrec (Eq.refl (¬unbounded r s ↔ bounded r s)) (propext not_iff_comm)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (¬bounded r s ↔ unbounded r s)) (propext (not_bounded_iff s))))
      (iff.refl (unbounded r s)))