/-
Copyright (c) 2022 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov

! This file was ported from Lean 3 source module analysis.complex.upper_half_plane.topology
! leanprover-community/mathlib commit fe44cd36149e675eb5dec87acc7e8f1d6568e081
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Analysis.Complex.UpperHalfPlane.Basic
import Mathbin.Analysis.Convex.Contractible
import Mathbin.Analysis.Convex.Normed
import Mathbin.Analysis.Convex.Complex
import Mathbin.Analysis.Complex.ReImTopology
import Mathbin.Topology.Homotopy.Contractible
import Mathbin.Geometry.Manifold.Mfderiv
import Mathbin.Geometry.Manifold.ContMdiffMfderiv

/-!
# Topology on the upper half plane

In this file we introduce a `topological_space` structure on the upper half plane and provide
various instances.
-/

noncomputable section

open Set Filter Function TopologicalSpace Complex

open Filter Topology UpperHalfPlane Manifold

namespace UpperHalfPlane

instance : TopologicalSpace ℍ :=
  Subtype.topologicalSpace

theorem openEmbedding_coe : OpenEmbedding (coe : ℍ → ℂ) :=
  IsOpen.openEmbedding_subtype_val <| isOpen_lt continuous_const Complex.continuous_im
#align upper_half_plane.open_embedding_coe UpperHalfPlane.openEmbedding_coe

theorem embedding_coe : Embedding (coe : ℍ → ℂ) :=
  embedding_subtype_val
#align upper_half_plane.embedding_coe UpperHalfPlane.embedding_coe

theorem continuous_coe : Continuous (coe : ℍ → ℂ) :=
  embedding_coe.Continuous
#align upper_half_plane.continuous_coe UpperHalfPlane.continuous_coe

theorem continuous_re : Continuous re :=
  Complex.continuous_re.comp continuous_coe
#align upper_half_plane.continuous_re UpperHalfPlane.continuous_re

theorem continuous_im : Continuous im :=
  Complex.continuous_im.comp continuous_coe
#align upper_half_plane.continuous_im UpperHalfPlane.continuous_im

instance : TopologicalSpace.SecondCountableTopology ℍ :=
  TopologicalSpace.Subtype.secondCountableTopology _ _

instance : T3Space ℍ :=
  Subtype.t3Space

instance : NormalSpace ℍ :=
  normalSpaceOfT3SecondCountable ℍ

instance : ContractibleSpace ℍ :=
  (convex_halfspace_im_gt 0).ContractibleSpace ⟨I, one_pos.trans_eq I_im.symm⟩

instance : LocPathConnectedSpace ℍ :=
  locPathConnected_of_isOpen <| isOpen_lt continuous_const Complex.continuous_im

