/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import data.vector
import data.list.nodup
import data.list.of_fn
import control.applicative
import meta.univs
/-!
# Additional theorems and definitions about the `vector` type

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

This file introduces the infix notation `::ᵥ` for `vector.cons`.
-/
universes u
variables {n : ℕ}

namespace vector
variables {α : Type*}

infixr ` ::ᵥ `:67  := vector.cons

attribute [simp] head_cons tail_cons

instance [inhabited α] : inhabited (vector α n) :=
⟨of_fn default⟩

theorem to_list_injective : function.injective (@to_list α n) :=
subtype.val_injective

/-- Two `v w : vector α n` are equal iff they are equal at every single index. -/
@[ext] theorem ext : ∀ {v w : vector α n}
  (h : ∀ m : fin n, vector.nth v m = vector.nth w m), v = w
| ⟨v, hv⟩ ⟨w, hw⟩ h := subtype.eq (list.ext_le (by rw [hv, hw])
  (λ m hm hn, h ⟨m, hv ▸ hm⟩))

/-- A vector with `n` elements `a`. -/
def replicate (n : ℕ) (a : α) : vector α n :=
⟨list.replicate n a, list.length_replicate n a⟩

/-- The empty `vector` is a `subsingleton`. -/
instance zero_subsingleton : subsingleton (vector α 0) :=
⟨λ _ _, vector.ext (λ m, fin.elim0 m)⟩

@[simp] theorem cons_val (a : α) : ∀ (v : vector α n), (a ::ᵥ v).val = a :: v.val
| ⟨_, _⟩ := rfl

@[simp] theorem cons_head (a : α) : ∀ (v : vector α n), (a ::ᵥ v).head = a
| ⟨_, _⟩ := rfl

@[simp] theorem cons_tail (a : α) : ∀ (v : vector α n), (a ::ᵥ v).tail = v
| ⟨_, _⟩ := rfl

