import Spa.localization_Huber
import Spa.presheaf
import sheaves.stalk_of_rings

/-!
# The valuation on the stalk

We define the valuations on the stalks of the structure presheaf of the adic spectrum.

The strategy is as follows:

1. Recall that a point in the adic spectrum is an equivalence class of valuations.
We pick a representative v. This valuation has a valuation field
that does not depend on the choice of representative (up to isomorphism).

2. Define a map from the stalk above [v] to K_v-hat, the completion of the valuation field of v.

3. Extend v to the completion of its valuation field.

4. Pullback v along the map constructed in 2.

The hard parts of this outline are #2 and #3,
however #3 has been dealt with in valuation/valuation_field_completion.lean.
That leaves us with #2.

The stalk of a presheaf F at a point x consists of “germs”:
pairs (U,s) of an open neighbourhood U of x and a section s in F(U),
modulo an equivalence relation.

To define a map out of the stalk, we can use a recursor,
and define the map on the sections s in F(U) for open neigbourhoods U of x.
But we have to check a compatibility condition, and this takes some effort.

Let us translate this to the context of the structure presheaf of the adic spectrum.
The sections above a rational open subset R(T/s) are:

  rat_open_data_completion r := A<T/s>

* We define a map A<T/s> → K_v-hat.
* We show that this map satisfies the property that if v in D(T1,s1) ⊂ D(T2,s2) then
  the maps A<Ti/si> → K_v-hat commute with the restriction map.
* We then show that we can get compatible maps O_X(U) → K_v-hat for an arbitrary open with v ∈ U.

Once this is in place, we can apply the recursor, to get the desired map from #2.
-/

open_locale classical
open topological_space valuation Spv spa uniform_space

namespace spa

variable {A : Huber_pair}

local attribute [instance] valued.uniform_space

namespace rational_open_data

/-- The natural map from A<T/s> to the completion of the valuation field of a valuation v
contained in R(T/s). -/
noncomputable def to_complete_valuation_field (r : rational_open_data A) {v : spa A}
  (hv : v ∈ r.open_set) :
  rat_open_data_completion r → completion (valuation_field (Spv.out v.1)) :=
completion.map (Huber_pair.rational_open_data.to_valuation_field hv)

variables {r r1 r2 : rational_open_data A} {v : spa A} (hv : v ∈ r.open_set)

/-- The natural map from A<T/s> to the completion of the valuation field of a valuation v
contained in R(T/s) is a ring homomorphism. -/
instance to_complete_valuation_field_is_ring_hom :
  is_ring_hom (r.to_complete_valuation_field hv) :=
completion.is_ring_hom_map (Huber_pair.rational_open_data.to_valuation_field_cts hv)

-- Next we need to show that the completed maps to K_v-hat
-- all commute with the restriction maps.

/-- The maps from rationals opens to completions commute with allowable restriction maps. -/
theorem to_valuation_field_commutes (hv1 : v ∈ r1.open_set) (hv2 : v ∈ r2.open_set) (h : r1 ≤ r2) :
  (r2.to_complete_valuation_field hv2) ∘ (rat_open_data_completion.restriction h) =
  (r1.to_complete_valuation_field hv1) :=
begin
  delta to_complete_valuation_field,
  delta rat_open_data_completion.restriction,
  have uc1 : uniform_continuous (rational_open_data.localization_map h),
    from rational_open_data.localization_map_is_uniform_continuous h,
  have uc2 : uniform_continuous (Huber_pair.rational_open_data.to_valuation_field hv2),
    from uniform_continuous_of_continuous (Huber_pair.rational_open_data.to_valuation_field_cts hv2),
  rw [Huber_pair.rational_open_data.to_valuation_field_commutes hv1 hv2 h, completion.map_comp uc2 uc1]
end

end rational_open_data

-- Now we need to show that for any 𝒪_X(U) with v in U we have a map to K_v-hat.
-- First let's write a noncomputable function which gets a basis element.
section
variables {v : spa A} {U : opens (spa A)}

lemma exists_rational_open_subset (hv : v ∈ U) :
  ∃ r : rational_open_data_subsets U, v ∈ r.1.open_set :=
begin
  suffices : U.1 ∈ nhds v,
  { rw mem_nhds_of_is_topological_basis (rational_basis.is_basis) at this,
    rcases this with ⟨_, ⟨r, rfl⟩, hv, hr⟩,
    use ⟨r, hr⟩,
    exact hv, },
  apply mem_nhds_sets U.2 hv,
end

/-- Given an open set U and a valuation v, this function chooses a random rational open subset
containing v and contained in U. -/
noncomputable def rational_open_subset_nhd (hv : v ∈ U) :
  rational_open_data_subsets U :=
classical.some $ spa.exists_rational_open_subset hv

lemma mem_rational_open_subset_nhd (hv : v ∈ U) :
  v ∈ (spa.rational_open_subset_nhd hv).1.open_set :=
classical.some_spec $ spa.exists_rational_open_subset hv

end

namespace presheaf
open rational_open_data
variables {v : spa A} {U : opens (spa A)} (hv : v ∈ U) (f : spa.presheaf_value U)

/-- The map from F(U) to K_v for v ∈ U, that restricts a section of the structure presheaf
to the completion of the valuation field of v. -/
noncomputable def to_valuation_field_completion :
  completion (valuation_field (Spv.out v.1)) :=
to_complete_valuation_field _ (spa.mem_rational_open_subset_nhd hv) $
  f.1 $ spa.rational_open_subset_nhd hv

/-- Restricting a section of the structure presheaf to a smaller open set is a ring homomorphism.-/
instance restriction_is_ring_hom (U : opens (spa A)) (r : rational_open_data_subsets U) :
  is_ring_hom (λ (f : presheaf_value U), f.val r) :=
{ map_one := rfl,
  map_mul := λ _ _, rfl,
  map_add := λ _ _, rfl }

/-- The map that restricts a section of the structure presheaf above U to the completion of
the valuation field of v ∈ U is a ring homomorphism. -/
instance : is_ring_hom (to_valuation_field_completion hv) :=
begin
  show is_ring_hom
    ((to_complete_valuation_field _ (spa.mem_rational_open_subset_nhd hv)) ∘
      (λ (f : presheaf_value U), (f.val (spa.rational_open_subset_nhd hv)))),
  exact is_ring_hom.comp _ _,
end

-- We need to prove that if V ⊆ U then to_valuation_field_completion commutes with restriction.

-- Before we even start with this terrifying noncomputable spa.rational_open_subset_nhd
-- let's check that spa.rat_open_data_completion.to_complete_valuation_field commutes with ≤.

-- We will place these helper lemmas in a separate namespace

namespace to_valuation_field_completion_well_defined
variables {r1 r2 : rational_open_data_subsets U}
variables (h1 : v ∈ r1.1.open_set) (h2 : v ∈ r2.1.open_set)
include h1 h2

lemma aux₁ :
  to_complete_valuation_field _ h1 (f.1 r1) = to_complete_valuation_field _
    (show v ∈ (r1.1.inter r2.1).open_set, by { rw inter_open_set, exact ⟨h1, h2⟩ })
  (f.1 (rational_open_data_subsets_inter r1 r2)) :=
begin
  rw ← to_valuation_field_commutes h1 _ (rational_open_data.le_inter_left r1.1 r2.1),
  swap, { rw rational_open_data.inter_open_set, exact ⟨h1, h2⟩ },
  delta function.comp,
  congr' 1,
  -- exact times out here; convert closes the goal really quickly
  convert f.2 r1 (rational_open_data_subsets_inter r1 r2) _,
end

-- now the other way
lemma aux₂ :
  to_complete_valuation_field _ h2 (f.1 r2) = to_complete_valuation_field _
    (show v ∈ (r1.1.inter r2.1).open_set, by { rw inter_open_set, exact ⟨h1, h2⟩ })
  (f.1 (rational_open_data_subsets_inter r1 r2)) :=
begin
  rw ← to_valuation_field_commutes h2 _ (rational_open_data.le_inter_right r1.1 r2.1),
  swap, { rw rational_open_data.inter_open_set, exact ⟨h1, h2⟩ },
  delta function.comp,
  congr' 1,
  -- exact times out here; convert closes the goal really quickly
  convert f.2 r2 (rational_open_data_subsets_inter r1 r2) _,
end

-- now let's check it agrees on any rational_open_data_subsets
lemma aux₃ :
  to_complete_valuation_field _ h1 (f.1 r1) = to_complete_valuation_field _ h2 (f.1 r2) :=
by rw [aux₁ f h1 h2, aux₂ f h1 h2]

end to_valuation_field_completion_well_defined

-- next I will prove that for every r : rational_open_data_subsets U with v ∈ r.1.rational_open,
-- f gets sent to the same thing.
lemma to_valuation_field_completion_well_defined
  (r : rational_open_data_subsets U) (hr : v ∈ r.1.open_set) :
  to_valuation_field_completion hv f = to_complete_valuation_field _ hr (f.1 r) :=
to_valuation_field_completion_well_defined.aux₃ f _ hr

-- now the main goal

/-- If v ∈ U then the map from 𝒪_X(U) to `completion (valuation_field v)`
    commutes with restriction (so we can get a map from the stalk at v) -/
theorem to_valuation_field_completion_commutes {U V : opens (spa A)} (hv : v ∈ U)
  (hUV : U ⊆ V) (f : spa.presheaf_value V) :
  to_valuation_field_completion (hUV hv) f =
  to_valuation_field_completion hv (spa.presheaf_map hUV f) :=
begin
  -- to_valuation_field_completion involves choosing a random basis element.
  let rU := rational_open_subset_nhd hv,
  let rV := rational_open_subset_nhd (hUV hv),
  -- we now need to intersect these two things.
  let rUV1 := rU.1.inter rV.1,
  rw [to_valuation_field_completion_well_defined hv (spa.presheaf_map hUV f) ⟨rUV1, _⟩,
      to_valuation_field_completion_well_defined (hUV hv) f ⟨rUV1, _⟩],
  { refl },
  { rw rational_open_data.inter_open_set,
    exact ⟨mem_rational_open_subset_nhd hv, mem_rational_open_subset_nhd _⟩, },
  { rw rational_open_data.inter_open_set,
    exact set.subset.trans (set.inter_subset_left _ _) rU.2 },
end

set_option class.instance_max_depth 49

/--An auxiliary function in the definition of the valuations on the stalks
of the structure presheaf of the adic spectrum of a Huber pair:
the valuation is obtained by pulling back a valuation along this function.

It is the natural map from the stalk above a point in spa(A),
which is an equivalence class of valuations,
to the completion of the valuation field of a valuation
that is a representative of this equivalence class. -/
noncomputable def stalk_to_valuation_field (x : spa A) :
  stalk_of_rings (spa.presheaf_of_topological_rings A).to_presheaf_of_rings x →
  completion (valuation_field (Spv.out x.1)) :=
to_stalk.rec (spa.presheaf_of_topological_rings A).to_presheaf_of_rings x
  (completion (valuation_field (Spv.out x.1))) (λ U hxU, to_valuation_field_completion hxU)
  (λ U V HUV r hxU, (to_valuation_field_completion_commutes hxU HUV r).symm)

/-- The natural map from the stalk above a point v in spa(A) to the
completion of the valuation field of v is a ring homomorphism. -/
instance stalk_to_valuation_field.is_ring_hom (x : spa A) :
  is_ring_hom (stalk_to_valuation_field x) := to_stalk.rec_is_ring_hom _ _ _ _ _

/--The valuation on the stalk of the structure presheaf of the adic spectrum.-/
noncomputable def stalk_valuation (x : spa A) :
  valuation (stalk_of_rings (spa.presheaf_of_topological_rings A).to_presheaf_of_rings x)
    (value_monoid (out x.1)) :=
(valuation_on_completion (out x.1)).comap (stalk_to_valuation_field x)

end presheaf

end spa


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

! This file was ported from Lean 3 source module category_theory.closed.ideal
! leanprover-community/mathlib commit ac3ae212f394f508df43e37aa093722fa9b65d31
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Limits.Preserves.Shapes.BinaryProducts
import Mathbin.CategoryTheory.Limits.Constructions.FiniteProductsOfBinaryProducts
import Mathbin.CategoryTheory.Monad.Limits
import Mathbin.CategoryTheory.Adjunction.FullyFaithful
import Mathbin.CategoryTheory.Adjunction.Reflective
import Mathbin.CategoryTheory.Closed.Cartesian
import Mathbin.CategoryTheory.Subterminal

/-!
# Exponential ideals

An exponential ideal of a cartesian closed category `C` is a subcategory `D ⊆ C` such that for any
`B : D` and `A : C`, the exponential `A ⟹ B` is in `D`: resembling ring theoretic ideals. We
define the notion here for inclusion functors `i : D ⥤ C` rather than explicit subcategories to
preserve the principle of equivalence.

We additionally show that if `C` is cartesian closed and `i : D ⥤ C` is a reflective functor, the
following are equivalent.
* The left adjoint to `i` preserves binary (equivalently, finite) products.
* `i` is an exponential ideal.
-/

universe v₁ v₂ u₁ u₂

noncomputable section

namespace CategoryTheory

open Limits Category

section Ideal