instance : NoncompactSpace ℍ := by
  refine' ⟨fun h => _⟩
  have : IsCompact (Complex.im ⁻¹' Ioi 0) := isCompact_iff_isCompact_univ.2 h
  replace := this.is_closed.closure_eq
  rw [closure_preimage_im, closure_Ioi, Set.ext_iff] at this
  exact absurd ((this 0).1 left_mem_Ici) (lt_irrefl _)

instance : LocallyCompactSpace ℍ :=
  openEmbedding_coe.LocallyCompactSpace

instance UpperHalfPlane.chartedSpace : ChartedSpace ℂ ℍ :=
  UpperHalfPlane.openEmbedding_coe.singletonChartedSpace
#align upper_half_plane.upper_half_plane.charted_space UpperHalfPlane.UpperHalfPlane.chartedSpace

instance UpperHalfPlane.smoothManifoldWithCorners : SmoothManifoldWithCorners 𝓘(ℂ) ℍ :=
  UpperHalfPlane.openEmbedding_coe.singleton_smoothManifoldWithCorners 𝓘(ℂ)
#align upper_half_plane.upper_half_plane.smooth_manifold_with_corners UpperHalfPlane.UpperHalfPlane.smoothManifoldWithCorners

/-- The inclusion map `ℍ → ℂ` is a smooth map of manifolds. -/
theorem smooth_coe : Smooth 𝓘(ℂ) 𝓘(ℂ) (coe : ℍ → ℂ) := fun x => contMdiffAt_extChartAt
#align upper_half_plane.smooth_coe UpperHalfPlane.smooth_coe

/-- The inclusion map `ℍ → ℂ` is a differentiable map of manifolds. -/
theorem mdifferentiable_coe : Mdifferentiable 𝓘(ℂ) 𝓘(ℂ) (coe : ℍ → ℂ) :=
  smooth_coe.Mdifferentiable
#align upper_half_plane.mdifferentiable_coe UpperHalfPlane.mdifferentiable_coe

end UpperHalfPlane


/-
Copyright (c) 2018 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Simon Hudon
-/

import control.functor.multivariate
import data.pfunctor.multivariate.basic
import data.pfunctor.multivariate.M
import data.qpf.multivariate.basic

/-!
# The final co-algebra of a multivariate qpf is again a qpf.

For a `(n+1)`-ary QPF `F (α₀,..,αₙ)`, we take the least fixed point of `F` with
regards to its last argument `αₙ`. The result is a `n`-ary functor: `fix F (α₀,..,αₙ₋₁)`.
Making `fix F` into a functor allows us to take the fixed point, compose with other functors
and take a fixed point again.

## Main definitions

 * `cofix.mk`     - constructor
 * `cofix.dest    - destructor
 * `cofix.corec`  - corecursor: useful for formulating infinite, productive computations
 * `cofix.bisim`  - bisimulation: proof technique to show the equality of possibly infinite values
                    of `cofix F α`

## Implementation notes

For `F` a QPF`, we define `cofix F α` in terms of the M-type of the polynomial functor `P` of `F`.
We define the relation `Mcongr` and take its quotient as the definition of `cofix F α`.

`Mcongr` is taken as the weakest bisimulation on M-type.  See
[avigad-carneiro-hudon2019] for more details.

## Reference

 * Jeremy Avigad, Mario M. Carneiro and Simon Hudon.
   [*Data Types as Quotients of Polynomial Functors*][avigad-carneiro-hudon2019]
-/

universe u
open_locale mvfunctor

namespace mvqpf
open typevec mvpfunctor
open mvfunctor (liftp liftr)

variables {n : ℕ} {F : typevec.{u} (n+1) → Type u} [mvfunctor F] [q : mvqpf F]
include q

/-- `corecF` is used as a basis for defining the corecursor of `cofix F α`. `corecF`
uses corecursion to construct the M-type generated by `q.P` and uses function on `F`
as a corecursive step -/
def corecF {α : typevec n} {β : Type*} (g : β → F (α.append1 β)) : β → q.P.M α :=
M.corec _ (λ x, repr (g x))

theorem corecF_eq {α : typevec n} {β : Type*} (g : β → F (α.append1 β)) (x : β) :
  M.dest q.P (corecF g x) = append_fun id (corecF g) <$$> repr (g x) :=
by rw [corecF, M.dest_corec]

/-- Characterization of desirable equivalence relations on M-types -/
def is_precongr {α : typevec n} (r : q.P.M α → q.P.M α → Prop) : Prop :=
  ∀ ⦃x y⦄, r x y →
    abs (append_fun id (quot.mk r) <$$> M.dest q.P x) =
      abs (append_fun id (quot.mk r) <$$> M.dest q.P y)

/-- Equivalence relation on M-types representing a value of type `cofix F` -/
def Mcongr {α : typevec n} (x y : q.P.M α) : Prop :=
∃ r, is_precongr r ∧ r x y

/-- Greatest fixed point of functor F. The result is a functor with one fewer parameters
than the input. For `F a b c` a ternary functor, fix F is a binary functor such that

```lean
cofix F a b = F a b (cofix F a b)
```
-/
def cofix (F : typevec (n + 1) → Type u) [mvfunctor F] [q : mvqpf F] (α : typevec n) :=
quot (@Mcongr _ F _ q α)

instance {α : typevec n} [inhabited q.P.A] [Π (i : fin2 n), inhabited (α i)] :
  inhabited (cofix F α) := ⟨ quot.mk _ default ⟩

/-- maps every element of the W type to a canonical representative -/
def Mrepr {α : typevec n} : q.P.M α → q.P.M α := corecF (abs ∘ M.dest q.P)

/-- the map function for the functor `cofix F` -/
def cofix.map {α β : typevec n} (g : α ⟹ β) : cofix F α → cofix F β :=
quot.lift (λ x : q.P.M α, quot.mk Mcongr (g <$$> x))
  begin
    rintros aa₁ aa₂ ⟨r, pr, ra₁a₂⟩, apply quot.sound,
    let r' := λ b₁ b₂, ∃ a₁ a₂ : q.P.M α, r a₁ a₂ ∧ b₁ = g <$$> a₁ ∧ b₂ = g <$$> a₂,
    use r', split,
    { show is_precongr r',
      rintros b₁ b₂ ⟨a₁, a₂, ra₁a₂, b₁eq, b₂eq⟩,
      let u : quot r → quot r' := quot.lift (λ x : q.P.M α, quot.mk r' (g <$$> x))
        (by { intros a₁ a₂ ra₁a₂, apply quot.sound, exact ⟨a₁, a₂, ra₁a₂, rfl, rfl⟩ }),
      have hu : (quot.mk r' ∘ λ x : q.P.M α, g <$$> x) = u ∘ quot.mk r,
        { ext x, refl },
      rw [b₁eq, b₂eq, M.dest_map, M.dest_map, ←q.P.comp_map, ←q.P.comp_map],
      rw [←append_fun_comp, id_comp, hu, hu, ←comp_id g, append_fun_comp],
      rw [q.P.comp_map, q.P.comp_map, abs_map, pr ra₁a₂, ←abs_map] },
    show r' (g <$$> aa₁) (g <$$> aa₂), from ⟨aa₁, aa₂, ra₁a₂, rfl, rfl⟩
  end

instance cofix.mvfunctor : mvfunctor (cofix F) :=
{ map := @cofix.map _ _ _ _}

/-- Corecursor for `cofix F` -/
def cofix.corec {α : typevec n} {β : Type u} (g : β → F (α.append1 β)) : β → cofix F α :=
λ x, quot.mk  _ (corecF g x)

/-- Destructor for `cofix F` -/
def cofix.dest {α : typevec n} : cofix F α → F (α.append1 (cofix F α)) :=
quot.lift
  (λ x, append_fun id (quot.mk Mcongr) <$$> (abs (M.dest q.P x)))
  begin
    rintros x y ⟨r, pr, rxy⟩, dsimp,
    have : ∀ x y, r x y → Mcongr x y,
    { intros x y h, exact ⟨r, pr, h⟩ },
    rw [←quot.factor_mk_eq _ _ this], dsimp,
    conv { to_lhs,
      rw [append_fun_comp_id, comp_map, ←abs_map, pr rxy, abs_map, ←comp_map,
        ←append_fun_comp_id] }
  end

/-- Abstraction function for `cofix F α` -/
def cofix.abs {α} : q.P.M α → cofix F α :=
quot.mk _

/-- Representation function for `cofix F α` -/
def cofix.repr {α} : cofix F α → q.P.M α :=
M.corec _ $ repr ∘ cofix.dest

/-- Corecursor for `cofix F` -/
def cofix.corec'₁ {α : typevec n} {β : Type u}
  (g : Π {X}, (β → X) → F (α.append1 X)) (x : β) : cofix F α :=
cofix.corec (λ x, g id) x

/-- More flexible corecursor for `cofix F`. Allows the return of a fully formed
value instead of making a recursive call -/
def cofix.corec' {α : typevec n} {β : Type u} (g : β → F (α.append1 (cofix F α ⊕ β))) (x : β) :
  cofix F α :=
let f : α ::: cofix F α ⟹ α ::: (cofix F α ⊕ β) := id ::: sum.inl in
cofix.corec
(sum.elim (mvfunctor.map f ∘ cofix.dest) g)
(sum.inr x : cofix F α ⊕ β)

/-- Corecursor for `cofix F`. The shape allows recursive calls to
look like recursive calls. -/
def cofix.corec₁ {α : typevec n} {β : Type u}
  (g : Π {X}, (cofix F α → X) → (β → X) → β → F (α ::: X)) (x : β) : cofix F α :=
cofix.corec' (λ x, g sum.inl sum.inr x) x

theorem cofix.dest_corec {α : typevec n} {β : Type u} (g : β → F (α.append1 β)) (x : β) :
  cofix.dest (cofix.corec g x) = append_fun id (cofix.corec g) <$$> g x :=
begin
  conv { to_lhs, rw [cofix.dest, cofix.corec] }, dsimp,
  rw [corecF_eq, abs_map, abs_repr, ←comp_map, ←append_fun_comp], reflexivity
end

/-- constructor for `cofix F` -/
def cofix.mk {α : typevec n} : F (α.append1 $ cofix F α) → cofix F α :=
cofix.corec (λ x, append_fun id (λ i : cofix F α, cofix.dest.{u} i) <$$> x)

/-!
## Bisimulation principles for `cofix F`

The following theorems are bisimulation principles. The general idea
is to use a bisimulation relation to prove the equality between
specific values of type `cofix F α`.

A bisimulation relation `R` for values `x y : cofix F α`:

 * holds for `x y`: `R x y`
 * for any values `x y` that satisfy `R`, their root has the same shape
   and their children can be paired in such a way that they satisfy `R`.

-/

private theorem cofix.bisim_aux {α : typevec n}
    (r : cofix F α → cofix F α → Prop)
    (h' : ∀ x, r x x)
    (h : ∀ x y, r x y →
      append_fun id (quot.mk r) <$$> cofix.dest x = append_fun id (quot.mk r) <$$> cofix.dest y) :
  ∀ x y, r x y → x = y :=
begin
  intro x, apply quot.induction_on x, clear x,
  intros x y, apply quot.induction_on y, clear y,
  intros y rxy,
  apply quot.sound,
  let r' := λ x y, r (quot.mk _ x) (quot.mk _ y),
  have : is_precongr r',
  { intros a b r'ab,
      have  h₀ :
          append_fun id (quot.mk r ∘ quot.mk Mcongr) <$$> abs (M.dest q.P a) =
          append_fun id (quot.mk r ∘ quot.mk Mcongr) <$$> abs (M.dest q.P b) :=
        by rw [append_fun_comp_id, comp_map, comp_map]; exact h _ _ r'ab,
    have h₁ : ∀ u v : q.P.M α, Mcongr u v → quot.mk r' u = quot.mk r' v,
    { intros u v cuv, apply quot.sound, dsimp [r'], rw quot.sound cuv, apply h' },
    let f : quot r → quot r' := quot.lift (quot.lift (quot.mk r') h₁)
      begin
        intro c, apply quot.induction_on c, clear c,
        intros c d, apply quot.induction_on d, clear d,
        intros d rcd, apply quot.sound, apply rcd
      end,
    have : f ∘ quot.mk r ∘ quot.mk Mcongr = quot.mk r' := rfl,
    rw [←this, append_fun_comp_id, q.P.comp_map, q.P.comp_map, abs_map, abs_map, abs_map,
         abs_map, h₀] },
  refine ⟨r', this, rxy⟩
end

/-- Bisimulation principle using `map` and `quot.mk` to match and relate children of two trees. -/
theorem cofix.bisim_rel {α : typevec n}
    (r : cofix F α → cofix F α → Prop)
    (h : ∀ x y, r x y →
      append_fun id (quot.mk r) <$$> cofix.dest x = append_fun id (quot.mk r) <$$> cofix.dest y) :
  ∀ x y, r x y → x = y :=
let r' x y := x = y ∨ r x y in
begin
  intros x y rxy,
  apply cofix.bisim_aux r',
  { intro x, left, reflexivity },
  { intros x y r'xy,
    cases r'xy, { rw r'xy },
    have : ∀ x y, r x y → r' x y := λ x y h, or.inr h,
    rw ←quot.factor_mk_eq _ _ this, dsimp,
    rw [append_fun_comp_id, append_fun_comp_id],
    rw [@comp_map _ _ _ q _ _ _ (append_fun id (quot.mk r)),
        @comp_map _ _ _ q _ _ _ (append_fun id (quot.mk r))],
    rw h _ _ r'xy },
  right, exact rxy
end

/-- Bisimulation principle using `liftr` to match and relate children of two trees. -/
theorem cofix.bisim {α : typevec n}
    (r : cofix F α → cofix F α → Prop)
    (h : ∀ x y, r x y → liftr (rel_last α r) (cofix.dest x) (cofix.dest y)) :
  ∀ x y, r x y → x = y :=
begin
  apply cofix.bisim_rel,
  intros x y rxy,
  rcases (liftr_iff (rel_last α r) _ _).mp (h x y rxy) with ⟨a, f₀, f₁, dxeq, dyeq, h'⟩,
  rw [dxeq, dyeq, ←abs_map, ←abs_map, mvpfunctor.map_eq, mvpfunctor.map_eq],
  rw [←split_drop_fun_last_fun f₀, ←split_drop_fun_last_fun f₁],
  rw [append_fun_comp_split_fun, append_fun_comp_split_fun],
  rw [id_comp, id_comp],
  congr' 2 with i j, cases i with _ i; dsimp,
  { apply quot.sound, apply h' _ j },
  { change f₀ _ j = f₁ _ j, apply h' _ j },
end

open mvfunctor

/-- Bisimulation principle using `liftr'` to match and relate children of two trees. -/
theorem cofix.bisim₂ {α : typevec n}
    (r : cofix F α → cofix F α → Prop)
    (h : ∀ x y, r x y → liftr' (rel_last' α r) (cofix.dest x) (cofix.dest y)) :
  ∀ x y, r x y → x = y :=
cofix.bisim _ $ by intros; rw ← liftr_last_rel_iff; apply h; assumption

/-- Bisimulation principle the values `⟨a,f⟩` of the polynomial functor representing
`cofix F α` as well as an invariant `Q : β → Prop` and a state `β` generating the
left-hand side and right-hand side of the equality through functions `u v : β → cofix F α` -/
theorem cofix.bisim' {α : typevec n} {β : Type*} (Q : β → Prop)
  (u v : β → cofix F α)
    (h : ∀ x, Q x → ∃ a f' f₀ f₁,
      cofix.dest (u x) = abs ⟨a, q.P.append_contents f' f₀⟩ ∧
      cofix.dest (v x) = abs ⟨a, q.P.append_contents f' f₁⟩ ∧
      ∀ i, ∃ x', Q x' ∧ f₀ i = u x' ∧ f₁ i = v x') :
  ∀ x, Q x → u x = v x :=
λ x Qx,
let R := λ w z : cofix F α, ∃ x', Q x' ∧ w = u x' ∧ z = v x' in
cofix.bisim R
  (λ x y ⟨x', Qx', xeq, yeq⟩,
    begin
      rcases h x' Qx' with ⟨a, f', f₀, f₁, ux'eq, vx'eq, h'⟩,
      rw liftr_iff,
      refine ⟨a, q.P.append_contents f' f₀, q.P.append_contents f' f₁,
        xeq.symm ▸ ux'eq, yeq.symm ▸ vx'eq, _⟩,
      intro i, cases i,
      { apply h' },
      { intro j, apply eq.refl },
    end)
  _ _ ⟨x, Qx, rfl, rfl⟩

lemma cofix.dest_mk {α : typevec n} (x : F (α.append1 $ cofix F α)) : cofix.dest (cofix.mk x) = x :=
begin
  have : cofix.mk ∘ cofix.dest = @_root_.id (cofix F α) := funext cofix.mk_dest,
  rw [cofix.mk, cofix.dest_corec, ←comp_map, ←cofix.mk, ← append_fun_comp, this, id_comp,
    append_fun_id_id, mvfunctor.id_map]
end

lemma cofix.ext {α : typevec n} (x y : cofix F α) (h : x.dest = y.dest) : x = y :=
by rw [← cofix.mk_dest x,h,cofix.mk_dest]

lemma cofix.ext_mk {α : typevec n} (x y : F (α ::: cofix F α)) (h : cofix.mk x = cofix.mk  y) :
  x = y :=
by rw [← cofix.dest_mk x,h,cofix.dest_mk]

/-!
`liftr_map`, `liftr_map_last` and `liftr_map_last'` are useful for reasoning about
the induction step in bisimulation proofs.
-/

section liftr_map

omit q

theorem liftr_map {α β : typevec n} {F' : typevec n → Type u} [mvfunctor F']
  [is_lawful_mvfunctor F']
  (R : β ⊗ β ⟹ repeat n Prop) (x : F' α) (f g : α ⟹ β)
  (h : α ⟹ subtype_ R)
  (hh : subtype_val _ ⊚ h = (f ⊗' g) ⊚ prod.diag) :
  liftr' R (f <$$> x) (g <$$> x) :=
begin
  rw liftr_def,
  existsi h <$$> x,
  rw [mvfunctor.map_map,comp_assoc,hh,← comp_assoc,fst_prod_mk,comp_assoc,fst_diag],
  rw [mvfunctor.map_map,comp_assoc,hh,← comp_assoc,snd_prod_mk,comp_assoc,snd_diag],
  dsimp [liftr'], split; refl,
end

open function

theorem liftr_map_last [is_lawful_mvfunctor F] {α : typevec n} {ι ι'}
  (R : ι' → ι' → Prop) (x : F (α ::: ι)) (f g : ι → ι')
  (hh : ∀ x : ι, R (f x) (g x)) :
  liftr' (rel_last' _ R) ((id ::: f) <$$> x) ((id ::: g) <$$> x) :=
let h : ι → { x : ι' × ι' // uncurry R x } := λ x, ⟨ (f x,g x), hh x ⟩ in
let b : α ::: ι ⟹ _ := @diag_sub n α ::: h,
    c : subtype_ α.repeat_eq ::: {x // uncurry R x} ⟹
        (λ (i : fin2 (n)), {x // of_repeat (α.rel_last' R i.fs x)}) ::: subtype (uncurry R) :=
      of_subtype _ ::: id
in
have hh : subtype_val _ ⊚ to_subtype _ ⊚ from_append1_drop_last ⊚ c ⊚ b =
          (id ::: f ⊗' id ::: g) ⊚ prod.diag,
  by { dsimp [c,b],
       apply eq_of_drop_last_eq,
       { dsimp,
         simp only [prod_map_id, drop_fun_prod, drop_fun_append_fun, drop_fun_diag, id_comp,
                    drop_fun_to_subtype],
         erw [to_subtype_of_subtype_assoc,id_comp],
         clear_except,
         ext i x : 2, induction i,
         refl,  apply i_ih, },
       simp only [h, last_fun_from_append1_drop_last, last_fun_to_subtype, last_fun_append_fun,
                  last_fun_subtype_val, comp.left_id, last_fun_comp, last_fun_prod],
       dsimp, ext1, refl },
liftr_map _ _ _ _ (to_subtype _ ⊚ from_append1_drop_last ⊚ c ⊚ b) hh

theorem liftr_map_last' [is_lawful_mvfunctor F] {α : typevec n} {ι}
  (R : ι → ι → Prop) (x : F (α ::: ι)) (f : ι → ι)
  (hh : ∀ x : ι, R (f x) x) :
  liftr' (rel_last' _ R) ((id ::: f) <$$> x) x :=
begin
  have := liftr_map_last R x f id hh,
  rwa [append_fun_id_id,mvfunctor.id_map] at this,
end

end liftr_map

lemma cofix.abs_repr {α} (x : cofix F α) :
  quot.mk _ (cofix.repr x) = x :=
begin
  let R := λ x y : cofix F α,
    cofix.abs (cofix.repr y) = x,
  refine cofix.bisim₂ R _ _ _ rfl,
  clear x, rintros x y h, dsimp [R] at h, subst h,
  dsimp [cofix.dest,cofix.abs],
  induction y using quot.ind,
  simp only [cofix.repr, M.dest_corec, abs_map, abs_repr],
  conv { congr, skip, rw cofix.dest },
  dsimp, rw [mvfunctor.map_map,mvfunctor.map_map,← append_fun_comp_id,← append_fun_comp_id],
  let f : α ::: (P F).M α ⟹ subtype_ (α.rel_last' R) :=
    split_fun diag_sub (λ x, ⟨(cofix.abs (cofix.abs x).repr, cofix.abs x),_⟩),
  refine liftr_map _ _ _ _ f _,
  { simp only [←append_prod_append_fun, prod_map_id],
    apply eq_of_drop_last_eq,
    { dsimp, simp only [drop_fun_diag],
      erw subtype_val_diag_sub },
    ext1,
    simp only [cofix.abs, prod.mk.inj_iff, prod_map, function.comp_app, last_fun_append_fun,
               last_fun_subtype_val, last_fun_comp, last_fun_split_fun],
    dsimp [drop_fun_rel_last,last_fun,prod.diag],
    split; refl, },
  dsimp [rel_last',split_fun,function.uncurry,R],
  refl,
end

section tactic

setup_tactic_parser
open tactic
omit q

/-- tactic for proof by bisimulation -/
meta def mv_bisim (e : parse texpr) (ids : parse with_ident_list) : tactic unit :=
do e ← to_expr e,
   (expr.pi n bi d b) ← retrieve $ do
   { generalize e,
     target },
   `(@eq %%t %%l %%r) ← pure b,
   x ← mk_local_def `n d,
   v₀ ← mk_local_def `a t,
   v₁ ← mk_local_def `b t,
   x₀ ← mk_app ``eq [v₀,l.instantiate_var x],
   x₁ ← mk_app ``eq [v₁,r.instantiate_var x],
   xx ← mk_app ``and [x₀,x₁],
   ex ← lambdas [x] xx,
   ex ← mk_app ``Exists [ex] >>= lambdas [v₀,v₁],
   R ← pose `R none ex,
   refine ``(cofix.bisim₂ %%R _ _ _ ⟨_,rfl,rfl⟩),
   let f (a b : name) : name := if a = `_ then b else a,
   let ids := (ids ++ list.repeat `_ 5).zip_with f [`a,`b,`x,`Ha,`Hb],
   (ids₀,w::ids₁) ← pure $ list.split_at 2 ids,
   intro_lst ids₀,
   h ← intro1,
   [(_,[w,h],_)] ← cases_core h [w],
   cases h ids₁,
   pure ()

run_cmd add_interactive [``mv_bisim]

end tactic

theorem corec_roll {α : typevec n} {X Y} {x₀ : X}
  (f : X → Y) (g : Y → F (α ::: X)) :
  cofix.corec (g ∘ f) x₀ = cofix.corec (mvfunctor.map (id ::: f) ∘ g) (f x₀) :=
begin
  mv_bisim x₀,
  rw [Ha,Hb,cofix.dest_corec,cofix.dest_corec],
  rw [mvfunctor.map_map,← append_fun_comp_id],
  refine liftr_map_last _ _ _ _ _,
  intros a, refine ⟨a,rfl,rfl⟩
end

theorem cofix.dest_corec' {α : typevec n} {β : Type u}
  (g : β → F (α.append1 (cofix F α ⊕ β))) (x : β) :
  cofix.dest (cofix.corec' g x) = append_fun id (sum.elim id (cofix.corec' g)) <$$> g x :=
begin
  rw [cofix.corec',cofix.dest_corec], dsimp,
  congr' with (i|i); rw corec_roll; dsimp [cofix.corec'],
  { mv_bisim i,
    rw [Ha,Hb,cofix.dest_corec], dsimp [(∘)],
    repeat { rw [mvfunctor.map_map,← append_fun_comp_id] },
    apply liftr_map_last', dsimp [(∘),R], intros, exact ⟨_,rfl,rfl⟩ },
  { congr' with y, erw [append_fun_id_id], simp [mvfunctor.id_map] },
end

theorem cofix.dest_corec₁ {α : typevec n} {β : Type u}
  (g : Π {X}, (cofix F α → X) → (β → X) → β → F (α.append1 X)) (x : β)
  (h : ∀ X Y (f : cofix F α → X) (f' : β → X) (k : X → Y),
         g (k ∘ f) (k ∘ f') x = (id ::: k) <$$> g f f' x) :
  cofix.dest (cofix.corec₁ @g x) = g id (cofix.corec₁ @g) x :=
by rw [cofix.corec₁,cofix.dest_corec',← h]; refl

instance mvqpf_cofix : mvqpf (cofix F) :=
{ P         := q.P.Mp,
  abs       := λ α, quot.mk Mcongr,
  repr      := λ α, cofix.repr,
  abs_repr  := λ α, cofix.abs_repr,
  abs_map   := λ α β g x, rfl }

end mvqpf


import power_quandle
import group_to_pq

import tactic

universe u

section automorphism_power_quandle

-- TODO: Define automorphism power quandle
-- TODO: Define property of morphism Q → Aut(Q)

structure automorphism (Q : Type u) [power_quandle Q] : Type u :=
(f : Q → Q)
(finv : Q → Q)
(hf : is_pq_morphism f)
(hfinv : is_pq_morphism finv)
(hffinv : f ∘ finv = id)
(hfinvf : finv ∘ f = id)

variables {Q : Type u} [power_quandle Q]

def automorphism_inverse (φ : automorphism Q) : automorphism Q := automorphism.mk
(automorphism.finv φ)
(automorphism.f φ)
(automorphism.hfinv φ)
(automorphism.hf φ)
(automorphism.hfinvf φ)
(automorphism.hffinv φ)

def automorphism_comp (φ1 : automorphism Q) (φ2 : automorphism Q) : automorphism Q := automorphism.mk
(automorphism.f φ1 ∘ automorphism.f φ2)
(automorphism.finv φ2 ∘ automorphism.finv φ1)
(begin
    cases φ1,
    cases φ2,
    simp,
    apply pq_morphism_comp,
    assumption,
    assumption,
end)
(begin
    cases φ1,
    cases φ2,
    simp,
    apply pq_morphism_comp,
    assumption,
    assumption,
end)
(begin
    cases φ1,
    cases φ2,
    simp,
    have assoc_rw : (φ1_f ∘ φ2_f) ∘ φ2_finv ∘ φ1_finv = φ1_f ∘ (φ2_f ∘ φ2_finv) ∘ φ1_finv,
    {
        repeat {rw function.comp.assoc},
    },
    rw assoc_rw,
    rw φ2_hffinv,
    simp,
    rw φ1_hffinv,
end)
(begin
    cases φ1,
    cases φ2,
    simp,
    have assoc_rw : (φ2_finv ∘ φ1_finv) ∘ φ1_f ∘ φ2_f = φ2_finv ∘ (φ1_finv ∘ φ1_f) ∘ φ2_f,
    {
        repeat {rw function.comp.assoc},
    },
    rw assoc_rw,
    rw φ1_hfinvf,
    simp,
    rw φ2_hfinvf,
end)

def id_automorphism : automorphism Q := automorphism.mk
(id)
(id)
(id_is_pq_morphism)
(id_is_pq_morphism)
(rfl)
(rfl)

lemma automorphism_eq (f1 : automorphism Q) (f2 : automorphism Q) : f1 = f2 ↔ automorphism.f f1 = automorphism.f f2 ∧ automorphism.finv f1 = automorphism.finv f2 :=
begin
    split,
    {
        intro hf,
        split,
        rw hf,
        rw hf,
    },
    {
        intro hf_pre,
        cases hf_pre with hf hfinv,
        induction f1,
        induction f2,
        simp,
        simp at hf,
        simp at hfinv,
        split,
        assumption,
        assumption,
    },
end

instance automorphism_has_mul : has_mul (automorphism Q) := ⟨automorphism_comp⟩

instance automorphism_has_one : has_one (automorphism Q) := ⟨id_automorphism⟩

instance automorphism_has_inv : has_inv (automorphism Q) := ⟨automorphism_inverse⟩

lemma automorphism_f_of_comp (f1 : automorphism Q) (f2 : automorphism Q) : (f1 * f2).f = f1.f ∘ f2.f := rfl
lemma automorphism_finv_of_comp (f1 : automorphism Q) (f2 : automorphism Q) : (f1 * f2).finv = f2.finv ∘ f1.finv := rfl

lemma automorphism_f_of_inverse (f1 : automorphism Q) : f1⁻¹.f = f1.finv := rfl
lemma automorphism_finv_of_inverse (f1 : automorphism Q) : f1⁻¹.finv = f1.f := rfl

lemma automorphism_f_of_id : (id_automorphism : automorphism Q).f = id := rfl
lemma automorphism_finv_of_id : (id_automorphism : automorphism Q).finv = id := rfl

lemma automorphism_comp_assoc : ∀ f1 f2 f3 : automorphism Q, f1 * f2 * f3 = f1 * (f2 * f3) :=
begin
    intros f1 f2 f3,
    refl,
end

lemma automorphism_one_mul : ∀ f1 : automorphism Q, 1 * f1 = f1 :=
begin
    intro f1,
    cases f1,
    refl,
end

lemma automorphism_mul_one : ∀ f1 : automorphism Q, f1 * 1 = f1 :=
begin
    intro f1,
    cases f1,
    refl,
end

lemma automorphism_mul_left_inv : ∀ f1 : automorphism Q, f1⁻¹ * f1 = 1 :=
begin
    intro f1,
    rw automorphism_eq,
    split,
    {
        rw automorphism_f_of_comp,
        rw automorphism_f_of_inverse,
        rw f1.hfinvf,
        refl,
    },
    {
        rw automorphism_finv_of_comp,
        rw automorphism_finv_of_inverse,
        rw f1.hfinvf,
        refl,
    },
end

instance automorphism_group : group (automorphism Q) := group.mk
(automorphism_comp)
(automorphism_comp_assoc)
(id_automorphism)
(automorphism_one_mul)
(automorphism_mul_one)
(automorphism_inverse)
(automorphism_mul_left_inv)

instance automorphism_power_quandle : power_quandle (automorphism Q) := group_is_power_quandle

end automorphism_power_quandle

section automorphism_power_quandle_morphism

variables {Q : Type u} [power_quandle Q]

def element_automorphism (a : Q) : automorphism Q := automorphism.mk
(λ b, a ▷ b)
(λ b, b ◁ a)
(begin
    split,
    {
        intros x y,
        simp,
        apply power_quandle.rhd_dist,
    },
    {
        intros x n,
        simp,
        apply eq.symm,
        apply power_quandle.pow_rhd,
    },
end)
(begin
    split,
    {
        intros x y,
        simp,
        repeat {rw power_quandle.q_powneg_left},
        apply power_quandle.rhd_dist,

    },
    {
        intros x n,
        simp,
        apply eq.symm,
        apply lhd_pow,
    },
end)
(begin
    apply funext,
    intro x,
    simp,
    apply rhd_lhd,
end)
(begin
    apply funext,
    intro x,
    simp,
    apply lhd_rhd,
end)

lemma element_automorphism_f (a : Q) : (element_automorphism a).f = λ b, a ▷ b := rfl
lemma element_automorphism_finv (a : Q) : (element_automorphism a).finv = λ b, b ◁ a := rfl

lemma element_automorphism_is_pq_morphism : is_pq_morphism (element_automorphism : Q → automorphism Q) :=
begin
    split,
    {
        intros a b,
        rw automorphism_eq,
        split,
        {
            rw rhd_def_group,
            rw automorphism_f_of_comp,
            rw automorphism_f_of_comp,
            rw automorphism_f_of_inverse,
            repeat {rw element_automorphism_f},
            rw element_automorphism_finv,
            apply funext,
            intro x,
            simp only [function.comp_app],
            rw ←rhd_lhd a x,
            rw ←power_quandle.rhd_dist,
            rw rhd_lhd,
        },
        {
            rw rhd_def_group,
            rw automorphism_finv_of_comp,
            rw automorphism_finv_of_comp,
            rw automorphism_finv_of_inverse,
            repeat {rw element_automorphism_finv},
            rw element_automorphism_f,
            apply funext,
            intro x,
            simp only [function.comp_app],
            rw lhd_rhd_pow,
            rw power_quandle.pow_rhd,
            rw ←rhd_lhd a x,
            rw ←power_quandle.rhd_dist,
            rw rhd_lhd,
            repeat {rw lhd_rhd_pow},
        },
    },
    {
        intros a n,
        induction n,
        {
            induction n with m hm,
            {
                have id_rw : element_automorphism a ^ int.of_nat 0 = id_automorphism,
                {
                    refl,
                },
                rw id_rw,
                rw automorphism_eq,
                split,
                {
                    rw element_automorphism_f,
                    rw automorphism_f_of_id,
                    apply funext,
                    intro x,
                    simp only [int.coe_nat_zero, id.def, int.of_nat_eq_coe],
                    rw power_quandle.pow_zero,
                    rw power_quandle.one_rhd,
                },
                {
                    rw element_automorphism_finv,
                    rw automorphism_finv_of_id,
                    apply funext,
                    intro x,
                    simp only [int.coe_nat_zero, id.def, int.of_nat_eq_coe],
                    rw power_quandle.pow_zero,
                    rw lhd_one,
                },
            },
            {
                --rw pow_of_nat,
                simp only [int.coe_nat_succ, int.of_nat_eq_coe],
                rw gpow_add_one,
                simp only [int.of_nat_eq_coe, gpow_coe_nat] at hm,
                simp only [gpow_coe_nat],
                rw ←hm,
                rw automorphism_eq,
                split,
                {
                    rw automorphism_f_of_comp,
                    repeat {rw element_automorphism_f},
                    apply funext,
                    intro x,
                    simp only [function.comp_app],
                    rw ←power_quandle.pow_one a,
                    rw power_quandle.pow_comp,
                    rw power_quandle.pow_comp,
                    rw power_quandle.rhd_pow_add,
                    simp only [one_mul],
                },
                {
                    rw automorphism_finv_of_comp,
                    repeat {rw element_automorphism_finv},
                    apply funext,
                    intro x,
                    simp only [function.comp_app],
                    rw ←power_quandle.pow_one a,
                    rw power_quandle.pow_comp,
                    rw power_quandle.pow_comp,
                    rw lhd_pow_add,
                    simp only [one_mul],
                    rw int.add_comm,
                },
            },
        },
        {
            induction n with m hm,
            {
                rw automorphism_eq,
                split,
                {
                    --rw pow_neg_succ_of_nat,
                    --rw pow_1_nat_group,
                    simp only [nat.nat_zero_eq_zero, gpow_neg_succ_of_nat, pow_one],
                    rw automorphism_f_of_inverse,
                    rw element_automorphism_finv,
                    rw element_automorphism_f,
                    apply funext,
                    intro x,
                    rw lhd_rhd_pow,
                    refl,
                },
                {
                    --rw pow_neg_succ_of_nat,
                    --rw pow_1_nat_group,
                    simp only [nat.nat_zero_eq_zero, gpow_neg_succ_of_nat, pow_one],
                    rw automorphism_finv_of_inverse,
                    rw element_automorphism_f,
                    rw element_automorphism_finv,
                    apply funext,
                    intro x,
                    rw lhd_rhd_pow,
                    rw ←power_quandle.pow_one a,
                    rw power_quandle.pow_comp,
                    rw power_quandle.pow_comp,
                    apply congr_arg (λ y, y ▷ x),
                    apply congr_arg,
                    refl,
                },
            },
            {
                --rw pow_neg_succ_of_nat_succ,
                have ar_rw : -[1+ m.succ] = -[1+ m] - 1 := rfl,
                rw ar_rw,
                rw gpow_sub_one,
                rw ←hm,
                rw automorphism_eq,
                split,
                {
                    rw automorphism_f_of_comp,
                    rw automorphism_f_of_inverse,
                    repeat {rw element_automorphism_f},
                    rw element_automorphism_finv,
                    apply funext,
                    intro x,
                    simp only [function.comp_app],
                    rw lhd_rhd_pow,
                    rw power_quandle.rhd_pow_add,
                    apply congr_arg (λ y, y ▷ x),
                    apply congr_arg,
                    refl,
                },
                {
                    rw automorphism_finv_of_comp,
                    rw automorphism_finv_of_inverse,
                    repeat {rw element_automorphism_finv},
                    rw element_automorphism_f,
                    apply funext,
                    intro x,
                    simp only [function.comp_app],
                    rw lhd_rhd_pow,
                    rw lhd_rhd_pow,
                    rw ←power_quandle.pow_one a,
                    repeat {rw power_quandle.pow_comp},
                    rw power_quandle.rhd_pow_add,
                    apply congr_arg (λ y, y ▷ x),
                    apply congr_arg,
                    ring,
                },
            },
        },
    },
end

end automorphism_power_quandle_morphism


/-
Copyright (c) 2022 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov

! This file was ported from Lean 3 source module order.monotone.odd
! leanprover-community/mathlib commit c3291da49cfa65f0d43b094750541c0731edc932
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Order.Monotone.Union
import Mathbin.Algebra.Order.Group.Instances

/-!
# Monotonicity of odd functions

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

An odd function on a linear ordered additive commutative group `G` is monotone on the whole group
provided that is is monotone on `set.Ici 0`, see `monotone_of_odd_of_monotone_on_nonneg`. We also
prove versions of this lemma for `antitone`, `strict_mono`, and `strict_anti`.
-/

open Set

variable {G H : Type _} [LinearOrderedAddCommGroup G] [OrderedAddCommGroup H]

/- warning: strict_mono_of_odd_strict_mono_on_nonneg -> strictMono_of_odd_strictMonoOn_nonneg is a dubious translation:
lean 3 declaration is
  forall {G : Type.{u1}} {H : Type.{u2}} [_inst_1 : LinearOrderedAddCommGroup.{u1} G] [_inst_2 : OrderedAddCommGroup.{u2} H] {f : G -> H}, (forall (x : G), Eq.{succ u2} H (f (Neg.neg.{u1} G (SubNegMonoid.toHasNeg.{u1} G (AddGroup.toSubNegMonoid.{u1} G (AddCommGroup.toAddGroup.{u1} G (OrderedAddCommGroup.toAddCommGroup.{u1} G (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} G _inst_1))))) x)) (Neg.neg.{u2} H (SubNegMonoid.toHasNeg.{u2} H (AddGroup.toSubNegMonoid.{u2} H (AddCommGroup.toAddGroup.{u2} H (OrderedAddCommGroup.toAddCommGroup.{u2} H _inst_2)))) (f x))) -> (StrictMonoOn.{u1, u2} G H (PartialOrder.toPreorder.{u1} G (OrderedAddCommGroup.toPartialOrder.{u1} G (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} G _inst_1))) (PartialOrder.toPreorder.{u2} H (OrderedAddCommGroup.toPartialOrder.{u2} H _inst_2)) f (Set.Ici.{u1} G (PartialOrder.toPreorder.{u1} G (OrderedAddCommGroup.toPartialOrder.{u1} G (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} G _inst_1))) (OfNat.ofNat.{u1} G 0 (OfNat.mk.{u1} G 0 (Zero.zero.{u1} G (AddZeroClass.toHasZero.{u1} G (AddMonoid.toAddZeroClass.{u1} G (SubNegMonoid.toAddMonoid.{u1} G (AddGroup.toSubNegMonoid.{u1} G (AddCommGroup.toAddGroup.{u1} G (OrderedAddCommGroup.toAddCommGroup.{u1} G (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} G _inst_1)))))))))))) -> (StrictMono.{u1, u2} G H (PartialOrder.toPreorder.{u1} G (OrderedAddCommGroup.toPartialOrder.{u1} G (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} G _inst_1))) (PartialOrder.toPreorder.{u2} H (OrderedAddCommGroup.toPartialOrder.{u2} H _inst_2)) f)
but is expected to have type
  forall {G : Type.{u1}} {H : Type.{u2}} [_inst_1 : LinearOrderedAddCommGroup.{u1} G] [_inst_2 : OrderedAddCommGroup.{u2} H] {f : G -> H}, (forall (x : G), Eq.{succ u2} H (f (Neg.neg.{u1} G (NegZeroClass.toNeg.{u1} G (SubNegZeroMonoid.toNegZeroClass.{u1} G (SubtractionMonoid.toSubNegZeroMonoid.{u1} G (SubtractionCommMonoid.toSubtractionMonoid.{u1} G (AddCommGroup.toDivisionAddCommMonoid.{u1} G (OrderedAddCommGroup.toAddCommGroup.{u1} G (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} G _inst_1))))))) x)) (Neg.neg.{u2} H (NegZeroClass.toNeg.{u2} H (SubNegZeroMonoid.toNegZeroClass.{u2} H (SubtractionMonoid.toSubNegZeroMonoid.{u2} H (SubtractionCommMonoid.toSubtractionMonoid.{u2} H (AddCommGroup.toDivisionAddCommMonoid.{u2} H (OrderedAddCommGroup.toAddCommGroup.{u2} H _inst_2)))))) (f x))) -> (StrictMonoOn.{u1, u2} G H (PartialOrder.toPreorder.{u1} G (OrderedAddCommGroup.toPartialOrder.{u1} G (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} G _inst_1))) (PartialOrder.toPreorder.{u2} H (OrderedAddCommGroup.toPartialOrder.{u2} H _inst_2)) f (Set.Ici.{u1} G (PartialOrder.toPreorder.{u1} G (OrderedAddCommGroup.toPartialOrder.{u1} G (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} G _inst_1))) (OfNat.ofNat.{u1} G 0 (Zero.toOfNat0.{u1} G (NegZeroClass.toZero.{u1} G (SubNegZeroMonoid.toNegZeroClass.{u1} G (SubtractionMonoid.toSubNegZeroMonoid.{u1} G (SubtractionCommMonoid.toSubtractionMonoid.{u1} G (AddCommGroup.toDivisionAddCommMonoid.{u1} G (OrderedAddCommGroup.toAddCommGroup.{u1} G (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} G _inst_1))))))))))) -> (StrictMono.{u1, u2} G H (PartialOrder.toPreorder.{u1} G (OrderedAddCommGroup.toPartialOrder.{u1} G (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} G _inst_1))) (PartialOrder.toPreorder.{u2} H (OrderedAddCommGroup.toPartialOrder.{u2} H _inst_2)) f)
Case conversion may be inaccurate. Consider using '#align strict_mono_of_odd_strict_mono_on_nonneg strictMono_of_odd_strictMonoOn_nonnegₓ'. -/
/-- An odd function on a linear ordered additive commutative group is strictly monotone on the whole
group provided that it is strictly monotone on `set.Ici 0`. -/
theorem strictMono_of_odd_strictMonoOn_nonneg {f : G → H} (h₁ : ∀ x, f (-x) = -f x)
    (h₂ : StrictMonoOn f (Ici 0)) : StrictMono f :=
  by
  refine' StrictMonoOn.Iic_union_Ici (fun x hx y hy hxy => neg_lt_neg_iff.1 _) h₂
  rw [← h₁, ← h₁]
  exact h₂ (neg_nonneg.2 hy) (neg_nonneg.2 hx) (neg_lt_neg hxy)
#align strict_mono_of_odd_strict_mono_on_nonneg strictMono_of_odd_strictMonoOn_nonneg

/- warning: strict_anti_of_odd_strict_anti_on_nonneg -> strictAnti_of_odd_strictAntiOn_nonneg is a dubious translation:
lean 3 declaration is
  forall {G : Type.{u1}} {H : Type.{u2}} [_inst_1 : LinearOrderedAddCommGroup.{u1} G] [_inst_2 : OrderedAddCommGroup.{u2} H] {f : G -> H}, (forall (x : G), Eq.{succ u2} H (f (Neg.neg.{u1} G (SubNegMonoid.toHasNeg.{u1} G (AddGroup.toSubNegMonoid.{u1} G (AddCommGroup.toAddGroup.{u1} G (OrderedAddCommGroup.toAddCommGroup.{u1} G (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} G _inst_1))))) x)) (Neg.neg.{u2} H (SubNegMonoid.toHasNeg.{u2} H (AddGroup.toSubNegMonoid.{u2} H (AddCommGroup.toAddGroup.{u2} H (OrderedAddCommGroup.toAddCommGroup.{u2} H _inst_2)))) (f x))) -> (StrictAntiOn.{u1, u2} G H (PartialOrder.toPreorder.{u1} G (OrderedAddCommGroup.toPartialOrder.{u1} G (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} G _inst_1))) (PartialOrder.toPreorder.{u2} H (OrderedAddCommGroup.toPartialOrder.{u2} H _inst_2)) f (Set.Ici.{u1} G (PartialOrder.toPreorder.{u1} G (OrderedAddCommGroup.toPartialOrder.{u1} G (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} G _inst_1))) (OfNat.ofNat.{u1} G 0 (OfNat.mk.{u1} G 0 (Zero.zero.{u1} G (AddZeroClass.toHasZero.{u1} G (AddMonoid.toAddZeroClass.{u1} G (SubNegMonoid.toAddMonoid.{u1} G (AddGroup.toSubNegMonoid.{u1} G (AddCommGroup.toAddGroup.{u1} G (OrderedAddCommGroup.toAddCommGroup.{u1} G (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} G _inst_1)))))))))))) -> (StrictAnti.{u1, u2} G H (PartialOrder.toPreorder.{u1} G (OrderedAddCommGroup.toPartialOrder.{u1} G (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} G _inst_1))) (PartialOrder.toPreorder.{u2} H (OrderedAddCommGroup.toPartialOrder.{u2} H _inst_2)) f)
but is expected to have type
  forall {G : Type.{u1}} {H : Type.{u2}} [_inst_1 : LinearOrderedAddCommGroup.{u1} G] [_inst_2 : OrderedAddCommGroup.{u2} H] {f : G -> H}, (forall (x : G), Eq.{succ u2} H (f (Neg.neg.{u1} G (NegZeroClass.toNeg.{u1} G (SubNegZeroMonoid.toNegZeroClass.{u1} G (SubtractionMonoid.toSubNegZeroMonoid.{u1} G (SubtractionCommMonoid.toSubtractionMonoid.{u1} G (AddCommGroup.toDivisionAddCommMonoid.{u1} G (OrderedAddCommGroup.toAddCommGroup.{u1} G (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} G _inst_1))))))) x)) (Neg.neg.{u2} H (NegZeroClass.toNeg.{u2} H (SubNegZeroMonoid.toNegZeroClass.{u2} H (SubtractionMonoid.toSubNegZeroMonoid.{u2} H (SubtractionCommMonoid.toSubtractionMonoid.{u2} H (AddCommGroup.toDivisionAddCommMonoid.{u2} H (OrderedAddCommGroup.toAddCommGroup.{u2} H _inst_2)))))) (f x))) -> (StrictAntiOn.{u1, u2} G H (PartialOrder.toPreorder.{u1} G (OrderedAddCommGroup.toPartialOrder.{u1} G (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} G _inst_1))) (PartialOrder.toPreorder.{u2} H (OrderedAddCommGroup.toPartialOrder.{u2} H _inst_2)) f (Set.Ici.{u1} G (PartialOrder.toPreorder.{u1} G (OrderedAddCommGroup.toPartialOrder.{u1} G (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} G _inst_1))) (OfNat.ofNat.{u1} G 0 (Zero.toOfNat0.{u1} G (NegZeroClass.toZero.{u1} G (SubNegZeroMonoid.toNegZeroClass.{u1} G (SubtractionMonoid.toSubNegZeroMonoid.{u1} G (SubtractionCommMonoid.toSubtractionMonoid.{u1} G (AddCommGroup.toDivisionAddCommMonoid.{u1} G (OrderedAddCommGroup.toAddCommGroup.{u1} G (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} G _inst_1))))))))))) -> (StrictAnti.{u1, u2} G H (PartialOrder.toPreorder.{u1} G (OrderedAddCommGroup.toPartialOrder.{u1} G (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} G _inst_1))) (PartialOrder.toPreorder.{u2} H (OrderedAddCommGroup.toPartialOrder.{u2} H _inst_2)) f)
