import SciLean.Data.DataArray.PlainDataType
import SciLean.Data.ArrayType

namespace SciLean

-- TODO: Quotient it out by trailing bits
structure DataArray (α : Type) [pd : PlainDataType α] where
  byteData : ByteArray
  size : Nat
  h_size : pd.bytes size ≤ byteData.size

variable {α : Type} [pd : PlainDataType α]
variable {ι} [Enumtype ι]

def DataArray.get (arr : DataArray α) (i : Fin arr.size) : α := -- pd.get a.data i sorry_proof
  match pd.btype with
  | .inl bitType =>
    let perByte := 8/bitType.bits
    let inByte  := (i.1 % perByte.toNat).toUInt8
    let ofByte  : Fin arr.byteData.size := ⟨i.1 / perByte.toNat, sorry_proof⟩
    let ones : UInt8 := 255
    let mask    := (ones - (ones <<< bitType.bits))   -- 00000111
    -- masking is note necessary if `fromBytes` correctly ignores unused bits
    let byte    := mask &&& (arr.byteData[ofByte] >>> (inByte*bitType.bits))
    bitType.fromByte byte
  | .inr byteType =>
    byteType.fromByteArray arr.byteData (byteType.bytes * i.1) sorry_proof

def DataArray.set (arr : DataArray α) (i : Fin arr.size) (val : α) : DataArray α := -- ⟨pd.set a.byteData i sorry_proof val, a.size, sorry_proof⟩
  match pd.btype with
  | .inl bitType =>
    let perByte := 8/bitType.bits
    let inByte  := (i.1 % perByte.toNat).toUInt8
    let ofByte  := ⟨i.1 / perByte.toNat, sorry_proof⟩
    let ones : UInt8 := 255
    let mask    := ones - ((ones - (ones <<< bitType.bits)) <<< (inByte*bitType.bits))  --- 11000111 for bitType.bits = 3 and inByte = 1
    let byte    := arr.byteData[ofByte]
    let newByte := (mask &&& byte) + (bitType.toByte val <<< (inByte*bitType.bits))
    ⟨arr.byteData.set ofByte newByte, arr.size, sorry_proof⟩
  | .inr byteType =>
    ⟨byteType.toByteArray arr.byteData (byteType.bytes * i.1) sorry_proof val, arr.size, sorry_proof⟩

/-- Capacity of an array. The return type is `Squash Nat` as the capacity is is just an implementation detail and should not affect semantics of the program. -/
def DataArray.capacity (arr : DataArray α) : Squash Nat := Quot.mk _ (pd.capacity (arr.byteData.size))
/-- Makes sure that `arr` fits at least `n` elements of `α` -/
def DataArray.reserve  (arr : DataArray α) (n : Nat) : DataArray α :=
  if (pd.capacity (arr.byteData.size)) ≤ n then
    arr
  else Id.run do
    let newBytes := pd.bytes n
    let mut arr' : DataArray α := ⟨ByteArray.mkEmpty newBytes, arr.size, sorry_proof⟩
    -- copy over the old data
    for i in [0:arr.size] do
      arr' := ⟨arr'.byteData.push 0, arr.size, sorry_proof⟩
      arr' := arr'.set ⟨i,sorry_proof⟩ (arr.get ⟨i,sorry_proof⟩)
    arr'

def DataArray.drop (arr : DataArray α) (k : Nat) : DataArray α := ⟨arr.byteData, arr.size - k, sorry_proof⟩

def DataArray.push (arr : DataArray α) (k : Nat := 1) (val : α) : DataArray α := Id.run do
  let oldSize := arr.size
  let newSize := arr.size + k
  let mut arr' := arr.reserve newSize
  arr' := ⟨arr'.byteData, newSize, sorry_proof⟩
  for i in [oldSize:newSize] do
    arr' := arr'.set ⟨i,sorry_proof⟩ val
  arr'

/-- Extensionality of DataArray

