/-
Copyright (c) 2018 Kevin Buzzard, Patrick Massot. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kevin Buzzard, Patrick Massot

This file is to a certain extent based on `quotient_module.lean` by Johannes Hölzl.
-/
import group_theory.congruence
import group_theory.coset
import group_theory.subgroup.finite
import group_theory.subgroup.pointwise

/-!
# Quotients of groups by normal subgroups

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

This files develops the basic theory of quotients of groups by normal subgroups. In particular it
proves Noether's first and second isomorphism theorems.

## Main definitions

* `mk'`: the canonical group homomorphism `G →* G/N` given a normal subgroup `N` of `G`.
* `lift φ`: the group homomorphism `G/N →* H` given a group homomorphism `φ : G →* H` such that
  `N ⊆ ker φ`.
* `map f`: the group homomorphism `G/N →* H/M` given a group homomorphism `f : G →* H` such that
  `N ⊆ f⁻¹(M)`.

## Main statements

* `quotient_ker_equiv_range`: Noether's first isomorphism theorem, an explicit isomorphism
  `G/ker φ → range φ` for every group homomorphism `φ : G →* H`.
* `quotient_inf_equiv_prod_normal_quotient`: Noether's second isomorphism theorem, an explicit
  isomorphism between `H/(H ∩ N)` and `(HN)/N` given a subgroup `H` and a normal subgroup `N` of a
  group `G`.
* `quotient_group.quotient_quotient_equiv_quotient`: Noether's third isomorphism theorem,
  the canonical isomorphism between `(G / N) / (M / N)` and `G / M`, where `N ≤ M`.

## Tags

isomorphism theorems, quotient groups
-/

open function
universes u v

namespace quotient_group

variables {G : Type u} [group G] (N : subgroup G) [nN : N.normal] {H : Type v} [group H]
include nN

/-- The congruence relation generated by a normal subgroup. -/
@[to_additive "The additive congruence relation generated by a normal additive subgroup."]
protected def con : con G :=
{ to_setoid := left_rel N,
  mul' := λ a b c d hab hcd, begin
    rw [left_rel_eq] at hab hcd ⊢,
    calc (a * c)⁻¹ * (b * d) = c⁻¹ * (a⁻¹ * b) * c⁻¹⁻¹ * (c⁻¹ * d) :
      by simp only [mul_inv_rev, mul_assoc, inv_mul_cancel_left]
    ... ∈ N : N.mul_mem (nN.conj_mem _ hab _) hcd
  end }

@[to_additive] instance quotient.group : group (G ⧸ N) := (quotient_group.con N).group

/-- The group homomorphism from `G` to `G/N`. -/
@[to_additive "The additive group homomorphism from `G` to `G/N`."]
def mk' : G →* G ⧸ N := monoid_hom.mk' (quotient_group.mk) (λ _ _, rfl)

@[simp, to_additive]
lemma coe_mk' : (mk' N : G → G ⧸ N) = coe := rfl

@[simp, to_additive]
lemma mk'_apply (x : G) : mk' N x = x := rfl

@[to_additive]
lemma mk'_surjective : surjective $ mk' N := @mk_surjective _ _ N

@[to_additive]
lemma mk'_eq_mk' {x y : G} : mk' N x = mk' N y ↔ ∃ z ∈ N, x * z = y :=
quotient_group.eq'.trans $
  by simp only [← _root_.eq_inv_mul_iff_mul_eq, exists_prop, exists_eq_right]

/-- Two `monoid_hom`s from a quotient group are equal if their compositions with
`quotient_group.mk'` are equal.

