/-
Copyright (c) 2022 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz
-/
import ring_theory.valuation.integers
import ring_theory.ideal.local_ring
import ring_theory.localization.fraction_ring
import ring_theory.discrete_valuation_ring
import tactic.field_simp

/-!
# Valuation Rings

A valuation ring is a domain such that for every pair of elements `a b`, either `a` divides
`b` or vice-versa.

Any valuation ring induces a natural valuation on its fraction field, as we show in this file.
Namely, given the following instances:
`[comm_ring A] [is_domain A] [valuation_ring A] [field K] [algebra A K] [is_fraction_ring A K]`,
there is a natural valuation `valuation A K` on `K` with values in `value_group A K` where
the image of `A` under `algebra_map A K` agrees with `(valuation A K).integer`.

We also show that valuation rings are local and that their lattice of ideals is totally ordered.
-/

universes u v w

/-- An integral domain is called a `valuation ring` provided that for any pair
of elements `a b : A`, either `a` divides `b` or vice versa. -/
class valuation_ring (A : Type u) [comm_ring A] [is_domain A] : Prop :=
(cond [] : ∀ a b : A, ∃ c : A, a * c = b ∨ b * c = a)

namespace valuation_ring

section
variables (A : Type u) [comm_ring A]
variables (K : Type v) [field K] [algebra A K]

/-- The value group of the valuation ring `A`. -/
def value_group : Type v := quotient (mul_action.orbit_rel Aˣ K)

instance : inhabited (value_group A K) := ⟨quotient.mk' 0⟩

instance : has_le (value_group A K) := has_le.mk $ λ x y,
quotient.lift_on₂' x y (λ a b, ∃ c : A, c • b = a)
begin
  rintros _ _ a b ⟨c,rfl⟩ ⟨d,rfl⟩, ext,
  split,
  { rintros ⟨e,he⟩, use ((c⁻¹ : Aˣ) * e * d),
    apply_fun (λ t, c⁻¹ • t) at he,
    simpa [mul_smul] using he },
  { rintros ⟨e,he⟩, dsimp,
    use (d⁻¹ : Aˣ) * c * e,
    erw [← he, ← mul_smul, ← mul_smul],
    congr' 1,
    rw mul_comm,
    simp only [← mul_assoc, ← units.coe_mul, mul_inv_self, one_mul] }
end

instance : has_zero (value_group A K) := ⟨quotient.mk' 0⟩
instance : has_one (value_group A K) := ⟨quotient.mk' 1⟩

instance : has_mul (value_group A K) := has_mul.mk $ λ x y,
quotient.lift_on₂' x y (λ a b, quotient.mk' $ a * b)
begin
  rintros _ _ a b ⟨c,rfl⟩ ⟨d,rfl⟩,
  apply quotient.sound',
  dsimp,
  use c * d,
  simp only [mul_smul, algebra.smul_def, units.smul_def, ring_hom.map_mul,
    units.coe_mul],
  ring,
end

instance : has_inv (value_group A K) := has_inv.mk $ λ x,
quotient.lift_on' x (λ a, quotient.mk' a⁻¹)
begin
  rintros _ a ⟨b,rfl⟩,
  apply quotient.sound',
  use b⁻¹,
  dsimp,
  rw [units.smul_def, units.smul_def, algebra.smul_def, algebra.smul_def,
    mul_inv, ring_hom.map_units_inv],
end

variables [is_domain A] [valuation_ring A] [is_fraction_ring A K]