Case conversion may be inaccurate. Consider using '#align strict_anti_of_odd_strict_anti_on_nonneg strictAnti_of_odd_strictAntiOn_nonnegₓ'. -/
/-- An odd function on a linear ordered additive commutative group is strictly antitone on the whole
group provided that it is strictly antitone on `set.Ici 0`. -/
theorem strictAnti_of_odd_strictAntiOn_nonneg {f : G → H} (h₁ : ∀ x, f (-x) = -f x)
    (h₂ : StrictAntiOn f (Ici 0)) : StrictAnti f :=
  @strictMono_of_odd_strictMonoOn_nonneg G Hᵒᵈ _ _ _ h₁ h₂
#align strict_anti_of_odd_strict_anti_on_nonneg strictAnti_of_odd_strictAntiOn_nonneg

/- warning: monotone_of_odd_of_monotone_on_nonneg -> monotone_of_odd_of_monotoneOn_nonneg is a dubious translation:
lean 3 declaration is
  forall {G : Type.{u1}} {H : Type.{u2}} [_inst_1 : LinearOrderedAddCommGroup.{u1} G] [_inst_2 : OrderedAddCommGroup.{u2} H] {f : G -> H}, (forall (x : G), Eq.{succ u2} H (f (Neg.neg.{u1} G (SubNegMonoid.toHasNeg.{u1} G (AddGroup.toSubNegMonoid.{u1} G (AddCommGroup.toAddGroup.{u1} G (OrderedAddCommGroup.toAddCommGroup.{u1} G (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} G _inst_1))))) x)) (Neg.neg.{u2} H (SubNegMonoid.toHasNeg.{u2} H (AddGroup.toSubNegMonoid.{u2} H (AddCommGroup.toAddGroup.{u2} H (OrderedAddCommGroup.toAddCommGroup.{u2} H _inst_2)))) (f x))) -> (MonotoneOn.{u1, u2} G H (PartialOrder.toPreorder.{u1} G (OrderedAddCommGroup.toPartialOrder.{u1} G (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} G _inst_1))) (PartialOrder.toPreorder.{u2} H (OrderedAddCommGroup.toPartialOrder.{u2} H _inst_2)) f (Set.Ici.{u1} G (PartialOrder.toPreorder.{u1} G (OrderedAddCommGroup.toPartialOrder.{u1} G (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} G _inst_1))) (OfNat.ofNat.{u1} G 0 (OfNat.mk.{u1} G 0 (Zero.zero.{u1} G (AddZeroClass.toHasZero.{u1} G (AddMonoid.toAddZeroClass.{u1} G (SubNegMonoid.toAddMonoid.{u1} G (AddGroup.toSubNegMonoid.{u1} G (AddCommGroup.toAddGroup.{u1} G (OrderedAddCommGroup.toAddCommGroup.{u1} G (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} G _inst_1)))))))))))) -> (Monotone.{u1, u2} G H (PartialOrder.toPreorder.{u1} G (OrderedAddCommGroup.toPartialOrder.{u1} G (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} G _inst_1))) (PartialOrder.toPreorder.{u2} H (OrderedAddCommGroup.toPartialOrder.{u2} H _inst_2)) f)
