/-
Copyright (c) 2022 Joël Riou. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Joël Riou

! This file was ported from Lean 3 source module category_theory.idempotents.homological_complex
! leanprover-community/mathlib commit 200eda15d8ff5669854ff6bcc10aaf37cb70498f
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Homology.Additive
import Mathbin.CategoryTheory.Idempotents.Karoubi

/-!
# Idempotent completeness and homological complexes

This file contains simplifications lemmas for categories
`karoubi (homological_complex C c)` and the construction of an equivalence
of categories `karoubi (homological_complex C c) ≌ homological_complex (karoubi C) c`.

When the category `C` is idempotent complete, it is shown that
`homological_complex (karoubi C) c` is also idempotent complete.

-/

namespace CategoryTheory

open Category

variable {C : Type _} [Category C] [Preadditive C] {ι : Type _} {c : ComplexShape ι}

namespace Idempotents

namespace Karoubi

namespace HomologicalComplex

variable {P Q : Karoubi (HomologicalComplex C c)} (f : P ⟶ Q) (n : ι)

@[simp, reassoc.1]
theorem p_comp_d : P.p.f n ≫ f.f.f n = f.f.f n :=
  HomologicalComplex.congr_hom (p_comp f) n
#align category_theory.idempotents.karoubi.homological_complex.p_comp_d CategoryTheory.Idempotents.Karoubi.HomologicalComplex.p_comp_d

@[simp, reassoc.1]
theorem comp_p_d : f.f.f n ≫ Q.p.f n = f.f.f n :=
  HomologicalComplex.congr_hom (comp_p f) n
#align category_theory.idempotents.karoubi.homological_complex.comp_p_d CategoryTheory.Idempotents.Karoubi.HomologicalComplex.comp_p_d

@[reassoc.1]
theorem p_comm_f : P.p.f n ≫ f.f.f n = f.f.f n ≫ Q.p.f n :=
  HomologicalComplex.congr_hom (p_comm f) n
#align category_theory.idempotents.karoubi.homological_complex.p_comm_f CategoryTheory.Idempotents.Karoubi.HomologicalComplex.p_comm_f

variable (P)

@[simp, reassoc.1]
theorem p_idem : P.p.f n ≫ P.p.f n = P.p.f n :=
  HomologicalComplex.congr_hom P.idem n
#align category_theory.idempotents.karoubi.homological_complex.p_idem CategoryTheory.Idempotents.Karoubi.HomologicalComplex.p_idem

end HomologicalComplex

end Karoubi

open Karoubi

namespace KaroubiHomologicalComplexEquivalence

namespace Functor

/-- The functor `karoubi (homological_complex C c) ⥤ homological_complex (karoubi C) c`,
on objects. -/
@[simps]
def obj (P : Karoubi (HomologicalComplex C c)) : HomologicalComplex (Karoubi C) c
    where
  pt n :=
    ⟨P.pt.pt n, P.p.f n, by
      simpa only [HomologicalComplex.comp_f] using HomologicalComplex.congr_hom P.idem n⟩
  d i j :=
    { f := P.p.f i ≫ P.pt.d i j
      comm := by tidy }
  shape' i j hij := by simp only [hom_eq_zero_iff, P.X.shape i j hij, limits.comp_zero]
#align category_theory.idempotents.karoubi_homological_complex_equivalence.functor.obj CategoryTheory.Idempotents.KaroubiHomologicalComplexEquivalence.Functor.obj

/-- The functor `karoubi (homological_complex C c) ⥤ homological_complex (karoubi C) c`,
on morphisms. -/
@[simps]
def map {P Q : Karoubi (HomologicalComplex C c)} (f : P ⟶ Q) : obj P ⟶ obj Q
    where f n :=
    { f := f.f.f n
      comm := by simp }
#align category_theory.idempotents.karoubi_homological_complex_equivalence.functor.map CategoryTheory.Idempotents.KaroubiHomologicalComplexEquivalence.Functor.map

end Functor

/-- The functor `karoubi (homological_complex C c) ⥤ homological_complex (karoubi C) c`. -/
@[simps]
def functor : Karoubi (HomologicalComplex C c) ⥤ HomologicalComplex (Karoubi C) c
    where
  obj := Functor.obj
  map P Q f := Functor.map f
#align category_theory.idempotents.karoubi_homological_complex_equivalence.functor CategoryTheory.Idempotents.KaroubiHomologicalComplexEquivalence.functor

namespace Inverse

/-- The functor `homological_complex (karoubi C) c ⥤ karoubi (homological_complex C c)`,
on objects -/
@[simps]
def obj (K : HomologicalComplex (Karoubi C) c) : Karoubi (HomologicalComplex C c)
    where
  pt :=
    { pt := fun n => (K.pt n).pt
      d := fun i j => (K.d i j).f
      shape' := fun i j hij => hom_eq_zero_iff.mp (K.shape i j hij)
      d_comp_d' := fun i j k hij hjk => by
        simpa only [comp_f] using hom_eq_zero_iff.mp (K.d_comp_d i j k) }
  p :=
    { f := fun n => (K.pt n).p
      comm' := by simp }
  idem := by tidy
#align category_theory.idempotents.karoubi_homological_complex_equivalence.inverse.obj CategoryTheory.Idempotents.KaroubiHomologicalComplexEquivalence.Inverse.obj

/-- The functor `homological_complex (karoubi C) c ⥤ karoubi (homological_complex C c)`,
on morphisms -/
@[simps]
def map {K L : HomologicalComplex (Karoubi C) c} (f : K ⟶ L) : obj K ⟶ obj L
    where
  f :=
    { f := fun n => (f.f n).f
      comm' := fun i j hij => by simpa only [comp_f] using hom_ext.mp (f.comm' i j hij) }
  comm := by tidy
#align category_theory.idempotents.karoubi_homological_complex_equivalence.inverse.map CategoryTheory.Idempotents.KaroubiHomologicalComplexEquivalence.Inverse.map

end Inverse

/-- The functor `homological_complex (karoubi C) c ⥤ karoubi (homological_complex C c)`. -/
@[simps]
def inverse : HomologicalComplex (Karoubi C) c ⥤ Karoubi (HomologicalComplex C c)
    where
  obj := Inverse.obj
  map K L f := Inverse.map f
#align category_theory.idempotents.karoubi_homological_complex_equivalence.inverse CategoryTheory.Idempotents.KaroubiHomologicalComplexEquivalence.inverse

/-- The counit isomorphism of the equivalence
`karoubi (homological_complex C c) ≌ homological_complex (karoubi C) c`. -/
@[simps]
def counitIso : inverse ⋙ functor ≅ 𝟭 (HomologicalComplex (Karoubi C) c) :=
  eqToIso (Functor.ext (fun P => HomologicalComplex.ext (by tidy) (by tidy)) (by tidy))
#align category_theory.idempotents.karoubi_homological_complex_equivalence.counit_iso CategoryTheory.Idempotents.KaroubiHomologicalComplexEquivalence.counitIso

/-- The unit isomorphism of the equivalence
`karoubi (homological_complex C c) ≌ homological_complex (karoubi C) c`. -/
@[simps]
def unitIso : 𝟭 (Karoubi (HomologicalComplex C c)) ≅ functor ⋙ inverse
    where
  Hom :=
    { app := fun P =>
        { f :=
            { f := fun n => P.p.f n
              comm' := fun i j hij => by
                dsimp
                simp only [HomologicalComplex.Hom.comm, HomologicalComplex.Hom.comm_assoc,
                  homological_complex.p_idem] }
          comm := by
            ext n
            dsimp
            simp only [homological_complex.p_idem] }
      naturality' := fun P Q φ => by
        ext
        dsimp
        simp only [comp_f, HomologicalComplex.comp_f, homological_complex.comp_p_d, inverse.map_f_f,
          functor.map_f_f, homological_complex.p_comp_d] }
  inv :=
    { app := fun P =>
        { f :=
            { f := fun n => P.p.f n
              comm' := fun i j hij => by
                dsimp
                simp only [HomologicalComplex.Hom.comm, assoc, homological_complex.p_idem] }
          comm := by
            ext n
            dsimp
            simp only [homological_complex.p_idem] }
      naturality' := fun P Q φ => by
        ext
        dsimp
        simp only [comp_f, HomologicalComplex.comp_f, inverse.map_f_f, functor.map_f_f,
          homological_complex.comp_p_d, homological_complex.p_comp_d] }
  hom_inv_id' := by
    ext
    dsimp
    simp only [homological_complex.p_idem, comp_f, HomologicalComplex.comp_f, id_eq]
  inv_hom_id' := by
    ext
    dsimp
    simp only [homological_complex.p_idem, comp_f, HomologicalComplex.comp_f, id_eq,
      inverse.obj_p_f, functor.obj_X_p]
