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


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Johannes Hölzl, Reid Barton, Sean Leather
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.category.default
import Mathlib.PostPort

universes u v l

namespace Mathlib

/-!
# Bundled types

`bundled c` provides a uniform structure for bundling a type equipped with a type class.

We provide `category` instances for these in `category_theory/unbundled_hom.lean`
(for categories with unbundled homs, e.g. topological spaces)
and in `category_theory/bundled_hom.lean` (for categories with bundled homs, e.g. monoids).
-/

namespace category_theory

/-- `bundled` is a type bundled with a type class instance for that type. Only
the type class is exposed as a parameter. -/
structure bundled (c : Type u → Type v)
where
  α : Type u
  str : autoParam (c α)
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.tactic.apply_instance")
    (Lean.Name.mkStr (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "tactic") "apply_instance") [])

namespace bundled

/-- A generic function for lifting a type equipped with an instance to a bundled object. -/
-- Usually explicit instances will provide their own version of this, e.g. `Mon.of` and `Top.of`.

def of {c : Type u → Type v} (α : Type u) [str : c α] : bundled c :=
  mk α

protected instance has_coe_to_sort {c : Type u → Type v} : has_coe_to_sort (bundled c) :=
  has_coe_to_sort.mk (Type u) α

@[simp] theorem coe_mk {c : Type u → Type v} (α : Type u) (str : autoParam (c α)
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.tactic.apply_instance")
    (Lean.Name.mkStr (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "tactic") "apply_instance") [])) : ↥(mk α) = α :=
  rfl

/-
`bundled.map` is reducible so that, if we define a category

  def Ring : Type (u+1) := induced_category SemiRing (bundled.map @ring.to_semiring)

instance search is able to "see" that a morphism R ⟶ S in Ring is really
a (semi)ring homomorphism from R.α to S.α, and not merely from
`(bundled.map @ring.to_semiring R).α` to `(bundled.map @ring.to_semiring S).α`.
-/

/-- Map over the bundled structure -/
def map {c : Type u → Type v} {d : Type u → Type v} (f : {α : Type u} → c α → d α) (b : bundled c) : bundled d :=
  mk ↥b


import GMLInit.Data.Basic

namespace Option

@[simp] theorem failure_eq_none : (failure : Option α) = none := rfl

@[simp] theorem orElse_none_left (x : Option α) : (none <|> x) = x := by
  rfl

@[simp] theorem orElse_none_right (x : Option α) : (x <|> none) = x := by
  cases x <;> rfl

theorem orElse_assoc (x y z : Option α) : ((x <|> y) <|> z) = (x <|> (y <|> z)) := by
  cases x <;> cases y <;> cases z <;> rfl

def first : List (Option α) → Option α
| [] => none
| x@(some _) :: _ => x
| none :: xs => first xs

@[simp] theorem first_nil : first ([] : List (Option α)) = none := rfl

@[simp] theorem first_cons (x : Option α) (xs : List (Option α)) : first (x :: xs) = (x <|> first xs) := by
  cases x <;> rfl

@[simp] theorem first_pure (x : Option α) : first [x] = x := by
  cases x <;> rfl

theorem first_append (xs ys : List (Option α)) : first (xs ++ ys) = (first xs <|> first ys) := by
  induction xs with
  | nil => rfl
  | cons x xs ih => simp [orElse_assoc, ih]

end Option


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Yury G. Kudryashov
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.logic.function.basic
import Mathlib.PostPort

universes u_1 u_2 u v w x u_3 u_4

namespace Mathlib

/-!
# More theorems about the sum type
-/

/-- Check if a sum is `inl` and if so, retrieve its contents. -/
@[simp] def sum.get_left {α : Type u_1} {β : Type u_2} : α ⊕ β → Option α :=
  sorry

/-- Check if a sum is `inr` and if so, retrieve its contents. -/
@[simp] def sum.get_right {α : Type u_1} {β : Type u_2} : α ⊕ β → Option β :=
  sorry

/-- Check if a sum is `inl`. -/
@[simp] def sum.is_left {α : Type u_1} {β : Type u_2} : α ⊕ β → Bool :=
  sorry

/-- Check if a sum is `inr`. -/
@[simp] def sum.is_right {α : Type u_1} {β : Type u_2} : α ⊕ β → Bool :=
  sorry

protected instance sum.decidable_eq (α : Type u) [a : DecidableEq α] (β : Type v) : [a : DecidableEq β] → DecidableEq (α ⊕ β) := sorry

@[simp] theorem sum.forall {α : Type u} {β : Type v} {p : α ⊕ β → Prop} : (∀ (x : α ⊕ β), p x) ↔ (∀ (a : α), p (sum.inl a)) ∧ ∀ (b : β), p (sum.inr b) := sorry

@[simp] theorem sum.exists {α : Type u} {β : Type v} {p : α ⊕ β → Prop} : (∃ (x : α ⊕ β), p x) ↔ (∃ (a : α), p (sum.inl a)) ∨ ∃ (b : β), p (sum.inr b) := sorry

namespace sum

theorem injective_inl {α : Type u} {β : Type v} : function.injective inl :=
  fun (x y : α) => inl.inj

theorem injective_inr {α : Type u} {β : Type v} : function.injective inr :=
  fun (x y : β) => inr.inj

/-- Map `α ⊕ β` to `α' ⊕ β'` sending `α` to `α'` and `β` to `β'`. -/
protected def map {α : Type u} {α' : Type w} {β : Type v} {β' : Type x} (f : α → α') (g : β → β') : α ⊕ β → α' ⊕ β' :=
  sorry

@[simp] theorem map_inl {α : Type u} {α' : Type w} {β : Type v} {β' : Type x} (f : α → α') (g : β → β') (x : α) : sum.map f g (inl x) = inl (f x) :=
  rfl

@[simp] theorem map_inr {α : Type u} {α' : Type w} {β : Type v} {β' : Type x} (f : α → α') (g : β → β') (x : β) : sum.map f g (inr x) = inr (g x) :=
  rfl

@[simp] theorem map_map {α : Type u} {α' : Type w} {β : Type v} {β' : Type x} {α'' : Type u_1} {β'' : Type u_2} (f' : α' → α'') (g' : β' → β'') (f : α → α') (g : β → β') (x : α ⊕ β) : sum.map f' g' (sum.map f g x) = sum.map (f' ∘ f) (g' ∘ g) x :=
  sum.cases_on x (fun (x : α) => idRhs (sum.map f' g' (sum.map f g (inl x)) = sum.map f' g' (sum.map f g (inl x))) rfl)
    fun (x : β) => idRhs (sum.map f' g' (sum.map f g (inr x)) = sum.map f' g' (sum.map f g (inr x))) rfl

@[simp] theorem map_comp_map {α : Type u} {α' : Type w} {β : Type v} {β' : Type x} {α'' : Type u_1} {β'' : Type u_2} (f' : α' → α'') (g' : β' → β'') (f : α → α') (g : β → β') : sum.map f' g' ∘ sum.map f g = sum.map (f' ∘ f) (g' ∘ g) :=
  funext (map_map f' g' f g)

@[simp] theorem map_id_id (α : Type u_1) (β : Type u_2) : sum.map id id = id :=
  funext fun (x : α ⊕ β) => sum.rec_on x (fun (_x : α) => rfl) fun (_x : β) => rfl

theorem inl.inj_iff {α : Type u} {β : Type v} {a : α} {b : α} : inl a = inl b ↔ a = b :=
  { mp := inl.inj, mpr := congr_arg fun {a : α} => inl a }

theorem inr.inj_iff {α : Type u} {β : Type v} {a : β} {b : β} : inr a = inr b ↔ a = b :=
  { mp := inr.inj, mpr := congr_arg fun {a : β} => inr a }

theorem inl_ne_inr {α : Type u} {β : Type v} {a : α} {b : β} : inl a ≠ inr b :=
  fun (ᾰ : inl a = inr b) =>
    eq.dcases_on ᾰ (fun (H_1 : inr b = inl a) => sum.no_confusion H_1) (Eq.refl (inr b)) (HEq.refl ᾰ)

theorem inr_ne_inl {α : Type u} {β : Type v} {a : α} {b : β} : inr b ≠ inl a :=
  fun (ᾰ : inr b = inl a) =>
    eq.dcases_on ᾰ (fun (H_1 : inl a = inr b) => sum.no_confusion H_1) (Eq.refl (inl a)) (HEq.refl ᾰ)

/-- Define a function on `α ⊕ β` by giving separate definitions on `α` and `β`. -/
protected def elim {α : Type u_1} {β : Type u_2} {γ : Sort u_3} (f : α → γ) (g : β → γ) : α ⊕ β → γ :=
  fun (x : α ⊕ β) => sum.rec_on x f g

@[simp] theorem elim_inl {α : Type u_1} {β : Type u_2} {γ : Sort u_3} (f : α → γ) (g : β → γ) (x : α) : sum.elim f g (inl x) = f x :=
  rfl

@[simp] theorem elim_inr {α : Type u_1} {β : Type u_2} {γ : Sort u_3} (f : α → γ) (g : β → γ) (x : β) : sum.elim f g (inr x) = g x :=
  rfl

@[simp] theorem elim_comp_inl {α : Type u_1} {β : Type u_2} {γ : Sort u_3} (f : α → γ) (g : β → γ) : sum.elim f g ∘ inl = f :=
  rfl

@[simp] theorem elim_comp_inr {α : Type u_1} {β : Type u_2} {γ : Sort u_3} (f : α → γ) (g : β → γ) : sum.elim f g ∘ inr = g :=
  rfl

@[simp] theorem elim_inl_inr {α : Type u_1} {β : Type u_2} : sum.elim inl inr = id :=
  funext fun (x : α ⊕ β) => sum.cases_on x (fun (_x : α) => rfl) fun (_x : β) => rfl

theorem comp_elim {α : Type u_1} {β : Type u_2} {γ : Sort u_3} {δ : Sort u_4} (f : γ → δ) (g : α → γ) (h : β → γ) : f ∘ sum.elim g h = sum.elim (f ∘ g) (f ∘ h) :=
  funext fun (x : α ⊕ β) => sum.cases_on x (fun (_x : α) => rfl) fun (_x : β) => rfl

@[simp] theorem elim_comp_inl_inr {α : Type u_1} {β : Type u_2} {γ : Sort u_3} (f : α ⊕ β → γ) : sum.elim (f ∘ inl) (f ∘ inr) = f :=
  funext fun (x : α ⊕ β) => sum.cases_on x (fun (_x : α) => rfl) fun (_x : β) => rfl

@[simp] theorem update_elim_inl {α : Type u_1} {β : Type u_2} {γ : Sort u_3} [DecidableEq α] [DecidableEq (α ⊕ β)] {f : α → γ} {g : β → γ} {i : α} {x : γ} : function.update (sum.elim f g) (inl i) x = sum.elim (function.update f i x) g := sorry

