/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes
-/
import number_theory.legendre_symbol.quadratic_reciprocity

/-!
# Lemmas of Gauss and Eisenstein

This file contains code for the proof of the Lemmas of Gauss and Eisenstein
on the Legendre symbol. The main results are `zmod.gauss_lemma_aux` and
`zmod.eisenstein_lemma_aux`.
-/

open function finset nat finite_field zmod
open_locale big_operators nat

namespace zmod

section wilson

variables (p : ℕ) [fact p.prime]

/-- **Wilson's Lemma**: the product of `1`, ..., `p-1` is `-1` modulo `p`. -/
@[simp] lemma wilsons_lemma : ((p - 1)! : zmod p) = -1 :=
begin
  refine
  calc ((p - 1)! : zmod p) = (∏ x in Ico 1 (succ (p - 1)), x) :
    by rw [← finset.prod_Ico_id_eq_factorial, prod_nat_cast]
                               ... = (∏ x : (zmod p)ˣ, x) : _
                               ... = -1 : by simp_rw [← units.coe_hom_apply,
    ← (units.coe_hom (zmod p)).map_prod, prod_univ_units_id_eq_neg_one, units.coe_hom_apply,
    units.coe_neg, units.coe_one],
  have hp : 0 < p := (fact.out p.prime).pos,
  symmetry,
  refine prod_bij (λ a _, (a : zmod p).val) _ _ _ _,
  { intros a ha,
    rw [mem_Ico, ← nat.succ_sub hp, nat.succ_sub_one],
    split,
    { apply nat.pos_of_ne_zero, rw ← @val_zero p,
      assume h, apply units.ne_zero a (val_injective p h) },
    { exact val_lt _ } },
  { intros a ha, simp only [cast_id, nat_cast_val], },
  { intros _ _ _ _ h, rw units.ext_iff, exact val_injective p h },
  { intros b hb,
    rw [mem_Ico, nat.succ_le_iff, ← succ_sub hp, succ_sub_one, pos_iff_ne_zero] at hb,
    refine ⟨units.mk0 b _, finset.mem_univ _, _⟩,
    { assume h, apply hb.1, apply_fun val at h,
      simpa only [val_cast_of_lt hb.right, val_zero] using h },
    { simp only [val_cast_of_lt hb.right, units.coe_mk0], } }
end

@[simp] lemma prod_Ico_one_prime : (∏ x in Ico 1 p, (x : zmod p)) = -1 :=
begin
  conv in (Ico 1 p) { rw [← succ_sub_one p, succ_sub (fact.out p.prime).pos] },
  rw [← prod_nat_cast, finset.prod_Ico_id_eq_factorial, wilsons_lemma]
end

end wilson

end zmod

section gauss_eisenstein

namespace zmod

/-- The image of the map sending a non zero natural number `x ≤ p / 2` to the absolute value
  of the element of interger in the interval `(-p/2, p/2]` congruent to `a * x` mod p is the set
  of non zero natural numbers `x` such that `x ≤ p / 2` -/
lemma Ico_map_val_min_abs_nat_abs_eq_Ico_map_id
  (p : ℕ) [hp : fact p.prime] (a : zmod p) (hap : a ≠ 0) :
  (Ico 1 (p / 2).succ).1.map (λ x, (a * x).val_min_abs.nat_abs) =
  (Ico 1 (p / 2).succ).1.map (λ a, a) :=
begin
  have he : ∀ {x}, x ∈ Ico 1 (p / 2).succ → x ≠ 0 ∧ x ≤ p / 2,
    by simp [nat.lt_succ_iff, nat.succ_le_iff, pos_iff_ne_zero] {contextual := tt},
  have hep : ∀ {x}, x ∈ Ico 1 (p / 2).succ → x < p,
    from λ x hx, lt_of_le_of_lt (he hx).2 (nat.div_lt_self hp.1.pos dec_trivial),
  have hpe : ∀ {x}, x ∈ Ico 1 (p / 2).succ → ¬ p ∣ x,
    from λ x hx hpx, not_lt_of_ge (le_of_dvd (nat.pos_of_ne_zero (he hx).1) hpx) (hep hx),
  have hmem : ∀ (x : ℕ) (hx : x ∈ Ico 1 (p / 2).succ),
    (a * x : zmod p).val_min_abs.nat_abs ∈ Ico 1 (p / 2).succ,
  { assume x hx,
    simp [hap, char_p.cast_eq_zero_iff (zmod p) p, hpe hx, lt_succ_iff, succ_le_iff,
        pos_iff_ne_zero, nat_abs_val_min_abs_le _], },
  have hsurj : ∀ (b : ℕ) (hb : b ∈ Ico 1 (p / 2).succ),
    ∃ x ∈ Ico 1 (p / 2).succ, b = (a * x : zmod p).val_min_abs.nat_abs,
  { assume b hb,
    refine ⟨(b / a : zmod p).val_min_abs.nat_abs, mem_Ico.mpr ⟨_, _⟩, _⟩,
    { apply nat.pos_of_ne_zero,
      simp only [div_eq_mul_inv, hap, char_p.cast_eq_zero_iff (zmod p) p, hpe hb, not_false_iff,
        val_min_abs_eq_zero, inv_eq_zero, int.nat_abs_eq_zero, ne.def, mul_eq_zero, or_self] },
    { apply lt_succ_of_le, apply nat_abs_val_min_abs_le },
    { rw nat_cast_nat_abs_val_min_abs,
      split_ifs,
      { erw [mul_div_cancel' _ hap, val_min_abs_def_pos, val_cast_of_lt (hep hb),
          if_pos (le_of_lt_succ (mem_Ico.1 hb).2), int.nat_abs_of_nat], },
      { erw [mul_neg, mul_div_cancel' _ hap, nat_abs_val_min_abs_neg,
          val_min_abs_def_pos, val_cast_of_lt (hep hb), if_pos (le_of_lt_succ (mem_Ico.1 hb).2),
          int.nat_abs_of_nat] } } },
  exact multiset.map_eq_map_of_bij_of_nodup _ _ (finset.nodup _) (finset.nodup _)
    (λ x _, (a * x : zmod p).val_min_abs.nat_abs) hmem (λ _ _, rfl)
    (inj_on_of_surj_on_of_card_le _ hmem hsurj le_rfl) hsurj
end

private lemma gauss_lemma_aux₁ (p : ℕ) [fact p.prime] [fact (p % 2 = 1)]
  {a : ℤ} (hap : (a : zmod p) ≠ 0) :
  (a^(p / 2) * (p / 2)! : zmod p) =
  (-1)^((Ico 1 (p / 2).succ).filter
    (λ x : ℕ, ¬(a * x : zmod p).val ≤ p / 2)).card * (p / 2)! :=
calc (a ^ (p / 2) * (p / 2)! : zmod p) =
    (∏ x in Ico 1 (p / 2).succ, a * x) :
  by rw [prod_mul_distrib, ← prod_nat_cast, prod_Ico_id_eq_factorial,
      prod_const, card_Ico, succ_sub_one]; simp
... = (∏ x in Ico 1 (p / 2).succ, (a * x : zmod p).val) : by simp
... = (∏ x in Ico 1 (p / 2).succ,
    (if (a * x : zmod p).val ≤ p / 2 then 1 else -1) *
      (a * x : zmod p).val_min_abs.nat_abs) :
  prod_congr rfl $ λ _ _, begin
    simp only [nat_cast_nat_abs_val_min_abs],
    split_ifs; simp
  end
... = (-1)^((Ico 1 (p / 2).succ).filter
      (λ x : ℕ, ¬(a * x : zmod p).val ≤ p / 2)).card *
    (∏ x in Ico 1 (p / 2).succ, (a * x : zmod p).val_min_abs.nat_abs) :
  have (∏ x in Ico 1 (p / 2).succ,
        if (a * x : zmod p).val ≤ p / 2 then (1 : zmod p) else -1) =
      (∏ x in (Ico 1 (p / 2).succ).filter
        (λ x : ℕ, ¬(a * x : zmod p).val ≤ p / 2), -1),
    from prod_bij_ne_one (λ x _ _, x)
      (λ x, by split_ifs; simp * at * {contextual := tt})
      (λ _ _ _ _ _ _, id)
      (λ b h _, ⟨b, by simp [-not_le, *] at *⟩)
      (by intros; split_ifs at *; simp * at *),
  by rw [prod_mul_distrib, this]; simp
... = (-1)^((Ico 1 (p / 2).succ).filter
      (λ x : ℕ, ¬(a * x : zmod p).val ≤ p / 2)).card * (p / 2)! :
  by rw [← prod_nat_cast, finset.prod_eq_multiset_prod,
      Ico_map_val_min_abs_nat_abs_eq_Ico_map_id p a hap,
      ← finset.prod_eq_multiset_prod, prod_Ico_id_eq_factorial]

lemma gauss_lemma_aux (p : ℕ) [hp : fact p.prime] [fact (p % 2 = 1)]
  {a : ℤ} (hap : (a : zmod p) ≠ 0) :
  (a^(p / 2) : zmod p) = (-1)^((Ico 1 (p / 2).succ).filter
    (λ x : ℕ, p / 2 < (a * x : zmod p).val)).card :=
(mul_left_inj'
    (show ((p / 2)! : zmod p) ≠ 0,
      by rw [ne.def, char_p.cast_eq_zero_iff (zmod p) p, hp.1.dvd_factorial, not_le];
          exact nat.div_lt_self hp.1.pos dec_trivial)).1 $
  by simpa using gauss_lemma_aux₁ p hap

/-- Gauss' lemma. The legendre symbol can be computed by considering the number of naturals less
  than `p/2` such that `(a * x) % p > p / 2` -/
lemma gauss_lemma {p : ℕ} [fact p.prime] {a : ℤ} (hp : p ≠ 2) (ha0 : (a : zmod p) ≠ 0) :
  legendre_sym p a = (-1) ^ ((Ico 1 (p / 2).succ).filter
    (λ x : ℕ, p / 2 < (a * x : zmod p).val)).card :=
begin
  haveI hp' : fact (p % 2 = 1) := ⟨nat.prime.mod_two_eq_one_iff_ne_two.mpr hp⟩,
  have : (legendre_sym p a : zmod p) = (((-1)^((Ico 1 (p / 2).succ).filter
    (λ x : ℕ, p / 2 < (a * x : zmod p).val)).card : ℤ) : zmod p) :=
    by { rw [legendre_sym.eq_pow, gauss_lemma_aux p ha0]; simp },
  cases legendre_sym.eq_one_or_neg_one p ha0;
  cases neg_one_pow_eq_or ℤ ((Ico 1 (p / 2).succ).filter
    (λ x : ℕ, p / 2 < (a * x : zmod p).val)).card;
  simp [*, ne_neg_self p one_ne_zero, (ne_neg_self p one_ne_zero).symm] at *
end

private lemma eisenstein_lemma_aux₁ (p : ℕ) [fact p.prime] [hp2 : fact (p % 2 = 1)]
  {a : ℕ} (hap : (a : zmod p) ≠ 0) :
  ((∑ x in Ico 1 (p / 2).succ, a * x : ℕ) : zmod 2) =
    ((Ico 1 (p / 2).succ).filter
      ((λ x : ℕ, p / 2 < (a * x : zmod p).val))).card +
      ∑ x in Ico 1 (p / 2).succ, x
    + (∑ x in Ico 1 (p / 2).succ, (a * x) / p : ℕ) :=
have hp2 : (p : zmod 2) = (1 : ℕ), from (eq_iff_modeq_nat _).2 hp2.1,
calc ((∑ x in Ico 1 (p / 2).succ, a * x : ℕ) : zmod 2)
    = ((∑ x in Ico 1 (p / 2).succ, ((a * x) % p + p * ((a * x) / p)) : ℕ) : zmod 2) :
  by simp only [mod_add_div]
... = (∑ x in Ico 1 (p / 2).succ, ((a * x : ℕ) : zmod p).val : ℕ) +
    (∑ x in Ico 1 (p / 2).succ, (a * x) / p : ℕ) :
  by simp only [val_nat_cast];
    simp [sum_add_distrib, mul_sum.symm, nat.cast_add, nat.cast_mul, nat.cast_sum, hp2]
... = _ : congr_arg2 (+)
  (calc ((∑ x in Ico 1 (p / 2).succ, ((a * x : ℕ) : zmod p).val : ℕ) : zmod 2)
      = ∑ x in Ico 1 (p / 2).succ,
          ((((a * x : zmod p).val_min_abs +
            (if (a * x : zmod p).val ≤ p / 2 then 0 else p)) : ℤ) : zmod 2) :
        by simp only [(val_eq_ite_val_min_abs _).symm]; simp [nat.cast_sum]
  ... = ((Ico 1 (p / 2).succ).filter
        (λ x : ℕ, p / 2 < (a * x : zmod p).val)).card +
      ((∑ x in Ico 1 (p / 2).succ, (a * x : zmod p).val_min_abs.nat_abs) : ℕ) :
    by { simp [ite_cast, add_comm, sum_add_distrib, finset.sum_ite, hp2, nat.cast_sum], }
  ... = _ : by rw [finset.sum_eq_multiset_sum,
      Ico_map_val_min_abs_nat_abs_eq_Ico_map_id p a hap,
      ← finset.sum_eq_multiset_sum];
    simp [nat.cast_sum]) rfl

