import logic.basic --hide

/-
So far we've worked with numbers in Lean and seen how we can substitute equalities
of natural numbers using `rewrite`.
In Lean we don't just work with objects like numbers, but we can also manipulate and prove things
that are far more abstract, and deal with propositions themselves as objects we want to prove things about.

In Lean these are called *propositions* and denoted `P : Prop`, exactly the same as how we had `n : ℕ`
before.
A proposition itself is a statement we might be trying to prove or disprove, but we can use the
same tool we used so far, rewriting, to manipulate them.
When dealing with concrete objects like numbers, we substitute equal numbers when proving.
For propositions we can subsitute equivalent propositions, where propositions are equivalent
if they are related by and if and only if. For instance one simple fact is that
-/
namespace bloop --hide
lemma or_comm : ∀ (P Q : Prop), P ∨ Q ↔ Q ∨ P
:= or_comm --hide
end bloop --hide
/-
So if we wanted to show `⊢ x = 2 ∨ y = 1` we could `rewrite or_comm,` to change the goal to
`⊢ y = 1 ∨ x = 2`, which might then match one of our hypotheses better.

Check out the left sidebar for some new lemmas that you can use to prove the statement below.
One subtlety, note the curly (instead of round) brackets used in `{P : Prop}` in the `not_not` lemma statement.
This signals that `P` is a so-called implicit argument to `not_not`, meaning that syntax like `rewrite not_not P,` is not correct,
and instead `rewrite not_not,` should be used (where the argument `P` is then infered automatically).
-/

/- Axiom : iff_self
∀ (P : Prop), (P ↔ P) ↔ true
-/

/- Axiom : iff_true
∀ (P : Prop), (P ↔ true) ↔ P
-/

/- Axiom : not_not
∀ {P : Prop}, ¬ ¬ P ↔ P
-/

/- Lemma :
-/
lemma prop_prop (P Q R : Prop) (hPQ : P ↔ Q) (hQR : Q ↔ ¬R) :
  (¬P ↔ (Q ↔ P)) ↔ R :=
begin
  rw hPQ,
  rw iff_self,
  rw iff_true,
  rw hQR,
  rw not_not,

end


import basic
open emulators
--(1,4), (4,1), (2,3), (3,2), (2,5), (5,2), (4,5), (5,4), (2,2), (3,3)
def ex: finset (vector ℚ 2 )
  := {
    vector.cons 1 (vector.cons 4 vector.nil),
    vector.cons 4 (vector.cons 1 vector.nil),
    vector.cons 2 (vector.cons 3 vector.nil),
    vector.cons 3 (vector.cons 2 vector.nil),
    vector.cons 2 (vector.cons 5 vector.nil),
    vector.cons 5 (vector.cons 2 vector.nil),
    vector.cons 4 (vector.cons 5 vector.nil),
    vector.cons 5 (vector.cons 4 vector.nil),
    vector.cons 2 (vector.cons 2 vector.nil),
    vector.cons 3 (vector.cons 3 vector.nil)
    }

lemma excard: (ex.card = 10) := begin
sorry,
end

-- Maybe a new file for this
-- OPEN PROBLEM B. What is the smallest cardinality m of such an E in 11? What is the relationship between the n in Open Problem A and this m here?
theorem open_problem_B:
∃ (S : finset (vector ℚ 2 )) ,
 S.card = 10 ∧
 ∀ (E:set (vector ℚ 2 )),
 (@is_emulator 2 (E) (↑S)) := begin
use ex,
split,
{
  exact excard,
},
intros E,
-- simp,
sorry,
end


import YatimaStdLib.Ring
import Std.Data.Rat.Basic

namespace Rat

def powAux (base : Rat) (exp : Nat) : Rat :=
  let rec go (power acc : Rat) (n : Nat) : Rat :=
    match h : n with
    | 0 => acc
    | _ + 1 =>
      let n' := n / 2
      have : n' < n := Nat.bitwise_rec_lemma (h ▸ Nat.succ_ne_zero _)
      if n % 2 == 0
      then go (power * power) acc n'
      else go (power * power) (acc * power) n'
  go base 1 exp

instance : Field Rat where
  hPow r n := powAux r n
  coe a := { num := a, reduced := by simp only [Nat.coprime, Nat.coprime_one_right]}
  zero := 0
  one := 1
  inv x := 1/x

def abs (r : Rat) : Rat := {r with num := r.num.natAbs}

def round (r : Rat) : Int :=
  let floor := r.floor
  if abs (r - floor) ≤ (1 : Rat)/2 then floor else r.ceil

end Rat


/- Copyright 2022 ACL & MIdFF-/

import algebra.free_algebra
import algebra.ring_quot
import algebra.triv_sq_zero_ext
import algebra.algebra.operations
import linear_algebra.multilinear.basic
import ring_theory.graded_algebra.basic
import ring_theory.tensor_product

import divided_powers.basic
import divided_powers.ideal_add
import ..weighted_homogeneous -- PR #17855

noncomputable theory

/-!
The divided power algebra of a module -/

open finset mv_polynomial ring_quot

section

variables (R : Type*) [comm_ring R]
variables (M : Type*) [add_comm_group M] [module R M]

namespace divided_power_algebra

/-- The type coding the basic relations that will give rise to
the divided power algebra.
The class of X (n, a) will be equal to dpow n a, with a ∈ M. --/
inductive rel : mv_polynomial (ℕ × M) R → mv_polynomial (ℕ × M) R → Prop
-- force `ι` to be linear and creates the divided powers
| zero {a : M} : rel (X (0, a)) 1
| smul {r : R} {n : ℕ} {a : M} : rel (X (n, r • a)) (r^n • X (n, a))
| mul {m n : ℕ} {a : M} : rel (X (m, a) * X (n, a)) ((nat.choose (m + n) n) • X (m + n, a))
| add {n : ℕ} {a b : M} : rel (X (n, a+b))
  (finset.sum (range (n + 1)) (λ k, (X (k, a) * X (n - k, b))))

end divided_power_algebra

/-- The divided power algebra of a module M is the quotient of the polynomial ring
by the ring relation defined by divided_power_algebra.rel -/
@[derive [inhabited, comm_ring, algebra R]]
def divided_power_algebra := ring_quot (divided_power_algebra.rel R M)

/- TODO : upgrade this definition to a graded algebra
this requires to define some graded_ring_quot when the relations are homogeneous -/

namespace divided_power_algebra

variable {M}

/-- The canonical linear map `M →ₗ[R] divided_power_algebra R M`. -/
def ι : M →ₗ[R] (divided_power_algebra R M) :=
{ to_fun := λ m, (mk_alg_hom R _ (X (1, m))),
  map_add' := λ x y, by {
    rw [← map_add, mk_alg_hom_rel R rel.add],
    simp only [sum_range_succ', sum_range_zero, zero_add, nat.sub_zero,
    nat.sub_self],
    simp only [map_add, map_mul],
    simp only [mk_alg_hom_rel R rel.zero],
    simp only [map_one, one_mul, mul_one], },
  map_smul' := λ r x, by {
    rw [← map_smul, mk_alg_hom_rel R rel.smul, pow_one, map_smul],
    simp only [ring_hom.id_apply, map_smul], } }

lemma mk_alg_hom_mv_polynomial_ι_eq_ι (m : M) :
  mk_alg_hom R (rel R M) (X (1, m)) = ι R m := rfl

variable {R}
def degree (v : (ℕ × M) →₀ ℕ) : ℕ := finsum (λ x, (v x) * x.1)

def is_homogeneous_of_degree (p : mv_polynomial (ℕ × M) R) (n : ℕ) : Prop :=
∀ v ∈ p.support, degree v = n

variables (R M)

/-- The degree-n submodule of the divided power algebra -/
def grade (n : ℕ) : submodule R (divided_power_algebra R M) :=
submodule.span R
  { u : divided_power_algebra R M | ∃ p : mv_polynomial (ℕ × M) R,
    (is_homogeneous_of_degree p n ∧ mk_alg_hom R (rel R M) p = u) }

-- instance : module R (direct_sum ℕ (λ (i : ℕ), ↥(grade R M i))) := infer_instance