@[simp] theorem update_elim_inr {α : Type u_1} {β : Type u_2} {γ : Sort u_3} [DecidableEq β] [DecidableEq (α ⊕ β)] {f : α → γ} {g : β → γ} {i : β} {x : γ} : function.update (sum.elim f g) (inr i) x = sum.elim f (function.update g i x) := sorry

@[simp] theorem update_inl_comp_inl {α : Type u_1} {β : Type u_2} {γ : Sort u_3} [DecidableEq α] [DecidableEq (α ⊕ β)] {f : α ⊕ β → γ} {i : α} {x : γ} : function.update f (inl i) x ∘ inl = function.update (f ∘ inl) i x :=
  function.update_comp_eq_of_injective f injective_inl i x

@[simp] theorem update_inl_apply_inl {α : Type u_1} {β : Type u_2} {γ : Sort u_3} [DecidableEq α] [DecidableEq (α ⊕ β)] {f : α ⊕ β → γ} {i : α} {j : α} {x : γ} : function.update f (inl i) x (inl j) = function.update (f ∘ inl) i x j := sorry

@[simp] theorem update_inl_comp_inr {α : Type u_1} {β : Type u_2} {γ : Sort u_3} [DecidableEq (α ⊕ β)] {f : α ⊕ β → γ} {i : α} {x : γ} : function.update f (inl i) x ∘ inr = f ∘ inr :=
  function.update_comp_eq_of_forall_ne f x fun (_x : β) => inr_ne_inl

@[simp] theorem update_inl_apply_inr {α : Type u_1} {β : Type u_2} {γ : Sort u_3} [DecidableEq (α ⊕ β)] {f : α ⊕ β → γ} {i : α} {j : β} {x : γ} : function.update f (inl i) x (inr j) = f (inr j) :=
  function.update_noteq inr_ne_inl x f

@[simp] theorem update_inr_comp_inl {α : Type u_1} {β : Type u_2} {γ : Sort u_3} [DecidableEq (α ⊕ β)] {f : α ⊕ β → γ} {i : β} {x : γ} : function.update f (inr i) x ∘ inl = f ∘ inl :=
  function.update_comp_eq_of_forall_ne f x fun (_x : α) => inl_ne_inr

@[simp] theorem update_inr_apply_inl {α : Type u_1} {β : Type u_2} {γ : Sort u_3} [DecidableEq (α ⊕ β)] {f : α ⊕ β → γ} {i : α} {j : β} {x : γ} : function.update f (inr j) x (inl i) = f (inl i) :=
  function.update_noteq inl_ne_inr x f

@[simp] theorem update_inr_comp_inr {α : Type u_1} {β : Type u_2} {γ : Sort u_3} [DecidableEq β] [DecidableEq (α ⊕ β)] {f : α ⊕ β → γ} {i : β} {x : γ} : function.update f (inr i) x ∘ inr = function.update (f ∘ inr) i x :=
  function.update_comp_eq_of_injective f injective_inr i x

@[simp] theorem update_inr_apply_inr {α : Type u_1} {β : Type u_2} {γ : Sort u_3} [DecidableEq β] [DecidableEq (α ⊕ β)] {f : α ⊕ β → γ} {i : β} {j : β} {x : γ} : function.update f (inr i) x (inr j) = function.update (f ∘ inr) i x j := sorry

inductive lex {α : Type u} {β : Type v} (ra : α → α → Prop) (rb : β → β → Prop) : α ⊕ β → α ⊕ β → Prop
where
| inl : ∀ {a₁ a₂ : α}, ra a₁ a₂ → lex ra rb (inl a₁) (inl a₂)
| inr : ∀ {b₁ b₂ : β}, rb b₁ b₂ → lex ra rb (inr b₁) (inr b₂)
| sep : ∀ (a : α) (b : β), lex ra rb (inl a) (inr b)

@[simp] theorem lex_inl_inl {α : Type u} {β : Type v} {ra : α → α → Prop} {rb : β → β → Prop} {a₁ : α} {a₂ : α} : lex ra rb (inl a₁) (inl a₂) ↔ ra a₁ a₂ := sorry

@[simp] theorem lex_inr_inr {α : Type u} {β : Type v} {ra : α → α → Prop} {rb : β → β → Prop} {b₁ : β} {b₂ : β} : lex ra rb (inr b₁) (inr b₂) ↔ rb b₁ b₂ := sorry

@[simp] theorem lex_inr_inl {α : Type u} {β : Type v} {ra : α → α → Prop} {rb : β → β → Prop} {b : β} {a : α} : ¬lex ra rb (inr b) (inl a) := sorry

theorem lex_acc_inl {α : Type u} {β : Type v} {ra : α → α → Prop} {rb : β → β → Prop} {a : α} (aca : acc ra a) : acc (lex ra rb) (inl a) := sorry

theorem lex_acc_inr {α : Type u} {β : Type v} {ra : α → α → Prop} {rb : β → β → Prop} (aca : ∀ (a : α), acc (lex ra rb) (inl a)) {b : β} (acb : acc rb b) : acc (lex ra rb) (inr b) := sorry

theorem lex_wf {α : Type u} {β : Type v} {ra : α → α → Prop} {rb : β → β → Prop} (ha : well_founded ra) (hb : well_founded rb) : well_founded (lex ra rb) :=
  (fun (aca : ∀ (a : α), acc (lex ra rb) (inl a)) =>
      well_founded.intro fun (x : α ⊕ β) => sum.rec_on x aca fun (b : β) => lex_acc_inr aca (well_founded.apply hb b))
    fun (a : α) => lex_acc_inl (well_founded.apply ha a)

/-- Swap the factors of a sum type -/
@[simp] def swap {α : Type u} {β : Type v} : α ⊕ β → β ⊕ α :=
  sorry

@[simp] theorem swap_swap {α : Type u} {β : Type v} (x : α ⊕ β) : swap (swap x) = x :=
  sum.cases_on x (fun (x : α) => Eq.refl (swap (swap (inl x)))) fun (x : β) => Eq.refl (swap (swap (inr x)))

@[simp] theorem swap_swap_eq {α : Type u} {β : Type v} : swap ∘ swap = id :=
  funext swap_swap

@[simp] theorem swap_left_inverse {α : Type u} {β : Type v} : function.left_inverse swap swap :=
  swap_swap

@[simp] theorem swap_right_inverse {α : Type u} {β : Type v} : function.right_inverse swap swap :=
  swap_swap

end sum

namespace function

theorem injective.sum_elim {α : Type u} {β : Type v} {γ : Sort u_1} {f : α → γ} {g : β → γ} (hf : injective f) (hg : injective g) (hfg : ∀ (a : α) (b : β), f a ≠ g b) : injective (sum.elim f g) := sorry

theorem injective.sum_map {α : Type u} {α' : Type w} {β : Type v} {β' : Type x} {f : α → β} {g : α' → β'} (hf : injective f) (hg : injective g) : injective (sum.map f g) := sorry

theorem surjective.sum_map {α : Type u} {α' : Type w} {β : Type v} {β' : Type x} {f : α → β} {g : α' → β'} (hf : surjective f) (hg : surjective g) : surjective (sum.map f g) := sorry


/-
Copyright (c) 2021 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import category_theory.adjunction.basic
import category_theory.adjunction.comma
import category_theory.limits.constructions.weakly_initial
import category_theory.limits.preserves.basic
import category_theory.limits.creates
import category_theory.limits.comma
import category_theory.punit

/-!
# Adjoint functor theorem

This file proves the (general) adjoint functor theorem, in the form:
* If `G : D ⥤ C` preserves limits and `D` has limits, and satisfies the solution set condition,
  then it has a left adjoint: `is_right_adjoint_of_preserves_limits_of_solution_set_condition`.

We show that the converse holds, i.e. that if `G` has a left adjoint then it satisfies the solution
set condition, see `solution_set_condition_of_is_right_adjoint`
(the file `category_theory/adjunction/limits` already shows it preserves limits).

We define the *solution set condition* for the functor `G : D ⥤ C` to mean, for every object
`A : C`, there is a set-indexed family ${f_i : A ⟶ G (B_i)}$ such that any morphism `A ⟶ G X`
factors through one of the `f_i`.

-/
universes v u

namespace category_theory
open limits

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

/--
The functor `G : D ⥤ C` satisfies the *solution set condition* if for every `A : C`, there is a
family of morphisms `{f_i : A ⟶ G (B_i) // i ∈ ι}` such that given any morphism `h : A ⟶ G X`,
there is some `i ∈ ι` such that `h` factors through `f_i`.

The key part of this definition is that the indexing set `ι` lives in `Type v`, where `v` is the
universe of morphisms of the category: this is the "smallness" condition which allows the general
adjoint functor theorem to go through.
-/
def solution_set_condition {D : Type u} [category.{v} D] (G : D ⥤ C) : Prop :=
∀ (A : C), ∃ (ι : Type v) (B : ι → D) (f : Π (i : ι), A ⟶ G.obj (B i)),
  ∀ X (h : A ⟶ G.obj X), ∃ (i : ι) (g : B i ⟶ X), f i ≫ G.map g = h

variables {D : Type u} [category.{v} D]

section general_adjoint_functor_theorem

variables (G : D ⥤ C)

/-- If `G : D ⥤ C` is a right adjoint it satisfies the solution set condition.  -/
lemma solution_set_condition_of_is_right_adjoint [is_right_adjoint G] :
  solution_set_condition G :=
begin
  intros A,
  refine ⟨punit, λ _, (left_adjoint G).obj A, λ _, (adjunction.of_right_adjoint G).unit.app A, _⟩,
  intros B h,
  refine ⟨punit.star, ((adjunction.of_right_adjoint G).hom_equiv _ _).symm h, _⟩,
  rw [←adjunction.hom_equiv_unit, equiv.apply_symm_apply],
end

/--
The general adjoint functor theorem says that if `G : D ⥤ C` preserves limits and `D` has them,
if `G` satisfies the solution set condition then `G` is a right adjoint.
-/
noncomputable def is_right_adjoint_of_preserves_limits_of_solution_set_condition
  [has_limits D] [preserves_limits G] (hG : solution_set_condition G) :
  is_right_adjoint G :=
begin
  apply is_right_adjoint_of_structured_arrow_initials _,
  intro A,
  specialize hG A,
  choose ι B f g using hG,
  let B' : ι → structured_arrow A G := λ i, structured_arrow.mk (f i),
  have hB' : ∀ (A' : structured_arrow A G), ∃ i, nonempty (B' i ⟶ A'),
  { intros A',
    obtain ⟨i, _, t⟩ := g _ A'.hom,
    exact ⟨i, ⟨structured_arrow.hom_mk _ t⟩⟩ },
  obtain ⟨T, hT⟩ := has_weakly_initial_of_weakly_initial_set_and_has_products hB',
  apply has_initial_of_weakly_initial_and_has_wide_equalizers hT,
end

end general_adjoint_functor_theorem

end category_theory


import category_theory.basic
import category_theory.instances

universes v vᵢ vₒ u uᵢ uₒ

open classical

namespace category

