/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Mario Carneiro, Minchao Wu
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.core
import Mathlib.PostPort

universes l

namespace Mathlib

/-!
# `#explode` command

Displays a proof term in a line by line format somewhat akin to a Fitch style
proof or the Metamath proof style.
-/

namespace tactic

namespace explode

inductive status
where
| reg : status
| intro : status
| lam : status
| sintro : status

/--
A type to distinguish introduction or elimination rules represented as
strings from theorems referred to by their names.
-/
/--
Turn a thm into a string.
-/
end explode

/--
`#explode decl_name` displays a proof term in a line-by-line format somewhat akin to a Fitch-style
proof or the Metamath proof style.
`#explode_widget decl_name` renders a widget that displays an `#explode` proof.

`#explode iff_true_intro` produces

```lean
iff_true_intro : ∀ {a : Prop}, a → (a ↔ true)
0│   │ a         ├ Prop
1│   │ h         ├ a
2│   │ hl        │ ┌ a
3│   │ trivial   │ │ true
4│2,3│ ∀I        │ a → true
5│   │ hr        │ ┌ true
6│5,1│ ∀I        │ true → a
7│4,6│ iff.intro │ a ↔ true
8│1,7│ ∀I        │ a → (a ↔ true)
9│0,8│ ∀I        │ ∀ {a : Prop}, a → (a ↔ true)
```

In more detail:

The output of `#explode` is a Fitch-style proof in a four-column diagram modeled after Metamath
proof displays like [this](http://us.metamath.org/mpeuni/ru.html). The headers of the columns are
"Step", "Hyp", "Ref", "Type" (or "Expression" in the case of Metamath):
* Step: An increasing sequence of numbers to number each step in the proof, used in the Hyp field.
* Hyp: The direct children of the current step. Most theorems are implications like `A -> B -> C`,
  and so on the step proving `C` the Hyp field will refer to the steps that prove `A` and `B`.
* Ref: The name of the theorem being applied. This is well-defined in Metamath, but in Lean there
  are some special steps that may have long names because the structure of proof terms doesn't
  exactly match this mold.
  * If the theorem is `foo (x y : Z) : A x -> B y -> C x y`:
    * the Ref field will contain `foo`,
    * `x` and `y` will be suppressed, because term construction is not interesting, and
    * the Hyp field will reference steps proving `A x` and `B y`. This corresponds to a proof term
      like `@foo x y pA pB` where `pA` and `pB` are subproofs.
  * If the head of the proof term is a local constant or lambda, then in this case the Ref will
    say `∀E` for forall-elimination. This happens when you have for example `h : A -> B` and
    `ha : A` and prove `b` by `h ha`; we reinterpret this as if it said `∀E h ha` where `∀E` is
    (n-ary) modus ponens.
  * If the proof term is a lambda, we will also use `∀I` for forall-introduction, referencing the
    body of the lambda. The indentation level will increase, and a bracket will surround the proof
    of the body of the lambda, starting at a proof step labeled with the name of the lambda variable
    and its type, and ending with the `∀I` step. Metamath doesn't have steps like this, but the
    style is based on Fitch proofs in first-order logic.
* Type: This contains the type of the proof term, the theorem being proven at the current step.
  This proof layout differs from `#print` in using lots of intermediate step displays so that you
  can follow along and don't have to see term construction steps because they are implicitly in the
  intermediate step displays.

Also, it is common for a Lean theorem to begin with a sequence of lambdas introducing local
constants of the theorem. In order to minimize the indentation level, the `∀I` steps at the end of
the proof will be introduced in a group and the indentation will stay fixed. (The indentation
brackets are only needed in order to delimit the scope of assumptions, and these assumptions
have global scope anyway so detailed tracking is not necessary.)
-/


import Smt

theorem cong (x y : Int) (f : Int → Int) : x = y → f x = f y := by
  smt
  simp_all


/-
Copyright (c) 2019 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.measure_theory.integration
import Mathlib.PostPort

universes u_1 u_2 u_3

namespace Mathlib

/-!
# The Giry monad

Let X be a measurable space. The collection of all measures on X again
forms a measurable space. This construction forms a monad on
measurable spaces and measurable functions, called the Giry monad.

Note that most sources use the term "Giry monad" for the restriction
to *probability* measures. Here we include all measures on X.

See also `measure_theory/category/Meas.lean`, containing an upgrade of the type-level
monad to an honest monad of the functor `Measure : Meas ⥤ Meas`.

## References

* <https://ncatlab.org/nlab/show/Giry+monad>

## Tags

giry monad
-/

namespace measure_theory

namespace measure

/-- Measurability structure on `measure`: Measures are measurable w.r.t. all projections -/
protected instance measurable_space {α : Type u_1} [measurable_space α] : measurable_space (measure α) :=
  supr
    fun (s : set α) =>
      supr fun (hs : is_measurable s) => measurable_space.comap (fun (μ : measure α) => coe_fn μ s) (borel ennreal)

theorem measurable_coe {α : Type u_1} [measurable_space α] {s : set α} (hs : is_measurable s) : measurable fun (μ : measure α) => coe_fn μ s :=
  measurable.of_comap_le
    (le_supr_of_le s
      (le_supr_of_le hs (le_refl (measurable_space.comap (fun (μ : measure α) => coe_fn μ s) ennreal.measurable_space))))

theorem measurable_of_measurable_coe {α : Type u_1} {β : Type u_2} [measurable_space α] [measurable_space β] (f : β → measure α) (h : ∀ (s : set α), is_measurable s → measurable fun (b : β) => coe_fn (f b) s) : measurable f := sorry

theorem measurable_measure {α : Type u_1} {β : Type u_2} [measurable_space α] [measurable_space β] {μ : α → measure β} : measurable μ ↔ ∀ (s : set β), is_measurable s → measurable fun (b : α) => coe_fn (μ b) s :=
  { mp := fun (hμ : measurable μ) (s : set β) (hs : is_measurable s) => measurable.comp (measurable_coe hs) hμ,
    mpr := measurable_of_measurable_coe μ }

theorem measurable_map {α : Type u_1} {β : Type u_2} [measurable_space α] [measurable_space β] (f : α → β) (hf : measurable f) : measurable fun (μ : measure α) => coe_fn (map f) μ := sorry

theorem measurable_dirac {α : Type u_1} [measurable_space α] : measurable dirac := sorry

theorem measurable_lintegral {α : Type u_1} [measurable_space α] {f : α → ennreal} (hf : measurable f) : measurable fun (μ : measure α) => lintegral μ fun (x : α) => f x := sorry

/-- Monadic join on `measure` in the category of measurable spaces and measurable
functions. -/
def join {α : Type u_1} [measurable_space α] (m : measure (measure α)) : measure α :=
  of_measurable (fun (s : set α) (hs : is_measurable s) => lintegral m fun (μ : measure α) => coe_fn μ s) sorry sorry

@[simp] theorem join_apply {α : Type u_1} [measurable_space α] {m : measure (measure α)} {s : set α} : is_measurable s → coe_fn (join m) s = lintegral m fun (μ : measure α) => coe_fn μ s :=
  of_measurable_apply

theorem measurable_join {α : Type u_1} [measurable_space α] : measurable join := sorry

theorem lintegral_join {α : Type u_1} [measurable_space α] {m : measure (measure α)} {f : α → ennreal} (hf : measurable f) : (lintegral (join m) fun (x : α) => f x) = lintegral m fun (μ : measure α) => lintegral μ fun (x : α) => f x := sorry

/-- Monadic bind on `measure`, only works in the category of measurable spaces and measurable
functions. When the function `f` is not measurable the result is not well defined. -/
def bind {α : Type u_1} {β : Type u_2} [measurable_space α] [measurable_space β] (m : measure α) (f : α → measure β) : measure β :=
  join (coe_fn (map f) m)

@[simp] theorem bind_apply {α : Type u_1} {β : Type u_2} [measurable_space α] [measurable_space β] {m : measure α} {f : α → measure β} {s : set β} (hs : is_measurable s) (hf : measurable f) : coe_fn (bind m f) s = lintegral m fun (a : α) => coe_fn (f a) s := sorry

theorem measurable_bind' {α : Type u_1} {β : Type u_2} [measurable_space α] [measurable_space β] {g : α → measure β} (hg : measurable g) : measurable fun (m : measure α) => bind m g :=
  measurable.comp measurable_join (measurable_map g hg)

theorem lintegral_bind {α : Type u_1} {β : Type u_2} [measurable_space α] [measurable_space β] {m : measure α} {μ : α → measure β} {f : β → ennreal} (hμ : measurable μ) (hf : measurable f) : (lintegral (bind m μ) fun (x : β) => f x) = lintegral m fun (a : α) => lintegral (μ a) fun (x : β) => f x :=
  Eq.trans (lintegral_join hf) (lintegral_map (measurable_lintegral hf) hμ)

theorem bind_bind {α : Type u_1} {β : Type u_2} [measurable_space α] [measurable_space β] {γ : Type u_3} [measurable_space γ] {m : measure α} {f : α → measure β} {g : β → measure γ} (hf : measurable f) (hg : measurable g) : bind (bind m f) g = bind m fun (a : α) => bind (f a) g := sorry

theorem bind_dirac {α : Type u_1} {β : Type u_2} [measurable_space α] [measurable_space β] {f : α → measure β} (hf : measurable f) (a : α) : bind (dirac a) f = f a := sorry

theorem dirac_bind {α : Type u_1} [measurable_space α] {m : measure α} : bind m dirac = m := sorry

theorem join_eq_bind {α : Type u_1} [measurable_space α] (μ : measure (measure α)) : join μ = bind μ id :=
  eq.mpr (id (Eq._oldrec (Eq.refl (join μ = bind μ id)) (bind.equations._eqn_1 μ id)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (join μ = join (coe_fn (map id) μ))) map_id)) (Eq.refl (join μ)))

theorem join_map_map {α : Type u_1} {β : Type u_2} [measurable_space α] [measurable_space β] {f : α → β} (hf : measurable f) (μ : measure (measure α)) : join (coe_fn (map ⇑(map f)) μ) = coe_fn (map f) (join μ) := sorry

theorem join_map_join {α : Type u_1} [measurable_space α] (μ : measure (measure (measure α))) : join (coe_fn (map join) μ) = join (join μ) := sorry

theorem join_map_dirac {α : Type u_1} [measurable_space α] (μ : measure α) : join (coe_fn (map dirac) μ) = μ :=
  dirac_bind

theorem join_dirac {α : Type u_1} [measurable_space α] (μ : measure α) : join (dirac μ) = μ :=
  Eq.trans (join_eq_bind (dirac μ)) (bind_dirac measurable_id μ)


import .homotopy_equivalences
import .lemmas

universes v u

open category_theory
open category_theory.category
local notation f ` ∘ `:80 g:80 := g ≫ f

/-

We show that IA is a cylinder object for A, in the sense that
A ⊔ A → IA → A is a factorization of the fold map into a
cofibration followed by a homotopy equivalence.

-/

namespace homotopy_theory.cofibrations
section C
open category_theory.has_initial_object
open homotopy_theory.cylinder
open I_category

parameters {C : Type u} [category.{v} C] [has_initial_object.{v} C]
  [has_coproducts.{v} C] [I_category.{v} C]

lemma cof_ii (a : C) : is_cof (ii.{v} @> a) :=
begin
  let po :=
    (Is_pushout_of_isomorphic (Is_pushout.refl (! (∂I.obj a))) _ _
      (coprod_initial_right ∅).symm (iso.refl _)
      (initial_object.unique Ii_initial has_initial_object.initial_object.is_initial_object)
      _ _),
  convert relative_cylinder' (! a) (all_objects_cofibrant.cofibrant.{v} a) _ _ po,
  any_goals { apply coprod.uniqueness; apply initial.uniqueness },
  symmetry,
  convert ←(po.induced_commutes₀ _ _ _),
  convert id_comp _,
  simp
end

lemma i₀p {a : C} : i.{v} 0 @> a ∘ p @> a ≃ 𝟙 (I.obj a) :=
let ⟨J, hJ₁, hJ₂⟩ :=
  hep_cof (ii.{v} @> a) (cof_ii a) 0 (I.obj a) (i 0 @> a ∘ p @> a)
    (I_of_coprod_is_coproduct.induced (i 0 @> a ∘ p @> a) (𝟙 (I.obj a))) $ begin
      apply coprod.uniqueness; erw i_nat_assoc; simp,
      rw ←assoc, dsimp, simp
    end in
⟨⟨J ∘ T @> a,
  begin
    erw [←assoc, cylinder_has_interchange.Ti],
    have : J ∘ I &> (i 0 @> a) = J ∘ I &> (ii @> a ∘ i₀), by simp [ii], rw this,
    rw [I.map_comp, assoc, hJ₂], simp
  end,
  begin
    erw [←assoc, cylinder_has_interchange.Ti],
    have : J ∘ I &> (i 1 @> a) = J ∘ I &> (ii @> a ∘ i₁), by simp [ii], rw this,
    rw [I.map_comp, assoc, hJ₂], simp
  end⟩⟩

lemma heq_p {a : C} : homotopy_equivalence.{v} (p @> a) :=
homotopy_equivalence_iff.mpr ⟨i 0 @> a, i₀p, by simp; refl⟩

lemma pii {a : C} : p.{v} @> a ∘ ii @> a = coprod.fold a :=
by apply coprod.uniqueness; simp

end C
end homotopy_theory.cofibrations


open Classical

theorem dne {p : Prop} (h : ¬¬p) : p :=
  Or.elim (em p)
    (fun hp : p => hp)
    (fun hnp : ¬p => absurd hnp h)

github-repos/lean/mothematician-lean4-proof-stuff/lean4-proof-stuff-1f202b1d3059f3a36dab9abd7564594bf765ebf2/intro to logic and proofs book/5.1proofbycontradiction.lean