variable {C : Type u₁} {D : Type u₂} [Category.{v₁} C] [Category.{v₁} D] {i : D ⥤ C}

variable (i) [HasFiniteProducts C] [CartesianClosed C]

/-- The subcategory `D` of `C` expressed as an inclusion functor is an *exponential ideal* if
`B ∈ D` implies `A ⟹ B ∈ D` for all `A`.
-/
class ExponentialIdeal : Prop where
  exp_closed : ∀ {B}, B ∈ i.essImage → ∀ A, (A ⟹ B) ∈ i.essImage
#align category_theory.exponential_ideal CategoryTheory.ExponentialIdeal

/-- To show `i` is an exponential ideal it suffices to show that `A ⟹ iB` is "in" `D` for any `A` in
`C` and `B` in `D`.
-/
theorem ExponentialIdeal.mk' (h : ∀ (B : D) (A : C), (A ⟹ i.obj B) ∈ i.essImage) :
    ExponentialIdeal i :=
  ⟨fun B hB A => by
    rcases hB with ⟨B', ⟨iB'⟩⟩
    exact functor.ess_image.of_iso ((exp A).mapIso iB') (h B' A)⟩
#align category_theory.exponential_ideal.mk' CategoryTheory.ExponentialIdeal.mk'

/-- The entire category viewed as a subcategory is an exponential ideal. -/
instance : ExponentialIdeal (𝟭 C) :=
  ExponentialIdeal.mk' _ fun B A => ⟨_, ⟨Iso.refl _⟩⟩

open CartesianClosed

/-- The subcategory of subterminal objects is an exponential ideal. -/
instance : ExponentialIdeal (subterminalInclusion C) :=
  by
  apply exponential_ideal.mk'
  intro B A
  refine' ⟨⟨A ⟹ B.1, fun Z g h => _⟩, ⟨iso.refl _⟩⟩
  exact uncurry_injective (B.2 (cartesian_closed.uncurry g) (cartesian_closed.uncurry h))

/-- If `D` is a reflective subcategory, the property of being an exponential ideal is equivalent to
the presence of a natural isomorphism `i ⋙ exp A ⋙ left_adjoint i ⋙ i ≅ i ⋙ exp A`, that is:
`(A ⟹ iB) ≅ i L (A ⟹ iB)`, naturally in `B`.
The converse is given in `exponential_ideal.mk_of_iso`.
-/
def exponentialIdealReflective (A : C) [Reflective i] [ExponentialIdeal i] :
    i ⋙ exp A ⋙ leftAdjoint i ⋙ i ≅ i ⋙ exp A :=
  by
  symm
  apply nat_iso.of_components _ _
  · intro X
    haveI := (exponential_ideal.exp_closed (i.obj_mem_ess_image X) A).unit_isIso
    apply as_iso ((adjunction.of_right_adjoint i).Unit.app (A ⟹ i.obj X))
  · simp
#align category_theory.exponential_ideal_reflective CategoryTheory.exponentialIdealReflective

/-- Given a natural isomorphism `i ⋙ exp A ⋙ left_adjoint i ⋙ i ≅ i ⋙ exp A`, we can show `i`
is an exponential ideal.
-/
theorem ExponentialIdeal.mk_of_iso [Reflective i]
    (h : ∀ A : C, i ⋙ exp A ⋙ leftAdjoint i ⋙ i ≅ i ⋙ exp A) : ExponentialIdeal i :=
  by
  apply exponential_ideal.mk'
  intro B A
  exact ⟨_, ⟨(h A).app B⟩⟩
#align category_theory.exponential_ideal.mk_of_iso CategoryTheory.ExponentialIdeal.mk_of_iso

end Ideal

section

variable {C : Type u₁} {D : Type u₂} [Category.{v₁} C] [Category.{v₁} D]

variable (i : D ⥤ C)

theorem reflective_products [HasFiniteProducts C] [Reflective i] : HasFiniteProducts D :=
  ⟨fun n => hasLimitsOfShape_of_reflective i⟩
#align category_theory.reflective_products CategoryTheory.reflective_products

attribute [local instance] reflective_products

open CartesianClosed

variable [HasFiniteProducts C] [Reflective i] [CartesianClosed C]

/-- If the reflector preserves binary products, the subcategory is an exponential ideal.
This is the converse of `preserves_binary_products_of_exponential_ideal`.
-/
instance (priority := 10) exponentialIdeal_of_preserves_binary_products
    [PreservesLimitsOfShape (Discrete WalkingPair) (leftAdjoint i)] : ExponentialIdeal i :=
  by
  let ir := adjunction.of_right_adjoint i
  let L : C ⥤ D := left_adjoint i
  let η : 𝟭 C ⟶ L ⋙ i := ir.unit
  let ε : i ⋙ L ⟶ 𝟭 D := ir.counit
  apply exponential_ideal.mk'
  intro B A
  let q : i.obj (L.obj (A ⟹ i.obj B)) ⟶ A ⟹ i.obj B
  apply cartesian_closed.curry (ir.hom_equiv _ _ _)
  apply _ ≫ (ir.hom_equiv _ _).symm ((exp.ev A).app (i.obj B))
  refine' prod_comparison L A _ ≫ limits.prod.map (𝟙 _) (ε.app _) ≫ inv (prod_comparison _ _ _)
  have : η.app (A ⟹ i.obj B) ≫ q = 𝟙 (A ⟹ i.obj B) :=
    by
    dsimp
    rw [← curry_natural_left, curry_eq_iff, uncurry_id_eq_ev, ← ir.hom_equiv_naturality_left,
      ir.hom_equiv_apply_eq, assoc, assoc, prod_comparison_natural_assoc, L.map_id, ←
      prod.map_id_comp_assoc, ir.left_triangle_components, prod.map_id_id, id_comp]
    apply is_iso.hom_inv_id_assoc
  haveI : is_split_mono (η.app (A ⟹ i.obj B)) := is_split_mono.mk' ⟨_, this⟩
  apply mem_ess_image_of_unit_is_split_mono
#align category_theory.exponential_ideal_of_preserves_binary_products CategoryTheory.exponentialIdeal_of_preserves_binary_products

variable [ExponentialIdeal i]

/-- If `i` witnesses that `D` is a reflective subcategory and an exponential ideal, then `D` is
itself cartesian closed.
-/
def cartesianClosedOfReflective : CartesianClosed D
    where closed' B :=
    {
      isAdj :=
        { right := i ⋙ exp (i.obj B) ⋙ leftAdjoint i
          adj := by
            apply adjunction.restrict_fully_faithful i i (exp.adjunction (i.obj B))
            · symm
              apply nat_iso.of_components _ _
              · intro X
                haveI :=
                  Adjunction.rightAdjointPreservesLimits.{0, 0} (adjunction.of_right_adjoint i)
                apply as_iso (prod_comparison i B X)
              · intro X Y f
                dsimp
                rw [prod_comparison_natural]
                simp
            · apply (exponential_ideal_reflective i _).symm } }
#align category_theory.cartesian_closed_of_reflective CategoryTheory.cartesianClosedOfReflective

-- It's annoying that I need to do this.
attribute [-instance]
  CategoryTheory.preservesLimitOfCreatesLimitAndHasLimit CategoryTheory.preservesLimitOfShapeOfCreatesLimitsOfShapeAndHasLimitsOfShape

/-- We construct a bijection between morphisms `L(A ⨯ B) ⟶ X` and morphisms `LA ⨯ LB ⟶ X`.
This bijection has two key properties:
* It is natural in `X`: See `bijection_natural`.
* When `X = LA ⨯ LB`, then the backwards direction sends the identity morphism to the product
  comparison morphism: See `bijection_symm_apply_id`.

Together these help show that `L` preserves binary products. This should be considered
*internal implementation* towards `preserves_binary_products_of_exponential_ideal`.
-/
noncomputable def bijection (A B : C) (X : D) :
    ((leftAdjoint i).obj (A ⨯ B) ⟶ X) ≃ ((leftAdjoint i).obj A ⨯ (leftAdjoint i).obj B ⟶ X) :=
  calc
    _ ≃ (A ⨯ B ⟶ i.obj X) := (Adjunction.ofRightAdjoint i).homEquiv _ _
    _ ≃ (B ⨯ A ⟶ i.obj X) := ((Limits.prod.braiding _ _).homCongr (Iso.refl _))
    _ ≃ (A ⟶ B ⟹ i.obj X) := ((exp.adjunction _).homEquiv _ _)
    _ ≃ (i.obj ((leftAdjoint i).obj A) ⟶ B ⟹ i.obj X) :=
      (unitCompPartialBijective _ (ExponentialIdeal.exp_closed (i.obj_mem_essImage _) _))
    _ ≃ (B ⨯ i.obj ((leftAdjoint i).obj A) ⟶ i.obj X) := ((exp.adjunction _).homEquiv _ _).symm
    _ ≃ (i.obj ((leftAdjoint i).obj A) ⨯ B ⟶ i.obj X) :=
      ((Limits.prod.braiding _ _).homCongr (Iso.refl _))
    _ ≃ (B ⟶ i.obj ((leftAdjoint i).obj A) ⟹ i.obj X) := ((exp.adjunction _).homEquiv _ _)
    _ ≃ (i.obj ((leftAdjoint i).obj B) ⟶ i.obj ((leftAdjoint i).obj A) ⟹ i.obj X) :=
      (unitCompPartialBijective _ (ExponentialIdeal.exp_closed (i.obj_mem_essImage _) _))
    _ ≃ (i.obj ((leftAdjoint i).obj A) ⨯ i.obj ((leftAdjoint i).obj B) ⟶ i.obj X) :=
      ((exp.adjunction _).homEquiv _ _).symm
    _ ≃ (i.obj ((leftAdjoint i).obj A ⨯ (leftAdjoint i).obj B) ⟶ i.obj X) :=
      by
      apply iso.hom_congr _ (iso.refl _)
      haveI : preserves_limits i := (adjunction.of_right_adjoint i).rightAdjointPreservesLimits
      haveI := preserves_smallest_limits_of_preserves_limits i
      exact (preserves_limit_pair.iso _ _ _).symm
    _ ≃ ((leftAdjoint i).obj A ⨯ (leftAdjoint i).obj B ⟶ X) := (equivOfFullyFaithful _).symm

#align category_theory.bijection CategoryTheory.bijection

theorem bijection_symm_apply_id (A B : C) : (bijection i A B _).symm (𝟙 _) = prodComparison _ _ _ :=
  by
  dsimp [bijection]
  rw [comp_id, comp_id, comp_id, i.map_id, comp_id, unit_comp_partial_bijective_symm_apply,
    unit_comp_partial_bijective_symm_apply, uncurry_natural_left, uncurry_curry,
    uncurry_natural_left, uncurry_curry, prod.lift_map_assoc, comp_id, prod.lift_map_assoc, comp_id,
    prod.comp_lift_assoc, prod.lift_snd, prod.lift_fst_assoc, prod.lift_fst_comp_snd_comp, ←
    adjunction.eq_hom_equiv_apply, adjunction.hom_equiv_unit, iso.comp_inv_eq, assoc,
    preserves_limit_pair.iso_hom]
  apply prod.hom_ext
  · rw [limits.prod.map_fst, assoc, assoc, prod_comparison_fst, ← i.map_comp, prod_comparison_fst]
    apply (adjunction.of_right_adjoint i).Unit.naturality
  · rw [limits.prod.map_snd, assoc, assoc, prod_comparison_snd, ← i.map_comp, prod_comparison_snd]
    apply (adjunction.of_right_adjoint i).Unit.naturality
#align category_theory.bijection_symm_apply_id CategoryTheory.bijection_symm_apply_id

theorem bijection_natural (A B : C) (X X' : D) (f : (leftAdjoint i).obj (A ⨯ B) ⟶ X) (g : X ⟶ X') :
    bijection i _ _ _ (f ≫ g) = bijection i _ _ _ f ≫ g :=
  by
  dsimp [bijection]
  apply i.map_injective
  rw [i.image_preimage, i.map_comp, i.image_preimage, comp_id, comp_id, comp_id, comp_id, comp_id,
    comp_id, adjunction.hom_equiv_naturality_right, ← assoc, curry_natural_right _ (i.map g),
    unit_comp_partial_bijective_natural, uncurry_natural_right, ← assoc, curry_natural_right,
    unit_comp_partial_bijective_natural, uncurry_natural_right, assoc]
#align category_theory.bijection_natural CategoryTheory.bijection_natural

/--
The bijection allows us to show that `prod_comparison L A B` is an isomorphism, where the inverse
is the forward map of the identity morphism.
-/
theorem prodComparison_iso (A B : C) : IsIso (prodComparison (leftAdjoint i) A B) :=
  ⟨⟨bijection i _ _ _ (𝟙 _), by
      rw [← (bijection i _ _ _).Injective.eq_iff, bijection_natural, ← bijection_symm_apply_id,
        Equiv.apply_symm_apply, id_comp],
      by rw [← bijection_natural, id_comp, ← bijection_symm_apply_id, Equiv.apply_symm_apply]⟩⟩
#align category_theory.prod_comparison_iso CategoryTheory.prodComparison_iso

attribute [local instance] prod_comparison_iso

