/-
Copyright (c) 2018 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Kenny Lau, Johan Commelin, Mario Carneiro, Kevin Buzzard,
Amelia Livingston, Yury Kudryashov
-/
import algebra.hom.group  -- Only needed for notation
import algebra.group.units
import group_theory.subsemigroup.basic

/-!
# Submonoids: definition and `complete_lattice` structure

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

This file defines bundled multiplicative and additive submonoids. We also define
a `complete_lattice` structure on `submonoid`s, define the closure of a set as the minimal submonoid
that includes this set, and prove a few results about extending properties from a dense set (i.e.
a set with `closure s = ⊤`) to the whole monoid, see `submonoid.dense_induction` and
`monoid_hom.of_mclosure_eq_top_left`/`monoid_hom.of_mclosure_eq_top_right`.

## Main definitions

* `submonoid M`: the type of bundled submonoids of a monoid `M`; the underlying set is given in
  the `carrier` field of the structure, and should be accessed through coercion as in `(S : set M)`.
* `add_submonoid M` : the type of bundled submonoids of an additive monoid `M`.

For each of the following definitions in the `submonoid` namespace, there is a corresponding
definition in the `add_submonoid` namespace.

* `submonoid.copy` : copy of a submonoid with `carrier` replaced by a set that is equal but possibly
  not definitionally equal to the carrier of the original `submonoid`.
* `submonoid.closure` :  monoid closure of a set, i.e., the least submonoid that includes the set.
* `submonoid.gi` : `closure : set M → submonoid M` and coercion `coe : submonoid M → set M`
  form a `galois_insertion`;
* `monoid_hom.eq_mlocus`: the submonoid of elements `x : M` such that `f x = g x`;
* `monoid_hom.of_mclosure_eq_top_right`:  if a map `f : M → N` between two monoids satisfies
  `f 1 = 1` and `f (x * y) = f x * f y` for `y` from some dense set `s`, then `f` is a monoid
  homomorphism. E.g., if `f : ℕ → M` satisfies `f 0 = 0` and `f (x + 1) = f x + f 1`, then `f` is
  an additive monoid homomorphism.

## Implementation notes

Submonoid inclusion is denoted `≤` rather than `⊆`, although `∈` is defined as
membership of a submonoid's underlying set.

Note that `submonoid M` does not actually require `monoid M`, instead requiring only the weaker
`mul_one_class M`.

This file is designed to have very few dependencies. In particular, it should not use natural
numbers. `submonoid` is implemented by extending `subsemigroup` requiring `one_mem'`.

## Tags
submonoid, submonoids
-/

variables {M : Type*} {N : Type*}
variables {A : Type*}

section non_assoc
variables [mul_one_class M] {s : set M}
variables [add_zero_class A] {t : set A}

/-- `one_mem_class S M` says `S` is a type of subsets `s ≤ M`, such that `1 ∈ s` for all `s`. -/
class one_mem_class (S M : Type*) [has_one M] [set_like S M] : Prop :=
(one_mem : ∀ (s : S), (1 : M) ∈ s)

export one_mem_class (one_mem)

/-- `zero_mem_class S M` says `S` is a type of subsets `s ≤ M`, such that `0 ∈ s` for all `s`. -/
class zero_mem_class (S M : Type*) [has_zero M] [set_like S M] : Prop :=
(zero_mem : ∀ (s : S), (0 : M) ∈ s)

export zero_mem_class (zero_mem)

attribute [to_additive] one_mem_class

section

set_option old_structure_cmd true

