/-
Copyright (c) 2018 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Mario Carneiro, Simon Hudon
-/
import data.fin.fin2
import logic.function.basic
import tactic.basic

/-!

# Tuples of types, and their categorical structure.

## Features

* `typevec n` - n-tuples of types
* `α ⟹ β`    - n-tuples of maps
* `f ⊚ g`     - composition

Also, support functions for operating with n-tuples of types, such as:

* `append1 α β`    - append type `β` to n-tuple `α` to obtain an (n+1)-tuple
* `drop α`         - drops the last element of an (n+1)-tuple
* `last α`         - returns the last element of an (n+1)-tuple
* `append_fun f g` - appends a function g to an n-tuple of functions
* `drop_fun f`     - drops the last function from an n+1-tuple
* `last_fun f`     - returns the last function of a tuple.

Since e.g. `append1 α.drop α.last` is propositionally equal to `α` but not definitionally equal
to it, we need support functions and lemmas to mediate between constructions.
-/

universes u v w

/--
n-tuples of types, as a category
-/
def typevec (n : ℕ) := fin2 n → Type*

instance {n} : inhabited (typevec.{u} n) := ⟨ λ _, punit ⟩

namespace typevec

variable {n : ℕ}

/-- arrow in the category of `typevec` -/
def arrow (α β : typevec n) := Π i : fin2 n, α i → β i

localized "infixl ` ⟹ `:40 := typevec.arrow" in mvfunctor

instance arrow.inhabited (α β : typevec n) [Π i, inhabited (β i)] : inhabited (α ⟹ β) :=
⟨ λ _ _, default _ ⟩

/-- identity of arrow composition -/
def id {α : typevec n} : α ⟹ α := λ i x, x

/-- arrow composition in the category of `typevec` -/
def comp {α β γ : typevec n} (g : β ⟹ γ) (f : α ⟹ β) : α ⟹ γ :=
λ i x, g i (f i x)

localized "infixr ` ⊚ `:80 := typevec.comp" in mvfunctor -- type as \oo

@[simp] theorem id_comp {α β : typevec n} (f : α ⟹ β) : id ⊚ f = f :=
rfl

@[simp] theorem comp_id {α β : typevec n} (f : α ⟹ β) : f ⊚ id = f :=
rfl

theorem comp_assoc {α β γ δ : typevec n} (h : γ ⟹ δ) (g : β ⟹ γ) (f : α ⟹ β) :
  (h ⊚ g) ⊚ f = h ⊚ g ⊚ f := rfl

/--
Support for extending a typevec by one element.
-/
def append1 (α : typevec n) (β : Type*) : typevec (n+1)
| (fin2.fs i) := α i
| fin2.fz      := β

infixl ` ::: `:67 := append1

/-- retain only a `n-length` prefix of the argument -/
def drop (α : typevec.{u} (n+1)) : typevec n := λ i, α i.fs

/-- take the last value of a `(n+1)-length` vector -/
def last (α : typevec.{u} (n+1)) : Type* := α fin2.fz

instance last.inhabited (α : typevec (n+1)) [inhabited (α fin2.fz)] : inhabited (last α) :=
⟨ (default (α fin2.fz) : α fin2.fz) ⟩

theorem drop_append1 {α : typevec n} {β : Type*} {i : fin2 n} : drop (append1 α β) i = α i := rfl

theorem drop_append1' {α : typevec n} {β : Type*} : drop (append1 α β) = α :=
by ext; apply drop_append1

theorem last_append1 {α : typevec n} {β : Type*} : last (append1 α β) = β := rfl

@[simp]
theorem append1_drop_last (α : typevec (n+1)) : append1 (drop α) (last α) = α :=
funext $ λ i, by cases i; refl

/-- cases on `(n+1)-length` vectors -/
@[elab_as_eliminator] def append1_cases
  {C : typevec (n+1) → Sort u} (H : ∀ α β, C (append1 α β)) (γ) : C γ :=
by rw [← @append1_drop_last _ γ]; apply H

@[simp] theorem append1_cases_append1 {C : typevec (n+1) → Sort u}
  (H : ∀ α β, C (append1 α β)) (α β) :
  @append1_cases _ C H (append1 α β) = H α β := rfl