but is expected to have type
  forall {G : Type.{u1}} {H : Type.{u2}} [_inst_1 : LinearOrderedAddCommGroup.{u1} G] [_inst_2 : OrderedAddCommGroup.{u2} H] {f : G -> H}, (forall (x : G), Eq.{succ u2} H (f (Neg.neg.{u1} G (NegZeroClass.toNeg.{u1} G (SubNegZeroMonoid.toNegZeroClass.{u1} G (SubtractionMonoid.toSubNegZeroMonoid.{u1} G (SubtractionCommMonoid.toSubtractionMonoid.{u1} G (AddCommGroup.toDivisionAddCommMonoid.{u1} G (OrderedAddCommGroup.toAddCommGroup.{u1} G (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} G _inst_1))))))) x)) (Neg.neg.{u2} H (NegZeroClass.toNeg.{u2} H (SubNegZeroMonoid.toNegZeroClass.{u2} H (SubtractionMonoid.toSubNegZeroMonoid.{u2} H (SubtractionCommMonoid.toSubtractionMonoid.{u2} H (AddCommGroup.toDivisionAddCommMonoid.{u2} H (OrderedAddCommGroup.toAddCommGroup.{u2} H _inst_2)))))) (f x))) -> (MonotoneOn.{u1, u2} G H (PartialOrder.toPreorder.{u1} G (OrderedAddCommGroup.toPartialOrder.{u1} G (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} G _inst_1))) (PartialOrder.toPreorder.{u2} H (OrderedAddCommGroup.toPartialOrder.{u2} H _inst_2)) f (Set.Ici.{u1} G (PartialOrder.toPreorder.{u1} G (OrderedAddCommGroup.toPartialOrder.{u1} G (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} G _inst_1))) (OfNat.ofNat.{u1} G 0 (Zero.toOfNat0.{u1} G (NegZeroClass.toZero.{u1} G (SubNegZeroMonoid.toNegZeroClass.{u1} G (SubtractionMonoid.toSubNegZeroMonoid.{u1} G (SubtractionCommMonoid.toSubtractionMonoid.{u1} G (AddCommGroup.toDivisionAddCommMonoid.{u1} G (OrderedAddCommGroup.toAddCommGroup.{u1} G (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} G _inst_1))))))))))) -> (Monotone.{u1, u2} G H (PartialOrder.toPreorder.{u1} G (OrderedAddCommGroup.toPartialOrder.{u1} G (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} G _inst_1))) (PartialOrder.toPreorder.{u2} H (OrderedAddCommGroup.toPartialOrder.{u2} H _inst_2)) f)
