/-
Copyright (c) 2021 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import category_theory.limits.has_limits
import category_theory.limits.shapes.equalizers

/-!
# Wide equalizers and wide coequalizers

This file defines wide (co)equalizers as special cases of (co)limits.

A wide equalizer for the family of morphisms `X ⟶ Y` indexed by `J` is the categorical
generalization of the subobject `{a ∈ A | ∀ j₁ j₂, f(j₁, a) = f(j₂, a)}`. Note that if `J` has
fewer than two morphisms this condition is trivial, so some lemmas and definitions assume `J` is
nonempty.

## Main definitions

* `walking_parallel_family` is the indexing category used for wide (co)equalizer diagrams
* `parallel_family` is a functor from `walking_parallel_family` to our category `C`.
* a `trident` is a cone over a parallel family.
  * there is really only one interesting morphism in a trident: the arrow from the vertex of the
    trident to the domain of f and g. It is called `trident.ι`.
* a `wide_equalizer` is now just a `limit (parallel_family f)`

Each of these has a dual.

## Main statements

* `wide_equalizer.ι_mono` states that every wide_equalizer map is a monomorphism
* `is_iso_limit_cone_parallel_family_of_self` states that the identity on the domain of `f` is an
  equalizer of `f` and `f`.

## Implementation notes
As with the other special shapes in the limits library, all the definitions here are given as
`abbreviation`s of the general statements for limits, so all the `simp` lemmas and theorems about
general limits can be used.

## References

* [F. Borceux, *Handbook of Categorical Algebra 1*][borceux-vol1]
-/

noncomputable theory

namespace category_theory.limits

open category_theory

universes w v u u₂

variables {J : Type w}

/-- The type of objects for the diagram indexing a wide (co)equalizer. -/
inductive walking_parallel_family (J : Type w) : Type w
| zero : walking_parallel_family
| one : walking_parallel_family

open walking_parallel_family

instance : decidable_eq (walking_parallel_family J)
| zero zero := is_true rfl
| zero one := is_false (λ t, walking_parallel_family.no_confusion t)
| one zero := is_false (λ t, walking_parallel_family.no_confusion t)
| one one := is_true rfl

instance : inhabited (walking_parallel_family J) := ⟨zero⟩

/-- The type family of morphisms for the diagram indexing a wide (co)equalizer. -/
@[derive decidable_eq] inductive walking_parallel_family.hom (J : Type w) :
  walking_parallel_family J → walking_parallel_family J → Type w
| id : Π X : walking_parallel_family.{w} J, walking_parallel_family.hom X X
| line : Π (j : J), walking_parallel_family.hom zero one

/-- Satisfying the inhabited linter -/
instance (J : Type v) : inhabited (walking_parallel_family.hom J zero zero) :=
{ default := hom.id _ }

open walking_parallel_family.hom

/-- Composition of morphisms in the indexing diagram for wide (co)equalizers. -/
def walking_parallel_family.hom.comp :
  Π (X Y Z : walking_parallel_family J)
    (f : walking_parallel_family.hom J X Y) (g : walking_parallel_family.hom J Y Z),
    walking_parallel_family.hom J X Z
  | _ _ _ (id _)   h := h
  | _ _ _ (line j) (id one) := line j.

local attribute [tidy] tactic.case_bash

instance walking_parallel_family.category : small_category (walking_parallel_family J) :=
{ hom  := walking_parallel_family.hom J,
  id   := walking_parallel_family.hom.id,
  comp := walking_parallel_family.hom.comp }

@[simp]
lemma walking_parallel_family.hom_id (X : walking_parallel_family J) :
  walking_parallel_family.hom.id X = 𝟙 X :=
rfl

variables {C : Type u} [category.{v} C]
variables {X Y : C} (f : J → (X ⟶ Y))

/--
`parallel_family f` is the diagram in `C` consisting of the given family of morphisms, each with
common domain and codomain.
-/
def parallel_family : walking_parallel_family J ⥤ C :=
{ obj := λ x, walking_parallel_family.cases_on x X Y,
  map := λ x y h, match x, y, h with
  | _, _, (id _) := 𝟙 _
  | _, _, (line j) := f j
  end,
  map_comp' :=
  begin
    rintro _ _ _ ⟨⟩ ⟨⟩;
    { unfold_aux, simp; refl },
  end }

@[simp] lemma parallel_family_obj_zero : (parallel_family f).obj zero = X := rfl
@[simp] lemma parallel_family_obj_one : (parallel_family f).obj one = Y := rfl

@[simp] lemma parallel_family_map_left {j : J} : (parallel_family f).map (line j) = f j := rfl

/-- Every functor indexing a wide (co)equalizer is naturally isomorphic (actually, equal) to a
    `parallel_family` -/
@[simps]
def diagram_iso_parallel_family (F : walking_parallel_family J ⥤ C) :
  F ≅ parallel_family (λ j, F.map (line j)) :=
nat_iso.of_components (λ j, eq_to_iso $ by cases j; tidy) $ by tidy

/-- `walking_parallel_pair` as a category is equivalent to a special case of
`walking_parallel_family`.  -/
@[simps]
def walking_parallel_family_equiv_walking_parallel_pair :
  walking_parallel_family.{w} (ulift bool) ≌ walking_parallel_pair :=
{ functor := parallel_family
      (λ p, cond p.down walking_parallel_pair_hom.left walking_parallel_pair_hom.right),
  inverse := parallel_pair (line (ulift.up tt)) (line (ulift.up ff)),
  unit_iso := nat_iso.of_components (λ X, eq_to_iso (by cases X; refl)) (by tidy),
  counit_iso := nat_iso.of_components (λ X, eq_to_iso (by cases X; refl)) (by tidy) }

/-- A trident on `f` is just a `cone (parallel_family f)`. -/
abbreviation trident := cone (parallel_family f)

/-- A cotrident on `f` and `g` is just a `cocone (parallel_family f)`. -/
abbreviation cotrident := cocone (parallel_family f)

variables {f}

/-- A trident `t` on the parallel family `f : J → (X ⟶ Y)` consists of two morphisms
    `t.π.app zero : t.X ⟶ X` and `t.π.app one : t.X ⟶ Y`. Of these, only the first one is
    interesting, and we give it the shorter name `trident.ι t`. -/
abbreviation trident.ι (t : trident f) := t.π.app zero

/-- A cotrident `t` on the parallel family `f : J → (X ⟶ Y)` consists of two morphisms
    `t.ι.app zero : X ⟶ t.X` and `t.ι.app one : Y ⟶ t.X`. Of these, only the second one is
    interesting, and we give it the shorter name `cotrident.π t`. -/
abbreviation cotrident.π (t : cotrident f) := t.ι.app one

@[simp] lemma trident.ι_eq_app_zero (t : trident f) : t.ι = t.π.app zero := rfl
@[simp] lemma cotrident.π_eq_app_one (t : cotrident f) : t.π = t.ι.app one := rfl

@[simp, reassoc] lemma trident.app_zero (s : trident f) (j : J) :
  s.π.app zero ≫ f j = s.π.app one :=
by rw [←s.w (line j), parallel_family_map_left]

@[simp, reassoc] lemma cotrident.app_one (s : cotrident f) (j : J) :
  f j ≫ s.ι.app one = s.ι.app zero :=
by rw [←s.w (line j), parallel_family_map_left]

/--
A trident on `f : J → (X ⟶ Y)` is determined by the morphism `ι : P ⟶ X` satisfying
`∀ j₁ j₂, ι ≫ f j₁ = ι ≫ f j₂`.
-/
@[simps]
def trident.of_ι [nonempty J] {P : C} (ι : P ⟶ X) (w : ∀ j₁ j₂, ι ≫ f j₁ = ι ≫ f j₂) :
  trident f :=
{ X := P,
  π :=
  { app := λ X, walking_parallel_family.cases_on X ι (ι ≫ f (classical.arbitrary J)),
    naturality' := λ i j f,
      begin
        dsimp,
        cases f with _ k,
        { simp },
        { simp [w (classical.arbitrary J) k] },
      end } }

/--
A cotrident on `f : J → (X ⟶ Y)` is determined by the morphism `π : Y ⟶ P` satisfying
`∀ j₁ j₂, f j₁ ≫ π = f j₂ ≫ π`.
-/
@[simps]
def cotrident.of_π [nonempty J] {P : C} (π : Y ⟶ P) (w : ∀ j₁ j₂, f j₁ ≫ π = f j₂ ≫ π) :
  cotrident f :=
{ X := P,
  ι :=
  { app := λ X, walking_parallel_family.cases_on X (f (classical.arbitrary J) ≫ π) π,
    naturality' := λ i j f,
      begin
        dsimp,
        cases f with _ k,
        { simp },
        { simp [w (classical.arbitrary J) k] }
      end } } -- See note [dsimp, simp]

lemma trident.ι_of_ι [nonempty J] {P : C} (ι : P ⟶ X) (w : ∀ j₁ j₂, ι ≫ f j₁ = ι ≫ f j₂) :
  (trident.of_ι ι w).ι = ι := rfl
lemma cotrident.π_of_π [nonempty J] {P : C} (π : Y ⟶ P) (w : ∀ j₁ j₂, f j₁ ≫ π = f j₂ ≫ π) :
  (cotrident.of_π π w).π = π := rfl

@[reassoc]
lemma trident.condition (j₁ j₂ : J) (t : trident f) : t.ι ≫ f j₁ = t.ι ≫ f j₂ :=
by rw [t.app_zero, t.app_zero]

@[reassoc]
lemma cotrident.condition (j₁ j₂ : J) (t : cotrident f) : f j₁ ≫ t.π = f j₂ ≫ t.π :=
by rw [t.app_one, t.app_one]

/-- To check whether two maps are equalized by both maps of a trident, it suffices to check it for
the first map -/
lemma trident.equalizer_ext [nonempty J] (s : trident f) {W : C} {k l : W ⟶ s.X}
  (h : k ≫ s.ι = l ≫ s.ι) : ∀ (j : walking_parallel_family J),
    k ≫ s.π.app j = l ≫ s.π.app j
| zero := h
| one := by rw [←s.app_zero (classical.arbitrary J), reassoc_of h]

/-- To check whether two maps are coequalized by both maps of a cotrident, it suffices to check it
for the second map -/
lemma cotrident.coequalizer_ext [nonempty J] (s : cotrident f) {W : C} {k l : s.X ⟶ W}
  (h : s.π ≫ k = s.π ≫ l) : ∀ (j : walking_parallel_family J),
    s.ι.app j ≫ k = s.ι.app j ≫ l
| zero := by rw [←s.app_one (classical.arbitrary J), category.assoc, category.assoc, h]
| one := h

lemma trident.is_limit.hom_ext [nonempty J] {s : trident f} (hs : is_limit s)
  {W : C} {k l : W ⟶ s.X} (h : k ≫ s.ι = l ≫ s.ι) :
  k = l :=
hs.hom_ext $ trident.equalizer_ext _ h

lemma cotrident.is_colimit.hom_ext [nonempty J] {s : cotrident f} (hs : is_colimit s)
  {W : C} {k l : s.X ⟶ W} (h : s.π ≫ k = s.π ≫ l) :
  k = l :=
hs.hom_ext $ cotrident.coequalizer_ext _ h

/-- If `s` is a limit trident over `f`, then a morphism `k : W ⟶ X` satisfying
    `∀ j₁ j₂, k ≫ f j₁ = k ≫ f j₂` induces a morphism `l : W ⟶ s.X` such that
    `l ≫ trident.ι s = k`. -/