def filtered_category (C : Type u) [nonempty C] [category.{v} C] : Prop
  := (∀ i₁ i₂ : C, ∃ (j : C), nonempty (Mor i₁ j) ∧ nonempty (Mor i₂ j))
      ∧ (∀ (i j : C) (f₁ f₂ : Mor i j), ∃ (k : C) (w : Mor j k), w ∘ₘ f₁ = w ∘ₘ f₂)

@[reducible]
def is_cocone {C: Type u} [category.{v} C] {I : Type uᵢ} [category.{vᵢ} I] (F : I +→ C)
  : (Σ cl : C, Π i : I, Mor (F.map i) cl) → Prop
  | ⟨cl ,j⟩ := ∀ (i₁ i₂ : I) (f : Mor i₁ i₂), j i₁ = (j i₂) ∘ₘ (F.fmap f)

def is_colimit {C: Type u} [category.{v} C] {I : Type uᵢ} [category.{vᵢ} I] (F : I +→ C)
  : (Σ cl : C, Π i : I, Mor (F.map i) cl) → Prop :=
  λ cᵤ, is_cocone F cᵤ ∧ ∀ c, is_cocone F c → ∃! φ : Mor cᵤ.1 c.1, ∀ i : I, c.2 i = φ ∘ₘ cᵤ.2 i

theorem colimits_essentially_unquie {C: Type u} [category.{v} C] {I : Type uᵢ} [category.{vᵢ} I] {F : I +→ C}
  {cl₁ cl₂ : (Σ cl : C, Π i : I, Mor (F.map i) cl)} (hcl₁ : is_colimit F cl₁) (hcl₂ : is_colimit F cl₂)
  : ∃! φ : Mor cl₁.1 cl₂.1, (isomorphism φ) ∧ (∀ i : I, cl₂.2 i = φ ∘ₘ cl₁.2 i) :=
begin
  cases cl₁ with cl₁ j₁,
  cases cl₂ with cl₂ j₂,
  cases hcl₁.2 ⟨cl₂,j₂⟩ hcl₂.1 with φ hφ,
  dsimp at hφ,
  cases hcl₂.2 ⟨cl₁,j₁⟩ hcl₁.1 with ψ hψ,
  dsimp at hψ,
  cases hcl₁.2 ⟨cl₁,j₁⟩ hcl₁.1 with idcl₁ hidcl₁,
  dsimp at hidcl₁,
  cases hcl₂.2 ⟨cl₂,j₂⟩ hcl₂.1 with idcl₂ hidcl₂,
  dsimp at hidcl₂,
  cases hφ with hφ uφ,
  cases hψ with hψ uψ,
  cases hidcl₁ with hidcl₁ uidcl₁,
  cases hidcl₂ with hidcl₂ uidcl₂,
  have hrw₁ : idₘ cl₁ = idcl₁,
    apply uidcl₁,
    intro,
    rw id_comp_left,
  have hrw₂ : idₘ cl₂ = idcl₂,
    apply uidcl₂,
    intro,
    rw id_comp_left,
  existsi φ,
  split,
  split,
  existsi ψ,
  dsimp,
  split,
  rw hrw₂,
  apply uidcl₂,
  intro,
  rw [←comp_assoc,←hψ,←hφ],
  rw hrw₁,
  apply uidcl₁,
  intro,
  rw [←comp_assoc,←hφ,←hψ],
  exact hφ,
  dsimp,
  intros φ' hφ',
  apply uφ,
  exact hφ'.2,
end

theorem isomorphisms_prev_colimits {C: Type u} [category.{v} C] {I : Type uᵢ} [category.{vᵢ} I] (F : I +→ C)
  {c₁: (Σ cl : C, Π i : I, Mor (F.map i) cl)} {c : C} {φ : Mor c₁.1 c} (hφ : isomorphism φ)
  : is_colimit F c₁ → is_colimit F ⟨c, λ i : I, φ ∘ₘ (c₁.2 i)⟩ :=
begin
  intro colc₁,
  cases hφ with ψ hψ,
  cases hψ with hψ₁ hψ₂,
  cases c₁ with c₁ j₁,
  split,
  simp [is_colimit,is_cocone] at colc₁,
  cases colc₁ with c₁cocone c₁uni,
  simp [is_cocone],
  intros i₁ i₂ f,
  rw c₁cocone i₁ i₂ f,
  simp [comp_assoc],
  intros c₂ hc₂,
  cases colc₁ with c₁cocone c₁uni,
  cases c₁uni c₂ hc₂ with ρ hρ,
  cases c₂ with c₂ j₂,
  cases hρ with hρ₁ hρ₂,
  existsi ρ ∘ₘ ψ,
  split,
  dsimp,
  intro i,
  rw [← comp_assoc, comp_assoc (j₁ i),hψ₂, id_comp_left],
  apply hρ₁,
  intros γ hγ,
  have hrw : γ ∘ₘ φ = ρ,
    apply hρ₂,
    intro i,
    rw ← comp_assoc,
    apply hγ,
  rw [← hrw, ← comp_assoc,hψ₁,id_comp_right],
end

/-
  Using a nonstandard defintion of concrete category based on the idea
  that I'm only using the defn for sheaf, and need them to commute with
  colimits to define stalks.

  I say that functor F : C → D commutes with colimits if for all functors
  G : J → C, G has a colimit if and only if F ∘ G has a colimit,
  and the cannoial morphism d → F(c) is an isomorphism where c, d are
  colimits of G and (F ∘ G) respectively.
-/

def image_of_colimit {C : Type u} [category.{v} C] {D : Type uₒ} [category.{vₒ} D] {J : Type uᵢ}
  [category.{vᵢ} J] {F : J +→ C} (G : C +→ D) (c : Σ cl : C, Π i : J, Mor (F.map i) cl)
  : Σ d : D, Π i : J, Mor ((G ⊚ F).map i) d := ⟨G.map c.1, λ i : J, G.fmap (c.2 i)⟩

theorem image_of_colimit_cocone {C : Type u} [category.{v} C] {D : Type uₒ} [category.{vₒ} D] {J : Type uᵢ}
  [category.{vᵢ} J] {F : J +→ C} (G : C +→ D) {c : Σ cl : C, Π i : J, Mor (F.map i) cl} (hc : is_colimit F c)
  : is_cocone (G ⊚ F) (image_of_colimit G c) :=
begin
  intros i₁ i₂ f,
  simp,
  have hrw : (G ⊚ F).fmap f = G.fmap (F.fmap f) := rfl,
  cases c,
  rw [hrw,← G.fmap_prevs_comp],
  cases hc,
  simp [is_cocone] at hc_left,
  rw ← hc_left i₁ i₂ f,
end

theorem exists_image_of_colimit_can_mor {C : Type u} [category.{v} C] {D : Type uₒ} [category.{vₒ} D] {J : Type uᵢ}
  [category.{vᵢ} J] {F : J +→ C} {G : C +→ D} {c : Σ cl : C, Π i : J, Mor (F.map i) cl}
  {d : Σ dl : D, Π i : J, Mor ((G ⊚ F).map i) dl} (hc : is_colimit F c) (hd : is_colimit (G ⊚ F) d)
  : ∃! φ : Mor d.1 (image_of_colimit G c).1, ∀ i : J, (image_of_colimit G c).2 i = φ ∘ₘ (d.2 i) :=
begin
  cases hd with dcocone duni,
  apply duni,
  apply image_of_colimit_cocone,
  exact hc,
end

noncomputable def image_of_colimit_can_mor {C : Type u} [category.{v} C] {D : Type uₒ} [category.{vₒ} D] {J : Type uᵢ}
  [category.{vᵢ} J] {F : J +→ C} {G : C +→ D} {c : Σ cl : C, Π i : J, Mor (F.map i) cl}
  {d : Σ dl : D, Π i : J, Mor ((G ⊚ F).map i) dl} (hc : is_colimit F c) (hd : is_colimit (G ⊚ F) d)
  : Mor d.1 (image_of_colimit G c).1 := some (exists_image_of_colimit_can_mor hc hd)

theorem image_of_colimit_can_mor_property {C : Type u} [category.{v} C] {D : Type vₒ} [category.{vₒ} D] {J : Type uᵢ}
  [category.{vᵢ} J] {F : J +→ C} {G : C +→ D} {c : Σ cl : C, Π i : J, Mor (F.map i) cl}
  {d : Σ dl : D, Π i : J, Mor ((G ⊚ F).map i) dl} (hc : is_colimit F c) (hd : is_colimit (G ⊚ F) d)
  : (∀ i : J, (image_of_colimit G c).2 i = (image_of_colimit_can_mor hc hd) ∘ₘ (d.2 i)) ∧ (∀ ϕ : Mor d.1 (image_of_colimit G c).1,
  (∀ i : J, (image_of_colimit G c).2 i = ϕ ∘ₘ (d.2 i)) → ϕ = (image_of_colimit_can_mor hc hd))
  := some_spec (exists_image_of_colimit_can_mor hc hd)

class has_small_filtered_colimits (C : Type u) [category.{v} C] :=
(colimits_exist : ∀ {J : Type v} [category.{v} J] [nonempty J] (hJ : filtered_category J)
  (F : J +→ C), ∃ c, is_colimit F c)

noncomputable def filtered_colimit {C : Type u} [category.{v} C] [has_small_filtered_colimits C]
  {J : Type v} [category.{v} J] [nonempty J] (hJ : filtered_category J) (F : J +→ C)
  : (Σ cl : C, Π i : J, Mor (F.map i) cl)
  := some (has_small_filtered_colimits.colimits_exist hJ F)

theorem filtered_colimit_property {C : Type u} [category.{v} C] [has_small_filtered_colimits C]
  {J : Type v} [category.{v} J] [nonempty J] (hJ : filtered_category J) (F : J +→ C)
  : is_colimit F (filtered_colimit hJ F)
  := some_spec (has_small_filtered_colimits.colimits_exist hJ F)

def f_colim_equiv {J : Type v} [category.{v} J] [nonempty J] (hJ : filtered_category J)
  (F : J +→ Type v) : (Σ i : J, F.map i) → (Σ i : J, F.map i) → Prop
  | ⟨i₁,s₁⟩ ⟨i₂,s₂⟩ := ∃ (k : J) (f₁ : Mor i₁ k) (f₂ : Mor i₂ k), F.fmap f₁ s₁ = F.fmap f₂ s₂

lemma f_colim_equiv_refl {J : Type v} [category.{v} J] [nonempty J] (hJ : filtered_category J)
  (F : J +→ Type v) : ∀ s : (Σ i : J, F.map i), f_colim_equiv hJ F s s :=
begin
  intro s,
  cases s with i s,
  existsi i,
  existsi idₘ i,
  existsi idₘ i,
  refl,
end

lemma f_colim_equiv_symm {J : Type v} [category.{v} J] [nonempty J] (hJ : filtered_category J)
  (F : J +→ Type v): ∀ s₁ s₂ : (Σ i : J, F.map i), f_colim_equiv hJ F s₁ s₂ → f_colim_equiv hJ F s₂ s₁ :=
