/-
Copyright (c) 2018 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau, Chris Hughes
-/
import data.matrix
import group_theory.subgroup group_theory.perm.sign

universes u v
open equiv equiv.perm finset function

namespace matrix

variables {n : Type u} [fintype n] [decidable_eq n] {R : Type v} [comm_ring R]

local notation `ε` σ:max := ((sign σ : ℤ ) : R)

definition det (M : matrix n n R) : R :=
univ.sum (λ (σ : perm n), ε σ * univ.prod (λ i, M (σ i) i))

@[simp] lemma det_diagonal {d : n → R} : det (diagonal d) = univ.prod d :=
begin
  refine (finset.sum_eq_single 1 _ _).trans _,
  { intros σ h1 h2,
    cases not_forall.1 (mt (equiv.ext _ _) h2) with x h3,
    convert ring.mul_zero _,
    apply finset.prod_eq_zero,
    { change x ∈ _, simp },
    exact if_neg h3 },
  { simp },
  { simp }
end

@[simp] lemma det_zero (h : nonempty n) : det (0 : matrix n n R) = 0 :=
by rw [← diagonal_zero, det_diagonal, finset.prod_const, ← fintype.card,
  zero_pow (fintype.card_pos_iff.2 h)]

@[simp] lemma det_one : det (1 : matrix n n R) = 1 :=
by rw [← diagonal_one]; simp [-diagonal_one]

lemma det_mul_aux {M N : matrix n n R} {p : n → n} (H : ¬bijective p) :
  univ.sum (λ σ : perm n, (ε σ) * (univ.prod (λ x, M (σ x) (p x) * N (p x) x))) = 0 :=
let ⟨i, hi⟩ := classical.not_forall.1 (mt fintype.injective_iff_bijective.1 H) in
let ⟨j, hij'⟩ := classical.not_forall.1 hi in
have hij : p i = p j ∧ i ≠ j, from not_imp.1 hij',
sum_involution
  (λ σ _, σ * swap i j)
  (λ σ _,
    have ∀ a, p (swap i j a) = p a := λ a, by simp only [swap_apply_def]; split_ifs; cc,
    have univ.prod (λ x, M (σ x) (p x)) = univ.prod (λ x, M ((σ * swap i j) x) (p x)),
      from prod_bij (λ a _, swap i j a) (λ _ _, mem_univ _) (by simp [this])
        (λ _ _ _ _ h, (swap i j).injective h)
        (λ b _, ⟨swap i j b, mem_univ _, by simp⟩),
    by simp [sign_mul, this, sign_swap hij.2, prod_mul_distrib])
  (λ σ _ _ h, hij.2 (σ.injective $ by conv {to_lhs, rw ← h}; simp))
  (λ _ _, mem_univ _)
  (λ _ _, equiv.ext _ _ $ by simp)