/-
Copyright (c) 2020 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author(s): Simon Hudon
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.group_power.default
import Mathlib.control.uliftable
import Mathlib.control.monad.basic
import Mathlib.data.bitvec.basic
import Mathlib.data.list.basic
import Mathlib.data.set.intervals.basic
import Mathlib.data.stream.basic
import Mathlib.data.fin
import Mathlib.tactic.cache
import Mathlib.tactic.interactive
import Mathlib.tactic.norm_num
import Mathlib.Lean3Lib.system.io
import Mathlib.Lean3Lib.system.random
import Mathlib.PostPort

universes u u_1 v l

namespace Mathlib

/-!
# Rand Monad and Random Class

This module provides tools for formulating computations guided by randomness and for
defining objects that can be created randomly.

## Main definitions
  * `rand` monad for computations guided by randomness;
  * `random` class for objects that can be generated randomly;
    * `random` to generate one object;
    * `random_r` to generate one object inside a range;
    * `random_series` to generate an infinite series of objects;
    * `random_series_r` to generate an infinite series of objects inside a range;
  * `io.mk_generator` to create a new random number generator;
  * `io.run_rand` to run a randomized computation inside the `io` monad;
  * `tactic.run_rand` to run a randomized computation inside the `tactic` monad

## Local notation

 * `i .. j` : `Icc i j`, the set of values between `i` and `j` inclusively;

## Tags

random monad io

## References

  * Similar library in Haskell: https://hackage.haskell.org/package/MonadRandom

-/

/-- A monad to generate random objects using the generator type `g` -/
def rand_g (g : Type) (α : Type u) := state (ulift g) α

/-- A monad to generate random objects using the generator type `std_gen` -/
def rand (α : Type u_1) := rand_g std_gen

protected instance rand_g.uliftable (g : Type) : uliftable (rand_g g) (rand_g g) :=
  state_t.uliftable' (equiv.trans equiv.ulift (equiv.symm equiv.ulift))

/-- Generate one more `ℕ` -/
def rand_g.next {g : Type} [random_gen g] : rand_g g ℕ :=
  state_t.mk (prod.map id ulift.up ∘ random_gen.next ∘ ulift.down)

/-- `bounded_random α` gives us machinery to generate values of type `α` between certain bounds -/
class bounded_random (α : Type u) [preorder α] where
  random_r : (g : Type) → [_inst_1_1 : random_gen g] → (x y : α) → x ≤ y → rand_g g ↥(set.Icc x y)

/-- `random α` gives us machinery to generate values of type `α` -/
class random (α : Type u) where
  random : (g : Type) → [_inst_1 : random_gen g] → rand_g g α

/-- shift_31_left = 2^31; multiplying by it shifts the binary
representation of a number left by 31 bits, dividing by it shifts it
right by 31 bits -/
def shift_31_left : ℕ :=
  bit0
    (bit0
      (bit0
        (bit0
          (bit0
            (bit0
              (bit0
                (bit0
                  (bit0
                    (bit0
                      (bit0
                        (bit0
                          (bit0
                            (bit0
                              (bit0
                                (bit0
                                  (bit0
                                    (bit0
                                      (bit0
                                        (bit0
                                          (bit0
                                            (bit0
                                              (bit0
                                                (bit0
                                                  (bit0
                                                    (bit0
                                                      (bit0
                                                        (bit0
                                                          (bit0
                                                            (bit0
                                                              (bit0 1))))))))))))))))))))))))))))))

namespace rand

/-- create a new random number generator distinct from the one stored in the state -/
def split (g : Type) [random_gen g] : rand_g g g :=
  state_t.mk (prod.map id ulift.up ∘ random_gen.split ∘ ulift.down)

/-- Generate a random value of type `α`. -/
def random (α : Type u) {g : Type} [random_gen g] [random α] : rand_g g α := random α g

/-- generate an infinite series of random values of type `α` -/
def random_series (α : Type u) {g : Type} [random_gen g] [random α] : rand_g g (stream α) :=
  do
    let gen ← uliftable.up (split g)
    pure (stream.corec_state (random α g) gen)

/-- Generate a random value between `x` and `y` inclusive. -/
def random_r {α : Type u} {g : Type} [random_gen g] [preorder α] [bounded_random α] (x : α) (y : α)
    (h : x ≤ y) : rand_g g ↥(set.Icc x y) :=
  bounded_random.random_r g x y h

/-- generate an infinite series of random values of type `α` between `x` and `y` inclusive. -/
def random_series_r {α : Type u} {g : Type} [random_gen g] [preorder α] [bounded_random α] (x : α)
    (y : α) (h : x ≤ y) : rand_g g (stream ↥(set.Icc x y)) :=
  do
    let gen ← uliftable.up (split g)
    pure (stream.corec_state (bounded_random.random_r g x y h) gen)

end rand

namespace io

/-- create and a seed a random number generator -/
def mk_generator : io std_gen :=
  do
    let seed ← rand 0 shift_31_left
    return (mk_std_gen seed)

/-- Run `cmd` using a randomly seeded random number generator -/
def run_rand {α : Type} (cmd : rand α) : io α :=
  do
    let g ← mk_generator
    return (prod.fst (state_t.run cmd (ulift.up g)))

/-- Run `cmd` using the provided seed. -/
def run_rand_with {α : Type} (seed : ℕ) (cmd : rand α) : io α :=
  return (prod.fst (state_t.run cmd (ulift.up (mk_std_gen seed))))

/-- randomly generate a value of type α -/
def random {α : Type} [random α] : io α := run_rand (rand.random α)

/-- randomly generate an infinite series of value of type α -/
def random_series {α : Type} [random α] : io (stream α) := run_rand (rand.random_series α)

/-- randomly generate a value of type α between `x` and `y` -/
def random_r {α : Type} [preorder α] [bounded_random α] (x : α) (y : α) (p : x ≤ y) :
    io ↥(set.Icc x y) :=
  run_rand (bounded_random.random_r std_gen x y p)

/-- randomly generate an infinite series of value of type α between `x` and `y` -/
def random_series_r {α : Type} [preorder α] [bounded_random α] (x : α) (y : α) (h : x ≤ y) :
    io (stream ↥(set.Icc x y)) :=
  run_rand (rand.random_series_r x y h)

end io

namespace tactic

/-- create a seeded random number generator in the `tactic` monad -/
/-- run `cmd` using the a randomly seeded random number generator
in the tactic monad -/
/-- Generate a random value between `x` and `y` inclusive. -/
/-- Generate an infinite series of random values of type `α` between `x` and `y` inclusive. -/
/-- randomly generate a value of type α -/
end tactic

namespace fin

/-- generate a `fin` randomly -/
protected def random {g : Type} [random_gen g] {n : ℕ} [fact (0 < n)] : rand_g g (fin n) :=
  state_t.mk fun (_x : ulift g) => sorry

end fin

protected instance nat_bounded_random : bounded_random ℕ :=
  bounded_random.mk
    fun (g : Type) (inst : random_gen g) (x y : ℕ) (hxy : x ≤ y) =>
      do
        let z ← fin.random
        pure { val := subtype.val z + x, property := sorry }

/-- This `bounded_random` interval generates integers between `x` and
`y` by first generating a natural number between `0` and `y - x` and
shifting the result appropriately. -/
protected instance int_bounded_random : bounded_random ℤ :=
  bounded_random.mk
    fun (g : Type) (inst : random_gen g) (x y : ℤ) (hxy : x ≤ y) =>
      do
        bounded_random.random_r g 0 (int.nat_abs (y - x)) sorry
        sorry

protected instance fin_random (n : ℕ) [fact (0 < n)] : random (fin n) :=
  random.mk fun (g : Type) (inst : random_gen g) => fin.random

protected instance fin_bounded_random (n : ℕ) : bounded_random (fin n) :=
  bounded_random.mk
    fun (g : Type) (inst : random_gen g) (x y : fin n) (p : x ≤ y) =>
      do
        rand.random_r (subtype.val x) (subtype.val y) p
        sorry

/-- A shortcut for creating a `random (fin n)` instance from
a proof that `0 < n` rather than on matching on `fin (succ n)`  -/
def random_fin_of_pos {n : ℕ} (h : 0 < n) : random (fin n) := sorry

theorem bool_of_nat_mem_Icc_of_mem_Icc_to_nat (x : Bool) (y : Bool) (n : ℕ) :
    n ∈ set.Icc (bool.to_nat x) (bool.to_nat y) → bool.of_nat n ∈ set.Icc x y :=
  sorry

protected instance bool.random : random Bool :=
  random.mk
    fun (g : Type) (inst : random_gen g) =>
      (bool.of_nat ∘ subtype.val) <$> bounded_random.random_r g 0 1 sorry

protected instance bool.bounded_random : bounded_random Bool :=
  bounded_random.mk
    fun (g : Type) (_inst : random_gen g) (x y : Bool) (p : x ≤ y) =>
      subtype.map bool.of_nat (bool_of_nat_mem_Icc_of_mem_Icc_to_nat x y) <$>
        bounded_random.random_r g (bool.to_nat x) (bool.to_nat y) (bool.to_nat_le_to_nat p)

/-- generate a random bit vector of length `n` -/
def bitvec.random {g : Type} [random_gen g] (n : ℕ) : rand_g g (bitvec n) :=
  bitvec.of_fin <$> rand.random (fin (bit0 1 ^ n))

/-- generate a random bit vector of length `n` -/
def bitvec.random_r {g : Type} [random_gen g] {n : ℕ} (x : bitvec n) (y : bitvec n) (h : x ≤ y) :
    rand_g g ↥(set.Icc x y) :=
  (fun
      (h' :
      ∀ (a : fin (bit0 1 ^ n)),
        a ∈ set.Icc (bitvec.to_fin x) (bitvec.to_fin y) → bitvec.of_fin a ∈ set.Icc x y) =>
      subtype.map bitvec.of_fin h' <$>
        rand.random_r (bitvec.to_fin x) (bitvec.to_fin y) (bitvec.to_fin_le_to_fin_of_le h))
    sorry

protected instance random_bitvec (n : ℕ) : random (bitvec n) :=
  random.mk fun (_x : Type) (inst : random_gen _x) => bitvec.random n

protected instance bounded_random_bitvec (n : ℕ) : bounded_random (bitvec n) :=
  bounded_random.mk
    fun (_x : Type) (inst : random_gen _x) (x y : bitvec n) (p : x ≤ y) => bitvec.random_r x y p

end Mathlib


import data.zmod.basic

import for_mathlib.complex_extend
import for_mathlib.projectives
import for_mathlib.two_step_resolution
import for_mathlib.hom_single_iso
import for_mathlib.homological_complex_op

.

universes v u

open category_theory homotopy_category

variables {C : Type u} {ι : Type*} [category.{v} C] [abelian C] {c : complex_shape ι}

open_locale zero_object

instance projective_zero : projective (0 : C) :=
{ factors := λ E X f e he, ⟨0, by ext⟩ }

lemma category_theory.is_iso_of_nat_iso {C D : Type*} [category C] [category D]
  {F G : C ⥤ D} (α : F ≅ G)
  {X Y : C} (f : X ⟶ Y) (h : is_iso (F.map f)) :
  is_iso (G.map f) :=
begin
  rw ← nat_iso.naturality_1 α f,
  apply_instance,
end

lemma category_theory.nat_iso.is_iso_iff {C D : Type*} [category C] [category D]
  {F G : C ⥤ D} (α : F ≅ G)
  {X Y : C} (f : X ⟶ Y) :
  is_iso (F.map f) ↔ is_iso (G.map f) :=
⟨category_theory.is_iso_of_nat_iso α _, category_theory.is_iso_of_nat_iso α.symm _⟩

open category_theory

lemma chain_complex.bounded_by_one (P : chain_complex C ℕ) :
  ((homological_complex.embed complex_shape.embedding.nat_down_int_up ⋙
      quotient C (complex_shape.up ℤ)).obj P).bounded_by 1 :=
begin
  rintro ((_|i)|i) h,
  { exfalso, revert h, dec_trivial },
  { exact limits.is_zero_zero _ },
  { exfalso, revert h, dec_trivial }
end

instance chain_complex.is_bounded_above (P : chain_complex C ℕ) :
  ((homological_complex.embed complex_shape.embedding.nat_down_int_up ⋙
      quotient C (complex_shape.up ℤ)).obj P).is_bounded_above :=
⟨⟨1, chain_complex.bounded_by_one _⟩⟩

/-- The functor from ℕ-indexed chain complexes to bounded-above ℤ-indexed cochain complexes
sending `C₀ ← C₁ ← ...` to `... ⟶ C₁ ⟶ C₀ ⟶ 0 ⟶ ...` -/
@[simps obj obj_val map]
noncomputable def chain_complex.to_bounded_homotopy_category :
  chain_complex C ℕ ⥤ bounded_homotopy_category C :=
{ obj := λ P,
  { val := (homological_complex.embed (complex_shape.embedding.nat_down_int_up) ⋙
      homotopy_category.quotient C _).obj P,
    bdd := by apply chain_complex.is_bounded_above },
  map := λ P Q f, (homological_complex.embed (complex_shape.embedding.nat_down_int_up) ⋙
      homotopy_category.quotient C _).map f,
  map_id' := λ P, (homological_complex.embed (complex_shape.embedding.nat_down_int_up) ⋙
      homotopy_category.quotient C _).map_id P,
  map_comp' := λ P Q R f g, (homological_complex.embed (complex_shape.embedding.nat_down_int_up) ⋙
      homotopy_category.quotient C _).map_comp f g }

lemma chain_complex.to_bounded_homotopy_category.is_K_projective [enough_projectives C]
  (P : chain_complex C ℕ) (A : C) (π : P ⟶ (chain_complex.single₀ C).obj A)
  (hP : P.is_projective_resolution A π) :
  is_K_projective (chain_complex.to_bounded_homotopy_category.obj P).val :=
