/-
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, Johan Commelin, Mario Carneiro
-/

import data.mv_polynomial.variables

/-!
# Multivariate polynomials over a ring

Many results about polynomials hold when the coefficient ring is a commutative semiring.
Some stronger results can be derived when we assume this semiring is a ring.

This file does not define any new operations, but proves some of these stronger results.

## Notation

As in other polynomial files, we typically use the notation:

+ `σ : Type*` (indexing the variables)

+ `R : Type*` `[comm_ring R]` (the coefficients)

+ `s : σ →₀ ℕ`, a function from `σ` to `ℕ` which is zero away from a finite set.
This will give rise to a monomial in `mv_polynomial σ R` which mathematicians might call `X^s`

+ `a : R`

+ `i : σ`, with corresponding monomial `X i`, often denoted `X_i` by mathematicians

+ `p : mv_polynomial σ R`

-/

noncomputable theory

open_locale classical big_operators

open set function finsupp add_monoid_algebra
open_locale big_operators

universes u v
variables {R : Type u} {S : Type v}

namespace mv_polynomial
variables {σ : Type*} {a a' a₁ a₂ : R} {e : ℕ} {n m : σ} {s : σ →₀ ℕ}

section comm_ring
variable [comm_ring R]
variables {p q : mv_polynomial σ R}

instance : comm_ring (mv_polynomial σ R) := add_monoid_algebra.comm_ring

variables (σ a a')

@[simp] lemma C_sub : (C (a - a') : mv_polynomial σ R) = C a - C a' := ring_hom.map_sub _ _ _

@[simp] lemma C_neg : (C (-a) : mv_polynomial σ R) = -C a := ring_hom.map_neg _ _

@[simp] lemma coeff_neg (m : σ →₀ ℕ) (p : mv_polynomial σ R) :
  coeff m (-p) = -coeff m p := finsupp.neg_apply _ _

@[simp] lemma coeff_sub (m : σ →₀ ℕ) (p q : mv_polynomial σ R) :
  coeff m (p - q) = coeff m p - coeff m q := finsupp.sub_apply _ _ _

@[simp] lemma support_neg : (- p).support = p.support :=
finsupp.support_neg p

lemma support_sub (p q : mv_polynomial σ R) : (p - q).support ⊆ p.support ∪ q.support :=
finsupp.support_sub

variables {σ} (p)

section degrees

lemma degrees_neg (p : mv_polynomial σ R) : (- p).degrees = p.degrees :=
by rw [degrees, support_neg]; refl

lemma degrees_sub (p q : mv_polynomial σ R) :
  (p - q).degrees ≤ p.degrees ⊔ q.degrees :=
by simpa only [sub_eq_add_neg] using le_trans (degrees_add p (-q)) (by rw degrees_neg)

end degrees

section vars

variables (p q)

@[simp] lemma vars_neg : (-p).vars = p.vars :=
by simp [vars, degrees_neg]

lemma vars_sub_subset : (p - q).vars ⊆ p.vars ∪ q.vars :=
by convert vars_add_subset p (-q) using 2; simp [sub_eq_add_neg]

variables {p q}

@[simp]
lemma vars_sub_of_disjoint (hpq : disjoint p.vars q.vars) : (p - q).vars = p.vars ∪ q.vars :=
begin
  rw ←vars_neg q at hpq,
  convert vars_add_of_disjoint hpq using 2;
    simp [sub_eq_add_neg]
end

end vars

section eval₂

variables [comm_ring S]
variables (f : R →+* S) (g : σ → S)

@[simp]

@[simp] lemma eval₂_neg : (-p).eval₂ f g = -(p.eval₂ f g) := (eval₂_hom f g).map_neg _

lemma hom_C (f : mv_polynomial σ ℤ →+* S) (n : ℤ) : f (C n) = (n : S) :=
(f.comp C).eq_int_cast n

/-- A ring homomorphism f : Z[X_1, X_2, ...] → R
is determined by the evaluations f(X_1), f(X_2), ... -/
@[simp] lemma eval₂_hom_X {R : Type u} (c : ℤ →+* S)
  (f : mv_polynomial R ℤ →+* S) (x : mv_polynomial R ℤ) :
  eval₂ c (f ∘ X) x = f x :=
mv_polynomial.induction_on x
(λ n, by { rw [hom_C f, eval₂_C], exact c.eq_int_cast n })
(λ p q hp hq, by { rw [eval₂_add, hp, hq], exact (f.map_add _ _).symm })
(λ p n hp, by { rw [eval₂_mul, eval₂_X, hp], exact (f.map_mul _ _).symm })

/-- Ring homomorphisms out of integer polynomials on a type `σ` are the same as
functions out of the type `σ`, -/
def hom_equiv : (mv_polynomial σ ℤ →+* S) ≃ (σ → S) :=
{ to_fun := λ f, ⇑f ∘ X,
  inv_fun := λ f, eval₂_hom (int.cast_ring_hom S) f,
  left_inv := λ f, ring_hom.ext  $ eval₂_hom_X _ _,
  right_inv := λ f, funext $ λ x, by simp only [coe_eval₂_hom, function.comp_app, eval₂_X] }

end eval₂

section degree_of

lemma degree_of_sub_lt {x : σ} {f g : mv_polynomial σ R} {k : ℕ} (h : 0 < k)
  (hf : ∀ (m : σ →₀ ℕ), m ∈ f.support → (k ≤ m x) → coeff m f = coeff m g)
  (hg : ∀ (m : σ →₀ ℕ), m ∈ g.support → (k ≤ m x) → coeff m f = coeff m g) :
  degree_of x (f - g) < k :=
begin
  rw degree_of_lt_iff h,
  intros m hm,
  by_contra hc,
  simp only [not_lt] at hc,
  have h := support_sub σ f g hm,
  simp only [mem_support_iff, ne.def, coeff_sub, sub_eq_zero] at hm,
  cases (finset.mem_union).1 h with cf cg,
  { exact hm (hf m cf hc), },
  { exact hm (hg m cg hc), },
end

end degree_of

section total_degree

@[simp] lemma total_degree_neg (a : mv_polynomial σ R) :
  (-a).total_degree = a.total_degree :=
by simp only [total_degree, support_neg]

lemma total_degree_sub (a b : mv_polynomial σ R) :
  (a - b).total_degree ≤ max a.total_degree b.total_degree :=
calc (a - b).total_degree = (a + -b).total_degree                : by rw sub_eq_add_neg
                      ... ≤ max a.total_degree (-b).total_degree : total_degree_add a (-b)
                      ... = max a.total_degree b.total_degree    : by rw total_degree_neg

end total_degree

end comm_ring

end mv_polynomial


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

import analysis.complex.upper_half_plane.functions_bounded_at_infty
import analysis.complex.upper_half_plane.topology
import number_theory.modular_forms.slash_invariant_forms
/-!
# Modular forms

This file defines modular forms and proves some basic properties about them.

We begin by defining modular forms and cusp forms as extension of `slash_invariant_forms` then we
define the space of modular forms, cusp forms and prove that the product of two modular forms is a
modular form.
-/

open complex upper_half_plane

open_locale topology manifold upper_half_plane

noncomputable theory

local prefix `↑ₘ`:1024 := @coe _ (matrix (fin 2) (fin 2) _) _

local notation `GL(` n `, ` R `)`⁺ := matrix.GL_pos (fin n) R

local notation `SL(` n `, ` R `)` := matrix.special_linear_group (fin n) R

section modular_form

open modular_form

variables (F : Type*) (Γ : subgroup SL(2, ℤ)) (k : ℤ)

local notation f `∣[`:73 k:0, A `]` :72 := slash_action.map ℂ k A f

set_option old_structure_cmd true

/--These are `slash_invariant_form`'s that are holomophic and bounded at infinity. -/
structure modular_form extends slash_invariant_form Γ k :=
(holo' : mdifferentiable 𝓘(ℂ) 𝓘(ℂ) (to_fun : ℍ → ℂ))
(bdd_at_infty' : ∀ (A : SL(2, ℤ)), is_bounded_at_im_infty (to_fun ∣[k, A]))

/-- The `slash_invariant_form` associated to a `modular_form`. -/
add_decl_doc modular_form.to_slash_invariant_form

/--These are `slash_invariant_form`s that are holomophic and zero at infinity. -/
structure cusp_form extends slash_invariant_form Γ k :=
(holo' : mdifferentiable 𝓘(ℂ) 𝓘(ℂ) (to_fun : ℍ → ℂ))
(zero_at_infty' : ∀ (A : SL(2, ℤ)), is_zero_at_im_infty (to_fun ∣[k, A]))

/-- The `slash_invariant_form` associated to a `cusp_form`. -/
add_decl_doc cusp_form.to_slash_invariant_form

/--`modular_form_class F Γ k` says that `F` is a type of bundled functions that extend
`slash_invariant_forms_class` by requiring that the functions be holomorphic and bounded
at infinity. -/
class modular_form_class extends slash_invariant_form_class F Γ k :=
(holo: ∀ f : F, mdifferentiable 𝓘(ℂ) 𝓘(ℂ) (f : ℍ → ℂ))
(bdd_at_infty : ∀ (f : F) (A : SL(2, ℤ)), is_bounded_at_im_infty (f ∣[k, A]))

/--`cusp_form_class F Γ k` says that `F` is a type of bundled functions that extend
`slash_invariant_forms_class` by requiring that the functions be holomorphic and zero
at infinity. -/
class cusp_form_class extends slash_invariant_form_class F Γ k :=
(holo: ∀ f : F, mdifferentiable 𝓘(ℂ) 𝓘(ℂ) (f : ℍ → ℂ))
(zero_at_infty : ∀ (f : F) (A : SL(2, ℤ)), is_zero_at_im_infty (f ∣[k, A]))

@[priority 100]
instance modular_form_class.modular_form : modular_form_class (modular_form Γ k) Γ k :=
{ coe := modular_form.to_fun,
  coe_injective' := λ f g h, by cases f; cases g; congr',
  slash_action_eq := modular_form.slash_action_eq',
  holo:= modular_form.holo',
  bdd_at_infty := modular_form.bdd_at_infty' }

@[priority 100]
instance cusp_form_class.cusp_form : cusp_form_class (cusp_form Γ k) Γ k :=
{ coe := cusp_form.to_fun,
  coe_injective' := λ f g h, by cases f; cases g; congr',
  slash_action_eq := cusp_form.slash_action_eq',
  holo:= cusp_form.holo',
  zero_at_infty := cusp_form.zero_at_infty' }

variables {F Γ k}

@[simp] lemma modular_form_to_fun_eq_coe {f : modular_form Γ k} : f.to_fun = (f : ℍ → ℂ) := rfl
@[simp] lemma cusp_form_to_fun_eq_coe {f : cusp_form Γ k} : f.to_fun = (f : ℍ → ℂ) := rfl

@[ext] theorem modular_form.ext {f g : modular_form Γ k} (h : ∀ x, f x = g x) : f = g :=
fun_like.ext f g h

@[ext] theorem cusp_form.ext {f g : cusp_form Γ k} (h : ∀ x, f x = g x) : f = g :=
fun_like.ext f g h

/-- Copy of a `modular_form` with a new `to_fun` equal to the old one. Useful to fix
definitional equalities. -/
protected def modular_form.copy (f : modular_form Γ k) (f' : ℍ → ℂ) (h : f' = ⇑f) :
  modular_form Γ k :=
{ to_fun := f',
  slash_action_eq' := h.symm ▸ f.slash_action_eq',
  holo' := h.symm ▸ f.holo',
  bdd_at_infty' := λ A, h.symm ▸ f.bdd_at_infty' A }

/-- Copy of a `cusp_form` with a new `to_fun` equal to the old one. Useful to fix
definitional equalities. -/
protected def cusp_form.copy (f : cusp_form Γ k) (f' : ℍ → ℂ) (h : f' = ⇑f) :
  cusp_form Γ k :=
{ to_fun := f',
  slash_action_eq' := h.symm ▸ f.slash_action_eq',
  holo' := h.symm ▸ f.holo',
  zero_at_infty' := λ A, h.symm ▸ f.zero_at_infty' A }

end modular_form

namespace modular_form

open slash_invariant_form

variables {F : Type*} {Γ : subgroup SL(2, ℤ)} {k : ℤ}

instance has_add : has_add (modular_form Γ k) :=
⟨ λ f g,
  { holo' := f.holo'.add g.holo',
    bdd_at_infty' := λ A, by simpa using (f.bdd_at_infty' A).add (g.bdd_at_infty' A),
    .. (f : slash_invariant_form Γ k) + g }⟩

@[simp] lemma coe_add (f g : modular_form Γ k) : ⇑(f + g) = f + g := rfl

@[simp] lemma add_apply (f g : modular_form Γ k) (z : ℍ) : (f + g) z = f z + g z := rfl

instance has_zero : has_zero (modular_form Γ k) :=
⟨ { holo' := (λ _, mdifferentiable_at_const 𝓘(ℂ, ℂ) 𝓘(ℂ, ℂ)),
    bdd_at_infty' := λ A, by simpa using zero_form_is_bounded_at_im_infty,
    .. (0 : slash_invariant_form Γ k) } ⟩

@[simp] lemma coe_zero : ⇑(0 : modular_form Γ k) = (0 : ℍ → ℂ) := rfl

@[simp] lemma zero_apply (z : ℍ) : (0 : modular_form Γ k) z = 0 := rfl

section
variables {α : Type*} [has_smul α ℂ] [is_scalar_tower α ℂ ℂ]

instance has_smul : has_smul α (modular_form Γ k) :=
⟨ λ c f,
  { to_fun := c • f,
    holo' := by simpa using f.holo'.const_smul (c • (1 : ℂ)),
    bdd_at_infty' := λ A, by simpa using (f.bdd_at_infty' A).const_smul_left (c • (1 : ℂ)),
     .. c • (f : slash_invariant_form Γ k)}⟩

@[simp] lemma coe_smul (f : (modular_form Γ k)) (n : α) : ⇑(n • f) = n • f := rfl
@[simp] lemma smul_apply (f : (modular_form Γ k)) (n : α) (z : ℍ) :
   (n • f) z = n • (f z) := rfl
end

instance has_neg : has_neg (modular_form Γ k) :=
⟨λ f,
  { to_fun := -f,
    holo' := f.holo'.neg,
    bdd_at_infty':= λ A, by simpa using (f.bdd_at_infty' A).neg,
    .. -(f : slash_invariant_form Γ k) }⟩

@[simp] lemma coe_neg (f : modular_form Γ k) : ⇑(-f) = -f := rfl

@[simp] lemma neg_apply (f : modular_form Γ k) (z : ℍ) : (-f) z = - (f z) := rfl

instance has_sub : has_sub (modular_form Γ k) :=
⟨ λ f g, f + -g ⟩

@[simp] lemma coe_sub (f g : (modular_form Γ k)) : ⇑(f - g) = f - g := rfl

@[simp] lemma sub_apply (f g : modular_form Γ k) (z : ℍ) : (f - g) z = f z - g z := rfl

instance : add_comm_group (modular_form Γ k) :=
fun_like.coe_injective.add_comm_group _ rfl coe_add coe_neg coe_sub coe_smul coe_smul

/--Additive coercion from `modular_form` to `ℍ → ℂ`. -/
@[simps] def coe_hom : (modular_form Γ k) →+ (ℍ → ℂ) :=
{ to_fun := λ f, f,
  map_zero' := coe_zero,
  map_add' := λ _ _, rfl }

instance : module ℂ (modular_form Γ k) :=
function.injective.module ℂ coe_hom fun_like.coe_injective (λ _ _, rfl)

instance : inhabited (modular_form Γ k) := ⟨0⟩

/--The modular form of weight `k_1 + k_2` given by the product of two modular forms of weights
`k_1` and `k_2`. -/
def mul {k_1 k_2 : ℤ} {Γ : subgroup SL(2, ℤ)} (f : (modular_form Γ k_1))
  (g : (modular_form Γ k_2)) : (modular_form Γ (k_1 + k_2)) :=
{ to_fun := f * g,
  slash_action_eq' := λ A, by simp_rw [mul_slash_subgroup, modular_form_class.slash_action_eq],
  holo' := f.holo'.mul g.holo',
  bdd_at_infty' := λ A, by simpa using (f.bdd_at_infty' A).mul (g.bdd_at_infty' A) }

@[simp] lemma mul_coe {k_1 k_2 : ℤ} {Γ : subgroup SL(2, ℤ)} (f : (modular_form Γ k_1))
  (g : (modular_form Γ k_2)) : ((f.mul g) : ℍ → ℂ) = f * g := rfl

instance : has_one (modular_form Γ 0) :=
⟨{  holo' := λ x, mdifferentiable_at_const 𝓘(ℂ, ℂ) 𝓘(ℂ, ℂ),
    bdd_at_infty' := λ A, by simpa using at_im_infty.const_bounded_at_filter (1:ℂ),
      .. (1 : slash_invariant_form Γ 0) }⟩

@[simp]

end modular_form

namespace cusp_form
open modular_form

variables {F : Type*} {Γ : subgroup SL(2, ℤ)} {k : ℤ}

instance has_add : has_add (cusp_form Γ k) :=
⟨ λ f g,
  { to_fun := f + g,
    holo' := f.holo'.add g.holo',
    zero_at_infty' := λ A, by simpa using (f.zero_at_infty' A).add (g.zero_at_infty' A),
    .. (f : slash_invariant_form Γ k) + g }⟩

@[simp] lemma coe_add (f g : cusp_form Γ k) : ⇑(f + g) = f + g := rfl

@[simp] lemma add_apply (f g : cusp_form Γ k) (z : ℍ) : (f + g) z = f z + g z := rfl

instance has_zero : has_zero (cusp_form Γ k) :=
⟨ { to_fun := 0,
    holo' := (λ _, mdifferentiable_at_const 𝓘(ℂ, ℂ) 𝓘(ℂ, ℂ)),
    zero_at_infty' := by simpa using filter.zero_zero_at_filter _,
    .. (0 : slash_invariant_form Γ k) }⟩

@[simp] lemma coe_zero : ⇑(0 : cusp_form Γ k) = (0 : ℍ → ℂ) := rfl

@[simp] lemma zero_apply (z : ℍ) : (0 : cusp_form Γ k) z = 0 := rfl

section
variables {α : Type*} [has_smul α ℂ] [is_scalar_tower α ℂ ℂ]

instance has_smul : has_smul α (cusp_form Γ k) :=
⟨ λ c f,
  { to_fun := c • f,
    holo' := by simpa using f.holo'.const_smul (c • (1 : ℂ)),
    zero_at_infty' := λ A, by simpa using (f.zero_at_infty' A).smul (c • (1 : ℂ)),
    .. c • (f : slash_invariant_form Γ k) }⟩

@[simp] lemma coe_smul (f : (cusp_form Γ k)) (n : α) : ⇑(n • f) = n • f := rfl
@[simp] lemma smul_apply (f : (cusp_form Γ k)) (n : α) {z : ℍ} :
   (n • f) z = n • (f z) := rfl

end

instance has_neg : has_neg (cusp_form Γ k) :=
⟨λ f,
  { to_fun := -f,
    holo' := f.holo'.neg,
    zero_at_infty':= λ A, by simpa using (f.zero_at_infty' A).neg,
    .. -(f : slash_invariant_form Γ k)} ⟩

@[simp] lemma coe_neg (f : cusp_form Γ k) : ⇑(-f) = -f := rfl
@[simp] lemma neg_apply (f : cusp_form Γ k) (z : ℍ) : (-f) z = -(f z) := rfl

instance has_sub : has_sub (cusp_form Γ k) :=
⟨ λ f g, f + -g ⟩

@[simp] lemma coe_sub (f g : cusp_form Γ k) : ⇑(f - g) = f - g := rfl
@[simp] lemma sub_apply (f g : cusp_form Γ k) (z : ℍ) : (f - g) z = f z - g z := rfl

instance : add_comm_group (cusp_form Γ k) :=
fun_like.coe_injective.add_comm_group _ rfl coe_add coe_neg coe_sub coe_smul coe_smul

/--Additive coercion from `cusp_form` to `ℍ → ℂ`. -/
@[simps] def coe_hom : (cusp_form Γ k) →+ (ℍ → ℂ) :=
{ to_fun := λ f, f,
  map_zero' := cusp_form.coe_zero,
  map_add' := λ _ _, rfl }

instance : module ℂ (cusp_form Γ k) :=
function.injective.module ℂ coe_hom fun_like.coe_injective (λ _ _, rfl)

instance : inhabited (cusp_form Γ k) := ⟨0⟩

@[priority 99]
instance [cusp_form_class F Γ k] : modular_form_class F Γ k :=
{ coe := fun_like.coe,
  coe_injective' := fun_like.coe_injective',
  slash_action_eq := cusp_form_class.slash_action_eq,
  holo:= cusp_form_class.holo,
  bdd_at_infty := λ _ _, (cusp_form_class.zero_at_infty _ _).bounded_at_filter}

end cusp_form


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

import data.nat.cast
import data.fintype.basic
import tactic.wlog

/-!
# Characteristic zero

A ring `R` is called of characteristic zero if every natural number `n` is non-zero when considered
as an element of `R`. Since this definition doesn't mention the multiplicative structure of `R`
except for the existence of `1` in this file characteristic zero is defined for additive monoids
with `1`.

## Main definition

`char_zero` is the typeclass of an additive monoid with one such that the natural homomorphism
from the natural numbers into it is injective.

## Main statements

* A linearly ordered semiring has characteristic zero.
* Characteristic zero implies that the additive monoid is infinite.

## TODO

* Once order of a group is defined for infinite additive monoids redefine or at least connect to
  order of `1` in the additive monoid with one.
* Unify with `char_p` (possibly using an out-parameter)
-/

/-- Typeclass for monoids with characteristic zero.
  (This is usually stated on fields but it makes sense for any additive monoid with 1.)

*Warning*: for a semiring `R`, `char_zero R` and `char_p R 0` need not coincide.
* `char_zero R` requires an injection `ℕ ↪ R`;
* `char_p R 0` asks that only `0 : ℕ` maps to `0 : R` under the map `ℕ → R`.

For instance, endowing `{0, 1}` with addition given by `max` (i.e. `1` is absorbing), shows that
`char_zero {0, 1}` does not hold and yet `char_p {0, 1} 0` does.
 -/
class char_zero (R : Type*) [add_monoid R] [has_one R] : Prop :=
(cast_injective : function.injective (coe : ℕ → R))

theorem char_zero_of_inj_zero {R : Type*} [add_left_cancel_monoid R] [has_one R]
  (H : ∀ n:ℕ, (n:R) = 0 → n = 0) : char_zero R :=
⟨λ m n, begin
   assume h,
   wlog hle : m ≤ n,
   rcases nat.le.dest hle with ⟨k, rfl⟩,
   rw [nat.cast_add, eq_comm, add_right_eq_self] at h,
   rw [H k h, add_zero]
 end⟩

/-- Note this is not an instance as `char_zero` implies `nontrivial`,
and this would risk forming a loop. -/
lemma ordered_semiring.to_char_zero {R : Type*} [ordered_semiring R] [nontrivial R] :
  char_zero R :=
⟨nat.strict_mono_cast.injective⟩

@[priority 100] -- see Note [lower instance priority]
instance linear_ordered_semiring.to_char_zero {R : Type*}
  [linear_ordered_semiring R] : char_zero R :=
ordered_semiring.to_char_zero

namespace nat
variables {R : Type*} [add_monoid R] [has_one R] [char_zero R]

theorem cast_injective : function.injective (coe : ℕ → R) :=
char_zero.cast_injective

/-- `nat.cast` as an embedding into monoids of characteristic `0`. -/
@[simps]
def cast_embedding : ℕ ↪ R := ⟨coe, cast_injective⟩

@[simp, norm_cast] theorem cast_inj {m n : ℕ} : (m : R) = n ↔ m = n :=
cast_injective.eq_iff

@[simp, norm_cast] theorem cast_eq_zero {n : ℕ} : (n : R) = 0 ↔ n = 0 :=
by rw [←cast_zero, cast_inj]

@[simp, norm_cast] theorem cast_eq_one {n : ℕ} : (n : R) = 1 ↔ n = 1 :=
by rw [←cast_one, cast_inj]

@[simp] lemma cast_pow_eq_one {R : Type*} [semiring R] [char_zero R] (q : ℕ) (n : ℕ) (hn : n ≠ 0) :
  (q : R) ^ n = 1 ↔ q = 1 :=
by { rw [←cast_pow, cast_eq_one], exact pow_eq_one_iff hn }

@[norm_cast] theorem cast_ne_zero {n : ℕ} : (n : R) ≠ 0 ↔ n ≠ 0 :=
cast_eq_zero.not

@[norm_cast] theorem cast_ne_one {n : ℕ} : (n : R) ≠ 1 ↔ n ≠ 1 :=
cast_eq_one.not

lemma cast_add_one_ne_zero (n : ℕ) : (n + 1 : R) ≠ 0 :=
by exact_mod_cast n.succ_ne_zero

@[simp, norm_cast]
theorem cast_dvd_char_zero {k : Type*} [field k] [char_zero k] {m n : ℕ}
  (n_dvd : n ∣ m) : ((m / n : ℕ) : k) = m / n :=
begin
  by_cases hn : n = 0,
  { subst hn,
    simp },
  { exact cast_dvd n_dvd (cast_ne_zero.mpr hn), },
end

end nat

section

variables (M : Type*) [add_monoid M] [has_one M] [char_zero M]

@[priority 100] -- see Note [lower instance priority]
instance char_zero.infinite : infinite M :=
infinite.of_injective coe nat.cast_injective

variable {M}

@[field_simps] lemma two_ne_zero' : (2:M) ≠ 0 :=
have ((2:ℕ):M) ≠ 0, from nat.cast_ne_zero.2 dec_trivial,
by rwa [nat.cast_two] at this

end

section
variables {R : Type*} [non_assoc_semiring R] [no_zero_divisors R] [char_zero R]

@[simp]
lemma add_self_eq_zero {a : R} : a + a = 0 ↔ a = 0 :=
by simp only [(two_mul a).symm, mul_eq_zero, two_ne_zero', false_or]

@[simp]
lemma bit0_eq_zero {a : R} : bit0 a = 0 ↔ a = 0 := add_self_eq_zero
@[simp]
lemma zero_eq_bit0 {a : R} : 0 = bit0 a ↔ a = 0 :=
by { rw [eq_comm], exact bit0_eq_zero }
end

section
variables {R : Type*} [non_assoc_ring R] [no_zero_divisors R] [char_zero R]

lemma neg_eq_self_iff {a : R} : -a = a ↔ a = 0 :=
neg_eq_iff_add_eq_zero.trans add_self_eq_zero

lemma eq_neg_self_iff {a : R} : a = -a ↔ a = 0 :=
eq_neg_iff_add_eq_zero.trans add_self_eq_zero

lemma nat_mul_inj {n : ℕ} {a b : R} (h : (n : R) * a = (n : R) * b) : n = 0 ∨ a = b :=
begin
  rw [←sub_eq_zero, ←mul_sub, mul_eq_zero, sub_eq_zero] at h,
  exact_mod_cast h,
end

lemma nat_mul_inj' {n : ℕ} {a b : R} (h : (n : R) * a = (n : R) * b) (w : n ≠ 0) : a = b :=
by simpa [w] using nat_mul_inj h

lemma bit0_injective : function.injective (bit0 : R → R) :=
λ a b h, begin
  dsimp [bit0] at h,
  simp only [(two_mul a).symm, (two_mul b).symm] at h,
  refine nat_mul_inj' _ two_ne_zero,
  exact_mod_cast h,
end

lemma bit1_injective : function.injective (bit1 : R → R) :=
λ a b h, begin
  simp only [bit1, add_left_inj] at h,
  exact bit0_injective h,
end

@[simp] lemma bit0_eq_bit0 {a b : R} : bit0 a = bit0 b ↔ a = b :=
bit0_injective.eq_iff

@[simp] lemma bit1_eq_bit1 {a b : R} : bit1 a = bit1 b ↔ a = b :=
bit1_injective.eq_iff

@[simp]
lemma bit1_eq_one {a : R} : bit1 a = 1 ↔ a = 0 :=
by rw [show (1 : R) = bit1 0, by simp, bit1_eq_bit1]

@[simp]
lemma one_eq_bit1 {a : R} : 1 = bit1 a ↔ a = 0 :=
by { rw [eq_comm], exact bit1_eq_one }

end

section
variables {R : Type*} [division_ring R] [char_zero R]

@[simp] lemma half_add_self (a : R) : (a + a) / 2 = a :=
by rw [← mul_two, mul_div_cancel a two_ne_zero']

@[simp] lemma add_halves' (a : R) : a / 2 + a / 2 = a :=
by rw [← add_div, half_add_self]

lemma sub_half (a : R) : a - a / 2 = a / 2 :=
by rw [sub_eq_iff_eq_add, add_halves']

lemma half_sub (a : R) : a / 2 - a = - (a / 2) :=
by rw [← neg_sub, sub_half]

end

namespace with_top

instance {R : Type*} [add_monoid R] [has_one R] [char_zero R] : char_zero (with_top R) :=
{ cast_injective := λ m n h, by rwa [← coe_nat, ← coe_nat n, coe_eq_coe, nat.cast_inj] at h }

end with_top

section ring_hom

variables {R S : Type*} [non_assoc_semiring R] [non_assoc_semiring S]

lemma ring_hom.char_zero (ϕ : R →+* S) [hS : char_zero S] : char_zero R :=
⟨λ a b h, char_zero.cast_injective (by rw [←map_nat_cast ϕ, ←map_nat_cast ϕ, h])⟩

lemma ring_hom.char_zero_iff {ϕ : R →+* S} (hϕ : function.injective ϕ) :
  char_zero R ↔ char_zero S :=
⟨λ hR, ⟨λ a b h, by rwa [←@nat.cast_inj R _ _ hR, ←hϕ.eq_iff, map_nat_cast ϕ, map_nat_cast ϕ]⟩,
  λ hS, by exactI ϕ.char_zero⟩

end ring_hom


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

! This file was ported from Lean 3 source module data.rat.lemmas
! leanprover-community/mathlib commit 550b58538991c8977703fdeb7c9d51a5aa27df11
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Rat.Defs
import Mathlib.Data.Int.Cast.Lemmas
import Mathlib.Data.Int.Div
import Mathlib.Algebra.GroupWithZero.Units.Lemmas
import Mathlib.Tactic.NthRewrite

/-!
# Further lemmas for the Rational Numbers

-/

namespace Rat

open Rat

theorem num_dvd (a) {b : ℤ} (b0 : b ≠ 0) : (a /. b).num ∣ a := by
  cases' e : a /. b with n d h c
  rw [Rat.num_den', divInt_eq_iff b0 (ne_of_gt (Int.coe_nat_pos.2 (Nat.pos_of_ne_zero h)))] at e
  refine' Int.natAbs_dvd.1 <| Int.dvd_natAbs.1 <| Int.coe_nat_dvd.2 <| c.dvd_of_dvd_mul_right _
  have := congr_arg Int.natAbs e
  simp only [Int.natAbs_mul, Int.natAbs_ofNat] at this; simp [this]
#align rat.num_dvd Rat.num_dvd

theorem den_dvd (a b : ℤ) : ((a /. b).den : ℤ) ∣ b := by
  by_cases b0 : b = 0; · simp [b0]
  cases' e : a /. b with n d h c
  rw [num_den', divInt_eq_iff b0 (ne_of_gt (Int.coe_nat_pos.2 (Nat.pos_of_ne_zero h)))] at e
  refine' Int.dvd_natAbs.1 <| Int.coe_nat_dvd.2 <| c.symm.dvd_of_dvd_mul_left _
  rw [← Int.natAbs_mul, ← Int.coe_nat_dvd, Int.dvd_natAbs, ← e]; simp
#align rat.denom_dvd Rat.den_dvd

theorem num_den_mk {q : ℚ} {n d : ℤ} (hd : d ≠ 0) (qdf : q = n /. d) :
    ∃ c : ℤ, n = c * q.num ∧ d = c * q.den := by
  obtain rfl | hn := eq_or_ne n 0
  · simp [qdf]
  have : q.num * d = n * ↑q.den := by
    refine' (divInt_eq_iff _ hd).mp _
    · exact Int.coe_nat_ne_zero.mpr (Rat.den_nz _)
    · rwa [num_den]
  have hqdn : q.num ∣ n := by
    rw [qdf]
    exact Rat.num_dvd _ hd
  refine' ⟨n / q.num, _, _⟩
  · rw [Int.ediv_mul_cancel hqdn]
  · refine' Int.eq_mul_div_of_mul_eq_mul_of_dvd_left _ hqdn this
    rw [qdf]
    exact Rat.num_ne_zero_of_ne_zero ((divInt_ne_zero hd).mpr hn)
#align rat.num_denom_mk Rat.num_den_mk

#noalign rat.mk_pnat_num
#noalign rat.mk_pnat_denom

theorem num_mk (n d : ℤ) : (n /. d).num = d.sign * n / n.gcd d := by
  rcases d with ((_ | _) | _) <;>
  rw [←Int.div_eq_ediv_of_dvd] <;>
  simp [divInt, mkRat, Rat.normalize, Nat.succPNat, Int.sign, Int.gcd, -Nat.cast_succ,
    Int.zero_ediv, Int.ofNat_dvd_left, Nat.gcd_dvd_left]

#align rat.num_mk Rat.num_mk

theorem den_mk (n d : ℤ) : (n /. d).den = if d = 0 then 1 else d.natAbs / n.gcd d := by
  rcases d with ((_ | _) | _) <;>
    simp [divInt, mkRat, Rat.normalize, Nat.succPNat, Int.sign, Int.gcd, -Nat.cast_succ]
#align rat.denom_mk Rat.den_mk

#noalign rat.mk_pnat_denom_dvd

theorem add_den_dvd (q₁ q₂ : ℚ) : (q₁ + q₂).den ∣ q₁.den * q₂.den := by
  rw [add_def, normalize_eq]
  apply Nat.div_dvd_of_dvd
  apply Nat.gcd_dvd_right
#align rat.add_denom_dvd Rat.add_den_dvd

theorem mul_den_dvd (q₁ q₂ : ℚ) : (q₁ * q₂).den ∣ q₁.den * q₂.den := by
  rw [mul_def, normalize_eq]
  apply Nat.div_dvd_of_dvd
  apply Nat.gcd_dvd_right
#align rat.mul_denom_dvd Rat.mul_den_dvd

theorem mul_num (q₁ q₂ : ℚ) :
    (q₁ * q₂).num = q₁.num * q₂.num / Nat.gcd (q₁.num * q₂.num).natAbs (q₁.den * q₂.den) := by
  rw [mul_def, normalize_eq]
#align rat.mul_num Rat.mul_num

theorem mul_den (q₁ q₂ : ℚ) :
    (q₁ * q₂).den =
      q₁.den * q₂.den / Nat.gcd (q₁.num * q₂.num).natAbs (q₁.den * q₂.den) := by
  rw [mul_def, normalize_eq]
#align rat.mul_denom Rat.mul_den

theorem mul_self_num (q : ℚ) : (q * q).num = q.num * q.num := by
  rw [mul_num, Int.natAbs_mul, Nat.coprime.gcd_eq_one, Int.ofNat_one, Int.ediv_one]
  exact (q.reduced.mul_right q.reduced).mul (q.reduced.mul_right q.reduced)
#align rat.mul_self_num Rat.mul_self_num

theorem mul_self_den (q : ℚ) : (q * q).den = q.den * q.den := by
  rw [Rat.mul_den, Int.natAbs_mul, Nat.coprime.gcd_eq_one, Nat.div_one]
  exact (q.reduced.mul_right q.reduced).mul (q.reduced.mul_right q.reduced)
#align rat.mul_self_denom Rat.mul_self_den

theorem add_num_den (q r : ℚ) :
    q + r = (q.num * r.den + q.den * r.num : ℤ) /. (↑q.den * ↑r.den : ℤ) := by
  have hqd : (q.den : ℤ) ≠ 0 := Int.coe_nat_ne_zero_iff_pos.2 q.den_pos
  have hrd : (r.den : ℤ) ≠ 0 := Int.coe_nat_ne_zero_iff_pos.2 r.den_pos
  conv_lhs => rw [← @num_den q, ← @num_den r, Rat.add_def'' hqd hrd]
  rw [mul_comm r.num q.den]
#align rat.add_num_denom Rat.add_num_den

section Casts

theorem exists_eq_mul_div_num_and_eq_mul_div_den (n : ℤ) {d : ℤ} (d_ne_zero : d ≠ 0) :
    ∃ c : ℤ, n = c * ((n : ℚ) / d).num ∧ (d : ℤ) = c * ((n : ℚ) / d).den :=
  haveI : (n : ℚ) / d = Rat.divInt n d := by rw [← Rat.divInt_eq_div]
  Rat.num_den_mk d_ne_zero this
#align rat.exists_eq_mul_div_num_and_eq_mul_div_denom Rat.exists_eq_mul_div_num_and_eq_mul_div_den

theorem mul_num_den' (q r : ℚ) :
    (q * r).num * q.den * r.den = q.num * r.num * (q * r).den := by
  let s := q.num * r.num /. (q.den * r.den : ℤ)
  have hs : (q.den * r.den : ℤ) ≠ 0 := Int.coe_nat_ne_zero_iff_pos.mpr (mul_pos q.pos r.pos)
  obtain ⟨c, ⟨c_mul_num, c_mul_den⟩⟩ :=
    exists_eq_mul_div_num_and_eq_mul_div_den (q.num * r.num) hs
  rw [c_mul_num, mul_assoc, mul_comm]
  nth_rw 1 [c_mul_den]
  repeat' rw [Int.mul_assoc]
  apply mul_eq_mul_left_iff.2
  rw [or_iff_not_imp_right]
  intro
  have h : _ = s :=
    @mul_def' q.num q.den r.num r.den (Int.coe_nat_ne_zero_iff_pos.mpr q.pos)
      (Int.coe_nat_ne_zero_iff_pos.mpr r.pos)
  rw [num_den, num_den] at h
  rw [h]
  rw [mul_comm]
  apply Rat.eq_iff_mul_eq_mul.mp
  rw [← divInt_eq_div]
#align rat.mul_num_denom' Rat.mul_num_den'

theorem add_num_den' (q r : ℚ) :
    (q + r).num * q.den * r.den = (q.num * r.den + r.num * q.den) * (q + r).den := by
  let s := divInt (q.num * r.den + r.num * q.den) (q.den * r.den : ℤ)
  have hs : (q.den * r.den : ℤ) ≠ 0 := Int.coe_nat_ne_zero_iff_pos.mpr (mul_pos q.pos r.pos)
  obtain ⟨c, ⟨c_mul_num, c_mul_den⟩⟩ :=
    exists_eq_mul_div_num_and_eq_mul_div_den (q.num * r.den + r.num * q.den) hs
  rw [c_mul_num, mul_assoc, mul_comm]
  nth_rw 1 [c_mul_den]
  repeat' rw [Int.mul_assoc]
  apply mul_eq_mul_left_iff.2
  rw [or_iff_not_imp_right]
  intro
  have h : _ = s :=
    @add_def'' q.num q.den r.num r.den (Int.coe_nat_ne_zero_iff_pos.mpr q.pos)
      (Int.coe_nat_ne_zero_iff_pos.mpr r.pos)
  rw [num_den, num_den] at h
  rw [h]
  rw [mul_comm]
  apply Rat.eq_iff_mul_eq_mul.mp
  rw [← divInt_eq_div]
#align rat.add_num_denom' Rat.add_num_den'

theorem substr_num_den' (q r : ℚ) :
    (q - r).num * q.den * r.den = (q.num * r.den - r.num * q.den) * (q - r).den := by
  rw [sub_eq_add_neg, sub_eq_add_neg, ← neg_mul, ← num_neg_eq_neg_num, ← den_neg_eq_den r,
    add_num_den' q (-r)]
#align rat.substr_num_denom' Rat.substr_num_den'

end Casts

protected theorem inv_neg (q : ℚ) : (-q)⁻¹ = -q⁻¹ := by
  rw [← @num_den q]
  simp only [Rat.neg_def, Rat.inv_def', eq_self_iff_true, Rat.divInt_neg_den]
#align rat.inv_neg Rat.inv_neg

@[simp]
theorem mul_den_eq_num {q : ℚ} : q * q.den = q.num := by
  suffices (q.num /. ↑q.den) * (↑q.den /. 1) = q.num /. 1 by
    conv => pattern (occs := 1)q ; (rw [← @num_den q])
    simp only [coe_int_eq_divInt, coe_nat_eq_divInt, num_den] at this ⊢; assumption
  have : (q.den : ℤ) ≠ 0 := ne_of_gt (by exact_mod_cast q.pos)
  rw [Rat.mul_def' this one_ne_zero, mul_comm (q.den : ℤ) 1, divInt_mul_right this]
#align rat.mul_denom_eq_num Rat.mul_den_eq_num

theorem den_div_cast_eq_one_iff (m n : ℤ) (hn : n ≠ 0) : ((m : ℚ) / n).den = 1 ↔ n ∣ m := by
  replace hn : (n : ℚ) ≠ 0
  · rwa [Ne.def, ← Int.cast_zero, coe_int_inj]
  constructor
  · intro h
    -- Porting note: was `lift (m : ℚ) / n to ℤ using h with k hk`
    use ((m : ℚ) / n).num
    have hk := Rat.coe_int_num_of_den_eq_one h
    simp_rw [eq_div_iff_mul_eq hn, ofInt_eq_cast, ← Int.cast_mul] at hk
    rwa [mul_comm, eq_comm, coe_int_inj] at hk
  · rintro ⟨d, rfl⟩
    rw [Int.cast_mul, mul_comm, mul_div_cancel _ hn, Rat.coe_int_den]
#align rat.denom_div_cast_eq_one_iff Rat.den_div_cast_eq_one_iff

theorem num_div_eq_of_coprime {a b : ℤ} (hb0 : 0 < b) (h : Nat.coprime a.natAbs b.natAbs) :
    (a / b : ℚ).num = a := by
  -- Porting note: was `lift b to ℕ using le_of_lt hb0`
  rw [←Int.natAbs_of_nonneg hb0.le, ← Rat.divInt_eq_div,
    ←mk_eq_divInt _ _ (Int.natAbs_ne_zero.mpr hb0.ne') h]
#align rat.num_div_eq_of_coprime Rat.num_div_eq_of_coprime

theorem den_div_eq_of_coprime {a b : ℤ} (hb0 : 0 < b) (h : Nat.coprime a.natAbs b.natAbs) :
    ((a / b : ℚ).den : ℤ) = b := by
  -- Porting note: was `lift b to ℕ using le_of_lt hb0`
  rw [←Int.natAbs_of_nonneg hb0.le, ← Rat.divInt_eq_div,
    ←mk_eq_divInt _ _ (Int.natAbs_ne_zero.mpr hb0.ne') h]
#align rat.denom_div_eq_of_coprime Rat.den_div_eq_of_coprime

theorem div_int_inj {a b c d : ℤ} (hb0 : 0 < b) (hd0 : 0 < d) (h1 : Nat.coprime a.natAbs b.natAbs)
    (h2 : Nat.coprime c.natAbs d.natAbs) (h : (a : ℚ) / b = (c : ℚ) / d) : a = c ∧ b = d := by
  apply And.intro
  · rw [← num_div_eq_of_coprime hb0 h1, h, num_div_eq_of_coprime hd0 h2]
  · rw [← den_div_eq_of_coprime hb0 h1, h, den_div_eq_of_coprime hd0 h2]
#align rat.div_int_inj Rat.div_int_inj

@[norm_cast]
theorem coe_int_div_self (n : ℤ) : ((n / n : ℤ) : ℚ) = n / n := by
  by_cases hn : n = 0
  · subst hn
    simp only [Int.cast_zero, Int.zero_div, zero_div]
  · have : (n : ℚ) ≠ 0 := by rwa [← coe_int_inj] at hn
    simp only [Int.ediv_self hn, Int.cast_one, Ne.def, not_false_iff, div_self this]
#align rat.coe_int_div_self Rat.coe_int_div_self

@[norm_cast]
theorem coe_nat_div_self (n : ℕ) : ((n / n : ℕ) : ℚ) = n / n :=
  coe_int_div_self n
#align rat.coe_nat_div_self Rat.coe_nat_div_self

theorem coe_int_div (a b : ℤ) (h : b ∣ a) : ((a / b : ℤ) : ℚ) = a / b := by
  rcases h with ⟨c, rfl⟩
  rw [mul_comm b, Int.mul_ediv_assoc c (dvd_refl b), Int.cast_mul,
    coe_int_div_self, Int.cast_mul, mul_div_assoc]
#align rat.coe_int_div Rat.coe_int_div

theorem coe_nat_div (a b : ℕ) (h : b ∣ a) : ((a / b : ℕ) : ℚ) = a / b := by
  rcases h with ⟨c, rfl⟩
  simp only [mul_comm b, Nat.mul_div_assoc c (dvd_refl b), Nat.cast_mul, mul_div_assoc,
    coe_nat_div_self]
#align rat.coe_nat_div Rat.coe_nat_div

theorem inv_coe_int_num_of_pos {a : ℤ} (ha0 : 0 < a) : (a : ℚ)⁻¹.num = 1 := by
  rw [← ofInt_eq_cast, ofInt, mk_eq_divInt, Rat.inv_def', divInt_eq_div, Nat.cast_one]
  apply num_div_eq_of_coprime ha0
  rw [Int.natAbs_one]
  exact Nat.coprime_one_left _
#align rat.inv_coe_int_num_of_pos Rat.inv_coe_int_num_of_pos

theorem inv_coe_nat_num_of_pos {a : ℕ} (ha0 : 0 < a) : (a : ℚ)⁻¹.num = 1 :=
  inv_coe_int_num_of_pos (by exact_mod_cast ha0 : 0 < (a : ℤ))
#align rat.inv_coe_nat_num_of_pos Rat.inv_coe_nat_num_of_pos

theorem inv_coe_int_den_of_pos {a : ℤ} (ha0 : 0 < a) : ((a : ℚ)⁻¹.den : ℤ) = a := by
  rw [← ofInt_eq_cast, ofInt, mk_eq_divInt, Rat.inv_def', divInt_eq_div, Nat.cast_one]
  apply den_div_eq_of_coprime ha0
  rw [Int.natAbs_one]
  exact Nat.coprime_one_left _
#align rat.inv_coe_int_denom_of_pos Rat.inv_coe_int_den_of_pos

theorem inv_coe_nat_den_of_pos {a : ℕ} (ha0 : 0 < a) : (a : ℚ)⁻¹.den = a := by
  rw [← Int.ofNat_inj, ← Int.cast_ofNat a, inv_coe_int_den_of_pos]
  rwa [Nat.cast_pos]
#align rat.inv_coe_nat_denom_of_pos Rat.inv_coe_nat_den_of_pos

@[simp]
theorem inv_coe_int_num (a : ℤ) : (a : ℚ)⁻¹.num = Int.sign a := by
  induction a using Int.induction_on <;>
    simp [← Int.negSucc_coe', Int.negSucc_coe, -neg_add_rev, Rat.inv_neg, Int.ofNat_add_one_out,
      -Nat.cast_succ, inv_coe_nat_num_of_pos, -Int.cast_negSucc, @eq_comm ℤ 1,
      Int.sign_eq_one_of_pos, ofInt_eq_cast]
#align rat.inv_coe_int_num Rat.inv_coe_int_num

@[simp]
theorem inv_coe_nat_num (a : ℕ) : (a : ℚ)⁻¹.num = Int.sign a :=
  inv_coe_int_num a
#align rat.inv_coe_nat_num Rat.inv_coe_nat_num

@[simp]
theorem inv_coe_int_den (a : ℤ) : (a : ℚ)⁻¹.den = if a = 0 then 1 else a.natAbs := by
  induction a using Int.induction_on <;>
    simp [← Int.negSucc_coe', Int.negSucc_coe, -neg_add_rev, Rat.inv_neg, Int.ofNat_add_one_out,
      -Nat.cast_succ, inv_coe_nat_den_of_pos, -Int.cast_negSucc, ofInt_eq_cast]
#align rat.inv_coe_int_denom Rat.inv_coe_int_den

@[simp]
theorem inv_coe_nat_den (a : ℕ) : (a : ℚ)⁻¹.den = if a = 0 then 1 else a := by
  simpa [-inv_coe_int_den, ofInt_eq_cast] using inv_coe_int_den a
#align rat.inv_coe_nat_denom Rat.inv_coe_nat_den

protected theorem «forall» {p : ℚ → Prop} : (∀ r, p r) ↔ ∀ a b : ℤ, p (a / b) :=
  ⟨fun h _ _ => h _,
   fun h q => by
    have := h q.num q.den
    rwa [Int.cast_ofNat, num_div_den q] at this⟩
#align rat.forall Rat.forall

protected theorem «exists» {p : ℚ → Prop} : (∃ r, p r) ↔ ∃ a b : ℤ, p (a / b) :=
  ⟨fun ⟨r, hr⟩ => ⟨r.num, r.den, by convert hr; convert num_div_den r⟩, fun ⟨a, b, h⟩ => ⟨_, h⟩⟩
#align rat.exists Rat.exists

/-!
### Denominator as `ℕ+`
-/

section PNatDen

/-- Denominator as `ℕ+`. -/
def pnatDen (x : ℚ) : ℕ+ :=
  ⟨x.den, x.pos⟩
#align rat.pnat_denom Rat.pnatDen

@[simp]
theorem coe_pnatDen (x : ℚ) : (x.pnatDen : ℕ) = x.den :=
  rfl
#align rat.coe_pnat_denom Rat.coe_pnatDen

#noalign rat.mk_pnat_pnat_denom_eq

theorem pnatDen_eq_iff_den_eq {x : ℚ} {n : ℕ+} : x.pnatDen = n ↔ x.den = ↑n :=
  Subtype.ext_iff
#align rat.pnat_denom_eq_iff_denom_eq Rat.pnatDen_eq_iff_den_eq

@[simp]
theorem pnatDen_one : (1 : ℚ).pnatDen = 1 :=
  rfl
#align rat.pnat_denom_one Rat.pnatDen_one

@[simp]
theorem pnatDen_zero : (0 : ℚ).pnatDen = 1 :=
  rfl
#align rat.pnat_denom_zero Rat.pnatDen_zero

end PNatDen

end Rat


/-
Copyright (c) 2020 Bolton Bailey. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bolton Bailey

! This file was ported from Lean 3 source module number_theory.lucas_primality
! leanprover-community/mathlib commit 70fd9563a21e7b963887c9360bd29b2393e6225a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Fintype.Basic
import Mathbin.GroupTheory.OrderOfElement
import Mathbin.Tactic.Zify
import Mathbin.Data.Nat.Totient

/-!
# The Lucas test for primes.

This file implements the Lucas test for primes (not to be confused with the Lucas-Lehmer test for
Mersenne primes). A number `a` witnesses that `n` is prime if `a` has order `n-1` in the
multiplicative group of integers mod `n`. This is checked by verifying that `a^(n-1) = 1 (mod n)`
and `a^d ≠ 1 (mod n)` for any divisor `d | n - 1`. This test is the basis of the Pratt primality
certificate.

## TODO

- Bonus: Show the reverse implication i.e. if a number is prime then it has a Lucas witness.
  Use `units.is_cyclic` from `ring_theory/integral_domain` to show the group is cyclic.
- Write a tactic that uses this theorem to generate Pratt primality certificates
- Integrate Pratt primality certificates into the norm_num primality verifier

## Implementation notes

Note that the proof for `lucas_primality` relies on analyzing the multiplicative group
modulo `p`. Despite this, the theorem still holds vacuously for `p = 0` and `p = 1`: In these
cases, we can take `q` to be any prime and see that `hd` does not hold, since `a^((p-1)/q)` reduces
to `1`.
-/

/- warning: lucas_primality -> lucas_primality is a dubious translation:
lean 3 declaration is
  forall (p : Nat) (a : ZMod p), (Eq.{1} (ZMod p) (HPow.hPow.{0, 0, 0} (ZMod p) Nat (ZMod p) (instHPow.{0, 0} (ZMod p) Nat (Monoid.Pow.{0} (ZMod p) (Ring.toMonoid.{0} (ZMod p) (CommRing.toRing.{0} (ZMod p) (ZMod.commRing p))))) a (HSub.hSub.{0, 0, 0} Nat Nat Nat (instHSub.{0} Nat Nat.hasSub) p (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))) (OfNat.ofNat.{0} (ZMod p) 1 (OfNat.mk.{0} (ZMod p) 1 (One.one.{0} (ZMod p) (AddMonoidWithOne.toOne.{0} (ZMod p) (AddGroupWithOne.toAddMonoidWithOne.{0} (ZMod p) (AddCommGroupWithOne.toAddGroupWithOne.{0} (ZMod p) (Ring.toAddCommGroupWithOne.{0} (ZMod p) (CommRing.toRing.{0} (ZMod p) (ZMod.commRing p)))))))))) -> (forall (q : Nat), (Nat.Prime q) -> (Dvd.Dvd.{0} Nat Nat.hasDvd q (HSub.hSub.{0, 0, 0} Nat Nat Nat (instHSub.{0} Nat Nat.hasSub) p (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))) -> (Ne.{1} (ZMod p) (HPow.hPow.{0, 0, 0} (ZMod p) Nat (ZMod p) (instHPow.{0, 0} (ZMod p) Nat (Monoid.Pow.{0} (ZMod p) (Ring.toMonoid.{0} (ZMod p) (CommRing.toRing.{0} (ZMod p) (ZMod.commRing p))))) a (HDiv.hDiv.{0, 0, 0} Nat Nat Nat (instHDiv.{0} Nat Nat.hasDiv) (HSub.hSub.{0, 0, 0} Nat Nat Nat (instHSub.{0} Nat Nat.hasSub) p (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne)))) q)) (OfNat.ofNat.{0} (ZMod p) 1 (OfNat.mk.{0} (ZMod p) 1 (One.one.{0} (ZMod p) (AddMonoidWithOne.toOne.{0} (ZMod p) (AddGroupWithOne.toAddMonoidWithOne.{0} (ZMod p) (AddCommGroupWithOne.toAddGroupWithOne.{0} (ZMod p) (Ring.toAddCommGroupWithOne.{0} (ZMod p) (CommRing.toRing.{0} (ZMod p) (ZMod.commRing p))))))))))) -> (Nat.Prime p)
but is expected to have type
  forall (p : Nat) (a : ZMod p), (Eq.{1} (ZMod p) (HPow.hPow.{0, 0, 0} (ZMod p) Nat (ZMod p) (instHPow.{0, 0} (ZMod p) Nat (Monoid.Pow.{0} (ZMod p) (MonoidWithZero.toMonoid.{0} (ZMod p) (Semiring.toMonoidWithZero.{0} (ZMod p) (Ring.toSemiring.{0} (ZMod p) (CommRing.toRing.{0} (ZMod p) (ZMod.commRing p))))))) a (HSub.hSub.{0, 0, 0} Nat Nat Nat (instHSub.{0} Nat instSubNat) p (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) (OfNat.ofNat.{0} (ZMod p) 1 (One.toOfNat1.{0} (ZMod p) (NonAssocRing.toOne.{0} (ZMod p) (Ring.toNonAssocRing.{0} (ZMod p) (CommRing.toRing.{0} (ZMod p) (ZMod.commRing p))))))) -> (forall (q : Nat), (Nat.Prime q) -> (Dvd.dvd.{0} Nat Nat.instDvdNat q (HSub.hSub.{0, 0, 0} Nat Nat Nat (instHSub.{0} Nat instSubNat) p (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) -> (Ne.{1} (ZMod p) (HPow.hPow.{0, 0, 0} (ZMod p) Nat (ZMod p) (instHPow.{0, 0} (ZMod p) Nat (Monoid.Pow.{0} (ZMod p) (MonoidWithZero.toMonoid.{0} (ZMod p) (Semiring.toMonoidWithZero.{0} (ZMod p) (Ring.toSemiring.{0} (ZMod p) (CommRing.toRing.{0} (ZMod p) (ZMod.commRing p))))))) a (HDiv.hDiv.{0, 0, 0} Nat Nat Nat (instHDiv.{0} Nat Nat.instDivNat) (HSub.hSub.{0, 0, 0} Nat Nat Nat (instHSub.{0} Nat instSubNat) p (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))) q)) (OfNat.ofNat.{0} (ZMod p) 1 (One.toOfNat1.{0} (ZMod p) (NonAssocRing.toOne.{0} (ZMod p) (Ring.toNonAssocRing.{0} (ZMod p) (CommRing.toRing.{0} (ZMod p) (ZMod.commRing p)))))))) -> (Nat.Prime p)
Case conversion may be inaccurate. Consider using '#align lucas_primality lucas_primalityₓ'. -/
/-- If `a^(p-1) = 1 mod p`, but `a^((p-1)/q) ≠ 1 mod p` for all prime factors `q` of `p-1`, then `p`
is prime. This is true because `a` has order `p-1` in the multiplicative group mod `p`, so this
group must itself have order `p-1`, which only happens when `p` is prime.
-/
theorem lucas_primality (p : ℕ) (a : ZMod p) (ha : a ^ (p - 1) = 1)
    (hd : ∀ q : ℕ, q.Prime → q ∣ p - 1 → a ^ ((p - 1) / q) ≠ 1) : p.Prime :=
  by
  have h0 : p ≠ 0 := by
    rintro ⟨⟩
    exact hd 2 Nat.prime_two (dvd_zero _) (pow_zero _)
  have h1 : p ≠ 1 := by
    rintro ⟨⟩
    exact hd 2 Nat.prime_two (dvd_zero _) (pow_zero _)
  have hp1 : 1 < p := lt_of_le_of_ne h0.bot_lt h1.symm
  have order_of_a : orderOf a = p - 1 :=
    by
    apply orderOf_eq_of_pow_and_pow_div_prime _ ha hd
    exact tsub_pos_of_lt hp1
  haveI : NeZero p := ⟨h0⟩
  rw [Nat.prime_iff_card_units]
  -- Prove cardinality of `units` of `zmod p` is both `≤ p-1` and `≥ p-1`
  refine' le_antisymm (Nat.card_units_zMod_lt_sub_one hp1) _
  have hp' : p - 2 + 1 = p - 1 := tsub_add_eq_add_tsub hp1
  let a' : (ZMod p)ˣ := Units.mkOfMulEqOne a (a ^ (p - 2)) (by rw [← pow_succ, hp', ha])
  calc
    p - 1 = orderOf a := order_of_a.symm
    _ = orderOf a' := (orderOf_injective (Units.coeHom (ZMod p)) Units.ext a')
    _ ≤ Fintype.card (ZMod p)ˣ := orderOf_le_card_univ

#align lucas_primality lucas_primality


/-
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.coset

/-!
# Quotients of groups by normal subgroups

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 / M) / (M / N)` and `G / N`, where `N ≤ M`.

## Tags

isomorphism theorems, quotient groups
-/

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

-- Define the `div_inv_monoid` before the `group` structure,
-- to make sure we have `inv` fully defined before we show `mul_left_inv`.
-- TODO: is there a non-invasive way of defining this in one declaration?
@[to_additive quotient_add_group.div_inv_monoid]
instance : div_inv_monoid (G ⧸ N) :=
{ one := (1 : G),
  mul := quotient.map₂' (*)
  (λ a₁ b₁ hab₁ a₂ b₂ hab₂,
    ((N.mul_mem_cancel_right (N.inv_mem hab₂)).1
        (by rw [mul_inv_rev, mul_inv_rev, ← mul_assoc (a₂⁻¹ * a₁⁻¹),
          mul_assoc _ b₂, ← mul_assoc b₂, mul_inv_self, one_mul, mul_assoc (a₂⁻¹)];
          exact nN.conj_mem _ hab₁ _))),
  mul_assoc := λ a b c, quotient.induction_on₃' a b c
    (λ a b c, congr_arg mk (mul_assoc a b c)),
  one_mul := λ a, quotient.induction_on' a
    (λ a, congr_arg mk (one_mul a)),
  mul_one := λ a, quotient.induction_on' a
    (λ a, congr_arg mk (mul_one a)),
  inv := λ a, quotient.lift_on' a (λ a, ((a⁻¹ : G) : G ⧸ N))
    (λ a b hab, quotient.sound' begin
      show a⁻¹⁻¹ * b⁻¹ ∈ N,
      rw ← mul_inv_rev,
      exact N.inv_mem (nN.mem_comm hab)
    end) }

@[to_additive quotient_add_group.add_group]
instance quotient.group : group (G ⧸ N) :=
{ mul_left_inv := λ a, quotient.induction_on' a
    (λ a, congr_arg mk (mul_left_inv a)),
 .. quotient.div_inv_monoid _ }

/-- The group homomorphism from `G` to `G/N`. -/
@[to_additive quotient_add_group.mk' "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

/-- 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 quotient_add_group.eq_zero_iff]
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 quotient_add_group.ker_mk]
lemma ker_mk :
  monoid_hom.ker (quotient_group.mk' N : G →* G ⧸ N) = N :=
subgroup.ext eq_one_iff

@[to_additive quotient_add_group.eq_iff_sub_mem]

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

@[to_additive quotient_add_group.add_comm_group]
instance {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 quotient_add_group.coe_zero]
lemma coe_one : ((1 : G) : Q) = 1 := rfl

@[simp, to_additive quotient_add_group.coe_add]
lemma coe_mul (a b : G) : ((a * b : G) : Q) = a * b := rfl

@[simp, to_additive quotient_add_group.coe_neg]
lemma coe_inv (a : G) : ((a⁻¹ : G) : Q) = a⁻¹ := rfl

@[simp] lemma coe_pow (a : G) (n : ℕ) : ((a ^ n : G) : Q) = a ^ n :=
(mk' N).map_pow a n

@[simp] lemma coe_zpow (a : G) (n : ℤ) : ((a ^ n : G) : Q) = a ^ n :=
(mk' N).map_zpow a n

/-- A group homomorphism `φ : G →* H` with `N ⊆ ker(φ)` descends (i.e. `lift`s) to a
group homomorphism `G/N →* H`. -/
@[to_additive quotient_add_group.lift "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 :=
monoid_hom.mk'
  (λ q : Q, quotient.lift_on' q φ $ assume a b (hab : a⁻¹ * b ∈ N),
  (calc φ a = φ a * 1           : (mul_one _).symm
  ...       = φ a * φ (a⁻¹ * b) : HN (a⁻¹ * b) hab ▸ rfl
  ...       = φ (a * (a⁻¹ * b)) : (φ.map_mul a (a⁻¹ * b)).symm
  ...       = φ b               : by rw mul_inv_cancel_left))
  (λ q r, quotient.induction_on₂' q r $ φ.map_mul)

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

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

@[simp, to_additive quotient_add_group.lift_quot_mk]
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 quotient_add_group.map "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 quotient_add_group.map_coe] 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) :=
lift_mk' _ _ x

@[to_additive quotient_add_group.map_mk'] 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) :=
quotient_group.lift_mk' _ _ x

omit nN
variables (φ : G →* H)

open function monoid_hom

/-- The induced map from the quotient by the kernel to the codomain. -/
@[to_additive quotient_add_group.ker_lift "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 quotient_add_group.ker_lift_mk]
lemma ker_lift_mk (g : G) : (ker_lift φ) g = φ g :=
lift_mk _ _ _

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

@[to_additive quotient_add_group.injective_ker_lift]
lemma ker_lift_injective : injective (ker_lift φ) :=
assume a b, quotient.induction_on₂' a b $
  assume a b (h : φ a = φ b), quotient.sound' $
show a⁻¹ * b ∈ ker φ, by rw [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 quotient_add_group.range_ker_lift "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 range_restrict_ker

@[to_additive quotient_add_group.range_ker_lift_injective]
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' $
show a⁻¹ * b ∈ ker φ, by rw [←range_restrict_ker, mem_ker,
  φ.range_restrict.map_mul, ← h, φ.range_restrict.map_inv, inv_mul_self]

@[to_additive quotient_add_group.range_ker_lift_surjective]
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 quotient_add_group.quotient_ker_equiv_range "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 quotient_add_group.quotient_ker_equiv_of_right_inverse "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φ : function.right_inverse ψ φ) :
  G ⧸ ker φ ≃* H :=
{ to_fun := ker_lift φ,
  inv_fun := mk ∘ ψ,
  left_inv := λ x, ker_lift_injective φ (by rw [function.comp_app, ker_lift_mk', hφ]),
  right_inv := hφ,
  .. ker_lift φ }

/-- The canonical isomorphism `G/⊥ ≃* G`. -/
@[to_additive quotient_add_group.quotient_bot "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 quotient_add_group.quotient_ker_equiv_of_surjective "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φ : function.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 equiv_quotient_of_eq {M N : subgroup G} [M.normal] [N.normal] (h : M = N) :
  G ⧸ M ≃* G ⧸ N :=
{ to_fun := (lift M (mk' N) (λ m hm, quotient_group.eq.mpr (by simpa [← h] using M.inv_mem hm))),
  inv_fun := (lift N (mk' M) (λ n hn, quotient_group.eq.mpr (by simpa [← h] using N.inv_mem hn))),
  left_inv := λ x, x.induction_on' $ by { intro, refl },
  right_inv := λ x, x.induction_on' $ by { intro, refl },
  map_mul' := λ x y, by rw monoid_hom.map_mul }

@[simp, to_additive]
lemma equiv_quotient_of_eq_mk {M N : subgroup G} [M.normal] [N.normal] (h : M = N) (x : G) :
  quotient_group.equiv_quotient_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) $
  by simp [subgroup.subgroup_of, subgroup.comap_comap]; exact 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 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 ⧸ ((H ⊓ N).comap H.subtype) ≃* _ ⧸ (N.comap (H ⊔ N).subtype) :=
/- φ is the natural homomorphism H →* (HN)/N. -/
let φ : H →* _ ⧸ (N.comap (H ⊔ N).subtype) :=
  (mk' $ N.comap (H ⊔ N).subtype).comp (inclusion le_sup_left) in
have φ_surjective : function.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 h⁻¹ * (h * n) ∈ N,
    rwa [←mul_assoc, inv_mul_self, one_mul],
  end,
(equiv_quotient_of_eq (by simp [comap_comap, ←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 quotient_add_group.map_normal]
instance map_normal : (M.map (quotient_group.mk' N)).normal :=
{ conj_mem := begin
    rintro _ ⟨x, hx, rfl⟩ y,
    refine induction_on' y (λ y, ⟨y * x * y⁻¹, subgroup.normal.conj_mem nM x hx y, _⟩),
    simp only [mk'_apply, coe_mul, coe_inv]
  end }

variables (h : N ≤ M)

/-- The map from the third isomorphism theorem for groups: `(G / N) / (M / N) → G / M`. -/
@[to_additive quotient_add_group.quotient_quotient_equiv_quotient_aux
"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 quotient_add_group.quotient_quotient_equiv_quotient_aux_coe]
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 quotient_add_group.quotient_quotient_equiv_quotient_aux_coe_coe]
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 quotient_add_group.quotient_quotient_equiv_quotient
"**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)) :=
trunc.subsingleton

/-- If the quotient by a subgroup gives a singleton then the subgroup is the whole group. -/
@[to_additive] 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 [one_inv, one_mul] at this

end trivial

end quotient_group


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

This file sets up a version of the Euclidean algorithm that works
only with natural numbers.  Given a, b > 0, it computes the unique
system (w, x, y, z, d) such that the following identities hold:

 w * z = x * y + 1
 a = (w + x) d
 b = (y + z) d

These equations force w, z, d > 0.  They also imply that
the integers a' = w + x = a / d and b' = y + z = b / d are coprime,
and that d is the gcd of a and b.

This story is closely related to the structure of SL₂(ℕ) (as a
free monoid on two generators) and the theory of continued fractions.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.ring
import Mathlib.tactic.abel
import Mathlib.data.pnat.prime
import Mathlib.PostPort

universes l

namespace Mathlib

namespace pnat

/-- A term of xgcd_type is a system of six naturals.  They should
 be thought of as representing the matrix
 [[w, x], [y, z]] = [[wp + 1, x], [y, zp + 1]]
 together with the vector [a, b] = [ap + 1, bp + 1].
-/
structure xgcd_type
where
  wp : ℕ
  x : ℕ
  y : ℕ
  zp : ℕ
  ap : ℕ
  bp : ℕ

namespace xgcd_type

protected instance has_sizeof : SizeOf xgcd_type :=
  { sizeOf := fun (u : xgcd_type) => bp u }

/-- The has_repr instance converts terms to strings in a way that
 reflects the matrix/vector interpretation as above. -/
protected instance has_repr : has_repr xgcd_type := sorry

def mk' (w : ℕ+) (x : ℕ) (y : ℕ) (z : ℕ+) (a : ℕ+) (b : ℕ+) : xgcd_type :=
  mk (Nat.pred (subtype.val w)) x y (Nat.pred (subtype.val z)) (Nat.pred (subtype.val a)) (Nat.pred (subtype.val b))

def w (u : xgcd_type) : ℕ+ :=
  nat.succ_pnat (wp u)

def z (u : xgcd_type) : ℕ+ :=
  nat.succ_pnat (zp u)

def a (u : xgcd_type) : ℕ+ :=
  nat.succ_pnat (ap u)

def b (u : xgcd_type) : ℕ+ :=
  nat.succ_pnat (bp u)

def r (u : xgcd_type) : ℕ :=
  (ap u + 1) % (bp u + 1)

def q (u : xgcd_type) : ℕ :=
  (ap u + 1) / (bp u + 1)

def qp (u : xgcd_type) : ℕ :=
  q u - 1

/-- The map v gives the product of the matrix
 [[w, x], [y, z]] = [[wp + 1, x], [y, zp + 1]]
 and the vector [a, b] = [ap + 1, bp + 1].  The map
 vp gives [sp, tp] such that v = [sp + 1, tp + 1].
-/
def vp (u : xgcd_type) : ℕ × ℕ :=
  (wp u + x u + ap u + wp u * ap u + x u * bp u, y u + zp u + bp u + y u * ap u + zp u * bp u)

def v (u : xgcd_type) : ℕ × ℕ :=
  (↑(w u) * ↑(a u) + x u * ↑(b u), y u * ↑(a u) + ↑(z u) * ↑(b u))

def succ₂ (t : ℕ × ℕ) : ℕ × ℕ :=
  (Nat.succ (prod.fst t), Nat.succ (prod.snd t))

theorem v_eq_succ_vp (u : xgcd_type) : v u = succ₂ (vp u) := sorry

/-- is_special holds if the matrix has determinant one. -/
def is_special (u : xgcd_type) :=
  wp u + zp u + wp u * zp u = x u * y u

def is_special' (u : xgcd_type) :=
  w u * z u = nat.succ_pnat (x u * y u)

theorem is_special_iff (u : xgcd_type) : is_special u ↔ is_special' u := sorry

/-- is_reduced holds if the two entries in the vector are the
 same.  The reduction algorithm will produce a system with this
 property, whose product vector is the same as for the original
 system. -/
def is_reduced (u : xgcd_type) :=
  ap u = bp u

def is_reduced' (u : xgcd_type) :=
  a u = b u

theorem is_reduced_iff (u : xgcd_type) : is_reduced u ↔ is_reduced' u :=
  { mp := congr_arg nat.succ_pnat, mpr := nat.succ_pnat_inj }

def flip (u : xgcd_type) : xgcd_type :=
  mk (zp u) (y u) (x u) (wp u) (bp u) (ap u)

@[simp] theorem flip_w (u : xgcd_type) : w (flip u) = z u :=
  rfl

@[simp] theorem flip_x (u : xgcd_type) : x (flip u) = y u :=
  rfl

@[simp] theorem flip_y (u : xgcd_type) : y (flip u) = x u :=
  rfl

@[simp] theorem flip_z (u : xgcd_type) : z (flip u) = w u :=
  rfl

@[simp] theorem flip_a (u : xgcd_type) : a (flip u) = b u :=
  rfl

@[simp] theorem flip_b (u : xgcd_type) : b (flip u) = a u :=
  rfl

theorem flip_is_reduced (u : xgcd_type) : is_reduced (flip u) ↔ is_reduced u :=
  id { mp := fun (h : bp u = ap u) => Eq.symm h, mpr := fun (h : ap u = bp u) => Eq.symm h }

theorem flip_is_special (u : xgcd_type) : is_special (flip u) ↔ is_special u := sorry

theorem flip_v (u : xgcd_type) : v (flip u) = prod.swap (v u) := sorry

/-- Properties of division with remainder for a / b.  -/
theorem rq_eq (u : xgcd_type) : r u + (bp u + 1) * q u = ap u + 1 :=
  nat.mod_add_div (ap u + 1) (bp u + 1)

theorem qp_eq (u : xgcd_type) (hr : r u = 0) : q u = qp u + 1 := sorry

/-- The following function provides the starting point for
 our algorithm.  We will apply an iterative reduction process
 to it, which will produce a system satisfying is_reduced.
 The gcd can be read off from this final system.
-/
def start (a : ℕ+) (b : ℕ+) : xgcd_type :=
  mk 0 0 0 0 (↑a - 1) (↑b - 1)

theorem start_is_special (a : ℕ+) (b : ℕ+) : is_special (start a b) :=
  id (Eq.refl (0 + 0 + 0 * 0))

theorem start_v (a : ℕ+) (b : ℕ+) : v (start a b) = (↑a, ↑b) := sorry

def finish (u : xgcd_type) : xgcd_type :=
  mk (wp u) ((wp u + 1) * qp u + x u) (y u) (y u * qp u + zp u) (bp u) (bp u)

theorem finish_is_reduced (u : xgcd_type) : is_reduced (finish u) :=
  id (Eq.refl (ap (finish u)))

theorem finish_is_special (u : xgcd_type) (hs : is_special u) : is_special (finish u) := sorry

theorem finish_v (u : xgcd_type) (hr : r u = 0) : v (finish u) = v u := sorry

/-- This is the main reduction step, which is used when u.r ≠ 0, or
 equivalently b does not divide a. -/
def step (u : xgcd_type) : xgcd_type :=
  mk (y u * q u + zp u) (y u) ((wp u + 1) * q u + x u) (wp u) (bp u) (r u - 1)

/-- We will apply the above step recursively.  The following result
 is used to ensure that the process terminates. -/
theorem step_wf (u : xgcd_type) (hr : r u ≠ 0) : sizeof (step u) < sizeof u := sorry

theorem step_is_special (u : xgcd_type) (hs : is_special u) : is_special (step u) := sorry

/-- The reduction step does not change the product vector. -/
theorem step_v (u : xgcd_type) (hr : r u ≠ 0) : v (step u) = prod.swap (v u) := sorry

/-- We can now define the full reduction function, which applies
 step as long as possible, and then applies finish. Note that the
 "have" statement puts a fact in the local context, and the
 equation compiler uses this fact to help construct the full
 definition in terms of well-founded recursion.  The same fact
 needs to be introduced in all the inductive proofs of properties
 given below. -/
def reduce : xgcd_type → xgcd_type :=
  sorry

theorem reduce_a {u : xgcd_type} (h : r u = 0) : reduce u = finish u := sorry

theorem reduce_b {u : xgcd_type} (h : r u ≠ 0) : reduce u = flip (reduce (step u)) := sorry

theorem reduce_reduced (u : xgcd_type) : is_reduced (reduce u) := sorry

theorem reduce_reduced' (u : xgcd_type) : is_reduced' (reduce u) :=
  iff.mp (is_reduced_iff (reduce u)) (reduce_reduced u)

theorem reduce_special (u : xgcd_type) : is_special u → is_special (reduce u) := sorry

theorem reduce_special' (u : xgcd_type) (hs : is_special u) : is_special' (reduce u) :=
  iff.mp (is_special_iff (reduce u)) (reduce_special u hs)

theorem reduce_v (u : xgcd_type) : v (reduce u) = v u := sorry

end xgcd_type

def xgcd (a : ℕ+) (b : ℕ+) : xgcd_type :=
  xgcd_type.reduce (xgcd_type.start a b)

def gcd_d (a : ℕ+) (b : ℕ+) : ℕ+ :=
  xgcd_type.a (xgcd a b)

def gcd_w (a : ℕ+) (b : ℕ+) : ℕ+ :=
  xgcd_type.w (xgcd a b)

def gcd_x (a : ℕ+) (b : ℕ+) : ℕ :=
  xgcd_type.x (xgcd a b)

def gcd_y (a : ℕ+) (b : ℕ+) : ℕ :=
  xgcd_type.y (xgcd a b)

def gcd_z (a : ℕ+) (b : ℕ+) : ℕ+ :=
  xgcd_type.z (xgcd a b)

def gcd_a' (a : ℕ+) (b : ℕ+) : ℕ+ :=
  nat.succ_pnat (xgcd_type.wp (xgcd a b) + xgcd_type.x (xgcd a b))

def gcd_b' (a : ℕ+) (b : ℕ+) : ℕ+ :=
  nat.succ_pnat (xgcd_type.y (xgcd a b) + xgcd_type.zp (xgcd a b))

theorem gcd_a'_coe (a : ℕ+) (b : ℕ+) : ↑(gcd_a' a b) = ↑(gcd_w a b) + gcd_x a b := sorry

theorem gcd_b'_coe (a : ℕ+) (b : ℕ+) : ↑(gcd_b' a b) = gcd_y a b + ↑(gcd_z a b) := sorry

theorem gcd_props (a : ℕ+) (b : ℕ+) : let d : ℕ+ := gcd_d a b;
let w : ℕ+ := gcd_w a b;
let x : ℕ := gcd_x a b;
let y : ℕ := gcd_y a b;
let z : ℕ+ := gcd_z a b;
let a' : ℕ+ := gcd_a' a b;
let b' : ℕ+ := gcd_b' a b;
w * z = nat.succ_pnat (x * y) ∧
  a = a' * d ∧
    b = b' * d ∧
      z * a' = nat.succ_pnat (x * ↑b') ∧
        w * b' = nat.succ_pnat (y * ↑a') ∧ ↑z * ↑a = x * ↑b + ↑d ∧ ↑w * ↑b = y * ↑a + ↑d := sorry

theorem gcd_eq (a : ℕ+) (b : ℕ+) : gcd_d a b = gcd a b := sorry

theorem gcd_det_eq (a : ℕ+) (b : ℕ+) : gcd_w a b * gcd_z a b = nat.succ_pnat (gcd_x a b * gcd_y a b) :=
  and.left (gcd_props a b)

theorem gcd_a_eq (a : ℕ+) (b : ℕ+) : a = gcd_a' a b * gcd a b :=
  gcd_eq a b ▸ and.left (and.right (gcd_props a b))

theorem gcd_b_eq (a : ℕ+) (b : ℕ+) : b = gcd_b' a b * gcd a b :=
  gcd_eq a b ▸ and.left (and.right (and.right (gcd_props a b)))

theorem gcd_rel_left' (a : ℕ+) (b : ℕ+) : gcd_z a b * gcd_a' a b = nat.succ_pnat (gcd_x a b * ↑(gcd_b' a b)) :=
  and.left (and.right (and.right (and.right (gcd_props a b))))

theorem gcd_rel_right' (a : ℕ+) (b : ℕ+) : gcd_w a b * gcd_b' a b = nat.succ_pnat (gcd_y a b * ↑(gcd_a' a b)) :=
  and.left (and.right (and.right (and.right (and.right (gcd_props a b)))))

theorem gcd_rel_left (a : ℕ+) (b : ℕ+) : ↑(gcd_z a b) * ↑a = gcd_x a b * ↑b + ↑(gcd a b) :=
  gcd_eq a b ▸ and.left (and.right (and.right (and.right (and.right (and.right (gcd_props a b))))))

theorem gcd_rel_right (a : ℕ+) (b : ℕ+) : ↑(gcd_w a b) * ↑b = gcd_y a b * ↑a + ↑(gcd a b) :=
  gcd_eq a b ▸ and.right (and.right (and.right (and.right (and.right (and.right (gcd_props a b))))))


/-!
# The Well-Typed Interpreter

In this example, we build an interpreter for a simple functional programming language,
with variables, function application, binary operators and an `if...then...else` construct.
We will use the dependent type system to ensure that any programs which can be represented are well-typed.

Remark: this example is based on an example found in the Idris manual.
-/

/-!
Vectors
--------

A `Vector` is a list of size `n` whose elements belong to a type `α`.
-/

inductive Vector (α : Type u) : Nat → Type u
  | nil : Vector α 0
  | cons : α → Vector α n → Vector α (n+1)

/-!
We can overload the `List.cons` notation `::` and use it to create `Vector`s.
-/
infix:67 " :: " => Vector.cons

/-!
Now, we define the types of our simple functional language.
We have integers, booleans, and functions, represented by `Ty`.
-/
inductive Ty where
  | int
  | bool
  | fn (a r : Ty)

/-!
We can write a function to translate `Ty` values to a Lean type
— remember that types are first class, so can be calculated just like any other value.
We mark `Ty.interp` as `[reducible]` to make sure the typeclass resolution procedure can
unfold/reduce it. For example, suppose Lean is trying to synthesize a value for the instance
`Add (Ty.interp Ty.int)`. Since `Ty.interp` is marked as `[reducible]`,
the typeclass resolution procedure can reduce `Ty.interp Ty.int` to `Int`, and use
the builtin instance for `Add Int` as the solution.
-/
@[reducible] def Ty.interp : Ty → Type
  | int    => Int
  | bool   => Bool
  | fn a r => a.interp → r.interp

/-!
Expressions are indexed by the types of the local variables, and the type of the expression itself.
-/
inductive HasType : Fin n → Vector Ty n → Ty → Type where
  | stop : HasType 0 (ty :: ctx) ty
  | pop  : HasType k ctx ty → HasType k.succ (u :: ctx) ty

inductive Expr : Vector Ty n → Ty → Type where
  | var   : HasType i ctx ty → Expr ctx ty
  | val   : Int → Expr ctx Ty.int
  | lam   : Expr (a :: ctx) ty → Expr ctx (Ty.fn a ty)
  | app   : Expr ctx (Ty.fn a ty) → Expr ctx a → Expr ctx ty
  | op    : (a.interp → b.interp → c.interp) → Expr ctx a → Expr ctx b → Expr ctx c
  | ife   : Expr ctx Ty.bool → Expr ctx a → Expr ctx a → Expr ctx a
  | delay : (Unit → Expr ctx a) → Expr ctx a

/-!
We use the command `open` to create the aliases `stop` and `pop` for `HasType.stop` and `HasType.pop` respectively.
-/
open HasType (stop pop)

/-!
Since expressions are indexed by their type, we can read the typing rules of the language from the definitions of the constructors.
Let us look at each constructor in turn.

We use a nameless representation for variables — they are de Bruijn indexed.
Variables are represented by a proof of their membership in the context, `HasType i ctx ty`,
which is a proof that variable `i` in context `ctx` has type `ty`.

We can treat `stop` as a proof that the most recently defined variable is well-typed,
and `pop n` as a proof that, if the `n`th most recently defined variable is well-typed, so is the `n+1`th.
In practice, this means we use `stop` to refer to the most recently defined variable,
`pop stop` to refer to the next, and so on, via the `Expr.var` constructor.

A value `Expr.val` carries a concrete representation of an integer.

A lambda `Expr.lam` creates a function. In the scope of a function ot type `Ty.fn a ty`, there is a
new local variable of type `a`.

A function application `Expr.app` produces a value of type `ty` given a function from `a` to `ty` and a value of type `a`.

The constructor `Expr.op` allows us to use arbitrary binary operators, where the type of the operator informs what the types of the arguments must be.

Finally, the constructor `Exp.ife` represents a `if-then-else` expression. The condition is a Boolean, and each branch must have the same type.

The auxiliary constructor `Expr.delay` is used to delay evaluation.
-/

/-!
When we evaluate an `Expr`, we’ll need to know the values in scope, as well as their types. `Env` is an environment,
indexed over the types in scope. Since an environment is just another form of list, albeit with a strongly specified connection
to the vector of local variable types, we overload again the notation `::` so that we can use the usual list syntax.
Given a proof that a variable is defined in the context, we can then produce a value from the environment.
-/
inductive Env : Vector Ty n → Type where
  | nil  : Env Vector.nil
  | cons : Ty.interp a → Env ctx → Env (a :: ctx)

infix:67 " :: " => Env.cons

def Env.lookup : HasType i ctx ty → Env ctx → ty.interp
  | stop,  x :: xs => x
  | pop k, x :: xs => lookup k xs

/-!
Given this, an interpreter is a function which translates an `Expr` into a Lean value with respect to a specific environment.
-/
def Expr.interp (env : Env ctx) : Expr ctx ty → ty.interp
  | var i     => env.lookup i
  | val x     => x
  | lam b     => fun x => b.interp (Env.cons x env)
  | app f a   => f.interp env (a.interp env)
  | op o x y  => o (x.interp env) (y.interp env)
  | ife c t e => if c.interp env then t.interp env else e.interp env
  | delay a   => (a ()).interp env

open Expr

/-!
We can make some simple test functions. Firstly, adding two inputs `fun x y => y + x` is written as follows.
-/

def add : Expr ctx (Ty.fn Ty.int (Ty.fn Ty.int Ty.int)) :=
  lam (lam (op (·+·) (var stop) (var (pop stop))))

#eval add.interp Env.nil 10 20

/-!
More interestingly, a factorial function fact (e.g. `fun x => if (x == 0) then 1 else (fact (x-1) * x)`), can be written as.
Note that this is a recursive (non-terminating) definition. For every input value, the interpreter terminates, but the
definition itself is non-terminating. We use two tricks to make sure Lean accepts it. First, we use the auxiliary constructor
`Expr.delay` to delay its unfolding. Second, we add the annotation `decreasing_by sorry` which can be viwed as
"trust me, this recursive definition makes sense". Recall that `sorry` is an unsound axiom in Lean.
-/

def fact : Expr ctx (Ty.fn Ty.int Ty.int) :=
  lam (ife (op (·==·) (var stop) (val 0))
           (val 1)
           (op (·*·) (delay fun _ => app fact (op (·-·) (var stop) (val 1))) (var stop)))
  decreasing_by sorry

#eval fact.interp Env.nil 10


/-
Copyright (c) 2020 Ruben Van de Velde. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.

! This file was ported from Lean 3 source module main
-/
import Mathlib.Data.Int.Parity
import Mathlib.RingTheory.Int.Basic
import Mathlib.RingTheory.Prime

/-- Being equal to `4` or odd. -/
def OddPrimeOrFour (z : ℤ) : Prop :=
  z = 4 ∨ Prime z ∧ Odd z
#align odd_prime_or_four OddPrimeOrFour

theorem OddPrimeOrFour.ne_zero {z : ℤ} (h : OddPrimeOrFour z) : z ≠ 0 :=
  by
  obtain rfl | ⟨h, -⟩ := h
  · norm_num
  · exact h.ne_zero
#align odd_prime_or_four.ne_zero OddPrimeOrFour.ne_zero

theorem OddPrimeOrFour.ne_one {z : ℤ} (h : OddPrimeOrFour z) : z ≠ 1 :=
  by
  obtain rfl | ⟨h, -⟩ := h
  · norm_num
  · exact h.ne_one
#align odd_prime_or_four.ne_one OddPrimeOrFour.ne_one

theorem OddPrimeOrFour.one_lt_abs {z : ℤ} (h : OddPrimeOrFour z) : 1 < abs z :=
  by
  obtain rfl | ⟨h, -⟩ := h
  · rw [Int.abs_eq_natAbs]
    norm_num
  · rw [Int.abs_eq_natAbs]
    rw [Int.prime_iff_natAbs_prime] at h
    norm_cast
    exact h.one_lt
#align odd_prime_or_four.one_lt_abs OddPrimeOrFour.one_lt_abs

theorem OddPrimeOrFour.not_unit {z : ℤ} (h : OddPrimeOrFour z) : ¬IsUnit z :=
  by
  obtain rfl | ⟨h, -⟩ := h
  · rw [isUnit_iff_dvd_one]
    norm_num
  · exact h.not_unit
#align odd_prime_or_four.not_unit OddPrimeOrFour.not_unit

theorem OddPrimeOrFour.abs {z : ℤ} (h : OddPrimeOrFour z) : OddPrimeOrFour (abs z) :=
  by
  obtain rfl | ⟨hp, ho⟩ := h
  · left
    rw [abs_eq_self]
    norm_num
  · right
    exact ⟨hp.abs, odd_abs.mpr ho⟩
#align odd_prime_or_four.abs OddPrimeOrFour.abs

theorem OddPrimeOrFour.exists_and_dvd {n : ℤ} (n2 : 2 < n) : ∃ p, p ∣ n ∧ OddPrimeOrFour p :=
  by
  lift n to ℕ using (zero_lt_two.trans n2).le
  norm_cast  at n2
  obtain ⟨k, rfl⟩ | ⟨p, hp, hdvd, hodd⟩ := n.eq_two_pow_or_exists_odd_prime_and_dvd
  · refine' ⟨4, ⟨2 ^ (k - 2), _⟩, Or.inl rfl⟩
    norm_cast
    calc
      2 ^ k = 2 ^ 2 * 2 ^ (k - 2) := (pow_mul_pow_sub _ ?_).symm
      _ = 4 * 2 ^ (k - 2) := by norm_num

    rcases k with (_ | _ | _)
    · exfalso
      norm_num at n2
    · exfalso
      exact lt_irrefl _ n2
    · exact le_add_self
  · rw [Nat.prime_iff_prime_int] at hp
    rw [← Int.odd_coe_nat] at hodd
    exact ⟨p, Int.coe_nat_dvd.mpr hdvd, Or.inr ⟨hp, hodd⟩⟩
#align odd_prime_or_four.exists_and_dvd OddPrimeOrFour.exists_and_dvd

theorem associated_of_dvd {a p : ℤ} (ha : OddPrimeOrFour a) (hp : OddPrimeOrFour p) (h : p ∣ a) :
    Associated p a :=
  by
  obtain rfl | ⟨ap, aodd⟩ := ha <;> obtain rfl | ⟨pp, podd⟩ := hp
  · rfl
  · exfalso
    have h0 : (4 : ℤ) = 2 ^ 2 := by norm_num
    rw [h0] at h
    refine' Int.even_iff_not_odd.mp _ podd
    rw [even_iff_two_dvd]
    apply Associated.dvd _
    exact ((pp.dvd_prime_iff_associated Int.prime_two).mp (pp.dvd_of_dvd_pow h)).symm
  · exfalso
    rw [Int.odd_iff_not_even] at aodd
    refine' aodd _
    rw [even_iff_two_dvd]
    refine' dvd_trans _ h
    norm_num
  · rwa [Prime.dvd_prime_iff_associated pp ap] at h
#align associated_of_dvd associated_of_dvd

theorem dvd_or_dvd {a p x : ℤ} (ha : OddPrimeOrFour a) (hp : OddPrimeOrFour p) (hdvd : p ∣ a * x) :
    p ∣ a ∨ p ∣ x := by
  obtain rfl | ⟨pp, -⟩ := hp
  · obtain rfl | ⟨ap, aodd⟩ := ha
    · exact Or.inl dvd_rfl
    · right
      have : (4 : ℤ) = 2 ^ 2 := by norm_num
      rw [this] at hdvd⊢
      apply Int.prime_two.pow_dvd_of_dvd_mul_left _ _ hdvd
      rwa [← even_iff_two_dvd, ← Int.odd_iff_not_even]
  · exact pp.dvd_or_dvd hdvd
#align dvd_or_dvd dvd_or_dvd

theorem exists_associated_mem_of_dvd_prod'' {p : ℤ} (hp : OddPrimeOrFour p) {s : Multiset ℤ}
    (hs : ∀ r ∈ s, OddPrimeOrFour r) (hdvd : p ∣ s.prod) : ∃ q ∈ s, Associated p q :=
  by
  induction' s using Multiset.induction_on with a s ih hs
  · simp [hp.not_unit, ← isUnit_iff_dvd_one] at hdvd
  · rw [Multiset.prod_cons] at hdvd
    have := hs a (Multiset.mem_cons_self _ _)
    obtain h | h := dvd_or_dvd this hp hdvd
    · exact ⟨a, Multiset.mem_cons_self _ _, associated_of_dvd this hp h⟩
    · obtain ⟨q, hq₁, hq₂⟩ := ih (fun r hr => hs _ (Multiset.mem_cons_of_mem hr)) h
      exact ⟨q, Multiset.mem_cons_of_mem hq₁, hq₂⟩
#align exists_associated_mem_of_dvd_prod'' exists_associated_mem_of_dvd_prod''

theorem factors_unique_prod' :
    ∀ {f g : Multiset ℤ},
      (∀ x ∈ f, OddPrimeOrFour x) →
        (∀ x ∈ g, OddPrimeOrFour x) → Associated f.prod g.prod → Multiset.Rel Associated f g :=
  by
  intro f
  induction' f using Multiset.induction_on with p f ih
  · rintro g - hg h
    rw [Multiset.prod_zero] at h
    rw [Multiset.rel_zero_left]
    apply Multiset.eq_zero_of_forall_not_mem
    intro x hx
    apply (hg x hx).not_unit
    rw [isUnit_iff_dvd_one]
    exact dvd_trans (Multiset.dvd_prod hx) h.symm.dvd
  · intro g hf hg hfg
    have hp := hf p (Multiset.mem_cons_self _ _)
    have hdvd : p ∣ g.prod :=
      by
      rw [← hfg.dvd_iff_dvd_right, Multiset.prod_cons]
      exact dvd_mul_right _ _
    obtain ⟨b, hbg, hb⟩ := exists_associated_mem_of_dvd_prod'' hp hg hdvd
    rw [← Multiset.cons_erase hbg]
    apply Multiset.Rel.cons hb
    apply ih _ _ _
    · exact fun q hq => hf _ (Multiset.mem_cons_of_mem hq)
    · exact fun q (hq : q ∈ g.erase b) => hg q (Multiset.mem_of_mem_erase hq)
    · apply Associated.of_mul_left _ hb hp.ne_zero
      rwa [← Multiset.prod_cons, ← Multiset.prod_cons, Multiset.cons_erase hbg]
#align factors_unique_prod' factors_unique_prod'

/-- The odd factors. -/
noncomputable def oddFactors (x : ℤ) :=
  Multiset.filter Odd (UniqueFactorizationMonoid.normalizedFactors x)
#align odd_factors oddFactors

theorem oddFactors.zero : oddFactors 0 = 0 :=
  rfl
#align odd_factors.zero oddFactors.zero

theorem oddFactors.not_two_mem (x : ℤ) : (2 : ℤ) ∉ oddFactors x := by
  simp only [oddFactors, even_bit0, not_true, not_false_iff, Int.odd_iff_not_even, and_false_iff,
    Multiset.mem_filter]
#align odd_factors.not_two_mem oddFactors.not_two_mem

theorem oddFactors.nonneg {z a : ℤ} (ha : a ∈ oddFactors z) : 0 ≤ a :=
  by
  simp only [oddFactors, Multiset.mem_filter] at ha
  exact
    Int.nonneg_of_normalize_eq_self (UniqueFactorizationMonoid.normalize_normalized_factor a ha.1)
#align odd_factors.nonneg oddFactors.nonneg

theorem oddFactors.pow (z : ℤ) (n : ℕ) : oddFactors (z ^ n) = n • oddFactors z :=
  by
  simp only [oddFactors]
  rw [UniqueFactorizationMonoid.normalizedFactors_pow, Multiset.filter_nsmul]
#align odd_factors.pow oddFactors.pow

/-- The exponent of `2` in the factorization. -/
noncomputable def evenFactorExp (x : ℤ) :=
  Multiset.count 2 (UniqueFactorizationMonoid.normalizedFactors x)
#align even_factor_exp evenFactorExp

theorem evenFactorExp.def (x : ℤ) :
    evenFactorExp x = Multiset.count 2 (UniqueFactorizationMonoid.normalizedFactors x) :=
  rfl
#align even_factor_exp.def evenFactorExp.def

theorem evenFactorExp.zero : evenFactorExp 0 = 0 :=
  rfl
#align even_factor_exp.zero evenFactorExp.zero

theorem evenFactorExp.pow (z : ℤ) (n : ℕ) : evenFactorExp (z ^ n) = n * evenFactorExp z :=
  by
  simp only [evenFactorExp]
  rw [UniqueFactorizationMonoid.normalizedFactors_pow, Multiset.count_nsmul]
#align even_factor_exp.pow evenFactorExp.pow

theorem even_and_odd_factors'' (x : ℤ) :
    UniqueFactorizationMonoid.normalizedFactors x =
      (UniqueFactorizationMonoid.normalizedFactors x).filter (Eq 2) + oddFactors x :=
  by
  by_cases hx : x = 0
  ·
    rw [hx, UniqueFactorizationMonoid.normalizedFactors_zero, oddFactors.zero, Multiset.filter_zero,
      add_zero]
  simp [evenFactorExp, oddFactors]
  rw [Multiset.filter_add_filter]
  convert (add_zero
    (Multiset.filter (fun a => 2 = a ∨ Odd a) (UniqueFactorizationMonoid.normalizedFactors x))).symm
  · symm
    rw [Multiset.filter_eq_self]
    intro a ha
    have hprime : Prime a := UniqueFactorizationMonoid.prime_of_normalized_factor a ha
    have := UniqueFactorizationMonoid.normalize_normalized_factor a ha
    rw [← Int.abs_eq_normalize, ← Int.coe_natAbs] at this
    rw [← this]
    rw [Int.prime_iff_natAbs_prime] at hprime
    rcases Nat.Prime.eq_two_or_odd' hprime with (h2 | hodd)
    · simp [h2]
    · right
      rw [this]
      exact Int.natAbs_odd.1 hodd
  · rw [Multiset.filter_eq_nil]
    rintro a ha ⟨rfl, hodd⟩
    norm_num at hodd
#align even_and_odd_factors'' even_and_odd_factors''

theorem even_and_odd_factors' (x : ℤ) :
    UniqueFactorizationMonoid.normalizedFactors x =
      Multiset.replicate (evenFactorExp x) 2 + oddFactors x :=
  by
  convert even_and_odd_factors'' x
  simp [evenFactorExp, ← Multiset.filter_eq]
#align even_and_odd_factors' even_and_odd_factors'

theorem even_and_oddFactors (x : ℤ) (hx : x ≠ 0) :
    Associated x (2 ^ evenFactorExp x * (oddFactors x).prod) :=
  by
  convert(UniqueFactorizationMonoid.normalizedFactors_prod hx).symm
  simp [evenFactorExp]
  rw [Multiset.pow_count, ← Multiset.prod_add, ← even_and_odd_factors'' x]
#align even_and_odd_factors even_and_oddFactors

theorem factors_2_even {z : ℤ} (hz : z ≠ 0) : evenFactorExp (4 * z) = 2 + evenFactorExp z :=
  by
  have h₀ : (4 : ℤ) ≠ 0 := four_ne_zero
  have h₁ : (2 : Int) ^ 2 = 4 := by norm_num
  simp [evenFactorExp]
  rw [UniqueFactorizationMonoid.normalizedFactors_mul h₀ hz, Multiset.count_add, ← h₁,
    UniqueFactorizationMonoid.normalizedFactors_pow, Multiset.count_nsmul,
    UniqueFactorizationMonoid.normalizedFactors_irreducible Int.prime_two.irreducible,
    Int.normalize_of_nonneg zero_le_two, Multiset.count_singleton_self, mul_one]
#align factors_2_even factors_2_even

-- most useful with  (hz : even (even_factor_exp z))
/-- Odd factors or `4`. -/
noncomputable def factorsOddPrimeOrFour (z : ℤ) : Multiset ℤ :=
  Multiset.replicate (evenFactorExp z / 2) 4 + oddFactors z
#align factors_odd_prime_or_four factorsOddPrimeOrFour

theorem factorsOddPrimeOrFour.nonneg {z a : ℤ} (ha : a ∈ factorsOddPrimeOrFour z) : 0 ≤ a :=
  by
  simp only [factorsOddPrimeOrFour, Multiset.mem_add] at ha
  cases ha with
  | inl ha =>
    rw [Multiset.eq_of_mem_replicate ha]
    norm_num
  | inr ha =>
    exact oddFactors.nonneg ha
#align factors_odd_prime_or_four.nonneg factorsOddPrimeOrFour.nonneg

theorem factorsOddPrimeOrFour.prod' {a : ℤ} (ha : 0 < a) (heven : Even (evenFactorExp a)) :
    (factorsOddPrimeOrFour a).prod = a :=
  by
  apply Int.eq_of_associated_of_nonneg
  · have := UniqueFactorizationMonoid.normalizedFactors_prod ha.ne'
    apply Associated.trans _ this
    obtain ⟨m, hm⟩ := even_iff_two_dvd.mp heven
    rw [even_and_odd_factors' _, Multiset.prod_add, factorsOddPrimeOrFour, Multiset.prod_add, hm,
      Nat.mul_div_right _ zero_lt_two, Multiset.prod_replicate, Multiset.prod_replicate, pow_mul]
    exact Associated.refl _
  · apply Multiset.prod_nonneg
    apply factorsOddPrimeOrFour.nonneg
  · exact ha.le
#align factors_odd_prime_or_four.prod' factorsOddPrimeOrFour.prod'

theorem factorsOddPrimeOrFour.associated' {a : ℤ} {f : Multiset ℤ} (hf : ∀ x ∈ f, OddPrimeOrFour x)
    (ha : 0 < a) (heven : Even (evenFactorExp a)) (hassoc : Associated f.prod a) :
    Multiset.Rel Associated f (factorsOddPrimeOrFour a) :=
  by
  apply factors_unique_prod' hf
  · intro x hx
    simp only [factorsOddPrimeOrFour, Multiset.mem_add] at hx
    apply Or.imp _ _ hx
    · exact Multiset.eq_of_mem_replicate
    · simp only [oddFactors, Multiset.mem_filter]
      exact And.imp_left (UniqueFactorizationMonoid.prime_of_normalized_factor _)
  · rwa [factorsOddPrimeOrFour.prod' ha heven]
#align factors_odd_prime_or_four.associated' factorsOddPrimeOrFour.associated'

theorem factorsOddPrimeOrFour.unique' {a : ℤ} {f : Multiset ℤ} (hf : ∀ x ∈ f, OddPrimeOrFour x)
    (hf' : ∀ x ∈ f, (0 : ℤ) ≤ x) (ha : 0 < a) (heven : Even (evenFactorExp a))
    (hassoc : Associated f.prod a) : f = factorsOddPrimeOrFour a :=
  by
  rw [← Multiset.rel_eq]
  apply Multiset.Rel.mono (factorsOddPrimeOrFour.associated' hf ha heven hassoc)
  intro x hx y hy hxy
  exact Int.eq_of_associated_of_nonneg hxy (hf' x hx) (factorsOddPrimeOrFour.nonneg hy)
#align factors_odd_prime_or_four.unique' factorsOddPrimeOrFour.unique'

theorem factorsOddPrimeOrFour.pow (z : ℤ) (n : ℕ) (hz : Even (evenFactorExp z)) :
    factorsOddPrimeOrFour (z ^ n) = n • factorsOddPrimeOrFour z := by
  simp only [factorsOddPrimeOrFour, nsmul_add, Multiset.nsmul_replicate, evenFactorExp.pow,
    Nat.mul_div_assoc _ (even_iff_two_dvd.mp hz), oddFactors.pow]
#align factors_odd_prime_or_four.pow factorsOddPrimeOrFour.pow


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import data.list.sort
import data.multiset.basic
import data.string.basic

/-!
# Construct a sorted list from a multiset.
-/

namespace multiset
open list
variables {α : Type*}

section sort
variables (r : α → α → Prop) [decidable_rel r]
  [is_trans α r] [is_antisymm α r] [is_total α r]

/-- `sort s` constructs a sorted list from the multiset `s`.
  (Uses merge sort algorithm.) -/
def sort (s : multiset α) : list α :=
quot.lift_on s (merge_sort r) $ λ a b h,
eq_of_perm_of_sorted
  ((perm_merge_sort _ _).trans $ h.trans (perm_merge_sort _ _).symm)
  (sorted_merge_sort r _)
  (sorted_merge_sort r _)

@[simp] theorem coe_sort (l : list α) : sort r l = merge_sort r l := rfl

@[simp] theorem sort_sorted (s : multiset α) : sorted r (sort r s) :=
quot.induction_on s $ λ l, sorted_merge_sort r _

@[simp]

@[simp] theorem mem_sort {s : multiset α} {a : α} : a ∈ sort r s ↔ a ∈ s :=
by rw [← mem_coe, sort_eq]

@[simp] theorem length_sort {s : multiset α} : (sort r s).length = s.card :=
quot.induction_on s $ length_merge_sort _

@[simp] theorem sort_zero : sort r 0 = [] :=
list.merge_sort_nil r

@[simp] theorem sort_singleton (a : α) : sort r {a} = [a] :=
list.merge_sort_singleton r a

end sort

instance [has_repr α] : has_repr (multiset α) :=
⟨λ s, "{" ++ string.intercalate ", " ((s.map repr).sort (≤)) ++ "}"⟩

end multiset