import ring_theory.principal_ideal_domain data.equiv.basic set_lemmas

variables {M : Type*} {R : Type*}
 [integral_domain R] [is_principal_ideal_ring R] [add_comm_group M]
[module R M] {A : submodule R M}
{α : Type*} {β : Type*} {γ : Type*} [add_comm_group α] [add_comm_group β]
open_locale classical
open finset

lemma sum_union_zero {s t : finset α} {f : α → β} (h : s ∩ t ⊆ {0}) (h0 : f 0 = 0) :
  finset.sum (s ∪ t) f = finset.sum s f + finset.sum t f :=
begin
  rw ←sum_union_inter,
  cases classical.em (s ∩ t = ∅) with hst hst,
  rw hst, rw sum_empty, rw add_zero,
  have : s ∩ t = {0}, from finset.subset.antisymm h (by {cases finset.nonempty_of_ne_empty hst with x hx,
  rw finset.singleton_subset_iff, convert hx, symmetry, exact finset.mem_singleton.1 (h hx)}),
  rw this, rw sum_singleton, rw h0, rw add_zero,
end

lemma sum_bind_zero {f : α → β} (h0 : f 0 = 0) {s : finset γ} {t : γ → finset α} :
  (∀x∈s, ∀y∈s, x ≠ y → (t x ∩ t y ⊆ {0})) → (finset.sum (s.bind t) f) = finset.sum s (λ x, finset.sum (t x) f) :=