begin
  constructor,
  introsI Y hY f,
  rw [← quotient_map_out f],
  apply eq_of_homotopy,
  refine projective.null_homotopic_of_projective_to_acyclic _ 1 _ _ hY.cond,
  { rintro ((_|i)|i),
    { exact hP.projective 0 },
    { exact projective_zero, },
    { exact hP.projective _ }, },
  { rintro ((_|i)|i),
    { intro h, exfalso, revert h, dec_trivial },
    { intro h, exact limits.is_zero_zero _ },
    { intro h, exfalso, revert h, dec_trivial } },
end
.

noncomputable
def homological_complex.homology_functor_single [decidable_eq ι] (i : ι) :
  homological_complex.single C c i ⋙ homology_functor C c i ≅ 𝟭 C :=
begin
  refine nat_iso.of_components _ _,
  { intro X,
    refine homology.congr _ _ _ _ ≪≫ homology_zero_zero ≪≫ _,
    { refl },
    { refl },
    { exact eq_to_iso (if_pos rfl) } },
  { intros X Y f,
    apply homology.ext,
    dsimp,
    simpa only [category.comp_id, homological_complex.hom.sq_from_left, eq_to_hom_refl,
      homological_complex.single_obj_X_self_hom, homology.map_desc_assoc, eq_to_hom_trans,
      homological_complex.single_obj_X_self_inv, homological_complex.single_map_f_self,
      category.assoc, limits.kernel_subobject_map_arrow, homology.π_desc_assoc] }
end

instance {X Y Z : C} (f: X ⟶ Y) : is_iso (homology.ι f (0 : Y ⟶ Z) limits.comp_zero) :=
begin
  suffices : limits.cokernel.desc f 0 limits.comp_zero = 0,
  { exact @@is_iso.comp_is_iso _ _ (show _, by convert limits.kernel.ι_zero_is_iso) },
  ext,
  simp,
end

lemma homology.desc_zero_is_iso_of_exact_of_epi {X Y Z W : C} (f : X ⟶ Y) (g : Y ⟶ Z)
  (h : exact f g) [epi g] : is_iso (homology.desc' f (0 : Y ⟶ W) limits.comp_zero
    (limits.kernel_zero_iso_source.hom ≫ g) (by simp [h.w])) :=
begin
  convert_to is_iso (homology.ι _ _ _ ≫
    (limits.colimit.iso_colimit_cocone ⟨_, abelian.is_colimit_of_exact_of_epi f g h⟩).hom),
  { ext, simp },
  { apply_instance }
end

lemma chain_complex.is_projective_resolution.is_quasi_iso_embed {P : chain_complex C ℕ}
  {A : C} {π : P ⟶ (chain_complex.single₀ C).obj A}
  (hP : P.is_projective_resolution A π) :
  is_quasi_iso ((homological_complex.embed (complex_shape.embedding.nat_down_int_up) ⋙
       homotopy_category.quotient C _).map π) :=
