/-
Copyright (c) 2018 Patrick Massot. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Patrick Massot, Johannes Hölzl
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.topology.uniform_space.uniform_embedding
import Mathlib.topology.uniform_space.complete_separated
import Mathlib.topology.algebra.group
import Mathlib.tactic.abel
import Mathlib.PostPort

universes u_3 l u_1 u_2 u u_4 u_5

namespace Mathlib

/-!
# Uniform structure on topological groups

* `topological_add_group.to_uniform_space` and `topological_add_group_is_uniform` can be used to
  construct a canonical uniformity for a topological add group.

* extension of ℤ-bilinear maps to complete groups (useful for ring completions)

* `add_group_with_zero_nhd`: construct the topological structure from a group with a neighbourhood
  around zero. Then with `topological_add_group.to_uniform_space` one can derive a `uniform_space`.
-/

/-- A uniform (additive) group is a group in which the addition and negation are
  uniformly continuous. -/
class uniform_add_group (α : Type u_3) [uniform_space α] [add_group α]
where
  uniform_continuous_sub : uniform_continuous fun (p : α × α) => prod.fst p - prod.snd p

theorem uniform_add_group.mk' {α : Type u_1} [uniform_space α] [add_group α] (h₁ : uniform_continuous fun (p : α × α) => prod.fst p + prod.snd p) (h₂ : uniform_continuous fun (p : α) => -p) : uniform_add_group α := sorry

theorem uniform_continuous_sub {α : Type u_1} [uniform_space α] [add_group α] [uniform_add_group α] : uniform_continuous fun (p : α × α) => prod.fst p - prod.snd p :=
  uniform_add_group.uniform_continuous_sub

theorem uniform_continuous.sub {α : Type u_1} {β : Type u_2} [uniform_space α] [add_group α] [uniform_add_group α] [uniform_space β] {f : β → α} {g : β → α} (hf : uniform_continuous f) (hg : uniform_continuous g) : uniform_continuous fun (x : β) => f x - g x :=
  uniform_continuous.comp uniform_continuous_sub (uniform_continuous.prod_mk hf hg)

theorem uniform_continuous.neg {α : Type u_1} {β : Type u_2} [uniform_space α] [add_group α] [uniform_add_group α] [uniform_space β] {f : β → α} (hf : uniform_continuous f) : uniform_continuous fun (x : β) => -f x := sorry

theorem uniform_continuous_neg {α : Type u_1} [uniform_space α] [add_group α] [uniform_add_group α] : uniform_continuous fun (x : α) => -x :=
  uniform_continuous.neg uniform_continuous_id

theorem uniform_continuous.add {α : Type u_1} {β : Type u_2} [uniform_space α] [add_group α] [uniform_add_group α] [uniform_space β] {f : β → α} {g : β → α} (hf : uniform_continuous f) (hg : uniform_continuous g) : uniform_continuous fun (x : β) => f x + g x := sorry

theorem uniform_continuous_add {α : Type u_1} [uniform_space α] [add_group α] [uniform_add_group α] : uniform_continuous fun (p : α × α) => prod.fst p + prod.snd p :=
  uniform_continuous.add uniform_continuous_fst uniform_continuous_snd

protected instance uniform_add_group.to_topological_add_group {α : Type u_1} [uniform_space α] [add_group α] [uniform_add_group α] : topological_add_group α :=
  topological_add_group.mk (uniform_continuous.continuous uniform_continuous_neg)

protected instance prod.uniform_add_group {α : Type u_1} {β : Type u_2} [uniform_space α] [add_group α] [uniform_add_group α] [uniform_space β] [add_group β] [uniform_add_group β] : uniform_add_group (α × β) :=
  uniform_add_group.mk
    (uniform_continuous.prod_mk
      (uniform_continuous.sub (uniform_continuous.comp uniform_continuous_fst uniform_continuous_fst)
        (uniform_continuous.comp uniform_continuous_fst uniform_continuous_snd))
      (uniform_continuous.sub (uniform_continuous.comp uniform_continuous_snd uniform_continuous_fst)
        (uniform_continuous.comp uniform_continuous_snd uniform_continuous_snd)))

theorem uniformity_translate {α : Type u_1} [uniform_space α] [add_group α] [uniform_add_group α] (a : α) : filter.map (fun (x : α × α) => (prod.fst x + a, prod.snd x + a)) (uniformity α) = uniformity α := sorry

theorem uniform_embedding_translate {α : Type u_1} [uniform_space α] [add_group α] [uniform_add_group α] (a : α) : uniform_embedding fun (x : α) => x + a := sorry

theorem uniformity_eq_comap_nhds_zero (α : Type u_1) [uniform_space α] [add_group α] [uniform_add_group α] : uniformity α = filter.comap (fun (x : α × α) => prod.snd x - prod.fst x) (nhds 0) := sorry

theorem group_separation_rel {α : Type u_1} [uniform_space α] [add_group α] [uniform_add_group α] (x : α) (y : α) : (x, y) ∈ Mathlib.separation_rel α ↔ x - y ∈ closure (singleton 0) := sorry

theorem uniform_continuous_of_tendsto_zero {α : Type u_1} {β : Type u_2} [uniform_space α] [add_group α] [uniform_add_group α] [uniform_space β] [add_group β] [uniform_add_group β] {f : α → β} [is_add_group_hom f] (h : filter.tendsto f (nhds 0) (nhds 0)) : uniform_continuous f := sorry

theorem uniform_continuous_of_continuous {α : Type u_1} {β : Type u_2} [uniform_space α] [add_group α] [uniform_add_group α] [uniform_space β] [add_group β] [uniform_add_group β] {f : α → β} [is_add_group_hom f] (h : continuous f) : uniform_continuous f := sorry

/-- The right uniformity on a topological group. -/
def topological_add_group.to_uniform_space (G : Type u) [add_comm_group G] [topological_space G] [topological_add_group G] : uniform_space G :=
  uniform_space.mk
    (uniform_space.core.mk (filter.comap (fun (p : G × G) => prod.snd p - prod.fst p) (nhds 0)) sorry sorry sorry) sorry

theorem uniformity_eq_comap_nhds_zero' (G : Type u) [add_comm_group G] [topological_space G] [topological_add_group G] : uniformity G = filter.comap (fun (p : G × G) => prod.snd p - prod.fst p) (nhds 0) :=
  rfl

theorem topological_add_group_is_uniform {G : Type u} [add_comm_group G] [topological_space G] [topological_add_group G] : uniform_add_group G := sorry

theorem to_uniform_space_eq {G : Type u} [u : uniform_space G] [add_comm_group G] [uniform_add_group G] : topological_add_group.to_uniform_space G = u := sorry

namespace add_comm_group

/- TODO: when modules are changed to have more explicit base ring, then change replace `is_Z_bilin`
by using `is_bilinear_map ℤ` from `tensor_product`. -/