lemma eq_cons_iff (a : α) (v : vector α n.succ) (v' : vector α n) :
  v = a ::ᵥ v' ↔ v.head = a ∧ v.tail = v' :=
⟨λ h, h.symm ▸ ⟨head_cons a v', tail_cons a v'⟩,
 λ h, trans (cons_head_tail v).symm (by rw [h.1, h.2])⟩

lemma ne_cons_iff (a : α) (v : vector α n.succ) (v' : vector α n) :
  v ≠ a ::ᵥ v' ↔ v.head ≠ a ∨ v.tail ≠ v' :=
by rw [ne.def, eq_cons_iff a v v', not_and_distrib]

lemma exists_eq_cons (v : vector α n.succ) :
  ∃ (a : α) (as : vector α n), v = a ::ᵥ as :=
⟨v.head, v.tail, (eq_cons_iff v.head v v.tail).2 ⟨rfl, rfl⟩⟩

@[simp] theorem to_list_of_fn : ∀ {n} (f : fin n → α), to_list (of_fn f) = list.of_fn f
| 0     f := rfl
| (n+1) f := by rw [of_fn, list.of_fn_succ, to_list_cons, to_list_of_fn]

@[simp] theorem mk_to_list :
  ∀ (v : vector α n) h, (⟨to_list v, h⟩ : vector α n) = v
| ⟨l, h₁⟩ h₂ := rfl

@[simp]
lemma length_coe (v : vector α n) :
  ((coe : { l : list α // l.length = n } → list α) v).length = n :=
v.2

@[simp] lemma to_list_map {β : Type*} (v : vector α n) (f : α → β) : (v.map f).to_list =
  v.to_list.map f := by cases v; refl

@[simp] lemma head_map {β : Type*} (v : vector α (n + 1)) (f : α → β) :
  (v.map f).head = f v.head :=
begin
  obtain ⟨a, v', h⟩ := vector.exists_eq_cons v,
  rw [h, map_cons, head_cons, head_cons],
end

@[simp] lemma tail_map {β : Type*} (v : vector α (n + 1)) (f : α → β) :
  (v.map f).tail = v.tail.map f :=
begin
  obtain ⟨a, v', h⟩ := vector.exists_eq_cons v,
  rw [h, map_cons, tail_cons, tail_cons],
end

theorem nth_eq_nth_le : ∀ (v : vector α n) (i),
  nth v i = v.to_list.nth_le i.1 (by rw to_list_length; exact i.2)
| ⟨l, h⟩ i := rfl

@[simp]
lemma nth_replicate (a : α) (i : fin n) :
  (vector.replicate n a).nth i = a :=
list.nth_le_replicate _ _

@[simp] lemma nth_map {β : Type*} (v : vector α n) (f : α → β) (i : fin n) :
  (v.map f).nth i = f (v.nth i) :=
by simp [nth_eq_nth_le]

@[simp] theorem nth_of_fn {n} (f : fin n → α) (i) : nth (of_fn f) i = f i :=
by rw [nth_eq_nth_le, ← list.nth_le_of_fn f];
   congr; apply to_list_of_fn

@[simp] theorem of_fn_nth (v : vector α n) : of_fn (nth v) = v :=
begin
  rcases v with ⟨l, rfl⟩,
  apply to_list_injective,
  change nth ⟨l, eq.refl _⟩ with λ i, nth ⟨l, rfl⟩ i,
  simpa only [to_list_of_fn] using list.of_fn_nth_le _
end

/-- The natural equivalence between length-`n` vectors and functions from `fin n`. -/
def _root_.equiv.vector_equiv_fin (α : Type*) (n : ℕ) : vector α n ≃ (fin n → α) :=
⟨vector.nth, vector.of_fn, vector.of_fn_nth, λ f, funext $ vector.nth_of_fn f⟩

theorem nth_tail (x : vector α n) (i) :
  x.tail.nth i = x.nth ⟨i.1 + 1, lt_tsub_iff_right.mp i.2⟩ :=
by { rcases x with ⟨_|_, h⟩; refl, }

@[simp]
theorem nth_tail_succ : ∀ (v : vector α n.succ) (i : fin n),
  nth (tail v) i = nth v i.succ
| ⟨a::l, e⟩ ⟨i, h⟩ := by simp [nth_eq_nth_le]; refl

@[simp] theorem tail_val : ∀ (v : vector α n.succ), v.tail.val = v.val.tail
| ⟨a::l, e⟩ := rfl

/-- The `tail` of a `nil` vector is `nil`. -/
@[simp] lemma tail_nil : (@nil α).tail = nil := rfl

/-- The `tail` of a vector made up of one element is `nil`. -/
@[simp] lemma singleton_tail (v : vector α 1) : v.tail = vector.nil :=
by simp only [←cons_head_tail, eq_iff_true_of_subsingleton]

@[simp] theorem tail_of_fn {n : ℕ} (f : fin n.succ → α) :
  tail (of_fn f) = of_fn (λ i, f i.succ) :=
(of_fn_nth _).symm.trans $ by { congr, funext i, cases i, simp, }

@[simp] theorem to_list_empty (v : vector α 0) : v.to_list = [] := list.length_eq_zero.mp v.2

/-- The list that makes up a `vector` made up of a single element,
retrieved via `to_list`, is equal to the list of that single element. -/
@[simp] lemma to_list_singleton (v : vector α 1) : v.to_list = [v.head] :=
begin
  rw ←v.cons_head_tail,
  simp only [to_list_cons, to_list_nil, cons_head, eq_self_iff_true,
             and_self, singleton_tail]
end

@[simp] lemma empty_to_list_eq_ff (v : vector α (n + 1)) : v.to_list.empty = ff :=
match v with | ⟨a :: as, _⟩ := rfl end

lemma not_empty_to_list (v : vector α (n + 1)) : ¬ v.to_list.empty :=
by simp only [empty_to_list_eq_ff, coe_sort_ff, not_false_iff]

/-- Mapping under `id` does not change a vector. -/
@[simp] lemma map_id {n : ℕ} (v : vector α n) : vector.map id v = v :=
  vector.eq _ _ (by simp only [list.map_id, vector.to_list_map])

lemma nodup_iff_nth_inj {v : vector α n} : v.to_list.nodup ↔ function.injective v.nth :=
begin
  cases v with l hl,
  subst hl,
  simp only [list.nodup_iff_nth_le_inj],
  split,
  { intros h i j hij,
    cases i, cases j, ext, apply h, simpa },
  { intros h i j hi hj hij,
    have := @h ⟨i, hi⟩ ⟨j, hj⟩, simp [nth_eq_nth_le] at *, tauto }
end

theorem head'_to_list : ∀ (v : vector α n.succ),
  (to_list v).head' = some (head v)
| ⟨a::l, e⟩ := rfl

/-- Reverse a vector. -/
def reverse (v : vector α n) : vector α n :=
⟨v.to_list.reverse, by simp⟩

/-- The `list` of a vector after a `reverse`, retrieved by `to_list` is equal
to the `list.reverse` after retrieving a vector's `to_list`. -/
lemma to_list_reverse {v : vector α n} : v.reverse.to_list = v.to_list.reverse := rfl

@[simp]
lemma reverse_reverse {v : vector α n} : v.reverse.reverse = v :=
by { cases v, simp [vector.reverse], }

@[simp] theorem nth_zero : ∀ (v : vector α n.succ), nth v 0 = head v
| ⟨a::l, e⟩ := rfl

@[simp] theorem head_of_fn
  {n : ℕ} (f : fin n.succ → α) : head (of_fn f) = f 0 :=
by rw [← nth_zero, nth_of_fn]

@[simp] theorem nth_cons_zero
  (a : α) (v : vector α n) : nth (a ::ᵥ v) 0 = a :=
by simp [nth_zero]

/-- Accessing the `nth` element of a vector made up
of one element `x : α` is `x` itself. -/
@[simp] lemma nth_cons_nil {ix : fin 1}
  (x : α) : nth (x ::ᵥ nil) ix = x :=
by convert nth_cons_zero x nil

@[simp] theorem nth_cons_succ
  (a : α) (v : vector α n) (i : fin n) : nth (a ::ᵥ v) i.succ = nth v i :=
by rw [← nth_tail_succ, tail_cons]

/-- The last element of a `vector`, given that the vector is at least one element. -/
def last (v : vector α (n + 1)) : α := v.nth (fin.last n)

/-- The last element of a `vector`, given that the vector is at least one element. -/
lemma last_def {v : vector α (n + 1)} : v.last = v.nth (fin.last n) := rfl

/-- The `last` element of a vector is the `head` of the `reverse` vector. -/
lemma reverse_nth_zero {v : vector α (n + 1)} : v.reverse.head = v.last :=
begin
  have : 0 = v.to_list.length - 1 - n,
  { simp only [nat.add_succ_sub_one, add_zero, to_list_length, tsub_self,
               list.length_reverse] },
  rw [←nth_zero, last_def, nth_eq_nth_le, nth_eq_nth_le],
  simp_rw [to_list_reverse, fin.val_eq_coe, fin.coe_last, fin.coe_zero, this],
  rw list.nth_le_reverse,
end

section scan

variables {β : Type*}
variables (f : β → α → β) (b : β)
variables (v : vector α n)

/--
Construct a `vector β (n + 1)` from a `vector α n` by scanning `f : β → α → β`
from the "left", that is, from 0 to `fin.last n`, using `b : β` as the starting value.
-/
def scanl : vector β (n + 1) :=
⟨list.scanl f b v.to_list, by rw [list.length_scanl, to_list_length]⟩

/-- Providing an empty vector to `scanl` gives the starting value `b : β`. -/
@[simp] lemma scanl_nil : scanl f b nil = b ::ᵥ nil := rfl

/--
The recursive step of `scanl` splits a vector `x ::ᵥ v : vector α (n + 1)`
into the provided starting value `b : β` and the recursed `scanl`
`f b x : β` as the starting value.

This lemma is the `cons` version of `scanl_nth`.
-/
@[simp] lemma scanl_cons (x : α) : scanl f b (x ::ᵥ v) = b ::ᵥ scanl f (f b x) v :=
by simpa only [scanl, to_list_cons]

/--
The underlying `list` of a `vector` after a `scanl` is the `list.scanl`
of the underlying `list` of the original `vector`.
-/
@[simp] lemma scanl_val : ∀ {v : vector α n}, (scanl f b v).val = list.scanl f b v.val
| ⟨l, hl⟩ := rfl

/--
The `to_list` of a `vector` after a `scanl` is the `list.scanl`
of the `to_list` of the original `vector`.
-/
@[simp] lemma to_list_scanl : (scanl f b v).to_list = list.scanl f b v.to_list := rfl

/--
The recursive step of `scanl` splits a vector made up of a single element
`x ::ᵥ nil : vector α 1` into a `vector` of the provided starting value `b : β`
and the mapped `f b x : β` as the last value.
-/
@[simp] lemma scanl_singleton (v : vector α 1) : scanl f b v = b ::ᵥ f b v.head ::ᵥ nil :=
begin
  rw [←cons_head_tail v],
  simp only [scanl_cons, scanl_nil, cons_head, singleton_tail]
end

/--
The first element of `scanl` of a vector `v : vector α n`,
retrieved via `head`, is the starting value `b : β`.
-/
@[simp] lemma scanl_head : (scanl f b v).head = b :=
begin
  cases n,
  { have : v = nil := by simp only [eq_iff_true_of_subsingleton],
    simp only [this, scanl_nil, cons_head] },
  { rw ←cons_head_tail v,
    simp only [←nth_zero, nth_eq_nth_le, to_list_scanl,
                to_list_cons, list.scanl, fin.val_zero', list.nth_le] }
end

/--
For an index `i : fin n`, the `nth` element of `scanl` of a
vector `v : vector α n` at `i.succ`, is equal to the application
function `f : β → α → β` of the `i.cast_succ` element of
`scanl f b v` and `nth v i`.

This lemma is the `nth` version of `scanl_cons`.
-/
@[simp] lemma scanl_nth (i : fin n) :
  (scanl f b v).nth i.succ = f ((scanl f b v).nth i.cast_succ) (v.nth i) :=
begin
  cases n,
  { exact fin_zero_elim i },
  induction n with n hn generalizing b,
  { have i0 : i = 0 := by simp only [eq_iff_true_of_subsingleton],
    simpa only [scanl_singleton, i0, nth_zero] },
  { rw [←cons_head_tail v, scanl_cons, nth_cons_succ],
    refine fin.cases _ _ i,
    { simp only [nth_zero, scanl_head, fin.cast_succ_zero, cons_head] },
    { intro i',
      simp only [hn, fin.cast_succ_fin_succ, nth_cons_succ] } }
end

end scan

/-- Monadic analog of `vector.of_fn`.
Given a monadic function on `fin n`, return a `vector α n` inside the monad. -/
def m_of_fn {m} [monad m] {α : Type u} : ∀ {n}, (fin n → m α) → m (vector α n)
| 0     f := pure nil
| (n+1) f := do a ← f 0, v ← m_of_fn (λi, f i.succ), pure (a ::ᵥ v)

theorem m_of_fn_pure {m} [monad m] [is_lawful_monad m] {α} :
  ∀ {n} (f : fin n → α), @m_of_fn m _ _ _ (λ i, pure (f i)) = pure (of_fn f)
| 0     f := rfl
| (n+1) f := by simp [m_of_fn, @m_of_fn_pure n, of_fn]

/-- Apply a monadic function to each component of a vector,
returning a vector inside the monad. -/
def mmap {m} [monad m] {α} {β : Type u} (f : α → m β) :
  ∀ {n}, vector α n → m (vector β n)
| 0 xs := pure nil
| (n+1) xs := do h' ← f xs.head, t' ← @mmap n xs.tail, pure (h' ::ᵥ t')

@[simp] theorem mmap_nil {m} [monad m] {α β} (f : α → m β) :
  mmap f nil = pure nil := rfl

@[simp] theorem mmap_cons {m} [monad m] {α β} (f : α → m β) (a) :
  ∀ {n} (v : vector α n), mmap f (a ::ᵥ v) =
  do h' ← f a, t' ← mmap f v, pure (h' ::ᵥ t')
| _ ⟨l, rfl⟩ := rfl

/-- Define `C v` by induction on `v : vector α n`.

This function has two arguments: `h_nil` handles the base case on `C nil`,
and `h_cons` defines the inductive step using `∀ x : α, C w → C (x ::ᵥ w)`.

This can be used as `induction v using vector.induction_on`. -/
@[elab_as_eliminator] def induction_on {C : Π {n : ℕ}, vector α n → Sort*}
  {n : ℕ} (v : vector α n)
  (h_nil : C nil)
  (h_cons : ∀ {n : ℕ} {x : α} {w : vector α n}, C w → C (x ::ᵥ w)) :
    C v :=
begin
  induction n with n ih generalizing v,
  { rcases v with ⟨_|⟨-,-⟩,-|-⟩,
    exact h_nil, },
  { rcases v with ⟨_|⟨a,v⟩,_⟩,
    cases v_property,
    apply @h_cons n _ ⟨v, (add_left_inj 1).mp v_property⟩,
    apply ih, }
end

-- check that the above works with `induction ... using`
example (v : vector α n) : true := by induction v using vector.induction_on; trivial

variables {β γ : Type*}

/-- Define `C v w` by induction on a pair of vectors `v : vector α n` and `w : vector β n`. -/
@[elab_as_eliminator] def induction_on₂ {C : Π {n}, vector α n → vector β n → Sort*}
  (v : vector α n) (w : vector β n)
  (h_nil : C nil nil)
  (h_cons : ∀ {n a b} {x : vector α n} {y}, C x y → C (a ::ᵥ x) (b ::ᵥ y)) : C v w :=
begin
  induction n with n ih generalizing v w,
  { rcases v with ⟨_|⟨-,-⟩,-|-⟩, rcases w with ⟨_|⟨-,-⟩,-|-⟩,
    exact h_nil, },
  { rcases v with ⟨_|⟨a,v⟩,_⟩,
    cases v_property,
    rcases w with ⟨_|⟨b,w⟩,_⟩,
    cases w_property,
    apply @h_cons n _ _ ⟨v, (add_left_inj 1).mp v_property⟩ ⟨w, (add_left_inj 1).mp w_property⟩,
    apply ih, }
end

/-- Define `C u v w` by induction on a triplet of vectors
`u : vector α n`, `v : vector β n`, and `w : vector γ b`. -/
@[elab_as_eliminator] def induction_on₃ {C : Π {n}, vector α n → vector β n → vector γ n → Sort*}
  (u : vector α n) (v : vector β n) (w : vector γ n)
  (h_nil : C nil nil nil)
  (h_cons : ∀ {n a b c} {x : vector α n} {y z}, C x y z → C (a ::ᵥ x) (b ::ᵥ y) (c ::ᵥ z)) :
  C u v w :=
begin
  induction n with n ih generalizing u v w,
  { rcases u with ⟨_|⟨-,-⟩,-|-⟩, rcases v with ⟨_|⟨-,-⟩,-|-⟩, rcases w with ⟨_|⟨-,-⟩,-|-⟩,
    exact h_nil, },
  { rcases u with ⟨_|⟨a,u⟩,_⟩,
    cases u_property,
    rcases v with ⟨_|⟨b,v⟩,_⟩,
    cases v_property,
    rcases w with ⟨_|⟨c,w⟩,_⟩,
    cases w_property,
    apply @h_cons n _ _ _ ⟨u, (add_left_inj 1).mp u_property⟩ ⟨v, (add_left_inj 1).mp v_property⟩
      ⟨w, (add_left_inj 1).mp w_property⟩,
    apply ih, }
end

/-- Cast a vector to an array. -/
def to_array : vector α n → array n α
| ⟨xs, h⟩ := cast (by rw h) xs.to_array

section insert_nth
variable {a : α}

/-- `v.insert_nth a i` inserts `a` into the vector `v` at position `i`
(and shifting later components to the right). -/
def insert_nth (a : α) (i : fin (n+1)) (v : vector α n) : vector α (n+1) :=
⟨v.1.insert_nth i a,
  begin
    rw [list.length_insert_nth, v.2],
    rw [v.2, ← nat.succ_le_succ_iff],
    exact i.2
  end⟩

lemma insert_nth_val {i : fin (n+1)} {v : vector α n} :
  (v.insert_nth a i).val = v.val.insert_nth i.1 a :=
rfl

@[simp] lemma remove_nth_val {i : fin n} :
  ∀{v : vector α n}, (remove_nth i v).val = v.val.remove_nth i
| ⟨l, hl⟩ := rfl

lemma remove_nth_insert_nth {v : vector α n} {i : fin (n+1)} :
  remove_nth i (insert_nth a i v) = v :=
subtype.eq $ list.remove_nth_insert_nth i.1 v.1

lemma remove_nth_insert_nth' {v : vector α (n+1)} :
  ∀{i : fin (n+1)} {j : fin (n+2)},
    remove_nth (j.succ_above i) (insert_nth a j v) = insert_nth a (i.pred_above j) (remove_nth i v)
| ⟨i, hi⟩ ⟨j, hj⟩ :=
  begin
    dsimp [insert_nth, remove_nth, fin.succ_above, fin.pred_above],
    simp only [subtype.mk_eq_mk],
    split_ifs,
    { convert (list.insert_nth_remove_nth_of_ge i (j-1) _ _ _).symm,
      { convert (nat.succ_pred_eq_of_pos _).symm, exact lt_of_le_of_lt (zero_le _) h, },
      { apply remove_nth_val, },
      { convert hi, exact v.2, },
      { exact nat.le_pred_of_lt h, }, },
    { convert (list.insert_nth_remove_nth_of_le i j _ _ _).symm,
      { apply remove_nth_val, },
      { convert hi, exact v.2, },
      { simpa using h, }, }
  end

lemma insert_nth_comm (a b : α) (i j : fin (n+1)) (h : i ≤ j) :
  ∀(v : vector α n),
    (v.insert_nth a i).insert_nth b j.succ = (v.insert_nth b j).insert_nth a i.cast_succ
| ⟨l, hl⟩ :=
  begin
    refine subtype.eq _,
    simp only [insert_nth_val, fin.coe_succ, fin.cast_succ, fin.val_eq_coe, fin.coe_cast_add],
    apply list.insert_nth_comm,
    { assumption },
    { rw hl, exact nat.le_of_succ_le_succ j.2 }
  end

end insert_nth

section update_nth

/-- `update_nth v n a` replaces the `n`th element of `v` with `a` -/
def update_nth (v : vector α n) (i : fin n) (a : α) : vector α n :=
⟨v.1.update_nth i.1 a, by rw [list.update_nth_length, v.2]⟩

@[simp] lemma to_list_update_nth (v : vector α n) (i : fin n) (a : α) :
  (v.update_nth i a).to_list = v.to_list.update_nth i a :=
rfl

@[simp] lemma nth_update_nth_same (v : vector α n) (i : fin n) (a : α) :
  (v.update_nth i a).nth i = a :=
by cases v; cases i; simp [vector.update_nth, vector.nth_eq_nth_le]

lemma nth_update_nth_of_ne {v : vector α n} {i j : fin n} (h : i ≠ j) (a : α) :
  (v.update_nth i a).nth j = v.nth j :=
by cases v; cases i; cases j; simp [vector.update_nth, vector.nth_eq_nth_le,
  list.nth_le_update_nth_of_ne (fin.vne_of_ne h)]

lemma nth_update_nth_eq_if {v : vector α n} {i j : fin n} (a : α) :
  (v.update_nth i a).nth j = if i = j then a else v.nth j :=
by split_ifs; try {simp *}; try {rw nth_update_nth_of_ne}; assumption

@[to_additive]
lemma prod_update_nth [monoid α] (v : vector α n) (i : fin n) (a : α) :
  (v.update_nth i a).to_list.prod =
    (v.take i).to_list.prod * a * (v.drop (i + 1)).to_list.prod :=
begin
  refine (list.prod_update_nth v.to_list i a).trans _,
  have : ↑i < v.to_list.length := lt_of_lt_of_le i.2 (le_of_eq v.2.symm),
  simp * at *
end

@[to_additive]
lemma prod_update_nth' [comm_group α] (v : vector α n) (i : fin n) (a : α) :
  (v.update_nth i a).to_list.prod =
    v.to_list.prod * (v.nth i)⁻¹ * a :=
begin
  refine (list.prod_update_nth' v.to_list i a).trans _,
  have : ↑i < v.to_list.length := lt_of_lt_of_le i.2 (le_of_eq v.2.symm),
  simp [this, nth_eq_nth_le, mul_assoc],
end

end update_nth

end vector

namespace vector

section traverse

variables {F G : Type u → Type u}
variables [applicative F] [applicative G]

open applicative functor
open list (cons) nat

private def traverse_aux {α β : Type u} (f : α → F β) :
  Π (x : list α), F (vector β x.length)
| []      := pure vector.nil
| (x::xs) := vector.cons <$> f x <*> traverse_aux xs

/-- Apply an applicative function to each component of a vector. -/
protected def traverse {α β : Type u} (f : α → F β) : vector α n → F (vector β n)
| ⟨v, Hv⟩ := cast (by rw Hv) $ traverse_aux f v

section
variables {α β : Type u}

@[simp] protected lemma traverse_def
  (f : α → F β) (x : α) : ∀ (xs : vector α n),
  (x ::ᵥ xs).traverse f = cons <$> f x <*> xs.traverse f :=
by rintro ⟨xs, rfl⟩; refl

protected lemma id_traverse : ∀ (x : vector α n), x.traverse id.mk = x :=
begin
  rintro ⟨x, rfl⟩, dsimp [vector.traverse, cast],
  induction x with x xs IH, {refl},
  simp! [IH], refl
end

end

open function

variables [is_lawful_applicative F] [is_lawful_applicative G]
variables {α β γ : Type u}

-- We need to turn off the linter here as
-- the `is_lawful_traversable` instance below expects a particular signature.
@[nolint unused_arguments]
protected lemma comp_traverse (f : β → F γ) (g : α → G β) : ∀ (x : vector α n),
  vector.traverse (comp.mk ∘ functor.map f ∘ g) x =
  comp.mk (vector.traverse f <$> vector.traverse g x) :=
by rintro ⟨x, rfl⟩; dsimp [vector.traverse, cast];
   induction x with x xs; simp! [cast, *] with functor_norm;
   [refl, simp [(∘)]]

protected lemma traverse_eq_map_id {α β} (f : α → β) : ∀ (x : vector α n),
  x.traverse (id.mk ∘ f) = id.mk (map f x) :=
by rintro ⟨x, rfl⟩; simp!;
   induction x; simp! * with functor_norm; refl

variable (η : applicative_transformation F G)

protected lemma naturality {α β : Type*}
  (f : α → F β) : ∀ (x : vector α n),
  η (x.traverse f) = x.traverse (@η _ ∘ f) :=
by rintro ⟨x, rfl⟩; simp! [cast];
   induction x with x xs IH; simp! * with functor_norm

end traverse

instance : traversable.{u} (flip vector n) :=
{ traverse := @vector.traverse n,
  map := λ α β, @vector.map.{u u} α β n }

instance : is_lawful_traversable.{u} (flip vector n) :=
{ id_traverse := @vector.id_traverse n,
  comp_traverse := @vector.comp_traverse n,
  traverse_eq_map_id := @vector.traverse_eq_map_id n,
  naturality := @vector.naturality n,
  id_map := by intros; cases x; simp! [(<$>)],
  comp_map := by intros; cases x; simp! [(<$>)] }

meta instance reflect [reflected_univ.{u}] {α : Type u} [has_reflect α] [reflected _ α] {n : ℕ} :
  has_reflect (vector α n) :=
λ v, @vector.induction_on α (λ n, reflected _) n v
  ((by reflect_name : reflected _ @vector.nil.{u}).subst `(α))
  (λ n x xs ih, (by reflect_name : reflected _ @vector.cons.{u}).subst₄ `(α) `(n) `(x) ih)

end vector


/-
Copyright (c) 2023 Kevin Buzzard. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author : Kevin Buzzard
-/

import tactic
import field_theory.subfield -- for `way_one`
import field_theory.is_alg_closed.basic -- for `way_three`
import ring_theory.norm -- for norms
import ring_theory.trace -- for traces

/-

# Field theory

Galois theory is the study of the symmetries of field extensions. So we have
to start with field extensions, and immediately we run into a design decision,
which took the Lean community several years to get right.

A mathematician would informally describe a field extension as a pair
of fields E ⊆ F. When pressed, they might instead concede that it is also
an injective ring homomorphism E → F of fields. So we have three possible ways
of setting things up.

-/

section way_one

variables (F : Type) [field F] (E : subfield F)

-- This way, `F` is a type and `E` is a term.

end way_one

section way_two

variables (E : Type) [field E] (F : Type) [field F] [algebra E F]

-- The `algebra` class fixes a ring homomorphism from `E` to `F` and
-- decrees it as "canonical" -- it is the one which the typeclass inference
-- system will find.

end way_two

section way_three

variables (Ω : Type) [field Ω] [is_alg_closed Ω] (E : subfield Ω)
  (F : subfield Ω) (h : E ≤ F)

end way_three

/-

The problem with the first way is that it is asymmetric. It doesn't take
long to get to a point in the theory where there are three fields E ⊆ F ⊆ K.
If `E : subfield F` then `F` is a type, so we can't also have `F : subfield K`.

The third way -- using a "universe" Ω and having every field a subfield,
is symmetric but feels very much like we are making arbitrary
choices; one could imagine that in theory one would have to prove that various
definitions were "independent of the choice". I have seen Galois theory at Imperial
being lectured that way (with `Ω = ℂ`) and it feels to me very much like
pre-Grothendieck algebraic geometry (Weil chose a "universal domain" in his
theory, in the 1940s). It's like defining a vector space to be a subset of ℝⁿ.
However, it has been proved to work in theorem provers. In the monumental
work of Gonthier and others proving the Feit-Thompson odd-order theorem,
all finite groups were a subgroup of a universal group, all group homomorphisms
were maps from the universal group to itself sending the source subgroup
to the target subgroup and so on. This works because given any two groups `G`
and `H`, they are both a subgroup of `G × H`. However, the same trick does
not work for rings; if `A` and `B` are rings, then (at least with Lean's conventions)
there might be no ring containing `A` and `B` as subrings; `A × B` does not work,
because `A × {0}` is not a subring, as it does not contain the correct 1.

Ultimately the community chose the second way. It is symmetric (everything is
a type), but there is a problem with it, which took a while to solve. I will
come back to this in the next sheet. For now let's do some basic theory
with fields as types rather than subfields.

Let `F/E` be a field extension (note `algebra E F` means "fix a ring homomorphism `E → F`").
The map from `E` to `F` is called `algebra_map E F`.
It's not hard to prove that this map must be injective, and thus
identifies `E` with a subfield of `F`.

-/
variables (E F : Type) [field E] [field F] [algebra E F]

-- Let's first prove injectivity.

example : function.injective (algebra_map E F) := (algebra_map E F).injective

-- Can you prove it from first principles? Hint: what ideal can the kernel be?
example : function.injective (algebra_map E F) :=
begin
  sorry,
end

-- Many concepts in the basic theory of field extensions assume the
-- extension is finite. Here's how to say this.

variable [finite_dimensional E F]

open finite_dimensional

noncomputable theory

-- Dimension of the extension
example : ℕ := finrank E F -- note: this returns 0 if the dimension is +∞ -- but it isn't

-- the norm (a monoid homomorphism)
example : F →* E := algebra.norm E

-- it's defined as the det of the endomorphism given by left multiplication by
-- the element.
example (f : F) : algebra.norm E f = linear_map.det (algebra.lmul E F f) := rfl

example (e : E) : algebra.norm E (algebra_map E F e) = e^(finrank E F) :=
begin
  exact algebra.norm_algebra_map e
end

-- the trace (an E-linear map)
example : F →ₗ[E] E := algebra.trace E F

example (e : E) : algebra.trace E F (algebra_map E F e) = finrank E F • e :=
begin
  exact algebra.trace_algebra_map e,
end

-- the min poly of an element of F
example (f : F) : polynomial E := minpoly E f


import linear_algebra.tensor_product
import algebra.category.Module.monoidal
import algebra.homology.exact

import .adjunction_general

universes u v

open category_theory category_theory.monoidal_category

namespace tensor_product

open_locale tensor_product zero_object
variables (R : Type u) [comm_ring R]
variables (M : Type v) [add_comm_group M] [module R M]
variables (A B C : Module.{v} R)

variables (fAB : A ⟶ B) (fBC : B ⟶ C)
variables (e0A : exact (0 : (0 : Module.{v} R) ⟶ _) fAB)
variables (eAB : exact fAB fBC) (eC0 : exact fBC (0 : _ ⟶ (0 : Module.{v} R)))

-- include fAB fBC e0A eAB eC0

/-
```
0 -----> A ---fAB---> B ---fBC---> C ----> 0
```
is exact
then
```
A ⊗ M --> B ⊗ M ---> C ⊗ M ----> 0
```
is exact
-/

section

include fBC eC0

lemma right_exact.at3 :
  exact
    (by exact map fBC linear_map.id : Module.of R (B ⊗[R] M) ⟶ Module.of R (C ⊗[R] M))
    (0 : _ ⟶ (0 : Module.{v} R)) :=
begin
  rw ←epi_iff_exact_zero_right,
  haveI : bimodule R R M,
  { refine ⟨λ r r' m, _⟩,
    rw [←mul_smul, mul_comm, mul_smul] },
  haveI : epi fBC,
  { rw ←epi_iff_exact_zero_right at eC0,
    exact eC0 },
  haveI epi0 : epi ((Module.tensor_functor R R M).map fBC),
  { apply_instance },
  rw Module.epi_iff_surjective at epi0 ⊢,
  exact epi0,
end

lemma right_exact.surj :
  function.surjective fBC :=
begin
  haveI e : epi fBC := by rwa ←epi_iff_exact_zero_right at eC0,
  rwa Module.epi_iff_surjective at e,
end

end

@[reducible] noncomputable def β_aux' : C → B :=
λ c, (@@right_exact.surj R _ B C fBC eC0 c).some

local notation `β_aux` := @@β_aux' R _ B C fBC eC0

lemma β_aux_spec (z) :
  fBC (β_aux z) = z :=
(@@right_exact.surj R _ B C fBC eC0 z).some_spec

section

include eAB

lemma right_exact.range_subset_ker :
  (map fAB linear_map.id : A ⊗[R] M →ₗ[R] B ⊗[R] M).range ≤
  (map fBC linear_map.id : B ⊗[R] M →ₗ[R] C ⊗[R] M).ker :=
begin
  rintros _ ⟨z, rfl⟩,
  induction z using tensor_product.induction_on with a m x y hx hy,
  { simp only [map_zero, linear_map.mem_ker], },
  { simp only [map_tmul, linear_map.id_apply],
    have mem1 : fAB a ∈ fAB.range := ⟨_, rfl⟩,
    rw Module.exact_iff at eAB,
    rw [eAB, linear_map.mem_ker] at mem1,
    rw [linear_map.mem_ker, map_tmul, mem1, zero_tmul], },
  { simp only [map_add],
    exact submodule.add_mem _ hx hy, },
end

end

namespace right_exact.ker_subset_range

local notation `quotient_space` := (B ⊗[R] M) ⧸ (map fAB linear_map.id : A ⊗[R] M →ₗ[R] B ⊗[R] M).range

@[reducible]
def π' : B ⊗[R] M →ₗ[R] quotient_space :=
submodule.mkq _

local notation `π` := π' R M A B fAB

@[reducible]
def α' : quotient_space →ₗ[R] C ⊗[R] M :=
submodule.liftq _ (map fBC linear_map.id) $ λ x hx, right_exact.range_subset_ker R M A B C fAB fBC eAB hx

local notation `α` := @α' R _ M _ _ A B C fAB fBC eAB

section

include eAB

lemma β_wd ⦃b b' : B⦄ (h : fBC b = fBC b') (m : M) :
  π (b ⊗ₜ m) = π (b' ⊗ₜ m) :=
(submodule.quotient.eq' _).mpr
begin
  rw [add_comm, ←sub_eq_add_neg, ←sub_tmul],
  rw [←sub_eq_zero, ←map_sub] at h,
  have mem1 : b' - b ∈ linear_map.range fAB,
  { rw Module.exact_iff at eAB,
    rw ←neg_sub,
    refine submodule.neg_mem _ _,
    rwa eAB, },
  rcases mem1 with ⟨a, ha⟩,
  rw ←ha,
  rw linear_map.mem_range,
  refine ⟨a ⊗ₜ m, _⟩,
  rw [map_tmul, linear_map.id_apply],
end

@[reducible] noncomputable def β' : C ⊗[R] M →ₗ[R] quotient_space :=
tensor_product.lift
{ to_fun := λ c,
  { to_fun := λ m, π $ β_aux c ⊗ₜ m,
    map_add' := λ m m', by rw [←map_add, ←tmul_add],
    map_smul' := λ r m, by rw [ring_hom.id_apply, ←π .map_smul, ←smul_tmul, ←smul_tmul'] },
  map_add' := λ c c', linear_map.ext $ λ m,
  begin
    simp only [linear_map.coe_mk, linear_map.add_apply],
    rw [←map_add, ←add_tmul],
    apply β_wd R M _ _ _ _ _ eAB,
    simp only [map_add, β_aux_spec],
  end,
  map_smul' := λ r c', linear_map.ext $ λ m,
  begin
    simp only [linear_map.coe_mk, ring_hom.id_apply, linear_map.smul_apply, ←π .map_smul],
    apply β_wd R M _ _ _ _ _ eAB,
    rw [linear_map.map_smul, β_aux_spec, β_aux_spec],
  end }

end

local notation `β` := @β' R _ M _ _ A B C fAB fBC eAB eC0

lemma αβ : α .comp β  = linear_map.id :=
linear_map.ext $ λ z, begin
  rw [linear_map.id_apply, linear_map.comp_apply],
  induction z using tensor_product.induction_on with c m z z' hz hz',
  { simp only [map_zero], },
  { erw [lift.tmul, linear_map.comp_apply],
    simpa only [linear_map.id_apply, β_aux_spec], },
  { rw [map_add, map_add, hz, hz'], },
end

lemma βα : β .comp α = linear_map.id :=
linear_map.ext $ λ z,
begin
  induction z using quotient.induction_on,
  simp only [linear_map.comp_apply, linear_map.id_apply],
  erw submodule.liftq_apply,
  induction z using tensor_product.induction_on with c m x y hx hy,
  { simpa only [map_zero], },
  { simp only [map_tmul, lift.tmul, linear_map.coe_mk, linear_map.id_apply],
    apply β_wd R M _ _ _ _ _ eAB,
    rw β_aux_spec, },
  { simpa only [map_add, hx, hy], },
end

section

include eAB eC0

lemma result (z : B ⊗[R] M) (hz : z ∈ (map fBC linear_map.id : B ⊗[R] M →ₗ[R] C ⊗[R] M).ker) :
  z ∈ (map fAB linear_map.id : A ⊗[R] M →ₗ[R] B ⊗[R] M).range :=
begin
  have EQ : α (π z) = 0,
  { erw submodule.liftq_apply, exact hz },
  apply_fun β at EQ,
  rw [←linear_map.comp_apply, βα, linear_map.id_apply, map_zero] at EQ,
  erw submodule.quotient.mk_eq_zero at EQ,
  exact EQ,
end

end

end right_exact.ker_subset_range

include eAB eC0

lemma right_exact.ker_subset_range :
  (map fBC linear_map.id : B ⊗[R] M →ₗ[R] C ⊗[R] M).ker ≤
  (map fAB linear_map.id : A ⊗[R] M →ₗ[R] B ⊗[R] M).range :=
@right_exact.ker_subset_range.result R _ M _ _ A B C fAB fBC eAB eC0

lemma right_exact :
  exact
    (by exact map fAB linear_map.id : Module.of R (A ⊗[R] M) ⟶ Module.of R (B ⊗[R] M))
    (by exact map fBC linear_map.id : Module.of R (B ⊗[R] M) ⟶ Module.of R (C ⊗[R] M)) ∧
  exact
    (by exact map fBC linear_map.id : Module.of R (B ⊗[R] M) ⟶ Module.of R (C ⊗[R] M))
    (0 : _ ⟶ (0 : Module.{v} R)) :=
⟨begin
  rw Module.exact_iff,
  refine le_antisymm _ _,
  { intros x hx,
    exact @@right_exact.range_subset_ker R _ M _ _ A B C fAB fBC eAB hx, },
  { intros x hx,
    exact @@right_exact.ker_subset_range R _ M _ _ A B C fAB fBC eAB eC0 hx, },
end, by exactI @@right_exact.at3 R _ M _ _ B C fBC eC0⟩

end tensor_product

noncomputable instance (R : Type u) [comm_ring R] (M : Module.{u} R) : limits.preserves_finite_colimits (tensor_right M) :=
begin
  haveI : limits.preserves_colimits_of_shape limits.walking_parallel_pair (tensor_right M),
  { sorry },
  refine category_theory.functor.preserves_finite_colimits_of_preserves_cokernels _,
end


import algebra.comm_rings.basic
import misc.set

namespace comm_ring

universes u v

def Im {R₁ : Type u} {R₂ : Type v} [comm_ring R₁] [comm_ring R₂] (φ : R₁ →ᵣ R₂)
  := subtype (λ y : R₂, ∃ x : R₁, y = φ x)

def Im_add {R₁ : Type u} {R₂ : Type v} [comm_ring R₁] [comm_ring R₂] (φ : R₁ →ᵣ R₂)
  : Im φ → Im φ → Im φ :=
begin
  intros yu₁ yu₂,
  cases yu₁ with y₁ hy₁,
  cases yu₂ with y₂ hy₂,
  existsi y₁ + y₂,
  cases hy₁ with x₁ hx₁,
  cases hy₂ with x₂ hx₂,
  existsi x₁ + x₂,
  rw [hx₁,hx₂],
  symmetry,
  exact φ.prevs_add x₁ x₂,
end

instance image_add {R₁ : Type u} {R₂ : Type v} [comm_ring R₁] [comm_ring R₂] (φ : R₁ →ᵣ R₂)
  : has_add (Im φ) := ⟨Im_add φ⟩

def Im_mul {R₁ : Type u} {R₂ : Type v} [comm_ring R₁] [comm_ring R₂] (φ : R₁ →ᵣ R₂)
  : Im φ → Im φ → Im φ :=
begin
  intros yu₁ yu₂,
  cases yu₁ with y₁ hy₁,
  cases yu₂ with y₂ hy₂,
  existsi y₁ * y₂,
  cases hy₁ with x₁ hx₁,
  cases hy₂ with x₂ hx₂,
  existsi x₁ * x₂,
  rw [hx₁,hx₂],
  symmetry,
  exact φ.prevs_mul x₁ x₂,
end

instance image_mul {R₁ : Type u} {R₂ : Type v} [comm_ring R₁] [comm_ring R₂] (φ : R₁ →ᵣ R₂)
  : has_mul (Im φ) := ⟨Im_mul φ⟩

def Im_one {R₁ : Type u} {R₂ : Type v} [comm_ring R₁] [comm_ring R₂] (φ : R₁ →ᵣ R₂) : Im φ :=
begin
  existsi (1 : R₂),
  existsi (1 : R₁),
  symmetry,
  exact φ.prevs_one,
end

instance image_one {R₁ : Type u} {R₂ : Type v} [comm_ring R₁] [comm_ring R₂] (φ : R₁ →ᵣ R₂)
  : has_one (Im φ) := ⟨Im_one φ⟩

def Im_zero {R₁ : Type u} {R₂ : Type v} [comm_ring R₁] [comm_ring R₂] (φ : R₁ →ᵣ R₂) : Im φ :=
begin
  existsi (0 : R₂),
  existsi (0 : R₁),
  symmetry,
  exact ring_hom_preserves_zero φ,
end

instance image_zero {R₁ : Type u} {R₂ : Type v} [comm_ring R₁] [comm_ring R₂] (φ : R₁ →ᵣ R₂)
  : has_zero (Im φ) := ⟨Im_zero φ⟩

def Im_minus {R₁ : Type u} {R₂ : Type v} [comm_ring R₁] [comm_ring R₂] (φ : R₁ →ᵣ R₂)
  : Im φ → Im φ :=
begin
  intro a,
  cases a with y hy,
  existsi -y,
  cases hy with x hx,
  existsi -x,
  symmetry,
  rw hx,
  apply minus_commutes_with_hom,
end

instance Im_neg {R₁ : Type u} {R₂ : Type v} [comm_ring R₁] [comm_ring R₂] (φ : R₁ →ᵣ R₂)
  : has_neg (Im φ) := ⟨Im_minus φ⟩

theorem Im_add_assoc {R₁ : Type u} {R₂ : Type v} [comm_ring R₁] [comm_ring R₂] (φ : R₁ →ᵣ R₂)
  : ∀ a b c : Im φ, a + (b + c) = (a + b) + c :=
begin
  intros a b c,
  apply set.val_injective,
  cases a,
  cases b,
  cases c,
  exact add_assoc a_val b_val c_val,
end

theorem Im_add_comm {R₁ : Type u} {R₂ : Type v} [comm_ring R₁] [comm_ring R₂] (φ : R₁ →ᵣ R₂)
  : ∀ a b : Im φ, a + b  = b + a :=
begin
  intros a b,
  apply set.val_injective,
  cases a,
  cases b,
  exact add_comm a_val b_val,
end

theorem Im_add_zero {R₁ : Type u} {R₂ : Type v} [comm_ring R₁] [comm_ring R₂] (φ : R₁ →ᵣ R₂)
  : ∀ a : Im φ , a + 0 = a :=
begin
  intro a,
  apply set.val_injective,
  cases a,
  exact add_zero a_val,
end

theorem Im_minus_inverse {R₁ : Type u} {R₂ : Type v} [comm_ring R₁] [comm_ring R₂] (φ : R₁ →ᵣ R₂)
  : ∀ a : Im φ , a + -a = 0 :=
begin
  intro a,
  apply set.val_injective,
  cases a,
  exact minus_inverse a_val,
end

theorem Im_mul_assoc {R₁ : Type u} {R₂ : Type v} [comm_ring R₁] [comm_ring R₂] (φ : R₁ →ᵣ R₂)
  : ∀ a b c : Im φ, a * (b * c) = (a * b) * c :=
begin
  intros a b c,
  apply set.val_injective,
  cases a,
  cases b,
  cases c,
  exact mul_assoc a_val b_val c_val,
end

theorem Im_mul_comm {R₁ : Type u} {R₂ : Type v} [comm_ring R₁] [comm_ring R₂] (φ : R₁ →ᵣ R₂)
  : ∀ a b : Im φ, a * b  = b * a :=
begin
  intros a b ,
  apply set.val_injective,
  cases a,
  cases b,
  exact mul_comm a_val b_val,
end

theorem Im_mul_one {R₁ : Type u} {R₂ : Type v} [comm_ring R₁] [comm_ring R₂] (φ : R₁ →ᵣ R₂)
  : ∀ a : Im φ , a * 1 = a :=
begin
  intro a,
  apply set.val_injective,
  cases a,
  exact mul_one a_val,
end

theorem Im_mul_dis {R₁ : Type u} {R₂ : Type v} [comm_ring R₁] [comm_ring R₂] (φ : R₁ →ᵣ R₂)
  : ∀ a b c : Im φ, a * (b + c) = a * b + a * c :=
begin
  intros a b c,
  apply set.val_injective,
  cases a,
  cases b,
  cases c,
  exact mul_dis a_val b_val c_val,
end

instance image_is_ring {R₁ : Type u} {R₂ : Type v} [comm_ring R₁] [comm_ring R₂] (φ : R₁ →ᵣ R₂)
  : comm_ring (Im φ) :=
begin
  split,
  exact Im_add_assoc φ,
  exact Im_add_comm φ,
  exact Im_add_zero φ,
  exact Im_minus_inverse φ,
  exact Im_mul_assoc φ,
  exact Im_mul_comm φ,
  exact Im_mul_one φ,
  exact Im_mul_dis φ,
end

def im_trival_hom_in {R₁ : Type u} {R₂ : Type v} [comm_ring R₁] [comm_ring R₂] (φ : R₁ →ᵣ R₂)
  : R₁ →ᵣ Im φ :=
{
  map :=
    by {intro x,
        existsi φ x,
        existsi x,
        refl,},
  prevs_add :=
    by { intros a b,
         apply set.val_injective,
         exact φ.prevs_add a b,},
  prevs_mul :=
    by { intros a b,
         apply set.val_injective,
         exact φ.prevs_mul a b,},
  prevs_one :=
    by { apply set.val_injective,
         exact φ.prevs_one},
}

instance int_is_ring : comm_ring ℤ :=
begin
  split,
  intros a b c,
  symmetry,
  exact int.add_assoc a b c,
  exact int.add_comm,
  exact int.add_zero,
  exact int.add_right_neg,
  intros a b c,
  symmetry,
  exact int.mul_assoc a b c,
  exact int.mul_comm,
  exact int.mul_one,
  exact int.distrib_left,
end

def initial_ring : (Σ R : Type u, comm_ring R) → Prop
  | ⟨R,lR⟩ := ∀ pair : (Σ R' : Type u, comm_ring R'), ∃! ψ : @ring_hom R pair.1 lR pair.2, true

def int_hom_map (R : Type u) [comm_ring R] : ℤ → R
  | (int.of_nat n)          := nat_to_ring R n
  | (int.neg_succ_of_nat n) := -1 + - (nat_to_ring R n)

lemma int_hom_of_nat {R : Type u} [comm_ring R] : ∀ {n : ℕ}, int_hom_map R (int.of_nat n) = nat_to_ring R n := λ _, rfl

theorem int_hom_prevs_zero {R : Type u} [lR:comm_ring R] : int_hom_map R 0 = lR.zero := rfl

theorem int_hom_prevs_mul {R : Type u} [comm_ring R] : ∀ x y : ℤ , int_hom_map R (x * y)
  =  (int_hom_map R x) * (int_hom_map R y) :=
begin
  intros x y,
  induction x with z hz,
  induction z with n hn,
  simp[int_hom_prevs_zero,int.of_nat_zero,int.zero_mul],
  rw [mul_comm,mul_zero],

end

inductive zero_ring : Type
  | elm : zero_ring

theorem zero_ring_has_one_element : ∀ x : zero_ring, x = zero_ring.elm :=
begin
  intro x,
  cases x,
  refl,
end

instance zero_ring_is_ring : comm_ring zero_ring :=
  {
    add := λ _ _, zero_ring.elm,
    mul := λ _ _, zero_ring.elm,
    zero := zero_ring.elm,
    one := zero_ring.elm,
    mul_dis := λ _ _ _, rfl,
    mul_assoc := λ _ _ _, rfl,
    mul_comm := λ _ _, rfl,
    mul_one :=
    begin
      intro a,
      cases a,
      refl,
    end,
    add_assoc := λ _ _ _, rfl,
    add_comm := λ _ _, rfl,
    add_zero :=
    begin
      intro a,
      cases a,
      refl,
    end,
    neg := λ _, zero_ring.elm,
    minus_inverse := λ _, rfl,
  }

def zero_ring_hom (R : Type u) [l:comm_ring R] : R →ᵣ zero_ring:=
  {
    map := λ _, zero_ring.elm,
    prevs_add := λ _ _, rfl,
    prevs_mul := λ _ _,rfl,
    prevs_one := rfl,
  }

def final_ring : (Σ R : Type u, comm_ring R) → Prop
  | ⟨R,lR⟩ := ∀ pair : (Σ R' : Type u, comm_ring R'), ∃! ψ : @ring_hom pair.1  R  pair.2 lR , true

def final_ring_hom_id {Z : Type u} [lZ: comm_ring Z] : final_ring ⟨Z,lZ⟩ → ∀ φ : Z →ᵣ Z, φ = idᵣ :=
begin
  intros upZ φ,
  cases upZ ⟨Z,lZ⟩ with φ_int hφ_int,
  cases hφ_int with trv hφ.raw,
  simp at hφ.raw,
  have h₁ := hφ.raw idᵣ trivial,
  have h₂ := hφ.raw φ trivial,
  rw [h₁,h₂],
end

theorem zero_ring_is_final : final_ring ⟨zero_ring,comm_ring.zero_ring_is_ring⟩ :=
begin
  intro pair,
  cases pair with R lR,
  existsi @zero_ring_hom R lR,
  split,
  trivial,
  intros φ trv,
  apply ring_hom_equality,
  apply funext,
  intro x,
  apply zero_ring_has_one_element,
end

theorem final_ring_unique {R₁ R₂: Type u} [lR₁ : comm_ring R₁] [lR₂ : comm_ring R₂]
  : final_ring ⟨R₁,lR₁⟩  → final_ring ⟨R₂,lR₂⟩
  → ∃! ψ : R₁ →ᵣ R₂ , ring_isomorphism ψ :=
begin
  intros R₁up R₂up ,
  cases R₁up ⟨R₂,lR₂⟩ with φ₁ hφ₁,
  cases R₂up ⟨R₁,lR₁⟩ with φ₂ hφ₂,
  existsi φ₂,
  split,
  existsi φ₁,
  split,
  apply final_ring_hom_id,
  exact R₁up,
  apply final_ring_hom_id,
  exact R₂up,
  simp,
  simp at hφ₂,
  intros ψ hψ,
  apply λ y, hφ₂ y trivial,
end

end comm_ring


import linear_algebra.tensor_product
import deprecated.subring

-- Swap these ↑ two imports, and then `foo` will always be happy.
-- This was not the cases on commit `df4500242eb6aa6ee20b315b185b0f97a9b359c5`.
-- You would get a timeout.

import algebra.module.submodule.basic

variables {R M N P Q : Type*} [comm_ring R]
variables [add_comm_group M] [module R M]
variables [add_comm_group N] [module R N]

open function

lemma injective_iff (f : M →ₗ[R] N) : function.injective f ↔ ∀ m, f m = 0 → m = 0 :=
injective_iff_map_eq_zero f

lemma foo (L : submodule R (unit → R))
  (H : ∀ (m : tensor_product R ↥L ↥L), (tensor_product.map L.subtype L.subtype) m = 0 → m = 0) :
  injective (tensor_product.map L.subtype L.subtype) :=
(injective_iff _).mpr H


import misc.rationals.basic

namespace rational

theorem add_zero : ∀ r : ℚ, r + 0 = r :=
begin
  intro r,
  cases quotient.exists_rep r with p hp,
  cases p with z n,
  rw [← hp,rational_zero_concrete_char,rational_add_concrete_char],
  have trv : n * 1 = n,
    apply coe_inj,
    simp[int.mul_one],
  simp[int.zero_mul,int.add_zero,int.mul_one, trv],
end

theorem zero_add : ∀ r : ℚ, 0 + r = r :=
begin
  intro r,
  cases quotient.exists_rep r with p hp,
  cases p with z n,
  simp [← hp,rational_zero_concrete_char,rational_add_concrete_char],
  simp[int.zero_mul,int.zero_add,int.mul_one],
  refl,
end

theorem mul_one : ∀ r : ℚ, r * 1 = r :=
begin
  intro r,
  cases quotient.exists_rep r with p hp,
  cases p with z n,
  rw [← hp,rational_one_concrete_char,rational_mul_concrete_char],
  have trv : n * 1 = n,
    apply coe_inj,
    simp[int.mul_one],
  simp[int.mul_one,trv],
end

theorem one_mul : ∀ r : ℚ, 1 * r = r :=
begin
  intro r,
  cases quotient.exists_rep r with p hp,
  cases p with z n,
  simp [← hp,rational_one_concrete_char,rational_mul_concrete_char],
  simp[int.one_mul],
  refl,
end

theorem mul_comm : ∀ r₁ r₂ : ℚ, r₁ * r₂ = r₂ * r₁ :=
begin
  intros r₁ r₂,
  cases quotient.exists_rep r₁ with p₁ hp₁,
  cases p₁ with z₁ n₁,
  cases quotient.exists_rep r₂ with p₂ hp₂,
  cases p₂ with z₂ n₂,
  have trv : n₁ * n₂ = n₂ * n₁,
    apply coe_inj,
    simp[int.mul_comm],
  simp[←hp₁,←hp₂,trv,rational_mul_concrete_char,int.mul_comm],
end

theorem mul_assoc : ∀ r₁ r₂ r₃ : ℚ, r₁ * (r₂ * r₃) = (r₁ * r₂) * r₃ :=
begin
  intros r₁ r₂ r₃,
  cases quotient.exists_rep r₁ with p₁ hp₁,
  cases p₁ with z₁ n₁,
  cases quotient.exists_rep r₂ with p₂ hp₂,
  cases p₂ with z₂ n₂,
  cases quotient.exists_rep r₃ with p₃ hp₃,
  cases p₃ with z₃ n₃,
  simp[← hp₁,← hp₂,← hp₃,rational_mul_concrete_char],
  have trv : n₁ * (n₂ * n₃) = (n₁ * n₂) * n₃,
    apply coe_inj,
    simp[int.mul_assoc],
  simp[trv,int.mul_assoc],
end

theorem add_comm : ∀ r₁ r₂ : ℚ, r₁ + r₂ = r₂ + r₁ :=
begin
  intros r₁ r₂,
  cases quotient.exists_rep r₁ with p₁ hp₁,
  cases p₁ with z₁ n₁,
  cases quotient.exists_rep r₂ with p₂ hp₂,
  cases p₂ with z₂ n₂,
  have trv : n₁ * n₂ = n₂ * n₁,
    apply coe_inj,
    simp[int.mul_comm],
  simp[←hp₁,←hp₂,trv,rational_add_concrete_char,int.add_comm],
end

theorem add_assoc : ∀ r₁ r₂ r₃ : ℚ, r₁ + (r₂ + r₃) = (r₁ + r₂) + r₃ :=
begin
  intros r₁ r₂ r₃,
  cases quotient.exists_rep r₁ with p₁ hp₁,
  cases p₁ with z₁ n₁,
  cases quotient.exists_rep r₂ with p₂ hp₂,
  cases p₂ with z₂ n₂,
  cases quotient.exists_rep r₃ with p₃ hp₃,
  cases p₃ with z₃ n₃,
  simp[← hp₁,← hp₂,← hp₃,rational_add_concrete_char],
  have trv : n₁ * (n₂ * n₃) = (n₁ * n₂) * n₃,
    apply coe_inj,
    simp[int.mul_assoc],
  simp[trv,int.add_assoc,int.mul_assoc,int.distrib_right],
  simp[int.mul_comm],
end

theorem fraction_cancel : ∀ (n m : ℕ⁺) (z : ℤ), ⟦(z * m,n * m)⟧ = ⟦(z,n)⟧ :=
begin
  intros n m z,
  apply quotient.sound,
  have res : (z * ↑m) * ↑n = z * ↑(n * m),
    simp[int.mul_comm ↑n,int.mul_assoc],
  exact res,
end

theorem mul_dis : ∀ r₁ r₂ r₃ : ℚ, r₁ * (r₂ + r₃) = (r₁ * r₂) + (r₁ * r₃) :=
begin
  intros r₁ r₂ r₃,
  cases quotient.exists_rep r₁ with p₁ hp₁,
  cases p₁ with z₁ n₁,
  cases quotient.exists_rep r₂ with p₂ hp₂,
  cases p₂ with z₂ n₂,
  cases quotient.exists_rep r₃ with p₃ hp₃,
  cases p₃ with z₃ n₃,
  simp[← hp₁,← hp₂,← hp₃,rational_add_concrete_char,rational_mul_concrete_char],
  have hrw₁ : z₁ * z₂ * (↑n₁ * ↑n₃) = z₁ * (z₂ * ↑n₃) * n₁,
    rw int.mul_comm ↑n₁,
    rw comm_ring.mul_assoc₄,
  have hrw₂ : z₁ * z₃ * (↑n₁ * ↑n₂) = z₁ * (z₃ * ↑n₂) * n₁,
    rw int.mul_comm ↑n₁,
    rw comm_ring.mul_assoc₄,
  have hrw₃ : n₁ * n₂ * (n₁ * n₃) = n₁ * (n₂ * n₃) * n₁,
    apply coe_inj,
    simp[int.mul_comm n₁ n₃,comm_ring.mul_assoc₄],
  rw [hrw₁,hrw₂,hrw₃,← int.distrib_right,fraction_cancel,int.distrib_left],
end

theorem minus_inverse : ∀ a : ℚ , a + (-a) = 0 :=
begin
  intro r,
  cases quotient.exists_rep r with p hp,
  cases p with z n,
  simp[←hp,rational_add_concrete_char,rational_minus_concrete_char],
  rw [← int.distrib_right,int.add_right_neg,int.zero_mul],
  apply quotient.sound,
  have res : (0 * 1:ℤ) = 0 * ↑(n * n) := by simp[int.zero_mul],
  exact res,
end

instance rational_comm_ring : comm_ring ℚ :=
{
  add_assoc := add_assoc,
  mul_assoc := mul_assoc,
  mul_dis   := mul_dis,
  add_comm := add_comm,
  mul_comm := mul_comm,
  add_zero := add_zero,
  mul_one := mul_one,
  minus_inverse := minus_inverse,
}

theorem sub_antisymm : ∀ x y : ℚ, x - y = -(y - x) :=
begin
  intros x y,
  simp[comm_ring.minus_dis,comm_ring.minus_minus,add_comm],
end

@[simp]
theorem better_zero_concrete_char : ∀ n : ℕ⁺, ⟦((0:ℤ),n)⟧ = (0: ℚ) :=
begin
  intro,
  apply quotient.sound,
  simp[int.zero_mul],
end

lemma mul_two_div_rat_by_two : ∀ (n : ℕ) (m : ℕ⁺), ⟦(int.of_nat n, m)⟧ =
  (⟦(int.of_nat n, m*2)⟧ + ⟦(int.of_nat n, m*2)⟧ : ℚ) :=
begin
  intros n m,
  rw [rational_add_concrete_char,← int.distrib_right],
  rw fraction_cancel,
  have hrw : int.of_nat n + int.of_nat n = (int.of_nat n) * ↑(2:ℕ⁺),
    have sub₁ : ↑(2:ℕ⁺) = (2:ℤ) := rfl,
    rw sub₁,
    rw int.mul_comm,
    have sub₂ : 2 = int.of_nat 2 := rfl,
    simp[← int.of_nat_add,sub₂,← int.of_nat_mul,nat.succ_mul,nat.zero_mul,nat.zero_add],
    rw [hrw,fraction_cancel],
end

end rational


import SciLean.Mathlib.Data.Table

import SciLean.Categories
import SciLean.Operators

namespace SciLean.Table

open Table

@[simp]
theorem sum_intro {C ι κ α}
  (f : ι → κ → α) [Table C κ α] [Table.Intro C] [Vec α] [Enumtype ι]
  : (∑ i, (Table.intro (f i) : C)) = (Table.intro (∑ i, f i) : C)
  :=
by
  admit

@[simp]
theorem add_intro {C ι α} [Table C ι α]
  (f g : ι → α) [Table.Intro C] [Vec α]
  :
    HAdd.hAdd (self := instHAdd) (Table.intro λ i : ι => f i : C)
                                 (Table.intro λ i : ι => g i : C)
    =
    (Table.intro λ i => f i + g i : C)
  :=
by
  admit

-- section VectorSpace
-- variable {C : Type u} [Trait C] [Table C (Index C) (Value C)] [Intro C]

-- Vector Space
-- instance [AddSemigroup (Value C)] : AddSemigroup C := AddSemigroup.mk sorry
-- instance [AddMonoid (Value C)]    : AddMonoid C    := AddMonoid.mk sorry sorry nsmul_rec sorry sorry
-- instance [AddCommMonoid (Value C)] : AddCommMonoid C := AddCommMonoid.mk sorry
-- instance [SubNegMonoid (Value C)] : SubNegMonoid C := SubNegMonoid.mk sorry gsmul_rec sorry sorry sorry
-- instance [AddGroup (Value C)]     : AddGroup C     := AddGroup.mk sorry
-- instance [AddCommGroup (Value C)] : AddCommGroup C := AddCommGroup.mk sorry

-- instance [Monoid β] [MulAction β (Value C)] : MulAction β C := MulAction.mk sorry sorry
-- instance {M} [AddMonoid (Value C)] [Monoid M] [DistribMulAction M (Value C)] : DistribMulAction M C := DistribMulAction.mk sorry sorry
-- instance {R} [AddCommGroup (Value C)] [Semiring R] [Module R (Value C)] : Module R C := Module.mk sorry sorry

-- set_option synthInstance.maxHeartbeats 3000 in
-- instance [Vec (Value C)] : Vec C := Vec.mk

-- end VectorSpace

----------------------------------------------------------------------

--  {R : outParam $ Type u} {D : outParam $ Type v} {e : outParam $ R → D → ℝ}
-- instance {C R D e} [Trait C]
--   [Table C (Index C) (Value C)]
--   [SemiInner (Value C) R D e]
--   [Zero R] [Add R] [Enumtype (Index C)]
--   : SemiInner C R D e :=
-- {
--   semiInner := λ x y => (∑ i, ⟪x[i], y[i]⟫)
--   testFunction := λ _ _ => True
-- }

-- instance {C R D e} [Trait C]
--   [Table C (Index C) (Value C)] [Intro C]
--   [SemiInner.Trait (Value C)] [Vec R] [SemiHilbert (Value C) R D e]
--   [Enumtype (Index C)]
--   : SemiHilbert C R D e :=
-- {
--   semi_inner_add := sorry
--   semi_inner_mul := sorry
--   semi_inner_sym := sorry
--   semi_inner_pos := sorry
--   semi_inner_ext := sorry
-- }

-- instance {C} [Trait C]
--   [Table C (Index C) (Value C)]
--   [SemiInner (Value C) ℝ Unit (λ r _ => r)]
--   [Enumtype (Index C)]
--   : SemiInner C ℝ Unit (λ r _ => r) :=
-- {
--   semiInner := λ x y => (∑ i, ⟪x[i], y[i]⟫)
--   testFunction := λ _ _ => True
-- }

-- instance {C} [Trait C]
--   [Table C (Index C) (Value C)] [Intro C]
--   [SemiInner.Trait (Value C)] [Hilbert (Value C)]
--   [Enumtype (Index C)]
--   : Hilbert C :=
-- {
--   semi_inner_add := sorry
--   semi_inner_mul := sorry
--   semi_inner_sym := sorry
--   semi_inner_pos := sorry
--   semi_inner_ext := sorry
-- }

-- #check SciLean.instSemiInner
-- #check SciLean.instSemiHilbert
-- #check SciLean.SemiHilbert.instSemiHilbertArrow

-- example {C} [Trait C] [Table C (Index C) (Value C)] [Enumtype (Index C)] [Intro C]
--   [Hilbert (Value C)]
--   : SemiInner C ℝ Unit (λ r _ => r) := by infer_instance

-- example {C}
--   [Trait C] [Table C (Index C) (Value C)] [Intro C] [Enumtype (Index C)]
--   [Hilbert (Value C)]
--   : Hilbert C := by infer_instance

-- ---------------------------------------------------------------------

-- variable {C} [Trait C] [Table C (Index C) (Value C)] [Table.Intro C]

-- instance (i : (Index C)) [Vec ( Value C)] : IsLin (λ c : C => c[i]) := sorry
-- instance [Vec (Value C)] : IsLin (λ (c : C) (i : (Index C))  => c[i]) := sorry

-- instance (i : (Index C))[Hilbert (Value C)] [Enumtype (Index C)]
--   : HasAdjoint (λ c : C => c[i]) := sorry

-- example (i : (Index C)) [Hilbert (Value C)] [Enumtype (Index C)]
--   : HasAdjoint ((λ c : C => c[i])†) := by infer_instance
-- example (i : (Index C)) [Hilbert (Value C)] [Enumtype (Index C)]
--   : HasAdjoint ((λ c : C => c[i])††) := by infer_instance

--   -- apply Adjoint.instHasAdjointAdjoint

-- set_option trace.Meta.synthInstance true in
-- @[simp]
-- theorem adjoint_of_table_get
--   (i : (Index C))
--   [Hilbert (Value C)]
--   [Enumtype (Index C)]
--   : (λ (c : C) (i : Index C) => c[i])† = intro :=
-- by
--   apply Adjoint.inner_ext

-- example : Vec (ℝ × _) := by infer_instance

-- set_option trace.Meta.Tactic.simp true in
-- @[simp]
-- theorem adjoint_of_table_get_at_i {R D e} (i : (Index C)) [Vec R] [SemiHilbert (Value C) R D e] [Enumtype (Index C)]
--   (f : C → Value C) [HasAdjoint f]
--   : f† = 0 :=  -- (λ c : C => c[i])† = λ a => intro (λ j => (kron i j) * a) :=
-- by
--   funext a
--   inner_ext ϕ D h;
--   simp (discharger := assumption)
--   rw[(SciLean.Adjoint.inner_adjoint_fst_left_test _ a ϕ D h)]
--   simp
--   simp
--   simp


/-
Copyright (c) 2021 Manuel Candales. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Manuel Candales, Benjamin Davidson

! This file was ported from Lean 3 source module geometry.euclidean.sphere.ptolemy
! leanprover-community/mathlib commit 46b633fd842bef9469441c0209906f6dddd2b4f5
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Geometry.Euclidean.Sphere.Power
import Mathbin.Geometry.Euclidean.Triangle

/-!
# Ptolemy's theorem

This file proves Ptolemy's theorem on the lengths of the diagonals and sides of a cyclic
quadrilateral.

## Main theorems

* `mul_dist_add_mul_dist_eq_mul_dist_of_cospherical`: Ptolemy’s Theorem (Freek No. 95).

TODO: The current statement of Ptolemy’s theorem works around the lack of a "cyclic polygon" concept
in mathlib, which is what the theorem statement would naturally use (or two such concepts, since
both a strict version, where all vertices must be distinct, and a weak version, where consecutive
vertices may be equal, would be useful; Ptolemy's theorem should then use the weak one).

An API needs to be built around that concept, which would include:
- strict cyclic implies weak cyclic,
- weak cyclic and consecutive points distinct implies strict cyclic,
- weak/strict cyclic implies weak/strict cyclic for any subsequence,
- any three points on a sphere are weakly or strictly cyclic according to whether they are distinct,
- any number of points on a sphere intersected with a two-dimensional affine subspace are cyclic in
  some order,
- a list of points is cyclic if and only if its reversal is,
- a list of points is cyclic if and only if any cyclic permutation is, while other permutations
  are not when the points are distinct,
- a point P where the diagonals of a cyclic polygon cross exists (and is unique) with weak/strict
  betweenness depending on weak/strict cyclicity,
- four points on a sphere with such a point P are cyclic in the appropriate order,
and so on.
-/

open Real

open EuclideanGeometry RealInnerProductSpace Real

namespace EuclideanGeometry

variable {V : Type _} [NormedAddCommGroup V] [InnerProductSpace ℝ V]

variable {P : Type _} [MetricSpace P] [NormedAddTorsor V P]

include V

/-- **Ptolemy’s Theorem**. -/
theorem mul_dist_add_mul_dist_eq_mul_dist_of_cospherical {a b c d p : P}
    (h : Cospherical ({a, b, c, d} : Set P)) (hapc : ∠ a p c = π) (hbpd : ∠ b p d = π) :
    dist a b * dist c d + dist b c * dist d a = dist a c * dist b d :=
  by
  have h' : cospherical ({a, c, b, d} : Set P) := by rwa [Set.insert_comm c b {d}]
  have hmul := mul_dist_eq_mul_dist_of_cospherical_of_angle_eq_pi h' hapc hbpd
  have hbp := left_dist_ne_zero_of_angle_eq_pi hbpd
  have h₁ : dist c d = dist c p / dist b p * dist a b :=
    by
    rw [dist_mul_of_eq_angle_of_dist_mul b p a c p d, dist_comm a b]
    · rw [angle_eq_angle_of_angle_eq_pi_of_angle_eq_pi hbpd hapc, angle_comm]
    all_goals field_simp [mul_comm, hmul]
  have h₂ : dist d a = dist a p / dist b p * dist b c :=
    by
    rw [dist_mul_of_eq_angle_of_dist_mul c p b d p a, dist_comm c b]
    · rwa [angle_comm, angle_eq_angle_of_angle_eq_pi_of_angle_eq_pi]
      rwa [angle_comm]
    all_goals field_simp [mul_comm, hmul]
  have h₃ : dist d p = dist a p * dist c p / dist b p := by field_simp [mul_comm, hmul]
  have h₄ : ∀ x y : ℝ, x * (y * x) = x * x * y := fun x y => by rw [mul_left_comm, mul_comm]
  field_simp [h₁, h₂, dist_eq_add_dist_of_angle_eq_pi hbpd, h₃, hbp, dist_comm a b, h₄, ← sq,
    dist_sq_mul_dist_add_dist_sq_mul_dist b, hapc]
#align euclidean_geometry.mul_dist_add_mul_dist_eq_mul_dist_of_cospherical EuclideanGeometry.mul_dist_add_mul_dist_eq_mul_dist_of_cospherical

end EuclideanGeometry


import data.set
import data.set.basic
import util.meta.tactic.basic
import util.data.order

open nat

universe variables u

class has_minimum (α : Type u) extends partial_order α :=
  (minimum : set α → α)
  (minimum_mem : ∀ s, s ≠ ∅ → minimum s ∈ s)
  (minimum_le : ∀ s x, x ∈ s → minimum s ≤ x)
  (le_minimum_of_forall_le : ∀ s x, s ≠ ∅ → (∀ y, y ∈ s → x ≤ y) → x ≤ minimum s)

class has_maximum (α : Type u) extends partial_order α :=
  (maximum : set α → α)
  (maximum_mem : ∀ s, s ≠ ∅ → maximum s ∈ s)
  (maximum_ge : ∀ s x, x ∈ s → x ≤ maximum s)
  (maximum_unique : ∀ s x, x ∈ s → (∀ y, y ∈ s → y ≤ x) → maximum s = x)

notation `↓` binders `, ` r:(scoped P, has_minimum.minimum P) := r

lemma min_eq_or_min_eq {α} [decidable_linear_order α] (x y : α)
: min x y = x ∨ min x y = y :=
begin
  apply or.imp min_eq_left min_eq_right,
  apply le_total
end

section minimum

parameters {α : Type u}
parameters [has_minimum α]
parameters {s : set α}
parameters {x : α}

lemma minimum_mem
: s ≠ ∅ → has_minimum.minimum s ∈ s :=
@has_minimum.minimum_mem _ _ _

lemma minimum_le
: x ∈ s → has_minimum.minimum s ≤ x :=
@has_minimum.minimum_le _ _ _ _

lemma le_minimum_of_forall_le
: s ≠ ∅ → (∀ y, y ∈ s → x ≤ y) → x ≤ has_minimum.minimum s :=
@has_minimum.le_minimum_of_forall_le _ _ _ _

lemma minimum_unique
  (h₀ : x ∈ s)
  (h₁ : ∀ y, y ∈ s → x ≤ y)
: has_minimum.minimum s = x :=
begin
  have h₂ := set.ne_empty_of_mem h₀,
  apply @le_antisymm α,
  { apply minimum_le h₀, },
  { apply le_minimum_of_forall_le h₂ h₁, },
end

lemma le_minimum_iff_forall_le
  (h : s ≠ ∅)
  (x : α)
: x ≤ (↓ x, x ∈ s) ↔ (∀ y, y ∈ s → x ≤ y) :=
begin
  split ; intro h₀,
  { intros y h₁, revert h₀,
    apply indirect_le_left_of_le x,
    apply has_minimum.minimum_le _ _ h₁, },
  { apply le_minimum_of_forall_le h h₀, },
end

lemma minimum_le_iff_exists_le
  (h : s ≠ ∅)
  (x : α)
: (↓ x, x ∈ s) ≤ x ↔ (∃ y, y ∈ s ∧ y ≤ x) :=
begin
  split ; intro h₀,
  { existsi (↓ (x : α), x ∈ s),
    refine ⟨_,h₀⟩,
    apply minimum_mem h, },
  { cases h₀,
    apply indirect_le_right_of_le ,
    apply has_minimum.minimum_le _ _ h₀_h.left,
    tauto, },
end

end minimum

section has_minimum

parameters {α : Type u}
parameters [partial_order α]
parameters minimum : set α → α
local notation `↓` binders ` | ` r:(scoped P, has_minimum.minimum P) := r
parameters minimum_mem : ∀ (s : set α), s ≠ ∅ → minimum s ∈ s
parameters h : ∀ (s : set α) (x : α), x ≤ minimum s ↔ ∀ y, y ∈ s → x ≤ y
include minimum_mem h

section lemmas

variables s : set α
variables x : α
variables h₀ : x ∈ s

include h₀

private lemma minimum_le
: minimum s ≤ x :=
begin
  apply le_of_indirect_le_left,
  intros z h',
  rw h at h',
  apply h' _ h₀,
end

omit h₀

variables h₁ : s ≠ ∅
variables h₂ : ∀ (y : α), y ∈ s → x ≤ y
include h₁ h₂

private lemma le_minimum_of_forall_le
: x ≤ minimum s :=
begin
  rw h, apply h₂,
end

end lemmas

def has_minimum_of_le_minimum_iff : has_minimum α :=
{ (_ : partial_order α) with
  minimum := minimum
, minimum_mem := @minimum_mem
, minimum_le := @minimum_le
, le_minimum_of_forall_le := @le_minimum_of_forall_le }

end has_minimum


/-
Copyright (c) 2022 Jireh Loreaux. All rights reserved.
Reeased under Apache 2.0 license as described in the file LICENSE.
Authors: Jireh Loreaux

! This file was ported from Lean 3 source module analysis.normed_space.star.gelfand_duality
! leanprover-community/mathlib commit e65771194f9e923a70dfb49b6ca7be6e400d8b6f
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Analysis.NormedSpace.Star.Spectrum
import Mathbin.Analysis.Normed.Group.Quotient
import Mathbin.Analysis.NormedSpace.Algebra
import Mathbin.Topology.ContinuousFunction.Units
import Mathbin.Topology.ContinuousFunction.Compact
import Mathbin.Topology.Algebra.Algebra
import Mathbin.Topology.ContinuousFunction.StoneWeierstrass

/-!
# Gelfand Duality

The `gelfand_transform` is an algebra homomorphism from a topological `𝕜`-algebra `A` to
`C(character_space 𝕜 A, 𝕜)`. In the case where `A` is a commutative complex Banach algebra, then
the Gelfand transform is actually spectrum-preserving (`spectrum.gelfand_transform_eq`). Moreover,
when `A` is a commutative C⋆-algebra over `ℂ`, then the Gelfand transform is a surjective isometry,
and even an equivalence between C⋆-algebras.

## Main definitions

* `ideal.to_character_space` : constructs an element of the character space from a maximal ideal in
  a commutative complex Banach algebra
* `weak_dual.character_space.comp_continuous_map`: The functorial map taking `ψ : A →⋆ₐ[ℂ] B` to a
  continuous function `character_space ℂ B → character_space ℂ A` given by pre-composition with `ψ`.

## Main statements

* `spectrum.gelfand_transform_eq` : the Gelfand transform is spectrum-preserving when the algebra is
  a commutative complex Banach algebra.
* `gelfand_transform_isometry` : the Gelfand transform is an isometry when the algebra is a
  commutative (unital) C⋆-algebra over `ℂ`.
* `gelfand_transform_bijective` : the Gelfand transform is bijective when the algebra is a
  commutative (unital) C⋆-algebra over `ℂ`.

## TODO

* After `star_alg_equiv` is defined, realize `gelfand_transform` as a `star_alg_equiv`.
* Prove that if `A` is the unital C⋆-algebra over `ℂ` generated by a fixed normal element `x` in
  a larger C⋆-algebra `B`, then `character_space ℂ A` is homeomorphic to `spectrum ℂ x`.
* From the previous result, construct the **continuous functional calculus**.
* Show that if `X` is a compact Hausdorff space, then `X` is (canonically) homeomorphic to
  `character_space ℂ C(X, ℂ)`.
* Conclude using the previous fact that the functors `C(⬝, ℂ)` and `character_space ℂ ⬝` along with
  the canonical homeomorphisms described above constitute a natural contravariant equivalence of
  the categories of compact Hausdorff spaces (with continuous maps) and commutative unital
  C⋆-algebras (with unital ⋆-algebra homomoprhisms); this is known as **Gelfand duality**.

## Tags

Gelfand transform, character space, C⋆-algebra
-/

open WeakDual

open NNReal

section ComplexBanachAlgebra

open Ideal

variable {A : Type _} [NormedCommRing A] [NormedAlgebra ℂ A] [CompleteSpace A] (I : Ideal A)
  [Ideal.IsMaximal I]

/-- Every maximal ideal in a commutative complex Banach algebra gives rise to a character on that
algebra. In particular, the character, which may be identified as an algebra homomorphism due to
`weak_dual.character_space.equiv_alg_hom`, is given by the composition of the quotient map and
the Gelfand-Mazur isomorphism `normed_ring.alg_equiv_complex_of_complete`. -/
noncomputable def Ideal.toCharacterSpace : characterSpace ℂ A :=
  characterSpace.equivAlgHom.symm <|
    ((@NormedRing.algEquivComplexOfComplete (A ⧸ I) _ _
              (letI := quotient.field I
              @isUnit_iff_ne_zero (A ⧸ I) _)
              _).symm :
          A ⧸ I →ₐ[ℂ] ℂ).comp
      (Quotient.mkₐ ℂ I)
#align ideal.to_character_space Ideal.toCharacterSpace

theorem Ideal.toCharacterSpace_apply_eq_zero_of_mem {a : A} (ha : a ∈ I) :
    I.toCharacterSpace a = 0 := by
  unfold Ideal.toCharacterSpace
  simpa only [character_space.equiv_alg_hom_symm_coe, AlgHom.coe_comp, AlgEquiv.coe_algHom,
    quotient.mkₐ_eq_mk, Function.comp_apply, quotient.eq_zero_iff_mem.mpr ha, spectrum.zero_eq,
    NormedRing.algEquivComplexOfComplete_symm_apply] using
    Set.eq_of_mem_singleton (Set.singleton_nonempty (0 : ℂ)).some_mem
#align ideal.to_character_space_apply_eq_zero_of_mem Ideal.toCharacterSpace_apply_eq_zero_of_mem

/-- If `a : A` is not a unit, then some character takes the value zero at `a`. This is equivlaent
to `gelfand_transform ℂ A a` takes the value zero at some character. -/
theorem WeakDual.characterSpace.exists_apply_eq_zero {a : A} (ha : ¬IsUnit a) :
    ∃ f : characterSpace ℂ A, f a = 0 :=
  by
  obtain ⟨M, hM, haM⟩ := (span {a}).exists_le_maximal (span_singleton_ne_top ha)
  exact
    ⟨M.to_character_space,
      M.to_character_space_apply_eq_zero_of_mem
        (haM (mem_span_singleton.mpr ⟨1, (mul_one a).symm⟩))⟩
#align weak_dual.character_space.exists_apply_eq_zero WeakDual.characterSpace.exists_apply_eq_zero

theorem WeakDual.characterSpace.mem_spectrum_iff_exists {a : A} {z : ℂ} :
    z ∈ spectrum ℂ a ↔ ∃ f : characterSpace ℂ A, f a = z :=
  by
  refine' ⟨fun hz => _, _⟩
  · obtain ⟨f, hf⟩ := WeakDual.characterSpace.exists_apply_eq_zero hz
    simp only [map_sub, sub_eq_zero, AlgHomClass.commutes, Algebra.id.map_eq_id,
      RingHom.id_apply] at hf
    exact (ContinuousMap.spectrum_eq_range (gelfand_transform ℂ A a)).symm ▸ ⟨f, hf.symm⟩
  · rintro ⟨f, rfl⟩
    exact AlgHom.apply_mem_spectrum f a
#align weak_dual.character_space.mem_spectrum_iff_exists WeakDual.characterSpace.mem_spectrum_iff_exists

/-- The Gelfand transform is spectrum-preserving. -/
theorem spectrum.gelfandTransform_eq (a : A) : spectrum ℂ (gelfandTransform ℂ A a) = spectrum ℂ a :=
  by
  ext z
  rw [ContinuousMap.spectrum_eq_range, WeakDual.characterSpace.mem_spectrum_iff_exists]
  exact Iff.rfl
#align spectrum.gelfand_transform_eq spectrum.gelfandTransform_eq

instance [Nontrivial A] : Nonempty (characterSpace ℂ A) :=
  ⟨Classical.choose <|
      WeakDual.characterSpace.exists_apply_eq_zero <| zero_mem_nonunits.2 zero_ne_one⟩

end ComplexBanachAlgebra

section ComplexCstarAlgebra

variable {A : Type _} [NormedCommRing A] [NormedAlgebra ℂ A] [CompleteSpace A]

variable [StarRing A] [CstarRing A] [StarModule ℂ A]

theorem gelfandTransform_map_star (a : A) :
    gelfandTransform ℂ A (star a) = star (gelfandTransform ℂ A a) :=
  ContinuousMap.ext fun φ => map_star φ a
#align gelfand_transform_map_star gelfandTransform_map_star

variable (A)

/-- The Gelfand transform is an isometry when the algebra is a C⋆-algebra over `ℂ`. -/
theorem gelfandTransform_isometry : Isometry (gelfandTransform ℂ A) :=
  by
  nontriviality A
  refine' AddMonoidHomClass.isometry_of_norm (gelfand_transform ℂ A) fun a => _
  /- By `spectrum.gelfand_transform_eq`, the spectra of `star a * a` and its
    `gelfand_transform` coincide. Therefore, so do their spectral radii, and since they are
    self-adjoint, so also do their norms. Applying the C⋆-property of the norm and taking square
    roots shows that the norm is preserved. -/
  have : spectralRadius ℂ (gelfand_transform ℂ A (star a * a)) = spectralRadius ℂ (star a * a) :=
    by
    unfold spectralRadius
    rw [spectrum.gelfandTransform_eq]
  simp only [map_mul, (IsSelfAdjoint.star_mul_self _).spectralRadius_eq_nnnorm,
    gelfandTransform_map_star a, ENNReal.coe_eq_coe, CstarRing.nnnorm_star_mul_self, ← sq] at this
  simpa only [Function.comp_apply, NNReal.sqrt_sq] using
    congr_arg ((coe : ℝ≥0 → ℝ) ∘ ⇑NNReal.sqrt) this
#align gelfand_transform_isometry gelfandTransform_isometry

/-- The Gelfand transform is bijective when the algebra is a C⋆-algebra over `ℂ`. -/
theorem gelfandTransform_bijective : Function.Bijective (gelfandTransform ℂ A) :=
  by
  refine' ⟨(gelfandTransform_isometry A).Injective, _⟩
  suffices (gelfand_transform ℂ A).range = ⊤ by
    exact fun x => this.symm ▸ (gelfand_transform ℂ A).mem_range.mp (this.symm ▸ Algebra.mem_top)
  /- Because the `gelfand_transform ℂ A` is an isometry, it has closed range, and so by the
    Stone-Weierstrass theorem, it suffices to show that the image of the Gelfand transform separates
    points in `C(character_space ℂ A, ℂ)` and is closed under `star`. -/
  have h : (gelfand_transform ℂ A).range.topologicalClosure = (gelfand_transform ℂ A).range :=
    le_antisymm
      (Subalgebra.topologicalClosure_minimal _ le_rfl
        (gelfandTransform_isometry A).ClosedEmbedding.closed_range)
      (Subalgebra.le_topologicalClosure _)
  refine'
    h ▸
      ContinuousMap.subalgebra_isROrC_topologicalClosure_eq_top_of_separatesPoints _ (fun _ _ => _)
        fun f hf => _
  /- Separating points just means that elements of the `character_space` which agree at all points
    of `A` are the same functional, which is just extensionality. -/
  · contrapose!
    exact fun h =>
      Subtype.ext
        (ContinuousLinearMap.ext fun a =>
          h (gelfand_transform ℂ A a) ⟨gelfand_transform ℂ A a, ⟨a, rfl⟩, rfl⟩)
  /- If `f = gelfand_transform ℂ A a`, then `star f` is also in the range of `gelfand_transform ℂ A`
    using the argument `star a`. The key lemma below may be hard to spot; it's `map_star` coming from
    `weak_dual.star_hom_class`, which is a nontrivial result. -/
  · obtain ⟨f, ⟨a, rfl⟩, rfl⟩ := subalgebra.mem_map.mp hf
    refine' ⟨star a, ContinuousMap.ext fun ψ => _⟩
    simpa only [gelfandTransform_map_star a, AlgHom.toRingHom_eq_coe, AlgHom.coe_toRingHom]
#align gelfand_transform_bijective gelfandTransform_bijective

/-- The Gelfand transform as a `star_alg_equiv` between a commutative unital C⋆-algebra over `ℂ`
and the continuous functions on its `character_space`. -/
@[simps]
noncomputable def gelfandStarTransform : A ≃⋆ₐ[ℂ] C(characterSpace ℂ A, ℂ) :=
  StarAlgEquiv.ofBijective
    (show A →⋆ₐ[ℂ] C(characterSpace ℂ A, ℂ) from
      { gelfandTransform ℂ A with map_star' := fun x => gelfandTransform_map_star x })
    (gelfandTransform_bijective A)
#align gelfand_star_transform gelfandStarTransform

end ComplexCstarAlgebra

section Functoriality

namespace WeakDual

namespace CharacterSpace

variable {A B C : Type _}

variable [NormedRing A] [NormedAlgebra ℂ A] [CompleteSpace A] [StarRing A]

variable [NormedRing B] [NormedAlgebra ℂ B] [CompleteSpace B] [StarRing B]

variable [NormedRing C] [NormedAlgebra ℂ C] [CompleteSpace C] [StarRing C]

/-- The functorial map taking `ψ : A →⋆ₐ[ℂ] B` to a continuous function
`character_space ℂ B → character_space ℂ A` obtained by pre-composition with `ψ`. -/
@[simps]
noncomputable def compContinuousMap (ψ : A →⋆ₐ[ℂ] B) : C(characterSpace ℂ B, characterSpace ℂ A)
    where
  toFun φ := equivAlgHom.symm ((equivAlgHom φ).comp ψ.toAlgHom)
  continuous_toFun :=
    Continuous.subtype_mk
      (continuous_of_continuous_eval fun a => map_continuous <| gelfandTransform ℂ B (ψ a)) _
#align weak_dual.character_space.comp_continuous_map WeakDual.characterSpace.compContinuousMap

variable (A)

/-- `weak_dual.character_space.comp_continuous_map` sends the identity to the identity. -/
@[simp]
theorem compContinuousMap_id :
    compContinuousMap (StarAlgHom.id ℂ A) = ContinuousMap.id (characterSpace ℂ A) :=
  ContinuousMap.ext fun a => ext fun x => rfl
#align weak_dual.character_space.comp_continuous_map_id WeakDual.characterSpace.compContinuousMap_id

variable {A}

/-- `weak_dual.character_space.comp_continuous_map` is functorial. -/
@[simp]
theorem compContinuousMap_comp (ψ₂ : B →⋆ₐ[ℂ] C) (ψ₁ : A →⋆ₐ[ℂ] B) :
    compContinuousMap (ψ₂.comp ψ₁) = (compContinuousMap ψ₁).comp (compContinuousMap ψ₂) :=
  ContinuousMap.ext fun a => ext fun x => rfl
#align weak_dual.character_space.comp_continuous_map_comp WeakDual.characterSpace.compContinuousMap_comp

end CharacterSpace

end WeakDual

end Functoriality