/-
Copyright (c) 2020 Anne Baanen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Anne Baanen
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.invertible
import Mathlib.linear_algebra.bilinear_form
import Mathlib.linear_algebra.determinant
import Mathlib.linear_algebra.special_linear_group
import Mathlib.PostPort

universes u v l u_1 w u_2 u_3

namespace Mathlib

/-!
# Quadratic forms

This file defines quadratic forms over a `R`-module `M`.
A quadratic form is a map `Q : M → R` such that
  (`to_fun_smul`) `Q (a • x) = a * a * Q x`
  (`polar_...`) The map `polar Q := λ x y, Q (x + y) - Q x - Q y` is bilinear.
They come with a scalar multiplication, `(a • Q) x = Q (a • x) = a * a * Q x`,
and composition with linear maps `f`, `Q.comp f x = Q (f x)`.

## Main definitions

 * `quadratic_form.associated`: associated bilinear form
 * `quadratic_form.pos_def`: positive definite quadratic forms
 * `quadratic_form.anisotropic`: anisotropic quadratic forms
 * `quadratic_form.discr`: discriminant of a quadratic form

## Main statements

 * `quadratic_form.associated_left_inverse`,
 * `quadratic_form.associated_right_inverse`: in a commutative ring where 2 has
  an inverse, there is a correspondence between quadratic forms and symmetric
  bilinear forms

## Notation

In this file, the variable `R` is used when a `ring` structure is sufficient and
`R₁` is used when specifically a `comm_ring` is required. This allows us to keep
`[module R M]` and `[module R₁ M]` assumptions in the variables without
confusion between `*` from `ring` and `*` from `comm_ring`.

## References

 * https://en.wikipedia.org/wiki/Quadratic_form
 * https://en.wikipedia.org/wiki/Discriminant#Quadratic_forms

## Tags

quadratic form, homogeneous polynomial, quadratic polynomial
-/

namespace quadratic_form

/-- Up to a factor 2, `Q.polar` is the associated bilinear form for a quadratic form `Q`.d

Source of this name: https://en.wikipedia.org/wiki/Quadratic_form#Generalization
-/
def polar {R : Type u} {M : Type v} [add_comm_group M] [ring R] (f : M → R) (x : M) (y : M) : R :=
  f (x + y) - f x - f y

theorem polar_add {R : Type u} {M : Type v} [add_comm_group M] [ring R] (f : M → R) (g : M → R) (x : M) (y : M) : polar (f + g) x y = polar f x y + polar g x y := sorry

theorem polar_neg {R : Type u} {M : Type v} [add_comm_group M] [ring R] (f : M → R) (x : M) (y : M) : polar (-f) x y = -polar f x y := sorry

theorem polar_smul {R : Type u} {M : Type v} [add_comm_group M] [ring R] (f : M → R) (s : R) (x : M) (y : M) : polar (s • f) x y = s * polar f x y := sorry

theorem polar_comm {M : Type v} [add_comm_group M] {R₁ : Type u} [comm_ring R₁] (f : M → R₁) (x : M) (y : M) : polar f x y = polar f y x := sorry

end quadratic_form

/-- A quadratic form over a module. -/
structure quadratic_form (R : Type u) (M : Type v) [ring R] [add_comm_group M] [module R M]
extends quadratic_form.to_fun #1 #0 R M _inst_6 _inst_7 (_inst_8 • to_fun) =
  _inst_8 * _inst_8 * quadratic_form.to_fun #1 #0 R M _inst_6 _inst_7 to_fun
where
  to_fun : M → R
  to_fun_smul : ∀ (a : R) (x : M), to_fun (a • x) = a * a * to_fun x
  polar_add_left' : ∀ (x x' y : M),
  quadratic_form.polar to_fun (x + x') y = quadratic_form.polar to_fun x y + quadratic_form.polar to_fun x' y
  polar_smul_left' : ∀ (a : R) (x y : M), quadratic_form.polar to_fun (a • x) y = a • quadratic_form.polar to_fun x y
  polar_add_right' : ∀ (x y y' : M),
  quadratic_form.polar to_fun x (y + y') = quadratic_form.polar to_fun x y + quadratic_form.polar to_fun x y'
  polar_smul_right' : ∀ (a : R) (x y : M), quadratic_form.polar to_fun x (a • y) = a • quadratic_form.polar to_fun x y

namespace quadratic_form

protected instance has_coe_to_fun {R : Type u} {M : Type v} [add_comm_group M] [ring R] [module R M] : has_coe_to_fun (quadratic_form R M) :=
  has_coe_to_fun.mk (fun (B : quadratic_form R M) => M → R) fun (B : quadratic_form R M) => to_fun B

/-- The `simp` normal form for a quadratic form is `coe_fn`, not `to_fun`. -/
@[simp] theorem to_fun_eq_apply {R : Type u} {M : Type v} [add_comm_group M] [ring R] [module R M] {Q : quadratic_form R M} : to_fun Q = ⇑Q :=
  rfl

@[simp] theorem polar_add_left {R : Type u} {M : Type v} [add_comm_group M] [ring R] [module R M] {Q : quadratic_form R M} (x : M) (x' : M) (y : M) : polar (⇑Q) (x + x') y = polar (⇑Q) x y + polar (⇑Q) x' y :=
  polar_add_left' Q x x' y

@[simp] theorem polar_smul_left {R : Type u} {M : Type v} [add_comm_group M] [ring R] [module R M] {Q : quadratic_form R M} (a : R) (x : M) (y : M) : polar (⇑Q) (a • x) y = a * polar (⇑Q) x y :=
  polar_smul_left' Q a x y

@[simp] theorem polar_neg_left {R : Type u} {M : Type v} [add_comm_group M] [ring R] [module R M] {Q : quadratic_form R M} (x : M) (y : M) : polar (⇑Q) (-x) y = -polar (⇑Q) x y := sorry

@[simp] theorem polar_sub_left {R : Type u} {M : Type v} [add_comm_group M] [ring R] [module R M] {Q : quadratic_form R M} (x : M) (x' : M) (y : M) : polar (⇑Q) (x - x') y = polar (⇑Q) x y - polar (⇑Q) x' y := sorry

@[simp] theorem polar_add_right {R : Type u} {M : Type v} [add_comm_group M] [ring R] [module R M] {Q : quadratic_form R M} (x : M) (y : M) (y' : M) : polar (⇑Q) x (y + y') = polar (⇑Q) x y + polar (⇑Q) x y' :=
  polar_add_right' Q x y y'

@[simp] theorem polar_smul_right {R : Type u} {M : Type v} [add_comm_group M] [ring R] [module R M] {Q : quadratic_form R M} (a : R) (x : M) (y : M) : polar (⇑Q) x (a • y) = a * polar (⇑Q) x y :=
  polar_smul_right' Q a x y

@[simp] theorem polar_neg_right {R : Type u} {M : Type v} [add_comm_group M] [ring R] [module R M] {Q : quadratic_form R M} (x : M) (y : M) : polar (⇑Q) x (-y) = -polar (⇑Q) x y := sorry

@[simp] theorem polar_sub_right {R : Type u} {M : Type v} [add_comm_group M] [ring R] [module R M] {Q : quadratic_form R M} (x : M) (y : M) (y' : M) : polar (⇑Q) x (y - y') = polar (⇑Q) x y - polar (⇑Q) x y' := sorry

theorem map_smul {R : Type u} {M : Type v} [add_comm_group M] [ring R] [module R M] {Q : quadratic_form R M} (a : R) (x : M) : coe_fn Q (a • x) = a * a * coe_fn Q x :=
  to_fun_smul Q a x

theorem map_add_self {R : Type u} {M : Type v} [add_comm_group M] [ring R] [module R M] {Q : quadratic_form R M} (x : M) : coe_fn Q (x + x) = bit0 (bit0 1) * coe_fn Q x := sorry

@[simp] theorem map_zero {R : Type u} {M : Type v} [add_comm_group M] [ring R] [module R M] {Q : quadratic_form R M} : coe_fn Q 0 = 0 := sorry

@[simp] theorem map_neg {R : Type u} {M : Type v} [add_comm_group M] [ring R] [module R M] {Q : quadratic_form R M} (x : M) : coe_fn Q (-x) = coe_fn Q x := sorry

theorem map_sub {R : Type u} {M : Type v} [add_comm_group M] [ring R] [module R M] {Q : quadratic_form R M} (x : M) (y : M) : coe_fn Q (x - y) = coe_fn Q (y - x) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (coe_fn Q (x - y) = coe_fn Q (y - x))) (Eq.symm (neg_sub y x))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (coe_fn Q (-(y - x)) = coe_fn Q (y - x))) (map_neg (y - x))))
      (Eq.refl (coe_fn Q (y - x))))

theorem ext {R : Type u} {M : Type v} [add_comm_group M] [ring R] [module R M] {Q : quadratic_form R M} {Q' : quadratic_form R M} (H : ∀ (x : M), coe_fn Q x = coe_fn Q' x) : Q = Q' := sorry

protected instance has_zero {R : Type u} {M : Type v} [add_comm_group M] [ring R] [module R M] : HasZero (quadratic_form R M) :=
  { zero := mk (fun (x : M) => 0) sorry sorry sorry sorry sorry }

@[simp] theorem zero_apply {R : Type u} {M : Type v} [add_comm_group M] [ring R] [module R M] (x : M) : coe_fn 0 x = 0 :=
  rfl

protected instance inhabited {R : Type u} {M : Type v} [add_comm_group M] [ring R] [module R M] : Inhabited (quadratic_form R M) :=
  { default := 0 }

protected instance has_add {R : Type u} {M : Type v} [add_comm_group M] [ring R] [module R M] : Add (quadratic_form R M) :=
  { add := fun (Q Q' : quadratic_form R M) => mk (⇑Q + ⇑Q') sorry sorry sorry sorry sorry }

@[simp] theorem coe_fn_add {R : Type u} {M : Type v} [add_comm_group M] [ring R] [module R M] (Q : quadratic_form R M) (Q' : quadratic_form R M) : ⇑(Q + Q') = ⇑Q + ⇑Q' :=
  rfl

@[simp] theorem add_apply {R : Type u} {M : Type v} [add_comm_group M] [ring R] [module R M] (Q : quadratic_form R M) (Q' : quadratic_form R M) (x : M) : coe_fn (Q + Q') x = coe_fn Q x + coe_fn Q' x :=
  rfl