Currently this is inconsistent, we need to turn DataArray into quotient!
-/
theorem DataArray.ext (d d' : DataArray α) : (h : d.size = d'.size) → (∀ i, d.get i = d'.get (h ▸ i)) → d = d' := sorry_proof

def DataArray.intro (f : ι → α) : DataArray α := Id.run do
  let bytes := (pd.bytes (numOf ι))
  let mut d : ByteArray := ByteArray.mkEmpty bytes
  for _ in [0:bytes] do
    d := d.push 0
  let mut d' : DataArray α := ⟨d, (numOf ι), sorry_proof⟩
  for (i,li) in Enumtype.fullRange ι do
    d' := d'.set ⟨li,sorry_proof⟩ (f i)
  d'

structure DataArrayN (α : Type) [pd : PlainDataType α] (n : Nat) where
  data : DataArray α
  h_size : n = data.size

instance (n) : GetElem (DataArrayN α n) (Fin n) α (λ _ _ => True) where
  getElem xs i _ := xs.1.get (xs.2 ▸ i)

instance : GetElem (DataArrayN α (numOf ι)) ι α (λ _ _ => True) where
  getElem xs i _ := xs.1.get (xs.2 ▸ toFin i)

instance : SetElem (DataArrayN α n) (Fin n) α where
  setElem xs i xi := ⟨xs.1.set (xs.2 ▸ i) xi, sorry_proof⟩

instance : SetElem (DataArrayN α (numOf ι)) ι α where
  setElem xs i xi := ⟨xs.1.set (xs.2 ▸ toFin i) xi, sorry_proof⟩

instance : IntroElem (DataArrayN α n) (Fin n) α where
  introElem f := ⟨DataArray.intro f, sorry_proof⟩

instance : IntroElem (DataArrayN α (numOf ι)) ι α where
  introElem f := ⟨DataArray.intro f, sorry_proof⟩

instance : PushElem (DataArrayN α) α where
  pushElem k val xs := ⟨xs.1.push k val, sorry_proof⟩

instance : DropElem (DataArrayN α) α where
  dropElem k xs := ⟨xs.1.drop k, sorry_proof⟩

instance : ReserveElem (DataArrayN α) α where
  reserveElem k xs := ⟨xs.1.reserve k, sorry_proof⟩

instance : ArrayType (DataArrayN α n) (Fin n) α  where
  ext := sorry_proof
  getElem_setElem_eq := sorry_proof
  getElem_setElem_neq := sorry_proof
  getElem_introElem := sorry_proof

instance : LinearArrayType (DataArrayN α) α  where
  toArrayType := by infer_instance
  pushElem_getElem := sorry_proof
  dropElem_getElem := sorry_proof
  reserveElem_id := sorry_proof

instance : ArrayType (DataArrayN α (numOf ι)) ι α  where
  ext := sorry_proof
  getElem_setElem_eq := sorry_proof
  getElem_setElem_neq := sorry_proof
  getElem_introElem := sorry_proof

@[infer_tc_goals_rl]
instance {Cont ι α : Type} [Enumtype ι] [Inhabited α] [pd : PlainDataType α] [ArrayType Cont ι α] : PlainDataType Cont where
  btype := match pd.btype with
    | .inl αBitType =>
      -- TODO: Fixme !!!!
      .inr {
        bytes := 2
        h_size := sorry_proof

        fromByteArray := λ b i h =>
          introElem (λ j => default)
        toByteArray   := λ b i h c => b
        toByteArray_size := sorry_proof
        fromByteArray_toByteArray := sorry_proof
        fromByteArray_toByteArray_other := sorry_proof
      }
    | .inr αByteType =>
      .inr {
        bytes := (numOf ι) * αByteType.bytes
        h_size := sorry_proof

        fromByteArray := λ b i h =>
          introElem (λ j =>
            let idx := (i + (toFin j).1*αByteType.bytes)
            αByteType.fromByteArray b idx sorry_proof)
        toByteArray   := λ b i h c => Id.run do
          let mut b := b
          for (j,lj) in Enumtype.fullRange ι do
            let idx := (i + lj.1*αByteType.bytes)
            b := αByteType.toByteArray b idx sorry_proof c[j]
          b

        toByteArray_size := sorry_proof
        fromByteArray_toByteArray := sorry_proof
        fromByteArray_toByteArray_other := sorry_proof
      }

  -- bytes : Nat
  -- h_size : 1 < bytes  -- for one byte types use BitInfo
  -- fromByteArray (b : ByteArray) (i : Nat) (h : i+bytes ≤ b.size) : α
  -- toByteArray   (b : ByteArray) (i : Nat) (h : i+bytes ≤ b.size) (a : α) : ByteArray

  -- -- `toByteArray` does not modify ByteArray size
  -- toByteArray_size : ∀ b i h a, (toByteArray b i h a).size = b.size
  -- -- we can recover `a` from bytes
  -- fromByteArray_toByteArray : ∀ a b i h h', fromByteArray (toByteArray b i h a) i h' = a
  -- -- `toByteArray` does not affect other bytes
  -- fromByteArray_toByteArray_other : ∀ a b i j h, (j < i) ∨ (i+size) ≤ j → (toByteArray b i h a).get! j = b.get! j

-- ShortOptDataArray is prefered for PowType
-- @[defaultInstance]
-- instance : PowType (DataArrayN α (numOf ι)) ι α := PowType.mk

-- ShortOptDataArray is prefered for PowType
-- @[defaultInstance]
-- instance : LinearPowType (DataArrayN α) α := LinearPowType.mk

-- #check ℝ^(Fin 3)

-- #eval ((λ [i] => i.1.toReal ) : ℝ^(Fin 100)) |>.map Math.sqrt

-- #eval ((λ [i] => i) : (Fin 3 × Fin 5)^(Fin 3 × Fin 5))
-- #eval ((λ [i] => i) : (Fin 3 × Fin 5)^(Fin 3 × Fin 5)).data
-- #eval ((λ [i] => i) : (Fin 3 × Fin 5)^(Fin 3 × Fin 5)).data.byteData

-- #eval (1,2,3,4)

-- #eval ((λ [i] => i) : (Fin 3 × Fin 2 × Fin 2)^(Fin 3 × Fin 2 × Fin 2))
-- #eval ((λ [i] => i) : (Fin 3 × Fin 2 × Fin 2)^(Fin 3 × Fin 2 × Fin 2)).data
-- #eval ((λ [i] => i) : (Fin 3 × Fin 2 × Fin 2)^(Fin 3 × Fin 2 × Fin 2)).data.byteData

-- #eval ((λ [i] => (i.1.toFloat, i.1.toFloat.sqrt)) : (Float × Float)^(Fin 17))

-- variable (x : ℝ^{n,m})

-- #check x
-- #check λ (i,j) => x[i,j]
-- #check ∑ i, x[i]

-- #check Id.run do
--   let mut a : ℝ^{10} := λ [i] => i.1
--   for (i,_) in Enumtype.fullRange a.Index do
--     a[i] *= 1000
--     a[i] += Math.sqrt i.1 + a[i]
--   a

-- #eval Id.run do
--   let mut a : (ℝ×ℝ)^{3,3} := λ [i,j] => (i.1,j.1)
--   for (i,li) in Enumtype.fullRange a.Index do
--     a[li] := (Math.sqrt a[li].1, Math.exp a[li].2)
--   a

-- #eval Id.run do
--   let mut a : ℝ^(Fin 3 × Fin 3) := 0
--   for ((i,j),li) in Enumtype.fullRange a.Index do
--     a[li] := if i = j then 1 else 0
--   a


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

import Dijkstra.Init
import Dijkstra.Control.Lawful
import Dijkstra.Control.Monad.Rel

/-!

# Dijkstra monads

A ***Dijkstra monad*** is a dependent analogue of a monad which is parametrized by a specific monad, called the *underlying monad*, so that the operations `pure` and `bind` are defined along with those on the underlying monad.
More precisely, given monad `W : Type u → Type v`, a type-family `M : (α : Type u) → W α → Type v` is a Dijkstra monad if it is equipped with the following two operations:

```lean
dpure {α : Type u} (a : α) :  M (pure a)
dbind {α β : Type u} {wa : W α} {wf : α → W β} : M α wa → ((a : α) → M β (wf a)) → M β (wa >>= wf)
```

In addition, these operations are supposed to satisfy dependent analogues of the ordinary monad relations.
There is, however, a problem to write down such conditions.
For example, one would expect that the left unitality of `dbind` can be written to be of the type `dbind (dpure a) f = f a`, thouth it is not type-correct.
Indeed, for `a : α`, `wb : W β`, and `f : α → M β wb`, we have

```lean
#check dbind (dpure a) f -- M β (pure a >>= λ _ => wb)
#check f a               -- M β wb
```

and it turns out that the dependent parameters are not definitionally equal (even if one has `[LawfulMonad W]`).
This is why we need `DEq` a dependent analogue of `Eq` for type families; see [Init.lean](Dijkstra/Init.lean).

-/

universe u v w

/-- The main structures of Dijkstra monads. -/
class DijkstraMonad (W : Type u → Type v) [Monad W] (M : (α : Type u) → W α → Type w) where
  dpure {α : Type u} (a : α) : M α (return a)
  dbind {α β : Type u} {wa : W α} {wf : α → W β} : M α wa → ((a : α) → M β (wf a)) → M β (wa >>= wf)

export DijkstraMonad (dpure dbind)

/-- The dependent monad laws for Dijkstra monads. -/
class DijkstraMonad.Lawful (W : Type u → Type v) [Monad W] (M : (α : Type u) → W α → Type w) [DijkstraMonad W M] where
  --- right unitality
  dbind_dpure {α : Type u} {wa : W α} {x : M α wa} : DEq (M α) (dbind x dpure) x
  --- left unitality
  dpure_dbind {α β : Type u} {wf : α → W β} (a : α) (f : (a : α) → M β (wf a)) : DEq (M β) (dbind (dpure a) f) (f a)
  --- associativity
  dbind_assoc {α β γ : Type u} {wa : W α} {wf : α → W β} {wg : β → W γ} (x : M α wa) (f : (a : α) → M β (wf a)) (g : (b : β) → M γ (wg b)) : DEq (M γ) (dbind (dbind x f) g) (dbind x (λ a => dbind (f a) g))

namespace DijkstraMonad

/-!

## Basic lemmas

-/

theorem dbind_congr {W : Type u → Type v} [Monad W] {M : (α : Type u) → W α → Type w} [DijkstraMonad W M] {α β : Type u} : ∀ {wa₁ wa₂ : W α} {wf₁ wf₂ : α → W β} {x₁ : M α wa₁} {x₂ : M α wa₂} {f₁ : (a : α) → M β (wf₁ a)} {f₂ : (a : α) → M β (wf₂ a)}, DEq (M α) x₁ x₂ → (∀ a, DEq (M β) (f₁ a) (f₂ a)) → DEq (M β) (dbind x₁ f₁) (dbind x₂ f₂)
| _, _, wf₁, wf₂, _, _, f₁, f₂, DEq.refl _, hf => by
  have : wf₁ = wf₂ := by
    funext a
    exact (hf a).eq_param
  cases this
  have : f₁ = f₂ := by
    funext a
    exact (hf a).eq_of_deq
  cases this
  exact DEq.refl _

theorem dbind_congrRight {W : Type u → Type v} [Monad W] {M : (α : Type u) → W α → Type w} [DijkstraMonad W M] {α β : Type u} : ∀ {wa : W α} {wf₁ wf₂ : α → W β} {x : M α wa} {f₁ : (a : α) → M β (wf₁ a)} {f₂ : (a : α) → M β (wf₂ a)}, (∀ a, DEq (M β) (f₁ a) (f₂ a)) → DEq (M β) (dbind x f₁) (dbind x f₂) :=
  dbind_congr (DEq.refl _)

theorem dbind_congrLeft {W : Type u → Type v} [Monad W] {M : (α : Type u) → W α → Type w} [DijkstraMonad W M] {α β : Type u} : ∀ {wa₁ wa₂ : W α} {wf : α → W β} {x₁ : M α wa₁} {x₂ : M α wa₂} {f : (a : α) → M β (wf a)}, DEq (M α) x₁ x₂ → DEq (M β) (dbind x₁ f) (dbind x₂ f) :=
  λ h => dbind_congr h (λ _ => DEq.refl _)

/-!

## Change of underlying monads

As is the case for parametrized type families, one can translate Dijkstra monads into other along monad homomorphisms on underlying monads.
In particular, given a monad homomorphism `F : MonadHom W₁ W₂`, we define the "push-forward" `DijkstraMonad W₁ M → DijkstraMonad W₂ (Push F M)` and the "pull-back" `DijkstraMonad W₂ M → DijkstraMonad W₁ (Pull F M)`.

-/

section underlying

universe v₁ v₂

variable {W₁ : Type u → Type v₁} [Monad W₁] {W₂ : Type u → Type v₂} [Monad W₂]

/-- Pushforward of Dijkstra monads along a monad homomorphism. -/
structure Push (F : MonadHom W₁ W₂) (M : (α : Type u) → W₁ α → Type w) (α : Type u) (wa₂ : W₂ α) : Type (max v₁ w) where
  base : W₁ α
  body : M α base
  underly : F.app base = wa₂

namespace Push

variable {F : MonadHom W₁ W₂} {M : (α : Type u) → W₁ α → Type w}

protected
theorem eq {α : Type u} {wa₂ : W₂ α} : ∀ {x y : Push F M α wa₂}, x.base = y.base → DEq (M α) x.body y.body → x = y
| mk _ _ _, mk _ _ _, rfl, DEq.refl _ => rfl

protected
theorem deq {α : Type u} {wa₂ wa₂': W₂ α} : ∀ {x : Push F M α wa₂} {y : Push F M α wa₂'}, x.base = y.base → DEq (M α) x.body y.body → DEq (Push F M α) x y
| mk base _ hx, mk _ _ hy, rfl, DEq.refl _ => by
  cases (Eq.trans hy.symm hx)
  exact DEq.refl _

instance instDijkstraMonadPush [DijkstraMonad W₁ M] : DijkstraMonad W₂ (Push F M) where
  dpure a := {
    base := pure a
    body := dpure a
    underly := F.app_pure a
  }
  dbind x f := {
    base := x.base >>= (λ a => (f a).base)
    body := dbind x.body (λ a => (f a).body)
    underly := by
      rw [F.app_bind, x.underly]
      apply bind_congr
      intro a; dsimp
      exact (f a).underly
  }

instance instDijkstraMonadLawfulPush [LawfulMonad W₁] [DijkstraMonad W₁ M] [DijkstraMonad.Lawful W₁ M] : DijkstraMonad.Lawful W₂ (Push F M) where
  dbind_dpure := by
    intro α wa₂ x
    cases x with | mk x_base x_body hx =>
    apply Push.deq <;> dsimp [dbind, dpure]
    . rw [bind_pure];
    . exact DijkstraMonad.Lawful.dbind_dpure (M:=M)
  dpure_dbind := by
    intro α β wb₂ a f
    apply Push.deq <;> dsimp [dbind, dpure]
    . rw [pure_bind]
    . exact DijkstraMonad.Lawful.dpure_dbind (M:=M) _ _
  dbind_assoc := by
    intro α β γ wa₂ wf wg x f g
    apply Push.deq <;> dsimp [dbind, dpure]
    . rw [bind_assoc]
    . exact DijkstraMonad.Lawful.dbind_assoc (M:=M) _ _ _

end Push

/-- Pullback of Dijkstra monads along a monad homomorphisms. -/
def Pull (F : MonadHom W₁ W₂) (M : (α : Type u) → W₂ α → Type w) (α : Type u) (wa₁ : W₁ α) : Type w :=
  M α (F.app wa₁)

namespace Pull

variable {F : MonadHom W₁ W₂} {M : (α : Type u) → W₂ α → Type w}

instance instDijkstraMonadPull [DijkstraMonad W₂ M] : DijkstraMonad W₁ (Pull F M) where
  dpure {α} a := (F.app_pure a).symm.rec (motive:=λ wa _ => M α wa) (dpure a)
  dbind {_} {β} {wa} {wf} x f :=
    (F.app_bind wa wf).symm.rec (motive:=λ wb _=> M β wb) (dbind (M:=M) (wf:=λ a => F.app (wf a)) x f)

protected
theorem deq {α : Type u} : ∀ {w₁ w₁' : W₁ α} {x : Pull F M α w₁} {y : Pull F M α w₁'}, w₁ = w₁' → DEq (M α) x y → DEq (Pull F M α) x y
| _, _, _, _, rfl, DEq.refl _ => DEq.refl _

theorem dpure_deq [DijkstraMonad W₂ M] {α : Type u} (a : α) : DEq (β:=M α) (dpure (M:=Pull F M) a) (dpure (M:=M) a) :=
  DEq.subst_deq

theorem dbind_deq [DijkstraMonad W₂ M] {α β : Type u} {wa : W₁ α} {wf : α → W₁ β} (x : Pull F M α wa) (f : (a : α) → Pull F M β (wf a)) : DEq (β:=M β) (dbind (M:=Pull F M) x f) (dbind (M:=M) x f) :=
  DEq.subst_deq

instance instDijkstraMonadLawfulPull [LawfulMonad W₁] [DijkstraMonad W₂ M] [DijkstraMonad.Lawful W₂ M] : DijkstraMonad.Lawful W₁ (Pull F M) where
  dbind_dpure := by
    intro α wa₁ x
    apply Pull.deq (bind_pure _)
    apply DEq.trans (Pull.dbind_deq x dpure) _
    apply DEq.trans (dbind_congrRight (W:=W₂) (M:=M) Pull.dpure_deq) _
    exact Lawful.dbind_dpure (M:=M)
  dpure_dbind := by
    intro α β wf a f
    apply Pull.deq (pure_bind _ _)
    apply DEq.trans (Pull.dbind_deq (dpure a) f) _
    apply DEq.trans (dbind_congrLeft (W:=W₂) (M:=M) (Pull.dpure_deq a))
    exact Lawful.dpure_dbind (M:=M) a f
  dbind_assoc := by
    intro α β γ wa wf wg x f g
    apply Pull.deq (bind_assoc _ _ _)
    apply DEq.trans (Pull.dbind_deq _ _)
    apply DEq.trans (dbind_congrLeft (W:=W₂) (M:=M) (Pull.dbind_deq _ _))
    apply DEq.trans (Lawful.dbind_assoc (M:=M) _ _ _)
    apply DEq.trans _ (Pull.dbind_deq x (λ a => dbind (f a) g)).symm
    apply dbind_congrRight
    intro a
    exact (Pull.dbind_deq _ _).symm

end Pull

end underlying

/-!

## Dijkstra monads from monadic relations

Given a monadic relation `r : MonadRel m n` for monads `m : Type u → Type v` and `n : Type u → Type w`, the associated submonad of `m × n` can be seen as a Dijkstra monad.
Although its underlying monad is a priori the product `m × n`, we define it as a Dijkstra monad over the second monad `n`.
In fact, the latter is obtained from the former by applying `Push` along the second projection.
It however turns out that our direct definition has more straightforward description.

-/

def Graph {m : Type u → Type v} [Monad m] {W : Type u → Type w} [Monad W] (r : MonadRel m W) (α : Type u) (wa : W α) : Type v :=
  {x : m α // r.rel x wa}

namespace Graph

variable {m : Type u → Type v} [Monad m] {W : Type u → Type v} [Monad W] {r : MonadRel m W}

protected
theorem deq {α : Type u} {wa₁ wa₂ : W α} : ∀ (x₁ : Graph r α wa₁) (x₂ : Graph r α wa₂), wa₁ = wa₂ → x₁.val = x₂.val → DEq (Graph r α) x₁ x₂
| Subtype.mk _ _, Subtype.mk _ _, rfl, rfl => DEq.refl _

instance instDijkstraMonadGraph : DijkstraMonad W (Graph r) where
  dpure a := Subtype.mk (pure a) (r.pure a)
  dbind x f := Subtype.mk (x.val >>= (λ a => (f a).val)) $ r.bind x.property (λ a => (f a).property)

instance instDijkstraMonadLawfulGraph [LawfulMonad m] [LawfulMonad W] : DijkstraMonad.Lawful W (Graph r) where
  dbind_dpure := by
    intro α wa x
    exact Graph.deq _ _ (bind_pure wa) (bind_pure x.val)
  dpure_dbind := by
    intro α β wf a f
    exact Graph.deq _ _ (pure_bind a wf) (pure_bind a (λ a => (f a).val))
  dbind_assoc := by
    intro α β γ wa wf wg x f g
    apply Graph.deq _ _ (bind_assoc wa wf wg)
    dsimp [dbind]; rw [bind_assoc]

end Graph

end DijkstraMonad


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

! This file was ported from Lean 3 source module category_theory.limits.constructions.over.connected
! leanprover-community/mathlib commit 10bf4f825ad729c5653adc039dafa3622e7f93c9
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Limits.Creates
import Mathbin.CategoryTheory.Over
import Mathbin.CategoryTheory.IsConnected

/-!
# Connected limits in the over category

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

Shows that the forgetful functor `over B ⥤ C` creates connected limits, in particular `over B` has
any connected limit which `C` has.
-/

universe v u

-- morphism levels before object levels. See note [category_theory universes].
noncomputable section

open CategoryTheory CategoryTheory.Limits

variable {J : Type v} [SmallCategory J]

variable {C : Type u} [Category.{v} C]

variable {X : C}

namespace CategoryTheory.Over

namespace CreatesConnected

/- warning: category_theory.over.creates_connected.nat_trans_in_over -> CategoryTheory.Over.CreatesConnected.natTransInOver is a dubious translation:
lean 3 declaration is
  forall {J : Type.{u1}} [_inst_1 : CategoryTheory.SmallCategory.{u1} J] {C : Type.{u2}} [_inst_2 : CategoryTheory.Category.{u1, u2} C] {B : C} (F : CategoryTheory.Functor.{u1, u1, u1, max u2 u1} J _inst_1 (CategoryTheory.Over.{u1, u2} C _inst_2 B) (CategoryTheory.Over.category.{u2, u1} C _inst_2 B)), Quiver.Hom.{succ u1, max u1 u2} (CategoryTheory.Functor.{u1, u1, u1, u2} J _inst_1 C _inst_2) (CategoryTheory.CategoryStruct.toQuiver.{u1, max u1 u2} (CategoryTheory.Functor.{u1, u1, u1, u2} J _inst_1 C _inst_2) (CategoryTheory.Category.toCategoryStruct.{u1, max u1 u2} (CategoryTheory.Functor.{u1, u1, u1, u2} J _inst_1 C _inst_2) (CategoryTheory.Functor.category.{u1, u1, u1, u2} J _inst_1 C _inst_2))) (CategoryTheory.Functor.comp.{u1, u1, u1, u1, max u2 u1, u2} J _inst_1 (CategoryTheory.Over.{u1, u2} C _inst_2 B) (CategoryTheory.Over.category.{u2, u1} C _inst_2 B) C _inst_2 F (CategoryTheory.Over.forget.{u1, u2} C _inst_2 B)) (CategoryTheory.Functor.obj.{u1, u1, u2, max u1 u2} C _inst_2 (CategoryTheory.Functor.{u1, u1, u1, u2} J _inst_1 C _inst_2) (CategoryTheory.Functor.category.{u1, u1, u1, u2} J _inst_1 C _inst_2) (CategoryTheory.Functor.const.{u1, u1, u1, u2} J _inst_1 C _inst_2) B)
but is expected to have type
  forall {J : Type.{u1}} [_inst_1 : CategoryTheory.SmallCategory.{u1} J] {C : Type.{u2}} [_inst_2 : CategoryTheory.Category.{u1, u2} C] {B : C} (F : CategoryTheory.Functor.{u1, u1, u1, max u2 u1} J _inst_1 (CategoryTheory.Over.{u1, u2} C _inst_2 B) (CategoryTheory.instCategoryOver.{u1, u2} C _inst_2 B)), Quiver.Hom.{succ u1, max u2 u1} (CategoryTheory.Functor.{u1, u1, u1, u2} J _inst_1 C _inst_2) (CategoryTheory.CategoryStruct.toQuiver.{u1, max u2 u1} (CategoryTheory.Functor.{u1, u1, u1, u2} J _inst_1 C _inst_2) (CategoryTheory.Category.toCategoryStruct.{u1, max u2 u1} (CategoryTheory.Functor.{u1, u1, u1, u2} J _inst_1 C _inst_2) (CategoryTheory.Functor.category.{u1, u1, u1, u2} J _inst_1 C _inst_2))) (CategoryTheory.Functor.comp.{u1, u1, u1, u1, max u2 u1, u2} J _inst_1 (CategoryTheory.Over.{u1, u2} C _inst_2 B) (CategoryTheory.instCategoryOver.{u1, u2} C _inst_2 B) C _inst_2 F (CategoryTheory.Over.forget.{u1, u2} C _inst_2 B)) (Prefunctor.obj.{succ u1, succ u1, u2, max u1 u2} C (CategoryTheory.CategoryStruct.toQuiver.{u1, u2} C (CategoryTheory.Category.toCategoryStruct.{u1, u2} C _inst_2)) (CategoryTheory.Functor.{u1, u1, u1, u2} J _inst_1 C _inst_2) (CategoryTheory.CategoryStruct.toQuiver.{u1, max u1 u2} (CategoryTheory.Functor.{u1, u1, u1, u2} J _inst_1 C _inst_2) (CategoryTheory.Category.toCategoryStruct.{u1, max u1 u2} (CategoryTheory.Functor.{u1, u1, u1, u2} J _inst_1 C _inst_2) (CategoryTheory.Functor.category.{u1, u1, u1, u2} J _inst_1 C _inst_2))) (CategoryTheory.Functor.toPrefunctor.{u1, u1, u2, max u1 u2} C _inst_2 (CategoryTheory.Functor.{u1, u1, u1, u2} J _inst_1 C _inst_2) (CategoryTheory.Functor.category.{u1, u1, u1, u2} J _inst_1 C _inst_2) (CategoryTheory.Functor.const.{u1, u1, u1, u2} J _inst_1 C _inst_2)) B)
Case conversion may be inaccurate. Consider using '#align category_theory.over.creates_connected.nat_trans_in_over CategoryTheory.Over.CreatesConnected.natTransInOverₓ'. -/
/-- (Impl) Given a diagram in the over category, produce a natural transformation from the
diagram legs to the specific object.
-/
def natTransInOver {B : C} (F : J ⥤ Over B) : F ⋙ forget B ⟶ (CategoryTheory.Functor.const J).obj B
    where app j := (F.obj j).Hom
#align category_theory.over.creates_connected.nat_trans_in_over CategoryTheory.Over.CreatesConnected.natTransInOver

attribute [local tidy] tactic.case_bash

#print CategoryTheory.Over.CreatesConnected.raiseCone /-
/-- (Impl) Given a cone in the base category, raise it to a cone in the over category. Note this is
where the connected assumption is used.
-/
@[simps]
def raiseCone [IsConnected J] {B : C} {F : J ⥤ Over B} (c : Cone (F ⋙ forget B)) : Cone F
    where
  pt := Over.mk (c.π.app (Classical.arbitrary J) ≫ (F.obj (Classical.arbitrary J)).Hom)
  π :=
    {
      app := fun j =>
        Over.homMk (c.π.app j) (nat_trans_from_is_connected (c.π ≫ natTransInOver F) j _) }
#align category_theory.over.creates_connected.raise_cone CategoryTheory.Over.CreatesConnected.raiseCone
-/

/- warning: category_theory.over.creates_connected.raised_cone_lowers_to_original -> CategoryTheory.Over.CreatesConnected.raised_cone_lowers_to_original is a dubious translation:
lean 3 declaration is
  forall {J : Type.{u1}} [_inst_1 : CategoryTheory.SmallCategory.{u1} J] {C : Type.{u2}} [_inst_2 : CategoryTheory.Category.{u1, u2} C] [_inst_3 : CategoryTheory.IsConnected.{u1, u1} J _inst_1] {B : C} {F : CategoryTheory.Functor.{u1, u1, u1, max u2 u1} J _inst_1 (CategoryTheory.Over.{u1, u2} C _inst_2 B) (CategoryTheory.Over.category.{u2, u1} C _inst_2 B)} (c : CategoryTheory.Limits.Cone.{u1, u1, u1, u2} J _inst_1 C _inst_2 (CategoryTheory.Functor.comp.{u1, u1, u1, u1, max u2 u1, u2} J _inst_1 (CategoryTheory.Over.{u1, u2} C _inst_2 B) (CategoryTheory.Over.category.{u2, u1} C _inst_2 B) C _inst_2 F (CategoryTheory.Over.forget.{u1, u2} C _inst_2 B))), (CategoryTheory.Limits.IsLimit.{u1, u1, u1, u2} J _inst_1 C _inst_2 (CategoryTheory.Functor.comp.{u1, u1, u1, u1, max u2 u1, u2} J _inst_1 (CategoryTheory.Over.{u1, u2} C _inst_2 B) (CategoryTheory.Over.category.{u2, u1} C _inst_2 B) C _inst_2 F (CategoryTheory.Over.forget.{u1, u2} C _inst_2 B)) c) -> (Eq.{max (succ u2) (succ u1)} (CategoryTheory.Limits.Cone.{u1, u1, u1, u2} J _inst_1 C _inst_2 (CategoryTheory.Functor.comp.{u1, u1, u1, u1, max u2 u1, u2} J _inst_1 (CategoryTheory.Over.{u1, u2} C _inst_2 B) (CategoryTheory.commaCategory.{u1, u1, u1, u2, u1, u2} C _inst_2 (CategoryTheory.Discrete.{u1} PUnit.{succ u1}) (CategoryTheory.discreteCategory.{u1} PUnit.{succ u1}) C _inst_2 (CategoryTheory.Functor.id.{u1, u2} C _inst_2) (CategoryTheory.Functor.fromPUnit.{u1, u2} C _inst_2 B)) C _inst_2 F (CategoryTheory.Over.forget.{u1, u2} C _inst_2 B))) (CategoryTheory.Functor.mapCone.{u1, u1, u1, u1, max u2 u1, u2} J _inst_1 (CategoryTheory.Over.{u1, u2} C _inst_2 B) (CategoryTheory.commaCategory.{u1, u1, u1, u2, u1, u2} C _inst_2 (CategoryTheory.Discrete.{u1} PUnit.{succ u1}) (CategoryTheory.discreteCategory.{u1} PUnit.{succ u1}) C _inst_2 (CategoryTheory.Functor.id.{u1, u2} C _inst_2) (CategoryTheory.Functor.fromPUnit.{u1, u2} C _inst_2 B)) C _inst_2 F (CategoryTheory.Over.forget.{u1, u2} C _inst_2 B) (CategoryTheory.Over.CreatesConnected.raiseCone.{u1, u2} J _inst_1 C _inst_2 _inst_3 B F c)) c)
but is expected to have type
  forall {J : Type.{u1}} [_inst_1 : CategoryTheory.SmallCategory.{u1} J] {C : Type.{u2}} [_inst_2 : CategoryTheory.Category.{u1, u2} C] [_inst_3 : CategoryTheory.IsConnected.{u1, u1} J _inst_1] {B : C} {F : CategoryTheory.Functor.{u1, u1, u1, max u2 u1} J _inst_1 (CategoryTheory.Over.{u1, u2} C _inst_2 B) (CategoryTheory.instCategoryOver.{u1, u2} C _inst_2 B)} (c : CategoryTheory.Limits.Cone.{u1, u1, u1, u2} J _inst_1 C _inst_2 (CategoryTheory.Functor.comp.{u1, u1, u1, u1, max u2 u1, u2} J _inst_1 (CategoryTheory.Over.{u1, u2} C _inst_2 B) (CategoryTheory.instCategoryOver.{u1, u2} C _inst_2 B) C _inst_2 F (CategoryTheory.Over.forget.{u1, u2} C _inst_2 B))), Eq.{max (succ u2) (succ u1)} (CategoryTheory.Limits.Cone.{u1, u1, u1, u2} J _inst_1 C _inst_2 (CategoryTheory.Functor.comp.{u1, u1, u1, u1, max u2 u1, u2} J _inst_1 (CategoryTheory.Over.{u1, u2} C _inst_2 B) (CategoryTheory.instCategoryOver.{u1, u2} C _inst_2 B) C _inst_2 F (CategoryTheory.Over.forget.{u1, u2} C _inst_2 B))) (CategoryTheory.Functor.mapCone.{u1, u1, u1, u1, max u2 u1, u2} J _inst_1 (CategoryTheory.Over.{u1, u2} C _inst_2 B) (CategoryTheory.instCategoryOver.{u1, u2} C _inst_2 B) C _inst_2 (CategoryTheory.Over.forget.{u1, u2} C _inst_2 B) F (CategoryTheory.Over.CreatesConnected.raiseCone.{u1, u2} J _inst_1 C _inst_2 _inst_3 B F c)) c
Case conversion may be inaccurate. Consider using '#align category_theory.over.creates_connected.raised_cone_lowers_to_original CategoryTheory.Over.CreatesConnected.raised_cone_lowers_to_originalₓ'. -/
theorem raised_cone_lowers_to_original [IsConnected J] {B : C} {F : J ⥤ Over B}
    (c : Cone (F ⋙ forget B)) (t : IsLimit c) : (forget B).mapCone (raiseCone c) = c := by tidy
#align category_theory.over.creates_connected.raised_cone_lowers_to_original CategoryTheory.Over.CreatesConnected.raised_cone_lowers_to_original

#print CategoryTheory.Over.CreatesConnected.raisedConeIsLimit /-
/-- (Impl) Show that the raised cone is a limit. -/
def raisedConeIsLimit [IsConnected J] {B : C} {F : J ⥤ Over B} {c : Cone (F ⋙ forget B)}
    (t : IsLimit c) : IsLimit (raiseCone c)
    where
  lift s :=
    Over.homMk (t.lift ((forget B).mapCone s))
      (by
        dsimp
        simp)
  uniq s m K := by
    ext1
    apply t.hom_ext
    intro j
    simp [← K j]
#align category_theory.over.creates_connected.raised_cone_is_limit CategoryTheory.Over.CreatesConnected.raisedConeIsLimit
-/

end CreatesConnected

#print CategoryTheory.Over.forgetCreatesConnectedLimits /-
/-- The forgetful functor from the over category creates any connected limit. -/
instance forgetCreatesConnectedLimits [IsConnected J] {B : C} : CreatesLimitsOfShape J (forget B)
    where CreatesLimit K :=
    createsLimitOfReflectsIso fun c t =>
      { liftedCone := CreatesConnected.raiseCone c
        validLift := eqToIso (CreatesConnected.raised_cone_lowers_to_original c t)
        makesLimit := CreatesConnected.raisedConeIsLimit t }
#align category_theory.over.forget_creates_connected_limits CategoryTheory.Over.forgetCreatesConnectedLimits
-/

#print CategoryTheory.Over.has_connected_limits /-
/-- The over category has any connected limit which the original category has. -/
instance has_connected_limits {B : C} [IsConnected J] [HasLimitsOfShape J C] :
    HasLimitsOfShape J (Over B) where HasLimit F := hasLimit_of_created F (forget B)
#align category_theory.over.has_connected_limits CategoryTheory.Over.has_connected_limits
-/

end CategoryTheory.Over


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Bhavik Mehta
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.const
import Mathlib.category_theory.discrete_category
import Mathlib.PostPort

universes v u u_1

namespace Mathlib

namespace category_theory

namespace functor

/-- The constant functor sending everything to `punit.star`. -/
def star (C : Type u) [category C] : C ⥤ discrete PUnit :=
  obj (const C) PUnit.unit

/-- Any two functors to `discrete punit` are isomorphic. -/
def punit_ext {C : Type u} [category C] (F : C ⥤ discrete PUnit) (G : C ⥤ discrete PUnit) : F ≅ G :=
  nat_iso.of_components (fun (_x : C) => eq_to_iso sorry) sorry

/--
Any two functors to `discrete punit` are *equal*.
You probably want to use `punit_ext` instead of this.
-/
theorem punit_ext' {C : Type u} [category C] (F : C ⥤ discrete PUnit) (G : C ⥤ discrete PUnit) : F = G :=
  ext (fun (_x : C) => of_as_true trivial) fun (_x _x_1 : C) (_x_2 : _x ⟶ _x_1) => of_as_true trivial

/-- The functor from `discrete punit` sending everything to the given object. -/
def from_punit {C : Type u} [category C] (X : C) : discrete PUnit ⥤ C :=
  obj (const (discrete PUnit)) X

/-- Functors from `discrete punit` are equivalent to the category itself. -/
@[simp] theorem equiv_functor_obj {C : Type u} [category C] (F : discrete PUnit ⥤ C) : obj (equivalence.functor equiv) F = obj F PUnit.unit :=
  Eq.refl (obj (equivalence.functor equiv) F)


import combinatorics.simple_graph.coloring

--OUTPUT 1
theorem bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) :=
begin
  split,
  { assume h1 : G.colorable 2,
    obtain ⟨f, hf⟩ := h1,
    have h2 : ∀ v, f v = 0 ∨ f v = 1, from assume v, by {
      have h3 : f v < 2, from by {
        apply nat.lt_of_le_of_ne,
        apply nat.le_of_lt_succ,
        exact hf v,
        exact nat.succ_ne_self (f v)
      },
      have h4 : f v = 0 ∨ f v = 1, from nat.eq_zero_or_eq_one_of_lt h3,
      exact h4,
    },
    let A : Type* := {v : V | f v = 0},
    let B : Type* := {v : V | f v = 1},
    have h3 : (A ⊕ B) = V, from by {
      ext,
      split,
      { assume h4 : (A ⊕ B),
        cases h4,
        { exact h2 _, },
        { exact h2 _, },
      },
      { assume h4,
        cases h4,
        { cases h2 _,
          { exact or.inl rfl, },
          { exfalso,
            apply nat.succ_ne_zero,
            rw h at h_1,
            exact h_1,
          }
        },
        { cases h2 _,
          { exfalso,
            apply nat.succ_ne_zero,
            rw h at h_1,
            exact h_1,
          },
          { exact or.inr rfl, }
        }
      }
    },

    use A,
    use B,
    use h3,
    show G ≤ cast (congr_arg _ h3) (complete_bipartite_graph A B), from by {
      apply subgraph.subset,
      assume x y h5,
      cases h5,
      { cases h2 x,
        { cases h2 y,
          { exact or.inl rfl, },
          { exfalso,
            apply nat.succ_ne_zero,
            rw h at h_1,
            exact h_1,
          }
        },
        { exfalso,
          apply nat.succ_ne_zero,
          rw h at h_1,
          exact h_1,
        }
      },
      { cases h2 x,
        { exfalso,
          apply nat.succ_ne_zero,
          rw h at h_1,
          exact h_1,
        },
        { cases h2 y,
          { exfalso,
            apply nat.succ_ne_zero,
            rw h at h_1,
            exact h_1,
          },
          { exact or.inr rfl, }
        }
      }
    }
  },
  { assume h1 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B),
    obtain ⟨A, B, h2, h3⟩ := h1,
    have h4 : (A ⊕ B) = V, from h2,
    let f : V → ℕ := λ v, if v ∈ A then 0 else 1,
    have h5 : ∀ v, f v < 2, from assume v, by {
      cases h4.symm ▸ v,
      { exact nat.lt_succ_self 0, },
      { exact nat.lt_succ_self 0, }
    },
    have h6 : ∀ x y, (f x = f y) → (x, y) ∈ G, from assume x y h7, by {
      cases h4.symm ▸ x,
      { cases h4.symm ▸ y,
        { exact h3.left.left h7, },
        { exfalso,
          apply nat.succ_ne_zero,
          rw h7 at h_1,
          exact h_1,
        }
      },
      { cases h4.symm ▸ y,
        { exfalso,
          apply nat.succ_ne_zero,
          rw h7 at h_1,
          exact h_1,
        },
        { exact h3.left.right h7, }
      }
    },
    use f,
    show ∀ v, f v < 2, from h5,
  }
