import tactic general set_lemmas linear_algebra.basis new_free ring_theory.principal_ideal_domain torsion primes
run_cmd tactic.skip
open_locale classical

variables {R : Type*} [integral_domain R] [is_principal_ideal_ring R]

noncomputable def projection {ι : Type*} {M : Type*} [add_comm_group M] [module R M]
  (v : ι → M) (hv : is_basis R v) (a : ι) :
  linear_map R M M :=
{ to_fun := λ x, x - hv.repr x a • v a,
  map_add' := λ x y, by {show (x + y) - hv.repr (x + y) a • v a = (x - _) + (y - _),
  rw linear_map.map_add, erw add_smul, abel, },
  map_smul' := λ c x, by {show c • x - hv.repr (c • x) a • v a = c • (x - _),
  rw linear_map.map_smul, rw smul_sub, rw ←mul_smul, refl, } }

theorem proj_mem {ι : Type*} {M : Type*} [add_comm_group M] [module R M]
  {s : set ι} {v : ι → M} (hv : is_basis R (v ∘ subtype.val : s → M)) {a : ι} (ha : a ∈ s) {x : M} :
  projection _ hv ⟨a, ha⟩ x ∈ submodule.span R (set.range (v ∘ subtype.val : (s \ {a} → M))) :=
begin
  show _ - _ ∈ _,
  conv {to_lhs, congr, rw ←hv.total_repr x},
  cases classical.em ((⟨a, ha⟩ : s) ∈ (hv.repr x).support),
  rw finsupp.total_apply, unfold finsupp.sum,
  rw ←finset.insert_erase h,
  erw finset.sum_insert (finset.not_mem_erase (⟨a, ha⟩ : s) (hv.repr x).support),
  simp only [add_sub_cancel', function.comp_app],
  refine @submodule.sum_mem R M _ _ _ _ (submodule.span R (set.range (v ∘ subtype.val))) (((hv.repr) x).support.erase ⟨a, ha⟩)
  (λ (y : s), ((hv.repr) x) y • v y.val) _,
  intros y hy, dsimp,
  apply submodule.smul_mem (submodule.span R (set.range (v ∘ subtype.val))) _,
  apply submodule.subset_span, use y,
  rw set.mem_diff, split,
  exact y.2,
  intro hya,
  have hyan : y = ⟨a, ha⟩ := subtype.ext_iff.2 hya,
  exact (finset.ne_of_mem_erase hy) hyan,
  rw finsupp.not_mem_support_iff.1 h, rw zero_smul, rw sub_zero,
    refine @submodule.sum_mem R M _ _ _ _ (submodule.span R (set.range (v ∘ subtype.val)))
      (((hv.repr) x).support)
  (λ (y : s), ((hv.repr) x) y • v y.val) _,
  intros y hy, dsimp,
  apply submodule.smul_mem (submodule.span R (set.range (v ∘ subtype.val))) _,
  apply submodule.subset_span, use y,
  rw set.mem_diff, split,
  exact y.2,
  intro hya,
  have hyan : y = ⟨a, ha⟩ := subtype.ext_iff.2 hya,
  rw hyan at hy, exact h hy,
end

lemma proj_ker {ι : Type*} {M : Type*} [add_comm_group M] [module R M]
  {s : set ι} {v : ι → M} (hv : is_basis R (v ∘ subtype.val : s → M)) {a : ι} (ha : a ∈ s) :
  (projection _ hv ⟨a, ha⟩).ker = submodule.span R {v a} :=
begin
  ext,
  split,
  intro hx,
  rw linear_map.mem_ker at hx,
  erw sub_eq_zero at hx,
  rw submodule.mem_span_singleton,
  use hv.repr x ⟨a, ha⟩,
  exact hx.symm,
  intro hx,
  rw submodule.mem_span_singleton at hx,
  cases hx with r hr,
  rw linear_map.mem_ker,
  erw sub_eq_zero,
  rw ←hr, rw linear_map.map_smul,
  have := @is_basis.repr_eq_single _ _ _ _ _ _ _ hv ⟨a, ha⟩,
  have hh : hv.repr ((v ∘ subtype.val) (⟨a, ha⟩ : s)) (⟨a, ha⟩ : s) = (1 : R) := by
    rw this; exact finsupp.single_eq_same,
  simp only [finsupp.smul_apply, algebra.id.smul_eq_mul, function.comp_app],
  rw mul_comm,
  rw mul_smul,
  rw hh, rw one_smul,
end

lemma projective_of_has_basis {ι : Type*} {M : Type*} [add_comm_group M] [module R M]
  {v : ι → M} (hv : is_basis R v) :
  projective R M :=
begin
  intros _ _ _ _ _ _ _ _ hg,
  let F' := λ i : ι, classical.some (hg (f (v i))),
  let F := @is_basis.constr _ _ _ _ _ _ _ _inst_6 _ _inst_7 hv F',
  use F,
  have huh : ∀ i : ι, g (F $ v i) = f (v i) := by {
  intro i, rw constr_basis, exact classical.some_spec (hg (f $ v i))},
  have : @linear_map.comp R M A B _ _ (@add_comm_group.to_add_comm_monoid A _inst_6)
   (@add_comm_group.to_add_comm_monoid B _inst_7_1) _ _ _ g F = f := @is_basis.ext
     _ _ _ _ _ _ _ _inst_7_1 _ _inst_7_2 (@linear_map.comp R M A B _ _
     (@add_comm_group.to_add_comm_monoid A _inst_6) (@add_comm_group.to_add_comm_monoid B _inst_7_1)
     _ _ _ g F) f
    hv (λ x, huh x),
  intro x,
  rw ←this,
  refl,
end

lemma split_of_left_inv {M : Type*} [add_comm_group M] [module R M] (A : submodule R M)
{B : Type*} [add_comm_group B] [module R B] (f : M →ₗ[R] B) (H : A.subtype.range = f.ker)
(g : B →ₗ[R] M) (hfg : f.comp g = linear_map.id) (hf : f.range = ⊤) :
  A ⊓ g.range = ⊥ ∧ A ⊔ g.range = ⊤ :=
begin
  split,
  rw eq_bot_iff,
  intros x hx,
  refine (submodule.mem_bot R).2 _,
  cases hx.2 with y hy,
  have : f x = 0, by {rw ←linear_map.mem_ker, rw ←H, exact ⟨⟨x, hx.1⟩, trivial, rfl⟩},
  rw ←hy.2 at this, rw ←linear_map.comp_apply at this,
  rw hfg at this,
  rw linear_map.id_apply at this,
  rw ←hy.2,
  rw this,
  rw g.map_zero,
  rw eq_top_iff,
  intros x _,
  apply submodule.mem_sup.2,
  clear a,
  use x - g (f x),
  split,
  rw ←submodule.range_subtype A, rw H,
  rw linear_map.mem_ker,
  rw linear_map.map_sub,
  show f x - f.comp g (f x) = 0,
  rw hfg,
  exact sub_self (f x),
  use g (f x),
  split,
  exact linear_map.mem_range.2 ⟨f x, rfl⟩,
  rw sub_add_cancel,
end

variables {ι : Type*} {M : Type*} (s : set ι)
  [fintype ι] [add_comm_group M]
  [module R M] (v : ι → M)
  (a : ι)

variables (R)

def wtf' (i : (s \ ({a} : set ι) : set ι)) : submodule.span R
  (set.range (v ∘ subtype.val : s \ {a} → M)) :=
subtype.mk ((v ∘ subtype.val) i) (submodule.subset_span $ set.mem_range_self i)

variables {R}
lemma is_basis_diff {n : ℕ} {ι : Type*} {M : Type*} {s : set ι}
  [fintype ι] (hs : fintype.card ↥s = nat.succ n) [add_comm_group M]
  [module R M] {v : ι → M} (hv : is_basis R (v ∘ subtype.val : s → M))
  {a : ι} (ha : a ∈ s) :
 is_basis R (wtf' R s v a ∘ (subtype.val : (@set.univ (s \ ({a} : set ι) : set ι) : set _) →
   (s \ ({a} : set ι) : set ι))) :=
