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

Outer measures -- overapproximations of measures
-/

import order.galois_connection algebra.big_operators algebra.module
       analysis.ennreal analysis.limits
       analysis.measure_theory.measurable_space

noncomputable theory

open set lattice finset function filter encodable
local attribute [instance] classical.prop_decidable

namespace measure_theory

structure outer_measure (α : Type*) :=
(measure_of : set α → ennreal)
(empty : measure_of ∅ = 0)
(mono : ∀{s₁ s₂}, s₁ ⊆ s₂ → measure_of s₁ ≤ measure_of s₂)
(Union_nat : ∀(s:ℕ → set α), measure_of (⋃i, s i) ≤ (∑i, measure_of (s i)))

namespace outer_measure

instance {α} : has_coe_to_fun (outer_measure α) := ⟨_, λ m, m.measure_of⟩

section basic
variables {α : Type*} {ms : set (outer_measure α)} {m : outer_measure α}

@[simp] theorem empty' (m : outer_measure α) : m ∅ = 0 := m.empty

theorem mono' (m : outer_measure α) {s₁ s₂}
  (h : s₁ ⊆ s₂) : m s₁ ≤ m s₂ := m.mono h

theorem Union_aux (m : set α → ennreal) (m0 : m ∅ = 0)
  {β} [encodable β] (s : β → set α) :
  (∑ b, m (s b)) = ∑ i, m (⋃ b ∈ decode2 β i, s b) :=
begin
  have H : ∀ n, m (⋃ b ∈ decode2 β n, s b) ≠ 0 → (decode2 β n).is_some,
  { intros n h,
    cases decode2 β n with b,
    { exact (h (by simp [m0])).elim },
    { exact rfl } },
  refine tsum_eq_tsum_of_ne_zero_bij (λ n h, option.get (H n h)) _ _ _,
  { intros m n hm hn e,
    have := mem_decode2.1 (option.get_mem (H n hn)),
    rwa [← e, mem_decode2.1 (option.get_mem (H m hm))] at this },
  { intros b h,
    refine ⟨encode b, _, _⟩,
    { convert h, simp [ext_iff, encodek2] },
    { exact option.get_of_mem _ (encodek2 _) } },
  { intros n h,
    transitivity, swap,
    rw [show decode2 β n = _, from option.get_mem (H n h)],
    congr, simp [ext_iff] }
end

protected theorem Union (m : outer_measure α)
  {β} [encodable β] (s : β → set α) :
  m (⋃i, s i) ≤ (∑i, m (s i)) :=