Case conversion may be inaccurate. Consider using '#align monotone_of_odd_of_monotone_on_nonneg monotone_of_odd_of_monotoneOn_nonnegₓ'. -/
/-- An odd function on a linear ordered additive commutative group is monotone on the whole group
provided that it is monotone on `set.Ici 0`. -/
theorem monotone_of_odd_of_monotoneOn_nonneg {f : G → H} (h₁ : ∀ x, f (-x) = -f x)
    (h₂ : MonotoneOn f (Ici 0)) : Monotone f :=
  by
  refine' MonotoneOn.Iic_union_Ici (fun x hx y hy hxy => neg_le_neg_iff.1 _) h₂
  rw [← h₁, ← h₁]
  exact h₂ (neg_nonneg.2 hy) (neg_nonneg.2 hx) (neg_le_neg hxy)
#align monotone_of_odd_of_monotone_on_nonneg monotone_of_odd_of_monotoneOn_nonneg

/- warning: antitone_of_odd_of_monotone_on_nonneg -> antitone_of_odd_of_monotoneOn_nonneg is a dubious translation:
lean 3 declaration is
  forall {G : Type.{u1}} {H : Type.{u2}} [_inst_1 : LinearOrderedAddCommGroup.{u1} G] [_inst_2 : OrderedAddCommGroup.{u2} H] {f : G -> H}, (forall (x : G), Eq.{succ u2} H (f (Neg.neg.{u1} G (SubNegMonoid.toHasNeg.{u1} G (AddGroup.toSubNegMonoid.{u1} G (AddCommGroup.toAddGroup.{u1} G (OrderedAddCommGroup.toAddCommGroup.{u1} G (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} G _inst_1))))) x)) (Neg.neg.{u2} H (SubNegMonoid.toHasNeg.{u2} H (AddGroup.toSubNegMonoid.{u2} H (AddCommGroup.toAddGroup.{u2} H (OrderedAddCommGroup.toAddCommGroup.{u2} H _inst_2)))) (f x))) -> (AntitoneOn.{u1, u2} G H (PartialOrder.toPreorder.{u1} G (OrderedAddCommGroup.toPartialOrder.{u1} G (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} G _inst_1))) (PartialOrder.toPreorder.{u2} H (OrderedAddCommGroup.toPartialOrder.{u2} H _inst_2)) f (Set.Ici.{u1} G (PartialOrder.toPreorder.{u1} G (OrderedAddCommGroup.toPartialOrder.{u1} G (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} G _inst_1))) (OfNat.ofNat.{u1} G 0 (OfNat.mk.{u1} G 0 (Zero.zero.{u1} G (AddZeroClass.toHasZero.{u1} G (AddMonoid.toAddZeroClass.{u1} G (SubNegMonoid.toAddMonoid.{u1} G (AddGroup.toSubNegMonoid.{u1} G (AddCommGroup.toAddGroup.{u1} G (OrderedAddCommGroup.toAddCommGroup.{u1} G (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} G _inst_1)))))))))))) -> (Antitone.{u1, u2} G H (PartialOrder.toPreorder.{u1} G (OrderedAddCommGroup.toPartialOrder.{u1} G (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} G _inst_1))) (PartialOrder.toPreorder.{u2} H (OrderedAddCommGroup.toPartialOrder.{u2} H _inst_2)) f)
but is expected to have type
  forall {G : Type.{u1}} {H : Type.{u2}} [_inst_1 : LinearOrderedAddCommGroup.{u1} G] [_inst_2 : OrderedAddCommGroup.{u2} H] {f : G -> H}, (forall (x : G), Eq.{succ u2} H (f (Neg.neg.{u1} G (NegZeroClass.toNeg.{u1} G (SubNegZeroMonoid.toNegZeroClass.{u1} G (SubtractionMonoid.toSubNegZeroMonoid.{u1} G (SubtractionCommMonoid.toSubtractionMonoid.{u1} G (AddCommGroup.toDivisionAddCommMonoid.{u1} G (OrderedAddCommGroup.toAddCommGroup.{u1} G (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} G _inst_1))))))) x)) (Neg.neg.{u2} H (NegZeroClass.toNeg.{u2} H (SubNegZeroMonoid.toNegZeroClass.{u2} H (SubtractionMonoid.toSubNegZeroMonoid.{u2} H (SubtractionCommMonoid.toSubtractionMonoid.{u2} H (AddCommGroup.toDivisionAddCommMonoid.{u2} H (OrderedAddCommGroup.toAddCommGroup.{u2} H _inst_2)))))) (f x))) -> (AntitoneOn.{u1, u2} G H (PartialOrder.toPreorder.{u1} G (OrderedAddCommGroup.toPartialOrder.{u1} G (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} G _inst_1))) (PartialOrder.toPreorder.{u2} H (OrderedAddCommGroup.toPartialOrder.{u2} H _inst_2)) f (Set.Ici.{u1} G (PartialOrder.toPreorder.{u1} G (OrderedAddCommGroup.toPartialOrder.{u1} G (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} G _inst_1))) (OfNat.ofNat.{u1} G 0 (Zero.toOfNat0.{u1} G (NegZeroClass.toZero.{u1} G (SubNegZeroMonoid.toNegZeroClass.{u1} G (SubtractionMonoid.toSubNegZeroMonoid.{u1} G (SubtractionCommMonoid.toSubtractionMonoid.{u1} G (AddCommGroup.toDivisionAddCommMonoid.{u1} G (OrderedAddCommGroup.toAddCommGroup.{u1} G (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} G _inst_1))))))))))) -> (Antitone.{u1, u2} G H (PartialOrder.toPreorder.{u1} G (OrderedAddCommGroup.toPartialOrder.{u1} G (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} G _inst_1))) (PartialOrder.toPreorder.{u2} H (OrderedAddCommGroup.toPartialOrder.{u2} H _inst_2)) f)
Case conversion may be inaccurate. Consider using '#align antitone_of_odd_of_monotone_on_nonneg antitone_of_odd_of_monotoneOn_nonnegₓ'. -/
/-- An odd function on a linear ordered additive commutative group is antitone on the whole group
provided that it is monotone on `set.Ici 0`. -/
theorem antitone_of_odd_of_monotoneOn_nonneg {f : G → H} (h₁ : ∀ x, f (-x) = -f x)
    (h₂ : AntitoneOn f (Ici 0)) : Antitone f :=
  @monotone_of_odd_of_monotoneOn_nonneg G Hᵒᵈ _ _ _ h₁ h₂
#align antitone_of_odd_of_monotone_on_nonneg antitone_of_odd_of_monotoneOn_nonneg


import tactic
import tukey

open function set

namespace ultrafilter

@[ext]structure filter (α : Type*) :=
(sets : set (set α))
(univ_sets : univ ∈ sets)
(sets_of_superset {A B} : (A ∈ sets) → (A ⊆ B) → B ∈ sets)
(inter_sets {A B} : A ∈ sets → B ∈ sets → A ∩ B ∈ sets)

variable {α : Type*}

instance : has_mem (set α) (filter α) := ⟨λ A F, A ∈ F.sets⟩
instance : has_le (filter α) := ⟨λ F G, F.sets ⊆ G.sets⟩
instance : partial_order (filter α) :=
{
	le := has_le.le,
	le_refl := λ (a : filter α), rfl.subset,
	le_trans := λ a b c hab hbc, subset.trans hab hbc,
	le_antisymm :=
	begin
		intros a b hab hba,
		ext,
		exact {mp := @hab x, mpr := @hba x},
	end
}

lemma filter_le_iff (F G : filter α) : F ≤ G ↔ F.sets ⊆ G.sets := iff.refl _

@[simp] lemma mem_filter_iff (x) (F : filter α) : x ∈ F.sets ↔ x ∈ F := iff.refl _

lemma filter_eq (f g : filter α) : f.sets = g.sets ↔ f = g :=
(filter.ext_iff f g).symm

lemma fin_inter_sets {F : filter α} {C : set (set α)} (C_ss : C ⊆ F.sets) (C_fin : C.finite) :
⋂₀ C ∈ F :=
begin
	suffices : ∀(C_ss : C ⊆ F.sets), ⋂₀ C ∈ F,
	{ exact this C_ss },
	apply set.finite.induction_on C_fin,
	{
		simp,
		exact F.univ_sets,
	},
	{
		intros a s has s_fin hs has,
		have : ⋂₀ insert a s = a ∩ ⋂₀ s := by finish,
		rw this, clear this,
		have haF : a ∈ F := has (mem_insert a s),
		specialize hs (λ x hx, has (mem_insert_of_mem _ hx)),
		exact F.inter_sets haF hs,
	}
end

def fip (A : set (set α)) : Prop := ∀ ⦃B⦄, B ⊆ A → B.finite → ⋂₀ B ≠ ∅

lemma fip_of_subset_fip {A B : set (set α)} (hAB : A ⊆ B) (B_fip : fip B) : fip A :=
λ C hCA C_fin, B_fip (subset.trans hCA hAB) C_fin

def proper_filter (F : filter α) : Prop := ∅ ∉ F

lemma proper_iff_not_univ (F : filter α) : proper_filter F ↔ F.sets ≠ univ :=
begin
	split,
	{
		intros h contra,
		apply h,
		unfold has_mem.mem, rw contra,
		exact trivial,
	},
	{
		intros h contra,
		apply h,
		ext x, split, intro h, exact trivial,
		intro _,
		exact F.sets_of_superset contra (empty_subset x),
	}
end

lemma fip_iff_proper_filter (F : filter α) : fip F.sets ↔ proper_filter F :=
begin
	split; intro h,
	{
		intro contra,
		have : {∅} ⊆ F.sets := by rwa singleton_subset_iff,
		apply h this (finite_singleton ∅),
		rw sInter_singleton,
	},
	{
		intros A A_ss A_fin contra,
		have := fin_inter_sets A_ss A_fin,
		rw contra at this,
		exact h this,
	},
end

def filter_containing (A : set (set α)) : filter α :=
{
	sets := {B : set α | ∃(C) (C_ss : C ⊆ A) (C_fin : C.finite), ⋂₀ C ⊆ B},
	univ_sets := begin
		simp,
		use [∅, empty_subset A, finite_empty],
	end,
	sets_of_superset := begin
		simp,
		intros B₁ B₂ C C_ss C_fin interC_ss B_ss,
		use [C, C_ss, C_fin, subset.trans interC_ss B_ss],
	end,
	inter_sets :=
	begin
		intros A₁ A₂ hA₁ hA₂,
		simp at *,

		rcases hA₁ with ⟨C₁, C₁_ss, C₁_fin, hC₁⟩,
		rcases hA₂ with ⟨C₂, C₂_ss, C₂_fin, hC₂⟩,
		use [C₁ ∪ C₂, union_subset C₁_ss C₂_ss, finite.union C₁_fin C₂_fin],
		split,
		{
			intros x hx,
			apply hC₁,
			intros t ht,
			apply hx,
			exact or.inl ht,
		},
		{
			intros x hx,
			apply hC₂,
			intros t ht,
			apply hx,
			exact or.inr ht,
		},
	end,
}

@[simp] lemma mem_filter_containing (A : set (set α)) (x : set α) :
x ∈ filter_containing A ↔ x ∈ {B : set α | ∃(C) (C_ss : C ⊆ A) (C_fin : C.finite), ⋂₀ C ⊆ B}
:= iff.refl _

lemma subset_of_filter_containing (A : set (set α)) : A ⊆ (filter_containing A).sets :=
λ x _, ⟨{x}, by finish⟩

lemma smallest_filter_containing {A : set (set α)} : ∀(F : filter α),
A ⊆ F.sets → (filter_containing A) ≤ F :=
begin
	intros F h_ss B hB,
	rcases hB with ⟨C, C_ss, C_fin, hC⟩,
	have hCF := fin_inter_sets (subset.trans C_ss h_ss) C_fin,
	exact F.sets_of_superset hCF hC,
end

lemma filter_containing_proper_iff (A : set (set α)) :
proper_filter (filter_containing A) ↔ fip A :=
begin
	split,
	{
		intros h C hCA C_fin contra,
		apply h, rw ←contra,
		use [C, hCA, C_fin, subset_refl _],
	},
	{
		intros A_fip contra,
		rcases contra with ⟨C, C_ss, C_fin, hC⟩,
		apply A_fip C_ss C_fin,
		rwa subset_empty_iff at hC,
	},
end

