/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Yury G. Kudryashov
-/
import logic.function.basic

/-!
# More theorems about the sum type
-/

universes u v w x
variables {α : Type u} {α' : Type w} {β : Type v} {β' : Type x}
open sum

/-- Check if a sum is `inl` and if so, retrieve its contents. -/
@[simp] def sum.get_left {α β} : α ⊕ β → option α
| (inl a) := some a
| (inr _) := none

/-- Check if a sum is `inr` and if so, retrieve its contents. -/
@[simp] def sum.get_right {α β} : α ⊕ β → option β
| (inr b) := some b
| (inl _) := none

/-- Check if a sum is `inl`. -/
@[simp] def sum.is_left {α β} : α ⊕ β → bool
| (inl _) := tt
| (inr _) := ff

/-- Check if a sum is `inr`. -/
@[simp] def sum.is_right {α β} : α ⊕ β → bool
| (inl _) := ff
| (inr _) := tt

attribute [derive decidable_eq] sum

@[simp] theorem sum.forall {p : α ⊕ β → Prop} : (∀ x, p x) ↔ (∀ a, p (inl a)) ∧ (∀ b, p (inr b)) :=
⟨λ h, ⟨λ a, h _, λ b, h _⟩, λ ⟨h₁, h₂⟩, sum.rec h₁ h₂⟩

@[simp] theorem sum.exists {p : α ⊕ β → Prop} : (∃ x, p x) ↔ (∃ a, p (inl a)) ∨ ∃ b, p (inr b) :=
⟨λ h, match h with
| ⟨inl a, h⟩ := or.inl ⟨a, h⟩
| ⟨inr b, h⟩ := or.inr ⟨b, h⟩
end, λ h, match h with
| or.inl ⟨a, h⟩ := ⟨inl a, h⟩
| or.inr ⟨b, h⟩ := ⟨inr b, h⟩
end⟩

namespace sum

lemma inl_injective : function.injective (sum.inl : α → α ⊕ β) :=
λ x y, sum.inl.inj

lemma inr_injective : function.injective (sum.inr : β → α ⊕ β) :=
λ x y, sum.inr.inj

/-- Map `α ⊕ β` to `α' ⊕ β'` sending `α` to `α'` and `β` to `β'`. -/
protected def map (f : α → α') (g : β → β')  : α ⊕ β → α' ⊕ β'
| (sum.inl x) := sum.inl (f x)
| (sum.inr x) := sum.inr (g x)

@[simp] lemma map_inl (f : α → α') (g : β → β') (x : α) : (inl x).map f g = inl (f x) := rfl
@[simp] lemma map_inr (f : α → α') (g : β → β') (x : β) : (inr x).map f g = inr (g x) := rfl

@[simp] lemma map_map {α'' β''} (f' : α' → α'') (g' : β' → β'') (f : α → α') (g : β → β') :
  ∀ x : α ⊕ β, (x.map f g).map f' g' = x.map (f' ∘ f) (g' ∘ g)
| (inl a) := rfl
| (inr b) := rfl

@[simp] lemma map_comp_map {α'' β''} (f' : α' → α'') (g' : β' → β'') (f : α → α') (g : β → β') :
  (sum.map f' g') ∘ (sum.map f g) = sum.map (f' ∘ f) (g' ∘ g) :=
funext $ map_map f' g' f g

@[simp] lemma map_id_id (α β) : sum.map (@id α) (@id β) = id :=
funext $ λ x, sum.rec_on x (λ _, rfl) (λ _, rfl)

theorem inl.inj_iff {a b} : (inl a : α ⊕ β) = inl b ↔ a = b :=
⟨inl.inj, congr_arg _⟩

theorem inr.inj_iff {a b} : (inr a : α ⊕ β) = inr b ↔ a = b :=
⟨inr.inj, congr_arg _⟩

theorem inl_ne_inr {a : α} {b : β} : inl a ≠ inr b.

theorem inr_ne_inl {a : α} {b : β} : inr b ≠ inl a.

/-- Define a function on `α ⊕ β` by giving separate definitions on `α` and `β`. -/
protected def elim {α β γ : Sort*} (f : α → γ) (g : β → γ) : α ⊕ β → γ := λ x, sum.rec_on x f g

@[simp] lemma elim_inl {α β γ : Sort*} (f : α → γ) (g : β → γ) (x : α) :
  sum.elim f g (inl x) = f x := rfl

@[simp] lemma elim_inr {α β γ : Sort*} (f : α → γ) (g : β → γ) (x : β) :
  sum.elim f g (inr x) = g x := rfl

@[simp] lemma elim_comp_inl {α β γ : Sort*} (f : α → γ) (g : β → γ) :
  sum.elim f g ∘ inl = f := rfl

@[simp] lemma elim_comp_inr {α β γ : Sort*} (f : α → γ) (g : β → γ) :
  sum.elim f g ∘ inr = g := rfl

@[simp] lemma elim_inl_inr {α β : Sort*} :
  @sum.elim α β _ inl inr = id :=
funext $ λ x, sum.cases_on x (λ _, rfl) (λ _, rfl)

lemma comp_elim {α β γ δ : Sort*} (f : γ → δ) (g : α → γ) (h : β → γ):
  f ∘ sum.elim g h = sum.elim (f ∘ g) (f ∘ h) :=
funext $ λ x, sum.cases_on x (λ _, rfl) (λ _, rfl)

@[simp] lemma elim_comp_inl_inr {α β γ : Sort*} (f : α ⊕ β → γ) :
  sum.elim (f ∘ inl) (f ∘ inr) = f :=
funext $ λ x, sum.cases_on x (λ _, rfl) (λ _, rfl)

open function (update update_eq_iff update_comp_eq_of_injective update_comp_eq_of_forall_ne)

@[simp] lemma update_elim_inl {α β γ} [decidable_eq α] [decidable_eq (α ⊕ β)]
  {f : α → γ} {g : β → γ} {i : α} {x : γ} :
  update (sum.elim f g) (inl i) x = sum.elim (update f i x) g :=
update_eq_iff.2 ⟨by simp, by simp { contextual := tt }⟩

@[simp] lemma update_elim_inr {α β γ} [decidable_eq β] [decidable_eq (α ⊕ β)]
  {f : α → γ} {g : β → γ} {i : β} {x : γ} :
  update (sum.elim f g) (inr i) x = sum.elim f (update g i x) :=
update_eq_iff.2 ⟨by simp, by simp { contextual := tt }⟩

@[simp] lemma update_inl_comp_inl {α β γ} [decidable_eq α] [decidable_eq (α ⊕ β)]
  {f : α ⊕ β → γ} {i : α} {x : γ} :
  update f (inl i) x ∘ inl = update (f ∘ inl) i x :=
update_comp_eq_of_injective _ inl_injective _ _

@[simp] lemma update_inl_apply_inl {α β γ} [decidable_eq α] [decidable_eq (α ⊕ β)]
  {f : α ⊕ β → γ} {i j : α} {x : γ} :
  update f (inl i) x (inl j) = update (f ∘ inl) i x j :=
by rw ← update_inl_comp_inl

@[simp] lemma update_inl_comp_inr {α β γ} [decidable_eq (α ⊕ β)]
  {f : α ⊕ β → γ} {i : α} {x : γ} :
  update f (inl i) x ∘ inr = f ∘ inr :=
update_comp_eq_of_forall_ne _ _ $ λ _, inr_ne_inl

@[simp] lemma update_inl_apply_inr {α β γ} [decidable_eq (α ⊕ β)]
  {f : α ⊕ β → γ} {i : α} {j : β} {x : γ} :
  update f (inl i) x (inr j) = f (inr j) :=
function.update_noteq inr_ne_inl _ _

@[simp] lemma update_inr_comp_inl {α β γ} [decidable_eq (α ⊕ β)]
  {f : α ⊕ β → γ} {i : β} {x : γ} :
  update f (inr i) x ∘ inl = f ∘ inl :=
update_comp_eq_of_forall_ne _ _ $ λ _, inl_ne_inr

@[simp] lemma update_inr_apply_inl {α β γ} [decidable_eq (α ⊕ β)]
  {f : α ⊕ β → γ} {i : α} {j : β} {x : γ} :
  update f (inr j) x (inl i) = f (inl i) :=
function.update_noteq inl_ne_inr _ _

@[simp] lemma update_inr_comp_inr {α β γ} [decidable_eq β] [decidable_eq (α ⊕ β)]
  {f : α ⊕ β → γ} {i : β} {x : γ} :
  update f (inr i) x ∘ inr = update (f ∘ inr) i x :=
update_comp_eq_of_injective _ inr_injective _ _

@[simp] lemma update_inr_apply_inr {α β γ} [decidable_eq β] [decidable_eq (α ⊕ β)]
  {f : α ⊕ β → γ} {i j : β} {x : γ} :
  update f (inr i) x (inr j) = update (f ∘ inr) i x j :=
by rw ← update_inr_comp_inr

