/-
Copyright (c) 2019 Reid Barton. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Reid Barton, Scott Morrison

Facts about epimorphisms and monomorphisms.

The definitions of `epi` and `mono` are in `category_theory.category`,
since they are used by some lemmas for `iso`, which is used everywhere.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.adjunction.basic
import Mathlib.category_theory.opposites
import Mathlib.PostPort

universes v₁ v₂ u₁ u₂ l

namespace Mathlib

namespace category_theory

theorem left_adjoint_preserves_epi {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : D ⥤ C} (adj : F ⊣ G) {X : C} {Y : C} {f : X ⟶ Y} (hf : epi f) : epi (functor.map F f) := sorry

theorem right_adjoint_preserves_mono {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : D ⥤ C} (adj : F ⊣ G) {X : D} {Y : D} {f : X ⟶ Y} (hf : mono f) : mono (functor.map G f) := sorry

theorem faithful_reflects_epi {C : Type u₁} [category C] {D : Type u₂} [category D] (F : C ⥤ D) [faithful F] {X : C} {Y : C} {f : X ⟶ Y} (hf : epi (functor.map F f)) : epi f := sorry

theorem faithful_reflects_mono {C : Type u₁} [category C] {D : Type u₂} [category D] (F : C ⥤ D) [faithful F] {X : C} {Y : C} {f : X ⟶ Y} (hf : mono (functor.map F f)) : mono f := sorry

/--
A split monomorphism is a morphism `f : X ⟶ Y` admitting a retraction `retraction f : Y ⟶ X`
such that `f ≫ retraction f = 𝟙 X`.

Every split monomorphism is a monomorphism.
-/
class split_mono {C : Type u₁} [category C] {X : C} {Y : C} (f : X ⟶ Y)
where
  retraction : Y ⟶ X
  id' : autoParam (f ≫ retraction = 𝟙)
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
    (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])

/--
A split epimorphism is a morphism `f : X ⟶ Y` admitting a section `section_ f : Y ⟶ X`
such that `section_ f ≫ f = 𝟙 Y`.
(Note that `section` is a reserved keyword, so we append an underscore.)

Every split epimorphism is an epimorphism.
-/
class split_epi {C : Type u₁} [category C] {X : C} {Y : C} (f : X ⟶ Y)
where
  section_ : Y ⟶ X
  id' : autoParam (section_ ≫ f = 𝟙)
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
    (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])

/-- The chosen retraction of a split monomorphism. -/
def retraction {C : Type u₁} [category C] {X : C} {Y : C} (f : X ⟶ Y) [split_mono f] : Y ⟶ X :=
  split_mono.retraction f