lemma eisenstein_lemma_aux (p : ℕ) [fact p.prime] [fact (p % 2 = 1)]
  {a : ℕ} (ha2 : a % 2 = 1) (hap : (a : zmod p) ≠ 0) :
  ((Ico 1 (p / 2).succ).filter
    ((λ x : ℕ, p / 2 < (a * x : zmod p).val))).card
  ≡ ∑ x in Ico 1 (p / 2).succ, (x * a) / p [MOD 2] :=
have ha2 : (a : zmod 2) = (1 : ℕ), from (eq_iff_modeq_nat _).2 ha2,
(eq_iff_modeq_nat 2).1 $ sub_eq_zero.1 $
  by simpa [add_left_comm, sub_eq_add_neg, finset.mul_sum.symm, mul_comm, ha2, nat.cast_sum,
            add_neg_eq_iff_eq_add.symm, neg_eq_self_mod_two, add_assoc]
    using eq.symm (eisenstein_lemma_aux₁ p hap)

lemma div_eq_filter_card {a b c : ℕ} (hb0 : 0 < b) (hc : a / b ≤ c) : a / b =
  ((Ico 1 c.succ).filter (λ x, x * b ≤ a)).card :=
calc a / b = (Ico 1 (a / b).succ).card : by simp
... = ((Ico 1 c.succ).filter (λ x, x * b ≤ a)).card :
  congr_arg _ $ finset.ext $ λ x,
    have x * b ≤ a → x ≤ c,
      from λ h, le_trans (by rwa [le_div_iff_mul_le hb0]) hc,
    by simp [lt_succ_iff, le_div_iff_mul_le hb0]; tauto

/-- The given sum is the number of integer points in the triangle formed by the diagonal of the
  rectangle `(0, p/2) × (0, q/2)`  -/
private lemma sum_Ico_eq_card_lt {p q : ℕ} :
  ∑ a in Ico 1 (p / 2).succ, (a * q) / p = ((Ico 1 (p / 2).succ ×ˢ Ico 1 (q / 2).succ).filter $
    λ x : ℕ × ℕ, x.2 * p ≤ x.1 * q).card :=
if hp0 : p = 0 then by simp [hp0, finset.ext_iff]
else
  calc ∑ a in Ico 1 (p / 2).succ, (a * q) / p =
    ∑ a in Ico 1 (p / 2).succ,
      ((Ico 1 (q / 2).succ).filter (λ x, x * p ≤ a * q)).card :
    finset.sum_congr rfl $ λ x hx,
      div_eq_filter_card (nat.pos_of_ne_zero hp0)
        (calc x * q / p ≤ (p / 2) * q / p :
            nat.div_le_div_right (mul_le_mul_of_nonneg_right
              (le_of_lt_succ $ (mem_Ico.mp hx).2)
              (nat.zero_le _))
          ... ≤ _ : nat.div_mul_div_le_div _ _ _)
  ... = _ : by rw [← card_sigma];
    exact card_congr (λ a _, ⟨a.1, a.2⟩)
      (by simp only [mem_filter, mem_sigma, and_self, forall_true_iff, mem_product]
        {contextual := tt})
      (λ ⟨_, _⟩ ⟨_, _⟩, by simp only [prod.mk.inj_iff, eq_self_iff_true, and_self, heq_iff_eq,
        forall_true_iff] {contextual := tt})
      (λ ⟨b₁, b₂⟩ h, ⟨⟨b₁, b₂⟩,
        by revert h; simp only [mem_filter, eq_self_iff_true, exists_prop_of_true, mem_sigma,
          and_self, forall_true_iff, mem_product] {contextual := tt}⟩)

/-- Each of the sums in this lemma is the cardinality of the set integer points in each of the
  two triangles formed by the diagonal of the rectangle `(0, p/2) × (0, q/2)`. Adding them
  gives the number of points in the rectangle. -/
lemma sum_mul_div_add_sum_mul_div_eq_mul (p q : ℕ) [hp : fact p.prime]
  (hq0 : (q : zmod p) ≠ 0) :
  ∑ a in Ico 1 (p / 2).succ, (a * q) / p +
  ∑ a in Ico 1 (q / 2).succ, (a * p) / q =
  (p / 2) * (q / 2) :=
begin
  have hswap : ((Ico 1 (q / 2).succ ×ˢ Ico 1 (p / 2).succ).filter
    (λ x : ℕ × ℕ, x.2 * q ≤ x.1 * p)).card =
  ((Ico 1 (p / 2).succ ×ˢ Ico 1 (q / 2).succ).filter
    (λ x : ℕ × ℕ, x.1 * q ≤ x.2 * p)).card :=
  card_congr (λ x _, prod.swap x)
    (λ ⟨_, _⟩, by simp only [mem_filter, and_self, prod.swap_prod_mk, forall_true_iff, mem_product]
      {contextual := tt})
    (λ ⟨_, _⟩ ⟨_, _⟩, by simp only [prod.mk.inj_iff, eq_self_iff_true, and_self, prod.swap_prod_mk,
      forall_true_iff] {contextual := tt})
    (λ ⟨x₁, x₂⟩ h, ⟨⟨x₂, x₁⟩, by revert h; simp only [mem_filter, eq_self_iff_true, and_self,
      exists_prop_of_true, prod.swap_prod_mk, forall_true_iff, mem_product] {contextual := tt}⟩),
  have hdisj : disjoint
    ((Ico 1 (p / 2).succ ×ˢ Ico 1 (q / 2).succ).filter
      (λ x : ℕ × ℕ, x.2 * p ≤ x.1 * q))
    ((Ico 1 (p / 2).succ ×ˢ Ico 1 (q / 2).succ).filter
      (λ x : ℕ × ℕ, x.1 * q ≤ x.2 * p)),
  { apply disjoint_filter.2 (λ x hx hpq hqp, _),
    have hxp : x.1 < p, from lt_of_le_of_lt
      (show x.1 ≤ p / 2, by simp only [*, lt_succ_iff, mem_Ico, mem_product] at *; tauto)
      (nat.div_lt_self hp.1.pos dec_trivial),
    have : (x.1 : zmod p) = 0,
    { simpa [hq0] using congr_arg (coe : ℕ → zmod p) (le_antisymm hpq hqp) },
    apply_fun zmod.val at this,
    rw [val_cast_of_lt hxp, val_zero] at this,
    simpa only [this, nonpos_iff_eq_zero, mem_Ico, one_ne_zero, false_and, mem_product] using hx },
  have hunion : (Ico 1 (p / 2).succ ×ˢ Ico 1 (q / 2).succ).filter
      (λ x : ℕ × ℕ, x.2 * p ≤ x.1 * q) ∪
    (Ico 1 (p / 2).succ ×ˢ Ico 1 (q / 2).succ).filter
      (λ x : ℕ × ℕ, x.1 * q ≤ x.2 * p) =
    (Ico 1 (p / 2).succ ×ˢ Ico 1 (q / 2).succ),
  from finset.ext (λ x, by have := le_total (x.2 * p) (x.1 * q);
    simp only [mem_union, mem_filter, mem_Ico, mem_product]; tauto),
  rw [sum_Ico_eq_card_lt, sum_Ico_eq_card_lt, hswap, ← card_disjoint_union hdisj, hunion,
    card_product],
  simp only [card_Ico, tsub_zero, succ_sub_succ_eq_sub]
end

lemma eisenstein_lemma {p : ℕ} [fact p.prime] (hp : p ≠ 2) {a : ℕ} (ha1 : a % 2 = 1)
  (ha0 : (a : zmod p) ≠ 0) :
  legendre_sym p a = (-1)^∑ x in Ico 1 (p / 2).succ, (x * a) / p :=
begin
  haveI hp' : fact (p % 2 = 1) := ⟨nat.prime.mod_two_eq_one_iff_ne_two.mpr hp⟩,
  have ha0' : ((a : ℤ) : zmod p) ≠ 0 := by { norm_cast, exact ha0 },
  rw [neg_one_pow_eq_pow_mod_two, gauss_lemma hp ha0', neg_one_pow_eq_pow_mod_two,
      (by norm_cast : ((a : ℤ) : zmod p) = (a : zmod p)),
      show _ = _, from eisenstein_lemma_aux p ha1 ha0]
end

end zmod

end gauss_eisenstein


import tactic
import tactic.swap_var
import data.set.basic

-- mathlib defines `symm_diff` in the general context
-- of Heyting algebras, but I choose to roll out my own
-- definition catered to the concrete setting of `set α`.
def symm_diff {α : Type*} (A B : set α) : set α := (A \ B) ∪ (B \ A)

infix ` ∆ `:100 := symm_diff

theorem inter_sdiff {α : Type*} (A B C : set α) :
  A ∩ (B ∆ C) = (A ∩ B) ∆ (A ∩ C) :=
begin
  ext, split; intro hx,
  { cases hx.2,
    work_on_goal 1 { refine or.inl ⟨⟨hx.1, h.1⟩, _⟩ },
    work_on_goal 2 { refine or.inr ⟨⟨hx.1, h.1⟩, _⟩ },
    all_goals { simpa using (λ _, h.2) } },
  { cases hx,
    work_on_goal 1 { refine ⟨hx.1.1, or.inl ⟨hx.1.2, _⟩⟩ },
    work_on_goal 2 { refine ⟨hx.1.1, or.inr ⟨hx.1.2, _⟩⟩ },
    all_goals {
      have h := hx.2,
      rw set.mem_inter_iff at h, push_neg at h,
      exact h hx.1.1
    } }
end

-- Needed for the following result
@[simp]
theorem symm_diff_self {α : Type*} (A : set α) : A ∆ A = ∅ :=
set.ext_iff.mpr (λ x,
  ⟨λ hx, (false.elim $ or.elim hx (λ h, h.2 h.1) (λ h, h.2 h.1)),
  λ hx, (false.elim $ (set.not_mem_empty x) hx)⟩
)

example : ∃ (α : Type*) (A B C : set α),
  A ∪ (B ∆ C) ≠ (A ∪ B) ∆ (A ∪ C) :=
by { use [ℕ, set.univ, set.univ, set.univ], simp }


-- TODO: Define functor, ie. group morphism to pq morphism and comp

import power_quandle

import algebra.group
import group_theory.quotient_group
import group_theory.order_of_element

universes u v

section group_to_pq

variables {Q : Type u} [group Q]

def rhd_group (x : Q) (y : Q) : Q := x * y * x⁻¹

instance group_has_rhd : has_rhd Q := ⟨rhd_group⟩

lemma rhd_def_group : ∀ a b : Q, a ▷ b = a * b * a⁻¹  := begin
  intros a b,
  refl,
end

lemma rhd_mul (x y z : Q) : x ▷ (y * z) = (x ▷ y) * (x ▷ z) :=
begin
  simp only [rhd_def_group, conj_mul],
end

lemma rhd_inv (x y : Q) : x ▷ (y⁻¹) = (x ▷ y)⁻¹ :=
begin
  simp only [rhd_def_group, conj_inv],
end

lemma mul_rhd (a b c : Q) : a * b ▷ c = a ▷ b ▷ c :=
begin
  simp only [rhd_def_group],
  group,
end

lemma center_reformulate (a b : Q) : (a * b = b * a) ↔ (a * b * a⁻¹ = b) :=
begin
    split,
    intro hab, rw hab, group,
    intro hab, rw ←hab, simp, rw hab,
end

lemma center_reformulate_inv (a b : Q) : (a * b⁻¹ = b⁻¹ * a) ↔ (a * b * a⁻¹ = b) :=
begin
    split,
    {
        intro hab,
        refine inv_inj.mp _,
        simp,
        rw hab,
        simp,
    },
    {
        intro hab,
        rw ←hab,
        simp,
        refine inv_inj.mp _,
        simp,
        exact hab,
    },
end

instance group_is_power_quandle : power_quandle Q := {
  rhd_dist := begin
    intros a b c,
    simp only [rhd_def_group, conj_mul, conj_inv],
  end,
  rhd_idem := begin
    intros a,
    simp only [rhd_def_group, mul_inv_cancel_right],
  end,
  pow_one := begin
    intros a,
    simp only [gpow_one],
  end,
  pow_zero := begin
    intros a,
    simp only [gpow_zero],
  end,
  pow_comp := begin
    intros a n m,
    group,
  end,
  rhd_one := begin
    intros a,
    simp only [rhd_def_group, mul_one, mul_right_inv],
  end,
  one_rhd := begin
    intros a,
    simp only [rhd_def_group, one_inv, mul_one, one_mul],
  end,
  pow_rhd := begin
    intros a b,
    have for_nat : ∀ n : ℕ, (a ▷ b) ^ n = a ▷ (b ^ n),
    {
      intro n,
      induction n,
      {
        simp only [rhd_def_group, mul_one, mul_right_inv, pow_zero],
      },
      {
        simp only [pow_succ, n_ih, rhd_mul],
      },
    },
    intro n,
    induction n,
    {
      simp only [for_nat, int.of_nat_eq_coe, gpow_coe_nat],
    },
    {
      simp only [gpow_neg_succ_of_nat, pow_succ, for_nat, rhd_inv],
    },
  end,
  rhd_pow_add := begin
      intros a b n m,
      simp only [rhd_def_group],
      group,
  end,
  ..group_has_rhd,
  ..group.has_pow }

end group_to_pq

section group_morph_to_pq_morph

variables {G : Type u} [group G] {H : Type v} [group H]

theorem functoriality_group_to_pq (f : G →* H) : is_pq_morphism f :=
begin
  split,
  {
    intros a b,
    simp only [rhd_def_group, monoid_hom.map_mul, eq_self_iff_true, monoid_hom.map_mul_inv, mul_left_inj],
  },
  {
    intros a n,
    simp only [monoid_hom.map_gpow],
  },
