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

! This file was ported from Lean 3 source module topology.sheaves.presheaf_of_functions
! leanprover-community/mathlib commit 6c31dd6563a3745bf8e0b80bdd077167583ebb8f
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Yoneda
import Mathbin.Topology.Sheaves.Presheaf
import Mathbin.Topology.Category.TopCommRing
import Mathbin.Topology.ContinuousFunction.Algebra

/-!
# Presheaves of functions

We construct some simple examples of presheaves of functions on a topological space.
* `presheaf_to_Types X T`, where `T : X → Type`,
  is the presheaf of dependently-typed (not-necessarily continuous) functions
* `presheaf_to_Type X T`, where `T : Type`,
  is the presheaf of (not-necessarily-continuous) functions to a fixed target type `T`
* `presheaf_to_Top X T`, where `T : Top`,
  is the presheaf of continuous functions into a topological space `T`
* `presheaf_To_TopCommRing X R`, where `R : TopCommRing`
  is the presheaf valued in `CommRing` of functions functions into a topological ring `R`
* as an example of the previous construction,
  `presheaf_to_TopCommRing X (TopCommRing.of ℂ)`
  is the presheaf of rings of continuous complex-valued functions on `X`.
-/

universe v u

open CategoryTheory

open TopologicalSpace

open Opposite

namespace TopCat

variable (X : TopCat.{v})

/-- The presheaf of dependently typed functions on `X`, with fibres given by a type family `T`.
There is no requirement that the functions are continuous, here.
-/
def presheafToTypes (T : X → Type v) : X.Presheaf (Type v)
    where
  obj U := ∀ x : unop U, T x
  map U V i g := fun x : unop V => g (i.unop x)
  map_id' U := by
    ext (g⟨x, hx⟩)
    rfl
  map_comp' U V W i j := rfl
#align Top.presheaf_to_Types TopCat.presheafToTypes

@[simp]
theorem presheafToTypes_obj {T : X → Type v} {U : (Opens X)ᵒᵖ} :
    (presheafToTypes X T).obj U = ∀ x : unop U, T x :=
  rfl
#align Top.presheaf_to_Types_obj TopCat.presheafToTypes_obj

@[simp]
theorem presheafToTypes_map {T : X → Type v} {U V : (Opens X)ᵒᵖ} {i : U ⟶ V} {f} :
    (presheafToTypes X T).map i f = fun x => f (i.unop x) :=
  rfl
#align Top.presheaf_to_Types_map TopCat.presheafToTypes_map

-- We don't just define this in terms of `presheaf_to_Types`,
-- as it's helpful later to see (at a syntactic level) that `(presheaf_to_Type X T).obj U`
-- is a non-dependent function.
-- We don't use `@[simps]` to generate the projection lemmas here,
-- as it turns out to be useful to have `presheaf_to_Type_map`
-- written as an equality of functions (rather than being applied to some argument).
/-- The presheaf of functions on `X` with values in a type `T`.
There is no requirement that the functions are continuous, here.
-/
def presheafToType (T : Type v) : X.Presheaf (Type v)
    where
  obj U := unop U → T
  map U V i g := g ∘ i.unop
  map_id' U := by
    ext (g⟨x, hx⟩)
    rfl
  map_comp' U V W i j := rfl
#align Top.presheaf_to_Type TopCat.presheafToType

@[simp]
theorem presheafToType_obj {T : Type v} {U : (Opens X)ᵒᵖ} :
    (presheafToType X T).obj U = (unop U → T) :=
  rfl
#align Top.presheaf_to_Type_obj TopCat.presheafToType_obj

@[simp]
theorem presheafToType_map {T : Type v} {U V : (Opens X)ᵒᵖ} {i : U ⟶ V} {f} :
    (presheafToType X T).map i f = f ∘ i.unop :=
  rfl
#align Top.presheaf_to_Type_map TopCat.presheafToType_map

/-- The presheaf of continuous functions on `X` with values in fixed target topological space
`T`. -/
def presheafToTop (T : TopCat.{v}) : X.Presheaf (Type v) :=
  (Opens.toTop X).op ⋙ yoneda.obj T
#align Top.presheaf_to_Top TopCat.presheafToTop

@[simp]
theorem presheafToTop_obj (T : TopCat.{v}) (U : (Opens X)ᵒᵖ) :
    (presheafToTop X T).obj U = ((Opens.toTop X).obj (unop U) ⟶ T) :=
  rfl
#align Top.presheaf_to_Top_obj TopCat.presheafToTop_obj

-- TODO upgrade the result to TopCommRing?
/-- The (bundled) commutative ring of continuous functions from a topological space
to a topological commutative ring, with pointwise multiplication. -/
def continuousFunctions (X : TopCat.{v}ᵒᵖ) (R : TopCommRing.{v}) : CommRingCat.{v} :=
  CommRingCat.of (unop X ⟶ (forget₂ TopCommRing TopCat).obj R)
#align Top.continuous_functions TopCat.continuousFunctions

namespace ContinuousFunctions

/-- Pulling back functions into a topological ring along a continuous map is a ring homomorphism. -/
def pullback {X Y : TopCatᵒᵖ} (f : X ⟶ Y) (R : TopCommRing) :
    continuousFunctions X R ⟶ continuousFunctions Y R
    where
  toFun g := f.unop ≫ g
  map_one' := rfl
  map_zero' := rfl
  map_add' := by tidy
  map_mul' := by tidy
#align Top.continuous_functions.pullback TopCat.continuousFunctions.pullback

/-- A homomorphism of topological rings can be postcomposed with functions from a source space `X`;
this is a ring homomorphism (with respect to the pointwise ring operations on functions). -/
def map (X : TopCat.{u}ᵒᵖ) {R S : TopCommRing.{u}} (φ : R ⟶ S) :
    continuousFunctions X R ⟶ continuousFunctions X S
    where
  toFun g := g ≫ (forget₂ TopCommRing TopCat).map φ
  map_one' := by ext <;> exact φ.1.map_one
  map_zero' := by ext <;> exact φ.1.map_zero
  map_add' := by intros <;> ext <;> apply φ.1.map_add
  map_mul' := by intros <;> ext <;> apply φ.1.map_mul
#align Top.continuous_functions.map TopCat.continuousFunctions.map

end ContinuousFunctions

