/-
Copyright (c) 2019 The Flypitch Project. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.

Authors: Jesse Han, Floris van Doorn
-/
import .fol .language_extension .completeness .zfc

local notation h :: t  := dvector.cons h t
local notation `[` l:(foldr `, ` (h t, dvector.cons h t) dvector.nil `]`:0) := l

/- A framework for proving things in a smaller theory by working in a conservative expansion -/

namespace fol
@[reducible, simp]def conservative {L} {T₁ : Theory L} {T₂ : Theory L} (h : T₁ ⊆ T₂) (f : sentence L) : Prop :=
  T₁ ⊢' f ↔ T₂ ⊢' f
@[reducible, simp]def model_conservative {L} {T₁ : Theory L} {T₂ : Theory L} (h : T₁ ⊆ T₂) (f : sentence L) : Prop :=
  T₁ ⊨ f ↔ T₂ ⊨ f

lemma model_conservative_iff_conservative {L} {T₁ : Theory L} {T₂ : Theory L} (h : T₁ ⊆ T₂) (f : sentence L) : model_conservative h f ↔ conservative h f :=
  by simp[completeness]

section const
/- constants are a special case of the lemmas that follow this section -/

@[reducible]def graph_relation_constant {L : Language} (c : L.constants) : bounded_formula L 1 :=
  &0 ≃ (bd_const c)

/- A 1-formula f(x) defines a constant c modulo T if T ⊢' c is the unique solution to f(x) -/
@[reducible]def defines_constant {L} {T : Theory L} (f : bounded_formula L 1) (c : L.constants) :=
T ⊢' ∀'(f ⇔ graph_relation_constant c)

lemma graph_relation_soundness_constant {L : Language} {c : L.constants} {M : Structure L} : ∀ x : M, realize_bounded_formula ([x]) (graph_relation_constant c) ([]) ↔ (x = realize_bounded_term dvector.nil (bd_const c) dvector.nil) := by intro; refl

theorem graph_relation_constant_defines_constant {L} {T : Theory L} {c : L.constants} : @defines_constant _ T (graph_relation_constant c) c :=
by {rw[graph_relation_constant,defines_constant,completeness _ _], intros M h1 h2 a, finish}

theorem defines_constant_elimination {L} {T : Theory L} {c : L.constants} {f : bounded_formula L 1} {Γ : bounded_formula L 1} {h_Γ : @defines_constant _ T Γ c} :
T ⊢' ∀'(Γ ⟹ f) ⇔ f[(bd_const c) /0] :=
begin
  unfold defines_constant at h_Γ, rw[completeness _ _] at h_Γ,
  rw[completeness _ _], intros M h_nonempty hM,
  have := h_Γ h_nonempty hM, simp only [fol.realize_sentence_biimp, fol.realize_bounded_formula, fol.realize_bounded_term, fol.realize_sentence_all, realize_subst_formula0, graph_relation_constant, fol.realize_bounded_formula_biimp] at *,
 split,
  {intro H, apply H, apply (this (realize_closed_term M (bd_const c))).mpr, refl},
  {intros H x H', convert H, exact (this x).mp H'}
end

lemma graph_relation_constant_elimination {L} {T : Theory L} {c : L.constants} {f : bounded_formula L 1} : T ⊢' ∀'(graph_relation_constant c ⟹ f) ⇔ f[(bd_const c) /0] :=
 by {apply defines_constant_elimination, exact graph_relation_constant_defines_constant}

end const

@[reducible, simp]def first_n_variables {L : Language} : ∀ n, dvector (bounded_term L n) n
| 0 := []
| (n+1) := ((first_n_variables n).map $ λ t, bounded_preterm.cast (by repeat{constructor} : n ≤ n +1) t).concat $ &(⟨n, by {repeat{constructor}}⟩: fin (n+1))

lemma first_n_variables_trunc {L : Language} : ∀ n m, (@first_n_variables L (n+m)).trunc n (by simp) = (@first_n_variables L n).map (λ t, t.cast (by simp)) := sorry

def graph_relation {n} {L : Language} (f : L.functions n) : bounded_formula L (n+1) :=
(bd_apps (bd_func f) (first_n_variables n)).cast1 ≃ bd_var (⟨n, by {repeat{constructor}}⟩)

