/-
Copyright (c) 2022 María Inés de Frutos-Fernández, Filippo A. E. Nuccio. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: María Inés de Frutos-Fernández, Filippo A. E. Nuccio
-/

/- import data.polynomial.eval
import data.real.nnreal
import number_theory.padics.padic_integers
import ring_theory.dedekind_domain.adic_valuation
import ring_theory.polynomial.basic -/
import eq_characteristic.basic
import from_mathlib.normed_valued
import from_mathlib.spectral_norm_unique

noncomputable theory

-- /-
-- * Topology on K + this is locally compact.
-- * Define normalized discrete valuation on K, using topological nilpotent elements.
-- * Unit ball = ring of integers
-- * Top. nilp. elements are a maximal ideal P in O_K
-- * Define ramification index e
-- * P^e = (p)
-- * Relate to norm (future)
-- -/

open is_dedekind_domain nnreal polynomial ratfunc
open_locale eq_char_local_field nnreal discrete_valuation

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

namespace FpX_field_completion

noncomputable! instance : is_rank_one (@FpX_field_completion.with_zero.valued p _).v :=
{ hom         := sorry,
  strict_mono := sorry,
  nontrivial  := begin
    use algebra_map (ratfunc 𝔽_[p]) 𝔽_[p]⟮⟮X⟯⟯ X,
    rw FpX_field_completion.valuation_X, -- wrong namespace (fix in basic file)
    split,
    { exact with_zero.coe_ne_zero,},
    { rw [← with_zero.coe_one, ne.def, with_zero.coe_inj, of_add_eq_one, neg_eq_zero],
      exact one_ne_zero }
  end }

instance : normed_field 𝔽_[p]⟮⟮X⟯⟯ := rank_one_valuation.valued_field.to_normed_field

end FpX_field_completion

namespace FpX_int_completion
--`[FAE]` The following `instance` will probably be PR'd soon in greater generality for all
-- integrally closed domains: see
-- [https://leanprover.zulipchat.com/#narrow/stream/116395-maths/topic/.E2.9C.94.20gcd_monoid]
noncomputable! instance  : normalized_gcd_monoid 𝔽_[p]⟦X⟧  :=
sorry

end FpX_int_completion

variables {K : Type*} [field K] [eq_char_local_field p K]

namespace eq_char_local_field

def norm_on_K : K → ℝ := spectral_norm 𝔽_[p]⟮⟮X⟯⟯ K

def nnnorm_on_K [eq_char_local_field p K] : K → ℝ≥0 :=
λ x, ⟨norm_on_K x, spectral_norm_nonneg x⟩

@[simp] lemma coe_nnnorm {K : Type*} [field K] [eq_char_local_field p K] (x : K) :
  ((nnnorm_on_K x) : ℝ) = norm_on_K x :=
rfl

@[ext] lemma nnnorm_ext_norm {K : Type*} [field K] [eq_char_local_field p K] (x y : K) :
  (nnnorm_on_K x) = (nnnorm_on_K y) ↔ norm_on_K x = norm_on_K y :=
subtype.ext_iff

--same proof as in mixed char case
lemma norm_on_K_one {K : Type*} [field K] [eq_char_local_field p K] : norm_on_K (1 : K) = 1 :=
by rw [norm_on_K, spectral_norm_is_norm_one_class]

lemma norm_of_int_le_one (x : 𝓞 p K) : norm_on_K (x : K) ≤ 1 :=
begin
  sorry
  /- let min_Z := minpoly ℤ_[p] x,
  have h_Z_monic := minpoly.monic (is_integral_closure.is_integral ℤ_[p] K x),
  let min_Q : polynomial ℚ_[p] := polynomial.map padic_int.coe.ring_hom min_Z,
  have h_Q_monic : monic min_Q := polynomial.monic.map padic_int.coe.ring_hom h_Z_monic,
  have is_minpoly : min_Q = @minpoly ℚ_[p] K _ _ _ (x : K),
  exact (minpoly.is_integrally_closed_eq_field_fractions ℚ_[p] K (is_integral_closure.is_integral
    ℤ_[p] K x)).symm,
  have : norm_on_K (x : K) = spectral_value h_Q_monic,
  simp only [norm_on_K, spectral_norm, ← is_minpoly],
  rw [this],
  refine csupr_le _,
  intro n,
  simp only [spectral_value_terms],
  split_ifs with hn,
  { have coeff_coe : ∀ n : ℕ, min_Q.coeff n = min_Z.coeff n :=
    λ n, by {simpa only [polynomial.coeff_map]},
    rw [coeff_coe n, padic_int.padic_norm_e_of_padic_int],
    apply real.rpow_le_one (norm_nonneg _) (polynomial.coeff min_Z n).norm_le_one,
    simp only [one_div, inv_nonneg, sub_nonneg, nat.cast_le],
    exact (le_of_lt hn) },
  { exact zero_le_one }, -/
end

variables (K)

noncomputable! def open_unit_ball : height_one_spectrum (𝓞 p K) :=
{ as_ideal :=
  { carrier   := { x : 𝓞 p K | norm_on_K (x : K) < 1},
    add_mem'  := λ x y hx hy,
    begin
      sorry
      /- rw [set.mem_set_of_eq, norm_on_K] at hx hy ⊢,
      refine lt_of_le_of_lt (spectral_norm_is_nonarchimedean
        (algebra.is_algebraic_of_finite ℚ_[p] K) padic_norm_e.nonarchimedean (x : K)
        (y : K)) (max_lt_iff.mpr ⟨hx, hy⟩), -/
    end,
    zero_mem' :=
    begin
      rw [set.mem_set_of_eq, zero_mem_class.coe_zero, norm_on_K, spectral_norm_zero],
      exact zero_lt_one,
    end,
    smul_mem' := λ k x hx,
    begin
      sorry/- rw [norm_on_K, smul_eq_mul, set.mem_set_of_eq, mul_mem_class.coe_mul,
        ← spectral_alg_norm_def (algebra.is_algebraic_of_finite ℚ_[p] K)
          padic_norm_e.nonarchimedean,
        spectral_norm_is_mul (algebra.is_algebraic_of_finite ℚ_[p] K)
          padic_norm_e.nonarchimedean (k : K) (x : K)],
      exact mul_lt_one_of_nonneg_of_lt_one_right (norm_of_int_le_one K k)
        (spectral_norm_nonneg _) hx, -/
    end },
  is_prime :=
  begin
    rw ideal.is_prime_iff,
    split,
    { rw ideal.ne_top_iff_one,
      simp only [set.mem_set_of_eq, submodule.mem_mk, one_mem_class.coe_one, not_lt],
      exact le_of_eq (norm_on_K_one).symm, },
    { sorry/- intros x y hxy,
      simp only [set.mem_set_of_eq, submodule.mem_mk, mul_mem_class.coe_mul] at hxy ⊢,
      rw [norm_on_K, ← spectral_alg_norm_def (algebra.is_algebraic_of_finite ℚ_[p] K)
        padic_norm_e.nonarchimedean, spectral_norm_is_mul (algebra.is_algebraic_of_finite ℚ_[p] K)
        padic_norm_e.nonarchimedean] at hxy,
      contrapose! hxy,
      exact one_le_mul_of_one_le_of_one_le hxy.1 hxy.2, -/  }
  end,
  ne_bot   := --TODO: golf
  begin
    apply ne_of_gt,
    split,
    { simp only [submodule.bot_coe, submodule.coe_set_mk, set.singleton_subset_iff,
        set.mem_set_of_eq, zero_mem_class.coe_zero, norm_on_K, spectral_norm_zero],
      exact zero_lt_one, },
    { sorry/- simp only [submodule.coe_set_mk, submodule.bot_coe, set.subset_singleton_iff,
        set.mem_set_of_eq, not_forall, exists_prop],
      refine ⟨(p : 𝓞 p K), _, ne_zero.ne ↑p⟩,
      have : ((p : 𝓞 p K) : K) = algebra_map ℚ_[p] K (p : ℚ_[p]) :=
        by {simp only [subring_class.coe_nat_cast, map_nat_cast]},
      rw [norm_on_K, this, spectral_norm_extends (p : ℚ_[p])],
      exact padic_norm_e.norm_p_lt_one -/ }
  end }

def normalized_valuation (K : Type*) [field K] [eq_char_local_field p K] : valuation K ℤₘ₀ :=
  (open_unit_ball K).valuation

instance (K : Type*) [field K] [eq_char_local_field p K] : valued K ℤₘ₀ :=
  valued.mk' (normalized_valuation K)

--Failed to find algebra `(ratfunc (galois_field p 1)) K` instance
/- lemma normalized_valuation_X_ne_zero [eq_char_local_field p K] :
  (normalized_valuation K) (algebra_map (ratfunc 𝔽_[p]) _ X) ≠ 0 :=
by {simp only [ne.def, valuation.zero_iff, nat.cast_eq_zero], from nat.prime.ne_zero (fact.out _)}  -/

open multiplicative is_dedekind_domain.height_one_spectrum
/- def ramification_index (K : Type*) [field K] [eq_char_local_field p K] : ℤ :=
  -(with_zero.unzero (normalized_valuation_X_ne_zero K)).to_add

localized "notation (name := ramification_index)
  `e` := eq_char_local_field.ramification_index" in eq_char_local_field -/

end eq_char_local_field

namespace FpX_field_completion

open eq_char_local_field
variable (p)

-- Even compiling the statement is slow...
noncomputable! lemma open_unit_ball_def :
  (open_unit_ball 𝔽_[p]⟮⟮X⟯⟯).as_ideal =
  ideal.span {(FpX_field_completion.ring_of_integers_equiv p).symm (FpX_int_completion.X p)} :=
begin
 sorry
  /- have hiff : ∀ (y : ℚ_[p]), y ∈ 𝓞 p ℚ_[p] ↔ ‖ y ‖  ≤ 1, -- we should extract this to a lemma
  { intro y, rw mem_ring_of_integers,
    rw is_integrally_closed.is_integral_iff,
    refine ⟨λ h, _, λ h, ⟨⟨y, h⟩, rfl⟩⟩,
    { obtain ⟨x, hx⟩ := h,
      rw [← hx],
      exact padic_int.norm_le_one _, }},
  simp only [open_unit_ball],
  ext ⟨x, hx⟩,
  have hx' : x = (⟨x, (hiff x).mp hx⟩ : ℤ_[p]) := rfl,
  rw [submodule.mem_mk, set.mem_set_of_eq, ideal.mem_span_singleton, norm_on_padic,
    set_like.coe_mk],
  conv_lhs {rw hx'},
  rw [← padic_int.norm_def, padic_int.norm_lt_one_iff_dvd, dvd_iff_exists_eq_mul_left,
    dvd_iff_exists_eq_mul_left],
  refine ⟨λ h, _, λ h, _⟩,
  { obtain ⟨⟨c, hc⟩, hcx⟩ := h,
    use ⟨c, (hiff c).mpr hc⟩,
    rw subtype.ext_iff at hcx ⊢,
    exact hcx },
  { obtain ⟨⟨c, hc⟩, hcx⟩ := h,
    use ⟨c, (hiff c).mp hc⟩,
    rw subtype.ext_iff at hcx ⊢,
    exact hcx }, -/
end

variable {p}

--set_option profiler true
/- lemma is_unramified_ℚ_p : e ℚ_[p] = 1 :=
begin
  have hp : normalized_valuation ℚ_[p] p = (of_add (-1 : ℤ)),
  { have hp0 : (p : 𝓞 p ℚ_[p]) ≠ 0,
    { simp only [ne.def, nat.cast_eq_zero], exact nat.prime.ne_zero (_inst_1.1) }, --looks bad
    have hp_alg : (p : ℚ_[p]) = algebra_map (𝓞 p ℚ_[p]) ℚ_[p] (p : 𝓞 p ℚ_[p]) := rfl,
    simp only [normalized_valuation],
    rw [hp_alg, valuation_of_algebra_map],
    simp only [int_valuation, ← valuation.to_fun_eq_coe],
    rw [int_valuation_def_if_neg _ hp0, ← padic.open_unit_ball_def, associates.count_self],
    refl,
    { exact associates_irreducible (open_unit_ball ℚ_[p]), }}, -- so slow!
  rw [ramification_index, neg_eq_iff_neg_eq, ← to_add_of_add (-1 : ℤ)],
  apply congr_arg,
  rw [← with_zero.coe_inj, ← hp, with_zero.coe_unzero],

end
 -/

end FpX_field_completion


import order.jordan_holder
import ring_theory.ideal.operations
import linear_algebra.isomorphisms
import ring_theory.artinian
import dimension_theory.length
import order.minimal

section

-- variables

def is_maximal_lt {α : Type*} [preorder α] (x y : α) : Prop :=
x ∈ maximals (≤) (set.Iio y)

lemma is_maximal_lt.lt {α : Type*} [preorder α] {x y : α} (h : is_maximal_lt x y) : x < y :=
h.1

lemma is_maximal_lt.le {α : Type*} [preorder α] {x y : α} (h : is_maximal_lt x y) : x ≤ y :=
h.lt.le

lemma is_maximal_lt_iff_Ioo {α : Type*} [preorder α] {x y : α} :
  is_maximal_lt x y ↔ x < y ∧ set.Ioo x y = ∅ :=
begin
  apply and_congr iff.rfl,
  split,
  { rw set.eq_empty_iff_forall_not_mem, rintros H z ⟨h₁, h₂⟩, exact not_le_of_lt h₁ (H h₂ h₁.le) },
  { intros H b h₁ h₂, by_contra h,
    show b ∈ (∅ : set α), rw ← H, exact ⟨lt_iff_le_not_le.mpr ⟨h₂, h⟩, h₁⟩ },
end

lemma sup_eq_of_is_maximal_lt {α : Type*} [semilattice_sup α] {x y z : α}
  (h₁ : x ≤ z) (h₂ : is_maximal_lt y z) (e : ¬ x ≤ y) : x ⊔ y = z :=
eq_of_le_of_not_lt (sup_le h₁ h₂.le) (λ e', e (le_sup_left.trans (h₂.2 e' le_sup_right)))

lemma sup_eq_of_is_maximal_lt_of_is_maximal_lt {α : Type*} [semilattice_sup α] {x y z : α}
  (h₁ : is_maximal_lt x z) (h₂ : is_maximal_lt y z) (e : x ≠ y) : x ⊔ y = z :=
