import week_8.ideas.Part_C_H1
/-

# Boundary maps

If 0 → A → B → C → 0 is exact, we want
a boundary map `H0 G C →+ H1 G A`

We're going to use the axiom of choice in our definition.
Whenever we invoke the axiom of choice we are using something
noncomputable, so it's important that we make a proper API
for the object we construct.

-/

-- missing?
section missing

variables {A B : Type*} [group A] [group B]
  (f : A →* B) (a1 a2 : A)

@[to_additive] lemma monoid_hom.map_div (a1 a2 : A) :
  f (a1 / a2) = f a1 / f a2 :=
by simp [div_eq_mul_inv]

@[simp, to_additive] lemma group.div_self (a : A) : a / a = 1 :=
by simp [div_eq_mul_inv]

@[simp, to_additive] lemma group.div_eq_one_iff (a1 a2 : A) : a1 / a2 = 1 ↔ a1 = a2 :=
⟨by simp [div_eq_mul_inv, mul_eq_one_iff_eq_inv], by {rintro rfl, simp}⟩

@[to_additive] lemma monoid_hom.div_mem_ker (f : A →* B) (a1 a2 : A) :
  a1 / a2 ∈ f.ker ↔ f a1 = f a2 :=
begin
  rw monoid_hom.mem_ker,
  rw f.map_div,
  rw group.div_eq_one_iff,
end

end missing

namespace boundary_map

variables {G M N P : Type} [monoid G]
  [add_comm_group M] [distrib_mul_action G M]
  [add_comm_group N] [distrib_mul_action G N]
  [add_comm_group P] [distrib_mul_action G P]
  {φ : M →+[G] N} {ψ : N →+[G] P} (hse : is_short_exact φ ψ)

include hse

noncomputable def raw_boundary_function : H0 G P → (G → M) :=
λ p g, hse.inverse_φ (g • (hse.inverse_ψ p) - hse.inverse_ψ p)
begin
  rw hse.exact_set,
  simp [hse.inverse_ψ_spec, p.spec],
end

lemma raw_boundary_function.is_cocycle
  {p : H0 G P} : is_cocycle (raw_boundary_function hse p) :=
begin
  intros g h,
  unfold raw_boundary_function,
  apply hse.injective,
  -- should `smul_sub` be a `simp` lemma?
  simp [mul_smul, smul_sub],
end

noncomputable def delta : H0 G P →+ H1 G M :=
{ to_fun := λ p, Z1.quotient
  { to_fun := raw_boundary_function hse p,
    is_cocycle' := raw_boundary_function.is_cocycle hse },
  map_zero' := begin
    rw ← add_monoid_hom.mem_ker,
    rw H1.ker_quotient,
    simp [raw_boundary_function],
    refine ⟨hse.inverse_φ (hse.inverse_ψ 0) _, _⟩,
    { rw hse.exact_set,
      rw hse.inverse_ψ_spec },
    ext g,
    simp,
    apply hse.injective,
    simp [hse.inverse_φ_spec],
  end,
  map_add' := begin
    intros p q,
    rw ← add_monoid_hom.map_add,
    rw ← add_monoid_hom.sub_mem_ker,
    rw H1.ker_quotient,
    have crucial :
      ∃ m : M, φ m = hse.inverse_ψ (↑p + ↑q) - hse.inverse_ψ p - hse.inverse_ψ q,
    { simp [hse.exact_set] },
    refine ⟨hse.inverse_φ _ crucial, _⟩,
    ext g,
    simp [cochain_map, Z1.coe_add, raw_boundary_function],
    apply hse.injective,
    simp [smul_sub],
    abel,
  end }

/-

todo
In Part D of this week's workshop we will define
a boundary map `H0 G C →+ H1 H A` coming from a short
exact sequence of `G`-modules. In this definition we make
a choice of sign ("do we use `g b - b` or `b - g b`?").
The final boss of this course
is verifying the first seven terms of the long exact sequence
of group cohomology associated to a short exact sequence of
G-modules.

TODO

boundary map API

7 term exact sequnce

inf-res

-/

end boundary_map


import .love07_metaprogramming_demo

/- # LoVe Exercise 7: Metaprogramming -/

set_option pp.beta true
set_option pp.generalized_field_notation false

namespace LoVe

/- ## Question 1: A Term Exploder

In this exercise, we develop a string format for the `expr` metatype. By
default, there is no `has_repr` instance to print a nice string. For example: -/

#eval (expr.app (expr.var 0) (expr.var 1) : expr)   -- result: `[external]`
#eval (`(λx : ℕ, x + x) : expr)                     -- result: `[external]`

/- 1.1. Define a metafunction `expr.repr` that converts an `expr` into a
`string`. It is acceptable to leave out some fields from the `expr`
constructors, such as the level `l` of a sort, the binder information `bi` of
a `λ` or `∀` binder, and the arguments of the `macro` constructor.

Hint: Use `name.to_string` to convert a name to a string, and `repr` for other
types that belong to the `has_repr` type class. -/

meta def expr.repr : expr → string
| (expr.var n)                := "(var " ++ repr n ++ ")"
| (expr.sort l)               := "sort"
| (expr.const n ls)           := "(const " ++ n.to_string ++ ")"
| (expr.mvar n m t)           :=
  "(mvar " ++ name.to_string n ++ " " ++ name.to_string m ++ " " ++
  expr.repr t ++ ")"
| (expr.local_const n m bi t) :=
  "(local_const " ++ name.to_string n ++ " " ++ name.to_string m ++ " " ++
  expr.repr t ++ ")"
| (expr.app e f)              :=
  "(app " ++ expr.repr e ++ " " ++ expr.repr f ++ ")"
| (expr.lam n bi e t)         :=
  "(lam " ++ name.to_string n ++ " " ++ expr.repr e ++ " " ++ expr.repr t ++ ")"
| (expr.pi n bi e t)          :=
  "(pi " ++ name.to_string n ++ " " ++ expr.repr e ++ " " ++ expr.repr t ++ ")"
| (expr.elet n g e f)         :=
  "(elet " ++ name.to_string n ++ " " ++ expr.repr g ++ " " ++ expr.repr e ++
  " " ++ expr.repr f ++ ")"
| (expr.macro d args)         := "macro"

/- We register `expr.repr` in the `has_repr` type class, so that we can use
`repr` without qualification in the future, and so that it is available to
`#eval`. We need the `meta` keyword in front of the command we enter. -/

meta instance expr.has_repr : has_repr expr :=
{ repr := expr.repr }

/- 1.2. Test your setup. -/

#eval (expr.app (expr.var 0) (expr.var 1) : expr)
#eval (`(λx : ℕ, x + x) : expr)

/- 1.3. Compare your answer with `expr.to_raw_fmt`. -/

#check expr.to_raw_fmt

/- ## Question 2: `destruct_and` on Steroids

Recall from the lecture that `destruct_and` fails on easy goals such as -/

lemma abc_ac₂ (a b c : Prop) (h : a ∧ b ∧ c) :
  a ∧ c :=
sorry

/- We will now address this by developing a new tactic called `destro_and`,
which applies both **des**truction and in**tro**duction rules for conjunction.
It will also go automatically through the hypotheses instead of taking an
argument. We will develop it in three steps.

2.1. Develop a tactic `intro_ands` that replaces all goals of the form
`a ∧ b` with two new goals `a` and `b` systematically, until all top-level
conjunctions are gone.

For this, we can use tactics such as `tactic.repeat` (which repeatedly applies a
tactic on all goals and subgoals until the tactic fails on each of the goal) and
`tactic.applyc` (which can be used to apply a rule, in connection with backtick
quoting). -/

meta def intro_ands : tactic unit :=
tactic.repeat (tactic.applyc `and.intro)

lemma abcd_bd (a b c d : Prop) (h : a ∧ (b ∧ c) ∧ d) :
  b ∧ d :=
begin
  intro_ands,
  /- The proof state should be as follows:

  2 goals
  a b c d : Prop,
  h : a ∧ (b ∧ c) ∧ d
  ⊢ b

  a b c d : Prop,
  h : a ∧ (b ∧ c) ∧ d
  ⊢ d -/
  repeat { sorry }
end

lemma abcd_bacb (a b c d : Prop) (h : a ∧ (b ∧ c) ∧ d) :
  b ∧ (a ∧ (c ∧ b)) :=
begin
  intro_ands,
  /- The proof state should be as follows:

  4 goals
  a b c d : Prop,
  h : a ∧ (b ∧ c) ∧ d
  ⊢ b

  a b c d : Prop,
  h : a ∧ (b ∧ c) ∧ d
  ⊢ a

  a b c d : Prop,
  h : a ∧ (b ∧ c) ∧ d
  ⊢ c

  a b c d : Prop,
  h : a ∧ (b ∧ c) ∧ d
  ⊢ b -/
  repeat { sorry }
end

/- 2.2. Develop a tactic `destruct_ands` that replaces hypotheses of the form
`h : a ∧ b` by two new hypotheses `h_left : a` and `h_right : b` systematically,
until all top-level conjunctions are gone.

Here is imperative-style pseudocode that you can follow:

1. Retrieve the list of hypotheses from the context. This is provided by the
   metaconstant `local_context`.

2. Find the first hypothesis (= term) with a type (= proposition) of the form
   `_ ∧ _`. Here, you can use the `list.mfirst` function, in conjunction with
   pattern matching. You can use `infer_type` to query the type of a term.

3. Perform a case split on the first found hypothesis. This can be achieved
   using the `cases` metafunction.

4. Repeat.

The above procedure might fail if there exists no hypotheses of the required
form. Make sure to handle this failure gracefully, for example using
`tactic.try` or `<|> pure ()`. -/

meta def destruct_ands : tactic unit :=
tactic.repeat (do
  hs ← tactic.local_context,
  h ← list.mfirst (λh, do `(_ ∧ _) ← tactic.infer_type h, pure h) hs,
  tactic.cases h,
  pure ())

-- Alternative solutions:
meta def destruct_ands₂ : tactic unit :=
tactic.try
  (do
     hs ← tactic.local_context,
     h ← list.mfirst (λh, do `(_ ∧ _) ← tactic.infer_type h, pure h) hs,
     tactic.cases h,
     destruct_ands₂)

meta def destruct_ands₃ : tactic unit :=
(do
   hs ← tactic.local_context,
   h ← list.mfirst (λh, do `(_ ∧ _) ← tactic.infer_type h, pure h) hs,
   tactic.cases h,
   destruct_ands₃)
<|> pure ()

lemma abcd_bd₂ (a b c d : Prop) (h : a ∧ (b ∧ c) ∧ d) :
  b ∧ d :=
begin
  destruct_ands,
  /- The proof state should be as follows:

  a b c d : Prop,
  h_left : a,
  h_right_right : d,
  h_right_left_left : b,
  h_right_left_right : c
  ⊢ b ∧ d -/
  sorry
end

/- 2.3. Combine the two tactics developed above and `tactic.assumption` to
implement the desired `destro_and` tactic. -/

meta def destro_and : tactic unit :=
do
  destruct_ands,
  intro_ands,
  tactic.all_goals (tactic.try tactic.assumption),
  pure ()

lemma abcd_bd₃ (a b c d : Prop) (h : a ∧ (b ∧ c) ∧ d) :
  b ∧ d :=
by destro_and

lemma abcd_bacb₂ (a b c d : Prop) (h : a ∧ (b ∧ c) ∧ d) :
  b ∧ (a ∧ (c ∧ b)) :=
by destro_and

lemma abd_bacb (a b c d : Prop) (h : a ∧ b ∧ d) :
  b ∧ (a ∧ (c ∧ b)) :=
begin
  destro_and,
  /- The proof state should be roughly as follows:

  a b c d : Prop,
  h_left : a,
  h_right_left : b,
  h_right_right : d
  ⊢ c -/
  sorry   -- unprovable
end

/- 2.4. Provide some more examples for `destro_and` to convince yourself that
it works as expected also on more complicated examples. -/

lemma ab (a b : Prop) (h : a ∨ b) :
  a ∨ b :=
by destro_and

lemma abcdef_1 (a b c d e f : Prop) (h : a ∧ b ∧ c ∧ d ∧ e ∧ f) :
  f ∧ e ∧ f ∧ a ∧ d ∧ b ∧ c ∧ a :=
by destro_and

lemma abcdef_2 (a b c d e f : Prop) (h : a ∧ ((b ∧ ((c ∧ d) ∧ e)) ∧ f)) :
  f ∧ e ∧ f ∧ a ∧ d ∧ b ∧ c ∧ a :=
by destro_and

lemma abcdef_3 (a b c d e f : Prop) (h : a ∧ (b ∧ (c ∧ (d ∧ e ∧ f)))) :
  f ∧ (e ∧ (f ∧ (a ∧ d ∧ b ∧ c ∧ a))) :=
by destro_and

/- ## Question 3 (**optional**): A Theorem Finder

We will implement a function that allows us to find theorems by constants
appearing in their statements. So given a list of constant names, the function
will list all theorems in which all these constants appear.

You can use the following metaconstants:

* `declaration` contains all data (name, type, value) associated with a
  declaration understood broadly (e.g., axiom, lemma, constant, etc.).

* `tactic.get_env` gives us access to the `environment`, a metatype that lists
  all `declaration`s (including all theorems).

* `environment.fold` allows us to walk through the environment and collect data.

* `expr.fold` allows us to walk through an expression and collect data.

3.1 (**optional**). Write a metafunction that checks whether an expression
contains a specific constant.

You can use `expr.fold` to walk through the expression, `||` and `ff` for
Booleans, and `expr.is_constant_of` to check whether an expression is a
constant. -/

meta def term_contains (e : expr) (nam : name) : bool :=
expr.fold e ff (λe' d c, c || expr.is_constant_of e' nam)

/- 3.2 (**optional**). Write a metafunction that checks whether an expression
contains **all** constants in a list.

You can use `list.band` (Boolean and). -/

meta def term_contains_all (nams : list name) (e : expr) : bool :=
list.band (list.map (term_contains e) nams)

/- 3.3 (**optional**). Produce the list of all theorems that contain all
constants `nams` in their statement.

`environment.fold` allows you to walk over the list of declarations. With
`declaration.type`, you get the type of a theorem, and with
`declaration.to_name` you get the name. -/

meta def list_constants (nams : list name) (e : environment) : list name :=
environment.fold e [] (λdecl nams',
  if term_contains_all nams decl.type then decl.to_name :: nams' else nams')

/- Finally, we develop a tactic that uses the above metafunctions to log all
found theorems: -/

meta def find_constants (nams : list name) : tactic unit :=
do
  env ← tactic.get_env,
  list.mmap' tactic.trace (list_constants nams env)

/- We test the solution. -/

run_cmd find_constants []   -- lists all theorems
run_cmd find_constants [`list.map, `function.comp]

end LoVe


/-
Copyright (c) 2021 OpenAI. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kunhao Zheng, Stanislas Polu, David Renshaw, OpenAI GPT-f
-/
import mathzoo.imports.miniF2F

open_locale nat rat real big_operators topological_space

theorem mathd_algebra_304 :
  91^2 = 8281 :=
begin
  norm_num,
end


import tactic

variable {α : Type}

-- Stages-are-key. Every set is formed at some stage.
--
-- Stages-are-ordered. Stages are ordered: some come before others.
--
-- Stages-accumulate. For any stage S, and for any sets which were formed
-- before stage S: a set is formed at stage S whose members are exactly those
-- sets. Nothing else is formed at stage S.

#print notation ⋂₀

example : ⋂₀ (∅ : set (set α)) = set.univ :=
begin
  unfold set.sInter,
  unfold Inf,
  ext,
  simp only [forall_false_left, set.mem_empty_eq, forall_const, set.set_of_true],
end

-- Stages-keep-going. There is no last stage.
--
-- Stages-hit-infinity. There is an infinite stage. That is, there is a stage
-- which (a) is not the first stage, and which (b) has some stages before it,
-- but which (c) has no immediate predecessor.

noncomputable theory

axiom Set : Type

#check @has_mem
#check @has_subset
#print notation ∈
#print notation ⊆

axiom mem : Set → Set → Prop

instance : has_mem Set Set := ⟨mem⟩

def subset (A B : Set) :=
∀ ⦃x⦄, x ∈ A → x ∈ B

instance : has_subset Set := ⟨subset⟩

-- Theorem 8.1 (Russell’s Paradox). There is no set R = {x : x ∉ x}
theorem russell's_paradox : ¬ ∃ R : Set, ∀ x, x ∈ R ↔ x ∉ x :=
begin
  rintro ⟨R, hR⟩,
  specialize hR R,
  simpa using hR
end

-- no (ZFC) axioms
#print axioms russell's_paradox

-- Axiom (Extensionality). For any sets A and B: ∀ x (x ∈ A ↔ x ∈ B) → A = B
@[ext] axiom extensionality (A B : Set) (h : ∀ x, x ∈ A ↔ x ∈ B) : A = B

#check @set.ext_iff

lemma ext_iff {A B : Set} : A = B ↔ ∀ x, x ∈ A ↔ x ∈ B :=
begin
  have := extensionality A B,
  tidy
end

#print notation ↔
#print notation ∧

#check @classical.some
#check @classical.some_spec

-- Axiom (Scheme of Separation). For every formula φ(x) this is an axiom: for
-- any A, the set {x ∈ A : φ(x)} exists.
axiom separation (φ : Set → Prop) (A : Set) : Set
axiom separation_spec (φ : Set → Prop) (A : Set) : ∀ x, x ∈ separation φ A ↔ x ∈ A ∧ φ x

#check @has_sep

instance : has_sep Set Set := ⟨separation⟩

