import definitions ralgebra

noncomputable theory
open set classical
local attribute [instance] prop_decidable

variables {X : Type*} [metric_space X] [compact_space X]

-- We adopt the notation of bounded countinuous function from mathlib
local infixr ` →ᵇ ` : 25 := bounded_continuous_function

/- This file contains all the non-proven propositions used by main.lean

Most of these lemmas are rather trivial. I aim to present a text proof alongside the
less trivial propositions. -/

-- compact.elim_finite_subcover require semilattices which we will assume
instance : semilattice_sup_bot (X →ᵇ ℝ) := sorry
instance : semilattice_inf_top (X →ᵇ ℝ) := sorry

variables {M₀ : set (X →ᵇ ℝ)}

-- The following 10 propositions are trivial
lemma le_finset_sup {I : finset X} (g : X → X →ᵇ ℝ) :
∀ i ∈ I, ∀ x : X, g i x ≤ (I.sup g) x := sorry

lemma finset_sup_lt {I : finset X} {g : X → X →ᵇ ℝ} {x} {r}
(hlt : ∀ i ∈ I, g i x < r) : (I.sup g) x < r := sorry

lemma finset_sup_mem_closure₀ {I : finset X} {g : X → X →ᵇ ℝ}
(hg : ∀ i, g i ∈ closure₀ M₀) : I.sup g ∈ closure₀ M₀ := sorry

lemma finset_inf_le {I : finset X} (g : X → X →ᵇ ℝ) :
∀ i ∈ I, ∀ x : X, (I.inf g) x ≤ g i x := sorry

lemma lt_finset_inf {I : finset X} {g : X → X →ᵇ ℝ} {x} {r}
(hlt : ∀ i ∈ I, r < g i x) : r < (I.inf g) x := sorry

lemma finset_inf_mem_closure₀ {I : finset X} {g : X → X →ᵇ ℝ}
(hg : ∀ i, g i ∈ closure₀ M₀) : I.inf g ∈ closure₀ M₀ := sorry

lemma is_open_aux_set₀ {f : X →ᵇ ℝ}
{g : X → X →ᵇ ℝ} {ε : ℝ} (hε : ε > 0) :
∀ y : X, is_open {z : X | f z - (g y) z < ε} := sorry

lemma is_open_aux_set₁ {f : X →ᵇ ℝ}
{g : X → X →ᵇ ℝ} {ε : ℝ} (hε : ε > 0) :
∀ x : X, is_open {z : X | g x z < f z + ε} := sorry

lemma neg_inf_eq_sup {f g h : X →ᵇ ℝ} : f = g ⊔ h ↔ -f = -g ⊓ -h := sorry
lemma neg_sup_eq_inf {f g h : X →ᵇ ℝ} : f = g ⊓ h ↔ -f = -g ⊔ -h := sorry

/- Follows by choosing the same δ from hF -/
lemma neg_unif_converges_to {f : X →ᵇ ℝ} {F : ℕ → (X →ᵇ ℝ)}
(hF : unif_converges_to (λ n, F n) f) : unif_converges_to (λ n, -F n) (-f) := sorry

/- The forward direction is true by mem_univ, the backwards is true by defining the function
such that ∀ z ∈ ℝ², f : X →ᵇ ℝ, (u : X) ↦ z.1 if u = x, else z.2 -/
lemma boundary_points_of_univ : ∀ x y : X, boundary_points univ x y = univ := sorry

/- This is true since M₀' is a subalgebra ⇒ 1 ∈ M₀'.carrier and
∀ μ ∈ ℝ, ∀ f ∈ M₀'.carrier, μf ∈ M₀'.carrier ⇒ r • 1 ∈ M₀'.carrier -/
lemma subalgebra_closed_under_smul' {M₀' : subalgebra ℝ (X →ᵇ ℝ)} :
∀ (α : ℝ) {x}, x ∈ M₀'.carrier → α • x ∈ M₀'.carrier := sorry

-- The following 4 propositions are trivial
lemma closure₂_of_closure₂ (M₀ : set (X →ᵇ ℝ)) :
closure₂ (closure₂ M₀) = closure₂ M₀ := sorry

lemma closure₀_closed_with_sup {M₀ : set (X →ᵇ ℝ)} {f g}
(hf : f ∈ closure₀ M₀) (hg : g ∈ closure₀ M₀) : f ⊔ g ∈ closure₀ M₀ := sorry

lemma closure₀_closed_with_inf {M₀ : set (X →ᵇ ℝ)} {f g}
(hf : f ∈ closure₀ M₀) (hg : g ∈ closure₀ M₀) : f ⊓ g ∈ closure₀ M₀ := sorry

lemma closure_le_seq₁ {M₀ : set (X →ᵇ ℝ)} :
closure₀ M₀ ⊆ closure₂ M₀ := sorry

/- To prove `closure₂_subalgebra` we need to first show that `closure₂ M₀'.carrier`
forms a subring. The is easily shown since M₀'.carrier ⊆ closure₂ M₀'.carrier and
closure₂ M₀'.carrier is closed.