protected instance has_neg {R : Type u} {M : Type v} [add_comm_group M] [ring R] [module R M] : Neg (quadratic_form R M) :=
  { neg := fun (Q : quadratic_form R M) => mk (-⇑Q) sorry sorry sorry sorry sorry }

@[simp] theorem coe_fn_neg {R : Type u} {M : Type v} [add_comm_group M] [ring R] [module R M] (Q : quadratic_form R M) : ⇑(-Q) = -⇑Q :=
  rfl

@[simp] theorem neg_apply {R : Type u} {M : Type v} [add_comm_group M] [ring R] [module R M] (Q : quadratic_form R M) (x : M) : coe_fn (-Q) x = -coe_fn Q x :=
  rfl

protected instance has_scalar {M : Type v} [add_comm_group M] {R₁ : Type u} [comm_ring R₁] [module R₁ M] : has_scalar R₁ (quadratic_form R₁ M) :=
  has_scalar.mk fun (a : R₁) (Q : quadratic_form R₁ M) => mk (a • ⇑Q) sorry sorry sorry sorry sorry

@[simp] theorem coe_fn_smul {M : Type v} [add_comm_group M] {R₁ : Type u} [comm_ring R₁] [module R₁ M] (a : R₁) (Q : quadratic_form R₁ M) : ⇑(a • Q) = a • ⇑Q :=
  rfl

@[simp] theorem smul_apply {M : Type v} [add_comm_group M] {R₁ : Type u} [comm_ring R₁] [module R₁ M] (a : R₁) (Q : quadratic_form R₁ M) (x : M) : coe_fn (a • Q) x = a * coe_fn Q x :=
  rfl

protected instance add_comm_group {R : Type u} {M : Type v} [add_comm_group M] [ring R] [module R M] : add_comm_group (quadratic_form R M) :=
  add_comm_group.mk Add.add sorry 0 sorry sorry Neg.neg (add_group.sub._default Add.add sorry 0 sorry sorry Neg.neg) sorry
    sorry

protected instance module {M : Type v} [add_comm_group M] {R₁ : Type u} [comm_ring R₁] [module R₁ M] : module R₁ (quadratic_form R₁ M) :=
  semimodule.mk sorry sorry

/-- Compose the quadratic form with a linear function. -/
def comp {R : Type u} {M : Type v} [add_comm_group M] [ring R] [module R M] {N : Type v} [add_comm_group N] [module R N] (Q : quadratic_form R N) (f : linear_map R M N) : quadratic_form R M :=
  mk (fun (x : M) => coe_fn Q (coe_fn f x)) sorry sorry sorry sorry sorry

@[simp] theorem comp_apply {R : Type u} {M : Type v} [add_comm_group M] [ring R] [module R M] {N : Type v} [add_comm_group N] [module R N] (Q : quadratic_form R N) (f : linear_map R M N) (x : M) : coe_fn (comp Q f) x = coe_fn Q (coe_fn f x) :=
  rfl

