/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro

! This file was ported from Lean 3 source module data.analysis.filter
! leanprover-community/mathlib commit f7fc89d5d5ff1db2d1242c7bb0e9062ce47ef47c
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Order.Filter.Cofinite

/-!
# Computational realization of filters (experimental)

This file provides infrastructure to compute with filters.

## Main declarations

* `CFilter`: Realization of a filter base. Note that this is in the generality of filters on
  lattices, while `Filter` is filters of sets (so corresponding to `CFilter (Set α) σ`).
* `Filter.Realizer`: Realization of a `Filter`. `CFilter` that generates the given filter.
-/

open Set Filter

-- Porting note: TODO write doc strings
/-- A `CFilter α σ` is a realization of a filter (base) on `α`,
  represented by a type `σ` together with operations for the top element and
  the binary `inf` operation. -/
structure CFilter (α σ : Type _) [PartialOrder α] where
  f : σ → α
  pt : σ
  inf : σ → σ → σ
  inf_le_left : ∀ a b : σ, f (inf a b) ≤ f a
  inf_le_right : ∀ a b : σ, f (inf a b) ≤ f b
#align cfilter CFilter

variable {α : Type _} {β : Type _} {σ : Type _} {τ : Type _}

instance [Inhabited α] [SemilatticeInf α] : Inhabited (CFilter α α) :=
  ⟨{  f := id
      pt := default
      inf := (· ⊓ ·)
      inf_le_left := fun _ _ ↦ inf_le_left
      inf_le_right := fun _ _ ↦ inf_le_right }⟩

namespace CFilter

section

variable [PartialOrder α] (F : CFilter α σ)

instance : CoeFun (CFilter α σ) fun _ ↦ σ → α :=
  ⟨CFilter.f⟩

/- Porting note: Due to the CoeFun instance, the lhs of this lemma has a variable (f) as its head
symbol (simpnf linter problem). Replacing it with a FunLike instance would not be mathematically
meaningful here, since the coercion to f cannot be injective, hence need to remove @[simp]. -/
-- @[simp]
theorem coe_mk (f pt inf h₁ h₂ a) : (@CFilter.mk α σ _ f pt inf h₁ h₂) a = f a :=
  rfl
#align cfilter.coe_mk CFilter.coe_mk

/-- Map a `CFilter` to an equivalent representation type. -/
def ofEquiv (E : σ ≃ τ) : CFilter α σ → CFilter α τ
  | ⟨f, p, g, h₁, h₂⟩ =>
    { f := fun a ↦ f (E.symm a)
      pt := E p
      inf := fun a b ↦ E (g (E.symm a) (E.symm b))
      inf_le_left := fun a b ↦ by simpa using h₁ (E.symm a) (E.symm b)
      inf_le_right := fun a b ↦ by simpa using h₂ (E.symm a) (E.symm b) }
#align cfilter.of_equiv CFilter.ofEquiv

@[simp]
theorem ofEquiv_val (E : σ ≃ τ) (F : CFilter α σ) (a : τ) : F.ofEquiv E a = F (E.symm a) := by
  cases F ; rfl
#align cfilter.of_equiv_val CFilter.ofEquiv_val

end

/-- The filter represented by a `CFilter` is the collection of supersets of
  elements of the filter base. -/
def toFilter (F : CFilter (Set α) σ) : Filter α where
  sets := { a | ∃ b, F b ⊆ a }
  univ_sets := ⟨F.pt, subset_univ _⟩
  sets_of_superset := fun ⟨b, h⟩ s ↦ ⟨b, Subset.trans h s⟩
  inter_sets := fun ⟨a, h₁⟩ ⟨b, h₂⟩ ↦ ⟨F.inf a b,
    subset_inter (Subset.trans (F.inf_le_left _ _) h₁) (Subset.trans (F.inf_le_right _ _) h₂)⟩
#align cfilter.to_filter CFilter.toFilter

@[simp]
theorem mem_toFilter_sets (F : CFilter (Set α) σ) {a : Set α} : a ∈ F.toFilter ↔ ∃ b, F b ⊆ a :=
  Iff.rfl
#align cfilter.mem_to_filter_sets CFilter.mem_toFilter_sets

end CFilter

-- Porting note: TODO write doc strings
/-- A realizer for filter `f` is a cfilter which generates `f`. -/
structure Filter.Realizer (f : Filter α) where
  σ : Type _
  F : CFilter (Set α) σ
  eq : F.toFilter = f
#align filter.realizer Filter.Realizer

/-- A `CFilter` realizes the filter it generates. -/
protected def CFilter.toRealizer (F : CFilter (Set α) σ) : F.toFilter.Realizer :=
  ⟨σ, F, rfl⟩
#align cfilter.to_realizer CFilter.toRealizer

namespace Filter.Realizer

theorem mem_sets {f : Filter α} (F : f.Realizer) {a : Set α} : a ∈ f ↔ ∃ b, F.F b ⊆ a := by
  cases F ; subst f ; rfl
#align filter.realizer.mem_sets Filter.Realizer.mem_sets

/-- Transfer a realizer along an equality of filter. This has better definitional equalities than
the `Eq.rec` proof. -/
def ofEq {f g : Filter α} (e : f = g) (F : f.Realizer) : g.Realizer :=
  ⟨F.σ, F.F, F.eq.trans e⟩
#align filter.realizer.of_eq Filter.Realizer.ofEq

-- Porting note: Added `noncomputable`
/-- A filter realizes itself. -/
noncomputable def ofFilter (f : Filter α) : f.Realizer :=
  ⟨f.sets,
    { f := Subtype.val
      pt := ⟨univ, univ_mem⟩
      inf := fun ⟨_, h₁⟩ ⟨_, h₂⟩ ↦ ⟨_, inter_mem h₁ h₂⟩
      inf_le_left := fun ⟨x, _⟩ ⟨y, _⟩ ↦ inter_subset_left x y
      inf_le_right := fun ⟨x, _⟩ ⟨y, _⟩ ↦ inter_subset_right x y },
    filter_eq <| Set.ext fun _ ↦ by simp [exists_mem_subset_iff]⟩
#align filter.realizer.of_filter Filter.Realizer.ofFilter

/-- Transfer a filter realizer to another realizer on a different base type. -/
def ofEquiv {f : Filter α} (F : f.Realizer) (E : F.σ ≃ τ) : f.Realizer :=
  ⟨τ, F.F.ofEquiv E, by
    refine' Eq.trans _ F.eq
    exact filter_eq (Set.ext fun _ ↦
      ⟨fun ⟨s, h⟩ ↦ ⟨E.symm s, by simpa using h⟩, fun ⟨t, h⟩ ↦ ⟨E t, by simp [h]⟩⟩)⟩
#align filter.realizer.of_equiv Filter.Realizer.ofEquiv

@[simp]
theorem ofEquiv_σ {f : Filter α} (F : f.Realizer) (E : F.σ ≃ τ) : (F.ofEquiv E).σ = τ :=
  rfl
#align filter.realizer.of_equiv_σ Filter.Realizer.ofEquiv_σ

@[simp]
theorem ofEquiv_F {f : Filter α} (F : f.Realizer) (E : F.σ ≃ τ) (s : τ) :
    (F.ofEquiv E).F s = F.F (E.symm s) := rfl
set_option linter.uppercaseLean3 false in
#align filter.realizer.of_equiv_F Filter.Realizer.ofEquiv_F

/-- `Unit` is a realizer for the principal filter -/
protected def principal (s : Set α) : (principal s).Realizer :=
  ⟨Unit,
    { f := fun _ ↦ s
      pt := ()
      inf := fun _ _ ↦ ()
      inf_le_left := fun _ _ ↦ le_rfl
      inf_le_right := fun _ _ ↦ le_rfl },
    filter_eq <| Set.ext fun _ ↦ ⟨fun ⟨_, s⟩ ↦ s, fun h ↦ ⟨(), h⟩⟩⟩
#align filter.realizer.principal Filter.Realizer.principal

@[simp]

@[simp]
theorem principal_F (s : Set α) (u : Unit) : (Realizer.principal s).F u = s :=
  rfl
set_option linter.uppercaseLean3 false in
#align filter.realizer.principal_F Filter.Realizer.principal_F

instance (s : Set α) : Inhabited (principal s).Realizer :=
  ⟨Realizer.principal s⟩

/-- `Unit` is a realizer for the top filter -/
protected def top : (⊤ : Filter α).Realizer :=
  (Realizer.principal _).ofEq principal_univ
#align filter.realizer.top Filter.Realizer.top

@[simp]
theorem top_σ : (@Realizer.top α).σ = Unit :=
  rfl
#align filter.realizer.top_σ Filter.Realizer.top_σ

@[simp]
theorem top_F (u : Unit) : (@Realizer.top α).F u = univ :=
  rfl
set_option linter.uppercaseLean3 false in
#align filter.realizer.top_F Filter.Realizer.top_F

/-- `Unit` is a realizer for the bottom filter -/
protected def bot : (⊥ : Filter α).Realizer :=
  (Realizer.principal _).ofEq principal_empty
#align filter.realizer.bot Filter.Realizer.bot

@[simp]
theorem bot_σ : (@Realizer.bot α).σ = Unit :=
  rfl
#align filter.realizer.bot_σ Filter.Realizer.bot_σ

@[simp]
theorem bot_F (u : Unit) : (@Realizer.bot α).F u = ∅ :=
  rfl
set_option linter.uppercaseLean3 false in
#align filter.realizer.bot_F Filter.Realizer.bot_F

/-- Construct a realizer for `map m f` given a realizer for `f` -/
protected def map (m : α → β) {f : Filter α} (F : f.Realizer) : (map m f).Realizer :=
  ⟨F.σ,
    { f := fun s ↦ image m (F.F s)
      pt := F.F.pt
      inf := F.F.inf
      inf_le_left := fun _ _ ↦ image_subset _ (F.F.inf_le_left _ _)
      inf_le_right := fun _ _ ↦ image_subset _ (F.F.inf_le_right _ _) },
    filter_eq <| Set.ext fun _ ↦ by
      simp only [CFilter.toFilter, image_subset_iff, mem_setOf_eq, Filter.mem_sets, mem_map]
      rw [F.mem_sets]⟩
#align filter.realizer.map Filter.Realizer.map

@[simp]
theorem map_σ (m : α → β) {f : Filter α} (F : f.Realizer) : (F.map m).σ = F.σ :=
  rfl
#align filter.realizer.map_σ Filter.Realizer.map_σ

@[simp]
theorem map_F (m : α → β) {f : Filter α} (F : f.Realizer) (s) : (F.map m).F s = image m (F.F s) :=
  rfl
set_option linter.uppercaseLean3 false in
#align filter.realizer.map_F Filter.Realizer.map_F

/-- Construct a realizer for `comap m f` given a realizer for `f` -/
protected def comap (m : α → β) {f : Filter β} (F : f.Realizer) : (comap m f).Realizer :=
  ⟨F.σ,
    { f := fun s ↦ preimage m (F.F s)
      pt := F.F.pt
      inf := F.F.inf
      inf_le_left := fun _ _ ↦ preimage_mono (F.F.inf_le_left _ _)
      inf_le_right := fun _ _ ↦ preimage_mono (F.F.inf_le_right _ _) },
    filter_eq <| Set.ext fun _ ↦ by
      cases F ; subst f
      exact ⟨fun ⟨s, h⟩ ↦ ⟨_, ⟨s, Subset.refl _⟩, h⟩,
        fun ⟨_, ⟨s, h⟩, h₂⟩ ↦ ⟨s, Subset.trans (preimage_mono h) h₂⟩⟩⟩
#align filter.realizer.comap Filter.Realizer.comap

/-- Construct a realizer for the sup of two filters -/
protected def sup {f g : Filter α} (F : f.Realizer) (G : g.Realizer) : (f ⊔ g).Realizer :=
  ⟨F.σ × G.σ,
    { f := fun ⟨s, t⟩ ↦ F.F s ∪ G.F t
      pt := (F.F.pt, G.F.pt)
      inf := fun ⟨a, a'⟩ ⟨b, b'⟩ ↦ (F.F.inf a b, G.F.inf a' b')
      inf_le_left := fun _ _ ↦ union_subset_union (F.F.inf_le_left _ _) (G.F.inf_le_left _ _)
      inf_le_right := fun _ _ ↦ union_subset_union (F.F.inf_le_right _ _) (G.F.inf_le_right _ _) },
    filter_eq <| Set.ext fun _ ↦ by cases F ; cases G ; substs f g ; simp [CFilter.toFilter]⟩
#align filter.realizer.sup Filter.Realizer.sup

/-- Construct a realizer for the inf of two filters -/
protected def inf {f g : Filter α} (F : f.Realizer) (G : g.Realizer) : (f ⊓ g).Realizer :=
  ⟨F.σ × G.σ,
    { f := fun ⟨s, t⟩ ↦ F.F s ∩ G.F t
      pt := (F.F.pt, G.F.pt)
      inf := fun ⟨a, a'⟩ ⟨b, b'⟩ ↦ (F.F.inf a b, G.F.inf a' b')
      inf_le_left := fun _ _ ↦ inter_subset_inter (F.F.inf_le_left _ _) (G.F.inf_le_left _ _)
      inf_le_right := fun _ _ ↦ inter_subset_inter (F.F.inf_le_right _ _) (G.F.inf_le_right _ _) },
    by
    cases F ; cases G ; substs f g ; simp only [CFilter.toFilter, Prod.exists] ; ext
    constructor
    · rintro ⟨s, t, h⟩
      apply mem_inf_of_inter _ _ h
      use s
      use t
    · rintro ⟨_, ⟨a, ha⟩, _, ⟨b, hb⟩, rfl⟩
      exact ⟨a, b, inter_subset_inter ha hb⟩⟩
#align filter.realizer.inf Filter.Realizer.inf

/-- Construct a realizer for the cofinite filter -/
protected def cofinite [DecidableEq α] : (@cofinite α).Realizer :=
  ⟨Finset α,
    { f := fun s ↦ { a | a ∉ s }
      pt := ∅
      inf := (· ∪ ·)
      inf_le_left := fun _ _ _ ↦ mt (Finset.mem_union_left _)
      inf_le_right := fun _ _ _ ↦ mt (Finset.mem_union_right _) },
    filter_eq <|
      Set.ext fun _ ↦
        ⟨fun ⟨s, h⟩ ↦ s.finite_toSet.subset (compl_subset_comm.1 h), fun h ↦
          ⟨h.toFinset, by simp [Subset.rfl]⟩⟩⟩
#align filter.realizer.cofinite Filter.Realizer.cofinite