/-- An upgraded version of the Yoneda embedding, observing that the continuous maps
from `X : Top` to `R : TopCommRing` form a commutative ring, functorial in both `X` and `R`. -/
def commRingYoneda : TopCommRing.{u} ⥤ TopCat.{u}ᵒᵖ ⥤ CommRingCat.{u}
    where
  obj R :=
    { obj := fun X => continuousFunctions X R
      map := fun X Y f => continuousFunctions.pullback f R
      map_id' := fun X => by
        ext
        rfl
      map_comp' := fun X Y Z f g => rfl }
  map R S φ :=
    { app := fun X => continuousFunctions.map X φ
      naturality' := fun X Y f => rfl }
  map_id' X := by
    ext
    rfl
  map_comp' X Y Z f g := rfl
#align Top.CommRing_yoneda TopCat.commRingYoneda

/-- The presheaf (of commutative rings), consisting of functions on an open set `U ⊆ X` with
values in some topological commutative ring `T`.

For example, we could construct the presheaf of continuous complex valued functions of `X` as
```
presheaf_to_TopCommRing X (TopCommRing.of ℂ)
```
(this requires `import topology.instances.complex`).
-/
def presheafToTopCommRing (T : TopCommRing.{v}) : X.Presheaf CommRingCat.{v} :=
  (Opens.toTop X).op ⋙ commRingYoneda.obj T
#align Top.presheaf_to_TopCommRing TopCat.presheafToTopCommRing

end TopCat


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta, Andrew Yang
-/
import category_theory.limits.shapes.terminal
import category_theory.limits.shapes.pullbacks
import category_theory.limits.shapes.binary_products

/-!
# Constructing binary product from pullbacks and terminal object.

The product is the pullback over the terminal objects. In particular, if a category
has pullbacks and a terminal object, then it has binary products.

We also provide the dual.
-/

universes v u

open category_theory category_theory.category category_theory.limits

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

/-- The pullback over the terminal object is the product -/
def is_product_of_is_terminal_is_pullback {W X Y Z : C} (f : X ⟶ Z) (g : Y ⟶ Z) (h : W ⟶ X)
  (k : W ⟶ Y) (H₁ : is_terminal Z)
  (H₂ : is_limit (pullback_cone.mk _ _ (show h ≫ f = k ≫ g, from H₁.hom_ext _ _))) :
  is_limit (binary_fan.mk h k) :=
{ lift := λ c, H₂.lift (pullback_cone.mk
    (c.π.app walking_pair.left) (c.π.app walking_pair.right) (H₁.hom_ext _ _)),
  fac' := λ c j,
  begin
    convert H₂.fac (pullback_cone.mk
      (c.π.app walking_pair.left) (c.π.app walking_pair.right) (H₁.hom_ext _ _)) (some j) using 1,
    cases j; refl
  end,
  uniq' := λ c m hm,
  begin
    apply pullback_cone.is_limit.hom_ext H₂,
    { exact (hm walking_pair.left).trans (H₂.fac (pullback_cone.mk (c.π.app walking_pair.left)
        (c.π.app walking_pair.right) (H₁.hom_ext _ _)) walking_cospan.left).symm },
    { exact (hm walking_pair.right).trans (H₂.fac (pullback_cone.mk (c.π.app walking_pair.left)
        (c.π.app walking_pair.right) (H₁.hom_ext _ _)) walking_cospan.right).symm },
  end }

/-- The product is the pullback over the terminal object. -/
def is_pullback_of_is_terminal_is_product {W X Y Z : C} (f : X ⟶ Z) (g : Y ⟶ Z) (h : W ⟶ X)
  (k : W ⟶ Y) (H₁ : is_terminal Z)
  (H₂ : is_limit (binary_fan.mk h k)) :
  is_limit (pullback_cone.mk _ _ (show h ≫ f = k ≫ g, from H₁.hom_ext _ _)) :=
begin
  apply pullback_cone.is_limit_aux',
  intro s,
  use H₂.lift (binary_fan.mk s.fst s.snd),
  use H₂.fac (binary_fan.mk s.fst s.snd) walking_pair.left,
  use H₂.fac (binary_fan.mk s.fst s.snd) walking_pair.right,
  intros m h₁ h₂,
  apply H₂.hom_ext,
  rintro ⟨⟩,
  { exact h₁.trans (H₂.fac (binary_fan.mk s.fst s.snd) walking_pair.left).symm },
  { exact h₂.trans (H₂.fac (binary_fan.mk s.fst s.snd) walking_pair.right).symm }
end

variable (C)

/-- Any category with pullbacks and terminal object has binary products. -/
-- This is not an instance, as it is not always how one wants to construct binary products!
lemma has_binary_products_of_terminal_and_pullbacks
  [has_terminal C] [has_pullbacks C] :
  has_binary_products C :=
{ has_limit := λ F, has_limit.mk
  { cone :=
    { X := pullback (terminal.from (F.obj walking_pair.left))
                    (terminal.from (F.obj walking_pair.right)),
      π := discrete.nat_trans (λ x, walking_pair.cases_on x pullback.fst pullback.snd)},
    is_limit :=
    { lift := λ c, pullback.lift ((c.π).app walking_pair.left)
                                  ((c.π).app walking_pair.right)
                                  (subsingleton.elim _ _),
      fac' := λ s c, walking_pair.cases_on c (limit.lift_π _ _) (limit.lift_π _ _),
      uniq' := λ s m J,
                begin
                  rw [←J, ←J],
                  ext;
                  rw limit.lift_π;
                  refl
                end } } }

variable {C}

/-- The pushout under the initial object is the coproduct -/
def is_coproduct_of_is_initial_is_pushout {W X Y Z : C} (f : X ⟶ Z) (g : Y ⟶ Z) (h : W ⟶ X)
  (k : W ⟶ Y) (H₁ : is_initial W)
  (H₂ : is_colimit (pushout_cocone.mk _ _ (show h ≫ f = k ≫ g, from H₁.hom_ext _ _))) :
  is_colimit (binary_cofan.mk f g) :=
{ desc := λ c, H₂.desc (pushout_cocone.mk
    (c.ι.app walking_pair.left) (c.ι.app walking_pair.right) (H₁.hom_ext _ _)),
  fac' := λ c j,
  begin
    convert H₂.fac (pushout_cocone.mk
      (c.ι.app walking_pair.left) (c.ι.app walking_pair.right) (H₁.hom_ext _ _)) (some j) using 1,
    cases j; refl
  end,
  uniq' := λ c m hm,
  begin
    apply pushout_cocone.is_colimit.hom_ext H₂,
    { exact (hm walking_pair.left).trans (H₂.fac (pushout_cocone.mk (c.ι.app walking_pair.left)
        (c.ι.app walking_pair.right) (H₁.hom_ext _ _)) walking_cospan.left).symm },
    { exact (hm walking_pair.right).trans (H₂.fac (pushout_cocone.mk (c.ι.app walking_pair.left)
        (c.ι.app walking_pair.right) (H₁.hom_ext _ _)) walking_cospan.right).symm },
  end }

/-- The coproduct is the pushout under the initial object. -/
def is_pushout_of_is_initial_is_coproduct {W X Y Z : C} (f : X ⟶ Z) (g : Y ⟶ Z) (h : W ⟶ X)
  (k : W ⟶ Y) (H₁ : is_terminal Z)
  (H₂ : is_limit (binary_fan.mk h k)) :
  is_limit (pullback_cone.mk _ _ (show h ≫ f = k ≫ g, from H₁.hom_ext _ _)) :=
begin
  apply pullback_cone.is_limit_aux',
  intro s,
  use H₂.lift (binary_fan.mk s.fst s.snd),
  use H₂.fac (binary_fan.mk s.fst s.snd) walking_pair.left,
  use H₂.fac (binary_fan.mk s.fst s.snd) walking_pair.right,
  intros m h₁ h₂,
  apply H₂.hom_ext,
  rintro ⟨⟩,
  { exact h₁.trans (H₂.fac (binary_fan.mk s.fst s.snd) walking_pair.left).symm },
  { exact h₂.trans (H₂.fac (binary_fan.mk s.fst s.snd) walking_pair.right).symm }
end

variable (C)

/-- Any category with pushouts and initial object has binary coproducts. -/
-- This is not an instance, as it is not always how one wants to construct binary coproducts!
lemma has_binary_coproducts_of_initial_and_pushouts
  [has_initial C] [has_pushouts C] :
  has_binary_coproducts C :=
{ has_colimit := λ F, has_colimit.mk
  { cocone :=
    { X := pushout (initial.to (F.obj walking_pair.left))
                    (initial.to (F.obj walking_pair.right)),
      ι := discrete.nat_trans (λ x, walking_pair.cases_on x pushout.inl pushout.inr)},
    is_colimit :=
    { desc := λ c, pushout.desc (c.ι.app walking_pair.left)
                                (c.ι.app walking_pair.right)
                                (subsingleton.elim _ _),
      fac' := λ s c, walking_pair.cases_on c (colimit.ι_desc _ _) (colimit.ι_desc _ _),
      uniq' := λ s m J,
                begin
                  rw [←J, ←J],
                  ext;
                  rw colimit.ι_desc;
                  refl
                end } } }


/-
Copyright (c) 2022 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import algebraic_geometry.properties

/-!
# Function field of integral schemes

We define the function field of an irreducible scheme as the stalk of the generic point.
This is a field when the scheme is integral.

## Main definition
* `algebraic_geometry.Scheme.function_field`: The function field of an integral scheme.
* `algebraic_geometry.germ_to_function_field`: The canonical map from a component into the function
  field. This map is injective.
-/

universes u v

open topological_space opposite category_theory category_theory.limits Top

namespace algebraic_geometry

variable (X : Scheme)

/-- The function field of an irreducible scheme is the local ring at its generic point.
Despite the name, this is a field only when the scheme is integral. -/
noncomputable
abbreviation Scheme.function_field [irreducible_space X.carrier] : CommRing :=
X.presheaf.stalk (generic_point X.carrier)

/-- The restriction map from a component to the function field. -/
noncomputable
abbreviation Scheme.germ_to_function_field [irreducible_space X.carrier] (U : opens X.carrier)
  [h : nonempty U] : X.presheaf.obj (op U) ⟶ X.function_field :=
X.presheaf.germ ⟨generic_point X.carrier,
  ((generic_point_spec X.carrier).mem_open_set_iff U.prop).mpr (by simpa using h)⟩

noncomputable
instance [irreducible_space X.carrier] (U : opens X.carrier) [nonempty U] :
  algebra (X.presheaf.obj (op U)) X.function_field :=
(X.germ_to_function_field U).to_algebra

noncomputable
instance [is_integral X] : field X.function_field :=
begin
  apply field_of_is_unit_or_eq_zero,
  intro a,
  obtain ⟨U, m, s, rfl⟩ := Top.presheaf.germ_exist _ _ a,
  rw [or_iff_not_imp_right, ← (X.presheaf.germ ⟨_, m⟩).map_zero],
  intro ha,
  replace ha := ne_of_apply_ne _ ha,
  have hs : generic_point X.carrier ∈ RingedSpace.basic_open _ s,
  { rw [← opens.mem_coe, (generic_point_spec X.carrier).mem_open_set_iff, set.top_eq_univ,
      set.univ_inter, ← set.ne_empty_iff_nonempty, ne.def, ← opens.coe_bot,
      subtype.coe_injective.eq_iff, ← opens.empty_eq],
    erw basic_open_eq_bot_iff,
    exacts [ha, (RingedSpace.basic_open _ _).prop] },
  have := (X.presheaf.germ ⟨_, hs⟩).is_unit_map (RingedSpace.is_unit_res_basic_open _ s),
  rwa Top.presheaf.germ_res_apply at this
end

lemma germ_injective_of_is_integral [is_integral X] {U : opens X.carrier} (x : U) :
  function.injective (X.presheaf.germ x) :=
begin
  rw ring_hom.injective_iff,
  intros y hy,
  rw ← (X.presheaf.germ x).map_zero at hy,
  obtain ⟨W, hW, iU, iV, e⟩ := X.presheaf.germ_eq _ x.prop x.prop _ _ hy,
  cases (show iU = iV, from subsingleton.elim _ _),
  haveI : nonempty W := ⟨⟨_, hW⟩⟩,
  exact map_injective_of_is_integral X iU e
end

lemma Scheme.germ_to_function_field_injective [is_integral X] (U : opens X.carrier)
  [nonempty U] : function.injective (X.germ_to_function_field U) :=
germ_injective_of_is_integral _ _

lemma generic_point_eq_of_is_open_immersion {X Y : Scheme} (f : X ⟶ Y) [H : is_open_immersion f]
  [hX : irreducible_space X.carrier] [irreducible_space Y.carrier] :
    f.1.base (generic_point X.carrier : _) = (generic_point Y.carrier : _) :=
begin
  apply ((generic_point_spec _).eq _).symm,
  show t0_space Y.carrier, by apply_instance,
  convert (generic_point_spec X.carrier).image (show continuous f.1.base, by continuity),
  symmetry,
  rw [eq_top_iff, set.top_eq_univ, set.top_eq_univ],
  convert subset_closure_inter_of_is_preirreducible_of_is_open _ H.base_open.open_range _,
  rw [set.univ_inter, set.image_univ],
  apply_with preirreducible_space.is_preirreducible_univ { instances := ff },
  show preirreducible_space Y.carrier, by apply_instance,
  exact ⟨_, trivial, set.mem_range_self hX.2.some⟩,
end

noncomputable
instance stalk_function_field_algebra [irreducible_space X.carrier] (x : X.carrier) :
  algebra (X.presheaf.stalk x) X.function_field :=
begin
  apply ring_hom.to_algebra,
  exact X.presheaf.stalk_specializes ((generic_point_spec X.carrier).specializes trivial)
end

instance function_field_is_scalar_tower [irreducible_space X.carrier] (U : opens X.carrier) (x : U)
  [nonempty U] :
  is_scalar_tower (X.presheaf.obj $ op U) (X.presheaf.stalk x) X.function_field :=
begin
  apply is_scalar_tower.of_algebra_map_eq',
  simp_rw [ring_hom.algebra_map_to_algebra],
  change _ = X.presheaf.germ x ≫ _,
  rw X.presheaf.germ_stalk_specializes,
  refl
end

noncomputable
instance (R : CommRing) [is_domain R] : algebra R (Scheme.Spec.obj $ op R).function_field :=
begin
  apply ring_hom.to_algebra,
  exact structure_sheaf.to_stalk R _,
end

@[simp] lemma generic_point_eq_bot_of_affine (R : CommRing) [is_domain R] :
  generic_point (Scheme.Spec.obj $ op R).carrier = (⟨0, ideal.bot_prime⟩ : prime_spectrum R) :=
begin
  apply (generic_point_spec (Scheme.Spec.obj $ op R).carrier).eq,
  simp [is_generic_point_def, ← prime_spectrum.zero_locus_vanishing_ideal_eq_closure]
end

instance function_field_is_fraction_ring_of_affine (R : CommRing.{u}) [is_domain R] :
  is_fraction_ring R (Scheme.Spec.obj $ op R).function_field :=
begin
  convert structure_sheaf.is_localization.to_stalk R _,
  delta is_fraction_ring is_localization.at_prime,
  congr' 1,
  rw generic_point_eq_bot_of_affine,
  ext,
  exact mem_non_zero_divisors_iff_ne_zero
end

instance {X : Scheme} [is_integral X] {U : opens X.carrier} [hU : nonempty U] :
  is_integral (X.restrict U.open_embedding) :=
begin
  haveI : nonempty (X.restrict U.open_embedding).carrier := hU,
  exact is_integral_of_open_immersion (X.of_restrict U.open_embedding)
end

lemma is_affine_open.prime_ideal_of_generic_point {X : Scheme} [is_integral X]
  {U : opens X.carrier} (hU : is_affine_open U) [h : nonempty U] :
  hU.prime_ideal_of ⟨generic_point X.carrier,
    ((generic_point_spec X.carrier).mem_open_set_iff U.prop).mpr (by simpa using h)⟩ =
  generic_point (Scheme.Spec.obj $ op $ X.presheaf.obj $ op U).carrier :=
begin
  haveI : is_affine _ := hU,
  have e : U.open_embedding.is_open_map.functor.obj ⊤ = U,
  { ext1, exact set.image_univ.trans subtype.range_coe },
  delta is_affine_open.prime_ideal_of,
  rw ← Scheme.comp_val_base_apply,
  convert (generic_point_eq_of_is_open_immersion ((X.restrict U.open_embedding).iso_Spec.hom ≫
    Scheme.Spec.map (X.presheaf.map (eq_to_hom e).op).op)),
  ext1,
  exact (generic_point_eq_of_is_open_immersion (X.of_restrict U.open_embedding)).symm
end

lemma function_field_is_fraction_ring_of_is_affine_open [is_integral X] (U : opens X.carrier)
  (hU : is_affine_open U) [hU' : nonempty U] :
  is_fraction_ring (X.presheaf.obj $ op U) X.function_field :=
begin
  haveI : is_affine _ := hU,
  haveI : nonempty (X.restrict U.open_embedding).carrier := hU',
  haveI : is_integral (X.restrict U.open_embedding) := @@is_integral_of_is_affine_is_domain _ _ _
    (by { dsimp, rw opens.open_embedding_obj_top, apply_instance }),
  have e : U.open_embedding.is_open_map.functor.obj ⊤ = U,
  { ext1, exact set.image_univ.trans subtype.range_coe },
  delta is_fraction_ring Scheme.function_field,
  convert hU.is_localization_stalk ⟨generic_point X.carrier, _⟩ using 1,
  rw [hU.prime_ideal_of_generic_point, generic_point_eq_bot_of_affine],
  ext, exact mem_non_zero_divisors_iff_ne_zero
end

instance (x : X.carrier) : is_affine (X.affine_cover.obj x) :=
algebraic_geometry.Spec_is_affine _

instance [h : is_integral X] (x : X.carrier) :
  is_fraction_ring (X.presheaf.stalk x) X.function_field :=
begin
  let U : opens X.carrier := ⟨set.range (X.affine_cover.map x).1.base,
    PresheafedSpace.is_open_immersion.base_open.open_range⟩,
  haveI : nonempty U := ⟨⟨_, X.affine_cover.covers x⟩⟩,
  have hU : is_affine_open U := range_is_affine_open_of_open_immersion (X.affine_cover.map x),
  exact @@is_fraction_ring.is_fraction_ring_of_is_domain_of_is_localization _ _ _ _ _ _ _ _ _ _ _
    (hU.is_localization_stalk ⟨x, X.affine_cover.covers x⟩)
      (function_field_is_fraction_ring_of_is_affine_open X U hU)
end

end algebraic_geometry


/-theorem interesting: 1 = 1 := rfl. -/
#check ¬ (1 = 0)
#check ∀ T: Type, ∀ t: T, t = t
lemma zeqz: 0 = 0 := rfl
lemma oeqo: 1 = 1 := rfl

theorem helloTheorem: "hello" = "hello" := rfl
theorem twooneone: 2 = 1 + 1 := rfl

theorem tthof: 2 + 3 = 1 + 4 := rfl
theorem holeqhl: "Hello " ++ "Logic!" = "Hello Logic!" := rfl

theorem zeqz_and_oeqo: 0 = 0 ∧ 1 = 1 := and.intro zeqz oeqo
theorem haha: 0 = 0 ∧ 1 = 1 := and.intro rfl rfl

theorem negation: tt = ¬ ff := rfl
variable a: bool
#check ¬ (a = ¬ a)

lemma ft: 5 = 1 + 4 := rfl
lemma st: "S" ++ "trike" = "Strike" := rfl

theorem ftst: 5 = 1 + 4 ∧ "S" ++ "trike" = "Strike" := and.intro ft st

#check rfl

constant T: Type
variable t: T

#check "Heoo"

theorem eee: t = t := rfl

#check (eq.refl tt)
#check (eq.refl "Hello")

constant a: Prop


/-
Copyright (c) 2021 Yaël Dillies, Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies, Bhavik Mehta
-/
import combinatorics.simplicial_complex.convex_independence
import combinatorics.simplicial_complex.glued

open set affine
namespace poly
variables {m n : ℕ} {E : Type*} [normed_group E] [normed_space ℝ E] {S : simplicial_complex E}
  {x : E} {X Y : finset E} {C : set E} {A : set (finset E)}

/--
A polytope of dimension `n` in `R^m` is a subset for which there exists a simplicial complex which
is pure of dimension `n` and has the same underlying space.
-/
@[ext] structure polytope (E : Type*) [normed_group E] [normed_space ℝ E] :=
(space : set E)
(realisable : ∃ {S : simplicial_complex E}, S.pure ∧ space = S.space)

variables {p : polytope E}

/--
A constructor for polytopes from an underlying simplicial complex
-/
def simplicial_complex.to_polytope (hS : S.pure) :
  polytope E :=
{ space := S.space,
  realisable := ⟨S, hS, rfl⟩}

noncomputable def polytope.to_simplicial_complex (p : polytope E) :
  simplicial_complex E := classical.some p.realisable

lemma pure_polytope_realisation :
  p.to_simplicial_complex.pure :=
(classical.some_spec p.realisable).1

lemma polytope_space_eq_realisation_space :
  p.space = p.to_simplicial_complex.space :=
(classical.some_spec p.realisable).2

def polytope.vertices (p : polytope E) :
  set E :=
⋂ (S : simplicial_complex E) (H : p.space = S.space), S.vertices

lemma vertices_subset_space :
  p.vertices ⊆ p.space :=
begin
  rintro x hx,
  have hx' : x ∈ p.to_simplicial_complex.vertices,
  {
    --apply bInter_subset_of_mem (polytope_space_eq_realisation_space :
     -- p.to_simplicial_complex ∈ set_of (λ q : simplicial_complex E, p.space = q.space)),
     sorry
  },
  rw polytope_space_eq_realisation_space,
  exact mem_space_iff.2 ⟨{x}, hx', by simp⟩,
end

def polytope.edges (p : polytope E) :
  set (finset E) :=
⋂ (S : simplicial_complex E) (H : p.space = S.space), {X | X ∈ S.faces ∧ X.card = 2}

--def polytope.faces {n : ℕ} (P : polytope E) : set (finset E) :=
--  P.realisation.boundary.faces

noncomputable def polytope.triangulation (p : polytope E) :
  simplicial_complex E :=
begin
  classical,
  exact
  if p.space.nonempty ∧ convex p.space then begin
    have hpnonempty : p.space.nonempty := sorry,
    let x := classical.some hpnonempty,
    have hx := classical.some_spec hpnonempty,
    sorry
  end else p.to_simplicial_complex,
end

/- Every convex polytope can be realised by a simplicial complex with the same vertices-/
lemma polytope.triangulable_of_convex (hp : convex p.space) :
  p.triangulation.vertices = p.vertices :=
begin
  cases p.space.eq_empty_or_nonempty with hpempty hpnonempty,
  {
    /-rw empty_space_of_empty_simplicial_complex,
    use hpempty,
    rintro X (hX : {X} ∈ {∅}),
    simp at hX,
    exfalso,
    exact hX,-/
    sorry
  },
  obtain ⟨x, hx⟩ := hpnonempty,
  --consider the boundary of some realisation of P and remove it x,
  --have := P.realisation.boundary.erasure {x},
  --then add it back by taking the pyramid of this monster with x
  sorry
end

/-lemma convex_polytope_iff_intersection_of_half_spaces {space : set E} {n : ℕ} :
  ∃ {S : simplicial_complex E}, S.pure ∧ space = S.space ↔ ∃ half spaces and stuff-/

@[ext] structure polytopial_complex (E : Type*) [normed_group E] [normed_space ℝ E] :=
(faces : set (finset E))
(indep : ∀ {X}, X ∈ faces → convex_independent (λ p, p : (X : set E) → E))
(down_closed : ∀ {X Y}, X ∈ faces → Y ⊆ X → (Y : set E) = (X : set E) ∩ affine_span ℝ (Y : set E)
  → Y ∈ faces)
(disjoint : ∀ {X Y}, X ∈ faces → Y ∈ faces →
  convex_hull ↑X ∩ convex_hull ↑Y ⊆ convex_hull (X ∩ Y : set E))

variables {P : polytopial_complex E}

def polytopial_complex.polytopes (P : polytopial_complex E) :
  set (polytope E) :=
  sorry

def polytopial_complex.space (P : polytopial_complex E) :
  set E :=
⋃ (p ∈ P.polytopes), (p : polytope E).space

lemma mem_space_iff :
  x ∈ P.space ↔ ∃ (p : polytope E), p ∈ P.polytopes ∧ x ∈ p.space :=
begin
  unfold polytopial_complex.space,
  simp,
end

def simplicial_complex.to_polytopial_complex (S : simplicial_complex E) :
  polytopial_complex E :=
{ faces := S.faces,
  indep := λ X hX, (S.indep hX).convex_independent,
  down_closed := λ X Y hX hYX hY, S.down_closed hX hYX,
  disjoint := S.disjoint }

noncomputable def polytope.to_polytopial_complex (p : polytope E) :
  polytopial_complex E :=
simplicial_complex.to_polytopial_complex p.to_simplicial_complex
--@Bhavik I can't use dot notation here because of namespace problems. Do you have a fix?

def polytopial_complex.coplanarless (P : polytopial_complex E) :
  Prop :=
∀ X Y ∈ P.faces, adjacent X Y → (X : set E) ⊆ affine_span ℝ (Y : set E) →
  X.card = finite_dimensional.finrank ℝ E + 1

def polytopial_complex.to_simplicial_complex (P : polytopial_complex E) :
  simplicial_complex E :=
{ faces := ⋃ (p ∈ P.polytopes), (p : polytope E).to_simplicial_complex.faces,
  indep := begin
    rintro X hX,
    rw mem_bUnion_iff at hX,
    obtain ⟨p, hp, hX⟩ := hX,
    exact p.to_simplicial_complex.indep hX,
  end,
  down_closed := begin
    rintro X Y hX hYX,
    rw mem_bUnion_iff at ⊢ hX,
    obtain ⟨p, hp, hX⟩ := hX,
    exact ⟨p, hp, p.to_simplicial_complex.down_closed hX hYX⟩,
  end,
  disjoint := begin
    rintro X Y hX hY,
    rw mem_bUnion_iff at hX hY,
    obtain ⟨p, hp, hX⟩ := hX,
    obtain ⟨q, hq, hY⟩ := hY,
    sorry --this is wrong because faces of adjacent polytopes aren't required to glue nicely
    -- causes problem as soon as their shared faces aren't simplices
  end }

lemma polytopial_space_iff_simplicial_space [finite_dimensional ℝ E] :
  (∃ (S : simplicial_complex E), S.space = C) ↔
  ∃ (P : polytopial_complex E), P.space = C :=
begin
  split,
  {
    rintro ⟨S, hS⟩,
    sorry
  },
  sorry
end

end poly


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel, Scott Morrison
-/
import algebra.group.ext
import category_theory.simple
import category_theory.linear
import category_theory.endomorphism
import algebra.algebra.spectrum

/-!
# Schur's lemma
We first prove the part of Schur's Lemma that holds in any preadditive category with kernels,
that any nonzero morphism between simple objects
is an isomorphism.

Second, we prove Schur's lemma for `𝕜`-linear categories with finite dimensional hom spaces,
over an algebraically closed field `𝕜`:
the hom space `X ⟶ Y` between simple objects `X` and `Y` is at most one dimensional,
and is 1-dimensional iff `X` and `Y` are isomorphic.

## Future work
It might be nice to provide a `division_ring` instance on `End X` when `X` is simple.
This is an easy consequence of the results here,
but may take some care setting up usable instances.
-/

namespace category_theory

open category_theory.limits

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

/--
The part of **Schur's lemma** that holds in any preadditive category with kernels:
that a nonzero morphism between simple objects is an isomorphism.
-/
lemma is_iso_of_hom_simple [has_kernels C] {X Y : C} [simple X] [simple Y] {f : X ⟶ Y} (w : f ≠ 0) :
  is_iso f :=
begin
  haveI : mono f := preadditive.mono_of_kernel_zero (kernel_zero_of_nonzero_from_simple w),
  exact is_iso_of_mono_of_nonzero w
end

/--
As a corollary of Schur's lemma for preadditive categories,
any morphism between simple objects is (exclusively) either an isomorphism or zero.
-/
lemma is_iso_iff_nonzero [has_kernels C] {X Y : C} [simple.{v} X] [simple.{v} Y] (f : X ⟶ Y) :
  is_iso.{v} f ↔ f ≠ 0 :=
⟨λ I,
  begin
    introI h,
    apply id_nonzero X,
    simp only [←is_iso.hom_inv_id f, h, zero_comp],
  end,
  λ w, is_iso_of_hom_simple w⟩

open finite_dimensional

variables (𝕜 : Type*) [field 𝕜]

/--
Part of **Schur's lemma** for `𝕜`-linear categories:
the hom space between two non-isomorphic simple objects is 0-dimensional.
-/
lemma finrank_hom_simple_simple_eq_zero_of_not_iso
  [has_kernels C] [linear 𝕜 C] {X Y : C} [simple.{v} X] [simple.{v} Y]
  (h : (X ≅ Y) → false):
  finrank 𝕜 (X ⟶ Y) = 0 :=
begin
  haveI := subsingleton_of_forall_eq (0 : X ⟶ Y) (λ f, begin
    have p := not_congr (is_iso_iff_nonzero f),
    simp only [not_not, ne.def] at p,
    refine p.mp (λ _, by exactI h (as_iso f)),
  end),
  exact finrank_zero_of_subsingleton,
end

variables [is_alg_closed 𝕜] [linear 𝕜 C]

-- In the proof below we have some difficulty using `I : finite_dimensional 𝕜 (X ⟶ X)`
-- where we need a `finite_dimensional 𝕜 (End X)`.
-- These are definitionally equal, but without eta reduction Lean can't see this.
-- To get around this, we use `convert I`,
-- then check the various instances agree field-by-field,
-- using `ext` equipped with the following extra lemmas:
local attribute [ext] module distrib_mul_action mul_action has_scalar

/--
An auxiliary lemma for Schur's lemma.

If `X ⟶ X` is finite dimensional, and every nonzero endomorphism is invertible,
then `X ⟶ X` is 1-dimensional.
-/
-- We prove this with the explicit `is_iso_iff_nonzero` assumption,
-- rather than just `[simple X]`, as this form is useful for
-- Müger's formulation of semisimplicity.
lemma finrank_endomorphism_eq_one
  {X : C} (is_iso_iff_nonzero : ∀ f : X ⟶ X, is_iso f ↔ f ≠ 0)
  [I : finite_dimensional 𝕜 (X ⟶ X)] :
  finrank 𝕜 (X ⟶ X) = 1 :=
begin
  have id_nonzero := (is_iso_iff_nonzero (𝟙 X)).mp (by apply_instance),
  apply finrank_eq_one (𝟙 X),
  { exact id_nonzero, },
  { intro f,
    haveI : nontrivial (End X) := nontrivial_of_ne _ _ id_nonzero,
    obtain ⟨c, nu⟩ := @spectrum.nonempty_of_is_alg_closed_of_finite_dimensional 𝕜 (End X) _ _ _ _ _
      (by { convert I, ext, refl, ext, refl, }) (End.of f),
    use c,
    rw [spectrum.mem_iff, is_unit.sub_iff, is_unit_iff_is_iso, is_iso_iff_nonzero, ne.def,
      not_not, sub_eq_zero, algebra.algebra_map_eq_smul_one] at nu,
    exact nu.symm, },
end

variables [has_kernels C]

/--
**Schur's lemma** for endomorphisms in `𝕜`-linear categories.
-/
lemma finrank_endomorphism_simple_eq_one
  (X : C) [simple.{v} X] [I : finite_dimensional 𝕜 (X ⟶ X)] :
  finrank 𝕜 (X ⟶ X) = 1 :=
finrank_endomorphism_eq_one 𝕜 is_iso_iff_nonzero

lemma endomorphism_simple_eq_smul_id
  {X : C} [simple.{v} X] [I : finite_dimensional 𝕜 (X ⟶ X)] (f : X ⟶ X) :
  ∃ c : 𝕜, c • 𝟙 X = f :=
(finrank_eq_one_iff_of_nonzero' (𝟙 X) (id_nonzero X)).mp (finrank_endomorphism_simple_eq_one 𝕜 X) f

/--
**Schur's lemma** for `𝕜`-linear categories:
if hom spaces are finite dimensional, then the hom space between simples is at most 1-dimensional.

See `finrank_hom_simple_simple_eq_one_iff` and `finrank_hom_simple_simple_eq_zero_iff` below
for the refinements when we know whether or not the simples are isomorphic.
-/
-- We don't really need `[∀ X Y : C, finite_dimensional 𝕜 (X ⟶ Y)]` here,
-- just at least one of `[finite_dimensional 𝕜 (X ⟶ X)]` or `[finite_dimensional 𝕜 (Y ⟶ Y)]`.
lemma finrank_hom_simple_simple_le_one
  (X Y : C) [∀ X Y : C, finite_dimensional 𝕜 (X ⟶ Y)] [simple.{v} X] [simple.{v} Y] :
  finrank 𝕜 (X ⟶ Y) ≤ 1 :=
begin
  cases subsingleton_or_nontrivial (X ⟶ Y) with h,
  { resetI,
    convert zero_le_one,
    exact finrank_zero_of_subsingleton, },
  { obtain ⟨f, nz⟩ := (nontrivial_iff_exists_ne 0).mp h,
    haveI fi := (is_iso_iff_nonzero f).mpr nz,
    apply finrank_le_one f,
    intro g,
    obtain ⟨c, w⟩ := endomorphism_simple_eq_smul_id 𝕜 (g ≫ inv f),
    exact ⟨c, by simpa using w =≫ f⟩, },
end

lemma finrank_hom_simple_simple_eq_one_iff
  (X Y : C) [∀ X Y : C, finite_dimensional 𝕜 (X ⟶ Y)] [simple.{v} X] [simple.{v} Y] :
  finrank 𝕜 (X ⟶ Y) = 1 ↔ nonempty (X ≅ Y) :=
begin
  fsplit,
  { intro h,
    rw finrank_eq_one_iff' at h,
    obtain ⟨f, nz, -⟩ := h,
    rw ←is_iso_iff_nonzero at nz,
    exactI ⟨as_iso f⟩, },
  { rintro ⟨f⟩,
    have le_one := finrank_hom_simple_simple_le_one 𝕜 X Y,
    have zero_lt : 0 < finrank 𝕜 (X ⟶ Y) :=
      finrank_pos_iff_exists_ne_zero.mpr ⟨f.hom, (is_iso_iff_nonzero f.hom).mp infer_instance⟩,
    linarith, }
end

lemma finrank_hom_simple_simple_eq_zero_iff
  (X Y : C) [∀ X Y : C, finite_dimensional 𝕜 (X ⟶ Y)] [simple.{v} X] [simple.{v} Y] :
  finrank 𝕜 (X ⟶ Y) = 0 ↔ is_empty (X ≅ Y) :=
begin
  rw [← not_nonempty_iff, ← not_congr (finrank_hom_simple_simple_eq_one_iff 𝕜 X Y)],
  refine ⟨λ h, by { rw h, simp, }, λ h, _⟩,
  have := finrank_hom_simple_simple_le_one 𝕜 X Y,
  interval_cases finrank 𝕜 (X ⟶ Y) with h',
  { exact h', },
  { exact false.elim (h h'), },
end

end category_theory


/-
Copyright (c) 2021 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import algebra.group.inj_surj
import data.list.big_operators
import data.list.range
import group_theory.group_action.defs
import group_theory.submonoid.basic
import data.set_like.basic
import data.sigma.basic

/-!
# Additively-graded multiplicative structures

This module provides a set of heterogeneous typeclasses for defining a multiplicative structure
over the sigma type `graded_monoid A` such that `(*) : A i → A j → A (i + j)`; that is to say, `A`
forms an additively-graded monoid. The typeclasses are:

* `graded_monoid.ghas_one A`
* `graded_monoid.ghas_mul A`
* `graded_monoid.gmonoid A`
* `graded_monoid.gcomm_monoid A`

With the `sigma_graded` locale open, these respectively imbue:

* `has_one (graded_monoid A)`
* `has_mul (graded_monoid A)`
* `monoid (graded_monoid A)`
* `comm_monoid (graded_monoid A)`

the base type `A 0` with:

* `graded_monoid.grade_zero.has_one`
* `graded_monoid.grade_zero.has_mul`
* `graded_monoid.grade_zero.monoid`
* `graded_monoid.grade_zero.comm_monoid`

and the `i`th grade `A i` with `A 0`-actions (`•`) defined as left-multiplication:

* (nothing)
* `graded_monoid.grade_zero.has_smul (A 0)`
* `graded_monoid.grade_zero.mul_action (A 0)`
* (nothing)

For now, these typeclasses are primarily used in the construction of `direct_sum.ring` and the rest
of that file.

## Dependent graded products

This also introduces `list.dprod`, which takes the (possibly non-commutative) product of a list
of graded elements of type `A i`. This definition primarily exist to allow `graded_monoid.mk`
and `direct_sum.of` to be pulled outside a product, such as in `graded_monoid.mk_list_dprod` and
`direct_sum.of_list_dprod`.

## Internally graded monoids

In addition to the above typeclasses, in the most frequent case when `A` is an indexed collection of
`set_like` subobjects (such as `add_submonoid`s, `add_subgroup`s, or `submodule`s), this file
provides the `Prop` typeclasses:

* `set_like.has_graded_one A` (which provides the obvious `graded_monoid.ghas_one A` instance)
* `set_like.has_graded_mul A` (which provides the obvious `graded_monoid.ghas_mul A` instance)
* `set_like.graded_monoid A` (which provides the obvious `graded_monoid.gmonoid A` and
  `graded_monoid.gcomm_monoid A` instances)
* `set_like.is_homogeneous A` (which says that `a` is homogeneous iff `a ∈ A i` for some `i : ι`)

Strictly this last class is unecessary as it has no fields not present in its parents, but it is
included for convenience. Note that there is no need for `graded_ring` or similar, as all the
information it would contain is already supplied by `graded_monoid` when `A` is a collection
of additively-closed set_like objects such as `submodule`s. These constructions are explored in
`algebra.direct_sum.internal`.

This file also contains the definition of `set_like.homogeneous_submonoid A`, which is, as the name
suggests, the submonoid consisting of all the homogeneous elements.

## tags

graded monoid
-/

set_option old_structure_cmd true

variables {ι : Type*}

/-- A type alias of sigma types for graded monoids. -/
def graded_monoid (A : ι → Type*) := sigma A

namespace graded_monoid

instance {A : ι → Type*} [inhabited ι] [inhabited (A default)]: inhabited (graded_monoid A) :=
sigma.inhabited

/-- Construct an element of a graded monoid. -/
def mk {A : ι → Type*} : Π i, A i → graded_monoid A := sigma.mk

/-! ### Typeclasses -/
section defs

variables (A : ι → Type*)

/-- A graded version of `has_one`, which must be of grade 0. -/
class ghas_one [has_zero ι] :=
(one : A 0)

/-- `ghas_one` implies `has_one (graded_monoid A)` -/
instance ghas_one.to_has_one [has_zero ι] [ghas_one A] : has_one (graded_monoid A) :=
⟨⟨_, ghas_one.one⟩⟩

/-- A graded version of `has_mul`. Multiplication combines grades additively, like
`add_monoid_algebra`. -/
class ghas_mul [has_add ι] :=
(mul {i j} : A i → A j → A (i + j))

/-- `ghas_mul` implies `has_mul (graded_monoid A)`. -/
instance ghas_mul.to_has_mul [has_add ι] [ghas_mul A] :
  has_mul (graded_monoid A) :=
⟨λ (x y : graded_monoid A), ⟨_, ghas_mul.mul x.snd y.snd⟩⟩

lemma mk_mul_mk [has_add ι] [ghas_mul A] {i j} (a : A i) (b : A j) :
  mk i a * mk j b = mk (i + j) (ghas_mul.mul a b) :=
rfl

namespace gmonoid

variables {A} [add_monoid ι] [ghas_mul A] [ghas_one A]

/-- A default implementation of power on a graded monoid, like `npow_rec`.
`gmonoid.gnpow` should be used instead. -/
def gnpow_rec : Π (n : ℕ) {i}, A i → A (n • i)
| 0 i a := cast (congr_arg A (zero_nsmul i).symm) ghas_one.one
| (n + 1) i a := cast (congr_arg A (succ_nsmul i n).symm) (ghas_mul.mul a $ gnpow_rec _ a)

@[simp] lemma gnpow_rec_zero (a : graded_monoid A) : graded_monoid.mk _ (gnpow_rec 0 a.snd) = 1 :=
sigma.ext (zero_nsmul _) (heq_of_cast_eq _ rfl).symm

/-- Tactic used to autofill `graded_monoid.gmonoid.gnpow_zero'` when the default
`graded_monoid.gmonoid.gnpow_rec` is used. -/
meta def apply_gnpow_rec_zero_tac : tactic unit := `[apply graded_monoid.gmonoid.gnpow_rec_zero]

@[simp] lemma gnpow_rec_succ (n : ℕ) (a : graded_monoid A) :
  (graded_monoid.mk _ $ gnpow_rec n.succ a.snd) = a * ⟨_, gnpow_rec n a.snd⟩ :=
sigma.ext (succ_nsmul _ _) (heq_of_cast_eq _ rfl).symm

/-- Tactic used to autofill `graded_monoid.gmonoid.gnpow_succ'` when the default
`graded_monoid.gmonoid.gnpow_rec` is used. -/
meta def apply_gnpow_rec_succ_tac : tactic unit := `[apply graded_monoid.gmonoid.gnpow_rec_succ]

end gmonoid

/-- A graded version of `monoid`.

Like `monoid.npow`, this has an optional `gmonoid.gnpow` field to allow definitional control of
natural powers of a graded monoid. -/
class gmonoid [add_monoid ι]  extends ghas_mul A, ghas_one A :=
(one_mul (a : graded_monoid A) : 1 * a = a)
(mul_one (a : graded_monoid A) : a * 1 = a)
(mul_assoc (a b c : graded_monoid A) : a * b * c = a * (b * c))
(gnpow : Π (n : ℕ) {i}, A i → A (n • i) := gmonoid.gnpow_rec)
(gnpow_zero' : Π (a : graded_monoid A), graded_monoid.mk _ (gnpow 0 a.snd) = 1
  . gmonoid.apply_gnpow_rec_zero_tac)
(gnpow_succ' : Π (n : ℕ) (a : graded_monoid A),
  (graded_monoid.mk _ $ gnpow n.succ a.snd) = a * ⟨_, gnpow n a.snd⟩
  . gmonoid.apply_gnpow_rec_succ_tac)

/-- `gmonoid` implies a `monoid (graded_monoid A)`. -/
instance gmonoid.to_monoid [add_monoid ι] [gmonoid A] :
  monoid (graded_monoid A) :=
{ one := (1), mul := (*),
  npow := λ n a, graded_monoid.mk _ (gmonoid.gnpow n a.snd),
  npow_zero' := λ a, gmonoid.gnpow_zero' a,
  npow_succ' := λ n a, gmonoid.gnpow_succ' n a,
  one_mul := gmonoid.one_mul, mul_one := gmonoid.mul_one, mul_assoc := gmonoid.mul_assoc }

lemma mk_pow [add_monoid ι] [gmonoid A] {i} (a : A i) (n : ℕ) :
  mk i a ^ n = mk (n • i) (gmonoid.gnpow _ a) :=
begin
  induction n with n,
  { rw [pow_zero],
    exact (gmonoid.gnpow_zero' ⟨_, a⟩).symm, },
  { rw [pow_succ, n_ih, mk_mul_mk],
    exact (gmonoid.gnpow_succ' n ⟨_, a⟩).symm, },
end

/-- A graded version of `comm_monoid`. -/
class gcomm_monoid [add_comm_monoid ι] extends gmonoid A :=
(mul_comm (a : graded_monoid A) (b : graded_monoid A) : a * b = b * a)

/-- `gcomm_monoid` implies a `comm_monoid (graded_monoid A)`, although this is only used as an
instance locally to define notation in `gmonoid` and similar typeclasses. -/
instance gcomm_monoid.to_comm_monoid [add_comm_monoid ι] [gcomm_monoid A] :
  comm_monoid (graded_monoid A) :=
{ mul_comm := gcomm_monoid.mul_comm, ..gmonoid.to_monoid A }

end defs

/-! ### Instances for `A 0`

The various `g*` instances are enough to promote the `add_comm_monoid (A 0)` structure to various
types of multiplicative structure.
-/

section grade_zero

variables (A : ι → Type*)

section one
variables [has_zero ι] [ghas_one A]

/-- `1 : A 0` is the value provided in `ghas_one.one`. -/
@[nolint unused_arguments]
instance grade_zero.has_one : has_one (A 0) :=
⟨ghas_one.one⟩

end one

section mul
variables [add_zero_class ι] [ghas_mul A]

/-- `(•) : A 0 → A i → A i` is the value provided in `graded_monoid.ghas_mul.mul`, composed with
an `eq.rec` to turn `A (0 + i)` into `A i`.
-/
instance grade_zero.has_smul (i : ι) : has_smul (A 0) (A i) :=
{ smul := λ x y, (zero_add i).rec (ghas_mul.mul x y) }

/-- `(*) : A 0 → A 0 → A 0` is the value provided in `graded_monoid.ghas_mul.mul`, composed with
an `eq.rec` to turn `A (0 + 0)` into `A 0`.
-/
instance grade_zero.has_mul : has_mul (A 0) :=
{ mul := (•) }

variables {A}

@[simp] lemma mk_zero_smul {i} (a : A 0) (b : A i) : mk _ (a • b) = mk _ a * mk _ b :=
sigma.ext (zero_add _).symm $ eq_rec_heq _ _

@[simp] lemma grade_zero.smul_eq_mul (a b : A 0) : a • b = a * b := rfl

end mul

section monoid
variables [add_monoid ι] [gmonoid A]

instance : has_pow (A 0) ℕ :=
{ pow := λ x n, (nsmul_zero n).rec (gmonoid.gnpow n x : A (n • 0)) }

variables {A}

@[simp] lemma mk_zero_pow (a : A 0) (n : ℕ) : mk _ (a ^ n) = mk _ a ^ n :=
sigma.ext (nsmul_zero n).symm $ eq_rec_heq _ _

variables (A)

/-- The `monoid` structure derived from `gmonoid A`. -/
instance grade_zero.monoid : monoid (A 0) :=
function.injective.monoid (mk 0) sigma_mk_injective rfl mk_zero_smul mk_zero_pow

end monoid

section monoid
variables [add_comm_monoid ι] [gcomm_monoid A]

/-- The `comm_monoid` structure derived from `gcomm_monoid A`. -/
instance grade_zero.comm_monoid : comm_monoid (A 0) :=
function.injective.comm_monoid (mk 0) sigma_mk_injective rfl mk_zero_smul mk_zero_pow

end monoid

section mul_action
variables [add_monoid ι] [gmonoid A]

/-- `graded_monoid.mk 0` is a `monoid_hom`, using the `graded_monoid.grade_zero.monoid` structure.
-/
def mk_zero_monoid_hom : A 0 →* (graded_monoid A) :=
{ to_fun := mk 0, map_one' := rfl, map_mul' := mk_zero_smul }

/-- Each grade `A i` derives a `A 0`-action structure from `gmonoid A`. -/
instance grade_zero.mul_action {i} : mul_action (A 0) (A i) :=
begin
  letI := mul_action.comp_hom (graded_monoid A) (mk_zero_monoid_hom A),
  exact function.injective.mul_action (mk i) sigma_mk_injective mk_zero_smul,
end

end mul_action

end grade_zero

end graded_monoid

/-! ### Dependent products of graded elements -/

section dprod

variables {α : Type*} {A : ι → Type*} [add_monoid ι] [graded_monoid.gmonoid A]

/-- The index used by `list.dprod`. Propositionally this is equal to `(l.map fι).sum`, but
definitionally it needs to have a different form to avoid introducing `eq.rec`s in `list.dprod`. -/
def list.dprod_index (l : list α) (fι : α → ι) : ι :=
l.foldr (λ i b, fι i + b) 0

@[simp] lemma list.dprod_index_nil (fι : α → ι) : ([] : list α).dprod_index fι = 0 := rfl
@[simp] lemma list.dprod_index_cons (a : α) (l : list α) (fι : α → ι) :
  (a :: l).dprod_index fι = fι a + l.dprod_index fι := rfl

lemma list.dprod_index_eq_map_sum (l : list α) (fι : α → ι) :
  l.dprod_index fι = (l.map fι).sum :=
begin
  dunfold list.dprod_index,
  induction l,
  { simp, },
  { simp [l_ih], },
end

/-- A dependent product for graded monoids represented by the indexed family of types `A i`.
This is a dependent version of `(l.map fA).prod`.

For a list `l : list α`, this computes the product of `fA a` over `a`, where each `fA` is of type
`A (fι a)`. -/
def list.dprod (l : list α) (fι : α → ι) (fA : Π a, A (fι a)) :
  A (l.dprod_index fι) :=
l.foldr_rec_on _ _ graded_monoid.ghas_one.one (λ i x a ha, graded_monoid.ghas_mul.mul (fA a) x)

@[simp] lemma list.dprod_nil (fι : α → ι) (fA : Π a, A (fι a)) :
  (list.nil : list α).dprod fι fA = graded_monoid.ghas_one.one := rfl

-- the `( : _)` in this lemma statement results in the type on the RHS not being unfolded, which
-- is nicer in the goal view.
@[simp] lemma list.dprod_cons (fι : α → ι) (fA : Π a, A (fι a)) (a : α) (l : list α) :
  (a :: l).dprod fι fA = (graded_monoid.ghas_mul.mul (fA a) (l.dprod fι fA) : _) := rfl

lemma graded_monoid.mk_list_dprod (l : list α) (fι : α → ι) (fA : Π a, A (fι a)) :
  graded_monoid.mk _ (l.dprod fι fA) = (l.map (λ a, graded_monoid.mk (fι a) (fA a))).prod :=
begin
  induction l,
  { simp, refl  },
  { simp [←l_ih, graded_monoid.mk_mul_mk, list.prod_cons],
    refl, },
end

/-- A variant of `graded_monoid.mk_list_dprod` for rewriting in the other direction. -/
lemma graded_monoid.list_prod_map_eq_dprod (l : list α) (f : α → graded_monoid A) :
  (l.map f).prod = graded_monoid.mk _ (l.dprod (λ i, (f i).1) (λ i, (f i).2)) :=
begin
  rw [graded_monoid.mk_list_dprod, graded_monoid.mk],
  simp_rw sigma.eta,
end

lemma graded_monoid.list_prod_of_fn_eq_dprod {n : ℕ} (f : fin n → graded_monoid A) :
  (list.of_fn f).prod =
    graded_monoid.mk _ ((list.fin_range n).dprod (λ i, (f i).1) (λ i, (f i).2)) :=
by rw [list.of_fn_eq_map, graded_monoid.list_prod_map_eq_dprod]

end dprod

/-! ### Concrete instances -/
section

variables (ι) {R : Type*}

@[simps one]
instance has_one.ghas_one [has_zero ι] [has_one R] : graded_monoid.ghas_one (λ i : ι, R) :=
{ one := 1 }

@[simps mul]
instance has_mul.ghas_mul [has_add ι] [has_mul R] : graded_monoid.ghas_mul (λ i : ι, R) :=
{ mul := λ i j, (*) }

/-- If all grades are the same type and themselves form a monoid, then there is a trivial grading
structure. -/
@[simps gnpow]
instance monoid.gmonoid [add_monoid ι] [monoid R] : graded_monoid.gmonoid (λ i : ι, R) :=
{ one_mul := λ a, sigma.ext (zero_add _) (heq_of_eq (one_mul _)),
  mul_one := λ a, sigma.ext (add_zero _) (heq_of_eq (mul_one _)),
  mul_assoc := λ a b c, sigma.ext (add_assoc _ _ _) (heq_of_eq (mul_assoc _ _ _)),
  gnpow := λ n i a, a ^ n,
  gnpow_zero' := λ a, sigma.ext (zero_nsmul _) (heq_of_eq (monoid.npow_zero' _)),
  gnpow_succ' := λ n ⟨i, a⟩, sigma.ext (succ_nsmul _ _) (heq_of_eq (monoid.npow_succ' _ _)),
  ..has_one.ghas_one ι,
  ..has_mul.ghas_mul ι }

/-- If all grades are the same type and themselves form a commutative monoid, then there is a
trivial grading structure. -/
instance comm_monoid.gcomm_monoid [add_comm_monoid ι] [comm_monoid R] :
  graded_monoid.gcomm_monoid (λ i : ι, R) :=
{ mul_comm := λ a b, sigma.ext (add_comm _ _) (heq_of_eq (mul_comm _ _)),
  ..monoid.gmonoid ι }

/-- When all the indexed types are the same, the dependent product is just the regular product. -/
@[simp] lemma list.dprod_monoid {α} [add_monoid ι] [monoid R] (l : list α) (fι : α → ι)
  (fA : α → R) :
  (l.dprod fι fA : (λ i : ι, R) _) = ((l.map fA).prod : _) :=
begin
  induction l,
  { rw [list.dprod_nil, list.map_nil, list.prod_nil], refl },
  { rw [list.dprod_cons, list.map_cons, list.prod_cons, l_ih], refl },
end

end

/-! ### Shorthands for creating instance of the above typeclasses for collections of subobjects -/

section subobjects

variables {R : Type*}

/-- A version of `graded_monoid.ghas_one` for internally graded objects. -/
class set_like.has_graded_one {S : Type*} [set_like S R] [has_one R] [has_zero ι]
  (A : ι → S) : Prop :=
(one_mem : (1 : R) ∈ A 0)

instance set_like.ghas_one {S : Type*} [set_like S R] [has_one R] [has_zero ι] (A : ι → S)
  [set_like.has_graded_one A] : graded_monoid.ghas_one (λ i, A i) :=
{ one := ⟨1, set_like.has_graded_one.one_mem⟩ }

@[simp] lemma set_like.coe_ghas_one {S : Type*} [set_like S R] [has_one R] [has_zero ι] (A : ι → S)
  [set_like.has_graded_one A] : ↑(@graded_monoid.ghas_one.one _ (λ i, A i) _ _) = (1 : R) := rfl

/-- A version of `graded_monoid.ghas_one` for internally graded objects. -/
class set_like.has_graded_mul {S : Type*} [set_like S R] [has_mul R] [has_add ι]
  (A : ι → S) : Prop :=
(mul_mem : ∀ ⦃i j⦄ {gi gj}, gi ∈ A i → gj ∈ A j → gi * gj ∈ A (i + j))

instance set_like.ghas_mul {S : Type*} [set_like S R] [has_mul R] [has_add ι] (A : ι → S)
  [set_like.has_graded_mul A] :
  graded_monoid.ghas_mul (λ i, A i) :=
{ mul := λ i j a b, ⟨(a * b : R), set_like.has_graded_mul.mul_mem a.prop b.prop⟩ }

@[simp] lemma set_like.coe_ghas_mul {S : Type*} [set_like S R] [has_mul R] [has_add ι] (A : ι → S)
  [set_like.has_graded_mul A] {i j : ι} (x : A i) (y : A j) :
    ↑(@graded_monoid.ghas_mul.mul _ (λ i, A i) _ _ _ _ x y) = (x * y : R) := rfl

/-- A version of `graded_monoid.gmonoid` for internally graded objects. -/
class set_like.graded_monoid {S : Type*} [set_like S R] [monoid R] [add_monoid ι]
  (A : ι → S) extends set_like.has_graded_one A, set_like.has_graded_mul A : Prop

namespace set_like.graded_monoid
variables {S : Type*} [set_like S R] [monoid R] [add_monoid ι]
variables {A : ι → S} [set_like.graded_monoid A]

lemma pow_mem (n : ℕ) {r : R} {i : ι} (h : r ∈ A i) : r ^ n ∈ A (n • i) :=
begin
  induction n,
  { rw [pow_zero, zero_nsmul], exact one_mem },
  { rw [pow_succ', succ_nsmul'], exact mul_mem n_ih h },
end

lemma list_prod_map_mem {ι'} (l : list ι') (i : ι' → ι) (r : ι' → R) (h : ∀ j ∈ l, r j ∈ A (i j)) :
  (l.map r).prod ∈ A (l.map i).sum :=
begin
  induction l,
  { rw [list.map_nil, list.map_nil, list.prod_nil, list.sum_nil],
    exact one_mem },
  { rw [list.map_cons, list.map_cons, list.prod_cons, list.sum_cons],
    exact mul_mem (h _ $ list.mem_cons_self _ _) (l_ih $ λ j hj, h _ $ list.mem_cons_of_mem _ hj) },
end

lemma list_prod_of_fn_mem {n} (i : fin n → ι) (r : fin n → R) (h : ∀ j, r j ∈ A (i j)) :
  (list.of_fn r).prod ∈ A (list.of_fn i).sum :=
begin
  rw [list.of_fn_eq_map, list.of_fn_eq_map],
  exact list_prod_map_mem _ _ _ (λ _ _, h _),
end

end set_like.graded_monoid

/-- Build a `gmonoid` instance for a collection of subobjects. -/
instance set_like.gmonoid {S : Type*} [set_like S R] [monoid R] [add_monoid ι] (A : ι → S)
  [set_like.graded_monoid A] :
  graded_monoid.gmonoid (λ i, A i) :=
{ one_mul := λ ⟨i, a, h⟩, sigma.subtype_ext (zero_add _) (one_mul _),
  mul_one := λ ⟨i, a, h⟩, sigma.subtype_ext (add_zero _) (mul_one _),
  mul_assoc := λ ⟨i, a, ha⟩ ⟨j, b, hb⟩ ⟨k, c, hc⟩,
    sigma.subtype_ext (add_assoc _ _ _) (mul_assoc _ _ _),
  gnpow := λ n i a, ⟨a ^ n, set_like.graded_monoid.pow_mem n a.prop⟩,
  gnpow_zero' := λ n, sigma.subtype_ext (zero_nsmul _) (pow_zero _),
  gnpow_succ' := λ n a, sigma.subtype_ext (succ_nsmul _ _) (pow_succ _ _),
  ..set_like.ghas_one A,
  ..set_like.ghas_mul A }

@[simp] lemma set_like.coe_gnpow {S : Type*} [set_like S R] [monoid R] [add_monoid ι] (A : ι → S)
  [set_like.graded_monoid A] {i : ι} (x : A i) (n : ℕ) :
    ↑(@graded_monoid.gmonoid.gnpow _ (λ i, A i) _ _ n _ x) = (x ^ n : R) := rfl

/-- Build a `gcomm_monoid` instance for a collection of subobjects. -/
instance set_like.gcomm_monoid {S : Type*} [set_like S R] [comm_monoid R] [add_comm_monoid ι]
  (A : ι → S) [set_like.graded_monoid A] :
  graded_monoid.gcomm_monoid (λ i, A i) :=
{ mul_comm := λ ⟨i, a, ha⟩ ⟨j, b, hb⟩, sigma.subtype_ext (add_comm _ _) (mul_comm _ _),
  ..set_like.gmonoid A}

section dprod
open set_like set_like.graded_monoid
variables {α S : Type*} [set_like S R] [monoid R] [add_monoid ι]

/-- Coercing a dependent product of subtypes is the same as taking the regular product of the
coercions. -/
@[simp] lemma set_like.coe_list_dprod (A : ι → S) [set_like.graded_monoid A]
  (fι : α → ι) (fA : Π a, A (fι a)) (l : list α) :
  ↑(l.dprod fι fA : (λ i, ↥(A i)) _) = (list.prod (l.map (λ a, fA a)) : R) :=
begin
  induction l,
  { rw [list.dprod_nil, coe_ghas_one, list.map_nil, list.prod_nil] },
  { rw [list.dprod_cons, coe_ghas_mul, list.map_cons, list.prod_cons, l_ih], },
end

include R

/-- A version of `list.coe_dprod_set_like` with `subtype.mk`. -/
lemma set_like.list_dprod_eq (A : ι → S) [set_like.graded_monoid A]
  (fι : α → ι) (fA : Π a, A (fι a)) (l : list α) :
  (l.dprod fι fA : (λ i, ↥(A i)) _) =
    ⟨list.prod (l.map (λ a, fA a)), (l.dprod_index_eq_map_sum fι).symm ▸
      list_prod_map_mem l _ _ (λ i hi, (fA i).prop)⟩ :=
subtype.ext $ set_like.coe_list_dprod _ _ _ _

end dprod

end subobjects

section homogeneous_elements

variables {R S : Type*} [set_like S R]

/-- An element `a : R` is said to be homogeneous if there is some `i : ι` such that `a ∈ A i`. -/
def set_like.is_homogeneous (A : ι → S) (a : R) : Prop := ∃ i, a ∈ A i

@[simp] lemma set_like.is_homogeneous_coe {A : ι → S} {i} (x : A i) :
  set_like.is_homogeneous A (x : R) :=
⟨i, x.prop⟩

lemma set_like.is_homogeneous_one [has_zero ι] [has_one R]
  (A : ι → S) [set_like.has_graded_one A] : set_like.is_homogeneous A (1 : R) :=
⟨0, set_like.has_graded_one.one_mem⟩

lemma set_like.is_homogeneous.mul [has_add ι] [has_mul R] {A : ι → S}
  [set_like.has_graded_mul A] {a b : R} :
  set_like.is_homogeneous A a → set_like.is_homogeneous A b → set_like.is_homogeneous A (a * b)
| ⟨i, hi⟩ ⟨j, hj⟩ := ⟨i + j, set_like.has_graded_mul.mul_mem hi hj⟩

/-- When `A` is a `set_like.graded_monoid A`, then the homogeneous elements forms a submonoid. -/
def set_like.homogeneous_submonoid [add_monoid ι] [monoid R]
  (A : ι → S) [set_like.graded_monoid A] : submonoid R :=
{ carrier := { a | set_like.is_homogeneous A a },
  one_mem' := set_like.is_homogeneous_one A,
  mul_mem' := λ a b, set_like.is_homogeneous.mul }

end homogeneous_elements


/-
Copyright (c) 2021 Yaël Dillies, Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies, Bhavik Mehta
-/
import topology.algebra.module

theorem continuous_linear_map.is_linear {R : Type*} [semiring R] {M : Type*} [topological_space M]
  [add_comm_monoid M] {M₂ : Type*} [topological_space M₂] [add_comm_monoid M₂] [module R M]
  [module R M₂] (f : M →L[R] M₂) :
  is_linear_map R ⇑f :=
f.to_linear_map.is_linear


/-
Copyright (c) 2015 Haitao Zhang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.

Author : Haitao Zhang
-/
import algebra.group data .hom .perm .finsubg

namespace group_theory
open finset function

local attribute perm.f [coercion]

private lemma and_left_true {a b : Prop} (Pa : a) : a ∧ b ↔ b :=
by rewrite [iff_true_intro Pa, true_and]

section def
variables {G S : Type} [group G] [fintype S]

definition is_fixed_point (hom : G → perm S) (H : finset G) (a : S) : Prop :=
∀ h, h ∈ H → hom h a = a

variables [decidable_eq S]

definition orbit (hom : G → perm S) (H : finset G) (a : S) : finset S :=
           image (move_by a) (image hom H)

definition fixed_points [reducible] (hom : G → perm S) (H : finset G) : finset S :=
{a ∈ univ | orbit hom H a = '{a}}

variable [decidable_eq G] -- required by {x ∈ H |p x} filtering

definition moverset (hom : G → perm S) (H : finset G) (a b : S) : finset G :=
           {f ∈ H | hom f a = b}

definition stab (hom : G → perm S) (H : finset G) (a : S) : finset G :=
           {f ∈ H | hom f a = a}

end def

section orbit_stabilizer

variables {G S : Type} [group G] [decidable_eq G] [fintype S] [decidable_eq S]

section

variables {hom : G → perm S} {H : finset G} {a : S} [Hom : is_hom_class hom]
include Hom

lemma exists_of_orbit {b : S} : b ∈ orbit hom H a → ∃ h, h ∈ H ∧ hom h a = b :=
      assume Pb,
      obtain p (Pp₁ : p ∈ image hom H) (Pp₂ : move_by a p = b), from exists_of_mem_image Pb,
      obtain h (Ph₁ : h ∈ H) (Ph₂ : hom h = p), from exists_of_mem_image Pp₁,
      have Phab : hom h a = b, from calc
        hom h a = p a : Ph₂
            ... = b   : Pp₂,
      exists.intro h (and.intro Ph₁ Phab)

lemma orbit_of_exists {b : S} : (∃ h, h ∈ H ∧ hom h a = b) → b ∈ orbit hom H a :=
assume Pex, obtain h PinH Phab, from Pex,
mem_image (mem_image_of_mem hom PinH) Phab

lemma is_fixed_point_of_mem_fixed_points :
  a ∈ fixed_points hom H → is_fixed_point hom H a :=
assume Pain, take h, assume Phin,
  eq_of_mem_singleton
    (of_mem_sep Pain ▸ orbit_of_exists (exists.intro h (and.intro Phin rfl)))

lemma mem_fixed_points_of_exists_of_is_fixed_point :
  (∃ h, h ∈ H) → is_fixed_point hom H a → a ∈ fixed_points hom H :=
assume Pex Pfp, mem_sep_of_mem !mem_univ
  (ext take x, iff.intro
    (assume Porb, obtain h Phin Pha, from exists_of_orbit Porb,
      by rewrite [mem_singleton_iff, -Pha, Pfp h Phin])
    (obtain h Phin, from Pex,
      by rewrite mem_singleton_iff;
         intro Peq; rewrite Peq;
         apply orbit_of_exists;
         existsi h; apply and.intro Phin (Pfp h Phin)))

lemma is_fixed_point_iff_mem_fixed_points_of_exists :
  (∃ h, h ∈ H) → (a ∈ fixed_points hom H ↔ is_fixed_point hom H a) :=
assume Pex, iff.intro is_fixed_point_of_mem_fixed_points (mem_fixed_points_of_exists_of_is_fixed_point Pex)

lemma is_fixed_point_iff_mem_fixed_points [finsubgH : is_finsubg H] :
  a ∈ fixed_points hom H ↔ is_fixed_point hom H a :=
is_fixed_point_iff_mem_fixed_points_of_exists (exists.intro 1 !finsubg_has_one)

lemma is_fixed_point_of_one : is_fixed_point hom ('{1}) a :=
take h, assume Ph, by rewrite [eq_of_mem_singleton Ph, hom_map_one]

lemma fixed_points_of_one : fixed_points hom ('{1}) = univ :=
ext take s, iff.intro (assume Pl, mem_univ s)
  (assume Pr, mem_fixed_points_of_exists_of_is_fixed_point
    (exists.intro 1 !mem_singleton) is_fixed_point_of_one)

open fintype
lemma card_fixed_points_of_one : card (fixed_points hom ('{1})) = card S :=
by rewrite [fixed_points_of_one]

end

-- these are already specified by stab hom H a
variables {hom : G → perm S} {H : finset G} {a : S}

variable [Hom : is_hom_class hom]
include Hom

lemma perm_f_mul (f g : G): perm.f ((hom f) * (hom g)) a = ((hom f) ∘ (hom g)) a :=
rfl

lemma stab_lmul {f g : G} : g ∈ stab hom H a → hom (f*g) a = hom f a :=
assume Pgstab,
have hom g a = a, from of_mem_sep Pgstab, calc
  hom (f*g) a = perm.f ((hom f) * (hom g)) a : is_hom hom
          ... = ((hom f) ∘ (hom g)) a        : by rewrite perm_f_mul
          ... = (hom f) a                    : by unfold comp; rewrite this

lemma stab_subset : stab hom H a ⊆ H :=
      begin
        apply subset_of_forall, intro f Pfstab, apply mem_of_mem_sep Pfstab
      end

lemma reverse_move {h g : G} : g ∈ moverset hom H a (hom h a) → hom (h⁻¹*g) a = a :=
assume Pg,
have hom g a = hom h a, from of_mem_sep Pg, calc
  hom (h⁻¹*g) a = perm.f ((hom h⁻¹) * (hom g)) a : by rewrite (is_hom hom)
  ... = ((hom h⁻¹) ∘ hom g) a                    : by rewrite perm_f_mul
  ... = perm.f ((hom h)⁻¹ * hom h) a             : by unfold comp; rewrite [this, perm_f_mul, hom_map_inv hom h]
  ... = perm.f (1 : perm S) a                    : by rewrite (mul.left_inv (hom h))
  ... = a                                        : by esimp

lemma moverset_inj_on_orbit : set.inj_on (moverset hom H a) (ts (orbit hom H a)) :=
      take b1 b2,
      assume Pb1, obtain h1 Ph1₁ Ph1₂, from exists_of_orbit Pb1,
      have Ph1b1 : h1 ∈ moverset hom H a b1,
        from mem_sep_of_mem Ph1₁ Ph1₂,
      assume Psetb2 Pmeq, begin
        subst b1,
        rewrite Pmeq at Ph1b1,
        apply of_mem_sep Ph1b1
      end

variable [finsubgH : is_finsubg H]
include finsubgH

lemma subg_stab_of_move {h g : G} :
      h ∈ H → g ∈ moverset hom H a (hom h a) → h⁻¹*g ∈ stab hom H a :=
      assume Ph Pg,
      have Phinvg : h⁻¹*g ∈ H, from begin
        apply finsubg_mul_closed H,
          apply finsubg_has_inv H, assumption,
          apply mem_of_mem_sep Pg
        end,
      mem_sep_of_mem Phinvg (reverse_move Pg)

lemma subg_stab_closed : finset_mul_closed_on (stab hom H a) :=
      take f g, assume Pfstab, have Pf : hom f a = a, from of_mem_sep Pfstab,
      assume Pgstab,
      have Pfg : hom (f*g) a = a, from calc
        hom (f*g) a = (hom f) a : stab_lmul Pgstab
        ... = a : Pf,
      have PfginH : (f*g) ∈ H,
        from finsubg_mul_closed H (mem_of_mem_sep Pfstab) (mem_of_mem_sep Pgstab),
      mem_sep_of_mem PfginH Pfg

lemma subg_stab_has_one : 1 ∈ stab hom H a :=
      have P : hom 1 a = a, from calc
        hom 1 a = perm.f (1 : perm S) a : {hom_map_one hom}
        ... = a                         : rfl,
      have PoneinH : 1 ∈ H, from finsubg_has_one H,
      mem_sep_of_mem PoneinH P

lemma subg_stab_has_inv : finset_has_inv (stab hom H a) :=
      take f, assume Pfstab, have Pf : hom f a = a, from of_mem_sep Pfstab,
      have Pfinv : hom f⁻¹ a = a, from calc
        hom f⁻¹ a = hom f⁻¹ ((hom f) a)      : by rewrite Pf
        ... = perm.f ((hom f⁻¹) * (hom f)) a : by rewrite perm_f_mul
        ... = hom (f⁻¹ * f) a                : by rewrite (is_hom hom)
        ... = hom 1 a                        : by rewrite mul.left_inv
        ... = perm.f (1 : perm S) a          : by rewrite (hom_map_one hom),
      have PfinvinH : f⁻¹ ∈ H, from finsubg_has_inv H (mem_of_mem_sep Pfstab),
      mem_sep_of_mem PfinvinH Pfinv

definition subg_stab_is_finsubg [instance] :
           is_finsubg (stab hom H a) :=
           is_finsubg.mk subg_stab_has_one subg_stab_closed subg_stab_has_inv

lemma subg_lcoset_eq_moverset {h : G} :
      h ∈ H → fin_lcoset (stab hom H a) h = moverset hom H a (hom h a) :=
      assume Ph, ext (take g, iff.intro
      (assume Pl, obtain f (Pf₁ : f ∈ stab hom H a) (Pf₂ : h*f = g), from exists_of_mem_image Pl,
       have Pfstab : hom f a = a, from of_mem_sep Pf₁,
       have PginH : g ∈ H, begin
        subst Pf₂,
        apply finsubg_mul_closed H,
          assumption,
          apply mem_of_mem_sep Pf₁
        end,
      have Pga : hom g a = hom h a, from calc
        hom g a = hom (h*f) a : by subst g
        ... = hom h a         : stab_lmul Pf₁,
      mem_sep_of_mem PginH Pga)
      (assume Pr, begin
       rewrite [↑fin_lcoset, mem_image_iff],
       existsi h⁻¹*g,
       split,
         exact subg_stab_of_move Ph Pr,
         apply mul_inv_cancel_left
       end))

lemma subg_moverset_of_orbit_is_lcoset_of_stab (b : S) :
      b ∈ orbit hom H a → ∃ h, h ∈ H ∧ fin_lcoset (stab hom H a) h = moverset hom H a b :=
      assume Porb,
      obtain p (Pp₁ : p ∈ image hom H) (Pp₂ : move_by a p = b), from exists_of_mem_image Porb,
      obtain h (Ph₁ : h ∈ H) (Ph₂ : hom h = p), from exists_of_mem_image Pp₁,
      have Phab : hom h a = b, from by subst p; assumption,
      exists.intro h (and.intro Ph₁ (Phab ▸ subg_lcoset_eq_moverset Ph₁))

lemma subg_lcoset_of_stab_is_moverset_of_orbit (h : G) :
      h ∈ H → ∃ b, b ∈ orbit hom H a ∧ moverset hom H a b = fin_lcoset (stab hom H a) h :=
      assume Ph,
      have Pha : (hom h a) ∈ orbit hom H a, by
        apply mem_image_of_mem; apply mem_image_of_mem; exact Ph,
      exists.intro (hom h a) (and.intro Pha (eq.symm (subg_lcoset_eq_moverset Ph)))

lemma subg_moversets_of_orbit_eq_stab_lcosets :
      image (moverset hom H a) (orbit hom H a) = fin_lcosets (stab hom H a) H :=
      ext (take s, iff.intro
      (assume Pl, obtain b Pb₁ Pb₂, from exists_of_mem_image Pl,
      obtain h Ph, from subg_moverset_of_orbit_is_lcoset_of_stab b Pb₁, begin
      rewrite [↑fin_lcosets, mem_image_eq],
      existsi h, subst Pb₂, assumption
      end)
      (assume Pr, obtain h Ph₁ Ph₂, from exists_of_mem_image Pr,
      obtain b Pb, from @subg_lcoset_of_stab_is_moverset_of_orbit G S _ _ _ _ hom H a Hom _ h Ph₁, begin
      rewrite [mem_image_eq],
      existsi b, subst Ph₂, assumption
      end))

open nat

theorem orbit_stabilizer_theorem : card H = card (orbit hom H a) * card (stab hom H a) :=
        calc card H = card (fin_lcosets (stab hom H a) H) * card (stab hom H a) : lagrange_theorem stab_subset
        ... = card (image (moverset hom H a) (orbit hom H a)) * card (stab hom H a) : subg_moversets_of_orbit_eq_stab_lcosets
        ... = card (orbit hom H a) * card (stab hom H a) : card_image_eq_of_inj_on moverset_inj_on_orbit

end orbit_stabilizer

section orbit_partition

variables {G S : Type} [group G] [decidable_eq G] [fintype S] [decidable_eq S]
variables {hom : G → perm S} [Hom : is_hom_class hom] {H : finset G} [subgH : is_finsubg H]
include Hom subgH

lemma in_orbit_refl {a : S} : a ∈ orbit hom H a :=
mem_image (mem_image (finsubg_has_one H) (hom_map_one hom)) rfl

lemma in_orbit_trans {a b c : S} :
  a ∈ orbit hom H b → b ∈ orbit hom H c → a ∈ orbit hom H c :=
assume Painb Pbinc,
obtain h PhinH Phba, from exists_of_orbit Painb,
obtain g PginH Pgcb, from exists_of_orbit Pbinc,
orbit_of_exists (exists.intro (h*g) (and.intro
  (finsubg_mul_closed H PhinH PginH)
  (calc hom (h*g) c = perm.f ((hom h) * (hom g)) c : is_hom hom
                ... = ((hom h) ∘ (hom g)) c        : by rewrite perm_f_mul
                ... = (hom h) b                    : Pgcb
                ... = a                            : Phba)))

lemma in_orbit_symm {a b : S} : a ∈ orbit hom H b → b ∈ orbit hom H a :=
assume Painb, obtain h PhinH Phba, from exists_of_orbit Painb,
have perm.f (hom h)⁻¹ a = b, by rewrite [-Phba, -perm_f_mul, mul.left_inv],
have (hom h⁻¹) a = b,        by rewrite [hom_map_inv, this],
orbit_of_exists (exists.intro h⁻¹ (and.intro (finsubg_has_inv H PhinH) this))

lemma orbit_is_partition : is_partition (orbit hom H) :=
take a b, propext (iff.intro
  (assume Painb, obtain h PhinH Phba, from exists_of_orbit Painb,
  ext take c, iff.intro
    (assume Pcina, in_orbit_trans Pcina Painb)
    (assume Pcinb, obtain g PginH Pgbc, from exists_of_orbit Pcinb,
      in_orbit_trans Pcinb (in_orbit_symm Painb)))
  (assume Peq, Peq ▸ in_orbit_refl))

variables (hom) (H)
open nat finset.partition fintype

definition orbit_partition : @partition S _ :=
mk univ (orbit hom H) orbit_is_partition
  (restriction_imp_union (orbit hom H) orbit_is_partition (λ a Pa, !subset_univ))

definition orbits : finset (finset S) := equiv_classes (orbit_partition hom H)

definition fixed_point_orbits : finset (finset S) :=
  {cls ∈ orbits hom H | card cls = 1}

variables {hom} {H}

lemma exists_iff_mem_orbits (orb : finset S) :
  orb ∈ orbits hom H ↔ ∃ a : S, orbit hom H a = orb :=
begin
  esimp [orbits, equiv_classes, orbit_partition],
  rewrite [mem_image_iff],
  apply iff.intro,
    intro Pl,
    cases Pl with a Pa,
    rewrite (and_left_true !mem_univ) at Pa,
    existsi a, exact Pa,
    intro Pr,
    cases Pr with a Pa,
    rewrite -true_and at Pa, rewrite -(iff_true_intro (mem_univ a)) at Pa,
    existsi a, exact Pa
end

lemma exists_of_mem_orbits {orb : finset S} :
  orb ∈ orbits hom H → ∃ a : S, orbit hom H a = orb :=
iff.elim_left (exists_iff_mem_orbits orb)

lemma fixed_point_orbits_eq : fixed_point_orbits hom H = image (orbit hom H) (fixed_points hom H) :=
ext take s, iff.intro
  (assume Pin,
   obtain Psin Ps, from iff.elim_left !mem_sep_iff Pin,
   obtain a Pa, from exists_of_mem_orbits Psin,
   mem_image
     (mem_sep_of_mem !mem_univ (eq.symm
       (eq_of_card_eq_of_subset (by rewrite [Pa, Ps])
         (subset_of_forall
           take x, assume Pxin, eq_of_mem_singleton Pxin ▸ in_orbit_refl))))
     Pa)
  (assume Pin,
   obtain a Pain Porba, from exists_of_mem_image Pin,
   mem_sep_of_mem
     (begin esimp [orbits, equiv_classes, orbit_partition], rewrite [mem_image_iff],
       existsi a, exact and.intro !mem_univ Porba end)
     (begin substvars, rewrite [of_mem_sep Pain] end))

lemma orbit_inj_on_fixed_points : set.inj_on (orbit hom H) (ts (fixed_points hom H)) :=
take a₁ a₂, begin
  rewrite [-*mem_eq_mem_to_set, ↑fixed_points, *mem_sep_iff],
  intro Pa₁ Pa₂,
  rewrite [and.right Pa₁, and.right Pa₂],
  exact eq_of_singleton_eq
end

lemma card_fixed_point_orbits_eq : card (fixed_point_orbits hom H) = card (fixed_points hom H) :=
by rewrite fixed_point_orbits_eq; apply card_image_eq_of_inj_on orbit_inj_on_fixed_points

lemma orbit_class_equation : card S = Sum (orbits hom H) card :=
class_equation (orbit_partition hom H)

lemma card_fixed_point_orbits : Sum (fixed_point_orbits hom H) card = card (fixed_point_orbits hom H) :=
calc Sum _ _ = Sum (fixed_point_orbits hom H) (λ x, 1) : Sum_ext (take c Pin, of_mem_sep Pin)
         ... = card (fixed_point_orbits hom H) * 1 : Sum_const_eq_card_mul
         ... = card (fixed_point_orbits hom H) : mul_one (card (fixed_point_orbits hom H))

local attribute nat.comm_semiring [instance]
lemma orbit_class_equation' : card S = card (fixed_points hom H) + Sum {cls ∈ orbits hom H | card cls ≠ 1} card :=
calc card S = Sum (orbits hom H) finset.card                                                            : orbit_class_equation
        ... = Sum (fixed_point_orbits hom H) finset.card + Sum {cls ∈ orbits hom H | card cls ≠ 1} card : Sum_binary_union
        ... = card (fixed_point_orbits hom H) + Sum {cls ∈ orbits hom H | card cls ≠ 1} card            : by rewrite -card_fixed_point_orbits
        ... = card (fixed_points hom H) + Sum {cls ∈ orbits hom H | card cls ≠ 1} card                  : by rewrite card_fixed_point_orbits_eq

end orbit_partition

section cayley
variables {G : Type} [group G] [fintype G]

definition action_by_lmul : G → perm G :=
take g, perm.mk (lmul_by g) (lmul_inj g)

variable [decidable_eq G]

lemma action_by_lmul_hom : homomorphic (@action_by_lmul G _ _) :=
take g₁ (g₂ : G), eq.symm (calc
      action_by_lmul g₁ * action_by_lmul g₂
    = perm.mk ((lmul_by g₁)∘(lmul_by g₂)) _ : rfl
... = perm.mk (lmul_by (g₁*g₂)) _ : by congruence; apply coset.lmul_compose)

lemma action_by_lmul_inj : injective (@action_by_lmul G _ _) :=
take g₁ g₂, assume Peq, perm.no_confusion Peq
  (λ Pfeq Pqeq,
  have Pappeq : g₁*1 = g₂*1, from congr_fun Pfeq _,
  calc g₁ = g₁ * 1 : mul_one
      ... = g₂ * 1 : Pappeq
      ... = g₂ : mul_one)

definition action_by_lmul_is_iso [instance] : is_iso_class (@action_by_lmul G _ _) :=
is_iso_class.mk action_by_lmul_hom action_by_lmul_inj

end cayley

section lcosets
open fintype subtype

variables {G : Type} [group G] [fintype G] [decidable_eq G]

variables H : finset G

definition action_on_lcoset : G → perm (lcoset_type univ H) :=
take g, perm.mk (lcoset_lmul (mem_univ g)) lcoset_lmul_inj

private definition lcoset_of (g : G) : lcoset_type univ H :=
tag (fin_lcoset H g) (exists.intro g (and.intro !mem_univ rfl))

variable {H}

lemma action_on_lcoset_eq (g : G) (J : lcoset_type univ H)
  : elt_of (action_on_lcoset H g J) = fin_lcoset (elt_of J) g := rfl

lemma action_on_lcoset_hom : homomorphic (action_on_lcoset H) :=
take g₁ g₂, eq_of_feq (funext take S, subtype.eq
  (by rewrite [↑action_on_lcoset, ↑lcoset_lmul, -fin_lcoset_compose]))

definition action_on_lcoset_is_hom [instance] : is_hom_class (action_on_lcoset H) :=
is_hom_class.mk action_on_lcoset_hom

variable [finsubgH : is_finsubg H]
include finsubgH

lemma aol_fixed_point_subset_normalizer (J : lcoset_type univ H) :
  is_fixed_point (action_on_lcoset H) H J → elt_of J ⊆ normalizer H :=
obtain j Pjin Pj, from exists_of_lcoset_type J,
assume Pfp,
have PH : ∀ {h}, h ∈ H → fin_lcoset (fin_lcoset H j) h = fin_lcoset H j,
  from take h, assume Ph, by rewrite [Pj, -action_on_lcoset_eq, Pfp h Ph],
subset_of_forall take g, begin
  rewrite [-Pj, fin_lcoset_same, -inv_inv at {2}],
  intro Pg,
  rewrite -Pg at PH,
  apply finsubg_has_inv,
  apply mem_sep_of_mem !mem_univ,
  intro h Ph,
  have Phg : fin_lcoset (fin_lcoset H g) h = fin_lcoset H g, from PH Ph,
  revert Phg,
  rewrite [↑conj_by, inv_inv, mul.assoc, fin_lcoset_compose, -fin_lcoset_same, ↑fin_lcoset, mem_image_iff, ↑lmul_by],
  intro Pex, cases Pex with k Pand, cases Pand with Pkin Pk,
  rewrite [-Pk, inv_mul_cancel_left], exact Pkin
end

lemma aol_fixed_point_of_mem_normalizer {g : G} :
  g ∈ normalizer H → is_fixed_point (action_on_lcoset H) H (lcoset_of H g) :=
assume Pgin, take h, assume Phin, subtype.eq
  (by rewrite [action_on_lcoset_eq, ↑lcoset_of, lrcoset_same_of_mem_normalizer Pgin, fin_lrcoset_comm, finsubg_lcoset_id Phin])

lemma aol_fixed_points_eq_normalizer :
  Union (fixed_points (action_on_lcoset H) H) elt_of = normalizer H :=
ext take g, begin
  rewrite [mem_Union_iff],
  apply iff.intro,
    intro Pl,
    cases Pl with L PL, revert PL,
    rewrite [is_fixed_point_iff_mem_fixed_points],
    intro Pg,
    apply mem_of_subset_of_mem,
      apply aol_fixed_point_subset_normalizer L, exact and.left Pg,
      exact and.right Pg,
    intro Pr,
    existsi (lcoset_of H g), apply and.intro,
      rewrite [is_fixed_point_iff_mem_fixed_points],
      exact aol_fixed_point_of_mem_normalizer Pr,
      exact fin_mem_lcoset g
end

open nat

lemma card_aol_fixed_points_eq_card_cosets :
  card (fixed_points (action_on_lcoset H) H) = card (lcoset_type (normalizer H) H) :=
have Peq : card (fixed_points (action_on_lcoset H) H) * card H = card (lcoset_type (normalizer H) H) * card H, from calc
  card _ * card H = card (Union (fixed_points (action_on_lcoset H) H) elt_of) : card_Union_lcosets
              ... = card (normalizer H) : aol_fixed_points_eq_normalizer
              ... = card (lcoset_type (normalizer H) H) * card H : lagrange_theorem' subset_normalizer,
eq_of_mul_eq_mul_right (card_pos_of_mem !finsubg_has_one) Peq

end lcosets

section perm_fin
open fin nat eq.ops

variable {n : nat}

definition lift_perm (p : perm (fin n)) : perm (fin (succ n)) :=
perm.mk (lift_fun p) (lift_fun_of_inj (perm.inj p))

definition lower_perm (p : perm (fin (succ n))) (P : p maxi = maxi) : perm (fin n) :=
perm.mk (lower_inj p (perm.inj p) P)
  (take i j, begin
  rewrite [-eq_iff_veq, *lower_inj_apply, eq_iff_veq],
  apply injective_comp (perm.inj p) lift_succ_inj
  end)

lemma lift_lower_eq : ∀ {p : perm (fin (succ n))} (P : p maxi = maxi),
  lift_perm (lower_perm p P) = p
| (perm.mk pf Pinj) := assume Pmax, begin
  rewrite [↑lift_perm], congruence,
  apply funext, intro i,
  have Pfmax : pf maxi = maxi, by apply Pmax,
  have Pd : decidable (i = maxi), from _,
    cases Pd with Pe Pne,
      rewrite [Pe, Pfmax], apply lift_fun_max,
      rewrite [lift_fun_of_ne_max Pne, ↑lower_perm, ↑lift_succ],
      rewrite [-eq_iff_veq, -val_lift, lower_inj_apply, eq_iff_veq],
      congruence, rewrite [-eq_iff_veq]
  end

lemma lift_perm_inj : injective (@lift_perm n) :=
take p1 p2, assume Peq, eq_of_feq (lift_fun_inj (feq_of_eq Peq))

lemma lift_perm_inj_on_univ : set.inj_on (@lift_perm n) (ts univ) :=
eq.symm to_set_univ ▸ iff.elim_left set.injective_iff_inj_on_univ lift_perm_inj

lemma lift_to_stab : image (@lift_perm n) univ = stab id univ maxi :=
ext (take (pp : perm (fin (succ n))), iff.intro
  (assume Pimg, obtain p P_ Pp, from exists_of_mem_image Pimg,
  have Ppp : pp maxi = maxi, from calc
    pp maxi = lift_perm p maxi : {eq.symm Pp}
        ... = lift_fun p maxi : rfl
        ... = maxi : lift_fun_max,
  mem_sep_of_mem !mem_univ Ppp)
  (assume Pstab,
  have Ppp : pp maxi = maxi, from of_mem_sep Pstab,
  mem_image !mem_univ (lift_lower_eq Ppp)))

definition move_from_max_to (i : fin (succ n)) : perm (fin (succ n)) :=
perm.mk (madd (i - maxi)) madd_inj

lemma orbit_max : orbit (@id (perm (fin (succ n)))) univ maxi = univ :=
ext (take i, iff.intro
  (assume P, !mem_univ)
  (assume P, begin
    apply mem_image,
      apply mem_image,
        apply mem_univ (move_from_max_to i), apply rfl,
      apply sub_add_cancel
    end))

lemma card_orbit_max : card (orbit (@id (perm (fin (succ n)))) univ maxi) = succ n :=
calc card (orbit (@id (perm (fin (succ n)))) univ maxi) = card univ : by rewrite orbit_max
                                                    ... = succ n    : card_fin (succ n)

open fintype

lemma card_lift_to_stab : card (stab (@id (perm (fin (succ n)))) univ maxi) = card (perm (fin n)) :=
 calc finset.card (stab (@id (perm (fin (succ n)))) univ maxi)
    = finset.card (image (@lift_perm n) univ) : by rewrite lift_to_stab
... = card univ                               : by rewrite (card_image_eq_of_inj_on lift_perm_inj_on_univ)

lemma card_perm_step : card (perm (fin (succ n))) = (succ n) * card (perm (fin n)) :=
 calc card (perm (fin (succ n)))
    = card (orbit id univ maxi) * card (stab id univ maxi) : orbit_stabilizer_theorem
... = (succ n) * card (stab id univ maxi)                  : {card_orbit_max}
... = (succ n) * card (perm (fin n))                       : by rewrite -card_lift_to_stab

end perm_fin
end group_theory