/-- `ℤ`-bilinearity for maps between additive commutative groups. -/
class is_Z_bilin {α : Type u_1} {β : Type u_2} {γ : Type u_3} [add_comm_group α] [add_comm_group β] [add_comm_group γ] (f : α × β → γ)
where
  add_left : ∀ (a a' : α) (b : β), f (a + a', b) = f (a, b) + f (a', b)
  add_right : ∀ (a : α) (b b' : β), f (a, b + b') = f (a, b) + f (a, b')

theorem is_Z_bilin.comp_hom {α : Type u_1} {β : Type u_2} {γ : Type u_3} {δ : Type u_4} [add_comm_group α] [add_comm_group β] [add_comm_group γ] (f : α × β → γ) [is_Z_bilin f] {g : γ → δ} [add_comm_group δ] [is_add_group_hom g] : is_Z_bilin (g ∘ f) := sorry

protected instance is_Z_bilin.comp_swap {α : Type u_1} {β : Type u_2} {γ : Type u_3} [add_comm_group α] [add_comm_group β] [add_comm_group γ] (f : α × β → γ) [is_Z_bilin f] : is_Z_bilin (f ∘ prod.swap) :=
  is_Z_bilin.mk (fun (a a' : β) (b : α) => is_Z_bilin.add_right f b a a')
    fun (a : β) (b b' : α) => is_Z_bilin.add_left f b b' a

theorem is_Z_bilin.zero_left {α : Type u_1} {β : Type u_2} {γ : Type u_3} [add_comm_group α] [add_comm_group β] [add_comm_group γ] (f : α × β → γ) [is_Z_bilin f] (b : β) : f (0, b) = 0 := sorry

theorem is_Z_bilin.zero_right {α : Type u_1} {β : Type u_2} {γ : Type u_3} [add_comm_group α] [add_comm_group β] [add_comm_group γ] (f : α × β → γ) [is_Z_bilin f] (a : α) : f (a, 0) = 0 :=
  is_Z_bilin.zero_left (f ∘ prod.swap)

theorem is_Z_bilin.zero {α : Type u_1} {β : Type u_2} {γ : Type u_3} [add_comm_group α] [add_comm_group β] [add_comm_group γ] (f : α × β → γ) [is_Z_bilin f] : f (0, 0) = 0 :=
  is_Z_bilin.zero_left f 0

theorem is_Z_bilin.neg_left {α : Type u_1} {β : Type u_2} {γ : Type u_3} [add_comm_group α] [add_comm_group β] [add_comm_group γ] (f : α × β → γ) [is_Z_bilin f] (a : α) (b : β) : f (-a, b) = -f (a, b) := sorry

theorem is_Z_bilin.neg_right {α : Type u_1} {β : Type u_2} {γ : Type u_3} [add_comm_group α] [add_comm_group β] [add_comm_group γ] (f : α × β → γ) [is_Z_bilin f] (a : α) (b : β) : f (a, -b) = -f (a, b) :=
  is_Z_bilin.neg_left (f ∘ prod.swap) b a

theorem is_Z_bilin.sub_left {α : Type u_1} {β : Type u_2} {γ : Type u_3} [add_comm_group α] [add_comm_group β] [add_comm_group γ] (f : α × β → γ) [is_Z_bilin f] (a : α) (a' : α) (b : β) : f (a - a', b) = f (a, b) - f (a', b) := sorry

theorem is_Z_bilin.sub_right {α : Type u_1} {β : Type u_2} {γ : Type u_3} [add_comm_group α] [add_comm_group β] [add_comm_group γ] (f : α × β → γ) [is_Z_bilin f] (a : α) (b : β) (b' : β) : f (a, b - b') = f (a, b) - f (a, b') :=
  is_Z_bilin.sub_left (f ∘ prod.swap) b b' a

end add_comm_group

-- α, β and G are abelian topological groups, G is a uniform space

theorem is_Z_bilin.tendsto_zero_left {α : Type u_1} {β : Type u_2} [topological_space α] [add_comm_group α] [topological_space β] [add_comm_group β] {G : Type u_5} [uniform_space G] [add_comm_group G] {ψ : α × β → G} (hψ : continuous ψ) [ψbilin : add_comm_group.is_Z_bilin ψ] (x₁ : α) : filter.tendsto ψ (nhds (x₁, 0)) (nhds 0) := sorry

theorem is_Z_bilin.tendsto_zero_right {α : Type u_1} {β : Type u_2} [topological_space α] [add_comm_group α] [topological_space β] [add_comm_group β] {G : Type u_5} [uniform_space G] [add_comm_group G] {ψ : α × β → G} (hψ : continuous ψ) [ψbilin : add_comm_group.is_Z_bilin ψ] (y₁ : β) : filter.tendsto ψ (nhds (0, y₁)) (nhds 0) :=
  eq.mp
    (Eq._oldrec (Eq.refl (filter.tendsto ψ (nhds (0, y₁)) (nhds (ψ (0, y₁))))) (add_comm_group.is_Z_bilin.zero_left ψ y₁))
    (continuous.tendsto hψ (0, y₁))

-- β is a dense subgroup of α, inclusion is denoted by e

theorem tendsto_sub_comap_self {α : Type u_1} {β : Type u_2} [topological_space α] [add_comm_group α] [topological_add_group α] [topological_space β] [add_comm_group β] {e : β → α} [is_add_group_hom e] (de : dense_inducing e) (x₀ : α) : filter.tendsto (fun (t : β × β) => prod.snd t - prod.fst t)
  (filter.comap (fun (p : β × β) => (e (prod.fst p), e (prod.snd p))) (nhds (x₀, x₀))) (nhds 0) := sorry

namespace dense_inducing

-- β is a dense subgroup of α, inclusion is denoted by e

-- δ is a dense subgroup of γ, inclusion is denoted by f

/-- Bourbaki GT III.6.5 Theorem I:
ℤ-bilinear continuous maps from dense images into a complete Hausdorff group extend by continuity.
Note: Bourbaki assumes that α and β are also complete Hausdorff, but this is not necessary. -/
theorem extend_Z_bilin {α : Type u_1} {β : Type u_2} {γ : Type u_3} {δ : Type u_4} {G : Type u_5} [topological_space α] [add_comm_group α] [topological_add_group α] [topological_space β] [add_comm_group β] [topological_add_group β] [topological_space γ] [add_comm_group γ] [topological_add_group γ] [topological_space δ] [add_comm_group δ] [topological_add_group δ] [uniform_space G] [add_comm_group G] [uniform_add_group G] [separated_space G] [complete_space G] {e : β → α} [is_add_group_hom e] (de : dense_inducing e) {f : δ → γ} [is_add_group_hom f] (df : dense_inducing f) {φ : β × δ → G} (hφ : continuous φ) [bilin : add_comm_group.is_Z_bilin φ] : continuous (extend (dense_inducing.prod de df) φ) := sorry


import graphs.composition

lemma id_compatability (G : graph) : G.endpoints ∘ id = sym2.map id ∘ G.endpoints :=
begin
  rw sym2.map_id,
  refl,
end


/-
Copyright (c) 2021 Fox Thomson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Fox Thomson, Yaël Dillies

! This file was ported from Lean 3 source module computability.epsilon_NFA
! leanprover-community/mathlib commit 28aa996fc6fb4317f0083c4e6daf79878d81be33
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Computability.NFA

/-!
# Epsilon Nondeterministic Finite Automata

This file contains the definition of an epsilon Nondeterministic Finite Automaton (`εNFA`), a state
machine which determines whether a string (implemented as a list over an arbitrary alphabet) is in a
regular set by evaluating the string over every possible path, also having access to ε-transitons,
which can be followed without reading a character.
Since this definition allows for automata with infinite states, a `Fintype` instance must be
supplied for true `εNFA`'s.
-/

open Set

open Computability

-- "ε_NFA"
set_option linter.uppercaseLean3 false

universe u v

/-- An `εNFA` is a set of states (`σ`), a transition function from state to state labelled by the
  alphabet (`step`), a starting state (`start`) and a set of acceptance states (`accept`).
  Note the transition function sends a state to a `Set` of states and can make ε-transitions by
  inputing `none`.
  Since this definition allows for Automata with infinite states, a `Fintype` instance must be
  supplied for true `εNFA`'s. -/
structure εNFA (α : Type u) (σ : Type v) where
  step : σ → Option α → Set σ
  start : Set σ
  accept : Set σ
#align ε_NFA εNFA

variable {α : Type u} {σ σ' : Type v} (M : εNFA α σ) {S : Set σ} {x : List α} {s : σ} {a : α}

namespace εNFA

/-- The `εClosure` of a set is the set of states which can be reached by taking a finite string of
ε-transitions from an element of the set. -/
inductive εClosure (S : Set σ) : Set σ
  | base : ∀ s ∈ S, εClosure S s
  | step : ∀ (s), ∀ t ∈ M.step s none, εClosure S s → εClosure S t
#align ε_NFA.ε_closure εNFA.εClosure

@[simp]
theorem subset_εClosure (S : Set σ) : S ⊆ M.εClosure S :=
  εClosure.base
#align ε_NFA.subset_ε_closure εNFA.subset_εClosure

@[simp]
theorem εClosure_empty : M.εClosure ∅ = ∅ :=
  eq_empty_of_forall_not_mem fun s hs ↦ by induction hs <;> assumption
#align ε_NFA.ε_closure_empty εNFA.εClosure_empty

@[simp]
theorem εClosure_univ : M.εClosure univ = univ :=
  eq_univ_of_univ_subset <| subset_εClosure _ _
#align ε_NFA.ε_closure_univ εNFA.εClosure_univ

/-- `M.stepSet S a` is the union of the ε-closure of `M.step s a` for all `s ∈ S`. -/
def stepSet (S : Set σ) (a : α) : Set σ :=
  ⋃ s ∈ S, M.εClosure <| M.step s a
#align ε_NFA.step_set εNFA.stepSet

variable {M}

@[simp]
theorem mem_stepSet_iff : s ∈ M.stepSet S a ↔ ∃ t ∈ S, s ∈ M.εClosure (M.step t a) := by
  simp_rw [stepSet, mem_unionᵢ₂, exists_prop]
#align ε_NFA.mem_step_set_iff εNFA.mem_stepSet_iff

@[simp]
theorem stepSet_empty (a : α) : M.stepSet ∅ a = ∅ := by
  simp_rw [stepSet, mem_empty_iff_false, unionᵢ_false, unionᵢ_empty]
#align ε_NFA.step_set_empty εNFA.stepSet_empty

variable (M)

/-- `M.evalFrom S x` computes all possible paths through `M` with input `x` starting at an element
of `S`. -/
def evalFrom (start : Set σ) : List α → Set σ :=
  List.foldl M.stepSet (M.εClosure start)
#align ε_NFA.eval_from εNFA.evalFrom

@[simp]
theorem evalFrom_nil (S : Set σ) : M.evalFrom S [] = M.εClosure S :=
  rfl
#align ε_NFA.eval_from_nil εNFA.evalFrom_nil

@[simp]
theorem evalFrom_singleton (S : Set σ) (a : α) : M.evalFrom S [a] = M.stepSet (M.εClosure S) a :=
  rfl
#align ε_NFA.eval_from_singleton εNFA.evalFrom_singleton

@[simp]
theorem evalFrom_append_singleton (S : Set σ) (x : List α) (a : α) :
    M.evalFrom S (x ++ [a]) = M.stepSet (M.evalFrom S x) a := by
  rw [evalFrom, List.foldl_append, List.foldl_cons, List.foldl_nil]
#align ε_NFA.eval_from_append_singleton εNFA.evalFrom_append_singleton

@[simp]
theorem evalFrom_empty (x : List α) : M.evalFrom ∅ x = ∅ := by
  induction' x using List.reverseRecOn with x a ih
  · rw [evalFrom_nil, εClosure_empty]
  · rw [evalFrom_append_singleton, ih, stepSet_empty]
#align ε_NFA.eval_from_empty εNFA.evalFrom_empty

/-- `M.eval x` computes all possible paths through `M` with input `x` starting at an element of
`M.start`. -/
def eval :=
  M.evalFrom M.start
#align ε_NFA.eval εNFA.eval

@[simp]
theorem eval_nil : M.eval [] = M.εClosure M.start :=
  rfl
#align ε_NFA.eval_nil εNFA.eval_nil

@[simp]
theorem eval_singleton (a : α) : M.eval [a] = M.stepSet (M.εClosure M.start) a :=
  rfl
#align ε_NFA.eval_singleton εNFA.eval_singleton

@[simp]
theorem eval_append_singleton (x : List α) (a : α) : M.eval (x ++ [a]) = M.stepSet (M.eval x) a :=
  evalFrom_append_singleton _ _ _ _
#align ε_NFA.eval_append_singleton εNFA.eval_append_singleton

/-- `M.accepts` is the language of `x` such that there is an accept state in `M.eval x`. -/
def accepts : Language α :=
  { x | ∃ S ∈ M.accept, S ∈ M.eval x }
#align ε_NFA.accepts εNFA.accepts

/-! ### Conversions between `εNFA` and `NFA` -/

/-- `M.toNFA` is an `NFA` constructed from an `εNFA` `M`. -/
def toNFA : NFA α σ where
  step S a := M.εClosure (M.step S a)
  start := M.εClosure M.start
  accept := M.accept
#align ε_NFA.to_NFA εNFA.toNFA

@[simp]
theorem toNFA_evalFrom_match (start : Set σ) :
    M.toNFA.evalFrom (M.εClosure start) = M.evalFrom start :=
  rfl
#align ε_NFA.to_NFA_eval_from_match εNFA.toNFA_evalFrom_match

@[simp]
theorem toNFA_correct : M.toNFA.accepts = M.accepts :=
  rfl
#align ε_NFA.to_NFA_correct εNFA.toNFA_correct

theorem pumping_lemma [Fintype σ] {x : List α} (hx : x ∈ M.accepts)
    (hlen : Fintype.card (Set σ) ≤ List.length x) :
    ∃ a b c, x = a ++ b ++ c ∧
      a.length + b.length ≤ Fintype.card (Set σ) ∧ b ≠ [] ∧ {a} * {b}∗ * {c} ≤ M.accepts :=
  M.toNFA.pumping_lemma hx hlen
#align ε_NFA.pumping_lemma εNFA.pumping_lemma

end εNFA

namespace NFA

/-- `M.toεNFA` is an `εNFA` constructed from an `NFA` `M` by using the same start and accept
  states and transition functions. -/
def toεNFA (M : NFA α σ) : εNFA α σ where
  step s a := a.casesOn' ∅ fun a ↦ M.step s a
  start := M.start
  accept := M.accept
#align NFA.to_ε_NFA NFA.toεNFA

@[simp]
theorem toεNFA_εClosure (M : NFA α σ) (S : Set σ) : M.toεNFA.εClosure S = S := by
  ext a
  refine' ⟨_, εNFA.εClosure.base _⟩
  rintro (⟨_, h⟩ | ⟨_, _, h, _⟩)
  · exact h
  · cases h
#align NFA.to_ε_NFA_ε_closure NFA.toεNFA_εClosure

@[simp]
theorem toεNFA_evalFrom_match (M : NFA α σ) (start : Set σ) :
    M.toεNFA.evalFrom start = M.evalFrom start := by
  rw [evalFrom, εNFA.evalFrom, toεNFA_εClosure]
  suffices εNFA.stepSet (toεNFA M) = stepSet M by rw [this]
  ext S s
  simp only [stepSet, εNFA.stepSet, exists_prop, Set.mem_unionᵢ]
  apply exists_congr
  simp only [and_congr_right_iff]
  intro _ _
  rw [M.toεNFA_εClosure]
  rfl
#align NFA.to_ε_NFA_eval_from_match NFA.toεNFA_evalFrom_match

@[simp]
theorem toεNFA_correct (M : NFA α σ) : M.toεNFA.accepts = M.accepts := by
  rw [εNFA.accepts, εNFA.eval, toεNFA_evalFrom_match]
  rfl
#align NFA.to_ε_NFA_correct NFA.toεNFA_correct

end NFA

/-! ### Regex-like operations -/

namespace εNFA

instance : Zero (εNFA α σ) :=
  ⟨⟨fun _ _ ↦ ∅, ∅, ∅⟩⟩

instance : One (εNFA α σ) :=
  ⟨⟨fun _ _ ↦ ∅, univ, univ⟩⟩

instance : Inhabited (εNFA α σ) :=
  ⟨0⟩

variable (P : εNFA α σ) (Q : εNFA α σ')

@[simp]
theorem step_zero (s a) : (0 : εNFA α σ).step s a = ∅ :=
  rfl
#align ε_NFA.step_zero εNFA.step_zero

@[simp]
theorem step_one (s a) : (1 : εNFA α σ).step s a = ∅ :=
  rfl
#align ε_NFA.step_one εNFA.step_one

@[simp]
theorem start_zero : (0 : εNFA α σ).start = ∅ :=
  rfl
#align ε_NFA.start_zero εNFA.start_zero

@[simp]
theorem start_one : (1 : εNFA α σ).start = univ :=
  rfl
#align ε_NFA.start_one εNFA.start_one

@[simp]
theorem accept_zero : (0 : εNFA α σ).accept = ∅ :=
  rfl
#align ε_NFA.accept_zero εNFA.accept_zero

@[simp]
theorem accept_one : (1 : εNFA α σ).accept = univ :=
  rfl
#align ε_NFA.accept_one εNFA.accept_one

end εNFA


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

universes u v u₂

namespace Mathlib

/-!
# Constructing limits from products and equalizers.

If a category has all products, and all equalizers, then it has all limits.
Similarly, if it has all finite products, and all equalizers, then it has all finite limits.

If a functor preserves all products and equalizers, then it preserves all limits.
Similarly, if it preserves all finite products and equalizers, then it preserves all finite limits.

# TODO

Provide the dual results.
Show the analogous results for functors which reflect or create (co)limits.
-/

namespace category_theory.limits

-- We hide the "implementation details" inside a namespace

namespace has_limit_of_has_products_of_has_equalizers

/--
(Implementation) Given the appropriate product and equalizer cones, build the cone for `F` which is
limiting if the given cones are also.
-/
def build_limit {C : Type u} [category C] {J : Type v} [small_category J] {F : J ⥤ C}
    {c₁ : fan (functor.obj F)}
    {c₂ :
      fan
        fun (f : sigma fun (p : J × J) => prod.fst p ⟶ prod.snd p) =>
          functor.obj F (prod.snd (sigma.fst f))}
    (s : cone.X c₁ ⟶ cone.X c₂) (t : cone.X c₁ ⟶ cone.X c₂)
    (hs :
      ∀ (f : sigma fun (p : J × J) => prod.fst p ⟶ prod.snd p),
        s ≫ nat_trans.app (cone.π c₂) f =
          nat_trans.app (cone.π c₁) (prod.fst (sigma.fst f)) ≫ functor.map F (sigma.snd f))
    (ht :
      ∀ (f : sigma fun (p : J × J) => prod.fst p ⟶ prod.snd p),
        t ≫ nat_trans.app (cone.π c₂) f = nat_trans.app (cone.π c₁) (prod.snd (sigma.fst f)))
    (i : fork s t) : cone F :=
  cone.mk (cone.X i) (nat_trans.mk fun (j : J) => fork.ι i ≫ nat_trans.app (cone.π c₁) j)

/--
(Implementation) Show the cone constructed in `build_limit` is limiting, provided the cones used in
its construction are.
-/
def build_is_limit {C : Type u} [category C] {J : Type v} [small_category J] {F : J ⥤ C}
    {c₁ : fan (functor.obj F)}
    {c₂ :
      fan
        fun (f : sigma fun (p : J × J) => prod.fst p ⟶ prod.snd p) =>
          functor.obj F (prod.snd (sigma.fst f))}
    (s : cone.X c₁ ⟶ cone.X c₂) (t : cone.X c₁ ⟶ cone.X c₂)
    (hs :
      ∀ (f : sigma fun (p : J × J) => prod.fst p ⟶ prod.snd p),
        s ≫ nat_trans.app (cone.π c₂) f =
          nat_trans.app (cone.π c₁) (prod.fst (sigma.fst f)) ≫ functor.map F (sigma.snd f))
    (ht :
      ∀ (f : sigma fun (p : J × J) => prod.fst p ⟶ prod.snd p),
        t ≫ nat_trans.app (cone.π c₂) f = nat_trans.app (cone.π c₁) (prod.snd (sigma.fst f)))
    {i : fork s t} (t₁ : is_limit c₁) (t₂ : is_limit c₂) (hi : is_limit i) :
    is_limit (build_limit s t hs ht i) :=
  is_limit.mk
    fun (q : cone F) =>
      is_limit.lift hi
        (fork.of_ι (is_limit.lift t₁ (fan.mk (cone.X q) fun (j : J) => nat_trans.app (cone.π q) j))
          sorry)

end has_limit_of_has_products_of_has_equalizers

/--
Given the existence of the appropriate (possibly finite) products and equalizers, we know a limit of
`F` exists.
(This assumes the existence of all equalizers, which is technically stronger than needed.)
-/
theorem has_limit_of_equalizer_and_product {C : Type u} [category C] {J : Type v} [small_category J]
    (F : J ⥤ C) [has_limit (discrete.functor (functor.obj F))]
    [has_limit
        (discrete.functor
          fun (f : sigma fun (p : J × J) => prod.fst p ⟶ prod.snd p) =>
            functor.obj F (prod.snd (sigma.fst f)))]
    [has_equalizers C] : has_limit F :=
  sorry

/--
Any category with products and equalizers has all limits.

See https://stacks.math.columbia.edu/tag/002N.
-/
theorem limits_from_equalizers_and_products {C : Type u} [category C] [has_products C]
    [has_equalizers C] : has_limits C :=
  has_limits.mk
    fun (J : Type v) (𝒥 : small_category J) =>
      has_limits_of_shape.mk fun (F : J ⥤ C) => has_limit_of_equalizer_and_product F

/--
Any category with finite products and equalizers has all finite limits.

See https://stacks.math.columbia.edu/tag/002O.
-/
theorem finite_limits_from_equalizers_and_finite_products {C : Type u} [category C]
    [has_finite_products C] [has_equalizers C] : has_finite_limits C :=
  fun (J : Type v) (_x : small_category J) (_x_1 : fin_category J) =>
    has_limits_of_shape.mk fun (F : J ⥤ C) => has_limit_of_equalizer_and_product F

/-- If a functor preserves equalizers and the appropriate products, it preserves limits. -/
def preserves_limit_of_preserves_equalizers_and_product {C : Type u} [category C] {J : Type v}
    [small_category J] {D : Type u₂} [category D] [has_limits_of_shape (discrete J) C]
    [has_limits_of_shape (discrete (sigma fun (p : J × J) => prod.fst p ⟶ prod.snd p)) C]
    [has_equalizers C] (G : C ⥤ D) [preserves_limits_of_shape walking_parallel_pair G]
    [preserves_limits_of_shape (discrete J) G]
    [preserves_limits_of_shape (discrete (sigma fun (p : J × J) => prod.fst p ⟶ prod.snd p)) G] :
    preserves_limits_of_shape J G :=
  sorry

/-- If G preserves equalizers and finite products, it preserves finite limits. -/
def preserves_finite_limits_of_preserves_equalizers_and_finite_products {C : Type u} [category C]
    {D : Type u₂} [category D] [has_equalizers C] [has_finite_products C] (G : C ⥤ D)
    [preserves_limits_of_shape walking_parallel_pair G]
    [(J : Type v) → [_inst_8 : fintype J] → preserves_limits_of_shape (discrete J) G] (J : Type v)
    [small_category J] [fin_category J] : preserves_limits_of_shape J G :=
  preserves_limit_of_preserves_equalizers_and_product G

/-- If G preserves equalizers and products, it preserves all limits. -/
def preserves_limits_of_preserves_equalizers_and_products {C : Type u} [category C] {D : Type u₂}
    [category D] [has_equalizers C] [has_products C] (G : C ⥤ D)
    [preserves_limits_of_shape walking_parallel_pair G]
    [(J : Type v) → preserves_limits_of_shape (discrete J) G] : preserves_limits G :=
  preserves_limits.mk
    fun (J : Type v) (𝒥 : small_category J) => preserves_limit_of_preserves_equalizers_and_product G

end Mathlib


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Tim Baumann, Stephen Morgan, Scott Morrison, Floris van Doorn
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.functor_category
import Mathlib.category_theory.isomorphism
import Mathlib.PostPort

universes u₁ u₂ v₁ v₂ u₃ v₃

namespace Mathlib

/-!
# Natural isomorphisms

For the most part, natural isomorphisms are just another sort of isomorphism.

We provide some special support for extracting components:
* if `α : F ≅ G`, then `a.app X : F.obj X ≅ G.obj X`,
and building natural isomorphisms from components:
*
```
nat_iso.of_components
  (app : ∀ X : C, F.obj X ≅ G.obj X)
  (naturality : ∀ {X Y : C} (f : X ⟶ Y), F.map f ≫ (app Y).hom = (app X).hom ≫ G.map f) :
F ≅ G
```
only needing to check naturality in one direction.

## Implementation

Note that `nat_iso` is a namespace without a corresponding definition;
we put some declarations that are specifically about natural isomorphisms in the `iso`
namespace so that they are available using dot notation.
-/

-- declare the `v`'s first; see `category_theory.category` for an explanation

namespace category_theory

namespace iso

/-- The application of a natural isomorphism to an object. We put this definition in a different
namespace, so that we can use `α.app` -/
@[simp] theorem app_hom {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D} (α : F ≅ G) (X : C) : hom (app α X) = nat_trans.app (hom α) X :=
  Eq.refl (hom (app α X))

@[simp] theorem hom_inv_id_app_assoc {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D} (α : F ≅ G) (X : C) {X' : D} (f' : functor.obj F X ⟶ X') : nat_trans.app (hom α) X ≫ nat_trans.app (inv α) X ≫ f' = f' := sorry

@[simp] theorem inv_hom_id_app_assoc {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D} (α : F ≅ G) (X : C) {X' : D} (f' : functor.obj G X ⟶ X') : nat_trans.app (inv α) X ≫ nat_trans.app (hom α) X ≫ f' = f' := sorry

end iso

namespace nat_iso

@[simp] theorem trans_app {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D} {H : C ⥤ D} (α : F ≅ G) (β : G ≅ H) (X : C) : iso.app (α ≪≫ β) X = iso.app α X ≪≫ iso.app β X :=
  rfl

theorem app_hom {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D} (α : F ≅ G) (X : C) : iso.hom (iso.app α X) = nat_trans.app (iso.hom α) X :=
  rfl

theorem app_inv {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D} (α : F ≅ G) (X : C) : iso.inv (iso.app α X) = nat_trans.app (iso.inv α) X :=
  rfl

protected instance hom_app_is_iso {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D} (α : F ≅ G) (X : C) : is_iso (nat_trans.app (iso.hom α) X) :=
  is_iso.mk (nat_trans.app (iso.inv α) X)

protected instance inv_app_is_iso {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D} (α : F ≅ G) (X : C) : is_iso (nat_trans.app (iso.inv α) X) :=
  is_iso.mk (nat_trans.app (iso.hom α) X)

/-!
Unfortunately we need a separate set of cancellation lemmas for components of natural isomorphisms,
because the `simp` normal form is `α.hom.app X`, rather than `α.app.hom X`.

(With the later, the morphism would be visibly part of an isomorphism, so general lemmas about
isomorphisms would apply.)

In the future, we should consider a redesign that changes this simp norm form,
but for now it breaks too many proofs.
-/

@[simp] theorem cancel_nat_iso_hom_left {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D} (α : F ≅ G) {X : C} {Z : D} (g : functor.obj G X ⟶ Z) (g' : functor.obj G X ⟶ Z) : nat_trans.app (iso.hom α) X ≫ g = nat_trans.app (iso.hom α) X ≫ g' ↔ g = g' := sorry

@[simp] theorem cancel_nat_iso_inv_left {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D} (α : F ≅ G) {X : C} {Z : D} (g : functor.obj F X ⟶ Z) (g' : functor.obj F X ⟶ Z) : nat_trans.app (iso.inv α) X ≫ g = nat_trans.app (iso.inv α) X ≫ g' ↔ g = g' := sorry

@[simp] theorem cancel_nat_iso_hom_right {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D} (α : F ≅ G) {X : D} {Y : C} (f : X ⟶ functor.obj F Y) (f' : X ⟶ functor.obj F Y) : f ≫ nat_trans.app (iso.hom α) Y = f' ≫ nat_trans.app (iso.hom α) Y ↔ f = f' := sorry

@[simp] theorem cancel_nat_iso_inv_right {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D} (α : F ≅ G) {X : D} {Y : C} (f : X ⟶ functor.obj G Y) (f' : X ⟶ functor.obj G Y) : f ≫ nat_trans.app (iso.inv α) Y = f' ≫ nat_trans.app (iso.inv α) Y ↔ f = f' := sorry

@[simp] theorem cancel_nat_iso_hom_right_assoc {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D} (α : F ≅ G) {W : D} {X : D} {X' : D} {Y : C} (f : W ⟶ X) (g : X ⟶ functor.obj F Y) (f' : W ⟶ X') (g' : X' ⟶ functor.obj F Y) : f ≫ g ≫ nat_trans.app (iso.hom α) Y = f' ≫ g' ≫ nat_trans.app (iso.hom α) Y ↔ f ≫ g = f' ≫ g' := sorry

@[simp] theorem cancel_nat_iso_inv_right_assoc {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D} (α : F ≅ G) {W : D} {X : D} {X' : D} {Y : C} (f : W ⟶ X) (g : X ⟶ functor.obj G Y) (f' : W ⟶ X') (g' : X' ⟶ functor.obj G Y) : f ≫ g ≫ nat_trans.app (iso.inv α) Y = f' ≫ g' ≫ nat_trans.app (iso.inv α) Y ↔ f ≫ g = f' ≫ g' := sorry

theorem naturality_1 {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D} {X : C} {Y : C} (α : F ≅ G) (f : X ⟶ Y) : nat_trans.app (iso.inv α) X ≫ functor.map F f ≫ nat_trans.app (iso.hom α) Y = functor.map G f := sorry

theorem naturality_2 {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D} {X : C} {Y : C} (α : F ≅ G) (f : X ⟶ Y) : nat_trans.app (iso.hom α) X ≫ functor.map G f ≫ nat_trans.app (iso.inv α) Y = functor.map F f := sorry

/--
A natural transformation is an isomorphism if all its components are isomorphisms.
-/
-- Making this an instance would cause a typeclass inference loop with `is_iso_app_of_is_iso`.

def is_iso_of_is_iso_app {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D} (α : F ⟶ G) [(X : C) → is_iso (nat_trans.app α X)] : is_iso α :=
  is_iso.mk (nat_trans.mk fun (X : C) => inv (nat_trans.app α X))

/--
The components of a natural isomorphism are isomorphisms.
-/
protected instance is_iso_app_of_is_iso {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D} (α : F ⟶ G) [is_iso α] (X : C) : is_iso (nat_trans.app α X) :=
  is_iso.mk (nat_trans.app (inv α) X)

/--
Construct a natural isomorphism between functors by giving object level isomorphisms,
and checking naturality only in the forward direction.
-/
def of_components {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D} (app : (X : C) → functor.obj F X ≅ functor.obj G X) (naturality : ∀ {X Y : C} (f : X ⟶ Y), functor.map F f ≫ iso.hom (app Y) = iso.hom (app X) ≫ functor.map G f) : F ≅ G :=
  iso.mk (nat_trans.mk fun (X : C) => iso.hom (app X)) (inv (nat_trans.mk fun (X : C) => iso.hom (app X)))

@[simp] theorem of_components.app {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D} (app' : (X : C) → functor.obj F X ≅ functor.obj G X) (naturality : ∀ {X Y : C} (f : X ⟶ Y), functor.map F f ≫ iso.hom (app' Y) = iso.hom (app' X) ≫ functor.map G f) (X : C) : iso.app (of_components app' naturality) X = app' X :=
  iso.ext (Eq.refl (iso.hom (iso.app (of_components app' naturality) X)))

@[simp] theorem of_components.hom_app {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D} (app : (X : C) → functor.obj F X ≅ functor.obj G X) (naturality : ∀ {X Y : C} (f : X ⟶ Y), functor.map F f ≫ iso.hom (app Y) = iso.hom (app X) ≫ functor.map G f) (X : C) : nat_trans.app (iso.hom (of_components app naturality)) X = iso.hom (app X) :=
  rfl

@[simp] theorem of_components.inv_app {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D} (app : (X : C) → functor.obj F X ≅ functor.obj G X) (naturality : ∀ {X Y : C} (f : X ⟶ Y), functor.map F f ≫ iso.hom (app Y) = iso.hom (app X) ≫ functor.map G f) (X : C) : nat_trans.app (iso.inv (of_components app naturality)) X = iso.inv (app X) :=
  rfl

/-- Horizontal composition of natural isomorphisms. -/
def hcomp {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E] {F : C ⥤ D} {G : C ⥤ D} {H : D ⥤ E} {I : D ⥤ E} (α : F ≅ G) (β : H ≅ I) : F ⋙ H ≅ G ⋙ I :=
  iso.mk (iso.hom α ◫ iso.hom β) (iso.inv α ◫ iso.inv β)


/-
Copyright (c) 2021 Rémy Degenne. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Rémy Degenne
-/

import measure_theory.measurable_space

/-!
# Sequence of measurable functions associated to a sequence of a.e.-measurable functions

We define here tools to prove statements about limits (infi, supr...) of sequences of
`ae_measurable` functions.
Given a sequence of a.e.-measurable functions `f : ι → α → β` with hypothesis
`hf : ∀ i, ae_measurable (f i) μ`, and a pointwise property `p : α → (ι → β) → Prop` such that we
have `hp : ∀ᵐ x ∂μ, p x (λ n, f n x)`, we define a sequence of measurable functions `ae_seq hf p`
and a measurable set `ae_seq_set hf p`, such that
* `μ (ae_seq_set hf p)ᶜ = 0`
* `x ∈ ae_seq_set hf p → ∀ i : ι, ae_seq hf hp i x = f i x`
* `x ∈ ae_seq_set hf p → p x (λ n, f n x)`
-/

open measure_theory
open_locale classical

variables {ι : Sort*} {α β γ : Type*} [measurable_space α] [measurable_space β]
  {f : ι → α → β} {μ : measure α} {p : α → (ι → β) → Prop}

/-- If we have the additional hypothesis `∀ᵐ x ∂μ, p x (λ n, f n x)`, this is a measurable set
whose complement has measure 0 such that for all `x ∈ ae_seq_set`, `f i x` is equal to
`(hf i).mk (f i) x` for all `i` and we have the pointwise property `p x (λ n, f n x)`. -/
def ae_seq_set (hf : ∀ i, ae_measurable (f i) μ) (p : α → (ι → β) → Prop) : set α :=
(to_measurable μ {x | (∀ i, f i x = (hf i).mk (f i) x) ∧ p x (λ n, f n x)}ᶜ)ᶜ

/-- A sequence of measurable functions that are equal to `f` and verify property `p` on the
measurable set `ae_seq_set hf p`. -/
noncomputable
def ae_seq (hf : ∀ i, ae_measurable (f i) μ) (p : α → (ι → β) → Prop) : ι → α → β :=
λ i x, ite (x ∈ ae_seq_set hf p) ((hf i).mk (f i) x) (⟨f i x⟩ : nonempty β).some

namespace ae_seq

section mem_ae_seq_set

lemma mk_eq_fun_of_mem_ae_seq_set (hf : ∀ i, ae_measurable (f i) μ) {x : α}
  (hx : x ∈ ae_seq_set hf p) (i : ι) :
  (hf i).mk (f i) x = f i x :=
begin
  have h_ss : ae_seq_set hf p ⊆ {x | ∀ i, f i x = (hf i).mk (f i) x},
  { rw [ae_seq_set, ←compl_compl {x | ∀ i, f i x = (hf i).mk (f i) x}, set.compl_subset_compl],
    refine set.subset.trans (set.compl_subset_compl.mpr (λ x h, _)) (subset_to_measurable _ _),
    exact h.1, },
  exact (h_ss hx i).symm,
end

lemma ae_seq_eq_mk_of_mem_ae_seq_set (hf : ∀ i, ae_measurable (f i) μ) {x : α}
  (hx : x ∈ ae_seq_set hf p) (i : ι) :
  ae_seq hf p i x = (hf i).mk (f i) x :=
by simp only [ae_seq, hx, if_true]

lemma ae_seq_eq_fun_of_mem_ae_seq_set (hf : ∀ i, ae_measurable (f i) μ) {x : α}
  (hx : x ∈ ae_seq_set hf p) (i : ι) :
  ae_seq hf p i x = f i x :=
by simp only [ae_seq_eq_mk_of_mem_ae_seq_set hf hx i, mk_eq_fun_of_mem_ae_seq_set hf hx i]

lemma prop_of_mem_ae_seq_set (hf : ∀ i, ae_measurable (f i) μ)
  {x : α} (hx : x ∈ ae_seq_set hf p) :
  p x (λ n, ae_seq hf p n x) :=
begin
  simp only [ae_seq, hx, if_true],
  rw funext (λ n, mk_eq_fun_of_mem_ae_seq_set hf hx n),
  have h_ss : ae_seq_set hf p ⊆ {x | p x (λ n, f n x)},
  { rw [←compl_compl {x | p x (λ n, f n x)}, ae_seq_set, set.compl_subset_compl],
    refine set.subset.trans (set.compl_subset_compl.mpr _) (subset_to_measurable _ _),
    exact λ x hx, hx.2, },
  have hx' := set.mem_of_subset_of_mem h_ss hx,
  exact hx',
end

lemma fun_prop_of_mem_ae_seq_set (hf : ∀ i, ae_measurable (f i) μ)
  {x : α} (hx : x ∈ ae_seq_set hf p) :
  p x (λ n, f n x) :=
begin
  have h_eq : (λ n, f n x) = λ n, ae_seq hf p n x,
    from funext (λ n, (ae_seq_eq_fun_of_mem_ae_seq_set hf hx n).symm),
  rw h_eq,
  exact prop_of_mem_ae_seq_set hf hx,
end

end mem_ae_seq_set

lemma measurable (hf : ∀ i, ae_measurable (f i) μ) (p : α → (ι → β) → Prop)
  (i : ι) :
  measurable (ae_seq hf p i) :=
measurable.ite ae_seq_set_measurable_set (hf i).measurable_mk $ measurable_const' $
  λ x y, rfl

lemma measure_compl_ae_seq_set_eq_zero [countable ι] (hf : ∀ i, ae_measurable (f i) μ)
  (hp : ∀ᵐ x ∂μ, p x (λ n, f n x)) :
  μ (ae_seq_set hf p)ᶜ = 0 :=
begin
  rw [ae_seq_set, compl_compl, measure_to_measurable],
  have hf_eq := λ i, (hf i).ae_eq_mk,
  simp_rw [filter.eventually_eq, ←ae_all_iff] at hf_eq,
  exact filter.eventually.and hf_eq hp,
end

lemma ae_seq_eq_mk_ae [countable ι] (hf : ∀ i, ae_measurable (f i) μ)
  (hp : ∀ᵐ x ∂μ, p x (λ n, f n x)) :
  ∀ᵐ (a : α) ∂μ, ∀ (i : ι), ae_seq hf p i a = (hf i).mk (f i) a :=
begin
  have h_ss : ae_seq_set hf p ⊆ {a : α | ∀ i, ae_seq hf p i a = (hf i).mk (f i) a},
    from λ x hx i, by simp only [ae_seq, hx, if_true],
  exact le_antisymm (le_trans (measure_mono (set.compl_subset_compl.mpr h_ss))
    (le_of_eq (measure_compl_ae_seq_set_eq_zero hf hp))) (zero_le _),
end

lemma ae_seq_eq_fun_ae [countable ι] (hf : ∀ i, ae_measurable (f i) μ)
  (hp : ∀ᵐ x ∂μ, p x (λ n, f n x)) :
  ∀ᵐ (a : α) ∂μ, ∀ (i : ι), ae_seq hf p i a = f i a :=
begin
  have h_ss : {a : α | ¬∀ (i : ι), ae_seq hf p i a = f i a} ⊆ (ae_seq_set hf p)ᶜ,
    from λ x, mt (λ hx i, (ae_seq_eq_fun_of_mem_ae_seq_set hf hx i)),
  exact measure_mono_null h_ss (measure_compl_ae_seq_set_eq_zero hf hp),
end

lemma ae_seq_n_eq_fun_n_ae [countable ι] (hf : ∀ i, ae_measurable (f i) μ)
  (hp : ∀ᵐ x ∂μ, p x (λ n, f n x)) (n : ι) :
  ae_seq hf p n =ᵐ[μ] f n:=
ae_all_iff.mp (ae_seq_eq_fun_ae hf hp) n

lemma supr [complete_lattice β] [countable ι]
  (hf : ∀ i, ae_measurable (f i) μ) (hp : ∀ᵐ x ∂μ, p x (λ n, f n x)) :
  (⨆ n, ae_seq hf p n) =ᵐ[μ] ⨆ n, f n :=
begin
  simp_rw [filter.eventually_eq, ae_iff, supr_apply],
  have h_ss : ae_seq_set hf p ⊆ {a : α | (⨆ (i : ι), ae_seq hf p i a) = ⨆ (i : ι), f i a},
  { intros x hx,
    congr,
    exact funext (λ i, ae_seq_eq_fun_of_mem_ae_seq_set hf hx i), },
  exact measure_mono_null (set.compl_subset_compl.mpr h_ss)
    (measure_compl_ae_seq_set_eq_zero hf hp),
end

end ae_seq


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

Free groups as a quotient over the reduction relation `a * x * x⁻¹ * b = a * b`.

First we introduce the one step reduction relation
  `free_group.red.step`:  w * x * x⁻¹ * v   ~>   w * v
its reflexive transitive closure:
  `free_group.red.trans`
and proof that its join is an equivalence relation.

Then we introduce `free_group α` as a quotient over `free_group.red.step`.
-/
import logic.relation
import algebra.group algebra.group_power
import data.fintype data.list.basic data.quot
import group_theory.subgroup
open relation
variables {α : Type*}

local attribute [simp] list.append_eq_has_append

namespace free_group
variables {L L₁ L₂ L₃ L₄ : list (α × bool)}

/-- Reduction step: `w * x * x⁻¹ * v ~> w * v` -/
inductive red.step : list (α × bool) → list (α × bool) → Prop
| bnot {L₁ L₂ x b} : red.step (L₁ ++ (x, b) :: (x, bnot b) :: L₂) (L₁ ++ L₂)
attribute [simp] red.step.bnot

/-- Reflexive-transitive closure of red.step -/
def red : list (α × bool) → list (α × bool) → Prop := refl_trans_gen red.step

@[refl] lemma red.refl : red L L := refl_trans_gen.refl
@[trans] lemma red.trans : red L₁ L₂ → red L₂ L₃ → red L₁ L₃ := refl_trans_gen.trans

namespace red

/-- Predicate asserting that word `w₁` can be reduced to `w₂` in one step, i.e. there are words
`w₃ w₄` and letter `x` such that `w₁ = w₃xx⁻¹w₄` and `w₂ = w₃w₄`  -/
theorem step.length : ∀ {L₁ L₂ : list (α × bool)}, step L₁ L₂ → L₂.length + 2 = L₁.length
| _ _ (@red.step.bnot _ L1 L2 x b) := by rw [list.length_append, list.length_append]; refl

@[simp] lemma step.bnot_rev {x b} : step (L₁ ++ (x, bnot b) :: (x, b) :: L₂) (L₁ ++ L₂) :=
by cases b; from step.bnot

@[simp] lemma step.cons_bnot {x b} : red.step ((x, b) :: (x, bnot b) :: L) L :=
@step.bnot _ [] _ _ _

@[simp] lemma step.cons_bnot_rev {x b} : red.step ((x, bnot b) :: (x, b) :: L) L :=
@red.step.bnot_rev _ [] _ _ _

theorem step.append_left : ∀ {L₁ L₂ L₃ : list (α × bool)}, step L₂ L₃ → step (L₁ ++ L₂) (L₁ ++ L₃)
| _ _ _ red.step.bnot := by rw [← list.append_assoc, ← list.append_assoc]; constructor

theorem step.cons {x} (H : red.step L₁ L₂) : red.step (x :: L₁) (x :: L₂) :=
@step.append_left _ [x] _ _ H

theorem step.append_right : ∀ {L₁ L₂ L₃ : list (α × bool)}, step L₁ L₂ → step (L₁ ++ L₃) (L₂ ++ L₃)
| _ _ _ red.step.bnot := by simp

lemma not_step_nil : ¬ step [] L :=
begin
  generalize h' : [] = L',
  assume h,
  cases h with L₁ L₂,
  simp [list.nil_eq_append_iff] at h',
  contradiction
end

lemma step.cons_left_iff {a : α} {b : bool} :
  step ((a, b) :: L₁) L₂ ↔ (∃L, step L₁ L ∧ L₂ = (a, b) :: L) ∨ (L₁ = (a, bnot b)::L₂) :=
begin
  split,
  { generalize hL : ((a, b) :: L₁ : list _) = L,
    assume h,
    rcases h with ⟨_ | ⟨p, s'⟩, e, a', b'⟩,
    { simp at hL, simp [*] },
    { simp at hL,
      rcases hL with ⟨rfl, rfl⟩,
      refine or.inl ⟨s' ++ e, step.bnot, _⟩,
      simp } },
  { assume h,
    rcases h with ⟨L, h, rfl⟩ | rfl,
    { exact step.cons h },
    { exact step.cons_bnot } }
end

lemma not_step_singleton : ∀ {p : α × bool}, ¬ step [p] L
| (a, b) := by simp [step.cons_left_iff, not_step_nil]

lemma step.cons_cons_iff : ∀{p : α × bool}, step (p :: L₁) (p :: L₂) ↔ step L₁ L₂ :=
by simp [step.cons_left_iff, iff_def, or_imp_distrib] {contextual := tt}

lemma step.append_left_iff : ∀L, step (L ++ L₁) (L ++ L₂) ↔ step L₁ L₂
| [] := by simp
| (p :: l) := by simp [step.append_left_iff l, step.cons_cons_iff]

private theorem step.diamond_aux : ∀ {L₁ L₂ L₃ L₄ : list (α × bool)} {x1 b1 x2 b2},
  L₁ ++ (x1, b1) :: (x1, bnot b1) :: L₂ = L₃ ++ (x2, b2) :: (x2, bnot b2) :: L₄ →
  L₁ ++ L₂ = L₃ ++ L₄ ∨ ∃ L₅, red.step (L₁ ++ L₂) L₅ ∧ red.step (L₃ ++ L₄) L₅
| []        _ []        _ _ _ _ _ H := by injections; subst_vars; simp
| []        _ [(x3,b3)] _ _ _ _ _ H := by injections; subst_vars; simp
| [(x3,b3)] _ []        _ _ _ _ _ H := by injections; subst_vars; simp
| []                     _ ((x3,b3)::(x4,b4)::tl) _ _ _ _ _ H :=
  by injections; subst_vars; simp; right; exact ⟨_, red.step.bnot, red.step.cons_bnot⟩
| ((x3,b3)::(x4,b4)::tl) _ []                     _ _ _ _ _ H :=
  by injections; subst_vars; simp; right; exact ⟨_, red.step.cons_bnot, red.step.bnot⟩
| ((x3,b3)::tl) _ ((x4,b4)::tl2) _ _ _ _ _ H :=
  let ⟨H1, H2⟩ := list.cons.inj H in
  match step.diamond_aux H2 with
    | or.inl H3 := or.inl $ by simp [H1, H3]
    | or.inr ⟨L₅, H3, H4⟩ := or.inr
      ⟨_, step.cons H3, by simpa [H1] using step.cons H4⟩
  end

theorem step.diamond : ∀ {L₁ L₂ L₃ L₄ : list (α × bool)},
  red.step L₁ L₃ → red.step L₂ L₄ → L₁ = L₂ →
  L₃ = L₄ ∨ ∃ L₅, red.step L₃ L₅ ∧ red.step L₄ L₅
| _ _ _ _ red.step.bnot red.step.bnot H := step.diamond_aux H

lemma step.to_red : step L₁ L₂ → red L₁ L₂ :=
refl_trans_gen.single

/-- Church-Rosser theorem for word reduction: If `w1 w2 w3` are words such that `w1` reduces to `w2`
and `w3` respectively, then there is a word `w4` such that `w2` and `w3` reduce to `w4` respectively. -/
theorem church_rosser : red L₁ L₂ → red L₁ L₃ → join red L₂ L₃ :=
relation.church_rosser (assume a b c hab hac,
match b, c, red.step.diamond hab hac rfl with
| b, _, or.inl rfl           := ⟨b, by refl, by refl⟩
| b, c, or.inr ⟨d, hbd, hcd⟩ := ⟨d, refl_gen.single hbd, hcd.to_red⟩
end)

lemma cons_cons {p} : red L₁ L₂ → red (p :: L₁) (p :: L₂) :=
refl_trans_gen_lift (list.cons p) (assume a b, step.cons)

lemma cons_cons_iff (p) : red (p :: L₁) (p :: L₂) ↔ red L₁ L₂ :=
iff.intro
  begin
    generalize eq₁ : (p :: L₁ : list _) = LL₁,
    generalize eq₂ : (p :: L₂ : list _) = LL₂,
    assume h,
    induction h using relation.refl_trans_gen.head_induction_on
      with L₁ L₂ h₁₂ h ih
      generalizing L₁ L₂,
    { subst_vars, cases eq₂, constructor },
    { subst_vars,
      cases p with a b,
      rw [step.cons_left_iff] at h₁₂,
      rcases h₁₂ with ⟨L, h₁₂, rfl⟩ | rfl,
      { exact (ih rfl rfl).head h₁₂ },
      { exact (cons_cons h).tail step.cons_bnot_rev } }
  end
  cons_cons

lemma append_append_left_iff : ∀L, red (L ++ L₁) (L ++ L₂) ↔ red L₁ L₂
| []       := iff.refl _
| (p :: L) := by simp [append_append_left_iff L, cons_cons_iff]

lemma append_append (h₁ : red L₁ L₃) (h₂ : red L₂ L₄) : red (L₁ ++ L₂) (L₃ ++ L₄) :=
(refl_trans_gen_lift (λL, L ++ L₂) (assume a b, step.append_right) h₁).trans
  ((append_append_left_iff _).2 h₂)

lemma to_append_iff : red L (L₁ ++ L₂) ↔ (∃L₃ L₄, L = L₃ ++ L₄ ∧ red L₃ L₁ ∧ red L₄ L₂) :=
iff.intro
  begin
    generalize eq : L₁ ++ L₂ = L₁₂,
    assume h,
    induction h with L' L₁₂ hLL' h ih generalizing L₁ L₂,
    { exact ⟨_, _, eq.symm, by refl, by refl⟩ },
    { cases h with s e a b,
      rcases list.append_eq_append_iff.1 eq with ⟨s', rfl, rfl⟩ | ⟨e', rfl, rfl⟩,
      { have : L₁ ++ (s' ++ ((a, b) :: (a, bnot b) :: e)) = (L₁ ++ s') ++ ((a, b) :: (a, bnot b) :: e),
        { simp },
        rcases ih this with ⟨w₁, w₂, rfl, h₁, h₂⟩,
        exact ⟨w₁, w₂, rfl, h₁, h₂.tail step.bnot⟩ },
      { have : (s ++ ((a, b) :: (a, bnot b) :: e')) ++ L₂ = s ++ ((a, b) :: (a, bnot b) :: (e' ++ L₂)),
        { simp },
        rcases ih this with ⟨w₁, w₂, rfl, h₁, h₂⟩,
        exact ⟨w₁, w₂, rfl, h₁.tail step.bnot, h₂⟩ }, }
  end
  (assume ⟨L₃, L₄, eq, h₃, h₄⟩, eq.symm ▸ append_append h₃ h₄)

/-- The empty word `[]` only reduces to itself. -/
theorem nil_iff : red [] L ↔ L = [] :=
refl_trans_gen_iff_eq (assume l, red.not_step_nil)

/-- A letter only reduces to itself. -/
theorem singleton_iff {x} : red [x] L₁ ↔ L₁ = [x] :=
refl_trans_gen_iff_eq (assume l, not_step_singleton)

/-- If `x` is a letter and `w` is a word such that `xw` reduces to the empty word, then `w` reduces
to `x⁻¹` -/
theorem cons_nil_iff_singleton {x b} : red ((x, b) :: L) [] ↔ red L [(x, bnot b)] :=
iff.intro
  (assume h,
    have h₁ : red ((x, bnot b) :: (x, b) :: L) [(x, bnot b)], from cons_cons h,
    have h₂ : red ((x, bnot b) :: (x, b) :: L) L, from refl_trans_gen.single step.cons_bnot_rev,
    let ⟨L', h₁, h₂⟩ := church_rosser h₁ h₂ in
    by rw [singleton_iff] at h₁; subst L'; assumption)
  (assume h, (cons_cons h).tail step.cons_bnot)

theorem red_iff_irreducible {x1 b1 x2 b2} (h : (x1, b1) ≠ (x2, b2)) :
  red [(x1, bnot b1), (x2, b2)] L ↔ L = [(x1, bnot b1), (x2, b2)] :=
begin
  apply refl_trans_gen_iff_eq,
  generalize eq : [(x1, bnot b1), (x2, b2)] = L',
  assume L h',
  cases h',
  simp [list.cons_eq_append_iff, list.nil_eq_append_iff] at eq,
  rcases eq with ⟨rfl, ⟨rfl, rfl⟩, ⟨rfl, rfl⟩, rfl⟩, subst_vars,
  simp at h,
  contradiction
end

/-- If `x` and `y` are distinct letters and `w₁ w₂` are words such that `xw₁` reduces to `yw₂`, then
`w₁` reduces to `x⁻¹yw₂`. -/
theorem inv_of_red_of_ne {x1 b1 x2 b2}
  (H1 : (x1, b1) ≠ (x2, b2))
  (H2 : red ((x1, b1) :: L₁) ((x2, b2) :: L₂)) :
  red L₁ ((x1, bnot b1) :: (x2, b2) :: L₂) :=
begin
  have : red ((x1, b1) :: L₁) ([(x2, b2)] ++ L₂), from H2,
  rcases to_append_iff.1 this with ⟨_ | ⟨p, L₃⟩, L₄, eq, h₁, h₂⟩,
  { simp [nil_iff] at h₁, contradiction },
  { cases eq,
    show red (L₃ ++ L₄) ([(x1, bnot b1), (x2, b2)] ++ L₂),
    apply append_append _ h₂,
    have h₁ : red ((x1, bnot b1) :: (x1, b1) :: L₃) [(x1, bnot b1), (x2, b2)],
    { exact cons_cons h₁ },
    have h₂ : red ((x1, bnot b1) :: (x1, b1) :: L₃) L₃,
    { exact step.cons_bnot_rev.to_red },
    rcases church_rosser h₁ h₂ with ⟨L', h₁, h₂⟩,
    rw [red_iff_irreducible H1] at h₁,
    rwa [h₁] at h₂ }
end

theorem step.sublist (H : red.step L₁ L₂) : L₂ <+ L₁ :=
by cases H; simp; constructor; constructor; refl

/-- If `w₁ w₂` are words such that `w₁` reduces to `w₂`, then `w₂` is a sublist of `w₁`. -/
theorem sublist : red L₁ L₂ → L₂ <+ L₁ :=
refl_trans_gen_of_transitive_reflexive
  (λl, list.sublist.refl l) (λa b c hab hbc, list.sublist.trans hbc hab) (λa b, red.step.sublist)

theorem sizeof_of_step : ∀ {L₁ L₂ : list (α × bool)}, step L₁ L₂ → L₂.sizeof < L₁.sizeof
| _ _ (@step.bnot _ L1 L2 x b) :=
  begin
    induction L1 with hd tl ih,
    case list.nil
    { dsimp [list.sizeof],
      have H : 1 + sizeof (x, b) + (1 + sizeof (x, bnot b) + list.sizeof L2)
        = (list.sizeof L2 + 1) + (sizeof (x, b) + sizeof (x, bnot b) + 1),
      { ac_refl },
      rw H,
      exact nat.le_add_right _ _ },
    case list.cons
    { dsimp [list.sizeof],
      exact nat.add_lt_add_left ih _ }
  end

theorem length (h : red L₁ L₂) : ∃ n, L₁.length = L₂.length + 2 * n :=
begin
  induction h with L₂ L₃ h₁₂ h₂₃ ih,
  { exact ⟨0, rfl⟩ },
  { rcases ih with ⟨n, eq⟩,
    existsi (1 + n),
    simp [mul_add, eq, (step.length h₂₃).symm] }
end

theorem antisymm (h₁₂ : red L₁ L₂) : red L₂ L₁ → L₁ = L₂ :=
match L₁, h₁₂.cases_head with
| _,  or.inl rfl            := assume h, rfl
| L₁, or.inr ⟨L₃, h₁₃, h₃₂⟩ := assume h₂₁,
  let ⟨n, eq⟩ := length (h₃₂.trans h₂₁) in
  have list.length L₃ + 0 = list.length L₃ + (2 * n + 2),
    by simpa [(step.length h₁₃).symm, add_comm, add_assoc] using eq,
  (nat.no_confusion $ nat.add_left_cancel this)
end

end red

theorem equivalence_join_red : equivalence (join (@red α)) :=
equivalence_join_refl_trans_gen $ assume a b c hab hac,
(match b, c, red.step.diamond hab hac rfl with
| b, _, or.inl rfl           := ⟨b, by refl, by refl⟩
| b, c, or.inr ⟨d, hbd, hcd⟩ := ⟨d, refl_gen.single hbd, refl_trans_gen.single hcd⟩
end)

theorem join_red_of_step (h : red.step L₁ L₂) : join red L₁ L₂ :=
join_of_single reflexive_refl_trans_gen h.to_red

theorem eqv_gen_step_iff_join_red : eqv_gen red.step L₁ L₂ ↔ join red L₁ L₂ :=
iff.intro
  (assume h,
    have eqv_gen (join red) L₁ L₂ := eqv_gen_mono (assume a b, join_red_of_step) h,
    (eqv_gen_iff_of_equivalence $ equivalence_join_red).1 this)
  (join_of_equivalence (eqv_gen.is_equivalence _) $ assume a b,
    refl_trans_gen_of_equivalence (eqv_gen.is_equivalence _) eqv_gen.rel)

end free_group

/-- The free group over a type, i.e. the words formed by the elements of the type and their formal
inverses, quotient by one step reduction. -/
def free_group (α : Type*) : Type* :=
quot $ @free_group.red.step α

namespace free_group

variables {α} {L L₁ L₂ L₃ L₄ : list (α × bool)}

def mk (L) : free_group α := quot.mk red.step L

@[simp] lemma quot_mk_eq_mk : quot.mk red.step L = mk L := rfl

@[simp] lemma quot_lift_mk (β : Type*) (f : list (α × bool) → β)
  (H : ∀ L₁ L₂, red.step L₁ L₂ → f L₁ = f L₂) :
quot.lift f H (mk L) = f L := rfl

@[simp] lemma quot_lift_on_mk (β : Type*) (f : list (α × bool) → β)
  (H : ∀ L₁ L₂, red.step L₁ L₂ → f L₁ = f L₂) :
quot.lift_on (mk L) f H = f L := rfl

instance : has_one (free_group α) := ⟨mk []⟩
lemma one_eq_mk : (1 : free_group α) = mk [] := rfl

instance : has_mul (free_group α) :=
⟨λ x y, quot.lift_on x
    (λ L₁, quot.lift_on y (λ L₂, mk $ L₁ ++ L₂) (λ L₂ L₃ H, quot.sound $ red.step.append_left H))
    (λ L₁ L₂ H, quot.induction_on y $ λ L₃, quot.sound $ red.step.append_right H)⟩
@[simp] lemma mul_mk : mk L₁ * mk L₂ = mk (L₁ ++ L₂) := rfl

instance : has_inv (free_group α) :=
⟨λx, quot.lift_on x (λ L, mk (L.map $ λ x : α × bool, (x.1, bnot x.2)).reverse)
  (assume a b h, quot.sound $ by cases h; simp)⟩
@[simp] lemma inv_mk : (mk L)⁻¹ = mk (L.map $ λ x : α × bool, (x.1, bnot x.2)).reverse := rfl

instance : group (free_group α) :=
{ mul := (*),
  one := 1,
  inv := has_inv.inv,
  mul_assoc := by rintros ⟨L₁⟩ ⟨L₂⟩ ⟨L₃⟩; simp,
  one_mul := by rintros ⟨L⟩; refl,
  mul_one := by rintros ⟨L⟩; simp [one_eq_mk],
  mul_left_inv := by rintros ⟨L⟩; exact (list.rec_on L rfl $
    λ ⟨x, b⟩ tl ih, eq.trans (quot.sound $ by simp [one_eq_mk]) ih) }

/-- `of x` is the canonical injection from the type to the free group over that type by sending each
element to the equivalence class of the letter that is the element. -/
def of (x : α) : free_group α :=
mk [(x, tt)]

theorem red.exact : mk L₁ = mk L₂ ↔ join red L₁ L₂ :=
calc (mk L₁ = mk L₂) ↔ eqv_gen red.step L₁ L₂ : iff.intro (quot.exact _) quot.eqv_gen_sound
  ... ↔ join red L₁ L₂ : eqv_gen_step_iff_join_red

/-- The canonical injection from the type to the free group is an injection. -/
theorem of.inj {x y : α} (H : of x = of y) : x = y :=
let ⟨L₁, hx, hy⟩ := red.exact.1 H in
by simp [red.singleton_iff] at hx hy; cc

section to_group

variables {β : Type*} [group β] (f : α → β) {x y : free_group α}

def to_group.aux : list (α × bool) → β :=
λ L, list.prod $ L.map $ λ x, cond x.2 (f x.1) (f x.1)⁻¹

theorem red.step.to_group {f : α → β} (H : red.step L₁ L₂) :
  to_group.aux f L₁ = to_group.aux f L₂ :=
by cases H with _ _ _ b; cases b; simp [to_group.aux]

/-- If `β` is a group, then any function from `α` to `β`
extends uniquely to a group homomorphism from
the free group over `α` to `β` -/
def to_group : free_group α → β :=
quot.lift (to_group.aux f) $ λ L₁ L₂ H, red.step.to_group H

variable {f}

@[simp] lemma to_group.mk : to_group f (mk L) =
  list.prod (L.map $ λ x, cond x.2 (f x.1) (f x.1)⁻¹) :=
rfl

@[simp] lemma to_group.of {x} : to_group f (of x) = f x :=
one_mul _

instance to_group.is_group_hom : is_group_hom (to_group f) :=
⟨by rintros ⟨L₁⟩ ⟨L₂⟩; simp⟩

@[simp] lemma to_group.mul : to_group f (x * y) = to_group f x * to_group f y :=
is_group_hom.mul _ _ _

@[simp] lemma to_group.one : to_group f 1 = 1 :=
is_group_hom.one _

@[simp] lemma to_group.inv : to_group f x⁻¹ = (to_group f x)⁻¹ :=
is_group_hom.inv _ _

theorem to_group.unique (g : free_group α → β) [is_group_hom g]
  (hg : ∀ x, g (of x) = f x) : ∀{x}, g x = to_group f x :=
by rintros ⟨L⟩; exact list.rec_on L (is_group_hom.one g)
(λ ⟨x, b⟩ t (ih : g (mk t) = _), bool.rec_on b
  (show g ((of x)⁻¹ * mk t) = to_group f (mk ((x, ff) :: t)),
     by simp [is_group_hom.mul g, is_group_hom.inv g, hg, ih, to_group, to_group.aux])
  (show g (of x * mk t) = to_group f (mk ((x, tt) :: t)),
     by simp [is_group_hom.mul g, is_group_hom.inv g, hg, ih, to_group, to_group.aux]))

theorem to_group.of_eq (x : free_group α) : to_group of x = x :=
eq.symm $ to_group.unique id (λ x, rfl)

theorem to_group.range_subset {s : set β} [is_subgroup s] (H : set.range f ⊆ s) :
  set.range (to_group f) ⊆ s :=
by rintros _ ⟨⟨L⟩, rfl⟩; exact list.rec_on L (is_submonoid.one_mem s)
(λ ⟨x, b⟩ tl ih, bool.rec_on b
    (by simp at ih ⊢; from is_submonoid.mul_mem
      (is_subgroup.inv_mem $ H ⟨x, rfl⟩) ih)
    (by simp at ih ⊢; from is_submonoid.mul_mem (H ⟨x, rfl⟩) ih))

theorem to_group.range_eq_closure :
  set.range (to_group f) = group.closure (set.range f) :=
set.subset.antisymm
  (to_group.range_subset group.subset_closure)
  (group.closure_subset $ λ y ⟨x, hx⟩, ⟨of x, by simpa⟩)

end to_group

section map

variables {β : Type*} (f : α → β) {x y : free_group α}

def map.aux (L : list (α × bool)) : list (β × bool) :=
L.map $ λ x, (f x.1, x.2)

/-- Any function from `α` to `β` extends uniquely
to a group homomorphism from the free group
ver `α` to the free group over `β`. -/
def map (x : free_group α) : free_group β :=
x.lift_on (λ L, mk $ map.aux f L) $
λ L₁ L₂ H, quot.sound $ by cases H; simp [map.aux]

instance map.is_group_hom : is_group_hom (map f) :=
⟨by rintros ⟨L₁⟩ ⟨L₂⟩; simp [map, map.aux]⟩

variable {f}

@[simp] lemma map.mk : map f (mk L) = mk (L.map (λ x, (f x.1, x.2))) :=
rfl

@[simp] lemma map.id : map id x = x :=
have H1 : (λ (x : α × bool), x) = id := rfl,
by rcases x with ⟨L⟩; simp [H1]

@[simp] lemma map.id' : map (λ z, z) x = x := map.id

theorem map.comp {γ : Type*} {f : α → β} {g : β → γ} {x} :
  map g (map f x) = map (g ∘ f) x :=
by rcases x with ⟨L⟩; simp

@[simp] lemma map.of {x} : map f (of x) = of (f x) := rfl

@[simp] lemma map.mul : map f (x * y) = map f x * map f y :=
is_group_hom.mul _ x y

@[simp] lemma map.one : map f 1 = 1 :=
is_group_hom.one _

@[simp] lemma map.inv : map f x⁻¹ = (map f x)⁻¹ :=
is_group_hom.inv _ x

theorem map.unique (g : free_group α → free_group β) [is_group_hom g]
  (hg : ∀ x, g (of x) = of (f x)) : ∀{x}, g x = map f x :=
by rintros ⟨L⟩; exact list.rec_on L (is_group_hom.one g)
(λ ⟨x, b⟩ t (ih : g (mk t) = map f (mk t)), bool.rec_on b
  (show g ((of x)⁻¹ * mk t) = map f ((of x)⁻¹ * mk t),
     by simp [is_group_hom.mul g, is_group_hom.inv g, hg, ih])
  (show g (of x * mk t) = map f (of x * mk t),
     by simp [is_group_hom.mul g, hg, ih]))

/-- Equivalent types give rise to equivalent free groups. -/
def free_group_congr {α β} (e : α ≃ β) : free_group α ≃ free_group β :=
⟨map e, map e.symm,
 λ x, by simp [function.comp, map.comp],
 λ x, by simp [function.comp, map.comp]⟩

theorem map_eq_to_group : map f x = to_group (of ∘ f) x :=
eq.symm $ map.unique _ $ λ x, by simp

end map

section prod

variables [group α] (x y : free_group α)

/-- If `α` is a group, then any function from `α` to `α`
extends uniquely to a homomorphism from the
free group over `α` to `α`. This is the multiplicative
version of `sum`. -/
def prod : α :=
to_group id x

variables {x y}

@[simp] lemma prod_mk :
  prod (mk L) = list.prod (L.map $ λ x, cond x.2 x.1 x.1⁻¹) :=
rfl

@[simp] lemma prod.of {x : α} : prod (of x) = x :=
to_group.of

instance prod.is_group_hom : is_group_hom (@prod α _) :=
to_group.is_group_hom

@[simp] lemma prod.mul : prod (x * y) = prod x * prod y :=
to_group.mul

@[simp] lemma prod.one : prod (1:free_group α) = 1 :=
to_group.one

@[simp] lemma prod.inv : prod x⁻¹ = (prod x)⁻¹ :=
to_group.inv

lemma prod.unique (g : free_group α → α) [is_group_hom g]
  (hg : ∀ x, g (of x) = x) {x} :
  g x = prod x :=
to_group.unique g hg

end prod

theorem to_group_eq_prod_map {β : Type*} [group β] {f : α → β} {x} :
  to_group f x = prod (map f x) :=
eq.symm $ to_group.unique (prod ∘ map f) $ λ _, by simp

section sum

variables [add_group α] (x y : free_group α)

/-- If `α` is a group, then any function from `α` to `α`
extends uniquely to a homomorphism from the
free group over `α` to `α`. This is the additive
version of `prod`. -/
def sum : α :=
@prod (multiplicative _) _ x

variables {x y}

@[simp] lemma sum_mk :
  sum (mk L) = list.sum (L.map $ λ x, cond x.2 x.1 (-x.1)) :=
rfl

@[simp] lemma sum.of {x : α} : sum (of x) = x :=
prod.of

instance sum.is_group_hom : is_group_hom (@sum α _) :=
prod.is_group_hom

@[simp] lemma sum.sum : sum (x * y) = sum x + sum y :=
prod.mul

@[simp] lemma sum.one : sum (1:free_group α) = 0 :=
prod.one

@[simp] lemma sum.inv : sum x⁻¹ = -sum x :=
prod.inv

end sum

def free_group_empty_equiv_unit : free_group empty ≃ unit :=
{ to_fun    := λ _, (),
  inv_fun   := λ _, 1,
  left_inv  := by rintros ⟨_ | ⟨⟨⟨⟩, _⟩, _⟩⟩; refl,
  right_inv := λ ⟨⟩, rfl }

def free_group_unit_equiv_int : free_group unit ≃ int :=
{ to_fun    := λ x, sum $ map (λ _, 1) x,
  inv_fun   := λ x, of () ^ x,
  left_inv  := by rintros ⟨L⟩; exact list.rec_on L rfl
    (λ ⟨⟨⟩, b⟩ tl ih, by cases b; simp [gpow_add] at ih ⊢; rw ih; refl),
  right_inv := λ x, int.induction_on x (by simp)
    (λ i ih, by simp at ih; simp [gpow_add, ih])
    (λ i ih, by simp at ih; simp [gpow_add, ih]) }

section reduce

variable [decidable_eq α]

/-- The maximal reduction of a word. It is computable
iff `α` has decidable equality. -/
def reduce (L : list (α × bool)) : list (α × bool) :=
list.rec_on L [] $ λ hd1 tl1 ih,
list.cases_on ih [hd1] $ λ hd2 tl2,
if hd1.1 = hd2.1 ∧ hd1.2 = bnot hd2.2 then tl2
else hd1 :: hd2 :: tl2

@[simp] lemma reduce.cons (x) : reduce (x :: L) =
  list.cases_on (reduce L) [x] (λ hd tl,
  if x.1 = hd.1 ∧ x.2 = bnot hd.2 then tl
  else x :: hd :: tl) := rfl

/-- The first theorem that characterises the function
`reduce`: a word reduces to its maximal reduction. -/
theorem reduce.red : red L (reduce L) :=
begin
  induction L with hd1 tl1 ih,
  case list.nil
  { constructor },
  case list.cons
  { dsimp,
    revert ih,
    generalize htl : reduce tl1 = TL,
    intro ih,
    cases TL with hd2 tl2,
    case list.nil
    { exact red.cons_cons ih },
    case list.cons
    { dsimp,
      by_cases h : hd1.fst = hd2.fst ∧ hd1.snd = bnot (hd2.snd),
      { rw [if_pos h],
        transitivity,
        { exact red.cons_cons ih },
        { cases hd1, cases hd2, cases h,
          dsimp at *, subst_vars,
          exact red.step.cons_bnot_rev.to_red } },
      { rw [if_neg h],
        exact red.cons_cons ih } } }
end

theorem reduce.not {p : Prop} : ∀ {L₁ L₂ L₃ : list (α × bool)} {x b}, reduce L₁ = L₂ ++ (x, b) :: (x, bnot b) :: L₃ → p
| [] L2 L3 _ _ := λ h, by cases L2; injections
| ((x,b)::L1) L2 L3 x' b' := begin
  dsimp,
  cases r : reduce L1,
  { dsimp, intro h,
    have := congr_arg list.length h,
    simp [-add_comm] at this,
    exact absurd this dec_trivial },
  cases hd with y c,
  by_cases x = y ∧ b = bnot c; simp [h]; intro H,
  { rw H at r,
    exact @reduce.not L1 ((y,c)::L2) L3 x' b' r },
  rcases L2 with _|⟨a, L2⟩,
  { injections, subst_vars,
    simp at h, cc },
  { refine @reduce.not L1 L2 L3 x' b' _,
    injection H with _ H,
    rw [r, H], refl }
end

/-- The second theorem that characterises the
function `reduce`: the maximal reduction of a word
only reduces to itself. -/
theorem reduce.min (H : red (reduce L₁) L₂) : reduce L₁ = L₂ :=
begin
  induction H with L1 L' L2 H1 H2 ih,
  { refl },
  { cases H1 with L4 L5 x b,
    exact reduce.not H2 }
end

/-- `reduce` is idempotent, i.e. the maximal reduction
of the maximal reduction of a word is the maximal
reduction of the word. -/
theorem reduce.idem : reduce (reduce L) = reduce L :=
eq.symm $ reduce.min reduce.red

theorem reduce.step.eq (H : red.step L₁ L₂) : reduce L₁ = reduce L₂ :=
let ⟨L₃, HR13, HR23⟩ := red.church_rosser reduce.red (reduce.red.head H) in
(reduce.min HR13).trans (reduce.min HR23).symm

/-- If a word reduces to another word, then they have
a common maximal reduction. -/
theorem reduce.eq_of_red (H : red L₁ L₂) : reduce L₁ = reduce L₂ :=
let ⟨L₃, HR13, HR23⟩ := red.church_rosser reduce.red (red.trans H reduce.red) in
(reduce.min HR13).trans (reduce.min HR23).symm

/-- If two words correspond to the same element in
the free group, then they have a common maximal
reduction. This is the proof that the function that
sends an element of the free group to its maximal
reduction is well-defined. -/
theorem reduce.sound (H : mk L₁ = mk L₂) : reduce L₁ = reduce L₂ :=
let ⟨L₃, H13, H23⟩ := red.exact.1 H in
(reduce.eq_of_red H13).trans (reduce.eq_of_red H23).symm

/-- If two words have a common maximal reduction,
then they correspond to the same element in the free group. -/
theorem reduce.exact (H : reduce L₁ = reduce L₂) : mk L₁ = mk L₂ :=
red.exact.2 ⟨reduce L₂, H ▸ reduce.red, reduce.red⟩

/-- A word and its maximal reduction correspond to
the same element of the free group. -/
theorem reduce.self : mk (reduce L) = mk L :=
reduce.exact reduce.idem

/-- If words `w₁ w₂` are such that `w₁` reduces to `w₂`,
then `w₂` reduces to the maximal reduction of `w₁`. -/
theorem reduce.rev (H : red L₁ L₂) : red L₂ (reduce L₁) :=
(reduce.eq_of_red H).symm ▸ reduce.red

/-- The function that sends an element of the free
group to its maximal reduction. -/
def to_word : free_group α → list (α × bool) :=
quot.lift reduce $ λ L₁ L₂ H, reduce.step.eq H

def to_word.mk : ∀{x : free_group α}, mk (to_word x) = x :=
by rintros ⟨L⟩; exact reduce.self

def to_word.inj : ∀(x y : free_group α), to_word x = to_word y → x = y :=
by rintros ⟨L₁⟩ ⟨L₂⟩; exact reduce.exact

/-- Constructive Church-Rosser theorem (compare `church_rosser`). -/
def reduce.church_rosser (H12 : red L₁ L₂) (H13 : red L₁ L₃) :
  { L₄ // red L₂ L₄ ∧ red L₃ L₄ } :=
⟨reduce L₁, reduce.rev H12, reduce.rev H13⟩

instance : decidable_eq (free_group α) :=
function.injective.decidable_eq to_word.inj

instance red.decidable_rel : decidable_rel (@red α)
| [] []          := is_true red.refl
| [] (hd2::tl2)  := is_false $ λ H, list.no_confusion (red.nil_iff.1 H)
| ((x,b)::tl) [] := match red.decidable_rel tl [(x, bnot b)] with
  | is_true H  := is_true $ red.trans (red.cons_cons H) $
    (@red.step.bnot _ [] [] _ _).to_red
  | is_false H := is_false $ λ H2, H $ red.cons_nil_iff_singleton.1 H2
  end
| ((x1,b1)::tl1) ((x2,b2)::tl2) := if h : (x1, b1) = (x2, b2)
  then match red.decidable_rel tl1 tl2 with
    | is_true H  := is_true $ h ▸ red.cons_cons H
    | is_false H := is_false $ λ H2, H $ h ▸ (red.cons_cons_iff _).1 $ H2
    end
  else match red.decidable_rel tl1 ((x1,bnot b1)::(x2,b2)::tl2) with
    | is_true H  := is_true $ (red.cons_cons H).tail red.step.cons_bnot
    | is_false H := is_false $ λ H2, H $ red.inv_of_red_of_ne h H2
    end

/-- A list containing every word that `w₁` reduces to. -/
def red.enum (L₁ : list (α × bool)) : list (list (α × bool)) :=
list.filter (λ L₂, red L₁ L₂) (list.sublists L₁)

theorem red.enum.sound (H : L₂ ∈ red.enum L₁) : red L₁ L₂ :=
list.of_mem_filter H

theorem red.enum.complete (H : red L₁ L₂) : L₂ ∈ red.enum L₁ :=
list.mem_filter_of_mem (list.mem_sublists.2 $ red.sublist H) H

instance : fintype { L₂ // red L₁ L₂ } :=
fintype.subtype (list.to_finset $ red.enum L₁) $
λ L₂, ⟨λ H, red.enum.sound $ list.mem_to_finset.1 H,
  λ H, list.mem_to_finset.2 $ red.enum.complete H⟩

end reduce

end free_group


import Mt.Utils.Fin

namespace Mt.Utils.List

theorem get_in {T : Type u} (l : List T) (idx : Fin l.length)
  : (l.get idx) ∈ l :=match l, idx with
  | a::_, ⟨0, _⟩ => List.Mem.head a _
  | _::as, ⟨n + 1, isLt⟩ => List.Mem.tail _ <| get_in as ⟨n, Nat.le_of_succ_le_succ isLt⟩

theorem get_of_set {T : Type u} (l : List T) (idx : Nat) (a : T)
  (isLt : idx < (l.set idx a).length)
  : (l.set idx a).get ⟨idx, isLt⟩ = a :=match l, idx with
  | _::_, 0 => rfl
  | _::xs, n + 1 => get_of_set xs n a <| Nat.lt_of_succ_lt_succ isLt

theorem erase_subset {T : Type u} {a : T} (l : List T) (idx : Nat)
  : a ∈ (l.eraseIdx idx) → a ∈ l :=match l, idx with
  | [], _ => id
  | x::xs, 0 => fun h => List.Mem.tail _ h
  | x::xs, n+1 => by
    intro h ; cases h
    . exact List.Mem.head ..
    . exact List.Mem.tail x <| erase_subset xs n (by assumption)

theorem set_subset {T : Type u} {a : T} (l : List T) (idx : Nat) (new_value : T)
  : a ∈ (l.set idx new_value) → a = new_value ∨ a ∈ l :=match l, idx with
  | [], _ => Or.inr
  | x::xs, 0 => by
    intro h ; cases h
    . exact Or.inl rfl
    . exact Or.inr <| List.Mem.tail _ (by assumption)
  | x::xs, n+1 => by
    intro h ; cases h
    . exact Or.inr <| List.Mem.head ..
    . cases set_subset xs n new_value (by assumption)
      . exact Or.inl (by assumption)
      . exact Or.inr <| List.Mem.tail _ (by assumption)

theorem index_exists {T : Type u} {a : T} (l : List T)
  : a ∈ l → ∃ i : Fin l.length, l.get i = a :=fun a_in_l => match l, a_in_l with
    | x::xs, a_in_l => by
      cases a_in_l
      . exists ⟨0, by simp_arith⟩
      . apply (index_exists xs (by assumption)).elim
        intro i xs_get_i
        exists ⟨i.val + 1, by simp_arith only [List.length] ; exact i.isLt⟩

theorem erase_set {T : Type u} (l : List T) (idx : Nat) (new_value : T)
  : (l.set idx new_value).eraseIdx idx = l.eraseIdx idx :=match l, idx with
  | [], _ => rfl
  | _::_, 0 => rfl
  | x::xs, n+1 => congrArg (x :: .) <| erase_set xs n new_value

theorem eq_of_in_map {U V : Type u} {f : U -> V} {l : List U} {v : V}
  : v ∈ (l.map f) → ∃ u, u ∈ l ∧ v = f u :=by
  intro v_in_map
  induction l
  . contradiction
  . rename_i head tail IH
    cases v_in_map
    . exact ⟨head, List.Mem.head .., rfl⟩
    . rename_i v_in_map_of_tail
      cases IH v_in_map_of_tail
      rename_i u u_hyp
      exact ⟨u, List.Mem.tail _ u_hyp.left, u_hyp.right⟩

theorem get_congr {T : Type u} {l l' : List T} (idx : Fin l.length)
  (eq : l = l')
  : l.get idx = l'.get (Fin.cast idx (congrArg _ eq)) :=Eq.rec
    (motive :=λ l' eq => l.get idx = l'.get (Fin.cast idx (congrArg _ eq)))
    rfl eq

theorem get_congr' {T : Type u} {l l' : List T}
  {i : Fin l.length}
  {j : Fin l'.length}
  (l_eq : l = l')
  (i_eq : i.val = j.val)
  : l.get i = l'.get j :=by
  have : j = Fin.cast i (congrArg _ l_eq) :=Fin.eq_of_val_eq i_eq.symm
  rw [this]
  exact get_congr _ l_eq

theorem get_of_map {U V : Type u} {f : U -> V} {l : List U}
  {idx : Fin (l.map f).length}
  : (l.map f).get idx = f (l.get (Fin.cast idx (List.length_map l f))) :=
  match l, idx with
  | head :: tail, ⟨0, isLt⟩ => rfl
  | head :: tail, ⟨n + 1, isLt⟩ => by
    simp only [List.map, List.get]
    rw [get_of_map]
    rfl

theorem set_map_commutes {U V : Type u} (f : U -> V) (l : List U)
  (idx : Nat) (new_val : U) :
  (l.set idx new_val).map f = (l.map f).set idx (f new_val) :=by
  revert idx
  induction l
  . intros ; rfl
  . rename_i head tail IH
    intro idx
    cases idx
    . rfl
    . simp only [List.set, List.map]
      rename_i n
      rw [IH n]

theorem erase_map_commutes {U V : Type u} (f : U -> V) (l : List U)
  (idx : Nat) :
  (l.eraseIdx idx).map f = (l.map f).eraseIdx idx :=by
  revert idx
  induction l
  . intros ; rfl
  . rename_i head tail IH
    intro idx
    cases idx
    . rfl
    . simp only [List.eraseIdx, List.map]
      rename_i n
      rw [IH n]

end Mt.Utils.List


/-
Copyright (c) 2020 Patrick Massot. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Patrick Massot
-/
import analysis.specific_limits.basic

/-!
# Hofer's lemma

This is an elementary lemma about complete metric spaces. It is motivated by an
application to the bubbling-off analysis for holomorphic curves in symplectic topology.
We are *very* far away from having these applications, but the proof here is a nice
example of a proof needing to construct a sequence by induction in the middle of the proof.

## References:

* H. Hofer and C. Viterbo, *The Weinstein conjecture in the presence of holomorphic spheres*
-/

open_locale classical topology big_operators
open filter finset

local notation `d` := dist

@[simp] lemma pos_div_pow_pos {α : Type*} [linear_ordered_semifield α] {a b : α} (ha : 0 < a)
  (hb : 0 < b) (k : ℕ) : 0 < a/b^k :=
div_pos ha (pow_pos hb k)

lemma hofer {X: Type*} [metric_space X] [complete_space X]
  (x : X) (ε : ℝ) (ε_pos : 0 < ε)
  {ϕ : X → ℝ} (cont : continuous ϕ) (nonneg : ∀ y, 0 ≤ ϕ y) :
  ∃ (ε' > 0) (x' : X), ε' ≤ ε ∧
                       d x' x ≤ 2*ε ∧
                       ε * ϕ(x) ≤ ε' * ϕ x' ∧
                       ∀ y, d x' y ≤ ε' → ϕ y ≤ 2*ϕ x' :=
begin
  by_contradiction H,
  have reformulation : ∀ x' (k : ℕ), ε * ϕ x ≤ ε / 2 ^ k * ϕ x' ↔ 2^k * ϕ x ≤ ϕ x',
  { intros x' k,
    rw [div_mul_eq_mul_div, le_div_iff, mul_assoc, mul_le_mul_left ε_pos, mul_comm],
    positivity },
  -- Now let's specialize to `ε/2^k`
  replace H : ∀ k : ℕ, ∀ x', d x' x ≤ 2 * ε ∧ 2^k * ϕ x ≤ ϕ x' →
    ∃ y, d x' y ≤ ε/2^k ∧ 2 * ϕ x' < ϕ y,
  { intros k x',
    push_neg at H,
    simpa [reformulation] using H (ε/2^k) (by simp [ε_pos]) x' (by simp [ε_pos.le, one_le_two]) },
  clear reformulation,
  haveI : nonempty X := ⟨x⟩,
  choose! F hF using H,  -- Use the axiom of choice
  -- Now define u by induction starting at x, with u_{n+1} = F(n, u_n)
  let u : ℕ → X := λ n, nat.rec_on n x F,
  have hu0 : u 0 = x := rfl,
  -- The properties of F translate to properties of u
  have hu :
    ∀ n,
      d (u n) x ≤ 2 * ε ∧ 2^n * ϕ x ≤ ϕ (u n) →
      d (u n) (u $ n + 1) ≤ ε / 2 ^ n ∧ 2 * ϕ (u n) < ϕ (u $ n + 1),
  { intro n,
    exact hF n (u n) },
  clear hF,
  -- Key properties of u, to be proven by induction
  have key : ∀ n, d (u n) (u (n + 1)) ≤ ε / 2 ^ n ∧ 2 * ϕ (u n) < ϕ (u (n + 1)),
  { intro n,
    induction n using nat.case_strong_induction_on with n IH,
    { specialize hu 0,
      simpa [hu0, mul_nonneg_iff, zero_le_one, ε_pos.le, le_refl] using hu },
    have A : d (u (n+1)) x ≤ 2 * ε,
    { rw [dist_comm],
      let r := range (n+1), -- range (n+1) = {0, ..., n}
      calc
      d (u 0) (u (n + 1))
          ≤ ∑ i in r, d (u i) (u $ i+1) : dist_le_range_sum_dist u (n + 1)
      ... ≤ ∑ i in r, ε/2^i             : sum_le_sum (λ i i_in, (IH i $ nat.lt_succ_iff.mp $
                                                                  finset.mem_range.mp i_in).1)
      ... = ∑ i in r, (1/2)^i*ε         : by { congr' with i, field_simp }
      ... = (∑ i in r, (1/2)^i)*ε       : finset.sum_mul.symm
      ... ≤ 2*ε                         : mul_le_mul_of_nonneg_right (sum_geometric_two_le _)
                                            (le_of_lt ε_pos), },
    have B : 2^(n+1) * ϕ x ≤ ϕ (u (n + 1)),
    { refine @geom_le (ϕ ∘ u) _ zero_le_two (n + 1) (λ m hm, _),
      exact (IH _ $ nat.lt_add_one_iff.1 hm).2.le },
    exact hu (n+1) ⟨A, B⟩, },
  cases forall_and_distrib.mp key with key₁ key₂,
  clear hu key,
  -- Hence u is Cauchy
  have cauchy_u : cauchy_seq u,
  { refine cauchy_seq_of_le_geometric _ ε one_half_lt_one (λ n, _),
    simpa only [one_div, inv_pow] using key₁ n },
  -- So u converges to some y
  obtain ⟨y, limy⟩ : ∃ y, tendsto u at_top (𝓝 y),
    from complete_space.complete cauchy_u,
  -- And ϕ ∘ u goes to +∞
  have lim_top : tendsto (ϕ ∘ u) at_top at_top,
  { let v := λ n, (ϕ ∘ u) (n+1),
    suffices : tendsto v at_top at_top,
      by rwa tendsto_add_at_top_iff_nat at this,
    have hv₀ : 0 < v 0,
    { have : 0 ≤ ϕ (u 0) := nonneg x,
      calc 0 ≤ 2 * ϕ (u 0) : by linarith
      ... < ϕ (u (0 + 1)) : key₂ 0 },
    apply tendsto_at_top_of_geom_le hv₀ one_lt_two,
    exact λ n, (key₂ (n+1)).le },
  -- But ϕ ∘ u also needs to go to ϕ(y)
  have lim : tendsto (ϕ ∘ u) at_top (𝓝 (ϕ y)),
    from tendsto.comp cont.continuous_at limy,
  -- So we have our contradiction!
  exact not_tendsto_at_top_of_tendsto_nhds lim lim_top,
end


import data.finset
import algebra.group.defs
import to_mathlib
import data.mv_polynomial
import Rings.Notation
import field_theory.subfield
import data.mv_polynomial.rename
import data.equiv.fin
import data.polynomial.algebra_map
import data.list
import Rings.ToMathlib.fin

universes u v

lemma with_bot.succ_lt_succ_succ {n : ℕ} : (n + 1 : with_bot ℕ) < ↑n.succ + 1 := by tidy

-- More general version of monoid.has_pow
-- instance has_pow_of_has_one_has_mul (A : Type u) [has_one A] [has_mul A] :
--   has_pow A ℕ := ⟨ λ t k, npow_rec k t ⟩

namespace mv_polynomial
  variables
    {A B : Type*}
    [comm_ring A] [comm_ring B] [algebra A B] {σ : Type*}

  open dvector

  noncomputable instance coe_mv_poly_A_to_mv_poly_B :
  has_coe (mv_polynomial σ A) (mv_polynomial σ B) :=
  ⟨ mv_polynomial.map (algebra_map A B)⟩

  noncomputable instance coe_mv_poly_Z_to_mv_poly_A :
  has_coe (mv_polynomial σ ℤ) (mv_polynomial σ A) :=
  ⟨ mv_polynomial.map (int.cast_ring_hom A) ⟩

  noncomputable instance coe_mv_poly_A_to_mv_poly_poly_A :
  has_coe (mv_polynomial σ A) (mv_polynomial σ (polynomial A)) :=
  ⟨ @mv_polynomial.map A (polynomial A) σ _ _ polynomial.C ⟩

  @[simp] lemma coe_mv_poly_X {k : σ} :
    ↑(mv_polynomial.X k : mv_polynomial σ ℤ) = (mv_polynomial.X k : mv_polynomial σ A) :=
  begin unfold_coes, simp, end

  @[simp] lemma coe_mv_poly_one : ↑ (1 : mv_polynomial σ ℤ) = (1 : mv_polynomial σ A) :=
  begin unfold_coes, simp, end

  @[simp] lemma coe_mv_poly_neg {t}: ↑ - (t : mv_polynomial σ ℤ) = - (↑t : mv_polynomial σ A) :=
  begin unfold_coes, simp, end

  @[simp] noncomputable def to_polynomial {n} (val : fin n → A)
    (p : mv_polynomial (fin n.succ) A) :
    polynomial A :=
  mv_polynomial.eval (fin.x_val polynomial.X (polynomial.C ∘ val)) p

  lemma eval_eq_poly_eval_mv_coeffs_X
  {n : ℕ} {val : fin n → A} (x : A) : Π {k},
    @mv_polynomial.eval A (fin n.succ) _ (fin.x_val x val) (mv_polynomial.X k)
    = polynomial.eval x (to_polynomial val (mv_polynomial.X k)) :=
  @fin.cases n
  (λ k, @mv_polynomial.eval A (fin n.succ) _ (fin.x_val x val) (mv_polynomial.X k)
    = polynomial.eval x (to_polynomial val (mv_polynomial.X k)))
  (begin
    simp only [mv_polynomial.eval_X, fin.cases_zero,
      function.comp_app, fin.x_val, to_polynomial],
    unfold_coes,
    simp,
  end)
  (begin
    simp only [mv_polynomial.eval_X, fin.cases_succ,
      function.comp_app, fin.x_val, to_polynomial],
    unfold_coes,
    simp,
  end)

  lemma eval_eq_poly_eval_mv_coeffs
  {n : ℕ} {p : mv_polynomial (fin n.succ) A} {val : fin n → A} (x : A) :
    @mv_polynomial.eval A (fin n.succ) _ (fin.x_val x val) p
    = polynomial.eval x (to_polynomial val p) :=
  @mv_polynomial.induction_on A (fin n.succ) _
    (λ q, @mv_polynomial.eval A (fin n.succ) _ (fin.x_val x val) q
    = polynomial.eval x (to_polynomial val q))
    p
  (begin
    intro a,
    simp only [mv_polynomial.eval_C, function.comp_app, fin.x_val, to_polynomial],
    unfold_coes,
    simp,
  end)
  (begin
    intros p q,
    simp only [to_polynomial],
    intros hp hq,
    unfold_coes,
    simp only [ring_hom.map_add, ring_hom.to_fun_eq_coe,
    function.comp_app, fin.x_val, polynomial.eval_add],
    simp only [ring_hom.to_fun_eq_coe, function.comp_app, fin.x_val] at hp hq,
    rw [hp, hq],
    refl,
  end)
  (begin
    intros p k,
    simp only [to_polynomial],
    unfold_coes,
    simp only [mv_polynomial.eval_X, ring_hom.to_fun_eq_coe,
      function.comp_app, polynomial.eval_mul, fin.x_val, mv_polynomial.eval_map,
      ring_hom.map_mul, mv_polynomial.map_X],
    intro hp,
    rw ← hp,
    have hx := @mv_polynomial.eval_eq_poly_eval_mv_coeffs_X _ _ _ val x k,
    simp only [mv_polynomial.eval_X, function.comp_app, fin.x_val, to_polynomial] at hx,
    rw hx,
    unfold_coes,
    simp,
  end)

  lemma eval_add {val : σ → A} {p q : mv_polynomial σ A} :
  mv_polynomial.eval val (p + q) = mv_polynomial.eval val p + mv_polynomial.eval val q :=
  by simp

  -- section equiv

  /-- The algebra isomorphism between multivariable polynomials in no variables
  and the ground ring. -/

  -- LIBRARY ---- mv_polynomial.rename_equiv
  --
  -- variables {R : Type u} [comm_semiring R]

  -- @[simp] noncomputable def var_equiv {σ τ : Type v} (hequiv : equiv σ τ) :
  --   mv_polynomial σ R ≃ₐ[R] mv_polynomial τ R :=
  -- let f : mv_polynomial σ R →+* mv_polynomial τ R :=
  --     ring_hom.of (eval₂ C (λ s,X (hequiv.to_fun s))),
  --     g : mv_polynomial τ R →+* mv_polynomial σ R :=
  --     ring_hom.of (eval₂ C (λ s, X (hequiv.inv_fun s)))
  -- in
  -- { to_fun    := eval₂ C (λ s, X (hequiv.to_fun s)),
  --   inv_fun   := eval₂ C (λ t, X (hequiv.inv_fun t)),
  --   left_inv  :=
  --   begin
  --     show ∀ p, g.comp f p = p,
  --     apply is_id,
  --     { intro a, simp },
  --     { intro n, simp }
  --   end,
  --   right_inv :=
  --   begin
  --     show ∀ p, f.comp g p = p,
  --     apply is_id,
  --     { intro a, simp },
  --     { intro n, simp }
  --   end,
  --   map_mul'  := λ _ _, eval₂_mul _ _,
  --   map_add'  := λ _ _, eval₂_add _ _,
  --   commutes' := λ _, eval₂_C _ _ _ }
  -- end equiv

  lemma is_empty {R : Type u} {σ : Type v} [comm_ring R] (h : is_empty σ)
    (f : mv_polynomial σ R) (as : σ → R) :
    f = mv_polynomial.C (mv_polynomial.eval as f) :=
  @mv_polynomial.induction_on R σ _
  (λ p, p = mv_polynomial.C (mv_polynomial.eval as p))
  f
  (begin
    intro a,
    rw (mv_polynomial.C_inj R),
    simp,
  end)
  (begin
    intros p q hp hq,
    rw [hp, hq],
    simp,
  end)
  (
  begin
    intros p n hp,
    apply is_empty.elim h n,
  end
  )

end mv_polynomial

namespace zorn

open classical
local attribute [instance] prop_decidable

  lemma fin_range_sub_mem_chain_of_sub_union
    {α : Type u} {c : set (set α)} (hchain : zorn.chain has_subset.subset c) (hc0 : c.nonempty) :
    Π {n : ℕ} (F : fin n → α), (Π k, F k ∈ ⋃₀ c)
      → ∃ (Y : set α), Y ∈ c ∧ (Π k, F k ∈ Y)
  | nat.zero :=
  begin
    intros F hF,
    cases hc0 with Y hY,
    use Y,
    split,
    {exact hY},
    {exact is_empty.elim fin.is_empty}
  end
  | (nat.succ n) :=
  begin
    intros Fsucc hFsucc,
    have F : fin n → α := λ k, Fsucc (k.succ),
    have hF : Π (k : fin n), Fsucc k.succ ∈ ⋃₀ c := λ k, hFsucc (fin.succ k),
    cases fin_range_sub_mem_chain_of_sub_union (λk, Fsucc (k.succ)) hF with Y hY,
    have h0cup : Fsucc 0 ∈ ⋃₀ c := hFsucc 0,
    rw set.mem_sUnion at h0cup,
    cases h0cup with Y0 hY0,
    cases hY0 with hY0c hY0,
    cases hY with hYc hY,
    by_cases hYY0 : Y = Y0,
    {
      use Y,
      split,
      {exact hYc},
      {
        intro k,
        apply @fin.cases n (λ l, Fsucc l ∈ Y),
        {rw hYY0, exact hY0},
        {intro i, apply hY i},
      }
    },
    {
      cases hchain Y hYc Y0 hY0c hYY0 with hsub hsub,
      {
        use Y0,
        split,
        {exact hY0c},
        {
          intro k,
          apply @fin.cases n (λ l, Fsucc l ∈ Y0),
          {exact hY0},
          {intro i, apply hsub, apply hY i},
        }
      },
      {
        use Y,
        split,
        {exact hYc},
        {
          intro k,
          apply @fin.cases n (λ l, Fsucc l ∈ Y),
          {apply hsub, exact hY0},
          {intro i, apply hY i},
        },
      },
    }
  end

  lemma fin_sub_mem_chain_of_sub_union
    {α : Type u} {c : set (set α)} (hchain : zorn.chain has_subset.subset c) (hc0 : c.nonempty) :
    Π (F : finset α), (↑F ⊆ ⋃₀ c) → ∃ (Y : set α), Y ∈ c ∧ ↑F ⊆ Y :=
  @finset.induction α (λ (F : finset α), (↑F ⊆ ⋃₀ c) → ∃ (Y : set α), Y ∈ c ∧ ↑F ⊆ Y)
  _
  (begin
    intro h0sub,
    cases hc0 with Y hY,
    use Y,
    split,
    exact hY,
    simp,
  end)
  (begin
    intros a F haF hind hFasub,
    have hacup : a ∈ ⋃₀ c,
    {apply hFasub, simp},
    rw set.mem_sUnion at hacup,
    cases hacup with Z hZ,
    cases hZ with hZc haZ,
    have hFsub : ↑F ⊆ ⋃₀ c,
    {apply set.subset.trans _ hFasub, simp},
    have Y := (hind hFsub),
    cases Y with Y hY,
    by_cases hYZ : Y = Z,
    {
      use Y,
      split,
      {exact hY.1},
      {
        simp only [finset.coe_insert, set.insert_subset],
        split,
        {rw hYZ, exact haZ,},
        {exact hY.2}
      }
    },
    cases hY with hYc hFY,
    cases hchain Y hYc Z hZc hYZ with hl hr,
    {
      use Z,
      split,
      {exact hZc},
      simp only [finset.coe_insert, set.insert_subset],
      split,
      {exact haZ},
      {exact set.subset.trans hFY hl},
    },
    {
      use Y,
      split,
      {exact hYc},
      {
        simp only [finset.coe_insert, set.insert_subset],
        split,
        {exact hr haZ},
        {exact hFY}
      },
    }
  end)

end zorn

namespace set
  lemma union_sdiff {α : Type u} {B : set α} {x y} :
    ¬x = y → (B ∪ {x}) \ {y} = B \ {y} ∪ {x} :=
  begin
    intro hxy,
    apply set.ext,
    intro b,
    split,
    {
      intro hb,
      by_cases hbx : b = x,
      {
        right,
        simpa,
      },
      {
        left,
        split,
        cases hb with hl hr,
        cases hl,
        {exact hl},
        {exfalso, apply hbx, simpa using hl},
        {exact hb.2},
      },
    },
    {
      intro hb,
      cases hb,
      {
        split,
        {left, exact hb.1},
        {simpa using hb.2},
      },
      {
        split,
        {right, exact hb},
        {intro hbot, apply hxy, tidy},
      },
    },
  end

  lemma remove_insert {α : Type u} {B : set α} {y} : y ∈ B → B \ {y} ∪ {y} = B :=
  begin
    intro hyB,
    apply set.ext,
    intro b,
    split,
    {
      intro hb,
      cases hb,
      {exact hb.1},
      {rw set.mem_singleton_iff at hb, rw hb, exact hyB},
    },
    {
      intro hbB,
      by_cases hby : b = y,
      {
        rw hby,
        right,
        simp,
      },
      {
        left,
        split,
        {exact hbB},
        {simpa using hby},
      },
    },
  end

  lemma remove_insert_not_mem {α : Type u} {B : set α} {x} : x ∉ B → B = (B ∪ {x}) \ {x} :=
  begin
    intro hxB,
    simp only [set.mem_singleton, set.insert_diff_of_mem, set.union_singleton],
    apply set.ext,
    intro b,
    split,
    {
      intro hb, split,
      {exact hb},
      {intro hbot,
      rw set.mem_singleton_iff at hbot,
      rw hbot at hb,
      exact hxB hb,}
    },
    {intro hb, cases hb, cc},
  end
end set

namespace subfield

  variables
    (L : Type u) [field L]

  -- lemma closure_subset (U V : set L) (hUV : U ⊆ V) :
  --   (subfield.closure U : set L) ⊆ subfield.closure V :=
  -- begin
  --   simp only [set_like.coe_subset_coe, closure_le],
  --   apply set.subset.trans hUV subset_closure,
  -- end

end subfield

-- couldn't find in the library
def big_add {A : Type u} [has_add A] [has_zero A] : Π {n : ℕ}, (fin n → A) → A
| nat.zero := 0
| (nat.succ n) := λ as, (big_add (λ k : fin n, as k)) + as n

def big_mul {A : Type u} [has_mul A] [has_one A] : Π {n : ℕ}, (fin n → A) → A
| nat.zero := 1
| (nat.succ n) := λ as, (big_mul (λ k : fin n, as k)) * as n


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Johannes Hölzl, Reid Barton, Sean Leather, Yury Kudryashov
-/
import category_theory.types
import category_theory.functor.epi_mono
import category_theory.limits.constructions.epi_mono

/-!
# Concrete categories

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

A concrete category is a category `C` with a fixed faithful functor
`forget : C ⥤ Type*`.  We define concrete categories using `class
concrete_category`.  In particular, we impose no restrictions on the
carrier type `C`, so `Type` is a concrete category with the identity
forgetful functor.

Each concrete category `C` comes with a canonical faithful functor
`forget C : C ⥤ Type*`.  We say that a concrete category `C` admits a
*forgetful functor* to a concrete category `D`, if it has a functor
`forget₂ C D : C ⥤ D` such that `(forget₂ C D) ⋙ (forget D) = forget C`,
see `class has_forget₂`.  Due to `faithful.div_comp`, it suffices
to verify that `forget₂.obj` and `forget₂.map` agree with the equality
above; then `forget₂` will satisfy the functor laws automatically, see
`has_forget₂.mk'`.

Two classes helping construct concrete categories in the two most
common cases are provided in the files `bundled_hom` and
`unbundled_hom`, see their documentation for details.

## References

See [Ahrens and Lumsdaine, *Displayed Categories*][ahrens2017] for
related work.
-/

universes w v v' u

namespace category_theory

open category_theory.limits

/--
A concrete category is a category `C` with a fixed faithful functor `forget : C ⥤ Type`.

Note that `concrete_category` potentially depends on three independent universe levels,
* the universe level `w` appearing in `forget : C ⥤ Type w`
* the universe level `v` of the morphisms (i.e. we have a `category.{v} C`)
* the universe level `u` of the objects (i.e `C : Type u`)
They are specified that order, to avoid unnecessary universe annotations.
-/
class concrete_category (C : Type u) [category.{v} C] :=
(forget [] : C ⥤ Type w)
[forget_faithful : faithful forget]

attribute [instance] concrete_category.forget_faithful

/-- The forgetful functor from a concrete category to `Type u`. -/
@[reducible] def forget (C : Type v) [category C] [concrete_category.{u} C] : C ⥤ Type u :=
concrete_category.forget C

instance concrete_category.types : concrete_category (Type u) :=
{ forget := 𝟭 _ }

/--
Provide a coercion to `Type u` for a concrete category. This is not marked as an instance
as it could potentially apply to every type, and so is too expensive in typeclass search.

You can use it on particular examples as:
```
instance : has_coe_to_sort X := concrete_category.has_coe_to_sort X
```
-/
def concrete_category.has_coe_to_sort (C : Type v) [category C] [concrete_category C] :
  has_coe_to_sort C (Type u) :=
⟨(concrete_category.forget C).obj⟩

section
local attribute [instance] concrete_category.has_coe_to_sort

variables {C : Type v} [category C] [concrete_category C]

@[simp] lemma forget_obj_eq_coe {X : C} : (forget C).obj X = X := rfl

/-- Usually a bundled hom structure already has a coercion to function
that works with different universes. So we don't use this as a global instance. -/
def concrete_category.has_coe_to_fun {X Y : C} : has_coe_to_fun (X ⟶ Y) (λ f, X → Y) :=
⟨λ f, (forget _).map f⟩

local attribute [instance] concrete_category.has_coe_to_fun

/-- In any concrete category, we can test equality of morphisms by pointwise evaluations.-/
lemma concrete_category.hom_ext {X Y : C} (f g : X ⟶ Y) (w : ∀ x : X, f x = g x) : f = g :=
begin
  apply faithful.map_injective (forget C),
  ext,
  exact w x,
end

@[simp] lemma forget_map_eq_coe {X Y : C} (f : X ⟶ Y) : (forget C).map f = f := rfl

/--
Analogue of `congr_fun h x`,
when `h : f = g` is an equality between morphisms in a concrete category.
-/

lemma coe_id {X : C} : ((𝟙 X) : X → X) = id :=
(forget _).map_id X

lemma coe_comp {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) :
  (f ≫ g : X → Z) = g ∘ f :=
(forget _).map_comp f g

@[simp] lemma id_apply {X : C} (x : X) : ((𝟙 X) : X → X) x = x :=
congr_fun ((forget _).map_id X) x

@[simp] lemma comp_apply {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) (x : X) :
  (f ≫ g) x = g (f x) :=
congr_fun ((forget _).map_comp _ _) x

lemma concrete_category.congr_hom {X Y : C} {f g : X ⟶ Y} (h : f = g) (x : X) : f x = g x :=
congr_fun (congr_arg (λ f : X ⟶ Y, (f : X → Y)) h) x

lemma concrete_category.congr_arg {X Y : C} (f : X ⟶ Y) {x x' : X} (h : x = x') : f x = f x' :=
congr_arg (f : X → Y) h

/-- In any concrete category, injective morphisms are monomorphisms. -/
lemma concrete_category.mono_of_injective {X Y : C} (f : X ⟶ Y) (i : function.injective f) :
  mono f :=
(forget C).mono_of_mono_map ((mono_iff_injective f).2 i)

lemma concrete_category.injective_of_mono_of_preserves_pullback {X Y : C} (f : X ⟶ Y) [mono f]
  [preserves_limits_of_shape walking_cospan (forget C)] : function.injective f :=
(mono_iff_injective ((forget C).map f)).mp infer_instance

lemma concrete_category.mono_iff_injective_of_preserves_pullback {X Y : C} (f : X ⟶ Y)
  [preserves_limits_of_shape walking_cospan (forget C)] : mono f ↔ function.injective f :=
((forget C).mono_map_iff_mono _).symm.trans (mono_iff_injective _)

/-- In any concrete category, surjective morphisms are epimorphisms. -/
lemma concrete_category.epi_of_surjective {X Y : C} (f : X ⟶ Y) (s : function.surjective f) :
  epi f :=
(forget C).epi_of_epi_map ((epi_iff_surjective f).2 s)

lemma concrete_category.surjective_of_epi_of_preserves_pushout {X Y : C} (f : X ⟶ Y) [epi f]
  [preserves_colimits_of_shape walking_span (forget C)] : function.surjective f :=
(epi_iff_surjective ((forget C).map f)).mp infer_instance

lemma concrete_category.epi_iff_surjective_of_preserves_pushout {X Y : C} (f : X ⟶ Y)
  [preserves_colimits_of_shape walking_span (forget C)] : epi f ↔ function.surjective f :=
((forget C).epi_map_iff_epi _).symm.trans (epi_iff_surjective _)

lemma concrete_category.bijective_of_is_iso {X Y : C} (f : X ⟶ Y) [is_iso f] :
  function.bijective ((forget C).map f) :=
by { rw ← is_iso_iff_bijective, apply_instance, }

@[simp] lemma concrete_category.has_coe_to_fun_Type {X Y : Type u} (f : X ⟶ Y) :
  coe_fn f = f :=
rfl

end

/--
`has_forget₂ C D`, where `C` and `D` are both concrete categories, provides a functor
`forget₂ C D : C ⥤ D` and a proof that `forget₂ ⋙ (forget D) = forget C`.
-/
class has_forget₂ (C : Type v) (D : Type v') [category C] [concrete_category.{u} C] [category D]
  [concrete_category.{u} D] :=
(forget₂ : C ⥤ D)
(forget_comp : forget₂ ⋙ (forget D) = forget C . obviously)

/-- The forgetful functor `C ⥤ D` between concrete categories for which we have an instance
`has_forget₂ C `. -/
@[reducible] def forget₂ (C : Type v) (D : Type v') [category C] [concrete_category C] [category D]
  [concrete_category D] [has_forget₂ C D] : C ⥤ D :=
has_forget₂.forget₂

instance forget₂_faithful (C : Type v) (D : Type v') [category C] [concrete_category C] [category D]
  [concrete_category D] [has_forget₂ C D] : faithful (forget₂ C D) :=
has_forget₂.forget_comp.faithful_of_comp

instance forget₂_preserves_monomorphisms (C : Type v) (D : Type v') [category C]
  [concrete_category C] [category D] [concrete_category D] [has_forget₂ C D]
  [(forget C).preserves_monomorphisms] : (forget₂ C D).preserves_monomorphisms :=
have (forget₂ C D ⋙ forget D).preserves_monomorphisms,
  by { simp only [has_forget₂.forget_comp], apply_instance },
by exactI functor.preserves_monomorphisms_of_preserves_of_reflects _ (forget D)

instance forget₂_preserves_epimorphisms (C : Type v) (D : Type v') [category C]
  [concrete_category C] [category D] [concrete_category D] [has_forget₂ C D]
  [(forget C).preserves_epimorphisms] : (forget₂ C D).preserves_epimorphisms :=
have (forget₂ C D ⋙ forget D).preserves_epimorphisms,
  by { simp only [has_forget₂.forget_comp], apply_instance },
by exactI functor.preserves_epimorphisms_of_preserves_of_reflects _ (forget D)

instance induced_category.concrete_category {C : Type v} {D : Type v'} [category D]
  [concrete_category D] (f : C → D) :
  concrete_category (induced_category D f) :=
{ forget := induced_functor f ⋙ forget D }

instance induced_category.has_forget₂ {C : Type v} {D : Type v'} [category D] [concrete_category D]
  (f : C → D) :
  has_forget₂ (induced_category D f) D :=
{ forget₂ := induced_functor f,
  forget_comp := rfl }

instance full_subcategory.concrete_category {C : Type v} [category C] [concrete_category C]
  (Z : C → Prop) : concrete_category (full_subcategory Z) :=
{ forget := full_subcategory_inclusion Z ⋙ forget C }

instance full_subcategory.has_forget₂ {C : Type v} [category C] [concrete_category C]
  (Z : C → Prop) : has_forget₂ (full_subcategory Z) C :=
{ forget₂ := full_subcategory_inclusion Z,
  forget_comp := rfl }

/--
In order to construct a “partially forgetting” functor, we do not need to verify functor laws;
it suffices to ensure that compositions agree with `forget₂ C D ⋙ forget D = forget C`.
-/
def has_forget₂.mk' {C : Type v} {D : Type v'} [category C] [concrete_category C] [category D]
  [concrete_category D] (obj : C → D) (h_obj : ∀ X, (forget D).obj (obj X) = (forget C).obj X)
  (map : Π {X Y}, (X ⟶ Y) → (obj X ⟶ obj Y))
  (h_map : ∀ {X Y} {f : X ⟶ Y}, (forget D).map (map f) == (forget C).map f) :
has_forget₂ C D :=
{ forget₂ := faithful.div _ _ _ @h_obj _ @h_map,
  forget_comp := by apply faithful.div_comp }

/-- Every forgetful functor factors through the identity functor. This is not a global instance as
    it is prone to creating type class resolution loops. -/
def has_forget_to_Type (C : Type v) [category C] [concrete_category C] :
  has_forget₂ C (Type u) :=
{ forget₂ := forget C,
  forget_comp := functor.comp_id _ }

end category_theory