@[simp] theorem split_mono.id_assoc {C : Type u₁} [category C] {X : C} {Y : C} (f : X ⟶ Y) [split_mono f] {X' : C} (f' : X ⟶ X') : f ≫ retraction f ≫ f' = f' := sorry

/-- The retraction of a split monomorphism is itself a split epimorphism. -/
protected instance retraction_split_epi {C : Type u₁} [category C] {X : C} {Y : C} (f : X ⟶ Y) [split_mono f] : split_epi (retraction f) :=
  split_epi.mk f

/-- A split mono which is epi is an iso. -/
def is_iso_of_epi_of_split_mono {C : Type u₁} [category C] {X : C} {Y : C} (f : X ⟶ Y) [split_mono f] [epi f] : is_iso f :=
  is_iso.mk (retraction f)

/--
The chosen section of a split epimorphism.
(Note that `section` is a reserved keyword, so we append an underscore.)
-/
def section_ {C : Type u₁} [category C] {X : C} {Y : C} (f : X ⟶ Y) [split_epi f] : Y ⟶ X :=
  split_epi.section_ f

@[simp] theorem split_epi.id_assoc {C : Type u₁} [category C] {X : C} {Y : C} (f : X ⟶ Y) [split_epi f] {X' : C} (f' : Y ⟶ X') : section_ f ≫ f ≫ f' = f' := sorry

/-- The section of a split epimorphism is itself a split monomorphism. -/
protected instance section_split_mono {C : Type u₁} [category C] {X : C} {Y : C} (f : X ⟶ Y) [split_epi f] : split_mono (section_ f) :=
  split_mono.mk f

/-- A split epi which is mono is an iso. -/
def is_iso_of_mono_of_split_epi {C : Type u₁} [category C] {X : C} {Y : C} (f : X ⟶ Y) [mono f] [split_epi f] : is_iso f :=
  is_iso.mk (section_ f)

/-- Every iso is a split mono. -/
protected instance split_mono.of_iso {C : Type u₁} [category C] {X : C} {Y : C} (f : X ⟶ Y) [is_iso f] : split_mono f :=
  split_mono.mk (inv f)

/-- Every iso is a split epi. -/
protected instance split_epi.of_iso {C : Type u₁} [category C] {X : C} {Y : C} (f : X ⟶ Y) [is_iso f] : split_epi f :=
  split_epi.mk (inv f)

/-- Every split mono is a mono. -/
protected instance split_mono.mono {C : Type u₁} [category C] {X : C} {Y : C} (f : X ⟶ Y) [split_mono f] : mono f := sorry

/-- Every split epi is an epi. -/
protected instance split_epi.epi {C : Type u₁} [category C] {X : C} {Y : C} (f : X ⟶ Y) [split_epi f] : epi f :=
  epi.mk
    fun (Z : C) (g h : Y ⟶ Z) (w : f ≫ g = f ≫ h) =>
      eq.mpr (id (Eq.refl (g = h)))
        (eq.mp
          ((fun (a a_1 : Y ⟶ Z) (e_1 : a = a_1) (ᾰ ᾰ_1 : Y ⟶ Z) (e_2 : ᾰ = ᾰ_1) => congr (congr_arg Eq e_1) e_2)
            (section_ f ≫ f ≫ g) g (split_epi.id_assoc f g) (section_ f ≫ f ≫ h) h (split_epi.id_assoc f h))
          (section_ f ≫= w))

/-- Every split mono whose retraction is mono is an iso. -/
def is_iso.of_mono_retraction {C : Type u₁} [category C] {X : C} {Y : C} {f : X ⟶ Y} [split_mono f] [mono (retraction f)] : is_iso f :=
  is_iso.mk (retraction f)

/-- Every split epi whose section is epi is an iso. -/
def is_iso.of_epi_section {C : Type u₁} [category C] {X : C} {Y : C} {f : X ⟶ Y} [split_epi f] [epi (section_ f)] : is_iso f :=
  is_iso.mk (section_ f)

protected instance unop_mono_of_epi {C : Type u₁} [category C] {A : Cᵒᵖ} {B : Cᵒᵖ} (f : A ⟶ B) [epi f] : mono (has_hom.hom.unop f) :=
  mono.mk
    fun (Z : C) (g h : Z ⟶ opposite.unop B) (eq : g ≫ has_hom.hom.unop f = h ≫ has_hom.hom.unop f) =>
      has_hom.hom.op_inj (iff.mp (cancel_epi f) (has_hom.hom.unop_inj eq))

protected instance unop_epi_of_mono {C : Type u₁} [category C] {A : Cᵒᵖ} {B : Cᵒᵖ} (f : A ⟶ B) [mono f] : epi (has_hom.hom.unop f) :=
  epi.mk
    fun (Z : C) (g h : opposite.unop A ⟶ Z) (eq : has_hom.hom.unop f ≫ g = has_hom.hom.unop f ≫ h) =>
      has_hom.hom.op_inj (iff.mp (cancel_mono f) (has_hom.hom.unop_inj eq))

protected instance op_mono_of_epi {C : Type u₁} [category C] {A : C} {B : C} (f : A ⟶ B) [epi f] : mono (has_hom.hom.op f) :=
  mono.mk
    fun (Z : Cᵒᵖ) (g h : Z ⟶ opposite.op B) (eq : g ≫ has_hom.hom.op f = h ≫ has_hom.hom.op f) =>
      has_hom.hom.unop_inj (iff.mp (cancel_epi f) (has_hom.hom.op_inj eq))

protected instance op_epi_of_mono {C : Type u₁} [category C] {A : C} {B : C} (f : A ⟶ B) [mono f] : epi (has_hom.hom.op f) :=
  epi.mk
    fun (Z : Cᵒᵖ) (g h : opposite.op A ⟶ Z) (eq : has_hom.hom.op f ≫ g = has_hom.hom.op f ≫ h) =>
      has_hom.hom.unop_inj (iff.mp (cancel_mono f) (has_hom.hom.op_inj eq))

/-- Split monomorphisms are also absolute monomorphisms. -/
protected instance functor.map.split_mono {C : Type u₁} [category C] {D : Type u₂} [category D] {X : C} {Y : C} (f : X ⟶ Y) [split_mono f] (F : C ⥤ D) : split_mono (functor.map F f) :=
  split_mono.mk (functor.map F (retraction f))

/-- Split epimorphisms are also absolute epimorphisms. -/
protected instance functor.map.split_epi {C : Type u₁} [category C] {D : Type u₂} [category D] {X : C} {Y : C} (f : X ⟶ Y) [split_epi f] (F : C ⥤ D) : split_epi (functor.map F f) :=
  split_epi.mk (functor.map F (section_ f))


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Mario Carneiro, Kevin Buzzard, Yury Kudryashov, Eric Wieser
-/
import linear_algebra.basic

/-! ### Products of modules

This file defines constructors for linear maps whose domains or codomains are products.

It contains theorems relating these to each other, as well as to `submodule.prod`, `submodule.map`,
`submodule.comap`, `linear_map.range`, and `linear_map.ker`.

## Main definitions

- products in the domain:
  - `linear_map.fst`
  - `linear_map.snd`
  - `linear_map.coprod`
  - `linear_map.prod_ext`
- products in the codomain:
  - `linear_map.inl`
  - `linear_map.inr`
  - `linear_map.prod`
- products in both domain and codomain:
  - `linear_map.prod_map`
  - `linear_equiv.prod_map`
  - `linear_equiv.skew_prod`
-/

universes u v w x y z u' v' w' y'
variables {R : Type u} {K : Type u'} {M : Type v} {V : Type v'} {M₂ : Type w} {V₂ : Type w'}
variables {M₃ : Type y} {V₃ : Type y'} {M₄ : Type z} {ι : Type x}

section prod

namespace linear_map

variables (S : Type*) [semiring R] [semiring S]
variables [add_comm_monoid M] [add_comm_monoid M₂] [add_comm_monoid M₃] [add_comm_monoid M₄]
variables [module R M] [module R M₂] [module R M₃] [module R M₄]
variables (f : M →ₗ[R] M₂)

section
variables (R M M₂)

/-- The first projection of a product is a linear map. -/
def fst : M × M₂ →ₗ[R] M := ⟨prod.fst, λ x y, rfl, λ x y, rfl⟩

/-- The second projection of a product is a linear map. -/
def snd : M × M₂ →ₗ[R] M₂ := ⟨prod.snd, λ x y, rfl, λ x y, rfl⟩
end

@[simp] theorem fst_apply (x : M × M₂) : fst R M M₂ x = x.1 := rfl
@[simp] theorem snd_apply (x : M × M₂) : snd R M M₂ x = x.2 := rfl

/-- The prod of two linear maps is a linear map. -/
@[simps] def prod (f : M →ₗ[R] M₂) (g : M →ₗ[R] M₃) : (M →ₗ[R] M₂ × M₃) :=
{ to_fun    := λ x, (f x, g x),
  map_add'  := λ x y, by simp only [prod.mk_add_mk, map_add],
  map_smul' := λ c x, by simp only [prod.smul_mk, map_smul] }

@[simp] theorem fst_prod (f : M →ₗ[R] M₂) (g : M →ₗ[R] M₃) :
  (fst R M₂ M₃).comp (prod f g) = f := by ext; refl

@[simp] theorem snd_prod (f : M →ₗ[R] M₂) (g : M →ₗ[R] M₃) :
  (snd R M₂ M₃).comp (prod f g) = g := by ext; refl

@[simp] theorem pair_fst_snd : prod (fst R M M₂) (snd R M M₂) = linear_map.id :=
by ext; refl

/-- Taking the product of two maps with the same domain is equivalent to taking the product of
their codomains.

See note [bundled maps over different rings] for why separate `R` and `S` semirings are used. -/
@[simps] def prod_equiv
  [module S M₂] [module S M₃] [smul_comm_class R S M₂] [smul_comm_class R S M₃] :
  ((M →ₗ[R] M₂) × (M →ₗ[R] M₃)) ≃ₗ[S] (M →ₗ[R] M₂ × M₃) :=
{ to_fun := λ f, f.1.prod f.2,
  inv_fun := λ f, ((fst _ _ _).comp f, (snd _ _ _).comp f),
  left_inv := λ f, by ext; refl,
  right_inv := λ f, by ext; refl,
  map_add' := λ a b, rfl,
  map_smul' := λ r a, rfl }

section
variables (R M M₂)

/-- The left injection into a product is a linear map. -/
def inl : M →ₗ[R] M × M₂ := prod linear_map.id 0

/-- The right injection into a product is a linear map. -/
def inr : M₂ →ₗ[R] M × M₂ := prod 0 linear_map.id

end

@[simp] theorem inl_apply (x : M) : inl R M M₂ x = (x, 0) := rfl
@[simp] theorem inr_apply (x : M₂) : inr R M M₂ x = (0, x) := rfl

theorem inl_eq_prod : inl R M M₂ = prod linear_map.id 0 := rfl

theorem inr_eq_prod : inr R M M₂ = prod 0 linear_map.id := rfl

theorem inl_injective : function.injective (inl R M M₂) :=
λ _, by simp

/-- The coprod function `λ x : M × M₂, f.1 x.1 + f.2 x.2` is a linear map. -/
def coprod (f : M →ₗ[R] M₃) (g : M₂ →ₗ[R] M₃) : M × M₂ →ₗ[R] M₃ :=
f.comp (fst _ _ _) + g.comp (snd _ _ _)

@[simp] theorem coprod_apply (f : M →ₗ[R] M₃) (g : M₂ →ₗ[R] M₃) (x : M × M₂) :
  coprod f g x = f x.1 + g x.2 := rfl

@[simp] theorem coprod_inl (f : M →ₗ[R] M₃) (g : M₂ →ₗ[R] M₃) :
  (coprod f g).comp (inl R M M₂) = f :=
by ext; simp only [map_zero, add_zero, coprod_apply, inl_apply, comp_apply]

@[simp] theorem coprod_inr (f : M →ₗ[R] M₃) (g : M₂ →ₗ[R] M₃) :
  (coprod f g).comp (inr R M M₂) = g :=
by ext; simp only [map_zero, coprod_apply, inr_apply, zero_add, comp_apply]

@[simp] theorem coprod_inl_inr : coprod (inl R M M₂) (inr R M M₂) = linear_map.id :=
by ext; simp only [prod.mk_add_mk, add_zero, id_apply, coprod_apply,
  inl_apply, inr_apply, zero_add]

theorem comp_coprod (f : M₃ →ₗ[R] M₄) (g₁ : M →ₗ[R] M₃) (g₂ : M₂ →ₗ[R] M₃) :
  f.comp (g₁.coprod g₂) = (f.comp g₁).coprod (f.comp g₂) :=
ext $ λ x, f.map_add (g₁ x.1) (g₂ x.2)

theorem fst_eq_coprod : fst R M M₂ = coprod linear_map.id 0 := by ext; simp

theorem snd_eq_coprod : snd R M M₂ = coprod 0 linear_map.id := by ext; simp

@[simp] theorem coprod_comp_prod (f : M₂ →ₗ[R] M₄) (g : M₃ →ₗ[R] M₄)
  (f' : M →ₗ[R] M₂) (g' : M →ₗ[R] M₃) :
  (f.coprod g).comp (f'.prod g') = f.comp f' + g.comp g' :=
rfl

/-- Taking the product of two maps with the same codomain is equivalent to taking the product of
their domains.

See note [bundled maps over different rings] for why separate `R` and `S` semirings are used. -/
@[simps] def coprod_equiv [module S M₃] [smul_comm_class R S M₃] :
  ((M →ₗ[R] M₃) × (M₂ →ₗ[R] M₃)) ≃ₗ[S] (M × M₂ →ₗ[R] M₃) :=
{ to_fun := λ f, f.1.coprod f.2,
  inv_fun := λ f, (f.comp (inl _ _ _), f.comp (inr _ _ _)),
  left_inv := λ f, by simp only [prod.mk.eta, coprod_inl, coprod_inr],
  right_inv := λ f, by simp only [←comp_coprod, comp_id, coprod_inl_inr],
  map_add' := λ a b,
    by { ext, simp only [prod.snd_add, add_apply, coprod_apply, prod.fst_add], ac_refl },
  map_smul' := λ r a,
    by { ext, simp only [smul_add, smul_apply, prod.smul_snd, prod.smul_fst, coprod_apply] } }

theorem prod_ext_iff {f g : M × M₂ →ₗ[R] M₃} :
  f = g ↔ f.comp (inl _ _ _) = g.comp (inl _ _ _) ∧ f.comp (inr _ _ _) = g.comp (inr _ _ _) :=
(coprod_equiv ℕ).symm.injective.eq_iff.symm.trans prod.ext_iff

/--
Split equality of linear maps from a product into linear maps over each component, to allow `ext`
to apply lemmas specific to `M →ₗ M₃` and `M₂ →ₗ M₃`.

See note [partially-applied ext lemmas]. -/
@[ext] theorem prod_ext {f g : M × M₂ →ₗ[R] M₃}
  (hl : f.comp (inl _ _ _) = g.comp (inl _ _ _))
  (hr : f.comp (inr _ _ _) = g.comp (inr _ _ _)) :
  f = g :=
prod_ext_iff.2 ⟨hl, hr⟩

/-- `prod.map` of two linear maps. -/
def prod_map (f : M →ₗ[R] M₃) (g : M₂ →ₗ[R] M₄) : (M × M₂) →ₗ[R] (M₃ × M₄) :=
(f.comp (fst R M M₂)).prod (g.comp (snd R M M₂))

@[simp] theorem prod_map_apply (f : M →ₗ[R] M₃) (g : M₂ →ₗ[R] M₄) (x) :
  f.prod_map g x = (f x.1, g x.2) := rfl

end linear_map

end prod

namespace linear_map
open submodule

variables [semiring R]
  [add_comm_monoid M] [add_comm_monoid M₂] [add_comm_monoid M₃] [add_comm_monoid M₄]
  [module R M] [module R M₂] [module R M₃] [module R M₄]

lemma range_coprod (f : M →ₗ[R] M₃) (g : M₂ →ₗ[R] M₃) :
  (f.coprod g).range = f.range ⊔ g.range :=
submodule.ext $ λ x, by simp [mem_sup]

lemma is_compl_range_inl_inr : is_compl (inl R M M₂).range (inr R M M₂).range :=
begin
  split,
  { rintros ⟨_, _⟩ ⟨⟨x, hx⟩, ⟨y, hy⟩⟩,
    simp only [prod.ext_iff, inl_apply, inr_apply, mem_bot] at hx hy ⊢,
    exact ⟨hy.1.symm, hx.2.symm⟩ },
  { rintros ⟨x, y⟩ -,
    simp only [mem_sup, mem_range, exists_prop],
    refine ⟨(x, 0), ⟨x, rfl⟩, (0, y), ⟨y, rfl⟩, _⟩,
    simp }
end

lemma sup_range_inl_inr : (inl R M M₂).range ⊔ (inr R M M₂).range = ⊤ :=
is_compl_range_inl_inr.sup_eq_top

lemma disjoint_inl_inr : disjoint (inl R M M₂).range (inr R M M₂).range :=
by simp [disjoint_def, @eq_comm M 0, @eq_comm M₂ 0] {contextual := tt}; intros; refl
theorem map_coprod_prod (f : M →ₗ[R] M₃) (g : M₂ →ₗ[R] M₃)
  (p : submodule R M) (q : submodule R M₂) :
  map (coprod f g) (p.prod q) = map f p ⊔ map g q :=
begin
  refine le_antisymm _ (sup_le (map_le_iff_le_comap.2 _) (map_le_iff_le_comap.2 _)),
  { rw set_like.le_def, rintro _ ⟨x, ⟨h₁, h₂⟩, rfl⟩,
    exact mem_sup.2 ⟨_, ⟨_, h₁, rfl⟩, _, ⟨_, h₂, rfl⟩, rfl⟩ },
  { exact λ x hx, ⟨(x, 0), by simp [hx]⟩ },
  { exact λ x hx, ⟨(0, x), by simp [hx]⟩ }
end

theorem comap_prod_prod (f : M →ₗ[R] M₂) (g : M →ₗ[R] M₃)
  (p : submodule R M₂) (q : submodule R M₃) :
  comap (prod f g) (p.prod q) = comap f p ⊓ comap g q :=
submodule.ext $ λ x, iff.rfl

theorem prod_eq_inf_comap (p : submodule R M) (q : submodule R M₂) :
  p.prod q = p.comap (linear_map.fst R M M₂) ⊓ q.comap (linear_map.snd R M M₂) :=
submodule.ext $ λ x, iff.rfl

theorem prod_eq_sup_map (p : submodule R M) (q : submodule R M₂) :
  p.prod q = p.map (linear_map.inl R M M₂) ⊔ q.map (linear_map.inr R M M₂) :=
by rw [← map_coprod_prod, coprod_inl_inr, map_id]

lemma span_inl_union_inr {s : set M} {t : set M₂} :
  span R (inl R M  M₂ '' s ∪ inr R M M₂ '' t) = (span R s).prod (span R t) :=
by rw [span_union, prod_eq_sup_map, ← span_image, ← span_image]

@[simp] lemma ker_prod (f : M →ₗ[R] M₂) (g : M →ₗ[R] M₃) :
  ker (prod f g) = ker f ⊓ ker g :=
by rw [ker, ← prod_bot, comap_prod_prod]; refl

lemma range_prod_le (f : M →ₗ[R] M₂) (g : M →ₗ[R] M₃) :
  range (prod f g) ≤ (range f).prod (range g) :=
begin
  simp only [set_like.le_def, prod_apply, mem_range, set_like.mem_coe, mem_prod,
    exists_imp_distrib],
  rintro _ x rfl,
  exact ⟨⟨x, rfl⟩, ⟨x, rfl⟩⟩
end

lemma ker_prod_ker_le_ker_coprod {M₂ : Type*} [add_comm_group M₂] [module R M₂]
  {M₃ : Type*} [add_comm_group M₃] [module R M₃]
  (f : M →ₗ[R] M₃) (g : M₂ →ₗ[R] M₃) :
  (ker f).prod (ker g) ≤ ker (f.coprod g) :=
by { rintros ⟨y, z⟩, simp {contextual := tt} }

lemma ker_coprod_of_disjoint_range {M₂ : Type*} [add_comm_group M₂] [module R M₂]
  {M₃ : Type*} [add_comm_group M₃] [module R M₃]
  (f : M →ₗ[R] M₃) (g : M₂ →ₗ[R] M₃) (hd : disjoint f.range g.range) :
  ker (f.coprod g) = (ker f).prod (ker g) :=
begin
  apply le_antisymm _ (ker_prod_ker_le_ker_coprod f g),
  rintros ⟨y, z⟩ h,
  simp only [mem_ker, mem_prod, coprod_apply] at h ⊢,
  have : f y ∈ f.range ⊓ g.range,
  { simp only [true_and, mem_range, mem_inf, exists_apply_eq_apply],
    use -z,
    rwa [eq_comm, map_neg, ← sub_eq_zero, sub_neg_eq_add] },
  rw [hd.eq_bot, mem_bot] at this,
  rw [this] at h,
  simpa [this] using h,
end

end linear_map

namespace submodule
open linear_map

variables [semiring R]
variables [add_comm_monoid M] [add_comm_monoid M₂]
variables [module R M] [module R M₂]

lemma sup_eq_range (p q : submodule R M) : p ⊔ q = (p.subtype.coprod q.subtype).range :=
submodule.ext $ λ x, by simp [submodule.mem_sup, set_like.exists]

variables (p : submodule R M) (q : submodule R M₂)

@[simp] theorem map_inl : p.map (inl R M M₂) = prod p ⊥ :=
by { ext ⟨x, y⟩, simp only [and.left_comm, eq_comm, mem_map, prod.mk.inj_iff, inl_apply, mem_bot,
  exists_eq_left', mem_prod] }

@[simp] theorem map_inr : q.map (inr R M M₂) = prod ⊥ q :=
by ext ⟨x, y⟩; simp [and.left_comm, eq_comm]

@[simp] theorem comap_fst : p.comap (fst R M M₂) = prod p ⊤ :=
by ext ⟨x, y⟩; simp

@[simp] theorem comap_snd : q.comap (snd R M M₂) = prod ⊤ q :=
by ext ⟨x, y⟩; simp

@[simp] theorem prod_comap_inl : (prod p q).comap (inl R M M₂) = p := by ext; simp

@[simp] theorem prod_comap_inr : (prod p q).comap (inr R M M₂) = q := by ext; simp

@[simp] theorem prod_map_fst : (prod p q).map (fst R M M₂) = p :=
by ext x; simp [(⟨0, zero_mem _⟩ : ∃ x, x ∈ q)]

@[simp] theorem prod_map_snd : (prod p q).map (snd R M M₂) = q :=
by ext x; simp [(⟨0, zero_mem _⟩ : ∃ x, x ∈ p)]

@[simp] theorem ker_inl : (inl R M M₂).ker = ⊥ :=
by rw [ker, ← prod_bot, prod_comap_inl]

@[simp] theorem ker_inr : (inr R M M₂).ker = ⊥ :=
by rw [ker, ← prod_bot, prod_comap_inr]

@[simp] theorem range_fst : (fst R M M₂).range = ⊤ :=
by rw [range_eq_map, ← prod_top, prod_map_fst]

@[simp] theorem range_snd : (snd R M M₂).range = ⊤ :=
by rw [range_eq_map, ← prod_top, prod_map_snd]

end submodule

namespace linear_equiv
section

variables [semiring R]
variables [add_comm_monoid M] [add_comm_monoid M₂] [add_comm_monoid M₃] [add_comm_monoid M₄]
variables {module_M : module R M} {module_M₂ : module R M₂}
variables {module_M₃ : module R M₃} {module_M₄ : module R M₄}
variables (e₁ : M ≃ₗ[R] M₂) (e₂ : M₃ ≃ₗ[R] M₄)

/-- Product of linear equivalences; the maps come from `equiv.prod_congr`. -/
protected def prod :
  (M × M₃) ≃ₗ[R] (M₂ × M₄) :=
{ map_add'  := λ x y, prod.ext (e₁.map_add _ _) (e₂.map_add _ _),
  map_smul' := λ c x, prod.ext (e₁.map_smul c _) (e₂.map_smul c _),
  .. equiv.prod_congr e₁.to_equiv e₂.to_equiv }

lemma prod_symm : (e₁.prod e₂).symm = e₁.symm.prod e₂.symm := rfl

@[simp] lemma prod_apply (p) :
  e₁.prod e₂ p = (e₁ p.1, e₂ p.2) := rfl

@[simp, norm_cast] lemma coe_prod :
  (e₁.prod e₂ : (M × M₃) →ₗ[R] (M₂ × M₄)) = (e₁ : M →ₗ[R] M₂).prod_map (e₂ : M₃ →ₗ[R] M₄) := rfl

end

section
variables [semiring R]
variables [add_comm_monoid M] [add_comm_monoid M₂] [add_comm_monoid M₃] [add_comm_group M₄]
variables {module_M : module R M} {module_M₂ : module R M₂}
variables {module_M₃ : module R M₃} {module_M₄ : module R M₄}
variables (e₁ : M ≃ₗ[R] M₂) (e₂ : M₃ ≃ₗ[R] M₄)

/-- Equivalence given by a block lower diagonal matrix. `e₁` and `e₂` are diagonal square blocks,
  and `f` is a rectangular block below the diagonal. -/
protected def skew_prod (f : M →ₗ[R] M₄) :
  (M × M₃) ≃ₗ[R] M₂ × M₄ :=
{ inv_fun := λ p : M₂ × M₄, (e₁.symm p.1, e₂.symm (p.2 - f (e₁.symm p.1))),
  left_inv := λ p, by simp,
  right_inv := λ p, by simp,
  .. ((e₁ : M →ₗ[R] M₂).comp (linear_map.fst R M M₃)).prod
    ((e₂ : M₃ →ₗ[R] M₄).comp (linear_map.snd R M M₃) +
      f.comp (linear_map.fst R M M₃)) }

@[simp] lemma skew_prod_apply (f : M →ₗ[R] M₄) (x) :
  e₁.skew_prod e₂ f x = (e₁ x.1, e₂ x.2 + f x.1) := rfl

@[simp] lemma skew_prod_symm_apply (f : M →ₗ[R] M₄) (x) :
  (e₁.skew_prod e₂ f).symm x = (e₁.symm x.1, e₂.symm (x.2 - f (e₁.symm x.1))) := rfl

end
end linear_equiv

namespace linear_map
open submodule

variables [ring R]
variables [add_comm_group M] [add_comm_group M₂] [add_comm_group M₃]
variables [module R M] [module R M₂] [module R M₃]

/-- If the union of the kernels `ker f` and `ker g` spans the domain, then the range of
`prod f g` is equal to the product of `range f` and `range g`. -/
lemma range_prod_eq {f : M →ₗ[R] M₂} {g : M →ₗ[R] M₃} (h : ker f ⊔ ker g = ⊤) :
  range (prod f g) = (range f).prod (range g) :=
begin
  refine le_antisymm (f.range_prod_le g) _,
  simp only [set_like.le_def, prod_apply, mem_range, set_like.mem_coe, mem_prod, exists_imp_distrib,
    and_imp, prod.forall],
  rintros _ _ x rfl y rfl,
  simp only [prod.mk.inj_iff, ← sub_mem_ker_iff],
  have : y - x ∈ ker f ⊔ ker g, { simp only [h, mem_top] },
  rcases mem_sup.1 this with ⟨x', hx', y', hy', H⟩,
  refine ⟨x' + x, _, _⟩,
  { rwa add_sub_cancel },
  { rwa [← eq_sub_iff_add_eq.1 H, add_sub_add_right_eq_sub, ← neg_mem_iff, neg_sub,
      add_sub_cancel'] }
end

end linear_map


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

! This file was ported from Lean 3 source module order.category.Semilat
! leanprover-community/mathlib commit e8ac6315bcfcbaf2d19a046719c3b553206dac75
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Order.Category.PartOrd
import Mathbin.Order.Hom.Lattice

/-!
# The categories of semilattices

This defines `SemilatSup` and `SemilatInf`, the categories of sup-semilattices with a bottom
element and inf-semilattices with a top element.

## References

* [nLab, *semilattice*](https://ncatlab.org/nlab/show/semilattice)
-/

universe u

open CategoryTheory

/-- The category of sup-semilattices with a bottom element. -/
structure SemilatSup : Type (u + 1) where
  pt : Type u
  [isSemilatticeSup : SemilatticeSup X]
  [isOrderBot : OrderBot X]
#align SemilatSup SemilatSup

/-- The category of inf-semilattices with a top element. -/
structure SemilatInf : Type (u + 1) where
  pt : Type u
  [isSemilatticeInf : SemilatticeInf X]
  [isOrderTop : OrderTop X]
#align SemilatInf SemilatInf

attribute [protected] SemilatSup.X SemilatInf.X

namespace SemilatSup

instance : CoeSort SemilatSup (Type _) :=
  ⟨SemilatSup.X⟩

attribute [instance] is_semilattice_sup is_order_bot

/-- Construct a bundled `SemilatSup` from a `semilattice_sup`. -/
def of (α : Type _) [SemilatticeSup α] [OrderBot α] : SemilatSup :=
  ⟨α⟩
#align SemilatSup.of SemilatSup.of

@[simp]
theorem coe_of (α : Type _) [SemilatticeSup α] [OrderBot α] : ↥(of α) = α :=
  rfl
#align SemilatSup.coe_of SemilatSup.coe_of

instance : Inhabited SemilatSup :=
  ⟨of PUnit⟩

instance : LargeCategory.{u} SemilatSup
    where
  Hom X Y := SupBotHom X Y
  id X := SupBotHom.id X
  comp X Y Z f g := g.comp f
  id_comp' X Y := SupBotHom.comp_id
  comp_id' X Y := SupBotHom.id_comp
  assoc' W X Y Z _ _ _ := SupBotHom.comp_assoc _ _ _

instance : ConcreteCategory SemilatSup
    where
  forget :=
    { obj := SemilatSup.X
      map := fun X Y => coeFn }
  forget_faithful := ⟨fun X Y => FunLike.coe_injective⟩

instance hasForgetToPartOrd : HasForget₂ SemilatSup PartOrd
    where forget₂ :=
    { obj := fun X => ⟨X⟩
      map := fun X Y f => f }
#align SemilatSup.has_forget_to_PartOrd SemilatSup.hasForgetToPartOrd

@[simp]
theorem coe_forget_to_partOrd (X : SemilatSup) : ↥((forget₂ SemilatSup PartOrd).obj X) = ↥X :=
  rfl
#align SemilatSup.coe_forget_to_PartOrd SemilatSup.coe_forget_to_partOrd

end SemilatSup

namespace SemilatInf

instance : CoeSort SemilatInf (Type _) :=
  ⟨SemilatInf.X⟩

attribute [instance] is_semilattice_inf is_order_top

/-- Construct a bundled `SemilatInf` from a `semilattice_inf`. -/
def of (α : Type _) [SemilatticeInf α] [OrderTop α] : SemilatInf :=
  ⟨α⟩
#align SemilatInf.of SemilatInf.of

@[simp]
theorem coe_of (α : Type _) [SemilatticeInf α] [OrderTop α] : ↥(of α) = α :=
  rfl
#align SemilatInf.coe_of SemilatInf.coe_of

instance : Inhabited SemilatInf :=
  ⟨of PUnit⟩

instance : LargeCategory.{u} SemilatInf
    where
  Hom X Y := InfTopHom X Y
  id X := InfTopHom.id X
  comp X Y Z f g := g.comp f
  id_comp' X Y := InfTopHom.comp_id
  comp_id' X Y := InfTopHom.id_comp
  assoc' W X Y Z _ _ _ := InfTopHom.comp_assoc _ _ _

instance : ConcreteCategory SemilatInf
    where
  forget :=
    { obj := SemilatInf.X
      map := fun X Y => coeFn }
  forget_faithful := ⟨fun X Y => FunLike.coe_injective⟩

instance hasForgetToPartOrd : HasForget₂ SemilatInf PartOrd
    where forget₂ :=
    { obj := fun X => ⟨X⟩
      map := fun X Y f => f }
#align SemilatInf.has_forget_to_PartOrd SemilatInf.hasForgetToPartOrd

@[simp]
theorem coe_forget_to_partOrd (X : SemilatInf) : ↥((forget₂ SemilatInf PartOrd).obj X) = ↥X :=
  rfl
#align SemilatInf.coe_forget_to_PartOrd SemilatInf.coe_forget_to_partOrd

end SemilatInf

/-! ### Order dual -/

namespace SemilatSup

/-- Constructs an isomorphism of lattices from an order isomorphism between them. -/
@[simps]
def Iso.mk {α β : SemilatSup.{u}} (e : α ≃o β) : α ≅ β
    where
  Hom := e
  inv := e.symm
  hom_inv_id' := by
    ext
    exact e.symm_apply_apply _
  inv_hom_id' := by
    ext
    exact e.apply_symm_apply _
#align SemilatSup.iso.mk SemilatSup.Iso.mk

/-- `order_dual` as a functor. -/
@[simps]
def dual : SemilatSup ⥤ SemilatInf
    where
  obj X := SemilatInf.of Xᵒᵈ
  map X Y := SupBotHom.dual
#align SemilatSup.dual SemilatSup.dual

end SemilatSup

namespace SemilatInf

/-- Constructs an isomorphism of lattices from an order isomorphism between them. -/
@[simps]
def Iso.mk {α β : SemilatInf.{u}} (e : α ≃o β) : α ≅ β
    where
  Hom := e
  inv := e.symm
  hom_inv_id' := by
    ext
    exact e.symm_apply_apply _
  inv_hom_id' := by
    ext
    exact e.apply_symm_apply _
#align SemilatInf.iso.mk SemilatInf.Iso.mk

/-- `order_dual` as a functor. -/
@[simps]
def dual : SemilatInf ⥤ SemilatSup
    where
  obj X := SemilatSup.of Xᵒᵈ
  map X Y := InfTopHom.dual
#align SemilatInf.dual SemilatInf.dual

end SemilatInf

/-- The equivalence between `SemilatSup` and `SemilatInf` induced by `order_dual` both ways.
-/
@[simps Functor inverse]
def semilatSupEquivSemilatInf : SemilatSup ≌ SemilatInf :=
  Equivalence.mk SemilatSup.dual SemilatInf.dual
    (NatIso.ofComponents (fun X => SemilatSup.Iso.mk <| OrderIso.dualDual X) fun X Y f => rfl)
    (NatIso.ofComponents (fun X => SemilatInf.Iso.mk <| OrderIso.dualDual X) fun X Y f => rfl)
#align SemilatSup_equiv_SemilatInf semilatSupEquivSemilatInf

theorem semilatSup_dual_comp_forget_to_partOrd :
    SemilatSup.dual ⋙ forget₂ SemilatInf PartOrd = forget₂ SemilatSup PartOrd ⋙ PartOrd.dual :=
  rfl
#align SemilatSup_dual_comp_forget_to_PartOrd semilatSup_dual_comp_forget_to_partOrd

theorem semilatInf_dual_comp_forget_to_partOrd :
    SemilatInf.dual ⋙ forget₂ SemilatSup PartOrd = forget₂ SemilatInf PartOrd ⋙ PartOrd.dual :=
  rfl
#align SemilatInf_dual_comp_forget_to_PartOrd semilatInf_dual_comp_forget_to_partOrd


-- auxilliary definitions and lemmas used for termination of QI

import .definitions1

def prop.num_quantifiers: prop → ℕ
| (prop.term t)        := 0
| (prop.not P)         := P.num_quantifiers
| (prop.and P₁ P₂)     := P₁.num_quantifiers + P₂.num_quantifiers
| (prop.or P₁ P₂)      := P₁.num_quantifiers + P₂.num_quantifiers
| (prop.pre t₁ t₂)     := 0
| (prop.pre₁ op t)     := 0
| (prop.pre₂ op t₁ t₂) := 0
| (prop.post t₁ t₂)    := 0
| (prop.call t)        := 0
| (prop.forallc x P)   := 1 + P.num_quantifiers
| (prop.exis x P)      := 1 + P.num_quantifiers

lemma same_num_quantifiers_after_substt {P: prop} {x y: var}:
      P.num_quantifiers = (P.substt x y).num_quantifiers :=
  begin
    induction P,
    case prop.term t {
      unfold prop.substt,
      change (
        prop.num_quantifiers (prop.term t) =
        prop.num_quantifiers (prop.term (term.substt x y t))
      ),
      unfold prop.num_quantifiers
    },
    case prop.not P₁ ih {
      unfold prop.substt,
      unfold prop.num_quantifiers,
      from ih
    },
    case prop.and P₁ P₂ P₁_ih P₂_ih {
      unfold prop.substt,
      change (
        prop.num_quantifiers (prop.and P₁ P₂) =
        prop.num_quantifiers (prop.and (prop.substt x y P₁) (prop.substt x y P₂))
      ),
      unfold prop.num_quantifiers,
      rw[P₁_ih],
      rw[P₂_ih]
    },
    case prop.or P₁ P₂ P₁_ih P₂_ih {
      unfold prop.substt,
      change (
        prop.num_quantifiers (prop.or P₁ P₂) =
        prop.num_quantifiers (prop.or (prop.substt x y P₁) (prop.substt x y P₂))
      ),
      unfold prop.num_quantifiers,
      rw[P₁_ih],
      rw[P₂_ih]
    },
    case prop.pre t₁ t₂ {
      unfold prop.substt,
      unfold prop.num_quantifiers
    },
    case prop.pre₁ op t {
      unfold prop.substt,
      unfold prop.num_quantifiers
    },
    case prop.pre₂ op t₁ t₂ {
      unfold prop.substt,
      unfold prop.num_quantifiers
    },
    case prop.call t {
      unfold prop.substt,
      unfold prop.num_quantifiers
    },
    case prop.post t₁ t₂ {
      unfold prop.substt,
      unfold prop.num_quantifiers
    },
    case prop.forallc y P₁ P₁_ih {
      unfold prop.substt,
      by_cases (x = y) with h,

      simp[h],

      simp[h],
      unfold prop.num_quantifiers,
      apply eq_add_left_of_eq,
      from P₁_ih
    },
    case prop.exis y P' P'_ih {
      unfold prop.substt,
      by_cases (x = y) with h,

      simp[h],

      simp[h],
      unfold prop.num_quantifiers,
      apply eq_add_left_of_eq,
      from P'_ih
    }
  end

lemma lifted_prop_smaller {P: prop} {x: var}:
      ∀P', ((P.lift_p x = some P') → (P'.num_quantifiers < P.num_quantifiers)) ∧
           ((P.lift_n x = some P') → (P'.num_quantifiers < P.num_quantifiers)) :=
  begin
    induction P,
    case prop.term t {
      assume P',
      split,

      assume h1,
      unfold prop.lift_p at h1,
      contradiction,

      assume h1,
      unfold prop.lift_n at h1,
      contradiction
    },
    case prop.not P₁ ih {
      assume P',
      split,

      assume h1,
      unfold prop.lift_p at h1,
      cases h2: prop.lift_n P₁ x,

      simp[h2] at h1,
      cases h1,

      have h3, from (ih a).right h2,
      simp[h2] at h1,
      cases h1,
      unfold prop.num_quantifiers,
      from h3,

      assume h1,
      unfold prop.lift_n at h1,
      cases h2: prop.lift_p P₁ x,

      simp[h2] at h1,
      cases h1,

      have h3, from (ih a).left h2,
      simp[h2] at h1,
      cases h1,
      unfold prop.num_quantifiers,
      from h3
    },
    case prop.and P₁ P₂ P₁_ih P₂_ih {
      assume P',
      split,

      assume h1,
      unfold prop.lift_p at h1,
      cases h2: prop.lift_p P₁ x,

      simp[h2] at h1,
      cases h3: prop.lift_p P₂ x,
      simp[h3] at h1,
      cases h1,

      simp[h3] at h1,
      cases h1,
      have h3, from (P₂_ih a).left h3,
      unfold prop.num_quantifiers,
      apply nat.add_lt_add_left,
      from h3,

      simp[h2] at h1,
      cases h1,
      unfold prop.num_quantifiers,
      apply nat.add_lt_add_right,
      from (P₁_ih a).left h2,

      assume h1,
      unfold prop.lift_n at h1,
      cases h2: prop.lift_n P₁ x,

      simp[h2] at h1,
      cases h3: prop.lift_n P₂ x,
      simp[h3] at h1,
      cases h1,

      simp[h3] at h1,
      cases h1,
      have h3, from (P₂_ih a).right h3,
      unfold prop.num_quantifiers,
      apply nat.add_lt_add_left,
      from h3,

      simp[h2] at h1,
      cases h1,
      unfold prop.num_quantifiers,
      apply nat.add_lt_add_right,
      from (P₁_ih a).right h2
    },
    case prop.or P₁ P₂ P₁_ih P₂_ih {
      assume P',
      split,

      assume h1,
      unfold prop.lift_p at h1,
      cases h2: prop.lift_p P₁ x,

      simp[h2] at h1,
      cases h3: prop.lift_p P₂ x,
      simp[h3] at h1,
      cases h1,

      simp[h3] at h1,
      cases h1,
      have h3, from (P₂_ih a).left h3,
      unfold prop.num_quantifiers,
      apply nat.add_lt_add_left,
      from h3,

      simp[h2] at h1,
      cases h1,
      unfold prop.num_quantifiers,
      apply nat.add_lt_add_right,
      from (P₁_ih a).left h2,

      assume h1,
      unfold prop.lift_n at h1,
      cases h2: prop.lift_n P₁ x,

      simp[h2] at h1,
      cases h3: prop.lift_n P₂ x,
      simp[h3] at h1,
      cases h1,

      simp[h3] at h1,
      cases h1,
      have h3, from (P₂_ih a).right h3,
      unfold prop.num_quantifiers,
      apply nat.add_lt_add_left,
      from h3,

      simp[h2] at h1,
      cases h1,
      unfold prop.num_quantifiers,
      apply nat.add_lt_add_right,
      from (P₁_ih a).right h2
    },
    case prop.pre t₁ t₂ {
      assume P',
      split,

      assume h1,
      unfold prop.lift_p at h1,
      contradiction,

      assume h1,
      unfold prop.lift_n at h1,
      contradiction
    },
    case prop.pre₁ op t {
      assume P',
      split,

      assume h1,
      unfold prop.lift_p at h1,
      contradiction,

      assume h1,
      unfold prop.lift_n at h1,
      contradiction
    },
    case prop.pre₂ op t₁ t₂ {
      assume P',
      split,

      assume h1,
      unfold prop.lift_p at h1,
      contradiction,

      assume h1,
      unfold prop.lift_n at h1,
      contradiction
    },
    case prop.call t {
      assume P',
      split,

      assume h1,
      unfold prop.lift_p at h1,
      contradiction,

      assume h1,
      unfold prop.lift_n at h1,
      contradiction
    },
    case prop.post t₁ t₂ {
      assume P',
      split,

      assume h1,
      unfold prop.lift_p at h1,
      contradiction,

      assume h1,
      unfold prop.lift_n at h1,
      contradiction
    },
    case prop.forallc y P₁ P₁_ih {
      assume P',
      split,

      assume h1,
      unfold prop.lift_p at h1,
      have h2, from option.some.inj h1,
      simp[h2.symm],
      unfold prop.num_quantifiers,
      have h3: (prop.num_quantifiers P₁ = prop.num_quantifiers (prop.substt y x P₁)),
      from same_num_quantifiers_after_substt,
      rw[←h3],
      simp,
      from lt_of_add_one,

      assume h1,
      unfold prop.lift_n at h1,
      contradiction
    },
    case prop.exis y P₁ P₁_ih {
      assume P',
      split,

      assume h1,
      unfold prop.lift_p at h1,
      contradiction,

      assume h1,
      unfold prop.lift_n at h1,
      contradiction
    }
  end

def erased_measure : has_well_founded
      (psum prop prop)
:= ⟨_, measure_wf $ λ s,
  match s with
  | psum.inl a := a.sizeof
  | psum.inr a := a.sizeof
  end⟩

def instantiate_with_measure : has_well_founded
      (psum (Σ' (p : prop), calltrigger)
            (Σ' (p : prop), calltrigger))
:= ⟨_, measure_wf $ λ s,
  match s with
  | psum.inl a := a.1.sizeof
  | psum.inr a := a.1.sizeof
  end⟩

def find_calls_measure : has_well_founded
      (psum prop prop)
:= ⟨_, measure_wf $ λ s,
  match s with
  | psum.inl a := a.sizeof
  | psum.inr a := a.sizeof
  end⟩

def prop.simplesize: prop → ℕ
| (prop.term t)        := 0
| (prop.not P)         := 1 + P.simplesize
| (prop.and P₁ P₂)     := 1 + P₁.simplesize + P₂.simplesize
| (prop.or P₁ P₂)      := 1 + P₁.simplesize + P₂.simplesize
| (prop.pre t₁ t₂)     := 0
| (prop.pre₁ op t)     := 0
| (prop.pre₂ op t₁ t₂) := 0
| (prop.call t)        := 0
| (prop.post t₁ t₂)    := 0
| (prop.forallc x P)   := 1 + P.simplesize
| (prop.exis x P)      := 1 + P.simplesize

lemma same_simplesize_after_subst {P: prop} {x: var} {v: value}:
      P.simplesize = (prop.subst x v P).simplesize :=
  begin
    induction P,
    case prop.term t {
      unfold prop.subst,
      unfold prop.simplesize,
      change (0 = prop.simplesize (prop.term (term.subst x v t))),
      unfold prop.simplesize
    },
    case prop.not P₁ ih {
      unfold prop.subst,
      unfold prop.simplesize,
      rw[ih]
    },
    case prop.and P₁ P₂ P₁_ih P₂_ih {
      unfold prop.subst,
      unfold prop.simplesize,
      change (prop.simplesize (prop.and P₁ P₂) = prop.simplesize (prop.and (prop.subst x v P₁) (prop.subst x v P₂))),
      unfold prop.simplesize,
      rw[P₁_ih],
      rw[P₂_ih]
    },
    case prop.or P₁ P₂ P₁_ih P₂_ih {
      unfold prop.subst,
      unfold prop.simplesize,
      change (prop.simplesize (prop.or P₁ P₂) = prop.simplesize (prop.or (prop.subst x v P₁) (prop.subst x v P₂))),
      unfold prop.simplesize,
      rw[P₁_ih],
      rw[P₂_ih]
    },
    case prop.pre t₁ t₂ {
      unfold prop.subst,
      unfold prop.simplesize
    },
    case prop.pre₁ op t {
      unfold prop.subst,
      unfold prop.simplesize
    },
    case prop.pre₂ op t₁ t₂ {
      unfold prop.subst,
      unfold prop.simplesize
    },
    case prop.call t {
      unfold prop.subst,
      unfold prop.simplesize
    },
    case prop.post t₁ t₂ {
      unfold prop.subst,
      unfold prop.simplesize
    },
    case prop.forallc z P' P'_ih {
      unfold prop.subst,
      unfold prop.simplesize,
      apply eq_add_left_of_eq,
      by_cases (x = z) with h1,
      simp[h1],
      simp[h1],
      from P'_ih
    },
    case prop.exis z P' P'_ih {
      unfold prop.subst,
      unfold prop.simplesize,
      apply eq_add_left_of_eq,
      by_cases (x = z) with h1,
      simp[h1],
      simp[h1],
      from P'_ih
    }
  end

lemma simplesize_prop_not {P: prop}:
      P.simplesize < P.not.simplesize :=
  begin
    unfold prop.simplesize,
    rw[add_comm],
    apply lt_add_of_pos_right,
    from zero_lt_one
  end

lemma simplesize_prop_and₁ {P S: prop}:
      P.simplesize < (prop.and P S).simplesize :=
  begin
    unfold prop.simplesize,
    rw[add_assoc],
    rw[add_comm],
    rw[add_assoc],
    apply lt_add_of_pos_right,
    change 0 < prop.simplesize S + 1,
    apply lt_add_of_le_of_pos nonneg_of_nat,
    from zero_lt_one
  end

lemma simplesize_prop_and₂ {P S: prop}:
      S.simplesize < (prop.and P S).simplesize :=
  begin
    unfold prop.simplesize,
    rw[add_comm],
    apply lt_add_of_pos_right,
    change 0 < 1 + prop.simplesize P,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    from zero_lt_one
  end

lemma simplesize_prop_or₁ {P S: prop}:
      P.simplesize < (prop.or P S).simplesize :=
  begin
    unfold prop.simplesize,
    rw[add_assoc],
    rw[add_comm],
    rw[add_assoc],
    apply lt_add_of_pos_right,
    change 0 < prop.simplesize S + 1,
    apply lt_add_of_le_of_pos nonneg_of_nat,
    from zero_lt_one
  end

lemma simplesize_prop_or₂ {P S: prop}:
      S.simplesize < (prop.or P S).simplesize :=
  begin
    unfold prop.simplesize,
    rw[add_comm],
    apply lt_add_of_pos_right,
    change 0 < 1 + prop.simplesize P,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    from zero_lt_one
  end

lemma simplesize_prop_exis {P: prop} {x: var}:
      P.simplesize < (prop.exis x P).simplesize :=
  begin
    unfold prop.simplesize,
    rw[add_comm],
    apply lt_add_of_pos_right,
    from zero_lt_one
  end

lemma simplesize_prop_forall {P: prop} {x: var}:
      P.simplesize < (prop.forallc x P).simplesize :=
  begin
    unfold prop.simplesize,
    rw[add_comm],
    apply lt_add_of_pos_right,
    from zero_lt_one
  end


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import topology.sheaves.sheaf_condition.sites
import category_theory.sites.limits
import category_theory.adjunction
import category_theory.limits.functor_category

/-!
# Presheaves in `C` have limits and colimits when `C` does.
-/

noncomputable theory

universes v u

open category_theory
open category_theory.limits

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

namespace Top

instance [has_limits C] (X : Top) : has_limits (presheaf C X) :=
by { dsimp [presheaf], apply_instance, }

instance [has_colimits C] (X : Top) : has_colimits (presheaf C X) :=
by { dsimp [presheaf], apply_instance, }

instance [has_limits C] (X : Top) : creates_limits (sheaf.forget C X) :=
(@@creates_limits_of_nat_iso _ _
  (presheaf.Sheaf_spaces_equiv_sheaf_sites_inverse_forget C X))
  (@@category_theory.comp_creates_limits _ _ _ _ _ _
    Sheaf.category_theory.Sheaf_to_presheaf.category_theory.creates_limits.{u v v})

instance [has_limits C] (X : Top) : has_limits (sheaf C X) :=
has_limits_of_has_limits_creates_limits (sheaf.forget C X)

lemma is_sheaf_of_is_limit [has_limits C] {X : Top} (F : J ⥤ presheaf C X)
  (H : ∀ j, (F.obj j).is_sheaf) {c : cone F} (hc : is_limit c) : c.X.is_sheaf :=
begin
  let F' : J ⥤ sheaf C X := { obj := λ j, ⟨F.obj j, H j⟩, map := F.map },
  let e : F' ⋙ sheaf.forget C X ≅ F := nat_iso.of_components (λ _, iso.refl _) (by tidy),
  exact presheaf.is_sheaf_of_iso ((is_limit_of_preserves (sheaf.forget C X)
      (limit.is_limit F')).cone_points_iso_of_nat_iso hc e) (limit F').2
end

lemma limit_is_sheaf [has_limits C] {X : Top} (F : J ⥤ presheaf C X)
  (H : ∀ j, (F.obj j).is_sheaf) : (limit F).is_sheaf :=
is_sheaf_of_is_limit F H (limit.is_limit F)

end Top


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Johan Commelin
-/
import order.with_bot
import algebra.ring.defs

/-!
# Adjoining a zero/one to semigroups and related algebraic structures

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

This file contains different results about adjoining an element to an algebraic structure which then
behaves like a zero or a one. An example is adjoining a one to a semigroup to obtain a monoid. That
this provides an example of an adjunction is proved in `algebra.category.Mon.adjunctions`.

Another result says that adjoining to a group an element `zero` gives a `group_with_zero`. For more
information about these structures (which are not that standard in informal mathematics, see
`algebra.group_with_zero.basic`)

## Implementation notes

At various points in this file, `id $` is used in at the start of a proof field in a structure. This
ensures that the generated `_proof_1` lemmas are stated in terms of the algebraic operations and
not `option.map`, as the latter does not typecheck once `with_zero`/`with_one` is irreducible.
-/

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

/-- Add an extra element `1` to a type -/
@[to_additive "Add an extra element `0` to a type"]
def with_one (α) := option α

namespace with_one

instance [has_repr α] : has_repr (with_zero α) :=
⟨λ o, match o with | none := "0" | (some a) := "↑" ++ repr a end⟩

@[to_additive]
instance [has_repr α] : has_repr (with_one α) :=
⟨λ o, match o with | none := "1" | (some a) := "↑" ++ repr a end⟩

@[to_additive]
instance : monad with_one := option.monad

@[to_additive]
instance : has_one (with_one α) := ⟨none⟩

@[to_additive]
instance [has_mul α] : has_mul (with_one α) := ⟨option.lift_or_get (*)⟩

@[to_additive] instance [has_inv α] : has_inv (with_one α) := ⟨λ a, option.map has_inv.inv a⟩

@[to_additive] instance [has_involutive_inv α] : has_involutive_inv (with_one α) :=
{ inv_inv := id $ λ a, (option.map_map _ _ _).trans $ by simp_rw [inv_comp_inv, option.map_id, id],
  ..with_one.has_inv }

@[to_additive] instance [has_inv α] : inv_one_class (with_one α) :=
{ inv_one := rfl,
  ..with_one.has_one,
  ..with_one.has_inv }

@[to_additive]
instance : inhabited (with_one α) := ⟨1⟩

@[to_additive]
instance [nonempty α] : nontrivial (with_one α) := option.nontrivial

@[to_additive]
instance : has_coe_t α (with_one α) := ⟨some⟩

/-- Recursor for `with_one` using the preferred forms `1` and `↑a`. -/
@[elab_as_eliminator,
  to_additive "Recursor for `with_zero` using the preferred forms `0` and `↑a`."]
def rec_one_coe {C : with_one α → Sort*} (h₁ : C 1) (h₂ : Π (a : α), C a) :
  Π (n : with_one α), C n :=
option.rec h₁ h₂

/-- Deconstruct a `x : with_one α` to the underlying value in `α`, given a proof that `x ≠ 1`. -/
@[to_additive unzero
  "Deconstruct a `x : with_zero α` to the underlying value in `α`, given a proof that `x ≠ 0`."]
def unone {x : with_one α} (hx : x ≠ 1) : α := with_bot.unbot x hx

@[simp, to_additive unzero_coe]
lemma unone_coe {x : α} (hx : (x : with_one α) ≠ 1) : unone hx = x := rfl

@[simp, to_additive coe_unzero]
lemma coe_unone {x : with_one α} (hx : x ≠ 1) : ↑(unone hx) = x := with_bot.coe_unbot x hx

@[to_additive]
lemma some_eq_coe {a : α} : (some a : with_one α) = ↑a := rfl

@[simp, to_additive]
lemma coe_ne_one {a : α} : (a : with_one α) ≠ (1 : with_one α) :=
option.some_ne_none a

@[simp, to_additive]
lemma one_ne_coe {a : α} : (1 : with_one α) ≠ a :=
coe_ne_one.symm

@[to_additive]
lemma ne_one_iff_exists {x : with_one α} : x ≠ 1 ↔ ∃ (a : α), ↑a = x :=
option.ne_none_iff_exists

@[to_additive]
instance can_lift : can_lift (with_one α) α coe (λ a, a ≠ 1) :=
{ prf := λ a, ne_one_iff_exists.1 }

@[simp, norm_cast, to_additive]
lemma coe_inj {a b : α} : (a : with_one α) = b ↔ a = b :=
option.some_inj

@[elab_as_eliminator, to_additive]
protected lemma cases_on {P : with_one α → Prop} :
  ∀ (x : with_one α), P 1 → (∀ a : α, P a) → P x :=
option.cases_on

@[to_additive]
instance [has_mul α] : mul_one_class (with_one α) :=
{ mul := (*),
  one := (1),
  one_mul := id $ (option.lift_or_get_is_left_id _).1,
  mul_one := id $ (option.lift_or_get_is_right_id _).1 }

@[to_additive]
instance [semigroup α] : monoid (with_one α) :=
{ mul_assoc := (option.lift_or_get_assoc _).1,
  ..with_one.mul_one_class }

example [semigroup α] :
  @monoid.to_mul_one_class _ (@with_one.monoid α _) = @with_one.mul_one_class α _ := rfl

@[to_additive]
instance [comm_semigroup α] : comm_monoid (with_one α) :=
{ mul_comm := (option.lift_or_get_comm _).1,
  ..with_one.monoid }

attribute [irreducible] with_one

@[simp, norm_cast, to_additive]
lemma coe_mul [has_mul α] (a b : α) : ((a * b : α) : with_one α) = a * b := rfl

@[simp, norm_cast, to_additive]

end with_one

namespace with_zero

instance [one : has_one α] : has_one (with_zero α) :=
{ ..one }

@[simp, norm_cast] lemma coe_one [has_one α] : ((1 : α) : with_zero α) = 1 := rfl

instance [has_mul α] : mul_zero_class (with_zero α) :=
{ mul       := option.map₂ (*),
  zero_mul  := id $ option.map₂_none_left (*),
  mul_zero  := id $ option.map₂_none_right (*),
  ..with_zero.has_zero }

@[simp, norm_cast] lemma coe_mul {α : Type u} [has_mul α]
  {a b : α} : ((a * b : α) : with_zero α) = a * b := rfl

instance [has_mul α] : no_zero_divisors (with_zero α) :=
⟨λ a b, id $ option.map₂_eq_none_iff.1⟩

instance [semigroup α] : semigroup_with_zero (with_zero α) :=
{ mul_assoc := id $ λ _ _ _, option.map₂_assoc mul_assoc,
  ..with_zero.mul_zero_class }

instance [comm_semigroup α] : comm_semigroup (with_zero α) :=
{ mul_comm := id $ λ _ _, option.map₂_comm mul_comm,
  ..with_zero.semigroup_with_zero }

instance [mul_one_class α] : mul_zero_one_class (with_zero α) :=
{ one_mul := id $ option.map₂_left_identity one_mul,
  mul_one := id $ option.map₂_right_identity mul_one,
  ..with_zero.mul_zero_class,
  ..with_zero.has_one }

instance [has_one α] [has_pow α ℕ] : has_pow (with_zero α) ℕ :=
⟨λ x n, match x, n with
  | none, 0 := 1
  | none, n + 1 := 0
  | some x, n := ↑(x ^ n)
  end⟩

@[simp, norm_cast] lemma coe_pow [has_one α] [has_pow α ℕ] {a : α} (n : ℕ) :
  ↑(a ^ n : α) = (↑a ^ n : with_zero α) := rfl

instance [monoid α] : monoid_with_zero (with_zero α) :=
{ npow := λ n x, x ^ n,
  npow_zero' := λ x, match x with
    | none   := rfl
    | some x := congr_arg some $ pow_zero _
    end,
  npow_succ' := λ n x, match x with
    | none   := rfl
    | some x := congr_arg some $ pow_succ _ _
    end,
  .. with_zero.mul_zero_one_class,
  .. with_zero.semigroup_with_zero }

instance [comm_monoid α] : comm_monoid_with_zero (with_zero α) :=
{ ..with_zero.monoid_with_zero, ..with_zero.comm_semigroup }

/-- Given an inverse operation on `α` there is an inverse operation
  on `with_zero α` sending `0` to `0`-/
instance [has_inv α] : has_inv (with_zero α) := ⟨λ a, option.map has_inv.inv a⟩

@[simp, norm_cast] lemma coe_inv [has_inv α] (a : α) : ((a⁻¹ : α) : with_zero α) = a⁻¹ := rfl

@[simp] lemma inv_zero [has_inv α] : (0 : with_zero α)⁻¹ = 0 := rfl

instance [has_involutive_inv α] : has_involutive_inv (with_zero α) :=
{ inv_inv := id $ λ a, (option.map_map _ _ _).trans $ by simp_rw [inv_comp_inv, option.map_id, id],
  ..with_zero.has_inv }

instance [inv_one_class α] : inv_one_class (with_zero α) :=
{ inv_one := show ((1⁻¹ : α) : with_zero α) = 1, by simp,
  ..with_zero.has_one,
  ..with_zero.has_inv }

instance [has_div α] : has_div (with_zero α) := ⟨option.map₂ (/)⟩

@[norm_cast] lemma coe_div [has_div α] (a b : α) : ↑(a / b : α) = (a / b : with_zero α) := rfl

instance [has_one α] [has_pow α ℤ] : has_pow (with_zero α) ℤ :=
⟨λ x n, match x, n with
  | none, int.of_nat 0            := 1
  | none, int.of_nat (nat.succ n) := 0
  | none, int.neg_succ_of_nat n   := 0
  | some x, n                     := ↑(x ^ n)
  end⟩

@[simp, norm_cast] lemma coe_zpow [div_inv_monoid α] {a : α} (n : ℤ) :
  ↑(a ^ n : α) = (↑a ^ n : with_zero α) := rfl

instance [div_inv_monoid α] : div_inv_monoid (with_zero α) :=
{ div_eq_mul_inv := λ a b, match a, b with
    | none,   _      := rfl
    | some a, none   := rfl
    | some a, some b := congr_arg some (div_eq_mul_inv _ _)
    end,
  zpow := λ n x, x ^ n,
  zpow_zero' := λ x, match x with
    | none   := rfl
    | some x := congr_arg some $ zpow_zero _
    end,
  zpow_succ' := λ n x, match x with
    | none   := rfl
    | some x := congr_arg some $ div_inv_monoid.zpow_succ' _ _
    end,
  zpow_neg' := λ n x, match x with
    | none   := rfl
    | some x := congr_arg some $ div_inv_monoid.zpow_neg' _ _
    end,
  .. with_zero.has_div,
  .. with_zero.has_inv,
  .. with_zero.monoid_with_zero, }

instance [div_inv_one_monoid α] : div_inv_one_monoid (with_zero α) :=
{ ..with_zero.div_inv_monoid,
  ..with_zero.inv_one_class }

instance [division_monoid α] : division_monoid (with_zero α) :=
{ mul_inv_rev := λ a b, match a, b with
    | none,   none   := rfl
    | none,   some b := rfl
    | some a, none   := rfl
    | some a, some b := congr_arg some $ mul_inv_rev _ _
    end,
  inv_eq_of_mul := λ a b, match a, b with
    | none,   none   := λ _, rfl
    | none,   some b := by contradiction
    | some a, none   := by contradiction
    | some a, some b := λ h, congr_arg some $ inv_eq_of_mul_eq_one_right $ option.some_injective _ h
    end,
  .. with_zero.div_inv_monoid, .. with_zero.has_involutive_inv }

instance [division_comm_monoid α] : division_comm_monoid (with_zero α) :=
{ .. with_zero.division_monoid, .. with_zero.comm_semigroup }

section group
variables [group α]

/-- if `G` is a group then `with_zero G` is a group with zero. -/
instance : group_with_zero (with_zero α) :=
{ inv_zero := inv_zero,
  mul_inv_cancel := λ a ha, by { lift a to α using ha, norm_cast, apply mul_right_inv },
  .. with_zero.monoid_with_zero,
  .. with_zero.div_inv_monoid,
  .. with_zero.nontrivial }

end group

instance [comm_group α] : comm_group_with_zero (with_zero α) :=
{ .. with_zero.group_with_zero, .. with_zero.comm_monoid_with_zero }

instance [add_monoid_with_one α] : add_monoid_with_one (with_zero α) :=
{ nat_cast := λ n, if n = 0 then 0 else (n.cast : α),
  nat_cast_zero := rfl,
  nat_cast_succ := λ n, begin
    cases n,
    show (((1 : ℕ) : α) : with_zero α) = 0 + 1, by rw [nat.cast_one, coe_one, zero_add],
    show (((n + 2 : ℕ) : α) : with_zero α) = ((n + 1 : ℕ) : α) + 1,
    by rw [nat.cast_succ, coe_add, coe_one],
  end,
  .. with_zero.add_monoid, ..with_zero.has_one }

instance [semiring α] : semiring (with_zero α) :=
{ left_distrib := λ a b c, begin
    cases a with a, {refl},
    cases b with b; cases c with c; try {refl},
    exact congr_arg some (left_distrib _ _ _)
  end,
  right_distrib := λ a b c, begin
    cases c with c,
    { change (a + b) * 0 = a * 0 + b * 0, simp },
    cases a with a; cases b with b; try {refl},
    exact congr_arg some (right_distrib _ _ _)
  end,
  ..with_zero.add_monoid_with_one,
  ..with_zero.add_comm_monoid,
  ..with_zero.mul_zero_class,
  ..with_zero.monoid_with_zero }

attribute [irreducible] with_zero

end with_zero


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

/-!
# The four lemma

Consider the following commutative diagram with exact rows in an abelian category:

A ---f--> B ---g--> C ---h--> D
|         |         |         |
α         β         γ         δ
|         |         |         |
v         v         v         v
A' --f'-> B' --g'-> C' --h'-> D'

We prove the "mono" version of the four lemma: if α is an epimorphism and β and δ are monomorphisms,
then γ is a monomorphism.

## Future work

The "epi" four lemma and the five lemma, which is then an easy corollary.

## Tags

four lemma, diagram lemma, diagram chase
-/
open category_theory
open category_theory.abelian.pseudoelement

universes v u

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

local attribute [instance] preadditive.has_equalizers_of_has_kernels
local attribute [instance] object_to_sort hom_to_fun

namespace category_theory.abelian

variables {A B C D A' B' C' D' : V}
variables {f : A ⟶ B} {g : B ⟶ C} {h : C ⟶ D}
variables {f' : A' ⟶ B'} {g' : B' ⟶ C'} {h' : C' ⟶ D'}
variables {α : A ⟶ A'} {β : B ⟶ B'} {γ : C ⟶ C'} {δ : D ⟶ D'}
variables [exact f g] [exact g h] [exact f' g']
variables (comm₁ : α ≫ f' = f ≫ β) (comm₂ : β ≫ g' = g ≫ γ) (comm₃ : γ ≫ h' = h ≫ δ)
include comm₁ comm₂ comm₃

/-- The four lemma, mono version. For names of objects and morphisms, consider the following
    diagram:

```
A ---f--> B ---g--> C ---h--> D
|         |         |         |
α         β         γ         δ
|         |         |         |
v         v         v         v
A' --f'-> B' --g'-> C' --h'-> D'
```
-/

end category_theory.abelian


/-
Copyright (c) 2019 Seul Baek. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Seul Baek
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.list.func
import Mathlib.tactic.ring
import Mathlib.tactic.omega.misc
import Mathlib.PostPort

namespace Mathlib

/-
Non-constant terms of linear constraints are represented
by storing their coefficients in integer lists.
-/

namespace omega

namespace coeffs

/-- `val_between v as l o` is the value (under valuation `v`) of the term
    obtained taking the term represented by `(0, as)` and dropping all
    subterms that include variables outside the range `[l,l+o)` -/
@[simp] def val_between (v : ℕ → ℤ) (as : List ℤ) (l : ℕ) : ℕ → ℤ :=
  sorry

@[simp] theorem val_between_nil {v : ℕ → ℤ} {l : ℕ} (m : ℕ) : val_between v [] l m = 0 := sorry

/-- Evaluation of the nonconstant component of a normalized linear arithmetic term. -/
def val (v : ℕ → ℤ) (as : List ℤ) : ℤ :=
  val_between v as 0 (list.length as)

@[simp] theorem val_nil {v : ℕ → ℤ} : val v [] = 0 :=
  rfl

theorem val_between_eq_of_le {v : ℕ → ℤ} {as : List ℤ} {l : ℕ} (m : ℕ) : list.length as ≤ l + m → val_between v as l m = val_between v as l (list.length as - l) := sorry

theorem val_eq_of_le {v : ℕ → ℤ} {as : List ℤ} {k : ℕ} : list.length as ≤ k → val v as = val_between v as 0 k := sorry

theorem val_between_eq_val_between {v : ℕ → ℤ} {w : ℕ → ℤ} {as : List ℤ} {bs : List ℤ} {l : ℕ} {m : ℕ} : (∀ (x : ℕ), l ≤ x → x < l + m → v x = w x) →
  (∀ (x : ℕ), l ≤ x → x < l + m → list.func.get x as = list.func.get x bs) → val_between v as l m = val_between w bs l m := sorry

theorem val_between_set {v : ℕ → ℤ} {a : ℤ} {l : ℕ} {n : ℕ} {m : ℕ} : l ≤ n → n < l + m → val_between v (list.func.set a [] n) l m = a * v n := sorry

@[simp] theorem val_set {v : ℕ → ℤ} {m : ℕ} {a : ℤ} : val v (list.func.set a [] m) = a * v m := sorry

theorem val_between_neg {v : ℕ → ℤ} {as : List ℤ} {l : ℕ} {o : ℕ} : val_between v (list.func.neg as) l o = -val_between v as l o := sorry

@[simp] theorem val_neg {v : ℕ → ℤ} {as : List ℤ} : val v (list.func.neg as) = -val v as := sorry

theorem val_between_add {v : ℕ → ℤ} {is : List ℤ} {js : List ℤ} {l : ℕ} (m : ℕ) : val_between v (list.func.add is js) l m = val_between v is l m + val_between v js l m := sorry

@[simp] theorem val_add {v : ℕ → ℤ} {is : List ℤ} {js : List ℤ} : val v (list.func.add is js) = val v is + val v js := sorry

theorem val_between_sub {v : ℕ → ℤ} {is : List ℤ} {js : List ℤ} {l : ℕ} (m : ℕ) : val_between v (list.func.sub is js) l m = val_between v is l m - val_between v js l m := sorry

@[simp] theorem val_sub {v : ℕ → ℤ} {is : List ℤ} {js : List ℤ} : val v (list.func.sub is js) = val v is - val v js := sorry

/-- `val_except k v as` is the value (under valuation `v`) of the term
    obtained taking the term represented by `(0, as)` and dropping the
    subterm that includes the `k`th variable. -/
def val_except (k : ℕ) (v : ℕ → ℤ) (as : List ℤ) : ℤ :=
  val_between v as 0 k + val_between v as (k + 1) (list.length as - (k + 1))

theorem val_except_eq_val_except {k : ℕ} {is : List ℤ} {js : List ℤ} {v : ℕ → ℤ} {w : ℕ → ℤ} : (∀ (x : ℕ), x ≠ k → v x = w x) →
  (∀ (x : ℕ), x ≠ k → list.func.get x is = list.func.get x js) → val_except k v is = val_except k w js := sorry

theorem val_except_update_set {v : ℕ → ℤ} {n : ℕ} {as : List ℤ} {i : ℤ} {j : ℤ} : val_except n (update n i v) (list.func.set j as n) = val_except n v as :=
  val_except_eq_val_except update_eq_of_ne (list.func.get_set_eq_of_ne n)

theorem val_between_add_val_between {v : ℕ → ℤ} {as : List ℤ} {l : ℕ} {m : ℕ} {n : ℕ} : val_between v as l m + val_between v as (l + m) n = val_between v as l (m + n) := sorry

theorem val_except_add_eq {v : ℕ → ℤ} (n : ℕ) {as : List ℤ} : val_except n v as + list.func.get n as * v n = val v as := sorry

@[simp] theorem val_between_map_mul {v : ℕ → ℤ} {i : ℤ} {as : List ℤ} {l : ℕ} {m : ℕ} : val_between v (list.map (Mul.mul i) as) l m = i * val_between v as l m := sorry

theorem forall_val_dvd_of_forall_mem_dvd {i : ℤ} {as : List ℤ} : (∀ (x : ℤ), x ∈ as → i ∣ x) → ∀ (n : ℕ), i ∣ list.func.get n as :=
  fun (ᾰ : ∀ (x : ℤ), x ∈ as → i ∣ x) (n : ℕ) =>
    idRhs ((fun (x : ℤ) => i ∣ x) (list.func.get n as)) (list.func.forall_val_of_forall_mem (dvd_zero i) ᾰ n)

theorem dvd_val_between {v : ℕ → ℤ} {i : ℤ} {as : List ℤ} {l : ℕ} {m : ℕ} : (∀ (x : ℤ), x ∈ as → i ∣ x) → i ∣ val_between v as l m := sorry

theorem dvd_val {v : ℕ → ℤ} {as : List ℤ} {i : ℤ} : (∀ (x : ℤ), x ∈ as → i ∣ x) → i ∣ val v as :=
  dvd_val_between

@[simp] theorem val_between_map_div {v : ℕ → ℤ} {as : List ℤ} {i : ℤ} {l : ℕ} (h1 : ∀ (x : ℤ), x ∈ as → i ∣ x) {m : ℕ} : val_between v (list.map (fun (x : ℤ) => x / i) as) l m = val_between v as l m / i := sorry

@[simp] theorem val_map_div {v : ℕ → ℤ} {as : List ℤ} {i : ℤ} : (∀ (x : ℤ), x ∈ as → i ∣ x) → val v (list.map (fun (x : ℤ) => x / i) as) = val v as / i := sorry

theorem val_between_eq_zero {v : ℕ → ℤ} {is : List ℤ} {l : ℕ} {m : ℕ} : (∀ (x : ℤ), x ∈ is → x = 0) → val_between v is l m = 0 := sorry

theorem val_eq_zero {v : ℕ → ℤ} {is : List ℤ} : (∀ (x : ℤ), x ∈ is → x = 0) → val v is = 0 :=
  val_between_eq_zero


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

! This file was ported from Lean 3 source module category_theory.concrete_category.reflects_isomorphisms
! leanprover-community/mathlib commit 69c6a5a12d8a2b159f20933e60115a4f2de62b58
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.ConcreteCategory.Basic
import Mathbin.CategoryTheory.Functor.ReflectsIsomorphisms

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

A `forget₂ C D` forgetful functor between concrete categories `C` and `D`
whose forgetful functors both reflect isomorphisms, itself reflects isomorphisms.
-/

universe u

namespace CategoryTheory

instance : ReflectsIsomorphisms (forget (Type u)) where reflects X Y f i := i

variable (C : Type (u + 1)) [Category C] [ConcreteCategory.{u} C]

variable (D : Type (u + 1)) [Category D] [ConcreteCategory.{u} D]

/- warning: category_theory.reflects_isomorphisms_forget₂ -> CategoryTheory.reflectsIsomorphisms_forget₂ is a dubious translation:
lean 3 declaration is
  forall (C : Type.{succ u1}) [_inst_1 : CategoryTheory.Category.{u2, succ u1} C] [_inst_2 : CategoryTheory.ConcreteCategory.{u1, u2, succ u1} C _inst_1] (D : Type.{succ u1}) [_inst_3 : CategoryTheory.Category.{u3, succ u1} D] [_inst_4 : CategoryTheory.ConcreteCategory.{u1, u3, succ u1} D _inst_3] [_inst_5 : CategoryTheory.HasForget₂.{succ u1, succ u1, u1, u2, u3} C D _inst_1 _inst_2 _inst_3 _inst_4] [_inst_6 : CategoryTheory.ReflectsIsomorphisms.{u2, u1, succ u1, succ u1} C _inst_1 Type.{u1} CategoryTheory.types.{u1} (CategoryTheory.forget.{succ u1, u1, u2} C _inst_1 _inst_2)], CategoryTheory.ReflectsIsomorphisms.{u2, u3, succ u1, succ u1} C _inst_1 D _inst_3 (CategoryTheory.forget₂.{succ u1, succ u1, u2, u1, u3} C D _inst_1 _inst_2 _inst_3 _inst_4 _inst_5)
but is expected to have type
  forall (C : Type.{succ u3}) [_inst_1 : CategoryTheory.Category.{u2, succ u3} C] [_inst_2 : CategoryTheory.ConcreteCategory.{u3, u2, succ u3} C _inst_1] (D : Type.{succ u3}) [_inst_3 : CategoryTheory.Category.{u1, succ u3} D] [_inst_4 : CategoryTheory.ConcreteCategory.{u3, u1, succ u3} D _inst_3] [_inst_5 : CategoryTheory.HasForget₂.{succ u3, succ u3, u3, u2, u1} C D _inst_1 _inst_2 _inst_3 _inst_4] [_inst_6 : CategoryTheory.ReflectsIsomorphisms.{u2, u3, succ u3, succ u3} C _inst_1 Type.{u3} CategoryTheory.types.{u3} (CategoryTheory.forget.{succ u3, u3, u2} C _inst_1 _inst_2)], CategoryTheory.ReflectsIsomorphisms.{u2, u1, succ u3, succ u3} C _inst_1 D _inst_3 (CategoryTheory.forget₂.{succ u3, succ u3, u2, u3, u1} C D _inst_1 _inst_2 _inst_3 _inst_4 _inst_5)
Case conversion may be inaccurate. Consider using '#align category_theory.reflects_isomorphisms_forget₂ CategoryTheory.reflectsIsomorphisms_forget₂ₓ'. -/
-- This should not be an instance, as it causes a typeclass loop
-- with `category_theory.has_forget_to_Type`
/-- A `forget₂ C D` forgetful functor between concrete categories `C` and `D`
where `forget C` reflects isomorphisms, itself reflects isomorphisms.
-/
theorem reflectsIsomorphisms_forget₂ [HasForget₂ C D] [ReflectsIsomorphisms (forget C)] :
    ReflectsIsomorphisms (forget₂ C D) :=
  {
    reflects := fun X Y f i => by
      skip
      haveI i' : is_iso ((forget D).map ((forget₂ C D).map f)) := functor.map_is_iso (forget D) _
      haveI : is_iso ((forget C).map f) :=
        by
        have := has_forget₂.forget_comp
        dsimp at this
        rw [← this]
        exact i'
      apply is_iso_of_reflects_iso f (forget C) }
#align category_theory.reflects_isomorphisms_forget₂ CategoryTheory.reflectsIsomorphisms_forget₂

end CategoryTheory


import analysis.real xenalib.M1Fstuff

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

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

/-
noncomputable def decimal_expansion (x : ℝ) : ℤ × Π n : ℕ, fin 10 :=
begin
have H1 := M1F.floor_real_exists x,
have Hm := classical.indefinite_description _ H1,
cases Hm with m H1,
refine (m,_),
let y := x-m,
have H2 : y < 1,
simp [H1.right,add_comm],
exact (λ d, match d with
| 0 := ⟨0,dec_trivial⟩
| succ e := ⟨1,dec_trivial⟩
end),
admit,
end
-/


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import data.pi.algebra
import algebra.hom.group
import algebra.order.group.instances
import algebra.order.monoid.with_zero.defs
import order.hom.basic

/-!
# Ordered monoid and group homomorphisms

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

This file defines morphisms between (additive) ordered monoids.

## Types of morphisms

* `order_add_monoid_hom`: Ordered additive monoid homomorphisms.
* `order_monoid_hom`: Ordered monoid homomorphisms.
* `order_monoid_with_zero_hom`: Ordered monoid with zero homomorphisms.

## Typeclasses

* `order_add_monoid_hom_class`
* `order_monoid_hom_class`
* `order_monoid_with_zero_hom_class`

## Notation

* `→+o`: Bundled ordered additive monoid homs. Also use for additive groups homs.
* `→*o`: Bundled ordered monoid homs. Also use for groups homs.
* `→*₀o`: Bundled ordered monoid with zero homs. Also use for groups with zero homs.

## Implementation notes

There's a coercion from bundled homs to fun, and the canonical notation is to use the bundled hom as
a function via this coercion.

There is no `order_group_hom` -- the idea is that `order_monoid_hom` is used.
The constructor for `order_monoid_hom` needs a proof of `map_one` as well as `map_mul`; a separate
constructor `order_monoid_hom.mk'` will construct ordered group homs (i.e. ordered monoid homs
between ordered groups) given only a proof that multiplication is preserved,

Implicit `{}` brackets are often used instead of type class `[]` brackets. This is done when the
instances can be inferred because they are implicit arguments to the type `order_monoid_hom`. When
they can be inferred from the type it is faster to use this method than to use type class inference.

## Tags

ordered monoid, ordered group, monoid with zero
-/

open function

variables {F α β γ δ : Type*}

section add_monoid

/-- `α →+o β` is the type of monotone functions `α → β` that preserve the `ordered_add_comm_monoid`
structure.

`order_add_monoid_hom` is also used for ordered group homomorphisms.

When possible, instead of parametrizing results over `(f : α →+o β)`,
you should parametrize over `(F : Type*) [order_add_monoid_hom_class F α β] (f : F)`.

When you extend this structure, make sure to extend `order_add_monoid_hom_class`. -/
structure order_add_monoid_hom (α β : Type*) [preorder α] [preorder β] [add_zero_class α]
  [add_zero_class β] extends α →+ β :=
(monotone' : monotone to_fun)

infixr ` →+o `:25 := order_add_monoid_hom

section
set_option old_structure_cmd true

/-- `order_add_monoid_hom_class F α β` states that `F` is a type of ordered monoid homomorphisms.

You should also extend this typeclass when you extend `order_add_monoid_hom`. -/
@[ancestor add_monoid_hom_class]
class order_add_monoid_hom_class (F : Type*) (α β : out_param $ Type*) [preorder α] [preorder β]
  [add_zero_class α] [add_zero_class β]
  extends add_monoid_hom_class F α β :=
(monotone (f : F) : monotone f)

end

-- Instances and lemmas are defined below through `@[to_additive]`.

end add_monoid

section monoid
variables [preorder α] [preorder β] [mul_one_class α] [mul_one_class β]

/-- `α →*o β` is the type of functions `α → β` that preserve the `ordered_comm_monoid` structure.

`order_monoid_hom` is also used for ordered group homomorphisms.

When possible, instead of parametrizing results over `(f : α →*o β)`,
you should parametrize over `(F : Type*) [order_monoid_hom_class F α β] (f : F)`.

When you extend this structure, make sure to extend `order_monoid_hom_class`. -/
@[to_additive]
structure order_monoid_hom (α β : Type*) [preorder α] [preorder β] [mul_one_class α]
  [mul_one_class β]
  extends α →* β :=
(monotone' : monotone to_fun)

infixr ` →*o `:25 := order_monoid_hom

section
set_option old_structure_cmd true

/-- `order_monoid_hom_class F α β` states that `F` is a type of ordered monoid homomorphisms.

You should also extend this typeclass when you extend `order_monoid_hom`. -/
@[ancestor monoid_hom_class, to_additive]
class order_monoid_hom_class (F : Type*) (α β : out_param $ Type*)
  [preorder α] [preorder β] [mul_one_class α] [mul_one_class β]
  extends monoid_hom_class F α β :=
(monotone (f : F) : monotone f)

end

@[priority 100, to_additive] -- See note [lower instance priority]
instance order_monoid_hom_class.to_order_hom_class [order_monoid_hom_class F α β] :
  order_hom_class F α β :=
{ map_rel := order_monoid_hom_class.monotone,
  .. ‹order_monoid_hom_class F α β› }

@[to_additive]
instance [order_monoid_hom_class F α β] : has_coe_t F (α →*o β) :=
⟨λ f, { to_fun := f, map_one' := map_one f, map_mul' := map_mul f,
  monotone' := order_monoid_hom_class.monotone _ }⟩

end monoid

section monoid_with_zero
variables [preorder α] [preorder β] [mul_zero_one_class α] [mul_zero_one_class β]

/-- `order_monoid_with_zero_hom α β` is the type of functions `α → β` that preserve
the `monoid_with_zero` structure.

`order_monoid_with_zero_hom` is also used for group homomorphisms.

When possible, instead of parametrizing results over `(f : α →+ β)`,
you should parametrize over `(F : Type*) [order_monoid_with_zero_hom_class F α β] (f : F)`.

When you extend this structure, make sure to extend `order_monoid_with_zero_hom_class`. -/
structure order_monoid_with_zero_hom (α β : Type*) [preorder α] [preorder β]
  [mul_zero_one_class α] [mul_zero_one_class β]
  extends α →*₀ β :=
(monotone' : monotone to_fun)

infixr ` →*₀o `:25 := order_monoid_with_zero_hom

section
set_option old_structure_cmd true

/-- `order_monoid_with_zero_hom_class F α β` states that `F` is a type of
ordered monoid with zero homomorphisms.

You should also extend this typeclass when you extend `order_monoid_with_zero_hom`. -/
class order_monoid_with_zero_hom_class (F : Type*) (α β : out_param $ Type*)
  [preorder α] [preorder β] [mul_zero_one_class α] [mul_zero_one_class β]
  extends monoid_with_zero_hom_class F α β :=
(monotone (f : F) : monotone f)

end

@[priority 100] -- See note [lower instance priority]
instance order_monoid_with_zero_hom_class.to_order_monoid_hom_class
  [order_monoid_with_zero_hom_class F α β] : order_monoid_hom_class F α β :=
{ .. ‹order_monoid_with_zero_hom_class F α β› }

instance [order_monoid_with_zero_hom_class F α β] : has_coe_t F (α →*₀o β) :=
⟨λ f, { to_fun := f, map_one' := map_one f, map_zero' := map_zero f, map_mul' := map_mul f,
  monotone' := order_monoid_with_zero_hom_class.monotone _ }⟩

end monoid_with_zero

section ordered_add_comm_monoid
variables [ordered_add_comm_monoid α] [ordered_add_comm_monoid β] [order_add_monoid_hom_class F α β]
  (f : F) {a : α}
include β

lemma map_nonneg (ha : 0 ≤ a) : 0 ≤ f a := by { rw ←map_zero f, exact order_hom_class.mono _ ha }
lemma map_nonpos (ha : a ≤ 0) : f a ≤ 0 := by { rw ←map_zero f, exact order_hom_class.mono _ ha }

end ordered_add_comm_monoid

section ordered_add_comm_group

variables [ordered_add_comm_group α]
  [ordered_add_comm_monoid β] [add_monoid_hom_class F α β] (f : F)

lemma monotone_iff_map_nonneg : monotone (f : α → β) ↔ ∀ a, 0 ≤ a → 0 ≤ f a :=
⟨λ h a, by { rw ←map_zero f, apply h }, λ h a b hl,
  by { rw [←sub_add_cancel b a, map_add f], exact le_add_of_nonneg_left (h _ $ sub_nonneg.2 hl) }⟩

lemma antitone_iff_map_nonpos : antitone (f : α → β) ↔ ∀ a, 0 ≤ a → f a ≤ 0 :=
monotone_to_dual_comp_iff.symm.trans $ monotone_iff_map_nonneg _
lemma monotone_iff_map_nonpos : monotone (f : α → β) ↔ ∀ a ≤ 0, f a ≤ 0 :=
antitone_comp_of_dual_iff.symm.trans $ antitone_iff_map_nonpos _
lemma antitone_iff_map_nonneg : antitone (f : α → β) ↔ ∀ a ≤ 0, 0 ≤ f a :=
monotone_comp_of_dual_iff.symm.trans $ monotone_iff_map_nonneg _

variable [covariant_class β β (+) (<)]

lemma strict_mono_iff_map_pos : strict_mono (f : α → β) ↔ ∀ a, 0 < a → 0 < f a :=
⟨λ h a, by { rw ←map_zero f, apply h }, λ h a b hl,
  by { rw [←sub_add_cancel b a, map_add f], exact lt_add_of_pos_left _ (h _ $ sub_pos.2 hl) }⟩

lemma strict_anti_iff_map_neg : strict_anti (f : α → β) ↔ ∀ a, 0 < a → f a < 0 :=
strict_mono_to_dual_comp_iff.symm.trans $ strict_mono_iff_map_pos _
lemma strict_mono_iff_map_neg : strict_mono (f : α → β) ↔ ∀ a < 0, f a < 0 :=
strict_anti_comp_of_dual_iff.symm.trans $ strict_anti_iff_map_neg _
lemma strict_anti_iff_map_pos : strict_anti (f : α → β) ↔ ∀ a < 0, 0 < f a :=
strict_mono_comp_of_dual_iff.symm.trans $ strict_mono_iff_map_pos _

end ordered_add_comm_group

namespace order_monoid_hom
section preorder
variables [preorder α] [preorder β] [preorder γ] [preorder δ] [mul_one_class α]
  [mul_one_class β] [mul_one_class γ] [mul_one_class δ] {f g : α →*o β}

@[to_additive]
instance : order_monoid_hom_class (α →*o β) α β :=
{ coe := λ f, f.to_fun,
  coe_injective' := λ f g h, by { obtain ⟨⟨_, _⟩, _⟩ := f, obtain ⟨⟨_, _⟩, _⟩ := g, congr' },
  map_mul := λ f, f.map_mul',
  map_one := λ f, f.map_one',
  monotone := λ f, f.monotone' }

/-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`
directly. -/
@[to_additive "Helper instance for when there's too many metavariables to apply
`fun_like.has_coe_to_fun` directly."]
instance : has_coe_to_fun (α →*o β) (λ _, α → β) := fun_like.has_coe_to_fun

-- Other lemmas should be accessed through the `fun_like` API
@[ext, to_additive] lemma ext (h : ∀ a, f a = g a) : f = g := fun_like.ext f g h
@[to_additive] lemma to_fun_eq_coe (f : α →*o β) : f.to_fun = (f : α → β) := rfl
@[simp, to_additive] lemma coe_mk (f : α →* β) (h) : (order_monoid_hom.mk f h : α → β) = f := rfl
@[simp, to_additive] lemma mk_coe (f : α →*o β) (h) : order_monoid_hom.mk (f :  α →* β) h = f :=
by { ext, refl }

/-- Reinterpret an ordered monoid homomorphism as an order homomorphism. -/
@[to_additive "Reinterpret an ordered additive monoid homomorphism as an order homomorphism."]
def to_order_hom (f : α →*o β) : α →o β := { ..f }

@[simp, to_additive] lemma coe_monoid_hom (f : α →*o β) : ((f : α →* β) : α → β) = f := rfl
@[simp, to_additive] lemma coe_order_hom (f : α →*o β) : ((f : α →o β) : α → β) = f := rfl

@[to_additive] lemma to_monoid_hom_injective : injective (to_monoid_hom : _ → α →* β) :=
λ f g h, ext $ by convert fun_like.ext_iff.1 h

@[to_additive] lemma to_order_hom_injective : injective (to_order_hom : _ → α →o β) :=
λ f g h, ext $ by convert fun_like.ext_iff.1 h

/-- Copy of an `order_monoid_hom` with a new `to_fun` equal to the old one. Useful to fix
definitional equalities. -/
@[to_additive "Copy of an `order_monoid_hom` with a new `to_fun` equal to the old one. Useful to fix
definitional equalities."]
protected def copy (f : α →*o β) (f' : α → β) (h : f' = f) : α →*o β :=
{ to_fun := f',
  monotone' := h.symm.subst f.monotone',
  ..f.to_monoid_hom.copy f' h }

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

@[to_additive] lemma copy_eq (f : α →*o β) (f' : α → β) (h : f' = f) :
  f.copy f' h = f :=
fun_like.ext' h

variables (α)

/-- The identity map as an ordered monoid homomorphism. -/
@[to_additive "The identity map as an ordered additive monoid homomorphism."]
protected def id : α →*o α := { ..monoid_hom.id α, ..order_hom.id }

@[simp, to_additive] lemma coe_id : ⇑(order_monoid_hom.id α) = id := rfl

@[to_additive] instance : inhabited (α →*o α) := ⟨order_monoid_hom.id α⟩

variables {α}

/-- Composition of `order_monoid_hom`s as an `order_monoid_hom`. -/
@[to_additive "Composition of `order_add_monoid_hom`s as an `order_add_monoid_hom`"]
def comp (f : β →*o γ) (g : α →*o β) : α →*o γ :=
{ ..f.to_monoid_hom.comp (g : α →* β), ..f.to_order_hom.comp (g : α →o β) }

@[simp, to_additive] lemma coe_comp (f : β →*o γ) (g : α →*o β) : (f.comp g : α → γ) = f ∘ g := rfl
@[simp, to_additive] lemma comp_apply (f : β →*o γ) (g : α →*o β) (a : α) :
  (f.comp g) a = f (g a) := rfl
@[simp, to_additive] lemma coe_comp_monoid_hom (f : β →*o γ) (g : α →*o β) :
  (f.comp g : α →* γ) = (f : β →* γ).comp g := rfl
@[simp, to_additive] lemma coe_comp_order_hom (f : β →*o γ) (g : α →*o β) :
  (f.comp g : α →o γ) = (f : β →o γ).comp g := rfl
@[simp, to_additive] lemma comp_assoc (f : γ →*o δ) (g : β →*o γ) (h : α →*o β) :
  (f.comp g).comp h = f.comp (g.comp h) := rfl
@[simp, to_additive] lemma comp_id (f : α →*o β) : f.comp (order_monoid_hom.id α) = f :=
ext $ λ a, rfl
@[simp, to_additive] lemma id_comp (f : α →*o β) : (order_monoid_hom.id β).comp f = f :=
ext $ λ a, rfl

@[to_additive]
lemma cancel_right {g₁ g₂ : β →*o γ} {f : α →*o β} (hf : function.surjective f) :
  g₁.comp f = g₂.comp f ↔ g₁ = g₂ :=
⟨λ h, ext $ hf.forall.2 $ fun_like.ext_iff.1 h, congr_arg _⟩

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

/-- `1` is the homomorphism sending all elements to `1`. -/
@[to_additive "`1` is the homomorphism sending all elements to `1`."]
instance : has_one (α →*o β) := ⟨{ monotone' := monotone_const, ..(1 : α →* β) }⟩

@[simp, to_additive]

@[simp, to_additive] lemma one_comp (f : α →*o β) : (1 : β →*o γ).comp f = 1 := rfl
@[simp, to_additive] lemma comp_one (f : β →*o γ) : f.comp (1 : α →*o β) = 1 :=
by { ext, exact map_one f }

end preorder

section mul
variables [ordered_comm_monoid α] [ordered_comm_monoid β] [ordered_comm_monoid γ]

/-- For two ordered monoid morphisms `f` and `g`, their product is the ordered monoid morphism
sending `a` to `f a * g a`. -/
@[to_additive "For two ordered additive monoid morphisms `f` and `g`, their product is the ordered
additive monoid morphism sending `a` to `f a + g a`."]
instance : has_mul (α →*o β) :=
⟨λ f g, { monotone' := f.monotone'.mul' g.monotone', ..(f * g : α →* β) }⟩

@[simp, to_additive] lemma coe_mul (f g : α →*o β) : ⇑(f * g) = f * g := rfl
@[simp, to_additive] lemma mul_apply (f g : α →*o β) (a : α) : (f * g) a = f a * g a := rfl

@[to_additive] lemma mul_comp (g₁ g₂ : β →*o γ) (f : α →*o β) :
  (g₁ * g₂).comp f = g₁.comp f * g₂.comp f := rfl
@[to_additive] lemma comp_mul (g : β →*o γ) (f₁ f₂ : α →*o β) :
  g.comp (f₁ * f₂) = g.comp f₁ * g.comp f₂ := by { ext, exact map_mul g _ _ }

end mul

section ordered_comm_monoid
variables {hα : ordered_comm_monoid α} {hβ : ordered_comm_monoid β}
include hα hβ

@[simp, to_additive] lemma to_monoid_hom_eq_coe (f : α →*o β) : f.to_monoid_hom = f :=
by { ext, refl }
@[simp, to_additive] lemma to_order_hom_eq_coe (f : α →*o β) : f.to_order_hom = f := rfl

end ordered_comm_monoid

section ordered_comm_group
variables {hα : ordered_comm_group α} {hβ : ordered_comm_group β}
include hα hβ

/-- Makes an ordered group homomorphism from a proof that the map preserves multiplication. -/
@[to_additive "Makes an ordered additive group homomorphism from a proof that the map preserves
addition.",
  simps {fully_applied := ff}]
def mk' (f : α → β) (hf : monotone f) (map_mul : ∀ a b : α, f (a * b) = f a * f b) : α →*o β :=
{ monotone' := hf,
  ..monoid_hom.mk' f map_mul }

end ordered_comm_group
end order_monoid_hom

namespace order_monoid_with_zero_hom
section preorder
variables [preorder α] [preorder β] [preorder γ] [preorder δ] [mul_zero_one_class α]
  [mul_zero_one_class β] [mul_zero_one_class γ] [mul_zero_one_class δ] {f g : α →*₀o β}

instance : order_monoid_with_zero_hom_class (α →*₀o β) α β :=
{ coe := λ f, f.to_fun,
  coe_injective' := λ f g h, by { obtain ⟨⟨_, _⟩, _⟩ := f, obtain ⟨⟨_, _⟩, _⟩ := g, congr' },
  map_mul := λ f, f.map_mul',
  map_one := λ f, f.map_one',
  map_zero := λ f, f.map_zero',
  monotone := λ f, f.monotone' }

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

-- Other lemmas should be accessed through the `fun_like` API
@[ext] lemma ext (h : ∀ a, f a = g a) : f = g := fun_like.ext f g h
lemma to_fun_eq_coe (f : α →*₀o β) : f.to_fun = (f : α → β) := rfl
@[simp] lemma coe_mk (f : α →*₀ β) (h) : (order_monoid_with_zero_hom.mk f h : α → β) = f := rfl
@[simp] lemma mk_coe (f : α →*₀o β) (h) : order_monoid_with_zero_hom.mk (f :  α →*₀ β) h = f :=
by { ext, refl }

/-- Reinterpret an ordered monoid with zero homomorphism as an order monoid homomorphism. -/
def to_order_monoid_hom (f : α →*₀o β) : α →*o β := { ..f }

@[simp] lemma coe_monoid_with_zero_hom (f : α →*₀o β) : ⇑(f : α →*₀ β) = f := rfl
@[simp] lemma coe_order_monoid_hom (f : α →*₀o β) : ⇑(f : α →*o β) = f := rfl

lemma to_order_monoid_hom_injective : injective (to_order_monoid_hom : _ → α →*o β) :=
λ f g h, ext $ by convert fun_like.ext_iff.1 h

lemma to_monoid_with_zero_hom_injective : injective (to_monoid_with_zero_hom : _ → α →*₀ β) :=
λ f g h, ext $ by convert fun_like.ext_iff.1 h

/-- Copy of an `order_monoid_with_zero_hom` with a new `to_fun` equal to the old one. Useful to fix
definitional equalities. -/
protected def copy (f : α →*₀o β) (f' : α → β) (h : f' = f) : α →*o β :=
{ to_fun := f',
  .. f.to_order_monoid_hom.copy f' h, .. f.to_monoid_with_zero_hom.copy f' h }

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

variables (α)

/-- The identity map as an ordered monoid with zero homomorphism. -/
protected def id : α →*₀o α := { ..monoid_with_zero_hom.id α, ..order_hom.id }

@[simp] lemma coe_id : ⇑(order_monoid_with_zero_hom.id α) = id := rfl

instance : inhabited (α →*₀o α) := ⟨order_monoid_with_zero_hom.id α⟩

variables {α}

/-- Composition of `order_monoid_with_zero_hom`s as an `order_monoid_with_zero_hom`. -/
def comp (f : β →*₀o γ) (g : α →*₀o β) : α →*₀o γ :=
{ ..f.to_monoid_with_zero_hom.comp (g : α →*₀ β), ..f.to_order_monoid_hom.comp (g : α →*o β) }

@[simp] lemma coe_comp (f : β →*₀o γ) (g : α →*₀o β) : (f.comp g : α → γ) = f ∘ g := rfl
@[simp] lemma comp_apply (f : β →*₀o γ) (g : α →*₀o β) (a : α) : (f.comp g) a = f (g a) := rfl
@[simp] lemma coe_comp_monoid_with_zero_hom (f : β →*₀o γ) (g : α →*₀o β) :
  (f.comp g : α →*₀ γ) = (f : β →*₀ γ).comp g := rfl
@[simp] lemma coe_comp_order_monoid_hom (f : β →*₀o γ) (g : α →*₀o β) :
  (f.comp g : α →*o γ) = (f : β →*o γ).comp g := rfl
@[simp] lemma comp_assoc (f : γ →*₀o δ) (g : β →*₀o γ) (h : α →*₀o β) :
  (f.comp g).comp h = f.comp (g.comp h) := rfl
@[simp] lemma comp_id (f : α →*₀o β) : f.comp (order_monoid_with_zero_hom.id α) = f :=
ext $ λ a, rfl
@[simp] lemma id_comp (f : α →*₀o β) : (order_monoid_with_zero_hom.id β).comp f = f :=
ext $ λ a, rfl

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

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

end preorder

section mul
variables [linear_ordered_comm_monoid_with_zero α] [linear_ordered_comm_monoid_with_zero β]
  [linear_ordered_comm_monoid_with_zero γ]

/-- For two ordered monoid morphisms `f` and `g`, their product is the ordered monoid morphism
sending `a` to `f a * g a`. -/
instance : has_mul (α →*₀o β) :=
⟨λ f g, { monotone' := f.monotone'.mul' g.monotone', ..(f * g : α →*₀ β) }⟩

@[simp] lemma coe_mul (f g : α →*₀o β) : ⇑(f * g) = f * g := rfl
@[simp] lemma mul_apply (f g : α →*₀o β) (a : α) : (f * g) a = f a * g a := rfl

lemma mul_comp (g₁ g₂ : β →*₀o γ) (f : α →*₀o β) : (g₁ * g₂).comp f = g₁.comp f * g₂.comp f := rfl
lemma comp_mul (g : β →*₀o γ) (f₁ f₂ : α →*₀o β) : g.comp (f₁ * f₂) = g.comp f₁ * g.comp f₂ :=
ext $ λ _, map_mul g _ _

end mul

section linear_ordered_comm_monoid_with_zero
variables {hα : preorder α} {hα' : mul_zero_one_class α} {hβ : preorder β}
  {hβ' : mul_zero_one_class β}
include hα hα' hβ hβ'

@[simp] lemma to_monoid_with_zero_hom_eq_coe (f : α →*₀o β) : f.to_monoid_with_zero_hom = f :=
by { ext, refl }
@[simp] lemma to_order_monoid_hom_eq_coe (f : α →*₀o β) : f.to_order_monoid_hom = f := rfl

end linear_ordered_comm_monoid_with_zero
end order_monoid_with_zero_hom


/-
Copyright (c) 2019 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Simon Hudon, Scott Morrison
-/
import control.bifunctor
import logic.equiv.defs

/-!
# Functor and bifunctors can be applied to `equiv`s.

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

We define
```lean
def functor.map_equiv (f : Type u → Type v) [functor f] [is_lawful_functor f] :
  α ≃ β → f α ≃ f β
```
and
```lean
def bifunctor.map_equiv (F : Type u → Type v → Type w) [bifunctor F] [is_lawful_bifunctor F] :
  α ≃ β → α' ≃ β' → F α α' ≃ F β β'
```
-/

universes u v w

variables {α β : Type u}
open equiv

namespace functor

variables (f : Type u → Type v) [functor f] [is_lawful_functor f]

/-- Apply a functor to an `equiv`. -/
def map_equiv (h : α ≃ β) : f α ≃ f β :=
{ to_fun    := map h,
  inv_fun   := map h.symm,
  left_inv  := λ x, by simp [map_map],
  right_inv := λ x, by simp [map_map] }

@[simp]
lemma map_equiv_apply (h : α ≃ β) (x : f α) :
  (map_equiv f h : f α ≃ f β) x = map h x := rfl

@[simp]
lemma map_equiv_symm_apply (h : α ≃ β) (y : f β) :
  (map_equiv f h : f α ≃ f β).symm y = map h.symm y := rfl

@[simp]

end functor

namespace bifunctor

variables {α' β' : Type v} (F : Type u → Type v → Type w) [bifunctor F] [is_lawful_bifunctor F]

/-- Apply a bifunctor to a pair of `equiv`s. -/
def map_equiv (h : α ≃ β) (h' : α' ≃ β') : F α α' ≃ F β β' :=
{ to_fun    := bimap h h',
  inv_fun   := bimap h.symm h'.symm,
  left_inv  := λ x, by simp [bimap_bimap, id_bimap],
  right_inv := λ x, by simp [bimap_bimap, id_bimap] }

@[simp]
lemma map_equiv_apply (h : α ≃ β) (h' : α' ≃ β') (x : F α α') :
  (map_equiv F h h' : F α α' ≃ F β β') x = bimap h h' x := rfl

@[simp]
lemma map_equiv_symm_apply (h : α ≃ β) (h' : α' ≃ β') (y : F β β') :
  (map_equiv F h h' : F α α' ≃ F β β').symm y = bimap h.symm h'.symm y := rfl

@[simp]
lemma map_equiv_refl_refl : map_equiv F (equiv.refl α) (equiv.refl α') = equiv.refl (F α α') :=
begin
  ext x,
  simp [id_bimap]
end

end bifunctor


/-
Copyright (c) 2020 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn
-/
import algebra.order.kleene
import data.set.pointwise.smul

/-!
# Sets as a semiring under union

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

This file defines `set_semiring α`, an alias of `set α`, which we endow with `∪` as addition and
pointwise `*` as multiplication. If `α` is a (commutative) monoid, `set_semiring α` is a
(commutative) semiring.
-/

open function set
open_locale pointwise

variables {α β : Type*}

/-- An alias for `set α`, which has a semiring structure given by `∪` as "addition" and pointwise
  multiplication `*` as "multiplication". -/
@[derive [inhabited, partial_order, order_bot]] def set_semiring (α : Type*) : Type* := set α

/-- The identity function `set α → set_semiring α`. -/
protected def set.up : set α ≃ set_semiring α := equiv.refl _

namespace set_semiring

/-- The identity function `set_semiring α → set α`. -/
protected def down : set_semiring α ≃ set α := equiv.refl _

@[simp] protected

-- TODO: These lemmas are not tagged `simp` because `set.le_eq_subset` simplifies the LHS
lemma up_le_up {s t : set α} : s.up ≤ t.up ↔ s ⊆ t := iff.rfl
lemma up_lt_up {s t : set α} : s.up < t.up ↔ s ⊂ t := iff.rfl

@[simp] lemma down_subset_down {s t : set_semiring α} : s.down ⊆ t.down ↔ s ≤ t := iff.rfl
@[simp] lemma down_ssubset_down {s t : set_semiring α} : s.down ⊂ t.down ↔ s < t := iff.rfl

instance : add_comm_monoid (set_semiring α) :=
{ add := λ s t, (s.down ∪ t.down).up,
  zero := (∅ : set α).up,
  add_assoc := union_assoc,
  zero_add := empty_union,
  add_zero := union_empty,
  add_comm := union_comm }

lemma zero_def : (0 : set_semiring α) = set.up ∅ := rfl

@[simp] lemma down_zero : (0 : set_semiring α).down = ∅ := rfl

@[simp] lemma _root_.set.up_empty : (∅ : set α).up = 0 := rfl

lemma add_def (s t : set_semiring α) : s + t = (s.down ∪ t.down).up := rfl

@[simp] lemma down_add (s t : set_semiring α) : (s + t).down = s.down ∪ t.down := rfl

@[simp] lemma _root_.set.up_union (s t : set α) : (s ∪ t).up = s.up + t.up := rfl

/- Since addition on `set_semiring` is commutative (it is set union), there is no need
to also have the instance `covariant_class (set_semiring α) (set_semiring α) (swap (+)) (≤)`. -/
instance covariant_class_add : covariant_class (set_semiring α) (set_semiring α) (+) (≤) :=
⟨λ a b c, union_subset_union_right _⟩

section has_mul
variables [has_mul α]

instance : non_unital_non_assoc_semiring (set_semiring α) :=
{ -- reducibility linter complains if we use `(s.down * t.down).up`
  mul := λ s t, (image2 (*) s.down t.down).up,
  zero_mul := λ s, empty_mul,
  mul_zero := λ s, mul_empty,
  left_distrib := λ _ _ _, mul_union,
  right_distrib := λ _ _ _, union_mul,
  ..set_semiring.add_comm_monoid }

lemma mul_def (s t : set_semiring α) : s * t = (s.down * t.down).up := rfl

@[simp] lemma down_mul (s t : set_semiring α) : (s * t).down = s.down * t.down := rfl

@[simp] lemma _root_.set.up_mul (s t : set α) : (s * t).up = s.up * t.up := rfl

instance : no_zero_divisors (set_semiring α) :=
⟨λ a b ab, a.eq_empty_or_nonempty.imp_right $ λ ha, b.eq_empty_or_nonempty.resolve_right $
  λ hb, nonempty.ne_empty ⟨_, mul_mem_mul ha.some_mem hb.some_mem⟩ ab⟩

instance covariant_class_mul_left : covariant_class (set_semiring α) (set_semiring α) (*) (≤) :=
⟨λ a b c, mul_subset_mul_left⟩

instance covariant_class_mul_right :
  covariant_class (set_semiring α) (set_semiring α) (swap (*)) (≤) :=
⟨λ a b c, mul_subset_mul_right⟩

end has_mul

section has_one
variables [has_one α]

instance : has_one (set_semiring α) := { one := set.up 1 }

lemma one_def : (1 : set_semiring α) = set.up 1 := rfl

@[simp] lemma down_one : (1 : set_semiring α).down = 1 := rfl

@[simp] lemma _root_.set.up_one : (1 : set α).up = 1 := rfl

end has_one

instance [mul_one_class α] : non_assoc_semiring (set_semiring α) :=
{ one := 1,
  mul := (*),
  ..set_semiring.non_unital_non_assoc_semiring, ..set.mul_one_class }

instance [semigroup α] : non_unital_semiring (set_semiring α) :=
{ ..set_semiring.non_unital_non_assoc_semiring, ..set.semigroup }

instance [monoid α] : idem_semiring (set_semiring α) :=
{ ..set_semiring.non_assoc_semiring, ..set_semiring.non_unital_semiring,
  ..set.complete_boolean_algebra }

instance [comm_semigroup α] : non_unital_comm_semiring (set_semiring α) :=
{ ..set_semiring.non_unital_semiring, ..set.comm_semigroup }

instance [comm_monoid α] : idem_comm_semiring (set_semiring α) :=
{ ..set_semiring.idem_semiring, ..set.comm_monoid }

instance [comm_monoid α] : canonically_ordered_comm_semiring (set_semiring α) :=
{ add_le_add_left := λ a b, add_le_add_left,
  exists_add_of_le := λ a b ab, ⟨b, (union_eq_right_iff_subset.2 ab).symm⟩,
  le_self_add := subset_union_left,
  ..set_semiring.idem_semiring, ..set.comm_monoid, ..set_semiring.no_zero_divisors }

/-- The image of a set under a multiplicative homomorphism is a ring homomorphism
with respect to the pointwise operations on sets. -/
def image_hom [mul_one_class α] [mul_one_class β] (f : α →* β) :
  set_semiring α →+* set_semiring β :=
{ to_fun := λ s, (image f s.down).up,
  map_zero' := image_empty _,
  map_one' := by rw [down_one, image_one, map_one, singleton_one, set.up_one],
  map_add' := image_union _,
  map_mul' := λ _ _, image_mul f }

lemma image_hom_def [mul_one_class α] [mul_one_class β] (f : α →* β) (s : set_semiring α) :
  image_hom f s = (image f s.down).up := rfl

@[simp] lemma down_image_hom [mul_one_class α] [mul_one_class β] (f : α →* β) (s : set_semiring α) :
  (image_hom f s).down = f '' s.down := rfl

@[simp] lemma _root_.set.up_image [mul_one_class α] [mul_one_class β] (f : α →* β) (s : set α) :
  (f '' s).up = image_hom f s.up := rfl

end set_semiring


/-
Copyright (c) 2021 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import data.finset.locally_finite
import data.finset.pointwise
import data.fintype.big_operators
import data.dfinsupp.order

/-!
# Finite intervals of finitely supported functions

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

This file provides the `locally_finite_order` instance for `Π₀ i, α i` when `α` itself is locally
finite and calculates the cardinality of its finite intervals.
-/

open dfinsupp finset
open_locale big_operators pointwise

variables {ι : Type*} {α : ι → Type*}

namespace finset
variables [decidable_eq ι] [Π i, has_zero (α i)] {s : finset ι} {f : Π₀ i, α i}
  {t : Π i, finset (α i)}

/-- Finitely supported product of finsets. -/
def dfinsupp (s : finset ι) (t : Π i, finset (α i)) : finset (Π₀ i, α i) :=
(s.pi t).map ⟨λ f, dfinsupp.mk s $ λ i, f i i.2, begin
  refine (mk_injective _).comp (λ f g h, _),
  ext i hi,
  convert congr_fun h ⟨i, hi⟩,
  end⟩

@[simp] lemma card_dfinsupp (s : finset ι) (t : Π i, finset (α i)) :
  (s.dfinsupp t).card = ∏ i in s, (t i).card :=
(card_map _).trans $ card_pi _ _

variables [Π i, decidable_eq (α i)]

lemma mem_dfinsupp_iff : f ∈ s.dfinsupp t ↔ f.support ⊆ s ∧ ∀ i ∈ s, f i ∈ t i :=
begin
  refine mem_map.trans ⟨_, _⟩,
  { rintro ⟨f, hf, rfl⟩,
    refine ⟨support_mk_subset, λ i hi, _⟩,
    convert mem_pi.1 hf i hi,
    exact mk_of_mem hi },
  { refine λ h, ⟨λ i _, f i, mem_pi.2 h.2, _⟩,
    ext i,
    dsimp,
    exact ite_eq_left_iff.2 (λ hi, (not_mem_support_iff.1 $ λ H, hi $ h.1 H).symm) }
end

/-- When `t` is supported on `s`, `f ∈ s.dfinsupp t` precisely means that `f` is pointwise in `t`.
-/
@[simp] lemma mem_dfinsupp_iff_of_support_subset {t : Π₀ i, finset (α i)} (ht : t.support ⊆ s) :
  f ∈ s.dfinsupp t ↔ ∀ i, f i ∈ t i :=
begin
  refine mem_dfinsupp_iff.trans (forall_and_distrib.symm.trans $ forall_congr $ λ i, ⟨λ h, _,
    λ h, ⟨λ hi, ht $ mem_support_iff.2 $ λ H, mem_support_iff.1 hi _, λ _, h⟩⟩),
  { by_cases hi : i ∈ s,
    { exact h.2 hi },
    { rw [not_mem_support_iff.1 (mt h.1 hi), not_mem_support_iff.1 (not_mem_mono ht hi)],
      exact zero_mem_zero } },
  { rwa [H, mem_zero] at h }
end

end finset

open finset

namespace dfinsupp

section bundled_singleton
variables [Π i, has_zero (α i)] {f : Π₀ i, α i} {i : ι} {a : α i}

/-- Pointwise `finset.singleton` bundled as a `dfinsupp`. -/
def singleton (f : Π₀ i, α i) : Π₀ i, finset (α i) :=
{ to_fun := λ i, {f i},
  support' := f.support'.map $ λ s, ⟨s, λ i, (s.prop i).imp id (congr_arg _) ⟩ }

lemma mem_singleton_apply_iff : a ∈ f.singleton i ↔ a = f i := mem_singleton

end bundled_singleton

section bundled_Icc
variables [Π i, has_zero (α i)] [Π i, partial_order (α i)] [Π i, locally_finite_order (α i)]
  {f g : Π₀ i, α i} {i : ι} {a : α i}

/-- Pointwise `finset.Icc` bundled as a `dfinsupp`. -/
def range_Icc (f g : Π₀ i, α i) : Π₀ i, finset (α i) :=
{ to_fun := λ i, Icc (f i) (g i),
  support' := f.support'.bind $ λ fs, g.support'.map $ λ gs,
    ⟨fs + gs, λ i, or_iff_not_imp_left.2 $ λ h, begin
      have hf : f i = 0 := (fs.prop i).resolve_left
        (multiset.not_mem_mono (multiset.le.subset $ multiset.le_add_right _ _) h),
      have hg : g i = 0 := (gs.prop i).resolve_left
        (multiset.not_mem_mono (multiset.le.subset $ multiset.le_add_left _ _) h),
      rw [hf, hg],
      exact Icc_self _,
    end⟩ }

@[simp] lemma range_Icc_apply (f g : Π₀ i, α i) (i : ι) : f.range_Icc g i = Icc (f i) (g i) := rfl

lemma mem_range_Icc_apply_iff : a ∈ f.range_Icc g i ↔ f i ≤ a ∧ a ≤ g i := mem_Icc

lemma support_range_Icc_subset [decidable_eq ι] [Π i, decidable_eq (α i)] :
  (f.range_Icc g).support ⊆ f.support ∪ g.support :=
begin
  refine λ x hx, _,
  by_contra,
  refine not_mem_support_iff.2 _ hx,
  rw [range_Icc_apply,
    not_mem_support_iff.1 (not_mem_mono (subset_union_left _ _) h),
      not_mem_support_iff.1 (not_mem_mono (subset_union_right _ _) h)],
  exact Icc_self _,
end

end bundled_Icc

section pi
variables [Π i, has_zero (α i)] [decidable_eq ι] [Π i, decidable_eq (α i)]

/-- Given a finitely supported function `f : Π₀ i, finset (α i)`, one can define the finset
`f.pi` of all finitely supported functions whose value at `i` is in `f i` for all `i`. -/
def pi (f : Π₀ i, finset (α i)) : finset (Π₀ i, α i) := f.support.dfinsupp f

@[simp] lemma mem_pi {f : Π₀ i, finset (α i)} {g : Π₀ i, α i} : g ∈ f.pi ↔ ∀ i, g i ∈ f i :=
mem_dfinsupp_iff_of_support_subset $ subset.refl _

@[simp] lemma card_pi (f : Π₀ i, finset (α i)) : f.pi.card = f.prod (λ i, (f i).card) :=
begin
  rw [pi, card_dfinsupp],
  exact finset.prod_congr rfl (λ i _, by simp only [pi.nat_apply, nat.cast_id]),
end

end pi

section locally_finite
variables [decidable_eq ι] [Π i, decidable_eq (α i)]
variables [Π i, partial_order (α i)] [Π i, has_zero (α i)] [Π i, locally_finite_order (α i)]

instance : locally_finite_order (Π₀ i, α i) :=
locally_finite_order.of_Icc (Π₀ i, α i)
  (λ f g, (f.support ∪ g.support).dfinsupp $ f.range_Icc g)
  (λ f g x, begin
    refine (mem_dfinsupp_iff_of_support_subset $ support_range_Icc_subset).trans _,
    simp_rw [mem_range_Icc_apply_iff, forall_and_distrib],
    refl,
  end)

variables (f g : Π₀ i, α i)

lemma Icc_eq : Icc f g = (f.support ∪ g.support).dfinsupp (f.range_Icc g) := rfl

lemma card_Icc : (Icc f g).card = ∏ i in f.support ∪ g.support, (Icc (f i) (g i)).card :=
card_dfinsupp _ _

lemma card_Ico : (Ico f g).card = ∏ i in f.support ∪ g.support, (Icc (f i) (g i)).card - 1 :=
by rw [card_Ico_eq_card_Icc_sub_one, card_Icc]

lemma card_Ioc : (Ioc f g).card = ∏ i in f.support ∪ g.support, (Icc (f i) (g i)).card - 1 :=
by rw [card_Ioc_eq_card_Icc_sub_one, card_Icc]

end locally_finite

section canonically_ordered
variables [decidable_eq ι] [Π i, decidable_eq (α i)]
variables [Π i, canonically_ordered_add_monoid (α i)] [Π i, locally_finite_order (α i)]

variables (f : Π₀ i, α i)

lemma card_Iic : (Iic f).card = ∏ i in f.support, (Iic (f i)).card :=
by simp_rw [Iic_eq_Icc, card_Icc, dfinsupp.bot_eq_zero, support_zero, empty_union, zero_apply,
  bot_eq_zero]

lemma card_Iio : (Iio f).card = ∏ i in f.support, (Iic (f i)).card - 1 :=
by rw [card_Iio_eq_card_Iic_sub_one, card_Iic]

end canonically_ordered

end dfinsupp