by rw [Union_decode2, Union_aux _ m.empty' s]; exact m.Union_nat _

lemma Union_null (m : outer_measure α)
  {β} [encodable β] {s : β → set α} (h : ∀ i, m (s i) = 0) : m (⋃i, s i) = 0 :=
by simpa [h] using m.Union s

protected lemma union (m : outer_measure α) (s₁ s₂ : set α) :
  m (s₁ ∪ s₂) ≤ m s₁ + m s₂ :=
begin
  convert m.Union (λ b, cond b s₁ s₂),
  { simp [union_eq_Union] },
  { rw tsum_fintype, change _ = _ + _, simp }
end

lemma union_null (m : outer_measure α) {s₁ s₂ : set α}
  (h₁ : m s₁ = 0) (h₂ : m s₂ = 0) : m (s₁ ∪ s₂) = 0 :=
by simpa [h₁, h₂] using m.union s₁ s₂

@[extensionality] lemma ext : ∀{μ₁ μ₂ : outer_measure α},
  (∀s, μ₁ s = μ₂ s) → μ₁ = μ₂
| ⟨m₁, e₁, _, u₁⟩ ⟨m₂, e₂, _, u₂⟩ h := by congr; exact funext h

instance : has_zero (outer_measure α) :=
⟨{ measure_of := λ_, 0,
   empty      := rfl,
   mono       := assume _ _ _, le_refl 0,
   Union_nat  := assume s, zero_le _ }⟩

@[simp] theorem zero_apply (s : set α) : (0 : outer_measure α) s = 0 := rfl

instance : inhabited (outer_measure α) := ⟨0⟩

instance : has_add (outer_measure α) :=
⟨λm₁ m₂,
  { measure_of := λs, m₁ s + m₂ s,
    empty      := show m₁ ∅ + m₂ ∅ = 0, by simp [outer_measure.empty],
    mono       := assume s₁ s₂ h, add_le_add' (m₁.mono h) (m₂.mono h),
    Union_nat  := assume s,
      calc m₁ (⋃i, s i) + m₂ (⋃i, s i) ≤
          (∑i, m₁ (s i)) + (∑i, m₂ (s i)) :
          add_le_add' (m₁.Union_nat s) (m₂.Union_nat s)
        ... = _ : ennreal.tsum_add.symm}⟩

@[simp] theorem add_apply (m₁ m₂ : outer_measure α) (s : set α) :
  (m₁ + m₂) s = m₁ s + m₂ s := rfl

instance : add_comm_monoid (outer_measure α) :=
{ zero      := 0,
  add       := (+),
  add_comm  := assume a b, ext $ assume s, add_comm _ _,
  add_assoc := assume a b c, ext $ assume s, add_assoc _ _ _,
  add_zero  := assume a, ext $ assume s, add_zero _,
  zero_add  := assume a, ext $ assume s, zero_add _ }

instance : has_bot (outer_measure α) := ⟨0⟩

instance outer_measure.order_bot : order_bot (outer_measure α) :=
{ le          := λm₁ m₂, ∀s, m₁ s ≤ m₂ s,
  bot         := 0,
  le_refl     := assume a s, le_refl _,
  le_trans    := assume a b c hab hbc s, le_trans (hab s) (hbc s),
  le_antisymm := assume a b hab hba, ext $ assume s, le_antisymm (hab s) (hba s),
  bot_le      := assume a s, zero_le _ }

section supremum

instance : has_Sup (outer_measure α) :=
⟨λms, {
  measure_of := λs, ⨆m:ms, m.val s,
  empty      := le_zero_iff_eq.1 $ supr_le $ λ ⟨m, h⟩, le_of_eq m.empty,
  mono       := assume s₁ s₂ hs, supr_le_supr $ assume ⟨m, hm⟩, m.mono hs,
  Union_nat  := assume f, supr_le $ assume m,
    calc m.val (⋃i, f i) ≤ (∑ (i : ℕ), m.val (f i)) : m.val.Union_nat _
      ... ≤ (∑i, ⨆m:ms, m.val (f i)) :
        ennreal.tsum_le_tsum $ assume i, le_supr (λm:ms, m.val (f i)) m }⟩

private lemma le_Sup (hm : m ∈ ms) : m ≤ Sup ms :=
λ s, le_supr (λm:ms, m.val s) ⟨m, hm⟩

private lemma Sup_le (hm : ∀m' ∈ ms, m' ≤ m) : Sup ms ≤ m :=
λ s, (supr_le $ assume ⟨m', h'⟩, (hm m' h') s)

instance : has_Inf (outer_measure α) := ⟨λs, Sup {m | ∀m'∈s, m ≤ m'}⟩
private lemma Inf_le (hm : m ∈ ms) : Inf ms ≤ m := Sup_le $ assume m' h', h' _ hm
private lemma le_Inf (hm : ∀m' ∈ ms, m ≤ m') : m ≤ Inf ms := le_Sup hm

instance : complete_lattice (outer_measure α) :=
{ top          := Sup univ,
  le_top       := assume a, le_Sup (mem_univ a),
  Sup          := Sup,
  Sup_le       := assume s m, Sup_le,
  le_Sup       := assume s m, le_Sup,
  Inf          := Inf,
  Inf_le       := assume s m, Inf_le,
  le_Inf       := assume s m, le_Inf,
  sup          := λa b, Sup {a, b},
  le_sup_left  := assume a b, le_Sup $ by simp,
  le_sup_right := assume a b, le_Sup $ by simp,
  sup_le       := assume a b c ha hb, Sup_le $ by simp [or_imp_distrib, ha, hb] {contextual:=tt},
  inf          := λa b, Inf {a, b},
  inf_le_left  := assume a b, Inf_le $ by simp,
  inf_le_right := assume a b, Inf_le $ by simp,
  le_inf       := assume a b c ha hb, le_Inf $ by simp [or_imp_distrib, ha, hb] {contextual:=tt},
  .. outer_measure.order_bot }

@[simp] theorem Sup_apply (ms : set (outer_measure α)) (s : set α) :
  (Sup ms) s = ⨆ m : ms, m s := rfl

@[simp] theorem supr_apply {ι} (f : ι → outer_measure α) (s : set α) :
  (⨆ i : ι, f i) s = ⨆ i, f i s :=
le_antisymm
  (supr_le $ λ ⟨_, i, rfl⟩, le_supr _ i)
  (supr_le $ λ i, le_supr
    (λ (m : {a : outer_measure α // ∃ i, a = f i}), m.1 s)
    ⟨f i, i, rfl⟩)

@[simp] theorem sup_apply (m₁ m₂ : outer_measure α) (s : set α) :
  (m₁ ⊔ m₂) s = m₁ s ⊔ m₂ s :=
by have := supr_apply (λ b, cond b m₁ m₂) s;
  rwa [supr_bool_eq, supr_bool_eq] at this

end supremum

def map {β} (f : α → β) (m : outer_measure α) : outer_measure β :=
{ measure_of := λs, m (f ⁻¹' s),
  empty := m.empty,
  mono := λ s t h, m.mono (preimage_mono h),
  Union_nat := λ s, by rw [preimage_Union]; exact
    m.Union_nat (λ i, f ⁻¹' s i) }

@[simp] theorem map_apply {β} (f : α → β)
  (m : outer_measure α) (s : set β) : map f m s = m (f ⁻¹' s) := rfl

@[simp] theorem map_id (m : outer_measure α) : map id m = m :=
ext $ λ s, rfl

@[simp] theorem map_map {β γ} (f : α → β) (g : β → γ)
  (m : outer_measure α) : map g (map f m) = map (g ∘ f) m :=
ext $ λ s, rfl

instance : functor outer_measure := {map := λ α β, map}

instance : is_lawful_functor outer_measure :=
{ id_map := λ α, map_id,
  comp_map := λ α β γ f g m, (map_map f g m).symm }

/-- The dirac outer measure. -/
def dirac (a : α) : outer_measure α :=
{ measure_of := λs, ⨆ h : a ∈ s, 1,
  empty := by simp,
  mono := λ s t h, supr_le_supr2 (λ h', ⟨h h', le_refl _⟩),
  Union_nat := λ s, supr_le $ λ h,
    let ⟨i, h⟩ := mem_Union.1 h in
    le_trans (by exact le_supr _ h) (ennreal.le_tsum i) }

@[simp] theorem dirac_apply (a : α) (s : set α) :
  dirac a s = ⨆ h : a ∈ s, 1 := rfl

def sum {ι} (f : ι → outer_measure α) : outer_measure α :=
{ measure_of := λs, ∑ i, f i s,
  empty := by simp,
  mono := λ s t h, ennreal.tsum_le_tsum (λ i, (f i).mono' h),
  Union_nat := λ s, by rw ennreal.tsum_comm; exact
    ennreal.tsum_le_tsum (λ i, (f i).Union_nat _) }

@[simp] theorem sum_apply {ι} (f : ι → outer_measure α) (s : set α) :
  sum f s = ∑ i, f i s := rfl

instance : has_scalar ennreal (outer_measure α) :=
⟨λ a m, {
  measure_of := λs, a * m s,
  empty := by simp,
  mono := λ s t h, canonically_ordered_semiring.mul_le_mul (le_refl _) (m.mono' h),
  Union_nat := λ s, by rw ennreal.mul_tsum; exact
    canonically_ordered_semiring.mul_le_mul (le_refl _) (m.Union_nat _) }⟩

@[simp] theorem smul_apply (a : ennreal) (m : outer_measure α) (s : set α) :
  (a • m) s = a * m s := rfl

instance : semimodule ennreal (outer_measure α) :=
{ smul_add := λ a m₁ m₂, ext $ λ s, mul_add _ _ _,
  add_smul := λ a b m, ext $ λ s, add_mul _ _ _,
  mul_smul := λ a b m, ext $ λ s, mul_assoc _ _ _,
  one_smul := λ m, ext $ λ s, one_mul _,
  zero_smul := λ m, ext $ λ s, zero_mul _,
  smul_zero := λ a, ext $ λ s, mul_zero _,
  ..outer_measure.has_scalar }

theorem smul_dirac_apply (a : ennreal) (b : α) (s : set α) :
  (a • dirac b) s = ⨆ h : b ∈ s, a :=
by by_cases b ∈ s; simp [h]

theorem top_apply {s : set α} (h : s ≠ ∅) : (⊤ : outer_measure α) s = ⊤ :=
let ⟨a, as⟩ := set.exists_mem_of_ne_empty h in
top_unique $ le_supr_of_le ⟨⊤ • dirac a, trivial⟩ $
by simp [smul_dirac_apply, as]

end basic

section of_function
set_option eqn_compiler.zeta true

/-- Given any function `m` assigning measures to sets satisying `m ∅ = 0`, there is
  a unique maximal outer measure `μ` satisfying `μ s ≤ m s` for all `s : set α`. -/
protected def of_function {α : Type*} (m : set α → ennreal) (m_empty : m ∅ = 0) :
  outer_measure α :=
let μ := λs, ⨅{f : ℕ → set α} (h : s ⊆ ⋃i, f i), ∑i, m (f i) in
{ measure_of := μ,
  empty      := le_antisymm
    (infi_le_of_le (λ_, ∅) $ infi_le_of_le (empty_subset _) $ by simp [m_empty])
    (zero_le _),
  mono       := assume s₁ s₂ hs, infi_le_infi $ assume f,
    infi_le_infi2 $ assume hb, ⟨subset.trans hs hb, le_refl _⟩,
  Union_nat := assume s, ennreal.le_of_forall_epsilon_le $ begin
    assume ε hε (hb : (∑i, μ (s i)) < ⊤),
    rcases ennreal.exists_pos_sum_of_encodable (ennreal.coe_lt_coe.2 hε) ℕ with ⟨ε', hε', hl⟩,
    refine le_trans _ (add_le_add_left' (le_of_lt hl)),
    rw ← ennreal.tsum_add,
    have : ∀i, ∃f:ℕ → set α, s i ⊆ (⋃i, f i) ∧ (∑i, m (f i)) < μ (s i) + ε' i,
    { intro,
      have : μ (s i) < μ (s i) + ε' i :=
        ennreal.lt_add_right
          (lt_of_le_of_lt (by apply ennreal.le_tsum) hb)
          (by simpa using hε' i),
      simpa [μ, infi_lt_iff] },
    cases classical.axiom_of_choice this with f hf,
    dsimp at f hf, clear this,
    refine le_trans _ (ennreal.tsum_le_tsum $ λ i, le_of_lt (hf i).2),
    rw [← ennreal.tsum_prod, ← tsum_equiv equiv.nat_prod_nat_equiv_nat.symm],
    swap, {apply_instance},
    refine infi_le_of_le _ (infi_le _ _),
    exact Union_subset (λ i, subset.trans (hf i).1 $
      Union_subset $ λ j, subset.trans (by simp) $
      subset_Union _ $ equiv.nat_prod_nat_equiv_nat (i, j)),
  end }

theorem of_function_le {α : Type*} (m : set α → ennreal) (m_empty s) :
  outer_measure.of_function m m_empty s ≤ m s :=
let f : ℕ → set α := λi, nat.rec_on i s (λn s, ∅) in
infi_le_of_le f $ infi_le_of_le (subset_Union f 0) $ le_of_eq $
calc (∑i, m (f i)) = ({0} : finset ℕ).sum (λi, m (f i)) :
    tsum_eq_sum $ by intro i; cases i; simp [m_empty]
  ... = m s : by simp; refl

theorem le_of_function {α : Type*} {m m_empty} {μ : outer_measure α} :
  μ ≤ outer_measure.of_function m m_empty ↔ ∀ s, μ s ≤ m s :=
⟨λ H s, le_trans (H _) (of_function_le _ _ _),
 λ H s, le_infi $ λ f, le_infi $ λ hs,
  le_trans (μ.mono hs) $ le_trans (μ.Union f) $
  ennreal.tsum_le_tsum $ λ i, H _⟩

end of_function

section caratheodory_measurable
universe u
parameters {α : Type u} (m : outer_measure α)
include m

local attribute [simp] set.inter_comm set.inter_left_comm set.inter_assoc

variables {s s₁ s₂ : set α}

private def C (s : set α) := ∀t, m t = m (t ∩ s) + m (t \ s)

private lemma C_iff_le {s : set α} : C s ↔ ∀t, m (t ∩ s) + m (t \ s) ≤ m t :=
forall_congr $ λ t, le_antisymm_iff.trans $ and_iff_right $
by convert m.union _ _; rw inter_union_diff t s

@[simp] private lemma C_empty : C ∅ := by simp [C, m.empty, diff_empty]

private lemma C_compl : C s₁ → C (- s₁) := by simp [C, diff_eq]

@[simp] private lemma C_compl_iff : C (- s) ↔ C s :=
⟨λ h, by simpa using C_compl m h, C_compl⟩

private lemma C_union (h₁ : C s₁) (h₂ : C s₂) : C (s₁ ∪ s₂) :=
λ t, begin
  rw [h₁ t, h₂ (t ∩ s₁), h₂ (t \ s₁), h₁ (t ∩ (s₁ ∪ s₂)),
    inter_diff_assoc _ _ s₁, set.inter_assoc _ _ s₁,
    inter_eq_self_of_subset_right (set.subset_union_left _ _),
    union_diff_left, h₂ (t ∩ s₁)],
  simp [diff_eq]
end

private lemma measure_inter_union (h : s₁ ∩ s₂ ⊆ ∅) (h₁ : C s₁) {t : set α} :
  m (t ∩ (s₁ ∪ s₂)) = m (t ∩ s₁) + m (t ∩ s₂) :=
by rw [h₁, set.inter_assoc, union_inter_cancel_left h,
  inter_diff_assoc, union_diff_cancel_left h]

private lemma C_Union_lt {s : ℕ → set α} : ∀{n:ℕ}, (∀i<n, C (s i)) → C (⋃i<n, s i)
| 0       h := by simp [nat.not_lt_zero]
| (n + 1) h := by rw Union_lt_succ; exact C_union m
  (h n (le_refl (n + 1)))
      (C_Union_lt $ assume i hi, h i $ lt_of_lt_of_le hi $ nat.le_succ _)

private lemma C_inter (h₁ : C s₁) (h₂ : C s₂) : C (s₁ ∩ s₂) :=
by rw [← C_compl_iff, compl_inter]; from C_union _ (C_compl _ h₁) (C_compl _ h₂)

private lemma C_sum {s : ℕ → set α} (h : ∀i, C (s i)) (hd : pairwise (disjoint on s)) {t : set α} :
  ∀ {n}, (finset.range n).sum (λi, m (t ∩ s i)) = m (t ∩ ⋃i<n, s i)
| 0            := by simp [nat.not_lt_zero, m.empty]
| (nat.succ n) := begin
  simp [Union_lt_succ],
  rw [measure_inter_union m _ (h n), C_sum],
  intro a, simpa using λ h₁ i hi h₂, hd _ _ (ne_of_gt hi) ⟨h₁, h₂⟩
end

private lemma C_Union_nat {s : ℕ → set α} (h : ∀i, C (s i))
  (hd : pairwise (disjoint on s)) : C (⋃i, s i) :=
C_iff_le.2 $ λ t, begin
  have hp : m (t ∩ ⋃i, s i) ≤ (⨆n, m (t ∩ ⋃i<n, s i)),
  { convert m.Union (λ i, t ∩ s i),
    { rw inter_Union_left },
    { simp [ennreal.tsum_eq_supr_nat, C_sum m h hd] } },
  refine le_trans (add_le_add_right' hp) _,
  rw ennreal.supr_add,
  refine supr_le (λ n, le_trans (add_le_add_left' _)
    (ge_of_eq (C_Union_lt m (λ i _, h i) _))),
  refine m.mono (diff_subset_diff_right _),
  exact bUnion_subset (λ i _, subset_Union _ i),
end

private lemma f_Union {s : ℕ → set α} (h : ∀i, C (s i))
  (hd : pairwise (disjoint on s)) : m (⋃i, s i) = ∑i, m (s i) :=
begin
  refine le_antisymm (m.Union_nat s) _,
  rw ennreal.tsum_eq_supr_nat,
  refine supr_le (λ n, _),
  have := @C_sum _ m _ h hd univ n,
  simp at this, simp [this],
  exact m.mono (bUnion_subset (λ i _, subset_Union _ i)),
end

private def caratheodory_dynkin : measurable_space.dynkin_system α :=
{ has := C,
  has_empty := C_empty,
  has_compl := assume s, C_compl,
  has_Union_nat := assume f hf hn, C_Union_nat hn hf }

/-- Given an outer measure `μ`, the Caratheodory measurable space is
  defined such that `s` is measurable if `∀t, μ t = μ (t ∩ s) + μ (t \ s)`. -/
protected def caratheodory : measurable_space α :=
caratheodory_dynkin.to_measurable_space $ assume s₁ s₂, C_inter

lemma is_caratheodory {s : set α} :
  caratheodory.is_measurable s ↔ ∀t, m t = m (t ∩ s) + m (t \ s) :=
iff.rfl

lemma is_caratheodory_le {s : set α} :
  caratheodory.is_measurable s ↔ ∀t, m (t ∩ s) + m (t \ s) ≤ m t :=
C_iff_le

protected lemma Union_eq_of_caratheodory {s : ℕ → set α}
  (h : ∀i, caratheodory.is_measurable (s i)) (hd : pairwise (disjoint on s)) :
  m (⋃i, s i) = ∑i, m (s i) :=
f_Union h hd

end caratheodory_measurable

variables {α : Type*}

lemma caratheodory_is_measurable {m : set α → ennreal} {s : set α}
  {h₀ : m ∅ = 0} (hs : ∀t, m (t ∩ s) + m (t \ s) ≤ m t) :
  (outer_measure.of_function m h₀).caratheodory.is_measurable s :=
let o := (outer_measure.of_function m h₀) in
(is_caratheodory_le o).2 $ λ t,
le_infi $ λ f, le_infi $ λ hf, begin
  refine le_trans (add_le_add'
    (infi_le_of_le (λi, f i ∩ s) $ infi_le _ _)
    (infi_le_of_le (λi, f i \ s) $ infi_le _ _)) _,
  { rw ← inter_Union_right,
    exact inter_subset_inter_left _ hf },
  { rw ← diff_Union_right,
    exact diff_subset_diff_left hf },
  { rw ← ennreal.tsum_add,
    exact ennreal.tsum_le_tsum (λ i, hs _) }
end

@[simp] theorem zero_caratheodory : (0 : outer_measure α).caratheodory = ⊤ :=
top_unique $ λ s _ t, (add_zero _).symm

theorem le_add_caratheodory (m₁ m₂ : outer_measure α) :
  m₁.caratheodory ⊓ m₂.caratheodory ≤ (m₁ + m₂ : outer_measure α).caratheodory :=
λ s ⟨hs₁, hs₂⟩ t, by simp [hs₁ t, hs₂ t]

theorem le_sum_caratheodory {ι} (m : ι → outer_measure α) :
  (⨅ i, (m i).caratheodory) ≤ (sum m).caratheodory :=
λ s h t, by simp [λ i,
  measurable_space.is_measurable_infi.1 h i t, ennreal.tsum_add]

theorem le_smul_caratheodory (a : ennreal) (m : outer_measure α) :
  m.caratheodory ≤ (a • m).caratheodory :=
λ s h t, by simp [h t, mul_add]

@[simp] theorem dirac_caratheodory (a : α) : (dirac a).caratheodory = ⊤ :=
top_unique $ λ s _ t, begin
  by_cases a ∈ t; simp [h],
  by_cases a ∈ s; simp [h]
end

end outer_measure

end measure_theory


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Tim Baumann, Stephen Morgan, Scott Morrison, Floris van Doorn
-/
import category_theory.functor

/-!
# Isomorphisms

This file defines isomorphisms between objects of a category.

## Main definitions

- `structure iso` : a bundled isomorphism between two objects of a category;
- `class is_iso` : an unbundled version of `iso`;
  note that `is_iso f` is a `Prop`, and only asserts the existence of an inverse.
  Of course, this inverse is unique, so it doesn't cost us much to use choice to retrieve it.
- `inv f`, for the inverse of a morphism with `[is_iso f]`
- `as_iso` : convert from `is_iso` to `iso` (noncomputable);
- `of_iso` : convert from `iso` to `is_iso`;
- standard operations on isomorphisms (composition, inverse etc)

## Notations

- `X ≅ Y` : same as `iso X Y`;
- `α ≪≫ β` : composition of two isomorphisms; it is called `iso.trans`

## Tags

category, category theory, isomorphism
-/

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

namespace category_theory
open category

/--
An isomorphism (a.k.a. an invertible morphism) between two objects of a category.
The inverse morphism is bundled.

See also `category_theory.core` for the category with the same objects and isomorphisms playing
the role of morphisms.

See <https://stacks.math.columbia.edu/tag/0017>.
-/
structure iso {C : Type u} [category.{v} C] (X Y : C) :=
(hom : X ⟶ Y)
(inv : Y ⟶ X)
(hom_inv_id' : hom ≫ inv = 𝟙 X . obviously)
(inv_hom_id' : inv ≫ hom = 𝟙 Y . obviously)

restate_axiom iso.hom_inv_id'
restate_axiom iso.inv_hom_id'
attribute [simp, reassoc] iso.hom_inv_id iso.inv_hom_id

infixr ` ≅ `:10  := iso             -- type as \cong or \iso

variables {C : Type u} [category.{v} C]
variables {X Y Z : C}

namespace iso

@[ext] lemma ext ⦃α β : X ≅ Y⦄ (w : α.hom = β.hom) : α = β :=
suffices α.inv = β.inv, by cases α; cases β; cc,
calc α.inv
    = α.inv ≫ (β.hom ≫ β.inv) : by rw [iso.hom_inv_id, category.comp_id]
... = (α.inv ≫ α.hom) ≫ β.inv : by rw [category.assoc, ←w]
... = β.inv                   : by rw [iso.inv_hom_id, category.id_comp]

/-- Inverse isomorphism. -/
@[symm] def symm (I : X ≅ Y) : Y ≅ X :=
{ hom := I.inv,
  inv := I.hom,
  hom_inv_id' := I.inv_hom_id',
  inv_hom_id' := I.hom_inv_id' }

@[simp] lemma symm_hom (α : X ≅ Y) : α.symm.hom = α.inv := rfl
@[simp] lemma symm_inv (α : X ≅ Y) : α.symm.inv = α.hom := rfl

@[simp] lemma symm_mk {X Y : C} (hom : X ⟶ Y) (inv : Y ⟶ X) (hom_inv_id) (inv_hom_id) :
  iso.symm {hom := hom, inv := inv, hom_inv_id' := hom_inv_id, inv_hom_id' := inv_hom_id} =
    {hom := inv, inv := hom, hom_inv_id' := inv_hom_id, inv_hom_id' := hom_inv_id} := rfl

@[simp] lemma symm_symm_eq {X Y : C} (α : X ≅ Y) : α.symm.symm = α :=
by cases α; refl

@[simp] lemma symm_eq_iff {X Y : C} {α β : X ≅ Y} : α.symm = β.symm ↔ α = β :=
⟨λ h, symm_symm_eq α ▸ symm_symm_eq β ▸ congr_arg symm h, congr_arg symm⟩

/-- Identity isomorphism. -/
@[refl, simps] def refl (X : C) : X ≅ X :=
{ hom := 𝟙 X,
  inv := 𝟙 X }

instance : inhabited (X ≅ X) := ⟨iso.refl X⟩

@[simp] lemma refl_symm (X : C) : (iso.refl X).symm = iso.refl X := rfl

/-- Composition of two isomorphisms -/
@[trans, simps] def trans (α : X ≅ Y) (β : Y ≅ Z) : X ≅ Z :=
{ hom := α.hom ≫ β.hom,
  inv := β.inv ≫ α.inv }

infixr ` ≪≫ `:80 := iso.trans -- type as `\ll \gg`.

@[simp] lemma trans_mk {X Y Z : C}
  (hom : X ⟶ Y) (inv : Y ⟶ X) (hom_inv_id) (inv_hom_id)
  (hom' : Y ⟶ Z) (inv' : Z ⟶ Y) (hom_inv_id') (inv_hom_id') (hom_inv_id'') (inv_hom_id'') :
  iso.trans
    {hom := hom, inv := inv, hom_inv_id' := hom_inv_id, inv_hom_id' := inv_hom_id}
    {hom := hom', inv := inv', hom_inv_id' := hom_inv_id', inv_hom_id' := inv_hom_id'} =
  { hom := hom ≫ hom', inv := inv' ≫ inv, hom_inv_id' := hom_inv_id'',
    inv_hom_id' := inv_hom_id''} :=
rfl

@[simp] lemma trans_symm (α : X ≅ Y) (β : Y ≅ Z) : (α ≪≫ β).symm = β.symm ≪≫ α.symm := rfl
@[simp] lemma trans_assoc {Z' : C} (α : X ≅ Y) (β : Y ≅ Z) (γ : Z ≅ Z') :
  (α ≪≫ β) ≪≫ γ = α ≪≫ β ≪≫ γ :=
by ext; simp only [trans_hom, category.assoc]

@[simp] lemma refl_trans (α : X ≅ Y) : (iso.refl X) ≪≫ α = α := by ext; apply category.id_comp
@[simp] lemma trans_refl (α : X ≅ Y) : α ≪≫ (iso.refl Y) = α := by ext; apply category.comp_id

@[simp] lemma symm_self_id (α : X ≅ Y) : α.symm ≪≫ α = iso.refl Y := ext α.inv_hom_id
@[simp] lemma self_symm_id (α : X ≅ Y) : α ≪≫ α.symm = iso.refl X := ext α.hom_inv_id

@[simp] lemma symm_self_id_assoc (α : X ≅ Y) (β : Y ≅ Z) : α.symm ≪≫ α ≪≫ β = β :=
by rw [← trans_assoc, symm_self_id, refl_trans]

@[simp] lemma self_symm_id_assoc (α : X ≅ Y) (β : X ≅ Z) : α ≪≫ α.symm ≪≫ β = β :=
by rw [← trans_assoc, self_symm_id, refl_trans]

lemma inv_comp_eq (α : X ≅ Y) {f : X ⟶ Z} {g : Y ⟶ Z} : α.inv ≫ f = g ↔ f = α.hom ≫ g :=
⟨λ H, by simp [H.symm], λ H, by simp [H]⟩

lemma eq_inv_comp (α : X ≅ Y) {f : X ⟶ Z} {g : Y ⟶ Z} : g = α.inv ≫ f ↔ α.hom ≫ g = f :=
(inv_comp_eq α.symm).symm

lemma comp_inv_eq (α : X ≅ Y) {f : Z ⟶ Y} {g : Z ⟶ X} : f ≫ α.inv = g ↔ f = g ≫ α.hom :=
⟨λ H, by simp [H.symm], λ H, by simp [H]⟩

lemma eq_comp_inv (α : X ≅ Y) {f : Z ⟶ Y} {g : Z ⟶ X} : g = f ≫ α.inv ↔ g ≫ α.hom = f :=
(comp_inv_eq α.symm).symm

lemma inv_eq_inv (f g : X ≅ Y) : f.inv = g.inv ↔ f.hom = g.hom :=
have ∀{X Y : C} (f g : X ≅ Y), f.hom = g.hom → f.inv = g.inv, from λ X Y f g h, by rw [ext h],
⟨this f.symm g.symm, this f g⟩

lemma hom_comp_eq_id (α : X ≅ Y) {f : Y ⟶ X} : α.hom ≫ f = 𝟙 X ↔ f = α.inv :=
by rw [←eq_inv_comp, comp_id]

lemma comp_hom_eq_id (α : X ≅ Y) {f : Y ⟶ X} : f ≫ α.hom = 𝟙 Y ↔ f = α.inv :=
by rw [←eq_comp_inv, id_comp]

lemma inv_comp_eq_id (α : X ≅ Y) {f : X ⟶ Y} : α.inv ≫ f = 𝟙 Y ↔ f = α.hom :=
hom_comp_eq_id α.symm

lemma comp_inv_eq_id (α : X ≅ Y) {f : X ⟶ Y} : f ≫ α.inv = 𝟙 X ↔ f = α.hom :=
comp_hom_eq_id α.symm

lemma hom_eq_inv (α : X ≅ Y) (β : Y ≅ X) : α.hom = β.inv ↔ β.hom = α.inv :=
by { erw [inv_eq_inv α.symm β, eq_comm], refl }

end iso

/-- `is_iso` typeclass expressing that a morphism is invertible. -/
class is_iso (f : X ⟶ Y) : Prop :=
(out : ∃ inv : Y ⟶ X, f ≫ inv = 𝟙 X ∧ inv ≫ f = 𝟙 Y)

/--
The inverse of a morphism `f` when we have `[is_iso f]`.
-/
noncomputable def inv (f : X ⟶ Y) [I : is_iso f] := classical.some I.1

namespace is_iso

@[simp, reassoc] lemma hom_inv_id (f : X ⟶ Y) [I : is_iso f] : f ≫ inv f = 𝟙 X :=
(classical.some_spec I.1).left
@[simp, reassoc] lemma inv_hom_id (f : X ⟶ Y) [I : is_iso f] : inv f ≫ f = 𝟙 Y :=
(classical.some_spec I.1).right

end is_iso

open is_iso

/-- Reinterpret a morphism `f` with an `is_iso f` instance as an `iso`. -/
noncomputable
def as_iso (f : X ⟶ Y) [h : is_iso f] : X ≅ Y := ⟨f, inv f, hom_inv_id f, inv_hom_id f⟩

@[simp] lemma as_iso_hom (f : X ⟶ Y) [is_iso f] : (as_iso f).hom = f := rfl
@[simp] lemma as_iso_inv (f : X ⟶ Y) [is_iso f] : (as_iso f).inv = inv f := rfl

namespace is_iso

@[priority 100] -- see Note [lower instance priority]
instance epi_of_iso (f : X ⟶ Y) [is_iso f] : epi f  :=
{ left_cancellation := λ Z g h w,
  -- This is an interesting test case for better rewrite automation.
  by rw [← is_iso.inv_hom_id_assoc f g, w, is_iso.inv_hom_id_assoc f h] }
@[priority 100] -- see Note [lower instance priority]
instance mono_of_iso (f : X ⟶ Y) [is_iso f] : mono f :=
{ right_cancellation := λ Z g h w,
  by rw [← category.comp_id g, ← category.comp_id h, ← is_iso.hom_inv_id f, ← category.assoc, w,
    ← category.assoc] }

@[ext] lemma inv_eq_of_hom_inv_id {f : X ⟶ Y} [is_iso f] {g : Y ⟶ X}
  (hom_inv_id : f ≫ g = 𝟙 X) : inv f = g :=
begin
  apply (cancel_epi f).mp,
  simp [hom_inv_id],
end

lemma inv_eq_of_inv_hom_id {f : X ⟶ Y} [is_iso f] {g : Y ⟶ X}
  (inv_hom_id : g ≫ f = 𝟙 Y) : inv f = g :=
begin
  apply (cancel_mono f).mp,
  simp [inv_hom_id],
end

@[ext] lemma eq_inv_of_hom_inv_id {f : X ⟶ Y} [is_iso f] {g : Y ⟶ X}
  (hom_inv_id : f ≫ g = 𝟙 X) : g = inv f :=
(inv_eq_of_hom_inv_id hom_inv_id).symm

lemma eq_inv_of_inv_hom_id {f : X ⟶ Y} [is_iso f] {g : Y ⟶ X}
  (inv_hom_id : g ≫ f = 𝟙 Y) : g = inv f :=
(inv_eq_of_inv_hom_id inv_hom_id).symm

instance id (X : C) : is_iso (𝟙 X) :=
⟨⟨𝟙 X, by simp⟩⟩

instance of_iso (f : X ≅ Y) : is_iso f.hom :=
⟨⟨f.inv, by simp⟩⟩

instance of_iso_inv (f : X ≅ Y) : is_iso f.inv :=
is_iso.of_iso f.symm

variables {f g : X ⟶ Y} {h : Y ⟶ Z}

instance inv_is_iso [is_iso f] : is_iso (inv f) :=
is_iso.of_iso_inv (as_iso f)

/- The following instance has lower priority for the following reason:
Suppose we are given `f : X ≅ Y` with `X Y : Type u`.
Without the lower priority, typeclass inference cannot deduce `is_iso f.hom`
because `f.hom` is defeq to `(λ x, x) ≫ f.hom`, triggering a loop. -/
@[priority 900]
instance comp_is_iso [is_iso f] [is_iso h] : is_iso (f ≫ h) :=
is_iso.of_iso $ (as_iso f) ≪≫ (as_iso h)

@[simp] lemma inv_id : inv (𝟙 X) = 𝟙 X := by { ext, simp, }
@[simp] lemma inv_comp [is_iso f] [is_iso h] : inv (f ≫ h) = inv h ≫ inv f := by { ext, simp, }
@[simp] lemma inv_inv [is_iso f] : inv (inv f) = f := by { ext, simp, }
@[simp] lemma iso.inv_inv (f : X ≅ Y) : inv (f.inv) = f.hom := by { ext, simp, }
@[simp] lemma iso.inv_hom (f : X ≅ Y) : inv (f.hom) = f.inv := by { ext, simp, }

@[simp]
lemma inv_comp_eq (α : X ⟶ Y) [is_iso α] {f : X ⟶ Z} {g : Y ⟶ Z} : inv α ≫ f = g ↔ f = α ≫ g :=
(as_iso α).inv_comp_eq

@[simp]
lemma eq_inv_comp (α : X ⟶ Y) [is_iso α] {f : X ⟶ Z} {g : Y ⟶ Z} : g = inv α ≫ f ↔ α ≫ g = f :=
(as_iso α).eq_inv_comp

@[simp]
lemma comp_inv_eq (α : X ⟶ Y) [is_iso α] {f : Z ⟶ Y} {g : Z ⟶ X} : f ≫ inv α = g ↔ f = g ≫ α :=
(as_iso α).comp_inv_eq

@[simp]
lemma eq_comp_inv (α : X ⟶ Y) [is_iso α] {f : Z ⟶ Y} {g : Z ⟶ X} : g = f ≫ inv α ↔ g ≫ α = f :=
(as_iso α).eq_comp_inv

lemma of_is_iso_comp_left {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z)
  [is_iso f] [is_iso (f ≫ g)] : is_iso g :=
by { rw [← id_comp g, ← inv_hom_id f, assoc], apply_instance, }

lemma of_is_iso_comp_right {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z)
  [is_iso g] [is_iso (f ≫ g)] : is_iso f :=
by { rw [← comp_id f, ← hom_inv_id g, ← assoc], apply_instance, }

lemma of_is_iso_fac_left {X Y Z : C} {f : X ⟶ Y} {g : Y ⟶ Z} {h : X ⟶ Z}
  [is_iso f] [hh : is_iso h] (w : f ≫ g = h) : is_iso g :=
by { rw ← w at hh, haveI := hh, exact of_is_iso_comp_left f g, }

lemma of_is_iso_fac_right {X Y Z : C} {f : X ⟶ Y} {g : Y ⟶ Z} {h : X ⟶ Z}
  [is_iso g] [hh : is_iso h] (w : f ≫ g = h) : is_iso f :=
by { rw ← w at hh, haveI := hh, exact of_is_iso_comp_right f g, }

end is_iso

open is_iso

lemma eq_of_inv_eq_inv {f g : X ⟶ Y} [is_iso f] [is_iso g] (p : inv f = inv g) : f = g :=
begin
  apply (cancel_epi (inv f)).1,
  erw [inv_hom_id, p, inv_hom_id],
end

lemma is_iso.inv_eq_inv {f g : X ⟶ Y} [is_iso f] [is_iso g] : inv f = inv g ↔ f = g :=
iso.inv_eq_inv (as_iso f) (as_iso g)

lemma hom_comp_eq_id (g : X ⟶ Y) [is_iso g] {f : Y ⟶ X} : g ≫ f = 𝟙 X ↔ f = inv g :=
(as_iso g).hom_comp_eq_id

lemma comp_hom_eq_id (g : X ⟶ Y) [is_iso g] {f : Y ⟶ X} : f ≫ g = 𝟙 Y ↔ f = inv g :=
(as_iso g).comp_hom_eq_id

lemma inv_comp_eq_id (g : X ⟶ Y) [is_iso g] {f : X ⟶ Y} : inv g ≫ f = 𝟙 Y ↔ f = g :=
(as_iso g).inv_comp_eq_id

lemma comp_inv_eq_id (g : X ⟶ Y) [is_iso g] {f : X ⟶ Y} : f ≫ inv g = 𝟙 X ↔ f = g :=
(as_iso g).comp_inv_eq_id

lemma is_iso_of_hom_comp_eq_id (g : X ⟶ Y) [is_iso g] {f : Y ⟶ X} (h : g ≫ f = 𝟙 X) : is_iso f :=
by { rw [(hom_comp_eq_id _).mp h], apply_instance }

lemma is_iso_of_comp_hom_eq_id (g : X ⟶ Y) [is_iso g] {f : Y ⟶ X} (h : f ≫ g = 𝟙 Y) : is_iso f :=
by { rw [(comp_hom_eq_id _).mp h], apply_instance }

namespace iso

@[ext] lemma inv_ext {f : X ≅ Y} {g : Y ⟶ X}
  (hom_inv_id : f.hom ≫ g = 𝟙 X) : f.inv = g :=
((hom_comp_eq_id f).1 hom_inv_id).symm

@[ext] lemma inv_ext' {f : X ≅ Y} {g : Y ⟶ X}
  (hom_inv_id : f.hom ≫ g = 𝟙 X) : g = f.inv :=
(hom_comp_eq_id f).1 hom_inv_id

/-!
All these cancellation lemmas can be solved by `simp [cancel_mono]` (or `simp [cancel_epi]`),
but with the current design `cancel_mono` is not a good `simp` lemma,
because it generates a typeclass search.

When we can see syntactically that a morphism is a `mono` or an `epi`
because it came from an isomorphism, it's fine to do the cancellation via `simp`.

In the longer term, it might be worth exploring making `mono` and `epi` structures,
rather than typeclasses, with coercions back to `X ⟶ Y`.
Presumably we could write `X ↪ Y` and `X ↠ Y`.
-/

@[simp] lemma cancel_iso_hom_left {X Y Z : C} (f : X ≅ Y) (g g' : Y ⟶ Z) :
  f.hom ≫ g = f.hom ≫ g' ↔ g = g' :=
by simp only [cancel_epi]

@[simp] lemma cancel_iso_inv_left {X Y Z : C} (f : Y ≅ X) (g g' : Y ⟶ Z) :
  f.inv ≫ g = f.inv ≫ g' ↔ g = g' :=
by simp only [cancel_epi]

@[simp] lemma cancel_iso_hom_right {X Y Z : C} (f f' : X ⟶ Y) (g : Y ≅ Z) :
  f ≫ g.hom = f' ≫ g.hom ↔ f = f' :=
by simp only [cancel_mono]

@[simp] lemma cancel_iso_inv_right {X Y Z : C} (f f' : X ⟶ Y) (g : Z ≅ Y) :
  f ≫ g.inv = f' ≫ g.inv ↔ f = f' :=
by simp only [cancel_mono]

/-
Unfortunately cancelling an isomorphism from the right of a chain of compositions is awkward.
We would need separate lemmas for each chain length (worse: for each pair of chain lengths).

We provide two more lemmas, for case of three morphisms, because this actually comes up in practice,
but then stop.
-/

@[simp] lemma cancel_iso_hom_right_assoc {W X X' Y Z : C}
  (f : W ⟶ X) (g : X ⟶ Y) (f' : W ⟶ X') (g' : X' ⟶ Y)
  (h : Y ≅ Z) :
  f ≫ g ≫ h.hom = f' ≫ g' ≫ h.hom ↔ f ≫ g = f' ≫ g' :=
by simp only [←category.assoc, cancel_mono]

@[simp] lemma cancel_iso_inv_right_assoc {W X X' Y Z : C}
  (f : W ⟶ X) (g : X ⟶ Y) (f' : W ⟶ X') (g' : X' ⟶ Y)
  (h : Z ≅ Y) :
  f ≫ g ≫ h.inv = f' ≫ g' ≫ h.inv ↔ f ≫ g = f' ≫ g' :=
by simp only [←category.assoc, cancel_mono]

end iso

namespace functor

universes u₁ v₁ u₂ v₂
variables {D : Type u₂}

variables [category.{v₂} D]

/-- A functor `F : C ⥤ D` sends isomorphisms `i : X ≅ Y` to isomorphisms `F.obj X ≅ F.obj Y` -/
@[simps]
def map_iso (F : C ⥤ D) {X Y : C} (i : X ≅ Y) : F.obj X ≅ F.obj Y :=
{ hom := F.map i.hom,
  inv := F.map i.inv,
  hom_inv_id' := by rw [←map_comp, iso.hom_inv_id, ←map_id],
  inv_hom_id' := by rw [←map_comp, iso.inv_hom_id, ←map_id] }

@[simp] lemma map_iso_symm (F : C ⥤ D) {X Y : C} (i : X ≅ Y) :
  F.map_iso i.symm = (F.map_iso i).symm :=
rfl

@[simp] lemma map_iso_trans (F : C ⥤ D) {X Y Z : C} (i : X ≅ Y) (j : Y ≅ Z) :
  F.map_iso (i ≪≫ j) = (F.map_iso i) ≪≫ (F.map_iso j) :=
by ext; apply functor.map_comp

@[simp] lemma map_iso_refl (F : C ⥤ D) (X : C) : F.map_iso (iso.refl X) = iso.refl (F.obj X) :=
iso.ext $ F.map_id X

instance map_is_iso (F : C ⥤ D) (f : X ⟶ Y) [is_iso f] : is_iso (F.map f) :=
is_iso.of_iso $ F.map_iso (as_iso f)

@[simp]

lemma map_hom_inv (F : C ⥤ D) {X Y : C} (f : X ⟶ Y) [is_iso f] :
  F.map f ≫ F.map (inv f) = 𝟙 (F.obj X) :=
by simp

lemma map_inv_hom (F : C ⥤ D) {X Y : C} (f : X ⟶ Y) [is_iso f] :
  F.map (inv f) ≫ F.map f = 𝟙 (F.obj Y) :=
by simp

end functor

end category_theory


/-
Copyright (c) 2020 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import data.pfun
import order.preorder_hom
import tactic.wlog
import tactic.monotonicity

/-!
# Omega Complete Partial Orders

An omega-complete partial order is a partial order with a supremum
operation on increasing sequences indexed by natural numbers (which we
call `ωSup`). In this sense, it is strictly weaker than join complete
semi-lattices as only ω-sized totally ordered sets have a supremum.

The concept of an omega-complete partial order (ωCPO) is useful for the
formalization of the semantics of programming languages. Its notion of
supremum helps define the meaning of recursive procedures.

## Main definitions

 * class `omega_complete_partial_order`
 * `ite`, `map`, `bind`, `seq` as continuous morphisms

## Instances of `omega_complete_partial_order`

 * `roption`
 * every `complete_lattice`
 * pi-types
 * product types
 * `monotone_hom`
 * `continuous_hom` (with notation →𝒄)
   * an instance of `omega_complete_partial_order (α →𝒄 β)`
 * `continuous_hom.of_fun`
 * `continuous_hom.of_mono`
 * continuous functions:
   * `id`
   * `ite`
   * `const`
   * `roption.bind`
   * `roption.map`
   * `roption.seq`

## References

 * [G. Markowsky, *Chain-complete posets and directed sets with applications*, https://doi.org/10.1007/BF02485815][markowsky]
 * [J. M. Cadiou and Zohar Manna, *Recursive definitions of partial functions and their computations.*, https://doi.org/10.1145/942580.807072][cadiou]
 * [Carl A. Gunter, *Semantics of Programming Languages: Structures and Techniques*, ISBN: 0262570955][gunter]
-/

universes u v

local attribute [-simp] roption.bind_eq_bind roption.map_eq_map
open_locale classical

namespace preorder_hom

variables (α : Type*) (β : Type*) {γ : Type*} {φ : Type*}
variables [preorder α] [preorder β] [preorder γ] [preorder φ]

variables {β γ}

/-- The constant function, as a monotone function. -/
@[simps]
def const (f : β) : α →ₘ β :=
{ to_fun := function.const _ f,
  monotone' := assume x y h, le_refl _}

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

/-- The diagonal function, as a monotone function. -/
@[simps]
def prod.diag : α →ₘ (α × α) :=
{ to_fun := λ x, (x,x),
  monotone' := λ x y h, ⟨h,h⟩ }

/-- The `prod.map` function, as a monotone function. -/
@[simps]
def prod.map (f : α →ₘ β) (f' : α' →ₘ β') : (α × α') →ₘ (β × β') :=
{ to_fun := prod.map f f',
  monotone' := λ ⟨x,x'⟩ ⟨y,y'⟩ ⟨h,h'⟩, ⟨f.monotone h,f'.monotone h'⟩ }

/-- The `prod.fst` projection, as a monotone function. -/
@[simps]
def prod.fst : (α × β) →ₘ α :=
{ to_fun := prod.fst,
  monotone' := λ ⟨x,x'⟩ ⟨y,y'⟩ ⟨h,h'⟩, h }

/-- The `prod.snd` projection, as a monotone function. -/
@[simps]
def prod.snd : (α × β) →ₘ β :=
{ to_fun := prod.snd,
  monotone' := λ ⟨x,x'⟩ ⟨y,y'⟩ ⟨h,h'⟩, h' }

/-- The `prod` constructor, as a monotone function. -/
@[simps]
def prod.zip (f : α →ₘ β) (g : α →ₘ γ) : α →ₘ (β × γ) :=
(prod.map f g).comp prod.diag

/-- `roption.bind` as a monotone function -/
@[simps]
def bind {β γ} (f : α →ₘ roption β) (g : α →ₘ β → roption γ) : α →ₘ roption γ :=
{ to_fun := λ x, f x >>= g x,
  monotone' :=
  begin
    intros x y h a,
    simp only [and_imp, exists_prop, roption.bind_eq_bind, roption.mem_bind_iff,
               exists_imp_distrib],
    intros b hb ha,
    refine ⟨b, f.monotone h _ hb, g.monotone h _ _ ha⟩,
  end }

end preorder_hom

namespace omega_complete_partial_order

/-- A chain is a monotonically increasing sequence.

See the definition on page 114 of [gunter]. -/
def chain (α : Type u) [preorder α] :=
ℕ →ₘ α

namespace chain

variables {α : Type u} {β : Type v} {γ : Type*}
variables [preorder α] [preorder β] [preorder γ]

instance : has_coe_to_fun (chain α) :=
@infer_instance (has_coe_to_fun $ ℕ →ₘ α) _

instance [inhabited α] : inhabited (chain α) :=
⟨ ⟨ λ _, default _, λ _ _ _, le_refl _ ⟩ ⟩

instance : has_mem α (chain α) :=
⟨λa (c : ℕ →ₘ α), ∃ i, a = c i⟩

variables (c c' : chain α)
variables (f : α →ₘ β)
variables (g : β →ₘ γ)

instance : has_le (chain α) :=
{ le := λ x y, ∀ i, ∃ j, x i ≤ y j  }

/-- `map` function for `chain` -/
@[simps] def map : chain β :=
f.comp c

variables {f}

lemma mem_map (x : α) : x ∈ c → f x ∈ chain.map c f :=
λ ⟨i,h⟩, ⟨i, h.symm ▸ rfl⟩

lemma exists_of_mem_map {b : β} : b ∈ c.map f → ∃ a, a ∈ c ∧ f a = b :=
λ ⟨i,h⟩, ⟨c i, ⟨i, rfl⟩, h.symm⟩

lemma mem_map_iff {b : β} : b ∈ c.map f ↔ ∃ a, a ∈ c ∧ f a = b :=
⟨ exists_of_mem_map _, λ h, by { rcases h with ⟨w,h,h'⟩, subst b, apply mem_map c _ h, } ⟩

@[simp]
lemma map_id : c.map preorder_hom.id = c :=
preorder_hom.comp_id _

lemma map_comp : (c.map f).map g = c.map (g.comp f) := rfl

@[mono]
lemma map_le_map {g : α →ₘ β} (h : f ≤ g) : c.map f ≤ c.map g :=
λ i, by simp [mem_map_iff]; intros; existsi i; apply h

/-- `chain.zip` pairs up the elements of two chains that have the same index -/
@[simps]
def zip (c₀ : chain α) (c₁ : chain β) : chain (α × β) :=
preorder_hom.prod.zip c₀ c₁

end chain

end omega_complete_partial_order

open omega_complete_partial_order

section prio
set_option extends_priority 50

/-- An omega-complete partial order is a partial order with a supremum
operation on increasing sequences indexed by natural numbers (which we
call `ωSup`). In this sense, it is strictly weaker than join complete
semi-lattices as only ω-sized totally ordered sets have a supremum.

See the definition on page 114 of [gunter]. -/
class omega_complete_partial_order (α : Type*) extends partial_order α :=
(ωSup     : chain α → α)
(le_ωSup  : ∀(c:chain α), ∀ i, c i ≤ ωSup c)
(ωSup_le  : ∀(c:chain α) x, (∀ i, c i ≤ x) → ωSup c ≤ x)

end prio

namespace omega_complete_partial_order
variables {α : Type u} {β : Type v} {γ : Type*}
variables [omega_complete_partial_order α]

/-- Transfer a `omega_complete_partial_order` on `β` to a `omega_complete_partial_order` on `α`
using a strictly monotone function `f : β →ₘ α`, a definition of ωSup and a proof that `f` is
continuous with regard to the provided `ωSup` and the ωCPO on `α`. -/
@[reducible]
protected def lift [partial_order β] (f : β →ₘ α)
  (ωSup₀ : chain β → β)
  (h : ∀ x y, f x ≤ f y → x ≤ y)
  (h' : ∀ c, f (ωSup₀ c) = ωSup (c.map f)) : omega_complete_partial_order β :=
{ ωSup := ωSup₀,
  ωSup_le := λ c x hx, h _ _ (by rw h'; apply ωSup_le; intro; apply f.monotone (hx i)),
  le_ωSup := λ c i, h _ _ (by rw h'; apply le_ωSup (c.map f)) }

lemma le_ωSup_of_le {c : chain α} {x : α} (i : ℕ) (h : x ≤ c i) : x ≤ ωSup c :=
le_trans h (le_ωSup c _)

lemma ωSup_total {c : chain α} {x : α} (h : ∀ i, c i ≤ x ∨ x ≤ c i) : ωSup c ≤ x ∨ x ≤ ωSup c :=
classical.by_cases
  (assume : ∀ i, c i ≤ x, or.inl (ωSup_le _ _ this))
  (assume : ¬ ∀ i, c i ≤ x,
    have ∃ i, ¬ c i ≤ x,
      by simp only [not_forall] at this ⊢; assumption,
    let ⟨i, hx⟩ := this in
    have x ≤ c i, from (h i).resolve_left hx,
    or.inr $ le_ωSup_of_le _ this)

@[mono]
lemma ωSup_le_ωSup_of_le {c₀ c₁ : chain α} (h : c₀ ≤ c₁) : ωSup c₀ ≤ ωSup c₁ :=
ωSup_le _ _ $
λ i, Exists.rec_on (h i) $
λ j h, le_trans h (le_ωSup _ _)

lemma ωSup_le_iff (c : chain α) (x : α) : ωSup c ≤ x ↔ (∀ i, c i ≤ x) :=
begin
  split; intros,
  { transitivity ωSup c,
    exact le_ωSup _ _, assumption },
  exact ωSup_le _ _ ‹_›,
end

/-- A subset `p : α → Prop` of the type closed under `ωSup` induces an
`omega_complete_partial_order` on the subtype `{a : α // p a}`. -/
def subtype {α : Type*} [omega_complete_partial_order α] (p : α → Prop)
  (hp : ∀ (c : chain α), (∀ i ∈ c, p i) → p (ωSup c)) :
  omega_complete_partial_order (subtype p) :=
omega_complete_partial_order.lift
  (preorder_hom.subtype.val p)
  (λ c, ⟨ωSup _, hp (c.map (preorder_hom.subtype.val p)) (λ i ⟨n, q⟩, q.symm ▸ (c n).2)⟩)
  (λ x y h, h)
  (λ c, rfl)

section continuity
open chain

variables [omega_complete_partial_order β]
variables [omega_complete_partial_order γ]

/-- A monotone function `f : α →ₘ β` is continuous if it distributes over ωSup.

In order to distinguish it from the (more commonly used) continuity from topology
(see topology/basic.lean), the present definition is often referred to as
"Scott-continuity" (referring to Dana Scott). It corresponds to continuity
in Scott topological spaces (not defined here). -/
def continuous (f : α →ₘ β) : Prop :=
∀ c : chain α, f (ωSup c) = ωSup (c.map f)

/-- `continuous' f` asserts that `f` is both monotone and continuous. -/
def continuous' (f : α → β) : Prop :=
∃ hf : monotone f, continuous ⟨f, hf⟩

lemma continuous.to_monotone {f : α → β} (hf : continuous' f) : monotone f := hf.fst

lemma continuous.of_bundled (f : α → β) (hf : monotone f)
  (hf' : continuous ⟨f, hf⟩) : continuous' f := ⟨hf, hf'⟩

lemma continuous.of_bundled' (f : α →ₘ β) (hf' : continuous f) : continuous' f :=
⟨f.monotone, hf'⟩

lemma continuous.to_bundled (f : α → β) (hf : continuous' f) :
  continuous ⟨f, continuous.to_monotone hf⟩ := hf.snd

variables (f : α →ₘ β) (g : β →ₘ γ)

lemma continuous_id : continuous (@preorder_hom.id α _) :=
by intro; rw c.map_id; refl

lemma continuous_comp (hfc : continuous f) (hgc : continuous g) : continuous (g.comp f):=
begin
  dsimp [continuous] at *, intro,
  rw [hfc,hgc,chain.map_comp]
end

lemma id_continuous' : continuous' (@id α) :=
continuous.of_bundled _ (λ a b h, h)
begin
  intro c, apply eq_of_forall_ge_iff, intro z,
  simp [ωSup_le_iff,function.const],
end

lemma const_continuous' (x: β) : continuous' (function.const α x) :=
continuous.of_bundled _ (λ a b h, le_refl _)
begin
  intro c, apply eq_of_forall_ge_iff, intro z,
  simp [ωSup_le_iff,function.const],
end

end continuity

end omega_complete_partial_order

namespace roption

variables {α : Type u} {β : Type v} {γ : Type*}
open omega_complete_partial_order

lemma eq_of_chain {c : chain (roption α)} {a b : α} (ha : some a ∈ c) (hb : some b ∈ c) : a = b :=
begin
  cases ha with i ha, replace ha := ha.symm,
  cases hb with j hb, replace hb := hb.symm,
  wlog h : i ≤ j := le_total i j using [a b i j, b a j i],
  rw [eq_some_iff] at ha hb,
  have := c.monotone h _ ha, apply mem_unique this hb
end

/-- The (noncomputable) `ωSup` definition for the `ω`-CPO structure on `roption α`. -/
protected noncomputable def ωSup (c : chain (roption α)) : roption α :=
if h : ∃a, some a ∈ c then some (classical.some h) else none

lemma ωSup_eq_some {c : chain (roption α)} {a : α} (h : some a ∈ c) : roption.ωSup c = some a :=
have ∃a, some a ∈ c, from ⟨a, h⟩,
have a' : some (classical.some this) ∈ c, from classical.some_spec this,
calc roption.ωSup c = some (classical.some this) : dif_pos this
                ... = some a : congr_arg _ (eq_of_chain a' h)

lemma ωSup_eq_none {c : chain (roption α)} (h : ¬∃a, some a ∈ c) : roption.ωSup c = none :=
dif_neg h

lemma mem_chain_of_mem_ωSup {c : chain (roption α)} {a : α} (h : a ∈ roption.ωSup c) : some a ∈ c :=
begin
  simp [roption.ωSup] at h, split_ifs at h,
  { have h' := classical.some_spec h_1,
    rw ← eq_some_iff at h, rw ← h, exact h' },
  { rcases h with ⟨ ⟨ ⟩ ⟩ }
end

noncomputable instance omega_complete_partial_order : omega_complete_partial_order (roption α) :=
{ ωSup    := roption.ωSup,
  le_ωSup := λ c i, by { intros x hx, rw ← eq_some_iff at hx ⊢,
                         rw [ωSup_eq_some, ← hx], rw ← hx, exact ⟨i,rfl⟩ },
  ωSup_le := by { rintros c x hx a ha, replace ha := mem_chain_of_mem_ωSup ha,
                  cases ha with i ha, apply hx i, rw ← ha, apply mem_some } }

section inst

lemma mem_ωSup (x : α) (c : chain (roption α)) : x ∈ ωSup c ↔ some x ∈ c :=
begin
  simp [omega_complete_partial_order.ωSup,roption.ωSup],
  split,
  { split_ifs, swap, rintro ⟨⟨⟩⟩,
    intro h', have hh := classical.some_spec h,
    simp at h', subst x, exact hh },
  { intro h,
    have h' : ∃ (a : α), some a ∈ c := ⟨_,h⟩,
    rw dif_pos h', have hh := classical.some_spec h',
    rw eq_of_chain hh h, simp }
end

end inst

end roption

namespace pi

variables {α : Type*} {β : α → Type*} {γ : Type*}

/-- Function application `λ f, f a` is monotone with respect to `f` for fixed `a`. -/
@[simps]
def monotone_apply [∀a, partial_order (β a)] (a : α) : (Πa, β a) →ₘ β a :=
{ to_fun := (λf:Πa, β a, f a),
  monotone' := assume f g hfg, hfg a }

open omega_complete_partial_order omega_complete_partial_order.chain

instance [∀a, omega_complete_partial_order (β a)] : omega_complete_partial_order (Πa, β a) :=
{ ωSup    := λc a, ωSup (c.map (monotone_apply a)),
  ωSup_le := assume c f hf a, ωSup_le _ _ $ by { rintro i, apply hf },
  le_ωSup := assume c i x, le_ωSup_of_le _ $ le_refl _ }

namespace omega_complete_partial_order

variables [∀ x, omega_complete_partial_order $ β x]
variables [omega_complete_partial_order γ]

lemma flip₁_continuous'
  (f : ∀ x : α, γ → β x) (a : α) (hf : continuous' (λ x y, f y x)) :
  continuous' (f a) :=
continuous.of_bundled _
  (λ x y h, continuous.to_monotone hf h a)
  (λ c, congr_fun (continuous.to_bundled _ hf c) a)

lemma flip₂_continuous'
  (f : γ → Π x, β x) (hf : ∀ x, continuous' (λ g, f g x)) : continuous' f :=
continuous.of_bundled _
  (λ x y h a, continuous.to_monotone (hf a) h)
  (by intro c; ext a; apply continuous.to_bundled _ (hf a) c)

end omega_complete_partial_order

end pi

namespace prod

open omega_complete_partial_order
variables {α : Type*} {β : Type*} {γ : Type*}
variables [omega_complete_partial_order α]
variables [omega_complete_partial_order β]
variables [omega_complete_partial_order γ]

/-- The supremum of a chain in the product `ω`-CPO. -/
@[simps]
protected def ωSup (c : chain (α × β)) : α × β :=
(ωSup (c.map preorder_hom.prod.fst), ωSup (c.map preorder_hom.prod.snd))

@[simps ωSup_fst ωSup_snd]
instance : omega_complete_partial_order (α × β) :=
{ ωSup := prod.ωSup,
  ωSup_le := λ c ⟨x,x'⟩ h, ⟨ωSup_le _ _ $ λ i, (h i).1, ωSup_le _ _ $ λ i, (h i).2⟩,
  le_ωSup := λ c i,
    ⟨le_ωSup (c.map preorder_hom.prod.fst) i, le_ωSup (c.map preorder_hom.prod.snd) i⟩ }

end prod

namespace complete_lattice
variables (α : Type u)

/-- Any complete lattice has an `ω`-CPO structure where the countable supremum is a special case
of arbitrary suprema. -/

@[priority 100] -- see Note [lower instance priority]
instance [complete_lattice α] : omega_complete_partial_order α :=
{ ωSup    := λc, ⨆ i, c i,
  ωSup_le := λ ⟨c, _⟩ s hs, by simp only [supr_le_iff, preorder_hom.coe_fun_mk] at ⊢ hs;
    intros i; apply hs i,
  le_ωSup := assume ⟨c, _⟩ i, by simp only [preorder_hom.coe_fun_mk]; apply le_supr_of_le i; refl }

variables {α} {β : Type v} [omega_complete_partial_order α] [complete_lattice β]
open omega_complete_partial_order

lemma inf_continuous [is_total β (≤)] (f g : α →ₘ β) (hf : continuous f) (hg : continuous g) :
  continuous (f ⊓ g) :=
begin
  intro c,
  apply eq_of_forall_ge_iff, intro z,
  simp only [inf_le_iff, hf c, hg c, ωSup_le_iff, ←forall_or_distrib_left, ←forall_or_distrib_right,
             chain.map_to_fun, function.comp_app, preorder_hom.has_inf_inf_to_fun],
  split,
  { introv h, apply h },
  { intros h i j,
    apply or.imp _ _ (h (max i j)); apply le_trans; mono*,
    { apply le_max_left },
    { apply le_max_right }, },
end

lemma Sup_continuous (s : set $ α →ₘ β) (hs : ∀ f ∈ s, continuous f) :
  continuous (Sup s) :=
begin
  intro c, apply eq_of_forall_ge_iff, intro z,
  simp only [ωSup_le_iff, and_imp, preorder_hom.complete_lattice_Sup, set.mem_image,
             chain.map_to_fun, function.comp_app, Sup_le_iff, preorder_hom.has_Sup_Sup_to_fun,
             exists_imp_distrib],
  split; introv h hx hb; subst b,
  { apply le_trans _ (h _ _ hx rfl),
    mono, apply le_ωSup },
  { rw [hs _ hx c, ωSup_le_iff], intro,
    apply h i _ x hx rfl, }
end

theorem Sup_continuous' :
  ∀s : set (α → β), (∀t∈s, omega_complete_partial_order.continuous' t) →
  omega_complete_partial_order.continuous' (Sup s) :=
begin
  introv ht, dsimp [continuous'],
  have : monotone (Sup s),
  { intros x y h,
    apply Sup_le_Sup_of_forall_exists_le, intro,
    simp only [and_imp, exists_prop, set.mem_range, set_coe.exists, subtype.coe_mk,
      exists_imp_distrib],
    intros f hfs hfx,
    subst hfx,
    refine ⟨f y, ⟨f, hfs, rfl⟩, _⟩,
    cases ht _ hfs with hf,
    apply hf h },
  existsi this,
  let s' : set (α →ₘ β) := { f | ⇑f ∈ s },
  suffices : omega_complete_partial_order.continuous (Sup s'),
  { convert this, ext,
    simp only [supr, has_Sup.Sup, Sup, set.image, set.mem_set_of_eq],
    congr, ext,
    simp only [exists_prop, set.mem_range, set_coe.exists, set.mem_set_of_eq, subtype.coe_mk],
    split,
    { rintro ⟨y,hy,hy'⟩,
      cases ht _ hy,
      refine ⟨⟨_, w⟩, hy, hy'⟩ },
    tauto },
  apply complete_lattice.Sup_continuous,
  intros f hf,
  specialize ht f hf, cases ht, exact ht_h,
end

lemma sup_continuous {f g : α →ₘ β} (hf : continuous f) (hg : continuous g) :
  continuous (f ⊔ g) :=
begin
  rw ← Sup_pair, apply Sup_continuous,
  simp only [or_imp_distrib, forall_and_distrib, set.mem_insert_iff, set.mem_singleton_iff,
    forall_eq],
  split; assumption,
end

lemma top_continuous :
  continuous (⊤ : α →ₘ β) :=
begin
  intro c, apply eq_of_forall_ge_iff, intro z,
  simp only [ωSup_le_iff, forall_const, chain.map_to_fun, function.comp_app,
             preorder_hom.has_top_top_to_fun],
end

lemma bot_continuous :
  continuous (⊥ : α →ₘ β) :=
begin
  intro c, apply eq_of_forall_ge_iff, intro z,
  simp only [ωSup_le_iff, forall_const, chain.map_to_fun, function.comp_app,
             preorder_hom.has_bot_bot_to_fun],
end

end complete_lattice

namespace omega_complete_partial_order

variables {α : Type u} {α' : Type*} {β : Type v} {β' : Type*} {γ : Type*} {φ : Type*}

variables [omega_complete_partial_order α] [omega_complete_partial_order β]
variables [omega_complete_partial_order γ] [omega_complete_partial_order φ]
variables [omega_complete_partial_order α'] [omega_complete_partial_order β']

namespace preorder_hom

/-- Function application `λ f, f a` (for fixed `a`) is a monotone function from the
monotone function space `α →ₘ β` to `β`. -/
@[simps]
def monotone_apply (a : α) : (α →ₘ β) →ₘ β :=
{ to_fun := (λf : α →ₘ β, f a),
  monotone' := assume f g hfg, hfg a }

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

/-- The `ωSup` operator for monotone functions. -/
@[simps]
protected def ωSup (c : chain (α →ₘ β)) : α →ₘ β :=
{ to_fun := λ a, ωSup (c.map (monotone_apply a)),
  monotone' := λ x y h, ωSup_le_ωSup_of_le (chain.map_le_map _ $ λ a, a.monotone h) }

@[simps ωSup_to_fun]
instance omega_complete_partial_order : omega_complete_partial_order (α →ₘ β) :=
omega_complete_partial_order.lift preorder_hom.to_fun_hom preorder_hom.ωSup
  (λ x y h, h) (λ c, rfl)

end preorder_hom

section old_struct
set_option old_structure_cmd true
variables (α β)

/-- A monotone function on `ω`-continuous partial orders is said to be continuous
if for every chain `c : chain α`, `f (⊔ i, c i) = ⊔ i, f (c i)`.
This is just the bundled version of `preorder_hom.continuous`. -/
structure continuous_hom extends preorder_hom α β :=
(cont : continuous (preorder_hom.mk to_fun monotone'))

attribute [nolint doc_blame] continuous_hom.to_preorder_hom

infixr ` →𝒄 `:25 := continuous_hom -- Input: \r\MIc

instance : has_coe_to_fun (α →𝒄 β) :=
{ F := λ _, α → β,
  coe :=  continuous_hom.to_fun }

instance : has_coe (α →𝒄 β) (α →ₘ β) :=
{ coe :=  continuous_hom.to_preorder_hom }

instance : partial_order (α →𝒄 β) :=
partial_order.lift continuous_hom.to_fun $ by rintro ⟨⟩ ⟨⟩ h; congr; exact h

end old_struct

namespace continuous_hom

theorem congr_fun {f g : α →𝒄 β} (h : f = g) (x : α) : f x = g x :=
congr_arg (λ h : α →𝒄 β, h x) h

theorem congr_arg (f : α →𝒄 β) {x y : α} (h : x = y) : f x = f y :=
congr_arg (λ x : α, f x) h

@[mono]
lemma monotone (f : α →𝒄 β) : monotone f :=
continuous_hom.monotone' f

lemma ite_continuous' {p : Prop} [hp : decidable p] (f g : α → β)
  (hf : continuous' f) (hg : continuous' g) : continuous' (λ x, if p then f x else g x) :=
by split_ifs; simp *

lemma ωSup_bind {β γ : Type v} (c : chain α) (f : α →ₘ roption β) (g : α →ₘ β → roption γ) :
  ωSup (c.map (f.bind g)) = ωSup (c.map f) >>= ωSup (c.map g) :=
begin
  apply eq_of_forall_ge_iff, intro x,
  simp only [ωSup_le_iff, roption.bind_le, chain.mem_map_iff, and_imp, preorder_hom.bind_to_fun,
    exists_imp_distrib],
  split; intro h''',
  { intros b hb, apply ωSup_le _ _ _,
    rintros i y hy, simp only [roption.mem_ωSup] at hb,
    rcases hb with ⟨j,hb⟩, replace hb := hb.symm,
    simp only [roption.eq_some_iff, chain.map_to_fun, function.comp_app, pi.monotone_apply_to_fun]
      at hy hb,
    replace hb : b ∈ f (c (max i j))   := f.monotone (c.monotone (le_max_right i j)) _ hb,
    replace hy : y ∈ g (c (max i j)) b := g.monotone (c.monotone (le_max_left i j)) _ _ hy,
    apply h''' (max i j),
    simp only [exists_prop, roption.bind_eq_bind, roption.mem_bind_iff, chain.map_to_fun,
               function.comp_app, preorder_hom.bind_to_fun],
    exact ⟨_,hb,hy⟩, },
  { intros i, intros y hy,
    simp only [exists_prop, roption.bind_eq_bind, roption.mem_bind_iff, chain.map_to_fun,
               function.comp_app, preorder_hom.bind_to_fun] at hy,
    rcases hy with ⟨b,hb₀,hb₁⟩,
    apply h''' b _,
    { apply le_ωSup (c.map g) _ _ _ hb₁ },
    { apply le_ωSup (c.map f) i _ hb₀ } },
end

lemma bind_continuous' {β γ : Type v} (f : α → roption β) (g : α → β → roption γ) :
  continuous' f → continuous' g →
  continuous' (λ x, f x >>= g x)
| ⟨hf,hf'⟩ ⟨hg,hg'⟩ :=
continuous.of_bundled' (preorder_hom.bind ⟨f,hf⟩ ⟨g,hg⟩)
  (by intro c; rw [ωSup_bind, ← hf', ← hg']; refl)

lemma map_continuous' {β γ : Type v} (f : β → γ) (g : α → roption β)
  (hg : continuous' g) :
  continuous' (λ x, f <$> g x) :=
by simp only [map_eq_bind_pure_comp];
   apply bind_continuous' _ _ hg;
   apply const_continuous'

lemma seq_continuous' {β γ : Type v} (f : α → roption (β → γ)) (g : α → roption β)
  (hf : continuous' f) (hg : continuous' g) :
  continuous' (λ x, f x <*> g x) :=
by simp only [seq_eq_bind_map];
   apply bind_continuous' _ _ hf;
   apply pi.omega_complete_partial_order.flip₂_continuous'; intro;
   apply map_continuous' _ _ hg

lemma continuous (F : α →𝒄 β) (C : chain α) : F (ωSup C) = ωSup (C.map F) :=
continuous_hom.cont _ _

/-- Construct a continuous function from a bare function, a continuous function, and a proof that
they are equal. -/
@[simps, reducible]
def of_fun (f : α → β) (g : α →𝒄 β) (h : f = g) : α →𝒄 β :=
by refine {to_fun := f, ..}; subst h; cases g; assumption

/-- Construct a continuous function from a monotone function with a proof of continuity. -/
@[simps, reducible]
def of_mono (f : α →ₘ β) (h : ∀ c : chain α, f (ωSup c) = ωSup (c.map f)) : α →𝒄 β :=
{ to_fun := f,
  monotone' := f.monotone,
  cont := h }

/-- The identity as a continuous function. -/
@[simps]
def id : α →𝒄 α :=
of_mono preorder_hom.id
  (by intro; rw [chain.map_id]; refl)

/-- The composition of continuous functions. -/
@[simps]
def comp (f : β →𝒄 γ) (g : α →𝒄 β) : α →𝒄 γ :=
of_mono (preorder_hom.comp (↑f) (↑g))
  (by intro; rw [preorder_hom.comp, ← preorder_hom.comp, ← chain.map_comp, ← f.continuous,
                 ← g.continuous]; refl)

@[ext]
protected lemma ext (f g : α →𝒄 β) (h : ∀ x, f x = g x) : f = g :=
by cases f; cases g; congr; ext; apply h

protected lemma coe_inj (f g : α →𝒄 β) (h : (f : α → β) = g) : f = g :=
continuous_hom.ext _ _ $ _root_.congr_fun h

@[simp]
lemma comp_id (f : β →𝒄 γ) : f.comp id = f := by ext; refl

@[simp]
lemma id_comp (f : β →𝒄 γ) : id.comp f = f := by ext; refl

@[simp]
lemma comp_assoc (f : γ →𝒄 φ) (g : β →𝒄 γ) (h : α →𝒄 β) : f.comp (g.comp h) = (f.comp g).comp h :=
by ext; refl

@[simp]
lemma coe_apply (a : α) (f : α →𝒄 β) : (f : α →ₘ β) a = f a := rfl

/-- `function.const` is a continuous function. -/
def const (f : β) : α →𝒄 β :=
of_mono (preorder_hom.const _ f)
    begin
      intro c, apply le_antisymm,
      { simp only [function.const, preorder_hom.const_to_fun],
        apply le_ωSup_of_le 0, refl },
      { apply ωSup_le, simp only [preorder_hom.const_to_fun, chain.map_to_fun, function.comp_app],
        intros, refl },
    end

@[simp] theorem const_apply (f : β) (a : α) : const f a = f := rfl

instance [inhabited β] : inhabited (α →𝒄 β) :=
⟨ const (default β) ⟩

namespace prod

/-- The application of continuous functions as a monotone function.

(It would make sense to make it a continuous function, but we are currently constructing a
`omega_complete_partial_order` instance for `α →𝒄 β`, and we cannot use it as the domain or image
of a continuous function before we do.) -/
@[simps]
def apply : (α →𝒄 β) × α →ₘ β :=
{ to_fun := λ f, f.1 f.2,
  monotone' := λ x y h, by dsimp; transitivity y.fst x.snd; [apply h.1, apply y.1.monotone h.2] }

end prod

/-- The map from continuous functions to monotone functions is itself a monotone function. -/
@[simps]
def to_mono : (α →𝒄 β) →ₘ (α →ₘ β) :=
{ to_fun := λ f, f,
  monotone' := λ x y h, h }

/-- When proving that a chain of applications is below a bound `z`, it suffices to consider the
functions and values being selected from the same index in the chains.

This lemma is more specific than necessary, i.e. `c₀` only needs to be a
chain of monotone functions, but it is only used with continuous functions. -/
@[simp]
lemma forall_forall_merge (c₀ : chain (α →𝒄 β)) (c₁ : chain α) (z : β) :
  (∀ (i j : ℕ), (c₀ i) (c₁ j) ≤ z) ↔ ∀ (i : ℕ), (c₀ i) (c₁ i) ≤ z :=
begin
  split; introv h,
  { apply h },
  { apply le_trans _ (h (max i j)),
    transitivity c₀ i (c₁ (max i j)),
    { apply (c₀ i).monotone, apply c₁.monotone, apply le_max_right },
    { apply c₀.monotone, apply le_max_left } }
end

@[simp]
lemma forall_forall_merge' (c₀ : chain (α →𝒄 β)) (c₁ : chain α) (z : β) :
  (∀ (j i : ℕ), (c₀ i) (c₁ j) ≤ z) ↔ ∀ (i : ℕ), (c₀ i) (c₁ i) ≤ z :=
by rw [forall_swap,forall_forall_merge]

/-- The `ωSup` operator for continuous functions, which takes the pointwise countable supremum
of the functions in the `ω`-chain. -/
@[simps]
protected def ωSup (c : chain (α →𝒄 β)) : α →𝒄 β :=
continuous_hom.of_mono (ωSup $ c.map to_mono)
begin
  intro c',
  apply eq_of_forall_ge_iff, intro z,
  simp only [ωSup_le_iff, (c _).continuous, chain.map_to_fun, preorder_hom.monotone_apply_to_fun,
    to_mono_to_fun, coe_apply, preorder_hom.omega_complete_partial_order_ωSup_to_fun,
    forall_forall_merge, forall_forall_merge', function.comp_app],
end

@[simps ωSup]
instance : omega_complete_partial_order (α →𝒄 β) :=
omega_complete_partial_order.lift continuous_hom.to_mono continuous_hom.ωSup
  (λ x y h, h) (λ c, rfl)

lemma ωSup_def (c : chain (α →𝒄 β)) (x : α) : ωSup c x = continuous_hom.ωSup c x := rfl

lemma ωSup_ωSup (c₀ : chain (α →𝒄 β)) (c₁ : chain α) :
  ωSup c₀ (ωSup c₁) = ωSup (continuous_hom.prod.apply.comp $ c₀.zip c₁) :=
begin
  apply eq_of_forall_ge_iff, intro z,
  simp only [ωSup_le_iff, (c₀ _).continuous, chain.map_to_fun, to_mono_to_fun, coe_apply,
    preorder_hom.omega_complete_partial_order_ωSup_to_fun, ωSup_def, forall_forall_merge,
    chain.zip_to_fun, preorder_hom.prod.map_to_fun, preorder_hom.prod.diag_to_fun, prod.map_mk,
    preorder_hom.monotone_apply_to_fun, function.comp_app, prod.apply_to_fun,
    preorder_hom.comp_to_fun, ωSup_to_fun],
end

/-- A family of continuous functions yields a continuous family of functions. -/
@[simps]
def flip {α : Type*} (f : α → β →𝒄 γ) : β →𝒄 α → γ :=
{ to_fun := λ x y, f y x,
  monotone' := λ x y h a, (f a).monotone h,
  cont := by intro; ext; change f x _ = _; rw [(f x).continuous ]; refl, }

/-- `roption.bind` as a continuous function. -/
@[simps { rhs_md := reducible }]
noncomputable def bind {β γ : Type v}
  (f : α →𝒄 roption β) (g : α →𝒄 β → roption γ) : α →𝒄 roption γ :=
of_mono (preorder_hom.bind (↑f) (↑g)) $ λ c, begin
  rw [preorder_hom.bind, ← preorder_hom.bind, ωSup_bind, ← f.continuous, ← g.continuous],
  refl
end

/-- `roption.map` as a continuous function. -/
@[simps {rhs_md := reducible}]
noncomputable def map {β γ : Type v} (f : β → γ) (g : α →𝒄 roption β) : α →𝒄 roption γ :=
of_fun (λ x, f <$> g x) (bind g (const (pure ∘ f))) $
by ext; simp only [map_eq_bind_pure_comp, bind_to_fun, preorder_hom.bind_to_fun, const_apply,
  preorder_hom.const_to_fun, coe_apply]

/-- `roption.seq` as a continuous function. -/
@[simps {rhs_md := reducible}]
noncomputable def seq {β γ : Type v} (f : α →𝒄 roption (β → γ)) (g : α →𝒄 roption β) :
  α →𝒄 roption γ :=
of_fun (λ x, f x <*> g x) (bind f $ (flip $ _root_.flip map g))
  (by ext; simp only [seq_eq_bind_map, flip, roption.bind_eq_bind, map_to_fun, roption.mem_bind_iff,
                      bind_to_fun, preorder_hom.bind_to_fun, coe_apply, flip_to_fun]; refl)

end continuous_hom

end omega_complete_partial_order


namespace hidden

inductive dm_option (α : Type): Type
| none : dm_option
| some (a : α) : dm_option

/-
Heres an example of a representation in Lean of
a partial function, p, from ℕ to ℕ, such that
p(n) = 0 if n=0 and p(n) is undefined otherwise.
-/

def p : ℕ → dm_option ℕ
| nat.zero := dm_option.some nat.zero
| _ := dm_option.none ℕ       -- needs explicit type!

end hidden


import hilbert.wr.pt_neg

namespace clfrags
    namespace hilbert
        namespace wr
            namespace pt_neg

                theorem pt₂_neg {a b c : Prop} (h₁ : neg (pt a b c)) : neg (pt b a c) :=
                    have h₂ : pt (neg a) b c, from ptn₁ h₁,
                    have h₃ : pt a (neg b) c, from ptn₃ h₂,
                    have h₄ : pt (neg b) a c, from pt.pt₂ h₃,
                    show neg (pt b a c), from ptn₂ h₄

                theorem pt₃_neg {a b c : Prop} (h₁ : neg (pt a b c)) : neg (pt a c b) :=
                    have h₂ : pt (neg a) b c, from ptn₁ h₁,
                    have h₃ : pt (neg a) c b, from pt.pt₃ h₂,
                    show neg (pt a c b), from ptn₂ h₃

                theorem pt₄_neg {a b : Prop} (h₁ : neg a) : neg (pt a b b) :=
                    have h₂ : pt (neg a) b b, from pt.pt₄ h₁,
                    show neg (pt a b b), from ptn₂ h₂

                theorem pt₅_neg {a b : Prop} (h₁ : neg (pt a b b)) : neg a :=
                    have h₂ : pt (neg a) b b, from ptn₁ h₁,
                    show neg a, from pt.pt₅ h₂

                theorem pt₆_neg {a b c d e : Prop} (h₁ : neg (pt a b (pt c d e))) : neg (pt (pt a b c) d e) :=
                    have h₂ : pt (neg a) b (pt c d e), from ptn₁ h₁,
                    have h₃ : pt (pt (neg a) b c) d e, from pt.pt₆ h₂,
                    have h₄ : pt d e (pt (neg a) b c), from pt.pt₃ (pt.pt₂ h₃),
                    have h₅ : pt (pt d e (neg a)) b c, from pt.pt₆ h₄,
                    have h₆ : pt b c (pt d e (neg a)), from pt.pt₃ (pt.pt₂ h₅),
                    have h₇ : pt b c (pt (neg a) d e), from pt.pt₂_pt (pt.pt₃_pt h₆),
                    have h₈ : pt (pt (neg a) d e) b c, from pt.pt₂ (pt.pt₃ h₇),
                    have h₉ : pt (neg a) d (pt e b c), from pt.pt₇ h₈,
                    have h₁₀ : neg (pt a d (pt e b c)), from ptn₂ h₉,
                    have h₁₁ : neg (pt d a (pt e b c)), from pt₂_neg h₁₀,
                    have h₁₂ : pt (neg d) a (pt e b c), from ptn₁ h₁₁,
                    have h₁₃ : pt (pt (neg d) a e) b c, from pt.pt₆ h₁₂,
                    have h₁₄ : pt b c (pt (neg d) a e), from pt.pt₃ (pt.pt₂ h₁₃),
                    have h₁₅ : pt b c (pt a (neg d) e), from pt.pt₂_pt h₁₄,
                    have h₁₆ : pt (pt b c a) (neg d) e, from pt.pt₆ h₁₅,
                    have h₁₇ : pt (neg d) e (pt b c a), from pt.pt₃ (pt.pt₂ h₁₆),
                    have h₁₈ : pt (neg d) e (pt a b c), from pt.pt₂_pt (pt.pt₃_pt h₁₇),
                    have h₁₉ : neg (pt d e (pt a b c)), from ptn₂ h₁₈,
                    show neg (pt (pt a b c) d e), from pt₂_neg (pt₃_neg h₁₉)

                theorem pt₇_neg {a b c d e : Prop} (h₁ : neg (pt (pt a b c) d e)) : neg (pt a b (pt c d e))  :=
                    have h₂ : neg (pt d (pt a b c) e), from pt₂_neg h₁,
                    have h₃ : neg (pt d e (pt a b c)), from pt₃_neg h₂,
                    have h₄ : neg (pt (pt d e a) b c), from pt₆_neg h₃,
                    have h₅ : neg (pt b (pt d e a) c), from pt₂_neg h₄,
                    have h₆ : neg (pt b c (pt d e a)), from pt₃_neg h₅,
                    have h₇ : neg (pt (pt b c d) e a), from pt₆_neg h₆,
                    have h₈ : neg (pt e (pt b c d) a), from pt₂_neg h₇,
                    have h₉ : neg (pt e a (pt b c d)), from pt₃_neg h₈,
                    have h₁₀ : neg (pt (pt e a b) c d), from pt₆_neg h₉,
                    have h₁₁ : neg (pt c (pt e a b) d), from pt₂_neg h₁₀,
                    have h₁₂ : neg (pt c d (pt e a b)), from pt₃_neg h₁₁,
                    have h₁₃ : neg (pt (pt c d e) a b), from pt₆_neg h₁₂,
                    have h₁₄ : neg (pt a (pt c d e) b), from pt₂_neg h₁₃,
                    show neg (pt a b (pt c d e)), from pt₃_neg h₁₄

                theorem n₁_pt {a b c d : Prop} (h₁ : pt c d a) (h₂ : pt c d (neg a)) : pt c d b :=
                    have h₃ : pt a c d, from pt.pt₂ (pt.pt₃ h₁),
                    have h₄ : pt (neg a) c d, from pt.pt₂ (pt.pt₃ h₂),
                    have h₅ : neg (pt a c d), from ptn₂ h₄,
                    show pt c d b, from n₁ h₃ h₅

                theorem ptn₁_pt {a b c d e : Prop} (h₁ : pt d e (neg (pt a b c))) : pt d e (pt (neg a) b c) :=
                    have h₂ : pt (neg (pt a b c)) d e, from pt.pt₂ (pt.pt₃ h₁),
                    have h₃ : neg (pt (pt a b c) d e), from ptn₂ h₂,
                    have h₄ : neg (pt a b (pt c d e)), from pt₇_neg h₃,
                    have h₅ : pt (neg a) b (pt c d e), from ptn₁ h₄,
                    have h₆ : pt (pt (neg a) b c) d e, from pt.pt₆ h₅,
                    show pt d e (pt (neg a) b c), from pt.pt₃ (pt.pt₂ h₆)

                theorem ptn₂_pt {a b c d e : Prop} (h₁ : pt d e (pt (neg a) b c))  : pt d e (neg (pt a b c)) :=
                    have h₂ : pt (pt (neg a) b c) d e, from pt.pt₂ (pt.pt₃ h₁),
                    have h₃ : pt (neg a) b (pt c d e), from pt.pt₇ h₂,
                    have h₄ : neg (pt a b (pt c d e)), from ptn₂ h₃,
                    have h₅ : neg (pt (pt a b c) d e), from pt₆_neg h₄,
                    have h₆ : pt (neg (pt a b c)) d e, from ptn₁ h₅,
                    show pt d e (neg (pt a b c)), from pt.pt₃ (pt.pt₂ h₆)

                theorem ptn₃_pt {a b c d e : Prop} (h₁ : pt d e (neg (pt a b c))) : pt d e (pt a (neg b) c) :=
                    have h₂ : pt (neg (pt a b c)) d e, from pt.pt₂ (pt.pt₃ h₁),
                    have h₃ : neg (pt (pt a b c) d e), from ptn₂ h₂,
                    have h₄ : neg (pt a b (pt c d e)), from pt₇_neg h₃,
                    have h₅ : neg (pt b a (pt c d e)), from pt₂_neg h₄,
                    have h₆ : pt (neg b) a (pt c d e), from ptn₁ h₅,
                    have h₇ : pt a (neg b) (pt c d e), from pt.pt₂ h₆,
                    have h₈ : pt (pt a (neg b) c) d e, from pt.pt₆ h₇,
                    show pt d e (pt a (neg b) c), from pt.pt₃ (pt.pt₂ h₈)

            end pt_neg
        end wr
    end hilbert
end clfrags


import category_theory.category.default
import category_theory.isomorphism

universes v u  -- The order in this declaration matters: v often needs to be explicitly specified while u often can be omitted

namespace category_theory

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

--rewrite this

/-
# Category world

## Level 1: Isomorphisms

An isomorphism `f : X ⟶ Y` is a morphism for which there exists a morphism `g : Y ⟶ X`, such that `f ≫ g = 𝟙 X` and `g ≫ f = 𝟙 Y`.
-/

/- Lemma
If $$f : X ⟶ Y$$ and $$g : X ⟶ Y$$ are morphisms such that $$f = g$$, then $$f ≫ h = g ≫ h$$.
-/
lemma cancel_left_iso' {X Y Z : C} (f : X ⟶ Y) [is_iso f] {g h : Z ⟶ X} : (g ≫ f = h ≫ f) ↔ g = h :=
begin
    split,

    intro hyp,
    rw ← category.comp_id g,
    rw ← category.comp_id h,
    rw ← is_iso.hom_inv_id f,
    rw ← category.assoc,
    rw hyp,
    rw category.assoc,

    intro hyp,
    rw hyp,
end

end category_theory


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

! This file was ported from Lean 3 source module algebra.category.BoolRing
! leanprover-community/mathlib commit 67779f73e572fd1fec2218648b2078d167d16c0a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Category.Ring.Basic
import Mathbin.Algebra.Ring.BooleanRing
import Mathbin.Order.Category.BoolAlg

/-!
# The category of Boolean rings

This file defines `BoolRing`, the category of Boolean rings.

## TODO

Finish the equivalence with `BoolAlg`.
-/

universe u

open CategoryTheory Order

/-- The category of Boolean rings. -/
def BoolRing :=
  Bundled BooleanRing
#align BoolRing BoolRing

namespace BoolRing

instance : CoeSort BoolRing (Type _) :=
  Bundled.hasCoeToSort

instance (X : BoolRing) : BooleanRing X :=
  X.str

/-- Construct a bundled `BoolRing` from a `boolean_ring`. -/
def of (α : Type _) [BooleanRing α] : BoolRing :=
  Bundled.of α
#align BoolRing.of BoolRing.of

@[simp]
theorem coe_of (α : Type _) [BooleanRing α] : ↥(of α) = α :=
  rfl
#align BoolRing.coe_of BoolRing.coe_of

instance : Inhabited BoolRing :=
  ⟨of PUnit⟩

instance : BundledHom.ParentProjection @BooleanRing.toCommRing :=
  ⟨⟩

deriving instance LargeCategory, ConcreteCategory for BoolRing

@[simps]
instance hasForgetToCommRing : HasForget₂ BoolRing CommRingCat :=
  BundledHom.forget₂ _ _
#align BoolRing.has_forget_to_CommRing BoolRing.hasForgetToCommRing

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

end BoolRing

/-! ### Equivalence between `BoolAlg` and `BoolRing` -/

@[simps]
instance BoolRing.hasForgetToBoolAlg : HasForget₂ BoolRing BoolAlg
    where forget₂ :=
    { obj := fun X => BoolAlg.of (AsBoolalg X)
      map := fun X Y => RingHom.asBoolalg }
#align BoolRing.has_forget_to_BoolAlg BoolRing.hasForgetToBoolAlg

@[simps]
instance BoolAlg.hasForgetToBoolRing : HasForget₂ BoolAlg BoolRing
    where forget₂ :=
    { obj := fun X => BoolRing.of (AsBoolring X)
      map := fun X Y => BoundedLatticeHom.asBoolring }
#align BoolAlg.has_forget_to_BoolRing BoolAlg.hasForgetToBoolRing

/-- The equivalence between Boolean rings and Boolean algebras. This is actually an isomorphism. -/
@[simps Functor inverse]
def boolRingEquivBoolAlg : BoolRing ≌ BoolAlg :=
  Equivalence.mk (forget₂ BoolRing BoolAlg) (forget₂ BoolAlg BoolRing)
    (NatIso.ofComponents (fun X => BoolRing.Iso.mk <| (RingEquiv.asBoolringAsBoolalg X).symm)
      fun X Y f => rfl)
    (NatIso.ofComponents (fun X => BoolAlg.Iso.mk <| OrderIso.asBoolalgAsBoolring X) fun X Y f =>
      rfl)
#align BoolRing_equiv_BoolAlg boolRingEquivBoolAlg


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.monoidal.functorial
import Mathlib.category_theory.monoidal.functor_category
import Mathlib.category_theory.limits.limits
import Mathlib.PostPort

universes u v

namespace Mathlib

/-!
# `lim : (J ⥤ C) ⥤ C` is lax monoidal when `C` is a monoidal category.

When `C` is a monoidal category, the functorial association `F ↦ limit F` is lax monoidal,
i.e. there are morphisms
* `lim_lax.ε : (𝟙_ C) → limit (𝟙_ (J ⥤ C))`
* `lim_lax.μ : limit F ⊗ limit G ⟶ limit (F ⊗ G)`
satisfying the laws of a lax monoidal functor.
-/

namespace category_theory.limits

protected instance limit_functorial {J : Type v} [small_category J] {C : Type u} [category C] [has_limits C] : functorial fun (F : J ⥤ C) => limit F :=
  functorial.mk (functor.map lim)

@[simp] theorem limit_functorial_map {J : Type v} [small_category J] {C : Type u} [category C] [has_limits C] {F : J ⥤ C} {G : J ⥤ C} (α : F ⟶ G) : map (fun (F : J ⥤ C) => limit F) α = functor.map lim α :=
  rfl

protected instance limit_lax_monoidal {J : Type v} [small_category J] {C : Type u} [category C] [has_limits C] [monoidal_category C] : lax_monoidal fun (F : J ⥤ C) => limit F :=
  lax_monoidal.mk (limit.lift (functor.obj (functor.const J) 𝟙_) (cone.mk 𝟙_ (nat_trans.mk fun (j : J) => 𝟙)))
    fun (F G : J ⥤ C) =>
      limit.lift (F ⊗ G) (cone.mk (limit F ⊗ limit G) (nat_trans.mk fun (j : J) => limit.π F j ⊗ limit.π G j))

/-- The limit functor `F ↦ limit F` bundled as a lax monoidal functor. -/
def lim_lax {J : Type v} [small_category J] {C : Type u} [category C] [has_limits C] [monoidal_category C] : lax_monoidal_functor (J ⥤ C) C :=
  lax_monoidal_functor.of fun (F : J ⥤ C) => limit F

@[simp] theorem lim_lax_obj {J : Type v} [small_category J] {C : Type u} [category C] [has_limits C] [monoidal_category C] (F : J ⥤ C) : functor.obj (lax_monoidal_functor.to_functor lim_lax) F = limit F :=
  rfl

theorem lim_lax_obj' {J : Type v} [small_category J] {C : Type u} [category C] [has_limits C] [monoidal_category C] (F : J ⥤ C) : functor.obj (lax_monoidal_functor.to_functor lim_lax) F = functor.obj lim F :=
  rfl

@[simp] theorem lim_lax_map {J : Type v} [small_category J] {C : Type u} [category C] [has_limits C] [monoidal_category C] {F : J ⥤ C} {G : J ⥤ C} (α : F ⟶ G) : functor.map (lax_monoidal_functor.to_functor lim_lax) α = functor.map lim α :=
  rfl

@[simp] theorem lim_lax_ε {J : Type v} [small_category J] {C : Type u} [category C] [has_limits C] [monoidal_category C] : lax_monoidal_functor.ε lim_lax =
  limit.lift (functor.obj (functor.const J) 𝟙_) (cone.mk 𝟙_ (nat_trans.mk fun (j : J) => 𝟙)) :=
  rfl

@[simp] theorem lim_lax_μ {J : Type v} [small_category J] {C : Type u} [category C] [has_limits C] [monoidal_category C] (F : J ⥤ C) (G : J ⥤ C) : lax_monoidal_functor.μ lim_lax F G =
  limit.lift (F ⊗ G) (cone.mk (limit F ⊗ limit G) (nat_trans.mk fun (j : J) => limit.π F j ⊗ limit.π G j)) :=
  rfl


/-
Copyright (c) 2022 Asta H. From. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Asta H. From, Jannis Limperg
-/
import Aesop

set_option aesop.check.all true

inductive Perm : (xs ys : List α) → Type where
  | prep {xs} x : Perm (x :: xs) (x :: xs)

inductive Proof : (Γ Δ : List Φ) → Prop where
  | basic (Γ Δ n) : Proof (n :: Γ) (n :: Δ)
  | per_l (Γ Γ' Δ) : Proof Γ Δ → Perm Γ' Γ → Proof Γ' Δ

theorem weaken (Γ Δ : List Φ) (prf : Proof Γ Δ) (δ : Φ) : Proof Γ (δ :: Δ) := by
  induction prf
  case basic Γ Δ n =>
    aesop (add unsafe [constructors Proof, constructors Perm])
      (options := { maxRuleApplications := 50, terminal := true })
  case per_l Γ Γ' Δ _ perm ih =>
    apply Proof.per_l Γ Γ' (δ :: Δ) ih perm


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

/-!
# Homology is an additive functor

When `V` is preadditive, `homological_complex V c` is also preadditive,
and `homology_functor` is additive.

TODO: similarly for `R`-linear.
-/

universes v u

open_locale classical
noncomputable theory

open category_theory category_theory.limits homological_complex

variables {ι : Type*}
variables {V : Type u} [category.{v} V] [preadditive V]

variables {c : complex_shape ι} {C D E : homological_complex V c}
variables (f g : C ⟶ D) (h k : D ⟶ E) (i : ι)

namespace homological_complex

instance : has_zero (C ⟶ D) := ⟨{ f := λ i, 0 }⟩
instance : has_add (C ⟶ D) := ⟨λ f g, { f := λ i, f.f i + g.f i, }⟩
instance : has_neg (C ⟶ D) := ⟨λ f, { f := λ i, -(f.f i), }⟩
instance : has_sub (C ⟶ D) := ⟨λ f g, { f := λ i, f.f i - g.f i, }⟩

@[simp] lemma zero_f_apply (i : ι) : (0 : C ⟶ D).f i = 0 := rfl
@[simp] lemma add_f_apply (f g : C ⟶ D) (i : ι) : (f + g).f i = f.f i + g.f i := rfl
@[simp] lemma neg_f_apply (f : C ⟶ D) (i : ι) : (-f).f i = -(f.f i) := rfl
@[simp] lemma sub_f_apply (f g : C ⟶ D) (i : ι) : (f - g).f i = f.f i - g.f i := rfl

/- TODO(jmc/Scott): the instance below doesn't have the correct defeq for `nsmul` and `zsmul`.
We should generalize `function.injective.add_comm_group` and friends.
For the `R`-linear version, it will be very convenient to have
a good definition of `nsmul` and `zsmul` that matches `smul`. -/

instance : add_comm_group (C ⟶ D) :=
function.injective.add_comm_group hom.f
  homological_complex.hom_f_injective (by tidy) (by tidy) (by tidy) (by tidy)

instance : preadditive (homological_complex V c) := {}

/-- The `i`-th component of a chain map, as an additive map from chain maps to morphisms. -/
@[simps]
def hom.f_add_monoid_hom {C₁ C₂ : homological_complex V c} (i : ι) :
  (C₁ ⟶ C₂) →+ (C₁.X i ⟶ C₂.X i) :=
add_monoid_hom.mk' (λ f, hom.f f i) (λ _ _, rfl)

end homological_complex

namespace homological_complex

instance eval_additive (i : ι) : (eval V c i).additive := {}

variables [has_zero_object V]

instance cycles_additive [has_equalizers V] : (cycles_functor V c i).additive := {}

variables [has_images V] [has_image_maps V]

instance boundaries_additive : (boundaries_functor V c i).additive := {}

variables [has_equalizers V] [has_cokernels V]

instance homology_additive : (homology_functor V c i).additive :=
{ map_add' := λ C D f g, begin
    dsimp [homology_functor],
    ext,
    simp only [homology.π_map, preadditive.comp_add, ←preadditive.add_comp],
    congr,
    ext, simp,
  end }

end homological_complex

namespace category_theory

variables {W : Type*} [category W] [preadditive W]

/--
An additive functor induces a functor between homological complexes.
This is sometimes called the "prolongation".
-/
@[simps]
def functor.map_homological_complex (F : V ⥤ W) [F.additive] (c : complex_shape ι) :
  homological_complex V c ⥤ homological_complex W c :=
{ obj := λ C,
  { X := λ i, F.obj (C.X i),
    d := λ i j, F.map (C.d i j),
    shape' := λ i j w, by rw [C.shape _ _ w, F.map_zero],
    d_comp_d' := λ i j k _ _, by rw [←F.map_comp, C.d_comp_d, F.map_zero], },
  map := λ C D f,
  { f := λ i, F.map (f.f i),
    comm' := λ i j h, by { dsimp,  rw [←F.map_comp, ←F.map_comp, f.comm], }, }, }.

instance functor.map_homogical_complex_additive
  (F : V ⥤ W) [F.additive] (c : complex_shape ι) : (F.map_homological_complex c).additive := {}

/--
A natural transformation between functors induces a natural transformation
between those functors applied to homological complexes.
-/
@[simps]
def nat_trans.map_homological_complex {F G : V ⥤ W} [F.additive] [G.additive]
  (α : F ⟶ G) (c : complex_shape ι) : F.map_homological_complex c ⟶ G.map_homological_complex c :=
{ app := λ C, { f := λ i, α.app _, }, }

@[simp] lemma nat_trans.map_homological_complex_id (c : complex_shape ι) (F : V ⥤ W) [F.additive] :
  nat_trans.map_homological_complex (𝟙 F) c = 𝟙 (F.map_homological_complex c) :=
by tidy

@[simp] lemma nat_trans.map_homological_complex_comp (c : complex_shape ι)
  {F G H : V ⥤ W} [F.additive] [G.additive] [H.additive]
  (α : F ⟶ G) (β : G ⟶ H):
  nat_trans.map_homological_complex (α ≫ β) c =
    nat_trans.map_homological_complex α c ≫ nat_trans.map_homological_complex β c :=
by tidy

@[simp, reassoc] lemma nat_trans.map_homological_complex_naturality {c : complex_shape ι}
  {F G : V ⥤ W} [F.additive] [G.additive] (α : F ⟶ G) {C D : homological_complex V c} (f : C ⟶ D) :
  (F.map_homological_complex c).map f ≫ (nat_trans.map_homological_complex α c).app D =
    (nat_trans.map_homological_complex α c).app C ≫ (G.map_homological_complex c).map f :=
by tidy

end category_theory

variables [has_zero_object V] {W : Type*} [category W] [preadditive W] [has_zero_object W]

namespace homological_complex

/--
Turning an object into a complex supported at `j` then applying a functor is
the same as applying the functor then forming the complex.
-/
def single_map_homological_complex (F : V ⥤ W) [F.additive] (c : complex_shape ι) (j : ι):
  single V c j ⋙ F.map_homological_complex _ ≅ F ⋙ single W c j :=
nat_iso.of_components (λ X,
{ hom := { f := λ i, if h : i = j then
    eq_to_hom (by simp [h])
  else
    0, },
  inv := { f := λ i, if h : i = j then
    eq_to_hom (by simp [h])
  else
    0, },
  hom_inv_id' := begin
    ext i,
    dsimp,
    split_ifs with h,
    { simp [h] },
    { rw [zero_comp, if_neg h],
      exact (zero_of_source_iso_zero _ F.map_zero_object).symm, },
  end,
  inv_hom_id' := begin
    ext i,
    dsimp,
    split_ifs with h,
    { simp [h] },
    { rw [zero_comp, if_neg h],
      simp, },
  end, })
  (λ X Y f, begin
    ext i,
    dsimp,
    split_ifs with h; simp [h],
  end).

variables (F : V ⥤ W) [functor.additive F] (c)

@[simp] lemma single_map_homological_complex_hom_app_self (j : ι) (X : V) :
  ((single_map_homological_complex F c j).hom.app X).f j = eq_to_hom (by simp) :=
by simp [single_map_homological_complex]
@[simp] lemma single_map_homological_complex_hom_app_ne
  {i j : ι} (h : i ≠ j) (X : V) :
  ((single_map_homological_complex F c j).hom.app X).f i = 0 :=
by simp [single_map_homological_complex, h]
@[simp] lemma single_map_homological_complex_inv_app_self (j : ι) (X : V) :
  ((single_map_homological_complex F c j).inv.app X).f j = eq_to_hom (by simp) :=
by simp [single_map_homological_complex]
@[simp] lemma single_map_homological_complex_inv_app_ne
  {i j : ι} (h : i ≠ j) (X : V):
  ((single_map_homological_complex F c j).inv.app X).f i = 0 :=
by simp [single_map_homological_complex, h]

end homological_complex

namespace chain_complex

-- TODO: dualize to cochain complexes

/--
Turning an object into a chain complex supported at zero then applying a functor is
the same as applying the functor then forming the complex.
-/
def single₀_map_homological_complex (F : V ⥤ W) [F.additive] :
  single₀ V ⋙ F.map_homological_complex _ ≅ F ⋙ single₀ W :=
nat_iso.of_components (λ X,
{ hom := { f := λ i, match i with
    | 0 := 𝟙 _
    | (i+1) := F.map_zero_object.hom
    end, },
  inv := { f := λ i, match i with
    | 0 := 𝟙 _
    | (i+1) := F.map_zero_object.inv
    end, },
  hom_inv_id' := begin
    ext (_|i),
    { unfold_aux, simp, },
    { unfold_aux,
      dsimp,
      simp only [comp_f, id_f, zero_comp],
      exact (zero_of_source_iso_zero _ F.map_zero_object).symm, }
  end,
  inv_hom_id' := by { ext (_|i); { unfold_aux, dsimp, simp, }, }, })
  (λ X Y f, by { ext (_|i); { unfold_aux, dsimp, simp, }, }).

@[simp]

end chain_complex


import Hw7
import Lean.Elab.Print
import Lean.Elab.Command

theorem desiredType : ∀ (α : Type) (A B : α → Prop), (∀ (x : α), A x → B x) → (∃ y, A y) → ∃ z, B z := sorry

open Lean
open Lean.Meta
open Lean.Elab.Command

def collectAxiomsOf (constName : Name) : MetaM (List String) := do
  let env ← getEnv
  let (_, s) := ((CollectAxioms.collect constName).run env).run {}
  let a := s.axioms.toList.map toString
  return a

#eval isDefEq (Expr.const ``desiredType []) (Expr.const ``problem1 [])
#eval collectAxiomsOf ``problem1