/-- A submonoid of a monoid `M` is a subset containing 1 and closed under multiplication. -/
@[ancestor subsemigroup]
structure submonoid (M : Type*) [mul_one_class M] extends subsemigroup M :=
(one_mem' : (1 : M) ∈ carrier)

end

/-- A submonoid of a monoid `M` can be considered as a subsemigroup of that monoid. -/
add_decl_doc submonoid.to_subsemigroup

/-- `submonoid_class S M` says `S` is a type of subsets `s ≤ M` that contain `1`
and are closed under `(*)` -/
class submonoid_class (S M : Type*) [mul_one_class M] [set_like S M]
  extends mul_mem_class S M, one_mem_class S M : Prop

section

set_option old_structure_cmd true

/-- An additive submonoid of an additive monoid `M` is a subset containing 0 and
  closed under addition. -/
@[ancestor add_subsemigroup]
structure add_submonoid (M : Type*) [add_zero_class M] extends add_subsemigroup M :=
(zero_mem' : (0 : M) ∈ carrier)

end

/-- An additive submonoid of an additive monoid `M` can be considered as an
additive subsemigroup of that additive monoid. -/
add_decl_doc add_submonoid.to_add_subsemigroup

/-- `add_submonoid_class S M` says `S` is a type of subsets `s ≤ M` that contain `0`
and are closed under `(+)` -/
class add_submonoid_class (S M : Type*) [add_zero_class M] [set_like S M]
  extends add_mem_class S M, zero_mem_class S M : Prop

attribute [to_additive] submonoid submonoid_class

@[to_additive]
lemma pow_mem {M} [monoid M] {A : Type*} [set_like A M] [submonoid_class A M] {S : A} {x : M}
  (hx : x ∈ S) : ∀ (n : ℕ), x ^ n ∈ S
| 0 := by { rw pow_zero, exact one_mem_class.one_mem S }
| (n + 1) := by { rw pow_succ, exact mul_mem_class.mul_mem hx (pow_mem n) }

namespace submonoid

@[to_additive]
instance : set_like (submonoid M) M :=
{ coe := submonoid.carrier,
  coe_injective' := λ p q h, by cases p; cases q; congr' }

@[to_additive]
instance : submonoid_class (submonoid M) M :=
{ one_mem := submonoid.one_mem',
  mul_mem := submonoid.mul_mem' }

/-- See Note [custom simps projection] -/
@[to_additive " See Note [custom simps projection]"]
def simps.coe (S : submonoid M) : set M := S

initialize_simps_projections submonoid (carrier → coe)
initialize_simps_projections add_submonoid (carrier → coe)

@[simp, to_additive]
lemma mem_carrier {s : submonoid M} {x : M} : x ∈ s.carrier ↔ x ∈ s := iff.rfl

@[simp, to_additive]
lemma mem_mk {s : set M} {x : M} (h_one) (h_mul) : x ∈ mk s h_one h_mul ↔ x ∈ s := iff.rfl

@[simp, to_additive]
lemma coe_set_mk {s : set M} (h_one) (h_mul) : (mk s h_one h_mul : set M) = s := rfl

@[simp, to_additive]
lemma mk_le_mk {s t : set M} (h_one) (h_mul) (h_one') (h_mul') :
  mk s h_one h_mul ≤ mk t h_one' h_mul' ↔ s ⊆ t := iff.rfl

/-- Two submonoids are equal if they have the same elements. -/
@[ext, to_additive "Two `add_submonoid`s are equal if they have the same elements."]

/-- Copy a submonoid replacing `carrier` with a set that is equal to it. -/
@[to_additive "Copy an additive submonoid replacing `carrier` with a set that is equal to it."]
protected def copy (S : submonoid M) (s : set M) (hs : s = S) : submonoid M :=
{ carrier := s,
  one_mem' := hs.symm ▸ S.one_mem',
  mul_mem' := λ _ _, hs.symm ▸ S.mul_mem' }

variable {S : submonoid M}

@[simp, to_additive] lemma coe_copy {s : set M} (hs : s = S) :
  (S.copy s hs : set M) = s := rfl

@[to_additive] lemma copy_eq {s : set M} (hs : s = S) : S.copy s hs = S :=
set_like.coe_injective hs

variable (S)

/-- A submonoid contains the monoid's 1. -/
@[to_additive "An `add_submonoid` contains the monoid's 0."]
protected theorem one_mem : (1 : M) ∈ S := one_mem S

/-- A submonoid is closed under multiplication. -/
@[to_additive "An `add_submonoid` is closed under addition."]
protected theorem mul_mem {x y : M} : x ∈ S → y ∈ S → x * y ∈ S := mul_mem

/-- The submonoid `M` of the monoid `M`. -/
@[to_additive "The additive submonoid `M` of the `add_monoid M`."]
instance : has_top (submonoid M) :=
⟨{ carrier := set.univ,
   one_mem' := set.mem_univ 1,
   mul_mem' := λ _ _ _ _, set.mem_univ _ }⟩

/-- The trivial submonoid `{1}` of an monoid `M`. -/
@[to_additive "The trivial `add_submonoid` `{0}` of an `add_monoid` `M`."]
instance : has_bot (submonoid M) :=
⟨{ carrier := {1},
   one_mem' := set.mem_singleton 1,
   mul_mem' := λ a b ha hb, by { simp only [set.mem_singleton_iff] at *, rw [ha, hb, mul_one] }}⟩

@[to_additive]
instance : inhabited (submonoid M) := ⟨⊥⟩

@[simp, to_additive] lemma mem_bot {x : M} : x ∈ (⊥ : submonoid M) ↔ x = 1 := set.mem_singleton_iff

@[simp, to_additive] lemma mem_top (x : M) : x ∈ (⊤ : submonoid M) := set.mem_univ x

@[simp, to_additive] lemma coe_top : ((⊤ : submonoid M) : set M) = set.univ := rfl

@[simp, to_additive] lemma coe_bot : ((⊥ : submonoid M) : set M) = {1} := rfl

/-- The inf of two submonoids is their intersection. -/
@[to_additive "The inf of two `add_submonoid`s is their intersection."]
instance : has_inf (submonoid M) :=
⟨λ S₁ S₂,
  { carrier := S₁ ∩ S₂,
    one_mem' := ⟨S₁.one_mem, S₂.one_mem⟩,
    mul_mem' := λ _ _ ⟨hx, hx'⟩ ⟨hy, hy'⟩,
      ⟨S₁.mul_mem hx hy, S₂.mul_mem hx' hy'⟩ }⟩

@[simp, to_additive]
lemma coe_inf (p p' : submonoid M) : ((p ⊓ p' : submonoid M) : set M) = p ∩ p' := rfl

@[simp, to_additive]
lemma mem_inf {p p' : submonoid M} {x : M} : x ∈ p ⊓ p' ↔ x ∈ p ∧ x ∈ p' := iff.rfl

@[to_additive]
instance : has_Inf (submonoid M) :=
⟨λ s,
{ carrier := ⋂ t ∈ s, ↑t,
  one_mem' := set.mem_bInter $ λ i h, i.one_mem,
  mul_mem' := λ x y hx hy, set.mem_bInter $ λ i h,
    i.mul_mem (by apply set.mem_Inter₂.1 hx i h) (by apply set.mem_Inter₂.1 hy i h) }⟩

@[simp, norm_cast, to_additive]
lemma coe_Inf (S : set (submonoid M)) : ((Inf S : submonoid M) : set M) = ⋂ s ∈ S, ↑s := rfl

@[to_additive]
lemma mem_Inf {S : set (submonoid M)} {x : M} : x ∈ Inf S ↔ ∀ p ∈ S, x ∈ p := set.mem_Inter₂

@[to_additive]
lemma mem_infi {ι : Sort*} {S : ι → submonoid M} {x : M} : (x ∈ ⨅ i, S i) ↔ ∀ i, x ∈ S i :=
by simp only [infi, mem_Inf, set.forall_range_iff]

@[simp, norm_cast, to_additive]
lemma coe_infi {ι : Sort*} {S : ι → submonoid M} : (↑(⨅ i, S i) : set M) = ⋂ i, S i :=
by simp only [infi, coe_Inf, set.bInter_range]

/-- Submonoids of a monoid form a complete lattice. -/
@[to_additive "The `add_submonoid`s of an `add_monoid` form a complete lattice."]
instance : complete_lattice (submonoid M) :=
{ le           := (≤),
  lt           := (<),
  bot          := (⊥),
  bot_le       := λ S x hx, (mem_bot.1 hx).symm ▸ S.one_mem,
  top          := (⊤),
  le_top       := λ S x hx, mem_top x,
  inf          := (⊓),
  Inf          := has_Inf.Inf,
  le_inf       := λ a b c ha hb x hx, ⟨ha hx, hb hx⟩,
  inf_le_left  := λ a b x, and.left,
  inf_le_right := λ a b x, and.right,
  .. complete_lattice_of_Inf (submonoid M) $ λ s,
    is_glb.of_image (λ S T,
      show (S : set M) ≤ T ↔ S ≤ T, from set_like.coe_subset_coe) is_glb_binfi }

@[simp, to_additive]
lemma subsingleton_iff : subsingleton (submonoid M) ↔ subsingleton M :=
⟨ λ h, by exactI ⟨λ x y,
    have ∀ i : M, i = 1 := λ i, mem_bot.mp $ subsingleton.elim (⊤ : submonoid M) ⊥ ▸ mem_top i,
    (this x).trans (this y).symm⟩,
  λ h, by exactI ⟨λ x y, submonoid.ext $ λ i, subsingleton.elim 1 i ▸ by simp [submonoid.one_mem]⟩⟩

@[simp, to_additive]
lemma nontrivial_iff : nontrivial (submonoid M) ↔ nontrivial M :=
not_iff_not.mp (
  (not_nontrivial_iff_subsingleton.trans subsingleton_iff).trans
  not_nontrivial_iff_subsingleton.symm)

@[to_additive]
instance [subsingleton M] : unique (submonoid M) :=
⟨⟨⊥⟩, λ a, @subsingleton.elim _ (subsingleton_iff.mpr ‹_›) a _⟩

@[to_additive]
instance [nontrivial M] : nontrivial (submonoid M) := nontrivial_iff.mpr ‹_›

/-- The `submonoid` generated by a set. -/
@[to_additive "The `add_submonoid` generated by a set"]
def closure (s : set M) : submonoid M := Inf {S | s ⊆ S}

@[to_additive]
lemma mem_closure {x : M} : x ∈ closure s ↔ ∀ S : submonoid M, s ⊆ S → x ∈ S :=
mem_Inf

/-- The submonoid generated by a set includes the set. -/
@[simp, to_additive "The `add_submonoid` generated by a set includes the set."]
lemma subset_closure : s ⊆ closure s := λ x hx, mem_closure.2 $ λ S hS, hS hx

@[to_additive]
lemma not_mem_of_not_mem_closure {P : M} (hP : P ∉ closure s) : P ∉ s := λ h, hP (subset_closure h)

variable {S}
open set

/-- A submonoid `S` includes `closure s` if and only if it includes `s`. -/
@[simp, to_additive "An additive submonoid `S` includes `closure s` if and only if it includes `s`"]
lemma closure_le : closure s ≤ S ↔ s ⊆ S :=
⟨subset.trans subset_closure, λ h, Inf_le h⟩

/-- Submonoid closure of a set is monotone in its argument: if `s ⊆ t`,
then `closure s ≤ closure t`. -/
@[to_additive "Additive submonoid closure of a set is monotone in its argument: if `s ⊆ t`,
then `closure s ≤ closure t`"]
lemma closure_mono ⦃s t : set M⦄ (h : s ⊆ t) : closure s ≤ closure t :=
closure_le.2 $ subset.trans h subset_closure

@[to_additive]
lemma closure_eq_of_le (h₁ : s ⊆ S) (h₂ : S ≤ closure s) : closure s = S :=
le_antisymm (closure_le.2 h₁) h₂

variable (S)

/-- An induction principle for closure membership. If `p` holds for `1` and all elements of `s`, and
is preserved under multiplication, then `p` holds for all elements of the closure of `s`. -/
@[elab_as_eliminator, to_additive "An induction principle for additive closure membership. If `p`
holds for `0` and all elements of `s`, and is preserved under addition, then `p` holds for all
elements of the additive closure of `s`."]
lemma closure_induction {p : M → Prop} {x} (h : x ∈ closure s)
  (Hs : ∀ x ∈ s, p x) (H1 : p 1)
  (Hmul : ∀ x y, p x → p y → p (x * y)) : p x :=
(@closure_le _ _ _ ⟨p, Hmul, H1⟩).2 Hs h

/-- A dependent version of `submonoid.closure_induction`.  -/
@[elab_as_eliminator, to_additive "A dependent version of `add_submonoid.closure_induction`. "]
lemma closure_induction' (s : set M) {p : Π x, x ∈ closure s → Prop}
  (Hs : ∀ x (h : x ∈ s), p x (subset_closure h))
  (H1 : p 1 (one_mem _))
  (Hmul : ∀ x hx y hy, p x hx → p y hy → p (x * y) (mul_mem hx hy))
  {x} (hx : x ∈ closure s) :
  p x hx :=
begin
  refine exists.elim _ (λ (hx : x ∈ closure s) (hc : p x hx), hc),
  exact closure_induction hx
    (λ x hx, ⟨_, Hs x hx⟩) ⟨_, H1⟩ (λ x y ⟨hx', hx⟩ ⟨hy', hy⟩, ⟨_, Hmul _ _ _ _ hx hy⟩),
end

/-- An induction principle for closure membership for predicates with two arguments.  -/
@[elab_as_eliminator, to_additive "An induction principle for additive closure membership for
predicates with two arguments."]
lemma closure_induction₂ {p : M → M → Prop} {x} {y : M} (hx : x ∈ closure s) (hy : y ∈ closure s)
  (Hs : ∀ (x ∈ s) (y ∈ s), p x y)
  (H1_left : ∀ x, p 1 x)
  (H1_right : ∀ x, p x 1)
  (Hmul_left : ∀ x y z, p x z → p y z → p (x * y) z)
  (Hmul_right : ∀ x y z, p z x → p z y → p z (x * y)) : p x y :=
closure_induction hx
  (λ x xs, closure_induction hy (Hs x xs) (H1_right x) (λ z y h₁ h₂, Hmul_right z _ _ h₁ h₂))
  (H1_left y) (λ x z h₁ h₂, Hmul_left _ _ _ h₁ h₂)

/-- If `s` is a dense set in a monoid `M`, `submonoid.closure s = ⊤`, then in order to prove that
some predicate `p` holds for all `x : M` it suffices to verify `p x` for `x ∈ s`, verify `p 1`,
and verify that `p x` and `p y` imply `p (x * y)`. -/
@[elab_as_eliminator, to_additive "If `s` is a dense set in an additive monoid `M`,
`add_submonoid.closure s = ⊤`, then in order to prove that some predicate `p` holds for all `x : M`
it suffices to verify `p x` for `x ∈ s`, verify `p 0`, and verify that `p x` and `p y` imply
`p (x + y)`."]
lemma dense_induction {p : M → Prop} (x : M) {s : set M} (hs : closure s = ⊤)
  (Hs : ∀ x ∈ s, p x) (H1 : p 1)
  (Hmul : ∀ x y, p x → p y → p (x * y)) : p x :=
have ∀ x ∈ closure s, p x, from λ x hx, closure_induction hx Hs H1 Hmul,
by simpa [hs] using this x

variable (M)

/-- `closure` forms a Galois insertion with the coercion to set. -/
@[to_additive "`closure` forms a Galois insertion with the coercion to set."]
protected def gi : galois_insertion (@closure M _) coe :=
{ choice := λ s _, closure s,
  gc := λ s t, closure_le,
  le_l_u := λ s, subset_closure,
  choice_eq := λ s h, rfl }

variable {M}

/-- Closure of a submonoid `S` equals `S`. -/
@[simp, to_additive "Additive closure of an additive submonoid `S` equals `S`"]
lemma closure_eq : closure (S : set M) = S := (submonoid.gi M).l_u_eq S

@[simp, to_additive] lemma closure_empty : closure (∅ : set M) = ⊥ :=
(submonoid.gi M).gc.l_bot

@[simp, to_additive] lemma closure_univ : closure (univ : set M) = ⊤ :=
@coe_top M _ ▸ closure_eq ⊤

@[to_additive]
lemma closure_union (s t : set M) : closure (s ∪ t) = closure s ⊔ closure t :=
(submonoid.gi M).gc.l_sup

@[to_additive]
lemma closure_Union {ι} (s : ι → set M) : closure (⋃ i, s i) = ⨆ i, closure (s i) :=
(submonoid.gi M).gc.l_supr

@[simp, to_additive]
lemma closure_singleton_le_iff_mem (m : M) (p : submonoid M) :
  closure {m} ≤ p ↔ m ∈ p :=
by rw [closure_le, singleton_subset_iff, set_like.mem_coe]

@[to_additive]
lemma mem_supr {ι : Sort*} (p : ι → submonoid M) {m : M} :
  (m ∈ ⨆ i, p i) ↔ (∀ N, (∀ i, p i ≤ N) → m ∈ N) :=
begin
  rw [← closure_singleton_le_iff_mem, le_supr_iff],
  simp only [closure_singleton_le_iff_mem],
end

@[to_additive]
lemma supr_eq_closure {ι : Sort*} (p : ι → submonoid M) :
  (⨆ i, p i) = submonoid.closure (⋃ i, (p i : set M)) :=
by simp_rw [submonoid.closure_Union, submonoid.closure_eq]

@[to_additive]
lemma disjoint_def {p₁ p₂ : submonoid M} :
  disjoint p₁ p₂ ↔ ∀ {x : M}, x ∈ p₁ → x ∈ p₂ → x = 1 :=
by simp_rw [disjoint_iff_inf_le, set_like.le_def, mem_inf, and_imp, mem_bot]

@[to_additive]
lemma disjoint_def' {p₁ p₂ : submonoid M} :
  disjoint p₁ p₂ ↔ ∀ {x y : M}, x ∈ p₁ → y ∈ p₂ → x = y → x = 1 :=
disjoint_def.trans ⟨λ h x y hx hy hxy, h hx $ hxy.symm ▸ hy,
  λ h x hx hx', h hx hx' rfl⟩

end submonoid

namespace monoid_hom

variables [mul_one_class N]

open submonoid

/-- The submonoid of elements `x : M` such that `f x = g x` -/
@[to_additive "The additive submonoid of elements `x : M` such that `f x = g x`"]
def eq_mlocus (f g : M →* N) : submonoid M :=
{ carrier := {x | f x = g x},
  one_mem' := by rw [set.mem_set_of_eq, f.map_one, g.map_one],
  mul_mem' := λ x y (hx : _ = _) (hy : _ = _), by simp [*] }

@[simp, to_additive] lemma eq_mlocus_same (f : M →* N) : f.eq_mlocus f = ⊤ :=
set_like.ext $ λ _, eq_self_iff_true _

/-- If two monoid homomorphisms are equal on a set, then they are equal on its submonoid closure. -/
@[to_additive "If two monoid homomorphisms are equal on a set, then they are equal on its submonoid
closure."]
lemma eq_on_mclosure {f g : M →* N} {s : set M} (h : set.eq_on f g s) :
  set.eq_on f g (closure s) :=
show closure s ≤ f.eq_mlocus g, from closure_le.2 h

@[to_additive]
lemma eq_of_eq_on_mtop {f g : M →* N} (h : set.eq_on f g (⊤ : submonoid M)) :
  f = g :=
ext $ λ x, h trivial

@[to_additive]
lemma eq_of_eq_on_mdense {s : set M} (hs : closure s = ⊤) {f g : M →* N} (h : s.eq_on f g) :
  f = g :=
eq_of_eq_on_mtop $ hs ▸ eq_on_mclosure h

end monoid_hom

end non_assoc

section assoc

variables [monoid M] [monoid N] {s : set M}

section is_unit

/-- The submonoid consisting of the units of a monoid -/
@[to_additive "The additive submonoid consisting of the additive units of an additive monoid"]
def is_unit.submonoid (M : Type*) [monoid M] : submonoid M :=
{ carrier := set_of is_unit,
  one_mem' := by simp only [is_unit_one, set.mem_set_of_eq],
  mul_mem' := by { intros a b ha hb, rw set.mem_set_of_eq at *, exact is_unit.mul ha hb } }

@[to_additive]
lemma is_unit.mem_submonoid_iff {M : Type*} [monoid M] (a : M) :
  a ∈ is_unit.submonoid M ↔ is_unit a :=
begin
  change a ∈ set_of is_unit ↔ is_unit a,
  rw set.mem_set_of_eq
end

end is_unit

namespace monoid_hom

open submonoid

/-- Let `s` be a subset of a monoid `M` such that the closure of `s` is the whole monoid.
Then `monoid_hom.of_mclosure_eq_top_left` defines a monoid homomorphism from `M` asking for
a proof of `f (x * y) = f x * f y` only for `x ∈ s`. -/
@[to_additive "/-- Let `s` be a subset of an additive monoid `M` such that the closure of `s` is
the whole monoid. Then `add_monoid_hom.of_mclosure_eq_top_left` defines an additive monoid
homomorphism from `M` asking for a proof of `f (x + y) = f x + f y` only for `x ∈ s`. -/"]
def of_mclosure_eq_top_left {M N} [monoid M] [monoid N] {s : set M} (f : M → N)
  (hs : closure s = ⊤) (h1 : f 1 = 1) (hmul : ∀ (x ∈ s) y, f (x * y) = f x * f y) :
  M →* N :=
{ to_fun := f,
  map_one' := h1,
  map_mul' := λ x, dense_induction x hs hmul (λ y, by rw [one_mul, h1, one_mul]) $ λ a b ha hb y,
    by rw [mul_assoc, ha, ha, hb, mul_assoc] }

@[simp, norm_cast, to_additive] lemma coe_of_mclosure_eq_top_left (f : M → N) (hs : closure s = ⊤)
  (h1 hmul) : ⇑(of_mclosure_eq_top_left f hs h1 hmul) = f :=
rfl

/-- Let `s` be a subset of a monoid `M` such that the closure of `s` is the whole monoid.
Then `monoid_hom.of_mclosure_eq_top_right` defines a monoid homomorphism from `M` asking for
a proof of `f (x * y) = f x * f y` only for `y ∈ s`. -/
@[to_additive "/-- Let `s` be a subset of an additive monoid `M` such that the closure of `s` is
the whole monoid. Then `add_monoid_hom.of_mclosure_eq_top_right` defines an additive monoid
homomorphism from `M` asking for a proof of `f (x + y) = f x + f y` only for `y ∈ s`. -/"]
def of_mclosure_eq_top_right {M N} [monoid M] [monoid N] {s : set M} (f : M → N)
  (hs : closure s = ⊤) (h1 : f 1 = 1) (hmul : ∀ x (y ∈ s), f (x * y) = f x * f y) :
  M →* N :=
{ to_fun := f,
  map_one' := h1,
  map_mul' := λ x y, dense_induction y hs (λ y hy x, hmul x y hy) (by simp [h1])
    (λ y₁ y₂ h₁ h₂ x, by simp only [← mul_assoc, h₁, h₂]) x }

@[simp, norm_cast, to_additive] lemma coe_of_mclosure_eq_top_right (f : M → N) (hs : closure s = ⊤)
  (h1 hmul) : ⇑(of_mclosure_eq_top_right f hs h1 hmul) = f :=
rfl

end monoid_hom

end assoc


import analysis.topology.topological_space
import analysis.topology.continuity
import analysis.topology.topological_structures
import data.set.basic
import analysis.real

open set
open function
open tactic

universes u v

variables {α: Type u} {β : Type v}
variables [topological_space α]
variables [topological_space β]
variables {a : α} {b : β}
variables {s s₁ s₂ : set α} {r r₁ r₂ : set β}
variables {f : α → β}

--- Usefull lemma's about the inclusion map
lemma image_preimage_subtype_val {s : set α} (t : set α) :
  subtype.val '' (@subtype.val α s ⁻¹' t) = s ∩ t :=
begin
  rw [image_preimage_eq_inter_range, inter_comm, subtype_val_range],
  exact set_of_mem,
end

lemma subtype_val_univ_eq (s : set α) : (subtype.val) '' (@univ s) = s :=
calc
  subtype.val '' (@univ s) = range subtype.val : image_univ
                       ... = s                 : subtype_val_range

lemma preimage_subtype_val_eq_univ (s : set α) : @univ s = (@subtype.val _ s) ⁻¹' s :=
let lift := @subtype.val α s in
calc
  @univ s = lift ⁻¹' univ                      : by rw set.preimage_univ
      ... = lift ⁻¹' (lift '' (lift ⁻¹' univ)) : by rw set.preimage_image_preimage
      ... = lift ⁻¹' (s ∩ univ)                : by rw image_preimage_subtype_val
      ... = lift ⁻¹' s                         : by rw inter_univ s

lemma preimage_subtype_val_empty_iff {s : set α} (t : set α) :
  @subtype.val α s ⁻¹' t = ∅ ↔ s ∩ t = ∅ :=
by rw [←image_preimage_subtype_val, image_eq_empty]

lemma preimage_subtype_val_ne_empty_iff {s : set α} (t : set α) :
  @subtype.val α s ⁻¹' t ≠ ∅ ↔ s ∩ t ≠ ∅ :=
not_iff_not_of_iff (preimage_subtype_val_empty_iff t)

lemma mem_image_inter_iff {f : α → β} : (∃ x : α, x ∈ s ∩ (f ⁻¹' r)) ↔ ∃ y : β, y ∈ (f '' s) ∩ r :=
iff.intro
  (assume h : ∃ x, x ∈ s ∩ (f ⁻¹' r),
   let ⟨x, _, _⟩ := h in
   show ∃ y, y ∈ (f '' s) ∩ r, from ⟨f x, ⟨x, ‹x ∈ s›, rfl⟩, ‹x ∈ f ⁻¹' r›⟩)
  (assume h : ∃ y, y ∈ (f '' s) ∩ r,
   let ⟨y, _, _⟩ := h in
   have ∃ x, x ∈ s ∧ f x = y, from ‹y ∈ f '' s›,
   let ⟨x, _, _⟩ := this in
   have x ∈ f ⁻¹' r, by rw [mem_preimage_eq, ‹f x = y›]; assumption,
   show ∃ x, x ∈ s ∩ (f ⁻¹' r), from ⟨x, ‹x ∈ s›, ‹x ∈ f ⁻¹' r›⟩)

lemma image_connected [continuous f] [is_connected s] : is_connected (f '' s) :=
-- We take arbitrary sets U and V of β
assume U : set β,
assume V : set β,
-- Assuming U is open we get that f ⁻¹' U is open
assume _ : is_open U,
have h₁ : is_open (f ⁻¹' U), from ‹continuous f› U ‹is_open U›,
-- Assuming V is open we get that f ⁻¹' V is open
assume _ : is_open V,
have h₂ : is_open (f ⁻¹' V), from ‹continuous f› V ‹is_open V›,
-- Assuming that (f '' s) ⊆ U ∪ V we get that s ⊆ (f ⁻¹' U) ∪ (f ⁻¹' V)
assume _ : f '' s ⊆ U ∪ V,
have h₃ : s ⊆ (f ⁻¹' U) ∪ (f ⁻¹' V),
  by rw [←preimage_union, ←image_subset_iff]; assumption,
-- Assuming (f '' s) ∩ U is non-empty we get that s ∩ (f ⁻¹' U) is non-empty
assume h₄' : ∃ y : β, y ∈ (f '' s) ∩ U,
have h₄ : ∃ x : α, x ∈ s ∩ (f ⁻¹' U), by rw mem_image_inter_iff; assumption,
-- Assuming (f '' s) ∩ V is non-empty we get that s ∩ (f ⁻¹' V) is non-empty
assume _ : ∃ y : β, y ∈ (f '' s) ∩ V,
have h₅ : ∃ x : α, x ∈ s ∩ (f ⁻¹' V), by rw mem_image_inter_iff; assumption,
-- Applying connectedness of s to f ⁻¹' U and f ⁻¹' V with our assumptions
-- tells us that s ∩ (f ⁻¹' U) ∩ (f ⁻¹' V) is non-empty
have ∃ x : α, x ∈ s ∩ ((f ⁻¹' U) ∩ (f ⁻¹' V)),
  from ‹is_connected s› (f ⁻¹' U) (f ⁻¹' V) h₁ h₂ h₃ h₄ h₅,
show ∃ y : β, y ∈ (f '' s) ∩ (U ∩ V),
  begin
    rw ←mem_image_inter_iff,
    fapply exists_imp_exists,
    exact λ x, x ∈ s ∩ ((f ⁻¹' U) ∩ (f ⁻¹' V)),
    intros,
    rw preimage_inter,
    assumption,
    assumption,
  end
-- This proves that f '' s is connected.

set_option eqn_compiler.zeta true

instance connected_subset [is_connected s] : connected_space s :=
⟨let lift := @subtype.val _ s in
 -- Start with arbitrary subsets of s
 assume U : set s,
 assume V : set s,
 -- We have an open set U' containing U if U is open in s
 assume _ : is_open U,
 have ∃ U' : set α, is_open U' ∧ U = lift ⁻¹' U', from ‹is_open U›,
 let ⟨U', h₁, _⟩ := this in
 -- We have an open set V' containing V if V is open in s
 assume _ : is_open V,
 have ∃ V' : set α, is_open V' ∧ V = lift ⁻¹' V', from ‹is_open V›,
 let ⟨V', h₂, _⟩ := this in
 -- Assuming the universe of s is contained in the union of U and V,
 -- s will be contained in the union of U' and V'
 assume _ : univ ⊆ U ∪ V,
 have h₃ : s ⊆ U' ∪ V',
   by rw [←(subtype_val_univ_eq s), image_subset_iff, preimage_union,
          ←‹U = lift ⁻¹' U'›, ←‹V = lift ⁻¹' V'›]; assumption,
 -- Assuming that U is non-empty we get that U' intersected s is non-empty
 assume _ :∃ x, x ∈ univ ∩ U,
 have h₄ : ∃ y, y ∈ s ∩ U',
   by rw [←(subtype_val_univ_eq s), ←mem_image_inter_iff, ←‹U = lift ⁻¹' U'›]; assumption,
 -- Assuming that V is non-empty we get that V' intersected s is non-empty
 assume _ : ∃ x, x ∈ univ ∩ V,
 have h₅ : ∃ y, y ∈ s ∩ V',
   by rw [←(subtype_val_univ_eq s), ←mem_image_inter_iff, ←‹V = lift ⁻¹' V'›]; assumption,
 -- We can now deduce that there is an element in s ∩ (U' ∩ V')
 -- which in turn gives an element of univ ∩ (U ∩ V)
 have ∃ y, y ∈ s ∩ (U' ∩ V'), from ‹is_connected s› U' V' h₁ h₂ h₃ h₄ h₅,
 show ∃ x, x ∈ univ ∩ (U ∩ V),
   by rw [‹U = lift ⁻¹' U'›, ‹V = lift ⁻¹' V'›, ←preimage_inter,
          mem_image_inter_iff, subtype_val_univ_eq]; assumption⟩

lemma connected_subspace_iff : connected_space s ↔ is_connected s :=
let lift := @subtype.val _ s in
iff.intro
  (assume h : connected_space s,
   have is_connected (@univ s), from h.is_connected_univ,
   have is_connected (lift '' univ),
     from @image_connected _ _ _ _ (@univ s) lift continuous_subtype_val ‹is_connected (@univ s)›,
   show is_connected s, by rw ←(subtype_val_univ_eq s); assumption)
  (@connected_subset _ _ s)

section old_connected

lemma preimage_empty_of_empty {f : α → β} {r : set β} (hf : surjective f): f⁻¹' r = ∅ → r = ∅ :=
suffices (∀a, a ∉ f ⁻¹' r) → ∀b, b ∉ r,
  by simpa only [eq_empty_iff_forall_not_mem],
assume h b,
let ⟨a, eq⟩ := hf b in
eq ▸ h a

lemma preimage_ne_empty_of_ne_empty {f : α → β } (_ : surjective f) {s : set β} (_ : s ≠ ∅ ) : f ⁻¹' s ≠ ∅ :=
let ⟨y, _⟩ := exists_mem_of_ne_empty ‹s ≠ ∅›,
    ⟨x, _⟩ := ‹surjective f›  y in
have f x ∈ s, from (eq.symm ‹f x = y›) ▸ ‹y ∈ s›,
show f⁻¹' s ≠ ∅, from ne_empty_of_mem ‹x ∈ f⁻¹' s›

-- Separations of a topological space: write α as the disjoint union of non empty, open subsets
def separation (s₁ s₂ : set α) : Prop :=
is_open s₁ ∧ is_open s₂ ∧ s₁ ≠ ∅ ∧ s₂ ≠ ∅ ∧ s₁ ∩ s₂ = ∅ ∧ s₁ ∪ s₂ = univ

-- Separations are symmetric: if s₁ s₂ is a separation of α, then so is s₂ s₁.
lemma sep_symm  (h : separation s₁ s₂) : separation s₂ s₁ :=
let ⟨ho1, ho2, hne1, hne2, hce, huu⟩ := h in ⟨ho2, ho1, hne2, hne1, (inter_comm s₁ s₂) ▸ hce, (union_comm s₁ s₂) ▸ huu⟩

lemma sep_neg (sep : separation s₁ s₂) : s₁ = -s₂ :=
let ⟨_, _, _, _, _, _⟩ := sep in
have s₁ ⊆ -s₂, by rw [subset_compl_iff_disjoint]; assumption,
have -s₂ ⊆ s₁, by rw [compl_subset_iff_union, union_comm]; assumption,
antisymm ‹s₁ ⊆ -s₂› ‹-s₂ ⊆ s₁›

lemma sep_sets_closed (h : separation s₁ s₂) : is_closed s₁ ∧ is_closed s₂ :=
let ⟨ho1, ho2, _, _, hce, huu⟩ := h in
have he1 : -s₂ = s₁, from eq.symm (sep_neg h),
have he2 : -s₁ = s₂, from eq.symm (sep_neg (sep_symm h)),
⟨he1 ▸ is_closed_compl_iff.mpr ho2, he2 ▸ is_closed_compl_iff.mpr ho1⟩

--Connected topological spaces
--class connected_space (α) [topological_space α] : Prop :=
--(connected : ¬∃ s₁ s₂ : set α, separation s₁ s₂)

theorem is_connected_image {f : α → β} [connected_space α] (_ : continuous f) : is_connected (f '' univ) :=
assume u v hu hv hcsuv ⟨y, hycs, hyu⟩ ⟨z, hzcs, hzv⟩,
sorry

/-- The image of a connected space under a surjective map is connected. -/
/-theorem im_connected {f : α → β} [connected_space α]
  (_ : continuous f) (_ : surjective f) : connected_space β :=
connected_space.mk $
-- a space is connected if there exists no separation, so we assume there is one and derive false
-- we do this by constructing a 'preimage separation'
assume _ : ∃ r₁ r₂ : set β, separation r₁ r₂,
  -- supose we have a separation r₁ ∪ r₂ = β
  let ⟨r₁, r₂, _, _, _, _, _, _⟩ := ‹∃ r₁ r₂ : set β, separation r₁ r₂› in
  -- we claim that then (s₁=f⁻¹r₁) ∪ (s₂=f⁻¹r₂) is a separation of α
  let s₁ := f⁻¹' r₁, s₂ := f⁻¹' r₂ in
  -- we now need to show that s_i are open, disjoint, nonempty, and span α
  have is_open s₁, from ‹continuous f› r₁ ‹is_open r₁›,
  have is_open s₂, from ‹continuous f› r₂ ‹is_open r₂›,
  have s₁ ≠ ∅, from preimage_ne_empty_of_ne_empty ‹surjective f› ‹r₁ ≠ ∅›,
  have s₂ ≠ ∅, from preimage_ne_empty_of_ne_empty ‹surjective f› ‹r₂ ≠ ∅›,
  have s₁ ∩ s₂ = ∅, by rw ←(@preimage_empty α β f); rw ←‹r₁ ∩ r₂ = ∅›; simp,
  have s₁ ∪ s₂ = univ, by rw ←(@preimage_univ α β f); rw ←‹r₁ ∪ r₂ = univ›; simp,
  -- with this preparation at hand, we construct a separation
  have separation s₁ s₂, from ⟨‹is_open s₁›, ‹is_open s₂›, ‹s₁ ≠ ∅›, ‹s₂ ≠ ∅›, ‹s₁ ∩ s₂ = ∅›, ‹s₁ ∪ s₂ = univ›⟩,
  -- which contradicts the fact that α is connected
  show false, from connected_space'.connected α
    ⟨s₁, s₂, ‹separation s₁ s₂›⟩

--Separations of a subset of a topological space
def subset_separation [topological_space α] (s s₁ s₂ : set α) : Prop :=
is_open s₁ ∧ is_open s₂ ∧ s₁ ∩ s ≠ ∅ ∧ s₂ ∩ s ≠ ∅ ∧ s₁ ∩ s₂ ∩ s = ∅ ∧ s ⊆ s₁ ∪ s₂

lemma subset_sep_symm {t : topological_space α} {s s₁ s₂ : set α} (h : subset_separation s s₁ s₂) : subset_separation s s₂ s₁ :=
let ⟨ho1, ho2, hne1, hne2, hce, huu⟩ := h in
⟨ho2, ho1, hne2, hne1, (inter_comm s₁ s₂) ▸ hce, (union_comm s₁ s₂) ▸ huu⟩

lemma sep_of_subset_sep {s s₁ s₂ : set α} :
  subset_separation s s₁ s₂ → @separation s _ (subtype.val⁻¹' s₁) (subtype.val⁻¹' s₂) :=
let lift := @subtype.val _ s in
assume h : subset_separation s s₁ s₂,
let ⟨_, _, _, _, _, _⟩ := h in
let s₁' := lift ⁻¹' s₁ in
let s₂' := lift ⁻¹' s₂ in
have is_open s₁', from ⟨s₁, ‹is_open s₁›, eq.refl s₁'⟩,
have is_open s₂', from ⟨s₂, ‹is_open s₂›, eq.refl s₂'⟩,
have s₁' ≠ ∅, by rw [preimage_subtype_val_ne_empty_iff, inter_comm]; assumption,
have s₂' ≠ ∅, by rw [preimage_subtype_val_ne_empty_iff, inter_comm]; assumption,
have s₁' ∩ s₂' = ∅, by rw [←preimage_inter, preimage_subtype_val_empty_iff, inter_comm]; assumption,
have s₁' ∪ s₂' = univ, from
  (have s₁' ∪ s₂' ⊆ univ, from subset_univ (s₁' ∪ s₂'),
   have univ ⊆ s₁' ∪ s₂', from
     calc
      univ = lift ⁻¹' s : by rw preimage_subtype_val_eq_univ
       ... ⊆ lift ⁻¹' (s₁ ∪ s₂) : preimage_mono ‹s ⊆ s₁ ∪ s₂›
       ... = (lift ⁻¹' s₁) ∪ (lift ⁻¹' s₂) : by rw preimage_union
       ... = s₁' ∪ s₂' : rfl,
   show s₁' ∪ s₂' = univ, from eq_of_subset_of_subset ‹s₁' ∪ s₂' ⊆ univ› ‹univ ⊆ s₁' ∪ s₂'›
  ),
show separation s₁' s₂',
   from ⟨‹is_open s₁'›, ‹is_open s₂'›, ‹s₁' ≠ ∅›, ‹s₂' ≠ ∅›, ‹s₁' ∩ s₂' = ∅›, ‹s₁' ∪ s₂' = univ›⟩

lemma exists_subset_sep_of_sep {s : set α} {s₁ s₂ : set s} :
  separation s₁ s₂ → ∃ s₁' s₂' : set α, subset_separation s s₁' s₂' :=
let lift := @subtype.val _ s in
assume h : separation s₁ s₂,
let ⟨_, _, _, _, _, _⟩ := h in
have ∃ s₁' : set α, is_open s₁' ∧ s₁ = (lift) ⁻¹' s₁', from ‹is_open s₁›,
let ⟨s₁', _, _⟩ := this in
have ∃ s₂' : set α, is_open s₂' ∧ s₂ = (lift) ⁻¹' s₂', from ‹is_open s₂›,
let ⟨s₂', _, _⟩ := this in
have s₁' ∩ s ≠ ∅,
  by rw [←inter_comm, ←preimage_subtype_val_ne_empty_iff, ←‹s₁ = lift ⁻¹' s₁'›]; assumption,
have s₂' ∩ s ≠ ∅,
  by rw [←inter_comm, ←preimage_subtype_val_ne_empty_iff, ←‹s₂ = lift ⁻¹' s₂'›]; assumption,
have s₁' ∩ s₂' ∩ s = ∅,
  by rw [←inter_comm, ←preimage_subtype_val_empty_iff, preimage_inter, ←‹s₁ = lift ⁻¹' s₁'›, ←‹s₂ = lift ⁻¹' s₂'›]; assumption,
have s ⊆ s₁' ∪ s₂', from
  (calc
       s = lift '' (univ) : by rw (subtype_val_univ_eq s)
     ... = lift '' (s₁ ∪ s₂) : by rw ‹s₁ ∪ s₂ = univ›
     ... = lift '' s₁ ∪ lift '' s₂ : by rw image_union
     ... = (lift '' (lift ⁻¹' s₁')) ∪ (lift '' (lift ⁻¹' s₂')) : by rw [‹s₁ = lift ⁻¹' s₁'›, ‹s₂ = lift ⁻¹' s₂'›]
     ... ⊆ s₁' ∪ s₂' : union_subset_union (image_preimage_subset lift s₁') (image_preimage_subset lift s₂')
  ),
show ∃s₁' s₂' : set α, subset_separation s s₁' s₂',
  from ⟨s₁', s₂', ‹is_open s₁'›, ‹is_open s₂'›, ‹s₁' ∩ s ≠ ∅›, ‹s₂' ∩ s ≠ ∅›, ‹s₁' ∩ s₂' ∩ s = ∅›, ‹s ⊆ s₁' ∪ s₂'›⟩

--Connected subsets of a topological space
def disconnected_subset (s : set α) : Prop :=
∃s₁ s₂ : set α, subset_separation s s₁ s₂

def connected_subset' (s : set α) : Prop :=
¬(disconnected_subset s)

lemma connected_space_iff : connected_space' α ↔ ¬∃ s₁ s₂ : set α, separation s₁ s₂ :=
begin
  constructor,
  apply connected_space'.connected,
  apply connected_space'.mk
end

theorem subtype_connected_iff_subset_connected {s : set α} : connected_space' s ↔ connected_subset' s :=
suffices h₀ : (∃ s₁ s₂ : set s, separation s₁ s₂) ↔ disconnected_subset s,
  by rw connected_space_iff; apply not_iff_not_of_iff; assumption,
let lift := @subtype.val α s in
iff.intro
  (assume h : ∃ s₁ s₂ : set s, separation s₁ s₂,
   let ⟨s₁, s₂, h₁⟩ := h in
   show ∃ s₁' s₂' : set α, subset_separation s s₁' s₂', from exists_subset_sep_of_sep h₁
  )
  (assume h : disconnected_subset s,
   let ⟨s₁, s₂, h₁⟩ := h in
   show ∃ s₁ s₂ : set s, separation s₁ s₂,
     from ⟨lift ⁻¹' s₁, lift ⁻¹' s₂, sep_of_subset_sep h₁⟩
  )-/

end old_connected


/-
Copyright (c) 2022 Anatole Dedecker. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Moritz Doll

! This file was ported from Lean 3 source module analysis.locally_convex.continuous_of_bounded
! leanprover-community/mathlib commit f2ce6086713c78a7f880485f7917ea547a215982
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Analysis.LocallyConvex.Bounded
import Mathbin.Data.IsROrC.Basic

/-!
# Continuity and Von Neumann boundedness

This files proves that for `E` and `F` two topological vector spaces over `ℝ` or `ℂ`,
if `E` is first countable, then every locally bounded linear map `E →ₛₗ[σ] F` is continuous
(this is `linear_map.continuous_of_locally_bounded`).

We keep this file separate from `analysis/locally_convex/bounded` in order not to import
`analysis/normed_space/is_R_or_C` there, because defining the strong topology on the space of
continuous linear maps will require importing `analysis/locally_convex/bounded` in
`analysis/normed_space/operator_norm`.

## References

* [Bourbaki, *Topological Vector Spaces*][bourbaki1987]

-/

open TopologicalSpace Bornology Filter

open Topology Pointwise

variable {𝕜 𝕜' E F : Type _}

variable [AddCommGroup E] [UniformSpace E] [UniformAddGroup E]

variable [AddCommGroup F] [UniformSpace F]

section NontriviallyNormedField

variable [UniformAddGroup F]

variable [NontriviallyNormedField 𝕜] [Module 𝕜 E] [Module 𝕜 F] [ContinuousSMul 𝕜 E]

/-- Construct a continuous linear map from a linear map `f : E →ₗ[𝕜] F` and the existence of a
neighborhood of zero that gets mapped into a bounded set in `F`. -/
def LinearMap.clmOfExistsBoundedImage (f : E →ₗ[𝕜] F)
    (h : ∃ (V : Set E)(hV : V ∈ 𝓝 (0 : E)), Bornology.IsVonNBounded 𝕜 (f '' V)) : E →L[𝕜] F :=
  ⟨f,
    by
    -- It suffices to show that `f` is continuous at `0`.
    refine' continuous_of_continuousAt_zero f _
    rw [continuousAt_def, f.map_zero]
    intro U hU
    -- Continuity means that `U ∈ 𝓝 0` implies that `f ⁻¹' U ∈ 𝓝 0`.
    rcases h with ⟨V, hV, h⟩
    rcases h hU with ⟨r, hr, h⟩
    rcases NormedField.exists_lt_norm 𝕜 r with ⟨x, hx⟩
    specialize h x hx.le
    -- After unfolding all the definitions, we know that `f '' V ⊆ x • U`. We use this to show the
    -- inclusion `x⁻¹ • V ⊆ f⁻¹' U`.
    have x_ne := norm_pos_iff.mp (hr.trans hx)
    have : x⁻¹ • V ⊆ f ⁻¹' U :=
      calc
        x⁻¹ • V ⊆ x⁻¹ • f ⁻¹' (f '' V) := Set.smul_set_mono (Set.subset_preimage_image (⇑f) V)
        _ ⊆ x⁻¹ • f ⁻¹' (x • U) := (Set.smul_set_mono (Set.preimage_mono h))
        _ = f ⁻¹' (x⁻¹ • x • U) := by
          ext <;> simp only [Set.mem_inv_smul_set_iff₀ x_ne, Set.mem_preimage, LinearMap.map_smul]
        _ ⊆ f ⁻¹' U := by rw [inv_smul_smul₀ x_ne _]

    -- Using this inclusion, it suffices to show that `x⁻¹ • V` is in `𝓝 0`, which is trivial.
    refine' mem_of_superset _ this
    convert set_smul_mem_nhds_smul hV (inv_ne_zero x_ne)
    exact (smul_zero _).symm⟩
#align linear_map.clm_of_exists_bounded_image LinearMap.clmOfExistsBoundedImage

theorem LinearMap.clmOfExistsBoundedImage_coe {f : E →ₗ[𝕜] F}
    {h : ∃ (V : Set E)(hV : V ∈ 𝓝 (0 : E)), Bornology.IsVonNBounded 𝕜 (f '' V)} :
    (f.clmOfExistsBoundedImage h : E →ₗ[𝕜] F) = f :=
  rfl
#align linear_map.clm_of_exists_bounded_image_coe LinearMap.clmOfExistsBoundedImage_coe

@[simp]
theorem LinearMap.clmOfExistsBoundedImage_apply {f : E →ₗ[𝕜] F}
    {h : ∃ (V : Set E)(hV : V ∈ 𝓝 (0 : E)), Bornology.IsVonNBounded 𝕜 (f '' V)} {x : E} :
    f.clmOfExistsBoundedImage h x = f x :=
  rfl
#align linear_map.clm_of_exists_bounded_image_apply LinearMap.clmOfExistsBoundedImage_apply

end NontriviallyNormedField

section IsROrC

open TopologicalSpace Bornology

variable [FirstCountableTopology E]

variable [IsROrC 𝕜] [Module 𝕜 E] [ContinuousSMul 𝕜 E]

variable [IsROrC 𝕜'] [Module 𝕜' F] [ContinuousSMul 𝕜' F]

variable {σ : 𝕜 →+* 𝕜'}

theorem LinearMap.continuousAt_zero_of_locally_bounded (f : E →ₛₗ[σ] F)
    (hf : ∀ (s : Set E) (hs : IsVonNBounded 𝕜 s), IsVonNBounded 𝕜' (f '' s)) : ContinuousAt f 0 :=
  by
  -- Assume that f is not continuous at 0
  by_contra
  -- We use a decreasing balanced basis for 0 : E and a balanced basis for 0 : F
  -- and reformulate non-continuity in terms of these bases
  rcases(nhds_basis_balanced 𝕜 E).exists_antitone_subbasis with ⟨b, bE1, bE⟩
  simp only [id.def] at bE
  have bE' : (𝓝 (0 : E)).HasBasis (fun x : ℕ => x ≠ 0) fun n : ℕ => (n : 𝕜)⁻¹ • b n :=
    by
    refine' bE.1.to_hasBasis _ _
    · intro n _
      use n + 1
      simp only [Ne.def, Nat.succ_ne_zero, not_false_iff, Nat.cast_add, Nat.cast_one, true_and_iff]
      -- `b (n + 1) ⊆ b n` follows from `antitone`.
      have h : b (n + 1) ⊆ b n := bE.2 (by simp)
      refine' subset_trans _ h
      rintro y ⟨x, hx, hy⟩
      -- Since `b (n + 1)` is balanced `(n+1)⁻¹ b (n + 1) ⊆ b (n + 1)`
      rw [← hy]
      refine' (bE1 (n + 1)).2.smul_mem _ hx
      have h' : 0 < (n : ℝ) + 1 := n.cast_add_one_pos
      rw [norm_inv, ← Nat.cast_one, ← Nat.cast_add, IsROrC.norm_eq_abs, IsROrC.abs_cast_nat,
        Nat.cast_add, Nat.cast_one, inv_le h' zero_lt_one]
      norm_cast
      simp
    intro n hn
    -- The converse direction follows from continuity of the scalar multiplication
    have hcont : ContinuousAt (fun x : E => (n : 𝕜) • x) 0 :=
      (continuous_const_smul (n : 𝕜)).ContinuousAt
    simp only [ContinuousAt, map_zero, smul_zero] at hcont
    rw [bE.1.tendsto_left_iffₓ] at hcont
    rcases hcont (b n) (bE1 n).1 with ⟨i, _, hi⟩
    refine' ⟨i, trivial, fun x hx => ⟨(n : 𝕜) • x, hi hx, _⟩⟩
    simp [← mul_smul, hn]
  rw [ContinuousAt, map_zero, bE'.tendsto_iff (nhds_basis_balanced 𝕜' F)] at h
  push_neg  at h
  rcases h with ⟨V, ⟨hV, hV'⟩, h⟩
  simp only [id.def, forall_true_left] at h
  -- There exists `u : ℕ → E` such that for all `n : ℕ` we have `u n ∈ n⁻¹ • b n` and `f (u n) ∉ V`
  choose! u hu hu' using h
  -- The sequence `(λ n, n • u n)` converges to `0`
  have h_tendsto : tendsto (fun n : ℕ => (n : 𝕜) • u n) at_top (𝓝 (0 : E)) :=
    by
    apply bE.tendsto
    intro n
    by_cases h : n = 0
    · rw [h, Nat.cast_zero, zero_smul]
      refine' mem_of_mem_nhds (bE.1.mem_of_mem <| by triv)
    rcases hu n h with ⟨y, hy, hu1⟩
    convert hy
    rw [← hu1, ← mul_smul]
    simp only [h, mul_inv_cancel, Ne.def, Nat.cast_eq_zero, not_false_iff, one_smul]
  -- The image `(λ n, n • u n)` is von Neumann bounded:
  have h_bounded : is_vonN_bounded 𝕜 (Set.range fun n : ℕ => (n : 𝕜) • u n) :=
    h_tendsto.cauchy_seq.totally_bounded_range.is_vonN_bounded 𝕜
  -- Since `range u` is bounded it absorbs `V`
  rcases hf _ h_bounded hV with ⟨r, hr, h'⟩
  cases' exists_nat_gt r with n hn
  -- We now find a contradiction between `f (u n) ∉ V` and the absorbing property
  have h1 : r ≤ ‖(n : 𝕜')‖ :=
    by
    rw [IsROrC.norm_eq_abs, IsROrC.abs_cast_nat]
    exact hn.le
  have hn' : 0 < ‖(n : 𝕜')‖ := lt_of_lt_of_le hr h1
  rw [norm_pos_iff, Ne.def, Nat.cast_eq_zero] at hn'
  have h'' : f (u n) ∈ V := by
    simp only [Set.image_subset_iff] at h'
    specialize h' (n : 𝕜') h1 (Set.mem_range_self n)
    simp only [Set.mem_preimage, LinearMap.map_smulₛₗ, map_natCast] at h'
    rcases h' with ⟨y, hy, h'⟩
    apply_fun fun y : F => (n : 𝕜')⁻¹ • y  at h'
    simp only [hn', inv_smul_smul₀, Ne.def, Nat.cast_eq_zero, not_false_iff] at h'
    rwa [← h']
  exact hu' n hn' h''
#align linear_map.continuous_at_zero_of_locally_bounded LinearMap.continuousAt_zero_of_locally_bounded

/-- If `E` is first countable, then every locally bounded linear map `E →ₛₗ[σ] F` is continuous. -/
theorem LinearMap.continuous_of_locally_bounded [UniformAddGroup F] (f : E →ₛₗ[σ] F)
    (hf : ∀ (s : Set E) (hs : IsVonNBounded 𝕜 s), IsVonNBounded 𝕜' (f '' s)) : Continuous f :=
  (uniformContinuous_of_continuousAt_zero f <| f.continuousAt_zero_of_locally_bounded hf).Continuous
#align linear_map.continuous_of_locally_bounded LinearMap.continuous_of_locally_bounded

end IsROrC


/-
Copyright (c) 2021 Ivan Sadofschi Costa. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Ivan Sadofschi Costa.
-/
import data.mv_polynomial.basic
import data.mv_polynomial.variables
import data.mv_polynomial.supported
import algebra.algebra.basic
import data.mv_polynomial.comm_ring
import data.nat.basic

import degree
import degree_new

universes u

open set function finsupp add_monoid_algebra

open_locale big_operators

namespace mv_polynomial

lemma C_mem_supported {R σ : Type*} [comm_semiring R] (s : set σ) (a : R) : C a ∈ supported R s :=
mem_supported.2 (by simp)

lemma support_monomial_of_mem_support_of_supported  {R σ : Type*} [comm_semiring R]
  {p : mv_polynomial σ R} {i : σ} { s : set σ} {m : σ →₀ ℕ} (hm : m ∈ p.support)
  (hp : p ∈ supported R s) : ∀ i ∈ m.support, i ∈ s :=
begin
  intros i h,
  simp only [finsupp.mem_support_iff, ne.def] at h,
  by_contradiction c,
  exact c (mem_of_mem_of_subset (by simpa using (mem_vars i).2
    ⟨m, ⟨hm, by simp [h]⟩⟩) (mem_supported.1 hp)),
end

lemma support_monomial_of_mem_support_of_supported'  {R σ : Type*} [comm_semiring R]
  {p : mv_polynomial σ R} {i : σ} { s : set σ} {m : σ →₀ ℕ}
  (hm : m ∈ p.support) (hp : p ∈ supported R s) (hi : i ∉ s) : m i = 0 :=
begin
  by_contradiction c,
  exact hi (mem_of_mem_of_subset (by simpa using (mem_vars i).2
    ⟨m, ⟨hm, by simp [c]⟩⟩) (mem_supported.1 hp)),
end

lemma eq_single_of_mem_support_of_supported_singleton  {R σ : Type*} [comm_semiring R]
  {p : mv_polynomial σ R} {i : σ} {m : σ →₀ ℕ} (hm : m ∈ p.support)
  (hp : p ∈ supported R ({i} : set σ)) : m = single i (m i) :=
begin
  ext j,
  by_cases c : i = j,
  { simp [c] },
  { simp only [c, single_eq_of_ne, ne.def, not_false_iff],
    apply support_monomial_of_mem_support_of_supported' hm hp,
    simp only [mem_singleton_iff],
    by_contradiction c',
    exact c c'.symm },
end

lemma single_total_degree_mem_support_of_supported_singleton {R σ : Type*} [comm_semiring R]
  {p : mv_polynomial σ R} {i : σ} (h : p ≠ 0) (hp : p ∈ supported R ({i} : set σ)) :
  finsupp.single i p.total_degree ∈ p.support :=
begin
  rcases exists_max_degree_monomial h with ⟨m, ⟨h, h'⟩⟩,
  convert h,
  rw eq_single_of_mem_support_of_supported_singleton h hp,
  congr,
  rw [← h', eq_single_of_mem_support_of_supported_singleton h hp, monomial_degree_single],
  simp,
end

lemma dominant_monomial_single_of_supported_singleton {R σ : Type*} [comm_semiring R]
  {p : mv_polynomial σ R} {i : σ} (h : p ≠ 0) (hp : p ∈ supported R ({i} : set σ)) :
  dominant_monomial (finsupp.single i p.total_degree) p :=
begin
  rw dominant_monomial,
  split,
  { rw max_degree_monomial,
    split,
    { exact single_total_degree_mem_support_of_supported_singleton h hp },
    {rw monomial_degree_single} },
  { intros t' ht',
    rw max_degree_monomial at ht',
    have x := eq_single_of_mem_support_of_supported_singleton ht'.1 hp,
    rw x,
    congr,
    rw [x, monomial_degree_single] at ht',
    exact ht'.2 },
end

lemma X_sub_C_ne_0 {R σ : Type*} [comm_ring R] [decidable_eq σ] [nontrivial R]
  (i : σ) (a : R) : X i - C a ≠ 0 :=
begin
  rw nonzero_iff_exists,
  use single i 1,
  have h' : ¬ 0 = single i 1, -- is this on mathlib?
  { suffices t : single i 1 i = 1,
    { by_contra h,
      simpa [←h] using t },
    simp },
  have c : coeff (single i 1) (X i - C a)  =  1 := by simp [h'],
  rw coeff at c,
  simp [c],
end

lemma total_degree_X_sub_C {R σ : Type*}[comm_ring R] [decidable_eq σ] [nontrivial R]
 (i : σ) (a : R) : total_degree (X i - C a) = 1 :=
begin
  -- this could be a separate lemma called `total_degree_sub_eq_left_of_total_degree_lt`
  rw [sub_eq_add_neg, total_degree_add_eq_left_of_total_degree_lt],
  { simp },
  { simp },
end

-- lemmas for g_S

lemma g_S_mem_supported {R σ : Type*} [comm_ring R] [nontrivial R]
  (S : finset R) (i : σ) : ∏ s in S, (X i - C s) ∈ supported R ({i}: set σ) :=
begin
  apply (supported R {i}).prod_mem,
  intros s hs,
  apply (supported R ({i}: set σ)).sub_mem,
  { apply X_mem_supported.2,
    { simp },
    { exact _inst_2 } },
  { apply C_mem_supported },
end

lemma eval_g_S_eq_zero {R σ : Type*} [comm_ring R] [is_domain R] (S : finset R) (hS : 0 < S.card)
  (s : σ → R) (i : σ) (h_s : s i ∈ S) : eval s (∏ s in S, (X i - C s)) = 0 :=
by simp  [eval_prod, finset.prod_eq_zero h_s]

lemma g_S_ne_0 {R σ : Type*} [comm_ring R] [is_domain R] [decidable_eq σ] (S : finset R)
 (i : σ) : ∏ s in S, (X i - C s) ≠ 0 :=
begin
  rw finset.prod_ne_zero_iff,
  intros a ha,
  apply X_sub_C_ne_0,
end

lemma total_degree_g_S {R σ : Type*} [comm_ring R] [is_domain R] [decidable_eq σ] (S : finset R) (i : σ) :
  total_degree (∏ s in S, (X i - C s)) = S.card :=
begin
  apply finset.cons_induction_on S,
  { simp },
  { clear S,
    intros a S haS hind,
    rw [finset.prod_cons, finset.card_cons, total_degree_mul', hind, add_comm],
    congr,
    rw total_degree_X_sub_C,
    { apply X_sub_C_ne_0 },
    { apply g_S_ne_0 } },
end

lemma g_S_monic {R σ : Type*} [comm_ring R] [is_domain R] [decidable_eq σ] (S : finset R) (i : σ) :
  coeff (single i S.card) ∏ s in S, (X i - C s) = 1 :=
begin
  apply finset.cons_induction_on S,
  { simp },
  { clear S,
    intros a S haS hind,
    simp only [finset.prod_cons, sub_mul, coeff_sub, finset.card_cons, coeff_X_mul', if_true,
              coeff_C_mul, single_eq_same, pi.add_apply, nat.succ_ne_zero, finsupp.mem_support_iff,
              ne.def, not_false_iff, add_tsub_cancel_right, coe_add, single_add, hind, sub_eq_self,
              mul_eq_zero],
    right,
    rw ← single_add,
    apply coeff_zero_of_degree_greater_than_total_degree,
    rw [total_degree_g_S, monomial_degree_single],
    simp },
end

lemma dominant_monomial_g_S {R σ : Type*} [comm_ring R] [is_domain R] [decidable_eq σ] (S : finset R)
  (i : σ) :  dominant_monomial (finsupp.single i (S.card)) (∏ s in S, (X i - C s)) :=
begin
  rw ← total_degree_g_S S i,
  apply dominant_monomial_single_of_supported_singleton,
  { apply g_S_ne_0 },
  { apply g_S_mem_supported },
end

end mv_polynomial


/-
Copyright (c) 2021 Justus Springer. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Justus Springer
-/
import topology.sheaves.forget
import category_theory.limits.shapes.types
import topology.sheaves.sheaf
import category_theory.types

/-!
# The sheaf condition in terms of unique gluings

We provide an alternative formulation of the sheaf condition in terms of unique gluings.

We work with sheaves valued in a concrete category `C` admitting all limits, whose forgetful
functor `C ⥤ Type` preserves limits and reflects isomorphisms. The usual categories of algebraic
structures, such as `Mon`, `AddCommGroup`, `Ring`, `CommRing` etc. are all examples of this kind of
category.

A presheaf `F : presheaf C X` satisfies the sheaf condition if and only if, for every
compatible family of sections `sf : Π i : ι, F.obj (op (U i))`, there exists a unique gluing
`s : F.obj (op (supr U))`.

Here, the family `sf` is called compatible, if for all `i j : ι`, the restrictions of `sf i`
and `sf j` to `U i ⊓ U j` agree. A section `s : F.obj (op (supr U))` is a gluing for the
family `sf`, if `s` restricts to `sf i` on `U i` for all `i : ι`

We show that the sheaf condition in terms of unique gluings is equivalent to the definition
in terms of equalizers. Our approach is as follows: First, we show them to be equivalent for
`Type`-valued presheaves. Then we use that composing a presheaf with a limit-preserving and
isomorphism-reflecting functor leaves the sheaf condition invariant, as shown in
`topology/sheaves/forget.lean`.

-/

noncomputable theory

open Top
open Top.presheaf
open Top.presheaf.sheaf_condition_equalizer_products
open category_theory
open category_theory.limits
open topological_space
open topological_space.opens
open opposite

universes u v

variables {C : Type u} [category.{v} C] [concrete_category.{v} C]

namespace Top

namespace presheaf

section

local attribute [instance] concrete_category.has_coe_to_sort concrete_category.has_coe_to_fun

variables {X : Top.{v}} (F : presheaf C X) {ι : Type v} (U : ι → opens X)

/--
A family of sections `sf` is compatible, if the restrictions of `sf i` and `sf j` to `U i ⊓ U j`
agree, for all `i` and `j`
-/
def is_compatible (sf : Π i : ι, F.obj (op (U i))) : Prop :=
  ∀ i j : ι, F.map (inf_le_left (U i) (U j)).op (sf i) = F.map (inf_le_right (U i) (U j)).op (sf j)

/--
A section `s` is a gluing for a family of sections `sf` if it restricts to `sf i` on `U i`,
for all `i`
-/
def is_gluing (sf : Π i : ι, F.obj (op (U i))) (s : F.obj (op (supr U))) : Prop :=
∀ i : ι, F.map (opens.le_supr U i).op s = sf i

/--
The sheaf condition in terms of unique gluings. A presheaf `F : presheaf C X` satisfies this sheaf
condition if and only if, for every compatible family of sections `sf : Π i : ι, F.obj (op (U i))`,
there exists a unique gluing `s : F.obj (op (supr U))`.

We prove this to be equivalent to the usual one below in
`is_sheaf_iff_is_sheaf_unique_gluing`
-/
def is_sheaf_unique_gluing : Prop :=
∀ ⦃ι : Type v⦄ (U : ι → opens X) (sf : Π i : ι, F.obj (op (U i))),
  is_compatible F U sf → ∃! s : F.obj (op (supr U)), is_gluing F U sf s

end

section type_valued

variables {X : Top.{v}} (F : presheaf (Type v) X) {ι : Type v} (U : ι → opens X)

/--
For presheaves of types, terms of `pi_opens F U` are just families of sections.
-/
def pi_opens_iso_sections_family : pi_opens F U ≅ Π i : ι, F.obj (op (U i)) :=
limits.is_limit.cone_point_unique_up_to_iso
  (limit.is_limit (discrete.functor (λ i : ι, F.obj (op (U i)))))
  ((types.product_limit_cone.{v v} (λ i : ι, F.obj (op (U i)))).is_limit)

/--
Under the isomorphism `pi_opens_iso_sections_family`, compatibility of sections is the same
as being equalized by the arrows `left_res` and `right_res` of the equalizer diagram.
-/
lemma compatible_iff_left_res_eq_right_res (sf : pi_opens F U) :
  is_compatible F U ((pi_opens_iso_sections_family F U).hom sf)
    ↔ left_res F U sf = right_res F U sf :=
begin
  split ; intros h,
  { ext ⟨i, j⟩,
    rw [left_res, types.limit.lift_π_apply', fan.mk_π_app,
        right_res, types.limit.lift_π_apply', fan.mk_π_app],
    exact h i j, },
  { intros i j,
    convert congr_arg (limits.pi.π (λ p : ι × ι, F.obj (op (U p.1 ⊓ U p.2))) (i,j)) h,
    { rw [left_res, types.pi_lift_π_apply], refl },
    { rw [right_res, types.pi_lift_π_apply], refl } }
end

/--
Under the isomorphism `pi_opens_iso_sections_family`, being a gluing of a family of
sections `sf` is the same as lying in the preimage of `res` (the leftmost arrow of the
equalizer diagram).
-/
@[simp]
lemma is_gluing_iff_eq_res (sf : pi_opens F U) (s : F.obj (op (supr U))):
  is_gluing F U ((pi_opens_iso_sections_family F U).hom sf) s ↔ res F U s = sf :=
begin
  split ; intros h,
  { ext ⟨i⟩,
    rw [res, types.limit.lift_π_apply', fan.mk_π_app],
    exact h i, },
  { intro i,
    convert congr_arg (limits.pi.π (λ i : ι, F.obj (op (U i))) i) h,
    rw [res, types.pi_lift_π_apply],
    refl },
end

/--
The "equalizer" sheaf condition can be obtained from the sheaf condition
in terms of unique gluings.
-/
lemma is_sheaf_of_is_sheaf_unique_gluing_types (Fsh : F.is_sheaf_unique_gluing) :
  F.is_sheaf :=
begin
  rw is_sheaf_iff_is_sheaf_equalizer_products,
  intros ι U,
  refine ⟨fork.is_limit.mk' _ _⟩,
  intro s,
  have h_compatible : ∀ x : s.X,
    F.is_compatible U ((F.pi_opens_iso_sections_family U).hom (s.ι x)),
  { intro x,
    rw compatible_iff_left_res_eq_right_res,
    convert congr_fun s.condition x, },
  choose m m_spec m_uniq using
    λ x : s.X, Fsh U ((pi_opens_iso_sections_family F U).hom (s.ι x)) (h_compatible x),
  refine ⟨m, _, _⟩,
  { ext ⟨i⟩ x,
    simp [res],
    exact m_spec x i, },
  { intros l hl,
    ext x,
    apply m_uniq,
    rw is_gluing_iff_eq_res,
    exact congr_fun hl x },
end

/--
The sheaf condition in terms of unique gluings can be obtained from the usual
"equalizer" sheaf condition.
-/
lemma is_sheaf_unique_gluing_of_is_sheaf_types (Fsh : F.is_sheaf) :
  F.is_sheaf_unique_gluing :=
begin
  rw is_sheaf_iff_is_sheaf_equalizer_products at Fsh,
  intros ι U sf hsf,
  let sf' := (pi_opens_iso_sections_family F U).inv sf,
  have hsf' : left_res F U sf' = right_res F U sf',
  { rwa [← compatible_iff_left_res_eq_right_res F U sf', inv_hom_id_apply] },
  choose s s_spec s_uniq using types.unique_of_type_equalizer _ _ (Fsh U).some sf' hsf',
  use s,
  dsimp,
  split,
  { convert (is_gluing_iff_eq_res F U sf' _).mpr s_spec,
    rw inv_hom_id_apply },
  { intros y hy,
    apply s_uniq,
    rw ← is_gluing_iff_eq_res F U,
    convert hy,
    rw inv_hom_id_apply, },
end

/--
For type-valued presheaves, the sheaf condition in terms of unique gluings is equivalent to the
usual sheaf condition in terms of equalizer diagrams.
-/
lemma is_sheaf_iff_is_sheaf_unique_gluing_types :
  F.is_sheaf ↔ F.is_sheaf_unique_gluing :=
iff.intro (is_sheaf_unique_gluing_of_is_sheaf_types F)
  (is_sheaf_of_is_sheaf_unique_gluing_types F)

end type_valued

section

local attribute [instance] concrete_category.has_coe_to_sort concrete_category.has_coe_to_fun

variables [has_limits C] [reflects_isomorphisms (forget C)] [preserves_limits (forget C)]
variables {X : Top.{v}} (F : presheaf C X) {ι : Type v} (U : ι → opens X)

/--
For presheaves valued in a concrete category, whose forgetful functor reflects isomorphisms and
preserves limits, the sheaf condition in terms of unique gluings is equivalent to the usual one
in terms of equalizer diagrams.
-/
lemma is_sheaf_iff_is_sheaf_unique_gluing :
  F.is_sheaf ↔ F.is_sheaf_unique_gluing :=
iff.trans (is_sheaf_iff_is_sheaf_comp (forget C) F)
  (is_sheaf_iff_is_sheaf_unique_gluing_types (F ⋙ forget C))

end

end presheaf

namespace sheaf

open presheaf
open category_theory

section

local attribute [instance] concrete_category.has_coe_to_sort concrete_category.has_coe_to_fun

variables [has_limits C] [reflects_isomorphisms (concrete_category.forget C)]
variables [preserves_limits (concrete_category.forget C)]

variables {X : Top.{v}} (F : sheaf C X) {ι : Type v} (U : ι → opens X)

/--
A more convenient way of obtaining a unique gluing of sections for a sheaf.
-/
lemma exists_unique_gluing (sf : Π i : ι, F.1.obj (op (U i)))
  (h : is_compatible F.1 U sf ) :
  ∃! s : F.1.obj (op (supr U)), is_gluing F.1 U sf s :=
(is_sheaf_iff_is_sheaf_unique_gluing F.1).mp F.cond U sf h

/--
In this version of the lemma, the inclusion homs `iUV` can be specified directly by the user,
which can be more convenient in practice.
-/
lemma exists_unique_gluing' (V : opens X) (iUV : Π i : ι, U i ⟶ V) (hcover : V ≤ supr U)
  (sf : Π i : ι, F.1.obj (op (U i))) (h : is_compatible F.1 U sf) :
  ∃! s : F.1.obj (op V), ∀ i : ι, F.1.map (iUV i).op s = sf i :=
begin
  have V_eq_supr_U : V = supr U := le_antisymm hcover (supr_le (λ i, (iUV i).le)),
  obtain ⟨gl, gl_spec, gl_uniq⟩ := F.exists_unique_gluing U sf h,
  refine ⟨F.1.map (eq_to_hom V_eq_supr_U).op gl, _, _⟩,
  { intro i,
    rw [← comp_apply, ← F.1.map_comp],
    exact gl_spec i },
  { intros gl' gl'_spec,
    convert congr_arg _ (gl_uniq (F.1.map (eq_to_hom V_eq_supr_U.symm).op gl') (λ i,_)) ;
      rw [← comp_apply, ← F.1.map_comp],
    { rw [eq_to_hom_op, eq_to_hom_op, eq_to_hom_trans, eq_to_hom_refl,
      F.1.map_id, id_apply] },
    { convert gl'_spec i } }
end

@[ext]
lemma eq_of_locally_eq (s t : F.1.obj (op (supr U)))
  (h : ∀ i, F.1.map (opens.le_supr U i).op s = F.1.map (opens.le_supr U i).op t) :
  s = t :=
begin
  let sf : Π i : ι, F.1.obj (op (U i)) := λ i, F.1.map (opens.le_supr U i).op s,
  have sf_compatible : is_compatible _ U sf,
  { intros i j, simp_rw [← comp_apply, ← F.1.map_comp], refl },
  obtain ⟨gl, -, gl_uniq⟩ := F.exists_unique_gluing U sf sf_compatible,
  transitivity gl,
  { apply gl_uniq, intro i, refl },
  { symmetry, apply gl_uniq, intro i, rw ← h },
end

/--
In this version of the lemma, the inclusion homs `iUV` can be specified directly by the user,
which can be more convenient in practice.
-/
lemma eq_of_locally_eq' (V : opens X) (iUV : Π i : ι, U i ⟶ V) (hcover : V ≤ supr U)
  (s t : F.1.obj (op V))
  (h : ∀ i, F.1.map (iUV i).op s = F.1.map (iUV i).op t) : s = t :=
begin
  have V_eq_supr_U : V = supr U := le_antisymm hcover (supr_le (λ i, (iUV i).le)),
  suffices : F.1.map (eq_to_hom V_eq_supr_U.symm).op s =
             F.1.map (eq_to_hom V_eq_supr_U.symm).op t,
  { convert congr_arg (F.1.map (eq_to_hom V_eq_supr_U).op) this ;
    rw [← comp_apply, ← F.1.map_comp, eq_to_hom_op, eq_to_hom_op, eq_to_hom_trans,
      eq_to_hom_refl, F.1.map_id, id_apply] },
  apply eq_of_locally_eq,
  intro i,
  rw [← comp_apply, ← comp_apply, ← F.1.map_comp],
  convert h i,
end

lemma eq_of_locally_eq₂ {U₁ U₂ V : opens X}
  (i₁ : U₁ ⟶ V) (i₂ : U₂ ⟶ V) (hcover : V ≤ U₁ ⊔ U₂)
  (s t : F.1.obj (op V))
  (h₁ : F.1.map i₁.op s = F.1.map i₁.op t)
  (h₂ : F.1.map i₂.op s = F.1.map i₂.op t) : s = t :=
begin
  classical,
  fapply F.eq_of_locally_eq' (λ t : ulift bool, if t.1 then U₁ else U₂),
  { exact λ i, if h : i.1 then (eq_to_hom (if_pos h)) ≫ i₁ else (eq_to_hom (if_neg h)) ≫ i₂ },
  { refine le_trans hcover _, rw sup_le_iff, split,
    { convert le_supr (λ t : ulift bool, if t.1 then U₁ else U₂) (ulift.up true) },
    { convert le_supr (λ t : ulift bool, if t.1 then U₁ else U₂) (ulift.up false) } },
  { rintro ⟨_|_⟩; simp [h₁, h₂] }
end

end

end sheaf

end Top


/-
Copyright (c) 2019 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/
import data.dfinsupp.basic
import group_theory.submonoid.operations
/-!
# Direct sum

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

This file defines the direct sum of abelian groups, indexed by a discrete type.

## Notation

`⨁ i, β i` is the n-ary direct sum `direct_sum`.
This notation is in the `direct_sum` locale, accessible after `open_locale direct_sum`.

## References

* https://en.wikipedia.org/wiki/Direct_sum
-/

open_locale big_operators

universes u v w u₁

variables (ι : Type v) [dec_ι : decidable_eq ι] (β : ι → Type w)

/-- `direct_sum β` is the direct sum of a family of additive commutative monoids `β i`.

Note: `open_locale direct_sum` will enable the notation `⨁ i, β i` for `direct_sum β`. -/
@[derive [add_comm_monoid, inhabited]]
def direct_sum [Π i, add_comm_monoid (β i)] : Type* := Π₀ i, β i

instance [Π i, add_comm_monoid (β i)] : has_coe_to_fun (direct_sum ι β) (λ _, Π i : ι, β i) :=
dfinsupp.has_coe_to_fun

localized "notation (name := direct_sum)
  `⨁` binders `, ` r:(scoped f, direct_sum _ f) := r" in direct_sum

namespace direct_sum

variables {ι}

section add_comm_group

variables [Π i, add_comm_group (β i)]

instance : add_comm_group (direct_sum ι β) := dfinsupp.add_comm_group

variables {β}
@[simp] lemma sub_apply (g₁ g₂ : ⨁ i, β i) (i : ι) : (g₁ - g₂) i = g₁ i - g₂ i := rfl

end add_comm_group

variables [Π i, add_comm_monoid (β i)]

@[simp] lemma zero_apply (i : ι) : (0 : ⨁ i, β i) i = 0 := rfl

variables {β}
@[simp] lemma add_apply (g₁ g₂ : ⨁ i, β i) (i : ι) : (g₁ + g₂) i = g₁ i + g₂ i := rfl

variables (β)
include dec_ι

/-- `mk β s x` is the element of `⨁ i, β i` that is zero outside `s`
and has coefficient `x i` for `i` in `s`. -/
def mk (s : finset ι) : (Π i : (↑s : set ι), β i.1) →+ ⨁ i, β i :=
{ to_fun := dfinsupp.mk s,
  map_add' := λ _ _, dfinsupp.mk_add,
  map_zero' := dfinsupp.mk_zero, }

/-- `of i` is the natural inclusion map from `β i` to `⨁ i, β i`. -/
def of (i : ι) : β i →+ ⨁ i, β i :=
dfinsupp.single_add_hom β i

@[simp] lemma of_eq_same (i : ι) (x : β i) : (of _ i x) i = x :=
dfinsupp.single_eq_same

lemma of_eq_of_ne (i j : ι) (x : β i) (h : i ≠ j) : (of _ i x) j = 0 :=
dfinsupp.single_eq_of_ne h

@[simp] lemma support_zero [Π (i : ι) (x : β i), decidable (x ≠ 0)] :
  (0 : ⨁ i, β i).support = ∅ := dfinsupp.support_zero

@[simp] lemma support_of [Π (i : ι) (x : β i), decidable (x ≠ 0)]
  (i : ι) (x : β i) (h : x ≠ 0) :
  (of _ i x).support = {i} := dfinsupp.support_single_ne_zero h

lemma support_of_subset [Π (i : ι) (x : β i), decidable (x ≠ 0)] {i : ι} {b : β i} :
  (of _ i b).support ⊆ {i} := dfinsupp.support_single_subset

lemma sum_support_of [Π (i : ι) (x : β i), decidable (x ≠ 0)] (x : ⨁ i, β i) :
  ∑ i in x.support, of β i (x i) = x := dfinsupp.sum_single

variables {β}

theorem mk_injective (s : finset ι) : function.injective (mk β s) :=
dfinsupp.mk_injective s

theorem of_injective (i : ι) : function.injective (of β i) :=
dfinsupp.single_injective

@[elab_as_eliminator]
protected theorem induction_on {C : (⨁ i, β i) → Prop}
  (x : ⨁ i, β i) (H_zero : C 0)
  (H_basic : ∀ (i : ι) (x : β i), C (of β i x))
  (H_plus : ∀ x y, C x → C y → C (x + y)) : C x :=
begin
  apply dfinsupp.induction x H_zero,
  intros i b f h1 h2 ih,
  solve_by_elim
end

/-- If two additive homomorphisms from `⨁ i, β i` are equal on each `of β i y`,
then they are equal. -/
lemma add_hom_ext {γ : Type*} [add_monoid γ] ⦃f g : (⨁ i, β i) →+ γ⦄
  (H : ∀ (i : ι) (y : β i), f (of _ i y) = g (of _ i y)) : f = g :=
dfinsupp.add_hom_ext H

/-- If two additive homomorphisms from `⨁ i, β i` are equal on each `of β i y`,
then they are equal.

See note [partially-applied ext lemmas]. -/
@[ext] lemma add_hom_ext' {γ : Type*} [add_monoid γ] ⦃f g : (⨁ i, β i) →+ γ⦄
  (H : ∀ (i : ι), f.comp (of _ i) = g.comp (of _ i)) : f = g :=
add_hom_ext $ λ i, add_monoid_hom.congr_fun $ H i

variables {γ : Type u₁} [add_comm_monoid γ]

section to_add_monoid

variables (φ : Π i, β i →+ γ) (ψ : (⨁ i, β i) →+ γ)

/-- `to_add_monoid φ` is the natural homomorphism from `⨁ i, β i` to `γ`
induced by a family `φ` of homomorphisms `β i → γ`. -/
def to_add_monoid : (⨁ i, β i) →+ γ :=
(dfinsupp.lift_add_hom φ)

@[simp] lemma to_add_monoid_of (i) (x : β i) : to_add_monoid φ (of β i x) = φ i x :=
dfinsupp.lift_add_hom_apply_single φ i x

theorem to_add_monoid.unique (f : ⨁ i, β i) :
  ψ f = to_add_monoid (λ i, ψ.comp (of β i)) f :=
by {congr, ext, simp [to_add_monoid, of]}

end to_add_monoid

section from_add_monoid

/-- `from_add_monoid φ` is the natural homomorphism from `γ` to `⨁ i, β i`
induced by a family `φ` of homomorphisms `γ → β i`.

Note that this is not an isomorphism. Not every homomorphism `γ →+ ⨁ i, β i` arises in this way. -/
def from_add_monoid : (⨁ i, γ →+ β i) →+ (γ →+ ⨁ i, β i) :=
to_add_monoid $ λ i, add_monoid_hom.comp_hom (of β i)

@[simp] lemma from_add_monoid_of (i : ι) (f : γ →+ β i) :
  from_add_monoid (of _ i f) = (of _ i).comp f :=
by { rw [from_add_monoid, to_add_monoid_of], refl }

lemma from_add_monoid_of_apply (i : ι) (f : γ →+ β i) (x : γ) :
  from_add_monoid (of _ i f) x = of _ i (f x) :=
by rw [from_add_monoid_of, add_monoid_hom.coe_comp]

end from_add_monoid

variables (β)
/-- `set_to_set β S T h` is the natural homomorphism `⨁ (i : S), β i → ⨁ (i : T), β i`,
where `h : S ⊆ T`. -/
-- TODO: generalize this to remove the assumption `S ⊆ T`.
def set_to_set (S T : set ι) (H : S ⊆ T) :
  (⨁ (i : S), β i) →+ (⨁ (i : T), β i) :=
to_add_monoid $ λ i, of (λ (i : subtype T), β i) ⟨↑i, H i.prop⟩
variables {β}

omit dec_ι

instance unique [∀ i, subsingleton (β i)] : unique (⨁ i, β i) := dfinsupp.unique

/-- A direct sum over an empty type is trivial. -/
instance unique_of_is_empty [is_empty ι] : unique (⨁ i, β i) := dfinsupp.unique_of_is_empty

/-- The natural equivalence between `⨁ _ : ι, M` and `M` when `unique ι`. -/
protected def id (M : Type v) (ι : Type* := punit) [add_comm_monoid M] [unique ι] :
  (⨁ (_ : ι), M) ≃+ M :=
{ to_fun := direct_sum.to_add_monoid (λ _, add_monoid_hom.id M),
  inv_fun := of (λ _, M) default,
  left_inv := λ x, direct_sum.induction_on x
    (by rw [add_monoid_hom.map_zero, add_monoid_hom.map_zero])
    (λ p x, by rw [unique.default_eq p, to_add_monoid_of]; refl)
    (λ x y ihx ihy, by rw [add_monoid_hom.map_add, add_monoid_hom.map_add, ihx, ihy]),
  right_inv := λ x, to_add_monoid_of _ _ _,
  ..direct_sum.to_add_monoid (λ _, add_monoid_hom.id M) }

section congr_left
variables {κ : Type*}

/--Reindexing terms of a direct sum.-/
def equiv_congr_left (h : ι ≃ κ) : (⨁ i, β i) ≃+ ⨁ k, β (h.symm k) :=
{ map_add' := dfinsupp.comap_domain'_add _ _,
  ..dfinsupp.equiv_congr_left h }

@[simp] lemma equiv_congr_left_apply (h : ι ≃ κ) (f : ⨁ i, β i) (k : κ) :
  equiv_congr_left h f k = f (h.symm k) := dfinsupp.comap_domain'_apply _ _ _ _

end congr_left

section option
variables {α : option ι → Type w} [Π i, add_comm_monoid (α i)]
include dec_ι

/--Isomorphism obtained by separating the term of index `none` of a direct sum over `option ι`.-/
@[simps] noncomputable def add_equiv_prod_direct_sum : (⨁ i, α i) ≃+ α none × ⨁ i, α (some i) :=
{ map_add' := dfinsupp.equiv_prod_dfinsupp_add, ..dfinsupp.equiv_prod_dfinsupp }

end option

section sigma
variables {α : ι → Type u} {δ : Π i, α i → Type w} [Π i j, add_comm_monoid (δ i j)]

/--The natural map between `⨁ (i : Σ i, α i), δ i.1 i.2` and `⨁ i (j : α i), δ i j`.-/
noncomputable def sigma_curry : (⨁ (i : Σ i, _), δ i.1 i.2) →+ ⨁ i j, δ i j :=
{ to_fun := @dfinsupp.sigma_curry _ _ δ _,
  map_zero' := dfinsupp.sigma_curry_zero,
  map_add' := λ f g, @dfinsupp.sigma_curry_add _ _ δ _ f g }

@[simp] lemma sigma_curry_apply (f : ⨁ (i : Σ i, _), δ i.1 i.2) (i : ι) (j : α i) :
  sigma_curry f i j = f ⟨i, j⟩ := @dfinsupp.sigma_curry_apply _ _ δ _ f i j

/--The natural map between `⨁ i (j : α i), δ i j` and `Π₀ (i : Σ i, α i), δ i.1 i.2`, inverse of
`curry`.-/
def sigma_uncurry [Π i, decidable_eq (α i)] [Π i j, decidable_eq (δ i j)] :
  (⨁ i j, δ i j) →+ ⨁ (i : Σ i, _), δ i.1 i.2 :=
{ to_fun := dfinsupp.sigma_uncurry,
  map_zero' := dfinsupp.sigma_uncurry_zero,
  map_add' := dfinsupp.sigma_uncurry_add }

@[simp] lemma sigma_uncurry_apply [Π i, decidable_eq (α i)] [Π i j, decidable_eq (δ i j)]
  (f : ⨁ i j, δ i j) (i : ι) (j : α i) :
  sigma_uncurry f ⟨i, j⟩ = f i j := dfinsupp.sigma_uncurry_apply f i j

/--The natural map between `⨁ (i : Σ i, α i), δ i.1 i.2` and `⨁ i (j : α i), δ i j`.-/
noncomputable def sigma_curry_equiv
  [Π i, decidable_eq (α i)] [Π i j, decidable_eq (δ i j)] :
  (⨁ (i : Σ i, _), δ i.1 i.2) ≃+ ⨁ i j, δ i j :=
{ ..sigma_curry, ..dfinsupp.sigma_curry_equiv }

end sigma

/-- The canonical embedding from `⨁ i, A i` to `M` where `A` is a collection of `add_submonoid M`
indexed by `ι`.

When `S = submodule _ M`, this is available as a `linear_map`, `direct_sum.coe_linear_map`. -/
protected def coe_add_monoid_hom {M S : Type*} [decidable_eq ι] [add_comm_monoid M]
  [set_like S M] [add_submonoid_class S M] (A : ι → S) : (⨁ i, A i) →+ M :=
to_add_monoid (λ i, add_submonoid_class.subtype (A i))

@[simp] lemma coe_add_monoid_hom_of {M S : Type*} [decidable_eq ι] [add_comm_monoid M]
  [set_like S M] [add_submonoid_class S M] (A : ι → S) (i : ι) (x : A i) :
  direct_sum.coe_add_monoid_hom A (of (λ i, A i) i x) = x :=
to_add_monoid_of _ _ _

lemma coe_of_apply {M S : Type*} [decidable_eq ι] [add_comm_monoid M]
  [set_like S M] [add_submonoid_class S M] {A : ι → S} (i j : ι) (x : A i) :
  (of _ i x j : M) = if i = j then x else 0 :=
begin
  obtain rfl | h := decidable.eq_or_ne i j,
  { rw [direct_sum.of_eq_same, if_pos rfl], },
  { rw [direct_sum.of_eq_of_ne _ _ _ _ h, if_neg h, zero_mem_class.coe_zero], },
end

/-- The `direct_sum` formed by a collection of additive submonoids (or subgroups, or submodules) of
`M` is said to be internal if the canonical map `(⨁ i, A i) →+ M` is bijective.

For the alternate statement in terms of independence and spanning, see
`direct_sum.subgroup_is_internal_iff_independent_and_supr_eq_top` and
`direct_sum.is_internal_submodule_iff_independent_and_supr_eq_top`. -/
def is_internal {M S : Type*} [decidable_eq ι] [add_comm_monoid M]
  [set_like S M] [add_submonoid_class S M] (A : ι → S) : Prop :=
function.bijective (direct_sum.coe_add_monoid_hom A)

lemma is_internal.add_submonoid_supr_eq_top {M : Type*} [decidable_eq ι] [add_comm_monoid M]
  (A : ι → add_submonoid M)
  (h : is_internal A) : supr A = ⊤ :=
begin
  rw [add_submonoid.supr_eq_mrange_dfinsupp_sum_add_hom, add_monoid_hom.mrange_top_iff_surjective],
  exact function.bijective.surjective h,
end

end direct_sum


/-
Copyright (c) 2019 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/

import algebra.module.basic
import algebra.gcd_monoid.basic
import group_theory.group_action.defs

/-!
# Instances on punit

This file collects facts about algebraic structures on the one-element type, e.g. that it is a
commutative ring.
-/

universes u

namespace punit
variables {R S : Type*} (x y : punit.{u+1}) (s : set punit.{u+1})

@[to_additive]
instance : comm_group punit :=
by refine_struct
{ mul := λ _ _, star,
  one := star,
  inv := λ _, star,
  div := λ _ _, star,
  npow := λ _ _, star,
  zpow := λ _ _, star,
  .. };
intros; exact subsingleton.elim _ _

@[simp, to_additive] lemma one_eq : (1 : punit) = star := rfl
@[simp, to_additive] lemma mul_eq : x * y = star := rfl
@[simp, to_additive] lemma div_eq : x / y = star := rfl
@[simp, to_additive] lemma inv_eq : x⁻¹ = star := rfl

instance : comm_ring punit :=
by refine
{ .. punit.comm_group,
  .. punit.add_comm_group,
  .. };
intros; exact subsingleton.elim _ _

instance : cancel_comm_monoid_with_zero punit :=
by refine
{ .. punit.comm_ring,
  .. };
intros; exact subsingleton.elim _ _

instance : normalized_gcd_monoid punit :=
by refine
{ gcd := λ _ _, star,
  lcm := λ _ _, star,
  norm_unit := λ x, 1,
  gcd_dvd_left := λ _ _, ⟨star, subsingleton.elim _ _⟩,
  gcd_dvd_right := λ _ _, ⟨star, subsingleton.elim _ _⟩,
  dvd_gcd := λ _ _ _ _ _, ⟨star, subsingleton.elim _ _⟩,
  gcd_mul_lcm := λ _ _, ⟨1, subsingleton.elim _ _⟩,
  .. };
intros; exact subsingleton.elim _ _

@[simp] lemma gcd_eq : gcd x y = star := rfl
@[simp] lemma lcm_eq : lcm x y = star := rfl
@[simp] lemma norm_unit_eq : norm_unit x = 1 := rfl

instance : complete_boolean_algebra punit :=
by refine
{ le := λ _ _, true,
  le_antisymm := λ _ _ _ _, subsingleton.elim _ _,
  lt := λ _ _, false,
  lt_iff_le_not_le := λ _ _, iff_of_false not_false (λ H, H.2 trivial),
  top := star,
  bot := star,
  sup := λ _ _, star,
  inf := λ _ _, star,
  Sup := λ _, star,
  Inf := λ _, star,
  compl := λ _, star,
  sdiff := λ _ _, star,
  .. };
intros; trivial <|> simp only [eq_iff_true_of_subsingleton]

@[simp] lemma top_eq : (⊤ : punit) = star := rfl
@[simp] lemma bot_eq : (⊥ : punit) = star := rfl
@[simp] lemma sup_eq : x ⊔ y = star := rfl
@[simp] lemma inf_eq : x ⊓ y = star := rfl
@[simp] lemma Sup_eq : Sup s = star := rfl
@[simp] lemma Inf_eq : Inf s = star := rfl
@[simp] lemma compl_eq : xᶜ = star := rfl
@[simp] lemma sdiff_eq : x \ y = star := rfl
@[simp] protected lemma le : x ≤ y := trivial
@[simp] lemma not_lt : ¬(x < y) := not_false

instance : canonically_ordered_add_monoid punit :=
by refine
{ le_iff_exists_add := λ _ _, iff_of_true _ ⟨star, subsingleton.elim _ _⟩,
  .. punit.comm_ring, .. punit.complete_boolean_algebra, .. };
intros; trivial

instance : linear_ordered_cancel_add_comm_monoid punit :=
{ add_left_cancel := λ _ _ _ _, subsingleton.elim _ _,
  le_of_add_le_add_left := λ _ _ _ _, trivial,
  le_total := λ _ _, or.inl trivial,
  decidable_le := λ _ _, decidable.true,
  decidable_eq := punit.decidable_eq,
  decidable_lt := λ _ _, decidable.false,
  .. punit.canonically_ordered_add_monoid }

instance : has_scalar R punit :=
{ smul := λ _ _, star }

@[simp] lemma smul_eq (r : R) : r • y = star := rfl

instance : smul_comm_class R S punit := ⟨λ _ _ _, subsingleton.elim _ _⟩

instance [has_scalar R S] : is_scalar_tower R S punit := ⟨λ _ _ _, subsingleton.elim _ _⟩

instance [has_zero R] : smul_with_zero R punit :=
by refine { ..punit.has_scalar, .. };
intros; exact subsingleton.elim _ _

instance [monoid R] : mul_action R punit :=
by refine { ..punit.has_scalar, .. };
intros; exact subsingleton.elim _ _

instance [monoid R] : distrib_mul_action R punit :=
by refine { ..punit.mul_action, .. };
intros; exact subsingleton.elim _ _

instance [monoid R] : mul_distrib_mul_action R punit :=
by refine { ..punit.mul_action, .. };
intros; exact subsingleton.elim _ _

/-! TODO: provide `mul_semiring_action R punit` -/
-- importing it here currently causes timeouts elsewhere due to the import order changing

instance [monoid_with_zero R] : mul_action_with_zero R punit :=
{ .. punit.mul_action, .. punit.smul_with_zero }

instance [semiring R] : module R punit :=
by refine { .. punit.distrib_mul_action, .. };
intros; exact subsingleton.elim _ _

end punit


/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/

import linear_algebra.finite_dimensional
import linear_algebra.basic
import ring_theory.mv_polynomial.basic
import data.mv_polynomial.expand
import field_theory.finite.basic

/-!
## Polynomials over finite fields
-/

namespace mv_polynomial
variables {σ : Type*}

/-- A polynomial over the integers is divisible by `n : ℕ`
if and only if it is zero over `zmod n`. -/
lemma C_dvd_iff_zmod (n : ℕ) (φ : mv_polynomial σ ℤ) :
  C (n:ℤ) ∣ φ ↔ map (int.cast_ring_hom (zmod n)) φ = 0 :=
C_dvd_iff_map_hom_eq_zero _ _ (char_p.int_cast_eq_zero_iff (zmod n) n) _

section frobenius

variables {p : ℕ} [fact p.prime]

lemma frobenius_zmod (f : mv_polynomial σ (zmod p)) :
  frobenius _ p f = expand p f :=
begin
  apply induction_on f,
  { intro a, rw [expand_C, frobenius_def, ← C_pow, zmod.pow_card], },
  { simp only [alg_hom.map_add, ring_hom.map_add], intros _ _ hf hg, rw [hf, hg] },
  { simp only [expand_X, ring_hom.map_mul, alg_hom.map_mul],
    intros _ _ hf, rw [hf, frobenius_def], },
end

end frobenius

end mv_polynomial

namespace mv_polynomial

noncomputable theory
open_locale big_operators classical
open set linear_map submodule

variables {K : Type*} {σ : Type*}
variables [field K] [fintype K] [fintype σ]

def indicator (a : σ → K) : mv_polynomial σ K :=
∏ n, (1 - (X n - C (a n))^(fintype.card K - 1))

lemma eval_indicator_apply_eq_one (a : σ → K) :
  eval a (indicator a) = 1 :=
have 0 < fintype.card K - 1,
begin
  rw [← fintype.card_units, fintype.card_pos_iff],
  exact ⟨1⟩
end,
by { simp only [indicator, (eval a).map_prod, ring_hom.map_sub,
    (eval a).map_one, (eval a).map_pow, eval_X, eval_C,
    sub_self, zero_pow this, sub_zero, finset.prod_const_one] }

lemma eval_indicator_apply_eq_zero (a b : σ → K) (h : a ≠ b) :
  eval a (indicator b) = 0 :=
have ∃i, a i ≠ b i, by rwa [(≠), function.funext_iff, not_forall] at h,
begin
  rcases this with ⟨i, hi⟩,
  simp only [indicator, (eval a).map_prod, ring_hom.map_sub,
    (eval a).map_one, (eval a).map_pow, eval_X, eval_C,
    sub_self, finset.prod_eq_zero_iff],
  refine ⟨i, finset.mem_univ _, _⟩,
  rw [finite_field.pow_card_sub_one_eq_one, sub_self],
  rwa [(≠), sub_eq_zero],
end

lemma degrees_indicator (c : σ → K) :
  degrees (indicator c) ≤ ∑ s : σ, (fintype.card K - 1) • {s} :=
begin
  rw [indicator],
  refine le_trans (degrees_prod _ _) (finset.sum_le_sum $ assume s hs, _),
  refine le_trans (degrees_sub _ _) _,
  rw [degrees_one, ← bot_eq_zero, bot_sup_eq],
  refine le_trans (degrees_pow _ _) (nsmul_le_nsmul_of_le_right _ _),
  refine le_trans (degrees_sub _ _) _,
  rw [degrees_C, ← bot_eq_zero, sup_bot_eq],
  exact degrees_X' _
end

lemma indicator_mem_restrict_degree (c : σ → K) :
  indicator c ∈ restrict_degree σ K (fintype.card K - 1) :=
begin
  rw [mem_restrict_degree_iff_sup, indicator],
  assume n,
  refine le_trans (multiset.count_le_of_le _ $ degrees_indicator _) (le_of_eq _),
  simp_rw [ ← multiset.coe_count_add_monoid_hom, (multiset.count_add_monoid_hom n).map_sum,
    add_monoid_hom.map_nsmul, multiset.coe_count_add_monoid_hom, nsmul_eq_mul, nat.cast_id],
  transitivity,
  refine finset.sum_eq_single n _ _,
  { assume b hb ne, rw [multiset.count_singleton, if_neg ne.symm, mul_zero] },
  { assume h, exact (h $ finset.mem_univ _).elim },
  { rw [multiset.count_singleton_self, mul_one] }
end

section
variables (K σ)
def evalₗ : mv_polynomial σ K →ₗ[K] (σ → K) → K :=
{ to_fun := λ p e, eval e p,
  map_add' := λ p q, by { ext x, rw ring_hom.map_add, refl, },
  map_smul' := λ a p, by { ext e, rw [smul_eq_C_mul, ring_hom.map_mul, eval_C], refl } }
end

lemma evalₗ_apply (p : mv_polynomial σ K) (e : σ → K) : evalₗ K σ p e = eval e p :=
rfl

lemma map_restrict_dom_evalₗ : (restrict_degree σ K (fintype.card K - 1)).map (evalₗ K σ) = ⊤ :=
begin
  refine top_unique (set_like.le_def.2 $ assume e _, mem_map.2 _),
  refine ⟨∑ n : σ → K, e n • indicator n, _, _⟩,
  { exact sum_mem _ (assume c _, smul_mem _ _ (indicator_mem_restrict_degree _)) },
  { ext n,
    simp only [linear_map.map_sum, @finset.sum_apply (σ → K) (λ_, K) _ _ _ _ _,
      pi.smul_apply, linear_map.map_smul],
    simp only [evalₗ_apply],
    transitivity,
    refine finset.sum_eq_single n _ _,
    { assume b _ h,
      rw [eval_indicator_apply_eq_zero _ _ h.symm, smul_zero] },
    { assume h, exact (h $ finset.mem_univ n).elim },
    { rw [eval_indicator_apply_eq_one, smul_eq_mul, mul_one] } }
end
end mv_polynomial

namespace mv_polynomial

open_locale classical cardinal
open linear_map submodule

universe u
variables (σ : Type u) (K : Type u) [fintype σ] [field K] [fintype K]

@[derive [add_comm_group, module K, inhabited]]
def R : Type u := restrict_degree σ K (fintype.card K - 1)

noncomputable instance decidable_restrict_degree (m : ℕ) :
  decidable_pred (∈ {n : σ →₀ ℕ | ∀i, n i ≤ m }) :=
by simp only [set.mem_set_of_eq]; apply_instance

lemma dim_R : module.rank K (R σ K) = fintype.card (σ → K) :=
calc module.rank K (R σ K) =
  module.rank K (↥{s : σ →₀ ℕ | ∀ (n : σ), s n ≤ fintype.card K - 1} →₀ K) :
    linear_equiv.dim_eq
      (finsupp.supported_equiv_finsupp {s : σ →₀ ℕ | ∀n:σ, s n ≤ fintype.card K - 1 })
  ... = #{s : σ →₀ ℕ | ∀ (n : σ), s n ≤ fintype.card K - 1} :
    by rw [finsupp.dim_eq, dim_self, mul_one]
  ... = #{s : σ → ℕ | ∀ (n : σ), s n < fintype.card K } :
  begin
    refine quotient.sound ⟨equiv.subtype_equiv finsupp.equiv_fun_on_fintype $ assume f, _⟩,
    refine forall_congr (assume n, le_tsub_iff_right _),
    exact fintype.card_pos_iff.2 ⟨0⟩
  end
  ... = #(σ → {n // n < fintype.card K}) :
    (@equiv.subtype_pi_equiv_pi σ (λ_, ℕ) (λs n, n < fintype.card K)).cardinal_eq
  ... = #(σ → fin (fintype.card K)) :
    (equiv.arrow_congr (equiv.refl σ) (equiv.fin_equiv_subtype _).symm).cardinal_eq
  ... = #(σ → K) :
    (equiv.arrow_congr (equiv.refl σ) (fintype.equiv_fin K).symm).cardinal_eq
  ... = fintype.card (σ → K) : cardinal.mk_fintype _

instance : finite_dimensional K (R σ K) :=
is_noetherian.iff_fg.1 $ is_noetherian.iff_dim_lt_omega.mpr
  (by simpa only [dim_R] using cardinal.nat_lt_omega (fintype.card (σ → K)))

lemma finrank_R : finite_dimensional.finrank K (R σ K) = fintype.card (σ → K) :=
finite_dimensional.finrank_eq_of_dim_eq (dim_R σ K)

def evalᵢ : R σ K →ₗ[K] (σ → K) → K :=
((evalₗ K σ).comp (restrict_degree σ K (fintype.card K - 1)).subtype)

lemma range_evalᵢ : (evalᵢ σ K).range = ⊤ :=
begin
  rw [evalᵢ, linear_map.range_comp, range_subtype],
  exact map_restrict_dom_evalₗ
end

lemma ker_evalₗ : (evalᵢ σ K).ker = ⊥ :=
begin
  refine (ker_eq_bot_iff_range_eq_top_of_finrank_eq_finrank _).mpr (range_evalᵢ _ _),
  rw [finite_dimensional.finrank_fintype_fun_eq_card, finrank_R]
end

lemma eq_zero_of_eval_eq_zero (p : mv_polynomial σ K)
  (h : ∀v:σ → K, eval v p = 0) (hp : p ∈ restrict_degree σ K (fintype.card K - 1)) :
  p = 0 :=
let p' : R σ K := ⟨p, hp⟩ in
have p' ∈ (evalᵢ σ K).ker := by { rw [mem_ker], ext v, exact h v },
show p'.1 = (0 : R σ K).1,
begin
  rw [ker_evalₗ, mem_bot] at this,
  rw [this]
end

end mv_polynomial


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

! This file was ported from Lean 3 source module data.mv_polynomial.derivation
! leanprover-community/mathlib commit 6e492fdbed778ea815798a5a0c6cb83df8486265
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.MvPolynomial.Supported
import Mathbin.RingTheory.Derivation

/-!
# Derivations of multivariate polynomials

In this file we prove that a derivation of `mv_polynomial σ R` is determined by its values on all
monomials `mv_polynomial.X i`. We also provide a constructor `mv_polynomial.mk_derivation` that
builds a derivation from its values on `X i`s and a linear equivalence
`mv_polynomial.equiv_derivation` between `σ → A` and `derivation (mv_polynomial σ R) A`.
-/

namespace MvPolynomial

open BigOperators

noncomputable section

variable {σ R A : Type _} [CommSemiring R] [AddCommMonoid A] [Module R A]
  [Module (MvPolynomial σ R) A]

section

variable (R)

/-- The derivation on `mv_polynomial σ R` that takes value `f i` on `X i`, as a linear map.
Use `mv_polynomial.mk_derivation` instead. -/
def mkDerivationₗ (f : σ → A) : MvPolynomial σ R →ₗ[R] A :=
  Finsupp.lsum R fun xs : σ →₀ ℕ =>
    (LinearMap.ringLmapEquivSelf R R A).symm <|
      xs.Sum fun i k => monomial (xs - Finsupp.single i 1) (k : R) • f i
#align mv_polynomial.mk_derivationₗ MvPolynomial.mkDerivationₗ

end

theorem mkDerivationₗ_monomial (f : σ → A) (s : σ →₀ ℕ) (r : R) :
    mkDerivationₗ R f (monomial s r) =
      r • s.Sum fun i k => monomial (s - Finsupp.single i 1) (k : R) • f i :=
  sum_monomial_eq <| LinearMap.map_zero _
#align mv_polynomial.mk_derivationₗ_monomial MvPolynomial.mkDerivationₗ_monomial

theorem mkDerivationₗ_c (f : σ → A) (r : R) : mkDerivationₗ R f (C r) = 0 :=
  (mkDerivationₗ_monomial f _ _).trans (smul_zero _)
#align mv_polynomial.mk_derivationₗ_C MvPolynomial.mkDerivationₗ_c

theorem mkDerivationₗ_x (f : σ → A) (i : σ) : mkDerivationₗ R f (X i) = f i :=
  (mkDerivationₗ_monomial f _ _).trans <| by simp
#align mv_polynomial.mk_derivationₗ_X MvPolynomial.mkDerivationₗ_x

@[simp]
theorem derivation_c (D : Derivation R (MvPolynomial σ R) A) (a : R) : D (C a) = 0 :=
  D.map_algebraMap a
#align mv_polynomial.derivation_C MvPolynomial.derivation_c

@[simp]
theorem derivation_c_mul (D : Derivation R (MvPolynomial σ R) A) (a : R) (f : MvPolynomial σ R) :
    D (C a * f) = a • D f := by rw [C_mul', D.map_smul]
#align mv_polynomial.derivation_C_mul MvPolynomial.derivation_c_mul

/-- If two derivations agree on `X i`, `i ∈ s`, then they agree on all polynomials from
`mv_polynomial.supported R s`. -/
theorem derivation_eqOn_supported {D₁ D₂ : Derivation R (MvPolynomial σ R) A} {s : Set σ}
    (h : Set.EqOn (D₁ ∘ X) (D₂ ∘ X) s) {f : MvPolynomial σ R} (hf : f ∈ supported R s) :
    D₁ f = D₂ f :=
  Derivation.eqOn_adjoin (Set.ball_image_iff.2 h) hf
#align mv_polynomial.derivation_eq_on_supported MvPolynomial.derivation_eqOn_supported

theorem derivation_eq_of_forall_mem_vars {D₁ D₂ : Derivation R (MvPolynomial σ R) A}
    {f : MvPolynomial σ R} (h : ∀ i ∈ f.vars, D₁ (X i) = D₂ (X i)) : D₁ f = D₂ f :=
  derivation_eqOn_supported h f.mem_supported_vars
#align mv_polynomial.derivation_eq_of_forall_mem_vars MvPolynomial.derivation_eq_of_forall_mem_vars

theorem derivation_eq_zero_of_forall_mem_vars {D : Derivation R (MvPolynomial σ R) A}
    {f : MvPolynomial σ R} (h : ∀ i ∈ f.vars, D (X i) = 0) : D f = 0 :=
  show D f = (0 : Derivation R (MvPolynomial σ R) A) f from derivation_eq_of_forall_mem_vars h
#align mv_polynomial.derivation_eq_zero_of_forall_mem_vars MvPolynomial.derivation_eq_zero_of_forall_mem_vars

@[ext]
theorem derivation_ext {D₁ D₂ : Derivation R (MvPolynomial σ R) A} (h : ∀ i, D₁ (X i) = D₂ (X i)) :
    D₁ = D₂ :=
  Derivation.ext fun f => derivation_eq_of_forall_mem_vars fun i _ => h i
#align mv_polynomial.derivation_ext MvPolynomial.derivation_ext

variable [IsScalarTower R (MvPolynomial σ R) A]

theorem leibniz_iff_x (D : MvPolynomial σ R →ₗ[R] A) (h₁ : D 1 = 0) :
    (∀ p q, D (p * q) = p • D q + q • D p) ↔
      ∀ s i,
        D (monomial s 1 * X i) =
          (monomial s 1 : MvPolynomial σ R) • D (X i) +
            (X i : MvPolynomial σ R) • D (monomial s 1) :=
  by
  refine' ⟨fun H p i => H _ _, fun H => _⟩
  have hC : ∀ r, D (C r) = 0 := by
    intro r
    rw [C_eq_smul_one, D.map_smul, h₁, smul_zero]
  have : ∀ p i, D (p * X i) = p • D (X i) + (X i : MvPolynomial σ R) • D p :=
    by
    intro p i
    induction' p using MvPolynomial.induction_on' with s r p q hp hq
    · rw [← mul_one r, ← C_mul_monomial, mul_assoc, C_mul', D.map_smul, H, C_mul', smul_assoc,
        smul_add, D.map_smul, smul_comm r (X i)]
      infer_instance
    · rw [add_mul, map_add, map_add, hp, hq, add_smul, smul_add, add_add_add_comm]
  intro p q
  induction q using MvPolynomial.induction_on
  case h_C c =>
    rw [mul_comm, C_mul', hC, smul_zero, zero_add, D.map_smul, C_eq_smul_one, smul_one_smul]
  case h_add q₁ q₂ h₁ h₂ => simp only [mul_add, map_add, h₁, h₂, smul_add, add_smul]; abel
  case h_X q i hq =>
    simp only [this, ← mul_assoc, hq, mul_smul, smul_add, smul_comm (X i), add_assoc]
#align mv_polynomial.leibniz_iff_X MvPolynomial.leibniz_iff_x

variable (R)

/-- The derivation on `mv_polynomial σ R` that takes value `f i` on `X i`. -/
def mkDerivation (f : σ → A) : Derivation R (MvPolynomial σ R) A
    where
  toLinearMap := mkDerivationₗ R f
  map_one_eq_zero' := mkDerivationₗ_c _ 1
  leibniz' :=
    (leibniz_iff_x (mkDerivationₗ R f) (mkDerivationₗ_c _ 1)).2 fun s i =>
      by
      simp only [mk_derivationₗ_monomial, X, monomial_mul, one_smul, one_mul]
      rw [Finsupp.sum_add_index'] <;> [skip, · simp,
        · intros
          simp only [Nat.cast_add, (monomial _).map_add, add_smul]]
      rw [Finsupp.sum_single_index, Finsupp.sum_single_index] <;> [skip, · simp, · simp]
      rw [tsub_self, add_tsub_cancel_right, Nat.cast_one, ← C_apply, C_1, one_smul, add_comm,
        Finsupp.smul_sum]
      refine' congr_arg₂ (· + ·) rfl (Finset.sum_congr rfl fun j hj => _); dsimp only
      rw [smul_smul, monomial_mul, one_mul, add_comm s, add_tsub_assoc_of_le]
      rwa [Finsupp.single_le_iff, Nat.succ_le_iff, pos_iff_ne_zero, ← Finsupp.mem_support_iff]
#align mv_polynomial.mk_derivation MvPolynomial.mkDerivation

@[simp]
theorem mkDerivation_x (f : σ → A) (i : σ) : mkDerivation R f (X i) = f i :=
  mkDerivationₗ_x f i
#align mv_polynomial.mk_derivation_X MvPolynomial.mkDerivation_x

theorem mkDerivation_monomial (f : σ → A) (s : σ →₀ ℕ) (r : R) :
    mkDerivation R f (monomial s r) =
      r • s.Sum fun i k => monomial (s - Finsupp.single i 1) (k : R) • f i :=
  mkDerivationₗ_monomial f s r
#align mv_polynomial.mk_derivation_monomial MvPolynomial.mkDerivation_monomial

/-- `mv_polynomial.mk_derivation` as a linear equivalence. -/
def mkDerivationEquiv : (σ → A) ≃ₗ[R] Derivation R (MvPolynomial σ R) A :=
  LinearEquiv.symm <|
    { invFun := mkDerivation R
      toFun := fun D i => D (X i)
      map_add' := fun D₁ D₂ => rfl
      map_smul' := fun c D => rfl
      left_inv := fun D => derivation_ext <| mkDerivation_x _ _
      right_inv := fun f => funext <| mkDerivation_x _ _ }
#align mv_polynomial.mk_derivation_equiv MvPolynomial.mkDerivationEquiv

end MvPolynomial


import data.mv_polynomial ring_theory.noetherian finsupp finset

open finsupp
namespace mv_polynomial
variables {σ : Type*} {α : Type*} [decidable_eq σ] [decidable_eq α]

/-section discrete_field
variables [discrete_field α]

theorem HBT : is_noetherian (mv_polynomial σ α) (mv_polynomial σ α) := sorry

lemma ideal_wf : well_founded ((>) : ideal (mv_polynomial σ α) → ideal (mv_polynomial σ α) → Prop) := is_noetherian_iff_well_founded.1 HBT

end discrete_field-/

section basic
variables [comm_semiring α]

instance : has_coe_to_fun (mv_polynomial σ α) := ⟨λ _, (σ →₀ ℕ) → α, finsupp.to_fun⟩
@[simp] lemma support_zero : (0 : mv_polynomial σ α).support = ∅ := finsupp.support_zero
@[simp] lemma zero_apply {a} : (0 : mv_polynomial σ α) a = 0 := rfl
@[simp] lemma support_eq_empty {p : mv_polynomial σ α} : p.support = ∅ ↔ p = 0 := finsupp.support_eq_empty
lemma support_ne_empty (p : mv_polynomial σ α) : p.support ≠ ∅ ↔ p ≠ 0 := by finish
@[simp] lemma eq_zero_lem : ∀ {f : (σ →₀ ℕ) → α} {l}, ({support := ∅, to_fun := f, mem_support_to_fun := l} : mv_polynomial σ α) = (0 : mv_polynomial σ α) := by apply finsupp.eq_zero_lem
lemma eq_zero_apply (p : mv_polynomial σ α) : (∀ a, p a = 0) ↔ p = 0 := eq_zero_apply p

@[simp] lemma zero_monomial {a : σ →₀ ℕ} : ((monomial a 0) : mv_polynomial σ α) = 0 := by simp [monomial]; refl
lemma monomial_eq_zero_iff {a : σ →₀ ℕ} {b : α} : monomial a b = 0 ↔ b = 0 := by simp [monomial]; apply single_eq_zero_iff

lemma monomial_add_monomial {a : σ →₀ ℕ} {b₁ b₂ : α} :
    monomial a (b₁ + b₂) = monomial a b₁ + monomial a b₂ := by simp [monomial]
lemma monomial_mul_monomial {a₁ a₂ : σ →₀ ℕ} {b₁ b₂ : α} :
  monomial a₁ b₁ * monomial a₂ b₂ = monomial (a₁ + a₂) (b₁ * b₂) := by simp [monomial]; apply single_mul_single

lemma monomial_apply {a a' : σ →₀ ℕ} {b : α} : ((monomial a b) : mv_polynomial σ α) a' = if a = a' then b else 0 := rfl

lemma support_monomial_eq {a : σ →₀ ℕ} {b : α} (hb : b ≠ 0) : (monomial a b).support = {a} :=
    by simp [monomial, single, hb]

lemma not_mem_disjoint {p : mv_polynomial σ α} {a : σ →₀ ℕ} (ha : a ∉ p.support)
{b : α} (hb : b ≠ 0) : disjoint (monomial a b).support p.support :=
by simpa [support_monomial_eq hb, finset.disjoint_singleton] using ha

@[simp] lemma add_zero {p : mv_polynomial σ α} : p + 0 = p := by simp

lemma add_monomial_nez {p : mv_polynomial σ α} {a} (ha : a ∉ p.support) {b : α} (hb : b ≠ 0) : monomial a b + p ≠ 0 :=
λ h, hb begin
    rw ←eq_zero_apply (monomial a b + p) at h,
    simpa [monomial_apply, not_mem_support_iff.1 ha] using h a,
end

@[simp] lemma nez_of_mem_support {p : mv_polynomial σ α} {a} (ha : a ∈ p.support) : p ≠ 0 :=
λ h', by finish

@[elab_as_eliminator]
theorem induction_f {C : (mv_polynomial σ α) → Prop} (p : mv_polynomial σ α)
  (C0 : C (0 : mv_polynomial σ α)) (Ca : ∀a b (p : mv_polynomial σ α), a ∉ p.support → b ≠ 0 → C p → C (monomial a b + p)) :
  C p :=
  begin
    apply finsupp.induction, assumption,
    intros a b f haf hb hf,
    simpa [monomial] using Ca a b f haf hb hf,
  end

end basic
end mv_polynomial


--
set_option autoBoundImplicitLocal false
universe u
variable {α : Type u}
variable {β : α → Type v}

theorem ex {p₁ p₂ : Sigma (fun a => β a)} (h₁ : p₁.1 = p₂.1) (h : p₁.2 ≅ p₂.2) : p₁ = p₂ :=
match p₁, p₂, h₁, h with
| ⟨_, _⟩, ⟨_, _⟩, rfl, HEq.refl _ => rfl


namespace nat

variables {x y z : ℕ}

lemma le_add_of_le_right (h : x ≤ y) :
  x ≤ y + z :=
by transitivity;
   [apply nat.le_add_right, apply nat.add_le_add_right h]

lemma le_add_of_le_left (h : x ≤ z) :
  x ≤ y + z :=
by transitivity;
   [apply nat.le_add_left, apply nat.add_le_add_left h]

end nat


/-
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 numbertheory_4x3m7y3neq2003
  (x y : ℤ) :
  4 * x^3 - 7 * y^3 ≠ 2003 :=
begin
  intro hneq,
  apply_fun (coe : ℤ → zmod 7) at hneq,
  push_cast at hneq,
  have : (2003 : zmod 7) = (1 : zmod 7),
    dec_trivial,
  rw this at hneq,
  have : (7 : zmod 7) = (0 : zmod 7),
    dec_trivial,
  rw this at hneq,
  rw zero_mul at hneq,
  rw sub_zero at hneq,
  have main : ∀ (x : zmod 7), x^3 ∈ [(0 : zmod 7), 1, -1],
    dec_trivial,
  rcases main x with h' | h' | h' | h,
  iterate 3 {
    rw h' at hneq,
    revert hneq,
    dec_trivial,
  },
  exact h,
end