/-
Copyright (c) 2019 Kevin Kappelmann. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kevin Kappelmann
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.continued_fractions.translations
import Mathlib.PostPort

universes u_1

namespace Mathlib

/-!
# Recurrence Lemmas for the `continuants` Function of Continued Fractions.

## Summary

Given a generalized continued fraction `g`, for all `n ≥ 1`, we prove that the `continuants`
function indeed satisfies the following recurrences:
- `Aₙ = bₙ * Aₙ₋₁ + aₙ * Aₙ₋₂`, and
- `Bₙ = bₙ * Bₙ₋₁ + aₙ * Bₙ₋₂`.
-/

namespace generalized_continued_fraction

theorem continuants_aux_recurrence {K : Type u_1} {g : generalized_continued_fraction K} {n : ℕ}
    [division_ring K] {gp : pair K} {ppred : pair K} {pred : pair K}
    (nth_s_eq : seq.nth (s g) n = some gp) (nth_conts_aux_eq : continuants_aux g n = ppred)
    (succ_nth_conts_aux_eq : continuants_aux g (n + 1) = pred) :
    continuants_aux g (n + bit0 1) =
        pair.mk (pair.b gp * pair.a pred + pair.a gp * pair.a ppred)
          (pair.b gp * pair.b pred + pair.a gp * pair.b ppred) :=
  sorry

theorem continuants_recurrence_aux {K : Type u_1} {g : generalized_continued_fraction K} {n : ℕ}
    [division_ring K] {gp : pair K} {ppred : pair K} {pred : pair K}
    (nth_s_eq : seq.nth (s g) n = some gp) (nth_conts_aux_eq : continuants_aux g n = ppred)
    (succ_nth_conts_aux_eq : continuants_aux g (n + 1) = pred) :
    continuants g (n + 1) =
        pair.mk (pair.b gp * pair.a pred + pair.a gp * pair.a ppred)
          (pair.b gp * pair.b pred + pair.a gp * pair.b ppred) :=
  sorry

/-- Shows that `Aₙ = bₙ * Aₙ₋₁ + aₙ * Aₙ₋₂` and `Bₙ = bₙ * Bₙ₋₁ + aₙ * Bₙ₋₂`. -/
theorem continuants_recurrence {K : Type u_1} {g : generalized_continued_fraction K} {n : ℕ}
    [division_ring K] {gp : pair K} {ppred : pair K} {pred : pair K}
    (succ_nth_s_eq : seq.nth (s g) (n + 1) = some gp) (nth_conts_eq : continuants g n = ppred)
    (succ_nth_conts_eq : continuants g (n + 1) = pred) :
    continuants g (n + bit0 1) =
        pair.mk (pair.b gp * pair.a pred + pair.a gp * pair.a ppred)
          (pair.b gp * pair.b pred + pair.a gp * pair.b ppred) :=
  continuants_recurrence_aux succ_nth_s_eq
    (eq.mp (Eq._oldrec (Eq.refl (continuants g n = ppred)) nth_cont_eq_succ_nth_cont_aux)
      nth_conts_eq)
    (eq.mp (Eq._oldrec (Eq.refl (continuants g (n + 1) = pred)) nth_cont_eq_succ_nth_cont_aux)
      succ_nth_conts_eq)

/-- Shows that `Aₙ = bₙ * Aₙ₋₁ + aₙ * Aₙ₋₂`. -/
theorem numerators_recurrence {K : Type u_1} {g : generalized_continued_fraction K} {n : ℕ}
    [division_ring K] {gp : pair K} {ppredA : K} {predA : K}
    (succ_nth_s_eq : seq.nth (s g) (n + 1) = some gp) (nth_num_eq : numerators g n = ppredA)
    (succ_nth_num_eq : numerators g (n + 1) = predA) :
    numerators g (n + bit0 1) = pair.b gp * predA + pair.a gp * ppredA :=
  sorry

/-- Shows that `Bₙ = bₙ * Bₙ₋₁ + aₙ * Bₙ₋₂`. -/
theorem denominators_recurrence {K : Type u_1} {g : generalized_continued_fraction K} {n : ℕ}
    [division_ring K] {gp : pair K} {ppredB : K} {predB : K}
    (succ_nth_s_eq : seq.nth (s g) (n + 1) = some gp) (nth_denom_eq : denominators g n = ppredB)
    (succ_nth_denom_eq : denominators g (n + 1) = predB) :
    denominators g (n + bit0 1) = pair.b gp * predB + pair.a gp * ppredB :=
  sorry

end Mathlib


/-
Copyright (c) 2019 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Fabian Glöckle
-/
import linear_algebra.finite_dimensional
import linear_algebra.projection

/-!
# Dual vector spaces

The dual space of an R-module M is the R-module of linear maps `M → R`.

## Main definitions

* `dual R M` defines the dual space of M over R.
* Given a basis for an `R`-module `M`, `basis.to_dual` produces a map from `M` to `dual R M`.
* Given families of vectors `e` and `ε`, `dual_pair e ε` states that these families have the
  characteristic properties of a basis and a dual.
* `dual_annihilator W` is the submodule of `dual R M` where every element annihilates `W`.

## Main results

* `to_dual_equiv` : the linear equivalence between the dual module and primal module,
  given a finite basis.
* `dual_pair.basis` and `dual_pair.eq_dual`: if `e` and `ε` form a dual pair, `e` is a basis and
  `ε` is its dual basis.
* `quot_equiv_annihilator`: the quotient by a subspace is isomorphic to its dual annihilator.

## Notation

We sometimes use `V'` as local notation for `dual K V`.

## TODO

Erdös-Kaplansky theorem about the dimension of a dual vector space in case of infinite dimension.
-/

noncomputable theory

namespace module

variables (R : Type*) (M : Type*)
variables [comm_semiring R] [add_comm_monoid M] [module R M]

/-- The dual space of an R-module M is the R-module of linear maps `M → R`. -/
@[derive [add_comm_monoid, module R]] def dual := M →ₗ[R] R

instance {S : Type*} [comm_ring S] {N : Type*} [add_comm_group N] [module S N] :
  add_comm_group (dual S N) := by {unfold dual, apply_instance}

namespace dual

instance : inhabited (dual R M) := by dunfold dual; apply_instance

instance : has_coe_to_fun (dual R M) (λ _, M → R) := ⟨linear_map.to_fun⟩

/-- Maps a module M to the dual of the dual of M. See `module.erange_coe` and
`module.eval_equiv`. -/
def eval : M →ₗ[R] (dual R (dual R M)) := linear_map.flip linear_map.id

@[simp] lemma eval_apply (v : M) (a : dual R M) : eval R M v a = a v :=
begin
  dunfold eval,
  rw [linear_map.flip_apply, linear_map.id_apply]
end