#align category_theory.idempotents.karoubi_homological_complex_equivalence.unit_iso CategoryTheory.Idempotents.KaroubiHomologicalComplexEquivalence.unitIso

end KaroubiHomologicalComplexEquivalence

variable (C) (c)

/-- The equivalence `karoubi (homological_complex C c) ≌ homological_complex (karoubi C) c`. -/
@[simps]
def karoubiHomologicalComplexEquivalence :
    Karoubi (HomologicalComplex C c) ≌ HomologicalComplex (Karoubi C) c
    where
  Functor := KaroubiHomologicalComplexEquivalence.functor
  inverse := KaroubiHomologicalComplexEquivalence.inverse
  unitIso := KaroubiHomologicalComplexEquivalence.unitIso
  counitIso := KaroubiHomologicalComplexEquivalence.counitIso
#align category_theory.idempotents.karoubi_homological_complex_equivalence CategoryTheory.Idempotents.karoubiHomologicalComplexEquivalence

variable (α : Type _) [AddRightCancelSemigroup α] [One α]

/-- The equivalence `karoubi (chain_complex C α) ≌ chain_complex (karoubi C) α`. -/
@[simps]
def karoubiChainComplexEquivalence : Karoubi (ChainComplex C α) ≌ ChainComplex (Karoubi C) α :=
  karoubiHomologicalComplexEquivalence C (ComplexShape.down α)
#align category_theory.idempotents.karoubi_chain_complex_equivalence CategoryTheory.Idempotents.karoubiChainComplexEquivalence

/-- The equivalence `karoubi (cochain_complex C α) ≌ cochain_complex (karoubi C) α`. -/
@[simps]
def karoubiCochainComplexEquivalence :
    Karoubi (CochainComplex C α) ≌ CochainComplex (Karoubi C) α :=
  karoubiHomologicalComplexEquivalence C (ComplexShape.up α)
#align category_theory.idempotents.karoubi_cochain_complex_equivalence CategoryTheory.Idempotents.karoubiCochainComplexEquivalence

instance [IsIdempotentComplete C] : IsIdempotentComplete (HomologicalComplex C c) :=
  by
  rw [is_idempotent_complete_iff_of_equivalence
      ((to_karoubi_equivalence C).mapHomologicalComplex c),
    ← is_idempotent_complete_iff_of_equivalence (karoubi_homological_complex_equivalence C c)]
  infer_instance

end Idempotents

end CategoryTheory


import combinatorics.simple_graph.basic
import combinatorics.simple_graph.subgraph

namespace simple_graph

universe u

variables {V : Type u} [fintype V] [decidable_eq V]
variable (G : simple_graph V)

def edge_to_finset_powerset_len_two : Π (e : sym2 V),
  e ∈ G.edge_set → ↥(finset.powerset_len 2 (finset.univ : finset V)) :=
λ e, λ e_in,
⟨ sym2.lift ⟨λ v₁ v₂ : V, ({v₁, v₂} : finset V),
    λ v₁ v₂ : V, finset.insert.comm v₁ v₂ ∅⟩ e,
  begin
    revert e,
    rw sym2.forall,
    unfold simple_graph.edge_set,
    intros v₁ v₂,
    rw sym2.from_rel_prop,
    intro h_adj,
    simp only [sym2.lift_mk, subtype.coe_mk],
    rw finset.mem_powerset_len,
    rw finset.card_eq_two,
    have v₁_ne_v₂ : v₁ ≠ v₂,
    { intro x_eq_y,
      rw x_eq_y at h_adj,
      exact G.loopless v₂ h_adj, },
    exact ⟨finset.subset_univ {v₁, v₂}, ⟨v₁, v₂, v₁_ne_v₂, rfl⟩⟩,
  end ⟩

lemma edge_to_finset_powerset_len_two_inj : ∀ e₁ e₂ e₁_in e₂_in,
  G.edge_to_finset_powerset_len_two e₁ e₁_in =
    G.edge_to_finset_powerset_len_two e₂ e₂_in →
  e₁ = e₂ :=
begin
  rw sym2.forall,
  intros v₁ v₂,
  rw sym2.forall,
  intros v₁' v₂',
  intros e₁_in e₂_in h_eq,
  apply sym2.ext,
  rw ← subtype.val_inj at h_eq,
  unfold edge_to_finset_powerset_len_two at h_eq,
  simp only [sym2.lift_mk, subtype.coe_mk] at h_eq,
  rw finset.ext_iff at h_eq,
  simp only [finset.mem_insert, finset.mem_singleton] at h_eq,
  simp_rw sym2.mem_iff,
  exact h_eq,
end

namespace subgraph

variables {G} [decidable_rel G.adj]
variables (G' : G.subgraph) [decidable_rel G'.adj]

namespace decidable