def ultrafilter (F : filter α) := proper_filter F ∧ (∀A, A ∈ F ∨ Aᶜ ∈ F)
def maximal_proper_filter (F : filter α) := proper_filter F ∧
 ∀{G : filter α}, proper_filter G → F ≤ G → F = G

 lemma not_mem_ultrafilter_iff {F : filter α} (h : ultrafilter F) (x) : x ∉ F ↔ xᶜ ∈ F :=
 begin
	split,
	{ have := (h.2) x, tauto },
	{
		intros hx contra,
		apply h.1,
		have : x ∩ xᶜ = ∅ := by finish,
		rw ←this,
		exact F.inter_sets contra hx
	},
 end

 lemma fip_insert_of_proper_filter {F : filter α} (F_proper : proper_filter F) (x : set α) :
 fip (insert x F.sets) ∨ fip (insert xᶜ F.sets) :=
 begin
	suffices : (∀{y}, y ∈ F → y ∩ x ≠ ∅) ∨ (∀{y}, y ∈ F → y ∩ xᶜ ≠ ∅),
	{
		have h_wlog : ∀x : set α, (∀{z}, z ∈ F → z ∩ x ≠ ∅) → fip (insert x F.sets),
		{
			clear this x,
			intros x hA₁ A A_ss A_fin hA₂,
			have hxA : x ∈ A,
			{
				by_contra,
				have A_ss_F : A ⊆ F.sets,
				{
					intros y hy,
					have := A_ss hy,
					cases this, exfalso, rw this at hy, exact h hy,
					exact this,
				},
				have := fin_inter_sets A_ss_F A_fin,
				rw hA₂ at this,
				apply F_proper,
				exact this,
			},
			have triv : A = (A \ {x}) ∪ {x},
			{
				ext y,
				split;finish
			},
			rw [triv, sInter_union, sInter_singleton] at hA₂, clear triv,
			have A'_ss : A \ {x} ⊆ F.sets,
			{
				intros y hy,
				simp at hy,
				have := A_ss hy.1,
				simp at this ⊢,
				tauto,
			},
			have A'_fin : (A \ {x}).finite := finite.diff A_fin _,
			have hA'F := fin_inter_sets A'_ss A'_fin,
			exact hA₁ hA'F hA₂,
		},
		cases this,
		{ exact or.inl (h_wlog _ @this) },
		{ exact or.inr (h_wlog _ @this) },
	},

	by_contra h, push_neg at h,
	rcases h with ⟨⟨Y₁, Y₁F, Y₁_empty⟩, ⟨Y₂, Y₂F, Y₂_empty⟩⟩,
	have contra : Y₁ ∩ Y₂ = ∅,
	{
		rw eq_empty_iff_forall_not_mem at *,
		intros y hy,
		by_cases y ∈ x,
		{ exact Y₁_empty _ ⟨hy.1, h⟩ },
		{ exact Y₂_empty _ ⟨hy.2, h⟩ },
	},
	have inter_sets := F.inter_sets Y₁F Y₂F,
	rw contra at inter_sets,
	exact F_proper inter_sets,
 end

lemma ultrafilter_iff_maximal_proper_filter (F : filter α) :
ultrafilter F ↔ maximal_proper_filter F :=
begin
	split,
	{
		intros h, use [h.1],
		intros G G_proper hFG,
		apply le_antisymm, exact hFG,
		intros x hxG, simp,
		by_contra contra,
		apply G_proper,
		rw not_mem_ultrafilter_iff h x at contra,
		have contra1 := G.inter_sets hxG (hFG contra),
		have : x ∩ xᶜ = ∅ := by finish,
		rwa ←this,
	},
	{
		intro hF, use hF.1, intros x, by_contra hx, push_neg at hx,
		have hfip := fip_insert_of_proper_filter hF.1 x,
		cases hfip,
		{
			have F_le : F ≤ filter_containing (insert x F.sets),
			{
				intros y hy,
				exact subset_of_filter_containing _ (mem_insert_of_mem _ hy),
			},
			have := (filter_containing_proper_iff _).mpr hfip,
			have := (hF.2 this) F_le,
			apply hx.1,
			rw this,
			apply subset_of_filter_containing,
			exact mem_insert _ _,
		},
		{
			have F_le : F ≤ filter_containing (insert xᶜ F.sets),
			{
				intros y hy,
				exact subset_of_filter_containing _ (mem_insert_of_mem _ hy),
			},
			have := (filter_containing_proper_iff _).mpr hfip,
			have := (hF.2 this) F_le,
			apply hx.2,
			rw this,
			apply subset_of_filter_containing,
			exact mem_insert _ _,
		},
	}
end

theorem ultrafilter_of_proper_filter {F : filter α} (F_proper : proper_filter F) :
∃ {U : filter α} (hFU : F.sets ⊆ U.sets), ultrafilter U :=
begin
	have F_fip : fip F.sets := by finish[(@fip_iff_proper_filter _ F).mpr F_proper],
	have := @exists_maximal_of_finite_character _ {G : set (set α) | fip G} F.sets F_fip _,
	swap,
	{
		exact λ G,
		⟨
			λ G_fip _ Y_ss Y_fin A A_ss A_fin, G_fip (subset.trans A_ss Y_ss) A_fin,
			λ hG _ A_ss A_fin, @hG _ A_ss A_fin _ (subset_refl _) A_fin
		⟩
	},

	rcases this with ⟨U_sets, U_fip, hFU, U_max⟩,
	have U_filter : (filter_containing U_sets).sets = U_sets,
	{
		apply U_max, swap, exact subset_of_filter_containing U_sets,
		simp,
		rwa [fip_iff_proper_filter, filter_containing_proper_iff],
	},
	use filter_containing U_sets,
	rw U_filter,
	use hFU,
	rw ultrafilter_iff_maximal_proper_filter,
	use by rwa [←fip_iff_proper_filter, U_filter],

	intros G G_proper hG,
	unfold has_le.le at hG, rw U_filter at hG,
	rw ←fip_iff_proper_filter at G_proper,
	rw [←filter_eq, U_filter, eq_comm],
	exact U_max G_proper hG,
end

theorem ultrafilter_of_fip {A : set (set α)} (A_fip : fip A) :
∃(U : filter α) (hAU : A ⊆ U.sets), ultrafilter U :=
begin
	rcases ultrafilter_of_proper_filter ((filter_containing_proper_iff _).mpr A_fip)
	with ⟨U, hAU, hU⟩,
	exact ⟨U, subset_trans (subset_of_filter_containing A) hAU, hU⟩,
end

end ultrafilter


import NBG.SetTheory.Defs
import NBG.SetTheory.Axioms.Difference

open Classical

-- 4. AxiomPair
axiom AxiomPair :
  ∀x y: Class, Set x → Set y
    → ∃z: Class,
      (z∈U) ∧ (∀u: Class, (u∈z ↔ (u ＝ x ∨ u ＝ y)))
noncomputable def Pair_mk (X Y: Class) [hx: Set X] [hy: Set Y] : Class :=
  choose (AxiomPair X Y hx hy)
noncomputable def Pair_def (X Y: Class) [hx: Set X] [hy: Set Y] :=
  choose_spec (AxiomPair X Y hx hy)
noncomputable def Pair_is_Set (X Y: Class) [Set X] [Set Y] : Set (Pair_mk X Y) :=
  Set.mk₂ (Pair_def X Y).1

-- singleton def
theorem SingletonSetExists (X: Class) [hx: Set X]:
  ∃z: Class,
    (z∈U) ∧ (∀u: Class, (u∈z ↔ (u ＝ X))) := by {
  exists (Pair_mk X X);
  apply And.intro;
  {exact (Pair_is_Set X X).2;}
  {
    intro u;
    have h := (Pair_def X X).2 u;
    apply Iff.trans h;
    apply Iff.intro;
    {
      intro h;
      cases h;
      case mp.inl h => exact h;
      case mp.inr h => exact h;
    }
    {exact fun h => (Or.inl h);}
  }
}
noncomputable def Singleton_mk (X: Class) [Set X]: Class :=
  choose (SingletonSetExists X)
noncomputable def Singleton_def (X: Class) [Set X]:
  ((Singleton_mk X) ∈ U) ∧ (∀u: Class, (u ∈ (Singleton_mk X) ↔ (u ＝ X))) :=
  choose_spec (SingletonSetExists X)
noncomputable def Singleton_is_Set (X: Class) [Set X]: Set (Singleton_mk X) :=
  Set.mk₂ (Singleton_def X).1

notation "{"x"}" => Singleton_mk x
notation "{"x","y"}" => Pair_mk x y

def isSingleton (X : Class) :=
  ∃x: Class, ∀u: Class, u∈X ↔ u＝x
class Singleton (X : Class) :=
  isSingleton: isSingleton X
def isPair (X : Class) :=
  ∃x y: Class, ∀u: Class, u∈X ↔ u＝x ∨ u＝y
class Pair (X : Class) :=
  isPair: isPair X

-- ordered pair
noncomputable def OrdPair_mk (X Y: Class) [Set X] [Set Y] : Class :=
  @Pair_mk {X} {X, Y} (Singleton_is_Set X) (Pair_is_Set X Y)
noncomputable def OrdPair_def (X Y: Class) [Set X] [Set Y] :=
  @Pair_def {X} {X, Y} (Singleton_is_Set X) (Pair_is_Set X Y)
noncomputable def OrdPair_is_Set (X Y: Class) [Set X] [Set Y] : Set (OrdPair_mk X Y) :=
  @Pair_is_Set {X} {X, Y} (Singleton_is_Set X) (Pair_is_Set X Y)
notation "＜"x","y"＞" => OrdPair_mk x y

noncomputable def OrdTriple_mk (X Y Z: Class) [Set X] [Set Y] [Set Z] : Class :=
  @OrdPair_mk ＜X, Y＞ Z (OrdPair_is_Set X Y) _
noncomputable def OrdTriple_def (X Y Z: Class) [Set X] [Set Y] [Set Z] :=
  @OrdPair_def ＜X, Y＞ Z (OrdPair_is_Set X Y) _
noncomputable def OrdTriple_is_Set (X Y Z: Class) [Set X] [Set Y] [Set Z]: Set (OrdTriple_mk X Y Z) :=
  @OrdPair_is_Set ＜X, Y＞ Z (OrdPair_is_Set X Y) _

-- ordered triple
notation "＜"x","y","z"＞" => OrdTriple_mk x y z

-- singleton
theorem SingletonIntro (x: Class) [Set x]:
  ∀u: Class, (u ∈ (Singleton_mk x) ↔ u ＝ x) :=
  fun u => (Singleton_def x).2 u

theorem SingletonSingleton (x y: Class) [Set x] [Set y]:
  {x} ＝ {y} ↔ x ＝ y:= by {
  apply Iff.intro;
  {
    intro h;
    rw [AxiomExtensionality] at h;
    have hx := (h x);
    rw [SingletonIntro, SingletonIntro] at hx;
    exact hx.1 (ClassEq.refl x);
  }
  {
    intro h;
    rw [AxiomExtensionality];
    intro z;
    apply Iff.trans ((Singleton_def x).2 z);
    apply Iff.trans _ ((Singleton_def y).2 z).symm;
    apply Iff.intro;
    {exact fun h' => ClassEq.trans h' h;}
    {exact fun h' => ClassEq.trans h' (ClassEq.symm h);}
  }
}

-- pair
theorem PairIntro (X Y: Class) [Set X] [Set Y]:
  ∀u: Class, (u ∈ (Pair_mk X Y) ↔ (u ＝ X ∨ u ＝ Y)) := (Pair_def X Y).2

theorem PairSymm (x y: Class) [Set x] [Set y]:
  {x, y} ＝ {y, x} := by {
    rw [AxiomExtensionality];
    intro z;
    rw [PairIntro, PairIntro];
    apply Iff.intro;
    {
      intro h;
      cases h;
      case mp.inl h => {exact Or.inr h;}
      case mp.inr h => {exact Or.inl h;}
    }
    {
      intro h;
      cases h;
      case mpr.inl h => {exact Or.inr h;}
      case mpr.inr h => {exact Or.inl h;}
    }
}

theorem SingletonEqSelfPair (x: Class) [Set x]:
  {x} ＝ {x, x} := by {
  rw [AxiomExtensionality];
  intro z;
  rw [SingletonIntro, PairIntro];
  apply Iff.intro;
  {exact fun h => Or.inr h;}
  {
    intro h;
    cases h;
    case mpr.inl h => {exact h;}
    case mpr.inr h => {exact h;}
  }
}

theorem SingletonPair {x y z: Class} [Set x] [Set y] [Set z]:
  {x} ＝ {y, z} ↔ x ＝ y ∧ x ＝ z:= by {
  apply Iff.intro;
  {
    intro h;
    rw [AxiomExtensionality] at h;
    have hy := h y;
    rw [SingletonIntro,PairIntro] at hy;
    have hy := ClassEq.symm (hy.2 (Or.inl (ClassEq.refl y)));
    have hz := h z;
    rw [SingletonIntro,PairIntro] at hz;
    have hz := ClassEq.symm (hz.2 (Or.inr (ClassEq.refl z)));
    exact ⟨hy,hz⟩;
  }
  {
    intro h;
    rw [AxiomExtensionality];
    intro u;
    rw [SingletonIntro,PairIntro];
    apply Iff.intro;
    {exact fun h'=> Or.inl (ClassEq.trans h' h.1);}
    {
      intro h';
      cases h';
      case mpr.mpr.inl h' => {exact ClassEq.trans h' (ClassEq.symm h.1);}
      case mpr.mpr.inr h' => {exact ClassEq.trans h' (ClassEq.symm h.2);}
    }
  }
}

-- -- ordered pair
theorem OrdPairIntro (x y: Class) [Set x] [Set y]:
  ∀u: Class, (u∈＜x, y＞ ↔ (u ＝ {x} ∨ u ＝ {x,y})) :=
  fun u => (@Pair_def {x} {x,y} (Singleton_is_Set x) (Pair_is_Set x y)).2 u