variables {R M} {M' : Type*} [add_comm_monoid M'] [module R M']

/-- The transposition of linear maps, as a linear map from `M →ₗ[R] M'` to
`dual R M' →ₗ[R] dual R M`. -/
def transpose : (M →ₗ[R] M') →ₗ[R] (dual R M' →ₗ[R] dual R M) :=
(linear_map.llcomp R M M' R).flip

lemma transpose_apply (u : M →ₗ[R] M') (l : dual R M') : transpose u l = l.comp u := rfl

variables {M'' : Type*} [add_comm_monoid M''] [module R M'']

lemma transpose_comp (u : M' →ₗ[R] M'') (v : M →ₗ[R] M') :
  transpose (u.comp v) = (transpose v).comp (transpose u) := rfl

end dual

end module

namespace basis

universes u v w

open module module.dual submodule linear_map cardinal function

variables {R M K V ι : Type*}

section comm_semiring

variables [comm_semiring R] [add_comm_monoid M] [module R M] [decidable_eq ι]
variables (b : basis ι R M)

/-- The linear map from a vector space equipped with basis to its dual vector space,
taking basis elements to corresponding dual basis elements. -/
def to_dual : M →ₗ[R] module.dual R M :=
b.constr ℕ $ λ v, b.constr ℕ $ λ w, if w = v then (1 : R) else 0

lemma to_dual_apply (i j : ι) :
  b.to_dual (b i) (b j) = if i = j then 1 else 0 :=
by { erw [constr_basis b, constr_basis b], ac_refl }

@[simp] lemma to_dual_total_left (f : ι →₀ R) (i : ι) :
  b.to_dual (finsupp.total ι M R b f) (b i) = f i :=
begin
  rw [finsupp.total_apply, finsupp.sum, linear_map.map_sum, linear_map.sum_apply],
  simp_rw [linear_map.map_smul, linear_map.smul_apply, to_dual_apply, smul_eq_mul,
           mul_boole, finset.sum_ite_eq'],
  split_ifs with h,
  { refl },
  { rw finsupp.not_mem_support_iff.mp h }
end

@[simp] lemma to_dual_total_right (f : ι →₀ R) (i : ι) :
  b.to_dual (b i) (finsupp.total ι M R b f) = f i :=
begin
  rw [finsupp.total_apply, finsupp.sum, linear_map.map_sum],
  simp_rw [linear_map.map_smul, to_dual_apply, smul_eq_mul, mul_boole, finset.sum_ite_eq],
  split_ifs with h,
  { refl },
  { rw finsupp.not_mem_support_iff.mp h }
end

lemma to_dual_apply_left (m : M) (i : ι) : b.to_dual m (b i) = b.repr m i :=
by rw [← b.to_dual_total_left, b.total_repr]

lemma to_dual_apply_right (i : ι) (m : M) : b.to_dual (b i) m = b.repr m i :=
by rw [← b.to_dual_total_right, b.total_repr]

lemma coe_to_dual_self (i : ι) : b.to_dual (b i) = b.coord i :=
by { ext, apply to_dual_apply_right }

/-- `h.to_dual_flip v` is the linear map sending `w` to `h.to_dual w v`. -/
def to_dual_flip (m : M) : (M →ₗ[R] R) := b.to_dual.flip m

lemma to_dual_flip_apply (m₁ m₂ : M) : b.to_dual_flip m₁ m₂ = b.to_dual m₂ m₁ := rfl

lemma to_dual_eq_repr (m : M) (i : ι) : b.to_dual m (b i) = b.repr m i :=
b.to_dual_apply_left m i

lemma to_dual_eq_equiv_fun [fintype ι] (m : M) (i : ι) : b.to_dual m (b i) = b.equiv_fun m i :=
by rw [b.equiv_fun_apply, to_dual_eq_repr]

lemma to_dual_inj (m : M) (a : b.to_dual m = 0) : m = 0 :=
begin
  rw [← mem_bot R, ← b.repr.ker, mem_ker, linear_equiv.coe_coe],
  apply finsupp.ext,
  intro b,
  rw [← to_dual_eq_repr, a],
  refl
end

theorem to_dual_ker : b.to_dual.ker = ⊥ :=
ker_eq_bot'.mpr b.to_dual_inj

theorem to_dual_range [fin : fintype ι] : b.to_dual.range = ⊤ :=
begin
  rw eq_top_iff',
  intro f,
  rw linear_map.mem_range,
  let lin_comb : ι →₀ R := finsupp.on_finset fin.elems (λ i, f.to_fun (b i)) _,
  { use finsupp.total ι M R b lin_comb,
    apply b.ext,
    { intros i,
      rw [b.to_dual_eq_repr _ i, repr_total b],
      { refl } } },
  { intros a _,
    apply fin.complete }
end

end comm_semiring

section comm_ring

variables [comm_ring R] [add_comm_group M] [module R M] [decidable_eq ι]
variables (b : basis ι R M)

/-- A vector space is linearly equivalent to its dual space. -/
@[simps]
def to_dual_equiv [fintype ι] : M ≃ₗ[R] (dual R M) :=
linear_equiv.of_bijective b.to_dual
  (ker_eq_bot.mp b.to_dual_ker) (range_eq_top.mp b.to_dual_range)

/-- Maps a basis for `V` to a basis for the dual space. -/
def dual_basis [fintype ι] : basis ι R (dual R M) :=
b.map b.to_dual_equiv

-- We use `j = i` to match `basis.repr_self`
lemma dual_basis_apply_self [fintype ι] (i j : ι) :
  b.dual_basis i (b j) = if j = i then 1 else 0 :=
by { convert b.to_dual_apply i j using 2, rw @eq_comm _ j i }

lemma total_dual_basis [fintype ι] (f : ι →₀ R) (i : ι) :
  finsupp.total ι (dual R M) R b.dual_basis f (b i) = f i :=
begin
  rw [finsupp.total_apply, finsupp.sum_fintype, linear_map.sum_apply],
  { simp_rw [linear_map.smul_apply, smul_eq_mul, dual_basis_apply_self, mul_boole,
      finset.sum_ite_eq, if_pos (finset.mem_univ i)] },
  { intro, rw zero_smul },
end

lemma dual_basis_repr [fintype ι] (l : dual R M) (i : ι) :
  b.dual_basis.repr l i = l (b i) :=
by rw [← total_dual_basis b, basis.total_repr b.dual_basis l]

lemma dual_basis_equiv_fun [fintype ι] (l : dual R M) (i : ι) :
  b.dual_basis.equiv_fun l i = l (b i) :=
by rw [basis.equiv_fun_apply, dual_basis_repr]

lemma dual_basis_apply [fintype ι] (i : ι) (m : M) : b.dual_basis i m = b.repr m i :=
b.to_dual_apply_right i m

@[simp] lemma coe_dual_basis [fintype ι] :
  ⇑b.dual_basis = b.coord :=
by { ext i x, apply dual_basis_apply }

@[simp] lemma to_dual_to_dual [fintype ι] :
  b.dual_basis.to_dual.comp b.to_dual = dual.eval R M :=
begin
  refine b.ext (λ i, b.dual_basis.ext (λ j, _)),
  rw [linear_map.comp_apply, to_dual_apply_left, coe_to_dual_self, ← coe_dual_basis,
      dual.eval_apply, basis.repr_self, finsupp.single_apply, dual_basis_apply_self]
end

theorem eval_ker {ι : Type*} (b : basis ι R M) :
  (dual.eval R M).ker = ⊥ :=
begin
  rw ker_eq_bot',
  intros m hm,
  simp_rw [linear_map.ext_iff, dual.eval_apply, zero_apply] at hm,
  exact (basis.forall_coord_eq_zero_iff _).mp (λ i, hm (b.coord i))
end

lemma eval_range {ι : Type*} [fintype ι] (b : basis ι R M) :
  (eval R M).range = ⊤ :=
begin
  classical,
  rw [← b.to_dual_to_dual, range_comp, b.to_dual_range, map_top, to_dual_range _],
  apply_instance
end

/-- A module with a basis is linearly equivalent to the dual of its dual space. -/
def eval_equiv  {ι : Type*} [fintype ι] (b : basis ι R M) : M ≃ₗ[R] dual R (dual R M) :=
linear_equiv.of_bijective (eval R M)
  (ker_eq_bot.mp b.eval_ker) (range_eq_top.mp b.eval_range)

@[simp] lemma eval_equiv_to_linear_map {ι : Type*} [fintype ι] (b : basis ι R M) :
  (b.eval_equiv).to_linear_map = dual.eval R M := rfl

end comm_ring

/-- `simp` normal form version of `total_dual_basis` -/
@[simp] lemma total_coord [comm_ring R] [add_comm_group M] [module R M] [fintype ι]
  (b : basis ι R M) (f : ι →₀ R) (i : ι) :
  finsupp.total ι (dual R M) R b.coord f (b i) = f i :=
by { haveI := classical.dec_eq ι, rw [← coe_dual_basis, total_dual_basis] }

-- TODO(jmc): generalize to rings, once `module.rank` is generalized
theorem dual_dim_eq [field K] [add_comm_group V] [module K V] [fintype ι] (b : basis ι K V) :
  cardinal.lift (module.rank K V) = module.rank K (dual K V) :=
begin
  classical,
  have := linear_equiv.lift_dim_eq b.to_dual_equiv,
  simp only [cardinal.lift_umax] at this,
  rw [this, ← cardinal.lift_umax],
  apply cardinal.lift_id,
end

end basis

namespace module

variables {K V : Type*}
variables [field K] [add_comm_group V] [module K V]
open module module.dual submodule linear_map cardinal basis finite_dimensional

theorem eval_ker : (eval K V).ker = ⊥ :=
by { classical, exact (basis.of_vector_space K V).eval_ker }

-- TODO(jmc): generalize to rings, once `module.rank` is generalized
theorem dual_dim_eq [finite_dimensional K V] :
  cardinal.lift (module.rank K V) = module.rank K (dual K V) :=
(basis.of_vector_space K V).dual_dim_eq

lemma erange_coe [finite_dimensional K V] : (eval K V).range = ⊤ :=
begin
  letI : is_noetherian K V := is_noetherian.iff_fg.2 infer_instance,
  exact (basis.of_vector_space K V).eval_range
end

variables (K V)

/-- A vector space is linearly equivalent to the dual of its dual space. -/
def eval_equiv [finite_dimensional K V] : V ≃ₗ[K] dual K (dual K V) :=
linear_equiv.of_bijective (eval K V)
  (ker_eq_bot.mp eval_ker) (range_eq_top.mp erange_coe)

variables {K V}

@[simp] lemma eval_equiv_to_linear_map [finite_dimensional K V] :
  (eval_equiv K V).to_linear_map = dual.eval K V := rfl

end module

section dual_pair

open module

variables {R M ι : Type*}
variables [comm_ring R] [add_comm_group M] [module R M] [decidable_eq ι]

/-- `e` and `ε` have characteristic properties of a basis and its dual -/
@[nolint has_inhabited_instance]
structure dual_pair (e : ι → M) (ε : ι → (dual R M)) :=
(eval : ∀ i j : ι, ε i (e j) = if i = j then 1 else 0)
(total : ∀ {m : M}, (∀ i, ε i m = 0) → m = 0)
[finite : ∀ m : M, fintype {i | ε i m ≠ 0}]

end dual_pair

namespace dual_pair

open module module.dual linear_map function

variables {R M ι : Type*}
variables [comm_ring R] [add_comm_group M] [module R M]
variables {e : ι → M} {ε : ι → dual R M}

/-- The coefficients of `v` on the basis `e` -/
def coeffs [decidable_eq ι] (h : dual_pair e ε) (m : M) : ι →₀ R :=
{ to_fun := λ i, ε i m,
  support := by { haveI := h.finite m, exact {i : ι | ε i m ≠ 0}.to_finset },
  mem_support_to_fun := by {intro i, rw set.mem_to_finset, exact iff.rfl } }

@[simp]

/-- linear combinations of elements of `e`.
This is a convenient abbreviation for `finsupp.total _ M R e l` -/
def lc {ι} (e : ι → M) (l : ι →₀ R) : M := l.sum (λ (i : ι) (a : R), a • (e i))

lemma lc_def (e : ι → M) (l : ι →₀ R) : lc e l = finsupp.total _ _ _ e l := rfl

variables [decidable_eq ι] (h : dual_pair e ε)
include h

lemma dual_lc (l : ι →₀ R) (i : ι) : ε i (dual_pair.lc e l) = l i :=
begin
  erw linear_map.map_sum,
  simp only [h.eval, map_smul, smul_eq_mul],
  rw finset.sum_eq_single i,
  { simp },
  { intros q q_in q_ne,
    simp [q_ne.symm] },
  { intro p_not_in,
    simp [finsupp.not_mem_support_iff.1 p_not_in] },
end

@[simp]
lemma coeffs_lc (l : ι →₀ R) : h.coeffs (dual_pair.lc e l) = l :=
by { ext i, rw [h.coeffs_apply, h.dual_lc] }

/-- For any m : M n, \sum_{p ∈ Q n} (ε p m) • e p = m -/
@[simp]
lemma lc_coeffs (m : M) : dual_pair.lc e (h.coeffs m) = m :=
begin
  refine eq_of_sub_eq_zero (h.total _),
  intros i,
  simp [-sub_eq_add_neg, linear_map.map_sub, h.dual_lc, sub_eq_zero]
end

/-- `(h : dual_pair e ε).basis` shows the family of vectors `e` forms a basis. -/
@[simps]
def basis : basis ι R M :=
basis.of_repr
{ to_fun := coeffs h,
  inv_fun := lc e,
  left_inv := lc_coeffs h,
  right_inv := coeffs_lc h,
  map_add' := λ v w, by { ext i, exact (ε i).map_add v w },
  map_smul' := λ c v, by { ext i, exact (ε i).map_smul c v } }

@[simp] lemma coe_basis : ⇑h.basis = e :=
by { ext i, rw basis.apply_eq_iff, ext j,
     rw [h.basis_repr_apply, coeffs_apply, h.eval, finsupp.single_apply],
     convert if_congr eq_comm rfl rfl } -- `convert` to get rid of a `decidable_eq` mismatch

lemma mem_of_mem_span {H : set ι} {x : M} (hmem : x ∈ submodule.span R (e '' H)) :
  ∀ i : ι, ε i x ≠ 0 → i ∈ H :=
begin
  intros i hi,
  rcases (finsupp.mem_span_image_iff_total _).mp hmem with ⟨l, supp_l, rfl⟩,
  apply not_imp_comm.mp ((finsupp.mem_supported' _ _).mp supp_l i),
  rwa [← lc_def, h.dual_lc] at hi
end

lemma coe_dual_basis [fintype ι] : ⇑h.basis.dual_basis = ε :=
funext (λ i, h.basis.ext (λ j, by rw [h.basis.dual_basis_apply_self, h.coe_basis, h.eval,
                                      if_congr eq_comm rfl rfl]))

end dual_pair

namespace submodule

universes u v w

variables {R : Type u} {M : Type v} [comm_ring R] [add_comm_group M] [module R M]
variable {W : submodule R M}

/-- The `dual_restrict` of a submodule `W` of `M` is the linear map from the
  dual of `M` to the dual of `W` such that the domain of each linear map is
  restricted to `W`. -/
def dual_restrict (W : submodule R M) :
  module.dual R M →ₗ[R] module.dual R W :=
linear_map.dom_restrict' W

@[simp] lemma dual_restrict_apply
  (W : submodule R M) (φ : module.dual R M) (x : W) :
  W.dual_restrict φ x = φ (x : M) := rfl

/-- The `dual_annihilator` of a submodule `W` is the set of linear maps `φ` such
  that `φ w = 0` for all `w ∈ W`. -/
def dual_annihilator {R : Type u} {M : Type v} [comm_ring R] [add_comm_group M]
  [module R M] (W : submodule R M) : submodule R $ module.dual R M :=
W.dual_restrict.ker

@[simp] lemma mem_dual_annihilator (φ : module.dual R M) :
  φ ∈ W.dual_annihilator ↔ ∀ w ∈ W, φ w = 0 :=
begin
  refine linear_map.mem_ker.trans _,
  simp_rw [linear_map.ext_iff, dual_restrict_apply],
  exact ⟨λ h w hw, h ⟨w, hw⟩, λ h w, h w.1 w.2⟩
end

lemma dual_restrict_ker_eq_dual_annihilator (W : submodule R M) :
  W.dual_restrict.ker = W.dual_annihilator :=
rfl

lemma dual_annihilator_sup_eq_inf_dual_annihilator (U V : submodule R M) :
  (U ⊔ V).dual_annihilator = U.dual_annihilator ⊓ V.dual_annihilator :=
begin
  ext φ,
  rw [mem_inf, mem_dual_annihilator, mem_dual_annihilator, mem_dual_annihilator],
  split; intro h,
  { refine ⟨_, _⟩;
    intros x hx,
    exact h x (mem_sup.2 ⟨x, hx, 0, zero_mem _, add_zero _⟩),
    exact h x (mem_sup.2 ⟨0, zero_mem _, x, hx, zero_add _⟩) },
  { simp_rw mem_sup,
    rintro _ ⟨x, hx, y, hy, rfl⟩,
    rw [linear_map.map_add, h.1 _ hx, h.2 _ hy, add_zero] }
end

/-- The pullback of a submodule in the dual space along the evaluation map. -/
def dual_annihilator_comap (Φ : submodule R (module.dual R M)) : submodule R M :=
Φ.dual_annihilator.comap (module.dual.eval R M)

lemma mem_dual_annihilator_comap_iff {Φ : submodule R (module.dual R M)} (x : M) :
  x ∈ Φ.dual_annihilator_comap ↔ ∀ φ ∈ Φ, (φ x : R) = 0 :=
by simp_rw [dual_annihilator_comap, mem_comap, mem_dual_annihilator, module.dual.eval_apply]

end submodule

namespace subspace

open submodule linear_map

universes u v w

-- We work in vector spaces because `exists_is_compl` only hold for vector spaces
variables {K : Type u} {V : Type v} [field K] [add_comm_group V] [module K V]

/-- Given a subspace `W` of `V` and an element of its dual `φ`, `dual_lift W φ` is
the natural extension of `φ` to an element of the dual of `V`.
That is, `dual_lift W φ` sends `w ∈ W` to `φ x` and `x` in the complement of `W` to `0`. -/
noncomputable def dual_lift (W : subspace K V) :
  module.dual K W →ₗ[K] module.dual K V :=
let h := classical.indefinite_description _ W.exists_is_compl in
  (linear_map.of_is_compl_prod h.2).comp (linear_map.inl _ _ _)

variable {W : subspace K V}

@[simp] lemma dual_lift_of_subtype {φ : module.dual K W} (w : W) :
  W.dual_lift φ (w : V) = φ w :=
by { erw of_is_compl_left_apply _ w, refl }

lemma dual_lift_of_mem {φ : module.dual K W} {w : V} (hw : w ∈ W) :
  W.dual_lift φ w = φ ⟨w, hw⟩ :=
dual_lift_of_subtype ⟨w, hw⟩

@[simp] lemma dual_restrict_comp_dual_lift (W : subspace K V) :
  W.dual_restrict.comp W.dual_lift = 1 :=
by { ext φ x, simp }

lemma dual_restrict_left_inverse (W : subspace K V) :
  function.left_inverse W.dual_restrict W.dual_lift :=
λ x, show W.dual_restrict.comp W.dual_lift x = x,
  by { rw [dual_restrict_comp_dual_lift], refl }

lemma dual_lift_right_inverse (W : subspace K V) :
  function.right_inverse W.dual_lift W.dual_restrict :=
W.dual_restrict_left_inverse

lemma dual_restrict_surjective :
  function.surjective W.dual_restrict :=
W.dual_lift_right_inverse.surjective

lemma dual_lift_injective : function.injective W.dual_lift :=
W.dual_restrict_left_inverse.injective

/-- The quotient by the `dual_annihilator` of a subspace is isomorphic to the
  dual of that subspace. -/
noncomputable def quot_annihilator_equiv (W : subspace K V) :
  (module.dual K V ⧸ W.dual_annihilator) ≃ₗ[K] module.dual K W :=
(quot_equiv_of_eq _ _ W.dual_restrict_ker_eq_dual_annihilator).symm.trans $
  W.dual_restrict.quot_ker_equiv_of_surjective dual_restrict_surjective

/-- The natural isomorphism forom the dual of a subspace `W` to `W.dual_lift.range`. -/
noncomputable def dual_equiv_dual (W : subspace K V) :
  module.dual K W ≃ₗ[K] W.dual_lift.range :=
linear_equiv.of_injective _ dual_lift_injective

lemma dual_equiv_dual_def (W : subspace K V) :
  W.dual_equiv_dual.to_linear_map = W.dual_lift.range_restrict := rfl

@[simp] lemma dual_equiv_dual_apply (φ : module.dual K W) :
  W.dual_equiv_dual φ = ⟨W.dual_lift φ, mem_range.2 ⟨φ, rfl⟩⟩ := rfl

section

open_locale classical

open finite_dimensional

variables {V₁ : Type*} [add_comm_group V₁] [module K V₁]

instance [H : finite_dimensional K V] : finite_dimensional K (module.dual K V) :=
linear_equiv.finite_dimensional (basis.of_vector_space K V).to_dual_equiv

variables [finite_dimensional K V] [finite_dimensional K V₁]

@[simp] lemma dual_finrank_eq :
  finrank K (module.dual K V) = finrank K V :=
linear_equiv.finrank_eq (basis.of_vector_space K V).to_dual_equiv.symm

/-- The quotient by the dual is isomorphic to its dual annihilator.  -/
noncomputable def quot_dual_equiv_annihilator (W : subspace K V) :
  (module.dual K V ⧸ W.dual_lift.range) ≃ₗ[K] W.dual_annihilator :=
linear_equiv.quot_equiv_of_quot_equiv $
  linear_equiv.trans W.quot_annihilator_equiv W.dual_equiv_dual

/-- The quotient by a subspace is isomorphic to its dual annihilator. -/
noncomputable def quot_equiv_annihilator (W : subspace K V) :
  (V ⧸ W) ≃ₗ[K] W.dual_annihilator :=
begin
  refine _ ≪≫ₗ W.quot_dual_equiv_annihilator,
  refine linear_equiv.quot_equiv_of_equiv _ (basis.of_vector_space K V).to_dual_equiv,
  exact (basis.of_vector_space K W).to_dual_equiv.trans W.dual_equiv_dual
end

open finite_dimensional

@[simp]
lemma finrank_dual_annihilator_comap_eq {Φ : subspace K (module.dual K V)} :
  finrank K Φ.dual_annihilator_comap = finrank K Φ.dual_annihilator :=
begin
  rw [submodule.dual_annihilator_comap, ← module.eval_equiv_to_linear_map],
  exact linear_equiv.finrank_eq (linear_equiv.of_submodule' _ _),
end

lemma finrank_add_finrank_dual_annihilator_comap_eq
  (W : subspace K (module.dual K V)) :
  finrank K W + finrank K W.dual_annihilator_comap = finrank K V :=
begin
  rw [finrank_dual_annihilator_comap_eq, W.quot_equiv_annihilator.finrank_eq.symm, add_comm,
      submodule.finrank_quotient_add_finrank, subspace.dual_finrank_eq],
end

end

end subspace

variables {R : Type*} [comm_ring R] {M₁ : Type*} {M₂ : Type*}
variables [add_comm_group M₁] [module R M₁] [add_comm_group M₂] [module R M₂]

open module

/-- Given a linear map `f : M₁ →ₗ[R] M₂`, `f.dual_map` is the linear map between the dual of
`M₂` and `M₁` such that it maps the functional `φ` to `φ ∘ f`. -/
def linear_map.dual_map (f : M₁ →ₗ[R] M₂) : dual R M₂ →ₗ[R] dual R M₁ :=
linear_map.lcomp R R f

@[simp] lemma linear_map.dual_map_apply (f : M₁ →ₗ[R] M₂) (g : dual R M₂) (x : M₁) :
  f.dual_map g x = g (f x) :=
linear_map.lcomp_apply f g x

@[simp] lemma linear_map.dual_map_id :
  (linear_map.id : M₁ →ₗ[R] M₁).dual_map = linear_map.id :=
by { ext, refl }

lemma linear_map.dual_map_comp_dual_map {M₃ : Type*} [add_comm_group M₃] [module R M₃]
  (f : M₁ →ₗ[R] M₂) (g : M₂ →ₗ[R] M₃) :
  f.dual_map.comp g.dual_map = (g.comp f).dual_map :=
rfl

/-- The `linear_equiv` version of `linear_map.dual_map`. -/
def linear_equiv.dual_map (f : M₁ ≃ₗ[R] M₂) : dual R M₂ ≃ₗ[R] dual R M₁ :=
{ inv_fun := f.symm.to_linear_map.dual_map,
  left_inv :=
    begin
      intro φ, ext x,
      simp only [linear_map.dual_map_apply, linear_equiv.coe_to_linear_map,
                 linear_map.to_fun_eq_coe, linear_equiv.apply_symm_apply]
    end,
  right_inv :=
    begin
      intro φ, ext x,
      simp only [linear_map.dual_map_apply, linear_equiv.coe_to_linear_map,
                 linear_map.to_fun_eq_coe, linear_equiv.symm_apply_apply]
    end,
  .. f.to_linear_map.dual_map }

@[simp] lemma linear_equiv.dual_map_apply (f : M₁ ≃ₗ[R] M₂) (g : dual R M₂) (x : M₁) :
  f.dual_map g x = g (f x) :=
linear_map.lcomp_apply f g x

@[simp] lemma linear_equiv.dual_map_refl :
  (linear_equiv.refl R M₁).dual_map = linear_equiv.refl R (dual R M₁) :=
by { ext, refl }

@[simp] lemma linear_equiv.dual_map_symm {f : M₁ ≃ₗ[R] M₂} :
  (linear_equiv.dual_map f).symm = linear_equiv.dual_map f.symm := rfl

lemma linear_equiv.dual_map_trans {M₃ : Type*} [add_comm_group M₃] [module R M₃]
  (f : M₁ ≃ₗ[R] M₂) (g : M₂ ≃ₗ[R] M₃) :
  g.dual_map.trans f.dual_map = (f.trans g).dual_map :=
rfl

namespace linear_map

variable (f : M₁ →ₗ[R] M₂)

lemma ker_dual_map_eq_dual_annihilator_range :
  f.dual_map.ker = f.range.dual_annihilator :=
begin
  ext φ, split; intro hφ,
  { rw mem_ker at hφ,
    rw submodule.mem_dual_annihilator,
    rintro y ⟨x, rfl⟩,
    rw [← dual_map_apply, hφ, zero_apply] },
  { ext x,
    rw dual_map_apply,
    rw submodule.mem_dual_annihilator at hφ,
    exact hφ (f x) ⟨x, rfl⟩ }
end

lemma range_dual_map_le_dual_annihilator_ker :
  f.dual_map.range ≤ f.ker.dual_annihilator :=
begin
  rintro _ ⟨ψ, rfl⟩,
  simp_rw [submodule.mem_dual_annihilator, mem_ker],
  rintro x hx,
  rw [dual_map_apply, hx, map_zero]
end

section finite_dimensional

variables {K : Type*} [field K] {V₁ : Type*} {V₂ : Type*}
variables [add_comm_group V₁] [module K V₁] [add_comm_group V₂] [module K V₂]

open finite_dimensional

variable [finite_dimensional K V₂]

@[simp] lemma finrank_range_dual_map_eq_finrank_range (f : V₁ →ₗ[K] V₂) :
  finrank K f.dual_map.range = finrank K f.range :=
begin
  have := submodule.finrank_quotient_add_finrank f.range,
  rw [(subspace.quot_equiv_annihilator f.range).finrank_eq,
      ← ker_dual_map_eq_dual_annihilator_range] at this,
  conv_rhs at this { rw ← subspace.dual_finrank_eq },
  refine add_left_injective (finrank K f.dual_map.ker) _,
  change _ + _ = _ + _,
  rw [finrank_range_add_finrank_ker f.dual_map, add_comm, this],
end

lemma range_dual_map_eq_dual_annihilator_ker [finite_dimensional K V₁] (f : V₁ →ₗ[K] V₂) :
  f.dual_map.range = f.ker.dual_annihilator :=
begin
  refine eq_of_le_of_finrank_eq f.range_dual_map_le_dual_annihilator_ker _,
  have := submodule.finrank_quotient_add_finrank f.ker,
  rw (subspace.quot_equiv_annihilator f.ker).finrank_eq at this,
  refine add_left_injective (finrank K f.ker) _,
  simp_rw [this, finrank_range_dual_map_eq_finrank_range],
  exact finrank_range_add_finrank_ker f,
end

end finite_dimensional

end linear_map


/-
Copyright (c) 2018 Robert Y. Lewis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Robert Y. Lewis
-/
import algebra.group_with_zero.power
import tactic.linarith
import data.equiv.ring

/-!
# Integer power operation on fields and division rings

This file collects basic facts about the operation of raising an element of a `division_ring` to an
integer power. More specialised results are provided in the case of a linearly ordered field.
-/

universe u

@[simp] lemma ring_hom.map_zpow {K L : Type*} [division_ring K] [division_ring L] (f : K →+* L) :
  ∀ (a : K) (n : ℤ), f (a ^ n) = f a ^ n :=
f.to_monoid_with_zero_hom.map_zpow

@[simp] lemma ring_equiv.map_zpow {K L : Type*} [division_ring K] [division_ring L] (f : K ≃+* L) :
  ∀ (a : K) (n : ℤ), f (a ^ n) = f a ^ n :=
f.to_ring_hom.map_zpow

@[simp] lemma zpow_bit0_neg {K : Type*} [division_ring K] (x : K) (n : ℤ) :
  (-x) ^ (bit0 n) = x ^ bit0 n :=
by rw [zpow_bit0', zpow_bit0', neg_mul_neg]

lemma even.zpow_neg {K : Type*} [division_ring K] {n : ℤ} (h : even n) (a : K) :
  (-a) ^ n = a ^ n :=
begin
  obtain ⟨k, rfl⟩ := h,
  rw [←bit0_eq_two_mul, zpow_bit0_neg],
end

@[simp] lemma zpow_bit1_neg {K : Type*} [division_ring K] (x : K) (n : ℤ) :
  (-x) ^ (bit1 n) = - x ^ bit1 n :=
by rw [zpow_bit1', zpow_bit1', neg_mul_neg, neg_mul_eq_mul_neg]

section ordered_field_power
open int

variables {K : Type u} [linear_ordered_field K] {a : K} {n : ℤ}

lemma zpow_eq_zero_iff (hn : 0 < n) :
  a ^ n = 0 ↔ a = 0 :=
begin
  refine ⟨zpow_eq_zero, _⟩,
  rintros rfl,
  exact zero_zpow _ hn.ne'
end

lemma zpow_nonneg {a : K} (ha : 0 ≤ a) : ∀ (z : ℤ), 0 ≤ a ^ z
| (n : ℕ) := by { rw zpow_coe_nat, exact pow_nonneg ha _ }
| -[1+n]  := by { rw zpow_neg_succ_of_nat, exact inv_nonneg.2 (pow_nonneg ha _) }

lemma zpow_pos_of_pos {a : K} (ha : 0 < a) : ∀ (z : ℤ), 0 < a ^ z
| (n : ℕ) := by { rw zpow_coe_nat, exact pow_pos ha _ }
| -[1+n]  := by { rw zpow_neg_succ_of_nat, exact inv_pos.2 (pow_pos ha _) }

lemma zpow_le_of_le {x : K} (hx : 1 ≤ x) {a b : ℤ} (h : a ≤ b) : x ^ a ≤ x ^ b :=
begin
  induction a with a a; induction b with b b,
  { simp only [of_nat_eq_coe, zpow_coe_nat],
    apply pow_le_pow hx,
    apply le_of_coe_nat_le_coe_nat h },
  { apply absurd h,
    apply not_le_of_gt,
    exact lt_of_lt_of_le (neg_succ_lt_zero _) (of_nat_nonneg _) },
  { simp only [zpow_neg_succ_of_nat, one_div, of_nat_eq_coe, zpow_coe_nat],
    apply le_trans (inv_le_one _); apply one_le_pow_of_one_le hx },
  { simp only [zpow_neg_succ_of_nat],
    apply (inv_le_inv _ _).2,
    { apply pow_le_pow hx,
      have : -(↑(a+1) : ℤ) ≤ -(↑(b+1) : ℤ), from h,
      have h' := le_of_neg_le_neg this,
      apply le_of_coe_nat_le_coe_nat h' },
    repeat { apply pow_pos (lt_of_lt_of_le zero_lt_one hx) } }
end

lemma pow_le_max_of_min_le {x : K} (hx : 1 ≤ x) {a b c : ℤ} (h : min a b ≤ c) :
      x ^ (-c) ≤ max (x ^ (-a)) (x ^ (-b)) :=
begin
  wlog hle : a ≤ b,
  have hnle : -b ≤ -a, from neg_le_neg hle,
  have hfle : x ^ (-b) ≤ x ^ (-a), from zpow_le_of_le hx hnle,
  have : x ^ (-c) ≤ x ^ (-a),
  { apply zpow_le_of_le hx,
    simpa only [min_eq_left hle, neg_le_neg_iff] using h },
  simpa only [max_eq_left hfle]
end

lemma zpow_le_one_of_nonpos {p : K} (hp : 1 ≤ p) {z : ℤ} (hz : z ≤ 0) : p ^ z ≤ 1 :=
calc p ^ z ≤ p ^ 0 : zpow_le_of_le hp hz
          ... = 1        : by simp

lemma one_le_zpow_of_nonneg {p : K} (hp : 1 ≤ p) {z : ℤ} (hz : 0 ≤ z) : 1 ≤ p ^ z :=
calc p ^ z ≥ p ^ 0 : zpow_le_of_le hp hz
          ... = 1        : by simp

theorem zpow_bit0_nonneg (a : K) (n : ℤ) : 0 ≤ a ^ bit0 n :=
by { rw zpow_bit0₀, exact mul_self_nonneg _ }

theorem zpow_two_nonneg (a : K) : 0 ≤ a ^ 2 :=
pow_bit0_nonneg a 1

theorem zpow_bit0_pos {a : K} (h : a ≠ 0) (n : ℤ) : 0 < a ^ bit0 n :=
(zpow_bit0_nonneg a n).lt_of_ne (zpow_ne_zero _ h).symm

theorem zpow_two_pos_of_ne_zero (a : K) (h : a ≠ 0) : 0 < a ^ 2 :=
pow_bit0_pos h 1

@[simp] theorem zpow_bit1_neg_iff : a ^ bit1 n < 0 ↔ a < 0 :=
⟨λ h, not_le.1 $ λ h', not_le.2 h $ zpow_nonneg h' _,
 λ h, by rw [bit1, zpow_add_one₀ h.ne]; exact mul_neg_of_pos_of_neg (zpow_bit0_pos h.ne _) h⟩

@[simp] theorem zpow_bit1_nonneg_iff : 0 ≤ a ^ bit1 n ↔ 0 ≤ a :=
le_iff_le_iff_lt_iff_lt.2 zpow_bit1_neg_iff

@[simp] theorem zpow_bit1_nonpos_iff : a ^ bit1 n ≤ 0 ↔ a ≤ 0 :=
begin
  rw [le_iff_lt_or_eq, zpow_bit1_neg_iff],
  split,
  { rintro (h | h),
    { exact h.le },
    { exact (zpow_eq_zero h).le } },
  { intro h,
    rcases eq_or_lt_of_le h with rfl|h,
    { exact or.inr (zero_zpow _ (bit1_ne_zero n)) },
    { exact or.inl h } }
end

@[simp] theorem zpow_bit1_pos_iff : 0 < a ^ bit1 n ↔ 0 < a :=
lt_iff_lt_of_le_iff_le zpow_bit1_nonpos_iff

lemma even.zpow_nonneg {n : ℤ} (hn : even n) (a : K) :
  0 ≤ a ^ n :=
begin
  cases le_or_lt 0 a with h h,
  { exact zpow_nonneg h _ },
  { exact (hn.zpow_neg a).subst (zpow_nonneg (neg_nonneg_of_nonpos h.le) _) }
end

theorem even.zpow_pos (hn : even n) (ha : a ≠ 0) : 0 < a ^ n :=
by cases hn with k hk; simpa only [hk, two_mul] using zpow_bit0_pos ha k

theorem odd.zpow_nonneg (hn : odd n) (ha : 0 ≤ a) : 0 ≤ a ^ n :=
by cases hn with k hk; simpa only [hk, two_mul] using zpow_bit1_nonneg_iff.mpr ha

theorem odd.zpow_pos (hn : odd n) (ha : 0 < a) : 0 < a ^ n :=
by cases hn with k hk; simpa only [hk, two_mul] using zpow_bit1_pos_iff.mpr ha

theorem odd.zpow_nonpos (hn : odd n) (ha : a ≤ 0) : a ^ n ≤ 0:=
by cases hn with k hk; simpa only [hk, two_mul] using zpow_bit1_nonpos_iff.mpr ha

theorem odd.zpow_neg (hn : odd n) (ha : a < 0) : a ^ n < 0:=
by cases hn with k hk; simpa only [hk, two_mul] using zpow_bit1_neg_iff.mpr ha

lemma even.zpow_abs {p : ℤ} (hp : even p) (a : K) : |a| ^ p = a ^ p :=
begin
  cases abs_choice a with h h;
  simp only [h, hp.zpow_neg _],
end

@[simp] lemma zpow_bit0_abs (a : K) (p : ℤ) : |a| ^ bit0 p = a ^ bit0 p :=
(even_bit0 _).zpow_abs _

lemma even.abs_zpow {p : ℤ} (hp : even p) (a : K) : |a ^ p| = a ^ p :=
begin
  rw [abs_eq_self],
  exact hp.zpow_nonneg _
end

@[simp] lemma abs_zpow_bit0 (a : K) (p : ℤ) :
  |a ^ bit0 p| = a ^ bit0 p :=
(even_bit0 _).abs_zpow _

end ordered_field_power

lemma one_lt_zpow {K} [linear_ordered_field K] {p : K} (hp : 1 < p) :
  ∀ z : ℤ, 0 < z → 1 < p ^ z
| (n : ℕ) h := (zpow_coe_nat p n).symm.subst (one_lt_pow hp $ int.coe_nat_ne_zero.mp h.ne')
| -[1+ n] h := ((int.neg_succ_not_pos _).mp h).elim

section ordered
variables  {K : Type*} [linear_ordered_field K]

lemma nat.zpow_pos_of_pos {p : ℕ} (h : 0 < p) (n:ℤ) : 0 < (p:K)^n :=
by { apply zpow_pos_of_pos, exact_mod_cast h }

lemma nat.zpow_ne_zero_of_pos {p : ℕ} (h : 0 < p) (n:ℤ) : (p:K)^n ≠ 0 :=
ne_of_gt (nat.zpow_pos_of_pos h n)

lemma zpow_strict_mono {x : K} (hx : 1 < x) :
  strict_mono (λ n:ℤ, x ^ n) :=
λ m n h, show x ^ m < x ^ n,
begin
  have xpos : 0 < x := zero_lt_one.trans hx,
  have h₀ : x ≠ 0 := xpos.ne',
  have hxm : 0 < x^m := zpow_pos_of_pos xpos m,
  have h : 1 < x ^ (n - m) := one_lt_zpow hx _ (sub_pos_of_lt h),
  replace h := mul_lt_mul_of_pos_right h hxm,
  rwa [sub_eq_add_neg, zpow_add₀ h₀, mul_assoc, zpow_neg_mul_zpow_self _ h₀, one_mul, mul_one] at h,
end

@[simp] lemma zpow_lt_iff_lt {x : K} (hx : 1 < x) {m n : ℤ} :
  x ^ m < x ^ n ↔ m < n :=
(zpow_strict_mono hx).lt_iff_lt

@[simp] lemma zpow_le_iff_le {x : K} (hx : 1 < x) {m n : ℤ} :
  x ^ m ≤ x ^ n ↔ m ≤ n :=
(zpow_strict_mono hx).le_iff_le

@[simp] lemma pos_div_pow_pos {a b : K} (ha : 0 < a) (hb : 0 < b) (k : ℕ) : 0 < a/b^k :=
div_pos ha (pow_pos hb k)

@[simp] lemma div_pow_le {a b : K} (ha : 0 < a) (hb : 1 ≤ b) (k : ℕ) : a/b^k ≤ a :=
(div_le_iff $ pow_pos (lt_of_lt_of_le zero_lt_one hb) k).mpr
(calc a = a * 1 : (mul_one a).symm
   ...  ≤ a*b^k : (mul_le_mul_left ha).mpr $ one_le_pow_of_one_le hb _)

lemma zpow_injective {x : K} (h₀ : 0 < x) (h₁ : x ≠ 1) :
  function.injective ((^) x : ℤ → K) :=
begin
  intros m n h,
  rcases h₁.lt_or_lt with H|H,
  { apply (zpow_strict_mono (one_lt_inv h₀ H)).injective,
    show x⁻¹ ^ m = x⁻¹ ^ n,
    rw [← zpow_neg_one₀, ← zpow_mul₀, ← zpow_mul₀, mul_comm _ m, mul_comm _ n, zpow_mul₀, zpow_mul₀,
      h], },
  { exact (zpow_strict_mono H).injective h, },
end

@[simp] lemma zpow_inj {x : K} (h₀ : 0 < x) (h₁ : x ≠ 1) {m n : ℤ} :
  x ^ m = x ^ n ↔ m = n :=
(zpow_injective h₀ h₁).eq_iff

end ordered

section
variables {K : Type*} [field K]

@[simp, norm_cast] theorem rat.cast_zpow [char_zero K] (q : ℚ) (n : ℤ) :
  ((q ^ n : ℚ) : K) = q ^ n :=
(rat.cast_hom K).map_zpow q n

end


import dict
import tactic
import tactic.induction

def var := ℕ

set_option pp.generalized_field_notation false

inductive Typ : Type
| Lam : Typ -> Typ -> Typ
| Nat : Typ
| Unit : Typ

notation t1 ` -> ` t2 := Typ.Lam t1 t2

inductive Term : Type
| Var : var -> Term
| Lam : var -> Typ -> Term -> Term
| Ap  : Term -> Term -> Term
| Nat : ℕ -> Term
| Plus : Term -> Term -> Term
| Unit : Term

notation `\` `(`x`:`S`)` `.` t := Term.Lam x S t
notation `()` := Term.Unit
notation `[`n`]` := Term.Nat n

inductive value : Term -> Prop
-- functions are values!
| Lam : ∀ (x : var) (τ : Typ) (e: Term), value (Term.Lam x τ e)
| Unit : value ()
| Nat : ∀ (n : ℕ), value [n]

def isVal (t : Term) := value t

def subst (s : Term) (v : var) : Term -> Term
| (Term.Var n) := if n = v then s else (Term.Var n)
| (Term.Lam n τ e) := if v = n then
                        Term.Lam n τ e
                      else
                        Term.Lam n τ (subst e)
| (Term.Ap e1 e2) := Term.Ap (subst e1) (subst e2)
| Term.Unit := Term.Unit
| (Term.Nat n) := Term.Nat n
| (Term.Plus m n) := Term.Plus (subst m) (subst n)

notation `[` s `//` x `]` t := subst s x t

inductive step : Term -> Term -> Prop
| ApLam : ∀ v x τ e, value v -> step (Term.Ap (Term.Lam x τ e) v) ([v//x]e)
| Ap1 : ∀ e1 e1' e2, step e1 e1' -> step (Term.Ap e1 e2) (Term.Ap e1' e2)
| Ap2 : ∀ e1 e2 e2', step e2 e2' -> step (Term.Ap e1 e2) (Term.Ap e1 e2')
| Plus1 : ∀ e1 e1' e2, step e1 e1' -> step (Term.Plus e1 e2) (Term.Plus e1' e2)
| Plus2 : ∀ e1 e2' e2, step e2 e2' -> step (Term.Plus e1 e2) (Term.Plus e1 e2')
| PlusNat : ∀ n m, step (Term.Plus (Term.Nat n) (Term.Nat m)) (Term.Nat (n + m))

inductive free_in : var -> Term -> Prop
| Var : ∀ x, free_in x (Term.Var x)
| Lam : ∀ x y τ e, x ≠ y -> free_in x e -> free_in x (Term.Lam y τ e)
| Ap1 : ∀ x e1 e2, free_in x e1 -> free_in x (Term.Ap e1 e2)
| Ap2 : ∀ x e1 e2, free_in x e2 -> free_in x (Term.Ap e1 e2)
| Plus1 : ∀ x e1 e2, free_in x e1 -> free_in x (Term.Plus e1 e2)
| Plus2 : ∀ x e1 e2, free_in x e2 -> free_in x (Term.Plus e1 e2)

def FV (e : Term) := {x | free_in x e}

-- this was a 15-312 assignment
inductive not_free_in : var -> Term -> Prop
| Var : ∀ x y, x ≠ y -> not_free_in x (Term.Var y)
| Ap : ∀ x e1 e2, not_free_in x e1 -> not_free_in x e2 -> not_free_in x (Term.Ap e1 e2)
| Lam1 : ∀ x y τ e, x ≠ y -> not_free_in x e -> not_free_in x (Term.Lam y τ e)
| Lam2 : ∀ x τ e, not_free_in x (Term.Lam x τ e)
| Nat : ∀ x n, not_free_in x (Term.Nat n)
| Plus : ∀ x e1 e2, not_free_in x e1 -> not_free_in x e2 -> not_free_in x (Term.Plus e1 e2)
| Unit : ∀ x, not_free_in x ()

instance : has_mem var Term := ⟨free_in⟩

infix ` ↦ `:50 := step

def Context := Dict var Typ

def ctx_Empty := @Dict.empty var Typ

notation Γ `, ` x ` : ` τ := Dict.add Γ x τ

notation `⬝` := ctx_Empty

inductive has_type : Context -> Term -> Typ -> Prop
| Var : ∀ (Γ : Context) (x : var) (τ : Typ), Dict.get Γ x = some τ -> has_type Γ (Term.Var x) τ
| Lam : ∀ (Γ : Context) (x : var) (τ₁ τ₂ : Typ) (t₁ : Term),
    has_type (Dict.add Γ x τ₁) t₁ τ₂ ->
    has_type Γ (Term.Lam x τ₁ t₁) (Typ.Lam τ₁ τ₂)

| Ap : ∀ Γ τ₁ τ₂ e₁ e₂,
    has_type Γ e₁ (Typ.Lam τ₁ τ₂) -> has_type Γ e₂ τ₁
    -> has_type Γ (Term.Ap e₁ e₂) τ₂
| Unit : ∀ Γ, has_type Γ Term.Unit Typ.Unit
| Nat : ∀ Γ n, has_type Γ (Term.Nat n) Typ.Nat
| Plus : ∀ Γ e₁ e₂, has_type Γ e₁ Typ.Nat -> has_type Γ e₂ Typ.Nat -> has_type Γ (Term.Plus e₁ e₂) Typ.Nat

notation Γ ` ⊢ ` e ` : ` τ  := has_type Γ e τ

lemma fn_typ_eq  {τ₁ τ₂ τ₃ τ₄ : Typ} (h : (τ₁ → τ₂) = (τ₃ → τ₄)) : τ₁ = τ₃ ∧ τ₂ = τ₄
:=
begin
  split,
  repeat {cases h, refl,},
end

theorem unicity {Γ : Context} {τ₁ τ₂ : Typ} {e : Term} (h1 : has_type Γ e τ₁) (h2 : has_type Γ e τ₂) : τ₁ = τ₂
:=
begin
  induction' h1,
  {
    cases h2 with _ _ _ h',
    rw h' at h,
    apply option.some.inj,
    exact h.symm,
  },
  {
    cases h2 with _ _ _ _ _ _ _ τ1 _ h',
    specialize ih h',
    rw ih,
  },
  {
    cases h2 with _ _ _ _ _ _ _ τ1 _ h' _ τ _ _ _ h h',
    specialize ih_h1 h,
    exact (fn_typ_eq ih_h1).2,
  },
  repeat {
    cases h2,
    refl,
  },
end

lemma CFL_Lam {τ₁ τ₂ : Typ} {e : Term} (h1: has_type ctx_Empty e (Typ.Lam τ₁ τ₂)) (h2 : value e)
  : ∃x t, e = Term.Lam x τ₁ t :=
begin
  cases h2 with x τ e,
  {
    use [x, e],
    cases h1,
    refl,
  },
  repeat {cases h1},
end

lemma CFL_Nat  {e : Term} (h1: has_type ctx_Empty e Typ.Nat) (h : value e)
  : ∃n, e = Term.Nat n:=
begin
  cases h,
  repeat {cases h1},
  use h_1,
end

lemma CFL_Unit  {e : Term} (h1: has_type ctx_Empty e Typ.Unit) (h : value e)
  : e = Term.Unit  :=
begin
  cases h,
  cases h1,
  refl,
  cases h1,
end

theorem progress (e : Term) (τ : Typ) (h : has_type ctx_Empty e τ) : value e ∨ ∃ e', e ↦ e' :=
begin
  induction' h with foo x τ h _ x τ τ₁ _ _ _ _ _ _ e1 e2 h h1 e1_ih e2_ih _ _ _ _ e1 e2 h1 h2,
  { contradiction },
  { exact or.inl (value.Lam x τ e) },
  {
    right,
    cases e1_ih,
    cases e2_ih,
    {
      rcases (CFL_Lam h e1_ih) with ⟨x, e, h_e1⟩,
      use ([e2 // x]e),
      rw h_e1,
      exact step.ApLam e2 x τ₁ e e2_ih,
    },
    {
      cases e2_ih with e2' e2_ih,
      use Term.Ap e1 e2',
      exact step.Ap2 e1 e2 e2' e2_ih,
    },
    {
      cases e1_ih with e1' e1_ih,
      use Term.Ap e1' e2,
      exact step.Ap1 e1 e1' e2 e1_ih,
    },
  },
  { exact or.inl value.Unit },
  { exact or.inl (value.Nat n) },
  {
    right,
    cases ih_h1,
    {
      cases ih_h2,
      {
        cases CFL_Nat h1 ih_h1 with n hn,
        cases CFL_Nat h2 ih_h2 with m hm,
        use Term.Nat (n+m),
        rw hn,
        rw hm,
        exact step.PlusNat n m,
      },
      {
        cases ih_h2 with e2' ih_e2,
        use Term.Plus e1 e2',
        exact step.Plus2 e1 e2' e2 ih_e2,
      },
    },
    {
      cases ih_h1 with e1' ih_e1,
      use Term.Plus e1' e2,
      exact step.Plus1 e1 e1' e2 ih_e1,
    }
  }
end

lemma inversion_Lam {Γ : Context} {x : var} {τ τ₁ : Typ} {t : Term} (h : has_type Γ (Term.Lam x τ₁ t) τ) : ∃ τ₂, τ = (τ₁ → τ₂) ∧ has_type (Dict.add Γ x τ₁) t τ₂
:=
begin
  cases h with _ _ _ _ _ _ _ τ₂ _ h',
  use τ₂,
  exact ⟨rfl, h'⟩,
end

lemma inversion_Ap {Γ : Context} {e1 e2 : Term} {τ : Typ} (h : has_type Γ (Term.Ap e1 e2) τ) : ∃ τ₁ τ₂, τ = τ₂ ∧ has_type Γ e1 (τ₁ → τ₂) ∧ has_type Γ e2 τ₁
:=
begin
  cases h with _ _ _ _ _ _ _ _ _ _ _ τ' _ _ _ h1 h2,
  --rcases h with _| _| @⟨a, τ', c, d, e, h1, h2⟩,
  use [τ', τ],
  exact ⟨rfl, ⟨h1, h2⟩⟩,
end

lemma inversion_Nat {Γ : Context} {n : ℕ} {τ : Typ} (h : has_type Γ (Term.Nat n) τ) : τ = Typ.Nat
:=
begin
  cases h,
  refl,
end

lemma inversion_Plus {Γ : Context} {e1 e2 : Term} {τ : Typ} (h : has_type Γ (Term.Plus e1 e2) τ) : τ = Typ.Nat ∧ has_type Γ e1 Typ.Nat ∧ has_type Γ e2 Typ.Nat
:=
begin
  cases h,
  exact ⟨rfl, h_ᾰ, h_ᾰ_1⟩,
end

lemma inversion_Unit {Γ : Context} {n : ℕ} {τ : Typ} (h : has_type Γ (Term.Unit) τ) : τ = Typ.Unit
:=
begin
  cases h,
  refl,
end

lemma free_in_context {x : var} {e : Term} {τ : Typ} {Γ : Context}
  (h : x ∈ e) (h1 : has_type Γ e τ) : Dict.inDict Γ x :=
begin
  induction' h,
  {
    rw Dict.inDict,
    cases h1 with _ _ _ h,
    intro h',
    rw h' at h,
    cases h },
  {
    rcases (inversion_Lam h1) with ⟨τ2, typ_eq, h'⟩,
    specialize ih h',
    simp only [Dict.inDict, Dict.add, Dict.get, h, if_false, ne.def] at ih,
    exact ih,
  },
  {
    rcases inversion_Ap h1 with ⟨τ1, τ2, -, h', -⟩,
    exact ih h',
  },
  {
    rcases inversion_Ap h1 with ⟨τ1, τ2, -, -, h'⟩,
    exact ih h',
  },
  {
    have inv := inversion_Plus h1,
    exact ih inv.2.1,
  },
  {
    have inv := inversion_Plus h1,
    exact ih inv.2.2,
  },
end

-- the next 3 theorems were a 15-312 HW
lemma not_free_correct (x : var) (e : Term) : xor (free_in x e) (not_free_in x e) :=
begin
  rw xor,
  induction e with _ y τ M _ e1 e2 e1_ih e2_ih _ e1 e2 e1_ih e2_ih,
  {
    by_cases x = e,
    {
      left,
      split,
        {
          rw ← h,
          exact free_in.Var x,
        },
        {
          intro h',
          cases h',
          contradiction,
        }
    },
    {
      right,
      split,
      {
        exact not_free_in.Var x e h,
      },
      {
        intro h',
        cases h',
        contradiction,
      },
    },
  },
  {
    cases e_ih,
    {
      by_cases this : x = y,
      {
        right,
        split,
        {
          rw this,
          exact not_free_in.Lam2 y τ M,
        },
        {
          intro h',
          cases h',
          contradiction,
        },
      },
      {
        left,
        split,
        {
          exact free_in.Lam x y τ M this e_ih.1,
        },
        {
          intro h',
          cases h',
          exact e_ih.2 h'_ᾰ_1,
          exact this rfl,
        },
      },
    },
    {
      by_cases this : x = y,
      {
        right,
        split,
        {
          rw this,
          exact not_free_in.Lam2 y τ M,
        },
        {
          intro h',
          cases h',
          contradiction,
        },
      },
      {
        right,
        split,
        {
          exact not_free_in.Lam1 x y τ M this e_ih.1,
        },
        {
          intro h',
          cases h',
          exact e_ih.2 h'_ᾰ_1,
        }
      },
    },
  },
  {
   cases e1_ih,
   cases e2_ih,
   repeat {
    left,
    split,
    {
      exact free_in.Ap1 x e1 e2 e1_ih.1,
    },
    {
      intro h',
      cases h',
      exact e1_ih.2 h'_ᾰ,
    },
   },
  cases e2_ih,
  {
    left,
    split,
    {
      exact free_in.Ap2 x e1 e2 e2_ih.1,
    },
    {
      intro h',
      cases h',
      exact e2_ih.2 h'_ᾰ_1,
    }
  },
  {
    right,
    split,
    {
      exact not_free_in.Ap x e1 e2 e1_ih.1 e2_ih.1,
    },
    {
      intro h',
      cases h',
      exact e1_ih.2 h'_ᾰ,
      exact e2_ih.2 h'_ᾰ,
    },
  },
  },
  {
    right,
    split,
    exact not_free_in.Nat x e,
    intro h',
    cases h',
  },
  {
    cases e1_ih,
    {
      cases e2_ih,
      {
        left,
        split,
        {
          exact free_in.Plus1 x e1 e2 e1_ih.1,
        },
        {
          intro h',
          cases h',
          exact e1_ih.2 h'_ᾰ,
        },
      },
      {
        left,
        split,
        {
          refine free_in.Plus1 x e1 e2 e1_ih.1,
        },
        {
          intro h',
          cases h',
          exact e1_ih.2 h'_ᾰ,
        },
      },
    },
    {
      cases e2_ih,
      {
        left,
        split,
        {
          refine free_in.Plus2 x e1 e2 e2_ih.1,
        },
        {
          intro h',
          cases h',
          exact e2_ih.2 h'_ᾰ_1,
        },
      },
      {
        right,
        split,
        {
          refine not_free_in.Plus x e1 e2 e1_ih.1 e2_ih.1,
        },
        {
          intro h',
          cases h',
          exact e1_ih.2 h'_ᾰ,
          exact e2_ih.2 h'_ᾰ,
        },
      },
    },
  },
  {
    right,
    split,
    exact not_free_in.Unit x,
    intro h',
    cases h',
  },
end

lemma not_free_correct' {x : var} {e : Term} : not_free_in x e ↔ ¬free_in x e :=
begin
  have this := not_free_correct x e,
  rw xor at this,
  split,
  {
    intro h,
    intro h',
    cases this,
    {
      exact this.2 h,
    },
    {
      exact this.2 h',
    },
  },
  {
    intro h,
    cases this,
    {
      exfalso,
      exact h this.1,
    },
    {
      exact this.1,
    },
  },
end

-- you could do this in 1 line from not_free_correct'
-- but it requires double negation elim :pensive:

lemma free_correct {x : var} {e : Term} : free_in x e ↔ ¬ not_free_in x e :=
begin
  have this := not_free_correct x e,
  split,
  {
    intro h,
    cases this,
    {
      exact this.2,
    },
    {
      exfalso,
      exact this.2 h,
    },
  },
  {
    intro h',
    cases this,
    {
      exact this.1,
    },
    {
      exfalso,
      exact h' this.1,
    },
  },
end

lemma subCtxDerive {Γ Γ' : Context} {h : Dict.subDictOf Γ Γ'} {e : Term} {τ : Typ}
  (h1 : has_type Γ e τ) : has_type Γ' e τ
:=
begin
  rw Dict.subDictOf at h,
  induction' e,
  {
    specialize h x,
    unfold has_mem.mem at h,
    by_cases this : Dict.inDict Γ x,
    {
      specialize h this,
      cases h1,
      rw h1_ᾰ at h,
      exact has_type.Var Γ' x τ (eq.symm h),
    },
    {
      cases h1,
      rw Dict.inDict at this,
      specialize h (Dict.getSome h1_ᾰ),
      rw h at h1_ᾰ,
      exact has_type.Var Γ' x τ h1_ᾰ,
    },
  },
  {
    rcases inversion_Lam h1 with ⟨τ₁, ⟨τ_eq, h'⟩⟩,
    rename x_1 τ2,
    specialize @ih (Dict.add Γ x τ2) (Dict.add Γ' x τ2) τ₁,
    suffices : ∀ (k : var), (Dict.inDict (Dict.add Γ x τ2)) k →
                            Dict.get (Dict.add Γ x τ2) k = Dict.get (Dict.add Γ' x  τ2) k, {
      simp only at this,
      specialize ih this,
      rw τ_eq,
      specialize ih h',
      exact has_type.Lam Γ' x τ2 τ₁ e ih,
    },
    intros k kh,
    specialize h k,
    simp only [Dict.get, Dict.add],
    split_ifs with lem,
    { refl },
    {
      unfold has_mem.mem at h,
      suffices : Dict.inDict Γ k, {
        specialize h this,
        repeat {rw Dict.get at h},
        exact h,
      },
      simp only [Dict.add, Dict.inDict, Dict.get, lem, if_false, ne.def] at kh,
      exact kh,
    },
  },
  {
    rcases inversion_Ap h1 with ⟨τ₁, τ₂, ⟨typ_eq, ⟨e1_typ, e2_typ⟩⟩⟩,
    specialize ih_e h e1_typ,
    specialize ih_e_1 h e2_typ,
    rw typ_eq,
    exact has_type.Ap Γ' τ₁ τ₂ e e_1 ih_e ih_e_1,
  },
  {
    cases h1,
    exact has_type.Nat Γ' n,
  },
  {
    cases inversion_Plus h1 with typ_eq inv,
    specialize ih_e h inv.1,
    specialize ih_e_1 h inv.2,
    rw typ_eq,
    exact has_type.Plus Γ' e e_1 ih_e ih_e_1,
  },
  {
    cases h1,
    exact has_type.Unit Γ',
  },
end

lemma contextWeakening {Γ Γ' : Context} {e : Term} {τ : Typ}
  (h1 : Dict.subDictOf Γ Γ') (h2 : has_type Γ e τ) : has_type Γ' e τ
:=
begin
  induction h2 with Γ _ _ h2i _ _ _ _ _ h2i _ _ _ _ _ _ h2 h2' h2'' h2_ih _ _ _ Γ e1 e2 h_e1 h_e2 e1_ih e2_ih,
  {
    refine has_type.Var Γ' h2_x h2_τ _,
    rw Dict.subDictOf at h1,
    specialize h1 h2_x (Dict.getSome h2i),
    rw ← h1,
    exact h2i,
  },
  {
    refine has_type.Lam Γ' h2_x h2_τ₁ h2_τ₂ h2_t₁ _,
    clear h2_ih,
    apply subCtxDerive,
    exact Dict.subDictAdd h1 h2_x h2_τ₁,
    exact h2i,
  },
  {
    specialize h2_ih h1,
    specialize h2'' h1,
    exact has_type.Ap Γ' h2_τ₁ h2_τ₂ h2_e₁ h2_e₂ h2'' h2_ih,
  },
  { exact has_type.Unit Γ', },
  { exact has_type.Nat Γ' h2_n, },
  {
    specialize e1_ih h1,
    specialize e2_ih h1,
    exact has_type.Plus Γ' e1 e2 e1_ih e2_ih,
  }
end

lemma emptyWeak {Γ : Context} {e : Term} {τ : Typ} (h : has_type ctx_Empty e τ) : has_type Γ e τ
  := contextWeakening (Dict.emptySubdictAll Γ) h

lemma substPresTyp {Γ : Context} {x : var} {t v : Term} {τ τ₁: Typ} :
  has_type (Dict.add Γ x τ) t τ₁ -> has_type ctx_Empty v τ -> has_type Γ ([v // x]t) τ₁
:=
begin
  intros h h_v,
  induction' t with y y τ' e,
  {
    rw subst,
    split_ifs with h',
    {
      rw h' at h,
      cases h with _ _ _ h,
      simp only [Dict.get, eq_self_iff_true, if_true] at h,
      rw ← (option.some.inj h),
      exact emptyWeak h_v,
    },
    {
      cases h with _ _ _ h,
      simp only [Dict.get, h', if_false] at h,
      exact has_type.Var Γ y τ₁ h,
    },
  },
  {
    rw subst,
    rcases (inversion_Lam h) with ⟨τ₂, typ_eq, h_inv⟩,
    split_ifs with h',
    {
      rw typ_eq,
      refine has_type.Lam Γ y τ' τ₂ e _,
      rw h' at h_inv,
      suffices : (Dict.add (Dict.add Γ y τ) y τ') = Dict.add Γ y τ', {
        rw ← this,
        exact h_inv,
      },
      simp only [Dict.add],
      funext,
      split_ifs,
      repeat {refl},
    },
    {
       suffices : (Dict.add (Dict.add Γ x τ) y τ') = (Dict.add (Dict.add Γ y τ') x τ), {
        rw this at h_inv,
        specialize ih h_v h_inv,
        rw typ_eq,
        exact has_type.Lam Γ y τ' τ₂ ([v//x]e) ih,
      },
      simp only [Dict.add],
      funext,
      split_ifs,
      {
        rw h_2 at h_1,
        exfalso,
        exact h' h_1,
      },
      repeat {refl},
    },
  },
  {
    rcases inversion_Ap h with ⟨τ₁, τ₂, ⟨inv_L, inv_M, inv_R⟩⟩,
    specialize ih_t h_v inv_M,
    specialize ih_t_1 h_v inv_R,
    rw inv_L,
    rw subst,
    exact has_type.Ap Γ τ₁ τ₂ ([v//x]t) ([v//x]t_1) ih_t ih_t_1,
  },
  {
    cases h,
    exact has_type.Nat Γ n,
  },
  {
    cases inversion_Plus h with typ_eq inv,
    rw subst,
    specialize ih_t h_v inv.1,
    specialize ih_t_1 h_v inv.2,
    rw typ_eq,
    exact has_type.Plus Γ ([v//x]t) ([v//x]t_1) ih_t ih_t_1,
  },
  {
    cases h,
    exact has_type.Unit Γ,
  },
end

theorem preservation {e e' : Term} {τ : Typ}
(h1 : has_type ctx_Empty e τ) (h2 : e ↦ e') : has_type ctx_Empty e' τ :=
begin
  induction' h2 with _ _ _ _ h' _ _ _ ih1 ih2,
  {
    cases h1 with _ _ _ _ _ _ _ _ _ _ _ τ1 _ _ _  h' h'',
    have inv := inversion_Lam h',
    rcases inv with ⟨τ₂, typ_eq, h_e⟩,
    rw ← (fn_typ_eq typ_eq).2 at h_e,
    rw (fn_typ_eq typ_eq).1 at h'',
    exact substPresTyp h_e h'',
  },
  {
    have inv := inversion_Ap h1,
    rcases inv with ⟨τ₁, τ₂, inv⟩,
    specialize ih2 inv.2.1,
    rw inv.1,
    exact has_type.Ap ⬝ τ₁ τ₂ e' e2 ih2 inv.2.2,
  },
  {
    have inv := inversion_Ap h1,
    rcases inv with ⟨τ₁, τ₂, inv⟩,
    specialize ih inv.2.2,
    rw inv.1,
    refine has_type.Ap ⬝ τ₁ τ₂ e1 e' inv.2.1 ih,
  },
  {
    cases inversion_Plus h1 with typ_eq inv,
    specialize ih inv.1,
    rw typ_eq,
    exact has_type.Plus ⬝ e' e2 ih inv.2,
  },
  {
    cases inversion_Plus h1 with typ_eq inv,
    specialize ih inv.2,
    rw typ_eq,
    exact has_type.Plus ⬝ e1 e' inv.1 ih,
  },
  {
    cases inversion_Plus h1 with typ_eq inv,
    rw typ_eq,
    exact has_type.Nat ⬝ (n + m),
  }
end


/- Author: E.W.Ayers © 2019 -/
import .engine .policy
import algebra.group_power
import tactic.ring
/-  The `equate` tactic. -/

namespace robot

meta def equate_user_attr : user_attribute rule_table unit :=
{ name := `equate
, descr := "add the given lemma to equate's rule-table."
, cache_cfg :=
    { mk_cache := rule_table.of_names
    , dependencies := []
    }
}

meta def get_equate_rule_table : tactic rule_table :=
    user_attribute.get_cache equate_user_attr

run_cmd attribute.register `robot.equate_user_attr

/-- Solves simple equalities using lemmas tagged with `equate`. -/
meta def equate (names : list name := []) := do
    base ← get_equate_rule_table,
    bonus ← rule_table.of_names names,
    all ← rule_table.join bonus base,
    tactic.timetac "time: " $ robot.run robot.simple_policy all

/- DEFAULT RULES: -/

attribute [equate] mul_assoc
attribute [equate] mul_comm
attribute [equate] mul_left_inv
attribute [equate] mul_right_inv
attribute [equate] one_mul
attribute [equate] mul_one
attribute [equate] inv_inv
@[equate] lemma mul_inv {G:Type*} [group G] {a b : G} : (a * b) ⁻¹ = b⁻¹ * a⁻¹ := by simp

attribute [equate] pow_succ
attribute [equate] pow_zero
@[equate] lemma nat_succ_is_nat_plus_one {n} : nat.succ n = n + 1 := rfl

attribute [equate] add_assoc
attribute [equate] add_left_neg
attribute [equate] add_right_neg
attribute [equate] zero_add
attribute [equate] add_zero
attribute [equate] add_comm
attribute [equate] neg_add
attribute [equate] neg_neg

@[equate] lemma one_plus_one_is_two : 1 + 1 = 2 := rfl

attribute [equate] sub_self
attribute [equate] sub_eq_add_neg
attribute [equate] zero_sub
attribute [equate] sub_zero
attribute [equate] sub_neg_eq_add
-- attribute [equate] add_sub_assoc -- [NOTE] commented out because it short-circuits an exampleproof

attribute [equate] left_distrib
attribute [equate] right_distrib
attribute [equate] mul_zero
attribute [equate] zero_mul
attribute [equate] neg_mul_eq_neg_mul
attribute [equate] neg_mul_eq_mul_neg
attribute [equate] neg_mul_neg
attribute [equate] neg_mul_comm
attribute [equate] mul_sub_left_distrib
attribute [equate] mul_sub_right_distrib

@[equate] lemma comp_def {α β γ : Type*} {f : α → β} {g : β → γ} {x : α} : (g ∘ f) x = g (f x) := rfl

/- Additional equalities for rings.
   These are needed because `equate` does not unfold definitions.
 -/
namespace ring_theory
    universe u
    variables {R : Type u} [comm_ring R] {x y z a b c : R}
    @[equate] def P1 : x ^ 0 = 1 := rfl
    @[equate] def P2 {n} : x ^ (nat.succ n) = x * x ^ n := rfl
    @[equate] def X2 : 2 * x = x + x  := by ring
end ring_theory

/- Some equalities for set theory. -/
namespace set_rules
    universe u
    variables {α : Type u} {A B C : set α}
    def ext : (∀ a, a ∈ A ↔ a ∈ B) → A = B := begin intro, funext, rw <-iff_eq_eq, apply a x end
    @[equate] def A1 : A \ B = A ∩ (- B) := rfl
    @[equate] def A2 : - ( B ∩ C ) = -B ∪ -C := ext $ λ a, ⟨λ h, classical.by_cases (λ aB, classical.by_cases (λ aC, absurd (and.intro aB aC) h) or.inr ) or.inl,λ h, or.cases_on h (λ h ⟨ab,_⟩, absurd ab h) (λ h ⟨_,ac⟩, absurd ac h)⟩
    @[equate] def A3 :  - ( B ∪ C ) = - B ∩ - C := ext $ λ a, ⟨λ h, ⟨h ∘ or.inl,h ∘ or.inr⟩, λ ⟨x,y⟩ h₂, or.cases_on h₂ x y⟩
    @[equate] def A4 : B ∩ C = C ∩ B := ext $ λ a, ⟨and.swap,and.swap⟩
    @[equate] def A5 : B ∪ C = C ∪ B := ext $ λ a, ⟨or.swap, or.swap⟩
    @[equate] def A6 : A ∪ (B ∩ C) = (A ∪ B) ∩ (A ∪ C) := ext $ λ a, ⟨λ h, or.cases_on h (λ h, ⟨or.inl h, or.inl h⟩) (λ ⟨b,c⟩, ⟨or.inr b, or.inr c⟩),λ ⟨ab,ac⟩, or.cases_on ab or.inl $ λ b, or.cases_on ac or.inl $ λ c, or.inr ⟨b,c⟩⟩ -- [NOTE] use mathlib, don't be macochistic.
    @[equate] def A7 : A ∩ (B ∪ C) = (A ∩ B) ∪ (A ∩ C) := ext $ λ a, ⟨λ ⟨a,bc⟩,or.cases_on bc (λ b, or.inl ⟨a,b⟩) (λ c, or.inr ⟨a,c⟩), λ h, or.cases_on h (λ ⟨a,b⟩, ⟨a,or.inl b⟩) (λ ⟨a,c⟩, ⟨a,or.inr c⟩)⟩
    @[equate] def A8 : (A ∩ B) ∩ C = A ∩ (B ∩ C)  := ext $ λ a, and.assoc
    @[equate] def A9 : (A ∪ B) ∪ C = A ∪ (B ∪ C)  := ext $ λ a, or.assoc
    @[equate] def A10 : A ∪ ∅ = A := ext $ λ _, or_false _
    @[equate] def A11 : A ∩ ∅ = ∅ := ext $ λ _, and_false _
    @[equate] def A12 : A ∪ set.univ = set.univ := ext $ λ _, or_true _
    @[equate] def A13 : A ∩ set.univ = A := ext $ λ _, and_true _
    @[equate] def A14 : A ∩ A = A := ext $ λ a, ⟨λ ⟨x,y⟩, x, λ x, ⟨x,x⟩⟩
    @[equate] def A15 : A ∪ A = A := ext $ λ a, ⟨λ xy, or.rec_on xy id id, or.inl⟩
    @[equate] def A16 : A \ A = ∅ := ext $ λ a, ⟨λ ⟨x,y⟩, y x, λ x, false.rec_on _ x⟩

end set_rules
namespace list_theory

end list_theory

-- run_cmd (get_equate_rule_table >>= tactic.trace)

end robot


/-
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
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.big_operators.basic
import Mathlib.data.finset.intervals
import Mathlib.PostPort

universes u_1 v

namespace Mathlib

/-!
# Results about big operators over intervals

We prove results about big operators over intervals (mostly the `ℕ`-valued `Ico m n`).
-/

namespace finset

theorem sum_Ico_add {δ : Type u_1} [add_comm_monoid δ] (f : ℕ → δ) (m : ℕ) (n : ℕ) (k : ℕ) :
    (finset.sum (Ico m n) fun (l : ℕ) => f (k + l)) =
        finset.sum (Ico (m + k) (n + k)) fun (l : ℕ) => f l :=
  Eq.subst (Ico.image_add m n k) Eq.symm
    (sum_image
      fun (x : ℕ) (hx : x ∈ Ico m n) (y : ℕ) (hy : y ∈ Ico m n) (h : k + x = k + y) =>
        nat.add_left_cancel h)

theorem prod_Ico_add {β : Type v} [comm_monoid β] (f : ℕ → β) (m : ℕ) (n : ℕ) (k : ℕ) :
    (finset.prod (Ico m n) fun (l : ℕ) => f (k + l)) =
        finset.prod (Ico (m + k) (n + k)) fun (l : ℕ) => f l :=
  sum_Ico_add f m n k

theorem sum_Ico_succ_top {δ : Type u_1} [add_comm_monoid δ] {a : ℕ} {b : ℕ} (hab : a ≤ b)
    (f : ℕ → δ) :
    (finset.sum (Ico a (b + 1)) fun (k : ℕ) => f k) =
        (finset.sum (Ico a b) fun (k : ℕ) => f k) + f b :=
  sorry

theorem prod_Ico_succ_top {β : Type v} [comm_monoid β] {a : ℕ} {b : ℕ} (hab : a ≤ b) (f : ℕ → β) :
    (finset.prod (Ico a (b + 1)) fun (k : ℕ) => f k) =
        (finset.prod (Ico a b) fun (k : ℕ) => f k) * f b :=
  sum_Ico_succ_top hab fun (k : ℕ) => f k

theorem sum_eq_sum_Ico_succ_bot {δ : Type u_1} [add_comm_monoid δ] {a : ℕ} {b : ℕ} (hab : a < b)
    (f : ℕ → δ) :
    (finset.sum (Ico a b) fun (k : ℕ) => f k) =
        f a + finset.sum (Ico (a + 1) b) fun (k : ℕ) => f k :=
  sorry

theorem prod_eq_prod_Ico_succ_bot {β : Type v} [comm_monoid β] {a : ℕ} {b : ℕ} (hab : a < b)
    (f : ℕ → β) :
    (finset.prod (Ico a b) fun (k : ℕ) => f k) =
        f a * finset.prod (Ico (a + 1) b) fun (k : ℕ) => f k :=
  sum_eq_sum_Ico_succ_bot hab fun (k : ℕ) => f k

theorem prod_Ico_consecutive {β : Type v} [comm_monoid β] (f : ℕ → β) {m : ℕ} {n : ℕ} {k : ℕ}
    (hmn : m ≤ n) (hnk : n ≤ k) :
    ((finset.prod (Ico m n) fun (i : ℕ) => f i) * finset.prod (Ico n k) fun (i : ℕ) => f i) =
        finset.prod (Ico m k) fun (i : ℕ) => f i :=
  Eq.subst (Ico.union_consecutive hmn hnk) Eq.symm (prod_union (Ico.disjoint_consecutive m n k))

theorem sum_range_add_sum_Ico {β : Type v} [add_comm_monoid β] (f : ℕ → β) {m : ℕ} {n : ℕ}
    (h : m ≤ n) :
    ((finset.sum (range m) fun (k : ℕ) => f k) + finset.sum (Ico m n) fun (k : ℕ) => f k) =
        finset.sum (range n) fun (k : ℕ) => f k :=
  Ico.zero_bot m ▸ Ico.zero_bot n ▸ sum_Ico_consecutive f (nat.zero_le m) h

theorem sum_Ico_eq_add_neg {δ : Type u_1} [add_comm_group δ] (f : ℕ → δ) {m : ℕ} {n : ℕ}
    (h : m ≤ n) :
    (finset.sum (Ico m n) fun (k : ℕ) => f k) =
        (finset.sum (range n) fun (k : ℕ) => f k) + -finset.sum (range m) fun (k : ℕ) => f k :=
  sorry

theorem sum_Ico_eq_sub {δ : Type u_1} [add_comm_group δ] (f : ℕ → δ) {m : ℕ} {n : ℕ} (h : m ≤ n) :
    (finset.sum (Ico m n) fun (k : ℕ) => f k) =
        (finset.sum (range n) fun (k : ℕ) => f k) - finset.sum (range m) fun (k : ℕ) => f k :=
  sorry

theorem sum_Ico_eq_sum_range {β : Type v} [add_comm_monoid β] (f : ℕ → β) (m : ℕ) (n : ℕ) :
    (finset.sum (Ico m n) fun (k : ℕ) => f k) =
        finset.sum (range (n - m)) fun (k : ℕ) => f (m + k) :=
  sorry

theorem prod_Ico_reflect {β : Type v} [comm_monoid β] (f : ℕ → β) (k : ℕ) {m : ℕ} {n : ℕ}
    (h : m ≤ n + 1) :
    (finset.prod (Ico k m) fun (j : ℕ) => f (n - j)) =
        finset.prod (Ico (n + 1 - m) (n + 1 - k)) fun (j : ℕ) => f j :=
  sorry

theorem sum_Ico_reflect {δ : Type u_1} [add_comm_monoid δ] (f : ℕ → δ) (k : ℕ) {m : ℕ} {n : ℕ}
    (h : m ≤ n + 1) :
    (finset.sum (Ico k m) fun (j : ℕ) => f (n - j)) =
        finset.sum (Ico (n + 1 - m) (n + 1 - k)) fun (j : ℕ) => f j :=
  prod_Ico_reflect f k h

theorem prod_range_reflect {β : Type v} [comm_monoid β] (f : ℕ → β) (n : ℕ) :
    (finset.prod (range n) fun (j : ℕ) => f (n - 1 - j)) =
        finset.prod (range n) fun (j : ℕ) => f j :=
  sorry

theorem sum_range_reflect {δ : Type u_1} [add_comm_monoid δ] (f : ℕ → δ) (n : ℕ) :
    (finset.sum (range n) fun (j : ℕ) => f (n - 1 - j)) = finset.sum (range n) fun (j : ℕ) => f j :=
  prod_range_reflect f n

@[simp] theorem prod_Ico_id_eq_factorial (n : ℕ) :
    (finset.prod (Ico 1 (n + 1)) fun (x : ℕ) => x) = nat.factorial n :=
  sorry

@[simp] theorem prod_range_add_one_eq_factorial (n : ℕ) :
    (finset.prod (range n) fun (x : ℕ) => x + 1) = nat.factorial n :=
  sorry

/-- Gauss' summation formula -/
theorem sum_range_id_mul_two (n : ℕ) :
    (finset.sum (range n) fun (i : ℕ) => i) * bit0 1 = n * (n - 1) :=
  sorry

/-- Gauss' summation formula -/
theorem sum_range_id (n : ℕ) : (finset.sum (range n) fun (i : ℕ) => i) = n * (n - 1) / bit0 1 :=
  sorry

end Mathlib


/-
Copyright (c) 2021 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov
-/
import measure_theory.measure.lebesgue
import number_theory.liouville.residual
import number_theory.liouville.liouville_with
import analysis.p_series

/-!
# Volume of the set of Liouville numbers

In this file we prove that the set of Liouville numbers with exponent (irrationality measure)
strictly greater than two is a set of Lebesuge measure zero, see
`volume_Union_set_of_liouville_with`.

Since this set is a residual set, we show that the filters `residual` and `volume.ae` are disjoint.
These filters correspond to two common notions of genericity on `ℝ`: residual sets and sets of full
measure. The fact that the filters are disjoint means that two mutually exclusive properties can be
“generic” at the same time (in the sense of different “genericity” filters).

## Tags

Liouville number, Lebesgue measure, residual, generic property
-/

open_locale filter big_operators ennreal topological_space nnreal
open filter set metric measure_theory real

lemma set_of_liouville_with_subset_aux :
  {x : ℝ | ∃ p > 2, liouville_with p x} ⊆
    ⋃ m : ℤ, (λ x : ℝ, x + m) ⁻¹' (⋃ n > (0 : ℕ),
      {x : ℝ | ∃ᶠ b : ℕ in at_top, ∃ a ∈ finset.Icc (0 : ℤ) b,
        |x - (a : ℤ) / b| < 1 / b ^ (2 + 1 / n : ℝ)}) :=
begin
  rintro x ⟨p, hp, hxp⟩,
  rcases exists_nat_one_div_lt (sub_pos.2 hp) with ⟨n, hn⟩,
  rw lt_sub_iff_add_lt' at hn,
  suffices : ∀ y : ℝ, liouville_with p y → y ∈ Ico (0 : ℝ) 1 →
    ∃ᶠ b : ℕ in at_top, ∃ a ∈ finset.Icc (0 : ℤ) b, |y - a / b| < 1 / b ^ (2 + 1 / (n + 1) : ℝ),
  { simp only [mem_Union, mem_preimage],
    have hx : x + ↑(-⌊x⌋) ∈ Ico (0 : ℝ) 1,
    { simp only [int.floor_le, int.lt_floor_add_one, add_neg_lt_iff_le_add', zero_add, and_self,
        mem_Ico, int.cast_neg, le_add_neg_iff_add_le] },
    refine ⟨-⌊x⌋, n + 1, n.succ_pos, this _ (hxp.add_int _) hx⟩ },
  clear hxp x, intros x hxp hx01,
  refine ((hxp.frequently_lt_rpow_neg hn).and_eventually (eventually_ge_at_top 1)).mono _,
  rintro b ⟨⟨a, hne, hlt⟩, hb⟩,
  rw [rpow_neg b.cast_nonneg, ← one_div] at hlt,
  refine ⟨a, _, hlt⟩,
  replace hb : (1 : ℝ) ≤ b, from nat.one_le_cast.2 hb,
  have hb0 : (0 : ℝ) < b := zero_lt_one.trans_le hb,
  replace hlt : |x - a / b| < 1 / b,
  { refine hlt.trans_le (one_div_le_one_div_of_le hb0 _),
    calc (b : ℝ) = b ^ (1 : ℝ) : (rpow_one _).symm
    ... ≤ b ^ (2 + 1 / (n + 1) : ℝ) : rpow_le_rpow_of_exponent_le hb (one_le_two.trans _),
    simpa using n.cast_add_one_pos.le },
  rw [sub_div' _ _ _ hb0.ne', abs_div, abs_of_pos hb0, div_lt_div_right hb0,
    abs_sub_lt_iff, sub_lt_iff_lt_add, sub_lt_iff_lt_add, ← sub_lt_iff_lt_add'] at hlt,
  rw [finset.mem_Icc, ← int.lt_add_one_iff, ← int.lt_add_one_iff, ← neg_lt_iff_pos_add, add_comm,
    ← @int.cast_lt ℝ, ← @int.cast_lt ℝ], push_cast,
  refine ⟨lt_of_le_of_lt _ hlt.1, hlt.2.trans_le _⟩,
  { simp only [mul_nonneg hx01.left b.cast_nonneg, neg_le_sub_iff_le_add, le_add_iff_nonneg_left] },
  { rw [add_le_add_iff_left],
    calc x * b ≤ 1 * b : mul_le_mul_of_nonneg_right hx01.2.le hb0.le
    ... = b : one_mul b }
end

/-- The set of numbers satisfying the Liouville condition with some exponent `p > 2` has Lebesgue
measure zero. -/
@[simp] lemma volume_Union_set_of_liouville_with :
  volume (⋃ (p : ℝ) (hp : 2 < p), {x : ℝ | liouville_with p x}) = 0 :=
begin
  simp only [← set_of_exists],
  refine measure_mono_null set_of_liouville_with_subset_aux _,
  rw measure_Union_null_iff, intro m, rw real.volume_preimage_add_right, clear m,
  refine (measure_bUnion_null_iff $ countable_encodable _).2 (λ n (hn : 1 ≤ n), _),
  generalize hr : (2 + 1 / n : ℝ) = r,
  replace hr : 2 < r, by simp [← hr, zero_lt_one.trans_le hn], clear hn n,
  refine measure_set_of_frequently_eq_zero _,
  simp only [set_of_exists, ← real.dist_eq, ← mem_ball, set_of_mem_eq],
  set B : ℤ → ℕ → set ℝ := λ a b, ball (a / b) (1 / b ^ r),
  have hB : ∀ a b, volume (B a b) = ↑(2 / b ^ r : ℝ≥0),
  { intros a b, simp only [B, real.volume_ball],
    rw [ennreal.of_real, mul_one_div, to_nnreal_div zero_le_two, to_nnreal_bit0 zero_le_one,
      to_nnreal_one, to_nnreal_rpow_of_nonneg (nat.cast_nonneg _), nnreal.to_nnreal_coe_nat] },
  have : ∀ b : ℕ, volume (⋃ a ∈ finset.Icc (0 : ℤ) b, B a b) ≤ (2 * (b ^ (1 - r) + b ^ (-r)) : ℝ≥0),
  { intro b,
    calc volume (⋃ a ∈ finset.Icc (0 : ℤ) b, B a b)
        ≤ ∑ a in finset.Icc (0 : ℤ) b, volume (B a b) : measure_bUnion_finset_le _ _
    ... = ((b + 1) * (2 / b ^ r) : ℝ≥0) :
      by simp only [hB, int.card_Icc, finset.sum_const, nsmul_eq_mul, sub_zero,
        ← int.coe_nat_succ, int.to_nat_coe_nat, ← nat.cast_succ, ennreal.coe_mul, ennreal.coe_nat]
    ... = _ : _,
    have : 1 - r ≠ 0, by linarith,
    rw [ennreal.coe_eq_coe],
    simp [add_mul, div_eq_mul_inv, nnreal.rpow_neg, nnreal.rpow_sub' _ this, mul_add,
      mul_left_comm] },
  refine ne_top_of_le_ne_top (ennreal.tsum_coe_ne_top_iff_summable.2 _)
    (ennreal.tsum_le_tsum this),
  refine (summable.add _ _).mul_left _; simp only [nnreal.summable_rpow]; linarith
end

lemma ae_not_liouville_with : ∀ᵐ x, ∀ p > (2 : ℝ), ¬liouville_with p x :=
by simpa only [ae_iff, not_forall, not_not, set_of_exists]
  using volume_Union_set_of_liouville_with

lemma ae_not_liouville : ∀ᵐ x, ¬liouville x :=
ae_not_liouville_with.mono $ λ x h₁ h₂, h₁ 3 (by norm_num) (h₂.liouville_with 3)

/-- The set of Liouville numbers has Lebesgue measure zero. -/
@[simp] lemma volume_set_of_liouville : volume {x : ℝ | liouville x} = 0 :=
by simpa only [ae_iff, not_not] using ae_not_liouville

/-- The filters `residual ℝ` and `volume.ae` are disjoint. This means that there exists a residual
set of Lebesgue measure zero (e.g., the set of Liouville numbers). -/
lemma real.disjoint_residual_ae : disjoint (residual ℝ) volume.ae :=
disjoint_of_disjoint_of_mem disjoint_compl_right eventually_residual_liouville ae_not_liouville


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

! This file was ported from Lean 3 source module data.finset.pimage
! leanprover-community/mathlib commit f7fc89d5d5ff1db2d1242c7bb0e9062ce47ef47c
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Finset.Option
import Mathlib.Data.PFun
import Mathlib.Data.Part

/-!
# Image of a `Finset α` under a partially defined function

In this file we define `Part.toFinset` and `Finset.pimage`. We also prove some trivial lemmas about
these definitions.

## Tags

finite set, image, partial function
-/

variable {α β : Type _}

namespace Part

/-- Convert a `o : Part α` with decidable `Part.Dom o` to `Finset α`. -/
def toFinset (o : Part α) [Decidable o.Dom] : Finset α :=
  o.toOption.toFinset
#align part.to_finset Part.toFinset

@[simp]
theorem mem_toFinset {o : Part α} [Decidable o.Dom] {x : α} : x ∈ o.toFinset ↔ x ∈ o := by
  simp [toFinset]
#align part.mem_to_finset Part.mem_toFinset

@[simp]
theorem toFinset_none [Decidable (none : Part α).Dom] : none.toFinset = (∅ : Finset α) := by
  simp [toFinset]
#align part.to_finset_none Part.toFinset_none

@[simp]
theorem toFinset_some {a : α} [Decidable (some a).Dom] : (some a).toFinset = {a} := by
  simp [toFinset]
#align part.to_finset_some Part.toFinset_some

@[simp]
theorem coe_toFinset (o : Part α) [Decidable o.Dom] : (o.toFinset : Set α) = { x | x ∈ o } :=
  Set.ext fun _ => mem_toFinset
#align part.coe_to_finset Part.coe_toFinset

end Part

namespace Finset

variable [DecidableEq β] {f g : α →. β} [∀ x, Decidable (f x).Dom] [∀ x, Decidable (g x).Dom]
  {s t : Finset α} {b : β}

/-- Image of `s : Finset α` under a partially defined function `f : α →. β`. -/
noncomputable def pimage (f : α →. β) [∀ x, Decidable (f x).Dom] (s : Finset α) : Finset β :=
  s.bunionᵢ fun x => (f x).toFinset
#align finset.pimage Finset.pimage

@[simp]
theorem mem_pimage : b ∈ s.pimage f ↔ ∃ a ∈ s, b ∈ f a := by
  simp [pimage]
#align finset.mem_pimage Finset.mem_pimage

@[simp, norm_cast]
theorem coe_pimage : (s.pimage f : Set β) = f.image s :=
  Set.ext fun _ => mem_pimage
#align finset.coe_pimage Finset.coe_pimage

@[simp]
theorem pimage_some (s : Finset α) (f : α → β) [∀ x, Decidable (Part.some <| f x).Dom] :
    (s.pimage fun x => Part.some (f x)) = s.image f := by
  ext
  simp [eq_comm]
#align finset.pimage_some Finset.pimage_some

theorem pimage_congr (h₁ : s = t) (h₂ : ∀ x ∈ t, f x = g x) : s.pimage f = t.pimage g := by
  subst s
  ext y
  -- Porting note: `←exists_prop` required because `∃ x ∈ s, p x` is defined differently
  simp (config := { contextual := true }) only [mem_pimage, ←exists_prop, h₂]
#align finset.pimage_congr Finset.pimage_congr

/-- Rewrite `s.pimage f` in terms of `Finset.filter`, `Finset.attach`, and `Finset.image`. -/
theorem pimage_eq_image_filter : s.pimage f =
    (filter (fun x => (f x).Dom) s).attach.image
      fun x : { x // x ∈ filter (fun x => (f x).Dom) s } =>
        (f x).get (mem_filter.mp x.coe_prop).2 := by
  ext x
  simp [Part.mem_eq, And.exists]
  -- Porting note: `←exists_prop` required because `∃ x ∈ s, p x` is defined differently
  simp only [←exists_prop]
#align finset.pimage_eq_image_filter Finset.pimage_eq_image_filter

theorem pimage_union [DecidableEq α] : (s ∪ t).pimage f = s.pimage f ∪ t.pimage f :=
  coe_inj.1 <| by
  simp only [coe_pimage, coe_union, ← PFun.image_union]
#align finset.pimage_union Finset.pimage_union

@[simp]
theorem pimage_empty : pimage f ∅ = ∅ := by
  ext
  simp
#align finset.pimage_empty Finset.pimage_empty

theorem pimage_subset {t : Finset β} : s.pimage f ⊆ t ↔ ∀ x ∈ s, ∀ y ∈ f x, y ∈ t := by
  simp [subset_iff, @forall_swap _ β]
#align finset.pimage_subset Finset.pimage_subset

@[mono]
theorem pimage_mono (h : s ⊆ t) : s.pimage f ⊆ t.pimage f :=
  pimage_subset.2 fun x hx _ hy => mem_pimage.2 ⟨x, h hx, hy⟩
#align finset.pimage_mono Finset.pimage_mono

theorem pimage_inter [DecidableEq α] : (s ∩ t).pimage f ⊆ s.pimage f ∩ t.pimage f := by
  simp only [← coe_subset, coe_pimage, coe_inter, PFun.image_inter]
#align finset.pimage_inter Finset.pimage_inter

end Finset


/-
Copyright (c) 2020 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel, Mario Carneiro
-/
import Qq.MetaM
import Mathlib.Logic.Nontrivial
import Mathlib.Tactic.SolveByElim

/-! # The `nontriviality` tactic. -/

namespace Mathlib.Tactic.Nontriviality
open Lean Elab Meta Tactic Linter Std.Linter UnreachableTactic Qq

/-- The `@[nontriviality]` simp set is used by the `nontriviality` tactic to automatically
discharge theorems about the trivial case (where we know `Subsingleton α` and many theorems
in e.g. groups are trivially true). -/
register_simp_attr nontriviality

theorem subsingleton_or_nontrivial_elim {p : Prop} {α : Type u}
    (h₁ : Subsingleton α → p) (h₂ : Nontrivial α → p) : p :=
  (subsingleton_or_nontrivial α).elim @h₁ @h₂

/--
Tries to generate a `Nontrivial α` instance by performing case analysis on
`subsingleton_or_nontrivial α`,
attempting to discharge the subsingleton branch using lemmas with `@[nontriviality]` attribute,
including `Subsingleton.le` and `eq_iff_true_of_subsingleton`.
-/
def nontrivialityByElim (α : Q(Type u)) (g : MVarId) (simpArgs : Array Syntax) : MetaM MVarId := do
  let p : Q(Prop) ← g.getType
  guard (← inferType p).isProp
  let g₁ ← mkFreshExprMVarQ q(Subsingleton $α → $p)
  let (_, g₁') ← g₁.mvarId!.intro1
  g₁'.withContext try
    -- FIXME: restore after lean4#2054 is fixed
    -- g₁'.inferInstance <|> do
    (do g₁'.assign (← synthInstance (← g₁'.getType))) <|> do
      let simpArgs := simpArgs.push (Unhygienic.run `(Parser.Tactic.simpLemma| nontriviality))
      let stx := open TSyntax.Compat in Unhygienic.run `(tactic| simp [$simpArgs,*])
      let ([], _) ← runTactic g₁' stx | failure
  catch _ => throwError
    "Could not prove goal assuming `{q(Subsingleton $α)}`\n{MessageData.ofGoal g₁'}"
  let g₂ : Q(Nontrivial $α → $p) ← mkFreshExprMVarQ q(Nontrivial $α → $p)
  g.assign q(subsingleton_or_nontrivial_elim $g₁ $g₂)
  pure g₂.mvarId!

/--
Tries to generate a `nontrivial α` instance using `nontrivial_of_ne` or `nontrivial_of_lt`
and local hypotheses.
-/
def nontrivialityByAssumption (g : MVarId) : MetaM Unit := do
  g.inferInstance <|> do
    _ ← SolveByElim.solveByElim.processSyntax {maxDepth := 6}
      false false [← `(nontrivial_of_ne), ← `(nontrivial_of_lt)] [] #[] [g]

/-- Attempts to generate a `Nontrivial α` hypothesis.

The tactic first looks for an instance using `infer_instance`.

If the goal is an (in)equality, the type `α` is inferred from the goal.
Otherwise, the type needs to be specified in the tactic invocation, as `nontriviality α`.

The `nontriviality` tactic will first look for strict inequalities amongst the hypotheses,
and use these to derive the `Nontrivial` instance directly.

Otherwise, it will perform a case split on `Subsingleton α ∨ Nontrivial α`, and attempt to discharge
the `Subsingleton` goal using `simp [lemmas, nontriviality]`, where `[lemmas]` is a list of
additional `simp` lemmas that can be passed to `nontriviality` using the syntax
`nontriviality α using [lemmas]`.

```
example {R : Type} [OrderedRing R] {a : R} (h : 0 < a) : 0 < a := by
  nontriviality -- There is now a `nontrivial R` hypothesis available.
  assumption
```

```
example {R : Type} [CommRing R] {r s : R} : r * s = s * r := by
  nontriviality -- There is now a `nontrivial R` hypothesis available.
  apply mul_comm
```

```
example {R : Type} [OrderedRing R] {a : R} (h : 0 < a) : (2 : ℕ) ∣ 4 := by
  nontriviality R -- there is now a `nontrivial R` hypothesis available.
  dec_trivial
```

```
def myeq {α : Type} (a b : α) : Prop := a = b

example {α : Type} (a b : α) (h : a = b) : myeq a b := by
  success_if_fail nontriviality α -- Fails
  nontriviality α using [myeq] -- There is now a `nontrivial α` hypothesis available
  assumption
```
-/
syntax (name := nontriviality) "nontriviality" (ppSpace (colGt term))?
  (" using " Parser.Tactic.simpArg,+)? : tactic

/-- Elaborator for the `nontriviality` tactic. -/
@[tactic nontriviality] def elabNontriviality : Tactic := fun stx => do
    let g ← getMainGoal
    let α ← match stx[1].getOptional? with
    | some e => Term.elabType e
    | none => (do
      let mut tgt ← withReducible g.getType'
      if let some tgt' := tgt.not? then tgt ← withReducible (whnf tgt')
      if let some (α, _) := tgt.eq? then return α
      if let some (α, _) := tgt.app4? ``LE.le then return α
      if let some (α, _) := tgt.app4? ``LT.lt then return α
      throwError "The goal is not an (in)equality, so you'll need to specify the desired {""
        }`Nontrivial α` instance by invoking `nontriviality α`.")
    let .sort (.succ u) ← whnf (← inferType α) | throwError "not a type{indentExpr α}"
    let α : Q(Type u) := α
    let tac := do
      let ty := q(Nontrivial $α)
      let m ← mkFreshExprMVar (some ty)
      nontrivialityByAssumption m.mvarId!
      g.assert `inst ty m
    let g ← liftM <| tac <|> nontrivialityByElim α g stx[2][1].getSepArgs
    replaceMainGoal [(← g.intro1).2]


/-
Copyright (c) 2020 Ruben Van de Velde. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
-/
import Mathlib.Data.Int.Order.Units
import Mathlib.NumberTheory.Zsqrtd.Basic
import Mathlib.RingTheory.Prime
import Flt.Primes

theorem Zsqrtd.exists {d : ℤ} (a : ℤ√d) (him : a.im ≠ 0) :
    ∃ c : ℤ√d, a.norm = c.norm ∧ 0 ≤ c.re ∧ c.im ≠ 0 :=
  by
  cases' le_or_lt a.re 0 with hre hre
  · use -a
    simp only [hre, him, Zsqrtd.norm_neg, eq_self_iff_true, Zsqrtd.neg_im, Zsqrtd.neg_re,
      and_self_iff, neg_nonneg, Ne.def, not_false_iff, neg_eq_zero]
  · use a
    simp only [hre.le, him, eq_self_iff_true, and_self_iff, Ne.def, not_false_iff]
#align zsqrtd.exists Zsqrtd.exists

-- Edwards p49 step (2')
theorem factors2 {a : ℤ√(-3)} (heven : Even a.norm) : ∃ b : ℤ√(-3), a.norm = 4 * b.norm :=
  by
  have hparity : Even a.re ↔ Even a.im := by
    simpa [two_ne_zero, Zsqrtd.norm_def, parity_simps] using heven
  simp only [iff_iff_and_or_not_and_not, ← Int.odd_iff_not_even] at hparity
  obtain ⟨⟨c, hc⟩, ⟨d, hd⟩⟩ | ⟨hre, him⟩ := hparity
  · use ⟨c, d⟩
    simp only [Zsqrtd.norm_def, hc, hd]
    ring
  · cases' Int.four_dvd_add_or_sub_of_odd hre him with h4 h4
    · obtain ⟨v, hv⟩ := h4
      use ⟨v - a.im, v⟩
      rw [eq_comm, ← sub_eq_iff_eq_add] at hv
      simp only [Zsqrtd.norm_def, ← hv]
      ring
    · obtain ⟨v, hv⟩ := h4
      use ⟨v + a.im, v⟩
      rw [sub_eq_iff_eq_add] at hv
      simp only [Zsqrtd.norm_def, hv]
      ring
#align factors2 factors2

theorem Spts.mul_of_dvd' {a p : ℤ√(-3)} (hdvd : p.norm ∣ a.norm) (hpprime : Prime p.norm) :
    ∃ u : ℤ√(-3), a = p * u ∨ a = star p * u :=
  by
  obtain ⟨f, hf⟩ := hdvd
  have h0 : p.norm ∣ p.re * a.im - a.re * p.im ∨ p.norm ∣ p.re * a.im + a.re * p.im :=
    by
    apply hpprime.dvd_or_dvd
    convert dvd_mul_right p.norm (a.im ^ 2 - p.im ^ 2 * f) using 1
    trans a.im ^ 2 * p.norm - p.im ^ 2 * (p.norm * f)
    · rw [← hf, Zsqrtd.norm_def, Zsqrtd.norm_def]
      ring
    · rw [Zsqrtd.norm_def]
      ring
  obtain ⟨A, HA⟩ : ∃ A : Units ℤ, p.norm ∣ p.re * a.im + A * a.re * p.im := by
    cases' h0 with h0 h0 <;> [(use -1), (use 1)] <;> convert h0 using 1 <;>
      simp only [Units.val_neg, Units.val_one, neg_mul, one_mul]
    ring
  have HAsq : (A : ℤ) ^ 2 = 1 := by
    calc
      (A : ℤ) ^ 2 = ((A ^ 2 : Units ℤ) : ℤ) := (Units.val_pow_eq_pow_val _ _).symm
      _ = ((1 : Units ℤ) : ℤ) := (congr_arg _ (Int.units_sq A))
      _ = 1 := Units.val_one

  · set X : ℤ√(-3) := ⟨p.re * a.re - A * 3 * p.im * a.im, p.re * a.im + A * a.re * p.im⟩ with HX
    obtain ⟨U, HU⟩ : (p.norm : ℤ√(-3)) ∣ X :=
      by
      rw [Zsqrtd.coe_int_dvd_iff]
      refine' ⟨_, HA⟩
      apply @Prime.dvd_of_dvd_pow _ _ _ hpprime _ 2
      have : X.re ^ 2 = X.norm - 3 * X.im ^ 2 :=
        by
        rw [Zsqrtd.norm_def]
        ring
      rw [this]
      apply dvd_sub
      · use a.norm
        trans
          (p.re * a.re) ^ 2 + (A : ℤ) ^ 2 * (3 * p.im * a.im) ^ 2 +
            3 * ((p.re * a.im) ^ 2 + (A : ℤ) ^ 2 * (a.re * p.im) ^ 2)
        · simp only [Zsqrtd.norm_def]
          ring
        · simp only [Zsqrtd.norm_def, HAsq]
          ring
      · apply dvd_mul_of_dvd_right
        exact dvd_pow HA two_ne_zero
    use U
    suffices a = ⟨p.re, -A * p.im⟩ * U by
      apply Or.imp _ _ (Int.units_eq_one_or A).symm <;> rintro rfl <;> simpa [Zsqrtd.ext] using this
    apply Zsqrtd.eq_of_smul_eq_smul_left hpprime.ne_zero
    have : p.norm = p.re ^ 2 + 3 * (A : ℤ) ^ 2 * p.im ^ 2 :=
      by
      rw [Zsqrtd.norm_def, HAsq]
      ring
    rw [mul_comm _ U, ← mul_assoc, ← HU, HX]
    simp only [Zsqrtd.ext, neg_mul, add_zero, Zsqrtd.coe_int_re, MulZeroClass.zero_mul, mul_neg,
      Zsqrtd.mul_im, Zsqrtd.mul_re, neg_neg, MulZeroClass.mul_zero, neg_zero, Zsqrtd.coe_int_im,
      this]
    constructor <;> ring
#align spts.mul_of_dvd' Spts.mul_of_dvd'

-- Edwards p49 step (3')
theorem Spts.mul_of_dvd'' {a p : ℤ√(-3)} (hdvd : p.norm ∣ a.norm) (hpprime : Prime p.norm) :
    ∃ u : ℤ√(-3), (a = p * u ∨ a = star p * u) ∧ a.norm = p.norm * u.norm :=
  by
  obtain ⟨u, hu⟩ := Spts.mul_of_dvd' hdvd hpprime
  refine' ⟨u, hu, _⟩
  obtain rfl | rfl := hu
  · rw [Zsqrtd.norm_mul]
  · rw [Zsqrtd.norm_mul, Zsqrtd.norm_conj]
#align spts.mul_of_dvd'' Spts.mul_of_dvd''

-- Edwards p49 step (4'), contraposed
theorem factors' (a : ℤ√(-3)) (f : ℤ) (g : ℤ) (hodd : Odd f) (hgpos : g ≠ 0)
    (hfactor : f * g = a.norm)
    (hnotform : ∀ f' : ℤ, f' ∣ g → Odd f' → ∃ p : ℤ√(-3), abs f' = p.norm) :
    ∃ p : ℤ√(-3), abs f = p.norm :=
  by
  induction' hg : g.natAbs using Nat.strong_induction_on with g'' IH generalizing a g
  subst g''
  dsimp at IH
  by_cases H : Even (Zsqrtd.norm a)
  · obtain ⟨c, hc⟩ := factors2 H
    have : 4 ∣ g := by
      apply IsCoprime.dvd_of_dvd_mul_left
      · show IsCoprime _ f
        rw [Int.odd_iff_not_even, even_iff_two_dvd, ← Int.prime_two.coprime_iff_not_dvd] at hodd
        convert hodd.pow_left
        rw [sq]
        norm_num
      · rw [hfactor, hc]
        exact dvd_mul_right _ _
    obtain ⟨g', rfl⟩ := this
    have hg'pos : g' ≠ 0 := right_ne_zero_of_mul hgpos
    refine' IH g'.natAbs _ c g' hg'pos _ _ rfl
    · rw [Int.natAbs_mul]
      apply lt_mul_of_one_lt_left (Int.natAbs_pos.mpr hg'pos)
      norm_num
    · rw [← mul_right_inj' (four_ne_zero' ℤ), ← hc, ← hfactor, mul_left_comm]
    · intro f' hf'dvd hf'odd
      refine' hnotform f' _ hf'odd
      exact hf'dvd.mul_left _
  · by_cases h : |g| = 1
    · apply_fun abs  at hfactor
      rw [abs_mul, h, mul_one, abs_of_nonneg (Zsqrtd.norm_nonneg (by norm_num) a)] at hfactor
      exact ⟨_, hfactor⟩
    · rw [Int.abs_eq_natAbs, ← Int.ofNat_one, Int.coe_nat_inj'] at h
      obtain ⟨p, pprime, pdvd⟩ := Int.exists_prime_and_dvd h
      have : p ∣ a.norm := by
        rw [← hfactor]
        exact pdvd.mul_left _
      have podd : Odd p :=
        Int.odd_iff_not_even.mpr
          (by
            intro X
            apply H
            apply even_iff_two_dvd.mpr
            apply dvd_trans _ this
            apply even_iff_two_dvd.mp X)
      obtain ⟨A, HA⟩ := hnotform p pdvd podd
      have pprime' := pprime.abs
      rw [HA] at pprime'
      have pdvd' : A.norm ∣ a.norm := by
        rw [← hfactor, ← HA, abs_dvd]
        exact dvd_mul_of_dvd_right pdvd _
      obtain ⟨c, -, hcd⟩ := Spts.mul_of_dvd'' pdvd' pprime'
      obtain ⟨q, rfl⟩ := pdvd
      have hqpos : q ≠ 0 := right_ne_zero_of_mul hgpos
      have : (p.sign * q).natAbs = q.natAbs := by
        rw [Int.natAbs_mul, Int.natAbs_sign_of_nonzero pprime.ne_zero, one_mul]
      refine' IH q.natAbs _ c (p.sign * q) _ _ _ this
      · rw [Int.natAbs_mul]
        apply lt_mul_of_one_lt_left (Int.natAbs_pos.mpr hqpos)
        rw [Int.prime_iff_natAbs_prime] at pprime
        exact pprime.one_lt
      · rwa [← Int.natAbs_eq_zero, this, Int.natAbs_eq_zero]
      ·
        rw [← mul_right_inj' pprime'.ne_zero, ← hcd, mul_left_comm, ← hfactor, ← HA, ←
          mul_assoc (|p|), mul_comm (|p|), Int.sign_mul_abs]
      · intro f' hf'dvd hf'odd
        refine' hnotform f' _ hf'odd
        rw [← Int.dvd_natAbs, this, Int.dvd_natAbs] at hf'dvd
        exact hf'dvd.mul_left _
#align factors' factors'

theorem Zqrtd.factor_div (a : ℤ√(-3)) {x : ℤ} (hodd : Odd x) :
    ∃ c m : ℤ√(-3), a = c + m * x ∧ c.norm < x ^ 2 :=
  by
  obtain ⟨m, c, ha, hc⟩ := Int.factor_div a.re x hodd
  obtain ⟨n, d, hb, hd⟩ := Int.factor_div a.im x hodd
  set c' : ℤ√(-3) := ⟨c, d⟩
  refine' ⟨c', ⟨m, n⟩, _, _⟩
  ·
    simp only [Zsqrtd.ext, ha, hb, add_zero, Zsqrtd.coe_int_re, eq_self_iff_true, Zsqrtd.mul_im,
      zero_add, Zsqrtd.add_im, and_self_iff, Zsqrtd.mul_re, MulZeroClass.mul_zero, Zsqrtd.add_re,
      Zsqrtd.coe_int_im]
  · rw [← mul_lt_mul_left (by norm_num : (0 : ℤ) < 4)]
    calc
      4 * c'.norm = (2 * c) ^ 2 + 3 * (2 * d) ^ 2 :=
        by
        rw [Zsqrtd.norm_def]
        ring
      _ < x ^ 2 + 3 * x ^ 2 := (add_lt_add ?_ ?_)
      _ = 4 * x ^ 2 := by ring

    · rw [mul_pow, ← Int.natAbs_pow_two c, ← Int.natAbs_pow_two x, ← mul_pow]
      norm_cast
      exact Nat.pow_lt_pow_of_lt_left hc zero_lt_two
    · rw [mul_pow, ← Int.natAbs_pow_two d, ← Int.natAbs_pow_two x, ← mul_pow,
        mul_lt_mul_left (by norm_num : (0 : ℤ) < 3)]
      norm_cast
      exact Nat.pow_lt_pow_of_lt_left hd zero_lt_two
#align zqrtd.factor_div Zqrtd.factor_div

theorem Zqrtd.factor_div' (a : ℤ√(-3)) {x : ℤ} (hodd : Odd x) (h : 1 < |x|)
    (hcoprime : IsCoprime a.re a.im) (hfactor : x ∣ a.norm) :
    ∃ c m : ℤ√(-3),
      a = c + m * x ∧ c.norm < x ^ 2 ∧ c ≠ 0 ∧ ∃ y, c.norm = x * y ∧ y.natAbs < x.natAbs :=
  by
  obtain ⟨c, m, rfl, h2⟩ := Zqrtd.factor_div a hodd
  refine' ⟨c, m, rfl, h2, _, _⟩
  · rintro rfl
    apply h.ne'
    rw [← Int.isUnit_iff_abs_eq]
    apply hcoprime.isUnit_of_dvd' <;>
      simp only [zero_add, mul_comm m, Zsqrtd.smul_re, Zsqrtd.smul_im, dvd_mul_right]
  · obtain ⟨y, hy⟩ : x ∣ c.norm :=
      by
      set e : ℤ := m.re ^ 2 * x + 2 * m.re * c.re + 3 * m.im ^ 2 * x + 6 * m.im * c.im with he
      convert dvd_sub hfactor (dvd_mul_right x e)
      rw [he, Zsqrtd.norm_def, Zsqrtd.norm_def]
      simp only [Zsqrtd.coe_int_re, Zsqrtd.mul_im, Zsqrtd.add_im, Zsqrtd.mul_re, Zsqrtd.add_re,
        Zsqrtd.coe_int_im]
      ring
    refine' ⟨y, hy, _⟩
    have h0'' : 0 < x.natAbs := by
      zify
      exact zero_lt_one.trans h
    rw [← mul_lt_mul_left h0'', ← pow_two, ← Int.natAbs_mul, ← hy]
    zify
    rwa [← Int.coe_natAbs x, Int.natAbs_pow_two x, ← Int.coe_natAbs,
      Int.natAbs_of_nonneg (Zsqrtd.norm_nonneg (by norm_num) c)]
#align zqrtd.factor_div' Zqrtd.factor_div'

-- Edwards p50 step (5')
theorem factors (a : ℤ√(-3)) (x : ℤ) (hcoprime : IsCoprime a.re a.im) (hodd : Odd x)
    (hfactor : x ∣ a.norm) : ∃ c : ℤ√(-3), abs x = c.norm :=
  by
  induction' hx' : x.natAbs using Nat.strong_induction_on with x' IH generalizing a x
  subst hx'
  have hneg1 : 1 ≤ a.norm := by
    rw [← Int.sub_one_lt_iff, sub_self]
    apply lt_of_le_of_ne (Zsqrtd.norm_nonneg (by norm_num) a)
    rw [Ne.def, eq_comm, Zsqrtd.norm_eq_zero_iff (by norm_num : (-3 : ℤ) < 0)]
    rintro rfl
    rw [Zsqrtd.zero_im, Zsqrtd.zero_re] at hcoprime
    exact not_isCoprime_zero_zero hcoprime
  have h0 : x ≠ 0 := by
    rintro rfl
    simp only [even_zero, not_true, Int.odd_iff_not_even] at hodd
  have h0' : 1 ≤ abs x := by rwa [← Int.sub_one_lt_iff, sub_self, abs_pos]
  cases' h0'.eq_or_lt with h h
  · rw [← h]
    refine' ⟨⟨1, 0⟩, _⟩
    norm_num [Zsqrtd.norm_def]
  obtain ⟨c', m, rfl, -, h1, ⟨y, hy, h3⟩⟩ := Zqrtd.factor_div' a hodd h hcoprime hfactor
  have h4 : c'.norm ≠ 0 := by rwa [Ne.def, Zsqrtd.norm_eq_zero_iff (by norm_num) c']
  set g := Int.gcd c'.re c'.im with hg
  have hgpos : 0 < g := by rwa [hg, Zsqrtd.gcd_pos_iff]
  obtain ⟨C', HC', HCDcoprime⟩ := Zsqrtd.exists_coprime_of_gcd_pos hgpos
  have h5 : x * y = (g : ℤ) ^ 2 * C'.norm := by
    rw [← hy, HC', Zsqrtd.norm_mul, Zsqrtd.norm_int_cast, ← pow_two]
  obtain ⟨z, hz⟩ : (g : ℤ) ^ 2 ∣ y :=
    by
    have : (g : ℤ) ^ 2 ∣ x * y := by
      rw [h5]
      exact dvd_mul_right _ _
    apply IsCoprime.dvd_of_dvd_mul_left _ this
    apply isCoprime_of_prime_dvd
    · contrapose! h0
      exact h0.2
    intro p hpprime hpdvdleft hpdvdright
    have : ↑p ∣ c' + m * x := by
      rw [HC']
      exact
        dvd_add
          (dvd_mul_of_dvd_left
            ((Zsqrtd.coe_int_dvd_coe_int _ _).mpr (hpprime.dvd_of_dvd_pow hpdvdleft)) _)
          (dvd_mul_of_dvd_right ((Zsqrtd.coe_int_dvd_coe_int _ _).mpr hpdvdright) _)
    have := Zsqrtd.coprime_of_dvd_coprime hcoprime this
    simp only [Zsqrtd.coe_int_re, isCoprime_zero_right, Zsqrtd.coe_int_im, hpprime.not_unit] at this
  have h6 : x * z = C'.norm :=
    by
    have hgnezero := Int.coe_nat_ne_zero_iff_pos.mpr hgpos
    apply Int.eq_of_mul_eq_mul_left (pow_ne_zero 2 hgnezero)
    rw [← h5, hz, mul_left_comm]
  have h8 : z ≠ 0 := by
    apply right_ne_zero_of_mul
    apply right_ne_zero_of_mul
    rwa [h6, ← h5, ← hy]
  refine' factors' _ x z hodd h8 h6 _
  intro w hwdvd hwodd
  refine' IH w.natAbs _ C' w HCDcoprime hwodd _ rfl
  ·
    calc
      w.natAbs ≤ z.natAbs :=
        Nat.le_of_dvd (Int.natAbs_pos.mpr h8) (Int.natAbs_dvd_natAbs.mpr hwdvd)
      _ ≤ y.natAbs := by
        rw [hz, Int.natAbs_mul]
        exact Nat.le_mul_of_pos_left (pow_pos hgpos 2)
      _ < x.natAbs := h3

  · rw [← h6]
    exact dvd_mul_of_dvd_right hwdvd x
#align factors factors

theorem Spts.eq_one {a : ℤ√(-3)} (h : a.norm = 1) : abs a.re = 1 ∧ a.im = 0 :=
  by
  suffices H : abs a.re = 1
  · refine' ⟨H, _⟩
    rw [Zsqrtd.norm_def, mul_assoc, ← Int.natAbs_mul_self' a.re, ← Int.abs_eq_natAbs, H, one_mul,
      neg_mul, sub_neg_eq_add, add_right_eq_self, mul_eq_zero, mul_self_eq_zero] at h
    exact h.resolve_left three_ne_zero
  contrapose! h
  cases' lt_or_gt_of_ne h with H H
  · have : a.re = 0 := by rwa [← Int.abs_lt_one_iff]
    simp only [Zsqrtd.norm_def, this, MulZeroClass.zero_mul, zero_sub, neg_mul, neg_neg]
    by_cases hb : a.im = 0
    · simp only [hb, not_false_iff, zero_ne_one, MulZeroClass.mul_zero]
    · have : 1 ≤ abs a.im := by rwa [← Int.abs_lt_one_iff, not_lt] at hb
      have : 1 ≤ a.im ^ 2 := by
        rw [← sq_abs]
        exact pow_le_pow_of_le_left zero_le_one this 2
      linarith
  · apply ne_of_gt
    rw [Zsqrtd.norm_def, neg_mul, neg_mul, sub_neg_eq_add]
    apply lt_add_of_lt_of_nonneg
    · rw [← sq, ← sq_abs]
      exact pow_lt_pow_of_lt_left H zero_le_one zero_lt_two
    · rw [mul_assoc]
      exact mul_nonneg zero_lt_three.le (mul_self_nonneg _)
#align spts.eq_one Spts.eq_one

theorem Spts.eq_one' {a : ℤ√(-3)} (h : a.norm = 1) : a = 1 ∨ a = -1 := by
  simp only [Zsqrtd.ext, Zsqrtd.one_re, Zsqrtd.one_im, Zsqrtd.neg_im, Zsqrtd.neg_re, neg_zero, ←
    or_and_right, ← abs_eq (zero_le_one' ℤ), Spts.eq_one h, eq_self_iff_true, and_self_iff]
#align spts.eq_one' Spts.eq_one'

theorem Spts.ne_zero_of_coprime' (a : ℤ√(-3)) (hcoprime : IsCoprime a.re a.im) : a.norm ≠ 0 :=
  by
  contrapose! hcoprime with H
  obtain ⟨rfl, rfl⟩ := (Zsqrtd.norm_eq_zero_iff (by norm_num) _).mp H
  exact not_isCoprime_zero_zero
#align spts.ne_zero_of_coprime' Spts.ne_zero_of_coprime'

theorem Spts.pos_of_coprime' {a : ℤ√(-3)} (hcoprime : IsCoprime a.re a.im) : 0 < a.norm :=
  by
  apply lt_of_le_of_ne
  · apply Zsqrtd.norm_nonneg
    norm_num
  · apply Ne.symm -- Porting note: `symm` fails
    exact Spts.ne_zero_of_coprime' _ hcoprime
#align spts.pos_of_coprime' Spts.pos_of_coprime'

theorem Spts.one_lt_of_im_ne_zero (a : ℤ√(-3)) (hb : a.im ≠ 0) : 1 < a.norm :=
  by
  apply lt_of_le_of_ne
  · rw [← Int.sub_one_lt_iff, sub_self]
    apply lt_of_le_of_ne (Zsqrtd.norm_nonneg (by norm_num) a)
    contrapose! hb
    rw [eq_comm, Zsqrtd.norm_eq_zero_iff (by norm_num) a] at hb
    rw [hb, Zsqrtd.zero_im]
  · intro H
    exact hb (Spts.eq_one H.symm).2
#align spts.one_lt_of_im_ne_zero Spts.one_lt_of_im_ne_zero

theorem Spts.not_two (a : ℤ√(-3)) : a.norm ≠ 2 :=
  by
  rw [Zsqrtd.norm_def]
  obtain him | him := eq_or_ne a.im 0
  · rw [him, MulZeroClass.mul_zero, sub_zero, ← Int.natAbs_mul_self, ← sq]
    norm_cast
    apply (Nat.pow_left_strictMono one_le_two).monotone.ne_of_lt_of_lt_nat 1 <;> norm_num
  · apply ne_of_gt
    apply lt_add_of_nonneg_of_lt (mul_self_nonneg a.re)
    rw [← Int.add_one_le_iff]
    rw [mul_assoc, neg_mul_eq_neg_mul, neg_neg]
    refine' le_mul_of_one_le_right zero_lt_three.le _
    rwa [← Int.sub_one_lt_iff, sub_self, mul_self_pos]
#align spts.not_two Spts.not_two

theorem Spts.four {p : ℤ√(-3)} (hfour : p.norm = 4) (hq : p.im ≠ 0) : abs p.re = 1 ∧ abs p.im = 1 :=
  by
  suffices p.re ^ 2 = 1 ∧ p.im ^ 2 = 1 by
    apply And.imp _ _ this <;>
      · intro h
        rwa [← sq_eq_sq (abs_nonneg (_ : ℤ)) zero_le_one, one_pow, sq_abs]
  have hq : p.im ^ 2 = 1 := by
    apply le_antisymm
    · contrapose! hfour with hq'
      apply ne_of_gt
      rw [← Int.add_one_le_iff] at hq'
      calc
        4 < 3 * 2 := by norm_num
        _ ≤ 3 * p.im ^ 2 := (Int.mul_le_mul_of_nonneg_left hq' (by norm_num))
        _ ≤ p.re ^ 2 + 3 * p.im ^ 2 := (le_add_of_nonneg_left (pow_two_nonneg p.re))
        _ = p.norm := by
          rw [Zsqrtd.norm_def]
          ring

    · rw [← Int.sub_one_lt_iff, sub_self]
      exact sq_pos_of_ne_zero _ hq
  refine' ⟨_, hq⟩
  calc
    p.re ^ 2 = p.re ^ 2 + 3 * p.im ^ 2 - 3 := by rw [hq, mul_one, add_sub_cancel]
    _ = p.norm - 3 := by
      rw [Zsqrtd.norm_def]
      ring
    _ = 1 := by
      rw [hfour]
      norm_num

#align spts.four Spts.four

theorem Spts.four_of_coprime {p : ℤ√(-3)} (hcoprime : IsCoprime p.re p.im) (hfour : p.norm = 4) :
    abs p.re = 1 ∧ abs p.im = 1 := by
  apply Spts.four hfour
  rintro him
  rw [him, isCoprime_zero_right, Int.isUnit_iff_abs_eq] at hcoprime
  rw [Zsqrtd.norm_def, him, MulZeroClass.mul_zero, sub_zero, ← sq, ← sq_abs, hcoprime] at hfour
  norm_num at hfour
#align spts.four_of_coprime Spts.four_of_coprime