-- Theorem 9.1. There is no universal set, i.e., {x : x = x} does not exist.
theorem not_exists_universal_set : ¬ ∃ V : Set, ∀ x, x ∈ V :=
begin
  rintro ⟨V, hV⟩,
  let R := separation (λ x, x ∉ x) V,
  have hR := separation_spec (λ x, x ∉ x) V,
  change ∀ x, x ∈ R ↔ _ ∧ x ∉ x at hR,
  specialize hV R,
  specialize hR R,
  simpa [hV] using hR
end

-- separation
#print axioms not_exists_universal_set

-- Proposition 9.2. If any set exists, then ∅ exists.
lemma proposition_9_2 (A : Set) : ∃ S : Set, ∀ x, x ∉ S :=
begin
  let S := separation (λ x, false) A,
  have hS := separation_spec (λ x, false) A,
  change ∀ x, x ∈ S ↔ _ ∧ false at hS,
  use S,
  intros x hx,
  specialize hS x,
  simpa using hS
end

#check @has_sdiff.sdiff
#print notation \

-- Proposition 9.3. A \ B exists for any sets A and B
lemma proposition_9_3 (A B : Set) : ∃ S : Set, ∀ x, x ∈ S ↔ x ∈ A ∧ x ∉ B :=
⟨separation _ _, separation_spec _ _⟩

instance : has_sdiff Set :=
⟨λ A B, separation (λ x, x ∉ B) A⟩

#print notation ⋂₀

-- Proposition 9.4. If A ≠ ∅, then ⋂ A = {x : (∀ y ∈ A) x ∈ y} exists.
lemma proposition_9_4 (A c : Set) (hc : c ∈ A) :
  ∃ S : Set, ∀ x, x ∈ S ↔ (∀ y, y ∈ A → x ∈ y) :=
begin
  let S := separation (λ x, ∀ y, y ∈ A → x ∈ y) c,
  have hS := separation_spec (λ x, ∀ y, y ∈ A → x ∈ y) c,
  change ∀ x, x ∈ S ↔ _ ∧ ∀ y, y ∈ A → x ∈ y at hS,
  use S,
  intro x,
  specialize hS x,
  rw [hS, and_iff_right_iff_imp],
  intro h,
  specialize h c,
  specialize h hc,
  assumption
end

-- Axiom (Union). For any set A, the set ⋃ A = {x : (∃ b ∈ A) x ∈ b} exists.
-- ∀ A ∃ U ∀ x (x ∈ U ↔ (∃ b ∈ A) x ∈ b)
axiom union (A : Set) : Set
axiom union_spec (A : Set) : ∀ x, x ∈ union A ↔ ∃ b, b ∈ A ∧ x ∈ b

#print notation ↔
#print notation ∨

-- Axiom (Pairs). For any sets a, b, the set {a, b} exists.
-- ∀ a ∀ b ∃ P ∀ x (x ∈ P ↔ (x = a ∨ x = b))
axiom pair (a b : Set) : Set
axiom pair_spec (a b : Set) : ∀ x, x ∈ pair a b ↔ x = a ∨ x = b

-- Axiom (Powersets). For any set A, the set ℘(A) = {x : x ⊆ A} exists.
-- ∀ A ∃ P ∀ x (x ∈ P ↔ (∀ z ∈ x) z ∈ A)
axiom powerset (A : Set) : Set
axiom powerset_spec (A : Set) : ∀ x, x ∈ powerset A ↔ ∀ z, z ∈ x → z ∈ A

-- Axiom (Infinity). There is a set, I, such that ∅ ∈ I and x ∪ {x} ∈ I
-- whenever x ∈ I
-- ∃ I ((∃ o ∈ I) ∀ x x ∉ o ∧
--      (∀ x ∈ I) (∃ s ∈ I) ∀ z (z ∈ s ↔ (z ∈ x ∨ z = x)))
axiom infinity : Set
axiom infinity_spec_zero : ∃ o ∈ infinity, ∀ x, x ∉ o
axiom infinity_spec_succ : ∀ x ∈ infinity, ∃ s ∈ infinity, ∀ z, z ∈ s ↔ z ∈ x ∨ z = x

#print notation ∅

instance : has_emptyc Set := ⟨separation (λ x, false) infinity⟩

lemma empty_spec : ∀ x, x ∉ (∅ : Set) :=
begin
  intros x hx,
  change x ∈ separation _ _ at hx,
  have h := separation_spec (λ x, false) infinity,
  change x ∈ ∅ at hx,
  change ∀ x, x ∈ (∅ : Set) ↔ _ ∧ false at h,
  specialize h x,
  simpa [hx] using h
end

lemma empty_mem_infinity : ∅ ∈ infinity :=
begin
  obtain ⟨o, ho₁, ho₂⟩ := infinity_spec_zero,
  suffices : ∅ = o, by rwa this,
  ext x,
  have h₁ := empty_spec x,
  have h₂ := ho₂ x,
  simp [h₁, h₂]
end

--def closed (f : Set → Set) (X : Set) := ∀ x, x ∈ X → f x ∈ X

-- Proposition 9.5. For any sets a and b, the following sets exist:
-- 1. {a}
-- 2. a ∪ b
-- 3. ⟨a,b⟩
instance : has_singleton Set Set := ⟨λ a, pair a a⟩

lemma singleton_spec (a : Set) : ∀ x ∈ ({a} : Set), x = a :=
begin
  intros x hx,
  change x ∈ pair a a at hx,
  have h := pair_spec a a,
  change x ∈ {a} at hx,
  change ∀ x, x ∈ ({a} : Set) ↔ _ at h,
  specialize h x,
  simpa [hx] using h
end

#check @has_union
#check @has_union.union
#print notation ∪

instance : has_union Set := ⟨λ a b, union (pair a b)⟩

lemma union_spec' (a b : Set) : ∀ x, x ∈ a ∪ b ↔ x ∈ a ∨ x ∈ b :=
begin
  intro x,
  change x ∈ union (pair a b) ↔ _,
  have h := union_spec (pair a b),
  specialize h x,
  rw h,
  clear h,
  have h := pair_spec a b,
  split,
  { rintro ⟨c, hc₁, hc₂⟩,
    specialize h c,
    simp [hc₁] at h,
    cases h,
    { rw ←h,
      left,
      assumption },
    { rw ←h,
      right,
      assumption } },
  { intro hx,
    cases hx,
    { use a,
      specialize h a,
      simp at h,
      simp [h, hx] },
    { use b,
      specialize h b,
      simp at h,
      simp [h, hx] } }
end

#check @has_insert

instance : has_insert Set Set := ⟨λ a b, {a} ∪ b⟩