protected lemma le_total (a b : value_group A K) : a ≤ b ∨ b ≤ a :=
begin
  rcases a with ⟨a⟩, rcases b with ⟨b⟩,
  obtain ⟨xa,ya,hya,rfl⟩ : ∃ (a b : A), _ := is_fraction_ring.div_surjective a,
  obtain ⟨xb,yb,hyb,rfl⟩ : ∃ (a b : A), _ := is_fraction_ring.div_surjective b,
  have : (algebra_map A K) ya ≠ 0 :=
    is_fraction_ring.to_map_ne_zero_of_mem_non_zero_divisors hya,
  have : (algebra_map A K) yb ≠ 0 :=
    is_fraction_ring.to_map_ne_zero_of_mem_non_zero_divisors hyb,
  obtain ⟨c,(h|h)⟩ := valuation_ring.cond (xa * yb) (xb * ya),
  { right,
    use c,
    rw algebra.smul_def,
    field_simp,
    simp only [← ring_hom.map_mul, ← h], congr' 1, ring },
  { left,
    use c,
    rw algebra.smul_def,
    field_simp,
    simp only [← ring_hom.map_mul, ← h], congr' 1, ring }
end

noncomputable
instance : linear_ordered_comm_group_with_zero (value_group A K) :=
{ le_refl := by { rintro ⟨⟩, use 1, rw one_smul },
  le_trans := by { rintros ⟨a⟩ ⟨b⟩ ⟨c⟩ ⟨e,rfl⟩ ⟨f,rfl⟩, use (e * f), rw mul_smul },
  le_antisymm := begin
    rintros ⟨a⟩ ⟨b⟩ ⟨e,rfl⟩ ⟨f,hf⟩,
    by_cases hb : b = 0, { simp [hb] },
    have : is_unit e,
    { apply is_unit_of_dvd_one,
      use f, rw mul_comm,
      rw [← mul_smul, algebra.smul_def] at hf,
      nth_rewrite 1 ← one_mul b at hf,
      rw ← (algebra_map A K).map_one at hf,
      exact is_fraction_ring.injective _ _
        (cancel_comm_monoid_with_zero.mul_right_cancel_of_ne_zero hb hf).symm },
    apply quotient.sound',
    use [this.unit, rfl],
  end,
  le_total := valuation_ring.le_total _ _,
  decidable_le := by { classical, apply_instance },
  mul_assoc := by { rintros ⟨a⟩ ⟨b⟩ ⟨c⟩, apply quotient.sound', rw mul_assoc, apply setoid.refl' },
  one_mul := by { rintros ⟨a⟩, apply quotient.sound', rw one_mul, apply setoid.refl' },
  mul_one := by { rintros ⟨a⟩, apply quotient.sound', rw mul_one, apply setoid.refl' },
  mul_comm := by { rintros ⟨a⟩ ⟨b⟩, apply quotient.sound', rw mul_comm, apply setoid.refl' },
  mul_le_mul_left := begin
    rintros ⟨a⟩ ⟨b⟩ ⟨c,rfl⟩ ⟨d⟩,
    use c, simp only [algebra.smul_def], ring,
  end,
  zero_mul := by { rintros ⟨a⟩, apply quotient.sound', rw zero_mul, apply setoid.refl' },
  mul_zero := by { rintros ⟨a⟩, apply quotient.sound', rw mul_zero, apply setoid.refl' },
  zero_le_one := ⟨0, by rw zero_smul⟩,
  exists_pair_ne := begin
    use [0,1],
    intro c, obtain ⟨d,hd⟩ := quotient.exact' c,
    apply_fun (λ t, d⁻¹ • t) at hd,
    simpa using hd,
  end,
  inv_zero := by { apply quotient.sound', rw inv_zero, apply setoid.refl' },
  mul_inv_cancel := begin
    rintros ⟨a⟩ ha,
    apply quotient.sound',
    use 1,
    simp only [one_smul],
    apply (mul_inv_cancel _).symm,
    contrapose ha,
    simp only [not_not] at ha ⊢,
    rw ha, refl,
  end,
  ..(infer_instance : has_le (value_group A K)),
  ..(infer_instance : has_mul (value_group A K)),
  ..(infer_instance : has_inv (value_group A K)),
  ..(infer_instance : has_zero (value_group A K)),
  ..(infer_instance : has_one (value_group A K)) }

/-- Any valuation ring induces a valuation on its fraction field. -/
def valuation : valuation K (value_group A K) :=
{ to_fun := quotient.mk',
  map_zero' := rfl,
  map_one' := rfl,
  map_mul' := λ _ _, rfl,
  map_add_le_max' := begin
    intros a b,
    obtain ⟨xa,ya,hya,rfl⟩ : ∃ (a b : A), _ := is_fraction_ring.div_surjective a,
    obtain ⟨xb,yb,hyb,rfl⟩ : ∃ (a b : A), _ := is_fraction_ring.div_surjective b,
    have : (algebra_map A K) ya ≠ 0 :=
      is_fraction_ring.to_map_ne_zero_of_mem_non_zero_divisors hya,
    have : (algebra_map A K) yb ≠ 0 :=
      is_fraction_ring.to_map_ne_zero_of_mem_non_zero_divisors hyb,
    obtain ⟨c,(h|h)⟩ := valuation_ring.cond (xa * yb) (xb * ya),
    dsimp,
    { apply le_trans _ (le_max_left _ _),
      use (c + 1),
      rw algebra.smul_def,
      field_simp,
      simp only [← ring_hom.map_mul, ← ring_hom.map_add, ← (algebra_map A K).map_one, ← h],
      congr' 1, ring },
    { apply le_trans _ (le_max_right _ _),
      use (c + 1),
      rw algebra.smul_def,
      field_simp,
      simp only [← ring_hom.map_mul, ← ring_hom.map_add, ← (algebra_map A K).map_one, ← h],
      congr' 1, ring }
  end }

lemma mem_integer_iff (x : K) : x ∈ (valuation A K).integer ↔ ∃ a : A, algebra_map A K a = x :=
begin
  split,
  { rintros ⟨c,rfl⟩,
    use c,
    rw [algebra.smul_def, mul_one] },
  { rintro ⟨c,rfl⟩,
    use c,
    rw [algebra.smul_def, mul_one] }
end

/-- The valuation ring `A` is isomorphic to the ring of integers of its associated valuation. -/
noncomputable def equiv_integer : A ≃+* (valuation A K).integer :=
ring_equiv.of_bijective (show A →ₙ+* (valuation A K).integer, from
{ to_fun := λ a, ⟨algebra_map A K a, (mem_integer_iff _ _ _).mpr ⟨a,rfl⟩⟩,
  map_mul' := λ _ _, by { ext1, exact (algebra_map A K).map_mul _ _ },
  map_zero' := by { ext1, exact (algebra_map A K).map_zero },
  map_add' := λ _ _, by { ext1, exact (algebra_map A K).map_add _ _ } })
begin
  split,
  { intros x y h,
    apply_fun (coe : _ → K) at h,
    dsimp at h,
    exact is_fraction_ring.injective _ _ h },
  { rintros ⟨a,(ha : a ∈ (valuation A K).integer)⟩,
    rw mem_integer_iff at ha,
    obtain ⟨a,rfl⟩ := ha,
    use [a, rfl] }
end

@[simp]
lemma coe_equiv_integer_apply (a : A) : (equiv_integer A K a : K) = algebra_map A K a := rfl

lemma range_algebra_map_eq : (valuation A K).integer = (algebra_map A K).range :=
by { ext, exact mem_integer_iff _ _ _ }

end

section

variables (A : Type u) [comm_ring A] [is_domain A] [valuation_ring A]

@[priority 100]
instance : local_ring A :=
local_ring.of_is_unit_or_is_unit_one_sub_self
begin
  intros a,
  obtain ⟨c,(h|h)⟩ := valuation_ring.cond a (1-a),
  { left,
    apply is_unit_of_mul_eq_one _ (c+1),
    simp [mul_add, h] },
  { right,
    apply is_unit_of_mul_eq_one _ (c+1),
    simp [mul_add, h] }
end

instance [decidable_rel ((≤) : ideal A → ideal A → Prop)] : linear_order (ideal A) :=
{ le_total := begin
    intros α β,
    by_cases h : α ≤ β, { exact or.inl h },
    erw not_forall at h,
    push_neg at h,
    obtain ⟨a,h₁,h₂⟩ := h,
    right,
    intros b hb,
    obtain ⟨c,(h|h)⟩ := valuation_ring.cond a b,
    { rw ← h,
      exact ideal.mul_mem_right _ _ h₁ },
    { exfalso, apply h₂, rw ← h,
      apply ideal.mul_mem_right _ _ hb },
  end,
  decidable_le := infer_instance,
  ..(infer_instance : complete_lattice (ideal A)) }

end

section

variables {𝒪 : Type u} {K : Type v} {Γ : Type w}
  [comm_ring 𝒪] [is_domain 𝒪] [field K] [algebra 𝒪 K]
  [linear_ordered_comm_group_with_zero Γ]
  (v : _root_.valuation K Γ) (hh : v.integers 𝒪)

include hh

/-- If `𝒪` satisfies `v.integers 𝒪` where `v` is a valuation on a field, then `𝒪`
is a valuation ring. -/
lemma of_integers : valuation_ring 𝒪 :=
begin
  constructor,
  intros a b,
  cases le_total (v (algebra_map 𝒪 K a)) (v (algebra_map 𝒪 K b)),
  { obtain ⟨c,hc⟩ := valuation.integers.dvd_of_le hh h,
    use c, exact or.inr hc.symm },
  { obtain ⟨c,hc⟩ := valuation.integers.dvd_of_le hh h,
    use c, exact or.inl hc.symm }
end

end

section

variables (K : Type u) [field K]

/-- A field is a valuation ring. -/
@[priority 100]
instance of_field : valuation_ring K :=
begin
  constructor,
  intros a b,
  by_cases b = 0,
  { use 0, left, simp [h] },
  { use a * b⁻¹, right, field_simp, rw mul_comm }
end

end

section

variables (A : Type u) [comm_ring A] [is_domain A] [discrete_valuation_ring A]

/-- A DVR is a valuation ring. -/
@[priority 100]
instance of_discrete_valuation_ring : valuation_ring A :=
begin
  constructor,
  intros a b,
  by_cases ha : a = 0, { use 0, right, simp [ha] },
  by_cases hb : b = 0, { use 0, left, simp [hb] },
  obtain ⟨ϖ,hϖ⟩ := discrete_valuation_ring.exists_irreducible A,
  obtain ⟨m,u,rfl⟩ := discrete_valuation_ring.eq_unit_mul_pow_irreducible ha hϖ,
  obtain ⟨n,v,rfl⟩ := discrete_valuation_ring.eq_unit_mul_pow_irreducible hb hϖ,
  cases le_total m n with h h,
  { use (u⁻¹ * v : Aˣ) * ϖ^(n-m), left,
    simp_rw [mul_comm (u : A), units.coe_mul, ← mul_assoc, mul_assoc _ (u : A)],
    simp only [units.mul_inv, mul_one, mul_comm _ (v : A), mul_assoc, ← pow_add],
    congr' 2,
    linarith },
  { use (v⁻¹ * u : Aˣ) * ϖ^(m-n), right,
    simp_rw [mul_comm (v : A), units.coe_mul, ← mul_assoc, mul_assoc _ (v : A)],
    simp only [units.mul_inv, mul_one, mul_comm _ (u : A), mul_assoc, ← pow_add],
    congr' 2,
    linarith }
end

end

end valuation_ring


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

Direct sum of modules over commutative rings, indexed by a discrete type.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.direct_sum
import Mathlib.linear_algebra.dfinsupp
import Mathlib.PostPort

universes u v w u₁ u_1

namespace Mathlib

/-!
# Direct sum of modules over commutative rings, indexed by a discrete type.

This file provides constructors for finite direct sums of modules.
It provides a construction of the direct sum using the universal property and proves
its uniqueness.

## Implementation notes

All of this file assumes that
* `R` is a commutative ring,
* `ι` is a discrete type,
* `S` is a finite set in `ι`,
* `M` is a family of `R` semimodules indexed over `ι`.
-/

namespace direct_sum

protected instance semimodule {R : Type u} [semiring R] {ι : Type v} {M : ι → Type w} [(i : ι) → add_comm_monoid (M i)] [(i : ι) → semimodule R (M i)] : semimodule R (direct_sum ι fun (i : ι) => M i) :=
  dfinsupp.semimodule

theorem smul_apply {R : Type u} [semiring R] {ι : Type v} {M : ι → Type w} [(i : ι) → add_comm_monoid (M i)] [(i : ι) → semimodule R (M i)] (b : R) (v : direct_sum ι fun (i : ι) => M i) (i : ι) : coe_fn (b • v) i = b • coe_fn v i :=
  dfinsupp.smul_apply b v i

/-- Create the direct sum given a family `M` of `R` semimodules indexed over `ι`. -/
def lmk (R : Type u) [semiring R] (ι : Type v) [dec_ι : DecidableEq ι] (M : ι → Type w) [(i : ι) → add_comm_monoid (M i)] [(i : ι) → semimodule R (M i)] (s : finset ι) : linear_map R ((i : ↥↑s) → M (subtype.val i)) (direct_sum ι fun (i : ι) => M i) :=
  dfinsupp.lmk

/-- Inclusion of each component into the direct sum. -/
def lof (R : Type u) [semiring R] (ι : Type v) [dec_ι : DecidableEq ι] (M : ι → Type w) [(i : ι) → add_comm_monoid (M i)] [(i : ι) → semimodule R (M i)] (i : ι) : linear_map R (M i) (direct_sum ι fun (i : ι) => M i) :=
  dfinsupp.lsingle

theorem single_eq_lof (R : Type u) [semiring R] {ι : Type v} [dec_ι : DecidableEq ι] {M : ι → Type w} [(i : ι) → add_comm_monoid (M i)] [(i : ι) → semimodule R (M i)] (i : ι) (b : M i) : dfinsupp.single i b = coe_fn (lof R ι M i) b :=
  rfl

/-- Scalar multiplication commutes with direct sums. -/
theorem mk_smul (R : Type u) [semiring R] {ι : Type v} [dec_ι : DecidableEq ι] {M : ι → Type w} [(i : ι) → add_comm_monoid (M i)] [(i : ι) → semimodule R (M i)] (s : finset ι) (c : R) (x : (i : ↥↑s) → M (subtype.val i)) : coe_fn (mk M s) (c • x) = c • coe_fn (mk M s) x :=
  linear_map.map_smul (lmk R ι M s) c x

/-- Scalar multiplication commutes with the inclusion of each component into the direct sum. -/
theorem of_smul (R : Type u) [semiring R] {ι : Type v} [dec_ι : DecidableEq ι] {M : ι → Type w} [(i : ι) → add_comm_monoid (M i)] [(i : ι) → semimodule R (M i)] (i : ι) (c : R) (x : M i) : coe_fn (of M i) (c • x) = c • coe_fn (of M i) x :=
  linear_map.map_smul (lof R ι M i) c x

theorem support_smul {R : Type u} [semiring R] {ι : Type v} [dec_ι : DecidableEq ι] {M : ι → Type w} [(i : ι) → add_comm_monoid (M i)] [(i : ι) → semimodule R (M i)] [(i : ι) → (x : M i) → Decidable (x ≠ 0)] (c : R) (v : direct_sum ι fun (i : ι) => M i) : dfinsupp.support (c • v) ⊆ dfinsupp.support v :=
  dfinsupp.support_smul c v

/-- The linear map constructed using the universal property of the coproduct. -/
def to_module (R : Type u) [semiring R] (ι : Type v) [dec_ι : DecidableEq ι] {M : ι → Type w} [(i : ι) → add_comm_monoid (M i)] [(i : ι) → semimodule R (M i)] (N : Type u₁) [add_comm_monoid N] [semimodule R N] (φ : (i : ι) → linear_map R (M i) N) : linear_map R (direct_sum ι fun (i : ι) => M i) N :=
  coe_fn dfinsupp.lsum φ

/-- The map constructed using the universal property gives back the original maps when
restricted to each component. -/
@[simp] theorem to_module_lof (R : Type u) [semiring R] {ι : Type v} [dec_ι : DecidableEq ι] {M : ι → Type w} [(i : ι) → add_comm_monoid (M i)] [(i : ι) → semimodule R (M i)] {N : Type u₁} [add_comm_monoid N] [semimodule R N] {φ : (i : ι) → linear_map R (M i) N} (i : ι) (x : M i) : coe_fn (to_module R ι N φ) (coe_fn (lof R ι M i) x) = coe_fn (φ i) x :=
  to_add_monoid_of (fun (i : ι) => linear_map.to_add_monoid_hom (φ i)) i x

/-- Every linear map from a direct sum agrees with the one obtained by applying
the universal property to each of its components. -/
theorem to_module.unique (R : Type u) [semiring R] {ι : Type v} [dec_ι : DecidableEq ι] {M : ι → Type w} [(i : ι) → add_comm_monoid (M i)] [(i : ι) → semimodule R (M i)] {N : Type u₁} [add_comm_monoid N] [semimodule R N] (ψ : linear_map R (direct_sum ι fun (i : ι) => M i) N) (f : direct_sum ι fun (i : ι) => M i) : coe_fn ψ f = coe_fn (to_module R ι N fun (i : ι) => linear_map.comp ψ (lof R ι M i)) f :=
  to_add_monoid.unique (linear_map.to_add_monoid_hom ψ) f

theorem to_module.ext (R : Type u) [semiring R] {ι : Type v} [dec_ι : DecidableEq ι] {M : ι → Type w} [(i : ι) → add_comm_monoid (M i)] [(i : ι) → semimodule R (M i)] {N : Type u₁} [add_comm_monoid N] [semimodule R N] {ψ : linear_map R (direct_sum ι fun (i : ι) => M i) N} {ψ' : linear_map R (direct_sum ι fun (i : ι) => M i) N} (H : ∀ (i : ι), linear_map.comp ψ (lof R ι M i) = linear_map.comp ψ' (lof R ι M i)) (f : direct_sum ι fun (i : ι) => M i) : coe_fn ψ f = coe_fn ψ' f :=
  eq.mpr (id (Eq._oldrec (Eq.refl (coe_fn ψ f = coe_fn ψ' f)) (dfinsupp.lhom_ext' H))) (Eq.refl (coe_fn ψ' f))

/--
The inclusion of a subset of the direct summands
into a larger subset of the direct summands, as a linear map.
-/
def lset_to_set (R : Type u) [semiring R] {ι : Type v} [dec_ι : DecidableEq ι] {M : ι → Type w} [(i : ι) → add_comm_monoid (M i)] [(i : ι) → semimodule R (M i)] (S : set ι) (T : set ι) (H : S ⊆ T) : linear_map R (direct_sum ↥S fun (i : ↥S) => M ↑i) (direct_sum ↥T fun (i : ↥T) => M ↑i) :=
  to_module R (↥S) (direct_sum ↥T fun (i : ↥T) => M ↑i)
    fun (i : ↥S) => lof R (↥T) (fun (i : Subtype T) => M ↑i) { val := ↑i, property := sorry }

/-- The natural linear equivalence between `⨁ _ : ι, M` and `M` when `unique ι`. -/
protected def lid (R : Type u) [semiring R] (M : Type v) (ι : optParam (Type u_1) PUnit) [add_comm_monoid M] [semimodule R M] [unique ι] : linear_equiv R (direct_sum ι fun (_x : ι) => M) M :=
  linear_equiv.mk (add_equiv.to_fun (direct_sum.id M ι)) sorry sorry (add_equiv.inv_fun (direct_sum.id M ι)) sorry sorry

/-- The projection map onto one component, as a linear map. -/
def component (R : Type u) [semiring R] (ι : Type v) (M : ι → Type w) [(i : ι) → add_comm_monoid (M i)] [(i : ι) → semimodule R (M i)] (i : ι) : linear_map R (direct_sum ι fun (i : ι) => M i) (M i) :=
  dfinsupp.lapply i

theorem apply_eq_component (R : Type u) [semiring R] {ι : Type v} {M : ι → Type w} [(i : ι) → add_comm_monoid (M i)] [(i : ι) → semimodule R (M i)] (f : direct_sum ι fun (i : ι) => M i) (i : ι) : coe_fn f i = coe_fn (component R ι M i) f :=
  rfl

theorem ext (R : Type u) [semiring R] {ι : Type v} {M : ι → Type w} [(i : ι) → add_comm_monoid (M i)] [(i : ι) → semimodule R (M i)] {f : direct_sum ι fun (i : ι) => M i} {g : direct_sum ι fun (i : ι) => M i} (h : ∀ (i : ι), coe_fn (component R ι M i) f = coe_fn (component R ι M i) g) : f = g :=
  dfinsupp.ext h

theorem ext_iff (R : Type u) [semiring R] {ι : Type v} {M : ι → Type w} [(i : ι) → add_comm_monoid (M i)] [(i : ι) → semimodule R (M i)] {f : direct_sum ι fun (i : ι) => M i} {g : direct_sum ι fun (i : ι) => M i} : f = g ↔ ∀ (i : ι), coe_fn (component R ι M i) f = coe_fn (component R ι M i) g := sorry

@[simp] theorem lof_apply (R : Type u) [semiring R] {ι : Type v} [dec_ι : DecidableEq ι] {M : ι → Type w} [(i : ι) → add_comm_monoid (M i)] [(i : ι) → semimodule R (M i)] (i : ι) (b : M i) : coe_fn (coe_fn (lof R ι M i) b) i = b :=
  dfinsupp.single_eq_same

@[simp] theorem component.lof_self (R : Type u) [semiring R] {ι : Type v} [dec_ι : DecidableEq ι] {M : ι → Type w} [(i : ι) → add_comm_monoid (M i)] [(i : ι) → semimodule R (M i)] (i : ι) (b : M i) : coe_fn (component R ι M i) (coe_fn (lof R ι M i) b) = b :=
  lof_apply R i b

theorem component.of (R : Type u) [semiring R] {ι : Type v} [dec_ι : DecidableEq ι] {M : ι → Type w} [(i : ι) → add_comm_monoid (M i)] [(i : ι) → semimodule R (M i)] (i : ι) (j : ι) (b : M j) : coe_fn (component R ι M i) (coe_fn (lof R ι M j) b) =
  dite (j = i) (fun (h : j = i) => eq.rec_on h b) fun (h : ¬j = i) => 0 :=
  dfinsupp.single_apply


/-
File: signature_recover_public_key_bigint_mul_soundness.lean

Autogenerated file.
-/
import starkware.cairo.lean.semantics.soundness.hoare
import .signature_recover_public_key_code
import ..signature_recover_public_key_spec
open tactic

open starkware.cairo.common.cairo_secp.bigint

variables {F : Type} [field F] [decidable_eq F] [prelude_hyps F]
variable  mem : F → F
variable  σ : register_state F

/- starkware.cairo.common.cairo_secp.bigint.bigint_mul autogenerated soundness theorem -/

theorem auto_sound_bigint_mul
    -- arguments
    (x y : BigInt3 F)
    -- code is in memory at σ.pc
    (h_mem : mem_at mem code_bigint_mul σ.pc)
    -- input arguments on the stack
    (hin_x : x = cast_BigInt3 mem (σ.fp - 8))
    (hin_y : y = cast_BigInt3 mem (σ.fp - 5))
    -- conclusion
  : ensures_ret mem σ (λ κ τ, τ.ap = σ.ap + 13 ∧ spec_bigint_mul mem κ x y (cast_UnreducedBigInt5 mem (τ.ap - 5))) :=
begin
  apply ensures_of_ensuresb, intro νbound,
  have h_mem_rec := h_mem,
  unpack_memory code_bigint_mul at h_mem with ⟨hpc0, hpc1, hpc2, hpc3, hpc4, hpc5, hpc6, hpc7, hpc8, hpc9, hpc10, hpc11, hpc12, hpc13⟩,
  -- return
  step_assert_eq hpc0 with hret0,
  step_assert_eq hpc1 with hret1,
  step_assert_eq hpc2 with hret2,
  step_assert_eq hpc3 with hret3,
  step_assert_eq hpc4 with hret4,
  step_assert_eq hpc5 with hret5,
  step_assert_eq hpc6 with hret6,
  step_assert_eq hpc7 with hret7,
  step_assert_eq hpc8 with hret8,
  step_assert_eq hpc9 with hret9,
  step_assert_eq hpc10 with hret10,
  step_assert_eq hpc11 with hret11,
  step_assert_eq hpc12 with hret12,
  step_ret hpc13,
  -- finish
  step_done, use_only [rfl, rfl],
  split, refl,
  -- Final Proof
  -- user-provided reduction
  suffices auto_spec: auto_spec_bigint_mul mem _ x y _,
  { apply sound_bigint_mul, apply auto_spec },
  -- prove the auto generated assertion
  dsimp [auto_spec_bigint_mul],
  try { norm_num1 }, try { arith_simps },
  try { split, linarith },
  try { ensures_simps; try { simp only [add_neg_eq_sub, hin_x, hin_y] }, },
  try { dsimp [cast_BigInt3, cast_UnreducedBigInt5] },
  try { arith_simps }, try { simp only [hret0, hret1, hret2, hret3, hret4, hret5, hret6, hret7, hret8, hret9, hret10, hret11, hret12] },
  try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },
end


/-
Copyright (c) 2021 Oliver Nash. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Oliver Nash
-/
import algebra.lie.basic
import ring_theory.noetherian

/-!
# Lie subalgebras

This file defines Lie subalgebras of a Lie algebra and provides basic related definitions and
results.

## Main definitions

  * `lie_subalgebra`
  * `lie_subalgebra.incl`
  * `lie_subalgebra.map`
  * `lie_hom.range`
  * `lie_equiv.of_injective`
  * `lie_equiv.of_eq`
  * `lie_equiv.of_subalgebra`
  * `lie_equiv.of_subalgebras`

## Tags

lie algebra, lie subalgebra
-/

universes u v w w₁ w₂

section lie_subalgebra

variables (R : Type u) (L : Type v) [comm_ring R] [lie_ring L] [lie_algebra R L]

/-- A Lie subalgebra of a Lie algebra is submodule that is closed under the Lie bracket.
This is a sufficient condition for the subset itself to form a Lie algebra. -/
structure lie_subalgebra extends submodule R L :=
(lie_mem' : ∀ {x y}, x ∈ carrier → y ∈ carrier → ⁅x, y⁆ ∈ carrier)

attribute [nolint doc_blame] lie_subalgebra.to_submodule

/-- The zero algebra is a subalgebra of any Lie algebra. -/
instance : has_zero (lie_subalgebra R L) :=
⟨{ lie_mem' := λ x y hx hy, by { rw [((submodule.mem_bot R).1 hx), zero_lie],
                                exact submodule.zero_mem (0 : submodule R L), },
   ..(0 : submodule R L) }⟩

instance : inhabited (lie_subalgebra R L) := ⟨0⟩
instance : has_coe (lie_subalgebra R L) (submodule R L) := ⟨lie_subalgebra.to_submodule⟩
instance : has_mem L (lie_subalgebra R L) := ⟨λ x L', x ∈ (L' : set L)⟩

/-- A Lie subalgebra forms a new Lie ring. -/
instance lie_subalgebra_lie_ring (L' : lie_subalgebra R L) : lie_ring L' :=
{ bracket      := λ x y, ⟨⁅x.val, y.val⁆, L'.lie_mem' x.property y.property⟩,
  lie_add      := by { intros, apply set_coe.ext, apply lie_add, },
  add_lie      := by { intros, apply set_coe.ext, apply add_lie, },
  lie_self     := by { intros, apply set_coe.ext, apply lie_self, },
  leibniz_lie  := by { intros, apply set_coe.ext, apply leibniz_lie, } }

/-- A Lie subalgebra forms a new Lie algebra. -/
instance lie_subalgebra_lie_algebra (L' : lie_subalgebra R L) : lie_algebra R L' :=
{ lie_smul := by { intros, apply set_coe.ext, apply lie_smul } }

namespace lie_subalgebra

variables {R L} (L' : lie_subalgebra R L)

@[simp] lemma zero_mem : (0 : L) ∈ L' := (L' : submodule R L).zero_mem

lemma smul_mem (t : R) {x : L} (h : x ∈ L') : t • x ∈ L' := (L' : submodule R L).smul_mem t h

lemma add_mem {x y : L} (hx : x ∈ L') (hy : y ∈ L') : (x + y : L) ∈ L' :=
(L' : submodule R L).add_mem hx hy

lemma sub_mem {x y : L} (hx : x ∈ L') (hy : y ∈ L') : (x - y : L) ∈ L' :=
(L' : submodule R L).sub_mem hx hy

lemma lie_mem {x y : L} (hx : x ∈ L') (hy : y ∈ L') : (⁅x, y⁆ : L) ∈ L' := L'.lie_mem' hx hy

@[simp] lemma mem_carrier {x : L} : x ∈ L'.carrier ↔ x ∈ (L' : set L) := iff.rfl

@[simp] lemma mem_mk_iff (S : set L) (h₁ h₂ h₃ h₄) {x : L} :
  x ∈ (⟨⟨S, h₁, h₂, h₃⟩, h₄⟩ : lie_subalgebra R L) ↔ x ∈ S :=
iff.rfl

@[simp] lemma mem_coe_submodule {x : L} : x ∈ (L' : submodule R L) ↔ x ∈ L' := iff.rfl

lemma mem_coe {x : L} : x ∈ (L' : set L) ↔ x ∈ L' := iff.rfl

@[simp, norm_cast] lemma coe_bracket (x y : L') : (↑⁅x, y⁆ : L) = ⁅(↑x : L), ↑y⁆ := rfl

lemma ext_iff (x y : L') : x = y ↔ (x : L) = y := subtype.ext_iff

lemma coe_zero_iff_zero (x : L') : (x : L) = 0 ↔ x = 0 := (ext_iff L' x 0).symm

@[ext] lemma ext (L₁' L₂' : lie_subalgebra R L) (h : ∀ x, x ∈ L₁' ↔ x ∈ L₂') :
  L₁' = L₂' :=
by { cases L₁', cases L₂', simp only [], ext x, exact h x, }

lemma ext_iff' (L₁' L₂' : lie_subalgebra R L) : L₁' = L₂' ↔ ∀ x, x ∈ L₁' ↔ x ∈ L₂' :=
⟨λ h x, by rw h, ext L₁' L₂'⟩

@[simp] lemma mk_coe (S : set L) (h₁ h₂ h₃ h₄) :
  ((⟨⟨S, h₁, h₂, h₃⟩, h₄⟩ : lie_subalgebra R L) : set L) = S := rfl

@[simp] lemma coe_to_submodule_mk (p : submodule R L) (h) :
  (({lie_mem' := h, ..p} : lie_subalgebra R L) : submodule R L) = p :=
by { cases p, refl, }

lemma coe_injective : function.injective (coe : lie_subalgebra R L → set L) :=
by { rintro ⟨⟨⟩⟩ ⟨⟨⟩⟩ h, congr' }

@[norm_cast] theorem coe_set_eq (L₁' L₂' : lie_subalgebra R L) :
  (L₁' : set L) = L₂' ↔ L₁' = L₂' := coe_injective.eq_iff

lemma to_submodule_injective :
  function.injective (coe : lie_subalgebra R L → submodule R L) :=
λ L₁' L₂' h, by { rw set_like.ext'_iff at h, rw ← coe_set_eq, exact h, }

@[simp] lemma coe_to_submodule_eq_iff (L₁' L₂' : lie_subalgebra R L) :
  (L₁' : submodule R L) = (L₂' : submodule R L) ↔ L₁' = L₂' :=
to_submodule_injective.eq_iff

@[norm_cast]
lemma coe_to_submodule : ((L' : submodule R L) : set L) = L' := rfl

section lie_module

variables {M : Type w} [add_comm_group M] [lie_ring_module L M]
variables {N : Type w₁} [add_comm_group N] [lie_ring_module L N] [module R N] [lie_module R L N]

/-- Given a Lie algebra `L` containing a Lie subalgebra `L' ⊆ L`, together with a Lie ring module
`M` of `L`, we may regard `M` as a Lie ring module of `L'` by restriction. -/
instance : lie_ring_module L' M :=
{ bracket     := λ x m, ⁅(x : L), m⁆,
  add_lie     := λ x y m, add_lie x y m,
  lie_add     := λ x y m, lie_add x y m,
  leibniz_lie := λ x y m, leibniz_lie x y m, }

@[simp] lemma coe_bracket_of_module (x : L') (m : M) : ⁅x, m⁆ = ⁅(x : L), m⁆ := rfl

variables [module R M] [lie_module R L M]

/-- Given a Lie algebra `L` containing a Lie subalgebra `L' ⊆ L`, together with a Lie module `M` of
`L`, we may regard `M` as a Lie module of `L'` by restriction. -/
instance : lie_module R L' M :=
{ smul_lie := λ t x m, by simp only [coe_bracket_of_module, smul_lie, submodule.coe_smul_of_tower],
  lie_smul := λ t x m, by simp only [coe_bracket_of_module, lie_smul], }

/-- An `L`-equivariant map of Lie modules `M → N` is `L'`-equivariant for any Lie subalgebra
`L' ⊆ L`. -/
def _root_.lie_module_hom.restrict_lie (f : M →ₗ⁅R,L⁆ N) (L' : lie_subalgebra R L) : M →ₗ⁅R,L'⁆ N :=
{ map_lie' := λ x m, f.map_lie ↑x m,
  .. (f : M →ₗ[R] N)}

@[simp] lemma _root_.lie_module_hom.coe_restrict_lie (f : M →ₗ⁅R,L⁆ N) :
  ⇑(f.restrict_lie L') = f :=
rfl

end lie_module

/-- The embedding of a Lie subalgebra into the ambient space as a morphism of Lie algebras. -/
def incl : L' →ₗ⁅R⁆ L :=
{ map_lie' := λ x y, by { simp only [linear_map.to_fun_eq_coe, submodule.subtype_apply], refl, },
  .. (L' : submodule R L).subtype, }

@[simp] lemma coe_incl : ⇑L'.incl = coe := rfl

/-- The embedding of a Lie subalgebra into the ambient space as a morphism of Lie modules. -/
def incl' : L' →ₗ⁅R,L'⁆ L :=
{ map_lie' := λ x y, by simp only [coe_bracket_of_module, linear_map.to_fun_eq_coe,
    submodule.subtype_apply, coe_bracket],
  .. (L' : submodule R L).subtype, }

@[simp] lemma coe_incl' : ⇑L'.incl' = coe := rfl

end lie_subalgebra

variables {R L} {L₂ : Type w} [lie_ring L₂] [lie_algebra R L₂]
variables (f : L →ₗ⁅R⁆ L₂)

namespace lie_hom

/-- The range of a morphism of Lie algebras is a Lie subalgebra. -/
def range : lie_subalgebra R L₂ :=
{ lie_mem' := λ x y,
    show x ∈ f.to_linear_map.range → y ∈ f.to_linear_map.range → ⁅x, y⁆ ∈ f.to_linear_map.range,
    by { repeat { rw linear_map.mem_range }, rintros ⟨x', hx⟩ ⟨y', hy⟩, refine ⟨⁅x', y'⁆, _⟩,
         rw [←hx, ←hy], change f ⁅x', y'⁆ = ⁅f x', f y'⁆, rw map_lie, },
  ..(f : L →ₗ[R] L₂).range }

@[simp] lemma range_coe : (f.range : set L₂) = set.range f :=
linear_map.range_coe ↑f

@[simp] lemma mem_range (x : L₂) : x ∈ f.range ↔ ∃ (y : L), f y = x := linear_map.mem_range

lemma mem_range_self (x : L) : f x ∈ f.range := linear_map.mem_range_self f x

/-- We can restrict a morphism to a (surjective) map to its range. -/
def range_restrict : L →ₗ⁅R⁆ f.range :=
{ map_lie' := λ x y, by { apply subtype.ext, exact f.map_lie x y, },
  ..(f : L →ₗ[R] L₂).range_restrict, }

@[simp] lemma range_restrict_apply (x : L) : f.range_restrict x = ⟨f x, f.mem_range_self x⟩ := rfl

lemma surjective_range_restrict : function.surjective (f.range_restrict) :=
begin
  rintros ⟨y, hy⟩,
  erw mem_range at hy, obtain ⟨x, rfl⟩ := hy,
  use x,
  simp only [subtype.mk_eq_mk, range_restrict_apply],
end

end lie_hom

lemma submodule.exists_lie_subalgebra_coe_eq_iff (p : submodule R L) :
  (∃ (K : lie_subalgebra R L), ↑K = p) ↔ ∀ (x y : L), x ∈ p → y ∈ p → ⁅x, y⁆ ∈ p :=
begin
  split,
  { rintros ⟨K, rfl⟩, exact K.lie_mem', },
  { intros h, use { lie_mem' := h, ..p }, exact lie_subalgebra.coe_to_submodule_mk p _, },
end

namespace lie_subalgebra

variables (K K' : lie_subalgebra R L) (K₂ : lie_subalgebra R L₂)

@[simp] lemma incl_range : K.incl.range = K :=
by { rw ← coe_to_submodule_eq_iff, exact (K : submodule R L).range_subtype, }

/-- The image of a Lie subalgebra under a Lie algebra morphism is a Lie subalgebra of the
codomain. -/
def map : lie_subalgebra R L₂ :=
{ lie_mem' := λ x y hx hy, by
  { erw submodule.mem_map at hx, rcases hx with ⟨x', hx', hx⟩, rw ←hx,
    erw submodule.mem_map at hy, rcases hy with ⟨y', hy', hy⟩, rw ←hy,
    erw submodule.mem_map,
    exact ⟨⁅x', y'⁆, K.lie_mem hx' hy', f.map_lie x' y'⟩, },
..((K : submodule R L).map (f : L →ₗ[R] L₂)) }

@[simp] lemma mem_map (x : L₂) : x ∈ K.map f ↔ ∃ (y : L), y ∈ K ∧ f y = x := submodule.mem_map

-- TODO Rename and state for homs instead of equivs.
@[simp] lemma mem_map_submodule (e : L ≃ₗ⁅R⁆ L₂) (x : L₂) :
  x ∈ K.map (e : L →ₗ⁅R⁆ L₂) ↔ x ∈ (K : submodule R L).map (e : L →ₗ[R] L₂) :=
iff.rfl

/-- The preimage of a Lie subalgebra under a Lie algebra morphism is a Lie subalgebra of the
domain. -/
def comap : lie_subalgebra R L :=
{ lie_mem' := λ x y hx hy, by
    { suffices : ⁅f x, f y⁆ ∈ K₂, by { simp [this], }, exact K₂.lie_mem hx hy, },
  ..((K₂ : submodule R L₂).comap (f : L →ₗ[R] L₂)), }

section lattice_structure

open set

instance : partial_order (lie_subalgebra R L) :=
{ le := λ N N', ∀ ⦃x⦄, x ∈ N → x ∈ N', -- Overriding `le` like this gives a better defeq.
  ..partial_order.lift (coe : lie_subalgebra R L → set L) coe_injective }

lemma le_def : K ≤ K' ↔ (K : set L) ⊆ K' := iff.rfl

@[simp, norm_cast] lemma coe_submodule_le_coe_submodule : (K : submodule R L) ≤ K' ↔ K ≤ K' :=
iff.rfl

instance : has_bot (lie_subalgebra R L) := ⟨0⟩

@[simp] lemma bot_coe : ((⊥ : lie_subalgebra R L) : set L) = {0} := rfl

@[simp] lemma bot_coe_submodule : ((⊥ : lie_subalgebra R L) : submodule R L) = ⊥ := rfl

@[simp] lemma mem_bot (x : L) : x ∈ (⊥ : lie_subalgebra R L) ↔ x = 0 := mem_singleton_iff

instance : has_top (lie_subalgebra R L) :=
⟨{ lie_mem' := λ x y hx hy, mem_univ ⁅x, y⁆,
   ..(⊤ : submodule R L) }⟩

@[simp] lemma top_coe : ((⊤ : lie_subalgebra R L) : set L) = univ := rfl

@[simp] lemma top_coe_submodule : ((⊤ : lie_subalgebra R L) : submodule R L) = ⊤ := rfl

@[simp] lemma mem_top (x : L) : x ∈ (⊤ : lie_subalgebra R L) := mem_univ x

lemma _root_.lie_hom.range_eq_map : f.range = map f ⊤ :=
by { ext, simp }

instance : has_inf (lie_subalgebra R L) :=
⟨λ K K', { lie_mem' := λ x y hx hy, mem_inter (K.lie_mem hx.1 hy.1) (K'.lie_mem hx.2 hy.2),
            ..(K ⊓ K' : submodule R L) }⟩

instance : has_Inf (lie_subalgebra R L) :=
⟨λ S, { lie_mem' := λ x y hx hy, by
        { simp only [submodule.mem_carrier, mem_Inter, submodule.Inf_coe, mem_set_of_eq,
            forall_apply_eq_imp_iff₂, exists_imp_distrib] at *,
          intros K hK, exact K.lie_mem (hx K hK) (hy K hK), },
        ..Inf {(s : submodule R L) | s ∈ S} }⟩

@[simp] theorem inf_coe : (↑(K ⊓ K') : set L) = K ∩ K' := rfl

@[simp] lemma Inf_coe_to_submodule (S : set (lie_subalgebra R L)) :
  (↑(Inf S) : submodule R L) = Inf {(s : submodule R L) | s ∈ S} := rfl

@[simp] lemma Inf_coe (S : set (lie_subalgebra R L)) : (↑(Inf S) : set L) = ⋂ s ∈ S, (s : set L) :=
begin
  rw [← coe_to_submodule, Inf_coe_to_submodule, submodule.Inf_coe],
  ext x,
  simpa only [mem_Inter, mem_set_of_eq, forall_apply_eq_imp_iff₂, exists_imp_distrib],
end

lemma Inf_glb (S : set (lie_subalgebra R L)) : is_glb S (Inf S) :=
begin
  have h : ∀ (K K' : lie_subalgebra R L), (K : set L) ≤ K' ↔ K ≤ K', { intros, exact iff.rfl, },
  apply is_glb.of_image h,
  simp only [Inf_coe],
  exact is_glb_binfi
end

/-- The set of Lie subalgebras of a Lie algebra form a complete lattice.

We provide explicit values for the fields `bot`, `top`, `inf` to get more convenient definitions
than we would otherwise obtain from `complete_lattice_of_Inf`. -/
instance : complete_lattice (lie_subalgebra R L) :=
{ bot          := ⊥,
  bot_le       := λ N _ h, by { rw mem_bot at h, rw h, exact N.zero_mem', },
  top          := ⊤,
  le_top       := λ _ _ _, trivial,
  inf          := (⊓),
  le_inf       := λ N₁ N₂ N₃ h₁₂ h₁₃ m hm, ⟨h₁₂ hm, h₁₃ hm⟩,
  inf_le_left  := λ _ _ _, and.left,
  inf_le_right := λ _ _ _, and.right,
  ..complete_lattice_of_Inf _ Inf_glb }

instance : add_comm_monoid (lie_subalgebra R L) :=
{ add       := (⊔),
  add_assoc := λ _ _ _, sup_assoc,
  zero      := ⊥,
  zero_add  := λ _, bot_sup_eq,
  add_zero  := λ _, sup_bot_eq,
  add_comm  := λ _ _, sup_comm, }

@[simp] lemma add_eq_sup : K + K' = K ⊔ K' := rfl

@[norm_cast, simp] lemma inf_coe_to_submodule :
  (↑(K ⊓ K') : submodule R L) = (K : submodule R L) ⊓ (K' : submodule R L) := rfl

@[simp] lemma mem_inf (x : L) : x ∈ K ⊓ K' ↔ x ∈ K ∧ x ∈ K' :=
by rw [← mem_coe_submodule, ← mem_coe_submodule, ← mem_coe_submodule, inf_coe_to_submodule,
  submodule.mem_inf]

lemma eq_bot_iff : K = ⊥ ↔ ∀ (x : L), x ∈ K → x = 0 :=
by { rw eq_bot_iff, exact iff.rfl, }

-- TODO[gh-6025]: make this an instance once safe to do so
lemma subsingleton_of_bot : subsingleton (lie_subalgebra R ↥(⊥ : lie_subalgebra R L)) :=
begin
  apply subsingleton_of_bot_eq_top,
  ext ⟨x, hx⟩, change x ∈ ⊥ at hx, rw submodule.mem_bot at hx, subst hx,
  simp only [true_iff, eq_self_iff_true, submodule.mk_eq_zero, mem_bot],
end

variables (R L)

lemma well_founded_of_noetherian [is_noetherian R L] :
  well_founded ((>) : lie_subalgebra R L → lie_subalgebra R L → Prop) :=
begin
  let f : ((>) : lie_subalgebra R L → lie_subalgebra R L → Prop) →r
          ((>) : submodule R L → submodule R L → Prop) :=
  { to_fun       := coe,
    map_rel' := λ N N' h, h, },
  apply f.well_founded, rw ← is_noetherian_iff_well_founded, apply_instance,
end

variables {R L K K' f}

section nested_subalgebras

variables (h : K ≤ K')

/-- Given two nested Lie subalgebras `K ⊆ K'`, the inclusion `K ↪ K'` is a morphism of Lie
algebras. -/
def hom_of_le : K →ₗ⁅R⁆ K' :=
{ map_lie' := λ x y, rfl,
  ..submodule.of_le h }

@[simp] lemma coe_hom_of_le (x : K) : (hom_of_le h x : L) = x := rfl

lemma hom_of_le_apply (x : K) : hom_of_le h x = ⟨x.1, h x.2⟩ := rfl

lemma hom_of_le_injective : function.injective (hom_of_le h) :=
λ x y, by simp only [hom_of_le_apply, imp_self, subtype.mk_eq_mk, set_like.coe_eq_coe,
  subtype.val_eq_coe]

/-- Given two nested Lie subalgebras `K ⊆ K'`, we can view `K` as a Lie subalgebra of `K'`,
regarded as Lie algebra in its own right. -/
def of_le : lie_subalgebra R K' := (hom_of_le h).range

@[simp] lemma mem_of_le (x : K') : x ∈ of_le h ↔ (x : L) ∈ K :=
begin
  simp only [of_le, hom_of_le_apply, lie_hom.mem_range],
  split,
  { rintros ⟨y, rfl⟩, exact y.property, },
  { intros h, use ⟨(x : L), h⟩, simp, },
end

lemma of_le_eq_comap_incl : of_le h = K.comap K'.incl :=
by { ext, rw mem_of_le, refl, }

end nested_subalgebras

lemma map_le_iff_le_comap {K : lie_subalgebra R L} {K' : lie_subalgebra R L₂} :
  map f K ≤ K' ↔ K ≤ comap f K' := set.image_subset_iff

lemma gc_map_comap : galois_connection (map f) (comap f) := λ K K', map_le_iff_le_comap

end lattice_structure

section lie_span

variables (R L) (s : set L)

/-- The Lie subalgebra of a Lie algebra `L` generated by a subset `s ⊆ L`. -/
def lie_span : lie_subalgebra R L := Inf {N | s ⊆ N}

variables {R L s}

lemma mem_lie_span {x : L} : x ∈ lie_span R L s ↔ ∀ K : lie_subalgebra R L, s ⊆ K → x ∈ K :=
by { change x ∈ (lie_span R L s : set L) ↔ _, erw Inf_coe, exact set.mem_bInter_iff, }

lemma subset_lie_span : s ⊆ lie_span R L s :=
by { intros m hm, erw mem_lie_span, intros K hK, exact hK hm, }

lemma submodule_span_le_lie_span : submodule.span R s ≤ lie_span R L s :=
by { rw submodule.span_le, apply subset_lie_span, }

lemma lie_span_le {K} : lie_span R L s ≤ K ↔ s ⊆ K :=
begin
  split,
  { exact set.subset.trans subset_lie_span, },
  { intros hs m hm, rw mem_lie_span at hm, exact hm _ hs, },
end

lemma lie_span_mono {t : set L} (h : s ⊆ t) : lie_span R L s ≤ lie_span R L t :=
by { rw lie_span_le, exact set.subset.trans h subset_lie_span, }

lemma lie_span_eq : lie_span R L (K : set L) = K :=
le_antisymm (lie_span_le.mpr rfl.subset) subset_lie_span

lemma coe_lie_span_submodule_eq_iff {p : submodule R L} :
  (lie_span R L (p : set L) : submodule R L) = p ↔ ∃ (K : lie_subalgebra R L), ↑K = p :=
begin
  rw p.exists_lie_subalgebra_coe_eq_iff, split; intros h,
  { intros x m hm, rw [← h, mem_coe_submodule], exact lie_mem _ (subset_lie_span hm), },
  { rw [← coe_to_submodule_mk p h, coe_to_submodule, coe_to_submodule_eq_iff, lie_span_eq], },
end

variables (R L)

/-- `lie_span` forms a Galois insertion with the coercion from `lie_subalgebra` to `set`. -/
protected def gi : galois_insertion (lie_span R L : set L → lie_subalgebra R L) coe :=
{ choice    := λ s _, lie_span R L s,
  gc        := λ s t, lie_span_le,
  le_l_u    := λ s, subset_lie_span,
  choice_eq := λ s h, rfl }

@[simp] lemma span_empty : lie_span R L (∅ : set L) = ⊥ :=
(lie_subalgebra.gi R L).gc.l_bot

@[simp] lemma span_univ : lie_span R L (set.univ : set L) = ⊤ :=
eq_top_iff.2 $ set_like.le_def.2 $ subset_lie_span

variables {L}

lemma span_union (s t : set L) : lie_span R L (s ∪ t) = lie_span R L s ⊔ lie_span R L t :=
(lie_subalgebra.gi R L).gc.l_sup

lemma span_Union {ι} (s : ι → set L) : lie_span R L (⋃ i, s i) = ⨆ i, lie_span R L (s i) :=
(lie_subalgebra.gi R L).gc.l_supr

end lie_span

end lie_subalgebra

end lie_subalgebra

namespace lie_equiv

variables {R : Type u} {L₁ : Type v} {L₂ : Type w}
variables [comm_ring R] [lie_ring L₁] [lie_ring L₂] [lie_algebra R L₁] [lie_algebra R L₂]

/-- An injective Lie algebra morphism is an equivalence onto its range. -/
noncomputable def of_injective (f : L₁ →ₗ⁅R⁆ L₂) (h : function.injective f) :
  L₁ ≃ₗ⁅R⁆ f.range :=
{ map_lie' := λ x y, by { apply set_coe.ext, simpa, },
..(linear_equiv.of_injective ↑f $ by rwa [lie_hom.coe_to_linear_map])}

@[simp] lemma of_injective_apply (f : L₁ →ₗ⁅R⁆ L₂) (h : function.injective f) (x : L₁) :
  ↑(of_injective f h x) = f x := rfl

variables (L₁' L₁'' : lie_subalgebra R L₁) (L₂' : lie_subalgebra R L₂)

/-- Lie subalgebras that are equal as sets are equivalent as Lie algebras. -/
def of_eq (h : (L₁' : set L₁) = L₁'') : L₁' ≃ₗ⁅R⁆ L₁'' :=
{ map_lie' := λ x y, by { apply set_coe.ext, simp, },
  ..(linear_equiv.of_eq ↑L₁' ↑L₁''
      (by {ext x, change x ∈ (L₁' : set L₁) ↔ x ∈ (L₁'' : set L₁), rw h, } )) }

@[simp] lemma of_eq_apply (L L' : lie_subalgebra R L₁) (h : (L : set L₁) = L') (x : L) :
  (↑(of_eq L L' h x) : L₁) = x := rfl

variables (e : L₁ ≃ₗ⁅R⁆ L₂)

/-- An equivalence of Lie algebras restricts to an equivalence from any Lie subalgebra onto its
image. -/
def of_subalgebra : L₁'' ≃ₗ⁅R⁆ (L₁''.map e : lie_subalgebra R L₂) :=
{ map_lie' := λ x y, by { apply set_coe.ext, exact lie_hom.map_lie (↑e : L₁ →ₗ⁅R⁆ L₂) ↑x ↑y, }
  ..(linear_equiv.of_submodule (e : L₁ ≃ₗ[R] L₂) ↑L₁'') }

@[simp] lemma of_subalgebra_apply (x : L₁'') : ↑(e.of_subalgebra _  x) = e x := rfl

/-- An equivalence of Lie algebras restricts to an equivalence from any Lie subalgebra onto its
image. -/
def of_subalgebras (h : L₁'.map ↑e = L₂') : L₁' ≃ₗ⁅R⁆ L₂' :=
{ map_lie' := λ x y, by { apply set_coe.ext, exact lie_hom.map_lie (↑e : L₁ →ₗ⁅R⁆ L₂) ↑x ↑y, },
  ..(linear_equiv.of_submodules (e : L₁ ≃ₗ[R] L₂) ↑L₁' ↑L₂' (by { rw ←h, refl, })) }

@[simp] lemma of_subalgebras_apply (h : L₁'.map ↑e = L₂') (x : L₁') :
  ↑(e.of_subalgebras _ _ h x) = e x := rfl

@[simp] lemma of_subalgebras_symm_apply (h : L₁'.map ↑e = L₂') (x : L₂') :
  ↑((e.of_subalgebras _ _ h).symm x) = e.symm x := rfl

end lie_equiv


lemma both_and (P Q : Prop) (p : P) (q : Q) : P ∧ Q :=
begin
    split,
    {
        exact p,
    },
    {
        exact q,
    },
end


/-
Copyright (c) 2021 Fox Thomson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Fox Thomson, Yaël Dillies

! This file was ported from Lean 3 source module computability.epsilon_NFA
! leanprover-community/mathlib commit 23aa88e32dcc9d2a24cca7bc23268567ed4cd7d6
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Computability.NFA

/-!
# Epsilon Nondeterministic Finite Automata

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

This file contains the definition of an epsilon Nondeterministic Finite Automaton (`ε_NFA`), a state
machine which determines whether a string (implemented as a list over an arbitrary alphabet) is in a
regular set by evaluating the string over every possible path, also having access to ε-transitons,
which can be followed without reading a character.
Since this definition allows for automata with infinite states, a `fintype` instance must be
supplied for true `ε_NFA`'s.
-/

open Set

open Computability

universe u v

#print εNFA /-
/-- An `ε_NFA` is a set of states (`σ`), a transition function from state to state labelled by the
  alphabet (`step`), a starting state (`start`) and a set of acceptance states (`accept`).
  Note the transition function sends a state to a `set` of states and can make ε-transitions by
  inputing `none`.
  Since this definition allows for Automata with infinite states, a `fintype` instance must be
  supplied for true `ε_NFA`'s.-/
structure εNFA (α : Type u) (σ : Type v) where
  step : σ → Option α → Set σ
  start : Set σ
  accept : Set σ
#align ε_NFA εNFA
-/

variable {α : Type u} {σ σ' : Type v} (M : εNFA α σ) {S : Set σ} {x : List α} {s : σ} {a : α}

namespace εNFA

#print εNFA.εClosure /-
/-- The `ε_closure` of a set is the set of states which can be reached by taking a finite string of
ε-transitions from an element of the set. -/
inductive εClosure (S : Set σ) : Set σ
  | base : ∀ s ∈ S, ε_closure s
  | step : ∀ (s), ∀ t ∈ M.step s none, ε_closure s → ε_closure t
#align ε_NFA.ε_closure εNFA.εClosure
-/

#print εNFA.subset_εClosure /-
@[simp]
theorem subset_εClosure (S : Set σ) : S ⊆ M.εClosure S :=
  εClosure.base
#align ε_NFA.subset_ε_closure εNFA.subset_εClosure
-/

#print εNFA.εClosure_empty /-
@[simp]
theorem εClosure_empty : M.εClosure ∅ = ∅ :=
  eq_empty_of_forall_not_mem fun s hs => by induction' hs with t ht _ _ _ _ ih <;> assumption
#align ε_NFA.ε_closure_empty εNFA.εClosure_empty
-/

#print εNFA.εClosure_univ /-
@[simp]
theorem εClosure_univ : M.εClosure univ = univ :=
  eq_univ_of_univ_subset <| subset_εClosure _ _
#align ε_NFA.ε_closure_univ εNFA.εClosure_univ
-/

#print εNFA.stepSet /-
/-- `M.step_set S a` is the union of the ε-closure of `M.step s a` for all `s ∈ S`. -/
def stepSet (S : Set σ) (a : α) : Set σ :=
  ⋃ s ∈ S, M.εClosure <| M.step s a
#align ε_NFA.step_set εNFA.stepSet
-/

variable {M}

/- warning: ε_NFA.mem_step_set_iff -> εNFA.mem_stepSet_iff is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {σ : Type.{u2}} {M : εNFA.{u1, u2} α σ} {S : Set.{u2} σ} {s : σ} {a : α}, Iff (Membership.Mem.{u2, u2} σ (Set.{u2} σ) (Set.hasMem.{u2} σ) s (εNFA.stepSet.{u1, u2} α σ M S a)) (Exists.{succ u2} σ (fun (t : σ) => Exists.{0} (Membership.Mem.{u2, u2} σ (Set.{u2} σ) (Set.hasMem.{u2} σ) t S) (fun (H : Membership.Mem.{u2, u2} σ (Set.{u2} σ) (Set.hasMem.{u2} σ) t S) => Membership.Mem.{u2, u2} σ (Set.{u2} σ) (Set.hasMem.{u2} σ) s (εNFA.εClosure.{u1, u2} α σ M (εNFA.step.{u1, u2} α σ M t ((fun (a : Type.{u1}) (b : Type.{u1}) [self : HasLiftT.{succ u1, succ u1} a b] => self.0) α (Option.{u1} α) (HasLiftT.mk.{succ u1, succ u1} α (Option.{u1} α) (CoeTCₓ.coe.{succ u1, succ u1} α (Option.{u1} α) (coeOption.{u1} α))) a))))))
but is expected to have type
  forall {α : Type.{u1}} {σ : Type.{u2}} {M : εNFA.{u1, u2} α σ} {S : Set.{u2} σ} {s : σ} {a : α}, Iff (Membership.mem.{u2, u2} σ (Set.{u2} σ) (Set.instMembershipSet.{u2} σ) s (εNFA.stepSet.{u1, u2} α σ M S a)) (Exists.{succ u2} σ (fun (t : σ) => And (Membership.mem.{u2, u2} σ (Set.{u2} σ) (Set.instMembershipSet.{u2} σ) t S) (Membership.mem.{u2, u2} σ (Set.{u2} σ) (Set.instMembershipSet.{u2} σ) s (εNFA.εClosure.{u1, u2} α σ M (εNFA.step.{u1, u2} α σ M t (Option.some.{u1} α a))))))
Case conversion may be inaccurate. Consider using '#align ε_NFA.mem_step_set_iff εNFA.mem_stepSet_iffₓ'. -/
@[simp]
theorem mem_stepSet_iff : s ∈ M.stepSet S a ↔ ∃ t ∈ S, s ∈ M.εClosure (M.step t a) :=
  mem_unionᵢ₂
#align ε_NFA.mem_step_set_iff εNFA.mem_stepSet_iff

#print εNFA.stepSet_empty /-
@[simp]
theorem stepSet_empty (a : α) : M.stepSet ∅ a = ∅ := by simp_rw [step_set, Union_false, Union_empty]
#align ε_NFA.step_set_empty εNFA.stepSet_empty
-/

variable (M)

#print εNFA.evalFrom /-
/-- `M.eval_from S x` computes all possible paths through `M` with input `x` starting at an element
of `S`. -/
def evalFrom (start : Set σ) : List α → Set σ :=
  List.foldl M.stepSet (M.εClosure start)
#align ε_NFA.eval_from εNFA.evalFrom
-/

#print εNFA.evalFrom_nil /-
@[simp]
theorem evalFrom_nil (S : Set σ) : M.evalFrom S [] = M.εClosure S :=
  rfl
#align ε_NFA.eval_from_nil εNFA.evalFrom_nil
-/

#print εNFA.evalFrom_singleton /-
@[simp]
theorem evalFrom_singleton (S : Set σ) (a : α) : M.evalFrom S [a] = M.stepSet (M.εClosure S) a :=
  rfl
#align ε_NFA.eval_from_singleton εNFA.evalFrom_singleton
-/

#print εNFA.evalFrom_append_singleton /-
@[simp]
theorem evalFrom_append_singleton (S : Set σ) (x : List α) (a : α) :
    M.evalFrom S (x ++ [a]) = M.stepSet (M.evalFrom S x) a := by
  simp only [eval_from, List.foldl_append, List.foldl_cons, List.foldl_nil]
#align ε_NFA.eval_from_append_singleton εNFA.evalFrom_append_singleton
-/

#print εNFA.evalFrom_empty /-
@[simp]
theorem evalFrom_empty (x : List α) : M.evalFrom ∅ x = ∅ :=
  by
  induction' x using List.reverseRecOn with x a ih
  · rw [eval_from_nil, ε_closure_empty]
  · rw [eval_from_append_singleton, ih, step_set_empty]
#align ε_NFA.eval_from_empty εNFA.evalFrom_empty
-/

#print εNFA.eval /-
/-- `M.eval x` computes all possible paths through `M` with input `x` starting at an element of
`M.start`. -/
def eval :=
  M.evalFrom M.start
#align ε_NFA.eval εNFA.eval
-/

#print εNFA.eval_nil /-
@[simp]
theorem eval_nil : M.eval [] = M.εClosure M.start :=
  rfl
#align ε_NFA.eval_nil εNFA.eval_nil
-/

#print εNFA.eval_singleton /-
@[simp]
theorem eval_singleton (a : α) : M.eval [a] = M.stepSet (M.εClosure M.start) a :=
  rfl
#align ε_NFA.eval_singleton εNFA.eval_singleton
-/

#print εNFA.eval_append_singleton /-
@[simp]
theorem eval_append_singleton (x : List α) (a : α) : M.eval (x ++ [a]) = M.stepSet (M.eval x) a :=
  evalFrom_append_singleton _ _ _ _
#align ε_NFA.eval_append_singleton εNFA.eval_append_singleton
-/

#print εNFA.accepts /-
/-- `M.accepts` is the language of `x` such that there is an accept state in `M.eval x`. -/
def accepts : Language α :=
  { x | ∃ S ∈ M.accept, S ∈ M.eval x }
#align ε_NFA.accepts εNFA.accepts
-/

/-! ### Conversions between `ε_NFA` and `NFA` -/

#print εNFA.toNFA /-
/-- `M.to_NFA` is an `NFA` constructed from an `ε_NFA` `M`. -/
def toNFA : NFA α σ where
  step S a := M.εClosure (M.step S a)
  start := M.εClosure M.start
  accept := M.accept
#align ε_NFA.to_NFA εNFA.toNFA
-/

#print εNFA.toNFA_evalFrom_match /-
@[simp]
theorem toNFA_evalFrom_match (start : Set σ) :
    M.toNFA.evalFrom (M.εClosure start) = M.evalFrom start :=
  rfl
#align ε_NFA.to_NFA_eval_from_match εNFA.toNFA_evalFrom_match
-/

#print εNFA.toNFA_correct /-
@[simp]
theorem toNFA_correct : M.toNFA.accepts = M.accepts :=
  by
  ext x
  rw [accepts, NFA.accepts, eval, NFA.eval, ← to_NFA_eval_from_match]
  rfl
#align ε_NFA.to_NFA_correct εNFA.toNFA_correct
-/

/- warning: ε_NFA.pumping_lemma -> εNFA.pumping_lemma is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {σ : Type.{u2}} (M : εNFA.{u1, u2} α σ) [_inst_1 : Fintype.{u2} σ] {x : List.{u1} α}, (Membership.Mem.{u1, u1} (List.{u1} α) (Language.{u1} α) (Language.hasMem.{u1} α) x (εNFA.accepts.{u1, u2} α σ M)) -> (LE.le.{0} Nat Nat.hasLe (Fintype.card.{u2} (Set.{u2} σ) (Set.fintype.{u2} σ _inst_1)) (List.length.{u1} α x)) -> (Exists.{succ u1} (List.{u1} α) (fun (a : List.{u1} α) => Exists.{succ u1} (List.{u1} α) (fun (b : List.{u1} α) => Exists.{succ u1} (List.{u1} α) (fun (c : List.{u1} α) => And (Eq.{succ u1} (List.{u1} α) x (Append.append.{u1} (List.{u1} α) (List.hasAppend.{u1} α) (Append.append.{u1} (List.{u1} α) (List.hasAppend.{u1} α) a b) c)) (And (LE.le.{0} Nat Nat.hasLe (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) (List.length.{u1} α a) (List.length.{u1} α b)) (Fintype.card.{u2} (Set.{u2} σ) (Set.fintype.{u2} σ _inst_1))) (And (Ne.{succ u1} (List.{u1} α) b (List.nil.{u1} α)) (LE.le.{u1} (Language.{u1} α) (Preorder.toLE.{u1} (Language.{u1} α) (PartialOrder.toPreorder.{u1} (Language.{u1} α) (CompleteSemilatticeInf.toPartialOrder.{u1} (Language.{u1} α) (CompleteLattice.toCompleteSemilatticeInf.{u1} (Language.{u1} α) (Order.Coframe.toCompleteLattice.{u1} (Language.{u1} α) (CompleteDistribLattice.toCoframe.{u1} (Language.{u1} α) (CompleteBooleanAlgebra.toCompleteDistribLattice.{u1} (Language.{u1} α) (Language.completeBooleanAlgebra.{u1} α)))))))) (HMul.hMul.{u1, u1, u1} (Language.{u1} α) (Language.{u1} α) (Language.{u1} α) (instHMul.{u1} (Language.{u1} α) (Language.hasMul.{u1} α)) (HMul.hMul.{u1, u1, u1} (Language.{u1} α) (Language.{u1} α) (Language.{u1} α) (instHMul.{u1} (Language.{u1} α) (Language.hasMul.{u1} α)) (Singleton.singleton.{u1, u1} (List.{u1} α) (Language.{u1} α) (Language.hasSingleton.{u1} α) a) (KStar.kstar.{u1} (Language.{u1} α) (Language.hasKstar.{u1} α) (Singleton.singleton.{u1, u1} (List.{u1} α) (Language.{u1} α) (Language.hasSingleton.{u1} α) b))) (Singleton.singleton.{u1, u1} (List.{u1} α) (Language.{u1} α) (Language.hasSingleton.{u1} α) c)) (εNFA.accepts.{u1, u2} α σ M))))))))
but is expected to have type
  forall {α : Type.{u1}} {σ : Type.{u2}} (M : εNFA.{u1, u2} α σ) [_inst_1 : Fintype.{u2} σ] {x : List.{u1} α}, (Membership.mem.{u1, u1} (List.{u1} α) (Language.{u1} α) (instMembershipListLanguage.{u1} α) x (εNFA.accepts.{u1, u2} α σ M)) -> (LE.le.{0} Nat instLENat (Fintype.card.{u2} (Set.{u2} σ) (Set.fintype.{u2} σ _inst_1)) (List.length.{u1} α x)) -> (Exists.{succ u1} (List.{u1} α) (fun (a : List.{u1} α) => Exists.{succ u1} (List.{u1} α) (fun (b : List.{u1} α) => Exists.{succ u1} (List.{u1} α) (fun (c : List.{u1} α) => And (Eq.{succ u1} (List.{u1} α) x (HAppend.hAppend.{u1, u1, u1} (List.{u1} α) (List.{u1} α) (List.{u1} α) (instHAppend.{u1} (List.{u1} α) (List.instAppendList.{u1} α)) (HAppend.hAppend.{u1, u1, u1} (List.{u1} α) (List.{u1} α) (List.{u1} α) (instHAppend.{u1} (List.{u1} α) (List.instAppendList.{u1} α)) a b) c)) (And (LE.le.{0} Nat instLENat (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) (List.length.{u1} α a) (List.length.{u1} α b)) (Fintype.card.{u2} (Set.{u2} σ) (Set.fintype.{u2} σ _inst_1))) (And (Ne.{succ u1} (List.{u1} α) b (List.nil.{u1} α)) (LE.le.{u1} (Language.{u1} α) (Preorder.toLE.{u1} (Language.{u1} α) (PartialOrder.toPreorder.{u1} (Language.{u1} α) (CompleteSemilatticeInf.toPartialOrder.{u1} (Language.{u1} α) (CompleteLattice.toCompleteSemilatticeInf.{u1} (Language.{u1} α) (Order.Coframe.toCompleteLattice.{u1} (Language.{u1} α) (CompleteDistribLattice.toCoframe.{u1} (Language.{u1} α) (CompleteBooleanAlgebra.toCompleteDistribLattice.{u1} (Language.{u1} α) (instCompleteBooleanAlgebraLanguage.{u1} α)))))))) (HMul.hMul.{u1, u1, u1} (Language.{u1} α) (Language.{u1} α) (Language.{u1} α) (instHMul.{u1} (Language.{u1} α) (Language.instMulLanguage.{u1} α)) (HMul.hMul.{u1, u1, u1} (Language.{u1} α) (Language.{u1} α) (Language.{u1} α) (instHMul.{u1} (Language.{u1} α) (Language.instMulLanguage.{u1} α)) (Singleton.singleton.{u1, u1} (List.{u1} α) (Language.{u1} α) (instSingletonListLanguage.{u1} α) a) (KStar.kstar.{u1} (Language.{u1} α) (Language.instKStarLanguage.{u1} α) (Singleton.singleton.{u1, u1} (List.{u1} α) (Language.{u1} α) (instSingletonListLanguage.{u1} α) b))) (Singleton.singleton.{u1, u1} (List.{u1} α) (Language.{u1} α) (instSingletonListLanguage.{u1} α) c)) (εNFA.accepts.{u1, u2} α σ M))))))))
Case conversion may be inaccurate. Consider using '#align ε_NFA.pumping_lemma εNFA.pumping_lemmaₓ'. -/
theorem pumping_lemma [Fintype σ] {x : List α} (hx : x ∈ M.accepts)
    (hlen : Fintype.card (Set σ) ≤ List.length x) :
    ∃ a b c,
      x = a ++ b ++ c ∧
        a.length + b.length ≤ Fintype.card (Set σ) ∧ b ≠ [] ∧ {a} * {b}∗ * {c} ≤ M.accepts :=
  by
  rw [← to_NFA_correct] at hx⊢
  exact M.to_NFA.pumping_lemma hx hlen
#align ε_NFA.pumping_lemma εNFA.pumping_lemma

end εNFA

namespace NFA

#print NFA.toεNFA /-
/-- `M.to_ε_NFA` is an `ε_NFA` constructed from an `NFA` `M` by using the same start and accept
  states and transition functions. -/
def toεNFA (M : NFA α σ) : εNFA α σ
    where
  step s a := a.casesOn' ∅ fun a => M.step s a
  start := M.start
  accept := M.accept
#align NFA.to_ε_NFA NFA.toεNFA
-/

#print NFA.toεNFA_εClosure /-
@[simp]
theorem toεNFA_εClosure (M : NFA α σ) (S : Set σ) : M.toεNFA.εClosure S = S :=
  by
  ext a
  refine' ⟨_, εNFA.εClosure.base _⟩
  rintro (⟨_, h⟩ | ⟨_, _, h, _⟩)
  · exact h
  · cases h
#align NFA.to_ε_NFA_ε_closure NFA.toεNFA_εClosure
-/

#print NFA.toεNFA_evalFrom_match /-
@[simp]
theorem toεNFA_evalFrom_match (M : NFA α σ) (start : Set σ) :
    M.toεNFA.evalFrom start = M.evalFrom start :=
  by
  rw [eval_from, εNFA.evalFrom, to_ε_NFA_ε_closure]
  congr
  ext (S s)
  simp only [step_set, εNFA.stepSet, exists_prop, Set.mem_unionᵢ]
  apply exists_congr
  simp only [and_congr_right_iff]
  intro t ht
  rw [M.to_ε_NFA_ε_closure]
  rfl
#align NFA.to_ε_NFA_eval_from_match NFA.toεNFA_evalFrom_match
-/

#print NFA.toεNFA_correct /-
@[simp]
theorem toεNFA_correct (M : NFA α σ) : M.toεNFA.accepts = M.accepts :=
  by
  rw [accepts, εNFA.accepts, eval, εNFA.eval, to_ε_NFA_eval_from_match]
  rfl
#align NFA.to_ε_NFA_correct NFA.toεNFA_correct
-/

end NFA

/-! ### Regex-like operations -/

namespace εNFA

instance : Zero (εNFA α σ) :=
  ⟨⟨fun _ _ => ∅, ∅, ∅⟩⟩

instance : One (εNFA α σ) :=
  ⟨⟨fun _ _ => ∅, univ, univ⟩⟩

instance : Inhabited (εNFA α σ) :=
  ⟨0⟩

variable (P : εNFA α σ) (Q : εNFA α σ')

#print εNFA.step_zero /-
@[simp]
theorem step_zero (s a) : (0 : εNFA α σ).step s a = ∅ :=
  rfl
#align ε_NFA.step_zero εNFA.step_zero
-/

#print εNFA.step_one /-
@[simp]
theorem step_one (s a) : (1 : εNFA α σ).step s a = ∅ :=
  rfl
#align ε_NFA.step_one εNFA.step_one
-/

#print εNFA.start_zero /-
@[simp]
theorem start_zero : (0 : εNFA α σ).start = ∅ :=
  rfl
#align ε_NFA.start_zero εNFA.start_zero
-/

#print εNFA.start_one /-
@[simp]
theorem start_one : (1 : εNFA α σ).start = univ :=
  rfl
#align ε_NFA.start_one εNFA.start_one
-/

#print εNFA.accept_zero /-
@[simp]
theorem accept_zero : (0 : εNFA α σ).accept = ∅ :=
  rfl
#align ε_NFA.accept_zero εNFA.accept_zero
-/

#print εNFA.accept_one /-
@[simp]
theorem accept_one : (1 : εNFA α σ).accept = univ :=
  rfl
#align ε_NFA.accept_one εNFA.accept_one
-/

end εNFA


/-
Copyright (c) 2019 Scott Morrison All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import control.equiv_functor
import category_theory.groupoid
import category_theory.whiskering
import category_theory.types

/-!
# The core of a category

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

The core of a category `C` is the (non-full) subcategory of `C` consisting of all objects,
and all isomorphisms. We construct it as a `groupoid`.

`core.inclusion : core C ⥤ C` gives the faithful inclusion into the original category.

Any functor `F` from a groupoid `G` into `C` factors through `core C`,
but this is not functorial with respect to `F`.
-/

namespace category_theory

universes v₁ v₂ u₁ u₂ -- morphism levels before object levels. See note [category_theory universes].

/-- The core of a category C is the groupoid whose morphisms are all the
isomorphisms of C. -/
@[nolint has_nonempty_instance]
def core (C : Type u₁) := C

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

instance core_category : groupoid.{v₁} (core C) :=
{ hom  := λ X Y : C, X ≅ Y,
  inv  := λ X Y f, iso.symm f,
  id   := λ X, iso.refl X,
  comp := λ X Y Z f g, iso.trans f g }

namespace core
@[simp] lemma id_hom (X : core C) : iso.hom (𝟙 X) = 𝟙 X := rfl
@[simp] lemma comp_hom {X Y Z : core C} (f : X ⟶ Y) (g : Y ⟶ Z) : (f ≫ g).hom = f.hom ≫ g.hom :=
rfl

variables (C)

/-- The core of a category is naturally included in the category. -/
def inclusion : core C ⥤ C :=
{ obj := id,
  map := λ X Y f, f.hom }

instance : faithful (inclusion C) := {}

variables {C} {G : Type u₂} [groupoid.{v₂} G]

/-- A functor from a groupoid to a category C factors through the core of C. -/
-- Note that this function is not functorial
-- (consider the two functors from [0] to [1], and the natural transformation between them).
noncomputable
def functor_to_core (F : G ⥤ C) : G ⥤ core C :=
{ obj := λ X, F.obj X,
  map := λ X Y f, ⟨F.map f, F.map (inv f)⟩ }

/--
We can functorially associate to any functor from a groupoid to the core of a category `C`,
a functor from the groupoid to `C`, simply by composing with the embedding `core C ⥤ C`.
-/
def forget_functor_to_core : (G ⥤ core C) ⥤ (G ⥤ C) := (whiskering_right _ _ _).obj (inclusion C)
end core

/--
`of_equiv_functor m` lifts a type-level `equiv_functor`
to a categorical functor `core (Type u₁) ⥤ core (Type u₂)`.
-/
def of_equiv_functor (m : Type u₁ → Type u₂) [equiv_functor m] :
  core (Type u₁) ⥤ core (Type u₂) :=
{ obj       := m,
  map       := λ α β f, (equiv_functor.map_equiv m f.to_equiv).to_iso,
  -- These are not very pretty.
  map_id' := λ α, begin ext, exact (congr_fun (equiv_functor.map_refl _) x), end,
  map_comp' := λ α β γ f g,
  begin
    ext,
    simp only [equiv_functor.map_equiv_apply, equiv.to_iso_hom,
      function.comp_app, core.comp_hom, types_comp],
    erw [iso.to_equiv_comp, equiv_functor.map_trans],
  end, }

end category_theory


/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import tactic.fresh_names
import category_theory.concrete_category

/-!
# Tools to reformulate category-theoretic lemmas in concrete categories

## The `elementwise` attribute

The `elementwise` attribute can be applied to a lemma

```lean
@[elementwise]
lemma some_lemma {C : Type*} [category C]
  {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) (h : X ⟶ Z) (w : ...) : f ≫ g = h := ...
```

and will produce

```lean
lemma some_lemma_apply {C : Type*} [category C] [concrete_category C]
  {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) (h : X ⟶ Z) (w : ...) (x : X) : g (f x) = h x := ...
```

Here `X` is being coerced to a type via `concrete_category.has_coe_to_sort` and
`f`, `g`, and `h` are being coerced to functions via `concrete_category.has_coe_to_fun`.
Further, we simplify the type using `concrete_category.coe_id : ((𝟙 X) : X → X) x = x` and
`concrete_category.coe_comp : (f ≫ g) x = g (f x)`,
replacing morphism composition with function composition.

The name of the produced lemma can be specified with `@[elementwise other_lemma_name]`.
If `simp` is added first, the generated lemma will also have the `simp` attribute.

## Implementation

This closely follows the implementation of the `@[reassoc]` attribute, due to Simon Hudon.
Thanks to Gabriel Ebner for help diagnosing universe issues.

-/

namespace tactic

open interactive lean.parser category_theory

/--
From an expression `f = g`,
where `f g : X ⟶ Y` for some objects `X Y : V` with `[S : category V]`,
extract the expression for `S`.
-/
meta def extract_category : expr → tactic expr
| `(@eq (@quiver.hom ._ (@category_struct.to_quiver _
     (@category.to_category_struct _ %%S)) _ _) _ _) := pure S
| _ := failed

/-- (internals for `@[elementwise]`)
Given a lemma of the form `f = g`, where `f g : X ⟶ Y` and `X Y : V`,
proves a new lemma of the form
`∀ (x : X), f x = g x`
if we are already in a concrete category, or
`∀ [concrete_category.{w} V] (x : X), f x = g x`
otherwise.

Returns the type and proof of this lemma,
and the universe parameter `w` for the `concrete_category` instance, if it was not synthesized.
-/
-- This is closely modelled on `reassoc_axiom`.
meta def prove_elementwise (h : expr) : tactic (expr × expr × option name) :=
do
   (vs,t) ← infer_type h >>= open_pis,
   (f, g) ← match_eq t,
   S ← extract_category t <|> fail "no morphism equation found in statement",
   `(@quiver.hom _ %%H %%X %%Y) ← infer_type f,
   C ← infer_type X,
   CC_type ← to_expr ``(@concrete_category %%C %%S),
   (CC, CC_found) ← (do CC ← mk_instance CC_type, pure (CC, tt)) <|>
     (do CC ← mk_local' `I binder_info.inst_implicit CC_type, pure (CC, ff)),
   -- This is need to fill in universe levels fixed by `mk_instance`:
   CC_type ← instantiate_mvars CC_type,
   x_type ← to_expr ``(@coe_sort %%C
     (@category_theory.concrete_category.has_coe_to_sort %%C %%S %%CC) %%X),
   x ← mk_local_def `x x_type,
   t' ← to_expr ``(@coe_fn (@quiver.hom %%C %%H %%X %%Y)
     (@category_theory.concrete_category.has_coe_to_fun %%C %%S %%CC %%X %%Y) %%f %%x =
       @coe_fn (@quiver.hom %%C %%H %%X %%Y)
         (@category_theory.concrete_category.has_coe_to_fun %%C %%S %%CC %%X %%Y) %%g %%x),
   let c' := h.mk_app vs,
   (_,pr) ← solve_aux t' (rewrite_target c'; reflexivity),
   -- The codomain of forget lives in a new universe, which may be now a universe metavariable
   -- if we didn't synthesize an instance:
   [w, _, _] ← pure CC_type.get_app_fn.univ_levels,
   -- We unify that with a fresh universe parameter.
   n ← match w with
   | level.mvar _ := (do
      n ← get_unused_name_reserved [`w] mk_name_set,
      unify (expr.sort (level.param n)) (expr.sort w),
      pure (option.some n))
   | _ := pure option.none
   end,
   t' ← instantiate_mvars t',
   CC ← instantiate_mvars CC,
   x ← instantiate_mvars x,
   -- Now the key step: replace morphism composition with function composition,
   -- and identity morphisms with nothing.
   let s := simp_lemmas.mk,
   s ← s.add_simp ``coe_id,
   s ← s.add_simp ``coe_comp,
   (t'', pr', _) ← simplify s [] t' {fail_if_unchanged := ff},
   pr' ← mk_eq_mp pr' pr,
   -- Further, if we're in `Type`, get rid of the coercions entirely.
   let s := simp_lemmas.mk,
   s ← s.add_simp ``concrete_category.has_coe_to_fun_Type,
   (t'', pr'', _) ← simplify s [] t'' {fail_if_unchanged := ff},
   pr'' ← mk_eq_mp pr'' pr',
   t'' ← pis (vs ++ (if CC_found then [x] else [CC, x])) t'',
   pr'' ← lambdas (vs ++ (if CC_found then [x] else [CC, x])) pr'',
   pure (t'', pr'', n)

/-- (implementation for `@[elementwise]`)
Given a declaration named `n` of the form `∀ ..., f = g`, proves a new lemma named `n'`
of the form `∀ ... [concrete_category V] (x : X), f x = g x`.
-/
meta def elementwise_lemma (n : name) (n' : name := n.append_suffix "_apply") : tactic unit :=
do d ← get_decl n,
   let c := @expr.const tt n d.univ_levels,
   (t'',pr',l') ← prove_elementwise c,
   let params := l'.to_list ++ d.univ_params,
   add_decl $ declaration.thm n' params t'' (pure pr'),
   copy_attribute `simp n n'

/--
The `elementwise` attribute can be applied to a lemma

```lean
@[elementwise]
lemma some_lemma {C : Type*} [category C]
  {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) (h : X ⟶ Z) (w : ...) : f ≫ g = h := ...
```

and will produce

```lean
lemma some_lemma_apply {C : Type*} [category C] [concrete_category C]
  {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) (h : X ⟶ Z) (w : ...) (x : X) : g (f x) = h x := ...
```

Here `X` is being coerced to a type via `concrete_category.has_coe_to_sort` and
`f`, `g`, and `h` are being coerced to functions via `concrete_category.has_coe_to_fun`.
Further, we simplify the type using `concrete_category.coe_id : ((𝟙 X) : X → X) x = x` and
`concrete_category.coe_comp : (f ≫ g) x = g (f x)`,
replacing morphism composition with function composition.

The `[concrete_category C]` argument will be omitted if it is possible to synthesize an instance.

The name of the produced lemma can be specified with `@[elementwise other_lemma_name]`.
If `simp` is added first, the generated lemma will also have the `simp` attribute.
-/
@[user_attribute]
meta def elementwise_attr : user_attribute unit (option name) :=
{ name := `elementwise,
  descr := "create a companion lemma for a morphism equation applied to an element",
  parser := optional ident,
  after_set := some (λ n _ _,
    do some n' ← elementwise_attr.get_param n | elementwise_lemma n (n.append_suffix "_apply"),
       elementwise_lemma n $ n.get_prefix ++ n' ) }

add_tactic_doc
{ name                     := "elementwise",
  category                 := doc_category.attr,
  decl_names               := [`tactic.elementwise_attr],
  tags                     := ["category theory"] }

namespace interactive

setup_tactic_parser

/--
`elementwise h`, for assumption `w : ∀ ..., f ≫ g = h`, creates a new assumption
`w : ∀ ... (x : X), g (f x) = h x`.

`elementwise! h`, does the same but deletes the initial `h` assumption.
(You can also add the attribute `@[elementwise]` to lemmas to generate new declarations generalized
in this way.)
-/
meta def elementwise (del : parse (tk "!")?) (ns : parse ident*) : tactic unit :=
do ns.mmap' (λ n,
   do h ← get_local n,
      (t,pr,u) ← prove_elementwise h,
      assertv n t pr,
      when del.is_some (tactic.clear h) )

end interactive

/-- Auxiliary definition for `category_theory.elementwise_of`. -/
meta def derive_elementwise_proof : tactic unit :=
do `(calculated_Prop %%v %%h) ← target,
   (t,pr,n) ← prove_elementwise h,
   unify v t,
   exact pr

end tactic

/--
With `w : ∀ ..., f ≫ g = h` (with universal quantifiers tolerated),
`elementwise_of w : ∀ ... (x : X), g (f x) = h x`.

The type and proof of `elementwise_of h` is generated by `tactic.derive_elementwise_proof`
which makes `elementwise_of` meta-programming adjacent. It is not called as a tactic but as
an expression. The goal is to avoid creating assumptions that are dismissed after one use:

```lean
example (M N K : Mon.{u}) (f : M ⟶ N) (g : N ⟶ K) (h : M ⟶ K) (w : f ≫ g = h) (m : M) :
  g (f m) = h m :=
begin
  rw elementwise_of w,
end
```
-/
theorem category_theory.elementwise_of {α} (hh : α) {β}
  (x : tactic.calculated_Prop β hh . tactic.derive_elementwise_proof) : β := x

/--
With `w : ∀ ..., f ≫ g = h` (with universal quantifiers tolerated),
`elementwise_of w : ∀ ... (x : X), g (f x) = h x`.

Although `elementwise_of` is not a tactic or a meta program, its type is generated
through meta-programming to make it usable inside normal expressions.
-/
add_tactic_doc
{ name                     := "category_theory.elementwise_of",
  category                 := doc_category.tactic,
  decl_names               := [`category_theory.elementwise_of],
  tags                     := ["category theory"] }


-- Copyright 2022-2023 VMware, Inc.
-- SPDX-License-Identifier: BSD-2-Clause

import .stream
import .linear
import .incremental
import tactic.abel
import init.classical

section zero.
variables {a: Type} [has_zero a].

def δ0 (x:a) : stream a :=
  λ t, if t = 0 then x else 0.

@[simp]
lemma δ0_apply (x: a) (n: ℕ) :
  δ0 x n = if n = 0 then x else 0
  := rfl.

@[simp]
lemma δ0_0 : δ0 (0: a) = 0 :=
begin
  ext n, simp,
end

def zero_after (s: stream a) (n: ℕ) := ∀ t ≥ n, s t = 0.

lemma zero_after_ge {s: stream a} {n1: ℕ} (pf1: zero_after s n1) :
  ∀ n2 ≥ n1, zero_after s n2 :=
begin
  intros n2 hge,
  intros m hge2,
  apply pf1, omega,
end

def δ0_zero_after (x:a) : zero_after (δ0 x) 1 :=
begin
  intros t hge, unfold δ0, rw if_neg, omega
end
end zero.

variables {a: Type} [add_comm_group a].

def drop (k: ℕ) (s: stream a) : stream a :=
  λ n, s (k + n).

lemma sum_vals_split (s: stream a) (n k: ℕ) :
  sum_vals s (n + k) = sum_vals s n + sum_vals (drop n s) k :=
begin
  revert n,
  induction k; introv,
  { simp, },
  { change (n + k_n.succ) with (n + k_n).succ,
    unfold sum_vals,
    rw k_ih,
    abel, }
end

lemma sum_vals_zero_ge (s: stream a) (n m:ℕ) (hz: zero_after s n) (hge: m ≥ n) :
  sum_vals s n = sum_vals s m :=
begin
  have h := sum_vals_split s n (m - n),
  have hdiff : m = n + (m - n) := by omega,
  rw [hdiff, h],
  rw sum_vals_zero (drop _ _), abel,
  intros t, unfold drop, apply hz, omega,
end

lemma sum_vals_eq_helper (s: stream a) (n1 n2: ℕ) (hz1: zero_after s n1) (hz2: zero_after s n2) :
  n1 ≤ n2 →
  sum_vals s n1 = sum_vals s n2 :=
begin
  intros hle,
  rw sum_vals_zero_ge,
  assumption,
  omega,
end

lemma sum_vals_eq (s: stream a) (n1 n2: ℕ) (hz1: zero_after s n1) (hz2: zero_after s n2) :
  sum_vals s n1 = sum_vals s n2 :=
begin
  by_cases (n1 ≤ n2),
  { rw sum_vals_eq_helper; assumption, },
  { symmetry, rw sum_vals_eq_helper; try { assumption }, omega, },
end

noncomputable def stream_elim (s: stream a) : a :=
  match classical.prop_decidable (∃ n, zero_after s n) with
  | decidable.is_true h := sum_vals s (classical.some h)
  | decidable.is_false _ := 0
  end.

lemma stream_elim_zero_after (s: stream a) (n:ℕ) (pf:zero_after s n) :
  stream_elim s = sum_vals s n :=
begin
  unfold stream_elim,
  cases (classical.prop_decidable _),
  { exfalso,
    apply h, use n, assumption,
  },
  { unfold stream_elim._match_1,
    apply sum_vals_eq,
    {  apply classical.some_spec h, },
    { assumption, },
  }
end

notation `∫ ` := stream_elim.

@[simp]
lemma stream_elim_0 : ∫ (0: stream a) = 0 :=
begin
  rw stream_elim_zero_after _ 0,
  { simp, },
  { intros t heq, simp, },
end

theorem stream_elim_delta (x: a) :
  ∫ (δ0 x) = x :=
begin
  rw stream_elim_zero_after _ 1,
  simp,
  apply δ0_zero_after,
end

theorem delta_linear :
  ∀ (x y: a), δ0 (x + y) = δ0 x + δ0 y :=
begin
  introv,
  ext t, simp,
  split_ifs; simp,
end

@[simp]
lemma delta_incremental :
  ↑↑(@δ0 a _)^Δ = ↑↑δ0 :=
begin
  apply lti_incremental,
  apply lifting_lti,
  apply delta_linear,
end

lemma sum_vals_linear (s1 s2: stream a) (n: ℕ) :
  sum_vals (s1 + s2) n = sum_vals s1 n + sum_vals s2 n :=
begin
  induction n; simp,
  rw n_ih, abel,
end

lemma sum_zero_after {s1 s2: stream a}
  {n1: ℕ} (pf1: zero_after s1 n1) {n2: ℕ} (pf2: zero_after s2 n2) :
  zero_after (s1 + s2) (if n1 ≥ n2 then n1 else n2) :=
begin
  split_ifs,
  { intros m hge, simp,
    rw pf1, swap, omega,
    rw pf2, swap, omega,
    simp,
  },
  { intros m hge, simp,
    rw pf1, swap, omega,
    rw pf2, swap, omega,
    simp,
  },
end

lemma sub_zero_after {s1 s2: stream a}
  {n1: ℕ} (pf1: zero_after s1 n1) {n2: ℕ} (pf2: zero_after s2 n2) :
  zero_after (s1 - s2) (if n1 ≥ n2 then n1 else n2) :=
begin
  split_ifs,
  { intros m hge, simp,
    rw pf1, swap, omega,
    rw pf2, swap, omega,
    simp,
  },
  { intros m hge, simp,
    rw pf1, swap, omega,
    rw pf2, swap, omega,
    simp,
  },
end

theorem stream_elim_linear (s1 s2: stream a)
  (n1: ℕ) (pf1: zero_after s1 n1) (n2: ℕ) (pf2: zero_after s2 n2) :
  ∫ (s1 + s2) = ∫ s1 + ∫ s2 :=
begin
  rw (stream_elim_zero_after s1 _ pf1),
  rw (stream_elim_zero_after s2 _ pf2),
  rw (stream_elim_zero_after _ _ (sum_zero_after pf1 pf2)),
  simp,

  generalize hmax : (if n2 ≤ n1 then n1 else n2) = max,

  have hmax1 : max ≥ n1 := by { subst hmax, split_ifs; omega },
  have hmax2 : max ≥ n2 := by { subst hmax, split_ifs; omega },
  rw (sum_vals_zero_ge s1 _ max pf1), swap, omega,
  rw (sum_vals_zero_ge s2 _ max pf2), swap, omega,

  apply sum_vals_linear,
end

lemma stream_elim_time_invariant :
  time_invariant ↑↑(@stream_elim a _) :=
begin
  apply lifting_time_invariant, simp,
end

lemma integral_zero (s: stream a) (n: ℕ) :
  zero_after (I s) n → zero_after s n.succ :=
begin
  intros hz,
  intros m hge,
  have hm := hz m (by omega),
  rw integral_unfold at hm, simp at hm,
  have hm' : z⁻¹ (I s) m = I s (m - 1) := by {
    unfold delay, rw if_neg, omega,
  },
  rw hm' at hm,
  rw (hz (m - 1)) at hm,
  abel at hm, assumption,
  omega,
end

lemma integral_nested_unfold (s: stream (stream a)) (t: ℕ) :
  0 < t →
  I s t = s t + I s (t-1) :=
begin
  intros hnz,
  conv_lhs {
    rw integral_unfold, simp,
  },
  simp,
  rw delay_sub_1, omega,
end

lemma integral_zero' (s: stream (stream a)) (t n: ℕ) :
  zero_after (I s t) n →
  zero_after (I s (t-1)) n →
  zero_after (s t) n.succ :=
begin
  by_cases (t = 0),
  { subst t, simp, intros hz _hz',
    apply (zero_after_ge hz), omega, },
  intros hz hz',
  intros m hge,
  transitivity (D (I s) t m),
  { simp, },
  unfold D, simp,
  rw (hz m), swap, omega,
  rw delay_sub_1, swap, omega,
  rw (hz' m), swap, omega,
  abel,
end

-- stream_elim_incremental is not provable
example {a: Type} [add_comm_group a] : true :=
begin
  have h : ↑↑(@stream_elim a _)^Δ = ↑↑stream_elim := by {
    unfold incremental,
    funext s,
    unfold D,
    funext t, simp,
    by_cases ht : (t = 0),
    { subst t, simp, },
    rw delay_sub_1, swap, omega, simp,
    -- this is not true: ∫ (I s t) might converge while ∫ (I s (t-1)) diverges and
    -- ∫ (s t) converges for example. What does seem true is that if both
    -- integrals on the left hand side converge, then the right-hand side
    -- converges and the equality holds.
    by_cases (∃ n, zero_after (I s t) n),
    { cases h with n hz,
      sorry,
    },
    -- this doesn't seem true
    sorry,
  },
  trivial,
end

lemma integral_delta (x:a) :
  I (δ0 x) = λ _n, x :=
begin
  ext t,
  induction t,
  { simp, },
  { rw integral_unfold, simp, assumption, }
end

@[simp]
lemma integral_delta_apply (x:a) (n:ℕ) :
  I (δ0 x) n = x :=
begin
  rw integral_delta,
end

variables {b: Type} [add_comm_group b].

lemma nested_zpp (Q: operator a b) :
  time_invariant Q → ∫ (Q (δ0 0)) = 0 :=
begin
  intros hti,
  rw δ0_0,
  rw time_invariant_zpp _ hti,
  rw stream_elim_0,
end


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon, Patrick Massot, Eric Wieser
-/
import algebra.group.prod
import group_theory.group_action.defs

/-!
# Prod instances for additive and multiplicative actions

This file defines instances for binary product of additive and multiplicative actions and provides
scalar multiplication as a homomorphism from `α × β` to `β`.

## Main declarations

* `smul_mul_hom`/`smul_monoid_hom`: Scalar multiplication bundled as a multiplicative/monoid
  homomorphism.
-/

variables {M N P α β : Type*}

namespace prod

section

variables [has_scalar M α] [has_scalar M β] [has_scalar N α] [has_scalar N β] (a : M) (x : α × β)

@[to_additive prod.has_vadd] instance : has_scalar M (α × β) := ⟨λa p, (a • p.1, a • p.2)⟩

@[simp, to_additive] theorem smul_fst : (a • x).1 = a • x.1 := rfl
@[simp, to_additive] theorem smul_snd : (a • x).2 = a • x.2 := rfl
@[simp, to_additive] theorem smul_mk (a : M) (b : α) (c : β) : a • (b, c) = (a • b, a • c) := rfl
@[to_additive] theorem smul_def (a : M) (x : α × β) : a • x = (a • x.1, a • x.2) := rfl
@[simp, to_additive] theorem smul_swap : (a • x).swap = a • x.swap := rfl

instance [has_scalar M N] [is_scalar_tower M N α] [is_scalar_tower M N β] :
  is_scalar_tower M N (α × β) :=
⟨λ x y z, mk.inj_iff.mpr ⟨smul_assoc _ _ _, smul_assoc _ _ _⟩⟩

@[to_additive] instance [smul_comm_class M N α] [smul_comm_class M N β] :
  smul_comm_class M N (α × β) :=
{ smul_comm := λ r s x, mk.inj_iff.mpr ⟨smul_comm _ _ _, smul_comm _ _ _⟩ }

instance [has_scalar Mᵐᵒᵖ α] [has_scalar Mᵐᵒᵖ β] [is_central_scalar M α] [is_central_scalar M β] :
  is_central_scalar M (α × β) :=
⟨λ r m, prod.ext (op_smul_eq_smul _ _) (op_smul_eq_smul _ _)⟩

@[to_additive has_faithful_vadd_left]
instance has_faithful_scalar_left [has_faithful_scalar M α] [nonempty β] :
  has_faithful_scalar M (α × β) :=
⟨λ x y h, let ⟨b⟩ := ‹nonempty β› in eq_of_smul_eq_smul $ λ a : α, by injection h (a, b)⟩

@[to_additive has_faithful_vadd_right]
instance has_faithful_scalar_right [nonempty α] [has_faithful_scalar M β] :
  has_faithful_scalar M (α × β) :=
⟨λ x y h, let ⟨a⟩ := ‹nonempty α› in eq_of_smul_eq_smul $ λ b : β, by injection h (a, b)⟩

end

@[to_additive]
instance smul_comm_class_both [has_mul N] [has_mul P] [has_scalar M N] [has_scalar M P]
  [smul_comm_class M N N] [smul_comm_class M P P] :
  smul_comm_class M (N × P) (N × P) :=
⟨λ c x y, by simp [smul_def, mul_def, mul_smul_comm]⟩

instance is_scalar_tower_both [has_mul N] [has_mul P] [has_scalar M N] [has_scalar M P]
  [is_scalar_tower M N N] [is_scalar_tower M P P] :
  is_scalar_tower M (N × P) (N × P) :=
⟨λ c x y, by simp [smul_def, mul_def, smul_mul_assoc]⟩

@[to_additive] instance {m : monoid M} [mul_action M α] [mul_action M β] : mul_action M (α × β) :=
{ mul_smul  := λ a₁ a₂ p, mk.inj_iff.mpr ⟨mul_smul _ _ _, mul_smul _ _ _⟩,
  one_smul  := λ ⟨b, c⟩, mk.inj_iff.mpr ⟨one_smul _ _, one_smul _ _⟩ }

instance {R M N : Type*} {r : monoid R} [add_monoid M] [add_monoid N]
  [distrib_mul_action R M] [distrib_mul_action R N] : distrib_mul_action R (M × N) :=
{ smul_add  := λ a p₁ p₂, mk.inj_iff.mpr ⟨smul_add _ _ _, smul_add _ _ _⟩,
  smul_zero := λ a, mk.inj_iff.mpr ⟨smul_zero _, smul_zero _⟩ }

instance {R M N : Type*} {r : monoid R} [monoid M] [monoid N]
  [mul_distrib_mul_action R M] [mul_distrib_mul_action R N] : mul_distrib_mul_action R (M × N) :=
{ smul_mul  := λ a p₁ p₂, mk.inj_iff.mpr ⟨smul_mul' _ _ _, smul_mul' _ _ _⟩,
  smul_one := λ a, mk.inj_iff.mpr ⟨smul_one _, smul_one _⟩ }

end prod

/-! ### Scalar multiplication as a homomorphism -/

section bundled_smul

/-- Scalar multiplication as a multiplicative homomorphism. -/
@[simps]
def smul_mul_hom [monoid α] [has_mul β] [mul_action α β] [is_scalar_tower α β β]
  [smul_comm_class α β β] :
  mul_hom (α × β) β :=
{ to_fun := λ a, a.1 • a.2,
  map_mul' := λ a b, (smul_mul_smul _ _ _ _).symm }

/-- Scalar multiplication as a monoid homomorphism. -/
@[simps]
def smul_monoid_hom [monoid α] [mul_one_class β] [mul_action α β] [is_scalar_tower α β β]
  [smul_comm_class α β β] :
  α × β →* β :=
{ map_one' := one_smul _ _,
  .. smul_mul_hom }

end bundled_smul


/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.preadditive.additive_functor
import category_theory.monoidal.category

/-!
# Preadditive monoidal categories

A monoidal category is `monoidal_preadditive` if it is preadditive and tensor product of morphisms
is linear in both factors.
-/

noncomputable theory
open_locale classical

namespace category_theory

open category_theory.limits
open category_theory.monoidal_category

variables (C : Type*) [category C] [preadditive C] [monoidal_category C]

/--
A category is `monoidal_preadditive` if tensoring is additive in both factors.

Note we don't `extend preadditive C` here, as `abelian C` already extends it,
and we'll need to have both typeclasses sometimes.
-/
class monoidal_preadditive :=
(tensor_zero' : ∀ {W X Y Z : C} (f : W ⟶ X), f ⊗ (0 : Y ⟶ Z) = 0 . obviously)
(zero_tensor' : ∀ {W X Y Z : C} (f : Y ⟶ Z), (0 : W ⟶ X) ⊗ f = 0 . obviously)
(tensor_add' : ∀ {W X Y Z : C} (f : W ⟶ X) (g h : Y ⟶ Z), f ⊗ (g + h) = f ⊗ g + f ⊗ h . obviously)
(add_tensor' : ∀ {W X Y Z : C} (f g : W ⟶ X) (h : Y ⟶ Z), (f + g) ⊗ h = f ⊗ h + g ⊗ h . obviously)

restate_axiom monoidal_preadditive.tensor_zero'
restate_axiom monoidal_preadditive.zero_tensor'
restate_axiom monoidal_preadditive.tensor_add'
restate_axiom monoidal_preadditive.add_tensor'
attribute [simp] monoidal_preadditive.tensor_zero monoidal_preadditive.zero_tensor

variables [monoidal_preadditive C]

local attribute [simp] monoidal_preadditive.tensor_add monoidal_preadditive.add_tensor

instance tensor_left_additive (X : C) : (tensor_left X).additive := {}
instance tensor_right_additive (X : C) : (tensor_right X).additive := {}
instance tensoring_left_additive (X : C) : ((tensoring_left C).obj X).additive := {}
instance tensoring_right_additive (X : C) : ((tensoring_right C).obj X).additive := {}

open_locale big_operators

lemma tensor_sum {P Q R S : C} {J : Type*} (s : finset J) (f : P ⟶ Q) (g : J → (R ⟶ S)) :
  f ⊗ ∑ j in s, g j = ∑ j in s, f ⊗ g j :=
begin
  rw ←tensor_id_comp_id_tensor,
  let tQ := (((tensoring_left C).obj Q).map_add_hom : (R ⟶ S) →+ _),
  change _ ≫ tQ _ = _,
  rw [tQ.map_sum, preadditive.comp_sum],
  dsimp [tQ],
  simp only [tensor_id_comp_id_tensor],
end

lemma sum_tensor {P Q R S : C} {J : Type*} (s : finset J) (f : P ⟶ Q) (g : J → (R ⟶ S)) :
  (∑ j in s, g j) ⊗ f = ∑ j in s, g j ⊗ f :=
begin
  rw ←tensor_id_comp_id_tensor,
  let tQ := (((tensoring_right C).obj P).map_add_hom : (R ⟶ S) →+ _),
  change tQ _ ≫ _ = _,
  rw [tQ.map_sum, preadditive.sum_comp],
  dsimp [tQ],
  simp only [tensor_id_comp_id_tensor],
end

variables {C}

-- In a closed monoidal category, this would hold because
-- `tensor_left X` is a left adjoint and hence preserves all colimits.
-- In any case it is true in any preadditive category.
instance (X : C) : preserves_finite_biproducts (tensor_left X) :=
{ preserves := λ J _, by exactI
  { preserves := λ f,
    { preserves := λ b i, is_bilimit_of_total _ begin
      dsimp,
      simp only [←tensor_comp, category.comp_id, ←tensor_sum, ←tensor_id, is_bilimit.total i],
    end } } }

instance (X : C) : preserves_finite_biproducts (tensor_right X) :=
{ preserves := λ J _, by exactI
  { preserves := λ f,
    { preserves := λ b i, is_bilimit_of_total _ begin
      dsimp,
      simp only [←tensor_comp, category.comp_id, ←sum_tensor, ←tensor_id, is_bilimit.total i],
    end } } }

variables [has_finite_biproducts C]

/-- The isomorphism showing how tensor product on the left distributes over direct sums. -/
def left_distributor {J : Type*} [fintype J] (X : C) (f : J → C) :
  X ⊗ (⨁ f) ≅ ⨁ (λ j, X ⊗ f j) :=
(tensor_left X).map_biproduct f

@[simp]
lemma left_distributor_hom {J : Type*} [fintype J] (X : C) (f : J → C) :
  (left_distributor X f).hom = ∑ j : J, (𝟙 X ⊗ biproduct.π f j) ≫ biproduct.ι _ j :=
begin
  ext, dsimp [tensor_left, left_distributor],
  simp [preadditive.sum_comp, biproduct.ι_π, comp_dite],
end

@[simp]
lemma left_distributor_inv {J : Type*} [fintype J] (X : C) (f : J → C) :
  (left_distributor X f).inv = ∑ j : J, biproduct.π _ j ≫ (𝟙 X ⊗ biproduct.ι f j) :=
begin
  ext, dsimp [tensor_left, left_distributor],
  simp [preadditive.comp_sum, biproduct.ι_π_assoc, dite_comp],
end

lemma left_distributor_assoc {J : Type*} [fintype J] (X Y : C) (f : J → C) :
   (as_iso (𝟙 X) ⊗ left_distributor Y f) ≪≫ left_distributor X _ =
     (α_ X Y (⨁ f)).symm ≪≫ left_distributor (X ⊗ Y) f ≪≫ biproduct.map_iso (λ j, α_ X Y _) :=
begin
  ext,
  simp only [category.comp_id,  category.assoc, eq_to_hom_refl,
    iso.trans_hom, iso.symm_hom, as_iso_hom, comp_zero, comp_dite,
    preadditive.sum_comp, preadditive.comp_sum,
    tensor_sum, id_tensor_comp, tensor_iso_hom, left_distributor_hom,
    biproduct.map_iso_hom, biproduct.ι_map, biproduct.ι_π,
    finset.sum_dite_irrel, finset.sum_dite_eq', finset.sum_const_zero],
  simp only [←id_tensor_comp, biproduct.ι_π],
  simp only [id_tensor_comp, tensor_dite, comp_dite],
  simp only [category.comp_id, comp_zero, monoidal_preadditive.tensor_zero, eq_to_hom_refl,
    tensor_id, if_true, dif_ctx_congr, finset.sum_congr, finset.mem_univ, finset.sum_dite_eq'],
  simp only [←tensor_id, associator_naturality, iso.inv_hom_id_assoc],
end

/-- The isomorphism showing how tensor product on the right distributes over direct sums. -/
def right_distributor {J : Type*} [fintype J] (X : C) (f : J → C) :
  (⨁ f) ⊗ X ≅ ⨁ (λ j, f j ⊗ X)  :=
(tensor_right X).map_biproduct f

@[simp]
lemma right_distributor_hom {J : Type*} [fintype J] (X : C) (f : J → C) :
  (right_distributor X f).hom = ∑ j : J, (biproduct.π f j ⊗ 𝟙 X) ≫ biproduct.ι _ j :=
begin
  ext, dsimp [tensor_right, right_distributor],
  simp [preadditive.sum_comp, biproduct.ι_π, comp_dite],
end

@[simp]
lemma right_distributor_inv {J : Type*} [fintype J] (X : C) (f : J → C) :
  (right_distributor X f).inv = ∑ j : J, biproduct.π _ j ≫ (biproduct.ι f j ⊗ 𝟙 X) :=
begin
  ext, dsimp [tensor_right, right_distributor],
  simp [preadditive.comp_sum, biproduct.ι_π_assoc, dite_comp],
end

lemma right_distributor_assoc {J : Type*} [fintype J] (X Y : C) (f : J → C) :
   (right_distributor X f ⊗ as_iso (𝟙 Y)) ≪≫ right_distributor Y _ =
     α_ (⨁ f) X Y ≪≫ right_distributor (X ⊗ Y) f ≪≫ biproduct.map_iso (λ j, (α_ _ X Y).symm) :=
begin
  ext,
  simp only [category.comp_id, category.assoc, eq_to_hom_refl, iso.symm_hom,
    iso.trans_hom, as_iso_hom, comp_zero, comp_dite, preadditive.sum_comp, preadditive.comp_sum,
    sum_tensor, comp_tensor_id, tensor_iso_hom, right_distributor_hom,
    biproduct.map_iso_hom, biproduct.ι_map, biproduct.ι_π,
    finset.sum_dite_irrel, finset.sum_dite_eq', finset.sum_const_zero, finset.mem_univ, if_true],
  simp only [←comp_tensor_id, biproduct.ι_π, dite_tensor, comp_dite],
  simp only [category.comp_id, comp_tensor_id, eq_to_hom_refl, tensor_id, comp_zero,
    monoidal_preadditive.zero_tensor,
    if_true, dif_ctx_congr, finset.mem_univ, finset.sum_congr, finset.sum_dite_eq'],
  simp only [←tensor_id, associator_inv_naturality, iso.hom_inv_id_assoc]
end

lemma left_distributor_right_distributor_assoc
  {J : Type*} [fintype J] (X Y : C) (f : J → C) :
  (left_distributor X f ⊗ as_iso (𝟙 Y)) ≪≫ right_distributor Y _ =
    α_ X (⨁ f) Y ≪≫ (as_iso (𝟙 X) ⊗ right_distributor Y _) ≪≫ left_distributor X _ ≪≫
      biproduct.map_iso (λ j, (α_ _ _ _).symm) :=
begin
  ext,
  simp only [category.comp_id, category.assoc, eq_to_hom_refl, iso.symm_hom,
    iso.trans_hom, as_iso_hom, comp_zero, comp_dite, preadditive.sum_comp, preadditive.comp_sum,
    sum_tensor, tensor_sum, comp_tensor_id, tensor_iso_hom,
    left_distributor_hom, right_distributor_hom,
    biproduct.map_iso_hom, biproduct.ι_map, biproduct.ι_π,
    finset.sum_dite_irrel, finset.sum_dite_eq', finset.sum_const_zero, finset.mem_univ, if_true],
  simp only [←comp_tensor_id, ←id_tensor_comp_assoc, category.assoc, biproduct.ι_π,
    comp_dite, dite_comp, tensor_dite, dite_tensor],
  simp only [category.comp_id, category.id_comp, category.assoc, id_tensor_comp,
    comp_zero, zero_comp, monoidal_preadditive.tensor_zero, monoidal_preadditive.zero_tensor,
    comp_tensor_id, eq_to_hom_refl, tensor_id,
    if_true, dif_ctx_congr, finset.sum_congr, finset.mem_univ, finset.sum_dite_eq'],
  simp only [associator_inv_naturality, iso.hom_inv_id_assoc]
end

end category_theory


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.natural_isomorphism
import Mathlib.category_theory.full_subcategory
import Mathlib.PostPort

universes v₁ v₂ u₁ u₂ l

namespace Mathlib

/-!
# Essential image of a functor

The essential image `ess_image` of a functor consists of the objects in the target category which
are isomorphic to an object in the image of the object function.
This, for instance, allows us to talk about objects belonging to a subcategory expressed as a
functor rather than a subtype, preserving the principle of equivalence. For example this lets us
define exponential ideals.

The essential image can also be seen as a subcategory of the target category, and witnesses that
a functor decomposes into a essentially surjective functor and a fully faithful functor.
(TODO: show that this decomposition forms an orthogonal factorisation system).
-/

namespace category_theory

namespace functor

/--
The essential image of a functor `F` consists of those objects in the target category which are
isomorphic to an object in the image of the function `F.obj`. In other words, this is the closure
under isomorphism of the function `F.obj`.
This is the "non-evil" way of describing the image of a functor.
-/
def ess_image {C : Type u₁} {D : Type u₂} [category C] [category D] (F : C ⥤ D) : set D :=
  fun (Y : D) => ∃ (X : C), Nonempty (obj F X ≅ Y)

/-- Get the witnessing object that `Y` is in the subcategory given by `F`. -/
def ess_image.witness {C : Type u₁} {D : Type u₂} [category C] [category D] {F : C ⥤ D} {Y : D} (h : Y ∈ ess_image F) : C :=
  Exists.some h

/-- Extract the isomorphism between `F.obj h.witness` and `Y` itself. -/
def ess_image.get_iso {C : Type u₁} {D : Type u₂} [category C] [category D] {F : C ⥤ D} {Y : D} (h : Y ∈ ess_image F) : obj F (ess_image.witness h) ≅ Y :=
  Classical.choice sorry

/-- Being in the essential image is a "hygenic" property: it is preserved under isomorphism. -/
theorem ess_image.of_iso {C : Type u₁} {D : Type u₂} [category C] [category D] {F : C ⥤ D} {Y : D} {Y' : D} (h : Y ≅ Y') (hY : Y ∈ ess_image F) : Y' ∈ ess_image F :=
  Exists.imp (fun (B : C) => nonempty.map fun (_x : obj F B ≅ Y) => _x ≪≫ h) hY

/--
If `Y` is in the essential image of `F` then it is in the essential image of `F'` as long as
`F ≅ F'`.
-/
theorem ess_image.of_nat_iso {C : Type u₁} {D : Type u₂} [category C] [category D] {F : C ⥤ D} {F' : C ⥤ D} (h : F ≅ F') {Y : D} (hY : Y ∈ ess_image F) : Y ∈ ess_image F' :=
  Exists.imp (fun (X : C) => nonempty.map fun (t : obj F X ≅ Y) => iso.app (iso.symm h) X ≪≫ t) hY

/-- Isomorphic functors have equal essential images. -/
theorem ess_image_eq_of_nat_iso {C : Type u₁} {D : Type u₂} [category C] [category D] {F : C ⥤ D} {F' : C ⥤ D} (h : F ≅ F') : ess_image F = ess_image F' :=
  set.ext fun (A : D) => { mp := ess_image.of_nat_iso h, mpr := ess_image.of_nat_iso (iso.symm h) }

/-- An object in the image is in the essential image. -/
theorem obj_mem_ess_image {C : Type u₁} {D : Type u₂} [category C] [category D] (F : D ⥤ C) (Y : D) : obj F Y ∈ ess_image F :=
  Exists.intro Y (Nonempty.intro (iso.refl (obj F Y)))

protected instance ess_image.category_theory.category {C : Type u₁} {D : Type u₂} [category C] [category D] {F : C ⥤ D} : category ↥(ess_image F) :=
  category_theory.full_subcategory fun (x : D) => x ∈ ess_image F

/-- The essential image as a subcategory has a fully faithful inclusion into the target category. -/
@[simp] theorem ess_image_inclusion_obj {C : Type u₁} {D : Type u₂} [category C] [category D] (F : C ⥤ D) (c : Subtype fun (X : D) => (fun (x : D) => x ∈ ess_image F) X) : obj (ess_image_inclusion F) c = ↑c :=
  Eq.refl ↑c

/--
Given a functor `F : C ⥤ D`, we have an (essentially surjective) functor from `C` to the essential
image of `F`.
-/
def to_ess_image {C : Type u₁} {D : Type u₂} [category C] [category D] (F : C ⥤ D) : C ⥤ ↥(ess_image F) :=
  mk (fun (X : C) => { val := obj F X, property := obj_mem_ess_image F X })
    fun (X Y : C) (f : X ⟶ Y) => preimage (ess_image_inclusion F) (map F f)

/--
The functor `F` factorises through its essential image, where the first functor is essentially
surjective and the second is fully faithful.
-/
@[simp] theorem to_ess_image_comp_essential_image_inclusion_hom_app {C : Type u₁} {D : Type u₂} [category C] [category D] {F : C ⥤ D} (X : C) : nat_trans.app (iso.hom to_ess_image_comp_essential_image_inclusion) X = 𝟙 :=
  Eq.refl 𝟙

end functor

/--
A functor `F : C ⥤ D` is essentially surjective if every object of `D` is in the essential image
of `F`. In other words, for every `Y : D`, there is some `X : C` with `F.obj X ≅ Y`.

See https://stacks.math.columbia.edu/tag/001C.
-/
class ess_surj {C : Type u₁} {D : Type u₂} [category C] [category D] (F : C ⥤ D)
where
  mem_ess_image : ∀ (Y : D), Y ∈ functor.ess_image F

protected instance functor.to_ess_image.ess_surj {C : Type u₁} {D : Type u₂} [category C] [category D] {F : C ⥤ D} : ess_surj (functor.to_ess_image F) :=
  ess_surj.mk fun (_x : ↥(functor.ess_image F)) => sorry

/-- Given an essentially surjective functor, we can find a preimage for every object `Y` in the
    codomain. Applying the functor to this preimage will yield an object isomorphic to `Y`, see
    `obj_obj_preimage_iso`. -/
/-- Applying an essentially surjective functor to a preimage of `Y` yields an object that is
def functor.obj_preimage {C : Type u₁} {D : Type u₂} [category C] [category D] (F : C ⥤ D) [ess_surj F] (Y : D) : C :=
  functor.ess_image.witness (ess_surj.mem_ess_image F Y)

    isomorphic to `Y`. -/
def functor.obj_obj_preimage_iso {C : Type u₁} {D : Type u₂} [category C] [category D] (F : C ⥤ D) [ess_surj F] (Y : D) : functor.obj F (functor.obj_preimage F Y) ≅ Y :=
  functor.ess_image.get_iso (ess_surj.mem_ess_image F Y)


import set_category.diagram_lemmas
import set_category.category_set
import set_category.colimits.Coequalizer
import help_functions
import coalgebra.Coalgebra

import tactic.tidy

universes u

namespace coalgebra_coequalizer

open category_theory
     set
     coalgebra
     classical
     help_functions
     Coequalizer
     coalgebra.Coalgebra
     category_set

local notation f ` ⊚ `:80 g:80 := category_struct.comp g f

variables   {F : Type u ⥤ Type u}
            {𝔸 Β: Coalgebra F}
            (ϕ ψ : 𝔸 ⟶ Β)

theorem coequalizer_is_homomorphism :
    let Β_Θ := theta ϕ ψ in
    let π_Θ : Β.carrier ⟶ Β_Θ := coequalizer ϕ ψ in
    ∃! α : Β_Θ → (F.obj Β_Θ),
    @is_coalgebra_homomorphism F Β ⟨Β_Θ , α⟩ π_Θ
    :=
    begin
        intros Β_Θ π_Θ,

        have hom_f : Β.α ∘ ϕ = (F.map ϕ) ∘ 𝔸.α := ϕ.property,
        have hom_g : Β.α ∘ ψ = (F.map ψ) ∘ 𝔸.α := ψ.property,
        let ϕ₁  : 𝔸.carrier ⟶ Β.carrier := ϕ.val,
        let ψ₁ : 𝔸.carrier ⟶ Β.carrier := ψ.val,
        have h : is_coequalizer ϕ₁ ψ₁ π_Θ := quot_is_coequalizer ϕ₁ ψ₁,

        have h2 : (F.map π_Θ) ∘ Β.α ∘ ϕ = (F.map π_Θ) ∘ Β.α ∘ ψ :=
            calc (F.map π_Θ) ∘ (Β.α ∘ ϕ)
                     = (F.map π_Θ) ∘ (F.map ϕ) ∘ 𝔸.α         : by rw hom_f
                 ... = ((F.map π_Θ) ⊚ (F.map ϕ)) ∘ 𝔸.α      : rfl
                 ... = (F.map (π_Θ ⊚ ϕ)) ∘ 𝔸.α              : by rw functor.map_comp
                 ... = (F.map (π_Θ ⊚ ψ)) ∘ 𝔸.α              : by tidy
                 ... = ((F.map π_Θ) ⊚ (F.map ψ)) ∘ 𝔸.α      : by rw ←functor.map_comp
                 ... = (F.map π_Θ) ∘ ((F.map ψ) ∘ 𝔸.α)       : rfl
                 ... = (F.map π_Θ) ∘ (Β.α ∘ ψ)               : by rw ← hom_g,

        have h3 : _ := h.2 (F.obj Β_Θ) ((F.map π_Θ) ∘ Β.α) h2,

        let α : Β_Θ → F.obj Β_Θ := some h3,

        use α,

        exact some_spec h3

    end

theorem coeq_competitor  (ℚ : Coalgebra F)
                    (q : homomorphism Β ℚ)
                    (h : q ∘ ϕ = q ∘ ψ)
        :
        let Β_Θ := theta ϕ ψ in
        let π_Θ := coequalizer ϕ ψ in
        let α := some (coequalizer_is_homomorphism ϕ ψ) in
            ∃! χ : homomorphism ⟨Β_Θ , α⟩ ℚ ,
            χ ∘ π_Θ = q.val
    :=
    begin
        intros Β_Θ π_Θ α,
        have sub_ker : sub_kern π_Θ q := coequalizer_kern ϕ ψ ℚ q h,
        have hom_π : _ :=(some_spec (coequalizer_is_homomorphism ϕ ψ)).1,

        have diag : _ := coalgebra_diagram
                    (⟨π_Θ, hom_π⟩: homomorphism Β ⟨Β_Θ , α⟩)
                    q
                    (quot_is_surjective ϕ ψ),
        exact diag.2 sub_ker
    end

theorem set_coequalizer_is_coalgebra_coequalizer :
    let Β_Θ := theta ϕ ψ in
    let π_Θ : Β.carrier ⟶ Β_Θ := coequalizer ϕ ψ in
    let α : Β_Θ → F.obj (Β_Θ):=  some (coequalizer_is_homomorphism ϕ ψ) in
    let h_π := (some_spec (coequalizer_is_homomorphism ϕ ψ)).1 in
    let co_Β_Θ : Coalgebra F := ⟨Β_Θ, α⟩ in
    let π₁ : Β ⟶ co_Β_Θ := ⟨π_Θ, h_π⟩ in
    is_coequalizer
        ϕ ψ π₁ :=
    begin
        intros Β_Θ π_Θ α h_π co_Β_Θ π₁,
        let ϕ₁ : 𝔸.carrier ⟶ Β.carrier := ϕ.val,
        let ψ₁ : 𝔸.carrier ⟶ Β.carrier := ψ.val,
        split,
        have h : is_coequalizer ϕ₁ ψ₁ π_Θ := quot_is_coequalizer ϕ ψ,
        have h1 : _ := h.1,
        exact eq_in_set.1 h1,
        intros ℚ q h,
        have h₁ : q.val ⊚ ϕ₁ = q.val ⊚ ψ₁ := eq_in_set.2 h,

        have com : ∃! χ : homomorphism ⟨Β_Θ , α⟩ ℚ ,
                         χ ∘ π_Θ = q.val :=
            begin
                have sub_ker : sub_kern π_Θ q := coequalizer_kern ϕ ψ ℚ q h₁,
                have hom_π : _ :=(some_spec (coequalizer_is_homomorphism ϕ ψ)).1,

                have diag : _ := coalgebra_diagram
                            (⟨π_Θ, hom_π⟩: homomorphism Β ⟨Β_Θ , α⟩)
                            q
                            (quot_is_surjective ϕ ψ),
                exact diag.2 sub_ker
            end,
        let χ : co_Β_Θ ⟶ ℚ := some com,
        use χ,
        have spec : χ ∘ π_Θ = q := (some_spec com).1,

        have h1 : (χ ⊚ π₁) = q := eq_in_set.1 spec,
        split,
        exact h1,
        intros χ₁ coeq,
        have coeq1 : χ₁ ⊚ π₁ = χ ⊚ π₁ := by simp[h1 , coeq],
        haveI ep : epi π_Θ := (epi_iff_surjective π_Θ).2
                                (quot_is_surjective ϕ ψ),
        have coeq2 : χ₁.val ⊚ π_Θ = χ.val ⊚ π_Θ :=
                    eq_in_set.2 coeq1,

        have coeq3: χ₁.val = χ.val := right_cancel π_Θ coeq2,

        exact eq_in_set.1 coeq3,
    end

end coalgebra_coequalizer