/-
Copyright (c) 2014 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Leonardo de Moura, Simon Hudon, Mario Carneiro
-/
import algebra.group.to_additive
import tactic.basic

/-!
# Typeclasses for (semi)groups and monoid

In this file we define typeclasses for algebraic structures with one binary operation.
The classes are named `(add_)?(comm_)?(semigroup|monoid|group)`, where `add_` means that
the class uses additive notation and `comm_` means that the class assumes that the binary
operation is commutative.

The file does not contain any lemmas except for

* axioms of typeclasses restated in the root namespace;
* lemmas required for instances.

For basic lemmas about these classes see `algebra.group.basic`.
-/

set_option old_structure_cmd true

universe u

/- Additive "sister" structures.
   Example, add_semigroup mirrors semigroup.
   These structures exist just to help automation.
   In an alternative design, we could have the binary operation as an
   extra argument for semigroup, monoid, group, etc. However, the lemmas
   would be hard to index since they would not contain any constant.
   For example, mul_assoc would be

   lemma mul_assoc {α : Type u} {op : α → α → α} [semigroup α op] :
                   ∀ a b c : α, op (op a b) c = op a (op b c) :=
    semigroup.mul_assoc

   The simplifier cannot effectively use this lemma since the pattern for
   the left-hand-side would be

        ?op (?op ?a ?b) ?c

   Remark: we use a tactic for transporting theorems from the multiplicative fragment
   to the additive one.
-/

section has_mul

variables {G : Type u} [has_mul G]

/-- `left_mul g` denotes left multiplication by `g` -/
@[to_additive "`left_add g` denotes left addition by `g`"]
def left_mul : G → G → G := λ g : G, λ x : G, g * x

/-- `right_mul g` denotes right multiplication by `g` -/
@[to_additive "`right_add g` denotes right addition by `g`"]
def right_mul : G → G → G := λ g : G, λ x : G, x * g

end has_mul

/-- A semigroup is a type with an associative `(*)`. -/
@[protect_proj, ancestor has_mul] class semigroup (G : Type u) extends has_mul G :=
(mul_assoc : ∀ a b c : G, a * b * c = a * (b * c))
/-- An additive semigroup is a type with an associative `(+)`. -/
@[protect_proj, ancestor has_add] class add_semigroup (G : Type u) extends has_add G :=
(add_assoc : ∀ a b c : G, a + b + c = a + (b + c))
attribute [to_additive] semigroup

section semigroup
variables {G : Type u} [semigroup G]

@[no_rsimp, to_additive]
lemma mul_assoc : ∀ a b c : G, a * b * c = a * (b * c) :=
semigroup.mul_assoc

attribute [no_rsimp] add_assoc -- TODO(Mario): find out why this isn't copying

@[to_additive]
instance semigroup.to_is_associative : is_associative G (*) :=
⟨mul_assoc⟩

end semigroup

/-- A commutative semigroup is a type with an associative commutative `(*)`. -/
@[protect_proj, ancestor semigroup]
class comm_semigroup (G : Type u) extends semigroup G :=
(mul_comm : ∀ a b : G, a * b = b * a)

/-- A commutative additive semigroup is a type with an associative commutative `(+)`. -/
@[protect_proj, ancestor add_semigroup]
class add_comm_semigroup (G : Type u) extends add_semigroup G :=
(add_comm : ∀ a b : G, a + b = b + a)
attribute [to_additive] comm_semigroup

section comm_semigroup
variables {G : Type u} [comm_semigroup G]

@[no_rsimp, to_additive]
lemma mul_comm : ∀ a b : G, a * b = b * a :=
comm_semigroup.mul_comm
attribute [no_rsimp] add_comm

@[to_additive]
instance comm_semigroup.to_is_commutative : is_commutative G (*) :=
⟨mul_comm⟩

end comm_semigroup

/-- A `left_cancel_semigroup` is a semigroup such that `a * b = a * c` implies `b = c`. -/
@[protect_proj, ancestor semigroup]
class left_cancel_semigroup (G : Type u) extends semigroup G :=
(mul_left_cancel : ∀ a b c : G, a * b = a * c → b = c)
/-- An `add_left_cancel_semigroup` is an additive semigroup such that
`a + b = a + c` implies `b = c`. -/
@[protect_proj, ancestor add_semigroup]
class add_left_cancel_semigroup (G : Type u) extends add_semigroup G :=
(add_left_cancel : ∀ a b c : G, a + b = a + c → b = c)
attribute [to_additive add_left_cancel_semigroup] left_cancel_semigroup

section left_cancel_semigroup
variables {G : Type u} [left_cancel_semigroup G] {a b c : G}

@[to_additive]
lemma mul_left_cancel : a * b = a * c → b = c :=
left_cancel_semigroup.mul_left_cancel a b c

@[to_additive]
lemma mul_left_cancel_iff : a * b = a * c ↔ b = c :=
⟨mul_left_cancel, congr_arg _⟩

@[to_additive]
theorem mul_right_injective (a : G) : function.injective ((*) a) :=
λ b c, mul_left_cancel

@[simp, to_additive]
theorem mul_right_inj (a : G) {b c : G} : a * b = a * c ↔ b = c :=
(mul_right_injective a).eq_iff

@[to_additive]
theorem mul_ne_mul_right (a : G) {b c : G} : a * b ≠ a * c ↔ b ≠ c :=
(mul_right_injective a).ne_iff

end left_cancel_semigroup

/-- A `right_cancel_semigroup` is a semigroup such that `a * b = c * b` implies `a = c`. -/
@[protect_proj, ancestor semigroup]
class right_cancel_semigroup (G : Type u) extends semigroup G :=
(mul_right_cancel : ∀ a b c : G, a * b = c * b → a = c)

/-- An `add_right_cancel_semigroup` is an additive semigroup such that
`a + b = c + b` implies `a = c`. -/
@[protect_proj, ancestor add_semigroup]
class add_right_cancel_semigroup (G : Type u) extends add_semigroup G :=
(add_right_cancel : ∀ a b c : G, a + b = c + b → a = c)
attribute [to_additive add_right_cancel_semigroup] right_cancel_semigroup

section right_cancel_semigroup
variables {G : Type u} [right_cancel_semigroup G] {a b c : G}

@[to_additive]
lemma mul_right_cancel : a * b = c * b → a = c :=
right_cancel_semigroup.mul_right_cancel a b c

@[to_additive]
lemma mul_right_cancel_iff : b * a = c * a ↔ b = c :=
⟨mul_right_cancel, congr_arg _⟩

@[to_additive]
theorem mul_left_injective (a : G) : function.injective (λ x, x * a) :=
λ b c, mul_right_cancel

@[simp, to_additive]
theorem mul_left_inj (a : G) {b c : G} : b * a = c * a ↔ b = c :=
(mul_left_injective a).eq_iff

@[to_additive]
theorem mul_ne_mul_left (a : G) {b c : G} : b * a ≠ c * a ↔ b ≠ c :=
(mul_left_injective a).ne_iff

end right_cancel_semigroup

/-- Typeclass for expressing that a type `M` with multiplication and a one satisfies
`1 * a = a` and `a * 1 = a` for all `a : M`. -/
@[ancestor has_one has_mul]
class mul_one_class (M : Type u) extends has_one M, has_mul M :=
(one_mul : ∀ (a : M), 1 * a = a)
(mul_one : ∀ (a : M), a * 1 = a)

/-- Typeclass for expressing that a type `M` with addition and a zero satisfies
`0 + a = a` and `a + 0 = a` for all `a : M`. -/
@[ancestor has_zero has_add]
class add_zero_class (M : Type u) extends has_zero M, has_add M :=
(zero_add : ∀ (a : M), 0 + a = a)
(add_zero : ∀ (a : M), a + 0 = a)

attribute [to_additive] mul_one_class

section mul_one_class
variables {M : Type u} [mul_one_class M]

@[ematch, simp, to_additive]
lemma one_mul : ∀ a : M, 1 * a = a :=
mul_one_class.one_mul

@[ematch, simp, to_additive]
lemma mul_one : ∀ a : M, a * 1 = a :=
mul_one_class.mul_one

attribute [ematch] add_zero zero_add -- TODO(Mario): Make to_additive transfer this

@[to_additive]
instance mul_one_class.to_is_left_id : is_left_id M (*) 1 :=
⟨ mul_one_class.one_mul ⟩

@[to_additive]
instance mul_one_class.to_is_right_id : is_right_id M (*) 1 :=
⟨ mul_one_class.mul_one ⟩

end mul_one_class

section
variables {M : Type u}

-- use `x * npow_rec n x` and not `npow_rec n x * x` in the definition to make sure that
-- definitional unfolding of `npow_rec` is blocked, to avoid deep recursion issues.
/-- The fundamental power operation in a monoid. `npow_rec n a = a*a*...*a` n times.
Use instead `a ^ n`,  which has better definitional behavior. -/
def npow_rec [has_one M] [has_mul M] : ℕ → M → M
| 0     a := 1
| (n+1) a := a * npow_rec n a

/-- The fundamental scalar multiplication in an additive monoid. `nsmul_rec n a = a+a+...+a` n
times. Use instead `n • a`, which has better definitional behavior. -/
def nsmul_rec [has_zero M] [has_add M] : ℕ → M → M
| 0     a := 0
| (n+1) a := a + nsmul_rec n a

attribute [to_additive] npow_rec

end

/-- Suppose that one can put two mathematical structures on a type, a rich one `R` and a poor one
`P`, and that one can deduce the poor structure from the rich structure through a map `F` (called a
forgetful functor) (think `R = metric_space` and `P = topological_space`). A possible
implementation would be to have a type class `rich` containing a field `R`, a type class `poor`
containing a field `P`, and an instance from `rich` to `poor`. However, this creates diamond
problems, and a better approach is to let `rich` extend `poor` and have a field saying that
`F R = P`.

To illustrate this, consider the pair `metric_space` / `topological_space`. Consider the topology
on a product of two metric spaces. With the first approach, it could be obtained by going first from
each metric space to its topology, and then taking the product topology. But it could also be
obtained by considering the product metric space (with its sup distance) and then the topology
coming from this distance. These would be the same topology, but not definitionally, which means
that from the point of view of Lean's kernel, there would be two different `topological_space`
instances on the product. This is not compatible with the way instances are designed and used:
there should be at most one instance of a kind on each type. This approach has created an instance
diamond that does not commute definitionally.

The second approach solves this issue. Now, a metric space contains both a distance, a topology, and
a proof that the topology coincides with the one coming from the distance. When one defines the
product of two metric spaces, one uses the sup distance and the product topology, and one has to
give the proof that the sup distance induces the product topology. Following both sides of the
instance diamond then gives rise (definitionally) to the product topology on the product space.

Another approach would be to have the rich type class take the poor type class as an instance
parameter. It would solve the diamond problem, but it would lead to a blow up of the number
of type classes one would need to declare to work with complicated classes, say a real inner
product space, and would create exponential complexity when working with products of
such complicated spaces, that are avoided by bundling things carefully as above.

Note that this description of this specific case of the product of metric spaces is oversimplified
compared to mathlib, as there is an intermediate typeclass between `metric_space` and
`topological_space` called `uniform_space`. The above scheme is used at both levels, embedding a
topology in the uniform space structure, and a uniform structure in the metric space structure.

Note also that, when `P` is a proposition, there is no such issue as any two proofs of `P` are
definitionally equivalent in Lean.

To avoid boilerplate, there are some designs that can automatically fill the poor fields when
creating a rich structure if one doesn't want to do something special about them. For instance,
in the definition of metric spaces, default tactics fill the uniform space fields if they are
not given explicitly. One can also have a helper function creating the rich structure from a
structure with fewer fields, where the helper function fills the remaining fields. See for instance
`uniform_space.of_core` or `real_inner_product.of_core`.

