/-
Copyright (c) 2019 Amelia Livingston. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Amelia Livingston
-/
import algebra.group.prod
import algebra.hom.equiv.basic
import data.setoid.basic
import group_theory.submonoid.operations

/-!
# Congruence relations

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

This file defines congruence relations: equivalence relations that preserve a binary operation,
which in this case is multiplication or addition. The principal definition is a `structure`
extending a `setoid` (an equivalence relation), and the inductive definition of the smallest
congruence relation containing a binary relation is also given (see `con_gen`).

The file also proves basic properties of the quotient of a type by a congruence relation, and the
complete lattice of congruence relations on a type. We then establish an order-preserving bijection
between the set of congruence relations containing a congruence relation `c` and the set of
congruence relations on the quotient by `c`.

The second half of the file concerns congruence relations on monoids, in which case the
quotient by the congruence relation is also a monoid. There are results about the universal
property of quotients of monoids, and the isomorphism theorems for monoids.

## Implementation notes

The inductive definition of a congruence relation could be a nested inductive type, defined using
the equivalence closure of a binary relation `eqv_gen`, but the recursor generated does not work.
A nested inductive definition could conceivably shorten proofs, because they would allow invocation
of the corresponding lemmas about `eqv_gen`.

The lemmas `refl`, `symm` and `trans` are not tagged with `@[refl]`, `@[symm]`, and `@[trans]`
respectively as these tags do not work on a structure coerced to a binary relation.

There is a coercion from elements of a type to the element's equivalence class under a
congruence relation.

A congruence relation on a monoid `M` can be thought of as a submonoid of `M × M` for which
membership is an equivalence relation, but whilst this fact is established in the file, it is not
used, since this perspective adds more layers of definitional unfolding.

## Tags

congruence, congruence relation, quotient, quotient by congruence relation, monoid,
quotient monoid, isomorphism theorems
-/

variables (M : Type*) {N : Type*} {P : Type*}

open function setoid

/-- A congruence relation on a type with an addition is an equivalence relation which
    preserves addition. -/