/-- Construct a realizer for filter bind -/
protected def bind {f : Filter α} {m : α → Filter β} (F : f.Realizer) (G : ∀ i, (m i).Realizer) :
    (f.bind m).Realizer :=
  ⟨Σs : F.σ, ∀ i ∈ F.F s, (G i).σ,
    { f := fun ⟨s, f⟩ ↦ ⋃ i ∈ F.F s, (G i).F (f i (by assumption))
      pt := ⟨F.F.pt, fun i _ ↦ (G i).F.pt⟩
      inf := fun ⟨a, f⟩ ⟨b, f'⟩ ↦
        ⟨F.F.inf a b, fun i h ↦
          (G i).F.inf (f i (F.F.inf_le_left _ _ h)) (f' i (F.F.inf_le_right _ _ h))⟩
      inf_le_left := fun _ _ _ ↦ by
        simp only [mem_unionᵢ, forall_exists_index]
        exact fun i h₁ h₂ ↦ ⟨i, F.F.inf_le_left _ _ h₁, (G i).F.inf_le_left _ _ h₂⟩
      inf_le_right := fun _ _ _ ↦ by
        simp only [mem_unionᵢ, forall_exists_index]
        exact fun i h₁ h₂ ↦ ⟨i, F.F.inf_le_right _ _ h₁, (G i).F.inf_le_right _ _ h₂⟩ },
    filter_eq <| Set.ext fun _ ↦ by
      cases' F with _ F _ ; subst f
      simp only [CFilter.toFilter, unionᵢ_subset_iff, Sigma.exists, Filter.mem_sets, mem_bind]
      exact
        ⟨fun ⟨s, f, h⟩ ↦
          ⟨F s, ⟨s, Subset.refl _⟩, fun i H ↦ (G i).mem_sets.2 ⟨f i H, fun _ h' ↦ h i H h'⟩⟩,
          fun ⟨_, ⟨s, h⟩, f⟩ ↦
          let ⟨f', h'⟩ := Classical.axiom_of_choice fun i : F s ↦ (G i).mem_sets.1 (f i (h i.2))
          ⟨s, fun i h ↦ f' ⟨i, h⟩, fun _ H _ m ↦ h' ⟨_, H⟩ m⟩⟩⟩
#align filter.realizer.bind Filter.Realizer.bind

-- Porting note: `supᵢ` had a long dubious translation message. I added `ₓ` to be safe.
/-- Construct a realizer for indexed supremum -/
protected def supᵢ {f : α → Filter β} (F : ∀ i, (f i).Realizer) : (⨆ i, f i).Realizer :=
  let F' : (⨆ i, f i).Realizer :=
    (Realizer.bind Realizer.top F).ofEq <|
      filter_eq <| Set.ext <| by simp [Filter.bind, eq_univ_iff_forall, supᵢ_sets_eq]
  F'.ofEquiv <|
    show (Σ_ : Unit, ∀ i : α, True → (F i).σ) ≃ ∀ i, (F i).σ from
      ⟨fun ⟨_, f⟩ i ↦ f i ⟨⟩, fun f ↦ ⟨(), fun i _ ↦ f i⟩, fun _ ↦ rfl, fun _ ↦ rfl⟩
#align filter.realizer.Sup Filter.Realizer.supᵢₓ

/-- Construct a realizer for the product of filters -/
protected def prod {f g : Filter α} (F : f.Realizer) (G : g.Realizer) : (f.prod g).Realizer :=
  (F.comap _).inf (G.comap _)
#align filter.realizer.prod Filter.Realizer.prod

theorem le_iff {f g : Filter α} (F : f.Realizer) (G : g.Realizer) :
    f ≤ g ↔ ∀ b : G.σ, ∃ a : F.σ, F.F a ≤ G.F b :=
  ⟨fun H t ↦ F.mem_sets.1 (H (G.mem_sets.2 ⟨t, Subset.refl _⟩)), fun H _ h ↦
    F.mem_sets.2 <|
      let ⟨s, h₁⟩ := G.mem_sets.1 h
      let ⟨t, h₂⟩ := H s
      ⟨t, Subset.trans h₂ h₁⟩⟩
#align filter.realizer.le_iff Filter.Realizer.le_iff

theorem tendsto_iff (f : α → β) {l₁ : Filter α} {l₂ : Filter β} (L₁ : l₁.Realizer)
    (L₂ : l₂.Realizer) : Tendsto f l₁ l₂ ↔ ∀ b, ∃ a, ∀ x ∈ L₁.F a, f x ∈ L₂.F b :=
  (le_iff (L₁.map f) L₂).trans <| forall_congr' fun _ ↦ exists_congr fun _ ↦ image_subset_iff
#align filter.realizer.tendsto_iff Filter.Realizer.tendsto_iff

theorem ne_bot_iff {f : Filter α} (F : f.Realizer) : f ≠ ⊥ ↔ ∀ a : F.σ, (F.F a).Nonempty := by
  rw [not_iff_comm, ← le_bot_iff, F.le_iff Realizer.bot, not_forall]
  simp only [Set.not_nonempty_iff_eq_empty]
  exact ⟨fun ⟨x, e⟩ _ ↦ ⟨x, le_of_eq e⟩, fun h ↦
    let ⟨x, h⟩ := h ()
    ⟨x, le_bot_iff.1 h⟩⟩
#align filter.realizer.ne_bot_iff Filter.Realizer.ne_bot_iff

end Filter.Realizer


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

The `simp_rw` tactic, a mix of `simp` and `rewrite`.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.core
import Mathlib.PostPort

namespace Mathlib

/-!
# The `simp_rw` tactic

This module defines a tactic `simp_rw` which functions as a mix of `simp` and
`rw`. Like `rw`, it applies each rewrite rule in the given order, but like
`simp` it repeatedly applies these rules and also under binders like `∀ x, ...`,
`∃ x, ...` and `λ x, ...`.

## Implementation notes

The tactic works by taking each rewrite rule in turn and applying `simp only` to
it. Arguments to `simp_rw` are of the format used by `rw` and are translated to
their equivalents for `simp`.
-/

namespace tactic.interactive

/--
`simp_rw` functions as a mix of `simp` and `rw`. Like `rw`, it applies each
rewrite rule in the given order, but like `simp` it repeatedly applies these
rules and also under binders like `∀ x, ...`, `∃ x, ...` and `λ x, ...`.

Usage:
  - `simp_rw [lemma_1, ..., lemma_n]` will rewrite the goal by applying the
    lemmas in that order. A lemma preceded by `←` is applied in the reverse direction.
  - `simp_rw [lemma_1, ..., lemma_n] at h₁ ... hₙ` will rewrite the given hypotheses.
  - `simp_rw [...] at ⊢ h₁ ... hₙ` rewrites the goal as well as the given hypotheses.
  - `simp_rw [...] at *` rewrites in the whole context: all hypotheses and the goal.

Lemmas passed to `simp_rw` must be expressions that are valid arguments to `simp`.

For example, neither `simp` nor `rw` can solve the following, but `simp_rw` can:
```lean
example {α β : Type} {f : α → β} {t : set β} : (∀ s, f '' s ⊆ t) = ∀ s : set α, ∀ x ∈ s, x ∈ f ⁻¹' t :=
by simp_rw [set.image_subset_iff, set.subset_def]
```
-/


/-
Copyright (c) 2021 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import data.real.sqrt
import number_theory.zsqrtd.basic

/-!
# Image of `zsqrtd` in `ℝ`

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

This file defines `zsqrtd.to_real` and related lemmas.
It is in a separate file to avoid pulling in all of `data.real` into `data.zsqrtd`.
-/

namespace zsqrtd

/-- The image of `zsqrtd` in `ℝ`, using `real.sqrt` which takes the positive root of `d`.

If the negative root is desired, use `to_real h a.conj`. -/
@[simps]
noncomputable def to_real {d : ℤ} (h : 0 ≤ d) : ℤ√d →+* ℝ :=
lift ⟨real.sqrt d, real.mul_self_sqrt (int.cast_nonneg.mpr h)⟩

lemma to_real_injective {d : ℤ} (h0d : 0 ≤ d) (hd : ∀ n : ℤ, d ≠ n*n) :
  function.injective (to_real h0d) :=
lift_injective _ hd

end zsqrtd


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import pullbacks
import comma
import category_theory.opposites

universes u v

namespace category_theory

open category_theory.limits

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

def sub' (X : C) := {f : over X // mono f.hom}
def le : sub' X → sub' X → Prop := λ f g, ∃ (h : f.1.left ⟶ g.1.left), f.1.hom = h ≫ g.1.hom
lemma le_refl : reflexive (@le _ _ X) := λ f, ⟨𝟙 _, (category.id_comp _ _).symm⟩
lemma le_trans : transitive (@le _ _ X) :=
begin
  rintros f g h ⟨k, r⟩ ⟨l, s⟩,
  refine ⟨k ≫ l, r.trans _⟩,
  rw s, simp
end

@[simps]
def pullback_sub' [has_pullbacks.{v} C] (f : X ⟶ Y) (g : sub' Y) : sub' X :=
⟨over.mk (pullback.snd : pullback g.1.hom f ⟶ X), @pullback.snd_of_mono _ _ _ _ _ _ _ _ g.2⟩

lemma pullback_preserves_le' [has_pullbacks.{v} C] (f : X ⟶ Y) {g₁ g₂ : sub' Y} (h : le g₁ g₂) :
  le (pullback_sub' f g₁) (pullback_sub' f g₂) :=
begin
  cases h,
  refine ⟨_, _⟩,
  refine pullback.lift (pullback.fst ≫ h_w) pullback.snd _,
  slice_lhs 2 3 {rw ← h_h},
  apply pullback.condition,
  dsimp, simp,
end

@[simps]
def postcompose_sub' (f : X ⟶ Y) [mono f] (g : sub' X) : sub' Y :=
⟨over.mk (g.1.hom ≫ f), begin haveI := g.2, dsimp, apply_instance end⟩

lemma postcompose_preserves_le' (f : X ⟶ Y) [mono f] {g₁ g₂ : sub' X} (h : le g₁ g₂) :
  le (postcompose_sub' f g₁) (postcompose_sub' f g₂) :=
begin
  cases h with h k,
  use h,
  dsimp, simp [k]
end

def equiv (X : C) : sub' X → sub' X → Prop := λ f g, le f g ∧ le g f
lemma equiv_is_equivalence : _root_.equivalence (@equiv _ _ X) :=
begin
  refine ⟨λ f, ⟨le_refl _, le_refl _⟩, λ f g ⟨k, l⟩, ⟨l, k⟩, λ f g h, _⟩,
  rintro ⟨a, b⟩ ⟨c, d⟩,
  refine ⟨le_trans a c, le_trans d b⟩,
end

