/-
Copyright (c) 2015 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Leonardo de Moura

Quotient types.
-/
prelude
import init.sigma init.setoid init.logic
open sigma.ops setoid

constant quot.{l}   : Π {A : Type.{l}}, setoid A → Type.{l}
-- Remark: if we do not use propext here, then we would need a quot.lift for propositions.
constant propext {a b : Prop} : (a ↔ b) → a = b

-- iff can now be used to do substitutions in a calculation
theorem iff_subst [subst] {a b : Prop} {P : Prop → Prop} (H₁ : a ↔ b) (H₂ : P a) : P b :=
eq.subst (propext H₁) H₂

namespace quot
  protected constant mk        : Π {A : Type}   [s : setoid A], A → quot s
  notation `⟦`:max a `⟧`:0 := quot.mk a

  constant sound     : Π {A : Type}   [s : setoid A] {a b : A}, a ≈ b → ⟦a⟧ = ⟦b⟧
  constant lift      : Π {A B : Type} [s : setoid A] (f : A → B), (∀ a b, a ≈ b → f a = f b) → quot s → B
  constant ind       : ∀ {A : Type}   [s : setoid A] {B : quot s → Prop}, (∀ a, B ⟦a⟧) → ∀ q, B q

  init_quotient

  protected theorem lift_beta {A B : Type} [setoid A] (f : A → B) (c : ∀ a b, a ≈ b → f a = f b) (a : A) : lift f c ⟦a⟧ = f a :=
  rfl

  protected theorem ind_beta {A : Type} [s : setoid A] {B : quot s → Prop} (p : ∀ a, B ⟦a⟧) (a : A) : ind p ⟦a⟧ = p a :=
  rfl

  protected definition lift_on [reducible] {A B : Type} [s : setoid A] (q : quot s) (f : A → B) (c : ∀ a b, a ≈ b → f a = f b) : B :=
  lift f c q

  protected theorem induction_on {A : Type} [s : setoid A] {B : quot s → Prop} (q : quot s) (H : ∀ a, B ⟦a⟧) : B q :=
  ind H q

  theorem exists_rep {A : Type} [s : setoid A] (q : quot s) : ∃ a : A, ⟦a⟧ = q :=
  quot.induction_on q (λ a, exists.intro a rfl)

  section
  variable {A : Type}
  variable [s : setoid A]
  variable {B : quot s → Type}
  include s

  protected definition indep [reducible] (f : Π a, B ⟦a⟧) (a : A) : Σ q, B q :=
  ⟨⟦a⟧, f a⟩

  protected lemma indep_coherent (f : Π a, B ⟦a⟧)
                       (H : ∀ (a b : A) (p : a ≈ b), eq.rec (f a) (sound p) = f b)
                       : ∀ a b, a ≈ b → quot.indep f a = quot.indep f b  :=
  λa b e, sigma.eq (sound e) (H a b e)

  protected lemma lift_indep_pr1
    (f : Π a, B ⟦a⟧) (H : ∀ (a b : A) (p : a ≈ b), eq.rec (f a) (sound p) = f b)
    (q : quot s) : (lift (quot.indep f) (quot.indep_coherent f H) q).1 = q  :=
  quot.ind (λ a, by esimp) q

  protected definition rec [reducible]
     (f : Π a, B ⟦a⟧) (H : ∀ (a b : A) (p : a ≈ b), eq.rec (f a) (sound p) = f b)
     (q : quot s) : B q :=
  let p := lift (quot.indep f) (quot.indep_coherent f H) q in
  eq.rec_on (quot.lift_indep_pr1 f H q) (p.2)

  protected definition rec_on [reducible]
     (q : quot s) (f : Π a, B ⟦a⟧) (H : ∀ (a b : A) (p : a ≈ b), eq.rec (f a) (sound p) = f b) : B q :=
  quot.rec f H q

  protected definition rec_on_subsingleton [reducible]
     [H : ∀ a, subsingleton (B ⟦a⟧)] (q : quot s) (f : Π a, B ⟦a⟧) : B q :=
  quot.rec f (λ a b h, !subsingleton.elim) q

  protected definition hrec_on [reducible]
     (q : quot s) (f : Π a, B ⟦a⟧) (c : ∀ (a b : A) (p : a ≈ b), f a == f b) : B q :=
  quot.rec_on q f
    (λ a b p, eq_of_heq (calc
      eq.rec (f a) (sound p) == f a : eq_rec_heq
                         ... == f b : c a b p))
  end

  section
  variables {A B C : Type}
  variables [s₁ : setoid A] [s₂ : setoid B]
  include s₁ s₂

  protected definition lift₂ [reducible]
     (f : A → B → C)(c : ∀ a₁ a₂ b₁ b₂, a₁ ≈ b₁ → a₂ ≈ b₂ → f a₁ a₂ = f b₁ b₂)
     (q₁ : quot s₁) (q₂ : quot s₂) : C :=
  quot.lift
    (λ a₁, lift (λ a₂, f a₁ a₂) (λ a b H, c a₁ a a₁ b (setoid.refl a₁) H) q₂)
    (λ a b H, ind (λ a', proof c a a' b a' H (setoid.refl a') qed) q₂)
    q₁

  protected definition lift_on₂ [reducible]
    (q₁ : quot s₁) (q₂ : quot s₂) (f : A → B → C) (c : ∀ a₁ a₂ b₁ b₂, a₁ ≈ b₁ → a₂ ≈ b₂ → f a₁ a₂ = f b₁ b₂) : C :=
  quot.lift₂ f c q₁ q₂

  protected theorem ind₂ {C : quot s₁ → quot s₂ → Prop} (H : ∀ a b, C ⟦a⟧ ⟦b⟧) (q₁ : quot s₁) (q₂ : quot s₂) : C q₁ q₂ :=
  quot.ind (λ a₁, quot.ind (λ a₂, H a₁ a₂) q₂) q₁

  protected theorem induction_on₂
     {C : quot s₁ → quot s₂ → Prop} (q₁ : quot s₁) (q₂ : quot s₂) (H : ∀ a b, C ⟦a⟧ ⟦b⟧) : C q₁ q₂ :=
  quot.ind (λ a₁, quot.ind (λ a₂, H a₁ a₂) q₂) q₁

  protected theorem induction_on₃
     [s₃ : setoid C]
     {D : quot s₁ → quot s₂ → quot s₃ → Prop} (q₁ : quot s₁) (q₂ : quot s₂) (q₃ : quot s₃) (H : ∀ a b c, D ⟦a⟧ ⟦b⟧ ⟦c⟧)
     : D q₁ q₂ q₃ :=
  quot.ind (λ a₁, quot.ind (λ a₂, quot.ind (λ a₃, H a₁ a₂ a₃) q₃) q₂) q₁
  end

  section exact
  variable {A : Type}
  variable [s : setoid A]
  include s

  private definition rel (q₁ q₂ : quot s) : Prop :=
  quot.lift_on₂ q₁ q₂
    (λ a₁ a₂, a₁ ≈ a₂)
    (λ a₁ a₂ b₁ b₂ a₁b₁ a₂b₂,
      propext (iff.intro
        (λ a₁a₂, setoid.trans (setoid.symm a₁b₁) (setoid.trans a₁a₂ a₂b₂))
        (λ b₁b₂, setoid.trans a₁b₁ (setoid.trans b₁b₂ (setoid.symm a₂b₂)))))

  local infix `~` := rel

  private lemma rel.refl : ∀ q : quot s, q ~ q :=
  λ q, quot.induction_on q (λ a, setoid.refl a)

  private lemma eq_imp_rel {q₁ q₂ : quot s} : q₁ = q₂ → q₁ ~ q₂ :=
  assume h, eq.rec_on h (rel.refl q₁)

  theorem exact {a b : A} : ⟦a⟧ = ⟦b⟧ → a ≈ b :=
  assume h, eq_imp_rel h
  end exact

  section
  variables {A B : Type}
  variables [s₁ : setoid A] [s₂ : setoid B]
  include s₁ s₂
  variable {C : quot s₁ → quot s₂ → Type}

  protected definition rec_on_subsingleton₂ [reducible]
     {C : quot s₁ → quot s₂ → Type₁} [H : ∀ a b, subsingleton (C ⟦a⟧ ⟦b⟧)]
     (q₁ : quot s₁) (q₂ : quot s₂) (f : Π a b, C ⟦a⟧ ⟦b⟧) : C q₁ q₂:=
  @quot.rec_on_subsingleton _ _ _
    (λ a, quot.ind _ _)
    q₁ (λ a, quot.rec_on_subsingleton q₂ (λ b, f a b))

  protected definition hrec_on₂ [reducible]
     {C : quot s₁ → quot s₂ → Type₁} (q₁ : quot s₁) (q₂ : quot s₂)
     (f : Π a b, C ⟦a⟧ ⟦b⟧) (c : ∀ a₁ a₂ b₁ b₂, a₁ ≈ b₁ → a₂ ≈ b₂ → f a₁ a₂ == f b₁ b₂) : C q₁ q₂:=
  quot.hrec_on q₁
    (λ a, quot.hrec_on q₂ (λ b, f a b) (λ b₁ b₂ p, c _ _ _ _ !setoid.refl p))
    (λ a₁ a₂ p, quot.induction_on q₂
      (λ b,
        have aux : f a₁ b == f a₂ b, from c _ _ _ _ p !setoid.refl,
        calc quot.hrec_on ⟦b⟧ (λ (b : B), f a₁ b) _
                 == f a₁ b                                 : eq_rec_heq
             ... == f a₂ b                                 : aux
             ... == quot.hrec_on ⟦b⟧ (λ (b : B), f a₂ b) _ : eq_rec_heq))
  end
end quot

attribute quot.mk                   [constructor]
attribute quot.lift_on              [unfold 4]
attribute quot.rec                  [unfold 6]
attribute quot.rec_on               [unfold 4]
attribute quot.hrec_on              [unfold 4]
attribute quot.rec_on_subsingleton  [unfold 5]
attribute quot.lift₂                [unfold 8]
attribute quot.lift_on₂             [unfold 6]
attribute quot.hrec_on₂             [unfold 6]
attribute quot.rec_on_subsingleton₂ [unfold 7]

open decidable
definition quot.has_decidable_eq [instance] {A : Type} {s : setoid A} [decR : ∀ a b : A, decidable (a ≈ b)] : decidable_eq (quot s) :=
λ q₁ q₂ : quot s,
  quot.rec_on_subsingleton₂ q₁ q₂
    (λ a₁ a₂,
      match decR a₁ a₂ with
      | inl h₁ := inl (quot.sound h₁)
      | inr h₂ := inr (λ h, absurd (quot.exact h) h₂)
      end)


/-
Copyright (c) 2022 Patrick Massot. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Patrick Massot, Floris van Doorn
-/
import to_mathlib.geometry.manifold.vector_bundle.misc
import interactive_expr
set_option trace.filter_inst_type true

/-!
# 1-jet bundles

This file contains the definition of the 1-jet bundle `J¹(M, M')`, also known as
`one_jet_bundle I M I' M'`.

We also define
* `one_jet_ext I I' f : M → J¹(M, M')`: the 1-jet extension `j¹f` of a map `f : M → M'`

We prove
* If `f` is smooth, `j¹f` is smooth.
* If `x ↦ (f₁ x, f₂ x, ϕ₁ x) : N → J¹(M₁, M₂)` and `x ↦ (f₂ x, f₃ x, ϕ₂ x) : N → J¹(M₂, M₃)`
  are smooth, then so is `x ↦ (f₁ x, f₃ x, ϕ₂ x ∘ ϕ₁ x) : N → J¹(M₁, M₃)`.
-/

noncomputable theory