/--
If a reflective subcategory is an exponential ideal, then the reflector preserves binary products.
This is the converse of `exponential_ideal_of_preserves_binary_products`.
-/
noncomputable def preservesBinaryProductsOfExponentialIdeal :
    PreservesLimitsOfShape (Discrete WalkingPair) (leftAdjoint i)
    where PreservesLimit K :=
    by
    apply limits.preserves_limit_of_iso_diagram _ (diagram_iso_pair K).symm
    apply preserves_limit_pair.of_iso_prod_comparison
#align category_theory.preserves_binary_products_of_exponential_ideal CategoryTheory.preservesBinaryProductsOfExponentialIdeal

/--
If a reflective subcategory is an exponential ideal, then the reflector preserves finite products.
-/
noncomputable def preservesFiniteProductsOfExponentialIdeal (J : Type) [Fintype J] :
    PreservesLimitsOfShape (Discrete J) (leftAdjoint i) :=
  by
  letI := preserves_binary_products_of_exponential_ideal i
  letI := leftAdjointPreservesTerminalOfReflective.{0} i
  apply preserves_finite_products_of_preserves_binary_and_terminal (left_adjoint i) J
#align category_theory.preserves_finite_products_of_exponential_ideal CategoryTheory.preservesFiniteProductsOfExponentialIdeal

end

end CategoryTheory


/-
Copyright (c) 2015 Leonardo de Moura. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Mario Carneiro
-/
import data.list.big_operators

/-!
# Lists in product and sigma types

This file proves basic properties of `list.product` and `list.sigma`, which are list constructions
living in `prod` and `sigma` types respectively. Their definitions can be found in
[`data.list.defs`](./defs). Beware, this is not about `list.prod`, the multiplicative product.
-/

variables {α β : Type*}

namespace list

/-! ### product -/

@[simp] lemma nil_product (l : list β) : product (@nil α) l = [] := rfl

@[simp] lemma product_cons (a : α) (l₁ : list α) (l₂ : list β)
        : product (a::l₁) l₂ = map (λ b, (a, b)) l₂ ++ product l₁ l₂ := rfl

@[simp] lemma product_nil : ∀ (l : list α), product l (@nil β) = []
| []     := rfl
| (a::l) := by rw [product_cons, product_nil]; refl

@[simp] lemma mem_product {l₁ : list α} {l₂ : list β} {a : α} {b : β} :
  (a, b) ∈ product l₁ l₂ ↔ a ∈ l₁ ∧ b ∈ l₂ :=
by simp only [product, mem_bind, mem_map, prod.ext_iff, exists_prop,
  and.left_comm, exists_and_distrib_left, exists_eq_left, exists_eq_right]

lemma length_product (l₁ : list α) (l₂ : list β) :
  length (product l₁ l₂) = length l₁ * length l₂ :=
by induction l₁ with x l₁ IH; [exact (zero_mul _).symm,
  simp only [length, product_cons, length_append, IH,
    right_distrib, one_mul, length_map, add_comm]]

/-! ### sigma -/

variable {σ : α → Type*}

@[simp] lemma nil_sigma (l : Π a, list (σ a)) : (@nil α).sigma l = [] := rfl

@[simp] lemma sigma_cons (a : α) (l₁ : list α) (l₂ : Π a, list (σ a))
        : (a::l₁).sigma l₂ = map (sigma.mk a) (l₂ a) ++ l₁.sigma l₂ := rfl

@[simp] lemma sigma_nil : ∀ (l : list α), l.sigma (λ a, @nil (σ a)) = []
| []     := rfl
| (a::l) := by rw [sigma_cons, sigma_nil]; refl

@[simp] lemma mem_sigma {l₁ : list α} {l₂ : Π a, list (σ a)} {a : α} {b : σ a} :
  sigma.mk a b ∈ l₁.sigma l₂ ↔ a ∈ l₁ ∧ b ∈ l₂ a :=
by simp only [list.sigma, mem_bind, mem_map, exists_prop, exists_and_distrib_left,
  and.left_comm, exists_eq_left, heq_iff_eq, exists_eq_right]

lemma length_sigma (l₁ : list α) (l₂ : Π a, list (σ a)) :
  length (l₁.sigma l₂) = (l₁.map (λ a, length (l₂ a))).sum :=
by induction l₁ with x l₁ IH; [refl,
simp only [map, sigma_cons, length_append, length_map, IH, sum_cons]]

end list


/-
Copyright (c) 2019 The Flypitch Project. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.

Authors: Jesse Han, Floris van Doorn
-/
/- Show that every theory can be extended to a complete theory -/

import .compactness order.zorn

local attribute [instance, priority 0] classical.prop_decidable
open fol set

universe variables u v
section
parameter L : Language.{u}

open classical zorn

lemma inconsis_not_of_provable {L} {T : Theory L} {f : sentence L} :
  T ⊢' f → ¬ is_consistent (T ∪ {∼f}) :=
begin
  intro H, suffices : (T ∪ {∼f}) ⊢' (⊥ : sentence L), by tidy,
  apply snot_and_self' _, exact f, apply nonempty.intro, apply andI,
  apply weakening, show set (formula L),
  exact T.fst, tidy, exact or.inr (by assumption),
  exact classical.choice H, apply axm, tidy
end

lemma provable_of_inconsis_not {L} {T : Theory L} {f : sentence L} :
¬ is_consistent (T ∪ {∼f})  → T ⊢' f :=
begin
  by_contra a, simp[*,-a] at a,
  cases a with a1 a2, apply consis_not_of_not_provable a2,
  exact classical.by_contradiction (by tidy)
end

/-- Given a theory T and a sentence ψ, either T ∪ {ψ} or T ∪ {∼ ψ} is consistent.--/
lemma can_extend {L : Language} (T : Theory L) (ψ : sentence L) (h : is_consistent T) :
  is_consistent (T ∪ {ψ}) ∨ is_consistent (T ∪ {∼ ψ}) :=
begin
  simp only [is_consistent, set.union_singleton], by_contra a,
  rw[not_or_distrib] at a, rcases a with ⟨H1, H2⟩,
  suffices : T ⊢' (⊥ : sentence L), by contradiction,
  exact snot_and_self'' (simpI' (classical.by_contradiction H1)) (simpI' (classical.by_contradiction H2))
end
  -- simp[is_consistent],  by_contra,  rename a hc, rw[not_or_distrib] at hc,
  -- have hc1 := classical.by_contradiction hc.1,
  -- have hc2 := classical.by_contradiction hc.2,
  -- have hc_uno : T ⊢'  ∼ψ,
  --   exact hc1.map simpI,
  -- have hc_dos : T ⊢' ∼∼ψ,
  --   exact hc2.map simpI,
  -- exact hc_dos.map2 (impE _) hc_uno

/-
Now, we have to show that given an arbitrary chain in this poset, we can obtain an upper bound in this chain. We do this by taking the union.
-/

/- Given a set of theories and a proof that they form a chain under set-inclusion, return their union and a proof that this contains every theory in the chain
-/

lemma nonempty_of_not_empty {α : Type u} (s : set α) (h : ¬ s = ∅) : set.nonempty s :=
by rwa ← ne_empty_iff_nonempty

/-- Theory_over T is the subtype of Theory L consisting of consistent theories T' such that T' ⊇ T--/
def Theory_over {L : Language.{u}} (T : Theory L) (hT : is_consistent T): Type u :=
{T' : Theory L // T ⊆ T' ∧ is_consistent T'}

/-- Every theory T is trivially a theory over itself --/
def over_self {L : Language} (T : Theory L) (hT : is_consistent T): Theory_over T hT:=
  by {refine ⟨T, _⟩, split, trivial, assumption}

/-- Given two consistent theories T₁ and T₂ over T, say that T₁ ⊆ T₂ if T₁ ⊆ T₂--/
def Theory_over_subset {L : Language.{u}} {T : Theory L} {hT : is_consistent T} : Theory_over T hT → Theory_over T hT→ Prop
:= λ T1 T2, T1.val ⊆ T2.val

instance {T : Theory L} {hT : is_consistent T} : has_subset (Theory_over T hT) := ⟨Theory_over_subset⟩

instance {T : Theory L} {hT : is_consistent T} : nonempty (Theory_over T hT) := ⟨over_self T hT⟩

/- Given a sentence and the hypothesis that ψ is provable from a theory T, return a list of sentences from T and a proof that this list proves ψ -/
-- TODO: refactor this away, use theory_proof_compactness
noncomputable def theory_proof_compactness' {L : Language} (T : Theory L) (ψ : sentence L) (hψ : T ⊢' ψ) : Σ' Γ : list (sentence L), {ϕ : sentence L | ϕ ∈ Γ} ⊢' ψ ∧ {ϕ : sentence L | ϕ ∈ Γ} ⊆ T :=
begin
  apply psigma_of_exists,
  rcases theory_proof_compactness hψ with ⟨Γ, H, K⟩,
  cases Γ with Γ hΓ, induction Γ, swap, refl,
  exact ⟨Γ, H, K⟩
end

-- #check set.nonempty_chain

/- Given a chain of sets with nonempty union, conclude that the chain is nonempty-/
def nonempty_chain_of_nonempty_union {α : Type u} {A_i : set $ set α} {h_chain : chain (⊆) A_i}
  (h : (set.sUnion A_i).nonempty) : A_i.nonempty :=
by rw nonempty_sUnion at h; obtain ⟨ _ , hs , _ ⟩ := h; exact nonempty_of_mem hs

/- Given two elements in a chain of sets over T, their union over T is in the chain -/
lemma in_chain_of_union {α : Type u} (T : set α) (A_i : set $ set α)
  (h_chain : chain set.subset A_i) (as : list A_i) (h_over_T : ∀ A ∈ A_i, T ⊆ A) (A1 A2 ∈ A_i) :
  A1 ∪ A2 = A1 ∨ A1 ∪ A2 = A2 :=
begin
dedup,
unfold has_union.union set.union has_mem.mem set.mem,
unfold chain set.pairwise at h_chain,
by_cases A1 = A2,
  simp*, finish,
  have := h_chain H H_1 h, cases this,
  {fapply or.inr, apply funext, intro x, apply propext, split,
  intro h1, have : A1 x ∨ A2 x, by assumption, fapply or.elim, exact A1 x, exact A2 x, assumption,
  intro hx, dedup, unfold set.subset at this, exact this hx, finish,
  intro hx, apply or.inr, assumption},

  {fapply or.inl, apply funext, intro x, apply propext, split,
  intro hx, have : A1 x ∨ A2 x, by assumption, fapply or.elim, exact A2 x, exact A1 x, finish,
  intro h2x, dedup, unfold set.subset at this, exact this h2x, finish,
intro h3x, apply or.inl, assumption}
end

/--Given a chain and two elements from this chain, return their maximum. --/
noncomputable def max_in_chain {α : Type u} {R : α → α → Prop} {Ts : set α}
  {nonempty_Ts : nonempty Ts} (h_chain : chain R Ts) (S1 S2 : α) (h_S1 : S1 ∈ Ts) (h_S2 : S2 ∈ Ts) :
  Σ' (S : α), (S = S1 ∧ (R S2 S1 ∨ S1 = S2)) ∨ (S = S2 ∧ (R S1 S2 ∨ S1 = S2)) :=
begin
  unfold chain set.pairwise at h_chain,
  have := h_chain h_S1 h_S2,
  by_cases S1 = S2,

    refine ⟨S1, _ ⟩, fapply or.inl, fapply and.intro, exact rfl, exact or.inr h,

    have H := this h,
    by_cases R S1 S2,
      refine ⟨S2, _⟩, fapply or.inr, refine and.intro rfl _, exact or.inl h,

      tactic.unfreeze_local_instances, dedup, simp[*, -H] at H, refine ⟨S1, _⟩, fapply or.inl,
      refine and.intro rfl _, exact or.inl H
end