begin
  intros s₁ s₂ h₁₂,
  cases s₁ with i₁ s₁,
  cases s₂ with i₂ s₂,
  cases h₁₂ with k hk,
  cases hk with f₁ h,
  cases h with f₂ h,
  existsi k,
  existsi f₂,
  existsi f₁,
  symmetry,
  exact h,
end

lemma f_colim_equiv_trans {J : Type v} [category.{v} J] [nonempty J] (hJ : filtered_category J)
  (F : J +→ Type v) : ∀ s₁ s₂ s₃ : (Σ i : J, F.map i), f_colim_equiv hJ F s₁ s₂ → f_colim_equiv hJ F s₂ s₃
    → f_colim_equiv hJ F s₁ s₃ :=
begin
  intros s₁ s₂ s₃ h₁₂ h₂₃,
  cases s₁ with i₁ s₁,
  cases s₂ with i₂ s₂,
  cases s₃ with i₃ s₃,
  cases hJ with hbound hcon,
  cases h₁₂ with k₁ rest,
  cases rest with a₁ rest,
  cases rest with a₂ h₁₂,
  cases h₂₃ with k₂ rest,
  cases rest with b₁ rest,
  cases rest with b₂ h₂₃,
  cases hbound k₁ k₂ with k hk,
  cases hk with hk₁ hk₂,
  cases hk₁ with φ₁,
  cases hk₂ with φ₂,
  cases hcon i₂ k (φ₁ ∘ₘ a₂) (φ₂ ∘ₘ b₁) with w hw,
  cases hw with ϕ hϕ,
  existsi w,
  existsi ϕ ∘ₘ φ₁ ∘ₘ a₁,
  existsi ϕ ∘ₘ φ₂ ∘ₘ b₂,
  simp [F.fmap_prevs_comp],
  simp [set_comp_app],
  rw [h₁₂,←h₂₃],
  rw ←set_comp_app (F.fmap φ₁),
  rw ←set_comp_app (F.fmap φ₂),
  simp [← set_comp_app (F.fmap ϕ),← F.fmap_prevs_comp],
  rw hϕ,
end

def f_colim_equiv_setoid {J : Type v} [category.{v} J] [nonempty J] (hJ : filtered_category J)
  (F : J +→ Type v) : setoid (Σ i : J, F.map i)
  := ⟨f_colim_equiv hJ F, f_colim_equiv_refl hJ F, f_colim_equiv_symm hJ F, f_colim_equiv_trans hJ F⟩

def filtered_colimit_set_obj {J : Type v} [category.{v} J] [nonempty J] (hJ : filtered_category J)
  (F : J +→ Type v) : Type v := quotient (f_colim_equiv_setoid hJ F)

def filtered_colimit_set_mor {J : Type v} [category.{v} J] [nonempty J] (hJ : filtered_category J)
  (F : J +→ Type v) : Π i : J, Mor (F.map i) (filtered_colimit_set_obj hJ F)
  := λ (i:J) (s : F.map i),  @quotient.mk (Σ i : J, F.map i) (f_colim_equiv_setoid hJ F) ⟨i,s⟩

def filtered_colimit_set {J : Type v} [category.{v} J] [nonempty J] (hJ : filtered_category J)
  (F : J +→ Type v) : (Σ cl : Type v, Π i : J, Mor (F.map i) cl)
  := ⟨filtered_colimit_set_obj hJ F, filtered_colimit_set_mor hJ F⟩

def filtered_colimit_set_pre_can {J : Type v} [category.{v} J] [nonempty J] (hJ : filtered_category J)
  {F : J +→ Type v} {c : (Σ cl : Type v, Π i : J, Mor (F.map i) cl)} (hc : is_cocone F c)
  : (Σ i : J, F.map i) → c.1
  | ⟨i,s⟩ := (c.2 i) s

lemma filtered_colimit_set_pre_can_lift {J : Type v} [category.{v} J] [nonempty J] (hJ : filtered_category J)
  {F : J +→ Type v} {c : (Σ cl : Type v, Π i : J, Mor (F.map i) cl)} (hc : is_cocone F c)
  : ∀ s₁ s₂ : (Σ i : J, F.map i), f_colim_equiv hJ F s₁ s₂ →
  filtered_colimit_set_pre_can hJ hc s₁ = filtered_colimit_set_pre_can hJ hc s₂ :=
begin
  intros s₁ s₂,
  intro h₁₂,
  cases s₁ with i₁ s₁,
  cases s₂ with i₂ s₂,
  simp [filtered_colimit_set_pre_can],
  cases c with c j,
  simp,
  simp [is_cocone] at hc,
  cases h₁₂ with k hk,
  cases hk with f₁ rest,
  cases rest with f₂ h₁₂,
  rw [hc i₁ k f₁, hc i₂ k f₂],
  simp [set_comp_app],
  rw h₁₂,
end

def filtered_colimit_set_can {J : Type v} [category.{v} J] [nonempty J] (hJ : filtered_category J)
  {F : J +→ Type v} {c : (Σ cl : Type v, Π i : J, Mor (F.map i) cl)} (hc : is_cocone F c)
  : filtered_colimit_set_obj hJ F → c.1 :=
begin
  apply quotient.lift,
  apply filtered_colimit_set_pre_can_lift,
  assumption,
end

lemma filtered_colimit_set_can_concrete_char {J : Type v} [category.{v} J] [nonempty J] (hJ : filtered_category J)
  {F : J +→ Type v} {c : (Σ cl : Type v, Π i : J, Mor (F.map i) cl)} (hc : is_cocone F c)
  : ∀ (i : J) (s : F.map i),
  filtered_colimit_set_can hJ hc (@quotient.mk (Σ i : J, F.map i) (f_colim_equiv_setoid hJ F) ⟨i,s⟩) = c.2 i s :=
begin
  intros i s,
  refl,
end

theorem filtered_colimit_set_colimit {J : Type v} [category.{v} J] [nonempty J] (hJ : filtered_category J)
  (F : J +→ Type v) : is_colimit F (filtered_colimit_set hJ F) :=
begin
  have trv₁ : (filtered_colimit_set hJ F).2 = filtered_colimit_set_mor hJ F := rfl,
  split,
  intros i₁ i₂ f,
  simp [filtered_colimit_set_mor],
  apply funext,
  intro s,
  rw set_comp_app,
  apply quotient.sound,
  existsi i₂,
  existsi f,
  existsi idₘ i₂,
  rw functor.fmap_prevs_id,
  refl,
  intros c hc,
  existsi filtered_colimit_set_can hJ hc,
  cases c with c j,
  simp [trv₁,filtered_colimit_set_mor],
  split,
  intro i,
  apply funext,
  intro s,
  rw set_comp_app,
  rw filtered_colimit_set_can_concrete_char hJ hc,
  intros ψ hψ,
  apply funext,
  intro q,
  cases (@quotient.exists_rep (Σ i : J, F.map i) (f_colim_equiv_setoid hJ F) q) with r hr,
  cases r with i s,
  simp [←hr],
  rw filtered_colimit_set_can_concrete_char hJ hc,
  simp,
  symmetry,
  rw hψ i,
  refl,
end

end category


import category_theory.limits.shapes.binary_products
import category_theory.limits.opposites
import category_theory.closed.cartesian

import subobject_classifier
import adjunction
import image
import topos

open category_theory category_theory.category category_theory.limits

/-!
Definitions and properties of direct image of a monic
Beck-Chevalley conditions

Only the first definition and the last theorems are not auxiliary junk
References : [MM92, IV.3]
-/

universes v u

noncomputable theory

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

open category_theory.limits.prod category_theory.cartesian_closed classifier opposite topos

namespace direct_image

variables {b b' c : C} (k : b' ⟶ b) [mono k]