theorem OrdPairEq₁ {x y u v: Class} [Set x] [Set y] [Set u] [Set v]:
  (x ＝ u) →  (y ＝ v) → (＜x,y＞ ＝ ＜u,v＞) := by {
  intro h1 h2;
  rw [AxiomExtensionality];
  intro z;
  rw [OrdPairIntro,OrdPairIntro];
  apply Iff.intro;
  case mp => {
    intro h3;
    cases h3;
    case inl h3 => {
      rw [←SingletonSingleton] at h1;
      exact Or.inl (ClassEq.trans h3 h1);
    }
    case inr h3 => {
      apply Or.inr;
      apply ClassEq.trans h3;
      rw [AxiomExtensionality];
      intro z;
      rw [PairIntro, PairIntro];
      apply Iff.intro;
      {
        intro h;
        cases h;
        case h.mp.inl h => {exact Or.inl (ClassEq.trans h h1);}
        case h.mp.inr h => {exact Or.inr (ClassEq.trans h h2);}
      }
      {
        intro h;
        cases h;
        case h.mpr.inl h => {exact Or.inl (ClassEq.trans h (ClassEq.symm h1));}
        case h.mpr.inr h => {exact Or.inr (ClassEq.trans h (ClassEq.symm h2));}
      }
    }
  }
  case mpr => {
    intro h3;
    cases h3;
    case inl h3 => {
      rw [←SingletonSingleton] at h1;
      exact Or.inl (ClassEq.trans h3 (ClassEq.symm h1));
    }
    case inr h3 => {
      apply Or.inr;
      apply ClassEq.trans h3;
      rw [AxiomExtensionality];
      intro z;
      rw [PairIntro, PairIntro];
      apply Iff.intro;
      {
        intro h;
        cases h;
        case h.mp.inl h => {exact Or.inl (ClassEq.trans h (ClassEq.symm h1));}
        case h.mp.inr h => {exact Or.inr (ClassEq.trans h (ClassEq.symm h2));}
      }
      {
        intro h;
        cases h;
        case h.mpr.inl h => {exact Or.inl (ClassEq.trans h h1);}
        case h.mpr.inr h => {exact Or.inr (ClassEq.trans h h2);}
      }
    }
  }
}

theorem OrdPairEq₂ {x y: Class} [Set x] [Set y]:
  x ＝ y → (∀(z: Class), (z ＝ {x} ∨ z ＝ {x, y}) ↔ (z ＝ {x})) := by {
  intro h z;
  apply Iff.intro;
  {
    intro hz;
    cases hz;
    case mp.inl hz => {exact hz}
    case mp.inr hz => {
      apply ClassEq.trans hz;
      rw [AxiomExtensionality];
      intro z;
      rw [SingletonIntro, PairIntro];
      apply Iff.intro;
      case mp => {
        intro h';
        cases h';
        case inl h' => {exact h';}
        case inr h' => {exact ClassEq.trans h' (ClassEq.symm h);}
      }
      case mpr => {exact fun h => Or.inl h;}
    }
  }
  {exact fun hz => Or.inl hz;}
}

theorem OrdPairEq {x y u v: Class} [Set x] [Set y] [Set u] [Set v]:
  (＜x,y＞ ＝ ＜u,v＞) ↔ (x ＝ u ∧ y ＝ v) := by {
  apply Iff.intro;
  {
    intro h;
    rw [AxiomExtensionality] at h;
    have h : ∀(z: Class),
      (z ＝ {x} ∨ z ＝ {x,y}) ↔ (z ＝ {u} ∨ z ＝ {u,v}) := by {
      intro z;
      rw [←OrdPairIntro,←OrdPairIntro];
      exact h z;
    };
    by_cases hxu : (x ＝ u);
    {
      have hyv : (y ＝ v) := by {
        by_cases hxy : (x ＝ y);
        {
          have h : ∀(z: Class), (z ＝ {u} ∨ z ＝ {u,v}) ↔ (z ＝ {x}) :=
            fun z => (Iff.trans (h z).symm (OrdPairEq₂ hxy z));
          have h' := ClassEq.symm ((h {u, v}).1 (Or.inr (ClassEq.refl {u,v})));
          rw [SingletonPair] at h';
          exact ClassEq.trans (ClassEq.symm hxy) h'.2;
        }
        {
          have h' := (h {x,y}).1 (Or.inr (ClassEq.refl {x,y}));
          cases h';
          case inr.inl h' => {
            have h' := SingletonPair.1 (ClassEq.symm h');
            have hxy' := ClassEq.trans (ClassEq.symm h'.1) h'.2;
            contradiction;
          }
          case inr.inr h' => {
            rw [AxiomExtensionality] at h';
            have hy := h' y;
            rw [PairIntro, PairIntro] at hy;
            have hy := hy.1 (Or.inr (ClassEq.refl y));
            cases hy;
            case inl hy => {
              have hxy' := ClassEq.trans hxu (ClassEq.symm hy);
              contradiction;
            }
            case inr hy => {exact hy;}
          }
        }
      }
      exact ⟨hxu, hyv⟩;
    }
    {
      have hx := (h {x}).1 (Or.inl (ClassEq.refl _));
      cases hx;
      case mp.inr.inl hx => {
        rw [SingletonSingleton] at hx;
        contradiction;
      }
      case mp.inr.inr hx => {
        rw [SingletonPair] at hx;
        have := hx.1;
        contradiction;
      }
    }
  }
  {exact fun h => OrdPairEq₁ h.1 h.2;}
}

theorem OrdTripleEq {x y z u v w: Class} [Set x] [Set y] [Set z] [Set u] [Set v] [Set w]:
  (＜x,y,z＞ ＝ ＜u,v,w＞) ↔ (x ＝ u ∧ y ＝ v ∧ z ＝ w) := by {
  have hxy := OrdPair_is_Set x y;
  have huv := OrdPair_is_Set u v;
  have h1 := @OrdPairEq ＜x, y＞ z ＜u,v＞ w;
  have h2 := @OrdPairEq x y u v;
  apply Iff.trans h1;
  rw [h2];
  apply Iff.intro;
  {exact fun h => ⟨h.1.1,⟨h.1.2,h.2⟩⟩;}
  {exact fun h => ⟨⟨h.1,h.2.1⟩,h.2.2⟩}
}


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison

! This file was ported from Lean 3 source module category_theory.functor.fully_faithful
! leanprover-community/mathlib commit 70d50ecfd4900dd6d328da39ab7ebd516abe4025
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.CategoryTheory.NatIso
import Mathlib.Logic.Equiv.Defs
import Mathlib.Tactic.Choose

/-!
# Full and faithful functors

We define typeclasses `Full` and `Faithful`, decorating functors.

## Main definitions and results
* Use `F.map_injective` to retrieve the fact that `F.map` is injective when `[Faithful F]`.
* Similarly, `F.map_surjective` states that `F.map` is surjective when `[Full F]`.
* Use `F.preimage` to obtain preimages of morphisms when `[Full F]`.
* We prove some basic "cancellation" lemmas for full and/or faithful functors, as well as a
  construction for "dividing" a functor by a faithful functor, see `Faithful.div`.
* `Full F` carries data, so definitional properties of the preimage can be used when using
  `F.preimage`. To obtain an instance of `Full F` non-constructively, you can use `fullOfExists`
  and `fullOfSurjective`.

See `CategoryTheory.Equivalence.of_fullyFaithful_ess_surj` for the fact that a functor is an
equivalence if and only if it is fully faithful and essentially surjective.

-/

-- declare the `v`'s first; see `CategoryTheory.Category` for an explanation
universe v₁ v₂ v₃ u₁ u₂ u₃

namespace CategoryTheory

variable {C : Type u₁} [Category.{v₁} C] {D : Type u₂} [Category.{v₂} D]

/-- A functor `F : C ⥤ D` is full if for each `X Y : C`, `F.map` is surjective.
In fact, we use a constructive definition, so the `Full F` typeclass contains data,
specifying a particular preimage of each `f : F.obj X ⟶ F.obj Y`.

See <https://stacks.math.columbia.edu/tag/001C>.
-/
class Full (F : C ⥤ D) where
  /-- The data of a preimage for every `f : F.obj X ⟶ F.obj Y`. -/
  preimage : ∀ {X Y : C} (_ : F.obj X ⟶ F.obj Y), X ⟶ Y
  /-- The property that `Full.preimage f` of maps to `f` via `F.map`. -/
  witness : ∀ {X Y : C} (f : F.obj X ⟶ F.obj Y), F.map (preimage f) = f := by aesop_cat
#align category_theory.full CategoryTheory.Full
#align category_theory.full.witness CategoryTheory.Full.witness

attribute [simp] Full.witness

/- ./././Mathport/Syntax/Translate/Command.lean:379:30: infer kinds are unsupported in Lean 4:
#[`map_injective'] [] -/
/-- A functor `F : C ⥤ D` is faithful if for each `X Y : C`, `F.map` is injective.

See <https://stacks.math.columbia.edu/tag/001C>.
-/
class Faithful (F : C ⥤ D) : Prop where
  /-- `F.map` is injective for each `X Y : C`. -/
  map_injective : ∀ {X Y : C}, Function.Injective (F.map : (X ⟶ Y) → (F.obj X ⟶ F.obj Y)) := by
    aesop_cat
#align category_theory.faithful CategoryTheory.Faithful
#align category_theory.faithful.map_injective CategoryTheory.Faithful.map_injective

namespace Functor

variable {X Y : C}

theorem map_injective (F : C ⥤ D) [Faithful F] :
    Function.Injective <| (F.map : (X ⟶ Y) → (F.obj X ⟶ F.obj Y)) :=
  Faithful.map_injective
#align category_theory.functor.map_injective CategoryTheory.Functor.map_injective

theorem mapIso_injective (F : C ⥤ D) [Faithful F] :
    Function.Injective <| (F.mapIso : (X ≅ Y) → (F.obj X ≅ F.obj Y))  := fun _ _ h =>
  Iso.ext (map_injective F (congr_arg Iso.hom h : _))
#align category_theory.functor.map_iso_injective CategoryTheory.Functor.mapIso_injective

/-- The specified preimage of a morphism under a full functor. -/
def preimage (F : C ⥤ D) [Full F] (f : F.obj X ⟶ F.obj Y) : X ⟶ Y :=
  Full.preimage.{v₁, v₂} f
#align category_theory.functor.preimage CategoryTheory.Functor.preimage

@[simp]
theorem image_preimage (F : C ⥤ D) [Full F] {X Y : C} (f : F.obj X ⟶ F.obj Y) :
    F.map (preimage F f) = f := by unfold preimage; aesop_cat
#align category_theory.functor.image_preimage CategoryTheory.Functor.image_preimage

theorem map_surjective (F : C ⥤ D) [Full F] :
    Function.Surjective (F.map : (X ⟶ Y) → (F.obj X ⟶ F.obj Y)) :=
  fun f => ⟨F.preimage f, F.image_preimage f⟩
#align category_theory.functor.map_surjective CategoryTheory.Functor.map_surjective

/-- Deduce that `F` is full from the existence of preimages, using choice. -/
noncomputable def fullOfExists (F : C ⥤ D)
    (h : ∀ (X Y : C) (f : F.obj X ⟶ F.obj Y), ∃ p, F.map p = f) : Full F := by
  choose p hp using h
  exact ⟨@p, @hp⟩
#align category_theory.functor.full_of_exists CategoryTheory.Functor.fullOfExists

/-- Deduce that `F` is full from surjectivity of `F.map`, using choice. -/
noncomputable def fullOfSurjective (F : C ⥤ D)
    (h : ∀ X Y : C, Function.Surjective (F.map : (X ⟶ Y) → (F.obj X ⟶ F.obj Y))) : Full F :=
  fullOfExists _ h
#align category_theory.functor.full_of_surjective CategoryTheory.Functor.fullOfSurjective

end Functor

section

variable {F : C ⥤ D} [Full F] [Faithful F] {X Y Z : C}

@[simp]
theorem preimage_id : F.preimage (𝟙 (F.obj X)) = 𝟙 X :=
  F.map_injective (by simp)
#align category_theory.preimage_id CategoryTheory.preimage_id

@[simp]
theorem preimage_comp (f : F.obj X ⟶ F.obj Y) (g : F.obj Y ⟶ F.obj Z) :
    F.preimage (f ≫ g) = F.preimage f ≫ F.preimage g :=
  F.map_injective (by simp)
#align category_theory.preimage_comp CategoryTheory.preimage_comp

@[simp]

variable (F)

namespace Functor

/-- If `F : C ⥤ D` is fully faithful, every isomorphism `F.obj X ≅ F.obj Y` has a preimage. -/
@[simps]
def preimageIso (f : F.obj X ≅ F.obj Y) :
    X ≅ Y where
  hom := F.preimage f.hom
  inv := F.preimage f.inv
  hom_inv_id := F.map_injective (by simp)
  inv_hom_id := F.map_injective (by simp)
#align category_theory.functor.preimage_iso CategoryTheory.Functor.preimageIso
#align category_theory.functor.preimage_iso_inv CategoryTheory.Functor.preimageIso_inv
#align category_theory.functor.preimage_iso_hom CategoryTheory.Functor.preimageIso_hom

@[simp]
theorem preimageIso_mapIso (f : X ≅ Y) : F.preimageIso (F.mapIso f) = f := by
  ext
  simp
#align category_theory.functor.preimage_iso_map_iso CategoryTheory.Functor.preimageIso_mapIso

end Functor

/-- If the image of a morphism under a fully faithful functor in an isomorphism,
then the original morphisms is also an isomorphism.
-/
theorem isIso_of_fully_faithful (f : X ⟶ Y) [IsIso (F.map f)] : IsIso f :=
  ⟨⟨F.preimage (inv (F.map f)), ⟨F.map_injective (by simp), F.map_injective (by simp)⟩⟩⟩
#align category_theory.is_iso_of_fully_faithful CategoryTheory.isIso_of_fully_faithful

/-- If `F` is fully faithful, we have an equivalence of hom-sets `X ⟶ Y` and `F X ⟶ F Y`. -/
@[simps]
def equivOfFullyFaithful {X Y} :
    (X ⟶ Y) ≃ (F.obj X ⟶ F.obj Y) where
  toFun f := F.map f
  invFun f := F.preimage f
  left_inv f := by simp
  right_inv f := by simp
#align category_theory.equiv_of_fully_faithful CategoryTheory.equivOfFullyFaithful
#align category_theory.equiv_of_fully_faithful_apply CategoryTheory.equivOfFullyFaithful_apply
#align category_theory.equiv_of_fully_faithful_symm_apply CategoryTheory.equivOfFullyFaithful_symm_apply