begin
  apply eq_of_le_of_not_lt (sup_le h₁.le h₂.le),
  intro e',
  apply e (eq_of_mem_maximals h₂ h₁.lt _).symm,
  rw [← sup_eq_left, ← le_sup_left.antisymm (h₁.2 e' le_sup_left)],
end

-- namespace is_modular_lattice

-- variables {α : Type*} [lattice α] [is_modular_lattice α]

-- def is_modular_lattice.inf_Ioo_order_iso_Ioo_sup (a b : α) :
--   set.Icc (a ⊓ b) a ≃o set.Icc b (a ⊔ b) := sorry

-- end is_modular_lattice

lemma is_maximal_lt_inf_left_of_is_maximal_lt_sup {α : Type*} [lattice α] [is_modular_lattice α]
  {x y : α} (h : is_maximal_lt y (x ⊔ y)) : is_maximal_lt (x ⊓ y) x :=
begin
  refine ⟨lt_of_le_of_ne inf_le_left _, _⟩,
  { rw [ne.def, inf_eq_left, ← sup_eq_right], exact h.lt.ne.symm },
  { rintros z (h₃ : z < x) h₄,
    refine le_inf h₃.le _,
    suffices : y ⊔ z ≤ y, { exact le_sup_right.trans this },
    apply h.2 (lt_of_le_of_ne _ _) le_sup_left,
    { exact sup_comm.trans_le (sup_le_sup_right h₃.le y) },
    { intro e,
      have : (y ⊔ z) ⊓ x = (x ⊔ y) ⊓ x := congr_arg (⊓ x) e,
      rw [sup_inf_assoc_of_le _ (le_refl x), sup_comm, sup_inf_assoc_of_le _ h₃.le,
        inf_comm, sup_inf_self, sup_eq_left.mpr h₄] at this,
      exact h₃.ne this } }
end

lemma is_maximal_lt_inf_left_of_is_maximal_lt_sup' {α : Type*} [lattice α] [is_modular_lattice α]
  {x y : α} (h : is_maximal_lt x (x ⊔ y)) : is_maximal_lt (x ⊓ y) y :=
begin
  rw inf_comm, apply is_maximal_lt_inf_left_of_is_maximal_lt_sup, rwa sup_comm
end

lemma le_or_is_maximal_of_is_maximal {α : Type*} [lattice α] [is_modular_lattice α]
  {x y z : α} (h₁ : is_maximal_lt x z) (h₂ : y ≤ z) : y ≤ x ∨ is_maximal_lt (x ⊓ y) y :=
begin
  rw or_iff_not_imp_left,
  intro h₃,
  apply is_maximal_lt_inf_left_of_is_maximal_lt_sup',
  convert h₁,
  rw sup_comm,
  apply sup_eq_of_is_maximal_lt h₂ h₁ h₃
end

section

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

instance : jordan_holder_lattice (submodule R M) :=
{ is_maximal := is_maximal_lt,
  lt_of_is_maximal := λ _ _ h, h.1,
  sup_eq_of_is_maximal := λ _ _ _, sup_eq_of_is_maximal_lt_of_is_maximal_lt,
  is_maximal_inf_left_of_is_maximal_sup := λ _ _ _, is_maximal_lt_inf_left_of_is_maximal_lt_sup,
  iso := λ p₁ p₂, nonempty ((p₁.2 ⧸ p₁.1.comap p₁.2.subtype) ≃ₗ[R] p₂.2 ⧸ p₂.1.comap p₂.2.subtype),
  iso_symm := λ x y e, ⟨e.some.symm⟩,
  iso_trans := λ x y z e₁ e₂, ⟨e₁.some.trans e₂.some⟩,
  second_iso := begin
    rintros x y _,
    rw [sup_comm, inf_comm],
    exact ⟨(linear_map.quotient_inf_equiv_sup_quotient y x).symm⟩
  end }
.

lemma submodule.exists_is_maximal_ge_of_le [h : is_noetherian R M] {p q : submodule R M}
  (e : q < p) :
  ∃ q' ≥ q, is_maximal_lt q' p :=
begin
  rw [is_noetherian_iff_well_founded, well_founded.well_founded_iff_has_max'] at h,
  obtain ⟨q', h₁, h₂⟩ := h (set.Ico q p) ⟨q, rfl.le, e⟩,
  exact ⟨q', h₁.1, h₁.2, λ x hx hx', (h₂ x ⟨h₁.1.trans hx', hx⟩ hx').le⟩
end

lemma submodule.exists_composition_series [is_noetherian R M] [h : is_artinian R M]
  {N N' : submodule R M} (e : N ≤ N') :
  ∃ s : composition_series (submodule R M), s.bot = N ∧ s.top = N' :=
begin
  rw is_artinian_iff_well_founded at h,
  revert e,
  apply well_founded.induction h N',
  clear N',
  intros N' H e,
  rcases eq_or_lt_of_le e with (rfl | e),
  { exact ⟨⟨0, ![N], λ e, fin_zero_elim e⟩, rfl, rfl⟩ },
  obtain ⟨N'', e', hN⟩ := submodule.exists_is_maximal_ge_of_le e,
  obtain ⟨s, h₁, h₂⟩ := H N'' hN.1 e',
  exact ⟨s.snoc N' (h₂.symm ▸ hN), h₁, composition_series.top_snoc _ _ _⟩
end

open composition_series

lemma exists_composition_series_length_lt
  (s : composition_series (submodule R M)) (x : submodule R M) (h₁ : s.bot ≤ x) (h₂ : x < s.top) :
  ∃ t : composition_series _, t.bot = s.bot ∧ t.top = x ∧ t.length < s.length :=
begin
  induction hle : s.length with n ih generalizing s x,
  { have h := forall_mem_eq_of_length_eq_zero hle s.bot_mem s.top_mem,
    exact (not_le_of_lt h₂ (h ▸ h₁)).elim },
  have htop := is_maximal_erase_top_top ((nat.zero_lt_succ _).trans_eq hle.symm),
  have hle' : s.erase_top.length = n := s.erase_top_length.trans (by rw [hle, nat.succ_sub_one]),
  cases le_or_is_maximal_of_is_maximal htop h₂.le,
  cases lt_or_eq_of_le h with h h,
  { obtain ⟨t, e₁, e₂, e₃⟩ := ih s.erase_top x h₁ h hle',
    exact ⟨t, e₁, e₂, e₃.trans (lt_add_one _)⟩ },
  { subst h, exact ⟨s.erase_top, rfl, rfl, hle'.trans_lt (lt_add_one _)⟩ },
  { have : ¬ s.erase_top.top ≤ x,
    { intro e,
      rw [← (htop.2 h₂ e).antisymm e, inf_idem] at h,
      exact @irrefl _ (<) _ x h.lt },
    rw [← inf_eq_right] at this,
    obtain ⟨t, e₁, e₂, e₃⟩ := ih s.erase_top (x ⊓ s.erase_top.top)
      (le_inf h₁ (bot_le_of_mem $ top_mem _)) (lt_of_le_of_ne inf_le_right this) hle',
    exact ⟨t.snoc x (by rwa [e₂, inf_comm]), e₁, t.top_snoc _ _, nat.add_lt_add_right e₃ 1⟩ }
end

lemma with_top.add_coe_right_injective
  {α : Type*} [add_cancel_monoid α] {a b : with_top α} (c : α) (h : a + c = b + c) : a = b :=
begin
  cases a; cases b; simp only [with_top.none_eq_top, with_top.some_eq_coe] at h ⊢,
  { simpa [← with_top.coe_add] using h },
  { simpa [← with_top.coe_add] using h },
  { rw [← with_top.coe_add, ← with_top.coe_add] at h,
    injection h with h', rw add_right_cancel h' }
end

lemma length_lt_composition_series_length (s : composition_series (submodule R M))
  (l : list (submodule R M)) (hbot : ∀ x ∈ l, s.bot ≤ x)
  (htop : l.head ≤ s.top) (hl' : l.chain' (>)) : l.length ≤ s.length + 1 :=
begin
  induction l with x l h generalizing s,
  { exact zero_le _ },
  { cases l with y l, { exact add_le_add (zero_le _) (le_refl 1) },
    obtain ⟨s', e₁, e₂, e₃⟩ := exists_composition_series_length_lt s y (hbot _ $ by simp)
      (lt_of_lt_of_le (list.chain'_cons.mp hl').1 htop),
    have := h (list.chain'_cons.mp hl').2 s' (λ z hz, e₁.symm ▸ hbot z (or.inr hz)) e₂.symm.le,
    apply add_le_add_right,
    exact this.trans (nat.lt_iff_add_one_le.mp e₃) }
end

lemma composition_series_length_succ_eq_chain_height (s : composition_series (submodule R M)) :
  ↑s.length + 1 = (set.Icc s.bot s.top).chain_height :=
begin
  apply le_antisymm,
  { apply set.le_chain_height_iff.mpr,
    refine ⟨s.to_list, ⟨_, _⟩, s.length_to_list⟩,
    { rw list.chain'_iff_pairwise, exact s.to_list_sorted },
    { intros i hi, rw mem_to_list at hi, exact ⟨bot_le_of_mem hi, le_top_of_mem hi⟩ } },
  { refine supr₂_le _,
    intros l hl,
    by_cases l = [], { subst h, exact zero_le _ },
    norm_cast,
    have := length_lt_composition_series_length s l.reverse _ _ _,
    { rwa [list.length_reverse] at this },
    { intros x hx, rw list.mem_reverse at hx, exact (hl.2 x hx).1 },
    { exact (hl.2 _ (list.mem_reverse.mp $ list.head_mem_self (list.reverse_eq_nil.not.mpr h))).2 },
    { rw list.chain'_reverse, exact hl.1 } }
end

lemma composition_series_length_eq_length (s : composition_series (submodule R M))
  (hbot : s.bot = ⊥) (htop : s.top = ⊤) :
  ↑s.length = module.length R M :=
begin
  apply with_top.add_coe_right_injective 1,
  rw [with_top.coe_one, composition_series_length_succ_eq_chain_height s, module.length_succ,
    htop, hbot, set.Icc_bot, set.Iic_top],
end

lemma finite_length_tfae :
  tfae [module.length R M ≠ ⊤,
    is_noetherian R M ∧ is_artinian R M,
    ∃ s : composition_series (submodule R M), s.bot = ⊥ ∧ s.top = ⊤] :=
begin
  tfae_have : 1 → 2,
  { exact λ h, ⟨is_noetherian_of_finite_length h, is_artinian_of_finite_length h⟩ },
  tfae_have : 2 → 3,
  { rintros ⟨h₁, h₂⟩, exactI submodule.exists_composition_series bot_le },
  tfae_have : 3 → 1,
  { rintro ⟨s, h, h'⟩, rw ← composition_series_length_eq_length s h h', exact with_top.coe_ne_top },
  tfae_finish
end

end

end


import algebra.category.Ring
import algebraic_geometry.stalks
import algebraic_geometry.Scheme

open category_theory category_theory.limits
open Top.presheaf Top.sheaf topological_space

namespace CommRing

@[simps] def from_iso {A B : CommRing} (i : A ≅ B) : A ≃+* B :=
{ to_fun := i.hom,
  inv_fun := i.inv,
  left_inv := λ f, by rw [←comp_apply, i.hom_inv_id, id_apply],
  right_inv := λ f, by rw [←comp_apply, i.inv_hom_id, id_apply],
  map_mul' := map_mul i.hom,
  map_add' := map_add i.hom }

lemma from_iso_to_ring_hom {A B : CommRing} (i : A ≅ B) :
  (from_iso i).to_ring_hom = i.hom :=
ring_hom.ext $ λ (a : A), show from_iso i a = i.hom a, from rfl

@[simps] def to_iso {A B : Type*} [comm_ring A] [comm_ring B]
  (i : A ≃+* B) : CommRing.of A ≅ CommRing.of B :=
{ hom := i.to_ring_hom,
  inv := i.symm.to_ring_hom,
  hom_inv_id' := fun_like.ext _ _ $ λ a,
    show (i.symm $ i a) = a, from i.symm_apply_apply a,
  inv_hom_id' := fun_like.ext _ _ $ λ (a : B),
    show (i $ i.symm a) = a, from i.apply_symm_apply a, }

lemma ring_equiv_eq_iff_to_iso_eq {A B : Type*} [comm_ring A] [comm_ring B]
  (i i' : A ≃+* B) : i = i' ↔ to_iso i = to_iso i' :=
{ mp := λ h, h ▸ rfl,
  mpr := λ h, ring_equiv.ext $ λ x, show (to_iso i).hom x = (to_iso i').hom x,
    from h ▸ rfl }

lemma CommRing_comp_eq_comp {R S T : Type*}
  [comm_ring R] [comm_ring S] [comm_ring T] (f : R →+* S) (g : S →+* T) :
  g.comp f = (show CommRing.of R ⟶ CommRing.of S, from f) ≫
    (show CommRing.of S ⟶ CommRing.of T, from g) :=
rfl

end CommRing

namespace algebra

variables (R R' X X' : Type*)
variables [comm_ring R] [comm_ring R']
variables [comm_ring X] [comm_ring X'] [algebra R X]

@[simps] def of_equiv' (i : R ≃+* R') [algebra R X] : algebra R' X :=
ring_hom.to_algebra $ (algebra_map _ _).comp i.symm.to_ring_hom

@[simps] def of_equiv (i : X ≃+* X') [algebra R X] : algebra R X' :=
ring_hom.to_algebra $ i.to_ring_hom.comp (algebra_map R X)

lemma algebra_map_self :
  algebra_map R R = ring_hom.id R := by { ext : 1, refl }

end algebra

namespace Top.presheaf

universes u v

variables {C : Type u} [category.{v} C] [has_colimits C] {X : Top.{v}}

lemma stalk_specializes_eq_to_hom (F : Top.presheaf C X) {x y : X} (h : x = y) :
  stalk_specializes F (by rw h : x ⤳ y) = eq_to_hom (by rw h) :=
begin
  subst h,
  rw [eq_to_hom_refl],
  apply stalk_hom_ext,
  intros U h,
  erw [germ_stalk_specializes, category.comp_id],
  refl,
end

end Top.presheaf

namespace algebraic_geometry

namespace PresheafedSpace

universes u v w

variables {C : Type u} [category.{v} C] [has_colimits C] (X Y : PresheafedSpace.{v v u} C)
variables (i : X ≅ Y) (x : X.carrier)

@[simps] noncomputable def stalk_iso : X.stalk x ≅ Y.stalk (i.hom.base x) :=
{ hom := stalk_specializes _ (by erw [←comp_apply i.hom.base, ←comp_base,
    iso.hom_inv_id, id_base, id_apply])
    ≫ PresheafedSpace.stalk_map i.inv (i.hom.base x),
  inv := PresheafedSpace.stalk_map i.hom _,
  hom_inv_id' :=
  begin
    rw Top.presheaf.stalk_specializes_eq_to_hom,
    work_on_goal 2
    { erw [←comp_apply i.hom.base, ←comp_base, iso.hom_inv_id, id_base, id_apply], },
    refine stalk_hom_ext _ _,
    intros U h,
    rw [category.assoc, ←stalk_map.comp i.hom i.inv],
    rw PresheafedSpace.stalk_map.congr_hom,
    work_on_goal 2 { exact iso.hom_inv_id _, },
    rw [eq_to_hom_trans_assoc, eq_to_hom_refl, stalk_map.id],
    erw category.comp_id,
  end,
  inv_hom_id' :=
  begin
    rw Top.presheaf.stalk_specializes_eq_to_hom,
    work_on_goal 2
    { erw [←comp_apply i.hom.base, ←comp_base, iso.hom_inv_id, id_base, id_apply], },
    rw [←category.assoc, PresheafedSpace.stalk_map.congr_point],
    work_on_goal 2
    { erw [←comp_apply i.hom.base, ←comp_base, iso.hom_inv_id, id_base, id_apply], },
    rw [category.assoc],
    erw [←stalk_map.comp i.inv i.hom],
    rw stalk_map.congr_hom,
    work_on_goal 2 { exact iso.inv_hom_id _, },
    rw [eq_to_hom_trans_assoc, eq_to_hom_refl, stalk_map.id],
    erw category.id_comp _,
  end }

end PresheafedSpace

namespace LocallyRingedSpace

universe u

variables (X Y : LocallyRingedSpace.{u})
variables (i : X ≅ Y) (x : X.carrier)

@[simps] noncomputable def stalk_iso : X.stalk x ≅ Y.stalk (i.hom.1.base x) :=
let i' : X.to_PresheafedSpace ≅ Y.to_PresheafedSpace :=
{ hom := i.hom.1,
  inv := i.inv.1,
  hom_inv_id' := by erw [←comp_val, iso.hom_inv_id, id_val]; refl,
  inv_hom_id' := by erw [←comp_val, iso.inv_hom_id, id_val]; refl } in
PresheafedSpace.stalk_iso _ _ i' x

end LocallyRingedSpace

namespace Scheme

universe u

variables (X Y : Scheme.{u}) (i : X ≅ Y) (x : X.carrier)

noncomputable def stalk_iso : X.stalk x ≅ Y.stalk (i.hom.1.base x) :=
LocallyRingedSpace.stalk_iso X.to_LocallyRingedSpace Y.to_LocallyRingedSpace
{ hom := i.hom,
  inv := i.inv,
  hom_inv_id' := i.hom_inv_id',
  inv_hom_id' := i.inv_hom_id' } x

end Scheme

end algebraic_geometry

namespace local_ring

universe u

variables (R S : Type u) [comm_ring R] [comm_ring S] [local_ring S] (f : R ≃+* S)

def of_equiv : local_ring R :=
@@local_ring.of_is_unit_or_is_unit_of_is_unit_add _
  (⟨⟨f.symm nontrivial.exists_pair_ne.some,
    f.symm nontrivial.exists_pair_ne.some_spec.some,
    λ r, nontrivial.exists_pair_ne.some_spec.some_spec $ f.symm.injective r⟩⟩ : nontrivial R) $ λ a b h,
begin
  have h' : is_unit (f (a + b)) := f.to_ring_hom.is_unit_map h,
  rw [map_add] at h',
  obtain h''|h'' := local_ring.is_unit_or_is_unit_of_is_unit_add h',
  left,
  convert f.symm.to_ring_hom.is_unit_map h'',
  erw [equiv.symm_apply_apply],
  right,
  convert f.symm.to_ring_hom.is_unit_map h'',
  erw [equiv.symm_apply_apply],
end

end local_ring


import algebraic_topology.simplicial_object
import algebraic_topology.simplicial_set
import path_homotopy
import combinatorics.quiver.basic
import combinatorics.quiver.path

open quiver category_theory
open category_theory.simplicial_object

universe u

variable {X : sSet.{u}}

instance path.is_setoid (A B : X _[0]) : setoid (@path (X _[0]) underlying A B) := by refine {
  r := homotopic A B,
  iseqv := htpy_is_equiv A B
}

def ho_hom (A B : X _[0]) := quotient (path.is_setoid A B)
def ho_id (A : X _[0]) : ho_hom A A := ⟦path.nil.cons (degen_edge A)⟧

def ho_comp' {A B C : X _[0]} (f : path A B) (g : path B C) : ho_hom A C := ⟦f.comp g⟧

def ho_comp {A B C : X _[0]} : ho_hom A B → ho_hom B C → ho_hom A C :=
quotient.lift₂ ho_comp' (begin
  intros a1 a2 b1 b2 H1 H2, apply quotient.sound,
  apply homotopic.trans,

  apply homotopic.comp_l, refine H2,
  apply homotopic.comp_r, refine H1,
end)

-- pick a representative using ⟦notation⟧
lemma pick_rep {A B : X _[0]} (f : ho_hom A B) : ∃ (f' : path A B), ⟦f'⟧ = f := quot.exists_rep f

lemma homotopy_compose {A B C : X _[0]} (f : path A B) (g : path B C) :
ho_comp ⟦f⟧ ⟦g⟧ = ⟦f.comp g⟧ := begin
  apply quotient.sound, refl,
end

instance realized : category.{u} (X _[0]) := by refine {
  hom := ho_hom,
  id := ho_id,
  comp := λ A B C : X _[0], λ f : ho_hom A B, λ g : ho_hom B C, ho_comp f g,

  id_comp' := begin
    intros, dsimp,

    unfold ho_id,
    have H := pick_rep f, revert H, rintro ⟨f', frw⟩, subst frw,
    rw homotopy_compose, simp,
    apply homotopic.trans,
    apply homotopic.comp_r, apply homotopic.degen, simp,
  end,

  comp_id' := begin
    intros, dsimp, unfold ho_id,

    have H := pick_rep f, revert H, rintro ⟨f', frw⟩, subst frw,
    rw homotopy_compose, apply quotient.sound,
    apply homotopic.trans,
    apply homotopic.comp_l, apply homotopic.degen, simp,
  end,

  assoc' := begin
    intros, dsimp,

    have H := pick_rep f, revert H, rintro ⟨f', frw⟩, subst frw,
    have H := pick_rep g, revert H, rintro ⟨g', grw⟩, subst grw,
    have H := pick_rep h, revert H, rintro ⟨h', hrw⟩, subst hrw,

    repeat {rw homotopy_compose},
    rw path.comp_assoc,
  end,
}

notation (name := simplicial_map.at) f ` ![`:1000 n `]` :=
  (f : category_theory.nat_trans hole! hole!).app (opposite.op (simplex_category.mk n))

lemma simplicial_map_preserves_faces {X Y : sSet} (f : X ⟶ Y) {n : ℕ} {i : fin (n+2)} {σ : X _[n+1] } :
  Y.δ i (f ![n+1] σ) = f ![n] (X.δ i σ) := begin
   have H := congr_fun (f.naturality (@simplex_category.δ n i).op) σ,
   simp at H,
   have : X.δ i = X.map (@simplex_category.δ n i).op, dsimp [δ], refl,
   rw this, clear this,
   have : Y.δ i = Y.map (@simplex_category.δ n i).op, dsimp [δ], refl,
   rw this, clear this,
   rw H,
end

def transport_ends {X Y : sSet} {a b : X _[0]} {ab : X _[1]}
  (f : X ⟶ Y) (e : ends ab a b) : ends (f ![1] ab) (f ![0] a) (f ![0] b) := begin
    destruct e, intros, subst left, subst right, split,
    repeat {refine simplicial_map_preserves_faces _},
end

lemma transport_degenerate_is_degenerate {X Y : sSet} {a : X _[0]} (f :  X ⟶ Y) :
f ![1] (X.σ 0 a) = Y.σ 0 (f ![0] a) := begin
  have : X.σ 0 = X.map (@simplex_category.σ 0 0).op, dsimp [σ], refl,
  rw this, clear this,
  have : Y.σ 0 = Y.map (@simplex_category.σ 0 0).op, dsimp [σ], refl,
  rw this, clear this,
  refine congr_fun (f.naturality (@simplex_category.σ _ 0).op) a,
end

def glue_one {X Y : sSet} (f : X ⟶ Y) {a b c : X _[0]}
    (q : path (f ![0] a) (f ![0] b))
    (e : X _[1]) (ε : ends e b c) : path (f ![0] a) (f ![0] c) :=
path.cons q (subtype.mk (f ![1] e) (transport_ends f ε))

def map_edge {X Y : sSet} (f : X ⟶ Y) {a b : X _[0]} (e : a ⟶ b) : (f ![0] a) ⟶ (f ![0] b) :=
begin
  have ε : (ends e.val a b), destruct e, intros, subst a_1, simp, assumption,
  have H := transport_ends f ε,
  refine subtype.mk (f ![1] e) H,
end

def path_map {X Y : sSet} (f : X ⟶ Y) {a : X _[0]} : Π {b : X _[0]}, path a b → path (f ![0] a) (f ![0] b)
| _ path.nil := path.nil
| b (path.cons p q) := glue_one f (path_map p) q (begin
  destruct q, intros, rw ← subtype.val_eq_coe, rw a_1, simp,
  dsimp [ends],
  refine property,
end)

@[simp] lemma path_map_nil {X Y : sSet} {a : X _[0]} (f : X ⟶ Y) :
(@path_map X Y f a a path.nil) = path.nil := rfl

@[simp] lemma path_map_id {X : sSet} {a b} {p : path a b} : path_map (𝟙 X) p = p := begin
  induction p with b' c' p' e, simp,
  unfold path_map, dsimp [glue_one], rw p_ih,
  destruct e, intros, subst a_1, simp,
end

@[simp] lemma path_map_app {X Y : sSet} (f : X ⟶ Y) {a b c : X _[0]} (p : path a b) (q : path b c) :
  path_map f (p ** q) = ((path_map f p) ** (path_map f q)) :=
begin
  induction q, simp,
  unfold path_map, unfold glue_one, simp, rw ← q_ih,
  unfold path_map, unfold glue_one,
end

@[simp] lemma path_map_cons {X Y : sSet} (f : X ⟶ Y) {a b c : X _[0]} {p : path a b} {e : b ⟶ c} :
  path_map f (path.cons p e) = (path_map f p).cons (map_edge f e) :=
begin
  unfold path_map, dsimp [glue_one], simp, dsimp [map_edge], refl,
end

@[simp] lemma path_map_comp {X Y Z : sSet} (f : X ⟶ Y) (g : Y ⟶ Z) {a b : X _[0]} {p : path a b} :
  path_map (f ≫ g) p = (@path_map Y Z g _ _ (@path_map X Y f _ _ p)) := begin

  induction p with b' c' p' e, simp,
  unfold path_map, dsimp [glue_one], rw p_ih,
  simp, dsimp [map_edge], refl,
end

def fmap' {X Y : sSet} (f : X ⟶ Y) {a b : X _[0]} :
path a b → ho_hom (f ![0] a) (f ![0] b) := λ p, ⟦path_map f p⟧

@[simp] lemma fmap'_comp {X Y : sSet} (f : X ⟶ Y) {a b c : X _[0]} (p : path a b) (q : path b c) :
  fmap' f (p ** q) = ho_comp (fmap' f p) (fmap' f q) := begin
  unfold fmap', simp, rw homotopy_compose,
end

lemma map_homotopy'' {X Y : sSet} {a b : X _[0]} {p q : path a b} (f : X ⟶ Y) :
  (homotopic'' a b p q) → (homotopic'' (f ![0] a) (f ![0] b) (path_map f p) (path_map f q)) := begin

    intros H, cases H,
    unfold path_map, unfold glue_one, simp,
    simp_rw ← simplicial_map_preserves_faces,

    have fσ : Y.δ 1 (Y.δ 1 (f ![2] H_h)) = f ![0] a,
    subst H_σ, repeat {rw (simplicial_map_preserves_faces f)},

    have fτ : Y.δ 0 (Y.δ 1 (f ![2] H_h)) = f ![0] b,
    subst H_τ, repeat {rw (simplicial_map_preserves_faces f)},

    have fρ : Y.δ 0 (Y.δ 2 (f ![2] H_h)) = f ![0] H_C,
    subst H_ρ, repeat {rw (simplicial_map_preserves_faces f)},

    have H' := homotopic''.homotopy (f ![2] H_h) fσ fτ fρ,

    dsimp [edge_to_path] at *, dsimp [edge_to_qedge] at *,
    unfold path_map, unfold glue_one, simp,
    simp_rw ← simplicial_map_preserves_faces,
    refine H',
end

def fmap {X Y : sSet} (f : X ⟶ Y) {a b : X _[0]} : ho_hom a b → ho_hom (f ![0] a) (f ![0] b) :=
quotient.lift (@fmap' X Y f a b) begin
  intros a1 b1 H,
  induction H,
  cases H_h with h C σ τ ρ, focus {
    apply quotient.sound,
    apply homotopic.lift,
    apply map_homotopy'',
    refine H_h,
  },
  focus {
    dsimp [fmap'], dsimp [path_map], dsimp [degen_edge], dsimp [glue_one],
    simp_rw transport_degenerate_is_degenerate f,
    apply quotient.sound, apply homotopic.degen,
  },
  refl,
  rw H_ih,
  rw H_ih_h1, rw H_ih_h2,
  simp, rw H_ih,
  simp, rw H_ih,
end

@[simp] lemma id_of_fmap_id {X : sSet} {a b : X _[0]} :
  @fmap X X (𝟙 X) a b = id := begin
  ext,
  have H := pick_rep x, revert H, rintros ⟨x, H⟩, subst H,
  dsimp [fmap], dsimp [fmap'], simp,
end

lemma fmap_id' {X Y : sSet} (f : X ⟶ Y) : Π (A : X _[0]), fmap f (𝟙 A) = 𝟙 (f ![0] A) := begin
  intro A,
  apply quotient.sound, simp, dsimp [map_edge], dsimp [degen_edge],
  simp_rw transport_degenerate_is_degenerate, refl,
end

lemma fmap_comp' {X Y : sSet} (f : X ⟶ Y) {A B C : X _[0]} {m1 : ho_hom A B} {m2 : ho_hom B C} :
  fmap f (ho_comp m1 m2) = ho_comp (fmap f m1) (fmap f m2) := begin
  have Hm1 := pick_rep m1, revert Hm1, rintro ⟨m1', m1'rw⟩, subst m1'rw,
  have Hm2 := pick_rep m2, revert Hm2, rintro ⟨m2', m2'rw⟩, subst m2'rw,
  rw homotopy_compose,
  unfold fmap, simp,
end

def fmap_functor {X Y : sSet} (f : X ⟶ Y) : (X _[0]) ⥤ (Y _[0]) := {
  obj := λ A, f ![0] A,
  map := λ A B, fmap f,
  map_id' := fmap_id' f,
  map_comp' := λ A B C m1 m2, fmap_comp' f,
}

@[simps]
def HomotopyRealization : sSet ⥤ Cat := {
  obj := λ X, Cat.of(X _[0]),
  map := λ X Y, fmap_functor,
  map_id' := begin
    intro X, unfold fmap_functor, dsimp [id], congr,
    ext, simp,
  end,
  map_comp' := begin
    intros X Y Z f g,
    dsimp [fmap_functor], congr, simp,

    ext,
    have H := pick_rep x_2, revert H, rintro ⟨x2', x2rw⟩, subst x2rw,
    dsimp [fmap], dsimp [fmap'],

    simp,
  end
}


import geometry.manifold.algebra.smooth_functions
import geometry.manifold.instances.real
import topology.metric_space.partition_of_unity
import global.smooth_embedding

noncomputable theory

open_locale manifold
open set metric

section
variables {𝕜 : Type*} [nontrivially_normed_field 𝕜]
  {E : Type*} [normed_add_comm_group E] [normed_space 𝕜 E]
  {H : Type*} [topological_space H]
  (I : model_with_corners 𝕜 E H)
  {M : Type*} [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M]
  {E' : Type*} [normed_add_comm_group E'] [normed_space 𝕜 E']
  {H' : Type*} [topological_space H']
  (I' : model_with_corners 𝕜 E' H')
  {M' : Type*} [topological_space M'] [charted_space H' M'] [smooth_manifold_with_corners I' M']

/-- Definition `def:localisation_data`. -/
structure localisation_data (f : M → M') :=
(cont : continuous f)
(ι' : Type*)
(N : ℕ)
(φ : index_type N → open_smooth_embedding 𝓘(𝕜, E) E I M)
(ψ : ι' → open_smooth_embedding 𝓘(𝕜, E') E' I' M')
(j : index_type N → ι')
(h₁ : (⋃ i, (φ i) '' (ball (0:E) 1)) = univ)
(h₂ : (⋃ i', (ψ i') '' (ball (0:E') 1)) = univ)
(h₃ : ∀ i, range (f ∘ (φ i)) ⊆ (ψ (j i)) '' (ball (0:E') 1))
(h₄ : locally_finite $ λ i', range (ψ i'))
(lf_φ : locally_finite $ λ i, range (φ i))

namespace localisation_data

variables {f : M → M'} {I I'} (ld : localisation_data I I' f)
abbreviation ψj := ld.ψ ∘ ld.j

/-- The type indexing the source charts of the given localisation data. -/
def ι (L : localisation_data I I' f) := index_type L.N

lemma Union_succ' {β : Type*} (s : ld.ι → set β) (i : index_type ld.N) :
  (⋃ j ≤ i, s j) = (⋃ j < i, s j) ∪ s i :=
begin
  simp only [(λ j, le_iff_lt_or_eq : ∀ j, j ≤ i ↔ j < i ∨ j = i)],
  erw [bUnion_union, bUnion_singleton],
  refl
end
open filter
end localisation_data

end

section

open model_with_corners

variables
  {E : Type*} [normed_add_comm_group E] [normed_space ℝ E] [finite_dimensional ℝ E]
  {M : Type*} [topological_space M] [sigma_compact_space M] [locally_compact_space M] [t2_space M]
  {H : Type*} [topological_space H] (I : model_with_corners ℝ E H) [boundaryless I]
  [nonempty M] [charted_space H M] [smooth_manifold_with_corners I M]
  (E' : Type*) [normed_add_comm_group E'] [normed_space ℝ E'] [finite_dimensional ℝ E']
  {H' : Type*} [topological_space H'] (I' : model_with_corners ℝ E' H') [boundaryless I']
  {M' : Type*} [metric_space M'] [sigma_compact_space M'] [locally_compact_space M']
  [nonempty M'] [charted_space H' M']
  [smooth_manifold_with_corners I' M']

variables (M')

lemma nice_atlas_target :
  ∃ n, ∃ ψ : index_type n → open_smooth_embedding 𝓘(ℝ, E') E' I' M',
  locally_finite (λ i', range (ψ i')) ∧
  (⋃ i', ψ i' '' ball 0 1) = univ :=
let h := (nice_atlas E' I' (λ j : punit, @is_open_univ M' _) (by simp [eq_univ_iff_forall])) in
⟨h.some, h.some_spec.some, h.some_spec.some_spec.2⟩

/-- A collection of charts on a manifold `M'` which are smooth open embeddings with domain the whole
model space, and which cover the manifold when restricted in each case to the unit ball. -/
def target_charts (i' : index_type (nice_atlas_target E' I' M').some) :
  open_smooth_embedding 𝓘(ℝ, E') E' I'  M' :=
(nice_atlas_target E' I' M').some_spec.some i'

lemma target_charts_cover : (⋃ i', (target_charts E' I' M' i') '' (ball (0:E') 1)) = univ :=
(nice_atlas_target E' I' M').some_spec.some_spec.2

variables (E) {M'} {f : M → M'} (hf : continuous f)

lemma nice_atlas_domain :
  ∃ n, ∃ φ : index_type n → open_smooth_embedding 𝓘(ℝ, E) E I M,
  (∀ i, ∃ i', (range (φ i)) ⊆ f ⁻¹' (⇑(target_charts E' I' M' i') '' (ball (0:E') 1))) ∧
  locally_finite (λ i, range (φ i)) ∧
  (⋃ i, φ i '' ball 0 1) = univ :=
nice_atlas E I
  (λ i', ((target_charts E' I' M' i').open_map (ball 0 1) is_open_ball).preimage hf)
  (by rw [← preimage_Union, target_charts_cover, preimage_univ])

/-- Lemma `lem:ex_localisation`
  Any continuous map between manifolds has some localisation data. -/
def std_localisation_data : localisation_data I I' f :=
{ cont := hf,
  N := (nice_atlas_domain E I E' I' hf).some,
  ι' := index_type (nice_atlas_target E' I' M').some,
  φ := (nice_atlas_domain E I E' I' hf).some_spec.some,
  ψ := target_charts E' I' M',
  j := λ i, ((nice_atlas_domain E I E' I' hf).some_spec.some_spec.1 i).some,
  h₁ := (nice_atlas_domain E I E' I' hf).some_spec.some_spec.2.2,
  h₂ := target_charts_cover E' I' M',
  h₃ := λ i, begin
    rw range_comp,
    rintros - ⟨y, hy, rfl⟩,
    exact ((nice_atlas_domain E I E' I' hf).some_spec.some_spec.1 i).some_spec hy,
  end,
  h₄ := (nice_atlas_target E' I' M').some_spec.some_spec.1,
  lf_φ := (nice_atlas_domain E I E' I' hf).some_spec.some_spec.2.1 }

variables {E E' I I'}

/-- Lemma `lem:localisation_stability`. -/
lemma localisation_stability {f : M → M'} (ld : localisation_data I I' f) :
  ∃ (ε : M → ℝ) (hε : ∀ m, 0 < ε m) (hε' : continuous ε),
    ∀ (g : M → M') (hg : ∀ m, dist (g m) (f m) < ε m) i, range (g ∘ ld.φ i) ⊆ range (ld.ψj i) :=
begin
  let K : ld.ι' → set M' := λ i, ld.ψ i '' closed_ball 0 1,
  let U : ld.ι' → set M' := λ i, range $ ld.ψ i,
  have hK : ∀ i, is_closed (K i) := λ i, is_compact.is_closed
    (is_compact.image (is_compact_closed_ball 0 1) (ld.ψ i).continuous),
  have hK' : locally_finite K := ld.h₄.subset (λ i, image_subset_range (ld.ψ i) (closed_ball 0 1)),
  have hU : ∀ i, is_open (U i) := λ i, (ld.ψ i).is_open_range,
  have hKU : ∀ i, K i ⊆ U i := λ i, image_subset_range _ _,
  obtain ⟨δ, hδ₀, hδ₁⟩ := exists_continuous_real_forall_closed_ball_subset hK hU hKU hK',
  have := ld.cont,
  refine ⟨δ ∘ f, λ m, hδ₀ (f m), by continuity, λ g hg i, _⟩,
  rintros - ⟨e, rfl⟩,
  have hi : f (ld.φ i e) ∈ K (ld.j i) :=
    image_subset _ ball_subset_closed_ball (ld.h₃ i (mem_range_self e)),
  exact hδ₁ (ld.j i) (f $ ld.φ i e) hi (le_of_lt (hg _)),
end

namespace localisation_data
protected def ε (ld : localisation_data I I' f) : M → ℝ :=
(localisation_stability ld).some

lemma ε_pos (ld : localisation_data I I' f) : ∀ m, 0 < ld.ε m :=
(localisation_stability ld).some_spec.some

lemma ε_cont (ld : localisation_data I I' f) : continuous ld.ε :=
(localisation_stability ld).some_spec.some_spec.some

lemma ε_spec (ld : localisation_data I I' f) :
  ∀ (g : M → M') (hg : ∀ m, dist (g m) (f m) < ld.ε m) (i : ld.ι),
  range (g ∘ ld.φ i) ⊆ range (ld.ψj i) :=
(localisation_stability ld).some_spec.some_spec.some_spec

end localisation_data

end


/-
Copyright (c) 2021 Paula Neeley. All rights reserved.
Author: Paula Neeley
Following the textbook "Dynamic Epistemic Logic" by
Hans van Ditmarsch, Wiebe van der Hoek, and Barteld Kooi
-/

import del.languageDEL del.syntax.syntaxDEL
import del.semantics.semanticsDEL del.syntax.syntaxlemmasDEL
import del.syntax.soundnessDEL order.zorn data.set.basic data.list.basic
local attribute [instance] classical.prop_decidable

variables {agents : Type}
open prfS5
open S5lemma

---------------------- Consistency ----------------------

def sem_cons (AX : ctx agents) (F : set (frame agents)) := ¬ global_sem_csq AX F form.bot
attribute [class] sem_cons

lemma sem_consS5 : sem_cons (∅ : ctx agents) equiv_class :=
begin
rw sem_cons,
rw global_sem_csq,
push_neg,
let f : frame agents :=
{ states := ℕ,
  h := ⟨0⟩,
  rel := λ a x y, x = y},
use f, let v := λ n x, true,
split,
intro a,
split,
intro x,
exact rfl,
split,
intros x y h1,
exact eq.symm h1,
intros x y z h1 h2,
exact (rfl.congr h2).mp h1,
use v,
split,
intros φ x h1,
exact false.elim h1,
let x := 42,
use x,
rw forces,
trivial
end

-- The S5 axiom system does not prove false
lemma nprfalse (hax : sem_cons (∅ : ctx agents) equiv_class) : ¬ prfS5 (∅ : ctx agents) form.bot :=
begin
have h1 : ¬ global_sem_csq (∅ : ctx agents) equiv_class form.bot → ¬ prfS5 ∅ form.bot,
{have h2 := soundnessS5,
rw ←not_imp_not at h2, exact h2},
apply h1, exact hax
end

lemma prnot_to_notpr (φ : form agents) (hax : sem_cons (∅ : ctx agents) equiv_class) :
  prfS5 ∅ (¬φ) → ¬ prfS5 ∅ φ :=
begin
intro h1, by_contradiction h2,
exact absurd (mp (mp pl5 contra_equiv_false) (mp (mp pl4 h2) h1)) (nprfalse hax)
end

lemma pr_to_notprnot (φ : form agents) (hax : sem_cons (∅ : ctx agents) equiv_class) :
  prfS5 ∅ φ → ¬ prfS5 ∅ (¬φ) :=
begin
have h1 := prnot_to_notpr φ hax,
rw ←not_imp_not at h1, intro h2, apply h1, rw not_not, exact h2,
end

-- finite conjunction of formulas
def fin_conj : list (form agents) → form agents
  | []      := ¬form.bot
  | (φ::φs) := φ & (fin_conj φs)

-- a few helper lemmas about finite conjunctions
lemma fin_conj_simp {Γ : ctx agents} : ∀ ψ : form agents, prfS5 Γ (¬fin_conj [ψ, ¬ψ]) :=
begin
intro ψ, exact (not_and_subst phi_and_true).mpr not_contra
end

lemma imp_conj_imp_imp {Γ : ctx agents} {φ ψ χ : form agents} {L : list (form agents)} :
  prfS5 Γ ((fin_conj (φ::L)) ⊃ ψ) ↔ prfS5 Γ (fin_conj L ⊃ (φ ⊃ ψ)) :=
begin
split,
intro h, dsimp [fin_conj] at h, rw and_right_imp at h, exact h,
intro h, dsimp [fin_conj], rw and_right_imp, exact h
end

lemma fin_conj_cons_imp {Γ : ctx agents} {φ b : form agents} {L : list (form agents)} :
 prfS5 Γ (fin_conj (φ::L) ⊃ (φ ⊃ b)) → prfS5 Γ (fin_conj L ⊃ (φ ⊃ b)) :=
begin
intro h, rw imp_conj_imp_imp at h, rw imp_imp_iff_imp at h, exact h, exact φ,
end

lemma fin_conj_append {Γ : ctx agents} {L L' : list (form agents)} :
  prfS5 Γ ((fin_conj L' & fin_conj L) ↔ (fin_conj (L' ++ L))) :=
begin
induction L', rw fin_conj,
exact (mp (mp pl4 (cut (mp pl6 and_switch) (mp pl5 phi_and_true)))
  (cut (mp pl6 phi_and_true) (mp pl5 and_switch))),
exact mp (mp pl4 (cut (mp pl5 and_commute) (imp_and_imp (mp pl5 L'_ih))))
  (cut iden (cut (imp_and_imp (mp pl6 L'_ih)) (mp pl6 and_commute)))
end

lemma fin_conj_empty {L : list (form agents)}
  (hax : sem_cons (∅ : ctx agents) equiv_class) :
  L = [] → ¬ prfS5 ∅ (fin_conj L ⊃ ⊥) :=
begin
intro h1, subst h1,
by_contradiction h2,
exact absurd (mp h2 iden) (nprfalse hax)
end

lemma fin_conj_repeat_helper {θ : form agents} {L : list (form agents)}
  (hax : sem_cons (∅ : ctx agents) equiv_class) :
  (∀ ψ ∈ L, ψ = θ) → prfS5 ∅ (θ ⊃ fin_conj L) :=
begin
intros h1, induction L,
exact mp pl1 iden,
rw fin_conj, simp at *,
cases h1 with h1 h2,
subst h1,
exact cut (mp double_imp pl4) (imp_and_and_imp (mp (mp pl4 iden) (L_ih h2))),
end

lemma fin_conj_repeat {φ : form agents} {L : list (form agents)}
  (hax : sem_cons (∅ : ctx agents) equiv_class) :
  (∀ ψ ∈ L, ψ = ¬φ) → prfS5 ∅ (¬fin_conj L) → prfS5 ∅ φ :=
begin
intros h1 h2, induction L,
exact absurd (mp dne h2) (nprfalse hax),
repeat {rw fin_conj at *}, simp at *,
cases h1 with h1 h3,
have h5 := contrapos.mpr (fin_conj_repeat_helper hax h3),
subst h1,
exact (mp (mp pl3 (contrapos.mpr (cut h5 dne)))
  (contrapos.mpr (cut ((demorgans.mp) (mp (mp pl6 (iff_not and_switch)) h2)) dne)))
end

lemma fin_conj_box2 {φ ψ : form agents} {a : agents} :
  prfS5 ∅ (((K a φ) & K a ψ) ⊃ K a (φ & ψ)) :=
begin
exact (mp double_imp (cut2 pl6 (cut pl5 (cut (mp kdist (nec pl4)) kdist))))
end

lemma fin_conj_boxn {L : list (form agents)} {a : agents} :
  prfS5 ∅ ((fin_conj (list.map (K a) L)) ⊃ (K a (fin_conj L))) :=
begin
induction L,
exact (mp pl1 (nec prtrue)),
exact (cut (imp_and_imp L_ih) fin_conj_box2)
end

lemma listempty {Γ : ctx agents} {L : list (form agents)} :
  (∀ φ ∈ L, φ ∈ Γ) → Γ = ∅ → L = [] :=
begin
intros h1 h2,
by_contradiction h3,
have h4 := list.length_pos_of_ne_nil,
have h5 := list.exists_mem_of_length_pos,
cases h5 (h4 h3) with φ h5,
exact absurd (h1 φ h5) (set.eq_empty_iff_forall_not_mem.mp h2 φ)
end

-- Consistency for a finite set of formulas L
def fin_ax_consist (L : list (form agents)) := ¬ prfS5 ∅ (fin_conj L ⊃ ⊥)

-- Consistency for an arbitrary set of formulas Γ
def ax_consist (Γ : ctx agents) :=
  ∀ L : list (form agents), (∀ ψ ∈ L, ψ ∈ Γ) → fin_ax_consist L

-- Γ is maximally ax-consistent
def max_ax_consist (Γ : ctx agents) :=
  ax_consist Γ ∧ (∀ Γ', Γ ⊂ Γ' → ¬ ax_consist Γ')

lemma max_imp_ax {Γ : ctx agents} : max_ax_consist Γ → ax_consist Γ :=
begin
intro h1, exact h1.left
end

-- Lemma 5 from class notes
lemma five_helper :
  ∀ Γ : ctx agents, ∀ φ : form agents, ∀ L : list (form agents), ∀ b : form agents,
  (∀ ψ ∈ L, ψ ∈ Γ ∨ ψ = φ) → prfS5 ∅ (fin_conj L ⊃ b) → ∃ L',
  (∀ ψ ∈ L', ψ ∈ Γ) ∧ prfS5 ∅ (fin_conj L' ⊃ (φ ⊃ b)) :=
begin
intros Γ φ L b h1 h2,
revert b,
induction L,
{intros b h2, existsi ([] : list (form agents)), split,
intros ψ h3, exfalso, apply list.not_mem_nil ψ h3,
exact imp_if_imp_imp h2},
{intros b h2,
have h1a : ∀ (ψ : form agents), ψ ∈ L_tl → ψ ∈ Γ ∨ ψ = φ,
  {intros ψ h2, apply h1 ψ (list.mem_cons_of_mem L_hd h2)},
have h1b: L_hd ∈ Γ ∨ L_hd = φ,
  {apply h1 L_hd, left, refl},
cases h1b,
have h3 := and_right_imp.mp h2,
cases L_ih h1a (L_hd ⊃ b) h3 with L' ih, existsi (L_hd::L' : list (form agents)),
cases ih, split, intros ψ h4, cases h4,
subst h4, exact h1b,
apply ih_left ψ h4, rw imp_shift at ih_right,
rw ←imp_conj_imp_imp at ih_right, exact ih_right,
have h3 : prfS5 ∅ (fin_conj (L_hd::L_tl) ⊃ b),
exact h2, exact b,
have h4 : prfS5 ∅ (fin_conj L_tl ⊃ (φ ⊃ b)),
  from eq.subst h1b (and_right_imp.mp) h2,
cases L_ih h1a (φ ⊃ b) h4 with L' ih,
cases ih, existsi (L' : list (form agents)), split,
exact ih_left, exact imp_imp_iff_imp.mp ih_right}
end

lemma five :
  ∀ Γ : ctx agents, ∀ φ : form agents, ¬ ax_consist (Γ ∪ φ) → ∃ L',
  (∀ ψ ∈ L', ψ ∈ Γ) ∧ prfS5 ∅ (fin_conj L' ⊃ ¬φ) :=
begin
intro Γ, intro φ, intro h1, rw ax_consist at h1,
push_neg at h1,
cases h1 with L h1,
have h2 : (∀ ψ ∈ L, ψ ∈ Γ ∨ ψ = φ) → prfS5 ∅ (fin_conj L ⊃ ⊥) → ∃ L',
  (∀ ψ ∈ L', ψ ∈ Γ) ∧ prfS5 ∅ (fin_conj L' ⊃ (φ ⊃ ⊥)), from five_helper Γ φ L ⊥,
cases h1,
have h3 : (∀ (ψ : form agents), ψ ∈ L → ψ ∈ Γ ∨ ψ = φ),
{intros ψ this, exact or.swap (h1_left ψ this)},
apply h2 h3, rw fin_ax_consist at h1_right, rw not_not at h1_right,
exact h1_right,
end

-- Lemma 6 from class notes
lemma six_helper (Γ : ctx agents) (h : ax_consist Γ) :
max_ax_consist Γ → ∀ φ : form agents, φ ∈ Γ ∨ (¬φ) ∈ Γ :=
begin
intros h1 φ, rw or_iff_not_and_not, by_contradiction h2,
cases h2 with h2l h2r,
cases h1 with h1l h1r, clear h,
have h2 := h1r (Γ ∪ φ),
have h3 : ¬ax_consist (Γ ∪ ¬φ),
{apply h1r (Γ ∪ ¬φ), from set.ssubset_insert h2r},
have h5 : ¬ax_consist (Γ ∪ φ),
{apply h2, from set.ssubset_insert h2l},
have h6 := five Γ φ _, have h7 := five Γ (¬φ) _,
cases h6 with L' h6, cases h7 with L h7, cases h6 with h6l h6r,
cases h7 with h7l h7r,
have h8 := imp_and_and_imp (mp (mp pl4 h6r) h7r),
have h12 := cut (mp pl6 fin_conj_append) (cut h8 (mp pl5 contra_equiv_false)),
have h13 : (∀ (ψ : form agents), ψ ∈ L' ++ L → ψ ∈ Γ),
intro ψ, intro h13,
rw list.mem_append at h13, cases h13, exact h6l ψ h13, exact h7l ψ h13,
exact absurd h12 (h1l (L' ++ L) h13),
exact h3,
exact h5,
end

lemma six (Γ : ctx agents) (h : ax_consist Γ) :
max_ax_consist Γ ↔ ∀ φ, (φ ∈ Γ ∨ (¬φ) ∈ Γ) ∧ ¬(φ ∈ Γ ∧ (¬φ) ∈ Γ) :=
begin
simp, split,
intro h1, intro φ,
split, exact six_helper Γ h h1 φ,
{rw ←not_and, by_contradiction h2,
cases h2 with h2 h3,
specialize h ([φ, ¬φ]), simp at *,
have h4 : (∀ (ψ : form agents), ψ = φ ∨ ψ = ¬φ → ψ ∈ Γ),
{intros ψ h4, cases h4, subst h4, exact h2, subst h4, exact h3},
have h5 : prfS5 ∅ (¬fin_conj [φ, ¬φ]), from fin_conj_simp φ,
exact absurd h5 (h h4)},
intro h1, split, exact h,
intros Γ' h2,
have h3 : Γ ⊆ Γ' ∧ ¬ Γ' ⊆ Γ, from h2,
cases h3,
rw set.not_subset at h3_right,
apply (exists.elim h3_right), simp, intros ψ h4 h5,
specialize h1 ψ, cases h1,
cases h1_left,
apply absurd h1_left h5,
have h6 : (¬ψ) ∈ Γ', from set.mem_of_subset_of_mem h3_left h1_left,
rw ax_consist,
push_neg,
existsi ([ψ,¬ψ] : list (form agents)),
simp, split, intros φ h7, cases h7, subst h7, exact h4,
subst h7, exact h6, rw fin_ax_consist, rw not_not,
exact fin_conj_simp ψ
end

-- Exercise 1 from class notes
lemma ex1help {Γ : ctx agents} {φ : form agents} {L L' : list (form agents)} :
  (∀ ψ ∈ L, ψ ∈ Γ) → prfS5 ∅ (fin_conj L ⊃ φ) → (∀ ψ ∈ L', ψ ∈ (insert φ Γ))
  → ∃ L'' : list (form agents), (∀ ψ ∈ L'', ψ ∈ Γ) ∧ prfS5 ∅ (fin_conj L'' ⊃ fin_conj L') :=
begin
intros h1 h2 h3, induction L',
existsi ([] : list (form agents)),
split,
intros ψ h4, exact false.elim h4,
exact iden,
simp at *, cases h3 with h3 h4,
cases L'_ih h4 with L'' L'_ih,
cases L'_ih with ih1 ih2,
cases h3,
existsi (L''++L : list (form agents)),
split,
simp at *, intros ψ h2,
cases h2 with h2 h5,
exact ih1 ψ h2,
exact h1 ψ h5,
subst h3,
exact (cut (mp pl6 fin_conj_append) (cut (mp pl5 and_switch) (imp_and_and_imp (mp (mp pl4 h2) ih2)))),
existsi (L'_hd::L'' : list (form agents)),
split, simp at *, split, exact h3, exact ih1,
exact imp_and_imp ih2
end

lemma exercise1 {Γ : ctx agents} {φ : form agents} {L : list (form agents)} :
  max_ax_consist Γ → (∀ ψ ∈ L, ψ ∈ Γ) → prfS5 ∅ (fin_conj L ⊃ φ) → φ ∈ Γ :=
begin
intros h1 h2 h3,
by_contradiction h4,
cases h1 with h1 h5,
specialize h5 (Γ ∪ {φ}),
simp at h5,
specialize h5 (set.ssubset_insert h4),
rw ax_consist at h5,
push_neg at h5,
cases h5 with L' h5,
cases h5 with h5 h6,
rw fin_ax_consist at h6,
rw not_not at h6,
have h7 := ex1help h2 h3 h5,
cases h7 with L'' h7,
cases h7 with h7 h8,
apply h1 L'' h7,
exact cut h8 h6
end

lemma max_dn (Γ : ctx agents) (h : max_ax_consist Γ) (φ : form agents) :
  φ ∈ Γ ↔ (¬¬φ) ∈ Γ :=
begin
split, intro h1,
have h2 : (∀ ψ ∈ [φ], ψ ∈ Γ) → prfS5 ∅ (fin_conj [φ] ⊃ (¬¬φ)) → (¬¬φ) ∈ Γ, from exercise1 h,
simp at *, apply h2, exact h1,
exact (cut (mp pl5 phi_and_true) dni),
intro h1,
have h2 : (∀ ψ ∈ [¬¬φ], ψ ∈ Γ) → prfS5 ∅ (fin_conj [¬¬φ] ⊃ φ) → φ ∈ Γ, from exercise1 h,
simp at *, apply h2, exact h1,
exact (cut (mp pl5 phi_and_true) dne),
end

lemma max_boxdn (Γ : ctx agents) (h : max_ax_consist Γ) (φ : form agents) (a : agents) :
  (¬K a φ) ∈ Γ → (¬ (K a (¬¬φ))) ∈ Γ :=
begin
intro h1,
have h2 : ∀ a, (∀ ψ ∈ [¬ K a φ], ψ ∈ Γ) → prfS5 ∅ (fin_conj [¬ K a φ] ⊃ (¬ (K a (¬¬φ)))) → (¬ (K a (¬¬φ))) ∈ Γ,
  from λ a, exercise1 h,
simp at *,
apply h2 a, exact h1, clear h2,
exact (cut (mp pl5 phi_and_true) (mp pl5 box_dn)),
end

lemma max_notiff (Γ : ctx agents) (h : max_ax_consist Γ) (φ : form agents) :
  φ ∉ Γ ↔ (¬φ) ∈ Γ :=
begin
split, intro h1,
have h2 := max_imp_ax h,
have h3 := six_helper Γ h2 h,
specialize h3 φ, cases h3, exact absurd h3 h1, exact h3,
intro h1,
have h2 := max_imp_ax h,
have h3 := six Γ h2,
cases h3, specialize h3_mp h (¬φ), simp at *,
cases h3_mp with mp1 mp2,
have h4 := max_dn Γ h φ,
rw ←not_iff_not at h4, apply h4.mpr, exact mp2 h1
end

lemma max_imp_1 {Γ : ctx agents} {φ ψ : form agents} :
  max_ax_consist Γ → (φ ∈ Γ → ψ ∈ Γ) → (φ ⊃ ψ) ∈ Γ :=
begin
intros h1 h2, rw imp_iff_not_or at h2,
cases h2,
have h3 : (∀ χ ∈ [¬φ], χ ∈ Γ) → prfS5 ∅ (fin_conj [¬φ] ⊃ (φ ⊃ ψ)) → (φ ⊃ ψ) ∈ Γ, from exercise1 h1,
simp at *, apply h3,
exact (max_notiff Γ h1 φ).mp h2,
exact cut (mp pl5 phi_and_true) (and_right_imp.mp exfalso),
have h3 : (∀ χ ∈ [ψ], χ ∈ Γ) → prfS5 ∅ (fin_conj [ψ] ⊃ (φ ⊃ ψ)) → (φ ⊃ ψ) ∈ Γ, from exercise1 h1,
simp at *,
apply h3, exact h2, exact (cut (mp pl5 phi_and_true) pl1),
end

lemma max_imp_2 {Γ : ctx agents} {φ ψ : form agents} :
  max_ax_consist Γ → (φ ⊃ ψ) ∈ Γ → φ ∈ Γ → ψ ∈ Γ :=
begin
intros h1 h2 h3,
have h4 : (∀ χ ∈ [φ, (φ ⊃ ψ)], χ ∈ Γ) → prfS5 ∅ (fin_conj [φ, (φ ⊃ ψ)] ⊃ ψ) → ψ ∈ Γ, from exercise1 h1,
simp at *, apply h4, intros χ h5, cases h5, subst h5, exact h3, subst h5, exact h2,
exact and_right_imp.mpr (mp pl5 phi_and_true)
end

lemma max_conj_1 {Γ : ctx agents} {φ ψ : form agents} :
  max_ax_consist Γ → (φ ∈ Γ ∧ ψ ∈ Γ) → (φ & ψ) ∈ Γ :=
begin
intros h1 h2,
have h3 : (∀ χ ∈ [φ], χ ∈ Γ) → prfS5 ∅ (fin_conj [φ] ⊃ (ψ ⊃ (φ & ψ))) → (ψ ⊃ (φ & ψ)) ∈ Γ,
  from exercise1 h1,
simp at *,
apply max_imp_2 h1,
exact (h3 h2.left) (cut (mp pl5 phi_and_true) pl4), exact h2.right
end

lemma max_conj_2 {Γ : ctx agents} {φ ψ : form agents} :
  max_ax_consist Γ → (φ & ψ) ∈ Γ → φ ∈ Γ :=
begin
intros h1 h2,
have h3 : (∀ χ ∈ [(φ & ψ)], χ ∈ Γ) → prfS5 ∅ (fin_conj [(φ & ψ)] ⊃ φ) → φ ∈ Γ,
  from exercise1 h1,
simp at *, apply h3, exact h2,
exact (cut (mp pl5 phi_and_true) pl5)
end

lemma max_conj_3 {Γ : ctx agents} {φ ψ : form agents} :
  max_ax_consist Γ → (φ & ψ) ∈ Γ → ψ ∈ Γ :=
begin
intros h1 h2,
have h3 : (∀ χ ∈ [(φ & ψ)], χ ∈ Γ) → prfS5 ∅ (fin_conj [(φ & ψ)] ⊃ ψ) → ψ ∈ Γ,
  from exercise1 h1,
simp at *, apply h3, exact h2,
exact (cut (mp pl5 phi_and_true) pl6)
end

-- Γ is maximally AX-consistent iff it is AX-consistent and for
-- every AX-consistent set Γ', if Γ ⊆ Γ', then Γ = Γ'
lemma max_equiv (Γ : ctx agents) : max_ax_consist Γ ↔ ax_consist Γ ∧
  ∀ Γ', ax_consist Γ' → Γ ⊆ Γ' → Γ = Γ' :=
begin
split,
{intro h1, split, exact h1.left,
intros Γ' h2 h3, rw set.subset.antisymm_iff, split, exact h3,
by_contradiction h4, exact h1.right Γ' (and.intro h3 h4) h2},
intro h1, split, exact h1.left,
intros Γ' h2, by_contradiction h3,
rw set.ssubset_def at h2, apply h2.right,
rw (h1.right Γ' h3) h2.left
end

open zorn
-- Lemma: if c is a chain of sets, L is a list of elements such that
-- every element in L is in Union(c), then there is an element m in c such that every
-- element of L is in m.
lemma lindenhelper (c : set (ctx agents)) (h : c.nonempty) (h1 : chain (⊆) c) (L : list (form agents)) :
(∀ φ ∈ L, φ ∈ ⋃₀(c)) → ∃ m ∈ c, (∀ ψ ∈ L, ψ ∈ m) :=
begin
intro h2,
induction L, simp,
rw ←set.nonempty_def, exact h,
have h2b : ∀ φ, φ ∈ L_tl → φ ∈ ⋃₀(c),
{intros φ h3, apply h2, exact set.mem_union_right (eq φ) h3},
cases L_ih h2b with m ih,
cases ih with h3 ih,
specialize h2 L_hd,
simp at h2,
cases h2 with m' h2,
cases h2 with h2 h4,
existsi (m' ∪ m : ctx agents),
have h5 : m' ∪ m ∈ c,
{have h6 := chain.total_of_refl h1 h3 h2,
cases h6,
exact (eq.substr (set.union_eq_self_of_subset_right h6) h2),
exact (eq.substr (set.union_eq_self_of_subset_left h6) h3)},
existsi (h5 : m' ∪ m ∈ c),
intros ψ h6, cases h6,
subst h6, exact set.mem_union_left m h4,
exact set.mem_union_right m' (ih ψ h6)
end

lemma lindenbaum (Γ : ctx agents) (hax : ax_consist Γ) :
  ∃ Γ', max_ax_consist Γ' ∧ Γ ⊆ Γ' :=
begin
let P := { Γ'' | Γ'' ⊇ Γ ∧ ax_consist Γ''},
have h : ∀ c ⊆ P, chain (⊆) c → c.nonempty → ∃ub ∈ P, ∀ s ∈ c, s ⊆ ub,
{intros c h2 h3 h4, use ⋃₀(c),
have h5 := lindenhelper c h4 h3,
repeat {split},
cases h4 with Γ'' h4,
have h6 := set.mem_of_mem_of_subset h4 h2,
cases h6 with h6 h7,
apply set.subset_sUnion_of_subset c Γ'' h6 h4,
intros L h6,
cases h5 L h6 with m h5,
cases h5 with h7 h5,
cases (set.mem_of_mem_of_subset h7 h2) with h8 h9,
apply h9, exact h5,
intros s h7, exact set.subset_sUnion_of_mem h7},
have h1 : Γ ∈ P,
split,
exact set.subset.rfl,
exact hax,
cases zorn_subset₀ P h Γ h1 with Γ' h2,
cases h2 with h2 h3,
cases h3 with h3 h4,
use Γ', split, rw max_equiv, split, apply h2.2,
intros m h5 h6, symmetry, apply h4 m, split,
apply set.subset.trans h2.1 h6,
exact h5, exact h6, apply h2.1
end

-- Corollary 8 from class notes
lemma max_ax_exists (hax : sem_cons (∅ : ctx agents) equiv_class) : ∃ Γ : ctx agents, max_ax_consist Γ :=
begin
have h1 : ax_consist ∅,
{intro L, intro h2, rw fin_ax_consist,
have h3 := listempty h2, have this : ∅ = ∅, refl,
specialize h3 this, subst h3, by_contradiction h4,
apply nprfalse hax, exact mp dne h4},
have h2 := lindenbaum ∅ h1,
cases h2 with Γ h2, cases h2 with h2 h3, existsi (Γ : ctx agents), apply h2
end


/-
Copyright (c) 2020 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/
import category_theory.abelian.exact
import category_theory.over
import algebra.category.Module.epi_mono

/-!
# Pseudoelements in abelian categories

A *pseudoelement* of an object `X` in an abelian category `C` is an equivalence class of arrows
ending in `X`, where two arrows are considered equivalent if we can find two epimorphisms with a
common domain making a commutative square with the two arrows. While the construction shows that
pseudoelements are actually subobjects of `X` rather than "elements", it is possible to chase these
pseudoelements through commutative diagrams in an abelian category to prove exactness properties.
This is done using some "diagram-chasing metatheorems" proved in this file. In many cases, a proof
in the category of abelian groups can more or less directly be converted into a proof using
pseudoelements.

A classic application of pseudoelements are diagram lemmas like the four lemma or the snake lemma.

Pseudoelements are in some ways weaker than actual elements in a concrete category. The most
important limitation is that there is no extensionality principle: If `f g : X ⟶ Y`, then
`∀ x ∈ X, f x = g x` does not necessarily imply that `f = g` (however, if `f = 0` or `g = 0`,
it does). A corollary of this is that we can not define arrows in abelian categories by dictating
their action on pseudoelements. Thus, a usual style of proofs in abelian categories is this:
First, we construct some morphism using universal properties, and then we use diagram chasing
of pseudoelements to verify that is has some desirable property such as exactness.

It should be noted that the Freyd-Mitchell embedding theorem gives a vastly stronger notion of
pseudoelement (in particular one that gives extensionality). However, this theorem is quite
difficult to prove and probably out of reach for a formal proof for the time being.

## Main results

We define the type of pseudoelements of an object and, in particular, the zero pseudoelement.

We prove that every morphism maps the zero pseudoelement to the zero pseudoelement (`apply_zero`)
and that a zero morphism maps every pseudoelement to the zero pseudoelement (`zero_apply`)

Here are the metatheorems we provide:
* A morphism `f` is zero if and only if it is the zero function on pseudoelements.
* A morphism `f` is an epimorphism if and only if it is surjective on pseudoelements.
* A morphism `f` is a monomorphism if and only if it is injective on pseudoelements
  if and only if `∀ a, f a = 0 → f = 0`.
* A sequence `f, g` of morphisms is exact if and only if
  `∀ a, g (f a) = 0` and `∀ b, g b = 0 → ∃ a, f a = b`.
* If `f` is a morphism and `a, a'` are such that `f a = f a'`, then there is some
  pseudoelement `a''` such that `f a'' = 0` and for every `g` we have
  `g a' = 0 → g a = g a''`. We can think of `a''` as `a - a'`, but don't get too carried away
  by that: pseudoelements of an object do not form an abelian group.

## Notations

We introduce coercions from an object of an abelian category to the set of its pseudoelements
and from a morphism to the function it induces on pseudoelements.

These coercions must be explicitly enabled via local instances:
`local attribute [instance] object_to_sort hom_to_fun`

## Implementation notes

It appears that sometimes the coercion from morphisms to functions does not work, i.e.,
writing `g a` raises a "function expected" error. This error can be fixed by writing
`(g : X ⟶ Y) a`.

## References

* [F. Borceux, *Handbook of Categorical Algebra 2*][borceux-vol2]
-/

open category_theory
open category_theory.limits
open category_theory.abelian
open category_theory.preadditive

universes v u

namespace category_theory.abelian

variables {C : Type u} [category.{v} C]

local attribute [instance] over.coe_from_hom

/-- This is just composition of morphisms in `C`. Another way to express this would be
    `(over.map f).obj a`, but our definition has nicer definitional properties. -/
def app {P Q : C} (f : P ⟶ Q) (a : over P) : over Q :=
a.hom ≫ f

@[simp] lemma app_hom {P Q : C} (f : P ⟶ Q) (a : over P) : (app f a).hom = a.hom ≫ f := rfl

/-- Two arrows `f : X ⟶ P` and `g : Y ⟶ P` are called pseudo-equal if there is some object
    `R` and epimorphisms `p : R ⟶ X` and `q : R ⟶ Y` such that `p ≫ f = q ≫ g`. -/
def pseudo_equal (P : C) (f g : over P) : Prop :=
∃ (R : C) (p : R ⟶ f.1) (q : R ⟶ g.1) (_ : epi p) (_ : epi q), p ≫ f.hom = q ≫ g.hom

lemma pseudo_equal_refl {P : C} : reflexive (pseudo_equal P) :=
λ f, ⟨f.1, 𝟙 f.1, 𝟙 f.1, by apply_instance, by apply_instance, by simp⟩

lemma pseudo_equal_symm {P : C} : symmetric (pseudo_equal P) :=
λ f g ⟨R, p, q, ep, eq, comm⟩, ⟨R, q, p, eq, ep, comm.symm⟩

variables [abelian.{v} C]

section

/-- Pseudoequality is transitive: Just take the pullback. The pullback morphisms will
    be epimorphisms since in an abelian category, pullbacks of epimorphisms are epimorphisms. -/
lemma pseudo_equal_trans {P : C} : transitive (pseudo_equal P) :=
λ f g h ⟨R, p, q, ep, eq, comm⟩ ⟨R', p', q', ep', eq', comm'⟩,
begin
  refine ⟨pullback q p', pullback.fst ≫ p, pullback.snd ≫ q', _, _, _⟩,
  { resetI, exact epi_comp _ _ },
  { resetI, exact epi_comp _ _ },
  { rw [category.assoc, comm, ←category.assoc, pullback.condition,
      category.assoc, comm', category.assoc] }
end

end

/-- The arrows with codomain `P` equipped with the equivalence relation of being pseudo-equal. -/
def pseudoelement.setoid (P : C) : setoid (over P) :=
⟨_, ⟨pseudo_equal_refl, pseudo_equal_symm, pseudo_equal_trans⟩⟩

local attribute [instance] pseudoelement.setoid

/-- A `pseudoelement` of `P` is just an equivalence class of arrows ending in `P` by being
    pseudo-equal. -/
def pseudoelement (P : C) : Type (max u v) := quotient (pseudoelement.setoid P)

namespace pseudoelement

/-- A coercion from an object of an abelian category to its pseudoelements. -/
def object_to_sort : has_coe_to_sort C (Type (max u v)) :=
⟨λ P, pseudoelement P⟩

local attribute [instance] object_to_sort

localized "attribute [instance] category_theory.abelian.pseudoelement.object_to_sort"
  in pseudoelement

/-- A coercion from an arrow with codomain `P` to its associated pseudoelement. -/
def over_to_sort {P : C} : has_coe (over P) (pseudoelement P) :=
⟨quot.mk (pseudo_equal P)⟩

local attribute [instance] over_to_sort

lemma over_coe_def {P Q : C} (a : Q ⟶ P) : (a : pseudoelement P) = ⟦a⟧ := rfl

/-- If two elements are pseudo-equal, then their composition with a morphism is, too. -/
lemma pseudo_apply_aux {P Q : C} (f : P ⟶ Q) (a b : over P) :
  a ≈ b → app f a ≈ app f b :=
λ ⟨R, p, q, ep, eq, comm⟩,
  ⟨R, p, q, ep, eq, show p ≫ a.hom ≫ f = q ≫ b.hom ≫ f, by rw reassoc_of comm⟩

/-- A morphism `f` induces a function `pseudo_apply f` on pseudoelements. -/
def pseudo_apply {P Q : C} (f : P ⟶ Q) : P → Q :=
quotient.map (λ (g : over P), app f g) (pseudo_apply_aux f)

/-- A coercion from morphisms to functions on pseudoelements -/
def hom_to_fun {P Q : C} : has_coe_to_fun (P ⟶ Q) (λ _, P → Q) := ⟨pseudo_apply⟩

local attribute [instance] hom_to_fun

localized "attribute [instance] category_theory.abelian.pseudoelement.hom_to_fun" in pseudoelement

lemma pseudo_apply_mk {P Q : C} (f : P ⟶ Q) (a : over P) : f ⟦a⟧ = ⟦a.hom ≫ f⟧ :=
rfl

/-- Applying a pseudoelement to a composition of morphisms is the same as composing
    with each morphism. Sadly, this is not a definitional equality, but at least it is
    true. -/
theorem comp_apply {P Q R : C} (f : P ⟶ Q) (g : Q ⟶ R) (a : P) : (f ≫ g) a = g (f a) :=
quotient.induction_on a $ λ x, quotient.sound $
by { unfold app, rw [←category.assoc, over.coe_hom] }

/-- Composition of functions on pseudoelements is composition of morphisms. -/
theorem comp_comp {P Q R : C} (f : P ⟶ Q) (g : Q ⟶ R) : g ∘ f = f ≫ g :=
funext $ λ x, (comp_apply _ _ _).symm

section zero
/-!
In this section we prove that for every `P` there is an equivalence class that contains
precisely all the zero morphisms ending in `P` and use this to define *the* zero
pseudoelement.
-/

section
local attribute [instance] has_binary_biproducts.of_has_binary_products

/-- The arrows pseudo-equal to a zero morphism are precisely the zero morphisms -/
lemma pseudo_zero_aux {P : C} (Q : C) (f : over P) : f ≈ (0 : Q ⟶ P) ↔ f.hom = 0 :=
⟨λ ⟨R, p, q, ep, eq, comm⟩, by exactI zero_of_epi_comp p (by simp [comm]),
  λ hf, ⟨biprod f.1 Q, biprod.fst, biprod.snd, by apply_instance, by apply_instance,
    by rw [hf, over.coe_hom, has_zero_morphisms.comp_zero, has_zero_morphisms.comp_zero]⟩⟩

end

lemma zero_eq_zero' {P Q R : C} :
  ⟦((0 : Q ⟶ P) : over P)⟧ = ⟦((0 : R ⟶ P) : over P)⟧ :=
quotient.sound $ (pseudo_zero_aux R _).2 rfl

/-- The zero pseudoelement is the class of a zero morphism -/
def pseudo_zero {P : C} : P := ⟦(0 : P ⟶ P)⟧

/--
We can not use `pseudo_zero` as a global `has_zero` instance,
as it would trigger on any type class search for `has_zero` applied to a `coe_sort`.
This would be too expensive.
-/
def has_zero {P : C} : has_zero P := ⟨pseudo_zero⟩
localized "attribute [instance] category_theory.abelian.pseudoelement.has_zero" in pseudoelement

instance {P : C} : inhabited (pseudoelement P) := ⟨0⟩

lemma pseudo_zero_def {P : C} : (0 : pseudoelement P) = ⟦(0 : P ⟶ P)⟧ := rfl
@[simp] lemma zero_eq_zero {P Q : C} : ⟦((0 : Q ⟶ P) : over P)⟧ = (0 : pseudoelement P) :=
zero_eq_zero'

/-- The pseudoelement induced by an arrow is zero precisely when that arrow is zero -/
lemma pseudo_zero_iff {P : C} (a : over P) : (a : P) = 0 ↔ a.hom = 0 :=
by { rw ←pseudo_zero_aux P a, exact quotient.eq }

end zero

open_locale pseudoelement

/-- Morphisms map the zero pseudoelement to the zero pseudoelement -/
@[simp] theorem apply_zero {P Q : C} (f : P ⟶ Q) : f 0 = 0 :=
by { rw [pseudo_zero_def, pseudo_apply_mk], simp }

/-- The zero morphism maps every pseudoelement to 0. -/
@[simp] theorem zero_apply {P : C} (Q : C) (a : P) : (0 : P ⟶ Q) a = 0 :=
quotient.induction_on a $ λ a',
  by { rw [pseudo_zero_def, pseudo_apply_mk], simp }

/-- An extensionality lemma for being the zero arrow. -/
theorem zero_morphism_ext {P Q : C} (f : P ⟶ Q) : (∀ a, f a = 0) → f = 0 :=
λ h, by { rw ←category.id_comp f, exact (pseudo_zero_iff ((𝟙 P ≫ f) : over Q)).1 (h (𝟙 P)) }

theorem zero_morphism_ext' {P Q : C} (f : P ⟶ Q) : (∀ a, f a = 0) → 0 = f :=
eq.symm ∘ zero_morphism_ext f

localized "attribute [ext] category_theory.abelian.pseudoelement.zero_morphism_ext
  category_theory.abelian.pseudoelement.zero_morphism_ext'" in pseudoelement

theorem eq_zero_iff {P Q : C} (f : P ⟶ Q) : f = 0 ↔ ∀ a, f a = 0 :=
⟨λ h a, by simp [h], zero_morphism_ext _⟩

/-- A monomorphism is injective on pseudoelements. -/
theorem pseudo_injective_of_mono {P Q : C} (f : P ⟶ Q) [mono f] : function.injective f :=
λ abar abar', quotient.induction_on₂ abar abar' $ λ a a' ha, quotient.sound $
  have ⟦(a.hom ≫ f : over Q)⟧ = ⟦a'.hom ≫ f⟧, by convert ha,
  match quotient.exact this with ⟨R, p, q, ep, eq, comm⟩ :=
    ⟨R, p, q, ep, eq, (cancel_mono f).1 $ by { simp only [category.assoc], exact comm }⟩
  end

/-- A morphism that is injective on pseudoelements only maps the zero element to zero. -/
lemma zero_of_map_zero {P Q : C} (f : P ⟶ Q) : function.injective f → ∀ a, f a = 0 → a = 0 :=
λ h a ha, by { rw ←apply_zero f at ha, exact h ha }

/-- A morphism that only maps the zero pseudoelement to zero is a monomorphism. -/
theorem mono_of_zero_of_map_zero {P Q : C} (f : P ⟶ Q) : (∀ a, f a = 0 → a = 0) → mono f :=
λ h, (mono_iff_cancel_zero _).2 $ λ R g hg, (pseudo_zero_iff (g : over P)).1 $ h _ $
  show f g = 0, from (pseudo_zero_iff (g ≫ f : over Q)).2 hg

section

/-- An epimorphism is surjective on pseudoelements. -/
theorem pseudo_surjective_of_epi {P Q : C} (f : P ⟶ Q) [epi f] : function.surjective f :=
λ qbar, quotient.induction_on qbar $ λ q, ⟨((pullback.fst : pullback f q.hom ⟶ P) : over P),
  quotient.sound $ ⟨pullback f q.hom, 𝟙 (pullback f q.hom), pullback.snd, by apply_instance,
    by apply_instance, by rw [category.id_comp, ←pullback.condition, app_hom, over.coe_hom]⟩⟩

end

/-- A morphism that is surjective on pseudoelements is an epimorphism. -/
theorem epi_of_pseudo_surjective {P Q : C} (f : P ⟶ Q) : function.surjective f → epi f :=
λ h, match h (𝟙 Q) with ⟨pbar, hpbar⟩ :=
  match quotient.exists_rep pbar with ⟨p, hp⟩ :=
    have ⟦(p.hom ≫ f : over Q)⟧ = ⟦𝟙 Q⟧, by { rw ←hp at hpbar, exact hpbar },
    match quotient.exact this with ⟨R, x, y, ex, ey, comm⟩ :=
      @epi_of_epi_fac _ _ _ _ _ (x ≫ p.hom) f y ey $
        by { dsimp at comm, rw [category.assoc, comm], apply category.comp_id }
    end
  end
end

section

/-- Two morphisms in an exact sequence are exact on pseudoelements. -/
theorem pseudo_exact_of_exact {P Q R : C} {f : P ⟶ Q} {g : Q ⟶ R} (h : exact f g) :
  (∀ a, g (f a) = 0) ∧ (∀ b, g b = 0 → ∃ a, f a = b) :=
⟨λ a, by { rw [←comp_apply, h.w], exact zero_apply _ _ },
  λ b', quotient.induction_on b' $ λ b hb,
    have hb' : b.hom ≫ g = 0, from (pseudo_zero_iff _).1 hb,
    begin
      -- By exactness, b factors through im f = ker g via some c
      obtain ⟨c, hc⟩ := kernel_fork.is_limit.lift' (is_limit_image f g h) _ hb',

      -- We compute the pullback of the map into the image and c.
      -- The pseudoelement induced by the first pullback map will be our preimage.
      use (pullback.fst : pullback (abelian.factor_thru_image f) c ⟶ P),

      -- It remains to show that the image of this element under f is pseudo-equal to b.
      apply quotient.sound,

      -- pullback.snd is an epimorphism because the map onto the image is!
      refine ⟨pullback (abelian.factor_thru_image f) c, 𝟙 _, pullback.snd,
        by apply_instance, by apply_instance, _⟩,

      -- Now we can verify that the diagram commutes.
      calc 𝟙 (pullback (abelian.factor_thru_image f) c) ≫ pullback.fst ≫ f = pullback.fst ≫ f
                : category.id_comp _
        ... = pullback.fst ≫ abelian.factor_thru_image f ≫ kernel.ι (cokernel.π f)
                : by rw abelian.image.fac
        ... = (pullback.snd ≫ c) ≫ kernel.ι (cokernel.π f)
                : by rw [←category.assoc, pullback.condition]
        ... = pullback.snd ≫ b.hom
                : by { rw category.assoc, congr' }
    end⟩

end

lemma apply_eq_zero_of_comp_eq_zero {P Q R : C} (f : Q ⟶ R) (a : P ⟶ Q) : a ≫ f = 0 → f a = 0 :=
λ h, by simp [over_coe_def, pseudo_apply_mk, over.coe_hom, h]

section

/-- If two morphisms are exact on pseudoelements, they are exact. -/
theorem exact_of_pseudo_exact {P Q R : C} (f : P ⟶ Q) (g : Q ⟶ R) :
  (∀ a, g (f a) = 0) ∧ (∀ b, g b = 0 → ∃ a, f a = b) → exact f g :=
λ ⟨h₁, h₂⟩, (abelian.exact_iff _ _).2 ⟨zero_morphism_ext _ $ λ a, by rw [comp_apply, h₁ a],
begin
  -- If we apply g to the pseudoelement induced by its kernel, we get 0 (of course!).
  have : g (kernel.ι g) = 0 := apply_eq_zero_of_comp_eq_zero _ _ (kernel.condition _),

  -- By pseudo-exactness, we get a preimage.
  obtain ⟨a', ha⟩ := h₂ _ this,
  obtain ⟨a, ha'⟩ := quotient.exists_rep a',
  rw ←ha' at ha,
  obtain ⟨Z, r, q, er, eq, comm⟩ := quotient.exact ha,

  -- Consider the pullback of kernel.ι (cokernel.π f) and kernel.ι g.
  -- The commutative diagram given by the pseudo-equality f a = b induces
  -- a cone over this pullback, so we get a factorization z.
  obtain ⟨z, hz₁, hz₂⟩ := @pullback.lift' _ _ _ _ _ _ (kernel.ι (cokernel.π f)) (kernel.ι g) _
    (r ≫ a.hom ≫ abelian.factor_thru_image f) q
      (by { simp only [category.assoc, abelian.image.fac], exact comm }),

  -- Let's give a name to the second pullback morphism.
  let j : pullback (kernel.ι (cokernel.π f)) (kernel.ι g) ⟶ kernel g := pullback.snd,

  -- Since q is an epimorphism, in particular this means that j is an epimorphism.
  haveI pe : epi j := by exactI epi_of_epi_fac hz₂,

  -- But is is also a monomorphism, because kernel.ι (cokernel.π f) is: A kernel is
  -- always a monomorphism and the pullback of a monomorphism is a monomorphism.
  -- But mono + epi = iso, so j is an isomorphism.
  haveI : is_iso j := is_iso_of_mono_of_epi _,

  -- But then kernel.ι g can be expressed using all of the maps of the pullback square, and we
  -- are done.
  rw (iso.eq_inv_comp (as_iso j)).2 pullback.condition.symm,
  simp only [category.assoc, kernel.condition, has_zero_morphisms.comp_zero]
end⟩

end

/-- If two pseudoelements `x` and `y` have the same image under some morphism `f`, then we can form
    their "difference" `z`. This pseudoelement has the properties that `f z = 0` and for all
    morphisms `g`, if `g y = 0` then `g z = g x`. -/
theorem sub_of_eq_image {P Q : C} (f : P ⟶ Q) (x y : P) : f x = f y →
  ∃ z, f z = 0 ∧ ∀ (R : C) (g : P ⟶ R), (g : P ⟶ R) y = 0 → g z = g x :=
quotient.induction_on₂ x y $ λ a a' h,
match quotient.exact h with ⟨R, p, q, ep, eq, comm⟩ :=
  let a'' : R ⟶ P := p ≫ a.hom - q ≫ a'.hom in ⟨a'',
    ⟨show ⟦((p ≫ a.hom - q ≫ a'.hom) ≫ f : over Q)⟧ = ⟦(0 : Q ⟶ Q)⟧,
      by { dsimp at comm, simp [sub_eq_zero.2 comm] },
      λ Z g hh,
      begin
        obtain ⟨X, p', q', ep', eq', comm'⟩ := quotient.exact hh,

        have : a'.hom ≫ g = 0,
        { apply (epi_iff_cancel_zero _).1 ep' _ (a'.hom ≫ g),
          simpa using comm' },

        apply quotient.sound,

        -- Can we prevent quotient.sound from giving us this weird `coe_b` thingy?
        change app g (a'' : over P) ≈ app g a,

        exact ⟨R, 𝟙 R, p, by apply_instance, ep, by simp [sub_eq_add_neg, this]⟩
      end⟩⟩
end

variable [limits.has_pullbacks C]
/-- If `f : P ⟶ R` and `g : Q ⟶ R` are morphisms and `p : P` and `q : Q` are pseudoelements such
    that `f p = g q`, then there is some `s : pullback f g` such that `fst s = p` and `snd s = q`.

    Remark: Borceux claims that `s` is unique, but this is false. See
    `counterexamples/pseudoelement` for details. -/
theorem pseudo_pullback {P Q R : C} {f : P ⟶ R} {g : Q ⟶ R} {p : P} {q : Q} : f p = g q →
  ∃ s, (pullback.fst : pullback f g ⟶ P) s = p ∧ (pullback.snd : pullback f g ⟶ Q) s = q :=
quotient.induction_on₂ p q $ λ x y h,
begin
  obtain ⟨Z, a, b, ea, eb, comm⟩ := quotient.exact h,

  obtain ⟨l, hl₁, hl₂⟩ := @pullback.lift' _ _ _ _ _ _ f g _ (a ≫ x.hom) (b ≫ y.hom)
    (by { simp only [category.assoc], exact comm }),

  exact ⟨l, ⟨quotient.sound ⟨Z, 𝟙 Z, a, by apply_instance, ea, by rwa category.id_comp⟩,
    quotient.sound ⟨Z, 𝟙 Z, b, by apply_instance, eb, by rwa category.id_comp⟩⟩⟩
end

section module

local attribute [-instance] hom_to_fun

/-- In the category `Module R`, if `x` and `y` are pseudoequal, then the range of the associated
morphisms is the same. -/
lemma Module.eq_range_of_pseudoequal {R : Type*} [comm_ring R] {G : Module R} {x y : over G}
  (h : pseudo_equal G x y) : x.hom.range = y.hom.range :=
begin
  obtain ⟨P, p, q, hp, hq, H⟩ := h,
  refine submodule.ext (λ a, ⟨λ ha, _, λ ha, _⟩),
  { obtain ⟨a', ha'⟩ := ha,
    obtain ⟨a'', ha''⟩ := (Module.epi_iff_surjective p).1 hp a',
    refine ⟨q a'', _⟩,
    rw [← linear_map.comp_apply, ← Module.comp_def, ← H, Module.comp_def, linear_map.comp_apply,
      ha'', ha'] },
  { obtain ⟨a', ha'⟩ := ha,
    obtain ⟨a'', ha''⟩ := (Module.epi_iff_surjective q).1 hq a',
    refine ⟨p a'', _⟩,
    rw [← linear_map.comp_apply, ← Module.comp_def, H, Module.comp_def, linear_map.comp_apply,
      ha'', ha'] }
end

end module

end pseudoelement
end category_theory.abelian


import missing.linear_algebra.matrix.pos_def
import missing.linear_algebra.matrix.spectrum
import missing.linear_algebra.eigenspace
import linear_algebra.matrix.ldl
import linear_algebra.matrix.dot_product

namespace finset
open_locale big_operators

lemma one_add_prod_le_prod_one_add {n : Type*} [fintype n] [nonempty n]
  (f : n → ℝ) (hf : ∀ i, 0 ≤ f i) :
  1 + (∏ i, f i) ≤ ∏ i, (1 + f i) :=
begin
classical,
calc
  1 + (∏ i, f i) =
      (∏ (a : n), 1 : ℝ) * ∏ (a : n) in univ \ univ, f a
       + (∏ (a : n) in ∅, 1) * ∏ (a : n) in univ \ ∅, f a : by simp
  ... ≤ ∑ (t : finset n),
          (∏ (a : n) in t, 1 : ℝ) * ∏ (a : n) in univ \ t, f a :
  begin
    convert finset.sum_le_univ_sum_of_nonneg _,
    { rw finset.sum_pair ,
      exact finset.univ_nonempty.ne_empty },
    { simp [hf, prod_nonneg] }
  end
  ... = ∏ i, (1 + f i) : by rw [prod_add, powerset_univ]
end

end finset

namespace matrix
variables {n : Type*} [fintype n] [decidable_eq n] [linear_order n] [locally_finite_order_bot n]
open_locale big_operators
open_locale matrix

namespace is_hermitian

variables {𝕜 : Type*} [decidable_eq 𝕜 ] [is_R_or_C 𝕜] {A : matrix n n 𝕜} (hA : A.is_hermitian)

lemma eigenvector_matrix_inv_mul :
  hA.eigenvector_matrix_inv ⬝ hA.eigenvector_matrix = 1 :=
by apply basis.to_matrix_mul_to_matrix_flip

theorem spectral_theorem' :
  hA.eigenvector_matrix ⬝ diagonal (coe ∘ hA.eigenvalues) ⬝ hA.eigenvector_matrixᴴ = A :=
by rw [conj_transpose_eigenvector_matrix, matrix.mul_assoc, ← spectral_theorem, ← matrix.mul_assoc,
    eigenvector_matrix_mul_inv, matrix.one_mul]

end is_hermitian

noncomputable def is_hermitian.sqrt {A : matrix n n ℝ} (hA : A.is_hermitian) : matrix n n ℝ :=
hA.eigenvector_matrix ⬝ matrix.diagonal (λ i, (hA.eigenvalues i).sqrt) ⬝ hA.eigenvector_matrixᵀ

lemma conj_transpose_eq_transpose {m n : Type*} {A : matrix m n ℝ} : Aᴴ = Aᵀ := rfl

@[simp] lemma pos_semidef.sqrt_mul_sqrt {A : matrix n n ℝ} (hA : A.pos_semidef) :
  hA.1.sqrt ⬝ hA.1.sqrt = A :=
calc
  hA.1.sqrt ⬝ hA.1.sqrt =
    hA.1.eigenvector_matrix ⬝ (matrix.diagonal (λ i, (hA.1.eigenvalues i).sqrt)
    ⬝ (hA.1.eigenvector_matrixᵀ ⬝ hA.1.eigenvector_matrix)
    ⬝ matrix.diagonal (λ i, (hA.1.eigenvalues i).sqrt)) ⬝ hA.1.eigenvector_matrixᵀ :
by simp [is_hermitian.sqrt, matrix.mul_assoc]
  ... = A :
begin
  rw [←conj_transpose_eq_transpose, hA.1.conj_transpose_eigenvector_matrix,
    hA.1.eigenvector_matrix_inv_mul, matrix.mul_one, diagonal_mul_diagonal,
    ← hA.1.conj_transpose_eigenvector_matrix],
  convert hA.1.spectral_theorem',
  funext i,
  rw [←real.sqrt_mul (hA.eigenvalues_nonneg i), real.sqrt_mul_self (hA.eigenvalues_nonneg i)],
  refl
end

lemma pos_semidef.pos_semidef_sqrt {A : matrix n n ℝ} (hA : A.pos_semidef) :
  hA.1.sqrt.pos_semidef :=
pos_semidef.conj_transpose_mul_mul _ _
  (pos_semidef_diagonal (λ i, real.sqrt_nonneg (hA.1.eigenvalues i)))

lemma is_hermitian.one_add {A : matrix n n ℝ} (hA : A.is_hermitian) : (1 + A).is_hermitian :=
by simp [is_hermitian, hA.eq]

lemma is_hermitian.has_eigenvector_one_add {A : matrix n n ℝ} (hA : A.is_hermitian) (i : n) :
  module.End.has_eigenvector (1 + A.to_lin') (1 + (hA.eigenvalues i)) ((hA.eigenvector_basis) i) :=
module.End.has_eigenvector_add
  (module.End.has_eigenvector_one (hA.has_eigenvector_eigenvector_basis i).2)
  (hA.has_eigenvector_eigenvector_basis i)

lemma pos_def.pos_def_sqrt {A : matrix n n ℝ} (hA : A.pos_def) :
  hA.1.sqrt.pos_def :=
begin
  unfold is_hermitian.sqrt,
  refine
    pos_def.conj_transpose_mul_mul _ (hA.1.eigenvector_matrixᵀ)
      (pos_def_diagonal (λ i, real.sqrt_pos.2 (hA.eigenvalues_pos i))) _,
  show det hA.1.eigenvector_matrixᵀ ≠ 0,
  rw [det_transpose],
  apply det_ne_zero_of_right_inverse hA.1.eigenvector_matrix_mul_inv,
end

lemma pos_semidef.pos_def_iff_det_ne_zero [decidable_eq n] {M : matrix n n ℝ} (hM : M.pos_semidef) :
  M.pos_def ↔ M.det ≠ 0 :=
begin
  refine ⟨pos_def.det_ne_zero, λ hdet, ⟨hM.1, _⟩⟩,
  intros x hx,
  apply lt_of_le_of_ne' (hM.2 x),
  rw [←hM.sqrt_mul_sqrt, ←mul_vec_mul_vec, dot_product_mul_vec, ←transpose_transpose hM.1.sqrt,
    vec_mul_transpose, transpose_transpose, ← conj_transpose_eq_transpose,
    hM.pos_semidef_sqrt.1.eq],
  simp only [is_R_or_C.re_to_real, star, id],
  change @inner ℝ (euclidean_space ℝ _) _ (hM.1.sqrt.mul_vec x) (hM.1.sqrt.mul_vec x) ≠ 0,
  intro hinner,
  have sqrtMdet0 : hM.1.sqrt.det = 0,
    from exists_mul_vec_eq_zero_iff.1 ⟨x, hx, inner_self_eq_zero.1 hinner⟩,
  rw [←hM.sqrt_mul_sqrt, det_mul, sqrtMdet0, mul_zero] at hdet,
  apply hdet rfl
end

/-- Subadditivity lemma for positive semidefinite matrices. This version assumes that one of the
matrices is positive definite. See `det_add_det_le_det_add` for the more general statement.

The argument is taken from Andreas Thom's comment on mathoverflow:
https://mathoverflow.net/questions/65424/determinant-of-sum-of-positive-definite-matrices/65430#65430 -/
lemma det_add_det_le_det_add' [nonempty n] (A B : matrix n n ℝ)
    (hA : A.pos_def) (hB : B.pos_semidef) :
  A.det + B.det ≤ (A + B).det :=
begin
  let sqrtA := hA.1.sqrt,
  have is_unit_det_sqrtA, from is_unit_iff_ne_zero.2 hA.pos_def_sqrt.det_ne_zero,
  have : is_unit sqrtA, from (is_unit_iff_is_unit_det _).2 is_unit_det_sqrtA,
  have is_hermitian_sqrtA : sqrtA⁻¹.is_hermitian,
  { apply is_hermitian.nonsingular_inv (hA.pos_semidef.pos_semidef_sqrt.1),
    exact is_unit_det_sqrtA },
  have pos_semidef_ABA : (sqrtA⁻¹ ⬝ B ⬝ sqrtA⁻¹).pos_semidef,
    from pos_semidef.mul_mul_of_is_hermitian hB is_hermitian_sqrtA,
  let μ := pos_semidef_ABA.1.eigenvalues,
  calc
    A.det + B.det = A.det * (1 + (sqrtA⁻¹ ⬝ B ⬝ sqrtA⁻¹).det) :
      begin
        rw [det_mul, det_mul, mul_comm _ B.det, mul_assoc, ←det_mul, ←matrix.mul_inv_rev,
          hA.pos_semidef.sqrt_mul_sqrt, mul_add, mul_one, mul_comm, mul_assoc, ←det_mul,
          nonsing_inv_mul _ (is_unit_iff_ne_zero.2 hA.det_ne_zero), det_one, mul_one]
      end
    ... = A.det * (1 + ∏ i, μ i) :
      begin
        rw pos_semidef_ABA.1.det_eq_prod_eigenvalues,
        refl
      end
    ... ≤ A.det * ∏ i, (1 + μ i) :
      begin
        apply (mul_le_mul_left hA.det_pos).2,
        apply finset.one_add_prod_le_prod_one_add μ pos_semidef_ABA.eigenvalues_nonneg
      end
    ... = A.det * (1 + sqrtA⁻¹ ⬝ B ⬝ sqrtA⁻¹).det :
      begin
        congr',
        refine (det_eq_prod_eigenvalues pos_semidef_ABA.1.eigenvector_basis
          (λ i, 1 + (pos_semidef_ABA.1.eigenvalues i)) _).symm,
        intro i,
        convert pos_semidef_ABA.1.has_eigenvector_one_add i,
        simp only [map_add, to_lin'_one, to_lin'_mul, add_left_inj],
        refl,
      end
    ... = (A+B).det :
      begin
        rw [← det_mul, ← det_conj this (A + B)],
        apply congr_arg,
        rw ←hA.pos_semidef.sqrt_mul_sqrt,
        change sqrtA ⬝ sqrtA ⬝ (1 + sqrtA⁻¹ ⬝ B ⬝ sqrtA⁻¹) = sqrtA ⬝ (sqrtA ⬝ sqrtA + B) ⬝ sqrtA⁻¹,
        rw [matrix.mul_add, matrix.mul_one, matrix.mul_add, matrix.add_mul,
          matrix.mul_assoc, matrix.mul_assoc, matrix.mul_assoc, matrix.mul_assoc,
          ← matrix.mul_assoc _ _ (B ⬝ _),
          matrix.mul_nonsing_inv _ is_unit_det_sqrtA, matrix.one_mul, matrix.mul_one,
          hA.pos_semidef.sqrt_mul_sqrt, matrix.mul_assoc]
      end
end

/-- Subadditivity lemma for positive semidefinite matrices. -/
lemma det_add_det_le_det_add [nonempty n] (A B : matrix n n ℝ)
    (hA : A.pos_semidef) (hB : B.pos_semidef) :
  A.det + B.det ≤ (A + B).det :=
begin
  by_cases hA' : A.det = 0,
  { by_cases hB' : B.det = 0,
    { simp [hA', hB'],
      apply (hA.add hB).det_nonneg },
    { rw [add_comm A B, add_comm A.det B.det],
      apply det_add_det_le_det_add' _ _ (hB.pos_def_iff_det_ne_zero.2 hB') hA }, },
  { apply det_add_det_le_det_add' _ _ (hA.pos_def_iff_det_ne_zero.2 hA') hB },
end

end matrix


theorem ex1 (n : Nat) : 0 + n = n := by
  induction n with
  | succ x ih₁ ih₂ ih₃ => admit
  | zero => rfl

theorem ex2 (n : Nat) : 0 + n = n := by
  cases n with
  | succ x ih => admit
  | zero => rfl


import data.pnat.basic
import number_theory.divisors

theorem IMO_2007_Pb_5 (a b: pnat) (h: ↑(4*a*b-1) ∈ (nat.divisors ((4*a^2-1)^2))): a=b :=
begin
  sorry
end


import linear_algebra.basis

variables {ι K M : Type*} [field K] [add_comm_group M] [module K M]

@[simp]
lemma basis.sum_extend_extends (f : ι → M)
  (hf : linear_independent K f) (i : ι) :
  (basis.sum_extend hf) (sum.inl i) = f i :=
begin
  dsimp [basis.sum_extend],
  simp,
end


/-
Copyright (c) 2021 Kevin Kappelmann. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kevin Kappelmann
-/
import algebra.continued_fractions.computation.approximations
import algebra.continued_fractions.convergents_equiv
import algebra.order.archimedean
import topology.algebra.order.basic

/-!
# Corollaries From Approximation Lemmas (`algebra.continued_fractions.computation.approximations`)

## Summary

We show that the generalized_continued_fraction given by `generalized_continued_fraction.of` in fact
is a (regular) continued fraction. Using the equivalence of the convergents computations
(`generalized_continued_fraction.convergents` and `generalized_continued_fraction.convergents'`) for
continued fractions (see `algebra.continued_fractions.convergents_equiv`), it follows that the
convergents computations for `generalized_continued_fraction.of` are equivalent.

Moreover, we show the convergence of the continued fractions computations, that is
`(generalized_continued_fraction.of v).convergents` indeed computes `v` in the limit.

## Main Definitions

- `continued_fraction.of` returns the (regular) continued fraction of a value.

## Main Theorems

- `generalized_continued_fraction.of_convergents_eq_convergents'` shows that the convergents
  computations for `generalized_continued_fraction.of` are equivalent.
- `generalized_continued_fraction.of_convergence` shows that
  `(generalized_continued_fraction.of v).convergents` converges to `v`.

## Tags

convergence, fractions
-/

variables {K : Type*} (v : K) [linear_ordered_field K] [floor_ring K]

open generalized_continued_fraction (of)
open generalized_continued_fraction

lemma generalized_continued_fraction.of_is_simple_continued_fraction :
  (of v).is_simple_continued_fraction :=
(λ _ _ nth_part_num_eq, of_part_num_eq_one nth_part_num_eq)

/-- Creates the simple continued fraction of a value. -/
def simple_continued_fraction.of : simple_continued_fraction K :=
⟨of v, generalized_continued_fraction.of_is_simple_continued_fraction v⟩

lemma simple_continued_fraction.of_is_continued_fraction :
  (simple_continued_fraction.of v).is_continued_fraction :=
(λ _ denom nth_part_denom_eq, lt_of_lt_of_le zero_lt_one
  (of_one_le_nth_part_denom nth_part_denom_eq))

/-- Creates the continued fraction of a value. -/
def continued_fraction.of : continued_fraction K :=
⟨simple_continued_fraction.of v, simple_continued_fraction.of_is_continued_fraction v⟩

namespace generalized_continued_fraction

lemma of_convergents_eq_convergents' :
  (of v).convergents = (of v).convergents' :=
@continued_fraction.convergents_eq_convergents'  _ _ (continued_fraction.of v)

section convergence
/-!
### Convergence

We next show that `(generalized_continued_fraction.of v).convergents v` converges to `v`.
-/

variable [archimedean K]
open nat

theorem of_convergence_epsilon :
  ∀ (ε > (0 : K)), ∃ (N : ℕ), ∀ (n ≥ N), |v - (of v).convergents n| < ε :=
begin
  assume ε ε_pos,
  -- use the archimedean property to obtian a suitable N
  rcases (exists_nat_gt (1 / ε) : ∃ (N' : ℕ), 1 / ε < N') with ⟨N', one_div_ε_lt_N'⟩,
  let N := max N' 5, -- set minimum to 5 to have N ≤ fib N work
  existsi N,
  assume n n_ge_N,
  let g := of v,
  cases decidable.em (g.terminated_at n) with terminated_at_n not_terminated_at_n,
  { have : v = g.convergents n, from of_correctness_of_terminated_at terminated_at_n,
    have : v - g.convergents n = 0, from sub_eq_zero.elim_right this,
    rw [this],
    exact_mod_cast ε_pos },
  { let B := g.denominators n,
    let nB := g.denominators (n + 1),
    have abs_v_sub_conv_le : |v - g.convergents n| ≤ 1 / (B * nB), from
      abs_sub_convergents_le not_terminated_at_n,
    suffices : 1 / (B * nB) < ε, from lt_of_le_of_lt abs_v_sub_conv_le this,
    -- show that `0 < (B * nB)` and then multiply by `B * nB` to get rid of the division
    have nB_ineq : (fib (n + 2) : K) ≤ nB, by
    { have : ¬g.terminated_at (n + 1 - 1), from not_terminated_at_n,
      exact (succ_nth_fib_le_of_nth_denom (or.inr this)) },
    have B_ineq : (fib (n + 1) : K) ≤ B, by
    { have : ¬g.terminated_at (n - 1), from mt (terminated_stable n.pred_le) not_terminated_at_n,
      exact (succ_nth_fib_le_of_nth_denom (or.inr this)) },
    have zero_lt_B : 0 < B, by
    { have : (0 : K) < fib (n + 1), by exact_mod_cast fib_pos n.zero_lt_succ,
      exact (lt_of_lt_of_le this B_ineq) },
    have zero_lt_mul_conts : 0 < B * nB, by
    { have : 0 < nB, by
      { have : (0 : K) < fib (n + 2), by exact_mod_cast fib_pos (n + 1).zero_lt_succ,
        exact (lt_of_lt_of_le this nB_ineq) },
      solve_by_elim [mul_pos] },
    suffices : 1 < ε * (B * nB), from (div_lt_iff zero_lt_mul_conts).elim_right this,
    -- use that `N ≥ n` was obtained from the archimedean property to show the following
    have one_lt_ε_mul_N : 1 < ε * n, by
    { have one_lt_ε_mul_N' : 1 < ε * (N' : K), from (div_lt_iff' ε_pos).elim_left one_div_ε_lt_N',
      have : (N' : K) ≤ N, by exact_mod_cast (le_max_left  _ _),
      have : ε * N' ≤ ε * n, from
        (mul_le_mul_left ε_pos).elim_right (le_trans this (by exact_mod_cast n_ge_N)),
      exact (lt_of_lt_of_le one_lt_ε_mul_N' this) },
    suffices : ε * n ≤ ε * (B * nB), from lt_of_lt_of_le one_lt_ε_mul_N this,
    -- cancel `ε`
    suffices : (n : K) ≤ B * nB, from (mul_le_mul_left ε_pos).elim_right this,
    show (n : K) ≤ B * nB,
      calc (n : K)
          ≤ fib n                     : by exact_mod_cast (le_fib_self $ le_trans
                                           (le_max_right N' 5) n_ge_N)
      ... ≤ fib (n + 1)               : by exact_mod_cast fib_le_fib_succ
      ... ≤ fib (n + 1) * fib (n + 1) : by exact_mod_cast ((fib (n + 1)).le_mul_self)
      ... ≤ fib (n + 1) * fib (n + 2) : mul_le_mul_of_nonneg_left
                                          (by exact_mod_cast fib_le_fib_succ)
                                          (by exact_mod_cast (fib (n + 1)).zero_le)
      ... ≤ B * nB                    : mul_le_mul B_ineq nB_ineq
                                          (by exact_mod_cast (fib (n + 2)).zero_le)
                                          (le_of_lt zero_lt_B) }
end

local attribute [instance] preorder.topology

theorem of_convergence [order_topology K] :
  filter.tendsto ((of v).convergents) filter.at_top $ nhds v :=
by simpa [linear_ordered_add_comm_group.tendsto_nhds, abs_sub_comm] using (of_convergence_epsilon v)

end convergence

end generalized_continued_fraction


import logic.equiv.defs
import tactic.norm_swap

open equiv tactic

/--
To properly test that norm_swap works without the help of the simplifier,
we turn off the simp lemmas that simplify swaps of the form
`swap x y x = y` and `swap x y y = x`.
-/
local attribute [-simp] swap_apply_left
local attribute [-simp] swap_apply_right

/--
We can check all possibilities of swapping of `0, 1, bit0 _, bit1 _` using the
64 combinations of `[0, 1, 2, 3]`. This example should execute and complete without error,
if `norm_swap.eval` is behaving properly.
-/
example : true := by do
  let l : list ℕ := [0, 1, 2, 3],
  let l' : list ((ℕ × ℕ) × ℕ) := (do a ← l, b ← l, c ← l, pure ((a, b), c)),
  let lhs : list expr := l'.map (λ (tup : (ℕ × ℕ) × ℕ),
    `(equiv.swap tup.fst.fst tup.fst.snd tup.snd).to_expr),
  let rhs : list expr := l'.map (λ (tup : (ℕ × ℕ) × ℕ),
    if tup.snd = tup.fst.fst then `(tup.fst.snd)
    else if tup.snd = tup.fst.snd then `(tup.fst.fst)
    else `(tup.snd)),
  let eqs : list expr := list.zip_with (λ L R, `(@eq.{1} ℕ %%L %%R)) lhs rhs,
  g ← get_goals,
  gls ← mmap mk_meta_var eqs,
  set_goals $ g ++ gls,
  triv, -- to discharge the starting `true` goal
  repeat $ tactic.norm_num norm_swap.eval [] (interactive.loc.ns [none]),
  done

example : true := by do
  let l : list ℤ := [0, 2, -1, 3, -4],
  let l' := (do a ← l, b ← l, c ← l, pure ((a, b), c)),
  ic ← mk_instance_cache `(ℤ),
  -- we have to convert the provided `int`s into numeral form for the goals
  -- to look like what they would usually: `⇑(swap -1 3) -4 = -4`, instead of
-- `⇑(swap (int.neg_succ_of_nat 0) (int.of_nat 3)) (int.neg_succ_of_nat 3) = int.neg_succ_of_nat 3`
  el ← mmap (λ (tup : (ℤ × ℤ) × ℤ), do
    (_, a) ← ic.of_int tup.fst.fst,
    (_, b) ← ic.of_int tup.fst.snd,
    (_, c) ← ic.of_int tup.snd,
    pure ((a, b), c)) l',
  (lhs : list expr) ← mmap (λ (tup : (expr × expr) × expr),
    to_expr ``((equiv.swap %%tup.fst.fst %%tup.fst.snd) %%tup.snd)) el,
  let rhs : list expr := el.map (λ (tup : (expr × expr) × expr),
    if tup.snd = tup.fst.fst then tup.fst.snd
    else if tup.snd = tup.fst.snd then tup.fst.fst
    else tup.snd),
  let eqs : list expr := list.zip_with (λ L R, `(@eq.{1} ℤ %%L %%R)) lhs rhs,
  g ← get_goals,
  gls ← mmap mk_meta_var eqs,
  set_goals $ g ++ gls,
  triv, -- to discharge the starting `true` goal
  repeat $ tactic.norm_num norm_swap.eval [] (interactive.loc.ns [none]),
  done

example : true := by do
  let l : list ℚ := [0, (2 : ℚ) / -2, -1, 3 / 5, 4],
  let l' := (do a ← l, b ← l, c ← l, pure ((a, b), c)),
  ic ← mk_instance_cache `(ℚ),
  -- we have to convert the provided `rat`s into numeral form for the goals
  -- to look like what they would usually: `⇑(swap -1 3) -4 = -4`, like with ℤ above
  el ← mmap (λ (tup : (ℚ × ℚ) × ℚ), do
    (_, a) ← ic.of_rat tup.fst.fst,
    (_, b) ← ic.of_rat tup.fst.snd,
    (_, c) ← ic.of_rat tup.snd,
    pure ((a, b), c)) l',
  (lhs : list expr) ← mmap (λ (tup : (expr × expr) × expr),
    to_expr ``((equiv.swap %%tup.fst.fst %%tup.fst.snd) %%tup.snd)) el,
  let rhs : list expr := el.map (λ (tup : (expr × expr) × expr),
    if tup.snd = tup.fst.fst then tup.fst.snd
    else if tup.snd = tup.fst.snd then tup.fst.fst
    else tup.snd),
  let eqs : list expr := list.zip_with (λ L R, `(@eq.{1} ℚ %%L %%R)) lhs rhs,
  g ← get_goals,
  gls ← mmap mk_meta_var eqs,
  set_goals $ g ++ gls,
  triv, -- to discharge the starting `true` goal
  repeat $ tactic.norm_num norm_swap.eval [] (interactive.loc.ns [none]),
  done

example : swap (3 : fin 7) 5 0 = 0 := by norm_num
example : swap (fin.succ 2 : fin 7) 5 0 = 0 := by norm_num
example : swap (3 : fin 7) 5 3 = 5 := by norm_num
example : swap (3 : fin 1) 5 0 = 0 := by norm_num
example : swap (3 : fin 7) 5 10 = 12 := by norm_fin
example : swap (2 : fin 7) 4 9 = 11 := by norm_fin
example : swap (3 : fin 7) 5 0 = 0 := by norm_num
example : swap (3 : fin 7) 12 9 = 2 := by norm_num
example : swap (0 : fin (1 + 2)) (1 : fin (nat.succ (1 + 1))) ((fin.succ 1) : fin 3) = 2 :=
by norm_num

-- norm_swap doesn't generate trace output on non-swap expressions
example : (1 : ℤ) = (1 : ℕ) := by norm_num


/-
Copyright (c) 2021 Oliver Nash. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Oliver Nash
-/
import analysis.normed_space.continuous_affine_map
import analysis.calculus.cont_diff

/-!
# Smooth affine maps

This file contains results about smoothness of affine maps.

## Main definitions:

 * `continuous_affine_map.cont_diff`: a continuous affine map is smooth

-/

namespace continuous_affine_map

variables {𝕜 V W : Type*} [nontrivially_normed_field 𝕜]
variables [normed_add_comm_group V] [normed_space 𝕜 V]
variables [normed_add_comm_group W] [normed_space 𝕜 W]

/-- A continuous affine map between normed vector spaces is smooth. -/
lemma cont_diff {n : ℕ∞} (f : V →A[𝕜] W) :
  cont_diff 𝕜 n f :=
begin
  rw f.decomp,
  apply f.cont_linear.cont_diff.add,
  simp only,
  exact cont_diff_const,
end

end continuous_affine_map