section
  variables (ra : α → α → Prop) (rb : β → β → Prop)

  /-- Lexicographic order for sum. Sort all the `inl a` before the `inr b`,
    otherwise use the respective order on `α` or `β`. -/
  inductive lex : α ⊕ β → α ⊕ β → Prop
  | inl {a₁ a₂} (h : ra a₁ a₂) : lex (inl a₁) (inl a₂)
  | inr {b₁ b₂} (h : rb b₁ b₂) : lex (inr b₁) (inr b₂)
  | sep (a b) : lex (inl a) (inr b)

  variables {ra rb}

  @[simp] theorem lex_inl_inl {a₁ a₂} : lex ra rb (inl a₁) (inl a₂) ↔ ra a₁ a₂ :=
  ⟨λ h, by cases h; assumption, lex.inl⟩

  @[simp] theorem lex_inr_inr {b₁ b₂} : lex ra rb (inr b₁) (inr b₂) ↔ rb b₁ b₂ :=
  ⟨λ h, by cases h; assumption, lex.inr⟩

  @[simp] theorem lex_inr_inl {b a} : ¬ lex ra rb (inr b) (inl a) :=
  λ h, by cases h

  attribute [simp] lex.sep

  theorem lex_acc_inl {a} (aca : acc ra a) : acc (lex ra rb) (inl a) :=
  begin
    induction aca with a H IH,
    constructor, intros y h,
    cases h with a' _ h',
    exact IH _ h'
  end

  theorem lex_acc_inr (aca : ∀ a, acc (lex ra rb) (inl a)) {b} (acb : acc rb b) :
    acc (lex ra rb) (inr b) :=
  begin
    induction acb with b H IH,
    constructor, intros y h,
    cases h with _ _ _ b' _ h' a,
    { exact IH _ h' },
    { exact aca _ }
  end

  theorem lex_wf (ha : well_founded ra) (hb : well_founded rb) : well_founded (lex ra rb) :=
  have aca : ∀ a, acc (lex ra rb) (inl a), from λ a, lex_acc_inl (ha.apply a),
  ⟨λ x, sum.rec_on x aca (λ b, lex_acc_inr aca (hb.apply b))⟩

end

/-- Swap the factors of a sum type -/
@[simp] def swap : α ⊕ β → β ⊕ α
| (inl a) := inr a
| (inr b) := inl b

@[simp] lemma swap_swap (x : α ⊕ β) : swap (swap x) = x :=
by cases x; refl

@[simp] lemma swap_swap_eq : swap ∘ swap = @id (α ⊕ β) :=
funext $ swap_swap

@[simp] lemma swap_left_inverse : function.left_inverse (@swap α β) swap :=
swap_swap

@[simp] lemma swap_right_inverse : function.right_inverse (@swap α β) swap :=
swap_swap

end sum

namespace function

open sum

lemma injective.sum_elim {γ} {f : α → γ} {g : β → γ}
  (hf : injective f) (hg : injective g) (hfg : ∀ a b, f a ≠ g b) :
  injective (sum.elim f g)
| (inl x) (inl y) h := congr_arg inl $ hf h
| (inl x) (inr y) h := (hfg x y h).elim
| (inr x) (inl y) h := (hfg y x h.symm).elim
| (inr x) (inr y) h := congr_arg inr $ hg h

lemma injective.sum_map {f : α → β} {g : α' → β'} (hf : injective f) (hg : injective g) :
  injective (sum.map f g)
| (inl x) (inl y) h := congr_arg inl $ hf $ inl.inj h
| (inr x) (inr y) h := congr_arg inr $ hg $ inr.inj h

lemma surjective.sum_map {f : α → β} {g : α' → β'} (hf : surjective f) (hg : surjective g) :
  surjective (sum.map f g)
| (inl y) := let ⟨x, hx⟩ := hf y in ⟨inl x, congr_arg inl hx⟩
| (inr y) := let ⟨x, hx⟩ := hg y in ⟨inr x, congr_arg inr hx⟩

end function


constants p q : Prop

theorem t1 : p → q → p := λ hp : p, λ hq : q, hp

#print t1


/-
Copyright (c) 2020 Jannis Limperg. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jannis Limperg
-/
import data.list.range

/-!
# Lemmas about list.*_with_index functions.

Some specification lemmas for `list.map_with_index`, `list.mmap_with_index`, `list.foldl_with_index`
and `list.foldr_with_index`.
-/

universes u v

open function

namespace list

variables {α : Type u} {β : Type v}

section map_with_index

lemma map_with_index_core_eq (l : list α) (f : ℕ → α → β) (n : ℕ) :
  l.map_with_index_core f n = l.map_with_index (λ i a, f (i + n) a) :=
begin
  induction l with hd tl hl generalizing f n,
  { simp [map_with_index, map_with_index_core] },
  { rw [map_with_index],
    simp [map_with_index_core, hl, add_left_comm, add_assoc, add_comm] }
end

lemma map_with_index_eq_enum_map (l : list α) (f : ℕ → α → β) :
  l.map_with_index f = l.enum.map (function.uncurry f) :=
begin
  induction l with hd tl hl generalizing f,
  { simp [map_with_index, map_with_index_core, list.enum_eq_zip_range] },
  { rw [map_with_index, map_with_index_core, map_with_index_core_eq, hl],
    simp [enum_eq_zip_range, range_succ_eq_map, zip_with_map_left,
    map_uncurry_zip_eq_zip_with] }
end

end map_with_index

section foldr_with_index

/-- Specification of `foldr_with_index_aux`. -/
def foldr_with_index_aux_spec (f : ℕ → α → β → β) (start : ℕ) (b : β)
  (as : list α) : β :=
foldr (uncurry f) b $ enum_from start as

theorem foldr_with_index_aux_spec_cons (f : ℕ → α → β → β) (start b a as) :
  foldr_with_index_aux_spec f start b (a :: as) =
  f start a (foldr_with_index_aux_spec f (start + 1) b as) :=
rfl

theorem foldr_with_index_aux_eq_foldr_with_index_aux_spec (f : ℕ → α → β → β)
  (start b as) :
  foldr_with_index_aux f start b as = foldr_with_index_aux_spec f start b as :=
begin
  induction as generalizing start,
  { refl },
  { simp only [foldr_with_index_aux, foldr_with_index_aux_spec_cons, *] }
end

theorem foldr_with_index_eq_foldr_enum (f : ℕ → α → β → β) (b : β) (as : list α) :
  foldr_with_index f b as = foldr (uncurry f) b (enum as) :=
by simp only
    [foldr_with_index, foldr_with_index_aux_spec,
     foldr_with_index_aux_eq_foldr_with_index_aux_spec, enum]

end foldr_with_index

theorem indexes_values_eq_filter_enum (p : α → Prop) [decidable_pred p]
  (as : list α) :
  indexes_values p as = filter (p ∘ prod.snd) (enum as) :=
by simp [indexes_values, foldr_with_index_eq_foldr_enum, uncurry, filter_eq_foldr]

theorem find_indexes_eq_map_indexes_values (p : α → Prop) [decidable_pred p]
  (as : list α) :
  find_indexes p as = map prod.fst (indexes_values p as) :=
by simp only
    [indexes_values_eq_filter_enum, map_filter_eq_foldr, find_indexes,
     foldr_with_index_eq_foldr_enum, uncurry]

section foldl_with_index

/-- Specification of `foldl_with_index_aux`. -/
def foldl_with_index_aux_spec (f : ℕ → α → β → α) (start : ℕ) (a : α)
  (bs : list β) : α :=
foldl (λ a (p : ℕ × β), f p.fst a p.snd) a $ enum_from start bs

theorem foldl_with_index_aux_spec_cons (f : ℕ → α → β → α) (start a b bs) :
  foldl_with_index_aux_spec f start a (b :: bs) =
  foldl_with_index_aux_spec f (start + 1) (f start a b) bs :=
rfl

theorem foldl_with_index_aux_eq_foldl_with_index_aux_spec (f : ℕ → α → β → α)
  (start a bs) :
  foldl_with_index_aux f start a bs = foldl_with_index_aux_spec f start a bs :=
begin
  induction bs generalizing start a,
  { refl },
  { simp [foldl_with_index_aux, foldl_with_index_aux_spec_cons, *] }
end

theorem foldl_with_index_eq_foldl_enum (f : ℕ → α → β → α) (a : α) (bs : list β) :
  foldl_with_index f a bs =
  foldl (λ a (p : ℕ × β), f p.fst a p.snd) a (enum bs) :=
by simp only
    [foldl_with_index, foldl_with_index_aux_spec,
     foldl_with_index_aux_eq_foldl_with_index_aux_spec, enum]

end foldl_with_index

section mfold_with_index

variables {m : Type u → Type v} [monad m]

theorem mfoldr_with_index_eq_mfoldr_enum {α β} (f : ℕ → α → β → m β) (b : β) (as : list α) :
  mfoldr_with_index f b as = mfoldr (uncurry f) b (enum as) :=
by simp only
    [mfoldr_with_index, mfoldr_eq_foldr, foldr_with_index_eq_foldr_enum, uncurry]

theorem mfoldl_with_index_eq_mfoldl_enum [is_lawful_monad m] {α β}
  (f : ℕ → β → α → m β) (b : β) (as : list α) :
  mfoldl_with_index f b as =
    mfoldl (λ b (p : ℕ × α), f p.fst b p.snd) b (enum as) :=
by rw [mfoldl_with_index, mfoldl_eq_foldl, foldl_with_index_eq_foldl_enum]

end mfold_with_index

section mmap_with_index

variables {m : Type u → Type v} [applicative m]

/-- Specification of `mmap_with_index_aux`. -/
def mmap_with_index_aux_spec {α β} (f : ℕ → α → m β) (start : ℕ) (as : list α) :
  m (list β) :=
list.traverse (uncurry f) $ enum_from start as
-- Note: `traverse` the class method would require a less universe-polymorphic
-- `m : Type u → Type u`.

theorem mmap_with_index_aux_spec_cons {α β} (f : ℕ → α → m β) (start : ℕ)
  (a : α) (as : list α) :
  mmap_with_index_aux_spec f start (a :: as) =
    list.cons <$> f start a <*> mmap_with_index_aux_spec f (start + 1) as :=
rfl

theorem mmap_with_index_aux_eq_mmap_with_index_aux_spec {α β} (f : ℕ → α → m β)
  (start : ℕ) (as : list α) :
  mmap_with_index_aux f start as = mmap_with_index_aux_spec f start as :=
begin
  induction as generalizing start,
  { refl },
  { simp [mmap_with_index_aux, mmap_with_index_aux_spec_cons, *] }
end

theorem mmap_with_index_eq_mmap_enum {α β} (f : ℕ → α → m β) (as : list α) :
  mmap_with_index f as = list.traverse (uncurry f) (enum as) :=
by simp only
    [mmap_with_index, mmap_with_index_aux_spec,
     mmap_with_index_aux_eq_mmap_with_index_aux_spec, enum ]

end mmap_with_index

section mmap_with_index'

variables {m : Type u → Type v} [applicative m] [is_lawful_applicative m]

theorem mmap_with_index'_aux_eq_mmap_with_index_aux {α} (f : ℕ → α → m punit)
  (start : ℕ) (as : list α) :
  mmap_with_index'_aux f start as =
  mmap_with_index_aux f start as *> pure punit.star :=
by induction as generalizing start;
    simp [mmap_with_index'_aux, mmap_with_index_aux, *, seq_right_eq, const, -comp_const]
      with functor_norm

theorem mmap_with_index'_eq_mmap_with_index {α} (f : ℕ → α → m punit) (as : list α) :
  mmap_with_index' f as = mmap_with_index f as *> pure punit.star :=
by apply mmap_with_index'_aux_eq_mmap_with_index_aux

end mmap_with_index'

end list


/-
Copyright (c) 2022 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz
-/
import ring_theory.valuation.integers
import ring_theory.ideal.local_ring
import ring_theory.localization.fraction_ring
import ring_theory.localization.integer
import ring_theory.discrete_valuation_ring
import ring_theory.bezout
import tactic.field_simp

/-!
# Valuation Rings

A valuation ring is a domain such that for every pair of elements `a b`, either `a` divides
`b` or vice-versa.

Any valuation ring induces a natural valuation on its fraction field, as we show in this file.
Namely, given the following instances:
`[comm_ring A] [is_domain A] [valuation_ring A] [field K] [algebra A K] [is_fraction_ring A K]`,
there is a natural valuation `valuation A K` on `K` with values in `value_group A K` where
the image of `A` under `algebra_map A K` agrees with `(valuation A K).integer`.

We also provide the equivalence of the following notions for a domain `R` in `valuation_ring.tfae`.
1. `R` is a valuation ring.
2. For each `x : fraction_ring K`, either `x` or `x⁻¹` is in `R`.
3. "divides" is a total relation on the elements of `R`.
4. "contains" is a total relation on the ideals of `R`.
5. `R` is a local bezout domain.

-/

universes u v w

/-- An integral domain is called a `valuation ring` provided that for any pair
of elements `a b : A`, either `a` divides `b` or vice versa. -/
class valuation_ring (A : Type u) [comm_ring A] [is_domain A] : Prop :=
(cond [] : ∀ a b : A, ∃ c : A, a * c = b ∨ b * c = a)

namespace valuation_ring

section
variables (A : Type u) [comm_ring A]
variables (K : Type v) [field K] [algebra A K]

/-- The value group of the valuation ring `A`. Note: this is actually a group with zero. -/
def value_group : Type v := quotient (mul_action.orbit_rel Aˣ K)

instance : inhabited (value_group A K) := ⟨quotient.mk' 0⟩

instance : has_le (value_group A K) := has_le.mk $ λ x y,
quotient.lift_on₂' x y (λ a b, ∃ c : A, c • b = a)
begin
  rintros _ _ a b ⟨c,rfl⟩ ⟨d,rfl⟩, ext,
  split,
  { rintros ⟨e,he⟩, use ((c⁻¹ : Aˣ) * e * d),
    apply_fun (λ t, c⁻¹ • t) at he,
    simpa [mul_smul] using he },
  { rintros ⟨e,he⟩, dsimp,
    use (d⁻¹ : Aˣ) * c * e,
    erw [← he, ← mul_smul, ← mul_smul],
    congr' 1,
    rw mul_comm,
    simp only [← mul_assoc, ← units.coe_mul, mul_inv_self, one_mul] }
end

instance : has_zero (value_group A K) := ⟨quotient.mk' 0⟩
instance : has_one (value_group A K) := ⟨quotient.mk' 1⟩

instance : has_mul (value_group A K) := has_mul.mk $ λ x y,
quotient.lift_on₂' x y (λ a b, quotient.mk' $ a * b)
begin
  rintros _ _ a b ⟨c,rfl⟩ ⟨d,rfl⟩,
  apply quotient.sound',
  dsimp,
  use c * d,
  simp only [mul_smul, algebra.smul_def, units.smul_def, ring_hom.map_mul,
    units.coe_mul],
  ring,
end

instance : has_inv (value_group A K) := has_inv.mk $ λ x,
quotient.lift_on' x (λ a, quotient.mk' a⁻¹)
begin
  rintros _ a ⟨b,rfl⟩,
  apply quotient.sound',
  use b⁻¹,
  dsimp,
  rw [units.smul_def, units.smul_def, algebra.smul_def, algebra.smul_def,
    mul_inv, map_units_inv],
end

variables [is_domain A] [valuation_ring A] [is_fraction_ring A K]