open filter set equiv bundle
open_locale manifold topology bundle

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']
  {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'']
  {F : Type*} [normed_add_comm_group F] [normed_space 𝕜 F]
  {G : Type*} [topological_space G] (J : model_with_corners 𝕜 F G)
  {N : Type*} [topological_space N] [charted_space G N] [smooth_manifold_with_corners J N]
  {F' : Type*} [normed_add_comm_group F'] [normed_space 𝕜 F']
  {G' : Type*} [topological_space G'] (J' : model_with_corners 𝕜 F' G')
  {N' : Type*} [topological_space N'] [charted_space G' N'] [smooth_manifold_with_corners J' N']
  {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₃]

/-- The one jet-bundle -/

variables {M M'}

local notation `σ` := ring_hom.id 𝕜

/-- The fibers of the one jet-bundle. -/
@[nolint unused_arguments, derive [add_comm_monoid, topological_space]]
def one_jet_space (p : M × M') : Type* :=
bundle.continuous_linear_map σ E
  ((cont_mdiff_map.fst : C^∞⟮I.prod I', M × M'; I, M⟯) *ᵖ tangent_space I) E'
  ((cont_mdiff_map.snd : C^∞⟮I.prod I', M × M'; I', M'⟯) *ᵖ tangent_space I') p

variables {I I'}
-- what is better notation for this?
local notation `FJ¹MM'` := (one_jet_space I I' : M × M' → Type*)
variables (I I')
instance (p : M × M') : has_coe_to_fun (one_jet_space I I' p)
  (λ _, tangent_space I p.1 → tangent_space I' p.2) := ⟨λ φ, φ.to_fun⟩

variables (M M')

/-- The space of one jets of maps between two smooth manifolds, as a Sigma type.
Defined in terms of `bundle.total_space` to be able to put a suitable topology on it. -/
@[nolint has_inhabited_instance, reducible] -- is empty if the base manifold is empty
def one_jet_bundle := total_space (one_jet_space I I' : M × M' → Type*)

variables {I I' M M'}
local notation `J¹MM'` := one_jet_bundle I M I' M'
local notation `HJ` := model_prod (model_prod H H') (E →L[𝕜] E')

@[ext] lemma one_jet_bundle.ext {x y : J¹MM'} (h : x.1.1 = y.1.1) (h' : x.1.2 = y.1.2)
  (h'' : x.2 = y.2) : x = y :=
begin
  rcases x with ⟨⟨a, b⟩, c⟩,
  rcases y with ⟨⟨d, e⟩, f⟩,
  dsimp only at h h' h'',
  rw [h, h', h'']
end

variables (I I' M M')

section one_jet_bundle_instances

section

variables {M} (p : M × M')

instance (x : M × M') : module 𝕜 (FJ¹MM' x) :=
by delta_instance one_jet_space

end

variable (M)

instance : topological_space J¹MM' :=
by delta_instance one_jet_bundle one_jet_space

instance : fiber_bundle (E →L[𝕜] E') FJ¹MM' :=
by delta_instance one_jet_space

instance : vector_bundle 𝕜 (E →L[𝕜] E') FJ¹MM' :=
by delta_instance one_jet_space

instance : charted_space HJ J¹MM' :=
by delta_instance one_jet_bundle one_jet_space

instance : smooth_manifold_with_corners ((I.prod I').prod 𝓘(𝕜, E →L[𝕜] E')) J¹MM' :=
by delta_instance one_jet_bundle one_jet_space

end one_jet_bundle_instances

variable (M)

/-- The tangent bundle projection on the basis is a continuous map. -/
lemma one_jet_bundle_proj_continuous : continuous (π FJ¹MM') :=
continuous_proj (E →L[𝕜] E') FJ¹MM'

variables {I M I' M' J J'}

attribute [simps] cont_mdiff_map.fst cont_mdiff_map.snd

lemma one_jet_bundle_trivialization_at' (x₀ x : J¹MM') :
  (trivialization_at (E →L[𝕜] E') (one_jet_space I I') x₀.proj x).2 =
  in_coordinates' E E' (tangent_space I) (tangent_space I')
    x₀.proj.1 x.proj.1 x₀.proj.2 x.proj.2 x.2 :=
begin
  delta one_jet_space,
  rw [continuous_linear_map_trivialization_at, trivialization.continuous_linear_map_apply],
  simp_rw [in_coordinates, in_coordinates', pullback_trivialization_at],
  erw [trivialization.pullback_symmL],
  refl
end

lemma one_jet_bundle_trivialization_at (x₀ x : J¹MM')
  (h1x : x.proj.1 ∈ (chart_at H x₀.proj.1).source)
  (h2x : x.proj.2 ∈ (chart_at H' x₀.proj.2).source) :
  (trivialization_at (E →L[𝕜] E') (one_jet_space I I') x₀.proj x).2 =
  in_coordinates_core' (tangent_bundle_core I M) (tangent_bundle_core I' M')
    x₀.proj.1 x.proj.1 x₀.proj.2 x.proj.2 x.2 :=
begin
  rw [one_jet_bundle_trivialization_at', ← in_coordinates_core'_eq],
  exacts [rfl, h1x, h2x]
end

@[simp, mfld_simps]
lemma trivialization_at_one_jet_bundle_source (x₀ : M × M') :
  (trivialization_at (E →L[𝕜] E') FJ¹MM' x₀).source =
  π FJ¹MM' ⁻¹' (prod.fst ⁻¹' (chart_at H x₀.1).source ∩ prod.snd ⁻¹' (chart_at H' x₀.2).source) :=
rfl

@[simp, mfld_simps]
lemma trivialization_at_one_jet_bundle_target (x₀ : M × M') :
  (trivialization_at (E →L[𝕜] E') FJ¹MM' x₀).target =
  (prod.fst ⁻¹' (trivialization_at E (tangent_space I) x₀.1).base_set ∩
  prod.snd ⁻¹' (trivialization_at E' (tangent_space I') x₀.2).base_set) ×ˢ set.univ :=
rfl

lemma one_jet_bundle_chart_at_apply' (v v' : one_jet_bundle I M I' M') :
  chart_at HJ v v' =
  ((chart_at H v.1.1 v'.1.1, chart_at H' v.1.2 v'.1.2),
  in_coordinates' E E' (tangent_space I) (tangent_space I')
    v.1.1 v'.1.1 v.1.2 v'.1.2 v'.2) :=
begin
  ext1,
  { refl },
  rw [charted_space_chart_at_snd],
  exact one_jet_bundle_trivialization_at' v v'
end

/-- Computing the value of a chart around `v` at point `v'` in `J¹(M, M')`.
  The last component equals the continuous linear map `v'.2`, composed on both sides by an
  appropriate coordinate change function. -/
lemma one_jet_bundle_chart_at_apply (v v' : one_jet_bundle I M I' M')
  (h1v' : v'.proj.1 ∈ (chart_at H v.proj.1).source)
  (h2v' : v'.proj.2 ∈ (chart_at H' v.proj.2).source) :
  chart_at HJ v v' =
  ((chart_at H v.1.1 v'.1.1, chart_at H' v.1.2 v'.1.2),
  in_coordinates_core' (tangent_bundle_core I M) (tangent_bundle_core I' M')
    v.1.1 v'.1.1 v.1.2 v'.1.2 v'.2) :=
begin
  ext1,
  { refl },
  rw [charted_space_chart_at_snd],
  exact one_jet_bundle_trivialization_at v v' h1v' h2v'
end

/-- In `J¹(M, M')`, the source of a chart has a nice formula -/
lemma one_jet_bundle_chart_source (x₀ : J¹MM') :
  (chart_at HJ x₀).source = π FJ¹MM' ⁻¹' (chart_at (model_prod H H') x₀.proj).source :=
begin
  simp only [fiber_bundle.charted_space_chart_at,
    trivialization_at_one_jet_bundle_source] with mfld_simps,
  simp_rw [prod_univ, ← preimage_inter, ← set.prod_eq, preimage_preimage, inter_eq_left_iff_subset,
    subset_def, mem_preimage],
  intros x hx,
  rwa [trivialization.coe_fst],
  rwa [trivialization_at_one_jet_bundle_source, mem_preimage, ← set.prod_eq],
end

/-- In `J¹(M, M')`, the target of a chart has a nice formula -/
lemma one_jet_bundle_chart_target (x₀ : J¹MM') :
  (chart_at HJ x₀).target =
  prod.fst ⁻¹' (chart_at (model_prod H H') x₀.proj).target :=
begin
  simp only [fiber_bundle.charted_space_chart_at,
    trivialization_at_one_jet_bundle_target] with mfld_simps,
  simp_rw [prod_univ, preimage_inter, preimage_preimage, inter_eq_left_iff_subset,
    subset_inter_iff],
  rw [← @preimage_preimage _ _ _ (λ x, (chart_at H x₀.proj.1).symm (prod.fst x))],
  rw [← @preimage_preimage _ _ _ (λ x, (chart_at H' x₀.proj.2).symm (prod.snd x))],
  refine ⟨preimage_mono _, preimage_mono _⟩,
  { rw [← @preimage_preimage _ _ _ (chart_at H x₀.proj.1).symm],
    refine (prod_subset_preimage_fst _ _).trans (preimage_mono _),
    exact (chart_at H x₀.proj.1).target_subset_preimage_source },
  { rw [← @preimage_preimage _ _ _ (chart_at H' x₀.proj.2).symm],
    refine (prod_subset_preimage_snd _ _).trans (preimage_mono _),
    exact (chart_at H' x₀.proj.2).target_subset_preimage_source }
end

section maps

lemma smooth_one_jet_bundle_proj :
  smooth ((I.prod I').prod 𝓘(𝕜, E →L[𝕜] E')) (I.prod I') (π FJ¹MM') :=
by apply smooth_proj _

lemma smooth.one_jet_bundle_proj {f : N → J¹MM'}
  (hf : smooth J ((I.prod I').prod 𝓘(𝕜, E →L[𝕜] E')) f) :
  smooth J (I.prod I') (λ x, (f x).1) :=
smooth_one_jet_bundle_proj.comp hf

lemma smooth_at.one_jet_bundle_proj {f : N → J¹MM'} {x₀ : N}
  (hf : smooth_at J ((I.prod I').prod 𝓘(𝕜, E →L[𝕜] E')) f x₀) :
  smooth_at J (I.prod I') (λ x, (f x).1) x₀ :=
(smooth_one_jet_bundle_proj _).comp x₀ hf

/-- The constructor of one_jet_bundle, in case `sigma.mk` will not give the right type. -/
@[simp] def one_jet_bundle.mk (x : M) (y : M') (f : one_jet_space I I' (x, y)) :
  J¹MM' :=
⟨(x, y), f⟩

@[simp, mfld_simps] lemma one_jet_bundle_mk_fst {x : M} {y : M'} {f : one_jet_space I I' (x, y)} :
  (one_jet_bundle.mk x y f).1 = (x, y) := rfl

@[simp, mfld_simps] lemma one_jet_bundle_mk_snd {x : M} {y : M'} {f : one_jet_space I I' (x, y)} :
  (one_jet_bundle.mk x y f).2 = f := rfl

-- todo: refactor
lemma smooth_at_one_jet_bundle {f : N → J¹MM'} {x₀ : N} :
  smooth_at J ((I.prod I').prod 𝓘(𝕜, E →L[𝕜] E')) f x₀ ↔
  smooth_at J I (λ x, (f x).1.1) x₀ ∧ smooth_at J I' (λ x, (f x).1.2) x₀ ∧
  smooth_at J 𝓘(𝕜, E →L[𝕜] E') (in_coordinates_core I I' (λ x, (f x).1.1) (λ x, (f x).1.2)
    (λ x, (f x).2) x₀) x₀ :=
begin
  simp_rw [smooth_at, cont_mdiff_at_total_space, cont_mdiff_at_prod, and_assoc,
    and.congr_right_iff],
  intros h1f h2f,
  refine filter.eventually_eq.cont_mdiff_at_iff _,
  have h1 := h1f.continuous_at.preimage_mem_nhds ((trivialization.open_base_set _).mem_nhds
    (mem_base_set_trivialization_at E (tangent_space I) (f x₀).proj.1)),
  have h2 := h2f.continuous_at.preimage_mem_nhds ((trivialization.open_base_set _).mem_nhds
    (mem_base_set_trivialization_at E' (tangent_space I') (f x₀).proj.2)),
  filter_upwards [h1, h2],
  intros x h1x h2x,
  exact one_jet_bundle_trivialization_at (f x₀) (f x) h1x h2x,
end

lemma smooth_at_one_jet_bundle_mk {f : N → M} {g : N → M'} {ϕ : N → E →L[𝕜] E'} {x₀ : N} :
  smooth_at J ((I.prod I').prod 𝓘(𝕜, E →L[𝕜] E'))
    (λ x, one_jet_bundle.mk (f x) (g x) (ϕ x) : N → J¹MM') x₀ ↔
  smooth_at J I f x₀ ∧ smooth_at J I' g x₀ ∧
  smooth_at J 𝓘(𝕜, E →L[𝕜] E') (in_coordinates_core I I' f g ϕ x₀) x₀ :=
smooth_at_one_jet_bundle

lemma smooth_at.one_jet_bundle_mk {f : N → M} {g : N → M'} {ϕ : N → E →L[𝕜] E'} {x₀ : N}
  (hf : smooth_at J I f x₀) (hg : smooth_at J I' g x₀)
  (hϕ : smooth_at J 𝓘(𝕜, E →L[𝕜] E') (in_coordinates_core I I' f g ϕ x₀) x₀) :
  smooth_at J ((I.prod I').prod 𝓘(𝕜, E →L[𝕜] E'))
    (λ x, one_jet_bundle.mk (f x) (g x) (ϕ x) : N → J¹MM') x₀ :=
smooth_at_one_jet_bundle.mpr ⟨hf, hg, hϕ⟩

variables (I I')
/-- The one-jet extension of a function -/
def one_jet_ext (f : M → M') : M → one_jet_bundle I M I' M' :=
λ x, one_jet_bundle.mk x (f x) (mfderiv I I' f x)

variables {I I'}

lemma smooth_at.one_jet_ext {f : M → M'} {x : M} (hf : smooth_at I I' f x) :
  smooth_at I ((I.prod I').prod 𝓘(𝕜, E →L[𝕜] E')) (one_jet_ext I I' f) x :=
smooth_at_id.one_jet_bundle_mk hf (hf.mfderiv' le_rfl)

lemma smooth.one_jet_ext {f : M → M'} (hf : smooth I I' f) :
  smooth I ((I.prod I').prod 𝓘(𝕜, E →L[𝕜] E')) (one_jet_ext I I' f) :=
λ x, (hf x).smooth_at.one_jet_ext

lemma continuous_at.in_coordinates_comp {f : N → M} {g : N → M'} {h : N → N'}
  {ϕ' : N → E' →L[𝕜] F'} {ϕ : N → E →L[𝕜] E'} {x₀ : N}
  (hg : continuous_at g x₀) :
  in_coordinates_core I J' f h (λ x, ϕ' x ∘L ϕ x) x₀ =ᶠ[𝓝 x₀]
  λ x, in_coordinates_core I' J' g h ϕ' x₀ x ∘L in_coordinates_core I I' f g ϕ x₀ x :=
begin
  refine eventually_of_mem (hg.preimage_mem_nhds $
    (achart H' (g x₀)).1.open_source.mem_nhds $ mem_achart_source H' (g x₀)) (λ x hx, _),
  ext v,
  simp_rw [function.comp_apply, in_coordinates_core, in_coordinates_core',
    continuous_linear_map.comp_apply],
  rw [(tangent_bundle_core I' M').coord_change_comp_eq_self],
  exact ⟨mem_achart_source H' (g x), hx⟩
end

lemma smooth_at.clm_comp_in_coordinates_core {f : N → M} {g : N → M'} {h : N → N'}
  {ϕ' : N → E' →L[𝕜] F'} {ϕ : N → E →L[𝕜] E'} {n : N}
  (hg : continuous_at g n)
  (hϕ' : smooth_at J 𝓘(𝕜, E' →L[𝕜] F') (in_coordinates_core I' J' g h ϕ' n) n)
  (hϕ : smooth_at J 𝓘(𝕜, E →L[𝕜] E') (in_coordinates_core I I' f g ϕ n) n) :
  smooth_at J (𝓘(𝕜, E →L[𝕜] F')) (in_coordinates_core I J' f h (λ n, ϕ' n ∘L ϕ n) n) n :=
(hϕ'.clm_comp hϕ).congr_of_eventually_eq (hg.in_coordinates_comp)

variables (I')
lemma smooth_at.one_jet_comp {f1 : N' → M} (f2 : N' → M') {f3 : N' → N} {x₀ : N'}
  {h : ∀ x : N', one_jet_space I' J (f2 x, f3 x)} {g : ∀ x : N', one_jet_space I I' (f1 x, f2 x)}
  (hh : smooth_at J' ((I'.prod J).prod 𝓘(𝕜, E' →L[𝕜] F)) (λ x, one_jet_bundle.mk _ _ (h x)) x₀)
  (hg : smooth_at J' ((I.prod I').prod 𝓘(𝕜, E →L[𝕜] E')) (λ x, one_jet_bundle.mk _ _ (g x)) x₀) :
  smooth_at J' ((I.prod J).prod 𝓘(𝕜, E →L[𝕜] F))
    (λ x, one_jet_bundle.mk (f1 x) (f3 x) (h x ∘L g x) : N' → one_jet_bundle I M J N) x₀ :=
begin
  rw [smooth_at_one_jet_bundle_mk] at hh hg ⊢,
  exact ⟨hg.1, hh.2.1, hh.2.2.clm_comp_in_coordinates_core hg.2.1.continuous_at hg.2.2⟩
end

lemma smooth.one_jet_comp {f1 : N' → M} (f2 : N' → M') {f3 : N' → N}
  {h : ∀ x : N', one_jet_space I' J (f2 x, f3 x)} {g : ∀ x : N', one_jet_space I I' (f1 x, f2 x)}
  (hh : smooth J' ((I'.prod J).prod 𝓘(𝕜, E' →L[𝕜] F)) (λ x, one_jet_bundle.mk _ _ (h x)))
  (hg : smooth J' ((I.prod I').prod 𝓘(𝕜, E →L[𝕜] E')) (λ x, one_jet_bundle.mk _ _ (g x))) :
  smooth J' ((I.prod J).prod 𝓘(𝕜, E →L[𝕜] F))
    (λ x, one_jet_bundle.mk (f1 x) (f3 x) (h x ∘L g x) : N' → one_jet_bundle I M J N) :=
λ x₀, hh.smooth_at.one_jet_comp I' f2 (hg x₀)

variables {I'}
lemma smooth.one_jet_add {f : N → M} {g : N → M'}
  {ϕ ϕ' : ∀ x : N, one_jet_space I I' (f x, g x)}
  (hϕ : smooth J ((I.prod I').prod 𝓘(𝕜, E →L[𝕜] E')) (λ x, one_jet_bundle.mk _ _ (ϕ x)))
  (hϕ' : smooth J ((I.prod I').prod 𝓘(𝕜, E →L[𝕜] E')) (λ x, one_jet_bundle.mk _ _ (ϕ' x))) :
  smooth J ((I.prod I').prod 𝓘(𝕜, E →L[𝕜] E'))
    (λ x, one_jet_bundle.mk (f x) (g x) (ϕ x + ϕ' x)) :=
begin
  intro x,
  specialize hϕ x,
  specialize hϕ' x,
  rw [← smooth_at, smooth_at_one_jet_bundle_mk] at hϕ hϕ' ⊢,
  simp_rw [in_coordinates_core, in_coordinates_core', continuous_linear_map.add_comp,
    continuous_linear_map.comp_add],
  exact ⟨hϕ.1, hϕ.2.1, hϕ.2.2.add hϕ'.2.2⟩
end

variables (I' J')
/-- A useful definition to define maps between two one_jet_bundles. -/
protected def one_jet_bundle.map (f : M → N) (g : M' → N')
  (Dfinv : ∀ x : M, tangent_space J (f x) →L[𝕜] tangent_space I x) :
  one_jet_bundle I M I' M' → one_jet_bundle J N J' N' :=
λ p, one_jet_bundle.mk (f p.1.1) (g p.1.2) ((mfderiv I' J' g p.1.2 ∘L p.2) ∘L Dfinv p.1.1)
variables {I' J'}

lemma one_jet_bundle.map_map {f₂ : N → M₂} {f : M → N} {g₂ : N' → M₃} {g : M' → N'}
  {Dfinv : ∀ x : M, tangent_space J (f x) →L[𝕜] tangent_space I x}
  {Df₂inv : ∀ x : N, tangent_space I₂ (f₂ x) →L[𝕜] tangent_space J x}
  {x : J¹MM'}
  (hg₂ : mdifferentiable_at J' I₃ g₂ (g x.1.2)) (hg : mdifferentiable_at I' J' g x.1.2) :
  one_jet_bundle.map J' I₃ f₂ g₂ Df₂inv (one_jet_bundle.map I' J' f g Dfinv x) =
  one_jet_bundle.map I' I₃ (f₂ ∘ f) (g₂ ∘ g) (λ x, Dfinv x ∘L Df₂inv (f x)) x :=
begin
  ext _, { refl }, { refl },
  dsimp only [one_jet_bundle.map, one_jet_bundle.mk],
  simp_rw [← continuous_linear_map.comp_assoc, mfderiv_comp x.1.2 hg₂ hg]
end

lemma one_jet_bundle.map_id (x : J¹MM') :
  one_jet_bundle.map I' I' id id (λ x, continuous_linear_map.id 𝕜 (tangent_space I x)) x = x :=
begin
  ext _, { refl }, { refl },
  dsimp only [one_jet_bundle.map, one_jet_bundle.mk],
  simp_rw [mfderiv_id],
  -- note: rw fails since we have to unfold the type `bundle.pullback`
  erw [continuous_linear_map.id_comp],
end

lemma smooth_at.one_jet_bundle_map {f : M'' → M → N} {g : M'' → M' → N'} {x₀ : M''}
  {Dfinv : ∀ (z : M'') (x : M), tangent_space J (f z x) →L[𝕜] tangent_space I x}
  {k : M'' → J¹MM'}
  (hf : smooth_at (I''.prod I) J f.uncurry (x₀, (k x₀).1.1))
  (hg : smooth_at (I''.prod I') J' g.uncurry (x₀, (k x₀).1.2))
  (hDfinv : smooth_at I'' 𝓘(𝕜, F →L[𝕜] E)
    (in_coordinates_core J I (λ x, f x (k x).1.1) (λ x, (k x).1.1) (λ x, Dfinv x (k x).1.1) x₀) x₀)
  (hk : smooth_at I'' ((I.prod I').prod (𝓘(𝕜, E →L[𝕜] E'))) k x₀) :
  smooth_at I'' ((J.prod J').prod (𝓘(𝕜, F →L[𝕜] F')))
    (λ z, one_jet_bundle.map I' J' (f z) (g z) (Dfinv z) (k z)) x₀ :=
begin
  rw [smooth_at_one_jet_bundle] at hk,
  refine smooth_at.one_jet_comp _ _ _ _,
  refine smooth_at.one_jet_comp _ _ _ _,
  { refine hk.2.1.one_jet_bundle_mk (hg.comp x₀ (smooth_at_id.prod_mk hk.2.1)) _,
    exact cont_mdiff_at.mfderiv''' g (λ x, (k x).1.2) hg hk.2.1 le_rfl },
  { exact hk.1.one_jet_bundle_mk hk.2.1 hk.2.2 },
  exact (hf.comp x₀ (smooth_at_id.prod_mk hk.1)).one_jet_bundle_mk hk.1 hDfinv,
end

/-- A useful definition to define maps between two one_jet_bundles. -/
def map_left (f : M → N) (Dfinv : ∀ x : M, tangent_space J (f x) →L[𝕜] tangent_space I x) :
  J¹MM' → one_jet_bundle J N I' M' :=
λ p, one_jet_bundle.mk (f p.1.1) p.1.2 (p.2 ∘L Dfinv p.1.1)

lemma map_left_eq_map (f : M → N) (Dfinv : ∀ x : M, tangent_space J (f x) →L[𝕜] tangent_space I x) :
  map_left f Dfinv = one_jet_bundle.map I' I' f (id : M' → M') Dfinv :=
by { ext x, refl, refl, dsimp only [one_jet_bundle.map, map_left, one_jet_bundle_mk_snd],
  simp_rw [mfderiv_id, continuous_linear_map.id_comp] }

lemma smooth_at.map_left {f : N' → M → N} {x₀ : N'}
  {Dfinv : ∀ (z : N') (x : M), tangent_space J (f z x) →L[𝕜] tangent_space I x}
  {g : N' → J¹MM'}
  (hf : smooth_at (J'.prod I) J f.uncurry (x₀, (g x₀).1.1))
  (hDfinv : smooth_at J' 𝓘(𝕜, F →L[𝕜] E)
    (in_coordinates_core J I (λ x, f x (g x).1.1) (λ x, (g x).1.1) (λ x, Dfinv x (g x).1.1) x₀) x₀)
  (hg : smooth_at J' ((I.prod I').prod (𝓘(𝕜, E →L[𝕜] E'))) g x₀) :
  smooth_at J' ((J.prod I').prod (𝓘(𝕜, F →L[𝕜] E'))) (λ z, map_left (f z) (Dfinv z) (g z)) x₀ :=
by { simp_rw [map_left_eq_map], exact hf.one_jet_bundle_map smooth_at_snd hDfinv hg }

/-- The projection `J¹(E × P, F) → J¹(E, F)`. Not actually used. -/
def bundle_fst : one_jet_bundle (J.prod I) (N × M) I' M' → one_jet_bundle J N I' M' :=
map_left prod.fst $ λ x, continuous_linear_map.inl 𝕜 F E

/-- The projection `J¹(P × E, F) → J¹(E, F)`. -/
def bundle_snd : one_jet_bundle (J.prod I) (N × M) I' M' → J¹MM' :=
map_left prod.snd $ λ x, mfderiv I (J.prod I) (λ y, (x.1, y)) x.2

lemma bundle_snd_eq (x : one_jet_bundle (J.prod I) (N × M) I' M') :
  bundle_snd x = map_left prod.snd (λ x, continuous_linear_map.inr 𝕜 F E) x :=
by simp_rw [bundle_snd, mfderiv_prod_right]

lemma smooth_bundle_snd :
  smooth (((J.prod I).prod I').prod 𝓘(𝕜, F × E →L[𝕜] E')) ((I.prod I').prod 𝓘(𝕜, E →L[𝕜] E'))
    (bundle_snd : one_jet_bundle (J.prod I) (N × M) I' M' → J¹MM') :=
begin
  intro x₀,
  refine smooth_at.map_left _ _ smooth_at_id,
  { exact smooth_at_snd.snd },
  apply cont_mdiff_at.mfderiv'''
    (λ (x : one_jet_bundle (J.prod I) (N × M) I' M') (y : M), (x.1.1.1, y))
    (λ (x : one_jet_bundle (J.prod I) (N × M) I' M'), x.1.1.2) _ _ le_top,
  { apply_instance },
  { exact (smooth_one_jet_bundle_proj.fst.fst.prod_map smooth_id).smooth_at }, -- slow
  { exact smooth_one_jet_bundle_proj.fst.snd.smooth_at }, -- slow
end

end maps

-- move
lemma local_equiv_eq_equiv {α β} {f : local_equiv α β} {e : α ≃ β}
  (h1 : ∀ x, f x = e x) (h2 : f.source = univ) (h3 : f.target = univ) : f = e.to_local_equiv :=
begin
  refine local_equiv.ext h1 (λ y, _) h2,
  conv_rhs { rw [← f.right_inv ((set.ext_iff.mp h3 y).mpr (mem_univ y)), h1] },
  exact (e.left_inv _).symm
end

local notation `𝓜` := model_prod (model_prod H H') (E →L[𝕜] E')
/-- In the one_jet bundle to the model space, the charts are just the canonical identification
between a product type and a sigma type, a.k.a. `sigma_equiv_prod`. -/
@[simp, mfld_simps] lemma one_jet_bundle_model_space_chart_at (p : one_jet_bundle I H I' H') :
  (chart_at 𝓜 p).to_local_equiv = (sigma_equiv_prod (H × H') (E →L[𝕜] E')).to_local_equiv :=
begin
  apply local_equiv_eq_equiv,
  { intros x,
    rw [local_homeomorph.coe_coe, one_jet_bundle_chart_at_apply p x (mem_chart_source H _)
      (mem_chart_source H' _), in_coordinates_core'_tangent_bundle_core_model_space],
    ext; refl },
  { simp_rw [one_jet_bundle_chart_source, prod_charted_space_chart_at, chart_at_self_eq,
      local_homeomorph.refl_prod_refl],
    refl },
  { simp_rw [one_jet_bundle_chart_target, prod_charted_space_chart_at, chart_at_self_eq,
      local_homeomorph.refl_prod_refl],
    refl },
end

@[simp, mfld_simps] lemma one_jet_bundle_model_space_coe_chart_at (p : one_jet_bundle I H I' H') :
  ⇑(chart_at 𝓜 p) = sigma_equiv_prod (H × H') (E →L[𝕜] E') :=
by { unfold_coes, simp only with mfld_simps }

@[simp, mfld_simps] lemma one_jet_bundle_model_space_coe_chart_at_symm
  (p : one_jet_bundle I H I' H') :
  ((chart_at 𝓜 p).symm : 𝓜 → one_jet_bundle I H I' H') =
  (sigma_equiv_prod (H × H') (E →L[𝕜] E')).symm :=
by { unfold_coes, simp only with mfld_simps }

variables (I I')

/-- The canonical identification between the one_jet bundle to the model space and the product,
as a homeomorphism -/
-- note: this proof works for all vector bundles where we have proven
-- `∀ p, chart_at _ p = f.to_local_equiv`
def one_jet_bundle_model_space_homeomorph : one_jet_bundle I H I' H' ≃ₜ 𝓜 :=
{ continuous_to_fun :=
  begin
    let p : one_jet_bundle I H I' H' := ⟨(I.symm (0 : E), I'.symm (0 : E')), 0⟩,
    have : continuous (chart_at 𝓜 p),
    { rw continuous_iff_continuous_on_univ,
      convert local_homeomorph.continuous_on _,
      simp only with mfld_simps },
    simpa only with mfld_simps using this,
  end,
  continuous_inv_fun :=
  begin
    let p : one_jet_bundle I H I' H' := ⟨(I.symm (0 : E), I'.symm (0 : E')), 0⟩,
    have : continuous (chart_at 𝓜 p).symm,
    { rw continuous_iff_continuous_on_univ,
      convert local_homeomorph.continuous_on _,
      simp only with mfld_simps },
    simpa only with mfld_simps using this,
  end,
  .. sigma_equiv_prod (H × H') (E →L[𝕜] E') }

-- unused
@[simp, mfld_simps] lemma one_jet_bundle_model_space_homeomorph_coe :
  (one_jet_bundle_model_space_homeomorph I I' : one_jet_bundle I H I' H' → 𝓜) =
  sigma_equiv_prod (H × H') (E →L[𝕜] E') :=
rfl

-- unused
@[simp, mfld_simps] lemma one_jet_bundle_model_space_homeomorph_coe_symm :
  ((one_jet_bundle_model_space_homeomorph I I').symm : 𝓜 → one_jet_bundle I H I' H') =
  (sigma_equiv_prod (H × H') (E →L[𝕜] E')).symm :=
rfl


/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.ring_theory.witt_vector.basic
import Mathlib.PostPort

universes u_1 u_2

namespace Mathlib

/-!
# Teichmüller lifts

This file defines `witt_vector.teichmuller`, a monoid hom `R →* 𝕎 R`, which embeds `r : R` as the
`0`-th component of a Witt vector whose other coefficients are `0`.

## Main declarations

- `witt_vector.teichmuller`: the Teichmuller map.
- `witt_vector.map_teichmuller`: `witt_vector.teichmuller` is a natural transformation.
- `witt_vector.ghost_component_teichmuller`:
  the `n`-th ghost component of `witt_vector.teichmuller p r` is `r ^ p ^ n`.

-/

namespace witt_vector

/--
The underlying function of the monoid hom `witt_vector.teichmuller`.
The `0`-th coefficient of `teichmuller_fun p r` is `r`, and all others are `0`.
-/
def teichmuller_fun (p : ℕ) {R : Type u_1} [comm_ring R] (r : R) : witt_vector p R :=
  sorry

/-!
## `teichmuller` is a monoid homomorphism

On ghost components, it is clear that `teichmuller_fun` is a monoid homomorphism.
But in general the ghost map is not injective.
We follow the same strategy as for proving that the the ring operations on `𝕎 R`
satisfy the ring axioms.

1. We first prove it for rings `R` where `p` is invertible,
   because then the ghost map is in fact an isomorphism.
2. After that, we derive the result for `mv_polynomial R ℤ`,
3. and from that we can prove the result for arbitrary `R`.
-/

/-- The Teichmüller lift of an element of `R` to `𝕎 R`.
The `0`-th coefficient of `teichmuller p r` is `r`, and all others are `0`.
This is a monoid homomorphism. -/
def teichmuller (p : ℕ) {R : Type u_1} [hp : fact (nat.prime p)] [comm_ring R] : R →* witt_vector p R :=
  monoid_hom.mk (teichmuller_fun p) sorry sorry

@[simp] theorem teichmuller_coeff_zero (p : ℕ) {R : Type u_1} [hp : fact (nat.prime p)] [comm_ring R] (r : R) : coeff (coe_fn (teichmuller p) r) 0 = r :=
  rfl

@[simp] theorem teichmuller_coeff_pos (p : ℕ) {R : Type u_1} [hp : fact (nat.prime p)] [comm_ring R] (r : R) (n : ℕ) (hn : 0 < n) : coeff (coe_fn (teichmuller p) r) n = 0 := sorry

@[simp] theorem teichmuller_zero (p : ℕ) {R : Type u_1} [hp : fact (nat.prime p)] [comm_ring R] : coe_fn (teichmuller p) 0 = 0 := sorry

/-- `teichmuller` is a natural transformation. -/
@[simp] theorem map_teichmuller (p : ℕ) {R : Type u_1} {S : Type u_2} [hp : fact (nat.prime p)] [comm_ring R] [comm_ring S] (f : R →+* S) (r : R) : coe_fn (map f) (coe_fn (teichmuller p) r) = coe_fn (teichmuller p) (coe_fn f r) :=
  map_teichmuller_fun p f r

/-- The `n`-th ghost component of `teichmuller p r` is `r ^ p ^ n`. -/
@[simp] theorem ghost_component_teichmuller (p : ℕ) {R : Type u_1} [hp : fact (nat.prime p)] [comm_ring R] (r : R) (n : ℕ) : coe_fn (ghost_component n) (coe_fn (teichmuller p) r) = r ^ p ^ n :=
  ghost_component_teichmuller_fun p r n


/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/
import order.galois_connection
import order.complete_lattice
import tactic.monotonicity
import order.bounded_order
import logic.function.iterate

/-!
# Preorder homomorphisms

This file defines preorder homomorphisms, which are bundled monotone functions. A preorder
homomorphism `f : α →ₘ β` is a function `α → β` along with a proof that `∀ x y, x ≤ y → f x ≤ f y`.

## Main definitions

In this file we define `preorder_hom α β` a.k.a. `α →ₘ β` to be a bundled monotone map.

We also define many `preorder_hom`s. In some cases we define two versions, one with `ₘ` suffix and
one without it (e.g., `preorder_hom.compₘ` and `preorder_hom.comp`). This means that the former
function is a "more bundled" version of the latter. We can't just drop the "less bundled" version
because the more bundled version usually does not work with dot notation.

* `preorder_hom.id`: identity map as `α →ₘ α`;
* `preorder_hom.curry`: an order isomorphism between `α × β →ₘ γ` and `α →ₘ β →ₘ γ`;
* `preorder_hom.comp`: composition of two bundled monotone maps;
* `preorder_hom.compₘ`: composition of bundled monotone maps as a bundled monotone map;
* `preorder_hom.const`: constant function as a bundled monotone map;
* `preorder_hom.prod`: combine `α →ₘ β` and `α →ₘ γ` into `α →ₘ β × γ`;
* `preorder_hom.prodₘ`: a more bundled version of `preorder_hom.prod`;
* `preorder_hom.prod_iso`: order isomorphism between `α →ₘ β × γ` and `(α →ₘ β) × (α →ₘ γ)`;
* `preorder_hom.diag`: diagonal embedding of `α` into `α × α` as a bundled monotone map;
* `preorder_hom.on_diag`: restrict a monotone map `α →ₘ α →ₘ β` to the diagonal;
* `preorder_hom.fst`: projection `prod.fst : α × β → α` as a bundled monotone map;
* `preorder_hom.snd`: projection `prod.snd : α × β → β` as a bundled monotone map;
* `preorder_hom.prod_map`: `prod.map f g` as a bundled monotone map;
* `pi.eval_preorder_hom`: evaluation of a function at a point `function.eval i` as a bundled
  monotone map;
* `preorder_hom.coe_fn_hom`: coercion to function as a bundled monotone map;
* `preorder_hom.apply`: application of a `preorder_hom` at a point as a bundled monotone map;
* `preorder_hom.pi`: combine a family of monotone maps `f i : α →ₘ π i` into a monotone map
  `α →ₘ Π i, π i`;
* `preorder_hom.pi_iso`: order isomorphism between `α →ₘ Π i, π i` and `Π i, α →ₘ π i`;
* `preorder_hom.subtyle.val`: embedding `subtype.val : subtype p → α` as a bundled monotone map;
* `preorder_hom.dual`: reinterpret a monotone map `α →ₘ β` as a monotone map
  `order_dual α →ₘ order_dual β`;
* `preorder_hom.dual_iso`: order isomorphism between `α →ₘ β` and
  `order_dual (order_dual α →ₘ order_dual β)`;

We also define two functions to convert other bundled maps to `α →ₘ β`:

* `order_embedding.to_preorder_hom`: convert `α ↪o β` to `α →ₘ β`;
* `rel_hom.to_preorder_hom`: conver a `rel_hom` between strict orders to a `preorder_hom`.

## Tags

monotone map, bundled morphism
-/

/-- Bundled monotone (aka, increasing) function -/
structure preorder_hom (α β : Type*) [preorder α] [preorder β] :=
(to_fun   : α → β)
(monotone' : monotone to_fun)

infixr ` →ₘ `:25 := preorder_hom

namespace preorder_hom
variables {α β γ δ : Type*} [preorder α] [preorder β] [preorder γ] [preorder δ]

instance : has_coe_to_fun (α →ₘ β) (λ _, α → β) := ⟨preorder_hom.to_fun⟩

initialize_simps_projections preorder_hom (to_fun → coe)

protected lemma monotone (f : α →ₘ β) : monotone f := f.monotone'
protected lemma mono (f : α →ₘ β) : monotone f := f.monotone

@[simp] lemma to_fun_eq_coe {f : α →ₘ β} : f.to_fun = f := rfl
@[simp] lemma coe_fun_mk {f : α → β} (hf : _root_.monotone f) : (mk f hf : α → β) = f := rfl

@[ext] -- See library note [partially-applied ext lemmas]
lemma ext (f g : α →ₘ β) (h : (f : α → β) = g) : f = g :=
by { cases f, cases g, congr, exact h }

/-- One can lift an unbundled monotone function to a bundled one. -/
instance : can_lift (α → β) (α →ₘ β) :=
{ coe := coe_fn,
  cond := monotone,
  prf := λ f h, ⟨⟨f, h⟩, rfl⟩ }

/-- The identity function as bundled monotone function. -/
@[simps {fully_applied := ff}]
def id : α →ₘ α := ⟨id, monotone_id⟩

instance : inhabited (α →ₘ α) := ⟨id⟩

/-- The preorder structure of `α →ₘ β` is pointwise inequality: `f ≤ g ↔ ∀ a, f a ≤ g a`. -/
instance : preorder (α →ₘ β) :=
@preorder.lift (α →ₘ β) (α → β) _ coe_fn

instance {β : Type*} [partial_order β] : partial_order (α →ₘ β) :=
@partial_order.lift (α →ₘ β) (α → β) _ coe_fn ext

lemma le_def {f g : α →ₘ β} : f ≤ g ↔ ∀ x, f x ≤ g x := iff.rfl

@[simp, norm_cast] lemma coe_le_coe {f g : α →ₘ β} : (f : α → β) ≤ g ↔ f ≤ g := iff.rfl

@[simp] lemma mk_le_mk {f g : α → β} {hf hg} : mk f hf ≤ mk g hg ↔ f ≤ g := iff.rfl

@[mono] lemma apply_mono {f g : α →ₘ β} {x y : α} (h₁ : f ≤ g) (h₂ : x ≤ y) :
  f x ≤ g y :=
(h₁ x).trans $ g.mono h₂

/-- Curry/uncurry as an order isomorphism between `α × β →ₘ γ` and `α →ₘ β →ₘ γ`. -/
def curry : (α × β →ₘ γ) ≃o (α →ₘ β →ₘ γ) :=
{ to_fun := λ f, ⟨λ x, ⟨function.curry f x, λ y₁ y₂ h, f.mono ⟨le_rfl, h⟩⟩,
    λ x₁ x₂ h y, f.mono ⟨h, le_rfl⟩⟩,
  inv_fun := λ f, ⟨function.uncurry (λ x, f x), λ x y h, (f.mono h.1 x.2).trans $ (f y.1).mono h.2⟩,
  left_inv := λ f, by { ext ⟨x, y⟩, refl },
  right_inv := λ f, by { ext x y, refl },
  map_rel_iff' := λ f g, by simp [le_def] }

@[simp] lemma curry_apply (f : α × β →ₘ γ) (x : α) (y : β) : curry f x y = f (x, y) := rfl

@[simp] lemma curry_symm_apply (f : α →ₘ β →ₘ γ) (x : α × β) : curry.symm f x = f x.1 x.2 := rfl

/-- The composition of two bundled monotone functions. -/
@[simps {fully_applied := ff}]
def comp (g : β →ₘ γ) (f : α →ₘ β) : α →ₘ γ := ⟨g ∘ f, g.mono.comp f.mono⟩

@[mono] lemma comp_mono ⦃g₁ g₂ : β →ₘ γ⦄ (hg : g₁ ≤ g₂) ⦃f₁ f₂ : α →ₘ β⦄ (hf : f₁ ≤ f₂) :
  g₁.comp f₁ ≤ g₂.comp f₂ :=
λ x, (hg _).trans (g₂.mono $ hf _)

/-- The composition of two bundled monotone functions, a fully bundled version. -/
@[simps {fully_applied := ff}]
def compₘ : (β →ₘ γ) →ₘ (α →ₘ β) →ₘ α →ₘ γ :=
curry ⟨λ f : (β →ₘ γ) × (α →ₘ β), f.1.comp f.2, λ f₁ f₂ h, comp_mono h.1 h.2⟩

@[simp] lemma comp_id (f : α →ₘ β) : comp f id = f :=
by { ext, refl }

@[simp] lemma id_comp (f : α →ₘ β) : comp id f = f :=
by { ext, refl }

/-- Constant function bundled as a `preorder_hom`. -/
@[simps {fully_applied := ff}]
def const (α : Type*) [preorder α] {β : Type*} [preorder β] : β →ₘ α →ₘ β :=
{ to_fun := λ b, ⟨function.const α b, λ _ _ _, le_rfl⟩,
  monotone' := λ b₁ b₂ h x, h }

@[simp] lemma const_comp (f : α →ₘ β) (c : γ) : (const β c).comp f = const α c := rfl

@[simp] lemma comp_const (γ : Type*) [preorder γ] (f : α →ₘ β) (c : α) :
  f.comp (const γ c) = const γ (f c) := rfl

/-- Given two bundled monotone maps `f`, `g`, `f.prod g` is the map `x ↦ (f x, g x)` bundled as a
`preorder_hom`. -/
@[simps] protected def prod (f : α →ₘ β) (g : α →ₘ γ) : α →ₘ (β × γ) :=
⟨λ x, (f x, g x), λ x y h, ⟨f.mono h, g.mono h⟩⟩

@[mono] lemma prod_mono {f₁ f₂ : α →ₘ β} (hf : f₁ ≤ f₂) {g₁ g₂ : α →ₘ γ} (hg : g₁ ≤ g₂) :
  f₁.prod g₁ ≤ f₂.prod g₂ :=
λ x, prod.le_def.2 ⟨hf _, hg _⟩

lemma comp_prod_comp_same (f₁ f₂ : β →ₘ γ) (g : α →ₘ β) :
  (f₁.comp g).prod (f₂.comp g) = (f₁.prod f₂).comp g :=
rfl

/-- Given two bundled monotone maps `f`, `g`, `f.prod g` is the map `x ↦ (f x, g x)` bundled as a
`preorder_hom`. This is a fully bundled version. -/
@[simps] def prodₘ : (α →ₘ β) →ₘ (α →ₘ γ) →ₘ α →ₘ β × γ :=
curry ⟨λ f : (α →ₘ β) × (α →ₘ γ), f.1.prod f.2, λ f₁ f₂ h, prod_mono h.1 h.2⟩

/-- Diagonal embedding of `α` into `α × α` as a `preorder_hom`. -/
@[simps] def diag : α →ₘ α × α := id.prod id

/-- Restriction of `f : α →ₘ α →ₘ β` to the diagonal. -/
@[simps {simp_rhs := tt}] def on_diag (f : α →ₘ α →ₘ β) : α →ₘ β := (curry.symm f).comp diag

/-- `prod.fst` as a `preorder_hom`. -/
@[simps] def fst : α × β →ₘ α := ⟨prod.fst, λ x y h, h.1⟩

/-- `prod.snd` as a `preorder_hom`. -/
@[simps] def snd : α × β →ₘ β := ⟨prod.snd, λ x y h, h.2⟩

@[simp] lemma fst_prod_snd : (fst : α × β →ₘ α).prod snd = id :=
by { ext ⟨x, y⟩ : 2, refl }

@[simp] lemma fst_comp_prod (f : α →ₘ β) (g : α →ₘ γ) : fst.comp (f.prod g) = f := ext _ _ rfl

@[simp] lemma snd_comp_prod (f : α →ₘ β) (g : α →ₘ γ) : snd.comp (f.prod g) = g := ext _ _ rfl

/-- Order isomorphism between the space of monotone maps to `β × γ` and the product of the spaces
of monotone maps to `β` and `γ`. -/
@[simps] def prod_iso : (α →ₘ β × γ) ≃o (α →ₘ β) × (α →ₘ γ) :=
{ to_fun := λ f, (fst.comp f, snd.comp f),
  inv_fun := λ f, f.1.prod f.2,
  left_inv := λ f, by ext; refl,
  right_inv := λ f, by ext; refl,
  map_rel_iff' := λ f g, forall_and_distrib.symm }

/-- `prod.map` of two `preorder_hom`s as a `preorder_hom`. -/
@[simps] def prod_map (f : α →ₘ β) (g : γ →ₘ δ) : α × γ →ₘ β × δ :=
⟨prod.map f g, λ x y h, ⟨f.mono h.1, g.mono h.2⟩⟩

variables {ι : Type*} {π : ι → Type*} [Π i, preorder (π i)]

/-- Evaluation of an unbundled function at a point (`function.eval`) as a `preorder_hom`. -/
@[simps {fully_applied := ff}]
def _root_.pi.eval_preorder_hom (i : ι) : (Π j, π j) →ₘ π i :=
⟨function.eval i, function.monotone_eval i⟩

/-- The "forgetful functor" from `α →ₘ β` to `α → β` that takes the underlying function,
is monotone. -/
@[simps {fully_applied := ff}] def coe_fn_hom : (α →ₘ β) →ₘ (α → β) :=
{ to_fun := λ f, f,
  monotone' := λ x y h, h }

/-- Function application `λ f, f a` (for fixed `a`) is a monotone function from the
monotone function space `α →ₘ β` to `β`. See also `pi.eval_preorder_hom`.  -/
@[simps {fully_applied := ff}] def apply (x : α) : (α →ₘ β) →ₘ β :=
(pi.eval_preorder_hom x).comp coe_fn_hom

/-- Construct a bundled monotone map `α →ₘ Π i, π i` from a family of monotone maps
`f i : α →ₘ π i`. -/
@[simps] def pi (f : Π i, α →ₘ π i) : α →ₘ (Π i, π i) :=
⟨λ x i, f i x, λ x y h i, (f i).mono h⟩

/-- Order isomorphism between bundled monotone maps `α →ₘ Π i, π i` and families of bundled monotone
maps `Π i, α →ₘ π i`. -/
@[simps] def pi_iso : (α →ₘ Π i, π i) ≃o Π i, α →ₘ π i :=
{ to_fun := λ f i, (pi.eval_preorder_hom i).comp f,
  inv_fun := pi,
  left_inv := λ f, by { ext x i, refl },
  right_inv := λ f, by { ext x i, refl },
  map_rel_iff' := λ f g, forall_swap }

/-- `subtype.val` as a bundled monotone function.  -/
@[simps {fully_applied := ff}]
def subtype.val (p : α → Prop) : subtype p →ₘ α :=
⟨subtype.val, λ x y h, h⟩

-- TODO[gh-6025]: make this a global instance once safe to do so
/-- There is a unique monotone map from a subsingleton to itself. -/
local attribute [instance]
def unique [subsingleton α] : unique (α →ₘ α) :=
{ default := preorder_hom.id, uniq := λ a, ext _ _ (subsingleton.elim _ _) }

lemma preorder_hom_eq_id [subsingleton α] (g : α →ₘ α) : g = preorder_hom.id :=
subsingleton.elim _ _

/-- Reinterpret a bundled monotone function as a monotone function between dual orders. -/
@[simps] protected def dual : (α →ₘ β) ≃ (order_dual α →ₘ order_dual β) :=
{ to_fun := λ f, ⟨order_dual.to_dual ∘ f ∘ order_dual.of_dual, f.mono.dual⟩,
  inv_fun := λ f, ⟨order_dual.of_dual ∘ f ∘ order_dual.to_dual, f.mono.dual⟩,
  left_inv := λ f, ext _ _ rfl,
  right_inv := λ f, ext _ _ rfl }

/-- `preorder_hom.dual` as an order isomorphism. -/
def dual_iso (α β : Type*) [preorder α] [preorder β] :
  (α →ₘ β) ≃o order_dual (order_dual α →ₘ order_dual β) :=
{ to_equiv := preorder_hom.dual.trans order_dual.to_dual,
  map_rel_iff' := λ f g, iff.rfl }

@[simps]
instance {β : Type*} [semilattice_sup β] : has_sup (α →ₘ β) :=
{ sup := λ f g, ⟨λ a, f a ⊔ g a, f.mono.sup g.mono⟩ }

instance {β : Type*} [semilattice_sup β] : semilattice_sup (α →ₘ β) :=
{ sup := has_sup.sup,
  le_sup_left := λ a b x, le_sup_left,
  le_sup_right := λ a b x, le_sup_right,
  sup_le := λ a b c h₀ h₁ x, sup_le (h₀ x) (h₁ x),
  .. (_ : partial_order (α →ₘ β)) }

@[simps]
instance {β : Type*} [semilattice_inf β] : has_inf (α →ₘ β) :=
{ inf := λ f g, ⟨λ a, f a ⊓ g a, f.mono.inf g.mono⟩ }

instance {β : Type*} [semilattice_inf β] : semilattice_inf (α →ₘ β) :=
{ inf := (⊓),
  .. (_ : partial_order (α →ₘ β)),
  .. (dual_iso α β).symm.to_galois_insertion.lift_semilattice_inf }

instance {β : Type*} [lattice β] : lattice (α →ₘ β) :=
{ .. (_ : semilattice_sup (α →ₘ β)),
  .. (_ : semilattice_inf (α →ₘ β)) }

@[simps]
instance {β : Type*} [preorder β] [order_bot β] : has_bot (α →ₘ β) :=
{ bot := const α ⊥ }

instance {β : Type*} [preorder β] [order_bot β] : order_bot (α →ₘ β) :=
{ bot := ⊥,
  bot_le := λ a x, bot_le }

@[simps]
instance {β : Type*} [preorder β] [order_top β] : has_top (α →ₘ β) :=
{ top := const α ⊤ }

instance {β : Type*} [preorder β] [order_top β] : order_top (α →ₘ β) :=
{ top := ⊤,
  le_top := λ a x, le_top }

instance {β : Type*} [complete_lattice β] : has_Inf (α →ₘ β) :=
{ Inf := λ s, ⟨λ x, ⨅ f ∈ s, (f : _) x, λ x y h, binfi_le_binfi (λ f _, f.mono h)⟩ }

@[simp] lemma Inf_apply {β : Type*} [complete_lattice β] (s : set (α →ₘ β)) (x : α) :
  Inf s x = ⨅ f ∈ s, (f : _) x := rfl

lemma infi_apply {ι : Sort*} {β : Type*} [complete_lattice β] (f : ι → α →ₘ β) (x : α) :
  (⨅ i, f i) x = ⨅ i, f i x :=
(Inf_apply _ _).trans infi_range

@[simp, norm_cast] lemma coe_infi {ι : Sort*} {β : Type*} [complete_lattice β] (f : ι → α →ₘ β) :
  ((⨅ i, f i : α →ₘ β) : α → β) = ⨅ i, f i :=
funext $ λ x, (infi_apply f x).trans (@_root_.infi_apply _ _ _ _ (λ i, f i) _).symm

instance {β : Type*} [complete_lattice β] : has_Sup (α →ₘ β) :=
{ Sup := λ s, ⟨λ x, ⨆ f ∈ s, (f : _) x, λ x y h, bsupr_le_bsupr (λ f _, f.mono h)⟩ }

@[simp] lemma Sup_apply {β : Type*} [complete_lattice β] (s : set (α →ₘ β)) (x : α) :
  Sup s x = ⨆ f ∈ s, (f : _) x := rfl

lemma supr_apply {ι : Sort*} {β : Type*} [complete_lattice β] (f : ι → α →ₘ β) (x : α) :
  (⨆ i, f i) x = ⨆ i, f i x :=
(Sup_apply _ _).trans supr_range

@[simp, norm_cast] lemma coe_supr {ι : Sort*} {β : Type*} [complete_lattice β] (f : ι → α →ₘ β) :
  ((⨆ i, f i : α →ₘ β) : α → β) = ⨆ i, f i :=
funext $ λ x, (supr_apply f x).trans (@_root_.supr_apply _ _ _ _ (λ i, f i) _).symm

instance {β : Type*} [complete_lattice β] : complete_lattice (α →ₘ β) :=
{ Sup := Sup,
  le_Sup := λ s f hf x, le_supr_of_le f (le_supr _ hf),
  Sup_le := λ s f hf x, bsupr_le (λ g hg, hf g hg x),
  Inf := Inf,
  le_Inf := λ s f hf x, le_binfi (λ g hg, hf g hg x),
  Inf_le := λ s f hf x, infi_le_of_le f (infi_le _ hf),
  .. (_ : lattice (α →ₘ β)),
  .. preorder_hom.order_top,
  .. preorder_hom.order_bot }

lemma iterate_sup_le_sup_iff {α : Type*} [semilattice_sup α] (f : α →ₘ α) :
  (∀ n₁ n₂ a₁ a₂, f^[n₁ + n₂] (a₁ ⊔ a₂) ≤ (f^[n₁] a₁) ⊔ (f^[n₂] a₂)) ↔
  (∀ a₁ a₂, f (a₁ ⊔ a₂) ≤ (f a₁) ⊔ a₂) :=
begin
  split; intros h,
  { exact h 1 0, },
  { intros n₁ n₂ a₁ a₂, have h' : ∀ n a₁ a₂, f^[n] (a₁ ⊔ a₂) ≤ (f^[n] a₁) ⊔ a₂,
    { intros n, induction n with n ih; intros a₁ a₂,
      { refl, },
      { calc f^[n + 1] (a₁ ⊔ a₂) = (f^[n] (f (a₁ ⊔ a₂))) : function.iterate_succ_apply f n _
                             ... ≤ (f^[n] ((f a₁) ⊔ a₂)) : f.mono.iterate n (h a₁ a₂)
                             ... ≤ (f^[n] (f a₁)) ⊔ a₂ : ih _ _
                             ... = (f^[n + 1] a₁) ⊔ a₂ : by rw ← function.iterate_succ_apply, }, },
    calc f^[n₁ + n₂] (a₁ ⊔ a₂) = (f^[n₁] (f^[n₂] (a₁ ⊔ a₂))) : function.iterate_add_apply f n₁ n₂ _
                           ... = (f^[n₁] (f^[n₂] (a₂ ⊔ a₁))) : by rw sup_comm
                           ... ≤ (f^[n₁] ((f^[n₂] a₂) ⊔ a₁)) : f.mono.iterate n₁ (h' n₂ _ _)
                           ... = (f^[n₁] (a₁ ⊔ (f^[n₂] a₂))) : by rw sup_comm
                           ... ≤ (f^[n₁] a₁) ⊔ (f^[n₂] a₂) : h' n₁ a₁ _, },
end

end preorder_hom

namespace order_embedding

/-- Convert an `order_embedding` to a `preorder_hom`. -/
@[simps {fully_applied := ff}]
def to_preorder_hom {X Y : Type*} [preorder X] [preorder Y] (f : X ↪o Y) : X →ₘ Y :=
{ to_fun := f,
  monotone' := f.monotone }

end order_embedding
section rel_hom

variables {α β : Type*} [partial_order α] [preorder β]

namespace rel_hom

variables (f : ((<) : α → α → Prop) →r ((<) : β → β → Prop))

/-- A bundled expression of the fact that a map between partial orders that is strictly monotone
is weakly monotone. -/
@[simps {fully_applied := ff}]
def to_preorder_hom : α →ₘ β :=
{ to_fun    := f,
  monotone' := strict_mono.monotone (λ x y, f.map_rel), }

end rel_hom

lemma rel_embedding.to_preorder_hom_injective (f : ((<) : α → α → Prop) ↪r ((<) : β → β → Prop)) :
  function.injective (f : ((<) : α → α → Prop) →r ((<) : β → β → Prop)).to_preorder_hom :=
λ _ _ h, f.injective h

end rel_hom


/-
Copyright (c) 2020 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel, Adam Topaz, Johan Commelin
-/
import category_theory.abelian.opposite
import category_theory.limits.preserves.shapes.zero
import category_theory.limits.preserves.shapes.kernels
import category_theory.adjunction.limits
import algebra.homology.exact
import tactic.tfae

/-!
# Exact sequences in abelian categories

In an abelian category, we get several interesting results related to exactness which are not
true in more general settings.

## Main results
* `(f, g)` is exact if and only if `f ≫ g = 0` and `kernel.ι g ≫ cokernel.π f = 0`. This
  characterisation tends to be less cumbersome to work with than the original definition involving
  the comparison map `image f ⟶ kernel g`.
* If `(f, g)` is exact, then `image.ι f` has the universal property of the kernel of `g`.
* `f` is a monomorphism iff `kernel.ι f = 0` iff `exact 0 f`, and `f` is an epimorphism iff
  `cokernel.π = 0` iff `exact f 0`.
* A faithful functor between abelian categories that preserves zero morphisms reflects exact
  sequences.
* `X ⟶ Y ⟶ Z ⟶ 0` is exact if and only if the second map is a cokernel of the first, and
  `0 ⟶ X ⟶ Y ⟶ Z` is exact if and only if the first map is a kernel of the second.

-/

universes v₁ v₂ u₁ u₂

noncomputable theory

open category_theory
open category_theory.limits
open category_theory.preadditive

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

namespace category_theory

namespace abelian

variables {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z)

local attribute [instance] has_equalizers_of_has_kernels

/--
In an abelian category, a pair of morphisms `f : X ⟶ Y`, `g : Y ⟶ Z` is exact
iff `image_subobject f = kernel_subobject g`.
-/
theorem exact_iff_image_eq_kernel : exact f g ↔ image_subobject f = kernel_subobject g :=
begin
  split,
  { intro h,
    fapply subobject.eq_of_comm,
    { suffices : is_iso (image_to_kernel _ _ h.w),
      { exactI as_iso (image_to_kernel _ _ h.w), },
      exact is_iso_of_mono_of_epi _, },
    { simp, }, },
  { apply exact_of_image_eq_kernel, },
end

theorem exact_iff : exact f g ↔ f ≫ g = 0 ∧ kernel.ι g ≫ cokernel.π f = 0 :=
begin
  split,
  { intro h,
    exact ⟨h.1, kernel_comp_cokernel f g h⟩ },
  { refine λ h, ⟨h.1, _⟩,
    suffices hl : is_limit
      (kernel_fork.of_ι (image_subobject f).arrow (image_subobject_arrow_comp_eq_zero h.1)),
    { have : image_to_kernel f g h.1 =
        (is_limit.cone_point_unique_up_to_iso hl (limit.is_limit _)).hom ≫
          (kernel_subobject_iso _).inv,
      { ext, simp },
      rw this,
      apply_instance, },
    refine is_limit.of_ι _ _ _ _ _,
    { refine λ W u hu,
        kernel.lift (cokernel.π f) u _ ≫ (image_iso_image f).hom ≫ (image_subobject_iso _).inv,
      rw [←kernel.lift_ι g u hu, category.assoc, h.2, has_zero_morphisms.comp_zero] },
    { tidy },
    { intros, rw [←cancel_mono (image_subobject f).arrow, w],
      simp, } }
end

theorem exact_iff' {cg : kernel_fork g} (hg : is_limit cg)
  {cf : cokernel_cofork f} (hf : is_colimit cf) : exact f g ↔ f ≫ g = 0 ∧ cg.ι ≫ cf.π = 0 :=
begin
  split,
  { intro h,
    exact ⟨h.1, fork_ι_comp_cofork_π f g h cg cf⟩ },
  { rw exact_iff,
    refine λ h, ⟨h.1, _⟩,
    apply zero_of_epi_comp (is_limit.cone_point_unique_up_to_iso hg (limit.is_limit _)).hom,
    apply zero_of_comp_mono
      (is_colimit.cocone_point_unique_up_to_iso (colimit.is_colimit _) hf).hom,
    simp [h.2] }
end

theorem exact_tfae :
  tfae [exact f g,
        f ≫ g = 0 ∧ kernel.ι g ≫ cokernel.π f = 0,
        image_subobject f = kernel_subobject g] :=
begin
  tfae_have : 1 ↔ 2, { apply exact_iff },
  tfae_have : 1 ↔ 3, { apply exact_iff_image_eq_kernel },
  tfae_finish
end

lemma is_equivalence.exact_iff {D : Type u₁} [category.{v₁} D] [abelian D]
  (F : C ⥤ D) [is_equivalence F] :
  exact (F.map f) (F.map g) ↔ exact f g :=
begin
  simp only [exact_iff, ← F.map_eq_zero_iff, F.map_comp, category.assoc,
    ← kernel_comparison_comp_ι g F, ← π_comp_cokernel_comparison f F],
  rw [is_iso.comp_left_eq_zero (kernel_comparison g F), ← category.assoc,
    is_iso.comp_right_eq_zero _ (cokernel_comparison f F)],
end

/-- If `(f, g)` is exact, then `images.image.ι f` is a kernel of `g`. -/
def is_limit_image (h : exact f g) :
  is_limit
    (kernel_fork.of_ι (abelian.image.ι f) (image_ι_comp_eq_zero h.1) : kernel_fork g) :=
begin
  rw exact_iff at h,
  refine is_limit.of_ι _ _ _ _ _,
  { refine λ W u hu, kernel.lift (cokernel.π f) u _,
    rw [←kernel.lift_ι g u hu, category.assoc, h.2, has_zero_morphisms.comp_zero] },
  tidy
end

/-- If `(f, g)` is exact, then `image.ι f` is a kernel of `g`. -/
def is_limit_image' (h : exact f g) :
  is_limit (kernel_fork.of_ι (limits.image.ι f) (limits.image_ι_comp_eq_zero h.1)) :=
is_kernel.iso_kernel _ _ (is_limit_image f g h) (image_iso_image f).symm $ is_image.lift_fac _ _

/-- If `(f, g)` is exact, then `coimages.coimage.π g` is a cokernel of `f`. -/
def is_colimit_coimage (h : exact f g) : is_colimit (cokernel_cofork.of_π (abelian.coimage.π g)
  (abelian.comp_coimage_π_eq_zero h.1) : cokernel_cofork f) :=
begin
  rw exact_iff at h,
  refine is_colimit.of_π _ _ _ _ _,
  { refine λ W u hu, cokernel.desc (kernel.ι g) u _,
    rw [←cokernel.π_desc f u hu, ←category.assoc, h.2, has_zero_morphisms.zero_comp] },
  tidy
end

/-- If `(f, g)` is exact, then `factor_thru_image g` is a cokernel of `f`. -/
def is_colimit_image (h : exact f g) : is_colimit
  (cokernel_cofork.of_π (limits.factor_thru_image g) (comp_factor_thru_image_eq_zero h.1)) :=
is_cokernel.cokernel_iso _ _ (is_colimit_coimage f g h) (coimage_iso_image' g) $
  (cancel_mono (limits.image.ι g)).1 $ by simp

lemma exact_cokernel : exact f (cokernel.π f) :=
by { rw exact_iff, tidy }

instance (h : exact f g) : mono (cokernel.desc f g h.w) :=
suffices h : cokernel.desc f g h.w =
  (is_colimit.cocone_point_unique_up_to_iso (colimit.is_colimit _) (is_colimit_image f g h)).hom
    ≫ limits.image.ι g, by { rw h, apply mono_comp },
(cancel_epi (cokernel.π f)).1 $ by simp

/-- If `ex : exact f g` and `epi g`, then `cokernel.desc _ _ ex.w` is an isomorphism. -/
instance (ex : exact f g) [epi g] : is_iso (cokernel.desc f g ex.w) :=
is_iso_of_mono_of_epi (limits.cokernel.desc f g ex.w)

@[simp, reassoc]
lemma cokernel.desc.inv [epi g] (ex : exact f g) :
  g ≫ inv (cokernel.desc _ _ ex.w) = cokernel.π _ :=
by simp

instance (ex : exact f g) [mono f] : is_iso (kernel.lift g f ex.w) :=
  is_iso_of_mono_of_epi (limits.kernel.lift g f ex.w)

@[simp, reassoc]
lemma kernel.lift.inv [mono f] (ex : exact f g) :
  inv (kernel.lift _ _ ex.w) ≫ f = kernel.ι g :=
by simp

/-- If `X ⟶ Y ⟶ Z ⟶ 0` is exact, then the second map is a cokernel of the first. -/
def is_colimit_of_exact_of_epi [epi g] (h : exact f g) :
  is_colimit (cokernel_cofork.of_π _ h.w) :=
is_colimit.of_iso_colimit (colimit.is_colimit _) $ cocones.ext
  ⟨cokernel.desc _ _ h.w, epi_desc g (cokernel.π f) ((exact_iff _ _).1 h).2,
    (cancel_epi (cokernel.π f)).1 (by tidy), (cancel_epi g).1 (by tidy)⟩ (λ j, by cases j; simp)

/-- If `0 ⟶ X ⟶ Y ⟶ Z` is exact, then the first map is a kernel of the second. -/
def is_limit_of_exact_of_mono [mono f] (h : exact f g) :
  is_limit (kernel_fork.of_ι _ h.w) :=
is_limit.of_iso_limit (limit.is_limit _) $ cones.ext
 ⟨mono_lift f (kernel.ι g) ((exact_iff _ _).1 h).2, kernel.lift _ _ h.w,
  (cancel_mono (kernel.ι g)).1 (by tidy), (cancel_mono f).1 (by tidy)⟩ (λ j, by cases j; simp)

lemma exact_of_is_cokernel (w : f ≫ g = 0)
  (h : is_colimit (cokernel_cofork.of_π _ w)) : exact f g :=
begin
  refine (exact_iff _ _).2 ⟨w, _⟩,
  have := h.fac (cokernel_cofork.of_π _ (cokernel.condition f)) walking_parallel_pair.one,
  simp only [cofork.of_π_ι_app] at this,
  rw [← this, ← category.assoc, kernel.condition, zero_comp]
end

lemma exact_of_is_kernel (w : f ≫ g = 0)
  (h : is_limit (kernel_fork.of_ι _ w)) : exact f g :=
begin
  refine (exact_iff _ _).2 ⟨w, _⟩,
  have := h.fac (kernel_fork.of_ι _ (kernel.condition g)) walking_parallel_pair.zero,
  simp only [fork.of_ι_π_app] at this,
  rw [← this, category.assoc, cokernel.condition, comp_zero]
end

section
variables (Z)

lemma tfae_mono : tfae [mono f, kernel.ι f = 0, exact (0 : Z ⟶ X) f] :=
begin
  tfae_have : 3 → 2,
  { exact kernel_ι_eq_zero_of_exact_zero_left Z },
  tfae_have : 1 → 3,
  { introsI, exact exact_zero_left_of_mono Z },
  tfae_have : 2 → 1,
  { exact mono_of_kernel_ι_eq_zero _ },
  tfae_finish
end

-- Note we've already proved `mono_iff_exact_zero_left : mono f ↔ exact (0 : Z ⟶ X) f`
-- in any preadditive category with kernels and images.

lemma mono_iff_kernel_ι_eq_zero : mono f ↔ kernel.ι f = 0 :=
(tfae_mono X f).out 0 1

lemma tfae_epi : tfae [epi f, cokernel.π f = 0, exact f (0 : Y ⟶ Z)] :=
begin
  tfae_have : 3 → 2,
  { rw exact_iff,
    rintro ⟨-, h⟩,
    exact zero_of_epi_comp _ h },
  tfae_have : 1 → 3,
  { rw exact_iff,
    introI,
    exact ⟨by simp, by simp [cokernel.π_of_epi]⟩ },
  tfae_have : 2 → 1,
  { exact epi_of_cokernel_π_eq_zero _ },
  tfae_finish
end

-- Note we've already proved `epi_iff_exact_zero_right : epi f ↔ exact f (0 : Y ⟶ Z)`
-- in any preadditive category with equalizers and images.

lemma epi_iff_cokernel_π_eq_zero : epi f ↔ cokernel.π f = 0 :=
(tfae_epi X f).out 0 1

end

section opposite

lemma exact.op (h : exact f g) : exact g.op f.op :=
begin
  rw exact_iff,
  refine ⟨by simp [← op_comp, h.w], quiver.hom.unop_inj _⟩,
  simp only [unop_comp, cokernel.π_op, eq_to_hom_refl, kernel.ι_op, category.id_comp,
    category.assoc, kernel_comp_cokernel_assoc _ _ h, zero_comp, comp_zero, unop_zero],
end

lemma exact.op_iff : exact g.op f.op ↔ exact f g :=
⟨λ e, begin
  rw ← is_equivalence.exact_iff _ _ (op_op_equivalence C).inverse,
  exact exact.op _ _ e
end, exact.op _ _⟩

lemma exact.unop {X Y Z : Cᵒᵖ} (g : X ⟶ Y) (f : Y ⟶ Z) (h : exact g f) : exact f.unop g.unop :=
begin
  rw [← f.op_unop, ← g.op_unop] at h,
  rwa ← exact.op_iff,
end

lemma exact.unop_iff {X Y Z : Cᵒᵖ} (g : X ⟶ Y) (f : Y ⟶ Z) : exact f.unop g.unop ↔ exact g f :=
⟨λ e, by rwa [← f.op_unop, ← g.op_unop, ← exact.op_iff] at e, λ e, @@exact.unop _ _ g f e⟩

end opposite

end abelian

namespace functor
variables {D : Type u₂} [category.{v₂} D] [abelian D]

@[priority 100]
instance reflects_exact_sequences_of_preserves_zero_morphisms_of_faithful (F : C ⥤ D)
  [preserves_zero_morphisms F] [faithful F] : reflects_exact_sequences F :=
{ reflects := λ X Y Z f g hfg,
  begin
    rw [abelian.exact_iff, ← F.map_comp, F.map_eq_zero_iff] at hfg,
    refine (abelian.exact_iff _ _).2 ⟨hfg.1, F.zero_of_map_zero _ _⟩,
    obtain ⟨k, hk⟩ := kernel.lift' (F.map g) (F.map (kernel.ι g))
      (by simp only [← F.map_comp, kernel.condition, category_theory.functor.map_zero]),
    obtain ⟨l, hl⟩ := cokernel.desc' (F.map f) (F.map (cokernel.π f))
      (by simp only [← F.map_comp, cokernel.condition, category_theory.functor.map_zero]),
    rw [F.map_comp, ← hk, ← hl, category.assoc, reassoc_of hfg.2, zero_comp, comp_zero]
  end }

end functor

end category_theory


/-
# Tests for eauto
-/

import GeneralizedRewriting.Eauto
import GeneralizedRewriting.Defs

set_option trace.Meta.Tactic.eauto true
set_option trace.Meta.Tactic.eauto.hints true

--== Basic computational examples ==--

-- Assumption
example: P → P := by
  eauto

-- Function application with no intermediate variable
example: (P → Q → R → S) → R → Q → P → S := by
  eauto

-- Reverse application
example: (((P → Q) → R) → S) → (Q → R) → P → S := by
  eauto

-- Intermediate metavariable for ?a:α
example (Pα: α → Prop) (f: forall a, Pα a → β) (a: α) (ha: Pα a): β := by
  eauto

-- Backtracking example; using ha₁ first which is incorrect
example (P₁ P₂: α → Prop) (f: forall (a: α), P₁ a → P₂ a → β)
        (a: α) (_: P₁ a)
        (a': α) (ha'₁: P₁ a') (ha'₂: P₂ a'): β := by
  eauto

--== Typeclass resolution cases (on local context) ==--

-- Simplest grewrite case
example {α β: Type} {Rα: relation α} {Pα: α → Prop}
  (h₁: Proper (Rα ==> Iff) Pα)
  (I₁: forall {T: Type} {R: relation T}, Subrel R R)
  (I₂: Subrel Iff (flip impl))
  (goal: forall (R₁: relation (α → Prop)) (R₂: relation Prop),
     Proper R₁ Pα →
     Subrel R₁ (Rα ==> R₂) →
     Subrel R₂ (flip impl) → β): β := by
  eauto

-- Now we force the use of Subrel_respectful, which has instance arguments
example {α β: Type} {Rα: relation α} {Pα: α → Prop}
  (h₁: Proper (Rα ==> Iff) Pα)
  (I₁: Subrel Rα Rα)
  (I₂: Subrel (flip impl) (flip impl))
  (I₃: Subrel Iff (flip impl))
  (goal: forall (R₁: relation (α → Prop)) (R₂: relation Prop),
     Proper R₁ Pα →
     Subrel R₁ (Rα ==> R₂) →
     Subrel R₂ (flip impl) → β): β := by
  have h := @Subrel_respectful
  typeclasses_eauto

-- Then we start to introduce generic instances
example {α β: Type} {Rα: relation α} {Pα: α → Prop}
  (h₁: Proper (Rα ==> Iff) Pα)
  (goal: forall (R₁: relation (α → Prop)) (R₂: relation Prop),
     Proper R₁ Pα →
     Subrel R₁ (Rα ==> R₂) →
     Subrel R₂ (flip impl) → β): β := by
  have h₁ := @Subrel_respectful
  have h₂ := @Reflexive_Subrel
  have h₃ := @Reflexive.refl.{0}
  have h₄ := @Subrel_Iff_flip_impl
  typeclasses_eauto

--== Typeclass resolution cases (on database) ==--

eauto_create_db test_eauto_1
eauto_hint Subrel_respectful: test_eauto_1
eauto_hint Reflexive.refl: test_eauto_1
eauto_hint Reflexive_Subrel: test_eauto_1
eauto_hint Subrel_Iff_flip_impl: test_eauto_1
#print_eauto_db

-- Only locally-relevant hypotheses in context here
example {α β: Type} {Rα: relation α} {Pα: α → Prop}
  (h₁: Proper (Rα ==> Iff) Pα)
  (goal: forall (R₁: relation (α → Prop)) (R₂: relation Prop),
     Proper R₁ Pα →
     Subrel R₁ (Rα ==> R₂) →
     Subrel R₂ (flip impl) → β): β := by
  typeclasses_eauto with test_eauto_1

--== Using eauto as a typeclass resolution algorithm ==--

eauto_create_db test_eauto_2
eauto_hint Reflexive_Subrel: test_eauto_2
eauto_hint Reflexive.refl: test_eauto_2
#print_eauto_db

example {α β: Type _} {Rα: relation α} {Pα: α → Prop}
  (h₁: Proper (Rα ==> Iff) Pα)
  (goal: forall (R₁: relation (α → Prop)) (R₂: relation Prop),
     Proper R₁ Pα →
     Subrel R₁ (Rα ==> R₂) →
     Subrel R₂ (flip impl) → β): β := by
  typeclasses_eauto with test_eauto_2


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Bhavik Mehta
-/
import category_theory.limits.has_limits
import category_theory.discrete_category

noncomputable theory

universes v u u₂

open category_theory

namespace category_theory.limits

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

-- We don't need an analogue of `pair` (for binary products), `parallel_pair` (for equalizers),
-- or `(co)span`, since we already have `discrete.functor`.

/-- A fan over `f : β → C` consists of a collection of maps from an object `P` to every `f b`. -/
abbreviation fan (f : β → C) := cone (discrete.functor f)
/-- A cofan over `f : β → C` consists of a collection of maps from every `f b` to an object `P`. -/
abbreviation cofan (f : β → C) := cocone (discrete.functor f)

/-- A fan over `f : β → C` consists of a collection of maps from an object `P` to every `f b`. -/
@[simps]
def fan.mk {f : β → C} (P : C) (p : Π b, P ⟶ f b) : fan f :=
{ X := P,
  π := { app := p } }

/-- A cofan over `f : β → C` consists of a collection of maps from every `f b` to an object `P`. -/
@[simps]
def cofan.mk {f : β → C} (P : C) (p : Π b, f b ⟶ P) : cofan f :=
{ X := P,
  ι := { app := p } }

/-- An abbreviation for `has_limit (discrete.functor f)`. -/
abbreviation has_product (f : β → C) := has_limit (discrete.functor f)

/-- An abbreviation for `has_colimit (discrete.functor f)`. -/
abbreviation has_coproduct (f : β → C) := has_colimit (discrete.functor f)

section
variables (C)

/-- An abbreviation for `has_limits_of_shape (discrete f)`. -/
abbreviation has_products_of_shape (β : Type v) := has_limits_of_shape.{v} (discrete β)
/-- An abbreviation for `has_colimits_of_shape (discrete f)`. -/
abbreviation has_coproducts_of_shape (β : Type v) := has_colimits_of_shape.{v} (discrete β)
end

/-- `pi_obj f` computes the product of a family of elements `f`.
(It is defined as an abbreviation for `limit (discrete.functor f)`,
so for most facts about `pi_obj f`, you will just use general facts about limits.) -/
abbreviation pi_obj (f : β → C) [has_product f] := limit (discrete.functor f)
/-- `sigma_obj f` computes the coproduct of a family of elements `f`.
(It is defined as an abbreviation for `colimit (discrete.functor f)`,
so for most facts about `sigma_obj f`, you will just use general facts about colimits.) -/
abbreviation sigma_obj (f : β → C) [has_coproduct f] := colimit (discrete.functor f)

notation `∏ ` f:20 := pi_obj f
notation `∐ ` f:20 := sigma_obj f

/-- The `b`-th projection from the pi object over `f` has the form `∏ f ⟶ f b`. -/
abbreviation pi.π (f : β → C) [has_product f] (b : β) : ∏ f ⟶ f b :=
limit.π (discrete.functor f) b
/-- The `b`-th inclusion into the sigma object over `f` has the form `f b ⟶ ∐ f`. -/
abbreviation sigma.ι (f : β → C) [has_coproduct f] (b : β) : f b ⟶ ∐ f :=
colimit.ι (discrete.functor f) b

/-- The fan constructed of the projections from the product is limiting. -/
def product_is_product (f : β → C) [has_product f] :
  is_limit (fan.mk _ (pi.π f)) :=
is_limit.of_iso_limit (limit.is_limit (discrete.functor f)) (cones.ext (iso.refl _) (by tidy))

/-- The cofan constructed of the inclusions from the coproduct is colimiting. -/
def coproduct_is_coproduct (f : β → C) [has_coproduct f] :
  is_colimit (cofan.mk _ (sigma.ι f)) :=
is_colimit.of_iso_colimit (colimit.is_colimit (discrete.functor f)) (cocones.ext (iso.refl _)
  (by tidy))

/-- A collection of morphisms `P ⟶ f b` induces a morphism `P ⟶ ∏ f`. -/
abbreviation pi.lift {f : β → C} [has_product f] {P : C} (p : Π b, P ⟶ f b) : P ⟶ ∏ f :=
limit.lift _ (fan.mk P p)
/-- A collection of morphisms `f b ⟶ P` induces a morphism `∐ f ⟶ P`. -/
abbreviation sigma.desc {f : β → C} [has_coproduct f] {P : C} (p : Π b, f b ⟶ P) : ∐ f ⟶ P :=
colimit.desc _ (cofan.mk P p)

/--
Construct a morphism between categorical products (indexed by the same type)
from a family of morphisms between the factors.
-/
abbreviation pi.map {f g : β → C} [has_product f] [has_product g]
  (p : Π b, f b ⟶ g b) : ∏ f ⟶ ∏ g :=
lim_map (discrete.nat_trans p)
/--
Construct an isomorphism between categorical products (indexed by the same type)
from a family of isomorphisms between the factors.
-/
abbreviation pi.map_iso {f g : β → C} [has_products_of_shape β C]
  (p : Π b, f b ≅ g b) : ∏ f ≅ ∏ g :=
lim.map_iso (discrete.nat_iso p)
/--
Construct a morphism between categorical coproducts (indexed by the same type)
from a family of morphisms between the factors.
-/
abbreviation sigma.map {f g : β → C} [has_coproduct f] [has_coproduct g]
  (p : Π b, f b ⟶ g b) : ∐ f ⟶ ∐ g :=
colim_map (discrete.nat_trans p)
/--
Construct an isomorphism between categorical coproducts (indexed by the same type)
from a family of isomorphisms between the factors.
-/
abbreviation sigma.map_iso {f g : β → C} [has_coproducts_of_shape β C]
  (p : Π b, f b ≅ g b) : ∐ f ≅ ∐ g :=
colim.map_iso (discrete.nat_iso p)

section comparison

variables {D : Type u₂} [category.{v} D] (G : C ⥤ D)
variables (f : β → C)

-- TODO: show this is an iso iff G preserves the product of f.
/-- The comparison morphism for the product of `f`. -/
def pi_comparison [has_product f] [has_product (λ b, G.obj (f b))] :
  G.obj (∏ f) ⟶ ∏ (λ b, G.obj (f b)) :=
pi.lift (λ b, G.map (pi.π f b))

@[simp, reassoc]
lemma pi_comparison_comp_π [has_product f] [has_product (λ b, G.obj (f b))] (b : β) :
  pi_comparison G f ≫ pi.π _ b = G.map (pi.π f b) :=
limit.lift_π _ b

@[simp, reassoc]
lemma map_lift_pi_comparison [has_product f] [has_product (λ b, G.obj (f b))]
  (P : C) (g : Π j, P ⟶ f j) :
  G.map (pi.lift g) ≫ pi_comparison G f = pi.lift (λ j, G.map (g j)) :=
by { ext, simp [← G.map_comp] }

-- TODO: show this is an iso iff G preserves the coproduct of f.
/-- The comparison morphism for the coproduct of `f`. -/
def sigma_comparison [has_coproduct f] [has_coproduct (λ b, G.obj (f b))] :
  ∐ (λ b, G.obj (f b)) ⟶ G.obj (∐ f) :=
sigma.desc (λ b, G.map (sigma.ι f b))

@[simp, reassoc]
lemma ι_comp_sigma_comparison [has_coproduct f] [has_coproduct (λ b, G.obj (f b))] (b : β) :
  sigma.ι _ b ≫ sigma_comparison G f = G.map (sigma.ι f b) :=
colimit.ι_desc _ b

@[simp, reassoc]
lemma sigma_comparison_map_desc [has_coproduct f] [has_coproduct (λ b, G.obj (f b))]
  (P : C) (g : Π j, f j ⟶ P) :
  sigma_comparison G f ≫ G.map (sigma.desc g) = sigma.desc (λ j, G.map (g j)) :=
by { ext, simp [← G.map_comp] }

end comparison

variables (C)

/-- An abbreviation for `Π J, has_limits_of_shape (discrete J) C` -/
abbreviation has_products := Π (J : Type v), has_limits_of_shape (discrete J) C
/-- An abbreviation for `Π J, has_colimits_of_shape (discrete J) C` -/
abbreviation has_coproducts := Π (J : Type v), has_colimits_of_shape (discrete J) C

end category_theory.limits


/-
Copyright (c) 2021 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import data.sigma.basic
import order.rel_classes

/-!
# Lexicographic order on a sigma type

This defines the lexicographical order of two arbitrary relations on a sigma type and proves some
lemmas about `psigma.lex`, which is defined in core Lean.

Given a relation in the index type and a relation on each summand, the lexicographical order on the
sigma type relates `a` and `b` if their summands are related or they are in the same summand and
related by the summand's relation.

## See also

For the lexicographic order per say, see `data.sigma.order`.

The lexicographic order on lists can be found in `data.list.lex`.

The lexicographic order on a product type (which can be thought of as the special case of
`sigma.lex` where all summands are the same) and on `psigma` live in `order.lexicographic`.
-/

namespace sigma
variables {ι : Type*} {α : ι → Type*} {r r₁ r₂ : ι → ι → Prop} {s s₁ s₂ : Π i, α i → α i → Prop}
  {a b : Σ i, α i}

/-- The lexicographical order on a sigma type. It takes in a relation on the index type and a
relation for each summand. `a` is related to `b` iff their summands are related or they are in the
same summand and are related through the summand's relation. -/
inductive lex (r : ι → ι → Prop) (s : Π i, α i → α i → Prop) : Π a b : Σ i, α i, Prop
| left {i j : ι} (a : α i) (b : α j) : r i j → lex ⟨i, a⟩ ⟨j, b⟩
| right {i : ι} (a b : α i)          : s i a b → lex ⟨i, a⟩ ⟨i, b⟩

lemma lex_iff : lex r s a b ↔ r a.1 b.1 ∨ ∃ h : a.1 = b.1, s _ (h.rec a.2) b.2 :=
begin
  split,
  { rintro (⟨i, j, a, b, hij⟩ | ⟨i, a, b, hab⟩),
    { exact or.inl hij },
    { exact or.inr ⟨rfl, hab⟩ } },
  { obtain ⟨i, a⟩ := a,
    obtain ⟨j, b⟩ := b,
    dsimp only,
    rintro (h | ⟨rfl, h⟩),
    { exact lex.left _ _ h },
    { exact lex.right _ _ h } }
end

instance lex.decidable (r : ι → ι → Prop) (s : Π i, α i → α i → Prop) [decidable_eq ι]
  [decidable_rel r] [Π i, decidable_rel (s i)] :
  decidable_rel (lex r s) :=
λ a b, decidable_of_decidable_of_iff infer_instance lex_iff.symm

lemma lex.mono (hr : ∀ a b, r₁ a b → r₂ a b) (hs : ∀ i a b, s₁ i a b → s₂ i a b) {a b : Σ i, α i}
  (h : lex r₁ s₁ a b) :
  lex r₂ s₂ a b :=
begin
  obtain (⟨i, j, a, b, hij⟩ | ⟨i, a, b, hab⟩) := h,
  { exact lex.left _ _ (hr _ _ hij) },
  { exact lex.right _ _ (hs _ _ _ hab) }
end

lemma lex.mono_left (hr : ∀ a b, r₁ a b → r₂ a b) {a b : Σ i, α i} (h : lex r₁ s a b) :
  lex r₂ s a b :=
h.mono hr $ λ _ _ _, id

lemma lex.mono_right (hs : ∀ i a b, s₁ i a b → s₂ i a b) {a b : Σ i, α i} (h : lex r s₁ a b) :
  lex r s₂ a b :=
h.mono (λ _ _, id) hs

instance [Π i, is_refl (α i) (s i)] : is_refl _ (lex r s) := ⟨λ ⟨i, a⟩, lex.right _ _ $ refl _⟩

instance [is_irrefl ι r] [Π i, is_irrefl (α i) (s i)] : is_irrefl _ (lex r s) :=
⟨begin
  rintro _ (⟨i, j, a, b, hi⟩ | ⟨i, a, b, ha⟩),
  { exact irrefl _ hi },
  { exact irrefl _ ha }
end⟩

instance [is_trans ι r] [Π i, is_trans (α i) (s i)] : is_trans _ (lex r s) :=
⟨begin
  rintro _ _ _ (⟨i, j, a, b, hij⟩ | ⟨i, a, b, hab⟩) (⟨_, k, _, c, hk⟩ | ⟨_, _, c, hc⟩),
  { exact lex.left _ _ (trans hij hk) },
  { exact lex.left _ _ hij },
  { exact lex.left _ _ hk },
  { exact lex.right _ _ (trans hab hc) }
end⟩

instance [is_symm ι r] [Π i, is_symm (α i) (s i)] : is_symm _ (lex r s) :=
⟨begin
  rintro _ _ (⟨i, j, a, b, hij⟩ | ⟨i, a, b, hab⟩),
  { exact lex.left _ _ (symm hij) },
  { exact lex.right _ _ (symm hab) }
end⟩

local attribute [instance] is_asymm.is_irrefl

instance [is_asymm ι r] [Π i, is_antisymm (α i) (s i)] : is_antisymm _ (lex r s) :=
⟨begin
  rintro _ _ (⟨i, j, a, b, hij⟩ | ⟨i, a, b, hab⟩) (⟨_, _, _, _, hji⟩ | ⟨_, _, _, hba⟩),
  { exact (asymm hij hji).elim },
  { exact (irrefl _ hij).elim },
  { exact (irrefl _ hji).elim },
  { exact ext rfl (heq_of_eq $ antisymm hab hba) }
end⟩

instance [is_trichotomous ι r] [Π i, is_total (α i) (s i)] : is_total _ (lex r s) :=
⟨begin
  rintro ⟨i, a⟩ ⟨j, b⟩,
  obtain hij | rfl | hji := trichotomous_of r i j,
  { exact or.inl (lex.left _ _ hij) },
  { obtain hab | hba := total_of (s i) a b,
    { exact or.inl (lex.right _ _ hab) },
    { exact or.inr (lex.right _ _ hba) } },
  { exact or.inr (lex.left _ _ hji) }
end⟩

instance [is_trichotomous ι r] [Π i, is_trichotomous (α i) (s i)] : is_trichotomous _ (lex r s) :=
⟨begin
  rintro ⟨i, a⟩ ⟨j, b⟩,
  obtain hij | rfl | hji := trichotomous_of r i j,
  { exact or.inl (lex.left _ _ hij) },
  { obtain hab | rfl | hba := trichotomous_of (s i) a b,
    { exact or.inl (lex.right _ _ hab) },
    { exact or.inr (or.inl rfl) },
    { exact or.inr (or.inr $ lex.right _ _ hba) } },
  { exact or.inr (or.inr $ lex.left _ _ hji) }
end⟩

end sigma

/-! ### `psigma` -/

namespace psigma
variables {ι : Sort*} {α : ι → Sort*} {r r₁ r₂ : ι → ι → Prop} {s s₁ s₂ : Π i, α i → α i → Prop}

lemma lex_iff {a b : Σ' i, α i} : lex r s a b ↔ r a.1 b.1 ∨ ∃ h : a.1 = b.1, s _ (h.rec a.2) b.2 :=
begin
  split,
  { rintro (⟨i, j, a, b, hij⟩ | ⟨i, a, b, hab⟩),
    { exact or.inl hij },
    { exact or.inr ⟨rfl, hab⟩ } },
  { obtain ⟨i, a⟩ := a,
    obtain ⟨j, b⟩ := b,
    dsimp only,
    rintro (h | ⟨rfl, h⟩),
    { exact lex.left _ _ h },
    { exact lex.right _ h } }
end

instance lex.decidable (r : ι → ι → Prop) (s : Π i, α i → α i → Prop) [decidable_eq ι]
  [decidable_rel r] [Π i, decidable_rel (s i)] :
  decidable_rel (lex r s) :=
λ a b, decidable_of_decidable_of_iff infer_instance lex_iff.symm

lemma lex.mono {r₁ r₂ : ι → ι → Prop} {s₁ s₂ : Π i, α i → α i → Prop}
  (hr : ∀ a b, r₁ a b → r₂ a b) (hs : ∀ i a b, s₁ i a b → s₂ i a b) {a b : Σ' i, α i}
  (h : lex r₁ s₁ a b) :
  lex r₂ s₂ a b :=
begin
  obtain (⟨i, j, a, b, hij⟩ | ⟨i, a, b, hab⟩) := h,
  { exact lex.left _ _ (hr _ _ hij) },
  { exact lex.right _ (hs _ _ _ hab) }
end

lemma lex.mono_left {r₁ r₂ : ι → ι → Prop} {s : Π i, α i → α i → Prop}
  (hr : ∀ a b, r₁ a b → r₂ a b) {a b : Σ' i, α i} (h : lex r₁ s a b) :
  lex r₂ s a b :=
h.mono hr $ λ _ _ _, id

lemma lex.mono_right {r : ι → ι → Prop} {s₁ s₂ : Π i, α i → α i → Prop}
  (hs : ∀ i a b, s₁ i a b → s₂ i a b) {a b : Σ' i, α i} (h : lex r s₁ a b) :
  lex r s₂ a b :=
h.mono (λ _ _, id) hs

end psigma


import data.list.func
import .helpers
import .boolset2d

def component1d : bset1d → bset1d → bset1d
| [] _ := []
| (ha::ta) ini := let hi := ini.head, ti := ini.tail in
  let hha := ti.head in
  let tcomp := component1d ta ((hha||(hi&&ha))::ti.tail) in
  (ha && (hi || tcomp.head))::tcomp

inductive in_component1d (avail ini : bset1d) : ℕ → Prop
| triv (n : ℕ) (Ha : n ∈ avail) (Hi : n ∈ ini)
  : in_component1d n
| move_fw (n : ℕ) (Ha : n ∈ avail) (Hc : in_component1d n.succ)
  : in_component1d n
| move_bw (n : ℕ) (Ha : n ∈ avail) (Hc : in_component1d n.pred)
  : in_component1d n

theorem component1d_ini_split : ∀ (avail ini : bset1d),
  component1d avail (ini.head::ini.tail) = component1d avail ini :=
begin
  intros, cases avail, simp! [component1d],
  simp! [component1d, list.head],
end
theorem component1d_avail_cons_ff : ∀ (avail ini : bset1d),
  component1d (ff::avail) ini = ff::(component1d avail (ini.tail)) :=
begin
  intros, unfold component1d, simp [component1d_ini_split],
end

theorem in_component1d_of_in_cons : ∀ (b : bool) (avail ini : bset1d) (n : ℕ),
  (in_component1d avail (ini.tail) n) → in_component1d (b::avail) ini n.succ :=
begin
  introv H, induction H with n Ha Hi n Ha Hc IH n Ha Hc IH,
  { apply in_component1d.triv,
    all_goals { unfold has_mem.mem at *, rw get_succ, assumption } },
  { apply in_component1d.move_fw,
    all_goals { assumption <|> exact IH }, },
  { cases n, exact IH,
    apply in_component1d.move_bw,
    all_goals { assumption <|> exact IH },
  },
end

theorem in_component1d_trans (avail ini ini2 : bset1d) :
  (∀ n, n ∈ avail → n ∈ ini2
    → in_component1d avail ini n) →
  ∀ n, in_component1d avail ini2 n → in_component1d avail ini n :=
begin
  intros H1 n H2, induction H2 with n Ha Hi n Ha Hc IH n Ha Hc IH,
  exact H1 n Ha Hi,
  exact in_component1d.move_fw _ Ha IH,
  exact in_component1d.move_bw _ Ha IH,
end

theorem component1d_valid : ∀ (avail ini : bset1d) (n : ℕ),
  n ∈ (component1d avail ini) → in_component1d avail ini n :=
begin
  intro avail, induction avail, {
    introv H, unfold component1d at H,
    simp [has_mem.mem] at H, contradiction,
  }, {
    introv H, cases avail_hd, {
      cases n,
      simp at H, contradiction,
      apply in_component1d_of_in_cons,
      simp [component1d_avail_cons_ff] at H,
      exact avail_ih _ _ H,
    }, {
      rw ←component1d_ini_split at H, unfold component1d at H,
      simp [list.head, list.tail] at H,
      cases Eh : list.head ini, {
        simp [Eh, component1d_ini_split] at H,
        cases Ech : (component1d avail_tl ini.tail).head,
        { rw [Ech] at H,
          cases n, simp at H, contradiction,
          simp [has_mem.mem] at H,
          apply in_component1d_of_in_cons,
          exact avail_ih _ n H,
        }, {
          rw [Ech] at H,
          cases n, {
            apply in_component1d.move_fw, simp [has_mem.mem],
            apply in_component1d_of_in_cons,
            apply avail_ih, simp [has_mem.mem, get_0_head], exact Ech,
          }, {
            apply in_component1d_of_in_cons,
            apply avail_ih, exact H,
          }
        }
      }, {
        rw Eh at H, simp at H,
        cases n, {
          apply in_component1d.triv, simp! [has_mem.mem],
          unfold has_mem.mem, rw get_0_head, exact Eh,
        }, {
          simp [has_mem.mem] at H, specialize avail_ih _ _ H,
          apply in_component1d_trans _ _ (tt::tt:: ini.tail.tail), {
            clear avail_ih H n, intros n H1 H2,
            cases n, { apply in_component1d.triv _ H1,
              unfold has_mem.mem, rw get_0_head, exact Eh, },
            cases n, {
              apply in_component1d.move_bw _ H1,
              apply in_component1d.triv,
              simp! [has_mem.mem],
              simp! [has_mem.mem, Eh, get_0_head],
            }, {
              apply in_component1d.triv,
              { simp [has_mem.mem, get_succ], simp [has_mem.mem, get_succ] at H1, exact H1, },
              { simp [has_mem.mem, get_succ], exact H2, },
            }
          },
          exact in_component1d_of_in_cons _ _ _ _ avail_ih,
        }
      }
    }
  },
end

theorem component1d_subset_avail : ∀ (avail ini : bset1d) (n : ℕ),
  list.func.get n (component1d avail ini) = tt → list.func.get n avail = tt :=
begin
  intro avail, induction avail,
  { intros ini n H, simp [component1d] at H, contradiction, },
  intros ini n H, cases n, {
    simp [component1d] at H, cases H with H1 H2,
    simp, exact H1,
  }, {
    simp, simp [component1d] at H, exact avail_ih _ _ H,
  }
end
theorem component1d_supset : ∀ (avail ini : bset1d) (n : ℕ),
  list.func.get n avail = tt → list.func.get n ini = tt
  → list.func.get n (component1d avail ini) = tt :=
begin
  intro avail, induction avail,
  { introv H1 H2, intros, simp at H1, contradiction, },
  introv H1 H2,
  cases n, {
    simp at H1, rw H1, clear H1,
    simp [get_0_head] at H2,
    simp [component1d], left, exact H2,
  }, {
    simp at H1,
    simp [get_succ] at H2,
    simp [component1d], apply avail_ih, {
      exact H1,
    }, {
      cases n, simp, left,
      simp [get_0_head] at H2, exact H2,
      simp [get_succ] at H2, simp, exact H2,
    }
  }
end
theorem component1d_succ_eq : ∀ (avail ini : bset1d) (n : ℕ),
  list.func.get n avail = tt → list.func.get n.succ avail = tt →
  list.func.get n.succ (component1d avail ini) =
  list.func.get n (component1d avail ini) :=
begin
  intro avail, induction avail, {
    introv H1 H2, simp at H1, contradiction,
  }, {
    introv H1 H2, cases n, {
      simp at H1, simp [get_0_head] at H2,
      rewrite H1, clear H1, simp,
      unfold component1d,
      cases ini.head, simp,
      apply get_0_head,
      simp, cases avail_tl, { simp at H2, contradiction, },
      simp at H2, rewrite H2, unfold component1d, simp,
    },
    unfold component1d, exact avail_ih _ _ H1 H2,
  }
end

theorem component1d_complete : ∀ (avail ini : bset1d) (n : ℕ),
  in_component1d avail ini n → list.func.get n (component1d avail ini) = tt :=
begin
  introv H, induction H with n Ha Hi n Ha Hc IH n Ha Hc IH,
  { apply component1d_supset, exact Ha, exact Hi, },
  { rw ←component1d_succ_eq, exact IH, exact Ha,
    exact component1d_subset_avail avail ini n.succ IH, },
  { cases n with n, exact IH, simp at IH,
    rw component1d_succ_eq, exact IH,
    exact component1d_subset_avail avail ini n IH,
    exact Ha, },
end


/-
# References

1. Enderton, Herbert B. A Mathematical Introduction to Logic. 2nd ed. San Diego:
   Harcourt/Academic Press, 2001.
-/

import Mathlib.Tactic.NormCast
import Mathlib.Tactic.Ring

/--
As described in [1], `n`-tuples are defined recursively as such:

  `⟨x₁, ..., xₙ⟩ = ⟨⟨x₁, ..., xₙ₋₁⟩, xₙ⟩`

We allow for empty tuples; [2] expects this functionality.

For a `Tuple`-like type with opposite "endian", refer to `Vector`.
-/
inductive Tuple : (α : Type u) → (size : Nat) → Type u where
  | nil : Tuple α 0
  | snoc : Tuple α n → α → Tuple α (n + 1)

syntax (priority := high) "t[" term,* "]" : term

macro_rules
  | `(t[]) => `(Tuple.nil)
  | `(t[$x]) => `(Tuple.snoc t[] $x)
  | `(t[$xs:term,*, $x]) => `(Tuple.snoc t[$xs,*] $x)

namespace Tuple

/- -------------------------------------
 - Coercions
 - -------------------------------------/

scoped instance : CoeOut (Tuple α (min (m + n) m)) (Tuple α m) where
  coe := cast (by simp)

scoped instance : Coe (Tuple α 0) (Tuple α (min n 0)) where
  coe := cast (by rw [Nat.min_zero])

scoped instance : Coe (Tuple α 0) (Tuple α (min 0 n)) where
  coe := cast (by rw [Nat.zero_min])

scoped instance : Coe (Tuple α n) (Tuple α (min n n)) where
  coe := cast (by simp)

scoped instance : Coe (Tuple α n) (Tuple α (0 + n)) where
  coe := cast (by simp)

scoped instance : Coe (Tuple α (min m n + 1)) (Tuple α (min (m + 1) (n + 1))) where
  coe := cast (by rw [Nat.min_succ_succ])

scoped instance : Coe (Tuple α m) (Tuple α (min (m + n) m)) where
  coe := cast (by simp)

/- -------------------------------------
 - Equality
 - -------------------------------------/

theorem eq_nil : @Tuple.nil α = t[] := rfl

theorem eq_iff_singleton : (a = b) ↔ (t[a] = t[b]) := by
  apply Iff.intro
  · intro h; rw [h]
  · intro h; injection h

theorem eq_iff_snoc {t₁ t₂ : Tuple α n}
  : (a = b ∧ t₁ = t₂) ↔ (snoc t₁ a = snoc t₂ b) := by
  apply Iff.intro
  · intro ⟨h₁, h₂ ⟩; rw [h₁, h₂]
  · intro h
    injection h with _ h₁ h₂
    exact And.intro h₂ h₁

/--
Implements decidable equality for `Tuple α m`, provided `a` has decidable equality.
-/
protected def hasDecEq [DecidableEq α] (t₁ t₂ : Tuple α n) : Decidable (Eq t₁ t₂) :=
  match t₁, t₂ with
  | t[], t[] => isTrue eq_nil
  | snoc as a, snoc bs b =>
    match Tuple.hasDecEq as bs with
    | isFalse np => isFalse (fun h => absurd (eq_iff_snoc.mpr h).right np)
    | isTrue hp =>
      if hq : a = b then
        isTrue (eq_iff_snoc.mp $ And.intro hq hp)
      else
        isFalse (fun h => absurd (eq_iff_snoc.mpr h).left hq)

instance [DecidableEq α] : DecidableEq (Tuple α n) := Tuple.hasDecEq

/- -------------------------------------
 - Basic API
 - -------------------------------------/

/--
Returns the number of entries of the `Tuple`.
-/
def size (_ : Tuple α n) : Nat := n

/--
Returns all but the last entry of the `Tuple`.
-/
def init : (t : Tuple α (n + 1)) → Tuple α n
  | snoc vs _ => vs

/--
Returns the last entry of the `Tuple`.
-/
def last : Tuple α (n + 1) → α
  | snoc _ v => v

/--
Prepends an entry to the start of the `Tuple`.
-/
def cons : Tuple α n → α → Tuple α (n + 1)
  | t[], a => t[a]
  | snoc ts t, a => snoc (cons ts a) t

/- -------------------------------------
 - Concatenation
 - -------------------------------------/

/--
Join two `Tuple`s together end to end.
-/
def concat : Tuple α m → Tuple α n → Tuple α (m + n)
  | is, t[] => is
  | is, snoc ts t => snoc (concat is ts) t

/--
Concatenating a `Tuple` with `nil` yields the original `Tuple`.
-/
theorem self_concat_nil_eq_self (t : Tuple α m) : concat t t[] = t :=
  match t with
  | t[] => rfl
  | snoc _ _ => rfl

/--
Concatenating `nil` with a `Tuple` yields the `Tuple`.
-/
theorem nil_concat_self_eq_self (t : Tuple α m) : concat t[] t = t :=
  Tuple.recOn
    t
    (by unfold concat; simp)
    (@fun n as a ih => by
      unfold concat
      rw [ih]
      suffices HEq (snoc (cast (_ : Tuple α n = Tuple α (0 + n)) as) a) ↑(snoc as a)
        from eq_of_heq this
      have h₁ := Eq.recOn
        (motive := fun x h => HEq
          (snoc (cast (show Tuple α n = Tuple α x by rw [h]) as) a)
          (snoc as a))
        (show n = 0 + n by simp)
        HEq.rfl
      exact Eq.recOn
        (motive := fun x h => HEq
          (snoc (cast (_ : Tuple α n = Tuple α (0 + n)) as) a)
          (cast h (snoc as a)))
        (show Tuple α (n + 1) = Tuple α (0 + (n + 1)) by simp)
        h₁)

/--
Concatenating a `Tuple` to a nonempty `Tuple` moves `concat` calls closer to
expression leaves.
-/
theorem concat_snoc_snoc_concat {bs : Tuple α n}
  : concat as (snoc bs b) = snoc (concat as bs) b :=
  rfl

/--
`snoc` is equivalent to concatenating the `init` and `last` element together.
-/
theorem snoc_eq_init_concat_last (as : Tuple α m) : snoc as a = concat as t[a] :=
  Tuple.casesOn (motive := fun _ t => snoc t a = concat t t[a])
    as
    rfl
    (fun _ _ => by simp; unfold concat concat; rfl)

/- -------------------------------------
 - Initial sequences
 - -------------------------------------/

/--
Take the first `k` entries from the `Tuple` to form a new `Tuple`, or the entire
`Tuple` if `k` exceeds the number of entries.
-/
def take (t : Tuple α n) (k : Nat) : Tuple α (min n k) :=
  if h : n ≤ k then
    cast (by rw [min_eq_left h]) t
  else
    match t with
    | t[] => t[]
    | @snoc _ n' as a => cast (by rw [min_lt_succ_eq h]) (take as k)
 where
  min_lt_succ_eq {m : Nat} (h : ¬m + 1 ≤ k) : min m k = min (m + 1) k := by
    have h' : k + 1 ≤ m + 1 := Nat.lt_of_not_le h
    simp at h'
    rw [min_eq_right h', min_eq_right (Nat.le_trans h' (Nat.le_succ m))]

/--
Taking no entries from any `Tuple` should yield an empty one.
-/
theorem self_take_zero_eq_nil (t : Tuple α n) : take t 0 = @nil α :=
  Tuple.recOn (motive := fun _ t => take t 0 = @nil α) t
    (by simp; rfl)
    (fun as a ih => by unfold take; simp; rw [ih]; simp)

/--
Taking any number of entries from an empty `Tuple` should yield an empty one.
-/
theorem nil_take_zero_eq_nil (k : Nat) : (take (@nil α) k) = @nil α := by
  cases k <;> (unfold take; simp)

/--
Taking `n` entries from a `Tuple` of size `n` should yield the same `Tuple`.
-/
theorem self_take_size_eq_self (t : Tuple α n) : take t n = t :=
  Tuple.casesOn (motive := fun x t => take t x = t) t
    (by simp; rfl)
    (fun as a => by unfold take; simp)

/--
Taking all but the last entry of a `Tuple` is the same result, regardless of the
value of the last entry.
-/
theorem take_subst_last {as : Tuple α n} (a₁ a₂ : α)
  : take (snoc as a₁) n = take (snoc as a₂) n := by
  unfold take
  simp

/--
Taking `n` elements from a tuple of size `n + 1` is the same as invoking `init`.
-/
theorem init_eq_take_pred (t : Tuple α (n + 1)) : take t n = init t :=
  match t with
  | snoc as a => by unfold init take; simp; rw [self_take_size_eq_self]; simp

/--
If two `Tuple`s are equal, then any initial sequences of those two `Tuple`s are
also equal.
-/
theorem eq_tuple_eq_take {t₁ t₂ : Tuple α n}
  : (t₁ = t₂) → (t₁.take k = t₂.take k) :=
  fun h => by rw [h]

/--
Given a `Tuple` of size `k`, concatenating an arbitrary `Tuple` and taking `k`
elements yields the original `Tuple`.
-/
theorem eq_take_concat {t₁ : Tuple α m} {t₂ : Tuple α n}
  : take (concat t₁ t₂) m = t₁ :=
  Tuple.recOn
    (motive := fun x t => take (concat t₁ t) m = t₁) t₂
    (by simp; rw [self_concat_nil_eq_self, self_take_size_eq_self])
    (@fun n' as a ih => by
      simp
      rw [concat_snoc_snoc_concat]
      unfold take
      simp
      rw [ih]
      simp)

end Tuple


import Mathlib.Data.Nat.Basic
import Mathlib.Init.Algebra.Order
import Mathlib.Init.Data.Nat.Basic
import Mathlib.Init.Data.Int.Order
import Mathlib.Init.Data.Nat.Lemmas
import Mathlib.Data.String.Defs
import Mathlib.Data.String.Lemmas
import Mathlib.Algebra.Group.Defs
import Mathlib.Algebra.Ring.Basic
import Mathlib.Data.Equiv.Basic

/- The number of nanoseconds in one second -/
abbrev oneSecondNanos : Nat := 1000000000

/-- The number of nanoseconds in one minute -/
abbrev oneMinuteNanos : Nat := 60000000000

/-- The number of nanoseconds in one hour -/
abbrev oneHourNanos : Nat := 3600000000000

/-- The number of nanoseconds in one day -/
abbrev oneDayNanos : Nat := 86400000000000

/-- The number of nanoseconds in one 7-day week -/
abbrev oneWeekNanos : Nat := 604800000000000

/-- The number of nanoseconds in one 365-day year -/
abbrev oneYearNanos : Nat := 31536000000000000

structure SignedDuration where
  val : Int
deriving DecidableEq, Ord, Repr

def SignedDuration.isNeg (d : SignedDuration) : Bool := d.val < 0
def SignedDuration.isNonNeg (d : SignedDuration) : Bool := ¬d.isNeg
def SignedDuration.abs (d : SignedDuration) : SignedDuration := SignedDuration.mk (d.val.natAbs)

instance : Neg SignedDuration where
  neg d := ⟨-d.val⟩

theorem SignedDuration.neg_def (d : SignedDuration) : -d = ⟨-d.val⟩ := by rfl

instance : Add SignedDuration where
  add a b := ⟨a.val + b.val⟩

theorem SignedDuration.add_def (a b : SignedDuration) : a + b = ⟨a.val + b.val⟩ := rfl

instance : Sub SignedDuration where
  sub a b := ⟨a.val - b.val⟩

theorem SignedDuration.sub_def (a b : SignedDuration) : a - b = ⟨a.val - b.val⟩ := rfl

instance : HMul SignedDuration Nat SignedDuration where
  hMul d n := ⟨d.val * n⟩

instance : HMod SignedDuration Int SignedDuration where
  hMod a n := ⟨a.val % n⟩

instance : HDiv SignedDuration Nat SignedDuration where
  hDiv a b := ⟨a.val / b⟩

instance : HPow SignedDuration Nat SignedDuration where
  hPow a b := ⟨a.val ^ b⟩

instance : LT SignedDuration where
  lt := InvImage Int.lt SignedDuration.val

instance : LE SignedDuration where
  le := InvImage Int.le SignedDuration.val

theorem SignedDuration.le_def {d₁ d₂ : SignedDuration} : (d₁ <= d₂) = (d₁.val <= d₂.val) := rfl
theorem SignedDuration.lt_def {d₁ d₂ : SignedDuration} : (d₁ < d₂) = (d₁.val < d₂.val) := rfl

theorem SignedDuration.val_eq_of_eq : ∀ {d1 d2 : SignedDuration} (h : d1 = d2), d1.val = d2.val
| ⟨_⟩, _, rfl => rfl

theorem SignedDuration.eq_of_val_eq : ∀ {d1 d2 : SignedDuration} (h : d1.val = d2.val), d1 = d2
| ⟨_⟩, _, rfl => rfl

instance (a b : SignedDuration) : Decidable (a < b) := inferInstanceAs (Decidable (a.val < b.val))
instance (a b : SignedDuration) : Decidable (a <= b) := inferInstanceAs (Decidable (a.val <= b.val))

instance : LinearOrder SignedDuration where
  le_refl (a) := le_refl a.val
  le_trans (a b c) := Int.le_trans
  lt_iff_le_not_le (a b) := Int.lt_iff_le_not_le
  le_antisymm (a b h1 h2) := by
    apply SignedDuration.eq_of_val_eq
    rw [SignedDuration.le_def] at h2 h1
    exact le_antisymm h1 h2
  le_total := by simp [SignedDuration.le_def, le_total]
  decidable_le := inferInstance

theorem SignedDuration.monotone {d₁ d₂ : SignedDuration} : d₁.val <= d₂.val -> d₁ <= d₂ :=
  fun h => (SignedDuration.le_def) ▸ h

@[reducible] def SignedDuration.toNanos (d : SignedDuration) : Int := d.val
@[reducible] def SignedDuration.toSeconds (d : SignedDuration) : Int := d.val / oneSecondNanos
@[reducible] def SignedDuration.toMinutes (d : SignedDuration) : Int := d.val / oneMinuteNanos
@[reducible] def SignedDuration.toHours (d : SignedDuration) : Int := d.val / oneHourNanos
@[reducible] def SignedDuration.toDays (d : SignedDuration) : Int := d.val / oneDayNanos
@[reducible] def SignedDuration.toWeeks (d : SignedDuration) : Int := d.val / oneWeekNanos
@[reducible] def SignedDuration.toNonLeapYears (d : SignedDuration) : Int := d.val / (365 * oneDayNanos)

@[reducible] def SignedDuration.fromNanos (n : Int) : SignedDuration := ⟨n⟩
@[reducible] def SignedDuration.fromSeconds (n : Int) : SignedDuration := ⟨n * oneSecondNanos⟩
@[reducible] def SignedDuration.fromMinutes (n : Int) : SignedDuration := ⟨n * oneMinuteNanos⟩
@[reducible] def SignedDuration.fromHours (n : Int) : SignedDuration := ⟨n * oneHourNanos⟩
@[reducible] def SignedDuration.fromWeeks (n : Int) : SignedDuration := ⟨n * oneWeekNanos⟩
@[reducible] def SignedDuration.fromDays (n : Int) : SignedDuration := ⟨n * oneDayNanos⟩
@[reducible] def SignedDuration.fromNonLeapYears (n : Int) : SignedDuration := ⟨n * oneYearNanos⟩

instance (n : Nat) : OfNat SignedDuration n where
  ofNat := ⟨n⟩

@[simp] theorem SignedDuration.zero_def : (0 : SignedDuration).val = (0 : Int) := by rfl

instance : ToString SignedDuration where
  toString d :=
    let pfx := if d.isNonNeg then "" else "-"
    let d := d.abs
    let secs := String.leftpad 2 '0' s!"{d.toSeconds}"
    let nanos := String.leftpad 9 '0' s!"{d.toNanos % Int.ofNat oneSecondNanos}"
    s!"{pfx}P{secs}.{nanos}S"

instance : AddCommSemigroup SignedDuration := {
  add_assoc := fun a b c => by simp [SignedDuration.add_def, AddSemigroup.add_assoc]
  add_comm := fun a b => by simp [SignedDuration.add_def]; exact AddCommSemigroup.add_comm (A := Int) _ _
}

instance : IsAddLeftCancel SignedDuration where
  add_left_cancel := fun a b c h0 => by
    have h2 := SignedDuration.val_eq_of_eq h0
    simp only [SignedDuration.val] at h2
    exact SignedDuration.eq_of_val_eq (@Int.add_left_cancel a.val b.val c.val (h2))

instance : IsAddRightCancel SignedDuration where
  add_right_cancel := fun a b c => by
    have h0 := @add_right_cancel Int _ _ a.val b.val c.val
    intro h1
    have h2 := SignedDuration.val_eq_of_eq h1
    simp only [SignedDuration.add_def, SignedDuration.val] at h2
    specialize h0 h2
    exact SignedDuration.eq_of_val_eq h0

instance : AddCommMonoid SignedDuration where
  add_zero := by simp [SignedDuration.eq_of_val_eq, SignedDuration.add_def, add_zero]
  zero_add := by simp [SignedDuration.eq_of_val_eq, SignedDuration.add_def, zero_add]
  nsmul_zero' := by simp [nsmul_rec]
  nsmul_succ' := by simp [nsmul_rec]
  add_comm := by simp [SignedDuration.eq_of_val_eq, SignedDuration.add_def, add_comm]

instance : Equiv Int SignedDuration where
  toFun := SignedDuration.mk
  invFun := SignedDuration.val
  left_inv := by simp [Function.LeftInverse]
  right_inv := by simp [Function.RightInverse, Function.LeftInverse]

instance : AddMonoidWithOne SignedDuration where
  __ := inferInstanceAs (AddCommMonoid SignedDuration)
  natCast n := SignedDuration.mk (Int.ofNat n)
  natCast_zero := rfl
  natCast_succ _ := rfl

private theorem SignedDuration.sub_eq_add_neg (a b : SignedDuration) : a - b = a + -b := by
  simp [
    SignedDuration.sub_def, SignedDuration.add_def, SignedDuration.neg_def,
    HSub.hSub, Sub.sub, Int.sub
  ]

private theorem SignedDuration.add_left_neg (a : SignedDuration) : -a + a = 0 := by
  apply SignedDuration.eq_of_val_eq
  simp [SignedDuration.sub_def, SignedDuration.add_def, SignedDuration.neg_def]

instance : AddGroupWithOne SignedDuration where
  __ := inferInstanceAs (AddMonoidWithOne (SignedDuration))
  gsmul_zero' := by simp [gsmul_rec, nsmul_rec]
  gsmul_succ' := by simp [gsmul_rec, nsmul_rec, -Int.ofNat_eq_cast]
  gsmul_neg' := by simp [gsmul_rec, nsmul_rec, -Int.ofNat_eq_cast]
  sub_eq_add_neg := SignedDuration.sub_eq_add_neg
  add_left_neg := SignedDuration.add_left_neg
  intCast := SignedDuration.mk
  intCast_ofNat _ := rfl
  intCast_negSucc _ := rfl