end

theorem functoriality_group_iso_to_pq (f : G ≃* H) : is_pq_morphism f :=
begin
  convert functoriality_group_to_pq f.to_monoid_hom,
end

-- composition and identity preservence is trivial

/-
theorem group_to_pq_fullness_almost (f : G → H) (hf : is_pq_morphism f) (hfs : function.surjective f) (hG : ∀ a b : H, (∀ c : H, a ▷ c = b ▷ c) → a = b) : is_group_morphism f :=
begin
    cases hf with hf1pre hf2,
    have hf1 : ∀ a b : G, f(a * b * a⁻¹) = f(a) * f(b) * (f(a))⁻¹,
    {
        intros a b,
        specialize hf1pre a b,
        repeat {rw rhd_group_def at hf1pre},
        exact hf1pre,
    },
    --split,
    {
        intros a b,
        apply hG,
        intro c,
        repeat {rw rhd_group_def},
        have de := hfs c,
        cases de with d hd,
        repeat {rw ←hd},
        simp,
        repeat {rw ←mul_assoc},
        rw ←hf1,
        simp,
        repeat {rw ←mul_assoc},
        have rw_mul_assoc : f (a * b * d * b⁻¹ * a⁻¹) = f a * (f b * f d * (f b)⁻¹) * (f a)⁻¹,
        {
            rw ←hf1,
            rw ←hf1,
            repeat {rw ←mul_assoc},
        },
        rw rw_mul_assoc,
        repeat {rw ←mul_assoc},
    },
    /-split,
    {
        specialize hf2 1 0,
        --rw pow_0_int at hf2,
        --rw pow_0_int at hf2,
        simp at hf2,
        exact hf2,
    },
    {
        intro a,
        specialize hf2 a (-1 : int),
        --rw pow_is_inv,
        --rw pow_is_inv,
        rw ←gpow_neg_one,
        rw ←gpow_neg_one,
        exact hf2,
    },-/
end
-/

end group_morph_to_pq_morph


--
set_option autoBoundImplicitLocal false
universe u
variable {α : Type u}
variable {β : α → Type v}
infix:50 " ≅ " => HEq
theorem ex {p₁ p₂ : Sigma (fun a => β a)} (h₁ : p₁.1 = p₂.1) (h : p₁.2 ≅ p₂.2) : p₁ = p₂ :=
match p₁, p₂, h₁, h with
| ⟨_, _⟩, ⟨_, _⟩, rfl, HEq.refl _ => rfl


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

! This file was ported from Lean 3 source module data.num.prime
! leanprover-community/mathlib commit 58581d0fe523063f5651df0619be2bf65012a94a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Num.Lemmas
import Mathbin.Data.Nat.Prime
import Mathbin.Tactic.Ring

/-!
# Primality for binary natural numbers

This file defines versions of `nat.min_fac` and `nat.prime` for `num` and `pos_num`. As with other
`num` definitions, they are not intended for general use (`nat` should be used instead of `num` in
most cases) but they can be used in contexts where kernel computation is required, such as proofs
by `rfl` and `dec_trivial`, as well as in `#reduce`.

The default decidable instance for `nat.prime` is optimized for VM evaluation, so it should be
preferred within `#eval` or in tactic execution, while for proofs the `norm_num` tactic can be used
to construct primality and non-primality proofs more efficiently than kernel computation.

Nevertheless, sometimes proof by computational reflection requires natural number computations, and
`num` implements algorithms directly on binary natural numbers for this purpose.
-/

namespace PosNum

/-- Auxiliary function for computing the smallest prime factor of a `pos_num`. Unlike
`nat.min_fac_aux`, we use a natural number `fuel` variable that is set to an upper bound on the
number of iterations. It is initialized to the number `n` we are determining primality for. Even
though this is exponential in the input (since it is a `nat`, not a `num`), it will get lazily
evaluated during kernel reduction, so we will only require about `sqrt n` unfoldings, for the
`sqrt n` iterations of the loop. -/
def minFacAux (n : PosNum) : ℕ → PosNum → PosNum
  | 0, _ => n
  | fuel + 1, k =>
    if h : n < k.bit1 * k.bit1 then n else if k.bit1 ∣ n then k.bit1 else min_fac_aux fuel k.succ
#align pos_num.min_fac_aux PosNum.minFacAux

theorem minFacAux_to_nat {fuel : ℕ} {n k : PosNum} (h : Nat.sqrt n < fuel + k.bit1) :
    (minFacAux n fuel k : ℕ) = Nat.minFacAux n k.bit1 :=
  by
  induction' fuel with fuel ih generalizing k <;> rw [min_fac_aux, Nat.minFacAux]
  · rw [if_pos]
    rwa [zero_add, Nat.sqrt_lt] at h
  rw [← mul_to_nat]; simp only [cast_lt, dvd_to_nat, ite_cast]
  congr 2
  rw [ih] <;> [congr , convert Nat.lt_succ_of_lt h using 1] <;>
    simp only [_root_.bit1, _root_.bit0, cast_bit1, cast_succ, Nat.succ_eq_add_one, add_assoc,
      add_left_comm]
#align pos_num.min_fac_aux_to_nat PosNum.minFacAux_to_nat

/-- Returns the smallest prime factor of `n ≠ 1`. -/
def minFac : PosNum → PosNum
  | 1 => 1
  | bit0 n => 2
  | bit1 n => minFacAux (bit1 n) n 1
#align pos_num.min_fac PosNum.minFac

@[simp]
theorem minFac_to_nat (n : PosNum) : (minFac n : ℕ) = Nat.minFac n :=
  by
  cases n; · rfl
  · rw [min_fac, Nat.minFac_eq, if_neg]
    swap
    · simp
    rw [min_fac_aux_to_nat]
    · rfl
    simp only [cast_one, cast_bit1]
    rw [Nat.sqrt_lt]
    convert lt_add_of_pos_right _ (by decide : (0 : ℕ) < (n + 4) * n + 8)
    unfold _root_.bit1 _root_.bit0
    ring
  · rw [min_fac, Nat.minFac_eq, if_pos]
    · rfl
    simp
#align pos_num.min_fac_to_nat PosNum.minFac_to_nat

/-- Primality predicate for a `pos_num`. -/
@[simp]
def Prime (n : PosNum) : Prop :=
  Nat.Prime n
#align pos_num.prime PosNum.Prime

instance decidablePrime : DecidablePred PosNum.Prime
  | 1 => Decidable.isFalse Nat.not_prime_one
  | bit0 n =>
    decidable_of_iff' (n = 1)
      (by
        refine' nat.prime_def_min_fac.trans ((and_iff_right _).trans <| eq_comm.trans _)
        · exact bit0_le_bit0.2 (to_nat_pos _)
        rw [← min_fac_to_nat, to_nat_inj]
        exact ⟨bit0.inj, congr_arg _⟩)
  | bit1 n =>
    decidable_of_iff' (minFacAux (bit1 n) n 1 = bit1 n)
      (by
        refine' nat.prime_def_min_fac.trans ((and_iff_right _).trans _)
        · exact Nat.bit0_le_bit1_iff.2 (to_nat_pos _)
        rw [← min_fac_to_nat, to_nat_inj]; rfl)
#align pos_num.decidable_prime PosNum.decidablePrime

end PosNum

namespace Num

/-- Returns the smallest prime factor of `n ≠ 1`. -/
def minFac : Num → PosNum
  | 0 => 2
  | Pos n => n.minFac
#align num.min_fac Num.minFac

@[simp]
theorem minFac_to_nat : ∀ n : Num, (minFac n : ℕ) = Nat.minFac n
  | 0 => rfl
  | Pos n => PosNum.minFac_to_nat _
#align num.min_fac_to_nat Num.minFac_to_nat

/-- Primality predicate for a `num`. -/
@[simp]
def Prime (n : Num) : Prop :=
  Nat.Prime n
#align num.prime Num.Prime

instance decidablePrime : DecidablePred Num.Prime
  | 0 => Decidable.isFalse Nat.not_prime_zero
  | Pos n => PosNum.decidablePrime n
#align num.decidable_prime Num.decidablePrime

end Num


import data.real.basic
import data.polynomial.derivative
import linear_algebra.basic
import linear_algebra.finite_dimensional

-- On se place dans le R -espace vectoriel E = R[X] .
-- (a) Soit H un sous-espace vectoriel de dimension finie et f un endomorphisme de H. Montrer qu'il existe p ∈ N tel que
--    ∀k ≥ p, Ker f k+1 = Ker f k.
--
-- Soit F un sous-espace vectoriel de E stable par l'opérateur D de dérivation.
-- (b) On suppose que F est de dimension finie non nulle. Montrer que l'endomorphisme induit par D sur R n [X] est nilpotent pour tout n ∈ N .
-- Montrer qu'il existe m ∈ N tel que F = R m [X] .
-- (c) Montrer que si F est de dimension innie alors F = R[X] .
-- (d) Soit g ∈ L(E) tel que g^2 = kId + D avec k ∈ R . Quel est le signe de k ?

variable F: submodule real (polynomial real)
variable HF: forall p: polynomial real, p ∈ F.carrier -> polynomial.derivative p ∈ F.carrier

theorem b (_: finite_dimensional real F):
  exists k >= 0, (linear_map.restrict polynomial.derivative HF)^ k = 0
:=
  sorry


def f (x y : Nat) : Nat :=
  x + 2*y

-- "+" with priority higher than the builtin "+" notation
infix:65 (priority := high) "+" => f

#check 1 + 2

theorem ex (x y : Nat) : x + y = f x y :=
  rfl


import o_minimal.examples.isolating
import algebra.module.ordered
import data.fintype.card
import algebra.module.pi
import algebra.module.submodule

import for_mathlib.ordered_group

namespace o_minimal

universe variable u

open_locale big_operators

/-
Let R be an ordered vector space over an ordered field K (most commonly, R = K).
Then the functions of the form x ↦ k₀ x₀ + ... + kₙ₋₁ xₙ₋₁ + r (with kᵢ ∈ K, r ∈ R)
form an isolating family, which defines the o-minimal structure of semilinear sets.
-/

variables (K R : Type u)
variables [linear_ordered_field K] [ordered_add_comm_group R]
  [semimodule K R] [ordered_semimodule K R]

section semilinear

def semilinear_function_type (n : ℕ) : submodule K (finvec n R → R) :=
{ carrier := {f | ∃ (k : fin n → K) (r : R), f = λ x, ∑ i, k i • x i + r},
  zero_mem' := by { use [0, 0], ext, simp, },
  add_mem' :=
  begin
    rintro - - ⟨kf, rf, rfl⟩ ⟨kg, rg, rfl⟩,
    use [kf + kg, rf + rg],
    ext,
    simp only [finset.sum_add_distrib, add_smul, pi.add_apply],
    abel,
  end,
  smul_mem' :=
  begin
    rintro c - ⟨k, r, rfl⟩,
    use [c • k, c • r],
    ext,
    simp only [smul_add, finset.smul_sum, smul_smul, smul_eq_mul, pi.smul_apply],
  end }

namespace semilinear_function_type
variables {K R} {n : ℕ}

instance : has_coe_to_fun (semilinear_function_type K R n) :=
{ F := λ f, finvec n R → R,
  coe := λ f, f.1 }

@[simp] lemma coe_eq_coe_fn (f : semilinear_function_type K R n) :
  (coe f : finvec n R → R) = f := rfl

@[simp] lemma coe_anon (f) (hf : f ∈ semilinear_function_type K R n) :
  ⇑(⟨f, hf⟩ : semilinear_function_type K R n) = f := rfl

/-- `mk k r` is the semilinear function `x ↦ ∑ i, k i • x i + r`. -/
def mk (k : fin n → K) (r : R) :
  semilinear_function_type K R n :=
⟨_, k, r, rfl⟩

@[simp] lemma coe_mk (k : fin n → K) (r : R) :
  (mk k r : finvec n R → R) = λ x, ∑ i, k i • x i + r := rfl

end semilinear_function_type

open semilinear_function_type

/-- The family of semilinear functions. -/
def semilinear_function_family : function_family R :=
{ carrier := λ n, semilinear_function_type K R n,
  to_fun := λ n, coe_fn,
  const := λ n r, mk 0 r,
  to_fun_const := λ n r, by simp,
  coord := λ n i, mk (λ j, if j = i then 1 else 0) 0,
  to_fun_coord := λ n i,
  begin
    ext x,
    simp only [add_zero, coe_mk],
    rw finset.sum_eq_single i,
    { simp only [if_true, eq_self_iff_true, one_smul], },
    { simp only [eq_self_iff_true, zero_smul, if_false, forall_true_iff] {contextual := tt}, },
    { simp only [finset.mem_univ, forall_prop_of_false, not_true, not_false_iff], }
  end,
  extend_left := λ n f, ⟨f ∘ fin.tail,
  begin
    rcases f with ⟨_, k, r, rfl⟩,
    refine ⟨(fin.cons 0 k), r, _⟩,
    ext,
    simp only [fin.sum_univ_succ, fin.tail, fin.cons_zero, fin.cons_succ, zero_smul, zero_add, coe_anon, function.comp_app],
  end⟩,
  to_fun_extend_left := λ n f, rfl,
  extend_right := λ n f, ⟨f ∘ fin.init,
  begin
    rcases f with ⟨_, k, r, rfl⟩,
    refine ⟨(fin.snoc k 0), r, _⟩,
    ext,
    simp only [fin.sum_univ_cast_succ, fin.init, fin.snoc_last, add_zero, function.comp_app, zero_smul, fin.snoc_cast_succ, coe_anon],
  end⟩,
  to_fun_extend_right := λ n f, rfl }