def trident.is_limit.lift' [nonempty J] {s : trident f} (hs : is_limit s) {W : C} (k : W ⟶ X)
  (h : ∀ j₁ j₂, k ≫ f j₁ = k ≫ f j₂) :
  {l : W ⟶ s.X // l ≫ trident.ι s = k} :=
⟨hs.lift $ trident.of_ι _ h, hs.fac _ _⟩

/-- If `s` is a colimit cotrident over `f`, then a morphism `k : Y ⟶ W` satisfying
    `∀ j₁ j₂, f j₁ ≫ k = f j₂ ≫ k` induces a morphism `l : s.X ⟶ W` such that
    `cotrident.π s ≫ l = k`. -/
def cotrident.is_colimit.desc' [nonempty J] {s : cotrident f} (hs : is_colimit s) {W : C}
  (k : Y ⟶ W) (h : ∀ j₁ j₂, f j₁ ≫ k = f j₂ ≫ k) :
  {l : s.X ⟶ W // cotrident.π s ≫ l = k} :=
⟨hs.desc $ cotrident.of_π _ h, hs.fac _ _⟩

/-- This is a slightly more convenient method to verify that a trident is a limit cone. It
    only asks for a proof of facts that carry any mathematical content -/
def trident.is_limit.mk [nonempty J] (t : trident f)
  (lift : Π (s : trident f), s.X ⟶ t.X)
  (fac : ∀ (s : trident f), lift s ≫ t.ι = s.ι)
  (uniq : ∀ (s : trident f) (m : s.X ⟶ t.X)
  (w : ∀ j : walking_parallel_family J, m ≫ t.π.app j = s.π.app j), m = lift s) :
  is_limit t :=
{ lift := lift,
  fac' := λ s j, walking_parallel_family.cases_on j (fac s)
    (by rw [←t.w (line (classical.arbitrary J)), reassoc_of fac, s.w]),
  uniq' := uniq }

/-- This is another convenient method to verify that a trident is a limit cone. It
    only asks for a proof of facts that carry any mathematical content, and allows access to the
    same `s` for all parts. -/
def trident.is_limit.mk' [nonempty J] (t : trident f)
  (create : Π (s : trident f), {l // l ≫ t.ι = s.ι ∧ ∀ {m}, m ≫ t.ι = s.ι → m = l}) :
is_limit t :=
trident.is_limit.mk t
  (λ s, (create s).1)
  (λ s, (create s).2.1)
  (λ s m w, (create s).2.2 (w zero))

/-- This is a slightly more convenient method to verify that a cotrident is a colimit cocone. It
    only asks for a proof of facts that carry any mathematical content -/
def cotrident.is_colimit.mk [nonempty J] (t : cotrident f)
  (desc : Π (s : cotrident f), t.X ⟶ s.X)
  (fac : ∀ (s : cotrident f), t.π ≫ desc s = s.π)
  (uniq : ∀ (s : cotrident f) (m : t.X ⟶ s.X)
  (w : ∀ j : walking_parallel_family J, t.ι.app j ≫ m = s.ι.app j), m = desc s) :
  is_colimit t :=
{ desc := desc,
  fac' := λ s j, walking_parallel_family.cases_on j
    (by rw [←t.w_assoc (line (classical.arbitrary J)), fac, s.w]) (fac s),
  uniq' := uniq }

/-- This is another convenient method to verify that a cotrident is a colimit cocone. It
    only asks for a proof of facts that carry any mathematical content, and allows access to the
    same `s` for all parts. -/
def cotrident.is_colimit.mk' [nonempty J] (t : cotrident f)
  (create : Π (s : cotrident f), {l : t.X ⟶ s.X // t.π ≫ l = s.π ∧ ∀ {m}, t.π ≫ m = s.π → m = l}) :
  is_colimit t :=
cotrident.is_colimit.mk t
  (λ s, (create s).1)
  (λ s, (create s).2.1)
  (λ s m w, (create s).2.2 (w one))

/--
Given a limit cone for the family `f : J → (X ⟶ Y)`, for any `Z`, morphisms from `Z` to its point
are in bijection with morphisms `h : Z ⟶ X` such that `∀ j₁ j₂, h ≫ f j₁ = h ≫ f j₂`.
Further, this bijection is natural in `Z`: see `trident.is_limit.hom_iso_natural`.
-/
@[simps]
def trident.is_limit.hom_iso [nonempty J] {t : trident f} (ht : is_limit t) (Z : C) :
  (Z ⟶ t.X) ≃ {h : Z ⟶ X // ∀ j₁ j₂, h ≫ f j₁ = h ≫ f j₂} :=
{ to_fun := λ k, ⟨k ≫ t.ι, by simp⟩,
  inv_fun := λ h, (trident.is_limit.lift' ht _ h.prop).1,
  left_inv := λ k, trident.is_limit.hom_ext ht (trident.is_limit.lift' _ _ _).prop,
  right_inv := λ h, subtype.ext (trident.is_limit.lift' ht _ _).prop }

/-- The bijection of `trident.is_limit.hom_iso` is natural in `Z`. -/
lemma trident.is_limit.hom_iso_natural [nonempty J] {t : trident f} (ht : is_limit t)
  {Z Z' : C} (q : Z' ⟶ Z) (k : Z ⟶ t.X) :
  (trident.is_limit.hom_iso ht _ (q ≫ k) : Z' ⟶ X) =
  q ≫ (trident.is_limit.hom_iso ht _ k : Z ⟶ X) :=
category.assoc _ _ _

/--
Given a colimit cocone for the family `f : J → (X ⟶ Y)`, for any `Z`, morphisms from the cocone
point to `Z` are in bijection with morphisms `h : Z ⟶ X` such that
`∀ j₁ j₂, f j₁ ≫ h = f j₂ ≫ h`.  Further, this bijection is natural in `Z`: see
`cotrident.is_colimit.hom_iso_natural`.
-/
@[simps]
def cotrident.is_colimit.hom_iso [nonempty J] {t : cotrident f} (ht : is_colimit t) (Z : C) :
  (t.X ⟶ Z) ≃ {h : Y ⟶ Z // ∀ j₁ j₂, f j₁ ≫ h = f j₂ ≫ h} :=
{ to_fun := λ k, ⟨t.π ≫ k, by simp⟩,
  inv_fun := λ h, (cotrident.is_colimit.desc' ht _ h.prop).1,
  left_inv := λ k, cotrident.is_colimit.hom_ext ht (cotrident.is_colimit.desc' _ _ _).prop,
  right_inv := λ h, subtype.ext (cotrident.is_colimit.desc' ht _ _).prop }

/-- The bijection of `cotrident.is_colimit.hom_iso` is natural in `Z`. -/
lemma cotrident.is_colimit.hom_iso_natural [nonempty J] {t : cotrident f} {Z Z' : C}
  (q : Z ⟶ Z') (ht : is_colimit t) (k : t.X ⟶ Z) :
    (cotrident.is_colimit.hom_iso ht _ (k ≫ q) : Y ⟶ Z') =
    (cotrident.is_colimit.hom_iso ht _ k : Y ⟶ Z) ≫ q :=
(category.assoc _ _ _).symm

/-- This is a helper construction that can be useful when verifying that a category has certain wide
    equalizers. Given `F : walking_parallel_family ⥤ C`, which is really the same as
    `parallel_family (λ j, F.map (line j))`, and a trident on `λ j, F.map (line j)`, we get a cone
    on `F`.

    If you're thinking about using this, have a look at
    `has_wide_equalizers_of_has_limit_parallel_family`, which you may find to be an easier way of
    achieving your goal. -/
def cone.of_trident
  {F : walking_parallel_family J ⥤ C} (t : trident (λ j, F.map (line j))) : cone F :=
{ X := t.X,
  π :=
  { app := λ X, t.π.app X ≫ eq_to_hom (by tidy),
    naturality' := λ j j' g, by { cases g; { dsimp, simp } } } }

/-- This is a helper construction that can be useful when verifying that a category has all
    coequalizers. Given `F : walking_parallel_family ⥤ C`, which is really the same as
    `parallel_family (λ j, F.map (line j))`, and a cotrident on `λ j, F.map (line j)` we get a
    cocone on `F`.

    If you're thinking about using this, have a look at
    `has_wide_coequalizers_of_has_colimit_parallel_family`, which you may find to be an easier way
    of achieving your goal. -/
def cocone.of_cotrident
  {F : walking_parallel_family J ⥤ C} (t : cotrident (λ j, F.map (line j))) : cocone F :=
{ X := t.X,
  ι :=
  { app := λ X, eq_to_hom (by tidy) ≫ t.ι.app X,
    naturality' := λ j j' g, by { cases g; dsimp; simp [cotrident.app_one t] } } }

@[simp] lemma cone.of_trident_π
  {F : walking_parallel_family J ⥤ C} (t : trident (λ j, F.map (line j))) (j) :
  (cone.of_trident t).π.app j = t.π.app j ≫ eq_to_hom (by tidy) := rfl

@[simp] lemma cocone.of_cotrident_ι
  {F : walking_parallel_family J ⥤ C} (t : cotrident (λ j, F.map (line j))) (j) :
  (cocone.of_cotrident t).ι.app j = eq_to_hom (by tidy) ≫ t.ι.app j := rfl

/-- Given `F : walking_parallel_family ⥤ C`, which is really the same as
    `parallel_family (λ j, F.map (line j))` and a cone on `F`, we get a trident on
    `λ j, F.map (line j)`. -/
def trident.of_cone
  {F : walking_parallel_family J ⥤ C} (t : cone F) : trident (λ j, F.map (line j)) :=
{ X := t.X,
  π := { app := λ X, t.π.app X ≫ eq_to_hom (by tidy) } }

/-- Given `F : walking_parallel_family ⥤ C`, which is really the same as
    `parallel_family (F.map left) (F.map right)` and a cocone on `F`, we get a cotrident on
    `λ j, F.map (line j)`. -/
def cotrident.of_cocone
  {F : walking_parallel_family J ⥤ C} (t : cocone F) : cotrident (λ j, F.map (line j)) :=
{ X := t.X,
  ι := { app := λ X, eq_to_hom (by tidy) ≫ t.ι.app X } }

@[simp] lemma trident.of_cone_π {F : walking_parallel_family J ⥤ C} (t : cone F) (j) :
  (trident.of_cone t).π.app j = t.π.app j ≫ eq_to_hom (by tidy) := rfl
@[simp] lemma cotrident.of_cocone_ι {F : walking_parallel_family J ⥤ C} (t : cocone F) (j) :
  (cotrident.of_cocone t).ι.app j = eq_to_hom (by tidy) ≫ t.ι.app j := rfl

/--
Helper function for constructing morphisms between wide equalizer tridents.
-/
@[simps]
def trident.mk_hom [nonempty J] {s t : trident f} (k : s.X ⟶ t.X) (w : k ≫ t.ι = s.ι) : s ⟶ t :=
{ hom := k,
  w' :=
  begin
    rintro ⟨_|_⟩,
    { exact w },
    { simpa using w =≫ f (classical.arbitrary J) },
  end }

/--
To construct an isomorphism between tridents,
it suffices to give an isomorphism between the cone points
and check that it commutes with the `ι` morphisms.
-/
@[simps]
def trident.ext [nonempty J] {s t : trident f} (i : s.X ≅ t.X) (w : i.hom ≫ t.ι = s.ι) : s ≅ t :=
{ hom := trident.mk_hom i.hom w,
  inv := trident.mk_hom i.inv (by rw [← w, iso.inv_hom_id_assoc]) }

/--
Helper function for constructing morphisms between coequalizer cotridents.
-/
@[simps]
def cotrident.mk_hom [nonempty J] {s t : cotrident f} (k : s.X ⟶ t.X) (w : s.π ≫ k = t.π) :
  s ⟶ t :=
{ hom := k,
  w' :=
  begin
    rintro ⟨_|_⟩,
    { simpa using f (classical.arbitrary J) ≫= w },
    { exact w },
  end }

/--
To construct an isomorphism between cotridents,
it suffices to give an isomorphism between the cocone points
and check that it commutes with the `π` morphisms.
-/
def cotrident.ext [nonempty J] {s t : cotrident f} (i : s.X ≅ t.X) (w : s.π ≫ i.hom = t.π) :
  s ≅ t :=
{ hom := cotrident.mk_hom i.hom w,
  inv := cotrident.mk_hom i.inv (by rw [iso.comp_inv_eq, w]) }

variables (f)

section
/--
`has_wide_equalizer f` represents a particular choice of limiting cone for the parallel family of
morphisms `f`.
-/
abbreviation has_wide_equalizer := has_limit (parallel_family f)

variables [has_wide_equalizer f]

/-- If a wide equalizer of `f` exists, we can access an arbitrary choice of such by
    saying `wide_equalizer f`. -/
abbreviation wide_equalizer : C := limit (parallel_family f)

/-- If a wide equalizer of `f` exists, we can access the inclusion `wide_equalizer f ⟶ X` by
    saying `wide_equalizer.ι f`. -/
abbreviation wide_equalizer.ι : wide_equalizer f ⟶ X :=
limit.π (parallel_family f) zero

/--
A wide equalizer cone for a parallel family `f`.
-/
abbreviation wide_equalizer.trident : trident f := limit.cone (parallel_family f)

@[simp] lemma wide_equalizer.trident_ι :
  (wide_equalizer.trident f).ι = wide_equalizer.ι f := rfl

@[simp] lemma wide_equalizer.trident_π_app_zero :
  (wide_equalizer.trident f).π.app zero = wide_equalizer.ι f := rfl

@[reassoc] lemma wide_equalizer.condition (j₁ j₂ : J) :
  wide_equalizer.ι f ≫ f j₁ = wide_equalizer.ι f ≫ f j₂ :=
trident.condition j₁ j₂ $ limit.cone $ parallel_family f

/-- The wide_equalizer built from `wide_equalizer.ι f` is limiting. -/
def wide_equalizer_is_wide_equalizer [nonempty J] :
  is_limit (trident.of_ι (wide_equalizer.ι f) (wide_equalizer.condition f)) :=
is_limit.of_iso_limit (limit.is_limit _) (trident.ext (iso.refl _) (by tidy))

variables {f}

/-- A morphism `k : W ⟶ X` satisfying `∀ j₁ j₂, k ≫ f j₁ = k ≫ f j₂` factors through the
    wide equalizer of `f` via `wide_equalizer.lift : W ⟶ wide_equalizer f`. -/
abbreviation wide_equalizer.lift [nonempty J] {W : C} (k : W ⟶ X)
  (h : ∀ j₁ j₂, k ≫ f j₁ = k ≫ f j₂) :
  W ⟶ wide_equalizer f :=
limit.lift (parallel_family f) (trident.of_ι k h)

@[simp, reassoc]
lemma wide_equalizer.lift_ι [nonempty J] {W : C} (k : W ⟶ X) (h : ∀ j₁ j₂, k ≫ f j₁ = k ≫ f j₂) :
  wide_equalizer.lift k h ≫ wide_equalizer.ι f = k :=
limit.lift_π _ _

/-- A morphism `k : W ⟶ X` satisfying `∀ j₁ j₂, k ≫ f j₁ = k ≫ f j₂` induces a morphism
    `l : W ⟶ wide_equalizer f` satisfying `l ≫ wide_equalizer.ι f = k`. -/
def wide_equalizer.lift' [nonempty J] {W : C} (k : W ⟶ X) (h : ∀ j₁ j₂, k ≫ f j₁ = k ≫ f j₂) :
  {l : W ⟶ wide_equalizer f // l ≫ wide_equalizer.ι f = k} :=
⟨wide_equalizer.lift k h, wide_equalizer.lift_ι _ _⟩

/-- Two maps into a wide equalizer are equal if they are are equal when composed with the wide
    equalizer map. -/
@[ext] lemma wide_equalizer.hom_ext [nonempty J] {W : C} {k l : W ⟶ wide_equalizer f}
  (h : k ≫ wide_equalizer.ι f = l ≫ wide_equalizer.ι f) : k = l :=
trident.is_limit.hom_ext (limit.is_limit _) h

/-- A wide equalizer morphism is a monomorphism -/
instance wide_equalizer.ι_mono [nonempty J] : mono (wide_equalizer.ι f) :=
{ right_cancellation := λ Z h k w, wide_equalizer.hom_ext w }

end

section
variables {f}
/-- The wide equalizer morphism in any limit cone is a monomorphism. -/
lemma mono_of_is_limit_parallel_family [nonempty J] {c : cone (parallel_family f)}
  (i : is_limit c) :
  mono (trident.ι c) :=
{ right_cancellation := λ Z h k w, trident.is_limit.hom_ext i w }

end

section
/--
`has_wide_coequalizer f g` represents a particular choice of colimiting cocone
for the parallel family of morphisms `f`.
-/
abbreviation has_wide_coequalizer := has_colimit (parallel_family f)

variables [has_wide_coequalizer f]

/-- If a wide coequalizer of `f`, we can access an arbitrary choice of such by
    saying `wide_coequalizer f`. -/
abbreviation wide_coequalizer : C := colimit (parallel_family f)

/--  If a wide_coequalizer of `f` exists, we can access the corresponding projection by
    saying `wide_coequalizer.π f`. -/
abbreviation wide_coequalizer.π : Y ⟶ wide_coequalizer f :=
colimit.ι (parallel_family f) one

/--
An arbitrary choice of coequalizer cocone for a parallel family `f`.
-/
abbreviation wide_coequalizer.cotrident : cotrident f := colimit.cocone (parallel_family f)

@[simp] lemma wide_coequalizer.cotrident_π :
  (wide_coequalizer.cotrident f).π = wide_coequalizer.π f := rfl

@[simp] lemma wide_coequalizer.cotrident_ι_app_one :
  (wide_coequalizer.cotrident f).ι.app one = wide_coequalizer.π f := rfl

@[reassoc] lemma wide_coequalizer.condition (j₁ j₂ : J) :
  f j₁ ≫ wide_coequalizer.π f = f j₂ ≫ wide_coequalizer.π f :=
cotrident.condition j₁ j₂ $ colimit.cocone $ parallel_family f

/-- The cotrident built from `wide_coequalizer.π f` is colimiting. -/
def wide_coequalizer_is_wide_coequalizer [nonempty J] :
  is_colimit (cotrident.of_π (wide_coequalizer.π f) (wide_coequalizer.condition f)) :=
is_colimit.of_iso_colimit (colimit.is_colimit _) (cotrident.ext (iso.refl _) (by tidy))

variables {f}

/-- Any morphism `k : Y ⟶ W` satisfying `∀ j₁ j₂, f j₁ ≫ k = f j₂ ≫ k` factors through the
    wide coequalizer of `f` via `wide_coequalizer.desc : wide_coequalizer f ⟶ W`. -/
abbreviation wide_coequalizer.desc [nonempty J] {W : C} (k : Y ⟶ W)
  (h : ∀ j₁ j₂, f j₁ ≫ k = f j₂ ≫ k) :
  wide_coequalizer f ⟶ W :=
colimit.desc (parallel_family f) (cotrident.of_π k h)

@[simp, reassoc]
lemma wide_coequalizer.π_desc [nonempty J] {W : C} (k : Y ⟶ W) (h : ∀ j₁ j₂, f j₁ ≫ k = f j₂ ≫ k) :
  wide_coequalizer.π f ≫ wide_coequalizer.desc k h = k :=
colimit.ι_desc _ _

/-- Any morphism `k : Y ⟶ W` satisfying `∀ j₁ j₂, f j₁ ≫ k = f j₂ ≫ k` induces a morphism
    `l : wide_coequalizer f ⟶ W` satisfying `wide_coequalizer.π ≫ g = l`. -/
def wide_coequalizer.desc' [nonempty J] {W : C} (k : Y ⟶ W) (h : ∀ j₁ j₂, f j₁ ≫ k = f j₂ ≫ k) :
  {l : wide_coequalizer f ⟶ W // wide_coequalizer.π f ≫ l = k} :=
⟨wide_coequalizer.desc k h, wide_coequalizer.π_desc _ _⟩

/-- Two maps from a wide coequalizer are equal if they are equal when composed with the wide
    coequalizer map -/
@[ext] lemma wide_coequalizer.hom_ext [nonempty J] {W : C} {k l : wide_coequalizer f ⟶ W}
  (h : wide_coequalizer.π f ≫ k = wide_coequalizer.π f ≫ l) : k = l :=
cotrident.is_colimit.hom_ext (colimit.is_colimit _) h

/-- A wide coequalizer morphism is an epimorphism -/
instance wide_coequalizer.π_epi [nonempty J] : epi (wide_coequalizer.π f) :=
{ left_cancellation := λ Z h k w, wide_coequalizer.hom_ext w }

end

section
variables {f}

/-- The wide coequalizer morphism in any colimit cocone is an epimorphism. -/
lemma epi_of_is_colimit_parallel_family [nonempty J] {c : cocone (parallel_family f)}
  (i : is_colimit c) :
  epi (c.ι.app one) :=
{ left_cancellation := λ Z h k w, cotrident.is_colimit.hom_ext i w }

end

variables (C)

/-- `has_wide_equalizers` represents a choice of wide equalizer for every family of morphisms -/
abbreviation has_wide_equalizers := Π J, has_limits_of_shape (walking_parallel_family.{w} J) C

/-- `has_wide_coequalizers` represents a choice of wide coequalizer for every family of morphisms -/
abbreviation has_wide_coequalizers := Π J, has_colimits_of_shape (walking_parallel_family.{w} J) C

/-- If `C` has all limits of diagrams `parallel_family f`, then it has all wide equalizers -/
lemma has_wide_equalizers_of_has_limit_parallel_family
  [Π {J : Type w} {X Y : C} {f : J → (X ⟶ Y)}, has_limit (parallel_family f)] :
  has_wide_equalizers.{w} C :=
λ J, { has_limit := λ F, has_limit_of_iso (diagram_iso_parallel_family F).symm }

/-- If `C` has all colimits of diagrams `parallel_family f`, then it has all wide coequalizers -/
lemma has_wide_coequalizers_of_has_colimit_parallel_family
  [Π {J : Type w} {X Y : C} {f : J → (X ⟶ Y)}, has_colimit (parallel_family f)] :
  has_wide_coequalizers.{w} C :=
λ J, { has_colimit := λ F, has_colimit_of_iso (diagram_iso_parallel_family F) }

@[priority 10]
instance has_equalizers_of_has_wide_equalizers [has_wide_equalizers.{w} C] : has_equalizers C :=
has_limits_of_shape_of_equivalence.{w} walking_parallel_family_equiv_walking_parallel_pair

@[priority 10]
instance has_coequalizers_of_has_wide_coequalizers [has_wide_coequalizers.{w} C] :
  has_coequalizers C :=
has_colimits_of_shape_of_equivalence.{w} walking_parallel_family_equiv_walking_parallel_pair

end category_theory.limits


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

! This file was ported from Lean 3 source module algebra.group.order_synonym
! leanprover-community/mathlib commit d6aae1bcbd04b8de2022b9b83a5b5b10e10c777d
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.Group.Defs
import Mathlib.Order.Synonym

/-!
# Group structure on the order type synonyms

Transfer algebraic instances from `α` to `αᵒᵈ` and `lex α`.
-/

open OrderDual

variable {α β : Type _}

/-! ### `OrderDual` -/

@[to_additive]
instance [h : One α] : One αᵒᵈ := h

@[to_additive]
instance [h : Mul α] : Mul αᵒᵈ := h

@[to_additive]
instance [h : Inv α] : Inv αᵒᵈ := h

@[to_additive]
instance [h : Div α] : Div αᵒᵈ := h

@[to_additive (attr := to_additive) (reorder := 1) instSMulOrderDual]
instance [h : Pow α β] : Pow αᵒᵈ β := h
#align order_dual.has_pow instPowOrderDual
#align order_dual.has_smul instSMulOrderDual

@[to_additive (attr := to_additive) (reorder := 1) instSMulOrderDual']
instance instPowOrderDual' [h : Pow α β] : Pow α βᵒᵈ := h
#align order_dual.has_pow' instPowOrderDual'
#align order_dual.has_smul' instSMulOrderDual'

@[to_additive]
instance [h : Semigroup α] : Semigroup αᵒᵈ := h

@[to_additive]
instance [h : CommSemigroup α] : CommSemigroup αᵒᵈ := h

@[to_additive]
instance [h : LeftCancelSemigroup α] : LeftCancelSemigroup αᵒᵈ := h

@[to_additive]
instance [h : RightCancelSemigroup α] : RightCancelSemigroup αᵒᵈ := h

@[to_additive]
instance [h : MulOneClass α] : MulOneClass αᵒᵈ := h

@[to_additive]
instance [h : Monoid α] : Monoid αᵒᵈ := h

@[to_additive]
instance [h : CommMonoid α] : CommMonoid αᵒᵈ := h

@[to_additive]
instance [h : LeftCancelMonoid α] : LeftCancelMonoid αᵒᵈ := h

@[to_additive]
instance [h : RightCancelMonoid α] : RightCancelMonoid αᵒᵈ := h

@[to_additive]
instance [h : CancelMonoid α] : CancelMonoid αᵒᵈ := h

@[to_additive]
instance [h : CancelCommMonoid α] : CancelCommMonoid αᵒᵈ := h

@[to_additive]
instance [h : InvolutiveInv α] : InvolutiveInv αᵒᵈ := h

@[to_additive]
instance [h : DivInvMonoid α] : DivInvMonoid αᵒᵈ := h

@[to_additive OrderDual.subtractionMonoid]
instance [h : DivisionMonoid α] : DivisionMonoid αᵒᵈ := h

@[to_additive OrderDual.subtractionCommMonoid]
instance [h : DivisionCommMonoid α] : DivisionCommMonoid αᵒᵈ := h

@[to_additive]
instance [h : Group α] : Group αᵒᵈ := h
#align order_dual.group instGroupOrderDual
#align order_dual.add_group instAddGroupOrderDual

@[to_additive]
instance [h : CommGroup α] : CommGroup αᵒᵈ := h

@[to_additive (attr := simp)]
theorem toDual_one [One α] : toDual (1 : α) = 1 := rfl
#align to_dual_one toDual_one
#align to_dual_zero toDual_zero

@[to_additive (attr := simp)]
theorem ofDual_one [One α] : (ofDual 1 : α) = 1 := rfl
#align of_dual_one ofDual_one
#align of_dual_zero ofDual_zero

@[to_additive (attr := simp)]
theorem toDual_mul [Mul α] (a b : α) : toDual (a * b) = toDual a * toDual b := rfl
#align to_dual_mul toDual_mul
#align to_dual_add toDual_add

@[to_additive (attr := simp)]
theorem ofDual_mul [Mul α] (a b : αᵒᵈ) : ofDual (a * b) = ofDual a * ofDual b := rfl
#align of_dual_mul ofDual_mul
#align of_dual_add ofDual_add

@[to_additive (attr := simp)]
theorem toDual_inv [Inv α] (a : α) : toDual a⁻¹ = (toDual a)⁻¹ := rfl
#align to_dual_inv toDual_inv
#align to_dual_neg toDual_neg

@[to_additive (attr := simp)]
theorem ofDual_inv [Inv α] (a : αᵒᵈ) : ofDual a⁻¹ = (ofDual a)⁻¹ := rfl
#align of_dual_inv ofDual_inv
#align of_dual_neg ofDual_neg

@[to_additive (attr := simp)]
theorem toDual_div [Div α] (a b : α) : toDual (a / b) = toDual a / toDual b := rfl
#align to_dual_div toDual_div
#align to_dual_sub toDual_sub

@[to_additive (attr := simp)]
theorem ofDual_div [Div α] (a b : αᵒᵈ) : ofDual (a / b) = ofDual a / ofDual b := rfl
#align of_dual_div ofDual_div
#align of_dual_sub ofDual_sub

@[to_additive (attr := simp, to_additive) (reorder := 1 4) toDual_smul]
theorem toDual_pow [Pow α β] (a : α) (b : β) : toDual (a ^ b) = toDual a ^ b := rfl
#align to_dual_pow toDual_pow
#align to_dual_smul toDual_smul
#align to_dual_vadd toDual_vadd

@[to_additive (attr := simp, to_additive) (reorder := 1 4) ofDual_smul]
theorem ofDual_pow [Pow α β] (a : αᵒᵈ) (b : β) : ofDual (a ^ b) = ofDual a ^ b := rfl
#align of_dual_pow ofDual_pow
#align of_dual_smul ofDual_smul
#align of_dual_vadd ofDual_vadd

@[to_additive (attr := simp, to_additive) (reorder := 1 4) toDual_smul']
theorem pow_toDual [Pow α β] (a : α) (b : β) : a ^ toDual b = a ^ b := rfl
#align pow_to_dual pow_toDual
#align to_dual_smul' toDual_smul'
#align to_dual_vadd' toDual_vadd'

@[to_additive (attr := simp, to_additive) (reorder := 1 4) ofDual_smul']
theorem pow_ofDual [Pow α β] (a : α) (b : βᵒᵈ) : a ^ ofDual b = a ^ b := rfl
#align pow_of_dual pow_ofDual
#align of_dual_smul' ofDual_smul'
#align of_dual_vadd' ofDual_vadd'

/-! ### Lexicographical order -/

@[to_additive]
instance [h : One α] : One (Lex α) := h

@[to_additive]
instance [h : Mul α] : Mul (Lex α) := h

@[to_additive]
instance [h : Inv α] : Inv (Lex α) := h

@[to_additive]
instance [h : Div α] : Div (Lex α) := h

@[to_additive (attr := to_additive) (reorder := 1) instSMulLex]
instance [h : Pow α β] : Pow (Lex α) β := h
#align lex.has_pow instPowLex
#align lex.has_smul instSMulLex

@[to_additive (attr := to_additive) (reorder := 1) instSMulLex']
instance instPowLex' [h : Pow α β] : Pow α (Lex β) := h
#align lex.has_pow' instPowLex'
#align lex.has_smul' instSMulLex'

@[to_additive]
instance [h : Semigroup α] : Semigroup (Lex α) := h

@[to_additive]
instance [h : CommSemigroup α] : CommSemigroup (Lex α) := h

@[to_additive]
instance [h : LeftCancelSemigroup α] : LeftCancelSemigroup (Lex α) := h

@[to_additive]
instance [h : RightCancelSemigroup α] : RightCancelSemigroup (Lex α) := h

@[to_additive]
instance [h : MulOneClass α] : MulOneClass (Lex α) := h

@[to_additive]
instance [h : Monoid α] : Monoid (Lex α) := h

@[to_additive]
instance [h : CommMonoid α] : CommMonoid (Lex α) := h

@[to_additive]
instance [h : LeftCancelMonoid α] : LeftCancelMonoid (Lex α) := h

@[to_additive]
instance [h : RightCancelMonoid α] : RightCancelMonoid (Lex α) := h

@[to_additive]
instance [h : CancelMonoid α] : CancelMonoid (Lex α) := h

@[to_additive]
instance [h : CancelCommMonoid α] : CancelCommMonoid (Lex α) := h

@[to_additive]
instance [h : InvolutiveInv α] : InvolutiveInv (Lex α) := h

@[to_additive]
instance [h : DivInvMonoid α] : DivInvMonoid (Lex α) := h

@[to_additive existing OrderDual.subtractionMonoid]
instance [h : DivisionMonoid α] : DivisionMonoid (Lex α) := h

@[to_additive existing OrderDual.subtractionCommMonoid]
instance [h : DivisionCommMonoid α] : DivisionCommMonoid (Lex α) := h

@[to_additive]
instance [h : Group α] : Group (Lex α) := h

@[to_additive]
instance [h : CommGroup α] : CommGroup (Lex α) := h

@[to_additive (attr := simp)]
theorem toLex_one [One α] : toLex (1 : α) = 1 := rfl
#align to_lex_one toLex_one
#align to_lex_zero toLex_zero

@[to_additive (attr := simp)]
theorem ofLex_one [One α] : (ofLex 1 : α) = 1 := rfl
#align of_lex_one ofLex_one
#align of_lex_zero ofLex_zero

@[to_additive (attr := simp)]
theorem toLex_mul [Mul α] (a b : α) : toLex (a * b) = toLex a * toLex b := rfl
#align to_lex_mul toLex_mul
#align to_lex_add toLex_add

@[to_additive (attr := simp)]
theorem ofLex_mul [Mul α] (a b : Lex α) : ofLex (a * b) = ofLex a * ofLex b := rfl
#align of_lex_mul ofLex_mul
#align of_lex_add ofLex_add

@[to_additive (attr := simp)]
theorem toLex_inv [Inv α] (a : α) : toLex a⁻¹ = (toLex a)⁻¹ := rfl
#align to_lex_inv toLex_inv
#align to_lex_neg toLex_neg

@[to_additive (attr := simp)]
theorem ofLex_inv [Inv α] (a : Lex α) : ofLex a⁻¹ = (ofLex a)⁻¹ := rfl
#align of_lex_inv ofLex_inv
#align of_lex_neg ofLex_neg

@[to_additive (attr := simp)]
theorem toLex_div [Div α] (a b : α) : toLex (a / b) = toLex a / toLex b := rfl
#align to_lex_div toLex_div
#align to_lex_sub toLex_sub

@[to_additive (attr := simp)]
theorem ofLex_div [Div α] (a b : Lex α) : ofLex (a / b) = ofLex a / ofLex b := rfl
#align of_lex_div ofLex_div
#align of_lex_sub ofLex_sub

@[to_additive (attr := simp, to_additive) (reorder := 1 4) toLex_smul]
theorem toLex_pow [Pow α β] (a : α) (b : β) : toLex (a ^ b) = toLex a ^ b := rfl
#align to_lex_pow toLex_pow
#align to_lex_smul toLex_smul
#align to_lex_vadd toLex_vadd

@[to_additive (attr := simp, to_additive) (reorder := 1 4) ofLex_smul]
theorem ofLex_pow [Pow α β] (a : Lex α) (b : β) : ofLex (a ^ b) = ofLex a ^ b := rfl
#align of_lex_pow ofLex_pow
#align of_lex_smul ofLex_smul
#align of_lex_vadd ofLex_vadd

@[to_additive (attr := simp, to_additive) (reorder := 1 4) toLex_smul']
theorem pow_toLex [Pow α β] (a : α) (b : β) : a ^ toLex b = a ^ b := rfl
#align pow_to_lex pow_toLex
#align to_lex_smul' toLex_smul'
#align to_lex_vadd' toLex_vadd'

@[to_additive (attr := simp, to_additive) (reorder := 1 4) ofLex_smul']
theorem pow_ofLex [Pow α β] (a : α) (b : Lex β) : a ^ ofLex b = a ^ b := rfl
#align pow_of_lex pow_ofLex
#align of_lex_smul' ofLex_smul'
#align of_lex_vadd' ofLex_vadd'


import tactic
import defs

namespace coc
section

open expr

/-- Three-way comparison operator. -/
inductive threeway (m n : nat) : Prop
| lt : m < n → threeway
| eq : m = n → threeway
| gt : n < m → threeway

@[irreducible]
def threeway_cmp (m n : nat) : threeway m n :=
  dite (m < n) threeway.lt
    (dite (m = n) (λ h _, threeway.eq h)
      (λ h₁ h₂, threeway.gt
        (nat.lt_of_le_and_ne (le_of_not_lt h₂)
          (λ h : n = m, (h₁ h.symm)))))

def expr.has_open : expr → nat → Prop
| (sort s)   n := false
| (var v)    n := v = n
| (app l r)  n := expr.has_open l n ∨ expr.has_open r n
| (lam t e)  n := expr.has_open t n ∨ expr.has_open e n.succ
| (pi t₁ t₂) n := expr.has_open t₁ n ∨ expr.has_open t₂ n.succ

def expr.closed : expr → nat → Prop
| (sort s)   n := true
| (var v)    n := v < n
| (app l r)  n := expr.closed l n ∧ expr.closed r n
| (lam t e)  n := expr.closed t n ∧ expr.closed e n.succ
| (pi t₁ t₂) n := expr.closed t₁ n ∧ expr.closed t₂ n.succ

structure cexpr (n : nat) : Type :=
  (e : expr) (hce : expr.closed e n)

open expr

/- Lemmas for `has_open e n`: `e` has variables unbound at `n`-th level. -/
namespace has_open
  lemma ho_var {v n} (h : v = n) :                              has_open (var v) n   := h
  lemma ho_app_left {l r n}          (hl : has_open l n) :      has_open (app l r) n := or.inl hl
  lemma ho_app_right {l r n}         (hr : has_open r n) :      has_open (app l r) n := or.inr hr
  lemma ho_lam_left {l r n}          (hl : has_open l n) :      has_open (lam l r) n := or.inl hl
  lemma ho_lam_right {l r} {n : nat} (hr : has_open r n.succ) : has_open (lam l r) n := or.inr hr
  lemma ho_pi_left {l r n}           (hl : has_open l n) :      has_open (pi l r) n  := or.inl hl
  lemma ho_pi_right {l r} {n : nat}  (hr : has_open r n.succ) : has_open (pi l r) n  := or.inr hr
end has_open
open has_open

/- Lemmas for `closed e n`: `e` has at most `n` levels of unbound variables. -/
namespace closed
  lemma c_sort (s n)                                                  : closed (sort s) n   := trivial
  lemma c_var {v n} (h : v < n)                                       : closed (var v) n    := h
  lemma c_app {l r n} (hcl : closed l n) (hcr : closed r n)           : closed (app l r) n  := ⟨hcl, hcr⟩
  lemma c_lam {t e n} (hct : closed t n) (hce : closed e n.succ)      : closed (lam t e) n  := ⟨hct, hce⟩
  lemma c_pi {t₁ t₂ n} (hct₁ : closed t₁ n) (hct₂ : closed t₂ n.succ) : closed (pi t₁ t₂) n := ⟨hct₁, hct₂⟩
  lemma c_weaken {e n n'} (hce : closed e n) (h : n <= n') : closed e n' :=
    @expr.rec (λ e, ∀ n n', n ≤ n' → closed e n → closed e n')
      (λ _ _ _ _ _, c_sort _ _)
      (λ v _ _ h h', c_var (lt_of_lt_of_le h' h))
      (λ _ _ hl hr _ _ h ⟨hcl, hcr⟩, ⟨hl _ _ h hcl, hr _ _ h hcr⟩)
      (λ _ _ ht he _ _ h ⟨hct, hce⟩, ⟨ht _ _ h hct, he _ _ (nat.succ_le_succ h) hce⟩)
      (λ _ _ ht₁ ht₂ _ _ h ⟨hct₁, hct₂⟩, ⟨ht₁ _ _ h hct₁, ht₂ _ _ (nat.succ_le_succ h) hct₂⟩)
      e n n' h hce
  lemma c_weaken₁ {e n} (hce : closed e n) : closed e n.succ :=
    c_weaken hce (nat.le_succ n)
end closed
open closed

lemma has_open.below_closed {e n n'} (ho : has_open e n') (hc : closed e n) : n' < n := by
{ induction e generalizing n n',
  case sort { unfold has_open at *, trivial },
  case var : v _ _ ho hc { unfold has_open closed at *, rw ho at hc, exact hc },
  case app : _ _ hl hr _ _ ho hc { cases ho, exact hl ho hc.1, exact hr ho hc.2 },
  case lam : _ _ ht he _ _ ho hc { cases ho, exact ht ho hc.1, exact nat.lt_of_succ_lt_succ (he ho hc.2) },
  case pi : _ _ ht₁ ht₂ _ _ ho hc { cases ho, exact ht₁ ho hc.1, exact nat.lt_of_succ_lt_succ (ht₂ ho hc.2) } }

lemma test : well_founded (nat.lt) :=
  ⟨λ n, by
  { induction n,
    case zero { apply acc.intro, intros x hx, exfalso, exact nat.not_lt_zero x hx },
    case succ : n ih
    { have h : ∀ x, x < n → acc nat.lt x := λ _, acc.inv ih,
      apply acc.intro,
      intros x hx,
      cases hx,
      case refl { exact ih },
      case step : y hy { apply h, exact nat.lt_of_succ_le hy } } }⟩

/-
case t_conv : Γ e t t' s hc ht he iht ihe { dedup, sorry },
case t_sort : Γ n hw ih { dedup, sorry },
case t_var : Γ n t hw ht ih { dedup, sorry },
case t_app : Γ l r t₁ t₂ hl hr ihl ihr { dedup, sorry },
case t_lam : Γ t₁ t₂ s e hs he iht ihe { dedup, sorry },
case t_pi : Γ t₁ s₁ t₂ s₂ ht₁ ht₂ iht₁ iht₂ { dedup, sorry }
-/

#check @classical.choice
#check @classical.indefinite_description

end
end coc


import hmem.stack

universe u
variables {α: Type u} [has_zero α] [decidable_eq α]

def rel_iterate {α: Type u} (r: α → α → Prop): ℕ → α → α → Prop
| 0 a a' := a = a'
| (n+1) a a' := ∃ x, r a x ∧ rel_iterate n x a'

notation f`^~[`n`]` := rel_iterate f n

theorem rel_iterate_zero {α: Type u} (r: α → α → Prop) (a: α):
  r^~[0] a a := eq.refl _

theorem rel_iterate_zero_iff {α: Type u} (r: α → α → Prop) (a b: α):
  r^~[0] a b ↔ a = b := by refl

theorem rel_iterate_one_iff {α: Type u} (r: α → α → Prop) (a b: α):
  r^~[1] a b ↔ r a b :=
begin
  split,
  { intro h,
    rcases h with ⟨x, hr, h⟩,
    rw [rel_iterate_zero_iff] at h,
    rwa [← h] },
  { intro h,
    refine ⟨ b, h, rel_iterate_zero _ _⟩ },
end

theorem rel_iterate_succ_iff {α: Type u} (r: α → α → Prop) (a b: α) (n: ℕ):
  r^~[n+1] a b ↔ ∃ x, r a x ∧ (r^~[n]) x b := by refl

theorem rel_iterate_succ_iff' {α: Type u} (r: α → α → Prop) (a b: α) (n: ℕ):
  r^~[n+1] a b ↔ ∃ x, r^~[n] a x ∧ r x b :=
begin
  induction n generalizing a b,
  { simp only [rel_iterate_succ_iff, rel_iterate_zero_iff, exists_eq_left', exists_eq_right] },
  { simp only [nat.succ_add, rel_iterate_succ_iff _ a, n_ih _ b, ← exists_and_distrib_left, ← exists_and_distrib_right, and_assoc],
    rw [exists_comm] },
end

theorem rel_iterate_sum_iff {α: Type u} (r: α → α → Prop) (a b: α) (n m: ℕ):
  r^~[n+m] a b ↔ ∃ x, r^~[n] a x ∧ (r^~[m]) x b :=
begin
  induction n generalizing a b,
  { simp only [zero_add, rel_iterate_zero_iff, exists_eq_left'] },
  { simp only [nat.succ_add, rel_iterate_succ_iff, n_ih, ← exists_and_distrib_left, ← exists_and_distrib_right, and_assoc],
    rw [exists_comm] }
end

namespace hmem

def program.max_internal_cost: program α → ℕ
| [] := 1
| ((@instruction.ite _ _ _ is')::is) := max (program.max_internal_cost is) (program.max_internal_cost is') + 1
| (i::is) := program.max_internal_cost is + 1

namespace thunk

def step_over (t r: thunk α): Prop :=
  match t.step with
  | (sum.inl t') := t' = r
  | (sum.inr (sum.inl m)) := false
  | (sum.inr (sum.inr (p, m, t'))) :=
    (p.get_or_else t.function).has_result m (r.state.getm 0)
    ∧ r = t'.set_result (r.state.getm 0)
  end

theorem step_over_unique {t r r': thunk α}:
  step_over t r → step_over t r' → r = r' :=
begin
  cases hstep:t.step,
  { simp only [step_over, hstep],
    intros hr hr',
    rw [← hr, ← hr'] },
  rcases val with _|⟨_, _, _⟩,
  { simp only [step_over, hstep, false_implies_iff] },
  simp only [step_over, hstep, and_imp],
  intros hres hr hres' hr',
  rw [hr, hr', program.unique_result hres hres']
end

theorem step_over_decreasing {t r: thunk α}:
  step_over t r → r.current.max_internal_cost < t.current.max_internal_cost :=
begin
  cases t,
  cases t_current,
  { simp only [step_over, stack.step, step, false_implies_iff] },
  cases t_current_hd;
  try { simp only [step_over, stack.step, step, program.max_internal_cost],
    intro hr,
    simpa only [← hr] using nat.lt_succ_self _ };
  try { simp only [step_over, stack.step, step, program.max_internal_cost, and_imp],
    intros _ hr,
    rw [hr],
    exact nat.lt_succ_self _ },
  { simp only [step_over, stack.step, step, program.max_internal_cost],
    intro hr,
    simp only [← hr],
    apply lt_of_le_of_lt _ (nat.lt_succ_self _),
    by_cases t_current_hd_cond t_state.getv,
    { simp only [h, if_true, le_max_right] },
    { simp only [h, if_false, le_max_left] } },
end

theorem step_over_irrefl (t: thunk α):
  ¬ step_over t t := λ h, lt_irrefl _ (step_over_decreasing h)

def external_time_cost_step (t: thunk α) (c r: ℕ): Prop :=
  match t.step with
  | (sum.inl _) := true
  | (sum.inr (sum.inl _)) := true
  | (sum.inr (sum.inr (p, m, _))) :=
      (option.map (λ p : program α, p.has_time_cost m c) p).get_or_else
        (t.function.has_time_cost m r)
  end

theorem external_time_cost_step_mono {t: thunk α} {c₀ r₀ c₁ r₁: ℕ}:
  external_time_cost_step t c₀ r₀ → c₀ ≤ c₁ → r₀ ≤ r₁ → external_time_cost_step t c₁ r₁ :=
begin
  cases hstep:t.step,
  { simp only [external_time_cost_step, hstep, imp_true_iff] },
  cases val,
  { simp only [external_time_cost_step, hstep, imp_true_iff] },
  rcases val with ⟨_ | _, _, _⟩;
  simp only [external_time_cost_step, hstep, option.map_none', option.map_some', option.get_or_else];
  intros h hc hr,
  { exact program.time_cost_mono h hr },
  { exact program.time_cost_mono h hc }
end

theorem external_time_cost_step_independent {t: thunk α} {c₀ r₀ c₁ r₁: ℕ}:
  external_time_cost_step t c₀ r₀ → external_time_cost_step t c₁ r₁ → external_time_cost_step t c₀ r₁ :=
begin
  cases hstep:t.step,
  { simp only [external_time_cost_step, hstep, imp_true_iff] },
  cases val,
  { simp only [external_time_cost_step, hstep, imp_true_iff] },
  rcases val with ⟨_ | _, _, _⟩;
  simp only [external_time_cost_step, hstep],
  { exact λ _ h, h },
  { exact λ h _, h }
end

def split_time_cost: thunk α → ℕ → ℕ → ℕ → Prop
| _ 0 _ _ := false
| t (i+1) c r := t.current = [] ∨ ∃ t' c₀ c₁ r₀ r₁, external_time_cost_step t c₀ r₀ ∧ step_over t t' ∧ split_time_cost t' i c₁ r₁ ∧ c = c₀ + c₁ ∧ r = r₀ + r₁

theorem split_cost_independent {t: thunk α} {i₀ c₀ r₀ i₁ c₁ r₁ i₂ c₂ r₂: ℕ}:
  split_time_cost t i₀ c₀ r₀ → split_time_cost t i₁ c₁ r₁ → split_time_cost t i₂ c₂ r₂ →
  split_time_cost t i₀ c₁ r₂ :=
begin
  induction i₀ generalizing t c₀ r₀ i₁ c₁ r₁ i₂ c₂ r₂,
  { exact false.rec_on _ },
  intro h₀, rcases h₀ with _|⟨t', c₀₀, c₀₁, r₀₀, r₀₁, hex₀, hstep₀, hsplit₀, hc₀, hr₀⟩, { exact λ _ _, or.inl h₀ },
  cases i₁, { exact false.rec_on _ },
  intro h₁, rcases h₁ with _|⟨t₁, c₁₀, c₁₁, r₁₀, r₁₁, hex₁, hstep₁, hsplit₁, hc₁, hr₁⟩, { exact λ _, or.inl h₁ },
  cases i₂, { exact false.rec_on _ },
  intro h₂, rcases h₂ with _|⟨t₂, c₂₀, c₂₁, r₂₀, r₂₁, hex₂, hstep₂, hsplit₂, hc₂, hr₂⟩, { exact or.inl h₂ },
  rw [step_over_unique hstep₁ hstep₀] at hsplit₁,
  rw [step_over_unique hstep₂ hstep₀] at hsplit₂,
  exact or.inr ⟨t', _, _, _, _, external_time_cost_step_independent hex₁ hex₂, hstep₀, i₀_ih hsplit₀ hsplit₁ hsplit₂, hc₁, hr₂⟩
end

theorem split_cost_mono {t: thunk α} {i c r i' c' r': ℕ}:
  split_time_cost t i c r → i ≤ i' → c ≤ c' → r ≤ r' →
  split_time_cost t i' c' r' :=
begin
  induction i generalizing t c r i' c' r',
  { exact false.rec_on _ },
  intros h hi' hc' hr',
  cases i', { exact (nat.not_succ_le_zero _) hi' },
  rcases h with _|⟨t', c₀, c₁, r₀, r₁, hex, hstep, hsplit, hc, hr⟩,
  { exact or.inl h },
  refine or.inr ⟨t', c₀, c' - c₀, r₀, r' - r₀, hex, hstep, i_ih hsplit _ _ _, _, _⟩,
  { exact nat.succ_le_succ_iff.mp hi' },
  { apply le_trans',
    apply nat.sub_le_sub_right hc',
    rw [hc, nat.add_sub_cancel_left] },
  { apply le_trans',
    apply nat.sub_le_sub_right hr',
    rw [hr, nat.add_sub_cancel_left] },
  { rw [add_comm, nat.sub_add_cancel],
    apply le_trans' hc',
    rw [hc],
    exact le_add_right (le_refl _) },
  { rw [add_comm, nat.sub_add_cancel],
    apply le_trans' hr',
    rw [hr],
    exact le_add_right (le_refl _) },
end

theorem not_split_time_cost_zero (t: thunk α) (c r: ℕ):
  ¬ split_time_cost t 0 c r := by cases t; cases t_current; exact not_false

theorem iterate_step_of_step_over {t r: thunk α}:
  t.step_over r → ∃ n, (stack.step)^[n] (stack.execution t []) = stack.execution r [] :=
begin
  cases hstep:t.step,
  { simp only [thunk.step_over, hstep],
    intro h,
    use 1,
    simp only [function.iterate_one, stack.step, hstep, h, eq_self_iff_true, and_true] },
  cases val,
  { simp only [thunk.step_over, hstep],
    trivial },
  rcases val with ⟨_, _, _⟩,
  simp only [thunk.step_over, hstep, and_imp],
  intros hres hr,
  cases hres with n hres,
  rcases stack.step_iterate_return hres _ [] with ⟨m, hm, hres⟩,
  use m + 1,
  rw [list.nil_append] at hres,
  simp only [function.iterate_succ_apply, stack.step, program.call, hstep],
  rw [hres, ← hr]
end

theorem iterate_step_of_iterate_step_over {t: thunk α} {n: ℕ} {r: thunk α}:
  step_over^~[n] t r → ∃ n', (stack.step)^[n'] (stack.execution t []) = stack.execution r [] :=
begin
  induction n generalizing t,
  { rw [rel_iterate_zero_iff],
    exact λ h, ⟨0, h ▸ rfl⟩ },
  { simp only [rel_iterate_succ_iff, exists_imp_distrib, and_imp],
    intros x h_hd h_tl,
    cases iterate_step_of_step_over h_hd with n_hd h_hd,
    cases n_ih h_tl with n_tl h_tl,
    use n_tl + n_hd,
    rw [function.iterate_add_apply, h_hd, h_tl] }
end

theorem iterate_step_of_iterate_step_over' {t: thunk α} {n: ℕ} {p: program α} {m: memory α}:
  step_over^~[n] t ⟨p, [], m⟩ → ∃ n', (stack.step)^[n'] (stack.execution t []) = stack.result m :=
begin
  intro h,
  cases iterate_step_of_iterate_step_over h with n h,
  refine ⟨n + 1, _⟩,
  rw [function.iterate_succ_apply', h],
  refl
end

theorem step_over_function {t t': thunk α}:
  step_over t t' → t.function = t'.function :=
begin
  intro h,
  cases iterate_step_of_step_over h with n h,
  exact stack.nstep_function' h,
end

theorem step_over_function' {p p' is is': program α} {m m': memory α}:
  step_over ⟨p, is, m⟩ ⟨p', is', m'⟩ → p = p' := step_over_function

theorem step_over_succ {p inp: program α} {n: ℕ} {m m': memory α}:
  step_over^~[n + 1] ⟨p, inp, m⟩ ⟨p, [], m'⟩ →
  ∃ x y, step_over ⟨p, inp, m⟩ ⟨p, x, y⟩ ∧ (step_over^~[n]) ⟨p, x, y⟩ ⟨p, [], m'⟩ :=
begin
  simp only [rel_iterate_succ_iff, exists_imp_distrib, and_imp],
  intros x hstep hnstep,
  cases x,
  have h := (step_over_function' hstep).symm,
  rw [h] at *,
  exact ⟨_, _, hstep, hnstep⟩
end

theorem exists_external_cost {t t': thunk α}:
  t.step_over t' →
  ∃ c r, t.external_time_cost_step c r :=
begin
  cases hstep:t.step,
  { refine λ _, ⟨0, 0, _⟩,
    simp only [external_time_cost_step, hstep] },
  cases val,
  { simp only [step_over, hstep, false_implies_iff] },
  rcases val with ⟨_|_, _, _⟩;
  simp only [step_over, hstep, external_time_cost_step, option.map_none', option.map_some', option.get_or_else, and_imp];
  intros h _;
  cases h with n h,
  { exact ⟨0, n, _, h⟩ },
  { exact ⟨n, 0, _, h⟩ }
end

theorem time_cost_of_external_cost {t: thunk α} {c r: ℕ} {t': thunk α}:
  t.step_over t' → t.external_time_cost_step c r →
  ∃ m ≤ (c + r), (stack.step)^[m + 1] (stack.execution t []) = stack.execution t' [] :=
begin
  cases hstep:t.step,
  { simp only [step_over, hstep],
    intros ht _,
    refine ⟨0, le_add_self, _⟩,
    simp only [function.iterate_one, stack.step, hstep, ht, eq_self_iff_true, and_true] },
  cases val,
  { simp only [step_over, hstep, false_implies_iff] },
  rcases val with ⟨_, _, _⟩,
  cases val_fst;
  { simp only [step_over, external_time_cost_step, hstep, and_imp, option.get_or_else_none, option.map_none', option.get_or_else_some, option.map_some'],
    intros hres ht hcost,
    cases hcost with m hcost,
    rcases stack.step_iterate_return' hcost val_snd_snd with ⟨r', hr', hcost'⟩,
    refine ⟨r', by linarith, _⟩,
    simp only [function.iterate_succ_apply, option.get_or_else_none, option.get_or_else_some, program.call, stack.step, hstep, hcost', eq_self_iff_true, and_true],
    rw [ht],
    exact congr_arg _ (program.unique_result ⟨_, hcost⟩ hres) },
end

theorem external_cost_of_time_cost {t: thunk α} {n: ℕ} {t': thunk α}:
  t.step_over t' →
  ((stack.step)^[n] (stack.execution t [])) = stack.execution t' [] →
  ∃ c r, c + r < n ∧ t.external_time_cost_step c r :=
begin
  induction n using nat.strong_induction_on with n ih generalizing t t',
  cases n,
  { rw [function.iterate_zero_apply, stack.execution.inj_eq, eq_self_iff_true, and_true],
    intros hso ht,
    rw [ht] at hso,
    exact absurd hso (step_over_irrefl _) },
  cases hstep:t.step,
  { exact λ _ _, ⟨0, 0, nat.zero_lt_succ _, by simp only [external_time_cost_step, hstep] ⟩ },
  cases val,
  { simp only [step_over, hstep, false_implies_iff] },
  rcases val with ⟨_ | _, _, _⟩;
  simp only [function.iterate_succ_apply, stack.step, step_over, external_time_cost_step, hstep,
    and_imp, option.get_or_else, option.map_none', option.map_some', program.call];
  intros hres ht hcost;
  rcases stack.result_of_step_iterate hcost with ⟨m, n', hn, hcost⟩,
  exact ⟨0, n', nat.lt_succ_of_le ((nat.zero_add n').symm ▸ hn), ⟨_, hcost⟩⟩,
  exact ⟨n', 0, nat.lt_succ_of_le ((nat.add_zero n').symm ▸ hn), ⟨_, hcost⟩⟩,
end

theorem iterate_step_over_of_iterate_step {t: thunk α} {n:ℕ} {t': thunk α}:
  stack.step^[n] (stack.execution t []) = stack.execution t' [] →
  ∃ n', thunk.step_over^~[n'] t t' :=
begin
  induction n using nat.strong_induction_on with n ih generalizing t t',
  cases n,
  { rw [function.iterate_zero_apply, stack.execution.inj_eq, and_imp],
    exact λ h _, ⟨0, h⟩ },
  rw [function.iterate_succ_apply],
  cases hstep:t.step,
  { simp only [stack.step, hstep],
    intro h,
    cases ih n (nat.lt_succ_self _) h with n' ih,
    use n'+1,
    rw [rel_iterate_succ_iff],
    refine ⟨_, _, ih⟩,
    simp only [thunk.step_over, hstep] },
  cases val,
  { simp [stack.step, hstep, stack.result_halt] },
  { rcases val with ⟨_, _, c'⟩,
    simp only [stack.step, hstep],
    intro h,
    rcases stack.result_of_step_iterate h with ⟨m, n₁, hn₁, h₁⟩,
    rcases stack.step_iterate_return h₁ c' [] with ⟨n₂, hn₂, h₂⟩,
    rw [list.nil_append] at h₂,
    cases nat.exists_eq_add_of_le (trans hn₂ hn₁) with x hx,
    rw [hx, nat.add_comm, function.iterate_add_apply, h₂] at h,
    cases ih _ _ h with y hy,
    { refine ⟨y + 1, _, _, hy⟩,
      cases c',
      simp only [step_over, hstep, program.has_result,
        thunk.set_result, memory.getm_setm,
        eq_self_iff_true, and_true],
      exact ⟨_, h₁⟩ },
    apply nat.lt_succ_of_le,
    rw [hx, add_comm],
    exact le_self_add },
end

theorem iterate_step_over_iff_iterate_step {t: thunk α} {m: memory α}:
  (∃ n, stack.step^[n] (stack.execution t []) = stack.result m) ↔
  (∃ n, step_over^~[n] t ⟨t.function, [], m⟩) :=
begin
  split,
  { intro h,
    cases h with n h,
    rw stack.result_nprev' at h,
    rcases h with ⟨n', hn, h⟩,
    exact iterate_step_over_of_iterate_step h },
  { intro h,
    cases h with _ h,
    exact iterate_step_of_iterate_step_over' h }
end

theorem time_cost_of_split {t: thunk α} {i c r: ℕ}:
  split_time_cost t i c r →
  ∃ m, (stack.step)^[i + c + r] (stack.execution t []) = stack.result m :=
begin
  induction i generalizing t c r,
  { exact flip absurd (not_split_time_cost_zero _ _ _) },
  simp only [nat.succ_add, split_time_cost, or_imp_distrib, exists_imp_distrib, and_imp, step_nil_iff],
  split,
  { intros _ h,
    simp only [function.iterate_succ_apply, stack.step, h, stack.result_halt, exists_eq'] },
  intros t' c₀ c₁ r₀ r₁ hex hso hcost hc hr,
  rcases time_cost_of_external_cost hso hex with ⟨n, hn, h⟩,
  rw [← @nat.sub_add_cancel (i_n + c + r) n, ← nat.add_succ, function.iterate_add_apply, h],
  { apply stack.result_mono (i_ih hcost),
    rw [show i_n + c + r = i_n + c₁ + r₁ + (c₀ + r₀), by rw [hc, hr]; ring,
      nat.add_sub_assoc hn],
    exact le_self_add },
  rw [show i_n + c + r = i_n + c₁ + r₁ + (c₀ + r₀), by rw [hc, hr]; ring],
  exact le_add_left hn,
end

theorem time_cost_of_split' {t: thunk α} {n: ℕ} {i c r: ℕ}:
  split_time_cost t i c r →
  n = i + c + r →
  ∃ m, (stack.step)^[n] (stack.execution t []) = stack.result m :=
λ h hn, hn.symm ▸ time_cost_of_split h

theorem result_or_step_over {t: thunk α} {m: memory α} {n: ℕ}:
  (stack.step)^[n] (stack.execution t []) = stack.result m →
  (stack.execution t []).step = stack.result m ∨
  ∃ t' n', thunk.step_over t t' ∧ (stack.step^[n'] (stack.execution t' [])) = stack.result m :=
begin
  intro h,
  cases iterate_step_over_iff_iterate_step.mp ⟨_, h⟩ with n₁ h₁,
  cases n₁,
  { left,
    rw [rel_iterate_zero_iff] at h₁,
    rw [h₁],
    refl },
  right,
  rw [rel_iterate_succ_iff] at h₁,
  rcases h₁ with ⟨t', ht, h₂⟩,
  cases iterate_step_of_iterate_step_over' h₂ with n₃ h₃,
  exact ⟨t', n₃, ht, h₃⟩
end

theorem result_or_external_cost {t: thunk α} {m: memory α} {n: ℕ}:
  (stack.step)^[n] (stack.execution t []) = stack.result m →
  (stack.execution t []).step = stack.result m ∨
  ∃ t' n₀ n₁ c r, external_time_cost_step t c r ∧ thunk.step_over t t' ∧ (stack.step^[n₁]) (stack.execution t' []) = stack.result m ∧ c + r < n₀ ∧ n₀ + n₁ = n :=
begin
  intro h₀,
  rcases result_or_step_over h₀ with h₁|⟨t', n₁, hso, h₁⟩,
  { exact or.inl h₁ },
  right,
  rcases exists_external_cost hso with ⟨c₀, r₀, hex₀⟩,
  rcases time_cost_of_external_cost hso hex₀ with ⟨n₂, hn₂, h₂⟩,
  rcases external_cost_of_time_cost hso h₂ with ⟨c₁, r₁, hcr, hex₁⟩,
  refine ⟨t', n₂ + 1, n - (n₂ + 1), c₁, r₁, hex₁, hso, stack.nstep_result_sub h₂ h₀, hcr, _⟩,
  rw [nat.add_comm, nat.sub_add_cancel],
  by_contradiction,
  rw [not_le] at h,
  cases nat.exists_eq_add_of_lt h with x hx,
  simpa only [hx, add_assoc n x 1, add_comm n (x + 1), function.iterate_add_apply _ (x + 1) n, h₀, stack.result_halt] using h₂
end

theorem split_cost_of_time_cost {t: thunk α} {m: memory α} {n: ℕ}:
  (stack.step)^[n] (stack.execution t []) = stack.result m →
  ∃ i c r, i + c + r ≤ n ∧ split_time_cost t i c r :=
begin
  induction n using nat.strong_induction_on with n ih generalizing t m,
  cases n,
  { simp only [function.iterate_zero_apply, false_implies_iff] },
  intro h,
  rcases result_or_external_cost h with h|⟨t', n₀, n₁, c₁, r₁, hex, hso, hs, hn₀, hn⟩,
  { refine ⟨1, 0, 0, nat.succ_le_succ (nat.zero_le _), or.inl _⟩,
    cases hstep:t.step,
    { simpa only [stack.step, hstep] using h },
    cases val,
    { simp only [step_nil_iff, hstep, exists_eq'] },
    rcases val with ⟨_|_,_,_⟩;
    { simpa only [stack.step, hstep] using h } },
  rcases ih _ _ hs with ⟨i₁, c₂, r₂, hn₁, ih⟩,
  { refine ⟨i₁ + 1, c₁ + c₂, r₁ + r₂, _, _⟩,
    { rw [← hn],
      linarith },
    exact or.inr ⟨_, _, _, _, _, hex, hso, ih, rfl, rfl⟩ },
  rw [← hn],
  exact lt_add_of_pos_left _ (pos_of_gt hn₀),
end

theorem apply_step_over {t t': thunk α} {m: memory α}:
  thunk.step_over t t' →
  (∃ n, (stack.step^[n]) (stack.execution t' []) = (stack.result m)) →
  ∃ n, (stack.step^[n]) (stack.execution t []) = (stack.result m) :=
begin
  intros hso hs,
  cases iterate_step_of_step_over hso with _ h,
  cases hs with _ h',
  exact ⟨_ + _, by rw[function.iterate_add_apply, h, h'] ⟩,
end

theorem apply_step_over_call {p: program α} {s: source α} {func is: program α} {m m' r: memory α}:
  func.has_result (m.getms s) m' →
  (∃ n, (stack.step^[n]) (stack.execution ⟨p, is, m.setm 0 m'⟩ []) = stack.result r) →
  (∃ n, (stack.step^[n]) (stack.execution ⟨p, (instruction.call func s)::is, m⟩ []) = stack.result r) :=
begin
  intro h,
  apply apply_step_over,
  simp only [thunk.step_over, thunk.step, set_result,
    option.get_or_else, option.map_some',
    memory.getm_setm, memory.setm_setm, h,
    true_and, eq_self_iff_true],
end

theorem apply_step_over_recurse {p: program α} {s: source α} {is: program α} {m m' r: memory α}:
  p.has_result (m.getms s) m' →
  (∃ n, (stack.step^[n]) (stack.execution ⟨p, is, m.setm 0 m'⟩ []) = stack.result r) →
  (∃ n, (stack.step^[n]) (stack.execution ⟨p, (instruction.recurse s)::is, m⟩ []) = stack.result r) :=
begin
  intro h,
  apply apply_step_over,
  simp only [thunk.step_over, thunk.step, set_result,
    option.get_or_else, option.map_none',
    memory.getm_setm, memory.setm_setm, h,
    true_and, eq_self_iff_true],
end

theorem apply_step_over' {p is₀ is₁ is₂: program α} {m₀ m₁ m₂: memory α}:
  is₀ = is₁ →
  thunk.step_over ⟨p, is₁, m₀⟩ ⟨p, is₂, m₁⟩ →
  (∃ n, (stack.step^[n]) (stack.execution ⟨p, is₂, m₁⟩ []) = (stack.result m₂)) →
  ∃ n, (stack.step^[n]) (stack.execution ⟨p, is₀, m₀⟩ []) = (stack.result m₂) :=
λ his, his ▸ apply_step_over
end thunk

namespace program

def internal_cost (p: program α) (inp: memory α) (i: ℕ): Prop :=
  ∃ c r, (p.call inp).split_time_cost i c r

def call_cost (p: program α) (inp: memory α) (c: ℕ): Prop :=
  ∃ i r, (p.call inp).split_time_cost i c r

def recurse_cost (p: program α) (inp: memory α) (r: ℕ): Prop :=
  ∃ i c, (p.call inp).split_time_cost i c r

theorem recurse_cost_mono {p: program α} {inp: memory α} {r r': ℕ}:
  p.recurse_cost inp r → r ≤ r' → p.recurse_cost inp r' :=
begin
  intros h hr,
  rcases h with ⟨i, c, h⟩,
  exact ⟨i, c, thunk.split_cost_mono h (le_refl _) (le_refl _) hr⟩,
end

theorem split_cost_of_components {p: program α} {inp: memory α} {i c r: ℕ}:
  internal_cost p inp i → call_cost p inp c → recurse_cost p inp r →
  (p.call inp).split_time_cost i c r :=
begin
  intros hi hc hr,
  rcases hi with ⟨_, _, hi⟩,
  rcases hc with ⟨_, _, hc⟩,
  rcases hr with ⟨_, _, hr⟩,
  exact thunk.split_cost_independent hi hc hr
end

theorem internal_cost_bound_helper_step {t: thunk α} {t': thunk α}:
  thunk.step_over t t' → t'.current.max_internal_cost < t.current.max_internal_cost :=
begin
  cases t,
  cases t_current,
  { simp only [thunk.step_over, thunk.step, false_implies_iff] },
  cases t_current_hd;
  try { simp only [thunk.step_over, thunk.step],
    intro h,
    rw [← h],
    simpa only [program.max_internal_cost] using nat.lt_succ_self _ };
  try { simp only [thunk.step_over, thunk.step, and_imp],
    intros _ h,
    rw [h],
    simpa only [program.max_internal_cost] using nat.lt_succ_self _ },
  simp only [thunk.step_over, thunk.step],
  by_cases (t_current_hd_cond t_state.getv);
  simp only [h, if_true];
  intro h;
  rw [← h],
  simpa only [program.max_internal_cost] using nat.lt_succ_of_le (le_max_right _ _),
  simpa only [program.max_internal_cost] using nat.lt_succ_of_le (le_max_left _ _)
end

theorem internal_cost_bound_helper {t: thunk α} {n: ℕ} {m: memory α}:
  thunk.step_over^~[n] t ⟨t.function, [], m⟩ → n < t.current.max_internal_cost :=
begin
  induction n generalizing t,
  {  rw [rel_iterate_zero_iff],
    intro h,
    rw [h],
    cases t,
    unfold max_internal_cost,
    exact nat.zero_lt_one },
  simp only [rel_iterate_succ_iff, exists_imp_distrib, and_imp],
  intros t' hd tl,
  rw [thunk.step_over_function hd] at tl,
  exact nat.succ_le_of_lt (nat.lt_of_le_of_lt (n_ih tl) (internal_cost_bound_helper_step hd))
end

theorem internal_cost_bound_helper' {p: program α} {n: ℕ} {m m': memory α}:
  thunk.step_over^~[n] (p.call m) ⟨p, [], m'⟩ → n < p.max_internal_cost :=
internal_cost_bound_helper

theorem internal_cost_of_step_over_helper {t: thunk α} {n: ℕ} {m: memory α}:
  (thunk.step_over^~[n]) t ⟨t.function, [], m⟩ → ∃ c r, t.split_time_cost (n + 1) c r :=
begin
  induction n generalizing t,
  { rw [rel_iterate_zero_iff],
    exact λ h, ⟨0, 0, h.symm ▸ or.inl rfl⟩ },
  simp only [rel_iterate_succ_iff, exists_imp_distrib, and_imp],
  intros t' hd tl,
  rcases thunk.exists_external_cost hd with ⟨c₀, r₀, hex⟩,
  rw [thunk.step_over_function hd] at tl,
  rcases n_ih tl with ⟨c₁, r₁, ih⟩,
  exact ⟨_, _, or.inr ⟨_, _, _, _, _, hex, hd, ih, rfl, rfl⟩⟩,
end

theorem internal_cost_of_step_over_helper' {t: thunk α} {i c r: ℕ}:
  t.split_time_cost i c r → ∃ (n < i) m, (thunk.step_over^~[n]) t ⟨t.function, [], m⟩:=
begin
  induction i generalizing t c r,
  { exact flip absurd (thunk.not_split_time_cost_zero _ _ _) },
  intro h,
  cases h,
  { cases t,
    refine ⟨_, nat.zero_lt_succ _, t_state, _⟩,
    rw [rel_iterate_zero_iff, ← h] },
  rcases h with ⟨t', _, _, _, _, _, hd, hsplit, _⟩,
  rcases i_ih hsplit with ⟨n, hn, m, tl⟩,
  rw [← thunk.step_over_function hd] at tl,
  exact ⟨_, nat.succ_le_succ hn, _, ⟨_, hd, tl⟩⟩
end

theorem internal_cost_bound {p: program α} {n: ℕ} {m: memory α}:
  p.internal_cost m n → p.internal_cost m p.max_internal_cost :=
begin
  intro h,
  rcases h with ⟨c, r, h⟩,
  rcases internal_cost_of_step_over_helper' h with ⟨_, _, _, h⟩,
  rw [program.call_function] at h,
  rcases internal_cost_of_step_over_helper h with ⟨c, r, h'⟩,
  exact ⟨c, r, thunk.split_cost_mono h' (nat.succ_le_of_lt ( internal_cost_bound_helper' h)) (le_refl _) (le_refl _)⟩
end

def recurse_arg (p: program α) (inp arg: memory α): Prop :=
  ∃ n t t', (thunk.step_over^~[n] (p.call inp) t) ∧ t.step = sum.inr (sum.inr (option.none, arg, t'))

def max_recurse_count: program α → ℕ
| ((instruction.recurse _)::is) := max_recurse_count is + 1
| ((@instruction.ite _ _ _ is')::is) := max (max_recurse_count is) (max_recurse_count is')
| (i::is) := max_recurse_count is
| [] := 0

theorem max_recurse_count_step_inl {t t': thunk α}:
  t.step = sum.inl t' →  t'.current.max_recurse_count ≤ t.current.max_recurse_count :=
begin
  rcases t with ⟨p, is, inp⟩,
  cases is,
  { simp only [thunk.step, false_implies_iff] },
  cases is_hd;
  try { { simp only [thunk.step],
    intro h,
    simp only [← h, max_recurse_count] } };
  try { { simp only [thunk.step, false_implies_iff] } },
  simp only [thunk.step],
  by_cases is_hd_cond inp.getv;
  { simp only [h, if_true, if_false],
    intro ht,
    simp only [← ht, max_recurse_count, le_max_right, le_max_left] }
end

theorem max_recurse_count_step_inr_inr_none {t: thunk α} {m: memory α} {t': thunk α}:
  t.step = sum.inr (sum.inr (none, m, t')) →  t.current.max_recurse_count = t'.current.max_recurse_count + 1 :=
begin
  rcases t with ⟨p, is, inp⟩,
  cases is,
  { simp only [thunk.step, false_implies_iff] },
  cases is_hd;
  try { { simp only [thunk.step, prod.mk.inj_iff, false_and, false_implies_iff] } },
  simp only [thunk.step, prod.mk.inj_iff, max_recurse_count, and_imp],
  intros _ _ h,
  rw [← h]
end

theorem max_recurse_count_step_inr_inr_some {t: thunk α} {p: program α} {m: memory α} {t': thunk α}:
  t.step = sum.inr (sum.inr (some p, m, t')) →  t.current.max_recurse_count = t'.current.max_recurse_count :=
begin
  rcases t with ⟨p, is, inp⟩,
  cases is,
  { simp only [thunk.step, false_implies_iff] },
  cases is_hd;
  try { { simp only [thunk.step, prod.mk.inj_iff, false_and, false_implies_iff] } },
  simp only [thunk.step, prod.mk.inj_iff, max_recurse_count, and_imp],
  intros _ _ h,
  rw [← h]
end

theorem max_recurse_helper_zero {t: thunk α} {i c r: ℕ}:
  thunk.split_time_cost t i c r →
  max_recurse_count t.current = 0 →
  thunk.split_time_cost t i c 0 :=
begin
  induction i generalizing t c r,
  { exact flip absurd (thunk.not_split_time_cost_zero _ _ _) },
  intros h hrec,
  cases h,
  { exact or.inl h },
  rcases h with ⟨t', c₀, c₁, r₀, r₁, hex, hso, hsplit, hc, hr⟩,
  refine or.inr ⟨t', c₀, c₁, 0, 0, _, hso, i_ih hsplit _, hc, (nat.add_zero _).symm⟩,
  { cases hstep:t.step,
    { simp only [thunk.external_time_cost_step, hstep] },
    cases val,
    { simpa only [thunk.step_over, hstep] using hso },
    rcases val with ⟨_|_,_,_⟩,
    { simpa only [max_recurse_count_step_inr_inr_none hstep, nat.succ_ne_zero] using hrec },
    { simpa only [thunk.external_time_cost_step, hstep] using hex } },
  { cases hstep:t.step,
    { apply nat.eq_zero_of_le_zero,
      rw [← hrec],
      apply max_recurse_count_step_inl,
      simpa only [sum.inl.inj_eq, thunk.step_over, hstep] using hso },
    cases val,
    { simpa only [thunk.step_over, hstep] using hso },
    rcases val with ⟨_|_,_,_⟩,
    { simpa only [max_recurse_count_step_inr_inr_none hstep, nat.succ_ne_zero] using hrec },
    rw [← hrec, max_recurse_count_step_inr_inr_some hstep],
    simp only [thunk.step_over, option.get_or_else, hstep] at hso,
    apply congr_arg,
    apply (thunk.set_result_current hso.right.symm).symm,
  }
end

theorem max_recurse_helper_zero' {t: thunk α} {i c r: ℕ}:
  thunk.split_time_cost t i c r →
  (∀ n t₁, thunk.step_over^~[n] t t₁ → ∀ m t₂, t₁.step ≠ sum.inr (sum.inr (none, m, t₂)))  →
  thunk.split_time_cost t i c 0 :=
begin
  induction i generalizing t c r,
  { exact flip absurd (thunk.not_split_time_cost_zero _ _ _) },
  intros h hrec,
  cases h,
  { exact or.inl h },
  rcases h with ⟨t', c₀, c₁, r₀, r₁, hex, hso, hsplit, hc, hr⟩,
  refine or.inr ⟨t', c₀, c₁, 0, 0, _, hso, i_ih hsplit _, hc, (nat.add_zero _).symm⟩,
  { cases hstep:t.step,
    { simp only [thunk.external_time_cost_step, hstep] },
    cases val,
    { simpa only [thunk.step_over, hstep] using hso },
    rcases val with ⟨_|_,_,_⟩,
    { exact absurd hstep (hrec _ _ (rel_iterate_zero _ _) _ _) },
    { simpa only [thunk.external_time_cost_step, hstep] using hex } },
  { intros n t₁ ht m t₂ hstep,
    apply hrec (n+1) t₁ _ _ _ hstep,
    { rw [rel_iterate_succ_iff],
      exact ⟨_, hso, ht⟩ } }
end

theorem max_recurse_helper {t: thunk α} {i c r n: ℕ}:
  thunk.split_time_cost t i c r →
  (∀ arg, (∃ n t' t'', (thunk.step_over^~[n]) t t' ∧ t'.step = sum.inr (sum.inr (option.none, arg, t''))) → t.function.has_time_cost arg n) →
  thunk.split_time_cost t i c (max_recurse_count t.current * n) :=
begin
  induction i generalizing t c r,
  { simp only [thunk.split_time_cost, false_implies_iff] },
  intros h hrec,
  cases h,
  { exact or.inl h },
  rcases h with ⟨t', c₀, c₁, r₀, r₁, hex, hso, hsplit, hc, hr⟩,
  cases hstep:t.step,
  { apply thunk.split_cost_mono _ (le_refl _) (le_refl _) (nat.mul_le_mul_right _ (max_recurse_count_step_inl hstep)),
    refine or.inr ⟨t', c₀, c₁, 0, _, _, hso, i_ih hsplit _, hc, _⟩,
    { simp only [thunk.external_time_cost_step, hstep] },
    { simp only [exists_imp_distrib, and_imp],
      exact λ arg n x _ hx hxstep, (thunk.step_over_function hso) ▸ hrec _ ⟨n+1, _, _, ⟨t', hso, hx⟩, hxstep⟩ },
      simp only [thunk.step_over, hstep] at hso,
      simp only [hso, nat.zero_add] },
  cases val,
  { exact or.inl (thunk.step_return_nil hstep) },
  rcases val with ⟨_|_, _, _⟩,
  { refine or.inr ⟨t', c₀, c₁, n, max_recurse_count t'.current * n, _, hso, i_ih hsplit _, hc, _⟩,
    { simp only [thunk.external_time_cost_step, hstep, option.map_none', option.get_or_else_none],
      exact hrec _ ⟨0, _, _, rel_iterate_zero _ _, hstep⟩ },
    { simp only [exists_imp_distrib, and_imp],
      exact λ arg n x _ hx hxstep, (thunk.step_over_function hso) ▸ hrec _ ⟨n+1, _, _, ⟨t', hso, hx⟩, hxstep⟩ },
    simp only [thunk.step_over, hstep] at hso,
    rw [max_recurse_count_step_inr_inr_none hstep, thunk.set_result_current hso.right.symm],
    ring },
  { refine or.inr ⟨t', c₀, c₁, 0, _, _, hso, i_ih hsplit _, hc, _⟩,
    { simpa only [thunk.external_time_cost_step, hstep, option.map_some', option.get_or_else] using hex },
    { simp only [exists_imp_distrib, and_imp],
      exact λ arg n x _ hx hxstep, (thunk.step_over_function hso) ▸ hrec _ ⟨n+1, _, _, ⟨t', hso, hx⟩, hxstep⟩ },
    simp only [thunk.step_over, hstep] at hso,
    rw [max_recurse_count_step_inr_inr_some hstep, thunk.set_result_current hso.right.symm],
    exact (nat.zero_add _).symm }
end

theorem max_recurse_cost {p: program α} {inp: memory α} {n: ℕ}:
  p.halts_on inp → (∀ arg, p.recurse_arg inp arg → p.has_time_cost arg n) → recurse_cost p inp (max_recurse_count p * n) :=
begin
  intros halt hrec,
  rcases halt with ⟨n, m, h⟩,
  rcases thunk.split_cost_of_time_cost h with ⟨i, c, r, hn, h⟩,
  exact ⟨i, c, max_recurse_helper h hrec⟩,
end

theorem max_recurse_cost_zero' {p: program α} {inp: memory α}:
  p.halts_on inp → (∀ arg, ¬ p.recurse_arg inp arg) → p.recurse_cost inp 0 :=
begin
  intros halt hrec,
  rcases halt with ⟨n, m, h⟩,
  rcases thunk.split_cost_of_time_cost h with ⟨i, c, r, hn, h⟩,
  refine ⟨i, c, max_recurse_helper_zero' h (λ _ _ ht _ _ hstep, hrec _ ⟨_, _, _, ht, hstep⟩)⟩,
end

theorem max_recurse_cost_zero {p: program α} {inp: memory α}:
  p.halts_on inp → p.max_recurse_count = 0 → p.recurse_cost inp 0 :=
begin
  intros halt hrec,
  rcases halt with ⟨n, m, h⟩,
  rcases thunk.split_cost_of_time_cost h with ⟨i, c, r, hn, h⟩,
  exact ⟨i, c, max_recurse_helper_zero h hrec⟩,
end

end program

end hmem


/-
Copyright (c) 2019 Bruno Bentzen. All rights reserved.
Released under the Apache License 2.0 (see "License");
Author: Bruno Bentzen
-/

import logic.function ...path.groupoid.ops

open interval

-- the meet connection

def meet.horn {A : Type} (kan : has_hcom2 A)
  (p : I →  A) : horn2 A :=
let u := horn1.mk (λ _, p i0) (λ _, p i0) p rfl rfl in
let meet' := kan.has1.hcom u in
horn2.mk (λ _ _, p i0)
(λ _ _, p i0) (λ j i, meet' i j)
(λ _ _, p i0) (λ j i, meet' i j)
rfl ((kan.has1.t0 u).symm) rfl ((kan.has1.t0 u).symm)
rfl ((kan.has1.lid u).symm) (kan.has1.lid u) rfl

def meet.filler {A : Type} (kan : has_hcom2 A)
  (p : I → A) : I → I → I → A :=
kan.hcom2 (meet.horn kan p)

def meet {A : Type} (kan : has_hcom2 A)
  (p : I → A) : I → I → A :=
(meet.filler kan p) i1

--notation p `[` j `∧` i `]` kan := meet kan p j i

namespace meet

lemma face0j {A : Type} (kan : has_hcom2 A)
  (p : I → A) : meet kan p i0 = λ _, p i0 :=
kan.eq0j (meet.horn kan p)

lemma face1j {A : Type} (kan : has_hcom2 A)
  (p : I → A) : meet kan p i1 = p :=
begin
  transitivity, apply kan.eq1j (meet.horn kan p),
  apply (kan.has1.t1 (horn1.mk (λ _, p i0) (λ _, p i0) p rfl rfl))
end

lemma face0i {A : Type} (kan : has_hcom2 A)
  (p : I → A) : (λ i, meet kan p i i0) = λ _, p i0 :=
kan.eq0i (meet.horn kan p)

lemma face0i' {A : Type} (kan : has_hcom2 A)
  (p : I → A) (i : I) : meet kan p i i0 = p i0 :=
by revert i; apply function.funext_iff.1; apply face0i

lemma face1i {A : Type} (kan : has_hcom2 A)
  (p : I → A) : (λ j, meet kan p j i1) = p :=
begin
  transitivity, apply kan.eq1i (meet.horn kan p),
  apply (kan.has1.t1 (horn1.mk (λ _, p i0) (λ _, p i0) p rfl rfl))
end

lemma face1i' {A : Type} (kan : has_hcom2 A)
  (p : I → A) (i : I) : meet kan p i i1 = p i :=
by revert i; apply function.funext_iff.1; apply face1i

lemma face0j0i {A : Type} (kan : has_hcom2 A)
  (p : I → A) : meet kan p i0 i0 = ( λ _, p i0) i0 :=
by apply function.funext_iff.1; apply face0j

lemma face0j1i {A : Type} (kan : has_hcom2 A)
  (p : I → A) : meet kan p i0 i1 = ( λ _, p i0) i1 :=
by apply function.funext_iff.1; apply face0j

lemma face1j0i {A : Type} (kan : has_hcom2 A)
  (p : I → A) : meet kan p i1 i0 = p i0 :=
by rw face1j

lemma face1j1i {A : Type} (kan : has_hcom2 A)
  (p : I → A) : meet kan p i1 i1 = p i1 :=
by rw face1j

end meet

/-                λ _, p i1                      --> i
         p i1 ================== p i0         j |
          ||                     |              v
          ||                     |
          ||                     |
λ _, p i1 ||      meet p j i     | p
          ||                     |
          ||                     |
          ||                     v
         p i1 -----------------> p i1
                     p
-/

namespace refl

open path

lemma meet {A : Type} {a b : A} (kan : has_hcom2 A) (p : path A a b) :
  path.refl a = abs (meet kan (app p) i0)
                (eq.trans (meet.face0j0i kan (app p)) (app0 p))
                (eq.trans (meet.face0j1i kan (app p)) (app0 p)) :=
begin
  apply eq,
  transitivity,
  apply meet.face0j kan (app p),
  apply funext, intro, apply path.app0
end

end refl


/-
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

Measurable spaces -- σ-algberas
-/
import data.set.disjointed data.finset order.galois_connection data.set.countable
open set lattice encodable
local attribute [instance] classical.prop_decidable

universes u v w x
variables {α : Type u} {β : Type v} {γ : Type w} {ι : Sort x}
  {s t u : set α}

structure measurable_space (α : Type u) :=
(is_measurable : set α → Prop)
(is_measurable_empty : is_measurable ∅)
(is_measurable_compl : ∀s, is_measurable s → is_measurable (- s))
(is_measurable_Union : ∀f:ℕ → set α, (∀i, is_measurable (f i)) → is_measurable (⋃i, f i))

attribute [class] measurable_space

section
variable [measurable_space α]

/-- `is_measurable s` means that `s` is measurable (in the ambient measure space on `α`) -/
def is_measurable : set α → Prop := ‹measurable_space α›.is_measurable

lemma is_measurable.empty : is_measurable (∅ : set α) :=
‹measurable_space α›.is_measurable_empty

lemma is_measurable.compl : is_measurable s → is_measurable (-s) :=
‹measurable_space α›.is_measurable_compl s

lemma is_measurable.compl_iff : is_measurable (-s) ↔ is_measurable s :=
⟨λ h, by simpa using h.compl, is_measurable.compl⟩

lemma is_measurable_univ : is_measurable (univ : set α) :=
by simpa using (@is_measurable.empty α _).compl

lemma encodable.Union_decode2 {α} [encodable β] (f : β → set α) :
  (⋃ b, f b) = ⋃ (i : ℕ) (b ∈ decode2 β i), f b :=
ext $ by simp [mem_decode2, exists_swap]

@[elab_as_eliminator] lemma encodable.Union_decode2_cases
  {α} [encodable β] {f : β → set α} {C : set α → Prop}
  (H0 : C ∅) (H1 : ∀ b, C (f b)) {n} :
  C (⋃ b ∈ decode2 β n, f b) :=
match decode2 β n with
| none := by simp; apply H0
| (some b) := by convert H1 b; simp [ext_iff]
end

lemma is_measurable.Union [encodable β] {f : β → set α} (h : ∀b, is_measurable (f b)) :
  is_measurable (⋃b, f b) :=
by rw encodable.Union_decode2; exact
‹measurable_space α›.is_measurable_Union
  (λ n, ⋃ b ∈ decode2 β n, f b)
  (λ n, encodable.Union_decode2_cases is_measurable.empty h)

lemma is_measurable.bUnion {f : β → set α} {s : set β} (hs : countable s)
  (h : ∀b∈s, is_measurable (f b)) : is_measurable (⋃b∈s, f b) :=
begin
  rw bUnion_eq_Union,
  haveI := hs.to_encodable,
  exact is_measurable.Union (by simpa using h)
end

lemma is_measurable.sUnion {s : set (set α)} (hs : countable s) (h : ∀t∈s, is_measurable t) :
  is_measurable (⋃₀ s) :=
by rw sUnion_eq_bUnion; exact is_measurable.bUnion hs h

lemma is_measurable.Inter [encodable β] {f : β → set α} (h : ∀b, is_measurable (f b)) :
  is_measurable (⋂b, f b) :=
is_measurable.compl_iff.1 $
by rw compl_Inter; exact is_measurable.Union (λ b, (h b).compl)

lemma is_measurable.bInter {f : β → set α} {s : set β} (hs : countable s)
  (h : ∀b∈s, is_measurable (f b)) : is_measurable (⋂b∈s, f b) :=
is_measurable.compl_iff.1 $
by rw compl_bInter; exact is_measurable.bUnion hs (λ b hb, (h b hb).compl)

lemma is_measurable.sInter {s : set (set α)} (hs : countable s) (h : ∀t∈s, is_measurable t) :
  is_measurable (⋂₀ s) :=
by rw sInter_eq_bInter; exact is_measurable.bInter hs h

lemma is_measurable.union {s₁ s₂ : set α}
  (h₁ : is_measurable s₁) (h₂ : is_measurable s₂) : is_measurable (s₁ ∪ s₂) :=
by rw union_eq_Union; exact
is_measurable.Union (bool.forall_bool.2 ⟨h₂, h₁⟩)

lemma is_measurable.inter {s₁ s₂ : set α}
  (h₁ : is_measurable s₁) (h₂ : is_measurable s₂) : is_measurable (s₁ ∩ s₂) :=
by rw inter_eq_compl_compl_union_compl; exact
(h₁.compl.union h₂.compl).compl

lemma is_measurable.diff {s₁ s₂ : set α}
  (h₁ : is_measurable s₁) (h₂ : is_measurable s₂) : is_measurable (s₁ \ s₂) :=
h₁.inter h₂.compl

lemma is_measurable.sub {s₁ s₂ : set α} :
  is_measurable s₁ → is_measurable s₂ → is_measurable (s₁ - s₂) :=
is_measurable.diff

lemma is_measurable.disjointed {f : ℕ → set α} (h : ∀i, is_measurable (f i)) (n) :
  is_measurable (disjointed f n) :=
disjointed_induct (h n) (assume t i ht, is_measurable.diff ht $ h _)

end

@[extensionality] lemma measurable_space.ext :
  ∀{m₁ m₂ : measurable_space α}, (∀s:set α, m₁.is_measurable s ↔ m₂.is_measurable s) → m₁ = m₂
| ⟨s₁, _, _, _⟩ ⟨s₂, _, _, _⟩ h :=
  have s₁ = s₂, from funext $ assume x, propext $ h x,
  by subst this

namespace measurable_space

section complete_lattice

instance : partial_order (measurable_space α) :=
{ le          := λm₁ m₂, m₁.is_measurable ≤ m₂.is_measurable,
  le_refl     := assume a b, le_refl _,
  le_trans    := assume a b c, le_trans,
  le_antisymm := assume a b h₁ h₂, measurable_space.ext $ assume s, ⟨h₁ s, h₂ s⟩ }

/-- The smallest σ-algebra containing a collection `s` of basic sets -/
inductive generate_measurable (s : set (set α)) : set α → Prop
| basic : ∀u∈s, generate_measurable u
| empty : generate_measurable ∅
| compl : ∀s, generate_measurable s → generate_measurable (-s)
| union : ∀f:ℕ → set α, (∀n, generate_measurable (f n)) → generate_measurable (⋃i, f i)

/-- Construct the smallest measure space containing a collection of basic sets -/
def generate_from (s : set (set α)) : measurable_space α :=
{ is_measurable       := generate_measurable s,
  is_measurable_empty := generate_measurable.empty s,
  is_measurable_compl := generate_measurable.compl,
  is_measurable_Union := generate_measurable.union }

lemma is_measurable_generate_from {s : set (set α)} {t : set α} (ht : t ∈ s) :
  (generate_from s).is_measurable t :=
generate_measurable.basic t ht

lemma generate_from_le {s : set (set α)} {m : measurable_space α} (h : ∀t∈s, m.is_measurable t) :
  generate_from s ≤ m :=
assume t (ht : generate_measurable s t), ht.rec_on h
  (is_measurable_empty m)
  (assume s _ hs, is_measurable_compl m s hs)
  (assume f _ hf, is_measurable_Union m f hf)

lemma generate_from_le_iff {s : set (set α)} {m : measurable_space α} :
  generate_from s ≤ m ↔ s ⊆ {t | m.is_measurable t} :=
iff.intro
  (assume h u hu, h _ $ is_measurable_generate_from hu)
  (assume h, generate_from_le h)

protected def mk_of_closure (g : set (set α)) (hg : {t | (generate_from g).is_measurable t} = g) :
  measurable_space α :=
{ is_measurable := λs, s ∈ g,
  is_measurable_empty := hg ▸ is_measurable_empty _,
  is_measurable_compl := hg ▸ is_measurable_compl _,
  is_measurable_Union := hg ▸ is_measurable_Union _ }

lemma mk_of_closure_sets {s : set (set α)}
  {hs : {t | (generate_from s).is_measurable t} = s} :
  measurable_space.mk_of_closure s hs = generate_from s :=
measurable_space.ext $ assume t, show t ∈ s ↔ _, by rw [← hs] {occs := occurrences.pos [1] }; refl

def gi_generate_from : galois_insertion (@generate_from α) (λm, {t | @is_measurable α m t}) :=
{ gc        := assume s m, generate_from_le_iff,
  le_l_u    := assume m s, is_measurable_generate_from,
  choice    :=
    λg hg, measurable_space.mk_of_closure g $ le_antisymm hg $ generate_from_le_iff.1 $ le_refl _,
  choice_eq := assume g hg, mk_of_closure_sets }

instance : complete_lattice (measurable_space α) :=
gi_generate_from.lift_complete_lattice

instance : inhabited (measurable_space α) := ⟨⊤⟩

lemma is_measurable_bot_iff {s : set α} : @is_measurable α ⊥ s ↔ (s = ∅ ∨ s = univ) :=
let b : measurable_space α :=
{ is_measurable       := λs, s = ∅ ∨ s = univ,
  is_measurable_empty := or.inl rfl,
  is_measurable_compl := by simp [or_imp_distrib] {contextual := tt},
  is_measurable_Union := assume f hf, classical.by_cases
    (assume h : ∃i, f i = univ,
      let ⟨i, hi⟩ := h in
      or.inr $ eq_univ_of_univ_subset $ hi ▸ le_supr f i)
    (assume h : ¬ ∃i, f i = univ,
      or.inl $ eq_empty_of_subset_empty $ Union_subset $ assume i,
        (hf i).elim (by simp {contextual := tt}) (assume hi, false.elim $ h ⟨i, hi⟩)) } in
have b = ⊥, from bot_unique $ assume s hs,
  hs.elim (assume s, s.symm ▸ @is_measurable_empty _ ⊥) (assume s, s.symm ▸ @is_measurable_univ _ ⊥),
this ▸ iff.refl _

@[simp] theorem is_measurable_top {s : set α} : @is_measurable _ ⊤ s := trivial

@[simp] theorem is_measurable_inf {m₁ m₂ : measurable_space α} {s : set α} :
  @is_measurable _ (m₁ ⊓ m₂) s ↔ @is_measurable _ m₁ s ∧ @is_measurable _ m₂ s :=
iff.rfl

@[simp] theorem is_measurable_Inf {ms : set (measurable_space α)} {s : set α} :
  @is_measurable _ (Inf ms) s ↔ ∀ m ∈ ms, @is_measurable _ m s :=
show s ∈ (⋂m∈ms, {t | @is_measurable _ m t }) ↔ _, by simp

@[simp] theorem is_measurable_infi {ι} {m : ι → measurable_space α} {s : set α} :
  @is_measurable _ (infi m) s ↔ ∀ i, @is_measurable _ (m i) s :=
show s ∈ (λm, {s | @is_measurable _ m s }) (infi m) ↔ _, by rw (@gi_generate_from α).gc.u_infi; simp; refl

end complete_lattice

section functors
variables {m m₁ m₂ : measurable_space α} {m' : measurable_space β} {f : α → β} {g : β → α}

/-- The forward image of a measure space under a function. `map f m` contains the sets `s : set β`
  whose preimage under `f` is measurable. -/
protected def map (f : α → β) (m : measurable_space α) : measurable_space β :=
{ is_measurable       := λs, m.is_measurable $ f ⁻¹' s,
  is_measurable_empty := m.is_measurable_empty,
  is_measurable_compl := assume s hs, m.is_measurable_compl _ hs,
  is_measurable_Union := assume f hf, by rw [preimage_Union]; exact m.is_measurable_Union _ hf }

@[simp] lemma map_id : m.map id = m :=
measurable_space.ext $ assume s, iff.rfl

@[simp] lemma map_comp {f : α → β} {g : β → γ} : (m.map f).map g = m.map (g ∘ f) :=
measurable_space.ext $ assume s, iff.rfl

/-- The reverse image of a measure space under a function. `comap f m` contains the sets `s : set α`
  such that `s` is the `f`-preimage of a measurable set in `β`. -/
protected def comap (f : α → β) (m : measurable_space β) : measurable_space α :=
{ is_measurable       := λs, ∃s', m.is_measurable s' ∧ f ⁻¹' s' = s,
  is_measurable_empty := ⟨∅, m.is_measurable_empty, rfl⟩,
  is_measurable_compl := assume s ⟨s', h₁, h₂⟩, ⟨-s', m.is_measurable_compl _ h₁, h₂ ▸ rfl⟩,
  is_measurable_Union := assume s hs,
    let ⟨s', hs'⟩ := classical.axiom_of_choice hs in
    ⟨⋃i, s' i, m.is_measurable_Union _ (λi, (hs' i).left), by simp [hs'] ⟩ }

@[simp] lemma comap_id : m.comap id = m :=
measurable_space.ext $ assume s, ⟨assume ⟨s', hs', h⟩, h ▸ hs', assume h, ⟨s, h, rfl⟩⟩

@[simp] lemma comap_comp {f : β → α} {g : γ → β} : (m.comap f).comap g = m.comap (f ∘ g) :=
measurable_space.ext $ assume s,
  ⟨assume ⟨t, ⟨u, h, hu⟩, ht⟩, ⟨u, h, ht ▸ hu ▸ rfl⟩, assume ⟨t, h, ht⟩, ⟨f ⁻¹' t, ⟨_, h, rfl⟩, ht⟩⟩

lemma comap_le_iff_le_map {f : α → β} : m'.comap f ≤ m ↔ m' ≤ m.map f :=
⟨assume h s hs, h _ ⟨_, hs, rfl⟩, assume h s ⟨t, ht, heq⟩, heq ▸ h _ ht⟩

lemma gc_comap_map (f : α → β) :
  galois_connection (measurable_space.comap f) (measurable_space.map f) :=
assume f g, comap_le_iff_le_map

lemma map_mono (h : m₁ ≤ m₂) : m₁.map f ≤ m₂.map f := (gc_comap_map f).monotone_u h
lemma monotone_map : monotone (measurable_space.map f) := assume a b h, map_mono h
lemma comap_mono (h : m₁ ≤ m₂) : m₁.comap g ≤ m₂.comap g := (gc_comap_map g).monotone_l h
lemma monotone_comap : monotone (measurable_space.comap g) := assume a b h, comap_mono h

@[simp] lemma comap_bot : (⊥:measurable_space α).comap g = ⊥ := (gc_comap_map g).l_bot
@[simp] lemma comap_sup : (m₁ ⊔ m₂).comap g = m₁.comap g ⊔ m₂.comap g := (gc_comap_map g).l_sup
@[simp] lemma comap_supr {m : ι → measurable_space α} :(⨆i, m i).comap g = (⨆i, (m i).comap g) :=
(gc_comap_map g).l_supr

@[simp] lemma map_top : (⊤:measurable_space α).map f = ⊤ := (gc_comap_map f).u_top
@[simp] lemma map_inf : (m₁ ⊓ m₂).map f = m₁.map f ⊓ m₂.map f := (gc_comap_map f).u_inf
@[simp] lemma map_infi {m : ι → measurable_space α} : (⨅i, m i).map f = (⨅i, (m i).map f) :=
(gc_comap_map f).u_infi

lemma comap_map_le : (m.map f).comap f ≤ m := (gc_comap_map f).l_u_le _
lemma le_map_comap : m ≤ (m.comap g).map g := (gc_comap_map g).le_u_l _

end functors

lemma comap_generate_from {f : α → β} {s : set (set β)} :
  (generate_from s).comap f = generate_from (preimage f '' s) :=
le_antisymm
  (assume u ⟨v, (hv : generate_measurable s v), eq⟩,
  begin
    rw [←eq], clear eq,
    induction hv,
    case generate_measurable.basic : u hu { exact (generate_measurable.basic _ $ ⟨u, hu, rfl⟩) },
    case generate_measurable.empty { simp [measurable_space.is_measurable_empty] },
    case generate_measurable.compl : u hu ih {
      rw [preimage_compl],
      exact measurable_space.is_measurable_compl _ _ ih },
    case generate_measurable.union : u hu ih {
      rw [preimage_Union],
      exact measurable_space.is_measurable_Union _ _ ih }
  end)
  (generate_from_le $ assume t ⟨u, hu, eq⟩, eq ▸ ⟨u, generate_measurable.basic _ hu, rfl⟩)

lemma generate_from_le_generate_from {s t : set (set α)} (h : s ⊆ t) :
  generate_from s ≤ generate_from t :=
gi_generate_from.gc.monotone_l h

lemma generate_from_sup_generate_from {s t : set (set α)} :
  generate_from s ⊔ generate_from t = generate_from (s ∪ t) :=
(@gi_generate_from α).gc.l_sup.symm

end measurable_space

section measurable_functions
open measurable_space

/-- A function `f` between measurable spaces is measurable if the preimage of every
  measurable set is measurable. -/
def measurable [m₁ : measurable_space α] [m₂ : measurable_space β] (f : α → β) : Prop :=
m₂ ≤ m₁.map f

lemma measurable_id [measurable_space α] : measurable (@id α) := le_refl _

lemma measurable.preimage [measurable_space α] [measurable_space β]
  {f : α → β} (hf : measurable f) {s : set β} : is_measurable s → is_measurable (f ⁻¹' s) := hf _

lemma measurable.comp [measurable_space α] [measurable_space β] [measurable_space γ]
  {f : α → β} {g : β → γ} (hf : measurable f) (hg : measurable g) : measurable (g ∘ f) :=
le_trans hg $ map_mono hf

lemma measurable_generate_from [measurable_space α] {s : set (set β)} {f : α → β}
  (h : ∀t∈s, is_measurable (f ⁻¹' t)) : @measurable _ _ _ (generate_from s) f :=
generate_from_le h

lemma measurable.if [measurable_space α] [measurable_space β]
  {p : α → Prop} [decidable_pred p] {f g : α → β}
  (hp : is_measurable {a | p a}) (hf : measurable f) (hg : measurable g) :
  measurable (λa, if p a then f a else g a) :=
λ s hs, show is_measurable {a | (if p a then f a else g a) ∈ s},
begin
  convert (hp.inter $ hf s hs).union (hp.compl.inter $ hg s hs),
  exact ext (λ a, by by_cases p a; simp [h, mem_def])
end

end measurable_functions

section constructions

instance : measurable_space empty := ⊤
instance : measurable_space unit := ⊤
instance : measurable_space bool := ⊤
instance : measurable_space ℕ := ⊤
instance : measurable_space ℤ := ⊤

section subtype

instance {p : α → Prop} [m : measurable_space α] : measurable_space (subtype p) :=
m.comap subtype.val

lemma measurable_subtype_val [measurable_space α] [measurable_space β] {p : β → Prop}
  {f : α → subtype p} (hf : measurable f) : measurable (λa:α, (f a).val) :=
hf.comp $ measurable_space.comap_le_iff_le_map.mp $ le_refl _

lemma measurable_subtype_mk [measurable_space α] [measurable_space β] {p : β → Prop}
  {f : α → subtype p} (hf : measurable (λa, (f a).val)) : measurable f :=
measurable_space.comap_le_iff_le_map.mpr $ by rw [measurable_space.map_comp]; exact hf

end subtype

section prod

instance [m₁ : measurable_space α] [m₂ : measurable_space β] : measurable_space (α × β) :=
m₁.comap prod.fst ⊔ m₂.comap prod.snd

lemma measurable_fst [measurable_space α] [measurable_space β] [measurable_space γ]
  {f : α → β × γ} (hf : measurable f) : measurable (λa:α, (f a).1) :=
hf.comp $ measurable_space.comap_le_iff_le_map.mp $ le_sup_left

lemma measurable_snd [measurable_space α] [measurable_space β] [measurable_space γ]
  {f : α → β × γ} (hf : measurable f) : measurable (λa:α, (f a).2) :=
hf.comp $ measurable_space.comap_le_iff_le_map.mp $ le_sup_right

lemma measurable.prod [measurable_space α] [measurable_space β] [measurable_space γ]
  {f : α → β × γ} (hf₁ : measurable (λa, (f a).1)) (hf₂ : measurable (λa, (f a).2)) :
  measurable f :=
sup_le
  (by rw [measurable_space.comap_le_iff_le_map, measurable_space.map_comp]; exact hf₁)
  (by rw [measurable_space.comap_le_iff_le_map, measurable_space.map_comp]; exact hf₂)

lemma measurable_prod_mk [measurable_space α] [measurable_space β] [measurable_space γ]
  {f : α → β} {g : α → γ} (hf : measurable f) (hg : measurable g) : measurable (λa:α, (f a, g a)) :=
measurable.prod hf hg

lemma is_measurable_set_prod [measurable_space α] [measurable_space β] {s : set α} {t : set β}
  (hs : is_measurable s) (ht : is_measurable t) : is_measurable (set.prod s t) :=
is_measurable.inter (measurable_fst measurable_id _ hs) (measurable_snd measurable_id _ ht)

end prod

instance [m₁ : measurable_space α] [m₂ : measurable_space β] : measurable_space (α ⊕ β) :=
m₁.map sum.inl ⊓ m₂.map sum.inr

instance {β : α → Type v} [m : Πa, measurable_space (β a)] : measurable_space (sigma β) :=
⨅a, (m a).map (sigma.mk a)

end constructions

namespace measurable_space

/-- Dynkin systems
The main purpose of Dynkin systems is to provide a powerful induction rule for σ-algebras generated
by intersection stable set systems.
-/
structure dynkin_system (α : Type*) :=
(has : set α → Prop)
(has_empty : has ∅)
(has_compl : ∀{a}, has a → has (-a))
(has_Union_nat : ∀{f:ℕ → set α}, pairwise (disjoint on f) → (∀i, has (f i)) → has (⋃i, f i))

theorem Union_decode2_disjoint_on
  {β} [encodable β] {f : β → set α} (hd : pairwise (disjoint on f)) :
  pairwise (disjoint on λ i, ⋃ b ∈ decode2 β i, f b) :=
begin
  rintro i j ij x ⟨h₁, h₂⟩,
  revert h₁ h₂,
  simp, intros b₁ e₁ h₁ b₂ e₂ h₂,
  refine hd _ _ _ ⟨h₁, h₂⟩,
  cases encodable.mem_decode2.1 e₁,
  cases encodable.mem_decode2.1 e₂,
  exact mt (congr_arg _) ij
end

namespace dynkin_system

@[extensionality] lemma ext :
  ∀{d₁ d₂ : dynkin_system α}, (∀s:set α, d₁.has s ↔ d₂.has s) → d₁ = d₂
| ⟨s₁, _, _, _⟩ ⟨s₂, _, _, _⟩ h :=
  have s₁ = s₂, from funext $ assume x, propext $ h x,
  by subst this

variable (d : dynkin_system α)

lemma has_compl_iff {a} : d.has (-a) ↔ d.has a :=
⟨λ h, by simpa using d.has_compl h, λ h, d.has_compl h⟩

lemma has_univ : d.has univ :=
by simpa using d.has_compl d.has_empty

theorem has_Union {β} [encodable β] {f : β → set α}
  (hd : pairwise (disjoint on f)) (h : ∀i, d.has (f i)) : d.has (⋃i, f i) :=
by rw encodable.Union_decode2; exact
d.has_Union_nat (Union_decode2_disjoint_on hd)
  (λ n, encodable.Union_decode2_cases d.has_empty h)

theorem has_union {s₁ s₂ : set α}
  (h₁ : d.has s₁) (h₂ : d.has s₂) (h : s₁ ∩ s₂ ⊆ ∅) : d.has (s₁ ∪ s₂) :=
by rw union_eq_Union; exact
d.has_Union (pairwise_disjoint_on_bool.2 h)
  (bool.forall_bool.2 ⟨h₂, h₁⟩)

lemma has_diff {s₁ s₂ : set α} (h₁ : d.has s₁) (h₂ : d.has s₂) (h : s₂ ⊆ s₁) : d.has (s₁ \ s₂) :=
d.has_compl_iff.1 begin
  simp [diff_eq, compl_inter],
  exact d.has_union (d.has_compl h₁) h₂ (λ x ⟨h₁, h₂⟩, h₁ (h h₂)),
end

instance : partial_order (dynkin_system α) :=
{ le          := λm₁ m₂, m₁.has ≤ m₂.has,
  le_refl     := assume a b, le_refl _,
  le_trans    := assume a b c, le_trans,
  le_antisymm := assume a b h₁ h₂, ext $ assume s, ⟨h₁ s, h₂ s⟩ }

def of_measurable_space (m : measurable_space α) : dynkin_system α :=
{ has       := m.is_measurable,
  has_empty := m.is_measurable_empty,
  has_compl := m.is_measurable_compl,
  has_Union_nat := assume f _ hf, m.is_measurable_Union f hf }

lemma of_measurable_space_le_of_measurable_space_iff {m₁ m₂ : measurable_space α} :
  of_measurable_space m₁ ≤ of_measurable_space m₂ ↔ m₁ ≤ m₂ :=
iff.rfl

/-- The least Dynkin system containing a collection of basic sets. -/
inductive generate_has (s : set (set α)) : set α → Prop
| basic : ∀t∈s, generate_has t
| empty : generate_has ∅
| compl : ∀{a}, generate_has a → generate_has (-a)
| Union : ∀{f:ℕ → set α}, pairwise (disjoint on f) →
    (∀i, generate_has (f i)) → generate_has (⋃i, f i)

def generate (s : set (set α)) : dynkin_system α :=
{ has := generate_has s,
  has_empty := generate_has.empty s,
  has_compl := assume a, generate_has.compl,
  has_Union_nat := assume f, generate_has.Union }

def to_measurable_space (h_inter : ∀s₁ s₂, d.has s₁ → d.has s₂ → d.has (s₁ ∩ s₂)) :=
{ measurable_space .
  is_measurable := d.has,
  is_measurable_empty := d.has_empty,
  is_measurable_compl := assume s h, d.has_compl h,
  is_measurable_Union := assume f hf,
    have ∀n, d.has (disjointed f n),
      from assume n, disjointed_induct (hf n)
        (assume t i h, h_inter _ _ h $ d.has_compl $ hf i),
    have d.has (⋃n, disjointed f n), from d.has_Union disjoint_disjointed this,
    by rwa [Union_disjointed] at this }

lemma of_measurable_space_to_measurable_space
  (h_inter : ∀s₁ s₂, d.has s₁ → d.has s₂ → d.has (s₁ ∩ s₂)) :
  of_measurable_space (d.to_measurable_space h_inter) = d :=
ext $ assume s, iff.rfl

def restrict_on {s : set α} (h : d.has s) : dynkin_system α :=
{ has       := λt, d.has (t ∩ s),
  has_empty := by simp [d.has_empty],
  has_compl := assume t hts,
    have -t ∩ s = (- (t ∩ s)) \ -s,
      from set.ext $ assume x, by by_cases x ∈ s; simp [h],
    by rw [this]; from d.has_diff (d.has_compl hts) (d.has_compl h)
      (compl_subset_compl.mpr $ inter_subset_right _ _),
  has_Union_nat := assume f hd hf,
    begin
      rw [inter_comm, inter_Union_left],
      apply d.has_Union_nat,
      { exact λ i j h x ⟨⟨_, h₁⟩, _, h₂⟩, hd i j h ⟨h₁, h₂⟩ },
      { simpa [inter_comm] using hf },
    end }

lemma generate_le {s : set (set α)} (h : ∀t∈s, d.has t) : generate s ≤ d :=
λ t ht, ht.rec_on h d.has_empty
  (assume a _ h, d.has_compl h)
  (assume f hd _ hf, d.has_Union hd hf)

lemma generate_inter {s : set (set α)}
  (hs : ∀t₁ t₂, t₁ ∈ s → t₂ ∈ s → t₁ ∩ t₂ ≠ ∅ → t₁ ∩ t₂ ∈ s) {t₁ t₂ : set α}
  (ht₁ : (generate s).has t₁) (ht₂ : (generate s).has t₂) : (generate s).has (t₁ ∩ t₂) :=
have generate s ≤ (generate s).restrict_on ht₂,
  from generate_le _ $ assume s₁ hs₁,
  have (generate s).has s₁, from generate_has.basic s₁ hs₁,
  have generate s ≤ (generate s).restrict_on this,
    from generate_le _ $ assume s₂ hs₂,
      show (generate s).has (s₂ ∩ s₁), from
        if h : s₂ ∩ s₁ = ∅ then by rw [h]; exact generate_has.empty _
        else generate_has.basic _ (hs _ _ hs₂ hs₁ h),
  have (generate s).has (t₂ ∩ s₁), from this _ ht₂,
  show (generate s).has (s₁ ∩ t₂), by rwa [inter_comm],
this _ ht₁

lemma generate_from_eq {s : set (set α)}
  (hs : ∀t₁ t₂, t₁ ∈ s → t₂ ∈ s → t₁ ∩ t₂ ≠ ∅ → t₁ ∩ t₂ ∈ s) :
generate_from s = (generate s).to_measurable_space (assume t₁ t₂, generate_inter hs) :=
le_antisymm
  (generate_from_le $ assume t ht, generate_has.basic t ht)
  (of_measurable_space_le_of_measurable_space_iff.mp $
    by rw [of_measurable_space_to_measurable_space];
    from (generate_le _ $ assume t ht, is_measurable_generate_from ht))

end dynkin_system

lemma induction_on_inter {C : set α → Prop} {s : set (set α)} {m : measurable_space α}
  (h_eq : m = generate_from s)
  (h_inter : ∀t₁ t₂, t₁ ∈ s → t₂ ∈ s → t₁ ∩ t₂ ≠ ∅ → t₁ ∩ t₂ ∈ s)
  (h_empty : C ∅) (h_basic : ∀t∈s, C t) (h_compl : ∀t, m.is_measurable t → C t → C (- t))
  (h_union : ∀f:ℕ → set α, (∀i j, i ≠ j → f i ∩ f j ⊆ ∅) →
    (∀i, m.is_measurable (f i)) → (∀i, C (f i)) → C (⋃i, f i)) :
  ∀{t}, m.is_measurable t → C t :=
have eq : m.is_measurable = dynkin_system.generate_has s,
  by rw [h_eq, dynkin_system.generate_from_eq h_inter]; refl,
assume t ht,
have dynkin_system.generate_has s t, by rwa [eq] at ht,
this.rec_on h_basic h_empty
  (assume t ht, h_compl t $ by rw [eq]; exact ht)
  (assume f hf ht, h_union f hf $ assume i, by rw [eq]; exact ht _)

end measurable_space