begin
  constructor,
  intro i,
  rw [← functor.comp_map, category_theory.nat_iso.is_iso_iff
    (functor.associator _ _ _ ≪≫ iso_whisker_left _ (homology_factors _ _ _))],
  rcases i with ((_|i)|i),
  { apply_with is_iso.of_is_iso_comp_right { instances := ff },
    show is_iso (functor.map_iso _ (chain_complex.single₀_comp_embed_iso_single.app A) ≪≫
        ((homological_complex.homology_functor_single (0 : ℤ)).app A : _)).hom, by apply_instance,
    apply_with is_iso.of_is_iso_comp_left { instances := ff },
    swap 2, convert @@homology.desc_zero_is_iso_of_exact_of_epi _ _ _ _ hP.exact₀ hP.epi using 1,
    swap 4,
    { refine (homology.map_iso _ _ (arrow.iso_mk _ _ _)
        (arrow.iso_mk _ (by exact iso.refl _) _) rfl).hom,
      { exact ((homological_complex.embed.obj complex_shape.embedding.nat_down_int_up P).X_prev_iso
          (show (complex_shape.up ℤ).rel (-[1+0]) 0, from neg_add_self 1)).symm },
      { exact iso.refl _ },
      { dsimp,
        rw [eq_comm, iso.eq_inv_comp, category.comp_id, eq_comm],
        apply homological_complex.d_to_eq },
      { dsimp,
        rw [category.comp_id, category.id_comp],
        erw homological_complex.d_from_eq _ (show (complex_shape.up ℤ).rel 0 1, from rfl),
        exact limits.zero_comp } },
    { ext,
      dsimp only [homology.map_iso, homological_complex.homology_functor_single],
      rw [← cancel_epi (limits.kernel_subobject_iso _).hom, homology.π'_eq_π_assoc],
      simp only [homology.π'_desc', category.comp_id, homological_complex.hom.sq_from_left,
        limits.kernel_subobject_arrow_assoc, homology.π_desc, homology.map_desc,
        limits.kernel_subobject_map_arrow_assoc, arrow.iso_mk_hom_left,
        limits.kernel_subobject_map_arrow],
      dsimp only [chain_complex.single₀_comp_embed_iso_single,
        chain_complex.single₀_comp_embed_iso_single_component],
      simp only [limits.kernel_subobject_map_arrow, limits.kernel_subobject_map_arrow_assoc, homological_complex.hom.sq_from_left,
        homological_complex.hom.iso_of_components_hom_f, functor.comp_map, homology_functor_map, nat_iso.of_components.app,
        eq_to_iso_refl, iso.trans_refl, iso.trans_hom, functor.map_iso_hom, homology.congr_hom, homology_zero_zero_hom,
        homology.map_desc, homology.π_map_assoc, limits.kernel_zero_iso_source_hom, limits.kernel_subobject_arrow_assoc],
      erw [homology.π_desc, limits.kernel_subobject_map_arrow_assoc],
      simp only [homological_complex.hom.sq_from_left, limits.kernel_subobject_map_arrow_assoc, arrow.iso_mk_hom_left],
      dsimp only [chain_complex.single₀_comp_embed_iso_single_component],
      erw [iso.refl_hom, iso.refl_hom, category.id_comp, category.id_comp, category.comp_id], refl,
      apply_instance },
    { apply_instance } },
  { refine limits.is_zero.is_iso _ _ _; refine exact.homology_is_zero _ _ (exact_of_zero _ _), },
  { refine limits.is_zero.is_iso _ _ _,
    { refine limits.is_zero_of_iso_of_zero _ (homology_iso _ (-[1+i.succ] : ℤ) _ (-i : ℤ) _ _).symm,
      rotate,
      { dsimp, refl, },
      { dsimp, simp only [int.neg_succ_of_nat_eq', sub_add_cancel], },
      refine exact.homology_is_zero _ _ _,
      cases i; exact (hP.exact _), },
    { refine limits.is_zero_of_iso_of_zero _ (homology_iso _ (-[1+i.succ] : ℤ) _ (-i : ℤ) _ _).symm,
      rotate,
      { dsimp, refl, },
      { dsimp, simp only [int.neg_succ_of_nat_eq', sub_add_cancel], },
      refine exact.homology_is_zero _ _ (exact_of_zero _ _), } }
end
.

open opposite
open category_theory.limits

@[simp]
lemma _root_.category_theory.equivalence.symm_to_adjunction_counit {C D : Type*} [category C]
  [category D] (e : C ≌ D) : e.symm.to_adjunction.counit = e.unit_inv := rfl

@[simp]
lemma _root_.homological_complex.shift_equiv_unit_app (i j : ℤ) (X : cochain_complex C ℤ) :
  homological_complex.hom.f ((shift_equiv _ i).unit.app X) j = (X.X_eq_to_iso $ by simp).hom :=
begin
  dsimp [shift_equiv, unit_of_tensor_iso_unit],
  simp only [homological_complex.X_eq_to_iso, eq_to_hom_map, eq_to_hom_app, eq_to_iso.hom,
    homological_complex.eq_to_hom_f, eq_to_hom_trans, homological_complex.shift_μ_inv_app_f],
end

@[simp]
lemma _root_.homological_complex.shift_equiv_unit_inv_app (i j : ℤ) (X : cochain_complex C ℤ) :
  homological_complex.hom.f ((shift_equiv _ i).unit_inv.app X) j = (X.X_eq_to_iso $ by simp).hom :=
begin
  dsimp [shift_equiv, unit_of_tensor_iso_unit],
  simp only [homological_complex.X_eq_to_iso, eq_to_hom_map, eq_to_hom_app, eq_to_iso.hom,
    homological_complex.eq_to_hom_f, homological_complex.shift_ε_inv_app_f, eq_to_hom_trans],
end

@[simp]
lemma _root_.category_theory.equivalence.symm_to_adjunction_unit {C D : Type*} [category C]
  [category D] (e : C ≌ D) : e.symm.to_adjunction.unit = e.counit_inv := rfl

@[simp]
lemma _root_.homological_complex.shift_equiv_counit_app (i j : ℤ) (X : cochain_complex C ℤ) :
  homological_complex.hom.f ((shift_equiv _ i).counit.app X) j = (X.X_eq_to_iso $ by simp).hom :=
begin
  dsimp [shift_equiv, unit_of_tensor_iso_unit],
  simp only [homological_complex.X_eq_to_iso, eq_to_hom_map, eq_to_hom_app, eq_to_iso.hom,
    homological_complex.eq_to_hom_f, homological_complex.shift_ε_inv_app_f, eq_to_hom_trans],
end

@[simp]
lemma _root_.homological_complex.shift_equiv_counit_inv_app (i j : ℤ) (X : cochain_complex C ℤ) :
  homological_complex.hom.f ((shift_equiv _ i).counit_inv.app X) j = (X.X_eq_to_iso $ by simp).hom :=
begin
  dsimp [shift_equiv, unit_of_tensor_iso_unit],
  simpa only [homological_complex.X_eq_to_iso, eq_to_hom_map, eq_to_hom_app, eq_to_iso.hom,
    add_neg_equiv_counit_iso_inv, nat_trans.comp_app, homological_complex.comp_f,
    homological_complex.shift_ε_hom_app_f, homological_complex.eq_to_hom_f,
    homological_complex.shift_μ_inv_app_f, eq_to_hom_trans],
end

variable [enough_projectives C]

noncomputable
def Ext'_iso (A : Cᵒᵖ) (B : C) (i : ℤ) (P : chain_complex C ℕ)
  (π : P ⟶ (chain_complex.single₀ C).obj A.unop)
  (hP : P.is_projective_resolution A.unop π) :
  ((Ext' i).obj A).obj B ≅
  (((preadditive_yoneda.obj B).map_homological_complex _).obj
    ((homological_complex.embed complex_shape.embedding.nat_down_int_up).obj P).op).homology (-i) :=
begin
  dsimp only [Ext', functor.comp_obj, functor.op_obj, functor.flip_obj_obj],
  haveI := chain_complex.to_bounded_homotopy_category.is_K_projective P A.unop π hP,
  haveI : is_quasi_iso (chain_complex.to_bounded_homotopy_category.map π) := hP.is_quasi_iso_embed,
  refine (bounded_homotopy_category.Ext_iso i
    (chain_complex.to_bounded_homotopy_category.obj P)
    _ _ (chain_complex.to_bounded_homotopy_category.map π ≫ _)) ≪≫
    (preadditive_yoneda.map_iso _).app (op (chain_complex.to_bounded_homotopy_category.obj P)) ≪≫
      bounded_homotopy_category.hom_single_iso _ B (-i),
  { exact ((homotopy_category.quotient _ _).map_iso $
      (chain_complex.single₀_comp_embed_iso_single).app A.unop).hom, },
  { apply_instance },
  { exact (bounded_homotopy_category.shift_single_iso 0 i).app B ≪≫ eq_to_iso (by rw zero_sub) }
end

lemma AddCommGroup.is_zero_of_eq (A : AddCommGroup) (h : ∀ x y : A, x = y) :
  is_zero A :=
begin
  rw is_zero_iff_id_eq_zero,
  ext,
  apply h,
end

lemma category_theory.ProjectiveResolution.is_projective_resolution
  {A : C} (P : ProjectiveResolution A) :
  P.complex.is_projective_resolution _ P.π :=
{ projective := P.projective,
  exact₀ := P.exact₀,
  exact := P.exact,
  epi := ProjectiveResolution.f.category_theory.epi P 0 }

lemma Ext'_is_zero_of_neg (A : Cᵒᵖ) (B : C) (i : ℤ) (hi : i < 0) :
  is_zero (((Ext' i).obj A).obj B) :=
begin
  let P := ProjectiveResolution.of A.unop,
  refine is_zero_of_iso_of_zero _ (Ext'_iso _ _ i P.complex P.π P.is_projective_resolution).symm,
  rcases i with (i|i),
  { exfalso, revert hi, dec_trivial },
  refine is_zero.homology_is_zero _ _ _ _,
  refine AddCommGroup.is_zero_of_eq _ _,
  intros f g,
  ext,
end

section
open bounded_homotopy_category

lemma Ext_single_right_is_zero
  (A : homotopy_category C (complex_shape.up ℤ)) (B : C)
  (i j k : ℤ)
  (hA : A.bounded_by i) [A.is_bounded_above]
  (hijk : i + j ≤ k) :
  is_zero (((Ext j).obj (op ⟨A⟩)).obj ((bounded_homotopy_category.single _ k).obj B)) :=
begin
  obtain ⟨P, H1, H2, f, H3, H4⟩ :=
    exists_bounded_K_projective_replacement_of_bounded _ _ hA,
  have H5 : P.is_bounded_above := ⟨⟨i, H2⟩⟩,
  resetI,
  refine is_zero_of_iso_of_zero _ (Ext_iso j ⟨P⟩ _ _ _).symm,
  swap, { exact f }, swap, { exact H3 },
  refine AddCommGroup.is_zero_of_eq _ _,
  rintro (φ ψ : P ⟶ _),
  rw [← quotient_map_out φ, ← quotient_map_out ψ],
  congr' 1,
  ext n,
  by_cases hn : i ≤ n,
  { apply (H2 n hn).eq_of_src },
  { apply is_zero.eq_of_tgt,
    dsimp [bounded_homotopy_category.single],
    rw if_neg, { exact is_zero_zero _ },
    linarith only [hijk, hn], }
end

end

namespace AddCommGroup

-- We only need `G` to preserve epimorphisms, but we don't have such a class.
lemma preserves_projectives {C D : Type*} [category C] [category.{v} D] {F : C ⥤ D} {G : D ⥤ C}
  (adj : F ⊣ G) [preserves_colimits_of_shape walking_span G] (P : C) [projective P] :
    projective (F.obj P) :=
begin
  constructor,
  intros,
  resetI,
  use (adj.hom_equiv _ _).symm (projective.factor_thru (adj.hom_equiv _ _ f) (G.map e)),
  rw [← adj.hom_equiv_naturality_right_symm, projective.factor_thru_comp, equiv.symm_apply_apply],
end

instance {C D : Type*} [category C] [category D] {F : C ⥤ D}
  {G : D ⥤ C} (adj : F ⊣ G) [faithful G] (X : D) : epi (adj.counit.app X) :=
begin
  have H : split_epi (G.map (adj.counit.app X)) := ⟨_, adj.right_triangle_components⟩,
  haveI := H.epi,
  exact G.epi_of_epi_map infer_instance
end

lemma enough_projectives_of_adjoint {C D : Type*} [category C] [category.{v} D] {F : C ⥤ D}
  {G : D ⥤ C} (adj : F ⊣ G) [preserves_colimits_of_shape walking_span G] [faithful G]
  [enough_projectives C] : enough_projectives D :=
begin
  haveI : is_left_adjoint F := ⟨_, adj⟩,
  constructor,
  intro X,
  refine ⟨⟨_, preserves_projectives adj _, (adj.hom_equiv _ _).symm (projective.π (G.obj X)), _⟩⟩,
  dsimp,
  rw adjunction.hom_equiv_counit,
  exact epi_comp _ _,
end

instance : enough_projectives AddCommGroup.{u} :=
enough_projectives_of_adjoint
  (functor.as_equivalence (forget₂ (Module ℤ) AddCommGroup)).to_adjunction

lemma Ext_is_zero_of_one_lt
  (A : AddCommGroup.{u}ᵒᵖ) (B : AddCommGroup.{u}) (i : ℤ) (hi : i > 1) :
  is_zero (((Ext' i).obj A).obj B) :=
begin
  induction A,
  rcases A with ⟨A, _Ainst⟩, resetI,
  let := Ext'_iso (op $AddCommGroup.of A) B i,
  dsimp at this,
  refine is_zero_of_iso_of_zero _ (this _ _ (two_step_resolution_ab_projective A)).symm,
  rcases i with ((_|_|i)|i),
  { exfalso, revert hi, dec_trivial },
  { exfalso, revert hi, dec_trivial },
  swap,
  { exfalso, revert hi, dec_trivial },
  refine is_zero.homology_is_zero _ _ _ _,
  refine AddCommGroup.is_zero_of_eq _ _,
  intros f g,
  apply category_theory.limits.has_zero_object.from_zero_ext,
end

noncomputable theory
variable (n : ℕ)

-- move me (the rest of the file)

def zmod_resolution : chain_complex AddCommGroup ℕ :=
chain_complex.mk' (of ℤ) (of ℤ) (n • 𝟙 _) (λ _, ⟨0, 0, zero_comp⟩)

example : (zmod_resolution n).X 0 = of ℤ := rfl

def zmod_resolution_pi_f :
  Π (i : ℕ), (zmod_resolution n).X i ⟶ ((chain_complex.single₀ AddCommGroup).obj (of $ zmod n)).X i
| 0     := show of ℤ ⟶ of (zmod n), from (int.cast_ring_hom (zmod n)).to_add_monoid_hom
| (i+1) := 0

def zmod_resolution_pi :
  zmod_resolution n ⟶ (chain_complex.single₀ AddCommGroup).obj (of $ zmod n) :=
{ f := zmod_resolution_pi_f n,
  comm' := begin
    rintros i ⟨_|j⟩ (rfl : _ = _),
    { ext k, dsimp [zmod_resolution_pi_f, zmod_resolution],
      simp only [zero_apply, fin.coe_zero, comp_apply, int.coe_cast_add_hom],
      simp only [chain_complex.mk'_d_1_0, add_monoid_hom.coe_smul, pi.smul_apply, id_apply,
        nsmul_one, int.coe_nat_bit0, int.coe_nat_succ, int.coe_nat_zero, zero_add, int.cast_bit0,
        int.cast_one, map_nsmul],
      simp only [ring_hom.coe_add_monoid_hom, eq_int_cast,
        int.cast_one, nsmul_one, zmod.nat_cast_self] },
    { exact comp_zero.trans comp_zero.symm }
  end }

local attribute [-instance] limits.has_smallest_colimits_of_has_colimits

instance : projective (AddCommGroup.of ℤ) :=
preserves_projectives (functor.as_equivalence (forget₂ (Module ℤ) AddCommGroup)).to_adjunction
  (Module.of ℤ ℤ)

lemma exact_zmod_nsmul_cast :
  exact (n • 𝟙 (of ℤ)) (AddCommGroup.of_hom $ int.cast_add_hom (zmod n)) :=
begin
  rw AddCommGroup.exact_iff,
  erw zmod.ker_int_cast_add_hom,
  ext,
  apply exists_congr,
  rintro (a : ℤ),
  change n • a = x ↔ a * (n : ℤ) = x,
  rw mul_comm,
  norm_num,
end

lemma zmod_resolution_is_resolution (hn : n ≠ 0) :
  (zmod_resolution n).is_projective_resolution (of (zmod n)) (zmod_resolution_pi n) :=
begin
  constructor,
  { rintro (_|_|_|_),
    { show projective (AddCommGroup.of ℤ), by apply_instance },
    { show projective (AddCommGroup.of ℤ), by apply_instance },
    { show projective (0 : AddCommGroup), by apply_instance },
    { show projective (0 : AddCommGroup), by apply_instance } },
  { dsimp [zmod_resolution_pi, zmod_resolution_pi_f, zmod_resolution],
    rw chain_complex.mk'_d_1_0,
    exact AddCommGroup.exact_zmod_nsmul_cast n },
  { intro i,
    dsimp [zmod_resolution, chain_complex.mk', chain_complex.mk, chain_complex.of],
    rw [if_pos rfl, if_pos rfl, category.id_comp, category.id_comp],
    rcases i with (_|_|_),
    { show exact 0 (n • 𝟙 (of ℤ)),
      rw [(abelian.tfae_mono 0 (n • 𝟙 (of ℤ))).out 2 0, AddCommGroup.mono_iff_injective],
      rintros (x : ℤ) (y : ℤ) (e : n • x = n • y),
      norm_num at e,
      exact e.resolve_right hn },
    { show exact 0 0, apply exact_of_zero },
    { show exact 0 0, apply exact_of_zero } },
  { dsimp [zmod_resolution_pi, zmod_resolution_pi_f],
    rw AddCommGroup.epi_iff_surjective,
    rintro (x : zmod n),
    exact ⟨(x : ℤ), by norm_num⟩ }
end

lemma zmod.nsmul_eq_zero (k : zmod n) : n • k = 0 := by norm_num

@[simps] def add_subgroup.equiv_top (A : Type*) [add_comm_group A] :
  A ≃+ (⊤ : add_subgroup A) :=
{ to_fun := λ x, ⟨x, add_subgroup.mem_top _⟩,
  inv_fun := λ x, x,
  left_inv := λ x, rfl,
  right_inv := by { rintro ⟨x, hx⟩, refl },
  map_add' := λ x y, rfl }

end AddCommGroup


import model_theory.substructures
import model_theory.bundled

--OUTPUT 1
theorem overflow {L : first_order.language} {F : L.Theory} (h : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin) : ∃ (M : F.Model), infinite M :=
begin
  -- define the auxilliary formula
  noncomputable def A_aux := λ n, ∃ (x1 : L.sorts.1), ∃ (x2 : L.sorts.1), ⋯ ∃ (xn : L.sorts.1),
    (∀ (i : fin n), ∀ (j : fin n), i.val ≠ j.val → (L.predicates.pempty.elim $ L.relations.rnequiv.elim $ xi i ≠ xi j))

  -- prove that its intended interpretation is correct
  lemma A_aux_iff_ge (n : ℕ) : A_aux n ↔ ∃ (N : F.Model) [Nfin : fintype N], n ≤ @fintype.card N Nfin := sorry

  -- define a function to build the auxiliary formula from a natural
  noncomputable def A_aux_thm (n : ℕ) : F.Model.Theory.Formula := sorry

  -- define formulas for the overflow
  noncomputable def A_thm := λ n, sorry

  -- define the set of sentences for the overflow
  noncomputable def F_thm := sorry

  -- define the set of sentences for the overflow
  noncomputable def Gamma_thm := sorry

  -- show that every finite subset of gamma is satisfiable
  have h1 : ∀ (g : finset F.Model.Theory.Formula), g.finite → ∃ (N : F.Model), F.Model.Theory.Satisfies N g, from sorry,

  -- apply the compactness theorem to gamma
  have h2 : ∃ (M : F.Model), F.Model.Theory.Satisfies M Gamma_thm, from sorry,

  -- show that M must be infinite
  have h3 : infinite M, from sorry,
  sorry

end

--OUTPUT 2
theorem overflow {L : first_order.language} {F : L.Theory} (h : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin) : ∃ (M : F.Model), infinite M :=
begin
  have h1 : ∀ n : ℕ, ∃ A n, n ≤ @fintype.card (F.Model) A, from by {
    assume (n : ℕ),
    have h2 : ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin, from h n,
    have h3 : ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin, from h2,
    show ∃ A n, n ≤ @fintype.card (F.Model) A, from sorry,
  },
  have h2 : ∀ n : ℕ, ∃ A n, n ≤ @fintype.card (F.Model) A, from h1,
  show ∃ (M : F.Model), infinite M, from sorry,
end

--OUTPUT 3
theorem overflow {L : first_order.language} {F : L.Theory} (h : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin) : ∃ (M : F.Model), infinite M :=
begin
  let A : set L.Statement := {s | ∃ n : ℕ, s = ∃ x₁ x₂, ..., ∃ xₙ, x₁ ≠ x₂ ∧ x₁ ≠ x₃ ∧ ... ∧ xₙ₋₁ ≠ xₙ},
  have h1 : ∀ (s : L.Statement), s ∈ A ↔ ∃ n : ℕ, s = ∃ x₁ x₂, ..., ∃ xₙ, x₁ ≠ x₂ ∧ x₁ ≠ x₃ ∧ ... ∧ xₙ₋₁ ≠ xₙ, from sorry,

  have h2 : ∀ (n : ℕ), ∃ (m : F.Model) [mfin : fintype m], n ≤ card m ∧ ∀ x, x ≠ x, from sorry,
  have h3 : ∀ (n : ℕ), ∃ (m : F.Model) [mfin : fintype m], n ≤ card m, from sorry,

  have h4 : ∀ (s : L.Statement), s ∈ A ↔ satisfiable (s :: ∅), from sorry,

  have h5 : ∀ (n : ℕ), satisfiable (∃ x₁ x₂, ..., ∃ xₙ, x₁ ≠ x₂ ∧ x₁ ≠ x₃ ∧ ... ∧ xₙ₋₁ ≠ xₙ :: ∅), from sorry,

  have h6 : ∀ (n : ℕ), satisfiable (∃ x₁ x₂, ..., ∃ xₙ, x₁ ≠ x₂ ∧ x₁ ≠ x₃ ∧ ... ∧ xₙ₋₁ ≠ xₙ :: F), from sorry,

  have h7 : satisfiable (F ∪ A), from sorry,

  show ∃ (M : F.Model), infinite M, from sorry,
end

--OUTPUT 4
theorem overflow {L : first_order.language} {F : L.Theory} (h : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin) : ∃ (M : F.Model), infinite M :=
begin
  have h1 : ∀ (i : ℕ), ∃ (m : ℕ), ∀ (m₁ m₂ : ℕ), (m₁ < i ∧ m₂ < i) → m₁ ≠ m₂, from sorry,
  have h2 : ∀ (i : ℕ), ∃ (m : F.Model) [mfin : fintype m], ∀ (m₁ m₂ : ℕ), (m₁ < i ∧ m₂ < i) → m₁ ≠ m₂, from sorry,
  have h3 : ∀ (i : ℕ), ∃ (m : F.Model) [mfin : fintype m], i ≤ @fintype.card m mfin, from sorry,
  have h4 : ∀ (i : ℕ), ∃ (m : F.Model) [mfin : fintype m], @fintype.card m mfin = i, from sorry,

  sorry,
end

--OUTPUT 5
theorem overflow {L : first_order.language} {F : L.Theory} (h : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin) : ∃ (M : F.Model), infinite M :=
by { sorry }

-- END
end

--OUTPUT 6
theorem overflow {L : first_order.language} {F : L.Theory} (h : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin) : ∃ (M : F.Model), infinite M :=
begin
  let Γ := F.formulas,
  have h1 : ∀ f : Γ, ∃ n : ℕ, n ,
  have h2 : ∀ (n : ℕ), ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin, from sorry,
  show ∃ (M : F.Model), infinite M, from sorry,
end

--OUTPUT 7
theorem overflow {L : first_order.language} {F : L.Theory} (h : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin) : ∃ (M : F.Model), infinite M :=
begin
  -- Let A_n be the formula saying that \mathbf{M} has at least n elements.
  let A_n : L.formula := ⟨exactly_n_non_equal_variables n, _⟩,
  have h1 : ∀ (n : ℕ), @is_true (exists x_1' x_2' x_n', (∀ i j : ℕ, (i < j ∧ j ≤ n) → x_i' ≠ x_j')) (exactly_n_non_equal_variables n), from sorry,
  have h2 : ∀ n : ℕ, ∀ (m : F.Model) [mfin : fintype m], n < @fintype.card m mfin → ∃ (e : F.Model.Term m) [mvar : L.Term.variable e.var], ∀ (m' : F.Model) [mfinn : fintype m'], m' ⊨ A_n [e], from sorry,

  cases h 3 with m [mfin : fintype m] h3,

  -- take the union of all of the A_i's (for i = 1, 2, ...).
  let φ := prod.snd (A_n),
  let A_infty : L.formula := ⟨∀ x_1' x_2' ..., ∀ i j : ℕ, (i < j) → (∀ (m : F.Model) [mfin : fintype m], m ⊨ φ [x_i'] → m ⊨ φ [x_j']), _⟩,
  have h4 : ∀ (m : F.Model) [mfin : fintype m], m ⊨ A_infty ↔ (∃ n, m ⊨ A_n), from sorry,

  let F_infty := F ∪ ⟨A_infty, _⟩,
  have h5 : finite F_infty, from sorry,
  have h6 : ∀ (t : F_infty), classical.prop_decidable (F_infty.eval t), from sorry,
  have h7 : consistent F_infty, from sorry,
  cases compactness_model (sorry) with M h8,

  show ∃ (M : F.Model), infinite M, from sorry,
end

--OUTPUT 8
theorem overflow {L : first_order.language} {F : L.Theory} (h : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin) : ∃ (M : F.Model), infinite M :=
begin
  sorry,
end

--OUTPUT 9
theorem overflow {L : first_order.language} {F : L.Theory} (h : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin) : ∃ (M : F.Model), infinite M :=
begin
  let F := λ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin,
  have h1 : ∀ n : ℕ, F n, from sorry,

  have h2 : ∀ n : ℕ, ∃ (m : F.Model), ∀ x y : ℕ, x ≠ y → m.relations.Interpretation x ≠ m.relations.Interpretation y, from
    sorry,
  have h3 : ∀ n : ℕ, ∃ (m : F.Model), ∀ x y : ℕ, x ≠ y → m.relations.Interpretation x ≠ m.relations.Interpretation y, from sorry,
  have h4 : ∀ n : ℕ, ∃ (m : F.Model), ∀ x y : ℕ, x ≠ y → m.relations.Interpretation x ≠ m.relations.Interpretation y, from sorry,
  have h5 : ∀ n : ℕ, ∃ (m : F.Model), ∀ x y : ℕ, x ≠ y → m.relations.Interpretation x ≠ m.relations.Interpretation y, from sorry,
  have h6 : ∀ n : ℕ, ∃ (m : F.Model), ∀ x y : ℕ, x ≠ y → m.relations.Interpretation x ≠ m.relations.Interpretation y, from sorry,
  have h7 : ∀ n : ℕ, ∃ (m : F.Model), @fintype.card m fintype.fin n = n, from sorry,
  have h8 : ∀ n : ℕ, ∃ (m : F.Model), @fintype.card m fintype.fin n = n, from sorry,
  have h9 : ∀ n : ℕ, ∃ (m : F.Model), @fintype.card m fintype.fin n = n, from sorry,
  have h10 : ∀ n : ℕ, ∃ (m : F.Model), @fintype.card m fintype.fin n = n, from sorry,
  have h11 : ∀ n : ℕ, ∃ (m : F.Model), @fintype.card m fintype.fin n = n, from sorry,
  have h12 : ∀ n : ℕ, ∃ (m : F.Model), @fintype.card m fintype.fin n = n, from sorry,
  have h13 : ∀ n : ℕ, ∃ (m : F.Model), @fintype.card m fintype.fin n = n, from sorry,
  have h14 : ∀ n : ℕ, ∃ (m : F.Model), @fintype.card m fintype.fin n = n, from sorry,
  have h15 : ∀ n : ℕ, ∃ (m : F.Model), @fintype.card m fintype.fin n = n, from sorry,
  have h16 : ∀ n : ℕ, ∃ (m : F.Model), @fintype.card m fintype.fin n = n, from sorry,
  have h17 : ∀ n : ℕ, ∃ (m : F.Model), @fintype.card m fintype.fin n = n, from sorry,
  have h18 : ∀ n : ℕ, ∃ (m : F.Model), @fintype.card m fintype.fin n = n, from sorry,
  have h19 : ∀ n : ℕ, ∃ (m : F.Model), @fintype.card m fintype.fin n = n, from sorry,
  have h20 : ∀ n : ℕ, ∃ (m : F.Model), @fintype.card m fintype.fin n = n, from sorry,
  have h21 : ∀ n : ℕ, ∃ (m : F.Model), @fintype.card m fintype.fin n = n, from sorry,
  have h22 : ∀ n : ℕ, ∃ (m : F.Model), @fintype.card m fintype.fin n = n, from sorry,
  have h23 : ∀ n : ℕ, ∃ (m : F.Model), @fintype.card m fintype.fin n = n, from sorry,
  have h24 : ∀ n : ℕ, ∃ (m : F.Model), @fintype.card m fintype.fin n = n, from sorry,
  have h25 : ∀ n : ℕ, ∃ (m : F.Model), @fintype.card m fintype.fin n = n, from sorry,
  have h26 : ∀ n : ℕ, ∃ (m : F.Model), @fintype.card m fintype.fin n = n, from sorry,
  have h27 : ∀ n : ℕ, ∃ (m : F.Model), @fintype.card m fintype.fin n = n, from sorry,
  have h28 : ∀ n : ℕ, ∃ (m : F.Model), @fintype.card m fintype.fin n = n, from sorry,
  have h29 : ∀ n : ℕ, ∃ (m : F.Model), @fintype.card m fintype.fin n = n, from sorry,
  have h30 : ∀ n : ℕ, ∃ (m : F.Model), @fintype.card m fintype.fin n = n, from sorry,
  have h31 : ∀ n : ℕ, ∃ (m : F.Model), @fintype.card m fintype.fin n = n, from sorry,
  have h32 : ∀ n : ℕ, ∃ (m : F.Model), @fintype.card m fintype.fin n = n, from sorry,
  have h33 : ∀ n : ℕ, ∃ (m : F.Model), @fintype.card m fintype.fin n = n, from sorry,
  have h34 : ∀ n : ℕ, ∃ (m : F.Model), @fintype.card m fintype.fin n = n, from sorry,
  have h35 : ∀ n : ℕ, ∃ (m : F.Model), @fintype.card m fintype.fin n = n, from sorry,
  have h36 : ∀ n : ℕ, ∃ (m : F.Model), @fintype.card m fintype.fin n = n, from sorry,
  have h37 : ∀ n : ℕ, ∃ (m : F.Model), @fintype.card m fintype.fin n = n, from sorry,
  have h38 : ∀ n : ℕ, ∃ (m : F.Model), @fintype.card m fintype.fin n = n, from sorry,
  have h39 : ∀ n : ℕ, ∃ (m : F.Model), @fintype.card m fintype.fin n = n, from sorry,
  have h40 : ∀ n : ℕ, ∃ (m : F.Model), @fintype.card m fintype.fin n = n, from sorry,
  have h41 : ∀ n : ℕ, ∃ (m : F.Model), @fintype.card m fintype.fin n = n, from sorry,
  have h42 : ∀ n : ℕ, ∃ (m : F.Model), @fintype.card m fintype.fin n = n, from sorry,
  have h43 : ∀ n : ℕ, ∃ (m : F.Model), @fintype.card m fintype.fin n = n, from sorry,
  have h44 : ∀ n : ℕ, ∃ (m : F.Model), @fintype.card m fintype.fin n = n, from sorry,
  have h45 : ∀ n : ℕ, ∃ (m : F.Model), @fintype.card m fintype.fin n = n, from sorry
end --Needs more than 2000 tokens!

--OUTPUT 10
theorem overflow {L : first_order.language} {F : L.Theory} (h : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin) : ∃ (M : F.Model), infinite M :=
begin
  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
  assume (A : set α) (hA : A ∈ 𝒫 S) (B : set α) (hB : B ∈ 𝒫 S),
  have h1 : (A ⊆ S) ∧ (B ⊆ S), from sorry,
  have h2 : (A ∩ B) ⊆ A, from sorry,
  have h3 : (A ∩ B) ⊆ S, from sorry,
  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
  calc (x + y)^2 = (x+y)*(x+y) : by sorry
  ... = x*(x+y) + y*(x+y) : by sorry
  ... = x*x + x*y + y*x + y*y : by sorry
  ... = 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
  have h1 : ∀ a b : G, ∃! x : G, a * x = b, from sorry,
  have h2 : ∀ a b : G, ∃! y : G, y * a = b, from sorry,

  have h3 : ∀ a : G, ∃! x : G, a * x = a, from sorry,
  have h4 : ∀ a : G, ∃! y : G, y * a = a, from sorry,

  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`
Overflow theorem
Let $F$ be a set of first-order formulas which has finite models of arbitrarily large size. Then $F$ has an infinite model.
`proof`
For each $n$, let $\mathbf A_n$ be the formula:

$\exists x_1 \exists x_2 \ldots \exists x_n: \{x_1 \ne x_2 \land x_1 \ne x_3 \land \ldots \land x_{n - 1} \ne x_n\}$

Then $\mathbf A_i$ is true in a structure $\AA$ iff $\AA$ has at least $n$ elements.

Take:
$$ \Gamma := F \cup \bigcup_{i \mathop = 1}^\infty A_i $$

Since $F$ has models of arbitrarily large size, every finite subset of $\Gamma$ is satisfiable.

From the Compactness Theorem, $\Gamma$ is satisfiable in some model $\mathbf{M}$.

But since $\mathbf{M} \models A_i$ for each $i$, $\mathbf{M}$ must be infinite.

So $F$ has an infinite model.

QED
-/
theorem  overflow {L : first_order.language} {F : L.Theory} (h : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin) : ∃ (M : F.Model), infinite M :=
FEW SHOT PROMPTS TO CODEX(END)-/


import global.relation

noncomputable theory

open set function filter (hiding map_smul) charted_space smooth_manifold_with_corners
  linear_map (ker)
open_locale topology manifold pointwise

section parameter_space
/-! ## Fundamental definitions -/

variables
{E : Type*} [normed_add_comm_group E] [normed_space ℝ E]
{H : Type*} [topological_space H] {I : model_with_corners ℝ E H}
{M : Type*} [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M]
{E' : Type*} [normed_add_comm_group E'] [normed_space ℝ E']
{H' : Type*} [topological_space H'] {I' : model_with_corners ℝ E' H'}
{M' : Type*} [topological_space M'] [charted_space H' M'] [smooth_manifold_with_corners I' M']
{EP : Type*} [normed_add_comm_group EP] [normed_space ℝ EP]
{HP : Type*} [topological_space HP] {IP : model_with_corners ℝ EP HP}
{P : Type*} [topological_space P] [charted_space HP P] [smooth_manifold_with_corners IP P]
{F : Type*} [normed_add_comm_group F] [normed_space ℝ F]
{G : Type*} [topological_space G] {J : model_with_corners ℝ F G}
{N : Type*} [topological_space N] [charted_space G N] [smooth_manifold_with_corners J N]
{EX : Type*} [normed_add_comm_group EX] [normed_space ℝ EX]
{HX : Type*} [topological_space HX] {IX : model_with_corners ℝ EX HX}
-- note: X is a metric space
{X : Type*} [metric_space X] [charted_space HX X] [smooth_manifold_with_corners IX X]
variables {R : rel_mfld I M I' M'}

variables (IP P)

/-- The relation `𝓡 ^ P` -/
def rel_mfld.relativize (R : rel_mfld I M I' M') : rel_mfld (IP.prod I) (P × M) I' M' :=
bundle_snd ⁻¹' R

variables {IP P}

lemma rel_mfld.mem_relativize (R : rel_mfld I M I' M') (w : one_jet_bundle (IP.prod I) (P × M) I' M') :
 w ∈ R.relativize IP P ↔
  (one_jet_bundle.mk w.1.1.2 w.1.2 (w.2.comp (continuous_linear_map.inr ℝ EP E)) :
    one_jet_bundle I M I' M') ∈ R :=
by { simp_rw [rel_mfld.relativize, mem_preimage, bundle_snd_eq], refl }

lemma rel_mfld.is_open_relativize (R : rel_mfld I M I' M') (h2 : is_open R) :
  is_open (R.relativize IP P) :=
h2.preimage smooth_bundle_snd.continuous

lemma relativize_slice {σ : one_jet_bundle (IP.prod I) (P × M) I' M'}
  {p : dual_pair $ tangent_space (IP.prod I) σ.1.1}
  (q : dual_pair $ tangent_space I σ.1.1.2)
  (hpq : p.π.comp (continuous_linear_map.inr ℝ EP E) = q.π) :
  (R.relativize IP P).slice σ p =
  σ.2 (p.v - (0, q.v)) +ᵥ R.slice (bundle_snd σ) q :=
begin
  -- for some reason this is needed
  letI : module ℝ (((cont_mdiff_map.snd : C^∞⟮(IP.prod I).prod I', (P × M) × M'; I', M'⟯) *ᵖ
    tangent_space I') σ.1),
  { apply_instance },
  have h2pq : ∀ x : E, p.π ((0 : EP), x) = q.π x := λ x, congr_arg (λ f : E →L[ℝ] ℝ, f x) hpq,
  ext1 w,
  have h1 : (p.update σ.2 w).comp (continuous_linear_map.inr ℝ EP E) =
    q.update (bundle_snd σ).2 (-σ.2 (p.v - (0, q.v)) + w),
  { ext1 x,
    simp_rw [continuous_linear_map.comp_apply, continuous_linear_map.inr_apply,
      ← continuous_linear_map.map_neg, neg_sub],
    obtain ⟨u, hu, t, rfl⟩ := q.decomp x,
    have hv : (0, q.v) - p.v ∈ ker p.π,
    { rw [linear_map.mem_ker, map_sub, p.pairing, h2pq, q.pairing, sub_self] },
    have hup : ((0 : EP), u) ∈ ker p.π := (h2pq u).trans hu,
    rw [q.update_apply _ hu, ← prod.zero_mk_add_zero_mk, map_add, p.update_ker_pi _ _ hup,
      ← prod.smul_zero_mk, map_smul],
    nth_rewrite 0 [← sub_add_cancel (0, q.v) p.v],
    rw [map_add, p.update_ker_pi _ _ hv, p.update_v, bundle_snd_eq],
    refl },
  have := preimage_vadd_neg (show E', from σ.2 (p.v - (0, q.v)))
    (show set E', from (R.slice (bundle_snd σ) q)),
  dsimp only at this,
  simp_rw [← this, mem_preimage, mem_slice, R.mem_relativize],
  dsimp only [one_jet_bundle_mk_fst, one_jet_bundle_mk_snd],
  congr'
end

lemma relativize_slice_eq_univ {σ : one_jet_bundle (IP.prod I) (P × M) I' M'}
  {p : dual_pair $ tangent_space (IP.prod I) σ.1.1}
  (hp : p.π.comp (continuous_linear_map.inr ℝ EP E) = 0) :
  ((R.relativize IP P).slice σ p).nonempty ↔
  (R.relativize IP P).slice σ p = univ :=
begin
  -- for some reason this is needed
  letI : module ℝ (((cont_mdiff_map.snd : C^∞⟮(IP.prod I).prod I', (P × M) × M'; I', M'⟯) *ᵖ
    tangent_space I') σ.1),
  { apply_instance },
  have h2p : ∀ x : E, p.π ((0 : EP), x) = 0 := λ x, congr_arg (λ f : E →L[ℝ] ℝ, f x) hp,
  have : ∀ y : E', (p.update σ.snd y).comp (continuous_linear_map.inr ℝ EP E) =
    σ.snd.comp (continuous_linear_map.inr ℝ EP E),
  { intro y,
    ext1 x,
    simp_rw [continuous_linear_map.comp_apply, continuous_linear_map.inr_apply,
      p.update_ker_pi _ _ (h2p x)] },
  simp_rw [set.nonempty, eq_univ_iff_forall, mem_slice, R.mem_relativize],
  dsimp only [one_jet_bundle_mk_fst, one_jet_bundle_mk_snd],
  simp_rw [this, exists_const, forall_const]
end

variables (IP P)

lemma rel_mfld.ample.relativize (hR : R.ample) : (R.relativize IP P).ample :=
begin
  intros σ p,
  let p2 := p.π.comp (continuous_linear_map.inr ℝ EP E),
  rcases eq_or_ne p2 0 with h|h,
  { intros w hw,
    rw [(relativize_slice_eq_univ h).mp ⟨w, hw⟩, connected_component_in_univ,
      preconnected_space.connected_component_eq_univ, convex_hull_univ] },
  obtain ⟨u', hu'⟩ := continuous_linear_map.exists_ne_zero h,
  let u := (p2 u')⁻¹ • u',
  let q : dual_pair (tangent_space I σ.1.1.2) :=
  ⟨p2, u, by rw [p2.map_smul, smul_eq_mul, inv_mul_cancel hu']⟩,
  rw [relativize_slice q rfl],
  refine (hR q).vadd,
end

variables {IP P}

lemma family_one_jet_sec.uncurry_mem_relativize (S : family_one_jet_sec I M I' M' IP P) {s : P}
  {x : M} : S.uncurry (s, x) ∈ R.relativize IP P ↔ S s x ∈ R :=
begin
  simp_rw [rel_mfld.relativize, mem_preimage, bundle_snd_eq, one_jet_sec.coe_apply,
    map_left],
  congr',
  ext v,
  simp_rw [S.uncurry_ϕ', continuous_linear_map.comp_apply, continuous_linear_map.add_apply,
    continuous_linear_map.comp_apply, continuous_linear_map.inr_apply,
    continuous_linear_map.coe_fst', continuous_linear_map.coe_snd',
    continuous_linear_map.map_zero, zero_add, S.coe_ϕ]
end

def family_formal_sol.uncurry
  (S : family_formal_sol IP P R) : formal_sol (R.relativize IP P) :=
begin
  refine ⟨S.to_family_one_jet_sec.uncurry, _⟩,
  rintro ⟨s, x⟩,
  exact S.to_family_one_jet_sec.uncurry_mem_relativize.mpr (S.is_sol' s x)
end

lemma family_formal_sol.uncurry_ϕ' (S : family_formal_sol IP P R) (p : P × M) :
  S.uncurry.ϕ p = mfderiv IP I' (λ z, S.bs z p.2) p.1 ∘L continuous_linear_map.fst ℝ EP E +
  S.ϕ p.1 p.2 ∘L continuous_linear_map.snd ℝ EP E :=
S.to_family_one_jet_sec.uncurry_ϕ' p

def family_one_jet_sec.curry (S : family_one_jet_sec (IP.prod I) (P × M) I' M' J N) :
  family_one_jet_sec I M I' M' (J.prod IP) (N × P) :=
{ bs := λ p x, (S p.1).bs (p.2, x),
  ϕ := λ p x, (S p.1).ϕ (p.2, x) ∘L mfderiv I (IP.prod I) (λ x, (p.2, x)) x,
  smooth' := begin
    rintro ⟨⟨t, s⟩, x⟩,
    refine smooth_at_snd.one_jet_bundle_mk (S.smooth_bs.comp smooth_prod_assoc _) _,
    have h1 : smooth_at ((J.prod IP).prod I) 𝓘(ℝ, EP × E →L[ℝ] E')
      (in_coordinates_core (IP.prod I) I' (λ (p : (N × P) × M), (p.1.2, p.2))
        (λ (p : (N × P) × M), (S p.1.1).bs (p.1.2, p.2))
        (λ (p : (N × P) × M), ((S p.1.1).ϕ (p.1.2, p.2))) ((t, s), x)) ((t, s), x),
    { apply (smooth_at_one_jet_bundle.mp $
        smooth_at.comp _ (by exact S.smooth (t, (s, x))) (smooth_prod_assoc ((t, s), x))).2.2 },
    have h2 : smooth_at ((J.prod IP).prod I) 𝓘(ℝ, E →L[ℝ] EP × E)
      (in_coordinates_core I (IP.prod I) prod.snd (λ (p : (N × P) × M), (p.1.2, p.2))
        (λ (p : (N × P) × M),
          (mfderiv I (IP.prod I) (λ (x : M), (p.1.2, x)) p.2)) ((t, s), x)) ((t, s), x),
    { apply cont_mdiff_at.mfderiv''' (λ (p : (N × P) × M) (x : M), (p.1.2, x)) prod.snd
        (smooth_at_fst.fst.snd.prod_mk smooth_at_snd :
          smooth_at (((J.prod IP).prod I).prod I) (IP.prod I) _ (((t, s), x), x))
        (smooth_at_snd : smooth_at ((J.prod IP).prod I) _ _ _) le_top },
    exact h1.clm_comp_in_coordinates_core (continuous_at_fst.snd.prod continuous_at_snd) h2
  end }

lemma family_one_jet_sec.curry_bs (S : family_one_jet_sec (IP.prod I) (P × M) I' M' J N) (p : N × P)
  (x : M) : (S.curry p).bs x = (S p.1).bs (p.2, x) :=
rfl

lemma family_one_jet_sec.curry_ϕ (S : family_one_jet_sec (IP.prod I) (P × M) I' M' J N) (p : N × P)
  (x : M) : (S.curry p).ϕ x = (S p.1).ϕ (p.2, x) ∘L mfderiv I (IP.prod I) (λ x, (p.2, x)) x :=
rfl

lemma family_one_jet_sec.curry_ϕ' (S : family_one_jet_sec (IP.prod I) (P × M) I' M' J N) (p : N × P)
  (x : M) : (S.curry p).ϕ x = (S p.1).ϕ (p.2, x) ∘L continuous_linear_map.inr ℝ EP E :=
begin
  rw [S.curry_ϕ],
  congr' 1,
  refine ((mdifferentiable_at_const I IP).mfderiv_prod smooth_id.mdifferentiable_at).trans _,
  rw [mfderiv_id, mfderiv_const],
  refl,
end

lemma formal_sol.eq_iff {F₁ F₂ : formal_sol R} {x : M} :
  F₁ x = F₂ x ↔ F₁.bs x = F₂.bs x ∧ F₁.ϕ x = by apply F₂.ϕ x :=
by { simp_rw [sigma.ext_iff, formal_sol.fst_eq, heq_iff_eq, prod.ext_iff, eq_self_iff_true,
  true_and], refl }

lemma family_one_jet_sec.is_holonomic_at_curry
  (S : family_one_jet_sec (IP.prod I) (P × M) I' M' J N)
  {t : N} {s : P} {x : M} (hS : (S t).is_holonomic_at (s, x)) :
  (S.curry (t, s)).is_holonomic_at x :=
begin
  simp_rw [one_jet_sec.is_holonomic_at, (S.curry _).snd_eq, S.curry_ϕ] at hS ⊢,
  dsimp only,
  rw [show (S.curry (t, s)).bs = λ x, (S.curry (t, s)).bs x, from rfl, funext (S.curry_bs _)],
  dsimp only,
  refine (mfderiv_comp x (S t).smooth_bs.mdifferentiable_at
    ((mdifferentiable_at_const I IP).prod_mk smooth_id.mdifferentiable_at)).trans _,
  rw [id, hS],
  refl,
end

lemma family_one_jet_sec.curry_mem (S : family_one_jet_sec (IP.prod I) (P × M) I' M' J N)
  {p : N × P} {x : M} (hR : S p.1 (p.2, x) ∈ R.relativize IP P) :
  S.curry p x ∈ R :=
begin
  simp_rw [rel_mfld.relativize, mem_preimage, bundle_snd_eq, one_jet_sec.coe_apply,
    map_left] at hR ⊢,
  convert hR,
  ext v,
  simp_rw [S.curry_ϕ']
end

def family_formal_sol.curry (S : family_formal_sol J N (R.relativize IP P)) :
  family_formal_sol (J.prod IP) (N × P) R :=
⟨S.to_family_one_jet_sec.curry, λ p x, S.to_family_one_jet_sec.curry_mem S.is_sol⟩

lemma family_formal_sol.curry_ϕ' (S : family_formal_sol J N (R.relativize IP P)) (p : N × P)
  (x : M) : (S.curry p).ϕ x = (S p.1).ϕ (p.2, x) ∘L continuous_linear_map.inr ℝ EP E :=
S.to_family_one_jet_sec.curry_ϕ' p x

lemma curry_eq_iff_eq_uncurry {𝓕 : family_formal_sol J N (R.relativize IP P)}
  {𝓕₀ : family_formal_sol IP P R} {t : N} {x : M} {s : P}
  (h : 𝓕 t (s, x) = 𝓕₀.uncurry (s, x)) :
  (𝓕.curry (t, s)) x = 𝓕₀ s x :=
begin
  simp_rw [formal_sol.eq_iff] at h ⊢,
  refine ⟨h.1, _⟩,
  simp_rw [𝓕.curry_ϕ', h.2, 𝓕₀.uncurry_ϕ'],
  ext v,
  simp_rw [continuous_linear_map.comp_apply, continuous_linear_map.add_apply,
    continuous_linear_map.comp_apply,
    continuous_linear_map.inr_apply, continuous_linear_map.coe_fst',
    continuous_linear_map.coe_snd', continuous_linear_map.map_zero, zero_add],
  refl
end

lemma rel_mfld.satisfies_h_principle.satisfies_h_principle_with
  (R : rel_mfld I M IX X) {C : set (P × M)}
  (ε : M → ℝ) (h : (R.relativize IP P).satisfies_h_principle C (λ x, ε x.2)) :
  R.satisfies_h_principle_with IP C ε :=
begin
  intros 𝓕₀ h𝓕₀,
  obtain ⟨𝓕, h1𝓕, h2𝓕, h3𝓕, h4𝓕⟩ :=
    h 𝓕₀.uncurry (h𝓕₀.mono (λ p hp, 𝓕₀.to_family_one_jet_sec.is_holonomic_uncurry.mpr hp)),
  refine ⟨𝓕.curry, _, _, _, _⟩,
  { intros s x, exact curry_eq_iff_eq_uncurry (h1𝓕 (s, x)) },
  { intros s x, exact 𝓕.to_family_one_jet_sec.is_holonomic_at_curry (h2𝓕 (s, x)) },
  { refine h3𝓕.mono _, rintro ⟨s, x⟩ hp t, exact curry_eq_iff_eq_uncurry (hp t) },
  { intros t s x, exact (h4𝓕 t (s, x)) },
end

end parameter_space


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.punit
import category_theory.structured_arrow
import category_theory.is_connected
import category_theory.limits.yoneda
import category_theory.limits.types

/-!
# Final and initial functors

A functor `F : C ⥤ D` is final if for every `d : D`,
the comma category of morphisms `d ⟶ F.obj c` is connected.

Dually, a functor `F : C ⥤ D` is initial if for every `d : D`,
the comma category of morphisms `F.obj c ⟶ d` is connected.

We show that right adjoints are examples of final functors, while
left adjoints are examples of initial functors.

For final functors, we prove that the following three statements are equivalent:
1. `F : C ⥤ D` is final.
2. Every functor `G : D ⥤ E` has a colimit if and only if `F ⋙ G` does,
   and these colimits are isomorphic via `colimit.pre G F`.
3. `colimit (F ⋙ coyoneda.obj (op d)) ≅ punit`.

Starting at 1. we show (in `cocones_equiv`) that
the categories of cocones over `G : D ⥤ E` and over `F ⋙ G` are equivalent.
(In fact, via an equivalence which does not change the cocone point.)
This readily implies 2., as `comp_has_colimit`, `has_colimit_of_comp`, and `colimit_iso`.

From 2. we can specialize to `G = coyoneda.obj (op d)` to obtain 3., as `colimit_comp_coyoneda_iso`.

From 3., we prove 1. directly in `cofinal_of_colimit_comp_coyoneda_iso_punit`.

Dually, we prove that if a functor `F : C ⥤ D` is initial, then any functor `G : D ⥤ E` has a
limit if and only if `F ⋙ G` does, and these limits are isomorphic via `limit.pre G F`.

## Naming
There is some discrepancy in the literature about naming; some say 'cofinal' instead of 'final'.
The explanation for this is that the 'co' prefix here is *not* the usual category-theoretic one
indicating duality, but rather indicating the sense of "along with".

## Future work
Dualise condition 3 above and the implications 2 ⇒ 3 and 3 ⇒ 1 to initial functors.

## References
* https://stacks.math.columbia.edu/tag/09WN
* https://ncatlab.org/nlab/show/final+functor
* Borceux, Handbook of Categorical Algebra I, Section 2.11.
  (Note he reverses the roles of definition and main result relative to here!)
-/

noncomputable theory

universes v u

namespace category_theory

namespace functor

open opposite
open category_theory.limits

variables {C : Type v} [small_category C]
variables {D : Type v} [small_category D]

/--
A functor `F : C ⥤ D` is final if for every `d : D`, the comma category of morphisms `d ⟶ F.obj c`
is connected.

See https://stacks.math.columbia.edu/tag/04E6
-/
class final (F : C ⥤ D) : Prop :=
(out (d : D) : is_connected (structured_arrow d F))

attribute [instance] final.out

/--
A functor `F : C ⥤ D` is initial if for every `d : D`, the comma category of morphisms
`F.obj c ⟶ d` is connected.
-/
class initial (F : C ⥤ D) : Prop :=
(out (d : D) : is_connected (costructured_arrow F d))

attribute [instance] initial.out

instance final_op_of_initial (F : C ⥤ D) [initial F] : final F.op :=
{ out := λ d, is_connected_of_equivalent (costructured_arrow_op_equivalence F (unop d)) }

instance initial_op_of_final (F : C ⥤ D) [final F] : initial F.op :=
{ out := λ d, is_connected_of_equivalent (structured_arrow_op_equivalence F (unop d)) }

lemma final_of_initial_op (F : C ⥤ D) [initial F.op] : final F :=
{ out := λ d, @is_connected_of_is_connected_op _ _
  (is_connected_of_equivalent (structured_arrow_op_equivalence F d).symm) }

lemma initial_of_final_op (F : C ⥤ D) [final F.op] : initial F :=
{ out := λ d, @is_connected_of_is_connected_op _ _
  (is_connected_of_equivalent (costructured_arrow_op_equivalence F d).symm) }

/-- If a functor `R : D ⥤ C` is a right adjoint, it is final. -/
lemma final_of_adjunction {L : C ⥤ D} {R : D ⥤ C} (adj : L ⊣ R) : final R :=
{ out := λ c,
  let u : structured_arrow c R := structured_arrow.mk (adj.unit.app c) in
  @zigzag_is_connected _ _ ⟨u⟩ $ λ f g, relation.refl_trans_gen.trans
    (relation.refl_trans_gen.single (show zag f u, from
      or.inr ⟨structured_arrow.hom_mk ((adj.hom_equiv c f.right).symm f.hom) (by simp)⟩))
    (relation.refl_trans_gen.single (show zag u g, from
      or.inl ⟨structured_arrow.hom_mk ((adj.hom_equiv c g.right).symm g.hom) (by simp)⟩)) }

/-- If a functor `L : C ⥤ D` is a left adjoint, it is initial. -/
lemma initial_of_adjunction {L : C ⥤ D} {R : D ⥤ C} (adj : L ⊣ R) : initial L :=
{ out := λ d,
  let u : costructured_arrow L d := costructured_arrow.mk (adj.counit.app d) in
  @zigzag_is_connected _ _ ⟨u⟩ $ λ f g, relation.refl_trans_gen.trans
    (relation.refl_trans_gen.single (show zag f u, from
      or.inl ⟨costructured_arrow.hom_mk (adj.hom_equiv f.left d f.hom) (by simp)⟩))
    (relation.refl_trans_gen.single (show zag u g, from
      or.inr ⟨costructured_arrow.hom_mk (adj.hom_equiv g.left d g.hom) (by simp)⟩)) }

@[priority 100]
instance final_of_is_right_adjoint (F : C ⥤ D) [h : is_right_adjoint F] : final F :=
final_of_adjunction h.adj

@[priority 100]
instance initial_of_is_left_adjoint (F : C ⥤ D) [h : is_left_adjoint F] : initial F :=
initial_of_adjunction h.adj

namespace final

variables (F : C ⥤ D) [final F]

instance (d : D) : nonempty (structured_arrow d F) := is_connected.is_nonempty

variables {E : Type u} [category.{v} E] (G : D ⥤ E)

/--
When `F : C ⥤ D` is cofinal, we denote by `lift F d` an arbitrary choice of object in `C` such that
there exists a morphism `d ⟶ F.obj (lift F d)`.
-/
def lift (d : D) : C :=
(classical.arbitrary (structured_arrow d F)).right

/--
When `F : C ⥤ D` is cofinal, we denote by `hom_to_lift` an arbitrary choice of morphism
`d ⟶ F.obj (lift F d)`.
-/
def hom_to_lift (d : D) : d ⟶ F.obj (lift F d) :=
(classical.arbitrary (structured_arrow d F)).hom

/--
We provide an induction principle for reasoning about `lift` and `hom_to_lift`.
We want to perform some construction (usually just a proof) about
the particular choices `lift F d` and `hom_to_lift F d`,
it suffices to perform that construction for some other pair of choices
(denoted `X₀ : C` and `k₀ : d ⟶ F.obj X₀` below),
and to show how to transport such a construction
*both* directions along a morphism between such choices.
-/
def induction {d : D} (Z : Π (X : C) (k : d ⟶ F.obj X), Sort*)
  (h₁ : Π X₁ X₂ (k₁ : d ⟶ F.obj X₁) (k₂ : d ⟶ F.obj X₂) (f : X₁ ⟶ X₂),
    (k₁ ≫ F.map f = k₂) → Z X₁ k₁ → Z X₂ k₂)
  (h₂ : Π X₁ X₂ (k₁ : d ⟶ F.obj X₁) (k₂ : d ⟶ F.obj X₂) (f : X₁ ⟶ X₂),
    (k₁ ≫ F.map f = k₂) → Z X₂ k₂ → Z X₁ k₁)
  {X₀ : C} {k₀ : d ⟶ F.obj X₀} (z : Z X₀ k₀) : Z (lift F d) (hom_to_lift F d) :=
begin
  apply nonempty.some,
  apply @is_preconnected_induction _ _ _
    (λ (Y : structured_arrow d F), Z Y.right Y.hom) _ _ { right := X₀, hom := k₀, } z,
  { intros j₁ j₂ f a, fapply h₁ _ _ _ _ f.right _ a, convert f.w.symm, dsimp, simp, },
  { intros j₁ j₂ f a, fapply h₂ _ _ _ _ f.right _ a, convert f.w.symm, dsimp, simp, },
end

variables {F G}

/--
Given a cocone over `F ⋙ G`, we can construct a `cocone G` with the same cocone point.
-/
@[simps]
def extend_cocone : cocone (F ⋙ G) ⥤ cocone G :=
{ obj := λ c,
  { X := c.X,
    ι :=
    { app := λ X, G.map (hom_to_lift F X) ≫ c.ι.app (lift F X),
      naturality' := λ X Y f,
      begin
        dsimp, simp,
        -- This would be true if we'd chosen `lift F X` to be `lift F Y`
        -- and `hom_to_lift F X` to be `f ≫ hom_to_lift F Y`.
        apply induction F
          (λ Z k, G.map f ≫ G.map (hom_to_lift F Y) ≫ c.ι.app (lift F Y) = G.map k ≫ c.ι.app Z),
        { intros Z₁ Z₂ k₁ k₂ g a z,
        rw [←a, functor.map_comp, category.assoc, ←functor.comp_map, c.w, z], },
        { intros Z₁ Z₂ k₁ k₂ g a z,
        rw [←a, functor.map_comp, category.assoc, ←functor.comp_map, c.w] at z,
        rw z, },
        { rw [←functor.map_comp_assoc], },
      end } },
  map := λ X Y f,
  { hom := f.hom, } }

@[simp]
lemma colimit_cocone_comp_aux (s : cocone (F ⋙ G)) (j : C) :
  G.map (hom_to_lift F (F.obj j)) ≫ s.ι.app (lift F (F.obj j)) =
    s.ι.app j :=
begin
  -- This point is that this would be true if we took `lift (F.obj j)` to just be `j`
  -- and `hom_to_lift (F.obj j)` to be `𝟙 (F.obj j)`.
  apply induction F (λ X k, G.map k ≫ s.ι.app X = (s.ι.app j : _)),
  { intros j₁ j₂ k₁ k₂ f w h, rw ←w, rw ← s.w f at h, simpa using h, },
  { intros j₁ j₂ k₁ k₂ f w h, rw ←w at h, rw ← s.w f, simpa using h, },
  { exact s.w (𝟙 _), },
end

variables (F G)

/--
If `F` is cofinal,
the category of cocones on `F ⋙ G` is equivalent to the category of cocones on `G`,
for any `G : D ⥤ E`.
-/
@[simps]
def cocones_equiv : cocone (F ⋙ G) ≌ cocone G :=
{ functor := extend_cocone,
  inverse := cocones.whiskering F,
  unit_iso := nat_iso.of_components (λ c, cocones.ext (iso.refl _) (by tidy)) (by tidy),
  counit_iso := nat_iso.of_components (λ c, cocones.ext (iso.refl _) (by tidy)) (by tidy), }.

variables {G}

/--
When `F : C ⥤ D` is cofinal, and `t : cocone G` for some `G : D ⥤ E`,
`t.whisker F` is a colimit cocone exactly when `t` is.
-/
def is_colimit_whisker_equiv (t : cocone G) : is_colimit (t.whisker F) ≃ is_colimit t :=
is_colimit.of_cocone_equiv (cocones_equiv F G).symm

/--
When `F` is cofinal, and `t : cocone (F ⋙ G)`,
`extend_cocone.obj t` is a colimit coconne exactly when `t` is.
-/
def is_colimit_extend_cocone_equiv (t : cocone (F ⋙ G)) :
  is_colimit (extend_cocone.obj t) ≃ is_colimit t :=
is_colimit.of_cocone_equiv (cocones_equiv F G)

/-- Given a colimit cocone over `G : D ⥤ E` we can construct a colimit cocone over `F ⋙ G`. -/
@[simps]
def colimit_cocone_comp (t : colimit_cocone G) :
  colimit_cocone (F ⋙ G) :=
{ cocone := _,
  is_colimit := (is_colimit_whisker_equiv F _).symm (t.is_colimit) }

@[priority 100]
instance comp_has_colimit [has_colimit G] :
  has_colimit (F ⋙ G) :=
has_colimit.mk (colimit_cocone_comp F (get_colimit_cocone G))

lemma colimit_pre_is_iso_aux {t : cocone G} (P : is_colimit t) :
  ((is_colimit_whisker_equiv F _).symm P).desc (t.whisker F) = 𝟙 t.X :=
begin
  dsimp [is_colimit_whisker_equiv],
  apply P.hom_ext,
  intro j,
  dsimp, simp, dsimp, simp, -- See library note [dsimp, simp].
end

instance colimit_pre_is_iso [has_colimit G] :
  is_iso (colimit.pre G F) :=
begin
  rw colimit.pre_eq (colimit_cocone_comp F (get_colimit_cocone G)) (get_colimit_cocone G),
  erw colimit_pre_is_iso_aux,
  dsimp,
  apply_instance,
end

section
variables (G)

/--
When `F : C ⥤ D` is cofinal, and `G : D ⥤ E` has a colimit, then `F ⋙ G` has a colimit also and
`colimit (F ⋙ G) ≅ colimit G`

https://stacks.math.columbia.edu/tag/04E7
-/
def colimit_iso [has_colimit G] : colimit (F ⋙ G) ≅ colimit G := as_iso (colimit.pre G F)

end

/-- Given a colimit cocone over `F ⋙ G` we can construct a colimit cocone over `G`. -/
@[simps]
def colimit_cocone_of_comp (t : colimit_cocone (F ⋙ G)) :
  colimit_cocone G :=
{ cocone := extend_cocone.obj t.cocone,
  is_colimit := (is_colimit_extend_cocone_equiv F _).symm (t.is_colimit), }

/--
When `F` is cofinal, and `F ⋙ G` has a colimit, then `G` has a colimit also.

We can't make this an instance, because `F` is not determined by the goal.
(Even if this weren't a problem, it would cause a loop with `comp_has_colimit`.)
-/
lemma has_colimit_of_comp [has_colimit (F ⋙ G)] :
  has_colimit G :=
has_colimit.mk (colimit_cocone_of_comp F (get_colimit_cocone (F ⋙ G)))

section
local attribute [instance] has_colimit_of_comp

/--
When `F` is cofinal, and `F ⋙ G` has a colimit, then `G` has a colimit also and
`colimit (F ⋙ G) ≅ colimit G`

https://stacks.math.columbia.edu/tag/04E7
-/
def colimit_iso' [has_colimit (F ⋙ G)] : colimit (F ⋙ G) ≅ colimit G := as_iso (colimit.pre G F)

end

/--
If the universal morphism `colimit (F ⋙ coyoneda.obj (op d)) ⟶ colimit (coyoneda.obj (op d))`
is an isomorphism (as it always is when `F` is cofinal),
then `colimit (F ⋙ coyoneda.obj (op d)) ≅ punit`
(simply because `colimit (coyoneda.obj (op d)) ≅ punit`).
-/
def colimit_comp_coyoneda_iso (d : D) [is_iso (colimit.pre (coyoneda.obj (op d)) F)] :
  colimit (F ⋙ coyoneda.obj (op d)) ≅ punit :=
as_iso (colimit.pre (coyoneda.obj (op d)) F) ≪≫ coyoneda.colimit_coyoneda_iso (op d)

/--
If `colimit (F ⋙ coyoneda.obj (op d)) ≅ punit` for all `d : D`, then `F` is cofinal.
-/
lemma cofinal_of_colimit_comp_coyoneda_iso_punit
  (I : Π d, colimit (F ⋙ coyoneda.obj (op d)) ≅ punit) : final F :=
⟨λ d, begin
  haveI : nonempty (structured_arrow d F),
  { have := (I d).inv punit.star,
    obtain ⟨j, y, rfl⟩ := limits.types.jointly_surjective' this,
    exact ⟨structured_arrow.mk y⟩, },
  apply zigzag_is_connected,
  rintros ⟨⟨⟩,X₁,f₁⟩ ⟨⟨⟩,X₂,f₂⟩,
  dsimp at *,
  let y₁ := colimit.ι (F ⋙ coyoneda.obj (op d)) X₁ f₁,
  let y₂ := colimit.ι (F ⋙ coyoneda.obj (op d)) X₂ f₂,
  have e : y₁ = y₂,
  { apply (I d).to_equiv.injective, ext, },
  have t := types.colimit_eq e,
  clear e y₁ y₂,
  exact zigzag_of_eqv_gen_quot_rel t,
end⟩

end final

namespace initial

variables (F : C ⥤ D) [initial F]

instance (d : D) : nonempty (costructured_arrow F d) := is_connected.is_nonempty

variables {E : Type u} [category.{v} E] (G : D ⥤ E)

/--
When `F : C ⥤ D` is initial, we denote by `lift F d` an arbitrary choice of object in `C` such that
there exists a morphism `F.obj (lift F d) ⟶ d`.
-/
def lift (d : D) : C := (classical.arbitrary (costructured_arrow F d)).left

/--
When `F : C ⥤ D` is initial, we denote by `hom_to_lift` an arbitrary choice of morphism
`F.obj (lift F d) ⟶ d`.
-/
def hom_to_lift (d : D) : F.obj (lift F d) ⟶ d :=
  (classical.arbitrary (costructured_arrow F d)).hom

/--
We provide an induction principle for reasoning about `lift` and `hom_to_lift`.
We want to perform some construction (usually just a proof) about
the particular choices `lift F d` and `hom_to_lift F d`,
it suffices to perform that construction for some other pair of choices
(denoted `X₀ : C` and `k₀ : F.obj X₀ ⟶ d` below),
and to show how to transport such a construction
*both* directions along a morphism between such choices.
-/
def induction {d : D} (Z : Π (X : C) (k : F.obj X ⟶ d), Sort*)
  (h₁ : Π X₁ X₂ (k₁ : F.obj X₁ ⟶ d) (k₂ : F.obj X₂ ⟶ d) (f : X₁ ⟶ X₂),
    (F.map f ≫ k₂ = k₁) → Z X₁ k₁ → Z X₂ k₂)
  (h₂ : Π X₁ X₂ (k₁ : F.obj X₁ ⟶ d) (k₂ : F.obj X₂ ⟶ d) (f : X₁ ⟶ X₂),
    (F.map f ≫ k₂ = k₁) → Z X₂ k₂ → Z X₁ k₁)
  {X₀ : C} {k₀ : F.obj X₀ ⟶ d} (z : Z X₀ k₀) : Z (lift F d) (hom_to_lift F d) :=
begin
  apply nonempty.some,
  apply @is_preconnected_induction _ _ _
    (λ Y : costructured_arrow F d, Z Y.left Y.hom) _ _ { left := X₀, hom := k₀ } z,
  { intros j₁ j₂ f a, fapply h₁ _ _ _ _ f.left _ a, convert f.w, dsimp, simp, },
  { intros j₁ j₂ f a, fapply h₂ _ _ _ _ f.left _ a, convert f.w, dsimp, simp, },
end

variables {F G}

/--
Given a cone over `F ⋙ G`, we can construct a `cone G` with the same cocone point.
-/
@[simps]
def extend_cone : cone (F ⋙ G) ⥤ cone G :=
{ obj := λ c,
  { X := c.X,
    π :=
    { app := λ d, c.π.app (lift F d) ≫ G.map (hom_to_lift F d),
      naturality' := λ X Y f,
      begin
        dsimp, simp,
        -- This would be true if we'd chosen `lift F Y` to be `lift F X`
        -- and `hom_to_lift F Y` to be `hom_to_lift F X ≫ f`.
        apply induction F (λ Z k, (c.π.app Z ≫ G.map k : c.X ⟶ _) =
          c.π.app (lift F X) ≫ G.map (hom_to_lift F X) ≫ G.map f),
        { intros Z₁ Z₂ k₁ k₂ g a z,
        rw [←a, functor.map_comp, ←functor.comp_map, ←category.assoc, ←category.assoc, c.w] at z,
        rw [z, category.assoc] },
        { intros Z₁ Z₂ k₁ k₂ g a z,
        rw [←a, functor.map_comp, ←functor.comp_map, ←category.assoc, ←category.assoc,
          c.w, z, category.assoc] },
        { rw [←functor.map_comp], },
      end } },
  map := λ X Y f,
  { hom := f.hom, } }

@[simp]
lemma limit_cone_comp_aux (s : cone (F ⋙ G)) (j : C) :
  s.π.app (lift F (F.obj j)) ≫ G.map (hom_to_lift F (F.obj j)) =
    s.π.app j :=
begin
  -- This point is that this would be true if we took `lift (F.obj j)` to just be `j`
  -- and `hom_to_lift (F.obj j)` to be `𝟙 (F.obj j)`.
  apply induction F (λ X k, s.π.app X ≫ G.map k = (s.π.app j : _)),
  { intros j₁ j₂ k₁ k₂ f w h, rw ←s.w f, rw ←w at h, simpa using h, },
  { intros j₁ j₂ k₁ k₂ f w h, rw ←s.w f at h, rw ←w, simpa using h, },
  { exact s.w (𝟙 _), },
end

variables (F G)

/--
If `F` is initial,
the category of cones on `F ⋙ G` is equivalent to the category of cones on `G`,
for any `G : D ⥤ E`.
-/
@[simps]
def cones_equiv : cone (F ⋙ G) ≌ cone G :=
{ functor := extend_cone,
  inverse := cones.whiskering F,
  unit_iso := nat_iso.of_components (λ c, cones.ext (iso.refl _) (by tidy)) (by tidy),
  counit_iso := nat_iso.of_components (λ c, cones.ext (iso.refl _) (by tidy)) (by tidy), }.

variables {G}

/--
When `F : C ⥤ D` is initial, and `t : cone G` for some `G : D ⥤ E`,
`t.whisker F` is a limit cone exactly when `t` is.
-/
def is_limit_whisker_equiv (t : cone G) : is_limit (t.whisker F) ≃ is_limit t :=
is_limit.of_cone_equiv (cones_equiv F G).symm

/--
When `F` is initial, and `t : cone (F ⋙ G)`,
`extend_cone.obj t` is a limit cone exactly when `t` is.
-/
def is_limit_extend_cone_equiv (t : cone (F ⋙ G)) :
  is_limit (extend_cone.obj t) ≃ is_limit t :=
is_limit.of_cone_equiv (cones_equiv F G)

/-- Given a limit cone over `G : D ⥤ E` we can construct a limit cone over `F ⋙ G`. -/
@[simps]
def limit_cone_comp (t : limit_cone G) :
  limit_cone (F ⋙ G) :=
{ cone := _,
  is_limit := (is_limit_whisker_equiv F _).symm (t.is_limit) }

@[priority 100]
instance comp_has_limit [has_limit G] :
  has_limit (F ⋙ G) :=
has_limit.mk (limit_cone_comp F (get_limit_cone G))

lemma limit_pre_is_iso_aux {t : cone G} (P : is_limit t) :
  ((is_limit_whisker_equiv F _).symm P).lift (t.whisker F) = 𝟙 t.X :=
begin
  dsimp [is_limit_whisker_equiv],
  apply P.hom_ext,
  intro j,
  simp,
end

instance limit_pre_is_iso [has_limit G] :
  is_iso (limit.pre G F) :=
begin
  rw limit.pre_eq (limit_cone_comp F (get_limit_cone G)) (get_limit_cone G),
  erw limit_pre_is_iso_aux,
  dsimp,
  apply_instance,
end

section
variables (G)

/--
When `F : C ⥤ D` is initial, and `G : D ⥤ E` has a limit, then `F ⋙ G` has a limit also and
`limit (F ⋙ G) ≅ limit G`

https://stacks.math.columbia.edu/tag/04E7
-/
def limit_iso [has_limit G] : limit (F ⋙ G) ≅ limit G := (as_iso (limit.pre G F)).symm

end

/-- Given a limit cone over `F ⋙ G` we can construct a limit cone over `G`. -/
@[simps]
def limit_cone_of_comp (t : limit_cone (F ⋙ G)) :
  limit_cone G :=
{ cone := extend_cone.obj t.cone,
  is_limit := (is_limit_extend_cone_equiv F _).symm (t.is_limit), }

/--
When `F` is initial, and `F ⋙ G` has a limit, then `G` has a limit also.

We can't make this an instance, because `F` is not determined by the goal.
(Even if this weren't a problem, it would cause a loop with `comp_has_limit`.)
-/
lemma has_limit_of_comp [has_limit (F ⋙ G)] :
  has_limit G :=
has_limit.mk (limit_cone_of_comp F (get_limit_cone (F ⋙ G)))

section
local attribute [instance] has_limit_of_comp

/--
When `F` is initial, and `F ⋙ G` has a limit, then `G` has a limit also and
`limit (F ⋙ G) ≅ limit G`

https://stacks.math.columbia.edu/tag/04E7
-/
def limit_iso' [has_limit (F ⋙ G)] : limit (F ⋙ G) ≅ limit G :=
(as_iso (limit.pre G F)).symm

end

end initial

end functor

end category_theory


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

Parallel computation of a computable sequence of computations by
a diagonal enumeration.
The important theorems of this operation are proven as
terminates_parallel and exists_of_mem_parallel.
(This operation is nondeterministic in the sense that it does not
honor sequence equivalence (irrelevance of computation time).)
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.seq.wseq
import Mathlib.PostPort

universes u v

namespace Mathlib

namespace computation

def parallel.aux2 {α : Type u} : List (computation α) → α ⊕ List (computation α) :=
  list.foldr (fun (c : computation α) (o : α ⊕ List (computation α)) => sorry) (sum.inr [])

def parallel.aux1 {α : Type u} : List (computation α) × wseq (computation α) → α ⊕ List (computation α) × wseq (computation α) :=
  sorry

/-- Parallel computation of an infinite stream of computations,
  taking the first result -/
def parallel {α : Type u} (S : wseq (computation α)) : computation α :=
  corec sorry ([], S)

theorem terminates_parallel.aux {α : Type u} {l : List (computation α)} {S : wseq (computation α)} {c : computation α} : c ∈ l → terminates c → terminates (corec parallel.aux1 (l, S)) := sorry

theorem terminates_parallel {α : Type u} {S : wseq (computation α)} {c : computation α} (h : c ∈ S) [T : terminates c] : terminates (parallel S) := sorry

theorem exists_of_mem_parallel {α : Type u} {S : wseq (computation α)} {a : α} (h : a ∈ parallel S) : ∃ (c : computation α), ∃ (H : c ∈ S), a ∈ c := sorry

theorem map_parallel {α : Type u} {β : Type v} (f : α → β) (S : wseq (computation α)) : map f (parallel S) = parallel (wseq.map (map f) S) := sorry

theorem parallel_empty {α : Type u} (S : wseq (computation α)) (h : wseq.head S ~> none) : parallel S = empty α := sorry

-- The reason this isn't trivial from exists_of_mem_parallel is because it eliminates to Sort

def parallel_rec {α : Type u} {S : wseq (computation α)} (C : α → Sort v) (H : (s : computation α) → s ∈ S → (a : α) → a ∈ s → C a) {a : α} (h : a ∈ parallel S) : C a :=
  let T : wseq (computation (α × computation α)) := wseq.map (fun (c : computation α) => map (fun (a : α) => (a, c)) c) S;
  (fun (_x : α × computation α) (e : get (parallel T) = _x) =>
      Prod.rec
        (fun (a' : α) (c : computation α) (e : get (parallel T) = (a', c)) =>
          and.dcases_on sorry fun (ac : a ∈ c) (cs : c ∈ S) => H c cs a ac)
        _x e)
    (get (parallel T)) sorry

theorem parallel_promises {α : Type u} {S : wseq (computation α)} {a : α} (H : ∀ (s : computation α), s ∈ S → s ~> a) : parallel S ~> a := sorry

theorem mem_parallel {α : Type u} {S : wseq (computation α)} {a : α} (H : ∀ (s : computation α), s ∈ S → s ~> a) {c : computation α} (cs : c ∈ S) (ac : a ∈ c) : a ∈ parallel S :=
  mem_of_promises (parallel S) (parallel_promises H)

theorem parallel_congr_lem {α : Type u} {S : wseq (computation α)} {T : wseq (computation α)} {a : α} (H : wseq.lift_rel equiv S T) : (∀ (s : computation α), s ∈ S → s ~> a) ↔ ∀ (t : computation α), t ∈ T → t ~> a := sorry

-- The parallel operation is only deterministic when all computation paths lead to the same value

theorem parallel_congr_left {α : Type u} {S : wseq (computation α)} {T : wseq (computation α)} {a : α} (h1 : ∀ (s : computation α), s ∈ S → s ~> a) (H : wseq.lift_rel equiv S T) : parallel S ~ parallel T := sorry

theorem parallel_congr_right {α : Type u} {S : wseq (computation α)} {T : wseq (computation α)} {a : α} (h2 : ∀ (t : computation α), t ∈ T → t ~> a) (H : wseq.lift_rel equiv S T) : parallel S ~ parallel T :=
  parallel_congr_left (iff.mpr (parallel_congr_lem H) h2) H