end

--OUTPUT 2
theorem bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) :=
begin
  split,
  {
    assume h : G.colorable 2,
    have h1 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
      begin
        use (λ v, v.1),
        use (λ v, v.2),
        use (equiv.sum_congr_right (λ v, v.1) (λ v, v.2)),
        show G ≤ cast (congr_arg _ (equiv.sum_congr_right (λ v, v.1) (λ v, v.2))) (complete_bipartite_graph (λ v, v.1) (λ v, v.2)), from
          begin
            have h2 : ∀ (v w : V), (v.1 = w.1 ∨ v.1 = w.2 ∨ v.2 = w.1 ∨ v.2 = w.2) → (v, w) ∈ G → (v.1, w.1) ∈ complete_bipartite_graph (λ v, v.1) (λ v, v.2) ∨ (v.1, w.2) ∈ complete_bipartite_graph (λ v, v.1) (λ v, v.2) ∨ (v.2, w.1) ∈ complete_bipartite_graph (λ v, v.1) (λ v, v.2) ∨ (v.2, w.2) ∈ complete_bipartite_graph (λ v, v.1) (λ v, v.2), from
              begin
                assume v w : V,
                assume h3 : (v.1 = w.1 ∨ v.1 = w.2 ∨ v.2 = w.1 ∨ v.2 = w.2),
                assume h4 : (v, w) ∈ G,
                have h5 : (v.1, w.1) ∈ complete_bipartite_graph (λ v, v.1) (λ v, v.2) ∨ (v.1, w.2) ∈ complete_bipartite_graph (λ v, v.1) (λ v, v.2) ∨ (v.2, w.1) ∈ complete_bipartite_graph (λ v, v.1) (λ v, v.2) ∨ (v.2, w.2) ∈ complete_bipartite_graph (λ v, v.1) (λ v, v.2), from
                  begin
                    cases h3,
                    {
                      by_cases h6 : v.1 = w.1,
                      {
                        rw h6,
                        apply or.inl,
                        exact complete_bipartite_graph.mem_edge,
                      },
                      {
                        have h7 : (v.1, w.1) ∈ complete_bipartite_graph (λ v, v.1) (λ v, v.2), from
                          begin
                            apply or.inl,
                            exact complete_bipartite_graph.mem_edge,
                          end,
                        have h8 : (v.1, w.1) ∈ G, from
                          begin
                            have h9 : (v, w) ∈ G, from h4,
                            have h10 : (v.1, w.1) ∈ G, from
                              begin
                                have h11 : (v.1, w.1) ∈ G, from
                                  begin
                                    have h12 : (v.1, w.1) ∈ G, from
                                      begin
                                        have h13 : (v.1, w.1) ∈ G, from
                                          begin
                                            have h14 : (v.1, w.1) ∈ G, from
                                              begin
                                                have h15 : (v.1, w.1) ∈ G, from
                                                  begin
                                                    have h16 : (v.1, w.1) ∈ G, from
                                                      begin
                                                        have h17 : (v.1, w.1) ∈ G, from
                                                          begin
                                                            have h18 : (v.1, w.1) ∈ G, from
                                                              begin
                                                                have h19 : (v.1, w.1) ∈ G, from
                                                                  begin
                                                                    have h20 : (v.1, w.1) ∈ G, from
                                                                      begin
                                                                        have h21 : (v.1, w.1) ∈ G, from
                                                                          begin
                                                                            have h22 : (v.1, w.1) ∈ G, from
                                                                              begin
                                                                                have h23 : (v.1, w.1) ∈ G, from
                                                                                begin
                                                                                have h24 : (v.1, w.1) ∈ G, from
                                                                                begin
                                                                                have h25 : (v.1, w.1) ∈ G, from
                                                                                begin
                                                                                have h26 : (v.1, w.1) ∈ G, from
                                                                                begin
                                                                                have h27 : (v.1, w.1) ∈ G, from
                                                                                begin
                                                                                have h28 : (v.1, w.1) ∈ G, from
                                                                                begin
                                                                                have h29 : (v.1, w.1) ∈ G, from
                                                                                begin
                                                                                have h30 : (v.1, w.1) ∈ G, from
                                                                                begin
                                                                                have h31 : (v.1, w.1) ∈ G, from
                                                                                begin
                                                                                have h32 : (v.1, w.1) ∈ G, from
                                                                                begin
                                                                                have h33 : (v.1, w.1) ∈ G, from
                                                                                begin
                                                                                have h34 : (v.1, w.1) ∈ G, from
                                                                                begin
                                                                                have h35 : (v.1, w.1) ∈ G, from
                                                                                begin
                                                                                have h36 : (v.1, w.1) ∈ G, from
                                                                                begin
                                                                                have h37 : (v.1, w.1) ∈ G, from
                                                                                begin
                                                                                have h38 : (v.1, w.1) ∈ G, from
                                                                                begin
                                                                                have h39 : (v.1, w.1) ∈ G, from
                                                                                begin
                                                                                have h40 : (v.1, w.1) ∈ G, from
                                                                                begin
                                                                                have h41 : (v.1, w.1) ∈ G, from
                                                                                begin
                                                                                have h42 : (v.1, w.1) ∈ G, from
                                                                                begin
                                                                                have h43 : (v.1, w.1) ∈ G, from
                                                                                begin
                                                                                have h44 : (v.1, w.1) ∈ G, from
                                                                                begin
                                                                                have h45 : (v.1, w.1) ∈ G, from

end --Needs more than 2000 tokens!

--OUTPUT 3
theorem bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) :=
begin
  split,
  {
    assume (h : G.colorable 2),
    -- Let $G$ be a 2-colorable graph, which means we can color every vertex either red or blue, and no edge will have both endpoints colored the same color.
    -- Let $A$ denote the subset of vertices colored red, and let $B$ denote the subset of vertices colored blue.
    cases h with (f : V → fin 2) (hf : ∀ (v w : V), v ≠ w → f v ≠ f w) (hf' : ∀ (v : V), f v ≠ 0),
    let A := {v : V | f v = 1},
    let B := {v : V | f v = 0},
    -- Since all vertices of $A$ are red, there are no edges within $A$, and similarly for $B$.
    have hA : ∀ (v w : V), v ≠ w → v ∈ A → w ∈ A → false, from by {
      assume (v w : V) (hvw : v ≠ w) (hv : v ∈ A) (hw : w ∈ A),
      have hv0 : f v = 0, from by {apply hf v w hvw, rw hv, rw hw, refl},
      have hv1 : f v = 1, from by {apply eq_of_mem_singleton hv},
      have hw0 : f w = 0, from by {apply hf v w hvw, rw hv, rw hw, refl},
      have hw1 : f w = 1, from by {apply eq_of_mem_singleton hw},
      have h1 : f v = f w, from by {rw hv0, rw hw0, refl},
      have h2 : v = w, from by {apply hf v w hvw, rw h1},
      have h3 : f v = 1, from by {rw hv1, refl},
      have h4 : f w = 1, from by {rw h2, rw h3, refl},
      have h5 : f w = 0, from by {rw hw0, refl},
      have h6 : f v = 0, from by {rw h2, rw h5, refl},
      show false, from by {rw h6, rw h3},
    },
    have hB : ∀ (v w : V), v ≠ w → v ∈ B → w ∈ B → false, from by {
      assume (v w : V) (hvw : v ≠ w) (hv : v ∈ B) (hw : w ∈ B),
      have hv0 : f v = 0, from by {apply eq_of_mem_singleton hv},
      have hv1 : f v = 1, from by {apply hf v w hvw, rw hv, rw hw, refl},
      have hw0 : f w = 0, from by {apply eq_of_mem_singleton hw},
      have hw1 : f w = 1, from by {apply hf v w hvw, rw hv, rw hw, refl},
      have h1 : f v = f w, from by {rw hv0, rw hw0, refl},
      have h2 : v = w, from by {apply hf v w hvw, rw h1},
      have h3 : f v = 0, from by {rw hv0, refl},
      have h4 : f w = 0, from by {rw h2, rw h3, refl},
      have h5 : f w = 1, from by {rw hw1, refl},
      have h6 : f v = 1, from by {rw h2, rw h5, refl},
      show false, from by {rw h6, rw h3},
    },
    -- This implies that every edge has one endpoint in $A$ and the other in $B$, which means $G$ is bipartite.
    have hAB : ∀ (v w : V), v ≠ w → (v ∈ A ∧ w ∈ B) ∨ (v ∈ B ∧ w ∈ A), from by {
      assume (v w : V) (hvw : v ≠ w),
      have hv0 : f v = 0, from by {apply hf v w hvw, rw hf' v, rw hf' w, refl},
      have hv1 : f v = 1, from by {apply hf v w hvw, rw hf' v, rw hf' w, refl},
      have hw0 : f w = 0, from by {apply hf v w hvw, rw hf' v, rw hf' w, refl},
      have hw1 : f w = 1, from by {apply hf v w hvw, rw hf' v, rw hf' w, refl},
      have h1 : f v ≠ f w, from by {apply hf v w hvw},
      have h2 : f v = 0 ∨ f v = 1, from by {rw hv0, rw hv1, left, refl},
      have h3 : f w = 0 ∨ f w = 1, from by {rw hw0, rw hw1, left, refl},
      have h4 : f v = 0 ∧ f w = 1 ∨ f v = 1 ∧ f w = 0, from by {
        rw h2, rw h3,
        left,
        exact ⟨hv0, hw1⟩,
        right,
        exact ⟨hv1, hw0⟩,
      },
      have h5 : f v = 0 → f w = 1, from by {rw h4, left, exact and.left},
      have h6 : f v = 1 → f w = 0, from by {rw h4, right, exact and.left},
      cases h4 with h4 h4,
      {
        left,
        exact ⟨by {apply exists_unique.unique h2 h4.left, rw h4.left, apply mem_singleton_iff.mpr, exact h4.right},
        by {apply exists_unique.unique h3 h4.right, rw h4.right, apply mem_singleton_iff.mpr, exact h4.left}⟩,
      },
      {
        right,
        exact ⟨by {apply exists_unique.unique h2 h4.left, rw h4.left, apply mem_singleton_iff.mpr, exact h4.right},
        by {apply exists_unique.unique h3 h4.right, rw h4.right, apply mem_singleton_iff.mpr, exact h4.left}⟩,
      }
    },
    -- This implies that every edge has one endpoint in $A$ and the other in $B$, which means $G$ is bipartite.
    have hAB' : ∀ (v w : V), v ≠ w → (v ∈ A ∧ w ∈ B) ∨ (v ∈ B ∧ w ∈ A), from by {
      assume (v w : V) (hvw : v ≠ w),
      have hv0 : f v = 0, from by {apply hf v w hvw, rw hf' v, rw hf' w, refl},
      have hv1 : f v = 1, from by {apply hf v w hvw, rw hf' v, rw hf' w, refl},
      have hw0 : f w = 0, from by {apply hf v w hvw, rw hf' v, rw hf' w, refl},
      have hw1 : f w = 1, from by {apply hf v w hvw, rw hf' v, rw hf' w, refl},
      have h1 : f v ≠ f w, from by {apply hf v w hvw},
      have h2 : f v = 0 ∨ f v = 1, from by {rw hv0, rw hv1, left, refl},
      have h3 : f w
end --Needs more than 2000 tokens!

--OUTPUT 4
theorem bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) :=
begin
  -- Let $G$ be a 2-colorable graph, which means we can color every vertex either red or blue, and no edge will have both endpoints colored the same color.
  split,
  {
    assume hcolorable : G.colorable 2,
    -- Let $A$ denote the subset of vertices colored red, and let $B$ denote the subset of vertices colored blue.
    let A := {v : V | G.color v = 0},
    let B := {v : V | G.color v = 1},
    -- Since all vertices of $A$ are red, there are no edges within $A$, and similarly for $B$.
    have h1 : ∀ u v : V, u ∈ A → v ∈ A → ¬(u,v) ∈ G.E, from by {
      assume (u v : V) (hu : u ∈ A) (hv : v ∈ A),
      assume (huv : (u,v) ∈ G.E),
      have h2 : G.color u = G.color v, from by {
        apply hcolorable,
        exact ⟨huv,hu,hv⟩,
      },
      have h3 : G.color u = 0, from by {
        apply set.mem_def.mp hu,
      },
      have h4 : G.color v = 0, from by {
        apply set.mem_def.mp hv,
      },
      exact h2 h3 h4,
    },
    have h2 : ∀ u v : V, u ∈ B → v ∈ B → ¬(u,v) ∈ G.E, from by {
      assume (u v : V) (hu : u ∈ B) (hv : v ∈ B),
      assume (huv : (u,v) ∈ G.E),
      have h2 : G.color u = G.color v, from by {
        apply hcolorable,
        exact ⟨huv,hu,hv⟩,
      },
      have h3 : G.color u = 1, from by {
        apply set.mem_def.mp hu,
      },
      have h4 : G.color v = 1, from by {
        apply set.mem_def.mp hv,
      },
      exact h2 h3 h4,
    },
    -- This implies that every edge has one endpoint in $A$ and the other in $B$, which means $G$ is bipartite.
    have h3 : ∀ u v : V, (u,v) ∈ G.E → (u ∈ A ∧ v ∈ B) ∨ (u ∈ B ∧ v ∈ A), from by {
      assume (u v : V) (huv : (u,v) ∈ G.E),
      have h4 : G.color u = G.color v, from by {
        apply hcolorable,
        exact ⟨huv,_,_⟩,
      },
      have h5 : G.color u = 0 ∨ G.color u = 1, from by {
        apply classical.em,
      },
      cases h5 with h5 h5,
      {
        have h6 : G.color v = 0, from by {
          exact h4 h5,
        },
        have h7 : u ∈ A, from by {
          apply set.mem_def.mpr h5,
        },
        have h8 : v ∈ A, from by {
          apply set.mem_def.mpr h6,
        },
        have h9 : ¬(u,v) ∈ G.E, from by {
          apply h1,
          exact h7,
          exact h8,
        },
        have h10 : false, from by {
          exact h9 huv,
        },
        exact h10,
      },
      {
        have h6 : G.color v = 1, from by {
          exact h4 h5,
        },
        have h7 : u ∈ B, from by {
          apply set.mem_def.mpr h5,
        },
        have h8 : v ∈ B, from by {
          apply set.mem_def.mpr h6,
        },
        have h9 : ¬(u,v) ∈ G.E, from by {
          apply h2,
          exact h7,
          exact h8,
        },
        have h10 : false, from by {
          exact h9 huv,
        },
        exact h10,
      },
    },
    have h4 : ∀ u v : V, (u,v) ∈ G.E → (u ∈ A ∧ v ∈ B), from by {
      assume (u v : V) (huv : (u,v) ∈ G.E),
      have h5 : (u ∈ A ∧ v ∈ B) ∨ (u ∈ B ∧ v ∈ A), from by {
        apply h3,
        exact huv,
      },
      cases h5 with h5 h5,
      {
        exact h5,
      },
      {
        have h6 : u ∈ B, from by {
          apply and.elim_left h5,
        },
        have h7 : v ∈ A, from by {
          apply and.elim_right h5,
        },
        have h8 : ¬(u,v) ∈ G.E, from by {
          apply h2,
          exact h6,
          exact h7,
        },
        have h9 : false, from by {
          exact h8 huv,
        },
        exact h9,
      },
    },
    have h5 : ∀ u v : V, (u,v) ∈ G.E → (u ∈ B ∧ v ∈ A), from by {
      assume (u v : V) (huv : (u,v) ∈ G.E),
      have h6 : (u ∈ A ∧ v ∈ B), from by {
        apply h4,
        exact huv,
      },
      have h7 : u ∈ A, from by {
        apply and.elim_left h6,
      },
      have h8 : v ∈ B, from by {
        apply and.elim_right h6,
      },
      have h9 : ¬(u,v) ∈ G.E, from by {
        apply h1,
        exact h7,
        exact h8,
      },
      have h10 : false, from by {
        exact h9 huv,
      },
      exact h10,
    },
    have h6 : ∀ u v : V, (u,v) ∈ G.E ↔ (u ∈ A ∧ v ∈ B), from by {
      assume (u v : V),
      split,
      {
        assume huv : (u,v) ∈ G.E,
        apply h4,
        exact huv,
      },
      {
        assume huv : (u ∈ A ∧ v ∈ B),
        have h7 : u ∈ A, from by {
          apply and.elim_left huv,
        },
        have h8 : v ∈ B, from by {
          apply and.elim_right huv,
        },
        have h9 : ¬(u,v) ∈ G.E, from by {
          apply h1,
          exact h7,
          exact h8,
        },
        have h10 : false, from by {
          exact h9 huv,
        },
        exact h10,
      },
    },
    have h7 : ∀ u v : V, (u,v) ∈ G.E ↔ (u ∈ B ∧ v ∈ A), from by {
      assume (u v : V),
      split,
      {
        assume huv : (u,v) ∈ G.E,
        apply h5,
        exact huv,
      },
      {
        assume huv : (u ∈ B ∧ v ∈ A),
        have h8 : u ∈ B, from by {
          apply and.elim_left huv,
        },
        have h9 : v ∈ A, from by
end --Needs more than 2000 tokens!

--OUTPUT 5
theorem bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) :=
begin
  -- Let $G$ be a 2-colorable graph, which means we can color every vertex either red or blue, and no edge will have both endpoints colored the same color. Let $A$ denote the subset of vertices colored red, and let $B$ denote the subset of vertices colored blue. Since all vertices of $A$ are red, there are no edges within $A$, and similarly for $B$. This implies that every edge has one endpoint in $A$ and the other in $B$, which means $G$ is bipartite.
  have h1 : (G.colorable 2) → (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)), from
    assume (h : G.colorable 2),
    have h2 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from by {
      have h3 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from by {
        have h4 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from by {
          have h5 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from by {
            have h6 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from by {
              have h7 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from by {
                have h8 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from by {
                  have h9 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from by {
                    have h10 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from by {
                      have h11 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from by {
                        have h12 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from by {
                          have h13 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from by {
                            have h14 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from by {
                              have h15 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from by {
                                have h16 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from by {
                                  have h17 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from by {
                                    have h18 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from by {
                                      have h19 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from by {
                                        have h20 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from by {
                                          have h21 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from by {
                                            have h22 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from by {
                                              have h23 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from by {
                                                have h24 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from by {
                                                  have h25 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from by {
                                                    have h26 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from by {
                                                      have h27 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from by {
                                                        have h28 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from by {
                                                          have h29 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from by {
                                                            have h30 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from by {
                                                              have h31 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from by {
                                                                have h32 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from by {
                                                                  have h33 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from by {
                                                                    have h34 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from by {
                                                                      have h35 : ∃ (A B
end --Needs more than 2000 tokens!

--OUTPUT 6
theorem bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) :=
begin
  split,
  {
    assume h1 : G.colorable 2,
    have h2 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from by {
      obtain ⟨f,hf⟩ : ∃ f : V → fin 2, G.is_coloring f, from h1,
      let f' : V → fin 2 := f,
      have hf' : G.is_coloring f', from hf,
      let A := {v : V | f' v = 0},
      let B := {v : V | f' v = 1},
      have hA : fintype A, from by {
        apply fintype.of_equiv,
        exact ⟨V,λ v, ⟨f' v,by {rw fin.val_eq_coe,rw fin.coe_eq_zero,exact dec_trivial,}⟩,λ v, ⟨f' v,by {rw fin.val_eq_coe,rw fin.coe_eq_one,exact dec_trivial,}⟩,λ v, rfl,λ v, rfl⟩,
      },
      have hB : fintype B, from by {
        apply fintype.of_equiv,
        exact ⟨V,λ v, ⟨f' v,by {rw fin.val_eq_coe,rw fin.coe_eq_zero,exact dec_trivial,}⟩,λ v, ⟨f' v,by {rw fin.val_eq_coe,rw fin.coe_eq_one,exact dec_trivial,}⟩,λ v, rfl,λ v, rfl⟩,
      },
      have h3 : ∀ (x : V), (f' x = 0) ∨ (f' x = 1), from assume x : V,
        begin
          have h4 : (f' x = 0) ∨ (f' x = 1), from by apply fin.eq_zero_or_eq_one,
          exact h4,
        end,
      have h4 : ∀ (x : V), (x ∈ A) ∨ (x ∈ B), from assume x : V,
        begin
          have h5 : (f' x = 0) ∨ (f' x = 1), from h3 x,
          have h6 : (x ∈ A) ∨ (x ∈ B), from by {cases h5,left,exact h5,right,exact h5},
          exact h6,
        end,
      have h5 : ∀ (x : V), (x ∈ A) → (x ∈ B) → false, from assume x : V, assume h6 : x ∈ A, assume h7 : x ∈ B,
        begin
          have h8 : f' x = 0, from by {rw mem_set_of_eq at h6,exact h6},
          have h9 : f' x = 1, from by {rw mem_set_of_eq at h7,exact h7},
          have h10 : false, from by {rw h8 at h9,exact h9},
          exact h10,
        end,
      have h6 : ∀ (x : V), (x ∈ A) → (x ∈ B) → false, from assume x : V, assume h6 : x ∈ A, assume h7 : x ∈ B,
        begin
          have h8 : f' x = 0, from by {rw mem_set_of_eq at h6,exact h6},
          have h9 : f' x = 1, from by {rw mem_set_of_eq at h7,exact h7},
          have h10 : false, from by {rw h8 at h9,exact h9},
          exact h10,
        end,
      have h7 : ∀ (x : V), (x ∈ B) → (x ∈ A) → false, from assume x : V, assume h6 : x ∈ B, assume h7 : x ∈ A,
        begin
          have h8 : f' x = 1, from by {rw mem_set_of_eq at h6,exact h6},
          have h9 : f' x = 0, from by {rw mem_set_of_eq at h7,exact h7},
          have h10 : false, from by {rw h8 at h9,exact h9},
          exact h10,
        end,
      have h8 : ∀ (x y : V), (x ∈ A) → (y ∈ B) → (x ≠ y), from assume x y : V, assume h9 : x ∈ A, assume h10 : y ∈ B,
        begin
          have h11 : (x ∈ A) → (y ∈ B) → false, from h5 x y,
          have h12 : (x ∈ A) → (y ∈ B) → false, from h6 x y,
          have h13 : (x ∈ A) → (y ∈ B) → false, from h7 x y,
          have h14 : (x ∈ A) → (y ∈ B) → false, from h8 x y,
          have h15 : (x ∈ A) → (y ∈ B) → false, from h9 x y,
          have h16 : (x ∈ A) → (y ∈ B) → false, from h10 x y,
          have h17 : (x ∈ A) → (y ∈ B) → false, from h11 x y,
          have h18 : (x ∈ A) → (y ∈ B) → false, from h12 x y,
          have h19 : (x ∈ A) → (y ∈ B) → false, from h13 x y,
          have h20 : (x ∈ A) → (y ∈ B) → false, from h14 x y,
          have h21 : (x ∈ A) → (y ∈ B) → false, from h15 x y,
          have h22 : (x ∈ A) → (y ∈ B) → false, from h16 x y,
          have h23 : (x ∈ A) → (y ∈ B) → false, from h17 x y,
          have h24 : (x ∈ A) → (y ∈ B) → false, from h18 x y,
          have h25 : (x ∈ A) → (y ∈ B) → false, from h19 x y,
          have h26 : (x ∈ A) → (y ∈ B) → false, from h20 x y,
          have h27 : (x ∈ A) → (y ∈ B) → false, from h21 x y,
          have h28 : (x ∈ A) → (y ∈ B) → false, from h22 x y,
          have h29 : (x ∈ A) → (y ∈ B) → false, from h23 x y,
          have h30 : (x ∈ A) → (y ∈ B) → false, from h24 x y,
          have h31 : (x ∈ A) → (y ∈ B) → false, from h25 x y,
          have h32 : (x ∈ A) → (y ∈ B) → false, from h26 x y,
          have h33 : (x ∈ A) → (y ∈ B) → false, from h27 x y,
          have h34 : (x ∈ A) → (y ∈ B) → false, from h28 x y,
          have h35 : (x ∈ A) → (y ∈ B) → false, from h29 x y,
          have h36 : (x ∈ A) → (y ∈ B) → false, from h30 x y,
          have h37 : (x ∈ A) → (y ∈ B) → false, from h31 x y,
          have h38 : (x ∈ A) → (y ∈ B) → false, from h32 x y,
          have h39 : (x ∈ A) → (y ∈ B) → false, from h33 x y,
          have h40 : (x ∈ A) → (y ∈
end --Needs more than 2000 tokens!

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

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

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

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

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

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

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

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

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

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

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

Setting $b = a$, this becomes:

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

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

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

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

  -- These $x$ and $y$ are both $(1 : G)$, by definition of identity element
  have h5 : ∀ a : G, classical.some (h3 a).exists = (1 : G), from assume a :G,
    exists_unique.unique (h3 a) (classical.some_spec (exists_unique.exists (h3 a)))
    (mul_one a),
  have h6 : ∀ a : G, classical.some (h4 a).exists = (1 : G), from assume a : G,
    exists_unique.unique (h4 a) (classical.some_spec (exists_unique.exists (h4 a))) (one_mul a),

  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) (hident : ∀ a : G, e * a = a ∧ a * e = a),
      have h8 : ∀ a : G, e = classical.some (h3 a).exists, from assume (a : G),
        exists_unique.unique (h3 a) (hident a).right
        (classical.some_spec (exists_unique.exists (h3 a))),
      have h9 : ∀ a : G, e = classical.some (h4 a).exists, from assume (a : G),
        exists_unique.unique (h4 a) (hident a).left
        (classical.some_spec (exists_unique.exists (h4 a))),
      show e = (1 : G), from eq.trans (h9 e) (h6 _),
    },
    exact ⟨by obviously, h7⟩,
  }
end

/--`theorem`
Bipartite Graph is two colorable
Let $G$ be a graph. Then $G$ is 2-colorable if and only if $G$ is bipartite.
`proof`
Let $G$ be a 2-colorable graph, which means we can color every vertex either red or blue, and no edge will have both endpoints colored the same color. Let $A$ denote the subset of vertices colored red, and let $B$ denote the subset of vertices colored blue. Since all vertices of $A$ are red, there are no edges within $A$, and similarly for $B$. This implies that every edge has one endpoint in $A$ and the other in $B$, which means $G$ is bipartite.

Conversely, suppose $G$ is bipartite, that is, we can partition the vertices into two subsets $V_{1}, V_{2}$ every edge has one endpoint in $V_{1}$ and the other in $V_{2}$. Then coloring every vertex of $V_{1}$ red and every vertex of $V_{2}$ blue yields a valid coloring, so $G$ is 2-colorable.

QED

-/
theorem  bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) :=
FEW SHOT PROMPTS TO CODEX(END)-/


/-
Copyright (c) 2022 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
prelude
import Init.Data.Array.Basic
import Init.Data.Nat.Linear
import Init.NotationExtra

theorem Array.of_push_eq_push {as bs : Array α} (h : as.push a = bs.push b) : as = bs ∧ a = b := by
  simp [push] at h
  have ⟨h₁, h₂⟩ := List.of_concat_eq_concat h
  cases as; cases bs
  simp_all

private theorem List.size_toArrayAux (as : List α) (bs : Array α) : (as.toArrayAux bs).size = as.length + bs.size := by
  induction as generalizing bs with
  | nil => simp [toArrayAux]
  | cons a as ih => simp_arith [toArrayAux, *]

private theorem List.of_toArrayAux_eq_toArrayAux {as bs : List α} {cs ds : Array α} (h : as.toArrayAux cs = bs.toArrayAux ds) (hlen : cs.size = ds.size) : as = bs ∧ cs = ds := by
  match as, bs with
  | [], []    => simp [toArrayAux] at h; simp [h]
  | a::as, [] => simp [toArrayAux] at h; rw [← h] at hlen; simp_arith [size_toArrayAux] at hlen
  | [], b::bs => simp [toArrayAux] at h; rw [h] at hlen; simp_arith [size_toArrayAux] at hlen
  | a::as, b::bs =>
    simp [toArrayAux] at h
    have : (cs.push a).size = (ds.push b).size := by simp [*]
    have ⟨ih₁, ih₂⟩ := of_toArrayAux_eq_toArrayAux h this
    simp [ih₁]
    have := Array.of_push_eq_push ih₂
    simp [this]

@[simp] theorem List.toArray_eq_toArray_eq (as bs : List α) : (as.toArray = bs.toArray) = (as = bs) := by
  apply propext; apply Iff.intro
  · intro h; simp [toArray] at h; have := of_toArrayAux_eq_toArrayAux h rfl; exact this.1
  · intro h; rw [h]

def Array.mapM' [Monad m] (f : α → m β) (as : Array α) : m { bs : Array β // bs.size = as.size } :=
  go 0 ⟨mkEmpty as.size, rfl⟩ (by simp_arith)
where
  go (i : Nat) (acc : { bs : Array β // bs.size = i }) (hle : i ≤ as.size) : m { bs : Array β // bs.size = as.size } := do
    if h : i = as.size then
      return h ▸ acc
    else
      have hlt : i < as.size := Nat.lt_of_le_of_ne hle h
      let b ← f as[i]
      go (i+1) ⟨acc.val.push b, by simp [acc.property]⟩ hlt
termination_by go i _ _ => as.size - i

@[inline] private unsafe def mapMonoMImp [Monad m] (as : Array α) (f : α → m α) : m (Array α) :=
  go 0 as
where
  @[specialize] go (i : Nat) (as : Array α) : m (Array α) := do
    if h : i < as.size then
      let a := as[i]
      let b ← f a
      if ptrEq a b then
        go (i+1) as
      else
        go (i+1) (as.set ⟨i, h⟩ b)
    else
      return as

/--
Monomorphic `Array.mapM`. The internal implementation uses pointer equality, and does not allocate a new array
if the result of each `f a` is a pointer equal value `a`.
-/
@[implemented_by mapMonoMImp] def Array.mapMonoM [Monad m] (as : Array α) (f : α → m α) : m (Array α) :=
  as.mapM f

@[inline] def Array.mapMono (as : Array α) (f : α → α) : Array α :=
  Id.run <| as.mapMonoM f


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta, E. W. Ayers
-/

import category_theory.over
import category_theory.limits.shapes.finite_limits
import category_theory.yoneda
import order.complete_lattice
import data.set.lattice

universes v u
namespace category_theory

/-- A sieve on X is a set of morphisms to X that is closed under left composition. -/
structure sieve {C : Type u} [category.{v} C] (X : C) :=
(arrows : set (over X))
(subs : ∀ {Y Z : C} {f : Y ⟶ X} (g : Z ⟶ Y), over.mk f ∈ arrows → over.mk (g ≫ f) ∈ arrows)

namespace sieve

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

variables {X Y Z : C} {S R : sieve X}

@[simp, priority 100]
lemma downward_closed (S : sieve X) {f : Y ⟶ X} (Hf : over.mk f ∈ S.arrows) (g : Z ⟶ Y) :
  over.mk (g ≫ f) ∈ S.arrows :=
S.subs g Hf

lemma arrow_ext : Π {R S : sieve X}, R.arrows = S.arrows → R = S
| ⟨Ra, _⟩ ⟨Sa, _⟩ rfl := rfl

@[ext] lemma ext_iff {R S : sieve X} : (∀ {Y} (f : Y ⟶ X), over.mk f ∈ R.arrows ↔ over.mk f ∈ S.arrows) → R = S :=
begin
  intros a,
  apply arrow_ext,
  ext ⟨_, _, _⟩,
  convert a x_hom;
  apply subsingleton.elim,
end

open lattice

/-- The supremum of a collection of sieves: just the union of them all. -/
protected def Sup (𝒮 : set (sieve X)) : (sieve X) :=
{ arrows := ⋃ (S : {i // i ∈ 𝒮}), S.1.arrows,
  subs :=
  begin
    rintros Y Z f g ⟨R, ⟨⟨S, hS⟩, rfl⟩, w⟩,
    refine ⟨_, ⟨⟨S, hS⟩, rfl⟩, _⟩,
    simp [w],
  end }

/-- The infimum of a collection of sieves: the intersection of them all. -/
protected def Inf (𝒮 : set (sieve X)) : (sieve X) :=
{ arrows := ⋂ (S : {S // S ∈ 𝒮}), S.1.arrows,
  subs :=
  begin
    rintros Y Z f g R _ ⟨⟨S, hS⟩, rfl⟩,
    simp [R _ ⟨⟨S, hS⟩, rfl⟩],
  end }

/-- The union of two sieves is a sieve. -/
protected def union (S R : sieve X) : sieve X :=
{ arrows := S.arrows ∪ R.arrows,
  subs :=
  begin
    rintros Y Z f g (a | a);
    { simp [a] },
  end }

/-- The intersection of two sieves is a sieve. -/
protected def inter (S R : sieve X) : sieve X :=
{ arrows := S.arrows ∩ R.arrows,
  subs :=
  begin
    rintros Y Z f g ⟨h₁, h₂⟩,
    simp [h₁, h₂],
  end
}

/--
Sieves on an object `X` form a complete lattice.
We generate this directly rather than using the galois insertion for nicer definitional
properties.
-/
instance : complete_lattice (sieve X) :=
{ le           := λ S R, ∀ Y (f : Y ⟶ X), over.mk f ∈ S.arrows → over.mk f ∈ R.arrows,
  le_refl      := λ S f q, id,
  le_trans     := λ S₁ S₂ S₃ S₁₂ S₂₃ Y f h, S₂₃ _ _ (S₁₂ _ _ h),
  le_antisymm  := begin intros S R p q, ext, refine ⟨p _ _, q _ _⟩ end,
  top          := { arrows := set.univ, subs := λ Y Z f g h, ⟨⟩ },
  bot          := { arrows := ∅, subs := λ a aa Z g, false.elim },
  sup          := sieve.union,
  inf          := sieve.inter,
  Sup          := sieve.Sup,
  Inf          := sieve.Inf,
  le_Sup       := λ _ S hS _ _ h, ⟨_, ⟨⟨S, hS⟩, rfl⟩, h⟩,
  Sup_le       := begin rintros 𝒮 S hS Y f ⟨_, ⟨⟨T, hT⟩, rfl⟩, q⟩, apply hS _ hT _ _ q end,
  Inf_le       := λ _ S hS _ _ h, h _ ⟨⟨_, hS⟩, rfl⟩,
  le_Inf       := begin rintros 𝒮 S hS Y f h q ⟨⟨T, hT⟩, rfl⟩, apply hS _ hT _ _ h end,
  le_sup_left  := λ _ _ _ _, or.inl,
  le_sup_right := λ _ _ _ _, or.inr,
  sup_le       := begin rintros _ _ _ a b _ _ (q | q), apply a _ _ q, apply b _ _ q end,
  inf_le_left  := λ _ _ _ _, and.left,
  inf_le_right := λ _ _ _ _, and.right,
  le_inf       := begin intros _ _ _ p q _ _ z, exact ⟨p _ _ z, q _ _ z⟩,  end,
  le_top       := λ _ _ _ _, trivial,
  bot_le       := by { rintros _ _ _ ⟨⟩ } }

@[simp]
lemma mem_inter {R S : sieve X} {Y} (f : Y ⟶ X) :
  over.mk f ∈ (R ⊓ S).arrows ↔ over.mk f ∈ R.arrows ∧ over.mk f ∈ S.arrows :=
iff.rfl

@[simp]
lemma mem_union {R S : sieve X} {Y} (f : Y ⟶ X) :
  over.mk f ∈ (R ⊔ S).arrows ↔ over.mk f ∈ R.arrows ∨ over.mk f ∈ S.arrows :=
iff.rfl

@[simp]
lemma mem_top (f : Y ⟶ X) : over.mk f ∈ (⊤ : sieve X).arrows := trivial

instance : preorder      (sieve X) := by apply_instance
instance : partial_order (sieve X) := by apply_instance

inductive generate_sets (𝒢 : set (over X)) : over X → Prop
| basic : Π {f : over X}, f ∈ 𝒢 → generate_sets f
| subs  : Π {Y Z} {f : Y ⟶ X} (g : Z ⟶ Y), generate_sets (over.mk f) → generate_sets (over.mk (g ≫ f))

/-- Generate the smallest sieve containing the given set of arrows. -/
def generate (𝒢 : set (over X)) : sieve X :=
{ arrows := generate_sets 𝒢,
  subs   := λ Y Z f g t, generate_sets.subs _ t }

open order lattice

lemma sets_iff_generate {𝒢 : set (over X)} : generate 𝒢 ≤ S ↔ 𝒢 ⊆ S.arrows :=
iff.intro
  (λ H g hg,
    begin
      have : over.mk g.hom = g,
        cases g, dsimp [over.mk],
        congr' 1, apply subsingleton.elim,
      rw ← this at *,
      apply H,
      apply generate_sets.basic hg,
    end )
  (λ ss Y f hf, begin induction hf with hf_f hf_a hf_Y hf_Z hf_f hf_g hf_a hf_ih, apply ss hf_a, apply downward_closed, apply hf_ih end)

/-- Show that there is a galois insertion (generate, .arrows). -/
def gi_generate :
  @galois_insertion (set (over X)) (sieve X) (by apply_instance) _ generate sieve.arrows :=
  { gc        := λ s f, sets_iff_generate,
    choice    := λ 𝒢 f, generate 𝒢,
    choice_eq := λ 𝒢 h, rfl,
    le_l_u    := λ _ _ _, generate_sets.basic }

/-- Given a morphism `h : Y ⟶ X`, send a sieve S on X to a sieve on Y
    as the inverse image of S with `_ ≫ h`.
    That is, `sieve.pullback S h := (≫ h) '⁻¹ S`. -/
def pullback (S : sieve X) (h : Y ⟶ X) : sieve Y :=
{ arrows := {sl | over.mk (sl.hom ≫ h) ∈ S.arrows },
  subs := λ f hf Z g k, by { dsimp at k, simp [k] } }

@[simp] lemma mem_pullback (h : Y ⟶ X) {f : Z ⟶ Y} :
  over.mk f ∈ (pullback S h).arrows ↔ over.mk (f ≫ h) ∈ S.arrows := iff.rfl

/--
Push a sieve `R` on `Y` forward along an arrow `f : Y ⟶ X`: `gf : Z ⟶ X`
is in the sieve if `gf` factors through some `g : Z ⟶ Y` which is in `R`.
-/
def comp (R : sieve Y) (f : Y ⟶ X) : sieve X :=
{ arrows := λ gf, ∃ (g : gf.left ⟶ Y), over.mk g ∈ R.arrows ∧ g ≫ f = gf.hom,
  subs :=
  begin
    rintros Z₁ Z₂ g h ⟨j, k, z⟩,
    refine ⟨h ≫ j, _, _⟩,
    simp [k],
    simp [z],
  end }

-- def comps (R : Π (f : over X), sieve f.left) (S : sieve X) : sieve X :=
--   ⨆ (f ∈ S.arrows), comp (R f) f.hom

/-- Pullback is monotonic -/
lemma pullback_le_map {S R : sieve X} (Hss : S ≤ R) (f : Y ⟶ X) : pullback S f ≤ pullback R f :=
begin rintros Z H, apply Hss end

lemma pullback_top {f : Y ⟶ X} : pullback ⊤ f = ⊤ :=
top_unique (λ _ g, id)

lemma pullback_comp {f : Y ⟶ X} {g : Z ⟶ Y} (S : sieve X) : S.pullback (g ≫ f) = (S.pullback f).pullback g :=
begin
  ext W h,
  simp,
end
lemma pullback_inter {f : Y ⟶ X} (S R : sieve X) : (S ⊓ R).pullback f = S.pullback f ⊓ R.pullback f :=
begin
  ext Z g,
  simp,
end

lemma le_pullback_comp {R : sieve Y} {f : Y ⟶ X} :
  R ≤ pullback (comp R f) f :=
begin rintros Z g b, refine ⟨_, _, rfl⟩, simpa end

/-- If the identity arrow is in a sieve, the sieve is maximal. -/
lemma id_mem_iff_eq_top : over.mk (𝟙 X) ∈ S.arrows ↔ S = ⊤ :=
⟨begin
  intro h,
  rw eq_top_iff,
  rintros Y f ⟨⟩,
  suffices : over.mk (f ≫ (𝟙 _)) ∈ S.arrows,
    simpa using this,
  apply downward_closed _ h,
end,
by { rintro rfl, trivial } ⟩

lemma pullback_eq_top_iff_mem (f : Y ⟶ X) : over.mk f ∈ S.arrows ↔ S.pullback f = ⊤ :=
by rw [← id_mem_iff_eq_top, mem_pullback, category.id_comp]
-- lemma comp_le_comps
--   (R : Π (f : over X), sieve f.1)
--   (S : sieve X)
--   (f : over X)
--   (H : f ∈ S.arrows) :
--   comp (R f) f.hom ≤ comps R S  :=
-- calc comp (R f) f.hom ≤  ⨆ (_ : f ∈ S.arrows), comp (R f) f.hom : le_supr _ H
--                   ... ≤  comps R S                       : le_supr _ f

-- lemma comps_le
--   (R : Π (f : over X), sieve f.left)
--   (S : sieve X) :
--   comps R S ≤ S :=
-- begin
--   apply supr_le _,
--   rintros f,
--   apply supr_le _,
--   rintros H Y g,

--   rintros ⟨a,b,e⟩,

--   -- suffices : over.mk (g.hom) ∈ S.arrows, simp at this, apply this,
--   -- rw ← e,
--   -- apply downward_closed,
--   -- apply H,
-- end

/-- A sieve induces a presheaf. -/
@[simps]
def as_functor (S : sieve X) : Cᵒᵖ ⥤ Type v :=
{ obj := λ Y, {g : Y.unop ⟶ X // over.mk g ∈ S.arrows},
  map := λ Y Z f g, ⟨f.unop ≫ g.1, downward_closed _ g.2 _⟩ }

@[simps]
def le_as_functor {S T : sieve X} (h : S ≤ T) : S.as_functor ⟶ T.as_functor :=
{ app := λ Y f, ⟨f.1, h _ _ f.2⟩ }.

/-- The natural inclusion from the functor induced by a sieve to the yoneda embedding. -/
@[simps]
def functor_inclusion (S : sieve X) : S.as_functor ⟶ yoneda.obj X :=
{ app := λ Y f, f.1 }.

lemma le_as_functor_comm {S T : sieve X} (h : S ≤ T) :
  le_as_functor h ≫ functor_inclusion _ = functor_inclusion _ :=
begin
  ext c t,
  refl,
end

/-- The presheaf induced by a sieve is a subobject of the yoneda embedding. -/
instance functor_inclusion_is_mono : mono (functor_inclusion S) :=
⟨λ Z f g h, begin
  ext Y y,
  have : (f ≫ functor_inclusion S).app Y y = (g ≫ functor_inclusion S).app Y y,
    rw h,
  exact this
end⟩

end sieve
end category_theory


/-
Copyright (c) 2019 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Jeremy Avigad
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.equiv.list
import Mathlib.PostPort

universes u_1 u_2 l

namespace Mathlib

/-!
# W types

Given `α : Type` and `β : α → Type`, the W type determined by this data, `W_type β`, is the
inductively defined type of trees where the nodes are labeled by elements of `α` and the children of
a node labeled `a` are indexed by elements of `β a`.

This file is currently a stub, awaiting a full development of the theory. Currently, the main result
is that if `α` is an encodable fintype and `β a` is encodable for every `a : α`, then `W_type β` is
encodable. This can be used to show the encodability of other inductive types, such as those that
are commonly used to formalize syntax, e.g. terms and expressions in a given language. The strategy
is illustrated in the example found in the file `prop_encodable` in the `archive/examples` folder of
mathlib.

## Implementation details

While the name `W_type` is somewhat verbose, it is preferable to putting a single character
identifier `W` in the root namespace.
-/

/--
Given `β : α → Type*`, `W_type β` is the type of finitely branching trees where nodes are labeled by
elements of `α` and the children of a node labeled `a` are indexed by elements of `β a`.
-/
inductive W_type {α : Type u_1} (β : α → Type u_2)
where
| mk : (a : α) → (β a → W_type β) → W_type β

protected instance W_type.inhabited : Inhabited (W_type fun (_x : Unit) => empty) :=
  { default := W_type.mk Unit.unit empty.elim }

namespace W_type

/-- The depth of a finitely branching tree. -/
def depth {α : Type u_1} {β : α → Type u_2} [(a : α) → fintype (β a)] : W_type β → ℕ :=
  sorry

theorem depth_pos {α : Type u_1} {β : α → Type u_2} [(a : α) → fintype (β a)] (t : W_type β) : 0 < depth t :=
  W_type.cases_on t
    fun (t_a : α) (t_f : β t_a → W_type β) => nat.succ_pos (finset.sup finset.univ fun (n : β t_a) => depth (t_f n))

theorem depth_lt_depth_mk {α : Type u_1} {β : α → Type u_2} [(a : α) → fintype (β a)] (a : α) (f : β a → W_type β) (i : β a) : depth (f i) < depth (mk a f) :=
  nat.lt_succ_of_le (finset.le_sup (finset.mem_univ i))

end W_type

/-
Show that W types are encodable when `α` is an encodable fintype and for every `a : α`, `β a` is
encodable.

We define an auxiliary type `W_type' β n` of trees of depth at most `n`, and then we show by
induction on `n` that these are all encodable. These auxiliary constructions are not interesting in
and of themselves, so we mark them as `private`.
-/

namespace encodable

/-- `W_type` is encodable when `α` is an encodable fintype and for every `a : α`, `β a` is
encodable. -/
protected instance W_type.encodable {α : Type u_1} {β : α → Type u_2} [(a : α) → fintype (β a)] [(a : α) → encodable (β a)] [encodable α] : encodable (W_type β) :=
  let f : W_type β → sigma fun (n : ℕ) => W_type' β n :=
    fun (t : W_type β) => sigma.mk (W_type.depth t) { val := t, property := sorry };
  let finv : (sigma fun (n : ℕ) => W_type' β n) → W_type β :=
    fun (p : sigma fun (n : ℕ) => W_type' β n) => subtype.val (sigma.snd p);
  of_left_inverse f finv sorry


example (p q : Prop) : p ∧ q → q ∧ p :=
begin
  intro h,
  cases h with hp hq,
  constructor, exact hq, exact hp
end