finset.induction_on s (λ _, by simp only [bind_empty, finset.sum_empty])
  (assume x s hxs ih hd,
  have hd' : ∀x∈s, ∀y∈s, x ≠ y → (t x ∩ t y ⊆ {0}),
    from assume _ hx _ hy, hd _ (mem_insert_of_mem hx) _ (mem_insert_of_mem hy),
  have ∀y∈s, x ≠ y,
    from assume _ hy h, by rw [←h] at hy; contradiction,
  have ∀y∈s, (t x ∩ t y ⊆ {0}),
    from assume _ hy, hd _ (mem_insert_self _ _) _ (mem_insert_of_mem hy) (this _ hy),
  have (t x) ∩ (finset.bind s t) ⊆ {0},
    by {intros z hz, rw finset.mem_inter at hz, rcases finset.mem_bind.1 hz.2 with ⟨y, hym, hy⟩,
    exact this y hym (finset.mem_inter.2 ⟨hz.1, hy⟩)},
  by simp only [bind_insert, sum_insert hxs, sum_union_zero this h0, ih hd'])

lemma pairwise_disjoint_of_disjoint (S : set (submodule R A))
  (Hb : ∀ N ∈ S, N ⊓ submodule.span R (set.Union (λ x : S \ {N}, x.1.1)) = ⊥)
  {x y} (hx : x ∈ S) (hy : y ∈ S) (hxy : x ≠ y) : x ⊓ y ≤ ⊥ :=
begin
  rw ←Hb x hx,
  refine inf_le_inf_left _ _,
  rw submodule.span_Union,
  convert le_supr _ (⟨(y : submodule R A), (set.mem_diff _).2 ⟨hy, ne.symm hxy⟩⟩ : S \ {x}),
  exact (submodule.span_eq y).symm,
end

noncomputable def sum_mk {S : set (submodule R A)}
  (Ht : submodule.span R (set.Union (λ x : S, x.1.1)) = ⊤) (x : A) :
  A →₀ R :=
classical.some $ (finsupp.mem_span_iff_total R).1 (show x ∈ submodule.span R (id '' (set.Union (λ y : S, y.1.1))),
by {rw set.image_id, rw Ht, trivial})

lemma sum_mk_mem {S : set (submodule R A)}
  (Ht : submodule.span R (set.Union (λ x : S, x.1.1)) = ⊤) {x : A} :
  sum_mk Ht x ∈ finsupp.supported R R (set.Union (λ x : S, x.1.1)) :=
classical.some $ classical.some_spec $ (finsupp.mem_span_iff_total R).1 (show x ∈ submodule.span R (id '' (set.Union (λ y : S, y.1.1))),
by {rw set.image_id, rw Ht, trivial})

lemma sum_mk_eq {S : set (submodule R A)}
  (Ht : submodule.span R (set.Union (λ x : S, x.1.1)) = ⊤) (x : A) :
  finsupp.total _ _ _ id (sum_mk Ht x) = x :=
classical.some_spec $ classical.some_spec $ (finsupp.mem_span_iff_total R).1 (show x ∈ submodule.span R (id '' (set.Union (λ y : S, y.1.1))),
by {rw set.image_id, rw Ht, trivial})

noncomputable def G (S : set (submodule R A))
  (Ht : submodule.span R (set.Union (λ x : S, x.1.1)) = ⊤)
  (Hb : ∀ N ∈ S, N ⊓ submodule.span R (set.Union (λ x : S \ {N}, x.1.1)) = ⊥)
  (x : A) :
  Π (X : S), A →₀ R :=
   λ X, { support := finset.filter (X : set A) (sum_mk Ht x).1,
  to_fun := λ y, if y ∈ (X : submodule R A) then (sum_mk Ht x) y else 0,
  mem_support_to_fun := λ y, ⟨λ hx, by {erw if_pos (finset.mem_filter.1 hx).2,  exact ((sum_mk Ht x).3 y).1 (finset.mem_filter.1 hx).1 }, λ hx,
    by {rw finset.mem_filter, split, rw finsupp.mem_support_iff, intro hl0, apply hx, split_ifs, exact hl0, refl,
    show y ∈ (X : submodule R A), apply classical.not_not.1, intro hnot, apply hx, rw if_neg hnot,
    }⟩ }

noncomputable def v (S : set (submodule R A))
  (Ht : submodule.span R (set.Union (λ x : S, x.1.1)) = ⊤)
  (Hb : ∀ N ∈ S, N ⊓ submodule.span R (set.Union (λ x : S \ {N}, x.1.1)) = ⊥) (x : A) :
  S → A :=
λ s, finsupp.total A A R id (G S Ht Hb x s)

theorem exists_finsupp_of_mem_direct_sum
  (S : set (submodule R A))
  (Ht : submodule.span R (set.Union (λ x : S, x.1.1)) = ⊤)
  (Hb : ∀ N ∈ S, N ⊓ submodule.span R (set.Union (λ x : S \ {N}, x.1.1)) = ⊥) (x : A) :
  ∃ (l : S →₀ R), finsupp.total S A R (v S Ht Hb x) l = x :=
begin
   let F : (set.Union (λ x : S, x.1.1)) → S := λ s, classical.some (set.mem_Union.1 s.2),
  have hF : ∀ s : (set.Union (λ x : S, x.1.1)), (s : A) ∈ (F s : submodule R A) :=
    λ s, classical.some_spec (set.mem_Union.1 s.2),
  let rly : finset (set.Union (λ x : S, x.1.1)) := subtype_mk' (sum_mk Ht x).support _ (sum_mk_mem Ht),
  have hunique : ∀ (z : (set.Union (λ x : S, x.1.1))) (M N : S),
    (z : A) ∈ (M : submodule R A) → (z : A) ∈ (N : submodule R A) → ((z : A) ≠ 0) → (M = N) :=
  λ z B C hB hC h0, by {have hbB := Hb B B.2, have hbN := Hb C C.2,
  apply classical.not_not.1, intro hne, apply h0,
  rw ←@submodule.mem_bot R A _ _ _ z, rw ←hbB, split,
  exact hB, apply submodule.subset_span,
  rw set.mem_Union,
  use ⟨C, ⟨C.2, λ hmem, hne $ (subtype.ext hmem).symm⟩⟩, exact hC,},
  let lSset : finset S := finset.image F rly,
  let Lfun : S → R := λ X, if X ∈ lSset then 1 else 0,
  let L : S →₀ R := ⟨lSset, Lfun, λ y, by {split,
  intro hy, rw (show Lfun y = 1, from if_pos hy), exact one_ne_zero,
  intro hy,
  refine classical.not_not.1 _,
  intros hnot, apply hy, exact if_neg hnot,
  }⟩,
  use L,
  conv_rhs {rw ←(sum_mk_eq Ht x)}, rw finsupp.total_apply, rw finsupp.total_apply,
  unfold finsupp.sum,
   have huh : (λ X : S, L X • v S Ht Hb x X) = (λ X : S, if X ∈ lSset then v S Ht Hb x X else 0), by
    {funext, split_ifs, convert one_smul R (v S Ht Hb x X), exact if_pos h,
     convert zero_smul R (v S Ht Hb x X), exact if_neg h},
  rw huh,
  erw ←finset.sum_filter,
  show (finset.filter (λ X : S, X ∈ lSset) L.support).sum (λ X : S, (finsupp.total A A R id) (G S Ht Hb x X)) = _,
  simp only [finsupp.total_apply],
  have hse : (λ X : S, (G S Ht Hb x X).sum (λ (i : A) (a : R), a • id i)) =
       (λ X : S, (filter (X : set A) (sum_mk Ht x).1).sum (λ (i : A), (sum_mk Ht x) i • id i)) :=
    by {funext, apply finset.sum_congr rfl, intros x hx,
    congr' 1, exact if_pos (finset.mem_filter.1 hx).2},
  rw hse,
  rw finset.filter_true_of_mem,
  rw ←sum_bind_zero,
  apply finset.sum_congr,
  rw finset.image_bind,
  ext y,
  rw finset.mem_bind,
  split,
  rintro ⟨z, hzm, hz⟩,
  exact (finset.mem_filter.1 hz).1,
  intro hy,
  use ⟨y, sum_mk_mem Ht hy⟩,
  split,
  rw mem_subtype_mk', exact hy,
  rw finset.mem_filter,
  split,
  exact hy,
  exact hF ⟨y, sum_mk_mem Ht hy⟩,
  intros, refl,
  exact smul_zero _,
  intros x hx y hy hxy,
  rw ←finset.filter_and,
  intros z hz,
  rw finset.mem_singleton,
  exact pairwise_disjoint_of_disjoint _ Hb x.2 y.2 (λ hnxy, hxy $ subtype.ext hnxy) (finset.mem_filter.1 hz).2,
  intros x hx, exact hx,
end

noncomputable def gen_coeffs
  (S : set (submodule R A))
  (Ht : submodule.span R (set.Union (λ x : S, x.1.1)) = ⊤)
  (Hb : ∀ N ∈ S, N ⊓ submodule.span R (set.Union (λ x : S \ {N}, x.1.1)) = ⊥) (x) : S →₀ R :=
    classical.some $ exists_finsupp_of_mem_direct_sum S Ht Hb x

theorem gen_sum_spec
  {S : set (submodule R A)} (Ht : submodule.span R (set.Union (λ x : S, x.1.1)) = ⊤)
  (Hb : ∀ N ∈ S, N ⊓ submodule.span R (set.Union (λ x : S \ {N}, x.1.1)) = ⊥) (x : A) :
  finsupp.total S A R (v S Ht Hb x) (gen_coeffs S Ht Hb x) = x :=
  classical.some_spec $ exists_finsupp_of_mem_direct_sum S Ht Hb x

theorem mem_gen_supp {S : set (submodule R A)} (Ht : submodule.span R (set.Union (λ x : S, x.1.1)) = ⊤)
  (Hb : ∀ N ∈ S, N ⊓ submodule.span R (set.Union (λ x : S \ {N}, x.1.1)) = ⊥) (x : A) :
  x ∈ submodule.span R (set.Union (λ y : (↑(gen_coeffs S Ht Hb x).support : set S), y.1.1.1)) :=
begin
  have := gen_sum_spec Ht Hb x,
  conv_lhs {rw ←this},
  rw finsupp.total_apply,
  unfold finsupp.sum,
  refine submodule.sum_mem _ _,
  intros c hc,
  refine submodule.smul_mem _ _ _,
  unfold v, rw finsupp.total_apply,
  unfold finsupp.sum,
  refine submodule.sum_mem _ _,
  intros d hd,
  refine submodule.smul_mem _ _ _,
  change d ∈ finset.filter _ _ at hd,
  rw finset.mem_filter at hd,
  show d ∈ _,
  apply submodule.subset_span,
  rw set.mem_Union,
  use c,
  exact hc,
  exact hd.2,
end

def T {s : finset M} {S : set (submodule R A)} (Hs : submodule.span R (↑s : set M) = A) (Ht : submodule.span R (set.Union (λ x : S, x.1.1)) = ⊤)
 (Hb : ∀ N ∈ S, N ⊓ submodule.span R (set.Union (λ x : S \ {N}, x.1.1)) = ⊥) : set S :=
↑(finset.bind (subtype_mk' s A (subset_span' Hs)) (λ x : A, (gen_coeffs S Ht Hb x).support))

lemma T_mem {s : finset M} {S : set (submodule R A)} (Hs : submodule.span R (↑s : set M) = A) (Ht : submodule.span R (set.Union (λ x : S, x.1.1)) = ⊤)
 (Hb : ∀ N ∈ S, N ⊓ submodule.span R (set.Union (λ x : S \ {N}, x.1.1)) = ⊥) {x : S} :
 x ∈ T Hs Ht Hb ↔ ∃ z ∈ s, x ∈ (gen_coeffs S Ht Hb ⟨z, subset_span' Hs H⟩).support :=
begin
  split,
  intro hx,
  rcases finset.mem_bind.1 hx with ⟨y, hym, hy⟩,
  rw mem_subtype_mk' (subset_span' Hs) at hym,
  use (y : M),
  use hym,
  rw subtype.coe_eta, exact hy,
  rintro ⟨z, hzm, hz⟩,
  apply finset.mem_bind.2,
  use ⟨z, subset_span' Hs hzm⟩,
  split,
  rw mem_subtype_mk' (subset_span' Hs),
  exact hzm,
  exact hz,
end

theorem subset_gen_supp {S : set (submodule R A)} (Ht : submodule.span R (set.Union (λ x : S, x.1.1)) = ⊤)
  (Hb : ∀ N ∈ S, N ⊓ submodule.span R (set.Union (λ x : S \ {N}, x.1.1)) = ⊥) {s : finset M} (Hs : submodule.span R (↑s : set M) = A) :
  (↑s : set M) ⊆ (submodule.span R (set.Union (λ X : T Hs Ht Hb, X.1.1.1))).map A.subtype :=
begin
  intros x hx,
  have := mem_gen_supp Ht Hb ⟨x, subset_span' Hs hx⟩,
  use ⟨x, subset_span' Hs hx⟩,
  split,
  refine submodule.span_mono _ this,
  intros z hz,
  rw set.mem_Union at *,
  cases hz with i hi,
  use ⟨(i : S), by {rw T_mem Hs Ht Hb, use [x, hx, i.2]}⟩,
  convert hi, refl,
end

lemma T_subset {S : set (submodule R A)} (Ht : submodule.span R (set.Union (λ x : S, x.1.1)) = ⊤)
  (Hb : ∀ N ∈ S, N ⊓ submodule.span R (set.Union (λ x : S \ {N}, x.1.1)) = ⊥) {s : finset M} (Hs : submodule.span R (↑s : set M) = A) :
  subtype.val '' T Hs Ht Hb ⊆ S :=
begin
  intros x hx,
  rcases hx with ⟨y, hym, hy⟩,
  rw ←hy, exact y.2,
end
#check set.finite

/-- Given an f.g. R-module A and a set S of submodules whose union generates all of A,
if for all `N ∈ S`, the intersection of N and the submodule generated by union of the elements of
`S \ N` is trivial then `S` is finite. -/
theorem finite_summands_of_fg (s : finset M)
  (Hs : submodule.span R (↑s : set M) = A)
  (S : set (submodule R A))
  (Ht : submodule.span R (set.Union (λ x : S, x.1.1)) = ⊤)
  (Hb : ∀ N ∈ S, N ⊓ submodule.span R (set.Union (λ x : S \ {N}, x.1.1)) = ⊥) :
  set.finite S :=
begin
  suffices : S ⊆ insert ⊥ (subtype.val '' T Hs Ht Hb),
    by {refine set.finite.subset _ this, apply set.finite.insert, apply set.finite.image, exact finset.finite_to_set _},
  intros x hxS,
  have hTt : (submodule.span R (set.Union (λ X : T Hs Ht Hb, X.1.1.1))) = ⊤ :=
    by {apply linear_map.map_injective A.ker_subtype, rw submodule.map_subtype_top, ext y, split, rintro ⟨z, hzm, hz⟩, rw ←hz, exact z.2,
    intro hy, rw ←Hs at hy,
    refine submodule.span_le.2 _ hy,
    exact (subset_gen_supp Ht Hb Hs)},
  have hTb : ∀ N ∈ subtype.val '' T Hs Ht Hb, N ⊓ submodule.span R (set.Union (λ x : subtype.val '' T Hs Ht Hb \ {N}, x.1.1)) = ⊥ :=
  λ N hN, by {rw eq_bot_iff, refine le_trans _ (eq_bot_iff.1 $ Hb N (T_subset Ht Hb Hs hN)),
  refine inf_le_inf_left _ _,
  apply submodule.span_mono,
  intros X hX, rw set.mem_Union at hX, rcases hX with ⟨Y, hY⟩,
  rw set.mem_Union,
  use ⟨Y.1, (set.mem_diff _).2 $ ⟨T_subset Ht Hb Hs $ ((set.mem_diff _).1 Y.2).1, ((set.mem_diff _).1 Y.2).2⟩⟩,
  exact hY,},
  cases classical.em (x = ⊥),
    left, exact h,
  right,
  apply classical.not_not.1,
  intro hnot,
  apply h,
  have := Hb x hxS,
  rw ←@inf_top_eq _ _ x,
  convert this,
  symmetry,
  rw eq_top_iff,
  rw ←hTt,
  apply submodule.span_mono,
  intros Y HY,
  rw set.mem_Union at HY,
  rcases HY with ⟨Z, hZ⟩,
  rw set.mem_Union,
  use ⟨Z, (set.mem_diff _).1 $ ⟨by {apply T_subset Ht Hb Hs, use Z, split, exact Z.2, refl},
     λ hnotZ, by {apply hnot, use Z, split, exact Z.2, exact hnotZ}⟩⟩,
  exact hZ,
end


import Structure.Generic.Axioms.Universes
import Structure.Generic.Axioms.AbstractFunctors
import Structure.Generic.Axioms.AbstractEquivalences
import Structure.Generic.Axioms.GeneralizedProperties
import Structure.Generic.Axioms.InstanceEquivalences

open GeneralizedRelation

set_option autoBoundImplicitLocal false
--set_option pp.universes true

universes u v w

-- We would also like to be able to manipulate such equivalences, and we need them to behave like
-- isomorphisms when doing so, with `refl` as the identity, `symm` as inverse, and `trans` as composition.
-- In other words, a structure with its equivalences is a category where every morphism has an inverse (as
-- guaranteed by `symm`), i.e. it is a groupoid. Since equivalences have equivalences, it is actually a
-- higher groupoid.
--
-- (Of course, the same type may also have a category structure with more morphisms, but since we are
-- defining a generalization of an equivalence relation, not a category, we wish to ignore such extra
-- structure at this point.)
--
-- We add three redundant axioms to avoid unnecessary computations. (Actually, this list of axioms was
-- originally inspired by the seven corresponding lemmas in `data.equiv.basic` of mathlib in Lean 3:
-- `symm_symm`, `trans_refl`, etc.)
--
-- Remark: Interestingly, all axioms can be regarded as simplification rules (with the simplification for
-- associativity being the omission of parentheses). With the addition of the three redundant axioms, they
-- enable equational reasoning by transforming all possible terms into a "flat" canonical form. Besides
-- making proofs trivial, this observation also suggests an alternative formalization of the axioms in
-- terms of a simplification function.
--
-- Note that for actual equivalence relations, the axioms are trivially satisfied in a proof-irrelevant
-- system such as Lean.

-- TODO: Introduce a specification that describes all of the redundancies in axioms, so that higher
-- structures can force redundant data to be equal.

section Morphisms

  variable {α : Sort u} {V : Universe.{v}} [HasInternalFunctors V] [HasInstanceEquivalences.{v, w} V]
           (R : GeneralizedRelation α V)

  variable [HasLinearFunOp V] [HasTrans R]

  @[reducible] def compCompRight (a b c d : α) : R a b ⟶ R b c ⟶ R c d ⟶ R a d :=
  HasLinearFunOp.revCompFunFun (R b c) HasTrans.trans ⊙ HasTrans.trans
  @[reducible] def compCompLeft  (a b c d : α) : R a b ⟶ R b c ⟶ R c d ⟶ R a d :=
  HasLinearFunOp.swapFunFun (HasLinearFunOp.compFunFunFun (R c d) (R b d) (R a d) ⊙ HasTrans.trans) ⊙ HasTrans.trans

  theorem compCompRight.eff [HasEquivCongrFun V] {a b c d : α} (f : R a b) (g : R b c) (h : R c d) :
    (compCompRight R a b c d) f g h = h • (g • f) :=
  by simp; rfl
  theorem compCompLeft.eff  [HasEquivCongrFun V] {a b c d : α} (f : R a b) (g : R b c) (h : R c d) :
    (compCompLeft  R a b c d) f g h = (h • g) • f :=
  by simp; rfl

  class IsCompositionRelation                                 : Sort (max 1 u v w) where
  (assoc {a b c d : α} : compCompRight R a b c d ≃ compCompLeft R a b c d)

  variable [HasRefl R]

  @[reducible] def leftMulId  (a b : α) : R a b ⟶ R a b := HasTrans.revTrans ⟮ident R b⟯
  @[reducible] def rightMulId (a b : α) : R a b ⟶ R a b := HasTrans.trans    ⟮ident R a⟯

  theorem leftMulId.eff  [HasEquivCongrFun V] {a b : α} (f : R a b) : (leftMulId  R a b) f = ident R b • f :=
  by simp; rfl
  theorem rightMulId.eff [HasEquivCongrFun V] {a b : α} (f : R a b) : (rightMulId R a b) f = f • ident R a :=
  rfl

  class IsMorphismRelation    extends IsCompositionRelation R : Sort (max 1 u v w) where
  (leftId  {a b : α} : leftMulId  R a b ≃ HasLinearFunOp.idFun (R a b))
  (rightId {a b : α} : rightMulId R a b ≃ HasLinearFunOp.idFun (R a b))

  variable [HasSubLinearFunOp V] [HasNonLinearFunOp V] [HasInternalEquivalences V] [HasSymm R]

  @[reducible] def leftMulInv  (a b : α) : R a b ⟶ R a a :=
  HasNonLinearFunOp.dupFun (HasTrans.revTrans ⊙ HasInternalEquivalences.toFun HasSymm.symm)
  @[reducible] def rightMulInv (a b : α) : R a b ⟶ R b b :=
  HasNonLinearFunOp.dupFun (HasTrans.trans    ⊙ HasInternalEquivalences.toFun HasSymm.symm)

  theorem leftMulInv.eff  [HasEquivCongrFun V] {a b : α} (f : R a b) : (leftMulInv  R a b) f = f⁻¹ • f :=
  by simp; rfl
  theorem rightMulInv.eff [HasEquivCongrFun V] {a b : α} (f : R a b) : (rightMulInv R a b) f = f • f⁻¹ :=
  by simp; rfl

  class IsIsomorphismRelation extends IsMorphismRelation    R : Sort (max 1 u v w) where
  (leftInv  {a b : α} : leftMulInv  R a b ≃ HasSubLinearFunOp.constFun (R a b) (ident R a))
  (rightInv {a b : α} : rightMulInv R a b ≃ HasSubLinearFunOp.constFun (R a b) (ident R b))

  -- TODO: convert to lemmas?
  --(invInv   {a b   : α} (f : R a b)             : (f⁻¹)⁻¹       ≃ f)
  --(compInv  {a b c : α} (f : R a b) (g : R b c) : (g • f)⁻¹     ≃ f⁻¹ • g⁻¹)
  --(idInv    (a     : α)                         : (ident R a)⁻¹ ≃ ident R a)

end Morphisms

-- TODO: Rephrase trans and symm as functor composition.

section Functors

  variable {α : Sort u} {V W : Universe} [HasInstanceEquivalences W] [HasExternalFunctors V W]
           (R : GeneralizedRelation α V) (S : GeneralizedRelation α W)

  def BaseFunctor := ∀ {a b}, R a b ⟶' S a b

  variable (F : BaseFunctor R S)

  class IsReflFunctor  [hR : HasRefl  R] [hS : HasRefl  S] where
  (respectsRefl  (a     : α)                         : F (hR.refl   a)   ≃ hS.refl   a)

  variable [HasInternalFunctors V] [HasInternalFunctors W]

  class IsTransFunctor [hR : HasTrans R] [hS : HasTrans S] where
  (respectsTrans {a b c : α} (f : R a b) (g : R b c) : F (hR.trans' f g) ≃ hS.trans' (F f) (F g))

  class IsPreorderFunctor [IsPreorder R] [IsPreorder S] extends IsReflFunctor R S F, IsTransFunctor R S F

  variable [HasInternalEquivalences V] [HasInternalEquivalences W]

  class IsSymmFunctor  [hR : HasSymm  R] [hS : HasSymm  S] where
  (respectsSymm  {a b   : α} (f : R a b)             : F (hR.symm'  f)   ≃ hS.symm'  (F f))

  class IsEquivalenceFunctor [IsEquivalence R] [IsEquivalence S] extends IsPreorderFunctor R S F, IsSymmFunctor R S F

end Functors

-- TODO: If arrows have equivalences, we can specify redundancies in axioms as such equivalences.

section NaturalTransformations

  variable {α : Sort u} {β : Sort v} {V W : Universe} [HasExternalFunctors V W]
           (R : GeneralizedRelation α V) (S : GeneralizedRelation β W)

  def MappedBaseFunctor (m : α → β) := ∀ {a b}, R a b ⟶' S (m a) (m b)

  variable [HasInternalFunctors W] [HasInstanceEquivalences W] [h : HasTrans S]
           {mF mG : α → β} (F : MappedBaseFunctor R S mF) (G : MappedBaseFunctor R S mG)

  class IsNatural (n : ∀ a, S (mF a) (mG a)) where
  (nat {a b : α} (f : R a b) : h.trans' (n a) (G f) ≃ h.trans' (F f) (n b))

  -- The following definitions specify how we can treat a natural quantification as an element of `W`.
  -- TODO: Maybe we can replace this with a more general quantification mechanism.

  structure NaturalQuantification where
  (n         : ∀ a, S (mF a) (mG a))
  [isNatural : IsNatural R S F G n]

  class HasInternalNaturalQuantification where
  (Nat      : W)
  (natEquiv : ⌈Nat⌉ ≃ NaturalQuantification R S F G)

end NaturalTransformations

class HasNaturalQuantification (U₁ U₂ V W : Universe) [HasExternalFunctors U₁ U₂] [HasExternalFunctors V W]
                                                      [HasInternalFunctors W] [HasInstanceEquivalences W] where
[hasNat {α : U₁} {β : U₂} (R : GeneralizedRelation ⌈α⌉ V) (S : GeneralizedRelation ⌈β⌉ W) [h : HasTrans S]
        {mF mG : α ⟶' β} (F : MappedBaseFunctor R S mF) (G : MappedBaseFunctor R S mG) :
   HasInternalNaturalQuantification R S F G]

section Categories

  variable (M : Universe.{v}) [HasInternalFunctors M] [HasLinearFunOp M] [HasInstanceEquivalences.{v, w} M] (α : Sort u)

  class IsCategory extends HasArrows α M : Sort (max 1 u (v + 1) w) where
  [isMor : IsMorphismRelation Arrow]

  namespace IsCategory

    variable [h : IsCategory M α]

    instance hasMor : IsMorphismRelation h.Arrow := h.isMor

  end IsCategory

  variable [HasSubLinearFunOp M] [HasNonLinearFunOp M] [HasInternalEquivalences M]

  class IsGroupoid extends HasEquivalences α M : Sort (max 1 u (v + 1) w) where
  [isIso : IsIsomorphismRelation Equiv]

  namespace IsGroupoid

    variable [h : IsGroupoid M α]

    instance hasIso : IsIsomorphismRelation h.Equiv := h.isIso

  end IsGroupoid

end Categories


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.monoidal.natural_transformation
import Mathlib.PostPort

universes u₁ u₂ v₁ v₂

namespace Mathlib

/-!
# Transport a monoidal structure along an equivalence.

When `C` and `D` are equivalent as categories,
we can transport a monoidal structure on `C` along the equivalence,
obtaining a monoidal structure on `D`.

We don't yet prove anything about this transported structure!
The next step would be to show that the original functor can be upgraded
to a monoidal functor with respect to this new structure.
-/

namespace category_theory.monoidal

/--
Transport a monoidal structure along an equivalence of (plain) categories.
-/
@[simp] theorem transport_tensor_unit {C : Type u₁} [category C] [monoidal_category C] {D : Type u₂} [category D] (e : C ≌ D) : 𝟙_ = functor.obj (equivalence.functor e) 𝟙_ :=
  Eq.refl 𝟙_

/-- A type synonym for `D`, which will carry the transported monoidal structure. -/
def transported {C : Type u₁} [category C] [monoidal_category C] {D : Type u₂} [category D] (e : C ≌ D) :=
  D

protected instance transported.category_theory.monoidal_category {C : Type u₁} [category C] [monoidal_category C] {D : Type u₂} [category D] (e : C ≌ D) : monoidal_category (transported e) :=
  transport e

protected instance transported.inhabited {C : Type u₁} [category C] [monoidal_category C] {D : Type u₂} [category D] (e : C ≌ D) : Inhabited (transported e) :=
  { default := 𝟙_ }

/--
We can upgrade `e.functor` to a lax monoidal functor from `C` to `D` with the transported structure.
-/
@[simp] theorem lax_to_transported_to_functor_map {C : Type u₁} [category C] [monoidal_category C] {D : Type u₂} [category D] (e : C ≌ D) {X : C} {Y : C} : ∀ (ᾰ : X ⟶ Y),
  functor.map (lax_monoidal_functor.to_functor (lax_to_transported e)) ᾰ = functor.map (equivalence.functor e) ᾰ :=
  fun (ᾰ : X ⟶ Y) => Eq.refl (functor.map (lax_monoidal_functor.to_functor (lax_to_transported e)) ᾰ)

/--
We can upgrade `e.functor` to a monoidal functor from `C` to `D` with the transported structure.
-/
@[simp] theorem to_transported_ε_is_iso {C : Type u₁} [category C] [monoidal_category C] {D : Type u₂} [category D] (e : C ≌ D) : monoidal_functor.ε_is_iso (to_transported e) = id (is_iso.id (functor.obj (equivalence.functor e) 𝟙_)) :=
  Eq.refl (monoidal_functor.ε_is_iso (to_transported e))

/--
We can upgrade `e.inverse` to a lax monoidal functor from `D` with the transported structure to `C`.
-/
def lax_from_transported {C : Type u₁} [category C] [monoidal_category C] {D : Type u₂} [category D] (e : C ≌ D) : lax_monoidal_functor (transported e) C :=
  lax_monoidal_functor.mk (functor.mk (functor.obj (equivalence.inverse e)) (functor.map (equivalence.inverse e)))
    (nat_trans.app (equivalence.unit e) 𝟙_)
    fun (X Y : transported e) =>
      nat_trans.app (equivalence.unit e) (functor.obj (equivalence.inverse e) X ⊗ functor.obj (equivalence.inverse e) Y)

/--
We can upgrade `e.inverse` to a monoidal functor from `D` with the transported structure to `C`.
-/
def from_transported {C : Type u₁} [category C] [monoidal_category C] {D : Type u₂} [category D] (e : C ≌ D) : monoidal_functor (transported e) C :=
  monoidal_functor.mk
    (lax_monoidal_functor.mk (lax_monoidal_functor.to_functor (lax_from_transported e))
      (lax_monoidal_functor.ε (lax_from_transported e)) (lax_monoidal_functor.μ (lax_from_transported e)))

/-- The unit isomorphism upgrades to a monoidal isomorphism. -/
def transported_monoidal_unit_iso {C : Type u₁} [category C] [monoidal_category C] {D : Type u₂} [category D] (e : C ≌ D) : lax_monoidal_functor.id C ≅ lax_to_transported e ⊗⋙ lax_from_transported e :=
  monoidal_nat_iso.of_components (fun (X : C) => iso.app (equivalence.unit_iso e) X) sorry sorry sorry

/-- The counit isomorphism upgrades to a monoidal isomorphism. -/
@[simp] theorem transported_monoidal_counit_iso_hom_to_nat_trans_app {C : Type u₁} [category C] [monoidal_category C] {D : Type u₂} [category D] (e : C ≌ D) (X : transported e) : nat_trans.app (monoidal_nat_trans.to_nat_trans (iso.hom (transported_monoidal_counit_iso e))) X =
  nat_trans.app (iso.hom (equivalence.counit_iso e)) X :=
  Eq.refl (nat_trans.app (iso.hom (equivalence.counit_iso e)) X)


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

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

/-!
# The Karoubi envelope of a category

In this file, we define the Karoubi envelope `karoubi C` of a category `C`.

## Main constructions and definitions

- `karoubi C` is the Karoubi envelope of a category `C`: it is an idempotent
complete category. It is also preadditive when `C` is preadditive.
- `to_karoubi C : C ⥤ karoubi C` is a fully faithful functor, which is an equivalence
(`to_karoubi_is_equivalence`) when `C` is idempotent complete.

-/

noncomputable section

open CategoryTheory.Category

open CategoryTheory.Preadditive

open CategoryTheory.Limits

open BigOperators

namespace CategoryTheory

variable (C : Type _) [Category C]

namespace Idempotents

/-- In a preadditive category `C`, when an object `X` decomposes as `X ≅ P ⨿ Q`, one may
consider `P` as a direct factor of `X` and up to unique isomorphism, it is determined by the
obvious idempotent `X ⟶ P ⟶ X` which is the projection onto `P` with kernel `Q`. More generally,
one may define a formal direct factor of an object `X : C` : it consists of an idempotent
`p : X ⟶ X` which is thought as the "formal image" of `p`. The type `karoubi C` shall be the
type of the objects of the karoubi enveloppe of `C`. It makes sense for any category `C`. -/
@[nolint has_nonempty_instance]
structure Karoubi where
  pt : C
  p : X ⟶ X
  idem : p ≫ p = p
#align category_theory.idempotents.karoubi CategoryTheory.Idempotents.Karoubi

namespace Karoubi

variable {C}

attribute [simp, reassoc.1] idem

@[ext]
theorem ext {P Q : Karoubi C} (h_X : P.pt = Q.pt) (h_p : P.p ≫ eqToHom h_X = eqToHom h_X ≫ Q.p) :
    P = Q := by
  cases P
  cases Q
  dsimp at h_X h_p
  subst h_X
  simpa only [true_and_iff, eq_self_iff_true, id_comp, eq_to_hom_refl, heq_iff_eq, comp_id] using
    h_p
#align category_theory.idempotents.karoubi.ext CategoryTheory.Idempotents.Karoubi.ext

/-- A morphism `P ⟶ Q` in the category `karoubi C` is a morphism in the underlying category
`C` which satisfies a relation, which in the preadditive case, expresses that it induces a
map between the corresponding "formal direct factors" and that it vanishes on the complement
formal direct factor. -/
@[ext]
structure Hom (P Q : Karoubi C) where
  f : P.pt ⟶ Q.pt
  comm : f = P.p ≫ f ≫ Q.p
#align category_theory.idempotents.karoubi.hom CategoryTheory.Idempotents.Karoubi.Hom

instance [Preadditive C] (P Q : Karoubi C) : Inhabited (Hom P Q) :=
  ⟨⟨0, by rw [zero_comp, comp_zero]⟩⟩

@[simp]
theorem hom_ext {P Q : Karoubi C} {f g : Hom P Q} : f = g ↔ f.f = g.f :=
  by
  constructor
  · intro h
    rw [h]
  · ext
#align category_theory.idempotents.karoubi.hom_ext CategoryTheory.Idempotents.Karoubi.hom_ext

@[simp, reassoc.1]
theorem p_comp {P Q : Karoubi C} (f : Hom P Q) : P.p ≫ f.f = f.f := by rw [f.comm, ← assoc, P.idem]
#align category_theory.idempotents.karoubi.p_comp CategoryTheory.Idempotents.Karoubi.p_comp

@[simp, reassoc.1]
theorem comp_p {P Q : Karoubi C} (f : Hom P Q) : f.f ≫ Q.p = f.f := by
  rw [f.comm, assoc, assoc, Q.idem]
#align category_theory.idempotents.karoubi.comp_p CategoryTheory.Idempotents.Karoubi.comp_p

theorem p_comm {P Q : Karoubi C} (f : Hom P Q) : P.p ≫ f.f = f.f ≫ Q.p := by rw [p_comp, comp_p]
#align category_theory.idempotents.karoubi.p_comm CategoryTheory.Idempotents.Karoubi.p_comm

theorem comp_proof {P Q R : Karoubi C} (g : Hom Q R) (f : Hom P Q) :
    f.f ≫ g.f = P.p ≫ (f.f ≫ g.f) ≫ R.p := by rw [assoc, comp_p, ← assoc, p_comp]
#align category_theory.idempotents.karoubi.comp_proof CategoryTheory.Idempotents.Karoubi.comp_proof

/-- The category structure on the karoubi envelope of a category. -/
instance : Category (Karoubi C) where
  Hom := Karoubi.Hom
  id P := ⟨P.p, by repeat' rw [P.idem]⟩
  comp P Q R f g := ⟨f.f ≫ g.f, Karoubi.comp_proof g f⟩

@[simp]
theorem comp_f {P Q R : Karoubi C} (f : P ⟶ Q) (g : Q ⟶ R) : (f ≫ g).f = f.f ≫ g.f := by rfl
#align category_theory.idempotents.karoubi.comp_f CategoryTheory.Idempotents.Karoubi.comp_f

@[simp]
theorem id_eq {P : Karoubi C} : 𝟙 P = ⟨P.p, by repeat' rw [P.idem]⟩ := by rfl
#align category_theory.idempotents.karoubi.id_eq CategoryTheory.Idempotents.Karoubi.id_eq

/-- It is possible to coerce an object of `C` into an object of `karoubi C`.
See also the functor `to_karoubi`. -/
instance coe : CoeTC C (Karoubi C) :=
  ⟨fun X => ⟨X, 𝟙 X, by rw [comp_id]⟩⟩
#align category_theory.idempotents.karoubi.coe CategoryTheory.Idempotents.Karoubi.coe

@[simp]
theorem coe_x (X : C) : (X : Karoubi C).pt = X := by rfl
#align category_theory.idempotents.karoubi.coe_X CategoryTheory.Idempotents.Karoubi.coe_x

@[simp]
theorem coe_p (X : C) : (X : Karoubi C).p = 𝟙 X := by rfl
#align category_theory.idempotents.karoubi.coe_p CategoryTheory.Idempotents.Karoubi.coe_p

@[simp]
theorem eqToHom_f {P Q : Karoubi C} (h : P = Q) :
    Karoubi.Hom.f (eqToHom h) = P.p ≫ eqToHom (congr_arg Karoubi.x h) :=
  by
  subst h
  simp only [eq_to_hom_refl, karoubi.id_eq, comp_id]
#align category_theory.idempotents.karoubi.eq_to_hom_f CategoryTheory.Idempotents.Karoubi.eqToHom_f

end Karoubi

/-- The obvious fully faithful functor `to_karoubi` sends an object `X : C` to the obvious
formal direct factor of `X` given by `𝟙 X`. -/
@[simps]
def toKaroubi : C ⥤ Karoubi C
    where
  obj X := ⟨X, 𝟙 X, by rw [comp_id]⟩
  map X Y f := ⟨f, by simp only [comp_id, id_comp]⟩
#align category_theory.idempotents.to_karoubi CategoryTheory.Idempotents.toKaroubi

instance : Full (toKaroubi C) where preimage X Y f := f.f

instance : Faithful (toKaroubi C) where

variable {C}

@[simps]
instance [Preadditive C] {P Q : Karoubi C} : AddCommGroup (P ⟶ Q)
    where
  add f g :=
    ⟨f.f + g.f, by
      rw [add_comp, comp_add]
      congr
      exacts[f.comm, g.comm]⟩
  zero := ⟨0, by simp only [comp_zero, zero_comp]⟩
  zero_add f := by
    ext
    simp only [zero_add]
  add_zero f := by
    ext
    simp only [add_zero]
  add_assoc f g h' := by simp only [add_assoc]
  add_comm f g := by
    ext
    apply_rules [add_comm]
  neg f := ⟨-f.f, by simpa only [neg_comp, comp_neg, neg_inj] using f.comm⟩
  add_left_neg f := by
    ext
    apply_rules [add_left_neg]

namespace Karoubi

theorem hom_eq_zero_iff [Preadditive C] {P Q : Karoubi C} {f : Hom P Q} : f = 0 ↔ f.f = 0 :=
  hom_ext
#align category_theory.idempotents.karoubi.hom_eq_zero_iff CategoryTheory.Idempotents.Karoubi.hom_eq_zero_iff

/-- The map sending `f : P ⟶ Q` to `f.f : P.X ⟶ Q.X` is additive. -/
@[simps]
def inclusionHom [Preadditive C] (P Q : Karoubi C) : AddMonoidHom (P ⟶ Q) (P.pt ⟶ Q.pt)
    where
  toFun f := f.f
  map_zero' := rfl
  map_add' f g := rfl
#align category_theory.idempotents.karoubi.inclusion_hom CategoryTheory.Idempotents.Karoubi.inclusionHom

@[simp]
theorem sum_hom [Preadditive C] {P Q : Karoubi C} {α : Type _} (s : Finset α) (f : α → (P ⟶ Q)) :
    (∑ x in s, f x).f = ∑ x in s, (f x).f :=
  AddMonoidHom.map_sum (inclusionHom P Q) f s
#align category_theory.idempotents.karoubi.sum_hom CategoryTheory.Idempotents.Karoubi.sum_hom

end Karoubi

/-- The category `karoubi C` is preadditive if `C` is. -/
instance [Preadditive C] : Preadditive (Karoubi C) where homGroup P Q := by infer_instance

instance [Preadditive C] : Functor.Additive (toKaroubi C) where

open Karoubi

variable (C)

instance : IsIdempotentComplete (Karoubi C) :=
  by
  refine' ⟨_⟩
  intro P p hp
  have hp' := hom_ext.mp hp
  simp only [comp_f] at hp'
  use ⟨P.X, p.f, hp'⟩
  use ⟨p.f, by rw [comp_p p, hp']⟩
  use ⟨p.f, by rw [hp', p_comp p]⟩
  constructor <;> simpa only [hom_ext] using hp'

instance [IsIdempotentComplete C] : EssSurj (toKaroubi C) :=
  ⟨fun P => by
    have h : is_idempotent_complete C := inferInstance
    rcases is_idempotent_complete.idempotents_split P.X P.p P.idem with ⟨Y, i, e, ⟨h₁, h₂⟩⟩
    use Y
    exact
      Nonempty.intro
        { Hom := ⟨i, by erw [id_comp, ← h₂, ← assoc, h₁, id_comp]⟩
          inv := ⟨e, by erw [comp_id, ← h₂, assoc, h₁, comp_id]⟩ }⟩

/-- If `C` is idempotent complete, the functor `to_karoubi : C ⥤ karoubi C` is an equivalence. -/
def toKaroubiIsEquivalence [IsIdempotentComplete C] : IsEquivalence (toKaroubi C) :=
  Equivalence.ofFullyFaithfullyEssSurj (toKaroubi C)
#align category_theory.idempotents.to_karoubi_is_equivalence CategoryTheory.Idempotents.toKaroubiIsEquivalence

/-- The equivalence `C ≅ karoubi C` when `C` is idempotent complete. -/
def toKaroubiEquivalence [IsIdempotentComplete C] : C ≌ Karoubi C :=
  haveI := to_karoubi_is_equivalence C
  functor.as_equivalence (to_karoubi C)
#align category_theory.idempotents.to_karoubi_equivalence CategoryTheory.Idempotents.toKaroubiEquivalence

instance toKaroubiEquivalence_functor_additive [Preadditive C] [IsIdempotentComplete C] :
    (toKaroubiEquivalence C).Functor.Additive :=
  (inferInstance : (toKaroubi C).Additive)
#align category_theory.idempotents.to_karoubi_equivalence_functor_additive CategoryTheory.Idempotents.toKaroubiEquivalence_functor_additive

namespace Karoubi

variable {C}

/-- The split mono which appears in the factorisation `decomp_id P`. -/
@[simps]
def decompIdI (P : Karoubi C) : P ⟶ P.pt :=
  ⟨P.p, by erw [coe_p, comp_id, P.idem]⟩
#align category_theory.idempotents.karoubi.decomp_id_i CategoryTheory.Idempotents.Karoubi.decompIdI

/-- The split epi which appears in the factorisation `decomp_id P`. -/
@[simps]
def decompIdP (P : Karoubi C) : (P.pt : Karoubi C) ⟶ P :=
  ⟨P.p, by erw [coe_p, id_comp, P.idem]⟩
#align category_theory.idempotents.karoubi.decomp_id_p CategoryTheory.Idempotents.Karoubi.decompIdP

/-- The formal direct factor of `P.X` given by the idempotent `P.p` in the category `C`
is actually a direct factor in the category `karoubi C`. -/
theorem decomp_id (P : Karoubi C) : 𝟙 P = decompIdI P ≫ decompIdP P :=
  by
  ext
  simp only [comp_f, id_eq, P.idem, decomp_id_i, decomp_id_p]
#align category_theory.idempotents.karoubi.decomp_id CategoryTheory.Idempotents.Karoubi.decomp_id

theorem decomp_p (P : Karoubi C) : (toKaroubi C).map P.p = decompIdP P ≫ decompIdI P :=
  by
  ext
  simp only [comp_f, decomp_id_p_f, decomp_id_i_f, P.idem, to_karoubi_map_f]
#align category_theory.idempotents.karoubi.decomp_p CategoryTheory.Idempotents.Karoubi.decomp_p

theorem decompIdI_toKaroubi (X : C) : decompIdI ((toKaroubi C).obj X) = 𝟙 _ :=
  by
  ext
  rfl
#align category_theory.idempotents.karoubi.decomp_id_i_to_karoubi CategoryTheory.Idempotents.Karoubi.decompIdI_toKaroubi

theorem decompIdP_toKaroubi (X : C) : decompIdP ((toKaroubi C).obj X) = 𝟙 _ :=
  by
  ext
  rfl
#align category_theory.idempotents.karoubi.decomp_id_p_to_karoubi CategoryTheory.Idempotents.Karoubi.decompIdP_toKaroubi

theorem decompIdI_naturality {P Q : Karoubi C} (f : P ⟶ Q) :
    f ≫ decompIdI _ = decompIdI _ ≫ ⟨f.f, by erw [comp_id, id_comp]⟩ :=
  by
  ext
  simp only [comp_f, decomp_id_i_f, karoubi.comp_p, karoubi.p_comp]
#align category_theory.idempotents.karoubi.decomp_id_i_naturality CategoryTheory.Idempotents.Karoubi.decompIdI_naturality

theorem decompIdP_naturality {P Q : Karoubi C} (f : P ⟶ Q) :
    decompIdP P ≫ f =
      (⟨f.f, by erw [comp_id, id_comp]⟩ : (P.pt : Karoubi C) ⟶ Q.pt) ≫ decompIdP Q :=
  by
  ext
  simp only [comp_f, decomp_id_p_f, karoubi.comp_p, karoubi.p_comp]
#align category_theory.idempotents.karoubi.decomp_id_p_naturality CategoryTheory.Idempotents.Karoubi.decompIdP_naturality

@[simp]
theorem zsmul_hom [Preadditive C] {P Q : Karoubi C} (n : ℤ) (f : P ⟶ Q) : (n • f).f = n • f.f :=
  map_zsmul (inclusionHom P Q) n f
#align category_theory.idempotents.karoubi.zsmul_hom CategoryTheory.Idempotents.Karoubi.zsmul_hom

end Karoubi

end Idempotents

end CategoryTheory


/-
Copyright (c) 2020 Kenji Nakagawa. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenji Nakagawa, Anne Baanen, Filippo A. E. Nuccio
-/
import ring_theory.dedekind_domain.ideal
import ring_theory.discrete_valuation_ring
import ring_theory.localization.at_prime
import ring_theory.localization.submodule
import ring_theory.valuation.tfae

/-!
# Dedekind domains

This file defines an equivalent notion of a Dedekind domain (or Dedekind ring),
namely a Noetherian integral domain where the localization at all nonzero prime ideals is a DVR
(TODO: and shows that implies the main definition).

## Main definitions

 - `is_dedekind_domain_dvr` alternatively defines a Dedekind domain as an integral domain that
   is Noetherian, and the localization at every nonzero prime ideal is a DVR.

## Main results
 - `is_localization.at_prime.discrete_valuation_ring_of_dedekind_domain` shows that
   `is_dedekind_domain` implies the localization at each nonzero prime ideal is a DVR.
 - `is_dedekind_domain.is_dedekind_domain_dvr` is one direction of the equivalence of definitions
   of a Dedekind domain

## Implementation notes

The definitions that involve a field of fractions choose a canonical field of fractions,
but are independent of that choice. The `..._iff` lemmas express this independence.

Often, definitions assume that Dedekind domains are not fields. We found it more practical
to add a `(h : ¬ is_field A)` assumption whenever this is explicitly needed.

## References

* [D. Marcus, *Number Fields*][marcus1977number]
* [J.W.S. Cassels, A. Frölich, *Algebraic Number Theory*][cassels1967algebraic]
* [J. Neukirch, *Algebraic Number Theory*][Neukirch1992]

## Tags

dedekind domain, dedekind ring
-/

variables (R A K : Type*) [comm_ring R] [comm_ring A] [is_domain A] [field K]

open_locale non_zero_divisors polynomial

/--
A Dedekind domain is an integral domain that is Noetherian, and the
localization at every nonzero prime is a discrete valuation ring.

This is equivalent to `is_dedekind_domain`.
TODO: prove the equivalence.
-/
structure is_dedekind_domain_dvr : Prop :=
(is_noetherian_ring : is_noetherian_ring A)
(is_dvr_at_nonzero_prime : ∀ P ≠ (⊥ : ideal A), P.is_prime →
  discrete_valuation_ring (localization.at_prime P))

/-- Localizing a domain of Krull dimension `≤ 1` gives another ring of Krull dimension `≤ 1`.

Note that the same proof can/should be generalized to preserving any Krull dimension,
once we have a suitable definition.
-/
lemma ring.dimension_le_one.localization {R : Type*} (Rₘ : Type*) [comm_ring R] [is_domain R]
  [comm_ring Rₘ] [algebra R Rₘ] {M : submonoid R} [is_localization M Rₘ] (hM : M ≤ R⁰)
  (h : ring.dimension_le_one R) : ring.dimension_le_one Rₘ :=
begin
  introsI p hp0 hpp,
  refine ideal.is_maximal_def.mpr ⟨hpp.ne_top, ideal.maximal_of_no_maximal (λ P hpP hPm, _)⟩,
  have hpP' : (⟨p, hpp⟩ : {p : ideal Rₘ // p.is_prime}) < ⟨P, hPm.is_prime⟩ := hpP,
  rw ← (is_localization.order_iso_of_prime M Rₘ).lt_iff_lt at hpP',
  haveI : ideal.is_prime (ideal.comap (algebra_map R Rₘ) p) :=
    ((is_localization.order_iso_of_prime M Rₘ) ⟨p, hpp⟩).2.1,
  haveI : ideal.is_prime (ideal.comap (algebra_map R Rₘ) P) :=
    ((is_localization.order_iso_of_prime M Rₘ) ⟨P, hPm.is_prime⟩).2.1,
  have hlt : ideal.comap (algebra_map R Rₘ) p < ideal.comap (algebra_map R Rₘ) P := hpP',
  refine h.not_lt_lt ⊥ (ideal.comap _ _) (ideal.comap _ _) ⟨_, hpP'⟩,
  exact is_localization.bot_lt_comap_prime _ _ hM _ hp0
end

/-- The localization of a Dedekind domain is a Dedekind domain. -/
lemma is_localization.is_dedekind_domain [is_dedekind_domain A] {M : submonoid A} (hM : M ≤ A⁰)
  (Aₘ : Type*) [comm_ring Aₘ] [is_domain Aₘ] [algebra A Aₘ]
  [is_localization M Aₘ] : is_dedekind_domain Aₘ :=
begin
  have : ∀ (y : M), is_unit (algebra_map A (fraction_ring A) y),
  { rintros ⟨y, hy⟩,
    exact is_unit.mk0 _ (mt is_fraction_ring.to_map_eq_zero_iff.mp (non_zero_divisors.ne_zero
      (hM hy))) },
  letI : algebra Aₘ (fraction_ring A) := ring_hom.to_algebra (is_localization.lift this),
  haveI : is_scalar_tower A Aₘ (fraction_ring A) := is_scalar_tower.of_algebra_map_eq
    (λ x, (is_localization.lift_eq this x).symm),
  haveI : is_fraction_ring Aₘ (fraction_ring A) :=
    is_fraction_ring.is_fraction_ring_of_is_domain_of_is_localization M _ _,
  refine (is_dedekind_domain_iff _ (fraction_ring A)).mpr ⟨_, _, _⟩,
  { exact is_localization.is_noetherian_ring M _ (by apply_instance) },
  { exact is_dedekind_domain.dimension_le_one.localization Aₘ hM },
  { intros x hx,
    obtain ⟨⟨y, y_mem⟩, hy⟩ := hx.exists_multiple_integral_of_is_localization M _,
    obtain ⟨z, hz⟩ := (is_integrally_closed_iff _).mp is_dedekind_domain.is_integrally_closed hy,
    refine ⟨is_localization.mk' Aₘ z ⟨y, y_mem⟩, (is_localization.lift_mk'_spec _ _ _ _).mpr _⟩,
    rw [hz, set_like.coe_mk, ← algebra.smul_def],
    refl },
end

/-- The localization of a Dedekind domain at every nonzero prime ideal is a Dedekind domain. -/
lemma is_localization.at_prime.is_dedekind_domain [is_dedekind_domain A]
  (P : ideal A) [P.is_prime] (Aₘ : Type*) [comm_ring Aₘ] [is_domain Aₘ] [algebra A Aₘ]
  [is_localization.at_prime Aₘ P] : is_dedekind_domain Aₘ :=
is_localization.is_dedekind_domain A P.prime_compl_le_non_zero_divisors Aₘ

lemma is_localization.at_prime.not_is_field
  {P : ideal A} (hP : P ≠ ⊥) [pP : P.is_prime]
  (Aₘ : Type*) [comm_ring Aₘ] [algebra A Aₘ] [is_localization.at_prime Aₘ P] :
  ¬ (is_field Aₘ) :=
begin
  intro h,
  letI := h.to_field,
  obtain ⟨x, x_mem, x_ne⟩ := P.ne_bot_iff.mp hP,
  exact (local_ring.maximal_ideal.is_maximal _).ne_top (ideal.eq_top_of_is_unit_mem _
    ((is_localization.at_prime.to_map_mem_maximal_iff Aₘ P _).mpr x_mem)
    (is_unit_iff_ne_zero.mpr ((map_ne_zero_iff (algebra_map A Aₘ)
      (is_localization.injective Aₘ P.prime_compl_le_non_zero_divisors)).mpr x_ne))),
end

/-- In a Dedekind domain, the localization at every nonzero prime ideal is a DVR. -/
lemma is_localization.at_prime.discrete_valuation_ring_of_dedekind_domain [is_dedekind_domain A]
  {P : ideal A} (hP : P ≠ ⊥) [pP : P.is_prime]
  (Aₘ : Type*) [comm_ring Aₘ] [is_domain Aₘ] [algebra A Aₘ] [is_localization.at_prime Aₘ P] :
  discrete_valuation_ring Aₘ :=
begin
  classical,
  letI : is_noetherian_ring Aₘ := is_localization.is_noetherian_ring P.prime_compl _
    is_dedekind_domain.is_noetherian_ring,
  letI : local_ring Aₘ := is_localization.at_prime.local_ring Aₘ P,
  have hnf := is_localization.at_prime.not_is_field A hP Aₘ,
  exact ((discrete_valuation_ring.tfae Aₘ hnf).out 0 2).mpr
    (is_localization.at_prime.is_dedekind_domain A P _)
end

/-- Dedekind domains, in the sense of Noetherian integrally closed domains of Krull dimension ≤ 1,
are also Dedekind domains in the sense of Noetherian domains where the localization at every
nonzero prime ideal is a DVR. -/
theorem is_dedekind_domain.is_dedekind_domain_dvr [is_dedekind_domain A] :
  is_dedekind_domain_dvr A :=
{ is_noetherian_ring := is_dedekind_domain.is_noetherian_ring,
  is_dvr_at_nonzero_prime := λ P hP pP, by exactI
    is_localization.at_prime.discrete_valuation_ring_of_dedekind_domain A hP _ }


import Logic.Predicate.FirstOrder.Formula

variable {L L₁ L₂ L₃ : Language} {μ : Type _}

namespace Language

namespace Hom
variable (Φ : Hom L₁ L₂) {n : ℕ}

open FirstOrder

def onSubFormula₁' (Φ : Hom L₁ L₂) : ∀ {n}, SubFormula L₁ μ n → SubFormula L₂ μ n
  | _, ⊤                   => ⊤
  | _, ⊥                   => ⊥
  | _, SubFormula.rel r v  => SubFormula.rel (Φ.onRel r) (fun i => Φ.onSubTerm (v i))
  | _, SubFormula.nrel r v => SubFormula.nrel (Φ.onRel r) (fun i => Φ.onSubTerm (v i))
  | _, p ⋏ q               => Φ.onSubFormula₁' p ⋏ Φ.onSubFormula₁' q
  | _, p ⋎ q               => Φ.onSubFormula₁' p ⋎ Φ.onSubFormula₁' q
  | _, ∀' p                => ∀' Φ.onSubFormula₁' p
  | _, ∃' p                => ∃' Φ.onSubFormula₁' p

lemma onSubFormula₁'_neg {n} (p : SubFormula L₁ μ n) :
    Φ.onSubFormula₁' (~p) = ~Φ.onSubFormula₁' p :=
  by induction p using SubFormula.rec' <;> simp[*, onSubFormula₁', ←SubFormula.neg_eq]

def onSubFormula₁ (Φ : Hom L₁ L₂) {n} : SubFormula L₁ μ n →L SubFormula L₂ μ n where
  toFun := Φ.onSubFormula₁'
  map_top' := by simp[onSubFormula₁']
  map_bot' := by simp[onSubFormula₁']
  map_and' := by simp[onSubFormula₁']
  map_or'  := by simp[onSubFormula₁']
  map_neg' := by simp[onSubFormula₁'_neg]
  map_imp' := by simp[SubFormula.imp_eq, onSubFormula₁'_neg, ←SubFormula.neg_eq, onSubFormula₁']