/-- Create a quadratic form in a commutative ring by proving only one side of the bilinearity. -/
def mk_left {M : Type v} [add_comm_group M] {R₁ : Type u} [comm_ring R₁] [module R₁ M] (f : M → R₁) (to_fun_smul : ∀ (a : R₁) (x : M), f (a • x) = a * a * f x) (polar_add_left : ∀ (x x' y : M), polar f (x + x') y = polar f x y + polar f x' y) (polar_smul_left : ∀ (a : R₁) (x y : M), polar f (a • x) y = a * polar f x y) : quadratic_form R₁ M :=
  mk f to_fun_smul polar_add_left polar_smul_left sorry sorry

/-- The product of linear forms is a quadratic form. -/
def lin_mul_lin {M : Type v} [add_comm_group M] {R₁ : Type u} [comm_ring R₁] [module R₁ M] (f : linear_map R₁ M R₁) (g : linear_map R₁ M R₁) : quadratic_form R₁ M :=
  mk_left (⇑f * ⇑g) sorry sorry sorry

@[simp] theorem lin_mul_lin_apply {M : Type v} [add_comm_group M] {R₁ : Type u} [comm_ring R₁] [module R₁ M] (f : linear_map R₁ M R₁) (g : linear_map R₁ M R₁) (x : M) : coe_fn (lin_mul_lin f g) x = coe_fn f x * coe_fn g x :=
  rfl

@[simp] theorem add_lin_mul_lin {M : Type v} [add_comm_group M] {R₁ : Type u} [comm_ring R₁] [module R₁ M] (f : linear_map R₁ M R₁) (g : linear_map R₁ M R₁) (h : linear_map R₁ M R₁) : lin_mul_lin (f + g) h = lin_mul_lin f h + lin_mul_lin g h :=
  ext fun (x : M) => add_mul (coe_fn f x) (coe_fn g x) (coe_fn h x)

@[simp] theorem lin_mul_lin_add {M : Type v} [add_comm_group M] {R₁ : Type u} [comm_ring R₁] [module R₁ M] (f : linear_map R₁ M R₁) (g : linear_map R₁ M R₁) (h : linear_map R₁ M R₁) : lin_mul_lin f (g + h) = lin_mul_lin f g + lin_mul_lin f h :=
  ext fun (x : M) => mul_add (coe_fn f x) (coe_fn g x) (coe_fn h x)

@[simp] theorem lin_mul_lin_comp {M : Type v} [add_comm_group M] {R₁ : Type u} [comm_ring R₁] [module R₁ M] {N : Type v} [add_comm_group N] [module R₁ N] (f : linear_map R₁ M R₁) (g : linear_map R₁ M R₁) (h : linear_map R₁ N M) : comp (lin_mul_lin f g) h = lin_mul_lin (linear_map.comp f h) (linear_map.comp g h) :=
  rfl

/-- `proj i j` is the quadratic form mapping the vector `x : n → R₁` to `x i * x j` -/
def proj {R₁ : Type u} [comm_ring R₁] {n : Type u_1} (i : n) (j : n) : quadratic_form R₁ (n → R₁) :=
  lin_mul_lin (linear_map.proj i) (linear_map.proj j)

@[simp] theorem proj_apply {R₁ : Type u} [comm_ring R₁] {n : Type u_1} (i : n) (j : n) (x : n → R₁) : coe_fn (proj i j) x = x i * x j :=
  rfl

end quadratic_form

/-!
### Associated bilinear forms

Over a commutative ring with an inverse of 2, the theory of quadratic forms is
basically identical to that of symmetric bilinear forms. The map from quadratic
forms to bilinear forms giving this identification is called the `associated`
quadratic form.
-/

namespace bilin_form

theorem polar_to_quadratic_form {R : Type u} {M : Type v} [add_comm_group M] [ring R] [module R M] {B : bilin_form R M} (x : M) (y : M) : quadratic_form.polar (fun (x : M) => coe_fn B x x) x y = coe_fn B x y + coe_fn B y x := sorry

/-- A bilinear form gives a quadratic form by applying the argument twice. -/
def to_quadratic_form {R : Type u} {M : Type v} [add_comm_group M] [ring R] [module R M] (B : bilin_form R M) : quadratic_form R M :=
  quadratic_form.mk (fun (x : M) => coe_fn B x x) sorry sorry sorry sorry sorry

@[simp] theorem to_quadratic_form_apply {R : Type u} {M : Type v} [add_comm_group M] [ring R] [module R M] (B : bilin_form R M) (x : M) : coe_fn (to_quadratic_form B) x = coe_fn B x x :=
  rfl

end bilin_form

namespace quadratic_form

/-- `associated` is the linear map that sends a quadratic form to its associated
symmetric bilinear form -/
def associated {M : Type v} [add_comm_group M] {R₁ : Type u} [comm_ring R₁] [module R₁ M] [invertible (bit0 1)] : linear_map R₁ (quadratic_form R₁ M) (bilin_form R₁ M) :=
  linear_map.mk
    (fun (Q : quadratic_form R₁ M) => bilin_form.mk (fun (x y : M) => ⅟ * polar (⇑Q) x y) sorry sorry sorry sorry) sorry
    sorry

@[simp] theorem associated_apply {M : Type v} [add_comm_group M] {R₁ : Type u} [comm_ring R₁] [module R₁ M] [invertible (bit0 1)] {Q : quadratic_form R₁ M} (x : M) (y : M) : coe_fn (coe_fn associated Q) x y = ⅟ * (coe_fn Q (x + y) - coe_fn Q x - coe_fn Q y) :=
  rfl

theorem associated_is_sym {M : Type v} [add_comm_group M] {R₁ : Type u} [comm_ring R₁] [module R₁ M] [invertible (bit0 1)] {Q : quadratic_form R₁ M} : sym_bilin_form.is_sym (coe_fn associated Q) := sorry

@[simp] theorem associated_comp {M : Type v} [add_comm_group M] {R₁ : Type u} [comm_ring R₁] [module R₁ M] [invertible (bit0 1)] {Q : quadratic_form R₁ M} {N : Type v} [add_comm_group N] [module R₁ N] (f : linear_map R₁ N M) : coe_fn associated (comp Q f) = bilin_form.comp (coe_fn associated Q) f f := sorry

@[simp] theorem associated_lin_mul_lin {M : Type v} [add_comm_group M] {R₁ : Type u} [comm_ring R₁] [module R₁ M] [invertible (bit0 1)] (f : linear_map R₁ M R₁) (g : linear_map R₁ M R₁) : coe_fn associated (lin_mul_lin f g) = ⅟ • (bilin_form.lin_mul_lin f g + bilin_form.lin_mul_lin g f) := sorry

theorem associated_to_quadratic_form {M : Type v} [add_comm_group M] {R₁ : Type u} [comm_ring R₁] [module R₁ M] [invertible (bit0 1)] (B : bilin_form R₁ M) (x : M) (y : M) : coe_fn (coe_fn associated (bilin_form.to_quadratic_form B)) x y = ⅟ * (coe_fn B x y + coe_fn B y x) := sorry

theorem associated_left_inverse {M : Type v} [add_comm_group M] {R₁ : Type u} [comm_ring R₁] [module R₁ M] [invertible (bit0 1)] {B₁ : bilin_form R₁ M} (h : sym_bilin_form.is_sym B₁) : coe_fn associated (bilin_form.to_quadratic_form B₁) = B₁ := sorry

theorem associated_right_inverse {M : Type v} [add_comm_group M] {R₁ : Type u} [comm_ring R₁] [module R₁ M] [invertible (bit0 1)] {Q : quadratic_form R₁ M} : bilin_form.to_quadratic_form (coe_fn associated Q) = Q := sorry

/-- An anisotropic quadratic form is zero only on zero vectors. -/
def anisotropic {R : Type u} {M : Type v} [add_comm_group M] [ring R] [module R M] (Q : quadratic_form R M) :=
  ∀ (x : M), coe_fn Q x = 0 → x = 0

theorem not_anisotropic_iff_exists {R : Type u} {M : Type v} [add_comm_group M] [ring R] [module R M] (Q : quadratic_form R M) : ¬anisotropic Q ↔ ∃ (x : M), ∃ (H : x ≠ 0), coe_fn Q x = 0 := sorry

/-- A positive definite quadratic form is positive on nonzero vectors. -/
def pos_def {M : Type v} [add_comm_group M] {R₂ : Type u} [ordered_ring R₂] [module R₂ M] (Q₂ : quadratic_form R₂ M) :=
  ∀ (x : M), x ≠ 0 → 0 < coe_fn Q₂ x

theorem pos_def.smul {M : Type v} [add_comm_group M] {R : Type u_1} [linear_ordered_comm_ring R] [module R M] {Q : quadratic_form R M} (h : pos_def Q) {a : R} (a_pos : 0 < a) : pos_def (a • Q) :=
  fun (x : M) (hx : x ≠ 0) => mul_pos a_pos (h x hx)

theorem pos_def.add {M : Type v} [add_comm_group M] {R₂ : Type u} [ordered_ring R₂] [module R₂ M] (Q : quadratic_form R₂ M) (Q' : quadratic_form R₂ M) (hQ : pos_def Q) (hQ' : pos_def Q') : pos_def (Q + Q') :=
  fun (x : M) (hx : x ≠ 0) => add_pos (hQ x hx) (hQ' x hx)

theorem lin_mul_lin_self_pos_def {M : Type v} [add_comm_group M] {R : Type u_1} [linear_ordered_comm_ring R] [module R M] (f : linear_map R M R) (hf : linear_map.ker f = ⊥) : pos_def (lin_mul_lin f f) := sorry

end quadratic_form

/-!
### Quadratic forms and matrices

Connect quadratic forms and matrices, in order to explicitly compute with them.
The convention is twos out, so there might be a factor 2⁻¹ in the entries of the
matrix.
The determinant of the matrix is the discriminant of the quadratic form.
-/

/-- `M.to_quadratic_form` is the map `λ x, col x ⬝ M ⬝ row x` as a quadratic form. -/
def matrix.to_quadratic_form' {R₁ : Type u} [comm_ring R₁] {n : Type w} [fintype n] [DecidableEq n] (M : matrix n n R₁) : quadratic_form R₁ (n → R₁) :=
  bilin_form.to_quadratic_form (coe_fn matrix.to_bilin' M)

/-- A matrix representation of the quadratic form. -/
def quadratic_form.to_matrix' {R₁ : Type u} [comm_ring R₁] {n : Type w} [fintype n] [DecidableEq n] [invertible (bit0 1)] (Q : quadratic_form R₁ (n → R₁)) : matrix n n R₁ :=
  coe_fn bilin_form.to_matrix' (coe_fn quadratic_form.associated Q)

theorem quadratic_form.to_matrix'_smul {R₁ : Type u} [comm_ring R₁] {n : Type w} [fintype n] [DecidableEq n] [invertible (bit0 1)] (a : R₁) (Q : quadratic_form R₁ (n → R₁)) : quadratic_form.to_matrix' (a • Q) = a • quadratic_form.to_matrix' Q := sorry

namespace quadratic_form

@[simp] theorem to_matrix'_comp {R₁ : Type u} [comm_ring R₁] {n : Type w} [fintype n] [DecidableEq n] [invertible (bit0 1)] {m : Type w} [DecidableEq m] [fintype m] (Q : quadratic_form R₁ (m → R₁)) (f : linear_map R₁ (n → R₁) (m → R₁)) : to_matrix' (comp Q f) =
  matrix.mul (matrix.mul (matrix.transpose (coe_fn linear_map.to_matrix' f)) (to_matrix' Q))
    (coe_fn linear_map.to_matrix' f) := sorry

/-- The discriminant of a quadratic form generalizes the discriminant of a quadratic polynomial. -/
def discr {R₁ : Type u} [comm_ring R₁] {n : Type w} [fintype n] [DecidableEq n] [invertible (bit0 1)] (Q : quadratic_form R₁ (n → R₁)) : R₁ :=
  matrix.det (to_matrix' Q)

theorem discr_smul {R₁ : Type u} [comm_ring R₁] {n : Type w} [fintype n] [DecidableEq n] [invertible (bit0 1)] {Q : quadratic_form R₁ (n → R₁)} (a : R₁) : discr (a • Q) = a ^ fintype.card n * discr Q := sorry

theorem discr_comp {R₁ : Type u} [comm_ring R₁] {n : Type w} [fintype n] [DecidableEq n] [invertible (bit0 1)] {Q : quadratic_form R₁ (n → R₁)} (f : linear_map R₁ (n → R₁) (n → R₁)) : discr (comp Q f) = matrix.det (coe_fn linear_map.to_matrix' f) * matrix.det (coe_fn linear_map.to_matrix' f) * discr Q := sorry

end quadratic_form

namespace quadratic_form

/-- An isometry between two quadratic spaces `M₁, Q₁` and `M₂, Q₂` over a ring `R`,
is a linear equivalence between `M₁` and `M₂` that commutes with the quadratic forms. -/
structure isometry {R : Type u} [ring R] {M₁ : Type u_1} {M₂ : Type u_2} [add_comm_group M₁] [add_comm_group M₂] [module R M₁] [module R M₂] (Q₁ : quadratic_form R M₁) (Q₂ : quadratic_form R M₂)
extends linear_equiv R M₁ M₂
where
  map_app' : ∀ (m : M₁), coe_fn Q₂ (linear_equiv.to_fun _to_linear_equiv m) = coe_fn Q₁ m

/-- Two quadratic forms over a ring `R` are equivalent
if there exists an isometry between them:
a linear equivalence that transforms one quadratic form into the other. -/
def equivalent {R : Type u} [ring R] {M₁ : Type u_1} {M₂ : Type u_2} [add_comm_group M₁] [add_comm_group M₂] [module R M₁] [module R M₂] (Q₁ : quadratic_form R M₁) (Q₂ : quadratic_form R M₂) :=
  Nonempty (isometry Q₁ Q₂)

namespace isometry

protected instance linear_equiv.has_coe {R : Type u} [ring R] {M₁ : Type u_1} {M₂ : Type u_2} [add_comm_group M₁] [add_comm_group M₂] [module R M₁] [module R M₂] {Q₁ : quadratic_form R M₁} {Q₂ : quadratic_form R M₂} : has_coe (isometry Q₁ Q₂) (linear_equiv R M₁ M₂) :=
  has_coe.mk to_linear_equiv

protected instance has_coe_to_fun {R : Type u} [ring R] {M₁ : Type u_1} {M₂ : Type u_2} [add_comm_group M₁] [add_comm_group M₂] [module R M₁] [module R M₂] {Q₁ : quadratic_form R M₁} {Q₂ : quadratic_form R M₂} : has_coe_to_fun (isometry Q₁ Q₂) :=
  has_coe_to_fun.mk (fun (_x : isometry Q₁ Q₂) => M₁ → M₂) fun (f : isometry Q₁ Q₂) => ⇑↑f

@[simp] theorem map_app {R : Type u} [ring R] {M₁ : Type u_1} {M₂ : Type u_2} [add_comm_group M₁] [add_comm_group M₂] [module R M₁] [module R M₂] {Q₁ : quadratic_form R M₁} {Q₂ : quadratic_form R M₂} (f : isometry Q₁ Q₂) (m : M₁) : coe_fn Q₂ (coe_fn f m) = coe_fn Q₁ m :=
  map_app' f m

/-- The identity isometry from a quadratic form to itself. -/
def refl {R : Type u} {M : Type v} [add_comm_group M] [ring R] [module R M] (Q : quadratic_form R M) : isometry Q Q :=
  mk
    (linear_equiv.mk (linear_equiv.to_fun (linear_equiv.refl R M)) sorry sorry
      (linear_equiv.inv_fun (linear_equiv.refl R M)) sorry sorry)
    sorry

/-- The inverse isometry of an isometry between two quadratic forms. -/
def symm {R : Type u} [ring R] {M₁ : Type u_1} {M₂ : Type u_2} [add_comm_group M₁] [add_comm_group M₂] [module R M₁] [module R M₂] {Q₁ : quadratic_form R M₁} {Q₂ : quadratic_form R M₂} (f : isometry Q₁ Q₂) : isometry Q₂ Q₁ :=
  mk
    (linear_equiv.mk (linear_equiv.to_fun (linear_equiv.symm ↑f)) sorry sorry
      (linear_equiv.inv_fun (linear_equiv.symm ↑f)) sorry sorry)
    sorry

/-- The composition of two isometries between quadratic forms. -/
def trans {R : Type u} [ring R] {M₁ : Type u_1} {M₂ : Type u_2} {M₃ : Type u_3} [add_comm_group M₁] [add_comm_group M₂] [add_comm_group M₃] [module R M₁] [module R M₂] [module R M₃] {Q₁ : quadratic_form R M₁} {Q₂ : quadratic_form R M₂} {Q₃ : quadratic_form R M₃} (f : isometry Q₁ Q₂) (g : isometry Q₂ Q₃) : isometry Q₁ Q₃ :=
  mk
    (linear_equiv.mk (linear_equiv.to_fun (linear_equiv.trans ↑f ↑g)) sorry sorry
      (linear_equiv.inv_fun (linear_equiv.trans ↑f ↑g)) sorry sorry)
    sorry

end isometry

namespace equivalent

theorem refl {R : Type u} {M : Type v} [add_comm_group M] [ring R] [module R M] (Q : quadratic_form R M) : equivalent Q Q :=
  Nonempty.intro (isometry.refl Q)

theorem symm {R : Type u} [ring R] {M₁ : Type u_1} {M₂ : Type u_2} [add_comm_group M₁] [add_comm_group M₂] [module R M₁] [module R M₂] {Q₁ : quadratic_form R M₁} {Q₂ : quadratic_form R M₂} (h : equivalent Q₁ Q₂) : equivalent Q₂ Q₁ :=
  nonempty.elim h fun (f : isometry Q₁ Q₂) => Nonempty.intro (isometry.symm f)

theorem trans {R : Type u} [ring R] {M₁ : Type u_1} {M₂ : Type u_2} {M₃ : Type u_3} [add_comm_group M₁] [add_comm_group M₂] [add_comm_group M₃] [module R M₁] [module R M₂] [module R M₃] {Q₁ : quadratic_form R M₁} {Q₂ : quadratic_form R M₂} {Q₃ : quadratic_form R M₃} (h : equivalent Q₁ Q₂) (h' : equivalent Q₂ Q₃) : equivalent Q₁ Q₃ :=
  nonempty.elim h' (nonempty.elim h fun (f : isometry Q₁ Q₂) (g : isometry Q₂ Q₃) => Nonempty.intro (isometry.trans f g))


-- 2. simply typed lambda calculus

import moromoro
import logic.basic

namespace stlc

inductive type : Type
| base : type
| arrow : type → type → type
open type

def type.repr : type → string
| base := "ι"
| (arrow t₁ t₂) := "(" ++ type.repr t₁ ++ " → " ++ type.repr t₂ ++ ")"

instance type_has_repr : has_repr type :=
⟨type.repr⟩

#eval (arrow (arrow base base) base)

----

variables ν : type → Type

inductive term : type → Type
| var : Π {t}, ν t → term t
| lam : Π {t₁ t₂}, (ν t₁ → term t₂) → term (arrow t₁ t₂)
| app : Π {t₁ t₂}, term (arrow t₁ t₂) → term t₁ → term t₂
open term

def Term (t : type) : Type 1 :=
Π ν, term ν t

variables {t t₁ t₂ t₃ : type}

def term.repr' : Π {t : type}, term (λ t, ℕ) t → ℕ → string
| _ (var n) _ := repr n
| _ (lam f) lv := "(λ" ++ repr lv ++ "." ++ term.repr' (f lv) (lv + 1) ++ ")"
| _ (app m₁ m₂) lv := "(" ++ term.repr' m₁ lv ++ " " ++ term.repr' m₂ lv ++ ")"

def term.repr : Term t → string :=
λ m, term.repr' (m _) 0 ++ " : " ++ repr t

instance Term_has_repr : has_repr (Term t) :=
⟨ term.repr ⟩

def nat : type := arrow (arrow base base) (arrow base base)

def zero : Term nat :=
λ ν, lam (λ f, lam (λ x, var x))

def succ : Term (arrow nat nat) :=
λ ν, lam (λ n, lam (λ f, lam (λ x, app (var f) (app (app (var n) (var f)) (var x)))))

def App : Term (arrow t₁ t₂) → Term t₁ → Term t₂ :=
λ m₁ m₂ ν, app (m₁ ν) (m₂ ν)

def succ_zero : Term nat :=
App succ zero

#eval zero
--> (λ0.(λ1.1)) : ((ι → ι) → (ι → ι))
#eval succ
--> (λ0.(λ1.(λ2.(1 ((0 1) 2))))) : (((ι → ι) → (ι → ι)) → ((ι → ι) → (ι → ι)))
#eval succ_zero
--> ((λ0.(λ1.(λ2.(1 ((0 1) 2))))) (λ0.(λ1.1))) : ((ι → ι) → (ι → ι))

-- -- // error!
-- def ω : Term _ := -- no such type
-- λ ν, lam (λ x, app (var x) (var x))

----

def domain : type → Type
| base := term ν base
| (arrow t₁ t₂) := domain t₁ → domain t₂

def Domain (t : type) : Type 1 :=
Π ν, domain ν t

def eval' : Π {t : type}, term (domain ν) t → domain ν t
| _ (var x) := x
| _ (lam f) := λ x, eval' (f x)
| _ (app m₁ m₂) := (eval' m₁) (eval' m₂)

def eval : Term t → Domain t :=
λ m ν, eval' ν (m _)

-- def nbe_wf : psum (Σ' {t : type}, domain ν t) (Σ' {t : type}, term ν t) → ℕ :=
-- λ v, match v with
-- | (psum.inl x) := sizeof x.fst
-- | (psum.inr x) := sizeof x.fst
-- end

-- mutual def reify, reflect
-- with reify : Π {t : type}, domain ν t → term ν t
-- | base ν := ν
-- | (arrow t₁ t₂) f := lam (λ x, reify (f (reflect (var x))))
-- with reflect : Π {t : type}, term ν t → domain ν t
-- | base m := m
-- | (arrow t₁ t₂) f := λ x, reflect (app f (reify x))
-- using_well_founded
-- { rel_tac := λ _ _, `[exact ⟨_, measure_wf (nbe_wf ν)⟩] }

def reify_reflect : Π (t : type), (domain ν t → term ν t) × (term ν t → domain ν t)
| base := ⟨ id, id ⟩
| (arrow t₁ t₂) :=
   let r₁ := reify_reflect t₁ in
   let r₂ := reify_reflect t₂ in
   let reify (f : domain ν t₁ → domain ν t₂) := lam (λ x, r₂.1 (f (r₁.2 (var x)))) in
   let reflect (f : term ν (arrow t₁ t₂)) := λ x, r₂.2 (app f (r₁.1 x)) in
   ⟨reify, reflect⟩

def reify : Domain t → Term t :=
λ x ν, (reify_reflect ν t).1 (x ν)

def normalize : Term t → Term t :=
reify ∘ eval

#eval normalize zero
#eval normalize (App succ zero)
#eval normalize (App succ (App succ zero))
#eval normalize (App succ (App succ (App succ zero)))

def i : Term (arrow (arrow base base) (arrow base base)) :=
λ ν, lam (λ f, var f)

#eval i
#eval normalize i

instance : setoid (Term t) :=
⟨inv_image eq normalize,
 inv_image.equivalence eq normalize eq_equivalence⟩

meta def canonicity : tactic unit :=
`[ try { unfold has_equiv.equiv setoid.r inv_image }, try { reflexivity } ]

def one : Term (arrow (arrow base base) (arrow base base)) :=
λ ν, lam (λ f, lam (λ x, app (var f) (var x)))

lemma zero_eqv_zero : zero ≈ zero :=
by canonicity

lemma succ_zero_eqv_one : App succ zero ≈ one :=
by canonicity

----

variable {α : Type}

inductive mem : α → list α → Type
| here : Π {x l}, mem x (x :: l)
| there : Π {x l y}, mem x l → mem x (y :: l)
open mem

local infix ` ∈' `:50 := mem

inductive judgment₁ : list type → type → Type
| var : Π {Γ t}, t ∈' Γ → judgment₁ Γ t
| lam : Π {Γ t₁ t₂}, judgment₁ (t₁ :: Γ) t₂ → judgment₁ Γ (arrow t₁ t₂)
| app : Π {Γ t₁ t₂}, judgment₁ Γ (arrow t₁ t₂) → judgment₁ Γ t₁ → judgment₁ Γ t₂
open judgment₁

variables {Γ Γ₁ Γ₂ : list type}

def judgment₁.repr' : Π {Γ t}, judgment₁ Γ t → string
| Γ _ (var h) := repr $ Γ.length - 1 - (h.rec_on (λ _ _, 0) (λ _ _ _ _ (n : ℕ), n + 1))
| Γ _ (lam m) := "(λ" ++ repr Γ.length ++ "." ++ judgment₁.repr' m ++ ")"
| _ _ (app m₁ m₂) := "(" ++ judgment₁.repr' m₁ ++ " " ++ judgment₁.repr' m₂ ++ ")"

def judgment₁.repr : Π {Γ t}, judgment₁ Γ t → string :=
λ Γ t m,
let env := (Γ.foldr (λ t p, prod.mk (prod.mk p.2 t :: p.1) (p.2 + 1)) (prod.mk [] 0)).1 in
let assigns := list.map (λ p, repr (prod.fst p) ++ " : " ++ repr (prod.snd p)) env in
string.intercalate ", " assigns ++ " ⊢ " ++ judgment₁.repr' m ++ " : " ++ repr t

instance : has_to_string (judgment₁ Γ t) :=
⟨judgment₁.repr⟩

-- x₁ : ι → ι, x₀ : ι ⊢ λ y, x₀ : (ι → ι) → ι
def ex1 : judgment₁ [arrow base base, base] (arrow (arrow base base) base) :=
lam (var (there (there here)))

#eval ex1 -- "1 : (ι → ι), 0 : ι ⊢ (λ2.0) : ((ι → ι) → ι)"

----

inductive perm : list α → list α → Type -- proof relevant version
| nil   : perm [] []
| skip  : Π {x : α} {l₁ l₂ : list α}, perm l₁ l₂ → perm (x :: l₁) (x :: l₂)
| swap  : Π {x y : α} {l : list α}, perm (y :: x :: l) (x :: y :: l)
| trans : Π {l₁ l₂ l₃ : list α}, perm l₁ l₂ → perm l₂ l₃ → perm l₁ l₃

local infix ~ := perm

def mem_perm {t : α} : Π {Γ₁ Γ₂}, Γ₁ ~ Γ₂ → t ∈' Γ₁ → t ∈' Γ₂
| _ _ perm.nil h := h
| _ _ (perm.skip _) here := here
| _ _ (perm.skip p) (there h) := there (mem_perm p h)
| _ _ perm.swap here := there here
| _ _ perm.swap (there here) := here
| _ _ perm.swap (there (there h)) := there (there h)
| _ _ (perm.trans p₁ p₂) h := mem_perm p₂ (mem_perm p₁ h)

namespace judgment₁

def xchg : Π {Γ₁ Γ₂ t}, (Γ₁ ~ Γ₂) → judgment₁ Γ₁ t → judgment₁ Γ₂ t
| _ _ _ p (var h) := var (mem_perm p h)
| _ _ _ p (lam m) := lam (xchg (perm.skip p) m)
| _ _ _ p (app m₁ m₂) := app (xchg p m₁) (xchg p m₂)

def weak : Π {Γ t₁ t₂}, judgment₁ Γ t₁ → judgment₁ (t₂ :: Γ) t₁
| _ _ _ (var h) := var (there h)
| _ _ _ (lam m) := lam (xchg perm.swap (weak m))
| _ _ _ (app m₁ m₂) := app (weak m₁) (weak m₂)

def heightof : Π {Γ t}, judgment₁ Γ t → ℕ
| _ _ (var h) := 1
| _ _ (lam m) := 1 + heightof m
| _ _ (app m₁ m₂) := 1 + max (heightof m₁) (heightof m₂)

lemma height_xchg_eq_height {m : judgment₁ Γ₁ t} : Π {Γ₂} {p : Γ₁ ~ Γ₂}, heightof (xchg p m) = heightof m :=
begin
  induction m with _ _ _ _ _ _ _ ih₁ _ _ _ _ _ ih₂ ih₃,
  { intros, refl },
  { intros, unfold xchg heightof, rw ih₁ },
  { intros, unfold xchg heightof, rw [ih₂, ih₃] }
end

def subst : Π {Γ t₁ t₂}, judgment₁ (t₁ :: Γ) t₂ → judgment₁ Γ t₁ → judgment₁ Γ t₂
| _ _ _ (var here) m := m
| _ _ _ (var (there h)) m := var h
| _ _ _ (app m₁ m₂) m :=
  have heightof m₁ < heightof (app m₁ m₂),
    by unfold heightof; rw add_comm;
    from lt_add_of_le_of_pos (le_max_left _ _) zero_lt_one,
  have heightof m₂ < heightof (app m₁ m₂),
    by unfold heightof; rw add_comm;
    from lt_add_of_le_of_pos (le_max_right _ _) zero_lt_one,
  app (subst m₁ m) (subst m₂ m)
| _ _ _ (lam m₁) m :=
  have heightof (xchg perm.swap m₁) < heightof (lam m₁),
    by unfold heightof; rw height_xchg_eq_height;
    from lt_add_of_pos_of_le zero_lt_one (le_refl _),
  lam (subst (xchg perm.swap m₁) (weak m))
using_well_founded
{ rel_tac := λ _ _, `[exact ⟨_, measure_wf (λ v, heightof v.snd.snd.snd.fst)⟩] }

def contr : judgment₁ (t₁ :: t₁ :: Γ) t₂ → judgment₁ (t₁ :: Γ) t₂ :=
λ m, subst m (var here)

def abs : judgment₁ (t₁ :: Γ) t₂ → judgment₁ Γ (arrow t₁ t₂) :=
lam

def antiabs : judgment₁ Γ (arrow t₁ t₂) → judgment₁ (t₁ :: Γ) t₂ :=
λ m, app (weak m) (var here)

end judgment₁

----

def type.foldl : list type → type → type :=
λ Γ t, list.foldl (λ r t, arrow t r) t Γ

#eval type.foldl [arrow base base, base] base -- "(ι → ((ι → ι) → ι))"

namespace judgment₁

inductive env : list type → Type
| nil {} : env []
| step : Π {t Γ}, ν t → env Γ →  env (t :: Γ)

def to_term_var : Π {Γ t}, t ∈' Γ → env ν Γ → term ν t
| (_ :: Γ) _ here (env.step x _) := term.var x
| (_ :: Γ) _ (there h) (env.step _ Δ) := to_term_var h Δ

def to_term' : Π {Γ t}, judgment₁ Γ t → env ν Γ → term ν t
| _ _ (var h) Δ := to_term_var ν h Δ
| _ _ (lam m) Δ := term.lam (λ x, to_term' m (env.step x Δ))
| _ _ (app m₁ m₂) Δ := term.app (to_term' m₁ Δ) (to_term' m₂ Δ)

def foldl : Π {Γ t}, judgment₁ Γ t → judgment₁ [] (type.foldl Γ t)
| [] _ m := m
| (t :: Γ) _ m := foldl (lam m)

def to_term : judgment₁ Γ t → Term (type.foldl Γ t) :=
λ m ν, to_term' ν (foldl m) env.nil

end judgment₁

----

variables {ν₁ ν₂ : type → Type}

inductive wf : list (Σ t, ν₁ t × ν₂ t) → Π {t}, term ν₁ t → term ν₂ t → Type
| var : Π {Γ t} {x₁ : ν₁ t} {x₂ : ν₂ t}, sigma.mk t (prod.mk x₁ x₂) ∈' Γ → wf Γ (var x₁) (var x₂)
| lam : Π {Γ t₁ t₂} {f₁ : ν₁ t₁ → term ν₁ t₂} {f₂ : ν₂ t₁ → term ν₂ t₂}, (Π x₁ x₂, wf (⟨t₁, x₁, x₂⟩ :: Γ) (f₁ x₁) (f₂ x₂)) → wf Γ (lam f₁) (lam f₂)
| app : Π {Γ t₁ t₂} {m₁ : term ν₁ (arrow t₁ t₂)} {m₂ : term ν₂ (arrow t₁ t₂)} {n₁ : term ν₁ t₁} {n₂ : term ν₂ t₁}, wf Γ m₁ m₂ → wf Γ n₁ n₂ → wf Γ (app m₁ n₁) (app m₂ n₂)

def WF (t : type) (m : Term t) : Type 1 :=
Π ν₁ ν₂, wf [] (m ν₁) (m ν₂)

constant term_wf : Π t m, WF t m

def to_judgment₁_var : Π {Γ t} {x₁ : ν₁ t} {x₂ : ν₂ t}, (sigma.mk t (prod.mk x₁ x₂)) ∈' Γ → t ∈' (list.map (λ x, sigma.fst x) Γ)
| _ _ _ _ here := here
| _ _ _ _ (there h) := there (to_judgment₁_var h)

def to_judgment₁' : Π {Γ t} {m₁ : term (λ x, unit) t} {m₂ : term (λ x, unit) t}, wf Γ m₁ m₂ → judgment₁ (list.map (λ x, sigma.fst x) Γ) t
| _ _ _ _ (wf.var h) := var (to_judgment₁_var h)
| _ _ _ _ (wf.lam f) := lam (to_judgment₁' (f () ()))
| _ _ _ _ (wf.app m₁ m₂) := app (to_judgment₁' m₁) (to_judgment₁' m₂)

noncomputable def to_judgment₁ : Term t → judgment₁ [] t :=
λ m, to_judgment₁' (term_wf _ m _ _)

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

-- def judgment0 (t : type) := Π ν, term ν t
-- def judgment1 (t₁ t₂ : type) := Π ν, ν t₁ → term ν t₂ -- term with one free variable

def judgment₂ : list type → type → Type :=
λ Γ t, list.foldr (λ t α, ν t → α) (term ν t) Γ

def Judgment₂ (Γ : list type) (t : type) : Type 1 := -- Type 1
Π ν, judgment₂ ν Γ t

#reduce Judgment₂ [] base           -- Π ν, term ν base
#reduce Judgment₂ [base] base       -- Π ν, ν base → term ν base
#reduce Judgment₂ [base, base] base -- Π ν, ν base → ν base → term ν base
#reduce Judgment₂ [base, arrow base base] base -- Π ν, ν base → ν (arrow base base) → term ν base

def judgment₂.repr' : Π {Γ}, judgment₂ (λ t, ℕ) Γ t → ℕ → string
| [] m lv := "⊢ " ++ term.repr' m lv
| (t :: Γ) f lv := "(" ++ repr lv ++ " : " ++ repr t ++ ") " ++ judgment₂.repr' (f lv) (lv + 1)

def judgment₂.repr : Judgment₂ Γ t → string :=
λ m, judgment₂.repr' (m _) 0 ++ " : " ++ repr t

instance Judgment₂_has_repr : has_repr (Judgment₂ Γ t) :=
⟨judgment₂.repr⟩

-- x₁ : ι → ι, x₂ : ι ⊢ (λ y : ι, x₂) : ι → ι
def ex2 : Judgment₂ [arrow base base, base] (arrow base base) :=
λ ν, λ x₁ x₂, lam (λ y, var x₂)

#eval ex2 -- "(0 : (ι → ι)) (1 : ι) ⊢ (λ2.1) : (ι → ι)"

-----

def subst' : Π {t}, term (term ν) t → term ν t
| _ (var m) := m
| _ (lam f) := lam (λ x, subst' (f (var x)))
| _ (app m₁ m₂) := app (subst' m₁) (subst' m₂)

namespace judgment₂

def weak : Judgment₂ Γ t₂ → Judgment₂ (t₁ :: Γ) t₂ :=
λ m ν x, m ν

def xchg' : Π {Γ₁ Γ₂}, (Γ₁ ~ Γ₂) → judgment₂ ν Γ₁ t → judgment₂ ν Γ₂ t
| _ _ perm.nil m := m
| _ _ (perm.skip h) m := λ x, xchg' h (m x)
| _ _ perm.swap m := λ x₁ x₂, m x₂ x₁
| _ _ (perm.trans h₁ h₂) m := xchg' h₂ (xchg' h₁ m)

def xchg : (Γ₁ ~ Γ₂) → Judgment₂ Γ₁ t → Judgment₂ Γ₂ t :=
λ h m ν, xchg' ν h (m ν)

def subst'' : Π {Γ}, judgment₂ (term ν) (t₁ :: Γ) t₂ → judgment₂ ν Γ t₁ → judgment₂ ν Γ t₂
| [] m₁ m₂ := subst' ν (m₁ m₂)
| (t :: Γ) f m := λ x, subst'' (λ x', f x' (var x)) (m x)

def subst : Judgment₂ (t₁ :: Γ) t₂ → Judgment₂ Γ t₁ → Judgment₂ Γ t₂ :=
λ m₁ m₂ ν, subst'' ν (m₁ _) (m₂ ν)

def lam' : Π {Γ}, judgment₂ ν (t₁ :: Γ) t₂ → judgment₂ ν Γ (arrow t₁ t₂)
| [] m := lam (λ x, m x)
| (t :: Γ) f := λ x, lam' (λ y, f y x)

def lam : Judgment₂ (t₁ :: Γ) t₂ → Judgment₂ Γ (arrow t₁ t₂) :=
λ m ν, lam' ν (m ν)

def app' : Π {Γ}, judgment₂ ν Γ (arrow t₁ t₂) → judgment₂ ν Γ t₁ → judgment₂ ν Γ t₂
| [] m₁ m₂ := app m₁ m₂
| (t :: Γ) f m := λ x, app' (f x) (m x)

def app : Judgment₂ Γ (arrow t₁ t₂) → Judgment₂ Γ t₁ → Judgment₂ Γ t₂ :=
λ m₁ m₂ ν, app' ν (m₁ ν) (m₂ ν)

def var' : Π {Γ}, judgment₂ ν (t :: Γ) t
| [] := λ x, var x
| (t :: Γ) := λ x y, var' x

def var : Π {Γ}, t ∈' Γ → Judgment₂ Γ t
| _ here := λ ν, var' ν
| _ (there h) := weak (var h)

def contr : Judgment₂ (t₁ :: t₁ :: Γ) t₂ → Judgment₂ (t₁ :: Γ) t₂ := -- same as judgment₁.contr
λ m, subst m (var here)

def nonfree (m : Judgment₂ (t₁ :: Γ) t₂) : Prop :=
∃ m', m = weak m' -- ∃ m', ∀ ν, (λ x, (m ν) x) = (λ x, (m' ν))

-- lemma nonfree_var_lem (m : Judgment₂ (t₁ :: Γ) t₂)
-- : nonfree m ↔ ∃ (m' : Judgment₂ Γ t₂), ∀ ν, (λ x, (m ν) x) = (λ x, (m' ν)) :=
-- begin
--   unfold nonfree,
--   split,
--   { intro h,
--     induction h,
--     existsi h_w,
--     intro ν,
--     rw h_h,
--     refl },
--   { intro h,
--     induction h,
--     existsi h_w,
--     apply funext h_h }
-- end

end judgment₂

----

def to_term : Judgment₂ [] t → Term t :=
id

def to_judgment₂ : Term t → Judgment₂ [] t :=
id

def type.foldr : list type → type → type :=
λ Γ t, list.foldr arrow t Γ

namespace judgment₂

def abs' : Π {Γ}, judgment₂ ν Γ t → judgment₂ ν [] (type.foldr Γ t)
| [] m := m
| (t :: Γ) f := term.lam (λ x, abs' (f x))

def abs : Judgment₂ Γ t → Term (type.foldr Γ t) :=
λ m ν, abs' ν (m ν)

def antiabs' : Π {Γ}, judgment₂ (term ν) [] (type.foldr Γ t) → judgment₂ ν Γ t
| [] m := subst' ν m
| (t :: Γ) m :=
  match m with
  | (term.var x) := λ x, antiabs' (term.app m (term.var (term.var x)))
  | (term.lam f) := λ x, antiabs' (f (term.var x))
  | (term.app m₁ m₂) := λ x, antiabs' (term.app m (term.var (term.var x)))
  end

def antiabs : Judgment₂ [] (type.foldr Γ t) → Judgment₂ Γ t :=
λ m ν, antiabs' ν (m _)

end judgment₂

instance Judgment₂.setoid : setoid (Judgment₂ Γ t) :=
⟨inv_image eq (normalize ∘ to_term ∘ judgment₂.abs),
 inv_image.equivalence eq (normalize ∘ to_term ∘ judgment₂.abs) eq_equivalence⟩

def zero' : Judgment₂ [] (arrow (arrow base base) (arrow base base)) :=
(judgment₂.antiabs ∘ to_judgment₂) zero

def one' : Judgment₂ [] (arrow (arrow base base) (arrow base base)) :=
(judgment₂.antiabs ∘ to_judgment₂) one

def succ' : Judgment₂ [] (arrow (arrow (arrow base base) (arrow base base)) (arrow (arrow base base) (arrow base base))) :=
(judgment₂.antiabs ∘ to_judgment₂) succ

lemma zero_approx_zero : zero' ≈ zero' :=
by canonicity

lemma succ_zero_approx_one : judgment₂.app succ' zero' ≈ one' :=
by canonicity

end stlc


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import data.option.basic

/-!
# Binary map of options

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

This file defines the binary map of `option`. This is mostly useful to define pointwise operations
on intervals.

## Main declarations

* `option.map₂`: Binary map of options.

## Notes

This file is very similar to `data.set.n_ary`, `data.finset.n_ary` and `order.filter.n_ary`. Please
keep them in sync.

We do not define `option.map₃` as its only purpose so far would be to prove properties of
`option.map₂` and casing already fulfills this task.
-/

open function

namespace option
variables {α α' β β' γ γ' δ δ' ε ε' : Type*} {f : α → β → γ} {a : option α} {b : option β}
  {c : option γ}

/-- The image of a binary function `f : α → β → γ` as a function `option α → option β → option γ`.
Mathematically this should be thought of as the image of the corresponding function `α × β → γ`. -/
def map₂ (f : α → β → γ) (a : option α) (b : option β) : option γ := a.bind $ λ a, b.map $ f a

/-- `option.map₂` in terms of monadic operations. Note that this can't be taken as the definition
because of the lack of universe polymorphism. -/
lemma map₂_def {α β γ : Type*} (f : α → β → γ) (a : option α) (b : option β) :
  map₂ f a b = f <$> a <*> b := by cases a; refl

@[simp] lemma map₂_some_some (f : α → β → γ) (a : α) (b : β) :
  map₂ f (some a) (some b) = some (f a b) :=
rfl

lemma map₂_coe_coe (f : α → β → γ) (a : α) (b : β) : map₂ f a b = f a b := rfl
@[simp] lemma map₂_none_left (f : α → β → γ) (b : option β) : map₂ f none b = none := rfl
@[simp] lemma map₂_none_right (f : α → β → γ) (a : option α) : map₂ f a none = none :=
by cases a; refl
@[simp] lemma map₂_coe_left (f : α → β → γ) (a : α) (b : option β) :
  map₂ f a b = b.map (λ b, f a b) := rfl
@[simp] lemma map₂_coe_right (f : α → β → γ) (a : option α) (b : β) :
  map₂ f a b = a.map (λ a, f a b) := rfl

@[simp] lemma mem_map₂_iff {c : γ} : c ∈ map₂ f a b ↔ ∃ a' b', a' ∈ a ∧ b' ∈ b ∧ f a' b' = c :=
by simp [map₂]

@[simp] lemma map₂_eq_none_iff : map₂ f a b = none ↔ a = none ∨ b = none :=
by cases a; cases b; simp

lemma map₂_swap (f : α → β → γ) (a : option α) (b : option β) :
  map₂ f a b = map₂ (λ a b, f b a) b a :=
by cases a; cases b; refl

lemma map_map₂ (f : α → β → γ) (g : γ → δ) : (map₂ f a b).map g = map₂ (λ a b, g (f a b)) a b :=
by cases a; cases b; refl

lemma map₂_map_left (f : γ → β → δ) (g : α → γ) :
  map₂ f (a.map g) b = map₂ (λ a b, f (g a) b) a b :=
by cases a; refl

lemma map₂_map_right (f : α → γ → δ) (g : β → γ) :
  map₂ f a (b.map g) = map₂ (λ a b, f a (g b)) a b :=
by cases b; refl

@[simp] lemma map₂_curry (f : α × β → γ) (a : option α) (b : option β) :
  map₂ (curry f) a b = option.map f (map₂ prod.mk a b) := (map_map₂ _ _).symm

@[simp] lemma map_uncurry (f : α → β → γ) (x : option (α × β)) :
  x.map (uncurry f) = map₂ f (x.map prod.fst) (x.map prod.snd) := by cases x; refl

/-!
### Algebraic replacement rules

A collection of lemmas to transfer associativity, commutativity, distributivity, ... of operations
to the associativity, commutativity, distributivity, ... of `option.map₂` of those operations.
The proof pattern is `map₂_lemma operation_lemma`. For example, `map₂_comm mul_comm` proves that
`map₂ (*) a b = map₂ (*) g f` in a `comm_semigroup`.
-/

lemma map₂_assoc {f : δ → γ → ε} {g : α → β → δ} {f' : α → ε' → ε} {g' : β → γ → ε'}
  (h_assoc : ∀ a b c, f (g a b) c = f' a (g' b c)) :
  map₂ f (map₂ g a b) c = map₂ f' a (map₂ g' b c) :=
by cases a; cases b; cases c; simp [h_assoc]

lemma map₂_comm {g : β → α → γ} (h_comm : ∀ a b, f a b = g b a) : map₂ f a b = map₂ g b a :=
by cases a; cases b; simp [h_comm]

lemma map₂_left_comm {f : α → δ → ε} {g : β → γ → δ} {f' : α → γ → δ'} {g' : β → δ' → ε}
  (h_left_comm : ∀ a b c, f a (g b c) = g' b (f' a c)) :
  map₂ f a (map₂ g b c) = map₂ g' b (map₂ f' a c) :=
by cases a; cases b; cases c; simp [h_left_comm]

lemma map₂_right_comm {f : δ → γ → ε} {g : α → β → δ} {f' : α → γ → δ'} {g' : δ' → β → ε}
  (h_right_comm : ∀ a b c, f (g a b) c = g' (f' a c) b) :
  map₂ f (map₂ g a b) c = map₂ g' (map₂ f' a c) b :=
by cases a; cases b; cases c; simp [h_right_comm]

lemma map_map₂_distrib {g : γ → δ} {f' : α' → β' → δ} {g₁ : α → α'} {g₂ : β → β'}
  (h_distrib : ∀ a b, g (f a b) = f' (g₁ a) (g₂ b)) :
  (map₂ f a b).map g = map₂ f' (a.map g₁) (b.map g₂) :=
by cases a; cases b; simp [h_distrib]

/-!
The following symmetric restatement are needed because unification has a hard time figuring all the
functions if you symmetrize on the spot. This is also how the other n-ary APIs do it.
-/

/-- Symmetric statement to `option.map₂_map_left_comm`. -/

/-- Symmetric statement to `option.map_map₂_right_comm`. -/
lemma map_map₂_distrib_right {g : γ → δ} {f' : α → β' → δ} {g' : β → β'}
  (h_distrib : ∀ a b, g (f a b) = f' a (g' b)) :
  (map₂ f a b).map g = map₂ f' a (b.map g') :=
by cases a; cases b; simp [h_distrib]

/-- Symmetric statement to `option.map_map₂_distrib_left`. -/
lemma map₂_map_left_comm {f : α' → β → γ} {g : α → α'} {f' : α → β → δ} {g' : δ → γ}
  (h_left_comm : ∀ a b, f (g a) b = g' (f' a b)) :
  map₂ f (a.map g) b = (map₂ f' a b).map g' :=
by cases a; cases b; simp [h_left_comm]

/-- Symmetric statement to `option.map_map₂_distrib_right`. -/
lemma map_map₂_right_comm {f : α → β' → γ} {g : β → β'} {f' : α → β → δ} {g' : δ → γ}
  (h_right_comm : ∀ a b, f a (g b) = g' (f' a b)) :
  map₂ f a (b.map g) = (map₂ f' a b).map g' :=
by cases a; cases b; simp [h_right_comm]

lemma map_map₂_antidistrib {g : γ → δ} {f' : β' → α' → δ} {g₁ : β → β'} {g₂ : α → α'}
  (h_antidistrib : ∀ a b, g (f a b) = f' (g₁ b) (g₂ a)) :
  (map₂ f a b).map g = map₂ f' (b.map g₁) (a.map g₂) :=
by cases a; cases b; simp [h_antidistrib]

/-- Symmetric statement to `option.map₂_map_left_anticomm`. -/
lemma map_map₂_antidistrib_left {g : γ → δ} {f' : β' → α → δ} {g' : β → β'}
  (h_antidistrib : ∀ a b, g (f a b) = f' (g' b) a) :
  (map₂ f a b).map g = map₂ f' (b.map g') a :=
by cases a; cases b; simp [h_antidistrib]

/-- Symmetric statement to `option.map_map₂_right_anticomm`. -/
lemma map_map₂_antidistrib_right {g : γ → δ} {f' : β → α' → δ} {g' : α → α'}
  (h_antidistrib : ∀ a b, g (f a b) = f' b (g' a)) :
  (map₂ f a b).map g = map₂ f' b (a.map g') :=
by cases a; cases b; simp [h_antidistrib]

/-- Symmetric statement to `option.map_map₂_antidistrib_left`. -/
lemma map₂_map_left_anticomm {f : α' → β → γ} {g : α → α'} {f' : β → α → δ} {g' : δ → γ}
  (h_left_anticomm : ∀ a b, f (g a) b = g' (f' b a)) :
  map₂ f (a.map g) b = (map₂ f' b a).map g' :=
by cases a; cases b; simp [h_left_anticomm]

/-- Symmetric statement to `option.map_map₂_antidistrib_right`. -/
lemma map_map₂_right_anticomm {f : α → β' → γ} {g : β → β'} {f' : β → α → δ} {g' : δ → γ}
  (h_right_anticomm : ∀ a b, f a (g b) = g' (f' b a)) :
  map₂ f a (b.map g) = (map₂ f' b a).map g' :=
by cases a; cases b; simp [h_right_anticomm]

/-- If `a` is a left identity for a binary operation `f`, then `some a` is a left identity for
`option.map₂ f`. -/
lemma map₂_left_identity {f : α → β → β} {a : α} (h : ∀ b, f a b = b) (o : option β) :
  map₂ f (some a) o = o :=
by { cases o, exacts [rfl, congr_arg some (h _)] }

/-- If `b` is a right identity for a binary operation `f`, then `some b` is a right identity for
`option.map₂ f`. -/
lemma map₂_right_identity {f : α → β → α} {b : β} (h : ∀ a, f a b = a) (o : option α) :
  map₂ f o (some b) = o :=
by simp [h, map₂]

end option


import Mt.Utils.List
import Mt.Utils.Nat

namespace Mt.Utils

theorem forall_ext {α : Type} {f g : α -> Prop}
  (h : ∀ a : α, f a = g a) : (∀ a : α, f a) = (∀ a : α, g a) :=by
  apply propext
  constructor <;> intro h' a
  . exact Eq.mp (h a) (h' a)
  . exact Eq.mpr (h a) (h' a)

end Mt.Utils


/-
Copyright (c) 2023 María Inés de Frutos-Fernández. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: María Inés de Frutos-Fernández
-/
import from_mathlib.pow_mult_faithful
import from_mathlib.seminorm_from_const
import from_mathlib.spectral_norm
import analysis.normed_space.finite_dimension
import topology.algebra.module.finite_dimension

/-!
# Unique norm extension theorem

Let `K` be a field complete with respect to a nontrivial nonarchimedean multiplicative norm and
`L/K` be an algebraic extension. We show that the spectral norm on `L` is a nonarchimedean
multiplicative norm, and any power-multiplicative `K`-algebra norm on `L` coincides with the
spectral norm. More over, if `L/K` is finite, then `L` is a complete space.
This result is [BGR, Theorem 3.2.4/2].

## Main Definitions

* `spectral_mul_alg_norm` : the spectral norm is a multiplicative `K`-algebra norm on `L`.

## Main Results
* `spectral_norm_unique'` : any power-multiplicative `K`-algebra norm on `L` coincides with the
  spectral norm.
* `spectral_norm_is_mul` : the spectral norm on `L` is multiplicative.
* `spectral_norm_complete_space` : if `L/K` is finite dimensional, then `L` is a complete space
  with respect to topology induced by the spectral norm.

## References
* [S. Bosch, U. Güntzer, R. Remmert, *Non-Archimedean Analysis*][bosch-guntzer-remmert]

## Tags

spectral, spectral norm, unique, seminorm, norm, nonarchimedean
-/

noncomputable theory

open_locale nnreal

variables {K : Type*} [nontrivially_normed_field K] {L : Type*} [field L] [algebra K L]
  (h_alg : algebra.is_algebraic K L)

/--If `K` is a field complete with respect to a nontrivial nonarchimedean multiplicative norm and
  `L/K` is an algebraic extension, then any power-multiplicative `K`-algebra norm on `L` coincides
  with the spectral norm. -/
lemma spectral_norm_unique' [complete_space K] {f : algebra_norm K L} (hf_pm : is_pow_mul f)
  (hna : is_nonarchimedean (norm : K → ℝ)) : f = spectral_alg_norm h_alg hna :=
begin
  apply eq_of_pow_mult_faithful f hf_pm _
    (spectral_alg_norm_is_pow_mul h_alg hna),
  intro x,
  set E : Type* := id K⟮x⟯ with hEdef,
  letI hE : field E := (by rw [hEdef, id.def] ; apply_instance),
  letI : algebra K E := K⟮x⟯.algebra,
  set id1 : K⟮x⟯ →ₗ[K] E :=
  { to_fun := id,
    map_add' := λ x y, rfl,
    map_smul' := λ r x, rfl, },
  set id2 : E →ₗ[K] K⟮x⟯ :=
  { to_fun := id,
    map_add' := λ x y, rfl,
    map_smul' := λ r x, rfl },
  set hs_norm : ring_norm E :=
  { to_fun    := (λ y : E, spectral_norm K L (id2 y : L)),
    map_zero' := by rw [map_zero, subfield.coe_zero, spectral_norm_zero],
    add_le'   := λ a b,
    by simp only [← spectral_alg_norm_def h_alg hna, subfield.coe_add]; exact map_add_le_add _ _ _,
    neg'      := λ a,
    by simp only [← spectral_alg_norm_def h_alg hna, subfield.coe_neg, map_neg, map_neg_eq_map],
    mul_le'  := λ a b,
    by simp only [← spectral_alg_norm_def h_alg hna, subfield.coe_mul]; exact map_mul_le_mul _ _ _,
    eq_zero_of_map_eq_zero' := λ a ha,
    begin
      simp only [←spectral_alg_norm_def h_alg hna, linear_map.coe_mk, id.def,
        map_eq_zero_iff_eq_zero, algebra_map.lift_map_eq_zero_iff] at ha,
      exact ha
    end },
  letI n1 : normed_ring E := norm_to_normed_ring hs_norm,
  letI N1 : normed_space K E :=
  { norm_smul_le := λ k y,
    begin
      change (spectral_alg_norm h_alg hna (id2 (k • y) : L) : ℝ) ≤
        ‖ k ‖ * spectral_alg_norm h_alg hna (id2 y : L),
      simp only [linear_map.coe_mk, id.def, intermediate_field.coe_smul, map_smul_eq_mul],
    end,
    ..K⟮x⟯.algebra },
  set hf_norm : ring_norm K⟮x⟯ :=
  { to_fun := λ y, f((algebra_map K⟮x⟯ L) y),
    map_zero' := map_zero _,
    add_le'  := λ a b, map_add_le_add _ _ _,
    neg' := λ y, by { simp only [map_neg, map_neg_eq_map] },
    mul_le'  := λ a b, map_mul_le_mul _ _ _,
    eq_zero_of_map_eq_zero' := λ a ha,
    begin
      simp only [map_eq_zero_iff_eq_zero, map_eq_zero] at ha,
      exact ha
    end },
  letI n2 : normed_ring K⟮x⟯ := norm_to_normed_ring hf_norm,
  letI N2 : normed_space K K⟮x⟯ :=
  { norm_smul_le :=  λ k y,
    begin
      change (f ((algebra_map K⟮x⟯ L) (k • y)) : ℝ) ≤ ‖ k ‖ * f (algebra_map K⟮x⟯ L y),
      have : (algebra_map ↥K⟮x⟯ L) (k • y) = k • (algebra_map ↥K⟮x⟯ L y),
      { rw [← is_scalar_tower.algebra_map_smul K⟮x⟯ k y, smul_eq_mul, map_mul,
          ← is_scalar_tower.algebra_map_apply K ↥K⟮x⟯ L, algebra.smul_def] },
      rw [ this, map_smul_eq_mul],
    end,
    ..K⟮x⟯.algebra },
  haveI hKx_fin : finite_dimensional K ↥K⟮x⟯ := intermediate_field.adjoin.finite_dimensional
    (is_algebraic_iff_is_integral.mp (h_alg x)),
  haveI : finite_dimensional K E := hKx_fin,
  set Id1 : K⟮x⟯ →L[K] E := ⟨id1, id1.continuous_of_finite_dimensional⟩ with hId1,
  set Id2 : E →L[K] K⟮x⟯ := ⟨id2, id2.continuous_of_finite_dimensional⟩ with hId2,
  have hC1 : ∃ (C1 : ℝ), 0 < C1 ∧ ∀ (y : K⟮x⟯), ‖ id1 y ‖ ≤ C1 * ‖ y ‖ :=
  Id1.is_bounded_linear_map.bound,
  have hC2 : ∃ (C2 : ℝ), 0 < C2 ∧ ∀ (y : E), ‖ id2 y ‖ ≤ C2 * ‖ y ‖ :=
  Id2.is_bounded_linear_map.bound,
  obtain ⟨C1, hC1_pos, hC1⟩ := hC1,
  obtain ⟨C2, hC2_pos, hC2⟩ := hC2,
  use [C2, C1, hC2_pos, hC1_pos],
  rw forall_and_distrib,
  split,
  { intro y, exact hC2 ⟨y, (intermediate_field.algebra_adjoin_le_adjoin K _) y.2⟩ },
  { intro y, exact hC1 ⟨y, (intermediate_field.algebra_adjoin_le_adjoin K _) y.2⟩ },
end

/-- If `K` is a field complete with respect to a nontrivial nonarchimedean multiplicative norm and
  `L/K` is an algebraic extension, then any multiplicative ring norm on `L` extending the norm on
  `K` coincides with the spectral norm. -/
lemma spectral_norm_unique_field_norm_ext [complete_space K] (h_alg : algebra.is_algebraic K L)
  {f : mul_ring_norm L} (hf_ext : function_extends (norm : K → ℝ) f)
  (hna : is_nonarchimedean (norm : K → ℝ)) (x : L) :
  f x = spectral_norm K L x :=
begin
  set g : algebra_norm K L :=
  { smul' := λ k x, by simp only [mul_ring_norm.to_fun_eq_coe, algebra.smul_def, map_mul, hf_ext k],
    mul_le' := λ x y, by simp only [mul_ring_norm.to_fun_eq_coe, map_mul_le_mul],
    ..f },
  have hg_pow : is_pow_mul g := mul_ring_norm.is_pow_mul _,
  have hgx : f x = g x := rfl,
  rw [hgx, spectral_norm_unique' h_alg hg_pow hna], refl,
end

/-- `seminorm_from_const` can be regarded as an algebra norm, when one assumes that
`(spectral_alg_norm h_alg hna).to_ring_seminorm 1 ≤ 1` and `0 ≠ spectral_alg_norm h_alg hna x`
for some `x : L` -/
def alg_norm_from_const (hna : is_nonarchimedean (norm : K → ℝ))
  (h1 : (spectral_alg_norm h_alg hna).to_ring_seminorm 1 ≤ 1) {x : L}
  (hx : 0 ≠ spectral_alg_norm h_alg hna x) :
  algebra_norm K L  :=
{ smul' := λ k y,
  begin
    have h_mul : ∀ (y : L), spectral_norm K L ((algebra_map K L k) * y) =
      spectral_norm K L (algebra_map K L k) * spectral_norm K L y,
    { intro y,
      rw [spectral_norm_extends, ← algebra.smul_def,
        ← spectral_alg_norm_def h_alg hna, map_smul_eq_mul _ _ _],
      refl, },
    have h : spectral_norm K L (algebra_map K L k) =
      seminorm_from_const' h1 hx (spectral_norm_is_pow_mul h_alg hna) (algebra_map K L k),
    {  rw seminorm_from_const_apply_of_is_mul h1 hx _ h_mul, refl, },
    simp only [ring_norm.to_fun_eq_coe, seminorm_from_const_ring_norm_of_field_def],
    rw [← spectral_norm_extends k, algebra.smul_def, h],
    exact seminorm_from_const_is_mul_of_is_mul _ _ _ h_mul _,
  end,
  ..(seminorm_from_const_ring_norm_of_field h1 hx.symm (spectral_alg_norm_is_pow_mul h_alg hna)) }

lemma alg_norm_from_const_def (hna : is_nonarchimedean (norm : K → ℝ))
  (h1 : (spectral_alg_norm h_alg hna).to_ring_seminorm 1 ≤ 1) {x y : L}
  (hx : 0 ≠ spectral_alg_norm h_alg hna x) :
  alg_norm_from_const h_alg hna h1 hx y =
    seminorm_from_const h1 hx (spectral_norm_is_pow_mul h_alg hna) y :=
rfl

/--If `K` is a field complete with respect to a nontrivial nonarchimedean multiplicative norm and
  `L/K` is an algebraic extension, then the spectral norm on `L` is multiplicative. -/
lemma spectral_norm_is_mul [complete_space K] (hna : is_nonarchimedean (norm : K → ℝ))
  (x y : L) : spectral_alg_norm h_alg hna (x * y) =
    spectral_alg_norm h_alg hna x * spectral_alg_norm h_alg hna y :=
begin
  by_cases hx : spectral_alg_norm h_alg hna x = 0,
  { rw [hx, zero_mul],
    rw [map_eq_zero_iff_eq_zero] at hx ⊢,
    rw [hx, zero_mul],  },
  { have hf1 : (spectral_alg_norm h_alg hna).to_ring_seminorm 1 ≤ 1 :=
    spectral_alg_norm_is_norm_le_one_class h_alg hna,
    set f : algebra_norm K L := alg_norm_from_const h_alg hna hf1 (ne.symm hx) with hf,
    have hf_pow : is_pow_mul f := seminorm_from_const_is_pow_mul hf1 (ne.symm hx)
      (spectral_norm_is_pow_mul h_alg hna),
    have hf_na : is_nonarchimedean f :=
    seminorm_from_const_is_nonarchimedean _ _ _ (spectral_norm_is_nonarchimedean h_alg hna),
    rw [← spectral_norm_unique' h_alg hf_pow, hf],
    simp only [alg_norm_from_const_def],
    exact seminorm_from_const_c_is_mul _ _ _ _, }
  end

/-- The spectral norm is a multiplicative `K`-algebra norm on `L`.-/
def spectral_mul_alg_norm [complete_space K] (hna : is_nonarchimedean (norm : K → ℝ)) :
  mul_algebra_norm K L  :=
{ map_one' := spectral_alg_norm_is_norm_one_class h_alg hna,
  map_mul' := spectral_norm_is_mul h_alg hna,
  ..spectral_alg_norm h_alg hna }

lemma spectral_mul_ring_norm_def [complete_space K] (hna : is_nonarchimedean (norm : K → ℝ))
  (x : L) : spectral_mul_alg_norm h_alg hna x = spectral_norm K L x :=
rfl

/-- `L` with the spectral norm is a `normed_field`. -/
def spectral_norm_to_normed_field [complete_space K] (h_alg : algebra.is_algebraic K L)
  (h : is_nonarchimedean (norm : K → ℝ)) : normed_field L :=
{ norm      := λ (x : L), (spectral_norm K L x : ℝ),
  dist      := λ (x y : L), (spectral_norm K L (x - y) : ℝ),
  dist_self := λ x, by { simp only [sub_self, spectral_norm_zero] },
  dist_comm := λ x y, by { simp only [dist], rw [← neg_sub, spectral_norm_neg h_alg h] },
  dist_triangle := λ x y z, begin
    simp only [dist_eq_norm],
    rw ← sub_add_sub_cancel x y z,
    exact add_le_of_is_nonarchimedean spectral_norm_nonneg
      (spectral_norm_is_nonarchimedean h_alg h) _ _,
  end,
  eq_of_dist_eq_zero := λ x y hxy,
  begin
    simp only [← spectral_mul_ring_norm_def h_alg h] at hxy,
    rw ← sub_eq_zero,
    exact mul_algebra_norm.eq_zero_of_map_eq_zero' _ _ hxy,
  end,
  dist_eq := λ x y, by refl,
  norm_mul' := λ x y,
  by simp only [← spectral_mul_ring_norm_def h_alg h]; exact map_mul _ _ _,
  ..(infer_instance : field L) }

/-- `L` with the spectral norm is a `normed_add_comm_group`. -/
def spectral_norm_to_normed_add_comm_group [complete_space K] (h_alg : algebra.is_algebraic K L)
  (h : is_nonarchimedean (norm : K → ℝ)) : normed_add_comm_group L :=
begin
  haveI : normed_field L := spectral_norm_to_normed_field h_alg h,
  apply_instance,
end

/-- `L` with the spectral norm is a `seminormed_add_comm_group`. -/
def spectral_norm_to_seminormed_add_comm_group [complete_space K] (h_alg : algebra.is_algebraic K L)
  (h : is_nonarchimedean (norm : K → ℝ)) : seminormed_add_comm_group L :=
begin
  haveI : normed_field L := spectral_norm_to_normed_field h_alg h,
  apply_instance,
end

/-- `L` with the spectral norm is a `normed_space` over `K`. -/
def spectral_norm_to_normed_space [complete_space K] (h_alg : algebra.is_algebraic K L)
  (h : is_nonarchimedean (norm : K → ℝ)) :
  @normed_space K L _ (spectral_norm_to_seminormed_add_comm_group h_alg h) :=
{ norm_smul_le := λ r x,
  begin
    change spectral_alg_norm h_alg h (r • x) ≤ ‖ r ‖*(spectral_alg_norm h_alg h x),
    exact le_of_eq (map_smul_eq_mul _ _ _),
  end,
  ..(infer_instance : module K L) }

/-- The metric space structure on `L` induced by the spectral norm. -/
def ms [complete_space K] (h : is_nonarchimedean (norm : K → ℝ)) : metric_space L :=
(spectral_norm_to_normed_field h_alg h).to_metric_space

/-- The uniform space structure on `L` induced by the spectral norm. -/
def us [complete_space K] (h : is_nonarchimedean (norm : K → ℝ)) :
  uniform_space L := (ms h_alg h).to_uniform_space -- normed_field.to_uniform_space

/-- If `L/K` is finite dimensional, then `L` is a complete space with respect to topology induced
  by the spectral norm. -/
@[priority 100] instance spectral_norm_complete_space [complete_space K]
  (h : is_nonarchimedean (norm : K → ℝ)) [h_fin : finite_dimensional K L] :
  @complete_space L (us h_alg h) :=
@finite_dimensional.complete K _ L (spectral_norm_to_normed_add_comm_group h_alg h)
  (spectral_norm_to_normed_space h_alg h) _ h_fin