We also need to show `range_le'` but this also follows directly from M₀'.carrier
⊆ closure₂ M₀'.carrier. -/
def closure₂_subalgebra (M₀' : subalgebra ℝ (X →ᵇ ℝ)) : subalgebra ℝ (X →ᵇ ℝ) :=
{ carrier := closure₂ M₀'.carrier,
  subring := sorry,
  range_le' := sorry}

/- This is the trivial subalgebra -/
def univ_subalgebra : subalgebra ℝ (X →ᵇ ℝ) :=
{ carrier := univ,
  subring := sorry,
  range_le' := sorry }


/-
Copyright (c) 2016 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.option.defs
import logic.nonempty
import tactic.cache

/-!
# Miscellaneous function constructions and lemmas
-/

universes u v w

namespace function

section
variables {α β γ : Sort*} {f : α → β}

/-- Evaluate a function at an argument. Useful if you want to talk about the partially applied
  `function.eval x : (Π x, β x) → β x`. -/
@[reducible] def eval {β : α → Sort*} (x : α) (f : Π x, β x) : β x := f x

@[simp] lemma eval_apply {β : α → Sort*} (x : α) (f : Π x, β x) : eval x f = f x := rfl

lemma comp_apply {α : Sort u} {β : Sort v} {φ : Sort w} (f : β → φ) (g : α → β) (a : α) :
  (f ∘ g) a = f (g a) := rfl

lemma const_def {y : β} : (λ x : α, y) = const α y := rfl

@[simp] lemma const_apply {y : β} {x : α} : const α y x = y := rfl

@[simp] lemma const_comp {f : α → β} {c : γ} : const β c ∘ f = const α c := rfl

@[simp] lemma comp_const {f : β → γ} {b : β} : f ∘ const α b = const α (f b) := rfl

lemma id_def : @id α = λ x, x := rfl

lemma hfunext {α α': Sort u} {β : α → Sort v} {β' : α' → Sort v} {f : Πa, β a} {f' : Πa, β' a}
  (hα : α = α') (h : ∀a a', a == a' → f a == f' a') : f == f' :=
begin
  subst hα,
  have : ∀a, f a == f' a,
  { intro a, exact h a a (heq.refl a) },
  have : β = β',
  { funext a, exact type_eq_of_heq (this a) },
  subst this,
  apply heq_of_eq,
  funext a,
  exact eq_of_heq (this a)
end

lemma funext_iff {β : α → Sort*} {f₁ f₂ : Π (x : α), β x} : f₁ = f₂ ↔ (∀ a, f₁ a = f₂ a) :=
iff.intro (assume h a, h ▸ rfl) funext

lemma ne_iff {β : α → Sort*} {f₁ f₂ : Π a, β a} : f₁ ≠ f₂ ↔ ∃ a, f₁ a ≠ f₂ a :=
funext_iff.not.trans not_forall

protected lemma bijective.injective {f : α → β} (hf : bijective f) : injective f := hf.1
protected lemma bijective.surjective {f : α → β} (hf : bijective f) : surjective f := hf.2

theorem injective.eq_iff (I : injective f) {a b : α} :
  f a = f b ↔ a = b :=
⟨@I _ _, congr_arg f⟩

theorem injective.eq_iff' (I : injective f) {a b : α} {c : β} (h : f b = c) :
  f a = c ↔ a = b :=
h ▸ I.eq_iff

lemma injective.ne (hf : injective f) {a₁ a₂ : α} : a₁ ≠ a₂ → f a₁ ≠ f a₂ :=
mt (assume h, hf h)

lemma injective.ne_iff (hf : injective f) {x y : α} : f x ≠ f y ↔ x ≠ y :=
⟨mt $ congr_arg f, hf.ne⟩

lemma injective.ne_iff' (hf : injective f) {x y : α} {z : β} (h : f y = z) :
  f x ≠ z ↔ x ≠ y :=
h ▸ hf.ne_iff

/-- If the co-domain `β` of an injective function `f : α → β` has decidable equality, then
the domain `α` also has decidable equality. -/
def injective.decidable_eq [decidable_eq β] (I : injective f) : decidable_eq α :=
λ a b, decidable_of_iff _ I.eq_iff

lemma injective.of_comp {g : γ → α} (I : injective (f ∘ g)) : injective g :=
λ x y h, I $ show f (g x) = f (g y), from congr_arg f h

lemma injective.of_comp_iff {f : α → β} (hf : injective f) (g : γ → α) :
  injective (f ∘ g) ↔ injective g :=
⟨injective.of_comp, hf.comp⟩

lemma injective.of_comp_iff' (f : α → β) {g : γ → α} (hg : bijective g) :
  injective (f ∘ g) ↔ injective f :=
⟨ λ h x y, let ⟨x', hx⟩ := hg.surjective x, ⟨y', hy⟩ := hg.surjective y in
    hx ▸ hy ▸ λ hf, h hf ▸ rfl,
  λ h, h.comp hg.injective⟩

/-- Composition by an injective function on the left is itself injective. -/
lemma injective.comp_left {g : β → γ} (hg : function.injective g) :
  function.injective ((∘) g : (α → β) → (α → γ)) :=
λ f₁ f₂ hgf, funext $ λ i, hg $ (congr_fun hgf i : _)

lemma injective_of_subsingleton [subsingleton α] (f : α → β) :
  injective f :=
λ a b ab, subsingleton.elim _ _

lemma injective.dite (p : α → Prop) [decidable_pred p]
  {f : {a : α // p a} → β} {f' : {a : α // ¬ p a} → β}
  (hf : injective f) (hf' : injective f')
  (im_disj : ∀ {x x' : α} {hx : p x} {hx' : ¬ p x'}, f ⟨x, hx⟩ ≠ f' ⟨x', hx'⟩) :
  function.injective (λ x, if h : p x then f ⟨x, h⟩ else f' ⟨x, h⟩) :=
λ x₁ x₂ h, begin
  dsimp only at h,
  by_cases h₁ : p x₁; by_cases h₂ : p x₂,
  { rw [dif_pos h₁, dif_pos h₂] at h, injection (hf h), },
  { rw [dif_pos h₁, dif_neg h₂] at h, exact (im_disj h).elim, },
  { rw [dif_neg h₁, dif_pos h₂] at h, exact (im_disj h.symm).elim, },
  { rw [dif_neg h₁, dif_neg h₂] at h, injection (hf' h), },
end

lemma surjective.of_comp {g : γ → α} (S : surjective (f ∘ g)) : surjective f :=
λ y, let ⟨x, h⟩ := S y in ⟨g x, h⟩

lemma surjective.of_comp_iff (f : α → β) {g : γ → α} (hg : surjective g) :
  surjective (f ∘ g) ↔ surjective f :=
⟨surjective.of_comp, λ h, h.comp hg⟩

lemma surjective.of_comp_iff' (hf : bijective f) (g : γ → α) :
  surjective (f ∘ g) ↔ surjective g :=
⟨λ h x, let ⟨x', hx'⟩ := h (f x) in ⟨x', hf.injective hx'⟩, hf.surjective.comp⟩

instance decidable_eq_pfun (p : Prop) [decidable p] (α : p → Type*)
  [Π hp, decidable_eq (α hp)] : decidable_eq (Π hp, α hp)
| f g := decidable_of_iff (∀ hp, f hp = g hp) funext_iff.symm

protected theorem surjective.forall (hf : surjective f) {p : β → Prop} :
  (∀ y, p y) ↔ ∀ x, p (f x) :=
⟨λ h x, h (f x), λ h y, let ⟨x, hx⟩ := hf y in hx ▸ h x⟩

protected theorem surjective.forall₂ (hf : surjective f) {p : β → β → Prop} :
  (∀ y₁ y₂, p y₁ y₂) ↔ ∀ x₁ x₂, p (f x₁) (f x₂) :=
hf.forall.trans $ forall_congr $ λ x, hf.forall

protected theorem surjective.forall₃ (hf : surjective f) {p : β → β → β → Prop} :
  (∀ y₁ y₂ y₃, p y₁ y₂ y₃) ↔ ∀ x₁ x₂ x₃, p (f x₁) (f x₂) (f x₃) :=
hf.forall.trans $ forall_congr $ λ x, hf.forall₂

protected theorem surjective.exists (hf : surjective f) {p : β → Prop} :
  (∃ y, p y) ↔ ∃ x, p (f x) :=
⟨λ ⟨y, hy⟩, let ⟨x, hx⟩ := hf y in ⟨x, hx.symm ▸ hy⟩, λ ⟨x, hx⟩, ⟨f x, hx⟩⟩

protected theorem surjective.exists₂ (hf : surjective f) {p : β → β → Prop} :
  (∃ y₁ y₂, p y₁ y₂) ↔ ∃ x₁ x₂, p (f x₁) (f x₂) :=
hf.exists.trans $ exists_congr $ λ x, hf.exists

protected theorem surjective.exists₃ (hf : surjective f) {p : β → β → β → Prop} :
  (∃ y₁ y₂ y₃, p y₁ y₂ y₃) ↔ ∃ x₁ x₂ x₃, p (f x₁) (f x₂) (f x₃) :=
hf.exists.trans $ exists_congr $ λ x, hf.exists₂

lemma surjective.injective_comp_right (hf : surjective f) :
  injective (λ g : β → γ, g ∘ f) :=
λ g₁ g₂ h, funext $ hf.forall.2 $ congr_fun h

protected lemma surjective.right_cancellable (hf : surjective f) {g₁ g₂ : β → γ} :
  g₁ ∘ f = g₂ ∘ f ↔ g₁ = g₂ :=
hf.injective_comp_right.eq_iff

lemma surjective_of_right_cancellable_Prop (h : ∀ g₁ g₂ : β → Prop, g₁ ∘ f = g₂ ∘ f → g₁ = g₂) :
  surjective f :=
begin
  specialize h (λ _, true) (λ y, ∃ x, f x = y) (funext $ λ x, _),
  { simp only [(∘), exists_apply_eq_apply] },
  { intro y,
    have : true = ∃ x, f x = y, from congr_fun h y,
    rw ← this, exact trivial }
end

lemma bijective_iff_exists_unique (f : α → β) : bijective f ↔
  ∀ b : β, ∃! (a : α), f a = b :=
⟨ λ hf b, let ⟨a, ha⟩ := hf.surjective b in ⟨a, ha, λ a' ha', hf.injective (ha'.trans ha.symm)⟩,
  λ he, ⟨
    λ a a' h, unique_of_exists_unique (he (f a')) h rfl,
    λ b, exists_of_exists_unique (he b) ⟩⟩

/-- Shorthand for using projection notation with `function.bijective_iff_exists_unique`. -/
protected lemma bijective.exists_unique {f : α → β} (hf : bijective f) (b : β) :
  ∃! (a : α), f a = b :=
(bijective_iff_exists_unique f).mp hf b

lemma bijective.exists_unique_iff {f : α → β} (hf : bijective f) {p : β → Prop} :
  (∃! y, p y) ↔ ∃! x, p (f x) :=
⟨λ ⟨y, hpy, hy⟩, let ⟨x, hx⟩ := hf.surjective y in ⟨x, by rwa hx,
  λ z (hz : p (f z)), hf.injective $ hx.symm ▸ hy _ hz⟩,
  λ ⟨x, hpx, hx⟩, ⟨f x, hpx, λ y hy,
    let ⟨z, hz⟩ := hf.surjective y in hz ▸ congr_arg f $ hx _ $ by rwa hz⟩⟩

lemma bijective.of_comp_iff (f : α → β) {g : γ → α} (hg : bijective g) :
  bijective (f ∘ g) ↔ bijective f :=
and_congr (injective.of_comp_iff' _ hg) (surjective.of_comp_iff _ hg.surjective)

lemma bijective.of_comp_iff' {f : α → β} (hf : bijective f) (g : γ → α) :
  function.bijective (f ∘ g) ↔ function.bijective g :=
and_congr (injective.of_comp_iff hf.injective _) (surjective.of_comp_iff' hf _)

/-- **Cantor's diagonal argument** implies that there are no surjective functions from `α`
to `set α`. -/
theorem cantor_surjective {α} (f : α → set α) : ¬ function.surjective f | h :=
let ⟨D, e⟩ := h (λ a, ¬ f a a) in
(iff_not_self (f D D)).1 $ iff_of_eq (congr_fun e D)

/-- **Cantor's diagonal argument** implies that there are no injective functions from `set α`
to `α`. -/
theorem cantor_injective {α : Type*} (f : (set α) → α) :
  ¬ function.injective f | i :=
cantor_surjective (λ a b, ∀ U, a = f U → U b) $
right_inverse.surjective (λ U, funext $ λ a, propext ⟨λ h, h U rfl, λ h' U' e, i e ▸ h'⟩)

/-- There is no surjection from `α : Type u` into `Type u`. This theorem
  demonstrates why `Type : Type` would be inconsistent in Lean. -/
theorem not_surjective_Type {α : Type u} (f : α → Type (max u v)) :
  ¬ surjective f :=
begin
  intro hf,
  let T : Type (max u v) := sigma f,
  cases hf (set T) with U hU,
  let g : set T → T := λ s, ⟨U, cast hU.symm s⟩,
  have hg : injective g,
  { intros s t h,
    suffices : cast hU (g s).2 = cast hU (g t).2,
    { simp only [cast_cast, cast_eq] at this, assumption },
    { congr, assumption } },
  exact cantor_injective g hg
end

/-- `g` is a partial inverse to `f` (an injective but not necessarily
  surjective function) if `g y = some x` implies `f x = y`, and `g y = none`
  implies that `y` is not in the range of `f`. -/
def is_partial_inv {α β} (f : α → β) (g : β → option α) : Prop :=
∀ x y, g y = some x ↔ f x = y

theorem is_partial_inv_left {α β} {f : α → β} {g} (H : is_partial_inv f g) (x) : g (f x) = some x :=
(H _ _).2 rfl

theorem injective_of_partial_inv {α β} {f : α → β} {g} (H : is_partial_inv f g) : injective f :=
λ a b h, option.some.inj $ ((H _ _).2 h).symm.trans ((H _ _).2 rfl)

theorem injective_of_partial_inv_right {α β} {f : α → β} {g} (H : is_partial_inv f g)
 (x y b) (h₁ : b ∈ g x) (h₂ : b ∈ g y) : x = y :=
((H _ _).1 h₁).symm.trans ((H _ _).1 h₂)

theorem left_inverse.comp_eq_id {f : α → β} {g : β → α} (h : left_inverse f g) : f ∘ g = id :=
funext h

theorem left_inverse_iff_comp {f : α → β} {g : β → α} : left_inverse f g ↔ f ∘ g = id :=
⟨left_inverse.comp_eq_id, congr_fun⟩

theorem right_inverse.comp_eq_id {f : α → β} {g : β → α} (h : right_inverse f g) : g ∘ f = id :=
funext h

theorem right_inverse_iff_comp {f : α → β} {g : β → α} : right_inverse f g ↔ g ∘ f = id :=
⟨right_inverse.comp_eq_id, congr_fun⟩

theorem left_inverse.comp {f : α → β} {g : β → α} {h : β → γ} {i : γ → β}
  (hf : left_inverse f g) (hh : left_inverse h i) : left_inverse (h ∘ f) (g ∘ i) :=
assume a, show h (f (g (i a))) = a, by rw [hf (i a), hh a]

theorem right_inverse.comp {f : α → β} {g : β → α} {h : β → γ} {i : γ → β}
  (hf : right_inverse f g) (hh : right_inverse h i) : right_inverse (h ∘ f) (g ∘ i) :=
left_inverse.comp hh hf

theorem left_inverse.right_inverse {f : α → β} {g : β → α} (h : left_inverse g f) :
  right_inverse f g := h

theorem right_inverse.left_inverse {f : α → β} {g : β → α} (h : right_inverse g f) :
  left_inverse f g := h

theorem left_inverse.surjective {f : α → β} {g : β → α} (h : left_inverse f g) :
  surjective f :=
h.right_inverse.surjective

theorem right_inverse.injective {f : α → β} {g : β → α} (h : right_inverse f g) :
  injective f :=
h.left_inverse.injective

theorem left_inverse.right_inverse_of_injective {f : α → β} {g : β → α} (h : left_inverse f g)
  (hf : injective f) :
  right_inverse f g :=
λ x, hf $ h (f x)

theorem left_inverse.right_inverse_of_surjective {f : α → β} {g : β → α} (h : left_inverse f g)
  (hg : surjective g) :
  right_inverse f g :=
λ x, let ⟨y, hy⟩ := hg x in hy ▸ congr_arg g (h y)

theorem left_inverse.eq_right_inverse {f : α → β} {g₁ g₂ : β → α} (h₁ : left_inverse g₁ f)
  (h₂ : right_inverse g₂ f) :
  g₁ = g₂ :=
calc g₁ = g₁ ∘ f ∘ g₂ : by rw [h₂.comp_eq_id, comp.right_id]
    ... = g₂          : by rw [← comp.assoc, h₁.comp_eq_id, comp.left_id]

local attribute [instance, priority 10] classical.prop_decidable

/-- We can use choice to construct explicitly a partial inverse for
  a given injective function `f`. -/
noncomputable def partial_inv {α β} (f : α → β) (b : β) : option α :=
if h : ∃ a, f a = b then some (classical.some h) else none

theorem partial_inv_of_injective {α β} {f : α → β} (I : injective f) :
  is_partial_inv f (partial_inv f) | a b :=
⟨λ h, if h' : ∃ a, f a = b then begin
    rw [partial_inv, dif_pos h'] at h,
    injection h with h, subst h,
    apply classical.some_spec h'
  end else by rw [partial_inv, dif_neg h'] at h; contradiction,
 λ e, e ▸ have h : ∃ a', f a' = f a, from ⟨_, rfl⟩,
   (dif_pos h).trans (congr_arg _ (I $ classical.some_spec h))⟩

theorem partial_inv_left {α β} {f : α → β} (I : injective f) : ∀ x, partial_inv f (f x) = some x :=
is_partial_inv_left (partial_inv_of_injective I)

end

section inv_fun

variables {α β : Sort*} [nonempty α] {f : α → β} {a : α} {b : β}
local attribute [instance, priority 10] classical.prop_decidable

/-- The inverse of a function (which is a left inverse if `f` is injective
  and a right inverse if `f` is surjective). -/
noncomputable def inv_fun (f : α → β) : β → α :=
λ y, if h : ∃ x, f x = y then h.some else classical.arbitrary α

theorem inv_fun_eq (h : ∃ a, f a = b) : f (inv_fun f b) = b :=
by simp only [inv_fun, dif_pos h, h.some_spec]

lemma inv_fun_neg (h : ¬ ∃ a, f a = b) : inv_fun f b = classical.choice ‹_› :=
dif_neg h

theorem inv_fun_eq_of_injective_of_right_inverse {g : β → α}
  (hf : injective f) (hg : right_inverse g f) : inv_fun f = g :=
funext $ assume b,
hf begin rw [hg b], exact inv_fun_eq ⟨g b, hg b⟩ end

lemma right_inverse_inv_fun (hf : surjective f) : right_inverse (inv_fun f) f :=
assume b, inv_fun_eq $ hf b

lemma left_inverse_inv_fun (hf : injective f) : left_inverse (inv_fun f) f :=
λ b, hf $ inv_fun_eq ⟨b, rfl⟩

lemma inv_fun_surjective (hf : injective f) : surjective (inv_fun f) :=
(left_inverse_inv_fun hf).surjective

lemma inv_fun_comp (hf : injective f) : inv_fun f ∘ f = id := funext $ left_inverse_inv_fun hf

lemma injective.has_left_inverse (hf : injective f) : has_left_inverse f :=
⟨inv_fun f, left_inverse_inv_fun hf⟩

lemma injective_iff_has_left_inverse : injective f ↔ has_left_inverse f :=
⟨injective.has_left_inverse, has_left_inverse.injective⟩

end inv_fun

section surj_inv
variables {α : Sort u} {β : Sort v} {γ : Sort w} {f : α → β}

/-- The inverse of a surjective function. (Unlike `inv_fun`, this does not require
  `α` to be inhabited.) -/
noncomputable def surj_inv {f : α → β} (h : surjective f) (b : β) : α := classical.some (h b)

lemma surj_inv_eq (h : surjective f) (b) : f (surj_inv h b) = b := classical.some_spec (h b)

lemma right_inverse_surj_inv (hf : surjective f) : right_inverse (surj_inv hf) f :=
surj_inv_eq hf

lemma left_inverse_surj_inv (hf : bijective f) : left_inverse (surj_inv hf.2) f :=
right_inverse_of_injective_of_left_inverse hf.1 (right_inverse_surj_inv hf.2)

lemma surjective.has_right_inverse (hf : surjective f) : has_right_inverse f :=
⟨_, right_inverse_surj_inv hf⟩

lemma surjective_iff_has_right_inverse : surjective f ↔ has_right_inverse f :=
⟨surjective.has_right_inverse, has_right_inverse.surjective⟩

lemma bijective_iff_has_inverse : bijective f ↔ ∃ g, left_inverse g f ∧ right_inverse g f :=
⟨λ hf, ⟨_, left_inverse_surj_inv hf, right_inverse_surj_inv hf.2⟩,
 λ ⟨g, gl, gr⟩, ⟨gl.injective,  gr.surjective⟩⟩

lemma injective_surj_inv (h : surjective f) : injective (surj_inv h) :=
(right_inverse_surj_inv h).injective

lemma surjective_to_subsingleton [na : nonempty α] [subsingleton β] (f : α → β) :
  surjective f :=
λ y, let ⟨a⟩ := na in ⟨a, subsingleton.elim _ _⟩

/-- Composition by an surjective function on the left is itself surjective. -/
lemma surjective.comp_left {g : β → γ} (hg : surjective g) :
  surjective ((∘) g : (α → β) → (α → γ)) :=
λ f, ⟨surj_inv hg ∘ f, funext $ λ x, right_inverse_surj_inv _ _⟩

/-- Composition by an bijective function on the left is itself bijective. -/
lemma bijective.comp_left {g : β → γ} (hg : bijective g) :
  bijective ((∘) g : (α → β) → (α → γ)) :=
⟨hg.injective.comp_left, hg.surjective.comp_left⟩

end surj_inv

section update
variables {α : Sort u} {β : α → Sort v} {α' : Sort w} [decidable_eq α] [decidable_eq α']

/-- Replacing the value of a function at a given point by a given value. -/
def update (f : Πa, β a) (a' : α) (v : β a') (a : α) : β a :=
if h : a = a' then eq.rec v h.symm else f a

/-- On non-dependent functions, `function.update` can be expressed as an `ite` -/
lemma update_apply {β : Sort*} (f : α → β) (a' : α) (b : β) (a : α) :
  update f a' b a = if a = a' then b else f a :=
begin
  dunfold update,
  congr,
  funext,
  rw eq_rec_constant,
end

@[simp] lemma update_same (a : α) (v : β a) (f : Πa, β a) : update f a v a = v :=
dif_pos rfl

lemma surjective_eval {α : Sort u} {β : α → Sort v} [h : Π a, nonempty (β a)] (a : α) :
  surjective (eval a : (Π a, β a) → β a) :=
λ b, ⟨@update _ _ (classical.dec_eq α) (λ a, (h a).some) a b,
  @update_same _ _ (classical.dec_eq α) _ _ _⟩

lemma update_injective (f : Πa, β a) (a' : α) : injective (update f a') :=
λ v v' h, have _ := congr_fun h a', by rwa [update_same, update_same] at this

@[simp] lemma update_noteq {a a' : α} (h : a ≠ a') (v : β a') (f : Πa, β a) :
  update f a' v a = f a :=
dif_neg h

lemma forall_update_iff (f : Π a, β a) {a : α} {b : β a} (p : Π a, β a → Prop) :
  (∀ x, p x (update f a b x)) ↔ p a b ∧ ∀ x ≠ a, p x (f x) :=
by { rw [← and_forall_ne a, update_same], simp { contextual := tt } }

lemma exists_update_iff (f : Π a, β a) {a : α} {b : β a} (p : Π a, β a → Prop) :
  (∃ x, p x (update f a b x)) ↔ p a b ∨ ∃ x ≠ a, p x (f x) :=
by { rw [← not_forall_not, forall_update_iff f (λ a b, ¬p a b)], simp [not_and_distrib] }

lemma update_eq_iff {a : α} {b : β a} {f g : Π a, β a} :
  update f a b = g ↔ b = g a ∧ ∀ x ≠ a, f x = g x :=
funext_iff.trans $ forall_update_iff _ (λ x y, y = g x)

lemma eq_update_iff {a : α} {b : β a} {f g : Π a, β a} :
  g = update f a b ↔ g a = b ∧ ∀ x ≠ a, g x = f x :=
funext_iff.trans $ forall_update_iff _ (λ x y, g x = y)

@[simp] lemma update_eq_self (a : α) (f : Πa, β a) : update f a (f a) = f :=
update_eq_iff.2 ⟨rfl, λ _ _, rfl⟩

lemma update_comp_eq_of_forall_ne' {α'} (g : Π a, β a) {f : α' → α} {i : α} (a : β i)
  (h : ∀ x, f x ≠ i) :
  (λ j, (update g i a) (f j)) = (λ j, g (f j)) :=
funext $ λ x, update_noteq (h _) _ _

/-- Non-dependent version of `function.update_comp_eq_of_forall_ne'` -/
lemma update_comp_eq_of_forall_ne {α β : Sort*} (g : α' → β) {f : α → α'} {i : α'} (a : β)
  (h : ∀ x, f x ≠ i) :
  (update g i a) ∘ f = g ∘ f :=
update_comp_eq_of_forall_ne' g a h

lemma update_comp_eq_of_injective' (g : Π a, β a) {f : α' → α} (hf : function.injective f)
  (i : α') (a : β (f i)) :
  (λ j, update g (f i) a (f j)) = update (λ i, g (f i)) i a :=
eq_update_iff.2 ⟨update_same _ _ _, λ j hj, update_noteq (hf.ne hj) _ _⟩

/-- Non-dependent version of `function.update_comp_eq_of_injective'` -/
lemma update_comp_eq_of_injective {β : Sort*} (g : α' → β) {f : α → α'}
  (hf : function.injective f) (i : α) (a : β) :
  (function.update g (f i) a) ∘ f = function.update (g ∘ f) i a :=
update_comp_eq_of_injective' g hf i a

lemma apply_update {ι : Sort*} [decidable_eq ι] {α β : ι → Sort*}
  (f : Π i, α i → β i) (g : Π i, α i) (i : ι) (v : α i) (j : ι) :
  f j (update g i v j) = update (λ k, f k (g k)) i (f i v) j :=
begin
  by_cases h : j = i,
  { subst j, simp },
  { simp [h] }
end

lemma apply_update₂ {ι : Sort*} [decidable_eq ι] {α β γ : ι → Sort*}
  (f : Π i, α i → β i → γ i) (g : Π i, α i) (h : Π i, β i) (i : ι) (v : α i) (w : β i) (j : ι) :
  f j (update g i v j) (update h i w j) = update (λ k, f k (g k) (h k)) i (f i v w) j :=
begin
  by_cases h : j = i,
  { subst j, simp },
  { simp [h] }
end

lemma comp_update {α' : Sort*} {β : Sort*} (f : α' → β) (g : α → α') (i : α) (v : α') :
  f ∘ (update g i v) = update (f ∘ g) i (f v) :=
funext $ apply_update _ _ _ _

theorem update_comm {α} [decidable_eq α] {β : α → Sort*}
  {a b : α} (h : a ≠ b) (v : β a) (w : β b) (f : Πa, β a) :
  update (update f a v) b w = update (update f b w) a v :=
begin
  funext c, simp only [update],
  by_cases h₁ : c = b; by_cases h₂ : c = a; try {simp [h₁, h₂]},
  cases h (h₂.symm.trans h₁),
end

@[simp] theorem update_idem {α} [decidable_eq α] {β : α → Sort*}
  {a : α} (v w : β a) (f : Πa, β a) : update (update f a v) a w = update f a w :=
by {funext b, by_cases b = a; simp [update, h]}

end update

section extend

noncomputable theory
local attribute [instance, priority 10] classical.prop_decidable

variables {α β γ : Sort*} {f : α → β}

/-- `extend f g e'` extends a function `g : α → γ`
along a function `f : α → β` to a function `β → γ`,
by using the values of `g` on the range of `f`
and the values of an auxiliary function `e' : β → γ` elsewhere.

Mostly useful when `f` is injective. -/
def extend (f : α → β) (g : α → γ) (e' : β → γ) : β → γ :=
λ b, if h : ∃ a, f a = b then g (classical.some h) else e' b

lemma extend_def (f : α → β) (g : α → γ) (e' : β → γ) (b : β) [decidable (∃ a, f a = b)] :
  extend f g e' b = if h : ∃ a, f a = b then g (classical.some h) else e' b :=
by { unfold extend, congr }

@[simp] lemma extend_apply (hf : injective f) (g : α → γ) (e' : β → γ) (a : α) :
  extend f g e' (f a) = g a :=
begin
  simp only [extend_def, dif_pos, exists_apply_eq_apply],
  exact congr_arg g (hf $ classical.some_spec (exists_apply_eq_apply f a))
end

@[simp] lemma extend_apply' (g : α → γ) (e' : β → γ) (b : β) (hb : ¬∃ a, f a = b) :
  extend f g e' b = e' b :=
by simp [function.extend_def, hb]

lemma apply_extend {δ} (hf : injective f) (F : γ → δ) (g : α → γ) (e' : β → γ) (b : β) :
  F (extend f g e' b) = extend f (F ∘ g) (F ∘ e') b :=
begin
  by_cases hb : ∃ a, f a = b,
  { cases hb with a ha, subst b,
    rw [extend_apply hf, extend_apply hf] },
  { rw [extend_apply' _ _ _ hb, extend_apply' _ _ _ hb] }
end

lemma extend_injective (hf : injective f) (e' : β → γ) :
  injective (λ g, extend f g e') :=
begin
  intros g₁ g₂ hg,
  refine funext (λ x, _),
  have H := congr_fun hg (f x),
  simp only [hf, extend_apply] at H,
  exact H
end

@[simp] lemma extend_comp (hf : injective f) (g : α → γ) (e' : β → γ) :
  extend f g e' ∘ f = g :=
funext $ λ a, extend_apply hf g e' a

lemma injective.surjective_comp_right' (hf : injective f) (g₀ : β → γ) :
  surjective (λ g : β → γ, g ∘ f) :=
λ g, ⟨extend f g g₀, extend_comp hf _ _⟩

lemma injective.surjective_comp_right [nonempty γ] (hf : injective f) :
  surjective (λ g : β → γ, g ∘ f) :=
hf.surjective_comp_right' (λ _, classical.choice ‹_›)

lemma bijective.comp_right (hf : bijective f) :
  bijective (λ g : β → γ, g ∘ f) :=
⟨hf.surjective.injective_comp_right,
  λ g, ⟨g ∘ surj_inv hf.surjective,
    by simp only [comp.assoc g _ f, (left_inverse_surj_inv hf).comp_eq_id, comp.right_id]⟩⟩

end extend

lemma uncurry_def {α β γ} (f : α → β → γ) : uncurry f = (λp, f p.1 p.2) :=
rfl

@[simp] lemma uncurry_apply_pair {α β γ} (f : α → β → γ) (x : α) (y : β) :
  uncurry f (x, y) = f x y :=
rfl

@[simp] lemma curry_apply {α β γ} (f : α × β → γ) (x : α) (y : β) :
  curry f x y = f (x, y) :=
rfl

section bicomp
variables {α β γ δ ε : Type*}

/-- Compose a binary function `f` with a pair of unary functions `g` and `h`.
If both arguments of `f` have the same type and `g = h`, then `bicompl f g g = f on g`. -/
def bicompl (f : γ → δ → ε) (g : α → γ) (h : β → δ) (a b) :=
f (g a) (h b)

/-- Compose an unary function `f` with a binary function `g`. -/
def bicompr (f : γ → δ) (g : α → β → γ) (a b) :=
f (g a b)

-- Suggested local notation:
local notation f `∘₂` g := bicompr f g

lemma uncurry_bicompr (f : α → β → γ) (g : γ → δ) :
  uncurry (g ∘₂ f) = (g ∘ uncurry f) := rfl

end bicomp

section uncurry

variables {α β γ δ : Type*}

/-- Records a way to turn an element of `α` into a function from `β` to `γ`. The most generic use
is to recursively uncurry. For instance `f : α → β → γ → δ` will be turned into
`↿f : α × β × γ → δ`. One can also add instances for bundled maps. -/
class has_uncurry (α : Type*) (β : out_param Type*) (γ : out_param Type*) := (uncurry : α → (β → γ))

/-- Uncurrying operator. The most generic use is to recursively uncurry. For instance
`f : α → β → γ → δ` will be turned into `↿f : α × β × γ → δ`. One can also add instances
for bundled maps.-/
add_decl_doc has_uncurry.uncurry

notation `↿`:max x:max := has_uncurry.uncurry x

instance has_uncurry_base : has_uncurry (α → β) α β := ⟨id⟩

instance has_uncurry_induction [has_uncurry β γ δ] : has_uncurry (α → β) (α × γ) δ :=
⟨λ f p, ↿(f p.1) p.2⟩

end uncurry

/-- A function is involutive, if `f ∘ f = id`. -/
def involutive {α} (f : α → α) : Prop := ∀ x, f (f x) = x

lemma involutive_iff_iter_2_eq_id {α} {f : α → α} : involutive f ↔ (f^[2] = id) :=
funext_iff.symm

namespace involutive
variables {α : Sort u} {f : α → α} (h : involutive f)
include h

@[simp]
lemma comp_self : f ∘ f = id := funext h

protected lemma left_inverse : left_inverse f f := h
protected lemma right_inverse : right_inverse f f := h

protected lemma injective : injective f := h.left_inverse.injective
protected lemma surjective : surjective f := λ x, ⟨f x, h x⟩
protected lemma bijective : bijective f := ⟨h.injective, h.surjective⟩

/-- Involuting an `ite` of an involuted value `x : α` negates the `Prop` condition in the `ite`. -/
protected lemma ite_not (P : Prop) [decidable P] (x : α) :
  f (ite P x (f x)) = ite (¬ P) x (f x) :=
by rw [apply_ite f, h, ite_not]

/-- An involution commutes across an equality. Compare to `function.injective.eq_iff`. -/
protected lemma eq_iff {x y : α} : f x = y ↔ x = f y :=
h.injective.eq_iff' (h y)

end involutive

/-- The property of a binary function `f : α → β → γ` being injective.
Mathematically this should be thought of as the corresponding function `α × β → γ` being injective.
-/
def injective2 {α β γ} (f : α → β → γ) : Prop :=
∀ ⦃a₁ a₂ b₁ b₂⦄, f a₁ b₁ = f a₂ b₂ → a₁ = a₂ ∧ b₁ = b₂

namespace injective2
variables {α β γ : Sort*} {f : α → β → γ}

/-- A binary injective function is injective when only the left argument varies. -/
protected lemma left (hf : injective2 f) (b : β) : function.injective (λ a, f a b) :=
λ a₁ a₂ h, (hf h).left

/-- A binary injective function is injective when only the right argument varies. -/
protected lemma right (hf : injective2 f) (a : α) : function.injective (f a) :=
λ a₁ a₂ h, (hf h).right

protected lemma uncurry {α β γ : Type*} {f : α → β → γ} (hf : injective2 f) :
  function.injective (uncurry f) :=
λ ⟨a₁, b₁⟩ ⟨a₂, b₂⟩ h, and.elim (hf h) (congr_arg2 _)

/-- As a map from the left argument to a unary function, `f` is injective. -/
lemma left' (hf : injective2 f) [nonempty β] : function.injective f :=
λ a₁ a₂ h, let ⟨b⟩ := ‹nonempty β› in hf.left b $ (congr_fun h b : _)

/-- As a map from the right argument to a unary function, `f` is injective. -/
lemma right' (hf : injective2 f) [nonempty α] : function.injective (λ b a, f a b) :=
λ b₁ b₂ h, let ⟨a⟩ := ‹nonempty α› in hf.right a $ (congr_fun h a : _)

lemma eq_iff (hf : injective2 f) {a₁ a₂ b₁ b₂} : f a₁ b₁ = f a₂ b₂ ↔ a₁ = a₂ ∧ b₁ = b₂ :=
⟨λ h, hf h, and.rec $ congr_arg2 f⟩

end injective2

section sometimes
local attribute [instance, priority 10] classical.prop_decidable

/-- `sometimes f` evaluates to some value of `f`, if it exists. This function is especially
interesting in the case where `α` is a proposition, in which case `f` is necessarily a
constant function, so that `sometimes f = f a` for all `a`. -/
noncomputable def sometimes {α β} [nonempty β] (f : α → β) : β :=
if h : nonempty α then f (classical.choice h) else classical.choice ‹_›

theorem sometimes_eq {p : Prop} {α} [nonempty α] (f : p → α) (a : p) : sometimes f = f a :=
dif_pos ⟨a⟩

theorem sometimes_spec {p : Prop} {α} [nonempty α]
  (P : α → Prop) (f : p → α) (a : p) (h : P (f a)) : P (sometimes f) :=
by rwa sometimes_eq

end sometimes

end function

/-- `s.piecewise f g` is the function equal to `f` on the set `s`, and to `g` on its complement. -/
def set.piecewise {α : Type u} {β : α → Sort v} (s : set α) (f g : Πi, β i)
  [∀j, decidable (j ∈ s)] :
  Πi, β i :=
λi, if i ∈ s then f i else g i

/-! ### Bijectivity of `eq.rec`, `eq.mp`, `eq.mpr`, and `cast` -/

lemma eq_rec_on_bijective {α : Sort*} {C : α → Sort*} :
  ∀ {a a' : α} (h : a = a'), function.bijective (@eq.rec_on _ _ C _ h)
| _ _ rfl := ⟨λ x y, id, λ x, ⟨x, rfl⟩⟩

lemma eq_mp_bijective {α β : Sort*} (h : α = β) : function.bijective (eq.mp h) :=
eq_rec_on_bijective h

lemma eq_mpr_bijective {α β : Sort*} (h : α = β) : function.bijective (eq.mpr h) :=
eq_rec_on_bijective h.symm

lemma cast_bijective {α β : Sort*} (h : α = β) : function.bijective (cast h) :=
eq_rec_on_bijective h

/-! Note these lemmas apply to `Type*` not `Sort*`, as the latter interferes with `simp`, and
is trivial anyway.-/

@[simp]
lemma eq_rec_inj {α : Sort*} {a a' : α} (h : a = a') {C : α → Type*} (x y : C a) :
  (eq.rec x h : C a') = eq.rec y h ↔ x = y :=
(eq_rec_on_bijective h).injective.eq_iff

@[simp]
lemma cast_inj {α β : Type*} (h : α = β) {x y : α} : cast h x = cast h y ↔ x = y :=
(cast_bijective h).injective.eq_iff

/-- A set of functions "separates points"
if for each pair of distinct points there is a function taking different values on them. -/
def set.separates_points {α β : Type*} (A : set (α → β)) : Prop :=
∀ ⦃x y : α⦄, x ≠ y → ∃ f ∈ A, (f x : β) ≠ f y

lemma is_symm_op.flip_eq {α β} (op) [is_symm_op α β op] : flip op = op :=
funext $ λ a, funext $ λ b, (is_symm_op.symm_op a b).symm

lemma inv_image.equivalence {α : Sort u} {β : Sort v} (r : β → β → Prop) (f : α → β)
  (h : equivalence r) : equivalence (inv_image r f) :=
⟨λ _, h.1 _, λ _ _ x, h.2.1 x, inv_image.trans r f h.2.2⟩


import Lens

structure Foo (α β : Type) where
  x : Nat
  y : α
  z : List (α × β)
  deriving Lenses

variable {α β : Type}

#check (Foo.Lens.x : Lens (Foo α β) Nat)
#check (Foo.Lens.y : Lens (Foo α β) α)
#check (Foo.Lens.z : Lens (Foo α β) (List (α × β)))

structure Bar (α β : Type) where
  foo : Foo α β
  deriving Lenses

namespace Lens
open Foo.Lens Bar.Lens

variable (a : Bar Nat Nat)

def bar : Bar Nat Nat :=
a & foo /. x %~ (. + 3)

#check (Bar.Lens.foo : Lens (Bar α β) (Foo α β))
#check (Bar.Lens.foo /. Foo.Lens.x : Lens (Bar α β) Nat)

def test := bar ⟨ { x := 1, y := 0, z := [] } ⟩

theorem check' : test = ⟨ { x := 4, y := 0, z := [] } ⟩ :=
rfl

end Lens


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

import for_mathlib.dold_kan.equivalence_additive
import for_mathlib.dold_kan.compatibility
import category_theory.idempotents.simplicial_object
import for_mathlib.idempotents.karoubi_misc
import for_mathlib.idempotents.homological_complex

/-!

# The Dold-Kan correspondence for pseudoabelian categories

In this file, for any idempotent complete additive category `C`,
the Dold-Kan equivalence
`idempotents.dold_kan.equivalence C : simplicial_object C ≌ chain_complex C ℕ`
is obtained. It is deduced from the equivalence
`preadditive.dold_kan.equivalence` between the respective idempotent
completions of these categories using the fact that when `C` is idempotent complete,
then both `simplicial_object C` and `chain_complex C ℕ` are idempotent complete.

The construction of `idempotents.dold_kan.equivalence` uses the tools
introduced in the file `compatibility.lean`. Doing so, the functor
`idempotents.dold_kan.N` of the equivalence is
the composition of `N₁ : simplicial_object C ⥤ karoubi (chain_complex C ℕ)`
(defined in `functor_n.lean`) and the inverse of the equivalence
`chain_complex C ℕ ≌ karoubi (chain_complex C ℕ)`. The functor
`idempotents.dold_kan.Γ` of the equivalence is by definition the functor
`Γ₀` introduced in `functor_gamma.lean`.

-/

noncomputable theory

open category_theory
open category_theory.category
open category_theory.limits
open category_theory.idempotents

variables {C : Type*} [category C] [is_idempotent_complete C]
  [preadditive C] [has_finite_coproducts C]

namespace category_theory

namespace idempotents

namespace dold_kan

open algebraic_topology.dold_kan

/-- The functor `N` for the equivalence is obtained by composing
`N' : simplicial_object C ⥤ karoubi (chain_complex C ℕ)` and the inverse
of the equivalence `chain_complex C ℕ ≌ karoubi (chain_complex C ℕ)`. -/
@[simps, nolint unused_arguments]
def N : simplicial_object C ⥤ chain_complex C ℕ :=
N₁ ⋙ (to_karoubi_equivalence _).inverse

/-- The functor `Γ` for the equivalence is `Γ'`. -/
@[simps, nolint unused_arguments]
def Γ : chain_complex C ℕ ⥤ simplicial_object C := Γ₀

lemma hN₁ : (to_karoubi_equivalence (simplicial_object C)).functor ⋙
  preadditive.dold_kan.equivalence.functor = N₁ :=
functor.congr_obj (functor_extension₁_comp_whiskering_left_to_karoubi _ _) N₁

lemma hΓ₀ : (to_karoubi_equivalence (chain_complex C ℕ)).functor ⋙
  preadditive.dold_kan.equivalence.inverse = Γ ⋙ (to_karoubi_equivalence _).functor :=
functor.congr_obj (functor_extension₂_comp_whiskering_left_to_karoubi _ _) Γ₀

/-- The Dold-Kan equivalence for pseudoabelian categories given
by the functors `N` and `Γ`. It is obtained by applying the results in
`compatibility.lean` to the equivalence `preadditive.dold_kan.equivalence`. -/
def equivalence : simplicial_object C ≌ chain_complex C ℕ :=
compatibility.equivalence (eq_to_iso hN₁) (eq_to_iso hΓ₀)

lemma equivalence_functor : (equivalence : simplicial_object C ≌ _).functor = N := by refl
lemma equivalence_inverse : (equivalence : simplicial_object C ≌ _).inverse = Γ := by refl

/-- The natural isomorphism `NΓ' satisfies the compatibility that is needed
for the construction of our counit isomorphism `η` -/
lemma hη : compatibility.τ₀ =
  compatibility.τ₁ (eq_to_iso hN₁) (eq_to_iso hΓ₀)
  (N₁Γ₀ : Γ ⋙ N₁ ≅ (to_karoubi_equivalence (chain_complex C ℕ)).functor) :=
begin
  ext K : 3,
  simpa only [compatibility.τ₀_hom_app, compatibility.τ₁_hom_app, eq_to_iso.hom,
    preadditive.dold_kan.equivalence_counit_iso, N₂Γ₂_to_karoubi_iso_hom, eq_to_hom_map,
    eq_to_hom_trans_assoc, eq_to_hom_app] using N₂Γ₂_compatible_with_N₁Γ₀ K,
end

/-- The counit isomorphism induced by `N₁Γ₀` -/
@[simps]
def η : Γ ⋙ N ≅ 𝟭 (chain_complex C ℕ) := compatibility.equivalence_counit_iso
  (N₁Γ₀ : (Γ : chain_complex C ℕ ⥤ _ ) ⋙ N₁ ≅ (to_karoubi_equivalence _).functor)

lemma equivalence_counit_iso :
  dold_kan.equivalence.counit_iso = (η : Γ ⋙ N ≅ 𝟭 (chain_complex C ℕ)) :=
compatibility.equivalence_counit_iso_eq hη

local attribute [-simp, reassoc] nat_trans.comp_app

lemma hε : compatibility.υ (eq_to_iso hN₁) =
  (Γ₂N₁ : (to_karoubi_equivalence _).functor ≅ (N₁ : simplicial_object C ⥤ _) ⋙
  preadditive.dold_kan.equivalence.inverse) :=
begin
  ext X : 4,
  erw [nat_trans.comp_app, compatibility_Γ₂N₁_Γ₂N₂_nat_trans],
  simp only [compatibility.υ_hom_app, compatibility_Γ₂N₁_Γ₂N₂,
    preadditive.dold_kan.equivalence_unit_iso, Γ₂N₂, iso.symm_hom, as_iso_inv, assoc],
  erw [← nat_trans.comp_app_assoc, is_iso.hom_inv_id],
  dsimp,
  simpa only [id_comp, eq_to_hom_app, eq_to_hom_map, eq_to_hom_trans],
end

/-- The unit isomorphism induced by `Γ₂N₁`. -/
@[simps]
def ε : 𝟭 (simplicial_object C) ≅ N ⋙ Γ :=
compatibility.equivalence_unit_iso (eq_to_iso hΓ₀) Γ₂N₁

lemma equivalence_unit_iso : dold_kan.equivalence.unit_iso =
  (ε : 𝟭 (simplicial_object C) ≅ N ⋙ Γ) :=
compatibility.equivalence_unit_iso_eq hε

end dold_kan

end idempotents

end category_theory


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

import for_mathlib.idempotents.karoubi

/-!
# Idempotent completeness and functor categories

In this file we define an instance `functor_category_is_idempotent_complete` expressing
that a functor category `J ⥤ C` is idempotent complete when the target category `C` is.

We also provide a fully faithful functor
`karoubi_functor_category_embedding : karoubi (J ⥤ C)) : J ⥤ karoubi C` for all categories
`J` and `C`.

-/

open category_theory
open category_theory.category
open category_theory.idempotents.karoubi
open category_theory.limits

namespace category_theory

namespace idempotents

variables (J C : Type*) [category J] [category C]

instance functor_category_is_idempotent_complete [is_idempotent_complete C] :
  is_idempotent_complete (J ⥤ C) :=
begin
  refine ⟨_⟩,
  intros F p hp,
  have hC := (is_idempotent_complete_iff_has_equalizer_of_id_and_idempotent C).mp infer_instance,
  haveI : ∀ (j : J), has_equalizer (𝟙 _) (p.app j) := λ j, hC _ _ (congr_app hp j),
  /- We construct the direct factor `Y` associated to `p : F ⟶ F` by computing
    the equalizer of the identity and `p.app j` on each object `(j : J)`.  -/
  let Y : J ⥤ C :=
  { obj := λ j, limits.equalizer (𝟙 _) (p.app j),
    map := λ j j' φ, equalizer.lift (limits.equalizer.ι (𝟙 _) (p.app j) ≫ F.map φ)
      (by rw [comp_id, assoc, p.naturality φ, ← assoc, ← limits.equalizer.condition, comp_id]),
    map_id' := λ j, by { ext, simp only [comp_id, functor.map_id, equalizer.lift_ι, id_comp], },
    map_comp' := λ j j' j'' φ φ', begin
      ext,
      simp only [assoc, functor.map_comp, equalizer.lift_ι, equalizer.lift_ι_assoc],
    end },
  let i : Y ⟶ F :=
  { app := λ j, equalizer.ι _ _,
    naturality' := λ j j' φ, by rw [equalizer.lift_ι],  },
  let e : F ⟶ Y :=
  { app := λ j, equalizer.lift (p.app j)
      (by { rw comp_id, exact (congr_app hp j).symm, }),
    naturality' := λ j j' φ, begin
      ext,
      simp only [assoc, equalizer.lift_ι, nat_trans.naturality, equalizer.lift_ι_assoc],
    end },
  use [Y, i, e],
  split; ext j,
  { simp only [nat_trans.comp_app, assoc, equalizer.lift_ι, nat_trans.id_app, id_comp,
      ← equalizer.condition, comp_id], },
  { simp only [nat_trans.comp_app, equalizer.lift_ι], },
end

namespace karoubi_functor_category_embedding

variables {J C}

/-- On objects, the functor which sends a formal direct factor `P` of a
functor `F : J ⥤ C` to the functor `J ⥤ karoubi C` which sends `(j : J)` to
the corresponding direct factor of `F.obj j`. -/
@[simps]
def obj (P : karoubi (J ⥤ C)) : J ⥤ karoubi C :=
{ obj := λ j, ⟨P.X.obj j, P.p.app j, congr_app P.idem j⟩,
  map := λ j j' φ,
  { f := P.p.app j ≫ P.X.map φ,
    comm := begin
      simp only [nat_trans.naturality, assoc],
      have h := congr_app P.idem j,
      rw [nat_trans.comp_app] at h,
      slice_rhs 1 3 { erw [h, h], },
    end },
  map_id' := λ j, by { ext, simp only [functor.map_id, comp_id, id_eq], },
  map_comp' := λ j j' j'' φ φ', begin
    ext,
    have h := congr_app P.idem j,
    rw [nat_trans.comp_app] at h,
    simp only [assoc, nat_trans.naturality_assoc, functor.map_comp, comp],
    slice_rhs 1 2 { rw h, },
    rw [assoc],
  end }

/-- Tautological action on maps of the functor `karoubi (J ⥤ C) ⥤ (J ⥤ karoubi C)`. -/
@[simps]
def map {P Q : karoubi (J ⥤ C)} (f : P ⟶ Q) : obj P ⟶ obj Q :=
{ app := λ j, ⟨f.f.app j, congr_app f.comm j⟩,
  naturality' := λ j j' φ, begin
    ext,
    simp only [comp],
    have h := congr_app (comp_p f) j,
    have h' := congr_app (p_comp f) j',
    dsimp at h h' ⊢,
    slice_rhs 1 2 { erw h, },
    rw ← P.p.naturality,
    slice_lhs 2 3 { erw h', },
    rw f.f.naturality,
  end }

end karoubi_functor_category_embedding

variables (J C)

/-- The tautological fully faithful functor `karoubi (J ⥤ C) ⥤ (J ⥤ karoubi C)`. -/
@[simps]
def karoubi_functor_category_embedding :
  karoubi (J ⥤ C) ⥤ (J ⥤ karoubi C) :=
{ obj := karoubi_functor_category_embedding.obj,
  map := λ P Q, karoubi_functor_category_embedding.map,
  map_id' := λ P, rfl,
  map_comp' := λ P Q R f g, rfl, }

instance : full (karoubi_functor_category_embedding J C) :=
{ preimage := λ P Q f,
  { f :=
    { app := λ j, (f.app j).f,
      naturality' := λ j j' φ, begin
        slice_rhs 1 1 { rw ← karoubi.comp_p, },
        have h := hom_ext.mp (f.naturality φ),
        simp only [comp] at h,
        dsimp [karoubi_functor_category_embedding] at h ⊢,
        erw [assoc, ← h, ← P.p.naturality φ, assoc, p_comp (f.app j')],
      end },
    comm := by { ext j, exact (f.app j).comm, } },
  witness' := λ P Q f, by { ext j, refl, }, }

instance : faithful (karoubi_functor_category_embedding J C) :=
{ map_injective' := λ P Q f f' h, by { ext j, exact hom_ext.mp (congr_app h j), }, }

/-- The composition of `(J ⥤ C) ⥤ karoubi (J ⥤ C)` and `karoubi (J ⥤ C) ⥤ (J ⥤ karoubi C)`
equals the functor `(J ⥤ C) ⥤ (J ⥤ karoubi C)` given by the composition with
`to_karoubi C : C ⥤ karoubi C`. -/
lemma to_karoubi_comp_karoubi_functor_category_embedding :
  (to_karoubi _) ⋙ karoubi_functor_category_embedding J C =
  (whiskering_right J _ _).obj (to_karoubi C) :=
begin
  refine functor.ext _ _ ,
  { intro X,
    refine functor.ext (λ j, rfl) _,
    { intros j j' φ,
      ext,
      dsimp,
      simpa only [comp_id, id_comp], },  },
  { intros X Y f,
    ext j,
    dsimp [to_karoubi],
    simp only [eq_to_hom_app, eq_to_hom_refl, id_comp],
    erw [comp_id], },
end

variables {J C}

@[simp, reassoc]
lemma app_idem (P : karoubi (J ⥤ C)) (X : J) :
  P.p.app X ≫ P.p.app X = P.p.app X := congr_app P.idem X

namespace nat_trans

@[simp, reassoc]
lemma app_p_comp {P Q : karoubi (J ⥤ C)} (f : P ⟶ Q) (X : J) :
  P.p.app X ≫ f.f.app X = f.f.app X :=
congr_app (p_comp f) X

@[simp, reassoc]
lemma app_comp_p {P Q : karoubi (J ⥤ C)} (f : P ⟶ Q) (X : J) :
  f.f.app X ≫ Q.p.app X = f.f.app X :=
congr_app (comp_p f) X

@[reassoc]
lemma app_p_comm {P Q : karoubi (J ⥤ C)} (f : P ⟶ Q) (X : J) :
  P.p.app X ≫ f.f.app X = f.f.app X ≫ Q.p.app X :=
congr_app (p_comm f) X

end nat_trans

end idempotents

end category_theory


import Days
import Days.Common
import Std
import Lean.Data.Parsec

open Days
open Days.Common
open Std (RBSet Queue RBMap)
open Lean.Parsec
open Lean (Parsec)

namespace Days.Day11
def day: ProblemNumber := 11

def sample := "Monkey 0:
  Starting items: 79, 98
  Operation: new = old * 19
  Test: divisible by 23
    If true: throw to monkey 2
    If false: throw to monkey 3

Monkey 1:
  Starting items: 54, 65, 75, 74
  Operation: new = old + 6
  Test: divisible by 19
    If true: throw to monkey 2
    If false: throw to monkey 0

Monkey 2:
  Starting items: 79, 60, 97
  Operation: new = old * old
  Test: divisible by 13
    If true: throw to monkey 1
    If false: throw to monkey 3

Monkey 3:
  Starting items: 74
  Operation: new = old + 3
  Test: divisible by 17
    If true: throw to monkey 0
    If false: throw to monkey 1"

structure Item where
  worry: Nat
  deriving Inhabited

instance : Repr Item where
  reprPrec i _ := .text s!"w={i.worry}"

instance : OfNat Item n where
  ofNat := .mk n

abbrev Items := Array Item

abbrev MonkeyId := Nat

structure Monkey where
  id: MonkeyId
  items: Items
  worryModifier: Nat → Nat
  testVal: Nat
  trueTarget: MonkeyId
  falseTarget: MonkeyId
  observedItems: Nat := 0

instance : Inhabited Monkey where
  default := Monkey.mk 0 ∅ id 1 0 0 0

instance : Repr Monkey where
  reprPrec m _ := .text s!"Moneky({m.id}) \{ items := {reprArg m.items} t:{m.trueTarget} f:{m.falseTarget} }"

abbrev Map (key: Type) [Ord key]  (value: Type) := RBMap key value compare

abbrev MonkeyMap := Map MonkeyId Monkey

structure WorryState where
  worry: Nat

export Functor (map)

/--
Needs to parse strings like:
- `Operation: new = old * 19`
- `Operation: new = old * old`
- `Operation: new = old + 6`
- `Operation: new = old * 19`
-/
def parseWorryOperation : Parsec $ Nat -> Nat := do
  _ ← pstring "Operation: new = "
  return ← operation
  where
    opFunction: Parsec $ Nat → Nat → Nat := do
      let op ← ws *> (pchar '*' <|> pchar '+') <* ws
      return match op with
      | '*' => fun (x₁ x₂: Nat) => x₁ * x₂
      | '+' => fun (x₁ x₂: Nat) => x₁ + x₂
      | u => fun (_ _: Nat) => panic! s!"Unknown op: {u}"
    operand : Parsec $ Nat → Nat :=
      return match ← pstring "old" <|> many1Chars digit with
      | "old" => id
      | digits =>
        let num := String.toNat! digits
        fun _ => num
    operation : Parsec $ Nat → Nat := do
      let op₁ ← operand
      let f ← opFunction
      let op₂ ← operand
      return fun (worry: Nat) =>
        f (op₁ worry) (op₂ worry)

def parseNat : Parsec Nat := map String.toNat! $ many1Chars digit
def parseItemsList: Parsec $ Items := many1 (map Item.mk $ parseNat <* (attempt (pchar ',' *> ws) <|> skip))

#eval "1, 2, 3".iter |> parseItemsList

/--
Parses:

```
Monkey 0:
  Starting items: 79, 98
  Operation: new = old * 19
  Test: divisible by 23
    If true: throw to monkey 2
    If false: throw to monkey 3
```
-/
def parseMonkey: Parsec Monkey := do
  let monkeyNumber ← ws *> pstring "Monkey" *> ws *> parseNat <* pchar ':' <* ws
  let items: Array Item ← pstring "Starting items:" *> ws *> parseItemsList <* ws
  let itemQueue : Items := items -- (∅ : Items).enqueueAll items.toList
  let op ← ws *> parseWorryOperation <* ws
  let test ← testVal
  let trueTarget ← pstring "If true: throw to monkey " *> parseNat <* ws
  let falseTarget ← pstring "If false: throw to monkey " *> parseNat <* ws

  return Monkey.mk monkeyNumber itemQueue op test trueTarget falseTarget 0
  where
    testVal := pstring "Test: divisible by " *> ws *> parseNat <* ws

def parseMonkeys : Parsec MonkeyMap := do
  let allMonkeys ← many1 parseMonkey
  return allMonkeys.foldl (init:=∅) (λ map m =>
    map.insert m.id m
  )

#eval parseMonkeys sample.iter

def monkey₀ := Monkey.mk 0 #[79, 98] (·*19) 23 2 3 0
def monkey₁ := Monkey.mk 1 #[54, 65, 75, 74] (·+6) 19 2 0 0
def monkey₂ := Monkey.mk 2 #[79, 60, 97] (λ x => x * x) 13 1 3 0
def monkey₃ := Monkey.mk 3 #[74] (·+3) 17 0 1 0

def monkeyExamples : MonkeyMap :=
  [
    (0, monkey₀),
    (1, monkey₁),
    (2, monkey₂),
    (3, monkey₃)
  ].toRBMap compare

def processMonkeyItem (monkey: Monkey) (worryReducer: Nat → Nat) (map: MonkeyMap) (item: Item) : MonkeyMap :=
  let worryFromInspection := monkey.worryModifier item.worry
  -- After each monkey inspects an item but before it tests your worry level,
  -- your relief that the monkey's inspection didn't damage the item
  -- causes your worry level to be divided by three and rounded down to the nearest integer.
  let worryAfterInspection : Nat := worryReducer worryFromInspection

  -- Cheat: Since all monkeys test for division using primes we can just use
  -- modular arithmetic under the ring of (m₁.testVal * m₂.testVal * ...)
  -- (is that the LCM? i think so since they're all primes...)
  -- This works because modular math and at least one of the monkeys tests will always match
  -- First i thought about finding a co-prime to be a divisor,
  -- but then they're all primes (and the example was 3 which would have been co-prime)...
  -- so that would be easy and also didn't work
  let coprimeReduction (n: Nat) : Nat :=
    let ring := map.foldl (init:=1) (λ co _ v => co * v.testVal)
    n % ring
  let boundedWorry := coprimeReduction worryAfterInspection
  let target :=
    if divisibleBy monkey.testVal boundedWorry
    then monkey.trueTarget
    else monkey.falseTarget

  let newItem : Item := Item.mk boundedWorry

  map.modify target (λ m =>
      let items: Items := #[].append m.items |>.push newItem
      { m with items }
  )
  where
    divisibleBy (n val: Nat) : Bool := val % n == 0

def processMonkey (monkey: Monkey) (map: MonkeyMap) (worryReducer: Nat → Nat := (·/3)) : MonkeyMap :=
  monkey.items.foldl (init:=removedItems) (processMonkeyItem monkey worryReducer)
  where
    removedItems := map.modify monkey.id (λ m => { m with items := ∅, observedItems := monkey.observedItems + monkey.items.size })

#eval monkeyExamples
  |> processMonkey monkey₀
#eval monkeyExamples
  |> processMonkey monkey₀
  |> processMonkey monkey₁
#eval monkeyExamples
  |> processMonkey monkey₀
  |> processMonkey monkey₁
  |> processMonkey monkey₂

#eval monkeyExamples
  |> (λ x => processMonkey (x.find? 0).get! x)
  |> (λ x => processMonkey (x.find? 1).get! x)
  |> (λ x => processMonkey (x.find? 2).get! x)
  |> (λ x => processMonkey (x.find? 3).get! x)

#eval monkeyExamples
  |> processMonkey monkey₀
  |> processMonkey monkey₁
  |> processMonkey monkey₂
  |> processMonkey monkey₃
  |>.find? 1

#eval monkeyExamples
  |> processMonkey monkey₀
  |> processMonkey monkey₁
  |> processMonkey monkey₂
  |>.find? 3

def monkeysRound (map: MonkeyMap) (worryReducer: Nat → Nat := (·/3)) : MonkeyMap :=
  map.foldl (init:=map) (λ map id _ =>
    processMonkey (map.find? id).get! map worryReducer
  )

#eval monkeyExamples |> monkeysRound

def parseAll [ToInput i] (input: i) : MonkeyMap :=
  match parseMonkeys (toInput input).iter with
  | .success _ monkies => monkies
  | .error pos msg => panic! s!"Oops: {msg} @ {pos}"

def runRounds (rounds: Nat) (worryReducer: Nat → Nat) : StateM (MonkeyMap × Array (Nat ×  MonkeyMap)) Unit := do
  for _round in [1:rounds+1] do
    let (current, history) ← get
    let round := monkeysRound current worryReducer
    set $ (round, history.push (_round, round))

abbrev MonkeyCountMap := Map MonkeyId Nat

def roundHistory [ToInput κ] (input: κ) (rounds: Nat) (worryReducer: Nat → Nat := (·/3)) : Array $ Nat × MonkeyMap :=
  let initialMonkeys := parseAll (toInput input)
  let result := StateT.run (runRounds rounds worryReducer) (initialMonkeys, #[(0, initialMonkeys)])
  let (_, history): MonkeyMap × Array (Nat × MonkeyMap) := result.snd
  history

#eval roundHistory sample 20

def run [ToInput κ] (input: κ) (rounds: Nat) (worryReducer: Nat → Nat := (·/3)) : Array Nat :=
  roundHistory input rounds worryReducer
  |>.map (λ ((_, round): Nat × MonkeyMap) =>
    round.foldl (init:=∅) (λ (state: MonkeyCountMap) (k: MonkeyId) (m: Monkey) =>
      state.insert k m.observedItems
    )
  )
  |>.lastD ∅
  |>.valuesArray
  |>.qsort (Ordering.lt == compare · ·)

#eval run sample 20
/--
-/
def part₁ (input: Input) : Nat :=
  let rounds := 20
  run input rounds
  |>.lastN 2
  |> Subarray.toArray
  |>.toList
  |> mul 1

/--
-/
def part₂ (input: Input) : Nat :=
  let rounds := 10000
  run input rounds id
  |>.lastN 2
  |> Subarray.toArray
  |>.toList
  |> mul 1

def solution : Problem Nat := ⟨ day, part₁, part₂ ⟩

#eval testPart₁ solution sample (expect:=10605)
-- #eval testPart₂ solution sample (expect:=0)


/-
Copyright (c) 2022 Yaël Dillies, Kexing Ying. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies, Kexing Ying
-/
import combinatorics.hall.basic
import combinatorics.simple_graph.acyclic
import combinatorics.simple_graph.clique
import data.real.sqrt
import set_theory.cardinal.basic

/-!
# Graph Theory, example sheet 2

Here are the statements (and hopefully soon proofs!) of the questions from the second example sheet
of the Cambridge Part II course Graph Theory.

If you solve a question in Lean, feel free to open a Pull Request on Github!
-/

/-!
### Question 1

For a graph $$G$$, show that $$κ(G) ≤ λ(G) ≤ δ(G)$$.
-/

/-!
### Question 2

Let $$G be a graph. Show that $$e(G) > {χ(G) \choose 2}$$.
-/

/-!
### Question 3

Let $$G$$ be a $$k$$-connected graph and let $$y, x_1, \dots, x_k$$ be distinct vertices in $$G$$.
Show that there exists paths $$P_1, \dots, P_k$$, where $$P_i$$ is a $$y − x_i$$ path and
$$P_1, \dots, P_k$$ have no vertices in common, apart from the vertex $$y$$.
-/

/-!
### Question 4

An independent set in a graph $$G = (V, E)$$ is a subset $$I ⊆ V$$ so that $$x ≁ y$$ for all
$$x, y ∈ I$$. Let $$G = (V, E)$$ be a connected graph with $$∆(G) ≤ 3$$ and $$|V| ≥ 10$$. Show that
there exists an independent set $$I ⊆ V$$ so that every odd cycle in $$G$$ intersects $$I$$.
-/

/-!
### Question 5

Determine the chromatic polynomial of the $$n$$-cycle $$C_n$$.
-/

/-!
### Question 6

Let $$G$$ be a graph on $$n$$ vertices, show that the coefficients of the chromatic polynomial
$$P_G$$ alternate in sign. That is, if $$P_G = P_ni=0 cit
i
, Then cn−j > 0 for even j and cn−j 6 0 for odd j. Also
show that if G has m edges and k triangles then cn−2 =
m
2

− k.
-/

/-!
### Question 7

Determine $$χ(K_{n,n}$$). Determine $$χ(K_n)$$.
-/

/-!
### Question 8

Let $$G$$ be a graph that has an orientation where the longest directed path has length $$t$$ (that
is, a sequence of oriented edges $$(v_1, v_2), \dots, (v_t, v_{t + 1})$$. Then $$χ(G) ≤ t + 1$$.
-/

/-!
### Question 9

Can $$K_{4, 4}$$ be drawn on the torus? What about $$K_{5, 5}$$?
-/

/-!
### Question 10

Let $$G$$ be a bipartite graph with maximum degree $$∆$$. Must we have $$χ(G) = ∆(G)$$?
-/

/-!
### Question 11

Let $$G = (V, E)$$ be a graph where $$V$$, $$E$$ are countably infinite. Show that $$χ(G) ≤ k$$ if
and only if $$χ(H) ≤ k$$ for every finite subgraph $$H$$ of $$G$$.
-/

/-!
### Question 12

For $$k > 2$$, let $$G = (V, E)$$ be a $$k$$-connected graph and let $${x_1, \dots, x_k} ⊆ V$$. Show
that there exists a cycle containing each of the vertices $$x_1, \dots, x_k$$.
-/

/-!
### Question 13

For each $$r > 2$$, construct a graph $$G$$ that does not contain a $$K_{r + 1}$$ and $$χ(G) > r$$.
-/

/-!
### Question 14

A graph is outer-planar if it can be drawn in the plane so that all of its vertices are on the
infinite face. Articulate a conjecture of the form “Let $$G$$ be a graph with $$|G| > 5$$. $$G$$ is
outer-planar if and only if ...”. Prove your conjecture.
-/

/-!
### Question 15

Show there is a triangle free graph with chromatic number $$2022$$.
-/

/-!
### Question 16

Let $$G$$ be a triangulation (a plane graph where every face is a triangle) and let $$G◦$$ be the
planar dual of $$G$$: the vertices of $$G◦$$ are the faces of $$G$$ and edges in $$G◦$$ join faces
that share a boundary edge (in $$G$$). Prove that $$χ(G) ≤ 4$$ if and only if $$χ(G◦) ≤ 3$$.
-/


/-
Copyright (c) 2022 Oliver Nash. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Oliver Nash
-/
import dynamics.ergodic.measure_preserving

/-!
# Ergodic maps and measures

Let `f : α → α` be measure preserving with respect to a measure `μ`. We say `f` is ergodic with
respect to `μ` (or `μ` is ergodic with respect to `f`) if the only measurable sets `s` such that
`f⁻¹' s = s` are either almost empty or full.

In this file we define ergodic maps / measures together with quasi-ergodic maps / measures and
provide some basic API. Quasi-ergodicity is a weaker condition than ergodicity for which the measure
preserving condition is relaxed to quasi measure preserving.

# Main definitions:

 * `pre_ergodic`: the ergodicity condition without the measure preserving condition. This exists
   to share code between the `ergodic` and `quasi_ergodic` definitions.
 * `ergodic`: the definition of ergodic maps / measures.
 * `quasi_ergodic`: the definition of quasi ergodic maps / measures.
 * `ergodic.quasi_ergodic`: an ergodic map / measure is quasi ergodic.
 * `quasi_ergodic.ae_empty_or_univ'`: when the map is quasi measure preserving, one may relax the
   strict invariance condition to almost invariance in the ergodicity condition.

-/

open set function filter measure_theory measure_theory.measure
open_locale ennreal

variables {α : Type*} {m : measurable_space α} (f : α → α) {s : set α}
include m

/-- A map `f : α → α` is said to be pre-ergodic with respect to a measure `μ` if any measurable
strictly invariant set is either almost empty or full. -/
structure pre_ergodic (μ : measure α . volume_tac) : Prop :=
(ae_empty_or_univ : ∀ ⦃s⦄, measurable_set s → f⁻¹' s = s → s =ᵐ[μ] (∅ : set α) ∨ s =ᵐ[μ] univ)

/-- A map `f : α → α` is said to be ergodic with respect to a measure `μ` if it is measure
preserving and pre-ergodic. -/
@[nolint has_nonempty_instance] structure ergodic (μ : measure α . volume_tac) extends
  measure_preserving f μ μ, pre_ergodic f μ : Prop

/-- A map `f : α → α` is said to be quasi ergodic with respect to a measure `μ` if it is quasi
measure preserving and pre-ergodic. -/
@[nolint has_nonempty_instance] structure quasi_ergodic (μ : measure α . volume_tac) extends
  quasi_measure_preserving f μ μ, pre_ergodic f μ : Prop

variables {f} {μ : measure α}

namespace pre_ergodic

lemma measure_self_or_compl_eq_zero (hf : pre_ergodic f μ)
  (hs : measurable_set s) (hs' : f⁻¹' s = s) :
  μ s = 0 ∨ μ sᶜ = 0 :=
by simpa using hf.ae_empty_or_univ hs hs'

/-- On a probability space, the (pre)ergodicity condition is a zero one law. -/
lemma prob_eq_zero_or_one [is_probability_measure μ] (hf : pre_ergodic f μ)
  (hs : measurable_set s) (hs' : f⁻¹' s = s) :
  μ s = 0 ∨ μ s = 1 :=
by simpa [hs] using hf.measure_self_or_compl_eq_zero hs hs'

lemma of_iterate (n : ℕ) (hf : pre_ergodic (f^[n]) μ) : pre_ergodic f μ :=
⟨λ s hs hs', hf.ae_empty_or_univ hs $ is_fixed_pt.preimage_iterate hs' n⟩

end pre_ergodic

namespace measure_theory.measure_preserving

variables {β : Type*} {m' : measurable_space β} {μ' : measure β} {s' : set β} {g : α → β}

lemma pre_ergodic_of_pre_ergodic_conjugate (hg : measure_preserving g μ μ')
  (hf : pre_ergodic f μ) {f' : β → β} (h_comm : g ∘ f = f' ∘ g) :
  pre_ergodic f' μ' :=
⟨begin
  intros s hs₀ hs₁,
  replace hs₁ : f⁻¹' (g⁻¹' s) = g⁻¹' s, { rw [← preimage_comp, h_comm, preimage_comp, hs₁], },
  cases hf.ae_empty_or_univ (hg.measurable hs₀) hs₁ with hs₂ hs₂;
  [left, right],
  { simpa only [ae_eq_empty, hg.measure_preimage hs₀] using hs₂, },
  { simpa only [ae_eq_univ, ← preimage_compl, hg.measure_preimage hs₀.compl] using hs₂, },
end⟩

lemma pre_ergodic_conjugate_iff {e : α ≃ᵐ β} (h : measure_preserving e μ μ') :
  pre_ergodic (e ∘ f ∘ e.symm) μ' ↔ pre_ergodic f μ :=
begin
  refine ⟨λ hf, pre_ergodic_of_pre_ergodic_conjugate (h.symm e) hf _,
          λ hf, pre_ergodic_of_pre_ergodic_conjugate h hf _⟩,
  { change (e.symm ∘ e) ∘ f ∘ e.symm = f ∘ e.symm,
    rw [measurable_equiv.symm_comp_self, comp.left_id], },
  { change e ∘ f = e ∘ f ∘ e.symm ∘ e,
    rw [measurable_equiv.symm_comp_self, comp.right_id], },
end

lemma ergodic_conjugate_iff {e : α ≃ᵐ β} (h : measure_preserving e μ μ') :
  ergodic (e ∘ f ∘ e.symm) μ' ↔ ergodic f μ :=
begin
  have : measure_preserving (e ∘ f ∘ e.symm) μ' μ' ↔ measure_preserving f μ μ :=
    by rw [h.comp_left_iff, (measure_preserving.symm e h).comp_right_iff],
  replace h : pre_ergodic (e ∘ f ∘ e.symm) μ' ↔ pre_ergodic f μ := h.pre_ergodic_conjugate_iff,
  exact ⟨λ hf, { .. this.mp hf.to_measure_preserving, .. h.mp hf.to_pre_ergodic, },
         λ hf, { .. this.mpr hf.to_measure_preserving, .. h.mpr hf.to_pre_ergodic, }⟩,
end

end measure_theory.measure_preserving

namespace quasi_ergodic

/-- For a quasi ergodic map, sets that are almost invariant (rather than strictly invariant) are
still either almost empty or full. -/
lemma ae_empty_or_univ'
  (hf : quasi_ergodic f μ) (hs : measurable_set s) (hs' : f⁻¹' s =ᵐ[μ] s) :
  s =ᵐ[μ] (∅ : set α) ∨ s =ᵐ[μ] univ :=
begin
  obtain ⟨t, h₀, h₁, h₂⟩ := hf.to_quasi_measure_preserving.exists_preimage_eq_of_preimage_ae hs hs',
  rcases hf.ae_empty_or_univ h₀ h₂ with h₃ | h₃;
  [left, right];
  exact ae_eq_trans h₁.symm h₃,
end

end quasi_ergodic

namespace ergodic

/-- An ergodic map is quasi ergodic. -/
lemma quasi_ergodic (hf : ergodic f μ) : quasi_ergodic f μ :=
{ .. hf.to_pre_ergodic,
  .. hf.to_measure_preserving.quasi_measure_preserving, }

/-- See also `ergodic.ae_empty_or_univ_of_preimage_ae_le`. -/
lemma ae_empty_or_univ_of_preimage_ae_le'
  (hf : ergodic f μ) (hs : measurable_set s) (hs' : f⁻¹' s ≤ᵐ[μ] s) (h_fin : μ s ≠ ∞) :
  s =ᵐ[μ] (∅ : set α) ∨ s =ᵐ[μ] univ :=
begin
  refine hf.quasi_ergodic.ae_empty_or_univ' hs _,
  refine ae_eq_of_ae_subset_of_measure_ge hs' (hf.measure_preimage hs).symm.le _ h_fin,
  exact measurable_set_preimage hf.measurable hs,
end

/-- See also `ergodic.ae_empty_or_univ_of_ae_le_preimage`. -/
lemma ae_empty_or_univ_of_ae_le_preimage'
  (hf : ergodic f μ) (hs : measurable_set s) (hs' : s ≤ᵐ[μ] f⁻¹' s) (h_fin : μ s ≠ ∞) :
  s =ᵐ[μ] (∅ : set α) ∨ s =ᵐ[μ] univ :=
begin
  replace h_fin : μ (f⁻¹' s) ≠ ∞, { rwa hf.measure_preimage hs, },
  refine hf.quasi_ergodic.ae_empty_or_univ' hs _,
  exact (ae_eq_of_ae_subset_of_measure_ge hs' (hf.measure_preimage hs).le hs h_fin).symm,
end

/-- See also `ergodic.ae_empty_or_univ_of_image_ae_le`. -/
lemma ae_empty_or_univ_of_image_ae_le'
  (hf : ergodic f μ) (hs : measurable_set s) (hs' : f '' s ≤ᵐ[μ] s) (h_fin : μ s ≠ ∞) :
  s =ᵐ[μ] (∅ : set α) ∨ s =ᵐ[μ] univ :=
begin
  replace hs' : s ≤ᵐ[μ] f ⁻¹' s :=
    (has_subset.subset.eventually_le (subset_preimage_image f s)).trans
    (hf.quasi_measure_preserving.preimage_mono_ae hs'),
  exact ae_empty_or_univ_of_ae_le_preimage' hf hs hs' h_fin,
end

section is_finite_measure

variables [is_finite_measure μ]

lemma ae_empty_or_univ_of_preimage_ae_le
  (hf : ergodic f μ) (hs : measurable_set s) (hs' : f⁻¹' s ≤ᵐ[μ] s) :
  s =ᵐ[μ] (∅ : set α) ∨ s =ᵐ[μ] univ :=
ae_empty_or_univ_of_preimage_ae_le' hf hs hs' $ measure_ne_top μ s

lemma ae_empty_or_univ_of_ae_le_preimage
  (hf : ergodic f μ) (hs : measurable_set s) (hs' : s ≤ᵐ[μ] f⁻¹' s) :
  s =ᵐ[μ] (∅ : set α) ∨ s =ᵐ[μ] univ :=
ae_empty_or_univ_of_ae_le_preimage' hf hs hs' $ measure_ne_top μ s

lemma ae_empty_or_univ_of_image_ae_le
  (hf : ergodic f μ) (hs : measurable_set s) (hs' : f '' s ≤ᵐ[μ] s) :
  s =ᵐ[μ] (∅ : set α) ∨ s =ᵐ[μ] univ :=
ae_empty_or_univ_of_image_ae_le' hf hs hs' $ measure_ne_top μ s

end is_finite_measure

end ergodic


/-
Copyright (c) 2022 Jun Yoshida. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
-/

import Mathlib.Data.List.Basic

namespace List

universe u v w

theorem map_comp {α : Type u} {β : Type v} {γ : Type w} (g : β → γ) (f : α → β) : ∀ {as : List α}, map (g∘ f) as = map g (as.map f) := by
  intro as
  induction as
  case nil => rfl
  case cons a as h_ind =>
    dsimp [map]
    rw [h_ind]

theorem join_append {α : Type u} : ∀ (ass bss : List (List α)), (ass ++ bss).join = ass.join ++ bss.join
| [], bss => rfl
| (as::ass), bss => by
  dsimp [join]
  rw [List.append_assoc, join_append ass bss]

theorem join_join {α : Type u} : ∀ (asss : List (List (List α))), asss.join.join = (asss.map join).join
| [] => rfl
| cons as asss => by
  dsimp [join]
  rw [join_append, join_join asss]

theorem map_join {α : Type u} {β : Type v} (f : α → β) : ∀ {ass : List (List α)}, map f ass.join = join (map (map f) ass)
| [] => rfl
| (as::ass) => by
  dsimp [join]
  rw [map_append, map_join f (ass:=ass)]

end List


import to_mathlib
import data.fin
import Rings.ToMathlib.fin

namespace dvector

variables {α : Type*} {n : ℕ}

lemma nil_append (as : dvector α n) :
  dvector.append dvector.nil as = as :=
by simp

/-- Converts a dvector into an n-ary tuple -/
@[simp] def fin_val (as : dvector α n) : fin n → α :=
λ k, dvector.nth' as k
 @[simp] lemma cons_nth'_succ_eq_nth' {n} {x : α} {as : dvector α n} {k : fin n} :
(dvector.cons x as).nth' (k.succ) = as.nth' k :=
begin
  unfold dvector.nth',
  simp,
end

/-- x_val is the same data as concatenation of dvectors -/
lemma fin_val_eq_x_val {x : α} {as : dvector α n} :
  fin_val (dvector.cons x as) = fin.x_val x (fin_val as) :=
funext (
  @fin.cases n
  (λ k, fin_val (dvector.cons x as) k = fin.x_val x (fin_val as) k)
  rfl
  (λ k, begin unfold fin_val, simp, end)
  )

lemma nth_eq_succ_nth : Π {k n : ℕ} {as : dvector α (n + 1)} {h : k < n},
as.nth k (lt_trans h (by simp)) = (dvector.remove_mth (n + 2) as).nth k h
| k nat.zero (dvector.cons a _) h := by {exfalso, simpa using h}
| nat.zero (nat.succ n) (dvector.cons a as) h := by simp
| (nat.succ k) (nat.succ n) (dvector.cons a as) h :=
  by {simpa using nth_eq_succ_nth}

def of_list : Π (as : list α), dvector α (list.length as)
| list.nil := dvector.nil
| (list.cons a as) := dvector.cons a (of_list as)

def reverse : Π {n : ℕ} (v : dvector α n),
  dvector α n
| nat.zero _ := dvector.nil
| (nat.succ n) (dvector.cons a v) := dvector.concat (reverse v) a

/-- if you append and take nth its the same as just taking nth for small n-/
lemma nth_append_small : Π {xl yl : ℕ}
  {xs : dvector α xl} {ys : dvector α yl} {n : ℕ} (h : n < xl),
  (dvector.append xs ys).nth n (nat.lt_of_lt_of_le h (nat.le_add_left _ _))
  = xs.nth n h
| 0             yl xs                  ys n h := by simpa using h
| (nat.succ xl) yl (dvector.cons x xs) ys 0 h := by simp
| (nat.succ xl) yl (dvector.cons x xs) ys (nat.succ n) h :=
begin
  simp only [dvector.nth, dvector.append],
  rw ← (@nth_append_small xl yl xs ys n (nat.succ_lt_succ_iff.1 h)),
  refl,
end

/-- if you append and take nth its the same as just taking n - kth for big n-/
lemma nth_append_big : Π {xl yl : ℕ}
  {xs : dvector α xl} {ys : dvector α yl} {n : ℕ}
  (hbig : xl ≤ n) (h : n < yl + xl),
  (dvector.append xs ys).nth n h
  = ys.nth (n - xl) ((nat.sub_lt_right_iff_lt_add hbig).2 h)
| 0             yl nil                 ys n hbig h := by simpa
| (nat.succ xl) yl (dvector.cons x xs) ys 0 hbig h :=
begin
  exfalso,
  exact nat.not_succ_le_zero _ hbig,
end
| (nat.succ xl) yl (dvector.cons x xs) ys (nat.succ n) hbig h :=
begin
  simp only [nat.succ_sub_succ_eq_sub, dvector.append, dvector.nth],
  apply nth_append_big (nat.le_of_succ_le_succ hbig),
end

lemma nth_cast : Π {xl yl k : ℕ}
  {xs : dvector α xl}
  (heq : xl = yl) (hk : k < yl),
  (dvector.cast heq xs).nth k hk = xs.nth k (by simp [heq, hk])
| 0             yl            k nil          heq hk :=
  (k.not_lt_zero (by simp [heq, hk])).elim
| (nat.succ xl) 0             k (cons x xs) heq hk :=
  (nat.succ_ne_zero _ heq).elim
| (nat.succ xl) (nat.succ yl) k (cons x xs) heq hk :=
begin
  rw dvector.cast_cons heq x xs,
  induction k with k hk,
  {simp},
  rw dvector.nth_cons _ _ _ (nat.lt_of_succ_lt_succ hk),
  exact nth_cast (nat.succ_injective heq) (nat.lt_of_succ_lt_succ hk),
end

lemma nth_of_list : Π (l : list α) (k : ℕ) (h : k < l.length),
  (dvector.of_list l).nth k h = list.nth_le l k h
| list.nil k h :=
begin
  exfalso,
  rw list.length at h,
  exact nat.not_lt_zero _ h,
end
| (a :: l) k h :=
begin
  rw of_list,
  induction k with k hk,
  {rw [dvector.nth, list.nth_le]},
  {simpa [dvector.nth, list.nth_le, nth_of_list l]},
end

def of_fn : (fin n → α) → dvector α n :=
λ f, dvector.cast (list.length_of_fn _) (dvector.of_list (list.of_fn f))

lemma nth_of_fn (as : fin n → α) (k : ℕ) (hk : k < n) :
  (dvector.of_fn as).nth k hk = as ⟨ k , hk ⟩ :=
by rw [of_fn, nth_cast, nth_of_list, list.nth_le_of_fn']

lemma nth'_of_fn (as : fin n → α) (k : fin n) :
  (dvector.of_fn as).nth' k = as k :=
by simp only [dvector.nth', nth_of_fn, fin.val_eq_coe, fin.eta]

lemma nth'_of_fn1 (as : fin n → α) :
  (dvector.of_fn as).nth' = as :=
funext $ nth'_of_fn as
--by rw [of_fn, nth_cast, nth_of_list, list.nth_le_of_fn']

def to_list : Π {n : ℕ},
  dvector α n → list α
| 0            as := []
| (nat.succ n) (dvector.cons a as) := list.cons a (to_list as)

lemma to_list_length : Π {n : ℕ} {as : dvector α n},
  list.length (to_list as) = n
| 0            as := rfl
| (nat.succ n) (dvector.cons a as) :=
by simp only [to_list, list.length_cons, @to_list_length n as]

lemma ith_chunk_aux {n m : ℕ} (i : fin n) (k : fin m) :
  i.val * m + ↑k < n * m :=
begin
  induction n with n hn,
  { apply fin_zero_elim i },
  {
    rw nat.succ_mul,
    cases fin.lt_or_eq_nat i with hi hi,
    {
      apply add_lt_add _ k.2,
      apply lt_of_le_of_lt _ (hn ⟨ i.1 , hi ⟩),
      apply le_add_right,
      apply le_of_eq,
      refl,
    },
    { rw [fin.val_eq_coe, hi, add_lt_add_iff_left],
      exact k.2, }
  }
end

def ith_chunk {n m : ℕ} (i : fin n) (xs : dvector α (n * m)) :
  dvector α m :=
  of_fn (λ k, dvector.nth xs (i.1 * m + k) (dvector.ith_chunk_aux i k))

lemma nth'_eq {α} {n} (ys : dvector α n) :
  (λ (i : fin n), ys.nth i i.2) = ys.nth' :=
begin
  funext, rw dvector.nth', refl,
end

lemma ith_chunk_nth {n m : ℕ} (i : fin n) (xs : dvector α (n * m))
  (l : ℕ) (hl : l < m) :
  dvector.nth (dvector.ith_chunk i xs) l hl =
  xs.nth (i.1 * m + l) (dvector.ith_chunk_aux i ⟨ l , hl ⟩) :=
by simpa only [dvector.ith_chunk, dvector.nth_of_fn]

lemma nth_remove_mth_big_m : Π {n m} (xs : dvector α (n+1)) {k : ℕ}
  (hk : k < n) (hm : k < m),
  (dvector.remove_mth m xs).nth k hk
  =
  xs.nth k (lt_trans hk (nat.lt_succ_self _))
| 0 _ _ k hk hm := false.elim (nat.not_lt_zero _ hk)
| n 0 (dvector.cons y ys) k hk hm := false.elim (nat.not_lt_zero _ hm)
| (n+1) (m+1) (dvector.cons y ys) 0 hk hm :=
begin
  simp only [dvector.remove_mth, dvector.nth],
end
| (n+1) (m+1) (dvector.cons y ys) (k+1) hk hm :=
begin
  rw [dvector.remove_mth,
    dvector.nth_cons y (dvector.remove_mth m ys) _ (nat.succ_lt_succ_iff.mp hk),
    dvector.nth_cons y ys _ (lt_trans (nat.lt_succ_self _) hk)],
  apply nth_remove_mth_big_m,
  rw ← nat.succ_lt_succ_iff,
  exact hm,
end

lemma ext : Π {as bs : dvector α n},
  as = bs ↔ ∀ (i : fin n), as.nth' i = bs.nth' i :=
begin
  intros as bs,
  induction as with n a as hind, cases bs,
  { simp only [implies_true_iff, eq_self_iff_true] },
  {
    cases bs with _ b bs,
    split,
    {
      intros heq i, rw heq,
    },
    {
      intros heq,
      simp only,
      split,
      {
        specialize heq 0,
        simp [dvector.nth', fin.val_zero', dvector.nth] at heq,
        exact heq,
      },
      {
        rw hind,
        intro i,
        specialize heq ⟨ i + 1 , nat.succ_lt_succ i.2 ⟩,
        simp [dvector.nth', dvector.nth] at heq,
        simp only [dvector.nth'],
        convert heq,
      },
    },
  },
end

lemma of_fn_eq_cons_of_fn_succ {f : ℕ → α} :
  of_fn (λ i : fin (n+1), f i) =
  cons (f 0) (of_fn (λ (i : fin n), f (i + 1))) :=
begin
  rw ext,
  intro i,
  cases i with i hi,
  cases i with i hind,
  { simp only [nth'_of_fn, fin.mk_zero, fin.coe_eq_cast_succ,
      fin.coe_succ_eq_succ],
    simpa only [dvector.nth', fin.val_zero', dvector.nth], },
  {
    simp only [nth'_of_fn, dvector.nth', dvector.nth, nth_of_fn],
    congr1,
  },
end

lemma remove_mth_of_fn_last_aux (i : fin n) :
  ((i : fin n.succ) : fin n.succ.succ) = (i : fin n.succ.succ) :=
begin
  cases i with i hi,
  simp only [fin.coe_eq_cast_succ, fin.cast_succ_mk, fin.coe_mk, coe_coe],
  ext1,
  simp only [fin.coe_of_nat_eq_mod],
  rw nat.mod_eq_of_lt (lt_trans hi (nat.lt_succ_self _)),
end

lemma remove_mth_of_fn_last {n : ℕ} : Π {f : ℕ → α},
  dvector.remove_mth n (of_fn (λ (i : fin (n+1)), f i))
  =
  dvector.of_fn (λ i : fin n, f i) :=
begin
  induction n with n hn,
  {intro f, refl},
  {
    intro f,
    have hrw : (of_fn (λ (i : fin (n+2)), f i))
      = cons (f 0) (of_fn (λ i : fin n.succ, f (i + 1))) :=
    of_fn_eq_cons_of_fn_succ,
    have hrw1 : of_fn (λ (i : fin n.succ), f i)
      = cons (f 0) (of_fn (λ i : fin n, f (i + 1))) :=
    of_fn_eq_cons_of_fn_succ,
    rw hrw,
    rw [dvector.remove_mth],
    rw hrw1,
    congr1,
    rw @hn (λ n, f (n + 1)),
  },
end

section ulift

def ulift_up {α} {n} : dvector α n → dvector (ulift α) n :=
  dvector.map ulift.up

def ulift_down {α} {n} : dvector (ulift α) n → dvector α n :=
  dvector.map ulift.down

end ulift

-- #check list.of_fn

end dvector