lemma onSubFormula₁_rel {k} (r : L₁.rel k) (v : Fin k → SubTerm L₁ μ n) :
    Φ.onSubFormula₁ (SubFormula.rel r v) = SubFormula.rel (Φ.onRel r) (fun i => Φ.onSubTerm (v i)) := rfl

lemma onSubFormula₁_nrel {k} (r : L₁.rel k) (v : Fin k → SubTerm L₁ μ n) :
    Φ.onSubFormula₁ (SubFormula.nrel r v) = SubFormula.nrel (Φ.onRel r) (fun i => Φ.onSubTerm (v i)) := rfl

@[simp] lemma onSubFormula₁_all (p : SubFormula L₁ μ (n + 1)) :
    Φ.onSubFormula₁ (∀' p) = ∀' Φ.onSubFormula₁ p := rfl

@[simp] lemma onSubFormula₁_ex (p : SubFormula L₁ μ (n + 1)) :
    Φ.onSubFormula₁ (∃' p) = ∃' Φ.onSubFormula₁ p := rfl

end Hom

end Language

namespace FirstOrder

namespace SubFormula
variable {L₁ L₂ : Language} (Φ : L₁ →ᵥ L₂) {μ₁ μ₂ : Type _} {n₁ n₂ : ℕ}

lemma onSubFormula₁_bind (bound : Fin n₁ → SubTerm L₁ μ₂ n₂) (free : μ₁ → SubTerm L₁ μ₂ n₂) (p) :
    Φ.onSubFormula₁ (bind bound free p) =
    bind (fun x => Φ.onSubTerm (bound x)) (fun x => Φ.onSubTerm (free x)) (Φ.onSubFormula₁ p) := by
  induction p using rec' generalizing μ₂ n₂ <;>
  simp[*, SubTerm.onSubTerm_bind, Matrix.comp_vecCons, Function.comp, SubTerm.onSubTerm_bShift,
    Language.Hom.onSubFormula₁_rel, Language.Hom.onSubFormula₁_nrel, bind_rel, bind_nrel]

lemma onSubFormula₁_map (bound : Fin n₁ → Fin n₂) (free : μ₁ → μ₂) (p) :
    Φ.onSubFormula₁ (map bound free p) = map bound free (Φ.onSubFormula₁ p) :=
  by simp[map, onSubFormula₁_bind]

lemma onSubFormula₁_subst (u) (p : SubFormula L₁ μ (n + 1)) :
    Φ.onSubFormula₁ (subst u p) = subst (Φ.onSubTerm u) (Φ.onSubFormula₁ p) :=
  by simp[subst, onSubFormula₁_bind, Matrix.comp_vecConsLast, Function.comp]

lemma onSubFormula₁_shift (p : SyntacticSubFormula L₁ n) : Φ.onSubFormula₁ (shift p) = shift (Φ.onSubFormula₁ p) :=
  by simp[shift, onSubFormula₁_map]

lemma onSubFormula₁_free (p : SyntacticSubFormula L₁ (n + 1)) : Φ.onSubFormula₁ (free p) = free (Φ.onSubFormula₁ p) :=
  by simp[free, onSubFormula₁_bind]; congr; exact funext $ Fin.lastCases (by simp) (by simp)

lemma onSubFormula₁_fix (p : SyntacticSubFormula L₁ n) : Φ.onSubFormula₁ (fix p) = fix (Φ.onSubFormula₁ p) :=
  by simp[fix, onSubFormula₁_bind]; congr; funext x; cases x <;> simp

end SubFormula

variable {L : Language} [∀ k, DecidableEq (L.func k)] [∀ k, DecidableEq (L.rel k)]

namespace SubFormula

noncomputable def languageFunc : ∀ {n}, SubFormula L μ n → Finset (Σ k, L.func k)
  | _, ⊤        => ∅
  | _, ⊥        => ∅
  | _, rel  _ v => Finset.bunionᵢ Finset.univ (fun i => SubTerm.languageFunc (v i))
  | _, nrel _ v => Finset.bunionᵢ Finset.univ (fun i => SubTerm.languageFunc (v i))
  | _, p ⋏ q    => languageFunc p ∪ languageFunc q
  | _, p ⋎ q    => languageFunc p ∪ languageFunc q
  | _, ∀' p     => languageFunc p
  | _, ∃' p     => languageFunc p

noncomputable def languageRel : ∀ {n}, SubFormula L μ n → Finset (Σ k, L.rel k)
  | _, ⊤        => ∅
  | _, ⊥        => ∅
  | _, rel  r _ => {⟨_, r⟩}
  | _, nrel r _ => {⟨_, r⟩}
  | _, p ⋏ q    => languageRel p ∪ languageRel q
  | _, p ⋎ q    => languageRel p ∪ languageRel q
  | _, ∀' p     => languageRel p
  | _, ∃' p     => languageRel p

lemma languageFunc_rel_ss {k} (r : L.rel k) (v : Fin k → SubTerm L μ n) (i) :
    (v i).languageFunc ⊆ (rel r v).languageFunc :=
  by intros x; simp[languageFunc]; intros h; exact ⟨i, h⟩

def toSubLanguage' (pf : ∀ k, L.func k → Prop) (pr : ∀ k, L.rel k → Prop) : ∀ {n} (p : SubFormula L μ n),
    (∀ k f, ⟨k, f⟩ ∈ p.languageFunc → pf k f) →
    (∀ k r, ⟨k, r⟩ ∈ p.languageRel → pr k r) →
    SubFormula (L.subLanguage pf pr) μ n
  | _, ⊤,        _,  _  => ⊤
  | _, ⊥,        _,  _  => ⊥
  | _, rel r v,  hf, hr =>
      rel ⟨r, hr _ r (by simp[languageRel])⟩
        (fun i => (v i).toSubLanguage' pf pr (fun k f h => hf k f (languageFunc_rel_ss r v i h)))
  | _, nrel r v, hf, hr =>
      nrel ⟨r, hr _ r (by simp[languageRel])⟩
        (fun i => (v i).toSubLanguage' pf pr (fun k f h => hf k f (languageFunc_rel_ss r v i h)))
  | _, p ⋏ q,    hf, hr =>
      toSubLanguage' pf pr p (fun k f h => hf k f (Finset.mem_union_left _ h)) (fun k r h => hr k r (Finset.mem_union_left _ h)) ⋏
      toSubLanguage' pf pr q (fun k f h => hf k f (Finset.mem_union_right _ h)) (fun k r h => hr k r (Finset.mem_union_right _ h))
  | _, p ⋎ q,    hf, hr =>
      toSubLanguage' pf pr p (fun k f h => hf k f (Finset.mem_union_left _ h)) (fun k r h => hr k r (Finset.mem_union_left _ h)) ⋎
      toSubLanguage' pf pr q (fun k f h => hf k f (Finset.mem_union_right _ h)) (fun k r h => hr k r (Finset.mem_union_right _ h))
  | _, ∀' p,     hf, hr => ∀' toSubLanguage' pf pr p (fun k f h => hf k f h) (fun k r h => hr k r h)
  | _, ∃' p,     hf, hr => ∃' toSubLanguage' pf pr p (fun k f h => hf k f h) (fun k r h => hr k r h)

@[simp] lemma onSubFormula_toSubLanguage'
  (pf : ∀ k, L.func k → Prop) (pr : ∀ k, L.rel k → Prop) {n} (p : SubFormula L μ n)
  (hf : ∀ k f, ⟨k, f⟩ ∈ p.languageFunc → pf k f) (hr : ∀ k r, ⟨k, r⟩ ∈ p.languageRel → pr k r) :
    L.ofSubLanguage.onSubFormula₁ (p.toSubLanguage' pf pr hf hr) = p := by
  induction p using rec' <;>
  simp[*, toSubLanguage', Language.Hom.onSubFormula₁_rel, Language.Hom.onSubFormula₁_nrel]

noncomputable def languageFuncIndexed (p : SubFormula L μ n) (k) : Finset (L.func k) :=
  Finset.preimage (languageFunc p) (Sigma.mk k) (Set.injOn_of_injective sigma_mk_injective _)

noncomputable def languageRelIndexed (p : SubFormula L μ n) (k) : Finset (L.rel k) :=
  Finset.preimage (languageRel p) (Sigma.mk k) (Set.injOn_of_injective sigma_mk_injective _)

def language (p : SubFormula L μ n) : Language :=
  Language.subLanguage L (fun k f => ⟨k, f⟩ ∈ languageFunc p) (fun k r => ⟨k, r⟩ ∈ languageRel p)

noncomputable instance (p : SubFormula L μ n) (k) : Fintype (p.language.func k) :=
  Fintype.subtype (languageFuncIndexed p k) (by simp[languageFuncIndexed])

noncomputable instance (p : SubFormula L μ n) (k) : Fintype (p.language.rel k) :=
  Fintype.subtype (languageRelIndexed p k) (by simp[languageRelIndexed])


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import data.set.lattice

/-! # Semiquotients

A data type for semiquotients, which are classically equivalent to
nonempty sets, but are useful for programming; the idea is that
a semiquotient set `S` represents some (particular but unknown)
element of `S`. This can be used to model nondeterministic functions,
which return something in a range of values (represented by the
predicate `S`) but are not completely determined.
-/

/-- A member of `semiquot α` is classically a nonempty `set α`,
  and in the VM is represented by an element of `α`; the relation
  between these is that the VM element is required to be a member
  of the set `s`. The specific element of `s` that the VM computes
  is hidden by a quotient construction, allowing for the representation
  of nondeterministic functions. -/
structure {u} semiquot (α : Type*) := mk' ::
(s : set α)
(val : trunc ↥s)

namespace semiquot
variables {α : Type*} {β : Type*}

instance : has_mem α (semiquot α) := ⟨λ a q, a ∈ q.s⟩

/-- Construct a `semiquot α` from `h : a ∈ s` where `s : set α`. -/
def mk {a : α} {s : set α} (h : a ∈ s) : semiquot α :=
⟨s, trunc.mk ⟨a, h⟩⟩

theorem ext_s {q₁ q₂ : semiquot α} : q₁ = q₂ ↔ q₁.s = q₂.s :=
⟨congr_arg _,
 λ h, by cases q₁; cases q₂; congr; exact h⟩

theorem ext {q₁ q₂ : semiquot α} : q₁ = q₂ ↔ ∀ a, a ∈ q₁ ↔ a ∈ q₂ :=
ext_s.trans set.ext_iff

theorem exists_mem (q : semiquot α) : ∃ a, a ∈ q :=
let ⟨⟨a, h⟩, h₂⟩ := q.2.exists_rep in ⟨a, h⟩

theorem eq_mk_of_mem {q : semiquot α} {a : α} (h : a ∈ q) :
  q = @mk _ a q.1 h := ext_s.2 rfl

theorem nonempty (q : semiquot α) : q.s.nonempty := q.exists_mem

/-- `pure a` is `a` reinterpreted as an unspecified element of `{a}`. -/
protected def pure (a : α) : semiquot α := mk (set.mem_singleton a)

@[simp] theorem mem_pure' {a b : α} : a ∈ semiquot.pure b ↔ a = b :=
set.mem_singleton_iff

/-- Replace `s` in a `semiquot` with a superset. -/
def blur' (q : semiquot α) {s : set α} (h : q.s ⊆ s) : semiquot α :=
⟨s, trunc.lift (λ a : q.s, trunc.mk ⟨a.1, h a.2⟩)
  (λ _ _, trunc.eq _ _) q.2⟩

/-- Replace `s` in a `q : semiquot α` with a union `s ∪ q.s` -/
def blur (s : set α) (q : semiquot α) : semiquot α :=
blur' q (set.subset_union_right s q.s)

theorem blur_eq_blur' (q : semiquot α) (s : set α) (h : q.s ⊆ s) :
  blur s q = blur' q h :=
by unfold blur; congr; exact set.union_eq_self_of_subset_right h

@[simp] theorem mem_blur' (q : semiquot α) {s : set α} (h : q.s ⊆ s)
  {a : α} : a ∈ blur' q h ↔ a ∈ s := iff.rfl

/-- Convert a `trunc α` to a `semiquot α`. -/
def of_trunc (q : trunc α) : semiquot α :=
⟨set.univ, q.map (λ a, ⟨a, trivial⟩)⟩

/-- Convert a `semiquot α` to a `trunc α`. -/
def to_trunc (q : semiquot α) : trunc α :=
q.2.map subtype.val

/-- If `f` is a constant on `q.s`, then `q.lift_on f` is the value of `f`
at any point of `q`. -/
def lift_on (q : semiquot α) (f : α → β) (h : ∀ a b ∈ q, f a = f b) : β :=
trunc.lift_on q.2 (λ x, f x.1) (λ x y, h _ _ x.2 y.2)

theorem lift_on_of_mem (q : semiquot α)
  (f : α → β) (h : ∀ a b ∈ q, f a = f b)
  (a : α) (aq : a ∈ q) : lift_on q f h = f a :=
by revert h; rw eq_mk_of_mem aq; intro; refl

/-- Apply a function to the unknown value stored in a `semiquot α`. -/
def map (f : α → β) (q : semiquot α) : semiquot β :=
⟨f '' q.1, q.2.map (λ x, ⟨f x.1, set.mem_image_of_mem _ x.2⟩)⟩

@[simp] theorem mem_map (f : α → β) (q : semiquot α) (b : β) :
  b ∈ map f q ↔ ∃ a, a ∈ q ∧ f a = b := set.mem_image _ _ _

/-- Apply a function returning a `semiquot` to a `semiquot`. -/
def bind (q : semiquot α) (f : α → semiquot β) : semiquot β :=
⟨⋃ a ∈ q.1, (f a).1,
 q.2.bind (λ a, (f a.1).2.map (λ b, ⟨b.1, set.mem_bUnion a.2 b.2⟩))⟩

@[simp] theorem mem_bind (q : semiquot α) (f : α → semiquot β) (b : β) :
  b ∈ bind q f ↔ ∃ a ∈ q, b ∈ f a := set.mem_bUnion_iff

instance : monad semiquot :=
{ pure := @semiquot.pure,
  map := @semiquot.map,
  bind := @semiquot.bind }

@[simp] lemma map_def {β} : ((<$>) : (α → β) → semiquot α → semiquot β) = map := rfl
@[simp] lemma bind_def {β} : ((>>=) : semiquot α → (α → semiquot β) → semiquot β) = bind := rfl

@[simp]

theorem mem_pure_self (a : α) : a ∈ (pure a : semiquot α) :=
set.mem_singleton a

@[simp] theorem pure_inj {a b : α} : (pure a : semiquot α) = pure b ↔ a = b :=
ext_s.trans set.singleton_eq_singleton_iff

instance : is_lawful_monad semiquot :=
{ pure_bind  := λ α β x f, ext.2 $ by simp,
  bind_assoc := λ α β γ s f g, ext.2 $ by simp; exact
    λ c, ⟨λ ⟨b, ⟨a, as, bf⟩, cg⟩, ⟨a, as, b, bf, cg⟩,
          λ ⟨a, as, b, bf, cg⟩, ⟨b, ⟨a, as, bf⟩, cg⟩⟩,
  id_map     := λ α q, ext.2 $ by simp,
  bind_pure_comp_eq_map := λ α β f s, ext.2 $ by simp [eq_comm] }

instance : has_le (semiquot α) := ⟨λ s t, s.s ⊆ t.s⟩

instance : partial_order (semiquot α) :=
{ le := λ s t, ∀ ⦃x⦄, x ∈ s → x ∈ t,
  le_refl := λ s, set.subset.refl _,
  le_trans := λ s t u, set.subset.trans,
  le_antisymm := λ s t h₁ h₂, ext_s.2 (set.subset.antisymm h₁ h₂) }

instance : semilattice_sup (semiquot α) :=
{ sup := λ s, blur s.s,
  le_sup_left := λ s t, set.subset_union_left _ _,
  le_sup_right := λ s t, set.subset_union_right _ _,
  sup_le := λ s t u, set.union_subset,
  ..semiquot.partial_order }

@[simp] theorem pure_le {a : α} {s : semiquot α} : pure a ≤ s ↔ a ∈ s :=
set.singleton_subset_iff

/-- Assert that a `semiquot` contains only one possible value. -/
def is_pure (q : semiquot α) : Prop := ∀ a b ∈ q, a = b

/-- Extract the value from a `is_pure` semiquotient. -/
def get (q : semiquot α) (h : q.is_pure) : α := lift_on q id h

theorem get_mem {q : semiquot α} (p) : get q p ∈ q :=
let ⟨a, h⟩ := exists_mem q in
by unfold get; rw lift_on_of_mem q _ _ a h; exact h

theorem eq_pure {q : semiquot α} (p) : q = pure (get q p) :=
ext.2 $ λ a, by simp; exact
⟨λ h, p _ _ h (get_mem _), λ e, e.symm ▸ get_mem _⟩

@[simp] theorem pure_is_pure (a : α) : is_pure (pure a)
| b c ab ac := by { simp at ab ac, cc }

theorem is_pure_iff {s : semiquot α} : is_pure s ↔ ∃ a, s = pure a :=
⟨λ h, ⟨_, eq_pure h⟩, λ ⟨a, e⟩, e.symm ▸ pure_is_pure _⟩

theorem is_pure.mono {s t : semiquot α}
  (st : s ≤ t) (h : is_pure t) : is_pure s
| a b as bs := h _ _ (st as) (st bs)

theorem is_pure.min {s t : semiquot α} (h : is_pure t) : s ≤ t ↔ s = t :=
⟨λ st, le_antisymm st $ by rw [eq_pure h, eq_pure (h.mono st)]; simp;
   exact h _ _ (get_mem _) (st $ get_mem _),
 le_of_eq⟩

theorem is_pure_of_subsingleton [subsingleton α] (q : semiquot α) : is_pure q
| a b aq bq := subsingleton.elim _ _

/-- `univ : semiquot α` represents an unspecified element of `univ : set α`. -/
def univ [inhabited α] : semiquot α :=
mk $ set.mem_univ (default _)

instance [inhabited α] : inhabited (semiquot α) := ⟨univ⟩

@[simp] theorem mem_univ [inhabited α] : ∀ a, a ∈ @univ α _ :=
@set.mem_univ α

@[congr] theorem univ_unique (I J : inhabited α) : @univ _ I = @univ _ J :=
ext.2 $ by simp

@[simp] theorem is_pure_univ [inhabited α] : @is_pure α univ ↔ subsingleton α :=
⟨λ h, ⟨λ a b, h a b trivial trivial⟩, λ ⟨h⟩ a b _ _, h a b⟩

instance [inhabited α] : order_top (semiquot α) :=
{ top := univ,
  le_top := λ s, set.subset_univ _ }

end semiquot


/-
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, Mario Carneiro, Floris van Doorn
-/
import topology.bases
import topology.homeomorph
import topology.continuous_function.basic
/-!
# Open sets

## Summary

We define the subtype of open sets in a topological space.

## Main Definitions

- `opens α` is the type of open subsets of a topological space `α`.
- `open_nhds_of x` is the type of open subsets of a topological space `α` containing `x : α`.
-/

open filter set
variables {α : Type*} {β : Type*} {γ : Type*}
  [topological_space α] [topological_space β] [topological_space γ]

namespace topological_space
variable (α)
/-- The type of open subsets of a topological space. -/
def opens := {s : set α // is_open s}

variable {α}
namespace opens
instance : has_coe (opens α) (set α) := { coe := subtype.val }

lemma val_eq_coe (U : opens α) : U.1 = ↑U := rfl

/-- the coercion `opens α → set α` applied to a pair is the same as taking the first component -/
lemma coe_mk {α : Type*} [topological_space α] {U : set α} {hU : is_open U} :
  ↑(⟨U, hU⟩ : opens α) = U := rfl

instance : has_subset (opens α) :=
{ subset := λ U V, (U : set α) ⊆ V }

instance : has_mem α (opens α) :=
{ mem := λ a U, a ∈ (U : set α) }

@[simp] lemma subset_coe {U V : opens α} : ((U : set α) ⊆ (V : set α)) = (U ⊆ V) := rfl

@[simp] lemma mem_coe {x : α} {U : opens α} : (x ∈ (U : set α)) = (x ∈ U) := rfl

@[ext] lemma ext {U V : opens α} (h : (U : set α) = V) : U = V := subtype.ext_iff.mpr h

@[ext] lemma ext_iff {U V : opens α} : (U : set α) = V ↔ U = V :=
⟨opens.ext, congr_arg coe⟩

instance : partial_order (opens α) := subtype.partial_order _

/-- The interior of a set, as an element of `opens`. -/
def interior (s : set α) : opens α := ⟨interior s, is_open_interior⟩

lemma gc : galois_connection (coe : opens α → set α) interior :=
λ U s, ⟨λ h, interior_maximal h U.property, λ h, le_trans h interior_subset⟩

open order_dual (of_dual to_dual)

/-- The galois insertion between sets and opens, but ordered by reverse inclusion. -/
def gi : galois_insertion (to_dual ∘ @interior α _ ∘ of_dual) (to_dual ∘ subtype.val ∘ of_dual) :=
{ choice := λ s hs, ⟨s, interior_eq_iff_open.mp $ le_antisymm interior_subset hs⟩,
  gc := gc.dual,
  le_l_u := λ _, interior_subset,
  choice_eq := λ s hs, le_antisymm interior_subset hs }

@[simp] lemma gi_choice_val {s : order_dual (set α)} {hs} : (gi.choice s hs).val = s := rfl

instance : complete_lattice (opens α) :=
complete_lattice.copy
  (@order_dual.complete_lattice _ (galois_insertion.lift_complete_lattice (@gi α _)))
/- le  -/ (λ U V, U ⊆ V) rfl
/- top -/ ⟨set.univ, is_open_univ⟩ (subtype.ext_iff_val.mpr interior_univ.symm)
/- bot -/ ⟨∅, is_open_empty⟩ rfl
/- sup -/ (λ U V, ⟨↑U ∪ ↑V, is_open.union U.2 V.2⟩) rfl
/- inf -/ (λ U V, ⟨↑U ∩ ↑V, is_open.inter U.2 V.2⟩)
begin
  funext,
  apply subtype.ext_iff_val.mpr,
  exact (is_open.inter U.2 V.2).interior_eq.symm,
end
/- Sup -/ _ rfl
/- Inf -/ _ rfl

lemma le_def {U V : opens α} : U ≤ V ↔ (U : set α) ≤ (V : set α) :=
by refl

@[simp] lemma mk_inf_mk {U V : set α} {hU : is_open U} {hV : is_open V} :
  (⟨U, hU⟩ ⊓ ⟨V, hV⟩ : opens α) = ⟨U ⊓ V, is_open.inter hU hV⟩ := rfl
@[simp,norm_cast] lemma coe_inf {U V : opens α} :
  ((U ⊓ V : opens α) : set α) = (U : set α) ⊓ (V : set α) := rfl

instance : has_inter (opens α) := ⟨λ U V, U ⊓ V⟩
instance : has_union (opens α) := ⟨λ U V, U ⊔ V⟩
instance : has_emptyc (opens α) := ⟨⊥⟩
instance : inhabited (opens α) := ⟨∅⟩

@[simp] lemma inter_eq (U V : opens α) : U ∩ V = U ⊓ V := rfl
@[simp] lemma union_eq (U V : opens α) : U ∪ V = U ⊔ V := rfl
@[simp] lemma empty_eq : (∅ : opens α) = ⊥ := rfl

@[simp] lemma Sup_s {Us : set (opens α)} : ↑(Sup Us) = ⋃₀ ((coe : _ → set α) '' Us) :=
by { rw [(@gc α _).l_Sup, set.sUnion_image], refl }

lemma supr_def {ι} (s : ι → opens α) : (⨆ i, s i) = ⟨⋃ i, s i, is_open_Union $ λ i, (s i).2⟩ :=
by { ext, simp only [supr, opens.Sup_s, sUnion_image, bUnion_range], refl }

@[simp] lemma supr_mk {ι} (s : ι → set α) (h : Π i, is_open (s i)) :
  (⨆ i, ⟨s i, h i⟩ : opens α) = ⟨⋃ i, s i, is_open_Union h⟩ :=
by { rw supr_def, simp }

@[simp] lemma supr_s {ι} (s : ι → opens α) : ((⨆ i, s i : opens α) : set α) = ⋃ i, s i :=
by simp [supr_def]

@[simp] theorem mem_supr {ι} {x : α} {s : ι → opens α} : x ∈ supr s ↔ ∃ i, x ∈ s i :=
by { rw [←mem_coe], simp, }

@[simp] lemma mem_Sup {Us : set (opens α)} {x : α} : x ∈ Sup Us ↔ ∃ u ∈ Us, x ∈ u :=
by simp_rw [Sup_eq_supr, mem_supr]

lemma open_embedding_of_le {U V : opens α} (i : U ≤ V) :
  open_embedding (set.inclusion i) :=
{ inj := set.inclusion_injective i,
  induced := (@induced_compose _ _ _ _ (set.inclusion i) coe).symm,
  open_range :=
  begin
    rw set.range_inclusion i,
    exact U.property.preimage continuous_subtype_val
  end, }

/-- A set of `opens α` is a basis if the set of corresponding sets is a topological basis. -/
def is_basis (B : set (opens α)) : Prop := is_topological_basis ((coe : _ → set α) '' B)

lemma is_basis_iff_nbhd {B : set (opens α)} :
  is_basis B ↔ ∀ {U : opens α} {x}, x ∈ U → ∃ U' ∈ B, x ∈ U' ∧ U' ⊆ U :=
begin
  split; intro h,
  { rintros ⟨sU, hU⟩ x hx,
    rcases h.mem_nhds_iff.mp (is_open.mem_nhds hU hx)
      with ⟨sV, ⟨⟨V, H₁, H₂⟩, hsV⟩⟩,
    refine ⟨V, H₁, _⟩,
    cases V, dsimp at H₂, subst H₂, exact hsV },
  { refine is_topological_basis_of_open_of_nhds _ _,
    { rintros sU ⟨U, ⟨H₁, H₂⟩⟩, subst H₂, exact U.property },
    { intros x sU hx hsU,
      rcases @h (⟨sU, hsU⟩ : opens α) x hx with ⟨V, hV, H⟩,
      exact ⟨V, ⟨V, hV, rfl⟩, H⟩ } }
end

lemma is_basis_iff_cover {B : set (opens α)} :
  is_basis B ↔ ∀ U : opens α, ∃ Us ⊆ B, U = Sup Us :=
begin
  split,
  { intros hB U,
    refine ⟨{V : opens α | V ∈ B ∧ V ⊆ U}, λ U hU, hU.left, _⟩,
    apply ext,
    rw [Sup_s, hB.open_eq_sUnion' U.prop],
    simp_rw [sUnion_image, sUnion_eq_bUnion, Union, supr_and, supr_image],
    refl },
  { intro h,
    rw is_basis_iff_nbhd,
    intros U x hx,
    rcases h U with ⟨Us, hUs, rfl⟩,
    rcases mem_Sup.1 hx with ⟨U, Us, xU⟩,
    exact ⟨U, hUs Us, xU, le_Sup Us⟩ }
end

/-- The preimage of an open set, as an open set. -/
def comap (f : C(α, β)) : opens β →ₘ opens α :=
{ to_fun := λ V, ⟨f ⁻¹' V, V.2.preimage f.continuous⟩,
  monotone' := λ V₁ V₂ hle, monotone_preimage hle }

@[simp] lemma comap_id : comap (continuous_map.id : C(α, α)) = preorder_hom.id :=
by { ext, refl }

lemma comap_mono (f : C(α, β)) {V W : opens β} (hVW : V ⊆ W) :
  comap f V ⊆ comap f W :=
(comap f).monotone hVW

@[simp] lemma coe_comap (f : C(α, β)) (U : opens β) : ↑(comap f U) = f ⁻¹' U := rfl

@[simp] lemma comap_val (f : C(α, β)) (U : opens β) : (comap f U).1 = f ⁻¹' U := rfl

protected lemma comap_comp (g : C(β, γ)) (f : C(α, β)) :
  comap (g.comp f) = (comap f).comp (comap g) :=
rfl

protected lemma comap_comap (g : C(β, γ)) (f : C(α, β)) (U : opens γ) :
  comap f (comap g U) = comap (g.comp f) U := rfl

/-- A homeomorphism induces an equivalence on open sets, by taking comaps. -/
@[simp] protected def equiv (f : α ≃ₜ β) : opens α ≃ opens β :=
{ to_fun := opens.comap f.symm.to_continuous_map,
  inv_fun := opens.comap f.to_continuous_map,
  left_inv := by { intro U, ext1, exact f.to_equiv.preimage_symm_preimage _ },
  right_inv := by { intro U, ext1, exact f.to_equiv.symm_preimage_preimage _ } }

/-- A homeomorphism induces an order isomorphism on open sets, by taking comaps. -/
@[simp] protected def order_iso (f : α ≃ₜ β) : opens α ≃o opens β :=
{ to_equiv := opens.equiv f,
  map_rel_iff' := λ U V, f.symm.surjective.preimage_subset_preimage_iff }

end opens

/-- The open neighborhoods of a point. See also `opens` or `nhds`. -/
def open_nhds_of (x : α) : Type* := { s : set α // is_open s ∧ x ∈ s }

instance open_nhds_of.inhabited {α : Type*} [topological_space α] (x : α) :
  inhabited (open_nhds_of x) := ⟨⟨set.univ, is_open_univ, set.mem_univ _⟩⟩

end topological_space


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

! This file was ported from Lean 3 source module algebra.free_monoid.basic
! leanprover-community/mathlib commit 657df4339ae6ceada048c8a2980fb10e393143ec
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.List.BigOperators.Basic

/-!
# Free monoid over a given alphabet

## Main definitions

* `FreeMonoid α`: free monoid over alphabet `α`; defined as a synonym for `List α`
  with multiplication given by `(++)`.
* `FreeMonoid.of`: embedding `α → FreeMonoid α` sending each element `x` to `[x]`;
* `FreeMonoid.lift`: natural equivalence between `α → M` and `FreeMonoid α →* M`
* `FreeMonoid.map`: embedding of `α → β` into `FreeMonoid α →* FreeMonoid β` given by `List.map`.
-/

variable {α : Type _} {β : Type _} {γ : Type _} {M : Type _} [Monoid M] {N : Type _} [Monoid N]

/-- Free monoid over a given alphabet. -/
@[to_additive "Free nonabelian additive monoid over a given alphabet"]
def FreeMonoid (α) := List α
#align free_monoid FreeMonoid
#align free_add_monoid FreeAddMonoid

namespace FreeMonoid

-- Porting note: TODO. Check this is still needed
@[to_additive]
instance [DecidableEq α] : DecidableEq (FreeMonoid α) := instDecidableEqList

/-- The identity equivalence between `FreeMonoid α` and `List α`. -/
@[to_additive "The identity equivalence between `FreeAddMonoid α` and `List α`."]
def toList : FreeMonoid α ≃ List α := Equiv.refl _
#align free_monoid.to_list FreeMonoid.toList
#align free_add_monoid.to_list FreeAddMonoid.toList

/-- The identity equivalence between `List α` and `FreeMonoid α`. -/
@[to_additive "The identity equivalence between `List α` and `FreeAddMonoid α`."]
def ofList : List α ≃ FreeMonoid α := Equiv.refl _
#align free_monoid.of_list FreeMonoid.ofList
#align free_add_monoid.of_list FreeAddMonoid.ofList

@[to_additive (attr := simp)]
theorem toList_symm : (@toList α).symm = ofList := rfl
#align free_monoid.to_list_symm FreeMonoid.toList_symm
#align free_add_monoid.to_list_symm FreeAddMonoid.toList_symm

@[to_additive (attr := simp)]
theorem ofList_symm : (@ofList α).symm = toList := rfl
#align free_monoid.of_list_symm FreeMonoid.ofList_symm
#align free_add_monoid.of_list_symm FreeAddMonoid.ofList_symm

@[to_additive (attr := simp)]
theorem toList_ofList (l : List α) : toList (ofList l) = l := rfl
#align free_monoid.to_list_of_list FreeMonoid.toList_ofList
#align free_add_monoid.to_list_of_list FreeAddMonoid.toList_ofList

@[to_additive (attr := simp)]
theorem ofList_toList (xs : FreeMonoid α) : ofList (toList xs) = xs := rfl
#align free_monoid.of_list_to_list FreeMonoid.ofList_toList
#align free_add_monoid.of_list_to_list FreeAddMonoid.ofList_toList

@[to_additive (attr := simp)]
theorem toList_comp_ofList : @toList α ∘ ofList = id := rfl
#align free_monoid.to_list_comp_of_list FreeMonoid.toList_comp_ofList
#align free_add_monoid.to_list_comp_of_list FreeAddMonoid.toList_comp_ofList

@[to_additive (attr := simp)]
theorem ofList_comp_toList : @ofList α ∘ toList = id := rfl
#align free_monoid.of_list_comp_to_list FreeMonoid.ofList_comp_toList
#align free_add_monoid.of_list_comp_to_list FreeAddMonoid.ofList_comp_toList

@[to_additive]
instance : CancelMonoid (FreeMonoid α)
    where
  one := ofList []
  mul x y := ofList (toList x ++ toList y)
  mul_one := List.append_nil
  one_mul := List.nil_append
  mul_assoc := List.append_assoc
  mul_left_cancel _ _ _ := List.append_left_cancel
  mul_right_cancel _ _ _ := List.append_right_cancel

@[to_additive]
instance : Inhabited (FreeMonoid α) := ⟨1⟩

@[to_additive (attr := simp)]
theorem toList_one : toList (1 : FreeMonoid α) = [] := rfl
#align free_monoid.to_list_one FreeMonoid.toList_one
#align free_add_monoid.to_list_zero FreeAddMonoid.toList_zero

@[to_additive (attr := simp)]
theorem ofList_nil : ofList ([] : List α) = 1 := rfl
#align free_monoid.of_list_nil FreeMonoid.ofList_nil
#align free_add_monoid.of_list_nil FreeAddMonoid.ofList_nil

@[to_additive (attr := simp)]
theorem toList_mul (xs ys : FreeMonoid α) : toList (xs * ys) = toList xs ++ toList ys := rfl
#align free_monoid.to_list_mul FreeMonoid.toList_mul
#align free_add_monoid.to_list_add FreeAddMonoid.toList_add

@[to_additive (attr := simp)]
theorem ofList_append (xs ys : List α) : ofList (xs ++ ys) = ofList xs * ofList ys := rfl
#align free_monoid.of_list_append FreeMonoid.ofList_append
#align free_add_monoid.of_list_append FreeAddMonoid.ofList_append

@[to_additive (attr := simp)]
theorem toList_prod (xs : List (FreeMonoid α)) : toList xs.prod = (xs.map toList).join := by
  induction xs <;> simp [*, List.join]
#align free_monoid.to_list_prod FreeMonoid.toList_prod
#align free_add_monoid.to_list_sum FreeAddMonoid.toList_sum

@[to_additive (attr := simp)]
theorem ofList_join (xs : List (List α)) : ofList xs.join = (xs.map ofList).prod :=
  toList.injective <| by simp
#align free_monoid.of_list_join FreeMonoid.ofList_join
#align free_add_monoid.of_list_join FreeAddMonoid.ofList_join

/-- Embeds an element of `α` into `FreeMonoid α` as a singleton list. -/
@[to_additive "Embeds an element of `α` into `FreeAddMonoid α` as a singleton list."]
def of (x : α) : FreeMonoid α := ofList [x]
#align free_monoid.of FreeMonoid.of
#align free_add_monoid.of FreeAddMonoid.of

@[to_additive (attr := simp)]
theorem toList_of (x : α) : toList (of x) = [x] := rfl
#align free_monoid.to_list_of FreeMonoid.toList_of
#align free_add_monoid.to_list_of FreeAddMonoid.toList_of

@[to_additive]
theorem ofList_singleton (x : α) : ofList [x] = of x := rfl
#align free_monoid.of_list_singleton FreeMonoid.ofList_singleton
#align free_add_monoid.of_list_singleton FreeAddMonoid.ofList_singleton

@[to_additive (attr := simp)]
theorem ofList_cons (x : α) (xs : List α) : ofList (x :: xs) = of x * ofList xs := rfl
#align free_monoid.of_list_cons FreeMonoid.ofList_cons
#align free_add_monoid.of_list_cons FreeAddMonoid.ofList_cons

@[to_additive]
theorem toList_of_mul (x : α) (xs : FreeMonoid α) : toList (of x * xs) = x :: toList xs := rfl
#align free_monoid.to_list_of_mul FreeMonoid.toList_of_mul
#align free_add_monoid.to_list_of_add FreeAddMonoid.toList_of_add

@[to_additive]
theorem of_injective : Function.Injective (@of α) := List.singleton_injective
#align free_monoid.of_injective FreeMonoid.of_injective
#align free_add_monoid.of_injective FreeAddMonoid.of_injective

/-- Recursor for `FreeMonoid` using `1` and `FreeMonoid.of x * xs` instead of `[]` and `x :: xs`. -/
@[to_additive (attr := elab_as_elim) "Recursor for `FreeAddMonoid` using `0` and
`FreeAddMonoid.of x + xs` instead of `[]` and `x :: xs`."]
-- Porting note: change from `List.recOn` to `List.rec` since only the latter is computable
def recOn {C : FreeMonoid α → Sort _} (xs : FreeMonoid α) (h0 : C 1)
    (ih : ∀ x xs, C xs → C (of x * xs)) : C xs := List.rec h0 ih xs
#align free_monoid.rec_on FreeMonoid.recOn
#align free_add_monoid.rec_on FreeAddMonoid.recOn

@[to_additive (attr := simp)]
theorem recOn_one {C : FreeMonoid α → Sort _} (h0 : C 1) (ih : ∀ x xs, C xs → C (of x * xs)) :
    @recOn α C 1 h0 ih = h0 := rfl
#align free_monoid.rec_on_one FreeMonoid.recOn_one
#align free_add_monoid.rec_on_zero FreeAddMonoid.recOn_zero

@[to_additive (attr := simp)]
theorem recOn_of_mul {C : FreeMonoid α → Sort _} (x : α) (xs : FreeMonoid α) (h0 : C 1)
    (ih : ∀ x xs, C xs → C (of x * xs)) : @recOn α C (of x * xs) h0 ih = ih x xs (recOn xs h0 ih) :=
  rfl
#align free_monoid.rec_on_of_mul FreeMonoid.recOn_of_mul
#align free_add_monoid.rec_on_of_add FreeAddMonoid.recOn_of_add

/-- A version of `List.cases_on` for `FreeMonoid` using `1` and `FreeMonoid.of x * xs` instead of
`[]` and `x :: xs`. -/
@[to_additive (attr := elab_as_elim) "A version of `List.casesOn` for `FreeAddMonoid` using `0` and
`FreeAddMonoid.of x + xs` instead of `[]` and `x :: xs`."]
def casesOn {C : FreeMonoid α → Sort _} (xs : FreeMonoid α) (h0 : C 1)
    (ih : ∀ x xs, C (of x * xs)) : C xs := List.casesOn xs h0 ih
#align free_monoid.cases_on FreeMonoid.casesOn
#align free_add_monoid.cases_on FreeAddMonoid.casesOn

@[to_additive (attr := simp)]
theorem casesOn_one {C : FreeMonoid α → Sort _} (h0 : C 1) (ih : ∀ x xs, C (of x * xs)) :
    @casesOn α C 1 h0 ih = h0 := rfl
#align free_monoid.cases_on_one FreeMonoid.casesOn_one
#align free_add_monoid.cases_on_zero FreeAddMonoid.casesOn_zero

@[to_additive (attr := simp)]
theorem casesOn_of_mul {C : FreeMonoid α → Sort _} (x : α) (xs : FreeMonoid α) (h0 : C 1)
    (ih : ∀ x xs, C (of x * xs)) : @casesOn α C (of x * xs) h0 ih = ih x xs := rfl
#align free_monoid.cases_on_of_mul FreeMonoid.casesOn_of_mul
#align free_add_monoid.cases_on_of_add FreeAddMonoid.casesOn_of_add

@[to_additive (attr := ext)]
theorem hom_eq ⦃f g : FreeMonoid α →* M⦄ (h : ∀ x, f (of x) = g (of x)) : f = g :=
  MonoidHom.ext fun l ↦ recOn l (f.map_one.trans g.map_one.symm)
    (fun x xs hxs ↦ by  simp only [h, hxs, MonoidHom.map_mul])
#align free_monoid.hom_eq FreeMonoid.hom_eq
#align free_add_monoid.hom_eq FreeAddMonoid.hom_eq

/-- A variant of `List.prod` that has `[x].prod = x` true definitionally.
The purpose is to make `FreeMonoid.lift_eval_of` true by `rfl`. -/
@[to_additive "A variant of `List.sum` that has `[x].sum = x` true definitionally.
The purpose is to make `FreeAddMonoid.lift_eval_of` true by `rfl`."]
def prodAux {M} [Monoid M] : List M → M
  | []  => 1
  | (x :: xs) => List.foldl (· * ·) x xs
#align free_monoid.prod_aux FreeMonoid.prodAux
#align free_add_monoid.sum_aux FreeAddMonoid.sumAux

@[to_additive]
lemma prodAux_eq : ∀ l : List M, FreeMonoid.prodAux l = l.prod
  | []  => rfl
  | (_ :: xs) => congr_arg (fun x => List.foldl (· * ·) x xs) (one_mul _).symm
#align free_monoid.prod_aux_eq FreeMonoid.prodAux_eq
#align free_add_monoid.sum_aux_eq FreeAddMonoid.sumAux_eq

/-- Equivalence between maps `α → M` and monoid homomorphisms `FreeMonoid α →* M`. -/
@[to_additive "Equivalence between maps `α → A` and additive monoid homomorphisms
`FreeAddMonoid α →+ A`."]
def lift : (α → M) ≃ (FreeMonoid α →* M) where
  toFun f :=
  { toFun := fun l ↦ prodAux ((toList l).map f)
    map_one' := rfl
    map_mul' := fun _ _ ↦ by simp only [prodAux_eq, toList_mul, List.map_append, List.prod_append] }
  invFun f x := f (of x)
  left_inv f := rfl
  right_inv f := hom_eq fun x ↦ rfl
#align free_monoid.lift FreeMonoid.lift
#align free_add_monoid.lift FreeAddMonoid.lift

-- porting note: new
@[to_additive (attr := simp)]
theorem lift_ofList (f : α → M) (l : List α) : lift f (ofList l) = (l.map f).prod :=
prodAux_eq _

@[to_additive (attr := simp)]
theorem lift_symm_apply (f : FreeMonoid α →* M) : lift.symm f = f ∘ of := rfl
#align free_monoid.lift_symm_apply FreeMonoid.lift_symm_apply
#align free_add_monoid.lift_symm_apply FreeAddMonoid.lift_symm_apply

@[to_additive]
theorem lift_apply (f : α → M) (l : FreeMonoid α) : lift f l = ((toList l).map f).prod :=
prodAux_eq _
#align free_monoid.lift_apply FreeMonoid.lift_apply
#align free_add_monoid.lift_apply FreeAddMonoid.lift_apply

@[to_additive]

@[to_additive (attr := simp)]
theorem lift_eval_of (f : α → M) (x : α) : lift f (of x) = f x := rfl
#align free_monoid.lift_eval_of FreeMonoid.lift_eval_of
#align free_add_monoid.lift_eval_of FreeAddMonoid.lift_eval_of

@[to_additive (attr := simp)]
theorem lift_restrict (f : FreeMonoid α →* M) : lift (f ∘ of) = f := lift.apply_symm_apply f
#align free_monoid.lift_restrict FreeMonoid.lift_restrict
#align free_add_monoid.lift_restrict FreeAddMonoid.lift_restrict

@[to_additive]
theorem comp_lift (g : M →* N) (f : α → M) : g.comp (lift f) = lift (g ∘ f) :=
-- Porting note: replace ext by FreeMonoid.hom_eq
  FreeMonoid.hom_eq (by simp)
#align free_monoid.comp_lift FreeMonoid.comp_lift
#align free_add_monoid.comp_lift FreeAddMonoid.comp_lift

@[to_additive]
theorem hom_map_lift (g : M →* N) (f : α → M) (x : FreeMonoid α) : g (lift f x) = lift (g ∘ f) x :=
  FunLike.ext_iff.1 (comp_lift g f) x
#align free_monoid.hom_map_lift FreeMonoid.hom_map_lift
#align free_add_monoid.hom_map_lift FreeAddMonoid.hom_map_lift

/-- Define a multiplicative action of `FreeMonoid α` on `β`. -/
@[to_additive "Define an additive action of `FreeAddMonoid α` on `β`."]
def mkMulAction (f : α → β → β) : MulAction (FreeMonoid α) β where
  smul l b := l.toList.foldr f b
  one_smul _ := rfl
  mul_smul _ _ _ := List.foldr_append _ _ _ _
#align free_monoid.mk_mul_action FreeMonoid.mkMulAction
#align free_add_monoid.mk_add_action FreeAddMonoid.mkAddAction

@[to_additive]
theorem smul_def (f : α → β → β) (l : FreeMonoid α) (b : β) :
    haveI := mkMulAction f
    l • b = l.toList.foldr f b := rfl
#align free_monoid.smul_def FreeMonoid.smul_def
#align free_add_monoid.vadd_def FreeAddMonoid.vadd_def

@[to_additive]
theorem ofList_smul (f : α → β → β) (l : List α) (b : β) :
    haveI := mkMulAction f
    ofList l • b = l.foldr f b := rfl
#align free_monoid.of_list_smul FreeMonoid.ofList_smul
#align free_add_monoid.of_list_vadd FreeAddMonoid.ofList_vadd

@[to_additive (attr := simp)]
theorem of_smul (f : α → β → β) (x : α) (y : β) :
    (haveI := mkMulAction f
    of x • y) = f x y := rfl
#align free_monoid.of_smul FreeMonoid.of_smul
#align free_add_monoid.of_vadd FreeAddMonoid.of_vadd

/-- The unique monoid homomorphism `FreeMonoid α →* FreeMonoid β` that sends
each `of x` to `of (f x)`. -/
@[to_additive "The unique additive monoid homomorphism `FreeAddMonoid α →+ FreeAddMonoid β`
that sends each `of x` to `of (f x)`."]
def map (f : α → β) : FreeMonoid α →* FreeMonoid β
    where
  toFun l := ofList <| l.toList.map f
  map_one' := rfl
  map_mul' _ _ := List.map_append _ _ _
#align free_monoid.map FreeMonoid.map
#align free_add_monoid.map FreeAddMonoid.map

@[to_additive (attr := simp)]
theorem map_of (f : α → β) (x : α) : map f (of x) = of (f x) := rfl
#align free_monoid.map_of FreeMonoid.map_of
#align free_add_monoid.map_of FreeAddMonoid.map_of

@[to_additive]
theorem toList_map (f : α → β) (xs : FreeMonoid α) : toList (map f xs) = xs.toList.map f := rfl
#align free_monoid.to_list_map FreeMonoid.toList_map
#align free_add_monoid.to_list_map FreeAddMonoid.toList_map

@[to_additive]
theorem ofList_map (f : α → β) (xs : List α) : ofList (xs.map f) = map f (ofList xs) := rfl
#align free_monoid.of_list_map FreeMonoid.ofList_map
#align free_add_monoid.of_list_map FreeAddMonoid.ofList_map

@[to_additive]
theorem lift_of_comp_eq_map (f : α → β) : (lift fun x ↦ of (f x)) = map f := hom_eq fun _ ↦ rfl
#align free_monoid.lift_of_comp_eq_map FreeMonoid.lift_of_comp_eq_map
#align free_add_monoid.lift_of_comp_eq_map FreeAddMonoid.lift_of_comp_eq_map

@[to_additive]
theorem map_comp (g : β → γ) (f : α → β) : map (g ∘ f) = (map g).comp (map f) := hom_eq fun _ ↦ rfl
#align free_monoid.map_comp FreeMonoid.map_comp
#align free_add_monoid.map_comp FreeAddMonoid.map_comp

@[to_additive (attr := simp)]
theorem map_id : map (@id α) = MonoidHom.id (FreeMonoid α) := hom_eq fun _ ↦ rfl
#align free_monoid.map_id FreeMonoid.map_id
#align free_add_monoid.map_id FreeAddMonoid.map_id

end FreeMonoid


/-
Copyright (c) 2020 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Yury G. Kudryashov
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.list.sort
import Mathlib.data.fin
import Mathlib.PostPort

universes u_1

namespace Mathlib

/-!
# Isomorphism between `fin (length l)` and `{x // x ∈ l}`

Given a list `l,

* if `l` has no duplicates, then `list.nodup.nth_le_equiv` is the bijection between `fin (length l)`
  and `{x // x ∈ l}` sending `⟨i, hi⟩` to `⟨nth_le l i hi, _⟩` with the inverse sending `⟨x, hx⟩` to
  `⟨index_of x l, _⟩`;

* if `l` is sorted w.r.t. `(<)`, then `list.sorted.nth_le_iso` is the same bijection reinterpreted
  as an `order_iso`.

-/

namespace list

namespace nodup

/-- If `l` has no duplicates, then `list.nth_le` defines a bijection between `fin (length l)` and
the set of elements of `l`. -/
def nth_le_equiv {α : Type u_1} [DecidableEq α] (l : List α) (H : nodup l) :
    fin (length l) ≃ Subtype fun (x : α) => x ∈ l :=
  equiv.mk (fun (i : fin (length l)) => { val := nth_le l ↑i sorry, property := sorry })
    (fun (x : Subtype fun (x : α) => x ∈ l) => { val := index_of (↑x) l, property := sorry }) sorry
    sorry

@[simp] theorem coe_nth_le_equiv_apply {α : Type u_1} [DecidableEq α] {l : List α} (H : nodup l)
    (i : fin (length l)) : ↑(coe_fn (nth_le_equiv l H) i) = nth_le l (↑i) (subtype.property i) :=
  rfl

@[simp] theorem coe_nth_le_equiv_symm_apply {α : Type u_1} [DecidableEq α] {l : List α}
    (H : nodup l) (x : Subtype fun (x : α) => x ∈ l) :
    ↑(coe_fn (equiv.symm (nth_le_equiv l H)) x) = index_of (↑x) l :=
  rfl

end nodup

namespace sorted

theorem nth_le_mono {α : Type u_1} [preorder α] {l : List α} (h : sorted LessEq l) :
    monotone fun (i : fin (length l)) => nth_le l (↑i) (subtype.property i) :=
  fun (i j : fin (length l)) => nth_le_of_sorted_of_le h

theorem nth_le_strict_mono {α : Type u_1} [preorder α] {l : List α} (h : sorted Less l) :
    strict_mono fun (i : fin (length l)) => nth_le l (↑i) (subtype.property i) :=
  fun (i j : fin (length l)) => iff.mp pairwise_iff_nth_le h (↑i) (↑j) (subtype.property j)

/-- If `l` is a list sorted w.r.t. `(<)`, then `list.nth_le` defines an order isomorphism between
`fin (length l)` and the set of elements of `l`. -/
def nth_le_iso {α : Type u_1} [preorder α] [DecidableEq α] (l : List α) (H : sorted Less l) :
    fin (length l) ≃o Subtype fun (x : α) => x ∈ l :=
  rel_iso.mk (nodup.nth_le_equiv l sorry) sorry

@[simp] theorem coe_nth_le_iso_apply {α : Type u_1} [preorder α] {l : List α} [DecidableEq α]
    (H : sorted Less l) {i : fin (length l)} :
    ↑(coe_fn (nth_le_iso l H) i) = nth_le l (↑i) (subtype.property i) :=
  rfl

@[simp] theorem coe_nth_le_iso_symm_apply {α : Type u_1} [preorder α] {l : List α} [DecidableEq α]
    (H : sorted Less l) {x : Subtype fun (x : α) => x ∈ l} :
    ↑(coe_fn (order_iso.symm (nth_le_iso l H)) x) = index_of (↑x) l :=
  rfl

end Mathlib


-- import .arity .list .logic
-- import .list
import .simp_fol

open tactic

variables {α β : Type}

structure model (α : Type) :=
(funcs : nat → list α → α)
(rels : nat → list α → Prop)

def func.default [inhabited α] (as : list α) : α :=
@inhabited.default _ _

def rel.default (as : list α) : Prop := false

def model.default [inhabited α] : model α :=
{ funcs := λ _, func.default,
  rels  := λ _, rel.default }

def cons (a : α) (f : nat → α) : nat → α
| 0     := a
| (k+1) := f k

notation a `::` f := cons a f

def model.cons_func (f : list α → α) (M : model α) : model α :=
{M with funcs := f::M.funcs, rels := rel.default::M.rels}

notation f `:f:` M := M.cons_func f

def model.cons_rel [inhabited α] (r : list α → Prop) (M : model α) : model α :=
{M with funcs := func.default::M.funcs, rels := r::M.rels}

notation r `:r:` M := M.cons_rel r

@[derive has_reflect]
inductive term : Type
| var : nat → term
| fnc : nat → term
| app : term → term → term

notation  `#` := term.var
notation  `&` := term.fnc
notation  t1 `^*` t2 := term.app t1 t2

-- | (# k) :=
-- | (& k) :=
-- | (t1 ^* t2) :=

namespace term

meta def to_string : term → string
| (# k) := "#" ++ (to_fmt k).to_string
| (& k) := "&" ++ (to_fmt k).to_string
| (t1 ^* t2) := "(" ++ t1.to_string ++ " " ++ t2.to_string ++ ")"

meta instance has_repr : has_repr term := ⟨to_string⟩

@[fol] def max_idx_lt (k) : term → Prop
| (# m)      := m < k
| (& _)      := true
| (t1 ^* t2) := t1.max_idx_lt ∧ t2.max_idx_lt

instance dec_max_idx_lt : ∀ k t, decidable (max_idx_lt k t) :=
begin
  intros k t, induction t;
  simp_fol, repeat {apply_instance},
  apply @and.decidable _ _ _ _; assumption
end

@[fol] def val_core (M : model α) (v : nat → α) : term → list α → α
| (# k)      _  := v k
| (& k)      as := M.funcs k as
| (t1 ^* t2) as := t1.val_core (t2.val_core []::as)

@[fol] def val (M v t) : α := val_core M v t []

lemma val_core_eq_val_core_of_max_idx_lt :
  ∀ M (v w : nat → α) t as k, max_idx_lt k t →
  (∀ m < k, v m = w m) → (val_core M v t as) = (val_core M w t as)
| M v w (# k) as m h1 h2 := begin simp_fol, apply h2 _ h1 end
| M v w (& k) as m h1 h2 := by simp_fol
| M v w (t1 ^* t2) as m h1 h2 :=
  begin
    simp_fol, cases h1,
    repeat {rw (val_core_eq_val_core_of_max_idx_lt M v w _ _ m)};
    assumption
  end

lemma val_eq_val_of_max_idx_lt (M) (v w : nat → α) (t k) :
  max_idx_lt k t → (∀ m < k, v m = w m) → (val M v t) = (val M w t) :=
val_core_eq_val_core_of_max_idx_lt M v w t [] k

def fv (k : nat) : term → list nat
| (# m)      := if k ≤ m then [m] else []
| (& _)      := []
| (t1 ^* t2) := (fv t1) ∪ (fv t2)

def fresh_func_idx : term → nat
| (# k)      := 0
| (& k)      := k + 1
| (t1 ^* t2) := max (fresh_func_idx t1) (fresh_func_idx t2)

def subst (m s) : term → term
| (# k)      := if k = m then s else (# k)
| (& k)      := (& k)
| (t1 ^* t2) := (subst t1) ^* (subst t2)

def incr_vdx : term → term
| (# k)      := # (k+1)
| (& k)      := (& k)
| (t1 ^* t2) := t1.incr_vdx ^* t2.incr_vdx

end term


/-
Copyright (c) 2021 Ashvni Narayanan. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Ashvni Narayanan
-/
import dirichlet_character.teichmuller_character
/-!
# Properties of norm
This file describes some properties of norm that are used in proofs of theorems such as `sum_even_character_tendsto_zero`.
-/
open_locale big_operators
open dirichlet_character zmod
variables (p : nat) {d m : nat} [fact (nat.prime p)] (R : Type*) [normed_comm_ring R] (χ : dirichlet_character R (d * p^m))

lemma norm_int_le_one [normed_algebra ℚ_[p] R] [norm_one_class R] (z : ℤ) : ∥(z : R)∥ ≤ 1 :=
begin
  rw [← ring_hom.map_int_cast (algebra_map ℚ_[p] R), ←padic_int.coe_coe_int,
    norm_algebra_map, norm_one_class.norm_one, mul_one],
  apply padic_int.norm_le_one,
end

variables {p R χ}
lemma norm_sum_le_smul {k : ℕ} [normed_algebra ℚ_[p] R] [norm_one_class R] (hk : 1 < k) {x : ℕ}
  (na : ∀ (n : ℕ) (f : ℕ → R), ∥ ∑ (i : ℕ) in finset.range n, f i∥ ≤ ⨆ (i : zmod n), ∥f i.val∥) :
  ∥∑ (y : ℕ) in finset.range (d * p ^ x + 1), (asso_dirichlet_character
  (χ.mul (teichmuller_character_mod_p' p R ^ k))) ((-1) * ↑y) *
  ∑ (x_1 : ℕ) in finset.range (k - 1), ↑(d * p ^ x) ^ x_1 * ((-1) * ↑y) ^ (k - 1 - (x_1 + 1)) *
  ↑((k - 1).choose (x_1 + 1))∥ ≤ (dirichlet_character.bound
  (χ.mul (teichmuller_character_mod_p' p R ^ k)) * (k - 1)) :=
begin
  have : ∀ y ∈ finset.range (d * p ^ x + 1), ∥(asso_dirichlet_character
    (χ.mul (teichmuller_character_mod_p' p R ^ k))) ((-1) * ↑y) *
    ∑ (x_1 : ℕ) in finset.range (k - 1), ↑(d * p ^ x) ^ x_1 * ((-1) * ↑y)^(k - 1 - (x_1 + 1)) *
    ↑((k - 1).choose (x_1 + 1)) ∥ ≤ (dirichlet_character.bound (χ.mul
    (teichmuller_character_mod_p' p R ^ k))) * (k - 1),
  { intros l hl,
    refine le_trans (norm_mul_le _ _) (mul_le_mul (le_of_lt (dirichlet_character.lt_bound _ _)) _
      (norm_nonneg _) (le_of_lt (dirichlet_character.bound_pos _))),
    simp_rw [mul_pow, mul_left_comm, mul_assoc],
    apply le_trans (norm_sum_le _ _) _,
    have : ∀ a ∈ finset.range (k - 1), ∥(-1 : R) ^ (k - 1 - (a + 1)) * (↑(d * p ^ x) ^ a *
      (↑l ^ (k - 1 - (a + 1)) * ↑((k - 1).choose (a + 1))))∥ ≤ 1,
    { intros a ha,
      rw [←int.cast_one, ←int.cast_neg, ←int.cast_pow],
      simp_rw [←nat.cast_pow, ←nat.cast_mul, ←int.cast_coe_nat, ←int.cast_mul],
      apply norm_int_le_one p R, },
    refine le_trans (finset.sum_le_sum this) _,
    rw [finset.sum_const, finset.card_range, nat.smul_one_eq_coe, nat.cast_sub (le_of_lt hk),
      nat.cast_one], },
  refine le_trans (na _ _) (cSup_le (set.range_nonempty _)
    (λ b ⟨y, hy⟩, hy ▸ this y.val (finset.mem_range.2 (zmod.val_lt _)))),
end

variables (p d R)
-- `coe_eq_ring_hom_map` replaced with `nat_coe_eq_ring_hom_map`
lemma nat_coe_eq_ring_hom_map [normed_algebra ℚ_[p] R] (y : ℕ) :
  (algebra_map ℚ_[p] R) (padic_int.coe.ring_hom (y : ℤ_[p])) = ((y : ℕ) : R) := by { simp }

-- `norm_coe_eq_ring_hom_map` replaced with `norm_coe_nat_eq_norm_ring_hom_map`
lemma norm_coe_nat_eq_norm_ring_hom_map [normed_algebra ℚ_[p] R]  [norm_one_class R] (y : ℕ) :
  ∥((y : ℕ) : R)∥ = ∥padic_int.coe.ring_hom (y : ℤ_[p])∥ :=
by { rw [←nat_coe_eq_ring_hom_map p R y, norm_algebra_map, norm_one_class.norm_one, mul_one], }

lemma norm_mul_pow_le_one_div_pow [normed_algebra ℚ_[p] R] [norm_one_class R] (y : ℕ) :
  ∥((d * p^y : ℕ) : R)∥ ≤ 1 / p^y :=
begin
  rw nat.cast_mul,
  apply le_trans (norm_mul_le _ _) _,
  rw ← one_mul (1 / (p : ℝ)^y),
  apply mul_le_mul _ _ (norm_nonneg _) zero_le_one,
  { rw norm_coe_nat_eq_norm_ring_hom_map p,
    apply padic_int.norm_le_one,  },
  { apply le_of_eq,
    rw norm_coe_nat_eq_norm_ring_hom_map p,
    simp only [one_div, map_nat_cast, norm_pow, ring_hom.map_pow, inv_pow,
      nat.cast_pow, padic_norm_e.norm_p], },
end

variables {p d R}
-- `norm_mul_two_le_one` replaced with `hlper_7`
lemma helper_7 [normed_algebra ℚ_[p] R] [norm_one_class R] (k : ℕ) (y : ℕ) :
  ∥((d * p ^ y : ℕ) : R) ^ (k - 2) * (1 + 1)∥ ≤ 1 :=
begin
  rw [←nat.cast_pow, ←@nat.cast_one R _ _, ←nat.cast_add, ←nat.cast_mul,
    norm_coe_nat_eq_norm_ring_hom_map p],
  apply padic_int.norm_le_one _,
end

-- `sub_add_norm_nonneg` replaced with `helper_8`
lemma helper_8 {k : ℕ} (hk : 1 < k) (n : ℕ) :
  0 ≤ (k : ℝ) - 1 + ∥(n : R) ^ (k - 2) * (1 + 1)∥ :=
begin
  apply add_nonneg _ (norm_nonneg _),
  rw [le_sub_iff_add_le, zero_add],
  norm_cast,
  apply le_of_lt hk,
end

-- `norm_two_mul_le` replaced with `helper_9`
lemma helper_9 [normed_algebra ℚ_[p] R] [norm_one_class R] {k : ℕ} (hk : 1 < k) (hp : 2 < p)
  (y : ℕ) : ∥(2⁻¹ : ℚ_[p])∥ * (↑k - 1 + ∥((d * p ^ y : ℕ) : R) ^ (k - 2) * (1 + 1)∥) ≤ k :=
begin
  rw ← one_mul ↑k,
  apply mul_le_mul (le_of_eq _) _ _ _,
  { rw [norm_inv, inv_eq_one],
    have : ((2 : ℕ) : ℚ_[p]) = (2 : ℚ_[p]), norm_cast,
    rw [←this, ←rat.cast_coe_nat, padic_norm_e.eq_padic_norm,
      padic_norm.padic_norm_of_prime_of_ne (λ h, ne_of_lt hp h.symm), rat.cast_one], },
  { rw one_mul,
    apply le_trans (add_le_add le_rfl (helper_7 k _)) _,
    any_goals { apply_instance, }, --why is this a problem?
    rw sub_add_cancel, },
  { rw one_mul,
    convert helper_8 hk _, },
  { linarith, },
end

variables (p R) {χ}
-- `norm_mul_eq` replaced with `norm_mul_nat_eq_mul_norm`
lemma norm_mul_nat_eq_mul_norm [normed_algebra ℚ_[p] R] [norm_one_class R] (x y : ℕ) :
  ∥(x * y : R)∥ = ∥(x : R)∥ * ∥(y : R)∥ :=
by { rw [←nat.cast_mul, norm_coe_nat_eq_norm_ring_hom_map p, nat.cast_mul,
  ring_hom.map_mul padic_int.coe.ring_hom, padic_norm_e.mul, ←norm_coe_nat_eq_norm_ring_hom_map p R,
  ←norm_coe_nat_eq_norm_ring_hom_map p R], }

-- `norm_pow_eq` replaced with `norm_pow_nat_eq_pow_norm`
lemma norm_pow_nat_eq_pow_norm [normed_algebra ℚ_[p] R] [norm_one_class R] (x n : ℕ) :
  ∥(x ^ n : R)∥ = ∥(x : R)∥^n :=
by { rw [←nat.cast_pow, norm_coe_nat_eq_norm_ring_hom_map p, nat.cast_pow, ring_hom.map_pow,
  norm_pow, ← norm_coe_nat_eq_norm_ring_hom_map p R], }

-- `norm_le_of_ge` replaced with `norm_mul_prime_pow_le_of_ge`
lemma norm_mul_prime_pow_le_of_ge [normed_algebra ℚ_[p] R] [norm_one_class R] {x y : ℕ}
  (h : x ≤ y) : ∥((d * p^y : ℕ) : R)∥ ≤ ∥((d * p^x : ℕ) : R)∥ :=
begin
  simp_rw [nat.cast_mul, norm_mul_nat_eq_mul_norm p R, nat.cast_pow],
  apply mul_le_mul le_rfl _ (norm_nonneg _) (norm_nonneg _),
  simp_rw [norm_pow_nat_eq_pow_norm p R, norm_coe_nat_eq_norm_ring_hom_map p],
  simp only [map_nat_cast, norm_pow, ring_hom.map_pow, inv_pow, nat.cast_pow, padic_norm_e.norm_p],
  rw inv_le_inv _ _,
  { refine pow_le_pow (nat.one_le_cast.2 (le_of_lt (nat.prime.one_lt (fact.out _)))) h, },
  any_goals { norm_cast, apply pow_pos _ _, apply nat.prime.pos _, apply fact.out, },
end

variable {R}
lemma norm_asso_dir_char_bound [normed_algebra ℚ_[p] R] [fact (0 < m)] (k : ℕ) (x : ℕ) :
  ⨆ (i : zmod (d * p ^ x)), ∥(asso_dirichlet_character (χ.mul
  (teichmuller_character_mod_p_change_level p R m d ^ k))) ↑(i.val.succ)∥ <
  dirichlet_character.bound (χ.mul (teichmuller_character_mod_p_change_level p R m d ^ k)) :=
begin
  rw supr_Prop_eq,
  refine ⟨0, dirichlet_character.lt_bound _ _⟩,
end

lemma norm_lim_eq_zero [normed_algebra ℚ_[p] R] [norm_one_class R] (k : R) :
  filter.tendsto (λ n : ℕ, (((d * p^n) : ℕ) : R) * k) (filter.at_top) (nhds 0) :=
begin
  by_cases k = 0,
  { rw h, simp only [mul_zero], exact tendsto_const_nhds, },
  { rw metric.tendsto_at_top,
    rintros ε hε,
    have f : 0 < ∥k∥⁻¹,
    { rw inv_pos, rw norm_pos_iff, apply h, },
    have f1 : 0 < ∥k∥⁻¹ * ε,
    { apply mul_pos f hε, },
    have f2 : 1/(p : ℝ) < 1,
    { rw one_div_lt _ _,
      { rw one_div_one, norm_cast, apply nat.prime.one_lt, apply fact.out, },
      { norm_cast, apply nat.prime.pos, apply fact.out, },
      { norm_num, }, },
    have f3 : 0 ≤ 1 / (p : ℝ),
    { apply div_nonneg _ _,
      any_goals { norm_cast, apply nat.zero_le _, }, },
    refine ⟨classical.some (exists_pow_lt_of_lt_one f1 f2), λ n hn, _⟩,
    rw dist_eq_norm, rw sub_zero,
    apply lt_of_le_of_lt (norm_mul_le _ _) _,
    apply lt_of_le_of_lt (mul_le_mul (norm_mul_pow_le_one_div_pow p d R n) le_rfl (norm_nonneg _) _) _,
    --{ apply_instance, },
    --{ apply_instance, },
    { rw ← one_div_pow, apply pow_nonneg f3 _, },
    rw ← inv_inv (∥k∥),
    rw mul_inv_lt_iff f,
    { rw ← one_div_pow,
      apply lt_of_le_of_lt (pow_le_pow_of_le_one f3 (le_of_lt f2) hn) _,
      apply classical.some_spec (exists_pow_lt_of_lt_one f1 f2), }, },
end

lemma norm_lim_eq_zero' [normed_algebra ℚ_[p] R] [norm_one_class R] {ε : ℝ} (hε : 0 < ε) {k : ℝ} (hk : 0 ≤ k) :
  ∃ n : ℕ, ∀ x ≥ n, ∥((d * p^x : ℕ) : R)∥ * k < ε :=
begin
  by_cases k = 0,
  { rw h, simp only [mul_zero, hε], simp only [implies_true_iff, exists_const], },
  { have f : 0 < k⁻¹,
    { rw inv_pos, apply lt_of_le_of_ne hk (ne_comm.1 h), },
    have f1 : 0 < k⁻¹ * ε,
    { apply mul_pos f hε, },
    have f2 : 1/(p : ℝ) < 1,
    { rw one_div_lt _ _,
      { rw one_div_one, norm_cast, apply nat.prime.one_lt, apply fact.out, },
      { norm_cast, apply nat.prime.pos, apply fact.out, },
      { norm_num, }, },
    have f3 : 0 ≤ 1 / (p : ℝ),
    { apply div_nonneg _ _,
      any_goals { norm_cast, apply nat.zero_le _, }, },
    obtain ⟨n, hn⟩ := exists_pow_lt_of_lt_one f1 f2,
    refine ⟨n, λ x hx, _⟩,
    apply lt_of_le_of_lt (mul_le_mul (norm_mul_pow_le_one_div_pow p d R x) le_rfl hk _) _,
--    { apply_instance, },
--    { apply_instance, },
    { rw ← one_div_pow, apply pow_nonneg f3 _, },
    rw ← inv_inv k,
    rw mul_inv_lt_iff f,
    { rw ← one_div_pow,
      apply lt_of_le_of_lt (pow_le_pow_of_le_one f3 (le_of_lt f2) hx) hn, }, },
end

lemma norm_le_one [normed_algebra ℚ_[p] R][norm_one_class R] (n : ℕ) : ∥(n : R)∥ ≤ 1 :=
begin
  rw norm_coe_nat_eq_norm_ring_hom_map p,
  apply padic_int.norm_le_one,
end

variables (p d R)
lemma norm_mul_pow_pos [fact (0 < d)] [nontrivial R] [algebra ℚ_[p] R] (x : ℕ) : 0 < ∥((d * p^x : ℕ) : R)∥ :=
norm_pos_iff.2 ((@nat.cast_ne_zero _ _ _ (char_zero_of_nontrivial_of_normed_algebra p R) _).2 (nat.ne_zero_of_lt' 0))

variables {p d R}
--`helper_W_4` replaced with `helper_17`
lemma helper_17 [normed_algebra ℚ_[p] R] [norm_one_class R] {k : ℕ} {x : ℕ} (y : (zmod (d * p^x))ˣ) :
  ∥(d : R) * ∑ (x_1 : ℕ) in finset.range (k - 1),
  (((p ^ x : ℕ) : R) * ↑d) ^ x_1 * ((-1) * ↑((y : zmod (d * p^x)).val)) ^ (k - 1 - (x_1 + 1)) *
  ↑((k - 1).choose (x_1 + 1))∥ ≤ 1 :=
begin
  have h1 : (-1 : R) = ((-1 : ℤ) : R), norm_cast,
  conv { congr, congr, congr, skip, apply_congr, skip, rw h1, },
  simp_rw [← int.cast_coe_nat, ← int.cast_mul, ← int.cast_pow, ← int.cast_mul, ← int.cast_sum,
    ← int.cast_mul],
  rw ← ring_hom.map_int_cast (algebra_map ℚ_[p] R),
  rw norm_algebra_map' R,
  rw ← padic_int.coe_coe_int,
  apply padic_int.norm_le_one,
end

variables (p d R)
open filter
lemma norm_pow_lim_eq_zero [normed_algebra ℚ_[p] R] [norm_one_class R] (k : R) {n : ℕ}
  (hn : 0 < n) : filter.tendsto (λ x : ℕ, (((d * p^x) : ℕ) : R)^n * k) (filter.at_top) (nhds 0) :=
begin
  conv { congr, funext, rw mul_comm _ k, skip, skip, congr, rw ←mul_zero k, rw ← zero_pow hn, },
  apply tendsto.const_mul,
  apply tendsto.pow,
  convert @norm_lim_eq_zero p d _ R _ _ _ (1 : R),
  simp_rw mul_one,
end

lemma norm_int_eq_padic_int_norm [normed_algebra ℚ_[p] R] [norm_one_class R] (z : ℤ) : ∥(z : R)∥ = ∥(z : ℤ_[p])∥ :=
begin
  rw padic_int.norm_int_cast_eq_padic_norm,
  rw ← norm_algebra_map' R (z : ℚ_[p]),
  rw ring_hom.map_int_cast,
end

lemma norm_prime_lt_one [normed_algebra ℚ_[p] R] [norm_one_class R] : ∥(p : R)∥ < 1 :=
begin
  change ∥((p : ℤ) : R)∥ < 1,
  rw norm_int_eq_padic_int_norm p R,
  rw padic_int.norm_lt_one_iff_dvd _,
  simp,
end