def uncurried := classifier_of (canonical_incl (in_map b') ≫ map k (𝟙 _))

def curried : (P C).obj (op b') ⟶ (P C).obj (op b) := curry (uncurried k)

lemma curried_id : curried (𝟙 b) = 𝟙 ((P C).obj (op b)) :=
begin
  erw [curry_eq_iff, uncurry_id_eq_ev],
  unfold uncurried, simp only [map_id_id, comp_id],
  rw classifier_of_canonical_incl_eq_self, refl
end

variables {g : c ⟶ b} {k}

lemma mono_of_pullback (s : pullback_cone g k) (is_lim : is_limit s) : mono s.fst :=
{ right_cancellation :=
  begin
    intros d u v heq,
    apply pullback_cone.is_limit.hom_ext is_lim heq,
    rw [←cancel_mono k, assoc, ←s.condition, ←assoc, heq, assoc, s.condition, assoc]
  end }

-- The instance mono s.fst should be infered from
-- pullback.fst_of_mono but is not

-- We follow [MM92, IV.3.2], with mostly their notations
variables (s : pullback_cone g k)

def upper_right_rectangle (k : b' ⟶ b) [mono k] : pullback_cone (uncurried k) (truth C) :=
pullback_cone.mk (canonical_incl (in_map b') ≫ map k (𝟙 _)) (terminal.from _) (classifier.comm _)

def upper_left_bottom : pullback_cone (map g (𝟙 ((P C).obj (op b')))) (map k (𝟙 ((P C).obj (op b')))) :=
pullback_cone.mk (map s.fst (𝟙 _)) (map s.snd (𝟙 _)) (by { rw [map_map, map_map, s.condition] })

def lower_right_rectangle [mono s.fst] : pullback_cone (uncurried s.fst) (truth C) :=
pullback_cone.mk (canonical_incl (in_map s.X) ≫ map s.fst (𝟙 _)) (terminal.from _) (classifier.comm _)

def lower_left_bottom : pullback_cone (map (𝟙 _) ((P C).map s.snd.op)) (map s.fst (𝟙 _))  :=
pullback_cone.mk (map s.fst (𝟙 _))  (map (𝟙 _) ((P C).map s.snd.op))
(by repeat { rw [map_map, id_comp, comp_id] })

lemma is_pullback_upper_right_rectangle : is_limit (upper_right_rectangle k) :=
classifier.is_pb _

lemma is_pullback_upper_left_bottom (is_lim : is_limit s) : is_limit (upper_left_bottom s) :=
is_pullback_of_prod_pullback is_lim (is_pullback_square_ids_snd _)

lemma is_pullback_lower_right_rectangle [mono s.fst] : is_limit (lower_right_rectangle s) :=
classifier.is_pb _

lemma is_pullback_lower_left_bottom (is_lim : is_limit s) : is_limit (lower_left_bottom s) :=
is_pullback_of_prod_pullback (is_pullback_square_ids_fst _) (is_pullback_square_ids_snd _)

def upper_big_canonical := canonical_incl (map s.snd (𝟙 _) ≫ in_map b')

namespace upper

def left : pullback (map s.snd (𝟙 _)) (canonical_incl (in_map b')) ⟶ s.X ⨯ (P C).obj (op b') :=
pullback.fst

def top : pullback (map s.snd (𝟙 _)) (canonical_incl (in_map b')) ⟶ s{in_map b'}s :=
pullback.snd

def cone : pullback_cone (map s.snd (𝟙 _) ≫ in_map b') (truth C) :=
pullback_cone.mk (left s) (top s ≫ terminal.from _)
begin
  erw [←assoc, pullback.condition],
  rw [assoc, canonical_incl_comm, assoc],
  refl,
end

lemma is_pullback_cone : is_limit (cone s) :=
big_square_is_pullback (top s) (terminal.from _)
    (map s.snd (𝟙 _)) (in_map b') (left s) (canonical_incl (in_map b')) (truth C)
    pullback.condition (canonical_incl_comm (in_map b'))
    (canonical_is_pullback _) (pullback_is_pullback _ _)

end upper

namespace lower

def left :
  pullback (map (𝟙 s.X) ((P C).map s.snd.op)) (canonical_incl (in_map s.X)) ⟶ _ :=
pullback.fst

def top :
  pullback (map (𝟙 s.X) ((P C).map s.snd.op)) (canonical_incl (in_map s.X)) ⟶ s{in_map s.X}s :=
pullback.snd

def cone : pullback_cone (map (𝟙 s.X) ((P C).map s.snd.op) ≫ in_map s.X) (truth C) :=
pullback_cone.mk (left s) (top s ≫ terminal.from _)
begin
  erw [←assoc, pullback.condition],
  rw [assoc, canonical_incl_comm, assoc],
  refl,
end

lemma is_pullback_cone: is_limit (cone s) :=
big_square_is_pullback (top s) (terminal.from _)
    (map (𝟙 s.X) ((P C).map s.snd.op)) (in_map s.X) (left s) (canonical_incl (in_map s.X)) (truth C)
    pullback.condition (canonical_incl_comm (in_map s.X))
    (canonical_is_pullback _) (pullback_is_pullback _ _)

end lower

namespace lower_big

def left_rectangle_flipped :
  pullback_cone (canonical_incl (in_map s.X) ≫ map s.fst (𝟙 _)) (map (𝟙 c) ((P C).map s.snd.op)) :=
pullback_cone.mk (lower.top s) (lower.left s ≫ map s.fst (𝟙 _))
begin
  rw assoc,
  erw (lower_left_bottom s).condition,
  rw ←assoc,
  erw ←pullback.condition,
  rw assoc, refl,
end

lemma is_pullback_left_rectangle_flipped (s_lim : is_limit s) :
  is_limit (left_rectangle_flipped s) :=
big_square_is_pullback (lower.left s) (map s.fst (𝟙 _))
    (canonical_incl (in_map s.X)) (map s.fst (𝟙 _)) (lower.top s)
    (map (𝟙 s.X) ((P C).map s.snd.op)) (map (𝟙 c) ((P C).map s.snd.op))
    pullback.condition.symm (lower_left_bottom s).condition.symm
    (pullback_cone.flip_is_limit (is_pullback_lower_left_bottom s s_lim))
    (pullback_cone.flip_is_limit (pullback_is_pullback _ _))

def left_rectangle :
  pullback_cone (map (𝟙 c) ((P C).map s.snd.op)) (canonical_incl (in_map s.X) ≫ map s.fst (𝟙 _)) :=
pullback_cone.mk (lower.left s ≫ map s.fst (𝟙 _)) (lower.top s)
(left_rectangle_flipped _).condition.symm

lemma is_pullback_left_rectangle (s_lim : is_limit s) : is_limit (left_rectangle s) :=
pullback_cone.flip_is_limit (is_pullback_left_rectangle_flipped s s_lim)

def big_square [mono s.fst] : pullback_cone (map (𝟙 c) ((P C).map s.snd.op) ≫ uncurried s.fst) (truth C) :=
pullback_cone.mk (lower.left s ≫ map s.fst (𝟙 _)) (lower.top s ≫ terminal.from _)
begin
  nth_rewrite 1 assoc,
  erw ←(lower_right_rectangle s).condition,
  rw [←assoc, ←assoc],
  apply eq_whisker,
  rw assoc, erw ←(left_rectangle s).condition,
  rw ←assoc, refl,
end

lemma is_pullback_big_square (s_lim : is_limit s) [mono s.fst] : is_limit (big_square s) :=
big_square_is_pullback (lower.top s) (terminal.from _)
  (map (𝟙 c) ((P C).map s.snd.op)) (uncurried s.fst)
  (lower.left s ≫ map s.fst (𝟙 _)) (canonical_incl (in_map s.X) ≫ map s.fst (𝟙 _))
  (truth C) (left_rectangle s).condition (lower_right_rectangle s).condition
  (is_pullback_lower_right_rectangle s)
  (is_pullback_left_rectangle s s_lim)

end lower_big

namespace upper_big

def left_rectangle_flipped :
  pullback_cone (canonical_incl (in_map b') ≫ map k (𝟙 _)) (map g (𝟙 _)) :=
pullback_cone.mk (upper.top s) (upper.left s ≫ map s.fst (𝟙 _))
begin
  rw assoc,
  erw (upper_left_bottom s).condition,
  rw ←assoc,
  erw ←pullback.condition,
  rw assoc, refl,
end

lemma is_pullback_left_rectangle_flipped (s_lim : is_limit s) :
  is_limit (left_rectangle_flipped s) :=
big_square_is_pullback (upper.left s) (map s.fst (𝟙 _))
    (canonical_incl (in_map b')) (map k (𝟙 _)) (upper.top s)
    (map s.snd (𝟙 _)) (map g (𝟙 _))
    pullback.condition.symm (upper_left_bottom s).condition.symm
    (pullback_cone.flip_is_limit (is_pullback_upper_left_bottom s s_lim))
    (pullback_cone.flip_is_limit (pullback_is_pullback _ _))

def left_rectangle :
  pullback_cone (map g (𝟙 _)) (canonical_incl (in_map b') ≫ map k (𝟙 _)) :=
pullback_cone.mk (upper.left s ≫ map s.fst (𝟙 _)) (upper.top s)
(left_rectangle_flipped _).condition.symm

lemma is_pullback_left_rectangle (s_lim : is_limit s) : is_limit (left_rectangle s) :=
pullback_cone.flip_is_limit (is_pullback_left_rectangle_flipped s s_lim)

def big_square [mono s.fst] : pullback_cone (map g (𝟙 _) ≫ uncurried k) (truth C) :=
pullback_cone.mk (upper.left s ≫ map s.fst (𝟙 _)) (upper.top s ≫ terminal.from _)
begin
  nth_rewrite 1 assoc,
  erw ←(upper_right_rectangle k).condition,
  rw [←assoc, ←assoc],
  apply eq_whisker,
  rw assoc, erw ←(left_rectangle s).condition,
  rw ←assoc, refl,
end

lemma is_pullback_big_square (s_lim : is_limit s) [mono s.fst] : is_limit (big_square s) :=
big_square_is_pullback (upper.top s) (terminal.from _)
  (map g (𝟙 _)) (uncurried k)
  (upper.left s ≫ map s.fst (𝟙 _)) (canonical_incl (in_map b') ≫ map k (𝟙 _))
  (truth C) (left_rectangle s).condition (upper_right_rectangle k).condition
  is_pullback_upper_right_rectangle
  (is_pullback_left_rectangle s s_lim)

end upper_big

namespace lower_upper

variables {s}

def low_of_up (t : pullback_cone (map s.snd (𝟙 _) ≫ in_map b') (truth C)) :
  pullback_cone (map (𝟙 s.X) ((P C).map s.snd.op) ≫ in_map s.X) (truth C) :=
pullback_cone.mk t.fst (terminal.from _)
begin
  erw [←in_map_dinatural, t.condition],
  congr,
end

def up_of_low (t : pullback_cone (map (𝟙 s.X) ((P C).map s.snd.op) ≫ in_map s.X) (truth C)) :
  pullback_cone (map s.snd (𝟙 _) ≫ in_map b') (truth C) :=
pullback_cone.mk t.fst (terminal.from _)
begin
  rw [in_map_dinatural, t.condition],
  congr,
end

variable (s)

def cone : pullback_cone (map (𝟙 s.X) ((P C).map s.snd.op) ≫ in_map s.X) (truth C) :=
low_of_up (upper.cone s)

def lift_cone (t : pullback_cone (map (𝟙 s.X) ((P C).map s.snd.op) ≫ in_map s.X) (truth C)) :=
pullback_cone.is_limit.lift' (upper.is_pullback_cone s) (up_of_low t).fst (up_of_low t).snd (up_of_low t).condition

lemma is_pullback_cone : is_limit (cone s) :=
begin
  apply pullback_cone.is_limit.mk _ (λ t, (lift_cone s t).val); intro t; simp only,
  { exact (lift_cone s t).prop.left },
  { apply is_terminal.hom_ext terminal_is_terminal },
  { intros r hfst hsnd,
    apply pullback_cone.is_limit.hom_ext (upper.is_pullback_cone s),
      erw [hfst, (lift_cone s t).prop.left], refl,
      apply is_terminal.hom_ext terminal_is_terminal }
end
end lower_upper

--

instance (s_lim : is_limit s) : mono (s.fst) := pullback_cone.mono_fst_of_is_pullback_of_mono s_lim

def iso_X := is_limit.cone_point_unique_up_to_iso (lower_upper.is_pullback_cone s) (lower.is_pullback_cone s)

lemma iso_comm_X_hom :
  (iso_X s).hom ≫ lower.left s ≫ map s.fst (𝟙 _) = upper.left s ≫ map s.fst (𝟙 _) :=
begin
  rw ←assoc,
  apply eq_whisker,
  apply is_limit.cone_point_unique_up_to_iso_hom_comp
    (lower_upper.is_pullback_cone s) (lower.is_pullback_cone s) walking_cospan.left
end

lemma iso_comm_X_inv :
  (iso_X s).inv ≫ upper.left s ≫ map s.fst (𝟙 _) = lower.left s ≫ map s.fst (𝟙 _) :=
by { rw [←iso_comm_X_hom, ←assoc, iso.inv_hom_id, id_comp] }

lemma mono_lower_left (s_lim : is_limit s) : mono (lower.left s ≫ map s.fst (𝟙 _)) :=
begin
  haveI := pullback_cone.mono_fst_of_is_pullback_of_mono s_lim,
  apply pullback_cone.mono_fst_of_is_pullback_of_mono (lower_big.is_pullback_big_square s s_lim),
end

lemma mono_upper_left (s_lim : is_limit s) : mono (upper.left s ≫ map s.fst (𝟙 _)) :=
begin
  rw ←iso_comm_X_hom,
  haveI := mono_lower_left s s_lim,
  apply mono_comp
end

abbreviation upleft := upper.left s ≫ map s.fst (𝟙 _)
abbreviation lowleft := lower.left s ≫ map s.fst (𝟙 _)

variable {s}

lemma mono_lowleft (s_lim : is_limit s) : mono (lowleft s) := mono_lower_left s s_lim
lemma mono_upleft (s_lim : is_limit s) : mono (upleft s) := mono_upper_left s s_lim

lemma classifier_upleft_eq_upper_bot [mono s.fst] (s_lim : is_limit s) :
  @classifier_of _ _ _ _ _ _ (upleft s) (mono_upleft s_lim) =
   map g (𝟙 _) ≫ uncurried k :=
begin
  apply uniquely,
  refine {comm := _, is_pb := _},
  convert (upper_big.big_square s).condition,
  convert (upper_big.is_pullback_big_square s s_lim),
  apply is_terminal.hom_ext terminal_is_terminal
end

def upper_left_big_lift [mono s.fst] (s_lim : is_limit s)
  (t : pullback_cone (map (𝟙 c) ((P C).map s.snd.op) ≫ uncurried s.fst) (truth C)) :=
pullback_cone.is_limit.lift' (lower_big.is_pullback_big_square s s_lim) t.fst t.snd t.condition

lemma classifier_upleft_eq_lower_bot [mono s.fst] (s_lim : is_limit s) :
  @classifier_of _ _ _ _ _ _ (upleft s) (mono_upleft s_lim) =
  map (𝟙 _) ((P C).map s.snd.op) ≫ uncurried s.fst :=
begin
  apply uniquely,
  refine {comm := _, is_pb := _},
  dunfold upleft,
  erw ←iso_comm_X_hom,
  rw assoc,
  erw (lower_big.big_square s).condition,
  symmetry,
  rw [←iso.inv_comp_eq, ←assoc, terminal.comp_from], congr,

  apply pullback_cone.is_limit.mk _ (λ t, (upper_left_big_lift s_lim t).val ≫ (iso_X s).inv);
  intro t; simp only,
  { rw [assoc, iso_comm_X_inv],
    erw (upper_left_big_lift s_lim t).prop.left },
  { apply is_terminal.hom_ext terminal_is_terminal },
  { intros r hfst hsdn, rw iso.eq_comp_inv,
    apply pullback_cone.is_limit.hom_ext (lower_big.is_pullback_big_square s s_lim),
      erw (upper_left_big_lift s_lim t).prop.left,
      rw assoc, erw [iso_comm_X_hom, hfst],
      apply is_terminal.hom_ext terminal_is_terminal }
end

lemma uncurried_beck_chevalley [mono s.fst] (s_lim : is_limit s) :
  map g (𝟙 _) ≫ uncurried k = map (𝟙 _) ((P C).map s.snd.op) ≫ uncurried s.fst :=
by rw [←classifier_upleft_eq_lower_bot, ←classifier_upleft_eq_upper_bot s_lim]

lemma curried_beck_chevalley' [mono s.fst] (s_lim : is_limit s) :
  curried k ≫ (P C).map g.op = (P C).map s.snd.op ≫ curried s.fst :=
begin
  dunfold curried,
  have eq := congr_arg curry (uncurried_beck_chevalley s_lim) ,
  rw curry_natural_left at eq,
  erw [←eq, eq_curry_iff, uncurry_natural_left, uncurry_pre],
  clear eq,
  erw [←assoc, map_map, id_comp, comp_id (curry (uncurried k))],
  rw [←comp_id g.op.unop, ←id_comp (curry (uncurried k)), ←map_map, assoc],
  rw [←uncurry_eq, uncurry_curry], refl,
end

variable {s}
def curried_beck_chevalley (is_lim : is_limit s) :=
  @curried_beck_chevalley' _ _ _ _ _ _ _ _ _ s (mono_of_pullback s is_lim) is_lim

-- Corollary 3.
variable (k)
lemma id_beck_chevalley : curried k ≫ (P C).map k.op = 𝟙 _ :=
begin
  have cond := curried_beck_chevalley (is_pullback_id_cone_of_monic k),
  simp only [pullback_cone.mk_fst, pullback_cone.mk_snd] at cond,
  erw cond,
  dunfold P, simp only, erw pre_id,
  rw [nat_trans.id_app, id_comp, curried_id], refl
end

end direct_image


import verification.semantics.stream_add
import verification.semantics.stream_multiply
import verification.semantics.stream_replicate
import verification.semantics.stream_props

local infixr ` ↠ `:50 := SimpleStream

section
variables {ι₁ ι₂ ι₃ : Type} [linear_order ι₁] [linear_order ι₂]
  [linear_order ι₃] {R : Type} [semiring R]

open Eval (eval)

local notation `∑ᵢ ` s := s.contract

local notation (name := bool_add) a ` && ` b := a + b

--
noncomputable instance SimpleStream.AddZeroEval_weird :
  AddZeroEval (ι₁ ↠ ι₂ ↠ ι₃ ↠ R) ι₁ (ι₂ →₀ ι₃ →₀ R) :=
  SimpleStream.AddZeroEval

example (a b c d : ι₁ ↠ ι₂ ↠ ι₃ ↠ R)  :
  eval (a * (b + c) * d) =
  (eval a) * ((eval b) + (eval c)) * (eval d) :=
by simp

example [semiring R] (a b c : SimpleStream ι₁ (SimpleStream ι₂ R)) :
  eval ((a + b) * c) = eval a * eval c + eval b * eval c :=
by simp [add_mul]

end

open_locale big_operators

section
variables {ι₁ ι₂ ι₃ : Type} [linear_order ι₁] [linear_order ι₂]
  [linear_order ι₃] {R : Type} [semiring R]

local notation `∑ᵢ ` s := s.contract

-- Unfortunately, Lean doesn't like the notation `eval s x y` because it doesn't know `eval s x` is going to be a function
-- TODO: Fix
@[reducible] def eval {ι₁ ι₂ α₁ R : Type*} [has_zero R] [Eval α₁ ι₁ (ι₂ →₀ R)]
  (x : α₁) : ι₁ →₀ ι₂ →₀ R := Eval.eval x

@[reducible] def eval3 {ι₁ ι₂ ι₃ α₁ R : Type*} [has_zero R] [Eval α₁ ι₁ (ι₂ →₀ ι₃ →₀ R)]
  (x : α₁) : ι₁ →₀ ι₂ →₀ ι₃ →₀ R := Eval.eval x

local attribute [simp] eval finsupp.sum_range_eq_sum finsupp.sum
  finsupp.finset_sum_apply

example (a b : ι₁ ↠ ι₂ ↠ R)
  (j : ι₂) : eval (∑ᵢ (a * b)) () j =
    ∑ i in (eval a * eval b).support,
    (eval a i j * eval b i j) :=
by rw Eval.contract'; simp

end

constants (n₁ n₂ n₃ : ℕ)

variables {R : Type} [semiring R]

variables {ι₁ ι₂ ι₃ : Type} [linear_order ι₁] [linear_order ι₂] [linear_order ι₃]
          (m₁ : fin n₁ ≃o ι₁)
          (m₂ : fin n₂ ≃o ι₂)
          (m₃ : fin n₃ ≃o ι₃)

local notation `⇑₁` := SimpleStream.replicate' (m₁ : fin n₁ ↪o ι₁)
local notation `⇑₂` := SimpleStream.replicate' (m₂ : fin n₂ ↪o ι₂)
local notation `⇑₃` := SimpleStream.replicate' (m₃ : fin n₃ ↪o ι₃)

section

local notation `∑ᵢ ` s := s.contract

local attribute [simp] eval finsupp.sum_range_eq_sum finsupp.sum
  finsupp.finset_sum_apply finsupp.const
  SimpleStream.replicate'.spec_equiv -- TODO: tag this as @[simp]?

example (c : R) (k : ι₃) : Eval.eval (⇑₃ c) k = c :=
by simp [Eval.eval]

example (v w : ι₃ ↠ R) (k : ι₃) : Eval.eval (v * w) k = (Eval.eval v k) * (Eval.eval w k) :=
by simp

example (c : R) (v : ι₃ ↠ R) (k : ι₃) : Eval.eval ((⇑₃ c) * v) k = c * (Eval.eval v k) :=
by { simp_rw [MulEval.hmul, Eval.eval], simp }

-- Help instance inferrer out a bit.
noncomputable instance test_instance :
Eval (StreamExec unit R) unit R := infer_instance
noncomputable instance test_instance2 {ι} [linear_order ι] :
Eval (StreamExec unit (ι ↠ R)) unit (ι →₀ R) := infer_instance

noncomputable def matmul (a : ι₁ ↠ ι₂ ↠ R) (b : ι₂ ↠ ι₃ ↠ R) :=
(λ (r : ι₂ ↠ R), ∑ᵢ ((⇑₃ <§₂> r) * b)) <§₂> a

example (a : ι₁ ↠ ι₂ ↠ R) (b : ι₂ ↠ ι₃ ↠ R) (i : ι₁) (k : ι₃) :
  eval3 (matmul m₃ a b) i () k =
    ∑ j in (eval a i).support ∪ (eval b).support,
    (eval a i j * eval b j k) :=
begin
  simp_rw [eval, eval3],
  sorry -- TODO: one day, hopefully soon
end

end


/-
Copyright (c) 2018 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Reid Barton, Bhavik Mehta
-/
import category_theory.over
import category_theory.adjunction.opposites
import category_theory.limits.preserves.basic
import category_theory.limits.shapes.pullbacks
import category_theory.limits.creates

/-!
# Limits and colimits in the over and under categories

Show that the forgetful functor `forget X : over X ⥤ C` creates colimits, and hence `over X` has
any colimits that `C` has (as well as the dual that `forget X : under X ⟶ C` creates limits).

Note that the folder `category_theory.limits.shapes.constructions.over` further shows that
`forget X : over X ⥤ C` creates connected limits (so `over X` has connected limits), and that
`over X` has `J`-indexed products if `C` has `J`-indexed wide pullbacks.

TODO: If `C` has binary products, then `forget X : over X ⥤ C` has a right adjoint.
-/
noncomputable theory

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

open category_theory category_theory.limits

variables {J : Type v} [small_category J]
variables {C : Type u} [category.{v} C]
variable {X : C}

namespace category_theory.functor

/-- We can interpret a functor `F` into the category of arrows with codomain `X` as a cocone over
    the diagram given by the domains of the arrows in the image of `F` such that the apex of the
    cocone is `X`. -/
@[simps] def to_cocone (F : J ⥤ over X) : cocone (F ⋙ over.forget X) :=
{ X := X,
  ι := { app := λ j, (F.obj j).hom } }

/-- We can interpret a functor `F` into the category of arrows with domain `X` as a cone over the
    diagram given by the codomains of the arrows in the image of `F` such that the apex of the cone
    is `X`. -/
@[simps] def to_cone (F : J ⥤ under X) : cone (F ⋙ under.forget X) :=
{ X := X,
  π := { app := λ j, (F.obj j).hom } }

end category_theory.functor

namespace category_theory.over

instance : reflects_colimits (forget X) :=
{ reflects_colimits_of_shape := λ J 𝒥₁,
  { reflects_colimit := λ F,
    { reflects := λ c t, by exactI
      { desc := λ s, hom_mk (t.desc ((forget X).map_cocone s)) $ t.hom_ext $
                         λ j, by { rw t.fac_assoc, exact ((s.ι.app j).w).trans (c.ι.app j).w.symm },
        fac' := λ s j, over_morphism.ext (t.fac _ j),
        uniq' :=
          λ s m w, over_morphism.ext $
          t.uniq ((forget X).map_cocone s) m.left (λ j, congr_arg comma_morphism.left (w j)) } } } }

instance : creates_colimits (forget X) :=
{ creates_colimits_of_shape := λ J 𝒥₁, by exactI
  { creates_colimit := λ K,
    { lifts := λ c t,
      { lifted_cocone :=
        { X := mk (t.desc K.to_cocone),
          ι :=
          { app := λ j, hom_mk (c.ι.app j),
            naturality' := λ j j' f, over_morphism.ext (c.ι.naturality f) } },
        valid_lift := cocones.ext (iso.refl _) (λ j, category.comp_id _) } } } }

instance has_colimit {F : J ⥤ over X} [has_colimit (F ⋙ forget X)] : has_colimit F :=
has_colimit_of_created _ (forget X)

instance has_colimits_of_shape [has_colimits_of_shape J C] :
  has_colimits_of_shape J (over X) :=
{}

instance has_colimits [has_colimits C] : has_colimits (over X) := {}

-- We can automatically infer that the forgetful functor preserves colimits
example [has_colimits C] : preserves_colimits (forget X) := infer_instance

section
variables [has_pullbacks C]

open tactic

/-- When `C` has pullbacks, a morphism `f : X ⟶ Y` induces a functor `over Y ⥤ over X`,
by pulling back a morphism along `f`. -/
@[simps]
def pullback {X Y : C} (f : X ⟶ Y) : over Y ⥤ over X :=
{ obj := λ g, over.mk (pullback.snd : pullback g.hom f ⟶ X),
  map := λ g h k,
    over.hom_mk
      (pullback.lift (pullback.fst ≫ k.left) pullback.snd (by simp [pullback.condition]))
      (by tidy) }

/-- `over.map f` is left adjoint to `over.pullback f`. -/
def map_pullback_adj {A B : C} (f : A ⟶ B) :
  over.map f ⊣ pullback f :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ g h,
  { to_fun := λ X, over.hom_mk (pullback.lift X.left g.hom (over.w X)) (pullback.lift_snd _ _ _),
    inv_fun := λ Y,
    begin
      refine over.hom_mk _ _,
      refine Y.left ≫ pullback.fst,
      dsimp,
      rw [← over.w Y, category.assoc, pullback.condition, category.assoc], refl,
    end,
    left_inv := λ X, by { ext, dsimp, simp, },
    right_inv := λ Y, begin
      ext, dsimp,
      simp only [pullback.lift_fst],
      dsimp,
      rw [pullback.lift_snd, ← over.w Y],
      refl,
    end } }

/-- pullback (𝟙 A) : over A ⥤ over A is the identity functor. -/
def pullback_id {A : C} : pullback (𝟙 A) ≅ 𝟭 _ :=
adjunction.right_adjoint_uniq
  (map_pullback_adj _)
  (adjunction.id.of_nat_iso_left over.map_id.symm)

/-- pullback commutes with composition (up to natural isomorphism). -/
def pullback_comp {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) :
  pullback (f ≫ g) ≅ pullback g ⋙ pullback f :=
adjunction.right_adjoint_uniq
  (map_pullback_adj _)
  (((map_pullback_adj _).comp _ _ (map_pullback_adj _)).of_nat_iso_left
    (over.map_comp _ _).symm)

instance pullback_is_right_adjoint {A B : C} (f : A ⟶ B) :
  is_right_adjoint (pullback f) :=
⟨_, map_pullback_adj f⟩

end

end category_theory.over

namespace category_theory.under

instance : reflects_limits (forget X) :=
{ reflects_limits_of_shape := λ J 𝒥₁,
  { reflects_limit := λ F,
    { reflects := λ c t, by exactI
      { lift := λ s, hom_mk (t.lift ((forget X).map_cone s)) $ t.hom_ext $ λ j,
                    by { rw [category.assoc, t.fac], exact (s.π.app j).w.symm.trans (c.π.app j).w },
        fac' := λ s j, under_morphism.ext (t.fac _ j),
        uniq' :=
          λ s m w, under_morphism.ext $
          t.uniq ((forget X).map_cone s) m.right (λ j, congr_arg comma_morphism.right (w j)) } } } }

instance : creates_limits (forget X) :=
{ creates_limits_of_shape := λ J 𝒥₁, by exactI
  { creates_limit := λ K,
    { lifts := λ c t,
      { lifted_cone :=
        { X := mk (t.lift K.to_cone),
          π :=
          { app := λ j, hom_mk (c.π.app j),
            naturality' := λ j j' f, under_morphism.ext (c.π.naturality f) } },
        valid_lift := cones.ext (iso.refl _) (λ j, (category.id_comp _).symm) } } } }

instance has_limit {F : J ⥤ under X} [has_limit (F ⋙ forget X)] : has_limit F :=
has_limit_of_created F (forget X)

instance has_limits_of_shape [has_limits_of_shape J C] :
  has_limits_of_shape J (under X) :=
{}

instance has_limits [has_limits C] : has_limits (under X) := {}

-- We can automatically infer that the forgetful functor preserves limits
example [has_limits C] : preserves_limits (forget X) := infer_instance

section
variables [has_pushouts C]

/-- When `C` has pushouts, a morphism `f : X ⟶ Y` induces a functor `under X ⥤ under Y`,
by pushing a morphism forward along `f`. -/
@[simps]
def pushout {X Y : C} (f : X ⟶ Y) : under X ⥤ under Y :=
{ obj := λ g, under.mk (pushout.inr : Y ⟶ pushout g.hom f),
  map := λ g h k,
    under.hom_mk
      (pushout.desc (k.right ≫ pushout.inl) pushout.inr (by { simp [←pushout.condition], }))
      (by tidy) }

end

end category_theory.under


import Playlean4.Group.Basic
import Playlean4.Group.Subgroup

namespace Group

open Group

section

variable (G : Type) (law : G → G → G) [grp : Group G law]

local infixl:70 " * " => id' law
@[appUnexpander id'] def normal.UnexpandGMul : Lean.PrettyPrinter.Unexpander
  | `(id' law $x $y) => `($x * $y)
  | _ => throw ()
local notation "one" => grp.one' -- HACK

section

variable {X : Type} (elaw : G → X → X) -- External Law

local infix:70 " • " => id' elaw
@[appUnexpander id'] def unexpandAction : Lean.PrettyPrinter.Unexpander
  | `(id' elaw $x $y) => `($x * $y)
  | _ => throw ()

class Action where
  identity' : ∀ x : X, one • x = x
  compat : ∀ (g g' : G) (x : X), (g * g') • x = g • (g' • x)

end

end

section

variable {G : Type} {law : G → G → G} [grp : Group G law]

local infixl:70 " * " => id' law
@[appUnexpander id'] def unexpandGMul : Lean.PrettyPrinter.Unexpander
  | `(id' Magma.law G $x $y) => `($x * $y)
  | _ => throw ()
local notation "one" => grp.one' -- HACK
local notation g"⁻¹" => grp.inv g

namespace Action

section

variable {X : Type} {elaw : G → X → X} [action : Action G law elaw]

local infix:70 " • " => id' elaw
@[appUnexpander id'] def unexpandAction : Lean.PrettyPrinter.Unexpander
  | `(id' elaw $x $y) => `($x • $y)
  | _ => throw ()

@[simp]
theorem identity (x : X) : one • x = x := action.identity' x

theorem reverseCompat (g g' : G) (x : X) : g • (g' • x) = (g * g') • x :=
Eq.symm <| action.compat g g' x

end

end Action

end

namespace Action

variable {G : Type} (law : G → G → G) [grp : Group G law]

local infixl:70 " * " => id' law
@[appUnexpander id'] def unexpandGMul : Lean.PrettyPrinter.Unexpander
  | `(id' Magma.law G $x $y) => `($x * $y)
  | _ => throw ()
local notation "one" => grp.one' -- HACK
local notation g"⁻¹" => grp.inv g

section

variable {X : Type} (elaw : G → X → X) [action : Action G law elaw]

local infix:70 " • " => id' elaw
@[appUnexpander id'] def unexpandAction' : Lean.PrettyPrinter.Unexpander
  | `(id' elaw $x $y) => `($x • $y)
  | _ => throw ()

def isStable (Y : Set X) : Prop := ∀ y : X, y ∈ Y → ∀ g : G, g • y ∈ Y

def orbit (x : X) : Set X := λ y => ∃ g : G, y = g • x

def memOfSelfOrbit (x : X) : x ∈ orbit elaw x := ⟨ one, by simp ⟩

theorem translatorOfMemOfOrbit {x : X} (y : orbit elaw x) : ∃ g : G, y.val = g • x := y.2

theorem orbitIsStable (x : X) : isStable elaw (orbit elaw x) :=
λ y yIn g => match yIn with
  | ⟨ g', h ⟩ =>  ⟨ (g * g'), by rw [h, ← action.compat] ⟩

def stabilizer (x : X) : Set G := λ g => g • x = x

class Transitive where
  singleOrbit : ∀ x y : X, ∃ g : G, y = g • x

end

namespace Remarkable

section

def onSelf : G → G → G := id' law

instance onSelfIsAction : Action G law (@onSelf G law) where
  identity' := λ g => by simp [onSelf]; exact grp.oneNeutralLeft _
  compat := λ g g' g'' => by simp [onSelf]; exact grp.assoc _ _ _

end

variable {X : Type} (elaw : G → X → X) [action : Action G law elaw]

local infix:70 " • " => id' elaw
@[appUnexpander id'] def unexpandAction : Lean.PrettyPrinter.Unexpander
  | `(id' elaw $x $y) => `($x • $y)
  | _ => throw ()

section

def liftToSet : (G → Set X → Set X) :=
  λ (g : G) => Set.img (λ x => g • x)

instance actionOnSet : Action G law (liftToSet elaw) where
  identity' := by
    intro x
    simp [liftToSet]
    funext a
    exact propext ⟨ (λ h => match h with
      | ⟨ y, h ⟩ => by rw [h.2]; simp; exact h.1),
      (λ h => ⟨ a, ⟨ h, by simp ⟩ ⟩) ⟩
  compat := by
    intro g g' x
    simp [liftToSet]
    funext a
    exact propext ⟨
      (λ h => match h with
      | ⟨ y, h ⟩ => ⟨ g' • y, by simp only []; exact
        (action.compat _ _ _) ▸ ⟨ ⟨ y, ⟨ h.1, rfl ⟩ ⟩, h.2 ⟩ ⟩),
      (λ h => match h with
      | ⟨ y₁, ⟨ ⟨ y₂, ⟨ y₂In, (h₁ : y₁ = g' • y₂) ⟩ ⟩, (h₂ : a = g • y₁) ⟩ ⟩ =>
        ⟨ y₂, ⟨ y₂In, by simp only []; exact (action.compat _ _ _).symm ▸ h₁ ▸ h₂ ⟩ ⟩) ⟩

end

section

variable (Y : Set X) (stable : isStable elaw Y)

def restr : G → Y → Y := λ g y => ⟨ g • y.1, stable y.1 y.2 g ⟩

instance restrAction : Action G law (restr elaw Y stable) where
  identity' := by
    intro y
    apply Subtype.eq
    simp [restr, id', show elaw one y = y from action.identity y]
  compat := by
    intro g g' y
    apply Subtype.eq
    simp [restr, id',
      show elaw (law g g') y = elaw g (elaw g' y) from action.compat _ _ _]

end

section

variable (x₀ : X)

def onOrbit : G → orbit elaw x₀ → orbit elaw x₀ :=
  restr elaw (orbit elaw x₀) (orbitIsStable law elaw x₀)

instance onOrbitTransitive : Transitive (onOrbit law elaw x₀) where
  singleOrbit := by
    intro ⟨ x, xIn ⟩ ⟨ y, yIn ⟩
    match xIn, yIn with
    | ⟨ g₁, xIs ⟩, ⟨ g₂, yIs ⟩ =>
      suffices p₂ : y = (g₂ * g₁⁻¹) • x
      from ⟨ (g₂ * g₁⁻¹), Subtype.eq p₂ ⟩
      simp [xIs, yIs, action.reverseCompat]

end

section

def leftTranslation : G → G → G := λ g g' => g * g'

instance leftTranslationAction (g : G) : Action G law (leftTranslation law) where
  identity' := λ x => by
    simp [id', leftTranslation]
    exact @oneNeutralLeft G law _ _
  compat := λ g g' g'' => by
    simp [id', leftTranslation]
    exact @assoc G law _ _ _ _

def conjugation : G → G → G := λ g g' => g * g' * g⁻¹

instance conjugationAction (g : G) : Action G law (conjugation law) where
  identity' := λ x => by
    suffices one * x * one⁻¹ = x by exact this
    simp
  compat := λ g g' x => by
    suffices ((g * g') * x * (g * g')⁻¹ = g * (g' * x * g'⁻¹) * g⁻¹) by exact this
    simp

end

end Remarkable

end Action

end Group


import tactic.rcases

/-
The problem is originally presented in:
A. Pease, G. Sutcliffe, N. Siegel, and S. Trac, “Large Theory
Reasoning with SUMO at CASC,” pp. 1–8, Jul. 2009.
Here we present the natural deduction proof in Lean.

adapted https://gist.github.com/digama0/16c62d1af34212de2e3fba380d87c043#file-common-sense-lean-lean-L170
-/

constant U : Type

constants SetOrClass Set Class Object Entity NullList_m List
          CorpuscularObject Invertebrate Vertebrate Animal SpinalColumn
          Organism Agent Physical Abstract
          subclass_m TransitiveRelation PartialOrderingRelation Relation : U
constant BananaSlug10 : U

@[class] constants exhaustiveDecomposition3 disjointDecomposition3 partition3 : U → U → U → Prop
@[class] constant ins : U → U → Prop
@[class] constant subclass : U → U → Prop
@[class] constant disjoint : U → U → Prop
@[class] constant component : U → U → Prop
@[class] constant part : U → U → Prop
@[class] constant inList : U → U → Prop
@[class] constant ConsFn : U → U → U
@[class] constant ListFn1 : U → U
@[class] constant ListFn2 : U → U → U
@[class] constant ListFn3 : U → U → U → U

@[class] noncomputable def subclass1 := subclass
@[instance] def subclass1_single (x y : U) [subclass1 x y] : subclass x y := by assumption

/- SUMO axioms -/

@[instance] axiom a13 : ins subclass_m PartialOrderingRelation

@[instance] axiom a15 (x y z : U) [ins x SetOrClass] [ins y SetOrClass]
  [ins z x] [subclass1 x y] : ins z y

/- EDITED (see https://github.com/own-pt/cl-krr/issues/23) -/
axiom a72773 (a : U) [ins a Animal] : (¬ ∃ p : U, ins p SpinalColumn ∧ part p a)
  → ¬ ins a Vertebrate

/- EDITED -/
axiom a72774 : ¬ ∃ s : U, ins s SpinalColumn ∧ part s BananaSlug10

axiom a72761 (x row0 row1 : U) [ins row0 Entity] [ins row1 Entity] [ins x Entity] :
 (ListFn3 x row0 row1 = ConsFn x (ListFn2 row0 row1))

axiom a72767 (x y : U) [ins x Entity] [ins y Entity] :
 ((ListFn2 x y) = (ConsFn x (ConsFn y NullList_m)))

axiom a72768 (x : U) [ins x Entity] : (ListFn1 x = ConsFn x NullList_m)

axiom a72769 (x : U) [ins x Entity] : ¬ inList x NullList_m

axiom a72770 (L x y : U) [ins x Entity] [ins y Entity] [ins L List] :
 ((inList x (ConsFn y L)) ↔ ((x = y) ∨ inList x L))

@[instance] axiom a67959 : ins NullList_m List

@[instance] axiom a67958 : ins List SetOrClass
@[instance] axiom a72772 : ins BananaSlug10 Animal
@[instance] axiom a72771 : ins Animal SetOrClass
@[instance] axiom a72778 : ins Invertebrate SetOrClass
@[instance] axiom a71402 : ins Vertebrate SetOrClass
@[instance] axiom a71371 : ins Organism SetOrClass
@[instance] axiom a71872 : ins Agent SetOrClass
@[instance] axiom a71669 : ins Object SetOrClass
@[instance] axiom a69763 : ins Physical SetOrClass
@[instance] axiom a67331 : ins Entity SetOrClass
@[instance] axiom a67448 : ins SetOrClass SetOrClass
@[instance] axiom a68771 : ins Abstract SetOrClass
@[instance] axiom a68763 : ins Relation SetOrClass
@[instance] axiom a71844 : ins TransitiveRelation SetOrClass
@[instance] axiom a72180 : ins PartialOrderingRelation SetOrClass

@[instance] axiom a71370 : partition3 Animal Vertebrate Invertebrate

axiom a67131 {c row0 row1 : U} [ins c Class] [ins row0 Class] [ins row1 Class] :
 (partition3 c row0 row1 ↔ (exhaustiveDecomposition3 c row0 row1 ∧ disjointDecomposition3 c row0 row1))

-- EDITED (see https://github.com/own-pt/cl-krr/issues/22)
axiom a67115 :
  ∀ (row0 row1 c obj : U),
    ∃ (item : U),
      ins item SetOrClass ∧
        (ins obj Entity →
          ins c SetOrClass → ins c Class →
          ins row0 Class → ins row0 Entity →
          ins row1 Class → ins row1 Entity →
            exhaustiveDecomposition3 c row0 row1 → ins obj c →
              inList item (ListFn2 row0 row1) ∧ ins obj item)

@[instance] axiom a67447 : partition3 SetOrClass Set Class
axiom a67172 : ∃ x : U, ins x Entity
axiom a67173 : ∀ {c : U}, ins c Class ↔ subclass c Entity

@[instance] axiom a67818 : subclass1 PartialOrderingRelation TransitiveRelation

@[instance] axiom a67809 (x y z : U) [ins x SetOrClass] [ins y SetOrClass] [ins z SetOrClass]
  [ins subclass_m TransitiveRelation] [subclass x y] [subclass1 y z] : subclass x z

@[instance] axiom a71382 : subclass1 Vertebrate Animal
@[instance] axiom a71383 : subclass1 Invertebrate Animal
@[instance] axiom a71369 : subclass1 Animal Organism
@[instance] axiom a71340 : subclass1 Organism Agent
@[instance] axiom a67315 : subclass1 Agent Object
@[instance] axiom a67177 : subclass1 Object Physical
@[instance] axiom a67174 : subclass1 Physical Entity
@[instance] axiom a67446 : subclass1 SetOrClass Abstract
@[instance] axiom a67332 : subclass1 Abstract Entity
@[instance] axiom a67954 : subclass1 List Relation
@[instance] axiom a67450 : subclass1 Relation Abstract

-- commented in list.kif
@[instance] axiom novo1 (x L : U) [ins L Entity] [ins L List] : ins (ConsFn x L) List

-- some initial tests

lemma VertebrateAnimal (x : U) [ins x Vertebrate] : ins x Animal := by apply_instance
lemma subclass_TransitiveRelation : ins subclass_m TransitiveRelation := by apply_instance
lemma VertebrateOrganism (x : U) [ins x Vertebrate] : ins x Organism := by apply_instance
lemma VertebrateEntity (x : U) [ins x Vertebrate] : ins x Entity := by apply_instance

lemma listLemma [hne : nonempty U] {x y z : U} [ins x Entity] [ins y Entity] [ins z Entity] :
  inList x (ListFn2 y z) → x = y ∨ x = z :=
begin
  intros h1,
  rw a72767 at h1,
  have h2 : x = y ∨ inList x (ConsFn z NullList_m), {rwa ← a72770},
  cases h2,
  { exact or.inl h2 },
  { have h3 : x = z ∨ inList x NullList_m, {rwa ← a72770},
    cases h3,
    { exact or.inr h3 },
    { exfalso,
      exact a72769 x h3 } }
end

lemma lX [hne : nonempty U] {x c c1 c2}
  [ins c SetOrClass] [ins c1 SetOrClass] [ins c2 SetOrClass]
  [ins c Class] [ins c1 Class] [ins c2 Class] [ins x Entity] :
  partition3 c c1 c2 → ins x c → ¬ ins x c1 → ins x c2 :=
begin
  intros h1 h2 h3,
  obtain ⟨h4a, h4b⟩ := a67131.1 h1,
  obtain ⟨b, h7, h8⟩ := a67115 _ _ _ _, resetI,
  cases h8 _ _ _ _ _ _ _ h4a h2 with h8a h8b; try {apply_instance},
  obtain rfl | rfl := listLemma h8a,
  {contradiction}, {assumption}
end

set_option class.instance_max_depth 200
set_option trace.class_instances true

lemma subclass_animal_entity : subclass Animal Entity := by apply_instance
lemma subclass_vertebrate_entity : subclass Vertebrate Entity := by apply_instance
lemma subclass_invertebrate_entity : subclass Invertebrate Entity := by apply_instance

lemma ins_banana_entity : ins BananaSlug10 Entity := by apply_instance
lemma ins_animal_class : ins Animal Class := a67173.2 $ by apply_instance

lemma l0  [nonempty U] : ¬(ins BananaSlug10 Vertebrate) := a72773 _ a72774

instance Vertebrate_class : ins Vertebrate Class := a67173.2 $ by apply_instance
instance Invertebrate_class : ins Invertebrate Class := a67173.2 $ by apply_instance
instance Animal_class : ins Animal Class := a67173.2 $ by apply_instance

theorem Banana_Invertebrate [nonempty U] : ins BananaSlug10 Invertebrate :=
 by apply lX a71370 _ l0; apply_instance

example (X Y C : U) [h : partition3 C X Y] : subclass X C ∧ subclass Y C := sorry -- not provable

example (h : ins SetOrClass SetOrClass) : false := sorry -- not provable