structure add_con [has_add M] extends setoid M :=
(add' : ∀ {w x y z}, r w x → r y z → r (w + y) (x + z))

/-- A congruence relation on a type with a multiplication is an equivalence relation which
    preserves multiplication. -/
@[to_additive add_con] structure con [has_mul M] extends setoid M :=
(mul' : ∀ {w x y z}, r w x → r y z → r (w * y) (x * z))

/-- The equivalence relation underlying an additive congruence relation. -/
add_decl_doc add_con.to_setoid

/-- The equivalence relation underlying a multiplicative congruence relation. -/
add_decl_doc con.to_setoid

variables {M}

/-- The inductively defined smallest additive congruence relation containing a given binary
    relation. -/
inductive add_con_gen.rel [has_add M] (r : M → M → Prop) : M → M → Prop
| of : Π x y, r x y → add_con_gen.rel x y
| refl : Π x, add_con_gen.rel x x
| symm : Π x y, add_con_gen.rel x y → add_con_gen.rel y x
| trans : Π x y z, add_con_gen.rel x y → add_con_gen.rel y z → add_con_gen.rel x z
| add : Π w x y z, add_con_gen.rel w x → add_con_gen.rel y z → add_con_gen.rel (w + y) (x + z)

/-- The inductively defined smallest multiplicative congruence relation containing a given binary
    relation. -/
@[to_additive add_con_gen.rel]
inductive con_gen.rel [has_mul M] (r : M → M → Prop) : M → M → Prop
| of : Π x y, r x y → con_gen.rel x y
| refl : Π x, con_gen.rel x x
| symm : Π x y, con_gen.rel x y → con_gen.rel y x
| trans : Π x y z, con_gen.rel x y → con_gen.rel y z → con_gen.rel x z
| mul : Π w x y z, con_gen.rel w x → con_gen.rel y z → con_gen.rel (w * y) (x * z)

/-- The inductively defined smallest multiplicative congruence relation containing a given binary
    relation. -/
@[to_additive add_con_gen "The inductively defined smallest additive congruence relation containing
a given binary relation."]
def con_gen [has_mul M] (r : M → M → Prop) : con M :=
⟨⟨con_gen.rel r, ⟨con_gen.rel.refl, con_gen.rel.symm, con_gen.rel.trans⟩⟩, con_gen.rel.mul⟩

namespace con

section
variables [has_mul M] [has_mul N] [has_mul P] (c : con M)

@[to_additive]
instance : inhabited (con M) :=
⟨con_gen empty_relation⟩

/-- A coercion from a congruence relation to its underlying binary relation. -/
@[to_additive "A coercion from an additive congruence relation to its underlying binary relation."]
instance : has_coe_to_fun (con M) (λ _, M → M → Prop) := ⟨λ c, λ x y, @setoid.r _ c.to_setoid x y⟩

@[simp, to_additive] lemma rel_eq_coe (c : con M) : c.r = c := rfl

/-- Congruence relations are reflexive. -/
@[to_additive "Additive congruence relations are reflexive."]
protected lemma refl (x) : c x x := c.to_setoid.refl' x

/-- Congruence relations are symmetric. -/
@[to_additive "Additive congruence relations are symmetric."]
protected lemma symm : ∀ {x y}, c x y → c y x := λ _ _ h, c.to_setoid.symm' h

/-- Congruence relations are transitive. -/
@[to_additive "Additive congruence relations are transitive."]
protected lemma trans : ∀ {x y z}, c x y → c y z → c x z :=
λ _ _ _ h, c.to_setoid.trans' h

/-- Multiplicative congruence relations preserve multiplication. -/
@[to_additive "Additive congruence relations preserve addition."]
protected lemma mul : ∀ {w x y z}, c w x → c y z → c (w * y) (x * z) :=
λ _ _ _ _ h1 h2, c.mul' h1 h2

@[simp, to_additive] lemma rel_mk {s : setoid M} {h a b} :
  con.mk s h a b ↔ r a b :=
iff.rfl

/-- Given a type `M` with a multiplication, a congruence relation `c` on `M`, and elements of `M`
    `x, y`, `(x, y) ∈ M × M` iff `x` is related to `y` by `c`. -/
@[to_additive "Given a type `M` with an addition, `x, y ∈ M`, and an additive congruence relation
`c` on `M`, `(x, y) ∈ M × M` iff `x` is related to `y` by `c`."]
instance : has_mem (M × M) (con M) := ⟨λ x c, c x.1 x.2⟩

variables {c}

/-- The map sending a congruence relation to its underlying binary relation is injective. -/
@[to_additive "The map sending an additive congruence relation to its underlying binary relation
is injective."]
lemma ext' {c d : con M} (H : c.r = d.r) : c = d :=
by { rcases c with ⟨⟨⟩⟩, rcases d with ⟨⟨⟩⟩, cases H, congr, }

/-- Extensionality rule for congruence relations. -/
@[ext, to_additive "Extensionality rule for additive congruence relations."]
lemma ext {c d : con M} (H : ∀ x y, c x y ↔ d x y) : c = d :=
ext' $ by ext; apply H

/-- The map sending a congruence relation to its underlying equivalence relation is injective. -/
@[to_additive "The map sending an additive congruence relation to its underlying equivalence
relation is injective."]
lemma to_setoid_inj {c d : con M} (H : c.to_setoid = d.to_setoid) : c = d :=
ext $ ext_iff.1 H

/-- Iff version of extensionality rule for congruence relations. -/
@[to_additive "Iff version of extensionality rule for additive congruence relations."]
lemma ext_iff {c d : con M} : (∀ x y, c x y ↔ d x y) ↔ c = d :=
⟨ext, λ h _ _, h ▸ iff.rfl⟩

/-- Two congruence relations are equal iff their underlying binary relations are equal. -/
@[to_additive "Two additive congruence relations are equal iff their underlying binary relations
are equal."]
lemma ext'_iff {c d : con M} : c.r = d.r ↔ c = d :=
⟨ext', λ h, h ▸ rfl⟩

/-- The kernel of a multiplication-preserving function as a congruence relation. -/
@[to_additive "The kernel of an addition-preserving function as an additive congruence relation."]
def mul_ker (f : M → P) (h : ∀ x y, f (x * y) = f x * f y) : con M :=
{ to_setoid := setoid.ker f,
  mul' := λ _ _ _ _ h1 h2, by { dsimp [setoid.ker, on_fun] at *, rw [h, h1, h2, h], } }

/-- Given types with multiplications `M, N`, the product of two congruence relations `c` on `M` and
    `d` on `N`: `(x₁, x₂), (y₁, y₂) ∈ M × N` are related by `c.prod d` iff `x₁` is related to `y₁`
    by `c` and `x₂` is related to `y₂` by `d`. -/
@[to_additive prod "Given types with additions `M, N`, the product of two congruence relations
`c` on `M` and `d` on `N`: `(x₁, x₂), (y₁, y₂) ∈ M × N` are related by `c.prod d` iff `x₁`
is related to `y₁` by `c` and `x₂` is related to `y₂` by `d`."]
protected def prod (c : con M) (d : con N) : con (M × N) :=
{ mul' := λ _ _ _ _ h1 h2, ⟨c.mul h1.1 h2.1, d.mul h1.2 h2.2⟩, ..c.to_setoid.prod d.to_setoid }

/-- The product of an indexed collection of congruence relations. -/
@[to_additive "The product of an indexed collection of additive congruence relations."]
def pi {ι : Type*} {f : ι → Type*} [Π i, has_mul (f i)]
  (C : Π i, con (f i)) : con (Π i, f i) :=
{ mul' := λ _ _ _ _ h1 h2 i, (C i).mul (h1 i) (h2 i), ..@pi_setoid _ _ $ λ i, (C i).to_setoid }

variables (c)

-- Quotients

/-- Defining the quotient by a congruence relation of a type with a multiplication. -/
@[to_additive "Defining the quotient by an additive congruence relation of a type with
an addition."]
protected def quotient := quotient $ c.to_setoid

/-- Coercion from a type with a multiplication to its quotient by a congruence relation.

See Note [use has_coe_t]. -/
@[to_additive "Coercion from a type with an addition to its quotient by an additive congruence
relation", priority 0]
instance : has_coe_t M c.quotient := ⟨@quotient.mk _ c.to_setoid⟩

/-- The quotient by a decidable congruence relation has decidable equality. -/
@[to_additive "The quotient by a decidable additive congruence relation has decidable equality.",
  priority 500] -- Lower the priority since it unifies with any quotient type.
instance [d : ∀ a b, decidable (c a b)] : decidable_eq c.quotient :=
@quotient.decidable_eq M c.to_setoid d

@[simp, to_additive] lemma quot_mk_eq_coe {M : Type*} [has_mul M] (c : con M) (x : M) :
  quot.mk c x = (x : c.quotient) :=
rfl

/-- The function on the quotient by a congruence relation `c` induced by a function that is
    constant on `c`'s equivalence classes. -/
@[elab_as_eliminator, to_additive "The function on the quotient by a congruence relation `c`
induced by a function that is constant on `c`'s equivalence classes."]
protected def lift_on {β} {c : con M} (q : c.quotient) (f : M → β)
  (h : ∀ a b, c a b → f a = f b) : β := quotient.lift_on' q f h

/-- The binary function on the quotient by a congruence relation `c` induced by a binary function
    that is constant on `c`'s equivalence classes. -/
@[elab_as_eliminator, to_additive "The binary function on the quotient by a congruence relation `c`
induced by a binary function that is constant on `c`'s equivalence classes."]
protected def lift_on₂ {β} {c : con M} (q r : c.quotient) (f : M → M → β)
  (h : ∀ a₁ a₂ b₁ b₂, c a₁ b₁ → c a₂ b₂ → f a₁ a₂ = f b₁ b₂) : β := quotient.lift_on₂' q r f h

/-- A version of `quotient.hrec_on₂'` for quotients by `con`. -/
@[to_additive "A version of `quotient.hrec_on₂'` for quotients by `add_con`."]
protected def hrec_on₂ {cM : con M} {cN : con N} {φ : cM.quotient → cN.quotient → Sort*}
  (a : cM.quotient) (b : cN.quotient)
  (f : Π (x : M) (y : N), φ x y) (h : ∀ x y x' y', cM x x' → cN y y' → f x y == f x' y') :
  φ a b :=
quotient.hrec_on₂' a b f h

@[simp, to_additive] lemma hrec_on₂_coe {cM : con M} {cN : con N}
  {φ : cM.quotient → cN.quotient → Sort*} (a : M) (b : N)
  (f : Π (x : M) (y : N), φ x y) (h : ∀ x y x' y', cM x x' → cN y y' → f x y == f x' y') :
  con.hrec_on₂ ↑a ↑b f h = f a b :=
rfl

variables {c}

/-- The inductive principle used to prove propositions about the elements of a quotient by a
    congruence relation. -/
@[elab_as_eliminator, to_additive "The inductive principle used to prove propositions about
the elements of a quotient by an additive congruence relation."]
protected lemma induction_on {C : c.quotient → Prop} (q : c.quotient) (H : ∀ x : M, C x) : C q :=
quotient.induction_on' q H

/-- A version of `con.induction_on` for predicates which take two arguments. -/
@[elab_as_eliminator, to_additive "A version of `add_con.induction_on` for predicates which take
two arguments."]
protected lemma induction_on₂ {d : con N} {C : c.quotient → d.quotient → Prop}
  (p : c.quotient) (q : d.quotient) (H : ∀ (x : M) (y : N), C x y) : C p q :=
quotient.induction_on₂' p q H

variables (c)

/-- Two elements are related by a congruence relation `c` iff they are represented by the same
    element of the quotient by `c`. -/
@[simp, to_additive "Two elements are related by an additive congruence relation `c` iff they
are represented by the same element of the quotient by `c`."]
protected lemma eq {a b : M} : (a : c.quotient) = b ↔ c a b :=
quotient.eq'

/-- The multiplication induced on the quotient by a congruence relation on a type with a
    multiplication. -/
@[to_additive "The addition induced on the quotient by an additive congruence relation on a type
with an addition."]
instance has_mul : has_mul c.quotient :=
⟨quotient.map₂' (*) $ λ _ _ h1 _ _ h2, c.mul h1 h2⟩

/-- The kernel of the quotient map induced by a congruence relation `c` equals `c`. -/
@[simp, to_additive "The kernel of the quotient map induced by an additive congruence relation
`c` equals `c`."]
lemma mul_ker_mk_eq : mul_ker (coe : M → c.quotient) (λ x y, rfl) = c :=
ext $ λ x y, quotient.eq'

variables {c}

/-- The coercion to the quotient of a congruence relation commutes with multiplication (by
    definition). -/
@[simp, to_additive "The coercion to the quotient of an additive congruence relation commutes with
addition (by definition)."]
lemma coe_mul (x y : M) : (↑(x * y) : c.quotient) = ↑x * ↑y := rfl

/-- Definition of the function on the quotient by a congruence relation `c` induced by a function
    that is constant on `c`'s equivalence classes. -/
@[simp, to_additive "Definition of the function on the quotient by an additive congruence
relation `c` induced by a function that is constant on `c`'s equivalence classes."]
protected lemma lift_on_coe {β} (c : con M) (f : M → β)
  (h : ∀ a b, c a b → f a = f b) (x : M) :
  con.lift_on (x : c.quotient) f h = f x := rfl

/-- Makes an isomorphism of quotients by two congruence relations, given that the relations are
    equal. -/
@[to_additive "Makes an additive isomorphism of quotients by two additive congruence relations,
given that the relations are equal."]
protected def congr {c d : con M} (h : c = d) :  c.quotient ≃* d.quotient :=
{ map_mul' := λ x y, by rcases x; rcases y; refl,
  ..quotient.congr (equiv.refl M) $ by apply ext_iff.2 h }

-- The complete lattice of congruence relations on a type

/-- For congruence relations `c, d` on a type `M` with a multiplication, `c ≤ d` iff `∀ x y ∈ M`,
    `x` is related to `y` by `d` if `x` is related to `y` by `c`. -/
@[to_additive "For additive congruence relations `c, d` on a type `M` with an addition, `c ≤ d` iff
`∀ x y ∈ M`, `x` is related to `y` by `d` if `x` is related to `y` by `c`."]
instance : has_le (con M) := ⟨λ c d, ∀ ⦃x y⦄, c x y → d x y⟩

/-- Definition of `≤` for congruence relations. -/
@[to_additive "Definition of `≤` for additive congruence relations."]
theorem le_def {c d : con M} : c ≤ d ↔ ∀ {x y}, c x y → d x y := iff.rfl

/-- The infimum of a set of congruence relations on a given type with a multiplication. -/
@[to_additive "The infimum of a set of additive congruence relations on a given type with
an addition."]
instance : has_Inf (con M) :=
⟨λ S, ⟨⟨λ x y, ∀ c : con M, c ∈ S → c x y,
⟨λ x c hc, c.refl x, λ _ _ h c hc, c.symm $ h c hc,
 λ _ _ _ h1 h2 c hc, c.trans (h1 c hc) $ h2 c hc⟩⟩,
 λ _ _ _ _ h1 h2 c hc, c.mul (h1 c hc) $ h2 c hc⟩⟩

/-- The infimum of a set of congruence relations is the same as the infimum of the set's image
    under the map to the underlying equivalence relation. -/
@[to_additive "The infimum of a set of additive congruence relations is the same as the infimum of
the set's image under the map to the underlying equivalence relation."]
lemma Inf_to_setoid (S : set (con M)) : (Inf S).to_setoid = Inf (to_setoid '' S) :=
setoid.ext' $ λ x y, ⟨λ h r ⟨c, hS, hr⟩, by rw ←hr; exact h c hS,
  λ h c hS, h c.to_setoid ⟨c, hS, rfl⟩⟩

/-- The infimum of a set of congruence relations is the same as the infimum of the set's image
    under the map to the underlying binary relation. -/
@[to_additive "The infimum of a set of additive congruence relations is the same as the infimum
of the set's image under the map to the underlying binary relation."]
lemma Inf_def (S : set (con M)) : ⇑(Inf S) = Inf (@set.image (con M) (M → M → Prop) coe_fn S) :=
by { ext, simp only [Inf_image, infi_apply, infi_Prop_eq], refl }

@[to_additive]
instance : partial_order (con M) :=
{ le := (≤),
  lt := λ c d, c ≤ d ∧ ¬d ≤ c,
  le_refl := λ c _ _, id,
  le_trans := λ c1 c2 c3 h1 h2 x y h, h2 $ h1 h,
  lt_iff_le_not_le := λ _ _, iff.rfl,
  le_antisymm := λ c d hc hd, ext $ λ x y, ⟨λ h, hc h, λ h, hd h⟩ }

/-- The complete lattice of congruence relations on a given type with a multiplication. -/
@[to_additive "The complete lattice of additive congruence relations on a given type with
an addition."]
instance : complete_lattice (con M) :=
{ inf := λ c d, ⟨(c.to_setoid ⊓ d.to_setoid), λ _ _ _ _ h1 h2, ⟨c.mul h1.1 h2.1, d.mul h1.2 h2.2⟩⟩,
  inf_le_left := λ _ _ _ _ h, h.1,
  inf_le_right := λ _ _ _ _ h, h.2,
  le_inf := λ _ _ _ hb hc _ _ h, ⟨hb h, hc h⟩,
  top := { mul' := by tauto, ..setoid.complete_lattice.top},
  le_top := λ _ _ _ h, trivial,
  bot := { mul' := λ _ _ _ _ h1 h2, h1 ▸ h2 ▸ rfl, ..setoid.complete_lattice.bot},
  bot_le := λ c x y h, h ▸ c.refl x,
  .. complete_lattice_of_Inf (con M) $ assume s,
    ⟨λ r hr x y h, (h : ∀ r ∈ s, (r : con M) x y) r hr, λ r hr x y h r' hr', hr hr' h⟩ }

/-- The infimum of two congruence relations equals the infimum of the underlying binary
    operations. -/
@[to_additive "The infimum of two additive congruence relations equals the infimum of the
underlying binary operations."]
lemma inf_def {c d : con M} : (c ⊓ d).r = c.r ⊓ d.r := rfl

/-- Definition of the infimum of two congruence relations. -/
@[to_additive "Definition of the infimum of two additive congruence relations."]
theorem inf_iff_and {c d : con M} {x y} : (c ⊓ d) x y ↔ c x y ∧ d x y := iff.rfl

/-- The inductively defined smallest congruence relation containing a binary relation `r` equals
    the infimum of the set of congruence relations containing `r`. -/
@[to_additive add_con_gen_eq "The inductively defined smallest additive congruence relation
containing a binary relation `r` equals the infimum of the set of additive congruence relations
containing `r`."]
theorem con_gen_eq (r : M → M → Prop) :
  con_gen r = Inf {s : con M | ∀ x y, r x y → s x y} :=
le_antisymm
  (λ x y H, con_gen.rel.rec_on H (λ _ _ h _ hs, hs _ _ h) (con.refl _) (λ _ _ _, con.symm _)
    (λ _ _ _ _ _, con.trans _)
    $ λ w x y z _ _ h1 h2 c hc, c.mul (h1 c hc) $ h2 c hc)
  (Inf_le (λ _ _, con_gen.rel.of _ _))

/-- The smallest congruence relation containing a binary relation `r` is contained in any
    congruence relation containing `r`. -/
@[to_additive add_con_gen_le "The smallest additive congruence relation containing a binary
relation `r` is contained in any additive congruence relation containing `r`."]
theorem con_gen_le {r : M → M → Prop} {c : con M} (h : ∀ x y, r x y → @setoid.r _ c.to_setoid x y) :
  con_gen r ≤ c :=
by rw con_gen_eq; exact Inf_le h

/-- Given binary relations `r, s` with `r` contained in `s`, the smallest congruence relation
    containing `s` contains the smallest congruence relation containing `r`. -/
@[to_additive add_con_gen_mono "Given binary relations `r, s` with `r` contained in `s`, the
smallest additive congruence relation containing `s` contains the smallest additive congruence
relation containing `r`."]
theorem con_gen_mono {r s : M → M → Prop} (h : ∀ x y, r x y → s x y) :
  con_gen r ≤ con_gen s :=
con_gen_le $ λ x y hr, con_gen.rel.of _ _ $ h x y hr

/-- Congruence relations equal the smallest congruence relation in which they are contained. -/
@[simp, to_additive add_con_gen_of_add_con "Additive congruence relations equal the smallest
additive congruence relation in which they are contained."]
lemma con_gen_of_con (c : con M) : con_gen c = c :=
le_antisymm (by rw con_gen_eq; exact Inf_le (λ _ _, id)) con_gen.rel.of

/-- The map sending a binary relation to the smallest congruence relation in which it is
    contained is idempotent. -/
@[simp, to_additive add_con_gen_idem "The map sending a binary relation to the smallest additive
congruence relation in which it is contained is idempotent."]
lemma con_gen_idem (r : M → M → Prop) :
  con_gen (con_gen r) = con_gen r :=
con_gen_of_con _

/-- The supremum of congruence relations `c, d` equals the smallest congruence relation containing
    the binary relation '`x` is related to `y` by `c` or `d`'. -/
@[to_additive sup_eq_add_con_gen "The supremum of additive congruence relations `c, d` equals the
smallest additive congruence relation containing the binary relation '`x` is related to `y`
by `c` or `d`'."]
lemma sup_eq_con_gen (c d : con M) :
  c ⊔ d = con_gen (λ x y, c x y ∨ d x y) :=
begin
  rw con_gen_eq,
  apply congr_arg Inf,
  simp only [le_def, or_imp_distrib, ← forall_and_distrib]
end

/-- The supremum of two congruence relations equals the smallest congruence relation containing
    the supremum of the underlying binary operations. -/
@[to_additive "The supremum of two additive congruence relations equals the smallest additive
congruence relation containing the supremum of the underlying binary operations."]
lemma sup_def {c d : con M} : c ⊔ d = con_gen (c.r ⊔ d.r) :=
by rw sup_eq_con_gen; refl

/-- The supremum of a set of congruence relations `S` equals the smallest congruence relation
    containing the binary relation 'there exists `c ∈ S` such that `x` is related to `y` by
    `c`'. -/
@[to_additive Sup_eq_add_con_gen "The supremum of a set of additive congruence relations `S` equals
the smallest additive congruence relation containing the binary relation 'there exists `c ∈ S`
such that `x` is related to `y` by `c`'."]
lemma Sup_eq_con_gen (S : set (con M)) :
  Sup S = con_gen (λ x y, ∃ c : con M, c ∈ S ∧ c x y) :=
begin
  rw con_gen_eq,
  apply congr_arg Inf,
  ext,
  exact ⟨λ h _ _ ⟨r, hr⟩, h hr.1 hr.2,
         λ h r hS _ _ hr, h _ _ ⟨r, hS, hr⟩⟩,
end

/-- The supremum of a set of congruence relations is the same as the smallest congruence relation
    containing the supremum of the set's image under the map to the underlying binary relation. -/
@[to_additive "The supremum of a set of additive congruence relations is the same as the smallest
additive congruence relation containing the supremum of the set's image under the map to the
underlying binary relation."]
lemma Sup_def {S : set (con M)} :
  Sup S = con_gen (Sup (@set.image (con M) (M → M → Prop) coe_fn S)) :=
begin
  rw [Sup_eq_con_gen, Sup_image],
  congr' with x y,
  simp only [Sup_image, supr_apply, supr_Prop_eq, exists_prop, rel_eq_coe]
end

variables (M)

/-- There is a Galois insertion of congruence relations on a type with a multiplication `M` into
    binary relations on `M`. -/
@[to_additive "There is a Galois insertion of additive congruence relations on a type with
an addition `M` into binary relations on `M`."]
protected def gi :
  @galois_insertion (M → M → Prop) (con M) _ _ con_gen coe_fn :=
{ choice := λ r h, con_gen r,
  gc := λ r c, ⟨λ H _ _ h, H $ con_gen.rel.of _ _ h, λ H, con_gen_of_con c ▸ con_gen_mono H⟩,
  le_l_u := λ x, (con_gen_of_con x).symm ▸ le_refl x,
  choice_eq := λ _ _, rfl }

variables {M} (c)

/-- Given a function `f`, the smallest congruence relation containing the binary relation on `f`'s
    image defined by '`x ≈ y` iff the elements of `f⁻¹(x)` are related to the elements of `f⁻¹(y)`
    by a congruence relation `c`.' -/
@[to_additive "Given a function `f`, the smallest additive congruence relation containing the
binary relation on `f`'s image defined by '`x ≈ y` iff the elements of `f⁻¹(x)` are related to the
elements of `f⁻¹(y)` by an additive congruence relation `c`.'"]
def map_gen (f : M → N) : con N :=
con_gen $ λ x y, ∃ a b, f a = x ∧ f b = y ∧ c a b

/-- Given a surjective multiplicative-preserving function `f` whose kernel is contained in a
    congruence relation `c`, the congruence relation on `f`'s codomain defined by '`x ≈ y` iff the
    elements of `f⁻¹(x)` are related to the elements of `f⁻¹(y)` by `c`.' -/
@[to_additive "Given a surjective addition-preserving function `f` whose kernel is contained in
an additive congruence relation `c`, the additive congruence relation on `f`'s codomain defined
by '`x ≈ y` iff the elements of `f⁻¹(x)` are related to the elements of `f⁻¹(y)` by `c`.'"]
def map_of_surjective (f : M → N) (H : ∀ x y, f (x * y) = f x * f y) (h : mul_ker f H ≤ c)
  (hf : surjective f) : con N :=
{ mul' := λ w x y z ⟨a, b, hw, hx, h1⟩ ⟨p, q, hy, hz, h2⟩,
    ⟨a * p, b * q, by rw [H, hw, hy], by rw [H, hx, hz], c.mul h1 h2⟩,
  ..c.to_setoid.map_of_surjective f h hf }

/-- A specialization of 'the smallest congruence relation containing a congruence relation `c`
    equals `c`'. -/
@[to_additive "A specialization of 'the smallest additive congruence relation containing
an additive congruence relation `c` equals `c`'."]
lemma map_of_surjective_eq_map_gen {c : con M} {f : M → N} (H : ∀ x y, f (x * y) = f x * f y)
  (h : mul_ker f H ≤ c) (hf : surjective f) :
  c.map_gen f = c.map_of_surjective f H h hf :=
by rw ←con_gen_of_con (c.map_of_surjective f H h hf); refl

/-- Given types with multiplications `M, N` and a congruence relation `c` on `N`, a
    multiplication-preserving map `f : M → N` induces a congruence relation on `f`'s domain
    defined by '`x ≈ y` iff `f(x)` is related to `f(y)` by `c`.' -/
@[to_additive "Given types with additions `M, N` and an additive congruence relation `c` on `N`,
an addition-preserving map `f : M → N` induces an additive congruence relation on `f`'s domain
defined by '`x ≈ y` iff `f(x)` is related to `f(y)` by `c`.' "]
def comap (f : M → N) (H : ∀ x y, f (x * y) = f x * f y) (c : con N) : con M :=
{ mul' := λ w x y z h1 h2, show c (f (w * y)) (f (x * z)), by rw [H, H]; exact c.mul h1 h2,
  ..c.to_setoid.comap f }

@[simp, to_additive] lemma comap_rel {f : M → N} (H : ∀ x y, f (x * y) = f x * f y)
  {c : con N} {x y : M} :
  comap f H c x y ↔ c (f x) (f y) :=
iff.rfl

section
open _root_.quotient

/-- Given a congruence relation `c` on a type `M` with a multiplication, the order-preserving
    bijection between the set of congruence relations containing `c` and the congruence relations
    on the quotient of `M` by `c`. -/
@[to_additive "Given an additive congruence relation `c` on a type `M` with an addition,
the order-preserving bijection between the set of additive congruence relations containing `c` and
the additive congruence relations on the quotient of `M` by `c`."]
def correspondence : {d // c ≤ d} ≃o (con c.quotient) :=
{ to_fun := λ d, d.1.map_of_surjective coe _
    (by rw mul_ker_mk_eq; exact d.2) $ @exists_rep _ c.to_setoid,
  inv_fun := λ d, ⟨comap (coe : M → c.quotient) (λ x y, rfl) d, λ _ _ h,
    show d _ _, by rw c.eq.2 h; exact d.refl _ ⟩,
  left_inv := λ d, subtype.ext_iff_val.2 $ ext $ λ _ _,
    ⟨λ h, let ⟨a, b, hx, hy, H⟩ := h in
      d.1.trans (d.1.symm $ d.2 $ c.eq.1 hx) $ d.1.trans H $ d.2 $ c.eq.1 hy,
     λ h, ⟨_, _, rfl, rfl, h⟩⟩,
  right_inv := λ d, let Hm : mul_ker (coe : M → c.quotient) (λ x y, rfl) ≤
        comap (coe : M → c.quotient) (λ x y, rfl) d :=
      λ x y h, show d _ _, by rw mul_ker_mk_eq at h; exact c.eq.2 h ▸ d.refl _ in
    ext $ λ x y, ⟨λ h, let ⟨a, b, hx, hy, H⟩ := h in hx ▸ hy ▸ H,
      con.induction_on₂ x y $ λ w z h, ⟨w, z, rfl, rfl, h⟩⟩,
  map_rel_iff' := λ s t, ⟨λ h _ _ hs, let ⟨a, b, hx, hy, ht⟩ := h ⟨_, _, rfl, rfl, hs⟩ in
      t.1.trans (t.1.symm $ t.2 $ eq_rel.1 hx) $ t.1.trans ht $ t.2 $ eq_rel.1 hy,
      λ h _ _ hs, let ⟨a, b, hx, hy, Hs⟩ := hs in ⟨a, b, hx, hy, h Hs⟩⟩ }

end

end

section mul_one_class

variables {M} [mul_one_class M] [mul_one_class N] [mul_one_class P] (c : con M)

/-- The quotient of a monoid by a congruence relation is a monoid. -/
@[to_additive "The quotient of an `add_monoid` by an additive congruence relation is
an `add_monoid`."]
instance mul_one_class : mul_one_class c.quotient :=
{ one := ((1 : M) : c.quotient),
  mul := (*),
  mul_one := λ x, quotient.induction_on' x $ λ _, congr_arg (coe : M → c.quotient) $ mul_one _,
  one_mul := λ x, quotient.induction_on' x $ λ _, congr_arg (coe : M → c.quotient) $ one_mul _ }

variables {c}

/-- The 1 of the quotient of a monoid by a congruence relation is the equivalence class of the
    monoid's 1. -/
@[simp, to_additive "The 0 of the quotient of an `add_monoid` by an additive congruence relation
is the equivalence class of the `add_monoid`'s 0."]
lemma coe_one : ((1 : M) : c.quotient) = 1 := rfl

variables (M c)

/-- The submonoid of `M × M` defined by a congruence relation on a monoid `M`. -/
@[to_additive "The `add_submonoid` of `M × M` defined by an additive congruence
relation on an `add_monoid` `M`."]
protected def submonoid : submonoid (M × M) :=
{ carrier := { x | c x.1 x.2 },
  one_mem' := c.iseqv.1 1,
  mul_mem' := λ _ _, c.mul }

variables {M c}

/-- The congruence relation on a monoid `M` from a submonoid of `M × M` for which membership
    is an equivalence relation. -/
@[to_additive "The additive congruence relation on an `add_monoid` `M` from
an `add_submonoid` of `M × M` for which membership is an equivalence relation."]
def of_submonoid (N : submonoid (M × M)) (H : equivalence (λ x y, (x, y) ∈ N)) : con M :=
{ r := λ x y, (x, y) ∈ N,
  iseqv := H,
  mul' := λ _ _ _ _, N.mul_mem }

/-- Coercion from a congruence relation `c` on a monoid `M` to the submonoid of `M × M` whose
    elements are `(x, y)` such that `x` is related to `y` by `c`. -/
@[to_additive "Coercion from a congruence relation `c` on an `add_monoid` `M`
to the `add_submonoid` of `M × M` whose elements are `(x, y)` such that `x`
is related to `y` by `c`."]
instance to_submonoid : has_coe (con M) (submonoid (M × M)) := ⟨λ c, c.submonoid M⟩

@[to_additive] lemma mem_coe {c : con M} {x y} :
  (x, y) ∈ (↑c : submonoid (M × M)) ↔ (x, y) ∈ c := iff.rfl

@[to_additive]
theorem to_submonoid_inj (c d : con M) (H : (c : submonoid (M × M)) = d) : c = d :=
ext $ λ x y, show (x, y) ∈ (c : submonoid (M × M)) ↔ (x, y) ∈ ↑d, by rw H

@[to_additive]
lemma le_iff {c d : con M} : c ≤ d ↔ (c : submonoid (M × M)) ≤ d :=
⟨λ h x H, h H, λ h x y hc, h $ show (x, y) ∈ c, from hc⟩

/-- The kernel of a monoid homomorphism as a congruence relation. -/
@[to_additive "The kernel of an `add_monoid` homomorphism as an additive congruence relation."]
def ker (f : M →* P) : con M := mul_ker f f.3

/-- The definition of the congruence relation defined by a monoid homomorphism's kernel. -/
@[simp, to_additive "The definition of the additive congruence relation defined by an `add_monoid`
homomorphism's kernel."]
lemma ker_rel (f : M →* P) {x y} : ker f x y ↔ f x = f y := iff.rfl

/-- There exists an element of the quotient of a monoid by a congruence relation (namely 1). -/
@[to_additive "There exists an element of the quotient of an `add_monoid` by a congruence relation
(namely 0)."]
instance quotient.inhabited : inhabited c.quotient := ⟨((1 : M) : c.quotient)⟩

variables (c)

/-- The natural homomorphism from a monoid to its quotient by a congruence relation. -/
@[to_additive "The natural homomorphism from an `add_monoid` to its quotient by an additive
congruence relation."]
def mk' : M →* c.quotient := ⟨coe, rfl, λ _ _, rfl⟩

variables (x y : M)

/-- The kernel of the natural homomorphism from a monoid to its quotient by a congruence
    relation `c` equals `c`. -/
@[simp, to_additive "The kernel of the natural homomorphism from an `add_monoid` to its quotient by
an additive congruence relation `c` equals `c`."]
lemma mk'_ker : ker c.mk' = c := ext $ λ _ _, c.eq

variables {c}

/-- The natural homomorphism from a monoid to its quotient by a congruence relation is
    surjective. -/
@[to_additive "The natural homomorphism from an `add_monoid` to its quotient by a congruence
relation is surjective."]
lemma mk'_surjective : surjective c.mk' :=
quotient.surjective_quotient_mk'

@[simp, to_additive] lemma coe_mk' : (c.mk' : M → c.quotient) = coe := rfl

@[simp, to_additive] lemma mrange_mk' : c.mk'.mrange = ⊤ :=
monoid_hom.mrange_top_iff_surjective.2 mk'_surjective

/-- The elements related to `x ∈ M`, `M` a monoid, by the kernel of a monoid homomorphism are
    those in the preimage of `f(x)` under `f`. -/
@[to_additive "The elements related to `x ∈ M`, `M` an `add_monoid`, by the kernel of
an `add_monoid` homomorphism are those in the preimage of `f(x)` under `f`. "]
lemma ker_apply_eq_preimage {f : M →* P} (x) : (ker f) x = f ⁻¹' {f x} :=
set.ext $ λ x,
  ⟨λ h, set.mem_preimage.2 $ set.mem_singleton_iff.2 h.symm,
   λ h, (set.mem_singleton_iff.1 $ set.mem_preimage.1 h).symm⟩

/-- Given a monoid homomorphism `f : N → M` and a congruence relation `c` on `M`, the congruence
    relation induced on `N` by `f` equals the kernel of `c`'s quotient homomorphism composed with
    `f`. -/
@[to_additive "Given an `add_monoid` homomorphism `f : N → M` and an additive congruence relation
`c` on `M`, the additive congruence relation induced on `N` by `f` equals the kernel of `c`'s
quotient homomorphism composed with `f`."]
lemma comap_eq {f : N →* M} : comap f f.map_mul c = ker (c.mk'.comp f) :=
ext $ λ x y, show c _ _ ↔ c.mk' _ = c.mk' _, by rw ←c.eq; refl

variables (c) (f : M →* P)

/-- The homomorphism on the quotient of a monoid by a congruence relation `c` induced by a
    homomorphism constant on `c`'s equivalence classes. -/
@[to_additive "The homomorphism on the quotient of an `add_monoid` by an additive congruence
relation `c` induced by a homomorphism constant on `c`'s equivalence classes."]
def lift (H : c ≤ ker f) : c.quotient →* P :=
{ to_fun := λ x, con.lift_on x f $ λ _ _ h, H h,
  map_one' := by rw ←f.map_one; refl,
  map_mul' := λ x y, con.induction_on₂ x y $ λ m n, f.map_mul m n ▸ rfl }

variables {c f}

/-- The diagram describing the universal property for quotients of monoids commutes. -/
@[to_additive "The diagram describing the universal property for quotients of `add_monoid`s
commutes."]
lemma lift_mk' (H : c ≤ ker f) (x) :
  c.lift f H (c.mk' x) = f x := rfl

/-- The diagram describing the universal property for quotients of monoids commutes. -/
@[simp, to_additive "The diagram describing the universal property for quotients of `add_monoid`s
commutes."]
lemma lift_coe (H : c ≤ ker f) (x : M) :
  c.lift f H x = f x := rfl

/-- The diagram describing the universal property for quotients of monoids commutes. -/
@[simp, to_additive "The diagram describing the universal property for quotients of `add_monoid`s
commutes."]
theorem lift_comp_mk' (H : c ≤ ker f) :
  (c.lift f H).comp c.mk' = f := by ext; refl

/-- Given a homomorphism `f` from the quotient of a monoid by a congruence relation, `f` equals the
    homomorphism on the quotient induced by `f` composed with the natural map from the monoid to
    the quotient. -/
@[simp, to_additive "Given a homomorphism `f` from the quotient of an `add_monoid` by an additive
congruence relation, `f` equals the homomorphism on the quotient induced by `f` composed with the
natural map from the `add_monoid` to the quotient."]
lemma lift_apply_mk' (f : c.quotient →* P) :
  c.lift (f.comp c.mk') (λ x y h, show f ↑x = f ↑y, by rw c.eq.2 h) = f :=
by ext; rcases x; refl

/-- Homomorphisms on the quotient of a monoid by a congruence relation are equal if they
    are equal on elements that are coercions from the monoid. -/
@[to_additive "Homomorphisms on the quotient of an `add_monoid` by an additive congruence relation
are equal if they are equal on elements that are coercions from the `add_monoid`."]
lemma lift_funext (f g : c.quotient →* P) (h : ∀ a : M, f a = g a) : f = g :=
begin
  rw [←lift_apply_mk' f, ←lift_apply_mk' g],
  congr' 1,
  exact monoid_hom.ext_iff.2 h,
end

/-- The uniqueness part of the universal property for quotients of monoids. -/
@[to_additive "The uniqueness part of the universal property for quotients of `add_monoid`s."]
theorem lift_unique (H : c ≤ ker f) (g : c.quotient →* P)
  (Hg : g.comp c.mk' = f) : g = c.lift f H :=
lift_funext g (c.lift f H) $ λ x, by { subst f, refl }

/-- Given a congruence relation `c` on a monoid and a homomorphism `f` constant on `c`'s
    equivalence classes, `f` has the same image as the homomorphism that `f` induces on the
    quotient. -/
@[to_additive "Given an additive congruence relation `c` on an `add_monoid` and a homomorphism `f`
constant on `c`'s equivalence classes, `f` has the same image as the homomorphism that `f` induces
on the quotient."]
theorem lift_range (H : c ≤ ker f) : (c.lift f H).mrange = f.mrange :=
submonoid.ext $ λ x, ⟨by rintros ⟨⟨y⟩, hy⟩; exact ⟨y, hy⟩, λ ⟨y, hy⟩, ⟨↑y, hy⟩⟩

/-- Surjective monoid homomorphisms constant on a congruence relation `c`'s equivalence classes
    induce a surjective homomorphism on `c`'s quotient. -/
@[to_additive "Surjective `add_monoid` homomorphisms constant on an additive congruence
relation `c`'s equivalence classes induce a surjective homomorphism on `c`'s quotient."]
lemma lift_surjective_of_surjective (h : c ≤ ker f) (hf : surjective f) :
  surjective (c.lift f h) :=
λ y, exists.elim (hf y) $ λ w hw, ⟨w, (lift_mk' h w).symm ▸ hw⟩

variables (c f)

/-- Given a monoid homomorphism `f` from `M` to `P`, the kernel of `f` is the unique congruence
    relation on `M` whose induced map from the quotient of `M` to `P` is injective. -/
@[to_additive "Given an `add_monoid` homomorphism `f` from `M` to `P`, the kernel of `f`
is the unique additive congruence relation on `M` whose induced map from the quotient of `M`
to `P` is injective."]
lemma ker_eq_lift_of_injective (H : c ≤ ker f) (h : injective (c.lift f H)) :
  ker f = c :=
to_setoid_inj $ ker_eq_lift_of_injective f H h

variables {c}

/-- The homomorphism induced on the quotient of a monoid by the kernel of a monoid homomorphism. -/
@[to_additive "The homomorphism induced on the quotient of an `add_monoid` by the kernel
of an `add_monoid` homomorphism."]
def ker_lift : (ker f).quotient →* P :=
(ker f).lift f $ λ _ _, id

variables {f}

/-- The diagram described by the universal property for quotients of monoids, when the congruence
    relation is the kernel of the homomorphism, commutes. -/
@[simp, to_additive "The diagram described by the universal property for quotients
of `add_monoid`s, when the additive congruence relation is the kernel of the homomorphism,
commutes."]
lemma ker_lift_mk (x : M) :  ker_lift f x = f x := rfl

/-- Given a monoid homomorphism `f`, the induced homomorphism on the quotient by `f`'s kernel has
    the same image as `f`. -/
@[simp, to_additive "Given an `add_monoid` homomorphism `f`, the induced homomorphism
on the quotient by `f`'s kernel has the same image as `f`."]
lemma ker_lift_range_eq : (ker_lift f).mrange = f.mrange :=
lift_range $ λ _ _, id

/-- A monoid homomorphism `f` induces an injective homomorphism on the quotient by `f`'s kernel. -/
@[to_additive "An `add_monoid` homomorphism `f` induces an injective homomorphism on the quotient
by `f`'s kernel."]
lemma ker_lift_injective (f : M →* P) : injective (ker_lift f) :=
λ x y, quotient.induction_on₂' x y $ λ _ _, (ker f).eq.2

/-- Given congruence relations `c, d` on a monoid such that `d` contains `c`, `d`'s quotient
    map induces a homomorphism from the quotient by `c` to the quotient by `d`. -/
@[to_additive "Given additive congruence relations `c, d` on an `add_monoid` such that `d`
contains `c`, `d`'s quotient map induces a homomorphism from the quotient by `c` to the quotient
by `d`."]
def map (c d : con M) (h : c ≤ d) : c.quotient →* d.quotient :=
c.lift d.mk' $ λ x y hc, show (ker d.mk') x y, from
  (mk'_ker d).symm ▸ h hc

/-- Given congruence relations `c, d` on a monoid such that `d` contains `c`, the definition of
    the homomorphism from the quotient by `c` to the quotient by `d` induced by `d`'s quotient
    map. -/
@[to_additive "Given additive congruence relations `c, d` on an `add_monoid` such that `d`
contains `c`, the definition of the homomorphism from the quotient by `c` to the quotient by `d`
induced by `d`'s quotient map."]
lemma map_apply {c d : con M} (h : c ≤ d) (x) :
  c.map d h x = c.lift d.mk' (λ x y hc, d.eq.2 $ h hc) x := rfl

variables (c)

/-- The first isomorphism theorem for monoids. -/
@[to_additive "The first isomorphism theorem for `add_monoid`s."]
noncomputable def quotient_ker_equiv_range (f : M →* P) : (ker f).quotient ≃* f.mrange :=
{ map_mul' := monoid_hom.map_mul _,
  ..equiv.of_bijective
      ((@mul_equiv.to_monoid_hom (ker_lift f).mrange _ _ _
        $ mul_equiv.submonoid_congr ker_lift_range_eq).comp (ker_lift f).mrange_restrict) $
      (equiv.bijective _).comp
        ⟨λ x y h, ker_lift_injective f $ by rcases x; rcases y; injections,
         λ ⟨w, z, hz⟩, ⟨z, by rcases hz; rcases _x; refl⟩⟩ }

/-- The first isomorphism theorem for monoids in the case of a homomorphism with right inverse. -/
@[to_additive "The first isomorphism theorem for `add_monoid`s in the case of a homomorphism
with right inverse.", simps]
def quotient_ker_equiv_of_right_inverse (f : M →* P) (g : P → M)
  (hf : function.right_inverse g f) :
  (ker f).quotient ≃* P :=
{ to_fun := ker_lift f,
  inv_fun := coe ∘ g,
  left_inv := λ x, ker_lift_injective _ (by rw [function.comp_app, ker_lift_mk, hf]),
  right_inv := hf,
  .. ker_lift f }

/-- The first isomorphism theorem for monoids in the case of a surjective homomorphism.

For a `computable` version, see `con.quotient_ker_equiv_of_right_inverse`.
-/
@[to_additive "The first isomorphism theorem for `add_monoid`s in the case of a surjective
homomorphism.

For a `computable` version, see `add_con.quotient_ker_equiv_of_right_inverse`.
"]
noncomputable def quotient_ker_equiv_of_surjective (f : M →* P) (hf : surjective f) :
  (ker f).quotient ≃* P :=
quotient_ker_equiv_of_right_inverse _ _ hf.has_right_inverse.some_spec

/-- The second isomorphism theorem for monoids. -/
@[to_additive "The second isomorphism theorem for `add_monoid`s."]
noncomputable def comap_quotient_equiv (f : N →* M) :
  (comap f f.map_mul c).quotient ≃* (c.mk'.comp f).mrange :=
(con.congr comap_eq).trans $ quotient_ker_equiv_range $ c.mk'.comp f

/-- The third isomorphism theorem for monoids. -/
@[to_additive "The third isomorphism theorem for `add_monoid`s."]
def quotient_quotient_equiv_quotient (c d : con M) (h : c ≤ d) :
  (ker (c.map d h)).quotient ≃* d.quotient :=
{ map_mul' := λ x y, con.induction_on₂ x y $ λ w z, con.induction_on₂ w z $ λ a b,
    show _ = d.mk' a * d.mk' b, by rw ←d.mk'.map_mul; refl,
  ..quotient_quotient_equiv_quotient c.to_setoid d.to_setoid h }

end mul_one_class

section monoids

/-- Multiplicative congruence relations preserve natural powers. -/
@[to_additive add_con.nsmul "Additive congruence relations preserve natural scaling."]
protected lemma pow {M : Type*} [monoid M] (c : con M) :
  ∀ (n : ℕ) {w x}, c w x → c (w ^ n) (x ^ n)
| 0 w x h := by simpa using c.refl _
| (nat.succ n) w x h := by simpa [pow_succ] using c.mul h (pow n h)

@[to_additive]
instance {M : Type*} [mul_one_class M] (c : con M) : has_one c.quotient :=
{ one := ((1 : M) : c.quotient) }

@[to_additive]

instance _root_.add_con.quotient.has_nsmul
  {M : Type*} [add_monoid M] (c : add_con M) : has_smul ℕ c.quotient :=
{ smul := λ n, quotient.map' ((•) n) $ λ x y, c.nsmul n }

@[to_additive add_con.quotient.has_nsmul]
instance {M : Type*} [monoid M] (c : con M) : has_pow c.quotient ℕ :=
{ pow := λ x n, quotient.map' (λ x, x ^ n) (λ x y, c.pow n) x }

/-- The quotient of a semigroup by a congruence relation is a semigroup. -/
@[to_additive "The quotient of an `add_semigroup` by an additive congruence relation is
an `add_semigroup`."]
instance semigroup {M : Type*} [semigroup M] (c : con M) : semigroup c.quotient :=
function.surjective.semigroup _ quotient.surjective_quotient_mk' (λ _ _, rfl)

/-- The quotient of a commutative semigroup by a congruence relation is a semigroup. -/
@[to_additive "The quotient of an `add_comm_semigroup` by an additive congruence relation is
an `add_semigroup`."]
instance comm_semigroup {M : Type*} [comm_semigroup M] (c : con M) : comm_semigroup c.quotient :=
function.surjective.comm_semigroup _ quotient.surjective_quotient_mk' (λ _ _, rfl)

/-- The quotient of a monoid by a congruence relation is a monoid. -/
@[to_additive "The quotient of an `add_monoid` by an additive congruence relation is
an `add_monoid`."]
instance monoid {M : Type*} [monoid M] (c : con M) : monoid c.quotient :=
function.surjective.monoid _ quotient.surjective_quotient_mk' rfl (λ _ _, rfl) (λ _ _, rfl)

/-- The quotient of a `comm_monoid` by a congruence relation is a `comm_monoid`. -/
@[to_additive "The quotient of an `add_comm_monoid` by an additive congruence
relation is an `add_comm_monoid`."]
instance comm_monoid {M : Type*} [comm_monoid M] (c : con M) :
  comm_monoid c.quotient :=
function.surjective.comm_monoid _ quotient.surjective_quotient_mk' rfl (λ _ _, rfl) (λ _ _, rfl)

end monoids

section groups

variables {M} [group M] [group N] [group P] (c : con M)

/-- Multiplicative congruence relations preserve inversion. -/
@[to_additive "Additive congruence relations preserve negation."]
protected lemma inv : ∀ {w x}, c w x → c w⁻¹ x⁻¹ :=
λ x y h, by simpa using c.symm (c.mul (c.mul (c.refl x⁻¹) h) (c.refl y⁻¹))

/-- Multiplicative congruence relations preserve division. -/
@[to_additive "Additive congruence relations preserve subtraction."]
protected lemma div : ∀ {w x y z}, c w x → c y z → c (w / y) (x / z) :=
λ w x y z h1 h2, by simpa only [div_eq_mul_inv] using c.mul h1 (c.inv h2)

/-- Multiplicative congruence relations preserve integer powers. -/
@[to_additive add_con.zsmul "Additive congruence relations preserve integer scaling."]
protected lemma zpow : ∀ (n : ℤ) {w x}, c w x → c (w ^ n) (x ^ n)
| (int.of_nat n) w x h := by simpa only [zpow_of_nat] using c.pow _ h
| -[1+ n] w x h := by simpa only [zpow_neg_succ_of_nat] using c.inv (c.pow _ h)

/-- The inversion induced on the quotient by a congruence relation on a type with a
    inversion. -/
@[to_additive "The negation induced on the quotient by an additive congruence relation on a type
with an negation."]
instance has_inv : has_inv c.quotient :=
⟨quotient.map' has_inv.inv $ λ a b, c.inv⟩

/-- The division induced on the quotient by a congruence relation on a type with a
    division. -/
@[to_additive "The subtraction induced on the quotient by an additive congruence relation on a type
with a subtraction."]
instance has_div : has_div c.quotient :=
⟨quotient.map₂' (/) $ λ _ _ h₁ _ _ h₂, c.div h₁ h₂⟩

/-- The integer scaling induced on the quotient by a congruence relation on a type with a
    subtraction. -/
instance _root_.add_con.quotient.has_zsmul
  {M : Type*} [add_group M] (c : add_con M) : has_smul ℤ c.quotient :=
⟨λ z, quotient.map' ((•) z) $ λ x y, c.zsmul z⟩

/-- The integer power induced on the quotient by a congruence relation on a type with a
    division. -/
@[to_additive add_con.quotient.has_zsmul]
instance has_zpow : has_pow c.quotient ℤ :=
⟨λ x z, quotient.map' (λ x, x ^ z) (λ x y h, c.zpow z h) x⟩

/-- The quotient of a group by a congruence relation is a group. -/
@[to_additive "The quotient of an `add_group` by an additive congruence relation is
an `add_group`."]
instance group : group c.quotient :=
function.surjective.group _ quotient.surjective_quotient_mk' rfl
  (λ _ _, rfl) (λ _, rfl) (λ _ _, rfl) (λ _ _, rfl) (λ _ _, rfl)

end groups

section units

variables {α : Type*} [monoid M] {c : con M}

/-- In order to define a function `(con.quotient c)ˣ → α` on the units of `con.quotient c`,
where `c : con M` is a multiplicative congruence on a monoid, it suffices to define a function `f`
that takes elements `x y : M` with proofs of `c (x * y) 1` and `c (y * x) 1`, and returns an element
of `α` provided that `f x y _ _ = f x' y' _ _` whenever `c x x'` and `c y y'`. -/
@[to_additive] def lift_on_units (u : units c.quotient)
  (f : Π (x y : M), c (x * y) 1 → c (y * x) 1 → α)
  (Hf : ∀ x y hxy hyx x' y' hxy' hyx', c x x' → c y y' → f x y hxy hyx = f x' y' hxy' hyx') :
  α :=
begin
  refine @con.hrec_on₂ M M _ _ c c (λ x y, x * y = 1 → y * x = 1 → α)
    (u : c.quotient) (↑u⁻¹ : c.quotient)
    (λ (x y : M) (hxy : (x * y : c.quotient) = 1) (hyx : (y * x : c.quotient) = 1),
    f x y (c.eq.1 hxy) (c.eq.1 hyx)) (λ x y x' y' hx hy, _) u.3 u.4,
  ext1, { rw [c.eq.2 hx, c.eq.2 hy] },
  rintro Hxy Hxy' -,
  ext1, { rw [c.eq.2 hx, c.eq.2 hy] },
  rintro Hyx Hyx' -,
  exact heq_of_eq (Hf _ _ _ _ _ _ _ _ hx hy)
end

/-- In order to define a function `(con.quotient c)ˣ → α` on the units of `con.quotient c`,
where `c : con M` is a multiplicative congruence on a monoid, it suffices to define a function `f`
that takes elements `x y : M` with proofs of `c (x * y) 1` and `c (y * x) 1`, and returns an element
of `α` provided that `f x y _ _ = f x' y' _ _` whenever `c x x'` and `c y y'`. -/
add_decl_doc add_con.lift_on_add_units

@[simp, to_additive]
lemma lift_on_units_mk (f : Π (x y : M), c (x * y) 1 → c (y * x) 1 → α)
  (Hf : ∀ x y hxy hyx x' y' hxy' hyx', c x x' → c y y' → f x y hxy hyx = f x' y' hxy' hyx')
  (x y : M) (hxy hyx) :
  lift_on_units ⟨(x : c.quotient), y, hxy, hyx⟩ f Hf = f x y (c.eq.1 hxy) (c.eq.1 hyx) :=
rfl

@[elab_as_eliminator, to_additive]
lemma induction_on_units {p : units c.quotient → Prop} (u : units c.quotient)
  (H : ∀ (x y : M) (hxy : c (x * y) 1) (hyx : c (y * x) 1), p ⟨x, y, c.eq.2 hxy, c.eq.2 hyx⟩) :
  p u :=
begin
  rcases u with ⟨⟨x⟩, ⟨y⟩, h₁, h₂⟩,
  exact H x y (c.eq.1 h₁) (c.eq.1 h₂)
end

end units

section actions

@[to_additive]
instance has_smul {α M : Type*} [mul_one_class M] [has_smul α M] [is_scalar_tower α M M]
  (c : con M) :
  has_smul α c.quotient :=
{ smul := λ a, quotient.map' ((•) a) $ λ x y, c.smul a }

@[to_additive]
lemma coe_smul {α M : Type*} [mul_one_class M] [has_smul α M] [is_scalar_tower α M M] (c : con M)
  (a : α) (x : M) : (↑(a • x) : c.quotient) = a • ↑x := rfl

@[to_additive]
instance mul_action {α M : Type*} [monoid α] [mul_one_class M] [mul_action α M]
  [is_scalar_tower α M M] (c : con M) :
  mul_action α c.quotient :=
{ smul := (•),
  one_smul := quotient.ind' $ by exact λ x, congr_arg quotient.mk' $ one_smul _ _,
  mul_smul := λ a₁ a₂, quotient.ind' $ by exact λ x, congr_arg quotient.mk' $ mul_smul _ _ _ }

instance mul_distrib_mul_action {α M : Type*} [monoid α] [monoid M] [mul_distrib_mul_action α M]
  [is_scalar_tower α M M] (c : con M) :
  mul_distrib_mul_action α c.quotient :=
{ smul := (•),
  smul_one := λ r, congr_arg quotient.mk' $ smul_one _,
  smul_mul := λ r, quotient.ind₂' $ by exact λ m₁ m₂, congr_arg quotient.mk' $ smul_mul' _ _ _,
  .. c.mul_action }

end actions

end con


/-
Copyright (c) 2022 Oliver Nash. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Oliver Nash
-/
import analysis.normed.group.quotient
import topology.instances.add_circle

/-!
# The additive circle as a normed group

We define the normed group structure on `add_circle p`, for `p : ℝ`. For example if `p = 1` then:
`‖(x : add_circle 1)‖ = |x - round x|` for any `x : ℝ` (see `unit_add_circle.norm_eq`).

## Main definitions:

 * `add_circle.norm_eq`: a characterisation of the norm on `add_circle p`

## TODO

 * The fact `inner_product_geometry.angle (real.cos θ) (real.sin θ) = ‖(θ : real.angle)‖`

-/

noncomputable theory

open set int (hiding mem_zmultiples_iff) add_subgroup

namespace add_circle

variables (p : ℝ)

instance : normed_add_comm_group (add_circle p) := add_subgroup.normed_add_comm_group_quotient _

@[simp] lemma norm_coe_mul (x : ℝ) (t : ℝ) :
  ‖(↑(t * x) : add_circle (t * p))‖ = |t| * ‖(x : add_circle p)‖ :=
begin
  have aux : ∀ {a b c : ℝ}, a ∈ zmultiples b → c * a ∈ zmultiples (c * b) := λ a b c h, by
  { simp only [mem_zmultiples_iff] at ⊢ h,
    obtain ⟨n, rfl⟩ := h,
    exact ⟨n, (mul_smul_comm n c b).symm⟩, },
  rcases eq_or_ne t 0 with rfl | ht, { simp, },
  have ht' : |t| ≠ 0 := (not_congr abs_eq_zero).mpr ht,
  simp only [quotient_norm_eq, real.norm_eq_abs],
  conv_rhs { rw [← smul_eq_mul, ← real.Inf_smul_of_nonneg (abs_nonneg t)], },
  simp only [quotient_add_group.mk'_apply, quotient_add_group.eq_iff_sub_mem],
  congr' 1,
  ext z,
  rw mem_smul_set_iff_inv_smul_mem₀ ht',
  show (∃ y, y - t * x ∈ zmultiples (t * p) ∧ |y| = z) ↔ ∃w, w - x ∈ zmultiples p ∧ |w| = |t|⁻¹ * z,
  split,
  { rintros ⟨y, hy, rfl⟩,
    refine ⟨t⁻¹ * y, _, by rw [abs_mul, abs_inv]⟩,
    rw [← inv_mul_cancel_left₀ ht x, ← inv_mul_cancel_left₀ ht p, ← mul_sub],
    exact aux hy, },
  { rintros ⟨w, hw, hw'⟩,
    refine ⟨t * w, _, by rw [← (eq_inv_mul_iff_mul_eq₀ ht').mp hw', abs_mul]⟩,
    rw ← mul_sub,
    exact aux hw, },
end

lemma norm_neg_period (x : ℝ) :
  ‖(x : add_circle (-p))‖ = ‖(x : add_circle p)‖ :=
begin
  suffices : ‖(↑(-1 * x) : add_circle (-1 * p))‖ = ‖(x : add_circle p)‖,
  { rw [← this, neg_one_mul], simp, },
  simp only [norm_coe_mul, abs_neg, abs_one, one_mul],
end

@[simp] lemma norm_eq_of_zero {x : ℝ} : ‖(x : add_circle (0 : ℝ))‖ = |x| :=
begin
  suffices : {y : ℝ | (y : add_circle (0 : ℝ)) = (x : add_circle (0 : ℝ)) } = { x },
  { rw [quotient_norm_eq, this, image_singleton, real.norm_eq_abs, cInf_singleton], },
  ext y,
  simp [quotient_add_group.eq_iff_sub_mem, mem_zmultiples_iff, sub_eq_zero],
end

lemma norm_eq {x : ℝ} : ‖(x : add_circle p)‖ = |x - round (p⁻¹ * x) * p| :=
begin
  suffices : ∀ (x : ℝ), ‖(x : add_circle (1 : ℝ))‖ = |x - round x|,
  { rcases eq_or_ne p 0 with rfl | hp, { simp, },
    intros,
    have hx := norm_coe_mul p x p⁻¹,
    rw [abs_inv, eq_inv_mul_iff_mul_eq₀ ((not_congr abs_eq_zero).mpr hp)] at hx,
    rw [← hx, inv_mul_cancel hp, this, ← abs_mul, mul_sub, mul_inv_cancel_left₀ hp, mul_comm p], },
  clear x p,
  intros,
  rw [quotient_norm_eq, abs_sub_round_eq_min],
  have h₁ : bdd_below (abs '' {m : ℝ | (m : add_circle (1 : ℝ)) = x}) :=
    ⟨0, by simp [mem_lower_bounds]⟩,
  have h₂ : (abs '' {m : ℝ | (m : add_circle (1 : ℝ)) = x}).nonempty := ⟨|x|, ⟨x, rfl, rfl⟩⟩,
  apply le_antisymm,
  { simp only [le_min_iff, real.norm_eq_abs, cInf_le_iff h₁ h₂],
    intros b h,
    refine ⟨mem_lower_bounds.1 h _ ⟨fract x, _, abs_fract⟩,
            mem_lower_bounds.1 h _ ⟨fract x - 1, _, by rw [abs_sub_comm, abs_one_sub_fract]⟩⟩,
    { simp only [mem_set_of_eq, fract, sub_eq_self, quotient_add_group.coe_sub,
        quotient_add_group.eq_zero_iff, int_cast_mem_zmultiples_one], },
    { simp only [mem_set_of_eq, fract, sub_eq_self, quotient_add_group.coe_sub,
        quotient_add_group.eq_zero_iff, int_cast_mem_zmultiples_one, sub_sub,
        (by norm_cast : (⌊x⌋ : ℝ) + 1 = (↑(⌊x⌋ + 1) : ℝ))], }, },
  { simp only [quotient_add_group.mk'_apply, real.norm_eq_abs, le_cInf_iff h₁ h₂],
    rintros b' ⟨b, hb, rfl⟩,
    simp only [mem_set_of_eq, quotient_add_group.eq_iff_sub_mem, mem_zmultiples_iff,
      smul_one_eq_coe] at hb,
    obtain ⟨z, hz⟩ := hb,
    rw [(by { rw hz, abel, } : x = b - z), fract_sub_int, ← abs_sub_round_eq_min],
    convert round_le b 0,
    simp, },
end

lemma norm_eq' (hp : 0 < p) {x : ℝ} :
  ‖(x : add_circle p)‖ = p * |(p⁻¹ * x) - round (p⁻¹ * x)| :=
begin
  conv_rhs { congr, rw ← abs_eq_self.mpr hp.le, },
  rw [← abs_mul, mul_sub, mul_inv_cancel_left₀ hp.ne.symm, norm_eq, mul_comm p],
end

lemma norm_le_half_period {x : add_circle p} (hp : p ≠ 0) : ‖x‖ ≤ |p|/2 :=
begin
  obtain ⟨x⟩ := x,
  change ‖(x : add_circle p)‖ ≤ |p|/2,
  rw [norm_eq, ← mul_le_mul_left (abs_pos.mpr (inv_ne_zero hp)), ← abs_mul, mul_sub, mul_left_comm,
    ← mul_div_assoc, ← abs_mul, inv_mul_cancel hp, mul_one, abs_one],
  exact abs_sub_round (p⁻¹ * x),
end

@[simp] lemma norm_half_period_eq : ‖(↑(p/2) : add_circle p)‖ = |p|/2 :=
begin
  rcases eq_or_ne p 0 with rfl | hp, { simp, },
  rw [norm_eq, ← mul_div_assoc, inv_mul_cancel hp, one_div, round_two_inv, algebra_map.coe_one,
    one_mul, (by linarith : p / 2 - p = -(p / 2)), abs_neg, abs_div, abs_two],
end

lemma norm_coe_eq_abs_iff {x : ℝ} (hp : p ≠ 0) : ‖(x : add_circle p)‖ = |x| ↔ |x| ≤ |p|/2 :=
begin
  refine ⟨λ hx, hx ▸ norm_le_half_period p hp, λ hx, _⟩,
  suffices : ∀ (p : ℝ), 0 < p → |x| ≤ p/2 → ‖(x : add_circle p)‖ = |x|,
  { rcases lt_trichotomy 0 p with hp | rfl | hp,
    { rw abs_eq_self.mpr hp.le at hx,
      exact this p hp hx, },
    { contradiction, },
    { rw ← norm_neg_period,
      rw abs_eq_neg_self.mpr hp.le at hx,
      exact this (-p) (neg_pos.mpr hp) hx, }, },
  clear hx,
  intros p hp hx,
  rcases eq_or_ne x (p/2) with rfl | hx', { simp [abs_div, abs_two], },
  suffices : round (p⁻¹ * x) = 0, { simp [norm_eq, this], },
  rw round_eq_zero_iff,
  obtain ⟨hx₁, hx₂⟩ := abs_le.mp hx,
  replace hx₂ := ne.lt_of_le hx' hx₂,
  split,
  { rwa [← mul_le_mul_left hp, ← mul_assoc, mul_inv_cancel hp.ne.symm, one_mul, mul_neg,
      ← mul_div_assoc, mul_one], },
  { rwa [← mul_lt_mul_left hp, ← mul_assoc, mul_inv_cancel hp.ne.symm, one_mul, ← mul_div_assoc,
      mul_one], },
end

open metric

lemma closed_ball_eq_univ_of_half_period_le
  (hp : p ≠ 0) (x : add_circle p) {ε : ℝ} (hε : |p|/2 ≤ ε) :
  closed_ball x ε = univ :=
eq_univ_iff_forall.mpr $
  λ x, by simpa only [mem_closed_ball, dist_eq_norm] using (norm_le_half_period p hp).trans hε

@[simp]

lemma coe_real_preimage_closed_ball_eq_Union (x ε : ℝ) :
  coe⁻¹' closed_ball (x : add_circle p) ε = ⋃ (z : ℤ), closed_ball (x + z • p) ε :=
begin
  rcases eq_or_ne p 0 with rfl | hp, { simp [Union_const], },
  ext y,
  simp only [dist_eq_norm, mem_preimage, mem_closed_ball, zsmul_eq_mul, mem_Union, real.norm_eq_abs,
    ← quotient_add_group.coe_sub, norm_eq, ← sub_sub],
  refine ⟨λ h, ⟨round (p⁻¹ * (y - x)), h⟩, _⟩,
  rintros ⟨n, hn⟩,
  rw [← mul_le_mul_left (abs_pos.mpr $ inv_ne_zero hp), ← abs_mul, mul_sub, mul_comm _ p,
    inv_mul_cancel_left₀ hp] at hn ⊢,
  exact (round_le (p⁻¹ * (y - x)) n).trans hn,
end

lemma coe_real_preimage_closed_ball_inter_eq
  {x ε : ℝ} (s : set ℝ) (hs : s ⊆ closed_ball x (|p|/2)) :
  coe⁻¹' closed_ball (x : add_circle p) ε ∩ s = if ε < |p|/2 then (closed_ball x ε) ∩ s else s :=
begin
  cases le_or_lt (|p|/2) ε with hε hε,
  { rcases eq_or_ne p 0 with rfl | hp,
    { simp only [abs_zero, zero_div] at hε,
      simp only [not_lt.mpr hε, coe_real_preimage_closed_ball_period_zero, abs_zero, zero_div,
        if_false, inter_eq_right_iff_subset],
      exact hs.trans (closed_ball_subset_closed_ball $ by simp [hε]), },
    simp [closed_ball_eq_univ_of_half_period_le p hp ↑x hε, not_lt.mpr hε], },
  { suffices : ∀ (z : ℤ), closed_ball (x + z • p) ε ∩ s = if z = 0 then closed_ball x ε ∩ s else ∅,
    { simp [-zsmul_eq_mul, ← quotient_add_group.coe_zero, coe_real_preimage_closed_ball_eq_Union,
        Union_inter, Union_ite, this, hε], },
    intros z,
    simp only [real.closed_ball_eq_Icc, zero_sub, zero_add] at ⊢ hs,
    rcases eq_or_ne z 0 with rfl | hz, { simp, },
    simp only [hz, zsmul_eq_mul, if_false, eq_empty_iff_forall_not_mem],
    rintros y ⟨⟨hy₁, hy₂⟩, hy₀⟩,
    obtain ⟨hy₃, hy₄⟩ := hs hy₀,
    rcases lt_trichotomy 0 p with hp | rfl | hp,
    { cases int.cast_le_neg_one_or_one_le_cast_of_ne_zero ℝ hz with hz' hz',
      { have : ↑z * p ≤ - p, nlinarith,
        linarith [abs_eq_self.mpr hp.le] },
      { have : p ≤ ↑z * p, nlinarith,
        linarith [abs_eq_self.mpr hp.le] } },
    { simp only [mul_zero, add_zero, abs_zero, zero_div] at hy₁ hy₂ hε,
      linarith },
    { cases int.cast_le_neg_one_or_one_le_cast_of_ne_zero ℝ hz with hz' hz',
      { have : - p ≤ ↑z * p, nlinarith,
        linarith [abs_eq_neg_self.mpr hp.le] },
      { have : ↑z * p ≤ p, nlinarith,
        linarith [abs_eq_neg_self.mpr hp.le] } } },
end

section finite_order_points

variables {p} [hp : fact (0 < p)]
include hp

lemma norm_div_nat_cast {m n : ℕ} :
  ‖(↑((↑m / ↑n) * p) : add_circle p)‖ = p * (↑(min (m % n) (n - m % n)) / n) :=
begin
  have : p⁻¹ * (↑m / ↑n * p) = ↑m / ↑n, { rw [mul_comm _ p, inv_mul_cancel_left₀ hp.out.ne.symm], },
  rw [norm_eq' p hp.out, this, abs_sub_round_div_nat_cast_eq],
end

lemma exists_norm_eq_of_fin_add_order {u : add_circle p} (hu : is_of_fin_add_order u) :
  ∃ (k : ℕ), ‖u‖ = p * (k / add_order_of u) :=
begin
  let n := add_order_of u,
  change ∃ (k : ℕ), ‖u‖ = p * (k / n),
  obtain ⟨m, -, -, hm⟩ := exists_gcd_eq_one_of_is_of_fin_add_order hu,
  refine ⟨min (m % n) (n - m % n), _⟩,
  rw [← hm, norm_div_nat_cast],
end

lemma le_add_order_smul_norm_of_is_of_fin_add_order
  {u : add_circle p} (hu : is_of_fin_add_order u) (hu' : u ≠ 0) :
  p ≤ add_order_of u • ‖u‖ :=
begin
  obtain ⟨n, hn⟩ := exists_norm_eq_of_fin_add_order hu,
  replace hu : (add_order_of u : ℝ) ≠ 0, { norm_cast, exact (add_order_of_pos_iff.mpr hu).ne.symm },
  conv_lhs { rw ← mul_one p, },
  rw [hn, nsmul_eq_mul, ← mul_assoc, mul_comm _ p, mul_assoc, mul_div_cancel' _ hu,
    mul_le_mul_left hp.out, nat.one_le_cast, nat.one_le_iff_ne_zero],
  contrapose! hu',
  simpa only [hu', algebra_map.coe_zero, zero_div, mul_zero, norm_eq_zero] using hn,
end

end finite_order_points

end add_circle

namespace unit_add_circle

lemma norm_eq {x : ℝ} : ‖(x : unit_add_circle)‖ = |x - round x| := by simp [add_circle.norm_eq]

end unit_add_circle


import Lib.Logic.Basic
import Lib.Data.Nat
import Lib.Data.Ordering
import Lib.Meta.DeclGraph
import Lib.Tactic

variable (α : Type u) [LE α]

class Preorder extends LT α, @Reflexive α (.≤.) where
  trans {x y z : α} :
    x ≤ y → y ≤ z → x ≤ z
  lt_iff {x y : α} :
    x < y ↔ x ≤ y ∧ ¬ y ≤ x

namespace Preorder

variable {α} [LE α] [Preorder α] {x y : α}

@[auto]
theorem le_of_eq : x = y → x ≤ y := by
intros h; subst h; auto

theorem lt_irrefl (x : α) : ¬ x < x :=
by rw [lt_iff]; auto

theorem lt_antisymm {x y : α} : x < y → y < x → False :=
by simp [lt_iff]; auto

variable {x y z w : α}

theorem lt_of_le_of_lt_of_le
        (h₀ : x ≤ y)
        (h₁ : y < z)
        (h₂ : z ≤ w) :
  x < w := by
rw [lt_iff] at h₁ ⊢
cases h₁ with | intro h₁ hb =>
constructor
next =>
  repeat
    first
    | assumption
    | apply Preorder.trans
next =>
  intros ha; apply hb; clear hb
  repeat
    first
    | assumption
    | apply Preorder.trans

theorem lt_of_le_of_lt
        (h₀ : x ≤ y)
        (h₁ : y < z) :
  x < z :=
lt_of_le_of_lt_of_le h₀ h₁ (Reflexive.refl _)

theorem lt_of_lt_of_le
        (h₁ : x < y)
        (h₂ : y ≤ z) :
  x < z :=
lt_of_le_of_lt_of_le (Reflexive.refl _) h₁ h₂

@[auto]
theorem le_of_lt : x < y → x ≤ y :=
by rw [lt_iff]; auto

instance : @Trans α α α LE.le LE.le LE.le where
  trans := Preorder.trans

instance : @Trans α α α LT.lt LT.lt LT.lt where
  trans {x y z} h₀ h₁ := lt_of_le_of_lt (le_of_lt h₀) h₁

theorem indirect_le_l {x y : α} :
  x ≤ y ↔ ∀ z, z ≤ x → z ≤ y := by
constructor
next =>
  intros; trans x <;> auto
next =>
  intros h; apply h; refl

theorem indirect_le_r {x y : α} :
  x ≤ y ↔ ∀ z, y ≤ z → x ≤ z := by
constructor
next =>
  intros; trans y <;> auto
next =>
  intros h; apply h; refl

end Preorder

class PartialOrder extends Preorder α where
  antisymm {x y : α} : x ≤ y → y ≤ x → x = y

namespace PartialOrder

open Preorder

variable {α} [LE α] [PartialOrder α] {x y : α}

theorem le_iff_lt_or_eq : x ≤ y ↔ x < y ∨ x = y := by
rw [lt_iff]
constructor <;> intros h
next =>
  by_cases h : y ≤ x; right
  . auto [antisymm]
  . left; auto
next =>
  cases h <;> auto

theorem indirect_eq_l {x y : α} :
  x = y ↔ ∀ z, z ≤ x ↔ z ≤ y := by
constructor
next =>
  intros h z; subst h; refl
next =>
  intros h; apply antisymm
  . rw [← h]; refl
  . rw [h]; refl

theorem indirect_eq_r {x y : α} :
  x = y ↔ ∀ z, x ≤ z ↔ y ≤ z := by
constructor
next =>
  intros h z; subst h; refl
next =>
  intros h; apply antisymm
  . rw [h]; refl
  . rw [← h]; refl

end PartialOrder

class TotalOrder extends PartialOrder α where
  total (x y : α) : x ≤ y ∨ y ≤ x

namespace TotalOrder

open Preorder PartialOrder

variable {α} [LE α] [TotalOrder α] (x y : α)

@[simp]
theorem not_le : ¬ x ≤ y ↔ y < x := by
rw [lt_iff]
constructor <;> intros h
next =>
  cases total x y <;> auto
next =>
  auto

@[simp]
theorem not_lt : ¬ x < y ↔ y ≤ x := by
rw [lt_iff]
constructor <;> intros h
next =>
  byContradiction h
  cases total x y <;> auto
next =>
  auto

theorem trichonomy : x < y ∨ x = y ∨ y < x := by
cases total x y
next h =>
  rw [le_iff_lt_or_eq] at h
  cases h
  . left; assumption
  . right; left; assumption
next h =>
  rw [le_iff_lt_or_eq] at h
  cases h
  . right; right; assumption
  . right; left; subst x; auto

end TotalOrder

class DecidableTotalOrder extends TotalOrder α, Ord α where
  compare_eq_lt_iff {x y : α} :
    compare x y = Ordering.lt ↔ x < y
  flip_compare {x y : α} :
    (compare x y).flip = compare y x

namespace DecidableTotalOrder
attribute [simp] compare_eq_lt_iff

open Ord Preorder PartialOrder TotalOrder
variable {α} [LE α] [DecidableTotalOrder α]

@[simp]
theorem compare_eq_eq_iff {x y : α} :
  compare x y = Ordering.eq ↔ x = y := by
constructor <;> intros h
next =>
  apply antisymm
  next =>
    match trichonomy x y with
    | Or.inl h => auto
    | Or.inr (Or.inl h) => auto
    | Or.inr (Or.inr h') =>
      rw [← compare_eq_lt_iff] at h'
      have h₂ := congrArg Ordering.flip h'
      simp [flip_compare,h] at h₂
  next =>
    rw [← not_lt, ← compare_eq_lt_iff, h]
    intro h; cases h
next =>
  subst h
  have h := lt_irrefl x
  rw [← compare_eq_lt_iff] at h
  have h' : ¬ compare x x = Ordering.gt := by
    intros h'; apply h
    have h' := congrArg Ordering.flip h'
    rw [flip_compare] at h'; auto
  cases h : compare x x <;> auto

@[simp]
theorem compare_eq_gt_iff {x y : α} :
  compare x y = Ordering.gt ↔ y < x := by
rw [← compare_eq_lt_iff]
constructor <;> intro h
<;> have h := congrArg Ordering.flip h
<;> simp [flip_compare] at h
<;> assumption

instance : DecidableEq α
| x, y =>
  Decidable.congr compare_eq_eq_iff

instance : @DecidableRel α (.<.)
| x, y => Decidable.congr compare_eq_lt_iff

instance : @DecidableRel α (.≤.)
| x, y => Decidable.congr <| by
  show compare x y ≠ Ordering.gt ↔ x ≤ y
  rw [← not_lt, ← compare_eq_gt_iff]
  refl

instance : BEq α where
  beq x y := decide (x = y)

open Ordering Ordering.Spec
open Reflexive

def compareSpec (x y : α) : Ordering.Spec x y (compare x y) :=
match h: compare x y with
| lt => isLT (by simp at h; assumption)
| eq => isEQ (by simp at h; assumption)
| gt => isGT (by simp at h; assumption)

def compareSpec' {x y : α} {cmp}
  (h : compare x y = cmp):
  Ordering.Spec x y cmp :=
h ▸ compareSpec x y

def pcompare (x y : α) : POrdering x y :=
have ⟨ord, h⟩ : { ord // compare x y = ord } := ⟨_, rfl⟩
match compareSpec' h with
| isLT h => POrdering.isLT h
| isEQ h => POrdering.isEQ h
| isGT h => POrdering.isGT h

theorem toOrdering_pcompare (x y : α) :
  (pcompare x y).toOrdering = compare x y := by
unfold pcompare
generalize h : { val := compare x y, property := rfl : Subtype _ } = z
cases z with | mk z hz =>
simp; clear h
cases compareSpec' hz
<;> simp [hz, POrdering.toOrdering]

macro "compare " x:term ", " y:term : tactic =>
  `(tactic|
    rw [← toOrdering_pcompare x y];
    cases pcompare x y <;> simp only [toOrdering] )

theorem and_comm {p q : Prop} :
  p ∧ q ↔ q ∧ p := by auto

theorem iff_and_iff_implies_l {p q : Prop} :
  (p ↔ p ∧ q) ↔ (p → q) := by
constructor
next =>
  intro h; rw [h]; auto
next =>
  intro h
  try auto

theorem iff_and_iff_implies_r {p q : Prop} :
  (p ↔ q ∧ p) ↔ (p → q) := by
constructor
next =>
  intro h; rw [h]; auto
next =>
  intro h
  try auto

@[simp]
theorem max_le_iff {x y z : α} :
  max x y ≤ z ↔ x ≤ z ∧ y ≤ z := by
simp [max]; split
<;> simp [iff_and_iff_implies_l, iff_and_iff_implies_r]
<;> intro h
next =>
  trans x <;> auto
next h' =>
  rw [not_lt] at h'
  trans y <;> auto

@[simp]
theorem le_min_iff {x y z : α} :
  z ≤ min x y ↔ z ≤ x ∧ z ≤ y := by
simp [min]; split
<;> simp [iff_and_iff_implies_l, iff_and_iff_implies_r]
<;> intro h
next =>
  trans x <;> auto
next h' =>
  rw [not_le] at h'
  trans y <;> auto

@[simp]
theorem min_le_iff {x y z : α} :
  min x y ≤ z ↔ x ≤ z ∨ y ≤ z := by
rw [indirect_le_l]; simp
constructor
next =>
  intros h
  cases total x y
  next h₀ =>
    have h₁ : x ≤ x := refl x
    left; apply h; auto
  next h₀ =>
    have h₁ : y ≤ y := refl _
    right; apply h; auto
next =>
  intros h w h'
  cases h'; cases h
  . trans x <;> assumption
  . trans y <;> assumption

@[simp]
theorem le_max_iff {x y z : α} :
  z ≤ max x y ↔ z ≤ x ∨ z ≤ y := by
rw [indirect_le_r]; simp
constructor
next =>
  intros h
  cases total x y
  next h₀ =>
    have h₁ : x ≤ x := refl x
    right; apply h; auto
  next h₀ =>
    have h₁ : y ≤ y := refl _
    left; apply h; auto
next =>
  intros h w h'
  cases h'; cases h
  . trans x <;> assumption
  . trans y <;> assumption

@[auto]
theorem le_max_l {x y : α} :
  x ≤ max x y :=
by rw [indirect_le_r]; simp; auto

@[auto]
theorem le_max_r {x y : α} :
  y ≤ max x y :=
by rw [indirect_le_r]; simp; auto

@[auto]
theorem min_le_l {x y : α} :
  min x y ≤ x :=
by rw [indirect_le_l]; simp; auto

@[auto]
theorem min_le_r {x y : α} :
  min x y ≤ y :=
by rw [indirect_le_l]; simp; auto

theorem max_comm {x y : α} :
  max x y = max y x := by
rw [indirect_eq_r]; simp; auto with 7

theorem min_comm {x y : α} :
  min x y = min y x := by
rw [indirect_eq_l]; simp; auto with 7

theorem max_assoc {x y z : α} :
  max (max x y) z = max x (max y z) := by
rw [indirect_eq_r]; simp; auto with 8

theorem min_assoc {x y z : α} :
  min (min x y) z = min x (min y z) := by
rw [indirect_eq_l]; simp; auto with 8

@[simp]
theorem max_eq_self_iff_l {x y : α} :
  max x y = x ↔ y ≤ x := by
constructor
next =>
  intros h; rw [← h]; auto
next =>
  intros h; rw [indirect_eq_r]; simp
  intros z
  constructor <;> intros h'
  next => auto
  next =>
    constructor; auto
    trans x <;> auto

@[simp]
theorem max_eq_self_iff_r {x y : α} :
  max x y = y ↔ x ≤ y := by
rw [max_comm, max_eq_self_iff_l]; refl

@[simp]
theorem min_eq_self_iff_l {x y : α} :
  min x y = x ↔ x ≤ y := by
constructor
next =>
  intros h; rw [← h]; auto
next =>
  intros h; rw [indirect_eq_l]; simp
  intros z
  constructor <;> intros h'
  next => auto
  next =>
    constructor; auto
    trans x <;> auto

@[simp]
theorem min_eq_self_iff_r {x y : α} :
  min x y = y ↔ y ≤ x := by
rw [min_comm, min_eq_self_iff_l]; refl

end DecidableTotalOrder

namespace Nat
open Preorder

instance : DecidableTotalOrder Nat where
  antisymm := Nat.le_antisymm
  trans := Nat.le_trans
  lt_iff := by
    intros; rw [Nat.lt_iff_not_le]
    constructor </> auto
    intros h
    constructor </> auto
    have h := Nat.gt_of_not_le h
    auto [Nat.le_of_lt]
  total := Nat.le_total
  compare_eq_lt_iff := by
    intros
    simp [compare, compareOfLessAndEq]
    split; auto
    next x y h =>
      by_cases h' : x = y
      next =>
        rw [ite_pos] </> assumption
        constructor
        . intros h; cases h
        . auto
      next =>
        rw [ite_neg] </> assumption
        constructor
        . intros h; cases h
        . auto
  flip_compare := by
    intros; simp [compare, compareOfLessAndEq]
    split
    next x y h =>
      have : ¬ y < x := by
        intros h'; have := Nat.lt_trans h h'
        cases Nat.lt_irrefl _ this
      have : ¬ y = x := by
        intro h; subst h; auto
      simp [*]
    split
    next x y h h' =>
      subst h'
      have h₀ : ¬ x < x := by
        assumption
      simp [h₀]
    next x y h h' =>
      have : y < x := by
        have := Nat.le_of_not_gt h
        rw [Nat.lt_iff_not_le]
        auto [Nat.le_antisymm]
      simp [*]

end Nat


-- Regla de introducción del bicondicional
-- =======================================

-- ----------------------------------------------------
-- Ej. 1. (p. 17) Demostrar
--    P ∧ Q ↔ Q ∧ P
-- ----------------------------------------------------

import tactic

variables (P Q : Prop)

-- 1ª demostración
example : P ∧ Q ↔ Q ∧ P :=
iff.intro
  ( assume h1 : P ∧ Q,
    have h2 : P,
      from and.elim_left h1,
    have h3 : Q,
      from and.elim_right h1,
    show Q ∧ P,
      from and.intro h3 h2)
  ( assume h4 : Q ∧ P,
    have h5 : Q,
      from and.elim_left h4,
    have h6 : P,
      from and.elim_right h4,
    show P ∧ Q,
      from and.intro h6 h5)

-- 2ª demostración
example : P ∧ Q ↔ Q ∧ P :=
iff.intro
  ( assume h1 : P ∧ Q,
    have h2 : P,
      from h1.1,
    have h3 : Q,
      from h1.2,
    show Q ∧ P,
      from and.intro h3 h2)
  ( assume h4 : Q ∧ P,
    have h5 : Q,
      from h4.1,
    have h6 : P,
      from h4.2,
    show P ∧ Q,
      from and.intro h6 h5)

-- 3ª demostración
example : P ∧ Q ↔ Q ∧ P :=
iff.intro
  ( assume h1 : P ∧ Q,
    have h2 : P := h1.1,
    have h3 : Q := h1.2,
    show Q ∧ P,
      from and.intro h3 h2)
  ( assume h4 : Q ∧ P,
    have h5 : Q := h4.1,
    have h6 : P := h4.2,
    show P ∧ Q,
      from and.intro h6 h5)

-- 4ª demostración
example : P ∧ Q ↔ Q ∧ P :=
iff.intro
  ( assume h1 : P ∧ Q,
    show Q ∧ P,
      from and.intro h1.2 h1.1)
  ( assume h4 : Q ∧ P,
    show P ∧ Q,
      from and.intro h4.2 h4.1)

-- 5ª demostración
example : P ∧ Q ↔ Q ∧ P :=
iff.intro
  ( assume h1 : P ∧ Q, and.intro h1.2 h1.1)
  ( assume h4 : Q ∧ P, and.intro h4.2 h4.1)

-- 6ª demostración
example : P ∧ Q ↔ Q ∧ P :=
iff.intro
  ( assume h1 : P ∧ Q, ⟨h1.2, h1.1⟩)
  ( assume h4 : Q ∧ P, ⟨h4.2, h4.1⟩)

-- 7ª demostración
example : P ∧ Q ↔ Q ∧ P :=
iff.intro
  (λ h, ⟨h.2, h.1⟩)
  (λ h, ⟨h.2, h.1⟩)

-- 8ª demostración
example : P ∧ Q ↔ Q ∧ P :=
iff.intro
  (λ ⟨hP, hQ⟩, ⟨hQ, hP⟩)
  (λ ⟨hQ, hP⟩, ⟨hP, hQ⟩)

-- 9ª demostración
lemma aux :
  P ∧ Q → Q ∧ P :=
λ h, ⟨h.2, h.1⟩

example : P ∧ Q ↔ Q ∧ P :=
iff.intro (aux P Q) (aux Q P)

-- 10ª demostración
example : P ∧ Q ↔ Q ∧ P :=
-- by library_search
and.comm

-- 11ª demostración
example : P ∧ Q ↔ Q ∧ P :=
begin
  split,
  { intro h1,
    cases h1 with h2 h3,
    split,
    { exact h3, },
    { exact h2, }},
  { intro h4,
    cases h4 with h5 h6,
    split,
    { exact h6, },
    { exact h5, }},
end

-- 12ª demostración
example : P ∧ Q ↔ Q ∧ P :=
begin
  split,
  { rintro ⟨h2, h3⟩,
    split,
    { exact h3, },
    { exact h2, }},
  { rintro ⟨h5, h6⟩,
    split,
    { exact h6, },
    { exact h5, }},
end

-- 13ª demostración
example : P ∧ Q ↔ Q ∧ P :=
begin
  constructor,
  { rintro ⟨h2, h3⟩,
    constructor,
    { exact h3, },
    { exact h2, }},
  { rintro ⟨h5, h6⟩,
    constructor,
    { exact h6, },
    { exact h5, }},
end

-- 14ª demostración
example : P ∧ Q ↔ Q ∧ P :=
-- by hint
by tauto

-- 15ª demostración
example : P ∧ Q ↔ Q ∧ P :=
by finish


import category_theory.category.default

universes v u  -- The order in this declaration matters: v often needs to be explicitly specified while u often can be omitted

namespace category_theory

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

--rewrite this

/-
# Category world

## Level 7: Composition of monomorphisms

Now we show that the composition of two monomorphisms produces another monomorphism.-/

/- Lemma
If $$f : X ⟶ Y$$ and $$g : X ⟶ Y$$ are monomorphisms, then $$f ≫ g : X ⟶ Z$$ is a monomorphism.
-/
lemma mono_of_mono' {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) [mono (f ≫ g)] : mono f :=
begin
  split,
  intros Z h l hyp,
  rw ← cancel_mono (f ≫ g),
  rw ← category.assoc,
  rw hyp,
  rw category.assoc,
end

end category_theory


import data.int.modeq data.int.basic data.nat.modeq data.equiv data.fintype data.nat.prime data.nat.gcd data.pnat .int_gcd data.nat.prime

@[simp] lemma int.mod_mod (a b : ℤ) : a % b % b = a % b :=
by conv {to_rhs, rw [← int.mod_add_div a b, int.add_mul_mod_self_left]}

@[simp] lemma int.mod_neg_mod (a b : ℤ) : (-(a % b) % b) = (-a % b) :=
by conv {to_rhs, rw [← int.mod_add_div a b, neg_add, neg_mul_eq_mul_neg, int.add_mul_mod_self_left]}

open nat nat.modeq int

def Zmod (n : ℕ) := subtype (< n)

namespace Zmod

--Copied from core, but marked as private in core
lemma mlt {n b : nat} : ∀ {a}, n > a → b % n < n
| 0     h := nat.mod_lt _ h
| (a+1) h :=
  have n > 0, from lt.trans (nat.zero_lt_succ _) h,
  nat.mod_lt _ this

class pos (n : ℕ) := (pos : 0 < n)

attribute [class] nat.prime

instance pos_of_prime (p : ℕ) [hp : nat.prime p] : pos p := ⟨hp.pos⟩

def add_aux {n : ℕ} (a b : Zmod n) : Zmod n :=
⟨(a.1 + b.1) % n, mlt a.2⟩

def mul_aux {n : ℕ} (a b : Zmod n) : Zmod n :=
⟨(a.1 * b.1) % n, mlt a.2⟩

def neg_aux {n : ℕ} (a : Zmod n) : Zmod n :=
⟨nat_mod (-(a.1 : ℤ)) n,
begin
  cases n with n,
  { exact (nat.not_lt_zero _ a.2).elim },
  { have h : (nat.succ n : ℤ) ≠ 0 := dec_trivial,
    rw [← int.coe_nat_lt, nat_mod, to_nat_of_nonneg (int.mod_nonneg _ h)],
    exact int.mod_lt _ h }
end⟩

instance (n : ℕ) : add_comm_semigroup (Zmod n) :=
{ add := add_aux,
  add_assoc := λ ⟨a, ha⟩ ⟨b, hb⟩ ⟨c, hc⟩, subtype.eq
    (show ((a + b) % n + c) ≡ (a + (b + c) % n) [MOD n],
    from calc ((a + b) % n + c) ≡ a + b + c [MOD n] : modeq_add (nat.mod_mod _ _) rfl
      ... ≡ a + (b + c) [MOD n] : by rw add_assoc
      ... ≡ (a + (b + c) % n) [MOD n] : modeq_add rfl (nat.mod_mod _ _).symm),
  add_comm := λ a b, subtype.eq (show (a.1 + b.1) % n = (b.1 + a.1) % n, by rw add_comm) }

instance (n : ℕ) : comm_semigroup (Zmod n) :=
{ mul := mul_aux,
  mul_assoc := λ ⟨a, ha⟩ ⟨b, hb⟩ ⟨c, hc⟩, subtype.eq
    (calc ((a * b) % n * c) ≡ a * b * c [MOD n] : modeq_mul (nat.mod_mod _ _) rfl
      ... ≡ a * (b * c) [MOD n] : by rw mul_assoc
      ... ≡ a * (b * c % n) [MOD n] : modeq_mul rfl (nat.mod_mod _ _).symm),
  mul_comm := λ a b, subtype.eq (show (a.1 * b.1) % n = (b.1 * a.1) % n, by rw mul_comm) }

def one_aux (n : ℕ) [h0 : pos n] : Zmod n := ⟨1 % n, nat.mod_lt _ h0.pos⟩

lemma one_mul_aux (n : ℕ) [h0 : pos n] : ∀ a : Zmod n, one_aux n * a = a :=
λ ⟨a, ha⟩, subtype.eq (show (1 % n * a) % n = a,
begin
  resetI,
  clear _fun_match,
  cases n with n,
  { simp },
  { cases n with n,
    { rw [nat.mod_self, zero_mul];
      exact (nat.eq_zero_of_le_zero (le_of_lt_succ ha)).symm },
    { have h : 1 < n + 2 := dec_trivial,
      have ha : a < succ (succ n) := ha,
      rw [nat.mod_eq_of_lt h, one_mul, nat.mod_eq_of_lt ha] } }
end)

lemma left_distrib_aux (n : ℕ) : ∀ a b c : Zmod n, a * (b + c) = a * b + a * c :=
λ ⟨a, ha⟩ ⟨b, hb⟩ ⟨c, hc⟩, subtype.eq
(calc a * ((b + c) % n) ≡ a * (b + c) [MOD n] : modeq_mul rfl (nat.mod_mod _ _)
  ... ≡ a * b + a * c [MOD n] : by rw mul_add
  ... ≡ (a * b) % n + (a * c) % n [MOD n] : modeq_add (nat.mod_mod _ _).symm (nat.mod_mod _ _).symm)

instance (n : ℕ) : has_neg (Zmod n) := ⟨neg_aux⟩

instance (n : ℕ) : distrib (Zmod n) :=
{ left_distrib := left_distrib_aux n,
  right_distrib := λ a b c, by rw [mul_comm, left_distrib_aux, mul_comm _ b, mul_comm]; refl,
  ..Zmod.add_comm_semigroup n,
  ..Zmod.comm_semigroup n }

instance (n : ℕ) [h0 : pos n] : comm_ring (Zmod n) :=
{ zero := ⟨0, h0.pos⟩,
  zero_add := λ ⟨a, ha⟩, subtype.eq (show (0 + a) % n = a, by rw zero_add; exact nat.mod_eq_of_lt ha),
  add_zero := λ ⟨a, ha⟩, subtype.eq (nat.mod_eq_of_lt ha),
  neg := has_neg.neg,
  add_left_neg :=
    λ ⟨a, ha⟩, subtype.eq (show (((-a : ℤ) % n).to_nat + a) % n = 0,
      from int.coe_nat_inj
      begin
        have hn : (n : ℤ) ≠ 0 := (ne_of_lt (int.coe_nat_lt.2 h0.pos)).symm,
        rw [int.coe_nat_mod, int.coe_nat_add, to_nat_of_nonneg (int.mod_nonneg _ hn), add_comm],
        simp,
      end),
  one := ⟨1 % n, nat.mod_lt _ h0.pos⟩,
  one_mul := one_mul_aux n,
  mul_one := λ a, by rw mul_comm; exact one_mul_aux n a,
  ..Zmod.distrib n,
  ..Zmod.add_comm_semigroup n,
  ..Zmod.comm_semigroup n }

-- instance {n : ℕ+} : has_coe ℤ (Zmod n) := ⟨of_int n⟩

-- instance Zmod_coe_nat (n : ℕ+) : has_coe ℕ (Zmod n) := ⟨of_nat n⟩

-- @[simp] lemma coe_nat_coe_int (n : ℕ+) (a : ℕ) : (((a : ℕ) : ℤ) : Zmod n) = a :=
-- subtype.eq $ int.coe_nat_inj $ (show (nat_mod a n : ℤ)= a % n, by simp)

-- lemma coe_eq_of_nat {n : ℕ+} (a : ℕ) : (a : Zmod n) = of_nat n a := rfl

-- lemma coe_int_add (n : ℕ+) (a b : ℤ) : ((a + b : ℤ) : Zmod n) = a + b :=
-- subtype.eq (show nat_mod (a + b) n = (nat_mod a n + nat_mod b n) % n,
--   from int.coe_nat_inj (by simp [int.coe_nat_add]))

-- lemma coe_int_mul (n : ℕ+) (a b : ℤ) : ((a * b : ℤ) : Zmod n) = a * b :=
-- subtype.eq (show nat_mod (a * b) n = (nat_mod a n * nat_mod b n) % n,
--   from int.coe_nat_inj (begin
--     rw [coe_coe, nat_mod_coe_pnat, int.coe_nat_mod, int.coe_nat_mul, nat_mod_coe_pnat, nat_mod_coe_pnat],
--     exact int.modeq.modeq_mul (int.mod_mod _ _).symm (int.mod_mod _ _).symm
--   end))

-- lemma coe_int_neg (n : ℕ+) (a : ℤ) : ((-a : ℤ) : Zmod n) = -a :=
-- subtype.eq (show nat_mod (-a) n = nat_mod (-↑(nat_mod a n)) n,
-- from int.coe_nat_inj (by simp))

-- lemma coe_int_sub (n : ℕ+) (a b : ℤ) : ((a - b : ℤ) : Zmod n) = a - b :=
-- by rw [sub_eq_add_neg, coe_int_add, coe_int_neg, sub_eq_add_neg]

-- lemma coe_nat_add (n : ℕ+) (a b : ℕ) : ((a + b : ℕ) : Zmod n) = a + b :=
-- subtype.eq (modeq_add (nat.mod_mod _ _).symm (nat.mod_mod _ _).symm)

-- lemma coe_nat_mul (n : ℕ+) (a b : ℕ) : ((a * b : ℕ) : Zmod n) = a * b :=
-- subtype.eq (modeq_mul (nat.mod_mod _ _).symm (nat.mod_mod _ _).symm)

-- lemma coe_nat_sub (n : ℕ+) {a b : ℕ} (h : b ≤ a) : ((a - b : ℕ) : Zmod n) = a - b :=
-- by rw [← coe_nat_coe_int, int.coe_nat_sub h, coe_int_sub]; simp

-- @[simp] lemma coe_eq_zero' (n : ℕ+) : ((n : ℕ) : Zmod n) = 0 :=
-- subtype.eq (nat.mod_self _)

-- lemma eq_iff_modeq_nat {n : ℕ+} {a b : ℕ} : (a : Zmod n) = b ↔ a ≡ b [MOD n] :=
-- ⟨subtype.mk.inj, λ h, subtype.eq h⟩

-- @[simp] lemma val_coe {n : ℕ+} (a : Zmod n) : (a.val : Zmod n) = a :=
-- subtype.eq (nat.mod_eq_of_lt a.2)

-- lemma eq_iff_modeq_int {n : ℕ+} {a b : ℤ} : (a : Zmod n) = b ↔ a ≡ b [ZMOD n] :=
-- ⟨λ h, begin
--   have := (int.coe_nat_eq_coe_nat_iff _ _).2 (subtype.mk.inj h),
--   rw [coe_coe, nat_mod_coe_pnat, nat_mod_coe_pnat] at this,
--   exact this
-- end,
-- λ h, subtype.eq (show nat_mod a n = nat_mod b n, from
--   int.coe_nat_inj begin
--   rw [coe_coe, nat_mod_coe_pnat, nat_mod_coe_pnat],
--   exact h
-- end)⟩

-- @[simp] lemma coe_int_mod (n : ℕ+) (a : ℤ) : ((a % ((n : ℕ) : ℤ) : ℤ) : Zmod n) = a :=
-- eq_iff_modeq_int.2 (int.mod_mod _ _)

-- @[simp] lemma coe_nat_mod (n : ℕ+) (a : ℕ) : ((a % n : ℕ) : Zmod n) = a :=
-- eq_iff_modeq_nat.2 (nat.mod_mod _ _)

-- @[simp] lemma coe_nat_zero (n : ℕ+) : ((0 : ℕ) : Zmod n) = 0 :=
-- subtype.eq (nat.zero_mod _)

-- @[simp] lemma coe_int_zero (n : ℕ+) : ((0 : ℤ) : Zmod n) = 0 :=
-- by rw [← int.coe_nat_zero, coe_nat_coe_int, coe_nat_zero]

-- @[simp] lemma coe_nat_one (n : ℕ+) : ((1 : ℕ) : Zmod n) = 1 := rfl

-- @[simp] lemma coe_int_one (n : ℕ+) : ((1 : ℤ) : Zmod n) = 1 := rfl

-- @[simp] lemma coe_nat_bit0 (n : ℕ+) (a : ℕ) : ((bit0 a : ℕ) : Zmod n) = bit0 (a : Zmod n) := coe_nat_add _ _ _

-- @[simp] lemma coe_nat_bit1 (n : ℕ+) (a : ℕ) : ((bit1 a : ℕ) : Zmod n) = bit1 (a : Zmod n) :=
-- by rw [bit1, bit1, coe_nat_add, coe_nat_bit0, coe_nat_one]

-- @[simp] lemma coe_int_bit0 (n : ℕ+) (a : ℤ) : ((bit0 a : ℤ) : Zmod n) = bit0 (a : Zmod n) := coe_int_add _ _ _

-- @[simp] lemma coe_int_bit1 (n : ℕ+) (a : ℤ) : ((bit1 a : ℤ) : Zmod n) = bit1 (a : Zmod n) :=
-- by rw [bit1, bit1, coe_int_add, coe_int_bit0, coe_int_one]

def to_nat {n : ℕ} (a : Zmod n) : ℕ := a.1

lemma to_nat_lt {n : ℕ} (a : Zmod n) : a.to_nat < n := a.2

@[simp] lemma to_nat_zero (n : ℕ) [h0 : pos n] : (0 : Zmod n).to_nat = 0 := rfl

@[simp] lemma cast_to_nat {n : ℕ} [h0 : pos n] (a : ℕ) : (a : Zmod n).to_nat = a % n :=
begin
  induction a with a ih,
  { rw [nat.zero_mod]; refl },
  { show ((a : Zmod n).to_nat + 1 % n) % n = (a + 1) % n,
    rw ih,
    exact nat.modeq.modeq_add (nat.mod_mod _ _) (nat.mod_mod _ _) }
end

@[simp] lemma eq_zero (n : ℕ) [h0 : pos n] : (n : Zmod n) = 0 :=
subtype.eq (show (n : Zmod n).to_nat = 0, by simp [cast_to_nat])

@[simp] lemma cast_nat_mod (n : ℕ) [h0 : pos n] (a : ℕ) : ((a % n : ℕ) : Zmod n) = a :=
subtype.eq (show ((a % n : ℕ) : Zmod n).to_nat = (a : Zmod n).to_nat, by simp)

-- @[simp] lemma cast_int_mod (n : ℕ) [h0 : pos n] (a : ℤ) : ((a % n : ℤ) : Zmod n) = a :=
-- begin

-- end

-- lemma eq_zero_iff_dvd_nat (n : ℕ) [h0 : pos n] (a : ℕ) : (a : Zmod n) = 0 ↔ (n : ℕ) ∣ a :=
-- ⟨begin end, sorry⟩

-- lemma eq_zero_iff_dvd_int (n : ℕ) [h0 : pos n] (a : ℤ) : (a : Zmod n) = 0 ↔ (n : ℤ) ∣ a :=
-- ⟨λ h, int.modeq.modeq_zero_iff.1 (eq_iff_modeq_int.1 (by  rw [h, coe_int_zero])),
-- λ h, by rwa [← int.modeq.modeq_zero_iff, ← eq_iff_modeq_int, coe_int_zero] at h⟩

-- def equiv_fin (n : ℕ) : Zmod n ≃ fin (nat_abs n) :=
-- { to_fun := λ ⟨a, h⟩, ⟨a, h⟩,
--   inv_fun := λ ⟨a, h⟩, ⟨a, h⟩,
--   left_inv := λ ⟨_, _⟩, rfl,
--   right_inv := λ ⟨_, _⟩, rfl }

-- instance (n : ℕ) : fintype (Zmod n) :=
-- fintype.of_equiv _ (equiv_fin n).symm

-- lemma card_Zmod {n : ℕ} : fintype.card (Zmod n) = n :=
-- eq.trans (fintype.card_congr (equiv_fin n)) (fintype.card_fin _)

-- private def inv_aux {n : ℕ+} (a : Zmod n) : Zmod n := gcd_a a.1 n

-- instance (n : ℕ+) : has_inv (Zmod n) := ⟨inv_aux⟩

-- @[simp] lemma int.gcd_neg (a b : ℤ) : int.gcd (-a) b = int.gcd a b :=
-- by unfold int.gcd; rw nat_abs_neg

-- lemma gcd_a_modeq (a b : ℕ) : (a : ℤ) * gcd_a a b ≡ nat.gcd a b [ZMOD b] :=
-- by rw [← add_zero ((a : ℤ) * _), gcd_eq_gcd_ab];
--   exact int.modeq.modeq_add rfl (int.modeq.modeq_zero_iff.2 (dvd_mul_right _ _)).symm

-- lemma mul_inv_eq_gcd_nat (n : ℕ+) (a : ℕ) : (a : Zmod n) * a⁻¹ = nat.gcd a n :=
-- eq_iff_modeq_nat.2 $ int.modeq.coe_nat_modeq_iff.1
--   (calc ((a % n * nat_mod (gcd_a (a % n) n) ↑n : ℕ) : ℤ) ≡ (a % n : ℕ) * gcd_a (a % n) n [ZMOD n] :
--     by rw [coe_coe, int.coe_nat_mul, nat_mod_coe_pnat]; exact int.modeq.modeq_mul rfl (int.mod_mod _ _)
--   ... ≡ nat.gcd (a % n) n [ZMOD n] : gcd_a_modeq _ _
--   ... = (nat.gcd a n : ℤ) : by rw [← gcd_rec, nat.gcd_comm])

-- lemma mul_inv_eq_gcd_int (n : ℕ+) (a : ℤ) : (a : Zmod n) * a⁻¹ = int.gcd a n :=
-- have h : ((n : ℕ) : ℤ) ≠ 0 := (ne_of_lt (int.coe_nat_lt.2 n.2)).symm,
-- begin
--   rw [int.gcd_comm, ← int.gcd_mod, int.gcd, coe_coe, nat_abs_of_nat, ← mul_inv_eq_gcd_nat,
--     ← coe_nat_coe_int _ (nat_abs _), nat_abs_of_nonneg (mod_nonneg _ h)],
--   simp,
-- end

-- private lemma mul_inv_cancel_aux {p : {n : ℕ+ // nat.prime n.1}} (a : Zmod (p : ℕ+)) (ha : a ≠ 0) : a * a⁻¹ = 1 :=
-- begin
--   rw [← val_coe a, ne.def, eq_zero_iff_dvd_nat] at ha,
--   have : coprime ((p : ℕ+) : ℕ) a.val := p.2.coprime_iff_not_dvd.2 ha,
--   rw [← val_coe a, mul_inv_eq_gcd_nat, nat.gcd_comm, coprime.gcd_eq_one this],
--   refl,
-- end

-- instance Zmod_prime_field (p : {n : ℕ+ // nat.prime n.1}) : field (Zmod (p : ℕ+)) :=
-- { inv := has_inv.inv,
--   zero_ne_one := λ h, begin
--     have : 0 = 1 % p.1.1 := subtype.mk.inj h,
--     rw nat.mod_eq_of_lt (p.2.gt_one) at this,
--     exact nat.no_confusion this,
--   end,
--   mul_inv_cancel := mul_inv_cancel_aux,
--   inv_mul_cancel := λ a ha, by rw mul_comm; exact mul_inv_cancel_aux a ha,
--   ..Zmod.comm_ring p.1 }

end Zmod


import ground_zero.types.equiv

namespace ground_zero.types

universes u v f

inductive coproduct (α : Sort u) (β : Sort v)
| inl {} : α → coproduct
| inr {} : β → coproduct
infix ` + ` := coproduct

namespace coproduct
  variables {α : Sort u} {β : Sort v}

  def elim {γ : Sort f} (g₀ : α → γ) (g₁ : β → γ) : α + β → γ
  | (inl a) := g₀ a
  | (inr b) := g₁ b

  def inv : α + β → β + α
  | (coproduct.inl x) := coproduct.inr x
  | (coproduct.inr x) := coproduct.inl x

  theorem symm : α + β ≃ β + α := begin
    existsi inv, split; existsi inv;
    { intro x, induction x; trivial }
  end
end coproduct

end ground_zero.types


/-
Copyright (c) 2021 Ashvni Narayanan. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Ashvni Narayanan
-/
import bernoulli_measure.equi_class
/-!
# An eventually constant sequence giving the Bernoulli measure
This file defines an eventually constant sequence constructed from a locally constant function.
Its limit is related to the Bernoulli distribution on `zmod d × ℤ_[p]`.

## Main definitions
 * `from_loc_const`
 * `loc_const_to_seq_limit`

## Implementation notes
 * `coprime_pow_spl` replaced with `coprime.pow_right`
 * `val_le_val'` replaced with `val_coe_val_le_val'`
 * `imp` replaced with `apply_instance`
 * `factor_F` replaced with `discrete_quotient_of_to_zmod_pow.le`
 * `succ_eq_bUnion_equi_class` replaced with `zmod'_succ_eq_bUnion_equi_class`
 * `g` replaced with `eventually_constant_seq.from_loc_const`
 * `mem_nonempty` replaced with `nonempty.intro`

## References
Introduction to Cyclotomic Fields, Washington (Chapter 12, Section 2)

## Tags
p-adic, L-function, Bernoulli measure
-/

local attribute [instance] zmod.topological_space

variables {p : ℕ} [fact p.prime] {d : ℕ}
variables (R : Type*) [normed_comm_ring R] {c : ℕ} {m : ℕ} [fact (0 < d)] [algebra ℚ_[p] R]

open_locale big_operators
open padic_int zmod nat equi_class
namespace set
lemma inter_nonempty_of_not_disjoint {α : Type*} {s t : set α} (h : ¬disjoint s t) :
  ∃ x, x ∈ s ∧ x ∈ t :=
begin
  contrapose h, push_neg at h,
  rw [not_not, disjoint_iff],
  ext,
  refine ⟨λ h', (h x ((set.mem_inter_iff _ _ _).1 h').1) ((set.mem_inter_iff _ _ _).1 h').2, _⟩,
  simp,
end

end set

namespace finset
lemma inter_nonempty_of_not_disjoint {α : Type*} {s t : finset α} [decidable_eq α]
  (h : ¬disjoint s t) : ∃ x, x ∈ s ∧ x ∈ t :=
begin
  obtain ⟨x, hx⟩ : finset.nonempty (s ⊓ t),
  { rw [finset.inf_eq_inter, finset.nonempty_iff_ne_empty],
    contrapose h, push_neg at h,
    rw [not_not, disjoint],
    simp only [inf_eq_inter, bot_eq_empty, le_eq_subset], -- simp does not work without rw disjoint
    rw [finset.subset_empty, h], },
  refine ⟨x, finset.mem_inter.1 hx⟩,
end

end finset

open discrete_quotient_of_to_zmod_pow
namespace eventually_constant_seq
/-- An eventually constant sequence constructed from a locally constant function. -/
noncomputable abbreviation from_loc_const (hc : c.coprime p) (hc' : c.coprime d)
  (f : locally_constant (zmod d × ℤ_[p]) R) (hd' : d.coprime p) : @eventually_constant_seq R :=
{ to_seq := λ (n : ℕ), ∑ a in (zmod' (d * p^n) (mul_prime_pow_pos n)),
    f(a) • ((algebra_map ℚ_[p] R) (bernoulli_distribution p d c n a)),
  is_eventually_const := ⟨classical.some (le hd' f) + 1,
  λ l hl', begin
  simp only [algebra.id.smul_eq_mul, set.mem_set_of_eq], -- why is the simp needed?
  have hl : classical.some (le hd' f) ≤ l := le_trans (nat.le_succ _) hl',
  set t := λ a : zmod (d * p ^ l), set.to_finset ((equi_class l.succ) a) with ht,
  have disj : set.pairwise_disjoint ↑(zmod' (d * p ^ l) _) t,
  { rintros x hx y hy hxy,
    contrapose hxy, push_neg,
    obtain ⟨z, hz⟩ := finset.inter_nonempty_of_not_disjoint hxy,
    rw ht at hz,
    simp only [set.mem_to_finset] at hz,
    rw [equi_class.mem, equi_class.mem] at hz,
    exact hz.1 ▸ hz.2, },
  rw [zmod'_succ_eq_bUnion, finset.sum_bUnion disj],
  { haveI : fact (0 < l) := fact_iff.2 (lt_of_lt_of_le (nat.zero_lt_succ _) hl'),
    conv_lhs { apply_congr, skip, conv { apply_congr, skip, rw equi_class.eq R hd' hl x x_1 H_1, },
    rw [←finset.mul_sum, bernoulli_distribution_sum R x hc hc'], }, }, end⟩, }

open eventually_constant_seq

lemma from_loc_const_def (hc : c.coprime p) (hc' : c.coprime d)
  (f : locally_constant (zmod d × ℤ_[p]) R) (n : ℕ) (hd' : d.coprime p) :
  (from_loc_const R hc hc' f hd').to_seq n =
    ∑ a in (finset.range (d * p^n)),f(a) • ((algebra_map ℚ_[p] R) (bernoulli_distribution p d c n a)) :=
begin
  apply finset.sum_bij (λ a ha, _) (λ a ha, _) (λ a ha, _) (λ a b ha hb h, zmod.val_injective _ h)
    (λ b hb, ⟨(b : zmod (d * p^n)), finset.mem_univ _,
    (zmod.val_cast_of_lt (finset.mem_range.1 hb)).symm⟩),
  { simp only [finset.mem_range, val_lt _], },
  { simp only [nat_cast_val, zmod.cast_id], },
end
end eventually_constant_seq

open eventually_constant_seq locally_constant clopen_from
lemma from_loc_const_char_fn {n : ℕ} (a : zmod (d * p^n)) (hc : c.coprime p) (hc' : c.coprime d)
  (h' : d.coprime p) (hm : n ≤ m) :
  (from_loc_const R hc hc' (_root_.char_fn R (clopen_from.is_clopen a)) h').to_seq m =
  ∑ (y : equi_class m a), (algebra_map ℚ_[p] R) (bernoulli_distribution p d c m y) :=
begin
  rw [from_loc_const_def, _root_.char_fn],
  simp only [algebra.id.smul_eq_mul, boole_mul, locally_constant.coe_mk, finset.sum_ite, add_zero,
    finset.sum_const_zero],
  rw finset.sum_bij (λ b hb, _) (λ b hb, finset.mem_univ _) (λ b hb, _) (λ b c hb hc h, _)
    (λ b hb, _),
  { simp only [finset.mem_filter] at hb,
    rw [mem_clopen_from, prod.fst_nat_cast, prod.snd_nat_cast] at hb,
    refine ⟨b, (mem _ _).2 ((function.injective.eq_iff (equiv.injective
      (zmod.chinese_remainder (coprime.pow_right n h')).to_equiv )).1 (prod.ext_iff.2 ⟨_, _⟩))⟩,
    { rw [inv_fst, inv_fst, cast_nat_cast (mul_dvd_mul_left d (pow_dvd_pow p hm)) _,
        cast_nat_cast (dvd_mul_right d _), hb.2.1],
      any_goals { refine zmod.char_p _, }, },
    { rw [inv_snd, inv_snd, cast_nat_cast (mul_dvd_mul_left d (pow_dvd_pow p hm)) _,
        cast_nat_cast (dvd_mul_left _ _), hb.2.2, map_nat_cast],
      any_goals { refine zmod.char_p _, },  }, },
  { simp only [subtype.coe_mk], },
  { simp only [finset.mem_filter, finset.mem_range] at hc,
    simp only [finset.mem_filter, finset.mem_range] at hb,
    rw [←zmod.val_cast_of_lt hb.1, ←zmod.val_cast_of_lt hc.1,
      (function.injective.eq_iff (zmod.val_injective _)).2 _],
    { apply_instance, },
    { exact subtype.ext_iff.1 h, }, },
  { simp only [finset.mem_filter, finset.mem_range, subtype.val_eq_coe],
    refine ⟨(b.val).val, _, _⟩,
    { simp only [finset.mem_filter, finset.mem_range, subtype.val_eq_coe, zmod.nat_cast_val],
      refine ⟨zmod.val_lt _, clopen a hm _⟩, },
    { rw subtype.ext_iff_val,
      simp only [zmod.cast_id', id.def, zmod.nat_cast_val], }, },
end

open eventually_constant_seq
-- zmod.cast_cast'
lemma seq_lim_from_loc_const_char_fn {n : ℕ} (a : zmod (d * p^n)) (hc : c.coprime p)
  (hc' : c.coprime d) (h' : d.coprime p) :
  sequence_limit_index' (from_loc_const R hc hc' (_root_.char_fn R (clopen_from.is_clopen a)) h') ≤ n :=
begin
  refine nat.Inf_le (λ m hm, _),
  have hm' : d * p^n ∣ d * p^m := mul_dvd_mul_left d (pow_dvd_pow p hm),
  rw [from_loc_const_char_fn R a hc hc' h' hm,
    from_loc_const_char_fn R a hc hc' h' (le_trans hm (le_succ _))],
  conv_rhs { apply_congr, skip, rw ←bernoulli_distribution_sum R _ hc hc', },
  rw ←finset.sum_bUnion,
  { refine finset.sum_bij (λ b hb, b.val) (λ b hb, finset.mem_bUnion.2 _) (λ b hb, rfl)
      (λ b b' hb hb' h, subtype.ext_iff_val.2 h) (λ b hb, _),
    { simp only [finset.mem_univ, set_coe.exists, finset.mem_bUnion, set.mem_to_finset,
        exists_true_left],
      refine ⟨b.val, (equi_class.mem _ _).2 _, (equi_class.mem _ _).2 rfl⟩,
      simp_rw [←(equi_class.mem _ _).1 b.prop, subtype.val_eq_coe],
      rw [←nat_cast_val (b : zmod (d * p ^ m.succ)), cast_nat_cast hm' _, nat_cast_val],
      refine zmod.char_p _, },
    { simp only [finset.mem_univ, set_coe.exists, finset.mem_bUnion, set.mem_to_finset,
        subtype.coe_mk, exists_true_left, exists_prop] at hb,
      simp only [exists_prop, finset.mem_univ, set_coe.exists, exists_eq_right',
        exists_true_left, subtype.coe_mk, subtype.val_eq_coe],
      rcases hb with ⟨z, h1, h3⟩,
      rw equi_class.mem at *,
      symmetry,
      rw [←h1, ←h3.2, ←nat_cast_val b, cast_nat_cast hm' _, nat_cast_val],
      refine zmod.char_p _, }, },
  { -- if I attach this to finset.sum_bUnion, I get an extra error of types and an extra goal of
    -- decidability
    refine (λ x hx y hy hxy, finset.disjoint_iff_ne.2 (λ z hz z' hz', λ h, hxy
      (subtype.ext_iff_val.2 (by { rw [subtype.val_eq_coe, subtype.val_eq_coe,
      ←((equi_class.mem _ _).1 (set.mem_to_finset_val.1 hz)), ←(((equi_class.mem _ _).1
      (set.mem_to_finset_val.1 hz'))), h], })))), },
end

/-- An `R`-linear map from `locally_constant (zmod d × ℤ_[p]) R` to `R` which gives a Bernoulli
  measure. -/
noncomputable abbreviation loc_const_to_seq_limit (hc : c.coprime p) (hc' : c.coprime d)
  (h' : d.coprime p) : locally_constant (zmod d × ℤ_[p]) R →ₗ[R] R :=
{ to_fun := λ f, sequence_limit (from_loc_const R hc hc' f h'),
  map_add' := λ x y, begin
    repeat { rw sequence_limit_eq (from_loc_const R hc hc' _ h') ((sequence_limit_index'
      (from_loc_const R hc hc' (x + y) h')) ⊔ (sequence_limit_index' (from_loc_const R hc hc' x h'))
      ⊔ (sequence_limit_index' (from_loc_const R hc hc' y h'))) _, },
    { simp only [algebra.id.smul_eq_mul, pi.add_apply, locally_constant.coe_add,
        ←finset.sum_add_distrib],
      refine finset.sum_congr rfl (λ y hy, add_mul _ _ _), },
    { refine le_sup_iff.2 (or.inr le_rfl), },
    { refine le_sup_iff.2 (or.inl (le_sup_iff.2 (or.inr le_rfl))), },
    { refine le_sup_iff.2 (or.inl (le_sup_iff.2 (or.inl le_rfl))), }, end,
  map_smul' := λ m x, begin
    repeat { rw sequence_limit_eq (from_loc_const R hc hc' _ h') ((sequence_limit_index'
      (from_loc_const R hc hc' x h')) ⊔
      (sequence_limit_index' (from_loc_const R hc hc' (m • x) h'))) _, },
    { simp only [algebra.id.smul_eq_mul, locally_constant.coe_smul, pi.smul_apply, finset.mul_sum],
      refine finset.sum_congr rfl (λ y hy, by { rw [mul_assoc, ring_hom.id_apply], }), },
    { refine le_sup_iff.2 (or.inl le_rfl), },
    { refine le_sup_iff.2 (or.inr le_rfl), }, end }

@[to_additive]
lemma prod_coe_to_finset {α : Type*} {β :Type*} [comm_monoid β] (s : set α) [fintype s] (f : α → β) :
  ∏ (i : α) in s.to_finset, f i = ∏ (i : s), f i :=
finset.prod_bij (λ t ht, ⟨t, set.mem_to_finset.1 ht⟩) (λ a ha, finset.mem_univ _)
  (λ a ha, by { simp only [subtype.coe_mk] }) (λ b c hb hc h, subtype.mk_eq_mk.1 h)
  (λ b hb, ⟨b.val, set.mem_to_finset.2 b.prop, by { simp }⟩)

lemma from_loc_const_to_seq [algebra ℚ_[p] R] {n : ℕ} (a : zmod (d * p^n)) (hc : c.coprime p)
  (hc' : c.coprime d) (h' : d.coprime p) :
  (from_loc_const R hc hc' (_root_.char_fn R (clopen_from.is_clopen a)) h').to_seq n =
  (algebra_map ℚ_[p] R) (bernoulli_distribution p d c n a) :=
begin
  rw from_loc_const_char_fn R a hc hc' h' (le_refl n),
  convert_to _ = ∑ (y : zmod (d * p^n)) in {a}, (algebra_map ℚ_[p] R) (bernoulli_distribution p d c n ↑y),
  { rw [finset.sum_singleton, zmod.cast_id], },
  { convert_to ∑ (y : zmod (d * p^n)) in (set.to_finset (equi_class n a)),
      (algebra_map ℚ_[p] R) (bernoulli_distribution p d c n ↑y) = _,
    { simp_rw [sum_coe_to_finset, zmod.cast_id], },
    { apply finset.sum_congr (finset.ext_iff.2 (λ y, _)) (λ x hx, rfl),
      { simp only [set.mem_to_finset, finset.mem_singleton, equi_class.mem, zmod.cast_id], }, }, },
end