-- lemma first_n_func_realize {n} {L : Language} {S : Structure L} (f : L.functions (n+1)) (xs : dvector S (n+1)) : realize_bounded_term xs (bd_apps (bd_func f) (first_n_variables (n+1))) dvector.nil = realize_bounded_term (xs.trunc n (by repeat{constructor})) (@bd_apps' L n 1 n ((bd_func f).cast_eq (by rw[add_comm] : n + 1 = 1 + n)) (first_n_variables n)) ([xs.last])

lemma function_semantics {n} {L : Language} {f : L.functions n} {S:Structure L} {xs : dvector S n} : realize_bounded_term xs (bd_apps (bd_func f) (first_n_variables n)) dvector.nil = S.fun_map f xs := sorry

lemma realize_first_n_variables {n : ℕ} {L : Language} {M : Structure L} {xs : dvector ↥M (n + 1)} : dvector.map (λ (t : bounded_term L n), realize_bounded_term (dvector.trunc n (by simp) xs) t dvector.nil) (first_n_variables n) = dvector.trunc n (by simp) xs :=
begin
  induction n, refl, rcases xs with ⟨x,xs⟩,
  have := @n_ih xs_xs, simp, conv {to_rhs, rw[<-this]}, sorry
end

lemma graph_relation_soundness {n} {L : Language} {f : L.functions n} {M : Structure L} {xs : dvector M (n+1)}: (M.fun_map f (xs.trunc n (by repeat{constructor})) = xs.last) ↔ (realize_bounded_formula xs (graph_relation f) dvector.nil) :=
begin
unfold graph_relation; simp only [fol.bd_apps, fol.realize_bounded_formula, fol.first_n_variables, fol.realize_bounded_term, dvector.nth, realize_bounded_term_bd_apps, bounded_preterm.cast1,realize_cast_bounded_term];
  unfold dvector.last; split; intros; rw[<-a]; rw[realize_first_n_variables]; refl
end

end fol

namespace fol
namespace Lhom

section conservativity

notation ϕ`[[`:95 T₁`]]`:90 := Lhom.Theory_induced ϕ T₁
-- notation ϕ`[[`:95 f`]]`:90 := Lhom.on_sentence ϕ f
notation ϕ`[[`:95 f`]]`:90 := Lhom.on_bounded_formula ϕ f

/-- Given an L₁-theory T₁, an L₂-theory T₂ such that h : ϕ[T₁] ⊆ ϕ[T₂], we say that that T₂ is conservative over T₁ at f if h is conservative at ϕ[f]. -/

@[reducible, simp]def conservative {L₁ L₂} (ϕ : L₁ →ᴸ L₂) (T₁ : Theory L₁) (T₂ : Theory L₂) (f : sentence L₁) (h : ϕ[[T₁]] ⊆ T₂) :=
  fol.conservative h $ ϕ[[f]]

private lemma conservative_sanity_check {L₁ L₂ : Language} (ϕ : L₁ →ᴸ L₂) (T₁ : Theory L₁) (T₂ : Theory L₂) (f : sentence L₁) (h : ϕ[[T₁]] ⊆ T₂) :
 conservative ϕ T₁ T₂ f h ↔ ((ϕ[[T₁]] ⊢' ϕ[[f]]) ↔ T₂ ⊢' ϕ[[f]]) := by refl -- phew

/- An L₂-structure M₂ is the expansion along ϕ is an L₁-structure M₁ if M₁ is equal to the ϕ-reduct of M₂. -/
@[reducible, simp]def is_expansion {L₁ L₂} (ϕ : L₁ →ᴸ L₂) (M₂ : Structure L₂) (M₁ : Structure L₁) := M₁ = M₂[[ϕ]]

theorem by_conservativity {L₁ L₂} (ϕ : L₁ →ᴸ L₂) (h_ϕ : is_injective ϕ) (M₂ : Structure L₂) (M₁ : Structure L₁)
  (h_expansion : is_expansion ϕ M₂ M₁)
  {T₁ : Theory L₁} {T₂ : Theory L₂} (f : sentence L₁) {h_M₁ : M₁ ⊨ T₁} {h_M₂ : M₂ ⊨ T₂}
  {h : ϕ[[T₁]] ⊆ T₂} :
    M₂ ⊨ ϕ[[f]] → M₁ ⊨ f :=
λ H, by {unfold is_expansion at h_expansion, rw[h_expansion], exact reduct_ssatisfied h_ϕ H}

theorem by_conservativity' {L₁ L₂} (ϕ : L₁ →ᴸ L₂) (h_ϕ : is_injective ϕ) (M₂ : Structure L₂) (M₁ : Structure L₁)
  (h_expansion : is_expansion ϕ M₂ M₁)
  (T₁ : Theory L₁) (T₂ : Theory L₂) (f : sentence L₁) (h_M₁ : M₁ ⊨ T₁) (h_M₂ : M₂ ⊨ T₂)
  (h : ϕ[[T₁]] ⊆ T₂) (f' : sentence L₂)
  (h_equiv : M₂ ⊨ ϕ[[f]] ↔ M₂ ⊨ f') :
    M₂ ⊨ f' → M₁ ⊨ f :=
λ H, by {unfold is_expansion at h_expansion, rw[h_expansion],
             apply reduct_ssatisfied h_ϕ, exact h_equiv.mpr H}

end conservativity

-- TODO use typeclasses to handle bookkeeping of hierarchy of expansions of a type?
section test
universe u

theorem by_conservativity_constant
{L₁ L₂ : Language.{u}} {c : L₂.constants} {Γ : bounded_formula L₁ 1}
{T₁ : Theory L₁} {T₂ : Theory L₂} {ϕ : L₁ →ᴸ L₂} {h_ϕ : is_injective ϕ}
{h_Γ : @defines_constant L₂ T₂ (ϕ[[Γ]]) c} {h_sub : ϕ[[T₁]] ⊆ T₂} {M₁ : Structure L₁} {H_M₁ : M₁ ⊨ T₁} {M₂ : Structure L₂} {H_M₂ : M₂ ⊨ T₂} {h_exp : is_expansion ϕ M₂ M₁} {h_nonempty_1 : nonempty M₁} {h_nonempty_2 : nonempty M₂} :

∀ f : bounded_formula L₁ 1, M₂ ⊨ (ϕ[[f]])[(bd_const c) /0] → M₁ ⊨ ∀'(Γ ⟹ f) :=

begin
  intro f, have := (completeness _ _).mp
          (@defines_constant_elimination L₂ T₂ c (ϕ[[f]]) (ϕ[[Γ]]) h_Γ) h_nonempty_2 H_M₂,
  rw[realize_sentence_biimp] at this, rw[<-this], have : ∀'(ϕ[[Γ]] ⟹ ϕ[[f]]) = (ϕ[[∀'(Γ ⟹ f)]]),
  by refl, rw[this], apply by_conservativity ϕ h_ϕ M₂ M₁ h_exp ∀'(Γ ⟹ f), repeat{assumption}
end

-- TODO instantiate this for ZFC and ZFC'

end test

end Lhom
end fol


#eval [1, 2, 3].map (·, 1)

#eval (·, ·) 1 2

#eval (., ., .) 1 2 3

theorem ex1 : [1, 2, 3].map (·, 1) = [(1, 1), (2, 1), (3, 1)] :=
  rfl

theorem ex2 : (., .) 1 2 = (1, 2) :=
  rfl


/-
Copyright (c) 2020 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Adam Topaz.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.free_algebra
import Mathlib.algebra.ring_quot
import Mathlib.algebra.triv_sq_zero_ext
import Mathlib.PostPort

universes u_1 u_2 u_3

namespace Mathlib

/-!
# Tensor Algebras

Given a commutative semiring `R`, and an `R`-module `M`, we construct the tensor algebra of `M`.
This is the free `R`-algebra generated (`R`-linearly) by the module `M`.

## Notation

1. `tensor_algebra R M` is the tensor algebra itself. It is endowed with an R-algebra structure.
2. `tensor_algebra.ι R` is the canonical R-linear map `M → tensor_algebra R M`.
3. Given a linear map `f : M → A` to an R-algebra `A`, `lift R f` is the lift of `f` to an
  `R`-algebra morphism `tensor_algebra R M → A`.

## Theorems

1. `ι_comp_lift` states that the composition `(lift R f) ∘ (ι R)` is identical to `f`.
2. `lift_unique` states that whenever an R-algebra morphism `g : tensor_algebra R M → A` is
  given whose composition with `ι R` is `f`, then one has `g = lift R f`.
3. `hom_ext` is a variant of `lift_unique` in the form of an extensionality theorem.
4. `lift_comp_ι` is a combination of `ι_comp_lift` and `lift_unique`. It states that the lift
  of the composition of an algebra morphism with `ι` is the algebra morphism itself.

## Implementation details

As noted above, the tensor algebra of `M` is constructed as the free `R`-algebra generated by `M`,
modulo the additional relations making the inclusion of `M` into an `R`-linear map.
-/

namespace tensor_algebra

/--
An inductively defined relation on `pre R M` used to force the initial algebra structure on
the associated quotient.
-/
-- force `ι` to be linear

inductive rel (R : Type u_1) [comm_semiring R] (M : Type u_2) [add_comm_monoid M] [semimodule R M] : free_algebra R M → free_algebra R M → Prop
where
| add : ∀ {a b : M}, rel R M (free_algebra.ι R (a + b)) (free_algebra.ι R a + free_algebra.ι R b)
| smul : ∀ {r : R} {a : M}, rel R M (free_algebra.ι R (r • a)) (coe_fn (algebra_map R (free_algebra R M)) r * free_algebra.ι R a)

end tensor_algebra

/--
The tensor algebra of the module `M` over the commutative semiring `R`.
-/
def tensor_algebra (R : Type u_1) [comm_semiring R] (M : Type u_2) [add_comm_monoid M] [semimodule R M] :=
  ring_quot sorry

namespace tensor_algebra

protected instance ring (M : Type u_2) [add_comm_monoid M] {S : Type u_1} [comm_ring S] [semimodule S M] : ring (tensor_algebra S M) :=
  ring_quot.ring (rel S M)

/--
The canonical linear map `M →ₗ[R] tensor_algebra R M`.
-/
def ι (R : Type u_1) [comm_semiring R] {M : Type u_2} [add_comm_monoid M] [semimodule R M] : linear_map R M (tensor_algebra R M) :=
  linear_map.mk (fun (m : M) => coe_fn (ring_quot.mk_alg_hom R (rel R M)) (free_algebra.ι R m)) sorry sorry

theorem ring_quot_mk_alg_hom_free_algebra_ι_eq_ι (R : Type u_1) [comm_semiring R] {M : Type u_2} [add_comm_monoid M] [semimodule R M] (m : M) : coe_fn (ring_quot.mk_alg_hom R (rel R M)) (free_algebra.ι R m) = coe_fn (ι R) m :=
  rfl

/--
Given a linear map `f : M → A` where `A` is an `R`-algebra, `lift R f` is the unique lift
of `f` to a morphism of `R`-algebras `tensor_algebra R M → A`.
-/
def lift (R : Type u_1) [comm_semiring R] {M : Type u_2} [add_comm_monoid M] [semimodule R M] {A : Type u_3} [semiring A] [algebra R A] : linear_map R M A ≃ alg_hom R (tensor_algebra R M) A :=
  equiv.mk
    (⇑(ring_quot.lift_alg_hom R) ∘
      fun (f : linear_map R M A) => { val := coe_fn (free_algebra.lift R) ⇑f, property := sorry })
    (fun (F : alg_hom R (tensor_algebra R M) A) => linear_map.comp (alg_hom.to_linear_map F) (ι R)) sorry sorry

@[simp] theorem ι_comp_lift {R : Type u_1} [comm_semiring R] {M : Type u_2} [add_comm_monoid M] [semimodule R M] {A : Type u_3} [semiring A] [algebra R A] (f : linear_map R M A) : linear_map.comp (alg_hom.to_linear_map (coe_fn (lift R) f)) (ι R) = f :=
  equiv.symm_apply_apply (lift R) f

@[simp] theorem lift_ι_apply {R : Type u_1} [comm_semiring R] {M : Type u_2} [add_comm_monoid M] [semimodule R M] {A : Type u_3} [semiring A] [algebra R A] (f : linear_map R M A) (x : M) : coe_fn (coe_fn (lift R) f) (coe_fn (ι R) x) = coe_fn f x :=
  id (Eq.refl (coe_fn f x))

@[simp] theorem lift_unique {R : Type u_1} [comm_semiring R] {M : Type u_2} [add_comm_monoid M] [semimodule R M] {A : Type u_3} [semiring A] [algebra R A] (f : linear_map R M A) (g : alg_hom R (tensor_algebra R M) A) : linear_map.comp (alg_hom.to_linear_map g) (ι R) = f ↔ g = coe_fn (lift R) f :=
  equiv.symm_apply_eq (lift R)

-- Marking `tensor_algebra` irreducible makes `ring` instances inaccessible on quotients.

-- https://leanprover.zulipchat.com/#narrow/stream/113488-general/topic/algebra.2Esemiring_to_ring.20breaks.20semimodule.20typeclass.20lookup/near/212580241

-- For now, we avoid this by not marking it irreducible.

@[simp] theorem lift_comp_ι {R : Type u_1} [comm_semiring R] {M : Type u_2} [add_comm_monoid M] [semimodule R M] {A : Type u_3} [semiring A] [algebra R A] (g : alg_hom R (tensor_algebra R M) A) : coe_fn (lift R) (linear_map.comp (alg_hom.to_linear_map g) (ι R)) = g := sorry

/-- See note [partially-applied ext lemmas]. -/
theorem hom_ext {R : Type u_1} [comm_semiring R] {M : Type u_2} [add_comm_monoid M] [semimodule R M] {A : Type u_3} [semiring A] [algebra R A] {f : alg_hom R (tensor_algebra R M) A} {g : alg_hom R (tensor_algebra R M) A} (w : linear_map.comp (alg_hom.to_linear_map f) (ι R) = linear_map.comp (alg_hom.to_linear_map g) (ι R)) : f = g := sorry

/-- The left-inverse of `algebra_map`. -/
def algebra_map_inv {R : Type u_1} [comm_semiring R] {M : Type u_2} [add_comm_monoid M] [semimodule R M] : alg_hom R (tensor_algebra R M) R :=
  coe_fn (lift R) 0

theorem algebra_map_left_inverse {R : Type u_1} [comm_semiring R] {M : Type u_2} [add_comm_monoid M] [semimodule R M] : function.left_inverse ⇑algebra_map_inv ⇑(algebra_map R (tensor_algebra R M)) := sorry

/-- The left-inverse of `ι`.

As an implementation detail, we implement this using `triv_sq_zero_ext` which has a suitable
algebra structure. -/
def ι_inv {R : Type u_1} [comm_semiring R] {M : Type u_2} [add_comm_monoid M] [semimodule R M] : linear_map R (tensor_algebra R M) M :=
  linear_map.comp (triv_sq_zero_ext.snd_hom R M) (alg_hom.to_linear_map (coe_fn (lift R) (triv_sq_zero_ext.inr_hom R M)))

theorem ι_left_inverse {R : Type u_1} [comm_semiring R] {M : Type u_2} [add_comm_monoid M] [semimodule R M] : function.left_inverse ⇑ι_inv ⇑(ι R) := sorry

end tensor_algebra

namespace free_algebra

/-- The canonical image of the `free_algebra` in the `tensor_algebra`, which maps
`free_algebra.ι R x` to `tensor_algebra.ι R x`. -/
def to_tensor {R : Type u_1} [comm_semiring R] {M : Type u_2} [add_comm_monoid M] [semimodule R M] : alg_hom R (free_algebra R M) (tensor_algebra R M) :=
  coe_fn (lift R) ⇑(tensor_algebra.ι R)

@[simp] theorem to_tensor_ι {R : Type u_1} [comm_semiring R] {M : Type u_2} [add_comm_monoid M] [semimodule R M] (m : M) : coe_fn to_tensor (ι R m) = coe_fn (tensor_algebra.ι R) m := sorry


import   algebra.module    data.pfun equiv

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

local attribute [instance] classical.prop_decidable

namespace equiv
section instances

variables (e : α ≃ β)

protected def has_scalar [has_scalar γ β] : has_scalar γ α := ⟨λ (a:γ)  x, e.symm ( a • e x)⟩

lemma smul_def [has_scalar γ β] (a: γ) (x : α) :
  @has_scalar.smul _ _ (equiv.has_scalar e) a x = e.symm ( a • e x) := rfl

protected def mul_action [monoid γ][mul_action γ  β] : mul_action γ  α :=
{ one_smul := by simp [smul_def, one_smul],
  mul_smul := by simp [smul_def, mul_action.mul_smul],
  ..equiv.has_scalar e  }

end instances

end equiv

def fun_one_equiv : (fin 1 → α) ≃ α :=
{ to_fun := λ x,  x 0,
  inv_fun := λ x,  (λ i:fin 1, x),
  left_inv := by {intro, simp[], ext1, apply congr_arg,
  have h:=fin.cases rfl (λ i, i.elim0),apply h},
  right_inv := by{ intro, simp[]}}

namespace pfun

protected def empty (α β : Type*) : α →. β := λx, roption.none
protected def id : α →. α := pfun.lift id
protected def comp (g : β →. γ) (f : α →. β) : α →. γ := λx, roption.bind (f x) g
infix ` ∘. `:90 := pfun.comp

def to_subtype (p : α → Prop) : α →. subtype p := λx, ⟨p x, λ h, ⟨x, h⟩⟩

def compatible (f g : α →. β) : Prop := ∀x, f x = g x

namespace compatible
  variables {f g h : α →. β}
  infix ` ~. `:50 := pfun.compatible
  protected lemma symm (h : f ~. g) : g ~. f := λx, (h x).symm
 end compatible

end pfun

structure pequiv (α : Type*) (β : Type*) :=
(to_fun    : α →. β)
(inv_fun   : β →. α)
(dom_inv_fun : ∀{{x}} (hx : x ∈ pfun.dom to_fun), to_fun.fn x hx ∈ pfun.dom inv_fun)
(dom_to_fun : ∀{{y}} (hy : y ∈ pfun.dom inv_fun), inv_fun.fn y hy ∈ pfun.dom to_fun)
(left_inv  : inv_fun ∘. to_fun ~. pfun.id)
(right_inv : to_fun ∘. inv_fun ~. pfun.id)

infixr ` ≃. `:25 := pequiv

namespace pmap

protected def has_zero [has_zero β] : has_zero (α →. β) := ⟨λ x, (0:(roption β))⟩
lemma zero_def [has_zero β] (x:α) : @has_zero.zero _ pmap.has_zero x  = (0:roption β) := rfl

protected def has_one [has_one β] : has_one (α →. β )  := ⟨λ x, (1:roption β)   ⟩
lemma one_def [has_one β] (x:α) : @has_one.one _ pmap.has_one x = (1:roption β) := rfl

protected def has_mul [has_mul β] : has_mul (α →. β ) := ⟨λ x y, λ z,  x z * y z⟩
lemma mul_def [has_mul β] (x y : α→. β) (z:α) : @has_mul.mul _ pmap.has_mul x y z=  (x z) * (y z) := rfl

protected def has_add [has_add β] : has_add(α →. β ) := ⟨λ f g, λ z,  f z + g z⟩
lemma add_def [has_add β] (x y : α→. β) (z:α) :  @has_add.add _ pmap.has_add x y z = x z +  y z := rfl

protected def has_inv [has_inv β] : has_inv (α →. β ) := ⟨λ x, λ y,  (x y )⁻¹⟩
lemma inv_def [has_inv β] (x : α →. β ) (y: α) : @has_inv.inv _ pmap.has_inv x y = (x y)⁻¹ := rfl

protected def has_neg [has_neg β] : has_neg (α →. β ) := ⟨λ x, λ y, -x y⟩
lemma neg_def [has_neg β] (x : α →. β ) (y:α) : @has_neg.neg _ pmap.has_neg x y = - x y := rfl

protected def has_scalar [has_scalar γ β] : has_scalar γ (α →. β ) := ⟨λ a x , λ y, a • x y⟩
lemma smul_def [has_scalar γ β] (a:γ) (x : α →. β ) (y:α) : @has_scalar.smul _ _ pmap.has_scalar a x y =  a • x y := rfl

protected def semigroup [semigroup β] : semigroup (α →. β) :=
{ mul_assoc := by simp [mul_def, mul_assoc],
  ..pmap.has_mul }

protected def comm_semigroup [comm_semigroup β] : comm_semigroup (α →. β )  :=
{ mul_comm := by { repeat{intro}, ext1, simp [mul_def, mul_comm]}
  ..pmap.semigroup }

protected def monoid [monoid β] : monoid (α →. β )  :=
{ monoid.
   mul := pmap.has_mul.mul,
   mul_assoc := by simp [mul_def, mul_assoc],
   one := λ x:α, some (1:β),
  one_mul := by {intro, ext1, rw[mul_def,one_def,monoid.one_mul]},
  mul_one := by {intro, ext1, rw [mul_def, pmap.one_def,monoid.mul_one]}
  }

protected def comm_monoid [comm_monoid β] : comm_monoid (α→. β) :=
{ ..pmap.comm_semigroup,
  ..pmap.monoid  }

protected def add_semigroup [add_semigroup β] : add_semigroup (α →. β ) :=
@additive.add_semigroup _ (@pmap.semigroup _ _  multiplicative.semigroup)

protected def add_comm_semigroup [add_comm_semigroup β] : add_comm_semigroup (α →. β ) :=
@additive.add_comm_semigroup _ (@pmap.comm_semigroup _ _  multiplicative.comm_semigroup)

protected def add_monoid [add_monoid β] : add_monoid (α →. β ) :=
@additive.add_monoid _ (@pmap.monoid _ _  multiplicative.monoid)

protected def add_comm_monoid [add_comm_monoid β] : add_comm_monoid (α →. β) :=
@additive.add_comm_monoid _ (@pmap.comm_monoid _ _ multiplicative.comm_monoid)

protected def mul_action [monoid γ][mul_action γ β] :mul_action γ (α →.β ):=
{ one_smul := by {repeat{intro}, simp[smul_def] },
  mul_smul := by {repeat{intro},ext1, simp[smul_def,mul_smul] },
  ..pmap.has_scalar
}

instance  add_monoid'[add_monoid β] : add_monoid (α →. β) := pmap.add_monoid

protected def distrib_mul_action [monoid γ] [add_monoid β]   [distrib_mul_action γ β] : distrib_mul_action γ (α →. β):=
{ smul_add := by {repeat{intro}, ext1,simp[smul_def,add_def,smul_add ]},
  smul_zero := by {repeat{intro}, ext1,simp only [smul_def], by library_search
 },
 ..pmap.mul_action
}

instance  add_comm_monoid'[add_comm_monoid β] : add_comm_monoid(α →. β) := pmap.add_comm_monoid

end pmap


/-
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
-/
import data.set.disjointed
import data.set.countable
import data.indicator_function
import data.equiv.encodable.lattice
import data.tprod
import order.filter.lift

/-!
# Measurable spaces and measurable functions

This file defines measurable spaces and the functions and isomorphisms
between them.

A measurable space is a set equipped with a σ-algebra, a collection of
subsets closed under complementation and countable union. A function
between measurable spaces is measurable if the preimage of each
measurable subset is measurable.

σ-algebras on a fixed set `α` form a complete lattice. Here we order
σ-algebras by writing `m₁ ≤ m₂` if every set which is `m₁`-measurable is
also `m₂`-measurable (that is, `m₁` is a subset of `m₂`). In particular, any
collection of subsets of `α` generates a smallest σ-algebra which
contains all of them. A function `f : α → β` induces a Galois connection
between the lattices of σ-algebras on `α` and `β`.

A measurable equivalence between measurable spaces is an equivalence
which respects the σ-algebras, that is, for which both directions of
the equivalence are measurable functions.

We say that a filter `f` is measurably generated if every set `s ∈ f` includes a measurable
set `t ∈ f`. This property is useful, e.g., to extract a measurable witness of `filter.eventually`.

## Notation

* We write `α ≃ᵐ β` for measurable equivalences between the measurable spaces `α` and `β`.
  This should not be confused with `≃ₘ` which is used for diffeomorphisms between manifolds.

## Implementation notes

Measurability of a function `f : α → β` between measurable spaces is
defined in terms of the Galois connection induced by f.

## References

* <https://en.wikipedia.org/wiki/Measurable_space>
* <https://en.wikipedia.org/wiki/Sigma-algebra>
* <https://en.wikipedia.org/wiki/Dynkin_system>

## Tags

measurable space, σ-algebra, measurable function, measurable equivalence, dynkin system,
π-λ theorem, π-system
-/

open set encodable function equiv
open_locale classical filter

variables {α β γ δ δ' : Type*} {ι : Sort*} {s t u : set α}

/-- A measurable space is a space equipped with a σ-algebra. -/
structure measurable_space (α : Type*) :=
(measurable_set' : set α → Prop)
(measurable_set_empty : measurable_set' ∅)
(measurable_set_compl : ∀ s, measurable_set' s → measurable_set' sᶜ)
(measurable_set_Union : ∀ f : ℕ → set α, (∀ i, measurable_set' (f i)) → measurable_set' (⋃ i, f i))

attribute [class] measurable_space

instance [h : measurable_space α] : measurable_space (order_dual α) := h

section
variable [measurable_space α]

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

@[simp] lemma measurable_set.empty : measurable_set (∅ : set α) :=
‹measurable_space α›.measurable_set_empty

lemma measurable_set.compl : measurable_set s → measurable_set sᶜ :=
‹measurable_space α›.measurable_set_compl s

lemma measurable_set.of_compl (h : measurable_set sᶜ) : measurable_set s :=
compl_compl s ▸ h.compl

@[simp] lemma measurable_set.compl_iff : measurable_set sᶜ ↔ measurable_set s :=
⟨measurable_set.of_compl, measurable_set.compl⟩

@[simp] lemma measurable_set.univ : measurable_set (univ : set α) :=
by simpa using (@measurable_set.empty α _).compl

@[nontriviality] lemma subsingleton.measurable_set [subsingleton α] {s : set α} :
  measurable_set s :=
subsingleton.set_cases measurable_set.empty measurable_set.univ s

lemma measurable_set.congr {s t : set α} (hs : measurable_set s) (h : s = t) :
  measurable_set t :=
by rwa ← h

lemma measurable_set.bUnion_decode2 [encodable β] ⦃f : β → set α⦄ (h : ∀ b, measurable_set (f b))
  (n : ℕ) : measurable_set (⋃ b ∈ decode2 β n, f b) :=
encodable.Union_decode2_cases measurable_set.empty h

lemma measurable_set.Union [encodable β] ⦃f : β → set α⦄ (h : ∀ b, measurable_set (f b)) :
  measurable_set (⋃ b, f b) :=
begin
  rw ← encodable.Union_decode2,
  exact ‹measurable_space α›.measurable_set_Union _ (measurable_set.bUnion_decode2 h)
end

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

lemma set.finite.measurable_set_bUnion {f : β → set α} {s : set β} (hs : finite s)
  (h : ∀ b ∈ s, measurable_set (f b)) :
  measurable_set (⋃ b ∈ s, f b) :=
measurable_set.bUnion hs.countable h

lemma finset.measurable_set_bUnion {f : β → set α} (s : finset β)
  (h : ∀ b ∈ s, measurable_set (f b)) :
  measurable_set (⋃ b ∈ s, f b) :=
s.finite_to_set.measurable_set_bUnion h

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

lemma set.finite.measurable_set_sUnion {s : set (set α)} (hs : finite s)
  (h : ∀ t ∈ s, measurable_set t) :
  measurable_set (⋃₀ s) :=
measurable_set.sUnion hs.countable h

lemma measurable_set.Union_Prop {p : Prop} {f : p → set α} (hf : ∀ b, measurable_set (f b)) :
  measurable_set (⋃ b, f b) :=
by { by_cases p; simp [h, hf, measurable_set.empty] }

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

section fintype

local attribute [instance] fintype.encodable

lemma measurable_set.Union_fintype [fintype β] {f : β → set α} (h : ∀ b, measurable_set (f b)) :
  measurable_set (⋃ b, f b) :=
measurable_set.Union h

lemma measurable_set.Inter_fintype [fintype β] {f : β → set α} (h : ∀ b, measurable_set (f b)) :
  measurable_set (⋂ b, f b) :=
measurable_set.Inter h

end fintype

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

lemma set.finite.measurable_set_bInter {f : β → set α} {s : set β} (hs : finite s)
  (h : ∀ b ∈ s, measurable_set (f b)) : measurable_set (⋂ b ∈ s, f b) :=
measurable_set.bInter hs.countable h

lemma finset.measurable_set_bInter {f : β → set α} (s : finset β)
  (h : ∀ b ∈ s, measurable_set (f b)) : measurable_set (⋂ b ∈ s, f b) :=
s.finite_to_set.measurable_set_bInter h

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

lemma set.finite.measurable_set_sInter {s : set (set α)} (hs : finite s)
  (h : ∀ t ∈ s, measurable_set t) : measurable_set (⋂₀ s) :=
measurable_set.sInter hs.countable h

lemma measurable_set.Inter_Prop {p : Prop} {f : p → set α} (hf : ∀ b, measurable_set (f b)) :
  measurable_set (⋂ b, f b) :=
by { by_cases p; simp [h, hf, measurable_set.univ] }

@[simp] lemma measurable_set.union {s₁ s₂ : set α} (h₁ : measurable_set s₁)
  (h₂ : measurable_set s₂) :
  measurable_set (s₁ ∪ s₂) :=
by { rw union_eq_Union, exact measurable_set.Union (bool.forall_bool.2 ⟨h₂, h₁⟩) }

@[simp] lemma measurable_set.inter {s₁ s₂ : set α} (h₁ : measurable_set s₁)
  (h₂ : measurable_set s₂) :
  measurable_set (s₁ ∩ s₂) :=
by { rw inter_eq_compl_compl_union_compl, exact (h₁.compl.union h₂.compl).compl }

@[simp] lemma measurable_set.diff {s₁ s₂ : set α} (h₁ : measurable_set s₁)
  (h₂ : measurable_set s₂) :
  measurable_set (s₁ \ s₂) :=
h₁.inter h₂.compl

@[simp] lemma measurable_set.ite {t s₁ s₂ : set α} (ht : measurable_set t) (h₁ : measurable_set s₁)
  (h₂ : measurable_set s₂) :
  measurable_set (t.ite s₁ s₂) :=
(h₁.inter ht).union (h₂.diff ht)

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

@[simp] lemma measurable_set.const (p : Prop) : measurable_set {a : α | p} :=
by { by_cases p; simp [h, measurable_set.empty]; apply measurable_set.univ }

/-- Every set has a measurable superset. Declare this as local instance as needed. -/
lemma nonempty_measurable_superset (s : set α) : nonempty { t // s ⊆ t ∧ measurable_set t} :=
⟨⟨univ, subset_univ s, measurable_set.univ⟩⟩

end

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

@[ext] lemma measurable_space.ext_iff {m₁ m₂ : measurable_space α} :
  m₁ = m₂ ↔ (∀ s : set α, m₁.measurable_set' s ↔ m₂.measurable_set' s) :=
⟨by { unfreezingI {rintro rfl}, intro s, refl }, measurable_space.ext⟩

/-- A typeclass mixin for `measurable_space`s such that each singleton is measurable. -/
class measurable_singleton_class (α : Type*) [measurable_space α] : Prop :=
(measurable_set_singleton : ∀ x, measurable_set ({x} : set α))

export measurable_singleton_class (measurable_set_singleton)

attribute [simp] measurable_set_singleton

section measurable_singleton_class

variables [measurable_space α] [measurable_singleton_class α]

lemma measurable_set_eq {a : α} : measurable_set {x | x = a} :=
measurable_set_singleton a

lemma measurable_set.insert {s : set α} (hs : measurable_set s) (a : α) :
  measurable_set (insert a s) :=
(measurable_set_singleton a).union hs

@[simp] lemma measurable_set_insert {a : α} {s : set α} :
  measurable_set (insert a s) ↔ measurable_set s :=
⟨λ h, if ha : a ∈ s then by rwa ← insert_eq_of_mem ha
  else insert_diff_self_of_not_mem ha ▸ h.diff (measurable_set_singleton _),
  λ h, h.insert a⟩

lemma set.finite.measurable_set {s : set α} (hs : finite s) : measurable_set s :=
finite.induction_on hs measurable_set.empty $ λ a s ha hsf hsm, hsm.insert _

protected lemma finset.measurable_set (s : finset α) : measurable_set (↑s : set α) :=
s.finite_to_set.measurable_set

end measurable_singleton_class

namespace measurable_space

section complete_lattice

instance : partial_order (measurable_space α) :=
{ le          := λ m₁ m₂, m₁.measurable_set' ≤ m₂.measurable_set',
  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 α :=
{ measurable_set'      := generate_measurable s,
  measurable_set_empty := generate_measurable.empty,
  measurable_set_compl := generate_measurable.compl,
  measurable_set_Union := generate_measurable.union }

lemma measurable_set_generate_from {s : set (set α)} {t : set α} (ht : t ∈ s) :
  (generate_from s).measurable_set' t :=
generate_measurable.basic t ht

lemma generate_from_le {s : set (set α)} {m : measurable_space α}
  (h : ∀ t ∈ s, m.measurable_set' t) : generate_from s ≤ m :=
assume t (ht : generate_measurable s t), ht.rec_on h
  (measurable_set_empty m)
  (assume s _ hs, measurable_set_compl m s hs)
  (assume f _ hf, measurable_set_Union m f hf)

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

@[simp] lemma generate_from_measurable_set [measurable_space α] :
  generate_from {s : set α | measurable_set s} = ‹_› :=
le_antisymm (generate_from_le $ λ _, id) $ λ s, measurable_set_generate_from

/-- If `g` is a collection of subsets of `α` such that the `σ`-algebra generated from `g` contains
the same sets as `g`, then `g` was already a `σ`-algebra. -/
protected def mk_of_closure (g : set (set α)) (hg : {t | (generate_from g).measurable_set' t} = g) :
  measurable_space α :=
{ measurable_set'      := λ s, s ∈ g,
  measurable_set_empty := hg ▸ measurable_set_empty _,
  measurable_set_compl := hg ▸ measurable_set_compl _,
  measurable_set_Union := hg ▸ measurable_set_Union _ }

lemma mk_of_closure_sets {s : set (set α)}
  {hs : {t | (generate_from s).measurable_set' t} = s} :
  measurable_space.mk_of_closure s hs = generate_from s :=
measurable_space.ext $ assume t, show t ∈ s ↔ _, by { conv_lhs { rw [← hs] }, refl }

/-- We get a Galois insertion between `σ`-algebras on `α` and `set (set α)` by using `generate_from`
  on one side and the collection of measurable sets on the other side. -/
def gi_generate_from : galois_insertion (@generate_from α) (λ m, {t | @measurable_set α m t}) :=
{ gc        := assume s, generate_from_le_iff,
  le_l_u    := assume m s, measurable_set_generate_from,
  choice    :=
    λ g hg, measurable_space.mk_of_closure g $ le_antisymm hg $ (generate_from_le_iff _).1 le_rfl,
  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 measurable_set_bot_iff {s : set α} : @measurable_set α ⊥ s ↔ (s = ∅ ∨ s = univ) :=
let b : measurable_space α :=
{ measurable_set'      := λ s, s = ∅ ∨ s = univ,
  measurable_set_empty := or.inl rfl,
  measurable_set_compl := by simp [or_imp_distrib] {contextual := tt},
  measurable_set_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 (λ s, s.symm ▸ @measurable_set_empty _ ⊥) (λ s, s.symm ▸ @measurable_set.univ _ ⊥),
this ▸ iff.rfl

@[simp] theorem measurable_set_top {s : set α} : @measurable_set _ ⊤ s := trivial

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

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

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

theorem measurable_set_sup {m₁ m₂ : measurable_space α} {s : set α} :
  @measurable_set _ (m₁ ⊔ m₂) s ↔ generate_measurable (m₁.measurable_set' ∪ m₂.measurable_set') s :=
iff.refl _

theorem measurable_set_Sup {ms : set (measurable_space α)} {s : set α} :
  @measurable_set _ (Sup ms) s ↔
    generate_measurable {s : set α | ∃ m ∈ ms, @measurable_set _ m s} s :=
begin
  change @measurable_set' _ (generate_from $ ⋃ m ∈ ms, _) _ ↔ _,
  simp [generate_from, ← set_of_exists]
end

theorem measurable_set_supr {ι} {m : ι → measurable_space α} {s : set α} :
  @measurable_set _ (supr m) s ↔
    generate_measurable {s : set α | ∃ i, @measurable_set _ (m i) s} s :=
begin
  convert @measurable_set_Sup _ (range m) s,
  simp,
end

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 β :=
{ measurable_set'      := λ s, m.measurable_set' $ f ⁻¹' s,
  measurable_set_empty := m.measurable_set_empty,
  measurable_set_compl := assume s hs, m.measurable_set_compl _ hs,
  measurable_set_Union := assume f hf, by { rw preimage_Union, exact m.measurable_set_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 α :=
{ measurable_set'      := λ s, ∃s', m.measurable_set' s' ∧ f ⁻¹' s' = s,
  measurable_set_empty := ⟨∅, m.measurable_set_empty, rfl⟩,
  measurable_set_compl := assume s ⟨s', h₁, h₂⟩, ⟨s'ᶜ, m.measurable_set_compl _ h₁, h₂ ▸ rfl⟩,
  measurable_set_Union := assume s hs,
    let ⟨s', hs'⟩ := classical.axiom_of_choice hs in
    ⟨⋃ i, s' i, m.measurable_set_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 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

lemma comap_generate_from {f : α → β} {s : set (set β)} :
  (generate_from s).comap f = generate_from (preimage f '' s) :=
le_antisymm
  (comap_le_iff_le_map.2 $ generate_from_le $ assume t hts,
    generate_measurable.basic _ $ mem_image_of_mem _ $ hts)
  (generate_from_le $ assume t ⟨u, hu, eq⟩, eq ▸ ⟨u, generate_measurable.basic _ hu, rfl⟩)

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 [measurable_space α] [measurable_space β] (f : α → β) : Prop :=
∀ ⦃t : set β⦄, measurable_set t → measurable_set (f ⁻¹' t)

lemma measurable_iff_le_map {m₁ : measurable_space α} {m₂ : measurable_space β} {f : α → β} :
  measurable f ↔ m₂ ≤ m₁.map f :=
iff.rfl

alias measurable_iff_le_map ↔ measurable.le_map measurable.of_le_map

lemma measurable_iff_comap_le {m₁ : measurable_space α} {m₂ : measurable_space β} {f : α → β} :
  measurable f ↔ m₂.comap f ≤ m₁ :=
comap_le_iff_le_map.symm

alias measurable_iff_comap_le ↔ measurable.comap_le measurable.of_comap_le

lemma measurable.mono {ma ma' : measurable_space α} {mb mb' : measurable_space β} {f : α → β}
  (hf : @measurable α β ma mb f) (ha : ma ≤ ma') (hb : mb' ≤ mb) :
  @measurable α β ma' mb' f :=
λ t ht, ha _ $ hf $ hb _ ht

lemma measurable_from_top [measurable_space β] {f : α → β} : @measurable _ _ ⊤ _ f :=
λ s hs, trivial

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

variables [measurable_space α] [measurable_space β] [measurable_space γ]

lemma measurable_id : measurable (@id α) := λ t, id

lemma measurable.comp {g : β → γ} {f : α → β} (hg : measurable g) (hf : measurable f) :
  measurable (g ∘ f) :=
λ t ht, hf (hg ht)

lemma measurable.iterate {f : α → α} (hf : measurable f) : ∀ n, measurable (f^[n])
| 0 := measurable_id
| (n+1) := (measurable.iterate n).comp hf

@[nontriviality] lemma subsingleton.measurable [subsingleton α] {f : α → β} : measurable f :=
λ s hs, @subsingleton.measurable_set α _ _ _

lemma measurable.piecewise {s : set α} {_ : decidable_pred s} {f g : α → β}
  (hs : measurable_set s) (hf : measurable f) (hg : measurable g) :
  measurable (piecewise s f g) :=
begin
  intros t ht,
  rw piecewise_preimage,
  exact hs.ite (hf ht) (hg ht)
end

/-- this is slightly different from `measurable.piecewise`. It can be used to show
`measurable (ite (x=0) 0 1)` by
`exact measurable.ite (measurable_set_singleton 0) measurable_const measurable_const`,
but replacing `measurable.ite` by `measurable.piecewise` in that example proof does not work. -/
lemma measurable.ite {p : α → Prop} {_ : decidable_pred p} {f g : α → β}
  (hp : measurable_set {a : α | p a}) (hf : measurable f) (hg : measurable g) :
  measurable (λ x, ite (p x) (f x) (g x)) :=
measurable.piecewise hp hf hg

@[simp] lemma measurable_const {a : α} : measurable (λ b : β, a) :=
assume s hs, measurable_set.const (a ∈ s)

lemma measurable.indicator [has_zero β] {s : set α} {f : α → β}
  (hf : measurable f) (hs : measurable_set s) : measurable (s.indicator f) :=
hf.piecewise hs measurable_const

@[to_additive]
lemma measurable_one [has_one α] : measurable (1 : β → α) := @measurable_const _ _ _ _ 1

lemma measurable_of_not_nonempty  (h : ¬ nonempty α) (f : α → β) : measurable f :=
begin
  assume s hs,
  convert measurable_set.empty,
  exact eq_empty_of_not_nonempty h _,
end

@[to_additive] lemma measurable_set_mul_support [has_one β]
  [measurable_singleton_class β] {f : α → β} (hf : measurable f) :
  measurable_set (mul_support f) :=
hf (measurable_set_singleton 1).compl

end measurable_functions

section constructions

variables [measurable_space α] [measurable_space β] [measurable_space γ]

instance : measurable_space empty := ⊤
instance : measurable_space punit := ⊤ -- this also works for `unit`
instance : measurable_space bool := ⊤
instance : measurable_space ℕ := ⊤
instance : measurable_space ℤ := ⊤
instance : measurable_space ℚ := ⊤

lemma measurable_to_encodable [encodable α] {f : β → α} (h : ∀ y, measurable_set (f ⁻¹' {f y})) :
  measurable f :=
begin
  assume s hs,
  rw [← bUnion_preimage_singleton],
  refine measurable_set.Union (λ y, measurable_set.Union_Prop $ λ hy, _),
  by_cases hyf : y ∈ range f,
  { rcases hyf with ⟨y, rfl⟩,
    apply h },
  { simp only [preimage_singleton_eq_empty.2 hyf, measurable_set.empty] }
end

lemma measurable_unit (f : unit → α) : measurable f :=
measurable_from_top

section nat

lemma measurable_from_nat {f : ℕ → α} : measurable f :=
measurable_from_top

lemma measurable_to_nat {f : α → ℕ} : (∀ y, measurable_set (f ⁻¹' {f y})) → measurable f :=
measurable_to_encodable

lemma measurable_find_greatest' {p : α → ℕ → Prop}
  {N} (hN : ∀ k ≤ N, measurable_set {x | nat.find_greatest (p x) N = k}) :
  measurable (λ x, nat.find_greatest (p x) N) :=
measurable_to_nat $ λ x, hN _ nat.find_greatest_le

lemma measurable_find_greatest {p : α → ℕ → Prop} {N} (hN : ∀ k ≤ N, measurable_set {x | p x k}) :
  measurable (λ x, nat.find_greatest (p x) N) :=
begin
  refine measurable_find_greatest' (λ k hk, _),
  simp only [nat.find_greatest_eq_iff, set_of_and, set_of_forall, ← compl_set_of],
  repeat { apply_rules [measurable_set.inter, measurable_set.const, measurable_set.Inter,
    measurable_set.Inter_Prop, measurable_set.compl, hN]; try { intros } }
end

lemma measurable_find {p : α → ℕ → Prop} (hp : ∀ x, ∃ N, p x N)
  (hm : ∀ k, measurable_set {x | p x k}) :
  measurable (λ x, nat.find (hp x)) :=
begin
  refine measurable_to_nat (λ x, _),
  simp only [set.preimage, mem_singleton_iff, nat.find_eq_iff, set_of_and, set_of_forall,
    ← compl_set_of],
  repeat { apply_rules [measurable_set.inter, hm, measurable_set.Inter, measurable_set.Inter_Prop,
    measurable_set.compl]; try { intros } }
end

end nat

section subtype

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

lemma measurable_subtype_coe {p : α → Prop} : measurable (coe : subtype p → α) :=
measurable_space.le_map_comap

lemma measurable.subtype_coe {p : β → Prop} {f : α → subtype p} (hf : measurable f) :
  measurable (λ a : α, (f a : β)) :=
measurable_subtype_coe.comp hf

lemma measurable.subtype_mk {p : β → Prop} {f : α → β} (hf : measurable f) {h : ∀ x, p (f x)} :
  measurable (λ x, (⟨f x, h x⟩ : subtype p)) :=
λ t ⟨s, hs⟩, hs.2 ▸ by simp only [← preimage_comp, (∘), subtype.coe_mk, hf hs.1]

lemma measurable_set.subtype_image {s : set α} {t : set s}
  (hs : measurable_set s) : measurable_set t → measurable_set ((coe : s → α) '' t)
| ⟨u, (hu : measurable_set u), (eq : coe ⁻¹' u = t)⟩ :=
  begin
    rw [← eq, subtype.image_preimage_coe],
    exact hu.inter hs
  end

lemma measurable_of_measurable_union_cover
  {f : α → β} (s t : set α) (hs : measurable_set s) (ht : measurable_set t) (h : univ ⊆ s ∪ t)
  (hc : measurable (λ a : s, f a)) (hd : measurable (λ a : t, f a)) :
  measurable f :=
begin
  intros u hu,
  convert (hs.subtype_image (hc hu)).union (ht.subtype_image (hd hu)),
  change f ⁻¹' u = coe '' (coe ⁻¹' (f ⁻¹' u) : set s) ∪ coe '' (coe ⁻¹' (f ⁻¹' u) : set t),
  rw [image_preimage_eq_inter_range, image_preimage_eq_inter_range, subtype.range_coe,
      subtype.range_coe, ← inter_distrib_left, univ_subset_iff.1 h, inter_univ],
end

lemma measurable_of_measurable_on_compl_singleton [measurable_singleton_class α]
  {f : α → β} (a : α) (hf : measurable (set.restrict f {x | x ≠ a})) :
  measurable f :=
measurable_of_measurable_union_cover _ _ measurable_set_eq measurable_set_eq.compl
  (λ x hx, classical.em _)
  (@subsingleton.measurable {x | x = a} _ _ _ ⟨λ x y, subtype.eq $ x.2.trans y.2.symm⟩ _) 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 (prod.fst : α × β → α) :=
measurable.of_comap_le le_sup_left

lemma measurable.fst {f : α → β × γ} (hf : measurable f) : measurable (λ a : α, (f a).1) :=
measurable_fst.comp hf

lemma measurable_snd : measurable (prod.snd : α × β → β) :=
measurable.of_comap_le le_sup_right

lemma measurable.snd {f : α → β × γ} (hf : measurable f) : measurable (λ a : α, (f a).2) :=
measurable_snd.comp hf

lemma measurable.prod {f : α → β × γ}
  (hf₁ : measurable (λ a, (f a).1)) (hf₂ : measurable (λ a, (f a).2)) : measurable f :=
measurable.of_le_map $ 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 {f : α → β × γ} : measurable f ↔
  measurable (λ a, (f a).1) ∧ measurable (λ a, (f a).2) :=
⟨λ hf, ⟨measurable_fst.comp hf, measurable_snd.comp hf⟩, λ h, measurable.prod h.1 h.2⟩

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

lemma measurable_prod_mk_left {x : α} : measurable (@prod.mk _ β x) :=
measurable_const.prod_mk measurable_id

lemma measurable_prod_mk_right {y : β} : measurable (λ x : α, (x, y)) :=
measurable_id.prod_mk measurable_const

lemma measurable.prod_map [measurable_space δ] {f : α → β} {g : γ → δ} (hf : measurable f)
  (hg : measurable g) : measurable (prod.map f g) :=
(hf.comp measurable_fst).prod_mk (hg.comp measurable_snd)

lemma measurable.of_uncurry_left {f : α → β → γ} (hf : measurable (uncurry f)) {x : α} :
  measurable (f x) :=
hf.comp measurable_prod_mk_left

lemma measurable.of_uncurry_right {f : α → β → γ} (hf : measurable (uncurry f)) {y : β} :
  measurable (λ x, f x y) :=
hf.comp measurable_prod_mk_right

lemma measurable_swap : measurable (prod.swap : α × β → β × α) :=
measurable.prod measurable_snd measurable_fst

lemma measurable_swap_iff {f : α × β → γ} : measurable (f ∘ prod.swap) ↔ measurable f :=
⟨λ hf, by { convert hf.comp measurable_swap, ext ⟨x, y⟩, refl }, λ hf, hf.comp measurable_swap⟩

lemma measurable_set.prod {s : set α} {t : set β} (hs : measurable_set s) (ht : measurable_set t) :
  measurable_set (s.prod t) :=
measurable_set.inter (measurable_fst hs) (measurable_snd ht)

lemma measurable_set_prod_of_nonempty {s : set α} {t : set β} (h : (s.prod t).nonempty) :
  measurable_set (s.prod t) ↔ measurable_set s ∧ measurable_set t :=
begin
  rcases h with ⟨⟨x, y⟩, hx, hy⟩,
  refine ⟨λ hst, _, λ h, h.1.prod h.2⟩,
  have : measurable_set ((λ x, (x, y)) ⁻¹' s.prod t) := measurable_id.prod_mk measurable_const hst,
  have : measurable_set (prod.mk x ⁻¹' s.prod t) := measurable_const.prod_mk measurable_id hst,
  simp * at *
end

lemma measurable_set_prod {s : set α} {t : set β} :
  measurable_set (s.prod t) ↔ (measurable_set s ∧ measurable_set t) ∨ s = ∅ ∨ t = ∅ :=
begin
  cases (s.prod t).eq_empty_or_nonempty with h h,
  { simp [h, prod_eq_empty_iff.mp h] },
  { simp [←not_nonempty_iff_eq_empty, prod_nonempty_iff.mp h, measurable_set_prod_of_nonempty h] }
end

lemma measurable_set_swap_iff {s : set (α × β)} :
  measurable_set (prod.swap ⁻¹' s) ↔ measurable_set s :=
⟨λ hs, by { convert measurable_swap hs, ext ⟨x, y⟩, refl }, λ hs, measurable_swap hs⟩

lemma measurable_from_prod_encodable [encodable β] [measurable_singleton_class β]
  {f : α × β → γ} (hf : ∀ y, measurable (λ x, f (x, y))) :
  measurable f :=
begin
  intros s hs,
  have : f ⁻¹' s = ⋃ y, ((λ x, f (x, y)) ⁻¹' s).prod {y},
  { ext1 ⟨x, y⟩,
    simp [and_assoc, and.left_comm] },
  rw this,
  exact measurable_set.Union (λ y, (hf y hs).prod (measurable_set_singleton y))
end

end prod

section pi

variables {π : δ → Type*}

instance measurable_space.pi [m : Π a, measurable_space (π a)] : measurable_space (Π a, π a) :=
⨆ a, (m a).comap (λ b, b a)

variables [Π a, measurable_space (π a)] [measurable_space γ]

lemma measurable_pi_iff {g : α → Π a, π a} :
  measurable g ↔ ∀ a, measurable (λ x, g x a) :=
by simp_rw [measurable_iff_comap_le, measurable_space.pi, measurable_space.comap_supr,
    measurable_space.comap_comp, function.comp, supr_le_iff]

lemma measurable_pi_apply (a : δ) : measurable (λ f : Π a, π a, f a) :=
measurable.of_comap_le $ le_supr _ a

lemma measurable.eval {a : δ} {g : α → Π a, π a}
  (hg : measurable g) : measurable (λ x, g x a) :=
(measurable_pi_apply a).comp hg

lemma measurable_pi_lambda (f : α → Π a, π a) (hf : ∀ a, measurable (λ c, f c a)) :
  measurable f :=
measurable_pi_iff.mpr hf

/-- The function `update f a : π a → Π a, π a` is always measurable.
  This doesn't require `f` to be measurable.
  This should not be confused with the statement that `update f a x` is measurable. -/
lemma measurable_update (f : Π (a : δ), π a) {a : δ} : measurable (update f a) :=
begin
  apply measurable_pi_lambda,
  intro x, by_cases hx : x = a,
  { cases hx, convert measurable_id, ext, simp },
  simp_rw [update_noteq hx], apply measurable_const,
end

/- Even though we cannot use projection notation, we still keep a dot to be consistent with similar
  lemmas, like `measurable_set.prod`. -/
lemma measurable_set.pi {s : set δ} {t : Π i : δ, set (π i)} (hs : countable s)
  (ht : ∀ i ∈ s, measurable_set (t i)) :
  measurable_set (s.pi t) :=
by { rw [pi_def], exact measurable_set.bInter hs (λ i hi, measurable_pi_apply _ (ht i hi)) }

lemma measurable_set.univ_pi [encodable δ] {t : Π i : δ, set (π i)}
  (ht : ∀ i, measurable_set (t i)) : measurable_set (pi univ t) :=
measurable_set.pi (countable_encodable _) (λ i _, ht i)

lemma measurable_set_pi_of_nonempty {s : set δ} {t : Π i, set (π i)} (hs : countable s)
  (h : (pi s t).nonempty) : measurable_set (pi s t) ↔ ∀ i ∈ s, measurable_set (t i) :=
begin
  rcases h with ⟨f, hf⟩, refine ⟨λ hst i hi, _, measurable_set.pi hs⟩,
  convert measurable_update f hst, rw [update_preimage_pi hi], exact λ j hj _, hf j hj
end

lemma measurable_set_pi {s : set δ} {t : Π i, set (π i)} (hs : countable s) :
  measurable_set (pi s t) ↔ (∀ i ∈ s, measurable_set (t i)) ∨ pi s t = ∅ :=
begin
  cases (pi s t).eq_empty_or_nonempty with h h,
  { simp [h] },
  { simp [measurable_set_pi_of_nonempty hs, h, ← not_nonempty_iff_eq_empty] }
end

section fintype

local attribute [instance] fintype.encodable

lemma measurable_set.pi_fintype [fintype δ] {s : set δ} {t : Π i, set (π i)}
  (ht : ∀ i ∈ s, measurable_set (t i)) : measurable_set (pi s t) :=
measurable_set.pi (countable_encodable _) ht

lemma measurable_set.univ_pi_fintype [fintype δ] {t : Π i, set (π i)}
  (ht : ∀ i, measurable_set (t i)) : measurable_set (pi univ t) :=
measurable_set.pi_fintype (λ i _, ht i)

end fintype
end pi

instance tprod.measurable_space (π : δ → Type*) [∀ x, measurable_space (π x)] :
  ∀ (l : list δ), measurable_space (list.tprod π l)
| []        := punit.measurable_space
| (i :: is) := @prod.measurable_space _ _ _ (tprod.measurable_space is)

section tprod

open list

variables {π : δ → Type*} [∀ x, measurable_space (π x)]

lemma measurable_tprod_mk (l : list δ) : measurable (@tprod.mk δ π l) :=
begin
  induction l with i l ih,
  { exact measurable_const },
  { exact (measurable_pi_apply i).prod_mk ih }
end

lemma measurable_tprod_elim : ∀ {l : list δ} {i : δ} (hi : i ∈ l),
  measurable (λ (v : tprod π l), v.elim hi)
| (i :: is) j hj := begin
  by_cases hji : j = i,
  { subst hji, simp [measurable_fst] },
  { rw [funext $ tprod.elim_of_ne _ hji],
    exact (measurable_tprod_elim (hj.resolve_left hji)).comp measurable_snd }
end

lemma measurable_tprod_elim' {l : list δ} (h : ∀ i, i ∈ l) :
  measurable (tprod.elim' h : tprod π l → Π i, π i) :=
measurable_pi_lambda _ (λ i, measurable_tprod_elim (h i))

lemma measurable_set.tprod (l : list δ) {s : ∀ i, set (π i)} (hs : ∀ i, measurable_set (s i)) :
  measurable_set (set.tprod l s) :=
by { induction l with i l ih, exact measurable_set.univ, exact (hs i).prod ih }

end tprod

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

section sum

lemma measurable_inl : measurable (@sum.inl α β) := measurable.of_le_map inf_le_left

lemma measurable_inr : measurable (@sum.inr α β) := measurable.of_le_map inf_le_right

lemma measurable_sum {f : α ⊕ β → γ}
  (hl : measurable (f ∘ sum.inl)) (hr : measurable (f ∘ sum.inr)) : measurable f :=
measurable.of_comap_le $ le_inf
  (measurable_space.comap_le_iff_le_map.2 $ hl)
  (measurable_space.comap_le_iff_le_map.2 $ hr)

lemma measurable.sum_elim {f : α → γ} {g : β → γ} (hf : measurable f) (hg : measurable g) :
  measurable (sum.elim f g) :=
measurable_sum hf hg

lemma measurable_set.inl_image {s : set α} (hs : measurable_set s) :
  measurable_set (sum.inl '' s : set (α ⊕ β)) :=
⟨show measurable_set (sum.inl ⁻¹' _), by { rwa [preimage_image_eq], exact (λ a b, sum.inl.inj) },
  have sum.inr ⁻¹' (sum.inl '' s : set (α ⊕ β)) = ∅ :=
    eq_empty_of_subset_empty $ assume x ⟨y, hy, eq⟩, by contradiction,
  show measurable_set (sum.inr ⁻¹' _), by { rw [this], exact measurable_set.empty }⟩

lemma measurable_set_range_inl : measurable_set (range sum.inl : set (α ⊕ β)) :=
by { rw [← image_univ], exact measurable_set.univ.inl_image }

lemma measurable_set_inr_image {s : set β} (hs : measurable_set s) :
  measurable_set (sum.inr '' s : set (α ⊕ β)) :=
⟨ have sum.inl ⁻¹' (sum.inr '' s : set (α ⊕ β)) = ∅ :=
    eq_empty_of_subset_empty $ assume x ⟨y, hy, eq⟩, by contradiction,
  show measurable_set (sum.inl ⁻¹' _), by { rw [this], exact measurable_set.empty },
  show measurable_set (sum.inr ⁻¹' _), by { rwa [preimage_image_eq], exact λ a b, sum.inr.inj }⟩

lemma measurable_set_range_inr : measurable_set (range sum.inr : set (α ⊕ β)) :=
by { rw [← image_univ], exact measurable_set_inr_image measurable_set.univ }

end sum

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

end constructions

/-- Equivalences between measurable spaces. Main application is the simplification of measurability
statements along measurable equivalences. -/
structure measurable_equiv (α β : Type*) [measurable_space α] [measurable_space β] extends α ≃ β :=
(measurable_to_fun : measurable to_fun)
(measurable_inv_fun : measurable inv_fun)

infix ` ≃ᵐ `:25 := measurable_equiv

namespace measurable_equiv

variables (α β) [measurable_space α] [measurable_space β] [measurable_space γ] [measurable_space δ]

instance : has_coe_to_fun (α ≃ᵐ β) :=
⟨λ _, α → β, λ e, e.to_equiv⟩

variables {α β}

lemma coe_eq (e : α ≃ᵐ β) : (e : α → β) = e.to_equiv := rfl

protected lemma measurable (e : α ≃ᵐ β) : measurable (e : α → β) :=
e.measurable_to_fun

@[simp] lemma coe_mk (e : α ≃ β) (h1 : measurable e) (h2 : measurable e.symm) :
  ((⟨e, h1, h2⟩ : α ≃ᵐ β) : α → β) = e := rfl

/-- Any measurable space is equivalent to itself. -/
def refl (α : Type*) [measurable_space α] : α ≃ᵐ α :=
{ to_equiv := equiv.refl α,
  measurable_to_fun := measurable_id, measurable_inv_fun := measurable_id }

instance : inhabited (α ≃ᵐ α) := ⟨refl α⟩

/-- The composition of equivalences between measurable spaces. -/
@[simps] def trans (ab : α ≃ᵐ β) (bc : β ≃ᵐ γ) :
  α ≃ᵐ γ :=
{ to_equiv := ab.to_equiv.trans bc.to_equiv,
  measurable_to_fun := bc.measurable_to_fun.comp ab.measurable_to_fun,
  measurable_inv_fun := ab.measurable_inv_fun.comp bc.measurable_inv_fun }

/-- The inverse of an equivalence between measurable spaces. -/
@[simps] def symm (ab : α ≃ᵐ β) : β ≃ᵐ α :=
{ to_equiv := ab.to_equiv.symm,
  measurable_to_fun := ab.measurable_inv_fun,
  measurable_inv_fun := ab.measurable_to_fun }

@[simp] lemma coe_symm_mk (e : α ≃ β) (h1 : measurable e) (h2 : measurable e.symm) :
  ((⟨e, h1, h2⟩ : α ≃ᵐ β).symm : β → α) = e.symm := rfl

@[simp] theorem symm_comp_self (e : α ≃ᵐ β) : e.symm ∘ e = id := funext e.left_inv

@[simp] theorem self_comp_symm (e : α ≃ᵐ β) : e ∘ e.symm = id := funext e.right_inv

/-- Equal measurable spaces are equivalent. -/
protected def cast {α β} [i₁ : measurable_space α] [i₂ : measurable_space β]
  (h : α = β) (hi : i₁ == i₂) : α ≃ᵐ β :=
{ to_equiv := equiv.cast h,
  measurable_to_fun  := by { substI h, substI hi, exact measurable_id },
  measurable_inv_fun := by { substI h, substI hi, exact measurable_id }}

protected lemma measurable_coe_iff {f : β → γ} (e : α ≃ᵐ β) :
  measurable (f ∘ e) ↔ measurable f :=
iff.intro
  (assume hfe,
    have measurable (f ∘ (e.symm.trans e).to_equiv) := hfe.comp e.symm.measurable,
    by rwa [trans_to_equiv, symm_to_equiv, equiv.symm_trans] at this)
  (λ h, h.comp e.measurable)

/-- Products of equivalent measurable spaces are equivalent. -/
def prod_congr (ab : α ≃ᵐ β) (cd : γ ≃ᵐ δ) : α × γ ≃ᵐ β × δ :=
{ to_equiv := prod_congr ab.to_equiv cd.to_equiv,
  measurable_to_fun := (ab.measurable_to_fun.comp measurable_id.fst).prod_mk
    (cd.measurable_to_fun.comp measurable_id.snd),
  measurable_inv_fun := (ab.measurable_inv_fun.comp measurable_id.fst).prod_mk
    (cd.measurable_inv_fun.comp measurable_id.snd) }

/-- Products of measurable spaces are symmetric. -/
def prod_comm : α × β ≃ᵐ β × α :=
{ to_equiv := prod_comm α β,
  measurable_to_fun  := measurable_id.snd.prod_mk measurable_id.fst,
  measurable_inv_fun := measurable_id.snd.prod_mk measurable_id.fst }

/-- Products of measurable spaces are associative. -/
def prod_assoc : (α × β) × γ ≃ᵐ α × (β × γ) :=
{ to_equiv := prod_assoc α β γ,
  measurable_to_fun  := measurable_fst.fst.prod_mk $ measurable_fst.snd.prod_mk measurable_snd,
  measurable_inv_fun := (measurable_fst.prod_mk measurable_snd.fst).prod_mk measurable_snd.snd }

/-- Sums of measurable spaces are symmetric. -/
def sum_congr (ab : α ≃ᵐ β) (cd : γ ≃ᵐ δ) : α ⊕ γ ≃ᵐ β ⊕ δ :=
{ to_equiv := sum_congr ab.to_equiv cd.to_equiv,
  measurable_to_fun :=
    begin
      cases ab with ab' abm, cases ab', cases cd with cd' cdm, cases cd',
      refine measurable_sum (measurable_inl.comp abm) (measurable_inr.comp cdm)
    end,
  measurable_inv_fun :=
    begin
      cases ab with ab' _ abm, cases ab', cases cd with cd' _ cdm, cases cd',
      refine measurable_sum (measurable_inl.comp abm) (measurable_inr.comp cdm)
    end }

/-- `set.prod s t ≃ (s × t)` as measurable spaces. -/
def set.prod (s : set α) (t : set β) : s.prod t ≃ᵐ s × t :=
{ to_equiv := equiv.set.prod s t,
  measurable_to_fun := measurable_id.subtype_coe.fst.subtype_mk.prod_mk
    measurable_id.subtype_coe.snd.subtype_mk,
  measurable_inv_fun := measurable.subtype_mk $ measurable_id.fst.subtype_coe.prod_mk
    measurable_id.snd.subtype_coe }

/-- `univ α ≃ α` as measurable spaces. -/
def set.univ (α : Type*) [measurable_space α] : (univ : set α) ≃ᵐ α :=
{ to_equiv := equiv.set.univ α,
  measurable_to_fun := measurable_id.subtype_coe,
  measurable_inv_fun := measurable_id.subtype_mk }

/-- `{a} ≃ unit` as measurable spaces. -/
def set.singleton (a : α) : ({a} : set α) ≃ᵐ unit :=
{ to_equiv := equiv.set.singleton a,
  measurable_to_fun := measurable_const,
  measurable_inv_fun := measurable_const }

/-- A set is equivalent to its image under a function `f` as measurable spaces,
  if `f` is an injective measurable function that sends measurable sets to measurable sets. -/
noncomputable def set.image (f : α → β) (s : set α) (hf : injective f)
  (hfm : measurable f) (hfi : ∀ s, measurable_set s → measurable_set (f '' s)) : s ≃ᵐ (f '' s) :=
{ to_equiv := equiv.set.image f s hf,
  measurable_to_fun  := (hfm.comp measurable_id.subtype_coe).subtype_mk,
  measurable_inv_fun :=
    begin
      rintro t ⟨u, hu, rfl⟩, simp [preimage_preimage, set.image_symm_preimage hf],
      exact measurable_subtype_coe (hfi u hu)
    end }

/-- The domain of `f` is equivalent to its range as measurable spaces,
  if `f` is an injective measurable function that sends measurable sets to measurable sets. -/
noncomputable def set.range (f : α → β) (hf : injective f) (hfm : measurable f)
  (hfi : ∀ s, measurable_set s → measurable_set (f '' s)) :
  α ≃ᵐ (range f) :=
(measurable_equiv.set.univ _).symm.trans $
  (measurable_equiv.set.image f univ hf hfm hfi).trans $
  measurable_equiv.cast (by rw image_univ) (by rw image_univ)

/-- `α` is equivalent to its image in `α ⊕ β` as measurable spaces. -/
def set.range_inl : (range sum.inl : set (α ⊕ β)) ≃ᵐ α :=
{ to_fun    := λ ab, match ab with
    | ⟨sum.inl a, _⟩ := a
    | ⟨sum.inr b, p⟩ := have false, by { cases p, contradiction }, this.elim
    end,
  inv_fun   := λ a, ⟨sum.inl a, a, rfl⟩,
  left_inv  := by { rintro ⟨ab, a, rfl⟩, refl },
  right_inv := assume a, rfl,
  measurable_to_fun  := assume s (hs : measurable_set s),
    begin
      refine ⟨_, hs.inl_image, set.ext _⟩,
      rintros ⟨ab, a, rfl⟩,
      simp [set.range_inl._match_1]
    end,
  measurable_inv_fun := measurable.subtype_mk measurable_inl }

/-- `β` is equivalent to its image in `α ⊕ β` as measurable spaces. -/
def set.range_inr : (range sum.inr : set (α ⊕ β)) ≃ᵐ β :=
{ to_fun    := λ ab, match ab with
    | ⟨sum.inr b, _⟩ := b
    | ⟨sum.inl a, p⟩ := have false, by { cases p, contradiction }, this.elim
    end,
  inv_fun   := λ b, ⟨sum.inr b, b, rfl⟩,
  left_inv  := by { rintro ⟨ab, b, rfl⟩, refl },
  right_inv := assume b, rfl,
  measurable_to_fun  := assume s (hs : measurable_set s),
    begin
      refine ⟨_, measurable_set_inr_image hs, set.ext _⟩,
      rintros ⟨ab, b, rfl⟩,
      simp [set.range_inr._match_1]
    end,
  measurable_inv_fun := measurable.subtype_mk measurable_inr }

/-- Products distribute over sums (on the right) as measurable spaces. -/
def sum_prod_distrib (α β γ) [measurable_space α] [measurable_space β] [measurable_space γ] :
  (α ⊕ β) × γ ≃ᵐ (α × γ) ⊕ (β × γ) :=
{ to_equiv := sum_prod_distrib α β γ,
  measurable_to_fun  :=
  begin
    refine measurable_of_measurable_union_cover
      ((range sum.inl).prod univ)
      ((range sum.inr).prod univ)
      (measurable_set_range_inl.prod measurable_set.univ)
      (measurable_set_range_inr.prod measurable_set.univ)
      (by { rintro ⟨a|b, c⟩; simp [set.prod_eq] })
      _
      _,
    { refine (set.prod (range sum.inl) univ).symm.measurable_coe_iff.1 _,
      refine (prod_congr set.range_inl (set.univ _)).symm.measurable_coe_iff.1 _,
      dsimp [(∘)],
      convert measurable_inl,
      ext ⟨a, c⟩, refl },
    { refine (set.prod (range sum.inr) univ).symm.measurable_coe_iff.1 _,
      refine (prod_congr set.range_inr (set.univ _)).symm.measurable_coe_iff.1 _,
      dsimp [(∘)],
      convert measurable_inr,
      ext ⟨b, c⟩, refl }
  end,
  measurable_inv_fun :=
    measurable_sum
      ((measurable_inl.comp measurable_fst).prod_mk measurable_snd)
      ((measurable_inr.comp measurable_fst).prod_mk measurable_snd) }

/-- Products distribute over sums (on the left) as measurable spaces. -/
def prod_sum_distrib (α β γ) [measurable_space α] [measurable_space β] [measurable_space γ] :
  α × (β ⊕ γ) ≃ᵐ (α × β) ⊕ (α × γ) :=
prod_comm.trans $ (sum_prod_distrib _ _ _).trans $ sum_congr prod_comm prod_comm

/-- Products distribute over sums as measurable spaces. -/
def sum_prod_sum (α β γ δ)
  [measurable_space α] [measurable_space β] [measurable_space γ] [measurable_space δ] :
  (α ⊕ β) × (γ ⊕ δ) ≃ᵐ ((α × γ) ⊕ (α × δ)) ⊕ ((β × γ) ⊕ (β × δ)) :=
(sum_prod_distrib _ _ _).trans $ sum_congr (prod_sum_distrib _ _ _) (prod_sum_distrib _ _ _)

variables {π π' : δ' → Type*} [∀ x, measurable_space (π x)] [∀ x, measurable_space (π' x)]

/-- A family of measurable equivalences `Π a, β₁ a ≃ᵐ β₂ a` generates a measurable equivalence
  between  `Π a, β₁ a` and `Π a, β₂ a`. -/
def Pi_congr_right (e : Π a, π a ≃ᵐ π' a) : (Π a, π a) ≃ᵐ (Π a, π' a) :=
{ to_equiv := Pi_congr_right (λ a, (e a).to_equiv),
  measurable_to_fun :=
    measurable_pi_lambda _ (λ i, (e i).measurable_to_fun.comp (measurable_pi_apply i)),
  measurable_inv_fun :=
    measurable_pi_lambda _ (λ i, (e i).measurable_inv_fun.comp (measurable_pi_apply i)) }

/-- Pi-types are measurably equivalent to iterated products. -/
noncomputable def pi_measurable_equiv_tprod {l : list δ'} (hnd : l.nodup) (h : ∀ i, i ∈ l) :
  (Π i, π i) ≃ᵐ list.tprod π l :=
{ to_equiv := list.tprod.pi_equiv_tprod hnd h,
  measurable_to_fun := measurable_tprod_mk l,
  measurable_inv_fun := measurable_tprod_elim' h }

end measurable_equiv

namespace filter

variables [measurable_space α]

/-- A filter `f` is measurably generates if each `s ∈ f` includes a measurable `t ∈ f`. -/
class is_measurably_generated (f : filter α) : Prop :=
(exists_measurable_subset : ∀ ⦃s⦄, s ∈ f → ∃ t ∈ f, measurable_set t ∧ t ⊆ s)

instance is_measurably_generated_bot : is_measurably_generated (⊥ : filter α) :=
⟨λ _ _, ⟨∅, mem_bot_sets, measurable_set.empty, empty_subset _⟩⟩

instance is_measurably_generated_top : is_measurably_generated (⊤ : filter α) :=
⟨λ s hs, ⟨univ, univ_mem_sets, measurable_set.univ, λ x _, hs x⟩⟩

lemma eventually.exists_measurable_mem {f : filter α} [is_measurably_generated f]
  {p : α → Prop} (h : ∀ᶠ x in f, p x) :
  ∃ s ∈ f, measurable_set s ∧ ∀ x ∈ s, p x :=
is_measurably_generated.exists_measurable_subset h

lemma eventually.exists_measurable_mem_of_lift' {f : filter α} [is_measurably_generated f]
  {p : set α → Prop} (h : ∀ᶠ s in f.lift' powerset, p s) :
  ∃ s ∈ f, measurable_set s ∧ p s :=
let ⟨s, hsf, hs⟩ := eventually_lift'_powerset.1 h,
  ⟨t, htf, htm, hts⟩ := is_measurably_generated.exists_measurable_subset hsf
in ⟨t, htf, htm, hs t hts⟩

instance inf_is_measurably_generated (f g : filter α) [is_measurably_generated f]
  [is_measurably_generated g] :
  is_measurably_generated (f ⊓ g) :=
begin
  refine ⟨_⟩,
  rintros t ⟨sf, hsf, sg, hsg, ht⟩,
  rcases is_measurably_generated.exists_measurable_subset hsf with ⟨s'f, hs'f, hmf, hs'sf⟩,
  rcases is_measurably_generated.exists_measurable_subset hsg with ⟨s'g, hs'g, hmg, hs'sg⟩,
  refine ⟨s'f ∩ s'g, inter_mem_inf_sets hs'f hs'g, hmf.inter hmg, _⟩,
  exact subset.trans (inter_subset_inter hs'sf hs'sg) ht
end

lemma principal_is_measurably_generated_iff {s : set α} :
  is_measurably_generated (𝓟 s) ↔ measurable_set s :=
begin
  refine ⟨_, λ hs, ⟨λ t ht, ⟨s, mem_principal_self s, hs, ht⟩⟩⟩,
  rintros ⟨hs⟩,
  rcases hs (mem_principal_self s) with ⟨t, ht, htm, hts⟩,
  have : t = s := subset.antisymm hts ht,
  rwa ← this
end

alias principal_is_measurably_generated_iff ↔
  _ measurable_set.principal_is_measurably_generated

instance infi_is_measurably_generated {f : ι → filter α} [∀ i, is_measurably_generated (f i)] :
  is_measurably_generated (⨅ i, f i) :=
begin
  refine ⟨λ s hs, _⟩,
  rw [← equiv.plift.surjective.infi_comp, mem_infi_iff] at hs,
  rcases hs with ⟨t, ht, ⟨V, hVf, hVs⟩⟩,
  choose U hUf hU using λ i, is_measurably_generated.exists_measurable_subset (hVf i),
  refine ⟨⋂ i : t, U i, _, _, _⟩,
  { rw [← equiv.plift.surjective.infi_comp, mem_infi_iff],
    refine ⟨t, ht, U, hUf, subset.refl _⟩ },
  { haveI := ht.countable.to_encodable,
    refine measurable_set.Inter (λ i, (hU i).1) },
  { exact subset.trans (Inter_subset_Inter $ λ i, (hU i).2) hVs }
end

end filter

/-- We say that a collection of sets is countably spanning if a countable subset spans the
  whole type. This is a useful condition in various parts of measure theory. For example, it is
  a needed condition to show that the product of two collections generate the product sigma algebra,
  see `generate_from_prod_eq`. -/
def is_countably_spanning (C : set (set α)) : Prop :=
∃ (s : ℕ → set α), (∀ n, s n ∈ C) ∧ (⋃ n, s n) = univ

lemma is_countably_spanning_measurable_set [measurable_space α] :
  is_countably_spanning {s : set α | measurable_set s} :=
⟨λ _, univ, λ _, measurable_set.univ, Union_const _⟩


-- make all the tactics work
import tactic
--import algebra.pi_instances -- you'll get the wrong 1 on ℕ² if you do this

-- Let's just use Lean's definition of the naturals and not worry
-- about what they are or how to make them.

import data.nat.basic

-- later on we'll do isomorphisms of rings
-- ≃+*
import data.equiv.ring

-- some missing simp lemma that Kenny needed
@[simp] theorem quotient.lift_on_beta₂ {α : Type} {β : Type} [setoid α] (f : α → α → β) (h)
  (x y : α) : ⟦x⟧.lift_on₂ ⟦y⟧ f h = f x y := rfl

-- Let's now experiment
namespace experiment

/-
An experiment where we try different definitions of the integers.
-/

--#print int
-- important todo: change all this to Lean 4 syntax
-- TODO: Look up Lean 4 definition of Int.
inductive int : Type
-- with notation ℤ
| of_nat : ℕ → int -- error -- I want this to be a ℤ
-- with notation ↑ [lemme add coercion `ℕ → ℤ` now, named automatically by computer]
| neg_succ_of_nat : ℕ → int

-- a mathematician does not need direct
-- access to either `of_nat` or `neg_succ_of_nat`, because the former is
-- the coercion and the latter is a function of no relevance
-- (it sends n to -1-n)

notation `ℤ1` := int

namespace int

-- done.

-- EXERCISE: prove it's a ring.

instance : has_zero ℤ1 := ⟨of_nat 0⟩
instance : has_one ℤ1 := ⟨of_nat 1⟩

-- all going fine so far

-- come back to these sorrys
/-
def add : ℤ1 → ℤ1 → ℤ1
| (of_nat a) (of_nat b) := of_nat (a + b)
| (neg_succ_of_nat a) (of_nat b) := sorry -- this is so horrible. It is
-- not the "right" way to do it.
| _ _ := sorry

-- troublemaking coecion? Is it?
instance : has_coe ℕ ℤ1 := sorry -- want to put something other than of_nat
-/

-- it looks so awful
-- Let's define addition on CS int via mathematician's int.

end int

-- more experimental int2

constant int2 : Type

notation `ℤ2` := int2

namespace int2

-- I'm going to be defined by my eliminator.
-- At the time of writing this is not dependent and does not cover induction.
-- My plan was to see what I really needed and start small because I need
-- to define add somehow
constant rec
(X : Type)
(F : ℕ → ℕ → X)
(H : ∀ a b c d : ℕ, a + d = b + c → F a b = F c d) :
ℤ2 → X

-- internal outputs of recursors are different. One is dependent
-- and one isn't. Does this matter to me? But I think there is another
-- difference involving quotients somehow.
--#print int.rec
--#print int2.rec

-- They're both the same though, right?

-- ℤ2 is a quotient of ℕ².
-- computer scientists call this map `mk`

constant sub : ℕ × ℕ → ℤ2

-- computer science version
noncomputable def mk : ℕ → ℕ → ℤ2 := function.curry sub

-- give it its proper name
infix ` minus `:65 := mk

-- the quotient map satisfies the quotient axioms.
-- First, the map to the quotient is surjective.
axiom sub_surj : function.surjective sub

-- Second, if two points are in the same equivalance class,
-- their images in the quotient are equal.

axiom probably_has_cs_name : ∀ a b c d : ℕ, a + d = b + c →
  (a minus b) = (c minus d)

open int

noncomputable def canonical1 : ℤ → ℤ2
| (of_nat n) := n minus 0
| (neg_succ_of_nat n) := 0 minus n.succ
-- enter math mode

-- now let's make ℤ2 into a ring

-- Hendrik Lenstra told me that older works often used bold face Z
noncomputable instance : has_zero ℤ2 := ⟨0 minus 0⟩
@[simp] lemma zero_sub_zero : 0 minus 0 = 0 := rfl

noncomputable def coe : ℕ → ℤ2 :=
λ n, n minus 0
noncomputable def neg : ℕ → ℤ2 :=
λ n, 0 minus n
open function

theorem neg_zero : neg 0 = 0 := by simp [neg]

-- OK we're making the integers into a ring
-- and we've defined the integers as nat squared mod equivalence

-- "choose a random preimage" function. We love the axiom of choice.
noncomputable def cs_name : ℤ2 → ℕ × ℕ :=
λ z, classical.some (sub_surj z)

--z : ℤ2
--⊢ sub (classical.some _) = z
-- theorem it_is_a_lift (z : ℤ2) : (cs_name z).1 minus (cs_name z).2 = z :=
-- begin
--   have h := classical.some_spec (sub_surj z),
--   sorry -- for all I know this is another axiom
-- end

def some_universal_property :=
λ z, classical.some_spec (sub_surj z)

-- not got this straight at all.
-- def add : ℤ2 → ℤ2 → ℤ2 := sorry
--λ a, rec _ (λ r s, sub (a.1 + r) (a.2 + s) : ℕ → ℕ → ℤ2)

end int2

open int2

-- Question. Are ℤ and Z2 the same?
noncomputable def sub (X : Type) (F : ℤ → X) : ℤ2 → X :=
begin
  apply int2.rec,
  swap,
  { intros a b,
    apply F,
    exact (a : ℤ) - b},
  -- hello what's this
  intros a b c d,
  intro h,
  -- it'a a proof obligation
  simp only [],
  suffices : (a : ℤ) - b = c - d,
    rw this,
  -- come on Lean
  have h1 : (a : ℤ) + d = b + c,
    norm_cast, assumption,
  have h2 : (a : ℤ) = (b + c) - d,
    rw ←h1,
  simp,
  rw h2,
  ring,
end

--#check and_congr
--#check congr
noncomputable def internal_eqality_thing (X : Type) (F : ℤ2 → X) : ℤ → X :=
λ z, F $ canonical1 z

-- Z2 and ℤ are the same.

--set_option pp.all true
-- fun exercise
-- noncomputable def canonical : ℤ ≃ ℤ2 :=
-- { to_fun := canonical1,
--   inv_fun := sub _ id,
--   left_inv := begin
--     intro x,
--     unfold sub,
--     dsimp,
--     have h := @int.rec,
--     cases x with n neg_one_minus_n,
--     { sorry},
--     { sorry}
--   end,
--   right_inv := sorry }

  -- I'm going to try doing int with quotients

namespace int3

notation `ℕ²` := ℕ × ℕ

namespace natsquared

notation `first` := prod.fst

notation `second` := prod.snd

@[ext] lemma ext {a b : ℕ²} : first a = first b → second a = second b → a = b :=
by tidy

lemma ext_iff (a b : ℕ²) : a = b ↔ first a = first b ∧ second a = second b :=
⟨λ h, by cases h; simp, λ ⟨p, q⟩, ext p q⟩

instance : has_zero ℕ² := ⟨(0, 0)⟩
@[simp] lemma first_zero : first (0 : ℕ²) = 0 := by refl
@[simp] lemma second_zero : second (0 : ℕ²) = 0 := by refl

def has_one : has_one ℕ² := ⟨(1, 0)⟩
local attribute [instance] has_one

@[simp] lemma first_one : first (1 : ℕ²) = 1 := by refl
@[simp] lemma second_one : second (1 : ℕ²) = 0 := by refl

def r (a b : ℕ²) := first a + second b = second a + first b

instance : has_equiv ℕ² := ⟨r⟩

namespace r
theorem refl (a : ℕ²) : a ≈ a :=
begin
  -- unfold it in your head
  change first a + second a = second a + first a,
  -- if you delete the line above, the line below still works
  apply add_comm,
end

theorem symm (a b : ℕ²) : a ≈ b → b ≈ a :=
begin
  intro hab,
  unfold has_equiv.equiv at *,
  rw [r] at *,
  omega,
end

theorem trans (a b c : ℕ²) : a ≈ b → b ≈ c → a ≈ c :=
begin
  intro hab,
  intro hbc,
  unfold has_equiv.equiv at *,
  rw [r] at *,
  omega,
end

theorem equiv : equivalence r :=
⟨refl, symm, trans⟩

end r

instance : setoid ℕ² :=
{ r := r,
  iseqv := r.equiv }

end natsquared

local attribute [instance] natsquared.has_one -- the canonical 1 is another one!

-- definition of int as quotient type
notation `ℤ3` := quotient natsquared.setoid

-- theorem! It's a ring!

def zero : ℤ3 := ⟦0⟧
instance : has_zero ℤ3 := ⟨zero⟩
@[simp] lemma zero.thing0 : (0 : ℤ3) = ⟦0⟧ := rfl

def one : ℤ3 := ⟦1⟧
instance : has_one ℤ3 := ⟨one⟩
@[simp] lemma one.thing0 : (1 : ℤ3) = ⟦1⟧ := rfl

@[simp] lemma one.first : first (1 : ℕ²) = 1 := by refl
@[simp] lemma one.second : second (1 : ℕ²) = 0 := by refl

open natsquared

@[simp] lemma thing (a b : ℕ²) : a ≈ b ↔ first a + second b = second a + first b := iff.rfl

@[simp] def add (a b : ℤ3) : ℤ3 := quotient.lift_on₂ a b (λ z w,
  ⟦(first z + first w, second z + second w)⟧) begin
  intros,
  simp at *,
  omega,
end

instance : has_add ℤ3 := ⟨add⟩

@[simp] lemma thing2 (a b : ℤ3) : a + b = add a b := rfl

@[simp] def neg (a : ℤ3) : ℤ3 := quotient.lift_on a (λ b, ⟦(second b, first b)⟧)
begin
  intros,
  simp at *,
  omega
end

instance : has_neg ℤ3 := ⟨neg⟩

@[simp] lemma neg.thing0 (a : ℤ3) : -a = neg a := rfl

instance : add_comm_group ℤ3 :=
{ add := (+),
  add_assoc :=
  begin
    intros a b c,
    apply quotient.induction_on₃ a b c,
    intros,
    simp * at *,
    omega,
  end,
  zero := 0,
  zero_add :=
  begin
    intro a,
    apply quotient.induction_on a,
    intros,
    simp * at *,
    omega
  end,
  add_zero :=
  begin
    intro a,
    apply quotient.induction_on a,
    intros,
    simp * at *,
    omega
  end,
  neg := has_neg.neg,
  add_left_neg :=
  begin
    intro a,
    apply quotient.induction_on a,
    intros,
    simp * at *,
    omega
  end,
  add_comm :=
  begin
    intros a b,
    apply quotient.induction_on₂ a b,
    intros,
    simp * at *,
    omega
  end
}

theorem useful (p q r s t u v w : ℕ) (h1 : p + u = q + t) (h2 : r + w = s + v) :
  p * r + q * s + (t * w + u * v) = p * s + q * r + (t * v + u * w) :=
begin
  have h3 : (p + u) * r = (q + t) * r,
    rw h1,
  rw [add_mul, add_mul] at h3,
  apply @nat.add_left_cancel (u * r),
  rw [show u * r + (p * r + q * s + (t * w + u * v)) = p * r + u * r + q * s + t * w + u * v, by ring],
  rw h3,
  rw [show q * r + t * r + q * s + t * w + u * v = t * (r + w) + q * s + u * v + q * r, by ring],
  rw [show u * r + (p * s + q * r + (t * v + u * w)) = u * (r + w) + p * s + t * v + q * r, by ring],
  rw [h2, mul_add, mul_add],
  rw [show t * s + t * v + q * s + u * v + q * r = t * s + q * s + t * v + u * v + q * r, by ring],
  --uv cancels tv cancels qr cancels
  suffices : t * s + q * s = (p + u) * s,
    rw this, ring,
  rw h1,
  ring,
end

@[simp] def mul (a b : ℤ3) : ℤ3 := quotient.lift_on₂ a b (λ z w,
  ⟦(first z * first w + second z * second w, first z * second w + second z * first w)⟧)
  -- why is this well-defined?
begin
  intros,
  simp at *,
  apply useful _ _ _ _ _ _ _ _ a_1 a_2,
end

instance : has_mul ℤ3 := ⟨mul⟩

@[simp] lemma thing3 (a b : ℤ3) : a * b = mul a b := rfl

-- the proof of every lemma is "just multiply it out"
instance : comm_ring ℤ3 :=
{ mul := (*),
  one := 1,
  mul_assoc := begin
    intros a b c,
    apply quotient.induction_on₃ a b c,
    intros,
    simp,
    ring
  end,
  one_mul := begin
    intro a,
    apply quotient.induction_on a,
    intros,
    simp,
    ring,
  end,
  mul_one := begin
    intro a,
    apply quotient.induction_on a,
    intros,
    simp,
    ring,
  end,
  left_distrib := begin
    intros a b c,
    apply quotient.induction_on₃ a b c,
    intros,
    apply quotient.sound,
    simp,
    ring,
  end,
  right_distrib := begin
    intros a b c,
    apply quotient.induction_on₃ a b c,
    intros,
    apply quotient.sound,
    simp,
    ring,
  end,
  mul_comm := begin
    intros a b,
    apply quotient.induction_on₂ a b,
    intros,
    simp,
    ring,
  end,
  ..int3.add_comm_group
}

-- is this a terrible idea??
example : ℤ ≃+* ℤ3 :=
{ to_fun := coe,
  inv_fun := λ a, quotient.lift_on a (λ b, ((first b : ℕ) : ℤ) - (second b : ℕ)) begin
    intros,
    simp * at *,
    rw sub_eq_sub_iff_add_eq_add,
    norm_cast,
    rw a_2,
    ring,
  end,
  left_inv := begin
    intro x,
    simp,
    sorry,
  end,
  right_inv := begin
    intro x,
    apply quotient.induction_on x,
    intros,
    simp * at *,
    sorry
  end,
  map_mul' := sorry,
  map_add' := sorry }

end int3

namespace int4

-- want amazing Amelia-like definition as localisation of a semiring
-- by a well-behaved equivalence relation.

-- TODO

instance : comm_semiring ℕ := by apply_instance

-- now what do I localise by to get ℤ as, say, an add_comm_group? Can I get a semiring?

end int4

/- question asked to me on Twitter today:
"How easy is it to show that ℤ are the initial objects
for pointed types with a self-equivalence"

  This means:
  if X is a type, if x : X, and if f : X ≃ X is a bijection
  then you want to define a map ℤ → X
  sending n to f^{(n)}(x).
-/

end experiment


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

/-!
# The category of types with partial functions

This defines `PartialFun`, the category of types equipped with partial functions.

This category is classically equivalent to the category of pointed types. The reason it doesn't hold
constructively stems from the difference between `part` and `option`. Both can model partial
functions, but the latter forces a decidable domain.

Precisely, `PartialFun_to_Pointed` turns a partial function `α →. β` into a function
`option α → option β` by sending to `none` the undefined values (and `none` to `none`). But being
defined is (generally) undecidable while being sent to `none` is decidable. So it can't be
constructive.

## References

* [nLab, *The category of sets and partial functions*]
  (https://ncatlab.org/nlab/show/partial+function)
-/

open category_theory option

universes u
variables {α β : Type*}

/-- The category of types equipped with partial functions. -/
def PartialFun : Type* := Type*

namespace PartialFun

instance : has_coe_to_sort PartialFun Type* := ⟨id⟩

/-- Turns a type into a `PartialFun`. -/
@[nolint has_inhabited_instance] def of : Type* → PartialFun := id

@[simp] lemma coe_of (X : Type*) : ↥(of X) = X := rfl

instance : inhabited PartialFun := ⟨Type*⟩

instance large_category : large_category.{u} PartialFun :=
{ hom := pfun,
  id := pfun.id,
  comp := λ X Y Z f g, g.comp f,
  id_comp' := @pfun.comp_id,
  comp_id' := @pfun.id_comp,
  assoc' := λ W X Y Z _ _ _, (pfun.comp_assoc _ _ _).symm }

/-- Constructs a partial function isomorphism between types from an equivalence between them. -/
@[simps] def iso.mk {α β : PartialFun.{u}} (e : α ≃ β) : α ≅ β :=
{ hom := e,
  inv := e.symm,
  hom_inv_id' := (pfun.coe_comp _ _).symm.trans $ congr_arg coe e.symm_comp_self,
  inv_hom_id' := (pfun.coe_comp _ _).symm.trans $ congr_arg coe e.self_comp_symm }

end PartialFun

/-- The forgetful functor from `Type` to `PartialFun` which forgets that the maps are total. -/
def Type_to_PartialFun : Type.{u} ⥤ PartialFun :=
{ obj := id,
  map := @pfun.lift,
  map_comp' := λ _ _ _ _ _, pfun.coe_comp _ _ }

instance : faithful Type_to_PartialFun := ⟨λ X Y, pfun.coe_injective⟩

/-- The functor which deletes the point of a pointed type. In return, this makes the maps partial.
This the computable part of the equivalence `PartialFun_equiv_Pointed`. -/
def Pointed_to_PartialFun : Pointed.{u} ⥤ PartialFun :=
{ obj := λ X, {x : X // x ≠ X.point},
  map := λ X Y f, pfun.to_subtype _ f.to_fun ∘ subtype.val,
  map_id' := λ X, pfun.ext $ λ a b,
    pfun.mem_to_subtype_iff.trans (subtype.coe_inj.trans part.mem_some_iff.symm),
  map_comp' := λ X Y Z f g, pfun.ext $ λ a c, begin
    refine (pfun.mem_to_subtype_iff.trans _).trans part.mem_bind_iff.symm,
    simp_rw [pfun.mem_to_subtype_iff, subtype.exists],
    refine ⟨λ h, ⟨f.to_fun a, λ ha, c.2 $ h.trans
      ((congr_arg g.to_fun ha : g.to_fun _ = _).trans g.map_point), rfl, h⟩, _⟩,
    rintro ⟨b, _, (rfl : b = _), h⟩,
    exact h,
  end }

/-- The functor which maps undefined values to a new point. This makes the maps total and creates
pointed types. This the noncomputable part of the equivalence `PartialFun_equiv_Pointed`. It can't
be computable because `= option.none` is decidable while the domain of a general `part` isn't. -/
noncomputable def PartialFun_to_Pointed : PartialFun ⥤ Pointed :=
by classical; exact
{ obj := λ X, ⟨option X, none⟩,
  map := λ X Y f, ⟨λ o, o.elim none (λ a, (f a).to_option), rfl⟩,
  map_id' := λ X, Pointed.hom.ext _ _ $ funext $ λ o,
    option.rec_on o rfl $ λ a, part.some_to_option _,
  map_comp' := λ X Y Z f g, Pointed.hom.ext _ _ $ funext $ λ o, option.rec_on o rfl $ λ a,
    part.bind_to_option _ _ }

/-- The equivalence induced by `PartialFun_to_Pointed` and `Pointed_to_PartialFun`.
`part.equiv_option` made functorial. -/
@[simps] noncomputable def PartialFun_equiv_Pointed : PartialFun.{u} ≌ Pointed :=
by classical; exact
equivalence.mk PartialFun_to_Pointed Pointed_to_PartialFun
  (nat_iso.of_components (λ X, PartialFun.iso.mk
    { to_fun := λ a, ⟨some a, some_ne_none a⟩,
      inv_fun := λ a, get $ ne_none_iff_is_some.1 a.2,
      left_inv := λ a, get_some _ _,
      right_inv := λ a, by simp only [subtype.val_eq_coe, some_get, subtype.coe_eta] }) $ λ X Y f,
      pfun.ext $ λ a b, begin
        unfold_projs,
        dsimp,
        rw part.bind_some,
        refine (part.mem_bind_iff.trans _).trans pfun.mem_to_subtype_iff.symm,
        obtain ⟨b | b, hb⟩ := b,
        { exact (hb rfl).elim },
        dsimp,
        simp_rw [part.mem_some_iff, subtype.mk_eq_mk, exists_prop, some_inj, exists_eq_right'],
        refine part.mem_to_option.symm.trans _,
        convert eq_comm,
        convert rfl,
      end)
  (nat_iso.of_components (λ X, Pointed.iso.mk
    { to_fun := λ a, a.elim X.point subtype.val,
      inv_fun := λ a, if h : a = X.point then none else some ⟨_, h⟩,
      left_inv := λ a, option.rec_on a (dif_pos rfl) $ λ a, (dif_neg a.2).trans $
        by simp only [option.elim, subtype.val_eq_coe, subtype.coe_eta],
      right_inv := λ a, begin
        change option.elim (dite _ _ _) _ _ = _,
        split_ifs,
        { rw h, refl },
        { refl }
      end } rfl) $ λ X Y f, Pointed.hom.ext _ _ $ funext $ λ a, option.rec_on a f.map_point.symm $
    λ a, begin
      change option.elim (option.elim _ _ _) _ _ = _,
      rw [option.elim, part.elim_to_option],
      split_ifs,
      { refl },
      { exact eq.symm (of_not_not h) }
    end)

/-- Forgetting that maps are total and making them total again by adding a point is the same as just
adding a point. -/
@[simps] noncomputable def Type_to_PartialFun_iso_PartialFun_to_Pointed :
  Type_to_PartialFun ⋙ PartialFun_to_Pointed ≅ Type_to_Pointed :=
nat_iso.of_components (λ X, { hom := ⟨id, rfl⟩,
                              inv := ⟨id, rfl⟩,
                              hom_inv_id' := rfl,
                              inv_hom_id' := rfl }) $ λ X Y f,
  Pointed.hom.ext _ _ $ funext $ λ a, option.rec_on a rfl $ λ a, by convert part.some_to_option _