instance : setoid (sub' X) := ⟨equiv X, equiv_is_equivalence⟩
def sub (X : C) := quotient ⟨equiv X, equiv_is_equivalence⟩

instance : has_le (sub X) :=
begin
  split,
  refine quotient.lift₂ _ _,
  exact le,
  rintros _ _ _ _ ⟨a₁b₁, b₁a₁⟩ ⟨a₂b₂, b₂a₂⟩,
  rw eq_iff_iff,
  split,
    intro a₁a₂, apply le_trans b₁a₁ (le_trans a₁a₂ a₂b₂),
    intro b₁b₂, apply le_trans a₁b₁ (le_trans b₁b₂ b₂a₂)
end

instance : preorder (sub X) :=
{ le := has_le.le,
  le_refl := λ Y, quotient.ind le_refl Y,
  le_trans := λ A B C, begin apply quotient.induction_on₃ A B C, intros a b c, apply le_trans end }

instance : partial_order (sub X) :=
{ le := has_le.le, le_refl := preorder.le_refl, le_trans := preorder.le_trans,
  le_antisymm :=
  begin
    intros A B,
    apply quotient.induction_on₂ A B,
    rintros a b k l,
    apply quotient.sound,
    split, exact k, exact l
  end }

def sub_map [has_pullbacks.{v} C] {Y : C} (f : X ⟶ Y) : sub Y → sub X :=
begin
  refine quotient.lift (λ g, quotient.mk (pullback_sub' f g)) _,
  rintros a b ⟨k, l⟩,
  apply quotient.sound,
  split,
  apply pullback_preserves_le' _ k,
  apply pullback_preserves_le' _ l
end

lemma sub_map_id [has_pullbacks.{v} C] (x : sub X) : sub_map (𝟙 X) x = x :=
begin
  apply quotient.induction_on x,
  intro a,
  dsimp [sub_map], apply quotient.sound, split,
  { dsimp [pullback_sub'],
    refine ⟨pullback.fst, _⟩, dsimp, rw pullback.condition, simp },
  { dsimp [pullback_sub'],
    refine ⟨pullback.lift (𝟙 _) a.val.hom _, _⟩, dsimp,
    simp, simp }
end
lemma sub_map_comp [has_pullbacks.{v} C] {Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) (x : sub Z) : sub_map (f ≫ g) x = sub_map f (sub_map g x) :=
begin
  apply quotient.induction_on x,
  intro a,
  dsimp [sub_map], apply quotient.sound,
  split,
  { dsimp [pullback_sub'],
  refine ⟨pullback.lift (pullback.lift pullback.fst (pullback.snd ≫ f) _) pullback.snd _, _⟩,
  rw pullback.condition, simp,
  simp, simp },
  { dsimp [pullback_sub'],
  refine ⟨pullback.lift (pullback.fst ≫ pullback.fst) pullback.snd _, _⟩,
  slice_lhs 2 3 {rw pullback.condition},
  slice_lhs 1 2 {rw pullback.condition},
  simp,
  simp },
end

variable (C)

def sub.functor [has_pullbacks.{v} C] : Cᵒᵖ ⥤ Type (max u v) :=
{ obj := λ X, sub (X.unop),
  map := λ X Y f, sub_map f.unop,
  map_id' := λ X,
  begin
    ext, apply sub_map_id
  end,
  map_comp' := λ X Y Z f g,
  begin
    ext, apply sub_map_comp
  end
}

variable {C}

def postcompose {X Y : C} (f : X ⟶ Y) [mono f] : sub X → sub Y :=
begin
  refine quotient.lift (λ g, quotient.mk (postcompose_sub' f g)) _,
  intros a b k,
  apply quotient.sound,
  exact ⟨postcompose_preserves_le' f k.1, postcompose_preserves_le' f k.2⟩,
end
-- quotient.map (postcompose_sub' f) (λ a b k, ⟨postcompose_preserves_le' f k.1, postcompose_preserves_le' f k.2⟩)

lemma postcompose_map_id (g : sub X) : postcompose (𝟙 X) g = g :=
begin
  apply quotient.induction_on g,
  intro a,
  dsimp [postcompose],
  apply quotient.sound,
  split,
  use 𝟙 _,
  dsimp [postcompose_sub'], simp,
  use (𝟙 _),
  dsimp [postcompose_sub'], simp,
end

lemma postcompose_map_comp {Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) [mono f] [mono g] (h : sub X) : postcompose (f ≫ g) h = postcompose g (postcompose f h) :=
begin
  apply quotient.induction_on h,
  intro a,
  dsimp [postcompose],
  apply quotient.sound,
  split,
  refine ⟨𝟙 _, _⟩,
  dsimp, simp,
  refine ⟨𝟙 _, _⟩, dsimp, simp
end

def sub_iso_compose (e : X ≅ Y) : sub X ≃ sub Y :=
{ to_fun := postcompose e.hom,
  inv_fun := postcompose e.inv,
  left_inv :=
  begin
    intro g,
    rw ← postcompose_map_comp,
    simp only [iso.hom_inv_id],
    rw postcompose_map_id
  end,
  right_inv :=
  begin
    intro g,
    rw ← postcompose_map_comp,
    simp only [iso.inv_hom_id],
    rw postcompose_map_id
  end
}

def postcompose_sub_comm [has_pullbacks.{v} C] {X Y Z W : C} (f : X ⟶ Y) (g : X ⟶ Z) (h : Y ⟶ W) (k : Z ⟶ W) [mono h] [mono g] (comm : f ≫ h = g ≫ k) (t : is_limit (pullback_cone.mk f g comm)) (p : sub Y) :
  postcompose g (sub_map f p) = sub_map k (postcompose h p) :=
begin
  apply quotient.induction_on p,
  intro a,
  dsimp [postcompose, sub_map],
  apply quotient.sound,
  split;
  refine ⟨_, _⟩,
  apply pullback.lift pullback.fst (pullback.snd ≫ g) _,
  slice_rhs 2 3 {rw ← comm},
  dsimp [postcompose_sub'],
  slice_lhs 1 2 {rw pullback.condition}, rw category.assoc,
  dsimp, rw limit.lift_π,
  refl,
  apply pullback.lift pullback.fst _ _,
  apply t.lift (pullback_cone.mk (pullback.fst ≫ a.val.hom) pullback.snd _),
  rw ← pullback.condition,
  rw category.assoc, refl,
  erw t.fac (pullback_cone.mk (pullback.fst ≫ a.val.hom) pullback.snd _) walking_cospan.left, refl,
  dsimp,
  rw ← category.assoc,
  rw limit.lift_π, dsimp,
  erw t.fac _ walking_cospan.right, refl,

end
end category_theory


import number_theory.padics.padic_integers

--OUTPUT 1
theorem p_adic_units (p : ℕ) (x : ℕ) (h : coprime p x) : is_unit (x : ℤ_[p]) :=
begin
  -- prove the contrapositive
  have h1 : ¬ is_unit (x : ℤ_[p]) → ¬ coprime p x, from sorry,
  -- we know that any element of $\mathbb{Z}_p$ is a unit if and only if it has norm 1, thus $\Vert x \Vert \neq 1$
  have h2 : ¬ is_unit (x : ℤ_[p]) → ¬ (norm_p x = 1), from sorry,
  -- also, since every element of $\mathbb{Z}_p$ must have norm less than or equal to 1, we conclude that $\Vert x \Vert < 1$
  have h3 : ¬ is_unit (x : ℤ_[p]) → norm_p x < 1, from sorry,
  -- but this must imply that $p | x$
  have h4 : ¬ is_unit (x : ℤ_[p]) → p ∣ x, from sorry,
  -- this completes our proof.
  show is_unit (x : ℤ_[p]), from sorry,
end

--OUTPUT 2
theorem p_adic_units (p : ℕ) (x : ℕ) : coprime p x → is_unit (x : ℤ_[p]) :=
begin
  -- prove the contrapositive
  assume h1 : ¬ is_unit (x : ℤ_[p]),
  have h2 : ¬ coprime p x, from sorry,
  show coprime p x → is_unit (x : ℤ_[p]), from sorry,
end

--OUTPUT 3
theorem p_adic_units (p : ℕ) (x : ℕ) (h : coprime p x) : x ∈ units (p_adic_int p) :=
begin
  -- we know that any element of $\mathbb{Z}_p$ is a unit if and only if it has norm 1, thus $\Vert x \Vert \neq 1$. Also, since every element of $\mathbb{Z}_p$ must have norm less than or equal to 1, we conclude that $\Vert x \Vert < 1$.
  have h1 : (∀ (x : p_adic_int p), x ∈ units (p_adic_int p) ↔ x.val = 1) ∧ (∀ (x : p_adic_int p), x.val ≤ 1), from sorry,
  have h2 : x ∉ units (p_adic_int p), from sorry,
  have h3 : x.val < 1, from sorry,

  -- But this must imply that $p | x$.
  have h4 : ∃ (k : ℕ), k * p = x, from sorry,
  have h5 : p ∣ x, from sorry,

  -- This completes our proof.
  show x ∈ units (p_adic_int p), from sorry,
end

--OUTPUT 4
theorem p_adic_units (p : ℕ) (x : ℕ) (h : coprime p x) : x ∈ units (ℤ p) :=
begin
  -- Let us prove the contrapositive, that is, is $x$ is not a unit of $\mathbb{Z}_p$, then $x$ is not coprime to $p$.
  by_contradiction,
  assume h1 : x ∉ units (ℤ p),
  -- We know that any element of $\mathbb{Z}_p$ is a unit if and only if it has norm 1, thus $\Vert x \Vert \neq 1$.
  have h2 : norm p x ≠ 1, from sorry,
  -- Also, since every element of $\mathbb{Z}_p$ must have norm less than or equal to 1, we conclude that $\Vert x \Vert < 1$.
  have h3 : norm p x < 1, from sorry,
  -- But this must imply that $p | x$.
  have h4 : p ∣ x, from sorry,
  -- This completes our proof.
  show false, from sorry,
end

--OUTPUT 5
theorem p_adic_units (p : ℕ) (x : ℕ) (h : coprime p x) : is_unit (int.nat_abs x) :=
begin
  -- Let us prove the contrapositive, that is, is $x$ is not a unit of $\mathbb{Z}_p$, then $x$ is not coprime to $p$.
  have h1 : ¬ is_unit (int.nat_abs x) → ¬ coprime p x, from sorry,
  have h2 : ¬ is_unit (int.nat_abs x) → ¬ (∀ a b : ℕ, a ∣ b → a ∣ p → a ∣ 1), from sorry,
  have h3 : ¬ is_unit (int.nat_abs x) → ¬ (∀ a b : ℕ, a ∣ b → a ∣ p → a ∣ 1), from sorry,
  have h4 : ¬ is_unit (int.nat_abs x) → ¬ (∀ a b : ℕ, a ∣ b → a ∣ p → a ∣ 1), from sorry,
  have h5 : ¬ is_unit (int.nat_abs x) → ¬ (∀ a b : ℕ, a ∣ b → a ∣ p → a ∣ 1), from sorry,
  have h6 : ¬ is_unit (int.nat_abs x) → ¬ (∀ a b : ℕ, a ∣ b → a ∣ p → a ∣ 1), from sorry,
  have h7 : ¬ is_unit (int.nat_abs x) → ¬ (∀ a b : ℕ, a ∣ b → a ∣ p → a ∣ 1), from sorry,
  have h8 : ¬ is_unit (int.nat_abs x) → ¬ (∀ a b : ℕ, a ∣ b → a ∣ p → a ∣ 1), from sorry,
  have h9 : ¬ is_unit (int.nat_abs x) → ¬ (∀ a b : ℕ, a ∣ b → a ∣ p → a ∣ 1), from sorry,
  have h10 : ¬ is_unit (int.nat_abs x) → ¬ (∀ a b : ℕ, a ∣ b → a ∣ p → a ∣ 1), from sorry,
  have h11 : ¬ is_unit (int.nat_abs x) → ¬ (∀ a b : ℕ, a ∣ b → a ∣ p → a ∣ 1), from sorry,
  have h12 : ¬ is_unit (int.nat_abs x) → ¬ (∀ a b : ℕ, a ∣ b → a ∣ p → a ∣ 1), from sorry,
  have h13 : ¬ is_unit (int.nat_abs x) → ¬ (∀ a b : ℕ, a ∣ b → a ∣ p → a ∣ 1), from sorry,
  have h14 : ¬ is_unit (int.nat_abs x) → ¬ (∀ a b : ℕ, a ∣ b → a ∣ p → a ∣ 1), from sorry,
  have h15 : ¬ is_unit (int.nat_abs x) → ¬ (∀ a b : ℕ, a ∣ b → a ∣ p → a ∣ 1), from sorry,
  have h16 : ¬ is_unit (int.nat_abs x) → ¬ (∀ a b : ℕ, a ∣ b → a ∣ p → a ∣ 1), from sorry,
  have h17 : ¬ is_unit (int.nat_abs x) → ¬ (∀ a b : ℕ, a ∣ b → a ∣ p → a ∣ 1), from sorry,
  have h18 : ¬ is_unit (int.nat_abs x) → ¬ (∀ a b : ℕ, a ∣ b → a ∣ p → a ∣ 1), from sorry,
  have h19 : ¬ is_unit (int.nat_abs x) → ¬ (∀ a b : ℕ, a ∣ b → a ∣ p → a ∣ 1), from sorry,
  have h20 : ¬ is_unit (int.nat_abs x) → ¬ (∀ a b : ℕ, a ∣ b → a ∣ p → a ∣ 1), from sorry,
  have h21 : ¬ is_unit (int.nat_abs x) → ¬ (∀ a b : ℕ, a ∣ b → a ∣ p → a ∣ 1), from sorry,
  have h22 : ¬ is_unit (int.nat_abs x) → ¬ (∀ a b : ℕ, a ∣ b → a ∣ p → a ∣ 1), from sorry,
  have h23 : ¬ is_unit (int.nat_abs x) → ¬ (∀ a b : ℕ, a ∣ b → a ∣ p → a ∣ 1), from sorry,
  have h24 : ¬ is_unit (int.nat_abs x) → ¬ (∀ a b : ℕ, a ∣ b → a ∣ p → a ∣ 1), from sorry,
  have h25 : ¬ is_unit (int.nat_abs x) → ¬ (∀ a b : ℕ, a ∣ b → a ∣ p → a ∣ 1), from sorry,
  have h26 : ¬ is_unit (int.nat_abs x) → ¬ (∀ a b : ℕ, a ∣ b → a ∣ p → a ∣ 1), from sorry,
  have h27 : ¬ is_unit (int.nat_abs x) → ¬ (∀ a b : ℕ, a ∣ b → a ∣ p → a ∣ 1), from sorry,
  have h28 : ¬ is_unit (int.nat_abs x) → ¬ (∀ a b : ℕ, a ∣ b → a ∣ p → a ∣ 1), from sorry,
  have h29 : ¬ is_unit (int.nat_abs x) → ¬ (∀ a b : ℕ, a ∣ b → a ∣ p → a ∣ 1), from sorry,
  have h30 : ¬ is_unit (int.nat_abs x) → ¬ (∀ a b : ℕ, a ∣ b → a ∣ p → a ∣ 1), from sorry,
  have h31 : ¬ is_unit (int.nat_abs x) → ¬ (∀ a b : ℕ, a ∣ b → a ∣ p → a ∣ 1), from sorry,
  have h32 : ¬ is_unit (int.nat_abs x) → ¬ (∀ a b : ℕ, a ∣ b → a ∣ p → a ∣ 1), from sorry,
  have h33 : ¬ is_unit (int.nat_abs x) → ¬ (∀ a b : ℕ, a ∣ b → a ∣ p → a ∣ 1), from sorry,
  have h34 : ¬ is_unit (int.nat_abs x) → ¬ (∀ a b : ℕ, a ∣ b → a ∣ p → a ∣ 1), from sorry,
  have h35 : ¬ is_unit (int.nat_abs x) → ¬ (∀ a b : ℕ, a ∣ b → a ∣ p → a ∣ 1), from sorry,
  have h36 : ¬ is_unit (int.nat_abs x) → ¬ (∀ a b : ℕ, a ∣ b → a ∣ p → a ∣ 1), from sorry,
  have h37 : ¬ is_unit (int.nat_abs x) → ¬ (∀ a b : ℕ, a ∣ b → a ∣ p → a ∣ 1), from sorry,
  have h38 : ¬ is_unit (int.nat_abs x) → ¬ (∀ a b : ℕ, a ∣ b → a ∣ p → a ∣ 1), from sorry,
  have h39 : ¬ is_unit (int.nat_abs x) → ¬ (∀ a b : ℕ,
end --Needs more than 2000 tokens!

--OUTPUT 6
theorem p_adic_units (p : ℕ) (x : ℕ) (h : x.coprime p) : x ∈ units (padic_int p) :=
begin
  -- Let us prove the contrapositive, that is, is $x$ is not a unit of $\mathbb{Z}_p$, then $x$ is not coprime to $p$.
  have h1 : ¬ (x ∈ units (padic_int p)) → ¬ x.coprime p, from sorry,
  have h2 : ¬ x.coprime p, from sorry,
  have h3 : ¬ (x ∈ units (padic_int p)), from sorry,
  show x ∈ units (padic_int p), from sorry,
end

/- FEW SHOT PROMPTS TO CODEX(START)
/--`theorem`
Power Set is Closed under Intersection
Let $S$ be a set.

Let $\powerset S$ be the power set of $S$.

Then:
:$\forall A, B \in \powerset S: A \cap B \in \powerset S$
`proof`
Let $A, B \in \powerset S$.

Then by the definition of power set, $A \subseteq S$ and $B \subseteq S$.

From Intersection is Subset we have that $A \cap B \subseteq A$.

It follows from Subset Relation is Transitive that $A \cap B \subseteq S$.

Thus $A \cap B \in \powerset S$ and closure is proved.
{{qed}}
-/
theorem power_set_intersection_closed {α : Type*} (S : set α) : ∀ A B ∈ 𝒫 S, (A ∩ B) ∈ 𝒫 S :=
begin
  -- $A$ and $B$ are sets. $A$ and $B$ belong to power set of $S$
  assume (A : set α) (hA : A ∈ 𝒫 S) (B : set α) (hB : B ∈ 𝒫 S),
  -- Then $A ⊆ S$ and $B ⊆ S$, by power set definition
  have h1 : (A ⊆ S) ∧ (B ⊆ S), from sorry,
  -- Then $(A ∩ B) ⊆ A$, by intersection of set is a subset
  have h2 : (A ∩ B) ⊆ A, from sorry,
  -- Then $(A ∩ B) ⊆ S$, by subset relation is transitive
  have h3 : (A ∩ B) ⊆ S, from sorry,
  -- Hence $(A ∩ B) ∈  𝒫 S$, by power set definition
  show (A ∩ B) ∈  𝒫 S, from sorry,
end

/--`theorem`
Square of Sum
 :$\forall x, y \in \R: \paren {x + y}^2 = x^2 + 2 x y + y^2$
`proof`
Follows from the distribution of multiplication over addition:

{{begin-eqn}}
{{eqn | l = \left({x + y}\right)^2
      | r = \left({x + y}\right) \cdot \left({x + y}\right)
}}
{{eqn | r = x \cdot \left({x + y}\right) + y \cdot \left({x + y}\right)
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x \cdot x + x \cdot y + y \cdot x + y \cdot y
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x^2 + 2xy + y^2
      | c =
}}
{{end-eqn}}
{{qed}}
-/
theorem square_of_sum (x y : ℝ) : (x + y)^2 = (x^2 + 2*x*y + y^2) :=
begin
  -- expand the power
  calc (x + y)^2 = (x+y)*(x+y) : by sorry
  -- distributive property of multiplication over addition gives:
  ... = x*(x+y) + y*(x+y) : by sorry
  -- applying the above property further gives:
  ... = x*x + x*y + y*x + y*y : by sorry
  -- rearranging the terms using commutativity and adding gives:
  ... = x^2 + 2*x*y + y^2 : by sorry,
end

/--`theorem`
Identity of Group is Unique
Let $\struct {G, \circ}$ be a group. Then there is a unique identity element $e \in G$.
`proof`
From Group has Latin Square Property, there exists a unique $x \in G$ such that:
:$a x = b$

and there exists a unique $y \in G$ such that:
:$y a = b$

Setting $b = a$, this becomes:

There exists a unique $x \in G$ such that:
:$a x = a$

and there exists a unique $y \in G$ such that:
:$y a = a$

These $x$ and $y$ are both $e$, by definition of identity element.
{{qed}}
-/
theorem group_identity_unique {G : Type*} [group G] : ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a :=
begin
  -- Group has Latin Square Property
  have h1 : ∀ a b : G, ∃! x : G, a * x = b, from sorry,
  have h2 : ∀ a b : G, ∃! y : G, y * a = b, from sorry,

  -- Setting $b = a$, this becomes:
  have h3 : ∀ a : G, ∃! x : G, a * x = a, from sorry,
  have h4 : ∀ a : G, ∃! y : G, y * a = a, from sorry,

  -- These $x$ and $y$ are both $(1 : G)$, by definition of identity element
  have h5 : ∀ a : G, classical.some (h3 a) = (1 : G), from sorry,
  have h6 : ∀ a : G, classical.some (h4 a) = (1 : G), from sorry,

  show ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a, from by {
    use (1 : G),
    have h7 : ∀ e : G, (∀ a : G, e * a = a ∧ a * e = a) → e = 1, from by {
      assume (e : G) (h7 : ∀ a : G, e * a = a ∧ a * e = a),
      have h8 : ∀ a : G, e = classical.some (h3 a), from sorry,
      have h9 : ∀ a : G, e = classical.some (h4 a), from sorry,
      show e = (1 : G), from sorry,
    },
    sorry,
  }
end

/--`theorem`
p-adic units
Given a prime number $p$ and a natural number $x$, if $x$ is coprime to $p$, then $x$ is a unit in the $p$-adic integers.
`proof`
Let us prove the contrapositive, that is, is $x$ is not a unit of $\mathbb{Z}_p$, then $x$ is not coprime to $p$.
We know that any element of $\mathbb{Z}_p$ is a unit if and only if it has norm 1, thus $\Vert x \Vert \neq 1$. Also, since every element of $\mathbb{Z}_p$ must have norm less than or equal to 1, we conclude that $\Vert x \Vert < 1$.
But this must imply that $p | x$.
This completes our proof.

QED
-/
theorem
FEW SHOT PROMPTS TO CODEX(END)-/


import analysis.asymptotics.specific_asymptotics
import measure_theory.decomposition.radon_nikodym
open filter

lemma l1 {k : ℝ} (hk₀ : 0 ≤ k) (hk₁ : k < 1) :
  (* k) ≤ᶠ[at_top] (λ x, x - 1) :=
begin
  rw [eventually_le, eventually_at_top],
  refine ⟨(1 - k)⁻¹, λ b hb, _⟩,
  suffices : b * k ≤ b * 1 - 1,
  { rwa mul_one at this },
  rw [← sub_nonneg, sub_sub, sub_add_eq_sub_sub_swap, ← mul_sub, sub_nonneg],
  refine (inv_pos_le_iff_one_le_mul _).mp hb,
  linarith,
end

example {k : ℝ} (hk₀ : 0 ≤ k) (hk₁ : k < 1) :
  (* k) ≤ᶠ[at_top] (λ x, ⌊x⌋) :=
eventually_le.trans (l1 hk₀ hk₁) $
  eventually_of_forall (λ x, (int.sub_one_lt_floor x).le)


import implementation.model.predicate
import implementation.spec.main
import implementation.proof.misc
import implementation.proof.proposer
import implementation.proof.voter
import implementation.proof.acceptor_voter_relation

-- This file contains the proof of the safety of the paxos algorithm.
--
-- In the spirit of Paxos Made Simple, it may help to read comments from the
-- bottom (the main proof) to the top.

variables {pid_t : Type} [linear_order pid_t] [fintype pid_t] {value_t : Type}
          {is_quorum : finset pid_t → Prop} [decidable_pred is_quorum]
          [quorum_assumption is_quorum] {vals : pid_t → value_t}

def choosable
  (s : sys_state pid_t (server pid_t value_t is_quorum vals) (message pid_t value_t))
  (b : ballot pid_t) :=
  ∃ (possible_voters : finset pid_t), is_quorum possible_voters ∧
     ∀ voter ∈ possible_voters, voted_ballot s voter b ∨ (s.procs voter).curr ≤ b

def chosen_ballot
  (s : sys_state pid_t (server pid_t value_t is_quorum vals) (message pid_t value_t))
  (b : ballot pid_t) :=
  ∃ (voters : finset pid_t), is_quorum voters ∧
     ∀ voter ∈ voters, voted_ballot s voter b

def chosen
  (s : sys_state pid_t (server pid_t value_t is_quorum vals) (message pid_t value_t))
  (v : value_t) :=
  ∃ (b : ballot pid_t), proposed s b v ∧ chosen_ballot s b

def safety
  (s : sys_state pid_t (server pid_t value_t is_quorum vals) (message pid_t value_t)) :=
  ∀ (v v' : value_t), chosen s v → chosen s v' → v = v'

lemma chosen_imp_choosable
  {s : sys_state pid_t (server pid_t value_t is_quorum vals) (message pid_t value_t)}
  {b : ballot pid_t}:
  chosen_ballot s b → choosable s b :=
begin
rintros ⟨voters, quorum, all_voted⟩,
exact ⟨voters, quorum, by { intros voter hyp_voter, left, exact all_voted voter hyp_voter }⟩
end

-- This shows that choosable is reverse stable. Choosable is definitely not
-- stable: the ballot on a server in the quorum may increase above the ballot in
-- question for choosability.
lemma choosable_reverse_stable
  {u w : sys_state pid_t (server pid_t value_t is_quorum vals) (message pid_t value_t)}
  {b : ballot pid_t}:
  u.possible_next w → choosable w b → choosable u b :=
begin
intro u_pn_w,
rcases (show _, by exact u_pn_w) with ⟨receiver, sender, e, he, deliverable, proc_change, ntwk_change, proc_same, ntwk_same⟩,
rintros ⟨possible_voter, quorum, may_vote_at_w⟩,
use [possible_voter, quorum],
intros voter h_voter,
specialize may_vote_at_w voter h_voter,
cases may_vote_at_w,
swap,
{ right, exact le_trans (ballot_nondecreasing voter u_pn_w) may_vote_at_w },
rcases may_vote_at_w with ⟨v, hv, v_is_vote⟩,
cases decidable.em (voter = receiver),
swap,
{ rw ntwk_same voter h at hv,
  left, exact ⟨v, hv, v_is_vote⟩ },
clear proc_same ntwk_same,
rw ← h at proc_change ntwk_change deliverable,
clear h receiver,
rw ntwk_change at hv,
cases hv,
{ left, exact ⟨v, hv, v_is_vote⟩ },
cases p2b_emitted v_is_vote hv with proposal_step acceptor_step,
{ right, apply le_of_eq,
  rcases proposal_step with ⟨_, _, _, _, _, v_is⟩,
  rw v_is at v_is_vote,
  injection v_is_vote },
right,
rcases acceptor_step with ⟨p, e_is_proposal, prop_bal_larger⟩,
suffices : p.bal = b, by { rw this at prop_bal_larger, exact prop_bal_larger },
rw e_is_proposal at hv,
unfold protocol.handler server.handle_p2a at hv,
rw [if_pos prop_bal_larger, set.mem_singleton_iff] at hv,
rw hv at v_is_vote,
injection v_is_vote
end

-- It's tricky to prove that any value proposed under a higher ballot than a
-- chosen ballot has the same value as the one proposed with the chosen ballot,
-- because a lower ballot may be chosen after a proposal is issued (there's a
-- relatively straightforward example with 3 servers, which I omit at least for now).
--
-- Instead, we prove that at every state, if a ballot b *may* be chosen and the
-- ballot has been proposed with value v, then any value v' proposed with a
-- ballot b' > b satisfies v' = v. This idea of "may be chosen" is called
-- `choosable` above; it says that there's a quorum where each server in the
-- quorum has either already voted for b or is not yet prohibited from voting for b.
--
-- We then use induction with all invariants we have proven so far. At a high
-- level, here is the idea.
--
-- In the base case, nothing is proposed, so there is nothing to prove.
--
-- In the inductive step, we have states u and w where u can transition to w; we
-- assume b is choosable at w, that b v is proposed at w, and that b' > b and
-- (b', v') is also proposed at w.  Choosability is "reverse stable" -- the
-- choosability of b at w implies that b was also choosable at u. On the other
-- hand, since (b', v') was proposed at w, the proposer of b' must have
-- communicated with a quorum who sent back p1bs with ballot b' -- in fact, this
-- must have happened by state u. Every member of this quorum has ballot at
-- least b' > b in state u, so one of them must have voted for b (as otherwise
-- they would all be prohibited from voting for b). This server's p1b must
-- reflect the proposal (b, v), so the proposer of b', having heard and merged
-- this p1b, will end up with a stored proposal with ballot b'' at least b. As
-- this proposal was issued, b'' must have been proposed with value v, so b' is
-- proposed with value v; hence v = v'.
lemma proposed_higher_than_chosen_has_same_val : predicate.invariant
  (λ (s : sys_state pid_t (server pid_t value_t is_quorum vals) (message pid_t value_t)),
    ∀ (b : ballot pid_t) (v : value_t),
      chosen_ballot s b → proposed s b v →
      ∀ (b' > b) (v' : value_t),
        proposed s b' v' → v = v') :=
begin
suffices fact : ∀ (b₁ : ballot pid_t) (v₁ : value_t), predicate.invariant
    (λ (s : sys_state pid_t (server pid_t value_t is_quorum vals) (message pid_t value_t)),
      choosable s b₁ →
        proposed s b₁ v₁ →
         ∀ (b₂ : ballot pid_t), b₂ > b₁ → ∀ (v₂ : value_t), proposed s b₂ v₂ → v₁ = v₂),
by { intros s s_r b₁ v₁ cond, exact fact b₁ v₁ s s_r (chosen_imp_choosable cond) },
intros b₁ v₁,
rw predicate.use_any_invariant,
split,
{ intros s hs __,
  rintros ⟨proposer, proposed_by_proposer⟩,
  exfalso,
  exact none_proposed_at_init s hs b₁ proposer ⟨v₁, proposed_by_proposer⟩ },
intros u w u_r hu u_pn_w w_r b₁_choosable_w b₁_v₁_proposed_w b₂ ballot_order v₂ b₂_v₂_proposed_w,
rcases (show _, by exact u_pn_w) with
  ⟨receiver, sender, e, he, deliverable, proc_change, ntwk_change, procs_same, ntwks_same⟩,
have b₁_choosable : choosable u b₁ := choosable_reverse_stable u_pn_w b₁_choosable_w,
have already_proposed_or_currently_proposed : proposed u b₂ v₂ ∨ ∃ e' ∈ (protocol.handler receiver (u.procs receiver) e.msg sender).snd, (envelope.msg e') = message.p2a {bal := b₂, val := v₂},
by {
  rcases b₂_v₂_proposed_w with ⟨proposer, e', he', e'_msg_is⟩,
  cases decidable.em (proposer = receiver),
  swap,
  { left, rw ntwks_same proposer h at he',
    exact ⟨proposer, e', he', e'_msg_is⟩ },
  rw h at he', clear h proposer,
  rw ntwk_change at he',
  cases he',
  { left, exact ⟨receiver, e', he', e'_msg_is⟩ },
  right, exact ⟨e', he', e'_msg_is⟩,
},
cases already_proposed_or_currently_proposed with b₂_v₂_proposed just_emitted,
{ clear proc_change ntwk_change procs_same ntwks_same he deliverable e,
  suffices b₁_v₁_proposed : proposed u b₁ v₁,
  by { exact hu b₁_choosable b₁_v₁_proposed b₂ ballot_order v₂ b₂_v₂_proposed },
  rcases proposed_imp_majority_sent_p1b u u_r b₂ v₂ b₂_v₂_proposed
    with ⟨promisers, promisers_are_quorum, promisers_made_promise⟩,
  rcases b₁_choosable
    with ⟨possible_voters, possible_voters_are_quorum, possible_voters_may_vote⟩,
  rcases quorum_assumption.intersect promisers possible_voters promisers_are_quorum possible_voters_are_quorum with ⟨a, a_in_inter⟩,
  rw finset.mem_inter at a_in_inter, cases a_in_inter with a_promised a_may_vote,
  specialize possible_voters_may_vote a a_may_vote,
  cases possible_voters_may_vote,
  { rcases voted_imp_proposed a b₁ u u_r possible_voters_may_vote with ⟨v', v'_proposed_u⟩,
    rw proposals_unique w w_r b₁ v₁ v' b₁_v₁_proposed_w (proposed_stable b₁ v' u w v'_proposed_u u_pn_w),
    exact v'_proposed_u },
  specialize promisers_made_promise a a_promised,
  exfalso,
  apply not_le_of_gt ballot_order,
  suffices : b₂ ≤ (u.procs a).curr,
  by { exact le_trans this possible_voters_may_vote },
  cases promisers_made_promise,
  { rw promisers_made_promise,
    apply proposer_ballot_ge u u_r b₂ b₂.address,
    rcases b₂_v₂_proposed with ⟨p, proposed_by_p⟩,
    rw proposer_is_ballot_address u u_r b₂ p ⟨v₂, proposed_by_p⟩,
    exact ⟨v₂, proposed_by_p⟩ },
  have fact : ∃ (e ∈ u.network a) p_or, envelope.msg e = message.p1b b₂ p_or, by {
    cases promisers_made_promise,
    { rcases promisers_made_promise with ⟨e, he, e_is⟩,
      exact ⟨e, he, none, e_is⟩ },
    rcases promisers_made_promise with ⟨e, he, prop, e_is, _⟩,
    exact ⟨e, he, some prop, e_is⟩ },
  rcases fact with ⟨e, he, p_or, e_promises_p_or⟩,
  exact ballot_ge_any_promised a b₂ p_or u u_r ⟨e, he, e_promises_p_or⟩ },
rcases just_emitted with ⟨ep, h_ep, ep_is_proposal⟩,
rcases p2a_emitted ep_is_proposal h_ep with ⟨acked_p_or, e_msg_eq, active, __, v_has_quorum, ep_is⟩, clear __,
have b₁_v₁_proposed : proposed u b₁ v₁,
by {
  rcases b₁_v₁_proposed_w with ⟨proposer, ep1, h_ep1, ep1_is_prop⟩,
  cases decidable.em (proposer = receiver) with cond cond,
  swap,
  { rw ntwks_same proposer cond at h_ep1,
    exact ⟨proposer, ep1, h_ep1, ep1_is_prop⟩ },
  rw cond at h_ep1, clear cond proposer,
  rw ntwk_change at h_ep1,
  cases h_ep1,
  { exact ⟨receiver, ep1, h_ep1, ep1_is_prop⟩ },
  rcases p2a_emitted ep1_is_prop h_ep1 with ⟨acked_p1_or, p1_or_cond, _, _, _, ep1_is⟩,
  have fact : acked_p_or = acked_p1_or, by { rw e_msg_eq at p1_or_cond, injection p1_or_cond },
  rw ep_is at ep_is_proposal,
  rw ep1_is at ep1_is_prop,
  rw fact at ep_is_proposal,
  injection eq.trans (eq.symm ep1_is_prop) ep_is_proposal with props_same,
  injection props_same with ballots_same,
  exfalso, exact (ne_of_lt ballot_order) ballots_same
},
suffices : v₁ = proposal.value_or_default (proposal.merge (u.procs receiver).accepted acked_p_or)
                                (vals receiver),
by {
  rw this,
  rw ep_is at ep_is_proposal,
  injection ep_is_proposal with proposals_match,
  injection proposals_match
},
suffices : ∃ stored, (proposal.merge (u.procs receiver).accepted acked_p_or) = some stored ∧ stored.val = v₁,
by {
  rcases this with ⟨stored, merge_eq, merged_val⟩,
  rw merge_eq,
  unfold proposal.value_or_default,
  exact eq.symm merged_val
},
suffices : ∃ stored, (proposal.merge (u.procs receiver).accepted acked_p_or) = some stored ∧ stored.bal ≥ b₁,
by {
  rcases this with ⟨stored, merge_eq, stored_bal_larger⟩,
  use [stored, merge_eq],
  cases proposal.merge_is_one_of (u.procs receiver).accepted acked_p_or with is_from is_from;
  rw is_from at merge_eq,
  { have stored_proposed_at_u := (accepted_means_issued u u_r).left receiver stored merge_eq,
    cases le_iff_lt_or_eq.mp stored_bal_larger,
    { specialize hu b₁_choosable b₁_v₁_proposed stored.bal h stored.val stored_proposed_at_u,
      exact eq.symm hu },
    rw h at b₁_v₁_proposed_w,
    exact proposals_unique w w_r stored.bal stored.val v₁ (proposed_stable stored.bal stored.val u w stored_proposed_at_u u_pn_w) b₁_v₁_proposed_w },
  have stored_proposed_at_u : proposed u stored.bal stored.val, by
  { apply (accepted_means_issued u u_r).right sender e he (u.procs receiver).curr stored,
    rw e_msg_eq, rw merge_eq },
  cases le_iff_lt_or_eq.mp stored_bal_larger,
  { specialize hu b₁_choosable b₁_v₁_proposed stored.bal h stored.val stored_proposed_at_u,
    exact eq.symm hu },
  rw h at b₁_v₁_proposed_w,
  exact proposals_unique w w_r stored.bal stored.val v₁ (proposed_stable stored.bal stored.val u w stored_proposed_at_u u_pn_w) b₁_v₁_proposed_w
},
have u_curr_ballot_is_b₂: (u.procs receiver).curr = b₂, by {
  rw ep_is at ep_is_proposal,
  injection ep_is_proposal with proposals_eq,
  injection proposals_eq
},
clear ep_is ep_is_proposal h_ep ep procs_same ntwks_same,
rcases b₁_choosable with ⟨poss_voters, poss_voters_quorum, all_voted_or_may_vote⟩,
rcases quorum_assumption.intersect poss_voters ((u.procs receiver).followers ∪ {sender}) poss_voters_quorum v_has_quorum with ⟨a, a_in_both⟩,
rw finset.mem_inter at a_in_both,
cases a_in_both with a_is_possible_voter a_is_follower,
specialize all_voted_or_may_vote a a_is_possible_voter, clear a_is_possible_voter,
rw finset.mem_union at a_is_follower,
clear poss_voters_quorum poss_voters,
cases a_is_follower,
swap,
{ rw finset.mem_singleton at a_is_follower,
  cases all_voted_or_may_vote with voted impossible,
  { rw ← a_is_follower at he,
    cases none_voted_between_p1b u u_r a b₁ (u.procs receiver).curr acked_p_or voted
                                 ⟨e, he, e_msg_eq⟩,
    { rw u_curr_ballot_is_b₂ at h, exact (not_le_of_lt ballot_order h).elim, },
    rcases h with ⟨p, ack_eq, p_bal_ge⟩,
    rw ack_eq,
    rcases proposal.merge_ballot_ge_right (u.procs receiver).accepted p
      with ⟨stored, stored_eq, stored_ge⟩,
    exact ⟨stored, stored_eq, le_trans p_bal_ge stored_ge⟩ },
  exfalso,
  have key := ballot_ge_any_promised sender (u.procs receiver).curr acked_p_or u u_r ⟨e, he, e_msg_eq⟩,
  rw a_is_follower at impossible,
  rw u_curr_ballot_is_b₂ at key,
  exact not_le_of_lt ballot_order (le_trans key impossible) },
have fact := followers_sent_p1b u u_r receiver active a a_is_follower,
clear a_is_follower,
cases fact,
{ rw fact at all_voted_or_may_vote, clear fact a,
  cases all_voted_or_may_vote with voted impossible,
  { rcases accepted_ge_any_voted receiver b₁ u u_r voted
      with ⟨old_stored, old_stored_eq, old_stored_ge⟩,
    rw old_stored_eq, clear old_stored_eq,
    rcases proposal.merge_ballot_ge_left old_stored acked_p_or
      with ⟨stored, stored_eq, stored_ge⟩,
    exact ⟨stored, stored_eq, le_trans old_stored_ge stored_ge⟩ },
  rw u_curr_ballot_is_b₂ at impossible,
  exfalso,
  exact not_le_of_lt ballot_order impossible },
cases fact,
{ exfalso,
  cases all_voted_or_may_vote with impossible impossible,
  { cases none_voted_between_p1b u u_r a b₁ (u.procs receiver).curr none impossible fact,
    { rw u_curr_ballot_is_b₂ at h,
      exact not_le_of_lt ballot_order h },
    rcases h with ⟨_, bad, _⟩, injection bad },
  have key := ballot_ge_any_promised a (u.procs receiver).curr none u u_r fact,
  rw u_curr_ballot_is_b₂ at key,
  exact not_le_of_lt ballot_order (le_trans key impossible) },
rcases fact with ⟨e', he', prop, e'_msg_eq, old_stored, accepted_eq_old_stored, old_stored_ge⟩,
rw accepted_eq_old_stored,
cases all_voted_or_may_vote with voted impossible,
{ cases none_voted_between_p1b u u_r a b₁ (u.procs receiver).curr (some prop) voted ⟨e', he', e'_msg_eq⟩,
  { rw u_curr_ballot_is_b₂ at h,
    exact (not_le_of_lt ballot_order h).elim },
  rcases h with ⟨p, p_eq_prop_tmp, p_ge_bal⟩,
  have p_eq_prop : prop = p, by { injection p_eq_prop_tmp },
  rw ← p_eq_prop at p_ge_bal,
  clear p_eq_prop_tmp p_eq_prop p,
  rcases proposal.merge_ballot_ge_left old_stored acked_p_or
    with ⟨stored, stored_eq, ge_old_stored⟩,
  exact ⟨stored, stored_eq, le_trans p_ge_bal (le_trans old_stored_ge ge_old_stored)⟩ },
exfalso,
have key := ballot_ge_any_promised a (u.procs receiver).curr (some prop) u u_r ⟨e', he', e'_msg_eq⟩,
rw u_curr_ballot_is_b₂ at key,
exact not_le_of_lt ballot_order (le_trans key impossible)
end

-- The safety of paxos: if two values are chosen at a state, then both values are the same.
--
-- The argument is as follows: the values are chosen because two proposals are
-- chosen. If the proposals have the same ballot, then they have the same value
-- and we are done.
--
-- So assume they don't have the same ballot; then all we need to show is that
-- if two proposals are chosen and one has a higher ballot than the other, then
-- the two proposals have the same value. To do that, it suffices to show that
-- if b < b' are ballots proposed with values v and v', and ballot b is chosen,
-- then v = v' (regardless of whether ballot b' is chosen). This is shown in
-- proposed_higher_than_chosen_has_same_val.
theorem at_most_one_value_chosen : predicate.invariant
  (λ s : sys_state pid_t (server pid_t value_t is_quorum vals) (message pid_t value_t),
    safety s) :=
begin
intros u u_r v v',
rintros ⟨b, proposed_b_v, chosen_b⟩,
rintros ⟨b', proposed_b'_v', chosen_b'⟩,
cases lt_trichotomy b b' with b_lt_b' b_ge_b',
swap,
cases b_ge_b' with b_eq_b' b_gt_b',
{ have proposed_b_v' : proposed u b v', by { rw b_eq_b', exact proposed_b'_v' },
  exact proposals_unique u u_r b v v' proposed_b_v proposed_b_v' },
swap,
{ exact proposed_higher_than_chosen_has_same_val
        u u_r b v chosen_b proposed_b_v b' b_lt_b' v' proposed_b'_v' },
symmetry,
exact proposed_higher_than_chosen_has_same_val
      u u_r b' v' chosen_b' proposed_b'_v' b b_gt_b' v proposed_b_v
end


import algebra.group.basic
import group_theory.order_of_element
import group_theory.subgroup.basic

open_locale big_operators

theorem df_3_2_16 (p : ℕ) (hp : prime p) (a : ℕ) :
  a ^ p ≡ a [MOD p]
:=
begin
  sorry,
end


import Src.Prover.Logic

namespace prover
noncomputable section

axiom some {α : Type} [Inhabited α] (P : α → Prop) : α
axiom some_spec {α : Type} [Inhabited α] {P : α → Prop}
  (h : ∃ (x : α), P x) : P (some P)

def someu {α : Type} [Inhabited α] (P : α → Prop) : α :=
some # λ a => P a ∧ ∀ b, P b → b = a

def some' {α : Type} [Inhabited α] {P : α → Prop} (h : ∃ (x : α), P x) : α :=
some P

def someu' {α : Type} [Inhabited α] {P : α → Prop} (h : ∃! (x : α), P x) : α :=
someu P

theorem someu_spec {α : Type} [Inhabited α] {P : α → Prop}
  (h : ∃! (x : α), P x) : P (someu P) :=
and_left # !some_spec # mp exiu_iff h

section Conditional

theorem exi_ite_val {α : Type} (P : Prop) (x y : α) :
  ∃ (z : α), (P → z = x) ∧ (¬P → z = y) :=
prop_rec (λ m => ∃ (z : α), (m → z = x) ∧ (¬m → z = y))
(exi_intro x # and_intro (λ _ => rfl) (λ h => exfalso # h trivial))
(exi_intro y # and_intro exfalso (λ _ => rfl))

def ite {α : Type} [Inhabited α] (P : Prop) (x y : α) : α :=
some' # exi_ite_val P x y

theorem if_pos {α : Type} [Inhabited α] {P : Prop} {x y : α} (h : P) : ite P x y = x :=
and_left (!some_spec # exi_ite_val P x y) h

theorem if_neg {α : Type} [Inhabited α] {P : Prop} {x y : α} (h : ¬P) : ite P x y = y :=
and_right (!some_spec # exi_ite_val P x y) h

theorem split_ifs {α : Type} [Inhabited α] (F : α → Prop) {P : Prop} {x y : α}
  (h₁ : P → F x) (h₂ : ¬P → F y) : F (ite P x y) :=
or_elim (@em P)
(λ h₃ => eq_rec' F (if_pos h₃) # h₁ h₃)
(λ h₃ => eq_rec' F (if_neg h₃) # h₂ h₃)

end Conditional


/-
Copyright (c) 2018 Alexander Bentkamp. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Alexander Bentkamp
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.module.pi
import Mathlib.algebra.big_operators.basic
import Mathlib.PostPort

universes u u_1

namespace Mathlib

/-!
# Basic properties of holors

Holors are indexed collections of tensor coefficients. Confusingly,
they are often called tensors in physics and in the neural network
community.

A holor is simply a multidimensional array of values. The size of a
holor is specified by a `list ℕ`, whose length is called the dimension
of the holor.

The tensor product of `x₁ : holor α ds₁` and `x₂ : holor α ds₂` is the
holor given by `(x₁ ⊗ x₂) (i₁ ++ i₂) = x₁ i₁ * x₂ i₂`. A holor is "of
rank at most 1" if it is a tensor product of one-dimensional holors.
The CP rank of a holor `x` is the smallest N such that `x` is the sum
of N holors of rank at most 1.

Based on the tensor library found in <https://www.isa-afp.org/entries/Deep_Learning.html>

## References

* <https://en.wikipedia.org/wiki/Tensor_rank_decomposition>
-/

/-- `holor_index ds` is the type of valid index tuples to identify an entry of a holor of dimensions `ds` -/
def holor_index (ds : List ℕ) :=
  Subtype fun (is : List ℕ) => list.forall₂ Less is ds

namespace holor_index

def take {ds₂ : List ℕ} {ds₁ : List ℕ} : holor_index (ds₁ ++ ds₂) → holor_index ds₁ :=
  sorry

def drop {ds₂ : List ℕ} {ds₁ : List ℕ} : holor_index (ds₁ ++ ds₂) → holor_index ds₂ :=
  sorry

theorem cast_type {ds₁ : List ℕ} {ds₂ : List ℕ} (is : List ℕ) (eq : ds₁ = ds₂) (h : list.forall₂ Less is ds₁) : subtype.val (cast (congr_arg holor_index eq) { val := is, property := h }) = is :=
  eq.drec (Eq.refl (subtype.val (cast (congr_arg holor_index (Eq.refl ds₁)) { val := is, property := h }))) eq

def assoc_right {ds₁ : List ℕ} {ds₂ : List ℕ} {ds₃ : List ℕ} : holor_index (ds₁ ++ ds₂ ++ ds₃) → holor_index (ds₁ ++ (ds₂ ++ ds₃)) :=
  cast sorry

def assoc_left {ds₁ : List ℕ} {ds₂ : List ℕ} {ds₃ : List ℕ} : holor_index (ds₁ ++ (ds₂ ++ ds₃)) → holor_index (ds₁ ++ ds₂ ++ ds₃) :=
  cast sorry

theorem take_take {ds₁ : List ℕ} {ds₂ : List ℕ} {ds₃ : List ℕ} (t : holor_index (ds₁ ++ ds₂ ++ ds₃)) : take (assoc_right t) = take (take t) := sorry

theorem drop_take {ds₁ : List ℕ} {ds₂ : List ℕ} {ds₃ : List ℕ} (t : holor_index (ds₁ ++ ds₂ ++ ds₃)) : take (drop (assoc_right t)) = drop (take t) := sorry

theorem drop_drop {ds₁ : List ℕ} {ds₂ : List ℕ} {ds₃ : List ℕ} (t : holor_index (ds₁ ++ ds₂ ++ ds₃)) : drop (drop (assoc_right t)) = drop t := sorry

end holor_index

/-- Holor (indexed collections of tensor coefficients) -/
def holor (α : Type u) (ds : List ℕ) :=
  holor_index ds → α

namespace holor

protected instance inhabited {α : Type} {ds : List ℕ} [Inhabited α] : Inhabited (holor α ds) :=
  { default := fun (t : holor_index ds) => Inhabited.default }

protected instance has_zero {α : Type} {ds : List ℕ} [HasZero α] : HasZero (holor α ds) :=
  { zero := fun (t : holor_index ds) => 0 }

protected instance has_add {α : Type} {ds : List ℕ} [Add α] : Add (holor α ds) :=
  { add := fun (x y : holor α ds) (t : holor_index ds) => x t + y t }

protected instance has_neg {α : Type} {ds : List ℕ} [Neg α] : Neg (holor α ds) :=
  { neg := fun (a : holor α ds) (t : holor_index ds) => -a t }

protected instance add_semigroup {α : Type} {ds : List ℕ} [add_semigroup α] : add_semigroup (holor α ds) :=
  add_semigroup.mk (fun (ᾰ ᾰ_1 : holor α ds) => id fun (ᾰ_2 : holor_index ds) => add_semigroup.add (ᾰ ᾰ_2) (ᾰ_1 ᾰ_2))
    sorry

protected instance add_comm_semigroup {α : Type} {ds : List ℕ} [add_comm_semigroup α] : add_comm_semigroup (holor α ds) :=
  add_comm_semigroup.mk
    (fun (ᾰ ᾰ_1 : holor α ds) => id fun (ᾰ_2 : holor_index ds) => add_comm_semigroup.add (ᾰ ᾰ_2) (ᾰ_1 ᾰ_2)) sorry sorry

protected instance add_monoid {α : Type} {ds : List ℕ} [add_monoid α] : add_monoid (holor α ds) :=
  add_monoid.mk (fun (ᾰ ᾰ_1 : holor α ds) => id fun (ᾰ_2 : holor_index ds) => add_monoid.add (ᾰ ᾰ_2) (ᾰ_1 ᾰ_2)) sorry
    (id fun (ᾰ : holor_index ds) => add_monoid.zero) sorry sorry

protected instance add_comm_monoid {α : Type} {ds : List ℕ} [add_comm_monoid α] : add_comm_monoid (holor α ds) :=
  add_comm_monoid.mk (fun (ᾰ ᾰ_1 : holor α ds) => id fun (ᾰ_2 : holor_index ds) => add_comm_monoid.add (ᾰ ᾰ_2) (ᾰ_1 ᾰ_2))
    sorry (id fun (ᾰ : holor_index ds) => add_comm_monoid.zero) sorry sorry sorry

protected instance add_group {α : Type} {ds : List ℕ} [add_group α] : add_group (holor α ds) :=
  add_group.mk (fun (ᾰ ᾰ_1 : holor α ds) => id fun (ᾰ_2 : holor_index ds) => add_group.add (ᾰ ᾰ_2) (ᾰ_1 ᾰ_2)) sorry
    (id fun (ᾰ : holor_index ds) => add_group.zero) sorry sorry
    (fun (ᾰ : holor α ds) => id fun (ᾰ_1 : holor_index ds) => add_group.neg (ᾰ ᾰ_1))
    (fun (ᾰ ᾰ_1 : holor α ds) => id fun (ᾰ_2 : holor_index ds) => add_group.sub (ᾰ ᾰ_2) (ᾰ_1 ᾰ_2)) sorry

protected instance add_comm_group {α : Type} {ds : List ℕ} [add_comm_group α] : add_comm_group (holor α ds) :=
  add_comm_group.mk (fun (ᾰ ᾰ_1 : holor α ds) => id fun (ᾰ_2 : holor_index ds) => add_comm_group.add (ᾰ ᾰ_2) (ᾰ_1 ᾰ_2))
    sorry (id fun (ᾰ : holor_index ds) => add_comm_group.zero) sorry sorry
    (fun (ᾰ : holor α ds) => id fun (ᾰ_1 : holor_index ds) => add_comm_group.neg (ᾰ ᾰ_1))
    (fun (ᾰ ᾰ_1 : holor α ds) => id fun (ᾰ_2 : holor_index ds) => add_comm_group.sub (ᾰ ᾰ_2) (ᾰ_1 ᾰ_2)) sorry sorry

/- scalar product -/

protected instance has_scalar {α : Type} {ds : List ℕ} [Mul α] : has_scalar α (holor α ds) :=
  has_scalar.mk fun (a : α) (x : holor α ds) (t : holor_index ds) => a * x t

protected instance semimodule {α : Type} {ds : List ℕ} [semiring α] : semimodule α (holor α ds) :=
  pi.semimodule (holor_index ds) (fun (ᾰ : holor_index ds) => α) α

/-- The tensor product of two holors. -/
def mul {α : Type} {ds₁ : List ℕ} {ds₂ : List ℕ} [s : Mul α] (x : holor α ds₁) (y : holor α ds₂) : holor α (ds₁ ++ ds₂) :=
  fun (t : holor_index (ds₁ ++ ds₂)) => x (holor_index.take t) * y (holor_index.drop t)

theorem cast_type {α : Type} {ds₁ : List ℕ} {ds₂ : List ℕ} (eq : ds₁ = ds₂) (a : holor α ds₁) : cast (congr_arg (holor α) eq) a = fun (t : holor_index ds₂) => a (cast (congr_arg holor_index (Eq.symm eq)) t) :=
  eq.drec (Eq.refl (cast (congr_arg (holor α) (Eq.refl ds₁)) a)) eq

def assoc_right {α : Type} {ds₁ : List ℕ} {ds₂ : List ℕ} {ds₃ : List ℕ} : holor α (ds₁ ++ ds₂ ++ ds₃) → holor α (ds₁ ++ (ds₂ ++ ds₃)) :=
  cast sorry

def assoc_left {α : Type} {ds₁ : List ℕ} {ds₂ : List ℕ} {ds₃ : List ℕ} : holor α (ds₁ ++ (ds₂ ++ ds₃)) → holor α (ds₁ ++ ds₂ ++ ds₃) :=
  cast sorry

theorem mul_assoc0 {α : Type} {ds₁ : List ℕ} {ds₂ : List ℕ} {ds₃ : List ℕ} [semigroup α] (x : holor α ds₁) (y : holor α ds₂) (z : holor α ds₃) : mul (mul x y) z = assoc_left (mul x (mul y z)) := sorry

theorem mul_assoc {α : Type} {ds₁ : List ℕ} {ds₂ : List ℕ} {ds₃ : List ℕ} [semigroup α] (x : holor α ds₁) (y : holor α ds₂) (z : holor α ds₃) : mul (mul x y) z == mul x (mul y z) := sorry

theorem mul_left_distrib {α : Type} {ds₁ : List ℕ} {ds₂ : List ℕ} [distrib α] (x : holor α ds₁) (y : holor α ds₂) (z : holor α ds₂) : mul x (y + z) = mul x y + mul x z :=
  funext
    fun (t : holor_index (ds₁ ++ ds₂)) =>
      left_distrib (x (holor_index.take t)) (y (holor_index.drop t)) (z (holor_index.drop t))

theorem mul_right_distrib {α : Type} {ds₁ : List ℕ} {ds₂ : List ℕ} [distrib α] (x : holor α ds₁) (y : holor α ds₁) (z : holor α ds₂) : mul (x + y) z = mul x z + mul y z :=
  funext
    fun (t : holor_index (ds₁ ++ ds₂)) =>
      right_distrib (x (holor_index.take t)) (y (holor_index.take t)) (z (holor_index.drop t))

@[simp] theorem zero_mul {ds₁ : List ℕ} {ds₂ : List ℕ} {α : Type} [ring α] (x : holor α ds₂) : mul 0 x = 0 :=
  funext fun (t : holor_index (ds₁ ++ ds₂)) => zero_mul (x (holor_index.drop t))

@[simp] theorem mul_zero {ds₁ : List ℕ} {ds₂ : List ℕ} {α : Type} [ring α] (x : holor α ds₁) : mul x 0 = 0 :=
  funext fun (t : holor_index (ds₁ ++ ds₂)) => mul_zero (x (holor_index.take t))

theorem mul_scalar_mul {α : Type} {ds : List ℕ} [monoid α] (x : holor α []) (y : holor α ds) : mul x y = x { val := [], property := list.forall₂.nil } • y := sorry

/- holor slices -/

/-- A slice is a subholor consisting of all entries with initial index i. -/
def slice {α : Type} {d : ℕ} {ds : List ℕ} (x : holor α (d :: ds)) (i : ℕ) (h : i < d) : holor α ds :=
  fun (is : holor_index ds) => x { val := i :: subtype.val is, property := sorry }

/-- The 1-dimensional "unit" holor with 1 in the `j`th position. -/
def unit_vec {α : Type} [monoid α] [add_monoid α] (d : ℕ) (j : ℕ) : holor α [d] :=
  fun (ti : holor_index [d]) => ite (subtype.val ti = [j]) 1 0

theorem holor_index_cons_decomp {d : ℕ} {ds : List ℕ} (p : holor_index (d :: ds) → Prop) (t : holor_index (d :: ds)) : (∀ (i : ℕ) (is : List ℕ) (h : subtype.val t = i :: is),
    p
      { val := i :: is,
        property :=
          eq.mpr (id (Eq._oldrec (Eq.refl (list.forall₂ Less (i :: is) (d :: ds))) (Eq.symm h)))
            (subtype.property t) }) →
  p t := sorry

/-- Two holors are equal if all their slices are equal. -/
theorem slice_eq {α : Type} {d : ℕ} {ds : List ℕ} (x : holor α (d :: ds)) (y : holor α (d :: ds)) (h : slice x = slice y) : x = y := sorry

theorem slice_unit_vec_mul {α : Type} {d : ℕ} {ds : List ℕ} [ring α] {i : ℕ} {j : ℕ} (hid : i < d) (x : holor α ds) : slice (mul (unit_vec d j) x) i hid = ite (i = j) x 0 := sorry

theorem slice_add {α : Type} {d : ℕ} {ds : List ℕ} [Add α] (i : ℕ) (hid : i < d) (x : holor α (d :: ds)) (y : holor α (d :: ds)) : slice x i hid + slice y i hid = slice (x + y) i hid := sorry

theorem slice_zero {α : Type} {d : ℕ} {ds : List ℕ} [HasZero α] (i : ℕ) (hid : i < d) : slice 0 i hid = 0 :=
  rfl

theorem slice_sum {α : Type} {d : ℕ} {ds : List ℕ} [add_comm_monoid α] {β : Type} (i : ℕ) (hid : i < d) (s : finset β) (f : β → holor α (d :: ds)) : (finset.sum s fun (x : β) => slice (f x) i hid) = slice (finset.sum s fun (x : β) => f x) i hid := sorry

/-- The original holor can be recovered from its slices by multiplying with unit vectors and summing up. -/
@[simp] theorem sum_unit_vec_mul_slice {α : Type} {d : ℕ} {ds : List ℕ} [ring α] (x : holor α (d :: ds)) : (finset.sum (finset.attach (finset.range d))
    fun (i : Subtype fun (x : ℕ) => x ∈ finset.range d) =>
      mul (unit_vec d ↑i) (slice x (↑i) (nat.succ_le_of_lt (iff.mp finset.mem_range (subtype.prop i))))) =
  x := sorry

/- CP rank -/

/-- `cprank_max1 x` means `x` has CP rank at most 1, that is,
  it is the tensor product of 1-dimensional holors. -/
inductive cprank_max1 {α : Type} [Mul α] : {ds : List ℕ} → holor α ds → Prop
where
| nil : ∀ (x : holor α []), cprank_max1 x
| cons : ∀ {d : ℕ} {ds : List ℕ} (x : holor α [d]) (y : holor α ds), cprank_max1 y → cprank_max1 (mul x y)

/-- `cprank_max N x` means `x` has CP rank at most `N`, that is,
  it can be written as the sum of N holors of rank at most 1. -/
inductive cprank_max {α : Type} [Mul α] [add_monoid α] : ℕ → {ds : List ℕ} → holor α ds → Prop
where
| zero : ∀ {ds : List ℕ}, cprank_max 0 0
| succ : ∀ (n : ℕ) {ds : List ℕ} (x y : holor α ds), cprank_max1 x → cprank_max n y → cprank_max (n + 1) (x + y)

theorem cprank_max_nil {α : Type} [monoid α] [add_monoid α] (x : holor α []) : cprank_max 1 x := sorry

theorem cprank_max_1 {α : Type} {ds : List ℕ} [monoid α] [add_monoid α] {x : holor α ds} (h : cprank_max1 x) : cprank_max 1 x := sorry

theorem cprank_max_add {α : Type} {ds : List ℕ} [monoid α] [add_monoid α] {m : ℕ} {n : ℕ} {x : holor α ds} {y : holor α ds} : cprank_max m x → cprank_max n y → cprank_max (m + n) (x + y) := sorry

theorem cprank_max_mul {α : Type} {d : ℕ} {ds : List ℕ} [ring α] (n : ℕ) (x : holor α [d]) (y : holor α ds) : cprank_max n y → cprank_max n (mul x y) := sorry

theorem cprank_max_sum {α : Type} {ds : List ℕ} [ring α] {β : Type u_1} {n : ℕ} (s : finset β) (f : β → holor α ds) : (∀ (x : β), x ∈ s → cprank_max n (f x)) → cprank_max (finset.card s * n) (finset.sum s fun (x : β) => f x) := sorry

theorem cprank_max_upper_bound {α : Type} [ring α] {ds : List ℕ} (x : holor α ds) : cprank_max (list.prod ds) x := sorry

/-- The CP rank of a holor `x`: the smallest N such that
  `x` can be written as the sum of N holors of rank at most 1. -/
def cprank {α : Type} {ds : List ℕ} [ring α] (x : holor α ds) : ℕ :=
  nat.find sorry

theorem cprank_upper_bound {α : Type} [ring α] {ds : List ℕ} (x : holor α ds) : cprank x ≤ list.prod ds :=
  nat.find_min'
    (Exists.intro (list.prod ds) ((fun (this : cprank_max (list.prod ds) x) => this) (cprank_max_upper_bound x)))
    (cprank_max_upper_bound x)


import analysis.special_functions.pow

import to_mathlib.logic.basic
import to_mathlib.data.nat.basic
import to_mathlib.topology.germ
import to_mathlib.order.filter.basic

import notations
import indexing

noncomputable theory

open set filter
open_locale topology

private def T : ℕ → ℝ := λ n, nat.rec 0 (λ k x, x + 1/(2 : ℝ)^(k+1)) n

open_locale big_operators

-- Note this is more painful than Patrick hoped for. Maybe this should be the definition of T.
private lemma T_eq (n : ℕ) : T n = 1- (1/(2: ℝ))^n :=
begin
  have : T n = ∑ k in finset.range n, 1/(2: ℝ)^(k+1),
  { induction n with n hn,
    { simp only [T, finset.range_zero, finset.sum_empty] },
    change T n + _ = _,
    rw [hn, finset.sum_range_succ] },
  simp_rw [this, ← one_div_pow, pow_succ, ← finset.mul_sum, geom_sum_eq (by norm_num : 1/(2:ℝ) ≠ 1) n],
  field_simp,
  norm_num,
  apply div_eq_of_eq_mul,
  apply neg_ne_zero.mpr,
  apply ne_of_gt,
  positivity,
  ring
end

private lemma T_lt (n : ℕ) : T n < 1 :=
begin
  rw T_eq,
  have : (0 : ℝ) < (1 / 2) ^ n, by positivity,
  linarith
end

private lemma T_lt_succ (n : ℕ) : T n < T (n+1) :=
lt_add_of_le_of_pos le_rfl (one_div_pos.mpr (pow_pos zero_lt_two _))

private lemma T_le_succ (n : ℕ) : T n ≤ T (n+1) := (T_lt_succ n).le

private lemma T_succ_sub (n : ℕ) : T (n+1) - T n = 1/2^(n+1) :=
begin
  change T n + _ - T n = _,
  simp
end

private lemma mul_T_succ_sub (n : ℕ) : 2^(n+1)*(T (n+1) - T n) = 1 :=
begin
  rw T_succ_sub,
  field_simp
end

private lemma T_one : T 1 = 1/2 :=
by simp [T]

private lemma not_T_succ_le (n : ℕ) : ¬ T (n + 1) ≤ 0 :=
begin
  rw [T_eq, not_le],
  have : (1 / (2 : ℝ)) ^ (n + 1) < 1,
  apply pow_lt_one ; norm_num,
  linarith,
end

lemma inductive_htpy_construction_aux {X Y : Type*} [topological_space X]
  {N : ℕ} {U K : index_type N → set X}
  (P₀ P₁ : Π x : X, germ (𝓝 x) Y → Prop) (P₂ : Π p : ℝ × X, germ (𝓝 p) Y → Prop)
  (hP₂ : ∀ a b (p : ℝ × X) (f : ℝ × X → Y), P₂ (a*p.1+b, p.2) f → P₂ p (λ p : ℝ × X, f (a*p.1+b, p.2)))
  {f₀ : X → Y} (init : ∀ x, P₀ x f₀)
  (ind : ∀ (i : index_type N) (f : X → Y), (∀ x, P₀ x f) → (∀ᶠ x near ⋃ j < i, K j, P₁ x f) →
    ∃ F : ℝ → X → Y, (∀ t, ∀ x, P₀ x $ F t) ∧ (∀ᶠ x near ⋃ j ≤ i, K j, P₁ x $ F 1) ∧
                     (∀ p, P₂ p ↿F) ∧ (∀ t, ∀ x ∉ U i, F t x = f x) ∧
                     (∀ᶠ t near Iic 0, F t = f) ∧ (∀ᶠ t near Ici 1, F t = F 1)) :
  ∃ f : ℕ → ℝ × X → Y, ∀ n,
    ((∀ p : ℝ × X, P₀ p.2 (filter.germ.slice_right (f n)) ∧ P₂ p (f n)) ∧
    (∀ᶠ x near (⋃ i ≤ (n : index_type N) , K i), P₁ x (filter.germ.slice_right (f n : (𝓝 (T (n+1), x)).germ Y))) ∧
    (∀ t ≥ T (n+1), ∀ x, f n (t, x) = f n (T (n+1), x)) ∧ (∀ x, f n (0, x) = f₀ x) ∧
    (∀ᶠ t in 𝓝 (T $ n+1), ∀ x, f n (t, x) = f n (T (n+1), x))) ∧
    ((((n+1:ℕ) : index_type N) = n → f (n+1) = f n) ∧
      ∀ x ∉ U (n + 1 : ℕ), ∀ t, f (n+1) (t, x) = f n (t, x))
   :=
begin
  let P₀' : Π p : ℝ × X, germ (𝓝 p) Y → Prop := λ p φ, P₀ p.2 φ.slice_right ∧ P₂ p φ,
  let P₁' : Π p : ℝ × X, germ (𝓝 p) Y → Prop := λ p φ, P₁ p.2 φ.slice_right,
  let P : ℕ → (ℝ × X → Y) → Prop :=
    λ n f, (∀ p, P₀' p f) ∧ (∀ᶠ x near (⋃ i ≤ (n : index_type N) , K i), P₁' (T (n+1), x) f) ∧
           (∀ t ≥ T (n+1), ∀ x, f (t, x) = f (T (n+1), x)) ∧ (∀ x, f (0, x) = f₀ x) ∧
           (∀ᶠ t in 𝓝 (T $ n+1), ∀ x, f (t, x) = f (T (n+1), x)),
  let Q : ℕ → (ℝ × X → Y) → (ℝ × X → Y) → Prop :=
    λ n f f', ((((n+1:ℕ) : index_type N) = n) → f' = f) ∧
              (∀ x ∉ U (n + 1 : ℕ), ∀ t, f' (t, x) = f (t, x)),
  change ∃ f : ℕ → ℝ × X → Y, ∀ n, P n (f n) ∧ Q n (f n) (f $ n + 1),
  apply exists_by_induction',
  { dsimp only [P],
    rcases ind 0 f₀ init _ with ⟨f', h₀f', h₁f', hf'₂, hf'not, hf'0, hf'1⟩,
    refine ⟨λ p, f' (2*p.1) p.2, λ p, ⟨_, _⟩, _, _, _, _⟩,
    { exact h₀f' (2*p.1) p.2 },
    { simpa using hP₂ 2 0 p ↿f' (hf'₂ _) },
    { apply h₁f'.mono,
      intros x hx,
      change P₁ x (λ x' : X, f' (2*T (0 + 1)) x'),
      simpa [T] using hx },
    { simp only [T, zero_add, one_div, nat.rec_add_one, algebra_map.coe_zero, nat.rec_zero,
                  pow_one, real.rpow_one, ge_iff_le, mul_inv_cancel_of_invertible],
      intros t ht x,
      rw ← hf'1.on_set (2*t) _,
      change 1 ≤ 2*t,
      field_simp at ht,
      linarith only [ht] },
    { intros x,
      rw hf'0.on_set,
      simp },
    { dsimp only,
      have : 2 * T (0 + 1) = 1, by simp [T_one],
      rw [this, zero_add],
      have : 𝓝 (1 : ℝ) ≤ 𝓝ˢ (Ici 1),
            { exact nhds_le_nhds_set left_mem_Ici },
      have : f' =ᶠ[𝓝 1] λ t, f' 1 := hf'1.filter_mono this,
      have lim : tendsto (λ t : ℝ, 2*t) (𝓝 $ T 1) (𝓝 1),
      { rw [T_one],
        convert tendsto_id.const_mul (2 : ℝ),
        simp },
      apply (this.comp_fun lim).mono (λ t ht, _),
      intro x',
      apply congr_fun ht },
    { simp [index_type.not_lt_zero] } },
  { rintros n f ⟨h₀'f, h₁f, hinvf, hf0, hfTn1⟩,
    rcases index_type.lt_or_eq_succ N n with hn | hn,
    { simp_rw index_type.le_or_lt_succ hn at h₁f,
      rcases ind (n+1 : ℕ) (λ x, f (T (n+1), x)) (λ x, (h₀'f (T (n+1), x)).1) h₁f with
        ⟨f', h₀f', h₁f', hf'₂, hf'not, hf'0, hf'1⟩,
      refine ⟨λ p, if p.1 ≥ T (n+1) then f' (2^(n+2)*(p.1 - T (n+1))) p.2 else f p, ⟨λ p, ⟨_, _⟩, _, _, _, _⟩, _, _⟩,
      { by_cases ht : (T $ n+1) ≤ p.1,
        { convert h₀f' (2^(n+2)*(p.1-T (n+1))) p.2 using 1,
          apply quotient.sound,
          simp [ht] },
        { convert (h₀'f p).1 using 1,
          apply quotient.sound,
          simp [ht] } },
      { rcases lt_trichotomy (T $ n+1) p.1 with ht|ht|ht,
        { convert hP₂ (2^(n+2)) (-2^(n+2)*T (n+1)) p ↿f' (hf'₂ _) using 1,
          apply quotient.sound,
          have hp : ∀ᶠ (q : ℝ × X) in 𝓝 p, T (n+1) ≤ q.1,
          { cases p with t x,
            apply mem_of_superset (prod_mem_nhds (Ioi_mem_nhds ht) univ_mem),
            rintros ⟨t', x'⟩ ⟨ht', hx'⟩,
            exact le_of_lt ht' },
          apply hp.mono (λ q hq, _),
          simp [if_pos hq, mul_sub, neg_mul],
          refl },
        { let g : ℝ × X → Y := λ p, f' (2 ^ (n + 2) * (p.fst - T (n + 1))) p.snd,
          have hg : P₂ p g,
          { convert hP₂ (2^(n+2)) (-2^(n+2)*T (n+1)) p ↿f' (hf'₂ _) using 2,
            ext q,
            dsimp only [g],
            ring_nf },
          convert hg using 1,
          apply quotient.sound,
          apply filter.eventually_eq.eventually_eq_ite,
          cases p with t x,
          have hf : f =ᶠ[𝓝 (t, x)] λ q : ℝ × X, f (T (n + 1), q.2),
          { change T (n+1) = t at ht,
            rw ← ht,
            apply mem_of_superset (prod_mem_nhds hfTn1 univ_mem),
            rintros ⟨t', x'⟩ ⟨ht', hx'⟩,
            exact ht' x' },
          replace hf'0 : ↿f' =ᶠ[𝓝 (0, x)] λ q : ℝ × X, f (T (n + 1), q.2),
          { have : 𝓝 (0 : ℝ) ≤ 𝓝ˢ (Iic 0),
            { exact nhds_le_nhds_set right_mem_Iic },
            apply mem_of_superset (prod_mem_nhds (hf'0.filter_mono this) univ_mem),
            rintros ⟨t', x'⟩ ⟨ht', hx'⟩,
            exact (congr_fun ht' x' : _) },
          have : tendsto (λ (x : ℝ × X), (2 ^ (n + 2) * (x.1 - T (n + 1)), x.2)) (𝓝 (t, x)) (𝓝 (0, x)),
          { rw [nhds_prod_eq, nhds_prod_eq],
            have limt : tendsto (λ t, 2 ^ (n + 2) * (t - T (n + 1))) (𝓝 t) (𝓝 0),
            { rw [show (0 : ℝ) = 2^(n+2)*(T (n+1) - T (n+1)), by simp, ht],
              apply tendsto.const_mul,
              exact tendsto_id.sub_const _ },
            exact limt.prod_map tendsto_id },
          have := hf'0.comp_fun this,
          rw show (λ (q : ℝ × X), f (T (n + 1), q.2)) ∘
            (λ (x : ℝ × X), (2 ^ (n + 2) * (x.1 - T (n + 1)), x.2)) =
            λ q : ℝ × X, f (T (n + 1), q.2),
          by { ext, refl } at this,
          exact this.trans hf.symm },
        { have hp : ∀ᶠ (q : ℝ × X) in 𝓝 p, ¬ T (n+1) ≤ q.1,
          { cases p with t x,
            apply mem_of_superset (prod_mem_nhds (Iio_mem_nhds ht) univ_mem),
            rintros ⟨t', x'⟩ ⟨ht', hx'⟩,
            simpa using ht' },
          convert (h₀'f p).2 using 1,
          apply quotient.sound,
          apply hp.mono (λ q hq, _),
          simp [if_neg hq] } },
      { apply h₁f'.mono,
        intros x hx,
        change P₁ x (λ x', if T (n+2) ≥ T (n+1) then f' (2^(n+2)*(T (n+2) - T (n+1))) x' else _),
        convert hx using 2,
        ext x',
        simp [if_pos (T_le_succ $ n+1), T_succ_sub] },
      { rintros t ht x,
        dsimp only,
        simp only [if_pos ((T_le_succ $ n+1).trans ht), if_pos (T_le_succ $ n+1),
                    T_succ_sub, one_div, mul_inv_cancel_of_invertible],
        replace ht : 1 / 2 ^ (n + 2) ≤ t - T (n+1) := le_sub_iff_add_le'.mpr ht,
        rw ← hf'1.on_set _ _,
        exact (div_le_iff' (by positivity)).mp ht },
      { intros x,
        simp [not_T_succ_le, hf0] },
      { suffices : (λ t x, f' (2 ^ (n + 2) * (t - T (n + 1))) x) =ᶠ[𝓝 (T (n + 2))] (λ t x, f' (2 ^ (n + 2) * (T (n+2) - T (n + 1))) x),
        { have hle : ∀ᶠ (t : ℝ) in 𝓝 (T (n + 1 + 1)), t ≥ T (n+1),
            from eventually_ge_of_tendsto_gt (T_lt_succ _) tendsto_id,
          apply (hle.and this).mono,
          rintros t ⟨ht, ht'⟩ x,
          dsimp only,
          rw [if_pos ht, if_pos (T_le_succ _)],
          apply congr_fun ht' },
        have : 𝓝 (1 : ℝ) ≤ 𝓝ˢ (Ici 1),
            { exact nhds_le_nhds_set left_mem_Ici },
        rw mul_T_succ_sub,
        have : f' =ᶠ[𝓝 1] λ t, f' 1 := hf'1.filter_mono this,
        apply this.comp_fun,
        conv { congr, congr, skip, rw ← mul_T_succ_sub (n+1) },
        exact (tendsto_id.sub_const _).const_mul _ },
      { exact λ hn', (hn.ne hn'.symm).elim },
      { intros x hx t,
        dsimp only,
        split_ifs with ht,
        { rw [hf'not _ _ hx, hinvf _ ht] },
        { refl }, } },
    { simp only [hn] at h₁f,
      refine ⟨f, ⟨h₀'f, _, _, hf0, _⟩, _, _⟩,
      { apply h₁f.mono,
        intros x hx,
        change P₁ x (λ x, f (T (n+2), x)),
        convert hx using 2,
        ext x',
        apply  hinvf,
        apply T_le_succ },
      { intros t ht x,
        rw [hinvf (T $ n+1+1) (T_le_succ _), hinvf _ ((T_le_succ $ n+1).trans ht)] },
      { have hle : ∀ᶠ (t : ℝ) in 𝓝 (T (n + 1 + 1)), t ≥ T (n+1),
            from eventually_ge_of_tendsto_gt (T_lt_succ _) tendsto_id,
        apply hle.mono (λ t ht, _),
        intro x,
        rw [hinvf t ht, hinvf (T $ n+2) (T_le_succ _)] },
      { simp },
      { simp } } }
end

/- TODO: think whether `∀ x ∈ ⋃ j < i, K j, P₁ x f` should be something more general. -/
lemma inductive_htpy_construction {X Y : Type*} [topological_space X]
  {N : ℕ} {U K : index_type N → set X}
  (P₀ P₁ : Π x : X, germ (𝓝 x) Y → Prop) (P₂ : Π p : ℝ × X, germ (𝓝 p) Y → Prop)
  (hP₂ : ∀ a b (p : ℝ × X) (f : ℝ × X → Y), P₂ (a*p.1+b, p.2) f → P₂ p (λ p : ℝ × X, f (a*p.1+b, p.2)))
  (U_fin : locally_finite U) (K_cover : (⋃ i, K i) = univ)
  {f₀ : X → Y} (init : ∀ x, P₀ x f₀)
  (ind : ∀ (i : index_type N) (f : X → Y), (∀ x, P₀ x f) → (∀ᶠ x near ⋃ j < i, K j, P₁ x f) →
    ∃ F : ℝ → X → Y, (∀ t, ∀ x, P₀ x $ F t) ∧ (∀ᶠ x near ⋃ j ≤ i, K j, P₁ x $ F 1) ∧
                     (∀ p, P₂ p ↿F) ∧ (∀ t, ∀ x ∉ U i, F t x = f x) ∧
                     (∀ᶠ t near Iic 0, F t = f) ∧ (∀ᶠ t near Ici 1, F t = F 1)) :
  ∃ F : ℝ → X → Y, F 0 = f₀ ∧ (∀ t x, P₀ x (F t)) ∧ (∀ x, P₁ x (F 1)) ∧ (∀ p, P₂ p ↿F) :=
begin
  let P₀' : Π p : ℝ × X, germ (𝓝 p) Y → Prop := λ p φ, P₀ p.2 φ.slice_right ∧ P₂ p φ,
  let P₁' : Π p : ℝ × X, germ (𝓝 p) Y → Prop := λ p φ, P₁ p.2 φ.slice_right,
  let P : ℕ → (ℝ × X → Y) → Prop :=
    λ n f, (∀ p, P₀' p f) ∧ (∀ᶠ x near (⋃ i ≤ (n : index_type N) , K i), P₁' (T (n+1), x) f) ∧
           (∀ t ≥ T (n+1), ∀ x, f (t, x) = f (T (n+1), x)) ∧ (∀ x, f (0, x) = f₀ x) ∧
           (∀ᶠ t in 𝓝 (T $ n+1), ∀ x, f (t, x) = f (T (n+1), x)),
  let Q : ℕ → (ℝ × X → Y) → (ℝ × X → Y) → Prop :=
    λ n f f', ((((n+1:ℕ) : index_type N) = n) → f' = f) ∧
              (∀ x ∉ U (n + 1 : ℕ), ∀ t, f' (t, x) = f (t, x)),
  obtain ⟨f, hf⟩ : ∃ f : ℕ → ℝ × X → Y, ∀ n, P n (f n) ∧ Q n (f n) (f $ n + 1),
  { apply inductive_htpy_construction_aux; assumption },
  simp only [P, Q, forall_and_distrib, forall₂_and_distrib] at hf,
  rcases hf with ⟨⟨⟨h₀f, h₂f⟩, h₁f, hinvf, hf0, hfTsucc⟩, hf₁, hf₃⟩,
  choose W W_in hW using U_fin,
  choose i₀ hi₀ using λ x, (hW x).bdd_above,
  have : ∀ x, ∃ n : ℕ, x ∈ K n,
  { intros x,
    rcases eq_univ_iff_forall.mp K_cover x with ⟨-, ⟨i, rfl⟩, hi⟩,
    use indexing.to_nat i,
    simpa using hi },
  choose nK hnK using this,
  let n₀ : X → ℕ := λ x, max (nK x) (indexing.to_nat (i₀ x)),
  have key : ∀ {x : X} {n}, n ≥ n₀ x → ∀ {q : ℝ × X}, q.2 ∈ W x → f n q = f (n₀ x) q,
  { intros x₀ n hn,
    rcases le_iff_exists_add.mp hn with ⟨k, rfl⟩, clear hn,
    rintros ⟨t, x⟩ (hx : x ∈ _),
    induction k with k hk,
    { rw add_zero },
    rw ← hk, clear hk,
    let π :  ℕ → index_type N := indexing.from_nat,
    have : ∀ n, π n < π (n+1) ∨ π n = π (n+1),
    exact λ n, lt_or_eq_of_le (indexing.mono_from n.le_succ),
    rcases this (n₀ x₀ + k) with H | H ; clear this,
    { have ineq : i₀ x₀ < π (n₀ x₀ + k + 1),
      { suffices : i₀ x₀ ≤ π (n₀ x₀ + k), from lt_of_le_of_lt this H,
        rw ← indexing.from_to (i₀ x₀),
        exact indexing.mono_from ((le_max_right _ _).trans le_self_add) },
      apply hf₃,
      intros hx',
      exact lt_irrefl _ (ineq.trans_le $ hi₀ x₀ ⟨x, ⟨hx', hx⟩⟩) },
    { rw [← nat.add_one, ← add_assoc, hf₁ _ H.symm] } },
  have key' : ∀ p : ℝ × X, ∀ n ≥ n₀ p.2, f n =ᶠ[𝓝 p] λ q, f (n₀ q.2) q,
  { rintros ⟨t, x⟩ n hn,
    apply mem_of_superset (prod_mem_nhds univ_mem $ W_in x) (λ p hp, _),
    dsimp only [mem_set_of],
    calc f n p = f (n₀ x) p : key hn hp.2
    ... = f (max (n₀ x) (n₀ p.2)) p : (key (le_max_left (n₀ x) _) hp.2).symm
    ... = f (n₀ p.2) p : key (le_max_right _ _) (mem_of_mem_nhds $ W_in _) },
  have key'' : ∀ p : ℝ × X, ∀ᶠ (n : ℕ) in at_top, f n =ᶠ[𝓝 p] λ q, f (n₀ q.2) q,
  { exact λ p, (eventually_ge_at_top (n₀ p.2)).mono (λ n hn, key' p n hn) },
  refine ⟨λ t x, f (n₀ x) (t, x), _, _, _, _⟩,
  { ext x,
    rw hf0 },
  { intros t x,
    convert h₀f (n₀ x) (t, x) using 1,
    apply quotient.sound,
    exact ((key' (t, x) _ le_rfl).comp_fun (continuous.prod.mk t).continuous_at).symm },
  { intro x,
    convert (h₁f (n₀ x)).on_set x (mem_Union₂_of_mem (indexing.coe_mono $ le_max_left _ _) $ hnK x) using 1,
    apply quotient.sound,
    change (λ x', f (n₀ x') (1, x')) =ᶠ[𝓝 x] λ (x' : X), f (n₀ x) (T (n₀ x + 1), x'),
    simp_rw ← hinvf (n₀ x) 1 (T_lt _).le,
    exact ((key' (1, x) _ le_rfl).comp_fun (continuous.prod.mk 1).continuous_at).symm },
  { rintros p,
    convert h₂f (n₀ p.2) p using 1,
    apply quotient.sound,
    rw show ↿(λ t x, f (n₀ x) (t, x)) = λ p : ℝ × X, f (n₀ p.2) p, by ext ⟨s, y⟩ ; refl,
    exact (key' p _ le_rfl).symm }
end


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Reid Barton
-/
import category_theory.limits.shapes.images
import category_theory.filtered
import tactic.equiv_rw

/-!
# Limits in the category of types.

We show that the category of types has all (co)limits, by providing the usual concrete models.

We also give a characterisation of filtered colimits in `Type`, via
`colimit.ι F i xi = colimit.ι F j xj ↔ ∃ k (f : i ⟶ k) (g : j ⟶ k), F.map f xi = F.map g xj`.

Finally, we prove the category of types has categorical images,
and that these agree with the range of a function.
-/

universes v u

open category_theory
open category_theory.limits

namespace category_theory.limits.types

variables {J : Type v} [small_category J]

/--
(internal implementation) the limit cone of a functor,
implemented as flat sections of a pi type
-/
def limit_cone (F : J ⥤ Type (max v u)) : cone F :=
{ X := F.sections,
  π := { app := λ j u, u.val j } }

local attribute [elab_simple] congr_fun
/-- (internal implementation) the fact that the proposed limit cone is the limit -/
def limit_cone_is_limit (F : J ⥤ Type (max v u)) : is_limit (limit_cone F) :=
{ lift := λ s v, ⟨λ j, s.π.app j v, λ j j' f, congr_fun (cone.w s f) _⟩,
  uniq' := by { intros, ext x j, exact congr_fun (w j) x } }

/--
The category of types has all limits.

See <https://stacks.math.columbia.edu/tag/002U>.
-/
instance has_limits_of_size : has_limits_of_size.{v} (Type (max v u)) :=
{ has_limits_of_shape := λ J 𝒥, by exactI
  { has_limit := λ F, has_limit.mk
    { cone := limit_cone F, is_limit := limit_cone_is_limit F } } }

instance : has_limits (Type u) := types.has_limits_of_size.{u u}

/--
The equivalence between a limiting cone of `F` in `Type u` and the "concrete" definition as the
sections of `F`.
-/
def is_limit_equiv_sections {F : J ⥤ Type (max v u)} {c : cone F} (t : is_limit c) :
  c.X ≃ F.sections :=
(is_limit.cone_point_unique_up_to_iso t (limit_cone_is_limit F)).to_equiv

@[simp]
lemma is_limit_equiv_sections_apply
  {F : J ⥤ Type (max v u)} {c : cone F} (t : is_limit c) (j : J) (x : c.X) :
  (((is_limit_equiv_sections t) x) : Π j, F.obj j) j = c.π.app j x :=
rfl

@[simp]
lemma is_limit_equiv_sections_symm_apply
  {F : J ⥤ Type (max v u)} {c : cone F} (t : is_limit c) (x : F.sections) (j : J) :
  c.π.app j ((is_limit_equiv_sections t).symm x) = (x : Π j, F.obj j) j :=
begin
  equiv_rw (is_limit_equiv_sections t).symm at x,
  simp,
end

/--
The equivalence between the abstract limit of `F` in `Type u`
and the "concrete" definition as the sections of `F`.
-/
noncomputable
def limit_equiv_sections (F : J ⥤ Type (max v u)) : (limit F : Type (max v u)) ≃ F.sections :=
is_limit_equiv_sections (limit.is_limit _)

@[simp]
lemma limit_equiv_sections_apply (F : J ⥤ Type (max v u)) (x : limit F) (j : J) :
  (((limit_equiv_sections F) x) : Π j, F.obj j) j = limit.π F j x :=
rfl

@[simp]
lemma limit_equiv_sections_symm_apply (F : J ⥤ Type (max v u)) (x : F.sections) (j : J) :
  limit.π F j ((limit_equiv_sections F).symm x) = (x : Π j, F.obj j) j :=
is_limit_equiv_sections_symm_apply _ _ _

@[simp]
lemma limit_equiv_sections_symm_apply' (F : J ⥤ Type v) (x : F.sections) (j : J) :
  limit.π F j ((limit_equiv_sections.{v v} F).symm x) = (x : Π j, F.obj j) j :=
is_limit_equiv_sections_symm_apply _ _ _

/--
Construct a term of `limit F : Type u` from a family of terms `x : Π j, F.obj j`
which are "coherent": `∀ (j j') (f : j ⟶ j'), F.map f (x j) = x j'`.
-/
@[ext]
noncomputable
def limit.mk (F : J ⥤ Type (max v u)) (x : Π j, F.obj j)
  (h : ∀ (j j') (f : j ⟶ j'), F.map f (x j) = x j') : (limit F : Type (max v u)) :=
(limit_equiv_sections F).symm ⟨x, h⟩

@[simp]
lemma limit.π_mk (F : J ⥤ Type (max v u)) (x : Π j, F.obj j)
  (h : ∀ (j j') (f : j ⟶ j'), F.map f (x j) = x j') (j) : limit.π F j (limit.mk F x h) = x j :=
by { dsimp [limit.mk], simp, }

@[simp]
lemma limit.π_mk' (F : J ⥤ Type v) (x : Π j, F.obj j)
  (h : ∀ (j j') (f : j ⟶ j'), F.map f (x j) = x j') (j) :
  limit.π F j (limit.mk.{v v} F x h) = x j :=
by { dsimp [limit.mk], simp, }

-- PROJECT: prove this for concrete categories where the forgetful functor preserves limits
@[ext]
lemma limit_ext (F : J ⥤ Type (max v u)) (x y : limit F) (w : ∀ j, limit.π F j x = limit.π F j y) :
  x = y :=
begin
  apply (limit_equiv_sections F).injective,
  ext j,
  simp [w j],
end

@[ext]
lemma limit_ext' (F : J ⥤ Type v) (x y : limit F) (w : ∀ j, limit.π F j x = limit.π F j y) :
  x = y :=
begin
  apply (limit_equiv_sections.{v v} F).injective,
  ext j,
  simp [w j],
end

lemma limit_ext_iff (F : J ⥤ Type (max v u)) (x y : limit F) :
  x = y ↔ (∀ j, limit.π F j x = limit.π F j y) :=
⟨λ t _, t ▸ rfl, limit_ext _ _ _⟩

lemma limit_ext_iff' (F : J ⥤ Type v) (x y : limit F) :
  x = y ↔ (∀ j, limit.π F j x = limit.π F j y) :=
⟨λ t _, t ▸ rfl, limit_ext _ _ _⟩

-- TODO: are there other limits lemmas that should have `_apply` versions?
-- Can we generate these like with `@[reassoc]`?
-- PROJECT: prove these for any concrete category where the forgetful functor preserves limits?

@[simp]
lemma limit.w_apply {F : J ⥤ Type (max v u)} {j j' : J} {x : limit F} (f : j ⟶ j') :
  F.map f (limit.π F j x) = limit.π F j' x :=
congr_fun (limit.w F f) x

@[simp]
lemma limit.lift_π_apply (F : J ⥤ Type (max v u)) (s : cone F) (j : J) (x : s.X) :
  limit.π F j (limit.lift F s x) = s.π.app j x :=
congr_fun (limit.lift_π s j) x

@[simp]
lemma limit.map_π_apply {F G : J ⥤ Type (max v u)} (α : F ⟶ G) (j : J) (x) :
  limit.π G j (lim_map α x) = α.app j (limit.π F j x) :=
congr_fun (lim_map_π α j) x

@[simp]
lemma limit.w_apply' {F : J ⥤ Type v} {j j' : J} {x : limit F} (f : j ⟶ j') :
  F.map f (limit.π F j x) = limit.π F j' x :=
congr_fun (limit.w F f) x

@[simp]
lemma limit.lift_π_apply' (F : J ⥤ Type v) (s : cone F) (j : J) (x : s.X) :
  limit.π F j (limit.lift F s x) = s.π.app j x :=
congr_fun (limit.lift_π s j) x

@[simp]
lemma limit.map_π_apply' {F G : J ⥤ Type v} (α : F ⟶ G) (j : J) (x) :
  limit.π G j (lim_map α x) = α.app j (limit.π F j x) :=
congr_fun (lim_map_π α j) x

/--
The relation defining the quotient type which implements the colimit of a functor `F : J ⥤ Type u`.
See `category_theory.limits.types.quot`.
-/
def quot.rel (F : J ⥤ Type (max v u)) : (Σ j, F.obj j) → (Σ j, F.obj j) → Prop :=
(λ p p', ∃ f : p.1 ⟶ p'.1, p'.2 = F.map f p.2)

/--
A quotient type implementing the colimit of a functor `F : J ⥤ Type u`,
as pairs `⟨j, x⟩` where `x : F.obj j`, modulo the equivalence relation generated by
`⟨j, x⟩ ~ ⟨j', x'⟩` whenever there is a morphism `f : j ⟶ j'` so `F.map f x = x'`.
-/
@[nolint has_inhabited_instance]
def quot (F : J ⥤ Type (max v u)) : Type (max v u) :=
@quot (Σ j, F.obj j) (quot.rel F)

/--
(internal implementation) the colimit cocone of a functor,
implemented as a quotient of a sigma type
-/
def colimit_cocone (F : J ⥤ Type (max v u)) : cocone F :=
{ X := quot F,
  ι :=
  { app := λ j x, quot.mk _ ⟨j, x⟩,
    naturality' := λ j j' f, funext $ λ x, eq.symm (quot.sound ⟨f, rfl⟩) } }

local attribute [elab_with_expected_type] quot.lift

/-- (internal implementation) the fact that the proposed colimit cocone is the colimit -/
def colimit_cocone_is_colimit (F : J ⥤ Type (max v u)) : is_colimit (colimit_cocone F) :=
{ desc := λ s, quot.lift (λ (p : Σ j, F.obj j), s.ι.app p.1 p.2)
    (assume ⟨j, x⟩ ⟨j', x'⟩ ⟨f, hf⟩, by rw hf; exact (congr_fun (cocone.w s f) x).symm) }

/--
The category of types has all colimits.

See <https://stacks.math.columbia.edu/tag/002U>.
-/
instance has_colimits_of_size : has_colimits_of_size.{v} (Type (max v u)) :=
{ has_colimits_of_shape := λ J 𝒥, by exactI
  { has_colimit := λ F, has_colimit.mk
    { cocone := colimit_cocone F, is_colimit := colimit_cocone_is_colimit F } } }

instance : has_colimits (Type u) := types.has_colimits_of_size.{u u}

/--
The equivalence between the abstract colimit of `F` in `Type u`
and the "concrete" definition as a quotient.
-/
noncomputable
def colimit_equiv_quot (F : J ⥤ Type (max v u)) : (colimit F : Type (max v u)) ≃ quot F :=
(is_colimit.cocone_point_unique_up_to_iso
  (colimit.is_colimit F)
  (colimit_cocone_is_colimit F)).to_equiv

@[simp]
lemma colimit_equiv_quot_symm_apply (F : J ⥤ Type (max v u)) (j : J) (x : F.obj j) :
  (colimit_equiv_quot F).symm (quot.mk _ ⟨j, x⟩) = colimit.ι F j x :=
rfl

@[simp]
lemma colimit_equiv_quot_apply (F : J ⥤ Type (max v u)) (j : J) (x : F.obj j) :
  (colimit_equiv_quot F) (colimit.ι F j x) = quot.mk _ ⟨j, x⟩ :=
begin
  apply (colimit_equiv_quot F).symm.injective,
  simp,
end

@[simp]
lemma colimit.w_apply {F : J ⥤ Type (max v u)} {j j' : J} {x : F.obj j} (f : j ⟶ j') :
  colimit.ι F j' (F.map f x) = colimit.ι F j x :=
congr_fun (colimit.w F f) x

@[simp]
lemma colimit.ι_desc_apply (F : J ⥤ Type (max v u)) (s : cocone F) (j : J) (x : F.obj j) :
  colimit.desc F s (colimit.ι F j x) = s.ι.app j x :=
congr_fun (colimit.ι_desc s j) x

@[simp]
lemma colimit.ι_map_apply {F G : J ⥤ Type (max v u)} (α : F ⟶ G) (j : J) (x) :
  colim.map α (colimit.ι F j x) = colimit.ι G j (α.app j x) :=
congr_fun (colimit.ι_map α j) x

@[simp]
lemma colimit.w_apply' {F : J ⥤ Type v} {j j' : J} {x : F.obj j} (f : j ⟶ j') :
  colimit.ι F j' (F.map f x) = colimit.ι F j x :=
congr_fun (colimit.w F f) x

@[simp]
lemma colimit.ι_desc_apply' (F : J ⥤ Type v) (s : cocone F) (j : J) (x : F.obj j) :
  colimit.desc F s (colimit.ι F j x) = s.ι.app j x :=
congr_fun (colimit.ι_desc s j) x

@[simp]
lemma colimit.ι_map_apply' {F G : J ⥤ Type v} (α : F ⟶ G) (j : J) (x) :
  colim.map α (colimit.ι F j x) = colimit.ι G j (α.app j x) :=
congr_fun (colimit.ι_map α j) x

lemma colimit_sound
  {F : J ⥤ Type (max v u)} {j j' : J} {x : F.obj j} {x' : F.obj j'}
  (f : j ⟶ j') (w : F.map f x = x') : colimit.ι F j x = colimit.ι F j' x' :=
begin
  rw [←w],
  simp,
end

lemma colimit_sound'
  {F : J ⥤ Type (max v u)} {j j' : J} {x : F.obj j} {x' : F.obj j'} {j'' : J}
  (f : j ⟶ j'') (f' : j' ⟶ j'') (w : F.map f x = F.map f' x') :
  colimit.ι F j x = colimit.ι F j' x' :=
begin
  rw [←colimit.w _ f, ←colimit.w _ f'],
  rw [types_comp_apply, types_comp_apply, w],
end

lemma colimit_eq {F : J ⥤ Type (max v u)} {j j' : J} {x : F.obj j} {x' : F.obj j'}
  (w : colimit.ι F j x = colimit.ι F j' x') : eqv_gen (quot.rel F) ⟨j, x⟩ ⟨j', x'⟩ :=
begin
  apply quot.eq.1,
  simpa using congr_arg (colimit_equiv_quot F) w,
end

lemma jointly_surjective (F : J ⥤ Type (max v u)) {t : cocone F} (h : is_colimit t)
  (x : t.X) : ∃ j y, t.ι.app j y = x :=
begin
  suffices : (λ (x : t.X), ulift.up (∃ j y, t.ι.app j y = x)) = (λ _, ulift.up true),
  { have := congr_fun this x,
    have H := congr_arg ulift.down this,
    dsimp at H,
    rwa eq_true at H },
  refine h.hom_ext _,
  intro j, ext y,
  erw iff_true,
  exact ⟨j, y, rfl⟩
end

/-- A variant of `jointly_surjective` for `x : colimit F`. -/
lemma jointly_surjective' {F : J ⥤ Type (max v u)}
  (x : colimit F) : ∃ j y, colimit.ι F j y = x :=
jointly_surjective F (colimit.is_colimit _) x

namespace filtered_colimit
/- For filtered colimits of types, we can give an explicit description
  of the equivalence relation generated by the relation used to form
  the colimit.  -/

variables (F : J ⥤ Type (max v u))

/--
An alternative relation on `Σ j, F.obj j`,
which generates the same equivalence relation as we use to define the colimit in `Type` above,
but that is more convenient when working with filtered colimits.

Elements in `F.obj j` and `F.obj j'` are equivalent if there is some `k : J` to the right
where their images are equal.
-/
protected def rel (x y : Σ j, F.obj j) : Prop :=
∃ k (f : x.1 ⟶ k) (g : y.1 ⟶ k), F.map f x.2 = F.map g y.2

lemma eqv_gen_quot_rel_of_rel (x y : Σ j, F.obj j) :
  filtered_colimit.rel F x y → eqv_gen (quot.rel F) x y :=
λ ⟨k, f, g, h⟩, eqv_gen.trans _ ⟨k, F.map f x.2⟩ _ (eqv_gen.rel _ _ ⟨f, rfl⟩)
  (eqv_gen.symm _ _ (eqv_gen.rel _ _ ⟨g, h⟩))

local attribute [elab_simple] nat_trans.app

/-- Recognizing filtered colimits of types. -/
noncomputable def is_colimit_of (t : cocone F) (hsurj : ∀ (x : t.X), ∃ i xi, x = t.ι.app i xi)
  (hinj : ∀ i j xi xj, t.ι.app i xi = t.ι.app j xj →
   ∃ k (f : i ⟶ k) (g : j ⟶ k), F.map f xi = F.map g xj) : is_colimit t :=
-- Strategy: Prove that the map from "the" colimit of F (defined above) to t.X
-- is a bijection.
begin
  apply is_colimit.of_iso_colimit (colimit.is_colimit F),
  refine cocones.ext (equiv.to_iso (equiv.of_bijective _ _)) _,
  { exact colimit.desc F t },
  { split,
    { show function.injective _,
      intros a b h,
      rcases jointly_surjective F (colimit.is_colimit F) a with ⟨i, xi, rfl⟩,
      rcases jointly_surjective F (colimit.is_colimit F) b with ⟨j, xj, rfl⟩,
      change (colimit.ι F i ≫ colimit.desc F t) xi = (colimit.ι F j ≫ colimit.desc F t) xj at h,
      rw [colimit.ι_desc, colimit.ι_desc] at h,
      rcases hinj i j xi xj h with ⟨k, f, g, h'⟩,
      change colimit.ι F i xi = colimit.ι F j xj,
      rw [←colimit.w F f, ←colimit.w F g],
      change colimit.ι F k (F.map f xi) = colimit.ι F k (F.map g xj),
      rw h' },
    { show function.surjective _,
      intro x,
      rcases hsurj x with ⟨i, xi, rfl⟩,
      use colimit.ι F i xi,
      simp } },
  { intro j, apply colimit.ι_desc }
end

variables [is_filtered_or_empty J]

protected lemma rel_equiv : equivalence (filtered_colimit.rel F) :=
⟨λ x, ⟨x.1, 𝟙 x.1, 𝟙 x.1, rfl⟩,
 λ x y ⟨k, f, g, h⟩, ⟨k, g, f, h.symm⟩,
 λ x y z ⟨k, f, g, h⟩ ⟨k', f', g', h'⟩,
   let ⟨l, fl, gl, _⟩ := is_filtered_or_empty.cocone_objs k k',
       ⟨m, n, hn⟩ := is_filtered_or_empty.cocone_maps (g ≫ fl) (f' ≫ gl) in
   ⟨m, f ≫ fl ≫ n, g' ≫ gl ≫ n, calc
      F.map (f ≫ fl ≫ n) x.2
          = F.map (fl ≫ n) (F.map f x.2)  : by simp
      ... = F.map (fl ≫ n) (F.map g y.2)  : by rw h
      ... = F.map ((g ≫ fl) ≫ n) y.2      : by simp
      ... = F.map ((f' ≫ gl) ≫ n) y.2     : by rw hn
      ... = F.map (gl ≫ n) (F.map f' y.2) : by simp
      ... = F.map (gl ≫ n) (F.map g' z.2) : by rw h'
      ... = F.map (g' ≫ gl ≫ n) z.2       : by simp⟩⟩

protected lemma rel_eq_eqv_gen_quot_rel :
  filtered_colimit.rel F = eqv_gen (quot.rel F) :=
begin
  ext ⟨j, x⟩ ⟨j', y⟩,
  split,
  { apply eqv_gen_quot_rel_of_rel },
  { rw ←(filtered_colimit.rel_equiv F).eqv_gen_iff,
    exact eqv_gen.mono (rel_of_quot_rel F) }
end

lemma colimit_eq_iff_aux {i j : J} {xi : F.obj i} {xj : F.obj j} :
  (colimit_cocone F).ι.app i xi = (colimit_cocone F).ι.app j xj ↔
    filtered_colimit.rel F ⟨i, xi⟩ ⟨j, xj⟩ :=
begin
  change quot.mk _ _ = quot.mk _ _ ↔ _,
  rw [quot.eq, filtered_colimit.rel_eq_eqv_gen_quot_rel],
end

lemma is_colimit_eq_iff {t : cocone F} (ht : is_colimit t) {i j : J} {xi : F.obj i} {xj : F.obj j} :
  t.ι.app i xi = t.ι.app j xj ↔ ∃ k (f : i ⟶ k) (g : j ⟶ k), F.map f xi = F.map g xj :=
let t' := colimit_cocone F,
    e : t' ≅ t := is_colimit.unique_up_to_iso (colimit_cocone_is_colimit F) ht,
    e' : t'.X ≅ t.X := (cocones.forget _).map_iso e in
begin
  refine iff.trans _ (colimit_eq_iff_aux F),
  convert e'.to_equiv.apply_eq_iff_eq; rw ←e.hom.w; refl
end

lemma colimit_eq_iff {i j : J} {xi : F.obj i} {xj : F.obj j} :
  colimit.ι F i xi = colimit.ι F j xj ↔ ∃ k (f : i ⟶ k) (g : j ⟶ k), F.map f xi = F.map g xj :=
is_colimit_eq_iff _ (colimit.is_colimit F)

end filtered_colimit

variables {α β : Type u} (f : α ⟶ β)

section -- implementation of `has_image`
/-- the image of a morphism in Type is just `set.range f` -/
def image : Type u := set.range f

instance [inhabited α] : inhabited (image f) :=
{ default := ⟨f default, ⟨_, rfl⟩⟩ }

/-- the inclusion of `image f` into the target -/
def image.ι : image f ⟶ β := subtype.val

instance : mono (image.ι f) :=
(mono_iff_injective _).2 subtype.val_injective

variables {f}

/-- the universal property for the image factorisation -/
noncomputable def image.lift (F' : mono_factorisation f) : image f ⟶ F'.I :=
(λ x, F'.e (classical.indefinite_description _ x.2).1 : image f → F'.I)

lemma image.lift_fac (F' : mono_factorisation f) : image.lift F' ≫ F'.m = image.ι f :=
begin
  ext x,
  change (F'.e ≫ F'.m) _ = _,
  rw [F'.fac, (classical.indefinite_description _ x.2).2],
  refl,
end
end

/-- the factorisation of any morphism in Type through a mono. -/
def mono_factorisation : mono_factorisation f :=
{ I := image f,
  m := image.ι f,
  e := set.range_factorization f }

/-- the facorisation through a mono has the universal property of the image. -/
noncomputable def is_image : is_image (mono_factorisation f) :=
{ lift := image.lift,
  lift_fac' := image.lift_fac }

instance : has_image f :=
has_image.mk ⟨_, is_image f⟩

instance : has_images (Type u) :=
{ has_image := by apply_instance }

instance : has_image_maps (Type u) :=
{ has_image_map := λ f g st, has_image_map.transport st (mono_factorisation f.hom) (is_image g.hom)
    (λ x, ⟨st.right x.1, ⟨st.left (classical.some x.2),
      begin
        have p := st.w,
        replace p := congr_fun p (classical.some x.2),
        simp only [functor.id_map, types_comp_apply, subtype.val_eq_coe] at p,
        erw [p, classical.some_spec x.2],
      end⟩⟩) rfl }

end category_theory.limits.types