For more details on this question, called the forgetful inheritance pattern, see [Competing
inheritance paths in dependent type theory: a case study in functional
analysis](https://hal.inria.fr/hal-02463336).
-/
library_note "forgetful inheritance"

/-- `try_refl_tac` solves goals of the form `∀ a b, f a b = g a b`,
if they hold by definition. -/
meta def try_refl_tac : tactic unit := `[intros; refl]

/-!
### Design note on `add_monoid` and `monoid`

An `add_monoid` has a natural `ℕ`-action, defined by `n • a = a + ... + a`, that we want to declare
as an instance as it makes it possible to use the language of linear algebra. However, there are
often other natural `ℕ`-actions. For instance, for any semiring `R`, the space of polynomials
`polynomial R` has a natural `R`-action defined by multiplication on the coefficients. This means
that `polynomial ℕ` would have two natural `ℕ`-actions, which are equal but not defeq. The same
goes for linear maps, tensor products, and so on (and even for `ℕ` itself).

To solve this issue, we embed an `ℕ`-action in the definition of an `add_monoid` (which is by
default equal to the naive action `a + ... + a`, but can be adjusted when needed), and declare
a `has_scalar ℕ α` instance using this action. See Note [forgetful inheritance] for more
explanations on this pattern.

For example, when we define `polynomial R`, then we declare the `ℕ`-action to be by multiplication
on each coefficient (using the `ℕ`-action on `R` that comes from the fact that `R` is
an `add_monoid`). In this way, the two natural `has_scalar ℕ (polynomial ℕ)` instances are defeq.

The tactic `to_additive` transfers definitions and results from multiplicative monoids to additive
monoids. To work, it has to map fields to fields. This means that we should also add corresponding
fields to the multiplicative structure `monoid`, which could solve defeq problems for powers if
needed. These problems do not come up in practice, so most of the time we will not need to adjust
the `npow` field when defining multiplicative objects.

Nice notation and a basic theory for the power function on monoids and the `ℕ`-action on additive
monoids are built in the file `algebra.group_power.basic`. For now, we only register the most basic
properties that we need right away.

In the definition, we use `n.succ` instead of `n + 1` in the `nsmul_succ'` and `npow_succ'` fields
to make sure that `to_additive` is not confused (otherwise, it would try to convert `1 : ℕ`
to `0 : ℕ`).
-/

/-- An `add_monoid` is an `add_semigroup` with an element `0` such that `0 + a = a + 0 = a`. -/
@[ancestor add_semigroup add_zero_class]
class add_monoid (M : Type u) extends add_semigroup M, add_zero_class M :=
(nsmul : ℕ → M → M := nsmul_rec)
(nsmul_zero' : ∀ x, nsmul 0 x = 0 . try_refl_tac)
(nsmul_succ' : ∀ (n : ℕ) x, nsmul n.succ x = x + nsmul n x . try_refl_tac)

export add_monoid (nsmul)

/-- A `monoid` is a `semigroup` with an element `1` such that `1 * a = a * 1 = a`. -/
@[ancestor semigroup mul_one_class, to_additive]
class monoid (M : Type u) extends semigroup M, mul_one_class M :=
(npow : ℕ → M → M := npow_rec)
(npow_zero' : ∀ x, npow 0 x = 1 . try_refl_tac)
(npow_succ' : ∀ (n : ℕ) x, npow n.succ x = x * npow n x . try_refl_tac)

export monoid (npow)

section monoid
variables {M : Type u} [monoid M]

@[to_additive]
lemma left_inv_eq_right_inv {a b c : M} (hba : b * a = 1) (hac : a * c = 1) : b = c :=
by rw [←one_mul c, ←hba, mul_assoc, hac, mul_one b]

end monoid

lemma npow_one {M : Type u} [monoid M] (x : M) :
  npow 1 x = x :=
by simp [monoid.npow_succ', monoid.npow_zero']

lemma nsmul_one' {M : Type u} [add_monoid M] (x : M) :
  nsmul 1 x = x :=
by simp [add_monoid.nsmul_succ', add_monoid.nsmul_zero']

attribute [to_additive nsmul_one'] npow_one

@[to_additive nsmul_add']
lemma npow_add {M : Type u} [monoid M] (m n : ℕ) (x : M) :
  npow (m + n) x = npow m x * npow n x :=
begin
  induction m with m ih,
  { rw [nat.zero_add, monoid.npow_zero', one_mul], },
  { rw [nat.succ_add, monoid.npow_succ', monoid.npow_succ', ih, ← mul_assoc] }
end

/-- An additive commutative monoid is an additive monoid with commutative `(+)`. -/
@[protect_proj, ancestor add_monoid add_comm_semigroup]
class add_comm_monoid (M : Type u) extends add_monoid M, add_comm_semigroup M

/-- A commutative monoid is a monoid with commutative `(*)`. -/
@[protect_proj, ancestor monoid comm_semigroup, to_additive]
class comm_monoid (M : Type u) extends monoid M, comm_semigroup M

section left_cancel_monoid

/-- An additive monoid in which addition is left-cancellative.
Main examples are `ℕ` and groups. This is the right typeclass for many sum lemmas, as having a zero
is useful to define the sum over the empty set, so `add_left_cancel_semigroup` is not enough. -/
@[protect_proj, ancestor add_left_cancel_semigroup add_monoid]
class add_left_cancel_monoid (M : Type u) extends add_left_cancel_semigroup M, add_monoid M

/-- A monoid in which multiplication is left-cancellative. -/
@[protect_proj, ancestor left_cancel_semigroup monoid, to_additive add_left_cancel_monoid]
class left_cancel_monoid (M : Type u) extends left_cancel_semigroup M, monoid M

end left_cancel_monoid

section right_cancel_monoid

/-- An additive monoid in which addition is right-cancellative.
Main examples are `ℕ` and groups. This is the right typeclass for many sum lemmas, as having a zero
is useful to define the sum over the empty set, so `add_right_cancel_semigroup` is not enough. -/
@[protect_proj, ancestor add_right_cancel_semigroup add_monoid]
class add_right_cancel_monoid (M : Type u) extends add_right_cancel_semigroup M, add_monoid M

/-- A monoid in which multiplication is right-cancellative. -/
@[protect_proj, ancestor right_cancel_semigroup monoid, to_additive add_right_cancel_monoid]
class right_cancel_monoid (M : Type u) extends right_cancel_semigroup M, monoid M

end right_cancel_monoid

section cancel_monoid

/-- An additive monoid in which addition is cancellative on both sides.
Main examples are `ℕ` and groups. This is the right typeclass for many sum lemmas, as having a zero
is useful to define the sum over the empty set, so `add_right_cancel_semigroup` is not enough. -/
@[protect_proj, ancestor add_left_cancel_monoid add_right_cancel_monoid]
class add_cancel_monoid (M : Type u)
  extends add_left_cancel_monoid M, add_right_cancel_monoid M

/-- A monoid in which multiplication is cancellative. -/
@[protect_proj, ancestor left_cancel_monoid right_cancel_monoid, to_additive add_cancel_monoid]
class cancel_monoid (M : Type u) extends left_cancel_monoid M, right_cancel_monoid M

/-- Commutative version of add_cancel_monoid. -/
@[protect_proj, ancestor add_left_cancel_monoid add_comm_monoid]
class add_cancel_comm_monoid (M : Type u) extends add_left_cancel_monoid M, add_comm_monoid M

/-- Commutative version of cancel_monoid. -/
@[protect_proj, ancestor left_cancel_monoid comm_monoid, to_additive add_cancel_comm_monoid]
class cancel_comm_monoid (M : Type u) extends left_cancel_monoid M, comm_monoid M

@[priority 100, to_additive] -- see Note [lower instance priority]
instance cancel_comm_monoid.to_cancel_monoid (M : Type u) [cancel_comm_monoid M] :
  cancel_monoid M :=
{ mul_right_cancel := λ a b c h, mul_left_cancel $ by rw [mul_comm, h, mul_comm],
  .. ‹cancel_comm_monoid M› }

end cancel_monoid

/-- The fundamental power operation in a group. `gpow_rec n a = a*a*...*a` n times, for integer `n`.
Use instead `a ^ n`,  which has better definitional behavior. -/
def gpow_rec {M : Type*} [has_one M] [has_mul M] [has_inv M] : ℤ → M → M
| (int.of_nat n) a := npow_rec n a
| -[1+ n]    a := (npow_rec n.succ a) ⁻¹

/-- The fundamental scalar multiplication in an additive group. `gsmul_rec n a = a+a+...+a` n
times, for integer `n`. Use instead `n • a`, which has better definitional behavior. -/
def gsmul_rec {M : Type*} [has_zero M] [has_add M] [has_neg M]: ℤ → M → M
| (int.of_nat n) a := nsmul_rec n a
| -[1+ n]    a := - (nsmul_rec n.succ a)

attribute [to_additive] gpow_rec

/-- A `div_inv_monoid` is a `monoid` with operations `/` and `⁻¹` satisfying
`div_eq_mul_inv : ∀ a b, a / b = a * b⁻¹`.

This is the immediate common ancestor of `group` and `group_with_zero`,
in order to deduplicate the name `div_eq_mul_inv`.
The default for `div` is such that `a / b = a * b⁻¹` holds by definition.

Adding `div` as a field rather than defining `a / b := a * b⁻¹` allows us to
avoid certain classes of unification failures, for example:
Let `foo X` be a type with a `∀ X, has_div (foo X)` instance but no
`∀ X, has_inv (foo X)`, e.g. when `foo X` is a `euclidean_domain`. Suppose we
also have an instance `∀ X [cromulent X], group_with_zero (foo X)`. Then the
`(/)` coming from `group_with_zero_has_div` cannot be definitionally equal to
the `(/)` coming from `foo.has_div`.

In the same way, adding a `gpow` field makes it possible to avoid definitional failures
in diamonds. See the definition of `monoid` and Note [forgetful inheritance] for more
explanations on this.
-/
@[protect_proj, ancestor monoid has_inv has_div]
class div_inv_monoid (G : Type u) extends monoid G, has_inv G, has_div G :=
(div := λ a b, a * b⁻¹)
(div_eq_mul_inv : ∀ a b : G, a / b = a * b⁻¹ . try_refl_tac)
(gpow : ℤ → G → G := gpow_rec)
(gpow_zero' : ∀ (a : G), gpow 0 a = 1 . try_refl_tac)
(gpow_succ' :
  ∀ (n : ℕ) (a : G), gpow (int.of_nat n.succ) a = a * gpow (int.of_nat n) a  . try_refl_tac)
(gpow_neg' :
  ∀ (n : ℕ) (a : G), gpow (-[1+ n]) a = (gpow n.succ a) ⁻¹ . try_refl_tac)

export div_inv_monoid (gpow)

/-- A `sub_neg_monoid` is an `add_monoid` with unary `-` and binary `-` operations
satisfying `sub_eq_add_neg : ∀ a b, a - b = a + -b`.

The default for `sub` is such that `a - b = a + -b` holds by definition.

Adding `sub` as a field rather than defining `a - b := a + -b` allows us to
avoid certain classes of unification failures, for example:
Let `foo X` be a type with a `∀ X, has_sub (foo X)` instance but no
`∀ X, has_neg (foo X)`. Suppose we also have an instance
`∀ X [cromulent X], add_group (foo X)`. Then the `(-)` coming from
`add_group.has_sub` cannot be definitionally equal to the `(-)` coming from
`foo.has_sub`.

In the same way, adding a `gsmul` field makes it possible to avoid definitional failures
in diamonds. See the definition of `add_monoid` and Note [forgetful inheritance] for more
explanations on this.
-/
@[protect_proj, ancestor add_monoid has_neg has_sub]
class sub_neg_monoid (G : Type u) extends add_monoid G, has_neg G, has_sub G :=
(sub := λ a b, a + -b)
(sub_eq_add_neg : ∀ a b : G, a - b = a + -b . try_refl_tac)
(gsmul : ℤ → G → G := gsmul_rec)
(gsmul_zero' : ∀ (a : G), gsmul 0 a = 0 . try_refl_tac)
(gsmul_succ' :
  ∀ (n : ℕ) (a : G), gsmul (int.of_nat n.succ) a = a + gsmul (int.of_nat n) a  . try_refl_tac)
(gsmul_neg' :
  ∀ (n : ℕ) (a : G), gsmul (-[1+ n]) a = - (gsmul n.succ a) . try_refl_tac)

export sub_neg_monoid (gsmul)

attribute [to_additive sub_neg_monoid] div_inv_monoid

@[to_additive]
lemma div_eq_mul_inv {G : Type u} [div_inv_monoid G] :
  ∀ a b : G, a / b = a * b⁻¹ :=
div_inv_monoid.div_eq_mul_inv

/-- A `group` is a `monoid` with an operation `⁻¹` satisfying `a⁻¹ * a = 1`.

There is also a division operation `/` such that `a / b = a * b⁻¹`,
with a default so that `a / b = a * b⁻¹` holds by definition.
-/
@[protect_proj, ancestor div_inv_monoid]
class group (G : Type u) extends div_inv_monoid G :=
(mul_left_inv : ∀ a : G, a⁻¹ * a = 1)

/-- An `add_group` is an `add_monoid` with a unary `-` satisfying `-a + a = 0`.

There is also a binary operation `-` such that `a - b = a + -b`,
with a default so that `a - b = a + -b` holds by definition.
-/
@[protect_proj, ancestor sub_neg_monoid]
class add_group (A : Type u) extends sub_neg_monoid A :=
(add_left_neg : ∀ a : A, -a + a = 0)

attribute [to_additive] group

/-- Abbreviation for `@div_inv_monoid.to_monoid _ (@group.to_div_inv_monoid _ _)`.

Useful because it corresponds to the fact that `Grp` is a subcategory of `Mon`.
Not an instance since it duplicates `@div_inv_monoid.to_monoid _ (@group.to_div_inv_monoid _ _)`.
-/
@[to_additive
"Abbreviation for `@sub_neg_monoid.to_add_monoid _ (@add_group.to_sub_neg_monoid _ _)`.

Useful because it corresponds to the fact that `AddGroup` is a subcategory of `AddMon`.
Not an instance since it duplicates
`@sub_neg_monoid.to_add_monoid _ (@add_group.to_sub_neg_monoid _ _)`."]
def group.to_monoid (G : Type u) [group G] : monoid G :=
@div_inv_monoid.to_monoid _ (@group.to_div_inv_monoid _ _)

section group
variables {G : Type u} [group G] {a b c : G}

@[simp, to_additive]
lemma mul_left_inv : ∀ a : G, a⁻¹ * a = 1 :=
group.mul_left_inv

@[to_additive] lemma inv_mul_self (a : G) : a⁻¹ * a = 1 := mul_left_inv a

@[simp, to_additive]
lemma inv_mul_cancel_left (a b : G) : a⁻¹ * (a * b) = b :=
by rw [← mul_assoc, mul_left_inv, one_mul]

@[simp, to_additive]
lemma inv_eq_of_mul_eq_one (h : a * b = 1) : a⁻¹ = b :=
left_inv_eq_right_inv (inv_mul_self a) h

@[simp, to_additive]
lemma inv_inv (a : G) : (a⁻¹)⁻¹ = a :=
inv_eq_of_mul_eq_one (mul_left_inv a)

@[simp, to_additive]
lemma mul_right_inv (a : G) : a * a⁻¹ = 1 :=
have a⁻¹⁻¹ * a⁻¹ = 1 := mul_left_inv a⁻¹,
by rwa [inv_inv] at this

@[to_additive] lemma mul_inv_self (a : G) : a * a⁻¹ = 1 := mul_right_inv a

@[simp, to_additive]
lemma mul_inv_cancel_right (a b : G) : a * b * b⁻¹ = a :=
by rw [mul_assoc, mul_right_inv, mul_one]

@[priority 100, to_additive]    -- see Note [lower instance priority]
instance group.to_cancel_monoid : cancel_monoid G :=
{ mul_right_cancel := λ a b c h, by rw [← mul_inv_cancel_right a b, h, mul_inv_cancel_right],
  mul_left_cancel := λ a b c h, by rw [← inv_mul_cancel_left a b, h, inv_mul_cancel_left],
  ..‹group G› }

end group

/-- A commutative group is a group with commutative `(*)`. -/
@[protect_proj, ancestor group comm_monoid]
class comm_group (G : Type u) extends group G, comm_monoid G
/-- An additive commutative group is an additive group with commutative `(+)`. -/
@[protect_proj, ancestor add_group add_comm_monoid]
class add_comm_group (G : Type u) extends add_group G, add_comm_monoid G
attribute [to_additive] comm_group
attribute [instance, priority 300] add_comm_group.to_add_comm_monoid

section comm_group

variables {G : Type u} [comm_group G]

@[priority 100, to_additive]    -- see Note [lower instance priority]
instance comm_group.to_cancel_comm_monoid : cancel_comm_monoid G :=
{ ..‹comm_group G›,
  ..group.to_cancel_monoid }

end comm_group


import Categories.Proto

set_option autoImplicit false

namespace Mathematics

structure Functor (A B : Category) :=
(apply : A.obj → B.obj)
(map   : Π {a b : A.obj}, Hom A a b → Hom B (apply a) (apply b))
(idm   : Π x, @map x x 1 = 1)
(com   : Π {a b c : A.obj} (f : Hom A b c) (g : Hom A a b), map (f ∘ g) = map f ∘ map g)

lemma Functor.eq {A B : Category} (F G : Functor A B) (h₁ : F.apply = G.apply) (h₂ : HEq (@Functor.map A B F) (@Functor.map A B G)) : F = G :=
begin cases F; cases G; simp at h₁ h₂; subst h₁; subst h₂; rfl end

instance (A B : Category) : CoeFun (Functor A B) (λ _, A.obj → B.obj) :=
⟨Functor.apply⟩

def idfun (C : Category) : Functor C C :=
{ apply := id,
  map   := id,
  idm   := λ _, rfl,
  com   := λ _ _, rfl }

def comfun {A B C : Category} (F : Functor B C) (G : Functor A B) : Functor A C :=
{ apply := λ x, F (G x),
  map   := λ g, F.map (G.map g),
  idm   := by { intros; dsimp; rw [G.idm, F.idm] },
  com   := by { intros; dsimp; rw [G.com, F.com] } }

def Δ {A : Category} (B : Category) (b : B.obj) : Functor A B :=
{ apply := λ _, b,
  map   := λ _, B.id b,
  idm   := λ _, rfl,
  com   := λ _ _, Eq.symm (B.lid _) }

instance (C : Category) : OfNat (Functor C C) 1 := ⟨idfun C⟩

def Natural {A B : Category} (F G : Functor A B) :=
{ η : Π x, Hom B (F x) (G x) // Π {a b : A.obj} (f : Hom A a b), η b ∘ F.map f = G.map f ∘ η a }

instance (A B : Category) (F G : Functor A B) : CoeFun (Natural F G) (λ _, Π x, Hom B (F x) (G x)) :=
⟨Subtype.val⟩

def Natural.id {A B : Category} (F : Functor A B) : Natural F F :=
⟨λ x, B.id (F x), λ _, by rw [B.lid, B.rid]⟩

def Natural.vert {A B : Category} {F G H : Functor A B} (η : Natural G H) (μ : Natural F G) : Natural F H :=
⟨λ x, η x ∘ μ x, λ _, by rw [B.assoc, μ.property, ←B.assoc, η.property, B.assoc]⟩

section
  variable {A B : Category}

  lemma Natural.lid {F G : Functor A B} (η : Natural F G) : Natural.vert (Natural.id G) η = η :=
  begin apply Subtype.eq; funext _; apply B.lid end

  lemma Natural.rid {F G : Functor A B} (η : Natural F G) : Natural.vert η (Natural.id F) = η :=
  begin apply Subtype.eq; funext _; apply B.rid end

  lemma Natural.assoc {F G H K : Functor A B} (η : Natural H K) (μ : Natural G H) (ε : Natural F G) :
    Natural.vert (Natural.vert η μ) ε = Natural.vert η (Natural.vert μ ε) :=
  begin apply Subtype.eq; funext _; apply B.assoc end
end

def Natural.hasInv {A B : Category} {F G : Functor A B} (η : Natural F G) :=
{ ε : Natural G F // Natural.vert η ε = Natural.id G ∧ Natural.vert ε η = Natural.id F }

def Functor.iso {A B : Category} (F G : Functor A B) :=
Σ (η : Natural F G), η.hasInv

def Functor.category (A B : Category) : Category :=
{ obj   := Functor A B,
  hom   := Natural,
  id    := Natural.id,
  com   := Natural.vert,
  lid   := Natural.lid,
  rid   := Natural.rid,
  assoc := Natural.assoc }

instance : HPow Category Category Category := ⟨λ B A, Functor.category A B⟩

def functorIso {A B : Category} (F : Functor A B) {a b : A.obj} (f : a ≅ b) : F a ≅ F b :=
begin
  exists F.map f.1; exists F.map f.2.1; constructor;
  rw [←F.com, f.2.2.1, F.idm]; rw [←F.com, f.2.2.2, F.idm]
end

def Algebra {C : Category} (F : Functor C C) :=
Σ (c : C.obj), Hom C (F c) c

def Algebra.hom {C : Category} {F : Functor C C} (Γ₁ Γ₂ : Algebra F) :=
{ φ : Hom C Γ₁.1 Γ₂.1 // φ ∘ Γ₁.2 = Γ₂.2 ∘ F.map φ }

def Algebra.idhom {C : Category} {F : Functor C C} (Γ : Algebra F) : Algebra.hom Γ Γ :=
⟨1, begin rw [F.idm]; apply Eq.trans; apply C.lid; apply Eq.symm (C.rid _) end⟩

def Algebra.com {C : Category} {F : Functor C C} {Γ₁ Γ₂ Γ₃ : Algebra F}
  (φ : Algebra.hom Γ₂ Γ₃) (ψ : Algebra.hom Γ₁ Γ₂) : Algebra.hom Γ₁ Γ₃ :=
⟨φ.1 ∘ ψ.1, by rw [C.assoc, ψ.2, ←C.assoc, φ.2, C.assoc, F.com]⟩

section
  variable {C : Category} {F : Functor C C}

  lemma Algebra.lid {Γ₁ Γ₂ : Algebra F} (φ : Algebra.hom Γ₁ Γ₂) : Algebra.com (Algebra.idhom Γ₂) φ = φ :=
  begin apply Subtype.eq; apply C.lid end

  lemma Algebra.rid {Γ₁ Γ₂ : Algebra F} (φ : Algebra.hom Γ₁ Γ₂) : Algebra.com φ (Algebra.idhom Γ₁) = φ :=
  begin apply Subtype.eq; apply C.rid end

  lemma Algebra.assoc {Γ₁ Γ₂ Γ₃ Γ₄ : Algebra F} (φ : Algebra.hom Γ₃ Γ₄) (ψ : Algebra.hom Γ₂ Γ₃) (ρ : Algebra.hom Γ₁ Γ₂) :
    Algebra.com (Algebra.com φ ψ) ρ = Algebra.com φ (Algebra.com ψ ρ) :=
  begin apply Subtype.eq; apply C.assoc end
end

def Algebra.category {C : Category} (F : Functor C C) : Category :=
{ obj   := Algebra F,
  hom   := Algebra.hom,
  id    := Algebra.idhom,
  com   := Algebra.com,
  lid   := Algebra.lid,
  rid   := Algebra.rid,
  assoc := Algebra.assoc }

notation "𝐴𝑙𝑔𝑒𝑏𝑟𝑎" => Algebra.category


/-
Copyright (c) 2018 Kevin Buzzard and Patrick Massot. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kevin Buzzard, Patrick Massot.

This file is to a certain extent based on `quotient_module.lean` by Johannes Hölzl.
-/
import group_theory.coset

universes u v

namespace quotient_group

variables {G : Type u} [group G] (N : set G) [normal_subgroup N] {H : Type v} [group H]

instance : group (quotient N) :=
{ one := (1 : G),
  mul := λ a b, quotient.lift_on₂' a b
    (λ a b, ((a * b : G) : quotient N))
  (λ a₁ a₂ b₁ b₂ hab₁ hab₂,
      quot.sound
    ((is_subgroup.mul_mem_cancel_left N (is_subgroup.inv_mem hab₂)).1
        (by rw [mul_inv_rev, mul_inv_rev, ← mul_assoc (a₂⁻¹ * a₁⁻¹),
          mul_assoc _ b₂, ← mul_assoc b₂, mul_inv_self, one_mul, mul_assoc (a₂⁻¹)];
          exact normal_subgroup.normal _ hab₁ _))),
  mul_assoc := λ a b c, quotient.induction_on₃' a b c
    (λ a b c, congr_arg mk (mul_assoc a b c)),
  one_mul := λ a, quotient.induction_on' a
    (λ a, congr_arg mk (one_mul a)),
  mul_one := λ a, quotient.induction_on' a
    (λ a, congr_arg mk (mul_one a)),
  inv := λ a, quotient.lift_on' a (λ a, ((a⁻¹ : G) : quotient N))
    (λ a b hab, quotient.sound' begin
      show a⁻¹⁻¹ * b⁻¹ ∈ N,
      rw ← mul_inv_rev,
      exact is_subgroup.inv_mem (is_subgroup.mem_norm_comm hab)
    end),
  mul_left_inv := λ a, quotient.induction_on' a
    (λ a, congr_arg mk (mul_left_inv a)) }
attribute [to_additive quotient_add_group.add_group._proof_6] quotient_group.group._proof_6
attribute [to_additive quotient_add_group.add_group._proof_5] quotient_group.group._proof_5
attribute [to_additive quotient_add_group.add_group._proof_4] quotient_group.group._proof_4
attribute [to_additive quotient_add_group.add_group._proof_3] quotient_group.group._proof_3
attribute [to_additive quotient_add_group.add_group._proof_2] quotient_group.group._proof_2
attribute [to_additive quotient_add_group.add_group._proof_1] quotient_group.group._proof_1
attribute [to_additive quotient_add_group.add_group] quotient_group.group
attribute [to_additive quotient_add_group.quotient.equations._eqn_1] quotient_group.quotient.equations._eqn_1
attribute [to_additive quotient_add_group.add_group.equations._eqn_1] quotient_group.group.equations._eqn_1

instance : is_group_hom (mk : G → quotient N) := ⟨λ _ _, rfl⟩
attribute [to_additive quotient_add_group.is_add_group_hom] quotient_group.is_group_hom
attribute [to_additive quotient_add_group.is_add_group_hom.equations._eqn_1] quotient_group.is_group_hom.equations._eqn_1

@[simp] lemma ker_mk :
  is_group_hom.ker (quotient_group.mk : G → quotient_group.quotient N) = N :=
begin
  ext g,
  rw [is_group_hom.mem_ker, eq_comm],
  show (((1 : G) : quotient_group.quotient N)) = g ↔ _,
  rw [quotient_group.eq, one_inv, one_mul],
end
attribute [to_additive quotient_add_group.ker_mk] quotient_group.ker_mk

instance {G : Type*} [comm_group G] (s : set G) [is_subgroup s] : comm_group (quotient s) :=
{ mul_comm := λ a b, quotient.induction_on₂' a b
    (λ a b, congr_arg mk (mul_comm a b)),
  ..@quotient_group.group _ _ s (normal_subgroup_of_comm_group s) }
attribute [to_additive quotient_add_group.add_comm_group._proof_6] quotient_group.comm_group._proof_6
attribute [to_additive quotient_add_group.add_comm_group._proof_5] quotient_group.comm_group._proof_5
attribute [to_additive quotient_add_group.add_comm_group._proof_4] quotient_group.comm_group._proof_4
attribute [to_additive quotient_add_group.add_comm_group._proof_3] quotient_group.comm_group._proof_3
attribute [to_additive quotient_add_group.add_comm_group._proof_2] quotient_group.comm_group._proof_2
attribute [to_additive quotient_add_group.add_comm_group._proof_1] quotient_group.comm_group._proof_1
attribute [to_additive quotient_add_group.add_comm_group] quotient_group.comm_group
attribute [to_additive quotient_add_group.add_comm_group.equations._eqn_1] quotient_group.comm_group.equations._eqn_1

@[simp] lemma coe_one : ((1 : G) : quotient N) = 1 := rfl
@[simp] lemma coe_mul (a b : G) : ((a * b : G) : quotient N) = a * b := rfl
@[simp] lemma coe_inv (a : G) : ((a⁻¹ : G) : quotient N) = a⁻¹ := rfl
@[simp] lemma coe_pow (a : G) (n : ℕ) : ((a ^ n : G) : quotient N) = a ^ n :=
@is_group_hom.pow _ _ _ _ mk _ a n

attribute [to_additive quotient_add_group.coe_zero] coe_one
attribute [to_additive quotient_add_group.coe_add] coe_mul
attribute [to_additive quotient_add_group.coe_neg] coe_inv

@[simp] lemma coe_gpow (a : G) (n : ℤ) : ((a ^ n : G) : quotient N) = a ^ n :=
@is_group_hom.gpow _ _ _ _ mk _ a n

local notation ` Q ` := quotient N

def lift (φ : G → H) [is_group_hom φ] (HN : ∀x∈N, φ x = 1) (q : Q) : H :=
q.lift_on' φ $ assume a b (hab : a⁻¹ * b ∈ N),
(calc φ a = φ a * 1           : by simp
...       = φ a * φ (a⁻¹ * b) : by rw HN (a⁻¹ * b) hab
...       = φ (a * (a⁻¹ * b)) : by rw is_group_hom.mul φ a (a⁻¹ * b)
...       = φ b               : by simp)
attribute [to_additive quotient_add_group.lift._proof_1] lift._proof_1
attribute [to_additive quotient_add_group.lift] lift
attribute [to_additive quotient_add_group.lift.equations._eqn_1] lift.equations._eqn_1

@[simp] lemma lift_mk {φ : G → H} [is_group_hom φ] (HN : ∀x∈N, φ x = 1) (g : G) :
  lift N φ HN (g : Q) = φ g := rfl
attribute [to_additive quotient_add_group.lift_mk] lift_mk

@[simp] lemma lift_mk' {φ : G → H} [is_group_hom φ] (HN : ∀x∈N, φ x = 1) (g : G) :
  lift N φ HN (mk g : Q) = φ g := rfl
attribute [to_additive quotient_add_group.lift_mk'] lift_mk'

def map (M : set H) [normal_subgroup M] (f : G → H) [is_group_hom f] (h : N ⊆ f ⁻¹' M) :
  quotient N → quotient M :=
begin
  haveI : is_group_hom ((mk : H → quotient M) ∘ f) := is_group_hom.comp _ _,
  refine quotient_group.lift N (mk ∘ f) _,
  assume x hx,
  refine quotient_group.eq.2 _,
  rw [mul_one, is_subgroup.inv_mem_iff],
  exact h hx,
end

attribute [to_additive quotient_add_group.map._proof_1] map._proof_1
attribute [to_additive quotient_add_group.map._proof_2] map._proof_2
attribute [to_additive quotient_add_group.map] map

variables (φ : G → H) [is_group_hom φ] (HN : ∀x∈N, φ x = 1)

instance is_group_hom_quotient_lift  :
  is_group_hom (lift N φ HN) :=
⟨λ q r, quotient.induction_on₂' q r $ λ a b,
  show φ (a * b) = φ a * φ b, from is_group_hom.mul φ a b⟩
attribute [to_additive quotient_add_group.is_add_group_hom_quotient_lift] quotient_group.is_group_hom_quotient_lift
attribute [to_additive quotient_add_group.is_add_group_hom_quotient_lift.equations._eqn_1] quotient_group.is_group_hom_quotient_lift.equations._eqn_1

@[to_additive quotient_add_group.map_is_add_group_hom]
instance map_is_group_hom (M : set H) [normal_subgroup M]
(f : G → H) [is_group_hom f] (h : N ⊆ f ⁻¹' M) : is_group_hom (map N M f h) :=
quotient_group.is_group_hom_quotient_lift _ _ _

open function is_group_hom

/-- The induced map from the quotient by the kernel to the codomain. -/
def ker_lift : quotient (ker φ) → H :=
lift _ φ $ λ g, (mem_ker φ).mp

attribute [to_additive quotient_add_group.ker_lift._proof_1] quotient_group.ker_lift._proof_1
attribute [to_additive quotient_add_group.ker_lift._proof_2] quotient_group.ker_lift._proof_2
attribute [to_additive quotient_add_group.ker_lift] quotient_group.ker_lift
attribute [to_additive quotient_add_group.ker_lift.equations._eqn_1] quotient_group.ker_lift.equations._eqn_1

@[simp, to_additive quotient_add_group.ker_lift_mk]
lemma ker_lift_mk (g : G) : (ker_lift φ) g = φ g :=
lift_mk _ _ _

@[simp, to_additive quotient_add_group.ker_lift_mk']
lemma ker_lift_mk' (g : G) : (ker_lift φ) (mk g) = φ g :=
lift_mk' _ _ _

@[to_additive quotient_add_group.ker_lift_is_add_group_hom]
instance ker_lift_is_group_hom : is_group_hom (ker_lift φ) :=
quotient_group.is_group_hom_quotient_lift _ _ _

@[to_additive quotient_add_group.injective_ker_lift]
lemma injective_ker_lift : injective (ker_lift φ) :=
assume a b, quotient.induction_on₂' a b $ assume a b (h : φ a = φ b), quotient.sound' $
show a⁻¹ * b ∈ ker φ, by rw [mem_ker φ,
  is_group_hom.mul φ, ← h, is_group_hom.inv φ, inv_mul_self]

--@[to_additive quotient_add_group.quotient_ker_equiv_range]
noncomputable def quotient_ker_equiv_range : (quotient (ker φ)) ≃ set.range φ :=
@equiv.of_bijective _ (set.range φ) (λ x, ⟨lift (ker φ) φ
  (by simp [mem_ker]) x, by exact quotient.induction_on' x (λ x, ⟨x, rfl⟩)⟩)
⟨λ a b h, injective_ker_lift _ (subtype.mk.inj h),
  λ ⟨x, y, hy⟩, ⟨mk y, subtype.eq hy⟩⟩

noncomputable def quotient_ker_equiv_of_surjective (hφ : function.surjective φ) :
  (quotient (ker φ)) ≃ H :=
calc (quotient_group.quotient (is_group_hom.ker φ)) ≃ set.range φ : quotient_ker_equiv_range _
... ≃ H : ⟨λ a, a.1, λ b, ⟨b, hφ b⟩, λ ⟨_, _⟩, rfl, λ _, rfl⟩

end quotient_group

namespace quotient_add_group
open is_add_group_hom

variables {G : Type u} [_root_.add_group G] (N : set G) [normal_add_subgroup N] {H : Type v} [_root_.add_group H]
variables (φ : G → H) [_root_.is_add_group_hom φ]

noncomputable def quotient_ker_equiv_range : (quotient (ker φ)) ≃ set.range φ :=
@quotient_group.quotient_ker_equiv_range (multiplicative G) _ (multiplicative H) _ φ _

noncomputable def quotient_ker_equiv_of_surjective (hφ : function.surjective φ) : (quotient (ker φ)) ≃ H :=
@quotient_group.quotient_ker_equiv_of_surjective (multiplicative G) _ (multiplicative H) _ φ _ hφ

attribute [to_additive quotient_add_group.quotient_ker_equiv_range] quotient_group.quotient_ker_equiv_range
attribute [to_additive quotient_add_group.quotient_ker_equiv_of_surjective] quotient_group.quotient_ker_equiv_of_surjective

end quotient_add_group


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

/-!
# Building finitely supported functions off finsets

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

This file defines `finsupp.indicator` to help create finsupps from finsets.

## Main declarations

* `finsupp.indicator`: Turns a map from a `finset` into a `finsupp` from the entire type.
-/

noncomputable theory

open finset function

variables {ι α : Type*}

namespace finsupp
variables [has_zero α] {s : finset ι} (f : Π i ∈ s, α) {i : ι}

/-- Create an element of `ι →₀ α` from a finset `s` and a function `f` defined on this finset. -/
def indicator (s : finset ι) (f : Π i ∈ s, α) : ι →₀ α :=
{ to_fun := λ i, by haveI := classical.dec_eq ι; exact
    if H : i ∈ s then f i H else 0,
  support := by haveI := classical.dec_eq α; exact
    (s.attach.filter $ λ i : s, f i.1 i.2 ≠ 0).map (embedding.subtype _),
  mem_support_to_fun := λ i, begin
    letI := classical.dec_eq α,
    rw [mem_map, dite_ne_right_iff],
    exact ⟨λ ⟨⟨j, hj⟩, hf, rfl⟩, ⟨hj, (mem_filter.1 hf).2⟩,
      λ ⟨hi, hf⟩, ⟨⟨i, hi⟩, mem_filter.2 $ ⟨mem_attach _ _, hf⟩, rfl⟩⟩,
  end }

lemma indicator_of_mem (hi : i ∈ s) (f : Π i ∈ s, α) : indicator s f i = f i hi :=
@dif_pos _ (id _) hi _ _ _
lemma indicator_of_not_mem (hi : i ∉ s) (f : Π i ∈ s, α) : indicator s f i = 0 :=
@dif_neg _ (id _) hi _ _ _

variables (s i)

@[simp] lemma indicator_apply [decidable_eq ι] :
  indicator s f i = if hi : i ∈ s then f i hi else 0 := by convert rfl

lemma indicator_injective : injective (λ f : Π i ∈ s, α, indicator s f) :=
begin
  intros a b h,
  ext i hi,
  rw [←indicator_of_mem hi a, ←indicator_of_mem hi b],
  exact congr_fun h i,
end

lemma support_indicator_subset : ((indicator s f).support : set ι) ⊆ s :=
begin
  intros i hi,
  rw [mem_coe, mem_support_iff] at hi,
  by_contra,
  exact hi (indicator_of_not_mem h _),
end

lemma single_eq_indicator (i : ι) (b : α) :
  single i b = indicator {i} (λ _ _, b) :=
by { classical, ext, simp [single_apply, indicator_apply, @eq_comm _ a] }

end finsupp


import field_theory.galois
import topology.algebra.filter_basis
import algebra.algebra.subalgebra

open_locale classical

/-!
# Krull topology

We define the Krull topology on `L ≃ₐ[K] L` for an arbitrary field extension `L/K`. In order to do this,
we first define a `group_filter_basis` on `L ≃ₐ[K] L`, whose sets are `E.fixing_subgroup` for all
intermediate fields `E` with `E/K` finite dimensional.

## Main Definitions

- `finite_exts K L`. Given a field extension `L/K`, this is the set of intermediate fields that are
  finite-dimensional over `K`.

- `fixed_by_finite K L`. Given a field extension `L/K`, `fixed_by_finite K L` is the set of
  subsets `Gal(L/E)` of `Gal(L/K)`, where `E/K` is finite

- `gal_basis K L`. Given a field extension `L/K`, this is the filter basis on `L ≃ₐ[K] L` whose
  sets are `Gal(L/E)` for intermediate fields `E` with `E/K` finite.

- `gal_group_basis K L`. This is the same as `gal_basis K L`, but with the added structure
  that it is a group filter basis on `L ≃ₐ[K] L`, rather than just a filter basis.

- `krull_topology K L`. Given a field extension `L/K`, this is the topology on `L ≃ₐ[K] L`, induced by
  the group filter basis `gal_group_basis K L`.

## Notations

- In docstrings, we will write `Gal(L/E)` to denote the fixing subgroup of an intermediate field `E`.
  That is, `Gal(L/E)` is the subgroup of `L ≃ₐ[K] L` consisting of automorphisms that fix every
  element of `E`. In particular, we distinguish between `L ≃ₐ[E] L` and `Gal(L/E)`, since the
  former is defined to be a subgroup of `L ≃ₐ[K] L`, while the latter is a group in its own right.

## Implementation Notes

- `krull_topology K L` is defined as an instance for type class inference.
-/

/-- Mapping intermediate fields along algebra equivalences preserves the partial order -/
lemma intermediate_field.map_mono {K L M : Type*} [field K] [field L] [field M]
  [algebra K L] [algebra K M] {E1 E2 : intermediate_field K L}
  (e : L ≃ₐ[K] M) (h12 : E1 ≤ E2) :
E1.map e.to_alg_hom ≤ E2.map e.to_alg_hom :=
set.image_subset e h12

/-- Mapping intermediate fields along the identity does not change them -/
lemma intermediate_field.map_id {K L : Type*} [field K] [field L] [algebra K L]
{E : intermediate_field K L} :
E.map (alg_hom.id K L) = E :=
set_like.coe_injective $ set.image_id _

/-- Mapping a finite dimensional intermediate field along an algebra equivalence gives
  a finite-dimensional intermediate field. -/
lemma im_finite_dimensional {K L : Type*} [field K] [field L] [algebra K L]
{E : intermediate_field K L} (σ : L ≃ₐ[K] L) (h_findim : finite_dimensional K E):
finite_dimensional K (E.map σ.to_alg_hom) :=
linear_equiv.finite_dimensional (intermediate_field.intermediate_field_map σ E).to_linear_equiv

/-- Given a field extension `L/K`, `finite_exts K L` is the set of
intermediate field extensions `L/E/K` such that `E/K` is finite -/
def finite_exts (K : Type*) [field K] (L : Type*) [field L] [algebra K L] :
set (intermediate_field K L) :=
{E | finite_dimensional K E}

/-- Given a field extension `L/K`, `fixed_by_finite K L` is the set of
subsets `Gal(L/E)` of `L ≃ₐ[K] L`, where `E/K` is finite -/
def fixed_by_finite (K L : Type*) [field K] [field L] [algebra K L]: set (subgroup (L ≃ₐ[K] L)) :=
intermediate_field.fixing_subgroup '' (finite_exts K L)

/-- For an field extension `L/K`, the intermediate field `K` is finite-dimensional over `K` -/
lemma intermediate_field.finite_dimensional_bot (K L : Type*) [field K]
  [field L] [algebra K L] : finite_dimensional K (⊥ : intermediate_field K L) :=
finite_dimensional_of_dim_eq_one intermediate_field.dim_bot

/-- This lemma says that `Gal(L/K) = L ≃ₐ[K] L` -/
lemma intermediate_field.fixing_subgroup.bot {K L : Type*} [field K]
  [field L] [algebra K L] :
  intermediate_field.fixing_subgroup (⊥ : intermediate_field K L) = ⊤ :=
begin
  ext f,
  refine ⟨λ _, subgroup.mem_top _, λ _, _⟩,
  rintro ⟨x, hx⟩,
  rw intermediate_field.mem_bot at hx,
  rcases hx with ⟨y, rfl⟩,
  exact f.commutes y,
end

/-- If `L/K` is a field extension, then we have `Gal(L/K) ∈ fixed_by_finite K L` -/
lemma top_fixed_by_finite {K L : Type*} [field K] [field L] [algebra K L] :
  ⊤ ∈ fixed_by_finite K L :=
⟨⊥, intermediate_field.finite_dimensional_bot K L, intermediate_field.fixing_subgroup.bot⟩

/-- If `E1` and `E2` are finite-dimensional intermediate fields, then so is their compositum.
  This rephrases a result already in mathlib so that it is compatible with our type classes -/
lemma finite_dimensional_sup {K L: Type*} [field K] [field L] [algebra K L]
  (E1 E2 : intermediate_field K L) (h1 : finite_dimensional K E1)
  (h2 : finite_dimensional K E2) : finite_dimensional K ↥(E1 ⊔ E2) :=
by exactI intermediate_field.finite_dimensional_sup E1 E2

/-- An element of `L ≃ₐ[K] L` is in `Gal(L/E)` if and only if it fixes every element of `E`-/
lemma mem_fixing_subgroup_iff {K L : Type*} [field K] [field L] [algebra K L]
(E : intermediate_field K L) (σ : (L ≃ₐ[K] L)): σ ∈ E.fixing_subgroup ↔
∀ (x : L), x ∈ E → σ x = x :=
⟨λ hσ x hx, hσ ⟨x, hx⟩, λ h ⟨x, hx⟩, h x hx⟩

/-- The map `E ↦ Gal(L/E)` is inclusion-reversing -/
lemma intermediate_field.fixing_subgroup.antimono {K L : Type*} [field K] [field L] [algebra K L]
{E1 E2 : intermediate_field K L} (h12 : E1 ≤ E2) : E2.fixing_subgroup ≤ E1.fixing_subgroup :=
begin
  rintro σ hσ ⟨x, hx⟩,
  exact hσ ⟨x, h12 hx⟩,
end

/-- Given a field extension `L/K`, `gal_basis K L` is the filter basis on `L ≃ₐ[K] L` whose sets are
  `Gal(L/E)` for intermediate fields `E` with `E/K` finite dimensional -/
def gal_basis (K L : Type*) [field K] [field L] [algebra K L] : filter_basis (L ≃ₐ[K] L) :=
{ sets := subgroup.carrier '' (fixed_by_finite K L),
  nonempty := ⟨⊤, ⊤, top_fixed_by_finite, rfl⟩,
  inter_sets :=
  begin
    rintros X Y ⟨H1, ⟨E1, h_E1, rfl⟩, rfl⟩ ⟨H2, ⟨E2, h_E2, rfl⟩, rfl⟩,
    use (intermediate_field.fixing_subgroup (E1 ⊔ E2)).carrier,
    refine ⟨⟨_, ⟨_, finite_dimensional_sup E1 E2 h_E1 h_E2, rfl⟩, rfl⟩, _⟩,
    rw set.subset_inter_iff,
    exact ⟨intermediate_field.fixing_subgroup.antimono le_sup_left,
      intermediate_field.fixing_subgroup.antimono le_sup_right⟩,
  end }

/-- A subset of `L ≃ₐ[K] L` is a member of `gal_basis K L` if and only if it is the underlying set
  of `Gal(L/E)` for some finite subextension `E/K`-/
lemma mem_gal_basis_iff (K L : Type*) [field K] [field L] [algebra K L]
(U : set (L ≃ₐ[K] L)) : U ∈ gal_basis K L ↔ U ∈ subgroup.carrier '' (fixed_by_finite K L) :=
iff.rfl

/-- For a field extension `L/K`, `gal_group_basis K L` is the group filter basis on `L ≃ₐ[K] L` whose
  sets are `Gal(L/E)` for finite subextensions `E/K` -/
def gal_group_basis (K L : Type*) [field K] [field L] [algebra K L] :
group_filter_basis (L ≃ₐ[K] L) :=
{ to_filter_basis := gal_basis K L,
  one' := λ U ⟨H, hH, h2⟩, h2 ▸ H.one_mem,
  mul' := λ U hU, ⟨U, hU, begin
    rcases hU with ⟨H, hH, rfl⟩,
    rintros x ⟨a, b, haH, hbH, rfl⟩,
    exact H.mul_mem haH hbH,
  end⟩,
  inv' := λ U hU, ⟨U, hU, begin
    rcases hU with ⟨H, hH, rfl⟩,
    exact H.inv_mem',
  end⟩,
  conj' :=
  begin
    rintros σ U ⟨H, ⟨E, hE, rfl⟩, rfl⟩,
    let F : intermediate_field K L := E.map (σ.symm.to_alg_hom),
    refine ⟨F.fixing_subgroup.carrier, ⟨⟨F.fixing_subgroup, ⟨F,
      im_finite_dimensional σ.symm hE, rfl⟩, rfl⟩, λ g hg, _⟩⟩,
    change σ * g * σ⁻¹ ∈ E.fixing_subgroup,
    rw mem_fixing_subgroup_iff,
    intros x hx,
    change σ(g(σ⁻¹ x)) = x,
    have h_in_F : σ⁻¹ x ∈ F := ⟨x, hx, by {dsimp, rw ← alg_equiv.inv_fun_eq_symm, refl }⟩,
    have h_g_fix : g (σ⁻¹ x) = (σ⁻¹ x),
    { rw [subgroup.mem_carrier, mem_fixing_subgroup_iff F g] at hg,
      exact hg (σ⁻¹ x) h_in_F },
    rw h_g_fix,
    change σ(σ⁻¹ x) = x,
    exact alg_equiv.apply_symm_apply σ x,
  end }

/-- For a field extension `L/K`, `krull_topology K L` is the topological space structure on
  `L ≃ₐ[K] L` induced by the group filter basis `gal_group_basis K L` -/
@[instance]
def krull_topology (K L : Type*) [field K] [field L] [algebra K L] :
topological_space (L ≃ₐ[K] L) :=
group_filter_basis.topology (gal_group_basis K L)

/-- For a field extension `L/K`, `krull_topological_group K L` is the topological group consisting of
  `L ≃ₐ[K] L`, together with the Krull topology `krull_topology K L` -/
def krull_topological_group (K L : Type*) [field K] [field L] [algebra K L] :
topological_group (L ≃ₐ[K] L) :=
group_filter_basis.is_topological_group (gal_group_basis K L)


/-
Copyright (c) 2022 Anand Rao, Rémi Bottinelli. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Anand Rao, Rémi Bottinelli
-/
import category_theory.cofiltered_system
import combinatorics.simple_graph.connectivity
import data.set_like.basic

/-!
# Ends

This file contains a definition of the ends of a simple graph, as sections of the inverse system
assigning, to each finite set of vertices, the connected components of its complement.
-/

universes u
variables {V : Type u} (G : simple_graph V) (K L L' M : set V)

namespace simple_graph

/-- The components outside a given set of vertices `K` -/
@[reducible] def component_compl := (G.induce Kᶜ).connected_component

variables {G} {K L M}

/-- The connected component of `v` in `G.induce Kᶜ`. -/
@[reducible] def component_compl_mk (G : simple_graph V) {v : V} (vK : v ∉ K) :
  G.component_compl K :=
connected_component_mk (G.induce Kᶜ) ⟨v, vK⟩

/-- The set of vertices of `G` making up the connected component `C` -/
def component_compl.supp (C : G.component_compl K) : set V :=
{v : V | ∃ h : v ∉ K, G.component_compl_mk h = C}

@[ext] lemma component_compl.supp_injective :
  function.injective (component_compl.supp : G.component_compl K → set V) :=
begin
  refine connected_component.ind₂ _,
  rintros ⟨v, hv⟩ ⟨w, hw⟩ h,
  simp only [set.ext_iff, connected_component.eq, set.mem_set_of_eq, component_compl.supp] at h ⊢,
  exact ((h v).mp ⟨hv, reachable.refl _⟩).some_spec,
end

lemma component_compl.supp_inj {C D : G.component_compl K} : C.supp = D.supp ↔ C = D :=
component_compl.supp_injective.eq_iff

instance : set_like (G.component_compl K) V :=
{ coe := component_compl.supp,
  coe_injective' := λ C D, (component_compl.supp_inj).mp, }

@[simp] lemma component_compl.mem_supp_iff {v : V} {C : component_compl G K} :
  v ∈ C ↔ ∃ (vK : v ∉ K), G.component_compl_mk vK = C := iff.rfl

lemma component_compl_mk_mem (G : simple_graph V) {v : V} (vK : v ∉ K) :
  v ∈ G.component_compl_mk vK := ⟨vK, rfl⟩

lemma component_compl_mk_eq_of_adj (G : simple_graph V) {v w : V} (vK : v ∉ K) (wK : w ∉ K)
  (a : G.adj v w) : G.component_compl_mk vK = G.component_compl_mk wK :=
by { rw [connected_component.eq], apply adj.reachable, exact a }

namespace component_compl

/--
A `component_compl` specialization of `quot.lift`, where soundness has to be proved only
for adjacent vertices.
-/
protected def lift {β : Sort*} (f : ∀ ⦃v⦄ (hv : v ∉ K), β)
  (h : ∀ ⦃v w⦄ (hv : v ∉ K) (hw : w ∉ K) (a : G.adj v w), f hv = f hw) : G.component_compl K → β :=
connected_component.lift (λ vv, f vv.prop) $ (λ v w p, by
  { induction p with _ u v w a q ih,
    { rintro _, refl, },
    { rintro h', exact (h u.prop v.prop a).trans (ih h'.of_cons), } })

protected lemma ind {β : G.component_compl K → Prop}
  (f : ∀ ⦃v⦄ (hv : v ∉ K), β (G.component_compl_mk hv)) : ∀ (C : G.component_compl K), β C := by
{ apply connected_component.ind, exact λ ⟨v, vnK⟩, f vnK, }

/-- The induced graph on the vertices `C`. -/
@[reducible]
protected def coe_graph (C : component_compl G K) : simple_graph C := G.induce (C : set V)

lemma coe_inj {C D : G.component_compl K} : (C : set V) = (D : set V) ↔ C = D := set_like.coe_set_eq

@[simp] protected lemma nonempty (C : G.component_compl K) : (C : set V).nonempty :=
C.ind (λ v vnK, ⟨v, vnK, rfl⟩)

protected lemma exists_eq_mk (C : G.component_compl K) :
  ∃ v (h : v ∉ K), G.component_compl_mk h = C :=
C.nonempty

protected lemma disjoint_right (C : G.component_compl K) : disjoint K C :=
begin
  rw set.disjoint_iff,
  exact λ v ⟨vK, vC⟩, vC.some vK,
end

lemma not_mem_of_mem {C : G.component_compl K} {c : V} (cC : c ∈ C) : c ∉ K :=
λ cK, set.disjoint_iff.mp C.disjoint_right ⟨cK, cC⟩

protected lemma pairwise_disjoint :
  pairwise $ λ C D : G.component_compl K, disjoint (C : set V) (D : set V) :=
begin
  rintro C D ne,
  rw set.disjoint_iff,
  exact λ u ⟨uC, uD⟩, ne (uC.some_spec.symm.trans uD.some_spec),
end

/--
Any vertex adjacent to a vertex of `C` and not lying in `K` must lie in `C`.
-/
lemma mem_of_adj : ∀ {C : G.component_compl K} (c d : V), c ∈ C → d ∉ K → G.adj c d → d ∈ C :=
λ C c d ⟨cnK, h⟩ dnK cd,
  ⟨ dnK, by { rw [←h, connected_component.eq], exact adj.reachable cd.symm, } ⟩

/--
Assuming `G` is preconnected and `K` not empty, given any connected component `C` outside of `K`,
there exists a vertex `k ∈ K` adjacent to a vertex `v ∈ C`.
-/
lemma exists_adj_boundary_pair (Gc : G.preconnected) (hK : K.nonempty) :
  ∀ (C : G.component_compl K), ∃ (ck : V × V), ck.1 ∈ C ∧ ck.2 ∈ K ∧ G.adj ck.1 ck.2 :=
begin
  refine component_compl.ind (λ v vnK, _),
  let C : G.component_compl K := G.component_compl_mk vnK,
  let dis := set.disjoint_iff.mp C.disjoint_right,
  by_contra' h,
  suffices : set.univ = (C : set V),
  { exact dis ⟨hK.some_spec, this ▸ (set.mem_univ hK.some)⟩, },
  symmetry,
  rw set.eq_univ_iff_forall,
  rintro u,
  by_contradiction unC,
  obtain ⟨p⟩ := Gc v u,
  obtain ⟨⟨⟨x, y⟩, xy⟩, d, xC, ynC⟩ :=
    p.exists_boundary_dart (C : set V) (G.component_compl_mk_mem vnK) unC,
  exact ynC (mem_of_adj x y xC (λ (yK : y ∈ K), h ⟨x, y⟩ xC yK xy) xy),
end

/--
If `K ⊆ L`, the components outside of `L` are all contained in a single component outside of `K`.
-/
@[reducible] def hom (h : K ⊆ L) (C : G.component_compl L) : G.component_compl K :=
C.map $ induce_hom hom.id $ set.compl_subset_compl.2 h

lemma subset_hom (C : G.component_compl L) (h : K ⊆ L) : (C : set V) ⊆ (C.hom h : set V) := by
{ rintro c ⟨cL, rfl⟩, exact ⟨λ h', cL (h h'), rfl⟩ }

lemma _root_.simple_graph.component_compl_mk_mem_hom (G : simple_graph V) {v : V} (vK : v ∉ K)
  (h : L ⊆ K) : v ∈ (G.component_compl_mk vK).hom h :=
subset_hom (G.component_compl_mk vK) h (G.component_compl_mk_mem vK)

lemma hom_eq_iff_le (C : G.component_compl L) (h : K ⊆ L) (D : G.component_compl K) :
  C.hom h = D ↔ (C : set V) ⊆ (D : set V) :=
⟨ λ h', h' ▸ (C.subset_hom h), C.ind (λ v vnL vD, (vD ⟨vnL, rfl⟩).some_spec) ⟩

lemma hom_eq_iff_not_disjoint (C : G.component_compl L) (h : K ⊆ L) (D : G.component_compl K) :
  C.hom h = D ↔ ¬ disjoint (C : set V) (D : set V) :=
begin
  rw set.not_disjoint_iff,
  split,
  { rintro rfl,
    apply C.ind (λ x xnL, _),
    exact ⟨x, ⟨xnL, rfl⟩, ⟨(λ xK, xnL (h xK)), rfl⟩⟩, },
  { apply C.ind (λ x xnL, _),
    rintro ⟨x, ⟨_, e₁⟩, _, rfl⟩,
    rw ←e₁, refl, },
end

lemma hom_refl (C : G.component_compl L) : C.hom (subset_refl L) = C :=
by { change C.map _ = C, erw [induce_hom_id G Lᶜ, connected_component.map_id], }

lemma hom_trans (C : G.component_compl L) (h : K ⊆ L) (h' : M ⊆ K) :
  C.hom (h'.trans h) = (C.hom h).hom h' :=
by { change C.map _ = (C.map _).map _, erw [connected_component.map_comp, induce_hom_comp], refl, }

lemma hom_mk {v : V} (vnL : v ∉ L) (h : K ⊆ L) :
  (G.component_compl_mk vnL).hom h = (G.component_compl_mk (set.not_mem_subset h vnL)) := rfl

lemma hom_infinite (C : G.component_compl L) (h : K ⊆ L) (Cinf : (C : set V).infinite) :
  (C.hom h : set V).infinite := set.infinite.mono (C.subset_hom h) Cinf

lemma infinite_iff_in_all_ranges {K : finset V} (C : G.component_compl K) :
  C.supp.infinite ↔ ∀ L (h : K ⊆ L), ∃ D : G.component_compl L, D.hom h = C :=
begin
  classical,
  split,
  { rintro Cinf L h,
    obtain ⟨v, ⟨vK, rfl⟩, vL⟩ := set.infinite.nonempty (set.infinite.diff Cinf L.finite_to_set),
    exact ⟨component_compl_mk _ vL, rfl⟩ },
  { rintro h Cfin,
    obtain ⟨D, e⟩ := h (K ∪ Cfin.to_finset) (finset.subset_union_left K Cfin.to_finset),
    obtain ⟨v, vD⟩ := D.nonempty,
    let Ddis := D.disjoint_right,
    simp_rw [finset.coe_union, set.finite.coe_to_finset, set.disjoint_union_left,
             set.disjoint_iff] at Ddis,
    exact Ddis.right ⟨(component_compl.hom_eq_iff_le _ _ _).mp e vD, vD⟩, },
end

end component_compl

section ends

variables (G)

open category_theory

/--
The functor assigning, to a finite set in `V`, the set of connected components in its complement.
-/
@[simps] def component_compl_functor : (finset V)ᵒᵖ ⥤ Type u :=
{ obj := λ K, G.component_compl K.unop,
  map := λ _ _ f, component_compl.hom (le_of_op_hom f),
  map_id' := λ K, funext $ λ C, C.hom_refl,
  map_comp' := λ K L M h h', funext $ λ C, C.hom_trans (le_of_op_hom h) (le_of_op_hom h') }

/-- The end of a graph, defined as the sections of the functor `component_compl_functor` . -/
@[protected]
def «end» := (component_compl_functor G).sections

lemma end_hom_mk_of_mk {s} (sec : s ∈ G.end) {K L : (finset V)ᵒᵖ} (h : L ⟶ K)
  {v : V} (vnL : v ∉ L.unop) (hs : s L = G.component_compl_mk vnL) :
  s K = G.component_compl_mk (set.not_mem_subset (le_of_op_hom h) vnL) :=
begin
  rw [←(sec h), hs],
  apply component_compl.hom_mk,
end

lemma infinite_iff_in_eventual_range {K : (finset V)ᵒᵖ} (C : G.component_compl_functor.obj K) :
  C.supp.infinite ↔ C ∈ G.component_compl_functor.eventual_range K :=
begin
  simp only [C.infinite_iff_in_all_ranges, category_theory.functor.eventual_range,
             set.mem_Inter, set.mem_range, component_compl_functor_map],
  exact ⟨λ h Lop KL, h Lop.unop (le_of_op_hom KL), λ h L KL, h (opposite.op L) (op_hom_of_le KL)⟩,
end

end ends

end simple_graph


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import data.polynomial.derivative
import data.nat.choose.sum
import ring_theory.polynomial.pochhammer
import data.polynomial.algebra_map
import linear_algebra.linear_independent
import data.mv_polynomial.pderiv

/-!
# Bernstein polynomials

The definition of the Bernstein polynomials
```
bernstein_polynomial (R : Type*) [comm_ring R] (n ν : ℕ) : polynomial R :=
(choose n ν) * X^ν * (1 - X)^(n - ν)
```
and the fact that for `ν : fin (n+1)` these are linearly independent over `ℚ`.

We prove the basic identities
* `(finset.range (n + 1)).sum (λ ν, bernstein_polynomial R n ν) = 1`
* `(finset.range (n + 1)).sum (λ ν, ν • bernstein_polynomial R n ν) = n • X`
* `(finset.range (n + 1)).sum (λ ν, (ν * (ν-1)) • bernstein_polynomial R n ν) = (n * (n-1)) • X^2`

## Notes

See also `analysis.special_functions.bernstein`, which defines the Bernstein approximations
of a continuous function `f : C([0,1], ℝ)`, and shows that these converge uniformly to `f`.
-/

noncomputable theory

open nat (choose)
open polynomial (X)
open_locale big_operators

variables (R : Type*) [comm_ring R]

/--
`bernstein_polynomial R n ν` is `(choose n ν) * X^ν * (1 - X)^(n - ν)`.

Although the coefficients are integers, it is convenient to work over an arbitrary commutative ring.
-/
def bernstein_polynomial (n ν : ℕ) : polynomial R := choose n ν * X^ν * (1 - X)^(n - ν)

example : bernstein_polynomial ℤ 3 2 = 3 * X^2 - 3 * X^3 :=
begin
  norm_num [bernstein_polynomial, choose],
  ring,
end

namespace bernstein_polynomial

lemma eq_zero_of_lt {n ν : ℕ} (h : n < ν) : bernstein_polynomial R n ν = 0 :=
by simp [bernstein_polynomial, nat.choose_eq_zero_of_lt h]

section
variables {R} {S : Type*} [comm_ring S]

@[simp] lemma map (f : R →+* S) (n ν : ℕ) :
  (bernstein_polynomial R n ν).map f = bernstein_polynomial S n ν :=
by simp [bernstein_polynomial]

end

lemma flip (n ν : ℕ) (h : ν ≤ n) :
  (bernstein_polynomial R n ν).comp (1-X) = bernstein_polynomial R n (n-ν) :=
begin
  dsimp [bernstein_polynomial],
  simp [h, tsub_tsub_assoc, mul_right_comm],
end

lemma flip' (n ν : ℕ) (h : ν ≤ n) :
  bernstein_polynomial R n ν = (bernstein_polynomial R n (n-ν)).comp (1-X) :=
begin
  rw [←flip _ _ _ h, polynomial.comp_assoc],
  simp,
end

lemma eval_at_0 (n ν : ℕ) : (bernstein_polynomial R n ν).eval 0 = if ν = 0 then 1 else 0 :=
begin
  dsimp [bernstein_polynomial],
  split_ifs,
  { subst h, simp, },
  { simp [zero_pow (nat.pos_of_ne_zero h)], },
end

lemma eval_at_1 (n ν : ℕ) : (bernstein_polynomial R n ν).eval 1 = if ν = n then 1 else 0 :=
begin
  dsimp [bernstein_polynomial],
  split_ifs,
  { subst h, simp, },
  { obtain w | w := (n - ν).eq_zero_or_pos,
    { simp [nat.choose_eq_zero_of_lt ((tsub_eq_zero_iff_le.mp w).lt_of_ne (ne.symm h))] },
    { simp [zero_pow w] } },
end.

lemma derivative_succ_aux (n ν : ℕ) :
  (bernstein_polynomial R (n+1) (ν+1)).derivative =
    (n+1) * (bernstein_polynomial R n ν - bernstein_polynomial R n (ν + 1)) :=
begin
  dsimp [bernstein_polynomial],
  suffices :
    ↑((n + 1).choose (ν + 1)) * ((↑ν + 1) * X ^ ν) * (1 - X) ^ (n - ν)
      -(↑((n + 1).choose (ν + 1)) * X ^ (ν + 1) * (↑(n - ν) * (1 - X) ^ (n - ν - 1))) =
    (↑n + 1) * (↑(n.choose ν) * X ^ ν * (1 - X) ^ (n - ν) -
         ↑(n.choose (ν + 1)) * X ^ (ν + 1) * (1 - X) ^ (n - (ν + 1))),
  { simpa [polynomial.derivative_pow, ←sub_eq_add_neg], },
  conv_rhs { rw mul_sub, },
  -- We'll prove the two terms match up separately.
  refine congr (congr_arg has_sub.sub _) _,
  { simp only [←mul_assoc],
    refine congr (congr_arg (*) (congr (congr_arg (*) _) rfl)) rfl,
    -- Now it's just about binomial coefficients
    exact_mod_cast congr_arg (λ m : ℕ, (m : polynomial R)) (nat.succ_mul_choose_eq n ν).symm, },
  { rw [← tsub_add_eq_tsub_tsub, ← mul_assoc, ← mul_assoc], congr' 1,
    rw mul_comm , rw [←mul_assoc,←mul_assoc],  congr' 1,
    norm_cast,
    congr' 1,
    convert (nat.choose_mul_succ_eq n (ν + 1)).symm using 1,
    { convert mul_comm _ _ using 2,
      simp, },
    { apply mul_comm, }, },
end

lemma derivative_succ (n ν : ℕ) :
  (bernstein_polynomial R n (ν+1)).derivative =
    n * (bernstein_polynomial R (n-1) ν - bernstein_polynomial R (n-1) (ν+1)) :=
begin
  cases n,
  { simp [bernstein_polynomial], },
  { apply derivative_succ_aux, }
end

lemma derivative_zero (n : ℕ) :
  (bernstein_polynomial R n 0).derivative = -n * bernstein_polynomial R (n-1) 0 :=
begin
  dsimp [bernstein_polynomial],
  simp [polynomial.derivative_pow],
end

lemma iterate_derivative_at_0_eq_zero_of_lt (n : ℕ) {ν k : ℕ} :
  k < ν → (polynomial.derivative^[k] (bernstein_polynomial R n ν)).eval 0 = 0 :=
begin
  cases ν,
  { rintro ⟨⟩, },
  { rw nat.lt_succ_iff,
    induction k with k ih generalizing n ν,
    { simp [eval_at_0], },
    { simp only [derivative_succ, int.coe_nat_eq_zero, int.nat_cast_eq_coe_nat, mul_eq_zero,
        function.comp_app, function.iterate_succ,
        polynomial.iterate_derivative_sub, polynomial.iterate_derivative_cast_nat_mul,
        polynomial.eval_mul, polynomial.eval_nat_cast, polynomial.eval_sub],
      intro h,
      apply mul_eq_zero_of_right,
      rw [ih _ _ (nat.le_of_succ_le h), sub_zero],
      convert ih _ _ (nat.pred_le_pred h),
      exact (nat.succ_pred_eq_of_pos (k.succ_pos.trans_le h)).symm } },
end

@[simp]
lemma iterate_derivative_succ_at_0_eq_zero (n ν : ℕ) :
  (polynomial.derivative^[ν] (bernstein_polynomial R n (ν+1))).eval 0 = 0 :=
iterate_derivative_at_0_eq_zero_of_lt R n (lt_add_one ν)

open polynomial

@[simp]

lemma iterate_derivative_at_0_ne_zero [char_zero R] (n ν : ℕ) (h : ν ≤ n) :
  (polynomial.derivative^[ν] (bernstein_polynomial R n ν)).eval 0 ≠ 0 :=
begin
  simp only [int.coe_nat_eq_zero, bernstein_polynomial.iterate_derivative_at_0, ne.def,
    nat.cast_eq_zero],
  simp only [←pochhammer_eval_cast],
  norm_cast,
  apply ne_of_gt,
  obtain rfl|h' := nat.eq_zero_or_pos ν,
  { simp, },
  { rw ← nat.succ_pred_eq_of_pos h' at h,
    exact pochhammer_pos _ _ (tsub_pos_of_lt (nat.lt_of_succ_le h)) }
end

/-!
Rather than redoing the work of evaluating the derivatives at 1,
we use the symmetry of the Bernstein polynomials.
-/
lemma iterate_derivative_at_1_eq_zero_of_lt (n : ℕ) {ν k : ℕ} :
  k < n - ν → (polynomial.derivative^[k] (bernstein_polynomial R n ν)).eval 1 = 0 :=
begin
  intro w,
  rw flip' _ _ _ (tsub_pos_iff_lt.mp (pos_of_gt w)).le,
  simp [polynomial.eval_comp, iterate_derivative_at_0_eq_zero_of_lt R n w],
end

@[simp]
lemma iterate_derivative_at_1 (n ν : ℕ) (h : ν ≤ n) :
  (polynomial.derivative^[n-ν] (bernstein_polynomial R n ν)).eval 1 =
    (-1)^(n-ν) * (pochhammer R (n - ν)).eval (ν + 1) :=
begin
  rw flip' _ _ _ h,
  simp [polynomial.eval_comp, h],
  obtain rfl | h' := h.eq_or_lt,
  { simp, },
  { congr,
    norm_cast,
    rw [← tsub_add_eq_tsub_tsub, tsub_tsub_cancel_of_le (nat.succ_le_iff.mpr h')] },
end

lemma iterate_derivative_at_1_ne_zero [char_zero R] (n ν : ℕ) (h : ν ≤ n) :
  (polynomial.derivative^[n-ν] (bernstein_polynomial R n ν)).eval 1 ≠ 0 :=
begin
  rw [bernstein_polynomial.iterate_derivative_at_1 _ _ _ h, ne.def, neg_one_pow_mul_eq_zero_iff,
    ←nat.cast_succ, ←pochhammer_eval_cast, ←nat.cast_zero, nat.cast_inj],
  exact (pochhammer_pos _ _ (nat.succ_pos ν)).ne',
end

open submodule

lemma linear_independent_aux (n k : ℕ) (h : k ≤ n + 1):
  linear_independent ℚ (λ ν : fin k, bernstein_polynomial ℚ n ν) :=
begin
  induction k with k ih,
  { apply linear_independent_empty_type, },
  { apply linear_independent_fin_succ'.mpr,
    fsplit,
    { exact ih (le_of_lt h), },
    { -- The actual work!
      -- We show that the (n-k)-th derivative at 1 doesn't vanish,
      -- but vanishes for everything in the span.
      clear ih,
      simp only [nat.succ_eq_add_one, add_le_add_iff_right] at h,
      simp only [fin.coe_last, fin.init_def],
      dsimp,
      apply not_mem_span_of_apply_not_mem_span_image ((polynomial.derivative_lhom ℚ)^(n-k)),
      simp only [not_exists, not_and, submodule.mem_map, submodule.span_image],
      intros p m,
      apply_fun (polynomial.eval (1 : ℚ)),
      simp only [polynomial.derivative_lhom_coe, linear_map.pow_apply],
      -- The right hand side is nonzero,
      -- so it will suffice to show the left hand side is always zero.
      suffices : (polynomial.derivative^[n-k] p).eval 1 = 0,
      { rw [this],
        exact (iterate_derivative_at_1_ne_zero ℚ n k h).symm, },
      apply span_induction m,
      { simp,
        rintro ⟨a, w⟩, simp only [fin.coe_mk],
        rw [iterate_derivative_at_1_eq_zero_of_lt ℚ n ((tsub_lt_tsub_iff_left_of_le h).mpr w)] },
      { simp, },
      { intros x y hx hy, simp [hx, hy], },
      { intros a x h, simp [h], }, }, },
end

/--
The Bernstein polynomials are linearly independent.

We prove by induction that the collection of `bernstein_polynomial n ν` for `ν = 0, ..., k`
are linearly independent.
The inductive step relies on the observation that the `(n-k)`-th derivative, evaluated at 1,
annihilates `bernstein_polynomial n ν` for `ν < k`, but has a nonzero value at `ν = k`.
-/

lemma linear_independent (n : ℕ) :
  linear_independent ℚ (λ ν : fin (n+1), bernstein_polynomial ℚ n ν) :=
linear_independent_aux n (n+1) le_rfl

lemma sum (n : ℕ) : ∑ ν in finset.range (n + 1), bernstein_polynomial R n ν = 1 :=
calc ∑ ν in finset.range (n + 1), bernstein_polynomial R n ν = (X + (1 - X)) ^ n :
  by { rw add_pow, simp only [bernstein_polynomial, mul_comm, mul_assoc, mul_left_comm] }
... = 1 : by simp

open polynomial
open mv_polynomial

lemma sum_smul (n : ℕ) :
  ∑ ν in finset.range (n + 1), ν • bernstein_polynomial R n ν = n • X :=
begin
  -- We calculate the `x`-derivative of `(x+y)^n`, evaluated at `y=(1-x)`,
  -- either directly or by using the binomial theorem.

  -- We'll work in `mv_polynomial bool R`.
  let x : mv_polynomial bool R := mv_polynomial.X tt,
  let y : mv_polynomial bool R := mv_polynomial.X ff,

  have pderiv_tt_x : pderiv tt x = 1, { simp [x], },
  have pderiv_tt_y : pderiv tt y = 0, { simp [pderiv_X, y], },

  let e : bool → polynomial R := λ i, cond i X (1-X),

  -- Start with `(x+y)^n = (x+y)^n`,
  -- take the `x`-derivative, evaluate at `x=X, y=1-X`, and multiply by `X`:
  have h : (x+y)^n = (x+y)^n := rfl,
  apply_fun (pderiv tt) at h,
  apply_fun (aeval e) at h,
  apply_fun (λ p, p * X) at h,

  -- On the left hand side we'll use the binomial theorem, then simplify.

  -- We first prepare a tedious rewrite:
  have w : ∀ k : ℕ,
    ↑k * polynomial.X ^ (k - 1) * (1 - polynomial.X) ^ (n - k) * ↑(n.choose k) * polynomial.X =
      k • bernstein_polynomial R n k,
  { rintro (_|k),
    { simp, },
    { dsimp [bernstein_polynomial],
      simp only [←nat_cast_mul, nat.succ_eq_add_one, nat.add_succ_sub_one, add_zero, pow_succ],
      push_cast,
      ring, }, },

  conv at h
  { to_lhs,
    rw [add_pow, (pderiv tt).map_sum, (mv_polynomial.aeval e).map_sum, finset.sum_mul],
    -- Step inside the sum:
    apply_congr, skip,
    simp [pderiv_mul, pderiv_tt_x, pderiv_tt_y, e, w], },
  -- On the right hand side, we'll just simplify.
  conv at h
  { to_rhs,
    rw [(pderiv tt).leibniz_pow, (pderiv tt).map_add, pderiv_tt_x, pderiv_tt_y],
    simp [e] },
  simpa using h,
end

lemma sum_mul_smul (n : ℕ) :
  ∑ ν in finset.range (n + 1), (ν * (ν-1)) • bernstein_polynomial R n ν = (n * (n-1)) • X^2 :=
begin
  -- We calculate the second `x`-derivative of `(x+y)^n`, evaluated at `y=(1-x)`,
  -- either directly or by using the binomial theorem.

  -- We'll work in `mv_polynomial bool R`.
  let x : mv_polynomial bool R := mv_polynomial.X tt,
  let y : mv_polynomial bool R := mv_polynomial.X ff,

  have pderiv_tt_x : pderiv tt x = 1, { simp [x], },
  have pderiv_tt_y : pderiv tt y = 0, { simp [pderiv_X, y], },

  let e : bool → polynomial R := λ i, cond i X (1-X),

  -- Start with `(x+y)^n = (x+y)^n`,
  -- take the second `x`-derivative, evaluate at `x=X, y=1-X`, and multiply by `X`:
  have h : (x+y)^n = (x+y)^n := rfl,
  apply_fun (pderiv tt) at h,
  apply_fun (pderiv tt) at h,
  apply_fun (aeval e) at h,
  apply_fun (λ p, p * X^2) at h,

  -- On the left hand side we'll use the binomial theorem, then simplify.

  -- We first prepare a tedious rewrite:
  have w : ∀ k : ℕ,
    ↑k * (↑(k-1) * polynomial.X ^ (k - 1 - 1)) *
      (1 - polynomial.X) ^ (n - k) * ↑(n.choose k) * polynomial.X^2 =
      (k * (k-1)) • bernstein_polynomial R n k,
  { rintro (_|k),
    { simp, },
    { rcases k with (_|k),
      { simp, },
      { dsimp [bernstein_polynomial],
        simp only [←nat_cast_mul, nat.succ_eq_add_one, nat.add_succ_sub_one, add_zero, pow_succ],
        push_cast,
        ring, }, }, },

  conv at h
  { to_lhs,
    rw [add_pow, (pderiv tt).map_sum, (pderiv tt).map_sum, (mv_polynomial.aeval e).map_sum,
      finset.sum_mul],
    -- Step inside the sum:
    apply_congr, skip,
    simp [pderiv_mul, pderiv_tt_x, pderiv_tt_y, e, w] },
  -- On the right hand side, we'll just simplify.
  conv at h
  { to_rhs,
    simp only [pderiv_one, pderiv_mul, (pderiv _).leibniz_pow, (pderiv _).map_coe_nat,
      (pderiv tt).map_add, pderiv_tt_x, pderiv_tt_y],
    simp [e, smul_smul] },
  simpa using h,
end

/--
A certain linear combination of the previous three identities,
which we'll want later.
-/
lemma variance (n : ℕ) :
  ∑ ν in finset.range (n+1), (n • polynomial.X - ν)^2 * bernstein_polynomial R n ν =
    n • polynomial.X * (1 - polynomial.X) :=
begin
  have p :
    (finset.range (n+1)).sum (λ ν, (ν * (ν-1)) • bernstein_polynomial R n ν) +
    (1 - (2 * n) • polynomial.X) * (finset.range (n+1)).sum (λ ν, ν • bernstein_polynomial R n ν) +
    (n^2 • X^2) * (finset.range (n+1)).sum (λ ν, bernstein_polynomial R n ν) = _ := rfl,
  conv at p { to_lhs,
    rw [finset.mul_sum, finset.mul_sum, ←finset.sum_add_distrib, ←finset.sum_add_distrib],
    simp only [←nat_cast_mul],
    simp only [←mul_assoc],
    simp only [←add_mul], },
  conv at p { to_rhs,
    rw [sum, sum_smul, sum_mul_smul, ←nat_cast_mul], },
  calc _ = _ : finset.sum_congr rfl (λ k m, _)
     ... = _ : p
     ... = _ : _,
  { congr' 1, simp only [←nat_cast_mul] with push_cast,
    cases k; { simp, ring, }, },
  { simp only [←nat_cast_mul] with push_cast,
    cases n,
    { simp, },
    { simp, ring, }, },
end

end bernstein_polynomial


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

import topology.algebra.valuation
import topology.algebra.with_zero_topology
import topology.algebra.uniform_field

/-!
# Valued fields and their completions

In this file we study the topology of a field `K` endowed with a valuation (in our application
to adic spaces, `K` will be the valuation field associated to some valuation on a ring, defined in
valuation.basic).

We already know from valuation.topology that one can build a topology on `K` which
makes it a topological ring.

The first goal is to show `K` is a topological *field*, ie inversion is continuous
at every non-zero element.

The next goal is to prove `K` is a *completable* topological field. This gives us
a completion `hat K` which is a topological field. We also prove that `K` is automatically
separated, so the map from `K` to `hat K` is injective.

Then we extend the valuation given on `K` to a valuation on `hat K`.
-/

open filter set
open_locale topological_space

section division_ring

variables {K : Type*} [division_ring K]

section valuation_topological_division_ring

section inversion_estimate
variables {Γ₀ : Type*} [linear_ordered_comm_group_with_zero Γ₀] (v : valuation K Γ₀)

-- The following is the main technical lemma ensuring that inversion is continuous
-- in the topology induced by a valuation on a division ring (ie the next instance)
-- and the fact that a valued field is completable
-- [BouAC, VI.5.1 Lemme 1]
lemma valuation.inversion_estimate {x y : K} {γ : units Γ₀} (y_ne : y ≠ 0)
  (h : v (x - y) < min (γ * ((v y) * (v y))) (v y)) :
  v (x⁻¹ - y⁻¹) < γ :=
begin
  have hyp1 : v (x - y) < γ * ((v y) * (v y)),
    from lt_of_lt_of_le h (min_le_left _ _),
  have hyp1' : v (x - y) * ((v y) * (v y))⁻¹ < γ,
    from mul_inv_lt_of_lt_mul₀ hyp1,
  have hyp2 : v (x - y) < v y,
    from lt_of_lt_of_le h (min_le_right _ _),
  have key : v x = v y, from valuation.map_eq_of_sub_lt v hyp2,
  have x_ne : x ≠ 0,
  { intro h,
    apply y_ne,
    rw [h, v.map_zero] at key,
    exact v.zero_iff.1 key.symm },
  have decomp : x⁻¹ - y⁻¹ = x⁻¹ * (y - x) * y⁻¹,
  by rw [mul_sub_left_distrib, sub_mul, mul_assoc,
        show y * y⁻¹ = 1, from mul_inv_cancel y_ne,
        show x⁻¹ * x = 1, from inv_mul_cancel x_ne, mul_one, one_mul],
  calc
    v (x⁻¹ - y⁻¹) = v (x⁻¹ * (y - x) * y⁻¹) : by rw decomp
    ... = (v x⁻¹) * (v $ y - x) * (v y⁻¹) : by repeat { rw valuation.map_mul }
    ... = (v x)⁻¹ * (v $ y - x) * (v y)⁻¹ : by rw [v.map_inv, v.map_inv]
    ... = (v $ y - x) * ((v y) * (v y))⁻¹ : by
      { rw [mul_assoc, mul_comm, key, mul_assoc, mul_inv_rev₀] }
    ... = (v $ y - x) * ((v y) * (v y))⁻¹ : rfl
    ... = (v $ x - y) * ((v y) * (v y))⁻¹ : by rw valuation.map_sub_swap
    ... < γ : hyp1',
end
end inversion_estimate

open valued

/-- The topology coming from a valuation on a division ring makes it a topological division ring
    [BouAC, VI.5.1 middle of Proposition 1] -/
@[priority 100]
instance valued.topological_division_ring [valued K] : topological_division_ring K :=
{ continuous_inv :=
    begin
      intros x x_ne s s_in,
      cases valued.mem_nhds.mp s_in with γ hs, clear s_in,
      rw [mem_map, valued.mem_nhds],
      change ∃ (γ : units (valued.Γ₀ K)), {y : K | v (y - x) < γ} ⊆ {x : K | x⁻¹ ∈ s},
      have vx_ne := (valuation.ne_zero_iff $ v).mpr x_ne,
      let γ' := units.mk0 _ vx_ne,
      use min (γ * (γ'*γ')) γ',
      intros y y_in,
      apply hs,
      simp only [mem_set_of_eq] at y_in,
      rw [units.min_coe, units.coe_mul, units.coe_mul] at y_in,
      exact valuation.inversion_estimate _ x_ne y_in
    end,
  ..(by apply_instance : topological_ring K) }

/-- A valued division ring is separated. -/
@[priority 100]
instance valued_ring.separated [valued K] : separated_space K :=
begin
  apply topological_add_group.separated_of_zero_sep,
  intros x x_ne,
  refine ⟨{k | v k < v x}, _, λ h, lt_irrefl _ h⟩,
  rw valued.mem_nhds,
  have vx_ne := (valuation.ne_zero_iff $ v).mpr x_ne,
  let γ' := units.mk0 _ vx_ne,
  exact ⟨γ', λ y hy, by simpa using hy⟩,
end

section
local attribute [instance] linear_ordered_comm_group_with_zero.topological_space

open valued

lemma valued.continuous_valuation [valued K] : continuous (v : K → Γ₀ K) :=
begin
  rw continuous_iff_continuous_at,
  intro x,
  classical,
  by_cases h : x = 0,
  { rw h,
    change tendsto _ _ (𝓝 (v (0 : K))),
    erw valuation.map_zero,
    rw linear_ordered_comm_group_with_zero.tendsto_zero,
    intro γ,
    rw valued.mem_nhds_zero,
    use [γ, set.subset.refl _] },
  { change tendsto _ _ _,
    have v_ne : v x ≠ 0, from (valuation.ne_zero_iff _).mpr h,
    rw linear_ordered_comm_group_with_zero.tendsto_of_ne_zero v_ne,
    apply valued.loc_const v_ne },
end
end

end valuation_topological_division_ring

end division_ring

section valuation_on_valued_field_completion
open uniform_space

variables {K : Type*} [field K] [valued K]

open valued uniform_space

local notation `hat ` := completion

/-- A valued field is completable. -/
@[priority 100]
instance valued.completable : completable_top_field K :=
{ nice := begin
    rintros F hF h0,
    have : ∃ (γ₀ : units (Γ₀ K)) (M ∈ F), ∀ x ∈ M, (γ₀ : Γ₀ K) ≤ v x,
    { rcases filter.inf_eq_bot_iff.mp h0 with ⟨U, U_in, M, M_in, H⟩,
      rcases valued.mem_nhds_zero.mp U_in with ⟨γ₀, hU⟩,
      existsi [γ₀, M, M_in],
      intros x xM,
      apply le_of_not_lt _,
      intro hyp,
      have : x ∈ U ∩ M := ⟨hU hyp, xM⟩,
      rwa H at this },
    rcases this with ⟨γ₀, M₀, M₀_in, H₀⟩,
    rw valued.cauchy_iff at hF ⊢,
    refine ⟨hF.1.map _, _⟩,
    replace hF := hF.2,
    intros γ,
    rcases hF (min (γ * γ₀ * γ₀) γ₀) with ⟨M₁, M₁_in, H₁⟩, clear hF,
    use (λ x : K, x⁻¹) '' (M₀ ∩ M₁),
    split,
    { rw mem_map,
      apply mem_of_superset (filter.inter_mem M₀_in M₁_in),
      exact subset_preimage_image _ _ },
    { rintros _ _ ⟨x, ⟨x_in₀, x_in₁⟩, rfl⟩ ⟨y, ⟨y_in₀, y_in₁⟩, rfl⟩,
      simp only [mem_set_of_eq],
      specialize H₁ x y x_in₁ y_in₁,
      replace x_in₀ := H₀ x x_in₀,
      replace y_in₀ := H₀ y y_in₀, clear H₀,
      apply valuation.inversion_estimate,
      { have : v x ≠ 0,
        { intro h, rw h at x_in₀, simpa using x_in₀, },
        exact (valuation.ne_zero_iff _).mp this },
      { refine lt_of_lt_of_le H₁ _,
        rw units.min_coe,
        apply min_le_min _ x_in₀,
        rw mul_assoc,
        have : ((γ₀ * γ₀ : units (Γ₀ K)) : Γ₀ K) ≤ v x * v x,
          from calc ↑γ₀ * ↑γ₀ ≤ ↑γ₀ * v x : mul_le_mul_left' x_in₀ ↑γ₀
                          ... ≤ _ : mul_le_mul_right' x_in₀ (v x),
        rw units.coe_mul,
        exact mul_le_mul_left' this γ } }
  end,
  ..valued_ring.separated }

local attribute [instance] linear_ordered_comm_group_with_zero.topological_space

/-- The extension of the valuation of a valued field to the completion of the field. -/
noncomputable def valued.extension : hat K → Γ₀ K :=
completion.dense_inducing_coe.extend (v : K → Γ₀ K)

lemma valued.continuous_extension : continuous (valued.extension : hat K → Γ₀ K) :=
 begin
  refine completion.dense_inducing_coe.continuous_extend _,
  intro x₀,
  by_cases h : x₀ = coe 0,
  { refine ⟨0, _⟩,
    erw [h, ← completion.dense_inducing_coe.to_inducing.nhds_eq_comap]; try { apply_instance },
    rw linear_ordered_comm_group_with_zero.tendsto_zero,
    intro γ₀,
    rw valued.mem_nhds,
    exact ⟨γ₀, by simp⟩ },
  { have preimage_one : v ⁻¹' {(1 : Γ₀ K)} ∈ 𝓝 (1 : K),
    { have : v (1 : K) ≠ 0, { rw valuation.map_one, exact zero_ne_one.symm },
      convert valued.loc_const this,
      ext x,
      rw [valuation.map_one, mem_preimage, mem_singleton_iff, mem_set_of_eq] },
    obtain ⟨V, V_in, hV⟩ : ∃ V ∈ 𝓝 (1 : hat K), ∀ x : K, (x : hat K) ∈ V → v x = 1,
    { rwa [completion.dense_inducing_coe.nhds_eq_comap, mem_comap] at preimage_one },

    have : ∃ V' ∈ (𝓝 (1 : hat K)), (0 : hat K) ∉ V' ∧ ∀ x y ∈ V', x*y⁻¹ ∈ V,
    { have : tendsto (λ p : hat K × hat K, p.1*p.2⁻¹) ((𝓝 1).prod (𝓝 1)) (𝓝 1),
      { rw ← nhds_prod_eq,
        conv {congr, skip, skip, rw ← (one_mul (1 : hat K))},
        refine tendsto.mul continuous_fst.continuous_at
                           (tendsto.comp _ continuous_snd.continuous_at),
        convert topological_division_ring.continuous_inv (1 : hat K) zero_ne_one.symm,
        exact inv_one.symm },
      rcases tendsto_prod_self_iff.mp this V V_in with ⟨U, U_in, hU⟩,
      let hatKstar := ({0}ᶜ : set $ hat K),
      have : hatKstar ∈ 𝓝 (1 : hat K),
      from compl_singleton_mem_nhds zero_ne_one.symm,
      use  [U ∩ hatKstar, filter.inter_mem U_in this],
      split,
      { rintro ⟨h, h'⟩,
        rw mem_compl_singleton_iff at h',
        exact h' rfl },
      { rintros x y ⟨hx, _⟩ ⟨hy, _⟩,
        apply hU ; assumption } },
    rcases this with ⟨V', V'_in, zeroV', hV'⟩,
    have nhds_right : (λ x, x*x₀) '' V' ∈ 𝓝 x₀,
    { have l : function.left_inverse (λ x : hat K, x * x₀⁻¹) (λ x : hat K, x * x₀),
      { intro x,
        simp only [mul_assoc, mul_inv_cancel h, mul_one] },
      have r: function.right_inverse (λ x : hat K, x * x₀⁻¹) (λ x : hat K, x * x₀),
      { intro x,
        simp only [mul_assoc, inv_mul_cancel h, mul_one] },
      have c : continuous  (λ x : hat K, x * x₀⁻¹),
        from continuous_id.mul continuous_const,
      rw image_eq_preimage_of_inverse l r,
      rw ← mul_inv_cancel h at V'_in,
      exact c.continuous_at V'_in },
    have : ∃ (z₀ : K) (y₀ ∈ V'), coe z₀ = y₀*x₀ ∧ z₀ ≠ 0,
    { rcases dense_range.mem_nhds completion.dense_range_coe nhds_right with ⟨z₀, y₀, y₀_in, h⟩,
      refine ⟨z₀, y₀, y₀_in, ⟨h.symm, _⟩⟩,
      intro hz,
      rw hz at h,
      cases zero_eq_mul.mp h.symm ; finish },
    rcases this with ⟨z₀, y₀, y₀_in, hz₀, z₀_ne⟩,
    have vz₀_ne: v z₀ ≠ 0 := by rwa valuation.ne_zero_iff,
    refine ⟨v z₀, _⟩,
    rw [linear_ordered_comm_group_with_zero.tendsto_of_ne_zero vz₀_ne, mem_comap],
    use [(λ x, x*x₀) '' V', nhds_right],
    intros x x_in,
    rcases mem_preimage.1 x_in with ⟨y, y_in, hy⟩, clear x_in,
    change y*x₀ = coe x at hy,
    have : v (x*z₀⁻¹) = 1,
    { apply hV,
      have : ((z₀⁻¹ : K) : hat K) = z₀⁻¹,
      from ring_hom.map_inv (completion.coe_ring_hom : K →+* hat K) z₀,
      rw [completion.coe_mul, this, ← hy, hz₀, mul_inv₀, mul_comm y₀⁻¹, ← mul_assoc, mul_assoc y,
          mul_inv_cancel h, mul_one],
      solve_by_elim },
    calc v x = v (x*z₀⁻¹*z₀) : by rw [mul_assoc, inv_mul_cancel z₀_ne, mul_one]
         ... = v (x*z₀⁻¹)*v z₀ : valuation.map_mul _ _ _
         ... = v z₀ : by rw [this, one_mul]  },
end

@[norm_cast]
lemma valued.extension_extends (x : K) : valued.extension (x : hat K) = v x :=
begin
  haveI : t2_space (valued.Γ₀ K) := regular_space.t2_space _,
  refine completion.dense_inducing_coe.extend_eq_of_tendsto _,
  rw ← completion.dense_inducing_coe.nhds_eq_comap,
  exact valued.continuous_valuation.continuous_at,
end

/-- the extension of a valuation on a division ring to its completion. -/
noncomputable def valued.extension_valuation :
  valuation (hat K) (Γ₀ K) :=
{ to_fun := valued.extension,
  map_zero' := by { simpa [← v.map_zero, ← valued.extension_extends (0 : K)] },
  map_one' := by { rw [← completion.coe_one, valued.extension_extends (1 : K)],
                   exact valuation.map_one _ },
  map_mul' := λ x y, begin
    apply completion.induction_on₂ x y,
    { have c1 : continuous (λ (x : hat K × hat K), valued.extension (x.1 * x.2)),
        from valued.continuous_extension.comp (continuous_fst.mul continuous_snd),

      have c2 : continuous (λ (x : hat K × hat K), valued.extension x.1 * valued.extension x.2),
        from (valued.continuous_extension.comp continuous_fst).mul
              (valued.continuous_extension.comp continuous_snd),
      exact is_closed_eq c1 c2 },
    { intros x y,
      norm_cast,
      exact valuation.map_mul _ _ _ },
  end,
  map_add' := λ x y, begin
    rw le_max_iff,
    apply completion.induction_on₂ x y,
    { have cont : continuous (valued.extension : hat K → Γ₀ K) := valued.continuous_extension,
      exact  (is_closed_le (cont.comp continuous_add) $ cont.comp continuous_fst).union
        (is_closed_le (cont.comp continuous_add) $ cont.comp continuous_snd) },
    { intros x y,
      dsimp,
      norm_cast,
      rw ← le_max_iff,
      exact v.map_add x y, },
  end }

end valuation_on_valued_field_completion