instance edge_set_mem :
decidable_pred (∈ G'.edge_set) := sym2.from_rel.decidable_pred G'.symm

instance coe_adj : decidable_rel G'.coe.adj :=
begin
  unfold decidable_rel,
  intros v w,
  rw simple_graph.subgraph.coe_adj,
  apply_instance,
end

instance coe_edge_set_mem [decidable_pred (∈ G'.verts)] :
decidable_pred (∈ G'.coe.edge_set) :=
sym2.from_rel.decidable_pred G'.coe.symm

end decidable

def edge_finset : finset (sym2 V) := G'.edge_set.to_finset

lemma edge_finset_subset : G'.edge_finset ⊆ G.edge_finset :=
begin
  unfold edge_finset,
  unfold simple_graph.edge_finset,
  rw ← set.subset_iff_to_finset_subset,
  exact G'.edge_set_subset,
end

def edge_to_finset_powerset_len_two [decidable_pred (∈ G'.verts)] : Π (e : sym2 V),
  e ∈ G'.edge_set → ↥(finset.powerset_len 2 G'.verts.to_finset) :=
λ e, λ e_in,
⟨ sym2.lift ⟨λ v₁ v₂ : V, ({v₁, v₂} : finset V),
    λ v₁ v₂ : V, finset.insert.comm v₁ v₂ ∅⟩ e,
  begin
    revert e,
    rw sym2.forall,
    unfold simple_graph.subgraph.edge_set,
    intros v₁ v₂,
    rw sym2.from_rel_prop,
    intro h_adj,
    simp only [sym2.lift_mk, subtype.coe_mk],
    rw finset.mem_powerset_len,
    rw finset.card_eq_two,
    have v₁_ne_v₂ : v₁ ≠ v₂,
    { intro v₁_eq_v₂,
      rw v₁_eq_v₂ at h_adj,
      exact G'.loopless v₂ h_adj, },
    have h_subset : {v₁, v₂} ⊆ G'.verts.to_finset,
    { rw finset.subset_iff,
      simp only [finset.mem_insert, finset.mem_singleton, set.mem_to_finset, forall_eq_or_imp, forall_eq],
      exact ⟨G'.edge_vert h_adj, G'.edge_vert (G'.symm h_adj)⟩, },
    exact ⟨h_subset, ⟨v₁, v₂, v₁_ne_v₂, rfl⟩⟩,
  end ⟩

def edge_to_finset_powerset_len_two_inj [decidable_pred (∈ G'.verts)] : ∀ e₁ e₂ e₁_in e₂_in,
  G'.edge_to_finset_powerset_len_two e₁ e₁_in =
    G'.edge_to_finset_powerset_len_two e₂ e₂_in →
  e₁ = e₂ :=
begin
  rw sym2.forall,
  intros v₁ v₂,
  rw sym2.forall,
  intros v₁' v₂',
  intros e₁_in e₂_in h_eq,
  apply sym2.ext,
  rw ← subtype.val_inj at h_eq,
  unfold edge_to_finset_powerset_len_two at h_eq,
  simp only [sym2.lift_mk, subtype.coe_mk] at h_eq,
  rw finset.ext_iff at h_eq,
  simp only [finset.mem_insert, finset.mem_singleton] at h_eq,
  simp_rw sym2.mem_iff,
  exact h_eq,
end

end subgraph

end simple_graph


/-
Copyright (c) 2019 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Bhavik Mehta
-/
import category_theory.structured_arrow
import category_theory.punit
import category_theory.functor.reflects_isomorphisms
import category_theory.epi_mono

/-!
# Over and under categories

Over (and under) categories are special cases of comma categories.
* If `L` is the identity functor and `R` is a constant functor, then `comma L R` is the "slice" or
  "over" category over the object `R` maps to.
* Conversely, if `L` is a constant functor and `R` is the identity functor, then `comma L R` is the
  "coslice" or "under" category under the object `L` maps to.

## Tags

comma, slice, coslice, over, under
-/

namespace category_theory

universes v₁ v₂ u₁ u₂ -- morphism levels before object levels. See note [category_theory universes].
variables {T : Type u₁} [category.{v₁} T]

/--
The over category has as objects arrows in `T` with codomain `X` and as morphisms commutative
triangles.

See <https://stacks.math.columbia.edu/tag/001G>.
-/
@[derive category]
def over (X : T) := costructured_arrow (𝟭 T) X

-- Satisfying the inhabited linter
instance over.inhabited [inhabited T] : inhabited (over (default : T)) :=
{ default :=
  { left := default,
    hom := 𝟙 _ } }

namespace over

variables {X : T}

@[ext] lemma over_morphism.ext {X : T} {U V : over X} {f g : U ⟶ V}
  (h : f.left = g.left) : f = g :=
by tidy

@[simp] lemma over_right (U : over X) : U.right = ⟨⟨⟩⟩ := by tidy

@[simp] lemma id_left (U : over X) : comma_morphism.left (𝟙 U) = 𝟙 U.left := rfl
@[simp] lemma comp_left (a b c : over X) (f : a ⟶ b) (g : b ⟶ c) :
  (f ≫ g).left = f.left ≫ g.left := rfl

@[simp, reassoc] lemma w {A B : over X} (f : A ⟶ B) : f.left ≫ B.hom = A.hom :=
by have := f.w; tidy

/-- To give an object in the over category, it suffices to give a morphism with codomain `X`. -/
@[simps left hom]
def mk {X Y : T} (f : Y ⟶ X) : over X :=
costructured_arrow.mk f

/-- We can set up a coercion from arrows with codomain `X` to `over X`. This most likely should not
    be a global instance, but it is sometimes useful. -/
def coe_from_hom {X Y : T} : has_coe (Y ⟶ X) (over X) :=
{ coe := mk }

section
local attribute [instance] coe_from_hom

@[simp] lemma coe_hom {X Y : T} (f : Y ⟶ X) : (f : over X).hom = f := rfl
end

/-- To give a morphism in the over category, it suffices to give an arrow fitting in a commutative
    triangle. -/
@[simps]
def hom_mk {U V : over X} (f : U.left ⟶ V.left) (w : f ≫ V.hom = U.hom . obviously) :
  U ⟶ V :=
costructured_arrow.hom_mk f w

/--
Construct an isomorphism in the over category given isomorphisms of the objects whose forward
direction gives a commutative triangle.
-/
@[simps]
def iso_mk {f g : over X} (hl : f.left ≅ g.left) (hw : hl.hom ≫ g.hom = f.hom . obviously) :
  f ≅ g :=
costructured_arrow.iso_mk hl hw

section
variable (X)
/--
The forgetful functor mapping an arrow to its domain.

See <https://stacks.math.columbia.edu/tag/001G>.
-/
def forget : over X ⥤ T := comma.fst _ _

end

@[simp] lemma forget_obj {U : over X} : (forget X).obj U = U.left := rfl
@[simp] lemma forget_map {U V : over X} {f : U ⟶ V} : (forget X).map f = f.left := rfl

/-- The natural cocone over the forgetful functor `over X ⥤ T` with cocone point `X`. -/
@[simps] def forget_cocone (X : T) : limits.cocone (forget X) :=
{ X := X, ι := { app := comma.hom } }

/--
A morphism `f : X ⟶ Y` induces a functor `over X ⥤ over Y` in the obvious way.

See <https://stacks.math.columbia.edu/tag/001G>.
-/
def map {Y : T} (f : X ⟶ Y) : over X ⥤ over Y := comma.map_right _ $ discrete.nat_trans (λ _, f)

section
variables {Y : T} {f : X ⟶ Y} {U V : over X} {g : U ⟶ V}
@[simp] lemma map_obj_left : ((map f).obj U).left = U.left := rfl
@[simp] lemma map_obj_hom  : ((map f).obj U).hom  = U.hom ≫ f := rfl
@[simp] lemma map_map_left : ((map f).map g).left = g.left := rfl

/-- Mapping by the identity morphism is just the identity functor. -/
def map_id : map (𝟙 Y) ≅ 𝟭 _ :=
nat_iso.of_components (λ X, iso_mk (iso.refl _) (by tidy)) (by tidy)

/-- Mapping by the composite morphism `f ≫ g` is the same as mapping by `f` then by `g`. -/
def map_comp {Y Z : T} (f : X ⟶ Y) (g : Y ⟶ Z) : map (f ≫ g) ≅ map f ⋙ map g :=
nat_iso.of_components (λ X, iso_mk (iso.refl _) (by tidy)) (by tidy)

end

instance forget_reflects_iso : reflects_isomorphisms (forget X) :=
{ reflects := λ Y Z f t, by exactI
  ⟨⟨over.hom_mk (inv ((forget X).map f))
      ((as_iso ((forget X).map f)).inv_comp_eq.2 (over.w f).symm),
    by tidy⟩⟩ }

instance forget_faithful : faithful (forget X) := {}.

/--
If `k.left` is an epimorphism, then `k` is an epimorphism. In other words, `over.forget X` reflects
epimorphisms.
The converse does not hold without additional assumptions on the underlying category.
-/
-- TODO: Show the converse holds if `T` has binary products or pushouts.
lemma epi_of_epi_left {f g : over X} (k : f ⟶ g) [hk : epi k.left] : epi k :=
faithful_reflects_epi (forget X) hk

/--
If `k.left` is a monomorphism, then `k` is a monomorphism. In other words, `over.forget X` reflects
monomorphisms.
The converse of `category_theory.over.mono_left_of_mono`.

This lemma is not an instance, to avoid loops in type class inference.
-/
lemma mono_of_mono_left {f g : over X} (k : f ⟶ g) [hk : mono k.left] : mono k :=
faithful_reflects_mono (forget X) hk

/--
If `k` is a monomorphism, then `k.left` is a monomorphism. In other words, `over.forget X` preserves
monomorphisms.
The converse of `category_theory.over.mono_of_mono_left`.
-/
instance mono_left_of_mono {f g : over X} (k : f ⟶ g) [mono k] : mono k.left :=
begin
  refine ⟨λ (Y : T) l m a, _⟩,
  let l' : mk (m ≫ f.hom) ⟶ f := hom_mk l (by { dsimp, rw [←over.w k, reassoc_of a] }),
  suffices : l' = hom_mk m,
  { apply congr_arg comma_morphism.left this },
  rw ← cancel_mono k,
  ext,
  apply a,
end

section iterated_slice
variables (f : over X)

/-- Given f : Y ⟶ X, this is the obvious functor from (T/X)/f to T/Y -/
@[simps]
def iterated_slice_forward : over f ⥤ over f.left :=
{ obj := λ α, over.mk α.hom.left,
  map := λ α β κ, over.hom_mk κ.left.left (by { rw auto_param_eq, rw ← over.w κ, refl }) }

/-- Given f : Y ⟶ X, this is the obvious functor from T/Y to (T/X)/f -/
@[simps]
def iterated_slice_backward : over f.left ⥤ over f :=
{ obj := λ g, mk (hom_mk g.hom : mk (g.hom ≫ f.hom) ⟶ f),
  map := λ g h α, hom_mk (hom_mk α.left (w_assoc α f.hom)) (over_morphism.ext (w α)) }

/-- Given f : Y ⟶ X, we have an equivalence between (T/X)/f and T/Y -/
@[simps]
def iterated_slice_equiv : over f ≌ over f.left :=
{ functor := iterated_slice_forward f,
  inverse := iterated_slice_backward f,
  unit_iso :=
    nat_iso.of_components
    (λ g, over.iso_mk (over.iso_mk (iso.refl _) (by tidy)) (by tidy))
    (λ X Y g, by { ext, dsimp, simp }),
  counit_iso :=
    nat_iso.of_components
    (λ g, over.iso_mk (iso.refl _) (by tidy))
    (λ X Y g, by { ext, dsimp, simp }) }

lemma iterated_slice_forward_forget :
  iterated_slice_forward f ⋙ forget f.left = forget f ⋙ forget X :=
rfl

lemma iterated_slice_backward_forget_forget :
  iterated_slice_backward f ⋙ forget f ⋙ forget X = forget f.left :=
rfl

end iterated_slice

section
variables {D : Type u₂} [category.{v₂} D]

/-- A functor `F : T ⥤ D` induces a functor `over X ⥤ over (F.obj X)` in the obvious way. -/
@[simps]
def post (F : T ⥤ D) : over X ⥤ over (F.obj X) :=
{ obj := λ Y, mk $ F.map Y.hom,
  map := λ Y₁ Y₂ f,
  { left := F.map f.left,
    w' := by tidy; erw [← F.map_comp, w] } }

end

end over

/-- The under category has as objects arrows with domain `X` and as morphisms commutative
    triangles. -/
@[derive category]
def under (X : T) := structured_arrow X (𝟭 T)

-- Satisfying the inhabited linter
instance under.inhabited [inhabited T] : inhabited (under (default : T)) :=
{ default :=
  { right := default,
    hom := 𝟙 _ } }

namespace under

variables {X : T}

@[ext] lemma under_morphism.ext {X : T} {U V : under X} {f g : U ⟶ V}
  (h : f.right = g.right) : f = g :=
by tidy

@[simp] lemma under_left (U : under X) : U.left = ⟨⟨⟩⟩ := by tidy

@[simp] lemma id_right (U : under X) : comma_morphism.right (𝟙 U) = 𝟙 U.right := rfl
@[simp] lemma comp_right (a b c : under X) (f : a ⟶ b) (g : b ⟶ c) :
  (f ≫ g).right = f.right ≫ g.right := rfl

@[simp, reassoc] lemma w {A B : under X} (f : A ⟶ B) : A.hom ≫ f.right = B.hom :=
by have := f.w; tidy

/-- To give an object in the under category, it suffices to give an arrow with domain `X`. -/
@[simps right hom]
def mk {X Y : T} (f : X ⟶ Y) : under X :=
structured_arrow.mk f

/-- To give a morphism in the under category, it suffices to give a morphism fitting in a
    commutative triangle. -/
@[simps]
def hom_mk {U V : under X} (f : U.right ⟶ V.right) (w : U.hom ≫ f = V.hom . obviously) :
  U ⟶ V :=
structured_arrow.hom_mk f w

/--
Construct an isomorphism in the over category given isomorphisms of the objects whose forward
direction gives a commutative triangle.
-/
def iso_mk {f g : under X} (hr : f.right ≅ g.right) (hw : f.hom ≫ hr.hom = g.hom) : f ≅ g :=
structured_arrow.iso_mk hr hw

@[simp]
lemma iso_mk_hom_right {f g : under X} (hr : f.right ≅ g.right) (hw : f.hom ≫ hr.hom = g.hom) :
  (iso_mk hr hw).hom.right = hr.hom := rfl

@[simp]
lemma iso_mk_inv_right {f g : under X} (hr : f.right ≅ g.right) (hw : f.hom ≫ hr.hom = g.hom) :
  (iso_mk hr hw).inv.right = hr.inv := rfl

section
variables (X)
/-- The forgetful functor mapping an arrow to its domain. -/
def forget : under X ⥤ T := comma.snd _ _

end

@[simp] lemma forget_obj {U : under X} : (forget X).obj U = U.right := rfl
@[simp] lemma forget_map {U V : under X} {f : U ⟶ V} : (forget X).map f = f.right := rfl

/-- The natural cone over the forgetful functor `under X ⥤ T` with cone point `X`. -/
@[simps] def forget_cone (X : T) : limits.cone (forget X) :=
{ X := X, π := { app := comma.hom } }

/-- A morphism `X ⟶ Y` induces a functor `under Y ⥤ under X` in the obvious way. -/
def map {Y : T} (f : X ⟶ Y) : under Y ⥤ under X := comma.map_left _ $ discrete.nat_trans (λ _, f)

section
variables {Y : T} {f : X ⟶ Y} {U V : under Y} {g : U ⟶ V}
@[simp] lemma map_obj_right : ((map f).obj U).right = U.right := rfl
@[simp] lemma map_obj_hom   : ((map f).obj U).hom   = f ≫ U.hom := rfl
@[simp] lemma map_map_right : ((map f).map g).right = g.right := rfl

/-- Mapping by the identity morphism is just the identity functor. -/
def map_id : map (𝟙 Y) ≅ 𝟭 _ :=
nat_iso.of_components (λ X, iso_mk (iso.refl _) (by tidy)) (by tidy)

/-- Mapping by the composite morphism `f ≫ g` is the same as mapping by `f` then by `g`. -/
def map_comp {Y Z : T} (f : X ⟶ Y) (g : Y ⟶ Z) : map (f ≫ g) ≅ map g ⋙ map f :=
nat_iso.of_components (λ X, iso_mk (iso.refl _) (by tidy)) (by tidy)

end

instance forget_reflects_iso : reflects_isomorphisms (forget X) :=
{ reflects := λ Y Z f t, by exactI
  ⟨⟨under.hom_mk (inv ((under.forget X).map f)) ((is_iso.comp_inv_eq _).2 (under.w f).symm),
    by tidy⟩⟩ }

instance forget_faithful : faithful (forget X) := {}.

section
variables {D : Type u₂} [category.{v₂} D]

/-- A functor `F : T ⥤ D` induces a functor `under X ⥤ under (F.obj X)` in the obvious way. -/
@[simps]
def post {X : T} (F : T ⥤ D) : under X ⥤ under (F.obj X) :=
{ obj := λ Y, mk $ F.map Y.hom,
  map := λ Y₁ Y₂ f,
  { right := F.map f.right,
    w' := by tidy; erw [← F.map_comp, w] } }

end

end under

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_scalar (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 `submodules`. 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_scalar (i : ι) : has_scalar (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) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kevin Buzzard, Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.monoidal.braided
import Mathlib.algebra.category.Module.basic
import Mathlib.linear_algebra.tensor_product
import Mathlib.PostPort

universes u u_1 u_2 u_3 u_4 u_5 u_6

namespace Mathlib

/-!
# The symmetric monoidal category structure on R-modules

Mostly this uses existing machinery in `linear_algebra.tensor_product`.
We just need to provide a few small missing pieces to build the
`monoidal_category` instance and then the `symmetric_category` instance.

If you're happy using the bundled `Module R`, it may be possible to mostly
use this as an interface and not need to interact much with the implementation details.
-/

namespace Module

namespace monoidal_category

-- The definitions inside this namespace are essentially private.

-- After we build the `monoidal_category (Module R)` instance,

-- you should use that API.

/-- (implementation) tensor product of R-modules -/
/-- (implementation) tensor product of morphisms R-modules -/
def tensor_obj {R : Type u} [comm_ring R] (M : Module R) (N : Module R) : Module R :=
  of R (tensor_product R ↥M ↥N)

def tensor_hom {R : Type u} [comm_ring R] {M : Module R} {N : Module R} {M' : Module R} {N' : Module R} (f : M ⟶ N) (g : M' ⟶ N') : tensor_obj M M' ⟶ tensor_obj N N' :=
  tensor_product.map f g

theorem tensor_id {R : Type u} [comm_ring R] (M : Module R) (N : Module R) : tensor_hom 𝟙 𝟙 = 𝟙 :=
  tensor_product.ext fun (x : ↥M) (y : ↥N) => Eq.refl (coe_fn (tensor_hom 𝟙 𝟙) (tensor_product.tmul R x y))

theorem tensor_comp {R : Type u} [comm_ring R] {X₁ : Module R} {Y₁ : Module R} {Z₁ : Module R} {X₂ : Module R} {Y₂ : Module R} {Z₂ : Module R} (f₁ : X₁ ⟶ Y₁) (f₂ : X₂ ⟶ Y₂) (g₁ : Y₁ ⟶ Z₁) (g₂ : Y₂ ⟶ Z₂) : tensor_hom (f₁ ≫ g₁) (f₂ ≫ g₂) = tensor_hom f₁ f₂ ≫ tensor_hom g₁ g₂ :=
  tensor_product.ext
    fun (x : ↥X₁) (y : ↥X₂) => Eq.refl (coe_fn (tensor_hom (f₁ ≫ g₁) (f₂ ≫ g₂)) (tensor_product.tmul R x y))

/-- (implementation) the associator for R-modules -/
def associator {R : Type u} [comm_ring R] (M : Module R) (N : Module R) (K : Module R) : tensor_obj (tensor_obj M N) K ≅ tensor_obj M (tensor_obj N K) :=
  linear_equiv.to_Module_iso (tensor_product.assoc R ↥M ↥N ↥K)

/-! The `associator_naturality` and `pentagon` lemmas below are very slow to elaborate.

We give them some help by expressing the lemmas first non-categorically, then using
`convert _aux using 1` to have the elaborator work as little as possible. -/

theorem associator_naturality {R : Type u} [comm_ring R] {X₁ : Module R} {X₂ : Module R} {X₃ : Module R} {Y₁ : Module R} {Y₂ : Module R} {Y₃ : Module R} (f₁ : X₁ ⟶ Y₁) (f₂ : X₂ ⟶ Y₂) (f₃ : X₃ ⟶ Y₃) : tensor_hom (tensor_hom f₁ f₂) f₃ ≫ category_theory.iso.hom (associator Y₁ Y₂ Y₃) =
  category_theory.iso.hom (associator X₁ X₂ X₃) ≫ tensor_hom f₁ (tensor_hom f₂ f₃) := sorry

theorem pentagon {R : Type u} [comm_ring R] (W : Module R) (X : Module R) (Y : Module R) (Z : Module R) : tensor_hom (category_theory.iso.hom (associator W X Y)) 𝟙 ≫
    category_theory.iso.hom (associator W (tensor_obj X Y) Z) ≫
      tensor_hom 𝟙 (category_theory.iso.hom (associator X Y Z)) =
  category_theory.iso.hom (associator (tensor_obj W X) Y Z) ≫ category_theory.iso.hom (associator W X (tensor_obj Y Z)) := sorry

/-- (implementation) the left unitor for R-modules -/
def left_unitor {R : Type u} [comm_ring R] (M : Module R) : of R (tensor_product R R ↥M) ≅ M :=
  linear_equiv.to_Module_iso (tensor_product.lid R ↥M) ≪≫ of_self_iso M

theorem left_unitor_naturality {R : Type u} [comm_ring R] {M : Module R} {N : Module R} (f : M ⟶ N) : tensor_hom 𝟙 f ≫ category_theory.iso.hom (left_unitor N) = category_theory.iso.hom (left_unitor M) ≫ f := sorry

/-- (implementation) the right unitor for R-modules -/
def right_unitor {R : Type u} [comm_ring R] (M : Module R) : of R (tensor_product R (↥M) R) ≅ M :=
  linear_equiv.to_Module_iso (tensor_product.rid R ↥M) ≪≫ of_self_iso M

theorem right_unitor_naturality {R : Type u} [comm_ring R] {M : Module R} {N : Module R} (f : M ⟶ N) : tensor_hom f 𝟙 ≫ category_theory.iso.hom (right_unitor N) = category_theory.iso.hom (right_unitor M) ≫ f := sorry

theorem triangle {R : Type u} [comm_ring R] (M : Module R) (N : Module R) : category_theory.iso.hom (associator M (of R R) N) ≫ tensor_hom 𝟙 (category_theory.iso.hom (left_unitor N)) =
  tensor_hom (category_theory.iso.hom (right_unitor M)) 𝟙 := sorry

end monoidal_category

protected instance Module.monoidal_category {R : Type u} [comm_ring R] : category_theory.monoidal_category (Module R) :=
  category_theory.monoidal_category.mk monoidal_category.tensor_obj monoidal_category.tensor_hom (of R R)
    monoidal_category.associator monoidal_category.left_unitor monoidal_category.right_unitor

/-- Remind ourselves that the monoidal unit, being just `R`, is still a commutative ring. -/
protected instance category_theory.monoidal_category.tensor_unit.comm_ring {R : Type u} [comm_ring R] : comm_ring ↥𝟙_ :=
  _inst_1

namespace monoidal_category

@[simp] theorem hom_apply {R : Type u} [comm_ring R] {K : Module R} {L : Module R} {M : Module R} {N : Module R} (f : K ⟶ L) (g : M ⟶ N) (k : ↥K) (m : ↥M) : coe_fn (f ⊗ g) (tensor_product.tmul R k m) = tensor_product.tmul R (coe_fn f k) (coe_fn g m) :=
  rfl

@[simp] theorem left_unitor_hom_apply {R : Type u} [comm_ring R] {M : Module R} (r : R) (m : ↥M) : coe_fn (category_theory.iso.hom λ_) (tensor_product.tmul R r m) = r • m :=
  tensor_product.lid_tmul m r

@[simp] theorem right_unitor_hom_apply {R : Type u} [comm_ring R] {M : Module R} (m : ↥M) (r : R) : coe_fn (category_theory.iso.hom ρ_) (tensor_product.tmul R m r) = r • m :=
  tensor_product.rid_tmul m r

@[simp] theorem associator_hom_apply {R : Type u} [comm_ring R] {M : Module R} {N : Module R} {K : Module R} (m : ↥M) (n : ↥N) (k : ↥K) : coe_fn (category_theory.iso.hom α_) (tensor_product.tmul R (tensor_product.tmul R m n) k) =
  tensor_product.tmul R m (tensor_product.tmul R n k) :=
  rfl

end monoidal_category

/-- (implementation) the braiding for R-modules -/
def braiding {R : Type u} [comm_ring R] (M : Module R) (N : Module R) : monoidal_category.tensor_obj M N ≅ monoidal_category.tensor_obj N M :=
  linear_equiv.to_Module_iso (tensor_product.comm R ↥M ↥N)

@[simp] theorem braiding_naturality {R : Type u} [comm_ring R] {X₁ : Module R} {X₂ : Module R} {Y₁ : Module R} {Y₂ : Module R} (f : X₁ ⟶ Y₁) (g : X₂ ⟶ Y₂) : (f ⊗ g) ≫ category_theory.iso.hom (braiding Y₁ Y₂) = category_theory.iso.hom (braiding X₁ X₂) ≫ (g ⊗ f) :=
  tensor_product.ext
    fun (x : ↥X₁) (y : ↥X₂) =>
      Eq.refl (coe_fn ((f ⊗ g) ≫ category_theory.iso.hom (braiding Y₁ Y₂)) (tensor_product.tmul R x y))

@[simp] theorem hexagon_forward {R : Type u} [comm_ring R] (X : Module R) (Y : Module R) (Z : Module R) : category_theory.iso.hom α_ ≫ category_theory.iso.hom (braiding X (Y ⊗ Z)) ≫ category_theory.iso.hom α_ =
  (category_theory.iso.hom (braiding X Y) ⊗ 𝟙) ≫
    category_theory.iso.hom α_ ≫ (𝟙 ⊗ category_theory.iso.hom (braiding X Z)) := sorry

@[simp] theorem hexagon_reverse {R : Type u} [comm_ring R] (X : Module R) (Y : Module R) (Z : Module R) : category_theory.iso.inv α_ ≫ category_theory.iso.hom (braiding (X ⊗ Y) Z) ≫ category_theory.iso.inv α_ =
  (𝟙 ⊗ category_theory.iso.hom (braiding Y Z)) ≫
    category_theory.iso.inv α_ ≫ (category_theory.iso.hom (braiding X Z) ⊗ 𝟙) := sorry

/-- The symmetric monoidal structure on `Module R`. -/
protected instance Module.symmetric_category {R : Type u} [comm_ring R] : category_theory.symmetric_category (Module R) :=
  category_theory.symmetric_category.mk

namespace monoidal_category

@[simp] theorem braiding_hom_apply {R : Type u} [comm_ring R] {M : Module R} {N : Module R} (m : ↥M) (n : ↥N) : coe_fn (category_theory.iso.hom β_) (tensor_product.tmul R m n) = tensor_product.tmul R n m :=
  rfl

@[simp] theorem braiding_inv_apply {R : Type u} [comm_ring R] {M : Module R} {N : Module R} (m : ↥M) (n : ↥N) : coe_fn (category_theory.iso.inv β_) (tensor_product.tmul R n m) = tensor_product.tmul R m n :=
  rfl


/-
Copyright (c) 2020 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.ring_theory.valuation.basic
import Mathlib.PostPort

universes u v w l

namespace Mathlib

/-!
# Ring of integers under a given valuation

The elements with valuation less than or equal to 1.

TODO: Define characteristic predicate.
-/

namespace valuation

/-- The ring of integers under a given valuation is the subring of elements with valuation ≤ 1. -/
def integer {R : Type u} {Γ₀ : Type v} [ring R] [linear_ordered_comm_group_with_zero Γ₀]
    (v : valuation R Γ₀) : subring R :=
  subring.mk (set_of fun (x : R) => coe_fn v x ≤ 1) sorry sorry sorry sorry sorry

/-- Given a valuation v : R → Γ₀ and a ring homomorphism O →+* R, we say that O is the integers of v
if f is injective, and its range is exactly `v.integer`. -/
structure integers {R : Type u} {Γ₀ : Type v} [comm_ring R] [linear_ordered_comm_group_with_zero Γ₀]
    (v : valuation R Γ₀) (O : Type w) [comm_ring O] [algebra O R]
    where
  hom_inj : function.injective ⇑(algebra_map O R)
  map_le_one : ∀ (x : O), coe_fn v (coe_fn (algebra_map O R) x) ≤ 1
  exists_of_le_one : ∀ {r : R}, coe_fn v r ≤ 1 → ∃ (x : O), coe_fn (algebra_map O R) x = r

-- typeclass shortcut

protected instance algebra {R : Type u} {Γ₀ : Type v} [comm_ring R]
    [linear_ordered_comm_group_with_zero Γ₀] (v : valuation R Γ₀) : algebra (↥(integer v)) R :=
  algebra.of_subring (integer v)

theorem integer.integers {R : Type u} {Γ₀ : Type v} [comm_ring R]
    [linear_ordered_comm_group_with_zero Γ₀] (v : valuation R Γ₀) : integers v ↥(integer v) :=
  integers.mk subtype.coe_injective (fun (r : ↥(integer v)) => subtype.property r)
    fun (r : R) (hr : coe_fn v r ≤ 1) => Exists.intro { val := r, property := hr } rfl

namespace integers

theorem one_of_is_unit {R : Type u} {Γ₀ : Type v} [comm_ring R]
    [linear_ordered_comm_group_with_zero Γ₀] {v : valuation R Γ₀} {O : Type w} [comm_ring O]
    [algebra O R] (hv : integers v O) {x : O} (hx : is_unit x) :
    coe_fn v (coe_fn (algebra_map O R) x) = 1 :=
  sorry

theorem is_unit_of_one {R : Type u} {Γ₀ : Type v} [comm_ring R]
    [linear_ordered_comm_group_with_zero Γ₀] {v : valuation R Γ₀} {O : Type w} [comm_ring O]
    [algebra O R] (hv : integers v O) {x : O} (hx : is_unit (coe_fn (algebra_map O R) x))
    (hvx : coe_fn v (coe_fn (algebra_map O R) x) = 1) : is_unit x :=
  sorry

theorem le_of_dvd {R : Type u} {Γ₀ : Type v} [comm_ring R] [linear_ordered_comm_group_with_zero Γ₀]
    {v : valuation R Γ₀} {O : Type w} [comm_ring O] [algebra O R] (hv : integers v O) {x : O}
    {y : O} (h : x ∣ y) :
    coe_fn v (coe_fn (algebra_map O R) y) ≤ coe_fn v (coe_fn (algebra_map O R) x) :=
  sorry

end integers

namespace integers

theorem dvd_of_le {F : Type u} {Γ₀ : Type v} [field F] [linear_ordered_comm_group_with_zero Γ₀]
    {v : valuation F Γ₀} {O : Type w} [comm_ring O] [algebra O F] (hv : integers v O) {x : O}
    {y : O} (h : coe_fn v (coe_fn (algebra_map O F) x) ≤ coe_fn v (coe_fn (algebra_map O F) y)) :
    y ∣ x :=
  sorry

theorem dvd_iff_le {F : Type u} {Γ₀ : Type v} [field F] [linear_ordered_comm_group_with_zero Γ₀]
    {v : valuation F Γ₀} {O : Type w} [comm_ring O] [algebra O F] (hv : integers v O) {x : O}
    {y : O} :
    x ∣ y ↔ coe_fn v (coe_fn (algebra_map O F) y) ≤ coe_fn v (coe_fn (algebra_map O F) x) :=
  { mp := le_of_dvd hv, mpr := dvd_of_le hv }

theorem le_iff_dvd {F : Type u} {Γ₀ : Type v} [field F] [linear_ordered_comm_group_with_zero Γ₀]
    {v : valuation F Γ₀} {O : Type w} [comm_ring O] [algebra O F] (hv : integers v O) {x : O}
    {y : O} :
    coe_fn v (coe_fn (algebra_map O F) x) ≤ coe_fn v (coe_fn (algebra_map O F) y) ↔ y ∣ x :=
  { mp := dvd_of_le hv, mpr := le_of_dvd hv }

end Mathlib


import EggTactic
-- Rewrites that force a counter to count upward.

inductive B where -- bit
| O : B
| I : B
open B

def count_upward_v3
    (count: B -> B -> B -> B)
    (count_0: ∀ (b2 b1: B), count b2 b1 O = count b2 b1 I)
    (count_1: ∀ (b2: B), count b2 O I = count b2 I O)
    (count_2: count O I I = count I O O): count I I I = count O O O := by {
      simp[count_0, count_1, count_2];
      -- rawEgg[count_0, count_1, count_2];
    }

/-
inductive N where  -- unary encoding of natural numbers
| Z : N
| S : N -> N

open N
open B

axiom BinNum : Type
axiom BinNum.get: BinNum -> N -> B -- get Nth bit
axiom counter: N -> BinNum  -- counter value at nth step

axiom counter_begin (ix: N): (counter Z).get ix = O

-- 0 0 0 -> 0 0 1
axiom axiom_000_SSn (n: N) (i: N) (Xssn: (counter n).get (S (S i)) = O)  (Xsn: (counter n).get (S i) = O) (Xn: (counter n).get i = O):
    (counter (S n)).get (S (S i)) = O
axiom axiom_000_Sn (n: N) (i: N) (Xssn: (counter n).get (S (S i)) = O)  (Xsn: (counter n).get (S i) = O) (Xn: (counter n).get i = O):
    (counter (S n)).get (S i) = O
axiom axiom_000_n (n: N) (i: N) (Xssn: (counter n).get (S (S i)) = O)  (Xsn: (counter n).get (S i) = O) (Xn: (counter n).get i = O):
    (counter (S n)).get i = I

-- 0 0 1 -> 0  1  0
--         Ssn Sn n
axiom axiom_001_SSn (n: N) (i: N) (Xssn: (counter n).get (S (S i)) = O)  (Xsn: (counter n).get (S i) = O) (Xn: (counter n).get i = I):
    (counter (S n)).get (S (S i)) = O
axiom axiom_001_Sn (n: N) (i: N) (Xssn: (counter n).get (S (S i)) = O)  (Xsn: (counter n).get (S i) = O) (Xn: (counter n).get i = I):
    (counter (S n)).get (S i) = I
axiom axiom_001_n (n: N) (i: N) (Xssn: (counter n).get (S (S i)) = O)  (Xsn: (counter n).get (S i) = O) (Xn: (counter n).get i = I):
    (counter (S n)).get i = O

-- 0 1 0 ->0   1  1
--         Ssn Sn n
axiom axiom_010_SSn (n: N) (i: N) (Xssn: (counter n).get (S (S i)) = O)  (Xsn: (counter n).get (S i) = I) (Xn: (counter n).get i = O):
    (counter (S n)).get (S (S i)) = O
axiom axiom_010_Sn (n: N) (i: N) (Xssn: (counter n).get (S (S i)) = O)  (Xsn: (counter n).get (S i) = I) (Xn: (counter n).get i = O):
    (counter (S n)).get (S i) = I
axiom axiom_010_n (n: N) (i: N) (Xssn: (counter n).get (S (S i)) = O)  (Xsn: (counter n).get (S i) = I) (Xn: (counter n).get i = O):

-- 0 1 1 -> 1 0 0
axiom axiom_011_SSn (n: N) (i: N) (Xssn: (counter n).get (S (S i)) = O)  (Xsn: (counter n).get (S i) = I) (Xn: (counter n).get i = O):
    (counter (S n)).get (S (S i)) = I
axiom axiom_011_Sn (n: N) (i: N) (Xssn: (counter n).get (S (S i)) = O)  (Xsn: (counter n).get (S i) = I) (Xn: (counter n).get i = O):
    (counter (S n)).get (S i) = O
axiom axiom_011_n (n: N) (i: N) (Xssn: (counter n).get (S (S i)) = O)  (Xsn: (counter n).get (S i) = I) (Xn: (counter n).get i = O):
    (counter (S n)).get i = O

abbrev one : N := S Z
abbrev two : N := S one
abbrev three : N := S two
abbrev four : N := S three
abbrev five : N := S four
abbrev six: N := S five
abbrev seven : N := S six

/-
#print seven
theorem count_upward_7_at_0: (counter seven).get Z = I := by {
  rawEgg [axiom_000_SSn, axiom_000_Sn, axiom_000_n
  , axiom_001_SSn, axiom_001_Sn, axiom_001_n
  , axiom_010_SSn, axiom_010_Sn, axiom_010_n
  , axiom_011_SSn, axiom_011_Sn, axiom_011_n]
  sorry
-/

def foo
  (x: Int)
  (y: Nat): True := sorry

def count_upward_7_at_0'
  -- 0 0 0 -> 0 0 1
  (axiom_000_SSn: forall (n: N) (i: N) (Xssn: (counter n).get (S (S i)) = O)  (Xsn: (counter n).get (S i) = O) (Xn: (counter n).get i = O), (counter (S n)).get (S (S i)) = O)
  (axiom_000_Sn: forall (n: N) (i: N) (Xssn: (counter n).get (S (S i)) = O)  (Xsn: (counter n).get (S i) = O) (Xn: (counter n).get i = O), (counter (S n)).get (S i) = O)
  (axiom_000_n: forall (n: N) (i: N) (Xssn: (counter n).get (S (S i)) = O)  (Xsn: (counter n).get (S i) = O) (Xn: (counter n).get i = O), (counter (S n)).get i = I)
  -- 0 0 1 -> 0  1  0
  --         Ssn Sn n
  (axiom_001_SSn: forall (n: N) (i: N) (Xssn: (counter n).get (S (S i)) = O)  (Xsn: (counter n).get (S i) = O) (Xn: (counter n).get i = I), (counter (S n)).get (S (S i)) = O)
  (axiom_001_Sn: forall (n: N) (i: N) (Xssn: (counter n).get (S (S i)) = O)  (Xsn: (counter n).get (S i) = O) (Xn: (counter n).get i = I), (counter (S n)).get (S i) = I)
  (axiom_001_n: forall (n: N) (i: N) (Xssn: (counter n).get (S (S i)) = O)  (Xsn: (counter n).get (S i) = O) (Xn: (counter n).get i = I), (counter (S n)).get i = O)
  -- 0 1 0 ->0   1  1
  --         Ssn Sn n
  (axiom_010_SSn: forall (n: N) (i: N) (Xssn: (counter n).get (S (S i)) = O)  (Xsn: (counter n).get (S i) = I) (Xn: (counter n).get i = O), (counter (S n)).get (S (S i)) = O)
  (axiom_010_Sn: forall (n: N) (i: N) (Xssn: (counter n).get (S (S i)) = O)  (Xsn: (counter n).get (S i) = I) (Xn: (counter n).get i = O), (counter (S n)).get (S i) = I)
  (axiom_010_n: forall (n: N) (i: N) (Xssn: (counter n).get (S (S i)) = O)  (Xsn: (counter n).get (S i) = I) (Xn: (counter n).get i = O), (counter (S n)).get i = I)
  -- 0 1 1 -> 1 0 0
  (axiom_011_SSn: forall (n: N) (i: N) (Xssn: (counter n).get (S (S i)) = O)  (Xsn: (counter n).get (S i) = I) (Xn: (counter n).get i = O), (counter (S n)).get (S (S i)) = I)
  (axiom_011_Sn: forall (n: N) (i: N) (Xssn: (counter n).get (S (S i)) = O)  (Xsn: (counter n).get (S i) = I) (Xn: (counter n).get i = O), (counter (S n)).get (S i) = O)
  (axiom_011_n: forall (n: N) (i: N) (Xssn: (counter n).get (S (S i)) = O)  (Xsn: (counter n).get (S i) = I) (Xn: (counter n).get i = O), (counter (S n)).get i = O):
   (counter seven).get Z = I := by {
    rawEgg [axiom_000_SSn, axiom_000_Sn, axiom_000_n
      , axiom_001_SSn, axiom_001_Sn, axiom_001_n
      , axiom_010_SSn, axiom_010_Sn, axiom_010_n
    , axiom_011_SSn, axiom_011_Sn, axiom_011_n];
    sorry

  }
-/


import for_mathlib.valuation_subring.basic
import rigid_elements.rigid_pair

variables {K : Type*} [field K] {T H : mul_subgroup K} {rp : rigid_pair T H}

open rigid_pair

lemma rigid_pair.preadditive.mul_mem (h : rp.preadditive) :
  ∀ (x y : K), x ∈ rp.OO → y ∈ rp.OO → x * y ∈ rp.OO :=
begin
  suffices : ∀ a b : K, a ∈ rp.OO_m → b ∈ rp.OO_m → a * b ∈ rp.OO,
  { rintros a b (ha|ha) (hb|hb),
    { apply this, assumption' },
    { left, rw mul_comm, apply hb.2, assumption },
    { left, apply ha.2, assumption },
    { right, apply rp.OO_p_mul_mem, assumption' } },
  intros x y hx hy,
  by_cases hxy : x * y ∈ H,
  { right, apply h.mul_mem_of_mem, assumption' },
  left, refine ⟨hxy,_⟩,
  rw (show (1 + x * y = 1 - ((-1) * x) * y), by ring),
  apply (rp.preadditive_iff.mp h) _ _ _ hy,
  apply h.neg_one_mem.2 _ hx,
end

lemma rigid_pair.preadditive.one_mem (h : rp.preadditive) :
  (1 : K) ∈ rp.OO := or.inr $ rp.OO_p_one_mem

lemma rigid_pair.preadditive.zero_mem (h : rp.preadditive) :
  (0 : K) ∈ rp.OO := or.inl $ rp.OO_m_zero_mem

lemma rigid_pair.preadditive.neg_mem (h : rp.preadditive) :
  ∀ (x : K), x ∈ rp.OO → -x ∈ rp.OO :=
begin
  intros x hx,
  rw (show -x = (-1) * x, by ring),
  apply h.mul_mem _ _ _ hx,
  exact or.inr h.neg_one_mem,
end

lemma rigid_pair.preadditive.one_plus_mem (h : rp.preadditive) :
  ∀ (x : K), x ∈ rp.OO → 1 + x ∈ rp.OO :=
begin
  intros z hz,
  by_cases hzz : z = -1, { rw hzz, simp [h.zero_mem] },
  have hzz' : 1 + z ≠ 0,
  { intro c, apply hzz,
    rwa [← add_eq_zero_iff_eq_neg, add_comm] },
  by_cases hz1 : z ∈ rp.OO_p,
  swap,
  { right, apply h, cases hz, assumption, contradiction },
  have hh : 1 - (1 + z) ∈ rp.OO_p,
  { rw (show 1 - (1 + z) = (-1) * z, by ring),
    apply rp.OO_p_mul_mem h.neg_one_mem hz1 },
  have aux : ∀ y : K, y ∈ rp.OO_m → 1 + (1 + z) * y ∈ T ∧ 1 + (1 + z) * y ∈ rp.OO_p,
  { intros y hy,
    have := h.one_sub_mul_mem (-(1+z)) y _ _ hy,
    { convert this, ring, ring },
    { contrapose! hzz, simp at hzz, rwa neg_add_eq_zero at hzz },
    { simpa using hh } },
  by_cases hz2 : (1 + z) ∈ H,
  { right, refine ⟨hz2, _⟩,
    intros y hy, refine ⟨_, (aux y hy).1⟩,
    intros c, apply hy.1,
    convert H.mul_mem (H.inv_mem hz2) c,
    field_simp, ring },
  have : 1 + (1 + z) * (-1 * (1 + z)⁻¹) ∉ T,
  { convert T.zero_nmem, field_simp, ring },
  have : (-1) * (1 + z)⁻¹ ∉ rp.OO_m,
  { intro c, apply this, exact (aux _ c).1 },
  rw (show (-1) * (1 + z)⁻¹ = (- (1 + z))⁻¹, by rw [inv_neg, ← neg_eq_neg_one_mul]) at this,
  rw ← rp.OO_m_mem_iff_inv_nmem at this,
  rw (show 1 + z = (-1) * (-(1+z)), by ring),
  apply h.mul_mem, apply h.neg_mem, apply h.one_mem, left, assumption, rwa neg_ne_zero,
  intro c, apply hz2,
  rw (show 1 + z = (-1) * (-(1 + z)), by ring),
  apply H.mul_mem _ c, apply rp.neg_one_mem,
end

lemma rigid_pair.preadditive.mem_or_inv_mem (h : rp.preadditive) :
  ∀ x : K, x ∈ rp.OO ∨ x⁻¹ ∈ rp.OO :=
begin
  intros x,
  by_cases hx : x ∈ rp.OO, { left, assumption },
  right, apply h.inv_mem_of_nmem, assumption,
end

lemma rigid_pair.preadditive.add_mem (h : rp.preadditive) :
  ∀ (x y : K), x ∈ rp.OO → y ∈ rp.OO → x + y ∈ rp.OO :=
begin
  intros x y hx hy,
  by_cases hxz : x = 0, { simpa [hxz] },
  by_cases hyz : y = 0, { simpa [hyz] },
  cases h.mem_or_inv_mem (x * y⁻¹) with hh hh,
  { replace hh := h.one_plus_mem _ hh,
    convert h.mul_mem _ _ hy hh, field_simp, ring },
  { replace hh := h.one_plus_mem _ hh,
    convert h.mul_mem _ _ hx hh, field_simp, ring }
end

def rigid_pair.preadditive.valuation_subring
  (h : rp.preadditive) : valuation_subring K :=
{ carrier := rp.OO,
  mul_mem' := h.mul_mem,
  one_mem' := h.one_mem,
  add_mem' := h.add_mem,
  zero_mem' := h.zero_mem,
  neg_mem' := h.neg_mem,
  mem_or_inv_mem' := h.mem_or_inv_mem }

lemma rigid_pair.preadditive.units_eq
  (h : rp.preadditive) (u : Kˣ) :
  u ∈ h.valuation_subring.unit_group ↔
  (u : K) ∈ rp.UU :=
begin
  split,
  { intros h,
    rw valuation_subring.mem_unit_group_iff_mem_and_inv_mem at h,
    rcases h with ⟨(h1|h1),(h2|h2)⟩,
    { rw OO_m_mem_iff_inv_nmem at h1, contradiction, exact u.ne_zero, exact h1.1 },
    { exfalso, apply h1.1, convert H.inv_mem h2.1, simp },
    { exfalso, apply h2.1, convert H.inv_mem h1.1 },
    { refine ⟨h1,h2⟩ } },
  { intros h,
    rw valuation_subring.mem_unit_group_iff_mem_and_inv_mem,
    split,
    exact or.inr h.1,
    exact or.inr h.2 }
end

lemma rigid_pair.preadditive.mem_of_mem_units
  (h : rp.preadditive) (u : Kˣ) (hu : u ∈ h.valuation_subring.unit_group) : (u : K) ∈ H :=
begin
  rw h.units_eq at hu,
  cases hu with hu _,
  exact hu.1,
end

lemma rigid_pair.preadditive.mem_of_mem_principal_units
  (h : rp.preadditive) (u : Kˣ)
  (hu : u ∈ h.valuation_subring.principal_unit_group) :
  (u : K) ∈ T :=
begin
  rw valuation_subring.mem_principal_unit_group_iff_mem at hu,
  rw valuation_subring.mem_nonunits_iff_mem_and_nmem at hu,
  change _ ∈ rp.OO ∧ _ ∉ _ at hu,
  cases hu with hu1 hu2,
  by_cases hune1 : u = 1,
  { rw hune1, simp [T.one_mem] },
  change ¬ ∃ v, _ at hu2, push_neg at hu2,
  have husub1 : (u : K) - 1 ≠ 0, { contrapose! hune1, rw sub_eq_zero at hune1, ext, exact hune1 },
  specialize hu2 (units.mk0 _ husub1),
  have : units.mk0 _ husub1 ∉ h.valuation_subring.unit_group,
  { intro c, exact hu2 c rfl },
  rw h.units_eq at this,
  cases hu1, convert hu1.2, ring,
  have : ((u : K) - 1)⁻¹ ∉ rp.OO_p,
  { intro c, apply this, split,
    exact hu1, exact c },
  obtain ⟨y,z,hy,hz,hh⟩ := rp.exists_inv_eq_mul _ (H.inv_mem hu1.1) this, rw inv_inv at hh,
  have hhneg1 : (-1 : K) ∈ rp.OO_p := h.neg_one_mem,
  replace hhneg1 := hhneg1.2 _ hy,
  convert (preadditive_iff _).mp h _ _ hhneg1 hz,
  rw [mul_assoc, ← hh], ring,
end