namespace semilinear_function_family

instance {n : ℕ} : add_comm_group (semilinear_function_family K R n) :=
show add_comm_group (semilinear_function_type K R n),
by apply_instance

instance {n : ℕ} : module K (semilinear_function_family K R n) :=
show module K (semilinear_function_type K R n),
by apply_instance

end semilinear_function_family

/-
NOTE
From now on we assume R = K, since Lean doesn't seem to have linear_ordered_add_comm_group yet.
Without it, we can't get a linear_order on R without diamonds.
-/

variable {K}

lemma semilinear_function_family_eq_constraint ⦃n : ℕ⦄
  (f : (semilinear_function_family K K) (n + 1)) :
  ∃ (ic : isolated_constraint (semilinear_function_family K K) n),
    ic.to_set = {x | f x = 0} :=
begin
  rcases f with ⟨-, k, r, rfl⟩,
  by_cases h : k (fin.last n) = 0,
  { refine ⟨isolated_constraint.push_eq (mk (k ∘ fin.cast_succ) r) 0, _⟩,
    simp only [h, isolated_constraint.to_set, fin.sum_univ_cast_succ, fin.init, function.comp_app,
      function_family.extend_right_app, smul_eq_mul, coe_anon, add_zero, coe_mk, zero_mul],
    ext x,
    exact iff.rfl },
  { let c := k (fin.last n),
    refine ⟨isolated_constraint.eq (mk (-c⁻¹ • k ∘ fin.cast_succ) (-c⁻¹ * r)), _⟩,
    simp only [h, isolated_constraint.to_set, fin.sum_univ_cast_succ, fin.init, coe_mk, function.comp_app,
      function_family.extend_right_app, smul_eq_mul, pi.smul_apply, coe_anon],
    ext x,
    show _ = _ ↔ _ = _,
    simp only [neg_mul_eq_neg_mul_symm, finset.sum_neg_distrib, mul_assoc, ← finset.mul_sum],
    rw [← neg_add, ← mul_add, eq_neg_iff_add_eq_zero, ← mul_right_inj' h],
    simp only [h, mul_add, ne.def, not_false_iff, mul_zero, mul_inv_cancel_left'],
    rw [add_left_comm, add_assoc], refl }
end

lemma semilinear_function_family_lt_constraint ⦃n : ℕ⦄
  (f : (semilinear_function_family K K) (n + 1)) :
  ∃ (ic : isolated_constraint (semilinear_function_family K K) n),
    ic.to_set = {x | f x < 0} :=
begin
  rcases f with ⟨-, k, r, rfl⟩,
  by_cases h : k (fin.last n) = 0,
  { refine ⟨isolated_constraint.push_lt (mk (k ∘ fin.cast_succ) r) 0, _⟩,
    simp only [h, isolated_constraint.to_set, fin.sum_univ_cast_succ, fin.init, function.comp_app,
      function_family.extend_right_app, smul_eq_mul, coe_anon, add_zero, coe_mk, zero_mul],
    ext x,
    exact iff.rfl },
  { let c := k (fin.last n),
    obtain hc|hc : c < 0 ∨ 0 < c := lt_or_gt_of_ne h,
    { refine ⟨isolated_constraint.gt (mk (-c⁻¹ • k ∘ fin.cast_succ) (-c⁻¹ * r)), _⟩,
      rw [isolated_constraint.to_set],
      simp only [neg_mul_eq_neg_mul_symm, coe_mk, pi.neg_apply, function.comp_app,
        function_family.extend_right_app, finset.sum_neg_distrib, smul_eq_mul, neg_smul, pi.smul_apply,
        fin.sum_univ_cast_succ, fin.init, coe_anon],
      ext x,
      show _ < _ ↔ _ < _,
      simp only [neg_mul_eq_neg_mul_symm, finset.sum_neg_distrib, mul_assoc, ← finset.mul_sum],
      rw [← neg_add, ← mul_add, ← sub_lt_zero, sub_eq_add_neg, ← mul_lt_mul_left_of_neg hc],
      rw [mul_zero, ← neg_add, ← neg_mul_eq_mul_neg, mul_add, mul_inv_cancel_left' (ne_of_lt hc)],
      rw [neg_pos, add_right_comm], refl },
    { refine ⟨isolated_constraint.lt (mk (-c⁻¹ • k ∘ fin.cast_succ) (-c⁻¹ * r)), _⟩,
      rw [isolated_constraint.to_set],
      simp only [neg_mul_eq_neg_mul_symm, coe_mk, pi.neg_apply, function.comp_app,
        function_family.extend_right_app, finset.sum_neg_distrib, smul_eq_mul, neg_smul, pi.smul_apply,
        fin.sum_univ_cast_succ, fin.init, coe_anon],
      ext x,
      show _ < _ ↔ _ < _,
      simp only [neg_mul_eq_neg_mul_symm, finset.sum_neg_distrib, mul_assoc, ← finset.mul_sum],
      rw [← neg_add, ← mul_add, ← sub_lt_zero, sub_eq_add_neg, neg_neg, ← mul_lt_mul_left hc],
      simp only [mul_add, mul_inv_cancel_left', ne_of_gt hc, ne.def, not_false_iff, mul_zero],
      rw [add_left_comm, add_assoc], refl }, }
end

variables (K)

lemma semilinear_function_family_is_isolating :
  (semilinear_function_family K K).is_isolating :=
begin
  rintros n s h,
  cases h with f g f g,
  { obtain ⟨ic, H⟩ := semilinear_function_family_eq_constraint (f - g),
    use ic, rw H, ext, rw ← sub_eq_zero, exact iff.rfl },
  { obtain ⟨ic, H⟩ := semilinear_function_family_lt_constraint (f - g),
    use ic, rw H, ext, rw ← sub_lt_zero, exact iff.rfl }
end

end semilinear

variables (K' : Type u) [linear_ordered_field K']

instance discrete_linear_ordered_field.DUNLO : DUNLO K' :=
{ .. ‹linear_ordered_field K'› }

def semilinear : struc K' :=
struc_of_isolating' (semilinear_function_family_is_isolating K')

lemma semilinear_o_minimal : o_minimal (semilinear K') :=
by apply o_minimal_of_isolating

end o_minimal


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Stephen Morgan, Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.products.basic
import Mathlib.PostPort

universes u₁ u₂ u₃ v₁ v₂ v₃

namespace Mathlib

/-#
The associator functor `((C × D) × E) ⥤ (C × (D × E))` and its inverse form an equivalence.
-/

namespace category_theory.prod

/--
The associator functor `(C × D) × E ⥤ C × (D × E)`.
-/
@[simp] theorem associator_map (C : Type u₁) [category C] (D : Type u₂) [category D] (E : Type u₃) [category E] (_x : (C × D) × E) : ∀ (_x_1 : (C × D) × E) (f : _x ⟶ _x_1),
  functor.map (associator C D E) f = (prod.fst (prod.fst f), prod.snd (prod.fst f), prod.snd f) :=
  fun (_x_1 : (C × D) × E) (f : _x ⟶ _x_1) => Eq.refl (functor.map (associator C D E) f)

/--
The inverse associator functor `C × (D × E) ⥤ (C × D) × E `.
-/
@[simp] theorem inverse_associator_map (C : Type u₁) [category C] (D : Type u₂) [category D] (E : Type u₃) [category E] (_x : C × D × E) : ∀ (_x_1 : C × D × E) (f : _x ⟶ _x_1),
  functor.map (inverse_associator C D E) f = ((prod.fst f, prod.fst (prod.snd f)), prod.snd (prod.snd f)) :=
  fun (_x_1 : C × D × E) (f : _x ⟶ _x_1) => Eq.refl (functor.map (inverse_associator C D E) f)

/--
The equivalence of categories expressing associativity of products of categories.
-/
def associativity (C : Type u₁) [category C] (D : Type u₂) [category D] (E : Type u₃) [category E] : (C × D) × E ≌ C × D × E :=
  equivalence.mk (associator C D E) (inverse_associator C D E)
    (nat_iso.of_components (fun (X : (C × D) × E) => eq_to_iso sorry) sorry)
    (nat_iso.of_components (fun (X : C × D × E) => eq_to_iso sorry) sorry)

protected instance associator_is_equivalence (C : Type u₁) [category C] (D : Type u₂) [category D] (E : Type u₃) [category E] : is_equivalence (associator C D E) :=
  is_equivalence.of_equivalence (associativity C D E)

protected instance inverse_associator_is_equivalence (C : Type u₁) [category C] (D : Type u₂) [category D] (E : Type u₃) [category E] : is_equivalence (inverse_associator C D E) :=
  is_equivalence.of_equivalence_inverse (associativity C D E)


import data.sym2

structure graph :=
  (vertices : Type)
  (edges : Type)
  (endpoints : edges → sym2 vertices)

structure morphism (G : graph) (H : graph) :=
  (vertex_map : G.vertices → H.vertices)
  (edge_map : G.edges → H.edges)
  (compatability : H.endpoints ∘ edge_map = sym2.map vertex_map ∘ G.endpoints)

infix `↦` :50 := morphism

lemma compatability {G H K : graph} (α : G ↦ H) (β : H ↦ K) : K.endpoints ∘ β.edge_map ∘ α.edge_map = sym2.map (β.vertex_map ∘ α.vertex_map) ∘ G.endpoints :=
begin
  calc K.endpoints ∘ β.edge_map ∘ α.edge_map = (sym2.map β.vertex_map ∘ H.endpoints) ∘ α.edge_map : by rw ← β.compatability
                                         ... = sym2.map β.vertex_map ∘ (sym2.map α.vertex_map ∘ G.endpoints) : by rw ← α.compatability
                                         ... = (sym2.map β.vertex_map ∘ sym2.map α.vertex_map) ∘ G.endpoints : by refl
                                         ... = sym2.map (β.vertex_map ∘ α.vertex_map) ∘ G.endpoints : by rw ← sym2.map_comp,
end


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Stephen Morgan, Scott Morrison, Johannes Hölzl, Reid Barton
-/

import category_theory.category.Cat
import order.category.Preorder

/-!

# Preorders as categories

We install a category instance on any preorder. This is not to be confused with the category _of_
preorders, defined in `order/category/Preorder`.

We show that monotone functions between preorders correspond to functors of the associated
categories. Furthermore, galois connections correspond to adjoint functors.

## Main definitions

* `hom_of_le` and `le_of_hom` provide translations between inequalities in the preorder, and
  morphisms in the associated category.
* `monotone.functor` is the functor associated to a monotone function.
* `galois_connection.adjunction` is the adjunction associated to a galois connection.
* `Preorder_to_Cat` is the functor embedding the category of preorders into `Cat`.

-/

universes u v

namespace preorder

open category_theory

/--
The category structure coming from a preorder. There is a morphism `X ⟶ Y` if and only if `X ≤ Y`.

Because we don't allow morphisms to live in `Prop`,
we have to define `X ⟶ Y` as `ulift (plift (X ≤ Y))`.
See `category_theory.hom_of_le` and `category_theory.le_of_hom`.

See https://stacks.math.columbia.edu/tag/00D3.
-/
@[priority 100] -- see Note [lower instance priority]
instance small_category (α : Type u) [preorder α] : small_category α :=
{ hom  := λ U V, ulift (plift (U ≤ V)),
  id   := λ X, ⟨ ⟨ le_refl X ⟩ ⟩,
  comp := λ X Y Z f g, ⟨ ⟨ le_trans _ _ _ f.down.down g.down.down ⟩ ⟩ }

end preorder

namespace category_theory

open opposite

variables {X : Type u} [preorder X]

/--
Express an inequality as a morphism in the corresponding preorder category.
-/
def hom_of_le {x y : X} (h : x ≤ y) : x ⟶ y := ulift.up (plift.up h)

alias hom_of_le ← has_le.le.hom

@[simp] lemma hom_of_le_refl {x : X} : (le_refl x).hom = 𝟙 x := rfl
@[simp] lemma hom_of_le_comp {x y z : X} (h : x ≤ y) (k : y ≤ z) :
  h.hom ≫ k.hom = (h.trans k).hom := rfl

/--
Extract the underlying inequality from a morphism in a preorder category.
-/
lemma le_of_hom {x y : X} (h : x ⟶ y) : x ≤ y := h.down.down

alias le_of_hom ← quiver.hom.le

@[simp] lemma le_of_hom_hom_of_le {x y : X} (h : x ≤ y) : h.hom.le = h := rfl
@[simp] lemma hom_of_le_le_of_hom {x y : X} (h : x ⟶ y) : h.le.hom = h :=
by { cases h, cases h, refl, }

/-- Construct a morphism in the opposite of a preorder category from an inequality. -/
def op_hom_of_le {x y : Xᵒᵖ} (h : unop x ≤ unop y) : y ⟶ x := h.hom.op

lemma le_of_op_hom {x y : Xᵒᵖ} (h : x ⟶ y) : unop y ≤ unop x := h.unop.le

instance unique_to_top [order_top X] {x : X} : unique (x ⟶ ⊤) := by tidy
instance unique_from_bot [order_bot X] {x : X} : unique (⊥ ⟶ x) := by tidy

end category_theory

section

variables {X : Type u} {Y : Type v} [preorder X] [preorder Y]

/--
A monotone function between preorders induces a functor between the associated categories.
-/
def monotone.functor {f : X → Y} (h : monotone f) : X ⥤ Y :=
{ obj := f,
  map := λ x₁ x₂ g, (h g.le).hom }

@[simp] lemma monotone.functor_obj {f : X → Y} (h : monotone f) : h.functor.obj = f := rfl

/--
A galois connection between preorders induces an adjunction between the associated categories.
-/
def galois_connection.adjunction {l : X → Y} {u : Y → X} (gc : galois_connection l u) :
  gc.monotone_l.functor ⊣ gc.monotone_u.functor :=
category_theory.adjunction.mk_of_hom_equiv
{ hom_equiv := λ X Y, ⟨λ f, (gc.le_u f.le).hom, λ f, (gc.l_le f.le).hom, by tidy, by tidy⟩ }

end

namespace category_theory

section preorder

variables {X : Type u} {Y : Type v} [preorder X] [preorder Y]

/--
A functor between preorder categories is monotone.
-/
@[mono] lemma functor.monotone (f : X ⥤ Y) : monotone f.obj :=
λ x y hxy, (f.map hxy.hom).le

/--
An adjunction between preorder categories induces a galois connection.
-/
lemma adjunction.gc {L : X ⥤ Y} {R : Y ⥤ X} (adj : L ⊣ R) :
  galois_connection L.obj R.obj :=
λ x y, ⟨λ h, ((adj.hom_equiv x y).to_fun h.hom).le, λ h, ((adj.hom_equiv x y).inv_fun h.hom).le⟩

/--
The embedding of `Preorder` into `Cat`.
-/
@[simps]
def Preorder_to_Cat : Preorder.{u} ⥤ Cat :=
{ obj := λ X, Cat.of X.1,
  map := λ X Y f, f.monotone.functor,
  map_id' := λ X, begin apply category_theory.functor.ext, tidy end,
  map_comp' := λ X Y Z f g, begin apply category_theory.functor.ext, tidy end }

instance : faithful Preorder_to_Cat.{u} :=
{ map_injective' := λ X Y f g h, begin ext x, exact functor.congr_obj h x end }

instance : full Preorder_to_Cat.{u} :=
{ preimage := λ X Y f, ⟨f.obj, f.monotone⟩,
  witness' := λ X Y f, begin apply category_theory.functor.ext, tidy end }

end preorder

section partial_order

variables {X : Type u} {Y : Type v} [partial_order X] [partial_order Y]

lemma iso.to_eq {x y : X} (f : x ≅ y) : x = y := le_antisymm f.hom.le f.inv.le

/--
A categorical equivalence between partial orders is just an order isomorphism.
-/
def equivalence.to_order_iso (e : X ≌ Y) : X ≃o Y :=
{ to_fun := e.functor.obj,
  inv_fun := e.inverse.obj,
  left_inv := λ a, (e.unit_iso.app a).to_eq.symm,
  right_inv := λ b, (e.counit_iso.app b).to_eq,
  map_rel_iff' := λ a a',
    ⟨λ h, ((equivalence.unit e).app a ≫ e.inverse.map h.hom ≫ (equivalence.unit_inv e).app a').le,
     λ (h : a ≤ a'), (e.functor.map h.hom).le⟩, }

-- `@[simps]` on `equivalence.to_order_iso` produces lemmas that fail the `simp_nf` linter,
-- so we provide them by hand:
@[simp]

@[simp]
lemma equivalence.to_order_iso_symm_apply (e : X ≌ Y) (y : Y) :
  e.to_order_iso.symm y = e.inverse.obj y := rfl

end partial_order

end category_theory


/-
Copyright (c) 2020 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes
-/
import ring_theory.prime
import ring_theory.polynomial.content
/-!
# Eisenstein's criterion

A proof of a slight generalisation of Eisenstein's criterion for the irreducibility of
a polynomial over an integral domain.
-/

open polynomial ideal.quotient
variables {R : Type*} [integral_domain R]

namespace polynomial
namespace eisenstein_criterion_aux
/- Section for auxiliary lemmas used in the proof of `irreducible_of_eisenstein_criterion`-/

lemma map_eq_C_mul_X_pow_of_forall_coeff_mem {f : polynomial R} {P : ideal R}
  (hfP : ∀ (n : ℕ), ↑n < f.degree → f.coeff n ∈ P) (hf0 : f ≠ 0) :
  map (mk P) f = C ((mk P) f.leading_coeff) * X ^ f.nat_degree :=
polynomial.ext (λ n, begin
  rcases lt_trichotomy ↑n (degree f) with h | h | h,
  { erw [coeff_map, eq_zero_iff_mem.2 (hfP n h), coeff_C_mul, coeff_X_pow, if_neg, mul_zero],
    rintro rfl, exact not_lt_of_ge degree_le_nat_degree h },
  { have : nat_degree f = n, from nat_degree_eq_of_degree_eq_some h.symm,
    rw [coeff_C_mul, coeff_X_pow, if_pos this.symm, mul_one, leading_coeff, this, coeff_map] },
  { rw [coeff_eq_zero_of_degree_lt, coeff_eq_zero_of_degree_lt],
    { refine lt_of_le_of_lt (degree_C_mul_X_pow_le _ _) _,
      rwa ← degree_eq_nat_degree hf0 },
    { exact lt_of_le_of_lt (degree_map_le _) h } }
end)

lemma le_nat_degree_of_map_eq_mul_X_pow {n : ℕ}
  {P : ideal R} (hP : P.is_prime) {q : polynomial R} {c : polynomial P.quotient}
  (hq : map (mk P) q = c * X ^ n) (hc0 : c.degree = 0) : n ≤ q.nat_degree :=
with_bot.coe_le_coe.1
  (calc ↑n = degree (q.map (mk P)) :
      by rw [hq, degree_mul, hc0, zero_add, degree_pow, degree_X, nsmul_one, nat.cast_with_bot]
      ... ≤ degree q : degree_map_le _
      ... ≤ nat_degree q : degree_le_nat_degree)

lemma eval_zero_mem_ideal_of_eq_mul_X_pow {n : ℕ} {P : ideal R}
  {q : polynomial R} {c : polynomial P.quotient}
  (hq : map (mk P) q = c * X ^ n) (hn0 : 0 < n) : eval 0 q ∈ P :=
by rw [← coeff_zero_eq_eval_zero, ← eq_zero_iff_mem, ← coeff_map,
    coeff_zero_eq_eval_zero, hq, eval_mul, eval_pow, eval_X, zero_pow hn0, mul_zero]

lemma is_unit_of_nat_degree_eq_zero_of_forall_dvd_is_unit {p q : polynomial R}
  (hu : ∀ (x : R), C x ∣ p * q → is_unit x) (hpm : p.nat_degree = 0) :
  is_unit p :=
begin
  rw [eq_C_of_degree_le_zero (nat_degree_eq_zero_iff_degree_le_zero.1 hpm), is_unit_C],
  refine hu _ _,
  rw [← eq_C_of_degree_le_zero (nat_degree_eq_zero_iff_degree_le_zero.1 hpm)],
  exact dvd_mul_right _ _
end

end eisenstein_criterion_aux

open eisenstein_criterion_aux

/-- If `f` is a non constant polynomial with coefficients in `R`, and `P` is a prime ideal in `R`,
then if every coefficient in `R` except the leading coefficient is in `P`, and
the trailing coefficient is not in `P^2` and no non units in `R` divide `f`, then `f` is
irreducible. -/
theorem irreducible_of_eisenstein_criterion {f : polynomial R} {P : ideal R} (hP : P.is_prime)
  (hfl : f.leading_coeff ∉ P)
  (hfP : ∀ n : ℕ, ↑n < degree f → f.coeff n ∈ P)
  (hfd0 : 0 < degree f) (h0 : f.coeff 0 ∉ P^2)
  (hu : f.is_primitive) : irreducible f :=
have hf0 : f ≠ 0, from λ _, by simp only [*, not_true, submodule.zero_mem, coeff_zero] at *,
have hf : f.map (mk P) = C (mk P (leading_coeff f)) * X ^ nat_degree f,
  from map_eq_C_mul_X_pow_of_forall_coeff_mem hfP hf0,
have hfd0 : 0 < f.nat_degree, from with_bot.coe_lt_coe.1
  (lt_of_lt_of_le hfd0 degree_le_nat_degree),
⟨mt degree_eq_zero_of_is_unit (λ h, by simp only [*, lt_irrefl] at *),
begin
  rintros p q rfl,
  rw [map_mul] at hf,
  rcases mul_eq_mul_prime_pow (show prime (X : polynomial (ideal.quotient P)),
    from prime_of_degree_eq_one_of_monic degree_X monic_X) hf with
      ⟨m, n, b, c, hmnd, hbc, hp, hq⟩,
  have hmn : 0 < m → 0 < n → false,
  { assume hm0 hn0,
    refine h0 _,
    rw [coeff_zero_eq_eval_zero, eval_mul, sq],
    exact ideal.mul_mem_mul
      (eval_zero_mem_ideal_of_eq_mul_X_pow hp hm0)
      (eval_zero_mem_ideal_of_eq_mul_X_pow hq hn0) },
  have hpql0 : (mk P) (p * q).leading_coeff ≠ 0,
  { rwa [ne.def, eq_zero_iff_mem] },
  have hp0 : p ≠ 0, from λ h, by simp only [*, zero_mul, eq_self_iff_true, not_true, ne.def] at *,
  have hq0 : q ≠ 0, from λ h, by simp only [*, eq_self_iff_true, not_true, ne.def, mul_zero] at *,
  have hbc0 : degree b = 0 ∧ degree c = 0,
  { apply_fun degree at hbc,
    rwa [degree_C hpql0, degree_mul, eq_comm, nat.with_bot.add_eq_zero_iff] at hbc },
  have hmp : m ≤ nat_degree p,
    from le_nat_degree_of_map_eq_mul_X_pow hP hp hbc0.1,
  have hnq : n ≤ nat_degree q,
    from le_nat_degree_of_map_eq_mul_X_pow hP hq hbc0.2,
  have hpmqn : p.nat_degree = m ∧ q.nat_degree = n,
  { rw [nat_degree_mul hp0 hq0] at hmnd,
    clear_except hmnd hmp hnq,
    contrapose hmnd,
    apply ne_of_lt,
    rw not_and_distrib at hmnd,
    cases hmnd,
    { exact add_lt_add_of_lt_of_le (lt_of_le_of_ne hmp (ne.symm hmnd)) hnq },
    { exact add_lt_add_of_le_of_lt hmp (lt_of_le_of_ne hnq (ne.symm hmnd)) } },
  obtain rfl | rfl : m = 0 ∨ n = 0,
  { rwa [pos_iff_ne_zero, pos_iff_ne_zero, imp_false, not_not,
      ← or_iff_not_imp_left] at hmn },
  { exact or.inl (is_unit_of_nat_degree_eq_zero_of_forall_dvd_is_unit hu hpmqn.1) },
  { exact or.inr (is_unit_of_nat_degree_eq_zero_of_forall_dvd_is_unit
      (by simpa only [mul_comm] using hu) hpmqn.2) }
end⟩

end polynomial


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta, Scott Morrison
-/
import category_theory.subobject.mono_over
import category_theory.skeletal

/-!
# Subobjects

We define `subobject X` as the quotient (by isomorphisms) of
`mono_over X := {f : over X // mono f.hom}`.

Here `mono_over X` is a thin category (a pair of objects has at most one morphism between them),
so we can think of it as a preorder. However as it is not skeletal, it is not a partial order.

There is a coercion from `subobject X` back to the ambient category `C`
(using choice to pick a representative), and for `P : subobject X`,
`P.arrow : (P : C) ⟶ X` is the inclusion morphism.

We provide
* `def pullback [has_pullbacks C] (f : X ⟶ Y) : subobject Y ⥤ subobject X`
* `def map (f : X ⟶ Y) [mono f] : subobject X ⥤ subobject Y`
* `def «exists» [has_images C] (f : X ⟶ Y) : subobject X ⥤ subobject Y`
and prove their basic properties and relationships.
These are all easy consequences of the earlier development
of the corresponding functors for `mono_over`.

The subobjects of `X` form a preorder making them into a category. We have `X ≤ Y` if and only if
`X.arrow` factors through `Y.arrow`: see `of_le`/`of_le_mk`/`of_mk_le`/`of_mk_le_mk` and
`le_of_comm`. Similarly, to show that two subobjects are equal, we can supply an isomorphism between
the underlying objects that commutes with the arrows (`eq_of_comm`).

See also

* `category_theory.subobject.factor_thru` :
  an API describing factorization of morphisms through subobjects.
* `category_theory.subobject.lattice` :
  the lattice structures on subobjects.

## Notes

This development originally appeared in Bhavik Mehta's "Topos theory for Lean" repository,
and was ported to mathlib by Scott Morrison.

### Implementation note

Currently we describe `pullback`, `map`, etc., as functors.
It may be better to just say that they are monotone functions,
and even avoid using categorical language entirely when describing `subobject X`.
(It's worth keeping this in mind in future use; it should be a relatively easy change here
if it looks preferable.)

### Relation to pseudoelements

There is a separate development of pseudoelements in `category_theory.abelian.pseudoelements`,
as a quotient (but not by isomorphism) of `over X`.

When a morphism `f` has an image, the image represents the same pseudoelement.
In a category with images `pseudoelements X` could be constructed as a quotient of `mono_over X`.
In fact, in an abelian category (I'm not sure in what generality beyond that),
`pseudoelements X` agrees with `subobject X`, but we haven't developed this in mathlib yet.

-/

universes v₁ v₂ u₁ u₂

noncomputable theory
namespace category_theory

open category_theory category_theory.category category_theory.limits

variables {C : Type u₁} [category.{v₁} C] {X Y Z : C}
variables {D : Type u₂} [category.{v₂} D]

/-!
We now construct the subobject lattice for `X : C`,
as the quotient by isomorphisms of `mono_over X`.

Since `mono_over X` is a thin category, we use `thin_skeleton` to take the quotient.

Essentially all the structure defined above on `mono_over X` descends to `subobject X`,
with morphisms becoming inequalities, and isomorphisms becoming equations.
-/

/--
The category of subobjects of `X : C`, defined as isomorphism classes of monomorphisms into `X`.
-/
@[derive [partial_order, category]]
def subobject (X : C) := thin_skeleton (mono_over X)

namespace subobject

/-- Convenience constructor for a subobject. -/
abbreviation mk {X A : C} (f : A ⟶ X) [mono f] : subobject X :=
(to_thin_skeleton _).obj (mono_over.mk' f)

/--
Use choice to pick a representative `mono_over X` for each `subobject X`.
-/
noncomputable
def representative {X : C} : subobject X ⥤ mono_over X :=
thin_skeleton.from_thin_skeleton _

/--
Starting with `A : mono_over X`, we can take its equivalence class in `subobject X`
then pick an arbitrary representative using `representative.obj`.
This is isomorphic (in `mono_over X`) to the original `A`.
-/
noncomputable
def representative_iso {X : C} (A : mono_over X) :
  representative.obj ((to_thin_skeleton _).obj A) ≅ A :=
(thin_skeleton.from_thin_skeleton _).as_equivalence.counit_iso.app A

/--
Use choice to pick a representative underlying object in `C` for any `subobject X`.

Prefer to use the coercion `P : C` rather than explicitly writing `underlying.obj P`.
-/
noncomputable
def underlying {X : C} : subobject X ⥤ C :=
representative ⋙ mono_over.forget _ ⋙ over.forget _

instance : has_coe (subobject X) C :=
{ coe := λ Y, underlying.obj Y, }

@[simp] lemma underlying_as_coe {X : C} (P : subobject X) : underlying.obj P = P := rfl

/--
If we construct a `subobject Y` from an explicit `f : X ⟶ Y` with `[mono f]`,
then pick an arbitrary choice of underlying object `(subobject.mk f : C)` back in `C`,
it is isomorphic (in `C`) to the original `X`.
-/
noncomputable
def underlying_iso {X Y : C} (f : X ⟶ Y) [mono f] : (subobject.mk f : C) ≅ X :=
(mono_over.forget _ ⋙ over.forget _).map_iso (representative_iso (mono_over.mk' f))

/--
The morphism in `C` from the arbitrarily chosen underlying object to the ambient object.
-/
noncomputable
def arrow {X : C} (Y : subobject X) : (Y : C) ⟶ X :=
(representative.obj Y).val.hom

instance arrow_mono {X : C} (Y : subobject X) : mono (Y.arrow) :=
(representative.obj Y).property

@[simp]
lemma arrow_congr {A : C} (X Y : subobject A) (h : X = Y) :
  eq_to_hom (congr_arg (λ X : subobject A, (X : C)) h) ≫ Y.arrow = X.arrow :=
by { induction h, simp, }

@[simp]
lemma representative_coe (Y : subobject X) :
  (representative.obj Y : C) = (Y : C) :=
rfl

@[simp]
lemma representative_arrow (Y : subobject X) :
  (representative.obj Y).arrow = Y.arrow :=
rfl

@[simp, reassoc]
lemma underlying_arrow {X : C} {Y Z : subobject X} (f : Y ⟶ Z) :
  underlying.map f ≫ arrow Z = arrow Y :=
over.w (representative.map f)

@[simp, reassoc]
lemma underlying_iso_arrow {X Y : C} (f : X ⟶ Y) [mono f] :
  (underlying_iso f).inv ≫ (subobject.mk f).arrow = f :=
over.w _

@[simp, reassoc]
lemma underlying_iso_hom_comp_eq_mk {X Y : C} (f : X ⟶ Y) [mono f] :
  (underlying_iso f).hom ≫ f = (mk f).arrow :=
(iso.eq_inv_comp _).1 (underlying_iso_arrow f).symm

/-- Two morphisms into a subobject are equal exactly if
the morphisms into the ambient object are equal -/
@[ext]
lemma eq_of_comp_arrow_eq {X Y : C} {P : subobject Y}
  {f g : X ⟶ P} (h : f ≫ P.arrow = g ≫ P.arrow) : f = g :=
(cancel_mono P.arrow).mp h

lemma mk_le_mk_of_comm {B A₁ A₂ : C} {f₁ : A₁ ⟶ B} {f₂ : A₂ ⟶ B} [mono f₁] [mono f₂] (g : A₁ ⟶ A₂)
  (w : g ≫ f₂ = f₁) : mk f₁ ≤ mk f₂ :=
⟨mono_over.hom_mk _ w⟩

@[simp] lemma mk_arrow (P : subobject X) : mk P.arrow = P :=
quotient.induction_on' P $ λ Q,
begin
  obtain ⟨e⟩ := @quotient.mk_out' _ (is_isomorphic_setoid _) Q,
  refine quotient.sound' ⟨mono_over.iso_mk _ _ ≪≫ e⟩;
  tidy
end

lemma le_of_comm {B : C} {X Y : subobject B} (f : (X : C) ⟶ (Y : C)) (w : f ≫ Y.arrow = X.arrow) :
  X ≤ Y :=
by convert mk_le_mk_of_comm _ w; simp

lemma le_mk_of_comm {B A : C} {X : subobject B} {f : A ⟶ B} [mono f] (g : (X : C) ⟶ A)
  (w : g ≫ f = X.arrow) : X ≤ mk f :=
le_of_comm (g ≫ (underlying_iso f).inv) $ by simp [w]

lemma mk_le_of_comm {B A : C} {X : subobject B} {f : A ⟶ B} [mono f] (g : A ⟶ (X : C))
  (w : g ≫ X.arrow = f) : mk f ≤ X :=
le_of_comm ((underlying_iso f).hom ≫ g) $ by simp [w]

/-- To show that two subobjects are equal, it suffices to exhibit an isomorphism commuting with
    the arrows. -/
@[ext] lemma eq_of_comm {B : C} {X Y : subobject B} (f : (X : C) ≅ (Y : C))
  (w : f.hom ≫ Y.arrow = X.arrow) : X = Y :=
le_antisymm (le_of_comm f.hom w) $ le_of_comm f.inv $ f.inv_comp_eq.2 w.symm

/-- To show that two subobjects are equal, it suffices to exhibit an isomorphism commuting with
    the arrows. -/
@[ext] lemma eq_mk_of_comm {B A : C} {X : subobject B} (f : A ⟶ B) [mono f] (i : (X : C) ≅ A)
  (w : i.hom ≫ f = X.arrow) : X = mk f :=
eq_of_comm (i.trans (underlying_iso f).symm) $ by simp [w]

/-- To show that two subobjects are equal, it suffices to exhibit an isomorphism commuting with
    the arrows. -/
@[ext] lemma mk_eq_of_comm {B A : C} {X : subobject B} (f : A ⟶ B) [mono f] (i : A ≅ (X : C))
  (w : i.hom ≫ X.arrow = f) : mk f = X :=
eq.symm $ eq_mk_of_comm _ i.symm $ by rw [iso.symm_hom, iso.inv_comp_eq, w]

/-- To show that two subobjects are equal, it suffices to exhibit an isomorphism commuting with
    the arrows. -/
@[ext] lemma mk_eq_mk_of_comm {B A₁ A₂ : C} (f : A₁ ⟶ B) (g : A₂ ⟶ B) [mono f] [mono g]
  (i : A₁ ≅ A₂) (w : i.hom ≫ g = f) : mk f = mk g :=
eq_mk_of_comm _ ((underlying_iso f).trans i) $ by simp [w]

/-- An inequality of subobjects is witnessed by some morphism between the corresponding objects. -/
-- We make `X` and `Y` explicit arguments here so that when `of_le` appears in goal statements
-- it is possible to see its source and target
-- (`h` will just display as `_`, because it is in `Prop`).
def of_le {B : C} (X Y : subobject B) (h : X ≤ Y) : (X : C) ⟶ (Y : C) :=
underlying.map $ hom_of_le h

@[simp, reassoc] lemma of_le_arrow {B : C} {X Y : subobject B} (h : X ≤ Y) :
  of_le X Y h ≫ Y.arrow = X.arrow :=
underlying_arrow _

/-- An inequality of subobjects is witnessed by some morphism between the corresponding objects. -/
def of_le_mk {B A : C} (X : subobject B) (f : A ⟶ B) [mono f] (h : X ≤ mk f) : (X : C) ⟶ A :=
of_le X (mk f) h ≫ (underlying_iso f).hom

@[simp] lemma of_le_mk_comp {B A : C} {X : subobject B} {f : A ⟶ B} [mono f] (h : X ≤ mk f) :
  of_le_mk X f h ≫ f = X.arrow :=
by simp [of_le_mk]

/-- An inequality of subobjects is witnessed by some morphism between the corresponding objects. -/
def of_mk_le {B A : C} (f : A ⟶ B) [mono f] (X : subobject B) (h : mk f ≤ X) : A ⟶ (X : C) :=
(underlying_iso f).inv ≫ of_le (mk f) X h

@[simp] lemma of_mk_le_arrow {B A : C} {f : A ⟶ B} [mono f] {X : subobject B} (h : mk f ≤ X) :
  of_mk_le f X h ≫ X.arrow = f :=
by simp [of_mk_le]

/-- An inequality of subobjects is witnessed by some morphism between the corresponding objects. -/
def of_mk_le_mk {B A₁ A₂ : C} (f : A₁ ⟶ B) (g : A₂ ⟶ B) [mono f] [mono g] (h : mk f ≤ mk g) :
  A₁ ⟶ A₂ :=
(underlying_iso f).inv ≫ of_le (mk f) (mk g) h ≫ (underlying_iso g).hom

@[simp] lemma of_mk_le_mk_comp {B A₁ A₂ : C} {f : A₁ ⟶ B} {g : A₂ ⟶ B} [mono f] [mono g]
  (h : mk f ≤ mk g) : of_mk_le_mk f g h ≫ g = f :=
by simp [of_mk_le_mk]

@[simp, reassoc] lemma of_le_comp_of_le {B : C} (X Y Z : subobject B) (h₁ : X ≤ Y) (h₂ : Y ≤ Z) :
  of_le X Y h₁ ≫ of_le Y Z h₂ = of_le X Z (h₁.trans h₂) :=
by simp [of_le, ←functor.map_comp underlying]

@[simp, reassoc] lemma of_le_comp_of_le_mk {B A : C} (X Y : subobject B) (f : A ⟶ B) [mono f]
  (h₁ : X ≤ Y) (h₂ : Y ≤ mk f) : of_le X Y h₁ ≫ of_le_mk Y f h₂ = of_le_mk X f (h₁.trans h₂) :=
by simp [of_mk_le, of_le_mk, of_le, ←functor.map_comp_assoc underlying]

@[simp, reassoc] lemma of_le_mk_comp_of_mk_le {B A : C} (X : subobject B) (f : A ⟶ B) [mono f]
  (Y : subobject B) (h₁ : X ≤ mk f) (h₂ : mk f ≤ Y) :
  of_le_mk X f h₁ ≫ of_mk_le f Y h₂ = of_le X Y (h₁.trans h₂) :=
by simp [of_mk_le, of_le_mk, of_le, ←functor.map_comp underlying]

@[simp, reassoc] lemma of_le_mk_comp_of_mk_le_mk {B A₁ A₂ : C} (X : subobject B) (f : A₁ ⟶ B)
  [mono f] (g : A₂ ⟶ B) [mono g] (h₁ : X ≤ mk f) (h₂ : mk f ≤ mk g) :
  of_le_mk X f h₁ ≫ of_mk_le_mk f g h₂ = of_le_mk X g (h₁.trans h₂) :=
by simp [of_mk_le, of_le_mk, of_le, of_mk_le_mk, ←functor.map_comp_assoc underlying]

@[simp, reassoc] lemma of_mk_le_comp_of_le {B A₁ : C} (f : A₁ ⟶ B) [mono f] (X Y : subobject B)
  (h₁ : mk f ≤ X) (h₂ : X ≤ Y) :
  of_mk_le f X h₁ ≫ of_le X Y h₂ = of_mk_le f Y (h₁.trans h₂) :=
by simp [of_mk_le, of_le_mk, of_le, of_mk_le_mk, ←functor.map_comp underlying]

@[simp, reassoc] lemma of_mk_le_comp_of_le_mk {B A₁ A₂ : C} (f : A₁ ⟶ B) [mono f] (X : subobject B)
  (g : A₂ ⟶ B) [mono g] (h₁ : mk f ≤ X) (h₂ : X ≤ mk g) :
  of_mk_le f X h₁ ≫ of_le_mk X g h₂ = of_mk_le_mk f g (h₁.trans h₂) :=
by simp [of_mk_le, of_le_mk, of_le, of_mk_le_mk, ←functor.map_comp_assoc underlying]

@[simp, reassoc] lemma of_mk_le_mk_comp_of_mk_le {B A₁ A₂ : C} (f : A₁ ⟶ B) [mono f] (g : A₂ ⟶ B)
  [mono g] (X : subobject B) (h₁ : mk f ≤ mk g) (h₂ : mk g ≤ X) :
  of_mk_le_mk f g h₁ ≫ of_mk_le g X h₂ = of_mk_le f X (h₁.trans h₂) :=
by simp [of_mk_le, of_le_mk, of_le, of_mk_le_mk, ←functor.map_comp underlying]

@[simp, reassoc] lemma of_mk_le_mk_comp_of_mk_le_mk {B A₁ A₂ A₃ : C} (f : A₁ ⟶ B) [mono f]
  (g : A₂ ⟶ B) [mono g] (h : A₃ ⟶ B) [mono h] (h₁ : mk f ≤ mk g) (h₂ : mk g ≤ mk h) :
  of_mk_le_mk f g h₁ ≫ of_mk_le_mk g h h₂ = of_mk_le_mk f h (h₁.trans h₂) :=
by simp [of_mk_le, of_le_mk, of_le, of_mk_le_mk, ←functor.map_comp_assoc underlying]

@[simp] lemma of_le_refl {B : C} (X : subobject B) :
  of_le X X (le_refl _) = 𝟙 _ :=
by { apply (cancel_mono X.arrow).mp, simp }

@[simp] lemma of_mk_le_mk_refl {B A₁ : C} (f : A₁ ⟶ B) [mono f] :
  of_mk_le_mk f f (le_refl _) = 𝟙 _ :=
by { apply (cancel_mono f).mp, simp }

/-- An equality of subobjects gives an isomorphism of the corresponding objects.
(One could use `underlying.map_iso (eq_to_iso h))` here, but this is more readable.) -/
-- As with `of_le`, we have `X` and `Y` as explicit arguments for readability.
@[simps]
def iso_of_eq {B : C} (X Y : subobject B) (h : X = Y) : (X : C) ≅ (Y : C) :=
{ hom := of_le _ _ h.le,
  inv := of_le _ _ h.ge, }

/-- An equality of subobjects gives an isomorphism of the corresponding objects. -/
@[simps]
def iso_of_eq_mk {B A : C} (X : subobject B) (f : A ⟶ B) [mono f] (h : X = mk f) : (X : C) ≅ A :=
{ hom := of_le_mk X f h.le,
  inv := of_mk_le f X h.ge }

/-- An equality of subobjects gives an isomorphism of the corresponding objects. -/
@[simps]
def iso_of_mk_eq {B A : C} (f : A ⟶ B) [mono f] (X : subobject B) (h : mk f = X) : A ≅ (X : C) :=
{ hom := of_mk_le f X h.le,
  inv := of_le_mk X f h.ge, }

/-- An equality of subobjects gives an isomorphism of the corresponding objects. -/
@[simps]
def iso_of_mk_eq_mk {B A₁ A₂ : C} (f : A₁ ⟶ B) (g : A₂ ⟶ B) [mono f] [mono g] (h : mk f = mk g) :
  A₁ ≅ A₂ :=
{ hom := of_mk_le_mk f g h.le,
  inv := of_mk_le_mk g f h.ge, }

end subobject

open category_theory.limits

namespace subobject

/-- Any functor `mono_over X ⥤ mono_over Y` descends to a functor
`subobject X ⥤ subobject Y`, because `mono_over Y` is thin. -/
def lower {Y : D} (F : mono_over X ⥤ mono_over Y) : subobject X ⥤ subobject Y :=
thin_skeleton.map F

/-- Isomorphic functors become equal when lowered to `subobject`.
(It's not as evil as usual to talk about equality between functors
because the categories are thin and skeletal.) -/
lemma lower_iso (F₁ F₂ : mono_over X ⥤ mono_over Y) (h : F₁ ≅ F₂) :
  lower F₁ = lower F₂ :=
thin_skeleton.map_iso_eq h

/-- A ternary version of `subobject.lower`. -/
def lower₂ (F : mono_over X ⥤ mono_over Y ⥤ mono_over Z) :
  subobject X ⥤ subobject Y ⥤ subobject Z :=
thin_skeleton.map₂ F

@[simp]

/-- An adjunction between `mono_over A` and `mono_over B` gives an adjunction
between `subobject A` and `subobject B`. -/
def lower_adjunction {A : C} {B : D}
  {L : mono_over A ⥤ mono_over B} {R : mono_over B ⥤ mono_over A} (h : L ⊣ R) :
  lower L ⊣ lower R :=
thin_skeleton.lower_adjunction _ _ h

/-- An equivalence between `mono_over A` and `mono_over B` gives an equivalence
between `subobject A` and `subobject B`. -/
@[simps]
def lower_equivalence {A : C} {B : D} (e : mono_over A ≌ mono_over B) : subobject A ≌ subobject B :=
{ functor := lower e.functor,
  inverse := lower e.inverse,
  unit_iso :=
  begin
    apply eq_to_iso,
    convert thin_skeleton.map_iso_eq e.unit_iso,
    { exact thin_skeleton.map_id_eq.symm },
    { exact (thin_skeleton.map_comp_eq _ _).symm },
  end,
  counit_iso :=
  begin
    apply eq_to_iso,
    convert thin_skeleton.map_iso_eq e.counit_iso,
    { exact (thin_skeleton.map_comp_eq _ _).symm },
    { exact thin_skeleton.map_id_eq.symm },
  end }

section pullback
variables [has_pullbacks C]

/-- When `C` has pullbacks, a morphism `f : X ⟶ Y` induces a functor `subobject Y ⥤ subobject X`,
by pulling back a monomorphism along `f`. -/
def pullback (f : X ⟶ Y) : subobject Y ⥤ subobject X :=
lower (mono_over.pullback f)

lemma pullback_id (x : subobject X) : (pullback (𝟙 X)).obj x = x :=
begin
  apply quotient.induction_on' x,
  intro f,
  apply quotient.sound,
  exact ⟨mono_over.pullback_id.app f⟩,
end

lemma pullback_comp (f : X ⟶ Y) (g : Y ⟶ Z) (x : subobject Z) :
  (pullback (f ≫ g)).obj x = (pullback f).obj ((pullback g).obj x) :=
begin
  apply quotient.induction_on' x,
  intro t,
  apply quotient.sound,
  refine ⟨(mono_over.pullback_comp _ _).app t⟩,
end

instance (f : X ⟶ Y) : faithful (pullback f) := {}

end pullback

section map

/--
We can map subobjects of `X` to subobjects of `Y`
by post-composition with a monomorphism `f : X ⟶ Y`.
-/
def map (f : X ⟶ Y) [mono f] : subobject X ⥤ subobject Y :=
lower (mono_over.map f)

lemma map_id (x : subobject X) : (map (𝟙 X)).obj x = x :=
begin
  apply quotient.induction_on' x,
  intro f,
  apply quotient.sound,
  exact ⟨mono_over.map_id.app f⟩,
end

lemma map_comp (f : X ⟶ Y) (g : Y ⟶ Z) [mono f] [mono g] (x : subobject X) :
  (map (f ≫ g)).obj x = (map g).obj ((map f).obj x) :=
begin
  apply quotient.induction_on' x,
  intro t,
  apply quotient.sound,
  refine ⟨(mono_over.map_comp _ _).app t⟩,
end

/-- Isomorphic objects have equivalent subobject lattices. -/
def map_iso {A B : C} (e : A ≅ B) : subobject A ≌ subobject B :=
lower_equivalence (mono_over.map_iso e)

/-- In fact, there's a type level bijection between the subobjects of isomorphic objects,
which preserves the order. -/
-- @[simps] here generates a lemma `map_iso_to_order_iso_to_equiv_symm_apply`
-- whose left hand side is not in simp normal form.
def map_iso_to_order_iso (e : X ≅ Y) : subobject X ≃o subobject Y :=
{ to_fun := (map e.hom).obj,
  inv_fun := (map e.inv).obj,
  left_inv := λ g, by simp_rw [← map_comp, e.hom_inv_id, map_id],
  right_inv := λ g, by simp_rw [← map_comp, e.inv_hom_id, map_id],
  map_rel_iff' := λ A B, begin
    dsimp, fsplit,
    { intro h,
      apply_fun (map e.inv).obj at h,
      simp_rw [← map_comp, e.hom_inv_id, map_id] at h,
      exact h, },
    { intro h,
      apply_fun (map e.hom).obj at h,
      exact h, },
  end }

@[simp] lemma map_iso_to_order_iso_apply (e : X ≅ Y) (P : subobject X) :
  map_iso_to_order_iso e P = (map e.hom).obj P :=
rfl

@[simp] lemma map_iso_to_order_iso_symm_apply (e : X ≅ Y) (Q : subobject Y) :
  (map_iso_to_order_iso e).symm Q = (map e.inv).obj Q :=
rfl

/-- `map f : subobject X ⥤ subobject Y` is
the left adjoint of `pullback f : subobject Y ⥤ subobject X`. -/
def map_pullback_adj [has_pullbacks C] (f : X ⟶ Y) [mono f] : map f ⊣ pullback f :=
lower_adjunction (mono_over.map_pullback_adj f)

@[simp]
lemma pullback_map_self [has_pullbacks C] (f : X ⟶ Y) [mono f] (g : subobject X) :
  (pullback f).obj ((map f).obj g) = g :=
begin
  revert g,
  apply quotient.ind,
  intro g',
  apply quotient.sound,
  exact ⟨(mono_over.pullback_map_self f).app _⟩,
end

lemma map_pullback [has_pullbacks C]
  {X Y Z W : C} {f : X ⟶ Y} {g : X ⟶ Z} {h : Y ⟶ W} {k : Z ⟶ W} [mono h] [mono g]
  (comm : f ≫ h = g ≫ k) (t : is_limit (pullback_cone.mk f g comm)) (p : subobject Y) :
  (map g).obj ((pullback f).obj p) = (pullback k).obj ((map h).obj p) :=
begin
  revert p,
  apply quotient.ind',
  intro a,
  apply quotient.sound,
  apply thin_skeleton.equiv_of_both_ways,
  { refine mono_over.hom_mk (pullback.lift pullback.fst _ _) (pullback.lift_snd _ _ _),
    change _ ≫ a.arrow ≫ h = (pullback.snd ≫ g) ≫ _,
    rw [assoc, ← comm, pullback.condition_assoc] },
  { refine mono_over.hom_mk (pullback.lift pullback.fst
                        (pullback_cone.is_limit.lift' t (pullback.fst ≫ a.arrow) pullback.snd _).1
                        (pullback_cone.is_limit.lift' _ _ _ _).2.1.symm) _,
    { rw [← pullback.condition, assoc], refl },
    { dsimp, rw [pullback.lift_snd_assoc],
      apply (pullback_cone.is_limit.lift' _ _ _ _).2.2 } }
end

end map

section «exists»
variables [has_images C]

/--
The functor from subobjects of `X` to subobjects of `Y` given by
sending the subobject `S` to its "image" under `f`, usually denoted $\exists_f$.
For instance, when `C` is the category of types,
viewing `subobject X` as `set X` this is just `set.image f`.

This functor is left adjoint to the `pullback f` functor (shown in `exists_pullback_adj`)
provided both are defined, and generalises the `map f` functor, again provided it is defined.
-/
def «exists» (f : X ⟶ Y) : subobject X ⥤ subobject Y :=
lower (mono_over.exists f)

/--
When `f : X ⟶ Y` is a monomorphism, `exists f` agrees with `map f`.
-/
lemma exists_iso_map (f : X ⟶ Y) [mono f] : «exists» f = map f :=
lower_iso _ _ (mono_over.exists_iso_map f)

/--
`exists f : subobject X ⥤ subobject Y` is
left adjoint to `pullback f : subobject Y ⥤ subobject X`.
-/
def exists_pullback_adj (f : X ⟶ Y) [has_pullbacks C] : «exists» f ⊣ pullback f :=
lower_adjunction (mono_over.exists_pullback_adj f)

end  «exists»

end subobject

end category_theory


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

! This file was ported from Lean 3 source module tactic.omega.int.form
! leanprover-community/mathlib commit 3d7987cda72abc473c7cdbbb075170e9ac620042
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Tactic.Omega.Int.Preterm

/-
Linear integer arithmetic formulas in pre-normalized form.
-/
namespace Omega

namespace Int

/-- Intermediate shadow syntax for LNA formulas that includes unreified exprs -/
unsafe inductive exprform
  | Eq : exprterm → exprterm → exprform
  | le : exprterm → exprterm → exprform
  | Not : exprform → exprform
  | Or : exprform → exprform → exprform
  | And : exprform → exprform → exprform
#align omega.int.exprform omega.int.exprform

/-- Intermediate shadow syntax for LIA formulas that includes non-canonical terms -/
inductive Preform
  | Eq : Preterm → Preterm → preform
  | le : Preterm → Preterm → preform
  | Not : preform → preform
  | Or : preform → preform → preform
  | And : preform → preform → preform
  deriving has_reflect, Inhabited
#align omega.int.preform Omega.Int.Preform

-- mathport name: preform.eq
scoped notation x " =* " y => Omega.Int.Preform.eq x y

-- mathport name: preform.le
scoped notation x " ≤* " y => Omega.Int.Preform.le x y

-- mathport name: preform.not
scoped notation "¬* " p => Omega.Int.Preform.not p

-- mathport name: preform.or
scoped notation p " ∨* " q => Omega.Int.Preform.or p q

-- mathport name: preform.and
scoped notation p " ∧* " q => Omega.Int.Preform.and p q

namespace Preform

/-- Evaluate a preform into prop using the valuation v. -/
@[simp]
def Holds (v : Nat → Int) : Preform → Prop
  | t =* s => t.val v = s.val v
  | t ≤* s => t.val v ≤ s.val v
  | ¬* p => ¬p.Holds
  | p ∨* q => p.Holds ∨ q.Holds
  | p ∧* q => p.Holds ∧ q.Holds
#align omega.int.preform.holds Omega.Int.Preform.Holds

end Preform

/-- univ_close p n := p closed by prepending n universal quantifiers -/
@[simp]
def UnivClose (p : Preform) : (Nat → Int) → Nat → Prop
  | v, 0 => p.Holds v
  | v, k + 1 => ∀ i : Int, univ_close (updateZero i v) k
#align omega.int.univ_close Omega.Int.UnivClose

namespace Preform

/-- Fresh de Brujin index not used by any variable in argument -/
def freshIndex : Preform → Nat
  | t =* s => max t.freshIndex s.freshIndex
  | t ≤* s => max t.freshIndex s.freshIndex
  | ¬* p => p.freshIndex
  | p ∨* q => max p.freshIndex q.freshIndex
  | p ∧* q => max p.freshIndex q.freshIndex
#align omega.int.preform.fresh_index Omega.Int.Preform.freshIndex

/-- All valuations satisfy argument -/
def Valid (p : Preform) : Prop :=
  ∀ v, Holds v p
#align omega.int.preform.valid Omega.Int.Preform.Valid

/-- There exists some valuation that satisfies argument -/
def Sat (p : Preform) : Prop :=
  ∃ v, Holds v p
#align omega.int.preform.sat Omega.Int.Preform.Sat

/-- implies p q := under any valuation, q holds if p holds -/
def Implies (p q : Preform) : Prop :=
  ∀ v, Holds v p → Holds v q
#align omega.int.preform.implies Omega.Int.Preform.Implies

/-- equiv p q := under any valuation, p holds iff q holds -/
def Equiv (p q : Preform) : Prop :=
  ∀ v, Holds v p ↔ Holds v q
#align omega.int.preform.equiv Omega.Int.Preform.Equiv

theorem sat_of_implies_of_sat {p q : Preform} : Implies p q → Sat p → Sat q := by intro h1 h2;
  apply Exists.imp h1 h2
#align omega.int.preform.sat_of_implies_of_sat Omega.Int.Preform.sat_of_implies_of_sat

theorem sat_or {p q : Preform} : Sat (p ∨* q) ↔ Sat p ∨ Sat q :=
  by
  constructor <;> intro h1
  · cases' h1 with v h1
    cases' h1 with h1 h1 <;> [left, right] <;> refine' ⟨v, _⟩ <;> assumption
  · cases' h1 with h1 h1 <;> cases' h1 with v h1 <;> refine' ⟨v, _⟩ <;> [left, right] <;> assumption
#align omega.int.preform.sat_or Omega.Int.Preform.sat_or

/-- There does not exist any valuation that satisfies argument -/
def Unsat (p : Preform) : Prop :=
  ¬Sat p
#align omega.int.preform.unsat Omega.Int.Preform.Unsat

def repr : Preform → String
  | t =* s => "(" ++ t.repr ++ " = " ++ s.repr ++ ")"
  | t ≤* s => "(" ++ t.repr ++ " ≤ " ++ s.repr ++ ")"
  | ¬* p => "¬" ++ p.repr
  | p ∨* q => "(" ++ p.repr ++ " ∨ " ++ q.repr ++ ")"
  | p ∧* q => "(" ++ p.repr ++ " ∧ " ++ q.repr ++ ")"
#align omega.int.preform.repr Omega.Int.Preform.repr

instance hasRepr : Repr Preform :=
  ⟨repr⟩
#align omega.int.preform.has_repr Omega.Int.Preform.hasRepr

unsafe instance has_to_format : has_to_format Preform :=
  ⟨fun x => x.repr⟩
#align omega.int.preform.has_to_format omega.int.preform.has_to_format

end Preform

theorem univClose_of_valid {p : Preform} : ∀ {m v}, p.valid → UnivClose p v m
  | 0, v, h1 => h1 _
  | m + 1, v, h1 => fun i => univ_close_of_valid h1
#align omega.int.univ_close_of_valid Omega.Int.univClose_of_valid

theorem valid_of_unsat_not {p : Preform} : (¬* p).Unsat → p.valid :=
  by
  simp only [preform.sat, preform.unsat, preform.valid, preform.holds]
  rw [not_exists_not]; intro h; assumption
#align omega.int.valid_of_unsat_not Omega.Int.valid_of_unsat_not

/- ./././Mathport/Syntax/Translate/Expr.lean:330:4: warning: unsupported (TODO): `[tacs] -/
/-- Tactic for setting up proof by induction over preforms. -/
unsafe def preform.induce (t : tactic Unit := tactic.skip) : tactic Unit :=
  sorry
#align omega.int.preform.induce omega.int.preform.induce

end Int

end Omega


import .set .lattice .order
open set lattice
structure filter (α:Type*) :=
(sets : set (set α))
(univ_sets : set.univ ∈ sets)
(sets_of_superset {X Y} : X ∈ sets → X ⊆ Y → Y ∈ sets)
(inter_sets {X Y} : X ∈ sets → Y ∈ sets → X ∩ Y ∈ sets)

namespace filter
universes u
variables {α : Type u} {ℱ 𝒢 : filter α} {X Y : set α}

instance : has_mem (set α) (filter α) :=
⟨λ X ℱ, X ∈ ℱ.sets⟩

lemma ext : ∀ {ℱ 𝒢 : filter α}, ℱ.sets = 𝒢.sets → ℱ = 𝒢
| ⟨s,_,_,_⟩ ⟨_,_,_,_⟩ rfl := rfl

def principal (X : set α) : filter α :=
⟨ {S | X ⊆ S}
, λ _ _, ⟨⟩
, λ _ _ hA ss _ ha, ss (hA ha)
, λ A B hA hB, subset.inter hA hB
⟩

instance : has_bot (filter α) := ⟨principal ∅⟩
instance : has_top (filter α) := ⟨principal univ⟩

/--Supremum of a filter of filters-/
def Join_filter (ℱ : filter (filter α)) : filter α :=
⟨ {S | {𝒢 : filter α | S ∈ 𝒢} ∈ ℱ}
,   suffices {𝒢 : filter α | set.univ ∈ 𝒢.sets} ∈ ℱ.sets, from this,
    by simp [filter.univ_sets]; exact ℱ.univ_sets
, λ A B hA ss, ℱ.sets_of_superset hA (λ 𝒢 gm, 𝒢.sets_of_superset gm ss)
, λ A B hA hB, sets_of_superset ℱ (inter_sets ℱ hA hB) (λ 𝒢 ⟨h₁, h₂⟩, inter_sets 𝒢 h₁ h₂)
⟩

instance : partial_order (filter α) :=
{ le := λ ℱ 𝒢, 𝒢.sets ⊆ ℱ.sets
, le_antisymm := λ _ _ h₁ h₂, filter.ext $ subset.antisymm h₂ h₁
, le_refl := λ a, subset.refl
, le_trans := λ a b c h₁ h₂, subset.trans h₂ h₁
}

lemma principal.monotone {X Y : set α} (ss : X ⊆ Y) : principal X ≤ principal Y := λ A hA, subset.trans ss hA

def forget : filter α → set (set α) := filter.sets

inductive free_gen (G : set (set α)) : set α → Prop
|basic {A} : A ∈ G → free_gen A
|univ {} : free_gen univ
|superset {A B} : free_gen A → A ⊆ B → free_gen B
|inter {A B} : free_gen A → free_gen B → free_gen (A ∩ B)

/-- Take the set of sets G and make the smallest filter which contains G. -/
def free (G : set (set α)) : filter α :=
{ sets := free_gen G
, univ_sets := free_gen.univ
, sets_of_superset := λ A B, free_gen.superset
, inter_sets := λ A B, free_gen.inter
}

variables {G : set (set α)}
lemma free.incl : ∀ A ∈ G, A ∈ free G :=
    λ A hA, free_gen.basic hA

lemma free.is_galois : (G ⊆ forget ℱ) ↔ ℱ ≤ free G :=
⟨λ ss X h, free_gen.rec_on h
    (λ _ hX, ss hX)
    (ℱ.univ_sets)
    (λ A B _ ssA rec, ℱ.sets_of_superset rec ssA)
    (λ A B _ _ r1 r2, ℱ.inter_sets r1 r2)
, λ l A hA, l $ free_gen.basic hA
⟩

lemma free.reflective : (free (forget ℱ)) = ℱ :=
    have l: (free (forget ℱ)) ≤ ℱ, from λ A hA, free_gen.basic hA,
    have r: (ℱ ≤ (free (forget ℱ))), from free.is_galois.1 subset.refl,
    partial_order.le_antisymm _ _ l r

instance : complete_lattice (filter α) :=
{ meet := λ ℱ 𝒢,
    {sets := {S | ∃ (A ∈ ℱ) (B ∈ 𝒢), A ∩ B ⊆ S}
    , univ_sets := ⟨univ, univ_sets _, univ, univ_sets _, λ x h, h.1⟩
    , sets_of_superset := λ X Y ⟨A, hA, B, hB, hi⟩ ss, ⟨A,hA,B,hB, subset.trans hi ss⟩
    , inter_sets := λ X Y ⟨XA, hXA, XB, hXB, iX⟩ ⟨YA, hYA, YB, hYB, iY⟩,
        ⟨XA ∩ YA, inter_sets _ hXA hYA, XB ∩ YB, inter_sets _ hXB hYB
        ,   calc (XA ∩ YA) ∩ (XB ∩ YB) = (XA ∩ XB) ∩ (YA ∩ YB) : by ac_refl
                                 ...   ⊆ X ∩ Y                 : subset.inter_subset_inter iX iY
        ⟩
    }
, π₁ := λ ℱ 𝒢 X h, ⟨X, h, univ, univ_sets _ ,λ x ⟨a,b⟩, a⟩
, π₂ := λ ℱ 𝒢 X h, ⟨univ, univ_sets _ , X, h, λ x ⟨a,b⟩, b⟩
, u_meet := λ (𝒜 ℬ 𝒞 : filter α) ab ac X ⟨B, hB, C, hC, ix⟩, sets_of_superset 𝒜 (inter_sets 𝒜 (ab hB) (ac hC)) ix

, join := λ ℱ 𝒢, free (forget ℱ ∩ forget 𝒢)
, ι₁ := λ ℱ 𝒢, free.is_galois.1 inter.π₁
, ι₂ := λ ℱ 𝒢, free.is_galois.1 inter.π₂
, u_join := λ 𝒜 ℬ 𝒞 ba ca A hA, free_gen.basic ⟨ba hA, ca hA⟩

, top := principal univ
, le_top := λ ℱ A hA, subset.antisymm hA subset.univ ▸ ℱ.univ_sets

, bot := principal ∅
, bot_le := λ ℱ A hA, subset.empty

, Join := λ fs, free $ {S | ∀ f ∈ fs, S ∈ f}
, ι := λ ℱs ℱ h₁, free.is_galois.1 (λ X h₂, h₂ ℱ h₁)
, u_Join := λ ℱs ℱ ts X h, free_gen.basic (λ ℱ h₂, ts _ h₂ h)

, Meet := λ fs, free $ {S | ∃ f ∈ fs, S ∈ f}
, π := λ ℱs ℱ h₁ X h₂, free_gen.basic $ ⟨ℱ, h₁, h₂⟩
, u_Meet := λ ℱs 𝒢 h₁, free.is_galois.1 (λ A ⟨ℱ,h₄,h₅⟩, h₁ ℱ h₄ h₅)

}

variables {β : Type u}

instance : functor (filter) :=
{ map := λ α β m 𝒜,
    { sets := {S | {x | m x ∈ S} ∈ 𝒜}
    , univ_sets := 𝒜.univ_sets
    , sets_of_superset := λ X Y h₁ ss, 𝒜.sets_of_superset h₁ (λ x h₂, ss h₂)
    , inter_sets := λ X Y h₁ h₂, 𝒜.inter_sets h₁ h₂
    }
}

instance : is_lawful_functor (filter) :=
{ id_map := λ α f, filter.ext rfl
, comp_map := λ α β γ g h 𝒜, filter.ext rfl
}

instance : monad filter :=
{ bind := λ α β ℱ m, Join_filter (m <$> ℱ)
, pure := λ α a, principal {a}
, ..filter.functor
}

protected def lift (ℱ : filter α) (f: set α → filter β) := ⨅₀ (f <$> ℱ.sets)
protected def lift' (ℱ : filter α) (f : set α → set β) : filter β := ⨅₀ ((principal ∘ f) <$> ℱ.sets)

/-- An ultrafilter is a minimal filter. Adding any more sets will cause it to be the universe. -/
def ultrafilter := {ℱ : filter α // ∀ 𝒢 : filter α,  𝒢 < ℱ → 𝒢 = ⊥}

def tendsto {β : Type u} (f : α → β) (𝒜 : filter α) (ℬ : filter β) := (f <$> 𝒜) ≤ ℬ

lemma mp_sets {U V : set α} (hs : U ∈ ℱ) (h : {x | x ∈ U → x ∈ V} ∈ ℱ) : V ∈ ℱ :=
sets_of_superset ℱ (inter_sets _ hs h) $ λ a ⟨h₁, h₂⟩, h₂ h₁

end filter