/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Johannes Hölzl, Yury Kudryashov
-/
import algebra.category.Group.basic
import category_theory.concrete_category.reflects_isomorphisms
import algebra.ring.equiv

/-!
# Category instances for semiring, ring, comm_semiring, and comm_ring.

We introduce the bundled categories:
* `SemiRing`
* `Ring`
* `CommSemiRing`
* `CommRing`
along with the relevant forgetful functors between them.
-/

universes u v

open category_theory

/-- The category of semirings. -/
def SemiRing : Type (u+1) := bundled semiring

namespace SemiRing

/-- `ring_hom` doesn't actually assume associativity. This alias is needed to make the category
theory machinery work. We use the same trick in `category_theory.Mon.assoc_monoid_hom`. -/
abbreviation assoc_ring_hom (M N : Type*) [semiring M] [semiring N] := ring_hom M N

instance bundled_hom : bundled_hom assoc_ring_hom :=
⟨λ M N [semiring M] [semiring N], by exactI @ring_hom.to_fun M N _ _,
 λ M [semiring M], by exactI @ring_hom.id M _,
 λ M N P [semiring M] [semiring N] [semiring P], by exactI @ring_hom.comp M N P _ _ _,
 λ M N [semiring M] [semiring N], by exactI @ring_hom.coe_inj M N _ _⟩

attribute [derive [large_category, concrete_category]] SemiRing

instance : has_coe_to_sort SemiRing Type* := bundled.has_coe_to_sort

/-- Construct a bundled SemiRing from the underlying type and typeclass. -/
def of (R : Type u) [semiring R] : SemiRing := bundled.of R

/-- Typecheck a `ring_hom` as a morphism in `SemiRing`. -/
def of_hom {R S : Type u} [semiring R] [semiring S] (f : R →+* S) : of R ⟶ of S := f

@[simp] lemma of_hom_apply {R S : Type u} [semiring R] [semiring S] (f : R →+* S) (x : R) :
  of_hom f x = f x := rfl

instance : inhabited SemiRing := ⟨of punit⟩

instance (R : SemiRing) : semiring R := R.str

@[simp] lemma coe_of (R : Type u) [semiring R] : (SemiRing.of R : Type u) = R := rfl

instance has_forget_to_Mon : has_forget₂ SemiRing Mon :=
bundled_hom.mk_has_forget₂
  (λ R hR, @monoid_with_zero.to_monoid R (@semiring.to_monoid_with_zero R hR))
  (λ R₁ R₂, ring_hom.to_monoid_hom) (λ _ _ _, rfl)

instance has_forget_to_AddCommMon : has_forget₂ SemiRing AddCommMon :=
-- can't use bundled_hom.mk_has_forget₂, since AddCommMon is an induced category
{ forget₂ :=
  { obj := λ R, AddCommMon.of R,
    map := λ R₁ R₂ f, ring_hom.to_add_monoid_hom f } }

end SemiRing

/-- The category of rings. -/
def Ring : Type (u+1) := bundled ring

namespace Ring

instance : bundled_hom.parent_projection @ring.to_semiring := ⟨⟩

attribute [derive [(λ Ring, has_coe_to_sort Ring Type*), large_category, concrete_category]] Ring

/-- Construct a bundled Ring from the underlying type and typeclass. -/
def of (R : Type u) [ring R] : Ring := bundled.of R

/-- Typecheck a `ring_hom` as a morphism in `Ring`. -/
def of_hom {R S : Type u} [ring R] [ring S] (f : R →+* S) : of R ⟶ of S := f

@[simp] lemma of_hom_apply {R S : Type u} [ring R] [ring S] (f : R →+* S) (x : R) :
  of_hom f x = f x := rfl

instance : inhabited Ring := ⟨of punit⟩

instance (R : Ring) : ring R := R.str

@[simp] lemma coe_of (R : Type u) [ring R] : (Ring.of R : Type u) = R := rfl

instance has_forget_to_SemiRing : has_forget₂ Ring SemiRing := bundled_hom.forget₂ _ _
instance has_forget_to_AddCommGroup : has_forget₂ Ring AddCommGroup :=
-- can't use bundled_hom.mk_has_forget₂, since AddCommGroup is an induced category
{ forget₂ :=
  { obj := λ R, AddCommGroup.of R,
    map := λ R₁ R₂ f, ring_hom.to_add_monoid_hom f } }

end Ring

/-- The category of commutative semirings. -/
def CommSemiRing : Type (u+1) := bundled comm_semiring

namespace CommSemiRing

instance : bundled_hom.parent_projection @comm_semiring.to_semiring := ⟨⟩

attribute [derive [large_category, concrete_category]] CommSemiRing

instance : has_coe_to_sort CommSemiRing Type* := bundled.has_coe_to_sort

/-- Construct a bundled CommSemiRing from the underlying type and typeclass. -/
def of (R : Type u) [comm_semiring R] : CommSemiRing := bundled.of R

/-- Typecheck a `ring_hom` as a morphism in `CommSemiRing`. -/
def of_hom {R S : Type u} [comm_semiring R] [comm_semiring S] (f : R →+* S) : of R ⟶ of S := f

@[simp]
lemma of_hom_apply {R S : Type u} [comm_semiring R] [comm_semiring S] (f : R →+* S) (x : R) :
  of_hom f x = f x := rfl

instance : inhabited CommSemiRing := ⟨of punit⟩

instance (R : CommSemiRing) : comm_semiring R := R.str

@[simp] lemma coe_of (R : Type u) [comm_semiring R] : (CommSemiRing.of R : Type u) = R := rfl

instance has_forget_to_SemiRing : has_forget₂ CommSemiRing SemiRing := bundled_hom.forget₂ _ _

/-- The forgetful functor from commutative rings to (multiplicative) commutative monoids. -/
instance has_forget_to_CommMon : has_forget₂ CommSemiRing CommMon :=
has_forget₂.mk'
  (λ R : CommSemiRing, CommMon.of R) (λ R, rfl)
  (λ R₁ R₂ f, f.to_monoid_hom) (by tidy)

end CommSemiRing

/-- The category of commutative rings. -/
def CommRing : Type (u+1) := bundled comm_ring

namespace CommRing

instance : bundled_hom.parent_projection @comm_ring.to_ring := ⟨⟩

attribute [derive [large_category, concrete_category]] CommRing

instance : has_coe_to_sort CommRing Type* := bundled.has_coe_to_sort

/-- Construct a bundled CommRing from the underlying type and typeclass. -/
def of (R : Type u) [comm_ring R] : CommRing := bundled.of R

/-- Typecheck a `ring_hom` as a morphism in `CommRing`. -/
def of_hom {R S : Type u} [comm_ring R] [comm_ring S] (f : R →+* S) : of R ⟶ of S := f

@[simp] lemma of_hom_apply {R S : Type u} [comm_ring R] [comm_ring S] (f : R →+* S) (x : R) :
  of_hom f x = f x := rfl

instance : inhabited CommRing := ⟨of punit⟩

instance (R : CommRing) : comm_ring R := R.str

@[simp] lemma coe_of (R : Type u) [comm_ring R] : (CommRing.of R : Type u) = R := rfl

instance has_forget_to_Ring : has_forget₂ CommRing Ring := bundled_hom.forget₂ _ _

/-- The forgetful functor from commutative rings to (multiplicative) commutative monoids. -/
instance has_forget_to_CommSemiRing : has_forget₂ CommRing CommSemiRing :=
has_forget₂.mk' (λ R : CommRing, CommSemiRing.of R) (λ R, rfl) (λ R₁ R₂ f, f) (by tidy)

instance : full (forget₂ CommRing CommSemiRing) :=
{ preimage := λ X Y f, f, }

end CommRing

-- This example verifies an improvement possible in Lean 3.8.
-- Before that, to have `add_ring_hom.map_zero` usable by `simp` here,
-- we had to mark all the concrete category `has_coe_to_sort` instances reducible.
-- Now, it just works.
example {R S : CommRing} (i : R ⟶ S) (r : R) (h : r = 0) : i r = 0 :=
by simp [h]

namespace ring_equiv

variables {X Y : Type u}

/-- Build an isomorphism in the category `Ring` from a `ring_equiv` between `ring`s. -/
@[simps] def to_Ring_iso [ring X] [ring Y] (e : X ≃+* Y) : Ring.of X ≅ Ring.of Y :=
{ hom := e.to_ring_hom,
  inv := e.symm.to_ring_hom }

/-- Build an isomorphism in the category `CommRing` from a `ring_equiv` between `comm_ring`s. -/
@[simps] def to_CommRing_iso [comm_ring X] [comm_ring Y] (e : X ≃+* Y) :
  CommRing.of X ≅ CommRing.of Y :=
{ hom := e.to_ring_hom,
  inv := e.symm.to_ring_hom }

end ring_equiv

namespace category_theory.iso