lemma one_mem : (1 : divided_power_algebra R M) ∈ grade R M 0 :=
submodule.subset_span ⟨C 1,
  ⟨λ v hv,
  begin
    classical,
    suffices hv : v = 0,
    simp only [hv, degree, finsupp.coe_zero, pi.zero_apply, zero_mul, finsum_zero],
    { apply symm,
      by_contradiction hv',
      simp only [mem_support_iff, mv_polynomial.coeff_C, if_neg hv'] at hv,
      apply hv, refl,},
  end,
  by simp only [map_one]⟩⟩

/-- degree of a product is sum of degrees -/
lemma mul_mem ⦃i j : ℕ⦄ {gi gj : divided_power_algebra R M} (hi : gi ∈ grade R M i)
  (hj : gj ∈ grade R M j) : gi * gj ∈ grade R M (i + j) :=
begin
  revert gj,
  apply submodule.span_induction hi,
  { intros x hx gj hj,
    apply submodule.span_induction hj,
    { intros y hy,
      obtain ⟨p, hp, rfl⟩ := hx,
      obtain ⟨q, hq, rfl⟩ := hy,
      apply submodule.subset_span,
      use p * q,
      split,
      intros w hw,
      let hw' := mv_polynomial.support_mul p q hw,
      simp only [mem_bUnion] at hw',
      obtain ⟨u, hu, v, hv, huv⟩ := hw',
      simp only [mem_singleton] at huv,
      rw [huv, degree, ← hp u hu, ← hq v hv, degree, degree, ← finsum_add_distrib],
      apply finsum_congr,
      intro x,
      simp only [finsupp.coe_add, pi.add_apply],
      rw add_mul,
      -- finiteness assumptions
      apply set.finite.subset u.support.finite_to_set _,
      intro i,
      simp only [function.mem_support, mem_coe, finsupp.mem_support_iff, ne.def],
      intros hui hi, apply hui, rw [hi, zero_mul],
      -- finiteness assumptions
      apply set.finite.subset v.support.finite_to_set _,
      intro i,
      simp only [function.mem_support, mem_coe, finsupp.mem_support_iff, ne.def],
      intros hvi hi, apply hvi, rw [hi, zero_mul],
      --
      simp only [map_mul], },
    { rw mul_zero, exact zero_mem _, },
    { intros y z hxy hxz,
      rw left_distrib,
      exact add_mem hxy hxz },
    { intros r y hxy,
      rw mul_smul_comm,
      exact submodule.smul_mem _ r hxy,}},
  { intros gj hj,
    rw zero_mul, exact zero_mem _, },
  { intros x y hx hy gj hj,
    rw right_distrib,
    exact add_mem (hx hj) (hy hj), },
  { intros r x hx gj hj,
    rw smul_mul_assoc,
    exact submodule.smul_mem _ _ (hx hj) },
end

/- The initial version

def grade' (n : ℕ) : submodule R (divided_power_algebra R M) :=
submodule.span R
  { u : divided_power_algebra R M | ∃ (s : multiset (ℕ × M))
    (hs : (s.map (λ x : ℕ × M, x.1)).sum = n),
    (s.map (λ x, mk_alg_hom R (rel R M) (X x))).prod = u }

lemma one_mem' : (1 : divided_power_algebra R M) ∈ grade' R M 0 :=
submodule.subset_span ⟨{(0, 0)}, by rw [multiset.map_singleton, multiset.sum_singleton],
  by { rw [multiset.map_singleton, multiset.prod_singleton,
    ← map_one (mk_alg_hom R (rel R M)), mk_alg_hom_rel R rel.zero]}⟩

lemma mul_mem' ⦃i j : ℕ⦄ {gi gj : divided_power_algebra R M} (hi : gi ∈ grade' R M i)
  (hj : gj ∈ grade' R M j) : gi * gj ∈ grade' R M (i + j) :=
begin
  revert gj,
  apply submodule.span_induction hi,
  { intros x hx gj hj,
    apply submodule.span_induction hj,
    { intros y hy,
      obtain ⟨s, hs, rfl⟩ := hx,
      obtain ⟨t, ht, rfl⟩ := hy,
      rw [← multiset.prod_add, ← multiset.map_add],
      apply submodule.subset_span,
      exact ⟨s + t, by rw [multiset.map_add, multiset.sum_add, hs, ht], rfl⟩,},
    { rw mul_zero, exact zero_mem _, },
    { intros y z hxy hxz,
      rw left_distrib,
      exact add_mem hxy hxz },
    { intros r y hxy,
      rw mul_smul_comm,
      exact submodule.smul_mem _ r hxy,}},
  { intros gj hj,
    rw zero_mul, exact zero_mem _, },
  { intros x y hx hy gj hj,
    rw right_distrib,
    exact add_mem (hx hj) (hy hj), },
  { intros r x hx gj hj,
    rw smul_mul_assoc,
    exact submodule.smul_mem _ _ (hx hj) },
end

def f :  R →+ (direct_sum ℕ (λ (i : ℕ), ↥(grade R M i))) := sorry

def decompose'' : ℕ × M → direct_sum ℕ (λ (i : ℕ), ↥(grade R M i)) :=
λ x,  direct_sum.of (λ n, grade R M n) x.1
  (⟨ring_quot.mk_alg_hom R (rel R M) (X x), submodule.subset_span ⟨{x},
    by rw [multiset.map_singleton, multiset.sum_singleton],
    by rw [multiset.map_singleton, multiset.prod_singleton]⟩⟩ : (grade R M x.1))

-/

/-- Split the class of a polynomial into its components of various degrees -/
def decompose' : mv_polynomial (ℕ × M) R → direct_sum ℕ (λ (i : ℕ), ↥(grade R M i)) := λ p,
  -- p = p.support.sum (λ (v : ℕ × M →₀ ℕ), ⇑(monomial v) (coeff v p))
  p.support.sum
    (λ (v : ℕ × M →₀ ℕ),
    direct_sum.of (λ n, grade R M n)
    (finsum (λ x : ℕ × M, (v x) * x.1))
    (⟨ring_quot.mk_alg_hom R (rel R M) (monomial v (coeff v p)),
      begin
        apply submodule.subset_span,
        use monomial v (coeff v p),
        split,
        { intros v' hv',
          suffices : v' = v, rw [degree, this],
          rw [← finset.mem_singleton],
          exact mv_polynomial.support_monomial_subset hv', },
        refl,
     end⟩))

  /- p.support : finset ((ℕ × M) →₀ ℕ)
    si v ∈ p.support, le monôme v est prod ("dpow n m")^(v (n, m))
    son degré est finsum (λ x, x.1 * (v x))
  -- p.coeff : ((ℕ × M) →₀ ℕ) → R
  -- p is a lift of sum (coeff v p) • prod ("dpow n m")^(v (n, m))
  -- dpow n m vit en degré n
  -- (prod ("dpow n m")^(v (n,m))) vit en degré finsum (ℕ × M) (λ x, v x * x.1)
  -/

  /-
  refine p.sum _ ,
  intros s a,
  refine direct_sum.mk (λ n, grade R M n) s.frange (λ m, _),
  obtain ⟨m, hm⟩ := m,
  simp only [mem_coe] at hm,
  rw finsupp.mem_frange at hm,

  --exact p.sum (λs a, f a * s.prod (λ n e, decompose'' n ^ e))
  --change add_monoid_algebra R ((ℕ × M)  →₀ ℕ) →+ direct_sum ℕ (λ (i : ℕ), ↥(grade R M i)),
  --refine add_monoid_algebra.lift_nc  _ (decompose'' R M),
  --intro x,
  --apply direct_sum.mk,
  sorry-/

def take_degree (p : mv_polynomial (ℕ ×M) R) (n : ℕ) :
  finset (ℕ × M →₀ ℕ) :=
  p.support.filter (λ v, finsum (λ x : ℕ × M, (v x) * x.1) = n)

lemma decompose'_eq (p: mv_polynomial (ℕ × M) R) (n : ℕ) :
  (decompose' R M p n : divided_power_algebra R M) =
  ring_quot.mk_alg_hom R (rel R M)
  ((p.support.filter
    (λ v : (ℕ × M) →₀ ℕ, finsum (λ x : ℕ × M, (v x) * x.1) = n )).sum
    (λ v, monomial v (coeff v p))) :=
begin
  classical,
  unfold decompose',

  induction p using mv_polynomial.induction_on' with v c p q hp hq,
  { -- case of monomials
    rw finset.sum_eq_single v,
    -- basic equality
    by_cases hn : finsum (λ x : ℕ × M, (v x) * x.1) = n,
    { rw ← hn,
      rw direct_sum.of_eq_same,
      simp only [subtype.coe_mk],
      apply congr_arg,
      rw finset.sum_eq_single v,
      intros w hw hw',
      rw finset.mem_filter at hw,
      rw mv_polynomial.monomial_eq_zero, rw mv_polynomial.coeff_monomial w v c,
      rw if_neg, intro h, exact hw' h.symm,
      --
      simp only [filter_true_of_mem, mem_support_iff, coeff_monomial, ne.def, ite_eq_right_iff, not_forall, exists_prop, and_imp,
  forall_eq', eq_self_iff_true, implies_true_iff, if_true, not_not, monomial_eq_zero, imp_self], },
    { rw direct_sum.of_eq_of_ne,
      simp only [submodule.coe_zero, coeff_monomial],
      apply symm, convert map_zero _,
      convert finset.sum_empty,
      rw finset.eq_empty_iff_forall_not_mem,
      intros w hw, rw finset.mem_filter at hw,
      apply hn,
      suffices : w = v, rw ← this, exact hw.2,
      rw ← finset.mem_singleton,
      exact mv_polynomial.support_monomial_subset hw.1,
      --
      exact hn,  },
    -- support condition
    intros w hw hwv,
    ext m,
    rw direct_sum.zero_apply ,
    rw subtype.coe_inj,
    by_cases hm : m = finsum (λ x, w x * x.1),
    { rw hm,
      rw direct_sum.of_eq_same,
      simp only [coeff_monomial, submodule.mk_eq_zero],
      rw if_neg,
      simp only [map_zero],
      { intro h, exact hwv h.symm }, },
    { rw direct_sum.of_eq_of_ne,
      intro h, exact hm h.symm, },

    -- second support condition
    unfold direct_sum.of,
    simp only [mem_support_iff, not_not, dfinsupp.single_add_hom_apply, dfinsupp.single_eq_zero],
    intro hv, simp_rw hv,
    simp only [map_zero, submodule.mk_eq_zero], },
  sorry
end

lemma not_mem_monomial_support (n : ℕ) (v : ℕ × M →₀ ℕ) (c : R) :
v ∉ ((monomial v) c).support
↔ c = 0  :=
begin
  classical,
rw [mv_polynomial.not_mem_support_iff, mv_polynomial.coeff_monomial],
simp only [eq_self_iff_true, if_true],
end

lemma decompose_rel' (a b : mv_polynomial (ℕ × M) R) (hab : ring_quot.rel (rel R M) a b) :
  decompose' R M a = decompose' R M b :=
begin
  induction hab with a b hab a b c h ih a b c h ih a b c h ih,
  { -- rel
    induction hab with m c n m n p m n m m',
    { unfold decompose',

    sorry },
    { sorry },
    { sorry },
    { sorry } },
  { sorry },
  { sorry },
  { sorry },

end

def decompose : divided_power_algebra R M → direct_sum ℕ (λ (i : ℕ), ↥(grade R M i)) :=
λ x, quot.lift (decompose' R M) (decompose_rel' R M) (x.1)

/- graded_algebra (grade R M )-/
instance graded : graded_algebra (divided_power_algebra.grade R M) :=
{ one_mem    := one_mem R M,
  mul_mem    := mul_mem R M,
  decompose' := decompose R M,
  left_inv   := sorry,
  right_inv  := sorry }

instance : has_one (grade R M 0) := ⟨⟨1, one_mem R M ⟩⟩

instance : has_mul (grade R M 0) :=
{ mul := λ x y, ⟨x*y, by convert mul_mem R M x.2 y.2⟩ }

@[simp] lemma grade_zero_coe_mul (x y : grade R M 0) :
  ((x * y : grade R M 0) : divided_power_algebra R M) = (x : divided_power_algebra R M) * y := rfl

@[simp] lemma grade_zero_coe_one: ((1 : grade R M 0) : divided_power_algebra R M) = 1 := rfl

instance : add_comm_monoid (grade R M 0) := infer_instance

instance : has_neg (grade R M 0) := add_subgroup_class.has_neg

instance : comm_ring (grade R M 0) :=
{ add           := (+),
  zero          := 0,
  neg           := has_neg.neg,
  one           := 1,
  mul           := (*),
  mul_assoc     := λ x y z, by ext; simp only [grade_zero_coe_mul, mul_assoc],
  one_mul       := λ x, by  ext; rw [grade_zero_coe_mul, grade_zero_coe_one, one_mul],
  mul_one       := λ x, by  ext; rw [grade_zero_coe_mul, grade_zero_coe_one, mul_one],
  left_distrib  := λ x y z,
  by ext; simp only [submodule.coe_add, grade_zero_coe_mul, left_distrib],
  right_distrib := λ x y z,
    by ext; simp only [submodule.coe_add, grade_zero_coe_mul, right_distrib],
  mul_comm      := λ x y, by ext; simp only [grade_zero_coe_mul, mul_comm],
  ..(infer_instance : add_comm_group (grade R M 0)), }

instance : algebra R (grade R M 0) := sorry

/- We need the projections (divided_power_algebra R M) → grade R M n ,
more generally for graded algebras -/

def proj' (n : ℕ) : divided_power_algebra R M →ₗ[R] grade R M n := sorry

/- R → grade R M 0 is isomorphism -/
def ring_equiv_degree_zero : ring_equiv R (grade R M 0) :=
{ to_fun    := (proj' R M 0) ∘ (algebra_map R (divided_power_algebra R M)),
  inv_fun   := sorry,
  left_inv  := sorry,
  right_inv := sorry,
  map_mul'  := sorry,
  map_add'  := sorry }

def proj_0_ring_hom : ring_hom (divided_power_algebra R M) R :=
{ to_fun    := (ring_equiv_degree_zero R M).inv_fun ∘ (proj' R M 0),
  map_one'  := sorry,
  map_mul'  := sorry,
  map_zero' := sorry,
  map_add'  := sorry }

/- ι : M → grade R M 1 is isomorphism -/
def linear_equiv_degree_one : linear_equiv (ring_hom.id R) M (grade R M 1) :=
{ to_fun    := (proj' R M 1) ∘ ι R,
  map_add'  := sorry,
  map_smul' := sorry,
  inv_fun   := sorry,
  left_inv  := sorry,
  right_inv := sorry }

def aug_ideal : ideal (divided_power_algebra R M) := (proj_0_ring_hom R M).ker

section

def is_aug_ideal (R : Type*) [comm_ring R] (I : ideal R) : Prop :=
∃ g : R⧸I →+* R, (ideal.quotient.mk I) ∘ g = id

/- We prove that the augmentation is an augmentation ideal, namely there is a section -/
lemma aug_ideal_is_aug_ideal : is_aug_ideal (divided_power_algebra R M) (aug_ideal R M) :=
sorry

variables (x : M) (n : ℕ)

/-- Lemma 2 of Roby 65. -/
lemma on_dp_algebra_unique (h h' : divided_powers (aug_ideal R M))
  (h1 : ∀ (x : M) (n : ℕ), h.dpow n (ι R x) = mk_alg_hom R _ (X (n, x)))
  (h1' : ∀ (x : M) (n : ℕ), h'.dpow n (ι R x) = mk_alg_hom R _ (X (n, x))) :
  h = h' := sorry

def cond_D : Prop := ∃ (h : divided_powers (aug_ideal R M)),
  ∀ (x : M) (n : ℕ), h.dpow n (ι R x) = mk_alg_hom R _ (X (n, x))

end

end divided_power_algebra

end

section roby
/- Formalization of Roby 1965, section 8 -/

.

open_locale tensor_product

variables (A R S : Type*) [comm_ring A] [comm_ring R] [algebra A R] [comm_ring S] [algebra A S]
  {I : ideal R} {J : ideal S} (hI : divided_powers I) (hJ : divided_powers J)

def i_1 : R →ₐ R ⊗[A] S := algebra.tensor_product.include_left

def i_2 : S →ₐ R ⊗[A] S := algebra.tensor_product.include_right

variables {R S} (I J)
def K : ideal (R ⊗[A] S) := (I.map (i_1 A R S)) ⊔ (J.map (i_2 A R S))

namespace divided_powers

variables {I J}
/- Lemma 1 : uniqueness of the dp structure on R ⊗ S for I + J -/
lemma on_tensor_product_unique (hK hK' : divided_powers (K A I J))
  (hi_1 : is_pd_morphism hI hK (i_1 A R S)) (hi_1' : is_pd_morphism hI hK' (i_1 A R S))
  (hi_2 : is_pd_morphism hJ hK (i_2 A R S)) (hi_2' : is_pd_morphism hJ hK' (i_2 A R S)) :
  hK = hK' :=
sorry

def cond_T : Prop :=
∃ hK : divided_powers (K A I J),
  is_pd_morphism hI hK (i_1 A R S) ∧ is_pd_morphism hJ hK (i_2 A R S)

section free

def cond_T_free [hR_free : module.free A R] [hS_free : module.free A S] : Prop :=
∃ hK : divided_powers (K A I J),
  is_pd_morphism hI hK (i_1 A R S) ∧ is_pd_morphism hJ hK (i_2 A R S)

def cond_Q (A R : Type*) [comm_ring A] [comm_ring R] [algebra A R]
  {I : ideal R} (hI : divided_powers I) : Prop :=
∃ (T : Type*) [comm_ring T], by exactI ∃ [algebra A T], by exactI ∃ [module.free A T]
  {J : ideal T} (hJ : divided_powers J) (f : pd_morphism hI hJ),
  function.surjective f.to_ring_hom

end free

end divided_powers

end roby

section divided_power_algebra

/-
and a divided power structure on that ideal such that
dpow R n (ι R x) = mk_alg_hom R (rel R M) (X (x, n))

(x,n) represents dpow n x
dpow m (x,n) should be dpow m (dpow n x) = (mchoose m n) dpow (m*n) x
An element x in divided_power_algebra R M takes the form
mk_alg_hom R (rel R M) (P)
where P is a sum of monomials  a * (m,n)   : m ∈ M, n ∈ ℕ
define
dpow k x = sum products a ^ kᵢ * dpow (mchoose kᵢ nᵢ (mᵢ,nᵢ * kᵢ))
where the sum is over functions → ℕ, with sum k
-/

/- Prove that it is unique… -/

/- Introduce notation ?
Here : x ^ [n] = mk_alg_hom R _ (X (x, n))
In general, x ^ [n]  for dpow n x ?

-/

end divided_power_algebra


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

import linear_algebra.basic

/-!
# modular equivalence for submodule
-/

open submodule

variables {R : Type*} [ring R]
variables {M : Type*} [add_comm_group M] [module R M] (U U₁ U₂ : submodule R M)
variables {x x₁ x₂ y y₁ y₂ z z₁ z₂ : M}
variables {N : Type*} [add_comm_group N] [module R N] (V V₁ V₂ : submodule R N)

/-- A predicate saying two elements of a module are equivalent modulo a submodule. -/
def smodeq (x y : M) : Prop :=
(submodule.quotient.mk x : U.quotient) = submodule.quotient.mk y

notation x ` ≡ `:50 y ` [SMOD `:50 N `]`:0 := smodeq N x y

variables {U U₁ U₂}

protected lemma smodeq.def : x ≡ y [SMOD U] ↔
  (submodule.quotient.mk x : U.quotient) = submodule.quotient.mk y := iff.rfl

namespace smodeq

@[simp] theorem top : x ≡ y [SMOD (⊤ : submodule R M)] :=
(submodule.quotient.eq ⊤).2 mem_top

@[simp] theorem bot : x ≡ y [SMOD (⊥ : submodule R M)] ↔ x = y :=
by rw [smodeq.def, submodule.quotient.eq, mem_bot, sub_eq_zero]

@[mono] theorem mono (HU : U₁ ≤ U₂) (hxy : x ≡ y [SMOD U₁]) : x ≡ y [SMOD U₂] :=
(submodule.quotient.eq U₂).2 $ HU $ (submodule.quotient.eq U₁).1 hxy

@[refl] theorem refl : x ≡ x [SMOD U] := eq.refl _

@[symm] theorem symm (hxy : x ≡ y [SMOD U]) : y ≡ x [SMOD U] := hxy.symm

@[trans] theorem trans (hxy : x ≡ y [SMOD U]) (hyz : y ≡ z [SMOD U]) : x ≡ z [SMOD U] :=
hxy.trans hyz

theorem add (hxy₁ : x₁ ≡ y₁ [SMOD U]) (hxy₂ : x₂ ≡ y₂ [SMOD U]) : x₁ + x₂ ≡ y₁ + y₂ [SMOD U] :=
by { rw smodeq.def at hxy₁ hxy₂ ⊢, simp_rw [quotient.mk_add, hxy₁, hxy₂] }

theorem smul (hxy : x ≡ y [SMOD U]) (c : R) : c • x ≡ c • y [SMOD U] :=
by { rw smodeq.def at hxy ⊢, simp_rw [quotient.mk_smul, hxy] }

theorem zero : x ≡ 0 [SMOD U] ↔ x ∈ U :=
by rw [smodeq.def, submodule.quotient.eq, sub_zero]

theorem map (hxy : x ≡ y [SMOD U]) (f : M →ₗ[R] N) : f x ≡ f y [SMOD U.map f] :=
(submodule.quotient.eq _).2 $ f.map_sub x y ▸ mem_map_of_mem $ (submodule.quotient.eq _).1 hxy

theorem comap {f : M →ₗ[R] N} (hxy : f x ≡ f y [SMOD V]) : x ≡ y [SMOD V.comap f] :=
(submodule.quotient.eq _).2 $ show f (x - y) ∈ V,
from (f.map_sub x y).symm ▸ (submodule.quotient.eq _).1 hxy

end smodeq


import data.nat.prime
open nat

theorem sqrt_two_irrational_V1 {a b : ℕ} (co : gcd a b = 1) : a^2 ≠ 2 * b^2 :=
assume h : a^2 = 2 * b^2,
have 2 ∣ a^2,
    by simp [h],
have ha : 2 ∣ a,
    from prime.dvd_of_dvd_pow prime_two this,
-- usually after exists.elim the rest of the proof should be inside
-- parantheses
exists.elim ha (assume c : ℕ, assume aeq : a = 2 * c,
have 2 * (2 * c^2) = 2 * b^2,
    by simp [eq.symm h, aeq];
       simp [nat.pow_succ, mul_comm, mul_assoc, mul_left_comm],
have 2 * c^2 = b^2,
    from eq_of_mul_eq_mul_left dec_trivial this,
have 2 ∣ b^2,
    by simp [eq.symm this],
have hb : 2 ∣ b,
    from prime.dvd_of_dvd_pow prime_two this,
have 2 ∣ gcd a b,
    from dvd_gcd ha hb,
have habs : 2 ∣ (1:ℕ),
    by simp * at *,
-- therefore the ) below!!!!
show false, from absurd habs dec_trivial )
--#check sqrt_two_irrational_V1

-- tactics mode
theorem sqrt_two_irrational_V2 {a b : ℕ} (co : gcd a b = 1) : a^2 ≠ 2 * b^2 :=
begin
    intro h,
    have h1 : 2 ∣ a^2, by simp [h],
    have h2 : 2 ∣ a, from prime.dvd_of_dvd_pow prime_two h1,
    cases h2 with c aeq,
    have h3 : 2 * (2 * c^2) = 2 * b^2,
        by simp [eq.symm h, aeq];
            simp [nat.pow_succ, mul_comm, mul_assoc, mul_left_comm],
    have h4 : 2 * c^2 = b^2,
        from eq_of_mul_eq_mul_left dec_trivial h3,
    have h5 : 2 ∣ b^2,
        by simp [eq.symm h4],
    have hb : 2 ∣ b,
        from prime.dvd_of_dvd_pow prime_two h5,
    have h6 : 2 ∣ gcd a b, from dvd_gcd (exists.intro c aeq) hb,
    have habs : 2 ∣ (1:ℕ), by simp * at *,
    exact absurd habs dec_trivial, done
end

-- using let (it may introduce a bug due to _let_match hypothesis)
theorem sqrt_two_irrational_V3 {a b : ℕ} (co : gcd a b = 1) : a^2 ≠ 2 * b^2 :=
assume h : a^2 = 2 * b^2,
have 2 ∣ a^2,
    by simp [h],
have ha : 2 ∣ a,
    from prime.dvd_of_dvd_pow prime_two this,
let ⟨c, aeq⟩ := ha in
have 2 * (2 * c^2) = 2 * b^2,
    by simp [eq.symm h, aeq];
       simp [nat.pow_succ, mul_comm, mul_assoc, mul_left_comm],
have 2 * c^2 = b^2,
    from eq_of_mul_eq_mul_left dec_trivial this,
have 2 ∣ b^2,
    by simp [eq.symm this],
have hb : 2 ∣ b,
    from prime.dvd_of_dvd_pow prime_two this,
have 2 ∣ gcd a b,
    from dvd_gcd ha hb,
have habs : 2 ∣ (1:ℕ),
    by clear_aux_decl; simp * at *, -- replaces simp * at *,
show false, from absurd habs dec_trivial

-- variant with match, needs end to finish
theorem sqrt_two_irrational_V4 {a b : ℕ} (co : gcd a b = 1) : a^2 ≠ 2 * b^2 :=
assume h : a^2 = 2 * b^2,
have 2 ∣ a^2,
    by simp [h],
have ha : 2 ∣ a,
    from prime.dvd_of_dvd_pow prime_two this,
match ha with | ⟨c, aeq⟩ :=
have 2 * (2 * c^2) = 2 * b^2,
    by simp [eq.symm h, aeq];
       simp [nat.pow_succ, mul_comm, mul_assoc, mul_left_comm],
have 2 * c^2 = b^2,
    from eq_of_mul_eq_mul_left dec_trivial this,
have 2 ∣ b^2,
    by simp [eq.symm this],
have hb : 2 ∣ b,
    from prime.dvd_of_dvd_pow prime_two this,
have 2 ∣ gcd a b,
    from dvd_gcd ha hb,
have habs : 2 ∣ (1:ℕ),
    by clear_aux_decl; simp * at *, -- replaces simp * at *,
show false, from absurd habs dec_trivial
end

theorem sqrt_two_irrational {a b : ℕ} (co : gcd a b = 1) :
  a^2 ≠ 2 * b^2 :=
assume h : a^2 = 2 * b^2,
have 2 ∣ a^2,
  by simp [h],
have 2 ∣ a,
  from prime.dvd_of_dvd_pow prime_two this,
exists.elim this $
assume (c : nat) (aeq : a = 2 * c),
have 2 * (2 * c^2) = 2 * b^2,
  by simp [eq.symm h, aeq];
    simp [nat.pow_succ, mul_comm, mul_assoc, mul_left_comm],
have 2 * c^2 = b^2,
  from eq_of_mul_eq_mul_left dec_trivial this,
have 2 ∣ b^2,
  by simp [eq.symm this],
have 2 ∣ b,
  from prime.dvd_of_dvd_pow prime_two this,
have 2 ∣ gcd a b,
  from dvd_gcd ‹2 ∣ a› ‹2 ∣ b›,
have 2 ∣ (1 : ℕ),
  by simp * at *,
show false, from absurd ‹2 ∣ 1› dec_trivial
--#check sqrt_two_irrational


universe u
namespace hidden

inductive list (α : Type u)
| nil {} : list
| cons : α → list → list

namespace list

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

variable {α : Type}

notation h :: t  := cons h t

def append: list α -> list α -> list α
| nil t := t
| (h::s) t := h::(append s t)
.

notation s ++ t := append s t

theorem nil_append (t : list α) : nil ++ t = t := rfl

theorem cons_append (x : α) (s t : list α) : x::s ++ t = x::(s ++ t) := rfl

theorem append_nil : ∀ (t : list α), t ++ nil = t
| nil := rfl
| (h::t) := by simp[append_nil t, cons_append]
.

theorem append_assoc (s t: list α): ∀(r: list α), r ++ s ++ t = r ++ (s ++ t)
| nil := rfl
| (h::r) := by simp[cons_append, append_assoc r]
.

def length: list α -> nat
| nil := 0
| (h::t) := 1 + (length t)
.
#reduce length nil
#reduce length [5]
#reduce length [1, 3, 5, 7, 9]

def reverse: list α -> list α
| nil := nil
| (h::t) := (reverse t) ++ [h]
.
#reduce reverse nil
#reduce reverse [5]
#reduce reverse [1, 3, 5, 7, 9]

lemma len_nil: length (nil: list α) = 0 := rfl.
lemma len_cons (h: α) (t: list α): length(h::t) = 1 + (length t) := by rsimp.
lemma len_cons_append (h: α) (t: list α): ∀(s: list α), (length ((h::s) ++ t)) = length (h::(s++t))
| nil := rfl
| (h2::s) := rfl
.

theorem len_append (t: list α): ∀ (s: list α), length(s++t) = (length s) + (length t)
| nil := by simp [nil_append, len_nil]
| (h::s) := begin
  simp [len_cons],
  rw [add_comm (length t), <-len_append s],
  simp [len_cons_append, len_cons]
end

lemma rev_cons (h: α) (t: list α): reverse (h::t) = (reverse t)++[h] := rfl
theorem len_rev: ∀(t: list α), length t = length (reverse t)
| nil := rfl
| (h::t) := begin
  simp [len_cons, rev_cons],
  simp [len_append],
  simp [len_rev t, len_cons, len_nil],
end

lemma rev_nil_s (s: list α): reverse(nil ++ s) = reverse s := rfl.
lemma rev_s_nil: ∀ (s: list α), reverse(s++nil) = reverse s
| nil := rfl
| (h::s) := by rw [rev_cons, <-rev_s_nil s]; reflexivity.
lemma rev_nil: reverse (nil: list α) = nil := rfl.

lemma rev_append (t: list α): ∀ (s: list α), reverse (s++t) = (reverse t) ++ (reverse s)
| nil := by simp[rev_nil, rev_nil_s, append_nil]
| (h::s) := begin
  simp [rev_cons],
  rw [<-append_assoc, <-rev_append s],
  rw [<-rev_cons],
  reflexivity
end

theorem rev_rev: ∀ (t: list α), reverse (reverse t) = t
| nil := rfl
| (h::t) := begin
  simp [rev_cons, rev_append, rev_rev t], reflexivity
end

end list

end hidden


/-
Copyright (c) 2019 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/
import algebra.algebra.bilinear
import algebra.module.submodule.pointwise
import algebra.module.submodule.bilinear
import algebra.module.opposites
import data.finset.pointwise
import data.set.semiring

/-!
# Multiplication and division of submodules of an algebra.

An interface for multiplication and division of sub-R-modules of an R-algebra A is developed.

## Main definitions

Let `R` be a commutative ring (or semiring) and aet `A` be an `R`-algebra.

* `1 : submodule R A`       : the R-submodule R of the R-algebra A
* `has_mul (submodule R A)` : multiplication of two sub-R-modules M and N of A is defined to be
                              the smallest submodule containing all the products `m * n`.
* `has_div (submodule R A)` : `I / J` is defined to be the submodule consisting of all `a : A` such
                              that `a • J ⊆ I`

It is proved that `submodule R A` is a semiring, and also an algebra over `set A`.

## Tags

multiplication of submodules, division of submodules, submodule semiring
-/

universes uι u v

open algebra set mul_opposite
open_locale big_operators
open_locale pointwise

namespace submodule

variables {ι : Sort uι}
variables {R : Type u} [comm_semiring R]

section ring

variables {A : Type v} [semiring A] [algebra R A]
variables (S T : set A) {M N P Q : submodule R A} {m n : A}

/-- `1 : submodule R A` is the submodule R of A. -/
instance : has_one (submodule R A) :=
⟨(algebra.linear_map R A).range⟩

theorem one_eq_range :
  (1 : submodule R A) = (algebra.linear_map R A).range := rfl

lemma algebra_map_mem (r : R) : algebra_map R A r ∈ (1 : submodule R A) :=
linear_map.mem_range_self _ _

@[simp] lemma mem_one {x : A} : x ∈ (1 : submodule R A) ↔ ∃ y, algebra_map R A y = x :=
by simp only [one_eq_range, linear_map.mem_range, algebra.linear_map_apply]

theorem one_eq_span : (1 : submodule R A) = R ∙ 1 :=
begin
  apply submodule.ext,
  intro a,
  simp only [mem_one, mem_span_singleton, algebra.smul_def, mul_one]
end

theorem one_le : (1 : submodule R A) ≤ P ↔ (1 : A) ∈ P :=
by simpa only [one_eq_span, span_le, set.singleton_subset_iff]

protected lemma map_one {A'} [semiring A'] [algebra R A'] (f : A →ₐ[R] A') :
  map f.to_linear_map (1 : submodule R A) = 1 :=
by { ext, simp }

@[simp] lemma map_op_one :
  map (↑(op_linear_equiv R : A ≃ₗ[R] Aᵐᵒᵖ) : A →ₗ[R] Aᵐᵒᵖ) (1 : submodule R A) = 1 :=
by { ext, induction x using mul_opposite.rec, simp }

@[simp] lemma comap_op_one :
  comap (↑(op_linear_equiv R : A ≃ₗ[R] Aᵐᵒᵖ) : A →ₗ[R] Aᵐᵒᵖ) (1 : submodule R Aᵐᵒᵖ) = 1 :=
by { ext, simp }

@[simp] lemma map_unop_one :
  map (↑(op_linear_equiv R : A ≃ₗ[R] Aᵐᵒᵖ).symm : Aᵐᵒᵖ →ₗ[R] A) (1 : submodule R Aᵐᵒᵖ) = 1 :=
by rw [←comap_equiv_eq_map_symm, comap_op_one]

@[simp] lemma comap_unop_one :
  comap (↑(op_linear_equiv R : A ≃ₗ[R] Aᵐᵒᵖ).symm : Aᵐᵒᵖ →ₗ[R] A) (1 : submodule R A) = 1 :=
by rw [←map_equiv_eq_comap_symm, map_op_one]

/-- Multiplication of sub-R-modules of an R-algebra A. The submodule `M * N` is the
smallest R-submodule of `A` containing the elements `m * n` for `m ∈ M` and `n ∈ N`. -/
instance : has_mul (submodule R A) := ⟨submodule.map₂ (algebra.lmul R A).to_linear_map⟩

theorem mul_mem_mul (hm : m ∈ M) (hn : n ∈ N) : m * n ∈ M * N := apply_mem_map₂ _ hm hn

theorem mul_le : M * N ≤ P ↔ ∀ (m ∈ M) (n ∈ N), m * n ∈ P := map₂_le

lemma mul_to_add_submonoid : (M * N).to_add_submonoid = M.to_add_submonoid * N.to_add_submonoid :=
begin
  dsimp [has_mul.mul],
  simp_rw [←algebra.lmul_left_to_add_monoid_hom R, algebra.lmul_left, ←map_to_add_submonoid, map₂],
  rw supr_to_add_submonoid,
  refl,
end

@[elab_as_eliminator] protected theorem mul_induction_on
  {C : A → Prop} {r : A} (hr : r ∈ M * N)
  (hm : ∀ (m ∈ M) (n ∈ N), C (m * n)) (ha : ∀ x y, C x → C y → C (x + y)) : C r :=
begin
  rw [←mem_to_add_submonoid, mul_to_add_submonoid] at hr,
  exact add_submonoid.mul_induction_on hr hm ha,
end

/-- A dependent version of `mul_induction_on`. -/
@[elab_as_eliminator] protected theorem mul_induction_on'
  {C : Π r, r ∈ M * N → Prop}
  (hm : ∀ (m ∈ M) (n ∈ N), C (m * n) (mul_mem_mul ‹_› ‹_›))
  (ha : ∀ x hx y hy, C x hx → C y hy → C (x + y) (add_mem ‹_› ‹_›))
  {r : A} (hr : r ∈ M * N) : C r hr :=
begin
  refine exists.elim _ (λ (hr : r ∈ M * N) (hc : C r hr), hc),
  exact submodule.mul_induction_on hr
    (λ x hx y hy, ⟨_, hm _ hx _ hy⟩) (λ x y ⟨_, hx⟩ ⟨_, hy⟩, ⟨_, ha _ _ _ _ hx hy⟩),
end

variables R
theorem span_mul_span : span R S * span R T = span R (S * T) := map₂_span_span _ _ _ _
variables {R}

variables (M N P Q)
protected theorem mul_assoc : (M * N) * P = M * (N * P) :=
le_antisymm (mul_le.2 $ λ mn hmn p hp,
  suffices M * N ≤ (M * (N * P)).comap (algebra.lmul_right R p), from this hmn,
  mul_le.2 $ λ m hm n hn, show m * n * p ∈ M * (N * P), from
  (mul_assoc m n p).symm ▸ mul_mem_mul hm (mul_mem_mul hn hp))
(mul_le.2 $ λ m hm np hnp,
  suffices N * P ≤ (M * N * P).comap (algebra.lmul_left R m), from this hnp,
  mul_le.2 $ λ n hn p hp, show m * (n * p) ∈ M * N * P, from
  mul_assoc m n p ▸ mul_mem_mul (mul_mem_mul hm hn) hp)

@[simp] theorem mul_bot : M * ⊥ = ⊥ := map₂_bot_right _ _

@[simp] theorem bot_mul : ⊥ * M = ⊥ := map₂_bot_left _ _

@[simp] protected theorem one_mul : (1 : submodule R A) * M = M :=
by { conv_lhs { rw [one_eq_span, ← span_eq M] }, erw [span_mul_span, one_mul, span_eq] }

@[simp] protected theorem mul_one : M * 1 = M :=
by { conv_lhs { rw [one_eq_span, ← span_eq M] }, erw [span_mul_span, mul_one, span_eq] }

variables {M N P Q}

@[mono] theorem mul_le_mul (hmp : M ≤ P) (hnq : N ≤ Q) : M * N ≤ P * Q := map₂_le_map₂ hmp hnq

theorem mul_le_mul_left (h : M ≤ N) : M * P ≤ N * P := map₂_le_map₂_left h

theorem mul_le_mul_right (h : N ≤ P) : M * N ≤ M * P := map₂_le_map₂_right h

variables (M N P)

theorem sup_mul : (M ⊔ N) * P = M * P ⊔ N * P := map₂_sup_left _ _ _ _

lemma mul_subset_mul : (↑M : set A) * (↑N : set A) ⊆ (↑(M * N) : set A) :=
image2_subset_map₂ (algebra.lmul R A).to_linear_map M N

protected lemma map_mul {A'} [semiring A'] [algebra R A'] (f : A →ₐ[R] A') :
  map f.to_linear_map (M * N) = map f.to_linear_map M * map f.to_linear_map N :=
calc map f.to_linear_map (M * N)
    = ⨆ (i : M), (N.map (lmul R A i)).map f.to_linear_map : map_supr _ _
... = map f.to_linear_map M * map f.to_linear_map N  :
  begin
    apply congr_arg Sup,
    ext S,
    split; rintros ⟨y, hy⟩,
    { use [f y, mem_map.mpr ⟨y.1, y.2, rfl⟩],
      refine trans _ hy,
      ext,
      simp },
    { obtain ⟨y', hy', fy_eq⟩ := mem_map.mp y.2,
      use [y', hy'],
      refine trans _ hy,
      rw f.to_linear_map_apply at fy_eq,
      ext,
      simp [fy_eq] }
end

lemma map_op_mul :
  map (↑(op_linear_equiv R : A ≃ₗ[R] Aᵐᵒᵖ) : A →ₗ[R] Aᵐᵒᵖ) (M * N) =
    map (↑(op_linear_equiv R : A ≃ₗ[R] Aᵐᵒᵖ) : A →ₗ[R] Aᵐᵒᵖ) N *
      map (↑(op_linear_equiv R : A ≃ₗ[R] Aᵐᵒᵖ) : A →ₗ[R] Aᵐᵒᵖ) M :=
begin
  apply le_antisymm,
  { simp_rw map_le_iff_le_comap,
    refine mul_le.2 (λ m hm n hn, _),
    rw [mem_comap, map_equiv_eq_comap_symm, map_equiv_eq_comap_symm],
    show op n * op m ∈ _,
    exact mul_mem_mul hn hm },
  { refine mul_le.2 (mul_opposite.rec $ λ m hm, mul_opposite.rec $ λ n hn, _),
    rw submodule.mem_map_equiv at ⊢ hm hn,
    exact mul_mem_mul hn hm, }
end

lemma comap_unop_mul :
  comap (↑(op_linear_equiv R : A ≃ₗ[R] Aᵐᵒᵖ).symm : Aᵐᵒᵖ →ₗ[R] A) (M * N) =
    comap (↑(op_linear_equiv R : A ≃ₗ[R] Aᵐᵒᵖ).symm : Aᵐᵒᵖ →ₗ[R] A) N *
      comap (↑(op_linear_equiv R : A ≃ₗ[R] Aᵐᵒᵖ).symm : Aᵐᵒᵖ →ₗ[R] A) M :=
by simp_rw [←map_equiv_eq_comap_symm, map_op_mul]

lemma map_unop_mul (M N : submodule R Aᵐᵒᵖ) :
  map (↑(op_linear_equiv R : A ≃ₗ[R] Aᵐᵒᵖ).symm : Aᵐᵒᵖ →ₗ[R] A) (M * N) =
    map (↑(op_linear_equiv R : A ≃ₗ[R] Aᵐᵒᵖ).symm : Aᵐᵒᵖ →ₗ[R] A) N *
      map (↑(op_linear_equiv R : A ≃ₗ[R] Aᵐᵒᵖ).symm : Aᵐᵒᵖ →ₗ[R] A) M :=
have function.injective (↑(op_linear_equiv R : A ≃ₗ[R] Aᵐᵒᵖ) : A →ₗ[R] Aᵐᵒᵖ) :=
  linear_equiv.injective _,
map_injective_of_injective this $
  by rw [← map_comp, map_op_mul, ←map_comp, ←map_comp, linear_equiv.comp_coe,
         linear_equiv.symm_trans_self, linear_equiv.refl_to_linear_map, map_id, map_id, map_id]

lemma comap_op_mul (M N : submodule R Aᵐᵒᵖ) :
  comap (↑(op_linear_equiv R : A ≃ₗ[R] Aᵐᵒᵖ) : A →ₗ[R] Aᵐᵒᵖ) (M * N) =
    comap (↑(op_linear_equiv R : A ≃ₗ[R] Aᵐᵒᵖ) : A →ₗ[R] Aᵐᵒᵖ) N *
      comap (↑(op_linear_equiv R : A ≃ₗ[R] Aᵐᵒᵖ) : A →ₗ[R] Aᵐᵒᵖ) M :=
by simp_rw [comap_equiv_eq_map_symm, map_unop_mul]

section
open_locale pointwise

/-- `submodule.has_pointwise_neg` distributes over multiplication.

This is available as an instance in the `pointwise` locale. -/
protected def has_distrib_pointwise_neg {A} [ring A] [algebra R A] :
  has_distrib_neg (submodule R A) :=
{ neg := has_neg.neg,
  neg_mul := λ x y, begin
    refine le_antisymm
      (mul_le.2 $ λ m hm n hn, _)
      ((submodule.neg_le _ _).2 $ mul_le.2 $ λ m hm n hn, _);
    simp only [submodule.mem_neg, ←neg_mul] at *,
    { exact mul_mem_mul hm hn,},
    { exact mul_mem_mul (neg_mem_neg.2 hm) hn },
  end,
  mul_neg := λ x y, begin
    refine le_antisymm
      (mul_le.2 $ λ m hm n hn, _)
      ((submodule.neg_le _ _).2 $ mul_le.2 $ λ m hm n hn, _);
    simp only [submodule.mem_neg, ←mul_neg] at *,
    { exact mul_mem_mul hm hn,},
    { exact mul_mem_mul hm (neg_mem_neg.2 hn) },
  end,
  ..submodule.has_involutive_pointwise_neg }

localized "attribute [instance] submodule.has_distrib_pointwise_neg" in pointwise

end

section decidable_eq

open_locale classical

lemma mem_span_mul_finite_of_mem_span_mul
  {R A} [semiring R] [add_comm_monoid A] [has_mul A] [module R A]
  {S : set A} {S' : set A} {x : A} (hx : x ∈ span R (S * S')) :
  ∃ (T T' : finset A), ↑T ⊆ S ∧ ↑T' ⊆ S' ∧ x ∈ span R (T * T' : set A) :=
begin
  obtain ⟨U, h, hU⟩ := mem_span_finite_of_mem_span hx,
  obtain ⟨T, T', hS, hS', h⟩ := finset.subset_mul h,
  use [T, T', hS, hS'],
  have h' : (U : set A) ⊆ T * T', { assumption_mod_cast, },
  have h'' := span_mono h' hU,
  assumption,
end

end decidable_eq

lemma mul_eq_span_mul_set (s t : submodule R A) : s * t = span R ((s : set A) * (t : set A)) :=
map₂_eq_span_image2 _ s t

lemma supr_mul (s : ι → submodule R A) (t : submodule R A) : (⨆ i, s i) * t = ⨆ i, s i * t :=
map₂_supr_left _ s t

lemma mul_supr (t : submodule R A) (s : ι → submodule R A) : t * (⨆ i, s i) = ⨆ i, t * s i :=
map₂_supr_right _ t s

lemma mem_span_mul_finite_of_mem_mul {P Q : submodule R A} {x : A} (hx : x ∈ P * Q) :
  ∃ (T T' : finset A), (T : set A) ⊆ P ∧ (T' : set A) ⊆ Q ∧ x ∈ span R (T * T' : set A) :=
submodule.mem_span_mul_finite_of_mem_span_mul
  (by rwa [← submodule.span_eq P, ← submodule.span_eq Q, submodule.span_mul_span] at hx)

variables {M N P}

/-- Sub-R-modules of an R-algebra form a semiring. -/
instance : semiring (submodule R A) :=
{ one_mul       := submodule.one_mul,
  mul_one       := submodule.mul_one,
  mul_assoc     := submodule.mul_assoc,
  zero_mul      := bot_mul,
  mul_zero      := mul_bot,
  left_distrib  := mul_sup,
  right_distrib := sup_mul,
  ..add_monoid_with_one.unary,
  ..submodule.pointwise_add_comm_monoid,
  ..submodule.has_one,
  ..submodule.has_mul }

variables (M)

lemma pow_subset_pow {n : ℕ} : (↑M : set A)^n ⊆ ↑(M^n : submodule R A) :=
begin
  induction n with n ih,
  { erw [pow_zero, pow_zero, set.singleton_subset_iff],
    rw [set_like.mem_coe, ← one_le],
    exact le_rfl },
  { rw [pow_succ, pow_succ],
    refine set.subset.trans (set.mul_subset_mul (subset.refl _) ih) _,
    apply mul_subset_mul }
end

/-- Dependent version of `submodule.pow_induction_on_left`. -/
@[elab_as_eliminator] protected theorem pow_induction_on_left'
  {C : Π (n : ℕ) x, x ∈ M ^ n → Prop}
  (hr : ∀ r : R, C 0 (algebra_map _ _ r) (algebra_map_mem r))
  (hadd : ∀ x y i hx hy, C i x hx → C i y hy → C i (x + y) (add_mem ‹_› ‹_›))
  (hmul : ∀ (m ∈ M) i x hx, C i x hx → C (i.succ) (m * x) (mul_mem_mul H hx))
  {x : A} {n : ℕ} (hx : x ∈ M ^ n) : C n x hx :=
begin
  induction n with n n_ih generalizing x,
  { rw pow_zero at hx,
    obtain ⟨r, rfl⟩ := hx,
    exact hr r, },
  exact submodule.mul_induction_on'
    (λ m hm x ih, hmul _ hm _ _ _ (n_ih ih))
    (λ x hx y hy Cx Cy, hadd _ _ _ _ _ Cx Cy) hx,
end

/-- Dependent version of `submodule.pow_induction_on_right`. -/
@[elab_as_eliminator] protected theorem pow_induction_on_right'
  {C : Π (n : ℕ) x, x ∈ M ^ n → Prop}
  (hr : ∀ r : R, C 0 (algebra_map _ _ r) (algebra_map_mem r))
  (hadd : ∀ x y i hx hy, C i x hx → C i y hy → C i (x + y) (add_mem ‹_› ‹_›))
  (hmul : ∀ i x hx, C i x hx → ∀ m ∈ M,
    C (i.succ) (x * m) ((pow_succ' M i).symm ▸ mul_mem_mul hx H))
  {x : A} {n : ℕ} (hx : x ∈ M ^ n) : C n x hx :=
begin
  induction n with n n_ih generalizing x,
  { rw pow_zero at hx,
    obtain ⟨r, rfl⟩ := hx,
    exact hr r, },
  revert hx,
  simp_rw pow_succ',
  intro hx,
  exact submodule.mul_induction_on'
    (λ m hm x ih, hmul _ _ hm (n_ih _) _ ih)
    (λ x hx y hy Cx Cy, hadd _ _ _ _ _ Cx Cy) hx,
end

/-- To show a property on elements of `M ^ n` holds, it suffices to show that it holds for scalars,
is closed under addition, and holds for `m * x` where `m ∈ M` and it holds for `x` -/
@[elab_as_eliminator] protected theorem pow_induction_on_left
  {C : A → Prop}
  (hr : ∀ r : R, C (algebra_map _ _ r))
  (hadd : ∀ x y, C x → C y → C (x + y))
  (hmul : ∀ (m ∈ M) x, C x → C (m * x))
  {x : A} {n : ℕ} (hx : x ∈ M ^ n) : C x :=
submodule.pow_induction_on_left' M
  (by exact hr) (λ x y i hx hy, hadd x y) (λ m hm i x hx, hmul _ hm _) hx

/-- To show a property on elements of `M ^ n` holds, it suffices to show that it holds for scalars,
is closed under addition, and holds for `x * m` where `m ∈ M` and it holds for `x` -/
@[elab_as_eliminator] protected theorem pow_induction_on_right
  {C : A → Prop}
  (hr : ∀ r : R, C (algebra_map _ _ r))
  (hadd : ∀ x y, C x → C y → C (x + y))
  (hmul : ∀ x, C x → ∀ (m ∈ M), C (x * m))
  {x : A} {n : ℕ} (hx : x ∈ M ^ n) : C x :=
submodule.pow_induction_on_right' M
  (by exact hr) (λ x y i hx hy, hadd x y) (λ i x hx, hmul _) hx

/-- `submonoid.map` as a `monoid_with_zero_hom`, when applied to `alg_hom`s. -/
@[simps]
def map_hom {A'} [semiring A'] [algebra R A'] (f : A →ₐ[R] A') :
  submodule R A →*₀ submodule R A' :=
{ to_fun := map f.to_linear_map,
  map_zero' := submodule.map_bot _,
  map_one' := submodule.map_one _,
  map_mul' := λ _ _, submodule.map_mul _ _ _}

/-- The ring of submodules of the opposite algebra is isomorphic to the opposite ring of
submodules. -/
@[simps apply symm_apply]
def equiv_opposite : submodule R Aᵐᵒᵖ ≃+* (submodule R A)ᵐᵒᵖ :=
{ to_fun := λ p, op $ p.comap (↑(op_linear_equiv R : A ≃ₗ[R] Aᵐᵒᵖ) : A →ₗ[R] Aᵐᵒᵖ),
  inv_fun := λ p, p.unop.comap (↑(op_linear_equiv R : A ≃ₗ[R] Aᵐᵒᵖ).symm : Aᵐᵒᵖ →ₗ[R] A),
  left_inv := λ p, set_like.coe_injective $ rfl,
  right_inv := λ p, unop_injective $ set_like.coe_injective rfl,
  map_add' := λ p q, by simp [comap_equiv_eq_map_symm, ←op_add],
  map_mul' := λ p q, congr_arg op $ comap_op_mul _ _ }

protected lemma map_pow {A'} [semiring A'] [algebra R A'] (f : A →ₐ[R] A') (n : ℕ) :
  map f.to_linear_map (M ^ n) = map f.to_linear_map M ^ n :=
map_pow (map_hom f) M n

lemma comap_unop_pow (n : ℕ) :
  comap (↑(op_linear_equiv R : A ≃ₗ[R] Aᵐᵒᵖ).symm : Aᵐᵒᵖ →ₗ[R] A) (M ^ n) =
    comap (↑(op_linear_equiv R : A ≃ₗ[R] Aᵐᵒᵖ).symm : Aᵐᵒᵖ →ₗ[R] A) M ^ n :=
(equiv_opposite : submodule R Aᵐᵒᵖ ≃+* _).symm.map_pow (op M) n

lemma comap_op_pow (n : ℕ) (M : submodule R Aᵐᵒᵖ) :
  comap (↑(op_linear_equiv R : A ≃ₗ[R] Aᵐᵒᵖ) : A →ₗ[R] Aᵐᵒᵖ) (M ^ n) =
    comap (↑(op_linear_equiv R : A ≃ₗ[R] Aᵐᵒᵖ) : A →ₗ[R] Aᵐᵒᵖ) M ^ n :=
op_injective $ (equiv_opposite : submodule R Aᵐᵒᵖ ≃+* _).map_pow M n

lemma map_op_pow (n : ℕ) :
  map (↑(op_linear_equiv R : A ≃ₗ[R] Aᵐᵒᵖ) : A →ₗ[R] Aᵐᵒᵖ) (M ^ n) =
    map (↑(op_linear_equiv R : A ≃ₗ[R] Aᵐᵒᵖ) : A →ₗ[R] Aᵐᵒᵖ) M ^ n :=
by rw [map_equiv_eq_comap_symm, map_equiv_eq_comap_symm, comap_unop_pow]

lemma map_unop_pow (n : ℕ) (M : submodule R Aᵐᵒᵖ) :
  map (↑(op_linear_equiv R : A ≃ₗ[R] Aᵐᵒᵖ).symm : Aᵐᵒᵖ →ₗ[R] A) (M ^ n) =
    map (↑(op_linear_equiv R : A ≃ₗ[R] Aᵐᵒᵖ).symm : Aᵐᵒᵖ →ₗ[R] A) M ^ n :=
by rw [←comap_equiv_eq_map_symm, ←comap_equiv_eq_map_symm, comap_op_pow]

/-- `span` is a semiring homomorphism (recall multiplication is pointwise multiplication of subsets
on either side). -/
def span.ring_hom : set_semiring A →+* submodule R A :=
{ to_fun := submodule.span R,
  map_zero' := span_empty,
  map_one' := one_eq_span.symm,
  map_add' := span_union,
  map_mul' := λ s t, by erw [span_mul_span, ← image_mul_prod] }

end ring

section comm_ring

variables {A : Type v} [comm_semiring A] [algebra R A]
variables {M N : submodule R A} {m n : A}

theorem mul_mem_mul_rev (hm : m ∈ M) (hn : n ∈ N) : n * m ∈ M * N :=
mul_comm m n ▸ mul_mem_mul hm hn

variables (M N)
protected theorem mul_comm : M * N = N * M :=
le_antisymm (mul_le.2 $ λ r hrm s hsn, mul_mem_mul_rev hsn hrm)
(mul_le.2 $ λ r hrn s hsm, mul_mem_mul_rev hsm hrn)

/-- Sub-R-modules of an R-algebra A form a semiring. -/
instance : comm_semiring (submodule R A) :=
{ mul_comm := submodule.mul_comm,
  .. submodule.semiring }

lemma prod_span {ι : Type*} (s : finset ι) (M : ι → set A) :
  (∏ i in s, submodule.span R (M i)) = submodule.span R (∏ i in s, M i) :=
begin
  letI := classical.dec_eq ι,
  refine finset.induction_on s _ _,
  { simp [one_eq_span, set.singleton_one] },
  { intros _ _ H ih,
    rw [finset.prod_insert H, finset.prod_insert H, ih, span_mul_span] }
end

lemma prod_span_singleton {ι : Type*} (s : finset ι) (x : ι → A) :
  (∏ i in s, span R ({x i} : set A)) = span R {∏ i in s, x i} :=
by rw [prod_span, set.finset_prod_singleton]

variables (R A)

/-- R-submodules of the R-algebra A are a module over `set A`. -/
instance module_set : module (set_semiring A) (submodule R A) :=
{ smul := λ s P, span R s * P,
  smul_add := λ _ _ _, mul_add _ _ _,
  add_smul := λ s t P, show span R (s ⊔ t) * P = _, by { erw [span_union, right_distrib] },
  mul_smul := λ s t P, show _ = _ * (_ * _),
    by { rw [← mul_assoc, span_mul_span, ← image_mul_prod] },
  one_smul := λ P, show span R {(1 : A)} * P = _,
    by { conv_lhs {erw ← span_eq P}, erw [span_mul_span, one_mul, span_eq] },
  zero_smul := λ P, show span R ∅ * P = ⊥, by erw [span_empty, bot_mul],
  smul_zero := λ _, mul_bot _ }

variables {R A}

lemma smul_def {s : set_semiring A} {P : submodule R A} : s • P = span R s * P := rfl

lemma smul_le_smul {s t : set_semiring A} {M N : submodule R A} (h₁ : s.down ≤ t.down)
  (h₂ : M ≤ N) : s • M ≤ t • N :=
mul_le_mul (span_mono h₁) h₂

lemma smul_singleton (a : A) (M : submodule R A) :
  ({a} : set A).up • M = M.map (lmul_left _ a) :=
begin
  conv_lhs {rw ← span_eq M},
  change span _ _ * span _ _ = _,
  rw [span_mul_span],
  apply le_antisymm,
  { rw span_le,
    rintros _ ⟨b, m, hb, hm, rfl⟩,
    rw [set_like.mem_coe, mem_map, set.mem_singleton_iff.mp hb],
    exact ⟨m, hm, rfl⟩ },
  { rintros _ ⟨m, hm, rfl⟩, exact subset_span ⟨a, m, set.mem_singleton a, hm, rfl⟩ }
end

section quotient

/-- The elements of `I / J` are the `x` such that `x • J ⊆ I`.

In fact, we define `x ∈ I / J` to be `∀ y ∈ J, x * y ∈ I` (see `mem_div_iff_forall_mul_mem`),
which is equivalent to `x • J ⊆ I` (see `mem_div_iff_smul_subset`), but nicer to use in proofs.

This is the general form of the ideal quotient, traditionally written $I : J$.
-/
instance : has_div (submodule R A) :=
⟨ λ I J,
{ carrier   := { x | ∀ y ∈ J, x * y ∈ I },
  zero_mem' := λ y hy, by { rw zero_mul, apply submodule.zero_mem },
  add_mem'  := λ a b ha hb y hy, by { rw add_mul, exact submodule.add_mem _ (ha _ hy) (hb _ hy) },
  smul_mem' := λ r x hx y hy, by { rw algebra.smul_mul_assoc,
    exact submodule.smul_mem _ _ (hx _ hy) } } ⟩

lemma mem_div_iff_forall_mul_mem {x : A} {I J : submodule R A} :
  x ∈ I / J ↔ ∀ y ∈ J, x * y ∈ I :=
iff.refl _

lemma mem_div_iff_smul_subset {x : A} {I J : submodule R A} : x ∈ I / J ↔ x • (J : set A) ⊆ I :=
⟨ λ h y ⟨y', hy', xy'_eq_y⟩, by { rw ← xy'_eq_y, apply h, assumption },
  λ h y hy, h (set.smul_mem_smul_set hy) ⟩

lemma le_div_iff {I J K : submodule R A} : I ≤ J / K ↔ ∀ (x ∈ I) (z ∈ K), x * z ∈ J := iff.refl _

lemma le_div_iff_mul_le {I J K : submodule R A} : I ≤ J / K ↔ I * K ≤ J :=
by rw [le_div_iff, mul_le]

@[simp] lemma one_le_one_div {I : submodule R A} :
  1 ≤ 1 / I ↔ I ≤ 1 :=
begin
  split, all_goals {intro hI},
  {rwa [le_div_iff_mul_le, one_mul] at hI},
  {rwa [le_div_iff_mul_le, one_mul]},
end

lemma le_self_mul_one_div {I : submodule R A} (hI : I ≤ 1) :
  I ≤ I * (1 / I) :=
begin
  rw [← mul_one I] {occs := occurrences.pos [1]},
  apply mul_le_mul_right (one_le_one_div.mpr hI),
end

lemma mul_one_div_le_one {I : submodule R A} : I * (1 / I) ≤ 1 :=
begin
  rw submodule.mul_le,
  intros m hm n hn,
  rw [submodule.mem_div_iff_forall_mul_mem] at hn,
  rw mul_comm,
  exact hn m hm,
end

@[simp] protected lemma map_div {B : Type*} [comm_semiring B] [algebra R B]
  (I J : submodule R A) (h : A ≃ₐ[R] B) :
  (I / J).map h.to_linear_map = I.map h.to_linear_map / J.map h.to_linear_map :=
begin
  ext x,
  simp only [mem_map, mem_div_iff_forall_mul_mem],
  split,
  { rintro ⟨x, hx, rfl⟩ _ ⟨y, hy, rfl⟩,
    exact ⟨x * y, hx _ hy, h.map_mul x y⟩ },
  { rintro hx,
    refine ⟨h.symm x, λ z hz, _, h.apply_symm_apply x⟩,
    obtain ⟨xz, xz_mem, hxz⟩ := hx (h z) ⟨z, hz, rfl⟩,
    convert xz_mem,
    apply h.injective,
    erw [h.map_mul, h.apply_symm_apply, hxz] }
end

end quotient

end comm_ring

end submodule


/-
Copyright (c) 2021 Ashvni Narayanan. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Ashvni Narayanan
-/
import zmod.properties

/-!
# Properties of p-adic integers
This file adds some properties of `ℤ_[p]`.

## Tags
p-adic
-/

local attribute [instance] zmod.topological_space

lemma discrete_topology.is_topological_basis {α : Type*} [topological_space α]
  [discrete_topology α] [monoid α] :
  @topological_space.is_topological_basis α _ (set.range set.singleton_monoid_hom) :=
  topological_space.is_topological_basis_of_open_of_nhds (λ u hu, is_open_discrete u)
    (λ  a u mema openu, ⟨({a} : set α), ⟨a, rfl⟩,
      set.mem_singleton a, set.singleton_subset_iff.2 mema⟩)

variables {p : ℕ} [fact p.prime]

namespace padic_int

lemma unit_pow_eq_one (a : units ℤ_[p]) :
  (padic_int.to_zmod (a : ℤ_[p]))^(p - 1) = (1 : (zmod p)) :=
begin
  -- applying FLT
  apply zmod.pow_card_sub_one_eq_one,
  rw [← ring_hom.coe_monoid_hom, ← units.coe_map],
  apply units.ne_zero _,
  apply_instance,
end

/-- The ideal p^n ℤ_[p] is the closed ball B(0, 1/p^n) -/
lemma span_eq_closed_ball (n : ℕ) :
  metric.closed_ball 0 (1/p^n) = (@ideal.span ℤ_[p] _ {(p^n : ℤ_[p])} : set ℤ_[p]) :=
begin
  ext,
  simp only [one_div, dist_zero_right, metric.mem_closed_ball, set_like.mem_coe],
  rw ←padic_int.norm_le_pow_iff_mem_span_pow, simp,
end

variable (p)
/-- The ideal p^n ℤ_[p] is closed -/
lemma is_closed_span (n : ℕ) : is_closed (@ideal.span ℤ_[p] _ {(p^n : ℤ_[p])} : set ℤ_[p]) :=
(@span_eq_closed_ball p _ n) ▸ metric.is_closed_ball

variable {p}
/-- The ideal p^n ℤ_[p] is the open ball B(0, 1/p^(1 - n)) -/
lemma span_eq_open_ball (n : ℕ) :
  metric.ball 0 ((p : ℝ) ^ (1 - (n : ℤ))) = (@ideal.span ℤ_[p] _ {(p^n : ℤ_[p])} : set ℤ_[p]) :=
begin
  ext,
  simp only [mem_ball_zero_iff, set_like.mem_coe],
  rw [←padic_int.norm_le_pow_iff_mem_span_pow, padic_int.norm_le_pow_iff_norm_lt_pow_add_one,
    sub_eq_neg_add 1 (n : ℤ)],
end

variable (p)
/-- The ideal p^n ℤ_[p] is open -/
lemma is_open_span (n : ℕ) : is_open ((ideal.span {p ^ n} : ideal ℤ_[p]) : set ℤ_[p]) :=
(@span_eq_open_ball p _ n) ▸ metric.is_open_ball

/-- The ideal p^n ℤ_[p] is clopen -/
lemma is_clopen_span (n : ℕ) : is_clopen ((ideal.span {p ^ n} : ideal ℤ_[p]) : set ℤ_[p]) :=
⟨is_open_span p n, is_closed_span p n⟩

variable {p}
-- enable set addition for additive groups
open_locale pointwise
open zmod

-- this is more generally a property of profinite groups
lemma preimage_to_zmod_pow {n : ℕ} (x : zmod (p^n)) : (@to_zmod_pow p _ n) ⁻¹' {x} =
 {(x : ℤ_[p])} + (((@to_zmod_pow p _ n).ker : ideal ℤ_[p]) : set ℤ_[p]) :=
begin
  ext y,
  simp only [set.image_add_left, set.mem_preimage, set.singleton_add, set.mem_singleton_iff,
    set_like.mem_coe, ring_hom.mem_ker, neg_add_eq_zero, ring_hom.map_add, ring_hom.map_neg,
    ring_hom_map_cast],
  rw eq_comm,
end

/-- The map `to_zmod_pow` is continuous. -/
lemma continuous_to_zmod_pow (n : ℕ) : continuous (@padic_int.to_zmod_pow p _ n) :=
topological_space.is_topological_basis.continuous discrete_topology.is_topological_basis _
  (λ s ⟨x, hx⟩, begin
    change {x} = s at hx,
    rw [←hx, preimage_to_zmod_pow, ker_to_zmod_pow],
    refine is_open.add_left (is_open_span p n), end )

variable (d : ℕ)

/-- The preimage of any singleton under `to_zmod_pow` is clopen. -/
lemma proj_lim_preimage_clopen {n : ℕ} (a : zmod (d*(p^n))) :
  is_clopen (set.preimage (padic_int.to_zmod_pow n) {a} : set ℤ_[p]) :=
⟨continuous_def.mp (continuous_to_zmod_pow n) {a} trivial,
  continuous_iff_is_closed.mp (continuous_to_zmod_pow n) {a} (is_closed_discrete {a})⟩

/-- The preimage of any singleton under `to_zmod_pow` is clopen. -/
lemma proj_lim_preimage_clopen_one (n : ℕ) (a : zmod (p^n)) :
  is_clopen (set.preimage (padic_int.to_zmod_pow n) {a} : set ℤ_[p]) :=
by { have := proj_lim_preimage_clopen 1 a, rw one_mul at this, convert this, simp, }

lemma singleton_add_ball {S : Type*} [normed_group S] (x y : S) (r : ℝ) :
  ({x} : set S) + metric.ball y r = metric.ball (x + y) r :=
begin
  ext z,
  have : dist (-x + z) y = dist z (x + y),
  { simp_rw [dist_eq_norm],
    refine congr_arg _ _,
    rw [← sub_sub, sub_eq_add_neg z x, add_comm z _], },
  simp [this, add_comm],
end

/-- The preimage of a singleton x is a ball centered at x. -/
lemma preimage_to_zmod_pow_eq_ball {n : ℕ} (x : zmod (p^n)) :
  (padic_int.to_zmod_pow n) ⁻¹' {(x : zmod (p^n))} =
  metric.ball (x : ℤ_[p]) ((p : ℝ) ^ (1 - (n : ℤ))) :=
by { rw [preimage_to_zmod_pow, ker_to_zmod_pow, ←span_eq_open_ball, singleton_add_ball, add_zero], }

open nat

lemma cast_to_zmod_pow_eq_appr (a : ℤ_[p]) (n : ℕ) : ((to_zmod_pow n a) : ℤ_[p]) = a.appr n :=
begin
  dsimp [to_zmod_pow, to_zmod_hom], rw ←zmod.nat_cast_comp_val ℤ_[p],
  { simp only [nat.cast_inj], apply zmod.val_cast_of_lt (appr_lt _ _), },
  exact fact.pow.pos,
end

variable (p)
lemma exists_one_div_pow_lt_of_prime {ε : ℝ} (h : (0 < ε)) : ∃ (n : ℕ), (1 / (p^n) : ℝ) < ε :=
begin
  convert exists_pow_lt_of_lt_one h _,
  swap, { exact 1/p, },
  { simp only [one_div, inv_pow], },
  rw div_lt_iff _,
  { simp only [one_mul, one_lt_cast], apply nat.prime.one_lt (fact.out _), assumption, },
  simp only [cast_pos], apply nat.prime.pos (fact.out _), assumption,
end

variable {p}
lemma dist_appr_spec (a : ℤ_[p]) (n : ℕ) : dist a ((a.appr n) : ℤ_[p]) ≤ (p : ℝ)^(-n : ℤ) :=
(dist_eq_norm a (a.appr n)).symm ▸ ((norm_le_pow_iff_mem_span_pow _ _).2 (appr_spec n a))

instance [fact (0 < d)] : compact_space (zmod d) := fintype.compact_space

lemma totally_bounded : totally_bounded (λ (x : ℚ_[p]), ∥x∥ ≤ 1) :=
metric.totally_bounded_of_finite_discretization (λ ε hε, begin
  obtain ⟨m, fm⟩ := exists_one_div_pow_lt_of_prime p (half_pos hε),
  have f : (2 : ℝ) / (p^m) = (1 / (p^m)) + (1 : ℝ) / (p^m), { rw ← _root_.add_div, refl, },
  have fm' : (2 : ℝ)/(p^m) < ε, { rw [f, ← add_halves ε], apply add_lt_add fm fm, },
  have f' : ↑p ^ (1 - (m.succ : ℤ)) = (1 : ℝ) / (p^m),
  { symmetry, rw [div_eq_iff _, ←zpow_coe_nat, ← zpow_add₀ _],
    norm_num, rw sub_add, rw add_sub_cancel', rw sub_self, rw zpow_zero,
    any_goals { apply pow_ne_zero, },
    all_goals { norm_cast, apply nat.prime.ne_zero, apply fact.out, }, },
  have f'' : ↑p ^ -(m.succ : ℤ) < (1 : ℝ) / (p^m),
  { rw div_eq_inv_mul, rw mul_one, rw zpow_neg, rw inv_lt_inv,
    { rw zpow_coe_nat, apply pow_lt_pow _ (lt_add_one _), norm_cast,
      apply nat.prime.one_lt (fact.out _), assumption, },
    any_goals { norm_cast, apply pow_pos, apply nat.prime.pos, rw fact_iff at *, assumption, }, },
  refine ⟨zmod (p^m.succ), @zmod.fintype _ fact.pow.pos, to_zmod_pow m.succ, λ x y h,
    lt_trans (gt_of_gt_of_ge _ (dist_triangle x (appr y m.succ) y)) fm'⟩,
  rw [←set.mem_singleton_iff, ←set.mem_preimage, preimage_to_zmod_pow_eq_ball, metric.mem_ball,
    cast_to_zmod_pow_eq_appr, f'] at h,
  rw [f, dist_comm _ ↑y, add_comm (dist _ _) _],
  have := add_lt_add (gt_of_gt_of_ge f'' (ge_iff_le.2 (dist_appr_spec y (m.succ)))) h,
  rw [subtype.dist_eq y _, subtype.dist_eq x _, padic_int.coe_coe] at this,
  exact this, end)

instance : compact_space ℤ_[p] := is_compact_iff_compact_space.mp
  (compact_iff_totally_bounded_complete.mpr ⟨totally_bounded,
  complete_space_coe_iff_is_complete.mp (show complete_space ℤ_[p], from infer_instance)⟩)

-- this implies tot disc, hence `ℤ_[p]` is profinite!
instance : totally_separated_space ℤ_[p] :=
{ is_totally_separated_univ := λ x hx y hx ne, begin
    obtain ⟨n,hn⟩ : ∃ (n : ℕ), to_zmod_pow n x ≠ to_zmod_pow n y,
    { contrapose ne, push_neg at ne, rw ext_of_to_zmod_pow at ne,
      simp only [ne, _root_.ne.def, eq_self_iff_true, not_true, not_false_iff], },
    obtain ⟨u, v, hu, hv, memu, memv, univ, disj⟩ :=
      (totally_separated_space.is_totally_separated_univ (zmod (p ^ n))) (to_zmod_pow n x)
      (set.mem_univ _) (to_zmod_pow n y) (set.mem_univ _) hn,
    refine ⟨(to_zmod_pow n)⁻¹' u, (to_zmod_pow n)⁻¹' v,
      continuous_def.mp (continuous_to_zmod_pow n) u hu,
      continuous_def.mp (continuous_to_zmod_pow n) v hv,
      set.mem_preimage.mpr memu, set.mem_preimage.mpr memv, λ z hz, _, _⟩,
    { rw set.mem_union,
      have univ' := univ (set.mem_univ (to_zmod_pow n z)),
      cases univ',
      { left, apply set.mem_preimage.mpr univ', },
      { right, apply set.mem_preimage.mpr univ', }, },
    { ext z,
      rw [←@set.preimage_empty _ _ (to_zmod_pow n), set.mem_preimage],
      rw set.ext_iff at disj, specialize disj (to_zmod_pow n z),
      simp only [set.mem_inter_eq, set.mem_preimage, set.mem_empty_eq, iff_false, not_and],
      simp only [set.mem_inter_eq, set.mem_empty_eq, iff_false, not_and] at disj, assumption, },
    end, }

lemma proj_lim_preimage_clopen' {n : ℕ} (a : zmod (p^n)) :
  is_clopen (set.preimage (padic_int.to_zmod_pow n) {a} : set ℤ_[p]) :=
⟨continuous_def.mp (continuous_to_zmod_pow n) {a} trivial,
  continuous_iff_is_closed.mp (continuous_to_zmod_pow n) {a} (by simp)⟩

variables {p}

lemma ball_mem_unit {x z : ℤ_[p]} (hx : is_unit x) {r : ℝ} (memz : z ∈ metric.ball x r)
  (le_one : r ≤ 1) : is_unit z :=
begin
  rw [is_unit_iff, ←(is_unit_iff.1 hx), ←norm_neg x],
  apply norm_eq_of_norm_add_lt_right,
  rw [norm_neg x, ←sub_eq_add_neg, is_unit_iff.1 hx],
  refine gt_of_ge_of_gt le_one (dist_eq_norm z x ▸ metric.mem_ball.1 memz),
end

lemma inv_mem_inv_ball {x z : units ℤ_[p]} {r : ℝ} (h : r ≤ 1) (hz : z.val ∈ metric.ball x.val r) :
  z.inv ∈ metric.ball x.inv r :=
begin
  rw mem_ball_iff_norm,
  suffices : ∥z.val * x.val∥ * ∥z.inv - x.inv∥ < r,
  { rw [padic_int.norm_mul, is_unit_iff.1 (ball_mem_unit (units.is_unit _) hz h),
      units.val_eq_coe, is_unit_iff.1 (units.is_unit x), one_mul, one_mul] at this,
    exact this, },
  { rw [←padic_int.norm_mul, mul_sub, mul_right_comm, mul_assoc _ x.val _, units.val_inv,
      units.val_inv, one_mul, mul_one, norm_sub_rev],
    exact mem_ball_iff_norm.1 hz, },
end

lemma top_eq_if_cont_inv' {α : Type*} [topological_space α] [monoid α]
 (h : @continuous _ _ (topological_space.induced (units.coe_hom α) infer_instance)
  infer_instance (@units.inv α _)) :
  topological_space.induced (units.coe_hom α) infer_instance ≤ units.topological_space :=
continuous_iff_le_induced.1 begin
  -- if I replace this with refine or try to bring it into term mode, I get an incorrect typeclass
  -- instance synthesized error
  apply continuous.prod_mk continuous_induced_dom (continuous.comp mul_opposite.continuous_op _),
  { convert h, }, end

lemma cont_inv : @continuous _ _ (topological_space.induced (units.coe_hom ℤ_[p]) infer_instance)
  infer_instance (@units.inv ℤ_[p] _) :=
  begin
  -- it is very hard to work in term mode because Lean always infers the incorrect topological
  -- structure on the units
  rw continuous_def, intros s hs,
  rw is_open_iff_forall_mem_open,
  rintros x hx,
  rw metric.is_open_iff at hs,
  obtain ⟨r, r_pos, hs⟩ := hs _ hx,
  by_cases r ≤ 1,
  { refine ⟨(units.inv)⁻¹' metric.ball x.inv r, λ z hz, hs hz, is_open_induced_iff.2
      ⟨metric.ball x.val r, metric.is_open_ball, _⟩, metric.mem_ball_self r_pos⟩,
    ext z,
    rw [set.mem_preimage, set.mem_preimage],
    refine ⟨λ hz, inv_mem_inv_ball h hz, λ hz, _⟩,
    repeat { rw [units.inv_eq_coe_inv, ←units.val_eq_coe] at hz },
    rw [←inv_inv x, ←inv_inv z],
    apply inv_mem_inv_ball h hz, },
  { refine ⟨(units.inv)⁻¹' metric.ball x.inv 1, λ z hz, hs (metric.ball_subset_ball (le_of_lt
      (not_le.1 h)) hz), is_open_induced_iff.2 ⟨metric.ball x.val 1, metric.is_open_ball, _⟩,
      metric.mem_ball_self (zero_lt_one)⟩,
    ext z,
    rw [set.mem_preimage, set.mem_preimage],
    refine ⟨λ hz, inv_mem_inv_ball rfl.ge hz, λ hz, _⟩,
    repeat { rw [units.inv_eq_coe_inv, ←units.val_eq_coe] at hz, },
    rw [←inv_inv x, ←inv_inv z],
    convert inv_mem_inv_ball (rfl.ge) hz, rw inv_inv, },
end

lemma top_eq_iff_cont_inv {α : Type*} [monoid α] [topological_space α] :
  topological_space.induced (units.coe_hom α) infer_instance = units.topological_space ↔
    @continuous _ _ (topological_space.induced (units.coe_hom α) infer_instance)
      infer_instance (@units.inv α _) :=
begin
  refine ⟨λ h, _, λ h,
    le_antisymm (top_eq_if_cont_inv' h) (continuous_iff_le_induced.1 units.continuous_coe)⟩,
  { rw h,
    have h1 : prod.snd ∘ (units.embed_product α) = mul_opposite.op ∘ units.val ∘ units.has_inv.inv,
    { ext,
      rw units.embed_product,
      simp only [function.comp_app, units.val_eq_coe, monoid_hom.coe_mk], },
    have h2 : continuous (prod.snd ∘ (units.embed_product α)) :=
      continuous.comp continuous_snd continuous_induced_dom,
    rw h1 at h2,
    have h3 := continuous.comp (@mul_opposite.continuous_unop α _) h2,
    -- cant substitute h3 as it is, get errors
    exact h3, },
end

lemma is_open_coe : is_open_map (coe : units ℤ_[p] → ℤ_[p]) := λ U hU,
begin
  rw ←(top_eq_iff_cont_inv.2 cont_inv) at hU, -- need this!
  rw is_open_induced_iff at hU,
  rcases hU with ⟨t, ht, htU⟩,
  refine is_open_iff_forall_mem_open.2 (λ x hx, _),
  rcases hx with ⟨y, hy, hyx⟩,
  have memt : x ∈ t,
  { rw [←htU, set.mem_preimage, units.coe_hom_apply, hyx] at hy,
    apply hy, },
  rw metric.is_open_iff at ht,
  obtain ⟨r, r_pos, ht⟩ := ht x memt,
  have is_unit_x : is_unit x,
  { rw ←hyx, simp only [units.is_unit], },
  by_cases r ≤ 1,
  { refine ⟨metric.ball x r, λ z hz, ⟨is_unit.unit (ball_mem_unit is_unit_x hz h), htU ▸ (ht hz),
      is_unit.unit_spec (ball_mem_unit is_unit_x hz h)⟩, metric.is_open_ball,
      metric.mem_ball_self r_pos⟩, },
  { refine ⟨metric.ball x 1, λ z hz, ⟨is_unit.unit (ball_mem_unit is_unit_x hz le_rfl),
      htU ▸ (ht ((metric.ball_subset_ball (le_of_lt (not_le.1 h))) hz)), is_unit.unit_spec
      (ball_mem_unit is_unit_x hz le_rfl)⟩, metric.is_open_ball, metric.mem_ball_self zero_lt_one⟩, },
end

lemma is_open_coe' : is_open_map (coe : units (zmod d) → zmod d) :=
inducing.is_open_map { induced := (top_eq_iff_cont_inv.2 begin
  convert continuous_of_discrete_topology, apply discrete_topology_induced,
  exact units.ext, end).symm } trivial

lemma is_closed_coe : is_closed (set.range (coe : units ℤ_[p] → ℤ_[p])) :=
begin
  have : set.range (coe : units ℤ_[p] → ℤ_[p]) = set.preimage norm {1},
  { ext x,
    simp only [set.mem_range, set.mem_preimage, set.mem_singleton_iff],
    rw ←is_unit_iff,
    refine ⟨λ h, h.some_spec ▸ (units.is_unit h.some), λ h, ⟨is_unit.unit h, is_unit.unit_spec _⟩⟩, },
  { refine this.symm ▸ continuous_iff_is_closed.mp continuous_norm {1} (t1_space.t1 1), },
end

lemma emb_coe : embedding (coe : units ℤ_[p] → ℤ_[p]) :=
{ induced := (top_eq_iff_cont_inv.2 cont_inv).symm,
  inj := units.ext, }

lemma open_embedding_coe : open_embedding (coe : ℤ_[p]ˣ → ℤ_[p]) :=
⟨emb_coe, (is_open_coe).is_open_range⟩

instance : compact_space ℤ_[p]ˣ :=
{ compact_univ := (embedding.is_compact_iff_is_compact_image emb_coe).2
   (compact_of_is_closed_subset compact_univ
   ((@set.image_univ ℤ_[p]ˣ ℤ_[p] coe).symm ▸ is_closed_coe) (set.subset_univ _)) }

instance : t2_space ℤ_[p]ˣ := embedding.t2_space emb_coe

instance : totally_disconnected_space ℤ_[p]ˣ :=
{ is_totally_disconnected_univ := embedding.is_totally_disconnected emb_coe
    (is_totally_disconnected_of_totally_disconnected_space (coe '' set.univ)) }

open_locale pointwise -- needed for has_add (set ℤ_[p])

lemma preimage_to_zmod (x : zmod p) : (@to_zmod p _) ⁻¹' {x} =
 {(x : ℤ_[p])} + (((@to_zmod p _).ker : ideal ℤ_[p]) : set ℤ_[p]) :=
begin
 ext y,
  simp only [set.image_add_left, set.mem_preimage, set.singleton_add,
    set.mem_singleton_iff, set_like.mem_coe],
  refine ⟨λ h, _, λ h, _⟩,
  { simp only [ring_hom.mem_ker, map_add, map_neg, ring_hom_map_cast, neg_add_eq_zero, h.symm], },
  { simp only [ring_hom.mem_ker, map_add, map_neg, ring_hom_map_cast, neg_add_eq_zero] at h,
    exact h.symm, },
end

lemma continuous_to_zmod : continuous (@padic_int.to_zmod p _) :=
topological_space.is_topological_basis.continuous discrete_topology.is_topological_basis _ (λ s hs,
  begin
  cases hs with x hx,
  change {x} = s at hx,
  rw [←hx, preimage_to_zmod, ker_to_zmod],
  refine is_open.add_left _,
  convert is_open_span p 1,
  rw [pow_one, maximal_ideal_eq_span_p], end)

lemma is_unit_padic_of_is_unit_zmod {x : ℕ} (h : x.coprime p) :
  is_unit (x : ℤ_[p]) :=
begin
  rw is_unit_iff,
  contrapose h,
  have hx' := lt_of_le_of_ne (norm_le_one _) h,
  change ∥((x : ℤ) : ℤ_[p])∥ < 1 at hx',
  rw norm_int_lt_one_iff_dvd at hx',
  norm_cast at hx',
  rw [nat.coprime_comm, nat.prime.coprime_iff_not_dvd _, not_not],
  { assumption, },
  { apply fact.out, },
end

lemma nat_is_unit_of_not_dvd {z : ℕ} (h : ¬ p ∣ z) : is_unit (z : ℤ_[p]) :=
begin
  contrapose h,
  rw [not_not, ←int.coe_nat_dvd, ←padic_int.norm_int_lt_one_iff_dvd],
  apply padic_int.mem_nonunits.1 h,
end

lemma cont_units_map {α β : Type*} [topological_space α] [monoid α] [topological_space β] [monoid β]
  (ha : @continuous _ _ (topological_space.induced (units.coe_hom α) infer_instance)
      infer_instance (@units.inv α _))
  (hb : @continuous _ _ (topological_space.induced (units.coe_hom β) infer_instance)
      infer_instance (@units.inv β _)) {f : α →* β} (hf : continuous f) :
      continuous (units.map f) :=
{ is_open_preimage := λ s hs, begin
  rw (top_eq_iff_cont_inv.2 ha).symm,
  rw [(top_eq_iff_cont_inv.2 hb).symm, is_open_induced_iff] at hs,
  rcases hs with ⟨t, ht, hs⟩,
  rw ←hs,
  convert_to is_open ((units.coe_hom α)⁻¹' (f⁻¹' t)),
  { rw top_eq_iff_cont_inv.2 ha, },
  { apply continuous.is_open_preimage (continuous.comp hf units.continuous_coe) t ht, }, end, }

lemma continuous_units (n : ℕ) :
  continuous (units.map (@padic_int.to_zmod_pow p _ n).to_monoid_hom) :=
cont_units_map cont_inv induced_top_cont_inv (padic_int.continuous_to_zmod_pow n)

lemma proj_lim_preimage_units_clopen {n : ℕ} (a : (zmod (p^n))ˣ) :
  is_clopen ((units.map (@padic_int.to_zmod_pow p _ n).to_monoid_hom) ⁻¹' {a}) :=
⟨continuous_def.mp (continuous_units n) {a} (is_open_discrete _),
  continuous_iff_is_closed.mp (continuous_units n) {a} (is_closed_discrete {a})⟩

variable (p)
lemma is_unit_to_zmod_pow_of_is_unit {n : ℕ} (hn : 1 < n) (x : ℤ_[p])
  (hx : is_unit (to_zmod_pow n x)) : is_unit x :=
begin
  rw padic_int.is_unit_iff,
  by_contra h,
  have hx' := lt_of_le_of_ne (padic_int.norm_le_one _) h,
  rw padic_int.norm_lt_one_iff_dvd at hx',
  cases hx' with y hy,
  rw hy at hx,
  rw ring_hom.map_mul at hx,
  rw is_unit.mul_iff at hx,
  simp only [map_nat_cast] at hx,
  have : ¬ is_unit (p : zmod (p^n)),
  { intro h,
    set q : (zmod (p^n))ˣ := is_unit.unit h,
    have := zmod.val_coe_unit_coprime q,
    rw is_unit.unit_spec at this,
    rw nat.coprime_pow_right_iff (lt_trans zero_lt_one hn) at this,
    rw zmod.val_cast_of_lt _ at this,
    simp only [nat.coprime_self] at this,
    apply @nat.prime.ne_one p (fact.out _),
    rw this,
    conv { congr, rw ← pow_one p, },
    rw pow_lt_pow_iff _, apply hn,
    apply nat.prime.one_lt (fact.out _),
    apply_instance, },
  apply this, apply hx.1,
end

end padic_int


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.order
import Mathlib.order.lattice
import Mathlib.PostPort

universes u v

namespace Mathlib

/-!
# `max` and `min`

This file proves basic properties about maxima and minima on a `linear_order`.

## Tags

min, max
-/

-- translate from lattices to linear orders (sup → max, inf → min)

@[simp] theorem le_min_iff {α : Type u} [linear_order α] {a : α} {b : α} {c : α} : c ≤ min a b ↔ c ≤ a ∧ c ≤ b :=
  le_inf_iff

@[simp] theorem max_le_iff {α : Type u} [linear_order α] {a : α} {b : α} {c : α} : max a b ≤ c ↔ a ≤ c ∧ b ≤ c :=
  sup_le_iff

theorem max_le_max {α : Type u} [linear_order α] {a : α} {b : α} {c : α} {d : α} : a ≤ c → b ≤ d → max a b ≤ max c d :=
  sup_le_sup

theorem min_le_min {α : Type u} [linear_order α] {a : α} {b : α} {c : α} {d : α} : a ≤ c → b ≤ d → min a b ≤ min c d :=
  inf_le_inf

theorem le_max_left_of_le {α : Type u} [linear_order α] {a : α} {b : α} {c : α} : a ≤ b → a ≤ max b c :=
  le_sup_left_of_le

theorem le_max_right_of_le {α : Type u} [linear_order α] {a : α} {b : α} {c : α} : a ≤ c → a ≤ max b c :=
  le_sup_right_of_le

theorem min_le_left_of_le {α : Type u} [linear_order α] {a : α} {b : α} {c : α} : a ≤ c → min a b ≤ c :=
  inf_le_left_of_le

theorem min_le_right_of_le {α : Type u} [linear_order α] {a : α} {b : α} {c : α} : b ≤ c → min a b ≤ c :=
  inf_le_right_of_le

theorem max_min_distrib_left {α : Type u} [linear_order α] {a : α} {b : α} {c : α} : max a (min b c) = min (max a b) (max a c) :=
  sup_inf_left

theorem max_min_distrib_right {α : Type u} [linear_order α] {a : α} {b : α} {c : α} : max (min a b) c = min (max a c) (max b c) :=
  sup_inf_right

theorem min_max_distrib_left {α : Type u} [linear_order α] {a : α} {b : α} {c : α} : min a (max b c) = max (min a b) (min a c) :=
  inf_sup_left

theorem min_max_distrib_right {α : Type u} [linear_order α] {a : α} {b : α} {c : α} : min (max a b) c = max (min a c) (min b c) :=
  inf_sup_right

theorem min_le_max {α : Type u} [linear_order α] {a : α} {b : α} : min a b ≤ max a b :=
  le_trans (min_le_left a b) (le_max_left a b)

@[simp] theorem min_eq_left_iff {α : Type u} [linear_order α] {a : α} {b : α} : min a b = a ↔ a ≤ b :=
  inf_eq_left

@[simp] theorem min_eq_right_iff {α : Type u} [linear_order α] {a : α} {b : α} : min a b = b ↔ b ≤ a :=
  inf_eq_right

@[simp] theorem max_eq_left_iff {α : Type u} [linear_order α] {a : α} {b : α} : max a b = a ↔ b ≤ a :=
  sup_eq_left

@[simp] theorem max_eq_right_iff {α : Type u} [linear_order α] {a : α} {b : α} : max a b = b ↔ a ≤ b :=
  sup_eq_right

/-- An instance asserting that `max a a = a` -/
protected instance max_idem {α : Type u} [linear_order α] : is_idempotent α max :=
  Mathlib.sup_is_idempotent

/-- An instance asserting that `min a a = a` -/
protected instance min_idem {α : Type u} [linear_order α] : is_idempotent α min :=
  Mathlib.inf_is_idempotent

@[simp] theorem max_lt_iff {α : Type u} [linear_order α] {a : α} {b : α} {c : α} : max a b < c ↔ a < c ∧ b < c :=
  sup_lt_iff

@[simp] theorem lt_min_iff {α : Type u} [linear_order α] {a : α} {b : α} {c : α} : a < min b c ↔ a < b ∧ a < c :=
  lt_inf_iff

@[simp] theorem lt_max_iff {α : Type u} [linear_order α] {a : α} {b : α} {c : α} : a < max b c ↔ a < b ∨ a < c :=
  lt_sup_iff

@[simp] theorem min_lt_iff {α : Type u} [linear_order α] {a : α} {b : α} {c : α} : min a b < c ↔ a < c ∨ b < c :=
  lt_max_iff

@[simp] theorem min_le_iff {α : Type u} [linear_order α] {a : α} {b : α} {c : α} : min a b ≤ c ↔ a ≤ c ∨ b ≤ c :=
  inf_le_iff

@[simp] theorem le_max_iff {α : Type u} [linear_order α] {a : α} {b : α} {c : α} : a ≤ max b c ↔ a ≤ b ∨ a ≤ c :=
  min_le_iff

theorem max_lt_max {α : Type u} [linear_order α] {a : α} {b : α} {c : α} {d : α} (h₁ : a < c) (h₂ : b < d) : max a b < max c d := sorry

theorem min_lt_min {α : Type u} [linear_order α] {a : α} {b : α} {c : α} {d : α} (h₁ : a < c) (h₂ : b < d) : min a b < min c d :=
  max_lt_max h₁ h₂

theorem min_right_comm {α : Type u} [linear_order α] (a : α) (b : α) (c : α) : min (min a b) c = min (min a c) b :=
  right_comm min min_comm min_assoc a b c

theorem max.left_comm {α : Type u} [linear_order α] (a : α) (b : α) (c : α) : max a (max b c) = max b (max a c) :=
  left_comm max max_comm max_assoc a b c

theorem max.right_comm {α : Type u} [linear_order α] (a : α) (b : α) (c : α) : max (max a b) c = max (max a c) b :=
  right_comm max max_comm max_assoc a b c

theorem monotone.map_max {α : Type u} {β : Type v} [linear_order α] [linear_order β] {f : α → β} {a : α} {b : α} (hf : monotone f) : f (max a b) = max (f a) (f b) := sorry

theorem monotone.map_min {α : Type u} {β : Type v} [linear_order α] [linear_order β] {f : α → β} {a : α} {b : α} (hf : monotone f) : f (min a b) = min (f a) (f b) :=
  monotone.map_max (monotone.order_dual hf)

theorem min_choice {α : Type u} [linear_order α] (a : α) (b : α) : min a b = a ∨ min a b = b := sorry

theorem max_choice {α : Type u} [linear_order α] (a : α) (b : α) : max a b = a ∨ max a b = b :=
  min_choice a b

theorem le_of_max_le_left {α : Type u} [linear_order α] {a : α} {b : α} {c : α} (h : max a b ≤ c) : a ≤ c :=
  le_trans (le_max_left a b) h

theorem le_of_max_le_right {α : Type u} [linear_order α] {a : α} {b : α} {c : α} (h : max a b ≤ c) : b ≤ c :=
  le_trans (le_max_right a b) h


def injective {X Y} (f : X → Y)
    := ∀ x₁ x₂, f x₁ = f x₂ → x₁ = x₂

def range {X Y} (f : X → Y)
    := { y | ∃ x, f x = y }

/--
Type of pairs (k,p) where k
is a natural number and p is a witness to the proof that k < n.
-/
def finite_subset (n : ℕ) := Σ' k, k < n

def lift_finite (m n : ℕ) (p : m < n) : finite_subset m → finite_subset n
    := λ k, ⟨k.1, lt.trans k.2 p⟩

lemma pred_exists (n : ℕ) (p: n > 0) : exists k, nat.succ k = n
:=
begin
induction n with d hd,
{sorry},
{ existsi d,
  refl}
end

lemma succ_greater_than_nat (n : ℕ) : nat.succ n > n

:=
begin
induction n with d hd,
{sorry},
{sorry}
end

/--
Pigeonhole principle, induction on n
-/
theorem pigeonhole_principle
    (n m : ℕ)
    (f : finite_subset n → finite_subset m)
: (n > m) → ¬(injective f)
:= begin
    intros n_gt_m f_injective,
    induction m with d hd,
    {
         cases pred_exists n n_gt_m with k hk,
         let n_gt_k := succ_greater_than_nat k,
         rw hk at n_gt_k,
         let fk := f ⟨k, n_gt_k⟩,
         let fk2 := fk.2,
         sorry
    },

    {
        sorry
    },

end

#print pigeonhole_principle


#check sub_self

example (x : ℤ) : x * 0 = 0 :=
calc
  x * 0 = x * (x - x): by rw sub_self x
  ... = x*x - x*x: by rw mul_sub x
  ... = 0: by rw sub_self (x*x)


class Trans (r : α → β → Prop) (s : β → γ → Prop) (t : outParam (α → γ → Prop)) where
  trans : r a b → s b c → t a c

export Trans (trans)

instance : Trans (α := Nat) (β := Nat) (γ := Nat) (.≤.) (.≤.) (.≤.) where
  trans := Nat.leTrans

instance : Trans (α := Int) (β := Int) (γ := Int) (.≤.) (.≤.) (.≤.) where
  trans := sorry

theorem ex1 {a b c d : Nat} (h1 : a ≤ b) (h2 : b ≤ c) (h3 : c ≤ d) : a ≤ d :=
  trans h1 <| trans h2 h3

theorem ex2 {a b c d : Int} (h1 : a ≤ b) (h2 : b ≤ c) (h3 : c ≤ d) : a ≤ d :=
  trans h1 <| trans h2 h3


import ring_theory.coprime.lemmas ring_theory.ideal.basic

/-! # IMO 2012 N1 -/

namespace IMOSL
namespace IMO2012N1

def admissible {R : Type*} [semiring R] (A : set R) :=
  ∀ x y : R, x ∈ A → y ∈ A → ∀ r : R, x ^ 2 + r * x * y + y ^ 2 ∈ A

private lemma admissible_ideal {R : Type*} [comm_semiring R] (I : ideal R) :
  admissible (I : set R) :=
  λ u v h h0 r, by rw [sq, mul_right_comm, ← add_mul, sq];
    exact I.add_mem (I.mul_mem_left (u + r * v) h) (I.mul_mem_left v h0)

private lemma admissible_mem_sq_mul {R : Type*} [comm_ring R]
  {A : set R} (h : admissible A) {z : R} (h0 : z ∈ A) (k : R) :
  k * z ^ 2 ∈ A :=
  by replace h := h z z h0 h0 (k - (1 + 1));
    rwa [mul_assoc, ← sq, ← one_add_mul, ← add_one_mul,
      add_right_comm, add_sub_cancel'_right] at h

/-- Final solution -/
theorem final_solution {R : Type*} [comm_ring R] (x y : R) :
  (∀ A : set R, admissible A → x ∈ A → y ∈ A → ∀ z : R, z ∈ A) ↔ is_coprime x y :=
begin
  refine ⟨λ h, _, λ h A h0 h1 h2, _⟩,

  ---- If the only admissible set containing `x` and `y` is `R`, then `x` and `y` are coprime.
  { replace h := h _ (admissible_ideal $ ideal.span {x, y})
      (ideal.subset_span $ set.mem_insert x _)
      (ideal.subset_span $ set.mem_insert_of_mem _ $ set.mem_singleton y) 1,
    rw [set_like.mem_coe, ideal.mem_span_insert] at h,
    rcases h with ⟨a, z, h0, h⟩,
    rw ideal.mem_span_singleton at h0; rcases h0 with ⟨b, rfl⟩,
    rw mul_comm y at h; exact ⟨a, b, h.symm⟩ },

  ---- If `x` and `y` are coprime, the only admissible set `x` and `y` is `R`
  suffices : (1 : R) ∈ A,
  { intros x,
    rw [← mul_one x, ← one_pow 2],
    exact admissible_mem_sq_mul h0 this x },
  { replace h : is_coprime (x ^ 2) (y ^ 2) := is_coprime.pow h,
    rcases h with ⟨a, b, h⟩,
    replace h0 := h0 _ _ (admissible_mem_sq_mul h0 h1 a) (admissible_mem_sq_mul h0 h2 b) 2,
    rwa [← add_sq, h, one_pow] at h0 }
end

end IMO2012N1
end IMOSL