/--Given a nonempty chain under a transitive relation and a list of elements from this chain, return an upper bound, with the maximum of the empty list defined to be the witness to the nonempty --/
noncomputable def max_of_list_in_chain {α : Type u} {R : α → α → Prop} {trans : ∀{a b c}, R a b → R b c → R a c} {Ts : set α} {nonempty_Ts : nonempty Ts} (h_chain : chain R Ts) (Ss : list α) -- {nonempty_Ss : nonempty {S | S ∈ Ss}}
(h_fs : ∀ S ∈ Ss, S ∈ Ts) : Σ' (S : α), S ∈ Ts ∧ (∀ S' ∈ Ss, S' = S ∨ R S' S) :=
begin
  induction Ss,
  {tactic.unfreeze_local_instances, have := (classical.choice nonempty_Ts),
   from ⟨this.1, ⟨this.2, by finish⟩⟩},
  specialize Ss_ih (by simp at h_fs; from h_fs.right),
  rcases Ss_ih with ⟨S,H_mem,H_s⟩,
  by_cases (R S Ss_hd),
    {use Ss_hd, use (by simp*), intros S' HS', cases HS',
      from or.inl ‹_›, right, by_cases S' = S, rwa[h],
      apply trans (or.resolve_left (H_s _ HS') h), assumption },
    {use S, use H_mem, intros S' HS', cases HS',
      {subst HS', by_cases S' = S, from or.inl ‹_›,
       unfold chain pairwise at h_chain,
        specialize @h_chain S' (by simp at h_fs; from h_fs.left) S ‹_› ‹_›,
        right, apply or.resolve_right h_chain, assumption },
      apply H_s _ HS' }
end

/-- Given a xs : list α, it is naturally a list {x ∈ α | x ∈ xs} --/
def list_is_list_of_subtype : Π(α : Type u), Π (fs : list α),  Σ' xs : list ↥{f : α | f ∈ fs}, ∀ f, ∀ h : f ∈ fs, (⟨f,h⟩ : ↥{f : α | f ∈ fs}) ∈ xs :=
begin
  intros α fs, induction fs with fs_hd fs_tl ih,
    { exact ⟨[], by simp⟩ },
    {  let F : {f | f ∈ fs_tl} → {f | f ∈ list.cons fs_hd fs_tl},
         by {intro f, refine ⟨f, _⟩, fapply or.inr, exact f.property},
    refine ⟨_,_⟩,
      { refine _::_,
        { exact ⟨fs_hd, by simp⟩ },
        { exact list.map F ih.fst }  },
      { intro a, classical, by_cases a = fs_hd,
        { finish },
        { tidy, right, tidy }}},
end

lemma set.eq_empty_of_is_empty_coe
  {α : Type*} (s : set α) (h : is_empty s) : s = ∅ :=
eq_empty_iff_forall_not_mem.mpr
  (λ x hxs, (@is_empty.exists_iff s h (λ x, true)).mp
    ⟨ subtype_of_exists ⟨ x , hxs ⟩, trivial ⟩)

/-- The limit theory of a chain of consistent theories over T is consistent --/
lemma consis_limit {L : Language} {T : Theory L} {hT : is_consistent T}
  (Ts : set (Theory_over T hT)) (h_chain : chain Theory_over_subset Ts)
  : is_consistent (T ∪ set.sUnion (subtype.val '' Ts)) :=
begin
  intro h_inconsis,
  by_cases nonempty Ts, swap,
  { simp at h, simp[*, -h_inconsis] at h_inconsis, unfold is_consistent at hT, apply hT,
    rw [←union_empty T], convert h_inconsis, simp },

  have Γpair := theory_proof_compactness' (T ∪ ⋃₀(subtype.val '' Ts)) ⊥ h_inconsis,
  have h_bad : ∃ T' : (Theory L), (T' ∈ (subtype.val '' Ts)) ∧ {ψ | ψ ∈ Γpair.fst} ⊆ T',

 {cases Γpair with fs Hfs, rename h hTs,
  have dSs : Π f ∈ fs, Σ' S_f : (Theory_over T hT), set.mem S_f Ts ∧ (set.mem (f) (S_f.val)), -- to each f in fs, associate an S_f containing f from the chain
    {  intros f hf, have H := Hfs.right,
  unfold set.image set.sUnion set.subset set.mem list.mem at H,
  have H' := H hf,  by_cases f ∈ T,
  split, swap, {exact (classical.choice hTs).val},
  {fapply and.intro, exact (choice hTs).property,
    have H := (choice hTs).val.property.left,
    exact H h},

    simp[*, -H'] at H',
    have witness := indefinite_description _ H', simp* at witness,
    split, swap, split, swap, exact witness.val, cases witness.property with case1 case2, cases case1 with case1' case1'', exact case1',
split, have witness_property := witness.property, cases witness_property with case1 case2, cases case1 with case1' case1'', exact case1'',
have witness_property := witness.property, cases witness_property with case1 case2, exact case2,},

  have T_max : Σ' (T_max : Theory_over T hT), (T_max ∈ Ts) ∧ ∀ ψ ∈ fs, (ψ) ∈ T_max.val,  -- get the theory and a proof that it contains all the f
    {  let F : {f | f ∈ fs} → Theory_over T hT :=
    begin intro f, exact (dSs f.val f.property).fst end,
  let fs_list_subtype := list_is_list_of_subtype _ fs,
  let T_list : list (Theory_over T hT) :=
    begin fapply list.map F, exact fs_list_subtype.fst end,
  have T_list_subset_Ts : (∀ (S : Theory_over T hT), S ∈ T_list → S ∈ Ts),
  { intro S, simp only [-sigma.exists, -sigma.forall, and_imp, bex_imp_distrib,
    list.mem_map, set_coe.exists, mem_set_of_eq, list.map],
    intros x h1 h2 h3,
    rw ← h3,
    exact (dSs x h1).snd.left },

  have max_of_list := max_of_list_in_chain h_chain T_list T_list_subset_Ts,
  split, swap,
    {exact max_of_list.fst},
    {split, exact max_of_list.snd.left,
      {intros f hf,
        have almost_there : f ∈ (F ⟨f, begin simpa end⟩).val, simp*, exact (dSs f hf).snd.right,
        have nearly_there : (F ⟨f, begin simpa end⟩) ⊆ max_of_list.fst,
          have := max_of_list.snd.right (F ⟨f, begin simpa end⟩),
          have so_close : F ⟨f, _⟩ = max_of_list.fst ∨ Theory_over_subset (F ⟨f, _⟩) (max_of_list.fst),
            begin
            refine this _, simp [*, -sigma.exists], fapply exists.intro, exact f, fapply exists.intro,
            exact hf, fapply and.intro, unfold has_mem.mem list.mem,
            {apply fs_list_subtype.snd},
            {refl},
            end,
        cases so_close with case1 case2,
        rw[case1], intros a h, exact h,
        exact case2,
        exact nearly_there almost_there,
        },
      },
    {intros a b c, unfold Theory_over_subset, fapply subset.trans},
    {assumption}},

  fapply exists.intro, exact T_max.fst.val,
  fapply and.intro, fapply set.mem_image_of_mem, exact T_max.snd.left,
  have := T_max.snd.right, intros ψ hψ, exact this ψ hψ},

  let T_bad := @strong_indefinite_description (Theory L) (λ S, S ∈ (subtype.val '' Ts) ∧ ({ϕ | ϕ ∈ Γpair.fst} ⊆ S))  begin apply_instance end,
  have T_bad_inconsis : sprovable T_bad.val ⊥,
  fapply nonempty.intro,
  fapply sweakening (T_bad.property h_bad).right,
  exact classical.choice Γpair.snd.left,
  have T_bad_consis : is_consistent T_bad.val,
    {have almost_done := (T_bad.property h_bad).left,
    simp[set.image] at almost_done,
    cases almost_done with H _, from H.right},
    exact T_bad_consis T_bad_inconsis,
end

/-- Given a chain of consistent extensions of a theory T, return the union of those theories and a proof that this is a consistent extension of T --/
def limit_theory {L : Language} {T : Theory L} {hT : is_consistent T} (Ts : set (Theory_over T hT)) (h_chain : chain Theory_over_subset Ts) : Σ' T : Theory_over T hT, ∀ T' ∈ Ts, T' ⊆ T :=
begin
refine ⟨⟨T ∪ set.sUnion (subtype.val '' Ts), _⟩, _⟩, simp*, intro,
exact @consis_limit L T hT Ts h_chain begin simp* end,
intros T' hT' ψ hψ, right, split, swap, exact T'.val,
apply exists.intro, swap, exact hψ, simp*, exact T'.property
end

/-- Given a theory T, show that the poset of theories over T satisfies the hypotheses of Zorn's lemma --/
lemma can_use_zorn {L : Language.{u}} {T : Theory L} {hT : is_consistent T}  : (∀c, @chain (Theory_over T hT) Theory_over_subset c → ∃ub, ∀a∈c, a ⊆ ub) ∧ (∀(a b c : Theory_over T hT), a ⊆ b → b ⊆ c → a ⊆ c) :=
begin
  split,  intro Ts, intro h_chain, let S := limit_theory Ts h_chain,
  let T_infty := S.fst,  let H_infty := S.snd,
  refine exists.intro _ _,  exact T_infty, intro T', intro H',
  finish, tidy
end

/-- Given a consistent theory T, return a maximal extension of it given by Zorn's lemma, along with the proof that it is consistent and maximal --/
noncomputable def maximal_extension (L : Language.{u}) (T : Theory L) (hT : is_consistent T) :
  Σ' (T_max : Theory_over T hT), ∀ T' : Theory_over T hT, T_max ⊆ T' → T' ⊆ T_max :=
begin
  let X := strong_indefinite_description (λ T_max : Theory_over T hT, ∀ T' : Theory_over T hT, T_max ⊆ T' → T' ⊆ T_max ) begin apply_instance end,
  have := @can_use_zorn L T, rename this h_can_use,
  have := exists_maximal_of_chains_bounded h_can_use.left h_can_use.right, rename this h_zorn,
  let T_max := X.val, let H := X.property,
  exact ⟨T_max, H h_zorn⟩,
end

/-- The maximal extension returned by maximal_extension cannot be extended. --/
lemma cannot_extend_maximal_extension {L : Language} {T : Theory L} {hT : is_consistent T} (T_max' : Σ' (T_max : Theory_over T hT), ∀ T' : Theory_over T hT, T_max ⊆ T' → T' ⊆ T_max) (ψ : sentence L) (H : is_consistent (T_max'.fst.val ∪ {ψ}))(H1 : ψ ∉ T_max'.fst.val) : false :=
begin
  let T_bad : Theory_over T hT :=
    by {refine ⟨T_max'.fst.val ∪ {ψ}, ⟨_, H⟩⟩, simp[has_subset.subset], intros ψ hψT,
        dedup, have extension_assumption := T_max'.fst.property.left, simp[has_insert.insert],
        from or.inr (extension_assumption ‹_›)},
  have h_bad := T_max'.snd T_bad,
  from absurd (h_bad (by finish) (by simp)) H1
end

/-- Given a maximal consistent extension of consistent theory T, show it is complete --/
lemma complete_maximal_extension_of_consis {L : Language} {T : Theory L} {hT : is_consistent T}: @is_complete L (@maximal_extension L T hT).fst.val :=
begin
  refine ⟨(@maximal_extension L T hT).fst.property.right, _⟩,
  intro ψ, by_cases ψ ∈ (@maximal_extension L T hT).fst.val, exact or.inl h,
  apply or.inr,
  by_contra,
  have can_extend := @can_extend L (@maximal_extension L T hT).fst.val ψ (@maximal_extension L T hT).fst.property.right,
  have h_max := (@maximal_extension L T hT).snd,

  by_cases is_consistent ((@maximal_extension L T hT).fst.val ∪ {ψ}),
    {rename h h1,
      from cannot_extend_maximal_extension _ _ ‹_› ‹_›},
  {rename h h2,
  have q_of_not_p : ∀ p q : Prop, ∀ h1 : p ∨ q, ∀ h2 : ¬ p, q := by tauto,
  have h2' := q_of_not_p _ _ can_extend h2,
  from cannot_extend_maximal_extension _ _ ‹_› ‹_›}
end

/-- Given a consistent theory, return a complete extension of it --/
noncomputable def completion_of_consis : Π ( T : Theory L) (h_consis : is_consistent T), Σ' T' : (Theory_over T h_consis), is_complete T'.val :=
λ T h_consis, ⟨(maximal_extension L T h_consis).fst, by apply complete_maximal_extension_of_consis⟩

end


/-
Copyright (c) 2018 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Jeremy Avigad

Polynomial functors. Also expresses the W-type construction as a polynomial functor.
(For the M-type construction, see Mtype.lean.)
-/
import tactic.interactive data.multiset
universe u

/- TODO (Jeremy): move this. -/

namespace functor

variables {F : Type u → Type u} [functor F]

def liftp {α : Type u} (p : α → Prop) : F α → Prop :=
λ x, ∃ u : F (subtype p), subtype.val <$> u = x

def liftr {α β : Type u} (r : α → β → Prop) : F α → F β → Prop :=
λ x y, ∃ u : F {p : α × β // r p.fst p.snd},
  (λ t : {p : α × β // r p.fst p.snd}, t.val.fst) <$> u = x ∧
  (λ t : {p : α × β // r p.fst p.snd}, t.val.snd) <$> u = y

def supp {α : Type u} (x : F α) : set α := { y : α | ∀ ⦃p⦄, liftp p x → p y }

theorem of_mem_supp {α : Type u} {x : F α} {p : α → Prop} (h : liftp p x) :
  ∀ y ∈ supp x, p y :=
λ y hy, hy h

end functor

/-
A polynomial functor `P` is given by a type `A` and a family `B` of types over `A`. `P` maps
any type `α` to a new type `P.apply α`.

An element of `P.apply α` is a pair `⟨a, f⟩`, where `a` is an element of a type `A` and
`f : B a → α`. Think of `a` as the shape of the object and `f` as an index to the relevant
elements of `α`.
-/

structure pfunctor :=
(A : Type u) (B : A → Type u)

namespace pfunctor

variables (P : pfunctor) {α β : Type u}

-- TODO: generalize to psigma?
def apply (α : Type*) := Σ x : P.A, P.B x → α

def map {α β : Type*} (f : α → β) : P.apply α → P.apply β :=
λ ⟨a, g⟩, ⟨a, f ∘ g⟩

instance : functor P.apply := {map := @map P}

theorem map_eq {α β : Type*} (f : α → β) (a : P.A) (g : P.B a → α) :
  @functor.map P.apply _ _ _ f ⟨a, g⟩ = ⟨a, f ∘ g⟩ :=
rfl

theorem id_map {α : Type*} : ∀ x : P.apply α, id <$> x = id x :=
λ ⟨a, b⟩, rfl

theorem comp_map {α β γ : Type*} (f : α → β) (g : β → γ) :
  ∀ x : P.apply α, (g ∘ f) <$> x = g <$> (f <$> x) :=
λ ⟨a, b⟩, rfl

instance : is_lawful_functor P.apply :=
{id_map := @id_map P, comp_map := @comp_map P}

inductive W
| mk (a : P.A) (f : P.B a → W) : W

def W_dest : W P → P.apply (W P)
| ⟨a, f⟩ := ⟨a, f⟩

def W_mk : P.apply (W P) → W P
| ⟨a, f⟩ := ⟨a, f⟩

@[simp] theorem W_dest_W_mk (p : P.apply (W P)) : P.W_dest (P.W_mk p) = p :=
by cases p; reflexivity

@[simp] theorem W_mk_W_dest (p : W P) : P.W_mk (P.W_dest p) = p :=
by cases p; reflexivity

def Idx := Σ x : P.A, P.B x
variables {P}

def apply.iget [decidable_eq P.A] {α} [inhabited α] (x : P.apply α) (i : P.Idx) : α :=
if h : i.1 = x.1
  then x.2 (cast (congr_arg _ h) i.2)
  else default _

@[simp]
lemma fst_map {α β : Type u} (x : P.apply α) (f : α → β) :
  (f <$> x).1 = x.1 := by { cases x; refl }

@[simp]
lemma iget_map [decidable_eq P.A] {α β : Type u} [inhabited α] [inhabited β]
  (x : P.apply α) (f : α → β) (i : P.Idx)
  (h : i.1 = x.1) :
  (f <$> x).iget i = f (x.iget i) :=
by { simp [apply.iget],
     rw [dif_pos h,dif_pos];
     cases x, refl, rw h, refl }

end pfunctor

/-
Composition of polynomial functors.
-/

namespace pfunctor

/-
def comp : pfunctor.{u} → pfunctor.{u} → pfunctor.{u}
| ⟨A₂, B₂⟩ ⟨A₁, B₁⟩ := ⟨Σ a₂ : A₂, B₂ a₂ → A₁, λ ⟨a₂, a₁⟩, Σ u : B₂ a₂, B₁ (a₁ u)⟩
-/

def comp (P₂ P₁ : pfunctor.{u}) : pfunctor.{u} :=
⟨ Σ a₂ : P₂.1, P₂.2 a₂ → P₁.1,
  λ a₂a₁, Σ u : P₂.2 a₂a₁.1, P₁.2 (a₂a₁.2 u) ⟩

def comp.mk (P₂ P₁ : pfunctor.{u}) {α : Type} (x : P₂.apply (P₁.apply α)) : (comp P₂ P₁).apply α :=
⟨ ⟨ x.1, sigma.fst ∘ x.2 ⟩, λ a₂a₁, (x.2 a₂a₁.1).2 a₂a₁.2  ⟩

def comp.get (P₂ P₁ : pfunctor.{u}) {α : Type} (x : (comp P₂ P₁).apply α) : P₂.apply (P₁.apply α) :=
⟨ x.1.1, λ a₂, ⟨x.1.2 a₂, λ a₁, x.2 ⟨a₂,a₁⟩ ⟩ ⟩

end pfunctor

/-
Lifting predicates and relations.
-/

namespace pfunctor
variables {P : pfunctor.{u}}
open functor

theorem liftp_iff {α : Type u} (p : α → Prop) (x : P.apply α) :
  liftp p x ↔ ∃ a f, x = ⟨a, f⟩ ∧ ∀ i, p (f i) :=
begin
  split,
  { rintros ⟨y, hy⟩, cases h : y with a f,
    refine ⟨a, λ i, (f i).val, _, λ i, (f i).property⟩,
    rw [←hy, h, map_eq] },
  rintros ⟨a, f, xeq, pf⟩,
  use ⟨a, λ i, ⟨f i, pf i⟩⟩,
  rw [xeq], reflexivity
end

theorem liftr_iff {α : Type u} (r : α → α → Prop) (x y : P.apply α) :
  liftr r x y ↔ ∃ a f₀ f₁, x = ⟨a, f₀⟩ ∧ y = ⟨a, f₁⟩ ∧ ∀ i, r (f₀ i) (f₁ i) :=
begin
  split,
  { rintros ⟨u, xeq, yeq⟩, cases h : u with a f,
    use [a, λ i, (f i).val.fst, λ i, (f i).val.snd],
    split, { rw [←xeq, h], refl },
    split, { rw [←yeq, h], refl },
    intro i, exact (f i).property },
  rintros ⟨a, f₀, f₁, xeq, yeq, h⟩,
  use ⟨a, λ i, ⟨(f₀ i, f₁ i), h i⟩⟩,
  dsimp, split,
  { rw [xeq], refl },
  rw [yeq], refl
end

end pfunctor

/-
Facts about the general quotient needed to construct final coalgebras.

TODO (Jeremy): move these somewhere.
-/

namespace quot

def factor {α : Type*} (r s: α → α → Prop) (h : ∀ x y, r x y → s x y) :
  quot r → quot s :=
quot.lift (quot.mk s) (λ x y rxy, quot.sound (h x y rxy))

def factor_mk_eq {α : Type*} (r s: α → α → Prop) (h : ∀ x y, r x y → s x y) :
  factor r s h ∘ quot.mk _= quot.mk _ := rfl

end quot


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

/-!
# Small types

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

A type is `w`-small if there exists an equivalence to some `S : Type w`.

We provide a noncomputable model `shrink α : Type w`, and `equiv_shrink α : α ≃ shrink α`.

A subsingleton type is `w`-small for any `w`.

If `α ≃ β`, then `small.{w} α ↔ small.{w} β`.
-/

universes u w v

/--
A type is `small.{w}` if there exists an equivalence to some `S : Type w`.
-/
class small (α : Type v) : Prop :=
(equiv_small : ∃ (S : Type w), nonempty (α ≃ S))

/--
Constructor for `small α` from an explicit witness type and equivalence.
-/
lemma small.mk' {α : Type v} {S : Type w} (e : α ≃ S) : small.{w} α :=
⟨⟨S, ⟨e⟩⟩⟩

/--
An arbitrarily chosen model in `Type w` for a `w`-small type.
-/
@[nolint has_nonempty_instance]
def shrink (α : Type v) [small.{w} α] : Type w :=
classical.some (@small.equiv_small α _)

/--
The noncomputable equivalence between a `w`-small type and a model.
-/
noncomputable
def equiv_shrink (α : Type v) [small.{w} α] : α ≃ shrink α :=
nonempty.some (classical.some_spec (@small.equiv_small α _))

@[priority 100]
instance small_self (α : Type v) : small.{v} α :=
small.mk' $ equiv.refl α

theorem small_map {α : Type*} {β : Type*} [hβ : small.{w} β] (e : α ≃ β) : small.{w} α :=
let ⟨γ, ⟨f⟩⟩ := hβ.equiv_small in small.mk' (e.trans f)

theorem small_lift (α : Type u) [hα : small.{v} α] : small.{max v w} α :=
let ⟨⟨γ, ⟨f⟩⟩⟩ := hα in small.mk' $ f.trans equiv.ulift.symm

@[priority 100]
instance small_max (α : Type v) : small.{max w v} α :=
small_lift.{v w} α

instance small_ulift (α : Type u) [small.{v} α] : small.{v} (ulift.{w} α) :=
small_map equiv.ulift

theorem small_type : small.{max (u+1) v} (Type u) := small_max.{max (u+1) v} _

section
open_locale classical

theorem small_congr {α : Type*} {β : Type*} (e : α ≃ β) : small.{w} α ↔ small.{w} β :=
⟨λ h, @small_map _ _ h e.symm, λ h, @small_map _ _ h e⟩

instance small_subtype (α : Type v) [small.{w} α] (P : α → Prop) : small.{w} { x // P x } :=
small_map (equiv_shrink α).subtype_equiv_of_subtype'

theorem small_of_injective {α : Type v} {β : Type w} [small.{u} β] {f : α → β}
  (hf : function.injective f) : small.{u} α :=
small_map (equiv.of_injective f hf)

theorem small_of_surjective {α : Type v} {β : Type w} [small.{u} α] {f : α → β}
  (hf : function.surjective f) : small.{u} β :=
small_of_injective (function.injective_surj_inv hf)

theorem small_subset {α : Type v} {s t : set α} (hts : t ⊆ s) [small.{u} s] : small.{u} t :=
let f : t → s := λ x, ⟨x, hts x.prop⟩ in
  @small_of_injective _ _ _ f (λ x y hxy, subtype.ext (subtype.mk.inj hxy))

@[priority 100]
instance small_subsingleton (α : Type v) [subsingleton α] : small.{w} α :=
begin
  rcases is_empty_or_nonempty α; resetI,
  { apply small_map (equiv.equiv_pempty α) },
  { apply small_map equiv.punit_of_nonempty_of_subsingleton, assumption' },
end

/-!
We don't define `small_of_fintype` or `small_of_countable` in this file,
to keep imports to `logic` to a minimum.
-/

instance small_Pi {α} (β : α → Type*) [small.{w} α] [∀ a, small.{w} (β a)] :
  small.{w} (Π a, β a) :=
⟨⟨Π a' : shrink α, shrink (β ((equiv_shrink α).symm a')),
  ⟨equiv.Pi_congr (equiv_shrink α) (λ a, by simpa using equiv_shrink (β a))⟩⟩⟩

instance small_sigma {α} (β : α → Type*) [small.{w} α] [∀ a, small.{w} (β a)] :
  small.{w} (Σ a, β a) :=
⟨⟨Σ a' : shrink α, shrink (β ((equiv_shrink α).symm a')),
  ⟨equiv.sigma_congr (equiv_shrink α) (λ a, by simpa using equiv_shrink (β a))⟩⟩⟩

instance small_prod {α β} [small.{w} α] [small.{w} β] : small.{w} (α × β) :=
⟨⟨shrink α × shrink β,
  ⟨equiv.prod_congr (equiv_shrink α) (equiv_shrink β)⟩⟩⟩

instance small_sum {α β} [small.{w} α] [small.{w} β] : small.{w} (α ⊕ β) :=
⟨⟨shrink α ⊕ shrink β,
  ⟨equiv.sum_congr (equiv_shrink α) (equiv_shrink β)⟩⟩⟩

instance small_set {α} [small.{w} α] : small.{w} (set α) :=
⟨⟨set (shrink α), ⟨equiv.set.congr (equiv_shrink α)⟩⟩⟩

instance small_range {α : Type v} {β : Type w} (f : α → β) [small.{u} α] :
  small.{u} (set.range f) :=
small_of_surjective set.surjective_onto_range

instance small_image {α : Type v} {β : Type w} (f : α → β) (S : set α) [small.{u} S] :
  small.{u} (f '' S) :=
small_of_surjective set.surjective_onto_image

theorem not_small_type : ¬ small.{u} (Type (max u v))
| ⟨⟨S, ⟨e⟩⟩⟩ := @function.cantor_injective (Σ α, e.symm α)
  (λ a, ⟨_, cast (e.3 _).symm a⟩)
  (λ a b e, (cast_inj _).1 $ eq_of_heq (sigma.mk.inj e).2)

end


/-
This is the second homework assignment for UVa CS2101, Spring 2019.

If you are in Professor Sullivan's class, you are to complete problems 1 - 8.
If you are in Prof. Hocking's class, you are to complete problems 9 - 13.

The first eight problems require that you carefully read the updated class
notes on relations vs. functions and on properties of functions: from the
start of 2.4 through 2.4.4. For all of the remaining problems, you must
have read the rest of the chapter, on higher-order functions.

The collaboration policy for this assignment has two parts. First, you must
complete this work on your own. Second, please do not discuss your results
with anyone in the other professor's class, even after the deadline for the
homework has passed, as your assignment this week will be part of their
assignment next week.

To complete this homework, first make a copy of this file in the "work"
directory of your class repository. Do not edit this file directly in the
hw directory. Make a copy first. Then fill in answers as required, save
your changes, and submit your work by uploading the completed file on Collab.

Make a copy of this file in your work directory; complete the work using
that copy; then upload the resulting file, after saving it, through Collab
before the due date.
-/

/-
1. Is the function, G, as defined in the reading, total? Explain.

Answer here:

-/

/-
2. Give an example of a value in the domain of definition the function, F,
as defined in the reading, that proves that F is strictly partial, i.e.,
for which F is not defined.

Answer here:

-/

/-
3. Give an example of a value in the codomain of F that proves that F is
not surjective.

Answer here:

-/

/-
4. Is our example function, G, strictly partial? Explain.

Answer here:

-/

/-
5. Identify a value in the codomain of F that is not the image of any
value value in its domain of definition.

Answer here:

-/

/-
6. Translate our logical definition of injective into mathematically
precise English following the examples for other properties of functions
given in the reading.

Answer here:

-/

/-
7. Is the function, f(x) = log(x) over the real numbers, injective?
Is it surjective? Is it bijective? Explain each of your answers briefly.

Answer here:

-/

/-
8. Is the relation, 3x^2 + 4y^2 = 4, single-valued? Explain your answers.

Answer here:

-/

/-
Complete each of the following partial definitions in Lean by replacing
the underscore characters with code to define functions of the specified
types using lambda notation. We only care that you define some function
of each required type, not what particular function you define.

In preparation, note that if you hover your mouse over an underscore,
Lean will tell you what type of term you is needed to fill that hole.
The type that Lean requires appears after the "turnstile" symbol, |-,
in the message Lean will give you. Even more interestingly, if you
fill in a hole with a term of the right type that itself has one or
more remaining holes, Lean will tell you what types of terms are needed
to fill in those holes! You can thus fill a hole in an incremental manner,
refining a partial solution at each step until all holes are filled,
guided by the types that Lean tells you are needed for any given hole.
We recommend that you try developing your answers in this "top-down
structured" style of programming. That said, we will grade you only on
your answers and not on how you developed them.
-/

-- 9.
def hw2_1: ℕ → ℕ :=
    λ(x: ℕ),
        _

-- 10.
def hw2_2: ℕ → ℕ → ℕ :=
    _

-- 11.
def hw2_3: (ℕ → ℕ) → (ℕ → ℕ) :=
    _

-- 12.
def hw2_4: (ℕ → ℕ) → ((ℕ → ℕ) → ℕ) :=
    _

-- 13.
def hw2_5: (ℕ → ℕ) → ((ℕ → ℕ) → (ℕ → ℕ)) :=
    _


/-
Copyright (c) 2022 Riccardo Brasca. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Alex Best, Riccardo Brasca, Eric Rodriguez
-/

import data.pnat.prime
import algebra.is_prime_pow
import number_theory.cyclotomic.basic
import ring_theory.adjoin.power_basis
import ring_theory.polynomial.cyclotomic.eval
import ring_theory.norm

/-!
# Primitive roots in cyclotomic fields
If `is_cyclotomic_extension {n} A B`, we define an element `zeta n A B : B` that is (under certain
assumptions) a primitive `n`-root of unity in `B` and we study its properties. We also prove related
theorems under the more general assumption of just being a primitive root, for reasons described
in the implementation details section.

## Main definitions
* `is_cyclotomic_extension.zeta n A B`: if `is_cyclotomic_extension {n} A B`, than `zeta n A B`
  is an element of `B` that plays the role of a primitive `n`-th root of unity.
* `is_primitive_root.power_basis`: if `K` and `L` are fields such that
  `is_cyclotomic_extension {n} K L`, then `is_primitive_root.power_basis`
  gives a K-power basis for L given a primitive root `ζ`.
* `is_primitive_root.embeddings_equiv_primitive_roots`: the equivalence between `L →ₐ[K] A`
  and `primitive_roots n A` given by the choice of `ζ`.

## Main results
* `is_cyclotomic_extension.zeta_primitive_root`: `zeta n A B` is a primitive `n`-th root of unity.
* `is_cyclotomic_extension.finrank`: if `irreducible (cyclotomic n K)` (in particular for
  `K = ℚ`), then the `finrank` of a cyclotomic extension is `n.totient`.
* `is_primitive_root.norm_eq_one`: if `irreducible (cyclotomic n K)` (in particular for `K = ℚ`),
  the norm of a primitive root is `1` if `n ≠ 2`.
* `is_primitive_root.sub_one_norm_eq_eval_cyclotomic`: if `irreducible (cyclotomic n K)`
  (in particular for `K = ℚ`), then the norm of `ζ - 1` is `eval 1 (cyclotomic n ℤ)`, for a
  primitive root ζ. We also prove the analogous of this result for `zeta`.
* `is_primitive_root.pow_sub_one_norm_prime_pow_ne_two` : if
  `irreducible (cyclotomic (p ^ (k + 1)) K)` (in particular for `K = ℚ`) and `p` is a prime,
  then the norm of `ζ ^ (p ^ s) - 1` is `p ^ (p ^ s)` `p ^ (k - s + 1) ≠ 2`. See the following
  lemmas for similar results. We also prove the analogous of this result for `zeta`.
* `is_primitive_root.sub_one_norm_prime_ne_two` : if `irreducible (cyclotomic (p ^ (k + 1)) K)`
  (in particular for `K = ℚ`) and `p` is an odd prime, then the norm of `ζ - 1` is `p`. We also
  prove the analogous of this result for `zeta`.
* `is_primitive_root.embeddings_equiv_primitive_roots`: the equivalence between `L →ₐ[K] A`
  and `primitive_roots n A` given by the choice of `ζ`.

## Implementation details
`zeta n A B` is defined as any primitive root of unity in `B`, that exists by definition. It is not
true in general that it is a root of `cyclotomic n B`, but this holds if `is_domain B` and
`ne_zero (↑n : B)`.

`zeta n A B` is defined using `exists.some`, which means we cannot control it.
For example, in normal mathematics, we can demand that `(zeta p ℤ ℤ[ζₚ] : ℚ(ζₚ))` is equal to
`zeta p ℚ ℚ(ζₚ)`, as we are just choosing "an arbitrary primitive root" and we can internally
specify that our choices agree. This is not the case here, and it is indeed impossible to prove that
these two are equal. Therefore, whenever possible, we prove our results for any primitive root,
and only at the "final step", when we need to provide an "explicit" primitive root, we use `zeta`.

-/

open polynomial algebra finset finite_dimensional is_cyclotomic_extension nat pnat set

universes u v w z

variables {p n : ℕ+} (A : Type w) (B : Type z) (K : Type u) {L : Type v} (C : Type w)
variables [comm_ring A] [comm_ring B] [algebra A B] [is_cyclotomic_extension {n} A B]

section zeta

namespace is_cyclotomic_extension

variables (n)

/-- If `B` is a `n`-th cyclotomic extension of `A`, then `zeta n A B` is a primitive root of
unity in `B`. -/
noncomputable def zeta : B :=
(exists_prim_root A $ set.mem_singleton n : ∃ r : B, is_primitive_root r n).some

/-- `zeta n A B` is a primitive `n`-th root of unity. -/
@[simp] lemma zeta_spec : is_primitive_root (zeta n A B) n :=
classical.some_spec (exists_prim_root A (set.mem_singleton n) : ∃ r : B, is_primitive_root r n)

lemma aeval_zeta [is_domain B] [ne_zero ((n : ℕ) : B)] :
  aeval (zeta n A B) (cyclotomic n A) = 0 :=
begin
  rw [aeval_def,  ← eval_map, ← is_root.def, map_cyclotomic, is_root_cyclotomic_iff],
  exact zeta_spec n A B
end

lemma zeta_is_root [is_domain B] [ne_zero ((n : ℕ) : B)] :
  is_root (cyclotomic n B) (zeta n A B) :=
by { convert aeval_zeta n A B, rw [is_root.def, aeval_def, eval₂_eq_eval_map, map_cyclotomic] }

lemma zeta_pow : (zeta n A B) ^ (n : ℕ) = 1 :=
(zeta_spec n A B).pow_eq_one

end is_cyclotomic_extension

end zeta

section no_order

variables [field K] [comm_ring L] [is_domain L] [algebra K L] [is_cyclotomic_extension {n} K L]
          {ζ : L} (hζ : is_primitive_root ζ n)

namespace is_primitive_root

variable {C}

/-- The `power_basis` given by a primitive root `η`. -/
@[simps] protected noncomputable def power_basis : power_basis K L :=
power_basis.map (algebra.adjoin.power_basis $ integral {n} K L ζ) $
  (subalgebra.equiv_of_eq _ _ (is_cyclotomic_extension.adjoin_primitive_root_eq_top hζ)).trans
  subalgebra.top_equiv

lemma power_basis_gen_mem_adjoin_zeta_sub_one :
  (hζ.power_basis K).gen ∈ adjoin K ({ζ - 1} : set L) :=
begin
  rw [power_basis_gen, adjoin_singleton_eq_range_aeval, alg_hom.mem_range],
  exact ⟨X + 1, by simp⟩
end

/-- The `power_basis` given by `η - 1`. -/
@[simps] noncomputable def sub_one_power_basis : power_basis K L :=
  (hζ.power_basis K).of_gen_mem_adjoin
    (is_integral_sub (is_cyclotomic_extension.integral {n} K L ζ) is_integral_one)
    (hζ.power_basis_gen_mem_adjoin_zeta_sub_one _)

variables {K} (C)

/-- The equivalence between `L →ₐ[K] C` and `primitive_roots n C` given by a primitive root `ζ`. -/
@[simps] noncomputable def embeddings_equiv_primitive_roots (C : Type*) [comm_ring C] [is_domain C]
  [algebra K C] (hirr : irreducible (cyclotomic n K)) : (L →ₐ[K] C) ≃ primitive_roots n C :=
((hζ.power_basis K).lift_equiv).trans
{ to_fun    := λ x,
  begin
    haveI := is_cyclotomic_extension.ne_zero' n K L,
    haveI hn := ne_zero.of_no_zero_smul_divisors K C n,
    refine ⟨x.1, _⟩,
    cases x,
    rwa [mem_primitive_roots n.pos, ←is_root_cyclotomic_iff, is_root.def,
         ←map_cyclotomic _ (algebra_map K C), hζ.minpoly_eq_cyclotomic_of_irreducible hirr,
         ←eval₂_eq_eval_map, ←aeval_def]
  end,
  inv_fun   := λ x,
  begin
    haveI := is_cyclotomic_extension.ne_zero' n K L,
    haveI hn := ne_zero.of_no_zero_smul_divisors K C n,
    refine ⟨x.1, _⟩,
    cases x,
    rwa [aeval_def, eval₂_eq_eval_map, hζ.power_basis_gen K,
         ←hζ.minpoly_eq_cyclotomic_of_irreducible hirr, map_cyclotomic, ←is_root.def,
         is_root_cyclotomic_iff, ← mem_primitive_roots n.pos]
  end,
  left_inv  := λ x, subtype.ext rfl,
  right_inv := λ x, subtype.ext rfl }

end is_primitive_root

namespace is_cyclotomic_extension

variables {K} (L)

/-- If `irreducible (cyclotomic n K)` (in particular for `K = ℚ`), then the `finrank` of a
cyclotomic extension is `n.totient`. -/
lemma finrank (hirr : irreducible (cyclotomic n K)) :
  finrank K L = (n : ℕ).totient :=
begin
  haveI := is_cyclotomic_extension.ne_zero' n K L,
  rw [((zeta_spec n K L).power_basis K).finrank, is_primitive_root.power_basis_dim,
      ←(zeta_spec n K L).minpoly_eq_cyclotomic_of_irreducible hirr, nat_degree_cyclotomic]
end

end is_cyclotomic_extension

end no_order

section norm

namespace is_primitive_root

variables [field L] {ζ : L} (hζ : is_primitive_root ζ n)
variables {K} [field K] [algebra K L]

/-- This mathematically trivial result is complementary to `norm_eq_one` below. -/
lemma norm_eq_neg_one_pow (hζ : is_primitive_root ζ 2) : norm K ζ = (-1) ^ finrank K L :=
by rw [hζ.eq_neg_one_of_two_right , show -1 = algebra_map K L (-1), by simp,
  algebra.norm_algebra_map]

include hζ

/-- If `irreducible (cyclotomic n K)` (in particular for `K = ℚ`), the norm of a primitive root is
`1` if `n ≠ 2`. -/
lemma norm_eq_one [is_cyclotomic_extension {n} K L] (hn : n ≠ 2)
  (hirr : irreducible (cyclotomic n K)) : norm K ζ = 1 :=
begin
  haveI := is_cyclotomic_extension.ne_zero' n K L,
  by_cases h1 : n = 1,
  { rw [h1, one_coe, one_right_iff] at hζ,
    rw [hζ, show 1 = algebra_map K L 1, by simp, algebra.norm_algebra_map, one_pow] },
  { replace h1 : 2 ≤ n,
    { by_contra' h,
      exact h1 (pnat.eq_one_of_lt_two h) },
    rw [← hζ.power_basis_gen K, power_basis.norm_gen_eq_coeff_zero_minpoly, hζ.power_basis_gen K,
      ← hζ.minpoly_eq_cyclotomic_of_irreducible hirr, cyclotomic_coeff_zero _ h1, mul_one,
      hζ.power_basis_dim K, ← hζ.minpoly_eq_cyclotomic_of_irreducible hirr, nat_degree_cyclotomic],
    exact (totient_even $ h1.lt_of_ne hn.symm).neg_one_pow }
end

/-- If `K` is linearly ordered, the norm of a primitive root is `1` if `n` is odd. -/
lemma norm_eq_one_of_linearly_ordered {K : Type*} [linear_ordered_field K] [algebra K L]
  (hodd : odd (n : ℕ)) : norm K ζ = 1 :=
begin
  have hz := congr_arg (norm K) ((is_primitive_root.iff_def _ n).1 hζ).1,
  rw [←(algebra_map K L).map_one , algebra.norm_algebra_map, one_pow, map_pow, ←one_pow ↑n] at hz,
  exact strict_mono.injective hodd.strict_mono_pow hz
end

lemma norm_of_cyclotomic_irreducible [is_cyclotomic_extension {n} K L]
  (hirr : irreducible (cyclotomic n K)) : norm K ζ = ite (n = 2) (-1) 1 :=
begin
  split_ifs with hn,
  { unfreezingI {subst hn},
    convert norm_eq_neg_one_pow hζ,
    erw [is_cyclotomic_extension.finrank _ hirr, totient_two, pow_one],
    all_goals { apply_instance } },
  { exact hζ.norm_eq_one hn hirr }
end

/-- If `irreducible (cyclotomic n K)` (in particular for `K = ℚ`), then the norm of
`ζ - 1` is `eval 1 (cyclotomic n ℤ)`. -/
lemma sub_one_norm_eq_eval_cyclotomic [is_cyclotomic_extension {n} K L]
  (h : 2 < (n : ℕ)) (hirr : irreducible (cyclotomic n K)) :
  norm K (ζ - 1) = ↑(eval 1 (cyclotomic n ℤ)) :=
begin
  haveI := is_cyclotomic_extension.ne_zero' n K L,
  let E := algebraic_closure L,
  obtain ⟨z, hz⟩ := is_alg_closed.exists_root _ (degree_cyclotomic_pos n E n.pos).ne.symm,
  apply (algebra_map K E).injective,
  letI := finite_dimensional {n} K L,
  letI := is_galois n K L,
  rw [norm_eq_prod_embeddings],
  conv_lhs { congr, skip, funext,
    rw [← neg_sub, alg_hom.map_neg, alg_hom.map_sub, alg_hom.map_one, neg_eq_neg_one_mul] },
  rw [prod_mul_distrib, prod_const, card_univ, alg_hom.card, is_cyclotomic_extension.finrank L hirr,
    (totient_even h).neg_one_pow, one_mul],
  have : finset.univ.prod (λ (σ : L →ₐ[K] E), 1 - σ ζ) = eval 1 (cyclotomic' n E),
  { rw [cyclotomic', eval_prod, ← @finset.prod_attach E E, ← univ_eq_attach],
    refine fintype.prod_equiv (hζ.embeddings_equiv_primitive_roots E hirr) _ _ (λ σ, _),
    simp },
  haveI : ne_zero ((n : ℕ) : E) := (ne_zero.of_no_zero_smul_divisors K _ (n : ℕ)),
  rw [this, cyclotomic', ← cyclotomic_eq_prod_X_sub_primitive_roots (is_root_cyclotomic_iff.1 hz),
      ← map_cyclotomic_int, (algebra_map K E).map_int_cast, ←int.cast_one, eval_int_cast_map,
      ring_hom.eq_int_cast, int.cast_id]
end

/-- If `is_prime_pow (n : ℕ)`, `n ≠ 2` and `irreducible (cyclotomic n K)` (in particular for
`K = ℚ`), then the norm of `ζ - 1` is `(n : ℕ).min_fac`. -/
lemma sub_one_norm_is_prime_pow (hn : is_prime_pow (n : ℕ)) [is_cyclotomic_extension {n} K L]
  (hirr : irreducible (cyclotomic (n : ℕ) K)) (h : n ≠ 2) :
  norm K (ζ - 1) = (n : ℕ).min_fac :=
begin
  have := (coe_lt_coe 2 _).1 (lt_of_le_of_ne (succ_le_of_lt (is_prime_pow.one_lt hn))
    (function.injective.ne pnat.coe_injective h).symm),
  letI hprime : fact ((n : ℕ).min_fac.prime) := ⟨min_fac_prime (is_prime_pow.ne_one hn)⟩,
  rw [sub_one_norm_eq_eval_cyclotomic hζ this hirr],
  nth_rewrite 0 [← is_prime_pow.min_fac_pow_factorization_eq hn],
  obtain ⟨k, hk⟩ : ∃ k, ((n : ℕ).factorization) (n : ℕ).min_fac = k + 1 :=
    exists_eq_succ_of_ne_zero (((n : ℕ).factorization.mem_support_to_fun (n : ℕ).min_fac).1 $
      factor_iff_mem_factorization.2 $ (mem_factors (is_prime_pow.ne_zero hn)).2
        ⟨hprime.out, min_fac_dvd _⟩),
  simp [hk, sub_one_norm_eq_eval_cyclotomic hζ this hirr],
end

omit hζ

variable {A}

lemma minpoly_sub_one_eq_cyclotomic_comp [algebra K A] [is_domain A] {ζ : A}
  [is_cyclotomic_extension {n} K A] (hζ : is_primitive_root ζ n)
  (h : irreducible (polynomial.cyclotomic n K)) :
  minpoly K (ζ - 1) = (cyclotomic n K).comp (X + 1) :=
begin
  haveI := is_cyclotomic_extension.ne_zero' n K A,
  rw [show ζ - 1 = ζ + (algebra_map K A (-1)), by simp [sub_eq_add_neg], minpoly.add_algebra_map
    (is_cyclotomic_extension.integral {n} K A ζ), hζ.minpoly_eq_cyclotomic_of_irreducible h],
  simp
end

local attribute [instance] is_cyclotomic_extension.finite_dimensional
local attribute [instance] is_cyclotomic_extension.is_galois

/-- If `irreducible (cyclotomic (p ^ (k + 1)) K)` (in particular for `K = ℚ`) and `p` is a prime,
then the norm of `ζ ^ (p ^ s) - 1` is `p ^ (p ^ s)` if `p ^ (k - s + 1) ≠ 2`. See the next lemmas
for similar results. -/
lemma pow_sub_one_norm_prime_pow_ne_two {k s : ℕ} (hζ : is_primitive_root ζ ↑(p ^ (k + 1)))
  [hpri : fact (p : ℕ).prime] [is_cyclotomic_extension {p ^ (k + 1)} K L]
  (hirr : irreducible (cyclotomic (↑(p ^ (k + 1)) : ℕ) K)) (hs : s ≤ k)
  (htwo : p ^ (k - s + 1) ≠ 2) : norm K (ζ ^ ((p : ℕ) ^ s) - 1) = p ^ ((p : ℕ) ^ s) :=
begin
  have hirr₁ : irreducible (cyclotomic (p ^ (k - s + 1)) K) :=
  cyclotomic_irreducible_pow_of_irreducible_pow hpri.1 (by linarith) hirr,
  rw ←pnat.pow_coe at hirr₁,
  let η := ζ ^ ((p : ℕ) ^ s) - 1,
  let η₁ : K⟮η⟯ := intermediate_field.adjoin_simple.gen K η,
  have hη : is_primitive_root (η + 1) (p ^ (k + 1 - s)),
  { rw [sub_add_cancel],
    refine is_primitive_root.pow (p ^ (k + 1)).pos hζ _,
    rw [pnat.pow_coe, ← pow_add, add_comm s, nat.sub_add_cancel (le_trans hs (nat.le_succ k))] },
  haveI : is_cyclotomic_extension {p ^ (k - s + 1)} K K⟮η⟯,
  { suffices : is_cyclotomic_extension {p ^ (k - s + 1)} K K⟮η + 1⟯.to_subalgebra,
    { have H : K⟮η + 1⟯.to_subalgebra = K⟮η⟯.to_subalgebra,
      { simp only [intermediate_field.adjoin_simple_to_subalgebra_of_integral _ _
          (is_cyclotomic_extension.integral {p ^ (k + 1)} K L _)],
        refine subalgebra.ext (λ x, ⟨λ hx, adjoin_le _ hx, λ hx, adjoin_le _ hx⟩),
        { simp only [set.singleton_subset_iff, set_like.mem_coe],
          exact subalgebra.add_mem _ (subset_adjoin (mem_singleton η)) (subalgebra.one_mem _) },
        { simp only [set.singleton_subset_iff, set_like.mem_coe],
          nth_rewrite 0 [← add_sub_cancel η 1],
          refine subalgebra.sub_mem _ (subset_adjoin (mem_singleton _)) (subalgebra.one_mem _) } },
      rw [H] at this,
      exact this },
    rw [intermediate_field.adjoin_simple_to_subalgebra_of_integral _ _
      (is_cyclotomic_extension.integral {p ^ (k + 1)} K L _)],
    have hη' : is_primitive_root (η + 1) ↑(p ^ (k + 1 - s)) := by simpa using hη,
    convert hη'.adjoin_is_cyclotomic_extension K,
    rw [nat.sub_add_comm hs] },
  replace hη : is_primitive_root (η₁ + 1) ↑(p ^ (k - s + 1)),
  { apply coe_submonoid_class_iff.1,
    convert hη,
    rw [nat.sub_add_comm hs, pow_coe] },
  rw [norm_eq_norm_adjoin K],
  { have H := hη.sub_one_norm_is_prime_pow _ hirr₁ htwo,
    swap, { rw [pnat.pow_coe], exact hpri.1.is_prime_pow.pow (nat.succ_ne_zero _) },
    rw [add_sub_cancel] at H,
    rw [H, coe_coe],
    congr,
    { rw [pnat.pow_coe, nat.pow_min_fac, hpri.1.min_fac_eq], exact nat.succ_ne_zero _ },
    have := finite_dimensional.finrank_mul_finrank K K⟮η⟯ L,
    rw [is_cyclotomic_extension.finrank L hirr, is_cyclotomic_extension.finrank K⟮η⟯ hirr₁,
      pnat.pow_coe, pnat.pow_coe, nat.totient_prime_pow hpri.out (k - s).succ_pos,
      nat.totient_prime_pow hpri.out k.succ_pos, mul_comm _ (↑p - 1), mul_assoc,
      mul_comm (↑p ^ (k.succ - 1))] at this,
    replace this := nat.eq_of_mul_eq_mul_left (tsub_pos_iff_lt.2 (nat.prime.one_lt hpri.out)) this,
    have Hex : k.succ - 1 = (k - s).succ - 1 + s,
    { simp only [nat.succ_sub_succ_eq_sub, tsub_zero],
      exact (nat.sub_add_cancel hs).symm },
    rw [Hex, pow_add] at this,
    exact nat.eq_of_mul_eq_mul_left (pow_pos hpri.out.pos _) this },
  all_goals { apply_instance }
end

/-- If `irreducible (cyclotomic (p ^ (k + 1)) K)` (in particular for `K = ℚ`) and `p` is a prime,
then the norm of `ζ ^ (p ^ s) - 1` is `p ^ (p ^ s)` if `p ≠ 2`. -/
lemma pow_sub_one_norm_prime_ne_two {k : ℕ} (hζ : is_primitive_root ζ ↑(p ^ (k + 1)))
  [hpri : fact (p : ℕ).prime] [is_cyclotomic_extension {p ^ (k + 1)} K L]
  (hirr : irreducible (cyclotomic (↑(p ^ (k + 1)) : ℕ) K)) {s : ℕ} (hs : s ≤ k)
  (hodd : p ≠ 2) : norm K (ζ ^ ((p : ℕ) ^ s) - 1) = p ^ ((p : ℕ) ^ s) :=
begin
  refine hζ.pow_sub_one_norm_prime_pow_ne_two hirr hs (λ h, _),
  rw [← pnat.coe_inj, pnat.coe_bit0, pnat.one_coe, pnat.pow_coe, ← pow_one 2] at h,
  replace h := eq_of_prime_pow_eq (prime_iff.1 hpri.out) (prime_iff.1 nat.prime_two)
    ((k - s).succ_pos) h,
  rw [← pnat.one_coe, ← pnat.coe_bit0, pnat.coe_inj] at h,
  exact hodd h
end

/-- If `irreducible (cyclotomic (p ^ (k + 1)) K)` (in particular for `K = ℚ`) and `p` is an odd
prime, then the norm of `ζ - 1` is `p`. -/
lemma sub_one_norm_prime_ne_two {k : ℕ} (hζ : is_primitive_root ζ ↑(p ^ (k + 1)))
  [hpri : fact (p : ℕ).prime] [is_cyclotomic_extension {p ^ (k + 1)} K L]
  (hirr : irreducible (cyclotomic (↑(p ^ (k + 1)) : ℕ) K)) (h : p ≠ 2) :
  norm K (ζ - 1) = p :=
by simpa using hζ.pow_sub_one_norm_prime_ne_two hirr k.zero_le h

/-- If `irreducible (cyclotomic p K)` (in particular for `K = ℚ`) and `p` is an odd prime,
then the norm of `ζ - 1` is `p`. -/
lemma sub_one_norm_prime [hpri : fact (p : ℕ).prime] [hcyc : is_cyclotomic_extension {p} K L]
  (hζ: is_primitive_root ζ p) (hirr : irreducible (cyclotomic p K)) (h : p ≠ 2) :
  norm K (ζ - 1) = p :=
begin
  replace hirr : irreducible (cyclotomic (↑(p ^ (0 + 1)) : ℕ) K) := by simp [hirr],
  replace hζ : is_primitive_root ζ (↑(p ^ (0 + 1)) : ℕ) := by simp [hζ],
  haveI : is_cyclotomic_extension {p ^ (0 + 1)} K L := by simp [hcyc],
  simpa using sub_one_norm_prime_ne_two hζ hirr h
end

/-- If `irreducible (cyclotomic (2 ^ (k + 1)) K)` (in particular for `K = ℚ`), then the norm of
`ζ ^ (2 ^ k) - 1` is `(-2) ^ (2 ^ k)`. -/
lemma pow_sub_one_norm_two {k : ℕ} (hζ : is_primitive_root ζ (2 ^ (k + 1)))
  [is_cyclotomic_extension {2 ^ (k + 1)} K L]
  (hirr : irreducible (cyclotomic (2 ^ (k + 1)) K)) :
  norm K (ζ ^ (2 ^ k) - 1) = (-2) ^ (2 ^ k) :=
begin
  have := hζ.pow_of_dvd (λ h, two_ne_zero (pow_eq_zero h)) (pow_dvd_pow 2 (le_succ k)),
  rw [nat.pow_div (le_succ k) zero_lt_two, nat.succ_sub (le_refl k), nat.sub_self, pow_one] at this,
  have H : (-1 : L) - (1 : L) = algebra_map K L (-2),
  { simp only [_root_.map_neg, map_bit0, _root_.map_one],
    ring },
  replace hirr : irreducible (cyclotomic (2 ^ (k + 1) : ℕ+) K) := by simp [hirr],
  rw [this.eq_neg_one_of_two_right, H, algebra.norm_algebra_map,
    is_cyclotomic_extension.finrank L hirr,
    pow_coe, pnat.coe_bit0, one_coe, totient_prime_pow nat.prime_two (zero_lt_succ k),
    succ_sub_succ_eq_sub, tsub_zero, mul_one]
end

/-- If `irreducible (cyclotomic (2 ^ k) K)` (in particular for `K = ℚ`) and `k` is at least `2`,
then the norm of `ζ - 1` is `2`. -/
lemma sub_one_norm_two {k : ℕ} (hζ : is_primitive_root ζ (2 ^ k)) (hk : 2 ≤ k)
  [H : is_cyclotomic_extension {2 ^ k} K L] (hirr : irreducible (cyclotomic (2 ^ k) K)) :
  norm K (ζ - 1) = 2 :=
begin
  have : 2 < (2 ^ k : ℕ+),
  { simp only [← coe_lt_coe, pnat.coe_bit0, one_coe, pow_coe],
    nth_rewrite 0 [← pow_one 2],
    exact pow_lt_pow one_lt_two (lt_of_lt_of_le one_lt_two hk) },
  replace hirr : irreducible (cyclotomic (2 ^ k : ℕ+) K) := by simp [hirr],
  replace hζ : is_primitive_root ζ (2 ^ k : ℕ+) := by simp [hζ],
  obtain ⟨k₁, hk₁⟩ := exists_eq_succ_of_ne_zero ((lt_of_lt_of_le zero_lt_two hk).ne.symm),
  simpa [hk₁] using sub_one_norm_eq_eval_cyclotomic hζ this hirr,
end

/-- If `irreducible (cyclotomic (p ^ (k + 1)) K)` (in particular for `K = ℚ`) and `p` is a prime,
then the norm of `ζ ^ (p ^ s) - 1` is `p ^ (p ^ s)` if `1 ≤ k`. -/
lemma pow_sub_one_norm_prime_pow_of_one_le {k s : ℕ} (hζ : is_primitive_root ζ ↑(p ^ (k + 1)))
  [hpri : fact (p : ℕ).prime] [hcycl : is_cyclotomic_extension {p ^ (k + 1)} K L]
  (hirr : irreducible (cyclotomic (↑(p ^ (k + 1)) : ℕ) K)) (hs : s ≤ k)
  (hk : 1 ≤ k) : norm K (ζ ^ ((p : ℕ) ^ s) - 1) = p ^ ((p : ℕ) ^ s) :=
begin
  by_cases htwo : p ^ (k - s + 1) = 2,
  { have hp : p = 2,
    { rw [← pnat.coe_inj, pnat.coe_bit0, pnat.one_coe, pnat.pow_coe, ← pow_one 2] at htwo,
      replace htwo := eq_of_prime_pow_eq (prime_iff.1 hpri.out) (prime_iff.1 nat.prime_two)
        (succ_pos _) htwo,
      rwa [show 2 = ((2 : ℕ+) : ℕ), by simp, pnat.coe_inj] at htwo },
    replace hs : s = k,
    { rw [hp, ← pnat.coe_inj, pnat.pow_coe, pnat.coe_bit0, pnat.one_coe] at htwo,
      nth_rewrite 1 [← pow_one 2] at htwo,
      replace htwo := nat.pow_right_injective rfl.le htwo,
      rw [add_left_eq_self, nat.sub_eq_zero_iff_le] at htwo,
      refine le_antisymm hs htwo },
    simp only [hs, hp, pnat.coe_bit0, one_coe, coe_coe, cast_bit0, cast_one,
      pow_coe] at ⊢ hζ hirr hcycl,
    haveI := hcycl,
    obtain ⟨k₁, hk₁⟩ := nat.exists_eq_succ_of_ne_zero (one_le_iff_ne_zero.1 hk),
    rw [hζ.pow_sub_one_norm_two hirr],
    rw [hk₁, pow_succ, pow_mul, neg_eq_neg_one_mul, mul_pow, neg_one_sq, one_mul, ← pow_mul,
      ← pow_succ] },
  { exact hζ.pow_sub_one_norm_prime_pow_ne_two hirr hs htwo }
end

end is_primitive_root

namespace is_cyclotomic_extension

open is_primitive_root

variables {K} (L) [field K] [field L] [algebra K L]
/-- If `irreducible (cyclotomic n K)` (in particular for `K = ℚ`), the norm of `zeta n K L` is `1`
if `n` is odd. -/
lemma norm_zeta_eq_one [is_cyclotomic_extension {n} K L] (hn : n ≠ 2)
  (hirr : irreducible (cyclotomic n K)) : norm K (zeta n K L) = 1 :=
(zeta_spec n K L).norm_eq_one hn hirr

/-- If `is_prime_pow (n : ℕ)`, `n ≠ 2` and `irreducible (cyclotomic n K)` (in particular for
`K = ℚ`), then the norm of `zeta n K L - 1` is `(n : ℕ).min_fac`. -/
lemma is_prime_pow_norm_zeta_sub_one (hn : is_prime_pow (n : ℕ))
  [is_cyclotomic_extension {n} K L]
  (hirr : irreducible (cyclotomic (n : ℕ) K)) (h : n ≠ 2) :
  norm K (zeta n K L - 1) = (n : ℕ).min_fac :=
(zeta_spec n K L).sub_one_norm_is_prime_pow hn hirr h

/-- If `irreducible (cyclotomic (p ^ (k + 1)) K)` (in particular for `K = ℚ`) and `p` is a prime,
then the norm of `(zeta (p ^ (k + 1)) K L) ^ (p ^ s) - 1` is `p ^ (p ^ s)`
if `p ^ (k - s + 1) ≠ 2`. -/
lemma prime_ne_two_pow_norm_zeta_pow_sub_one {k : ℕ} [hpri : fact (p : ℕ).prime]
  [is_cyclotomic_extension {p ^ (k + 1)} K L]
  (hirr : irreducible (cyclotomic (↑(p ^ (k + 1)) : ℕ) K))  {s : ℕ} (hs : s ≤ k)
  (htwo : p ^ (k - s + 1) ≠ 2) :
  norm K ((zeta (p ^ (k + 1)) K L) ^ ((p : ℕ) ^ s) - 1) = p ^ ((p : ℕ) ^ s) :=
(zeta_spec _ K L).pow_sub_one_norm_prime_pow_ne_two hirr hs htwo

/-- If `irreducible (cyclotomic (p ^ (k + 1)) K)` (in particular for `K = ℚ`) and `p` is an odd
prime, then the norm of `zeta (p ^ (k + 1)) K L - 1` is `p`. -/
lemma prime_ne_two_pow_norm_zeta_sub_one {k : ℕ} [hpri : fact (p : ℕ).prime]
  [is_cyclotomic_extension {p ^ (k + 1)} K L]
  (hirr : irreducible (cyclotomic (↑(p ^ (k + 1)) : ℕ) K)) (h : p ≠ 2) :
  norm K (zeta (p ^ (k + 1)) K L - 1) = p :=
(zeta_spec _ K L).sub_one_norm_prime_ne_two hirr h

/-- If `irreducible (cyclotomic p K)` (in particular for `K = ℚ`) and `p` is an odd prime,
then the norm of `zeta p K L - 1` is `p`. -/
lemma prime_ne_two_norm_zeta_sub_one [hpri : fact (p : ℕ).prime]
  [hcyc : is_cyclotomic_extension {p} K L] (hirr : irreducible (cyclotomic p K)) (h : p ≠ 2) :
  norm K (zeta p K L - 1) = p :=
(zeta_spec _ K L).sub_one_norm_prime hirr h

/-- If `irreducible (cyclotomic (2 ^ k) K)` (in particular for `K = ℚ`) and `k` is at least `2`,
then the norm of `zeta (2 ^ k) K L - 1` is `2`. -/
lemma two_pow_norm_zeta_sub_one {k : ℕ} (hk : 2 ≤ k)
  [is_cyclotomic_extension {2 ^ k} K L] (hirr : irreducible (cyclotomic (2 ^ k) K)) :
  norm K (zeta (2 ^ k) K L - 1) = 2 :=
sub_one_norm_two (zeta_spec (2 ^ k) K L) hk hirr

end is_cyclotomic_extension

end norm


import data.nat.basic
import data.int.basic

section one
  variables x y : ℕ

  def double := x + x

  #check double
  #check double y
  #check double (2 * x)

  theorem t1 : double (x + y) = double x + double y :=
  by simp [double, add_left_comm, add_comm]

  #check t1 y
  #check t1 (2 * x)
end one

section two
  parameters {α : Type} (r : α → α → Type)
  parameter  transr : ∀ {x y z}, r x y → r y z → r x z

  variables {a b c d e : α}

  theorem t1' (h₁ : r a b) (h₂ : r b c) (h₃ : r c d) : r a d :=
  transr (transr h₁ h₂) h₃

  theorem t2 (h₁ : r a b) (h₂ : r b c) (h₃ : r c d)
      (h₄ : r d e) :
    r a e :=
  transr h₁ (t1' h₂ h₃ h₄)

  #check t1
  #check t2
end two

variable {α : Type*}

def is_prefix (l₁ : list α) (l₂ : list α) : Prop :=
∃ t, l₁ ++ t = l₂

/- this is just in lean now -/
-- infix `<+:`:50 := is_prefix

@[simp]
theorem list.is_prefix_refl (l : list α) : l <+: l :=
⟨[], by simp⟩

example : [1, 2, 3] <+: [1, 2, 3] := by simp

namespace int

def dvd (m n : ℤ) : Prop := ∃ k, n = m * k
instance : has_dvd int := ⟨int.dvd⟩

@[simp]
theorem dvd_zero (n : ℤ) : n ∣ 0 :=
⟨0, by simp⟩

theorem dvd_intro {m n : ℤ} (k : ℤ) (h : n = m * k) : m ∣ n :=
⟨k, h⟩

end int

open int

section mod_m
  parameter (m : ℤ)
  variables (a b c : ℤ)

  definition mod_equiv := (m ∣ b - a)

  local infix ≡ := mod_equiv

  theorem mod_refl : a ≡ a :=
  show m ∣ a - a, by simp [sub_self]

  theorem mod_symm (h : a ≡ b) : b ≡ a :=
  begin
    cases h with c hc,
    apply dvd_intro (-c),
    simp [eq.symm hc, neg_sub],
  end

  theorem mod_trans (h₁ : a ≡ b) (h₂ : b ≡ c) : a ≡ c :=
  begin
    cases h₁ with d hd, cases h₂ with e he,
    apply dvd_intro (d + e),
    simp [
      mul_add,
      eq.symm hd,
      eq.symm he,
      ←neg_add_eq_sub,
      ←add_assoc
    ],
    end
end mod_m

#check (mod_refl : ∀ (m a : ℤ), mod_equiv m a a)

#check (mod_symm : ∀ (m a b : ℤ), mod_equiv m a b →
                     mod_equiv m b a)

#check (mod_trans :  ∀ (m a b c : ℤ), mod_equiv m a b →
                       mod_equiv m b c → mod_equiv m a c)

variables m n : ℕ
variables i j : ℤ

#check i + m      -- i + ↑m : ℤ
#check i + m + j  -- i + ↑m + j : ℤ
#check i + m + n  -- i + ↑m + ↑n : ℤ

#check ↑m + i        -- ↑m + i : ℤ
#check ↑(m + n) + i  -- ↑(m + n) + i : ℤ
#check ↑m + ↑n + i   -- ↑m + ↑n + i : ℤ

#check of_nat

def foo {α : Type} (x : α) : α := x

#check foo
#check @foo
#reduce foo
#reduce (foo nat.zero)
#print foo

#print notation
#print notation + * -
#print +

#print axioms
#print options
#print prefix nat
#print prefix nat.le
#print classes
#print instances ring

#print fields ring
#print ring

#check (λ x, x + 1) 1
set_option pp.beta true
#check (λ x, x + 1) 1
set_option pp.beta false