-- To mathlib ?

import data.set.function
import data.equiv.basic
import topology.basic
import topology.constructions

#print continuous_equiv_fun_basis
#check function.uncurry
#check continuous
#print is_open_map.of_inverse
#print is_open_map.comp
#check preimage_equivalence
#print nhds_le_of_le

lemma continuous_uncurry {A B C : Type} [topological_space A] [topological_space B] [topological_space C]
: continuous (@function.uncurry A B C) :=
begin
    intros s hs,
    apply is_open_iff_nhds.mpr,
    intros a ha,
    rw filter.le_principal_iff,
    change (function.uncurry a ∈ s) at ha,
    sorry,
end

lemma continuous_uncurry_apply {A B C : Type} [topological_space A] [topological_space B] [topological_space C]
(f : A → B → C) (hf : continuous f) : continuous (function.uncurry f) :=
begin
  intros s1 hs1,
  let s2 : set (B → C) := { h : B → C | ∀ b, h b ∈ s1 },
  have hs2 : is_open s2,
  { sorry, },
  sorry,
end

#check continuous_iff_continuous_at
#print continuous_at
#print filter.tendsto
#print continuous_infi_dom
#check continuous_iff_coinduced_le
#print topological_space.coinduced

lemma continuous_flip {A B C: Type} [topological_space A] [topological_space B] [topological_space C]
(f : A → B → C) (hf : continuous f) : continuous (flip f) :=
begin
  --rw continuous_iff_continuous_at,
  --replace hf := (continuous_iff_continuous_at.mp hf),
  --intros x s hs,
  rw continuous_iff_coinduced_le,
  rw continuous_iff_coinduced_le at hf,
  intros x hx,
  sorry,
end


/-
Copyright (c) 2022 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser, Heather Macbeth
-/
import topology.uniform_space.pi
import data.matrix.basic

/-!
# Uniform space structure on matrices
-/

open_locale uniformity topological_space

variables (m n 𝕜 : Type*) [uniform_space 𝕜]

namespace matrix

instance : uniform_space (matrix m n 𝕜) :=
(by apply_instance : uniform_space (m → n → 𝕜))

lemma uniformity :
  𝓤 (matrix m n 𝕜) = ⨅ (i : m) (j : n), (𝓤 𝕜).comap (λ a, (a.1 i j, a.2 i j)) :=
begin
  erw [Pi.uniformity, Pi.uniformity],
  simp_rw [filter.comap_infi, filter.comap_comap],
  refl,
end

lemma uniform_continuous {β : Type*} [uniform_space β] {f : β → matrix m n 𝕜} :
  uniform_continuous f ↔ ∀ i j, uniform_continuous (λ x, f x i j) :=
by simp only [uniform_continuous, matrix.uniformity, filter.tendsto_infi, filter.tendsto_comap_iff]

instance [complete_space 𝕜] : complete_space (matrix m n 𝕜) :=
(by apply_instance : complete_space (m → n → 𝕜))

instance [separated_space 𝕜] : separated_space (matrix m n 𝕜) :=
(by apply_instance : separated_space (m → n → 𝕜))

end matrix


import  .Sup_fin data.finsupp order.lattice data.nat.cast .euclidean_domain unique_factorization_domain
import .to_finsupp .to_finset
universes u v w

noncomputable theory

open classical set function finsupp lattice

local attribute [instance] finsupp.to_comm_semiring
local attribute [instance] finsupp.to_semiring
local infix ^ := monoid.pow

-- TODO: for some reasons these rules don't work
@[simp] lemma nat_rec_zero {C : ℕ → Sort u} (h₁ : C 0) (h₂ : Π (n : ℕ), C n → C (nat.succ n)) :
  @nat.rec C h₁ h₂ 0 = h₁ := rfl

@[simp] lemma nat_rec_add_one {C : ℕ → Sort u} (h₁ : C 0) (h₂ : Π (n : ℕ), C n → C (nat.succ n)) {n : ℕ} :
  @nat.rec C h₁ h₂ (n + 1) = h₂ n (nat.rec h₁ h₂ n) := rfl

-- TODO: relax semiring to semi-algebra?
def polynomial (α : Type u) [semiring α] := ℕ →₀ α

--correct? should have an explicit argument
def characteristic_zero (α : Type u) [semiring α] : Prop :=  ∀ n : ℕ, n ≠ 0 → (↑n : α) ≠ 0