/-- Build a `ring_equiv` from an isomorphism in the category `Ring`. -/
def Ring_iso_to_ring_equiv {X Y : Ring} (i : X ≅ Y) : X ≃+* Y :=
{ to_fun    := i.hom,
  inv_fun   := i.inv,
  left_inv  := by tidy,
  right_inv := by tidy,
  map_add'  := by tidy,
  map_mul'  := by tidy }.

/-- Build a `ring_equiv` from an isomorphism in the category `CommRing`. -/
def CommRing_iso_to_ring_equiv {X Y : CommRing} (i : X ≅ Y) : X ≃+* Y :=
{ to_fun    := i.hom,
  inv_fun   := i.inv,
  left_inv  := by tidy,
  right_inv := by tidy,
  map_add'  := by tidy,
  map_mul'  := by tidy }.

@[simp]
lemma CommRing_iso_to_ring_equiv_to_ring_hom {X Y : CommRing} (i : X ≅ Y) :
  i.CommRing_iso_to_ring_equiv.to_ring_hom = i.hom := by { ext, refl }

@[simp]
lemma CommRing_iso_to_ring_equiv_symm_to_ring_hom {X Y : CommRing} (i : X ≅ Y) :
  i.CommRing_iso_to_ring_equiv.symm.to_ring_hom = i.inv := by { ext, refl }

end category_theory.iso

/-- Ring equivalences between `ring`s are the same as (isomorphic to) isomorphisms in `Ring`. -/
def ring_equiv_iso_Ring_iso {X Y : Type u} [ring X] [ring Y] :
  (X ≃+* Y) ≅ (Ring.of X ≅ Ring.of Y) :=
{ hom := λ e, e.to_Ring_iso,
  inv := λ i, i.Ring_iso_to_ring_equiv, }

/-- Ring equivalences between `comm_ring`s are the same as (isomorphic to) isomorphisms
in `CommRing`. -/
def ring_equiv_iso_CommRing_iso {X Y : Type u} [comm_ring X] [comm_ring Y] :
  (X ≃+* Y) ≅ (CommRing.of X ≅ CommRing.of Y) :=
{ hom := λ e, e.to_CommRing_iso,
  inv := λ i, i.CommRing_iso_to_ring_equiv, }

instance Ring.forget_reflects_isos : reflects_isomorphisms (forget Ring.{u}) :=
{ reflects := λ X Y f _,
  begin
    resetI,
    let i := as_iso ((forget Ring).map f),
    let e : X ≃+* Y := { ..f, ..i.to_equiv },
    exact ⟨(is_iso.of_iso e.to_Ring_iso).1⟩,
  end }

instance CommRing.forget_reflects_isos : reflects_isomorphisms (forget CommRing.{u}) :=
{ reflects := λ X Y f _,
  begin
    resetI,
    let i := as_iso ((forget CommRing).map f),
    let e : X ≃+* Y := { ..f, ..i.to_equiv },
    exact ⟨(is_iso.of_iso e.to_CommRing_iso).1⟩,
  end }

-- It would be nice if we could have the following,
-- but it requires making `reflects_isomorphisms_forget₂` an instance,
-- which can cause typeclass loops:

local attribute [priority 50,instance] reflects_isomorphisms_forget₂
example : reflects_isomorphisms (forget₂ Ring AddCommGroup) := by apply_instance


import M4R.Algebra.Group.Defs

namespace M4R
  namespace Monoid

    protected instance Product (α₁ : Type _) (α₂ : Type _) [Monoid α₁] [Monoid α₂] : Monoid (α₁ × α₂) where
      zero      := (0, 0)
      add       := fun (x₁, x₂) (y₁, y₂) => (x₁ + y₁, x₂ + y₂)
      add_zero  := fun (a₁, a₂) => by simp only [HAdd.hAdd, Add.add, Prod.mk.injEq]; exact ⟨add_zero a₁, add_zero a₂⟩
      zero_add  := fun (a₁, a₂) => by simp only [HAdd.hAdd, Add.add, Prod.mk.injEq]; exact ⟨zero_add a₁, zero_add a₂⟩
      add_assoc := fun (a₁, a₂) (b₁, b₂) (c₁, c₂) => by
        simp only [HAdd.hAdd, Add.add, Prod.mk.injEq]
        exact ⟨add_assoc a₁ b₁ c₁, add_assoc a₂ b₂ c₂⟩

    theorem product_zero (α₁ : Type _) (α₂ : Type _) [Monoid α₁] [Monoid α₂] : (0 : α₁ × α₂) = (0, 0) := rfl
    theorem product_add {α₁ : Type _} {α₂ : Type _} [Monoid α₁] [Monoid α₂] : ∀ x y : α₁ × α₂, x + y = (x.fst + y.fst, x.snd + y.snd) :=
      fun (x₁, x₂) (y₁, y₂) => rfl

    protected instance multi_product.Zero {ι : Type _} (fι : ι → Type _) [∀ i, Zero (fι i)] : Zero (MultiProd fι) where
      zero := fun _ => 0
    protected theorem multi_product.Zero_def {ι : Type _} {fι : ι → Type _} [∀ i, Zero (fι i)] : ∀ i, (0 : MultiProd fι) i = 0 :=
      fun _ => rfl

    protected instance multi_product.Add {ι : Type _} (fι : ι → Type _) [∀ i, Add (fι i)] : Add (MultiProd fι) where
      add := fun a b i => a i + b i
    protected theorem multi_product.Add_def {ι : Type _} {fι : ι → Type _} [∀ i, Add (fι i)] (a b : MultiProd fι) :
      ∀ i, (a + b) i = a i + b i := fun _ => rfl

    protected instance multi_product {ι : Type _} (fι : ι → Type _) [∀ i, Monoid (fι i)] : Monoid (MultiProd fι) where
      add_zero  := fun a => funext fun i => Monoid.add_zero (a i)
      zero_add  := fun a => funext fun i => Monoid.zero_add (a i)
      add_assoc := fun a b c => funext fun i => Monoid.add_assoc (a i) (b i) (c i)

  end Monoid

  namespace CommMonoid

    protected instance Product (α₁ : Type _) (α₂ : Type _) [CommMonoid α₁] [CommMonoid α₂] : CommMonoid (α₁ × α₂) where
      add_comm := fun (a₁, a₂) (b₁, b₂) => by simp [HAdd.hAdd, Add.add]; exact ⟨add_comm a₁ b₁, add_comm a₂ b₂⟩

    protected instance multi_product {ι : Type _} (fι : ι → Type _) [∀ i, CommMonoid (fι i)] : CommMonoid (MultiProd fι) where
      add_comm := fun a b => funext fun i => CommMonoid.add_comm (a i) (b i)

    theorem add_right_comm [CommMonoid α] (a b c : α) : a + b + c = a + c + b := by
      rw [Monoid.add_assoc, add_comm b, ←Monoid.add_assoc]
    theorem add_left_comm [CommMonoid α] (a b c : α) : a + (b + c) = b + (a + c) := by
      rw [←Monoid.add_assoc, add_comm a, Monoid.add_assoc]

    protected class constructor_cm (α : Type _) extends Zero α, Add α where
      add_zero  : ∀ a : α, a + 0 = a
      add_assoc : ∀ a b c : α, (a + b) + c = a + (b + c)
      add_comm  : ∀ a b : α, a + b = b + a

    protected def construct {α : Type _} (c : CommMonoid.constructor_cm α) : CommMonoid α where
      add_zero  := c.add_zero
      zero_add  := fun a => by rw [c.add_comm]; exact c.add_zero a
      add_assoc := c.add_assoc
      add_comm  := c.add_comm

    protected def to_constructor (α : Type _) [CommMonoid α] : CommMonoid.constructor_cm α where
      add_zero  := Monoid.add_zero
      add_assoc := Monoid.add_assoc
      add_comm  := CommMonoid.add_comm

  end CommMonoid

  instance NatMonoid : CommMonoid Nat := CommMonoid.construct
    {
      add_zero  := Nat.add_zero
      add_assoc := Nat.add_assoc
      add_comm  := Nat.add_comm
    }

  instance UnorderedListMonoid (α : Type _) : CommMonoid (UnorderedList α) := CommMonoid.construct {
    add_zero  := UnorderedList.append.add_zero
    add_assoc := UnorderedList.append.assoc
    add_comm  := UnorderedList.append.comm
  }

end M4R


import model4 model_theory.bundled

instance modelA : (first_order.language.unary_preds).Structure (fin 3 × ℕ) :=
first_order.language.Structure.mk₂ empty.elim empty.elim empty.elim
(λ (b : bool), bool.rec {x : fin 3 × ℕ | x.fst = 0} {x : fin 3 × ℕ | x.fst = 1} b) empty.elim

instance modelB : (first_order.language.unary_preds).Structure (fin 2 × ℕ) :=
first_order.language.Structure.mk₂ empty.elim empty.elim empty.elim
(λ (b : bool), bool.rec {x : fin 2 × ℕ | x.fst = 0} {x : fin 2 × ℕ | x.fst = 1} b) empty.elim

lemma modelA₁up₁ : (fin 3 × ℕ) ⊨ (set.range (first_order.language.sentence.unary_card_ge first_order.language.up₁)) :=
begin
  simp,
  refine set.infinite_coe_iff.mpr _,
  rw first_order.language.up₁,
  simp,
  refine set.infinite_of_not_bdd_above _,
  rw not_bdd_above_iff',
  intros x,
  induction x,
  fconstructor,
  fconstructor,
  use 1,
  use x_snd + 1,
  simp,
end

lemma modelB₁up₁ : (fin 2 × ℕ) ⊨ (set.range (first_order.language.sentence.unary_card_ge first_order.language.up₁)) :=
begin
  simp,
  refine set.infinite_coe_iff.mpr _,
  rw first_order.language.up₁,
  simp,
  refine set.infinite_of_not_bdd_above _,
  rw not_bdd_above_iff',
  intros x,
  induction x,
  fconstructor,
  fconstructor,
  use 1,
  use x_snd + 1,
  simp,
end

lemma modelA₂up₁ : (fin 3 × ℕ) ⊨ (set.range (first_order.language.sentence.not_unary_card_ge first_order.language.up₁)) :=
begin
  simp,
  refine set.infinite_coe_iff.mpr _,
  rw first_order.language.up₁,
  simp,
  refine set.infinite_of_not_bdd_above _,
  rw not_bdd_above_iff',
  intros x,
  induction x,
  fconstructor,
  fconstructor,
  use 2,
  use x_snd + 1,
  simp,
  intro h,
  simp at h,
  injections_and_clear,
  simp at *,
  norm_num at h_1,
end

lemma modelB₂up₁ : (fin 2 × ℕ) ⊨ (set.range (first_order.language.sentence.not_unary_card_ge first_order.language.up₁)) :=
begin
  simp,
  refine set.infinite_coe_iff.mpr _,
  rw first_order.language.up₁,
  simp,
  refine set.infinite_of_not_bdd_above _,
  rw not_bdd_above_iff',
  intros x,
  induction x,
  fconstructor,
  fconstructor,
  use 2,
  use x_snd + 1,
  simp,
  intro h,
  simp at h,
  injections_and_clear,
  simp at *,
  norm_num at h_1,
end

lemma modelA₃ : (fin 3 × ℕ) ⊨ (first_order.language.sentence.unary_disjoint) :=
begin
  simp,
  rw first_order.language.up₁,
  rw first_order.language.up₂,
  simp,
  rw disjoint_iff,
  simp,
  rw set.eq_empty_iff_forall_not_mem,
  simp,
end

lemma modelB₃ : (fin 2 × ℕ) ⊨ (first_order.language.sentence.unary_disjoint) :=
begin
  simp,
  rw first_order.language.up₁,
  rw first_order.language.up₂,
  simp,
  rw disjoint_iff,
  simp,
  rw set.eq_empty_iff_forall_not_mem,
  simp,
end

lemma modelA₁up₂ : (fin 3 × ℕ) ⊨ (set.range (first_order.language.sentence.unary_card_ge first_order.language.up₂)) :=
begin
  simp,
  refine set.infinite_coe_iff.mpr _,
  rw first_order.language.up₂,
  simp,
  refine set.infinite_of_not_bdd_above _,
  rw not_bdd_above_iff',
  intros x,
  induction x,
  fconstructor,
  fconstructor,
  use 0,
  use x_snd + 1,
  simp,
end

lemma modelB₁up₂ : (fin 2 × ℕ) ⊨ (set.range (first_order.language.sentence.unary_card_ge first_order.language.up₂)) :=
begin
  simp,
  refine set.infinite_coe_iff.mpr _,
  rw first_order.language.up₂,
  simp,
  refine set.infinite_of_not_bdd_above _,
  rw not_bdd_above_iff',
  intros x,
  induction x,
  fconstructor,
  fconstructor,
  use 0,
  use x_snd + 1,
  simp,
end

lemma modelA₂up₂ : (fin 3 × ℕ) ⊨ (set.range (first_order.language.sentence.not_unary_card_ge first_order.language.up₂)) :=
begin
  simp,
  refine set.infinite_coe_iff.mpr _,
  rw first_order.language.up₂,
  simp,
  refine set.infinite_of_not_bdd_above _,
  rw not_bdd_above_iff',
  intros x,
  induction x,
  fconstructor,
  fconstructor,
  use 2,
  use x_snd + 1,
  simp,
  intro h,
  simp at h,
  injections_and_clear,
  simp at *,
  norm_num at h_1,
end

lemma modelB₂up₂ : (fin 2 × ℕ) ⊨ (set.range (first_order.language.sentence.not_unary_card_ge first_order.language.up₂)) :=
begin
  simp,
  refine set.infinite_coe_iff.mpr _,
  rw first_order.language.up₂,
  simp,
  refine set.infinite_of_not_bdd_above _,
  rw not_bdd_above_iff',
  intros x,
  induction x,
  fconstructor,
  fconstructor,
  use 1,
  use x_snd + 1,
  simp,
  intro h,
  simp at h,
  exact h
end

instance modelAT : (fin 3 × ℕ) ⊨ (first_order.language.Theory.disjoint_unary_preds) :=
begin
  rw first_order.language.Theory.disjoint_unary_preds,
  rw first_order.language.Theory.model_union_iff,
  rw first_order.language.Theory.model_union_iff,
  rw first_order.language.Theory.model_union_iff,
  rw first_order.language.Theory.model_union_iff,
  split,
  split,
  split,
  split,
  exact modelA₁up₁,
  exact modelA₁up₂,
  exact modelA₂up₁,
  exact modelA₂up₂,
  rw first_order.language.Theory.model_singleton_iff,
  exact modelA₃,
end

instance modelBT : (fin 2 × ℕ) ⊨ (first_order.language.Theory.disjoint_unary_preds) :=
begin
  rw first_order.language.Theory.disjoint_unary_preds,
  rw first_order.language.Theory.model_union_iff,
  rw first_order.language.Theory.model_union_iff,
  rw first_order.language.Theory.model_union_iff,
  rw first_order.language.Theory.model_union_iff,
  split,
  split,
  split,
  split,
  exact modelB₁up₁,
  exact modelB₁up₂,
  exact modelB₂up₁,
  exact modelB₂up₂,
  rw first_order.language.Theory.model_singleton_iff,
  exact modelB₃,
end

lemma modelAℵ₀ : cardinal.mk (fin 3 × ℕ) = cardinal.aleph_0 :=
begin
  rw ← cardinal.denumerable_iff,
  fconstructor,
  exact denumerable.of_encodable_of_infinite (fin 3 × ℕ),
end

lemma modelBℵ₀ : cardinal.mk (fin 2 × ℕ) = cardinal.aleph_0 :=
begin
  rw ← cardinal.denumerable_iff,
  fconstructor,
  exact denumerable.of_encodable_of_infinite (fin 2 × ℕ),
end

def ModelA : first_order.language.Theory.Model (first_order.language.Theory.disjoint_unary_preds) :=
{ carrier := fin 3 × ℕ }

def ModelB : first_order.language.Theory.Model (first_order.language.Theory.disjoint_unary_preds) :=
{ carrier := fin 2 × ℕ }


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

From: https://github.com/leanprover-community/mathlib/pull/14582
-/

import cicm2022.internal.decomposition
import cicm2022.internal.graded_ring

/-! # Graded scalar multiplication -/

/-! ### External version on graded monoid -/

namespace graded_monoid

variables {ι : Type*} (A : ι → Type*) (M : ι → Type*)

/-- A graded version of `has_smul`. Scalar multiplication combines grades additively, i.e.
if `a ∈ A i` and `m ∈ M j`, then `a • b` must be in `M (i + j)`-/
class ghas_smul [has_add ι] :=
(smul {i j} : A i → M j → M (i + j))

instance ghas_mul.to_ghas_mul [has_add ι] [ghas_mul A] : ghas_smul A A :=
{ smul := λ _ _, ghas_mul.mul }

instance [has_add ι] [ghas_smul A M] : has_smul (graded_monoid A) (graded_monoid M) :=
⟨λ (x : graded_monoid A) (y : graded_monoid M), ⟨_, ghas_smul.smul x.snd y.snd⟩⟩

/-- A graded version of `mul_action`. -/
class gmul_action [add_monoid ι] [graded_monoid.gmonoid A] extends ghas_smul A M :=
(one_smul (b : graded_monoid M) : (1 : graded_monoid A) • b = b)
(mul_smul (a a' : graded_monoid A) (b : graded_monoid M) : (a * a') • b = a • a' • b)

instance gmonoid.to_gmul_action [add_monoid ι] [gmonoid A] :
  gmul_action A A :=
{ one_smul := λ x, graded_monoid.gmonoid.one_mul x,
  mul_smul := graded_monoid.gmonoid.mul_assoc }

instance [add_monoid ι] [gmonoid A] [gmul_action A M] :
  mul_action (graded_monoid A) (graded_monoid M) :=
{ one_smul := gmul_action.one_smul,
  mul_smul := gmul_action.mul_smul }

end graded_monoid

/-! ### Internal version -/

section set_like

/-- A version of `graded_monoid.ghas_smul` for internally graded objects. -/
class set_like.has_graded_smul {ι S R N M : Type*} [set_like S R] [set_like N M]
  [has_smul R M] [has_add ι] (A : ι → S) (B : ι → N) : Prop :=
(smul_mem : ∀ ⦃i j : ι⦄ {ai bj}, ai ∈ A i → bj ∈ B j → ai • bj ∈ B (i + j))

lemma set_like.smul_mem_graded {ι S R N M : Type*} [set_like S R] [set_like N M]
  [has_smul R M] [has_add ι] (A : ι → S) (B : ι → N) [set_like.has_graded_smul A B]
  ⦃i j⦄ {gi gj} (hi : gi ∈ A i) (hj : gj ∈ B j) :
  gi • gj ∈ B (i + j) :=
set_like.has_graded_smul.smul_mem hi hj

instance set_like.ghas_smul {ι S R N M : Type*} [set_like S R] [set_like N M]
  [has_smul R M] [has_add ι] (A : ι → S) (B : ι → N) [set_like.has_graded_smul A B] :
  graded_monoid.ghas_smul (λ i, A i) (λ i, B i) :=
{ smul := λ i j a b, ⟨(a : R) • b, set_like.has_graded_smul.smul_mem a.2 b.2⟩ }

@[simp] lemma set_like.coe_ghas_smul {ι S R N M : Type*} [set_like S R] [set_like N M]
  [has_smul R M] [has_add ι] (A : ι → S) (B : ι → N) [set_like.has_graded_smul A B]
  {i j : ι} (x : A i) (y : B j) :
  (@graded_monoid.ghas_smul.smul ι (λ i, A i) (λ i, B i) _ _ i j x y : M) = ((x : R) • y) :=
rfl

instance set_like.has_graded_mul.to_has_graded_smul
  {ι S R : Type*} [set_like S R] [monoid R] [add_monoid ι] (A : ι → S) [set_like.has_graded_mul A] :
  set_like.has_graded_smul A A :=
{ smul_mem := λ i j ai bj hi hj, set_like.has_graded_mul.mul_mem hi hj, }

end set_like

/-! ### Graded modules -/

section gmodule

section defs

variables {ι : Type*} [add_monoid ι] (A : ι → Type*) (M : ι → Type*)

/-- A graded version of `distrib_mul_action`. -/
class gdistrib_mul_action [graded_monoid.gmonoid A] [Π i, add_monoid $ M i]
  extends graded_monoid.gmul_action A M :=
(smul_add {i j} (a : A i) (b c : M j) : smul a (b + c) = smul a b + smul a c)
(smul_zero {i j} (a : A i) : smul a (0 : M j) = 0)

/-- A graded version of `module`. -/
class gmodule [graded_monoid.gmonoid A] [Π i, add_comm_monoid $ M i] [Π i, add_comm_monoid $ A i]
  extends gdistrib_mul_action A M :=
(add_smul {i j} (a a' : A i) (b : M j) : smul (a + a') b = smul a b + smul a' b)
(zero_smul {i j} (b : M j) : smul (0 : A i) b = 0)

end defs

-- External version of graded module
open_locale direct_sum

variables {ι : Type*} [add_monoid ι] (A : ι → Type*) (M : ι → Type*)
variables [Π (i : ι), add_comm_monoid (A i)] [Π i, add_comm_monoid $ M i]

/-- The piecewise multiplication from the `has_mul` instance, as a bundled homomorphism. -/
@[simps]
def gsmul_hom {i j} [graded_monoid.gmonoid A] [gmodule A M] : A i →+ M j →+ M (i + j) :=
{ to_fun := λ a,
  { to_fun := λ b, graded_monoid.ghas_smul.smul a b,
    map_zero' := gdistrib_mul_action.smul_zero _,
    map_add' := gdistrib_mul_action.smul_add _ },
  map_zero' := add_monoid_hom.ext $ λ a, gmodule.zero_smul a,
  map_add' := λ a₁ a₂, add_monoid_hom.ext $ λ b, gmodule.add_smul _ _ _}

/-- The multiplication from the `has_smul` instance, as a bundled homomorphism. -/
def gmodule.smul_add_monoid_hom [decidable_eq ι] [graded_monoid.gmonoid A] [gmodule A M] :
  (⨁ i, A i) →+ (⨁ i, M i) →+ ⨁ i, M i :=
direct_sum.to_add_monoid $ λ i,
  add_monoid_hom.flip $ direct_sum.to_add_monoid $ λ j, add_monoid_hom.flip $
    (direct_sum.of M _).comp_hom.comp $ gsmul_hom A M

section

variables [decidable_eq ι] [graded_monoid.gmonoid A] [gmodule A M]
instance : has_smul (⨁ i, A i) (⨁ i, M i) :=
{ smul := λ x y, gmodule.smul_add_monoid_hom A M x y }

@[simp] lemma gmodule.smul_def
  (x : ⨁ i, A i) (y : ⨁ i, M i) : x • y = gmodule.smul_add_monoid_hom _ _ x y := rfl
@[simp] lemma gmodule.smul_add_monoid_hom_apply_of_of {i j} (x : A i) (y : M j) :
  gmodule.smul_add_monoid_hom A M (direct_sum.of A i x) (direct_sum.of M j y) =
  direct_sum.of M (i + j) (graded_monoid.ghas_smul.smul x y) :=
by simp [gmodule.smul_add_monoid_hom]

@[simp] lemma gmodule.of_smul_of
  {i j} (x : A i) (y : M j) :
  direct_sum.of A i x • direct_sum.of M j y =
  direct_sum.of M (i + j) (graded_monoid.ghas_smul.smul x y) :=
gmodule.smul_add_monoid_hom_apply_of_of _ _ _ _

end

open add_monoid_hom

-- Almost identical to the proof of `direct_sum.one_mul`
private lemma one_smul [decidable_eq ι] [direct_sum.gsemiring A] [gmodule A M] (x : ⨁ i, M i) :
  (1 : ⨁ i, A i) • x = x :=
suffices gmodule.smul_add_monoid_hom A M 1 = add_monoid_hom.id (⨁ i, M i),
  from add_monoid_hom.congr_fun this x,
begin
  apply direct_sum.add_hom_ext, intros i xi,
  unfold has_one.one,
  rw gmodule.smul_add_monoid_hom_apply_of_of,
  exact direct_sum.of_eq_of_graded_monoid_eq (one_smul (graded_monoid A) $ graded_monoid.mk i xi),
end

-- Almost identical to the proof of `direct_sum.mul_assoc`
private lemma mul_smul [decidable_eq ι] [direct_sum.gsemiring A] [gmodule A M]
  (a b : ⨁ i, A i) (c : ⨁ i, M i) : (a * b) • c = a • (b • c) :=
suffices (gmodule.smul_add_monoid_hom A M).comp_hom.comp (direct_sum.mul_hom A) -- `λ a b c, (a * b) • c` as a bundled hom
       = (add_monoid_hom.comp_hom add_monoid_hom.flip_hom $                     -- `λ a b c, a • (b • c)` as a bundled hom
             (gmodule.smul_add_monoid_hom A M).flip.comp_hom.comp (gmodule.smul_add_monoid_hom A M)).flip,
  from add_monoid_hom.congr_fun (add_monoid_hom.congr_fun (add_monoid_hom.congr_fun this a) b) c,
begin
  ext ai ax bi bx ci cx : 6,
  dsimp only [coe_comp, function.comp_app, comp_hom_apply_apply, flip_apply, flip_hom_apply],
  rw [gmodule.smul_add_monoid_hom_apply_of_of, gmodule.smul_add_monoid_hom_apply_of_of,
    direct_sum.mul_hom_of_of, gmodule.smul_add_monoid_hom_apply_of_of],
  exact direct_sum.of_eq_of_graded_monoid_eq
    (mul_smul (graded_monoid.mk ai ax) (graded_monoid.mk bi bx) (graded_monoid.mk ci cx)),
end

instance gmodule.module [decidable_eq ι] [direct_sum.gsemiring A] [gmodule A M] :
  module (⨁ i, A i) (⨁ i, M i) :=
{ smul := (•),
  one_smul := one_smul _ _,
  mul_smul := mul_smul _ _,
  smul_add := λ r, (gmodule.smul_add_monoid_hom A M r).map_add,
  smul_zero := λ r, (gmodule.smul_add_monoid_hom A M r).map_zero,
  add_smul := λ r s x, by simp only [gmodule.smul_def, map_add, add_monoid_hom.add_apply],
  zero_smul := λ x, by simp only [gmodule.smul_def, map_zero, add_monoid_hom.zero_apply] }

end gmodule

section

-- internal version of graded module

variables {ι R A M σ σ' : Type*}
variables [add_monoid ι] [comm_semiring R] [semiring A] [algebra R A]
variables (𝓐 : ι → σ') [set_like σ' A]
variables (𝓜 : ι → σ)

open_locale direct_sum

namespace graded_module

include σ' A σ M

instance gdistrib_mul_action [add_monoid M] [distrib_mul_action A M]
  [set_like σ M] [add_submonoid_class σ M] [set_like.graded_monoid 𝓐]
  [set_like.has_graded_smul 𝓐 𝓜] :
  gdistrib_mul_action (λ i, 𝓐 i) (λ i, 𝓜 i) :=
{ smul := λ i j x y, ⟨(x : A) • (y : M), set_like.has_graded_smul.smul_mem x.2 y.2⟩,
  one_smul := λ ⟨i, m⟩, sigma.subtype_ext (zero_add _) (one_smul _ _),
  mul_smul := λ ⟨i, a⟩ ⟨j, a'⟩ ⟨k, b⟩, sigma.subtype_ext (add_assoc _ _ _) (mul_smul _ _ _),
  smul_add := λ i j a b c, subtype.ext $ smul_add _ _ _,
  smul_zero := λ i j a, subtype.ext $ smul_zero _ }

variables [add_comm_monoid M] [module A M] [set_like σ M] [add_submonoid_class σ' A]
  [add_submonoid_class σ M] [set_like.graded_monoid 𝓐] [set_like.has_graded_smul 𝓐 𝓜]

-- [set_like.graded_monoid 𝓐] [set_like.has_graded_smul 𝓐 𝓜] is the internal version of graded module
-- the internal version can be translated into the external version `gmodule`.
instance gmodule : gmodule (λ i, 𝓐 i) (λ i, 𝓜 i) :=
{ smul := λ i j x y, ⟨(x : A) • (y : M), set_like.has_graded_smul.smul_mem x.2 y.2⟩,
  add_smul := λ i j a a' b, subtype.ext $ add_smul _ _ _,
  zero_smul := λ i j b, subtype.ext $ zero_smul _ _,
  ..graded_module.gdistrib_mul_action 𝓐 𝓜}

/--
The smul multiplication of `A` on `⨁ i, 𝓜 i` from `(⨁ i, 𝓐 i) →+ (⨁ i, 𝓜 i) →+ ⨁ i, 𝓜 i`
turns `⨁ i, 𝓜 i` into an `A`-module
-/
def is_module [decidable_eq ι] [graded_ring 𝓐] :
  module A (⨁ i, 𝓜 i) :=
{ smul := λ a b, direct_sum.decompose 𝓐 a • b,
  ..module.comp_hom _ $
    (direct_sum.decompose_ring_equiv 𝓐 : A ≃+* ⨁ i, 𝓐 i).to_ring_hom }

local attribute [instance] graded_module.is_module

/--
`⨁ i, 𝓜 i` and `M` are isomorphic as `A`-modules.
"The internal version" and "the external version" are isomorphism as `A`-modules.
-/
def linear_equiv [decidable_eq ι] [graded_ring 𝓐]
  [direct_sum.decomposition 𝓜] :
  M ≃ₗ[A] ⨁ i, 𝓜 i :=
{ to_fun := direct_sum.decompose_add_equiv 𝓜,
  map_smul' := λ x y, begin
    classical,
    rw [← direct_sum.sum_support_decompose 𝓐 x, map_sum, finset.sum_smul, map_sum,
      finset.sum_smul, finset.sum_congr rfl (λ i hi, _)],
    rw [ring_hom.id_apply, ← direct_sum.sum_support_decompose 𝓜 y, map_sum, finset.smul_sum,
      map_sum, finset.smul_sum, finset.sum_congr rfl (λ j hj, _)],
    unfold has_smul.smul,
    simp only [direct_sum.decompose_add_equiv_apply, direct_sum.decompose_coe,
      gmodule.smul_add_monoid_hom_apply_of_of],
    convert direct_sum.decompose_coe 𝓜 _,
    refl,
  end,
  .. (direct_sum.decompose_add_equiv 𝓜) }

end graded_module

end


import ExtParser.Grammar

namespace AST
  open Grammar

  inductive PreAST (n : Nat) (b : Nat) where
    | skip (s e : Fin b) (G : PEG n)
    | ε (s e : Fin b)
    | any (s e : Fin b) (x : Char)
    | terminal (s e : Fin b) (a x : Char)
    | nonTerminal (s e : Fin b) (A : Fin n) (T : PreAST n b)
    | seq (s e : Fin b) (T1 T2 : PreAST n b)
    | prior (s e : Fin b) (T1 T2 : PreAST n b)
    | star (s e : Fin b) (T0 TS : PreAST n b)
    | notP (s e : Fin b) (T : PreAST n b)

  inductive PreAST.SkipPreAST : PreAST n b → Prop where
    | skip : SkipPreAST (.skip s e G)

  inductive PreAST.StarPreAST : PreAST n b → Prop where
    | star : StarPreAST (.star s e T0 TS)

  inductive PreAST.IsValid : PreAST n b → Prop where
    | skip : IsValid (.skip s e G)
    | ε : IsValid (.ε s e)
    | any : IsValid (.any s e x)
    | terminal : IsValid (.terminal s e a x)
    | nonTerminal : IsValid sub_T → ¬SkipPreAST sub_T → IsValid (.nonTerminal s e A sub_T)
    | seq : IsValid T1 → IsValid T2 → ¬SkipPreAST T1 → IsValid (.seq s e T1 T2)
    | prior : IsValid T1 → IsValid T2 → ¬SkipPreAST T1 → IsValid (.prior s e T1 T2)
    | star : IsValid T0 → IsValid TS → ¬SkipPreAST T0 → (SkipPreAST TS ∨ StarPreAST TS) → IsValid (.star s e T0 TS)
    | notP : IsValid sub_T → ¬SkipPreAST sub_T → IsValid (.notP s e sub_T)

  def PreAST.size (T : PreAST n b) : Nat :=
    match T with
    | .skip _ _ _ => 0
    | .ε _ _ => 0
    | .any _ _ _ => 0
    | .terminal _ _ _ _ => 0
    | .nonTerminal _ _ _ T => T.size + 1
    | .seq _ _ T1 T2 => T1.size + T2.size + 1
    | .prior _ _ T1 T2 => T1.size + T2.size + 1
    | .star _ _ T0 TS => T0.size + TS.size + 1
    | .notP _ _ T => T.size + 1

  def PreAST.start (T : PreAST n b) : Fin b :=
    match T with
    | .skip s _ _             => s
    | .ε s _                  => s
    | .any s _ _              => s
    | .terminal s _ _ _       => s
    | .nonTerminal s _ _ _    => s
    | .seq s _ _ _            => s
    | .prior s _ _ _          => s
    | .star s _ _ _           => s
    | .notP s _ _             => s

  def PreAST.end (T : PreAST n b) : Fin b :=
    match T with
    | .skip _ e _             => e
    | .ε _ e                  => e
    | .any _ e _              => e
    | .terminal _ e _ _       => e
    | .nonTerminal _ e _ _    => e
    | .seq _ e _ _            => e
    | .prior _ e _ _          => e
    | .star _ e _ _           => e
    | .notP _ e _             => e

  mutual

  inductive PreAST.SuccessAST : PreAST n b → Prop where
    | ε : s = e → SuccessAST (.ε s e)
    | any : s.inbound_succ h = e → SuccessAST (.any s e x)
    | terminal : s.inbound_succ h = e → a = x → SuccessAST (.terminal s e a x)
    | nonTerminal : SuccessAST T → SuccessAST (.nonTerminal s e A T)
    | seq : SuccessAST T1 → SuccessAST T2 → SuccessAST (.seq s e T1 T2)
    | prior_S : SuccessAST T1 → SuccessAST (.prior s e T1 T2)
    | prior_FS : FailureAST T1 → SuccessAST T2 → SuccessAST (.prior s e T1 T2)
    | star_F : FailureAST T0 → SuccessAST (.star s e T0 TS)
    | star_SS : SuccessAST T0 → SuccessAST TS → SuccessAST (.star s e T0 TS)
    | notP : FailureAST T → SuccessAST (.notP s e T)

  inductive PreAST.FailureAST : PreAST n b → Prop where
    | any : s = e → Fin.IsMax e → FailureAST (.any s e x)
    | terminal_mismatch : s.inbound_succ h = e → a ≠ x → FailureAST (.terminal s e a x)
    | terminal_empty : s = e → Fin.IsMax e → FailureAST (.terminal s e a x)
    | nonTerminal : FailureAST T → FailureAST (.nonTerminal s e A T)
    | seq_F : FailureAST T1 → FailureAST (.seq s e T1 T2)
    | seq_SF : SuccessAST T1 → FailureAST T2 → FailureAST (.seq s e T1 T2)
    | prior : FailureAST T1 → FailureAST T2 → FailureAST (.prior s e T1 T2)
    | notP : SuccessAST T → FailureAST (.notP s e T)

  end

  theorem PreAST.SuccessAST.ne_failure : ∀ {T : PreAST n b}, PreAST.IsValid T → SuccessAST T → ¬FailureAST T := by
    intro T valid_T hs hf;
    match T with
      | .skip _ _ _ => cases hs;
      | .ε _ _ => cases hf;
      | .any _ _ _ => cases hs; cases hf; apply absurd (by assumption); apply Fin.ne_of_val_ne; apply Nat.ne_of_lt; apply Fin.lt_from_inbound_succ; assumption;
      | .terminal s e a x => cases hs; cases hf; contradiction; apply absurd (by assumption); apply Fin.ne_of_val_ne; apply Nat.ne_of_lt; apply Fin.lt_from_inbound_succ; assumption;
      | .nonTerminal s e A _ => match hs with
        | .nonTerminal (T := Ts) st =>
          {
            match hf with
            | .nonTerminal (T := Ts) ft =>
              {
                apply absurd ft; apply ne_failure; cases valid_T; assumption; assumption;
              }
          }
      | .seq s e _ _ => match hs with
        | .seq (T1 := T1) (T2 := T2) st1 st2 =>
          {
            match hf with
              | .seq_F (T1 := T1) (T2 := T2) ft1 =>
                {
                  apply absurd ft1; apply ne_failure; cases valid_T; assumption; assumption;
                }
              | .seq_SF (T1 := T1) (T2 := T2) _ ft2 =>
                {
                  apply absurd ft2; apply ne_failure; cases valid_T; assumption; assumption;
                }
          }
      | .prior s e _ _ => match hf with
        | .prior (T1 := T1) (T2 := T2) ft1 ft2 =>
          {
            match hs with
              | .prior_S (T1 := T1) (T2 := T2) st1 =>
                {
                  apply absurd ft1; apply ne_failure; cases valid_T; assumption; assumption;
                }
              | .prior_FS (T1 := T1) (T2 := T2) _ st2 =>
                {
                  apply absurd ft2; apply ne_failure; cases valid_T; assumption; assumption;
                }
          }
      | .star s e _ _ => cases hf;
      | .notP s e _ => match hs with
        | .notP (T := T) ft =>
          {
            match hf with
              | .notP (T := T) st =>
                {
                  apply absurd ft; apply ne_failure; cases valid_T; assumption; assumption;
                }
          }

  theorem PreAST.FailureAST.ne_success : ∀ {T : PreAST n b}, PreAST.IsValid T → FailureAST T → ¬SuccessAST T := by
    intro T valid_T hf hs;
    exact SuccessAST.ne_failure valid_T hs hf;

  theorem PreAST.PreAST.star_cannot_fail : ∀ {T : PreAST n b}, StarPreAST T → ¬FailureAST T := by
    intro T h_star h_fail;
    cases h_star; cases h_fail;

  def PreAST.IsMeaningful (T : PreAST n b) : Prop := SuccessAST T ∨ FailureAST T

  inductive PreAST.IsWellformed : PreAST n b → Prop where
    | ε :           IsMeaningful (.ε (n := n) (b := b) s e)
                    → IsWellformed (.ε (n := n) (b := b) s e)
    | any :         IsMeaningful (.any (n := n) (b := b) s e x)
                    → IsWellformed (.any (n := n) (b := b) s e x)
    | terminal :    IsMeaningful (.terminal (n := n) (b := b) s e a x)
                    → IsWellformed (.terminal (n := n) (b := b) s e a x)
    | nonTerminal : ∀ {sub_T : PreAST n b},
                    s = sub_T.start → e = sub_T.end
                    → IsWellformed sub_T
                    → IsWellformed (.nonTerminal s e A sub_T)
    | seq_F :       ∀ {T1 T2 : PreAST n b},
                    s = T1.start → T1.end = T2.start → e = T2.end → T2.start = T2.end
                    → IsWellformed T1 → FailureAST T1 → SkipPreAST T2
                    → IsWellformed (.seq s e T1 T2)
    | seq_S :       ∀ {T1 T2 : PreAST n b},
                    s = T1.start → T1.end = T2.start → e = T2.end
                    → IsWellformed T1 → SuccessAST T1 → IsWellformed T2
                    → IsWellformed (.seq s e T1 T2)
    | prior_S :     ∀ {T1 T2 : PreAST n b},
                    s = T1.start → s = T2.start → s = T2.end → e = T1.end
                    → IsWellformed T1 → SuccessAST T1 → SkipPreAST T2
                    → IsWellformed (.prior s e T1 T2)
    | prior_F :     ∀ {T1 T2 : PreAST n b},
                    s = T1.start → s = T2.start → e = T2.end
                    → IsWellformed T1 → FailureAST T1 → IsWellformed T2
                    → IsWellformed (.prior s e T1 T2)
    | star_S :      ∀ {T0 TS : PreAST n b},
                    s = T0.start → T0.end = TS.start → e = TS.end
                    → IsWellformed T0 → SuccessAST T0 → IsWellformed TS
                    → IsWellformed (.star s e T0 TS)
    | star_F :      ∀ {T0 TS : PreAST n b},
                    s = T0.start → T0.end = TS.start → TS.start = TS.end → s = e
                    → IsWellformed T0 → FailureAST T0 → SkipPreAST TS
                    → IsWellformed (.star s e T0 TS)
    | notP :        ∀ {sub_T : PreAST n b},
                    s = e → s = sub_T.start
                    → IsWellformed sub_T
                    → IsWellformed (.notP s e sub_T)

  theorem PreAST.skip_is_not_wellformed : ∀ {T : PreAST n b}, SkipPreAST T → ¬IsWellformed T := by
    intro T hskip hwf;
    cases hskip; cases hwf;

  theorem PreAST.valid_and_wellformed_implies_meaningful : ∀ {T : PreAST n b}, IsValid T → IsWellformed T → IsMeaningful T := by
    intro T h_valid hwf;
    match hwf with
    | .ε _ => assumption;
    | .any _ => assumption;
    | .terminal _ => assumption;
    | .nonTerminal _ _ hwfT =>
      {
        cases h_valid; cases valid_and_wellformed_implies_meaningful (by assumption) hwfT;
        apply Or.inl; constructor <;> assumption;
        apply Or.inr; constructor <;> assumption;
      }
    | .seq_F _ _ _ _ _ hf1 hskip2 =>
      {
        cases h_valid; apply Or.inr;
        apply FailureAST.seq_F <;> assumption;
      }
    | .seq_S _ _ _ _ hs1 hwf2 =>
      {
        cases h_valid; cases valid_and_wellformed_implies_meaningful (by assumption) hwf2;
        apply Or.inl; constructor <;> assumption;
        apply Or.inr; apply FailureAST.seq_SF <;> assumption;
      }
    | .prior_S _ _ _ _ _ hs1 hskip2 =>
      {
        cases h_valid; apply Or.inl;
        apply SuccessAST.prior_S <;> assumption;
      }
    | .prior_F _ _ _ _ hf1 hwf2 =>
      {
        cases h_valid; cases valid_and_wellformed_implies_meaningful (by assumption) hwf2;
        apply Or.inl; apply SuccessAST.prior_FS <;> assumption;
        apply Or.inr; constructor <;> assumption;
      }
    | .star_S (TS := TS) _ _ _ _ hs0 hwfS =>
      {
        match h_valid with
        | PreAST.IsValid.star _ _ _ svs =>
          match svs with
          | Or.inl hskip =>
            {
              apply absurd hwfS;
              apply skip_is_not_wellformed; assumption;
            }
          | Or.inr hstar =>
            {
              apply Or.inl; apply SuccessAST.star_SS;
              assumption;
              match valid_and_wellformed_implies_meaningful (by assumption) hwfS with
              | Or.inl _ => assumption
              | Or.inr hf => cases hstar; cases hf;
            }

      }
    | .star_F _ _ _ _ _ hf0 hskipS =>
      {
        cases h_valid; apply Or.inl;
        apply SuccessAST.star_F <;> assumption;
      }
    | .notP _ _ hwfT =>
      {
        cases h_valid; cases valid_and_wellformed_implies_meaningful (by assumption) hwfT;
        apply Or.inr; constructor <;> assumption;
        apply Or.inl; constructor <;> assumption;
      }

  theorem PreAST.valid_and_wellformed_implies_start_le_end : ∀ {T : PreAST n b}, IsValid T → IsWellformed T → T.start ≤ T.end := by
    intro T h_valid hwf;
    match hwf with
    | .ε hm =>
      {
        simp [PreAST.start, PreAST.end, PreAST.start, PreAST.end];
        match hm with
        | Or.inl hs => cases hs; apply Nat.le_of_eq; apply Fin.val_eq_of_eq; assumption;
      }
    | .any hm =>
      {
        simp [PreAST.start, PreAST.end, PreAST.start, PreAST.end];
        match hm with
        | Or.inl hs => cases hs; apply Nat.le_of_lt; apply Fin.lt_from_inbound_succ; assumption;
        | Or.inr hf => cases hf; apply Nat.le_of_eq; apply Fin.val_eq_of_eq; assumption;
      }
    | .terminal hm =>
      {
        simp [PreAST.start, PreAST.end, PreAST.start, PreAST.end];
        match hm with
        | Or.inl hs => cases hs; apply Nat.le_of_lt; apply Fin.lt_from_inbound_succ; assumption;
        | Or.inr hf => cases hf; apply Nat.le_of_lt; apply Fin.lt_from_inbound_succ; assumption; apply Nat.le_of_eq; apply Fin.val_eq_of_eq; assumption;
      }
    | .nonTerminal hssT heeT hwfT =>
      {
        cases h_valid; simp [PreAST.start, PreAST.end, PreAST.start, PreAST.end];
        rw [hssT, heeT];
        apply valid_and_wellformed_implies_start_le_end <;> assumption;
      }
    | .seq_F hss1 he1s2 hee2 hs2e2 hwf1 _ hskip2 =>
      {
        cases h_valid; simp [PreAST.start, PreAST.end, PreAST.start, PreAST.end];
        rw [hss1, hee2, ←hs2e2, ←he1s2]
        apply valid_and_wellformed_implies_start_le_end <;> assumption;
      }
    | .seq_S hss1 he1s2 hee2 hwf1 _ hwf2 =>
      {
        cases h_valid; simp [PreAST.start, PreAST.end, PreAST.start, PreAST.end];
        rw [hss1, hee2];
        apply Nat.le_trans;
        apply valid_and_wellformed_implies_start_le_end (by assumption) hwf1;
        rw [he1s2];
        apply valid_and_wellformed_implies_start_le_end (by assumption) hwf2;
      }
    | .prior_S hss1 _ _ hee1 hwf1 _ hskip2 =>
      {
        cases h_valid; simp [PreAST.start, PreAST.end, PreAST.start, PreAST.end];
        rw [hss1, hee1];
        apply valid_and_wellformed_implies_start_le_end (by assumption) hwf1;
      }
    | .prior_F _ hss2 hee2 _ _ hwf2 =>
      {
        cases h_valid; simp [PreAST.start, PreAST.end, PreAST.start, PreAST.end];
        rw [hss2, hee2];
        apply valid_and_wellformed_implies_start_le_end (by assumption) hwf2;
      }
    | .star_S (TS := TS) hss0 he0sS heeS hwf0 _ hwfS =>
      {
        cases h_valid; simp [PreAST.start, PreAST.end, PreAST.start, PreAST.end];
        rw [hss0, heeS];
        apply Nat.le_trans;
        apply valid_and_wellformed_implies_start_le_end (by assumption) hwf0;
        rw [he0sS];
        apply valid_and_wellformed_implies_start_le_end (by assumption) hwfS;
      }
    | .star_F _ _ _ hse _ _ hskipS =>
      {
        cases h_valid; simp [PreAST.start, PreAST.end, PreAST.start, PreAST.end];
        rw [hse];
        apply Nat.le_refl;
      }
    | .notP hse _ hwfT =>
      {
        cases h_valid; simp [PreAST.start, PreAST.end, PreAST.start, PreAST.end];
        rw [hse];
        apply Nat.le_refl;
      }

  structure AST (n : Nat) (b : Nat) where
    T : PreAST n b
    valid_T : PreAST.IsValid T
    wf_T : PreAST.IsWellformed T

  def AST.size (T : AST n b) : Nat := T.T.size
  def AST.start (T : AST n b) : Fin b := T.T.start
  def AST.end (T : AST n b) : Fin b := T.T.end

  theorem AST.meaningful (T : AST n b) : PreAST.IsMeaningful T.T := PreAST.valid_and_wellformed_implies_meaningful T.valid_T T.wf_T
  theorem AST.start_le_end (T : AST n b) : T.start ≤ T.end := by
    rw [AST.start, AST.end];
    apply PreAST.valid_and_wellformed_implies_start_le_end T.valid_T T.wf_T;

end AST


import Mathlib.GroupTheory.Submonoid.Basic
import Mathlib.Algebra.Divisibility.Basic
import Mathlib.GroupTheory.Submonoid.Membership
import Mathlib.Algebra.Associated

namespace Submonoid

variable {M N : Type _} [CommMonoid M] [CommMonoid N]

def Absorbing (S : Submonoid M) : Prop :=
  ∀ x y, x * y ∈ S → ∃ z ∈ S, Associated x z ∧ ∃ z ∈ S, Associated y z

section Basic

theorem absorbing_def {S : Submonoid M} :
    Absorbing S ↔ ∀ x y, x * y ∈ S → ∃ z ∈ S, Associated x z ∧ ∃ z ∈ S, Associated y z :=
  Iff.rfl

variable (M)

variable (N)

theorem top_absorbing : (⊤ : Submonoid M).Absorbing := fun x y _ =>
  ⟨x, Submonoid.mem_top _, Associated.refl _, y, Submonoid.mem_top _, Associated.refl _⟩

theorem bot_absorbing : (⊥ : Submonoid M).Absorbing := fun x y hxy =>
  ⟨1, (⊥ : Submonoid M).one_mem, associated_one_of_mul_eq_one _ (Submonoid.mem_bot.1 hxy), 1,
    (⊥ : Submonoid M).one_mem,
    associated_one_of_mul_eq_one _ (Submonoid.mem_bot.1 (by rwa [mul_comm] at hxy))⟩

theorem IsUnit.submonoid_absorbing : (IsUnit.submonoid M).Absorbing := fun x y hxy =>
  ⟨x, isUnit_of_mul_isUnit_left hxy, Associated.refl _, y, isUnit_of_mul_isUnit_right hxy,
    Associated.refl _⟩

theorem Associated.prod (x z : M × N) : Associated x z ↔ Associated x.1 z.1 ∧ Associated x.2 z.2 :=
  by
  refine'
    ⟨_, fun ⟨⟨u₁, hu₁⟩, ⟨u₂, hu₂⟩⟩ =>
      ⟨MulEquiv.prodUnits.invFun (u₁, u₂), Prod.eq_iff_fst_eq_snd_eq.2 ⟨hu₁, hu₂⟩⟩⟩
  rintro ⟨u, hu⟩
  cases' u.isUnit.exists_right_inv with b hb
  rw [Prod.mul_def, Prod.mk_eq_one] at hb
  rw [← hu, Prod.fst_mul, Prod.snd_mul]
  refine'
    ⟨(associated_mul_isUnit_right_iff (isUnit_of_mul_eq_one _ _ hb.1)).2 (Associated.refl _),
      (associated_mul_isUnit_right_iff (isUnit_of_mul_eq_one _ _ hb.2)).2 (Associated.refl _)⟩

theorem Submonoid.prod_absorbing (s : Submonoid M) (t : Submonoid N) :
    (s.prod t).Absorbing ↔ Absorbing s ∧ Absorbing t :=
  by
  refine' ⟨fun h => ⟨fun x y hxy => _, fun x y hxy => _⟩, _⟩
  · specialize h (x, 1) (y, 1)
    rw [Prod.mk_one_mul_mk_one] at h
    rcases h (Submonoid.mem_prod.2 ⟨hxy, t.one_mem⟩) with ⟨a, ha, ha₂, ⟨b, hb, hb₂⟩⟩
    exact
      ⟨a.1, (Submonoid.mem_prod.1 ha).1, ((Associated.prod _ _ _ _).1 ha₂).1, b.1,
        (Submonoid.mem_prod.1 hb).1, ((Associated.prod _ _ _ _).1 hb₂).1⟩
  · specialize h (1, x) (1, y)
    rw [Prod.one_mk_mul_one_mk] at h
    rcases h (Submonoid.mem_prod.2 ⟨s.one_mem, hxy⟩) with ⟨a, ha, ha₂, ⟨b, hb, hb₂⟩⟩
    exact
      ⟨a.2, (Submonoid.mem_prod.1 ha).2, ((Associated.prod _ _ _ _).1 ha₂).2, b.2,
        (Submonoid.mem_prod.1 hb).2, ((Associated.prod _ _ _ _).1 hb₂).2⟩
  · rintro ⟨hs, ht⟩ x y hxy
    rcases hs x.1 y.1 hxy.1 with ⟨z, hz, hz₂, ⟨z', hz', hz'₂⟩⟩
    rcases ht x.2 y.2 hxy.2 with ⟨w, hw, hw₂, ⟨w', hw', hw'₂⟩⟩
    exact
      ⟨(z, w), Submonoid.mem_prod.2 ⟨hz, hw⟩, (Associated.prod _ _ _ _).2 ⟨hz₂, hw₂⟩, (z', w'),
        Submonoid.mem_prod.2 ⟨hz', hw'⟩, (Associated.prod _ _ _ _).2 ⟨hz'₂, hw'₂⟩⟩

end Basic

section CommMonoid

theorem absorbing_iff_of_comm {S : Submonoid M} :
    Absorbing S ↔ ∀ x y, x * y ∈ S → ∃ z ∈ S, Associated x z :=
  by
  refine' ⟨fun hS x y hxy => _, fun h x y hxy => _⟩
  · rcases hS x y hxy with ⟨z, hz, hz₂, _⟩
    exact ⟨z, hz, hz₂⟩
  · obtain ⟨z, hz, hz₂⟩ := h x y hxy
    refine' ⟨z, hz, hz₂, _⟩
    rw [mul_comm] at hxy
    exact h y x hxy

end CommMonoid

end Submonoid


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

/-
# Lemma 2.1

## Main results

- `lemma_2_1`: Let F be a field and f ∈ F[x₀,…,xₙ]. Suppose that for 0 ≤ i ≤ n,
  the degree of f in xᵢ is at most tᵢ. Let S₀,…,Sₙ ⊆ F be subsets such that tᵢ < |Sᵢ|.
  Suppose that f(s₀,…,sₙ) = 0 for each (s₀,…,sₙ) ∈ S₀ × … × Sₙ. Then f = 0.

  This is Lemma 2.1 in Alon's paper "Combinatorial Nullstellensatz".
-/

open_locale big_operators

local attribute [instance] classical.prop_decidable

namespace mv_polynomial

private lemma lemma_2_1_fin_n { n : ℕ } {R : Type*} [comm_ring R] [is_domain R]
  (f : mv_polynomial (fin n) R)
  (S : fin n → finset R)
  (hS : ∀ i : fin n, degree_of i f < (S i).card)
  (hz : ∀ s : fin n → R, (∀ i : fin n, s i ∈ S i ) → eval s f = 0) :
  f = 0 :=
begin
  induction n with n hn,
  simp only [forall_const] at hz,
  apply (ring_equiv.map_eq_zero_iff (is_empty_ring_equiv R (fin 0))).1,
  simp only [is_empty_ring_equiv_apply],
  simpa using (hz fin.is_empty.elim),
  apply (ring_equiv.map_eq_zero_iff ↑(fin_succ_equiv R n)).1 ∘ polynomial.ext_iff.2,
  intro i,
  rw ← polynomial.coeff_zero i,
  apply hn (polynomial.coeff ((fin_succ_equiv R n) f) i),
  exact λ j, lt_of_le_of_lt (degree_of_coeff_fin_succ_equiv f j i) (hS j.succ),
  intros s hs,
  rw [ ← coeff_eval_eq_eval_coeff],
  suffices h : polynomial.map (eval s) (fin_succ_equiv R n f) = 0,
  { rw h,
    simp },
  by_contradiction c1,
  suffices h1 : (S 0).val ⊆ (polynomial.map (eval (λ (i : fin n), s i)) (fin_succ_equiv R n f)).roots,
  { simpa using lt_of_le_of_lt ((polynomial.card_le_degree_of_subset_roots h1).trans _) (hS 0),
    rw ← nat_degree_fin_succ_equiv f,
    exact polynomial.nat_degree_le_nat_degree (polynomial.degree_mono (polynomial.support_map_subset _ _)),},
  suffices h0 : ∀ s' : fin n → R, (∀ i : fin n, s' i ∈ S i.succ) → ∀ y : R, y ∈ S 0 →
    polynomial.eval y (polynomial.map (eval s') ((fin_succ_equiv R n) f)) = 0,
  { rw multiset.subset_iff,
    intros x hx,
    rw polynomial.mem_roots c1,
    simpa using h0 _ hs x hx },
  intros s' hs' y hy,
  rw [← eval_eq_eval_mv_eval', hz],
  intro i,
  by_cases c : i ≠ 0,
  { rw [ ←fin.succ_pred i c, fin.cons_succ],
    exact hs' (fin.pred i c) },
  { rwa [not_not.1 c, fin.cons_zero] },
end

/- Lemma 2.1 in Alon's "Combinatorial Nullstellensatz" paper. -/
lemma lemma_2_1 {R σ : Type*} [comm_ring R] [is_domain R] [fintype σ] (f : mv_polynomial σ R)
  (S : σ → finset R) (hS : ∀ i : σ, degree_of i f < (S i).card)
  (hz : ∀ s : σ → R, (∀ i : σ, s i ∈ S i ) → eval s f = 0) : f = 0 :=
begin
  rcases exists_fin_rename f with ⟨n, ⟨ψ,⟨hψ,⟨g,hg⟩⟩⟩⟩,
  rw hg,
  rw hg at hS,
  rw hg at hz,
  clear hg f,
  have h_S_nonempty : ∀ i, ∃ x, x ∈ S i,
  { intro i,
    apply multiset.card_pos_iff_exists_mem.1,
    convert lt_of_le_of_lt (zero_le _) (hS i), },
  have hs0 : ∃ s0 : σ → R, (∀ i : σ, s0 i ∈ S i ) := by apply classical.skolem.1 h_S_nonempty,
  cases hs0 with s0 hs0,
  by_cases c : nonempty (fin n),
  { have hS' : ∀ i : (fin n), degree_of i g < ((S ∘ ψ) i).card,
    { intro i,
      convert hS (ψ i),
      rw degree_of_rename_of_injective hψ i },
    suffices hz' : ∀ s : (fin n) → R, (∀ i : fin n, s i ∈ (S ∘ ψ) i ) → eval s g = 0,
      by simp [lemma_2_1_fin_n g (S ∘ ψ ) hS' hz'],
    intros s' h,
    let φ := @function.inv_fun (fin n) σ c ψ,
    have φ_left_inv := @function.left_inverse_inv_fun (fin n) σ c ψ hψ,
    let s : σ → R := λ i, if h : ∃ j : fin n, ψ j = i then (s' ∘ φ) i else s0 i,
    have hs' : s' = s ∘ ψ,
    { ext,
      have hx  : ∃ j, ψ j = ψ x := ⟨x, by refl⟩,
      simp only [function.comp_app, s, hx, dif_pos, φ, φ_left_inv x], },
    suffices hs : ∀ (i : σ), s i ∈ S i,
    { rw hs',
      convert hz s hs,
      simp only [eval, eval₂_hom_rename] },
    intro i,
    by_cases ch : ∃ (j : fin n), ψ j = i,
    { simp only [s, dite_eq_ite, function.comp_app, if_pos, ch, φ ],
      cases ch with j hj,
      simpa [← hj, φ_left_inv j] using h j},
    { simpa only [s, dite_eq_ite, if_neg, ch, not_false_iff] using hs0 i } },
  { simp only [not_nonempty_iff] at c,
    cases @C_surjective R _ (fin n) c g with a ha,
    simp only [←ha, rename_C] at hz,
    have t := hz s0 hs0,
    rw [eval_C] at t,
    simp [←ha, rename_C, t] },
end

end mv_polynomial


/-
Copyright (c) 2021 Anne Baanen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Anne Baanen, Ashvni Narayanan
-/
import field_theory.ratfunc
import ring_theory.algebraic
import ring_theory.dedekind_domain
import ring_theory.integrally_closed

/-!
# Function fields

This file defines a function field and the ring of integers corresponding to it.

## Main definitions
 - `function_field Fq F` states that `F` is a function field over the (finite) field `Fq`,
   i.e. it is a finite extension of the field of rational functions in one variable over `Fq`.
 - `function_field.ring_of_integers` defines the ring of integers corresponding to a function field
    as the integral closure of `polynomial Fq` in the function field.

## Implementation notes
The definitions that involve a field of fractions choose a canonical field of fractions,
but are independent of that choice. We also omit assumptions like `finite Fq` or
`is_scalar_tower (polynomial Fq) (fraction_ring (polynomial Fq)) F` in definitions,
adding them back in lemmas when they are needed.

## References
* [D. Marcus, *Number Fields*][marcus1977number]
* [J.W.S. Cassels, A. Frölich, *Algebraic Number Theory*][cassels1967algebraic]
* [P. Samuel, *Algebraic Theory of Numbers*][samuel1970algebraic]

## Tags
function field, ring of integers
-/

noncomputable theory

variables (Fq F : Type) [field Fq] [field F]

/-- `F` is a function field over the finite field `Fq` if it is a finite
extension of the field of rational functions in one variable over `Fq`.

Note that `F` can be a function field over multiple, non-isomorphic, `Fq`.
-/
abbreviation function_field [algebra (ratfunc Fq) F] : Prop :=
finite_dimensional (ratfunc Fq) F

/-- `F` is a function field over `Fq` iff it is a finite extension of `Fq(t)`. -/
protected lemma function_field_iff (Fqt : Type*) [field Fqt]
  [algebra (polynomial Fq) Fqt] [is_fraction_ring (polynomial Fq) Fqt]
  [algebra (ratfunc Fq) F] [algebra Fqt F]
  [algebra (polynomial Fq) F] [is_scalar_tower (polynomial Fq) Fqt F]
  [is_scalar_tower (polynomial Fq) (ratfunc Fq) F] :
  function_field Fq F ↔ finite_dimensional Fqt F :=
begin
  let e := is_localization.alg_equiv (non_zero_divisors (polynomial Fq)) (ratfunc Fq) Fqt,
  have : ∀ c (x : F), e c • x = c • x,
  { intros c x,
    rw [algebra.smul_def, algebra.smul_def],
    congr,
    refine congr_fun _ c,
    refine is_localization.ext (non_zero_divisors (polynomial Fq)) _ _ _ _ _ _ _;
      intros; simp only [alg_equiv.map_one, ring_hom.map_one, alg_equiv.map_mul, ring_hom.map_mul,
                         alg_equiv.commutes, ← is_scalar_tower.algebra_map_apply], },
  split; intro h; resetI,
  { let b := finite_dimensional.fin_basis (ratfunc Fq) F,
    exact finite_dimensional.of_fintype_basis (b.map_coeffs e this) },
  { let b := finite_dimensional.fin_basis Fqt F,
    refine finite_dimensional.of_fintype_basis (b.map_coeffs e.symm _),
    intros c x, convert (this (e.symm c) x).symm, simp only [e.apply_symm_apply] },
end

namespace function_field

/-- The function field analogue of `number_field.ring_of_integers`:
`function_field.ring_of_integers Fq Fqt F` is the integral closure of `Fq[t]` in `F`.

We don't actually assume `F` is a function field over `Fq` in the definition,
only when proving its properties.
-/
def ring_of_integers [algebra (polynomial Fq) F] := integral_closure (polynomial Fq) F

namespace ring_of_integers

variables [algebra (polynomial Fq) F]

instance : is_domain (ring_of_integers Fq F) :=
(ring_of_integers Fq F).is_domain

instance : is_integral_closure (ring_of_integers Fq F) (polynomial Fq) F :=
integral_closure.is_integral_closure _ _

variables [algebra (ratfunc Fq) F] [function_field Fq F]
variables [is_scalar_tower (polynomial Fq) (ratfunc Fq) F]

instance : is_fraction_ring (ring_of_integers Fq F) F :=
integral_closure.is_fraction_ring_of_finite_extension (ratfunc Fq) F

instance : is_integrally_closed (ring_of_integers Fq F) :=
integral_closure.is_integrally_closed_of_finite_extension (ratfunc Fq)

instance [is_separable (ratfunc Fq) F] :
  is_dedekind_domain (ring_of_integers Fq F) :=
is_integral_closure.is_dedekind_domain (polynomial Fq) (ratfunc Fq) F _

end ring_of_integers

end function_field


/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Robert Y. Lewis
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.ring_theory.witt_vector.truncated
import Mathlib.ring_theory.witt_vector.identities
import Mathlib.data.padics.ring_homs
import Mathlib.PostPort

universes u_1

namespace Mathlib

/-!

# Comparison isomorphism between `witt_vector p (zmod p)` and `ℤ_[p]`

We construct a ring isomorphism between `witt_vector p (zmod p)` and `ℤ_[p]`.
This isomorphism follows from the fact that both satisfy the universal property
of the inverse limit of `zmod (p^n)`.

## Main declarations

* `witt_vector.to_zmod_pow`: a family of compatible ring homs `𝕎 (zmod p) → zmod (p^k)`
* `witt_vector.equiv`: the isomorphism

-/

namespace truncated_witt_vector

theorem eq_of_le_of_cast_pow_eq_zero (p : ℕ) [hp : fact (nat.prime p)] (n : ℕ) (R : Type u_1)
    [comm_ring R] [char_p R p] (i : ℕ) (hin : i ≤ n) (hpi : ↑p ^ i = 0) : i = n :=
  sorry

theorem card_zmod (p : ℕ) [hp : fact (nat.prime p)] (n : ℕ) :
    fintype.card (truncated_witt_vector p n (zmod p)) = p ^ n :=
  eq.mpr
    (id
      (Eq._oldrec (Eq.refl (fintype.card (truncated_witt_vector p n (zmod p)) = p ^ n)) (card p n)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (fintype.card (zmod p) ^ n = p ^ n)) (zmod.card p)))
      (Eq.refl (p ^ n)))

theorem char_p_zmod (p : ℕ) [hp : fact (nat.prime p)] (n : ℕ) :
    char_p (truncated_witt_vector p n (zmod p)) (p ^ n) :=
  char_p_of_prime_pow_injective (truncated_witt_vector p n (zmod p)) p n (card_zmod p n)
    (eq_of_le_of_cast_pow_eq_zero p n (zmod p))

/--
The unique isomorphism between `zmod p^n` and `truncated_witt_vector p n (zmod p)`.

This isomorphism exists, because `truncated_witt_vector p n (zmod p)` is a finite ring
with characteristic and cardinality `p^n`.
-/
def zmod_equiv_trunc (p : ℕ) [hp : fact (nat.prime p)] (n : ℕ) :
    zmod (p ^ n) ≃+* truncated_witt_vector p n (zmod p) :=
  zmod.ring_equiv (truncated_witt_vector p n (zmod p)) (card_zmod p n)

theorem zmod_equiv_trunc_apply (p : ℕ) [hp : fact (nat.prime p)] (n : ℕ) {x : zmod (p ^ n)} :
    coe_fn (zmod_equiv_trunc p n) x =
        coe_fn (zmod.cast_hom (dvd_refl (p ^ n)) (truncated_witt_vector p n (zmod p))) x :=
  rfl

/--
The following diagram commutes:
```text
          zmod (p^n) ----------------------------> zmod (p^m)
            |                                        |
            |                                        |
            v                                        v
truncated_witt_vector p n (zmod p) ----> truncated_witt_vector p m (zmod p)
```
Here the vertical arrows are `truncated_witt_vector.zmod_equiv_trunc`,
the horizontal arrow at the top is `zmod.cast_hom`,
and the horizontal arrow at the bottom is `truncated_witt_vector.truncate`.
-/
theorem commutes (p : ℕ) [hp : fact (nat.prime p)] (n : ℕ) {m : ℕ} (hm : n ≤ m) :
    ring_hom.comp (truncate hm) (ring_equiv.to_ring_hom (zmod_equiv_trunc p m)) =
        ring_hom.comp (ring_equiv.to_ring_hom (zmod_equiv_trunc p n))
          (zmod.cast_hom (pow_dvd_pow p hm) (zmod (p ^ n))) :=
  ring_hom.ext_zmod (ring_hom.comp (truncate hm) (ring_equiv.to_ring_hom (zmod_equiv_trunc p m)))
    (ring_hom.comp (ring_equiv.to_ring_hom (zmod_equiv_trunc p n))
      (zmod.cast_hom (pow_dvd_pow p hm) (zmod (p ^ n))))

theorem commutes' (p : ℕ) [hp : fact (nat.prime p)] (n : ℕ) {m : ℕ} (hm : n ≤ m)
    (x : zmod (p ^ m)) :
    coe_fn (truncate hm) (coe_fn (zmod_equiv_trunc p m) x) =
        coe_fn (zmod_equiv_trunc p n)
          (coe_fn (zmod.cast_hom (pow_dvd_pow p hm) (zmod (p ^ n))) x) :=
  sorry

theorem commutes_symm' (p : ℕ) [hp : fact (nat.prime p)] (n : ℕ) {m : ℕ} (hm : n ≤ m)
    (x : truncated_witt_vector p m (zmod p)) :
    coe_fn (ring_equiv.symm (zmod_equiv_trunc p n)) (coe_fn (truncate hm) x) =
        coe_fn (zmod.cast_hom (pow_dvd_pow p hm) (zmod (p ^ n)))
          (coe_fn (ring_equiv.symm (zmod_equiv_trunc p m)) x) :=
  sorry

/--
The following diagram commutes:
```text
truncated_witt_vector p n (zmod p) ----> truncated_witt_vector p m (zmod p)
            |                                        |
            |                                        |
            v                                        v
          zmod (p^n) ----------------------------> zmod (p^m)
```
Here the vertical arrows are `(truncated_witt_vector.zmod_equiv_trunc p _).symm`,
the horizontal arrow at the top is `zmod.cast_hom`,
and the horizontal arrow at the bottom is `truncated_witt_vector.truncate`.
-/
theorem commutes_symm (p : ℕ) [hp : fact (nat.prime p)] (n : ℕ) {m : ℕ} (hm : n ≤ m) :
    ring_hom.comp (ring_equiv.to_ring_hom (ring_equiv.symm (zmod_equiv_trunc p n))) (truncate hm) =
        ring_hom.comp (zmod.cast_hom (pow_dvd_pow p hm) (zmod (p ^ n)))
          (ring_equiv.to_ring_hom (ring_equiv.symm (zmod_equiv_trunc p m))) :=
  ring_hom.ext fun (x : truncated_witt_vector p m (zmod p)) => commutes_symm' p n hm x

end truncated_witt_vector

namespace witt_vector

/--
`to_zmod_pow` is a family of compatible ring homs. We get this family by composing
`truncated_witt_vector.zmod_equiv_trunc` (in right-to-left direction)
with `witt_vector.truncate`.
-/
def to_zmod_pow (p : ℕ) [hp : fact (nat.prime p)] (k : ℕ) :
    witt_vector p (zmod p) →+* zmod (p ^ k) :=
  ring_hom.comp
    (ring_equiv.to_ring_hom (ring_equiv.symm (truncated_witt_vector.zmod_equiv_trunc p k)))
    (truncate k)

theorem to_zmod_pow_compat (p : ℕ) [hp : fact (nat.prime p)] (m : ℕ) (n : ℕ) (h : m ≤ n) :
    ring_hom.comp (zmod.cast_hom (pow_dvd_pow p h) (zmod (p ^ m))) (to_zmod_pow p n) =
        to_zmod_pow p m :=
  sorry

/--
`to_padic_int` lifts `to_zmod_pow : 𝕎 (zmod p) →+* zmod (p ^ k)` to a ring hom to `ℤ_[p]`
using `padic_int.lift`, the universal property of `ℤ_[p]`.
-/
def to_padic_int (p : ℕ) [hp : fact (nat.prime p)] : witt_vector p (zmod p) →+* padic_int p :=
  padic_int.lift (to_zmod_pow_compat p)

theorem zmod_equiv_trunc_compat (p : ℕ) [hp : fact (nat.prime p)] (k₁ : ℕ) (k₂ : ℕ) (hk : k₁ ≤ k₂) :
    ring_hom.comp (truncated_witt_vector.truncate hk)
          (ring_hom.comp (ring_equiv.to_ring_hom (truncated_witt_vector.zmod_equiv_trunc p k₂))
            (padic_int.to_zmod_pow k₂)) =
        ring_hom.comp (ring_equiv.to_ring_hom (truncated_witt_vector.zmod_equiv_trunc p k₁))
          (padic_int.to_zmod_pow k₁) :=
  sorry

/--
`from_padic_int` uses `witt_vector.lift` to lift `truncated_witt_vector.zmod_equiv_trunc`
composed with `padic_int.to_zmod_pow` to a ring hom `ℤ_[p] →+* 𝕎 (zmod p)`.
-/
def from_padic_int (p : ℕ) [hp : fact (nat.prime p)] : padic_int p →+* witt_vector p (zmod p) :=
  lift
    (fun (k : ℕ) =>
      ring_hom.comp (ring_equiv.to_ring_hom (truncated_witt_vector.zmod_equiv_trunc p k))
        (padic_int.to_zmod_pow k))
    (zmod_equiv_trunc_compat p)

theorem to_padic_int_comp_from_padic_int (p : ℕ) [hp : fact (nat.prime p)] :
    ring_hom.comp (to_padic_int p) (from_padic_int p) = ring_hom.id (padic_int p) :=
  sorry

theorem to_padic_int_comp_from_padic_int_ext (p : ℕ) [hp : fact (nat.prime p)] (x : padic_int p) :
    coe_fn (ring_hom.comp (to_padic_int p) (from_padic_int p)) x =
        coe_fn (ring_hom.id (padic_int p)) x :=
  sorry

theorem from_padic_int_comp_to_padic_int (p : ℕ) [hp : fact (nat.prime p)] :
    ring_hom.comp (from_padic_int p) (to_padic_int p) = ring_hom.id (witt_vector p (zmod p)) :=
  sorry

theorem from_padic_int_comp_to_padic_int_ext (p : ℕ) [hp : fact (nat.prime p)]
    (x : witt_vector p (zmod p)) :
    coe_fn (ring_hom.comp (from_padic_int p) (to_padic_int p)) x =
        coe_fn (ring_hom.id (witt_vector p (zmod p))) x :=
  sorry

/--
The ring of Witt vectors over `zmod p` is isomorphic to the ring of `p`-adic integers. This
equivalence is witnessed by `witt_vector.to_padic_int` with inverse `witt_vector.from_padic_int`.
-/
def equiv (p : ℕ) [hp : fact (nat.prime p)] : witt_vector p (zmod p) ≃+* padic_int p :=
  ring_equiv.mk (⇑(to_padic_int p)) (⇑(from_padic_int p)) (from_padic_int_comp_to_padic_int_ext p)
    (to_padic_int_comp_from_padic_int_ext p) sorry sorry

end Mathlib


/-
Copyright (c) 2020 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.module.linear_map
import Mathlib.algebra.opposites
import Mathlib.PostPort

universes u v

namespace Mathlib

/-!
# Module operations on `Mᵒᵖ`

This file contains definitions that could not be placed into `algebra.opposites` due to import
cycles.
-/

namespace opposite

/-- `opposite.distrib_mul_action` extends to a `semimodule` -/
protected instance semimodule (R : Type u) {M : Type v} [semiring R] [add_comm_monoid M]
    [semimodule R M] : semimodule R (Mᵒᵖ) :=
  semimodule.mk sorry sorry

/-- The function `op` is a linear equivalence. -/
def op_linear_equiv (R : Type u) {M : Type v} [semiring R] [add_comm_monoid M] [semimodule R M] :
    linear_equiv R M (Mᵒᵖ) :=
  linear_equiv.mk (add_equiv.to_fun op_add_equiv) sorry sorry (add_equiv.inv_fun op_add_equiv) sorry
    sorry

@[simp] theorem coe_op_linear_equiv (R : Type u) {M : Type v} [semiring R] [add_comm_monoid M]
    [semimodule R M] : ⇑(op_linear_equiv R) = op :=
  rfl

@[simp] theorem coe_op_linear_equiv_symm (R : Type u) {M : Type v} [semiring R] [add_comm_monoid M]
    [semimodule R M] : ⇑(linear_equiv.symm (op_linear_equiv R)) = unop :=
  rfl

@[simp] theorem coe_op_linear_equiv_to_linear_map (R : Type u) {M : Type v} [semiring R]
    [add_comm_monoid M] [semimodule R M] : ⇑(linear_equiv.to_linear_map (op_linear_equiv R)) = op :=
  rfl

@[simp] theorem coe_op_linear_equiv_symm_to_linear_map (R : Type u) {M : Type v} [semiring R]
    [add_comm_monoid M] [semimodule R M] :
    ⇑(linear_equiv.to_linear_map (linear_equiv.symm (op_linear_equiv R))) = unop :=
  rfl

@[simp] theorem op_linear_equiv_to_add_equiv (R : Type u) {M : Type v} [semiring R]
    [add_comm_monoid M] [semimodule R M] :
    linear_equiv.to_add_equiv (op_linear_equiv R) = op_add_equiv :=
  rfl

@[simp] theorem op_linear_equiv_symm_to_add_equiv (R : Type u) {M : Type v} [semiring R]
    [add_comm_monoid M] [semimodule R M] :
    linear_equiv.to_add_equiv (linear_equiv.symm (op_linear_equiv R)) =
        add_equiv.symm op_add_equiv :=
  rfl

end Mathlib


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl
-/
import logic.function.basic
import tactic.ext
import tactic.lint
import tactic.simps

/-!
# Subtypes

This file provides basic API for subtypes, which are defined in core.

A subtype is a type made from restricting another type, say `α`, to its elements that satisfy some
predicate, say `p : α → Prop`. Specifically, it is the type of pairs `⟨val, property⟩` where
`val : α` and `property : p val`. It is denoted `subtype p` and notation `{val : α // p val}` is
available.

A subtype has a natural coercion to the parent type, by coercing `⟨val, property⟩` to `val`. As
such, subtypes can be thought of as bundled sets, the difference being that elements of a set are
still of type `α` while elements of a subtype aren't.
-/

open function

namespace subtype
variables {α β γ : Sort*} {p q : α → Prop}

/-- See Note [custom simps projection] -/
def simps.coe (x : subtype p) : α := x

initialize_simps_projections subtype (val → coe)

/-- A version of `x.property` or `x.2` where `p` is syntactically applied to the coercion of `x`
  instead of `x.1`. A similar result is `subtype.mem` in `data.set.basic`. -/
lemma prop (x : subtype p) : p x := x.2

@[simp] lemma val_eq_coe {x : subtype p} : x.1 = ↑x := rfl

@[simp] protected theorem «forall» {q : {a // p a} → Prop} :
  (∀ x, q x) ↔ (∀ a b, q ⟨a, b⟩) :=
⟨assume h a b, h ⟨a, b⟩, assume h ⟨a, b⟩, h a b⟩

/-- An alternative version of `subtype.forall`. This one is useful if Lean cannot figure out `q`
  when using `subtype.forall` from right to left. -/
protected theorem forall' {q : ∀ x, p x → Prop} :
  (∀ x h, q x h) ↔ (∀ x : {a // p a}, q x x.2) :=
(@subtype.forall _ _ (λ x, q x.1 x.2)).symm

@[simp] protected theorem «exists» {q : {a // p a} → Prop} :
  (∃ x, q x) ↔ (∃ a b, q ⟨a, b⟩) :=
⟨assume ⟨⟨a, b⟩, h⟩, ⟨a, b, h⟩, assume ⟨a, b, h⟩, ⟨⟨a, b⟩, h⟩⟩

/-- An alternative version of `subtype.exists`. This one is useful if Lean cannot figure out `q`
  when using `subtype.exists` from right to left. -/
protected theorem exists' {q : ∀x, p x → Prop} :
  (∃ x h, q x h) ↔ (∃ x : {a // p a}, q x x.2) :=
(@subtype.exists _ _ (λ x, q x.1 x.2)).symm

@[ext] protected lemma ext : ∀ {a1 a2 : {x // p x}}, (a1 : α) = (a2 : α) → a1 = a2
| ⟨x, h1⟩ ⟨.(x), h2⟩ rfl := rfl

lemma ext_iff {a1 a2 : {x // p x}} : a1 = a2 ↔ (a1 : α) = (a2 : α) :=
⟨congr_arg _, subtype.ext⟩

lemma heq_iff_coe_eq (h : ∀ x, p x ↔ q x) {a1 : {x // p x}} {a2 : {x // q x}} :
  a1 == a2 ↔ (a1 : α) = (a2 : α) :=
eq.rec (λ a2', heq_iff_eq.trans ext_iff) (funext $ λ x, propext (h x)) a2

lemma heq_iff_coe_heq {α β : Sort*} {p : α → Prop} {q : β → Prop} {a : {x // p x}}
  {b : {y // q y}} (h : α = β) (h' : p == q) :
  a == b ↔ (a : α) == (b : β) :=
by { subst h, subst h', rw [heq_iff_eq, heq_iff_eq, ext_iff] }

lemma ext_val {a1 a2 : {x // p x}} : a1.1 = a2.1 → a1 = a2 :=
subtype.ext

lemma ext_iff_val {a1 a2 : {x // p x}} : a1 = a2 ↔ a1.1 = a2.1 :=
ext_iff

@[simp] theorem coe_eta (a : {a // p a}) (h : p a) : mk ↑a h = a := subtype.ext rfl

@[simp] theorem coe_mk (a h) : (@mk α p a h : α) = a := rfl

@[simp, nolint simp_nf] -- built-in reduction doesn't always work
theorem mk_eq_mk {a h a' h'} : @mk α p a h = @mk α p a' h' ↔ a = a' :=
ext_iff

theorem coe_eq_iff {a : {a // p a}} {b : α} : ↑a = b ↔ ∃ h, a = ⟨b, h⟩ :=
⟨λ h, h ▸ ⟨a.2, (coe_eta _ _).symm⟩, λ ⟨hb, ha⟩, ha.symm ▸ rfl⟩

theorem coe_injective : injective (coe : subtype p → α) :=
λ a b, subtype.ext

theorem val_injective : injective (@val _ p) :=
coe_injective

/-- Restrict a (dependent) function to a subtype -/
def restrict {α} {β : α → Type*} (f : Π x, β x) (p : α → Prop) (x : subtype p) : β x.1 :=
f x

lemma restrict_apply {α} {β : α → Type*} (f : Π x, β x) (p : α → Prop) (x : subtype p) :
  restrict f p x = f x.1 :=
by refl

lemma restrict_def {α β} (f : α → β) (p : α → Prop) : restrict f p = f ∘ coe :=
by refl

lemma restrict_injective {α β} {f : α → β} (p : α → Prop) (h : injective f) :
  injective (restrict f p) :=
h.comp coe_injective

lemma surjective_restrict {α} {β : α → Type*} [ne : Π a, nonempty (β a)] (p : α → Prop) :
  surjective (λ f : Π x, β x, restrict f p) :=
begin
  letI := classical.dec_pred p,
  refine λ f, ⟨λ x, if h : p x then f ⟨x, h⟩ else nonempty.some (ne x), funext $ _⟩,
  rintro ⟨x, hx⟩,
  exact dif_pos hx
end

/-- Defining a map into a subtype, this can be seen as an "coinduction principle" of `subtype`-/
@[simps] def coind {α β} (f : α → β) {p : β → Prop} (h : ∀ a, p (f a)) : α → subtype p :=
λ a, ⟨f a, h a⟩

theorem coind_injective {α β} {f : α → β} {p : β → Prop} (h : ∀ a, p (f a))
  (hf : injective f) : injective (coind f h) :=
λ x y hxy, hf $ by apply congr_arg subtype.val hxy

theorem coind_surjective {α β} {f : α → β} {p : β → Prop} (h : ∀ a, p (f a))
  (hf : surjective f) : surjective (coind f h) :=
λ x, let ⟨a, ha⟩ := hf x in ⟨a, coe_injective ha⟩

theorem coind_bijective {α β} {f : α → β} {p : β → Prop} (h : ∀ a, p (f a))
  (hf : bijective f) : bijective (coind f h) :=
⟨coind_injective h hf.1, coind_surjective h hf.2⟩

/-- Restriction of a function to a function on subtypes. -/
@[simps] def map {p : α → Prop} {q : β → Prop} (f : α → β) (h : ∀ a, p a → q (f a)) :
  subtype p → subtype q :=
λ x, ⟨f x, h x x.prop⟩

theorem map_comp {p : α → Prop} {q : β → Prop} {r : γ → Prop} {x : subtype p}
  (f : α → β) (h : ∀ a, p a → q (f a)) (g : β → γ) (l : ∀ a, q a → r (g a)) :
  map g l (map f h x) = map (g ∘ f) (assume a ha, l (f a) $ h a ha) x :=
rfl

theorem map_id {p : α → Prop} {h : ∀ a, p a → p (id a)} : map (@id α) h = id :=
funext $ assume ⟨v, h⟩, rfl

lemma map_injective {p : α → Prop} {q : β → Prop} {f : α → β} (h : ∀ a, p a → q (f a))
  (hf : injective f) : injective (map f h) :=
coind_injective _ $ hf.comp coe_injective

lemma map_involutive {p : α → Prop} {f : α → α} (h : ∀ a, p a → p (f a))
  (hf : involutive f) : involutive (map f h) :=
λ x, subtype.ext (hf x)

instance [has_equiv α] (p : α → Prop) : has_equiv (subtype p) :=
⟨λ s t, (s : α) ≈ (t : α)⟩

theorem equiv_iff [has_equiv α] {p : α → Prop} {s t : subtype p} :
  s ≈ t ↔ (s : α) ≈ (t : α) :=
iff.rfl

variables [setoid α]

protected theorem refl (s : subtype p) : s ≈ s :=
setoid.refl ↑s

protected theorem symm {s t : subtype p} (h : s ≈ t) : t ≈ s :=
setoid.symm h

protected theorem trans {s t u : subtype p} (h₁ : s ≈ t) (h₂ : t ≈ u) : s ≈ u :=
setoid.trans h₁ h₂

theorem equivalence (p : α → Prop) : equivalence (@has_equiv.equiv (subtype p) _) :=
mk_equivalence _ subtype.refl (@subtype.symm _ p _) (@subtype.trans _ p _)

instance (p : α → Prop) : setoid (subtype p) :=
setoid.mk (≈) (equivalence p)

end subtype

namespace subtype
/-! Some facts about sets, which require that `α` is a type. -/
variables {α β γ : Type*} {p : α → Prop}

@[simp] lemma coe_prop {S : set α} (a : {a // a ∈ S}) : ↑a ∈ S := a.prop

lemma val_prop {S : set α} (a : {a // a ∈ S}) : a.val ∈ S := a.property

end subtype


import algebra.category.Group.limits
import for_mathlib.Profinite.extend
import Lbar.basic
import Lbar.functor
import pseudo_normed_group.category.strictProFiltPseuNormGrpWithTinv
import pseudo_normed_group.bounded_limits

noncomputable theory

universes u v

open_locale nnreal

set_option pp.universes true

open Lbar Profinite CommGroup category_theory.limits

lemma limit_torsion_free_to_Ab
  {C : Type u} [category_theory.small_category C] (J : C ⥤ Ab.{u})
  (h_tf : ∀ j, no_zero_smul_divisors ℤ (J.obj j))
  : no_zero_smul_divisors ℤ (limit J).α :=
begin
  let L := get_limit_cone _,
  haveI := AddCommGroup.forget_preserves_limits.{u u},
  have h_inj := @concrete.to_product_injective_of_is_limit AddCommGroup.{u} _ _
    C _ J _ L.cone L.is_limit,
  fconstructor,
  intros c x hx,
  let φ := λ x : (limit J), λ j, (L.cone.π.app j) x,
  have h1: φ 0 = 0,
  { ext j,
    exact (L.cone.π.app j).2 },
  have h2: φ (c • x) = c • φ x,
  { ext j,
    exact map_zsmul (L.cone.π.app j) _ _ },
  apply_fun φ at hx,
  simp only [h1, h2, pi.zero_def, function.funext_iff, pi.smul_apply, smul_eq_zero] at hx,
  by_cases hc : c = 0,
  { apply or.intro_left, exact hc},
  { simp only [hc, false_or] at hx,
    apply or.intro_right,
    apply h_inj,
    funext j,
    specialize hx j,
    simp only [_root_.map_zero],
    exact hx },
end

--[FAE] not needed for LTE, may be for mathlib?
lemma add_comm_group.limit_on_nat_torsion_free
  (J : (category_theory.as_small.{u} ℕ) ⥤ AddCommGroup.{u})
  (h_tf : ∀ j, no_zero_smul_divisors ℤ (J.obj j))
  : no_zero_smul_divisors ℤ (limit J).α := limit_torsion_free_to_Ab J h_tf

open CompHausFiltPseuNormGrp₁ category_theory

instance : concrete_category.{u} PseuNormGrp₁.{u} :=
{ forget :=
  { obj := λ M, M,
    map := λ M N f, f,
    map_id' := λ M, rfl,
    map_comp' := λ _ _ _ f g, rfl },
  forget_faithful := { map_injective' := λ M N f g h, by { ext, dsimp at h, rw h, } } }

lemma PNG₁.iso_injective {X Y : PseuNormGrp₁.{u}} (f : X ≅ Y) :
  function.injective f.hom :=
begin
  intros x y h,
  apply_fun f.inv at h,
  simp only [← category_theory.comp_apply, f.hom_inv_id] at h,
  exact h,
end

lemma PNG₁.map_zsmul {X Y : PseuNormGrp₁} (f : X ⟶ Y) (n : ℤ) (x : X) :
  f (n • x) = n • f x :=
f.to_add_monoid_hom.map_zsmul _ _

namespace Profinite

lemma extend_torsion_free (A : Fintype.{u} ⥤ CompHausFiltPseuNormGrp₁)
  (hA : ∀ X, no_zero_smul_divisors ℤ (A.obj X)) (S : Profinite) :
  no_zero_smul_divisors ℤ ((Profinite.extend A).obj S) :=
begin
  let T := Ab.explicit_limit_cone.{u u}
    ((S.fintype_diagram ⋙ A ⋙ to_PNG₁) ⋙ PseuNormGrp₁.to_Ab),
  set T' := limit.cone.{u u} ((S.fintype_diagram ⋙ A ⋙ to_PNG₁) ⋙ PseuNormGrp₁.to_Ab) with hT',
  let hT : is_limit T := Ab.explicit_limit_cone_is_limit _,
  let E := PseuNormGrp₁.bounded_cone.{u} ⟨T,hT⟩,
  let hE : is_limit E := PseuNormGrp₁.bounded_cone_is_limit _,
  suffices claim : no_zero_smul_divisors ℤ E.X,
  { resetI,
    let iso : to_PNG₁.obj ((extend (A)).obj S) ≅ E.X :=
      (is_limit_of_preserves to_PNG₁
      (limit.is_limit _)).cone_point_unique_up_to_iso hE,
    apply function.injective.no_zero_smul_divisors iso.hom (PNG₁.iso_injective _),
    any_goals { apply_instance },
    { apply strict_pseudo_normed_group_hom.map_zero },
    { intros, rw PNG₁.map_zsmul } },
  let ι : E.X →+ T.X := add_subgroup.subtype _,
  apply function.injective.no_zero_smul_divisors ι (subtype.val_injective.{u+1}) ι.map_zero,
  any_goals { apply_instance },
  { intros c x, apply ι.map_zsmul, },
  let iso_pts := functor.map_iso (limits.cones.forget.{u} _)
    (hT.unique_up_to_iso (limit_cone.is_limit.{u u u u+1} _)),
  let φ := (@iso.AddCommGroup_iso_to_add_equiv.{u} T.X T'.X iso_pts),
  apply function.injective.no_zero_smul_divisors φ φ.injective φ.map_zero,
  { intros c x,
    exact map_zsmul φ _ _ },
  apply limit_torsion_free_to_Ab.{u},
  intro j,
  exact hA ((S.fintype_diagram).obj j),
end

end Profinite