/-- If `F` is fully faithful, we have an equivalence of iso-sets `X ≅ Y` and `F X ≅ F Y`. -/
@[simps]
def isoEquivOfFullyFaithful {X Y} :
    (X ≅ Y) ≃ (F.obj X ≅ F.obj Y) where
  toFun f := F.mapIso f
  invFun f := F.preimageIso f
  left_inv f := by simp
  right_inv f := by
    ext
    simp
#align category_theory.iso_equiv_of_fully_faithful CategoryTheory.isoEquivOfFullyFaithful
#align category_theory.iso_equiv_of_fully_faithful_symm_apply CategoryTheory.isoEquivOfFullyFaithful_symm_apply
#align category_theory.iso_equiv_of_fully_faithful_apply CategoryTheory.isoEquivOfFullyFaithful_apply

end

section

variable {E : Type _} [Category E] {F G : C ⥤ D} (H : D ⥤ E) [Full H] [Faithful H]

/-- We can construct a natural transformation between functors by constructing a
natural transformation between those functors composed with a fully faithful functor. -/
@[simps]
def natTransOfCompFullyFaithful (α : F ⋙ H ⟶ G ⋙ H) :
    F ⟶ G where
  app X := (equivOfFullyFaithful H).symm (α.app X)
  naturality X Y f := by
    dsimp
    apply H.map_injective
    simpa using α.naturality f
#align category_theory.nat_trans_of_comp_fully_faithful CategoryTheory.natTransOfCompFullyFaithful
#align category_theory.nat_trans_of_comp_fully_faithful_app CategoryTheory.natTransOfCompFullyFaithful_app

/-- We can construct a natural isomorphism between functors by constructing a natural isomorphism
between those functors composed with a fully faithful functor. -/
@[simps!]
def natIsoOfCompFullyFaithful (i : F ⋙ H ≅ G ⋙ H) : F ≅ G :=
  NatIso.ofComponents (fun X => (isoEquivOfFullyFaithful H).symm (i.app X)) fun f => by
    dsimp
    apply H.map_injective
    simpa using i.hom.naturality f
#align category_theory.nat_iso_of_comp_fully_faithful CategoryTheory.natIsoOfCompFullyFaithful
#align category_theory.nat_iso_of_comp_fully_faithful_hom_app CategoryTheory.natIsoOfCompFullyFaithful_hom_app
#align category_theory.nat_iso_of_comp_fully_faithful_inv_app CategoryTheory.natIsoOfCompFullyFaithful_inv_app

theorem natIsoOfCompFullyFaithful_hom (i : F ⋙ H ≅ G ⋙ H) :
    (natIsoOfCompFullyFaithful H i).hom = natTransOfCompFullyFaithful H i.hom := by
  ext
  simp [natIsoOfCompFullyFaithful]
#align category_theory.nat_iso_of_comp_fully_faithful_hom CategoryTheory.natIsoOfCompFullyFaithful_hom

theorem natIsoOfCompFullyFaithful_inv (i : F ⋙ H ≅ G ⋙ H) :
    (natIsoOfCompFullyFaithful H i).inv = natTransOfCompFullyFaithful H i.inv := by
  ext
  simp [← preimage_comp]
#align category_theory.nat_iso_of_comp_fully_faithful_inv CategoryTheory.natIsoOfCompFullyFaithful_inv

/-- Horizontal composition with a fully faithful functor induces a bijection on
natural transformations. -/
@[simps]
def NatTrans.equivOfCompFullyFaithful :
    (F ⟶ G) ≃ (F ⋙ H ⟶ G ⋙ H) where
  toFun α := α ◫ 𝟙 H
  invFun := natTransOfCompFullyFaithful H
  left_inv := by aesop_cat
  right_inv := by aesop_cat
#align category_theory.nat_trans.equiv_of_comp_fully_faithful CategoryTheory.NatTrans.equivOfCompFullyFaithful
#align category_theory.nat_trans.equiv_of_comp_fully_faithful_apply CategoryTheory.NatTrans.equivOfCompFullyFaithful_apply
#align category_theory.nat_trans.equiv_of_comp_fully_faithful_symm_apply CategoryTheory.NatTrans.equivOfCompFullyFaithful_symm_apply

/-- Horizontal composition with a fully faithful functor induces a bijection on
natural isomorphisms. -/
@[simps]
def NatIso.equivOfCompFullyFaithful :
    (F ≅ G) ≃ (F ⋙ H ≅ G ⋙ H) where
  toFun e := NatIso.hcomp e (Iso.refl H)
  invFun := natIsoOfCompFullyFaithful H
  left_inv := by aesop_cat
  right_inv := by aesop_cat
#align category_theory.nat_iso.equiv_of_comp_fully_faithful CategoryTheory.NatIso.equivOfCompFullyFaithful
#align category_theory.nat_iso.equiv_of_comp_fully_faithful_symm_apply CategoryTheory.NatIso.equivOfCompFullyFaithful_symm_apply
#align category_theory.nat_iso.equiv_of_comp_fully_faithful_apply CategoryTheory.NatIso.equivOfCompFullyFaithful_apply

end

end CategoryTheory

namespace CategoryTheory

variable {C : Type u₁} [Category.{v₁} C]

instance Full.id : Full (𝟭 C) where preimage f := f
#align category_theory.full.id CategoryTheory.Full.id

instance Faithful.id : Faithful (𝟭 C) := { }
#align category_theory.faithful.id CategoryTheory.Faithful.id

variable {D : Type u₂} [Category.{v₂} D] {E : Type u₃} [Category.{v₃} E]

variable (F F' : C ⥤ D) (G : D ⥤ E)

instance Faithful.comp [Faithful F] [Faithful G] :
    Faithful (F ⋙ G) where map_injective p := F.map_injective (G.map_injective p)
#align category_theory.faithful.comp CategoryTheory.Faithful.comp

theorem Faithful.of_comp [Faithful <| F ⋙ G] : Faithful F :=
  -- Porting note: (F ⋙ G).map_injective.of_comp has the incorrect type
  { map_injective := fun {_ _} => Function.Injective.of_comp (F ⋙ G).map_injective }
#align category_theory.faithful.of_comp CategoryTheory.Faithful.of_comp

section

variable {F F'}

/-- If `F` is full, and naturally isomorphic to some `F'`, then `F'` is also full. -/
def Full.ofIso [Full F] (α : F ≅ F') :
    Full F' where
  preimage {X Y} f := F.preimage ((α.app X).hom ≫ f ≫ (α.app Y).inv)
  witness f := by simp [←NatIso.naturality_1 α]
#align category_theory.full.of_iso CategoryTheory.Full.ofIso

theorem Faithful.of_iso [Faithful F] (α : F ≅ F') : Faithful F' :=
  { map_injective := fun h =>
      F.map_injective (by rw [← NatIso.naturality_1 α.symm, h, NatIso.naturality_1 α.symm]) }
#align category_theory.faithful.of_iso CategoryTheory.Faithful.of_iso

end

variable {F G}

theorem Faithful.of_comp_iso {H : C ⥤ E} [Faithful H] (h : F ⋙ G ≅ H) : Faithful F :=
  @Faithful.of_comp _ _ _ _ _ _ F G (Faithful.of_iso h.symm)
#align category_theory.faithful.of_comp_iso CategoryTheory.Faithful.of_comp_iso

alias Faithful.of_comp_iso ← _root_.CategoryTheory.Iso.faithful_of_comp
#align category_theory.iso.faithful_of_comp CategoryTheory.Iso.faithful_of_comp

-- We could prove this from `Faithful.of_comp_iso` using `eq_to_iso`,
-- but that would introduce a cyclic import.
theorem Faithful.of_comp_eq {H : C ⥤ E} [ℋ : Faithful H] (h : F ⋙ G = H) : Faithful F :=
  @Faithful.of_comp _ _ _ _ _ _ F G (h.symm ▸ ℋ)
#align category_theory.faithful.of_comp_eq CategoryTheory.Faithful.of_comp_eq

alias Faithful.of_comp_eq ← _root_.Eq.faithful_of_comp
#align eq.faithful_of_comp Eq.faithful_of_comp

variable (F G)
/-- “Divide” a functor by a faithful functor. -/
protected def Faithful.div (F : C ⥤ E) (G : D ⥤ E) [Faithful G] (obj : C → D)
    (h_obj : ∀ X, G.obj (obj X) = F.obj X) (map : ∀ {X Y}, (X ⟶ Y) → (obj X ⟶ obj Y))
    (h_map : ∀ {X Y} {f : X ⟶ Y}, HEq (G.map (map f)) (F.map f)) : C ⥤ D :=
  { obj, map := @map,
    map_id := by
      intros X
      apply G.map_injective
      apply eq_of_heq
      trans F.map (𝟙 X)
      · exact h_map
      · rw [F.map_id, G.map_id, h_obj X]
    map_comp := by
      intros X Y Z f g
      refine G.map_injective <| eq_of_heq <| h_map.trans ?_
      simp only [Functor.map_comp]
      convert HEq.refl (F.map f ≫ F.map g)
      all_goals { first | apply h_obj | apply h_map } }
#align category_theory.faithful.div CategoryTheory.Faithful.div

-- This follows immediately from `Functor.hext` (`Functor.hext h_obj @h_map`),
-- but importing `CategoryTheory.EqToHom` causes an import loop:
-- CategoryTheory.EqToHom → CategoryTheory.Opposites →
-- CategoryTheory.Equivalence → CategoryTheory.FullyFaithful
theorem Faithful.div_comp (F : C ⥤ E) [Faithful F] (G : D ⥤ E) [Faithful G] (obj : C → D)
    (h_obj : ∀ X, G.obj (obj X) = F.obj X) (map : ∀ {X Y}, (X ⟶ Y) → (obj X ⟶ obj Y))
    (h_map : ∀ {X Y} {f : X ⟶ Y}, HEq (G.map (map f)) (F.map f)) :
    Faithful.div F G obj @h_obj @map @h_map ⋙ G = F := by
  -- Porting note: Have to unfold the structure twice because the first one recovers only the
  -- prefunctor `F_pre`
  cases' F with F_pre _ _ ; cases' G with G_pre _ _
  cases' F_pre with F_obj _ ; cases' G_pre with G_obj _
  unfold Faithful.div Functor.comp
  -- Porting note: unable to find the lean4 analogue to `unfold_projs`, works without it
  have : F_obj = G_obj ∘ obj := (funext h_obj).symm
  subst this
  congr
  simp only [Function.comp_apply, heq_eq_eq] at h_map
  ext
  exact h_map
#align category_theory.faithful.div_comp CategoryTheory.Faithful.div_comp

theorem Faithful.div_faithful (F : C ⥤ E) [Faithful F] (G : D ⥤ E) [Faithful G] (obj : C → D)
    (h_obj : ∀ X, G.obj (obj X) = F.obj X) (map : ∀ {X Y}, (X ⟶ Y) → (obj X ⟶ obj Y))
    (h_map : ∀ {X Y} {f : X ⟶ Y}, HEq (G.map (map f)) (F.map f)) :
    Faithful (Faithful.div F G obj @h_obj @map @h_map) :=
  (Faithful.div_comp F G _ h_obj _ @h_map).faithful_of_comp
#align category_theory.faithful.div_faithful CategoryTheory.Faithful.div_faithful

instance Full.comp [Full F] [Full G] :
    Full (F ⋙ G) where preimage f := F.preimage (G.preimage f)
#align category_theory.full.comp CategoryTheory.Full.comp

/-- If `F ⋙ G` is full and `G` is faithful, then `F` is full. -/
def Full.ofCompFaithful [Full <| F ⋙ G] [Faithful G] :
    Full F where
  preimage f := (F ⋙ G).preimage (G.map f)
  witness _ := G.map_injective ((F ⋙ G).image_preimage _)
#align category_theory.full.of_comp_faithful CategoryTheory.Full.ofCompFaithful

/-- If `F ⋙ G` is full and `G` is faithful, then `F` is full. -/
def Full.ofCompFaithfulIso {F : C ⥤ D} {G : D ⥤ E} {H : C ⥤ E} [Full H] [Faithful G]
    (h : F ⋙ G ≅ H) : Full F :=
  @Full.ofCompFaithful _ _ _ _ _ _ F G (Full.ofIso h.symm) _
#align category_theory.full.of_comp_faithful_iso CategoryTheory.Full.ofCompFaithfulIso

/-- Given a natural isomorphism between `F ⋙ H` and `G ⋙ H` for a fully faithful functor `H`, we
can 'cancel' it to give a natural iso between `F` and `G`.
-/
def fullyFaithfulCancelRight {F G : C ⥤ D} (H : D ⥤ E) [Full H] [Faithful H]
    (comp_iso : F ⋙ H ≅ G ⋙ H) : F ≅ G :=
  NatIso.ofComponents (fun X => H.preimageIso (comp_iso.app X)) fun f =>
    H.map_injective (by simpa using comp_iso.hom.naturality f)
#align category_theory.fully_faithful_cancel_right CategoryTheory.fullyFaithfulCancelRight

@[simp]
theorem fullyFaithfulCancelRight_hom_app {F G : C ⥤ D} {H : D ⥤ E} [Full H] [Faithful H]
    (comp_iso : F ⋙ H ≅ G ⋙ H) (X : C) :
    (fullyFaithfulCancelRight H comp_iso).hom.app X = H.preimage (comp_iso.hom.app X) :=
  rfl
#align category_theory.fully_faithful_cancel_right_hom_app CategoryTheory.fullyFaithfulCancelRight_hom_app

@[simp]
theorem fullyFaithfulCancelRight_inv_app {F G : C ⥤ D} {H : D ⥤ E} [Full H] [Faithful H]
    (comp_iso : F ⋙ H ≅ G ⋙ H) (X : C) :
    (fullyFaithfulCancelRight H comp_iso).inv.app X = H.preimage (comp_iso.inv.app X) :=
  rfl
#align category_theory.fully_faithful_cancel_right_inv_app CategoryTheory.fullyFaithfulCancelRight_inv_app

end CategoryTheory