begin
  split,
  refine linear_independent.comp _ subtype.val subtype.val_injective,
  apply linear_independent_span,
  dsimp,
  cases hv with hv1 hv2,
  have := linear_independent.to_subtype_range hv1,
  have H := linear_independent.mono (show (set.range (v ∘ subtype.val : s \ {a} → M) ⊆
  set.range (v ∘ subtype.val : s → M)), by
  {rw set.range_subset_iff, intro y,
  exact ⟨⟨(y : ι), set.diff_subset _ _ y.2⟩, rfl⟩}) this,
  refine linear_independent.of_subtype_range _ H,
  have hi := linear_independent.injective hv1,
  intros x y h,
  have hxy : (⟨(x : ι), set.diff_subset _ _ x.2⟩ : s) = (⟨(y : ι), set.diff_subset _ _ y.2⟩ : s) :=
  hi (by simpa only [function.comp_app] using h),
  apply subtype.ext_iff.2, simpa only [] using hxy,
  refine linear_map.map_injective (submodule.ker_subtype _) _,
  rw submodule.map_subtype_top, rw ←submodule.span_image,
  rw ←set.range_comp, congr' 1,
  ext,
  split,
  rintro ⟨y, hy⟩, simp only [submodule.subtype_apply, function.comp_app, wtf'] at hy,
  rw ←hy, use y.1, refl,
  rintro ⟨y, hy⟩,
  rw ←hy, use y, simp only [wtf', submodule.subtype_apply, submodule.coe_mk, function.comp_app],
end

theorem free_subm0 (ι : Type*) [fintype ι] (s : set ι) (hs : fintype.card s = 0)
  (M : Type*) [add_comm_group M] [module R M] (v : ι → M)
  (hv : is_basis R (v ∘ (subtype.val : s → ι)))
  (S : submodule R M) : ∃ (t : set M), linear_independent R (λ x, x : t → M) ∧
    submodule.span R (set.range (λ x, x : t → M)) = S :=
begin
  use ∅,
  split,
  exact linear_independent_empty R M,
  cases hv with hv1 hv2,
  have hs := fintype.card_eq_zero_iff.1 hs,
  erw subtype.range_coe_subtype, erw submodule.span_empty,
  suffices : ∀ x : M, x = 0, by {symmetry, rw eq_bot_iff, intros x hx, apply (submodule.mem_bot R).2,
    exact this (x : M)},
  intro x,
  have : set.range (v ∘ (subtype.val : s → ι )) = ∅ :=
  by {apply set.range_eq_empty.2, intro h, cases h with y hy, exact hs y },
  rw this at hv2, rw submodule.span_empty at hv2,
  apply (submodule.mem_bot R).1, rw hv2, exact submodule.mem_top,
end

noncomputable def free_equiv {ι : Type*} (x : ι)
  {M : Type*} [add_comm_group M] [module R M] {v : ι → M}
  (hv : is_basis R (v ∘ (subtype.val : ({x}: set ι) → ι))) :
  linear_equiv R R M :=
equiv_of_is_basis (@is_basis_singleton_one ({x} : set ι) R
  (set.unique_singleton x) _) hv (equiv.refl _)

lemma free_subm1 (ι : Type*) [fintype ι] (s : set ι) (hs : ¬ 1 < fintype.card s)
  (M : Type*) [add_comm_group M] [module R M] (v : ι → M) (hv : is_basis R (v ∘ (subtype.val : s → ι)))
  (S : submodule R M) : ∃ (t : set M), linear_independent R (λ x, x : t → M) ∧
    submodule.span R (set.range (λ x, x : t → M)) = S :=
begin
  cases classical.em (S = ⊥),
  use ∅, split, exact linear_independent_empty _ _, rw h, simp,
  have : fintype.card s = 0 ∨ fintype.card s = 1 := by omega,
  cases this with hl hr, exact free_subm0 ι s hl M v hv S,
  cases fintype.card_eq_one_iff.1 hr with y hy,
  have hrange : set.range (v ∘ subtype.val) = {(v ∘ subtype.val) y} := by {rw ←set.image_univ,
  convert set.image_singleton, symmetry, rw ←set.univ_subset_iff, intros t ht, exact hy t,},
  have hys : {(y : ι)} = s := by {ext a, split, intro ha, convert y.2, intro ha,
  exact subtype.ext_iff.1 (hy ⟨a, ha⟩)},
  let Smap := S.map (@free_equiv R _ _ ι (y : ι) M _ _ v (hys.symm ▸ hv)).symm.to_linear_map,
  cases submodule.is_principal.principal Smap with c hc,
  let C := @free_equiv R _ _ ι (y : ι) M _ _ v (hys.symm ▸ hv) c,
  use {C},
  have hCy : C ∈ submodule.span R {(v ∘ subtype.val) y} := by {rw ←hrange, rw hv.2,
  exact submodule.mem_top,},
  cases submodule.mem_span_singleton.1 hCy with r hr,
  have hCS : S = submodule.span R {C} := by {simp only [Smap, C] at hc ⊢, rw ←set.image_singleton,
    erw submodule.span_image,
   rw ←hc, rw ←submodule.map_comp, symmetry, convert submodule.map_id S, ext z,
   exact linear_equiv.apply_symm_apply (@free_equiv R _ _ ι (y : ι) M _ _ v (hys.symm ▸ hv)) z,},
  have hC0 : C ≠ 0 := λ hC0, by {rw hC0 at hCS, change S = submodule.span R (⊥ : submodule R M) at hCS,
    erw submodule.span_eq at hCS, exact h hCS},
  have hr0 : r ≠ 0 := λ hr0, by {rw hr0 at hr, rw zero_smul at hr, apply hC0, exact hr.symm},
  split,
  refine linear_independent.mono _ _, exact {r • v (y : ι)}, rw ←hr,
  rw set.singleton_subset_iff, exact set.mem_singleton _,
  have hry : {r • v (y : ι)} = set.range (λ m : s, r • (v ∘ subtype.val) m) :=
    by {rw ←set.image_univ, erw ←@set.image_singleton _ _ (λ m : s, r • (v ∘ subtype.val) m) y,
     congr, exact set.eq_univ_of_forall hy},
  rw hry,
  apply linear_independent.to_subtype_range, rw linear_independent_iff,
  have hv1 := linear_independent_iff.1 hv.1, intros l hl,
  let L : {x // x ∈ s} →₀ R := finsupp.map_range (λ m, r • m) (smul_zero r) l,
  have hvL := hv1 L (by {rw finsupp.total_apply at hl ⊢, unfold finsupp.sum,
    simp only [finsupp.map_range_apply],
  rw finset.sum_subset (finsupp.support_map_range), convert hl,dsimp,
    simp only [mul_comm r, mul_smul], refl,
  intros X hX hX0, have hm := finsupp.not_mem_support_iff.1 hX0,
  rw finsupp.map_range_apply at hm,rw hm, rw zero_smul,
  }),
  ext,
  rw finsupp.ext_iff at hvL, specialize hvL a,
  exact or.resolve_left (mul_eq_zero.1 hvL) hr0,
  convert hCS.symm,
  simp only [subtype.range_coe_subtype], refl,
end

lemma one_empty {n : ℕ} {ι : Type*} {M : Type*} {s : set ι} [hι : fintype ι]
  (hs : fintype.card ↥s = n.succ)
[add_comm_group M] [module R M] {v : ι → M} (hv : is_basis R (v ∘ subtype.val : s → M))
{S : submodule R M} (h1 : 1 < fintype.card ↥s) {b : ι} (hb : b ∈ s)
{t : set ↥(submodule.span R (set.range (v ∘ subtype.val : s \ {b} → M)))}
(ht : linear_independent R (λ (x : t), (↑x : submodule.span R (set.range
 (v ∘ subtype.val : s \ {b} → M)))) ∧ submodule.span R (set.range (λ (x : ↥t),
 (↑x : submodule.span R (set.range
 (v ∘ subtype.val : s \ {b} → M))))) =
      submodule.map
        (linear_map.cod_restrict (submodule.span R (set.range (v ∘ subtype.val)))
           (projection (v ∘ subtype.val) hv ⟨b, hb⟩)
           (λ c, proj_mem hv hb))
        S)
{l : set ↥((projection (v ∘ subtype.val) hv ⟨b, hb⟩).ker)}
(hl :
  linear_independent R (λ (x : ↥l), (↑x : (projection (v ∘ subtype.val) hv ⟨b, hb⟩).ker)) ∧
    submodule.span R (set.range (λ (x : ↥l), (↑x : (projection (v ∘ subtype.val) hv ⟨b, hb⟩).ker))) =
    ((submodule.of_le $ @inf_le_right _ _ S (projection _ hv ⟨b, hb⟩).ker).range))
(h : l = ∅) :
∃ (t : set M),
    linear_independent R (λ (x : ↥t), (↑x : M)) ∧ submodule.span R (set.range (λ (x : ↥t), ↑x)) = S :=
begin
  use (submodule.span R (set.range (v ∘ subtype.val : s \ {b} → M))).subtype '' t,
  split,
  apply linear_independent.image_subtype,
  exact ht.1,
  simp only [disjoint_bot_right, submodule.ker_subtype],
  simp only [submodule.subtype_apply, subtype.range_coe_subtype],
  show submodule.span R ((submodule.span R (set.range (v ∘ subtype.val))).subtype '' t) = S,
  rw submodule.span_image,
  apply le_antisymm,
  rw submodule.map_le_iff_le_comap,
  intros y hy,
  simp only [submodule.mem_comap, submodule.subtype_apply],
  sorry, sorry,
end

theorem free_subm (ι : Type*) [fintype ι] (s : set ι) (n : ℕ) (hs : fintype.card s = n)
  (M : Type*) [add_comm_group M] [module R M] (v : ι → M) (hv : is_basis R (v ∘ (subtype.val : s → ι)))
  (S : submodule R M) : ∃ (t : set M), linear_independent R (λ x, x : t → M) ∧ submodule.span R (set.range (λ x, x : t → M)) = S :=
begin
  unfreezingI {revert ι M s,
  induction n using nat.case_strong_induction_on with n hn},
  intros ι M s hι h0 inst inst' v hv S,
    exact @free_subm0 _ _ _ ι hι s h0 M inst inst' v hv S,
  intros ι M s hι hs _ _ v hv S,
  resetI,
  cases (classical.em (1 < fintype.card s)) with h1 h1,
  rcases fintype.card_pos_iff.1 (show 0 < fintype.card s, by omega) with ⟨b, hb⟩,
  rcases hn n (nat.le_refl n) (s \ ({b} : set ι) : set ι)
    (submodule.span R (set.range (v ∘ subtype.val : (s \ ({b} : set ι)) → M))) (set.univ)
  (by {
    apply (add_right_inj 1).1, rw add_comm 1 n, rw ←nat.succ_eq_add_one n, rw ← hs,
    erw univ_card'', rw add_comm,
    rw (card_insert' (s \ ({b} : set ι)) not_mem_diff_singleton).symm,
    congr, rw ←eq_insert_erase_of_mem s b hb, apply_instance, apply_instance})
    (λ i, ⟨v i, submodule.subset_span $ set.mem_range_self i⟩)
    (by convert is_basis_diff hs hv hb)
   (S.map $ (projection _ hv ⟨b, hb⟩).cod_restrict (submodule.span R (set.range
     (v ∘ subtype.val : (s \ ({b} : set ι)) → M)))
   (λ c, proj_mem hv hb)) with ⟨t, ht⟩,
  rcases hn 1 (by omega) ({b} : set ι) (projection _ hv ⟨b, hb⟩).ker set.univ sorry
    (λ x, ⟨v x, by {rw proj_ker,apply submodule.subset_span,convert set.mem_singleton _, exact x.2.symm}⟩)
  (by {split,
  suffices : linear_independent R (v ∘ subtype.val : ({b} : set ι) → M), by
    {  apply linear_independent.comp _ subtype.val subtype.val_injective,
       erw linear_independent_comp_subtype at this,
       rw linear_independent_iff,intros l hl,
       specialize this (finsupp.emb_domain (function.embedding.subtype ({b} : set ι)) l)
         (by {rw finsupp.mem_supported, rw finsupp.support_emb_domain,
         intros x hx, rcases finset.mem_map.1 hx with ⟨y, hym, hy⟩,
         rw ←hy, exact y.2}), rw finsupp.total_apply at hl,
      rw finsupp.total_emb_domain at this,rw finsupp.total_apply at this,
      simp only [function.comp_app] at this,
      change ((l.sum (λ (i : ({b} : set ι)) (c : R), c • v (↑i : ι)) = 0) →
  (finsupp.emb_domain (function.embedding.subtype ({b} : set ι)) l = 0)) at this,
     specialize this (by {rw subtype.ext_iff at hl,dsimp at hl,rw ←hl,
     show _ = submodule.subtype _ _,
     conv_rhs {rw ←finsupp.total_apply},
     rw linear_map.map_finsupp_total, rw finsupp.total_apply,
     apply finset.sum_congr rfl, intros x hx, simp only [submodule.subtype_apply, submodule.coe_mk,
     function.comp_app], }),
     rw finsupp.ext_iff at this,ext,specialize this a,erw finsupp.emb_domain_apply at this,
     rw this,simp only [finsupp.zero_apply], },
  have huh := linear_independent.to_subtype_range hv.1,
  have hm := linear_independent.mono (show set.range (v ∘ subtype.val : ({b} : set ι) → M) ⊆
    set.range (v ∘ subtype.val : s → M), by
  {rw set.range_subset_iff, intro y, use b, exact hb, rw ←subtype.eta y y.2, simp only
    [function.comp_app, subtype.eta],
  exact congr_arg v y.2.symm,
  }) huh,
  apply linear_independent.of_subtype_range, intros c d hcd,
  rw subtype.ext_iff, rw (show (c : ι) = b, from c.2), symmetry, exact d.2, exact hm,
  apply linear_map.map_injective (projection _ hv ⟨b, hb⟩).ker.ker_subtype,
  rw submodule.map_subtype_top, rw ←submodule.span_image, symmetry,
  convert proj_ker hv hb,
  rw ←set.range_comp,
  ext m,
  split,
  rintro ⟨k, hk⟩,
  rw ← hk, show _ = _, simpa only [] using congr_arg v k.1.2,
  intro hm, use b, exact set.mem_singleton _, rw (show _ = _, from hm), refl,
  })
  (submodule.of_le $ @inf_le_right _ _ S (projection _ hv ⟨b, hb⟩).ker).range with ⟨l, hl⟩,
  cases (classical.em (l = ∅)),
    exact one_empty hs hv h1 hb ht hl h,
  let V := (submodule.span R (set.range (v ∘ subtype.val : (s \ ({b} : set ι)) → M))).subtype '' t,
  let W := (projection (v ∘ subtype.val) hv ⟨b, hb⟩).ker.subtype '' l,
  use V ∪ W,
  refine union_is_basis_of_gen_compl S ((submodule.span R (set.range (v ∘ subtype.val :
    (s \ ({b} : set ι)) → M))).comap S.subtype) V (submodule.comap S.subtype $
    linear_map.ker (projection (v ∘ subtype.val) hv ⟨b, hb⟩)) W _ _ _ _ _ _,
  rw submodule.map_comap_subtype,
    sorry,
  rw submodule.map_comap_subtype, sorry,
  refine linear_independent.image_subtype _ _,
  exact ht.1, sorry,
  refine linear_independent.image_subtype _ _,
  exact hl.1, sorry,
  rw ←submodule.comap_inf,
  rw eq_bot_iff,
  intros x hx, rw submodule.mem_bot,
  cases hx with hxl hxr,
  simp at hxr,
  sorry,
  sorry,
  exact free_subm1 ι s h1 M v hv S,
end

lemma tf_iff {M : Type*} [add_comm_group M] [module R M] :
  tors R M = ⊥ ↔ ∀ (x : M) (r : R), r • x = 0 → r = 0 ∨ x = 0 :=
begin
  split,
  intro h,
  rw eq_bot_iff at h,
  intros x r hx,
  cases (classical.em (r = 0)),
  left, assumption,
  right,
  exact (submodule.mem_bot R).1 (h ⟨r, h_1, hx⟩),
  intros h,
  rw eq_bot_iff,
  intros x hx,
  cases hx with r hr,
  exact (submodule.mem_bot R).2 (or.resolve_left (h x r hr.2) hr.1)
end

theorem fg_quotient {M : Type*} [add_comm_group M] [module R M]
  (S : submodule R M) (Hfg : S.fg) (A : submodule R S) : (⊤ : submodule R A.quotient).fg :=
@is_noetherian.noetherian _ _ _ _ _
  (is_noetherian_of_quotient_of_noetherian R S A $ is_noetherian_of_fg_of_noetherian S Hfg) ⊤

lemma span_insert_zero_eq' {s : set M} :
  submodule.span R (insert (0 : M) s) = submodule.span R s :=
begin
  rw ←set.union_singleton,
  rw submodule.span_union,
  rw submodule.span_singleton_eq_bot.2 rfl,
  rw sup_bot_eq,
end

lemma card_pos_of_ne_bot {M : Type*} [add_comm_group M] [module R M] {s : finset M}
  {S : submodule R M} (h : S ≠ ⊥) (hs : submodule.span R (↑s : set M) = S) :
  0 < (s.erase 0).card :=
begin
  rw nat.pos_iff_ne_zero,
  intro h0,
  rw finset.card_eq_zero at h0,
  cases classical.em ((0 : M) ∈ s) with hl hr,
  rw ←finset.insert_erase hl at hs,
  rw insert_to_set' at hs,
  rw span_insert_zero_eq' at hs,
  rw h0 at hs, erw submodule.span_empty at hs, exact h hs.symm,
  rw finset.erase_eq_of_not_mem hr at h0,
  rw h0 at hs, erw submodule.span_empty at hs,
  exact h hs.symm,
end

lemma subset_singleton' {c : M} {l : finset M} (h : l ⊆ {c}) : l = ∅ ∨ l = {c} :=
begin
  cases (finset.eq_empty_or_nonempty l),
  left,
  exact h_1,
  right,
  erw finset.eq_singleton_iff_unique_mem,
  cases h_1 with w hw,
  have := finset.mem_singleton.1 (h hw),
  rw ←this,
  split,
  exact hw,
  intros x hx,
  rw this,
  exact finset.mem_singleton.1 (h hx),
end

lemma single_of_singleton_support {α : Type*} {l : α →₀ R} {x : α}
  (h : l.support = {x}) : l = finsupp.single x (l x) :=
begin
  ext,
  cases classical.em (a = x),
  rw h_1, simp only [finsupp.single_eq_same],
  rw finsupp.not_mem_support_iff.1 (by rw h; exact finset.not_mem_singleton.2 h_1),
  rw finsupp.single_eq_of_ne (ne.symm h_1),
end

def WHY (s : finset M) : set M := @has_lift.lift _ _ finset.has_lift s

noncomputable def finsupp_insert {s : finset M} {x : M} {l :  (set.insert x (WHY s)) →₀ R}
  (hx : x ∉ s) (hl : l.2 (⟨x, set.mem_insert x (WHY s)⟩ : set.insert x (WHY s)) = 0) :
  WHY s →₀ R :=
{ support := subtype_mk' (finset.image subtype.val l.support) (WHY s) (by {intros y hy,
erw finset.mem_image at hy, rcases hy with ⟨z, hzm, hz⟩, rw ←hz, exact
or.resolve_left z.2 (by {intro hzx, rw finsupp.mem_support_iff at hzm, apply hzm, rw ←hl,
  congr, rw subtype.ext_iff, exact hzx})}),
  to_fun := λ x, l ⟨x, set.subset_insert _ _ x.2⟩,
  mem_support_to_fun := λ y, by {split, intros h h0, erw finset.mem_image at h,
  rcases h with ⟨b, hmb, hb⟩, cases b with b1 b2, erw finset.mem_image at b2, rcases b2 with ⟨c, hmc, hc⟩,
  apply finsupp.mem_support_iff.1 hmc, rw ←subtype.eta c c.2, rw ←h0, congr' 1,
    rw subtype.mk_eq_mk, rw hc, rw ←hb, refl,
    intros h0, apply finset.mem_image.2, use (y : M), apply finset.mem_image.2,
    use ⟨y, set.subset_insert _ _ y.2⟩,
    split, exact finsupp.mem_support_iff.2 h0, refl,
    split, exact finset.mem_univ _, rw subtype.ext_iff, refl,} }

lemma finsupp_insert_apply {s : finset M} {x : M} {l :  (set.insert x (WHY s)) →₀ R}
  (hx : x ∉ s) (hl : l.2 (⟨x, set.mem_insert x (WHY s)⟩ : set.insert x (WHY s)) = 0)
  {y : M} (hy : y ∈ s) : finsupp_insert hx hl ⟨y, hy⟩ = l ⟨y, set.subset_insert _ _ hy⟩ :=
rfl

lemma finsupp_insert_total {s : finset M} {x : M} {l :  (set.insert x (WHY s)) →₀ R}
  (hx : x ∉ s) (hl : l.2 (⟨x, set.mem_insert x (WHY s)⟩ : set.insert x (WHY s)) = 0)
  : finsupp.total (WHY s) M R subtype.val (finsupp_insert hx hl) =
    finsupp.total (set.insert x (WHY s)) M R subtype.val l :=
begin
  rw finsupp.total_apply,
  rw finsupp.total_apply,
  unfold finsupp.sum,
  show (subtype_mk' _ _ _).sum (λ (z : WHY s), l ⟨z, set.subset_insert _ _ z.2⟩ • (z : M)) = _,
  sorry,
end

variables (ρ : finset M) (T : set M)

instance fucksake2 (s : finset M) : fintype (WHY s) :=
finset_coe.fintype s

noncomputable def dep_coeff_map {M : Type*} [add_comm_group M] [module R M] (s : finset M) (z : M)
(h : ¬(finsupp.total (set.insert z (WHY s)) M R subtype.val).ker = ⊥) :
  (finsupp.total (set.insert z (WHY s)) M R subtype.val).ker :=
@classical.some (finsupp.total (set.insert z (WHY s)) M R subtype.val).ker (λ f, f ≠ 0) (by {
  have h' : ¬(finsupp.total (set.insert z (WHY s)) M R subtype.val).ker ≤ ⊥, from λ h', h (eq_bot_iff.2 h'),
  rcases submodule.not_le_iff_exists.1 h' with ⟨y, hym, hy⟩, use y,exact hym,
  intro hy0, rw subtype.ext_iff at hy0,
exact hy hy0})

noncomputable def dep_coeff {M : Type*} [add_comm_group M] [module R M] (s : finset M) (z : M)
(h : ¬(finsupp.total (set.insert z (WHY s)) M R subtype.val).ker = ⊥) : R :=
dep_coeff_map s z h ⟨z, (set.mem_insert z _)⟩

theorem dep_coeff_spec {M : Type*} [add_comm_group M] [module R M] (s : finset M) (z : M)
  (h : ¬(finsupp.total (set.insert z (WHY s)) M R subtype.val).ker = ⊥) :
  dep_coeff_map s z h ≠ 0 :=
@classical.some_spec (finsupp.total (set.insert z (WHY s)) M R subtype.val).ker (λ f, f ≠ 0) (by {
  have h' : ¬(finsupp.total (set.insert z (WHY s)) M R subtype.val).ker ≤ ⊥,
    from λ h', h (eq_bot_iff.2 h'),
  rcases submodule.not_le_iff_exists.1 h' with ⟨y, hym, hy⟩, use y,
    exact hym, intro hy0, rw subtype.ext_iff at hy0,
exact hy hy0})

lemma prod_ne_zero {M : Type*} [add_comm_group M] [module R M] (Y s : finset M)
(h : ∀ z : M, z ∈ Y \ s → ¬(finsupp.total (set.insert (z : M) (WHY s)) M R subtype.val).ker = ⊥)
  (hli : (finsupp.total (WHY s) M R subtype.val).ker = ⊥) :
 finset.prod (finset.image (λ w : (WHY (Y \ s)), dep_coeff s (w : M) $ h w w.2)
 (@finset.univ (WHY (Y \ s)) _)) id ≠ 0 :=
begin
  intro hr0,
  have hr := finset_prod_eq_zero_iff.1 hr0,
  rw finset.mem_image at hr, rcases hr with ⟨x, hxm, hx⟩,
  rw eq_bot_iff at hli,
  have H := classical.not_not.2 hli,
  apply H,
  rw submodule.not_le_iff_exists,
  let F := @finsupp_insert R _ _ _ _ _ s x (dep_coeff_map s x (h x x.2)) (finset.mem_sdiff.1 x.2).2 hx,
  use F,
  split,
  rw linear_map.mem_ker,
  erw finsupp_insert_total (finset.mem_sdiff.1 x.2).2 hx,
  have huh := (dep_coeff_map s (x : M) (h x x.2)).2,
  rw linear_map.mem_ker at huh, exact huh,
  intro hF0,
  apply dep_coeff_spec s (x : M) (h x x.2),
  rw submodule.mem_bot at hF0,
  rw subtype.ext_iff,
  rw submodule.coe_zero,
  ext,
  cases (set.mem_insert_iff.1 a.2),
  rw finsupp.zero_apply, rw ←hx, congr, rw subtype.ext_iff, exact h_1,
  have huh := finsupp.ext_iff.1 hF0 ⟨a, h_1⟩,
  rw finsupp_insert_apply at huh,
  rw subtype.coe_eta at huh, rw huh, refl,
end

lemma prod_smul_mem {M : Type*} [add_comm_group M] [module R M] (Y s : finset M)
(h : ∀ z : M, z ∈ Y \ s → ¬(finsupp.total (set.insert (z : M) (WHY s)) M R subtype.val).ker = ⊥)
 (hli : (finsupp.total (WHY s) M R subtype.val).ker = ⊥)
 {y} (hy : y ∈ Y) :
 finset.prod (finset.image (λ w : (WHY (Y \ s)), dep_coeff s (w : M) $ h w w.2)
 (@finset.univ (WHY (Y \ s)) _)) id • y ∈ submodule.span R (↑s : set M) :=
begin
  sorry,
end

variables {r : R} (S : submodule R M)

noncomputable def r_equiv (htf : ∀ (x : S) (r : R), r • x = 0 → r = 0 ∨ x = 0) (r : R) (hr : r ≠ 0) :=
linear_equiv.of_injective ((r • linear_map.id).comp S.subtype) (by {
rw linear_map.ker_eq_bot', intros m hm, exact or.resolve_left
(htf m r $ subtype.ext_iff.2 $ by {dsimp at hm, rw ←submodule.coe_smul at hm,
  rw ←@submodule.coe_zero _ _ _ _ _ S at hm, exact hm}) hr})

lemma equiv_apply (htf : ∀ (x : S) (r : R), r • x = 0 → r = 0 ∨ x = 0) (r : R) (hr : r ≠ 0) {x : S} :
(r_equiv S htf r hr x : M) = r • x := rfl

theorem free_of_tf (M : Type*) [add_comm_group M] [module R M] (S : submodule R M)
  (hfg : S.fg) (htf : ∀ (x : S) (r : R), r • x = 0 → r = 0 ∨ x = 0) :
  ∃ (t : set M), linear_independent R (λ x, x : t → M) ∧
  submodule.span R (set.range (λ x, x : t → M)) = S :=
begin
  cases (classical.em (S = ⊥)),
  {  use ∅,
       split,
       exact linear_independent_empty _ _,
       rw h, simp only [subtype.range_coe_subtype], exact submodule.span_empty},
  cases hfg with X hX,
  set Y := X.erase 0,
  have hY : (↑Y : set M) ⊆ S := set.subset.trans (finset.erase_subset 0 X) (hX ▸ submodule.subset_span),
  set n := nat.find_greatest (λ n, ∃ s : finset M, s ⊆ Y ∧
    linear_independent R (λ x, x : (WHY s) → M) ∧ s.card = n) Y.card,
  cases @nat.find_greatest_spec (λ n, ∃ s : finset M, s ⊆ Y ∧
    linear_independent R (λ x, x : (WHY s) → M) ∧ s.card = n) _ Y.card
    ⟨1, nat.succ_le_of_lt $ card_pos_of_ne_bot h hX, by
    {cases finset.card_pos.1 (card_pos_of_ne_bot h hX) with c hc,
    use {c}, split,
    exact finset.singleton_subset_iff.2 hc, split,
    rw linear_independent_subtype, intros l hlm hl,
    cases subset_singleton ((finsupp.mem_supported _ _).1 hlm) with hl0 hlc,
    rw ←finsupp.support_eq_empty, exact hl0,
    rw single_of_singleton_support hlc at hl ⊢,
    rw finsupp.total_single at hl,
    rw finsupp.single_eq_zero,
    exact or.resolve_right (htf ⟨c, hY hc⟩ (l c) (subtype.ext_iff.2 $ hl))
    (λ h0, (finset.mem_erase.1 hc).1 $ subtype.ext_iff.1 h0),
    exact finset.card_singleton _,
     }⟩ with s hs,
  cases (classical.em (∃ x, x ∈ Y \ s)),
  cases h_1 with z hz,
  have hnl : ∀ z, z ∈ Y \ s → ¬(linear_independent R $ (λ y, y : (set.insert z (WHY s) : set M) → M)) :=
    λ x hx hnl,
  by {have huh := @nat.find_greatest_is_greatest (λ n, ∃ s : finset M, s ⊆ Y ∧
    linear_independent R (λ x, x : (WHY s) → M) ∧ s.card = n) _ Y.card
      ⟨1, nat.succ_le_of_lt $ card_pos_of_ne_bot h hX, by
    {cases finset.card_pos.1 (card_pos_of_ne_bot h hX) with c hc,
    use {c}, split,
    exact finset.singleton_subset_iff.2 hc, split,
    rw linear_independent_subtype, intros l hlm hl,
    cases subset_singleton ((finsupp.mem_supported _ _).1 hlm) with hl0 hlc,
    rw ←finsupp.support_eq_empty, exact hl0,
    rw single_of_singleton_support hlc at hl ⊢,
    rw finsupp.total_single at hl,
    rw finsupp.single_eq_zero,
    exact or.resolve_right (htf ⟨c, hY hc⟩ (l c) (subtype.ext_iff.2 $ hl))
      (λ h0, (finset.mem_erase.1 hc).1 $ subtype.ext_iff.1 h0),
    exact finset.card_singleton _,
     }⟩ n.succ (by {split, exact nat.lt_succ_self _, rw nat.succ_le_iff, simp only [n], erw ←hs.2.2,
     apply finset.card_lt_card, rw finset.ssubset_iff_of_subset, use x,
     rw ←finset.mem_sdiff, exact hx, exact hs.1}),
     exact huh ⟨(insert x s), by {split, rw finset.insert_subset,split,
     exact (finset.mem_sdiff.1 hx).1, exact hs.1, split,
     simp only [*, not_exists, set.diff_singleton_subset_iff, submodule.mem_coe,
     finset.coe_erase, not_and, finset.mem_sdiff, ne.def,
   set.insert_eq_of_mem, submodule.zero_mem, finset.mem_erase] at *, convert hnl,
   all_goals {try {exact finset.coe_insert _ _}},
     rw finset.card_insert_of_not_mem, rw hs.2.2, exact (finset.mem_sdiff.1 hx).2,
      }⟩, },
  unfold linear_independent at hnl,
set r : R := finset.prod (finset.image (λ w : (↑(Y \ s) : set M),
   dep_coeff s (w : M) $ hnl w w.2) (@finset.univ (↑(Y \ s) : set M) _)) id,
 have hr0 : r ≠ 0 := prod_ne_zero Y s hnl hs.2.1,
  have hrX : ∀ x, x ∈ X → r • x ∈ submodule.span R (↑s : set M) := sorry,
  have hrS : ∀ x, x ∈ S → r • x ∈ submodule.span R (↑s : set M) := λ w hw,
  by {rw ←hX at hw, rw ←set.image_id (↑X : set M) at hw, rcases
  (finsupp.mem_span_iff_total R).1 hw with ⟨f, hfm, hf⟩,
  rw ←hf, rw finsupp.total_apply, rw finsupp.smul_sum,
  apply submodule.sum_mem (submodule.span R (↑s : set M)), intros c hc,
  dsimp, rw ←mul_smul, rw mul_comm, rw mul_smul,
  apply submodule.smul_mem (submodule.span R (↑s : set M)) (f c),
  exact hrX c (hfm hc)
   },
  cases free_subm (↑s : set M) set.univ s.card (by { rw univ_card s, rw finset.card_univ,
  apply fintype.card_congr, symmetry,
  exact (equiv.set.univ _).symm,
  }) (submodule.span R (↑s : set M) : set M) (λ x, ⟨x, submodule.subset_span x.2⟩)
  ⟨sorry, sorry⟩ (submodule.comap (submodule.span R (↑s : set M)).subtype
    (submodule.map (r • linear_map.id) S)) with t ht,
  let T := (λ x, r • x)⁻¹' (subtype.val '' t),
  use T,
  split, simp only [],
  unfold linear_independent at *,
  rw eq_bot_iff at *,
  by_contradiction,
  rcases submodule.not_le_iff_exists.1 a with ⟨f, hfm, hf⟩,
  refine absurd ht.1 _,
  apply submodule.not_le_iff_exists.2,
  let sset : finset t := @finset.preimage _ _ (subtype.val ∘ subtype.val)
     (finset.image (λ x : T, r • (x : M)) f.1) sorry,
  let func : t → R := λ x, f.2 ⟨r • x, sorry⟩,
  let F : t →₀ R := ⟨sset, func, sorry⟩,
  use F,
  split,
    sorry, sorry,
  ext i, split,
  intro hmem,
  sorry, sorry,
  use (↑s : set M),
  split,
  exact hs.2.1,
  rw ←hX,
  have hsY : s = Y := le_antisymm hs.1 sorry,
  rw hsY,
  sorry,
end

theorem torsion_decomp {M : Type*} [add_comm_group M] [module R M] (S : submodule R M)
  (hfg : S.fg) : ∃ t : set S, linear_independent R (λ x, x : t → S) ∧
  (tors R S) ⊓ (submodule.span R t) = ⊥ ∧ (tors R S) ⊔ (submodule.span R t) = ⊤ :=
begin
  cases free_of_tf (tors R S).quotient ⊤ (fg_quotient S hfg (tors R S))
    (tf_iff.1 $ eq_bot_iff.2 $ λ b hb, by {have := eq_bot_iff.1 (tors_free_of_quotient R S),
    rcases hb with ⟨c, hc⟩,
    have h0 : c • (b : (tors R S).quotient) = 0 := by {rw ←submodule.coe_smul,
      rw ←@submodule.coe_zero R (tors R S).quotient _ _ _ ⊤, congr, exact hc.2 },
    have ffs := this ⟨c, hc.1, h0⟩,
    rw submodule.mem_bot at ffs ⊢, rw subtype.ext_iff,
    rw ffs, refl}
    ) with t ht,
  cases (projective_of_has_basis ht S (tors R S).quotient linear_map.id (tors R S).mkq
    (λ x, quotient.induction_on' x $ λ y, ⟨y, rfl⟩)) with f hf,
  have HP := split_of_left_inv (tors R S) (tors R S).mkq (by {rw submodule.ker_mkq,
    rw submodule.range_subtype}) f (linear_map.ext hf) (submodule.range_mkq _),
  use (set.range ((f : _ → S) ∘ subtype.val : t → S)),
  split,
  apply linear_independent.to_subtype_range,
  apply linear_independent.restrict_of_comp_subtype,
  rw linear_independent_comp_subtype,
  intros l hlm hl,
  apply (linear_independent_subtype.1 ht.1 l hlm),
  rw finsupp.total_apply at *,
  apply f.to_add_monoid_hom.injective_iff.1 (function.left_inverse.injective hf),
  rw ←hl,
  erw (finset.sum_hom l.support f).symm,
  apply finset.sum_congr rfl,
  intros x hx, dsimp,
  rw linear_map.map_smul,
  convert HP, all_goals
  {rw ←set.image_univ,
  rw set.image_comp, rw submodule.span_image,
  show _ = (⊤ : submodule R (tors R S).quotient).map f,
  congr, convert ht.2, rw set.image_univ, refl},
end

def tf_basis {M : Type*} [add_comm_group M] [module R M] (S : submodule R M)
  (hfg : S.fg) := classical.some (torsion_decomp S hfg)

theorem tf_basis_is_basis {M : Type*} [add_comm_group M] [module R M] (S : submodule R M)
  (hfg : S.fg) : linear_independent R (λ x, x : tf_basis S hfg → S) :=
(classical.some_spec (torsion_decomp S hfg)).1

theorem disjoint_tors_tf {M : Type*} [add_comm_group M] [module R M] {S : submodule R M}
  (hfg : S.fg) : (tors R S) ⊓ (submodule.span R $ tf_basis S hfg) = ⊥ :=
(classical.some_spec (torsion_decomp S hfg)).2.1

theorem tors_tf_span {M : Type*} [add_comm_group M] [module R M] {S : submodule R M}
  (hfg : S.fg) : (tors R S) ⊔ (submodule.span R $ tf_basis S hfg) = ⊤ :=
(classical.some_spec (torsion_decomp S hfg)).2.2


/-
Copyright (c) 2022 María Inés de Frutos-Fernández. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: María Inés de Frutos-Fernández
-/
import field_theory.ratfunc
import ring_theory.dedekind_domain.adic_valuation
import data.polynomial.basic
import analysis.special_functions.log.base
import basic

/-!
# Ostrowski's theorem for K(X)

## References
* https://kconrad.math.uconn.edu/blurbs/gradnumthy/ostrowskiF(T).pdf

## Tags
ring_norm, ostrowski
-/

noncomputable theory

open polynomial

open_locale polynomial big_operators

section infty

/-- The norm on K(X) associated to the place at infinity. -/
noncomputable! def mul_ring_norm.infty (K : Type*) [field K] [decidable_eq (ratfunc K)]
  (c : ℝ) (hc_pos : 0 < c) (hc_one_lt : 1 < c) : mul_ring_norm (ratfunc K) :=
{ to_fun := λ r, if r = 0 then 0 else c ^ r.int_degree,
  map_zero' := sorry,
  add_le' := sorry,
  neg' := λ r,
  begin
    by_cases r = 0,
    { simp only [h, neg_zero] } ,
    { have h₁ : ¬ -r = 0,
      { intro h₁,
        apply h,
        exact neg_eq_zero.1 h₁ },
      simp only [h, h₁, ratfunc.int_degree_neg] }
  end,
  map_one' := sorry,
  map_mul' :=
  begin
    intros r s,
    simp [mul_eq_zero, ite_mul, mul_ite, mul_zero, zero_mul],
    by_cases r = 0 ∨ s = 0,
    { simp only [h, if_true],
      cases h,
      { simp only [h, eq_self_iff_true, if_true, if_t_t] },
      { simp only [h, eq_self_iff_true, if_true] } },
    { simp only [h, if_false],
      rw not_or_distrib at h,
      cases h with h₁ h₂,
      simp only [h₁, h₂, if_false],
      rw ratfunc.int_degree_mul h₁ h₂,
      repeat {rw ←real.rpow_int_cast},
      push_cast,
      exact real.rpow_add hc_pos _ _ }
  end,
  eq_zero_of_map_eq_zero' := λ x hx,
  begin
    by_contra,
    simp only [h, if_false] at hx,
    linarith [zpow_eq_zero hx],
  end }

@[simp] lemma mul_ring_norm.infty_def (K : Type*) [field K] [decidable_eq (ratfunc K)] (c : ℝ)
  (hc_pos : 0 < c) (hc_one_lt : 1 < c) (r : ratfunc K):
    mul_ring_norm.infty K c hc_pos hc_one_lt r = if r = 0 then 0 else c ^ r.int_degree := rfl

lemma mul_ring_norm.infty_is_nonarchimedean (K : Type*) [field K] [decidable_eq (ratfunc K)] (c : ℝ)
  (hc_pos : 0 < c) (hc_one_lt : 1 < c) :
  is_nonarchimedean (mul_ring_norm.infty K c hc_pos hc_one_lt) :=
begin
  intros r s,
  simp only [mul_ring_norm.infty_def, le_max_iff],
  by_cases r + s = 0,
  { simp only [h, eq_self_iff_true, if_true],
    sorry},
  { simp only [h, if_false],
    by_cases h₁ : r = 0,
    { right,
      have h₂ : ¬ s = 0,
      { intro h₃,
        apply h,
        simp only [h₁, h₃, add_zero] },
      simp only [h₁, h₂, zero_add, if_false] },
    { have h₂ : ¬ s = 0 := sorry, -- this is false,
      simp only [h₁, h₂, if_false],

      sorry} }
end

end infty

/-- The maximal ideal on K[X] generated by an irreducible polynomial. -/
def polynomial.maximal_ideal_of_irreducible {K : Type*} [field K] [decidable_eq (ratfunc K)]
  {p : polynomial K} (hp : irreducible p) : is_dedekind_domain.height_one_spectrum (K[X]) :=
{ as_ideal := ideal.span({p}),
  is_prime := (ideal.span_singleton_prime (prime.ne_zero
    (principal_ideal_ring.irreducible_iff_prime.mp hp))).mpr
      (principal_ideal_ring.irreducible_iff_prime.mp hp),
  ne_bot   := by simp only [ne.def, ideal.span_singleton_eq_bot,
    prime.ne_zero (principal_ideal_ring.irreducible_iff_prime.mp hp), not_false_iff] }

section adic

/-- The norm on K(X) associated to an irreducible polynomial. -/
noncomputable! def mul_ring_norm.adic {K : Type*} [field K] [decidable_eq (ratfunc K)] (c : ℝ)
  (hc_pos : 0 < c) (hc_one_lt : 1 < c) {p : polynomial K} (hp : irreducible p) :
    mul_ring_norm (ratfunc K) :=
{ to_fun := λ r, if hr : r = 0 then 0 else c ^ multiplicative.to_add (with_zero.unzero
  ((@polynomial.maximal_ideal_of_irreducible K _ _ p hp).valuation.ne_zero_iff.mpr hr)),
  map_zero' := sorry,
  add_le' :=
  begin
    intros r s,
    by_cases r + s = 0,
    { simp only [h, dif_pos],
      by_cases hr : r = 0,
      { have hs : s = 0,
        {sorry},
        simp only [hs, hr, dif_pos],
        linarith },
      { have hs : ¬ s = 0,
        {sorry},
        simp only [hs, hr, not_false_iff, dif_neg],
        exact add_nonneg (zpow_nonneg (le_of_lt hc_pos) _)
          (zpow_nonneg (le_of_lt hc_pos) _) } },
    { simp only [h, not_false_iff, dif_neg],
      by_cases hr : r = 0,
      { have hs : ¬ s = 0,
        {sorry},
        simp only [hr, hs, not_false_iff, zero_add, dif_pos, dif_neg] },
      { by_cases hs : s = 0,
        {sorry},
        {sorry} } }
  end,
  neg' := sorry,
  map_one' := sorry,
  map_mul' :=
  begin
    intros x y,
    simp [mul_eq_zero, valuation.map_mul],
    by_cases (x = 0 ∨ y = 0),
    {sorry},
    { rw not_or_distrib at h,
      simp only [h.1, h.2, or_self, not_false_iff, dif_neg],
      rw ←@zpow_add₀ _ _ c (by linarith),
      congr,
      rw ←to_add_mul,
      congr,
      rw ←with_zero.coe_inj,
      push_cast,
      repeat {rw with_zero.coe_unzero} },
  end,
  eq_zero_of_map_eq_zero' :=
  begin
    intros x hx,
    by_contra,
    simp only [h, not_false_iff, dif_neg] at hx,
    linarith [zpow_eq_zero hx]
  end }

@[simp] lemma mul_ring_norm.adic_def {K : Type*} [field K] [decidable_eq (ratfunc K)]
  (c : ℝ) (hc_pos : 0 < c) (hc_one_lt : 1 < c) {p : polynomial K} (hp : irreducible p)
    (r : ratfunc K): mul_ring_norm.adic c hc_pos hc_one_lt hp r = if hr : r = 0 then 0 else
      c ^ multiplicative.to_add (with_zero.unzero ((
        @polynomial.maximal_ideal_of_irreducible K _ _ p hp).valuation.ne_zero_iff.mpr hr))
:= rfl

lemma mul_ring_norm.adic_is_nonarchimedean (K : Type*) [field K] [decidable_eq (ratfunc K)] (c : ℝ)
  (hc_pos : 0 < c) (hc_one_lt : 1 < c) {p : polynomial K} (hp : irreducible p) :
  is_nonarchimedean (@mul_ring_norm.adic K _ _ c hc_pos hc_one_lt p hp) :=
begin
  intros x y,
  simp only [nonempty_of_inhabited, mul_ring_norm.adic_def, le_max_iff],
  by_cases x + y = 0,
  {sorry},
  { simp only [h, not_false_iff, dif_neg],
    by_cases hx : x = 0,
    { have hy : ¬ y = 0,
      {sorry},
      simp only [hx, hy, not_false_iff, zero_add, dif_neg, le_refl, or_true] },
    { left,
      simp only [hx, not_false_iff, dif_neg],
      repeat {rw ←real.rpow_int_cast},
      apply real.rpow_le_rpow_of_exponent_le,
      { linarith },
      { sorry } } }
end

end adic

open filter

-- Done in PR17863
lemma Sum_le {R : Type*} [ring R] (f : mul_ring_norm R) (n : ℕ) {ι : ℕ → R} :
  f (∑ i in finset.range n, ι i) ≤ ∑ i in finset.range n, f (ι i) := sorry

-- Done in PR17863
lemma is_nonarchimedean_iff_exists_ne_zero_map_nat_mul_le_one {R : Type*}
  [comm_ring R] {f : mul_ring_norm R} :
    is_nonarchimedean f ↔ (∃ x : R, x ≠ 0 ∧ ∀ n : ℕ, f (n * x) ≤ 1) := sorry

lemma unknown_name1 {K : Type*} [field K] [decidable_eq (ratfunc K)]
  {f : mul_ring_norm (ratfunc K)} (hf_nontriv : f ≠ 1)
    (hf_triv_K : ∀ {x : K} (hx : x ≠ 0), f (ratfunc.C x) = 1) :
      is_nonarchimedean f :=
begin
  rw is_nonarchimedean_iff_exists_ne_zero_map_nat_mul_le_one,
  refine ⟨1, _⟩,
  simp only [ne.def, one_ne_zero, not_false_iff, mul_one, true_and],
  intro n,
  have hn1 : ratfunc.C (n : K) = (n : ratfunc K),
  { simp only [map_nat_cast] },
  by_cases h : (n : K) = 0,
  { have hn : (n : ratfunc K) = 0,
    { rw ← hn1,
      rw h,
      simp only [map_zero] },
    rw hn,
    simp only [map_zero, zero_le_one] },
  { specialize hf_triv_K h,
    rw hn1 at hf_triv_K,
    rw hf_triv_K }
end

lemma mul_ring_norm.is_nonarchimedaen_eq_max_of_neq {R : Type*} [non_assoc_ring R]
  {f : mul_ring_norm R} (hf : is_nonarchimedean f) {r s : R} (h_neq : f r ≠ f s) :
    f (r + s) = max (f r) (f s) :=
begin
  have hf₁ := hf,
  specialize hf r s,
  cases ne.lt_or_lt h_neq with h₁ h₂,
  { specialize hf₁ (r + s) (-r),
    simp only [add_neg_cancel_comm, map_neg_eq_map, le_max_iff] at hf₁,
    cases hf₁ with h₃ h₄,
    { have hrs : f r ≤ f s := by linarith,
      rw max_eq_right hrs at hf ⊢,
      linarith },
    { linarith } },
  { specialize hf₁ (r + s) (-s),
    simp only [add_neg_cancel_right, map_neg_eq_map, le_max_iff] at hf₁,
    cases hf₁ with h₃ h₄,
    { have hrs : f s ≤ f r := by linarith,
      rw max_eq_left hrs at hf ⊢,
      linarith },
    { linarith } }
end

lemma unknown_name {R : Type*} [non_assoc_ring R] {f : mul_ring_norm R}
  (hf : is_nonarchimedean f) (s : finset ℕ) {g : ℕ → R} {a : ℕ}
    (h_max : ∀ p : ℕ, f (g p) ≤ f (g a)) :
      f (∑ p in s, g p) = f (g a) :=
begin
  sorry
end

/-- Ostrowski's Theorem -/
theorem rat_ring_norm_p_adic_or_real' (K : Type*) [field K] [decidable_eq (ratfunc K)]
  (c : ℝ) (hc_pos : 0 < c) (hc_one_lt : 1 < c) (f : mul_ring_norm (ratfunc K))
    (hf_nontriv : f ≠ 1) (hf_triv_K : ∀ {x : K} (hx : x ≠ 0), f (ratfunc.C x) = 1) :
      (mul_ring_norm.equiv f (mul_ring_norm.infty K c hc_pos hc_one_lt)) ∨
        ∃ (p : K[X]) [hp : irreducible p],
          mul_ring_norm.equiv f (@mul_ring_norm.adic K _ _ c hc_pos hc_one_lt p hp) :=
begin
  by_cases 1 < f (ratfunc.mk X 1),
  { left,
    let c₁ := 1 / f (ratfunc.mk X 1),
    have hc₁ : 0 < c₁,
    {sorry}, -- easy
    have hc₂ : 0 ≤ c₁,
    { linarith [hc₁] },
    have hc₃ : c₁ ≠ 1,
    {sorry}, -- easy as well
    have hc : c ≠ 0,
    { linarith },
    have hc1 : 0 ≤ c,
    { linarith },
    have h₁ : ∀ x : K[X], f (ratfunc.mk x 1) = c₁ ^ -(x.nat_degree : ℝ),
    { intro x,
      nth_rewrite 0 as_sum_support_C_mul_X_pow x,
      have h₁ : ratfunc.mk (x.support.sum (λ (i : ℕ), C (x.coeff i) * X ^ i)) 1
      = ∑ p in x.support, (ratfunc.mk (C (x.coeff p) * X ^ p) 1),
      {sorry},
      rw h₁, clear h₁,
      have h₂ : ∀ (p : ℕ), f (ratfunc.mk (C (x.coeff p) * X ^ p) 1)
        ≤ f (ratfunc.mk (C (x.coeff (nat_degree x)) * X ^ (nat_degree x)) 1),
      {sorry},
      have hf : is_nonarchimedean f,
      { exact unknown_name1 hf_nontriv @hf_triv_K },
      rw unknown_name hf (x.support) h₂,
      clear h₂,
      have h₃ : f (ratfunc.mk (C (x.coeff x.nat_degree) * X ^ x.nat_degree) 1)
         = f (ratfunc.mk (C (x.coeff x.nat_degree)) 1) * f (ratfunc.mk (X ^ x.nat_degree) 1),
      {sorry},
      rw h₃,
      clear h₃,
      have h₄ : f (ratfunc.mk (C (x.coeff x.nat_degree)) 1) = 1,
      {sorry},
      rw h₄,
      clear h₄,
      rw one_mul,
      have h₅ : f (ratfunc.mk (X ^ x.nat_degree) 1) = (f (ratfunc.mk X 1)) ^ (x.nat_degree),
      {sorry},
      rw h₅,
      clear h₅,
      dsimp [c₁],
      rw one_div,
      rw ←real.rpow_neg_one,
      rw ←real.rpow_mul,
      { simp only [neg_mul, one_mul, neg_neg, real.rpow_nat_cast] },
      sorry}, -- main step here
    refine ⟨-real.logb c₁ c, _, _⟩,
    {sorry}, -- 0 < -real.logb c₁ c-
    { ext,
      rw [mul_ring_norm.infty_def],
      by_cases h₂ : x = 0,
      {sorry}, -- easy
      { simp only [h₂, if_false],
        have h₃ := h₁ (x.num),
        specialize h₁ x.denom,
        have h₄ : x = (ratfunc.mk x.num 1) / (ratfunc.mk x.denom 1),
        {sorry}, -- quite tricky here
        rw h₄,
        have h₅ : f (ratfunc.mk x.num 1 / ratfunc.mk x.denom 1) = f (ratfunc.mk x.num 1) / f (ratfunc.mk x.denom 1),
        {sorry}, -- This should be a separate lemma
        rw h₅,
        rw [h₁, h₃],
        rw ←real.rpow_sub hc₁,
        field_simp,
        rw ←real.rpow_mul hc₂,
        rw ←neg_mul_comm,
        field_simp,
        rw mul_comm,
        rw real.rpow_mul hc₂,
        rw real.rpow_logb_eq_abs hc₁ hc₃ hc,
        rw abs_eq_self.2 hc1,
        dsimp [ratfunc.int_degree],
        rw ←real.rpow_int_cast,
        push_cast } } },
  { right,
    sorry}
end


import Mathbin

open MvPolynomial

@[simp]
lemma eq_zero_of_zero_eq (R : Type u) [HasZero R] (r : R) : 0 = r ↔ r = 0 :=
  by exact eq_comm

@[simp] lemma zero_sub_eq_iff (R : Type u) [AddCommGroup R] (a b : R) : 0 - a = b ↔ a + b = 0 := by
  apply Iff.intro
  · intro h
    rw [←h]
    sorry
  · sorry

register_simp_attr polynomial_nf
  "Attribute for lemmas that are used in the conversion of mv_polynomial expressions to a normal form consisting of adds of sums of muls of mv_polynomials"

attribute [polynomial_nf] Polynomial.eval₂
attribute [polynomial_nf] Polynomial.sum
attribute [polynomial_nf] Finsupp.sum
attribute [polynomial_nf] mul_add
attribute [polynomial_nf] add_mul
attribute [polynomial_nf] Finset.sum_mul
attribute [polynomial_nf] Finset.mul_sum
attribute [polynomial_nf] Finset.sum_add_distrib
attribute [polynomial_nf] mul_assoc
attribute [polynomial_nf] finsupp.smul_sum
attribute [polynomial_nf] mul_smul_comm
attribute [polynomial_nf] smul_add
attribute [polynomial_nf] mul_smul
attribute [polynomial_nf] smul_mul_assoc

register_simp_attr polynomial_nf_2
  "Attribute for lemmas that are used in the conversion of mv_polynomial expressions to a normal form consisting of adds of sums of muls of mv_polynomials"

attribute [polynomial_nf_2] mul_add
attribute [polynomial_nf_2] add_mul
attribute [polynomial_nf_2] finset.sum_add_distrib
attribute [polynomial_nf_2] sum_X_mul
attribute [polynomial_nf_2] sum_C_mul
attribute [polynomial_nf_2] rearrange_constants_right
attribute [polynomial_nf_2] rearrange_constants_right_with_extra
attribute [polynomial_nf_2] rearrange_sums_right
attribute [polynomial_nf_2] rearrange_sums_right_with_extra
attribute [polynomial_nf_2] C_mul_C
attribute [polynomial_nf_2] finset.sum_hom
attribute [polynomial_nf_2] mv_polynomial.smul_eq_C_mul
attribute [polynomial_nf_2] mul_assoc
attribute [polynomial_nf_2] finsupp.smul_sum
attribute [polynomial_nf_2] mul_smul_comm
attribute [polynomial_nf_2] smul_add
attribute [polynomial_nf_2] mul_smul
attribute [polynomial_nf_2] smul_mul_assoc

register_simp_attr polynomial_nf_3
  "Attribute for lemmas that are used in the conversion of mv_polynomial expressions to a normal form consisting of adds of sums of muls of mv_polynomials"

attribute [polynomial_nf_3] mul_add
attribute [polynomial_nf_3] add_mul
attribute [polynomial_nf_3] finset.sum_add_distrib
attribute [polynomial_nf_3] mul_sum_symm
attribute [polynomial_nf_3] rearrange_constants_right
attribute [polynomial_nf_3] rearrange_constants_right_with_extra
attribute [polynomial_nf_3] rearrange_sums_right
attribute [polynomial_nf_3] rearrange_sums_right_with_extra
attribute [polynomial_nf_3] C_mul_C
attribute [polynomial_nf_3] finset.sum_hom
attribute [polynomial_nf_3] mv_polynomial.smul_eq_C_mul
attribute [polynomial_nf_3] mul_assoc


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import category_theory.adjunction.basic
import category_theory.category.preorder
import category_theory.isomorphism_classes
import category_theory.thin

/-!
# Skeleton of a category

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

Define skeletal categories as categories in which any two isomorphic objects are equal.

Construct the skeleton of an arbitrary category by taking isomorphism classes, and show it is a
skeleton of the original category.

In addition, construct the skeleton of a thin category as a partial ordering, and (noncomputably)
show it is a skeleton of the original category. The advantage of this special case being handled
separately is that lemmas and definitions about orderings can be used directly, for example for the
subobject lattice. In addition, some of the commutative diagrams about the functors commute
definitionally on the nose which is convenient in practice.
-/

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

namespace category_theory

open category

variables (C : Type u₁) [category.{v₁} C]
variables (D : Type u₂) [category.{v₂} D]
variables {E : Type u₃} [category.{v₃} E]

/-- A category is skeletal if isomorphic objects are equal. -/
def skeletal : Prop := ∀ ⦃X Y : C⦄, is_isomorphic X Y → X = Y

/--
`is_skeleton_of C D F` says that `F : D ⥤ C` exhibits `D` as a skeletal full subcategory of `C`,
in particular `F` is a (strong) equivalence and `D` is skeletal.
-/
structure is_skeleton_of (F : D ⥤ C) :=
(skel : skeletal D)
(eqv : is_equivalence F)

local attribute [instance] is_isomorphic_setoid

variables {C D}
/-- If `C` is thin and skeletal, then any naturally isomorphic functors to `C` are equal. -/
lemma functor.eq_of_iso {F₁ F₂ : D ⥤ C} [quiver.is_thin C] (hC : skeletal C)
  (hF : F₁ ≅ F₂) : F₁ = F₂ :=
functor.ext (λ X, hC ⟨hF.app X⟩) (λ _ _ _, subsingleton.elim _ _)

/--
If `C` is thin and skeletal, `D ⥤ C` is skeletal.
`category_theory.functor_thin` shows it is thin also.
-/
lemma functor_skeletal [quiver.is_thin C] (hC : skeletal C) : skeletal (D ⥤ C) :=
λ F₁ F₂ h, h.elim (functor.eq_of_iso hC)
variables (C D)

/--
Construct the skeleton category as the induced category on the isomorphism classes, and derive
its category structure.
-/
@[derive category]
def skeleton : Type u₁ := induced_category C quotient.out

instance [inhabited C] : inhabited (skeleton C) := ⟨⟦default⟧⟩

/-- The functor from the skeleton of `C` to `C`. -/
@[simps, derive [full, faithful]]
noncomputable def from_skeleton : skeleton C ⥤ C := induced_functor _

instance : ess_surj (from_skeleton C) :=
{ mem_ess_image := λ X, ⟨quotient.mk X, quotient.mk_out X⟩ }

noncomputable instance : is_equivalence (from_skeleton C) :=
equivalence.of_fully_faithfully_ess_surj (from_skeleton C)

/-- The equivalence between the skeleton and the category itself. -/
noncomputable def skeleton_equivalence : skeleton C ≌ C :=
(from_skeleton C).as_equivalence

lemma skeleton_skeletal : skeletal (skeleton C) :=
begin
  rintro X Y ⟨h⟩,
  have : X.out ≈ Y.out := ⟨(from_skeleton C).map_iso h⟩,
  simpa using quotient.sound this,
end

/-- The `skeleton` of `C` given by choice is a skeleton of `C`. -/
noncomputable def skeleton_is_skeleton : is_skeleton_of C (skeleton C) (from_skeleton C) :=
{ skel := skeleton_skeletal C,
  eqv := from_skeleton.is_equivalence C }

section
variables {C D}

/--
Two categories which are categorically equivalent have skeletons with equivalent objects.
-/
noncomputable
def equivalence.skeleton_equiv (e : C ≌ D) : skeleton C ≃ skeleton D :=
let f := ((skeleton_equivalence C).trans e).trans (skeleton_equivalence D).symm in
{ to_fun := f.functor.obj,
  inv_fun := f.inverse.obj,
  left_inv := λ X, skeleton_skeletal C ⟨(f.unit_iso.app X).symm⟩,
  right_inv := λ Y, skeleton_skeletal D ⟨(f.counit_iso.app Y)⟩, }

end

/--
Construct the skeleton category by taking the quotient of objects. This construction gives a
preorder with nice definitional properties, but is only really appropriate for thin categories.
If your original category is not thin, you probably want to be using `skeleton` instead of this.
-/
def thin_skeleton : Type u₁ := quotient (is_isomorphic_setoid C)

instance inhabited_thin_skeleton [inhabited C] : inhabited (thin_skeleton C) :=
⟨quotient.mk default⟩

instance thin_skeleton.preorder : preorder (thin_skeleton C) :=
{ le := quotient.lift₂ (λ X Y, nonempty (X ⟶ Y))
  begin
    rintros _ _ _ _ ⟨i₁⟩ ⟨i₂⟩,
    exact propext ⟨nonempty.map (λ f, i₁.inv ≫ f ≫ i₂.hom),
      nonempty.map (λ f, i₁.hom ≫ f ≫ i₂.inv)⟩,
  end,
  le_refl :=
  begin
    refine quotient.ind (λ a, _),
    exact ⟨𝟙 _⟩,
  end,
  le_trans := λ a b c, quotient.induction_on₃ a b c $ λ A B C, nonempty.map2 (≫) }

/-- The functor from a category to its thin skeleton. -/
@[simps]
def to_thin_skeleton : C ⥤ thin_skeleton C :=
{ obj := quotient.mk,
  map := λ X Y f, hom_of_le (nonempty.intro f) }

/-!
The constructions here are intended to be used when the category `C` is thin, even though
some of the statements can be shown without this assumption.
-/
namespace thin_skeleton

/-- The thin skeleton is thin. -/
instance thin : quiver.is_thin (thin_skeleton C) :=
λ _ _, ⟨by { rintros ⟨⟨f₁⟩⟩ ⟨⟨f₂⟩⟩, refl }⟩

variables {C} {D}

/-- A functor `C ⥤ D` computably lowers to a functor `thin_skeleton C ⥤ thin_skeleton D`. -/
@[simps]
def map (F : C ⥤ D) : thin_skeleton C ⥤ thin_skeleton D :=
{ obj := quotient.map F.obj $ λ X₁ X₂ ⟨hX⟩, ⟨F.map_iso hX⟩,
  map := λ X Y, quotient.rec_on_subsingleton₂ X Y $
           λ x y k, hom_of_le (k.le.elim (λ t, ⟨F.map t⟩)) }

lemma comp_to_thin_skeleton (F : C ⥤ D) : F ⋙ to_thin_skeleton D = to_thin_skeleton C ⋙ map F :=
rfl

/-- Given a natural transformation `F₁ ⟶ F₂`, induce a natural transformation `map F₁ ⟶ map F₂`.-/
def map_nat_trans {F₁ F₂ : C ⥤ D} (k : F₁ ⟶ F₂) : map F₁ ⟶ map F₂ :=
{ app := λ X, quotient.rec_on_subsingleton X (λ x, ⟨⟨⟨k.app x⟩⟩⟩) }

-- TODO: state the lemmas about what happens when you compose with `to_thin_skeleton`
/-- A functor `C ⥤ D ⥤ E` computably lowers to a functor
`thin_skeleton C ⥤ thin_skeleton D ⥤ thin_skeleton E` -/
@[simps]
def map₂ (F : C ⥤ D ⥤ E) :
  thin_skeleton C ⥤ thin_skeleton D ⥤ thin_skeleton E :=
{ obj := λ x,
  { obj := λ y, quotient.map₂ (λ X Y, (F.obj X).obj Y)
                (λ X₁ X₂ ⟨hX⟩ Y₁ Y₂ ⟨hY⟩, ⟨(F.obj X₁).map_iso hY ≪≫ (F.map_iso hX).app Y₂⟩) x y,
    map := λ y₁ y₂, quotient.rec_on_subsingleton x $
            λ X, quotient.rec_on_subsingleton₂ y₁ y₂ $
              λ Y₁ Y₂ hY, hom_of_le (hY.le.elim (λ g, ⟨(F.obj X).map g⟩)) },
  map := λ x₁ x₂, quotient.rec_on_subsingleton₂ x₁ x₂ $
           λ X₁ X₂ f,
           { app := λ y, quotient.rec_on_subsingleton y
              (λ Y, hom_of_le (f.le.elim (λ f', ⟨(F.map f').app Y⟩))) } }

variables (C)

section
variables [quiver.is_thin C]

instance to_thin_skeleton_faithful : faithful (to_thin_skeleton C) := {}

/-- Use `quotient.out` to create a functor out of the thin skeleton. -/
@[simps]
noncomputable def from_thin_skeleton : thin_skeleton C ⥤ C :=
{ obj := quotient.out,
  map := λ x y, quotient.rec_on_subsingleton₂ x y $
    λ X Y f,
            (nonempty.some (quotient.mk_out X)).hom
          ≫ f.le.some
          ≫ (nonempty.some (quotient.mk_out Y)).inv }

noncomputable instance from_thin_skeleton_equivalence : is_equivalence (from_thin_skeleton C) :=
{ inverse := to_thin_skeleton C,
  counit_iso := nat_iso.of_components (λ X, (nonempty.some (quotient.mk_out X))) (by tidy),
  unit_iso :=
    nat_iso.of_components
      (λ x, quotient.rec_on_subsingleton x
        (λ X, eq_to_iso (quotient.sound ⟨(nonempty.some (quotient.mk_out X)).symm⟩)))
      (by tidy) }

/-- The equivalence between the thin skeleton and the category itself. -/
noncomputable def equivalence : thin_skeleton C ≌ C :=
(from_thin_skeleton C).as_equivalence

variables {C}

lemma equiv_of_both_ways {X Y : C} (f : X ⟶ Y) (g : Y ⟶ X) : X ≈ Y :=
⟨iso_of_both_ways f g⟩

instance thin_skeleton_partial_order : partial_order (thin_skeleton C) :=
{ le_antisymm := quotient.ind₂
  begin
    rintros _ _ ⟨f⟩ ⟨g⟩,
    apply quotient.sound (equiv_of_both_ways f g),
  end,
  ..category_theory.thin_skeleton.preorder C }

lemma skeletal : skeletal (thin_skeleton C) :=
λ X Y, quotient.induction_on₂ X Y $ λ x y h, h.elim $ λ i, i.1.le.antisymm i.2.le

lemma map_comp_eq (F : E ⥤ D) (G : D ⥤ C) : map (F ⋙ G) = map F ⋙ map G :=
functor.eq_of_iso skeletal $
  nat_iso.of_components (λ X, quotient.rec_on_subsingleton X (λ x, iso.refl _)) (by tidy)

lemma map_id_eq : map (𝟭 C) = 𝟭 (thin_skeleton C) :=
functor.eq_of_iso skeletal $
  nat_iso.of_components (λ X, quotient.rec_on_subsingleton X (λ x, iso.refl _)) (by tidy)

lemma map_iso_eq {F₁ F₂ : D ⥤ C} (h : F₁ ≅ F₂) : map F₁ = map F₂ :=
functor.eq_of_iso skeletal { hom := map_nat_trans h.hom, inv := map_nat_trans h.inv }

/-- `from_thin_skeleton C` exhibits the thin skeleton as a skeleton. -/
noncomputable def thin_skeleton_is_skeleton : is_skeleton_of C (thin_skeleton C)
  (from_thin_skeleton C) :=
{ skel := skeletal,
  eqv := thin_skeleton.from_thin_skeleton_equivalence C }

noncomputable instance is_skeleton_of_inhabited :
  inhabited (is_skeleton_of C (thin_skeleton C) (from_thin_skeleton C)) :=
⟨thin_skeleton_is_skeleton⟩

end

variables {C}

/-- An adjunction between thin categories gives an adjunction between their thin skeletons. -/
def lower_adjunction
  (R : D ⥤ C) (L : C ⥤ D) (h : L ⊣ R) :
  thin_skeleton.map L ⊣ thin_skeleton.map R :=
adjunction.mk_of_unit_counit
{ unit :=
  { app := λ X,
    begin
      letI := is_isomorphic_setoid C,
      refine quotient.rec_on_subsingleton X (λ x, hom_of_le ⟨h.unit.app x⟩),
      -- TODO: make quotient.rec_on_subsingleton' so the letI isn't needed
    end },
  counit :=
  { app := λ X,
    begin
      letI := is_isomorphic_setoid D,
      refine quotient.rec_on_subsingleton X (λ x, hom_of_le ⟨h.counit.app x⟩),
    end } }

end thin_skeleton

open thin_skeleton

section
variables {C} {α : Type*} [partial_order α]

/--
When `e : C ≌ α` is a categorical equivalence from a thin category `C` to some partial order `α`,
the `thin_skeleton C` is order isomorphic to `α`.
-/
noncomputable
def equivalence.thin_skeleton_order_iso
  [quiver.is_thin C] (e : C ≌ α) : thin_skeleton C ≃o α :=
((thin_skeleton.equivalence C).trans e).to_order_iso

end

end category_theory


/-
Copyright (c) 2020 Kevin Buzzard. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kevin Buzzard, Calle Sönne
-/

import topology.category.CompHaus
import topology.connected
import topology.subset_properties
import category_theory.adjunction.reflective
import category_theory.monad.limits

/-!
# The category of Profinite Types

We construct the category of profinite topological spaces,
often called profinite sets -- perhaps they could be called
profinite types in Lean.

The type of profinite topological spaces is called `Profinite`. It has a category
instance and is a fully faithful subcategory of `Top`. The fully faithful functor
is called `Profinite_to_Top`.

## Implementation notes

A profinite type is defined to be a topological space which is
compact, Hausdorff and totally disconnected.

## TODO

0. Link to category of projective limits of finite discrete sets.
1. finite coproducts
2. Clausen/Scholze topology on the category `Profinite`.

## Tags

profinite

-/

open category_theory

/-- The type of profinite topological spaces. -/
structure Profinite :=
(to_Top : Top)
[is_compact : compact_space to_Top]
[is_t2 : t2_space to_Top]
[is_totally_disconnected : totally_disconnected_space to_Top]

namespace Profinite

instance : inhabited Profinite := ⟨{to_Top := { α := pempty }}⟩

instance category : category Profinite := induced_category.category to_Top
instance concrete_category : concrete_category Profinite := induced_category.concrete_category _
instance has_forget₂ : has_forget₂ Profinite Top := induced_category.has_forget₂ _

instance : has_coe_to_sort Profinite := ⟨Type*, λ X, X.to_Top⟩
instance {X : Profinite} : compact_space X := X.is_compact
instance {X : Profinite} : t2_space X := X.is_t2
instance {X : Profinite} : totally_disconnected_space X := X.is_totally_disconnected

@[simp]
lemma coe_to_Top {X : Profinite} : (X.to_Top : Type*) = X :=
rfl

@[simp] lemma coe_id (X : Profinite) : (𝟙 X : X → X) = id := rfl

@[simp] lemma coe_comp {X Y Z : Profinite} (f : X ⟶ Y) (g : Y ⟶ Z) : (f ≫ g : X → Z) = g ∘ f := rfl

end Profinite

/-- The fully faithful embedding of `Profinite` in `Top`. -/
@[simps, derive [full, faithful]]
def Profinite_to_Top : Profinite ⥤ Top := forget₂ _ _

/-- The fully faithful embedding of `Profinite` in `CompHaus`. -/
@[simps] def Profinite.to_CompHaus : Profinite ⥤ CompHaus :=
{ obj := λ X, { to_Top := X.to_Top },
  map := λ _ _ f, f }

instance : full Profinite.to_CompHaus := { preimage := λ _ _ f, f }
instance : faithful Profinite.to_CompHaus := {}

@[simp] lemma Profinite.to_CompHaus_to_Top :
  Profinite.to_CompHaus ⋙ CompHaus_to_Top = Profinite_to_Top :=
rfl

section Profinite
local attribute [instance] connected_component_setoid

universes u

/--
(Implementation) The object part of the connected_components functor from compact Hausdorff spaces
to Profinite spaces, given by quotienting a space by its connected components.
See: https://stacks.math.columbia.edu/tag/0900
-/
-- Without explicit universe annotations here, Lean introduces two universe variables and
-- unhelpfully defines a function `CompHaus.{max u₁ u₂} → Profinite.{max u₁ u₂}`.
def CompHaus.to_Profinite_obj (X : CompHaus.{u}) : Profinite.{u} :=
{ to_Top := { α := connected_components X.to_Top.α },
  is_compact := quotient.compact_space,
  is_t2 := connected_components.t2,
  is_totally_disconnected := connected_components.totally_disconnected_space }

/--
(Implementation) The bijection of homsets to establish the reflective adjunction of Profinite
spaces in compact Hausdorff spaces.
-/
def Profinite.to_CompHaus_equivalence (X : CompHaus.{u}) (Y : Profinite.{u}) :
  (CompHaus.to_Profinite_obj X ⟶ Y) ≃ (X ⟶ Profinite.to_CompHaus.obj Y) :=
{ to_fun := λ f,
  { to_fun := f.1 ∘ quotient.mk,
    continuous_to_fun := continuous.comp f.2 (continuous_quotient_mk) },
  inv_fun := λ g,
    { to_fun := continuous.connected_components_lift g.2,
      continuous_to_fun := continuous.connected_components_lift_continuous g.2},
  left_inv := λ f, continuous_map.ext $ λ x, quotient.induction_on x $ λ a, rfl,
  right_inv := λ f, continuous_map.ext $ λ x, rfl }

/--
The connected_components functor from compact Hausdorff spaces to profinite spaces,
left adjoint to the inclusion functor.
-/
def CompHaus.to_Profinite : CompHaus ⥤ Profinite :=
adjunction.left_adjoint_of_equiv Profinite.to_CompHaus_equivalence (λ _ _ _ _ _, rfl)

lemma CompHaus.to_Profinite_obj' (X : CompHaus) :
  ↥(CompHaus.to_Profinite.obj X) = connected_components X.to_Top.α := rfl

end Profinite

namespace Profinite

/--
The adjunction between CompHaus.to_Profinite and Profinite.to_CompHaus
-/
def to_Profinite_adj_to_CompHaus : CompHaus.to_Profinite ⊣ Profinite.to_CompHaus :=
adjunction.adjunction_of_equiv_left _ _

/-- The category of profinite sets is reflective in the category of compact hausdroff spaces -/
instance to_CompHaus.reflective : reflective Profinite.to_CompHaus :=
{ to_is_right_adjoint := ⟨CompHaus.to_Profinite, Profinite.to_Profinite_adj_to_CompHaus⟩ }

noncomputable
instance to_CompHaus.creates_limits : creates_limits Profinite.to_CompHaus :=
monadic_creates_limits _

noncomputable
instance to_Top.reflective : reflective (Profinite_to_Top : Profinite ⥤ Top) :=
reflective.comp Profinite.to_CompHaus CompHaus_to_Top

noncomputable
instance to_Top.creates_limits : creates_limits Profinite_to_Top :=
monadic_creates_limits _

instance has_limits : limits.has_limits Profinite :=
has_limits_of_has_limits_creates_limits Profinite_to_Top

instance has_colimits : limits.has_colimits Profinite :=
has_colimits_of_reflective to_CompHaus

/-- Any morphism of profinite spaces is a closed map. -/
lemma is_closed_map {X Y : Profinite} (f : X ⟶ Y) : is_closed_map f :=
show is_closed_map (Profinite.to_CompHaus.map f), from CompHaus.is_closed_map _

/-- Any continuous bijection of profinite spaces induces an isomorphism. -/
lemma is_iso_of_bijective {X Y : Profinite} (f : X ⟶ Y)
  (bij : function.bijective f) : is_iso f :=
begin
  haveI := CompHaus.is_iso_of_bijective (Profinite.to_CompHaus.map f) bij,
  exact is_iso_of_fully_faithful Profinite.to_CompHaus _
end

/-- Any continuous bijection of profinite spaces induces an isomorphism. -/
noncomputable def iso_of_bijective {X Y : Profinite} (f : X ⟶ Y)
  (bij : function.bijective f) : X ≅ Y :=
by letI := Profinite.is_iso_of_bijective f bij; exact as_iso f

instance forget_reflects_isomorphisms : reflects_isomorphisms (forget Profinite) :=
⟨by introsI A B f hf; exact Profinite.is_iso_of_bijective _ ((is_iso_iff_bijective ⇑f).mp hf)⟩

end Profinite


import inner_product_spaces.real_ip.ip_normed_space
import linear_algebra.basic
import analysis.normed_space.bounded_linear_maps
import data.set.countable
import linear_algebra.linear_combination

noncomputable theory

variables {α : Type*} {β : Type*}
variables [decidable_eq α] [add_comm_group α] [vector_space ℝ α] [ℝ_inner_product_space α]
variables [decidable_eq β] [add_comm_group β] [vector_space ℝ β] [ℝ_inner_product_space β]

open real function

def ℝ_topological_space : topological_space ℝ := by apply_instance

def α_uniform_space : uniform_space α :=
begin
    have w := @ip_space_is_metric_space α _ _ _ _,
    exact @metric_space.to_uniform_space α w,
end

def α_topological_space : topological_space α := @uniform_space.to_topological_space α α_uniform_space

section ip_map

def ip_map (x : α) : linear_map ℝ α ℝ :=
begin
    refine_struct {..},
    use λ y, ⟪x ∥ y⟫,
    repeat {simp},
end

@[simp] lemma ip_map_to_fun (x : α) : ⇑(ip_map x) = λ y, ⟪x ∥ y⟫ := rfl

theorem ip_map_is_bounded_linear_map (x : α) : @is_bounded_linear_map ℝ _ α ip_space_is_normed_space ℝ _ (ip_map x) :=
begin
    constructor,
    constructor,
    repeat {simp},

    by_cases (x = 0),

    use 1,
    split,
    exact zero_lt_one,
    intros y,
    rw [h],
    simp,

    use ∥x∥,
    split,
    have w := (@norm_neq_zero_iff_neq_zero α (ip_space_is_normed_space) x).2 h,
    have α_normed_group : normed_group α := begin
        have w := @ip_space_is_normed_space α _ _ _ _,
        exact @normed_space.to_normed_group ℝ α _ w,
    end,
    have k := (@norm_pos_iff α α_normed_group x).2,
    rw [ne.def] at k,
    sorry,
    intros y,
    exact cauchy_schwarz x y,
end

lemma ip_map_is_continuous (x : α) : @continuous α _ α_topological_space ℝ_topological_space (ip_map x) :=
@is_bounded_linear_map.continuous ℝ _ α ip_space_is_normed_space ℝ _ _ (ip_map_is_bounded_linear_map x)

end ip_map

section hilbert_space

class Hilbert_space (α : Type*) [decidable_eq α] [add_comm_group α] [vector_space ℝ α] extends ℝ_inner_product_space α :=
(complete : ∀ {f : filter α}, (@cauchy α (@α_uniform_space α _ _ _ _)) f → ∃x, f ≤ @nhds α (@α_topological_space α _ _ _ _) x)

variables [Hilbert_space α] [Hilbert_space β]

structure unitary_operator (α : Type*) (β : Type*) [decidable_eq α] [add_comm_group α] [vector_space ℝ α] [ℝ_inner_product_space α] [Hilbert_space α]
[decidable_eq β] [add_comm_group β] [vector_space ℝ β] [ℝ_inner_product_space β] [Hilbert_space β] extends linear_map ℝ α β :=
(bijective : bijective to_fun)
(norm_preserving : ∀ (x : α), ∥to_fun x∥ = ∥x∥)

variables {T : unitary_operator α β}

@[simp] lemma norm_preserving (x : α) : ∥T.to_fun x∥ = ∥x∥ :=
by apply unitary_operator.norm_preserving

lemma polarisation_identity (x y : α) : ⟪x ∥ y⟫ = 1/4*(∥x+y∥^2 - ∥x-y∥^2) :=
begin
    conv {to_lhs, rw [←one_mul ⟪x ∥ y⟫, ←@inv_mul_cancel _ _ (4 : ℝ) four_ne_zero]},
    rw [←one_div_eq_inv, mul_assoc],
    apply congr_arg (λ (r : ℝ), 1/4 * r),
    dsimp [norm],
    rw [sqr_sqrt (norm_sq_nonneg _), sqr_sqrt (norm_sq_nonneg _)],
    dsimp [norm_sq],
    rw [add_left, add_left, add_right, add_right, add_right, add_right, ←neg_one_smul ℝ y,
    mul_left, mul_left, mul_right, mul_right, conj_symm y x],
    ring,
end

@[simp] theorem ip_preserving (x y : α) : ⟪T.to_fun x ∥ T.to_fun y⟫ = ⟪x ∥ y⟫ :=
begin
    rw [polarisation_identity (T.to_fun x) (T.to_fun y), ←linear_map.add,
        sub_eq_add_neg (T.to_fun x) (T.to_fun y), ←neg_one_smul ℝ (T.to_fun y),
        ←linear_map.smul, ←linear_map.add, norm_preserving, norm_preserving,
        neg_one_smul, ←sub_eq_add_neg, ←polarisation_identity],
end

end hilbert_space

open set finsupp

section separable

-- def coeff_sum (f : α →₀ ℝ) : finset.sum (finset.map (λ (a : α), f a • a) f.support)

local attribute [instance, priority 0] classical.prop_decidable
noncomputable theory

-- def lc.total' {α β} [discrete_field α] [add_comm_group β] [vector_space α β] (f : β →₀ α) : β := (lc.total _ _ _ id).1 f
-- variables [Hilbert_space α]
-- variables (sep : ∃ (S : set α), countable S ∧ ∀ (x : α) (ε > 0), ∃ (f : α →₀ ℝ), ∥sum {z | ∃ (e ∈ S), z = f e • e} - x∥ < ε)

end separable


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

import category_theory.morphism_property
import category_theory.category.Quiv

/-!

# Construction of the localized category

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

This file constructs the localized category, obtained by formally inverting
a class of maps `W : morphism_property C` in a category `C`.

We first construct a quiver `loc_quiver W` whose objects are the same as those
of `C` and whose maps are the maps in `C` and placeholders for the formal
inverses of the maps in `W`.

The localized category `W.localization` is obtained by taking the quotient
of the path category of `loc_quiver W` by the congruence generated by four
types of relations.

The obvious functor `Q W : C ⥤ W.localization` satisfies the universal property
of the localization. Indeed, if `G : C ⥤ D` sends morphisms in `W` to isomorphisms
in `D` (i.e. we have `hG : W.is_inverted_by G`), then there exists a unique functor
`G' : W.localization ⥤ D` such that `Q W ≫ G' = G`. This `G'` is `lift G hG`.
The expected property of `lift G hG` if expressed by the lemma `fac` and the
uniqueness is expressed by `uniq`.

## References

* [P. Gabriel, M. Zisman, *Calculus of fractions and homotopy theory*][gabriel-zisman-1967]

-/

noncomputable theory

open category_theory.category

namespace category_theory

variables {C : Type*} [category C] (W : morphism_property C) {D : Type*} [category D]

namespace localization

namespace construction

/-- If `W : morphism_property C`, `loc_quiver W` is a quiver with the same objects
as `C`, and whose morphisms are those in `C` and placeholders for formal
inverses of the morphisms in `W`. -/
@[nolint has_nonempty_instance]
structure loc_quiver (W : morphism_property C) := (obj : C)

instance : quiver (loc_quiver W) :=
{ hom := λ A B, (A.obj ⟶ B.obj) ⊕ { f : B.obj ⟶ A.obj // W f} }

/-- The object in the path category of `loc_quiver W` attached to an object in
the category `C` -/
def ι_paths (X : C) : paths (loc_quiver W) := ⟨X⟩

/-- The morphism in the path category associated to a morphism in the original category. -/
@[simp]
def ψ₁ {X Y : C} (f : X ⟶ Y) : ι_paths W X ⟶ ι_paths W Y := paths.of.map (sum.inl f)

/-- The morphism in the path category corresponding to a formal inverse. -/
@[simp]
def ψ₂ {X Y : C} (w : X ⟶ Y) (hw : W w) : ι_paths W Y ⟶ ι_paths W X :=
paths.of.map (sum.inr ⟨w, hw⟩)

/-- The relations by which we take the quotient in order to get the localized category. -/
inductive relations : hom_rel (paths (loc_quiver W))
| id (X : C) :
  relations (ψ₁ W (𝟙 X)) (𝟙 _)
| comp {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) :
  relations (ψ₁ W (f ≫ g)) (ψ₁ W f ≫ ψ₁ W g)
| Winv₁ {X Y : C} (w : X ⟶ Y) (hw : W w) :
  relations (ψ₁ W w ≫ ψ₂ W w hw) (𝟙 _)
| Winv₂ {X Y : C} (w : X ⟶ Y) (hw : W w) :
  relations (ψ₂ W w hw ≫ ψ₁ W w) (𝟙 _)

end construction

end localization

namespace morphism_property

open localization.construction

/-- The localized category obtained by formally inverting the morphisms
in `W : morphism_property C` -/
@[derive category, nolint has_nonempty_instance]
def localization := category_theory.quotient (localization.construction.relations W)

/-- The obvious functor `C ⥤ W.localization` -/
def Q : C ⥤ W.localization :=
{ obj := λ X, (quotient.functor _).obj (paths.of.obj ⟨X⟩),
  map := λ X Y f, (quotient.functor _).map (ψ₁ W f),
  map_id' := λ X, quotient.sound _ (relations.id X),
  map_comp' := λ X Z Y f g, quotient.sound _ (relations.comp f g), }

end morphism_property

namespace localization

namespace construction

variable {W}

/-- The isomorphism in `W.localization` associated to a morphism `w` in W -/
def Wiso {X Y : C} (w : X ⟶ Y) (hw : W w) : iso (W.Q.obj X) (W.Q.obj Y) :=
{ hom := W.Q.map w,
  inv := (quotient.functor _).map (paths.of.map (sum.inr ⟨w, hw⟩)),
  hom_inv_id' := quotient.sound _ (relations.Winv₁ w hw),
  inv_hom_id' := quotient.sound _ (relations.Winv₂ w hw), }

/-- The formal inverse in `W.localization` of a morphism `w` in `W`. -/
abbreviation Winv {X Y : C} (w : X ⟶ Y) (hw : W w) := (Wiso w hw).inv

variable (W)

lemma _root_.category_theory.morphism_property.Q_inverts : W.is_inverted_by W.Q :=
λ X Y w hw, is_iso.of_iso (localization.construction.Wiso w hw)

variables {W} (G : C ⥤ D) (hG : W.is_inverted_by G)

include G hG

/-- The lifting of a functor to the path category of `loc_quiver W` -/
@[simps]
def lift_to_path_category : paths (loc_quiver W) ⥤ D :=
Quiv.lift
{ obj := λ X, G.obj X.obj,
  map := λ X Y, begin
    rintro (f|⟨g, hg⟩),
    { exact G.map f, },
    { haveI := hG g hg,
      exact inv (G.map g), },
  end, }

/-- The lifting of a functor `C ⥤ D` inverting `W` as a functor `W.localization ⥤ D` -/
@[simps]
def lift : W.localization ⥤ D :=
quotient.lift (relations W) (lift_to_path_category G hG)
begin
  rintro ⟨X⟩ ⟨Y⟩ f₁ f₂ r,
  rcases r,
  tidy,
end

@[simp]
lemma fac : W.Q ⋙ lift G hG = G :=
functor.ext (λ X, rfl)
begin
  intros X Y f,
  simp only [functor.comp_map, eq_to_hom_refl, comp_id, id_comp],
  dsimp [lift, lift_to_path_category, morphism_property.Q],
  rw compose_path_to_path,
end

omit G hG

variable (W)

/-- The canonical bijection between objects in a category and its
localization with respect to a morphism_property `W` -/
@[simps]
def obj_equiv : C ≃ W.localization :=
{ to_fun := W.Q.obj,
  inv_fun := λ X, X.as.obj,
  left_inv := λ X, rfl,
  right_inv := by { rintro ⟨⟨X⟩⟩, refl, }, }

variable {W}

/-- A `morphism_property` in `W.localization` is satisfied by all
morphisms in the localized category if it contains the image of the
morphisms in the original category, the inverses of the morphisms
in `W` and if it is stable under composition -/
lemma morphism_property_is_top
  (P : morphism_property W.localization)
  (hP₁ : ∀ ⦃X Y : C⦄ (f : X ⟶ Y), P (W.Q.map f))
  (hP₂ : ∀ ⦃X Y : C⦄ (w : X ⟶ Y) (hw : W w), P (Winv w hw))
  (hP₃ : P.stable_under_composition) : P = ⊤ :=
begin
  ext X Y f,
  split,
  { intro hf,
    simp only [pi.top_apply], },
  { intro hf, clear hf,
    let G : _ ⥤ W.localization := quotient.functor _,
    suffices : ∀ (X₁ X₂ : C) (p : localization.construction.ι_paths W X₁ ⟶
      localization.construction.ι_paths W X₂), P (G.map p),
    { rcases X with ⟨⟨X⟩⟩,
      rcases Y with ⟨⟨Y⟩⟩,
      simpa only [functor.image_preimage] using this _ _ (G.preimage f), },
    intros X₁ X₂ p,
    induction p with X₂ X₃ p g hp,
    { simpa only [functor.map_id] using hP₁ (𝟙 X₁), },
    { cases X₂,
      cases X₃,
      let p' : ι_paths W X₁ ⟶ ι_paths W X₂ := p,
      rw [show p.cons g = p' ≫ quiver.hom.to_path g, by refl, G.map_comp],
      refine hP₃ _ _ hp _,
      rcases g with (g | ⟨g, hg⟩),
      { apply hP₁, },
      { apply hP₂, }, }, },
end

/-- A `morphism_property` in `W.localization` is satisfied by all
morphisms in the localized category if it contains the image of the
morphisms in the original category, if is stable under composition
and if the property is stable by passing to inverses. -/
lemma morphism_property_is_top'
  (P : morphism_property W.localization)
  (hP₁ : ∀ ⦃X Y : C⦄ (f : X ⟶ Y), P (W.Q.map f))
  (hP₂ : ∀ ⦃X Y : W.localization⦄ (e : X ≅ Y) (he : P e.hom), P e.inv)
  (hP₃ : P.stable_under_composition) : P = ⊤ :=
morphism_property_is_top P hP₁ (λ X Y w hw, hP₂ _ (by exact hP₁ w)) hP₃

namespace nat_trans_extension

variables {F₁ F₂ : W.localization ⥤ D} (τ : W.Q ⋙ F₁ ⟶ W.Q ⋙ F₂)
include τ

/-- If `F₁` and `F₂` are functors `W.localization ⥤ D` and if we have
`τ : W.Q ⋙ F₁ ⟶ W.Q ⋙ F₂`, we shall define a natural transformation `F₁ ⟶ F₂`.
This is the `app` field of this natural transformation. -/
def app (X : W.localization) : F₁.obj X ⟶ F₂.obj X :=
eq_to_hom (congr_arg F₁.obj ((obj_equiv W).right_inv X).symm) ≫
    τ.app ((obj_equiv W).inv_fun X) ≫ eq_to_hom (congr_arg F₂.obj ((obj_equiv W).right_inv X))

@[simp]
lemma app_eq (X : C) : (app τ) (W.Q.obj X) = τ.app X :=
by simpa only [app, eq_to_hom_refl, comp_id, id_comp]

end nat_trans_extension

/-- If `F₁` and `F₂` are functors `W.localization ⥤ D`, a natural transformation `F₁ ⟶ F₂`
can be obtained from a natural transformation `W.Q ⋙ F₁ ⟶ W.Q ⋙ F₂`. -/
@[simps]
def nat_trans_extension {F₁ F₂ : W.localization ⥤ D} (τ : W.Q ⋙ F₁ ⟶ W.Q ⋙ F₂) :
  F₁ ⟶ F₂ :=
{ app := nat_trans_extension.app τ,
  naturality' := λ X Y f, begin
    have h := morphism_property_is_top'
      (morphism_property.naturality_property (nat_trans_extension.app τ)) _
      (morphism_property.naturality_property.is_stable_under_inverse _)
      (morphism_property.naturality_property.is_stable_under_composition _), swap,
    { intros X Y f,
      simpa only [morphism_property.naturality_property, nat_trans_extension.app_eq]
        using τ.naturality f, },
    have hf : (⊤ : morphism_property _) f := by simp only [pi.top_apply],
    simpa only [← h] using hf,
  end,  }

@[simp]
lemma nat_trans_extension_hcomp {F G : W.localization ⥤ D} (τ : W.Q ⋙ F ⟶ W.Q ⋙ G) :
  (𝟙 W.Q) ◫ nat_trans_extension τ = τ :=
begin
  ext X,
  simp only [nat_trans.hcomp_app, nat_trans.id_app, G.map_id, comp_id,
    nat_trans_extension_app, nat_trans_extension.app_eq],
end

lemma nat_trans_hcomp_injective {F G : W.localization ⥤ D} {τ₁ τ₂ : F ⟶ G}
  (h : 𝟙 W.Q ◫ τ₁ = 𝟙 W.Q ◫ τ₂) : τ₁ = τ₂ :=
begin
  ext X,
  have eq := (obj_equiv W).right_inv X,
  simp only [obj_equiv] at eq,
  rw [← eq, ← nat_trans.id_hcomp_app, ← nat_trans.id_hcomp_app, h],
end

variables (W D)

namespace whiskering_left_equivalence

/-- The functor `(W.localization ⥤ D) ⥤ (W.functors_inverting D)` induced by the
composition with `W.Q : C ⥤ W.localization`. -/
@[simps]
def functor : (W.localization ⥤ D) ⥤ (W.functors_inverting D) :=
full_subcategory.lift _ ((whiskering_left _ _ D).obj W.Q)
  (λ F, morphism_property.is_inverted_by.of_comp W W.Q W.Q_inverts _)

/-- The function `(W.functors_inverting D) ⥤ (W.localization ⥤ D)` induced by
`construction.lift`. -/
@[simps]
def inverse : (W.functors_inverting D) ⥤ (W.localization ⥤ D) :=
{ obj := λ G, lift G.obj G.property,
  map := λ G₁ G₂ τ, nat_trans_extension (eq_to_hom (by rw fac) ≫ τ ≫ eq_to_hom (by rw fac)),
  map_id' := λ G, nat_trans_hcomp_injective begin
    rw nat_trans_extension_hcomp,
    ext X,
    simpa only [nat_trans.comp_app, eq_to_hom_app, eq_to_hom_refl, comp_id, id_comp,
      nat_trans.hcomp_id_app, nat_trans.id_app, functor.map_id],
  end,
  map_comp' := λ G₁ G₂ G₃ τ₁ τ₂, nat_trans_hcomp_injective begin
    ext X,
    simpa only [nat_trans_extension_hcomp, nat_trans.comp_app, eq_to_hom_app, eq_to_hom_refl,
      id_comp, comp_id, nat_trans.hcomp_app, nat_trans.id_app, functor.map_id,
      nat_trans_extension_app, nat_trans_extension.app_eq],
  end, }

/-- The unit isomorphism of the equivalence of categories `whiskering_left_equivalence W D`. -/
@[simps]
def unit_iso : 𝟭 (W.localization ⥤ D) ≅ functor W D ⋙ inverse W D := eq_to_iso
begin
  refine functor.ext (λ G, _) (λ G₁ G₂ τ, _),
  { apply uniq,
    dsimp [functor],
    rw fac, },
  { apply nat_trans_hcomp_injective,
    ext X,
    simp only [functor.id_map, nat_trans.hcomp_app, comp_id, functor.comp_map,
      inverse_map, nat_trans.comp_app, eq_to_hom_app, eq_to_hom_refl, nat_trans_extension_app,
      nat_trans_extension.app_eq, functor_map_app, id_comp], },
end

/-- The counit isomorphism of the equivalence of categories `whiskering_left_equivalence W D`. -/
@[simps]
def counit_iso : inverse W D ⋙ functor W D ≅ 𝟭 (W.functors_inverting D) := eq_to_iso
begin
  refine functor.ext _ _,
  { rintro ⟨G, hG⟩,
    ext1,
    apply fac, },
  { rintros ⟨G₁, hG₁⟩ ⟨G₂, hG₂⟩ f,
    ext X,
    apply nat_trans_extension.app_eq, },
end

end whiskering_left_equivalence

/-- The equivalence of categories `(W.localization ⥤ D) ≌ (W.functors_inverting D)`
induced by the composition with `W.Q : C ⥤ W.localization`. -/
def whiskering_left_equivalence : (W.localization ⥤ D) ≌ W.functors_inverting D :=
{ functor := whiskering_left_equivalence.functor W D,
  inverse := whiskering_left_equivalence.inverse W D,
  unit_iso := whiskering_left_equivalence.unit_iso W D,
  counit_iso := whiskering_left_equivalence.counit_iso W D,
  functor_unit_iso_comp' := λ F, begin
    ext X,
    simpa only [eq_to_hom_app, whiskering_left_equivalence.unit_iso_hom,
      whiskering_left_equivalence.counit_iso_hom, eq_to_hom_map, eq_to_hom_trans,
      eq_to_hom_refl],
  end, }

end construction

end localization

end category_theory


open Nat.SOM
example : (x + y) * (x + y + 1) = x * (1 + y + x) + (y + 1 + x) * y :=
  let ctx := [x, y]
  let lhs : Expr := .mul (.add (.var 0) (.var 1)) (.add (.add (.var 0) (.var 1)) (.num 1))
  let rhs : Expr := .add (.mul (.var 0) (.add (.add (.num 1) (.var 1)) (.var 0)))
                         (.mul (.add (.add (.var 1) (.num 1)) (.var 0)) (.var 1))
  Expr.eq_of_toPoly_eq ctx lhs rhs (Eq.refl true)


import analysis.real xenalib.M1Fstuff

theorem Q1 (S : set ℝ) (H1 : ∃ s : ℝ, s ∈ S) (H2 : ∃ b : ℝ, ∀ s : ℝ, s ∈ S → s ≤ b) :
  ∃ x : ℝ, is_lub S x ∧
  ∀ T : set ℝ, (T ⊆ S ∧ ∃ t : ℝ, t ∈ T) → ∃ y : ℝ, is_lub T y ∧ y ≤ x :=
begin
cases H1 with s₁ Hs₁,
cases H2 with b Hb,
have Hlub := exists_supremum_real Hs₁ Hb,
cases Hlub with x Hx,
existsi x,
split,exact Hx,
intros T HT,
have HT_bounded_above : ∀ t : ℝ, t ∈ T → t ≤ b,
{ intros t Ht,
  apply Hb,
  apply HT.left,
  exact Ht,
},
cases HT.right with t₁ Ht₁,
have HlubT := exists_supremum_real Ht₁ HT_bounded_above,
cases HlubT with y₁ Hy₁,
existsi y₁,
split, exact Hy₁,
apply Hy₁.right,
intro t₂,
intro Ht₂,
apply Hx.left,
apply HT.left,
exact Ht₂
end

noncomputable def decimal_expansion' (x : ℝ) (H1 : x ≥ 0) (H2 : x < 1) : ℕ → fin 10
| 0 := ⟨0,dec_trivial⟩
| (nat.succ m) := decimal_expansion' m
-- crap I can't do yhis

/-
noncomputable def decimal_expansion (x : ℝ) : ℤ × Π n : ℕ, fin 10 :=
begin
have H1 := M1F.floor_real_exists x,
have Hm := classical.indefinite_description _ H1,
cases Hm with m H1,
refine (m,_),
let y := x-m,
have H2 : y < 1,
simp [H1.right,add_comm],
exact (λ d, match d with
| 0 := ⟨0,dec_trivial⟩
| succ e := ⟨1,dec_trivial⟩
end),
admit,
end
-/
-- Author: Chris Hughes
import data.nat.modeq data.set.finite
open nat
local attribute [instance, priority 0] classical.prop_decidable
namespace set
open function
universe u
variable α : Type u

-- Two lemmas courtesy of Johannes Hölzl via gitter, due to be added to mathlib
lemma infinite_univ_nat : infinite (univ : set ℕ) :=
 assume (h : finite (univ : set ℕ)),
 let ⟨n, hn⟩ := finset.exists_nat_subset_range h.to_finset in
 have n ∈ finset.range n, from finset.subset_iff.mpr hn $ by simp,
 by simp * at *

lemma not_injective_nat_fintype [fintype α] [decidable_eq α] {f : ℕ → α} : ¬ injective f :=
 assume (h : injective f),
 have finite (f '' univ),
   from finite_subset (finset.finite_to_set $ fintype.elems α) (assume a h, fintype.complete a),
 have finite (univ : set ℕ), from finite_of_finite_image h this,
 infinite_univ_nat this

end set

noncomputable instance subtype.fintype_le_nat (n : ℕ) : fintype {i : ℕ // i ≤ n} :=
  classical.choice $ set.finite_le_nat n

theorem sheet_7_2e (f : ℕ → ℕ) (d) : d > 0 → ∃ a b, a ≠ b ∧ f a ≡ f b [MOD d]:=begin
  assume hd,
  unfold modeq,
  apply by_contradiction,
  assume h,
  let f' : ℕ → {i // i ≤ d} := λ n, ⟨f n % d, le_of_lt (mod_lt (f n) hd)⟩,
  have h_inj : function.injective f',
   assume a b,
   simp[f'],
   rw not_exists at h, have := h a, rw not_exists at this,
   have := this b,
   rwa [not_and',not_not] at this,
  exact set.not_injective_nat_fintype {i // i ≤ d} h_inj,
end


lemma commutativity_forall{S: Type}:
  (∀(s: S), ∀(P: S → Prop), P s) ↔
    (∀(P: S → Prop), ∀(s: S), P s) :=
begin
  split,
    assume pfUnivPS,
    intros,
    exact pfUnivPS s P,

    assume pfUnivPS,
    intros,
    exact pfUnivPS P s,
end

lemma commutativity_forall'{S: Type}:
  (∀(s: S), ∀(P: S → Prop), P s) ↔
    (∀(P': S → Prop), ∀(s': S), P' s') :=
begin
  split,
    assume pfUnivPS,
    intros,
    exact pfUnivPS s' P',

    assume pfUnivPS,
    intros,
    exact pfUnivPS P s,
end

lemma forall_is_impl{P Q: Prop}:
   (∀(p: P), Q) ↔ (P → Q) :=
begin
  split,
    assume pfPimpQ,
    assumption,

    assume pfPimpQ,
    assumption,
end


open function

#print surjective

universes u v w
variables {α : Type u} {β : Type v} {γ : Type w}
open function

lemma surjective_comp {g : β → γ} {f : α → β}
  (hg : surjective g) (hf : surjective f) :
surjective (g ∘ f) := (
  assume c: γ,
  let ⟨b, (hgb: g b = c)⟩ := hg c in
  let ⟨a, (hfa: f a = b)⟩ := hf b in
  have hc: (g ∘ f) a = c, by rsimp,
  ⟨a, hc⟩
).


import Quiz9
import Sets.Basic
import Lean.Elab.Print
import Lean.Elab.Command

open Set

variable {α : Type}
variable (X Y : Set α)

theorem desiredType1 : X ∩ Xᶜ = ∅ := sorry

theorem desiredType2 : X ∪ Xᶜ = Univ := sorry

theorem desiredTyep3 : Xᶜ ∪ X = Univ := sorry

open Lean
open Lean.Meta
open Lean.Elab.Command

def n : String := "2"

def problem : String := "problem"++n

def desired : String := "desiredType"++n

def collectAxiomsOf (constName : Name) : MetaM (List String) := do
  let env ← getEnv
  let (_, s) := ((CollectAxioms.collect constName).run env).run {}
  let a := s.axioms.toList.map toString
  return a

#eval isDefEq (Expr.const desired []) (Expr.const problem [])
#eval collectAxiomsOf problem


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import order.hom.bounded
import topology.order.hom.basic

/-!
# Esakia morphisms

This file defines pseudo-epimorphisms and Esakia morphisms.

We use the `fun_like` design, so each type of morphisms has a companion typeclass which is meant to
be satisfied by itself and all stricter types.

## Types of morphisms

* `pseudo_epimorphism`: Pseudo-epimorphisms. Maps `f` such that `f a ≤ b` implies the existence of
  `a'` such that `a ≤ a'` and `f a' = b`.
* `esakia_hom`: Esakia morphisms. Continuous pseudo-epimorphisms.

## Typeclasses

* `pseudo_epimorphism_class`
* `esakia_hom_class`

## References

* [Wikipedia, *Esakia space*](https://en.wikipedia.org/wiki/Esakia_space)
-/

open function

variables {F α β γ δ : Type*}

/-- The type of pseudo-epimorphisms, aka p-morphisms, aka bounded maps, from `α` to `β`. -/
structure pseudo_epimorphism (α β : Type*) [preorder α] [preorder β] extends α →o β :=
(exists_map_eq_of_map_le' ⦃a : α⦄ ⦃b : β⦄ : to_fun a ≤ b → ∃ c, a ≤ c ∧ to_fun c = b)

/-- The type of Esakia morphisms, aka continuous pseudo-epimorphisms, from `α` to `β`. -/
structure esakia_hom (α β : Type*) [topological_space α] [preorder α] [topological_space β]
  [preorder β] extends α →Co β :=
(exists_map_eq_of_map_le' ⦃a : α⦄ ⦃b : β⦄ : to_fun a ≤ b → ∃ c, a ≤ c ∧ to_fun c = b)

section
set_option old_structure_cmd true

/-- `pseudo_epimorphism_class F α β` states that `F` is a type of `⊔`-preserving morphisms.

You should extend this class when you extend `pseudo_epimorphism`. -/
class pseudo_epimorphism_class (F : Type*) (α β : out_param $ Type*) [preorder α] [preorder β]
  extends rel_hom_class F ((≤) : α → α → Prop) ((≤) : β → β → Prop) :=
(exists_map_eq_of_map_le (f : F) ⦃a : α⦄ ⦃b : β⦄ : f a ≤ b → ∃ c, a ≤ c ∧ f c = b)

/-- `esakia_hom_class F α β` states that `F` is a type of lattice morphisms.

You should extend this class when you extend `esakia_hom`. -/
class esakia_hom_class (F : Type*) (α β : out_param $ Type*) [topological_space α] [preorder α]
  [topological_space β] [preorder β]
  extends continuous_order_hom_class F α β :=
(exists_map_eq_of_map_le (f : F) ⦃a : α⦄ ⦃b : β⦄ : f a ≤ b → ∃ c, a ≤ c ∧ f c = b)

end

export pseudo_epimorphism_class (exists_map_eq_of_map_le)

@[priority 100] -- See note [lower instance priority]
instance pseudo_epimorphism_class.to_top_hom_class [partial_order α] [order_top α] [preorder β]
  [order_top β] [pseudo_epimorphism_class F α β] : top_hom_class F α β :=
{ map_top := λ f, let ⟨b, h⟩ := exists_map_eq_of_map_le f (@le_top _ _ _ $ f ⊤) in
                  by rw [←top_le_iff.1 h.1, h.2]
  .. ‹pseudo_epimorphism_class F α β› }

@[priority 100] -- See note [lower instance priority]
instance order_iso_class.to_pseudo_epimorphism_class [preorder α] [preorder β]
  [order_iso_class F α β] : pseudo_epimorphism_class F α β :=
{ exists_map_eq_of_map_le :=
      λ f a b h, ⟨equiv_like.inv f b, (le_map_inv_iff f).2 h, equiv_like.right_inv _ _⟩,
  .. order_iso_class.to_order_hom_class }

@[priority 100] -- See note [lower instance priority]
instance esakia_hom_class.to_pseudo_epimorphism_class [topological_space α] [preorder α]
  [topological_space β] [preorder β] [esakia_hom_class F α β] : pseudo_epimorphism_class F α β :=
{ .. ‹esakia_hom_class F α β› }

instance [preorder α] [preorder β] [pseudo_epimorphism_class F α β] :
  has_coe_t F (pseudo_epimorphism α β) :=
⟨λ f, ⟨f, exists_map_eq_of_map_le f⟩⟩

instance [topological_space α] [preorder α] [topological_space β] [preorder β]
  [esakia_hom_class F α β] : has_coe_t F (esakia_hom α β) :=
⟨λ f, ⟨f, exists_map_eq_of_map_le f⟩⟩

/-! ### Pseudo-epimorphisms -/

namespace pseudo_epimorphism
variables [preorder α] [preorder β] [preorder γ] [preorder δ]

instance : pseudo_epimorphism_class (pseudo_epimorphism α β) α β :=
{ coe := λ f, f.to_fun,
  coe_injective' := λ f g h, by { obtain ⟨⟨_, _⟩, _⟩ := f, obtain ⟨⟨_, _⟩, _⟩ := g, congr' },
  map_rel := λ f, f.monotone',
  exists_map_eq_of_map_le := pseudo_epimorphism.exists_map_eq_of_map_le' }

/-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`
directly. -/
instance : has_coe_to_fun (pseudo_epimorphism α β) (λ _, α → β) := fun_like.has_coe_to_fun

@[simp] lemma to_fun_eq_coe {f : pseudo_epimorphism α β} : f.to_fun = (f : α → β) := rfl

@[ext] lemma ext {f g : pseudo_epimorphism α β} (h : ∀ a, f a = g a) : f = g := fun_like.ext f g h

/-- Copy of a `pseudo_epimorphism` with a new `to_fun` equal to the old one. Useful to fix
definitional equalities. -/
protected def copy (f : pseudo_epimorphism α β) (f' : α → β) (h : f' = f) :
  pseudo_epimorphism α β :=
⟨f.to_order_hom.copy f' h, by simpa only [h.symm, to_fun_eq_coe] using f.exists_map_eq_of_map_le'⟩

@[simp] lemma coe_copy (f : pseudo_epimorphism α β) (f' : α → β) (h : f' = f) :
  ⇑(f.copy f' h) = f' :=
rfl

lemma copy_eq (f : pseudo_epimorphism α β) (f' : α → β) (h : f' = f) :
  f.copy f' h = f :=
fun_like.ext' h

variables (α)

/-- `id` as a `pseudo_epimorphism`. -/
protected def id : pseudo_epimorphism α α := ⟨order_hom.id, λ a b h, ⟨b, h, rfl⟩⟩

instance : inhabited (pseudo_epimorphism α α) := ⟨pseudo_epimorphism.id α⟩

@[simp] lemma coe_id : ⇑(pseudo_epimorphism.id α) = id := rfl
@[simp] lemma coe_id_order_hom : (pseudo_epimorphism.id α : α →o α) = order_hom.id := rfl

variables {α}

@[simp] lemma id_apply (a : α) : pseudo_epimorphism.id α a = a := rfl

/-- Composition of `pseudo_epimorphism`s as a `pseudo_epimorphism`. -/
def comp (g : pseudo_epimorphism β γ) (f : pseudo_epimorphism α β) : pseudo_epimorphism α γ :=
⟨g.to_order_hom.comp f.to_order_hom, λ a b h₀, begin
  obtain ⟨b, h₁, rfl⟩ := g.exists_map_eq_of_map_le' h₀,
  obtain ⟨b, h₂, rfl⟩ := f.exists_map_eq_of_map_le' h₁,
  exact ⟨b, h₂, rfl⟩,
end⟩

@[simp] lemma coe_comp (g : pseudo_epimorphism β γ) (f : pseudo_epimorphism α β) :
  (g.comp f : α → γ) = g ∘ f := rfl
@[simp] lemma coe_comp_order_hom (g : pseudo_epimorphism β γ) (f : pseudo_epimorphism α β) :
  (g.comp f : α →o γ) = (g : β →o γ).comp f := rfl
@[simp] lemma comp_apply (g : pseudo_epimorphism β γ) (f : pseudo_epimorphism α β) (a : α) :
  (g.comp f) a = g (f a) := rfl
@[simp] lemma comp_assoc (h : pseudo_epimorphism γ δ) (g : pseudo_epimorphism β γ)
  (f : pseudo_epimorphism α β) :
  (h.comp g).comp f = h.comp (g.comp f) := rfl
@[simp]

lemma cancel_right {g₁ g₂ : pseudo_epimorphism β γ} {f : pseudo_epimorphism α β}
  (hf : surjective f) :
  g₁.comp f = g₂.comp f ↔ g₁ = g₂ :=
⟨λ h, ext $ hf.forall.2 $ fun_like.ext_iff.1 h, congr_arg _⟩

lemma cancel_left {g : pseudo_epimorphism β γ} {f₁ f₂ : pseudo_epimorphism α β} (hg : injective g) :
  g.comp f₁ = g.comp f₂ ↔ f₁ = f₂ :=
⟨λ h, ext $ λ a, hg $ by rw [←comp_apply, h, comp_apply], congr_arg _⟩

end pseudo_epimorphism

/-! ### Esakia morphisms -/

namespace esakia_hom
variables [topological_space α] [preorder α] [topological_space β] [preorder β]
  [topological_space γ] [preorder γ] [topological_space δ] [preorder δ]

/-- Reinterpret an `esakia_hom` as a `pseudo_epimorphism`. -/
def to_pseudo_epimorphism (f : esakia_hom α β) : pseudo_epimorphism α β := { ..f }

instance : esakia_hom_class (esakia_hom α β) α β :=
{ coe := λ f, f.to_fun,
  coe_injective' := λ f g h,
    by { obtain ⟨⟨⟨_, _⟩, _⟩, _⟩ := f, obtain ⟨⟨⟨_, _⟩, _⟩, _⟩ := g, congr' },
  map_rel := λ f, f.monotone',
  map_continuous := λ f, f.continuous_to_fun,
  exists_map_eq_of_map_le := λ f, f.exists_map_eq_of_map_le' }

/-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`
directly. -/
instance : has_coe_to_fun (esakia_hom α β) (λ _, α → β) := fun_like.has_coe_to_fun

@[simp] lemma to_fun_eq_coe {f : esakia_hom α β} : f.to_fun = (f : α → β) := rfl

@[ext] lemma ext {f g : esakia_hom α β} (h : ∀ a, f a = g a) : f = g := fun_like.ext f g h

/-- Copy of an `esakia_hom` with a new `to_fun` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (f : esakia_hom α β) (f' : α → β) (h : f' = f) : esakia_hom α β :=
⟨f.to_continuous_order_hom.copy f' h,
  by simpa only [h.symm, to_fun_eq_coe] using f.exists_map_eq_of_map_le'⟩

@[simp] lemma coe_copy (f : esakia_hom α β) (f' : α → β) (h : f' = f) : ⇑(f.copy f' h) = f' := rfl
lemma copy_eq (f : esakia_hom α β) (f' : α → β) (h : f' = f) : f.copy f' h = f := fun_like.ext' h

variables (α)

/-- `id` as an `esakia_hom`. -/
protected def id : esakia_hom α α := ⟨continuous_order_hom.id α, λ a b h, ⟨b, h, rfl⟩⟩

instance : inhabited (esakia_hom α α) := ⟨esakia_hom.id α⟩

@[simp] lemma coe_id : ⇑(esakia_hom.id α) = id := rfl
@[simp] lemma coe_id_continuous_order_hom :
  (esakia_hom.id α : α →Co α) = continuous_order_hom.id α := rfl
@[simp] lemma coe_id_pseudo_epimorphism :
  (esakia_hom.id α : pseudo_epimorphism α α) = pseudo_epimorphism.id α  := rfl

variables {α}

@[simp] lemma id_apply (a : α) : esakia_hom.id α a = a := rfl

/-- Composition of `esakia_hom`s as an `esakia_hom`. -/
def comp (g : esakia_hom β γ) (f : esakia_hom α β) : esakia_hom α γ :=
⟨g.to_continuous_order_hom.comp f.to_continuous_order_hom, λ a b h₀, begin
  obtain ⟨b, h₁, rfl⟩ := g.exists_map_eq_of_map_le' h₀,
  obtain ⟨b, h₂, rfl⟩ := f.exists_map_eq_of_map_le' h₁,
  exact ⟨b, h₂, rfl⟩,
end⟩

@[simp] lemma coe_comp (g : esakia_hom β γ) (f : esakia_hom α β) : (g.comp f : α → γ) = g ∘ f := rfl
@[simp] lemma comp_apply (g : esakia_hom β γ) (f : esakia_hom α β) (a : α) :
  (g.comp f) a = g (f a) := rfl
@[simp] lemma coe_comp_continuous_order_hom (g : esakia_hom β γ) (f : esakia_hom α β) :
  (g.comp f : α →Co γ) = (g : β →Co γ).comp f := rfl
@[simp] lemma coe_comp_pseudo_epimorphism (g : esakia_hom β γ) (f : esakia_hom α β) :
  (g.comp f : pseudo_epimorphism α γ) = (g : pseudo_epimorphism β γ).comp f := rfl
@[simp] lemma comp_assoc (h : esakia_hom γ δ) (g : esakia_hom β γ) (f : esakia_hom α β) :
  (h.comp g).comp f = h.comp (g.comp f) := rfl
@[simp] lemma comp_id (f : esakia_hom α β) : f.comp (esakia_hom.id α) = f := ext $ λ a, rfl
@[simp] lemma id_comp (f : esakia_hom α β) : (esakia_hom.id β).comp f = f := ext $ λ a, rfl

lemma cancel_right {g₁ g₂ : esakia_hom β γ} {f : esakia_hom α β} (hf : surjective f) :
  g₁.comp f = g₂.comp f ↔ g₁ = g₂ :=
⟨λ h, ext $ hf.forall.2 $ fun_like.ext_iff.1 h, congr_arg _⟩

lemma cancel_left {g : esakia_hom β γ} {f₁ f₂ : esakia_hom α β} (hg : injective g) :
  g.comp f₁ = g.comp f₂ ↔ f₁ = f₂ :=
⟨λ h, ext $ λ a, hg $ by rw [←comp_apply, h, comp_apply], congr_arg _⟩

end esakia_hom