/-- append an arrow and a function for arbitrary source and target
type vectors -/
def split_fun {α α' : typevec (n+1)}
  (f : drop α ⟹ drop α') (g : last α → last α') : α ⟹ α'
| (fin2.fs i) := f i
| fin2.fz      := g

/-- append an arrow and a function as well as their respective source
and target types / typevecs -/
def append_fun {α α' : typevec n} {β β' : Type*}
  (f : α ⟹ α') (g : β → β') : append1 α β ⟹ append1 α' β' := split_fun f g

infixl ` ::: ` := append_fun

/-- split off the prefix of an arrow -/
def drop_fun {α β : typevec (n+1)} (f : α ⟹ β) : drop α ⟹ drop β :=
λ i, f i.fs

/-- split off the last function of an arrow -/
def last_fun {α β : typevec (n+1)} (f : α ⟹ β) : last α → last β :=
f fin2.fz

/-- arrow in the category of `0-length` vectors -/
def nil_fun {α : typevec 0} {β : typevec 0} : α ⟹ β :=
λ i, fin2.elim0 i

theorem eq_of_drop_last_eq {α β : typevec (n+1)} {f g : α ⟹ β}
  (h₀ : drop_fun f = drop_fun g) (h₁ : last_fun f = last_fun g) : f = g :=
by replace h₀ := congr_fun h₀;
   ext1 (ieq | ⟨j, ieq⟩); apply_assumption

@[simp]

/-- turn an equality into an arrow -/
def arrow.mp {α β : typevec n} (h : α = β) : α ⟹ β
| i := eq.mp (congr_fun h _)

/-- turn an equality into an arrow, with reverse direction -/
def arrow.mpr {α β : typevec n} (h : α = β) : β ⟹ α
| i := eq.mpr (congr_fun h _)

/-- decompose a vector into its prefix appended with its last element -/
def to_append1_drop_last {α : typevec (n+1)} : α ⟹ drop α ::: last α :=
arrow.mpr (append1_drop_last _)

/-- stitch two bits of a vector back together -/
def from_append1_drop_last {α : typevec (n+1)} : drop α ::: last α ⟹ α :=
arrow.mp (append1_drop_last _)

@[simp] theorem last_fun_split_fun {α α' : typevec (n+1)}
  (f : drop α ⟹ drop α') (g : last α → last α') :
  last_fun (split_fun f g) = g := rfl

@[simp] theorem drop_fun_append_fun {α α' : typevec n} {β β' : Type*} (f : α ⟹ α') (g : β → β') :
  drop_fun (f ::: g) = f := rfl

@[simp] theorem last_fun_append_fun {α α' : typevec n} {β β' : Type*} (f : α ⟹ α') (g : β → β') :
  last_fun (f ::: g) = g := rfl

theorem split_drop_fun_last_fun {α α' : typevec (n+1)} (f : α ⟹ α') :
  split_fun (drop_fun f) (last_fun f) = f :=
eq_of_drop_last_eq rfl rfl

theorem split_fun_inj
  {α α' : typevec (n+1)} {f f' : drop α ⟹ drop α'} {g g' : last α → last α'}
  (H : split_fun f g = split_fun f' g') : f = f' ∧ g = g' :=
by rw [← drop_fun_split_fun f g, H, ← last_fun_split_fun f g, H]; simp

theorem append_fun_inj {α α' : typevec n} {β β' : Type*} {f f' : α ⟹ α'} {g g' : β → β'} :
  f ::: g = f' ::: g' →  f = f' ∧ g = g' :=
split_fun_inj

theorem split_fun_comp {α₀ α₁ α₂ : typevec (n+1)}
    (f₀ : drop α₀ ⟹ drop α₁) (f₁ : drop α₁ ⟹ drop α₂)
    (g₀ : last α₀ → last α₁) (g₁ : last α₁ → last α₂) :
  split_fun (f₁ ⊚ f₀) (g₁ ∘ g₀) = split_fun f₁ g₁ ⊚ split_fun f₀ g₀ :=
eq_of_drop_last_eq rfl rfl

theorem append_fun_comp_split_fun
  {α γ : typevec n} {β δ : Type*} {ε : typevec (n + 1)}
    (f₀ : drop ε ⟹ α) (f₁ : α ⟹ γ)
    (g₀ : last ε → β) (g₁ : β → δ) :
  append_fun f₁ g₁ ⊚ split_fun f₀ g₀ = split_fun (f₁ ⊚ f₀) (g₁ ∘ g₀) :=
(split_fun_comp _ _ _ _).symm

lemma append_fun_comp {α₀ α₁ α₂ : typevec n} {β₀ β₁ β₂ : Type*}
    (f₀ : α₀ ⟹ α₁) (f₁ : α₁ ⟹ α₂) (g₀ : β₀ → β₁) (g₁ : β₁ → β₂) :
  f₁ ⊚ f₀ ::: g₁ ∘ g₀ = (f₁ ::: g₁) ⊚ (f₀ ::: g₀) :=
eq_of_drop_last_eq rfl rfl

lemma append_fun_comp' {α₀ α₁ α₂ : typevec n} {β₀ β₁ β₂ : Type*}
    (f₀ : α₀ ⟹ α₁) (f₁ : α₁ ⟹ α₂) (g₀ : β₀ → β₁) (g₁ : β₁ → β₂) :
  (f₁ ::: g₁) ⊚ (f₀ ::: g₀) = f₁ ⊚ f₀ ::: g₁ ∘ g₀ :=
eq_of_drop_last_eq rfl rfl

lemma nil_fun_comp {α₀ : typevec 0} (f₀ : α₀ ⟹ fin2.elim0) : nil_fun ⊚ f₀ = f₀ :=
funext $ λ x, fin2.elim0 x

theorem append_fun_comp_id {α : typevec n} {β₀ β₁ β₂ : Type*}
    (g₀ : β₀ → β₁) (g₁ : β₁ → β₂) :
  @id _ α ::: g₁ ∘ g₀ = (id ::: g₁) ⊚ (id ::: g₀) :=
eq_of_drop_last_eq rfl rfl

@[simp]
theorem drop_fun_comp {α₀ α₁ α₂ : typevec (n+1)} (f₀ : α₀ ⟹ α₁) (f₁ : α₁ ⟹ α₂) :
  drop_fun (f₁ ⊚ f₀) = drop_fun f₁ ⊚ drop_fun f₀ := rfl

@[simp]
theorem last_fun_comp {α₀ α₁ α₂ : typevec (n+1)} (f₀ : α₀ ⟹ α₁) (f₁ : α₁ ⟹ α₂) :
  last_fun (f₁ ⊚ f₀) = last_fun f₁ ∘ last_fun f₀ := rfl

theorem append_fun_aux {α α' : typevec n} {β β' : Type*}
  (f : α ::: β ⟹ α' ::: β') : drop_fun f ::: last_fun f = f :=
eq_of_drop_last_eq rfl rfl

theorem append_fun_id_id {α : typevec n} {β : Type*} :
  @typevec.id n α ::: @_root_.id β = typevec.id :=
eq_of_drop_last_eq rfl rfl

instance subsingleton0 : subsingleton (typevec 0) :=
⟨ λ a b, funext $ λ a, fin2.elim0 a  ⟩

run_cmd do
  mk_simp_attr `typevec,
  tactic.add_doc_string `simp_attr.typevec
"simp set for the manipulation of typevec and arrow expressions"

local prefix `♯`:0 := cast (by try { simp }; congr' 1; try { simp })

/-- cases distinction for 0-length type vector -/
protected def cases_nil {β : typevec 0 → Sort*} (f : β fin2.elim0) :
  Π v, β v :=
λ v, ♯ f

/-- cases distinction for (n+1)-length type vector -/
protected def cases_cons (n : ℕ) {β : typevec (n+1) → Sort*}
  (f : Π t (v : typevec n), β (v ::: t)) :
  Π v, β v :=
λ v : typevec (n+1), ♯ f v.last v.drop

protected lemma cases_nil_append1 {β : typevec 0 → Sort*} (f : β fin2.elim0) :
  typevec.cases_nil f fin2.elim0 = f := rfl

protected lemma cases_cons_append1 (n : ℕ) {β : typevec (n+1) → Sort*}
      (f : Π t (v : typevec n), β (v ::: t))
      (v : typevec n) (α) :
  typevec.cases_cons n f (v ::: α) = f α v := rfl

/-- cases distinction for an arrow in the category of 0-length type vectors -/
def typevec_cases_nil₃ {β : Π v v' : typevec 0, v ⟹ v' → Sort*}
  (f : β fin2.elim0 fin2.elim0 nil_fun) :
  Π v v' fs, β v v' fs :=
λ v v' fs,
begin
  refine cast _ f; congr' 1; ext; try { intros; casesm fin2 0 }, refl
end

/-- cases distinction for an arrow in the category of (n+1)-length type vectors -/
def typevec_cases_cons₃ (n : ℕ) {β : Π v v' : typevec (n+1), v ⟹ v' → Sort*}
  (F : Π t t' (f : t → t') (v v' : typevec n) (fs : v ⟹ v'), β (v ::: t) (v' ::: t') (fs ::: f)) :
  Π v v' fs, β v v' fs :=
begin
  intros v v',
  rw [←append1_drop_last v, ←append1_drop_last v'],
  intro fs,
  rw [←split_drop_fun_last_fun fs],
  apply F
end

/-- specialized cases distinction for an arrow in the category of 0-length type vectors -/
def typevec_cases_nil₂ {β : fin2.elim0 ⟹ fin2.elim0 → Sort*}
  (f : β nil_fun) :
  Π f, β f :=
begin
  intro g, have : g = nil_fun, ext ⟨ ⟩,
  rw this, exact f
end

/-- specialized cases distinction for an arrow in the category of (n+1)-length type vectors -/
def typevec_cases_cons₂ (n : ℕ) (t t' : Type*) (v v' : typevec (n))
  {β : (v ::: t) ⟹ (v' ::: t') → Sort*} (F : Π (f : t → t') (fs : v ⟹ v'), β (fs ::: f)) :
  Π fs, β fs :=
begin
  intro fs,
  rw [←split_drop_fun_last_fun fs],
  apply F
end

lemma typevec_cases_nil₂_append_fun {β : fin2.elim0 ⟹ fin2.elim0 → Sort*}
  (f : β nil_fun) :
  typevec_cases_nil₂ f nil_fun = f := rfl

lemma typevec_cases_cons₂_append_fun (n : ℕ) (t t' : Type*)
  (v v' : typevec (n)) {β : (v ::: t) ⟹ (v' ::: t') → Sort*}
  (F : Π (f : t → t') (fs : v ⟹ v'), β (fs ::: f)) (f fs) :
  typevec_cases_cons₂ n t t' v v' F (fs ::: f) = F f fs := rfl

/- for lifting predicates and relations -/

/-- `pred_last α p x` predicates `p` of the last element of `x : α.append1 β`. -/
def pred_last (α : typevec n) {β : Type*} (p : β → Prop) : Π ⦃i⦄, (α.append1 β) i → Prop
| (fin2.fs i) := λ x, true
| fin2.fz      := p

/-- `rel_last α r x y` says that `p` the last elements of `x y : α.append1 β` are related by `r` and
all the other elements are equal. -/
def rel_last (α : typevec n) {β γ : Type*} (r : β → γ → Prop) :
  Π ⦃i⦄, (α.append1 β) i → (α.append1 γ) i → Prop
| (fin2.fs i) := eq
| fin2.fz      := r

section liftp'
open nat

/-- `repeat n t` is a `n-length` type vector that contains `n` occurences of `t` -/
def repeat : Π (n : ℕ) (t : Sort*), typevec n
| 0 t := fin2.elim0
| (nat.succ i) t := append1 (repeat i t) t

/-- `prod α β` is the pointwise product of the components of `α` and `β` -/
def prod : Π {n} (α β : typevec.{u} n), typevec n
| 0 α β := fin2.elim0
| (n+1) α β := prod (drop α) (drop β) ::: (last α × last β)

localized "infix ` ⊗ `:45 := typevec.prod" in mvfunctor

/-- `const x α` is an arrow that ignores its source and constructs a `typevec` that
contains nothing but `x` -/
protected def const {β} (x : β) : Π {n} (α : typevec n), α ⟹ repeat _ β
| (succ n) α (fin2.fs i) := const (drop α) _
| (succ n) α fin2.fz := λ _, x

open function (uncurry)

/-- vector of equality on a product of vectors -/
def repeat_eq : Π {n} (α : typevec n), α ⊗ α ⟹ repeat _ Prop
| 0 α := nil_fun
| (succ n) α := repeat_eq (drop α) ::: uncurry eq

lemma const_append1 {β γ} (x : γ) {n} (α : typevec n) :
  typevec.const x (α ::: β) = append_fun (typevec.const x α) (λ _, x) :=
by ext i : 1; cases i; refl

lemma eq_nil_fun {α β : typevec 0} (f : α ⟹ β) : f = nil_fun :=
by ext x; cases x

lemma id_eq_nil_fun {α : typevec 0} : @id _ α = nil_fun :=
by ext x; cases x

lemma const_nil {β} (x : β) (α : typevec 0) : typevec.const x α = nil_fun :=
by ext i : 1; cases i; refl

@[typevec]
lemma repeat_eq_append1 {β} {n} (α : typevec n) :
  repeat_eq (α ::: β) = split_fun (repeat_eq α) (uncurry eq) :=
by induction n; refl

@[typevec]
lemma repeat_eq_nil (α : typevec 0) : repeat_eq α = nil_fun :=
by ext i : 1; cases i; refl

/-- predicate on a type vector to constrain only the last object -/
def pred_last' (α : typevec n) {β : Type*} (p : β → Prop) : α ::: β ⟹ repeat (n+1) Prop :=
split_fun (typevec.const true α) p

/-- predicate on the product of two type vectors to constrain only their last object -/
def rel_last' (α : typevec n) {β : Type*} (p : β → β → Prop) :
  (α ::: β ⊗ α ::: β) ⟹ repeat (n+1) Prop :=
split_fun (repeat_eq α) (uncurry p)

/-- given `F : typevec.{u} (n+1) → Type u`, `curry F : Type u → typevec.{u} → Type u`,
i.e. its first argument can be fed in separately from the rest of the vector of arguments -/
def curry (F : typevec.{u} (n+1) → Type*) (α : Type u) (β : typevec.{u} n) : Type* :=
F (β ::: α)

instance curry.inhabited (F : typevec.{u} (n+1) → Type*) (α : Type u) (β : typevec.{u} n)
  [I : inhabited (F $ β ::: α)]:
  inhabited (curry F α β) := I

/-- arrow to remove one element of a `repeat` vector -/
def drop_repeat (α : Type*) : Π {n}, drop (repeat (succ n) α) ⟹ repeat n α
| (succ n) (fin2.fs i) := drop_repeat i
| (succ n) fin2.fz := _root_.id

/-- projection for a repeat vector -/
def of_repeat {α : Sort*} : Π {n i}, repeat n α i → α
| ._ fin2.fz := _root_.id
| ._ (fin2.fs i) := @of_repeat _ i

lemma const_iff_true {α : typevec n} {i x p} : of_repeat (typevec.const p α i x) ↔ p :=
by induction i; [refl, erw [typevec.const,@i_ih (drop α) x]]

-- variables  {F : typevec.{u} n → Type*} [mvfunctor F]
variables {α β γ : typevec.{u} n}
variables (p : α ⟹ repeat n Prop) (r : α ⊗ α ⟹ repeat n Prop)

/-- left projection of a `prod` vector -/
def prod.fst : Π {n} {α β : typevec.{u} n}, α ⊗ β ⟹ α
| (succ n) α β (fin2.fs i) := @prod.fst _ (drop α) (drop β) i
| (succ n) α β fin2.fz := _root_.prod.fst

/-- right projection of a `prod` vector -/
def prod.snd : Π {n} {α β : typevec.{u} n}, α ⊗ β ⟹ β
| (succ n) α β (fin2.fs i) := @prod.snd _ (drop α) (drop β) i
| (succ n) α β fin2.fz := _root_.prod.snd

/-- introduce a product where both components are the same -/
def prod.diag : Π {n} {α : typevec.{u} n}, α ⟹ α ⊗ α
| (succ n) α (fin2.fs i) x := @prod.diag _ (drop α) _ x
| (succ n) α fin2.fz x := (x,x)

/-- constructor for `prod` -/
def prod.mk : Π {n} {α β : typevec.{u} n} (i : fin2 n), α i → β i → (α ⊗ β) i
| (succ n) α β (fin2.fs i) := prod.mk i
| (succ n) α β fin2.fz := _root_.prod.mk

@[simp]
lemma prod_fst_mk {α β : typevec n} (i : fin2 n) (a : α i) (b : β i) :
  typevec.prod.fst i (prod.mk i a b) = a :=
by induction i; simp [prod.fst, prod.mk, *] at *

@[simp]
lemma prod_snd_mk {α β : typevec n} (i : fin2 n) (a : α i) (b : β i) :
  typevec.prod.snd i (prod.mk i a b) = b :=
by induction i; simp [prod.snd, prod.mk, *] at *

/-- `prod` is functorial -/
protected def prod.map : Π {n} {α α' β β' : typevec.{u} n}, (α ⟹ β) → (α' ⟹ β') → α ⊗ α' ⟹ β ⊗ β'
| (succ n) α α' β β' x y (fin2.fs i) a :=
  @prod.map _ (drop α) (drop α') (drop β) (drop β') (drop_fun x) (drop_fun y) _ a
| (succ n) α α' β β' x y fin2.fz a := (x _ a.1,y _ a.2)

localized "infix ` ⊗' `:45 := typevec.prod.map" in mvfunctor

theorem fst_prod_mk {α α' β β' : typevec n} (f : α ⟹ β) (g : α' ⟹ β') :
  typevec.prod.fst ⊚ (f ⊗' g) = f ⊚ typevec.prod.fst :=
by ext i; induction i; [refl, apply i_ih]

theorem snd_prod_mk {α α' β β' : typevec n} (f : α ⟹ β) (g : α' ⟹ β') :
  typevec.prod.snd ⊚ (f ⊗' g) = g ⊚ typevec.prod.snd :=
by ext i; induction i; [refl, apply i_ih]

theorem fst_diag {α : typevec n} : typevec.prod.fst ⊚ (prod.diag : α ⟹ _) = id :=
by ext i; induction i; [refl, apply i_ih]

theorem snd_diag {α : typevec n} : typevec.prod.snd ⊚ (prod.diag : α ⟹ _) = id :=
by ext i; induction i; [refl, apply i_ih]

lemma repeat_eq_iff_eq {α : typevec n} {i x y} :
  of_repeat (repeat_eq α i (prod.mk _ x y)) ↔ x = y :=
by induction i; [refl, erw [repeat_eq,@i_ih (drop α) x y]]

/-- given a predicate vector `p` over vector `α`, `subtype_ p` is the type of vectors
that contain an `α` that satisfies `p` -/
def subtype_ : Π {n} {α : typevec.{u} n} (p : α ⟹ repeat n Prop), typevec n
| ._ α p fin2.fz := _root_.subtype (λ x, p fin2.fz x)
| ._ α p (fin2.fs i) := subtype_ (drop_fun p) i

/-- projection on `subtype_` -/
def subtype_val : Π {n} {α : typevec.{u} n} (p : α ⟹ repeat n Prop), subtype_ p ⟹ α
| (succ n) α p (fin2.fs i) := @subtype_val n _ _ i
| (succ n) α p fin2.fz := _root_.subtype.val

/-- arrow that rearranges the type of `subtype_` to turn a subtype of vector into
a vector of subtypes -/
def to_subtype : Π {n} {α : typevec.{u} n} (p : α ⟹ repeat n Prop),
  (λ (i : fin2 n), { x // of_repeat $ p i x }) ⟹ subtype_ p
| (succ n) α p (fin2.fs i) x := to_subtype (drop_fun p) i x
| (succ n) α p fin2.fz x := x

/-- arrow that rearranges the type of `subtype_` to turn a vector of subtypes
into a subtype of vector -/
def of_subtype : Π {n} {α : typevec.{u} n} (p : α ⟹ repeat n Prop),
  subtype_ p ⟹ (λ (i : fin2 n), { x // of_repeat $ p i x })
| (succ n) α p (fin2.fs i) x := of_subtype _ i x
| (succ n) α p fin2.fz x := x

/-- similar to `to_subtype` adapted to relations (i.e. predicate on product) -/
def to_subtype' : Π {n} {α : typevec.{u} n} (p : α ⊗ α ⟹ repeat n Prop),
  (λ (i : fin2 n), { x : α i × α i // of_repeat $ p i (prod.mk _ x.1 x.2) }) ⟹ subtype_ p
| (succ n) α p (fin2.fs i) x := to_subtype' (drop_fun p) i x
| (succ n) α p fin2.fz x := ⟨x.val,cast (by congr; simp [prod.mk]) x.property⟩

/-- similar to `of_subtype` adapted to relations (i.e. predicate on product) -/
def of_subtype' : Π {n} {α : typevec.{u} n} (p : α ⊗ α ⟹ repeat n Prop),
  subtype_ p ⟹ (λ (i : fin2 n), { x : α i × α i // of_repeat $ p i (prod.mk _ x.1 x.2) })
| ._ α p (fin2.fs i) x := of_subtype' _ i x
| ._ α p fin2.fz x := ⟨x.val,cast (by congr; simp [prod.mk]) x.property⟩

/-- similar to `diag` but the target vector is a `subtype_`
guaranteeing the equality of the components -/
def diag_sub  : Π {n} {α : typevec.{u} n}, α ⟹ subtype_ (repeat_eq α)
| (succ n) α (fin2.fs i) x := @diag_sub _ (drop α) _ x
| (succ n) α fin2.fz x := ⟨(x,x), rfl⟩

lemma subtype_val_nil {α : typevec.{u} 0} (ps : α ⟹ repeat 0 Prop) :
  typevec.subtype_val ps = nil_fun :=
funext $ by rintro ⟨ ⟩; refl

lemma diag_sub_val {n} {α : typevec.{u} n} :
  subtype_val (repeat_eq α) ⊚ diag_sub = prod.diag :=
by ext i; induction i; [refl, apply i_ih]

lemma prod_id : Π {n} {α β : typevec.{u} n}, (id ⊗' id) = (id : α ⊗ β ⟹ _) :=
begin
  intros, ext i a, induction i,
  { cases a, refl },
  { apply i_ih },
end

lemma append_prod_append_fun {n} {α α' β β' : typevec.{u} n}
  {φ φ' ψ ψ' : Type u}
  {f₀ : α ⟹ α'} {g₀ : β ⟹ β'}
  {f₁ : φ → φ'}  {g₁ : ψ → ψ'} :
  (f₀ ⊗' g₀) ::: _root_.prod.map f₁ g₁ = ((f₀ ::: f₁) ⊗' (g₀ ::: g₁)) :=
by ext i a; cases i; [cases a, skip]; refl

end liftp'

@[simp]
lemma drop_fun_diag {α} :
  drop_fun (@prod.diag (n+1) α) = prod.diag :=
by { ext i : 2, induction i; simp [drop_fun,*]; refl }

@[simp]
lemma drop_fun_subtype_val {α} (p : α ⟹ repeat (n+1) Prop) :
  drop_fun (subtype_val p) = subtype_val _ := rfl

@[simp]
lemma last_fun_subtype_val {α} (p : α ⟹ repeat (n+1) Prop) :
  last_fun (subtype_val p) = subtype.val := rfl

@[simp]
lemma drop_fun_to_subtype {α} (p : α ⟹ repeat (n+1) Prop) :
  drop_fun (to_subtype p) = to_subtype _ :=
by { ext i : 2, induction i; simp [drop_fun,*]; refl }

@[simp]
lemma last_fun_to_subtype {α} (p : α ⟹ repeat (n+1) Prop) :
  last_fun (to_subtype p) = _root_.id :=
by { ext i : 2, induction i; simp [drop_fun,*]; refl }

@[simp]
lemma drop_fun_of_subtype {α} (p : α ⟹ repeat (n+1) Prop) :
  drop_fun (of_subtype p) = of_subtype _ :=
by { ext i : 2, induction i; simp [drop_fun,*]; refl }

@[simp]
lemma last_fun_of_subtype {α} (p : α ⟹ repeat (n+1) Prop) :
  last_fun (of_subtype p) = _root_.id :=
by { ext i : 2, induction i; simp [drop_fun,*]; refl }

@[simp]
lemma drop_fun_rel_last {α : typevec n} {β}
  (R : β → β → Prop) :
  drop_fun (rel_last' α R) = repeat_eq α := rfl

attribute [simp] drop_append1'
open_locale mvfunctor

@[simp]
lemma drop_fun_prod {α α' β β' : typevec (n+1)} (f : α ⟹ β) (f' : α' ⟹ β') :
  drop_fun (f ⊗' f') = (drop_fun f ⊗' drop_fun f') :=
by { ext i : 2, induction i; simp [drop_fun,*]; refl }

@[simp]
lemma last_fun_prod {α α' β β' : typevec (n+1)} (f : α ⟹ β) (f' : α' ⟹ β') :
  last_fun (f ⊗' f') = _root_.prod.map (last_fun f) (last_fun f') :=
by { ext i : 1, induction i; simp [last_fun,*]; refl }

@[simp]
lemma drop_fun_from_append1_drop_last {α : typevec (n+1)} :
  drop_fun (@from_append1_drop_last _ α) = id := rfl

@[simp]
lemma last_fun_from_append1_drop_last {α : typevec (n+1)} :
  last_fun (@from_append1_drop_last _ α) = _root_.id := rfl

@[simp]
lemma drop_fun_id {α : typevec (n+1)} :
  drop_fun (@typevec.id _ α) = id := rfl

@[simp]
lemma prod_map_id {α β : typevec n} :
  (@typevec.id _ α ⊗' @typevec.id _ β) = id :=
by { ext i : 2, induction i; simp only [typevec.prod.map,*,drop_fun_id],
     cases x, refl, refl }

@[simp]
lemma subtype_val_diag_sub {α : typevec n} :
  subtype_val (repeat_eq α) ⊚ diag_sub = prod.diag :=
by { clear_except, ext i, induction i; [refl, apply i_ih], }

@[simp]
lemma to_subtype_of_subtype {α : typevec n} (p : α ⟹ repeat n Prop) :
  to_subtype p ⊚ of_subtype p = id :=
by ext i x; induction i; dsimp only [id, to_subtype, comp, of_subtype] at *; simp *

@[simp]
lemma subtype_val_to_subtype {α : typevec n} (p : α ⟹ repeat n Prop) :
  subtype_val p ⊚ to_subtype p = λ _, subtype.val :=
by ext i x; induction i; dsimp only [to_subtype, comp, subtype_val] at *; simp *

@[simp]
lemma to_subtype_of_subtype_assoc {α β : typevec n} (p : α ⟹ repeat n Prop)
  (f : β ⟹ subtype_ p) :
  @to_subtype n _ p ⊚ of_subtype _ ⊚ f = f :=
by rw [← comp_assoc,to_subtype_of_subtype]; simp

@[simp]
lemma to_subtype'_of_subtype' {α : typevec n} (r : α ⊗ α ⟹ repeat n Prop) :
  to_subtype' r ⊚ of_subtype' r = id :=
by ext i x; induction i; dsimp only [id, to_subtype', comp, of_subtype'] at *; simp [subtype.eta, *]

lemma subtype_val_to_subtype' {α : typevec n} (r : α ⊗ α ⟹ repeat n Prop) :
  subtype_val r ⊚ to_subtype' r = λ i x, prod.mk i x.1.fst x.1.snd :=
by ext i x; induction i; dsimp only [id, to_subtype', comp, subtype_val, prod.mk] at *; simp *

end typevec


/-
Copyright (c) 2014 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Leonardo de Moura, Floris van Doorn, Yury Kudryashov, Neil Strickland

! This file was ported from Lean 3 source module algebra.ring.semiconj
! leanprover-community/mathlib commit 70d50ecfd4900dd6d328da39ab7ebd516abe4025
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.Group.Semiconj
import Mathlib.Algebra.Ring.Defs

/-!
# Semirings and rings

This file gives lemmas about semirings, rings and domains.
This is analogous to `Mathlib.Algebra.Group.Basic`,
the difference being that the former is about `+` and `*` separately, while
the present file is about their interaction.

For the definitions of semirings and rings see `Mathlib.Algebra.Ring.Defs`.

-/

universe u v w x

variable {α : Type u} {β : Type v} {γ : Type w} {R : Type x}

open Function

namespace SemiconjBy

@[simp]
theorem add_right [Distrib R] {a x y x' y' : R} (h : SemiconjBy a x y) (h' : SemiconjBy a x' y') :
    SemiconjBy a (x + x') (y + y') := by
  simp only [SemiconjBy, left_distrib, right_distrib, h.eq, h'.eq]
#align semiconj_by.add_right SemiconjBy.add_right

@[simp]
theorem add_left [Distrib R] {a b x y : R} (ha : SemiconjBy a x y) (hb : SemiconjBy b x y) :
    SemiconjBy (a + b) x y := by
  simp only [SemiconjBy, left_distrib, right_distrib, ha.eq, hb.eq]
#align semiconj_by.add_left SemiconjBy.add_left

section

variable [Mul R] [HasDistribNeg R] {a x y : R}

theorem neg_right (h : SemiconjBy a x y) : SemiconjBy a (-x) (-y) := by
  simp only [SemiconjBy, h.eq, neg_mul, mul_neg]
#align semiconj_by.neg_right SemiconjBy.neg_right

@[simp]
theorem neg_right_iff : SemiconjBy a (-x) (-y) ↔ SemiconjBy a x y :=
  ⟨fun h => neg_neg x ▸ neg_neg y ▸ h.neg_right, SemiconjBy.neg_right⟩
#align semiconj_by.neg_right_iff SemiconjBy.neg_right_iff

theorem neg_left (h : SemiconjBy a x y) : SemiconjBy (-a) x y := by
  simp only [SemiconjBy, h.eq, neg_mul, mul_neg]
#align semiconj_by.neg_left SemiconjBy.neg_left

@[simp]
theorem neg_left_iff : SemiconjBy (-a) x y ↔ SemiconjBy a x y :=
  ⟨fun h => neg_neg a ▸ h.neg_left, SemiconjBy.neg_left⟩
#align semiconj_by.neg_left_iff SemiconjBy.neg_left_iff

end

section

variable [MulOneClass R] [HasDistribNeg R] {a x y : R}

-- porting note: `simpNF` told me to remove `simp` attribute
theorem neg_one_right (a : R) : SemiconjBy a (-1) (-1) :=
  (one_right a).neg_right
#align semiconj_by.neg_one_right SemiconjBy.neg_one_right

-- porting note: `simpNF` told me to remove `simp` attribute
theorem neg_one_left (x : R) : SemiconjBy (-1) x x :=
  (SemiconjBy.one_left x).neg_left
#align semiconj_by.neg_one_left SemiconjBy.neg_one_left

end

section

variable [NonUnitalNonAssocRing R] {a b x y x' y' : R}

@[simp]
theorem sub_right (h : SemiconjBy a x y) (h' : SemiconjBy a x' y') :
    SemiconjBy a (x - x') (y - y') := by
  simpa only [sub_eq_add_neg] using h.add_right h'.neg_right
#align semiconj_by.sub_right SemiconjBy.sub_right

@[simp]
theorem sub_left (ha : SemiconjBy a x y) (hb : SemiconjBy b x y) :
    SemiconjBy (a - b) x y := by
  simpa only [sub_eq_add_neg] using ha.add_left hb.neg_left
#align semiconj_by.sub_left SemiconjBy.sub_left

end

end SemiconjBy


/-
Copyright (c) 2021 Aaron Anderson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Aaron Anderson
-/
import ring_theory.hahn_series
import ring_theory.localization

/-!
# Laurent Series

## Main Definitions
* Defines `laurent_series` as an abbreviation for `hahn_series ℤ`.
* Provides a coercion `power_series R` into `laurent_series R` given by
  `hahn_series.of_power_series`.
* Defines `laurent_series.power_series_part`
* Defines the localization map `laurent_series.of_power_series_localization` which evaluates to
  `hahn_series.of_power_series`.

-/

open hahn_series
open_locale big_operators classical
noncomputable theory

/-- A `laurent_series` is implemented as a `hahn_series` with value group `ℤ`. -/
abbreviation laurent_series (R : Type*) [has_zero R] := hahn_series ℤ R

variables {R : Type*}

namespace laurent_series

section semiring
variable [semiring R]

instance : has_coe (power_series R) (laurent_series R) :=
⟨hahn_series.of_power_series ℤ R⟩

lemma coe_power_series (x : power_series R) : (x : laurent_series R) =
  hahn_series.of_power_series ℤ R x := rfl

@[simp] lemma coeff_coe_power_series (x : power_series R) (n : ℕ) :
  hahn_series.coeff (x : laurent_series R) n = power_series.coeff R n x :=
by rw [← int.nat_cast_eq_coe_nat, coe_power_series, of_power_series_apply_coeff]

/-- This is a power series that can be multiplied by an integer power of `X` to give our
  Laurent series. If the Laurent series is nonzero, `power_series_part` has a nonzero
  constant term.  -/
def power_series_part (x : laurent_series R) : power_series R :=
power_series.mk (λ n, x.coeff (x.order + n))

@[simp] lemma power_series_part_coeff (x : laurent_series R) (n : ℕ) :
  power_series.coeff R n x.power_series_part = x.coeff (x.order + n) :=
power_series.coeff_mk _ _

@[simp] lemma power_series_part_zero : power_series_part (0 : laurent_series R) = 0 :=
by { ext, simp }

@[simp] lemma power_series_part_eq_zero (x : laurent_series R) :
  x.power_series_part = 0 ↔ x = 0 :=
begin
  split,
  { contrapose!,
    intro h,
    rw [power_series.ext_iff, not_forall],
    refine ⟨0, _⟩,
    simp [coeff_order_ne_zero h] },
  { rintro rfl,
    simp }
end

@[simp] lemma single_order_mul_power_series_part (x : laurent_series R) :
  (single x.order 1 : laurent_series R) * x.power_series_part = x :=
begin
  ext n,
  rw [← sub_add_cancel n x.order, single_mul_coeff_add, sub_add_cancel, one_mul],
  by_cases h : x.order ≤ n,
  { rw [int.eq_nat_abs_of_zero_le (sub_nonneg_of_le h), coeff_coe_power_series,
      power_series_part_coeff, ← int.eq_nat_abs_of_zero_le (sub_nonneg_of_le h),
      add_sub_cancel'_right] },
  { rw [coe_power_series, of_power_series_apply, emb_domain_notin_range],
    { contrapose! h,
      exact order_le_of_coeff_ne_zero h.symm },
    { contrapose! h,
      simp only [set.mem_range, rel_embedding.coe_fn_mk, function.embedding.coe_fn_mk,
        int.nat_cast_eq_coe_nat] at h,
      obtain ⟨m, hm⟩ := h,
      rw [← sub_nonneg, ← hm],
      exact int.zero_le_of_nat _ } }
end

lemma of_power_series_power_series_part (x : laurent_series R) :
  of_power_series ℤ R x.power_series_part = single (-x.order) 1 * x :=
begin
  refine eq.trans _ (congr rfl x.single_order_mul_power_series_part),
  rw [← mul_assoc, single_mul_single, neg_add_self, mul_one, ← C_apply, C_one, one_mul,
    coe_power_series],
end

@[simp] lemma of_power_series_X :
  of_power_series ℤ R power_series.X = single 1 1 :=
begin
  ext n,
  cases n,
  { rw [int.of_nat_eq_coe, ← int.nat_cast_eq_coe_nat, of_power_series_apply_coeff],
    by_cases h1 : n = 1,
    { simp [h1] },
    { rw [power_series.coeff_X, single_coeff, if_neg h1, if_neg],
      contrapose! h1,
      rw [← nat.cast_one] at h1,
      exact nat.cast_injective h1 } },
  { rw [of_power_series_apply, emb_domain_notin_range, single_coeff_of_ne],
    { dec_trivial },
    rw [set.mem_range, not_exists],
    intro m,
    simp only [rel_embedding.coe_fn_mk, function.embedding.coe_fn_mk, int.nat_cast_eq_coe_nat],
    dec_trivial }
end

end semiring

@[simp] lemma of_power_series_X_pow [comm_semiring R] (n : ℕ) :
  of_power_series ℤ R (power_series.X ^ n) = single (n : ℤ) 1 :=
begin
  rw ring_hom.map_pow,
  induction n with n ih,
  { refl },
  rw [pow_succ, int.coe_nat_succ, ih, of_power_series_X, mul_comm, single_mul_single, one_mul],
end

instance [comm_semiring R] : algebra (power_series R) (laurent_series R) :=
(hahn_series.of_power_series ℤ R).to_algebra

@[simp] lemma coe_algebra_map [comm_semiring R] :
  ⇑(algebra_map (power_series R) (laurent_series R)) = hahn_series.of_power_series ℤ R :=
rfl

/-- The localization map from power series to Laurent series. -/
@[simps] instance of_power_series_localization [comm_ring R] :
  is_localization (submonoid.powers (power_series.X : power_series R)) (laurent_series R) :=
{ map_units := (begin rintro ⟨_, n, rfl⟩,
    refine ⟨⟨single (n : ℤ) 1, single (-n : ℤ) 1, _, _⟩, _⟩,
    { simp only [single_mul_single, mul_one, add_right_neg],
      refl },
    { simp only [single_mul_single, mul_one, add_left_neg],
      refl },
    { simp } end),
 surj := (begin intro z,
    by_cases h : 0 ≤ z.order,
    { refine ⟨⟨power_series.X ^ (int.nat_abs z.order) * power_series_part z, 1⟩, _⟩,
      simp only [ring_hom.map_one, mul_one, ring_hom.map_mul, coe_algebra_map,
        of_power_series_X_pow, submonoid.coe_one],
      rw [int.nat_abs_of_nonneg h, ← coe_power_series, single_order_mul_power_series_part] },
    { refine ⟨⟨power_series_part z, power_series.X ^ (int.nat_abs z.order), ⟨_, rfl⟩⟩, _⟩,
      simp only [coe_algebra_map, of_power_series_power_series_part],
      rw [mul_comm _ z],
      refine congr rfl _,
      rw [subtype.coe_mk, of_power_series_X_pow, int.of_nat_nat_abs_of_nonpos],
      exact le_of_not_ge h } end),
  eq_iff_exists := (begin intros x y,
    rw [coe_algebra_map, of_power_series_injective.eq_iff],
    split,
    { rintro rfl,
      exact ⟨1, rfl⟩ },
    { rintro ⟨⟨_, n, rfl⟩, hc⟩,
      rw [← sub_eq_zero, ← sub_mul, power_series.ext_iff] at hc,
      rw [← sub_eq_zero, power_series.ext_iff],
      intro m,
      have h := hc (m + n),
      rw [linear_map.map_zero, subtype.coe_mk, power_series.X_pow_eq, power_series.monomial,
        power_series.coeff, finsupp.single_add, mv_power_series.coeff_add_mul_monomial,
        mul_one] at h,
      exact h } end) }

end laurent_series


/-
Copyright (c) 2020 Kevin Buzzard, Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kevin Buzzard, Bhavik Mehta
-/

import category_theory.limits.preserves.shapes.equalizers
import category_theory.limits.preserves.shapes.products
import category_theory.limits.yoneda
import category_theory.sites.sheaf_of_types

/-!
# Sheaves taking values in a category

If C is a category with a Grothendieck topology, we define the notion of a sheaf taking values in
an arbitrary category `A`. We follow the definition in https://stacks.math.columbia.edu/tag/00VR,
noting that the presheaf of sets "defined above" can be seen in the comments between tags 00VQ and
00VR on the page https://stacks.math.columbia.edu/tag/00VL. The advantage of this definition is
that we need no assumptions whatsoever on `A` other than the assumption that the morphisms in `C`
and `A` live in the same universe.

* An `A`-valued presheaf `P : Cᵒᵖ ⥤ A` is defined to be a sheaf (for the topology `J`) iff for
  every `X : A`, the type-valued presheaves of sets given by sending `U : Cᵒᵖ` to `Hom_{A}(X, P U)`
  are all sheaves of sets, see `category_theory.presheaf.is_sheaf`.
* When `A = Type`, this recovers the basic definition of sheaves of sets, see
  `category_theory.is_sheaf_iff_is_sheaf_of_type`.
* An alternate definition when `C` is small, has pullbacks and `A` has products is given by an
  equalizer condition `category_theory.presheaf.is_sheaf'`. This is equivalent to the earlier
  definition, shown in `category_theory.presheaf.is_sheaf_iff_is_sheaf'`.
* When `A = Type`, this is *definitionally* equal to the equalizer condition for presieves in
  `category_theory.sites.sheaf_of_types`.
* When `A` has limits and there is a functor `s : A ⥤ Type` which is faithful, reflects isomorphisms
  and preserves limits, then `P : C^op ⥤ A` is a sheaf iff the underlying presheaf of types
  `P ⋙ s : C^op ⥤ Type` is a sheaf (`category_theory.presheaf.is_sheaf_iff_is_sheaf_forget`).
  Cf https://stacks.math.columbia.edu/tag/0073, which is a weaker version of this statement (it's
  only over spaces, not sites) and https://stacks.math.columbia.edu/tag/00YR (a), which
  additionally assumes filtered colimits.
-/

universes w v₁ v₂ u₁ u₂

noncomputable theory

namespace category_theory

open opposite category_theory category limits sieve classical

namespace presheaf

variables {C : Type u₁} [category.{v₁} C]
variables {A : Type u₂} [category.{v₂} A]
variables (J : grothendieck_topology C)

-- We follow https://stacks.math.columbia.edu/tag/00VL definition 00VR

/--
A sheaf of A is a presheaf P : C^op => A such that for every X : A, the
presheaf of types given by sending U : C to Hom_{A}(X, P U) is a sheaf of types.

https://stacks.math.columbia.edu/tag/00VR
-/
def is_sheaf (P : Cᵒᵖ ⥤ A) : Prop :=
∀ X : A, presieve.is_sheaf J (P ⋙ coyoneda.obj (op X))

variable {J}

/-- This is a wrapper around `presieve.is_sheaf_for.amalgamate` to be used below.
  If `P`s a sheaf, `S` is a cover of `X`, and `x` is a collection of morphisms from `E`
  to `P` evaluated at terms in the cover which are compatible, then we can amalgamate
  the `x`s to obtain a single morphism `E ⟶ P.obj (op X)`. -/
def is_sheaf.amalgamate {A : Type u₂} [category.{max v₁ u₁} A]
  {E : A} {X : C} {P : Cᵒᵖ ⥤ A} (hP : presheaf.is_sheaf J P) (S : J.cover X)
  (x : Π (I : S.arrow), E ⟶ P.obj (op I.Y))
  (hx : ∀ (I : S.relation), x I.fst ≫ P.map I.g₁.op = x I.snd ≫ P.map I.g₂.op) :
  E ⟶ P.obj (op X) :=
(hP _ _ S.condition).amalgamate (λ Y f hf, x ⟨Y,f,hf⟩) $
  λ Y₁ Y₂ Z g₁ g₂ f₁ f₂ h₁ h₂ w, hx ⟨Y₁, Y₂, Z, g₁, g₂, f₁, f₂, h₁, h₂, w⟩

@[simp, reassoc]
lemma is_sheaf.amalgamate_map {A : Type u₂} [category.{max v₁ u₁} A]
  {E : A} {X : C} {P : Cᵒᵖ ⥤ A} (hP : presheaf.is_sheaf J P) (S : J.cover X)
  (x : Π (I : S.arrow), E ⟶ P.obj (op I.Y))
  (hx : ∀ (I : S.relation), x I.fst ≫ P.map I.g₁.op = x I.snd ≫ P.map I.g₂.op)
  (I : S.arrow) : hP.amalgamate S x hx ≫ P.map I.f.op = x _ :=
begin
  rcases I with ⟨Y,f,hf⟩,
  apply @presieve.is_sheaf_for.valid_glue _ _ _ _ _ _ (hP _ _ S.condition)
    (λ Y f hf, x ⟨Y,f,hf⟩)
    (λ Y₁ Y₂ Z g₁ g₂ f₁ f₂ h₁ h₂ w, hx ⟨Y₁, Y₂, Z, g₁, g₂, f₁, f₂, h₁, h₂, w⟩) f hf,
end

lemma is_sheaf.hom_ext {A : Type u₂} [category.{max v₁ u₁} A]
  {E : A} {X : C} {P : Cᵒᵖ ⥤ A} (hP : presheaf.is_sheaf J P) (S : J.cover X)
  (e₁ e₂ : E ⟶ P.obj (op X)) (h : ∀ (I : S.arrow), e₁ ≫ P.map I.f.op = e₂ ≫ P.map I.f.op) :
  e₁ = e₂ :=
(hP _ _ S.condition).is_separated_for.ext (λ Y f hf, h ⟨Y,f,hf⟩)

variable (J)

end presheaf

variables {C : Type u₁} [category.{v₁} C]
variables (J : grothendieck_topology C)
variables (A : Type u₂) [category.{v₂} A]

/-- The category of sheaves taking values in `A` on a grothendieck topology. -/
@[derive category]
def Sheaf : Type* :=
{P : Cᵒᵖ ⥤ A // presheaf.is_sheaf J P}

/-- The inclusion functor from sheaves to presheaves. -/
@[simps map {rhs_md := semireducible}, derive [full, faithful]]
def Sheaf_to_presheaf : Sheaf J A ⥤ (Cᵒᵖ ⥤ A) :=
full_subcategory_inclusion (presheaf.is_sheaf J)

namespace Sheaf

@[simp] lemma id_app (X : Sheaf J A) (B : Cᵒᵖ) : (𝟙 X : X ⟶ X).app B = 𝟙 _ := rfl
@[simp] lemma comp_app {X Y Z : Sheaf J A} (f : X ⟶ Y) (g : Y ⟶ Z) (B : Cᵒᵖ) :
  (f ≫ g).app B = f.app B ≫ g.app B := rfl

instance : has_coe (Sheaf J A) (Cᵒᵖ ⥤ A) := ⟨λ P, P.val⟩

end Sheaf

@[simp] lemma Sheaf_to_presheaf_obj (P : Sheaf J A) : (Sheaf_to_presheaf J A).obj P = P := rfl

/-- The sheaf of sections guaranteed by the sheaf condition. -/
@[simps] abbreviation sheaf_over {A : Type u₂} [category.{v₂} A] {J : grothendieck_topology C}
  (ℱ : Sheaf J A) (X : A) : SheafOfTypes J := ⟨↑ℱ ⋙ coyoneda.obj (op X), ℱ.property X⟩

lemma is_sheaf_iff_is_sheaf_of_type (P : Cᵒᵖ ⥤ Type w) :
  presheaf.is_sheaf J P ↔ presieve.is_sheaf J P :=
begin
  split,
  { intros hP,
    refine presieve.is_sheaf_iso J _ (hP punit),
    exact iso_whisker_left _ coyoneda.punit_iso ≪≫ P.right_unitor },
  { intros hP X Y S hS z hz,
    refine ⟨λ x, (hP S hS).amalgamate (λ Z f hf, z f hf x) _, _, _⟩,
    { intros Y₁ Y₂ Z g₁ g₂ f₁ f₂ hf₁ hf₂ h,
      exact congr_fun (hz g₁ g₂ hf₁ hf₂ h) x },
    { intros Z f hf,
      ext x,
      apply presieve.is_sheaf_for.valid_glue },
    { intros y hy,
      ext x,
      apply (hP S hS).is_separated_for.ext,
      intros Y' f hf,
      rw [presieve.is_sheaf_for.valid_glue _ _ _ hf, ← hy _ hf],
      refl } }
end

/--
The category of sheaves taking values in Type is the same as the category of set-valued sheaves.
-/
@[simps]
def Sheaf_equiv_SheafOfTypes : Sheaf J (Type w) ≌ SheafOfTypes J :=
{ functor :=
  { obj := λ S, ⟨S.1, (is_sheaf_iff_is_sheaf_of_type _ _).1 S.2⟩,
    map := λ S₁ S₂ f, f },
  inverse :=
  { obj := λ S, ⟨S.1, (is_sheaf_iff_is_sheaf_of_type _ _).2 S.2⟩,
    map := λ S₁ S₂ f, f },
  unit_iso := nat_iso.of_components (λ X, ⟨𝟙 _, 𝟙 _, by tidy, by tidy⟩) (by tidy),
  counit_iso := nat_iso.of_components (λ X, ⟨𝟙 _, 𝟙 _, by tidy, by tidy⟩) (by tidy) }

instance : inhabited (Sheaf (⊥ : grothendieck_topology C) (Type w)) :=
⟨(Sheaf_equiv_SheafOfTypes _).inverse.obj (default _)⟩

variables {J} {A}

/-- If the empty sieve is a cover of `X`, then `F(X)` is terminal. -/
def Sheaf.is_terminal_of_bot_cover (F : Sheaf J A) (X : C) (H : ⊥ ∈ J X) :
  is_terminal (F.1.obj (op X)) :=
begin
  apply_with is_terminal.of_unique { instances := ff },
  intro Y,
  choose t h using F.2 Y _ H (by tidy) (by tidy),
  exact ⟨⟨t⟩, λ a, h.2 a (by tidy)⟩
end

end category_theory

namespace category_theory

open opposite category_theory category limits sieve classical

namespace presheaf

-- Under here is the equalizer story, which is equivalent if A has products (and doesn't
-- make sense otherwise). It's described in https://stacks.math.columbia.edu/tag/00VL,
-- between 00VQ and 00VR.

variables {C : Type u₁} [category.{v₁} C]
variables {A : Type u₂} [category.{max v₁ u₁} A]
variables (J : grothendieck_topology C)
variables {U : C} (R : presieve U)
variables (P : Cᵒᵖ ⥤ A)

section multiequalizer_conditions

/-- When `P` is a sheaf and `S` is a cover, the associated multifork is a limit. -/
def is_limit_of_is_sheaf {X : C} (S : J.cover X) (hP : is_sheaf J P) :
  is_limit (S.multifork P) :=
{ lift := λ (E : multifork _), hP.amalgamate S (λ I, E.ι _) (λ I, E.condition _),
  fac' := begin
    rintros (E : multifork _) (a|b),
    { apply hP.amalgamate_map },
    { rw [← E.w (walking_multicospan.hom.fst b),
        ← (S.multifork P).w (walking_multicospan.hom.fst b), ← category.assoc],
      congr' 1,
      apply hP.amalgamate_map }
  end,
  uniq' := begin
    rintros (E : multifork _) m hm,
    apply hP.hom_ext S,
    intros I,
    erw hm (walking_multicospan.left I),
    symmetry,
    apply hP.amalgamate_map
  end }

lemma is_sheaf_iff_multifork : is_sheaf J P ↔
  (∀ (X : C) (S : J.cover X), nonempty (is_limit (S.multifork P))) :=
begin
  refine ⟨λ hP X S, ⟨is_limit_of_is_sheaf _ _ _ hP⟩, _⟩,
  intros h E X S hS x hx,
  let T : J.cover X := ⟨S,hS⟩,
  obtain ⟨hh⟩ := h _ T,
  let K : multifork (T.index P) :=
    multifork.of_ι _ E (λ I, x I.f I.hf) (λ I, hx _ _ _ _ I.w),
  use hh.lift K,
  dsimp, split,
  { intros Y f hf,
    apply hh.fac K (walking_multicospan.left ⟨Y,f,hf⟩) },
  { intros e he,
    apply hh.uniq K,
    rintros (a|b),
    { apply he },
    { rw [← K.w (walking_multicospan.hom.fst b),
        ← (T.multifork P).w (walking_multicospan.hom.fst b), ← category.assoc],
      congr' 1,
      apply he } }
end

lemma is_sheaf_iff_multiequalizer
  [∀ (X : C) (S : J.cover X), has_multiequalizer (S.index P)] : is_sheaf J P ↔
  (∀ (X : C) (S : J.cover X), is_iso (S.to_multiequalizer P)) :=
begin
  rw is_sheaf_iff_multifork,
  apply forall_congr (λ X, _), apply forall_congr (λ S, _), split,
  { rintros ⟨h⟩,
    let e : P.obj (op X) ≅ multiequalizer (S.index P) :=
      h.cone_point_unique_up_to_iso (limit.is_limit _),
    exact (infer_instance : is_iso e.hom) },
  { introsI h,
    refine ⟨is_limit.of_iso_limit (limit.is_limit _) (cones.ext _ _)⟩,
    { apply (@as_iso _ _ _ _ _ h).symm },
    { intros a,
      symmetry,
      erw is_iso.inv_comp_eq,
      change _ = limit.lift _ _ ≫ _,
      simp } }
end

end multiequalizer_conditions

section

variables [has_products A]

/--
The middle object of the fork diagram given in Equation (3) of [MM92], as well as the fork diagram
of https://stacks.math.columbia.edu/tag/00VM.
-/
def first_obj : A :=
∏ (λ (f : Σ V, {f : V ⟶ U // R f}), P.obj (op f.1))

/--
The left morphism of the fork diagram given in Equation (3) of [MM92], as well as the fork diagram
of https://stacks.math.columbia.edu/tag/00VM.
-/
def fork_map : P.obj (op U) ⟶ first_obj R P :=
pi.lift (λ f, P.map f.2.1.op)

variables [has_pullbacks C]

/--
The rightmost object of the fork diagram of https://stacks.math.columbia.edu/tag/00VM, which
contains the data used to check a family of elements for a presieve is compatible.
-/
def second_obj : A :=
∏ (λ (fg : (Σ V, {f : V ⟶ U // R f}) × (Σ W, {g : W ⟶ U // R g})),
  P.obj (op (pullback fg.1.2.1 fg.2.2.1)))

/-- The map `pr₀*` of https://stacks.math.columbia.edu/tag/00VM. -/
def first_map : first_obj R P ⟶ second_obj R P :=
pi.lift (λ fg, pi.π _ _ ≫ P.map pullback.fst.op)

/-- The map `pr₁*` of https://stacks.math.columbia.edu/tag/00VM. -/
def second_map : first_obj R P ⟶ second_obj R P :=
pi.lift (λ fg, pi.π _ _ ≫ P.map pullback.snd.op)

lemma w : fork_map R P ≫ first_map R P = fork_map R P ≫ second_map R P :=
begin
  apply limit.hom_ext,
  rintro ⟨⟨Y, f, hf⟩, ⟨Z, g, hg⟩⟩,
  simp only [first_map, second_map, fork_map, limit.lift_π, limit.lift_π_assoc, assoc,
    fan.mk_π_app, subtype.coe_mk, subtype.val_eq_coe],
  rw [← P.map_comp, ← op_comp, pullback.condition],
  simp,
end

/--
An alternative definition of the sheaf condition in terms of equalizers. This is shown to be
equivalent in `category_theory.presheaf.is_sheaf_iff_is_sheaf'`.
-/
def is_sheaf' (P : Cᵒᵖ ⥤ A) : Prop := ∀ (U : C) (R : presieve U) (hR : generate R ∈ J U),
nonempty (is_limit (fork.of_ι _ (w R P)))

/-- (Implementation). An auxiliary lemma to convert between sheaf conditions. -/
def is_sheaf_for_is_sheaf_for' (P : Cᵒᵖ ⥤ A) (s : A ⥤ Type (max v₁ u₁))
  [Π J, preserves_limits_of_shape (discrete J) s] (U : C) (R : presieve U) :
  is_limit (s.map_cone (fork.of_ι _ (w R P))) ≃
    is_limit (fork.of_ι _ (equalizer.presieve.w (P ⋙ s) R)) :=
begin
  apply equiv.trans (is_limit_map_cone_fork_equiv _ _) _,
  apply (is_limit.postcompose_hom_equiv _ _).symm.trans (is_limit.equiv_iso_limit _),
  { apply nat_iso.of_components _ _,
    { rintro (_ | _),
      { apply preserves_product.iso s },
      { apply preserves_product.iso s } },
    { rintro _ _ (_ | _),
      { ext : 1,
        dsimp [equalizer.presieve.first_map, first_map],
        simp only [limit.lift_π, map_lift_pi_comparison, assoc, fan.mk_π_app, functor.map_comp],
        erw pi_comparison_comp_π_assoc },
      { ext : 1,
        dsimp [equalizer.presieve.second_map, second_map],
        simp only [limit.lift_π, map_lift_pi_comparison, assoc, fan.mk_π_app, functor.map_comp],
        erw pi_comparison_comp_π_assoc },
      { dsimp,
        simp } } },
  { refine fork.ext (iso.refl _) _,
    dsimp [equalizer.fork_map, fork_map],
    simp }
end

/-- The equalizer definition of a sheaf given by `is_sheaf'` is equivalent to `is_sheaf`. -/
theorem is_sheaf_iff_is_sheaf' :
  is_sheaf J P ↔ is_sheaf' J P :=
begin
  split,
  { intros h U R hR,
    refine ⟨_⟩,
    apply coyoneda_jointly_reflects_limits,
    intro X,
    have q : presieve.is_sheaf_for (P ⋙ coyoneda.obj X) _ := h X.unop _ hR,
    rw ←presieve.is_sheaf_for_iff_generate at q,
    rw equalizer.presieve.sheaf_condition at q,
    replace q := classical.choice q,
    apply (is_sheaf_for_is_sheaf_for' _ _ _ _).symm q },
  { intros h U X S hS,
    rw equalizer.presieve.sheaf_condition,
    refine ⟨_⟩,
    refine is_sheaf_for_is_sheaf_for' _ _ _ _ _,
    apply is_limit_of_preserves,
    apply classical.choice (h _ S _),
    simpa }
end

end

section concrete

variables [has_pullbacks C]

/--
For a concrete category `(A, s)` where the forgetful functor `s : A ⥤ Type v` preserves limits and
reflects isomorphisms, and `A` has limits, an `A`-valued presheaf `P : Cᵒᵖ ⥤ A` is a sheaf iff its
underlying `Type`-valued presheaf `P ⋙ s : Cᵒᵖ ⥤ Type` is a sheaf.

Note this lemma applies for "algebraic" categories, eg groups, abelian groups and rings, but not
for the category of topological spaces, topological rings, etc since reflecting isomorphisms doesn't
hold.
-/
lemma is_sheaf_iff_is_sheaf_forget (s : A ⥤ Type (max v₁ u₁))
  [has_limits A] [preserves_limits s] [reflects_isomorphisms s] :
  is_sheaf J P ↔ is_sheaf J (P ⋙ s) :=
begin
  rw [is_sheaf_iff_is_sheaf', is_sheaf_iff_is_sheaf'],
  apply forall_congr (λ U, _),
  apply ball_congr (λ R hR, _),
  letI : reflects_limits s := reflects_limits_of_reflects_isomorphisms,
  have : is_limit (s.map_cone (fork.of_ι _ (w R P))) ≃ is_limit (fork.of_ι _ (w R (P ⋙ s))) :=
    is_sheaf_for_is_sheaf_for' P s U R,
  rw ←equiv.nonempty_congr this,
  split,
  { exact nonempty.map (λ t, is_limit_of_preserves s t) },
  { exact nonempty.map (λ t, is_limit_of_reflects s t) }
end

end concrete

end presheaf

end category_theory


import .mat

-- TODO: move
lemma fin.eq_zero_fin1 (i : fin 1) : i = 0 :=
begin
  rw fin.eq_iff_veq,
  apply nat.eq_zero_of_le_zero (nat.le_of_lt_succ i.2)
end

namespace one_by_one_matrix
/-
def coe {α : Type*} : (matrix (fin 1) (fin 1) α) → α := λ A, A 0 0

instance coe_instance (α : Type*) : has_coe (matrix (fin 1) (fin 1) α) α :=
  ⟨coe⟩

@[simp] lemma coe_add (α : Type*) [has_add α] (A B : matrix (fin 1) (fin 1) α) :
  coe (A + B) = coe A + coe B :=
by simp [coe]

@[simp] lemma coe_smul (α : Type*) [has_mul α] (a : α) (A : matrix (fin 1) (fin 1) α) :
  coe (a • A) = a * coe A :=
by simp [coe, has_scalar.smul]

@[simp] lemma coe_smul' (α : Type*) [has_mul α] (a : α) (A : matrix (fin 1) (fin 1) α) :
  coe (a • A) = a * coe A :=
by simp [coe, has_scalar.smul]

@[simp] lemma coe_neg (α : Type*) [has_neg α] (A : matrix (fin 1) (fin 1) α) :
  coe (- A) = - coe A :=
by simp [coe]

@[simp] lemma coe_zero (α : Type*) [has_zero α] :
  coe (0 : matrix (fin 1) (fin 1) α) = 0 :=
by simp [coe]
-/

@[simp] lemma transpose (α : Type*) [ring α] (A : matrix (fin 1) (fin 1) α) : Aᵀ = A :=
begin
  ext i j,
  unfold matrix.transpose,
  rw [fin.eq_zero_fin1 i, fin.eq_zero_fin1 j]
end

end one_by_one_matrix


/-
Copyright (c) 2015 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.

Authors: Leonardo de Moura

! This file was ported from Lean 3 source module init.data.setoid
! leanprover-community/mathlib commit 9af482290ef68e8aaa5ead01aa7b09b7be7019fd
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
prelude
import Leanbin.Init.Logic

universe u

#print Setoid /-
class Setoid (α : Sort u) where
  r : α → α → Prop
  iseqv : Equivalence r
#align setoid Setoid
-/

instance (priority := 100) setoidHasEquiv {α : Sort u} [Setoid α] : HasEquiv α :=
  ⟨Setoid.r⟩
#align setoid_has_equiv setoidHasEquiv

namespace Setoid

variable {α : Sort u} [Setoid α]

#print Setoid.refl /-
@[refl]
theorem refl (a : α) : a ≈ a :=
  match Setoid.iseqv with
  | ⟨h_refl, h_symm, h_trans⟩ => h_refl a
#align setoid.refl Setoid.refl
-/

#print Setoid.symm /-
@[symm]
theorem symm {a b : α} (hab : a ≈ b) : b ≈ a :=
  match Setoid.iseqv with
  | ⟨h_refl, h_symm, h_trans⟩ => h_symm hab
#align setoid.symm Setoid.symm
-/

#print Setoid.trans /-
@[trans]
theorem trans {a b c : α} (hab : a ≈ b) (hbc : b ≈ c) : a ≈ c :=
  match Setoid.iseqv with
  | ⟨h_refl, h_symm, h_trans⟩ => h_trans hab hbc
#align setoid.trans Setoid.trans
-/

end Setoid


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

! This file was ported from Lean 3 source module category_theory.bicategory.locally_discrete
! leanprover-community/mathlib commit c9c9fa15fec7ca18e9ec97306fb8764bfe988a7e
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.CategoryTheory.DiscreteCategory
import Mathlib.CategoryTheory.Bicategory.Functor
import Mathlib.CategoryTheory.Bicategory.Strict

/-!
# Locally discrete bicategories

A category `C` can be promoted to a strict bicategory `LocallyDiscrete C`. The objects and the
1-morphisms in `LocallyDiscrete C` are the same as the objects and the morphisms, respectively,
in `C`, and the 2-morphisms in `LocallyDiscrete C` are the equalities between 1-morphisms. In
other words, the category consisting of the 1-morphisms between each pair of objects `X` and `Y`
in `LocallyDiscrete C` is defined as the discrete category associated with the type `X ⟶ Y`.
-/

namespace CategoryTheory

open Bicategory Discrete

open Bicategory

universe w₂ v v₁ v₂ u u₁ u₂

variable {C : Type u}

/-- A type synonym for promoting any type to a category,
with the only morphisms being equalities.
-/
def LocallyDiscrete (C : Type u) :=
  C
#align category_theory.locally_discrete CategoryTheory.LocallyDiscrete

namespace LocallyDiscrete

instance [Inhabited C] : Inhabited (LocallyDiscrete C) := ⟨(default : C)⟩

instance [CategoryStruct.{v} C] : CategoryStruct (LocallyDiscrete C)
    where
  Hom := fun X Y : C => Discrete (X ⟶ Y)
  id := fun X : C => ⟨𝟙 X⟩
  comp f g := ⟨f.as ≫ g.as⟩

variable [CategoryStruct.{v} C]

instance (priority := 900) homSmallCategory (X Y : LocallyDiscrete C) : SmallCategory (X ⟶ Y) :=
  let X' : C := X
  let Y' : C := Y
  CategoryTheory.discreteCategory (X' ⟶ Y')
#align category_theory.locally_discrete.hom_small_category CategoryTheory.LocallyDiscrete.homSmallCategory

-- Porting note: Manually adding this instance (inferInstance doesn't work)
instance subsingleton2Hom {X Y : LocallyDiscrete C} (f g : X ⟶ Y) : Subsingleton (f ⟶ g) :=
  let X' : C := X
  let Y' : C := Y
  let f' : Discrete (X' ⟶ Y') := f
  let g' : Discrete (X' ⟶ Y') := g
  show Subsingleton (f' ⟶ g') from inferInstance

/-- Extract the equation from a 2-morphism in a locally discrete 2-category. -/
theorem eq_of_hom {X Y : LocallyDiscrete C} {f g : X ⟶ Y} (η : f ⟶ g) : f = g :=
  Discrete.ext _ _ η.1.1
#align category_theory.locally_discrete.eq_of_hom CategoryTheory.LocallyDiscrete.eq_of_hom

end LocallyDiscrete

variable (C) [Category.{v} C]

/-- The locally discrete bicategory on a category is a bicategory in which the objects and the
1-morphisms are the same as those in the underlying category, and the 2-morphisms are the
equalities between 1-morphisms.
-/
instance locallyDiscreteBicategory : Bicategory (LocallyDiscrete C)
    where
  whiskerLeft f g h η := eqToHom (congr_arg₂ (· ≫ ·) rfl (LocallyDiscrete.eq_of_hom η))
  whiskerRight η h := eqToHom (congr_arg₂ (· ≫ ·) (LocallyDiscrete.eq_of_hom η) rfl)
  associator f g h :=
    eqToIso <| by
      apply Discrete.ext
      change (f.as ≫ g.as) ≫ h.as = f.as ≫ (g.as ≫ h.as)
      rw [Category.assoc]
  leftUnitor f :=
    eqToIso <| by
      apply Discrete.ext
      change 𝟙 _ ≫ _ = _
      rw [Category.id_comp]
  rightUnitor f :=
    eqToIso <| by
      apply Discrete.ext
      change _ ≫ 𝟙 _ = _
      rw [Category.comp_id]
#align category_theory.locally_discrete_bicategory CategoryTheory.locallyDiscreteBicategory

/-- A locally discrete bicategory is strict. -/
instance locallyDiscreteBicategory.strict : Strict (LocallyDiscrete C)
    where
  id_comp := by
    intros
    apply Discrete.ext
    apply Category.id_comp
  comp_id := by
    intros
    apply Discrete.ext
    apply Category.comp_id
  assoc := by
    intros
    apply Discrete.ext
    apply Category.assoc
#align category_theory.locally_discrete_bicategory.strict CategoryTheory.locallyDiscreteBicategory.strict

variable {I : Type u₁} [Category.{v₁} I] {B : Type u₂} [Bicategory.{w₂, v₂} B] [Strict B]

/--
If `B` is a strict bicategory and `I` is a (1-)category, any functor (of 1-categories) `I ⥤ B` can
be promoted to an oplax functor from `LocallyDiscrete I` to `B`.
-/
@[simps]
def Functor.toOplaxFunctor (F : I ⥤ B) : OplaxFunctor (LocallyDiscrete I) B
    where
  obj := F.obj
  map f := F.map f.as
  map₂ η := eqToHom (congr_arg _ (LocallyDiscrete.eq_of_hom η))
  mapId i := eqToHom (F.map_id i)
  mapComp f g := eqToHom (F.map_comp f.as g.as)
#align category_theory.functor.to_oplax_functor CategoryTheory.Functor.toOplaxFunctor

end CategoryTheory


import data.set.function
import analysis.normed_space
import tactic.easy

noncomputable theory
local attribute [instance] classical.prop_decidable

open function set

def continuous_on {α : Type*} {β : Type*} [topological_space α] [topological_space β] (U : set α) (f : α → β) :=
∀ W : set β, is_open W → is_open (f ⁻¹' W ∩ U)

section smooth_maps
universes u
variables {α : Type u} {β : Type u} {γ : Type u} [normed_space ℝ α] [normed_space ℝ β] [normed_space ℝ γ]

def smooth_at : ∀ (x : α) (f : α → β), Prop := sorry

lemma smooth_at_congr {x : α} {f g : α → β} {U : set α}  (U_nhd : U ∈ (nhds x).sets) (Hcongr : ∀ x ∈ U, f x = g x) :
  smooth_at x f ↔ smooth_at x g :=
sorry

lemma smooth_at_comp {x} {f : α → β} {g : β → γ} :
  smooth_at x f → smooth_at (f x) g → smooth_at x (g ∘ f) := sorry

def smooth_on (U : set α) (f : α → β) : Prop := ∀ x ∈ U, smooth_at x f

lemma cont_on_of_smooth_on {U : set α} {f : α → β} : smooth_on U f → continuous_on U f :=
sorry

variables {U : set α} {V : set β}

lemma smooth_on_comp (f : α → β) (g : β → γ) :
  smooth_on U f → smooth_on V g → f '' U ⊆ V → smooth_on U (g ∘ f) :=
assume sm_f sm_g f_U_V x x_in_U,
  smooth_at_comp (sm_f x x_in_U) (sm_g (f x) $ f_U_V $ mem_image_of_mem f x_in_U)
end smooth_maps

section charts

structure chart (X : Type) :=
(domain : set X)
(target : Type)
[normed_target : normed_space ℝ target]
(map : X → target)
(inj : inj_on map domain)
(open_range : is_open $ map '' domain)

variables {X : Type} [inhabited X]

def chart.range (φ : chart X) := φ.map '' φ.domain
def chart.inv (φ : chart X) := inv_fun_on φ.map (φ.domain)

instance : has_coe_to_fun (chart X) := ⟨_, λ φ, φ.map⟩
instance : has_mem X (chart X) := ⟨λ x φ, x ∈ φ.domain⟩

instance chart.target_is_normed (φ : chart X) : normed_space ℝ (φ.target) :=
φ.normed_target

lemma chart.injectivity (φ : chart X) :
 ∀ (x : X), x ∈ φ.domain → ∀ (y : X), y ∈ φ.domain → φ x = φ y → x = y :=
begin
  intros,
  apply φ.inj ; assumption
end

lemma chart_inv_chart {φ : chart X} (x ∈ φ.domain) :
  φ.inv (φ x) = x :=
begin
  change inv_fun_on (φ.map) (φ.domain) (φ.map x) = x,
  rw inv_fun_on_eq',
  exact chart.injectivity φ,
  assumption
end

lemma chart_chart_inv {φ : chart X} {x : φ.target} : x ∈ φ.range → φ (φ.inv x) = x
| ⟨y, ⟨y_in, φ_y⟩⟩ := inv_fun_on_eq ⟨y, ⟨y_in, φ_y⟩⟩

lemma chart.mem_inter {φ ψ : chart X} {x : X} (h : x ∈ φ) (h' : x ∈ ψ) : x ∈ φ.domain ∩ ψ.domain :=
mem_inter h h'

lemma chart.image_inter {φ : chart X} (U V : set X) : φ '' (φ.domain ∩ U) ∩ φ '' (φ.domain ∩ V) = φ '' (φ.domain ∩ U ∩ V) :=
begin
  have : ∀ (x ∈ φ.domain ∩ U) (y ∈ φ.domain ∩ V), φ x = φ y → x = y,
  { intros x x_in y y_in,
    apply φ.injectivity,
    easy },
  have : φ '' (φ.domain ∩ V) ∩ φ '' (φ.domain ∩ U) = φ '' (φ.domain ∩ V ∩ (φ.domain ∩ U))
    := image_inter_on this,
  have tauto : φ.domain ∩ V ∩ (φ.domain ∩ U) = φ.domain ∩ U ∩ V,
    by easy,
  rwa [inter_comm, tauto] at this
end

def transition (φ ψ : chart X) : φ.target → ψ.target :=
ψ ∘ φ.inv

lemma transition_comp (φ ψ χ : chart X) (x : φ.target) :
  x ∈ φ '' (φ.domain ∩ ψ.domain ∩ χ.domain) → transition φ χ x = ((transition ψ χ) ∘ (transition φ ψ)) x :=
begin
  intro h,
  change χ.map (φ.inv x) =
    (χ.map ((ψ.inv) (ψ (φ.inv x)))),
  rcases h with ⟨y, ⟨⟨y_in_φ, y_in_ψ⟩, y_in_χ⟩, ψ_y⟩,
  rw chart_inv_chart,
  rw [←ψ_y, chart_inv_chart] ; assumption
end

@[simp]
lemma transition_self {φ : chart X} : ∀ y ∈ φ.range, transition φ φ y = y :=
begin
  intros,
  change φ (chart.inv φ y) = y,
  simp [chart_chart_inv, *]
end

@[simp]
lemma transition_inverse {φ ψ : chart X} {y : φ.target} (H : y ∈ φ '' (φ.domain ∩ ψ.domain)) :
  transition ψ φ (transition φ ψ y) = y  :=
begin
  change ((transition ψ φ) ∘ transition φ ψ) y = y,
  rw ←transition_comp,
  { have : y ∈ φ.range := image_subset φ (inter_subset_left _ _) H,
    simp [*] },
  have : φ.domain ∩ ψ.domain ∩ φ.domain = φ.domain ∩ ψ.domain,
    by easy,
  simp [this, H]
end

lemma image_transition_eq_preimage {φ ψ : chart X} {U : set φ.target} :
  U ⊆ φ '' (φ.domain ∩ ψ.domain) → (transition φ ψ) '' U = (transition ψ φ) ⁻¹' U ∩ ψ ''(φ.domain ∩ ψ.domain) :=
begin
  intro sub,
  ext x,
  split,
  { intro x_in,
    rcases x_in with ⟨y, ⟨y_in_U, tr_y_x⟩⟩,
    have : transition ψ φ x = y,
    { rw ←tr_y_x,
      exact transition_inverse (sub y_in_U) },
    split,
    { rw mem_preimage_eq,
      cc },
    { existsi φ.inv y,
      split,
      { rcases sub y_in_U with ⟨a, ⟨⟨h, h'⟩, h''⟩⟩,
        rw [←h'', chart_inv_chart] ; try { split } ; assumption },
      { exact tr_y_x } } },
  { intro h,
    cases h with tr_x_in x_in_ψ_inter,
    rw inter_comm at x_in_ψ_inter,
    existsi [transition ψ φ x, tr_x_in],
    simp[transition_inverse, *] }
end

def is_open_intersection (φ ψ : chart X) :=
is_open (φ '' (φ.domain ∩ ψ.domain))

def is_smooth_transition (φ ψ : chart X) :=
smooth_on (φ '' (φ.domain ∩ ψ.domain)) (transition φ ψ)

lemma open_transition_of_compatible {φ ψ : chart X} {U : set φ.target} :
  is_smooth_transition ψ φ → is_open U → U ⊆ φ '' (φ.domain ∩ ψ.domain) → is_open ((transition φ ψ) '' U) :=
begin
  intros sm op sub,
  rw image_transition_eq_preimage sub,
  simpa [inter_comm] using cont_on_of_smooth_on sm U op
end

structure smooth_compatible (φ ψ : chart X) : Prop :=
(open_intersection  : is_open_intersection φ ψ)
(smooth_transition  : is_smooth_transition φ ψ)
end charts

section atlases
variables (X : Type) [inhabited X]
structure smooth_atlas :=
(charts : set (chart X))
(covering : ∀ m : X, ∃ φ ∈ charts, m ∈ φ)
(compatibility : ∀ φ ψ ∈ charts, smooth_compatible φ ψ)

lemma open_triple_intersection {φ ψ χ : chart X} :
smooth_compatible φ ψ → smooth_compatible ψ φ → smooth_compatible ψ χ → is_open (φ '' (φ.domain ∩ ψ.domain ∩ χ.domain))
 :=
begin
  intros h h' h'',
  rcases h with ⟨op_φ_ψ, smooth_φ_ψ⟩,
  rcases h' with ⟨op_ψ_φ, smooth_ψ_φ⟩,
  rcases h'' with ⟨op_ψ_χ, smooth_ψ_χ⟩,
  have op := is_open_inter op_ψ_φ op_ψ_χ,
  rw chart.image_inter at op,

  have : ψ '' (ψ.domain ∩ φ.domain ∩ χ.domain) ⊆ ψ '' (ψ.domain ∩ φ.domain) :=
    image_subset ψ (inter_subset_left _ _),
  have op := open_transition_of_compatible smooth_φ_ψ op this,
  have h : transition ψ φ '' (ψ '' (ψ.domain ∩ φ.domain ∩ χ.domain)) = φ '' (ψ.domain ∩ φ.domain ∩ χ.domain),
  { rw [←image_comp, image_eq_image_of_eq_on],
    intros x x_in,
    rcases x_in with ⟨⟨x_in_ψ, x_in_φ⟩, x_in_χ⟩,
    change φ (ψ.inv (ψ x)) = φ x,
    rwa chart_inv_chart },
  have comm : ψ.domain ∩ φ.domain ∩ χ.domain = φ.domain ∩ ψ.domain ∩ χ.domain,
    by easy,
  rwa [h, comm] at op
end

lemma smooth_atlas_eqv_aux {a b c : smooth_atlas X} {φ χ : chart X}
  (φ_in_a : φ ∈ a.charts) (χ_in_c : χ ∈ c.charts)
  (h₁ : ∀ (ψ : chart X), ψ ∈ b.charts → smooth_compatible φ ψ ∧ smooth_compatible ψ φ)
  (h₂ : ∀ (ψ : chart X), ψ ∈ b.charts → smooth_compatible ψ χ ∧ smooth_compatible χ ψ)
: smooth_compatible φ χ :=
begin
  constructor,
    { apply is_open_iff_forall_mem_open.2,
      intros x x_in,
      rcases x_in with ⟨y, ⟨y_in_φ, y_in_χ⟩, φ_y⟩,
      rcases b.covering y with ⟨ψ, ψ_in_b, y_in_ψ⟩,
      have H : φ '' (φ.domain ∩ ψ.domain ∩ χ.domain) ⊆ φ '' (φ.domain ∩ χ.domain),
      { apply image_subset,
        intros x h,
        easy },
      existsi [φ '' (φ.domain ∩ ψ.domain ∩ χ.domain), H],
      exact ⟨open_triple_intersection X (h₁ ψ ψ_in_b).1 (h₁ ψ ψ_in_b).2 (h₂ ψ ψ_in_b).1,
             ⟨y, by { easy}⟩⟩ },
  { intros x x_in,
    rcases x_in with ⟨y, ⟨y_in_φ, y_in_χ⟩, φ_y⟩,
    rcases b.covering y with ⟨ψ, ψ_in_b, y_in_ψ⟩,
    rcases h₁ ψ ψ_in_b with ⟨⟨op_φ_ψ, smooth_φ_ψ⟩, ⟨op_ψ_φ, smooth_ψ_φ⟩⟩,
    rcases h₂ ψ ψ_in_b with ⟨⟨op_ψ_χ, smooth_ψ_χ⟩, ⟨op_χ_ψ, smooth_χ_ψ⟩⟩,

    have : y ∈ φ.domain ∩ ψ.domain ∩ χ.domain,
      by easy,
    let W := φ '' (φ.domain ∩ ψ.domain ∩ χ.domain),
    have x_in_W : x ∈ W := φ_y ▸ mem_image_of_mem φ this,
    have W_nhds_x : W ∈ (nhds x).sets :=
      mem_nhds_sets (open_triple_intersection X (h₁ ψ ψ_in_b).1 (h₁ ψ ψ_in_b).2 (h₂ ψ ψ_in_b).1) x_in_W,

    rw smooth_at_congr W_nhds_x (transition_comp φ ψ χ),
    change smooth_at x (transition ψ χ ∘ transition φ ψ),
    apply smooth_at_comp,
    { exact smooth_φ_ψ x (φ_y ▸ mem_image_of_mem φ ⟨y_in_φ, y_in_ψ⟩) },
    { apply smooth_ψ_χ,
      existsi y,
      split,
      { easy },
      { rw ←φ_y,
        change ψ y = ψ (chart.inv φ (φ y)),
        rwa chart_inv_chart } } }
end

instance smooth_atlas_eqv : setoid (smooth_atlas X) :=
⟨λ a b, ∀ (φ ∈ a.charts) (ψ ∈ b.charts),
  (smooth_compatible φ ψ) ∧ (smooth_compatible ψ φ),
  begin
    apply mk_equivalence,
    { intros a φ φ_in_a ψ ψ_in_a,
      exact ⟨a.compatibility φ ψ φ_in_a ψ_in_a, a.compatibility ψ φ ψ_in_a φ_in_a⟩ },
    { intros a b H ψ ψ_in_b φ φ_in_a,
      finish },
    { intros a b c h₁ h₂ φ φ_in_a χ χ_in_c,
      specialize h₁ φ φ_in_a,
      replace h₂ := λ ψ ψ_in_b, h₂ ψ ψ_in_b χ χ_in_c,
      split,
      exact smooth_atlas_eqv_aux X φ_in_a χ_in_c h₁ h₂,
      apply smooth_atlas_eqv_aux X χ_in_c φ_in_a,
      swap 3,
      exact b,
      all_goals { simp * {contextual := tt} } }
  end⟩

def smooth_atlas_class := quotient $ smooth_atlas_eqv X

variable {X}
def atlases (atlas_class : smooth_atlas_class X) : set (smooth_atlas X) :=
{ a | ⟦a⟧ = atlas_class }

def charts (atlas_class : smooth_atlas_class X) : set (chart X) :=
⋃₀ (smooth_atlas.charts '' atlases atlas_class)

def chart_domains (atlas_class : smooth_atlas_class X) : set (set X) :=
chart.domain '' (charts atlas_class)

open topological_space

def smooth_atlas_class.to_topology (atlas_class : smooth_atlas_class X) : topological_space X :=
generate_from (chart_domains atlas_class)

variable (X)
class smooth_manifold :=
(dim : ℕ)
(atlas_class : smooth_atlas_class X)
(is_t2 : @t2_space X (smooth_atlas_class.to_topology atlas_class))
(is_second_countable : @second_countable_topology X (smooth_atlas_class.to_topology atlas_class))

end atlases

namespace smooth_manifold
variables (X : Type) [inhabited X] [smooth_manifold X]

def charts := charts (smooth_manifold.atlas_class X)

def domains := chart.domain '' charts X

def topology := smooth_atlas_class.to_topology (smooth_manifold.atlas_class X)
end smooth_manifold


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

! This file was ported from Lean 3 source module ring_theory.class_group
! leanprover-community/mathlib commit 565eb991e264d0db702722b4bde52ee5173c9950
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.GroupTheory.QuotientGroup
import Mathbin.RingTheory.DedekindDomain.Ideal

/-!
# The ideal class group

This file defines the ideal class group `class_group R` of fractional ideals of `R`
inside its field of fractions.

## Main definitions
 - `to_principal_ideal` sends an invertible `x : K` to an invertible fractional ideal
 - `class_group` is the quotient of invertible fractional ideals modulo `to_principal_ideal.range`
 - `class_group.mk0` sends a nonzero integral ideal in a Dedekind domain to its class

## Main results
 - `class_group.mk0_eq_mk0_iff` shows the equivalence with the "classical" definition,
   where `I ~ J` iff `x I = y J` for `x y ≠ (0 : R)`

## Implementation details

The definition of `class_group R` involves `fraction_ring R`. However, the API should be completely
identical no matter the choice of field of fractions for `R`.
-/

variable {R K L : Type _} [CommRing R]

variable [Field K] [Field L] [DecidableEq L]

variable [Algebra R K] [IsFractionRing R K]

variable [Algebra K L] [FiniteDimensional K L]

variable [Algebra R L] [IsScalarTower R K L]

open nonZeroDivisors

open IsLocalization IsFractionRing FractionalIdeal Units

section

variable (R K)

/-- `to_principal_ideal R K x` sends `x ≠ 0 : K` to the fractional `R`-ideal generated by `x` -/
irreducible_def toPrincipalIdeal : Kˣ →* (FractionalIdeal R⁰ K)ˣ :=
  { toFun := fun x =>
      ⟨spanSingleton _ x, spanSingleton _ x⁻¹, by
        simp only [span_singleton_one, Units.mul_inv', span_singleton_mul_span_singleton], by
        simp only [span_singleton_one, Units.inv_mul', span_singleton_mul_span_singleton]⟩
    map_mul' := fun x y =>
      ext (by simp only [Units.val_mk, Units.val_mul, span_singleton_mul_span_singleton])
    map_one' := ext (by simp only [span_singleton_one, Units.val_mk, Units.val_one]) }
#align to_principal_ideal toPrincipalIdeal

variable {R K}

@[simp]
theorem coe_toPrincipalIdeal (x : Kˣ) :
    (toPrincipalIdeal R K x : FractionalIdeal R⁰ K) = spanSingleton _ x :=
  by
  simp only [toPrincipalIdeal]
  rfl
#align coe_to_principal_ideal coe_toPrincipalIdeal

@[simp]
theorem toPrincipalIdeal_eq_iff {I : (FractionalIdeal R⁰ K)ˣ} {x : Kˣ} :
    toPrincipalIdeal R K x = I ↔ spanSingleton R⁰ (x : K) = I :=
  by
  simp only [toPrincipalIdeal]
  exact Units.ext_iff
#align to_principal_ideal_eq_iff toPrincipalIdeal_eq_iff

theorem mem_principal_ideals_iff {I : (FractionalIdeal R⁰ K)ˣ} :
    I ∈ (toPrincipalIdeal R K).range ↔ ∃ x : K, spanSingleton R⁰ x = I :=
  by
  simp only [MonoidHom.mem_range, toPrincipalIdeal_eq_iff]
  constructor <;> rintro ⟨x, hx⟩
  · exact ⟨x, hx⟩
  · refine' ⟨Units.mk0 x _, hx⟩
    rintro rfl
    simpa [I.ne_zero.symm] using hx
#align mem_principal_ideals_iff mem_principal_ideals_iff

instance PrincipalIdeals.normal : (toPrincipalIdeal R K).range.Normal :=
  Subgroup.normal_of_comm _
#align principal_ideals.normal PrincipalIdeals.normal

end

variable (R) [IsDomain R]

/-- The ideal class group of `R` is the group of invertible fractional ideals
modulo the principal ideals. -/
def ClassGroup :=
  (FractionalIdeal R⁰ (FractionRing R))ˣ ⧸ (toPrincipalIdeal R (FractionRing R)).range deriving
  CommGroup
#align class_group ClassGroup

noncomputable instance : Inhabited (ClassGroup R) :=
  ⟨1⟩

variable {R K}

/-- Send a nonzero fractional ideal to the corresponding class in the class group. -/
noncomputable def ClassGroup.mk : (FractionalIdeal R⁰ K)ˣ →* ClassGroup R :=
  (QuotientGroup.mk' (toPrincipalIdeal R (FractionRing R)).range).comp
    (Units.map (FractionalIdeal.canonicalEquiv R⁰ K (FractionRing R)))
#align class_group.mk ClassGroup.mk

theorem ClassGroup.mk_eq_mk {I J : (FractionalIdeal R⁰ <| FractionRing R)ˣ} :
    ClassGroup.mk I = ClassGroup.mk J ↔
      ∃ x : (FractionRing R)ˣ, I * toPrincipalIdeal R (FractionRing R) x = J :=
  by
  erw [QuotientGroup.mk'_eq_mk', canonical_equiv_self, Units.map_id, Set.exists_range_iff]
  rfl
#align class_group.mk_eq_mk ClassGroup.mk_eq_mk

theorem ClassGroup.mk_eq_mk_of_coe_ideal {I J : (FractionalIdeal R⁰ <| FractionRing R)ˣ}
    {I' J' : Ideal R} (hI : (I : FractionalIdeal R⁰ <| FractionRing R) = I')
    (hJ : (J : FractionalIdeal R⁰ <| FractionRing R) = J') :
    ClassGroup.mk I = ClassGroup.mk J ↔
      ∃ x y : R, x ≠ 0 ∧ y ≠ 0 ∧ Ideal.span {x} * I' = Ideal.span {y} * J' :=
  by
  rw [ClassGroup.mk_eq_mk]
  constructor
  · rintro ⟨x, rfl⟩
    rw [Units.val_mul, hI, coe_toPrincipalIdeal, mul_comm,
      span_singleton_mul_coe_ideal_eq_coe_ideal] at hJ
    exact ⟨_, _, sec_fst_ne_zero le_rfl x.ne_zero, sec_snd_ne_zero le_rfl ↑x, hJ⟩
  · rintro ⟨x, y, hx, hy, h⟩
    constructor
    rw [mul_comm, ← Units.eq_iff, Units.val_mul, coe_toPrincipalIdeal]
    convert(mk'_mul_coe_ideal_eq_coe_ideal (FractionRing R) <| mem_nonZeroDivisors_of_ne_zero hy).2
        h
    apply (Ne.isUnit _).unit_spec
    rwa [Ne, mk'_eq_zero_iff_eq_zero]
#align class_group.mk_eq_mk_of_coe_ideal ClassGroup.mk_eq_mk_of_coe_ideal

theorem ClassGroup.mk_eq_one_of_coe_ideal {I : (FractionalIdeal R⁰ <| FractionRing R)ˣ}
    {I' : Ideal R} (hI : (I : FractionalIdeal R⁰ <| FractionRing R) = I') :
    ClassGroup.mk I = 1 ↔ ∃ x : R, x ≠ 0 ∧ I' = Ideal.span {x} :=
  by
  rw [← map_one ClassGroup.mk, ClassGroup.mk_eq_mk_of_coe_ideal hI (_ : _ = ↑⊤)]
  any_goals rfl
  constructor
  · rintro ⟨x, y, hx, hy, h⟩
    rw [Ideal.mul_top] at h
    rcases ideal.mem_span_singleton_mul.mp ((Ideal.span_singleton_le_iff_mem _).mp h.ge) with
      ⟨i, hi, rfl⟩
    rw [← Ideal.span_singleton_mul_span_singleton, Ideal.span_singleton_mul_right_inj hx] at h
    exact ⟨i, right_ne_zero_of_mul hy, h⟩
  · rintro ⟨x, hx, rfl⟩
    exact ⟨1, x, one_ne_zero, hx, by rw [Ideal.span_singleton_one, Ideal.top_mul, Ideal.mul_top]⟩
#align class_group.mk_eq_one_of_coe_ideal ClassGroup.mk_eq_one_of_coe_ideal

variable (K)

/-- Induction principle for the class group: to show something holds for all `x : class_group R`,
we can choose a fraction field `K` and show it holds for the equivalence class of each
`I : fractional_ideal R⁰ K`. -/
@[elab_as_elim]
theorem ClassGroup.induction {P : ClassGroup R → Prop}
    (h : ∀ I : (FractionalIdeal R⁰ K)ˣ, P (ClassGroup.mk I)) (x : ClassGroup R) : P x :=
  QuotientGroup.induction_on x fun I =>
    by
    convert h (Units.mapEquiv (↑(canonical_equiv R⁰ (FractionRing R) K)) I)
    ext : 1
    rw [Units.coe_map, Units.coe_mapEquiv]
    exact (canonical_equiv_flip R⁰ K (FractionRing R) I).symm
#align class_group.induction ClassGroup.induction

/-- The definition of the class group does not depend on the choice of field of fractions. -/
noncomputable def ClassGroup.equiv :
    ClassGroup R ≃* (FractionalIdeal R⁰ K)ˣ ⧸ (toPrincipalIdeal R K).range :=
  QuotientGroup.congr _ _
      (Units.mapEquiv
        (FractionalIdeal.canonicalEquiv R⁰ (FractionRing R) K :
          FractionalIdeal R⁰ (FractionRing R) ≃* FractionalIdeal R⁰ K)) <|
    by
    ext I
    simp only [Subgroup.mem_map, mem_principal_ideals_iff, MonoidHom.coe_coe]
    constructor
    · rintro ⟨I, ⟨x, hx⟩, rfl⟩
      refine' ⟨FractionRing.algEquiv R K x, _⟩
      rw [Units.coe_mapEquiv, ← hx, RingEquiv.coe_toMulEquiv, canonical_equiv_span_singleton]
      rfl
    · rintro ⟨x, hx⟩
      refine'
        ⟨Units.mapEquiv (↑(canonical_equiv R⁰ K (FractionRing R))) I,
          ⟨(FractionRing.algEquiv R K).symm x, _⟩, Units.ext _⟩
      · rw [Units.coe_mapEquiv, ← hx, RingEquiv.coe_toMulEquiv, canonical_equiv_span_singleton]
        rfl
      simp only [RingEquiv.coe_toMulEquiv, canonical_equiv_flip, Units.coe_mapEquiv]
#align class_group.equiv ClassGroup.equiv

@[simp]
theorem ClassGroup.equiv_mk (K' : Type _) [Field K'] [Algebra R K'] [IsFractionRing R K']
    (I : (FractionalIdeal R⁰ K)ˣ) :
    ClassGroup.equiv K' (ClassGroup.mk I) =
      QuotientGroup.mk' _ (Units.mapEquiv (↑(FractionalIdeal.canonicalEquiv R⁰ K K')) I) :=
  by
  rw [ClassGroup.equiv, ClassGroup.mk, MonoidHom.comp_apply, QuotientGroup.congr_mk']
  congr
  ext : 1
  rw [Units.coe_mapEquiv, Units.coe_mapEquiv, Units.coe_map]
  exact FractionalIdeal.canonicalEquiv_canonicalEquiv _ _ _ _ _
#align class_group.equiv_mk ClassGroup.equiv_mk

@[simp]
theorem ClassGroup.mk_canonicalEquiv (K' : Type _) [Field K'] [Algebra R K'] [IsFractionRing R K']
    (I : (FractionalIdeal R⁰ K)ˣ) :
    ClassGroup.mk (Units.map (↑(canonicalEquiv R⁰ K K')) I : (FractionalIdeal R⁰ K')ˣ) =
      ClassGroup.mk I :=
  by
  rw [ClassGroup.mk, MonoidHom.comp_apply, ← MonoidHom.comp_apply (Units.map _), ← Units.map_comp, ←
      RingEquiv.coe_monoidHom_trans, FractionalIdeal.canonicalEquiv_trans_canonicalEquiv] <;>
    rfl
#align class_group.mk_canonical_equiv ClassGroup.mk_canonicalEquiv

/-- Send a nonzero integral ideal to an invertible fractional ideal. -/
noncomputable def FractionalIdeal.mk0 [IsDedekindDomain R] : (Ideal R)⁰ →* (FractionalIdeal R⁰ K)ˣ
    where
  toFun I := Units.mk0 I (coe_ideal_ne_zero.mpr <| mem_nonZeroDivisors_iff_ne_zero.mp I.2)
  map_one' := by simp
  map_mul' x y := by simp
#align fractional_ideal.mk0 FractionalIdeal.mk0

@[simp]
theorem FractionalIdeal.coe_mk0 [IsDedekindDomain R] (I : (Ideal R)⁰) :
    (FractionalIdeal.mk0 K I : FractionalIdeal R⁰ K) = I :=
  rfl
#align fractional_ideal.coe_mk0 FractionalIdeal.coe_mk0

theorem FractionalIdeal.canonicalEquiv_mk0 [IsDedekindDomain R] (K' : Type _) [Field K']
    [Algebra R K'] [IsFractionRing R K'] (I : (Ideal R)⁰) :
    FractionalIdeal.canonicalEquiv R⁰ K K' (FractionalIdeal.mk0 K I) = FractionalIdeal.mk0 K' I :=
  by simp only [FractionalIdeal.coe_mk0, coe_coe, FractionalIdeal.canonicalEquiv_coe_ideal]
#align fractional_ideal.canonical_equiv_mk0 FractionalIdeal.canonicalEquiv_mk0

@[simp]
theorem FractionalIdeal.map_canonicalEquiv_mk0 [IsDedekindDomain R] (K' : Type _) [Field K']
    [Algebra R K'] [IsFractionRing R K'] (I : (Ideal R)⁰) :
    Units.map (↑(FractionalIdeal.canonicalEquiv R⁰ K K')) (FractionalIdeal.mk0 K I) =
      FractionalIdeal.mk0 K' I :=
  Units.ext (FractionalIdeal.canonicalEquiv_mk0 K K' I)
#align fractional_ideal.map_canonical_equiv_mk0 FractionalIdeal.map_canonicalEquiv_mk0

/-- Send a nonzero ideal to the corresponding class in the class group. -/
noncomputable def ClassGroup.mk0 [IsDedekindDomain R] : (Ideal R)⁰ →* ClassGroup R :=
  ClassGroup.mk.comp (FractionalIdeal.mk0 (FractionRing R))
#align class_group.mk0 ClassGroup.mk0

@[simp]
theorem ClassGroup.mk_mk0 [IsDedekindDomain R] (I : (Ideal R)⁰) :
    ClassGroup.mk (FractionalIdeal.mk0 K I) = ClassGroup.mk0 I := by
  rw [ClassGroup.mk0, MonoidHom.comp_apply, ← ClassGroup.mk_canonicalEquiv K (FractionRing R),
    FractionalIdeal.map_canonicalEquiv_mk0]
#align class_group.mk_mk0 ClassGroup.mk_mk0

@[simp]
theorem ClassGroup.equiv_mk0 [IsDedekindDomain R] (I : (Ideal R)⁰) :
    ClassGroup.equiv K (ClassGroup.mk0 I) =
      QuotientGroup.mk' (toPrincipalIdeal R K).range (FractionalIdeal.mk0 K I) :=
  by
  rw [ClassGroup.mk0, MonoidHom.comp_apply, ClassGroup.equiv_mk]
  congr
  ext
  simp
#align class_group.equiv_mk0 ClassGroup.equiv_mk0

/- ./././Mathport/Syntax/Translate/Basic.lean:635:2: warning: expanding binder collection (x «expr ≠ » (0 : K)) -/
theorem ClassGroup.mk0_eq_mk0_iff_exists_fraction_ring [IsDedekindDomain R] {I J : (Ideal R)⁰} :
    ClassGroup.mk0 I = ClassGroup.mk0 J ↔ ∃ (x : _)(_ : x ≠ (0 : K)), spanSingleton R⁰ x * I = J :=
  by
  refine' (ClassGroup.equiv K).Injective.eq_iff.symm.trans _
  simp only [ClassGroup.equiv_mk0, QuotientGroup.mk'_eq_mk', mem_principal_ideals_iff, coe_coe,
    Units.ext_iff, Units.val_mul, FractionalIdeal.coe_mk0, exists_prop]
  constructor
  · rintro ⟨X, ⟨x, hX⟩, hx⟩
    refine' ⟨x, _, _⟩
    · rintro rfl
      simpa [X.ne_zero.symm] using hX
    simpa only [hX, mul_comm] using hx
  · rintro ⟨x, hx, eq_J⟩
    refine' ⟨Units.mk0 _ (span_singleton_ne_zero_iff.mpr hx), ⟨x, rfl⟩, _⟩
    simpa only [mul_comm] using eq_J
#align class_group.mk0_eq_mk0_iff_exists_fraction_ring ClassGroup.mk0_eq_mk0_iff_exists_fraction_ring

variable {K}

theorem ClassGroup.mk0_eq_mk0_iff [IsDedekindDomain R] {I J : (Ideal R)⁰} :
    ClassGroup.mk0 I = ClassGroup.mk0 J ↔
      ∃ (x y : R)(hx : x ≠ 0)(hy : y ≠ 0), Ideal.span {x} * (I : Ideal R) = Ideal.span {y} * J :=
  by
  refine' (ClassGroup.mk0_eq_mk0_iff_exists_fraction_ring (FractionRing R)).trans ⟨_, _⟩
  · rintro ⟨z, hz, h⟩
    obtain ⟨x, ⟨y, hy⟩, rfl⟩ := IsLocalization.mk'_surjective R⁰ z
    refine' ⟨x, y, _, mem_non_zero_divisors_iff_ne_zero.mp hy, _⟩
    · rintro hx
      apply hz
      rw [hx, IsFractionRing.mk'_eq_div, _root_.map_zero, zero_div]
    · exact (FractionalIdeal.mk'_mul_coe_ideal_eq_coe_ideal _ hy).mp h
  · rintro ⟨x, y, hx, hy, h⟩
    have hy' : y ∈ R⁰ := mem_non_zero_divisors_iff_ne_zero.mpr hy
    refine' ⟨IsLocalization.mk' _ x ⟨y, hy'⟩, _, _⟩
    · contrapose! hx
      rwa [mk'_eq_iff_eq_mul, MulZeroClass.zero_mul, ← (algebraMap R (FractionRing R)).map_zero,
        (IsFractionRing.injective R (FractionRing R)).eq_iff] at hx
    · exact (FractionalIdeal.mk'_mul_coe_ideal_eq_coe_ideal _ hy').mpr h
#align class_group.mk0_eq_mk0_iff ClassGroup.mk0_eq_mk0_iff

theorem ClassGroup.mk0_surjective [IsDedekindDomain R] :
    Function.Surjective (ClassGroup.mk0 : (Ideal R)⁰ → ClassGroup R) :=
  by
  rintro ⟨I⟩
  obtain ⟨a, a_ne_zero', ha⟩ := I.1.2
  have a_ne_zero := mem_non_zero_divisors_iff_ne_zero.mp a_ne_zero'
  have fa_ne_zero : (algebraMap R (FractionRing R)) a ≠ 0 :=
    IsFractionRing.to_map_ne_zero_of_mem_nonZeroDivisors a_ne_zero'
  refine' ⟨⟨{ carrier := { x | (algebraMap R _ a)⁻¹ * algebraMap R _ x ∈ I.1 }.. }, _⟩, _⟩
  · simp only [RingHom.map_add, Set.mem_setOf_eq, MulZeroClass.mul_zero, RingHom.map_mul, mul_add]
    exact fun _ _ ha hb => Submodule.add_mem I ha hb
  · simp only [RingHom.map_zero, Set.mem_setOf_eq, MulZeroClass.mul_zero, RingHom.map_mul]
    exact Submodule.zero_mem I
  · intro c _ hb
    simp only [smul_eq_mul, Set.mem_setOf_eq, MulZeroClass.mul_zero, RingHom.map_mul, mul_add,
      mul_left_comm ((algebraMap R (FractionRing R)) a)⁻¹]
    rw [← Algebra.smul_def c]
    exact Submodule.smul_mem I c hb
  · rw [mem_nonZeroDivisors_iff_ne_zero, Submodule.zero_eq_bot, Submodule.ne_bot_iff]
    obtain ⟨x, x_ne, x_mem⟩ := exists_ne_zero_mem_is_integer I.ne_zero
    refine' ⟨a * x, _, mul_ne_zero a_ne_zero x_ne⟩
    change ((algebraMap R _) a)⁻¹ * (algebraMap R _) (a * x) ∈ I.1
    rwa [RingHom.map_mul, ← mul_assoc, inv_mul_cancel fa_ne_zero, one_mul]
  · symm
    apply Quotient.sound
    change Setoid.r _ _
    rw [QuotientGroup.leftRel_apply]
    refine' ⟨Units.mk0 (algebraMap R _ a) fa_ne_zero, _⟩
    rw [_root_.eq_inv_mul_iff_mul_eq, eq_comm, mul_comm I]
    apply Units.ext
    simp only [FractionalIdeal.coe_mk0, FractionalIdeal.map_canonicalEquiv_mk0, [anonymous],
      Units.val_mk0, coe_toPrincipalIdeal, coe_coe, Units.val_mul,
      FractionalIdeal.eq_spanSingleton_mul]
    constructor
    · intro zJ' hzJ'
      obtain ⟨zJ, hzJ : (algebraMap R _ a)⁻¹ * algebraMap R _ zJ ∈ ↑I, rfl⟩ :=
        (mem_coe_ideal R⁰).mp hzJ'
      refine' ⟨_, hzJ, _⟩
      rw [← mul_assoc, mul_inv_cancel fa_ne_zero, one_mul]
    · intro zI' hzI'
      obtain ⟨y, hy⟩ := ha zI' hzI'
      rw [← Algebra.smul_def, mem_coe_ideal]
      refine' ⟨y, _, hy⟩
      show (algebraMap R _ a)⁻¹ * algebraMap R _ y ∈ (I : FractionalIdeal R⁰ (FractionRing R))
      rwa [hy, Algebra.smul_def, ← mul_assoc, inv_mul_cancel fa_ne_zero, one_mul]
#align class_group.mk0_surjective ClassGroup.mk0_surjective

theorem ClassGroup.mk_eq_one_iff {I : (FractionalIdeal R⁰ K)ˣ} :
    ClassGroup.mk I = 1 ↔ (I : Submodule R K).IsPrincipal :=
  by
  simp only [← (ClassGroup.equiv K).Injective.eq_iff, _root_.map_one, ClassGroup.equiv_mk,
    QuotientGroup.mk'_apply, QuotientGroup.eq_one_iff, MonoidHom.mem_range, Units.ext_iff,
    coe_toPrincipalIdeal, Units.coe_mapEquiv, FractionalIdeal.canonicalEquiv_self, coe_coe,
    RingEquiv.coe_mulEquiv_refl, MulEquiv.refl_apply]
  refine' ⟨fun ⟨x, hx⟩ => ⟨⟨x, by rw [← hx, coe_span_singleton]⟩⟩, _⟩
  intro hI
  obtain ⟨x, hx⟩ := @Submodule.IsPrincipal.principal _ _ _ _ _ _ hI
  have hx' : (I : FractionalIdeal R⁰ K) = span_singleton R⁰ x :=
    by
    apply Subtype.coe_injective
    rw [hx, coe_span_singleton]
  refine' ⟨Units.mk0 x _, _⟩
  · intro x_eq
    apply Units.ne_zero I
    simp [hx', x_eq]
  simp [hx']
#align class_group.mk_eq_one_iff ClassGroup.mk_eq_one_iff

theorem ClassGroup.mk0_eq_one_iff [IsDedekindDomain R] {I : Ideal R} (hI : I ∈ (Ideal R)⁰) :
    ClassGroup.mk0 ⟨I, hI⟩ = 1 ↔ I.IsPrincipal :=
  ClassGroup.mk_eq_one_iff.trans (coeSubmodule_isPrincipal R _)
#align class_group.mk0_eq_one_iff ClassGroup.mk0_eq_one_iff

/-- The class group of principal ideal domain is finite (in fact a singleton).

See `class_group.fintype_of_admissible` for a finiteness proof that works for rings of integers
of global fields.
-/
noncomputable instance [IsPrincipalIdealRing R] : Fintype (ClassGroup R)
    where
  elems := {1}
  complete := by
    refine' ClassGroup.induction (FractionRing R) fun I => _
    rw [Finset.mem_singleton]
    exact class_group.mk_eq_one_iff.mpr (I : FractionalIdeal R⁰ (FractionRing R)).IsPrincipal

/-- The class number of a principal ideal domain is `1`. -/
theorem card_classGroup_eq_one [IsPrincipalIdealRing R] : Fintype.card (ClassGroup R) = 1 :=
  by
  rw [Fintype.card_eq_one_iff]
  use 1
  refine' ClassGroup.induction (FractionRing R) fun I => _
  exact class_group.mk_eq_one_iff.mpr (I : FractionalIdeal R⁰ (FractionRing R)).IsPrincipal
#align card_class_group_eq_one card_classGroup_eq_one

/-- The class number is `1` iff the ring of integers is a principal ideal domain. -/
theorem card_classGroup_eq_one_iff [IsDedekindDomain R] [Fintype (ClassGroup R)] :
    Fintype.card (ClassGroup R) = 1 ↔ IsPrincipalIdealRing R :=
  by
  constructor; swap;
  · intros
    convert card_classGroup_eq_one
    assumption
  rw [Fintype.card_eq_one_iff]
  rintro ⟨I, hI⟩
  have eq_one : ∀ J : ClassGroup R, J = 1 := fun J => trans (hI J) (hI 1).symm
  refine' ⟨fun I => _⟩
  by_cases hI : I = ⊥
  · rw [hI]
    exact bot_isPrincipal
  exact (ClassGroup.mk0_eq_one_iff (mem_non_zero_divisors_iff_ne_zero.mpr hI)).mp (eq_one _)
#align card_class_group_eq_one_iff card_classGroup_eq_one_iff


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

! This file was ported from Lean 3 source module category_theory.limits.shapes.reflexive
! leanprover-community/mathlib commit d6814c584384ddf2825ff038e868451a7c956f31
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.CategoryTheory.Limits.Shapes.Equalizers
import Mathlib.CategoryTheory.Limits.Shapes.KernelPair

/-!
# Reflexive coequalizers

We define reflexive pairs as a pair of morphisms which have a common section. We say a category has
reflexive coequalizers if it has coequalizers of all reflexive pairs.
Reflexive coequalizers often enjoy nicer properties than general coequalizers, and feature heavily
in some versions of the monadicity theorem.

We also give some examples of reflexive pairs: for an adjunction `F ⊣ G` with counit `ε`, the pair
`(FGε_B, ε_FGB)` is reflexive. If a pair `f,g` is a kernel pair for some morphism, then it is
reflexive.

# TODO
* If `C` has binary coproducts and reflexive coequalizers, then it has all coequalizers.
* If `T` is a monad on cocomplete category `C`, then `Algebra T` is cocomplete iff it has reflexive
  coequalizers.
* If `C` is locally cartesian closed and has reflexive coequalizers, then it has images: in fact
  regular epi (and hence strong epi) images.
-/

namespace CategoryTheory

universe v v₂ u u₂

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

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

variable {A B : C} {f g : A ⟶ B}

/-- The pair `f g : A ⟶ B` is reflexive if there is a morphism `B ⟶ A` which is a section for both.
-/
class IsReflexivePair (f g : A ⟶ B) : Prop where
  common_section' : ∃ s : B ⟶ A, s ≫ f = 𝟙 B ∧ s ≫ g = 𝟙 B
#align category_theory.is_reflexive_pair CategoryTheory.IsReflexivePair

-- porting note: added theorem, because of unsupported infer kinds
theorem IsReflexivePair.common_section (f g : A ⟶ B) [IsReflexivePair f g]:
  ∃ s : B ⟶ A, s ≫ f = 𝟙 B ∧ s ≫ g = 𝟙 B := IsReflexivePair.common_section'

/--
The pair `f g : A ⟶ B` is coreflexive if there is a morphism `B ⟶ A` which is a retraction for both.
-/
class IsCoreflexivePair (f g : A ⟶ B) : Prop where
  common_retraction' : ∃ s : B ⟶ A, f ≫ s = 𝟙 A ∧ g ≫ s = 𝟙 A
#align category_theory.is_coreflexive_pair CategoryTheory.IsCoreflexivePair

-- porting note: added theorem, because of unsupported infer kinds
theorem IsCoreflexivePair.common_retraction (f g : A ⟶ B) [IsCoreflexivePair f g]:
  ∃ s : B ⟶ A, f ≫ s = 𝟙 A ∧ g ≫ s = 𝟙 A := IsCoreflexivePair.common_retraction'

theorem IsCoreflexivePair.mk' (s : B ⟶ A) (fs : f ≫ s = 𝟙 A) (gs : g ≫ s = 𝟙 A) :
    IsCoreflexivePair f g :=
  ⟨⟨s, fs, gs⟩⟩
#align category_theory.is_coreflexive_pair.mk' CategoryTheory.IsCoreflexivePair.mk'

/-- Get the common section for a reflexive pair. -/
noncomputable def commonSection (f g : A ⟶ B) [IsReflexivePair f g] : B ⟶ A :=
  (IsReflexivePair.common_section f g).choose
#align category_theory.common_section CategoryTheory.commonSection

@[reassoc (attr := simp)]
theorem section_comp_left (f g : A ⟶ B) [IsReflexivePair f g] : commonSection f g ≫ f = 𝟙 B :=
  (IsReflexivePair.common_section f g).choose_spec.1
#align category_theory.section_comp_left CategoryTheory.section_comp_left

@[reassoc (attr := simp)]
theorem section_comp_right (f g : A ⟶ B) [IsReflexivePair f g] : commonSection f g ≫ g = 𝟙 B :=
  (IsReflexivePair.common_section f g).choose_spec.2
#align category_theory.section_comp_right CategoryTheory.section_comp_right

/-- Get the common retraction for a coreflexive pair. -/
noncomputable def commonRetraction (f g : A ⟶ B) [IsCoreflexivePair f g] : B ⟶ A :=
  (IsCoreflexivePair.common_retraction f g).choose
#align category_theory.common_retraction CategoryTheory.commonRetraction

@[reassoc (attr := simp)]
theorem left_comp_retraction (f g : A ⟶ B) [IsCoreflexivePair f g] :
    f ≫ commonRetraction f g = 𝟙 A :=
  (IsCoreflexivePair.common_retraction f g).choose_spec.1
#align category_theory.left_comp_retraction CategoryTheory.left_comp_retraction

@[reassoc (attr := simp)]
theorem right_comp_retraction (f g : A ⟶ B) [IsCoreflexivePair f g] :
    g ≫ commonRetraction f g = 𝟙 A :=
  (IsCoreflexivePair.common_retraction f g).choose_spec.2
#align category_theory.right_comp_retraction CategoryTheory.right_comp_retraction

/-- If `f,g` is a kernel pair for some morphism `q`, then it is reflexive. -/
theorem IsKernelPair.isReflexivePair {R : C} {f g : R ⟶ A} {q : A ⟶ B} (h : IsKernelPair q f g) :
    IsReflexivePair f g :=
  IsReflexivePair.mk' _ (h.lift' _ _ rfl).2.1 (h.lift' _ _ _).2.2
#align category_theory.is_kernel_pair.is_reflexive_pair CategoryTheory.IsKernelPair.isReflexivePair

-- This shouldn't be an instance as it would instantly loop.
/-- If `f,g` is reflexive, then `g,f` is reflexive. -/
theorem IsReflexivePair.swap [IsReflexivePair f g] : IsReflexivePair g f :=
  IsReflexivePair.mk' _ (section_comp_right f g) (section_comp_left f g)
#align category_theory.is_reflexive_pair.swap CategoryTheory.IsReflexivePair.swap

-- This shouldn't be an instance as it would instantly loop.
/-- If `f,g` is coreflexive, then `g,f` is coreflexive. -/
theorem IsCoreflexivePair.swap [IsCoreflexivePair f g] : IsCoreflexivePair g f :=
  IsCoreflexivePair.mk' _ (right_comp_retraction f g) (left_comp_retraction f g)
#align category_theory.is_coreflexive_pair.swap CategoryTheory.IsCoreflexivePair.swap

variable {F : C ⥤ D} {G : D ⥤ C} (adj : F ⊣ G)

/-- For an adjunction `F ⊣ G` with counit `ε`, the pair `(FGε_B, ε_FGB)` is reflexive. -/
instance (B : D) :
    IsReflexivePair (F.map (G.map (adj.counit.app B))) (adj.counit.app (F.obj (G.obj B))) :=
  IsReflexivePair.mk' (F.map (adj.unit.app (G.obj B)))
    (by
      rw [← F.map_comp, adj.right_triangle_components]
      apply F.map_id)
    adj.left_triangle_components

namespace Limits

variable (C)

/-- `C` has reflexive coequalizers if it has coequalizers for every reflexive pair. -/
class HasReflexiveCoequalizers : Prop where
  has_coeq : ∀ ⦃A B : C⦄ (f g : A ⟶ B) [IsReflexivePair f g], HasCoequalizer f g
#align category_theory.limits.has_reflexive_coequalizers CategoryTheory.Limits.HasReflexiveCoequalizers

/-- `C` has coreflexive equalizers if it has equalizers for every coreflexive pair. -/
class HasCoreflexiveEqualizers : Prop where
  has_eq : ∀ ⦃A B : C⦄ (f g : A ⟶ B) [IsCoreflexivePair f g], HasEqualizer f g
#align category_theory.limits.has_coreflexive_equalizers CategoryTheory.Limits.HasCoreflexiveEqualizers

attribute [instance] HasReflexiveCoequalizers.has_coeq

attribute [instance] HasCoreflexiveEqualizers.has_eq

theorem hasCoequalizer_of_common_section [HasReflexiveCoequalizers C] {A B : C} {f g : A ⟶ B}
    (r : B ⟶ A) (rf : r ≫ f = 𝟙 _) (rg : r ≫ g = 𝟙 _) : HasCoequalizer f g := by
  letI := IsReflexivePair.mk' r rf rg
  infer_instance
#align category_theory.limits.has_coequalizer_of_common_section CategoryTheory.Limits.hasCoequalizer_of_common_section

theorem hasEqualizer_of_common_retraction [HasCoreflexiveEqualizers C] {A B : C} {f g : A ⟶ B}
    (r : B ⟶ A) (fr : f ≫ r = 𝟙 _) (gr : g ≫ r = 𝟙 _) : HasEqualizer f g := by
  letI := IsCoreflexivePair.mk' r fr gr
  infer_instance
#align category_theory.limits.has_equalizer_of_common_retraction CategoryTheory.Limits.hasEqualizer_of_common_retraction

/-- If `C` has coequalizers, then it has reflexive coequalizers. -/
instance (priority := 100) hasReflexiveCoequalizers_of_hasCoequalizers [HasCoequalizers C] :
    HasReflexiveCoequalizers C where has_coeq A B f g _ := by infer_instance
#align category_theory.limits.has_reflexive_coequalizers_of_has_coequalizers CategoryTheory.Limits.hasReflexiveCoequalizers_of_hasCoequalizers

/-- If `C` has equalizers, then it has coreflexive equalizers. -/
instance (priority := 100) hasCoreflexiveEqualizers_of_hasEqualizers [HasEqualizers C] :
    HasCoreflexiveEqualizers C where has_eq A B f g _ := by infer_instance
#align category_theory.limits.has_coreflexive_equalizers_of_has_equalizers CategoryTheory.Limits.hasCoreflexiveEqualizers_of_hasEqualizers

end Limits

open Limits

end CategoryTheory


open Lean

instance : IsAssociative (α := Nat) HAdd.hAdd := ⟨Nat.add_assoc⟩
instance : IsCommutative (α := Nat) HAdd.hAdd := ⟨Nat.add_comm⟩
instance : IsNeutral HAdd.hAdd 0 := ⟨Nat.zero_add, Nat.add_zero⟩

instance : IsAssociative (α := Nat) HMul.hMul := ⟨Nat.mul_assoc⟩
instance : IsCommutative (α := Nat) HMul.hMul := ⟨Nat.mul_comm⟩
instance : IsNeutral HMul.hMul 1 := ⟨Nat.one_mul, Nat.mul_one⟩

@[simp] theorem succ_le_succ_iff {x y : Nat} : x.succ ≤ y.succ ↔ x ≤ y :=
  ⟨Nat.le_of_succ_le_succ, Nat.succ_le_succ⟩

@[simp] theorem add_le_add_right_iff {x y z : Nat} : x + z ≤ y + z ↔ x ≤ y := by
  induction z <;> simp_all [Nat.add_succ]

set_option linter.unusedVariables false in
theorem le_ext : ∀ {x y : Nat} (h : ∀ z, z ≤ x ↔ z ≤ y), x = y
  | 0, 0, _ => rfl
  | x+1, y+1, h => congrArg (· + 1) <| le_ext fun z => have := h (z + 1); by simp_all
  | 0, y+1, h => have := h 1; by simp_all
  | x+1, 0, h => have := h 1; by simp_all

theorem le_or_le : ∀ (a b : Nat), a ≤ b ∨ b ≤ a
  | x+1, y+1 => by simp [le_or_le x y]
  | 0, 0 | x+1, 0 | 0, y+1 => by simp

theorem le_of_not_le {a b : Nat} (h : ¬ a ≤ b) : b ≤ a :=
  match le_or_le a b with | .inl ab => (h ab).rec | .inr ba => ba

@[simp] theorem le_max_iff {x y z : Nat} : x ≤ max y z ↔ x ≤ y ∨ x ≤ z := by
  simp only [Nat.max_def]
  split
  · exact Iff.intro .inr fun | .inl xy => Nat.le_trans ‹_› ‹_› | .inr xz => ‹_›
  · exact Iff.intro .inl fun | .inl xy => ‹_› | .inr xz => Nat.le_trans ‹_› (le_of_not_le ‹_›)

theorem or_assoc : (p ∨ q) ∨ r ↔ p ∨ (q ∨ r) := by
  by_cases p <;> by_cases q <;> by_cases r <;> simp_all

theorem or_comm : p ∨ q ↔ q ∨ p := by
  by_cases p <;> by_cases q <;> simp_all

theorem max_assoc (n m k : Nat) : max (max n m) k = max n (max m k) :=
  le_ext (by simp [or_assoc])

theorem max_comm (n m : Nat) : max n m = max m n :=
  le_ext (by simp [or_comm])

theorem max_idem (n : Nat) : max n n = n := le_ext (by simp)

theorem Nat.zero_max (n : Nat) : max 0 n = n := by simp [Nat.max_def]

theorem Nat.max_zero (n : Nat) : max n 0 = n := by rw [max_comm, Nat.zero_max]

instance : IsAssociative (α := Nat) max := ⟨max_assoc⟩
instance : IsCommutative (α := Nat) max := ⟨max_comm⟩
instance : IsIdempotent (α := Nat) max := ⟨max_idem⟩
instance : IsNeutral max 0 := ⟨Nat.zero_max, Nat.max_zero⟩

instance : IsAssociative And := ⟨λ p q r => propext ⟨λ ⟨⟨hp, hq⟩, hr⟩ => ⟨hp, hq, hr⟩, λ ⟨hp, hq, hr⟩ => ⟨⟨hp, hq⟩, hr⟩⟩⟩
instance : IsCommutative And := ⟨λ p q => propext ⟨λ ⟨hp, hq⟩ => ⟨hq, hp⟩, λ ⟨hq, hp⟩ => ⟨hp, hq⟩⟩⟩
instance : IsIdempotent And := ⟨λ p => propext ⟨λ ⟨hp, _⟩ => hp, λ hp => ⟨hp, hp⟩⟩⟩
instance : IsNeutral And True :=
  ⟨λ p => propext ⟨λ ⟨_, hp⟩ => hp, λ hp => ⟨True.intro, hp⟩⟩, λ p => propext ⟨λ ⟨hp, _⟩ => hp, λ hp => ⟨hp, True.intro⟩⟩⟩

instance : IsAssociative Or := ⟨by simp [or_assoc]⟩
instance : IsCommutative Or := ⟨λ p q => propext ⟨λ hpq => hpq.elim Or.inr Or.inl, λ hqp => hqp.elim Or.inr Or.inl⟩⟩
instance : IsIdempotent Or := ⟨λ p => propext ⟨λ hp => hp.elim id id, Or.inl⟩⟩
instance : IsNeutral Or False :=
  ⟨λ p => propext ⟨λ hfp => hfp.elim False.elim id, Or.inr⟩, λ p => propext ⟨λ hpf => hpf.elim id False.elim, Or.inl⟩⟩

example (x y z : Nat) : x + y + 0 + z = z + (x + y) := by ac_rfl

example (x y z : Nat) : (x + y) * (0 + z) = (x + y) * z:= by ac_rfl

example (x y z : Nat) : (x + y) * (0 + z) = 1 * z * (y + 0 + x) := by ac_rfl

theorem ex₁ (x y z : Nat) : max (0 + (max x (max z (max (0 + 0) ((max 1 0) + 0 + 0) * y)))) y = max (max x y) z := by ac_rfl
#print ex₁

example (x y : Nat) : 1 + 0 + 0 = 0 + 1 := by ac_rfl

example (x y : Nat) : (x + y = 42) = (y + x = 42) := by ac_rfl

example (x y : Nat) (P : Prop) : (x + y = 42 → P) = (y + x = 42 → P) := by ac_rfl

inductive Vector (α : Type u) : Nat → Type u where
  | nil  : Vector α 0
  | cons : α → Vector α n → Vector α (n+1)

def f (n : Nat) (xs : Vector α n) := xs

-- Repro: Dependent types trigger incorrect proofs
theorem ex₂ (n m : Nat) (xs : Vector α (n+m)) (ys : Vector α (m+n)) : (f (n+m) xs, f (m+n) ys, n+m) = (f (n+m) xs, f (m+n) ys, m+n) := by
  ac_rfl

-- Repro: Binders also trigger invalid proofs
theorem ex₃ (n : Nat) : (fun x => n + x) = (fun x => x + n) := by
  ac_rfl
#print ex₃

-- Repro: the Prop universe doesn't work
example (p q : Prop) : (p ∨ p ∨ q ∧ True) = (q ∨ p) := by
  ac_rfl

-- Repro: missing withContext
example : ∀ x : Nat, x = x := by intro x; ac_rfl