See note [partially-applied ext lemmas]. -/
@[ext, to_additive /-" Two `add_monoid_hom`s from an additive quotient group are equal if their
compositions with `add_quotient_group.mk'` are equal.

See note [partially-applied ext lemmas]. "-/]
lemma monoid_hom_ext ⦃f g : G ⧸ N →* H⦄ (h : f.comp (mk' N) = g.comp (mk' N)) : f = g :=
monoid_hom.ext $ λ x, quotient_group.induction_on x $ (monoid_hom.congr_fun h : _)

@[simp, to_additive]
lemma eq_one_iff {N : subgroup G} [nN : N.normal] (x : G) : (x : G ⧸ N) = 1 ↔ x ∈ N :=
begin
  refine quotient_group.eq.trans _,
  rw [mul_one, subgroup.inv_mem_iff],
end

@[simp, to_additive]
lemma ker_mk : monoid_hom.ker (quotient_group.mk' N : G →* G ⧸ N) = N :=
subgroup.ext eq_one_iff

@[to_additive]

-- for commutative groups we don't need normality assumption
omit nN

@[to_additive]
instance quotient.comm_group {G : Type*} [comm_group G] (N : subgroup G) : comm_group (G ⧸ N) :=
{ mul_comm := λ a b, quotient.induction_on₂' a b
    (λ a b, congr_arg mk (mul_comm a b)),
  .. @quotient_group.quotient.group _ _ N N.normal_of_comm }

include nN

local notation ` Q ` := G ⧸ N

@[simp, to_additive] lemma coe_one : ((1 : G) : Q) = 1 := rfl
@[simp, to_additive] lemma coe_mul (a b : G) : ((a * b : G) : Q) = a * b := rfl
@[simp, to_additive] lemma coe_inv (a : G) : ((a⁻¹ : G) : Q) = a⁻¹ := rfl
@[simp, to_additive] lemma coe_div (a b : G) : ((a / b : G) : Q) = a / b := rfl
@[simp, to_additive] lemma coe_pow (a : G) (n : ℕ) : ((a ^ n : G) : Q) = a ^ n := rfl
@[simp, to_additive] lemma coe_zpow (a : G) (n : ℤ) : ((a ^ n : G) : Q) = a ^ n := rfl

/-- A group homomorphism `φ : G →* H` with `N ⊆ ker(φ)` descends (i.e. `lift`s) to a
group homomorphism `G/N →* H`. -/
@[to_additive "An `add_group` homomorphism `φ : G →+ H` with `N ⊆ ker(φ)` descends (i.e. `lift`s)
to a group homomorphism `G/N →* H`."]
def lift (φ : G →* H) (HN : ∀x∈N, φ x = 1) : Q →* H :=
(quotient_group.con N).lift φ $ λ x y h, begin
  simp only [quotient_group.con, left_rel_apply, con.rel_mk] at h,
  calc φ x = φ (y * (x⁻¹ * y)⁻¹) : by rw [mul_inv_rev, inv_inv, mul_inv_cancel_left]
       ... = φ y                 : by rw [φ.map_mul, HN _ (N.inv_mem h), mul_one]
  end

@[simp, to_additive]
lemma lift_mk {φ : G →* H} (HN : ∀x∈N, φ x = 1) (g : G) : lift N φ HN (g : Q) = φ g := rfl

@[simp, to_additive]
lemma lift_mk' {φ : G →* H} (HN : ∀x∈N, φ x = 1) (g : G) : lift N φ HN (mk g : Q) = φ g := rfl

@[simp, to_additive]
lemma lift_quot_mk {φ : G →* H} (HN : ∀x∈N, φ x = 1) (g : G) :
  lift N φ HN (quot.mk _ g : Q) = φ g := rfl

/-- A group homomorphism `f : G →* H` induces a map `G/N →* H/M` if `N ⊆ f⁻¹(M)`. -/
@[to_additive "An `add_group` homomorphism `f : G →+ H` induces a map `G/N →+ H/M` if
`N ⊆ f⁻¹(M)`."]
def map (M : subgroup H) [M.normal] (f : G →* H) (h : N ≤ M.comap f) :
  G ⧸ N →* H ⧸ M :=
begin
  refine quotient_group.lift N ((mk' M).comp f) _,
  assume x hx,
  refine quotient_group.eq.2 _,
  rw [mul_one, subgroup.inv_mem_iff],
  exact h hx,
end

@[simp, to_additive] lemma map_coe (M : subgroup H) [M.normal] (f : G →* H) (h : N ≤ M.comap f)
  (x : G) :
  map N M f h ↑x = ↑(f x) :=
rfl

@[to_additive] lemma map_mk' (M : subgroup H) [M.normal] (f : G →* H) (h : N ≤ M.comap f) (x : G) :
  map N M f h (mk' _ x) = ↑(f x) :=
rfl

@[to_additive]
lemma map_id_apply (h : N ≤ subgroup.comap (monoid_hom.id _) N := (subgroup.comap_id N).le) (x) :
  map N N (monoid_hom.id _) h x = x :=
induction_on' x $ λ x, rfl

@[simp, to_additive]
lemma map_id (h : N ≤ subgroup.comap (monoid_hom.id _) N := (subgroup.comap_id N).le) :
  map N N (monoid_hom.id _) h = monoid_hom.id _ :=
monoid_hom.ext (map_id_apply N h)

@[simp, to_additive]
lemma map_map {I : Type*} [group I] (M : subgroup H) (O : subgroup I)
  [M.normal] [O.normal]
  (f : G →* H) (g : H →* I) (hf : N ≤ subgroup.comap f M) (hg : M ≤ subgroup.comap g O)
  (hgf : N ≤ subgroup.comap (g.comp f) O :=
    hf.trans ((subgroup.comap_mono hg).trans_eq (subgroup.comap_comap _ _ _))) (x : G ⧸ N) :
  map M O g hg (map N M f hf x) = map N O (g.comp f) hgf x :=
begin
  refine induction_on' x (λ x, _),
  simp only [map_coe, monoid_hom.comp_apply]
end

@[simp, to_additive]
lemma map_comp_map {I : Type*} [group I] (M : subgroup H) (O : subgroup I)
  [M.normal] [O.normal]
  (f : G →* H) (g : H →* I) (hf : N ≤ subgroup.comap f M) (hg : M ≤ subgroup.comap g O)
  (hgf : N ≤ subgroup.comap (g.comp f) O :=
    hf.trans ((subgroup.comap_mono hg).trans_eq (subgroup.comap_comap _ _ _))) :
  (map M O g hg).comp (map N M f hf) = map N O (g.comp f) hgf :=
monoid_hom.ext (map_map N M O f g hf hg hgf)

omit nN

section congr

variables (G' : subgroup G) (H' : subgroup H) [subgroup.normal G'] [subgroup.normal H']

/-- `quotient_group.congr` lifts the isomorphism `e : G ≃ H` to `G ⧸ G' ≃ H ⧸ H'`,
given that `e` maps `G` to `H`. -/
@[to_additive "`quotient_add_group.congr` lifts the isomorphism `e : G ≃ H` to `G ⧸ G' ≃ H ⧸ H'`,
given that `e` maps `G` to `H`."]
def congr (e : G ≃* H) (he : G'.map ↑e = H') : G ⧸ G' ≃* H ⧸ H' :=
{ to_fun := map G' H' ↑e (he ▸ G'.le_comap_map e),
  inv_fun := map H' G' ↑e.symm (he ▸ (G'.map_equiv_eq_comap_symm e).le),
  left_inv := λ x, by rw map_map; -- `simp` doesn't like this lemma...
    simp only [map_map, ← mul_equiv.coe_monoid_hom_trans, mul_equiv.self_trans_symm,
        mul_equiv.coe_monoid_hom_refl, map_id_apply],
  right_inv := λ x, by rw map_map; -- `simp` doesn't like this lemma...
    simp only [← mul_equiv.coe_monoid_hom_trans, mul_equiv.symm_trans_self,
        mul_equiv.coe_monoid_hom_refl, map_id_apply],
  .. map G' H' ↑e (he ▸ G'.le_comap_map e) }

@[simp] lemma congr_mk (e : G ≃* H) (he : G'.map ↑e = H')
  (x) : congr G' H' e he (mk x) = e x :=
rfl

lemma congr_mk' (e : G ≃* H) (he : G'.map ↑e = H')
  (x) : congr G' H' e he (mk' G' x) = mk' H' (e x) :=
rfl

@[simp] lemma congr_apply (e : G ≃* H) (he : G'.map ↑e = H')
  (x : G) : congr G' H' e he x = mk' H' (e x) :=
rfl

@[simp] lemma congr_refl (he : G'.map (mul_equiv.refl G : G →* G) = G' := subgroup.map_id G') :
  congr G' G' (mul_equiv.refl G) he = mul_equiv.refl (G ⧸ G') :=
by { ext ⟨x⟩, refl }

@[simp] lemma congr_symm (e : G ≃* H) (he : G'.map ↑e = H') :
  (congr G' H' e he).symm = congr H' G' e.symm ((subgroup.map_symm_eq_iff_map_eq _).mpr he) :=
rfl

end congr

variables (φ : G →* H)

open monoid_hom

/-- The induced map from the quotient by the kernel to the codomain. -/
@[to_additive "The induced map from the quotient by the kernel to the codomain."]
def ker_lift : G ⧸ ker φ →* H :=
lift _ φ $ λ g, φ.mem_ker.mp

@[simp, to_additive]
lemma ker_lift_mk (g : G) : (ker_lift φ) g = φ g := lift_mk _ _ _

@[simp, to_additive]
lemma ker_lift_mk' (g : G) : (ker_lift φ) (mk g) = φ g := lift_mk' _ _ _

@[to_additive]
lemma ker_lift_injective : injective (ker_lift φ) :=
assume a b, quotient.induction_on₂' a b $
  assume a b (h : φ a = φ b), quotient.sound' $
  by rw [left_rel_apply, mem_ker, φ.map_mul, ← h, φ.map_inv, inv_mul_self]

-- Note that `ker φ` isn't definitionally `ker (φ.range_restrict)`
-- so there is a bit of annoying code duplication here

/-- The induced map from the quotient by the kernel to the range. -/
@[to_additive "The induced map from the quotient by the kernel to the range."]
def range_ker_lift : G ⧸ ker φ →* φ.range :=
lift _ φ.range_restrict $ λ g hg, (mem_ker _).mp $ by rwa ker_range_restrict

@[to_additive]
lemma range_ker_lift_injective : injective (range_ker_lift φ) :=
assume a b, quotient.induction_on₂' a b $
  assume a b (h : φ.range_restrict a = φ.range_restrict b), quotient.sound' $
  by rw [left_rel_apply, ←ker_range_restrict, mem_ker,
  φ.range_restrict.map_mul, ← h, φ.range_restrict.map_inv, inv_mul_self]

@[to_additive]
lemma range_ker_lift_surjective : surjective (range_ker_lift φ) :=
begin
  rintro ⟨_, g, rfl⟩,
  use mk g,
  refl,
end

/-- **Noether's first isomorphism theorem** (a definition): the canonical isomorphism between
`G/(ker φ)` to `range φ`. -/
@[to_additive "The first isomorphism theorem (a definition): the canonical isomorphism between
`G/(ker φ)` to `range φ`."]
noncomputable def quotient_ker_equiv_range : G ⧸ ker φ ≃* range φ :=
mul_equiv.of_bijective (range_ker_lift φ) ⟨range_ker_lift_injective φ, range_ker_lift_surjective φ⟩

/-- The canonical isomorphism `G/(ker φ) ≃* H` induced by a homomorphism `φ : G →* H`
with a right inverse `ψ : H → G`. -/
@[to_additive "The canonical isomorphism `G/(ker φ) ≃+ H` induced by a homomorphism `φ : G →+ H`
with a right inverse `ψ : H → G`.", simps]
def quotient_ker_equiv_of_right_inverse (ψ : H → G) (hφ : right_inverse ψ φ) :
  G ⧸ ker φ ≃* H :=
{ to_fun := ker_lift φ,
  inv_fun := mk ∘ ψ,
  left_inv := λ x, ker_lift_injective φ (by rw [comp_app, ker_lift_mk', hφ]),
  right_inv := hφ,
  .. ker_lift φ }

/-- The canonical isomorphism `G/⊥ ≃* G`. -/
@[to_additive "The canonical isomorphism `G/⊥ ≃+ G`.", simps]
def quotient_bot : G ⧸ (⊥ : subgroup G) ≃* G :=
quotient_ker_equiv_of_right_inverse (monoid_hom.id G) id (λ x, rfl)

/-- The canonical isomorphism `G/(ker φ) ≃* H` induced by a surjection `φ : G →* H`.

For a `computable` version, see `quotient_group.quotient_ker_equiv_of_right_inverse`.
-/
@[to_additive "The canonical isomorphism `G/(ker φ) ≃+ H` induced by a surjection `φ : G →+ H`.

For a `computable` version, see `quotient_add_group.quotient_ker_equiv_of_right_inverse`."]
noncomputable def quotient_ker_equiv_of_surjective (hφ : surjective φ) :
  G ⧸ (ker φ) ≃* H :=
quotient_ker_equiv_of_right_inverse φ _ hφ.has_right_inverse.some_spec

/-- If two normal subgroups `M` and `N` of `G` are the same, their quotient groups are
isomorphic. -/
@[to_additive "If two normal subgroups `M` and `N` of `G` are the same, their quotient groups are
isomorphic."]
def quotient_mul_equiv_of_eq {M N : subgroup G} [M.normal] [N.normal] (h : M = N) :
  G ⧸ M ≃* G ⧸ N :=
{ map_mul' := λ q r, quotient.induction_on₂' q r (λ g h, rfl),
  .. subgroup.quotient_equiv_of_eq h }

@[simp, to_additive]
lemma quotient_mul_equiv_of_eq_mk {M N : subgroup G} [M.normal] [N.normal] (h : M = N) (x : G) :
  quotient_group.quotient_mul_equiv_of_eq h (quotient_group.mk x) = (quotient_group.mk x) :=
rfl

/-- Let `A', A, B', B` be subgroups of `G`. If `A' ≤ B'` and `A ≤ B`,
then there is a map `A / (A' ⊓ A) →* B / (B' ⊓ B)` induced by the inclusions. -/
@[to_additive "Let `A', A, B', B` be subgroups of `G`. If `A' ≤ B'` and `A ≤ B`,
then there is a map `A / (A' ⊓ A) →+ B / (B' ⊓ B)` induced by the inclusions."]
def quotient_map_subgroup_of_of_le {A' A B' B : subgroup G}
  [hAN : (A'.subgroup_of A).normal] [hBN : (B'.subgroup_of B).normal]
  (h' : A' ≤ B') (h : A ≤ B) :
  A ⧸ (A'.subgroup_of A) →* B ⧸ (B'.subgroup_of B) :=
map _ _ (subgroup.inclusion h) $ subgroup.comap_mono h'

@[simp, to_additive]
lemma quotient_map_subgroup_of_of_le_coe {A' A B' B : subgroup G}
  [hAN : (A'.subgroup_of A).normal] [hBN : (B'.subgroup_of B).normal]
  (h' : A' ≤ B') (h : A ≤ B) (x : A) :
  quotient_map_subgroup_of_of_le h' h x = ↑(subgroup.inclusion h x : B) := rfl

/-- Let `A', A, B', B` be subgroups of `G`.
If `A' = B'` and `A = B`, then the quotients `A / (A' ⊓ A)` and `B / (B' ⊓ B)` are isomorphic.

Applying this equiv is nicer than rewriting along the equalities, since the type of
`(A'.subgroup_of A : subgroup A)` depends on on `A`.
-/
@[to_additive "Let `A', A, B', B` be subgroups of `G`.
If `A' = B'` and `A = B`, then the quotients `A / (A' ⊓ A)` and `B / (B' ⊓ B)` are isomorphic.

Applying this equiv is nicer than rewriting along the equalities, since the type of
`(A'.add_subgroup_of A : add_subgroup A)` depends on on `A`.
"]
def equiv_quotient_subgroup_of_of_eq {A' A B' B : subgroup G}
  [hAN : (A'.subgroup_of A).normal] [hBN : (B'.subgroup_of B).normal]
  (h' : A' = B') (h : A = B) :
  A ⧸ (A'.subgroup_of A) ≃* B ⧸ (B'.subgroup_of B) :=
monoid_hom.to_mul_equiv
  (quotient_map_subgroup_of_of_le h'.le h.le) (quotient_map_subgroup_of_of_le h'.ge h.ge)
  (by { ext ⟨x, hx⟩, refl })
  (by { ext ⟨x, hx⟩, refl })

section zpow

variables {A B C : Type u} [comm_group A] [comm_group B] [comm_group C]
variables (f : A →* B) (g : B →* A) (e : A ≃* B) (d : B ≃* C) (n : ℤ)

/-- The map of quotients by powers of an integer induced by a group homomorphism. -/
@[to_additive "The map of quotients by multiples of an integer induced by an additive group
homomorphism."]
def hom_quotient_zpow_of_hom :
  A ⧸ (zpow_group_hom n : A →* A).range →* B ⧸ (zpow_group_hom n : B →* B).range :=
lift _ ((mk' _).comp f) $
  λ g ⟨h, (hg : h ^ n = g)⟩, (eq_one_iff _).mpr ⟨_, by simpa only [← hg, map_zpow]⟩

@[simp, to_additive]
lemma hom_quotient_zpow_of_hom_id :
  hom_quotient_zpow_of_hom (monoid_hom.id A) n = monoid_hom.id _ :=
monoid_hom_ext _ rfl

@[simp, to_additive]
lemma hom_quotient_zpow_of_hom_comp :
  hom_quotient_zpow_of_hom (f.comp g) n
    = (hom_quotient_zpow_of_hom f n).comp (hom_quotient_zpow_of_hom g n) :=
monoid_hom_ext _ rfl

@[simp, to_additive]
lemma hom_quotient_zpow_of_hom_comp_of_right_inverse (i : function.right_inverse g f) :
  (hom_quotient_zpow_of_hom f n).comp (hom_quotient_zpow_of_hom g n) = monoid_hom.id _ :=
monoid_hom_ext _ $ monoid_hom.ext $ λ x, congr_arg coe $ i x

/-- The equivalence of quotients by powers of an integer induced by a group isomorphism. -/
@[to_additive "The equivalence of quotients by multiples of an integer induced by an additive group
isomorphism."]
def equiv_quotient_zpow_of_equiv :
  A ⧸ (zpow_group_hom n : A →* A).range ≃* B ⧸ (zpow_group_hom n : B →* B).range :=
monoid_hom.to_mul_equiv _ _ (hom_quotient_zpow_of_hom_comp_of_right_inverse e.symm e n e.left_inv)
  (hom_quotient_zpow_of_hom_comp_of_right_inverse e e.symm n e.right_inv)

@[simp, to_additive]
lemma equiv_quotient_zpow_of_equiv_refl :
  mul_equiv.refl (A ⧸ (zpow_group_hom n : A →* A).range)
    = equiv_quotient_zpow_of_equiv (mul_equiv.refl A) n :=
by { ext x, rw [← quotient.out_eq' x], refl }

@[simp, to_additive]
lemma equiv_quotient_zpow_of_equiv_symm :
  (equiv_quotient_zpow_of_equiv e n).symm = equiv_quotient_zpow_of_equiv e.symm n :=
rfl

@[simp, to_additive]
lemma equiv_quotient_zpow_of_equiv_trans :
  (equiv_quotient_zpow_of_equiv e n).trans (equiv_quotient_zpow_of_equiv d n)
    = equiv_quotient_zpow_of_equiv (e.trans d) n :=
by { ext x, rw [← quotient.out_eq' x], refl }

end zpow

section snd_isomorphism_thm

open _root_.subgroup

/-- **Noether's second isomorphism theorem**: given two subgroups `H` and `N` of a group `G`, where
`N` is normal, defines an isomorphism between `H/(H ∩ N)` and `(HN)/N`. -/
@[to_additive "The second isomorphism theorem: given two subgroups `H` and `N` of a group `G`,
where `N` is normal, defines an isomorphism between `H/(H ∩ N)` and `(H + N)/N`"]
noncomputable def quotient_inf_equiv_prod_normal_quotient (H N : subgroup G) [N.normal] :
  H ⧸ (N.subgroup_of H) ≃* _ ⧸ (N.subgroup_of (H ⊔ N)) :=
/- φ is the natural homomorphism H →* (HN)/N. -/
let φ : H →* _ ⧸ (N.subgroup_of (H ⊔ N)) :=
  (mk' $ N.subgroup_of (H ⊔ N)).comp (inclusion le_sup_left) in
have φ_surjective : surjective φ := λ x, x.induction_on' $
  begin
    rintro ⟨y, (hy : y ∈ ↑(H ⊔ N))⟩, rw mul_normal H N at hy,
    rcases hy with ⟨h, n, hh, hn, rfl⟩,
    use [h, hh], apply quotient.eq.mpr,
    change setoid.r _ _,
    rw left_rel_apply,
    change h⁻¹ * (h * n) ∈ N,
    rwa [←mul_assoc, inv_mul_self, one_mul],
  end,
(quotient_mul_equiv_of_eq (by simp [← comap_ker])).trans
  (quotient_ker_equiv_of_surjective φ φ_surjective)

end snd_isomorphism_thm

section third_iso_thm

variables (M : subgroup G) [nM : M.normal]

include nM nN

@[to_additive] instance map_normal : (M.map (quotient_group.mk' N)).normal :=
nM.map _ mk_surjective

variables (h : N ≤ M)

/-- The map from the third isomorphism theorem for groups: `(G / N) / (M / N) → G / M`. -/
@[to_additive "The map from the third isomorphism theorem for additive groups:
`(A / N) / (M / N) → A / M`."]
def quotient_quotient_equiv_quotient_aux :
  (G ⧸ N) ⧸ (M.map (mk' N)) →* G ⧸ M :=
lift (M.map (mk' N))
  (map N M (monoid_hom.id G) h)
  (by { rintro _ ⟨x, hx, rfl⟩, rw map_mk' N M _ _ x,
        exact (quotient_group.eq_one_iff _).mpr hx })

@[simp, to_additive]
lemma quotient_quotient_equiv_quotient_aux_coe (x : G ⧸ N) :
  quotient_quotient_equiv_quotient_aux N M h x = quotient_group.map N M (monoid_hom.id G) h x :=
quotient_group.lift_mk' _ _ x

@[to_additive]
lemma quotient_quotient_equiv_quotient_aux_coe_coe (x : G) :
  quotient_quotient_equiv_quotient_aux N M h (x : G ⧸ N) =
    x :=
quotient_group.lift_mk' _ _ x

/-- **Noether's third isomorphism theorem** for groups: `(G / N) / (M / N) ≃* G / M`. -/
@[to_additive "**Noether's third isomorphism theorem** for additive groups:
`(A / N) / (M / N) ≃+ A / M`."]
def quotient_quotient_equiv_quotient :
  (G ⧸ N) ⧸ (M.map (quotient_group.mk' N)) ≃* G ⧸ M :=
monoid_hom.to_mul_equiv
  (quotient_quotient_equiv_quotient_aux N M h)
  (quotient_group.map _ _ (quotient_group.mk' N) (subgroup.le_comap_map _ _))
  (by { ext, simp })
  (by { ext, simp })

end third_iso_thm

section trivial

@[to_additive] lemma subsingleton_quotient_top :
  subsingleton (G ⧸ (⊤ : subgroup G)) :=
begin
  dsimp [has_quotient.quotient, subgroup.has_quotient, quotient],
  rw left_rel_eq,
  exact @trunc.subsingleton G,
end

/-- If the quotient by a subgroup gives a singleton then the subgroup is the whole group. -/
@[to_additive "If the quotient by an additive subgroup gives a singleton then the additive subgroup
is the whole additive group."] lemma subgroup_eq_top_of_subsingleton (H : subgroup G)
  (h : subsingleton (G ⧸ H)) : H = ⊤ :=
top_unique $ λ x _,
  have this : 1⁻¹ * x ∈ H := quotient_group.eq.1 (subsingleton.elim _ _),
  by rwa [inv_one, one_mul] at this

end trivial

@[to_additive]
lemma comap_comap_center {H₁ : subgroup G} [H₁.normal] {H₂ : subgroup (G ⧸ H₁)} [H₂.normal] :
  (((subgroup.center ((G ⧸ H₁) ⧸ H₂))).comap (mk' H₂)).comap (mk' H₁) =
  (subgroup.center (G ⧸ H₂.comap (mk' H₁))).comap (mk' (H₂.comap (mk' H₁))) :=
begin
  ext x,
  simp only [mk'_apply, subgroup.mem_comap, subgroup.mem_center_iff, forall_coe,
    ← coe_mul, eq_iff_div_mem, coe_div]
end

end quotient_group

namespace group

open_locale classical
open quotient_group subgroup

variables {F G H : Type u} [group F] [group G] [group H] [fintype F] [fintype H]
variables (f : F →* G) (g : G →* H)

/-- If `F` and `H` are finite such that `ker(G →* H) ≤ im(F →* G)`, then `G` is finite. -/
@[to_additive "If `F` and `H` are finite such that `ker(G →+ H) ≤ im(F →+ G)`, then `G` is finite."]
noncomputable def fintype_of_ker_le_range (h : g.ker ≤ f.range) : fintype G :=
@fintype.of_equiv _ _ (@prod.fintype _ _ (fintype.of_injective _ $ ker_lift_injective g) $
                                          fintype.of_injective _ $ inclusion_injective h)
  group_equiv_quotient_times_subgroup.symm

/-- If `F` and `H` are finite such that `ker(G →* H) = im(F →* G)`, then `G` is finite. -/
@[to_additive "If `F` and `H` are finite such that `ker(G →+ H) = im(F →+ G)`, then `G` is finite."]
noncomputable def fintype_of_ker_eq_range (h : g.ker = f.range) : fintype G :=
fintype_of_ker_le_range _ _ h.le

/-- If `ker(G →* H)` and `H` are finite, then `G` is finite. -/
@[to_additive "If `ker(G →+ H)` and `H` are finite, then `G` is finite."]
noncomputable def fintype_of_ker_of_codom [fintype g.ker] : fintype G :=
fintype_of_ker_le_range ((top_equiv : _ ≃* G).to_monoid_hom.comp $ inclusion le_top) g $
  λ x hx, ⟨⟨x, hx⟩, rfl⟩

/-- If `F` and `coker(F →* G)` are finite, then `G` is finite. -/
@[to_additive "If `F` and `coker(F →+ G)` are finite, then `G` is finite."]
noncomputable def fintype_of_dom_of_coker [normal f.range] [fintype $ G ⧸ f.range] : fintype G :=
fintype_of_ker_le_range _ (mk' f.range) $ λ x, (eq_one_iff x).mp

end group


/-
Copyright (c) 2019 Neil Strickland. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Neil Strickland

This file effectively deals with the cartesian-closed category
of finite posets and the associated "strong homotopy category".
However, we have taken an ad hoc approach rather than using the
category theory library.
-/

import order.basic order.sort_rank
import logic.equiv.basic
import data.fintype.basic data.fin_extra
import logic.relation
import algebra.punit_instances

universes uP uQ uR uS

variables (P : Type uP) [partial_order P]
variables (Q : Type uQ) [partial_order Q]
variables (R : Type uR) [partial_order R]
variables (S : Type uS) [partial_order S]

namespace poset

structure hom :=
(val : P → Q)
(property : monotone val)

instance : has_coe_to_fun (hom P Q) (λ _, P → Q) := {
 coe := λ f, f.val
}

@[ext]
lemma hom_ext (f g : hom P Q) :
  (∀ (p : P), f p = g p) → f = g :=
begin
  rcases f with ⟨f,hf⟩,
  rcases g with ⟨g,hg⟩,
  intro h,
  have h' : f = g := funext h,
  rcases h', refl,
end

def id : hom P P := ⟨_root_.id,monotone_id⟩

lemma id_val : (id P).val = _root_.id := rfl

variables {P Q R}

instance hom_order : partial_order (hom P Q) := {
 le := λ f g, ∀ p, (f p) ≤ (g p),
 le_refl := λ f p,le_refl (f p),
 le_antisymm := λ f g f_le_g g_le_f,
  begin ext p, exact le_antisymm (f_le_g p) (g_le_f p), end,
 le_trans := λ f g h f_le_g g_le_h p,
   le_trans (f_le_g p) (g_le_h p)
}

@[simp]
lemma id_eval (p : P) : (id P) p = p := rfl

variable (P)
def const (q : Q) : hom P Q := ⟨λ p,q, λ p₀ p₁ hp, le_refl q⟩

def terminal : hom P punit.{uP + 1} := const P punit.star
variable {P}

lemma eq_terminal (f : hom P punit.{uP + 1}) : f = terminal P := by { ext p }

@[irreducible]
def adjoint (f : hom P Q) (g : hom Q P) : Prop :=
  ∀ {p : P} {q : Q}, f p ≤ q ↔ p ≤ g q

def adjoint.iff {f : hom P Q} {g : hom Q P} (h : adjoint f g) :
  ∀ {p : P} {q : Q}, f p ≤ q ↔ p ≤ g q :=
    by { intros p q, unfold adjoint at h, exact h }

def comp : (hom Q R) → (hom P Q) → (hom P R) :=
 λ g f, ⟨g.val ∘ f.val, monotone.comp g.property f.property⟩

lemma comp_val (g : hom Q R) (f : hom P Q) :
 (comp g f).val = g.val ∘ f.val := rfl

lemma id_comp (f : hom P Q) : comp (id Q) f = f := by {ext, refl}
lemma comp_id (f : hom P Q) : comp f (id P) = f := by {ext, refl}
lemma comp_assoc (h : hom R S) (g : hom Q R) (f : hom P Q) :
 comp (comp h g) f = comp h (comp g f) := by {ext, refl}

lemma const_comp (r : R) (f : hom P Q) :
 comp (const Q r) f = const P r := by {ext, refl}

lemma comp_const (g : hom Q R) (q : Q) :
 comp g (const P q) = const P (g q) := by {ext, refl}

lemma comp_mono₂ {g₀ g₁ : hom Q R} {f₀ f₁ : hom P Q}
 (eg : g₀ ≤ g₁) (ef : f₀ ≤ f₁) : comp g₀ f₀ ≤ comp g₁ f₁ :=
 λ p, calc
  g₀.val (f₀.val p) ≤ g₀.val (f₁.val p) : g₀.property (ef p)
  ... ≤ g₁.val (f₁.val p) : eg (f₁.val p)

@[simp]
lemma comp_eval (g : hom Q R) (f : hom P Q) (p : P) :
 (comp g f) p = g (f p) := rfl

def comp' : (hom Q R) × (hom P Q) → (hom P R) :=
 λ ⟨g,f⟩, comp g f

lemma comp'_mono : monotone (@comp' P _ Q _ R _) :=
 λ ⟨g₀,f₀⟩ ⟨g₁,f₁⟩ ⟨eg,ef⟩, comp_mono₂ eg ef

def eval : (hom P Q) → P → Q := λ f p, f.val p

lemma eval_mono₂ {f₀ f₁ : hom P Q} {p₀ p₁ : P}
 (ef : f₀ ≤ f₁) (ep : p₀ ≤ p₁) : eval f₀ p₀ ≤ eval f₁ p₁ :=
calc
  f₀.val p₀ ≤ f₀.val p₁ : f₀.property ep
  ... ≤ f₁.val p₁ : ef p₁

def eval' : (hom P Q) × P → Q := λ ⟨f,p⟩, eval f p

lemma eval'_mono : monotone (@eval' P _ Q _) :=
 λ ⟨f₀,p₀⟩ ⟨f₁,p₁⟩ ⟨ef,ep⟩, eval_mono₂ ef ep

def ins' : P → (hom Q (P × Q)) :=
 λ p, ⟨λ q,⟨p,q⟩, λ q₀ q₁ eq, ⟨le_refl p,eq⟩⟩

lemma ins_mono : monotone (@ins' P _ Q _) :=
 λ p₀ p₁ ep q, ⟨ep,le_refl q⟩

lemma adjoint.unit {f : hom P Q} {g : hom Q P} (h : adjoint f g) :
  id P ≤ comp g f := λ p, h.iff.mp (le_refl (f p))

lemma adjoint.counit {f : hom P Q} {g : hom Q P} (h : adjoint f g) :
  comp f g ≤ id Q := λ q, h.iff.mpr (le_refl (g q))

variable (P)
def π₀ : Type* := quot (has_le.le : P → P → Prop)
variable {P}

def component (p : P) : π₀ P := quot.mk _ p

def connected : P → P → Prop := λ p₀ p₁, component p₀ = component p₁

lemma π₀.sound {p₀ p₁ : P} (hp : p₀ ≤ p₁) :
 component p₀ = component p₁ := quot.sound hp

lemma π₀.epi {X : Type*} (f₀ f₁ : π₀ P → X)
 (h : ∀ p, f₀ (component p) = f₁ (component p)) : f₀ = f₁ :=
  by {apply funext, rintro ⟨p⟩, exact (h p),}

def π₀.lift {X : Type*} (f : P → X)
 (h : ∀ p₀ p₁ : P, p₀ ≤ p₁ → f p₀ = f p₁) :
  (π₀ P) → X := @quot.lift P has_le.le X f h

lemma π₀.lift_beta {X : Type*} (f : P → X)
 (h : ∀ p₀ p₁ : P, p₀ ≤ p₁ → f p₀ = f p₁) (p : P) :
  π₀.lift f h (component p) = f p :=
   @quot.lift_beta P has_le.le X f h p

def π₀.lift₂ {X : Type*} (f : P → Q → X)
 (h : ∀ p₀ p₁ q₀ q₁, p₀ ≤ p₁ → q₀ ≤ q₁ → f p₀ q₀ = f p₁ q₁) :
  (π₀ P) → (π₀ Q) → X :=
begin
 let h1 := λ p q₀ q₁ hq, h p p q₀ q₁ (le_refl p) hq,
 let f1 : P → (π₀ Q) → X := λ p, π₀.lift (f p) (h1 p),
 let hf1 : ∀ p q, f1 p (component q) = f p q := λ p, π₀.lift_beta (f p) (h1 p),
 let h2 : ∀ p₀ p₁, p₀ ≤ p₁ → f1 p₀ = f1 p₁ := λ p₀ p₁ hp,
  begin
   apply π₀.epi,intro q,rw[hf1,hf1],
   exact h p₀ p₁ q q hp (le_refl q),
  end,
 exact π₀.lift f1 h2
end

lemma π₀.lift₂_beta {X : Type*} (f : P → Q → X)
 (h : ∀ p₀ p₁ q₀ q₁, p₀ ≤ p₁ → q₀ ≤ q₁ → f p₀ q₀ = f p₁ q₁)
  (p : P) (q : Q) : (π₀.lift₂ f h) (component p) (component q) = f p q :=
begin
 unfold π₀.lift₂,simp only [],rw[π₀.lift_beta,π₀.lift_beta],
end

lemma parity_induction (u : ℕ → Prop)
  (h_zero : u 0)
  (h_even : ∀ i, u (2 * i) → u (2 * i + 1))
  (h_odd  : ∀ i, u (2 * i + 1) → u (2 * i + 2)) :
  ∀ i, u i
| 0 := h_zero
| (i + 1) :=
begin
  have ih := parity_induction i,
  let k := i.div2,
  have hi : cond i.bodd 1 0 + 2 * k = i := nat.bodd_add_div2 i,
  rcases i.bodd ; intro hk; rw[cond] at hk,
  { rw [zero_add] at hk,
    rw [← hk] at ih ⊢,
    exact h_even k ih },
  { rw [add_comm] at hk,
    rw [← hk] at ih ⊢,
    exact h_odd k ih }
end

lemma zigzag (u : ℕ → P)
  (h_even : ∀ i, u (2 * i) ≤ u (2 * i + 1))
  (h_odd : ∀ i, u (2 * i + 2) ≤ u(2 * i + 1)) :
   ∀ i, component (u i) = component (u 0) :=
parity_induction
 (λ i, component (u i) = component (u 0))
 rfl
 (λ i h, (π₀.sound (h_even i)).symm.trans h)
 (λ i h, (π₀.sound (h_odd i)).trans h)

variables (P Q)
def homₕ := π₀ (hom P Q)

def idₕ : homₕ P P := component (id P)

variables {P Q}

def compₕ : (homₕ Q R) → (homₕ P Q) → (homₕ P R) :=
 π₀.lift₂ (λ g f, component (comp g f)) (begin
  intros g₀ g₁ f₀ f₁ hg hf,
  let hgf := comp_mono₂ hg hf,
  let hgf' := π₀.sound hgf,
  exact (π₀.sound (comp_mono₂ hg hf))
 end)

lemma compₕ_def (g : hom Q R) (f : hom P Q) :
 compₕ (component g) (component f) = component (comp g f) :=
  by {simp[compₕ,π₀.lift₂_beta]}

lemma id_compₕ (f : homₕ P Q) : compₕ (idₕ Q) f = f :=
 begin
  rcases f with ⟨f⟩,
  change compₕ (component (id Q)) (component f) = component f,
  rw[compₕ_def,id_comp],
 end

lemma comp_idₕ (f : homₕ P Q) : compₕ f (idₕ P) = f :=
 begin
  rcases f with ⟨f⟩,
  change compₕ (component f) (component (id P)) = component f,
  rw[compₕ_def,comp_id],
 end

lemma comp_assocₕ (h : homₕ R S) (g : homₕ Q R) (f : homₕ P Q) :
 compₕ (compₕ h g) f = compₕ h (compₕ g f) :=
 begin
  rcases h with ⟨h⟩, rcases g with ⟨g⟩, rcases f with ⟨f⟩,
  change compₕ (compₕ (component h) (component g)) (component f) =
         compₕ (component h) (compₕ (component g) (component f)),
  repeat {rw[compₕ_def]},rw[comp_assoc],
 end

variables (P Q)
structure equivₕ :=
(to_fun : homₕ P Q)
(inv_fun : homₕ Q P)
(left_inv : compₕ inv_fun to_fun = idₕ P)
(right_inv : compₕ to_fun inv_fun = idₕ Q)

@[refl] def equivₕ.refl : equivₕ P P :=
{ to_fun := idₕ P, inv_fun := idₕ P,
  left_inv := comp_idₕ _,
  right_inv := comp_idₕ _ }

variables {P Q}

@[symm] def equivₕ.symm (e : equivₕ P Q) : equivₕ Q P :=
{ to_fun := e.inv_fun, inv_fun := e.to_fun,
  left_inv := e.right_inv, right_inv := e.left_inv }

@[trans] def equivₕ.trans (e : equivₕ P Q) (f : equivₕ Q R) : (equivₕ P R) :=
{ to_fun  := compₕ f.to_fun e.to_fun,
  inv_fun := compₕ e.inv_fun f.inv_fun,
  left_inv := by
    rw [comp_assocₕ, ← comp_assocₕ _ f.inv_fun, f.left_inv,
        id_compₕ, e.left_inv],
  right_inv := by
    rw [comp_assocₕ, ← comp_assocₕ _ e.to_fun, e.right_inv,
        id_compₕ, f.right_inv] }

lemma adjoint.unitₕ {f : hom P Q} {g : hom Q P} (h : adjoint f g) :
  compₕ (component g) (component f) = idₕ P :=
begin
  have : id P ≤ comp g f := by { apply adjoint.unit, assumption },
  exact (π₀.sound this).symm
end

lemma adjoint.counitₕ {f : hom P Q} {g : hom Q P} (h : adjoint f g) :
  compₕ (component f) (component g) = idₕ Q :=
begin
  have : comp f g ≤ id Q := by { apply adjoint.counit, assumption },
  exact (π₀.sound this)
end

/-- LaTeX: rem-adjoint-strong -/
def equivₕ_of_adjoint {f : hom P Q} {g : hom Q P} (h : adjoint f g) :
  equivₕ P Q :=
{ to_fun := component f,
  inv_fun := component g,
  left_inv := adjoint.unitₕ h,
  right_inv := adjoint.counitₕ h }

variable (P)

/-- defn-strongly-contractible -/
def contractibleₕ := nonempty (equivₕ P punit.{uP + 1})

variable {P}

lemma contractibleₕ_of_smallest {m : P} (h : ∀ p, m ≤ p) : contractibleₕ P :=
begin
  have : adjoint (const punit.{uP + 1} m) (terminal P) :=
  begin
    unfold adjoint,
    rintro ⟨⟩ p,
    change m ≤ p ↔ punit.star ≤ punit.star,
    simp only [le_refl, h p],
  end,
  let hh := equivₕ_of_adjoint this,
  exact ⟨hh.symm⟩,
end

def π₀.map (f : hom P Q) : (π₀ P) → (π₀ Q) :=
 π₀.lift (λ p, component (f p)) (λ p₀ p₁ ep, quot.sound (f.property ep))

lemma π₀.map_def (f : hom P Q) (p : P) : π₀.map f (component p) = component (f p) :=
 by { simp [π₀.map, π₀.lift_beta] }

lemma π₀.map_congr {f₀ f₁ : hom P Q} (ef : f₀ ≤ f₁) : π₀.map f₀ = π₀.map f₁ :=
begin
  apply π₀.epi,
  intro p,
  rw [π₀.map_def, π₀.map_def],
  exact π₀.sound (ef p)
end

variable (P)
lemma π₀.map_id : π₀.map (id P) = _root_.id :=
 by { apply π₀.epi, intro p, rw[π₀.map_def], refl }
variable {P}

lemma π₀.map_comp (g : hom Q R) (f : hom P Q) :
 π₀.map (comp g f) = (π₀.map g) ∘ (π₀.map f) :=
  by { apply π₀.epi, intro p, rw[π₀.map_def], refl }

def evalₕ : (homₕ P Q) → (π₀ P) → (π₀ Q) :=
 π₀.lift π₀.map (@π₀.map_congr _ _ _ _)

variables {P Q}

def comma (f : hom P Q) (q : Q) := { p : P // f p ≤ q }

instance comma_order (f : hom P Q) (q : Q) :
  partial_order (comma f q) := by { dsimp[comma], apply_instance }

def cocomma (f : hom P Q) (q : Q) := { p : P // q ≤ f p }

instance cocomma_order (f : hom P Q) (q : Q) :
  partial_order (cocomma f q) := by { dsimp[cocomma], apply_instance }

/-- Here we define predicates finalₕ and cofinalₕ.
  If (finalₕ f) holds then f is homotopy cofinal, by
  prop-cofinal.  The dual is also valid, but the converse
  is not.
-/

def finalₕ (f : hom P Q) : Prop :=
  ∀ q, contractibleₕ (cocomma f q)

def cofinalₕ (f : hom P Q) : Prop :=
  ∀ q, contractibleₕ (comma f q)

variable (P)

structure fin_ranking :=
(card : ℕ)
(rank : P ≃ fin card)
(rank_mono : monotone rank.to_fun)

section sort

variable {P}
variable [decidable_rel (has_le.le : P → P → Prop)]

def is_semisorted (l : list P) : Prop :=
  l.pairwise (λ a b, ¬ b < a)

lemma mem_ordered_insert (x p : P) (l : list P) :
  x ∈ (l.ordered_insert has_le.le p) ↔ x = p ∨ x ∈ l :=
begin
  rw [list.perm.mem_iff (list.perm_ordered_insert _ _ _)],
  apply list.mem_cons_iff
end

lemma insert_semisorted (p : P) (l : list P) (h : is_semisorted l) :
  is_semisorted (l.ordered_insert has_le.le p) :=
begin
  induction h with q l hq hl ih,
  { apply list.pairwise_singleton },
  { dsimp [list.ordered_insert],
    split_ifs with hpq,
    { apply list.pairwise.cons,
      { intros x x_in_ql,
        rcases (list.mem_cons_iff _ _ _).mp x_in_ql with ⟨⟨⟩⟩ | x_in_l,
        { exact not_lt_of_ge hpq },
        { intro x_lt_p,
          exact hq x x_in_l (lt_of_lt_of_le x_lt_p hpq) } },
      { exact list.pairwise.cons hq hl } },
    { apply list.pairwise.cons,
      { intros x x_in_pl x_lt_q,
        rw [mem_ordered_insert] at x_in_pl,
        rcases x_in_pl with ⟨⟨⟩⟩ | x_in_l,
        { exact hpq (le_of_lt x_lt_q) },
        { exact hq x x_in_l x_lt_q } },
      { exact ih } } }
end

lemma insertion_sort_semisorted (l : list P) :
  is_semisorted (l.insertion_sort (has_le.le : P → P → Prop)) :=
begin
  induction l with p l ih,
  { apply list.pairwise.nil },
  { dsimp [list.insertion_sort],
    apply insert_semisorted,
    exact ih }
end

variable (P)

lemma exists_fin_ranking [fintype P] : nonempty (fin_ranking P) :=
begin
  rcases fintype.equiv_fin P with f,
  let n := fintype.card P,
  let l := (fin.elems_list n).map f.symm,
  have l_nodup : l.nodup :=
    list.nodup.map f.symm.injective (fin.elems_list_nodup _),
  have l_univ : ∀ p, p ∈ l := λ p,
  begin
    apply list.mem_map.mpr,
    exact ⟨f.to_fun p, ⟨fin.elems_list_complete (f.to_fun p),f.left_inv p⟩⟩
  end,
  have l_length : l.length = n :=
    (list.length_map f.symm (fin.elems_list _)).trans (fin.elems_list_length _),
  let ls := l.insertion_sort has_le.le,
  let ls_perm := list.perm_insertion_sort has_le.le l,
  have ls_sorted : is_semisorted ls :=
    insertion_sort_semisorted l,
  have ls_nodup : ls.nodup :=
    (list.perm.nodup_iff ls_perm).mpr l_nodup,
  have ls_univ : ∀ p, p ∈ ls := λ p,
    (list.perm.mem_iff ls_perm).mpr (l_univ p),
  have ls_length : ls.length = n :=
    (list.perm.length_eq ls_perm).trans l_length,
  let inv_fun : (fin n) → P :=
    λ i, ls.nth_le i.val (@eq.subst ℕ (nat.lt i.val) _ _ ls_length.symm i.is_lt),
  let to_fun_aux : ∀ a : P, {i : fin n // inv_fun i = a} :=
  begin
    intro p,
    let i_val := ls.index_of p,
    let i_lt_l := list.index_of_lt_length.mpr (ls_univ p),
    let i_lt_n : i_val < n := @eq.subst ℕ (nat.lt i_val) _ _ ls_length i_lt_l,
    let i : fin n := ⟨i_val,i_lt_n⟩,
    have : inv_fun i = p := list.index_of_nth_le i_lt_l,
    exact ⟨i,this⟩
  end,
  let to_fun : P → (fin n) := λ p, (to_fun_aux p).val,
  let left_inv : ∀ p : P, inv_fun (to_fun p) = p :=
    λ p, (to_fun_aux p).property,
  let right_inv : ∀ i : (fin n), to_fun (inv_fun i) = i :=
  begin
   intro i,cases i with i_val i_is_lt,
   apply fin.eq_of_veq,
   let i_lt_l : i_val < ls.length :=
    @eq.subst ℕ (nat.lt i_val) _ _ ls_length.symm i_is_lt,
   exact list.nth_le_index_of ls_nodup i_val i_lt_l,
  end,
  let g : P ≃ (fin n) := ⟨to_fun,inv_fun,left_inv,right_inv⟩,
  have g_mono : monotone g.to_fun := λ p q hpq,
  begin
    let i := g.to_fun p,
    let j := g.to_fun q,
    have hp : g.inv_fun i = p := g.left_inv p,
    have hq : g.inv_fun j = q := g.left_inv q,
    have hi : i.val < ls.length := by { rw [ls_length], exact i.is_lt },
    have hj : j.val < ls.length := by { rw [ls_length], exact j.is_lt },
    by_cases h : i ≤ j, { exact h },
    exfalso,
    replace h := lt_of_not_ge h,
    have hp' : ls.nth_le i.val hi = g.inv_fun i := rfl,
    have hq' : ls.nth_le j.val hj = g.inv_fun j := rfl,
    let h_ne  := list.pairwise_nth_iff.mp ls_nodup h hi,
    let h_ngt := list.pairwise_nth_iff.mp ls_sorted h hi,
    rw [hp', hq', hp, hq] at h_ne h_ngt,
    exact h_ngt (lt_of_le_of_ne hpq h_ne.symm),
  end,
  exact ⟨⟨n,g,g_mono⟩⟩
end

end sort

end poset


import tactic

structure Dict (α : Type*) (β : Type*) :=
  (data : α -> option β)

namespace Dict
  variables {α β : Type*}
  [decidable_eq α]

  def empty : Dict α β :=
    ⟨λ k, none⟩

  def add (d : Dict α β) (k : α) (e : β) : Dict α β :=
    ⟨λ k', if k' = k then e else d.data k'⟩

  def rem (d : Dict α β) (k : α) : Dict α β :=
    ⟨λ k', if k' = k then none else d.data k'⟩

  def get (d : Dict α β) (k : α) : option β := d.data k

  def inDict (d : Dict α β) (x : α) := d.get x ≠ none

  instance : has_mem α (Dict α β) := ⟨λ k d, inDict d k⟩

  def subDictOf (d1 d2 : Dict α β) := ∀ k ∈ d1, d1.get k = d2.get k

  theorem emptySubdictAll (d : Dict α β) : subDictOf empty d :=
  begin
    intros k h,
    exact congr_fun (false.rec (empty.get = λ (k : α), get d k) (h rfl)) k,
  end

  theorem subDictSelf (d : Dict α β) : subDictOf d d :=
  begin
    intros k h,
    refl,
  end

  theorem getSome {d : Dict α β} {x : α} {y : β} : Dict.get d x = (some y) -> x ∈ d :=
  begin
    intro h,
    unfold has_mem.mem,
    rw inDict,
    rw h,
    simp only [ne.def, not_false_iff],
  end

  theorem subDictAdd {d1 d2 : Dict α β} (h : subDictOf d1 d2) :
  ∀ k e, subDictOf (add d1 k e) (add d2 k e)
  :=
  begin
    intros k e k' h',
    simp only [add, get],
    split_ifs with lem,
    { refl },
    specialize h k',
    simp only [has_mem.mem, inDict, get, add, lem, if_false, ne.def] at h',
    exact h h',
  end
end Dict


import MLIR.Util.FinInt
import MLIR.Dialects.ArithSemantics
open MLIR.AST

abbrev FinIntPred1 := (sz: Nat) → FinInt sz → Bool
abbrev FinIntPred2 := (sz: Nat) → FinInt sz → FinInt sz → Bool
abbrev FinIntPred3 := (sz: Nat) → FinInt sz → FinInt sz → FinInt sz → Bool

def isTautologyUpTo1 (sz: Nat) (P: FinIntPred1): Bool :=
  match sz with
  | 0 => P 0 .nil
  | sz+1 =>
      isTautologyUpTo1 sz (fun sz n => P (sz+1) n.O) &&
      isTautologyUpTo1 sz (fun sz n => P (sz+1) n.I)

def isTautologyUpTo2 (sz: Nat) (P: FinIntPred2): Bool :=
  match sz with
  | 0 => P 0 .nil .nil
  | sz+1 =>
      isTautologyUpTo2 sz (fun sz n m => P (sz+1) n.O m.O) &&
      isTautologyUpTo2 sz (fun sz n m => P (sz+1) n.O m.I) &&
      isTautologyUpTo2 sz (fun sz n m => P (sz+1) n.I m.O) &&
      isTautologyUpTo2 sz (fun sz n m => P (sz+1) n.I m.I)

def P₁: FinIntPred2 := fun _ X Y =>
  ((X ||| Y) - X) = ((X ^^^ -1) &&& Y)

theorem P₁_tautology8: isTautologyUpTo2 8 P₁ := by
  native_decide

def P₂: FinIntPred2 := fun _ X Y =>
  (X + Y) - (X &&& Y) = (X ||| Y)

theorem P₂_tautology8: isTautologyUpTo2 8 P₂ := by
  native_decide

def P₃: FinIntPred2 := fun _ X Y =>
  -(FinInt.select 0 (-X) Y) = FinInt.select 0 X (-Y) &&
  -(FinInt.select 1 (-X) Y) = FinInt.select 1 X (-Y)

theorem P₃_tautology8: isTautologyUpTo2 8 P₃ := by
  native_decide

--

axiom alive1 (P: FinIntPred1):
  isTautologyUpTo1 8 P → ∀ sz n, P sz n

axiom alive2 (P: FinIntPred2):
  isTautologyUpTo2 8 P → ∀ sz n m, P sz n m

---

namespace BruteforceThm1
def LHS: Region arith := [mlir_region|{
    %_1 = "addi"(%X, %Y): (i32, i32) -> i32
    %_2 = "andi"(%X, %Y): (i32, i32) -> i32
    %r = "subi"(%_1, %_2): (i32, i32) -> i32
}]
def RHS: Region arith := [mlir_region|{
  ^bb:
    %r = "ori"(%X, %Y): (i32, i32) -> i32
}]
def INPUT (X Y: FinInt 32): SSAEnv arith := SSAEnv.One [
  ("X", ⟨.i32, X⟩), ("Y", ⟨.i32, Y⟩)
]

-- Too long... times out during type checking
/-
theorem equivalent (X Y: FinInt 32):
    (run (denoteBB _ LHS) (INPUT X Y) |>.snd.get "r" .i32) =
    (run (denoteBB _ RHS) (INPUT X Y) |>.snd.get "r" .i32) := by
  simp [LHS, RHS, INPUT]
  simp [run, denoteBB, denoteBBStmt, denoteOp]; simp_itree
  simp [interpUB']; simp_itree
  simp [interpSSA', Fitree.interpState, SSAEnvE.handle, SSAEnv.get]; simp_itree
  repeat (simp [SSAEnv.get]; simp_itree)
  have h := alive2 _ P₂_tautology8 _ X Y
  simp [P₂] at h; assumption
-/
end BruteforceThm1


import Qpf

open MvQPF

-- inductive QpfStruct (α : Type) where
--   mk : α → QpfStruct α

namespace QpfStruct

  abbrev HeadT  := Unit

  @[simp]
  abbrev ChildT : HeadT → TypeVec 2
    := fun _ i => match i with
        | 0 => Empty
        | 1 => Unit

  abbrev P := MvPFunctor.mk HeadT ChildT

  abbrev QpfStruct (α : Type)
    := Fix P.Obj (fun _ => α)

  abbrev mk {α : Type} (a : α) : QpfStruct α
    := Fix.mk ⟨(), fun i _ => match i with
                                | 0 => by contradiction
                                | 1 => a
    ⟩

  -- def rec {α}
  --         {motive : QpfStruct α → Sort _}
  --         : ((a : α) → motive (mk a))
  --         → (t : QpfStruct α)
  --         → motive t :=
  --   fun recurse t =>
  --     let g := fun ⟨a, f⟩ =>
  --       by cases a
  --          let a := f 1(a₁, ..., aₘ).append1, Vec.cons] at a;
  --          apply recurse a
  --     Fix.drec (β := motive) g t

  abbrev rec {α motive} := Fix.drec (F:=P.Obj) (α := α) (β := motive)

  -- open MvPFunctor in
  -- example : QpfStruct α → α :=
  --   by intro x
  --      let x := Fix.dest x;
  --      simp [Obj, TypeVec.append1] at x;
  --      cases x
  --     --  have : ∃ a f, x = Fix.mk ⟨a, f⟩
  --     --   := by unfold QpfStruct

  --      cases x using QpfStruct.rec

end QpfStruct

open QpfStruct (QpfStruct)


import Kenny_comm_alg.ideal_lattice

noncomputable theory
local attribute [instance] classical.prop_decidable

universe u

namespace is_ideal

section maximal_ideal

parameters {α : Type u} [comm_ring α] (P : set α) [hp : is_proper_ideal P]
include hp

def find_maximal_ideal.partial_order : partial_order {S : set α // P ⊆ S ∧ is_proper_ideal S} :=
subrel.partial_order

def find_maximal_ideal.inhabited : inhabited {S : set α // P ⊆ S ∧ is_proper_ideal S} :=
⟨⟨P, set.subset.refl P, hp⟩⟩

local attribute [instance] find_maximal_ideal.partial_order find_maximal_ideal.inhabited

private theorem find_maximal_ideal.aux :
  ∃ (M : {S : set α // P ⊆ S ∧ is_proper_ideal S}), ∀ x, M ≤ x → x = M :=
zorn.zorn' {S : set α // P ⊆ S ∧ is_proper_ideal S} $
λ c x hx hc, ⟨⟨{y | ∃ S : {S : set α // P ⊆ S ∧ is_proper_ideal S}, S ∈ c ∧ y ∈ S.val},
  λ z hz, ⟨x, hx, x.2.1 hz⟩,
  { zero_ := ⟨x, hx, @@is_ideal.zero _ x.1 x.2.2.to_is_ideal⟩,
    add_  := λ x y ⟨Sx, hxc, hx⟩ ⟨Sy, hyc, hy⟩,
      or.cases_on (hc Sx Sy hxc hyc)
        (λ hxy, ⟨Sy, hyc, @@is_ideal.add _ Sy.2.2.to_is_ideal (hxy hx) hy⟩)
        (λ hyx, ⟨Sx, hxc, @@is_ideal.add _ Sx.2.2.to_is_ideal hx (hyx hy)⟩),
    smul  := λ x y ⟨Sy, hyc, hy⟩,
      ⟨Sy, hyc, @@is_ideal.mul_left _ Sy.2.2.to_is_ideal hy⟩,
    ne_univ := λ h, by rw set.eq_univ_iff_forall at h;
      rcases h 1 with ⟨S, hsc, hs⟩; apply S.2.2.ne_univ;
      exact @@is_submodule.univ_of_one_mem _ S.1
        S.2.2.to_is_ideal.to_is_submodule hs }⟩,
λ S hsc z hzs, ⟨S, hsc, hzs⟩⟩

def find_maximal_ideal : set α :=
(classical.some find_maximal_ideal.aux).1

theorem find_maximal_ideal.contains : P ⊆ find_maximal_ideal :=
(classical.some find_maximal_ideal.aux).2.1

def find_maximal_ideal.is_maximal_ideal :
  is_maximal_ideal find_maximal_ideal :=
let M : {S : set α // P ⊆ S ∧ is_proper_ideal S} :=
classical.some find_maximal_ideal.aux in
{ eq_or_univ_of_subset := λ T ht hmt, or_iff_not_imp_right.2 $
    λ h, congr_arg subtype.val $
    classical.some_spec find_maximal_ideal.aux
    ⟨T, set.subset.trans M.2.1 hmt, { ne_univ := h, .. ht }⟩ hmt,
  ..M.2.2 }

end maximal_ideal

section nonunits

parameters {α : Type u} [comm_ring α]
parameters (x : α) (hx : x ∈ nonunits α)

include hx

theorem ne_univ_of_nonunits : span ({x}:set α) ≠ set.univ :=
begin
  intro h,
  rw [span_singleton, set.eq_univ_iff_forall] at h,
  exact hx (h 1)
end

def find_maximal_ideal.of_nonunits : set α :=
@@find_maximal_ideal _ (span ({x}:set α))
{ ne_univ := ne_univ_of_nonunits }

theorem find_maximal_ideal.of_nonunits.mem :
  x ∈ find_maximal_ideal.of_nonunits :=
@@find_maximal_ideal.contains _ (span ({x}:set α))
{ ne_univ := ne_univ_of_nonunits } $
subset_span $ set.mem_singleton x

def find_maximal_ideal.of_nonunits.is_maximal_ideal :
  is_maximal_ideal find_maximal_ideal.of_nonunits :=
@@find_maximal_ideal.is_maximal_ideal _ (span ({x}:set α))
{ ne_univ := ne_univ_of_nonunits }

end nonunits

section zero_ne_one

parameters {α : Type u} [comm_ring α]
parameters (hzo : (0:α) ≠ 1)

include hzo

def find_maximal_ideal.of_zero_ne_one : set α :=
find_maximal_ideal.of_nonunits 0 $
λ ⟨y, h⟩, hzo $ by simpa using h

def find_maximal_ideal.of_zero_ne_one.is_maximal_ideal :
  is_maximal_ideal find_maximal_ideal.of_zero_ne_one :=
find_maximal_ideal.of_nonunits.is_maximal_ideal 0 $
λ ⟨y, h⟩, hzo $ by simpa using h

end zero_ne_one

end is_ideal


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Mario Carneiro

The Schröder-Bernstein theorem, and well ordering of cardinals.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.order.fixed_points
import Mathlib.order.zorn
import Mathlib.PostPort

universes u v

namespace Mathlib

namespace function

namespace embedding

theorem schroeder_bernstein {α : Type u} {β : Type v} {f : α → β} {g : β → α} (hf : injective f)
    (hg : injective g) : ∃ (h : α → β), bijective h :=
  sorry

theorem antisymm {α : Type u} {β : Type v} : (α ↪ β) → (β ↪ α) → Nonempty (α ≃ β) := sorry

theorem min_injective {ι : Type u} {β : ι → Type v} (I : Nonempty ι) :
    ∃ (i : ι), Nonempty ((j : ι) → β i ↪ β j) :=
  sorry

theorem total {α : Type u} {β : Type v} : Nonempty (α ↪ β) ∨ Nonempty (β ↪ α) := sorry

end Mathlib


/-
Copyright (c) 2018 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin

Nonnegative real numbers.
-/
import data.real.nnreal analysis.real analysis.topology.infinite_sum
noncomputable theory
open set topological_space

namespace nnreal
local notation ` ℝ≥0 ` := nnreal

instance : metric_space ℝ≥0 := by unfold nnreal; apply_instance
instance : topological_space ℝ≥0 := infer_instance

instance : topological_semiring ℝ≥0 :=
{ continuous_mul :=
   continuous_subtype_mk _
        (continuous_mul (continuous.comp continuous_fst continuous_subtype_val)
                        (continuous.comp continuous_snd continuous_subtype_val)),
  continuous_add :=
    continuous_subtype_mk _
          (continuous_add (continuous.comp continuous_fst continuous_subtype_val)
                          (continuous.comp continuous_snd continuous_subtype_val)) }

instance : orderable_topology ℝ≥0 :=
⟨ le_antisymm
    begin
      apply induced_le_iff_le_coinduced.2,
      rw [orderable_topology.topology_eq_generate_intervals ℝ],
      apply generate_from_le,
      assume s hs,
      rcases hs with ⟨a, rfl | rfl⟩,
      { show topological_space.generate_open _ {b : ℝ≥0 | a < b },
        by_cases ha : 0 ≤ a,
        { exact topological_space.generate_open.basic _ ⟨⟨a, ha⟩, or.inl rfl⟩ },
        { have : a < 0, from lt_of_not_ge ha,
          have : {b : ℝ≥0 | a < b } = set.univ,
            from (set.eq_univ_iff_forall.2 $ assume b, lt_of_lt_of_le this b.2),
          rw [this],
          exact topological_space.generate_open.univ _ } },
      { show (topological_space.generate_from _).is_open {b : ℝ≥0 | a > b },
        by_cases ha : 0 ≤ a,
        { exact topological_space.generate_open.basic _ ⟨⟨a, ha⟩, or.inr rfl⟩ },
        { have : {b : ℝ≥0 | a > b } = ∅,
            from (set.eq_empty_iff_forall_not_mem.2 $ assume b hb, ha $
              show 0 ≤ a, from le_trans b.2 (le_of_lt hb)),
          rw [this],
          apply @is_open_empty } },
    end
    (generate_from_le $ assume s hs,
    match s, hs with
    | _, ⟨⟨a, ha⟩, or.inl rfl⟩ := ⟨{b : ℝ | a < b}, is_open_lt' a, rfl⟩
    | _, ⟨⟨a, ha⟩, or.inr rfl⟩ := ⟨{b : ℝ | b < a}, is_open_gt' a, set.ext $ assume b, iff.refl _⟩
    end) ⟩

section coe
variable {α : Type*}
open filter

lemma continuous_of_real : continuous nnreal.of_real :=
continuous_subtype_mk _ $ continuous_max continuous_id continuous_const

lemma continuous_coe : continuous (coe : nnreal → ℝ) :=
continuous_subtype_val

lemma tendsto_coe {f : filter α} {m : α → nnreal} :
  ∀{x : nnreal}, tendsto (λa, (m a : ℝ)) f (nhds (x : ℝ)) ↔ tendsto m f (nhds x)
| ⟨r, hr⟩ := by rw [nhds_subtype_eq_comap, tendsto_comap_iff]; refl

lemma tendsto_of_real {f : filter α} {m : α → ℝ} {x : ℝ} (h : tendsto m f (nhds x)):
  tendsto (λa, nnreal.of_real (m a)) f (nhds (nnreal.of_real x)) :=
h.comp (continuous_iff_tendsto.1 continuous_of_real _)

lemma tendsto_sub {f : filter α} {m n : α → nnreal} {r p : nnreal}
  (hm : tendsto m f (nhds r)) (hn : tendsto n f (nhds p)) :
  tendsto (λa, m a - n a) f (nhds (r - p)) :=
tendsto_of_real $ tendsto_sub (tendsto_coe.2 hm) (tendsto_coe.2 hn)

lemma is_sum_coe {f : α → nnreal} {r : nnreal} : is_sum (λa, (f a : ℝ)) (r : ℝ) ↔ is_sum f r :=
by simp [is_sum, sum_coe.symm, tendsto_coe]

lemma has_sum_coe {f : α → nnreal} : has_sum (λa, (f a : ℝ)) ↔ has_sum f :=
begin
  simp [has_sum],
  split,
  exact assume ⟨a, ha⟩, ⟨⟨a, is_sum_le (λa, (f a).2) is_sum_zero ha⟩, is_sum_coe.1 ha⟩,
  exact assume ⟨a, ha⟩, ⟨a.1, is_sum_coe.2 ha⟩
end

lemma tsum_coe {f : α → nnreal} (hf : has_sum f) : (∑a, (f a : ℝ)) = ↑(∑a, f a) :=
tsum_eq_is_sum $ is_sum_coe.2 $ is_sum_tsum $ hf

end coe

end nnreal


theorem succ_inj' {a b : mynat} (hs : succ(a) = succ(b)) :  a = b :=
begin
cases hs,
refl,
end

-- theorem succ_inj' {a b : mynat} (hs : succ(a) = succ(b)) :  a = b :=
-- begin
-- exact succ_inj hs,
-- end

-- theorem succ_inj' {a b : mynat} (hs : succ(a) = succ(b)) :  a = b :=
-- begin
-- apply succ_inj,
-- rw hs,
-- refl,
-- end

-- theorem succ_inj' {a b : mynat} (hs : succ(a) = succ(b)) :  a = b :=
-- begin
-- have f := succ_inj,
-- exact f(hs),
-- end


import tactic
import tactic.induction
import logic.function.iterate
import data.list.basic

noncomputable theory
open_locale classical

def get_some {α : Type} [inhabited α] (P : α → Prop) : α :=
if h : ∃ (x : α), P x then h.some else default

def fixed {α : Type} [inhabited α] (f : α → α) (z : α) : α :=
get_some (λ (x : α), ∃ (n : ℕ), (f^[n]) z = x ∧ (f^[n + 1]) z = x)

def all {α : Type} (P : α → Prop) (l : list α) : Prop := l.all (λ (x : α), P x)

def is_digit (n : ℕ) : Prop := n ≤ 9

def is_digit_list (l : list ℕ) : Prop := all is_digit l

def get_digits (n : ℕ) : list ℕ :=
get_some (λ (l : list ℕ), is_digit_list l ∧ l.foldl (λ (a b : ℕ), a * 10 + b) 0 = n)

def sum_digits (n : ℕ) : ℕ := (get_digits n).sum

def digital_root (n : ℕ) : ℕ := fixed sum_digits n

-----

lemma get_some_pos {α : Type} [inhabited α] {P : α → Prop}
  (h : ∃ (x : α), P x) : get_some P = h.some :=
dif_pos h

lemma get_some_eq_get_some_of_exists_iff {α β : Type} [inhabited α]
  {P₁ P₂ : α → Prop} {f : α → β}
  (h₁ : (∃ (x : α), P₁ x) ↔ (∃ (x : α), P₂ x))
  (h₂ : ∀ (h₁ : ∃ (x : α), P₁ x) (h₂ : ∃ (x : α), P₂ x), f h₁.some = f h₂.some) :
  f (get_some P₁) = f (get_some P₂) :=
begin
  simp_rw [get_some, h₁], split_ifs with h₃,
  { apply h₂ },
  { refl },
end

def reversed {α : Type} (f : list α → list α) (l : list α) : list α :=
(f l.reverse).reverse

def trim_start : list ℕ → list ℕ
| (0::l) := trim_start l
| l := l

def trim_end : list ℕ → list ℕ :=
reversed trim_start

instance {n : ℕ} : decidable (is_digit n) :=
by { rw is_digit, apply_instance }

lemma list_reverse_snoc {α : Type} {l : list α} {x : α} :
  (l ++ [x]).reverse = x :: l.reverse := list.reverse_append _ _

lemma trim_start_zero_cons {l : list ℕ} : trim_start (0 :: l) = trim_start l := rfl

lemma trim_start_succ_cons {l : list ℕ} {n : ℕ} :
  trim_start (n.succ :: l) = n.succ :: l := rfl

lemma trim_end_snoc_zero {l : list ℕ} : trim_end (l ++ [0]) = trim_end l :=
by { rw [trim_end, reversed, list_reverse_snoc, trim_start_zero_cons], refl }

lemma list_length_snoc {α : Type} {l : list α} {x : α} :
  (l ++ [x]).length = l.length + 1 := list.length_append _ _

lemma trim_end_snoc_succ {l : list ℕ} {n : ℕ} :
  trim_end (l ++ [n.succ]) = l ++ [n.succ] :=
by rw [trim_end, reversed, list_reverse_snoc, trim_start_succ_cons,
  list.reverse_cons, list.reverse_reverse]

lemma length_trim_end_le {l : list ℕ} : (trim_end l).length ≤ l.length :=
begin
  induction l using list.reverse_rec_on with l n ih,
  { refl },
  { cases n,
    { rw [trim_end_snoc_zero, list_length_snoc],
      exact nat.le_succ_of_le ih },
    { rw [trim_end_snoc_succ] }},
end

lemma list_repeat_succ_snoc {α : Type} {x : α} {n : ℕ} :
  list.repeat x n.succ = list.repeat x n ++ [x] :=
by { rw list.repeat_add x n 1, refl }

lemma trim_end_append_repeat_zero {l : list ℕ} :
  trim_end l ++ list.repeat 0 (l.length - (trim_end l).length) = l :=
begin
  induction l using list.reverse_rec_on with l n ih,
  { refl },
  { cases n,
    { rw [trim_end_snoc_zero, list_length_snoc, nat.sub_add_comm length_trim_end_le,
        list_repeat_succ_snoc, ←list.append_assoc, ih] },
    { rw [trim_end_snoc_succ, list_length_snoc, nat.sub_self,
      list.repeat, list.append_nil] }},
end

lemma all_nil {α : Type} {P : α → Prop} : all P [] := by simp [all]

lemma all_cons {α : Type} {P : α → Prop} {l : list α} {x : α} :
  all P (x :: l) ↔ P x ∧ all P l := by simp [all]

lemma all_iff {α : Type} {P : α → Prop} {l : list α} : all P l ↔ ∀ (x ∈ l), P x :=
begin
  induction l with x l ih,
  { simp [all_nil] },
  { simp [all_cons, ih] },
end

lemma all_append {α : Type} {P : α → Prop} {l₁ l₂ : list α} :
  all P (l₁ ++ l₂) ↔ all P l₁ ∧ all P l₂ :=
begin
  simp_rw all_iff, split; intro h,
  { split; rintro n h₁; apply h n,
    { exact list.mem_append_left _ h₁ },
    { exact list.mem_append_right _ h₁ }},
  { cases h with h₁ h₂, rintro n h₃, rw list.mem_append_eq at h₃, cases h₃,
    { exact h₁ _ h₃ },
    { exact h₂ _ h₃ }},
end

lemma all_singleton {α : Type} {P : α → Prop} {x : α} : all P [x] ↔ P x :=
begin
  simp_rw all_iff, split; intro h,
  { exact h _ (list.mem_singleton_self _) },
  { rintro m h₁, rw list.mem_singleton at h₁, subst m, exact h },
end

lemma all_snoc {α : Type} {P : α → Prop} {l : list α} {x : α} :
  all P (l ++ [x]) ↔ all P l ∧ P x := by rw [all_append, all_singleton]

lemma all_reverse {α : Type} {P : α → Prop} {l : list α} : all P l.reverse ↔ all P l :=
begin
  induction l with n l ih,
  { refl },
  { rw [list.reverse_cons, all_snoc, all_cons], tauto },
end

lemma is_digit_of_is_digit_add {d₁ d₂ : ℕ} (h : is_digit (d₁ + d₂)) :
  is_digit d₁ ∧ is_digit d₂ := ⟨le_of_add_le_left h, le_of_add_le_right h⟩

lemma not_is_digit_add_10 {n : ℕ} : ¬is_digit (n + 10) := dec_trivial

lemma is_digit_mul_10 {n : ℕ} : is_digit (n * 10) ↔ n = 0 :=
begin
  split; intro h,
  { cases n,
    { refl },
    { revert h, rw nat.succ_mul, dec_trivial }},
  { subst n, dec_trivial },
end

lemma sum_eq_zero_of_foldr_eq_zero {l : list ℕ}
  (h : l.foldr (λ (a b : ℕ), a + b * 10) 0 = 0) : l.sum = 0 :=
begin
  induction' l with hd l ih,
  { refl },
  { rw [list.foldr_cons, add_eq_zero_iff] at h, rcases h with ⟨rfl, h⟩,
    apply ih, rw mul_eq_zero at h, cases h,
    { exact h },
    { cases h }},
end

lemma sum_eq_of_foldr_eq_digit {l : list ℕ} {d : ℕ}
  (h₁ : is_digit_list l) (h₂ : is_digit d)
  (h₃ : l.foldr (λ (a b : ℕ), a + b * 10) 0 = d) : l.sum = d :=
begin
  cases l with d₁ l,
  { exact h₃ },
  { rw list.sum_cons, rw list.foldr_cons at h₃, rw [is_digit_list, all_cons] at h₁,
    cases h₁ with h₁ h₄, subst d, congr, have h₃ := (is_digit_of_is_digit_add h₂).2,
    rw is_digit_mul_10 at h₃, rw h₃, exact sum_eq_zero_of_foldr_eq_zero h₃ },
end

lemma is_digit_succ {n : ℕ} : is_digit n.succ ↔ n < 9 :=
begin
  rw [is_digit, le_iff_lt_or_eq], split; intro h,
  { cases h,
    { exact nat.lt_of_succ_lt h },
    { cases h, dec_trivial }},
  { rwa [←nat.succ_le_iff, le_iff_lt_or_eq] at h },
end

lemma nat_exi_mul (x y : ℕ) :
  ∃ (a b : ℕ), a = x / y ∧ b = x % y ∧ x = a * y + b :=
by { simp_rw mul_comm, exact ⟨_, _, rfl, rfl, (nat.div_add_mod _ _).symm⟩ }

lemma is_digit_mod_10 {n : ℕ} : is_digit (n % 10) :=
by { rw [is_digit, ←nat.lt_succ_iff], apply nat.mod_lt, dec_trivial }

lemma digit_ind {P : ℕ → Prop} {n : ℕ}
  (h₁ : P 0) (h₂ : ∀ (d n : ℕ), is_digit d → P n → P (d + n * 10)) : P n :=
begin
  induction n using nat.strong_induction_on with n ih, dsimp at ih,
  obtain ⟨a, b, ha, hb, h₃⟩ := nat_exi_mul n 10, rw [h₃, add_comm], apply h₂,
  { rw hb, exact is_digit_mod_10 },
  { rw ha, cases n,
    { exact h₁ },
    { apply ih, apply nat.div_lt_self; dec_trivial }},
end

def all_zeros (l : list ℕ) : Prop := all (λ (n : ℕ), n = 0) l

lemma foldr_eq_zero_iff {l : list ℕ} :
  l.foldr (λ (a b : ℕ), a + b * 10) 0 = 0 ↔ all_zeros l :=
begin
  induction l with x l ih,
  { simp [all_zeros, all_nil] },
  { rw [list.foldr_cons, all_zeros, all_cons, ←all_zeros, ←ih,
    add_eq_zero_iff, mul_eq_zero], tauto },
end

lemma trim_end_nil : trim_end [] = [] := rfl

lemma trim_end_eq_nil_iff {l : list ℕ} : trim_end l = [] ↔ all_zeros l :=
begin
  induction l using list.reverse_rec_on with l n ih,
  { simp [trim_end_nil, all_zeros, all_nil] },
  { cases n,
    { simp [trim_end_snoc_zero, ih, all_zeros, all_snoc] },
    { simp [trim_end_snoc_succ, all_zeros, all_snoc] }},
end

lemma left_lt_of_add_lt {a b c : ℕ} (h : a + b < c) : a < c := buffer.lt_aux_1 h

lemma right_lt_of_add_lt {a b c : ℕ} (h : a + b < c) : b < c :=
by { rw add_comm at h, exact left_lt_of_add_lt h }

lemma lt_of_add_lt {a b c : ℕ} (h : a + b < c) : a < c ∧ b < c :=
⟨left_lt_of_add_lt h, right_lt_of_add_lt h⟩

lemma not_add_self_lt_self {a b : ℕ} : ¬a + b < b :=
by { intro h, cases lt_irrefl _ (right_lt_of_add_lt h) }

lemma eq_zero_of_mul_lt_self {a b : ℕ} (h : a * b < a) : b = 0 :=
begin
  cases b,
  { refl },
  { rw nat.mul_succ at h, cases not_add_self_lt_self h },
end

lemma add_mul_eq_add_mul_iff {k d₁ d₂ a b : ℕ} (h₁ : d₁ < k) (h₂ : d₂ < k) :
  d₁ + a * k = d₂ + b * k ↔ d₁ = d₂ ∧ a = b :=
begin
  split; intro h,
  { induction a with a ih generalizing b,
    { rw [zero_mul, add_zero] at h, subst d₁, have h₃ := right_lt_of_add_lt h₁,
      rw mul_comm at h₃, replace h₃ := eq_zero_of_mul_lt_self h₃, subst b,
      rw zero_mul, exact ⟨rfl, rfl⟩ },
    { rw [nat.succ_mul, ←add_assoc] at h, cases b,
      { rw [zero_mul, add_zero] at h, subst d₂, cases not_add_self_lt_self h₂ },
      { rw [nat.succ_mul, ←add_assoc, add_left_inj] at h,
        rw nat.succ_inj', exact ih h }}},
  { rw [h.1, h.2] },
end

lemma digit_lt_10 {d : ℕ} (h : is_digit d) : d < 10 := by rwa nat.lt_succ_iff

lemma digit_add_mul_10_eq_digit_add_mul_10_iff {d₁ d₂ a b : ℕ}
  (h₁ : is_digit d₁) (h₂ : is_digit d₂) :
  d₁ + a * 10 = d₂ + b * 10 ↔ d₁ = d₂ ∧ a = b :=
by { rw add_mul_eq_add_mul_iff; apply digit_lt_10; assumption }

lemma trim_end_cons {l : list ℕ} {n : ℕ} :
  trim_end (n :: l) = if all_zeros l then trim_end [n] else n :: trim_end l :=
begin
  split_ifs,
  { induction l using list.reverse_rec_on with l m ih,
    { refl },
    { rw [all_zeros, all_snoc, ←all_zeros] at h, rcases h with ⟨h, rfl⟩,
      specialize ih h, rwa [←list.cons_append, trim_end_snoc_zero] }},
  { induction l using list.reverse_rec_on with l m ih,
    { cases h all_nil },
    { rw ←list.cons_append,
      rw [all_zeros, all_snoc, ←all_zeros, not_and_distrib] at h, cases m,
      { simp_rw trim_end_snoc_zero, cases h,
        { exact ih h },
        { cases h rfl }},
      { simp_rw [trim_end_snoc_succ, list.cons_append], use rfl }}},
end

lemma trim_end_all_zeros {l : list ℕ} (h : all_zeros l) : trim_end l = [] :=
by rwa trim_end_eq_nil_iff

lemma trim_end_singleton {n : ℕ} : trim_end [n] = if n = 0 then [] else [n] :=
begin
  split_ifs,
  { subst n, refl },
  { change [n] with [] ++ [n], cases n,
    { cases h rfl },
    { rw trim_end_snoc_succ }},
end

lemma trim_end_same_cons_eq_iff_aux {l₁ l₂ : list ℕ} {n : ℕ}
  (h₁ : all_zeros l₁) (h₂ : ¬all_zeros l₂) :
  trim_end [n] = n :: trim_end l₂ ↔ trim_end l₁ = trim_end l₂ :=
begin
  rw trim_end_all_zeros h₁, split; intro h,
  { rw trim_end_singleton at h, split_ifs at h with h₃,
    { cases h },
    { exact h.2 }},
  { symmetry' at h, rw trim_end_eq_nil_iff at h, contradiction }
end

lemma trim_end_same_cons_eq_iff {l₁ l₂ : list ℕ} {n : ℕ} :
  trim_end (n :: l₁) = trim_end (n :: l₂) ↔ trim_end l₁ = trim_end l₂ :=
begin
  nth_rewrite 0 trim_end_cons, nth_rewrite 1 trim_end_cons, split_ifs with h₁ h₂ h₂,
  { simp [trim_end_all_zeros h₁, trim_end_all_zeros h₂] },
  { exact trim_end_same_cons_eq_iff_aux h₁ h₂ },
  { have := @trim_end_same_cons_eq_iff_aux _ _ n h₂ h₁, tauto },
  { simp }
end

lemma trim_end_eq_trim_end_of_foldr_eq_foldr {l₁ l₂ : list ℕ}
  (h₁ : is_digit_list l₁) (h₂ : is_digit_list l₂)
  (h₃ : l₁.foldr (λ (a b : ℕ), a + b * 10) 0 = l₂.foldr (λ (a b : ℕ), a + b * 10) 0) :
  trim_end l₁ = trim_end l₂ :=
begin
  induction l₁ with n l₁ ih generalizing l₂,
  { rw trim_end_nil, symmetry' at h₃ ⊢, change _ = 0 at h₃,
    rw foldr_eq_zero_iff at h₃, rwa trim_end_eq_nil_iff },
  { rw [is_digit_list, all_cons, ←is_digit_list] at h₁,
    cases h₁ with h₁ h₄, specialize @ih h₄, cases l₂ with m l₂,
    { change _ = 0 at h₃,
      rw [list.foldr_cons, add_eq_zero_iff, mul_eq_zero, foldr_eq_zero_iff] at h₃,
      rcases h₃ with ⟨rfl, h₃⟩, rw [trim_end_nil, trim_end_eq_nil_iff, all_zeros, all_cons],
      use rfl, cases h₃,
      { exact h₃ },
      { cases h₃ }},
    { rw [is_digit_list, all_cons, ←is_digit_list] at h₂, cases h₂ with h₂ h₅,
      simp_rw [list.foldr_cons, digit_add_mul_10_eq_digit_add_mul_10_iff h₁ h₂] at h₃,
      rcases h₃ with ⟨rfl, h₃⟩, rw trim_end_same_cons_eq_iff, exact ih h₅ h₃ }},
end

lemma exi_eq_append_zeros_of_foldr_eq_foldr {l₁ l₂ : list ℕ}
  (h₁ : is_digit_list l₁) (h₂ : is_digit_list l₂)
  (h₃ : l₁.foldr (λ (a b : ℕ), a + b * 10) 0 = l₂.foldr (λ (a b : ℕ), a + b * 10) 0) :
  ∃ (l : list ℕ) (n₁ n₂ : ℕ), l₁ = l ++ list.repeat 0 n₁ ∧ l₂ = l ++ list.repeat 0 n₂ :=
begin
  use [trim_end l₁, l₁.length - (trim_end l₁).length, l₂.length - (trim_end l₁).length,
    trim_end_append_repeat_zero.symm], symmetry,
  rw [(_ : trim_end l₁ = trim_end l₂), trim_end_append_repeat_zero],
  exact trim_end_eq_trim_end_of_foldr_eq_foldr h₁ h₂ h₃,
end

lemma sum_append_repeat_zero {l : list ℕ} {n : ℕ} :
  (l ++ list.repeat 0 n).sum = l.sum :=
by { rw [list.sum_append, list.sum_repeat], refl }

lemma sum_eq_sum_of_foldr_eq_foldr {l₁ l₂ : list ℕ}
  (h₁ : is_digit_list l₁) (h₂ : is_digit_list l₂)
  (h₃ : l₁.foldr (λ (a b : ℕ), a + b * 10) 0 = l₂.foldr (λ (a b : ℕ), a + b * 10) 0) :
  l₁.sum = l₂.sum :=
begin
  obtain ⟨l, n₁, n₂, rfl, rfl⟩ := exi_eq_append_zeros_of_foldr_eq_foldr h₁ h₂ h₃,
  simp_rw sum_append_repeat_zero,
end

lemma sum_eq_sum_of_foldl_eq_foldr {l₁ l₂ : list ℕ}
  (h₁ : is_digit_list l₁) (h₂ : is_digit_list l₂)
  (h₃ : l₁.foldl (λ (a b : ℕ), a * 10 + b) 0 = l₂.foldr (λ (a b : ℕ), a + b * 10) 0) :
  l₁.sum = l₂.sum :=
begin
  rw ←list.sum_reverse l₁,
  rw ←list.foldr_reverse _ _ l₁ at h₃,
  rename l₁ l,
  rw [is_digit_list, ←all_reverse, ←is_digit_list] at h₁,
  revert h₁ h₃,
  generalize : l.reverse = l₁,
  rintro h₁ h₃,
  clear l,
  replace h₃ : list.foldr (λ a b, a + b * 10) 0 l₁ = list.foldr (λ a b, a + b * 10) 0 l₂,
  { convert h₃; ext a b; rw add_comm },
  exact sum_eq_sum_of_foldr_eq_foldr h₁ h₂ h₃,
end

lemma exi_foldl_iff_exi_foldr {n : ℕ} :
  (∃ (l : list ℕ), is_digit_list l ∧ l.foldl (λ (a b : ℕ), a * 10 + b) 0 = n) ↔
  (∃ (l : list ℕ), is_digit_list l ∧ l.foldr (λ (a b : ℕ), a + b * 10) 0 = n) :=
begin
  split; rintro ⟨l, hl, rfl⟩; use l.reverse;
  { rw list.foldl_reverse <|> rw list.foldr_reverse,
    simp_rw add_comm, rw [is_digit_list, all_reverse, ←is_digit_list], use hl },
end

lemma sum_digits_eq_get_some {n : ℕ} :
  sum_digits n = (get_some (λ (l : list ℕ), is_digit_list l ∧
    l.foldr (λ (a b : ℕ), a + b * 10) 0 = n)).sum :=
begin
  apply get_some_eq_get_some_of_exists_iff exi_foldl_iff_exi_foldr,
  rintro h₁ h₂, have h₃ := h₁.some_spec, have h₄ := h₂.some_spec,
  have h₅ : list.foldl (λ (a b : ℕ), a * 10 + b) 0 h₁.some =
    list.foldr (λ (a b : ℕ), a + b * 10) 0 h₂.some := by rw [h₃.2, h₄.2],
  exact sum_eq_sum_of_foldl_eq_foldr h₃.1 h₄.1 h₅,
end

lemma sum_digits_zero : sum_digits 0 = 0 :=
begin
  rw [sum_digits_eq_get_some, get_some_pos], swap,
  { exact ⟨[], all_nil, rfl⟩ },
  generalize_proofs h, exact sum_eq_zero_of_foldr_eq_zero h.some_spec.2,
end

lemma iter_sum_digits_zero {n : ℕ} : (sum_digits^[n]) 0 = 0 :=
begin
  induction' n,
  { refl },
  { rw [function.iterate_succ_apply', ih, sum_digits_zero] },
end

lemma digital_root_zero : digital_root 0 = 0 :=
begin
  rw [digital_root, fixed, get_some_pos], swap,
  { exact ⟨0, 0, rfl, sum_digits_zero⟩ },
  generalize_proofs h₁, obtain ⟨n, h₂, h₃⟩ := h₁.some_spec,
  rw iter_sum_digits_zero at h₂, exact h₂.symm,
end

def modp (n k : ℕ) : ℕ := if n % k = 0 then k else n % k

lemma modp_digit_of_pos {d : ℕ} (h₁ : is_digit d) (h₂ : 0 < d) : modp d 9 = d :=
begin
  rw modp, split_ifs,
  { rw [is_digit, le_iff_lt_or_eq] at h₁, cases h₁,
    { rw nat.mod_eq_of_lt h₁ at h, rw h at h₂, cases h₂ },
    { exact h₁.symm }},
  { rw [is_digit, le_iff_lt_or_eq] at h₁, cases h₁,
    { exact nat.mod_eq_of_lt h₁ },
    { subst d, contradiction }},
end

lemma sum_digits_digit {d : ℕ} (h : is_digit d) : sum_digits d = d :=
begin
  rw [sum_digits_eq_get_some, get_some_pos], swap,
  { exact ⟨[d], all_singleton.mpr h, rfl⟩ },
  generalize_proofs h₁, obtain ⟨h₂, h₃⟩ := h₁.some_spec,
  exact sum_eq_of_foldr_eq_digit h₂ h h₃,
end

lemma iterate_eq_self {α : Type} {f : α → α} {x : α} {n : ℕ}
  (h : f x = x) : (f^[n] x) = x :=
begin
  induction n with n ih,
  { refl },
  { rw [function.iterate_succ_apply', ih, h] },
end

lemma fixed_eq_self_of {α : Type} [inhabited α] {f : α → α} {x : α}
  (h : f x = x) : fixed f x = x :=
begin
  rw [fixed, get_some_pos], swap,
  { exact ⟨x, 0, rfl, h⟩ },
  generalize_proofs h₁, obtain ⟨n, h₂, h₃⟩ := h₁.some_spec,
  rw [←h₂, iterate_eq_self h],
end

lemma digital_root_digit_eq_self {d : ℕ} (h : is_digit d) :
  digital_root d = d := fixed_eq_self_of (sum_digits_digit h)

lemma is_digit_modp_9 {n : ℕ} : is_digit (modp n 9) :=
begin
  rw [is_digit, modp], split_ifs,
  { refl },
  { apply le_of_lt, apply nat.mod_lt, dec_trivial },
end

lemma is_digit_digit_add_digit_sub {d₁ d₂ n : ℕ} (h₁ : is_digit d₁) (h₂ : is_digit d₂)
  (h₃ : 9 ≤ n) : is_digit (d₁ + d₂ - n) :=
begin
  rw is_digit at h₁ h₂ ⊢,
  have h₄ := (add_le_add h₁ h₂).trans (add_le_add (le_refl _) h₃),
  rwa tsub_le_iff_right,
end

lemma exi_digit_add_10_of_not_is_digit_add {d₁ d₂ : ℕ}
  (h₁ : is_digit d₁) (h₂ : is_digit d₂) (h₃ : ¬is_digit (d₁ + d₂)) :
  ∃ (d : ℕ), is_digit d ∧ d₁ + d₂ = d + 10 :=
begin
  refine ⟨d₁ + d₂ - 10, _, _⟩,
  { apply is_digit_digit_add_digit_sub h₁ h₂, dec_trivial },
  { rw [is_digit, not_le] at h₃, obtain ⟨k, h₄⟩ := nat.exists_eq_add_of_lt h₃,
    rw h₄, refine (nat.sub_eq_iff_eq_add _).mp rfl, rw add_right_comm, exact le_self_add },
end

lemma exi_digit_add_9_of_not_is_digit_add {d₁ d₂ : ℕ}
  (h₁ : is_digit d₁) (h₂ : is_digit d₂) (h₃ : ¬is_digit (d₁ + d₂)) :
  ∃ (d : ℕ), is_digit d ∧ d₁ + d₂ = d + 9 :=
begin
  refine ⟨d₁ + d₂ - 9, _, _⟩,
  { apply is_digit_digit_add_digit_sub h₁ h₂, dec_trivial },
  { rw [is_digit, not_le] at h₃, obtain ⟨k, h₄⟩ := nat.exists_eq_add_of_lt h₃,
    rw h₄, refine (nat.sub_eq_iff_eq_add _).mp rfl, apply nat.le_succ_of_le,
    exact le_self_add },
end

lemma is_digit_of_is_digit_succ {d : ℕ} (h : is_digit d.succ) : is_digit d :=
(@is_digit_of_is_digit_add d 1 h).1

lemma sum_eq_of_foldr_eq_digit_add_10 {l : list ℕ} {d : ℕ}
  (h₁ : is_digit_list l) (h₂ : is_digit d)
  (h₃ : l.foldr (λ (a b : ℕ), a + b * 10) 0 = d + 10) : l.sum = d.succ :=
begin
  cases l with d₁ l,
  { cases h₃ },
  { rw list.foldr_cons at h₃, rw [is_digit_list, all_cons, ←is_digit_list] at h₁,
    cases h₁ with h₁ h₄, nth_rewrite 1 ←one_mul 10 at h₃,
    rw digit_add_mul_10_eq_digit_add_mul_10_iff h₁ h₂ at h₃, rcases h₃ with ⟨rfl, h₃⟩,
    rw [list.sum_cons, sum_eq_of_foldr_eq_digit h₄ dec_trivial h₃] },
end

lemma sum_digits_pos_digit_add_9 {d : ℕ} (h₁ : is_digit d) (h₂ : 0 < d) :
  sum_digits (d + 9) = d :=
begin
  cases d,
  { cases h₂ },
  { rw [sum_digits_eq_get_some, get_some_pos], swap,
    { refine ⟨[d, 1], _, _⟩,
      { simp_rw [is_digit_list, all_cons, all_nil],
        exact ⟨is_digit_of_is_digit_succ h₁, dec_trivial, trivial⟩ },
      { refl }},
    generalize_proofs h₃, obtain ⟨h₄, h₅⟩ := h₃.some_spec, change _ = d + 10 at h₅,
    exact sum_eq_of_foldr_eq_digit_add_10 h₄ (is_digit_of_is_digit_succ h₁) h₅ },
end

lemma pos_left_of_not_is_digit_digit_add_digit {d₁ d₂ : ℕ}
  (h₁ : is_digit d₁) (h₂ : is_digit d₂) (h₃ : ¬is_digit (d₁ + d₂)) : 0 < d₁ :=
by { rw is_digit at h₁ h₂ h₃, linarith }

lemma pos_right_of_not_is_digit_digit_add_digit {d₁ d₂ : ℕ}
  (h₁ : is_digit d₁) (h₂ : is_digit d₂) (h₃ : ¬is_digit (d₁ + d₂)) : 0 < d₂ :=
by { rw add_comm at h₃, exact pos_left_of_not_is_digit_digit_add_digit h₂ h₁ h₃ }

lemma sum_digits_digit_add_digit {d₁ d₂ : ℕ} (h₁ : is_digit d₁) (h₂ : is_digit d₂) :
  sum_digits (d₁ + d₂) = if d₁ + d₂ ≤ 9 then d₁ + d₂ else d₁ + d₂ - 9 :=
begin
  split_ifs,
  { exact sum_digits_digit h },
  { obtain ⟨d, h₃, h₄⟩ := exi_digit_add_9_of_not_is_digit_add h₁ h₂ h, have h₅ : 0 < d,
    { rw h₄ at h, push_neg at h, rwa lt_add_iff_pos_left at h },
    rw [h₄, sum_digits_pos_digit_add_9 h₃ h₅], refl },
end

lemma modp_of_le_of_pos {k d : ℕ} (h₁ : 0 < d) (h₂ : d ≤ k) : modp d k = d :=
begin
  rw modp, cases k,
  { rw le_zero_iff at h₂, subst d, refl },
  { split_ifs with h₃,
    { rw le_iff_lt_or_eq at h₂, cases h₂,
      { rw nat.mod_eq_of_lt h₂ at h₃, subst d, cases h₁ },
      { subst d }},
    { rw le_iff_lt_or_eq at h₂, cases h₂,
      { exact nat.mod_eq_of_lt h₂ },
      { subst d, cases h₃ (nat.mod_self _) }}},
end

lemma add_self_mod_eq_zero {a : ℕ} : (a + a) % a = 0 := by simp

lemma modp_add {k a b : ℕ} : modp (a + b) k = modp (modp a k + modp b k) k :=
by { simp_rw modp, split_ifs; simp [*, nat.add_mod] at * }

lemma modp_pos_of_pos {k d : ℕ} (h : 0 < d) : 0 < modp d k :=
begin
  rw modp, split_ifs with h₁,
  { by_contra' h₂, rw le_zero_iff at h₂, subst k,
    rw nat.mod_zero at h₁, subst d, cases h },
  { rwa pos_iff_ne_zero },
end

lemma digital_root_eq_self_of {n : ℕ} (h : sum_digits n = n) :
  digital_root n = n := fixed_eq_self_of h

lemma modp_zero {d : ℕ} : modp d 0 = d :=
begin
  rw [modp, nat.mod_zero], split_ifs,
  { exact h.symm },
  { refl },
end

lemma modp_of_lt {k d : ℕ} (h₁ : 0 < d) (h₂ : d < k) : modp d k = d :=
begin
  rw modp, split_ifs,
  { rw nat.mod_eq_of_lt h₂ at h, subst d, cases h₁ },
  { rw nat.mod_eq_of_lt h₂ },
end

lemma modp_self {k : ℕ} : modp k k = k :=
by { rw [modp, nat.mod_self], refl }

lemma modp_of_le {k d : ℕ} (h₁ : 0 < d) (h₂ : d ≤ k) : modp d k = d :=
begin
  rw le_iff_lt_or_eq at h₂, cases h₂,
  { exact modp_of_lt h₁ h₂ },
  { subst d, rw modp_self },
end

lemma modp_add_self {k d : ℕ} : modp (d + k) k = modp d k :=
begin
  simp_rw modp, split_ifs with h₁ h₂ h₂;
  try { rw nat.add_mod_right at h₁, contradiction },
  { refl },
  { rw nat.add_mod_right },
end

lemma modp_of_gt_of_lt_mul_2 {k d : ℕ} (h₁ : k < d) (h₂ : d < k * 2) : modp d k = d - k :=
begin
  obtain ⟨n, rfl⟩ := nat.exists_eq_add_of_lt h₁, clear h₁,
  replace h₂ : n + 1 < k := by linarith,
  rw [add_rotate k n 1, nat.add_sub_cancel, modp_add_self],
  exact modp_of_lt (nat.succ_pos _) h₂,
end

lemma modp_add_lt {k d₁ d₂ : ℕ} (h₁ : 0 < d₁ ∨ 0 < d₂) (h₂ : d₁ < k) (h₃ : d₂ < k) :
  modp (d₁ + d₂) k = if d₁ + d₂ ≤ k then d₁ + d₂ else d₁ + d₂ - k :=
begin
  split_ifs with h₄,
  { exact modp_of_le ((nat.add_pos_iff_pos_or_pos d₁ d₂).mpr h₁) h₄ },
  { push_neg at h₄, apply modp_of_gt_of_lt_mul_2 h₄, rw mul_two, exact add_lt_add h₂ h₃ },
end

lemma modp_add_le_aux {k d : ℕ} (h : d < k) :
  modp (d + k) k = if d + k ≤ k then d + k else d + k - k :=
begin
  cases d,
  { simp_rw [zero_add, modp_self, if_pos (le_refl _)] },
  { rw [modp_add_self, if_neg, modp_of_lt (nat.succ_pos _) h, nat.add_sub_cancel],
    push_neg, rw [nat.succ_add, nat.lt_succ_iff], exact le_add_self }
end

lemma modp_add_le {k d₁ d₂ : ℕ} (h₁ : 0 < d₁ ∨ 0 < d₂) (h₂ : d₁ ≤ k) (h₃ : d₂ ≤ k) :
  modp (d₁ + d₂) k = if d₁ + d₂ ≤ k then d₁ + d₂ else d₁ + d₂ - k :=
begin
  rw le_iff_lt_or_eq at h₂, cases h₂,
  { rw le_iff_lt_or_eq at h₃, cases h₃,
    { exact modp_add_lt h₁ h₂ h₃ },
    { subst d₂, exact modp_add_le_aux h₂ }},
  { subst d₁, rw add_comm k d₂, rw le_iff_lt_or_eq at h₃, cases h₃,
    { exact modp_add_le_aux h₃ },
    { subst d₂, rw [modp_add_self, modp_self, if_neg, nat.add_sub_cancel],
      push_neg, rw or_self at h₁, exact lt_add_of_pos_left k h₁ }},
end

lemma modp_digit_add_digit {d₁ d₂ : ℕ} (h₁ : is_digit d₁) (h₂ : is_digit d₂)
  (h₃ : 0 < d₁ ∨ 0 < d₂) :
  modp (d₁ + d₂) 9 = if d₁ + d₂ ≤ 9 then d₁ + d₂ else d₁ + d₂ - 9 :=
modp_add_le h₃ h₁ h₂

lemma modp_le {k d : ℕ} (h : 0 < k) : modp d k ≤ k :=
begin
  rw modp, split_ifs with h₁,
  { refl },
  { exact le_of_lt (nat.mod_lt _ h) },
end

lemma modp_self_mul {k n : ℕ} : modp (k * n) k = k :=
by { rw modp, split_ifs; simp * at * }

lemma zero_modp {k : ℕ} : modp 0 k = k :=
by { rw modp, split_ifs; simp * at * }

lemma modp_modp {k d : ℕ} : modp (modp d k) k = modp d k :=
begin
  cases k,
  { simp_rw modp_zero },
  { cases d,
    { simp_rw [zero_modp, modp_self] },
    { exact modp_of_le (modp_pos_of_pos (nat.succ_pos _)) (modp_le (nat.succ_pos _)) }},
end

lemma modp_add_self_mul {k d n : ℕ} : modp (d + k * n) k = modp d k :=
by { rw [modp_add, modp_self_mul, modp_add_self, modp_modp] }

lemma modp_digit_add_mul_10 {d n : ℕ} (h : is_digit d) :
  modp (d + n * 10) 9 = modp (d + n) 9 :=
begin
  change 10 with 9 + 1, rw [mul_add, mul_one], cases d,
  { simp_rw zero_add, rw [add_comm, mul_comm, modp_add_self_mul] },
  { rw [modp_add, modp_digit_of_pos h (nat.succ_pos _),
    add_comm (n * 9), mul_comm, modp_add_self_mul, eq_comm,
    modp_add, modp_digit_of_pos h (nat.succ_pos _)] },
end

lemma lt_mul_of_lt {a b c : ℕ} (h₁ : a < b) (h₂ : 0 < c) : a < b * c :=
begin
  cases c,
  { cases h₂ },
  { rw nat.mul_succ, apply nat.lt_add_left, assumption },
end

lemma le_mul_of_le {a b c : ℕ} (h₁ : a ≤ b) (h₂ : 0 < c) : a ≤ b * c :=
begin
  cases c,
  { cases h₂ },
  { rw nat.mul_succ, exact le_add_left h₁},
end

lemma lt_add_left_iff_lt {a b c : ℕ} : c + a < c + b ↔ a < b :=
by apply rel_iff_cov

lemma le_add_left_iff_le {a b c : ℕ} : c + a ≤ c + b ↔ a ≤ b :=
by apply rel_iff_cov

lemma sum_le_foldr {l : list ℕ} : l.sum ≤ l.foldr (λ (a b : ℕ), a + b * 10) 0 :=
begin
  induction l with d l ih,
  { apply zero_le },
  { rw [list.sum_cons, list.foldr_cons, le_add_left_iff_le],
    exact le_mul_of_le ih dec_trivial },
end

lemma add_left_le_self_iff {a b : ℕ} : a + b ≤ b ↔ a = 0 :=
begin
  split; intro h,
  { cases a,
    { refl },
    { rw [nat.succ_add, nat.succ_le_iff] at h,
      cases lt_irrefl _ (right_lt_of_add_lt h) }},
  { subst a, rw zero_add },
end

lemma sum_eq_zero_iff {l : list ℕ} : l.sum = 0 ↔ all_zeros l :=
by { rw [list.sum_eq_zero_iff, all_zeros, all_iff] }

lemma sum_eq_foldr_mul_iff_of_gt_1 {l : list ℕ} {n : ℕ}
  (h₁ : is_digit_list l) (h₂ : 1 < n) :
  l.sum = l.foldr (λ (a b : ℕ), a + b * 10) 0 * n ↔ all_zeros l :=
begin
  split; intro h,
  { have h₃ := @sum_le_foldr l, rw h at h₃,
    obtain ⟨n, rfl⟩ := nat.exists_eq_add_of_lt h₂, clear h₂,
    have h₂ : 1 + n + 1 = n + 2 := by linarith, rw h₂ at *,
    rw [mul_add, mul_two, ←add_assoc, add_left_le_self_iff, add_eq_zero_iff] at h₃,
    rwa [h₃.2, zero_mul, sum_eq_zero_iff] at h },
  { rwa [foldr_eq_zero_iff.mpr h, zero_mul, sum_eq_zero_iff] },
end

lemma is_digit_sum_of_sum_eq_foldr {l : list ℕ} (h₁ : is_digit_list l)
  (h₂ : l.sum = l.foldr (λ (a b : ℕ), a + b * 10) 0) : is_digit l.sum :=
begin
  cases l with d l,
  { dec_trivial },
  { rw [is_digit_list, all_cons, ←is_digit_list] at h₁, cases h₁ with h₁ h₃,
    rw [list.sum_cons, list.foldr_cons, add_right_inj,
    sum_eq_foldr_mul_iff_of_gt_1 h₃ (dec_trivial : 1 < 10)] at h₂,
    rwa [list.sum_cons, sum_eq_zero_iff.mpr h₂] },
end

lemma sum_digits_eq_self_iff_is_digit {n : ℕ} : sum_digits n = n ↔ is_digit n :=
begin
  split; intro h,
  { by_cases h₁ : n = 0,
    { subst n, dec_trivial },
    { rw [sum_digits_eq_get_some, get_some] at h, split_ifs at h with h₁,
      { obtain ⟨h₂, h₃⟩ := h₁.some_spec, revert h h₂ h₃, generalize : h₁.some = l,
        rintro h₁ h₂ h₃, subst n, exact is_digit_sum_of_sum_eq_foldr h₂ h₃.symm },
      { subst n, dec_trivial }}},
  { exact sum_digits_digit h },
end

lemma is_digit_digital_root {n : ℕ} : is_digit (digital_root n) :=
begin
  rw [is_digit, digital_root, fixed, get_some], split_ifs,
  { obtain ⟨k, h₁, h₂⟩ := h.some_spec,
    rwa [function.iterate_succ_apply', h₁, sum_digits_eq_self_iff_is_digit] at h₂ },
  { dec_trivial },
end

lemma exi_sum_digits {n : ℕ} : ∃ (l : list ℕ), is_digit_list l ∧
  l.foldr (λ (a b : ℕ), a + b * 10) 0 = n :=
begin
  induction n using digit_ind with d n h ih,
  { use ([]), split,
    { rw is_digit_list, exact all_nil },
    { refl }},
  { rcases ih with ⟨l, h₁, h₂⟩, use d :: l, split,
    { rw [is_digit_list, all_cons, ←is_digit_list], split; assumption },
    { rw [list.foldr_cons, add_right_inj, h₂] }},
end

lemma sum_digits_digit_add_mul_10 {d n : ℕ} (h : is_digit d) :
  sum_digits (d + n * 10) = d + sum_digits n :=
begin
  rw [sum_digits_eq_get_some, get_some_pos exi_sum_digits], generalize_proofs h₁,
  obtain ⟨h₁, h₂⟩ := h₁.some_spec, revert h₁ h₂, generalize : exi_sum_digits.some = l₂,
  clear h₁, rintro h₁ h₂, rw [sum_digits_eq_get_some, get_some_pos exi_sum_digits],
  generalize_proofs h₁, obtain ⟨h₁, h₂⟩ := h₁.some_spec, revert h₁ h₂,
  generalize : exi_sum_digits.some = l₁, clear h₁, rintro h₃ h₄, cases l₂ with d₂ l₂,
  { change 0 = _ at h₂, symmetry' at h₂, rw [add_eq_zero_iff, mul_eq_zero] at h₂,
    rcases h₂ with ⟨rfl, h₂⟩, clear h h₁, cases h₂,
    { subst n, rw foldr_eq_zero_iff at h₂, rw sum_eq_zero_iff.mpr h₂, refl },
    { cases h₂ }},
  { rw list.foldr_cons at h₂, rw [is_digit_list, all_cons, ←is_digit_list] at h₁,
    cases h₁ with h₁ h₅, rw digit_add_mul_10_eq_digit_add_mul_10_iff h₁ h at h₂,
    rcases h₂ with ⟨rfl, h₂⟩, rw [list.sum_cons, add_right_inj], rw ←h₄ at h₂,
    exact sum_eq_sum_of_foldr_eq_foldr h₅ h₃ h₂ },
end

lemma sum_digits_le {n : ℕ} : sum_digits n ≤ n :=
begin
  induction n using digit_ind with d n h ih,
  { rw sum_digits_zero },
  { rw sum_digits_digit_add_mul_10 h, apply add_le_add_left,
    exact le_trans ih (le_mul_of_le (le_refl _) dec_trivial) },
end

lemma sum_digits_eq_self_of_sum_digits_sum_digits_eq_self {n : ℕ}
  (h : sum_digits (sum_digits n) = n) : sum_digits n = n :=
begin
  apply le_antisymm,
  { exact sum_digits_le },
  { have h₁ := @sum_digits_le (sum_digits n), rwa h at h₁ },
end

lemma iter_le_of_le {f : ℕ → ℕ} {z n : ℕ}
  (h : ∀ (z : ℕ), f z ≤ z) : (f^[n] z) ≤ z :=
begin
  induction n with n ih,
  { refl },
  { rw function.iterate_succ_apply', exact le_trans (h _) ih },
end

lemma iter_le_iter_of_le {f : ℕ → ℕ} {z m n : ℕ}
  (h₁ : ∀ (z : ℕ), f z ≤ z) (h₂ : m ≤ n) : (f^[n] z) ≤ (f^[m] z) :=
begin
  obtain ⟨n, rfl⟩ := nat.exists_eq_add_of_le h₂,
  rw [add_comm, function.iterate_add_apply], exact iter_le_of_le h₁,
end

lemma iter_sum_digits_le_iter_sum_digits_of_le {n k₁ k₂ : ℕ} (h : k₁ ≤ k₂) :
  (sum_digits^[k₂] n) ≤ (sum_digits^[k₁] n) := iter_le_iter_of_le (λ _, sum_digits_le) h

lemma sum_digits_digital_root {n : ℕ} : sum_digits (digital_root n) = digital_root n :=
by { rw sum_digits_eq_self_iff_is_digit, exact is_digit_digital_root }

lemma digital_root_digit {d : ℕ} (h : is_digit d) : digital_root d = d :=
digital_root_eq_self_of (sum_digits_digit h)

lemma digital_root_one : digital_root 1 = 1 := digital_root_digit dec_trivial

lemma is_digit_sum_digits_digit_add_digit {d₁ d₂ : ℕ}
  (h₁ : is_digit d₁) (h₂ : is_digit d₂) : is_digit (sum_digits (d₁ + d₂)) :=
begin
  rw sum_digits_digit_add_digit h₁ h₂, split_ifs,
  { exact h },
  { rw is_digit at *, exact nat.sub_le_sub_right (add_le_add h₁ h₂) 9 },
end

lemma iter_sum_digits_digit {d n : ℕ} (h : is_digit d) : (sum_digits^[n]) d = d :=
function.iterate_fixed (sum_digits_digit h) _

lemma digital_root_digit_add_digit {d₁ d₂ : ℕ} (h₁ : is_digit d₁) (h₂ : is_digit d₂) :
  digital_root (d₁ + d₂) = sum_digits (d₁ + d₂) :=
begin
  rw [digital_root, fixed, get_some_pos], swap,
  { use [sum_digits (d₁ + d₂), 1], split,
    { refl },
    { exact sum_digits_digit (is_digit_sum_digits_digit_add_digit h₁ h₂) }},
  generalize_proofs h₃, obtain ⟨n, -, h₄⟩ := h₃.some_spec,
  symmetry, rwa [function.iterate_succ_apply,
  iter_sum_digits_digit (is_digit_sum_digits_digit_add_digit h₁ h₂)] at h₄,
end

lemma sum_digits_def {n : ℕ} : sum_digits n = n % 10 + sum_digits (n / 10) :=
begin
  obtain ⟨a, b, ha, hb, h⟩ := nat_exi_mul n 10,
  rw [←ha, ←hb, h, add_comm, hb],
  exact sum_digits_digit_add_mul_10 is_digit_mod_10,
end

def converges_to {α : Type} (f : α → α) (z x : α) : Prop :=
∃ (n : ℕ), (f^[n]) z = x ∧ (f^[n + 1]) z = x

def converges {α : Type} (f : α → α) (z : α) : Prop :=
∃ (x : α), converges_to f z x

lemma iter_add {α : Type} {f : α → α} {z : α} {m n : ℕ} :
  (f^[m + n]) z = (f^[n]) ((f^[m]) z) := by rw [add_comm, function.iterate_add_apply]

lemma converges_to_congr_aux {α : Type} {n₂ n₁ : ℕ} {f : α → α} {z x y : α}
  (h₁ : f^[n₁] z = x) (h₂ : f^[n₁ + 1] z = x) (h₃ : f^[n₂] z = y) (h₄ : f^[n₂ + 1] z = y)
  (h₅ : n₁ ≤ n₂) : x = y :=
begin
  obtain ⟨n₂, rfl⟩ := nat.exists_eq_add_of_le h₅, clear h₅, rw add_assoc at h₄,
  simp_rw iter_add at h₂ h₃ h₄, change (f^[1]) with f at h₂ h₄, rw ←h₁ at h₂,
  have h₅ := function.iterate_fixed h₂ n₂, rw [h₃, h₁] at h₅, exact h₅.symm,
end

lemma converges_to_congr {α : Type} {f : α → α} {z x y : α}
  (h₁ : converges_to f z x) (h₂ : converges_to f z y) : x = y :=
begin
  rcases h₂ with ⟨n₂, h₃, h₄⟩, rcases h₁ with ⟨n₁, h₁, h₂⟩, by_cases h₅ : n₁ ≤ n₂,
  { exact converges_to_congr_aux h₁ h₂ h₃ h₄ h₅ },
  { push_neg at h₅, exact (converges_to_congr_aux h₃ h₄ h₁ h₂ (le_of_lt h₅)).symm },
end

lemma fixed_eq_of_converges_to {α : Type} [inhabited α] {f : α → α} {z x : α}
  (h : converges_to f z x) : fixed f z = x :=
begin
  rw [fixed, get_some_pos], swap, { exact ⟨x, h⟩ },
  generalize_proofs h₃, exact converges_to_congr h₃.some_spec h,
end

lemma apply_eq_of_converges_to {α : Type} {f : α → α} {z x : α}
  (h : converges_to f z x) : f x = x :=
by { rcases h with ⟨n, h₁, h₂⟩, rwa [function.iterate_succ_apply', h₁] at h₂ }

lemma apply_fixed_of_converges {α : Type} [inhabited α] {f : α → α} {z : α}
  (h : converges f z) : f (fixed f z) = fixed f z :=
by { cases h with x h, by rw [fixed_eq_of_converges_to h, apply_eq_of_converges_to h] }

lemma iter_apply_comm {α : Type} {f : α → α} {x : α} {n : ℕ} :
  (f^[n]) (f x) = f ((f^[n]) x) :=
by rw [←function.iterate_succ_apply, function.iterate_succ_apply']

lemma converges_of_le {f : ℕ → ℕ} {n : ℕ} (h : ∀ (n : ℕ), f n ≤ n) : converges f n :=
begin
  change ∃ (_ _ : ℕ), _, induction n using nat.strong_induction_on with n ih, dsimp at ih,
  simp_rw function.iterate_succ_apply', have h₁ := h ((f^[n]) n),
  rw le_iff_lt_or_eq at h₁, cases h₁,
  { replace h₁ : _ < n := gt_of_ge_of_gt (iter_le_of_le h) h₁,
    specialize ih _ h₁, rcases ih with ⟨y, k, h₂, h₃⟩,
    use [y, n + 1 + k], split; simp_rw iter_add,
    { exact h₂ },
    { rwa ←@iter_apply_comm _ f }},
  { exact ⟨_, _, rfl, h₁⟩ },
end

lemma converges_sum_digits {n : ℕ} : converges sum_digits n :=
converges_of_le (λ _, sum_digits_le)

lemma converges_to_fixed {α : Type} [inhabited α] {f : α → α} {z : α}
  (h : converges f z) : converges_to f z (fixed f z) :=
by { cases h with x h, rwa fixed_eq_of_converges_to h }

lemma converges_to_apply {α : Type} {f : α → α} {z x : α}
  (h : converges_to f z x) : converges_to f z (f x) :=
begin
  rcases h with ⟨n, h₁, h₂⟩, use n + 1, split; rw iter_add,
  { rw h₁, refl },
  { rw h₂, refl },
end

lemma apply_converges_to {α : Type} {f : α → α} {z x : α}
  (h : converges_to f z x) : converges_to f (f z) x :=
begin
  rcases h with ⟨k, h₁, h₂⟩, cases k,
  { use 0, split,
    { exact h₂ },
    { cases h₁, rwa [iter_apply_comm, h₂] }},
  { exact ⟨k, h₁, h₂⟩ },
end

lemma apply_converges {α : Type} {f : α → α} {z : α}
  (h : converges f z) : converges f (f z) := ⟨_, apply_converges_to h.some_spec⟩

lemma fixed_eq_fixed_of {α : Type} [inhabited α] {f : α → α} {z₁ z₂ x : α}
  (h₁ : converges_to f z₁ x) (h₂ : converges_to f z₂ x) : fixed f z₁ = fixed f z₂ :=
by rw [fixed_eq_of_converges_to h₁, fixed_eq_of_converges_to h₂]

lemma fixed_apply_eq_of_converges {α : Type} [inhabited α] {f : α → α} {z : α}
  (h : converges f z) : fixed f (f z) = fixed f z :=
by { cases h with x h, exact fixed_eq_fixed_of (apply_converges_to h) h }

lemma digital_root_sum_digits {n : ℕ} : digital_root (sum_digits n) = digital_root n :=
fixed_apply_eq_of_converges converges_sum_digits

lemma fixed_ind {α : Type} [inhabited α] {P : α → Prop} {f : α → α} {z : α}
  (h₁ : converges f z) (h₂ : P z) (h₃ : ∀ (x : α), P x → P (f x)) : P (fixed f z) :=
begin
  cases h₁ with x h₁, rw fixed_eq_of_converges_to h₁,
  rcases h₁ with ⟨n, h₁, -⟩, rw ←h₁, exact function.iterate.rec _ h₃ h₂ _,
end

lemma sum_digits_mod_9 {n : ℕ} : sum_digits n % 9 = n % 9 :=
begin
  induction n using digit_ind with d n h ih,
  { rw sum_digits_zero },
  { rw [sum_digits_digit_add_mul_10 h, nat.add_mod, ih, eq_comm, nat.add_mod,
    nat.mul_mod], congr' 2, change 10 % 9 with 1, rw [nat.mul_one, nat.mod_mod] },
end

lemma digital_root_mod_9 {n : ℕ} : digital_root n % 9 = n % 9 :=
begin
  apply @fixed_ind _ _ (λ (k : ℕ), k % 9 = n % 9) _ _ converges_sum_digits rfl,
  rintro x h, rw [←h, sum_digits_mod_9],
end

lemma digit_mod_10 {d : ℕ} (h : is_digit d) : d % 10 = d :=
nat.mod_eq_of_lt (nat.lt_succ_of_le h)

lemma pos_add_iff {a b : ℕ} : 0 < a + b ↔ 0 < a ∨ 0 < b :=
by { rw ←not_iff_not, push_neg, simp_rw [le_zero_iff, add_eq_zero_iff] }

lemma sum_digits_pos_succ {n : ℕ} : 0 < sum_digits n.succ :=
begin
  induction n using nat.strong_induction_on with n ih, dsimp at ih,
  rw [sum_digits_def, pos_add_iff], by_cases h : n.succ ≤ 9,
  { rw digit_mod_10 h, exact or.inl (nat.succ_pos _) },
  {
    right, push_neg at h, rw nat.lt_succ_iff at h,
    obtain ⟨n, rfl⟩ := nat.exists_eq_add_of_le h, clear h,
    rw [add_comm, ←nat.add_succ, nat.add_div_right _ (nat.succ_pos _)],
    apply ih, rw add_comm, cases n,
    { dec_trivial },
    { apply nat.lt_add_right, apply nat.div_lt_self; dec_trivial }},
end

lemma sum_digits_eq_zero_iff {n : ℕ} : sum_digits n = 0 ↔ n = 0 :=
begin
  split; intro h,
  { cases n,
    { refl },
    { contrapose h, exact ne_of_gt sum_digits_pos_succ }},
  { subst h, exact sum_digits_zero },
end

lemma digital_root_eq_zero_iff {n : ℕ} : digital_root n = 0 ↔ n = 0 :=
begin
  apply @fixed_ind _ _ (λ (k : ℕ), k = 0 ↔ n = 0) _ _ converges_sum_digits (iff.refl _),
  rintro x h, rw [←h, sum_digits_eq_zero_iff],
end

lemma digit_mod_9_eq_zero_iff {d : ℕ} (h : is_digit d) : d % 9 = 0 ↔ d = 0 ∨ d = 9 :=
begin
  rw is_digit at h, split; intro h₁,
  { cases d,
    { exact or.inl rfl },
    { rw le_iff_eq_or_lt at h, cases h,
      { exact or.inr h },
      { rw nat.mod_eq_of_lt h at h₁, cases h₁ }}},
  { cases h₁; subst d; refl },
end

lemma digital_root_eq_of_pos {n : ℕ} (h : 0 < n) : digital_root n = modp n 9 :=
begin
  cases n,
  { cases h },
  { rw modp, split_ifs with h₁;
    rw [←digital_root_mod_9, digit_mod_9_eq_zero_iff is_digit_digital_root] at h₁,
    { cases h₁,
      { rw digital_root_eq_zero_iff at h₁, cases h₁ },
      { exact h₁ }},
    { rw not_or_distrib at h₁, cases h₁ with h₁ h₂,
      rw [←digital_root_mod_9, nat.mod_eq_of_lt],
      exact lt_of_le_of_ne is_digit_digital_root h₂ }},
end

lemma digital_root_succ {n : ℕ} : digital_root n.succ = modp n.succ 9 :=
digital_root_eq_of_pos (nat.succ_pos _)

lemma eq_zero_of_modp_eq_zero {k n : ℕ} (h : modp n k = 0) : n = 0 :=
begin
  rw modp at h, split_ifs at h with h₁,
  { subst k, rwa nat.mod_zero at h₁ },
  { contradiction },
end

lemma succ_mod_eq_zero_iff_aux {k n : ℕ} : n.succ % k.succ = 0 ↔ n % k.succ = k :=
begin
  split; intro h,
  { contrapose! h,
    replace h := lt_of_le_of_ne (nat.le_of_lt_succ (nat.mod_lt _ (nat.succ_pos _))) h,
    cases k,
    { cases h },
    { rw [←ne, ←pos_iff_ne_zero, ←nat.add_one, nat.add_mod, nat.one_mod, nat.mod_eq_of_lt],
      { apply nat.zero_lt_succ }, rwa nat.succ_lt_succ_iff }},
  { cases k,
    { rw nat.mod_one },
    { rw [←nat.add_one, nat.add_mod, h, nat.one_mod, nat.mod_self] }},
end

lemma succ_mod_eq_zero_iff {k n : ℕ} (h : 0 < k) : n.succ % k = 0 ↔ n % k = k - 1 :=
begin
  cases k,
  { cases h },
  { rw [nat.succ_sub_one, succ_mod_eq_zero_iff_aux] },
end

lemma digital_root_mod_9_eq_of_ne_9 {n : ℕ} (h : digital_root n ≠ 9) :
  digital_root n % 9 = digital_root n :=
nat.mod_eq_of_lt (lt_of_le_of_ne is_digit_digital_root h)

lemma digital_root_succ_eq_of_ne_9 {n : ℕ} (h : digital_root n ≠ 9) :
  digital_root n.succ = (digital_root n).succ :=
begin
  rw [digital_root_eq_of_pos (nat.succ_pos _), modp], split_ifs with h₁,
  { rw [succ_mod_eq_zero_iff (nat.succ_pos _), ←digital_root_mod_9,
    digital_root_mod_9_eq_of_ne_9 h] at h₁, rw h₁ },
  { cases n,
    { rw digital_root_zero, refl },
    { rw [digital_root_eq_of_pos (nat.succ_pos _), modp], split_ifs with h₂,
      { rw [←digital_root_mod_9, digital_root_mod_9_eq_of_ne_9 h,
        digital_root_eq_zero_iff] at h₂, cases h₂ },
      { clear h, rw succ_mod_eq_zero_iff (nat.succ_pos _) at h₁ h₂,
        rw [←nat.add_one, nat.add_mod, nat.one_mod],
        have h₃ : n.succ % 9 = (n % 9 + 1) % 9,
        { rw [←nat.add_one, nat.add_mod, nat.one_mod] },
        rw h₃ at *, clear h₃, have h₃ : n % 9 < 9 := nat.mod_lt _ (nat.succ_pos _),
        revert h₃ h₁ h₂, generalize : n % 9 = d, rintro h₁ h₂ h₃,
        clear n, replace h₁ : d ≤ 7,
        { cases d,
          { apply zero_le },
          { rw nat.lt_succ_iff at h₁, rw ←nat.lt_succ_iff, exact lt_of_le_of_ne h₁ h₃ }},
        rw ←not_lt at h₁, iterate 7 { cases d, refl }, cases d, cases h₂ rfl,
        contrapose! h₁, change 7 < d + 8, linarith }}},
end

lemma not_digit_succ_le_9_iff {d : ℕ} (h : is_digit d) : ¬d.succ ≤ 9 ↔ d = 9 :=
begin
  split; intro h₁,
  { contrapose! h₁, exact nat.succ_le_of_lt (lt_of_le_of_ne h h₁) },
  { subst d, dec_trivial }
end

lemma digital_root_succ_eq_sum_digits {n : ℕ} :
  digital_root n.succ = sum_digits (digital_root n).succ :=
begin
  rw [eq_comm, digital_root_succ, modp,
  sum_digits_digit_add_digit is_digit_digital_root (dec_trivial : is_digit 1)],
  simp_rw ←nat.add_one, split_ifs with h₁ h₂ h₂,
  { rw [←digital_root_mod_9, digit_mod_9_eq_zero_iff is_digit_digital_root] at h₂,
    cases h₂,
    { rw digital_root_eq_of_pos (nat.succ_pos _) at h₂, cases eq_zero_of_modp_eq_zero h₂ },
    { rw nat.succ_le_iff at h₁, rw [nat.succ_inj', ←nat.mod_eq_of_lt h₁, digital_root_mod_9],
      apply_fun (λ n, n % 9) at h₂, rwa [nat.mod_self, digital_root_mod_9,
      succ_mod_eq_zero_iff (nat.succ_pos _)] at h₂ }},
  { rw [←digital_root_mod_9, digit_mod_9_eq_zero_iff is_digit_digital_root,
    not_or_distrib] at h₂, cases h₂ with h₂ h₃,
    have h₄ := lt_of_le_of_ne is_digit_digital_root h₃,
    rw [←digital_root_mod_9, nat.mod_eq_of_lt h₄, digital_root_succ_eq_of_ne_9],
    exact ne_of_lt (nat.lt_of_succ_le h₁) },
  { rw not_digit_succ_le_9_iff is_digit_digital_root at h₁,
    rw [succ_mod_eq_zero_iff (nat.succ_pos _), ←digital_root_mod_9, h₁] at h₂, cases h₂ },
  { rw not_digit_succ_le_9_iff is_digit_digital_root at h₁,
    rw [nat.add_mod, ←@digital_root_mod_9 n, h₁], refl },
end

lemma sum_digits_digit_succ {d : ℕ} (h : is_digit d) : sum_digits d.succ = modp d.succ 9 :=
begin
  rw [←nat.add_one, sum_digits_digit_add_digit h (dec_trivial : is_digit 1), modp],
  split_ifs with h₁ h₂ h₂; try { rw not_digit_succ_le_9_iff h at h₁ },
  { rw [succ_mod_eq_zero_iff (nat.succ_pos _),
    nat.mod_eq_of_lt (nat.lt_of_succ_le h₁)] at h₂, rwa h₂ },
  { rw nat.mod_eq_of_lt, rw succ_mod_eq_zero_iff (nat.succ_pos _) at h₂,
    rw le_iff_lt_or_eq at h₁, cases h₁,
    { exact h₁ },
    { rw nat.succ_inj' at h₁, subst d, cases h₂ rfl }},
  { subst h₁, cases h₂ },
  { subst h₁, refl },
end

lemma not_pos_iff {n : ℕ} : ¬0 < n ↔ n = 0 := by rw [not_lt, le_zero_iff]

lemma is_digit_zero : is_digit 0 := dec_trivial

lemma is_digit_one : is_digit 1 := dec_trivial

lemma le_sub_add {m n : ℕ} : m ≤ m - n + n :=
begin
  induction n with n ih generalizing m,
  { refl },
  { cases m,
    { apply zero_le },
    { rw [nat.succ_sub_succ, nat.add_succ, nat.succ_le_succ_iff], exact ih }},
end

lemma is_digit_digit_add_digit_sub_9 {d₁ d₂ : ℕ} (h₁ : is_digit d₁) (h₂ : is_digit d₂) :
  is_digit (d₁ + d₂ - 9) := nat.sub_le_sub_right (add_le_add h₁ h₂) _

lemma digital_root_add_aux₁ {d₁ d₂ : ℕ} (h₁ : is_digit d₁) (h₂ : is_digit d₂)
  (h₃ : 0 < d₁) (h₄ : 0 < d₂) :
  sum_digits (d₁ + sum_digits d₂.succ) = modp (sum_digits (d₁ + d₂)).succ 9 :=
begin
  simp_rw [sum_digits_digit_succ h₂, sum_digits_digit_add_digit h₁ h₂,
  sum_digits_digit_add_digit h₁ is_digit_modp_9, ←nat.add_one],
  split_ifs with h₅ h₆ h₆,
  { rw [ modp_digit_add_digit h₂ is_digit_one (or.inr nat.zero_lt_one),
    modp_digit_add_digit h₆ is_digit_one (or.inr nat.zero_lt_one)] at *,
    split_ifs at *; linarith },
  { rw [ modp_digit_add_digit h₂ is_digit_one (or.inr nat.zero_lt_one),
    modp_digit_add_digit (is_digit_digit_add_digit_sub_9 h₁ h₂)
    is_digit_one (or.inr nat.zero_lt_one)] at *, split_ifs at * with h₇ h₈ h₈,
    { linarith },
    { linarith },
    { rw not_digit_succ_le_9_iff h₂ at h₇, subst h₇, refl },
    { rw not_digit_succ_le_9_iff h₂ at h₇, subst h₇,
      rw [nat.add_sub_cancel, not_digit_succ_le_9_iff h₁] at h₈, subst h₈,
      contrapose! h₅, dec_trivial }},
  { rw [ modp_digit_add_digit h₂ is_digit_one (or.inr nat.zero_lt_one),
    modp_digit_add_digit h₆ is_digit_one (or.inr nat.zero_lt_one)] at *,
    split_ifs at * with h₇ h₈ h₈,
    { rw [←nat.add_assoc, not_digit_succ_le_9_iff h₆] at h₅, rw [←nat.add_assoc, h₅] },
    { linarith },
    { linarith }},
  { rw [ modp_digit_add_digit h₂ is_digit_one (or.inr nat.zero_lt_one),
    modp_digit_add_digit (is_digit_digit_add_digit_sub_9 h₁ h₂)
    is_digit_one (or.inr nat.zero_lt_one) ] at *, split_ifs at * with h₇ h₈ h₈,
    { push_neg at h₆, rw ←nat.add_assoc, exact nat.succ_sub (le_of_lt h₆) },
    { push_neg at h₅ h₆ h₈, rw ←nat.add_assoc at h₅ ⊢, contrapose! h₈,
      rw nat.succ_le_succ_iff at h₇ ⊢, exact tsub_le_iff_left.mpr (nat.add_le_add h₁ h₇) },
    { push_neg at h₅ h₆ h₇, contrapose! h₅,
      rwa [←nat.add_sub_assoc (le_of_lt h₇), ←nat.add_assoc, nat.succ_sub (le_of_lt h₆)] },
    { push_neg at h₅ h₆ h₇ h₈,
      rwa [←nat.add_sub_assoc (le_of_lt h₇), ←nat.add_assoc, nat.succ_sub (le_of_lt h₆)] }},
end

lemma digital_root_add_aux {d₁ d₂ : ℕ} (h₁ : is_digit d₁) (h₂ : is_digit d₂) :
  sum_digits (d₁ + sum_digits d₂.succ) = modp (sum_digits (d₁ + d₂)).succ 9 :=
begin
  by_cases h₃ : 0 < d₁,
  { by_cases h₄ : 0 < d₂,
    { exact digital_root_add_aux₁ h₁ h₂ h₃ h₄ },
    { rw not_pos_iff at h₄, subst d₂, rw [add_zero, sum_digits_digit is_digit_one,
      sum_digits_digit h₁, ←nat.add_one, sum_digits_digit_add_digit h₁ is_digit_one,
      modp_digit_add_digit h₁ is_digit_one], exact or.inl h₃ }},
  { rw not_pos_iff at h₃, subst d₁, simp_rw [zero_add, ←nat.add_one],
    rw [sum_digits_digit (is_digit_sum_digits_digit_add_digit h₂ is_digit_one),
    sum_digits_digit_add_digit h₂ is_digit_one, sum_digits_digit h₂,
    modp_digit_add_digit h₂ is_digit_one(or.inr one_pos)] },
end

lemma digital_root_add {m n : ℕ} :
  digital_root (m + n) = sum_digits (digital_root m + digital_root n) :=
begin
  induction n with n ih,
  { simp_rw [digital_root_zero, add_zero, sum_digits_digital_root] },
  { rw [nat.add_succ, digital_root_succ_eq_sum_digits, ih, sum_digits_digit_succ
    (is_digit_sum_digits_digit_add_digit is_digit_digital_root is_digit_digital_root)],
    rw digital_root_succ_eq_sum_digits,
    generalize hm : digital_root m = d₁, generalize hn : digital_root n = d₂,
    have h₁ : is_digit d₁, { rw ←hm, exact is_digit_digital_root },
    have h₂ : is_digit d₂, { rw ←hn, exact is_digit_digital_root },
    exact (digital_root_add_aux h₁ h₂).symm },
end

lemma sum_digits_mul_10 {n : ℕ} : sum_digits (n * 10) = sum_digits n :=
by rw [←nat.zero_add (n * 10), sum_digits_digit_add_mul_10 is_digit_zero, nat.zero_add]

lemma digital_root_mul_10 {n : ℕ} : digital_root (n * 10) = digital_root n :=
by rw [←digital_root_sum_digits, sum_digits_mul_10, digital_root_sum_digits]

lemma digital_root_digit_add_mul_10 {d n : ℕ} (h : is_digit d) :
  digital_root (d + n * 10) = sum_digits (d + digital_root n) :=
by rw [digital_root_add, digital_root_mul_10, digital_root_digit h]

lemma digital_root_eq_modp_of_pos {n : ℕ} (h : 0 < n) : digital_root n = modp n 9 :=
begin
  induction n using digit_ind with d n h₁ ih,
  { cases h },
  { cases n,
    { simp_rw [zero_mul, add_zero] at h ⊢,
      rw [modp_digit_of_pos h₁ h, digital_root_digit_eq_self h₁] },
    { specialize ih (nat.succ_pos _),
      rw [digital_root_digit_add_mul_10 h₁, modp_digit_add_mul_10 h₁, ih,
      sum_digits_digit_add_digit h₁ is_digit_modp_9],
      split_ifs with h,
      { cases d,
        { simp },
        { rw [modp_add, modp_digit_of_pos h₁ (nat.succ_pos _),
          modp_digit_add_digit h₁ is_digit_modp_9 (or.inl (nat.succ_pos _)), if_pos h] }},
      { have h₂ : 0 < d,
        { contrapose! h, rw le_zero_iff at h, subst d,
          rw zero_add, apply modp_le, dec_trivial },
        rw [modp_add, modp_digit_of_pos h₁ h₂], revert h,
        generalize h₃ : modp n.succ 9 = d₂, intro h, have h₄ : 0 < d₂,
        { subst d₂, exact modp_pos_of_pos (nat.succ_pos _) },
        have h₅ : is_digit d₂,
        { subst d₂, exact is_digit_modp_9 },
        rw [modp_digit_add_digit h₁ h₅ (or.inl h₂), if_neg h] }}},
end

lemma digital_root_def {n : ℕ} :
  digital_root n = if n = 0 then 0 else if n % 9 = 0 then 9 else n % 9 :=
begin
  rw ←modp, split_ifs with h h₁,
  { cases h, exact digital_root_zero },
  { exact digital_root_eq_modp_of_pos (pos_iff_ne_zero.mpr h) },
end