instance : is_lawful_singleton Set Set :=
⟨begin
  change ∀ x, {x} ∪ ∅ = {x},
  intro x,
  ext y,
  simp [union_spec', empty_spec]
end⟩

example {α : Type} (a b : α) (h : a ∈ ({b} : set α)) : a = b :=
set.mem_singleton_iff.mp h

#check @set.mem_singleton_iff

lemma mem_singleton_iff {a b : Set} : a ∈ ({b} : Set) ↔ a = b :=
begin
  change a ∈ pair b b ↔ _,
  have := pair_spec b b a,
  simp [this]
end

variables {a b c : Set}

#check ({a, b, c} : Set)

variables {a₁ a₂ b₁ b₂ : Set}

#check extensionality
#check set.ext_iff

lemma pair_spec' (a b : Set) : pair a b = {a, b} :=
begin
  ext x,
  have := pair_spec a b x,
  rw this,
  clear this,
  change _ ↔ x ∈ {a} ∪ {b},
  have := union_spec' {a} {b} x,
  rw [this, mem_singleton_iff, mem_singleton_iff]
end

lemma eq_of_eq_singleton (h : {b₁, b₂} = ({a} : Set)) : b₁ = b₂ :=
begin
  have h₁ : b₁ = a,
  { have := ext_iff.mp h b₁,
    rw [←pair_spec', mem_singleton_iff, pair_spec b₁ b₂ b₁] at this,
    simpa using this },
  have h₂ : b₂ = a,
  { have := ext_iff.mp h b₂,
    rw [←pair_spec', mem_singleton_iff, pair_spec b₁ b₂ b₂] at this,
    simpa using this },
  rw [h₁, h₂]
end

def tuple (a b : Set) : Set := pair (pair a a) (pair a b)

#check singleton_spec

example {α : Type} (a b : α) (h : ({a} : set α) = {b}) : a = b :=
by simpa only [set.singleton_eq_singleton_iff] using h

lemma singleton_eq_singleton_iff {a b : Set} : ({a} : Set) = {b} ↔ a = b :=
begin
  split,
  { intro h,
    have : a ∈ {b}, by rw [←h, mem_singleton_iff],
    rwa mem_singleton_iff at this },
  { intro h,
    rw h }
end

lemma fst_eq_fst_of_tuple_eq_tuple (h : tuple a₁ b₁ = tuple a₂ b₂) : a₁ = a₂ :=
begin
  have h' : pair a₂ a₂ ∈ tuple a₁ b₁,
  { rw h,
    have := pair_spec (pair a₂ a₂) (pair a₂ b₂) (pair a₂ a₂),
    simpa using this },
  unfold tuple at h',
  have := pair_spec (pair a₁ a₁) (pair a₁ b₁) (pair a₂ a₂),
  simp [h'] at this,
  clear h h',
  cases this,
  { change {a₂} = {a₁} at this,
    rw ←singleton_eq_singleton_iff,
    symmetry,
    assumption },
  { suffices h : a₁ = b₁,
    { subst h,
      change {a₂} = {a₁} at this,
      rw ←singleton_eq_singleton_iff,
      symmetry,
      assumption },
    change {a₂} = _ at this,
    have h := pair_spec' a₁ b₁,
    rw h at this,
    clear h,
    have := eq_of_eq_singleton (this).symm,
    assumption }
end

example {α : Type} (a b : α) : a = b ↔ b = a :=
eq_comm

lemma pair_eq_singleton (a : Set) : pair a a = {a} :=
begin
  ext,
  have := pair_spec a a x,
  simp [this, mem_singleton_iff]
end

lemma mem_pair_left (a b : Set) : a ∈ pair a b :=
begin
  have := pair_spec a b a,
  simpa using this
end

lemma mem_pair_right (a b : Set) : b ∈ pair a b :=
begin
  have := pair_spec a b b,
  simpa using this
end

lemma snd_eq_snd_of_tuple_eq_tuple (h : tuple a₁ b₁ = tuple a₂ b₂) : b₁ = b₂ :=
begin
  obtain rfl := fst_eq_fst_of_tuple_eq_tuple h,
  rename a₁ a,
  have h' : pair a b₂ ∈ tuple a b₁,
  { rw h,
    have := pair_spec (pair a a) (pair a b₂) (pair a b₂),
    simpa using this },
  unfold tuple at h',
  have := pair_spec (pair a a) (pair a b₁) (pair a b₂),
  simp [h'] at this,
  cases this,
  { have : a = b₂,
    { change _ = {a} at this,
      rw pair_spec' at this,
      simp [eq_of_eq_singleton this] },
    subst this,
    clear this,
    unfold tuple at h,
    rw [pair_eq_singleton, pair_eq_singleton, pair_spec', pair_spec'] at h,
    have h := eq_of_eq_singleton h,
    have h := eq_of_eq_singleton h.symm,
    rw h },
  { clear h h',
    have h₁ := pair_spec a b₁ b₂,
    rw ←this at h₁,
    simp [mem_pair_right] at h₁,
    have h₂ := pair_spec a b₂ b₁,
    rw this at h₂,
    simp [mem_pair_right] at h₂,
    cases h₁; cases h₂; tidy }
end

lemma tuple_spec : tuple a₁ b₁ = tuple a₂ b₂ ↔ a₁ = a₂ ∧ b₁ = b₂ :=
begin
  split; intro h,
  { simp [fst_eq_fst_of_tuple_eq_tuple h, snd_eq_snd_of_tuple_eq_tuple h] },
  { simp [h] }
end


/-
# EGAI 2.4.1
-/

import algebraic_geometry.AffineScheme
-- imports from mathlib

import about_local_rings
import target_affine_scheme
-- imports from this repo

noncomputable theory

open algebraic_geometry
open category_theory category_theory.limits
open topological_space
open opposite

namespace algebraic_geometry

universe u

namespace Scheme

section local_scheme

variables {Y : Scheme.{u}} (y : Y.carrier)

def _root_.algebraic_geometry.is_affine_open.iso_Spec
  {V : opens Y.carrier} (hV : is_affine_open V) :
  Y.restrict V.open_embedding ≅ _ :=
@Scheme.iso_Spec _ hV

instance restrict_stalk_is_local
  (V : opens Y.carrier) (hV : is_affine_open V) (mem_ : y ∈ V) :
  local_ring ((Y.restrict V.open_embedding).stalk ⟨y, mem_⟩) :=
@local_ring.of_equiv _
  (localization.at_prime ((hV.iso_Spec.hom.1.base ⟨y, mem_⟩).as_ideal :
    ideal $ Γ.obj $ op $ Y.restrict V.open_embedding)) _ _ _ $
@@Scheme.stalk_iso_of_affine' (Y.restrict $ V.open_embedding)
  hV ⟨y, mem_⟩

instance stalk_is_local : local_ring (Y.stalk y) :=
begin
  obtain ⟨⟨V, mem_y⟩, A, ⟨i⟩⟩ := Y.2 y,
  have hV : is_affine_open V,
  { refine @@is_affine_of_iso _ _ (algebraic_geometry.Spec_is_affine (op A)),
    exact i.hom, refine ⟨⟨i.inv, i.hom_inv_id, i.inv_hom_id⟩⟩, },
  haveI : local_ring ((Y.restrict V.open_embedding).stalk ⟨y, mem_y⟩) :=
    Scheme.restrict_stalk_is_local _ _ hV _,
  let i := Y.1.to_PresheafedSpace.restrict_stalk_iso V.open_embedding ⟨y, mem_y⟩,
  refine local_ring.of_equiv _
    ((Y.restrict V.open_embedding).stalk ⟨y, mem_y⟩)
    ⟨i.inv, i.hom, i.inv_hom_id_apply, i.hom_inv_id_apply, map_mul _, map_add _⟩,
end

section

variable {y}

def sections_to_stalk_restrict_aux
  {V : opens Y.carrier} (hV : is_affine_open V) (mem_ : y ∈ V) :
  Γ.obj (op $ Y.restrict V.open_embedding) ⟶
  (Y.restrict V.open_embedding).stalk ⟨y, mem_⟩ :=
Top.presheaf.germ (Y.restrict V.open_embedding).presheaf
  ⟨⟨y, mem_⟩, by tauto⟩

/--
      Γ(Y|_ V) -------------`≅`---------> Γ(Spec Γ(Y|_ V))
          |                                   |
`sections_to_stalk_restrict_aux`              |
          |                                   |
          v                                   v
        𝒪_{Y|_ V, y} -------`≅`-------> 𝒪_{Spec Γ(Y|_ V), 𝔭}

-/
lemma sections_to_stalk_restrict_aux.commutative_sq
  {V : opens Y.carrier} (hV : is_affine_open V) (mem_ : y ∈ V) :
  sections_to_stalk_restrict_aux hV mem_ ≫
  (eq_to_hom (by { congr, simpa only [←Scheme.comp_val_base_apply, iso.hom_inv_id] })
    ≫ PresheafedSpace.stalk_map (hV.iso_Spec.inv.1) _ :
      (Y.restrict V.open_embedding).stalk ⟨y, mem_⟩ ⟶
      (Spec_obj $ Γ.obj $ op $ Y.restrict V.open_embedding).stalk
        (hV.iso_Spec.hom.1.base ⟨y, mem_⟩)) =
  hV.iso_Spec.inv.1.c.app _ ≫ (Spec_obj $ Γ.obj $ op $ Y.restrict V.open_embedding).presheaf.germ
      (⟨hV.iso_Spec.hom.1.base ⟨y, mem_⟩, ⟨⟩⟩ : (⊤ : opens _)) :=
begin
  erw ←Top.presheaf.stalk_specializes_eq_to_hom,
  erw Top.presheaf.germ_stalk_specializes'_assoc,
  erw PresheafedSpace.stalk_map_germ hV.iso_Spec.inv.1 ⊤
    ⟨hV.iso_Spec.hom.val.base ⟨y, mem_⟩, ⟨⟩⟩,
  refl,

  simpa only [←Scheme.comp_val_base_apply, iso.hom_inv_id],
end

section

lemma sections_to_stalk_restrict_aux.apply_is_unit_iff_mem_prime_compl
  {V : opens Y.carrier} (hV : is_affine_open V) (mem_ : y ∈ V)
  {z : Γ.obj (op $ Y.restrict V.open_embedding)} :
  is_unit (sections_to_stalk_restrict_aux hV mem_ z) ↔
  z ∈ (hV.iso_Spec.hom.1.base ⟨y, mem_⟩).as_ideal.prime_compl :=
begin
  delta sections_to_stalk_restrict_aux,
  rw ←Scheme.mem_basic_open,
  dsimp only [subtype.coe_mk],

  rw ←@Scheme.map_prime_spectrum_basic_open_of_affine _ hV,
  erw opens.map_obj,
  simp only [opens.mem_mk, set.mem_preimage],
  dsimp only [unop_op],
  refl,
end

def _root_.algebraic_geometry.is_affine_open.sections_algebra_stalk_restrict
  {V : opens Y.carrier} (hV : is_affine_open V) (mem_ : y ∈ V) :
  algebra (Γ.obj $ op $ Y.restrict V.open_embedding)
    ((Y.restrict V.open_embedding).stalk ⟨y, mem_⟩) :=
ring_hom.to_algebra $ sections_to_stalk_restrict_aux hV mem_

end

def sections_to_stalk_restrict
  {V : opens Y.carrier} (hV : is_affine_open V) (mem_ : y ∈ V) :
  Γ.obj (op $ Y.restrict V.open_embedding) ⟶ Y.stalk y :=
sections_to_stalk_restrict_aux hV mem_ ≫
(Y.1.to_PresheafedSpace.restrict_stalk_iso _ _).hom

def Spec_stalk_to_restrict
  {V : opens Y.carrier} (hV : is_affine_open V) (mem_ : y ∈ V) :
  (Spec_obj $ Y.stalk y) ⟶ Y.restrict V.open_embedding :=
Spec_map (sections_to_stalk_restrict hV mem_) ≫ hV.iso_Spec.inv

section

variable (y)
def Spec_stalk_to_self :
  (Spec_obj $ Y.stalk y) ⟶ Y :=
Spec_stalk_to_restrict
begin
  have := (Y.2 y).some_spec.some_spec.some,
  refine @@is_affine_of_iso _ _ (algebraic_geometry.Spec_is_affine
    $ op $ (Y.2 y).some_spec.some),
  work_on_goal 2 { exact ((Y.2 y).some_spec.some_spec.some.hom) },
  refine ⟨⟨(Y.2 y).some_spec.some_spec.some.inv, iso.hom_inv_id _,
    iso.inv_hom_id _⟩⟩,
end
begin
  refine (Y.2 y).some.2,
end ≫ Scheme.of_restrict _ _

end

namespace Spec_stalk_to_self_independence_proof

variables {V W : opens Y.carrier} (hV : is_affine_open V) (hW : is_affine_open W)

def restrict_of_subset_rel (subset_rel : V ≤ W) :
  Y.restrict V.open_embedding ⟶ Y.restrict W.open_embedding :=
is_open_immersion.lift
  (Y.of_restrict W.open_embedding)
  (Y.of_restrict V.open_embedding)
  begin
    rintros _ ⟨⟨y, hy⟩, rfl⟩,
    refine ⟨⟨y, subset_rel hy⟩, rfl⟩,
  end

@[simps] def restrict_of_subset_rel'_PresheafedSpace (subset_rel : V ≤ W) :
  (Y.restrict V.open_embedding).to_PresheafedSpace ⟶
  (Y.restrict W.open_embedding).to_PresheafedSpace :=
{ base := ⟨λ y, ⟨y.1, subset_rel y.2⟩, by continuity⟩,
  c :=
  { app := λ U, Y.presheaf.map (hom_of_le
    begin
      rintros _ ⟨y, hy, rfl⟩,
      erw set.mem_preimage at hy,
      refine ⟨⟨_, subset_rel y.2⟩, hy, rfl⟩,
    end : V.open_embedding.is_open_map.functor.obj _ ⟶ W.open_embedding.is_open_map.functor.obj _).op,
    naturality' := λ U V inc,
    begin
      erw [←Y.presheaf.map_comp, ←Y.presheaf.map_comp],
      congr,
    end } }

lemma restrict_of_subset_rel'_PresheafedSpace_comp (subset_rel : V ≤ W) :
  restrict_of_subset_rel'_PresheafedSpace subset_rel ≫
    Y.to_PresheafedSpace.of_restrict W.open_embedding =
  Y.to_PresheafedSpace.of_restrict V.open_embedding :=
begin
  ext z,
  { dsimp, erw [←Y.presheaf.map_comp, ←Y.presheaf.map_comp], congr, },
  { ext pt : 1,
    dsimp, refl, },
end

lemma restrict_of_subset_rel'_PresheafedSpace_eq (subset_rel : V ≤ W) :
  restrict_of_subset_rel'_PresheafedSpace subset_rel =
  (restrict_of_subset_rel subset_rel).1 :=
begin
  dsimp [restrict_of_subset_rel, is_open_immersion.lift],
  rw PresheafedSpace.is_open_immersion.lift_uniq _ _ _ _
    (restrict_of_subset_rel'_PresheafedSpace_comp subset_rel),
  symmetry,
  refine PresheafedSpace.is_open_immersion.lift_uniq _ _ _ _ _,
  { rintros _ ⟨⟨y, hy⟩, rfl⟩,
    refine ⟨⟨y, subset_rel hy⟩, rfl⟩, },
  have := LocallyRingedSpace.is_open_immersion.lift_fac _ _ _,
  rw LocallyRingedSpace.hom.ext_iff at this,
  convert this,
end

instance (subset_rel : V ≤ W) (y) : is_local_ring_hom $
  PresheafedSpace.stalk_map (restrict_of_subset_rel'_PresheafedSpace subset_rel) y :=
begin
  rw restrict_of_subset_rel'_PresheafedSpace_eq,
  exact (restrict_of_subset_rel subset_rel).2 y,
end

def restrict_of_subset_rel' (subset_rel : V ≤ W) :
  Y.restrict V.open_embedding ⟶ Y.restrict W.open_embedding :=
{ val := restrict_of_subset_rel'_PresheafedSpace subset_rel,
  prop := infer_instance }

lemma restrict_of_subset_rel'_comp (subset_rel : V ≤ W) :
  restrict_of_subset_rel' subset_rel ≫ Y.of_restrict W.open_embedding =
  Y.of_restrict V.open_embedding :=
begin
  ext z,
  { dsimp, erw [←Y.presheaf.map_comp, ←Y.presheaf.map_comp], congr, },
  { ext pt : 1,
    dsimp, refl, },
end

lemma restrict_of_subset_rel_comp (subset_rel : V ≤ W) :
  restrict_of_subset_rel subset_rel ≫ Y.of_restrict W.open_embedding =
  Y.of_restrict V.open_embedding :=
is_open_immersion.lift_fac _ _ _

lemma restrict_of_subset_rel_comp' (subset_rel : V ≤ W) :
  Γ.map (Y.of_restrict W.open_embedding).op ≫
    Γ.map (restrict_of_subset_rel' subset_rel).op =
  Γ.map (Y.of_restrict V.open_embedding).op :=
by rw [←Γ.map_comp, ←op_comp, restrict_of_subset_rel'_comp]

def ring_hom_of_subset
  (subset_rel : V ≤ W) :
  Γ.obj (op $ Y.restrict W.open_embedding) ⟶ Γ.obj (op $ Y.restrict V.open_embedding) :=
Γ.map (restrict_of_subset_rel' subset_rel).op

lemma commutes (subset_rel : V ≤ W) (mem_ : y ∈ V) :
  ring_hom_of_subset subset_rel ≫ sections_to_stalk_restrict hV mem_ =
  sections_to_stalk_restrict hW (subset_rel mem_) :=
begin
  dsimp only [ring_hom_of_subset, sections_to_stalk_restrict,
    sections_to_stalk_restrict_aux, restrict_of_subset_rel', Γ],
  dsimp,
  erw PresheafedSpace.restrict_stalk_iso_hom_eq_germ,
  erw PresheafedSpace.restrict_stalk_iso_hom_eq_germ,
  convert Top.presheaf.germ_res _ _ _,
  rw subtype.coe_mk, refl,
end

example : true := ⟨⟩

lemma commutes' (subset_rel : V ≤ W) (mem_ : y ∈ V) :
  Spec_stalk_to_restrict hW (subset_rel mem_) =
  Spec_stalk_to_restrict hV mem_ ≫
  restrict_of_subset_rel' subset_rel :=
begin
  dsimp only [Spec_stalk_to_restrict],
  rw ←commutes hV hW subset_rel mem_,
  rw Spec_map_comp,
  rw [category.assoc, category.assoc],
  congr' 1,
  dsimp only [ring_hom_of_subset],
  have := whisker_eq hV.iso_Spec.inv
    (Γ_Spec.adjunction.unit_naturality (restrict_of_subset_rel' subset_rel)),
  dsimp at this,
  erw is_iso.inv_hom_id_assoc at this,
  erw this,
  erw [category.assoc, category.assoc, is_iso.hom_inv_id, category.comp_id],
end

lemma independent_aux (subset_rel : V ≤ W) (mem_V : y ∈ V) :
  Spec_stalk_to_restrict hW (subset_rel mem_V) ≫ Y.of_restrict W.open_embedding =
  Spec_stalk_to_restrict hV mem_V ≫ Y.of_restrict V.open_embedding :=
by rw [commutes' hV, category.assoc, restrict_of_subset_rel'_comp]

lemma is_affine_open.of_restrict
  (U : opens (Y.restrict V.open_embedding).carrier)
  (hU : is_affine_open U) :
  is_affine_open (V.open_embedding.is_open_map.functor.obj U) :=
begin
  refine is_affine_of_iso _,
  rotate 3, { exact hU },
  generalize_proofs h1 h2 h3 h4,
  let i : Y.restrict h3 ≅ (Y.restrict h2).restrict h4,
  { refine is_open_immersion.iso_of_range_eq (Scheme.of_restrict _ _)
      (Scheme.of_restrict _ _ ≫ Scheme.of_restrict _ _) _,
    ext : 1,
    rw [set.mem_range, set.mem_range],
    split,
    { rintros ⟨⟨_, ⟨⟨y, hy1⟩, hy2, rfl⟩⟩, rfl⟩,
      refine ⟨⟨⟨y, hy1⟩, hy2⟩, rfl⟩, },
    { rintros ⟨⟨⟨y, hy1⟩, hy2⟩, rfl⟩,
      refine ⟨⟨y, ⟨⟨y, hy1⟩, hy2, rfl⟩⟩, rfl⟩, }, },
  exact i.hom,
  exact is_iso.of_iso _,
end

lemma independent (mem_V : y ∈ V) (mem_W : y ∈ W) :
  Spec_stalk_to_restrict hW mem_W ≫ Y.of_restrict W.open_embedding =
  Spec_stalk_to_restrict hV mem_V ≫ Y.of_restrict V.open_embedding :=
begin
  suffices : ∃ (U : opens Y.carrier), is_affine_open U ∧ U ≤ V ⊓ W ∧ y ∈ U,
  { obtain ⟨U, hU, U_le, mem_U⟩ := this,
    have U_le1 : U ≤ V := U_le.trans inf_le_left,
    have U_le2 : U ≤ W := U_le.trans inf_le_right,
    erw independent_aux hU hV U_le1 mem_U,
    erw independent_aux hU hW U_le2 mem_U, },
  obtain ⟨⟨U, hU⟩, R, ⟨i⟩⟩ := (Y.restrict (V ⊓ W).open_embedding).2 ⟨y, ⟨mem_V, mem_W⟩⟩,
  refine ⟨(V ⊓ W).open_embedding.is_open_map.functor.obj U, _, _, _⟩,
  { apply is_affine_open.of_restrict,
    refine is_affine_of_iso _,
    rotate 3, { exact algebraic_geometry.Spec_is_affine (op R), },
    { exact i.hom },
    { refine ⟨⟨i.inv, i.hom_inv_id, i.inv_hom_id⟩⟩, }, },
  { rintros _ ⟨y, hy, rfl⟩, exact y.2, },
  { refine ⟨⟨y, ⟨mem_V, mem_W⟩⟩, hU, rfl⟩, },
end

end Spec_stalk_to_self_independence_proof

lemma Spec_stalk_to_self_on_affine_open {V : opens Y.carrier}
  (hV : is_affine_open V) (mem_ : y ∈ V) :
  Spec_stalk_to_self y =
  Spec_stalk_to_restrict hV mem_ ≫ Y.of_restrict _ :=
Spec_stalk_to_self_independence_proof.independent _ _ _ _

example -- is_affine_open.is_localization_restrict
  {V : opens Y.carrier} (hV : is_affine_open V) (mem_ : y ∈ V) :
  @@is_localization.at_prime _
    ((Y.restrict V.open_embedding).stalk ⟨y, mem_⟩) _
    (hV.sections_algebra_stalk_restrict mem_)
    (hV.iso_Spec.hom.1.base ⟨y, mem_⟩).as_ideal _ :=
{ map_units := λ z,
  begin
    rw ring_hom.algebra_map_to_algebra,
    rw sections_to_stalk_restrict_aux.apply_is_unit_iff_mem_prime_compl,
    exact z.2,
  end,
  surj := λ z,
  begin
    rw ring_hom.algebra_map_to_algebra,
    sorry
    -- have := PresheafedSpace.stalk_map hV.iso_Spec.inv.1 (hV.iso_Spec.hom.1 ⟨y, mem_⟩) _,
    -- refine ⟨⟨_, 1⟩, _⟩,
    -- swap,
    -- { dsimp only, conv_lhs { rw [submonoid.coe_one, map_one, mul_one] },
    --   sorry },
  end,
  eq_iff_exists := λ a b,
  begin
    rw ring_hom.algebra_map_to_algebra,
    split,
    { rintros h, sorry },
    { rintros ⟨⟨c, hc1⟩, (hc2 : a * c = b * c)⟩,
      rw ←sections_to_stalk_restrict_aux.apply_is_unit_iff_mem_prime_compl at hc1,
      have hc2' := congr_arg (sections_to_stalk_restrict_aux hV mem_) hc2,
      rw [map_mul, map_mul] at hc2',
      have hc2'' := congr_arg (λ y, y * hc1.unit.inv) hc2',
      dsimp only at hc2'',
      rw [mul_assoc, mul_assoc] at hc2'',
      change _ * (hc1.unit.1 * hc1.unit.inv) = _ * (hc1.unit.1 * hc1.unit.inv) at hc2'',
      rwa [hc1.unit.3, mul_one, mul_one] at hc2'', }
  end }
-- begin
--   have := is_localization.is_localization_of_alg_equiv
--     (hV.iso_Spec.hom.1.base ⟨y, mem_⟩).as_ideal.prime_compl,
--   refine this _,
--   work_on_goal 5
--   { exactI localization.is_localization },
--   clear this,
--   fconstructor,
--   { refine λ x, PresheafedSpace.stalk_map hV.iso_Spec.hom.1 _
--       (structure_sheaf.localization_to_stalk _ _ x), },
--   { sorry },
--   { sorry },
--   { sorry },
--   { sorry },
--   { sorry },
--   { rintros (r : Γ.obj _),
--     dsimp only [unop_op],
--     rw ring_hom.algebra_map_to_algebra,
--     rw [←comp_apply, ←comp_apply],
--     have := sections_to_stalk_restrict_aux.commutative_sq hV mem_, },
-- end

instance is_affine_open.algebra {V : opens Y.carrier}
  (hV : is_affine_open V) (mem_ : y ∈ V) :
  algebra (Γ.obj $ op $ Y.restrict V.open_embedding) (Y.stalk y) :=
ring_hom.to_algebra $ sections_to_stalk_restrict hV mem_

-- Do I even need this?
-- instance is_affine_open.is_localization {V : opens Y.carrier}
--   (hV : is_affine_open V) (mem_ : y ∈ V) :
--   @@is_localization.at_prime _ (Y.stalk y) _
--     (algebraic_geometry.Scheme.is_affine_open.algebra hV mem_)
--     (hV.iso_Spec.hom.1.base ⟨y, mem_⟩).as_ideal _ :=
-- begin
--   have := @@is_localization.is_localization_of_alg_equiv _ _ _ _ _ _
--     _ _,
--   refine this,
--   work_on_goal 4
--   { exact @algebraic_geometry.Scheme.stalk_is_localization'
--       (Y.restrict V.open_embedding) hV ⟨y, mem_⟩ },
--   refine { to_fun := _, inv_fun := _, left_inv := _, right_inv := _,
--     map_mul' := _, map_add' := _, commutes' := _ },
--   { -- to_fun
--     refine (Y.1.restrict_stalk_iso V.open_embedding ⟨y, mem_⟩).hom,
--    },
--   { -- inv_fun
--     refine (Y.1.restrict_stalk_iso V.open_embedding ⟨y, mem_⟩).inv,
--    },
--   { -- left inverse
--     sorry },
--   { -- right_inverse
--     sorry },
--   { -- map_mul,
--     intros, simp only [map_mul], },
--   { -- map_add,
--     intros, simp only [map_add] },
--   { -- commutes,
--     intros r,
--     rw [ring_hom.algebra_map_to_algebra, ring_hom.algebra_map_to_algebra],
--     rw [ring_hom.comp_apply],
--     apply_fun (Y.1.restrict_stalk_iso V.open_embedding ⟨y, mem_⟩).inv,
--     swap, exact concrete_category.injective_of_mono_of_preserves_pullback _,
--     rw iso.hom_inv_id_apply,
--     erw Scheme.stalk_iso_of_affine'_symm_apply,
--     rw [←localization.mk_one_eq_algebra_map, localization.mk_eq_mk'],
--     erw structure_sheaf.localization_to_stalk_mk',
--     simp_rw submonoid.coe_one,
--     erw ←structure_sheaf.to_open_eq_const,
--     erw structure_sheaf.germ_to_open,
--     sorry
--      }
-- end

end

end local_scheme

end Scheme

end algebraic_geometry


import tactic --hide

/-Lemma
If $P$ is a logical statement then $P$ implies $(P \implies \mathrm{false}) \implies \mathrm{false}$
-/
lemma P_to_P_to_false_to_false (P : Prop) :  P → ((P → false) → false) :=
begin
   intros hp hpf,
   apply hpf,
   exact hp,

end


/-
Copyright (c) 2021 OpenAI. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kunhao Zheng, Stanislas Polu, David Renshaw, OpenAI GPT-f
-/
import mathzoo.imports.miniF2F

open_locale nat rat real big_operators topological_space

theorem mathd_algebra_132
  (x : ℝ)
  (f g : ℝ → ℝ)
  (h₀ : ∀ x, f x = x + 2)
  (h₁ : ∀ x, g x = x^2)
  (h₂ : f (g x) = g (f x)) :
  x = - 1/2 :=
begin
  field_simp * at *,
  nlinarith,
end


/-
Copyright (c) 2021 Oliver Nash. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Oliver Nash
-/
import algebra.lie.submodule

/-!
# Ideal operations for Lie algebras

Given a Lie module `M` over a Lie algebra `L`, there is a natural action of the Lie ideals of `L`
on the Lie submodules of `M`. In the special case that `M = L` with the adjoint action, this
provides a pairing of Lie ideals which is especially important. For example, it can be used to
define solvability / nilpotency of a Lie algebra via the derived / lower-central series.

## Main definitions

  * `lie_submodule.has_bracket`
  * `lie_submodule.lie_ideal_oper_eq_linear_span`
  * `lie_ideal.map_bracket_le`
  * `lie_ideal.comap_bracket_le`

## Notation

Given a Lie module `M` over a Lie algebra `L`, together with a Lie submodule `N ⊆ M` and a Lie
ideal `I ⊆ L`, we introduce the notation `⁅I, N⁆` for the Lie submodule of `M` corresponding to
the action defined in this file.

## Tags

lie algebra, ideal operation
-/

universes u v w w₁ w₂

namespace lie_submodule

variables {R : Type u} {L : Type v} {M : Type w} {M₂ : Type w₁}
variables [comm_ring R] [lie_ring L] [lie_algebra R L]
variables [add_comm_group M] [module R M] [lie_ring_module L M] [lie_module R L M]
variables [add_comm_group M₂] [module R M₂] [lie_ring_module L M₂] [lie_module R L M₂]
variables (N N' : lie_submodule R L M) (I J : lie_ideal R L) (N₂ : lie_submodule R L M₂)

section lie_ideal_operations

/-- Given a Lie module `M` over a Lie algebra `L`, the set of Lie ideals of `L` acts on the set
of submodules of `M`. -/
instance has_bracket : has_bracket (lie_ideal R L) (lie_submodule R L M) :=
⟨λ I N, lie_span R L { m | ∃ (x : I) (n : N), ⁅(x : L), (n : M)⁆ = m }⟩

lemma lie_ideal_oper_eq_span :
  ⁅I, N⁆ = lie_span R L { m | ∃ (x : I) (n : N), ⁅(x : L), (n : M)⁆ = m } := rfl

/-- See also `lie_submodule.lie_ideal_oper_eq_linear_span'` and
`lie_submodule.lie_ideal_oper_eq_tensor_map_range`. -/
lemma lie_ideal_oper_eq_linear_span :
  (↑⁅I, N⁆ : submodule R M) = submodule.span R { m | ∃ (x : I) (n : N), ⁅(x : L), (n : M)⁆ = m } :=
begin
  apply le_antisymm,
  { let s := {m : M | ∃ (x : ↥I) (n : ↥N), ⁅(x : L), (n : M)⁆ = m},
    have aux : ∀ (y : L) (m' ∈ submodule.span R s), ⁅y, m'⁆ ∈ submodule.span R s,
    { intros y m' hm', apply submodule.span_induction hm',
      { rintros m'' ⟨x, n, hm''⟩, rw [← hm'', leibniz_lie],
        refine submodule.add_mem _ _ _; apply submodule.subset_span,
        { use [⟨⁅y, ↑x⁆, I.lie_mem x.property⟩, n], refl, },
        { use [x, ⟨⁅y, ↑n⁆, N.lie_mem n.property⟩], refl, }, },
      { simp only [lie_zero, submodule.zero_mem], },
      { intros m₁ m₂ hm₁ hm₂, rw lie_add, exact submodule.add_mem _ hm₁ hm₂, },
      { intros t m'' hm'', rw lie_smul, exact submodule.smul_mem _ t hm'', }, },
    change _ ≤ ↑({ lie_mem := aux, ..submodule.span R s } : lie_submodule R L M),
    rw [coe_submodule_le_coe_submodule, lie_ideal_oper_eq_span, lie_span_le],
    exact submodule.subset_span, },
  { rw lie_ideal_oper_eq_span, apply submodule_span_le_lie_span, },
end

lemma lie_ideal_oper_eq_linear_span' :
  (↑⁅I, N⁆ : submodule R M) = submodule.span R { m | ∃ (x ∈ I) (n ∈ N), ⁅x, n⁆ = m } :=
begin
  rw lie_ideal_oper_eq_linear_span,
  congr,
  ext m,
  split,
  { rintros ⟨⟨x, hx⟩, ⟨n, hn⟩, rfl⟩,
    exact ⟨x, hx, n, hn, rfl⟩, },
  { rintros ⟨x, hx, n, hn, rfl⟩,
    exact ⟨⟨x, hx⟩, ⟨n, hn⟩, rfl⟩, },
end

lemma lie_le_iff : ⁅I, N⁆ ≤ N' ↔ ∀ (x ∈ I) (m ∈ N), ⁅x, m⁆ ∈ N' :=
begin
  rw [lie_ideal_oper_eq_span, lie_submodule.lie_span_le],
  refine ⟨λ h x hx m hm, h ⟨⟨x, hx⟩, ⟨m, hm⟩, rfl⟩, _⟩,
  rintros h _ ⟨⟨x, hx⟩, ⟨m, hm⟩, rfl⟩,
  exact h x hx m hm,
end

lemma lie_coe_mem_lie (x : I) (m : N) : ⁅(x : L), (m : M)⁆ ∈ ⁅I, N⁆ :=
by { rw lie_ideal_oper_eq_span, apply subset_lie_span, use [x, m], }

lemma lie_mem_lie {x : L} {m : M} (hx : x ∈ I) (hm : m ∈ N) : ⁅x, m⁆ ∈ ⁅I, N⁆ :=
N.lie_coe_mem_lie I ⟨x, hx⟩ ⟨m, hm⟩

lemma lie_comm : ⁅I, J⁆ = ⁅J, I⁆ :=
begin
  suffices : ∀ (I J : lie_ideal R L), ⁅I, J⁆ ≤ ⁅J, I⁆, { exact le_antisymm (this I J) (this J I), },
  clear I J, intros I J,
  rw [lie_ideal_oper_eq_span, lie_span_le], rintros x ⟨y, z, h⟩, rw ← h,
  rw [← lie_skew, ← lie_neg, ← lie_submodule.coe_neg],
  apply lie_coe_mem_lie,
end

lemma lie_le_right : ⁅I, N⁆ ≤ N :=
begin
  rw [lie_ideal_oper_eq_span, lie_span_le], rintros m ⟨x, n, hn⟩, rw ← hn,
  exact N.lie_mem n.property,
end

lemma lie_le_left : ⁅I, J⁆ ≤ I :=
by { rw lie_comm, exact lie_le_right I J, }

lemma lie_le_inf : ⁅I, J⁆ ≤ I ⊓ J :=
by { rw le_inf_iff, exact ⟨lie_le_left I J, lie_le_right J I⟩, }

@[simp] lemma lie_bot : ⁅I, (⊥ : lie_submodule R L M)⁆ = ⊥ :=
by { rw eq_bot_iff, apply lie_le_right, }

@[simp] lemma bot_lie : ⁅(⊥ : lie_ideal R L), N⁆ = ⊥ :=
begin
  suffices : ⁅(⊥ : lie_ideal R L), N⁆ ≤ ⊥, { exact le_bot_iff.mp this, },
  rw [lie_ideal_oper_eq_span, lie_span_le], rintros m ⟨⟨x, hx⟩, n, hn⟩, rw ← hn,
  change x ∈ (⊥ : lie_ideal R L) at hx, rw mem_bot at hx, simp [hx],
end

lemma lie_eq_bot_iff : ⁅I, N⁆ = ⊥ ↔ ∀ (x ∈ I) (m ∈ N), ⁅(x : L), m⁆ = 0 :=
begin
  rw [lie_ideal_oper_eq_span, lie_submodule.lie_span_eq_bot_iff],
  refine ⟨λ h x hx m hm, h ⁅x, m⁆ ⟨⟨x, hx⟩, ⟨m, hm⟩, rfl⟩, _⟩,
  rintros h - ⟨⟨x, hx⟩, ⟨⟨n, hn⟩, rfl⟩⟩,
  exact h x hx n hn,
end

lemma mono_lie (h₁ : I ≤ J) (h₂ : N ≤ N') : ⁅I, N⁆ ≤ ⁅J, N'⁆ :=
begin
  intros m h,
  rw [lie_ideal_oper_eq_span, mem_lie_span] at h, rw [lie_ideal_oper_eq_span, mem_lie_span],
  intros N hN, apply h, rintros m' ⟨⟨x, hx⟩, ⟨n, hn⟩, hm⟩, rw ← hm, apply hN,
  use [⟨x, h₁ hx⟩, ⟨n, h₂ hn⟩], refl,
end

lemma mono_lie_left (h : I ≤ J) : ⁅I, N⁆ ≤ ⁅J, N⁆ := mono_lie _ _ _ _ h (le_refl N)

lemma mono_lie_right (h : N ≤ N') : ⁅I, N⁆ ≤ ⁅I, N'⁆ := mono_lie _ _ _ _ (le_refl I) h

@[simp] lemma lie_sup : ⁅I, N ⊔ N'⁆ = ⁅I, N⁆ ⊔ ⁅I, N'⁆ :=
begin
  have h : ⁅I, N⁆ ⊔ ⁅I, N'⁆ ≤ ⁅I, N ⊔ N'⁆,
  { rw sup_le_iff, split; apply mono_lie_right; [exact le_sup_left, exact le_sup_right], },
  suffices : ⁅I, N ⊔ N'⁆ ≤ ⁅I, N⁆ ⊔ ⁅I, N'⁆, { exact le_antisymm this h, }, clear h,
  rw [lie_ideal_oper_eq_span, lie_span_le], rintros m ⟨x, ⟨n, hn⟩, h⟩, erw lie_submodule.mem_sup,
  erw lie_submodule.mem_sup at hn, rcases hn with ⟨n₁, hn₁, n₂, hn₂, hn'⟩,
  use ⁅(x : L), (⟨n₁, hn₁⟩ : N)⁆, split, { apply lie_coe_mem_lie, },
  use ⁅(x : L), (⟨n₂, hn₂⟩ : N')⁆, split, { apply lie_coe_mem_lie, },
  simp [← h, ← hn'],
end

@[simp] lemma sup_lie : ⁅I ⊔ J, N⁆ = ⁅I, N⁆ ⊔ ⁅J, N⁆ :=
begin
  have h : ⁅I, N⁆ ⊔ ⁅J, N⁆ ≤ ⁅I ⊔ J, N⁆,
  { rw sup_le_iff, split; apply mono_lie_left; [exact le_sup_left, exact le_sup_right], },
  suffices : ⁅I ⊔ J, N⁆ ≤ ⁅I, N⁆ ⊔ ⁅J, N⁆, { exact le_antisymm this h, }, clear h,
  rw [lie_ideal_oper_eq_span, lie_span_le], rintros m ⟨⟨x, hx⟩, n, h⟩, erw lie_submodule.mem_sup,
  erw lie_submodule.mem_sup at hx, rcases hx with ⟨x₁, hx₁, x₂, hx₂, hx'⟩,
  use ⁅((⟨x₁, hx₁⟩ : I) : L), (n : N)⁆, split, { apply lie_coe_mem_lie, },
  use ⁅((⟨x₂, hx₂⟩ : J) : L), (n : N)⁆, split, { apply lie_coe_mem_lie, },
  simp [← h, ← hx'],
end

@[simp] lemma lie_inf : ⁅I, N ⊓ N'⁆ ≤ ⁅I, N⁆ ⊓ ⁅I, N'⁆ :=
by { rw le_inf_iff, split; apply mono_lie_right; [exact inf_le_left, exact inf_le_right], }

@[simp] lemma inf_lie : ⁅I ⊓ J, N⁆ ≤ ⁅I, N⁆ ⊓ ⁅J, N⁆ :=
by { rw le_inf_iff, split; apply mono_lie_left; [exact inf_le_left, exact inf_le_right], }

variables (f : M →ₗ⁅R,L⁆ M₂)

lemma map_bracket_eq : map f ⁅I, N⁆ = ⁅I, map f N⁆ :=
begin
  rw [← coe_to_submodule_eq_iff, coe_submodule_map, lie_ideal_oper_eq_linear_span,
    lie_ideal_oper_eq_linear_span, submodule.map_span],
  congr,
  ext m,
  split,
  { rintros ⟨-, ⟨⟨x, ⟨n, hn⟩, rfl⟩, hm⟩⟩,
    simp only [lie_module_hom.coe_to_linear_map, lie_module_hom.map_lie] at hm,
    exact ⟨x, ⟨f n, (mem_map (f n)).mpr ⟨n, hn, rfl⟩⟩, hm⟩, },
  { rintros ⟨x, ⟨m₂, hm₂ : m₂ ∈ map f N⟩, rfl⟩,
    obtain ⟨n, hn, rfl⟩ := (mem_map m₂).mp hm₂,
    exact ⟨⁅x, n⁆, ⟨x, ⟨n, hn⟩, rfl⟩, by simp⟩, },
end

lemma map_comap_eq (hf : N₂ ≤ f.range) : map f (comap f N₂) = N₂ :=
begin
  rw set_like.ext'_iff,
  exact set.image_preimage_eq_of_subset hf,
end

lemma le_comap_map : N ≤ comap f (map f N) :=
(N : set M).subset_preimage_image f

lemma comap_map_eq (hf : f.ker = ⊥) : comap f (map f N) = N :=
begin
  rw set_like.ext'_iff,
  exact (N : set M).preimage_image_eq (f.ker_eq_bot.mp hf),
end

lemma comap_bracket_eq (hf₁ : f.ker = ⊥) (hf₂ : N₂ ≤ f.range) :
  comap f ⁅I, N₂⁆ = ⁅I, comap f N₂⁆ :=
begin
  conv_lhs { rw ← map_comap_eq N₂ f hf₂, },
  rw [← map_bracket_eq, comap_map_eq _ f hf₁],
end

@[simp] lemma map_comap_incl : map N.incl (comap N.incl N') = N ⊓ N' :=
begin
  rw ← coe_to_submodule_eq_iff,
  exact (N : submodule R M).map_comap_subtype N',
end

end lie_ideal_operations

end lie_submodule

namespace lie_ideal

open lie_algebra

variables {R : Type u} {L : Type v} {L' : Type w₂}
variables [comm_ring R] [lie_ring L] [lie_algebra R L] [lie_ring L'] [lie_algebra R L']
variables (f : L →ₗ⁅R⁆ L') (I : lie_ideal R L) (J : lie_ideal R L')

/-- Note that the inequality can be strict; e.g., the inclusion of an Abelian subalgebra of a
simple algebra. -/
lemma map_bracket_le {I₁ I₂ : lie_ideal R L} : map f ⁅I₁, I₂⁆ ≤ ⁅map f I₁, map f I₂⁆ :=
begin
  rw map_le_iff_le_comap, erw lie_submodule.lie_span_le,
  intros x hx, obtain ⟨⟨y₁, hy₁⟩, ⟨y₂, hy₂⟩, hx⟩ := hx, rw ← hx,
  let fy₁ : ↥(map f I₁) := ⟨f y₁, mem_map hy₁⟩,
  let fy₂ : ↥(map f I₂) := ⟨f y₂, mem_map hy₂⟩,
  change _ ∈ comap f ⁅map f I₁, map f I₂⁆,
  simp only [submodule.coe_mk, mem_comap, lie_hom.map_lie],
  exact lie_submodule.lie_coe_mem_lie _ _ fy₁ fy₂,
end

lemma map_bracket_eq {I₁ I₂ : lie_ideal R L} (h : function.surjective f) :
  map f ⁅I₁, I₂⁆ = ⁅map f I₁, map f I₂⁆ :=
begin
  suffices : ⁅map f I₁, map f I₂⁆ ≤ map f ⁅I₁, I₂⁆, { exact le_antisymm (map_bracket_le f) this, },
  rw [← lie_submodule.coe_submodule_le_coe_submodule, coe_map_of_surjective h,
    lie_submodule.lie_ideal_oper_eq_linear_span,
    lie_submodule.lie_ideal_oper_eq_linear_span, linear_map.map_span],
  apply submodule.span_mono,
  rintros x ⟨⟨z₁, h₁⟩, ⟨z₂, h₂⟩, rfl⟩,
  obtain ⟨y₁, rfl⟩ := mem_map_of_surjective h h₁,
  obtain ⟨y₂, rfl⟩ := mem_map_of_surjective h h₂,
  use [⁅(y₁ : L), (y₂ : L)⁆, y₁, y₂],
  apply f.map_lie,
end

lemma comap_bracket_le {J₁ J₂ : lie_ideal R L'} : ⁅comap f J₁, comap f J₂⁆ ≤ comap f ⁅J₁, J₂⁆ :=
begin
  rw ← map_le_iff_le_comap,
  exact le_trans (map_bracket_le f) (lie_submodule.mono_lie _ _ _ _ map_comap_le map_comap_le),
end

variables {f}

lemma map_comap_incl {I₁ I₂ : lie_ideal R L} : map I₁.incl (comap I₁.incl I₂) = I₁ ⊓ I₂ :=
by { conv_rhs { rw ← I₁.incl_ideal_range, }, rw ← map_comap_eq, exact I₁.incl_is_ideal_morphism, }

lemma comap_bracket_eq {J₁ J₂ : lie_ideal R L'} (h : f.is_ideal_morphism) :
  comap f ⁅f.ideal_range ⊓ J₁, f.ideal_range ⊓ J₂⁆ = ⁅comap f J₁, comap f J₂⁆ ⊔ f.ker :=
begin
  rw [← lie_submodule.coe_to_submodule_eq_iff, comap_coe_submodule,
    lie_submodule.sup_coe_to_submodule, f.ker_coe_submodule, ← submodule.comap_map_eq,
    lie_submodule.lie_ideal_oper_eq_linear_span, lie_submodule.lie_ideal_oper_eq_linear_span,
    linear_map.map_span],
  congr, simp only [lie_hom.coe_to_linear_map, set.mem_set_of_eq], ext y,
  split,
  { rintros ⟨⟨x₁, hx₁⟩, ⟨x₂, hx₂⟩, hy⟩, rw ← hy,
    erw [lie_submodule.mem_inf, f.mem_ideal_range_iff h] at hx₁ hx₂,
    obtain ⟨⟨z₁, hz₁⟩, hz₁'⟩ := hx₁, rw ← hz₁ at hz₁',
    obtain ⟨⟨z₂, hz₂⟩, hz₂'⟩ := hx₂, rw ← hz₂ at hz₂',
    use [⁅z₁, z₂⁆, ⟨z₁, hz₁'⟩, ⟨z₂, hz₂'⟩, rfl],
    simp only [hz₁, hz₂, submodule.coe_mk, lie_hom.map_lie], },
  { rintros ⟨x, ⟨⟨z₁, hz₁⟩, ⟨z₂, hz₂⟩, hx⟩, hy⟩, rw [← hy, ← hx],
    have hz₁' : f z₁ ∈ f.ideal_range ⊓ J₁,
    { rw lie_submodule.mem_inf, exact ⟨f.mem_ideal_range, hz₁⟩, },
    have hz₂' : f z₂ ∈ f.ideal_range ⊓ J₂,
    { rw lie_submodule.mem_inf, exact ⟨f.mem_ideal_range, hz₂⟩, },
    use [⟨f z₁, hz₁'⟩, ⟨f z₂, hz₂'⟩], simp only [submodule.coe_mk, lie_hom.map_lie], },
end

lemma map_comap_bracket_eq {J₁ J₂ : lie_ideal R L'} (h : f.is_ideal_morphism) :
  map f ⁅comap f J₁, comap f J₂⁆ = ⁅f.ideal_range ⊓ J₁, f.ideal_range ⊓ J₂⁆ :=
by { rw [← map_sup_ker_eq_map, ← comap_bracket_eq h, map_comap_eq h, inf_eq_right],
     exact le_trans (lie_submodule.lie_le_left _ _) inf_le_left, }

lemma comap_bracket_incl {I₁ I₂ : lie_ideal R L} :
  ⁅comap I.incl I₁, comap I.incl I₂⁆ = comap I.incl ⁅I ⊓ I₁, I ⊓ I₂⁆ :=
begin
  conv_rhs { congr, skip, rw ← I.incl_ideal_range, }, rw comap_bracket_eq,
  simp only [ker_incl, sup_bot_eq], exact I.incl_is_ideal_morphism,
end

/-- This is a very useful result; it allows us to use the fact that inclusion distributes over the
Lie bracket operation on ideals, subject to the conditions shown. -/
lemma comap_bracket_incl_of_le {I₁ I₂ : lie_ideal R L} (h₁ : I₁ ≤ I) (h₂ : I₂ ≤ I) :
  ⁅comap I.incl I₁, comap I.incl I₂⁆ = comap I.incl ⁅I₁, I₂⁆ :=
by { rw comap_bracket_incl, rw ← inf_eq_right at h₁ h₂, rw [h₁, h₂], }

end lie_ideal


/-
Copyright (c) 2019 Jean Lo. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jean Lo, Yaël Dillies, Moritz Doll
-/
import analysis.locally_convex.basic
import data.real.pointwise
import data.real.sqrt
import topology.algebra.filter_basis
import topology.algebra.module.locally_convex

/-!
# Seminorms

This file defines seminorms.

A seminorm is a function to the reals which is positive-semidefinite, absolutely homogeneous, and
subadditive. They are closely related to convex sets and a topological vector space is locally
convex if and only if its topology is induced by a family of seminorms.

## Main declarations

For an addditive group:
* `add_group_seminorm`: A function `f` from an add_group `G` to the reals that preserves zero,
takes nonnegative values, is subadditive and such that `f (-x) = f x` for all `x ∈ G`.

For a module over a normed ring:
* `seminorm`: A function to the reals that is positive-semidefinite, absolutely homogeneous, and
  subadditive.
* `norm_seminorm 𝕜 E`: The norm on `E` as a seminorm.

## References

* [H. H. Schaefer, *Topological Vector Spaces*][schaefer1966]

## Tags

seminorm, locally convex, LCTVS
-/

set_option old_structure_cmd true

open normed_field set
open_locale big_operators nnreal pointwise topological_space

variables {R R' 𝕜 E F G ι : Type*}

/-- A seminorm on an add_group `G` is a function A function `f : G → ℝ` that preserves zero, takes
nonnegative values, is subadditive and such that `f (-x) = f x` for all `x ∈ G`. -/
structure add_group_seminorm (G : Type*) [add_group G]
  extends zero_hom G ℝ :=
(nonneg' : ∀ r, 0 ≤ to_fun r)
(add_le' : ∀ r s, to_fun (r + s) ≤ to_fun r + to_fun s)
(neg' : ∀ r, to_fun (- r) = to_fun r)

attribute [nolint doc_blame] add_group_seminorm.to_zero_hom

namespace add_group_seminorm

variables [add_group E]

instance zero_hom_class : zero_hom_class (add_group_seminorm E) E ℝ :=
{ coe := λ f, f.to_fun,
  coe_injective' := λ f g h, by cases f; cases g; congr',
  map_zero := λ f, f.map_zero' }

/-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`. -/
instance : has_coe_to_fun (add_group_seminorm E) (λ _, E → ℝ) := ⟨λ p, p.to_fun⟩

@[ext] lemma ext {p q : add_group_seminorm E} (h : ∀ x, (p : E → ℝ) x = q x) : p = q :=
fun_like.ext p q h

instance : has_zero (add_group_seminorm E) :=
⟨{ to_fun   := 0,
  nonneg'   := λ r, le_refl _,
  map_zero' := pi.zero_apply _,
  add_le'   := λ _ _, eq.ge (zero_add _),
  neg'      := λ x, rfl}⟩

@[simp] lemma coe_zero : ⇑(0 : add_group_seminorm E) = 0 := rfl

@[simp] lemma zero_apply (x : E) : (0 : add_group_seminorm E) x = 0 := rfl

instance : inhabited (add_group_seminorm E) := ⟨0⟩

variables (p : add_group_seminorm E) (x y : E) (r : ℝ)

protected lemma nonneg : 0 ≤ p x := p.nonneg' _
@[simp] protected lemma map_zero : p 0 = 0 := p.map_zero'
protected lemma add_le : p (x + y) ≤ p x + p y := p.add_le' _ _
@[simp] protected lemma neg : p (- x) = p x := p.neg' _

/-- Any action on `ℝ` which factors through `ℝ≥0` applies to an `add_group_seminorm`. -/
instance [has_scalar R ℝ] [has_scalar R ℝ≥0] [is_scalar_tower R ℝ≥0 ℝ] :
  has_scalar R (add_group_seminorm E) :=
{ smul := λ r p,
  { to_fun := λ x, r • p x,
    nonneg' := λ x, begin
      simp only [←smul_one_smul ℝ≥0 r (_ : ℝ), nnreal.smul_def, smul_eq_mul],
      exact mul_nonneg (nnreal.coe_nonneg _) (p.nonneg _)
    end,
    map_zero' := by simp only [←smul_one_smul ℝ≥0 r (_ : ℝ), nnreal.smul_def, smul_eq_mul,
      p.map_zero, mul_zero],
    add_le' := λ _ _, begin
      simp only [←smul_one_smul ℝ≥0 r (_ : ℝ), nnreal.smul_def, smul_eq_mul],
      exact (mul_le_mul_of_nonneg_left (p.add_le _ _) (nnreal.coe_nonneg _)).trans_eq
        (mul_add _ _ _),
    end,
    neg' := λ x, by rw p.neg }}

instance [has_scalar R ℝ] [has_scalar R ℝ≥0] [is_scalar_tower R ℝ≥0 ℝ]
  [has_scalar R' ℝ] [has_scalar R' ℝ≥0] [is_scalar_tower R' ℝ≥0 ℝ]
  [has_scalar R R'] [is_scalar_tower R R' ℝ] :
  is_scalar_tower R R' (add_group_seminorm E) :=
{ smul_assoc := λ r a p, ext $ λ x, smul_assoc r a (p x) }

@[simp] lemma coe_smul [has_scalar R ℝ] [has_scalar R ℝ≥0] [is_scalar_tower R ℝ≥0 ℝ]
  (r : R) (p : add_group_seminorm E) : ⇑(r • p) = r • p := rfl

@[simp] lemma smul_apply [has_scalar R ℝ] [has_scalar R ℝ≥0] [is_scalar_tower R ℝ≥0 ℝ]
  (r : R) (p : add_group_seminorm E) (x : E) : (r • p) x = r • p x := rfl

instance : has_add (add_group_seminorm E) :=
{ add := λ p q,
  { to_fun    := λ x, p x + q x,
    nonneg'   := λ x, add_nonneg (p.nonneg _) (q.nonneg _),
    map_zero' := by rw [p.map_zero, q.map_zero, zero_add],
    add_le'   := λ _ _, has_le.le.trans_eq (add_le_add (p.add_le _ _) (q.add_le _ _))
      (add_add_add_comm _ _ _ _),
    neg' := λ x, by rw [p.neg, q.neg] }}

@[simp] lemma coe_add (p q : add_group_seminorm E) : ⇑(p + q) = p + q := rfl

@[simp] lemma add_apply (p q : add_group_seminorm E) (x : E) : (p + q) x = p x + q x := rfl

-- TODO: define `has_Sup` too, from the skeleton at
-- https://github.com/leanprover-community/mathlib/pull/11329#issuecomment-1008915345
noncomputable instance : has_sup (add_group_seminorm E) :=
{ sup := λ p q,
  { to_fun  := p ⊔ q,
    nonneg' := λ x, begin
      simp only [pi.sup_apply, le_sup_iff],
      exact or.intro_left _ (p.nonneg _),
    end,
    map_zero' := begin
      simp only [pi.sup_apply],
      rw [← p.map_zero, sup_eq_left, p.map_zero, q.map_zero],
    end,
    add_le' := λ x y, sup_le
      ((p.add_le x y).trans $ add_le_add le_sup_left le_sup_left)
      ((q.add_le x y).trans $ add_le_add le_sup_right le_sup_right),
    neg' := λ x, by rw [pi.sup_apply, pi.sup_apply, p.neg, q.neg] }}

@[simp] lemma coe_sup (p q : add_group_seminorm E) : ⇑(p ⊔ q) = p ⊔ q := rfl
lemma sup_apply (p q : add_group_seminorm E) (x : E) : (p ⊔ q) x = p x ⊔ q x := rfl

lemma smul_sup [has_scalar R ℝ] [has_scalar R ℝ≥0] [is_scalar_tower R ℝ≥0 ℝ]
  (r : R) (p q : add_group_seminorm E) :
  r • (p ⊔ q) = r • p ⊔ r • q :=
have real.smul_max : ∀ x y : ℝ, r • max x y = max (r • x) (r • y),
from λ x y, by simpa only [←smul_eq_mul, ←nnreal.smul_def, smul_one_smul ℝ≥0 r (_ : ℝ)]
                     using mul_max_of_nonneg x y (r • 1 : ℝ≥0).prop,
ext $ λ x, real.smul_max _ _

instance : partial_order (add_group_seminorm E) := partial_order.lift _ fun_like.coe_injective

lemma le_def (p q : add_group_seminorm E) : p ≤ q ↔ (p : E → ℝ) ≤ q := iff.rfl
lemma lt_def (p q : add_group_seminorm E) : p < q ↔ (p : E → ℝ) < q := iff.rfl

noncomputable instance : semilattice_sup (add_group_seminorm E) :=
function.injective.semilattice_sup _ fun_like.coe_injective coe_sup

section add_comm_group
variable [add_comm_group G]

variables (q : add_group_seminorm G)

protected lemma sub_le (x y : G) : q (x - y) ≤ q x + q y :=
calc
  q (x - y)
      = q (x + -y) : by rw sub_eq_add_neg
  ... ≤ q x + q (-y) : q.add_le x (-y)
  ... = q x + q y : by rw q.neg

lemma sub_rev (x y : G) : q (x - y) = q (y - x) :=
by rw [←neg_sub, q.neg]

/-- The direct path from 0 to y is shorter than the path with x "inserted" in between. -/
lemma le_insert (x y : G) : q y ≤ q x + q (x - y) :=
calc q y = q (x - (x - y)) : by rw sub_sub_cancel
... ≤ q x + q (x - y) : q.sub_le  _ _

/-- The direct path from 0 to x is shorter than the path with y "inserted" in between. -/
lemma le_insert' (x y : G) : q x ≤ q y + q (x - y) :=
by { rw sub_rev, exact le_insert _ _ _ }

private lemma bdd_below_range_add (x : G) (p q : add_group_seminorm G) :
  bdd_below (range (λ (u : G), p u + q (x - u))) :=
by { use 0, rintro _ ⟨x, rfl⟩, exact add_nonneg (p.nonneg _) (q.nonneg _) }

noncomputable instance : has_inf (add_group_seminorm G) :=
{ inf := λ p q,
  { to_fun    := λ x, ⨅ u : G, p u + q (x-u),
    map_zero' := cinfi_eq_of_forall_ge_of_forall_gt_exists_lt
        (λ x, add_nonneg (p.nonneg _) (q.nonneg _))
        (λ r hr, ⟨0, by simpa [sub_zero, p.map_zero, q.map_zero, add_zero] using hr⟩),
    nonneg'   := λ x, le_cinfi (λ x, add_nonneg (p.nonneg _) (q.nonneg _)),
    add_le'   := λ x y, begin
      refine le_cinfi_add_cinfi (λ u v, _),
      apply cinfi_le_of_le (bdd_below_range_add _ _ _) (v+u), dsimp only,
      convert add_le_add (p.add_le v u) (q.add_le (y-v) (x-u)) using 1,
      { rw show x + y - (v + u) = y - v + (x - u), by abel },
      { abel },
    end,
    neg' := λ x, begin
      have : (⨅ (u : G), p u + q (x - u) : ℝ) = ⨅ (u : G), p (- u) + q (x + u),
      { apply function.surjective.infi_congr (λ (x : G), -x) neg_surjective,
        { intro u,
          simp only [neg_neg, add_right_inj, sub_eq_add_neg] }},
      rw this,
      apply congr_arg,
      ext u,
      rw [p.neg, sub_eq_add_neg, ← neg_add_rev, add_comm u, q.neg],
    end }}

@[simp] lemma inf_apply (p q : add_group_seminorm G) (x : G) :
  (p ⊓ q) x = ⨅ u : G, p u + q (x-u) := rfl

noncomputable instance : lattice (add_group_seminorm G) :=
{ inf := (⊓),
  inf_le_left := λ p q x, begin
    apply cinfi_le_of_le (bdd_below_range_add _ _ _) x,
    simp only [sub_self, map_zero, add_zero],
  end,
  inf_le_right := λ p q x, begin
    apply cinfi_le_of_le (bdd_below_range_add _ _ _) (0:G),
    simp only [sub_self, map_zero, zero_add, sub_zero],
  end,
  le_inf := λ a b c hab hac x,
    le_cinfi $ λ u, le_trans (a.le_insert' _ _) (add_le_add (hab _) (hac _)),
  ..add_group_seminorm.semilattice_sup }

end add_comm_group

section comp
variables [add_group F] [add_group G]

/-- Composition of an add_group_seminorm with an add_monoid_hom is an add_group_seminorm. -/
def comp (p : add_group_seminorm F) (f : E →+ F) : add_group_seminorm E :=
{ to_fun    := λ x, p (f x),
  nonneg'   := λ x, p.nonneg _,
  map_zero' := by rw [f.map_zero, p.map_zero],
  add_le'   := λ _ _, by apply eq.trans_le (congr_arg p (f.map_add _ _)) (p.add_le _ _),
  neg'      := λ x, by rw [map_neg, p.neg] }

@[simp] lemma coe_comp (p : add_group_seminorm F) (f : E →+ F) : ⇑(p.comp f) = p ∘ f := rfl

@[simp] lemma comp_apply (p : add_group_seminorm F) (f : E →+ F) (x : E) :
  (p.comp f) x = p (f x) := rfl

@[simp] lemma comp_id (p : add_group_seminorm E) : p.comp (add_monoid_hom.id _) = p :=
ext $ λ _, rfl

@[simp]

@[simp] lemma zero_comp (f : E →+ F) : (0 : add_group_seminorm F).comp f = 0 :=
ext $ λ _, rfl

lemma comp_comp (p : add_group_seminorm G) (g : F →+ G) (f : E →+ F) :
  p.comp (g.comp f) = (p.comp g).comp f :=
ext $ λ _, rfl

lemma add_comp (p q : add_group_seminorm F) (f : E →+ F) : (p + q).comp f = p.comp f + q.comp f :=
ext $ λ _, rfl

lemma comp_add_le {A B : Type*} [add_comm_group A] [add_comm_group B]
  (p : add_group_seminorm B) (f g : A →+ B) : p.comp (f + g) ≤ p.comp f + p.comp g :=
λ _, p.add_le _ _

lemma comp_mono {p : add_group_seminorm F} {q : add_group_seminorm F} (f : E →+ F) (hp : p ≤ q) :
  p.comp f ≤ q.comp f := λ _, hp _

end comp

end add_group_seminorm

/-- A seminorm on a module over a normed ring is a function to the reals that is positive
semidefinite, positive homogeneous, and subadditive. -/
structure seminorm (𝕜 : Type*) (E : Type*) [semi_normed_ring 𝕜] [add_group E] [has_scalar 𝕜 E]
  extends add_group_seminorm E :=
(smul' : ∀ (a : 𝕜) (x : E), to_fun (a • x) = ∥a∥ * to_fun x)

attribute [nolint doc_blame] seminorm.to_add_group_seminorm

private lemma map_zero.of_smul {𝕜 : Type*} {E : Type*} [semi_normed_ring 𝕜] [add_group E]
  [smul_with_zero 𝕜 E] {f : E → ℝ} (smul : ∀ (a : 𝕜) (x : E), f (a • x) = ∥a∥ * f x) : f 0 = 0 :=
calc f 0 = f ((0 : 𝕜) • 0) : by rw zero_smul
     ... = 0 : by rw [smul, norm_zero, zero_mul]

private lemma neg.of_smul {𝕜 : Type*} {E : Type*} [semi_normed_ring 𝕜] [add_comm_group E]
  [module 𝕜 E] {f : E → ℝ} (smul : ∀ (a : 𝕜) (x : E), f (a • x) = ∥a∥ * f x) (x : E) :
  f (-x) = f x :=
by rw [←neg_one_smul 𝕜, smul, norm_neg, ← smul, one_smul]

private lemma nonneg.of {𝕜 : Type*} {E : Type*} [semi_normed_ring 𝕜] [add_comm_group E] [module 𝕜 E]
  {f : E → ℝ} (add_le : ∀ (x y : E), f (x + y) ≤ f x + f y)
  (smul : ∀ (a : 𝕜) (x : E), f (a • x) = ∥a∥ * f x) (x : E) : 0 ≤ f x :=
have h: 0 ≤ 2 * f x, from
calc 0 = f (x + (- x)) : by rw [add_neg_self, map_zero.of_smul smul]
...    ≤ f x + f (-x)  : add_le _ _
...    = 2 * f x : by rw [neg.of_smul smul, two_mul],
nonneg_of_mul_nonneg_left h zero_lt_two

/-- Alternative constructor for a `seminorm` on an `add_comm_group E` that is a module over a
`semi_norm_ring 𝕜`. -/
def seminorm.of {𝕜 : Type*} {E : Type*} [semi_normed_ring 𝕜] [add_comm_group E] [module 𝕜 E]
  (f : E → ℝ) (add_le : ∀ (x y : E), f (x + y) ≤ f x + f y)
  (smul : ∀ (a : 𝕜) (x : E), f (a • x) = ∥a∥ * f x) : seminorm 𝕜 E :=
{ to_fun    := f,
  map_zero' := map_zero.of_smul smul,
  nonneg'   := nonneg.of add_le smul,
  add_le'   := add_le,
  smul'     := smul,
  neg'      := neg.of_smul smul }

namespace seminorm

section semi_normed_ring
variables [semi_normed_ring 𝕜]

section add_group
variables [add_group E]

section has_scalar
variables [has_scalar 𝕜 E]

instance zero_hom_class : zero_hom_class (seminorm 𝕜 E) E ℝ :=
{ coe := λ f, f.to_fun,
  coe_injective' := λ f g h, by cases f; cases g; congr',
  map_zero := λ f, f.map_zero' }

/-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`. -/
instance : has_coe_to_fun (seminorm 𝕜 E) (λ _, E → ℝ) := ⟨λ p, p.to_fun⟩

@[ext] lemma ext {p q : seminorm 𝕜 E} (h : ∀ x, (p : E → ℝ) x = q x) : p = q := fun_like.ext p q h

instance : has_zero (seminorm 𝕜 E) :=
⟨{ smul' := λ _ _, (mul_zero _).symm,
  ..add_group_seminorm.has_zero.zero }⟩

@[simp] lemma coe_zero : ⇑(0 : seminorm 𝕜 E) = 0 := rfl

@[simp] lemma zero_apply (x : E) : (0 : seminorm 𝕜 E) x = 0 := rfl

instance : inhabited (seminorm 𝕜 E) := ⟨0⟩

variables (p : seminorm 𝕜 E) (c : 𝕜) (x y : E) (r : ℝ)

protected lemma nonneg : 0 ≤ p x := p.nonneg' _
protected lemma map_zero : p 0 = 0 := p.map_zero'
protected lemma smul : p (c • x) = ∥c∥ * p x := p.smul' _ _
protected lemma add_le : p (x + y) ≤ p x + p y := p.add_le' _ _

/-- Any action on `ℝ` which factors through `ℝ≥0` applies to a seminorm. -/
instance [has_scalar R ℝ] [has_scalar R ℝ≥0] [is_scalar_tower R ℝ≥0 ℝ] :
  has_scalar R (seminorm 𝕜 E) :=
{ smul := λ r p,
  { to_fun  := λ x, r • p x,
    smul' := λ _ _, begin
      simp only [←smul_one_smul ℝ≥0 r (_ : ℝ), nnreal.smul_def, smul_eq_mul],
      rw [p.smul, mul_left_comm],
    end,
    ..(r • p.to_add_group_seminorm) }}

instance [has_scalar R ℝ] [has_scalar R ℝ≥0] [is_scalar_tower R ℝ≥0 ℝ]
  [has_scalar R' ℝ] [has_scalar R' ℝ≥0] [is_scalar_tower R' ℝ≥0 ℝ]
  [has_scalar R R'] [is_scalar_tower R R' ℝ] :
  is_scalar_tower R R' (seminorm 𝕜 E) :=
{ smul_assoc := λ r a p, ext $ λ x, smul_assoc r a (p x) }

lemma coe_smul [has_scalar R ℝ] [has_scalar R ℝ≥0] [is_scalar_tower R ℝ≥0 ℝ]
  (r : R) (p : seminorm 𝕜 E) : ⇑(r • p) = r • p := rfl

@[simp] lemma smul_apply [has_scalar R ℝ] [has_scalar R ℝ≥0] [is_scalar_tower R ℝ≥0 ℝ]
  (r : R) (p : seminorm 𝕜 E) (x : E) : (r • p) x = r • p x := rfl

instance : has_add (seminorm 𝕜 E) :=
{ add := λ p q,
  { to_fun    := λ x, p x + q x,
    smul'     := λ a x, by simp only [p.smul, q.smul, mul_add],
    ..(p.to_add_group_seminorm + q.to_add_group_seminorm) }}

lemma coe_add (p q : seminorm 𝕜 E) : ⇑(p + q) = p + q := rfl

@[simp] lemma add_apply (p q : seminorm 𝕜 E) (x : E) : (p + q) x = p x + q x := rfl

instance : add_monoid (seminorm 𝕜 E) :=
fun_like.coe_injective.add_monoid _ rfl coe_add (λ p n, coe_smul n p)

instance : ordered_cancel_add_comm_monoid (seminorm 𝕜 E) :=
fun_like.coe_injective.ordered_cancel_add_comm_monoid _ rfl coe_add (λ p n, coe_smul n p)

instance [monoid R] [mul_action R ℝ] [has_scalar R ℝ≥0] [is_scalar_tower R ℝ≥0 ℝ] :
  mul_action R (seminorm 𝕜 E) :=
fun_like.coe_injective.mul_action _ coe_smul

variables (𝕜 E)

/-- `coe_fn` as an `add_monoid_hom`. Helper definition for showing that `seminorm 𝕜 E` is
a module. -/
@[simps]
def coe_fn_add_monoid_hom : add_monoid_hom (seminorm 𝕜 E) (E → ℝ) := ⟨coe_fn, coe_zero, coe_add⟩

lemma coe_fn_add_monoid_hom_injective : function.injective (coe_fn_add_monoid_hom 𝕜 E) :=
show @function.injective (seminorm 𝕜 E) (E → ℝ) coe_fn, from fun_like.coe_injective

variables {𝕜 E}

instance [monoid R] [distrib_mul_action R ℝ] [has_scalar R ℝ≥0] [is_scalar_tower R ℝ≥0 ℝ] :
  distrib_mul_action R (seminorm 𝕜 E) :=
(coe_fn_add_monoid_hom_injective 𝕜 E).distrib_mul_action _ coe_smul

instance [semiring R] [module R ℝ] [has_scalar R ℝ≥0] [is_scalar_tower R ℝ≥0 ℝ] :
  module R (seminorm 𝕜 E) :=
(coe_fn_add_monoid_hom_injective 𝕜 E).module R _ coe_smul

-- TODO: define `has_Sup` too, from the skeleton at
-- https://github.com/leanprover-community/mathlib/pull/11329#issuecomment-1008915345
noncomputable instance : has_sup (seminorm 𝕜 E) :=
{ sup := λ p q,
  { to_fun  := p ⊔ q,
    smul' := λ x v, (congr_arg2 max (p.smul x v) (q.smul x v)).trans $
      (mul_max_of_nonneg _ _ $ norm_nonneg x).symm,
    ..(p.to_add_group_seminorm ⊔ q.to_add_group_seminorm) } }

@[simp] lemma coe_sup (p q : seminorm 𝕜 E) : ⇑(p ⊔ q) = p ⊔ q := rfl
lemma sup_apply (p q : seminorm 𝕜 E) (x : E) : (p ⊔ q) x = p x ⊔ q x := rfl

lemma smul_sup [has_scalar R ℝ] [has_scalar R ℝ≥0] [is_scalar_tower R ℝ≥0 ℝ]
  (r : R) (p q : seminorm 𝕜 E) :
  r • (p ⊔ q) = r • p ⊔ r • q :=
have real.smul_max : ∀ x y : ℝ, r • max x y = max (r • x) (r • y),
from λ x y, by simpa only [←smul_eq_mul, ←nnreal.smul_def, smul_one_smul ℝ≥0 r (_ : ℝ)]
                     using mul_max_of_nonneg x y (r • 1 : ℝ≥0).prop,
ext $ λ x, real.smul_max _ _

instance : partial_order (seminorm 𝕜 E) :=
  partial_order.lift _ fun_like.coe_injective

lemma le_def (p q : seminorm 𝕜 E) : p ≤ q ↔ (p : E → ℝ) ≤ q := iff.rfl
lemma lt_def (p q : seminorm 𝕜 E) : p < q ↔ (p : E → ℝ) < q := iff.rfl

noncomputable instance : semilattice_sup (seminorm 𝕜 E) :=
function.injective.semilattice_sup _ fun_like.coe_injective coe_sup

end has_scalar

end add_group

section module
variables [add_comm_group E] [add_comm_group F] [add_comm_group G]
variables [module 𝕜 E] [module 𝕜 F] [module 𝕜 G]
variables [has_scalar R ℝ] [has_scalar R ℝ≥0] [is_scalar_tower R ℝ≥0 ℝ]

/-- Composition of a seminorm with a linear map is a seminorm. -/
def comp (p : seminorm 𝕜 F) (f : E →ₗ[𝕜] F) : seminorm 𝕜 E :=
{ to_fun    := λ x, p (f x),
  smul'     := λ _ _, (congr_arg p (f.map_smul _ _)).trans (p.smul _ _),
  ..(p.to_add_group_seminorm.comp f.to_add_monoid_hom) }

lemma coe_comp (p : seminorm 𝕜 F) (f : E →ₗ[𝕜] F) : ⇑(p.comp f) = p ∘ f := rfl

@[simp] lemma comp_apply (p : seminorm 𝕜 F) (f : E →ₗ[𝕜] F) (x : E) : (p.comp f) x = p (f x) := rfl

@[simp] lemma comp_id (p : seminorm 𝕜 E) : p.comp linear_map.id = p :=
ext $ λ _, rfl

@[simp] lemma comp_zero (p : seminorm 𝕜 F) : p.comp (0 : E →ₗ[𝕜] F) = 0 :=
ext $ λ _, map_zero p

@[simp] lemma zero_comp (f : E →ₗ[𝕜] F) : (0 : seminorm 𝕜 F).comp f = 0 :=
ext $ λ _, rfl

lemma comp_comp (p : seminorm 𝕜 G) (g : F →ₗ[𝕜] G) (f : E →ₗ[𝕜] F) :
  p.comp (g.comp f) = (p.comp g).comp f :=
ext $ λ _, rfl

lemma add_comp (p q : seminorm 𝕜 F) (f : E →ₗ[𝕜] F) : (p + q).comp f = p.comp f + q.comp f :=
ext $ λ _, rfl

lemma comp_add_le (p : seminorm 𝕜 F) (f g : E →ₗ[𝕜] F) : p.comp (f + g) ≤ p.comp f + p.comp g :=
λ _, p.add_le _ _

lemma smul_comp (p : seminorm 𝕜 F) (f : E →ₗ[𝕜] F) (c : R) : (c • p).comp f = c • (p.comp f) :=
ext $ λ _, rfl

lemma comp_mono {p : seminorm 𝕜 F} {q : seminorm 𝕜 F} (f : E →ₗ[𝕜] F) (hp : p ≤ q) :
  p.comp f ≤ q.comp f := λ _, hp _

/-- The composition as an `add_monoid_hom`. -/
@[simps] def pullback (f : E →ₗ[𝕜] F) : add_monoid_hom (seminorm 𝕜 F) (seminorm 𝕜 E) :=
⟨λ p, p.comp f, zero_comp f, λ p q, add_comp p q f⟩

section
variables (p : seminorm 𝕜 E)

@[simp]
protected lemma neg (x : E) : p (-x) = p x :=
by rw [←neg_one_smul 𝕜, seminorm.smul, norm_neg, ←seminorm.smul, one_smul]

protected lemma sub_le (x y : E) : p (x - y) ≤ p x + p y :=
calc
  p (x - y)
      = p (x + -y) : by rw sub_eq_add_neg
  ... ≤ p x + p (-y) : p.add_le x (-y)
  ... = p x + p y : by rw p.neg

lemma sub_rev (x y : E) : p (x - y) = p (y - x) := by rw [←neg_sub, p.neg]

/-- The direct path from 0 to y is shorter than the path with x "inserted" in between. -/
lemma le_insert (x y : E) : p y ≤ p x + p (x - y) :=
calc p y = p (x - (x - y)) : by rw sub_sub_cancel
... ≤ p x + p (x - y) : p.sub_le _ _

/-- The direct path from 0 to x is shorter than the path with y "inserted" in between. -/
lemma le_insert' (x y : E) : p x ≤ p y + p (x - y) := by { rw sub_rev, exact le_insert _ _ _ }

end

instance : order_bot (seminorm 𝕜 E) := ⟨0, seminorm.nonneg⟩

@[simp] lemma coe_bot : ⇑(⊥ : seminorm 𝕜 E) = 0 := rfl

lemma bot_eq_zero : (⊥ : seminorm 𝕜 E) = 0 := rfl

lemma smul_le_smul {p q : seminorm 𝕜 E} {a b : ℝ≥0} (hpq : p ≤ q) (hab : a ≤ b) :
  a • p ≤ b • q :=
begin
  simp_rw [le_def, pi.le_def, coe_smul],
  intros x,
  simp_rw [pi.smul_apply, nnreal.smul_def, smul_eq_mul],
  exact mul_le_mul hab (hpq x) (p.nonneg x) (nnreal.coe_nonneg b),
end

lemma finset_sup_apply (p : ι → seminorm 𝕜 E) (s : finset ι) (x : E) :
  s.sup p x = ↑(s.sup (λ i, ⟨p i x, (p i).nonneg x⟩) : ℝ≥0) :=
begin
  induction s using finset.cons_induction_on with a s ha ih,
  { rw [finset.sup_empty, finset.sup_empty, coe_bot, _root_.bot_eq_zero, pi.zero_apply,
        nonneg.coe_zero] },
  { rw [finset.sup_cons, finset.sup_cons, coe_sup, sup_eq_max, pi.sup_apply, sup_eq_max,
        nnreal.coe_max, subtype.coe_mk, ih] }
end

lemma finset_sup_le_sum (p : ι → seminorm 𝕜 E) (s : finset ι) : s.sup p ≤ ∑ i in s, p i :=
begin
  classical,
  refine finset.sup_le_iff.mpr _,
  intros i hi,
  rw [finset.sum_eq_sum_diff_singleton_add hi, le_add_iff_nonneg_left],
  exact bot_le,
end

lemma finset_sup_apply_le {p : ι → seminorm 𝕜 E} {s : finset ι} {x : E} {a : ℝ} (ha : 0 ≤ a)
  (h : ∀ i, i ∈ s → p i x ≤ a) : s.sup p x ≤ a :=
begin
  lift a to ℝ≥0 using ha,
  rw [finset_sup_apply, nnreal.coe_le_coe],
  exact finset.sup_le h,
end

lemma finset_sup_apply_lt {p : ι → seminorm 𝕜 E} {s : finset ι} {x : E} {a : ℝ} (ha : 0 < a)
  (h : ∀ i, i ∈ s → p i x < a) : s.sup p x < a :=
begin
  lift a to ℝ≥0 using ha.le,
  rw [finset_sup_apply, nnreal.coe_lt_coe, finset.sup_lt_iff],
  { exact h },
  { exact nnreal.coe_pos.mpr ha },
end

end module
end semi_normed_ring

section semi_normed_comm_ring
variables [semi_normed_comm_ring 𝕜] [add_comm_group E] [add_comm_group F] [module 𝕜 E] [module 𝕜 F]

lemma comp_smul (p : seminorm 𝕜 F) (f : E →ₗ[𝕜] F) (c : 𝕜) :
  p.comp (c • f) = ∥c∥₊ • p.comp f :=
ext $ λ _, by rw [comp_apply, smul_apply, linear_map.smul_apply, p.smul, nnreal.smul_def,
  coe_nnnorm, smul_eq_mul, comp_apply]

lemma comp_smul_apply (p : seminorm 𝕜 F) (f : E →ₗ[𝕜] F) (c : 𝕜) (x : E) :
  p.comp (c • f) x = ∥c∥ * p (f x) := p.smul _ _

end semi_normed_comm_ring

section normed_field
variables [normed_field 𝕜] [add_comm_group E] [module 𝕜 E]

private lemma bdd_below_range_add (x : E) (p q : seminorm 𝕜 E) :
  bdd_below (range (λ (u : E), p u + q (x - u))) :=
by { use 0, rintro _ ⟨x, rfl⟩, exact add_nonneg (p.nonneg _) (q.nonneg _) }

noncomputable instance : has_inf (seminorm 𝕜 E) :=
{ inf := λ p q,
  { to_fun  := λ x, ⨅ u : E, p u + q (x-u),
    smul' :=
    begin
      intros a x,
      obtain rfl | ha := eq_or_ne a 0,
      { rw [norm_zero, zero_mul, zero_smul],
        refine cinfi_eq_of_forall_ge_of_forall_gt_exists_lt
          (λ i, add_nonneg (p.nonneg _) (q.nonneg _))
          (λ x hx, ⟨0, by rwa [map_zero, sub_zero, map_zero, add_zero]⟩) },
      simp_rw [real.mul_infi_of_nonneg (norm_nonneg a), mul_add, ←p.smul, ←q.smul, smul_sub],
      refine function.surjective.infi_congr ((•) a⁻¹ : E → E) (λ u, ⟨a • u, inv_smul_smul₀ ha u⟩)
        (λ u, _),
      rw smul_inv_smul₀ ha
    end,
    ..(p.to_add_group_seminorm ⊓ q.to_add_group_seminorm) }}

@[simp] lemma inf_apply (p q : seminorm 𝕜 E) (x : E) : (p ⊓ q) x = ⨅ u : E, p u + q (x-u) := rfl

noncomputable instance : lattice (seminorm 𝕜 E) :=
{ inf := (⊓),
  inf_le_left := λ p q x, begin
    apply cinfi_le_of_le (bdd_below_range_add _ _ _) x,
    simp only [sub_self, map_zero, add_zero],
  end,
  inf_le_right := λ p q x, begin
    apply cinfi_le_of_le (bdd_below_range_add _ _ _) (0:E),
    simp only [sub_self, map_zero, zero_add, sub_zero],
  end,
  le_inf := λ a b c hab hac x,
    le_cinfi $ λ u, le_trans (a.le_insert' _ _) (add_le_add (hab _) (hac _)),
  ..seminorm.semilattice_sup }

lemma smul_inf [has_scalar R ℝ] [has_scalar R ℝ≥0] [is_scalar_tower R ℝ≥0 ℝ]
  (r : R) (p q : seminorm 𝕜 E) :
  r • (p ⊓ q) = r • p ⊓ r • q :=
begin
  ext,
  simp_rw [smul_apply, inf_apply, smul_apply, ←smul_one_smul ℝ≥0 r (_ : ℝ), nnreal.smul_def,
    smul_eq_mul, real.mul_infi_of_nonneg (subtype.prop _), mul_add],
end

end normed_field

/-! ### Seminorm ball -/

section semi_normed_ring
variables [semi_normed_ring 𝕜]

section add_comm_group
variables [add_comm_group E]

section has_scalar
variables [has_scalar 𝕜 E] (p : seminorm 𝕜 E)

/-- The ball of radius `r` at `x` with respect to seminorm `p` is the set of elements `y` with
`p (y - x) < `r`. -/
def ball (x : E) (r : ℝ) := { y : E | p (y - x) < r }

variables {x y : E} {r : ℝ}

@[simp] lemma mem_ball : y ∈ ball p x r ↔ p (y - x) < r := iff.rfl

lemma mem_ball_zero : y ∈ ball p 0 r ↔ p y < r := by rw [mem_ball, sub_zero]

lemma ball_zero_eq : ball p 0 r = { y : E | p y < r } := set.ext $ λ x, p.mem_ball_zero

@[simp] lemma ball_zero' (x : E) (hr : 0 < r) : ball (0 : seminorm 𝕜 E) x r = set.univ :=
begin
  rw [set.eq_univ_iff_forall, ball],
  simp [hr],
end

lemma ball_smul (p : seminorm 𝕜 E) {c : nnreal} (hc : 0 < c) (r : ℝ) (x : E) :
  (c • p).ball x r = p.ball x (r / c) :=
by { ext, rw [mem_ball, mem_ball, smul_apply, nnreal.smul_def, smul_eq_mul, mul_comm,
  lt_div_iff (nnreal.coe_pos.mpr hc)] }

lemma ball_sup (p : seminorm 𝕜 E) (q : seminorm 𝕜 E) (e : E) (r : ℝ) :
  ball (p ⊔ q) e r = ball p e r ∩ ball q e r :=
by simp_rw [ball, ←set.set_of_and, coe_sup, pi.sup_apply, sup_lt_iff]

lemma ball_finset_sup' (p : ι → seminorm 𝕜 E) (s : finset ι) (H : s.nonempty) (e : E) (r : ℝ) :
  ball (s.sup' H p) e r = s.inf' H (λ i, ball (p i) e r) :=
begin
  induction H using finset.nonempty.cons_induction with a a s ha hs ih,
  { classical, simp },
  { rw [finset.sup'_cons hs, finset.inf'_cons hs, ball_sup, inf_eq_inter, ih] },
end

lemma ball_mono {p : seminorm 𝕜 E} {r₁ r₂ : ℝ} (h : r₁ ≤ r₂) : p.ball x r₁ ⊆ p.ball x r₂ :=
λ _ (hx : _ < _), hx.trans_le h

lemma ball_antitone {p q : seminorm 𝕜 E} (h : q ≤ p) : p.ball x r ⊆ q.ball x r :=
λ _, (h _).trans_lt

lemma ball_add_ball_subset (p : seminorm 𝕜 E) (r₁ r₂ : ℝ) (x₁ x₂ : E):
  p.ball (x₁ : E) r₁ + p.ball (x₂ : E) r₂ ⊆ p.ball (x₁ + x₂) (r₁ + r₂) :=
begin
  rintros x ⟨y₁, y₂, hy₁, hy₂, rfl⟩,
  rw [mem_ball, add_sub_add_comm],
  exact (p.add_le _ _).trans_lt (add_lt_add hy₁ hy₂),
end

end has_scalar

section module

variables [module 𝕜 E]
variables [add_comm_group F] [module 𝕜 F]

lemma ball_comp (p : seminorm 𝕜 F) (f : E →ₗ[𝕜] F) (x : E) (r : ℝ) :
  (p.comp f).ball x r = f ⁻¹' (p.ball (f x) r) :=
begin
  ext,
  simp_rw [ball, mem_preimage, comp_apply, set.mem_set_of_eq, map_sub],
end

variables (p : seminorm 𝕜 E)

lemma ball_zero_eq_preimage_ball {r : ℝ} :
  p.ball 0 r = p ⁻¹' (metric.ball 0 r) :=
begin
  ext x,
  simp only [mem_ball, sub_zero, mem_preimage, mem_ball_zero_iff],
  rw real.norm_of_nonneg,
  exact p.nonneg _,
end

@[simp] lemma ball_bot {r : ℝ} (x : E) (hr : 0 < r) :
  ball (⊥ : seminorm 𝕜 E) x r = set.univ :=
ball_zero' x hr

/-- Seminorm-balls at the origin are balanced. -/
lemma balanced_ball_zero (r : ℝ) : balanced 𝕜 (ball p 0 r) :=
begin
  rintro a ha x ⟨y, hy, hx⟩,
  rw [mem_ball_zero, ←hx, p.smul],
  calc _ ≤ p y : mul_le_of_le_one_left (p.nonneg _) ha
  ...    < r   : by rwa mem_ball_zero at hy,
end

lemma ball_finset_sup_eq_Inter (p : ι → seminorm 𝕜 E) (s : finset ι) (x : E) {r : ℝ} (hr : 0 < r) :
  ball (s.sup p) x r = ⋂ (i ∈ s), ball (p i) x r :=
begin
  lift r to nnreal using hr.le,
  simp_rw [ball, Inter_set_of, finset_sup_apply, nnreal.coe_lt_coe,
    finset.sup_lt_iff (show ⊥ < r, from hr), ←nnreal.coe_lt_coe, subtype.coe_mk],
end

lemma ball_finset_sup (p : ι → seminorm 𝕜 E) (s : finset ι) (x : E) {r : ℝ} (hr : 0 < r) :
  ball (s.sup p) x r = s.inf (λ i, ball (p i) x r) :=
begin
  rw finset.inf_eq_infi,
  exact ball_finset_sup_eq_Inter _ _ _ hr,
end

lemma ball_smul_ball (p : seminorm 𝕜 E) (r₁ r₂ : ℝ) :
  metric.ball (0 : 𝕜) r₁ • p.ball 0 r₂ ⊆ p.ball 0 (r₁ * r₂) :=
begin
  rw set.subset_def,
  intros x hx,
  rw set.mem_smul at hx,
  rcases hx with ⟨a, y, ha, hy, hx⟩,
  rw [←hx, mem_ball_zero, seminorm.smul],
  exact mul_lt_mul'' (mem_ball_zero_iff.mp ha) (p.mem_ball_zero.mp hy) (norm_nonneg a) (p.nonneg y),
end

@[simp] lemma ball_eq_emptyset (p : seminorm 𝕜 E) {x : E} {r : ℝ} (hr : r ≤ 0) : p.ball x r = ∅ :=
begin
  ext,
  rw [seminorm.mem_ball, set.mem_empty_eq, iff_false, not_lt],
  exact hr.trans (p.nonneg _),
end

end module
end add_comm_group
end semi_normed_ring

section normed_field
variables [normed_field 𝕜] [add_comm_group E] [module 𝕜 E] (p : seminorm 𝕜 E) {A B : set E}
  {a : 𝕜} {r : ℝ} {x : E}

lemma smul_ball_zero {p : seminorm 𝕜 E} {k : 𝕜} {r : ℝ} (hk : 0 < ∥k∥) :
  k • p.ball 0 r = p.ball 0 (∥k∥ * r) :=
begin
  ext,
  rw [set.mem_smul_set, seminorm.mem_ball_zero],
  split; intro h,
  { rcases h with ⟨y, hy, h⟩,
    rw [←h, seminorm.smul],
    rw seminorm.mem_ball_zero at hy,
    exact (mul_lt_mul_left hk).mpr hy },
  refine ⟨k⁻¹ • x, _, _⟩,
  { rw [seminorm.mem_ball_zero, seminorm.smul, norm_inv, ←(mul_lt_mul_left hk),
      ←mul_assoc, ←(div_eq_mul_inv ∥k∥ ∥k∥), div_self (ne_of_gt hk), one_mul],
    exact h},
  rw [←smul_assoc, smul_eq_mul, ←div_eq_mul_inv, div_self (norm_pos_iff.mp hk), one_smul],
end

lemma ball_zero_absorbs_ball_zero (p : seminorm 𝕜 E) {r₁ r₂ : ℝ} (hr₁ : 0 < r₁) :
  absorbs 𝕜 (p.ball 0 r₁) (p.ball 0 r₂) :=
begin
  by_cases hr₂ : r₂ ≤ 0,
  { rw ball_eq_emptyset p hr₂, exact absorbs_empty },
  rw [not_le] at hr₂,
  rcases exists_between hr₁ with ⟨r, hr, hr'⟩,
  refine ⟨r₂/r, div_pos hr₂ hr, _⟩,
  simp_rw set.subset_def,
  intros a ha x hx,
  have ha' : 0 < ∥a∥ := lt_of_lt_of_le (div_pos hr₂ hr) ha,
  rw [smul_ball_zero ha', p.mem_ball_zero],
  rw p.mem_ball_zero at hx,
  rw div_le_iff hr at ha,
  exact hx.trans (lt_of_le_of_lt ha ((mul_lt_mul_left ha').mpr hr')),
end

/-- Seminorm-balls at the origin are absorbent. -/
protected lemma absorbent_ball_zero (hr : 0 < r) : absorbent 𝕜 (ball p (0 : E) r) :=
begin
  rw absorbent_iff_nonneg_lt,
  rintro x,
  have hxr : 0 ≤ p x/r := div_nonneg (p.nonneg _) hr.le,
  refine ⟨p x/r, hxr, λ a ha, _⟩,
  have ha₀ : 0 < ∥a∥ := hxr.trans_lt ha,
  refine ⟨a⁻¹ • x, _, smul_inv_smul₀ (norm_pos_iff.1 ha₀) x⟩,
  rwa [mem_ball_zero, p.smul, norm_inv, inv_mul_lt_iff ha₀, ←div_lt_iff hr],
end

/-- Seminorm-balls containing the origin are absorbent. -/
protected lemma absorbent_ball (hpr : p x < r) : absorbent 𝕜 (ball p x r) :=
begin
  refine (p.absorbent_ball_zero $ sub_pos.2 hpr).subset (λ y hy, _),
  rw p.mem_ball_zero at hy,
  exact p.mem_ball.2 ((p.sub_le _ _).trans_lt $ add_lt_of_lt_sub_right hy),
end

lemma symmetric_ball_zero (r : ℝ) (hx : x ∈ ball p 0 r) : -x ∈ ball p 0 r :=
balanced_ball_zero p r (-1) (by rw [norm_neg, norm_one]) ⟨x, hx, by rw [neg_smul, one_smul]⟩

@[simp]
lemma neg_ball (p : seminorm 𝕜 E) (r : ℝ) (x : E) :
  -ball p x r = ball p (-x) r :=
by { ext, rw [mem_neg, mem_ball, mem_ball, ←neg_add', sub_neg_eq_add, p.neg], }

@[simp]
lemma smul_ball_preimage (p : seminorm 𝕜 E) (y : E) (r : ℝ) (a : 𝕜) (ha : a ≠ 0) :
  ((•) a) ⁻¹' p.ball y r = p.ball (a⁻¹ • y) (r / ∥a∥) :=
set.ext $ λ _, by rw [mem_preimage, mem_ball, mem_ball,
  lt_div_iff (norm_pos_iff.mpr ha), mul_comm, ←p.smul, smul_sub, smul_inv_smul₀ ha]

end normed_field

section convex
variables [normed_field 𝕜] [add_comm_group E] [normed_space ℝ 𝕜] [module 𝕜 E]

section has_scalar
variables [has_scalar ℝ E] [is_scalar_tower ℝ 𝕜 E] (p : seminorm 𝕜 E)

/-- A seminorm is convex. Also see `convex_on_norm`. -/
protected lemma convex_on : convex_on ℝ univ p :=
begin
  refine ⟨convex_univ, λ x y _ _ a b ha hb hab, _⟩,
  calc p (a • x + b • y) ≤ p (a • x) + p (b • y) : p.add_le _ _
    ... = ∥a • (1 : 𝕜)∥ * p x + ∥b • (1 : 𝕜)∥ * p y
        : by rw [←p.smul, ←p.smul, smul_one_smul, smul_one_smul]
    ... = a * p x + b * p y
        : by rw [norm_smul, norm_smul, norm_one, mul_one, mul_one, real.norm_of_nonneg ha,
            real.norm_of_nonneg hb],
end

end has_scalar

section module
variables [module ℝ E] [is_scalar_tower ℝ 𝕜 E] (p : seminorm 𝕜 E) (x : E) (r : ℝ)

/-- Seminorm-balls are convex. -/
lemma convex_ball : convex ℝ (ball p x r) :=
begin
  convert (p.convex_on.translate_left (-x)).convex_lt r,
  ext y,
  rw [preimage_univ, sep_univ, p.mem_ball, sub_eq_add_neg],
  refl,
end

end module
end convex
end seminorm

/-! ### The norm as a seminorm -/

section norm_seminorm
variables (𝕜) (E) [normed_field 𝕜] [semi_normed_group E] [normed_space 𝕜 E] {r : ℝ}

/-- The norm of a seminormed group as an add_monoid seminorm. -/
def norm_add_group_seminorm : add_group_seminorm E :=
⟨norm, norm_zero, norm_nonneg, norm_add_le, norm_neg⟩

@[simp] lemma coe_norm_add_group_seminorm : ⇑(norm_add_group_seminorm E) = norm := rfl

/-- The norm of a seminormed group as a seminorm. -/
def norm_seminorm : seminorm 𝕜 E :=
{ smul' := norm_smul,
  ..(norm_add_group_seminorm E)}

@[simp] lemma coe_norm_seminorm : ⇑(norm_seminorm 𝕜 E) = norm := rfl

@[simp] lemma ball_norm_seminorm : (norm_seminorm 𝕜 E).ball = metric.ball :=
by { ext x r y, simp only [seminorm.mem_ball, metric.mem_ball, coe_norm_seminorm, dist_eq_norm] }

variables {𝕜 E} {x : E}

/-- Balls at the origin are absorbent. -/
lemma absorbent_ball_zero (hr : 0 < r) : absorbent 𝕜 (metric.ball (0 : E) r) :=
by { rw ←ball_norm_seminorm 𝕜, exact (norm_seminorm _ _).absorbent_ball_zero hr }

/-- Balls containing the origin are absorbent. -/
lemma absorbent_ball (hx : ∥x∥ < r) : absorbent 𝕜 (metric.ball x r) :=
by { rw ←ball_norm_seminorm 𝕜, exact (norm_seminorm _ _).absorbent_ball hx }

/-- Balls at the origin are balanced. -/
lemma balanced_ball_zero : balanced 𝕜 (metric.ball (0 : E) r) :=
by { rw ←ball_norm_seminorm 𝕜, exact (norm_seminorm _ _).balanced_ball_zero r }

end norm_seminorm


/-
Copyright (c) 2020 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser, Utensil Song
-/

import algebra.ring_quot
import linear_algebra.tensor_algebra.basic
import linear_algebra.quadratic_form.isometry

/-!
# Clifford Algebras

We construct the Clifford algebra of a module `M` over a commutative ring `R`, equipped with
a quadratic_form `Q`.

## Notation

The Clifford algebra of the `R`-module `M` equipped with a quadratic_form `Q` is
an `R`-algebra denoted `clifford_algebra Q`.

Given a linear morphism `f : M → A` from a module `M` to another `R`-algebra `A`, such that
`cond : ∀ m, f m * f m = algebra_map _ _ (Q m)`, there is a (unique) lift of `f` to an `R`-algebra
morphism from `clifford_algebra Q` to `A`, which is denoted `clifford_algebra.lift Q f cond`.

The canonical linear map `M → clifford_algebra Q` is denoted `clifford_algebra.ι Q`.

## Theorems

The main theorems proved ensure that `clifford_algebra Q` satisfies the universal property
of the Clifford algebra.
1. `ι_comp_lift` is the fact that the composition of `ι Q` with `lift Q f cond` agrees with `f`.
2. `lift_unique` ensures the uniqueness of `lift Q f cond` with respect to 1.

Additionally, when `Q = 0` an `alg_equiv` to the `exterior_algebra` is provided as `as_exterior`.

## Implementation details

The Clifford algebra of `M` is constructed as a quotient of the tensor algebra, as follows.
1. We define a relation `clifford_algebra.rel Q` on `tensor_algebra R M`.
   This is the smallest relation which identifies squares of elements of `M` with `Q m`.
2. The Clifford algebra is the quotient of the tensor algebra by this relation.

This file is almost identical to `linear_algebra/exterior_algebra.lean`.
-/

variables {R : Type*} [comm_ring R]
variables {M : Type*} [add_comm_group M] [module R M]
variables (Q : quadratic_form R M)

variable {n : ℕ}

namespace clifford_algebra
open tensor_algebra

/-- `rel` relates each `ι m * ι m`, for `m : M`, with `Q m`.

The Clifford algebra of `M` is defined as the quotient modulo this relation.
-/
inductive rel : tensor_algebra R M → tensor_algebra R M → Prop
| of (m : M) : rel (ι R m * ι R m) (algebra_map R _ (Q m))

end clifford_algebra

/--
The Clifford algebra of an `R`-module `M` equipped with a quadratic_form `Q`.
-/
@[derive [inhabited, ring, algebra R]]
def clifford_algebra := ring_quot (clifford_algebra.rel Q)

namespace clifford_algebra

/--
The canonical linear map `M →ₗ[R] clifford_algebra Q`.
-/
def ι : M →ₗ[R] clifford_algebra Q :=
(ring_quot.mk_alg_hom R _).to_linear_map.comp (tensor_algebra.ι R)

/-- As well as being linear, `ι Q` squares to the quadratic form -/
@[simp]
theorem ι_sq_scalar (m : M) : ι Q m * ι Q m = algebra_map R _ (Q m) :=
begin
  erw [←alg_hom.map_mul, ring_quot.mk_alg_hom_rel R (rel.of m), alg_hom.commutes],
  refl,
end

variables {Q} {A : Type*} [semiring A] [algebra R A]

@[simp]
theorem comp_ι_sq_scalar (g : clifford_algebra Q →ₐ[R] A) (m : M) :
  g (ι Q m) * g (ι Q m) = algebra_map _ _ (Q m) :=
by rw [←alg_hom.map_mul, ι_sq_scalar, alg_hom.commutes]

variables (Q)

/--
Given a linear map `f : M →ₗ[R] A` into an `R`-algebra `A`, which satisfies the condition:
`cond : ∀ m : M, f m * f m = Q(m)`, this is the canonical lift of `f` to a morphism of `R`-algebras
from `clifford_algebra Q` to `A`.
-/
@[simps symm_apply]
def lift :
  {f : M →ₗ[R] A // ∀ m, f m * f m = algebra_map _ _ (Q m)} ≃ (clifford_algebra Q →ₐ[R] A) :=
{ to_fun := λ f,
  ring_quot.lift_alg_hom R ⟨tensor_algebra.lift R (f : M →ₗ[R] A),
    (λ x y (h : rel Q x y), by
    { induction h,
      rw [alg_hom.commutes, alg_hom.map_mul, tensor_algebra.lift_ι_apply, f.prop], })⟩,
  inv_fun := λ F, ⟨F.to_linear_map.comp (ι Q), λ m, by rw [
    linear_map.comp_apply, alg_hom.to_linear_map_apply, comp_ι_sq_scalar]⟩,
  left_inv := λ f, by { ext,
    simp only [ι, alg_hom.to_linear_map_apply, function.comp_app, linear_map.coe_comp,
               subtype.coe_mk, ring_quot.lift_alg_hom_mk_alg_hom_apply,
               tensor_algebra.lift_ι_apply] },
  right_inv := λ F, by { ext,
    simp only [ι, alg_hom.comp_to_linear_map, alg_hom.to_linear_map_apply, function.comp_app,
               linear_map.coe_comp, subtype.coe_mk, ring_quot.lift_alg_hom_mk_alg_hom_apply,
               tensor_algebra.lift_ι_apply] } }

variables {Q}

@[simp]
theorem ι_comp_lift (f : M →ₗ[R] A) (cond : ∀ m, f m * f m = algebra_map _ _ (Q m)) :
  (lift Q ⟨f, cond⟩).to_linear_map.comp (ι Q) = f :=
(subtype.mk_eq_mk.mp $ (lift Q).symm_apply_apply ⟨f, cond⟩)

@[simp]
theorem lift_ι_apply (f : M →ₗ[R] A) (cond : ∀ m, f m * f m = algebra_map _ _ (Q m)) (x) :
  lift Q ⟨f, cond⟩ (ι Q x) = f x :=
(linear_map.ext_iff.mp $ ι_comp_lift f cond) x

@[simp]
theorem lift_unique (f : M →ₗ[R] A) (cond : ∀ m : M, f m * f m = algebra_map _ _ (Q m))
  (g : clifford_algebra Q →ₐ[R] A) :
  g.to_linear_map.comp (ι Q) = f ↔ g = lift Q ⟨f, cond⟩ :=
begin
  convert (lift Q).symm_apply_eq,
  rw lift_symm_apply,
  simp only,
end

attribute [irreducible] clifford_algebra ι lift

@[simp]
theorem lift_comp_ι (g : clifford_algebra Q →ₐ[R] A) :
  lift Q ⟨g.to_linear_map.comp (ι Q), comp_ι_sq_scalar _⟩ = g :=
begin
  convert (lift Q).apply_symm_apply g,
  rw lift_symm_apply,
  refl,
end

/-- See note [partially-applied ext lemmas]. -/
@[ext]
theorem hom_ext {A : Type*} [semiring A] [algebra R A] {f g : clifford_algebra Q →ₐ[R] A} :
  f.to_linear_map.comp (ι Q) = g.to_linear_map.comp (ι Q) → f = g :=
begin
  intro h,
  apply (lift Q).symm.injective,
  rw [lift_symm_apply, lift_symm_apply],
  simp only [h],
end

/-- If `C` holds for the `algebra_map` of `r : R` into `clifford_algebra Q`, the `ι` of `x : M`,
and is preserved under addition and muliplication, then it holds for all of `clifford_algebra Q`.

See also the stronger `clifford_algebra.left_induction` and `clifford_algebra.right_induction`.
-/
-- This proof closely follows `tensor_algebra.induction`
@[elab_as_eliminator]
lemma induction {C : clifford_algebra Q → Prop}
  (h_grade0 : ∀ r, C (algebra_map R (clifford_algebra Q) r))
  (h_grade1 : ∀ x, C (ι Q x))
  (h_mul : ∀ a b, C a → C b → C (a * b))
  (h_add : ∀ a b, C a → C b → C (a + b))
  (a : clifford_algebra Q) :
  C a :=
begin
  -- the arguments are enough to construct a subalgebra, and a mapping into it from M
  let s : subalgebra R (clifford_algebra Q) :=
  { carrier := C,
    mul_mem' := h_mul,
    add_mem' := h_add,
    algebra_map_mem' := h_grade0, },
  let of : { f : M →ₗ[R] s // ∀ m, f m * f m = algebra_map _ _ (Q m) } :=
  ⟨(ι Q).cod_restrict s.to_submodule h_grade1,
    λ m, subtype.eq $ ι_sq_scalar Q m ⟩,
  -- the mapping through the subalgebra is the identity
  have of_id : alg_hom.id R (clifford_algebra Q) = s.val.comp (lift Q of),
  { ext,
    simp [of], },
  -- finding a proof is finding an element of the subalgebra
  convert subtype.prop (lift Q of a),
  exact alg_hom.congr_fun of_id a,
end

/-- The symmetric product of vectors is a scalar -/
lemma ι_mul_ι_add_swap (a b : M) :
  ι Q a * ι Q b + ι Q b * ι Q a = algebra_map R _ (quadratic_form.polar Q a b) :=
calc  ι Q a * ι Q b + ι Q b * ι Q a
    = ι Q (a + b) * ι Q (a + b) - ι Q a * ι Q a - ι Q b * ι Q b :
        by { rw [(ι Q).map_add, mul_add, add_mul, add_mul], abel, }
... = algebra_map R _ (Q (a + b)) - algebra_map R _ (Q a) - algebra_map R _ (Q b) :
        by rw [ι_sq_scalar, ι_sq_scalar, ι_sq_scalar]
... = algebra_map R _ (Q (a + b) - Q a - Q b) :
        by rw [←ring_hom.map_sub, ←ring_hom.map_sub]
... = algebra_map R _ (quadratic_form.polar Q a b) : rfl

lemma ι_mul_comm (a b : M) :
  ι Q a * ι Q b = algebra_map R _ (quadratic_form.polar Q a b) - ι Q b * ι Q a :=
eq_sub_of_add_eq (ι_mul_ι_add_swap a b)

/-- $aba$ is a vector. -/
lemma ι_mul_ι_mul_ι  (a b : M) :
  ι Q a * ι Q b * ι Q a = ι Q (quadratic_form.polar Q a b • a - Q a • b) :=
by rw [ι_mul_comm, sub_mul, mul_assoc, ι_sq_scalar, ←algebra.smul_def, ←algebra.commutes,
  ←algebra.smul_def, ←map_smul, ←map_smul, ←map_sub]

@[simp]
lemma ι_range_map_lift (f : M →ₗ[R] A) (cond : ∀ m, f m * f m = algebra_map _ _ (Q m)) :
  (ι Q).range.map (lift Q ⟨f, cond⟩).to_linear_map = f.range :=
by rw [←linear_map.range_comp, ι_comp_lift]

section map

variables {M₁ M₂ M₃ : Type*}
variables [add_comm_group M₁] [add_comm_group M₂] [add_comm_group M₃]
variables [module R M₁] [module R M₂] [module R M₃]
variables (Q₁ : quadratic_form R M₁) (Q₂ : quadratic_form R M₂) (Q₃ : quadratic_form R M₃)

/-- Any linear map that preserves the quadratic form lifts to an `alg_hom` between algebras.

See `clifford_algebra.equiv_of_isometry` for the case when `f` is a `quadratic_form.isometry`. -/
def map (f : M₁ →ₗ[R] M₂) (hf : ∀ m, Q₂ (f m) = Q₁ m) :
  clifford_algebra Q₁ →ₐ[R] clifford_algebra Q₂ :=
clifford_algebra.lift Q₁ ⟨(clifford_algebra.ι Q₂).comp f,
  λ m, (ι_sq_scalar _ _).trans $ ring_hom.congr_arg _ $ hf m⟩

@[simp]
lemma map_comp_ι (f : M₁ →ₗ[R] M₂) (hf) :
  (map Q₁ Q₂ f hf).to_linear_map.comp (ι Q₁) = (ι Q₂).comp f :=
ι_comp_lift _ _

@[simp]
lemma map_apply_ι (f : M₁ →ₗ[R] M₂) (hf) (m : M₁):
  map Q₁ Q₂ f hf (ι Q₁ m) = ι Q₂ (f m) :=
lift_ι_apply _ _ m

@[simp]
lemma map_id :
  map Q₁ Q₁ (linear_map.id : M₁ →ₗ[R] M₁) (λ m, rfl) = alg_hom.id R (clifford_algebra Q₁) :=
by { ext m, exact map_apply_ι _ _ _ _ m }

@[simp]
lemma map_comp_map (f : M₂ →ₗ[R] M₃) (hf) (g : M₁ →ₗ[R] M₂) (hg) :
  (map Q₂ Q₃ f hf).comp (map Q₁ Q₂ g hg) = map Q₁ Q₃ (f.comp g) (λ m, (hf _).trans $ hg m) :=
begin
  ext m,
  dsimp only [linear_map.comp_apply, alg_hom.comp_apply, alg_hom.to_linear_map_apply,
    alg_hom.id_apply],
  rw [map_apply_ι, map_apply_ι, map_apply_ι, linear_map.comp_apply],
end

@[simp]
lemma ι_range_map_map (f : M₁ →ₗ[R] M₂) (hf : ∀ m, Q₂ (f m) = Q₁ m) :
  (ι Q₁).range.map (map Q₁ Q₂ f hf).to_linear_map = f.range.map (ι Q₂) :=
(ι_range_map_lift _ _).trans (linear_map.range_comp _ _)

variables {Q₁ Q₂ Q₃}

/-- Two `clifford_algebra`s are equivalent as algebras if their quadratic forms are
equivalent. -/
@[simps apply]
def equiv_of_isometry (e : Q₁.isometry Q₂) :
  clifford_algebra Q₁ ≃ₐ[R] clifford_algebra Q₂ :=
alg_equiv.of_alg_hom
  (map Q₁ Q₂ e e.map_app)
  (map Q₂ Q₁ e.symm e.symm.map_app)
  ((map_comp_map _ _ _ _ _ _ _).trans $ begin
    convert map_id _ using 2,
    ext m,
    exact e.to_linear_equiv.apply_symm_apply m,
  end)
  ((map_comp_map _ _ _ _ _ _ _).trans $ begin
    convert map_id _ using 2,
    ext m,
    exact e.to_linear_equiv.symm_apply_apply m,
  end)

@[simp]
lemma equiv_of_isometry_symm (e : Q₁.isometry Q₂) :
  (equiv_of_isometry e).symm = equiv_of_isometry e.symm := rfl

@[simp]
lemma equiv_of_isometry_trans (e₁₂ : Q₁.isometry Q₂) (e₂₃ : Q₂.isometry Q₃) :
  (equiv_of_isometry e₁₂).trans (equiv_of_isometry e₂₃) = equiv_of_isometry (e₁₂.trans e₂₃) :=
by { ext x, exact alg_hom.congr_fun (map_comp_map Q₁ Q₂ Q₃ _ _ _ _) x }

@[simp]
lemma equiv_of_isometry_refl :
  (equiv_of_isometry $ quadratic_form.isometry.refl Q₁) = alg_equiv.refl :=
by { ext x, exact alg_hom.congr_fun (map_id Q₁) x }

end map

variables (Q)

/-- If the quadratic form of a vector is invertible, then so is that vector. -/
def invertible_ι_of_invertible (m : M) [invertible (Q m)] : invertible (ι Q m) :=
{ inv_of := ι Q (⅟(Q m) • m),
  inv_of_mul_self := by rw [map_smul, smul_mul_assoc, ι_sq_scalar, algebra.smul_def, ←map_mul,
    inv_of_mul_self, map_one],
  mul_inv_of_self := by rw [map_smul, mul_smul_comm, ι_sq_scalar, algebra.smul_def, ←map_mul,
    inv_of_mul_self, map_one] }

/-- For a vector with invertible quadratic form, $v^{-1} = \frac{v}{Q(v)}$ -/
lemma inv_of_ι (m : M) [invertible (Q m)] [invertible (ι Q m)] : ⅟(ι Q m) = ι Q (⅟(Q m) • m) :=
begin
  letI := invertible_ι_of_invertible Q m,
  convert (rfl : ⅟(ι Q m) = _),
end

lemma is_unit_ι_of_is_unit {m : M} (h : is_unit (Q m)) : is_unit (ι Q m) :=
begin
  casesI h.nonempty_invertible,
  letI := invertible_ι_of_invertible Q m,
  exactI is_unit_of_invertible (ι Q m),
end

/-- $aba^{-1}$ is a vector. -/
lemma ι_mul_ι_mul_inv_of_ι (a b : M) [invertible (ι Q a)] [invertible (Q a)] :
  ι Q a * ι Q b * ⅟(ι Q a) = ι Q ((⅟(Q a) * quadratic_form.polar Q a b) • a - b) :=
by rw [inv_of_ι, map_smul, mul_smul_comm, ι_mul_ι_mul_ι, ←map_smul, smul_sub, smul_smul, smul_smul,
  inv_of_mul_self, one_smul]

/-- $a^{-1}ba$ is a vector. -/
lemma inv_of_ι_mul_ι_mul_ι (a b : M) [invertible (ι Q a)] [invertible (Q a)] :
  ⅟(ι Q a) * ι Q b * ι Q a = ι Q ((⅟(Q a) * quadratic_form.polar Q a b) • a - b) :=
by rw [inv_of_ι, map_smul, smul_mul_assoc, smul_mul_assoc, ι_mul_ι_mul_ι, ←map_smul, smul_sub,
  smul_smul, smul_smul, inv_of_mul_self, one_smul]

end clifford_algebra

namespace tensor_algebra

variables {Q}

/-- The canonical image of the `tensor_algebra` in the `clifford_algebra`, which maps
`tensor_algebra.ι R x` to `clifford_algebra.ι Q x`. -/
def to_clifford : tensor_algebra R M →ₐ[R] clifford_algebra Q :=
tensor_algebra.lift R (clifford_algebra.ι Q)

@[simp] lemma to_clifford_ι (m : M) : (tensor_algebra.ι R m).to_clifford = clifford_algebra.ι Q m :=
by simp [to_clifford]

end tensor_algebra