namespace polynomial
local attribute [instance] prop_decidable
variables {α : Type u} {a a' a₁ a₂ : α} --{n m : ℕ} --do we want n and m?

section semiring
variable [semiring α]

instance : has_coe_to_fun (polynomial α) := finsupp.has_coe_to_fun
instance : has_zero (polynomial α) := finsupp.has_zero
instance : has_one (polynomial α) := finsupp.has_one
instance : has_add (polynomial α) := finsupp.has_add
instance : has_mul (polynomial α) := finsupp.has_mul
instance : semiring (polynomial α) := finsupp.to_semiring

@[simp] lemma one_apply_zero : (1 : polynomial α) 0 = 1 := single_eq_same

@[simp] lemma zero_apply {n : ℕ} : (0 : polynomial α) n = 0 := zero_apply

def C (a : α) : polynomial α := finsupp.single 0 a

--embed R in R[x] --use has_lift, because has_coe is heavy on performance
instance : has_lift (α) (polynomial α) := ⟨C⟩ -- Is this embedding correct?

lemma embedding {a : α} : ↑a = C a := rfl --Where do we use this?

@[simp] lemma C_0 : C 0 = (0:polynomial α) := single_zero

@[simp] lemma C_1 : C 1 = (1:polynomial α) := rfl

lemma C_apply {c : α } {n : ℕ}: ((C c) : ℕ → α) n = (if 0 = n then c else 0) := rfl

lemma C_eq_zero_iff_eq_zero (c : α) : C c = 0 ↔ c = 0 :=
begin
  split,
  { intro h,
    have : ((C c) : ℕ → α) 0 = (0 : polynomial α) 0,
      { rw h},
    rw [C_apply, if_pos] at this,
    simp * },
  { intro h,
    simp * }
end

lemma C_add_C (a b : α) : C a + C b = C (a + b) :=
begin
  apply eq.symm,
  exact single_add,
end

def is_constant (p : polynomial α) : Prop := ∃ c : α, p = C c

@[simp] lemma is_constant_zero : is_constant (0 : polynomial α) :=  ⟨0, C_0.symm⟩

@[simp] lemma is_constant_C {c : α} : is_constant (C c) := ⟨c, rfl⟩

--naming?
lemma eq_zero_iff_embed_eq_zero {f : α} : f = 0 ↔ (↑f : polynomial α) = 0 :=
begin
  rw embedding,
  constructor, --Do we prefer constructor or split?
  {
    intro h,
    simp *,
  },
  {
    intro h,
    have : ((C f) : ℕ → α) 0 = f,
      {simp [C_apply]},
    rw h at this,
    simp * at *,
  }
end

def X : polynomial α := finsupp.single 1 1

lemma X_apply {n : ℕ}: ((X : polynomial α): ℕ → α) n = (if 1 = n then 1 else 0) :=  rfl

lemma single_eq_X_pow : ∀{n:ℕ}, single n a = C a * X ^ n
| 0       := by simp [C]
| (n + 1) :=
  calc single (n + 1) a = single n a * X : by simp [X, single_mul_single]
    ... = C a * X ^ (n + 1) : by rw [@single_eq_X_pow n]; simp [pow_add, pow_one, mul_assoc]

lemma X_pow_eq_single {n:ℕ} : (X ^ (n) : polynomial α) = single n 1 :=
begin
  calc (X ^ n : polynomial α) = C 1 * X ^ n : by simp [C_apply]
  ... = single n 1 : eq.symm single_eq_X_pow,
end

lemma X_pow_apply {n m : ℕ} : ((X  ^ n : polynomial α): ℕ → α) m = (if n = m then 1 else 0) :=
by rw [X_pow_eq_single, single_apply]

--naming?
lemma sum_const_mul_pow_X  {f : polynomial α} : finsupp.sum f (λ n a, C a * X ^ n) = f :=
begin
  have h1: f.sum single = f,
    from sum_single,
  simp [finsupp.sum] at h1,
  have h2 : finset.sum (support f) (λ (a : ℕ), single a (f a)) =  sum f (λ (n : ℕ) (a : α), C a * X ^ n),
    {
    apply finset.sum_congr (eq.refl f.support),
    intros x h2,
    apply single_eq_X_pow
    },
  rw ←h2,
  exact h1
end

lemma induction_on {M : polynomial α → Prop} (p : polynomial α)
  (M_C : ∀(a : α), M (C a)) (M_X : M X)
  (M_add : ∀{p q}, M p → M q → M (p + q))
  (M_mul : ∀{p q}, M p → M q → M (p * q)) :
  M p :=
have M_0 : M 0, by rw [←C_0]; exact M_C 0,
have M_1 : M 1, from M_C 1,
have M_single : ∀n c, M (single n c),
begin
  assume n a,
  rw [single_eq_X_pow],
  apply M_mul (M_C a),
  induction n; simp [M_1, pow_add, pow_one, nat.succ_eq_add_one, *]; exact M_1
end,
have M_sum : ∀{s:finset ℕ} {f : ℕ → polynomial α}, (∀a∈s, M (f a)) → M (s.sum f),
  from assume s f, finset.induction_on s (by simp [M_0]) (by simp * {contextual := tt}),
begin
  rw [←@sum_single _ _ _ p],
  apply M_sum,
  exact (assume a ha, M_single _ _)
end

lemma induction_on_X {M : polynomial α → Prop} (p : polynomial α)
  (M_C : ∀(a : α), M (C a))
  (M_add : ∀{p q}, M p → M q → M (p + q))
  (M_mul_X : ∀{p}, M p → M (p * X) ):
  M p :=
have M_0 : M 0, by rw [←C_0]; exact M_C 0,
have M_1 : M 1, from M_C 1,
have M_single : ∀n c, M (single n c),
begin
assume n a, simp [single_eq_X_pow ],
induction n, have htmp : C a * X ^ 0 = C a, simp [pow_zero], simp [pow_zero], exact M_C _, simp [pow_succ'],
have htmp3 : (C a * (X ^ n_n * X)) = (C a * (X ^ n_n) * X), simp [mul_assoc], rw [htmp3], apply M_mul_X, assumption
end,
have M_sum : ∀{s:finset ℕ} {f : ℕ → polynomial α}, (∀a∈s, M (f a)) → M (s.sum f),
  from assume s f, finset.induction_on s (by simp [M_0]) (by simp * {contextual := tt}),
begin
  rw [←@sum_single _ _ _ p],
  apply M_sum,
  exact (assume a ha, M_single _ _)
end

def eval (p : polynomial α) (a : α) : α := p.sum $ λn c, c * a ^ n

def degree (p : polynomial α) : ℕ := p.support.Sup_fin id

def leading_coeff (p : polynomial α) : α := p (degree p)

lemma leading_coeff_def {p : polynomial α } : leading_coeff p = p (degree p) := rfl

--Can you add the simp attribute to a definition?
def monic (p : polynomial α):= leading_coeff p = 1

--Does this work? No leads to deep recursion??
--@[simp] lemma monic_def {f : polynomial α} {h : monic f} : leading_coeff f = 1 := h --Should we make monic reducible instead?

lemma ext : ∀{f g : polynomial α}, (∀a, f a = g a) → f = g:= @finsupp.ext _ _ _

lemma exists_coeff_ne_zero_of_ne_zero {f : polynomial α}: f ≠ 0 → ∃m, f m ≠ 0:=
assume h,
  have ¬(∀k, f k = (0 : polynomial α) k),
    from (iff.elim_right not_imp_not ext) h,
  classical.not_forall.1 this

lemma le_degree {p : polynomial α} {n : ℕ} (h : p n ≠ 0) : n ≤ degree p :=
show id n ≤ degree p, from finset.le_Sup_fin (by simp [h])

lemma le_degree_of_mem_support {p : polynomial α} {n : ℕ} : n ∈ support p → n ≤ degree p :=
begin
  intro h1,
  apply le_degree,
  rwa [mem_support_iff] at h1,
end

@[simp] lemma degree_zero : degree (0 : polynomial α) = 0 :=
have (0 : polynomial α).support = ∅, from support_zero,
by simp [degree, this]; refl

--naming?
lemma degree_single {a : α} {n : ℕ} : degree (single n a) ≤ n :=
calc degree (single n a) = (single n a).support.Sup_fin id : by simp [degree]
  ... ≤ (finset.singleton n).Sup_fin id : finset.Sup_fin_mono finsupp.support_single_subset
  ... ≤ _ : by simp [finset.Sup_fin_singleton]

lemma degree_single_eq {a : α} (n : ℕ): degree ((single n a) : polynomial α) = (if a = 0 then (0 : ℕ) else n) :=
begin
  by_cases h : a = 0,
  {
    simp [h],
    apply degree_zero, --Why didn't the simplifier do this?
  },
  {
    simp [if_neg, *],
    apply le_antisymm (degree_single),
    {
      apply le_degree, --Why can't I give this to the simplifier?
      simpa,
    }
  }
end

@[simp] lemma degree_X (h : 0 ≠ (1:α)) : degree (X : polynomial α) = 1 :=
by rwa [X, degree_single_eq, if_neg h.symm]

lemma degree_X_eq_zero_of_zero_eq_one (h : 0 = (1:α)) : degree (X : polynomial α) = 0 :=
by rwa [X, degree_single_eq, if_pos h.symm]

--correct simp?
@[simp] lemma degree_X_pow (h : 0 ≠ (1:α)) {n : ℕ} : degree ((X : polynomial α) ^ n) = n :=
by rw [X_pow_eq_single, degree_single_eq, if_neg h.symm]

@[simp] lemma degree_C {a : α} : degree (C a) = 0 :=
nat.eq_zero_of_le_zero degree_single

@[simp] lemma degree_one : degree (1: polynomial α)  = 0 := degree_C

lemma degree_add {f g : polynomial α} : degree (f + g) ≤ max (degree f) (degree g) :=
calc degree (f + g) ≤ (f.support ∪ g.support).Sup_fin id : finset.Sup_fin_mono finsupp.support_add
  ... = max (degree f) (degree g) : finset.Sup_fin_union

lemma degree_sum {β : Type w} {s : finset β} {f : β → polynomial α} :
  degree (s.sum f) ≤ s.Sup_fin (λi, degree (f i)) :=
finset.induction_on s (by simp; refl) $
  assume b s hbs ih,
  calc degree ((insert b s).sum f) = degree (f b + s.sum f) : by simp [hbs]
    ... ≤ degree (f b) ⊔ degree (s.sum f) : degree_add
    ... ≤ degree (f b) ⊔ s.Sup_fin (λi, degree (f i)) : sup_le_sup (le_refl _) ih
    ... = (insert b s).Sup_fin (λi, degree (f i)) : by simp

lemma degree_mul {f g : polynomial α} : degree (f * g) ≤ degree f + degree g :=
calc degree (f * g) ≤ _ : degree_sum
  ... ≤ _ : finset.Sup_fin_mono_fun $ assume a ha, degree_sum
  ... ≤ _ : finset.Sup_fin_le $ assume b₁ hb₁, finset.Sup_fin_le $ assume b₂ hb₂,
    calc _ ≤ b₁ + b₂ : degree_single
      ... ≤ degree f + degree g : add_le_add (finset.le_Sup_fin hb₁) (finset.le_Sup_fin hb₂)

lemma ne_zero_of_degree_ne_zero {f : polynomial α} : degree f ≠ 0 → f ≠ 0 :=
begin
  intros h1 h2,
  simp * at *,
end

--application lemmas --correct?
@[simp] lemma add_apply {g₁ g₂ : polynomial α} {a : ℕ} :
  (g₁ + g₂) a = g₁ a + g₂ a := finsupp.add_apply

/-leading coef lemmas-/

@[simp] lemma leading_coeff_single {a : α} {n : ℕ} : leading_coeff (single n a) = a :=
begin
  rw [leading_coeff, degree_single_eq],
  by_cases h1 : a = 0 ; simp [*, single_apply]
end

@[simp] lemma leading_coeff_C {a : α} : leading_coeff (C a) = a :=
by simp [leading_coeff_def, degree_C, C_apply]

@[simp] lemma leading_coeff_zero : leading_coeff (0 : polynomial α) = 0 := rfl

@[simp] lemma leading_coeff_one : leading_coeff (1 : polynomial α) = 1 := leading_coeff_C

@[simp] lemma leading_coeff_X : leading_coeff (X : polynomial α) = 1 :=
by rw [X, leading_coeff_single]

--Are we using the interference here correctly? --Correct simp?
lemma not_monic_zero (h : (0 : α) ≠ 1) : ¬monic (0 : polynomial α) :=
by simpa [monic]

lemma ne_zero_of_monic (h0 : (0 : α) ≠ 1) (p : polynomial α) (h : monic p) : p ≠ 0 :=
begin
  intro h1,
  subst h1,
  exact not_monic_zero h0 h,
end

lemma monic_X : monic (X : polynomial α) :=
by rw [monic, leading_coeff_X]

@[simp] lemma monic_one : monic (1 : polynomial α) := leading_coeff_one

lemma leading_coeff_X_pow {n : ℕ} : leading_coeff ((X ^ n) : polynomial α) = (1 : α) :=
by  rw [X_pow_eq_single, leading_coeff_single]

lemma monic_X_pow {n : ℕ }: monic ((X ^ n) : polynomial α) :=
by rw [monic, leading_coeff_X_pow]

def root_of (a : polynomial α) (b : α) := polynomial.eval a b = 0

lemma C_mul_X {c : α} : C c * X = single 1 c :=
calc C c * X = single 0 c * single 1 1 : rfl
... = single (0 + 1) (c * 1) : single_mul_single
... = single 1 c : by simp

--Should we remove the implication lemmas? and only keep the IFF?
lemma is_constant_of_degree_eq_zero {p : polynomial α} : degree p = 0 → is_constant p :=
begin
  intro h,
  have h1 : support p = {0} ∨ support p = ∅,
    from eq_singleton_or_eq_empty_of_sup_fin_eq_bot h,
  cases h1,
  {
    exact eq_single_of_support_eq_singleton _ h1,
  },
  {
    have : p = 0,
    {
      exact eq_zero_of_support_eq_empty _ h1,
    },
    exact ⟨0, by simp * at *⟩,
  }
end

lemma is_constant_iff_degree_eq_zero {p : polynomial α} : is_constant p ↔ degree p = 0 :=
begin
  constructor,
  {
    intro h1,
    rcases h1 with ⟨c, h2⟩,
    simp *,
  },
  {
    exact is_constant_of_degree_eq_zero
  }
end

lemma eq_zero_of_leading_coef_eq_zero {p : polynomial α} : leading_coeff p = 0 → p = 0 :=
begin
  intro h1,
  by_cases h2 : (degree p = 0),
  {
    rw ←is_constant_iff_degree_eq_zero at h2,
    rcases h2 with ⟨c, h3⟩,
    subst h3,
    simp [*, C_apply] at *,
  },
  {
  have h3 : support p ≠ ∅,
    {
      have h3a : p ≠ 0,
        from ne_zero_of_degree_ne_zero h2,
      rwa [ne.def, ←eq_zero_iff_support_eq_empty p],
    },
    have h4 : degree p ∈ support p,
      from Sup_fin_mem_of_id_nat h3,
    have h5 : p (degree p) ≠  0,
      {rwa ←mem_support_iff p},
    contradiction
  }
end

@[simp] lemma leading_coef_zero_eq_zero : leading_coeff 0 = (0 : α):=
by simp [leading_coeff]

--Should we remove the sublemmas?
lemma leading_coef_eq_zero_iff_eq_zero {p : polynomial α} : leading_coeff p = 0 ↔ p = 0 :=
iff.intro eq_zero_of_leading_coef_eq_zero (by simp {contextual := tt})

--lt maybe better?
lemma eq_zero_of_gt_degree : ∀{h : polynomial α}, ∀{x : ℕ}, x > degree h → h x = 0 :=
begin
  intros h x h1,
  by_contradiction h2,
  have h9: x ≤ degree h,
    from le_degree h2,
  have : ¬ x ≤ degree h,
    from not_le_of_gt h1,
  contradiction,
end

private lemma add_lemma {a b c d : ℕ} : a < c → a + b = c + d → b > d :=
begin
    intros h1 h2,
    by_contradiction h3,
    have h4 : b ≤ d,
      from le_of_not_gt h3,
    have : a + b < c + d,
    {
      calc a + b < c + b : add_lt_add_right h1 b
      ... ≤ c + d : add_le_add_left h4 c,
    },
    have : a + b ≥ c + d,
    {
      simp [h2],
      exact le_refl _,
    },
    have : ¬ a + b < c + d,
      {simp [*, not_lt_of_ge]},
    contradiction
end

private lemma h_sum (f g : polynomial α) :
sum f (λ (n : ℕ) (b : α), sum g (λ (m : ℕ) (c : α), ite (n + m = degree f + degree g) (b * c) 0)) =
sum f (λ (n : ℕ) (b : α), sum g (λ (m : ℕ) (c : α), (ite (n = degree f) b 0) * (ite (m = degree g) c 0))) :=
begin
  apply finsupp.sum_congr (eq.refl (support f)),
  intros n h1,
  apply finsupp.sum_congr (eq.refl (support g)),
  intros m h2,

  by_cases h5 : (n + m = degree f + degree g),
  {
    by_cases h3 : (n = degree f),
    {
      subst h3,
      have h4 : m = degree g,
        from nat.add_left_cancel h5,
      simp *,
    },
    {
      have h6 : n ≤ degree f,
        from le_degree_of_mem_support h1,
      have h8 : n < degree f,
        from nat.lt_of_le_and_ne h6 h3,
      have h7 : (m > degree g),
        from add_lemma h8 h5,
      have h8 : g m = 0,
        from eq_zero_of_gt_degree h7,
      simp *,
    },
  },
  {
    have h5 : ¬ ((n = degree f) ∧ (m = degree g)),
    {
      by_contradiction h6,
      simp * at *,
    },
    rw not_and_distrib at h5,
    cases h5 ; simp *,
  }
end

private lemma h_sum_2 (f g : polynomial α) :
sum f (λ (n : ℕ) (b : α), sum g (λ (m : ℕ) (c : α), ite (n = degree f) b 0 * ite (m = degree g) c 0)) =
sum f (λ (n : ℕ) (b : α), ite (n = degree f) b 0 * sum g (λ (m : ℕ) (c : α), ite (m = degree g) c 0)):=
finsupp.sum_congr (eq.refl f.support) (assume x h1, eq.symm finset.mul_sum)

private lemma h_sum_3 (f g : polynomial α) :
sum f (λ (n : ℕ) (b : α), ite (n = degree f) b 0 * sum g (λ (m : ℕ) (c : α), ite (m = degree g) c 0)) =
(sum f (λ (n : ℕ) (b : α), ite (n = degree f) b 0)) * sum g (λ (m : ℕ) (c : α), ite (m = degree g) c 0):=
eq.symm finsupp.sum_mul

private lemma h_sum_g (f g : polynomial α):
sum g (λ (m : ℕ) (c : α), ite (m = degree g) c 0) = if (degree g ∈ g.support) then g (degree g) else 0 :=
finsupp.sum_ite

private lemma h_sum_f (f g : polynomial α): sum f (λ (m : ℕ) (c : α), ite (m = degree f) c 0) = if (degree f ∈ f.support) then f (degree f) else 0 :=
finsupp.sum_ite

lemma degree_mem_support_of_ne_zero {p : polynomial α} (h1 : p ≠ 0) : degree p ∈ support p :=
begin
  apply Sup_fin_mem_of_id_nat,
  simp,
  rw ←eq_zero_iff_support_eq_empty,
  exact h1
end

lemma mul_degree_add_degree_eq_leading_coeff_mul_leading_coeff {f g : polynomial α} : (f * g) (degree f + degree g) = (leading_coeff f) * (leading_coeff g):=
begin
  rw mul_def,
  simp [single_apply],
  rw [h_sum, h_sum_2, h_sum_3,h_sum_g f g, h_sum_f f g],
  by_cases h1 : (f = 0),
  {
    subst h1,
    simp *,
  },
  {
    rw [if_pos (degree_mem_support_of_ne_zero h1)],
    by_cases h4 : (g = 0),
    {
      subst h4,
      simp *,
    },
    {
      rw [if_pos (degree_mem_support_of_ne_zero h4)],
      exact rfl,
    },
  }
end

lemma degree_mul_eq_degree_add_degree_of_leading_coeff_mul_leading_coeff_ne_zero
{f g : polynomial α} (h : leading_coeff f * leading_coeff g ≠ 0) : degree (f * g) = degree f + degree g :=
begin
  have h4: (f * g) (degree f + degree g) ≠  0,
  {
    calc (f * g) (degree f + degree g) = leading_coeff f * leading_coeff g : mul_degree_add_degree_eq_leading_coeff_mul_leading_coeff
    ... ≠ 0 : h,
  },
  have h5 : degree f + degree g ≤ degree (f * g),
    from le_degree h4,
  have h6: degree (f * g) ≤ degree f + degree g,
    from degree_mul,
  exact le_antisymm h6 h5
end

lemma degree_monic_mul {f g : polynomial α}(h1 : monic f) (h2 : (0 : α) ≠ 1)(h3 : g ≠ 0): degree (f * g) = degree f + degree g :=
begin
  have h3 : leading_coeff f * leading_coeff g ≠ 0,
  {
    rw [ne.def, ←leading_coef_eq_zero_iff_eq_zero] at h3,
    simp [monic, *] at *,
  },
  exact degree_mul_eq_degree_add_degree_of_leading_coeff_mul_leading_coeff_ne_zero h3,
end

--naming?
lemma leading_coeff_monic_mul{f g: polynomial α} {h1 : monic f} (h2 : (0 : α) ≠ 1): leading_coeff (f * g) = leading_coeff g :=
begin
  by_cases h3 : (g = 0),
  {
   simp *,
  },
  {
    have h4 : degree (f * g) = degree f + degree g,
      from degree_monic_mul h1 h2 h3,
    rw [leading_coeff, h4, mul_degree_add_degree_eq_leading_coeff_mul_leading_coeff],
    simp [monic, *] at *,
  }
end

--naming incorrect?
lemma C_mul_C {a b : α} : C (a * b) = C a * C b :=
by simp [C, single_mul_single]

end semiring

section comm_semiring
variable [comm_semiring α]

instance : comm_semiring (polynomial α) := finsupp.to_comm_semiring

lemma C_prod_eq_map_C_prod {f : multiset α} : C (f.prod) = (f.map C).prod :=
begin
  fapply multiset.induction_on f,
  {
    simp
  },
  {
    intros a s h1,
    simp [C_mul_C, *]
  }
end

lemma mul_C_eq_sum {f : polynomial α} {a : α} : f * C a = f.sum (λi c, single i (a * c)) :=
calc f * C a = (f.sum single) * C a : by rw [sum_single]
  ... = f.sum (λi c, single i c * C a) : finset.sum_mul
  ... = f.sum (λi c, single i (a * c)) :
    by simp [single_eq_X_pow, C_mul_C, mul_assoc, mul_comm, mul_left_comm]

lemma mul_X_eq_sum {f : polynomial α} : f * X = f.sum (λi c, single (i + 1) c) :=
calc f * X = (f.sum single) * X : by rw [sum_single]
  ... = f.sum (λi c, single i c * X) : finset.sum_mul
  ... = f.sum (λi c, single (i + 1) c) :
    by simp [single_eq_X_pow, pow_add, pow_one, mul_assoc, mul_comm, mul_left_comm]

lemma degree_le {p : polynomial α} {n : ℕ} (h : ∀ m > n, p m = 0) : degree p ≤ n :=
begin
  by_cases h1 : (p = 0),
  {
    simp [*, nat.zero_le]
  },
  {
    have h2 : degree p ∈ support p,
      from degree_mem_support_of_ne_zero h1,
    rw [mem_support_iff] at h2,
    by_contradiction h3,
    have h4 : degree p > n,
      from lt_of_not_ge h3,
    have : p (degree p) = 0,
      from h _ h4,
    contradiction,
  }
end

open finset

--Are these used in MS 2? That is more general using multisets.
--Where to place this?
lemma dvd_sum_of_forall_mem_dvd [comm_semiring α] {β : Type u} {p : α} {s : finset β} {f : β → α} :
   (∀ x ∈ s, p ∣ f x) → p ∣ (s.sum f) :=
begin
  apply finset.induction_on s,
  {simp},
  {
    intros a s h1 h2 h3,
    have htmp: (∀ (x : β), x ∈ s → p ∣ f x),
    {
      intros y h4,
      have : y ∈ insert a s,
      {
        simp [finset.mem_insert, h4],
      },
      exact h3 y this,
    },
    have ha_mem : a ∈ insert a s,
    {
      simp [finset.mem_insert],
    },
    have ha: p ∣ f a,
      from h3 a ha_mem,
    have hsum: p ∣ sum s f,
      from h2 htmp,
    simp [finset.sum_insert h1, dvd_add ha hsum],
  }
end

--Is this used?
lemma dvd_prod_of_dvd_mem {β : Type w} {p : polynomial α} {s : finset β} {x : β} {f : β → polynomial α} (h_mem :  x ∈ s) (h_dvd : p ∣ f x) :
p∣ s.prod f :=
begin
  rw ←(insert_erase h_mem),
  simp [finset.prod_insert, dvd_mul_of_dvd_left h_dvd (finset.prod (erase s x) f)],
end

--Is this used?
lemma pow_sub_one_dvd_pow
{p : polynomial α} {n : ℕ} : monoid.pow p (n - 1) ∣ (monoid.pow p n) :=
begin
  cases n,
  {
    simp,
  },
  {
    rw nat.succ_sub_one,
    refine  dvd_of_mul_left_eq p _,
    exact rfl,
  },
end

end comm_semiring

section ring
variable [ring α]

--made priority local,but doesn't solve the problem..
instance : ring (polynomial α) := finsupp.to_ring
instance : add_comm_group (polynomial α) := by apply_instance

local attribute [priority 1100]  polynomial.ring
local attribute [priority 1100]  polynomial.add_comm_group

--application lemmas

@[simp] lemma neg_apply  {g : polynomial α } {a : ℕ } : (- g) a = - g a := finsupp.neg_apply

@[simp] lemma sub_apply {g₁ g₂ : polynomial α } {a : ℕ} : (g₁ - g₂) a = g₁ a - g₂ a := finsupp.sub_apply

--correct simp?
@[simp] lemma degree_neg {f : polynomial α} : degree (-f) = degree f:=
by simp [degree]

lemma degree_sub {f g : polynomial α} : degree (f - g) ≤ max (degree f) (degree g) :=
calc degree (f - g) = degree (f  + (- g)) : by simp
     ... ≤ max (degree f) (degree (-g)) : degree_add
     ...= max (degree f) (degree g) : by rw (@degree_neg _ _ g)

lemma neg_C_eq_C_neg (c : α) : - C c = C (- c) :=
begin
  apply eq.symm,
  simp [eq_neg_iff_add_eq_zero, C_add_C],
end

/-Why doesn't this work? It produces deep recursion?
@[simp] lemma is_constant_of_is_constant_neg (p : polynomial α) (h : is_constant (-p)) : is_constant p :=
begin
  rcases h with ⟨c, hc⟩,
  have : p = - C c,
  {
    exact calc p = - - p : by simp
    ... = _ : by rw hc,
  },
  subst this,
  simp [neg_C_eq_C_neg],
end-/

lemma is_constant_neg_iff_is_constant (p : polynomial α) : is_constant (-p) ↔ is_constant p :=
begin
  split,
  {
    intro h,
    rcases h with ⟨c, hc⟩,
    have : p = - C c,
    {
      exact calc p = - - p : by simp
      ... = _ : by rw hc,
    },
    subst this,
    simp [neg_C_eq_C_neg],
  },
  {
    intro h,
    rcases h with ⟨c, hc⟩,
    subst hc,
    exact ⟨-c, neg_C_eq_C_neg c⟩,
  }
end

end ring

section comm_ring
variable [comm_ring α]

instance : comm_ring (polynomial α) := finsupp.to_comm_ring

end comm_ring

end polynomial


------------------------------------------------------------------------------
-- File     : PUZ134_2 : TPTP v7.3.0. Released v5.1.0.
-- Domain   : Puzzles
-- Problem  : The Knowheyan Job Puzzle - Ages
-- Version  : Especial.
-- English  : Five Knowheyans, A, B, C, D, and E, work in Metropolisas Airfoil
--            Technician, Communications Consultant, Space Planner, Lunar Energy
--            Engineer, and Synthetic Food Nutrionist. No two of them are the
--            same age. The Knowheyan interpreter explains about the jobs and
--           ages of these five inhabitants, as follows:
--           1. The Communications Consultant is not younger than any of the
--              other four.
--           2. D is not as old as A and not as young as B, who is not as old
--              as the Lunar Energy Engineer, but not as young as C.
--            3. The Airfoil Technician is not younger than the Space Planner,
--               who is not younger than the Synthetic Food Nutrionist.
--            4. C is not the yougest of the five.
--            What is the age order of the five Knowheyans?

-- Refs     : [WS+06] Willis et al. (2006), The World's Biggest Book of Brai
-- Source   : [TPTP]
--------------------------------------------------------------------------------

variable knowheyan: Type

variable job: Type

variable age: Type

variable age_of: knowheyan → age

variable job_of: knowheyan → job

variable greater: age × age → Prop

variable a: knowheyan

variable b: knowheyan

variable c: knowheyan

variable d: knowheyan

variable e: knowheyan

-- axioms
variable a_not_b : a ≠ b

variable a_not_c : a ≠ c

variable a_not_d : a ≠ d

variable a_not_e : a ≠ e

variable b_not_c : b ≠ c

variable b_not_d : b ≠ d

variable b_not_e : b ≠ e

variable c_not_d : c ≠ d

variable c_not_e : c ≠ e

variable d_not_e : d ≠ e

variable airfoil_technician: job

variable communications_consultant: job

variable space_planner: job

variable lunar_energy_engineer: job

variable synthetic_food_nutitionist: job

variable airfoil_technician_not_communications_consultant:
    airfoil_technician ≠ communications_consultant

variable airfoil_technician_not_space_planner:
    airfoil_technician ≠ space_planner

variable airfoil_technician_not_lunar_energy_engineer:
    airfoil_technician ≠ lunar_energy_engineer

variable airfoil_technician_not_synthetic_food_nutitionist:
    airfoil_technician ≠ synthetic_food_nutitionist

variable communications_consultant_not_space_planner:
    communications_consultant ≠ space_planner

variable communications_consultant_not_lunar_energy_engineer:
    communications_consultant ≠ lunar_energy_engineer

variable communications_consultant_not_synthetic_food_nutitionist:
    communications_consultant ≠ synthetic_food_nutitionist

variable space_planner_not_lunar_energy_engineer:
    space_planner ≠ lunar_energy_engineer

variable space_planner_not_synthetic_food_nutitionist:
    space_planner ≠ synthetic_food_nutitionist

variable lunar_energy_engineer_not_synthetic_food_nutitionist:
    lunar_energy_engineer ≠ synthetic_food_nutitionist

variable only_knowheyans:
    ∀ (X: knowheyan) ,
      ( X = a
      ∨ X = b
      ∨ X = c
      ∨ X = d
      ∨ X = e )

variable only_jobs:
    ∀ (X: job) ,
      ( X = airfoil_technician
      ∨ X = communications_consultant
      ∨ X = space_planner
      ∨ X = lunar_energy_engineer
      ∨ X = synthetic_food_nutitionist )

variable unique_ages:
    ∀ (X: knowheyan) (Y: knowheyan) ,
      ( X ≠ Y
     → age_of(X) ≠ age_of(Y) )

variable unique_jobs:
    ∀ (X: knowheyan) (Y: knowheyan) ,
      ( X ≠ Y
     → job_of(X) ≠ job_of(Y) )

variable age_transitive:
    ∀ (X: age) (Y: age) (Z: age) ,
      ( ( greater(X,Y)
        ∧ greater(Y,Z) )
     →  greater(X,Z) )

variable age_irreflexive:
    ∀ (X: age)(Y: age) ,
      ¬ ( greater(X,Y)
        ∧ greater(Y,X) )

variable age_greater:
  ∀ (X: age)(Y: age) ,
      ( X ≠ Y
    ↔ ( greater(X,Y)
        ∨ greater(Y,X) ) )

variable communications_consultant_not_younger:
    ∀ (X: knowheyan) ,
      ( job_of(X) = communications_consultant
     → ¬ ∃ (Y: knowheyan) , greater(age_of(Y),age_of(X)) )

variable age_info1:
    greater(age_of(a),age_of(d))

variable age_info2:
    greater(age_of(d),age_of(b))

variable age_info3:
    ∀ (X: knowheyan) ,
      ( job_of(X) = lunar_energy_engineer
     → greater(age_of(X),age_of(b)) )

variable age_info4:
    greater(age_of(b),age_of(c))

variable age_job1:
    ∀ (X: knowheyan) (Y: knowheyan) ,
      ( ( job_of(X) = airfoil_technician
        ∧ job_of(Y) = space_planner )
     → greater(age_of(X),age_of(Y)) )

variable age_job2:
    ∀ (X: knowheyan) (Y: knowheyan) ,
      ( ( job_of(X) = space_planner
        ∧ job_of(Y) = synthetic_food_nutitionist )
     ∧ greater(age_of(X),age_of(Y)) )

variable c_not_youngest:
    ∃ (X: knowheyan) , greater(age_of(c),age_of(X))

-- conjecture : age_order
theorem age_order :
    ( greater(age_of(a),age_of(d))
    ∧ greater(age_of(d),age_of(b))
    ∧ greater(age_of(b),age_of(c))
    ∧ greater(age_of(c),age_of(e)) ) := sorry


import SciLean.Basic
import SciLean.Mechanics
import SciLean.Data.Prod
-- import SciLean.Solver.Solver

open SciLean

set_option synthInstance.maxSize 2048
-- set_option synthInstance.maxHeartbeats 5000000
-- set_option maxHeartbeats 5000000

variable {X : Type} [Hilbert X]

instance : IsSmooth Math.sin := sorry
instance : IsSmooth Math.cos := sorry
instance : IsSmooth Math.exp := sorry

@[simp]
theorem differential_of_cos : ∂ Math.cos = λ x dx => - dx * Math.sin x := sorry
@[simp]
theorem differential_of_sin : ∂ Math.sin = λ x dx => dx * Math.cos x := sorry
@[simp]
theorem differential_of_exp : ∂ Math.exp = λ x dx => dx * Math.exp x := sorry

instance : IsSmooth (λ (x : X×X) => ⟪x.1,x.1 + x.1⟫) := by infer_instance
instance : IsSmooth (λ ((r,s) : ℝ×ℝ) => r + r * r) := by simp; infer_instance

abbrev Parm (X : Type) [Hilbert X] {Y} [Hilbert Y] (P : Y ⟿ (X ⟿ ℝ)) := X × X × ℝ × Y

variable {Y: Type} [Hilbert Y] (P : Y ⟿ (X ⟿ ℝ))

instance : Hilbert (Parm X P) := by simp[Parm] infer_instance

def parm (r : ℝ) : Parm X P → (X → ℝ) :=
  λ (y,k,ω,α) => λ x => (P α x) * Math.cos (⟪k, x - y⟫ + ω) * Math.exp (- ∥x - y∥² * (1/r^2))

def parm' (r : ℝ) : Parm X P ⟿ (X ⟿ ℝ) :=
  ⟨λ (y,k,ω,α) => λ x ⟿ (P α x) * Math.cos (⟪k, x - y⟫ + ω) * Math.exp (- ∥x - y∥² * (1/r^2)), sorry⟩
  -- , by
  --     simp;
  --     conv =>
  --       enter [1,x]
  --       simp[Smooth.Hom.mk]
  --     simp; infer_instance⟩

def parm'' (r : ℝ) : Parm X P → (X → ℝ) :=
  λ p => λ x =>
    let y := p[0]
    let k := p[1]
    let ω := p[2]
    let α := p[3]
    (P α x) * Math.cos (⟪k, x - y⟫ + ω) * Math.exp (- ∥x - y∥² * (1/r^2))
  -- , by simp infer_instance⟩
  -- , by simp infer_instance⟩

example (r : ℝ) : IsSmooth (λ α : Parm X P => parm'' P r α) := by simp[parm''] infer_instance

#check Subtype
@[simp]
theorem differential_of_subtype {X : Type} [Vec X] (P : X → Prop) [Vec (Subtype P)]
  : ∂ (λ x : (Subtype P) => x.1) = λ x dx => dx.1 := sorry

@[simp]
theorem differential_of_fst {X Y : Type} [Vec X] [Vec Y]
  : ∂ (λ ((x,y) : X×Y) => x) = λ (x,y) (dx,dy) => dx := sorry

@[simp]
theorem differential_of_fst' {X Y : Type} [Vec X] [Vec Y]
  : ∂ (λ (x : X×Y) => x.fst) = λ x dx => dx.fst := sorry

-- set_option trace.Meta.Tactic.simp.discharge true in
-- set_option trace.Meta.Tactic.simp.unify true in
noncomputable
example : Impl (∂ λ p => parm'' P r p) :=
  by
    -- funext (y,k,ω,α) (dy,dk,dω,dα)
    simp[parm'']
    unfold_atomic
    simp[Prod.getOp, Prod.Get.geti]
    unfold_atomic
    finish_impl

variable (x : ℂ) (y : ℝ)

constant integrall : (X → Y) → Y

prefix:max "∫" => integrall

#check SciLean.integral

variable [Hilbert X] {A : Type} [Hilbert A] [Hilbert Y]

variable (U : A → X → Y) [IsSmooth U] [∀ a, IsSmooth (U a)]

-- #check ∫ λ x : X => λ a b => λ da => (λ db => ⟪∂ U a da x, ∂ U b db x⟫)† 1

variable (f : X → Y) (k : X) (ω r : ℝ)

-- #check (∫ λ x : X => ℂ.exp ⟨-∥x∥², ⟪k, x⟫⟩ * ⟨f x, 0⟩)
--        =
--        (∫ λ x : X => Math.exp (- ∥x∥²) * fᶜ ⟨x, -k⟩) -- Math.exp (- ∥x∥²) *

namespace AbstractManifolGalerkin

  structure ApproxSolution {X} [Vec X] (spec : X → Prop) where
    approx : ℕ → X
    proof : spec (limit val)

  structure Solution {X} [Vec X] (spec : X → Prop) where
    approx : X
    proof : spec val

  variable {X : Type} [Hilbert X]
  variable {U : ℕ → Type} [∀ n, Vec (U n)]

  variable (f : X → X) (x : ℝ → X)

  def manifoldGalerkinSolution (f : X → X) (x₀ : X) (p : (n : ℕ) → U n → X) [∀ n, IsSmooth (p n)] (n : ℕ) :=
    Solution (λ (uₙ : ℝ → U n) =>
        (∀ v t, ⟪ⅆ (p n ∘ uₙ) t, ∂ (p n) (uₙ t) v⟫
                =
                ⟪f (p n (uₙ t)), ∂ (p n) (uₙ t) v⟫)
        ∧
        (∀ v, ⟪x₀ - p n (uₙ 0), ∂ (p n) (uₙ 0) v⟫ = 0))

  -- Give a fix approximation `p : U → X`, we form an approximation by
  -- summing n copies of `p` i.e. `x` is approximated by `∑ i, p (u i)`
  def manifoldGalerkinNSolution {U} [Vec U] (f : X → X) (x₀ : X) (p : U → X) [IsSmooth p] (n : ℕ) :=
    let Uₙ := Fin n → U  -- U^n ???
    Solution (λ (uₙ : ℝ → Uₙ) =>
      (∀ i v t, (∑ j, ⟪∂ p (uₙ t j) (ⅆ uₙ t j), ∂ p (uₙ t i) v⟫)
                 =
                 ⟪f (∑ j, p (uₙ t j)), ∂ p (uₙ t i) v⟫)
      ∧
      ∀ i v, ⟪x₀ - (∑ j, p (uₙ 0 j)), ∂ p (uₙ 0 i) v⟫ = 0)

  variable {U : Type} [Hilbert U] (f : X → X) (x₀ : X) (p : U → X) [IsSmooth p] (n : ℕ)

  -- Mass Matrix Block : U → U
  #check λ uj ui vj => (λ vi => ⟪∂ p uj vj, ∂ p ui vi⟫)† 1

  -- rhs block for linear problems
  #check λ uj ui => (λ vi => ⟪f uj, ∂ p ui vi⟫)† 1

  #check Impl

  def manifoldGalerkinNSolution.blockwiseLinear {U} [Hilbert U] (f : X → X) (p : U → X) [IsSmooth p] (n : ℕ) (u₀ : Fin n → U)
    (mblock : Impl (λ uj ui vj => (λ vi => ⟪∂ p uj vj, ∂ p ui vi⟫)† 1))
    (fblock : Impl (λ uj ui => (λ vi => ⟪f (p uj), ∂ p ui vi⟫)† 1)) :=
    let Uₙ := Fin n → U  -- U^n ???
    let massMatrix : Uₙ → Uₙ → Uₙ := λ u v i => ∑ j, mblock.assemble! (u j) (u i) (v i)
    let forces : Uₙ → Uₙ := λ u i => ∑ j, fblock.assemble! (u j) (u i)
    Solution (λ (uₙ : ℝ → Uₙ) =>
      (∀ t, massMatrix (uₙ t) (ⅆ uₙ t) = forces (uₙ t))
      ∧
      (uₙ 0 = u₀))

  -- (ⅆ u = v) ∧ (ⅆ v = c^2 * ∂ u)
  noncomputable
  def ∂ {d : ℕ} (f : (ℝ^d) → ℝ) : (ℝ^d) → ℝ := sorry

  -- noncomputable
  -- def waveEquation (dim : ℕ) (speed : ℝ) : (ℝ → ℝ)×(ℝ → ℝ) → (ℝ → ℝ)×(ℝ → ℝ) :=
  --   λ (u, v) => (v, (speed^(2:ℝ)) * ∂ u)

  /- position, wave vector, phase shift, amplitude -/
  abbrev 𝓤 := (ℝ^(2:ℕ)) × (ℝ^(2:ℕ)) × ℝ × ℝ

  def parm (r : ℝ) : 𝓤 → ((ℝ^(2:ℕ)) → ℝ) :=
    λ (y, k, ω, A) =>
    λ x =>
    A * Math.cos (⟪k, x - y⟫ - ω) *  Math.exp (- ∥x-y∥²/(r^2))

  /- Final flattened vector for speed -/
  abbrev Uₙ (n : ℕ) := ℝ^(n * 6)
  def elem  {n} : Uₙ n → (Fin n → 𝓤) := sorry
  def intro {n} : (Fin n → 𝓤) → Uₙ n := sorry

  def to_solution {n} : Uₙ n → (ℝ^(2:ℕ)) → ℝ := sorry

  /- The idea is that types `Z a` closely resonstruct the type `X`
     However, this only works for well behaved elements in `X`, usuall smooth and/or integrable -/
  class ApproxSpace {N : Type} (Z : N → Type) (X : Type) where
    filter : Filter N
    canBeApproximated : X → Prop
    approx :
      ∃ (interpolate : {n : N} → Z n → X) (sample : (n : N) → X → Z n),
      (∀ n, sample n ∘ interpolate = id)
      ∧
      (∀ n (xₙ : Z n), canBeApproximated (interpolate xₙ))
      ∧
      (∀ x : X, canBeApproximated x →
                lim filter (λ n => interpolate (sample n x)) = x)

  /- Sample -/
  class ToApproxSpace {N : Type} (Xₙ : N → Type) (X : Type) where
    toApproxSpace (n : N) : X → Xₙ n

  /- Interpolate -/
  class FromApproxSpace {N : Type} (Xₙ : N → Type) (X : Type) where
    fromApproxSpace {n} : Xₙ n → X

  instance [s : ApproxSpace Xₙ X] (α : Type) : ApproxSpace (λ n => α → Xₙ n) (α → X) := sorry
  instance [s : ApproxSpace Xₙ X] (α : Type) : ApproxSpace (λ n => Xₙ n → α) (X → α) := sorry
  instance [s : ApproxSpace Xₙ X] : ApproxSpace (λ n => Xₙ n → Xₙ n) (X → X) := sorry

  instance : ApproxSpace Uₙ ((ℝ^(2:ℕ)) → ℝ) := sorry

  -- impl asdf (x : ℝ) : X := ∇ Math.sin
  -- by
  --   asdf

  -- approx asdf (x : ℝ) : X := ∇ Math.sin
  -- by
  --   asdf

  structure ApproxSol (Z : N → Type) {X : Type} (spec : X → Prop) [s : ApproxSpace Z X] where
    val : (n : N) → Z n
    -- proof : spec (lim s.filter (λ n => s.approx (val n)))

  class Foo (X : Type) where
    foo : X → X
    bar : X → X

  def real_noncomp (x : ℝ) : ℝ := x

  instance : Foo ℝ where
    foo x := 2 * x
    bar x := panic! "Implement me!"

  #eval (Foo.foo (2.0 : ℝ))
  #eval (Foo.bar (2.0 : ℝ))

  -- syntax declModifiers "def " declId bracketedBinder* (":" term)? ":=" term " rewrite " convSeq : command

  -- def adsf : ApproxT (λ n => ℝ → Uₙ n → Uₙ n) (ode_solve (waveEquation)) := sorry

  def ode_stepper (Xₙ : Nat → Type) (f : X → X) [ApproxSpace Xₙ X]
  : ApproxSol (λ n => ℝ → Xₙ n → Xₙ n)
    (λ (ϕ : ℝ → X → X) =>
      ∀ x₀,
      let x := λ t => ϕ t x₀
      (∀ t, ⅆ x t = f (x t)) ∧ (x 0 = x₀)) := sorry

  -- def hihi : Impl (ode_solve (waveEquation 2 1.0)) :=
  -- by
  --   unfold waveEquation

    -- finish_impl

  -- theorem manifoldGalerkin (p : (n : ℕ) → U n → X) [∀ n, IsSmooth (p n)] (n : ℕ)
  --   : Solution (λ (uₙ : ℝ → U n) =>
  --       ∀ v t, ⟪ⅆ (p n ∘ uₙ) t, ∂ (p n) (uₙ t) v⟫ = ⟪f (p n (uₙ t)), ∂ (p n) (uₙ t) v⟫)
  --     →
  --     ApproxSolution λ (x : ℝ → X) => ∀ t, ⅆ x t = f (x t)
  --   := sorry

  -- theorem manifoldGalerkinPaticles {U} [Vec U] (p : U → X) [IsSmooth p] (n : ℕ)
  --   : let Uₙ := Fin n → U
  --     let pₙ := λ (uₙ : Uₙ n) => ∑ i, uₙ i
  --     Solution (λ (uₙ : ℝ → Uₙ) => ∀ i t, )
  --     True
  --   := sorry

end AbstractManifolGalerkin


import tactic.linarith
import analysis.topology.topological_structures
import ring_theory.subring
import power_bounded
import Huber_ring

-- Scholze : "Recall that a topological ring R is Tate if it contains an
-- open and bounded subring R₀ ⊂ R and a topologically nilpotent unit ϖ ∈ R; such elements are
-- called pseudo-uniformizers."

universe u

variables {R : Type u} [comm_ring R] [topological_space R] [topological_ring R]

open filter function

lemma half_nhds {s : set R} (hs : s ∈ (nhds (0 : R)).sets) :
  ∃ V ∈ (nhds (0 : R)).sets, ∀ v w ∈ V, v * w ∈ s :=
begin
  have : ((λa:R×R, a.1 * a.2) ⁻¹' s) ∈ (nhds ((0, 0) : R × R)).sets :=
    tendsto_mul' (by simpa using hs),
  rw nhds_prod_eq at this,
  rcases filter.mem_prod_iff.1 this with ⟨V₁, H₁, V₂, H₂, H⟩,
  exact ⟨V₁ ∩ V₂, filter.inter_mem_sets H₁ H₂, assume v w ⟨hv, _⟩ ⟨_, hw⟩, @H (v, w) ⟨hv, hw⟩⟩
end

def topologically_nilpotent (r : R) : Prop :=
∀ U ∈ (nhds (0 :R)).sets, ∃ N : ℕ, ∀ n : ℕ, n > N → r^n ∈ U

def is_pseudo_uniformizer (ϖ : units R) : Prop := topologically_nilpotent ϖ.val

variable (R)
def pseudo_uniformizer := { ϖ : units R // topologically_nilpotent ϖ.val}

instance pseudo_unif.power_bounded: has_coe (pseudo_uniformizer R) (power_bounded_subring R) :=
⟨λ ⟨ϖ, h⟩, ⟨ϖ, begin
  intros U U_nhds,
  rcases half_nhds U_nhds with ⟨U', ⟨U'_nhds, U'_prod⟩⟩,
  rcases h U' U'_nhds with ⟨N, H⟩,
  let V : set R := (λ u, u*ϖ^(N+1)) '' U',
  have V_nhds : V ∈ (nhds (0 : R)).sets,
  { dsimp [V],
    have inv : left_inverse (λ (u : R), u * (↑ϖ⁻¹)^((N + 1))) (λ (u : R), u * ϖ^(N + 1)) ∧
        right_inverse (λ (u : R), u * (↑ϖ⁻¹)^(N + 1)) (λ (u : R), u * ϖ^(N + 1)),
    by split ; intro ; simp [mul_assoc, (mul_pow _ _ _).symm],
    rw set.image_eq_preimage_of_inverse inv.1 inv.2,
    have : tendsto (λ (u : R), u * ↑ϖ⁻¹ ^ (N + 1)) (nhds 0) (nhds 0),
    { conv {congr, skip, skip, rw ←(zero_mul (↑ϖ⁻¹ ^ (N + 1) : R))},
        exact tendsto_mul tendsto_id tendsto_const_nhds },
    exact this U'_nhds },
  use [V, V_nhds],
  rintros v ⟨u, u_in, uv⟩ b ⟨n, h'⟩,
  rw [← h', ←uv, mul_assoc, ← pow_add],
  apply U'_prod _ _ u_in (H _ _),
  clear uv h', -- otherwise linarith gets confused
  linarith
end⟩⟩

class Tate_ring (R : Type*) extends comm_ring R, topological_space R, topological_ring R :=
(R₀ : set R)
(R₀_is_open : is_open R₀)
(R₀_is_bounded : is_bounded R₀)
(R₀_is_subring : is_subring R₀)
(ϖ : units R)
(ϖ_is_pseudo_uniformizer : is_pseudo_uniformizer ϖ)

instance tate_ring.to_huber_ring (R : Type*) [Tate_ring R] : Huber_ring R :=
sorry


import Mathlib
import Mathlib.Algebra.Group.Defs
import PremiseSelection.Tactic
import PremiseSelection.Widget

open PremiseSelection

variable {M : Type u} [RightCancelMonoid M] {a b : M}
variable [CommSemigroup G]

example : b = a * b ↔ a = 1 := by {
  rw [eq_comm]
  suggest_premises
  sorry
}

example : ∀ a b c : G, a * (b * c) = b * (a * c) := by
{
  intros a b c
  suggest_premises
  sorry
}

example (a : Nat) : 0 + a = a := by {
  suggest_premises
  sorry
}


/-
Copyright (c) 2019 Seul Baek. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Seul Baek
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.localized
import Mathlib.PostPort

namespace Mathlib

/-
Miscellaneous.
-/

namespace omega

theorem fun_mono_2 {α : Type} {β : Type} {γ : Type} {p : α → β → γ} {a1 : α} {a2 : α} {b1 : β} {b2 : β} : a1 = a2 → b1 = b2 → p a1 b1 = p a2 b2 :=
  fun (h1 : a1 = a2) (h2 : b1 = b2) =>
    eq.mpr (id (Eq._oldrec (Eq.refl (p a1 b1 = p a2 b2)) h1))
      (eq.mpr (id (Eq._oldrec (Eq.refl (p a2 b1 = p a2 b2)) h2)) (Eq.refl (p a2 b2)))

theorem pred_mono_2 {α : Type} {β : Type} {p : α → β → Prop} {a1 : α} {a2 : α} {b1 : β} {b2 : β} : a1 = a2 → b1 = b2 → (p a1 b1 ↔ p a2 b2) :=
  fun (h1 : a1 = a2) (h2 : b1 = b2) =>
    eq.mpr (id (Eq._oldrec (Eq.refl (p a1 b1 ↔ p a2 b2)) h1))
      (eq.mpr (id (Eq._oldrec (Eq.refl (p a2 b1 ↔ p a2 b2)) h2)) (iff.refl (p a2 b2)))

theorem pred_mono_2' {c : Prop → Prop → Prop} {a1 : Prop} {a2 : Prop} {b1 : Prop} {b2 : Prop} : (a1 ↔ a2) → (b1 ↔ b2) → (c a1 b1 ↔ c a2 b2) :=
  fun (h1 : a1 ↔ a2) (h2 : b1 ↔ b2) =>
    eq.mpr (id (Eq._oldrec (Eq.refl (c a1 b1 ↔ c a2 b2)) (propext h1)))
      (eq.mpr (id (Eq._oldrec (Eq.refl (c a2 b1 ↔ c a2 b2)) (propext h2))) (iff.refl (c a2 b2)))

/-- Update variable assignment for a specific variable
    and leave everything else unchanged -/
def update {α : Type} (m : ℕ) (a : α) (v : ℕ → α) : ℕ → α :=
  sorry

theorem update_eq {α : Type} (m : ℕ) (a : α) (v : ℕ → α) : update m a v m = a := sorry

theorem update_eq_of_ne {α : Type} {m : ℕ} {a : α} {v : ℕ → α} (k : ℕ) : k ≠ m → update m a v k = v k := sorry

/-- Assign a new value to the zeroth variable, and push all
    other assignments up by 1 -/
def update_zero {α : Type} (a : α) (v : ℕ → α) : ℕ → α :=
  sorry


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Mario Carneiro
-/
import topology.metric_space.basic
import topology.algebra.uniform_group
import topology.algebra.ring
import topology.algebra.star
import ring_theory.subring.basic
import group_theory.archimedean
import algebra.periodic
import order.filter.archimedean
import topology.instances.int

/-!
# Topological properties of ℝ
-/

noncomputable theory
open classical filter int metric set topological_space
open_locale classical topological_space filter uniformity interval

universes u v w
variables {α : Type u} {β : Type v} {γ : Type w}

instance : noncompact_space ℝ := int.closed_embedding_coe_real.noncompact_space

theorem real.uniform_continuous_add : uniform_continuous (λp : ℝ × ℝ, p.1 + p.2) :=
metric.uniform_continuous_iff.2 $ λ ε ε0,
let ⟨δ, δ0, Hδ⟩ := rat_add_continuous_lemma abs ε0 in
⟨δ, δ0, λ a b h, let ⟨h₁, h₂⟩ := max_lt_iff.1 h in Hδ h₁ h₂⟩

theorem real.uniform_continuous_neg : uniform_continuous (@has_neg.neg ℝ _) :=
metric.uniform_continuous_iff.2 $ λ ε ε0, ⟨_, ε0, λ a b h,
  by rw dist_comm at h; simpa [real.dist_eq] using h⟩

instance : has_continuous_star ℝ := ⟨continuous_id⟩

instance : uniform_add_group ℝ :=
uniform_add_group.mk' real.uniform_continuous_add real.uniform_continuous_neg

 -- short-circuit type class inference
instance : topological_add_group ℝ := by apply_instance

instance : proper_space ℝ :=
{ is_compact_closed_ball := λx r, by { rw real.closed_ball_eq_Icc, apply is_compact_Icc } }

instance : second_countable_topology ℝ := second_countable_of_proper

lemma real.is_topological_basis_Ioo_rat :
  @is_topological_basis ℝ _ (⋃(a b : ℚ) (h : a < b), {Ioo a b}) :=
is_topological_basis_of_open_of_nhds
  (by simp [is_open_Ioo] {contextual:=tt})
  (assume a v hav hv,
    let ⟨l, u, ⟨hl, hu⟩, h⟩ := mem_nhds_iff_exists_Ioo_subset.mp (is_open.mem_nhds hv hav),
        ⟨q, hlq, hqa⟩ := exists_rat_btwn hl,
        ⟨p, hap, hpu⟩ := exists_rat_btwn hu in
    ⟨Ioo q p,
      by { simp only [mem_Union], exact ⟨q, p, rat.cast_lt.1 $ hqa.trans hap, rfl⟩ },
      ⟨hqa, hap⟩, assume a' ⟨hqa', ha'p⟩, h ⟨hlq.trans hqa', ha'p.trans hpu⟩⟩)

@[simp] lemma real.cocompact_eq : cocompact ℝ = at_bot ⊔ at_top :=
by simp only [← comap_dist_right_at_top_eq_cocompact (0 : ℝ), real.dist_eq, sub_zero,
  comap_abs_at_top]

/- TODO(Mario): Prove that these are uniform isomorphisms instead of uniform embeddings
lemma uniform_embedding_add_rat {r : ℚ} : uniform_embedding (λp:ℚ, p + r) :=
_

lemma uniform_embedding_mul_rat {q : ℚ} (hq : q ≠ 0) : uniform_embedding ((*) q) :=
_ -/

lemma real.mem_closure_iff {s : set ℝ} {x : ℝ} :
  x ∈ closure s ↔ ∀ ε > 0, ∃ y ∈ s, |y - x| < ε :=
by simp [mem_closure_iff_nhds_basis nhds_basis_ball, real.dist_eq]

lemma real.uniform_continuous_inv (s : set ℝ) {r : ℝ} (r0 : 0 < r) (H : ∀ x ∈ s, r ≤ |x|) :
  uniform_continuous (λp:s, p.1⁻¹) :=
metric.uniform_continuous_iff.2 $ λ ε ε0,
let ⟨δ, δ0, Hδ⟩ := rat_inv_continuous_lemma abs ε0 r0 in
⟨δ, δ0, λ a b h, Hδ (H _ a.2) (H _ b.2) h⟩

lemma real.uniform_continuous_abs : uniform_continuous (abs : ℝ → ℝ) :=
metric.uniform_continuous_iff.2 $ λ ε ε0,
  ⟨ε, ε0, λ a b, lt_of_le_of_lt (abs_abs_sub_abs_le_abs_sub _ _)⟩

lemma real.tendsto_inv {r : ℝ} (r0 : r ≠ 0) : tendsto (λq, q⁻¹) (𝓝 r) (𝓝 r⁻¹) :=
by rw ← abs_pos at r0; exact
tendsto_of_uniform_continuous_subtype
  (real.uniform_continuous_inv {x | |r| / 2 < |x|} (half_pos r0) (λ x h, le_of_lt h))
  (is_open.mem_nhds ((is_open_lt' (|r| / 2)).preimage continuous_abs) (half_lt_self r0))

lemma real.continuous_inv : continuous (λa:{r:ℝ // r ≠ 0}, a.val⁻¹) :=
continuous_iff_continuous_at.mpr $ assume ⟨r, hr⟩,
  tendsto.comp (real.tendsto_inv hr) (continuous_iff_continuous_at.mp continuous_subtype_val _)

lemma real.continuous.inv [topological_space α] {f : α → ℝ} (h : ∀a, f a ≠ 0) (hf : continuous f) :
  continuous (λa, (f a)⁻¹) :=
show continuous ((has_inv.inv ∘ @subtype.val ℝ (λr, r ≠ 0)) ∘ λa, ⟨f a, h a⟩),
  from real.continuous_inv.comp (continuous_subtype_mk _ hf)

lemma real.uniform_continuous_mul_const {x : ℝ} : uniform_continuous ((*) x) :=
metric.uniform_continuous_iff.2 $ λ ε ε0, begin
  cases exists_gt (|x|) with y xy,
  have y0 := lt_of_le_of_lt (abs_nonneg _) xy,
  refine ⟨_, div_pos ε0 y0, λ a b h, _⟩,
  rw [real.dist_eq, ← mul_sub, abs_mul, ← mul_div_cancel' ε (ne_of_gt y0)],
  exact mul_lt_mul' (le_of_lt xy) h (abs_nonneg _) y0
end

lemma real.uniform_continuous_mul (s : set (ℝ × ℝ))
  {r₁ r₂ : ℝ} (H : ∀ x ∈ s, |(x : ℝ × ℝ).1| < r₁ ∧ |x.2| < r₂) :
  uniform_continuous (λp:s, p.1.1 * p.1.2) :=
metric.uniform_continuous_iff.2 $ λ ε ε0,
let ⟨δ, δ0, Hδ⟩ := rat_mul_continuous_lemma abs ε0 in
⟨δ, δ0, λ a b h,
  let ⟨h₁, h₂⟩ := max_lt_iff.1 h in Hδ (H _ a.2).1 (H _ b.2).2 h₁ h₂⟩

protected lemma real.continuous_mul : continuous (λp : ℝ × ℝ, p.1 * p.2) :=
continuous_iff_continuous_at.2 $ λ ⟨a₁, a₂⟩,
tendsto_of_uniform_continuous_subtype
  (real.uniform_continuous_mul
    ({x | |x| < |a₁| + 1} ×ˢ {x | |x| < |a₂| + 1})
    (λ x, id))
  (is_open.mem_nhds
    (((is_open_gt' (|a₁| + 1)).preimage continuous_abs).prod
      ((is_open_gt' (|a₂| + 1)).preimage continuous_abs ))
    ⟨lt_add_one (|a₁|), lt_add_one (|a₂|)⟩)

instance : topological_ring ℝ :=
{ continuous_mul := real.continuous_mul, ..real.topological_add_group }

instance : complete_space ℝ :=
begin
  apply complete_of_cauchy_seq_tendsto,
  intros u hu,
  let c : cau_seq ℝ abs := ⟨u, metric.cauchy_seq_iff'.1 hu⟩,
  refine ⟨c.lim, λ s h, _⟩,
  rcases metric.mem_nhds_iff.1 h with ⟨ε, ε0, hε⟩,
  have := c.equiv_lim ε ε0,
  simp only [mem_map, mem_at_top_sets, mem_set_of_eq],
  refine this.imp (λ N hN n hn, hε (hN n hn))
end

lemma real.totally_bounded_ball (x ε : ℝ) : totally_bounded (ball x ε) :=
by rw real.ball_eq_Ioo; apply totally_bounded_Ioo

section

lemma closure_of_rat_image_lt {q : ℚ} : closure ((coe:ℚ → ℝ) '' {x | q < x}) = {r | ↑q ≤ r} :=
subset.antisymm
  ((is_closed_ge' _).closure_subset_iff.2
    (image_subset_iff.2 $ λ p h, le_of_lt $ (@rat.cast_lt ℝ _ _ _).2 h)) $
λ x hx, mem_closure_iff_nhds.2 $ λ t ht,
let ⟨ε, ε0, hε⟩ := metric.mem_nhds_iff.1 ht in
let ⟨p, h₁, h₂⟩ := exists_rat_btwn ((lt_add_iff_pos_right x).2 ε0) in
⟨_, hε (show abs _ < _,
    by rwa [abs_of_nonneg (le_of_lt $ sub_pos.2 h₁), sub_lt_iff_lt_add']),
  p, rat.cast_lt.1 (@lt_of_le_of_lt ℝ _ _ _ _ hx h₁), rfl⟩

/- TODO(Mario): Put these back only if needed later
lemma closure_of_rat_image_le_eq {q : ℚ} : closure ((coe:ℚ → ℝ) '' {x | q ≤ x}) = {r | ↑q ≤ r} :=
_

lemma closure_of_rat_image_le_le_eq {a b : ℚ} (hab : a ≤ b) :
  closure (of_rat '' {q:ℚ | a ≤ q ∧ q ≤ b}) = {r:ℝ | of_rat a ≤ r ∧ r ≤ of_rat b} :=
_-/

lemma real.bounded_iff_bdd_below_bdd_above {s : set ℝ} : bounded s ↔ bdd_below s ∧ bdd_above s :=
⟨begin
  assume bdd,
  rcases (bounded_iff_subset_ball 0).1 bdd with ⟨r, hr⟩, -- hr : s ⊆ closed_ball 0 r
  rw real.closed_ball_eq_Icc at hr, -- hr : s ⊆ Icc (0 - r) (0 + r)
  exact ⟨bdd_below_Icc.mono hr, bdd_above_Icc.mono hr⟩
end,
λ h, bounded_of_bdd_above_of_bdd_below h.2 h.1⟩

lemma real.subset_Icc_Inf_Sup_of_bounded {s : set ℝ} (h : bounded s) :
  s ⊆ Icc (Inf s) (Sup s) :=
subset_Icc_cInf_cSup (real.bounded_iff_bdd_below_bdd_above.1 h).1
  (real.bounded_iff_bdd_below_bdd_above.1 h).2

end

section periodic

namespace function

lemma periodic.compact_of_continuous' [topological_space α] {f : ℝ → α} {c : ℝ}
  (hp : periodic f c) (hc : 0 < c) (hf : continuous f) :
  is_compact (range f) :=
begin
  convert is_compact_Icc.image hf,
  ext x,
  refine ⟨_, mem_range_of_mem_image f (Icc 0 c)⟩,
  rintros ⟨y, h1⟩,
  obtain ⟨z, hz, h2⟩ := hp.exists_mem_Ico₀ hc y,
  exact ⟨z, mem_Icc_of_Ico hz, h2.symm.trans h1⟩,
end

/-- A continuous, periodic function has compact range. -/
lemma periodic.compact_of_continuous [topological_space α] {f : ℝ → α} {c : ℝ}
  (hp : periodic f c) (hc : c ≠ 0) (hf : continuous f) :
  is_compact (range f) :=
begin
  cases lt_or_gt_of_ne hc with hneg hpos,
  exacts [hp.neg.compact_of_continuous' (neg_pos.mpr hneg) hf, hp.compact_of_continuous' hpos hf],
end

/-- A continuous, periodic function is bounded. -/
lemma periodic.bounded_of_continuous [pseudo_metric_space α] {f : ℝ → α} {c : ℝ}
  (hp : periodic f c) (hc : c ≠ 0) (hf : continuous f) :
  bounded (range f) :=
(hp.compact_of_continuous hc hf).bounded

end function

end periodic

section subgroups

/-- Given a nontrivial subgroup `G ⊆ ℝ`, if `G ∩ ℝ_{>0}` has no minimum then `G` is dense. -/
lemma real.subgroup_dense_of_no_min {G : add_subgroup ℝ} {g₀ : ℝ} (g₀_in : g₀ ∈ G) (g₀_ne : g₀ ≠ 0)
  (H' : ¬ ∃ a : ℝ, is_least {g : ℝ | g ∈ G ∧ 0 < g} a) :
  dense (G : set ℝ) :=
begin
  let G_pos := {g : ℝ | g ∈ G ∧ 0 < g},
  push_neg at H',
  intros x,
  suffices : ∀ ε > (0 : ℝ), ∃ g ∈ G, |x - g| < ε,
    by simpa only [real.mem_closure_iff, abs_sub_comm],
  intros ε ε_pos,
  obtain ⟨g₁, g₁_in, g₁_pos⟩ : ∃ g₁ : ℝ, g₁ ∈ G ∧ 0 < g₁,
  { cases lt_or_gt_of_ne g₀_ne with Hg₀ Hg₀,
    { exact ⟨-g₀, G.neg_mem g₀_in, neg_pos.mpr Hg₀⟩ },
    { exact ⟨g₀, g₀_in, Hg₀⟩ } },
  obtain ⟨a, ha⟩ : ∃ a, is_glb G_pos a :=
    ⟨Inf G_pos, is_glb_cInf ⟨g₁, g₁_in, g₁_pos⟩ ⟨0, λ _ hx, le_of_lt hx.2⟩⟩,
  have a_notin : a ∉ G_pos,
  { intros H,
    exact H' a ⟨H, ha.1⟩ },
  obtain ⟨g₂, g₂_in, g₂_pos, g₂_lt⟩ : ∃ g₂ : ℝ, g₂ ∈ G ∧ 0 < g₂ ∧ g₂ < ε,
  { obtain ⟨b, hb, hb', hb''⟩ := ha.exists_between_self_add' a_notin ε_pos,
    obtain ⟨c, hc, hc', hc''⟩ := ha.exists_between_self_add' a_notin (sub_pos.2 hb'),
    refine ⟨b - c, G.sub_mem hb.1 hc.1, _, _⟩ ;
    linarith },
  refine ⟨floor (x/g₂) * g₂, _, _⟩,
  { exact add_subgroup.int_mul_mem _ g₂_in },
  { rw abs_of_nonneg (sub_floor_div_mul_nonneg x g₂_pos),
    linarith [sub_floor_div_mul_lt x g₂_pos] }
end

/-- Subgroups of `ℝ` are either dense or cyclic. See `real.subgroup_dense_of_no_min` and
`subgroup_cyclic_of_min` for more precise statements. -/
lemma real.subgroup_dense_or_cyclic (G : add_subgroup ℝ) :
  dense (G : set ℝ) ∨ ∃ a : ℝ, G = add_subgroup.closure {a} :=
begin
  cases add_subgroup.bot_or_exists_ne_zero G with H H,
  { right,
    use 0,
    rw [H, add_subgroup.closure_singleton_zero] },
  { let G_pos := {g : ℝ | g ∈ G ∧ 0 < g},
    by_cases H' : ∃ a, is_least G_pos a,
    { right,
      rcases H' with ⟨a, ha⟩,
      exact ⟨a, add_subgroup.cyclic_of_min ha⟩ },
    { left,
      rcases H with ⟨g₀, g₀_in, g₀_ne⟩,
      exact real.subgroup_dense_of_no_min g₀_in g₀_ne H' } }
end

end subgroups


import tactic.ring
import group_theory.group_action
import algebra.module
import algebra.pi_instances
import linear_algebra.subtype_module
import .holomorphic_functions
import .upper_half_space

universes u v

open complex

local notation `ℍ` := upper_half_space

def is_Petersson_weight_ (k : ℕ) := { f : ℍ → ℂ | ∀ M : SL2Z, ∀ z : ℍ, f (SL2Z_H M z) = (M.c*z + M.d)^k * f z }

def is_bound_at_infinity := { f : ℍ → ℂ | ∃ (M A : ℝ), ∀ z : ℍ, im z ≥ A → abs (f z) ≤ M }

def is_zero_at_infinity := { f : ℍ → ℂ | ∀ ε : ℝ, ε > 0 → ∃ A : ℝ, ∀ z : ℍ, im z ≥ A → abs (f z) ≤ ε }

instance (k : ℕ) : is_submodule (is_Petersson_weight_ k) :=
{ zero_ := λ M z, by simp,
  add_  := λ f g hf hg M z, begin
    suffices : f (SL2Z_H M z) + g (SL2Z_H M z) = (↑(M.c) * ↑z + ↑(M.d)) ^ k * (f z + g z),
      by simp at *; assumption,
    rw [hf, hg],
    ring
  end,
  smul  := λ c f hyp M z, begin
    suffices : c * f (SL2Z_H M z) = (↑(M.c) * ↑z + ↑(M.d)) ^ k * (c * f z),
      by simp at *; assumption,
    rw hyp M z,
    ring
  end }

instance : is_submodule is_bound_at_infinity :=
{ zero_ := ⟨0, ⟨0, λ z h, by simp⟩⟩,
  add_  := λ f g hf hg, begin
    cases hf with Mf hMf,
    cases hg with Mg hMg,
    cases hMf with Af hAMf,
    cases hMg with Ag hAMg,
    existsi (Mf + Mg),
    existsi (max Af Ag),
    intros z hz,
    simp,
    apply le_trans (complex.abs_add _ _),
    apply add_le_add,
    { refine hAMf z _,
      exact le_trans (le_max_left _ _) hz },
    { refine hAMg z _,
      exact le_trans (le_max_right _ _) hz }
  end,
  smul  := λ c f hyp, begin
    cases hyp with M hM,
    cases hM with A hAM,
    existsi (abs c * M),
    existsi A,
    intros z hz,
    simp,
    apply mul_le_mul_of_nonneg_left (hAM z hz) (complex.abs_nonneg c)
  end }

instance : is_submodule is_zero_at_infinity :=
{ zero_ := λ ε hε, ⟨1, λ z hz, by simp; exact le_of_lt hε⟩,
  add_  := λ f g hf hg ε hε, begin
    cases hf (ε/2) (half_pos hε) with Af hAf,
    cases hg (ε/2) (half_pos hε) with Ag hAg,
    existsi (max Af Ag),
    intros z hz,
    simp,
    apply le_trans (complex.abs_add _ _),
    rw show ε = ε / 2 + ε / 2, by simp,
    apply add_le_add,
    { refine hAf z (le_trans (le_max_left _ _) hz) },
    { refine hAg z (le_trans (le_max_right _ _) hz) }
  end,
  smul  := λ c f hyp ε hε, begin
    by_cases hc : (c = 0),
    { existsi (0 : ℝ ), intros, simp [hc], exact le_of_lt hε },
    { cases hyp (ε / abs c) (lt_div_of_mul_lt (by simp [hc]) (by simp; exact hε)) with A hA,
      existsi A,
      intros z hz,
      simp,
      rw show ε = abs c * (ε / abs c),
      begin
        rw [mul_comm],
        refine (div_mul_cancel _ _).symm,
        simp [hc]
      end,
      apply mul_le_mul_of_nonneg_left (hA z hz) (complex.abs_nonneg c), }
  end }

lemma is_bound_at_infinity_of_is_zero_at_infinity {f : ℍ → ℂ} (h : is_zero_at_infinity f) :
is_bound_at_infinity f := ⟨1, h 1 zero_lt_one⟩

-- structure is_modular_form (k : ℕ) (f : ℍ → ℂ) : Prop :=
-- (hol      : is_holomorphic f)
-- (transf   : ∀ M : SL2Z, ∀ z : ℍ, f (SL2Z_H M z) = (M.c*z + M.d)^k * f z)
-- (infinity : ∃ (M A : ℝ), ∀ z : ℍ, im z ≥ A → abs (f z) ≤ M)

def is_modular_form (k : ℕ) := {f : ℍ → ℂ | is_holomorphic f} ∩ (is_Petersson_weight_ k) ∩ is_bound_at_infinity

def is_cusp_form (k : ℕ) := {f : ℍ → ℂ | is_holomorphic f} ∩ (is_Petersson_weight_ k) ∩ is_zero_at_infinity

lemma is_modular_form_of_is_cusp_form {k : ℕ} (f : ℍ → ℂ) (h : is_cusp_form k f) : is_modular_form k f :=
⟨h.1, is_bound_at_infinity_of_is_zero_at_infinity h.2⟩

instance (k : ℕ) : is_submodule (is_modular_form k) := is_submodule.inter_submodule

instance (k : ℕ) : is_submodule (is_cusp_form k) := is_submodule.inter_submodule

/- def Hecke_operator {k : ℕ} (m : ℤ) : modular_forms k → modular_forms k :=
λ f,
(m^k.pred : ℂ) • (sorry : modular_forms k) -- why is this • failing?
 -/


universe u v

structure InjectiveFunction (α : Type u) (β : Type v) where
  fn  : α → β
  inj : ∀ a b, fn a = fn b → a = b

def add1 : InjectiveFunction Nat Nat where
  fn a      := a + 1
  inj a b h := by injection h; assumption

instance : CoeFun (InjectiveFunction α β) (fun _ => α → β) where
  coe s := s.fn

#eval add1 10

def mapAdd1 (xs : List Nat) : List Nat :=
  xs.map add1

#eval mapAdd1 [1, 2]

def foo : InjectiveFunction Bool (Nat → Nat) where
  fn
   | true,  a => a + 1
   | false, a => a
  inj a b h := by
    cases a
    cases b; rfl; injection (congrFun h 0)
    cases b; injection (congrFun h 0); rfl

theorem ex1 (x : Nat) : foo true x = x + 1 :=
  rfl

theorem ex2 (x : Nat) : foo false x = x :=
  rfl

#eval foo true 10
#eval foo false 20

#eval [1, 2, 3].map (foo true)


/-
Copyright (c) 2021 Yaël Dillies, Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies, Bhavik Mehta, Maxwell Thum
-/
import analysis.convex.hull
import linear_algebra.affine_space.independent
import combinatorial_surface.abstract_simplicial_complex.finite
import data.real.basic

/-!
# DISCLAIMER
**THIS IS MY COPY OF MATHLIB'S `analysis.convex.simplicial_complex.basic`!!!**
These edits have nothing to do with the original authors.
I'm not sure whether this will ultimately go in mathlib, so I'm changing a lot willy-nilly.

# Simplicial complexes

In this file, we define simplicial complexes in `𝕜`-modules. A simplicial complex is a collection
of simplices closed by inclusion (of vertices) and intersection (of underlying sets).

We model them by a downward-closed set of affine independent finite sets whose convex hulls "glue
nicely", each finite set and its convex hull corresponding respectively to the vertices and the
underlying set of a simplex.

## Main declarations

* `simplicial_complex 𝕜 E`: A simplicial complex in the `𝕜`-module `E`.
* `simplicial_complex.vertices`: The zero dimensional faces of a simplicial complex.
* `simplicial_complex.facets`: The maximal faces of a simplicial complex.

## Notation

`s ∈ K` means that `s` is a face of `K`.

`K ≤ L` means that the faces of `K` are faces of `L`.

## Implementation notes

"glue nicely" usually means that the intersection of two faces (as sets in the ambient space) is a
face. Given that we store the vertices, not the faces, this would be a bit awkward to spell.
Instead, `simplicial_complex.inter_subset_convex_hull` is an equivalent condition which works on the
vertices.

## TODO

Simplicial complexes can be generalized to affine spaces once `convex_hull` has been ported.
-/

open finset set

variables (𝕜 E : Type*) [decidable_eq E] {ι : Type*} [ordered_ring 𝕜] [add_comm_group E] [module 𝕜 E]
/- I added `decidable_eq E` to `asc` for some reason to do with set theory
iirc. Apparently lean can't synthesize that from `add_comm_group E` alone
though... If the authors of this didn't add it then do I want to? -/
namespace geometry

/-- A simplicial complex in a `𝕜`-module is a collection of simplices which glue nicely together.
Note that the textbook meaning of "glue nicely" is given in
`geometry.simplicial_complex.disjoint_or_exists_inter_eq_convex_hull`. It is mostly useless, as
`geometry.simplicial_complex.convex_hull_inter_convex_hull` is enough for all purposes. -/
-- TODO: update to new binder order? not sure what binder order is correct for `down_closed`.
@[ext] structure simplicial_complex extends abstract_simplicial_complex E :=
--(faces : set (finset E))
--(not_empty_mem : ∅ ∉ faces)
(indep : ∀ {s}, s ∈ faces → affine_independent 𝕜 (coe : (s : set E) → E))
--(down_closed : ∀ {s t}, s ∈ faces → t ⊆ s → t ≠ ∅ → t ∈ faces)
(inter_subset_convex_hull : ∀ {s t}, s ∈ faces → t ∈ faces →
  convex_hull 𝕜 ↑s ∩ convex_hull 𝕜 ↑t ⊆ convex_hull 𝕜 (s ∩ t : set E))

namespace simplicial_complex
variables {𝕜 E} {K : simplicial_complex 𝕜 E} {s t : finset E} {x : E}

/-
/-- A `finset` belongs to a `simplicial_complex` if it's a face of it. -/
instance : has_mem (finset E) (simplicial_complex 𝕜 E) := ⟨λ s K, s ∈ K.faces⟩
-/

/-- The underlying space of a simplicial complex is the union of its faces. -/
def space (K : simplicial_complex 𝕜 E) : set E := ⋃ s ∈ K.faces, convex_hull 𝕜 (s : set E)

lemma mem_space_iff : x ∈ K.space ↔ ∃ s ∈ K.faces, x ∈ convex_hull 𝕜 (s : set E) := mem_Union₂

lemma convex_hull_subset_space (hs : s ∈ K.faces) : convex_hull 𝕜 ↑s ⊆ K.space :=
subset_bUnion_of_mem hs

protected lemma subset_space (hs : s ∈ K.faces) : (s : set E) ⊆ K.space :=
(subset_convex_hull 𝕜 _).trans $ convex_hull_subset_space hs

lemma convex_hull_inter_convex_hull (hs : s ∈ K.faces) (ht : t ∈ K.faces) :
  convex_hull 𝕜 ↑s ∩ convex_hull 𝕜 ↑t = convex_hull 𝕜 (s ∩ t : set E) :=
(K.inter_subset_convex_hull hs ht).antisymm $ subset_inter
  (convex_hull_mono $ set.inter_subset_left _ _) $ convex_hull_mono $ set.inter_subset_right _ _

/-- The conclusion is the usual meaning of "glue nicely" in textbooks. It turns out to be quite
unusable, as it's about faces as sets in space rather than simplices. Further,  additional structure
on `𝕜` means the only choice of `u` is `s ∩ t` (but it's hard to prove). -/
lemma disjoint_or_exists_inter_eq_convex_hull (hs : s ∈ K.faces) (ht : t ∈ K.faces) :
  disjoint (convex_hull 𝕜 (s : set E)) (convex_hull 𝕜 ↑t) ∨
  ∃ u ∈ K.faces, convex_hull 𝕜 (s : set E) ∩ convex_hull 𝕜 ↑t = convex_hull 𝕜 ↑u :=
begin
  classical,
  by_contra' h,
  refine h.2 (s ∩ t) (K.down_closed _ hs _ (inter_subset_left _ _) $ λ hst, h.1 $
    disjoint_iff_inf_le.mpr $ (K.inter_subset_convex_hull hs ht).trans _) _,
  { rw [←coe_inter, hst, coe_empty, convex_hull_empty],
    refl },
  { rw [coe_inter, convex_hull_inter_convex_hull hs ht] }
end

/-- Construct a simplicial complex by removing the empty face for you. -/
@[simps] def of_erase
  (faces : set (finset E))
  (indep : ∀ s ∈ faces, affine_independent 𝕜 (coe : (s : set E) → E))
  (down_closed : ∀ s ∈ faces, ∀ t ⊆ s, t ∈ faces)
  (inter_subset_convex_hull : ∀ s t ∈ faces,
    convex_hull 𝕜 ↑s ∩ convex_hull 𝕜 ↑t ⊆ convex_hull 𝕜 (s ∩ t : set E)) :
  simplicial_complex 𝕜 E :=
{ faces := faces \ {∅},
  not_empty_mem := λ h, h.2 (mem_singleton _),
  indep := λ s hs, indep _ hs.1,
  down_closed := λ s hs t hts ht, ⟨down_closed _ hs.1 _ hts, ht⟩,
  inter_subset_convex_hull := λ s t hs ht, inter_subset_convex_hull _ hs.1 _ ht.1 }

/-- Construct a simplicial complex as a subset of a given simplicial complex. -/
@[simps] def of_subcomplex (K : simplicial_complex 𝕜 E)
  (faces : set (finset E))
  (subset : faces ⊆ K.faces)
  (down_closed : ∀ s ∈ faces, ∀ t ⊆ s, t ∈ faces) :
  simplicial_complex 𝕜 E :=
{ faces := faces,
  not_empty_mem := λ h, K.not_empty_mem (subset h),
  indep := λ s hs, K.indep (subset hs),
  down_closed := λ s hs t hts _, down_closed _ hs _ hts,
  inter_subset_convex_hull := λ s t hs ht, K.inter_subset_convex_hull (subset hs) (subset ht) }

/-- Construct a simplicial complex from an abstract simplicial complex. This is usually
called *geometric realization*. This particular realization is from
`https://ncatlab.org/nlab/show/simplicial+complex#canonical_construction`. -/
def of_finasc {A : Type*} (K : finite_abstract_simplicial_complex A) : simplicial_complex ℝ (K.vertices → ℝ) :=
{ faces := { x : finset (K.vertices → ℝ) | ∃ a ∈ K.faces, ↑x = f '' a}, -- idk put an order on the set first
  not_empty_mem := sorry, --K.not_empty_mem,
  indep := sorry,
  down_closed := sorry, --K.down_closed,
  inter_subset_convex_hull := sorry }

/-! ### Vertices -/

/-
/-- The vertices of a simplicial complex are its zero dimensional faces. -/
def vertices (K : simplicial_complex 𝕜 E) : set E := {x | {x} ∈ K.faces}

lemma mem_vertices : x ∈ K.vertices ↔ {x} ∈ K.faces := abstract_simplicial_complex.mem_vertices

lemma vertices_eq : K.vertices = ⋃ k ∈ K.faces, (k : set E) := abstract_simplicial_complex.vertices_eq
-/

lemma vertices_subset_space : K.vertices ⊆ K.space :=
abstract_simplicial_complex.vertices_eq.subset.trans $ Union₂_mono $ λ x hx, subset_convex_hull 𝕜 x

lemma vertex_mem_convex_hull_iff (hx : x ∈ K.vertices) (hs : s ∈ K.faces) :
  x ∈ convex_hull 𝕜 (s : set E) ↔ x ∈ s :=
begin
  refine ⟨λ h, _, λ h, subset_convex_hull _ _ h⟩,
  classical,
  have h := K.inter_subset_convex_hull hx hs ⟨by simp, h⟩,
  by_contra H,
  rwa [←coe_inter, finset.disjoint_iff_inter_eq_empty.1
    (finset.disjoint_singleton_right.2 H).symm, coe_empty, convex_hull_empty] at h,
end

/-- A face is a subset of another one iff its vertices are.  -/
lemma face_subset_face_iff (hs : s ∈ K.faces) (ht : t ∈ K.faces) :
  convex_hull 𝕜 (s : set E) ⊆ convex_hull 𝕜 ↑t ↔ s ⊆ t :=
⟨λ h x hxs, (vertex_mem_convex_hull_iff (K.down_closed _ hs _ (finset.singleton_subset_iff.2 hxs) $
  singleton_ne_empty _) ht).1 (h (subset_convex_hull 𝕜 ↑s hxs)), convex_hull_mono⟩

/-! ### Facets -/

/-
/-- A facet of a simplicial complex is a maximal face. -/
def facets (K : simplicial_complex 𝕜 E) : set (finset E) :=
{s ∈ K.faces | ∀ ⦃t⦄, t ∈ K.faces → s ⊆ t → s = t}

lemma mem_facets : s ∈ K.facets ↔ s ∈ K.faces ∧ ∀ t ∈ K.faces, s ⊆ t → s = t := mem_sep_iff

lemma facets_subset : K.facets ⊆ K.faces := λ s hs, hs.1

lemma not_facet_iff_subface (hs : s ∈ K.faces) : (s ∉ K.facets ↔ ∃ t, t ∈ K.faces ∧ s ⊂ t) :=
begin
  refine ⟨λ (hs' : ¬ (_ ∧ _)), _, _⟩,
  { push_neg at hs',
    obtain ⟨t, ht⟩ := hs' hs,
    exact ⟨t, ht.1, ⟨ht.2.1, (λ hts, ht.2.2 (subset.antisymm ht.2.1 hts))⟩⟩ },
  { rintro ⟨t, ht⟩ ⟨hs, hs'⟩,
    have := hs' ht.1 ht.2.1,
    rw this at ht,
    exact ht.2.2 (subset.refl t) } -- `has_ssubset.ssubset.ne` would be handy here
end
-/

/-!
### The semilattice of simplicial complexes

`K ≤ L` means that `K.faces ⊆ L.faces`.
-/

variables (𝕜 E)

/-- The complex consisting of only the faces present in both of its arguments. -/
instance : has_inf (simplicial_complex 𝕜 E) :=
⟨λ K L, { faces := K.faces ∩ L.faces,
  not_empty_mem := λ h, K.not_empty_mem (set.inter_subset_left _ _ h),
  indep := λ s hs, K.indep hs.1,
  down_closed := λ s hs t hst ht, ⟨K.down_closed s hs.1 t hst ht, L.down_closed s hs.2 t hst ht⟩,
  inter_subset_convex_hull := λ s t hs ht, K.inter_subset_convex_hull hs.1 ht.1 }⟩

/- I don't think I care about this much for DDG so I'm just commenting it out for now
instance : semilattice_inf (K : simplicial_complex 𝕜 E) :=
{ inf := (⊓),
  inf_le_left := λ K L s hs, hs.1,
  inf_le_right := λ K L s hs, hs.2,
  le_inf := λ K L M hKL hKM s hs, ⟨hKL hs, hKM hs⟩,
  .. (partial_order.lift (abstract_simplicial_complex.faces ∘ to_abstract_simplicial_complex) $ λ x y, ext _ _) }
-/

instance : has_bot (simplicial_complex 𝕜 E) :=
⟨{ faces := ∅,
  not_empty_mem := set.not_mem_empty ∅,
  indep := λ s hs, (set.not_mem_empty _ hs).elim,
  down_closed := λ s hs _, (set.not_mem_empty _ hs).elim,
  inter_subset_convex_hull := λ s _ hs, (set.not_mem_empty _ hs).elim }⟩

/- Ditto
instance : order_bot (simplicial_complex 𝕜 E) :=
{ bot_le := λ K, set.empty_subset _, .. simplicial_complex.has_bot 𝕜 E }
-/

instance : inhabited (simplicial_complex 𝕜 E) := ⟨⊥⟩

variables {𝕜 E}

lemma faces_bot : (⊥ : simplicial_complex 𝕜 E).faces = ∅ := rfl

lemma space_bot : (⊥ : simplicial_complex 𝕜 E).space = ∅ := set.bUnion_empty _

lemma facets_bot : (⊥ : simplicial_complex 𝕜 E).facets = ∅ := eq_empty_of_subset_empty abstract_simplicial_complex.facets_subset

end simplicial_complex
end geometry


/-
Copyright (c) 2018 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Simon Hudon
-/
import control.functor.multivariate
import data.pfunctor.univariate.basic

/-!
# Multivariate polynomial functors.

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

Multivariate polynomial functors are used for defining M-types and W-types.
They map a type vector `α` to the type `Σ a : A, B a ⟹ α`, with `A : Type` and
`B : A → typevec n`. They interact well with Lean's inductive definitions because
they guarantee that occurrences of `α` are positive.
-/

universes u v
open_locale mvfunctor

/--
multivariate polynomial functors
-/
structure mvpfunctor (n : ℕ) :=
(A : Type.{u}) (B : A → typevec.{u} n)

namespace mvpfunctor
open mvfunctor (liftp liftr)

variables {n m : ℕ} (P : mvpfunctor.{u} n)

/-- Applying `P` to an object of `Type` -/
def obj (α : typevec.{u} n) : Type u := Σ a : P.A, P.B a ⟹ α

/-- Applying `P` to a morphism of `Type` -/
def map {α β : typevec n} (f : α ⟹ β) : P.obj α → P.obj β :=
λ ⟨a, g⟩, ⟨a, typevec.comp f g⟩

instance : inhabited (mvpfunctor n) :=
⟨⟨default, default⟩⟩

instance obj.inhabited {α : typevec n} [inhabited P.A] [Π i, inhabited (α i)] :
  inhabited (P.obj α) :=
⟨ ⟨default, λ _ _, default⟩ ⟩

instance : mvfunctor P.obj :=
⟨@mvpfunctor.map n P⟩

theorem map_eq {α β : typevec n} (g : α ⟹ β) (a : P.A) (f : P.B a ⟹ α) :
  @mvfunctor.map _ P.obj _ _ _ g ⟨a, f⟩ = ⟨a, g ⊚ f⟩ :=
rfl

theorem id_map {α : typevec n} : ∀ x : P.obj α, typevec.id <$$> x = x
| ⟨a, g⟩ := rfl

theorem comp_map {α β γ : typevec n} (f : α ⟹ β) (g : β ⟹ γ) :
  ∀ x : P.obj α, (g ⊚ f) <$$> x = g <$$> (f <$$> x)
| ⟨a, h⟩ := rfl

instance : is_lawful_mvfunctor P.obj :=
{ id_map := @id_map _ P,
  comp_map := @comp_map _ P }

/-- Constant functor where the input object does not affect the output -/
def const (n : ℕ) (A : Type u) : mvpfunctor n :=
{ A := A, B := λ a i, pempty }

section const
variables (n) {A : Type u}  {α β : typevec.{u} n}

/-- Constructor for the constant functor -/
def const.mk (x : A) {α} : (const n A).obj α :=
⟨ x, λ i a, pempty.elim a ⟩

variables {n A}

/-- Destructor for the constant functor -/
def const.get (x : (const n A).obj α) : A :=
x.1

@[simp]
lemma const.get_map (f : α ⟹ β) (x : (const n A).obj α) :
  const.get (f <$$> x) = const.get x :=
by { cases x, refl }

@[simp]
lemma const.get_mk (x : A) : const.get (const.mk n x : (const n A).obj α) = x :=
by refl

@[simp]
lemma const.mk_get (x : (const n A).obj α) : const.mk n (const.get x) = x :=
by { cases x, dsimp [const.get,const.mk], congr' with _ ⟨ ⟩ }

end const

/-- Functor composition on polynomial functors -/
def comp (P : mvpfunctor.{u} n) (Q : fin2 n → mvpfunctor.{u} m) : mvpfunctor m :=
{ A := Σ a₂ : P.1, Π i, P.2 a₂ i → (Q i).1,
  B := λ a, λ i, Σ j (b : P.2 a.1 j), (Q j).2 (a.snd j b) i }

variables {P} {Q : fin2 n → mvpfunctor.{u} m} {α β : typevec.{u} m}

/-- Constructor for functor composition -/
def comp.mk (x : P.obj (λ i, (Q i).obj α)) : (comp P Q).obj α :=
⟨ ⟨ x.1, λ i a, (x.2 _ a).1  ⟩, λ i a, (x.snd a.fst (a.snd).fst).snd i (a.snd).snd ⟩

/-- Destructor for functor composition -/
def comp.get (x : (comp P Q).obj α) : P.obj (λ i, (Q i).obj α) :=
⟨ x.1.1, λ i a, ⟨x.fst.snd i a, λ (j : fin2 m) (b : (Q i).B _ j), x.snd j ⟨i, ⟨a, b⟩⟩⟩ ⟩

lemma comp.get_map (f : α ⟹ β) (x : (comp P Q).obj α) :
  comp.get (f <$$> x) = (λ i (x : (Q i).obj α), f <$$> x) <$$> comp.get x :=
by { cases x, refl }

@[simp]
lemma comp.get_mk (x : P.obj (λ i, (Q i).obj α)) : comp.get (comp.mk x) = x :=
begin
  cases x,
  simp! [comp.get,comp.mk],
end

@[simp]
lemma comp.mk_get (x : (comp P Q).obj α) : comp.mk (comp.get x) = x :=
begin
  cases x,
  dsimp [comp.get,comp.mk],
  ext : 2; intros, refl, refl,
  congr, ext1; intros; refl,
  ext : 2, congr, rcases x_1 with ⟨a,b,c⟩; refl
end

/-
lifting predicates and relations
-/

theorem liftp_iff {α : typevec n} (p : Π ⦃i⦄ , α i → Prop) (x : P.obj α) :
  liftp p x ↔ ∃ a f, x = ⟨a, f⟩ ∧ ∀ i j, p (f i j) :=
begin
  split,
  { rintros ⟨y, hy⟩, cases h : y with a f,
    refine ⟨a, λ i j, (f i j).val, _, λ i j, (f i j).property⟩,
    rw [←hy, h, map_eq], refl },
  rintros ⟨a, f, xeq, pf⟩,
  use ⟨a, λ i j, ⟨f i j, pf i j⟩⟩,
  rw [xeq], reflexivity
end

theorem liftp_iff' {α : typevec n} (p : Π ⦃i⦄ , α i → Prop) (a : P.A) (f : P.B a ⟹ α) :
  @liftp.{u} _ P.obj _ α p ⟨a,f⟩ ↔ ∀ i x, p (f i x) :=
begin
  simp only [liftp_iff, sigma.mk.inj_iff]; split; intro,
  { casesm* [Exists _, _ ∧ _], subst_vars, assumption },
  repeat { constructor <|> assumption }
end

theorem liftr_iff {α : typevec n} (r : Π ⦃i⦄, α i → α i → Prop) (x y : P.obj α) :
  liftr r x y ↔ ∃ a f₀ f₁, x = ⟨a, f₀⟩ ∧ y = ⟨a, f₁⟩ ∧ ∀ i j, r (f₀ i j) (f₁ i j) :=
begin
  split,
  { rintros ⟨u, xeq, yeq⟩, cases h : u with a f,
    use [a, λ i j, (f i j).val.fst, λ i j, (f i j).val.snd],
    split, { rw [←xeq, h], refl },
    split, { rw [←yeq, h], refl },
    intros i j, exact (f i j).property },
  rintros ⟨a, f₀, f₁, xeq, yeq, h⟩,
  use ⟨a, λ i j, ⟨(f₀ i j, f₁ i j), h i j⟩⟩,
  dsimp, split,
  { rw [xeq], refl },
  rw [yeq], refl
end

open set mvfunctor

theorem supp_eq {α : typevec n} (a : P.A) (f : P.B a ⟹ α) (i) :
  @supp.{u} _ P.obj _ α  (⟨a,f⟩ : P.obj α) i = f i '' univ :=
begin
  ext, simp only [supp, image_univ, mem_range, mem_set_of_eq],
  split; intro h,
  { apply @h (λ i x, ∃ (y : P.B a i), f i y = x),
    rw liftp_iff', intros, refine ⟨_,rfl⟩ },
  { simp only [liftp_iff'], cases h, subst x,
    tauto }
end

end mvpfunctor

/-
Decomposing an n+1-ary pfunctor.
-/

namespace mvpfunctor
open typevec
variables {n : ℕ} (P : mvpfunctor.{u} (n+1))

/-- Split polynomial functor, get a n-ary functor
from a `n+1`-ary functor -/
def drop : mvpfunctor n :=
{ A := P.A, B := λ a, (P.B a).drop }

/-- Split polynomial functor, get a univariate functor
from a `n+1`-ary functor -/
def last : pfunctor :=
{ A := P.A, B := λ a, (P.B a).last }

/-- append arrows of a polynomial functor application -/
@[reducible] def append_contents {α : typevec n} {β : Type*}
    {a : P.A} (f' : P.drop.B a ⟹ α) (f : P.last.B a → β) :
  P.B a ⟹ α ::: β :=
split_fun f' f

end mvpfunctor


import Categories.Functor
import Categories.Initial

set_option autoImplicit false

namespace Mathematics

section
  variable {A B C : Category}

  def Comma.obj (F : Functor A C) (G : Functor B C) := Σ (a : A.obj) (b : B.obj), Hom C (F a) (G b)

  variable {F : Functor A C} {G : Functor B C}

  def Comma.mor (w₁ w₂ : Comma.obj F G) :=
  { w : Hom A w₁.1 w₂.1 × Hom B w₁.2.1 w₂.2.1 // w₂.2.2 ∘ F.map w.1 = G.map w.2 ∘ w₁.2.2 }

  def Comma.id (w : Comma.obj F G) : Comma.mor w w :=
  ⟨(1, 1), begin rw [F.idm, G.idm]; apply Eq.trans; apply C.rid; apply Eq.symm (C.lid _) end⟩

  def Comma.com {w₁ w₂ w₃ : Comma.obj F G} (f : Comma.mor w₂ w₃) (g : Comma.mor w₁ w₂) : Comma.mor w₁ w₃ :=
  ⟨(f.1.1 ∘ g.1.1, f.1.2 ∘ g.1.2), by rw [F.com, G.com, ←C.assoc, f.2, C.assoc, g.2, C.assoc]⟩

  lemma Comma.lid {w₁ w₂ : Comma.obj F G} (f : Comma.mor w₁ w₂) : Comma.com (Comma.id w₂) f = f :=
  begin apply Subtype.eq; apply Prod.eq; apply A.lid; apply B.lid end

  lemma Comma.rid {w₁ w₂ : Comma.obj F G} (f : Comma.mor w₁ w₂) : Comma.com f (Comma.id w₁) = f :=
  begin apply Subtype.eq; apply Prod.eq; apply A.rid; apply B.rid end

  lemma Comma.assoc {w₁ w₂ w₃ w₄ : Comma.obj F G} (f : Comma.mor w₃ w₄) (g : Comma.mor w₂ w₃) (h : Comma.mor w₁ w₂) :
    Comma.com (Comma.com f g) h = Comma.com f (Comma.com g h) :=
  begin apply Subtype.eq; apply Prod.eq; apply A.assoc; apply B.assoc end
end

def Comma {A B C : Category} (F : Functor A C) (G : Functor B C) : Category :=
{ obj   := Comma.obj F G,
  hom   := Comma.mor,
  id    := Comma.id,
  com   := Comma.com,
  lid   := Comma.lid,
  rid   := Comma.rid,
  assoc := Comma.assoc }

infix:61 " ↓ " => Comma

def Arrow (C : Category) :=
idfun C ↓ idfun C

def Slice (C : Category) (c : C.obj) :=
idfun C ↓ @Δ 𝟙 C c

def Coslice (C : Category) (c : C.obj) :=
@Δ 𝟙 C c ↓ idfun C

notation C " / " c => Slice C c
notation c " / " C => Coslice C c

def Slice.terminal (C : Category) (c : C.obj) : isTerminal (C / c) ⟨c, ★, C.id c⟩ :=
begin
  intro w; constructor;
  { apply Subtype.mk (w.2.2, ★);
    { apply Eq.trans; apply C.lid;
      apply Eq.symm; apply C.lid } };
  { intro f g; apply Subtype.eq; apply Prod.eq;
    rw [←C.lid f.1.1]; apply Eq.trans; exact f.2;
    apply Eq.symm; rw [←C.lid g.1.1]; apply g.2; rfl }
end

def Coslice.initial (C : Category) (c : C.obj) : isInitial (c / C) ⟨★, c, C.id c⟩ :=
begin
  intro w; constructor;
  { apply Subtype.mk (★, w.2.2);
    { apply Eq.trans; apply C.rid;
      apply Eq.symm; apply C.rid } };
  { intro f g; apply Subtype.eq; apply Prod.eq; rfl;
    rw [←C.rid f.1.2]; apply Eq.trans; exact Eq.symm f.2;
    apply Eq.symm; rw [←C.rid g.1.2]; apply Eq.symm g.2 }
end

def Pointed (C : Category) [H : HasTerminal C] : Category := H.τ / C


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

! This file was ported from Lean 3 source module ring_theory.discriminant
! leanprover-community/mathlib commit 825edd3cd735e87495b0c2a2114fc3929eefce41
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.RingTheory.Trace
import Mathbin.RingTheory.Norm
import Mathbin.NumberTheory.NumberField.Basic

/-!
# Discriminant of a family of vectors

Given an `A`-algebra `B` and `b`, an `ι`-indexed family of elements of `B`, we define the
*discriminant* of `b` as the determinant of the matrix whose `(i j)`-th element is the trace of
`b i * b j`.

## Main definition

* `algebra.discr A b` : the discriminant of `b : ι → B`.

## Main results

* `algebra.discr_zero_of_not_linear_independent` : if `b` is not linear independent, then
  `algebra.discr A b = 0`.
* `algebra.discr_of_matrix_vec_mul` and `discr_of_matrix_mul_vec` : formulas relating
  `algebra.discr A ι b` with `algebra.discr A ((P.map (algebra_map A B)).vec_mul b)` and
  `algebra.discr A ((P.map (algebra_map A B)).mul_vec b)`.
* `algebra.discr_not_zero_of_basis` : over a field, if `b` is a basis, then
  `algebra.discr K b ≠ 0`.
* `algebra.discr_eq_det_embeddings_matrix_reindex_pow_two` : if `L/K` is a field extension and
  `b : ι → L`, then `discr K b` is the square of the determinant of the matrix whose `(i, j)`
  coefficient is `σⱼ (b i)`, where `σⱼ : L →ₐ[K] E` is the embedding in an algebraically closed
  field `E` corresponding to `j : ι` via a bijection `e : ι ≃ (L →ₐ[K] E)`.
* `algebra.discr_of_power_basis_eq_prod` : the discriminant of a power basis.
* `discr_is_integral` : if `K` and `L` are fields and `is_scalar_tower R K L`, is `b : ι → L`
  satisfies ` ∀ i, is_integral R (b i)`, then `is_integral R (discr K b)`.
* `discr_mul_is_integral_mem_adjoin` : let `K` be the fraction field of an integrally closed domain
  `R` and let `L` be a finite separable extension of `K`. Let `B : power_basis K L` be such that
  `is_integral R B.gen`. Then for all, `z : L` we have
  `(discr K B.basis) • z ∈ adjoin R ({B.gen} : set L)`.

## Implementation details

Our definition works for any `A`-algebra `B`, but note that if `B` is not free as an `A`-module,
then `trace A B = 0` by definition, so `discr A b = 0` for any `b`.
-/

universe u v w z

open Matrix BigOperators

open Matrix FiniteDimensional Fintype Polynomial Finset IntermediateField

namespace Algebra

variable (A : Type u) {B : Type v} (C : Type z) {ι : Type w}

variable [CommRing A] [CommRing B] [Algebra A B] [CommRing C] [Algebra A C]

section Discr

/-- Given an `A`-algebra `B` and `b`, an `ι`-indexed family of elements of `B`, we define
`discr A ι b` as the determinant of `trace_matrix A ι b`. -/
noncomputable def discr (A : Type u) {B : Type v} [CommRing A] [CommRing B] [Algebra A B]
    [Fintype ι] (b : ι → B) := by classical exact (trace_matrix A b).det
#align algebra.discr Algebra.discr

theorem discr_def [DecidableEq ι] [Fintype ι] (b : ι → B) : discr A b = (traceMatrix A b).det := by
  convert rfl
#align algebra.discr_def Algebra.discr_def

variable {ι' : Type _} [Fintype ι'] [Fintype ι]

section Basic

@[simp]
theorem discr_reindex (b : Basis ι A B) (f : ι ≃ ι') : discr A (b ∘ ⇑f.symm) = discr A b := by
  classical rw [← Basis.coe_reindex, discr_def, trace_matrix_reindex, det_reindex_self, ← discr_def]
#align algebra.discr_reindex Algebra.discr_reindex

/-- If `b` is not linear independent, then `algebra.discr A b = 0`. -/
theorem discr_zero_of_not_linearIndependent [IsDomain A] {b : ι → B}
    (hli : ¬LinearIndependent A b) : discr A b = 0 := by
  classical
    obtain ⟨g, hg, i, hi⟩ := Fintype.not_linearIndependent_iff.1 hli
    have : (trace_matrix A b).mulVec g = 0 := by
      ext i
      have : ∀ j, (trace A B) (b i * b j) * g j = (trace A B) (g j • b j * b i) :=
        by
        intro j
        simp [mul_comm]
      simp only [mul_vec, dot_product, trace_matrix, Pi.zero_apply, trace_form_apply, fun j =>
        this j, ← LinearMap.map_sum, ← sum_mul, hg, MulZeroClass.zero_mul, LinearMap.map_zero]
    by_contra h
    rw [discr_def] at h
    simpa [Matrix.eq_zero_of_mulVec_eq_zero h this] using hi
#align algebra.discr_zero_of_not_linear_independent Algebra.discr_zero_of_not_linearIndependent

variable {A}

/-- Relation between `algebra.discr A ι b` and
`algebra.discr A ((P.map (algebra_map A B)).vec_mul b)`. -/
theorem discr_of_matrix_vecMul [DecidableEq ι] (b : ι → B) (P : Matrix ι ι A) :
    discr A ((P.map (algebraMap A B)).vecMul b) = P.det ^ 2 * discr A b := by
  rw [discr_def, trace_matrix_of_matrix_vec_mul, det_mul, det_mul, det_transpose, mul_comm, ←
    mul_assoc, discr_def, pow_two]
#align algebra.discr_of_matrix_vec_mul Algebra.discr_of_matrix_vecMul

/-- Relation between `algebra.discr A ι b` and
`algebra.discr A ((P.map (algebra_map A B)).mul_vec b)`. -/
theorem discr_of_matrix_mulVec [DecidableEq ι] (b : ι → B) (P : Matrix ι ι A) :
    discr A ((P.map (algebraMap A B)).mulVec b) = P.det ^ 2 * discr A b := by
  rw [discr_def, trace_matrix_of_matrix_mul_vec, det_mul, det_mul, det_transpose, mul_comm, ←
    mul_assoc, discr_def, pow_two]
#align algebra.discr_of_matrix_mul_vec Algebra.discr_of_matrix_mulVec

end Basic

section Field

variable (K : Type u) {L : Type v} (E : Type z) [Field K] [Field L] [Field E]

variable [Algebra K L] [Algebra K E]

variable [Module.Finite K L] [IsAlgClosed E]

/-- Over a field, if `b` is a basis, then `algebra.discr K b ≠ 0`. -/
theorem discr_not_zero_of_basis [IsSeparable K L] (b : Basis ι K L) : discr K b ≠ 0 :=
  by
  cases isEmpty_or_nonempty ι
  · simp [discr]
  · have :=
      span_eq_top_of_linearIndependent_of_card_eq_finrank b.linear_independent
        (finrank_eq_card_basis b).symm
    classical
      rw [discr_def, trace_matrix_def]
      simp_rw [← Basis.mk_apply b.linear_independent this.ge]
      rw [← trace_matrix_def, trace_matrix_of_basis, ← BilinForm.nondegenerate_iff_det_ne_zero]
      exact traceFormNondegenerate _ _
#align algebra.discr_not_zero_of_basis Algebra.discr_not_zero_of_basis

/-- Over a field, if `b` is a basis, then `algebra.discr K b` is a unit. -/
theorem discr_isUnit_of_basis [IsSeparable K L] (b : Basis ι K L) : IsUnit (discr K b) :=
  IsUnit.mk0 _ (discr_not_zero_of_basis _ _)
#align algebra.discr_is_unit_of_basis Algebra.discr_isUnit_of_basis

variable (b : ι → L) (pb : PowerBasis K L)

/-- If `L/K` is a field extension and `b : ι → L`, then `discr K b` is the square of the
determinant of the matrix whose `(i, j)` coefficient is `σⱼ (b i)`, where `σⱼ : L →ₐ[K] E` is the
embedding in an algebraically closed field `E` corresponding to `j : ι` via a bijection
`e : ι ≃ (L →ₐ[K] E)`. -/
theorem discr_eq_det_embeddingsMatrixReindex_pow_two [DecidableEq ι] [IsSeparable K L]
    (e : ι ≃ (L →ₐ[K] E)) :
    algebraMap K E (discr K b) = (embeddingsMatrixReindex K E b e).det ^ 2 := by
  rw [discr_def, RingHom.map_det, RingHom.mapMatrix_apply,
    trace_matrix_eq_embeddings_matrix_reindex_mul_trans, det_mul, det_transpose, pow_two]
#align algebra.discr_eq_det_embeddings_matrix_reindex_pow_two Algebra.discr_eq_det_embeddingsMatrixReindex_pow_two

/-- The discriminant of a power basis. -/
theorem discr_powerBasis_eq_prod (e : Fin pb.dim ≃ (L →ₐ[K] E)) [IsSeparable K L] :
    algebraMap K E (discr K pb.Basis) =
      ∏ i : Fin pb.dim, ∏ j in Ioi i, (e j pb.gen - e i pb.gen) ^ 2 :=
  by
  rw [discr_eq_det_embeddings_matrix_reindex_pow_two K E pb.basis e,
    embeddings_matrix_reindex_eq_vandermonde, det_transpose, det_vandermonde, ← prod_pow]
  congr ; ext i
  rw [← prod_pow]
#align algebra.discr_power_basis_eq_prod Algebra.discr_powerBasis_eq_prod

/-- A variation of `of_power_basis_eq_prod`. -/
theorem discr_powerBasis_eq_prod' [IsSeparable K L] (e : Fin pb.dim ≃ (L →ₐ[K] E)) :
    algebraMap K E (discr K pb.Basis) =
      ∏ i : Fin pb.dim, ∏ j in Ioi i, -((e j pb.gen - e i pb.gen) * (e i pb.gen - e j pb.gen)) :=
  by
  rw [discr_power_basis_eq_prod _ _ _ e]
  congr ; ext i; congr ; ext j
  ring
#align algebra.discr_power_basis_eq_prod' Algebra.discr_powerBasis_eq_prod'

-- mathport name: exprn
local notation "n" => finrank K L

/-- A variation of `of_power_basis_eq_prod`. -/
theorem discr_powerBasis_eq_prod'' [IsSeparable K L] (e : Fin pb.dim ≃ (L →ₐ[K] E)) :
    algebraMap K E (discr K pb.Basis) =
      (-1) ^ (n * (n - 1) / 2) *
        ∏ i : Fin pb.dim, ∏ j in Ioi i, (e j pb.gen - e i pb.gen) * (e i pb.gen - e j pb.gen) :=
  by
  rw [discr_power_basis_eq_prod' _ _ _ e]
  simp_rw [fun i j => neg_eq_neg_one_mul ((e j pb.gen - e i pb.gen) * (e i pb.gen - e j pb.gen)),
    prod_mul_distrib]
  congr
  simp only [prod_pow_eq_pow_sum, prod_const]
  congr
  rw [← @Nat.cast_inj ℚ, Nat.cast_sum]
  have : ∀ x : Fin pb.dim, ↑x + 1 ≤ pb.dim := by simp [Nat.succ_le_iff, Fin.is_lt]
  simp_rw [Fin.card_Ioi, Nat.sub_sub, add_comm 1]
  simp only [Nat.cast_sub, this, Finset.card_fin, nsmul_eq_mul, sum_const, sum_sub_distrib,
    Nat.cast_add, Nat.cast_one, sum_add_distrib, mul_one]
  rw [← Nat.cast_sum, ← @Finset.sum_range ℕ _ pb.dim fun i => i, sum_range_id]
  have hn : n = pb.dim :=
    by
    rw [← AlgHom.card K L E, ← Fintype.card_fin pb.dim]
    exact card_congr (Equiv.symm e)
  have h₂ : 2 ∣ pb.dim * (pb.dim - 1) := even_iff_two_dvd.1 (Nat.even_mul_self_pred _)
  have hne : ((2 : ℕ) : ℚ) ≠ 0 := by simp
  have hle : 1 ≤ pb.dim :=
    by
    rw [← hn, Nat.one_le_iff_ne_zero, ← zero_lt_iff, FiniteDimensional.finrank_pos_iff]
    infer_instance
  rw [hn, Nat.cast_div h₂ hne, Nat.cast_mul, Nat.cast_sub hle]
  field_simp
  ring
#align algebra.discr_power_basis_eq_prod'' Algebra.discr_powerBasis_eq_prod''

/-- Formula for the discriminant of a power basis using the norm of the field extension. -/
theorem discr_powerBasis_eq_norm [IsSeparable K L] :
    discr K pb.Basis =
      (-1) ^ (n * (n - 1) / 2) * norm K (aeval pb.gen (minpoly K pb.gen).derivative) :=
  by
  let E := AlgebraicClosure L
  letI := fun a b : E => Classical.propDecidable (Eq a b)
  have e : Fin pb.dim ≃ (L →ₐ[K] E) :=
    by
    refine' equiv_of_card_eq _
    rw [Fintype.card_fin, AlgHom.card]
    exact (PowerBasis.finrank pb).symm
  have hnodup : (map (algebraMap K E) (minpoly K pb.gen)).roots.Nodup :=
    nodup_roots (separable.map (IsSeparable.separable K pb.gen))
  have hroots : ∀ σ : L →ₐ[K] E, σ pb.gen ∈ (map (algebraMap K E) (minpoly K pb.gen)).roots :=
    by
    intro σ
    rw [mem_roots, is_root.def, eval_map, ← aeval_def, aeval_alg_hom_apply]
    repeat' simp [minpoly.ne_zero (IsSeparable.isIntegral K pb.gen)]
  apply (algebraMap K E).Injective
  rw [RingHom.map_mul, RingHom.map_pow, RingHom.map_neg, RingHom.map_one,
    discr_power_basis_eq_prod'' _ _ _ e]
  congr
  rw [norm_eq_prod_embeddings, prod_prod_Ioi_mul_eq_prod_prod_off_diag]
  conv_rhs =>
    congr
    skip
    ext
    rw [← aeval_alg_hom_apply,
      aeval_root_derivative_of_splits (minpoly.monic (IsSeparable.isIntegral K pb.gen))
        (IsAlgClosed.splits_codomain _) (hroots σ),
      ← Finset.prod_mk _ (hnodup.erase _)]
  rw [prod_sigma', prod_sigma']
  refine'
    prod_bij (fun i hi => ⟨e i.2, e i.1 pb.gen⟩) (fun i hi => _) (fun i hi => by simp at hi)
      (fun i j hi hj hij => _) fun σ hσ => _
  · simp only [true_and_iff, Finset.mem_mk, mem_univ, mem_sigma]
    rw [Multiset.mem_erase_of_ne fun h => _]
    · exact hroots _
    · simp only [true_and_iff, mem_univ, Ne.def, mem_sigma, mem_compl, mem_singleton] at hi
      rw [← PowerBasis.liftEquiv_apply_coe, ← PowerBasis.liftEquiv_apply_coe] at h
      exact hi (e.injective <| pb.lift_equiv.injective <| Subtype.eq h.symm)
  · simp only [Equiv.apply_eq_iff_eq, heq_iff_eq] at hij
    have h := hij.2
    rw [← PowerBasis.liftEquiv_apply_coe, ← PowerBasis.liftEquiv_apply_coe] at h
    refine' Sigma.eq (Equiv.injective e (Equiv.injective _ (Subtype.eq h))) (by simp [hij.1])
  · simp only [true_and_iff, Finset.mem_mk, mem_univ, mem_sigma] at hσ⊢
    simp only [Sigma.exists, exists_prop, mem_compl, mem_singleton, Ne.def]
    refine' ⟨e.symm (PowerBasis.lift pb σ.2 _), e.symm σ.1, ⟨fun h => _, Sigma.eq _ _⟩⟩
    · rw [aeval_def, eval₂_eq_eval_map, ← is_root.def, ← mem_roots]
      · exact Multiset.erase_subset _ _ hσ
      · simp [minpoly.ne_zero (IsSeparable.isIntegral K pb.gen)]
    · replace h := AlgHom.congr_fun (Equiv.injective _ h) pb.gen
      rw [PowerBasis.lift_gen] at h
      rw [← h] at hσ
      exact hnodup.not_mem_erase hσ
    all_goals simp
#align algebra.discr_power_basis_eq_norm Algebra.discr_powerBasis_eq_norm

section Integral

variable {R : Type z} [CommRing R] [Algebra R K] [Algebra R L] [IsScalarTower R K L]

/-- If `K` and `L` are fields and `is_scalar_tower R K L`, and `b : ι → L` satisfies
` ∀ i, is_integral R (b i)`, then `is_integral R (discr K b)`. -/
theorem discr_isIntegral {b : ι → L} (h : ∀ i, IsIntegral R (b i)) : IsIntegral R (discr K b) := by
  classical
    rw [discr_def]
    exact IsIntegral.det fun i j => is_integral_trace (isIntegral_mul (h i) (h j))
#align algebra.discr_is_integral Algebra.discr_isIntegral

/-- If `b` and `b'` are `ℚ`-bases of a number field `K` such that
`∀ i j, is_integral ℤ (b.to_matrix b' i j)` and `∀ i j, is_integral ℤ (b'.to_matrix b i j)` then
`discr ℚ b = discr ℚ b'`. -/
theorem discr_eq_discr_of_toMatrix_coeff_isIntegral [NumberField K] {b : Basis ι ℚ K}
    {b' : Basis ι' ℚ K} (h : ∀ i j, IsIntegral ℤ (b.toMatrix b' i j))
    (h' : ∀ i j, IsIntegral ℤ (b'.toMatrix b i j)) : discr ℚ b = discr ℚ b' :=
  by
  replace h' : ∀ i j, IsIntegral ℤ (b'.to_matrix (b.reindex (b.index_equiv b')) i j)
  · intro i j
    convert h' i ((b.index_equiv b').symm j)
    simpa
  classical
    rw [← (b.reindex (b.index_equiv b')).toMatrix_map_vecMul b', discr_of_matrix_vec_mul, ←
      one_mul (discr ℚ b), Basis.coe_reindex, discr_reindex]
    congr
    have hint : IsIntegral ℤ ((b.reindex (b.index_equiv b')).toMatrix b').det :=
      IsIntegral.det fun i j => h _ _
    obtain ⟨r, hr⟩ := IsIntegrallyClosed.isIntegral_iff.1 hint
    have hunit : IsUnit r :=
      by
      have : IsIntegral ℤ (b'.to_matrix (b.reindex (b.index_equiv b'))).det :=
        IsIntegral.det fun i j => h' _ _
      obtain ⟨r', hr'⟩ := IsIntegrallyClosed.isIntegral_iff.1 this
      refine' isUnit_iff_exists_inv.2 ⟨r', _⟩
      suffices algebraMap ℤ ℚ (r * r') = 1
        by
        rw [← RingHom.map_one (algebraMap ℤ ℚ)] at this
        exact (IsFractionRing.injective ℤ ℚ) this
      rw [RingHom.map_mul, hr, hr', ← det_mul, Basis.toMatrix_mul_toMatrix_flip, det_one]
    rw [← RingHom.map_one (algebraMap ℤ ℚ), ← hr]
    cases' Int.isUnit_iff.1 hunit with hp hm
    · simp [hp]
    · simp [hm]
#align algebra.discr_eq_discr_of_to_matrix_coeff_is_integral Algebra.discr_eq_discr_of_toMatrix_coeff_isIntegral

/-- Let `K` be the fraction field of an integrally closed domain `R` and let `L` be a finite
separable extension of `K`. Let `B : power_basis K L` be such that `is_integral R B.gen`.
Then for all, `z : L` that are integral over `R`, we have
`(discr K B.basis) • z ∈ adjoin R ({B.gen} : set L)`. -/
theorem discr_mul_isIntegral_mem_adjoin [IsDomain R] [IsSeparable K L] [IsIntegrallyClosed R]
    [IsFractionRing R K] {B : PowerBasis K L} (hint : IsIntegral R B.gen) {z : L}
    (hz : IsIntegral R z) : discr K B.Basis • z ∈ adjoin R ({B.gen} : Set L) :=
  by
  have hinv : IsUnit (trace_matrix K B.basis).det := by
    simpa [← discr_def] using discr_is_unit_of_basis _ B.basis
  have H :
    (trace_matrix K B.basis).det • (trace_matrix K B.basis).mulVec (B.basis.equiv_fun z) =
      (trace_matrix K B.basis).det • fun i => trace K L (z * B.basis i) :=
    by
    congr
    exact trace_matrix_of_basis_mul_vec _ _
  have cramer := mul_vec_cramer (trace_matrix K B.basis) fun i => trace K L (z * B.basis i)
  suffices ∀ i, ((trace_matrix K B.basis).det • B.basis.equiv_fun z) i ∈ (⊥ : Subalgebra R K)
    by
    rw [← B.basis.sum_repr z, Finset.smul_sum]
    refine' Subalgebra.sum_mem _ fun i hi => _
    replace this := this i
    rw [← discr_def, Pi.smul_apply, mem_bot] at this
    obtain ⟨r, hr⟩ := this
    rw [Basis.equivFun_apply] at hr
    rw [← smul_assoc, ← hr, algebraMap_smul]
    refine' Subalgebra.smul_mem _ _ _
    rw [B.basis_eq_pow i]
    refine' Subalgebra.pow_mem _ (subset_adjoin (Set.mem_singleton _)) _
  intro i
  rw [← H, ← mul_vec_smul] at cramer
  replace cramer := congr_arg (mul_vec (trace_matrix K B.basis)⁻¹) cramer
  rw [mul_vec_mul_vec, nonsing_inv_mul _ hinv, mul_vec_mul_vec, nonsing_inv_mul _ hinv, one_mul_vec,
    one_mul_vec] at cramer
  rw [← congr_fun cramer i, cramer_apply, det_apply]
  refine'
    Subalgebra.sum_mem _ fun σ _ => Subalgebra.zsmul_mem _ (Subalgebra.prod_mem _ fun j _ => _) _
  by_cases hji : j = i
  · simp only [update_column_apply, hji, eq_self_iff_true, PowerBasis.coe_basis]
    exact
      mem_bot.2
        (IsIntegrallyClosed.isIntegral_iff.1 <|
          is_integral_trace <| isIntegral_mul hz <| IsIntegral.pow hint _)
  · simp only [update_column_apply, hji, PowerBasis.coe_basis]
    exact
      mem_bot.2
        (IsIntegrallyClosed.isIntegral_iff.1 <|
          is_integral_trace <| isIntegral_mul (IsIntegral.pow hint _) (IsIntegral.pow hint _))
#align algebra.discr_mul_is_integral_mem_adjoin Algebra.discr_mul_isIntegral_mem_adjoin

end Integral

end Field

end Discr

end Algebra