@[simp] lemma det_mul (M N : matrix n n R) : det (M * N) = det M * det N :=
calc det (M * N) = univ.sum (λ σ : perm n, (univ.pi (λ a, univ)).sum
    (λ (p : Π (a : n), a ∈ univ → n), ε σ *
    univ.attach.prod (λ i, M (σ i.1) (p i.1 (mem_univ _)) * N (p i.1 (mem_univ _)) i.1))) :
  by simp only [det, mul_val', prod_sum, mul_sum]
... = univ.sum (λ σ : perm n, univ.sum
    (λ p : n → n, ε σ * univ.prod (λ i, M (σ i) (p i) * N (p i) i))) :
  sum_congr rfl (λ σ _, sum_bij
    (λ f h i, f i (mem_univ _)) (λ _ _, mem_univ _)
    (by simp) (by simp [funext_iff]) (λ b _, ⟨λ i hi, b i, by simp⟩))
... = univ.sum (λ p : n → n, univ.sum
    (λ σ : perm n, ε σ * univ.prod (λ i, M (σ i) (p i) * N (p i) i))) :
  finset.sum_comm
... = ((@univ (n → n) _).filter bijective ∪ univ.filter (λ p : n → n, ¬bijective p)).sum
    (λ p : n → n, univ.sum (λ σ : perm n, ε σ * univ.prod (λ i, M (σ i) (p i) * N (p i) i))) :
  finset.sum_congr (finset.ext.2 (by simp; tauto)) (λ _ _, rfl)
... = ((@univ (n → n) _).filter bijective).sum (λ p : n → n, univ.sum
    (λ σ : perm n, ε σ * univ.prod (λ i, M (σ i) (p i) * N (p i) i))) +
    (univ.filter (λ p : n → n, ¬bijective p)).sum (λ p : n → n, univ.sum
    (λ σ : perm n, ε σ * univ.prod (λ i, M (σ i) (p i) * N (p i) i))) :
  finset.sum_union (by simp [finset.ext]; tauto)
... = ((@univ (n → n) _).filter bijective).sum (λ p : n → n, univ.sum
    (λ σ : perm n, ε σ * univ.prod (λ i, M (σ i) (p i) * N (p i) i))) +
    (univ.filter (λ p : n → n, ¬bijective p)).sum (λ p, 0) :
  (add_left_inj _).2 (finset.sum_congr rfl $ λ p h, det_mul_aux (mem_filter.1 h).2)
... = ((@univ (n → n) _).filter bijective).sum (λ p : n → n, univ.sum
    (λ σ : perm n, ε σ * univ.prod (λ i, M (σ i) (p i) * N (p i) i))) : by simp
... = (@univ (perm n) _).sum (λ τ, univ.sum
    (λ σ : perm n, ε σ * univ.prod (λ i, M (σ i) (τ i) * N (τ i) i))) :
  sum_bij (λ p h, equiv.of_bijective (mem_filter.1 h).2) (λ _ _, mem_univ _)
    (λ _ _, rfl) (λ _ _ _ _ h, by injection h)
    (λ b _, ⟨b, mem_filter.2 ⟨mem_univ _, b.bijective⟩, eq_of_to_fun_eq rfl⟩)
... = univ.sum (λ σ : perm n, univ.sum (λ τ : perm n,
    (univ.prod (λ i, N (σ i) i) * ε τ) * univ.prod (λ j, M (τ j) (σ j)))) :
  by simp [mul_sum, det, mul_comm, mul_left_comm, prod_mul_distrib, mul_assoc]
... = univ.sum (λ σ : perm n, univ.sum (λ τ : perm n,
    (univ.prod (λ i, N (σ i) i) * (ε σ * ε τ)) *
    univ.prod (λ i, M (τ i) i))) :
  sum_congr rfl (λ σ _, sum_bij (λ τ _, τ * σ⁻¹) (λ _ _, mem_univ _)
    (λ τ _,
      have univ.prod (λ j, M (τ j) (σ j)) = univ.prod (λ j, M ((τ * σ⁻¹) j) j),
        by rw prod_univ_perm σ⁻¹; simp [mul_apply],
      have h : ε σ * ε (τ * σ⁻¹) = ε τ :=
        calc ε σ * ε (τ * σ⁻¹) = ε ((τ * σ⁻¹) * σ) :
          by rw [mul_comm, sign_mul (τ * σ⁻¹)]; simp [sign_mul]
        ... = ε τ : by simp,
      by rw h; simp [this, mul_comm, mul_assoc, mul_left_comm])
    (λ _ _ _ _, (mul_right_inj _).1) (λ τ _, ⟨τ * σ, by simp⟩))
... = det M * det N : by simp [det, mul_assoc, mul_sum, mul_comm, mul_left_comm]

instance : is_monoid_hom (det : matrix n n R → R) :=
{ map_one := det_one,
  map_mul := det_mul }

end matrix


/-
Copyright (c) 2019 Riccardo Brasca. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Riccardo Brasca, Paul Lezeau, Junyan Xu
-/
import data.polynomial.field_division
import ring_theory.adjoin_root
import field_theory.minpoly.field
import ring_theory.polynomial.gauss_lemma

/-!
# Minimal polynomials over a GCD monoid

This file specializes the theory of minpoly to the case of an algebra over a GCD monoid.

## Main results

 * `is_integrally_closed_eq_field_fractions`: For integrally closed domains, the minimal polynomial
    over the ring is the same as the minimal polynomial over the fraction field.

 * `is_integrally_closed_dvd` : For integrally closed domains, the minimal polynomial divides any
    primitive polynomial that has the integral element as root.

 * `is_integrally_closed_unique` : The minimal polynomial of an element `x` is uniquely
    characterized by its defining property: if there is another monic polynomial of minimal degree
    that has `x` as a root, then this polynomial is equal to the minimal polynomial of `x`.

-/

open_locale classical polynomial
open polynomial set function minpoly

namespace minpoly

variables {R S : Type*} [comm_ring R] [comm_ring S] [is_domain R] [algebra R S]

section

variables (K L : Type*) [field K] [algebra R K] [is_fraction_ring R K] [field L] [algebra R L]
 [algebra S L] [algebra K L] [is_scalar_tower R K L] [is_scalar_tower R S L]

variables [is_integrally_closed R]

/-- For integrally closed domains, the minimal polynomial over the ring is the same as the minimal
polynomial over the fraction field. See `minpoly.is_integrally_closed_eq_field_fractions'` if
`S` is already a `K`-algebra. -/
theorem is_integrally_closed_eq_field_fractions [is_domain S] {s : S} (hs : is_integral R s) :
  minpoly K (algebra_map S L s) = (minpoly R s).map (algebra_map R K) :=
begin
  refine (eq_of_irreducible_of_monic _ _ _).symm,
  { exact (polynomial.monic.irreducible_iff_irreducible_map_fraction_map
      (monic hs)).1 (irreducible hs) },
   { rw [aeval_map_algebra_map, aeval_algebra_map_apply, aeval, map_zero] },
  { exact (monic hs).map _ }
end

/-- For integrally closed domains, the minimal polynomial over the ring is the same as the minimal
polynomial over the fraction field. Compared to `minpoly.is_integrally_closed_eq_field_fractions`,
this version is useful if the element is in a ring that is already a `K`-algebra. -/
theorem is_integrally_closed_eq_field_fractions' [is_domain S] [algebra K S] [is_scalar_tower R K S]
  {s : S} (hs : is_integral R s) : minpoly K s = (minpoly R s).map (algebra_map R K) :=
begin
  let L := fraction_ring S,
  rw [← is_integrally_closed_eq_field_fractions K L hs],
  refine minpoly.eq_of_algebra_map_eq (is_fraction_ring.injective S L)
    (is_integral_of_is_scalar_tower hs) rfl
end

end

variables [is_domain S] [no_zero_smul_divisors R S]

variable [is_integrally_closed R]

/-- For integrally closed rings, the minimal polynomial divides any polynomial that has the
  integral element as root. See also `minpoly.dvd` which relaxes the assumptions on `S`
  in exchange for stronger assumptions on `R`. -/
theorem is_integrally_closed_dvd [nontrivial R] {s : S} (hs : is_integral R s) {p : R[X]}
  (hp : polynomial.aeval s p = 0) : minpoly R s ∣ p :=
begin
  let K := fraction_ring R,
    let L := fraction_ring S,
    have : minpoly K (algebra_map S L s) ∣ map (algebra_map R K) (p %ₘ (minpoly R s)),
    { rw [map_mod_by_monic _ (minpoly.monic hs), mod_by_monic_eq_sub_mul_div],
      refine dvd_sub (minpoly.dvd K (algebra_map S L s) _) _,
      rw [← map_aeval_eq_aeval_map, hp, map_zero],
      rw [← is_scalar_tower.algebra_map_eq, ← is_scalar_tower.algebra_map_eq],

      apply dvd_mul_of_dvd_left,
      rw is_integrally_closed_eq_field_fractions K L hs,

      exact monic.map _ (minpoly.monic hs) },
    rw [is_integrally_closed_eq_field_fractions _ _ hs, map_dvd_map (algebra_map R K)
      (is_fraction_ring.injective R K) (minpoly.monic hs)] at this,
    rw [← dvd_iff_mod_by_monic_eq_zero (minpoly.monic hs)],
    refine polynomial.eq_zero_of_dvd_of_degree_lt this
      (degree_mod_by_monic_lt p $ minpoly.monic hs),
      all_goals { apply_instance }
end

lemma ker_eval {s : S} (hs : is_integral R s) :
  ((polynomial.aeval s).to_ring_hom : R[X] →+* S).ker = ideal.span ({minpoly R s} : set R[X] ):=
by ext p ; simp_rw [ring_hom.mem_ker, alg_hom.to_ring_hom_eq_coe, alg_hom.coe_to_ring_hom,
  is_integrally_closed_dvd_iff hs, ← ideal.mem_span_singleton]

/-- If an element `x` is a root of a nonzero polynomial `p`, then the degree of `p` is at least the
degree of the minimal polynomial of `x`. See also `minpoly.degree_le_of_ne_zero` which relaxes the
assumptions on `S` in exchange for stronger assumptions on `R`. -/
lemma is_integrally_closed.degree_le_of_ne_zero {s : S} (hs : is_integral R s) {p : R[X]}
  (hp0 : p ≠ 0) (hp : polynomial.aeval s p = 0) : degree (minpoly R s) ≤ degree p :=
begin
  rw [degree_eq_nat_degree (minpoly.ne_zero hs), degree_eq_nat_degree hp0],
  norm_cast,
  exact nat_degree_le_of_dvd ((is_integrally_closed_dvd_iff hs _).mp hp) hp0
end

/-- The minimal polynomial of an element `x` is uniquely characterized by its defining property:
if there is another monic polynomial of minimal degree that has `x` as a root, then this polynomial
is equal to the minimal polynomial of `x`. See also `minpoly.unique` which relaxes the
assumptions on `S` in exchange for stronger assumptions on `R`. -/
lemma is_integrally_closed.minpoly.unique {s : S} {P : R[X]} (hmo : P.monic)
  (hP : polynomial.aeval s P = 0)
  (Pmin : ∀ Q : R[X], Q.monic → polynomial.aeval s Q = 0 → degree P ≤ degree Q) :
  P = minpoly R s :=
begin
  have hs : is_integral R s := ⟨P, hmo, hP⟩,
  symmetry, apply eq_of_sub_eq_zero,
  by_contra hnz,
  have := is_integrally_closed.degree_le_of_ne_zero hs hnz (by simp [hP]),
  contrapose! this,
  refine degree_sub_lt _ (ne_zero hs) _,
  { exact le_antisymm (min R s hmo hP)
      (Pmin (minpoly R s) (monic hs) (aeval R s)) },
  { rw [(monic hs).leading_coeff, hmo.leading_coeff] }
end

theorem prime_of_is_integrally_closed {x : S} (hx : is_integral R x) :
  _root_.prime (minpoly R x) :=
begin
  refine ⟨(minpoly.monic hx).ne_zero, ⟨by by_contra h_contra ;
    exact (ne_of_lt (minpoly.degree_pos hx)) (degree_eq_zero_of_is_unit h_contra).symm,
      λ a b h, or_iff_not_imp_left.mpr (λ h', _)⟩⟩,
  rw ← minpoly.is_integrally_closed_dvd_iff hx at ⊢ h' h,
  rw aeval_mul at h,
  exact eq_zero_of_ne_zero_of_mul_left_eq_zero h' h,
end

section adjoin_root

noncomputable theory

open algebra polynomial adjoin_root

variables {R} {x : S}

lemma to_adjoin.injective (hx : is_integral R x) :
  function.injective (minpoly.to_adjoin R x) :=
begin
  refine (injective_iff_map_eq_zero _).2 (λ P₁ hP₁, _),
  obtain ⟨P, hP⟩ := mk_surjective (minpoly.monic hx) P₁,
  by_cases hPzero : P = 0,
  { simpa [hPzero] using hP.symm },
  rw [← hP, minpoly.to_adjoin_apply', lift_hom_mk,  ← subalgebra.coe_eq_zero,
    aeval_subalgebra_coe, set_like.coe_mk, is_integrally_closed_dvd_iff hx] at hP₁,
  obtain ⟨Q, hQ⟩ := hP₁,
  rw [← hP, hQ, ring_hom.map_mul, mk_self, zero_mul],
end

/-- The algebra isomorphism `adjoin_root (minpoly R x) ≃ₐ[R] adjoin R x` -/
@[simps] def equiv_adjoin (hx : is_integral R x) :
  adjoin_root (minpoly R x) ≃ₐ[R] adjoin R ({x} : set S) :=
alg_equiv.of_bijective (minpoly.to_adjoin R x)
  ⟨minpoly.to_adjoin.injective hx, minpoly.to_adjoin.surjective R x⟩

/-- The `power_basis` of `adjoin R {x}` given by `x`. See `algebra.adjoin.power_basis` for a version
over a field. -/
@[simps] def _root_.algebra.adjoin.power_basis' (hx : is_integral R x) :
  power_basis R (algebra.adjoin R ({x} : set S)) :=
power_basis.map (adjoin_root.power_basis' (minpoly.monic hx)) (minpoly.equiv_adjoin hx)

/-- The power basis given by `x` if `B.gen ∈ adjoin R {x}`. -/
@[simps] noncomputable def _root_.power_basis.of_gen_mem_adjoin' (B : power_basis R S)
  (hint : is_integral R x) (hx : B.gen ∈ adjoin R ({x} : set S)) :
  power_basis R S :=
(algebra.adjoin.power_basis' hint).map $
  (subalgebra.equiv_of_eq _ _ $ power_basis.adjoin_eq_top_of_gen_mem_adjoin hx).trans
  subalgebra.top_equiv

end adjoin_root

end minpoly


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

! This file was ported from Lean 3 source module ring_theory.ideal.prod
! leanprover-community/mathlib commit 052f6013363326d50cb99c6939814a4b8eb7b301
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.RingTheory.Ideal.Operations

/-!
# Ideals in product rings

For commutative rings `R` and `S` and ideals `I ≤ R`, `J ≤ S`, we define `Ideal.prod I J` as the
product `I × J`, viewed as an ideal of `R × S`. In `ideal_prod_eq` we show that every ideal of
`R × S` is of this form.  Furthermore, we show that every prime ideal of `R × S` is of the form
`p × S` or `R × p`, where `p` is a prime ideal.
-/

universe u v

variable {R : Type u} {S : Type v} [Ring R] [Ring S] (I I' : Ideal R) (J J' : Ideal S)

namespace Ideal

/-- `I × J` as an ideal of `R × S`. -/
def prod : Ideal (R × S) where
  carrier := { x | x.fst ∈ I ∧ x.snd ∈ J }
  zero_mem' := by simp
  add_mem' := by
    rintro ⟨a₁, a₂⟩ ⟨b₁, b₂⟩ ⟨ha₁, ha₂⟩ ⟨hb₁, hb₂⟩
    exact ⟨I.add_mem ha₁ hb₁, J.add_mem ha₂ hb₂⟩
  smul_mem' := by
    rintro ⟨a₁, a₂⟩ ⟨b₁, b₂⟩ ⟨hb₁, hb₂⟩
    exact ⟨I.mul_mem_left _ hb₁, J.mul_mem_left _ hb₂⟩
#align ideal.prod Ideal.prod

@[simp]
theorem mem_prod {r : R} {s : S} : (⟨r, s⟩ : R × S) ∈ prod I J ↔ r ∈ I ∧ s ∈ J :=
  Iff.rfl
#align ideal.mem_prod Ideal.mem_prod

@[simp]
theorem prod_top_top : prod (⊤ : Ideal R) (⊤ : Ideal S) = ⊤ :=
  Ideal.ext <| by simp
#align ideal.prod_top_top Ideal.prod_top_top

/- Porting note: This is necessary to prevent failing type class searches in
`map (RingHom.fst R S) I`, remove when `etaExperiment` becomes the default. -/
attribute [-instance] Ring.toNonAssocRing

/-- Every ideal of the product ring is of the form `I × J`, where `I` and `J` can be explicitly
    given as the image under the projection maps. -/

@[simp]
theorem map_fst_prod (I : Ideal R) (J : Ideal S) : map (RingHom.fst R S) (prod I J) = I := by
  ext x
  rw [mem_map_iff_of_surjective (RingHom.fst R S) Prod.fst_surjective]
  exact
    ⟨by
      rintro ⟨x, ⟨h, rfl⟩⟩
      exact h.1, fun h => ⟨⟨x, 0⟩, ⟨⟨h, Ideal.zero_mem _⟩, rfl⟩⟩⟩
#align ideal.map_fst_prod Ideal.map_fst_prod

@[simp]
theorem map_snd_prod (I : Ideal R) (J : Ideal S) : map (RingHom.snd R S) (prod I J) = J := by
  ext x
  rw [mem_map_iff_of_surjective (RingHom.snd R S) Prod.snd_surjective]
  exact
    ⟨by
      rintro ⟨x, ⟨h, rfl⟩⟩
      exact h.2, fun h => ⟨⟨0, x⟩, ⟨⟨Ideal.zero_mem _, h⟩, rfl⟩⟩⟩
#align ideal.map_snd_prod Ideal.map_snd_prod

@[simp]
theorem map_prodComm_prod :
    map ((RingEquiv.prodComm : R × S ≃+* S × R) : R × S →+* S × R) (prod I J) = prod J I := by
  refine' Trans.trans (ideal_prod_eq _) _
  simp [map_map]
#align ideal.map_prod_comm_prod Ideal.map_prodComm_prod

/-- Ideals of `R × S` are in one-to-one correspondence with pairs of ideals of `R` and ideals of
    `S`. -/
def idealProdEquiv : Ideal (R × S) ≃ Ideal R × Ideal S
    where
  toFun I := ⟨map (RingHom.fst R S) I, map (RingHom.snd R S) I⟩
  invFun I := prod I.1 I.2
  left_inv I := (ideal_prod_eq I).symm
  right_inv := fun ⟨I, J⟩ => by simp
#align ideal.ideal_prod_equiv Ideal.idealProdEquiv

@[simp]
theorem idealProdEquiv_symm_apply (I : Ideal R) (J : Ideal S) :
    idealProdEquiv.symm ⟨I, J⟩ = prod I J :=
  rfl
#align ideal.ideal_prod_equiv_symm_apply Ideal.idealProdEquiv_symm_apply

theorem prod.ext_iff {I I' : Ideal R} {J J' : Ideal S} : prod I J = prod I' J' ↔ I = I' ∧ J = J' :=
  by
  simp only [← idealProdEquiv_symm_apply, idealProdEquiv.symm.injective.eq_iff, Prod.mk.inj_iff]
#align ideal.prod.ext_iff Ideal.prod.ext_iff

theorem isPrime_of_isPrime_prod_top {I : Ideal R} (h : (Ideal.prod I (⊤ : Ideal S)).IsPrime) :
    I.IsPrime := by
  constructor
  · contrapose! h
    rw [h, prod_top_top, isPrime_iff]
    simp [isPrime_iff, h]
  · intro x y hxy
    have : (⟨x, 1⟩ : R × S) * ⟨y, 1⟩ ∈ prod I ⊤ :=
      by
      rw [Prod.mk_mul_mk, mul_one, mem_prod]
      exact ⟨hxy, trivial⟩
    simpa using h.mem_or_mem this
#align ideal.is_prime_of_is_prime_prod_top Ideal.isPrime_of_isPrime_prod_top

theorem isPrime_of_isPrime_prod_top' {I : Ideal S} (h : (Ideal.prod (⊤ : Ideal R) I).IsPrime) :
    I.IsPrime := by
  apply @isPrime_of_isPrime_prod_top _ R
  rw [← map_prodComm_prod]
  exact map_isPrime_of_equiv _
#align ideal.is_prime_of_is_prime_prod_top' Ideal.isPrime_of_isPrime_prod_top'

theorem isPrime_ideal_prod_top {I : Ideal R} [h : I.IsPrime] : (prod I (⊤ : Ideal S)).IsPrime := by
  constructor
  · rcases h with ⟨h, -⟩
    contrapose! h
    rw [← prod_top_top, prod.ext_iff] at h
    exact h.1
  rintro ⟨r₁, s₁⟩ ⟨r₂, s₂⟩ ⟨h₁, _⟩
  cases' h.mem_or_mem h₁ with h h
  · exact Or.inl ⟨h, trivial⟩
  · exact Or.inr ⟨h, trivial⟩
#align ideal.is_prime_ideal_prod_top Ideal.isPrime_ideal_prod_top

theorem isPrime_ideal_prod_top' {I : Ideal S} [h : I.IsPrime] : (prod (⊤ : Ideal R) I).IsPrime := by
  letI : IsPrime (prod I (⊤ : Ideal R)) := isPrime_ideal_prod_top
  rw [← map_prodComm_prod]
  apply map_isPrime_of_equiv _
#align ideal.is_prime_ideal_prod_top' Ideal.isPrime_ideal_prod_top'

theorem ideal_prod_prime_aux {I : Ideal R} {J : Ideal S} :
    (Ideal.prod I J).IsPrime → I = ⊤ ∨ J = ⊤ := by
  contrapose!
  simp only [ne_top_iff_one, isPrime_iff, not_and, not_forall, not_or]
  exact fun ⟨hI, hJ⟩ _ => ⟨⟨0, 1⟩, ⟨1, 0⟩, by simp, by simp [hJ], by simp [hI]⟩
#align ideal.ideal_prod_prime_aux Ideal.ideal_prod_prime_aux

/-- Classification of prime ideals in product rings: the prime ideals of `R × S` are precisely the
    ideals of the form `p × S` or `R × p`, where `p` is a prime ideal of `R` or `S`. -/
theorem ideal_prod_prime (I : Ideal (R × S)) :
    I.IsPrime ↔
      (∃ p : Ideal R, p.IsPrime ∧ I = Ideal.prod p ⊤) ∨
        ∃ p : Ideal S, p.IsPrime ∧ I = Ideal.prod ⊤ p := by
  constructor
  · rw [ideal_prod_eq I]
    intro hI
    rcases ideal_prod_prime_aux hI with (h | h)
    · right
      rw [h] at hI⊢
      exact ⟨_, ⟨isPrime_of_isPrime_prod_top' hI, rfl⟩⟩
    · left
      rw [h] at hI⊢
      exact ⟨_, ⟨isPrime_of_isPrime_prod_top hI, rfl⟩⟩
  · rintro (⟨p, ⟨h, rfl⟩⟩ | ⟨p, ⟨h, rfl⟩⟩)
    · exact isPrime_ideal_prod_top
    · exact isPrime_ideal_prod_top'
#align ideal.ideal_prod_prime Ideal.ideal_prod_prime

end Ideal


import GMLInit.Data.Index.Basic
import GMLInit.Data.Index.Append

namespace Index
variable {α} {xss : List (List α)}

def join : {xss : List (List α)} → (i : Index xss) × (Index i.val) → Index xss.join
| _, ⟨head, j⟩ => append (.inl j)
| _, ⟨tail i, j⟩ => append (.inr (join ⟨i, j⟩))

def unjoin : {xss : List (List α)} → Index xss.join → (i : Index xss) × (Index i.val)
| _::_, k =>
  match unappend k with
  | .inl j => ⟨head, j⟩
  | .inr k => ⟨tail (unjoin k).fst, (unjoin k).snd⟩

theorem unjoin_join (i : (i : Index xss) × (Index i.val)) : unjoin (join i) = i := by
  induction xss with
  | nil => cases i; contradiction
  | cons xs xss ih =>
    match i with
    | ⟨head, j⟩ => clean unfold join unjoin; rw [unappend_append]
    | ⟨tail i, j⟩ => clean unfold join unjoin; rw [unappend_append]; clean; rw [ih]

theorem join_unjoin (k : Index xss.join) : join (unjoin k) = k := by
  induction xss with
  | nil => contradiction
  | cons xs xss ih =>
    match h : unappend k with
    | .inl j => rw [unappend_eq_iff_eq_append] at h; rw [h, unjoin, unappend_append, join]
    | .inr k => rw [unappend_eq_iff_eq_append] at h; rw [h, unjoin, unappend_append, join, ih]

theorem join_eq_iff_eq_unjoin (i : (i : Index xss) × (Index i.val)) (k : Index xss.join) : join i = k ↔ i = unjoin k := by
  constr
  · intro h; rw [←h, unjoin_join]
  · intro h; rw [h, join_unjoin]

theorem unjoin_eq_iff_eq_join (k : Index xss.join) (i : (i : Index xss) × (Index i.val)) : unjoin k = i ↔ k = join i := by
  constr
  · intro h; rw [←h, join_unjoin]
  · intro h; rw [h, unjoin_join]

def joinEquiv (xss : List (List α)) : Equiv ((i : Index xss) × Index i.val) (Index xss.join) where
  fwd := join
  rev := unjoin
  spec := by
    intros
    constr
    · intro | rfl => exact unjoin_join ..
    · intro | rfl => exact join_unjoin ..

theorem val_join (i : (i : Index xss) × Index i.val) : (join i).val = i.snd.val := by
  induction xss with
  | nil => cases i; contradiction
  | cons xs xss ih =>
    match i with
    | ⟨head, j⟩ => rw [join, val_append_inl]
    | ⟨tail i, j⟩ => rw [join, val_append_inr, ih]

theorem val_unjoin (k : Index xss.join) : (unjoin k).snd.val = k.val := by
  rw [←join_unjoin k, val_join, unjoin_join]

end Index


/-
Copyright (c) 2019 The Flypitch Project. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.

Authors: Jesse Han, Floris van Doorn
-/
import .fol

open fol

local notation h :: t  := dvector.cons h t
local notation `[]` := dvector.nil
local notation `[` l:(foldr `, ` (h t, dvector.cons h t) dvector.nil `]`) := l

namespace nnf
section

/- Recurse through a formula, rewriting f ⟹ ⊥ to (∼f) when possible -/
def not_rewrite {L} : ∀{l}, preformula L l → preformula L l
| l falsum          := falsum
| l (t₁ ≃ t₂)       := t₁ ≃ t₂
| l (rel R)          := rel R
| l (apprel f t)     := apprel f t
| l (f ⟹ falsum)    := (∼f)
| l (f ⟹ g)         := (not_rewrite f) ⟹ (not_rewrite g)
| l (∀' f)           := ∀' not_rewrite f

/- Recurse through a formula, rewriting ∼(f ⟹ ∼g) to f ⊓ g -/
def and_rewrite {L} : ∀{l}, preformula L l → preformula L l
| l falsum          := falsum
| l (t₁ ≃ t₂)       := t₁ ≃ t₂
| l (rel R)          := rel R
| l (apprel f t)     := apprel f t
--| l ∼(f ⟹ (∼ g)) := f ⊓ g -- this pattern makes the equation compiler complain
| l ((f ⟹ (g ⟹ falsum)) ⟹ falsum) := f ⊓ g
| l (f ⟹ g)         := (and_rewrite f) ⟹ (and_rewrite g)
| l (∀' f)           := ∀' and_rewrite f

def or_rewrite {L} : ∀{l}, preformula L l → preformula L l
| l falsum          := falsum
| l (t₁ ≃ t₂)       := t₁ ≃ t₂
| l (rel R)          := rel R
| l (apprel f t)     := apprel f t
| l ((f ⟹ falsum) ⟹ g) := f ⊔ g
| l (f ⟹ g)         := (or_rewrite f) ⟹ (or_rewrite g)
| l (∀' f)           := ∀' or_rewrite f

def imp_rewrite {L} : ∀{l}, preformula L l → preformula L l
| l falsum          := falsum
| l (t₁ ≃ t₂)       := t₁ ≃ t₂
| l (rel R)          := rel R
| l (apprel f t)     := apprel f t
| l (f ⟹ g)         := ∼(imp_rewrite f) ⊔ (imp_rewrite g)
| l (∀' f)           := ∀' imp_rewrite f

lemma neg_rewrite_sanity_check {L} {f : formula L} : not_rewrite (f ⟹ ⊥) = (∼f) :=
  by {conv {to_lhs, rw[not_rewrite]}}

lemma and_rewrite_sanity_check {L} {f g : formula L} : and_rewrite ∼(f ⟹ (∼g)) = f ⊓ g :=
  by {conv {to_lhs, simp[fol.not], rw[and_rewrite]}}
--the simp[fol.not] is unfortunate, but the equation compiler doesn't let me use `∼` in and_rewrite

/- To put formulas into normal form,
    1. replace implication with material implication, and
    2. simplify with de-morgan's laws

    maybe hijack the simplifier?
 -/

end
end nnf


/-
Copyright (c) 2019 Kevin Kappelmann. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kevin Kappelmann
-/
import data.seq.seq
import algebra.field.defs
/-!
# Basic Definitions/Theorems for Continued Fractions

## Summary

We define generalised, simple, and regular continued fractions and functions to evaluate their
convergents. We follow the naming conventions from Wikipedia and [wall2018analytic], Chapter 1.

## Main definitions

1. Generalised continued fractions (gcfs)
2. Simple continued fractions (scfs)
3. (Regular) continued fractions ((r)cfs)
4. Computation of convergents using the recurrence relation in `convergents`.
5. Computation of convergents by directly evaluating the fraction described by the gcf in
`convergents'`.

## Implementation notes

1. The most commonly used kind of continued fractions in the literature are regular continued
fractions. We hence just call them `continued_fractions` in the library.
2. We use sequences from `data.seq` to encode potentially infinite sequences.

## References

- <https://en.wikipedia.org/wiki/Generalized_continued_fraction>
- [Wall, H.S., *Analytic Theory of Continued Fractions*][wall2018analytic]

## Tags

numerics, number theory, approximations, fractions
-/

-- Fix a carrier `α`.
variable (α : Type*)
/-!### Definitions-/

/-- We collect a partial numerator `aᵢ` and partial denominator `bᵢ` in a pair `⟨aᵢ,bᵢ⟩`. -/
@[derive inhabited]
protected structure generalized_continued_fraction.pair := (a : α) (b : α)

open generalized_continued_fraction
open stream.seq as seq

/-! Interlude: define some expected coercions and instances. -/
namespace generalized_continued_fraction.pair

variable {α}

/-- Make a `gcf.pair` printable. -/
instance [has_repr α] : has_repr (pair α) :=
⟨λ p, "(a : " ++ (repr p.a) ++ ", b : " ++ (repr p.b) ++ ")"⟩

/-- Maps a function `f` on both components of a given pair. -/
def map {β : Type*} (f : α → β) (gp : pair α) : pair β :=
⟨f gp.a, f gp.b⟩

section coe
/- Fix another type `β` which we will convert to. -/
variables {β : Type*} [has_coe α β]

/-- Coerce a pair by elementwise coercion. -/
instance has_coe_to_generalized_continued_fraction_pair : has_coe (pair α) (pair β) :=
⟨map coe⟩

@[simp, norm_cast]

end coe
end generalized_continued_fraction.pair

variable (α)

/--
A *generalised continued fraction* (gcf) is a potentially infinite expression of the form
$$
  h + \dfrac{a_0}
            {b_0 + \dfrac{a_1}
                         {b_1 + \dfrac{a_2}
                                      {b_2 + \dfrac{a_3}
                                                   {b_3 + \dots}}}}
$$
where `h` is called the *head term* or *integer part*, the `aᵢ` are called the
*partial numerators* and the `bᵢ` the *partial denominators* of the gcf.
We store the sequence of partial numerators and denominators in a sequence of
generalized_continued_fraction.pairs `s`.
For convenience, one often writes `[h; (a₀, b₀), (a₁, b₁), (a₂, b₂),...]`.
-/
structure generalized_continued_fraction :=
(h : α) (s : seq $ pair α)

variable {α}

namespace generalized_continued_fraction

/-- Constructs a generalized continued fraction without fractional part. -/
def of_integer (a : α) : generalized_continued_fraction α :=
⟨a, seq.nil⟩

instance [inhabited α] : inhabited (generalized_continued_fraction α) := ⟨of_integer default⟩

/-- Returns the sequence of partial numerators `aᵢ` of `g`. -/
def partial_numerators (g : generalized_continued_fraction α) : seq α :=
g.s.map pair.a
/-- Returns the sequence of partial denominators `bᵢ` of `g`. -/
def partial_denominators (g : generalized_continued_fraction α) : seq α :=
g.s.map pair.b

/-- A gcf terminated at position `n` if its sequence terminates at position `n`. -/
def terminated_at (g : generalized_continued_fraction α) (n : ℕ) : Prop := g.s.terminated_at n

/-- It is decidable whether a gcf terminated at a given position. -/
instance terminated_at_decidable (g : generalized_continued_fraction α) (n : ℕ) :
  decidable (g.terminated_at n) :=
by { unfold terminated_at, apply_instance }

/-- A gcf terminates if its sequence terminates. -/
def terminates (g : generalized_continued_fraction α) : Prop := g.s.terminates

section coe
/-! Interlude: define some expected coercions. -/
/- Fix another type `β` which we will convert to. -/
variables {β : Type*} [has_coe α β]

/-- Coerce a gcf by elementwise coercion. -/
instance has_coe_to_generalized_continued_fraction :
  has_coe (generalized_continued_fraction α) (generalized_continued_fraction β) :=
⟨λ g, ⟨(g.h : β), (g.s.map coe : seq $ pair β)⟩⟩

@[simp, norm_cast]
lemma coe_to_generalized_continued_fraction {g : generalized_continued_fraction α} :
  (↑(g : generalized_continued_fraction α) : generalized_continued_fraction β) =
    ⟨(g.h : β), (g.s.map coe : seq $ pair β)⟩ :=
rfl

end coe
end generalized_continued_fraction

/--
A generalized continued fraction is a *simple continued fraction* if all partial numerators are
equal to one.
$$
  h + \dfrac{1}
            {b_0 + \dfrac{1}
                         {b_1 + \dfrac{1}
                                      {b_2 + \dfrac{1}
                                                   {b_3 + \dots}}}}
$$
-/
def generalized_continued_fraction.is_simple_continued_fraction
  (g : generalized_continued_fraction α) [has_one α] : Prop :=
∀ (n : ℕ) (aₙ : α), g.partial_numerators.nth n = some aₙ → aₙ = 1

variable (α)
/--
A *simple continued fraction* (scf) is a generalized continued fraction (gcf) whose partial
numerators are equal to one.
$$
  h + \dfrac{1}
            {b_0 + \dfrac{1}
                         {b_1 + \dfrac{1}
                                      {b_2 + \dfrac{1}
                                                   {b_3 + \dots}}}}
$$
For convenience, one often writes `[h; b₀, b₁, b₂,...]`.
It is encoded as the subtype of gcfs that satisfy
`generalized_continued_fraction.is_simple_continued_fraction`.
 -/
def simple_continued_fraction [has_one α] :=
{g : generalized_continued_fraction α // g.is_simple_continued_fraction}

variable {α}
/- Interlude: define some expected coercions. -/
namespace simple_continued_fraction

variable [has_one α]

/-- Constructs a simple continued fraction without fractional part. -/
def of_integer (a : α) : simple_continued_fraction α :=
⟨generalized_continued_fraction.of_integer a, λ n aₙ h, by cases h⟩

instance : inhabited (simple_continued_fraction α) := ⟨of_integer 1⟩

/-- Lift a scf to a gcf using the inclusion map. -/
instance has_coe_to_generalized_continued_fraction :
  has_coe (simple_continued_fraction α) (generalized_continued_fraction α) :=
by {unfold simple_continued_fraction, apply_instance}

lemma coe_to_generalized_continued_fraction {s : simple_continued_fraction α} :
  (↑s : generalized_continued_fraction α) = s.val := rfl

end simple_continued_fraction

/--
A simple continued fraction is a *(regular) continued fraction* ((r)cf) if all partial denominators
`bᵢ` are positive, i.e. `0 < bᵢ`.
-/
def simple_continued_fraction.is_continued_fraction [has_one α] [has_zero α] [has_lt α]
  (s : simple_continued_fraction α) : Prop :=
∀ (n : ℕ) (bₙ : α),
  (↑s : generalized_continued_fraction α).partial_denominators.nth n = some bₙ → 0 < bₙ

variable (α)

/--
A *(regular) continued fraction* ((r)cf) is a simple continued fraction (scf) whose partial
denominators are all positive. It is the subtype of scfs that satisfy
`simple_continued_fraction.is_continued_fraction`.
 -/
def continued_fraction [has_one α] [has_zero α] [has_lt α] :=
{s : simple_continued_fraction α // s.is_continued_fraction}

variable {α}

/-! Interlude: define some expected coercions. -/
namespace continued_fraction

variables [has_one α] [has_zero α] [has_lt α]

/-- Constructs a continued fraction without fractional part. -/
def of_integer (a : α) : continued_fraction α :=
⟨simple_continued_fraction.of_integer a, λ n bₙ h, by cases h⟩

instance : inhabited (continued_fraction α) := ⟨of_integer 0⟩

/-- Lift a cf to a scf using the inclusion map. -/
instance has_coe_to_simple_continued_fraction :
  has_coe (continued_fraction α) (simple_continued_fraction α) :=
by {unfold continued_fraction, apply_instance}

lemma coe_to_simple_continued_fraction {c : continued_fraction α} :
  (↑c : simple_continued_fraction α) = c.val := rfl

/-- Lift a cf to a scf using the inclusion map. -/
instance has_coe_to_generalized_continued_fraction :
  has_coe (continued_fraction α) (generalized_continued_fraction α) :=
⟨λ c, ↑(↑c : simple_continued_fraction α)⟩

lemma coe_to_generalized_continued_fraction {c : continued_fraction α} :
  (↑c : generalized_continued_fraction α) = c.val := rfl

end continued_fraction

namespace generalized_continued_fraction
/-!
### Computation of Convergents

We now define how to compute the convergents of a gcf. There are two standard ways to do this:
directly evaluating the (infinite) fraction described by the gcf or using a recurrence relation.
For (r)cfs, these computations are equivalent as shown in
`algebra.continued_fractions.convergents_equiv`.
-/

-- Fix a division ring for the computations.
variables {K : Type*} [division_ring K]

/-!
We start with the definition of the recurrence relation. Given a gcf `g`, for all `n ≥ 1`, we define
- `A₋₁ = 1,  A₀ = h,  Aₙ = bₙ₋₁ * Aₙ₋₁ + aₙ₋₁ * Aₙ₋₂`, and
- `B₋₁ = 0,  B₀ = 1,  Bₙ = bₙ₋₁ * Bₙ₋₁ + aₙ₋₁ * Bₙ₋₂`.

`Aₙ, `Bₙ` are called the *nth continuants*, Aₙ the *nth numerator*, and `Bₙ` the
*nth denominator* of `g`. The *nth convergent* of `g` is given by `Aₙ / Bₙ`.
-/

/--
Returns the next numerator `Aₙ = bₙ₋₁ * Aₙ₋₁ + aₙ₋₁ * Aₙ₋₂`, where `predA` is `Aₙ₋₁`,
`ppredA` is `Aₙ₋₂`, `a` is `aₙ₋₁`, and `b` is `bₙ₋₁`.
-/
def next_numerator (a b ppredA predA : K) : K := b * predA + a * ppredA

/--
Returns the next denominator `Bₙ = bₙ₋₁ * Bₙ₋₁ + aₙ₋₁ * Bₙ₋₂``, where `predB` is `Bₙ₋₁` and
`ppredB` is `Bₙ₋₂`, `a` is `aₙ₋₁`, and `b` is `bₙ₋₁`.
-/
def next_denominator (aₙ bₙ ppredB predB : K) : K := bₙ * predB + aₙ * ppredB

/--
Returns the next continuants `⟨Aₙ, Bₙ⟩` using `next_numerator` and `next_denominator`, where `pred`
is `⟨Aₙ₋₁, Bₙ₋₁⟩`, `ppred` is `⟨Aₙ₋₂, Bₙ₋₂⟩`, `a` is `aₙ₋₁`, and `b` is `bₙ₋₁`.
-/
def next_continuants (a b : K) (ppred pred : pair K) : pair K :=
⟨next_numerator a b ppred.a pred.a, next_denominator a b ppred.b pred.b⟩

/-- Returns the continuants `⟨Aₙ₋₁, Bₙ₋₁⟩` of `g`. -/
def continuants_aux (g : generalized_continued_fraction K) : stream (pair K)
| 0 := ⟨1, 0⟩
| 1 := ⟨g.h, 1⟩
| (n + 2) :=
  match g.s.nth n with
  | none := continuants_aux (n + 1)
  | some gp := next_continuants gp.a gp.b (continuants_aux n) (continuants_aux $ n + 1)
  end

/-- Returns the continuants `⟨Aₙ, Bₙ⟩` of `g`. -/
def continuants (g : generalized_continued_fraction K) : stream (pair K) :=
g.continuants_aux.tail

/-- Returns the numerators `Aₙ` of `g`. -/
def numerators (g : generalized_continued_fraction K) : stream K :=
g.continuants.map pair.a

/-- Returns the denominators `Bₙ` of `g`. -/
def denominators (g : generalized_continued_fraction K) : stream K :=
g.continuants.map pair.b

/-- Returns the convergents `Aₙ / Bₙ` of `g`, where `Aₙ, Bₙ` are the nth continuants of `g`. -/
def convergents (g : generalized_continued_fraction K) : stream K :=
λ (n : ℕ), (g.numerators n) / (g.denominators n)

/--
Returns the approximation of the fraction described by the given sequence up to a given position n.
For example, `convergents'_aux [(1, 2), (3, 4), (5, 6)] 2 = 1 / (2 + 3 / 4)` and
`convergents'_aux [(1, 2), (3, 4), (5, 6)] 0 = 0`.
-/
def convergents'_aux : seq (pair K) → ℕ → K
| s 0 := 0
| s (n + 1) := match s.head with
  | none := 0
  | some gp := gp.a / (gp.b + convergents'_aux s.tail n)
  end

/--
Returns the convergents of `g` by evaluating the fraction described by `g` up to a given
position `n`. For example, `convergents' [9; (1, 2), (3, 4), (5, 6)] 2 = 9 + 1 / (2 + 3 / 4)` and
`convergents' [9; (1, 2), (3, 4), (5, 6)] 0 = 9`
-/
def convergents' (g : generalized_continued_fraction K) (n : ℕ) : K := g.h + convergents'_aux g.s n

end generalized_continued_fraction

-- Now, some basic, general theorems
namespace generalized_continued_fraction

/-- Two gcfs `g` and `g'` are equal if and only if their components are equal. -/
protected lemma ext_iff {g g' : generalized_continued_fraction α} :
  g = g' ↔ g.h = g'.h ∧ g.s = g'.s :=
by { cases g, cases g', simp }

@[ext]
protected lemma ext {g g' : generalized_continued_fraction α} (hyp : g.h = g'.h ∧ g.s = g'.s) :
  g = g' :=
generalized_continued_fraction.ext_iff.elim_right hyp

end generalized_continued_fraction


import data.equiv.basic

structure partition (X : Type) :=
(C : set (set X))
(Hnonempty : ∀ c ∈ C, c ≠ ∅)
(Hcover : ∀ x, ∃ c ∈ C, x ∈ c)
(Hunique : ∀ c d ∈ C, c ∩ d ≠ ∅ → c = d)

def partition.ext {X : Type} (P Q : partition X) (H : P.C = Q.C) : P = Q :=
begin
  cases P, cases Q,
  rwa partition.mk.inj_eq,
end

def equivalence_class {X : Type} (R : X → X → Prop) (x : X) := {y : X | R x y}

lemma mem_class {X : Type} {R : X → X → Prop} (HR : equivalence R) (x : X) : x ∈ equivalence_class R x :=
begin
  cases HR with HRR HR,
  exact HRR x,
end

example (X : Type) : {R : X → X → Prop // equivalence R} ≃ partition X :=
{ to_fun := λ R, {
    C := { S : set X | ∃ x : X, S = equivalence_class R x},
    Hnonempty := begin
      intro c,
      intro hc,
      cases hc with x hx,
      rw set.ne_empty_iff_nonempty,
      use x,
      rw hx,
      exact mem_class R.2 x,
    end,
    Hcover := begin
      intro x,
      use equivalence_class R x,
      existsi _,
      { exact mem_class R.2 x },
      use x,
    end,
    Hunique := begin
      intros c d hc hd hcd,
      rw set.ne_empty_iff_nonempty at hcd,
      cases hcd with x hx,
      cases hc with a ha,
      cases hd with b hb,
      cases R with  R HR,
      cases hx with hxc hxd,
      rw ha at *,
      rw hb at *,
      change R a x at hxc,
      change R b x at hxd,
      rcases HR with ⟨HRR, HRS, HRT⟩,
      apply set.subset.antisymm,
      { intros y hy,
        change R a y at hy,
        change R b y,
        refine HRT hxd _,
        refine HRT _ hy,
        apply HRS,
        assumption
      },
      { intros y hy,
        change R a y,
        change R b y at hy,
        refine HRT hxc _,
        refine HRT _ hy,
        apply HRS,
        assumption,
      }
    end },
  inv_fun := λ P, ⟨λ x y, ∃ c ∈ P.C, x ∈ c ∧ y ∈ c, begin
    split,
    { intro x,
      cases P.Hcover x with c hc,
      cases hc with hc hxc,
      use c,
      use hc,
      split; assumption,
    },
    split,
    { intros x y hxy,
      cases hxy with c hc,
      cases hc with hc1 hc2,
      use c,
      use hc1,
      cases hc2 with hx hy,
      split; assumption
    },
    { rintros x y z ⟨c, hc, hxc, hyc⟩ ⟨d, hd, hyd, hzd⟩,
      use c,
      use hc,
      split,
      exact hxc,
      have hcd : c = d,
      { apply P.Hunique c d,
        use hc,
        use hd,
        rw set.ne_empty_iff_nonempty,
        use y,
        split,
        use hyc,
        use hyd,
      },
      rw hcd,
      use hzd,
    }
  end⟩,
  left_inv := begin
    rintro ⟨R, HRR, HRS, HRT⟩,
    dsimp, -- not taught in NNG
    rw subtype.ext, -- not taught in NNG
    dsimp, -- not taught in NNG
    ext x y, -- not taught in NNG
    split,
    { rintro ⟨c, ⟨z, rfl⟩, ⟨hx, hy⟩⟩,
      refine HRT _ hy,
      apply HRS,
      exact hx,
    },
    { intro H,
      use equivalence_class R x,
      use x,
      split,
      exact HRR x,
      exact H,
    }
  end,
  right_inv := begin
    intro P,
    dsimp,
    cases P with C _ _ _,
    dsimp,
    apply partition.ext,
    dsimp, -- dsimps everywhere
    ext c,
    split,
    { intro h,
      dsimp at h,
      cases h with x hx,
      rw hx, clear hx,
      rcases P_Hcover x with ⟨d, hd, hxd⟩,
      convert hd, -- not taught in NNG
      clear c,
      ext y,
      split,
      { intro hy,
        unfold equivalence_class at hy,
        dsimp at hy,
        rcases hy with ⟨e, he, hxe, hye⟩,
        convert hye, -- not taught
        refine P_Hunique d e hd he _,
        rw set.ne_empty_iff_nonempty,
        use x,
        split;assumption
      },
      { intro hyd,
        unfold equivalence_class, dsimp,
        use d,
        use hd,
        split;assumption
      },
    },
    { intro hc,
      dsimp,
      have h := P_Hnonempty c hc,
      rw set.ne_empty_iff_nonempty at h,
      cases h with x hxc,
      use x,
      unfold equivalence_class,
      ext y,
      split,
      { intro hyc,
        dsimp,
        use c,
        use hc,
        split;assumption,
      },
      { intro h,
        dsimp at h,
        rcases h with ⟨d, hd, hxd, hyd⟩,
        convert hyd,
        apply P_Hunique c d hc hd,
        rw set.ne_empty_iff_nonempty,
        use x,
        split;assumption
      }
    }
  end }


/-
Copyright (c) 2020 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
prelude
import Init.Core
import Init.NotationExtra

universes u v

/- Classical reasoning support -/

namespace Classical

axiom choice {α : Sort u} : Nonempty α → α

noncomputable def indefiniteDescription {α : Sort u} (p : α → Prop) (h : ∃ x, p x) : {x // p x} :=
  choice <| let ⟨x, px⟩ := h; ⟨⟨x, px⟩⟩

noncomputable def choose {α : Sort u} {p : α → Prop} (h : ∃ x, p x) : α :=
  (indefiniteDescription p h).val

theorem chooseSpec {α : Sort u} {p : α → Prop} (h : ∃ x, p x) : p (choose h) :=
  (indefiniteDescription p h).property

/- Diaconescu's theorem: excluded middle from choice, Function extensionality and propositional extensionality. -/
theorem em (p : Prop) : p ∨ ¬p :=
  let U (x : Prop) : Prop := x = True ∨ p;
  let V (x : Prop) : Prop := x = False ∨ p;
  have exU : ∃ x, U x := ⟨True, Or.inl rfl⟩;
  have exV : ∃ x, V x := ⟨False, Or.inl rfl⟩;
  let u : Prop := choose exU;
  let v : Prop := choose exV;
  have uDef : U u := chooseSpec exU;
  have vDef : V v := chooseSpec exV;
  have notUvOrP : u ≠ v ∨ p :=
    match uDef, vDef with
    | Or.inr h, _ => Or.inr h
    | _, Or.inr h => Or.inr h
    | Or.inl hut, Or.inl hvf =>
      have hne : u ≠ v := hvf.symm ▸ hut.symm ▸ trueNeFalse
      Or.inl hne
  have pImpliesUv : p → u = v :=
    fun hp =>
    have hpred : U = V :=
      funext fun x =>
        have hl : (x = True ∨ p) → (x = False ∨ p) :=
          fun a => Or.inr hp;
        have hr : (x = False ∨ p) → (x = True ∨ p) :=
          fun a => Or.inr hp;
        show (x = True ∨ p) = (x = False ∨ p) from
          propext (Iff.intro hl hr);
    have h₀ : ∀ exU exV, @choose _ U exU = @choose _ V exV :=
      hpred ▸ fun exU exV => rfl;
    show u = v from h₀ ..;
  match notUvOrP with
  | Or.inl hne => Or.inr (mt pImpliesUv hne)
  | Or.inr h   => Or.inl h

theorem existsTrueOfNonempty {α : Sort u} : Nonempty α → ∃ x : α, True
  | ⟨x⟩ => ⟨x, trivial⟩

noncomputable def inhabitedOfNonempty {α : Sort u} (h : Nonempty α) : Inhabited α :=
  ⟨choice h⟩

noncomputable def inhabitedOfExists {α : Sort u} {p : α → Prop} (h : ∃ x, p x) : Inhabited α :=
  inhabitedOfNonempty (Exists.elim h (fun w hw => ⟨w⟩))

/- all propositions are Decidable -/
noncomputable scoped instance (priority := low) propDecidable (a : Prop) : Decidable a :=
  choice <| match em a with
    | Or.inl h => ⟨isTrue h⟩
    | Or.inr h => ⟨isFalse h⟩

noncomputable def decidableInhabited (a : Prop) : Inhabited (Decidable a) where
  default := inferInstance

noncomputable def typeDecidableEq (α : Sort u) : DecidableEq α :=
  fun x y => inferInstance

noncomputable def typeDecidable (α : Sort u) : PSum α (α → False) :=
  match (propDecidable (Nonempty α)) with
  | (isTrue hp)  => PSum.inl (@arbitrary _ (inhabitedOfNonempty hp))
  | (isFalse hn) => PSum.inr (fun a => absurd (Nonempty.intro a) hn)

noncomputable def strongIndefiniteDescription {α : Sort u} (p : α → Prop) (h : Nonempty α) : {x : α // (∃ y : α, p y) → p x} :=
  @dite _ (∃ x : α, p x) (propDecidable _)
    (fun (hp : ∃ x : α, p x) =>
      show {x : α // (∃ y : α, p y) → p x} from
      let xp := indefiniteDescription _ hp;
      ⟨xp.val, fun h' => xp.property⟩)
    (fun hp => ⟨choice h, fun h => absurd h hp⟩)

/- the Hilbert epsilon Function -/

noncomputable def epsilon {α : Sort u} [h : Nonempty α] (p : α → Prop) : α :=
  (strongIndefiniteDescription p h).val

theorem epsilonSpecAux {α : Sort u} (h : Nonempty α) (p : α → Prop) : (∃ y, p y) → p (@epsilon α h p) :=
  (strongIndefiniteDescription p h).property

theorem epsilonSpec {α : Sort u} {p : α → Prop} (hex : ∃ y, p y) : p (@epsilon α (nonemptyOfExists hex) p) :=
  epsilonSpecAux (nonemptyOfExists hex) p hex

theorem epsilonSingleton {α : Sort u} (x : α) : @epsilon α ⟨x⟩ (fun y => y = x) = x :=
  @epsilonSpec α (fun y => y = x) ⟨x, rfl⟩

/- the axiom of choice -/

theorem axiomOfChoice {α : Sort u} {β : α → Sort v} {r : ∀ x, β x → Prop} (h : ∀ x, ∃ y, r x y) : ∃ (f : ∀ x, β x), ∀ x, r x (f x) :=
  ⟨_, fun x => chooseSpec (h x)⟩

theorem skolem {α : Sort u} {b : α → Sort v} {p : ∀ x, b x → Prop} : (∀ x, ∃ y, p x y) ↔ ∃ (f : ∀ x, b x), ∀ x, p x (f x) :=
  ⟨axiomOfChoice, fun ⟨f, hw⟩ (x) => ⟨f x, hw x⟩⟩

theorem propComplete (a : Prop) : a = True ∨ a = False := by
  cases em a with
  | inl _  => apply Or.inl; apply propext; apply Iff.intro; { intros; apply True.intro }; { intro; assumption }
  | inr hn => apply Or.inr; apply propext; apply Iff.intro; { intro h; exact hn h }; { intro h; apply False.elim h }

-- this supercedes byCases in Decidable
theorem byCases {p q : Prop} (hpq : p → q) (hnpq : ¬p → q) : q :=
  Decidable.byCases (dec := propDecidable _) hpq hnpq

-- this supercedes byContradiction in Decidable
theorem byContradiction {p : Prop} (h : ¬p → False) : p :=
  Decidable.byContradiction (dec := propDecidable _) h

macro "byCases" h:ident ":" e:term : tactic =>
  `(cases em $e:term with
    | inl $h:ident => _
    | inr $h:ident => _)

end Classical


/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes
-/
import data.nat.modeq
import tactic.ring

/-!

# Congruences modulo an integer

This file defines the equivalence relation `a ≡ b [ZMOD n]` on the integers, similarly to how
`data.nat.modeq` defines them for the natural numbers. The notation is short for `n.modeq a b`,
which is defined to be `a % n = b % n` for integers `a b n`.

## Tags

modeq, congruence, mod, MOD, modulo, integers

-/

namespace int

/-- `a ≡ b [ZMOD n]` when `a % n = b % n`. -/
@[derive decidable]
def modeq (n a b : ℤ) := a % n = b % n

notation a ` ≡ `:50 b ` [ZMOD `:50 n `]`:0 := modeq n a b

variables {m n a b c d : ℤ}

namespace modeq

@[refl] protected theorem refl (a : ℤ) : a ≡ a [ZMOD n] := @rfl _ _

protected theorem rfl : a ≡ a [ZMOD n] := modeq.refl _

@[symm] protected theorem symm : a ≡ b [ZMOD n] → b ≡ a [ZMOD n] := eq.symm

@[trans] protected theorem trans : a ≡ b [ZMOD n] → b ≡ c [ZMOD n] → a ≡ c [ZMOD n] := eq.trans

end modeq

lemma coe_nat_modeq_iff {a b n : ℕ} : a ≡ b [ZMOD n] ↔ a ≡ b [MOD n] :=
by unfold modeq nat.modeq; rw ← int.coe_nat_eq_coe_nat_iff; simp [coe_nat_mod]

theorem modeq_zero_iff_dvd : a ≡ 0 [ZMOD n] ↔ n ∣ a :=
by rw [modeq, zero_mod, dvd_iff_mod_eq_zero]

lemma _root_.has_dvd.dvd.modeq_zero_int (h : n ∣ a) : a ≡ 0 [ZMOD n] := modeq_zero_iff_dvd.2 h
lemma _root_.has_dvd.dvd.zero_modeq_int (h : n ∣ a) : 0 ≡ a [ZMOD n] := h.modeq_zero_int.symm

theorem modeq_iff_dvd : a ≡ b [ZMOD n] ↔ n ∣ b - a :=
by rw [modeq, eq_comm];
   simp [mod_eq_mod_iff_mod_sub_eq_zero, dvd_iff_mod_eq_zero, -euclidean_domain.mod_eq_zero]

theorem modeq.dvd : a ≡ b [ZMOD n] → n ∣ b - a := modeq_iff_dvd.1
theorem modeq_of_dvd : n ∣ b - a → a ≡ b [ZMOD n] := modeq_iff_dvd.2

theorem mod_modeq (a n) : a % n ≡ a [ZMOD n] := mod_mod _ _

namespace modeq

protected theorem modeq_of_dvd (d : m ∣ n) (h : a ≡ b [ZMOD n]) : a ≡ b [ZMOD m] :=
modeq_iff_dvd.2 $ d.trans h.dvd

protected theorem mul_left' (hc : 0 ≤ c) (h : a ≡ b [ZMOD n]) : c * a ≡ c * b [ZMOD (c * n)] :=
or.cases_on hc.lt_or_eq (λ hc,
  by unfold modeq;
  simp [mul_mod_mul_of_pos hc, (show _ = _, from h)] )
(λ hc, by simp [hc.symm])

protected theorem mul_right' (hc : 0 ≤ c) (h : a ≡ b [ZMOD n]) : a * c ≡ b * c [ZMOD (n * c)] :=
by rw [mul_comm a, mul_comm b, mul_comm n]; exact h.mul_left' hc

protected theorem add (h₁ : a ≡ b [ZMOD n]) (h₂ : c ≡ d [ZMOD n]) : a + c ≡ b + d [ZMOD n] :=
modeq_iff_dvd.2 $ by { convert dvd_add h₁.dvd h₂.dvd, ring }

protected theorem add_left (c : ℤ) (h : a ≡ b [ZMOD n]) : c + a ≡ c + b [ZMOD n] :=
modeq.rfl.add h

protected theorem add_right (c : ℤ) (h : a ≡ b [ZMOD n]) : a + c ≡ b + c [ZMOD n] :=
h.add modeq.rfl

protected theorem add_left_cancel (h₁ : a ≡ b [ZMOD n]) (h₂ : a + c ≡ b + d [ZMOD n]) :
  c ≡ d [ZMOD n] :=
have d - c = b + d - (a + c) - (b - a) := by ring,
modeq_iff_dvd.2 $ by { rw [this], exact dvd_sub h₂.dvd h₁.dvd }

protected theorem add_left_cancel' (c : ℤ) (h : c + a ≡ c + b [ZMOD n]) : a ≡ b [ZMOD n] :=
modeq.rfl.add_left_cancel h

protected theorem add_right_cancel (h₁ : c ≡ d [ZMOD n]) (h₂ : a + c ≡ b + d [ZMOD n]) :
  a ≡ b [ZMOD n] :=
by { rw [add_comm a, add_comm b] at h₂, exact h₁.add_left_cancel h₂ }

protected theorem add_right_cancel' (c : ℤ) (h : a + c ≡ b + c [ZMOD n]) : a ≡ b [ZMOD n] :=
modeq.rfl.add_right_cancel h

protected theorem neg (h : a ≡ b [ZMOD n]) : -a ≡ -b [ZMOD n] :=
h.add_left_cancel (by simp_rw [←sub_eq_add_neg, sub_self])

protected theorem sub (h₁ : a ≡ b [ZMOD n]) (h₂ : c ≡ d [ZMOD n]) :
  a - c ≡ b - d [ZMOD n] :=
by { rw [sub_eq_add_neg, sub_eq_add_neg], exact h₁.add h₂.neg }

protected theorem sub_left (c : ℤ) (h : a ≡ b [ZMOD n]) : c - a ≡ c - b [ZMOD n] :=
modeq.rfl.sub h

protected theorem sub_right (c : ℤ) (h : a ≡ b [ZMOD n]) : a - c ≡ b - c [ZMOD n] :=
h.sub modeq.rfl

protected theorem mul_left (c : ℤ) (h : a ≡ b [ZMOD n]) : c * a ≡ c * b [ZMOD n] :=
or.cases_on (le_total 0 c)
(λ hc, (h.mul_left' hc).modeq_of_dvd (dvd_mul_left _ _) )
(λ hc, by rw [← neg_neg c, ← neg_mul_eq_neg_mul, ← neg_mul_eq_neg_mul _ b];
    exact ((h.mul_left' $ neg_nonneg.2 hc).modeq_of_dvd (dvd_mul_left _ _)).neg)

protected theorem mul_right (c : ℤ) (h : a ≡ b [ZMOD n]) : a * c ≡ b * c [ZMOD n] :=
by { rw [mul_comm a, mul_comm b], exact h.mul_left c }

protected theorem mul (h₁ : a ≡ b [ZMOD n]) (h₂ : c ≡ d [ZMOD n]) : a * c ≡ b * d [ZMOD n] :=
(h₂.mul_left _).trans (h₁.mul_right _)

protected theorem pow (m : ℕ) (h : a ≡ b [ZMOD n]) : a ^ m ≡ b ^ m [ZMOD n] :=
begin
  induction m with d hd, {refl},
  rw [pow_succ, pow_succ],
  exact h.mul hd,
end

theorem of_modeq_mul_left (m : ℤ) (h : a ≡ b [ZMOD m * n]) : a ≡ b [ZMOD n] :=
by rw [modeq_iff_dvd] at *; exact (dvd_mul_left n m).trans h

theorem of_modeq_mul_right (m : ℤ) : a ≡ b [ZMOD n * m] → a ≡ b [ZMOD n] :=
mul_comm m n ▸ of_modeq_mul_left _

end modeq

theorem modeq_one : a ≡ b [ZMOD 1] := modeq_of_dvd (one_dvd _)

lemma modeq_sub (a b : ℤ) : a ≡ b [ZMOD a - b] :=
(modeq_of_dvd dvd_rfl).symm

lemma modeq_and_modeq_iff_modeq_mul {a b m n : ℤ} (hmn : m.nat_abs.coprime n.nat_abs) :
  a ≡ b [ZMOD m] ∧ a ≡ b [ZMOD n] ↔ (a ≡ b [ZMOD m * n]) :=
⟨λ h, begin
    rw [modeq_iff_dvd, modeq_iff_dvd] at h,
    rw [modeq_iff_dvd, ← nat_abs_dvd, ← dvd_nat_abs,
      coe_nat_dvd, nat_abs_mul],
    refine hmn.mul_dvd_of_dvd_of_dvd _ _;
    rw [← coe_nat_dvd, nat_abs_dvd, dvd_nat_abs]; tauto
  end,
λ h, ⟨h.of_modeq_mul_right _, h.of_modeq_mul_left _⟩⟩

lemma gcd_a_modeq (a b : ℕ) : (a : ℤ) * nat.gcd_a a b ≡ nat.gcd a b [ZMOD b] :=
by { rw [← add_zero ((a : ℤ) * _), nat.gcd_eq_gcd_ab],
  exact (dvd_mul_right _ _).zero_modeq_int.add_left _ }

theorem modeq_add_fac {a b n : ℤ} (c : ℤ) (ha : a ≡ b [ZMOD n]) : a + n*c ≡ b [ZMOD n] :=
calc a + n*c ≡ b + n*c [ZMOD n] : ha.add_right _
         ... ≡ b + 0 [ZMOD n] : (dvd_mul_right _ _).modeq_zero_int.add_left _
         ... ≡ b [ZMOD n] : by rw add_zero

lemma mod_coprime {a b : ℕ} (hab : nat.coprime a b) : ∃ y : ℤ, a * y ≡ 1 [ZMOD b] :=
⟨ nat.gcd_a a b,
  have hgcd : nat.gcd a b = 1, from nat.coprime.gcd_eq_one hab,
  calc
   ↑a * nat.gcd_a a b ≡ ↑a * nat.gcd_a a b + ↑b * nat.gcd_b a b [ZMOD ↑b] : modeq.symm $
                      modeq_add_fac _ $ modeq.refl _
              ... ≡ 1 [ZMOD ↑b] : by rw [← nat.gcd_eq_gcd_ab, hgcd]; reflexivity ⟩

lemma exists_unique_equiv (a : ℤ) {b : ℤ} (hb : 0 < b) : ∃ z : ℤ, 0 ≤ z ∧ z < b ∧ z ≡ a [ZMOD b] :=
⟨ a % b, mod_nonneg _ (ne_of_gt hb),
  have a % b < |b|, from mod_lt _ (ne_of_gt hb),
  by rwa abs_of_pos hb at this,
  by simp [modeq] ⟩

lemma exists_unique_equiv_nat (a : ℤ) {b : ℤ} (hb : 0 < b) : ∃ z : ℕ, ↑z < b ∧ ↑z ≡ a [ZMOD b] :=
let ⟨z, hz1, hz2, hz3⟩ := exists_unique_equiv a hb in
⟨z.nat_abs, by split; rw [←of_nat_eq_coe, of_nat_nat_abs_eq_of_nonneg hz1]; assumption⟩

@[simp] lemma mod_mul_right_mod (a b c : ℤ) : a % (b * c) % b = a % b :=
(mod_modeq _ _).of_modeq_mul_right _

@[simp] lemma mod_mul_left_mod (a b c : ℤ) : a % (b * c) % c = a % c :=
(mod_modeq _ _).of_modeq_mul_left _

end int


/-
Copyright (c) 2020 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov, Johannes Hölzl
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.order.conditionally_complete_lattice
import Mathlib.logic.function.iterate
import Mathlib.order.rel_iso
import Mathlib.PostPort

universes u v w x

namespace Mathlib

/-!
# Order continuity

We say that a function is *left order continuous* if it sends all least upper bounds
to least upper bounds. The order dual notion is called *right order continuity*.

For monotone functions `ℝ → ℝ` these notions correspond to the usual left and right continuity.

We prove some basic lemmas (`map_sup`, `map_Sup` etc) and prove that an `rel_iso` is both left
and right order continuous.
-/

/-!
### Definitions
-/

/-- A function `f` between preorders is left order continuous if it preserves all suprema.  We
define it using `is_lub` instead of `Sup` so that the proof works both for complete lattices and
conditionally complete lattices. -/
def left_ord_continuous {α : Type u} {β : Type v} [preorder α] [preorder β] (f : α → β) :=
  ∀ {s : set α} {x : α}, is_lub s x → is_lub (f '' s) (f x)

/-- A function `f` between preorders is right order continuous if it preserves all infima.  We
define it using `is_glb` instead of `Inf` so that the proof works both for complete lattices and
conditionally complete lattices. -/
def right_ord_continuous {α : Type u} {β : Type v} [preorder α] [preorder β] (f : α → β) :=
  ∀ {s : set α} {x : α}, is_glb s x → is_glb (f '' s) (f x)

namespace left_ord_continuous

protected theorem id (α : Type u) [preorder α] : left_ord_continuous id := sorry

protected theorem order_dual {α : Type u} {β : Type v} [preorder α] [preorder β] {f : α → β} (hf : left_ord_continuous f) : right_ord_continuous f :=
  hf

theorem map_is_greatest {α : Type u} {β : Type v} [preorder α] [preorder β] {f : α → β} (hf : left_ord_continuous f) {s : set α} {x : α} (h : is_greatest s x) : is_greatest (f '' s) (f x) :=
  { left := set.mem_image_of_mem f (and.left h), right := and.left (hf (is_greatest.is_lub h)) }

theorem mono {α : Type u} {β : Type v} [preorder α] [preorder β] {f : α → β} (hf : left_ord_continuous f) : monotone f := sorry

theorem comp {α : Type u} {β : Type v} {γ : Type w} [preorder α] [preorder β] [preorder γ] {g : β → γ} {f : α → β} (hg : left_ord_continuous g) (hf : left_ord_continuous f) : left_ord_continuous (g ∘ f) := sorry

protected theorem iterate {α : Type u} [preorder α] {f : α → α} (hf : left_ord_continuous f) (n : ℕ) : left_ord_continuous (nat.iterate f n) :=
  nat.rec_on n (left_ord_continuous.id α) fun (n : ℕ) (ihn : left_ord_continuous (nat.iterate f n)) => comp ihn hf

theorem map_sup {α : Type u} {β : Type v} [semilattice_sup α] [semilattice_sup β] {f : α → β} (hf : left_ord_continuous f) (x : α) (y : α) : f (x ⊔ y) = f x ⊔ f y := sorry

theorem le_iff {α : Type u} {β : Type v} [semilattice_sup α] [semilattice_sup β] {f : α → β} (hf : left_ord_continuous f) (h : function.injective f) {x : α} {y : α} : f x ≤ f y ↔ x ≤ y := sorry

theorem lt_iff {α : Type u} {β : Type v} [semilattice_sup α] [semilattice_sup β] {f : α → β} (hf : left_ord_continuous f) (h : function.injective f) {x : α} {y : α} : f x < f y ↔ x < y := sorry

/-- Convert an injective left order continuous function to an order embedding. -/
def to_order_embedding {α : Type u} {β : Type v} [semilattice_sup α] [semilattice_sup β] (f : α → β) (hf : left_ord_continuous f) (h : function.injective f) : α ↪o β :=
  rel_embedding.mk (function.embedding.mk f h) sorry

@[simp] theorem coe_to_order_embedding {α : Type u} {β : Type v} [semilattice_sup α] [semilattice_sup β] {f : α → β} (hf : left_ord_continuous f) (h : function.injective f) : ⇑(to_order_embedding f hf h) = f :=
  rfl

theorem map_Sup' {α : Type u} {β : Type v} [complete_lattice α] [complete_lattice β] {f : α → β} (hf : left_ord_continuous f) (s : set α) : f (Sup s) = Sup (f '' s) :=
  Eq.symm (is_lub.Sup_eq (hf (is_lub_Sup s)))

theorem map_Sup {α : Type u} {β : Type v} [complete_lattice α] [complete_lattice β] {f : α → β} (hf : left_ord_continuous f) (s : set α) : f (Sup s) = supr fun (x : α) => supr fun (H : x ∈ s) => f x :=
  eq.mpr (id (Eq._oldrec (Eq.refl (f (Sup s) = supr fun (x : α) => supr fun (H : x ∈ s) => f x)) (map_Sup' hf s)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (Sup (f '' s) = supr fun (x : α) => supr fun (H : x ∈ s) => f x)) Sup_image))
      (Eq.refl (supr fun (a : α) => supr fun (H : a ∈ s) => f a)))

theorem map_supr {α : Type u} {β : Type v} {ι : Sort x} [complete_lattice α] [complete_lattice β] {f : α → β} (hf : left_ord_continuous f) (g : ι → α) : f (supr fun (i : ι) => g i) = supr fun (i : ι) => f (g i) := sorry

theorem map_cSup {α : Type u} {β : Type v} [conditionally_complete_lattice α] [conditionally_complete_lattice β] {f : α → β} (hf : left_ord_continuous f) {s : set α} (sne : set.nonempty s) (sbdd : bdd_above s) : f (Sup s) = Sup (f '' s) :=
  Eq.symm (is_lub.cSup_eq (hf (is_lub_cSup sne sbdd)) (set.nonempty.image f sne))

theorem map_csupr {α : Type u} {β : Type v} {ι : Sort x} [conditionally_complete_lattice α] [conditionally_complete_lattice β] [Nonempty ι] {f : α → β} (hf : left_ord_continuous f) {g : ι → α} (hg : bdd_above (set.range g)) : f (supr fun (i : ι) => g i) = supr fun (i : ι) => f (g i) := sorry

end left_ord_continuous

namespace right_ord_continuous

protected theorem id (α : Type u) [preorder α] : right_ord_continuous id := sorry

protected theorem order_dual {α : Type u} {β : Type v} [preorder α] [preorder β] {f : α → β} (hf : right_ord_continuous f) : left_ord_continuous f :=
  hf

theorem map_is_least {α : Type u} {β : Type v} [preorder α] [preorder β] {f : α → β} (hf : right_ord_continuous f) {s : set α} {x : α} (h : is_least s x) : is_least (f '' s) (f x) :=
  left_ord_continuous.map_is_greatest (right_ord_continuous.order_dual hf) h

theorem mono {α : Type u} {β : Type v} [preorder α] [preorder β] {f : α → β} (hf : right_ord_continuous f) : monotone f :=
  monotone.order_dual (left_ord_continuous.mono (right_ord_continuous.order_dual hf))

theorem comp {α : Type u} {β : Type v} {γ : Type w} [preorder α] [preorder β] [preorder γ] {g : β → γ} {f : α → β} (hg : right_ord_continuous g) (hf : right_ord_continuous f) : right_ord_continuous (g ∘ f) :=
  left_ord_continuous.comp (right_ord_continuous.order_dual hg) (right_ord_continuous.order_dual hf)

protected theorem iterate {α : Type u} [preorder α] {f : α → α} (hf : right_ord_continuous f) (n : ℕ) : right_ord_continuous (nat.iterate f n) :=
  left_ord_continuous.iterate (right_ord_continuous.order_dual hf) n

theorem map_inf {α : Type u} {β : Type v} [semilattice_inf α] [semilattice_inf β] {f : α → β} (hf : right_ord_continuous f) (x : α) (y : α) : f (x ⊓ y) = f x ⊓ f y :=
  left_ord_continuous.map_sup (right_ord_continuous.order_dual hf) x y

theorem le_iff {α : Type u} {β : Type v} [semilattice_inf α] [semilattice_inf β] {f : α → β} (hf : right_ord_continuous f) (h : function.injective f) {x : α} {y : α} : f x ≤ f y ↔ x ≤ y :=
  left_ord_continuous.le_iff (right_ord_continuous.order_dual hf) h

theorem lt_iff {α : Type u} {β : Type v} [semilattice_inf α] [semilattice_inf β] {f : α → β} (hf : right_ord_continuous f) (h : function.injective f) {x : α} {y : α} : f x < f y ↔ x < y :=
  left_ord_continuous.lt_iff (right_ord_continuous.order_dual hf) h

/-- Convert an injective left order continuous function to a `order_embedding`. -/
def to_order_embedding {α : Type u} {β : Type v} [semilattice_inf α] [semilattice_inf β] (f : α → β) (hf : right_ord_continuous f) (h : function.injective f) : α ↪o β :=
  rel_embedding.mk (function.embedding.mk f h) sorry

@[simp] theorem coe_to_order_embedding {α : Type u} {β : Type v} [semilattice_inf α] [semilattice_inf β] {f : α → β} (hf : right_ord_continuous f) (h : function.injective f) : ⇑(to_order_embedding f hf h) = f :=
  rfl

theorem map_Inf' {α : Type u} {β : Type v} [complete_lattice α] [complete_lattice β] {f : α → β} (hf : right_ord_continuous f) (s : set α) : f (Inf s) = Inf (f '' s) :=
  left_ord_continuous.map_Sup' (right_ord_continuous.order_dual hf) s

theorem map_Inf {α : Type u} {β : Type v} [complete_lattice α] [complete_lattice β] {f : α → β} (hf : right_ord_continuous f) (s : set α) : f (Inf s) = infi fun (x : α) => infi fun (H : x ∈ s) => f x :=
  left_ord_continuous.map_Sup (right_ord_continuous.order_dual hf) s

theorem map_infi {α : Type u} {β : Type v} {ι : Sort x} [complete_lattice α] [complete_lattice β] {f : α → β} (hf : right_ord_continuous f) (g : ι → α) : f (infi fun (i : ι) => g i) = infi fun (i : ι) => f (g i) :=
  left_ord_continuous.map_supr (right_ord_continuous.order_dual hf) g

theorem map_cInf {α : Type u} {β : Type v} [conditionally_complete_lattice α] [conditionally_complete_lattice β] {f : α → β} (hf : right_ord_continuous f) {s : set α} (sne : set.nonempty s) (sbdd : bdd_below s) : f (Inf s) = Inf (f '' s) :=
  left_ord_continuous.map_cSup (right_ord_continuous.order_dual hf) sne sbdd

theorem map_cinfi {α : Type u} {β : Type v} {ι : Sort x} [conditionally_complete_lattice α] [conditionally_complete_lattice β] [Nonempty ι] {f : α → β} (hf : right_ord_continuous f) {g : ι → α} (hg : bdd_below (set.range g)) : f (infi fun (i : ι) => g i) = infi fun (i : ι) => f (g i) :=
  left_ord_continuous.map_csupr (right_ord_continuous.order_dual hf) hg

end right_ord_continuous

namespace order_iso

protected theorem left_ord_continuous {α : Type u} {β : Type v} [preorder α] [preorder β] (e : α ≃o β) : left_ord_continuous ⇑e := sorry

protected theorem right_ord_continuous {α : Type u} {β : Type v} [preorder α] [preorder β] (e : α ≃o β) : right_ord_continuous ⇑e :=
  order_iso.left_ord_continuous (order_iso.dual e)


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

! This file was ported from Lean 3 source module measure_theory.function.floor
! leanprover-community/mathlib commit d003c55042c3cd08aefd1ae9a42ef89441cdaaf3
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.MeasureTheory.Constructions.BorelSpace

/-!
# Measurability of `⌊x⌋` etc

In this file we prove that `int.floor`, `int.ceil`, `int.fract`, `nat.floor`, and `nat.ceil` are
measurable under some assumptions on the (semi)ring.
-/

open Set

section FloorRing

variable {α R : Type _} [MeasurableSpace α] [LinearOrderedRing R] [FloorRing R] [TopologicalSpace R]
  [OrderTopology R] [MeasurableSpace R]

theorem Int.measurable_floor [OpensMeasurableSpace R] : Measurable (Int.floor : R → ℤ) :=
  measurable_to_countable fun x => by
    simpa only [Int.preimage_floor_singleton] using measurableSet_Ico
#align int.measurable_floor Int.measurable_floor

@[measurability]
theorem Measurable.floor [OpensMeasurableSpace R] {f : α → R} (hf : Measurable f) :
    Measurable fun x => ⌊f x⌋ :=
  Int.measurable_floor.comp hf
#align measurable.floor Measurable.floor

theorem Int.measurable_ceil [OpensMeasurableSpace R] : Measurable (Int.ceil : R → ℤ) :=
  measurable_to_countable fun x => by
    simpa only [Int.preimage_ceil_singleton] using measurableSet_Ioc
#align int.measurable_ceil Int.measurable_ceil

@[measurability]
theorem Measurable.ceil [OpensMeasurableSpace R] {f : α → R} (hf : Measurable f) :
    Measurable fun x => ⌈f x⌉ :=
  Int.measurable_ceil.comp hf
#align measurable.ceil Measurable.ceil

theorem measurable_fract [BorelSpace R] : Measurable (Int.fract : R → R) :=
  by
  intro s hs
  rw [Int.preimage_fract]
  exact MeasurableSet.unionᵢ fun z => measurable_id.sub_const _ (hs.inter measurableSet_Ico)
#align measurable_fract measurable_fract

@[measurability]
theorem Measurable.fract [BorelSpace R] {f : α → R} (hf : Measurable f) :
    Measurable fun x => Int.fract (f x) :=
  measurable_fract.comp hf
#align measurable.fract Measurable.fract

theorem MeasurableSet.image_fract [BorelSpace R] {s : Set R} (hs : MeasurableSet s) :
    MeasurableSet (Int.fract '' s) :=
  by
  simp only [Int.image_fract, sub_eq_add_neg, image_add_right']
  exact MeasurableSet.unionᵢ fun m => (measurable_add_const _ hs).inter measurableSet_Ico
#align measurable_set.image_fract MeasurableSet.image_fract

end FloorRing

section FloorSemiring

variable {α R : Type _} [MeasurableSpace α] [LinearOrderedSemiring R] [FloorSemiring R]
  [TopologicalSpace R] [OrderTopology R] [MeasurableSpace R] [OpensMeasurableSpace R] {f : α → R}

theorem Nat.measurable_floor : Measurable (Nat.floor : R → ℕ) :=
  measurable_to_countable fun n => by
    cases eq_or_ne ⌊n⌋₊ 0 <;> simp [*, Nat.preimage_floor_of_ne_zero]
#align nat.measurable_floor Nat.measurable_floor

@[measurability]
theorem Measurable.nat_floor (hf : Measurable f) : Measurable fun x => ⌊f x⌋₊ :=
  Nat.measurable_floor.comp hf
#align measurable.nat_floor Measurable.nat_floor

theorem Nat.measurable_ceil : Measurable (Nat.ceil : R → ℕ) :=
  measurable_to_countable fun n => by
    cases eq_or_ne ⌈n⌉₊ 0 <;> simp [*, Nat.preimage_ceil_of_ne_zero]
#align nat.measurable_ceil Nat.measurable_ceil

@[measurability]
theorem Measurable.nat_ceil (hf : Measurable f) : Measurable fun x => ⌈f x⌉₊ :=
  Nat.measurable_ceil.comp hf
#align measurable.nat_ceil Measurable.nat_ceil

end FloorSemiring


lemma add_mul (a b t : mynat) : (a + b) * t = a * t + b * t :=
begin
induction t with h hd,
repeat {rw mul_zero},
refl,
repeat {rw mul_succ},
rw hd,
rw add_right_comm,
rw add_assoc,
rw add_assoc,
rw add_comm (b * h),
rw add_assoc,
refl,
end


import nat.width
import nat.lemmas

namespace counter

open nat

def idx (m n : nat) := (2 ^ m - 1) + n

theorem idx_pos {m n : nat} (m_pos : m > 0): 0 < idx m n
:= by rw [idx]; exact zero_lt_add_of_pos_left _ (zero_lt_pow2_sub_one m_pos)

theorem idx_succ {m n : nat}: succ (idx m n) = (2 ^ m) + n
:= begin
  rw [idx, <-add_one],
  rw [nat.add_assoc, nat.add_comm n 1, <-nat.add_assoc],
  rw [nat.sub_add_cancel (one_le_pow m two_pos)],
end

def idx_width (n : nat) : nat := width n.succ - 1

theorem idx_width_zero : idx_width 0 = 0 := rfl

theorem idx_width_of_idx {m n : nat} (h : n < 2 ^ m): idx_width (idx m n) = m
:= by rw [idx_width, idx_succ, width_pow2_add h, succ_sub_one]

def counter (n : nat):
Pi (i : nat), i < idx_width n -> bool
:= fun i _, test_bit (n.succ - 2 ^ (idx_width n)) i

theorem counter_val (n i : nat) (h : i < idx_width n):
counter n i h = test_bit (n.succ - 2 ^ (idx_width n)) i
:= rfl

def bit (n i : nat)
:= counter (idx (max i.succ (width n)) n) i begin
  rw [idx_width_of_idx],
  exact le_max_left (succ i) _,
  exact lt_pow2_max_width_right _ _,
end

theorem bit_eq_test_bit {n i : nat}:
bit n i = test_bit n i
:= begin
  rw [bit, counter_val],
  rw [idx_succ, idx_width_of_idx (lt_pow2_max_width_right _ _)],
  rw [add_comm, nat.add_sub_cancel],
end

def sub_bit (n i : nat) (h : i < width n)
:= counter (idx (width n) n) i begin
  rw [idx_width_of_idx (lt_pow2_of_width n)], exact h
end

theorem sub_bit_eq_test_bit {n i : nat} (h : i < width n):
sub_bit n i h = test_bit n i
:= begin
  rw [sub_bit, counter_val],
  rw [idx_succ, idx_width_of_idx (lt_pow2_of_width n)],
  rw [add_comm, nat.add_sub_cancel],
end

end counter


import algebra.category.Group.limits
import category_theory.limits.concrete_category

universes u v

namespace Ab

open category_theory
open category_theory.limits

variables {J : Type u} [category_theory.small_category J] (K : J ⥤ Ab.{max u v})

lemma comp_apply {A B C : Ab} (f : A ⟶ B) (g : B ⟶ C) (a : A) :
  (f ≫ g) a = g (f a) := rfl

instance : add_comm_group (K ⋙ category_theory.forget _).sections :=
{ add := λ u v, ⟨ u + v, λ i j f, begin
    have u2 := u.2 f,
    have v2 := v.2 f,
    dsimp only [functor.comp_map, pi.add_apply, forget_map_eq_coe, subtype.val_eq_coe] at ⊢ u2 v2,
    simp only [u2, v2, map_add],
  end⟩,
  add_assoc := λ a b c, by { ext, simp only [add_assoc, subtype.coe_mk] },
  zero := ⟨0, λ i j f, by { dsimp only [functor.comp_map, pi.zero_apply,
    forget_map_eq_coe], rw [map_zero] }⟩,
  zero_add := λ a, by { ext, simp only [subtype.coe_mk, zero_add] },
  add_zero := λ a, by { ext, simp only [subtype.coe_mk, add_zero] },
  neg := λ t, ⟨ -t, begin
    intros i j f,
    have t2 := t.2 f,
    dsimp only [functor.comp_map, pi.neg_apply, forget_map_eq_coe, subtype.val_eq_coe] at ⊢ t2,
    simp only [map_neg, t2],
  end ⟩,
  add_left_neg := λ a, by { ext, change - (a.1 x) + a.1 x = 0, simp only [add_left_neg] },
  add_comm := λ a b, by { ext, change (a.1 x) + (b.1 x) = (b.1 x) + (a.1 x), rw [add_comm] } }

def explicit_limit_cone : cone K :=
{ X := AddCommGroup.of (K ⋙ category_theory.forget _).sections,
  π :=
  { app := λ j,
    { to_fun := λ t, t.1 j,
      map_zero' := rfl,
      map_add' := λ x y, rfl },
    naturality' := begin
      intros i j f,
      ext,
      simpa using (x.2 f).symm,
    end } }

def explicit_limit_cone_is_limit : is_limit (explicit_limit_cone K) :=
{ lift := λ S,
  { to_fun := λ t, ⟨λ j, S.π.app j t, begin
      intros i j f,
      dsimp,
      rw ← S.w f,
      refl,
    end⟩,
    map_zero' := by { ext, dsimp, simpa },
    map_add' := λ x y, by { ext, dsimp, simpa } },
  fac' := begin
    intros S j,
    ext,
    refl,
  end,
  uniq' := begin
    intros S m hm,
    ext,
    simpa [← hm],
  end }

noncomputable
def barx : preserves_limit K (forget Ab.{max u v}) :=
preserves_limits_of_shape.preserves_limit

noncomputable
instance foo {K : J ⥤ Ab.{u}} : preserves_limit K (forget Ab.{u}) :=
barx.{u u} K

lemma is_limit_ext {K : J ⥤ Ab.{u}} (C : limit_cone K) (x y : C.cone.X)
  (h : ∀ j : J, C.cone.π.app j x = C.cone.π.app j y) : x = y :=
limits.concrete.is_limit_ext K C.2 _ _ h

noncomputable
instance forget_creates_limit (J : Type u) [small_category J] (K : J ⥤ Ab.{max u v}) :
  creates_limit K (forget Ab) :=
creates_limit_of_reflects_iso $ λ C hC,
{ lifted_cone := explicit_limit_cone _,
  valid_lift := (types.limit_cone_is_limit _).unique_up_to_iso hC,
  makes_limit := explicit_limit_cone_is_limit _ }

-- Do we have this somewhere else?
noncomputable
instance forget_creates_limits : creates_limits (forget Ab.{max u v}) :=
by { constructor, introsI J hJ, constructor, intros K, apply Ab.forget_creates_limit.{_ u} J K }

-- Do we have this somewhere else?
noncomputable
instance forget_creates_limits' : creates_limits (forget Ab.{u}) :=
Ab.forget_creates_limits.{u u}

end Ab


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

/-!
# Projection to a subspace

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

In this file we define
* `linear_proj_of_is_compl (p q : submodule R E) (h : is_compl p q)`: the projection of a module `E`
  to a submodule `p` along its complement `q`; it is the unique linear map `f : E → p` such that
  `f x = x` for `x ∈ p` and `f x = 0` for `x ∈ q`.
* `is_compl_equiv_proj p`: equivalence between submodules `q` such that `is_compl p q` and
  projections `f : E → p`, `∀ x ∈ p, f x = x`.

We also provide some lemmas justifying correctness of our definitions.

## Tags

projection, complement subspace
-/

section ring

variables {R : Type*} [ring R] {E : Type*} [add_comm_group E] [module R E]
  {F : Type*} [add_comm_group F] [module R F]
  {G : Type*} [add_comm_group G] [module R G] (p q : submodule R E)
variables {S : Type*} [semiring S] {M : Type*} [add_comm_monoid M] [module S M] (m : submodule S M)

noncomputable theory

namespace linear_map

variable {p}

open submodule

lemma ker_id_sub_eq_of_proj {f : E →ₗ[R] p} (hf : ∀ x : p, f x = x) :
  ker (id - p.subtype.comp f) = p :=
begin
  ext x,
  simp only [comp_apply, mem_ker, subtype_apply, sub_apply, id_apply, sub_eq_zero],
  exact ⟨λ h, h.symm ▸ submodule.coe_mem _, λ hx, by erw [hf ⟨x, hx⟩, subtype.coe_mk]⟩
end

lemma range_eq_of_proj {f : E →ₗ[R] p} (hf : ∀ x : p, f x = x) :
  range f = ⊤ :=
range_eq_top.2 $ λ x, ⟨x, hf x⟩

lemma is_compl_of_proj {f : E →ₗ[R] p} (hf : ∀ x : p, f x = x) :
  is_compl p f.ker :=
begin
  split,
  { rw disjoint_iff_inf_le,
    rintros x ⟨hpx, hfx⟩,
    erw [set_like.mem_coe, mem_ker, hf ⟨x, hpx⟩, mk_eq_zero] at hfx,
    simp only [hfx, set_like.mem_coe, zero_mem] },
  { rw codisjoint_iff_le_sup,
    intros x hx,
    rw [mem_sup'],
    refine ⟨f x, ⟨x - f x, _⟩, add_sub_cancel'_right _ _⟩,
    rw [mem_ker, linear_map.map_sub, hf, sub_self] }
end

end linear_map

namespace submodule

open linear_map

/-- If `q` is a complement of `p`, then `M/p ≃ q`. -/
def quotient_equiv_of_is_compl (h : is_compl p q) : (E ⧸ p) ≃ₗ[R] q :=
linear_equiv.symm $ linear_equiv.of_bijective (p.mkq.comp q.subtype)
  ⟨by rw [← ker_eq_bot, ker_comp, ker_mkq, disjoint_iff_comap_eq_bot.1 h.symm.disjoint],
   by rw [← range_eq_top, range_comp, range_subtype, map_mkq_eq_top, h.sup_eq_top]⟩

@[simp] lemma quotient_equiv_of_is_compl_symm_apply (h : is_compl p q) (x : q) :
  (quotient_equiv_of_is_compl p q h).symm x = quotient.mk x := rfl

@[simp] lemma quotient_equiv_of_is_compl_apply_mk_coe (h : is_compl p q) (x : q) :
  quotient_equiv_of_is_compl p q h (quotient.mk x) = x :=
(quotient_equiv_of_is_compl p q h).apply_symm_apply x

@[simp] lemma mk_quotient_equiv_of_is_compl_apply (h : is_compl p q) (x : E ⧸ p) :
  (quotient.mk (quotient_equiv_of_is_compl p q h x) : E ⧸ p) = x :=
(quotient_equiv_of_is_compl p q h).symm_apply_apply x

/-- If `q` is a complement of `p`, then `p × q` is isomorphic to `E`. It is the unique
linear map `f : E → p` such that `f x = x` for `x ∈ p` and `f x = 0` for `x ∈ q`. -/
def prod_equiv_of_is_compl (h : is_compl p q) : (p × q) ≃ₗ[R] E :=
begin
  apply linear_equiv.of_bijective (p.subtype.coprod q.subtype),
  split,
  { rw [← ker_eq_bot, ker_coprod_of_disjoint_range, ker_subtype, ker_subtype, prod_bot],
    rw [range_subtype, range_subtype],
    exact h.1 },
  { rw [← range_eq_top, ← sup_eq_range, h.sup_eq_top] }
end

@[simp] lemma coe_prod_equiv_of_is_compl (h : is_compl p q) :
  (prod_equiv_of_is_compl p q h : (p × q) →ₗ[R] E) = p.subtype.coprod q.subtype := rfl

@[simp] lemma coe_prod_equiv_of_is_compl' (h : is_compl p q) (x : p × q) :
  prod_equiv_of_is_compl p q h x = x.1 + x.2 := rfl

@[simp] lemma prod_equiv_of_is_compl_symm_apply_left (h : is_compl p q) (x : p) :
  (prod_equiv_of_is_compl p q h).symm x = (x, 0) :=
(prod_equiv_of_is_compl p q h).symm_apply_eq.2 $ by simp

@[simp] lemma prod_equiv_of_is_compl_symm_apply_right (h : is_compl p q) (x : q) :
  (prod_equiv_of_is_compl p q h).symm x = (0, x) :=
(prod_equiv_of_is_compl p q h).symm_apply_eq.2 $ by simp

@[simp] lemma prod_equiv_of_is_compl_symm_apply_fst_eq_zero (h : is_compl p q) {x : E} :
  ((prod_equiv_of_is_compl p q h).symm x).1 = 0 ↔ x ∈ q :=
begin
  conv_rhs { rw [← (prod_equiv_of_is_compl p q h).apply_symm_apply x] },
  rw [coe_prod_equiv_of_is_compl', submodule.add_mem_iff_left _ (submodule.coe_mem _),
    mem_right_iff_eq_zero_of_disjoint h.disjoint]
end

@[simp] lemma prod_equiv_of_is_compl_symm_apply_snd_eq_zero (h : is_compl p q) {x : E} :
  ((prod_equiv_of_is_compl p q h).symm x).2 = 0 ↔ x ∈ p :=
begin
  conv_rhs { rw [← (prod_equiv_of_is_compl p q h).apply_symm_apply x] },
  rw [coe_prod_equiv_of_is_compl', submodule.add_mem_iff_right _ (submodule.coe_mem _),
    mem_left_iff_eq_zero_of_disjoint h.disjoint]
end

@[simp]
lemma prod_comm_trans_prod_equiv_of_is_compl (h : is_compl p q) :
  linear_equiv.prod_comm R q p ≪≫ₗ prod_equiv_of_is_compl p q h =
    prod_equiv_of_is_compl q p h.symm :=
linear_equiv.ext $ λ _, add_comm _ _

/-- Projection to a submodule along its complement. -/
def linear_proj_of_is_compl (h : is_compl p q) :
  E →ₗ[R] p :=
(linear_map.fst R p q) ∘ₗ ↑(prod_equiv_of_is_compl p q h).symm

variables {p q}

@[simp] lemma linear_proj_of_is_compl_apply_left (h : is_compl p q) (x : p) :
  linear_proj_of_is_compl p q h x = x :=
by simp [linear_proj_of_is_compl]

@[simp] lemma linear_proj_of_is_compl_range (h : is_compl p q) :
  (linear_proj_of_is_compl p q h).range = ⊤ :=
range_eq_of_proj (linear_proj_of_is_compl_apply_left h)

@[simp] lemma linear_proj_of_is_compl_apply_eq_zero_iff (h : is_compl p q) {x : E} :
  linear_proj_of_is_compl p q h x = 0 ↔ x ∈ q:=
by simp [linear_proj_of_is_compl]

lemma linear_proj_of_is_compl_apply_right' (h : is_compl p q) (x : E) (hx : x ∈ q) :
  linear_proj_of_is_compl p q h x = 0 :=
(linear_proj_of_is_compl_apply_eq_zero_iff h).2 hx

@[simp] lemma linear_proj_of_is_compl_apply_right (h : is_compl p q) (x : q) :
  linear_proj_of_is_compl p q h x = 0 :=
linear_proj_of_is_compl_apply_right' h x x.2

@[simp] lemma linear_proj_of_is_compl_ker (h : is_compl p q) :
  (linear_proj_of_is_compl p q h).ker = q :=
ext $ λ x, mem_ker.trans (linear_proj_of_is_compl_apply_eq_zero_iff h)

lemma linear_proj_of_is_compl_comp_subtype (h : is_compl p q) :
  (linear_proj_of_is_compl p q h).comp p.subtype = id :=
linear_map.ext $ linear_proj_of_is_compl_apply_left h

lemma linear_proj_of_is_compl_idempotent (h : is_compl p q) (x : E) :
  linear_proj_of_is_compl p q h (linear_proj_of_is_compl p q h x) =
    linear_proj_of_is_compl p q h x :=
linear_proj_of_is_compl_apply_left h _

lemma exists_unique_add_of_is_compl_prod (hc : is_compl p q) (x : E) :
  ∃! (u : p × q), (u.fst : E) + u.snd = x :=
(prod_equiv_of_is_compl _ _ hc).to_equiv.bijective.exists_unique _

lemma exists_unique_add_of_is_compl (hc : is_compl p q) (x : E) :
  ∃ (u : p) (v : q), ((u : E) + v = x ∧ ∀ (r : p) (s : q),
    (r : E) + s = x → r = u ∧ s = v) :=
let ⟨u, hu₁, hu₂⟩ := exists_unique_add_of_is_compl_prod hc x in
  ⟨u.1, u.2, hu₁, λ r s hrs, prod.eq_iff_fst_eq_snd_eq.1 (hu₂ ⟨r, s⟩ hrs)⟩

lemma linear_proj_add_linear_proj_of_is_compl_eq_self (hpq : is_compl p q) (x : E) :
  (p.linear_proj_of_is_compl q hpq x + q.linear_proj_of_is_compl p hpq.symm x : E) = x :=
begin
  dunfold linear_proj_of_is_compl,
  rw ←prod_comm_trans_prod_equiv_of_is_compl _ _ hpq,
  exact (prod_equiv_of_is_compl _ _ hpq).apply_symm_apply x,
end

end submodule

namespace linear_map

open submodule

/-- Given linear maps `φ` and `ψ` from complement submodules, `of_is_compl` is
the induced linear map over the entire module. -/
def of_is_compl {p q : submodule R E} (h : is_compl p q)
  (φ : p →ₗ[R] F) (ψ : q →ₗ[R] F) : E →ₗ[R] F :=
(linear_map.coprod φ ψ) ∘ₗ ↑(submodule.prod_equiv_of_is_compl _ _ h).symm

variables {p q}

@[simp] lemma of_is_compl_left_apply
  (h : is_compl p q) {φ : p →ₗ[R] F} {ψ : q →ₗ[R] F} (u : p) :
  of_is_compl h φ ψ (u : E) = φ u := by simp [of_is_compl]

@[simp] lemma of_is_compl_right_apply
  (h : is_compl p q) {φ : p →ₗ[R] F} {ψ : q →ₗ[R] F} (v : q) :
  of_is_compl h φ ψ (v : E) = ψ v := by simp [of_is_compl]

lemma of_is_compl_eq (h : is_compl p q)
  {φ : p →ₗ[R] F} {ψ : q →ₗ[R] F} {χ : E →ₗ[R] F}
  (hφ : ∀ u, φ u = χ u) (hψ : ∀ u, ψ u = χ u) :
  of_is_compl h φ ψ = χ :=
begin
  ext x,
  obtain ⟨_, _, rfl, _⟩ := exists_unique_add_of_is_compl h x,
  simp [of_is_compl, hφ, hψ]
end

lemma of_is_compl_eq' (h : is_compl p q)
  {φ : p →ₗ[R] F} {ψ : q →ₗ[R] F} {χ : E →ₗ[R] F}
  (hφ : φ = χ.comp p.subtype) (hψ : ψ = χ.comp q.subtype) :
  of_is_compl h φ ψ = χ :=
of_is_compl_eq h (λ _, hφ.symm ▸ rfl) (λ _, hψ.symm ▸ rfl)

@[simp] lemma of_is_compl_zero (h : is_compl p q) :
  (of_is_compl h 0 0 : E →ₗ[R] F) = 0 :=
of_is_compl_eq _ (λ _, rfl) (λ _, rfl)

@[simp] lemma of_is_compl_add (h : is_compl p q)
  {φ₁ φ₂ : p →ₗ[R] F} {ψ₁ ψ₂ : q →ₗ[R] F} :
  of_is_compl h (φ₁ + φ₂) (ψ₁ + ψ₂) = of_is_compl h φ₁ ψ₁ + of_is_compl h φ₂ ψ₂ :=
of_is_compl_eq _ (by simp) (by simp)

@[simp] lemma of_is_compl_smul
  {R : Type*} [comm_ring R] {E : Type*} [add_comm_group E] [module R E]
  {F : Type*} [add_comm_group F] [module R F] {p q : submodule R E}
  (h : is_compl p q) {φ : p →ₗ[R] F} {ψ : q →ₗ[R] F} (c : R) :
  of_is_compl h (c • φ) (c • ψ) = c • of_is_compl h φ ψ :=
of_is_compl_eq _ (by simp) (by simp)

section

variables {R₁ : Type*} [comm_ring R₁] [module R₁ E] [module R₁ F]

/-- The linear map from `(p →ₗ[R₁] F) × (q →ₗ[R₁] F)` to `E →ₗ[R₁] F`. -/
def of_is_compl_prod {p q : submodule R₁ E} (h : is_compl p q) :
  ((p →ₗ[R₁] F) × (q →ₗ[R₁] F)) →ₗ[R₁] (E →ₗ[R₁] F) :=
{ to_fun := λ φ, of_is_compl h φ.1 φ.2,
  map_add' := by { intros φ ψ, rw [prod.snd_add, prod.fst_add, of_is_compl_add] },
  map_smul' := by { intros c φ, simp [prod.smul_snd, prod.smul_fst, of_is_compl_smul] } }

@[simp] lemma of_is_compl_prod_apply {p q : submodule R₁ E} (h : is_compl p q)
  (φ : (p →ₗ[R₁] F) × (q →ₗ[R₁] F)) : of_is_compl_prod h φ = of_is_compl h φ.1 φ.2 := rfl

/-- The natural linear equivalence between `(p →ₗ[R₁] F) × (q →ₗ[R₁] F)` and `E →ₗ[R₁] F`. -/
def of_is_compl_prod_equiv {p q : submodule R₁ E} (h : is_compl p q) :
  ((p →ₗ[R₁] F) × (q →ₗ[R₁] F)) ≃ₗ[R₁] (E →ₗ[R₁] F) :=
{ inv_fun := λ φ, ⟨φ.dom_restrict p, φ.dom_restrict q⟩,
  left_inv :=
    begin
      intros φ, ext,
      { exact of_is_compl_left_apply h x },
      { exact of_is_compl_right_apply h x }
    end,
  right_inv :=
    begin
      intro φ, ext,
      obtain ⟨a, b, hab, _⟩ := exists_unique_add_of_is_compl h x,
      rw [← hab], simp,
    end, .. of_is_compl_prod h }

end

@[simp] lemma linear_proj_of_is_compl_of_proj (f : E →ₗ[R] p) (hf : ∀ x : p, f x = x) :
  p.linear_proj_of_is_compl f.ker (is_compl_of_proj hf) = f :=
begin
  ext x,
  have : x ∈ p ⊔ f.ker,
  { simp only [(is_compl_of_proj hf).sup_eq_top, mem_top] },
  rcases mem_sup'.1 this with ⟨x, y, rfl⟩,
  simp [hf]
end

/-- If `f : E →ₗ[R] F` and `g : E →ₗ[R] G` are two surjective linear maps and
their kernels are complement of each other, then `x ↦ (f x, g x)` defines
a linear equivalence `E ≃ₗ[R] F × G`. -/
def equiv_prod_of_surjective_of_is_compl (f : E →ₗ[R] F) (g : E →ₗ[R] G) (hf : f.range = ⊤)
  (hg : g.range = ⊤) (hfg : is_compl f.ker g.ker) :
  E ≃ₗ[R] F × G :=
linear_equiv.of_bijective (f.prod g) ⟨by simp [← ker_eq_bot, hfg.inf_eq_bot],
  by { rw [←range_eq_top], simp [range_prod_eq hfg.sup_eq_top, *] }⟩

@[simp] lemma coe_equiv_prod_of_surjective_of_is_compl {f : E →ₗ[R] F} {g : E →ₗ[R] G}
  (hf : f.range = ⊤) (hg : g.range = ⊤) (hfg : is_compl f.ker g.ker) :
  (equiv_prod_of_surjective_of_is_compl f g hf hg hfg : E →ₗ[R] F × G) = f.prod g :=
rfl

@[simp] lemma equiv_prod_of_surjective_of_is_compl_apply {f : E →ₗ[R] F} {g : E →ₗ[R] G}
  (hf : f.range = ⊤) (hg : g.range = ⊤) (hfg : is_compl f.ker g.ker) (x : E):
  equiv_prod_of_surjective_of_is_compl f g hf hg hfg x = (f x, g x) :=
rfl

end linear_map

namespace submodule

open linear_map

/-- Equivalence between submodules `q` such that `is_compl p q` and linear maps `f : E →ₗ[R] p`
such that `∀ x : p, f x = x`. -/
def is_compl_equiv_proj :
  {q // is_compl p q} ≃ {f : E →ₗ[R] p // ∀ x : p, f x = x} :=
{ to_fun := λ q, ⟨linear_proj_of_is_compl p q q.2, linear_proj_of_is_compl_apply_left q.2⟩,
  inv_fun := λ f, ⟨(f : E →ₗ[R] p).ker, is_compl_of_proj f.2⟩,
  left_inv := λ ⟨q, hq⟩, by simp only [linear_proj_of_is_compl_ker, subtype.coe_mk],
  right_inv := λ ⟨f, hf⟩, subtype.eq $ f.linear_proj_of_is_compl_of_proj hf }

@[simp] lemma coe_is_compl_equiv_proj_apply (q : {q // is_compl p q}) :
  (p.is_compl_equiv_proj q : E →ₗ[R] p) = linear_proj_of_is_compl p q q.2 := rfl

@[simp] lemma coe_is_compl_equiv_proj_symm_apply (f : {f : E →ₗ[R] p // ∀ x : p, f x = x}) :
  (p.is_compl_equiv_proj.symm f : submodule R E) = (f : E →ₗ[R] p).ker := rfl

end submodule

namespace linear_map

open submodule

/--
A linear endomorphism of a module `E` is a projection onto a submodule `p` if it sends every element
of `E` to `p` and fixes every element of `p`.
The definition allow more generally any `fun_like` type and not just linear maps, so that it can be
used for example with `continuous_linear_map` or `matrix`.
-/
structure is_proj {F : Type*} [fun_like F M (λ _, M)] (f : F) : Prop :=
(map_mem : ∀ x, f x ∈ m)
(map_id : ∀ x ∈ m, f x = x)

lemma is_proj_iff_idempotent (f : M →ₗ[S] M) : (∃ p : submodule S M, is_proj p f) ↔ f ∘ₗ f = f :=
begin
  split,
  { intro h, obtain ⟨p, hp⟩ := h, ext, rw comp_apply, exact hp.map_id (f x) (hp.map_mem x), },
  { intro h, use f.range, split,
    { intro x, exact mem_range_self f x, },
    { intros x hx, obtain ⟨y, hy⟩ := mem_range.1 hx, rw [←hy, ←comp_apply, h], }, },
end

namespace is_proj

variables {p m}

/--
Restriction of the codomain of a projection of onto a subspace `p` to `p` instead of the whole
space.
-/
def cod_restrict {f : M →ₗ[S] M} (h : is_proj m f) : M →ₗ[S] m :=
f.cod_restrict m h.map_mem

@[simp]
lemma cod_restrict_apply {f : M →ₗ[S] M} (h : is_proj m f) (x : M) :
  ↑(h.cod_restrict x) = f x := f.cod_restrict_apply m x

@[simp]
lemma cod_restrict_apply_cod {f : M →ₗ[S] M} (h : is_proj m f) (x : m) :
  h.cod_restrict x = x :=
by {ext, rw [cod_restrict_apply], exact h.map_id x x.2}

lemma cod_restrict_ker {f : M →ₗ[S] M} (h : is_proj m f) :
  h.cod_restrict.ker = f.ker := f.ker_cod_restrict m _

lemma is_compl {f : E →ₗ[R] E} (h : is_proj p f) : is_compl p f.ker :=
by { rw ←cod_restrict_ker, exact is_compl_of_proj h.cod_restrict_apply_cod, }

lemma eq_conj_prod_map' {f : E →ₗ[R] E} (h : is_proj p f) :
  f = (p.prod_equiv_of_is_compl f.ker h.is_compl).to_linear_map ∘ₗ prod_map id 0 ∘ₗ
    (p.prod_equiv_of_is_compl f.ker h.is_compl).symm.to_linear_map :=
begin
  refine (linear_map.cancel_right
    (p.prod_equiv_of_is_compl f.ker h.is_compl).surjective).1 _,
  ext,
  { simp only [coe_comp, linear_equiv.coe_to_linear_map, coe_inl, function.comp_app,
  linear_equiv.of_top_apply, linear_equiv.of_injective_apply, coprod_apply, submodule.coe_subtype,
  coe_zero, add_zero, prod_equiv_of_is_compl_symm_apply_left, prod_map_apply, id_coe, id.def,
  zero_apply, coe_prod_equiv_of_is_compl', h.map_id x x.2], },
  {simp only [coe_comp, linear_equiv.coe_to_linear_map, coe_inr, function.comp_app,
  linear_equiv.of_top_apply, linear_equiv.of_injective_apply, coprod_apply, submodule.coe_subtype,
  coe_zero, zero_add, map_coe_ker, prod_equiv_of_is_compl_symm_apply_right, prod_map_apply, id_coe,
  id.def, zero_apply, coe_prod_equiv_of_is_compl'], }
end

end is_proj

end linear_map

end ring

section comm_ring

namespace linear_map

variables {R : Type*} [comm_ring R] {E : Type*} [add_comm_group E] [module R E]  {p : submodule R E}

lemma is_proj.eq_conj_prod_map {f : E →ₗ[R] E} (h : is_proj p f) :
  f = (p.prod_equiv_of_is_compl f.ker h.is_compl).conj (prod_map id 0) :=
by {rw linear_equiv.conj_apply, exact h.eq_conj_prod_map'}

end linear_map

end comm_ring


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import topology.category.Top.basic
import category_theory.eq_to_hom

/-!
# The category of open sets in a topological space.

We define `to_Top : opens X ⥤ Top` and
`map (f : X ⟶ Y) : opens Y ⥤ opens X`, given by taking preimages of open sets.

Unfortunately `opens` isn't (usefully) a functor `Top ⥤ Cat`.
(One can in fact define such a functor,
but using it results in unresolvable `eq.rec` terms in goals.)

Really it's a 2-functor from (spaces, continuous functions, equalities)
to (categories, functors, natural isomorphisms).
We don't attempt to set up the full theory here, but do provide the natural isomorphisms
`map_id : map (𝟙 X) ≅ 𝟭 (opens X)` and
`map_comp : map (f ≫ g) ≅ map g ⋙ map f`.

Beyond that, there's a collection of simp lemmas for working with these constructions.
-/

open category_theory
open topological_space
open opposite

universe u

namespace topological_space.opens

variables {X Y Z : Top.{u}}

/-!
Since `opens X` has a partial order, it automatically receives a `category` instance.
Unfortunately, because we do not allow morphisms in `Prop`,
the morphisms `U ⟶ V` are not just proofs `U ≤ V`, but rather
`ulift (plift (U ≤ V))`.
-/

instance opens_hom_has_coe_to_fun {U V : opens X} : has_coe_to_fun (U ⟶ V) :=
{ F := λ f, U → V,
  coe := λ f x, ⟨x, (le_of_hom f) x.2⟩ }

/-!
We now construct as morphisms various inclusions of open sets.
-/
-- This is tedious, but necessary because we decided not to allow Prop as morphisms in a category...

/--
The inclusion `U ⊓ V ⟶ U` as a morphism in the category of open sets.
-/
def inf_le_left (U V : opens X) : U ⊓ V ⟶ U :=
hom_of_le inf_le_left

/--
The inclusion `U ⊓ V ⟶ V` as a morphism in the category of open sets.
-/
def inf_le_right (U V : opens X) : U ⊓ V ⟶ V :=
hom_of_le inf_le_right

/--
The inclusion `U i ⟶ supr U` as a morphism in the category of open sets.
-/
def le_supr {ι : Type*} (U : ι → opens X) (i : ι) : U i ⟶ supr U :=
hom_of_le (le_supr U i)

/--
The inclusion `⊥ ⟶ U` as a morphism in the category of open sets.
-/
def bot_le (U : opens X) : ⊥ ⟶ U :=
hom_of_le bot_le

/--
The inclusion `U ⟶ ⊤` as a morphism in the category of open sets.
-/
def le_top (U : opens X) : U ⟶ ⊤ :=
hom_of_le le_top

-- We do not mark this as a simp lemma because it breaks open `x`.
-- Nevertheless, it is useful in `sheaf_of_functions`.
lemma inf_le_left_apply (U V : opens X) (x) :
  (inf_le_left U V) x = ⟨x.1, (@_root_.inf_le_left _ _ U V : _ ≤ _) x.2⟩ :=
rfl

@[simp]
lemma inf_le_left_apply_mk (U V : opens X) (x) (m) :
  (inf_le_left U V) ⟨x, m⟩ = ⟨x, (@_root_.inf_le_left _ _ U V : _ ≤ _) m⟩ :=
rfl

@[simp]
lemma le_supr_apply_mk {ι : Type*} (U : ι → opens X) (i : ι) (x) (m) :
  (le_supr U i) ⟨x, m⟩ = ⟨x, (_root_.le_supr U i : _) m⟩ :=
rfl

/--
The functor from open sets in `X` to `Top`,
realising each open set as a topological space itself.
-/
def to_Top (X : Top.{u}) : opens X ⥤ Top :=
{ obj := λ U, ⟨U.val, infer_instance⟩,
  map := λ U V i, ⟨λ x, ⟨x.1, (le_of_hom i) x.2⟩,
    (embedding.continuous_iff embedding_subtype_coe).2 continuous_induced_dom⟩ }

@[simp]
lemma to_Top_map (X : Top.{u}) {U V : opens X} {f : U ⟶ V} {x} {h} :
  ((to_Top X).map f) ⟨x, h⟩ = ⟨x, (le_of_hom f) h⟩ :=
rfl

/--
The inclusion map from an open subset to the whole space, as a morphism in `Top`.
-/
@[simps]
def inclusion {X : Top.{u}} (U : opens X) : (to_Top X).obj U ⟶ X :=
{ to_fun := _,
  continuous_to_fun := continuous_subtype_coe }

lemma open_embedding {X : Top.{u}} (U : opens X) : open_embedding (inclusion U) :=
is_open.open_embedding_subtype_coe U.2

/-- `opens.map f` gives the functor from open sets in Y to open set in X,
    given by taking preimages under f. -/
def map (f : X ⟶ Y) : opens Y ⥤ opens X :=
{ obj := λ U, ⟨ f ⁻¹' U.val, U.property.preimage f.continuous ⟩,
  map := λ U V i, ⟨ ⟨ λ a b, (le_of_hom i) b ⟩ ⟩ }.

@[simp] lemma map_obj (f : X ⟶ Y) (U) (p) :
  (map f).obj ⟨U, p⟩ = ⟨f ⁻¹' U, p.preimage f.continuous⟩ := rfl

@[simp] lemma map_id_obj (U : opens X) : (map (𝟙 X)).obj U = U :=
by { ext, refl } -- not quite `rfl`, since we don't have eta for records

@[simp] lemma map_id_obj' (U) (p) : (map (𝟙 X)).obj ⟨U, p⟩ = ⟨U, p⟩ :=
rfl

@[simp] lemma map_id_obj_unop (U : (opens X)ᵒᵖ) : (map (𝟙 X)).obj (unop U) = unop U :=
by simp
@[simp]

/--
The inclusion `U ⟶ (map f).obj ⊤` as a morphism in the category of open sets.
-/
def le_map_top (f : X ⟶ Y) (U : opens X) : U ⟶ (map f).obj ⊤ :=
hom_of_le $ λ _ _, trivial

@[simp] lemma map_comp_obj (f : X ⟶ Y) (g : Y ⟶ Z) (U) :
  (map (f ≫ g)).obj U = (map f).obj ((map g).obj U) :=
by { ext, refl } -- not quite `rfl`, since we don't have eta for records

@[simp] lemma map_comp_obj' (f : X ⟶ Y) (g : Y ⟶ Z) (U) (p) :
  (map (f ≫ g)).obj ⟨U, p⟩ = (map f).obj ((map g).obj ⟨U, p⟩) :=
rfl

@[simp] lemma map_comp_map (f : X ⟶ Y) (g : Y ⟶ Z) {U V} (i : U ⟶ V) :
  (map (f ≫ g)).map i = (map f).map ((map g).map i) :=
rfl

@[simp] lemma map_comp_obj_unop (f : X ⟶ Y) (g : Y ⟶ Z) (U) :
  (map (f ≫ g)).obj (unop U) = (map f).obj ((map g).obj (unop U)) :=
map_comp_obj f g (unop U)

@[simp] lemma op_map_comp_obj (f : X ⟶ Y) (g : Y ⟶ Z) (U) :
  (map (f ≫ g)).op.obj U = (map f).op.obj ((map g).op.obj U) :=
by simp

section
variable (X)

/--
The functor `opens X ⥤ opens X` given by taking preimages under the identity function
is naturally isomorphic to the identity functor.
-/
@[simps]
def map_id : map (𝟙 X) ≅ 𝟭 (opens X) :=
{ hom := { app := λ U, eq_to_hom (map_id_obj U) },
  inv := { app := λ U, eq_to_hom (map_id_obj U).symm } }

end

/--
The natural isomorphism between taking preimages under `f ≫ g`, and the composite
of taking preimages under `g`, then preimages under `f`.
-/
@[simps]
def map_comp (f : X ⟶ Y) (g : Y ⟶ Z) : map (f ≫ g) ≅ map g ⋙ map f :=
{ hom := { app := λ U, eq_to_hom (map_comp_obj f g U) },
  inv := { app := λ U, eq_to_hom (map_comp_obj f g U).symm } }

/--
If two continuous maps `f g : X ⟶ Y` are equal,
then the functors `opens Y ⥤ opens X` they induce are isomorphic.
-/
-- We could make `f g` implicit here, but it's nice to be able to see when
-- they are the identity (often!)
def map_iso (f g : X ⟶ Y) (h : f = g) : map f ≅ map g :=
nat_iso.of_components (λ U, eq_to_iso (congr_fun (congr_arg functor.obj (congr_arg map h)) U) )
  (by obviously)

@[simp] lemma map_iso_refl (f : X ⟶ Y) (h) : map_iso f f h = iso.refl (map _) := rfl

@[simp] lemma map_iso_hom_app (f g : X ⟶ Y) (h : f = g) (U : opens Y) :
  (map_iso f g h).hom.app U = eq_to_hom (congr_fun (congr_arg functor.obj (congr_arg map h)) U) :=
rfl

@[simp] lemma map_iso_inv_app (f g : X ⟶ Y) (h : f = g) (U : opens Y) :
  (map_iso f g h).inv.app U =
     eq_to_hom (congr_fun (congr_arg functor.obj (congr_arg map h.symm)) U) :=
rfl

end topological_space.opens

/--
An open map `f : X ⟶ Y` induces a functor `opens X ⥤ opens Y`.
-/
@[simps]
def is_open_map.functor {X Y : Top} {f : X ⟶ Y} (hf : is_open_map f) :
  opens X ⥤ opens Y :=
{ obj := λ U, ⟨f '' U, hf U U.2⟩,
  map := λ U V h, ⟨⟨set.image_subset _ h.down.down⟩⟩ }

/--
An open map `f : X ⟶ Y` induces an adjunction between `opens X` and `opens Y`.
-/
def is_open_map.adjunction {X Y : Top} {f : X ⟶ Y} (hf : is_open_map f) :
  adjunction hf.functor (topological_space.opens.map f) :=
adjunction.mk_of_unit_counit
{ unit := { app := λ U, hom_of_le $ λ x hxU, ⟨x, hxU, rfl⟩ },
  counit := { app := λ V, hom_of_le $ λ y ⟨x, hfxV, hxy⟩, hxy ▸ hfxV } }


import group_theory.coset data.quot
import tactic.rewrite_search

open set function
open quotient_group

variable {α : Type*}

-- Some instances allowing us to use quotient notation
local attribute [instance] left_rel normal_subgroup.to_is_subgroup

-- We now prove two lemmas about elements in normal subgroups. I haven't attempted any automation here.
lemma quotient_group_aux  [group α] (s : set α) [normal_subgroup s] (a b : α) (h : a⁻¹ * b ∈ s) : a * b⁻¹ ∈ s :=
begin
  rw [← inv_inv a, ← mul_inv_rev],
  exact is_subgroup.inv_mem (is_subgroup.mem_norm_comm h),
end

lemma quotient_group_aux' [group α] (s : set α) [normal_subgroup s] (a b c d : α) (h₁ : a * b ∈ s) (h₂ : c * d ∈ s) : c * (a * (b * d)) ∈ s :=
begin
  apply is_subgroup.mem_norm_comm,
  rw [← mul_assoc, mul_assoc],
  apply (is_subgroup.mul_mem_cancel_right s h₁).2,
  exact is_subgroup.mem_norm_comm h₂
end
lemma quotient_group_aux'' [group α] (s : set α) [normal_subgroup s] (a b c d : α) (h₁ : a * b ∈ s) (h₂ : c * d ∈ s) : c * a * (b * d) ∈ s :=
begin
sorry
end

-- PROJECT one could write a tactic proving "all such" lemmas as above:
-- Given a word in α, write it as a vector in ℤ^α, and similarly write any hypotheses.
-- Now use Smith normal form (or perhaps Hermite normal form) to determine if there are solutions to the corresponding integer Diophantine equation.

-- Some 'hint' attributes for obviously.
local attribute [reducible] setoid_has_equiv left_rel
local attribute [applicable] is_submonoid.one_mem  -- `applicable` means the lemma should be applied whenever relevant
local attribute [semiapplicable] quotient_group_aux quotient_group_aux' quotient_group_aux'' -- `semiapplicable` means the lemma should be applied if all its hypotheses can be satisfied from the context
local attribute [simp] mul_assoc

instance quotient_group' [group α] (s : set α) [normal_subgroup s] : group (left_cosets s) :=
by refine
{ one := ⟦1⟧,
  mul := λ a b, quotient.lift_on₂ a b (λ a b, ⟦a * b⟧) (by obviously),
  inv := λ a',  quotient.lift_on  a'  (λ a, ⟦a⁻¹⟧)     (by obviously),
  .. }; obviously