protected lemma le_total (a b : value_group A K) : a ≤ b ∨ b ≤ a :=
begin
  rcases a with ⟨a⟩, rcases b with ⟨b⟩,
  obtain ⟨xa,ya,hya,rfl⟩ : ∃ (a b : A), _ := is_fraction_ring.div_surjective a,
  obtain ⟨xb,yb,hyb,rfl⟩ : ∃ (a b : A), _ := is_fraction_ring.div_surjective b,
  have : (algebra_map A K) ya ≠ 0 :=
    is_fraction_ring.to_map_ne_zero_of_mem_non_zero_divisors hya,
  have : (algebra_map A K) yb ≠ 0 :=
    is_fraction_ring.to_map_ne_zero_of_mem_non_zero_divisors hyb,
  obtain ⟨c,(h|h)⟩ := valuation_ring.cond (xa * yb) (xb * ya),
  { right,
    use c,
    rw algebra.smul_def,
    field_simp,
    simp only [← ring_hom.map_mul, ← h], congr' 1, ring },
  { left,
    use c,
    rw algebra.smul_def,
    field_simp,
    simp only [← ring_hom.map_mul, ← h], congr' 1, ring }
end

noncomputable
instance : linear_ordered_comm_group_with_zero (value_group A K) :=
{ le_refl := by { rintro ⟨⟩, use 1, rw one_smul },
  le_trans := by { rintros ⟨a⟩ ⟨b⟩ ⟨c⟩ ⟨e,rfl⟩ ⟨f,rfl⟩, use (e * f), rw mul_smul },
  le_antisymm := begin
    rintros ⟨a⟩ ⟨b⟩ ⟨e,rfl⟩ ⟨f,hf⟩,
    by_cases hb : b = 0, { simp [hb] },
    have : is_unit e,
    { apply is_unit_of_dvd_one,
      use f, rw mul_comm,
      rw [← mul_smul, algebra.smul_def] at hf,
      nth_rewrite 1 ← one_mul b at hf,
      rw ← (algebra_map A K).map_one at hf,
      exact is_fraction_ring.injective _ _ (mul_right_cancel₀ hb hf).symm },
    apply quotient.sound',
    use [this.unit, rfl],
  end,
  le_total := valuation_ring.le_total _ _,
  decidable_le := by { classical, apply_instance },
  mul_assoc := by { rintros ⟨a⟩ ⟨b⟩ ⟨c⟩, apply quotient.sound', rw mul_assoc, apply setoid.refl' },
  one_mul := by { rintros ⟨a⟩, apply quotient.sound', rw one_mul, apply setoid.refl' },
  mul_one := by { rintros ⟨a⟩, apply quotient.sound', rw mul_one, apply setoid.refl' },
  mul_comm := by { rintros ⟨a⟩ ⟨b⟩, apply quotient.sound', rw mul_comm, apply setoid.refl' },
  mul_le_mul_left := begin
    rintros ⟨a⟩ ⟨b⟩ ⟨c,rfl⟩ ⟨d⟩,
    use c, simp only [algebra.smul_def], ring,
  end,
  zero_mul := by { rintros ⟨a⟩, apply quotient.sound', rw zero_mul, apply setoid.refl' },
  mul_zero := by { rintros ⟨a⟩, apply quotient.sound', rw mul_zero, apply setoid.refl' },
  zero_le_one := ⟨0, by rw zero_smul⟩,
  exists_pair_ne := begin
    use [0,1],
    intro c, obtain ⟨d,hd⟩ := quotient.exact' c,
    apply_fun (λ t, d⁻¹ • t) at hd,
    simpa using hd,
  end,
  inv_zero := by { apply quotient.sound', rw inv_zero, apply setoid.refl' },
  mul_inv_cancel := begin
    rintros ⟨a⟩ ha,
    apply quotient.sound',
    use 1,
    simp only [one_smul],
    apply (mul_inv_cancel _).symm,
    contrapose ha,
    simp only [not_not] at ha ⊢,
    rw ha, refl,
  end,
  ..(infer_instance : has_le (value_group A K)),
  ..(infer_instance : has_mul (value_group A K)),
  ..(infer_instance : has_inv (value_group A K)),
  ..(infer_instance : has_zero (value_group A K)),
  ..(infer_instance : has_one (value_group A K)) }

/-- Any valuation ring induces a valuation on its fraction field. -/
def valuation : valuation K (value_group A K) :=
{ to_fun := quotient.mk',
  map_zero' := rfl,
  map_one' := rfl,
  map_mul' := λ _ _, rfl,
  map_add_le_max' := begin
    intros a b,
    obtain ⟨xa,ya,hya,rfl⟩ : ∃ (a b : A), _ := is_fraction_ring.div_surjective a,
    obtain ⟨xb,yb,hyb,rfl⟩ : ∃ (a b : A), _ := is_fraction_ring.div_surjective b,
    have : (algebra_map A K) ya ≠ 0 :=
      is_fraction_ring.to_map_ne_zero_of_mem_non_zero_divisors hya,
    have : (algebra_map A K) yb ≠ 0 :=
      is_fraction_ring.to_map_ne_zero_of_mem_non_zero_divisors hyb,
    obtain ⟨c,(h|h)⟩ := valuation_ring.cond (xa * yb) (xb * ya),
    dsimp,
    { apply le_trans _ (le_max_left _ _),
      use (c + 1),
      rw algebra.smul_def,
      field_simp,
      simp only [← ring_hom.map_mul, ← ring_hom.map_add, ← (algebra_map A K).map_one, ← h],
      congr' 1, ring },
    { apply le_trans _ (le_max_right _ _),
      use (c + 1),
      rw algebra.smul_def,
      field_simp,
      simp only [← ring_hom.map_mul, ← ring_hom.map_add, ← (algebra_map A K).map_one, ← h],
      congr' 1, ring }
  end }

lemma mem_integer_iff (x : K) : x ∈ (valuation A K).integer ↔ ∃ a : A, algebra_map A K a = x :=
begin
  split,
  { rintros ⟨c,rfl⟩,
    use c,
    rw [algebra.smul_def, mul_one] },
  { rintro ⟨c,rfl⟩,
    use c,
    rw [algebra.smul_def, mul_one] }
end

/-- The valuation ring `A` is isomorphic to the ring of integers of its associated valuation. -/
noncomputable def equiv_integer : A ≃+* (valuation A K).integer :=
ring_equiv.of_bijective (show A →ₙ+* (valuation A K).integer, from
{ to_fun := λ a, ⟨algebra_map A K a, (mem_integer_iff _ _ _).mpr ⟨a,rfl⟩⟩,
  map_mul' := λ _ _, by { ext1, exact (algebra_map A K).map_mul _ _ },
  map_zero' := by { ext1, exact (algebra_map A K).map_zero },
  map_add' := λ _ _, by { ext1, exact (algebra_map A K).map_add _ _ } })
begin
  split,
  { intros x y h,
    apply_fun (coe : _ → K) at h,
    dsimp at h,
    exact is_fraction_ring.injective _ _ h },
  { rintros ⟨a,(ha : a ∈ (valuation A K).integer)⟩,
    rw mem_integer_iff at ha,
    obtain ⟨a,rfl⟩ := ha,
    use [a, rfl] }
end

@[simp]
lemma coe_equiv_integer_apply (a : A) : (equiv_integer A K a : K) = algebra_map A K a := rfl

lemma range_algebra_map_eq : (valuation A K).integer = (algebra_map A K).range :=
by { ext, exact mem_integer_iff _ _ _ }

end

section

variables (A : Type u) [comm_ring A] [is_domain A] [valuation_ring A]

@[priority 100]
instance : local_ring A :=
local_ring.of_is_unit_or_is_unit_one_sub_self
begin
  intros a,
  obtain ⟨c,(h|h)⟩ := valuation_ring.cond a (1-a),
  { left,
    apply is_unit_of_mul_eq_one _ (c+1),
    simp [mul_add, h] },
  { right,
    apply is_unit_of_mul_eq_one _ (c+1),
    simp [mul_add, h] }
end

instance [decidable_rel ((≤) : ideal A → ideal A → Prop)] : linear_order (ideal A) :=
{ le_total := begin
    intros α β,
    by_cases h : α ≤ β, { exact or.inl h },
    erw not_forall at h,
    push_neg at h,
    obtain ⟨a,h₁,h₂⟩ := h,
    right,
    intros b hb,
    obtain ⟨c,(h|h)⟩ := valuation_ring.cond a b,
    { rw ← h,
      exact ideal.mul_mem_right _ _ h₁ },
    { exfalso, apply h₂, rw ← h,
      apply ideal.mul_mem_right _ _ hb },
  end,
  decidable_le := infer_instance,
  ..(infer_instance : complete_lattice (ideal A)) }

end

section

variables {R : Type*} [comm_ring R] [is_domain R] {K : Type*}
variables [field K] [algebra R K] [is_fraction_ring R K]

lemma iff_dvd_total :
  valuation_ring R ↔ is_total R (∣) :=
begin
  classical,
  refine ⟨λ H, ⟨λ a b, _⟩, λ H, ⟨λ a b, _⟩⟩; resetI,
  { obtain ⟨c,rfl|rfl⟩ := @@valuation_ring.cond _ _ H a b; simp },
  { obtain (⟨c, rfl⟩|⟨c, rfl⟩) := @is_total.total _ _ H a b; use c; simp }
end

lemma iff_ideal_total :
  valuation_ring R ↔ is_total (ideal R) (≤) :=
begin
  classical,
  refine ⟨λ _, by exactI ⟨le_total⟩, λ H, iff_dvd_total.mpr ⟨λ a b, _⟩⟩,
  have := @is_total.total _ _ H (ideal.span {a}) (ideal.span {b}),
  simp_rw ideal.span_singleton_le_span_singleton at this,
  exact this.symm
end

variables {R} (K)

lemma dvd_total [h : valuation_ring R] (x y : R) : x ∣ y ∨ y ∣ x :=
@@is_total.total _ (iff_dvd_total.mp h) x y

lemma unique_irreducible [valuation_ring R] ⦃p q : R⦄
  (hp : irreducible p) (hq : irreducible q) : associated p q :=
begin
  have := dvd_total p q,
  rw [irreducible.dvd_comm hp hq, or_self] at this,
  exact associated_of_dvd_dvd (irreducible.dvd_symm hq hp this) this,
end

variable (R)

lemma iff_is_integer_or_is_integer :
  valuation_ring R ↔ ∀ x : K, is_localization.is_integer R x ∨ is_localization.is_integer R x⁻¹ :=
begin
  split,
  { introsI H x,
    obtain ⟨x : R, y, hy, rfl⟩ := is_fraction_ring.div_surjective x,
    any_goals { apply_instance },
    have := (map_ne_zero_iff _ (is_fraction_ring.injective R K)).mpr (non_zero_divisors.ne_zero hy),
    obtain ⟨s, rfl|rfl⟩ := valuation_ring.cond x y,
    { exact or.inr ⟨s, eq_inv_of_mul_eq_one_left $
        by rwa [mul_div, div_eq_one_iff_eq, map_mul, mul_comm]⟩ },
    { exact or.inl ⟨s, by rwa [eq_div_iff, map_mul, mul_comm]⟩ } },
  { intro H,
    constructor,
    intros a b,
    by_cases ha : a = 0, { subst ha, exact ⟨0, or.inr $ mul_zero b⟩ },
    by_cases hb : b = 0, { subst hb, exact ⟨0, or.inl $ mul_zero a⟩ },
    replace ha := (map_ne_zero_iff _ (is_fraction_ring.injective R K)).mpr ha,
    replace hb := (map_ne_zero_iff _ (is_fraction_ring.injective R K)).mpr hb,
    obtain ⟨c, e⟩|⟨c, e⟩ := H (algebra_map R K a / algebra_map R K b),
    { rw [eq_div_iff hb, ← map_mul, (is_fraction_ring.injective R K).eq_iff, mul_comm] at e,
      exact ⟨c, or.inr e⟩ },
    { rw [inv_div, eq_div_iff ha, ← map_mul,
        (is_fraction_ring.injective R K).eq_iff, mul_comm c] at e,
      exact ⟨c, or.inl e⟩ } }
end

variable {K}

lemma is_integer_or_is_integer [h : valuation_ring R] (x : K) :
  is_localization.is_integer R x ∨ is_localization.is_integer R x⁻¹ :=
(iff_is_integer_or_is_integer R K).mp h x

variable {R}

-- This implies that valuation rings are integrally closed through typeclass search.
@[priority 100]
instance [valuation_ring R] : is_bezout R :=
begin
  classical,
  rw is_bezout.iff_span_pair_is_principal,
  intros x y,
  rw ideal.span_insert,
  cases le_total (ideal.span {x} : ideal R) (ideal.span {y}),
  { erw sup_eq_right.mpr h, exact ⟨⟨_, rfl⟩⟩ },
  { erw sup_eq_left.mpr h, exact ⟨⟨_, rfl⟩⟩ }
end

lemma iff_local_bezout_domain :
  valuation_ring R ↔ local_ring R ∧ is_bezout R :=
begin
  classical,
  refine ⟨λ H, by exactI ⟨infer_instance, infer_instance⟩, _⟩,
  rintro ⟨h₁, h₂⟩,
  resetI,
  refine iff_dvd_total.mpr ⟨λ a b, _⟩,
  obtain ⟨g, e : _ = ideal.span _⟩ := is_bezout.span_pair_is_principal a b,
  obtain ⟨a, rfl⟩ := ideal.mem_span_singleton'.mp
    (show a ∈ ideal.span {g}, by { rw [← e], exact ideal.subset_span (by simp) }),
  obtain ⟨b, rfl⟩ := ideal.mem_span_singleton'.mp
    (show b ∈ ideal.span {g}, by { rw [← e], exact ideal.subset_span (by simp) }),
  obtain ⟨x, y, e'⟩ := ideal.mem_span_pair.mp
    (show g ∈ ideal.span {a * g, b * g}, by { rw e, exact ideal.subset_span (by simp) }),
  cases eq_or_ne g 0 with h h, { simp [h] },
  have : x * a + y * b = 1,
  { apply mul_left_injective₀ h, convert e'; ring_nf },
  cases local_ring.is_unit_or_is_unit_of_add_one this with h' h',
  left, swap, right,
  all_goals
  { exact mul_dvd_mul_right (is_unit_iff_forall_dvd.mp (is_unit_of_mul_is_unit_right h') _) _ },
end

protected lemma tfae (R : Type u) [comm_ring R] [is_domain R] :
  tfae [valuation_ring R,
    ∀ x : fraction_ring R, is_localization.is_integer R x ∨ is_localization.is_integer R x⁻¹,
    is_total R (∣),
    is_total (ideal R) (≤),
    local_ring R ∧ is_bezout R] :=
begin
  tfae_have : 1 ↔ 2, { exact iff_is_integer_or_is_integer R _ },
  tfae_have : 1 ↔ 3, { exact iff_dvd_total },
  tfae_have : 1 ↔ 4, { exact iff_ideal_total },
  tfae_have : 1 ↔ 5, { exact iff_local_bezout_domain },
  tfae_finish
end

end

lemma _root_.function.surjective.valuation_ring {R S : Type*} [comm_ring R] [is_domain R]
  [valuation_ring R] [comm_ring S] [is_domain S] (f : R →+* S) (hf : function.surjective f) :
  valuation_ring S :=
⟨λ a b, begin
  obtain ⟨⟨a, rfl⟩, ⟨b, rfl⟩⟩ := ⟨hf a, hf b⟩,
  obtain ⟨c, rfl|rfl⟩ := valuation_ring.cond a b,
  exacts [⟨f c, or.inl $ (map_mul _ _ _).symm⟩, ⟨f c, or.inr $ (map_mul _ _ _).symm⟩],
end⟩

section

variables {𝒪 : Type u} {K : Type v} {Γ : Type w}
  [comm_ring 𝒪] [is_domain 𝒪] [field K] [algebra 𝒪 K]
  [linear_ordered_comm_group_with_zero Γ]
  (v : _root_.valuation K Γ) (hh : v.integers 𝒪)

include hh

/-- If `𝒪` satisfies `v.integers 𝒪` where `v` is a valuation on a field, then `𝒪`
is a valuation ring. -/
lemma of_integers : valuation_ring 𝒪 :=
begin
  constructor,
  intros a b,
  cases le_total (v (algebra_map 𝒪 K a)) (v (algebra_map 𝒪 K b)),
  { obtain ⟨c,hc⟩ := valuation.integers.dvd_of_le hh h,
    use c, exact or.inr hc.symm },
  { obtain ⟨c,hc⟩ := valuation.integers.dvd_of_le hh h,
    use c, exact or.inl hc.symm }
end

end

section

variables (K : Type u) [field K]

/-- A field is a valuation ring. -/
@[priority 100]
instance of_field : valuation_ring K :=
begin
  constructor,
  intros a b,
  by_cases b = 0,
  { use 0, left, simp [h] },
  { use a * b⁻¹, right, field_simp, rw mul_comm }
end

end

section

variables (A : Type u) [comm_ring A] [is_domain A] [discrete_valuation_ring A]

/-- A DVR is a valuation ring. -/
@[priority 100]
instance of_discrete_valuation_ring : valuation_ring A :=
begin
  constructor,
  intros a b,
  by_cases ha : a = 0, { use 0, right, simp [ha] },
  by_cases hb : b = 0, { use 0, left, simp [hb] },
  obtain ⟨ϖ,hϖ⟩ := discrete_valuation_ring.exists_irreducible A,
  obtain ⟨m,u,rfl⟩ := discrete_valuation_ring.eq_unit_mul_pow_irreducible ha hϖ,
  obtain ⟨n,v,rfl⟩ := discrete_valuation_ring.eq_unit_mul_pow_irreducible hb hϖ,
  cases le_total m n with h h,
  { use (u⁻¹ * v : Aˣ) * ϖ^(n-m), left,
    simp_rw [mul_comm (u : A), units.coe_mul, ← mul_assoc, mul_assoc _ (u : A)],
    simp only [units.mul_inv, mul_one, mul_comm _ (v : A), mul_assoc, ← pow_add],
    congr' 2,
    linarith },
  { use (v⁻¹ * u : Aˣ) * ϖ^(m-n), right,
    simp_rw [mul_comm (v : A), units.coe_mul, ← mul_assoc, mul_assoc _ (v : A)],
    simp only [units.mul_inv, mul_one, mul_comm _ (u : A), mul_assoc, ← pow_add],
    congr' 2,
    linarith }
end

end

end valuation_ring


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

Facts about epimorphisms and monomorphisms.

The definitions of `epi` and `mono` are in `category_theory.category`,
since they are used by some lemmas for `iso`, which is used everywhere.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.adjunction.basic
import Mathlib.category_theory.opposites
import Mathlib.PostPort

universes v₁ v₂ u₁ u₂ l

namespace Mathlib

namespace category_theory

theorem left_adjoint_preserves_epi {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D}
    {G : D ⥤ C} (adj : F ⊣ G) {X : C} {Y : C} {f : X ⟶ Y} (hf : epi f) : epi (functor.map F f) :=
  sorry

theorem right_adjoint_preserves_mono {C : Type u₁} [category C] {D : Type u₂} [category D]
    {F : C ⥤ D} {G : D ⥤ C} (adj : F ⊣ G) {X : D} {Y : D} {f : X ⟶ Y} (hf : mono f) :
    mono (functor.map G f) :=
  sorry

theorem faithful_reflects_epi {C : Type u₁} [category C] {D : Type u₂} [category D] (F : C ⥤ D)
    [faithful F] {X : C} {Y : C} {f : X ⟶ Y} (hf : epi (functor.map F f)) : epi f :=
  sorry

theorem faithful_reflects_mono {C : Type u₁} [category C] {D : Type u₂} [category D] (F : C ⥤ D)
    [faithful F] {X : C} {Y : C} {f : X ⟶ Y} (hf : mono (functor.map F f)) : mono f :=
  sorry

/--
A split monomorphism is a morphism `f : X ⟶ Y` admitting a retraction `retraction f : Y ⟶ X`
such that `f ≫ retraction f = 𝟙 X`.

Every split monomorphism is a monomorphism.
-/
class split_mono {C : Type u₁} [category C] {X : C} {Y : C} (f : X ⟶ Y) where
  retraction : Y ⟶ X
  id' :
    autoParam (f ≫ retraction = 𝟙)
      (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
        (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])

/--
A split epimorphism is a morphism `f : X ⟶ Y` admitting a section `section_ f : Y ⟶ X`
such that `section_ f ≫ f = 𝟙 Y`.
(Note that `section` is a reserved keyword, so we append an underscore.)

Every split epimorphism is an epimorphism.
-/
class split_epi {C : Type u₁} [category C] {X : C} {Y : C} (f : X ⟶ Y) where
  section_ : Y ⟶ X
  id' :
    autoParam (section_ ≫ f = 𝟙)
      (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
        (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])

/-- The chosen retraction of a split monomorphism. -/
def retraction {C : Type u₁} [category C] {X : C} {Y : C} (f : X ⟶ Y) [split_mono f] : Y ⟶ X :=
  split_mono.retraction f

@[simp] theorem split_mono.id_assoc {C : Type u₁} [category C] {X : C} {Y : C} (f : X ⟶ Y)
    [split_mono f] {X' : C} (f' : X ⟶ X') : f ≫ retraction f ≫ f' = f' :=
  sorry

/-- The retraction of a split monomorphism is itself a split epimorphism. -/
protected instance retraction_split_epi {C : Type u₁} [category C] {X : C} {Y : C} (f : X ⟶ Y)
    [split_mono f] : split_epi (retraction f) :=
  split_epi.mk f

/-- A split mono which is epi is an iso. -/
def is_iso_of_epi_of_split_mono {C : Type u₁} [category C] {X : C} {Y : C} (f : X ⟶ Y)
    [split_mono f] [epi f] : is_iso f :=
  is_iso.mk (retraction f)

/--
The chosen section of a split epimorphism.
(Note that `section` is a reserved keyword, so we append an underscore.)
-/
def section_ {C : Type u₁} [category C] {X : C} {Y : C} (f : X ⟶ Y) [split_epi f] : Y ⟶ X :=
  split_epi.section_ f

@[simp] theorem split_epi.id_assoc {C : Type u₁} [category C] {X : C} {Y : C} (f : X ⟶ Y)
    [split_epi f] {X' : C} (f' : Y ⟶ X') : section_ f ≫ f ≫ f' = f' :=
  sorry

/-- The section of a split epimorphism is itself a split monomorphism. -/
protected instance section_split_mono {C : Type u₁} [category C] {X : C} {Y : C} (f : X ⟶ Y)
    [split_epi f] : split_mono (section_ f) :=
  split_mono.mk f

/-- A split epi which is mono is an iso. -/
def is_iso_of_mono_of_split_epi {C : Type u₁} [category C] {X : C} {Y : C} (f : X ⟶ Y) [mono f]
    [split_epi f] : is_iso f :=
  is_iso.mk (section_ f)

/-- Every iso is a split mono. -/
protected instance split_mono.of_iso {C : Type u₁} [category C] {X : C} {Y : C} (f : X ⟶ Y)
    [is_iso f] : split_mono f :=
  split_mono.mk (inv f)

/-- Every iso is a split epi. -/
protected instance split_epi.of_iso {C : Type u₁} [category C] {X : C} {Y : C} (f : X ⟶ Y)
    [is_iso f] : split_epi f :=
  split_epi.mk (inv f)

/-- Every split mono is a mono. -/
protected instance split_mono.mono {C : Type u₁} [category C] {X : C} {Y : C} (f : X ⟶ Y)
    [split_mono f] : mono f :=
  sorry

/-- Every split epi is an epi. -/
protected instance split_epi.epi {C : Type u₁} [category C] {X : C} {Y : C} (f : X ⟶ Y)
    [split_epi f] : epi f :=
  epi.mk
    fun (Z : C) (g h : Y ⟶ Z) (w : f ≫ g = f ≫ h) =>
      eq.mpr (id (Eq.refl (g = h)))
        (eq.mp
          ((fun (a a_1 : Y ⟶ Z) (e_1 : a = a_1) (ᾰ ᾰ_1 : Y ⟶ Z) (e_2 : ᾰ = ᾰ_1) =>
              congr (congr_arg Eq e_1) e_2)
            (section_ f ≫ f ≫ g) g (split_epi.id_assoc f g) (section_ f ≫ f ≫ h) h
            (split_epi.id_assoc f h))
          (section_ f ≫= w))

/-- Every split mono whose retraction is mono is an iso. -/
def is_iso.of_mono_retraction {C : Type u₁} [category C] {X : C} {Y : C} {f : X ⟶ Y} [split_mono f]
    [mono (retraction f)] : is_iso f :=
  is_iso.mk (retraction f)

/-- Every split epi whose section is epi is an iso. -/
def is_iso.of_epi_section {C : Type u₁} [category C] {X : C} {Y : C} {f : X ⟶ Y} [split_epi f]
    [epi (section_ f)] : is_iso f :=
  is_iso.mk (section_ f)

protected instance unop_mono_of_epi {C : Type u₁} [category C] {A : Cᵒᵖ} {B : Cᵒᵖ} (f : A ⟶ B)
    [epi f] : mono (has_hom.hom.unop f) :=
  mono.mk
    fun (Z : C) (g h : Z ⟶ opposite.unop B)
      (eq : g ≫ has_hom.hom.unop f = h ≫ has_hom.hom.unop f) =>
      has_hom.hom.op_inj (iff.mp (cancel_epi f) (has_hom.hom.unop_inj eq))

protected instance unop_epi_of_mono {C : Type u₁} [category C] {A : Cᵒᵖ} {B : Cᵒᵖ} (f : A ⟶ B)
    [mono f] : epi (has_hom.hom.unop f) :=
  epi.mk
    fun (Z : C) (g h : opposite.unop A ⟶ Z)
      (eq : has_hom.hom.unop f ≫ g = has_hom.hom.unop f ≫ h) =>
      has_hom.hom.op_inj (iff.mp (cancel_mono f) (has_hom.hom.unop_inj eq))

protected instance op_mono_of_epi {C : Type u₁} [category C] {A : C} {B : C} (f : A ⟶ B) [epi f] :
    mono (has_hom.hom.op f) :=
  mono.mk
    fun (Z : Cᵒᵖ) (g h : Z ⟶ opposite.op B) (eq : g ≫ has_hom.hom.op f = h ≫ has_hom.hom.op f) =>
      has_hom.hom.unop_inj (iff.mp (cancel_epi f) (has_hom.hom.op_inj eq))

protected instance op_epi_of_mono {C : Type u₁} [category C] {A : C} {B : C} (f : A ⟶ B) [mono f] :
    epi (has_hom.hom.op f) :=
  epi.mk
    fun (Z : Cᵒᵖ) (g h : opposite.op A ⟶ Z) (eq : has_hom.hom.op f ≫ g = has_hom.hom.op f ≫ h) =>
      has_hom.hom.unop_inj (iff.mp (cancel_mono f) (has_hom.hom.op_inj eq))

/-- Split monomorphisms are also absolute monomorphisms. -/
protected instance functor.map.split_mono {C : Type u₁} [category C] {D : Type u₂} [category D]
    {X : C} {Y : C} (f : X ⟶ Y) [split_mono f] (F : C ⥤ D) : split_mono (functor.map F f) :=
  split_mono.mk (functor.map F (retraction f))

/-- Split epimorphisms are also absolute epimorphisms. -/
protected instance functor.map.split_epi {C : Type u₁} [category C] {D : Type u₂} [category D]
    {X : C} {Y : C} (f : X ⟶ Y) [split_epi f] (F : C ⥤ D) : split_epi (functor.map F f) :=
  split_epi.mk (functor.map F (section_ f))

end Mathlib


/-
Copyright (c) 2020 Jannis Limperg. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jannis Limperg
-/

import data.list.basic
import data.list.defs
import data.list.zip
import data.list.range
import logic.basic

universes u v

open function

namespace list

variables {α : Type u} {β : Type v}

section map_with_index

lemma map_with_index_core_eq (l : list α) (f : ℕ → α → β) (n : ℕ) :
  l.map_with_index_core f n = l.map_with_index (λ i a, f (i + n) a) :=
begin
  induction l with hd tl hl generalizing f n,
  { simp [map_with_index, map_with_index_core] },
  { rw [map_with_index],
    simp [map_with_index_core, hl, add_left_comm, add_assoc, add_comm] }
end

lemma map_with_index_eq_enum_map (l : list α) (f : ℕ → α → β) :
  l.map_with_index f = l.enum.map (function.uncurry f) :=
begin
  induction l with hd tl hl generalizing f,
  { simp [map_with_index, map_with_index_core, list.enum_eq_zip_range] },
  { rw [map_with_index, map_with_index_core, map_with_index_core_eq, hl],
    simp [enum_eq_zip_range, range_succ_eq_map, zip_with_map_left,
    map_uncurry_zip_eq_zip_with] }
end

end map_with_index

section foldr_with_index

/-- Specification of `foldr_with_index_aux`. -/
def foldr_with_index_aux_spec (f : ℕ → α → β → β) (start : ℕ) (b : β)
  (as : list α) : β :=
foldr (uncurry f) b $ enum_from start as

theorem foldr_with_index_aux_spec_cons (f : ℕ → α → β → β) (start b a as) :
  foldr_with_index_aux_spec f start b (a :: as) =
  f start a (foldr_with_index_aux_spec f (start + 1) b as) :=
rfl

theorem foldr_with_index_aux_eq_foldr_with_index_aux_spec (f : ℕ → α → β → β)
  (start b as) :
  foldr_with_index_aux f start b as = foldr_with_index_aux_spec f start b as :=
begin
  induction as generalizing start,
  { refl },
  { simp only [foldr_with_index_aux, foldr_with_index_aux_spec_cons, *] }
end

theorem foldr_with_index_eq_foldr_enum (f : ℕ → α → β → β) (b : β) (as : list α) :
  foldr_with_index f b as = foldr (uncurry f) b (enum as) :=
by simp only
    [foldr_with_index, foldr_with_index_aux_spec,
     foldr_with_index_aux_eq_foldr_with_index_aux_spec, enum]

end foldr_with_index

theorem indexes_values_eq_filter_enum (p : α → Prop) [decidable_pred p]
  (as : list α) :
  indexes_values p as = filter (p ∘ prod.snd) (enum as) :=
by simp [indexes_values, foldr_with_index_eq_foldr_enum, uncurry, filter_eq_foldr]

theorem find_indexes_eq_map_indexes_values (p : α → Prop) [decidable_pred p]
  (as : list α) :
  find_indexes p as = map prod.fst (indexes_values p as) :=
by simp only
    [indexes_values_eq_filter_enum, map_filter_eq_foldr, find_indexes,
     foldr_with_index_eq_foldr_enum, uncurry]

section foldl_with_index

/-- Specification of `foldl_with_index_aux`. -/
def foldl_with_index_aux_spec (f : ℕ → α → β → α) (start : ℕ) (a : α)
  (bs : list β) : α :=
foldl (λ a (p : ℕ × β), f p.fst a p.snd) a $ enum_from start bs

theorem foldl_with_index_aux_spec_cons (f : ℕ → α → β → α) (start a b bs) :
  foldl_with_index_aux_spec f start a (b :: bs) =
  foldl_with_index_aux_spec f (start + 1) (f start a b) bs :=
rfl

theorem foldl_with_index_aux_eq_foldl_with_index_aux_spec (f : ℕ → α → β → α)
  (start a bs) :
  foldl_with_index_aux f start a bs = foldl_with_index_aux_spec f start a bs :=
begin
  induction bs generalizing start a,
  { refl },
  { simp [foldl_with_index_aux, foldl_with_index_aux_spec_cons, *] }
end

theorem foldl_with_index_eq_foldl_enum (f : ℕ → α → β → α) (a : α) (bs : list β) :
  foldl_with_index f a bs =
  foldl (λ a (p : ℕ × β), f p.fst a p.snd) a (enum bs) :=
by simp only
    [foldl_with_index, foldl_with_index_aux_spec,
     foldl_with_index_aux_eq_foldl_with_index_aux_spec, enum]

end foldl_with_index

section mfold_with_index

variables {m : Type u → Type v} [monad m]

theorem mfoldr_with_index_eq_mfoldr_enum {α β} (f : ℕ → α → β → m β) (b : β) (as : list α) :
  mfoldr_with_index f b as = mfoldr (uncurry f) b (enum as) :=
by simp only
    [mfoldr_with_index, mfoldr_eq_foldr, foldr_with_index_eq_foldr_enum, uncurry]

theorem mfoldl_with_index_eq_mfoldl_enum [is_lawful_monad m] {α β}
  (f : ℕ → β → α → m β) (b : β) (as : list α) :
  mfoldl_with_index f b as =
    mfoldl (λ b (p : ℕ × α), f p.fst b p.snd) b (enum as) :=
by rw [mfoldl_with_index, mfoldl_eq_foldl, foldl_with_index_eq_foldl_enum]

end mfold_with_index

section mmap_with_index

variables {m : Type u → Type v} [applicative m]

/-- Specification of `mmap_with_index_aux`. -/
def mmap_with_index_aux_spec {α β} (f : ℕ → α → m β) (start : ℕ) (as : list α) :
  m (list β) :=
list.traverse (uncurry f) $ enum_from start as
-- Note: `traverse` the class method would require a less universe-polymorphic
-- `m : Type u → Type u`.

theorem mmap_with_index_aux_spec_cons {α β} (f : ℕ → α → m β) (start : ℕ)
  (a : α) (as : list α) :
  mmap_with_index_aux_spec f start (a :: as) =
    list.cons <$> f start a <*> mmap_with_index_aux_spec f (start + 1) as :=
rfl

theorem mmap_with_index_aux_eq_mmap_with_index_aux_spec {α β} (f : ℕ → α → m β)
  (start : ℕ) (as : list α) :
  mmap_with_index_aux f start as = mmap_with_index_aux_spec f start as :=
begin
  induction as generalizing start,
  { refl },
  { simp [mmap_with_index_aux, mmap_with_index_aux_spec_cons, *] }
end

theorem mmap_with_index_eq_mmap_enum {α β} (f : ℕ → α → m β) (as : list α) :
  mmap_with_index f as = list.traverse (uncurry f) (enum as) :=
by simp only
    [mmap_with_index, mmap_with_index_aux_spec,
     mmap_with_index_aux_eq_mmap_with_index_aux_spec, enum ]

end mmap_with_index

section mmap_with_index'

variables {m : Type u → Type v} [applicative m] [is_lawful_applicative m]

theorem mmap_with_index'_aux_eq_mmap_with_index_aux {α} (f : ℕ → α → m punit)
  (start : ℕ) (as : list α) :
  mmap_with_index'_aux f start as =
  mmap_with_index_aux f start as *> pure punit.star :=
by induction as generalizing start;
    simp [mmap_with_index'_aux, mmap_with_index_aux, *, seq_right_eq, const, -comp_const]
      with functor_norm

theorem mmap_with_index'_eq_mmap_with_index {α} (f : ℕ → α → m punit) (as : list α) :
  mmap_with_index' f as = mmap_with_index f as *> pure punit.star :=
by apply mmap_with_index'_aux_eq_mmap_with_index_aux

end mmap_with_index'

end list


import system_of_complexes.basic

/-!
# The normed snake dual lemma: weak and non-weak

This file proves the weak normed snake dual lemma and the normed snake dual lemma: they are the
statements `weak_normed_snake_dual` and `normed_snake_dual`, respectively.

The principal definitions of the concepts in this file appear in Section 4 of the blueprint.

The two main results prove `is_(weak_)bounded_exact` for certain `system_of_complexes`. The
Lean-definitions of these concepts appears in `system_of_complexes.basic`.

Intuitively, the two predicates assert a version of exactness for a complex whose overall shape is
an inequality of the form
```lean
∥res ? - (M.d ??) ?∥ ≤ const * ∥(M.d ?? ?∥ + ε.
```
(Recall that `res` is a restriction among certain complexes, `M.d` stands for a differential,
`const` is a constant; the error `ε` is a non-negative real number.  For the weak version, we
quantify over all `0 < ε ∈ ℝ`.  For the non-weak version, we use `ε = 0`.)

More in detail, at the heart of the computation, is a proof of an inequality of the form
```lean
∥res m - (M.d (i - 1) i) y∥ ≤ K * (1 + K' * r₁ * r₂) * ∥(M.d i (i + 1)) m∥ + ε.
```
In the weak normed snake dual lemma, for any choice of positive `0 < ε`, we should be able to fix
the parameters so that the inequality above is satisfied.  In the normed snake dual lemma, we want
the inequality above with `ε = 0`.  As you will see, the bulk of the proof of the normed snake dual
lemma recycles the proof of the weak version.

The proof involves several estimations: we broke these proofs into smaller partial inequalities,
for three reasons.  First, it streamlines the formalization.  Second, it helps Lean processing the
statements, reducing processing times.  Third, it allows us to us a large part of the argument for
both `weak_normed_snake_dual` and `normed_snake_dual`.

# Remark

While following the proof, keep an eye out for how the factor `ρ = 1 + K' * r₁ * r₂` forms itself.
Once the factor `ρ` is formed, we can almost treat it as a new strictly positive variable.
-/

universe variables u

noncomputable theory
open_locale nnreal
open category_theory opposite normed_add_group_hom system_of_complexes

variables {M N P : system_of_complexes.{u}} {f : M ⟶ N} {g : N ⟶ P}

/-  I (DT) extracted this lemma to speed up the proof of `weak_normed_snake_dual`. -/
lemma ε₁_le_ε {ε ε₁ : ℝ} (hε : 0 ≤ ε) (mK : ℝ≥0) (hε₁ : ε₁ = ε / 2 * (1 + mK)⁻¹) :
  ε₁ ≤ ε :=
by { rw [hε₁, div_eq_mul_inv, mul_assoc, ← mul_inv],
     exact mul_le_of_le_one_right hε (inv_le_one $ nnreal.coe_le_coe.mpr $
      one_le_mul one_le_two $ le_add_of_nonneg_right mK.2) }

/-!
First, we break off the main term `∥res m - (M.d i' i) m₁∥` into a sum of two expressions:

* `∥(res (f m) : N c i) - N.d i' i (res n₁)∥`, and
* `∥(N.d i' i ((N.d i'' i') n₂ + nnew₁) : N c i)∥`.
-/
lemma norm_sub_le_split {k' c c₁ : ℝ≥0} {i i' i'' : ℕ}
  [hk' : fact (1 ≤ k')] [fc : fact (c ≤ c₁)]
  (hfnorm : ∀ (c : ℝ≥0) (i : ℕ) (x : (M c i)), ∥(f.apply) x∥ = ∥x∥)
  {n₁ : N (k' * c) i'} {n₂ : N c i''} {nnew₁ : N c i'} {m₁ : M c i'} {m : (M c₁ i)}
  (hm₁ : f m₁ = res n₁ - ((N.d i'' i') n₂) - nnew₁) :
  ∥res m - (M.d i' i) m₁∥ ≤
    ∥(res (f m) : N c i) - N.d i' i (res n₁)∥ + ∥(N.d i' i ((N.d i'' i') n₂ + nnew₁) : N c i)∥ :=
calc ∥res m - (M.d i' i) m₁∥
      = ∥f (res m - (M.d i' i) m₁)∥ : (hfnorm _ _ _).symm
  ... = ∥res (f m) - (N.d i' i (res n₁) - N.d i' i ((N.d i'' i') n₂ + nnew₁))∥ :
    by rw [hom_apply, _root_.map_sub, ←hom_apply, ←hom_apply, ←res_apply,
      ←d_apply, hm₁, sub_sub, _root_.map_sub]
  ... = ∥(res (f m) - N.d i' i (res n₁)) + N.d i' i ((N.d i'' i') n₂ + nnew₁)∥ :
    by rw [sub_eq_add_neg, neg_sub, sub_eq_neg_add, ← add_assoc, ← sub_eq_add_neg]
  ... ≤ ∥res (f m) - N.d i' i (res n₁)∥ + ∥N.d i' i ((N.d i'' i') n₂ + nnew₁)∥ : norm_add_le _ _

/-!
We then massage the left-hand side.  The proof of this lemma is deceptively simple, since
there is a lot of typeclass work happening in the background.  In particular, the `c` in the sea of
underscores of the second line is crucial for the *previous* line to compile.

(The hypothesis `(hN_adm : N.admissible)` is only used via `(hN_adm.res_norm_noninc _ c _ _ _)`,
producing the inequality
`(dis : ∥(res (res (f m) - (N.d i' i) n₁) : N c i)∥ ≤ ∥res (f m) - (N.d i' i) n₁∥)`.)
-/
lemma norm_sub_le_mul_norm_add_lhs {k' K c c₁ : ℝ≥0} {ε₁ : ℝ} {i i' : ℕ}
  [hk' : fact (1 ≤ k')] [fc₁ : fact (k' * c ≤ c₁)] [fc : fact (c ≤ c₁)]
  {n₁ : N (k' * c) i'} {m : (M c₁ i)}
  (hN_adm : N.admissible)
  (hn₁ : ∥res (f m) - (N.d i' i) n₁∥ ≤ K * ∥(N.d i (i + 1)) (f m)∥ + ε₁) :
  ∥(res (f m) : N c i) - N.d i' i (res n₁)∥ ≤ K * ∥(N.d i (i + 1)) (f m)∥ + ε₁ :=
calc ∥(res (f m) : N c i) - N.d i' i (res n₁)∥
      = ∥res (res (f m) - (N.d i' i) n₁)∥ : by rw [_root_.map_sub, d_res, ← res_res]
  ... ≤ K * ∥(N.d i (i + 1)) (f m)∥ + ε₁  : trans (hN_adm.res_norm_noninc _ c _ _ _) hn₁

/-!
And we also massage the right-hand side.  Here, the factor `K' * r₁ * r₂` appears.

(The hypothesis `(hN_adm : N.admissible)` is only used via `(hN_adm.d_norm_noninc _ _ i' i nnew₁)`,
producing the inequality `(dis : ∥(N.d i' i) nnew₁∥ ≤ ∥nnew₁∥)`.)
-/
lemma norm_sub_le_mul_norm_add_rhs {k' K K' r₁ r₂ c c₁ : ℝ≥0} {ε₁ ε₂ : ℝ}
  {i i' i'' : ℕ} (hii' : i' + 1 = i)
  [hk' : fact (1 ≤ k')] [fc₁ : fact (k' * c ≤ c₁)]
  (hgnorm : ∀ (c : ℝ≥0) (i : ℕ) (x : (N c i)), ∥g x∥ ≤ ↑r₁ * ∥x∥)
  {n₁ : N (k' * c) i'} {n₂ : N c i''} {nnew₁ : N c i'} {m : (M c₁ i)}
  (hN_adm : N.admissible)
  (hn₁ : ∥res (f m) - (N.d i' i) n₁∥ ≤ K * ∥(N.d i (i + 1)) (f m)∥ + ε₁)
  (hp₂ : ∥res (g n₁) - (P.d i'' i') (g n₂)∥ ≤ K' * ∥(P.d i' (i' + 1)) (g n₁)∥ + ε₂)
  (hnormnnew₁ : ∥nnew₁∥ ≤ r₂ * ∥g (res n₁ - ((N.d i'' i') n₂))∥)
  (hfm : ∥g ((N.d i' i) n₁)∥ = ∥g (res (f m) - (N.d i' i) n₁)∥) :
  ∥(N.d i' i ((N.d i'' i') n₂ + nnew₁) : N c i)∥ ≤
    K * K' * r₁ * r₂ * ∥(N.d i (i+1)) (f m)∥ + K' * r₁ * r₂ * ε₁ + r₂ * ε₂ :=
calc ∥(N.d i' i ((N.d i'' i') n₂ + nnew₁) : N c i)∥
      = ∥N.d i' i nnew₁∥ : by simp only [map_add, zero_add, d_d]
  ... ≤ r₂ * ∥g (res n₁ - (N.d i'' i') n₂)∥ : trans (hN_adm.d_norm_noninc _ _ i' i nnew₁) hnormnnew₁
  ... = r₂ * ∥res (g n₁) - P.d i'' i' (g n₂)∥ :
    by rw [hom_apply, _root_.map_sub, ←hom_apply, ←hom_apply, ←res_apply _ _ g, ←d_apply]
  ... ≤ r₂ * (K' * ∥P.d i' (i'+1) (g n₁)∥ + ε₂) : mul_le_mul_of_nonneg_left hp₂ r₂.coe_nonneg
  ... = r₂ * (K' * ∥g (res (f m) - N.d i' i n₁)∥ + ε₂) : by rw [d_apply _ _ g _, hii', hfm]
  ... ≤ r₂ * (K' * (r₁ * ∥res (f m) - N.d i' i n₁∥) + ε₂) :
    mul_le_mul_of_nonneg_left (add_le_add_right (mul_le_mul_of_nonneg_left
      (hgnorm _ _ _) K'.coe_nonneg) _) $ r₂.coe_nonneg
  ... = r₂ * (K' * r₁ * ∥res (f m) - N.d i' i n₁∥ + ε₂) : by rw mul_assoc
  ... ≤ r₂ * (K' * r₁ * (K * ∥(N.d i (i+1)) (f m)∥ + ε₁) + ε₂) :
    mul_le_mul_of_nonneg_left (add_le_add_right (mul_le_mul_of_nonneg_left
      hn₁ $ mul_nonneg K'.coe_nonneg r₁.coe_nonneg) _) r₂.coe_nonneg
  ... = _ : by ring

/-!
We collect the inequalities obtained so far:

* use `norm_sub_le_split` to split the norm into a sum of two terme;
* apply `norm_sub_le_mul_norm_add_lhs` to the left-hand-side;
* apply `norm_sub_le_mul_norm_add_rhs` to the right-hand-side.

The rest is simple manipulations of real numbers.
-/
lemma norm_sub_le_mul_norm_add {k' K K' r₁ r₂ c c₁ : ℝ≥0} {ε ε₁ ε₂ : ℝ}
  {i i' i'' : ℕ} (hii' : i' + 1 = i)
  [hk' : fact (1 ≤ k')] [fc₁ : fact (k' * c ≤ c₁)] [fc : fact (c ≤ c₁)]
  (hN_adm : N.admissible)
  (hgnorm : ∀ (c : ℝ≥0) (i : ℕ) (x : (N c i)), ∥g x∥ ≤ ↑r₁ * ∥x∥)
  (hfnorm : ∀ (c : ℝ≥0) (i : ℕ) (x : (M c i)), ∥(f.apply) x∥ = ∥x∥)
  {n₁ : N (k' * c) i'} {n₂ : N c i''} {nnew₁ : N c i'} {m₁ : M c i'} {m : (M c₁ i)}
  (hmulε₁ : ε₁ * (1 + K' * r₁ * r₂) = ε / 2)
  (hle : (r₂ : ℝ) * ε₂ ≤ ε / 2)
  (hn₁ : ∥res (f m) - (N.d i' i) n₁∥ ≤ K * ∥(N.d i (i + 1)) (f m)∥ + ε₁)
  (hp₂ : ∥res (g n₁) - (P.d i'' i') (g n₂)∥ ≤ K' * ∥(P.d i' (i' + 1)) (g n₁)∥ + ε₂)
  (hnormnnew₁ : ∥nnew₁∥ ≤ r₂ * ∥g (res n₁ - ((N.d i'' i') n₂))∥)
  (hm₁ : f m₁ = res n₁ - ((N.d i'' i') n₂) - nnew₁)
  (hfm : ∥g ((N.d i' i) n₁)∥ = ∥g (res (f m) - (N.d i' i) n₁)∥) :
  ∥res m - (M.d i' i) m₁∥ ≤ (K + r₁ * r₂ * K * K') * ∥(M.d i (i + 1)) m∥ + ε :=
calc
∥res m - (M.d i' i) m₁∥ ≤ ∥res (f m) - N.d i' i (res n₁)∥ + ∥N.d i' i ((N.d i'' i') n₂ + nnew₁)∥ :
    norm_sub_le_split hfnorm hm₁
  ... ≤ (K * ∥(N.d i (i + 1)) (f m)∥ + ε₁) +
        (K * K' * r₁ * r₂ * ∥(N.d i (i+1)) (f m)∥ + K' * r₁ * r₂ * ε₁ + r₂ * ε₂) : add_le_add
      (norm_sub_le_mul_norm_add_lhs hN_adm hn₁)
      (norm_sub_le_mul_norm_add_rhs hii' hgnorm hN_adm hn₁ hp₂ hnormnnew₁ hfm)
  ... = (K + r₁ * r₂ * K * K') * ∥N.d i (i+1) (f m)∥ + ε₁ * (1 + K' * r₁ * r₂) + r₂ * ε₂ : by ring
  ... = (K + r₁ * r₂ * K * K') * ∥N.d i (i+1) (f m)∥ + ε / 2 + r₂ * ε₂ :
    congr_arg (λ e, (↑K + ↑r₁ * ↑r₂ * ↑K * ↑K') * ∥(N.d i (i + 1)) (f m)∥ + e + ↑r₂ * ε₂) hmulε₁
  ... ≤ (K + r₁ * r₂ * K * K') * ∥N.d i (i+1) (f m)∥ + ε / 2 + ε / 2 : add_le_add_left hle _
  ... = (K + r₁ * r₂ * K * K') * ∥(M.d i (i+1)) m∥ + ε :
    by rw [add_assoc, add_halves', d_apply, hom_apply, hfnorm]

/-!
We shall apply this lemma with `ρ = K + r₁ * r₂ * K * K' = K * (1 + K' * r₁ * r₂)`.
-/
lemma exists_norm_sub_le_mul_add {k k' c ρ : ℝ≥0}
  {i : ℕ}
  [hk : fact (1 ≤ k)] [hk' : fact (1 ≤ k')]
  (hM_adm : M.admissible)
  (ex_le : (∀ (m : (M (k * (k' * c)) i)) (ε : ℝ), 0 < ε →
        (∃ (i₀ : ℕ) (hi₀ : i₀ = i - 1) (y : (M c i₀)),
           ∥res m - (M.d i₀ i) y∥ ≤ ↑ρ * ∥(M.d i (i + 1)) m∥ + ε)))
  {m₁ : (M (k * k' * c) i)}
  {ε : ℝ} (hε : 0 < ε) :
  ∃ (i₀ j : ℕ) (hi₀ : i₀ = i - 1) (hj : i + 1 = j) (y : (M c i₀)),
      ∥res m₁ - (M.d i₀ i) y∥ ≤ ↑ρ * ∥(M.d i j) m₁∥ + ε :=
begin
  haveI : fact (k * (k' * c) ≤ k * k' * c) := { out := (mul_assoc _ _ _).symm.le },
  rcases ex_le (res m₁) ε hε with ⟨i₀, rfl, y, hy⟩,
  rw [res_res, d_res] at hy,
  refine ⟨i - 1, _, rfl, rfl, _⟩,
  refine ⟨y, hy.trans (add_le_add_right (mul_le_mul_of_nonneg_left _ ρ.2) ε)⟩,
  exact hM_adm.res_norm_noninc _ _ _ _ _,
end

/-!
This argument proves the main inequality in the case where the indices are `0` or `1`.
-/
lemma norm_sub_le_mul_mul_norm_add {M N : system_of_complexes} {f : M ⟶ N}
  {k k' K c : ℝ≥0} (mK : ℝ≥0) {ε ε₁ : ℝ} {m : M (k * (k' * c)) 0} {n₁ : N (k' * c) 0} {m₁ : M c 0}
  (ee1 : ε₁ ≤ ε)
  [hk : fact (1 ≤ k)] [hk' : fact (1 ≤ k')]
  (hfnorm : ∀ (c : ℝ≥0) (i : ℕ) (x : (M c i)), ∥(f.apply) x∥ = ∥x∥)
  (inadm : ∥((res (res m : (M (k' * c) 0))) : (M c 0))∥ ≤ ∥(res m : (M (k' * c) 0))∥ )
  (hn₁ : ∥res (f m) - (N.d 0 0) n₁∥ ≤ ↑K * ∥(N.d 0 (0 + 1)) (f m)∥ + ε₁) :
  ∥res m - (M.d 0 0) m₁∥ ≤ (K * (1 + mK)) * ∥(M.d 0 (0 + 1)) m∥ + ε :=
begin
  simp only [d_self_apply, sub_zero, nnreal.coe_add, nnreal.coe_mul] at hn₁ ⊢,
  rw [res_apply, hom_apply f (res m), hfnorm] at hn₁,
  have new : fact (c ≤ k' * c) := { out := le_mul_of_one_le_left c.2 hk'.out },
  rw ←res_res _ _ _ new,
  refine le_trans inadm (le_trans hn₁ _),
  rw [d_apply, hom_apply f _, hfnorm],
  refine add_le_add _ ee1,
  rw mul_assoc,
  refine (mul_le_mul_of_nonneg_left _ K.2),
  exact le_mul_of_one_le_left (norm_nonneg _) (le_add_of_nonneg_right mK.2),
end

/-!
Note that `ε = 0` is allowed.  Indeed, the weak normed snake dual lemma uses `0 ≤ ε`, while the
normed snake dual lemma uses `ε = 0`.
-/
lemma exist_norm_sub_le_mul_norm_add {k k' K K' r₁ r₂ c₀ c : ℝ≥0}
  {a i : ℕ} {ε : ℝ} (hε : 0 ≤ ε)
  [hk : fact (1 ≤ k)] [hk' : fact (1 ≤ k')]
  (hN_adm : N.admissible)
  (hgnrm : ∀ (c : ℝ≥0) (i : ℕ) (x : (N c i)), ∥g x∥ ≤ r₁ * ∥x∥)
  (Hg : ∀ (c : ℝ≥0) [_inst_1 : fact (c₀ ≤ c)] (i : ℕ),
          i ≤ a + 1 + 1 → ∀ (y : (P c i)), ∃ (x : (N c i)), g x = y ∧ ∥x∥ ≤ r₂ * ∥y∥)
  (hg : ∀ (c : ℝ≥0) (i : ℕ), (range f.apply : add_subgroup (N c i)) = ker g.apply)
  (hf : ∀ (c : ℝ≥0) (i : ℕ), (isometry (f.apply : M c i ⟶ N c i) : _))
  (hc : fact (c₀ ≤ c))
  (hi : i ≤ a)
  {m : M (k * (k' * c)) i} {n₁ : N (k' * c) (i - 1)}
  (hn₁ : ∥res (f m) - (N.d (i - 1) i) n₁∥ ≤
    K * ∥(N.d i (i + 1)) (f m)∥ + ε / 2 * (1 + K' * r₁ * r₂)⁻¹)
  (Hi' : i - 1 ≤ a + 1)
  (p₂ : P c (i - 1 - 1)) (hp₂ : ∥res (g n₁) - (P.d (i - 1 - 1) (i - 1)) p₂∥ ≤
    K' * ∥(P.d (i - 1) (i - 1 + 1)) (g n₁)∥ + ite (r₂ = 0) 1 (ε / 2 * (r₂)⁻¹)) :
  ∃ (i₀ : ℕ) (hi₀ : i₀ = i - 1) (y : (M c i₀)),
    ∥res m - (M.d i₀ i) y∥ ≤ (K + r₁ * r₂ * K * K') * ∥(M.d i (i + 1)) m∥ + ε :=
begin
  obtain ⟨n₂, rfl, hnormn₂⟩ :=
    Hg c (i - 1 - 1) (trans (nat.pred_le _) (trans Hi' (nat.le_succ _))) p₂,
  let n₁' := N.d (i - 1 - 1) (i - 1) n₂,
  obtain ⟨nnew₁, hnnew₁, hnrmnew₁⟩ := Hg c (i - 1) (trans Hi' a.succ.le_succ) (g (res n₁ - n₁')),
  have hker : (res n₁ - n₁') - nnew₁ ∈ g.apply.ker,
  { rw [mem_ker, _root_.map_sub, sub_eq_zero, ←hom_apply, ←hom_apply, hnnew₁] },
  rw ←hg at hker,
  obtain ⟨m₁, hm₁ : f m₁ = res n₁ - n₁' - nnew₁⟩ := (mem_range _ _).1 hker,
  refine ⟨i - 1, rfl, m₁, _⟩,
  have hfnrm : ∀ c i (x : M c i), ∥f.apply x∥ = ∥x∥ := λ c i x, (add_monoid_hom_class.isometry_iff_norm _).1 (hf c i) x,
  by_cases hizero : i = 0,
  { subst hizero,
    convert norm_sub_le_mul_mul_norm_add (K' * r₁ * r₂) _ hfnrm _ hn₁,
    { norm_cast, ring },
    { exact ε₁_le_ε hε (K' * r₁ * r₂) rfl },
    { exact (admissible_of_isometry hN_adm hf).res_norm_noninc _ _ _ _ _ } },
  { refine norm_sub_le_mul_norm_add _ hN_adm hgnrm hfnrm _ _ hn₁ hp₂ hnrmnew₁ hm₁ _,
    { exact nat.succ_pred_eq_of_pos (nat.pos_of_ne_zero hizero) },
    { rw inv_mul_cancel_right₀,
      exact ne_of_gt (add_pos_of_pos_of_nonneg zero_lt_one (zero_le (K' * r₁ * r₂))) },
    { by_cases H : r₂ = 0,
      { simp only [H, nnreal.coe_zero, if_true, zero_mul, (div_nonneg hε zero_le_two)] },
      { simp only [H, nnreal.coe_eq_zero, if_false, mul_comm,
          mul_inv_cancel_left₀ (nnreal.coe_ne_zero.mpr H)] } },
    { have : f (res m : M (k' * c) i) ∈ f.apply.range, { rw mem_range, exact ⟨res m, rfl⟩ },
      rw [hg, mem_ker] at this,
      rw [hom_apply g (res (f m) - (N.d (i - 1) i) n₁), res_apply, _root_.map_sub, this,
        zero_sub, norm_neg, ←hom_apply] } }
end

/-!
We apply this lemma with `ρ = K + r₁ * r₂ * K * K'`.
-/
lemma exists_norm_sub_le_mul {M : system_of_complexes} {k k' c ρ : ℝ≥0}
  {i : ℕ}
  [hk : fact (1 ≤ k)] [hk' : fact (1 ≤ k')]
  (hM_adm : M.admissible)
  (ex_le : (∀ (m : (M (k * (k' * c)) i)),
        (∃ (i₀ : ℕ) (hi₀ : i₀ = i - 1) (y : (M c i₀)),
           ∥res m - (M.d i₀ i) y∥ ≤ ↑ρ * ∥(M.d i (i + 1)) m∥)))
  (m₁ : (M (k * k' * c) i)) :
  ∃ (i₀ j : ℕ) (hi₀ : i₀ = i - 1) (hj : i + 1 = j) (y : (M c i₀)),
      ∥res m₁ - (M.d i₀ i) y∥ ≤ ↑ρ * ∥(M.d i j) m₁∥ :=
begin
  haveI : fact (k * (k' * c) ≤ k * k' * c) := { out := (mul_assoc _ _ _).symm.le },
  rcases ex_le (res m₁) with ⟨i₀, rfl, y, hy⟩,
  rw [res_res, d_res] at hy,
  refine ⟨i - 1, _, rfl, rfl, _⟩,
  refine ⟨y, hy.trans (mul_le_mul_of_nonneg_left _ ρ.2)⟩,
  exact hM_adm.res_norm_noninc _ _ _ _ _,
end

variables (M N P f g)

/-!
Finally, we state and prove the weak normed snake dual lemma.
-/
lemma weak_normed_snake_dual (k k' K K' r₁ r₂ : ℝ≥0)
  [hk : fact (1 ≤ k)] [hk' : fact (1 ≤ k')]
  {a : ℕ} {c₀ : ℝ≥0}
  (hN : N.is_weak_bounded_exact k K (a + 1) c₀)
  (hP : P.is_weak_bounded_exact k' K' (a + 1) c₀)
  (hN_adm : N.admissible)
  (hgnrm : ∀ c i (x : N c i), ∥g x∥ ≤ r₁ * ∥x∥)
  (Hg : ∀ (c : ℝ≥0) [fact (c₀ ≤ c)] (i : ℕ) (hi : i ≤ a + 1 + 1) (y : P c i),
    ∃ (x : N c i), g x = y ∧ ∥x∥ ≤ r₂ * ∥y∥)
  (hg : ∀ c i, (f.apply : M c i ⟶ N c i).range = g.apply.ker)
  (hf : ∀ c i, @isometry (M c i) (N c i) _ _ f.apply) :
  M.is_weak_bounded_exact (k * k') (K + r₁ * r₂ * K * K') a c₀ :=
begin
  introsI c hc i hi,
  apply exists_norm_sub_le_mul_add (admissible_of_isometry hN_adm hf),
  intros m ε hε,

  have hε₁ : 0 < ε / 2 * (1 + K' * r₁ * r₂)⁻¹ := mul_pos (half_pos hε)
    (inv_pos.2 $ add_pos_of_pos_of_nonneg zero_lt_one ((K' * r₁ * r₂).coe_nonneg)),
  obtain ⟨_, _, rfl, rfl, n₁, hn₁⟩ :=
    hN _ ⟨hc.out.trans $ le_mul_of_one_le_left' hk'.out⟩ _ (trans hi a.le_succ) (f m) _ hε₁,
  have Hi' : i - 1 ≤ a + 1 := trans i.pred_le (trans hi a.le_succ),
  obtain ⟨_, _, rfl, rfl, p₂, hp₂⟩ := hP _ hc _ Hi' (g n₁)
    (if (r₂ : ℝ) = 0 then 1 else (ε / 2) * r₂⁻¹) _,
  { simp_rw [nnreal.coe_eq_zero r₂] at hp₂,
    apply exist_norm_sub_le_mul_norm_add hε.le hN_adm hgnrm Hg hg hf hc hi hn₁ Hi' p₂,
    convert hp₂, },
  { by_cases H : r₂ = 0,
    { simp only [H, zero_lt_one, if_true, eq_self_iff_true, nnreal.coe_eq_zero] },
    { simp only [H, nnreal.coe_eq_zero, if_false],
      exact mul_pos (half_pos hε) (inv_pos.2 (nnreal.coe_pos.2 (zero_lt_iff.2 H))) } }
end

/-!
And also the normed snake dual lemma.
-/
lemma normed_snake_dual {k k' K K' r₁ r₂ : ℝ≥0}
  [hk : fact (1 ≤ k)] [hk' : fact (1 ≤ k')]
  {a : ℕ} {c₀ : ℝ≥0}
  (hN : N.is_bounded_exact k K (a + 1) c₀)
  (hP : P.is_bounded_exact k' K' (a + 1) c₀)
  (hN_adm : N.admissible)
  (hgnorm : ∀ c i (x : N c i), ∥g x∥ ≤ r₁ * ∥x∥)
  (Hg : ∀ (c : ℝ≥0) [fact (c₀ ≤ c)] (i : ℕ) (hi : i ≤ a + 1 + 1) (y : P c i),
    ∃ (x : N c i), g x = y ∧ ∥x∥ ≤ r₂ * ∥y∥)
  (hg : ∀ c i, (f.apply : M c i ⟶ N c i).range = g.apply.ker)
  (hf : ∀ c i, @isometry (M c i) (N c i) _ _ f.apply) :
  M.is_bounded_exact (k * k') (K + r₁ * r₂ * K * K') a c₀ :=
begin
  introsI c hc i hi,
  refine exists_norm_sub_le_mul (admissible_of_isometry hN_adm hf) _,
  intro m,

  obtain ⟨_, _, rfl, rfl, n₁, hn₁⟩ :=
    hN _ ⟨hc.out.trans $ le_mul_of_one_le_left' hk'.out⟩ _ (trans hi a.le_succ) (f m),
  have Hi' : (i - 1) ≤ a + 1 := trans i.pred_le (trans hi a.le_succ),
  obtain ⟨_, _, rfl, rfl, p₂, hp₂⟩ := hP _ hc _ Hi' (g n₁),
  rw ← add_zero (_ * ∥_∥) at ⊢,
  have hn₁₁ :  ∥res (f m) - (N.d (i - 1) i) n₁∥ ≤
    K * ∥(N.d i (i + 1)) (f m)∥ + 0 / 2 * (1 + K' * r₁ * r₂)⁻¹, rwa [zero_div, zero_mul, add_zero],
  obtain F := exist_norm_sub_le_mul_norm_add rfl.le hN_adm hgnorm Hg hg hf hc hi hn₁₁ Hi' p₂,
  by_cases hr : r₂ = 0,
  { subst hr,
    simp at ⊢ F,
    exact F (trans hp₂ (le_add_of_nonneg_right zero_le_one)) },
  { exact F (by { convert hp₂, simp [hr] } ) }
end


import operations
import params

import category_theory.category.basic

open operations
open params

open category_theory

namespace operations_examples

variable [category (bitvec word_len)]

/-!
  # Formalized examples from the spec

  https://cr.yp.to/snuffle/spec.pdf

  Notes:

  - Examples are formalized as `lemma`s instead of `example`
  so they show up in the documentation.
-/

/-- 0xc0a8787e ⊕ 0x9fd1161d = 0x5f796e63 -/
lemma example_xor : bitvec.xor (bitvec.of_nat word_len 0xc0a8787e)
  (bitvec.of_nat word_len 0x9fd1161d) = 0x5f796e63 :=
begin
  rw [word_len, bitvec.of_nat],
  norm_num1,
  refl,
end

/-- 0xc0a8787e + 0x9fd1161d = 0x60798e9b -/
lemma example_mod : 0xc0a8787e MOD 0x9fd1161d = 0x60798e9b :=
begin
  rw [operations.mod, params.max_bitvec, params.mod, word_len],
  dunfold bitvec.of_nat,
  norm_num1,
  refl,
end

/-- 0xc0a8787e <<< 5 = 0x150f0fd8 -/
lemma example_rotl : (rotl (bitvec.of_nat word_len 0xc0a8787e) 5) = 0x150f0fd8 :=
begin
  rw [rotl, bitvec.shl, bitvec.ushr, bitvec.fill_shr, word_len],
  dunfold bitvec.of_nat,
  norm_num1,
  refl,
end

/-! # Inverse examples -/

/-- 0x5f796e63 ⊕ 0x9fd1161d = 0xc0a8787e -/
lemma example_inverse_xor : bitvec.xor (bitvec.of_nat word_len 0x5f796e63)
  (bitvec.of_nat word_len 0x9fd1161d) = 0xc0a8787e :=
begin
  rw word_len,
  dunfold bitvec.of_nat,
  norm_num1,
  refl,
end

/-- 0x150f0fd8 <<<⁻¹ 5 = 0xc0a8787e -/
lemma example_rotl_inv : rotl_inv (bitvec.of_nat word_len 0x150f0fd8) 5 =
  0xc0a8787e :=
begin
  rw [rotl_inv, bitvec.shl, bitvec.ushr, bitvec.fill_shr, word_len],
  dunfold bitvec.of_nat,
  norm_num1,
  refl,
end

end operations_examples


import topology.category.Profinite
import category_theory.filtered

import locally_constant.analysis
import analysis.normed.group.SemiNormedGroup.kernels

/-!

# The functor of locally constant maps

The functor sending a seminormed group `V` and a profinite type `S` to the seminormed group
of locally constant maps from `S` to `V` (with the sup norm).

## Main definition

- `LocallyConstant : SemiNormedGroup ⥤ Profiniteᵒᵖ ⥤ SemiNormedGroup` : the functor.

-/

noncomputable theory

set_option pp.proofs true

namespace SemiNormedGroup
open opposite locally_constant

local attribute [instance] locally_constant.seminormed_add_comm_group locally_constant.pseudo_metric_space

/-- The bifunctor of locally constant maps from profinite spaces to seminormed groups.
    The effects on homs of groups or space are defined in terms of push-forward
    (ie. post-composition) and pull-back (ie. pre-composition) of locally constant maps
    respectively. -/
@[simps]
def LocallyConstant : SemiNormedGroup ⥤ Profiniteᵒᵖ ⥤ SemiNormedGroup :=
{ obj := λ V,
  { obj := λ S, SemiNormedGroup.of $ locally_constant (unop S : Profinite) V,
    map := λ S₁ S₂ f, comap_hom (f.unop) (f.unop.continuous),
    map_id' := λ S, comap_hom_id,
    map_comp' := λ S₁ S₂ S₃ f g, (comap_hom_comp _ _ _ _).symm },
  map := λ V W f,
  { app := λ S, map_hom f,
    naturality' := λ S₁ S₂ g,
    begin
      dsimp, ext,
      simp only [map_hom_apply, comap_hom_apply, category_theory.coe_comp,
        function.comp_app, map_apply, coe_comap, g.unop.continuous]
    end } ,
  map_id' := by { intros, ext, refl },
  map_comp' := by { intros, ext, refl } }

@[simp]
lemma LocallyConstant_map_apply (M : SemiNormedGroup) (X Y : Profinite) (f : X ⟶ Y)
  (g : (LocallyConstant.obj M).obj (op Y)) (x : X) :
  ((LocallyConstant.obj M).map f.op g).to_fun x = g.to_fun (f x) :=
begin
  dsimp [LocallyConstant, comap],
  split_ifs,
  { refl },
  all_goals { exfalso, apply h, continuity }
end

lemma LocallyConstant_obj_map_norm_noninc (V : SemiNormedGroup) (X Y : Profiniteᵒᵖ) (φ : X ⟶ Y) :
  ((LocallyConstant.obj V).map φ).norm_noninc :=
comap_hom_norm_noninc _ _

open category_theory

universe u

-- TODO: Fix the statement below using bounded colimits.
--@[nolint unused_arguments]
--instance {M : SemiNormedGroup.{u}} {J : Type u} [small_category J] [is_filtered J] :
--  limits.preserves_colimits_of_shape J (LocallyConstant.obj M) := by admit

end SemiNormedGroup

#lint- only unused_arguments def_lemma doc_blame


import for_mathlib.exact_seq
import for_mathlib.abelian_category

noncomputable theory

open category_theory
open category_theory.limits

universes v u

variables {𝒜 : Type u} [category.{v} 𝒜] [abelian 𝒜]
variables {A B C : 𝒜} {f : A ⟶ B} {g : B ⟶ C}

namespace category_theory

namespace exact_seq

lemma drop : ∀ {L : list (arrow 𝒜)} (h : exact_seq 𝒜 L) (n : ℕ),
  exact_seq 𝒜 (L.drop n)
| _ nil               0     := nil
| _ nil               (n+1) := nil
| _ (single f)        0     := single f
| _ (single f)        (n+1) := drop nil n
| _ (cons f g h L hL) 0     := cons f g h L hL
| _ (cons f g h L hL) (n+1) := hL.drop n

lemma pair : ∀ {L : list (arrow 𝒜)} (h : exact_seq 𝒜 (f :: g :: L)),
  exact f g
| L (cons _ _ h _ _) := h

end exact_seq

namespace exact

lemma mono_of_eq_zero (h : exact f g) (hf : f = 0) : mono g :=
by rwa [(abelian.tfae_mono A g).out 0 2, ← hf]

lemma eq_zero_of_mono (h : exact f g) (hg : mono g) : f = 0 :=
by rw [← cancel_mono g, h.w, zero_comp]

lemma mono_iff_eq_zero (h : exact f g) : mono g ↔ f = 0 :=
⟨h.eq_zero_of_mono, h.mono_of_eq_zero⟩

lemma epi_of_eq_zero (h : exact f g) (hg : g = 0) : category_theory.epi f :=
by rwa [(abelian.tfae_epi C f).out 0 2, ← hg]

lemma eq_zero_of_epi (h : exact f g) (hf : category_theory.epi f) : g = 0 :=
by rw [← cancel_epi f, h.w, comp_zero]

lemma epi_iff_eq_zero (h : exact f g) : category_theory.epi f ↔ g = 0 :=
⟨h.eq_zero_of_epi, h.epi_of_eq_zero⟩

lemma mono_of_is_zero (h : exact f g) (hA : is_zero A) : mono g :=
by { rw h.mono_iff_eq_zero, exact hA.eq_of_src f _ }

lemma epi_of_is_zero (h : exact f g) (hA : is_zero C) : category_theory.epi f :=
by { rw h.epi_iff_eq_zero, exact hA.eq_of_tgt g _ }

lemma is_zero_of_eq_zero_eq_zero (h : exact f g) (hf : f = 0) (hg : g = 0) : is_zero B :=
is_zero_of_exact_zero_zero' _ _ h hf hg

lemma is_zero_of_is_zero_is_zero (h : exact f g) (hA : is_zero A) (hC : is_zero C) : is_zero B :=
is_zero_of_exact_is_zero_is_zero _ _ h hA hC

protected lemma exact_seq (h : exact f g) : exact_seq 𝒜 [f, g] :=
(exact_iff_exact_seq _ _).mp h

lemma cons (h : exact f g) {L : list (arrow 𝒜)} (hL : exact_seq 𝒜 (g :: L)) :
  exact_seq 𝒜 (f :: g :: L) :=
exact_seq.cons f g h L hL

end exact

end category_theory


import data.fix.parser.basic

universes u

namespace hidden

universes u_1 u_2 u_3

set_option trace.app_builder true
set_option pp.universes true

qpf list_F'' (α β : Type)
| cons : ℤ → (ℕ → α) → (list ℕ → α) → (ℤ → β) → list_F''
| a : α → list_F''
| b : β → list_F''
| nil : list_F''
-- #exit
-- @[derive mvqpf]
qpf list_F (α : Type)
| nil : list_F
| cons : ℤ → α → list_F

-- #exit
-- -- #print hidden.list_F.head_t
-- #print prefix hidden.list_F
-- #print hidden.list_F.child_t
-- -- #print hidden.list_F.pfunctor

-- -- #test list_F.internal_eq
-- -- #test @list_F.map

-- example : ∀ (α : Type), list_F.internal (typevec.of_ind (typevec.ind.cons α typevec.ind.nil)) = list_F α :=
-- list_F.internal_eq

-- example : Π (α β : typevec 1), α ⟹ β → list_F.internal α → list_F.internal β :=
-- list_F.internal.map

-- -- #test hidden.list_F.internal.map._equation_0
-- -- #test hidden.list_F.internal.map._equation_1

-- example : ∀ (α α' : Type) (f0 : α → α'),
--   list_F.internal.map (typevec.of_ind (typevec.ind.cons α typevec.ind.nil))
--       (typevec.of_ind (typevec.ind.cons α' typevec.ind.nil))
--       (typevec.append_fun typevec.nil_fun f0)
--       _ =
--     list_F.nil α' :=
-- list_F.internal.map._equation_0

-- example : ∀ (α α' : Type) (f0 : α → α') (a : ℤ) (a_1 : α),
--   list_F.internal.map (typevec.of_ind (typevec.ind.cons α typevec.ind.nil))
--       (typevec.of_ind (typevec.ind.cons α' typevec.ind.nil))
--       (typevec.append_fun typevec.nil_fun f0)
--       _ =
--     list_F.cons a (f0 a_1) :=
-- list_F.internal.map._equation_1

-- @[derive mvqpf]

-- @[user_command]
-- meta def my_cmd (_ : interactive.parse (lean.parser.tk "my_cmd")) : lean.parser unit :=
-- do lean.parser.with_input lean.parser.command_like
-- "inductive list_F (a : Type)
-- | nil : list_F",
--    pure ().

-- my_cmd

-- #check @list_F.no_confusion

-- -- #print hidden.list_F'.head_t
-- -- #print hidden.list_F'.child_t.α
-- -- #print hidden.list_F'.child_t.β
-- -- #print hidden.list_F'.child_t
-- -- #print hidden.list_F'.pfunctor

-- -- #test list_F'.internal_eq
-- -- #test @list_F'.map

-- example : ∀ (α β : Type),
--   list_F'.internal (typevec.of_ind (typevec.ind.cons α (typevec.ind.cons β typevec.ind.nil))) = list_F' α β :=
-- list_F'.internal_eq

-- example : Π (α β : typevec 2), α ⟹ β → list_F'.internal α → list_F'.internal β :=
-- list_F'.internal.map

-- -- #test hidden.list_F'.internal.map._equation_0
-- -- #test hidden.list_F'.internal.map._equation_1

-- example : ∀ (α β α' β' : Type) (f0 : α → α') (f1 : β → β'),
--   list_F'.internal.map (typevec.of_ind (typevec.ind.cons α (typevec.ind.cons β typevec.ind.nil)))
--       (typevec.of_ind (typevec.ind.cons α' (typevec.ind.cons β' typevec.ind.nil)))
--       (typevec.append_fun (typevec.append_fun typevec.nil_fun f1) f0)
--       _ =
--     list_F'.nil α' β' :=
-- list_F'.internal.map._equation_0

-- example : ∀ (α β α' β' : Type) (f0 : α → α') (f1 : β → β') (a : α) (a_1 : β),
--   list_F'.internal.map (typevec.of_ind (typevec.ind.cons α (typevec.ind.cons β typevec.ind.nil)))
--       (typevec.of_ind (typevec.ind.cons α' (typevec.ind.cons β' typevec.ind.nil)))
--       (typevec.append_fun (typevec.append_fun typevec.nil_fun f1) f0)
--       _ =
--     list_F'.cons (f0 a) (f1 a_1) :=
-- list_F'.internal.map._equation_1
set_option trace.app_builder true
set_option pp.universes true

-- @[derive mvqpf]
qpf list_F''_ (α β γ : Type u)
| nil : (β → γ) → list_F''_
| cons : (α → β) → list_F''_

-- #exit
-- #print hidden.list_F''.head_t
-- #print hidden.list_F''.child_t.γ
-- #print hidden.list_F''.child_t
-- #print hidden.list_F''.pfunctor

-- #check list_F''.internal_eq
-- #check @list_F''.map

-- example : ∀ (α : Type*) (β : Type*) (γ : Type*),
--     list_F''.internal α β (typevec.of_ind (typevec.ind.cons γ typevec.ind.nil)) = list_F'' α β γ :=
-- list_F''.internal_eq

-- example : Π (α : Type*) (β : Type*) (α_1 β_1 : typevec 1),
--     α_1 ⟹ β_1 → list_F''.internal α β α_1 → list_F''.internal α β β_1 :=
-- @list_F''.internal.map

-- #test hidden.list_F''.internal.map._equation_0
-- #test hidden.list_F''.internal.map._equation_1

-- #check list_F''.internal.map

-- example : ∀ (α : Type u_1) (β : Type u_1) (γ γ' : Type u_1) (f2 : γ → γ') (a : β → γ),
--   list_F''.internal.map α β (typevec.of_ind (typevec.ind.cons γ typevec.ind.nil))
--       (typevec.of_ind (typevec.ind.cons γ' typevec.ind.nil))
--       (typevec.append_fun typevec.nil_fun f2)
--       _ =
--     list_F''.nil α (λ (a_1 : β), f2 (a a_1)) :=
-- list_F''.internal.map._equation_0

-- example : ∀ (α : Type u_1) (β : Type u_1) (γ γ' : Type u_1) (f2 : γ → γ') (a : α → β),
--   list_F''.internal.map α β (typevec.of_ind (typevec.ind.cons γ typevec.ind.nil))
--       (typevec.of_ind (typevec.ind.cons γ' typevec.ind.nil))
--       (typevec.append_fun typevec.nil_fun f2)
--       _ =
--     list_F''.cons γ' (λ (a_1 : α), a a_1) :=
-- list_F''.internal.map._equation_1

-- @[derive mvqpf]
qpf list_F''' (α β γ : Type u)
| nil : list_F'''
| cons : (γ → β) → list_F'''

-- #check hidden.list_F'''.pfunctor.cons

-- #exit
-- #print hidden.list_F'''.head_t
-- #print hidden.list_F'''.child_t.α
-- #print hidden.list_F'''.child_t.β
-- #print hidden.list_F'''.child_t
-- #print hidden.list_F'''.pfunctor

-- #check list_F'''.internal_eq
-- #check @list_F'''.map

-- example : ∀ (α β γ : Type*),
--     list_F'''.internal γ (typevec.of_ind (typevec.ind.cons α (typevec.ind.cons β typevec.ind.nil))) =
--       list_F''' α β γ :=
-- list_F'''.internal_eq

-- example : Π (γ : Type*) (α β : typevec 2), α ⟹ β → list_F'''.internal γ α → list_F'''.internal γ β :=
-- @list_F'''.internal.map

-- -- #test hidden.list_F'''.internal.map._equation_0
-- -- #test hidden.list_F'''.internal.map._equation_1

-- example : ∀ (α β γ α' β' : Type u) (f0 : α → α') (f1 : β → β'),
--   list_F'''.internal.map γ (typevec.of_ind (typevec.ind.cons α (typevec.ind.cons β typevec.ind.nil)))
--       (typevec.of_ind (typevec.ind.cons α' (typevec.ind.cons β' typevec.ind.nil)))
--       (typevec.append_fun (typevec.append_fun typevec.nil_fun f1) f0)
--       _ = --(list_F'''.nil α β γ) =
--     list_F'''.nil α' β' γ :=
-- list_F'''.internal.map._equation_0

-- example : ∀ (α β γ α' β' : Type u) (f0 : α → α') (f1 : β → β') (a : γ → β),
--   list_F'''.internal.map γ (typevec.of_ind (typevec.ind.cons α (typevec.ind.cons β typevec.ind.nil)))
--       (typevec.of_ind (typevec.ind.cons α' (typevec.ind.cons β' typevec.ind.nil)))
--       (typevec.append_fun (typevec.append_fun typevec.nil_fun f1) f0)
--       ( _ ) =
--     list_F'''.cons α' (λ (a_1 : γ), f1 (a a_1)) :=
-- list_F'''.internal.map._equation_1

-- @[derive mvqpf]
qpf list_F'''' (α β γ : Type u)
| nil : (β → γ) → (γ → α) → list_F''''
| cons : (α → β) → list_F''''

-- #print prefix hidden.list_F''''
-- #check hidden.list_F''''.pfunctor.cons

-- #print hidden.list_F''''.head_t
-- #print hidden.list_F''''.child_t
-- #print hidden.list_F''''.pfunctor

-- #check @list_F''''.internal_eq
-- #check @list_F''''.internal.map

-- example : ∀ (α : Type*) (β : Type*) (γ : Type*),
--     list_F''''.internal α β γ (typevec.of_ind typevec.ind.nil) = list_F'''' α β γ :=
-- @list_F''''.internal_eq

example : Π (α : Type*) (β : Type*) (γ : Type*) (α_1 β_1 : typevec 0),
    α_1 ⟹ β_1 → list_F''''.internal α β γ α_1 → list_F''''.internal α β γ β_1 :=
@list_F''''.internal.map

-- #test hidden.list_F''''.internal.map._equation_0

example : ∀ (α : Type u_1) (β : Type u_1) (γ : Type u_1) (a : β → γ) (a_1 : γ → α),
  list_F''''.internal.map α β γ ⦃ ⦄ ⦃ ⦄ typevec.nil_fun
      _ =
    list_F''''.nil (λ (a_1 : β), a a_1) (λ (a : γ), a_1 a) :=
list_F''''.internal.map._equation_0

example : ∀ (α : Type u_1) (β : Type u_1) (γ : Type u_1) (a : α → β),
  list_F''''.internal.map α β γ (⦃ ⦄) ( ⦃ ⦄ ) typevec.nil_fun
      _ =
    list_F''''.cons γ (λ (a_1 : α), a a_1) :=
list_F''''.internal.map._equation_1

-- data list
-- | nil : list
-- | cons : ℤ → list → list

end hidden


/-
Copyright (c) 2016 Leonardo de Moura. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import data.set.lattice

/-!
# Functoriality of `set`

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

This file defines the functor structure of `set`.
-/

universes u

open function

namespace set
variables {α β : Type u} {s : set α} {f : α → set β} {g : set (α → β)}

instance : monad.{u} set :=
{ pure       := λ α a, {a},
  bind       := λ α β s f, ⋃ i ∈ s, f i,
  seq        := λ α β, set.seq,
  map        := λ α β, set.image }

@[simp] lemma bind_def : s >>= f = ⋃ i ∈ s, f i := rfl
@[simp] lemma fmap_eq_image (f : α → β) : f <$> s = f '' s := rfl
@[simp] lemma seq_eq_set_seq (s : set (α → β)) (t : set α) : s <*> t = s.seq t := rfl
@[simp] lemma pure_def (a : α) : (pure a : set α) = {a} := rfl

/-- `set.image2` in terms of monadic operations. Note that this can't be taken as the definition
because of the lack of universe polymorphism. -/
lemma image2_def {α β γ : Type*} (f : α → β → γ) (s : set α) (t : set β) :
  image2 f s t = f <$> s <*> t :=
by { ext, simp }

instance : is_lawful_monad set :=
{ id_map                := λ α, image_id,
  comp_map              := λ α β γ f g s, image_comp _ _ _,
  pure_bind             := λ α β, bUnion_singleton,
  bind_assoc            := λ α β γ s f g, by simp only [bind_def, bUnion_Union],
  bind_pure_comp_eq_map := λ α β f s, (image_eq_Union _ _).symm,
  bind_map_eq_seq       := λ α β s t, seq_def.symm }

instance : is_comm_applicative (set : Type u → Type u) :=
⟨ λ α β s t, prod_image_seq_comm s t ⟩

instance : alternative set :=
{ orelse := λ α, (∪),
  failure := λ α, ∅,
  .. set.monad }

end set


/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.monoidal.braided
import category_theory.functor.reflects_isomorphisms

/-!
# Half braidings and the Drinfeld center of a monoidal category

We define `center C` to be pairs `⟨X, b⟩`, where `X : C` and `b` is a half-braiding on `X`.

We show that `center C` is braided monoidal,
and provide the monoidal functor `center.forget` from `center C` back to `C`.

## Future work

Verifying the various axioms here is done by tedious rewriting.
Using the `slice` tactic may make the proofs marginally more readable.

More exciting, however, would be to make possible one of the following options:
1. Integration with homotopy.io / globular to give "picture proofs".
2. The monoidal coherence theorem, so we can ignore associators
   (after which most of these proofs are trivial;
   I'm unsure if the monoidal coherence theorem is even usable in dependent type theory).
3. Automating these proofs using `rewrite_search` or some relative.

-/

open category_theory
open category_theory.monoidal_category

universes v v₁ v₂ v₃ u u₁ u₂ u₃
noncomputable theory

namespace category_theory

variables {C : Type u₁} [category.{v₁} C] [monoidal_category C]

/--
A half-braiding on `X : C` is a family of isomorphisms `X ⊗ U ≅ U ⊗ X`,
monoidally natural in `U : C`.

Thinking of `C` as a 2-category with a single `0`-morphism, these are the same as natural
transformations (in the pseudo- sense) of the identity 2-functor on `C`, which send the unique
`0`-morphism to `X`.
-/
@[nolint has_inhabited_instance]
structure half_braiding (X : C) :=
(β : Π U, X ⊗ U ≅ U ⊗ X)
(monoidal' : ∀ U U', (β (U ⊗ U')).hom =
  (α_ _ _ _).inv ≫ ((β U).hom ⊗ 𝟙 U') ≫ (α_ _ _ _).hom ≫ (𝟙 U ⊗ (β U').hom) ≫ (α_ _ _ _).inv
  . obviously)
(naturality' : ∀ {U U'} (f : U ⟶ U'), (𝟙 X ⊗ f) ≫ (β U').hom = (β U).hom ≫ (f ⊗ 𝟙 X) . obviously)

restate_axiom half_braiding.monoidal'
attribute [reassoc, simp] half_braiding.monoidal -- the reassoc lemma is redundant as a simp lemma
restate_axiom half_braiding.naturality'
attribute [simp, reassoc] half_braiding.naturality

variables (C)
/--
The Drinfeld center of a monoidal category `C` has as objects pairs `⟨X, b⟩`, where `X : C`
and `b` is a half-braiding on `X`.
-/
@[nolint has_inhabited_instance]
def center := Σ X : C, half_braiding X

namespace center

variables {C}

/-- A morphism in the Drinfeld center of `C`. -/
@[ext, nolint has_inhabited_instance]
structure hom (X Y : center C) :=
(f : X.1 ⟶ Y.1)
(comm' : ∀ U, (f ⊗ 𝟙 U) ≫ (Y.2.β U).hom = (X.2.β U).hom ≫ (𝟙 U ⊗ f) . obviously)

restate_axiom hom.comm'
attribute [simp, reassoc] hom.comm

instance : category (center C) :=
{ hom := hom,
  id := λ X, { f := 𝟙 X.1, },
  comp := λ X Y Z f g, { f := f.f ≫ g.f, }, }

@[simp] lemma id_f (X : center C) : hom.f (𝟙 X) = 𝟙 X.1 := rfl
@[simp] lemma comp_f {X Y Z : center C} (f : X ⟶ Y) (g : Y ⟶ Z) : (f ≫ g).f = f.f ≫ g.f := rfl

@[ext]
lemma ext {X Y : center C} (f g : X ⟶ Y) (w : f.f = g.f) : f = g :=
by { cases f, cases g, congr, exact w, }

/--
Construct an isomorphism in the Drinfeld center from
a morphism whose underlying morphism is an isomorphism.
-/
@[simps]
def iso_mk {X Y : center C} (f : X ⟶ Y) [is_iso f.f] : X ≅ Y :=
{ hom := f,
  inv := ⟨inv f.f, λ U, by simp [←cancel_epi (f.f ⊗ 𝟙 U), ←comp_tensor_id_assoc, ←id_tensor_comp]⟩ }

instance is_iso_of_f_is_iso {X Y : center C} (f : X ⟶ Y) [is_iso f.f] : is_iso f :=
begin
  change is_iso (iso_mk f).hom,
  apply_instance,
end

/-- Auxiliary definition for the `monoidal_category` instance on `center C`. -/
@[simps]
def tensor_obj (X Y : center C) : center C :=
⟨X.1 ⊗ Y.1,
  { β := λ U, α_ _ _ _ ≪≫ (iso.refl X.1 ⊗ Y.2.β U) ≪≫ (α_ _ _ _).symm
      ≪≫ (X.2.β U ⊗ iso.refl Y.1) ≪≫ α_ _ _ _,
    monoidal' := λ U U',
    begin
      dsimp,
      simp only [comp_tensor_id, id_tensor_comp, category.assoc, half_braiding.monoidal],
      rw [pentagon_assoc, pentagon_inv_assoc, iso.eq_inv_comp, ←pentagon_assoc,
        ←id_tensor_comp_assoc, iso.hom_inv_id, tensor_id, category.id_comp,
        ←associator_naturality_assoc, cancel_epi, cancel_epi,
        ←associator_inv_naturality_assoc (X.2.β U).hom,
        associator_inv_naturality_assoc _ _ (Y.2.β U').hom, tensor_id, tensor_id,
        id_tensor_comp_tensor_id_assoc, associator_naturality_assoc (X.2.β U).hom,
        ←associator_naturality_assoc _ _ (Y.2.β U').hom, tensor_id, tensor_id,
        tensor_id_comp_id_tensor_assoc, ←id_tensor_comp_tensor_id, tensor_id, category.comp_id,
        ←is_iso.inv_comp_eq, inv_tensor, is_iso.inv_id, is_iso.iso.inv_inv, pentagon_assoc,
        iso.hom_inv_id_assoc, cancel_epi, cancel_epi, ←is_iso.inv_comp_eq, is_iso.iso.inv_hom,
        ←pentagon_inv_assoc, ←comp_tensor_id_assoc, iso.inv_hom_id, tensor_id, category.id_comp,
        ←associator_inv_naturality_assoc, cancel_epi, cancel_epi, ←is_iso.inv_comp_eq, inv_tensor,
        is_iso.iso.inv_hom, is_iso.inv_id, pentagon_inv_assoc, iso.inv_hom_id, category.comp_id],
    end,
    naturality' := λ U U' f,
    begin
      dsimp,
      rw [category.assoc, category.assoc, category.assoc, category.assoc,
        id_tensor_associator_naturality_assoc, ←id_tensor_comp_assoc, half_braiding.naturality,
        id_tensor_comp_assoc, associator_inv_naturality_assoc, ←comp_tensor_id_assoc,
        half_braiding.naturality, comp_tensor_id_assoc, associator_naturality, ←tensor_id],
    end, }⟩

/-- Auxiliary definition for the `monoidal_category` instance on `center C`. -/
@[simps]
def tensor_hom {X₁ Y₁ X₂ Y₂ : center C} (f : X₁ ⟶ Y₁) (g : X₂ ⟶ Y₂) :
  tensor_obj X₁ X₂ ⟶ tensor_obj Y₁ Y₂ :=
{ f := f.f ⊗ g.f,
  comm' := λ U, begin
    dsimp,
    rw [category.assoc, category.assoc, category.assoc, category.assoc,
      associator_naturality_assoc, ←tensor_id_comp_id_tensor, category.assoc,
      ←id_tensor_comp_assoc, g.comm, id_tensor_comp_assoc, tensor_id_comp_id_tensor_assoc,
      ←id_tensor_comp_tensor_id, category.assoc, associator_inv_naturality_assoc,
      id_tensor_associator_inv_naturality_assoc, tensor_id,
      id_tensor_comp_tensor_id_assoc, ←tensor_id_comp_id_tensor g.f, category.assoc,
      ←comp_tensor_id_assoc, f.comm, comp_tensor_id_assoc, id_tensor_associator_naturality,
      associator_naturality_assoc, ←id_tensor_comp, tensor_id_comp_id_tensor],
  end }

/-- Auxiliary definition for the `monoidal_category` instance on `center C`. -/
@[simps]
def tensor_unit : center C :=
⟨𝟙_ C,
  { β := λ U, (λ_ U) ≪≫ (ρ_ U).symm,
    monoidal' := λ U U', by simp,
    naturality' := λ U U' f, begin
      dsimp,
      rw [left_unitor_naturality_assoc, right_unitor_inv_naturality, category.assoc],
    end, }⟩

/-- Auxiliary definition for the `monoidal_category` instance on `center C`. -/
def associator (X Y Z : center C) : tensor_obj (tensor_obj X Y) Z ≅ tensor_obj X (tensor_obj Y Z) :=
iso_mk ⟨(α_ X.1 Y.1 Z.1).hom, λ U, begin
  dsimp,
  simp only [category.assoc, comp_tensor_id, id_tensor_comp],
  rw [pentagon, pentagon_assoc, ←associator_naturality_assoc (𝟙 X.1) (𝟙 Y.1), tensor_id, cancel_epi,
    cancel_epi, iso.eq_inv_comp, ←pentagon_assoc, ←id_tensor_comp_assoc, iso.hom_inv_id, tensor_id,
    category.id_comp, ←associator_naturality_assoc, cancel_epi, cancel_epi, ←is_iso.inv_comp_eq,
    inv_tensor, is_iso.inv_id, is_iso.iso.inv_inv, pentagon_assoc, iso.hom_inv_id_assoc, ←tensor_id,
    ←associator_naturality_assoc],
end⟩

/-- Auxiliary definition for the `monoidal_category` instance on `center C`. -/
def left_unitor (X : center C) : tensor_obj tensor_unit X ≅ X :=
iso_mk ⟨(λ_ X.1).hom, λ U, begin
  dsimp,
  simp only [category.comp_id, category.assoc, tensor_inv_hom_id, comp_tensor_id,
    tensor_id_comp_id_tensor, triangle_assoc_comp_right_inv],
  rw [←left_unitor_tensor, left_unitor_naturality, left_unitor_tensor'_assoc],
end⟩

/-- Auxiliary definition for the `monoidal_category` instance on `center C`. -/
def right_unitor (X : center C) : tensor_obj X tensor_unit ≅ X :=
iso_mk ⟨(ρ_ X.1).hom, λ U, begin
  dsimp,
  simp only [tensor_id_comp_id_tensor_assoc, triangle_assoc, id_tensor_comp, category.assoc],
  rw [←tensor_id_comp_id_tensor_assoc (ρ_ U).inv, cancel_epi, ←right_unitor_tensor_inv_assoc,
    ←right_unitor_inv_naturality_assoc],
  simp,
end⟩

section
local attribute [simp] associator_naturality left_unitor_naturality right_unitor_naturality
  pentagon
local attribute [simp] center.associator center.left_unitor center.right_unitor

instance : monoidal_category (center C) :=
{ tensor_obj := λ X Y, tensor_obj X Y,
  tensor_hom := λ X₁ Y₁ X₂ Y₂ f g, tensor_hom f g,
  tensor_unit := tensor_unit,
  associator := associator,
  left_unitor := left_unitor,
  right_unitor := right_unitor, }

@[simp] lemma tensor_fst (X Y : center C) : (X ⊗ Y).1 = X.1 ⊗ Y.1 := rfl

@[simp] lemma tensor_β (X Y : center C) (U : C) :
  (X ⊗ Y).2.β U =
    α_ _ _ _ ≪≫ (iso.refl X.1 ⊗ Y.2.β U) ≪≫ (α_ _ _ _).symm
      ≪≫ (X.2.β U ⊗ iso.refl Y.1) ≪≫ α_ _ _ _ :=
rfl
@[simp]

@[simp] lemma tensor_unit_β (U : C) : (𝟙_ (center C)).2.β U = (λ_ U) ≪≫ (ρ_ U).symm := rfl

@[simp] lemma associator_hom_f (X Y Z : center C) : hom.f (α_ X Y Z).hom = (α_ X.1 Y.1 Z.1).hom :=
rfl

@[simp] lemma associator_inv_f (X Y Z : center C) : hom.f (α_ X Y Z).inv = (α_ X.1 Y.1 Z.1).inv :=
by { ext, rw [←associator_hom_f, ←comp_f, iso.hom_inv_id], refl, }

@[simp] lemma left_unitor_hom_f (X : center C) : hom.f (λ_ X).hom = (λ_ X.1).hom :=
rfl

@[simp] lemma left_unitor_inv_f (X : center C) : hom.f (λ_ X).inv = (λ_ X.1).inv :=
by { ext, rw [←left_unitor_hom_f, ←comp_f, iso.hom_inv_id], refl, }

@[simp] lemma right_unitor_hom_f (X : center C) : hom.f (ρ_ X).hom = (ρ_ X.1).hom :=
rfl

@[simp] lemma right_unitor_inv_f (X : center C) : hom.f (ρ_ X).inv = (ρ_ X.1).inv :=
by { ext, rw [←right_unitor_hom_f, ←comp_f, iso.hom_inv_id], refl, }

end

section
variables (C)

/-- The forgetful monoidal functor from the Drinfeld center to the original category. -/
@[simps]
def forget : monoidal_functor (center C) C :=
{ obj := λ X, X.1,
  map := λ X Y f, f.f,
  ε := 𝟙 (𝟙_ C),
  μ := λ X Y, 𝟙 (X.1 ⊗ Y.1), }

instance : reflects_isomorphisms (forget C).to_functor :=
{ reflects := λ A B f i, by { dsimp at i, resetI, change is_iso (iso_mk f).hom, apply_instance, } }

end

/-- Auxiliary definition for the `braided_category` instance on `center C`. -/
@[simps]
def braiding (X Y : center C) : X ⊗ Y ≅ Y ⊗ X :=
iso_mk ⟨(X.2.β Y.1).hom, λ U, begin
  dsimp,
  simp only [category.assoc],
  rw [←is_iso.inv_comp_eq, is_iso.iso.inv_hom, ←half_braiding.monoidal_assoc,
    ←half_braiding.naturality_assoc, half_braiding.monoidal],
  simp,
end⟩

instance braided_category_center : braided_category (center C) :=
{ braiding := braiding,
  braiding_naturality' := λ X Y X' Y' f g, begin
    ext,
    dsimp,
    rw [←tensor_id_comp_id_tensor, category.assoc, half_braiding.naturality, f.comm_assoc,
      id_tensor_comp_tensor_id],
  end, } -- `obviously` handles the hexagon axioms

section
variables [braided_category C]

open braided_category

/-- Auxiliary construction for `of_braided`. -/
@[simps]
def of_braided_obj (X : C) : center C :=
⟨X, { β := λ Y, β_ X Y,
  monoidal' := λ U U', begin
    rw [iso.eq_inv_comp, ←category.assoc, ←category.assoc, iso.eq_comp_inv,
      category.assoc, category.assoc],
    exact hexagon_forward X U U',
  end }⟩

variables (C)

/--
The functor lifting a braided category to its center, using the braiding as the half-braiding.
-/
@[simps]
def of_braided : monoidal_functor C (center C) :=
{ obj := of_braided_obj,
  map := λ X X' f,
  { f := f,
    comm' := λ U, braiding_naturality _ _, },
  ε :=
  { f := 𝟙 _,
    comm' := λ U, begin
      dsimp,
      rw [tensor_id, category.id_comp, tensor_id, category.comp_id, ←braiding_right_unitor,
        category.assoc, iso.hom_inv_id, category.comp_id],
    end, },
  μ := λ X Y,
  { f := 𝟙 _,
    comm' := λ U, begin
      dsimp,
      rw [tensor_id, tensor_id, category.id_comp, category.comp_id,
        ←iso.inv_comp_eq, ←category.assoc, ←category.assoc, ←iso.comp_inv_eq,
        category.assoc, hexagon_reverse, category.assoc],
    end, }, }

end

end center

end category_theory