/-
Copyright (c) 2018 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.nat.enat
import Mathlib.data.set.intervals.ord_connected
import Mathlib.PostPort

universes u_1 u_4 l u_3 u_2

namespace Mathlib

/-!
# Theory of conditionally complete lattices.

A conditionally complete lattice is a lattice in which every non-empty bounded subset s
has a least upper bound and a greatest lower bound, denoted below by Sup s and Inf s.
Typical examples are real, nat, int with their usual orders.

The theory is very comparable to the theory of complete lattices, except that suitable
boundedness and nonemptiness assumptions have to be added to most statements.
We introduce two predicates bdd_above and bdd_below to express this boundedness, prove
their basic properties, and then go on to prove most useful properties of Sup and Inf
in conditionally complete lattices.

To differentiate the statements between complete lattices and conditionally complete
lattices, we prefix Inf and Sup in the statements by c, giving cInf and cSup. For instance,
Inf_le is a statement in complete lattices ensuring Inf s ≤ x, while cInf_le is the same
statement in conditionally complete lattices with an additional assumption that s is
bounded below.
-/

/-!
Extension of Sup and Inf from a preorder `α` to `with_top α` and `with_bot α`
-/

protected instance with_top.has_Sup {α : Type u_1} [preorder α] [has_Sup α] :
    has_Sup (with_top α) :=
  has_Sup.mk
    fun (S : set (with_top α)) => ite (⊤ ∈ S) ⊤ (ite (bdd_above (coe ⁻¹' S)) ↑(Sup (coe ⁻¹' S)) ⊤)

protected instance with_top.has_Inf {α : Type u_1} [has_Inf α] : has_Inf (with_top α) :=
  has_Inf.mk fun (S : set (with_top α)) => ite (S ⊆ singleton ⊤) ⊤ ↑(Inf (coe ⁻¹' S))

protected instance with_bot.has_Sup {α : Type u_1} [has_Sup α] : has_Sup (with_bot α) :=
  has_Sup.mk Inf

protected instance with_bot.has_Inf {α : Type u_1} [preorder α] [has_Inf α] :
    has_Inf (with_bot α) :=
  has_Inf.mk Sup

/-- A conditionally complete lattice is a lattice in which
every nonempty subset which is bounded above has a supremum, and
every nonempty subset which is bounded below has an infimum.
Typical examples are real numbers or natural numbers.

To differentiate the statements from the corresponding statements in (unconditional)
complete lattices, we prefix Inf and Sup by a c everywhere. The same statements should
hold in both worlds, sometimes with additional assumptions of nonemptiness or
boundedness.-/
class conditionally_complete_lattice (α : Type u_4) extends lattice α, has_Sup α, has_Inf α where
  le_cSup : ∀ (s : set α) (a : α), bdd_above s → a ∈ s → a ≤ Sup s
  cSup_le : ∀ (s : set α) (a : α), set.nonempty s → a ∈ upper_bounds s → Sup s ≤ a
  cInf_le : ∀ (s : set α) (a : α), bdd_below s → a ∈ s → Inf s ≤ a
  le_cInf : ∀ (s : set α) (a : α), set.nonempty s → a ∈ lower_bounds s → a ≤ Inf s

/-- A conditionally complete linear order is a linear order in which
every nonempty subset which is bounded above has a supremum, and
every nonempty subset which is bounded below has an infimum.
Typical examples are real numbers or natural numbers.

To differentiate the statements from the corresponding statements in (unconditional)
complete linear orders, we prefix Inf and Sup by a c everywhere. The same statements should
hold in both worlds, sometimes with additional assumptions of nonemptiness or
boundedness.-/
class conditionally_complete_linear_order (α : Type u_4)
    extends linear_order α, conditionally_complete_lattice α where

/-- A conditionally complete linear order with `bot` is a linear order with least element, in which
every nonempty subset which is bounded above has a supremum, and every nonempty subset (necessarily
bounded below) has an infimum.  A typical example is the natural numbers.

To differentiate the statements from the corresponding statements in (unconditional)
complete linear orders, we prefix Inf and Sup by a c everywhere. The same statements should
hold in both worlds, sometimes with additional assumptions of nonemptiness or
boundedness.-/
class conditionally_complete_linear_order_bot (α : Type u_4)
    extends order_bot α, conditionally_complete_linear_order α where
  cSup_empty : Sup ∅ = ⊥

/- A complete lattice is a conditionally complete lattice, as there are no restrictions
on the properties of Inf and Sup in a complete lattice.-/

protected instance conditionally_complete_lattice_of_complete_lattice {α : Type u_1}
    [complete_lattice α] : conditionally_complete_lattice α :=
  conditionally_complete_lattice.mk complete_lattice.sup complete_lattice.le complete_lattice.lt
    complete_lattice.le_refl complete_lattice.le_trans complete_lattice.le_antisymm
    complete_lattice.le_sup_left complete_lattice.le_sup_right complete_lattice.sup_le
    complete_lattice.inf complete_lattice.inf_le_left complete_lattice.inf_le_right
    complete_lattice.le_inf complete_lattice.Sup complete_lattice.Inf sorry sorry sorry sorry

protected instance conditionally_complete_linear_order_of_complete_linear_order {α : Type u_1}
    [complete_linear_order α] : conditionally_complete_linear_order α :=
  conditionally_complete_linear_order.mk conditionally_complete_lattice.sup
    conditionally_complete_lattice.le conditionally_complete_lattice.lt sorry sorry sorry sorry
    sorry sorry conditionally_complete_lattice.inf sorry sorry sorry
    conditionally_complete_lattice.Sup conditionally_complete_lattice.Inf sorry sorry sorry sorry
    complete_linear_order.le_total complete_linear_order.decidable_le
    complete_linear_order.decidable_eq complete_linear_order.decidable_lt

theorem le_cSup {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {a : α}
    (h₁ : bdd_above s) (h₂ : a ∈ s) : a ≤ Sup s :=
  conditionally_complete_lattice.le_cSup s a h₁ h₂

theorem cSup_le {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {a : α}
    (h₁ : set.nonempty s) (h₂ : ∀ (b : α), b ∈ s → b ≤ a) : Sup s ≤ a :=
  conditionally_complete_lattice.cSup_le s a h₁ h₂

theorem cInf_le {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {a : α}
    (h₁ : bdd_below s) (h₂ : a ∈ s) : Inf s ≤ a :=
  conditionally_complete_lattice.cInf_le s a h₁ h₂

theorem le_cInf {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {a : α}
    (h₁ : set.nonempty s) (h₂ : ∀ (b : α), b ∈ s → a ≤ b) : a ≤ Inf s :=
  conditionally_complete_lattice.le_cInf s a h₁ h₂

theorem le_cSup_of_le {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {a : α} {b : α}
    (_x : bdd_above s) (hb : b ∈ s) (h : a ≤ b) : a ≤ Sup s :=
  le_trans h (le_cSup _x hb)

theorem cInf_le_of_le {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {a : α} {b : α}
    (_x : bdd_below s) (hb : b ∈ s) (h : b ≤ a) : Inf s ≤ a :=
  le_trans (cInf_le _x hb) h

theorem cSup_le_cSup {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {t : set α}
    (_x : bdd_above t) : set.nonempty s → s ⊆ t → Sup s ≤ Sup t :=
  fun (_x_1 : set.nonempty s) (h : s ⊆ t) =>
    cSup_le _x_1 fun (a : α) (ha : a ∈ s) => le_cSup _x (h ha)

theorem cInf_le_cInf {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {t : set α}
    (_x : bdd_below t) : set.nonempty s → s ⊆ t → Inf t ≤ Inf s :=
  fun (_x_1 : set.nonempty s) (h : s ⊆ t) =>
    le_cInf _x_1 fun (a : α) (ha : a ∈ s) => cInf_le _x (h ha)

theorem is_lub_cSup {α : Type u_1} [conditionally_complete_lattice α] {s : set α}
    (ne : set.nonempty s) (H : bdd_above s) : is_lub s (Sup s) :=
  { left := fun (x : α) => le_cSup H, right := fun (x : α) => cSup_le ne }

theorem is_glb_cInf {α : Type u_1} [conditionally_complete_lattice α] {s : set α}
    (ne : set.nonempty s) (H : bdd_below s) : is_glb s (Inf s) :=
  { left := fun (x : α) => cInf_le H, right := fun (x : α) => le_cInf ne }

theorem is_lub.cSup_eq {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {a : α}
    (H : is_lub s a) (ne : set.nonempty s) : Sup s = a :=
  is_lub.unique (is_lub_cSup ne (Exists.intro a (and.left H))) H

/-- A greatest element of a set is the supremum of this set. -/
theorem is_greatest.cSup_eq {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {a : α}
    (H : is_greatest s a) : Sup s = a :=
  is_lub.cSup_eq (is_greatest.is_lub H) (is_greatest.nonempty H)

theorem is_glb.cInf_eq {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {a : α}
    (H : is_glb s a) (ne : set.nonempty s) : Inf s = a :=
  is_glb.unique (is_glb_cInf ne (Exists.intro a (and.left H))) H

/-- A least element of a set is the infimum of this set. -/
theorem is_least.cInf_eq {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {a : α}
    (H : is_least s a) : Inf s = a :=
  is_glb.cInf_eq (is_least.is_glb H) (is_least.nonempty H)

theorem subset_Icc_cInf_cSup {α : Type u_1} [conditionally_complete_lattice α] {s : set α}
    (hb : bdd_below s) (ha : bdd_above s) : s ⊆ set.Icc (Inf s) (Sup s) :=
  fun (x : α) (hx : x ∈ s) => { left := cInf_le hb hx, right := le_cSup ha hx }

theorem cSup_le_iff {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {a : α}
    (hb : bdd_above s) (ne : set.nonempty s) : Sup s ≤ a ↔ ∀ (b : α), b ∈ s → b ≤ a :=
  is_lub_le_iff (is_lub_cSup ne hb)

theorem le_cInf_iff {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {a : α}
    (hb : bdd_below s) (ne : set.nonempty s) : a ≤ Inf s ↔ ∀ (b : α), b ∈ s → a ≤ b :=
  le_is_glb_iff (is_glb_cInf ne hb)

theorem cSup_lower_bounds_eq_cInf {α : Type u_1} [conditionally_complete_lattice α] {s : set α}
    (h : bdd_below s) (hs : set.nonempty s) : Sup (lower_bounds s) = Inf s :=
  is_lub.unique
    (is_lub_cSup h
      (set.nonempty.mono (fun (x : α) (hx : x ∈ s) (y : α) (hy : y ∈ lower_bounds s) => hy hx) hs))
    (is_greatest.is_lub (is_glb_cInf hs h))

theorem cInf_upper_bounds_eq_cSup {α : Type u_1} [conditionally_complete_lattice α] {s : set α}
    (h : bdd_above s) (hs : set.nonempty s) : Inf (upper_bounds s) = Sup s :=
  is_glb.unique
    (is_glb_cInf h
      (set.nonempty.mono (fun (x : α) (hx : x ∈ s) (y : α) (hy : y ∈ upper_bounds s) => hy hx) hs))
    (is_least.is_glb (is_lub_cSup hs h))

/--Introduction rule to prove that b is the supremum of s: it suffices to check that b
is larger than all elements of s, and that this is not the case of any `w<b`.-/
theorem cSup_intro {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {b : α}
    (_x : set.nonempty s) :
    (∀ (a : α), a ∈ s → a ≤ b) → (∀ (w : α), w < b → ∃ (a : α), ∃ (H : a ∈ s), w < a) → Sup s = b :=
  sorry

/--Introduction rule to prove that b is the infimum of s: it suffices to check that b
is smaller than all elements of s, and that this is not the case of any `w>b`.-/
theorem cInf_intro {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {b : α}
    (_x : set.nonempty s) :
    (∀ (a : α), a ∈ s → b ≤ a) → (∀ (w : α), b < w → ∃ (a : α), ∃ (H : a ∈ s), a < w) → Inf s = b :=
  sorry

/--b < Sup s when there is an element a in s with b < a, when s is bounded above.
This is essentially an iff, except that the assumptions for the two implications are
slightly different (one needs boundedness above for one direction, nonemptiness and linear
order for the other one), so we formulate separately the two implications, contrary to
the complete_lattice case.-/
theorem lt_cSup_of_lt {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {a : α} {b : α}
    (_x : bdd_above s) : a ∈ s → b < a → b < Sup s :=
  fun (_x_1 : a ∈ s) (_x_2 : b < a) => lt_of_lt_of_le _x_2 (le_cSup _x _x_1)

/--Inf s < b when there is an element a in s with a < b, when s is bounded below.
This is essentially an iff, except that the assumptions for the two implications are
slightly different (one needs boundedness below for one direction, nonemptiness and linear
order for the other one), so we formulate separately the two implications, contrary to
the complete_lattice case.-/
theorem cInf_lt_of_lt {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {a : α} {b : α}
    (_x : bdd_below s) : a ∈ s → a < b → Inf s < b :=
  fun (_x_1 : a ∈ s) (_x_2 : a < b) => lt_of_le_of_lt (cInf_le _x _x_1) _x_2

/-- If all elements of a nonempty set `s` are less than or equal to all elements
of a nonempty set `t`, then there exists an element between these sets. -/
theorem exists_between_of_forall_le {α : Type u_1} [conditionally_complete_lattice α] {s : set α}
    {t : set α} (sne : set.nonempty s) (tne : set.nonempty t)
    (hst : ∀ (x : α), x ∈ s → ∀ (y : α), y ∈ t → x ≤ y) :
    set.nonempty (upper_bounds s ∩ lower_bounds t) :=
  Exists.intro (Inf t)
    { left := fun (x : α) (hx : x ∈ s) => le_cInf tne (hst x hx),
      right := fun (y : α) (hy : y ∈ t) => cInf_le (set.nonempty.mono hst sne) hy }

/--The supremum of a singleton is the element of the singleton-/
@[simp] theorem cSup_singleton {α : Type u_1} [conditionally_complete_lattice α] (a : α) :
    Sup (singleton a) = a :=
  is_greatest.cSup_eq is_greatest_singleton

/--The infimum of a singleton is the element of the singleton-/
@[simp] theorem cInf_singleton {α : Type u_1} [conditionally_complete_lattice α] (a : α) :
    Inf (singleton a) = a :=
  is_least.cInf_eq is_least_singleton

/--If a set is bounded below and above, and nonempty, its infimum is less than or equal to
its supremum.-/
theorem cInf_le_cSup {α : Type u_1} [conditionally_complete_lattice α] {s : set α}
    (hb : bdd_below s) (ha : bdd_above s) (ne : set.nonempty s) : Inf s ≤ Sup s :=
  is_glb_le_is_lub (is_glb_cInf ne hb) (is_lub_cSup ne ha) ne

/--The sup of a union of two sets is the max of the suprema of each subset, under the assumptions
that all sets are bounded above and nonempty.-/
theorem cSup_union {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {t : set α}
    (hs : bdd_above s) (sne : set.nonempty s) (ht : bdd_above t) (tne : set.nonempty t) :
    Sup (s ∪ t) = Sup s ⊔ Sup t :=
  is_lub.cSup_eq (is_lub.union (is_lub_cSup sne hs) (is_lub_cSup tne ht)) (set.nonempty.inl sne)

/--The inf of a union of two sets is the min of the infima of each subset, under the assumptions
that all sets are bounded below and nonempty.-/
theorem cInf_union {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {t : set α}
    (hs : bdd_below s) (sne : set.nonempty s) (ht : bdd_below t) (tne : set.nonempty t) :
    Inf (s ∪ t) = Inf s ⊓ Inf t :=
  is_glb.cInf_eq (is_glb.union (is_glb_cInf sne hs) (is_glb_cInf tne ht)) (set.nonempty.inl sne)

/--The supremum of an intersection of two sets is bounded by the minimum of the suprema of each
set, if all sets are bounded above and nonempty.-/
theorem cSup_inter_le {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {t : set α}
    (_x : bdd_above s) : bdd_above t → set.nonempty (s ∩ t) → Sup (s ∩ t) ≤ Sup s ⊓ Sup t :=
  sorry

/--The infimum of an intersection of two sets is bounded below by the maximum of the
infima of each set, if all sets are bounded below and nonempty.-/
theorem le_cInf_inter {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {t : set α}
    (_x : bdd_below s) : bdd_below t → set.nonempty (s ∩ t) → Inf s ⊔ Inf t ≤ Inf (s ∩ t) :=
  sorry

/-- The supremum of insert a s is the maximum of a and the supremum of s, if s is
nonempty and bounded above.-/
theorem cSup_insert {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {a : α}
    (hs : bdd_above s) (sne : set.nonempty s) : Sup (insert a s) = a ⊔ Sup s :=
  is_lub.cSup_eq (is_lub.insert a (is_lub_cSup sne hs)) (set.insert_nonempty a s)

/-- The infimum of insert a s is the minimum of a and the infimum of s, if s is
nonempty and bounded below.-/
theorem cInf_insert {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {a : α}
    (hs : bdd_below s) (sne : set.nonempty s) : Inf (insert a s) = a ⊓ Inf s :=
  is_glb.cInf_eq (is_glb.insert a (is_glb_cInf sne hs)) (set.insert_nonempty a s)

@[simp] theorem cInf_Ici {α : Type u_1} [conditionally_complete_lattice α] {a : α} :
    Inf (set.Ici a) = a :=
  is_least.cInf_eq is_least_Ici

@[simp] theorem cSup_Iic {α : Type u_1} [conditionally_complete_lattice α] {a : α} :
    Sup (set.Iic a) = a :=
  is_greatest.cSup_eq is_greatest_Iic

/--The indexed supremum of two functions are comparable if the functions are pointwise comparable-/
theorem csupr_le_csupr {α : Type u_1} {ι : Sort u_3} [conditionally_complete_lattice α] {f : ι → α}
    {g : ι → α} (B : bdd_above (set.range g)) (H : ∀ (x : ι), f x ≤ g x) : supr f ≤ supr g :=
  sorry

/--The indexed supremum of a function is bounded above by a uniform bound-/
theorem csupr_le {α : Type u_1} {ι : Sort u_3} [conditionally_complete_lattice α] [Nonempty ι]
    {f : ι → α} {c : α} (H : ∀ (x : ι), f x ≤ c) : supr f ≤ c :=
  cSup_le (set.range_nonempty f)
    (eq.mpr
      (id
        (Eq._oldrec (Eq.refl (∀ (b : α), b ∈ set.range f → b ≤ c)) (propext set.forall_range_iff)))
      H)

/--The indexed supremum of a function is bounded below by the value taken at one point-/
theorem le_csupr {α : Type u_1} {ι : Sort u_3} [conditionally_complete_lattice α] {f : ι → α}
    (H : bdd_above (set.range f)) (c : ι) : f c ≤ supr f :=
  le_cSup H (set.mem_range_self c)

/--The indexed infimum of two functions are comparable if the functions are pointwise comparable-/
theorem cinfi_le_cinfi {α : Type u_1} {ι : Sort u_3} [conditionally_complete_lattice α] {f : ι → α}
    {g : ι → α} (B : bdd_below (set.range f)) (H : ∀ (x : ι), f x ≤ g x) : infi f ≤ infi g :=
  sorry

/--The indexed minimum of a function is bounded below by a uniform lower bound-/
theorem le_cinfi {α : Type u_1} {ι : Sort u_3} [conditionally_complete_lattice α] [Nonempty ι]
    {f : ι → α} {c : α} (H : ∀ (x : ι), c ≤ f x) : c ≤ infi f :=
  le_cInf (set.range_nonempty f)
    (eq.mpr
      (id
        (Eq._oldrec (Eq.refl (∀ (b : α), b ∈ set.range f → c ≤ b)) (propext set.forall_range_iff)))
      H)

/--The indexed infimum of a function is bounded above by the value taken at one point-/
theorem cinfi_le {α : Type u_1} {ι : Sort u_3} [conditionally_complete_lattice α] {f : ι → α}
    (H : bdd_below (set.range f)) (c : ι) : infi f ≤ f c :=
  cInf_le H (set.mem_range_self c)

@[simp] theorem cinfi_const {α : Type u_1} {ι : Sort u_3} [conditionally_complete_lattice α]
    [hι : Nonempty ι] {a : α} : (infi fun (b : ι) => a) = a :=
  eq.mpr
    (id
      (Eq._oldrec (Eq.refl ((infi fun (b : ι) => a) = a)) (infi.equations._eqn_1 fun (b : ι) => a)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (Inf (set.range fun (b : ι) => a) = a)) set.range_const))
      (eq.mpr (id (Eq._oldrec (Eq.refl (Inf (singleton a) = a)) (cInf_singleton a))) (Eq.refl a)))

@[simp] theorem csupr_const {α : Type u_1} {ι : Sort u_3} [conditionally_complete_lattice α]
    [hι : Nonempty ι] {a : α} : (supr fun (b : ι) => a) = a :=
  eq.mpr
    (id
      (Eq._oldrec (Eq.refl ((supr fun (b : ι) => a) = a)) (supr.equations._eqn_1 fun (b : ι) => a)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (Sup (set.range fun (b : ι) => a) = a)) set.range_const))
      (eq.mpr (id (Eq._oldrec (Eq.refl (Sup (singleton a) = a)) (cSup_singleton a))) (Eq.refl a)))

theorem infi_unique {α : Type u_1} {ι : Sort u_3} [conditionally_complete_lattice α] [unique ι]
    {s : ι → α} : (infi fun (i : ι) => s i) = s Inhabited.default :=
  sorry

theorem supr_unique {α : Type u_1} {ι : Sort u_3} [conditionally_complete_lattice α] [unique ι]
    {s : ι → α} : (supr fun (i : ι) => s i) = s Inhabited.default :=
  sorry

@[simp] theorem infi_unit {α : Type u_1} [conditionally_complete_lattice α] {f : Unit → α} :
    (infi fun (x : Unit) => f x) = f Unit.unit :=
  sorry

@[simp] theorem supr_unit {α : Type u_1} [conditionally_complete_lattice α] {f : Unit → α} :
    (supr fun (x : Unit) => f x) = f Unit.unit :=
  sorry

/-- Nested intervals lemma: if `f` is a monotonically increasing sequence, `g` is a monotonically
decreasing sequence, and `f n ≤ g n` for all `n`, then `⨆ n, f n` belongs to all the intervals
`[f n, g n]`. -/
theorem csupr_mem_Inter_Icc_of_mono_incr_of_mono_decr {α : Type u_1} {β : Type u_2}
    [conditionally_complete_lattice α] [Nonempty β] [semilattice_sup β] {f : β → α} {g : β → α}
    (hf : monotone f) (hg : ∀ {m n : β}, m ≤ n → g n ≤ g m) (h : ∀ (n : β), f n ≤ g n) :
    (supr fun (n : β) => f n) ∈ set.Inter fun (n : β) => set.Icc (f n) (g n) :=
  sorry

/-- Nested intervals lemma: if `[f n, g n]` is a monotonically decreasing sequence of nonempty
closed intervals, then `⨆ n, f n` belongs to all the intervals `[f n, g n]`. -/
theorem csupr_mem_Inter_Icc_of_mono_decr_Icc {α : Type u_1} {β : Type u_2}
    [conditionally_complete_lattice α] [Nonempty β] [semilattice_sup β] {f : β → α} {g : β → α}
    (h : ∀ {m n : β}, m ≤ n → set.Icc (f n) (g n) ⊆ set.Icc (f m) (g m))
    (h' : ∀ (n : β), f n ≤ g n) :
    (supr fun (n : β) => f n) ∈ set.Inter fun (n : β) => set.Icc (f n) (g n) :=
  csupr_mem_Inter_Icc_of_mono_incr_of_mono_decr
    (fun (m n : β) (hmn : m ≤ n) => and.left (iff.mp (set.Icc_subset_Icc_iff (h' n)) (h hmn)))
    (fun (m n : β) (hmn : m ≤ n) => and.right (iff.mp (set.Icc_subset_Icc_iff (h' n)) (h hmn))) h'

/-- Nested intervals lemma: if `[f n, g n]` is a monotonically decreasing sequence of nonempty
closed intervals, then `⨆ n, f n` belongs to all the intervals `[f n, g n]`. -/
theorem csupr_mem_Inter_Icc_of_mono_decr_Icc_nat {α : Type u_1} [conditionally_complete_lattice α]
    {f : ℕ → α} {g : ℕ → α} (h : ∀ (n : ℕ), set.Icc (f (n + 1)) (g (n + 1)) ⊆ set.Icc (f n) (g n))
    (h' : ∀ (n : ℕ), f n ≤ g n) :
    (supr fun (n : ℕ) => f n) ∈ set.Inter fun (n : ℕ) => set.Icc (f n) (g n) :=
  csupr_mem_Inter_Icc_of_mono_decr_Icc (monotone_of_monotone_nat h) h'

protected instance pi.conditionally_complete_lattice {ι : Type u_1} {α : ι → Type u_2}
    [(i : ι) → conditionally_complete_lattice (α i)] :
    conditionally_complete_lattice ((i : ι) → α i) :=
  conditionally_complete_lattice.mk lattice.sup lattice.le lattice.lt sorry sorry sorry sorry sorry
    sorry lattice.inf sorry sorry sorry Sup Inf sorry sorry sorry sorry

/-- When b < Sup s, there is an element a in s with b < a, if s is nonempty and the order is
a linear order. -/
theorem exists_lt_of_lt_cSup {α : Type u_1} [conditionally_complete_linear_order α] {s : set α}
    {b : α} (hs : set.nonempty s) (hb : b < Sup s) : ∃ (a : α), ∃ (H : a ∈ s), b < a :=
  sorry

/--
Indexed version of the above lemma `exists_lt_of_lt_cSup`.
When `b < supr f`, there is an element `i` such that `b < f i`.
-/
theorem exists_lt_of_lt_csupr {α : Type u_1} {ι : Sort u_3} [conditionally_complete_linear_order α]
    {b : α} [Nonempty ι] {f : ι → α} (h : b < supr f) : ∃ (i : ι), b < f i :=
  sorry

/--When Inf s < b, there is an element a in s with a < b, if s is nonempty and the order is
a linear order.-/
theorem exists_lt_of_cInf_lt {α : Type u_1} [conditionally_complete_linear_order α] {s : set α}
    {b : α} (hs : set.nonempty s) (hb : Inf s < b) : ∃ (a : α), ∃ (H : a ∈ s), a < b :=
  sorry

/--
Indexed version of the above lemma `exists_lt_of_cInf_lt`
When `infi f < a`, there is an element `i` such that `f i < a`.
-/
theorem exists_lt_of_cinfi_lt {α : Type u_1} {ι : Sort u_3} [conditionally_complete_linear_order α]
    {a : α} [Nonempty ι] {f : ι → α} (h : infi f < a) : ∃ (i : ι), f i < a :=
  sorry

/--Introduction rule to prove that b is the supremum of s: it suffices to check that
1) b is an upper bound
2) every other upper bound b' satisfies b ≤ b'.-/
theorem cSup_intro' {α : Type u_1} [conditionally_complete_linear_order α] {s : set α} {b : α}
    (_x : set.nonempty s) (h_is_ub : ∀ (a : α), a ∈ s → a ≤ b)
    (h_b_le_ub : ∀ (ub : α), (∀ (a : α), a ∈ s → a ≤ ub) → b ≤ ub) : Sup s = b :=
  le_antisymm ((fun (this : Sup s ≤ b) => this) (cSup_le _x h_is_ub))
    ((fun (this : b ≤ Sup s) => this)
      (h_b_le_ub (Sup s) fun (a : α) => le_cSup (Exists.intro b h_is_ub)))

theorem cSup_empty {α : Type u_1} [conditionally_complete_linear_order_bot α] : Sup ∅ = ⊥ :=
  conditionally_complete_linear_order_bot.cSup_empty

namespace nat

protected instance has_Inf : has_Inf ℕ :=
  has_Inf.mk
    fun (s : set ℕ) =>
      dite (∃ (n : ℕ), n ∈ s) (fun (h : ∃ (n : ℕ), n ∈ s) => nat.find h)
        fun (h : ¬∃ (n : ℕ), n ∈ s) => 0

protected instance has_Sup : has_Sup ℕ :=
  has_Sup.mk
    fun (s : set ℕ) =>
      dite (∃ (n : ℕ), ∀ (a : ℕ), a ∈ s → a ≤ n)
        (fun (h : ∃ (n : ℕ), ∀ (a : ℕ), a ∈ s → a ≤ n) => nat.find h)
        fun (h : ¬∃ (n : ℕ), ∀ (a : ℕ), a ∈ s → a ≤ n) => 0

theorem Inf_def {s : set ℕ} (h : set.nonempty s) : Inf s = nat.find h := dif_pos h

theorem Sup_def {s : set ℕ} (h : ∃ (n : ℕ), ∀ (a : ℕ), a ∈ s → a ≤ n) : Sup s = nat.find h :=
  dif_pos h

@[simp] theorem Inf_eq_zero {s : set ℕ} : Inf s = 0 ↔ 0 ∈ s ∨ s = ∅ := sorry

theorem Inf_mem {s : set ℕ} (h : set.nonempty s) : Inf s ∈ s :=
  eq.mpr (id (Eq._oldrec (Eq.refl (Inf s ∈ s)) (Inf_def h))) (nat.find_spec h)

theorem not_mem_of_lt_Inf {s : set ℕ} {m : ℕ} (hm : m < Inf s) : ¬m ∈ s :=
  or.dcases_on (set.eq_empty_or_nonempty s)
    (fun (h : s = ∅) => Eq._oldrec (fun (hm : m < Inf ∅) => set.not_mem_empty m) (Eq.symm h) hm)
    fun (h : set.nonempty s) =>
      nat.find_min h (eq.mp (Eq._oldrec (Eq.refl (m < Inf s)) (Inf_def h)) hm)

protected theorem Inf_le {s : set ℕ} {m : ℕ} (hm : m ∈ s) : Inf s ≤ m :=
  eq.mpr (id (Eq._oldrec (Eq.refl (Inf s ≤ m)) (Inf_def (Exists.intro m hm))))
    (nat.find_min' (Exists.intro m hm) hm)

/-- This instance is necessary, otherwise the lattice operations would be derived via
conditionally_complete_linear_order_bot and marked as noncomputable. -/
protected instance lattice : lattice ℕ := Mathlib.lattice_of_linear_order

protected instance conditionally_complete_linear_order_bot :
    conditionally_complete_linear_order_bot ℕ :=
  conditionally_complete_linear_order_bot.mk lattice.sup order_bot.le order_bot.lt sorry sorry sorry
    sorry sorry sorry lattice.inf sorry sorry sorry Sup Inf sorry sorry sorry sorry sorry
    linear_order.decidable_le linear_order.decidable_eq linear_order.decidable_lt order_bot.bot
    sorry sorry

end nat

namespace with_top

/-- The Sup of a non-empty set is its least upper bound for a conditionally
complete lattice with a top. -/
theorem is_lub_Sup' {β : Type u_1} [conditionally_complete_lattice β] {s : set (with_top β)}
    (hs : set.nonempty s) : is_lub s (Sup s) :=
  sorry

theorem is_lub_Sup {α : Type u_1} [conditionally_complete_linear_order_bot α]
    (s : set (with_top α)) : is_lub s (Sup s) :=
  sorry

/-- The Inf of a bounded-below set is its greatest lower bound for a conditionally
complete lattice with a top. -/
theorem is_glb_Inf' {β : Type u_1} [conditionally_complete_lattice β] {s : set (with_top β)}
    (hs : bdd_below s) : is_glb s (Inf s) :=
  sorry

theorem is_glb_Inf {α : Type u_1} [conditionally_complete_linear_order_bot α]
    (s : set (with_top α)) : is_glb s (Inf s) :=
  dite (bdd_below s) (fun (hs : bdd_below s) => is_glb_Inf' hs)
    fun (hs : ¬bdd_below s) =>
      False._oldrec (hs (Exists.intro ⊥ (id (id fun (a : with_top α) (ᾰ : a ∈ s) => bot_le))))

protected instance complete_linear_order {α : Type u_1}
    [conditionally_complete_linear_order_bot α] : complete_linear_order (with_top α) :=
  complete_linear_order.mk lattice.sup linear_order.le linear_order.lt sorry sorry sorry sorry sorry
    sorry lattice.inf sorry sorry sorry order_top.top sorry order_bot.bot sorry Sup Inf sorry sorry
    sorry sorry sorry (classical.dec_rel LessEq) linear_order.decidable_eq linear_order.decidable_lt

theorem coe_Sup {α : Type u_1} [conditionally_complete_linear_order_bot α] {s : set α}
    (hb : bdd_above s) : ↑(Sup s) = supr fun (a : α) => supr fun (H : a ∈ s) => ↑a :=
  sorry

theorem coe_Inf {α : Type u_1} [conditionally_complete_linear_order_bot α] {s : set α}
    (hs : set.nonempty s) : ↑(Inf s) = infi fun (a : α) => infi fun (H : a ∈ s) => ↑a :=
  sorry

end with_top

namespace enat

protected instance complete_linear_order : complete_linear_order enat :=
  complete_linear_order.mk bounded_lattice.sup linear_order.le linear_order.lt linear_order.le_refl
    linear_order.le_trans linear_order.le_antisymm bounded_lattice.le_sup_left
    bounded_lattice.le_sup_right bounded_lattice.sup_le bounded_lattice.inf
    bounded_lattice.inf_le_left bounded_lattice.inf_le_right bounded_lattice.le_inf
    bounded_lattice.top bounded_lattice.le_top bounded_lattice.bot bounded_lattice.bot_le
    (fun (s : set enat) => coe_fn (equiv.symm with_top_equiv) (Sup (⇑with_top_equiv '' s)))
    (fun (s : set enat) => coe_fn (equiv.symm with_top_equiv) (Inf (⇑with_top_equiv '' s))) sorry
    sorry sorry sorry linear_order.le_total linear_order.decidable_le linear_order.decidable_eq
    linear_order.decidable_lt

end enat

protected instance order_dual.conditionally_complete_lattice (α : Type u_1)
    [conditionally_complete_lattice α] : conditionally_complete_lattice (order_dual α) :=
  conditionally_complete_lattice.mk lattice.sup lattice.le lattice.lt sorry sorry sorry sorry sorry
    sorry lattice.inf sorry sorry sorry Sup Inf cInf_le le_cInf le_cSup cSup_le

protected instance order_dual.conditionally_complete_linear_order (α : Type u_1)
    [conditionally_complete_linear_order α] : conditionally_complete_linear_order (order_dual α) :=
  conditionally_complete_linear_order.mk conditionally_complete_lattice.sup
    conditionally_complete_lattice.le conditionally_complete_lattice.lt sorry sorry sorry sorry
    sorry sorry conditionally_complete_lattice.inf sorry sorry sorry
    conditionally_complete_lattice.Sup conditionally_complete_lattice.Inf sorry sorry sorry sorry
    sorry linear_order.decidable_le linear_order.decidable_eq linear_order.decidable_lt

namespace monotone

/-! A monotone function into a conditionally complete lattice preserves the ordering properties of
`Sup` and `Inf`. -/

theorem le_cSup_image {α : Type u_1} {β : Type u_2} [preorder α] [conditionally_complete_lattice β]
    {f : α → β} (h_mono : monotone f) {s : set α} {c : α} (hcs : c ∈ s) (h_bdd : bdd_above s) :
    f c ≤ Sup (f '' s) :=
  le_cSup (map_bdd_above h_mono h_bdd) (set.mem_image_of_mem f hcs)

theorem cSup_image_le {α : Type u_1} {β : Type u_2} [preorder α] [conditionally_complete_lattice β]
    {f : α → β} (h_mono : monotone f) {s : set α} (hs : set.nonempty s) {B : α}
    (hB : B ∈ upper_bounds s) : Sup (f '' s) ≤ f B :=
  cSup_le (set.nonempty.image f hs) (mem_upper_bounds_image h_mono hB)

theorem cInf_image_le {α : Type u_1} {β : Type u_2} [preorder α] [conditionally_complete_lattice β]
    {f : α → β} (h_mono : monotone f) {s : set α} {c : α} (hcs : c ∈ s) (h_bdd : bdd_below s) :
    Inf (f '' s) ≤ f c :=
  le_cSup_image (fun (x y : order_dual α) (hxy : x ≤ y) => h_mono hxy) hcs h_bdd

theorem le_cInf_image {α : Type u_1} {β : Type u_2} [preorder α] [conditionally_complete_lattice β]
    {f : α → β} (h_mono : monotone f) {s : set α} (hs : set.nonempty s) {B : α}
    (hB : B ∈ lower_bounds s) : f B ≤ Inf (f '' s) :=
  cSup_image_le (fun (x y : order_dual α) (hxy : x ≤ y) => h_mono hxy) hs hB

end monotone

/-!
### Complete lattice structure on `with_top (with_bot α)`

If `α` is a `conditionally_complete_lattice`, then we show that `with_top α` and `with_bot α`
also inherit the structure of conditionally complete lattices. Furthermore, we show
that `with_top (with_bot α)` naturally inherits the structure of a complete lattice. Note that
for α a conditionally complete lattice, `Sup` and `Inf` both return junk values
for sets which are empty or unbounded. The extension of `Sup` to `with_top α` fixes
the unboundedness problem and the extension to `with_bot α` fixes the problem with
the empty set.

This result can be used to show that the extended reals [-∞, ∞] are a complete lattice.
-/

/-- Adding a top element to a conditionally complete lattice gives a conditionally complete lattice -/
protected instance with_top.conditionally_complete_lattice {α : Type u_1}
    [conditionally_complete_lattice α] : conditionally_complete_lattice (with_top α) :=
  conditionally_complete_lattice.mk lattice.sup lattice.le lattice.lt sorry sorry sorry sorry sorry
    sorry lattice.inf sorry sorry sorry Sup Inf sorry sorry sorry sorry

/-- Adding a bottom element to a conditionally complete lattice gives a conditionally complete lattice -/
protected instance with_bot.conditionally_complete_lattice {α : Type u_1}
    [conditionally_complete_lattice α] : conditionally_complete_lattice (with_bot α) :=
  conditionally_complete_lattice.mk lattice.sup lattice.le lattice.lt sorry sorry sorry sorry sorry
    sorry lattice.inf sorry sorry sorry Sup Inf sorry sorry sorry sorry

/-- Adding a bottom and a top to a conditionally complete lattice gives a bounded lattice-/
protected instance with_top.with_bot.bounded_lattice {α : Type u_1}
    [conditionally_complete_lattice α] : bounded_lattice (with_top (with_bot α)) :=
  bounded_lattice.mk lattice.sup order_bot.le order_bot.lt sorry sorry sorry sorry sorry sorry
    lattice.inf sorry sorry sorry order_top.top sorry order_bot.bot sorry

theorem with_bot.cSup_empty {α : Type u_1} [conditionally_complete_lattice α] : Sup ∅ = ⊥ := sorry

protected instance with_top.with_bot.complete_lattice {α : Type u_1}
    [conditionally_complete_lattice α] : complete_lattice (with_top (with_bot α)) :=
  complete_lattice.mk bounded_lattice.sup bounded_lattice.le bounded_lattice.lt sorry sorry sorry
    sorry sorry sorry bounded_lattice.inf sorry sorry sorry bounded_lattice.top sorry
    bounded_lattice.bot sorry Sup Inf sorry sorry sorry sorry

/-! ### Subtypes of conditionally complete linear orders

In this section we give conditions on a subset of a conditionally complete linear order, to ensure
that the subtype is itself conditionally complete.

We check that an `ord_connected` set satisfies these conditions.

TODO There are several possible variants; the `conditionally_complete_linear_order` could be changed
to `conditionally_complete_linear_order_bot` or `complete_linear_order`.
-/

/-- `has_Sup` structure on a nonempty subset `s` of an object with `has_Sup`. This definition is
non-canonical (it uses `default s`); it should be used only as here, as an auxiliary instance in the
construction of the `conditionally_complete_linear_order` structure. -/
def subset_has_Sup {α : Type u_1} (s : set α) [has_Sup α] [Inhabited ↥s] : has_Sup ↥s :=
  has_Sup.mk
    fun (t : set ↥s) =>
      dite (Sup (coe '' t) ∈ s)
        (fun (ht : Sup (coe '' t) ∈ s) => { val := Sup (coe '' t), property := ht })
        fun (ht : ¬Sup (coe '' t) ∈ s) => Inhabited.default

@[simp] theorem subset_Sup_def {α : Type u_1} (s : set α) [has_Sup α] [Inhabited ↥s] :
    Sup =
        fun (t : set ↥s) =>
          dite (Sup (coe '' t) ∈ s)
            (fun (ht : Sup (coe '' t) ∈ s) => { val := Sup (coe '' t), property := ht })
            fun (ht : ¬Sup (coe '' t) ∈ s) => Inhabited.default :=
  rfl

theorem subset_Sup_of_within {α : Type u_1} (s : set α) [has_Sup α] [Inhabited ↥s] {t : set ↥s}
    (h : Sup (coe '' t) ∈ s) : Sup (coe '' t) = ↑(Sup t) :=
  sorry

/-- `has_Inf` structure on a nonempty subset `s` of an object with `has_Inf`. This definition is
non-canonical (it uses `default s`); it should be used only as here, as an auxiliary instance in the
construction of the `conditionally_complete_linear_order` structure. -/
def subset_has_Inf {α : Type u_1} (s : set α) [has_Inf α] [Inhabited ↥s] : has_Inf ↥s :=
  has_Inf.mk
    fun (t : set ↥s) =>
      dite (Inf (coe '' t) ∈ s)
        (fun (ht : Inf (coe '' t) ∈ s) => { val := Inf (coe '' t), property := ht })
        fun (ht : ¬Inf (coe '' t) ∈ s) => Inhabited.default

@[simp] theorem subset_Inf_def {α : Type u_1} (s : set α) [has_Inf α] [Inhabited ↥s] :
    Inf =
        fun (t : set ↥s) =>
          dite (Inf (coe '' t) ∈ s)
            (fun (ht : Inf (coe '' t) ∈ s) => { val := Inf (coe '' t), property := ht })
            fun (ht : ¬Inf (coe '' t) ∈ s) => Inhabited.default :=
  rfl

theorem subset_Inf_of_within {α : Type u_1} (s : set α) [has_Inf α] [Inhabited ↥s] {t : set ↥s}
    (h : Inf (coe '' t) ∈ s) : Inf (coe '' t) = ↑(Inf t) :=
  sorry

/-- For a nonempty subset of a conditionally complete linear order to be a conditionally complete
linear order, it suffices that it contain the `Sup` of all its nonempty bounded-above subsets, and
the `Inf` of all its nonempty bounded-below subsets. -/
def subset_conditionally_complete_linear_order {α : Type u_1} (s : set α)
    [conditionally_complete_linear_order α] [Inhabited ↥s]
    (h_Sup : ∀ {t : set ↥s}, set.nonempty t → bdd_above t → Sup (coe '' t) ∈ s)
    (h_Inf : ∀ {t : set ↥s}, set.nonempty t → bdd_below t → Inf (coe '' t) ∈ s) :
    conditionally_complete_linear_order ↥s :=
  conditionally_complete_linear_order.mk lattice.sup lattice.le lattice.lt sorry sorry sorry sorry
    sorry sorry lattice.inf sorry sorry sorry Sup Inf sorry sorry sorry sorry sorry
    linear_order.decidable_le linear_order.decidable_eq linear_order.decidable_lt

/-- The `Sup` function on a nonempty `ord_connected` set `s` in a conditionally complete linear
order takes values within `s`, for all nonempty bounded-above subsets of `s`. -/
theorem Sup_within_of_ord_connected {α : Type u_1} [conditionally_complete_linear_order α]
    {s : set α} [hs : set.ord_connected s] {t : set ↥s} (ht : set.nonempty t)
    (h_bdd : bdd_above t) : Sup (coe '' t) ∈ s :=
  sorry

/-- The `Inf` function on a nonempty `ord_connected` set `s` in a conditionally complete linear
order takes values within `s`, for all nonempty bounded-below subsets of `s`. -/
theorem Inf_within_of_ord_connected {α : Type u_1} [conditionally_complete_linear_order α]
    {s : set α} [hs : set.ord_connected s] {t : set ↥s} (ht : set.nonempty t)
    (h_bdd : bdd_below t) : Inf (coe '' t) ∈ s :=
  sorry

/-- A nonempty `ord_connected` set in a conditionally complete linear order is naturally a
conditionally complete linear order. -/
protected instance ord_connected_subset_conditionally_complete_linear_order {α : Type u_1}
    (s : set α) [conditionally_complete_linear_order α] [Inhabited ↥s] [set.ord_connected s] :
    conditionally_complete_linear_order ↥s :=
  subset_conditionally_complete_linear_order s Sup_within_of_ord_connected
    Inf_within_of_ord_connected

end Mathlib


/-
Copied and modified from Lean 4 `./src/Lean/PrettyPrinter/Delaborator/Builtins.lean`
-/
import Lean
import LeanCodePrompts.Utils
open Lean Meta Elab Term Parser PrettyPrinter
/-!
# Verbose delaborators

We define delaborators that preserve more information than the default ones, and corresponding syntax to allow this.
-/
namespace LeanAide.Meta

open Elab Term in
/-- Syntax `proof =: prop` for a proof with its type recorded -/
elab (name:=proved_prop) "(" a:term "=:" b:term ")": term => do
    let b ← elabType b
    let a ← elabTermEnsuringType a (some b)
    guard (← isProof a)
    return a

example :=  ((by decide) =: 1 ≤ 2 )

open Delaborator SubExpr
def checkExprDepth (e: Expr) : DelabM Unit := do
  let depth ← getDelabBound
  if e.approxDepth > depth then
    failure

def checkDepth : DelabM Unit := do
  let depth ← getDelabBound
  let e ← getExpr
  if e.approxDepth > depth then
    failure

/-- Modified top-level delaborator to expand if proof to `proof =: prop`-/
partial def delabVerbose : Delab := do
  checkMaxHeartbeats "delab"
  let e ← getExpr
  let isProof := !e.isAtomic && (← (try Meta.isProof e catch _ => pure false))
  let k ← getExprKind
  let stx ← delabFor k <|> (liftM $ show MetaM _ from throwError "don't know how to delaborate '{k}'")
  if (← getPPOption getPPAnalyzeTypeAscriptions <&&> getPPOption getPPAnalysisNeedsType <&&> pure !e.isMData) then
    let typeStx ← withType delab
    `(($stx : $typeStx)) >>= annotateCurPos
  else if isProof then
    let typeStx ← withType delab
    `(($stx =: $typeStx)) >>= annotateCurPos
  else
    return stx

/-- Helper wrapping a proof `proof` as `proof =: prop` -/
def wrapInType (e: Expr)(stx: Term) : Delab := do
  let isProof ← (try Meta.isProof e catch _ => pure false)
  if isProof then
    let typeStx ← withType delab
    `(($stx =: $typeStx)) >>= annotateCurPos
  else
    return stx

open Lean.Parser.Term
open TSyntax.Compat

def fvarPrefix : Name := "freeVariable"

@[delab app]
def delabAppExplicitVerbose : Delab := do
  checkDepth
  let paramKinds ← getParamKinds
  let tagAppFn ← getPPOption getPPTagAppFns
  let (fnStx, _, argStxs) ← withAppFnArgs
    (do
      let stx ← withOptionAtCurrPos `pp.tagAppFns tagAppFn delabAppFn
      let needsExplicit := stx.raw.getKind != ``Lean.Parser.Term.explicit
      let stx ← if needsExplicit then `(@$stx) else pure stx
      pure (stx, paramKinds.toList, #[]))
    (fun ⟨fnStx, paramKinds, argStxs⟩ => do
      let isInstImplicit := match paramKinds with
                            | [] => false
                            | param :: _ => param.bInfo == BinderInfo.instImplicit
      let argStx ← if ← getPPOption getPPAnalysisHole then `(_)
                   else if isInstImplicit == true then
                     let stx ← if ← getPPOption getPPInstances then delab else `(_)
                     if ← getPPOption getPPInstanceTypes then
                       let typeStx ← withType delab
                       `(($stx : $typeStx))
                     else pure stx
                   else delabVerbose
      pure (fnStx, paramKinds.tailD [], argStxs.push argStx))
  let stx := Syntax.mkApp fnStx argStxs
  wrapInType (← getExpr) stx

@[delab app]
def delabAppImplicit : Delab := do
  checkDepth
  -- TODO: always call the unexpanders, make them guard on the right # args?
  let paramKinds ← getParamKinds
  if ← getPPOption getPPExplicit then
    if paramKinds.any (fun param => !param.isRegularExplicit) then failure

  -- If the application has an implicit function type, fall back to delabAppExplicit.
  -- This is e.g. necessary for `@Eq`.
  let isImplicitApp ← try
      let ty ← whnf (← inferType (← getExpr))
      pure <| ty.isForall && (ty.binderInfo == BinderInfo.implicit || ty.binderInfo == BinderInfo.instImplicit)
    catch _ => pure false
  if isImplicitApp then failure

  let tagAppFn ← getPPOption getPPTagAppFns
  let (fnStx, _, argStxs) ← withAppFnArgs
    (withOptionAtCurrPos `pp.tagAppFns tagAppFn <|
      return (← delabAppFn, paramKinds.toList, #[]))
    (fun (fnStx, paramKinds, argStxs) => do
      let arg ← getExpr
      let opts ← getOptions
      let mkNamedArg (name : Name) (argStx : Syntax) : DelabM Syntax := do
        `(Parser.Term.namedArgument| ($(mkIdent name) := $argStx))
      let argStx? : Option Syntax ←
        if ← getPPOption getPPAnalysisSkip then pure none
        else if ← getPPOption getPPAnalysisHole then `(_)
        else
          match paramKinds with
          | [] => delabVerbose
          | param :: rest =>
            if param.defVal.isSome && rest.isEmpty then
              let v := param.defVal.get!
              if !v.hasLooseBVars && v == arg then pure none else delabVerbose
            else if !param.isRegularExplicit && param.defVal.isNone then
              if ← getPPOption getPPAnalysisNamedArg <||> (pure (param.name == `motive) <&&> shouldShowMotive arg opts) then some <$> mkNamedArg param.name (← delabVerbose) else pure none
            else delabVerbose
      let argStxs := match argStx? with
        | none => argStxs
        | some stx => argStxs.push stx
      pure (fnStx, paramKinds.tailD [], argStxs))
  let stx := Syntax.mkApp fnStx argStxs
  let stx ← wrapInType (← getExpr) stx
  if ← isRegularApp then
    (guard (← getPPOption getPPNotation) *> unexpandRegularApp stx)
    <|> (guard (← getPPOption getPPStructureInstances) *> unexpandStructureInstance stx)
    <|> pure stx
  else pure stx

/--
  Extract arguments of motive applications from the matcher type.
  For the example below: `#[#[`([])], #[`(a::as)]]` -/
private partial def delabPatterns (st : AppMatchState) : DelabM (Array (Array Term)) :=
  withReader (fun ctx => { ctx with inPattern := true, optionsPerPos := {} }) do
    let ty ← instantiateForall st.matcherTy st.params
    -- need to reduce `let`s that are lifted into the matcher type
    forallTelescopeReducing ty fun params _ => do
      -- skip motive and discriminators
      let alts := Array.ofSubarray params[1 + st.discrs.size:]
      alts.mapIdxM fun idx alt => do
        let ty ← inferType alt
        -- TODO: this is a hack; we are accessing the expression out-of-sync with the position
        -- Currently, we reset `optionsPerPos` at the beginning of `delabPatterns` to avoid
        -- incorrectly considering annotations.
        withTheReader SubExpr ({ · with expr := ty }) $
          usingNames st.varNames[idx]! do
            withAppFnArgs (pure #[]) (fun pats => do pure $ pats.push (← delabVerbose))
where
  usingNames {α} (varNames : Array Name) (x : DelabM α) : DelabM α :=
    usingNamesAux 0 varNames x
  usingNamesAux {α} (i : Nat) (varNames : Array Name) (x : DelabM α) : DelabM α :=
    if i < varNames.size then
      withBindingBody varNames[i]! <| usingNamesAux (i+1) varNames x
    else
      x

/-- Skip `numParams` binders, and execute `x varNames` where `varNames` contains the new binder names. -/
private partial def skippingBinders {α} (numParams : Nat) (x : Array Name → DelabM α) : DelabM α :=
  loop numParams #[]
where
  loop : Nat → Array Name → DelabM α
    | 0,   varNames => x varNames
    | n+1, varNames => do
      let rec visitLambda : DelabM α := do
        let varName := (← getExpr).bindingName!.eraseMacroScopes
        -- Pattern variables cannot shadow each other
        if varNames.contains varName then
          let varName := (← getLCtx).getUnusedName varName
          withBindingBody varName do
            loop n (varNames.push varName)
        else
          withBindingBodyUnusedName fun id => do
            loop n (varNames.push id.getId)
      let e ← getExpr
      if e.isLambda then
        visitLambda
      else
        -- eta expand `e`
        let e ← forallTelescopeReducing (← inferType e) fun xs _ => do
          if xs.size == 1 && (← inferType xs[0]!).isConstOf ``Unit then
            -- `e` might be a thunk create by the dependent pattern matching compiler, and `xs[0]` may not even be a pattern variable.
            -- If it is a pattern variable, it doesn't look too bad to use `()` instead of the pattern variable.
            -- If it becomes a problem in the future, we should modify the dependent pattern matching compiler, and make sure
            -- it adds an annotation to distinguish these two cases.
            mkLambdaFVars xs (mkApp e (mkConst ``Unit.unit))
          else
            mkLambdaFVars xs (mkAppN e xs)
        withTheReader SubExpr (fun ctx => { ctx with expr := e }) visitLambda

/--
  Delaborate applications of "matchers" such as
  ```
  List.map.match_1 : {α : Type _} →
    (motive : List α → Sort _) →
      (x : List α) → (Unit → motive List.nil) → ((a : α) → (as : List α) → motive (a :: as)) → motive x
  ```
-/
@[delab app]
def delabAppMatch : Delab := whenPPOption getPPNotation <| whenPPOption getPPMatch do
  checkDepth
  -- incrementally fill `AppMatchState` from arguments
  let st ← withAppFnArgs
    (do
      let (Expr.const c us) ← getExpr | failure
      let (some info) ← getMatcherInfo? c | failure
      let matcherTy ← instantiateTypeLevelParams (← getConstInfo c) us
      return { matcherTy, info : AppMatchState })
    (fun st => do
      if st.params.size < st.info.numParams then
        return { st with params := st.params.push (← getExpr) }
      else if st.motive.isNone then
        -- store motive argument separately
        let lamMotive ← getExpr
        let piMotive ← lambdaTelescope lamMotive fun xs body => mkForallFVars xs body
        -- TODO: pp.analyze has not analyzed `piMotive`, only `lamMotive`
        -- Thus the binder types won't have any annotations
        let piStx ← withTheReader SubExpr (fun cfg => { cfg with expr := piMotive }) delabVerbose
        let named ← getPPOption getPPAnalysisNamedArg
        return { st with motive := (piStx, lamMotive), motiveNamed := named }
      else if st.discrs.size < st.info.numDiscrs then
        let idx := st.discrs.size
        let discr ← delabVerbose
        if let some hName := st.info.discrInfos[idx]!.hName? then
          -- TODO: we should check whether the corresponding binder name, matches `hName`.
          -- If it does not we should pretty print this `match` as a regular application.
          return { st with discrs := st.discrs.push (← `(matchDiscr| $(mkIdent hName) : $discr)) }
        else
          return { st with discrs := st.discrs.push (← `(matchDiscr| $discr:term)) }
      else if st.rhss.size < st.info.altNumParams.size then
        /- We save the variables names here to be able to implement safe_shadowing.
           The pattern delaboration must use the names saved here. -/
        let (varNames, rhs) ← skippingBinders st.info.altNumParams[st.rhss.size]! fun varNames => do
          let rhs ← delabVerbose
          return (varNames, rhs)
        return { st with rhss := st.rhss.push rhs, varNames := st.varNames.push varNames }
      else
        return { st with moreArgs := st.moreArgs.push (← delabVerbose) })

  if st.discrs.size < st.info.numDiscrs || st.rhss.size < st.info.altNumParams.size then
    -- underapplied
    failure

  match st.discrs, st.rhss with
  | #[discr], #[] =>
    let stx ← `(nomatch $discr)
    return Syntax.mkApp stx st.moreArgs
  | _,        #[] => failure
  | _,        _   =>
    let pats ← delabPatterns st
    let stx ← do
      let (piStx, lamMotive) := st.motive.get!
      let opts ← getOptions
      -- TODO: disable the match if other implicits are needed?
      if ← pure st.motiveNamed <||> shouldShowMotive lamMotive opts then
        `(match (motive := $piStx) $[$st.discrs:matchDiscr],* with $[| $pats,* => $st.rhss]*)
      else
        `(match $[$st.discrs:matchDiscr],* with $[| $pats,* => $st.rhss]*)
    return Syntax.mkApp stx st.moreArgs

/--
  Delaborate applications of the form `(fun x => b) v` as `let_fun x := v; b`
-/
def delabLetFun : Delab := do
  let stxV ← withAppArg delabVerbose
  withAppFn do
    let Expr.lam n _ b _ ← getExpr | unreachable!
    let n ← getUnusedName n b
    let stxB ← withBindingBody n delabVerbose
    if ← getPPOption getPPLetVarTypes <||> getPPOption getPPAnalysisLetVarType then
      let stxT ← withBindingDomain delab
      `(let_fun $(mkIdent n) : $stxT := $stxV; $stxB)
    else
      `(let_fun $(mkIdent n) := $stxV; $stxB)

@[delab mdata]
def delabMData : Delab := do
  -- checkDepth
  if let some _ := inaccessible? (← getExpr) then
    let s ← withMDataExpr delabVerbose
    if (← read).inPattern then
      `(.($s)) -- We only include the inaccessible annotation when we are delaborating patterns
    else
      return s
  else if isLetFun (← getExpr) && getPPNotation (← getOptions) then
    withMDataExpr <| delabLetFun
  else if let some _ := isLHSGoal? (← getExpr) then
    withMDataExpr <| withAppFn <| withAppArg <| delabVerbose
  else
    withMDataOptions delabVerbose

/--
Check for a `Syntax.ident` of the given name anywhere in the tree.
This is usually a bad idea since it does not check for shadowing bindings,
but in the delaborator we assume that bindings are never shadowed.
-/
partial def hasIdent (id : Name) : Syntax → Bool
  | Syntax.ident _ _ id' _ => id == id'
  | Syntax.node _ _ args   => args.any (hasIdent id)
  | _                      => false

/--
Return `true` iff current binder should be merged with the nested
binder, if any, into a single binder group:
* both binders must have same binder info and domain
* they cannot be inst-implicit (`[a b : A]` is not valid syntax)
* `pp.binderTypes` must be the same value for both terms
* prefer `fun a b` over `fun (a b)`
-/
private def shouldGroupWithNext : DelabM Bool := do
  let e ← getExpr
  let ppEType ← getPPOption (getPPBinderTypes e)
  let go (e' : Expr) := do
    let ppE'Type ← withBindingBody `_ $ getPPOption (getPPBinderTypes e)
    pure $ e.binderInfo == e'.binderInfo &&
      e.bindingDomain! == e'.bindingDomain! &&
      e'.binderInfo != BinderInfo.instImplicit &&
      ppEType == ppE'Type &&
      (e'.binderInfo != BinderInfo.default || ppE'Type)
  match e with
  | Expr.lam _ _     e'@(Expr.lam _ _ _ _) _     => go e'
  | Expr.forallE _ _ e'@(Expr.forallE _ _ _ _) _ => go e'
  | _ => pure false
where
  getPPBinderTypes (e : Expr) :=
    if e.isForall then getPPPiBinderTypes else getPPFunBinderTypes

def withBindingBodyUnusedName {α} (d : Syntax → DelabM α) : DelabM α := do
  let n ← getUnusedName (← getExpr).bindingName! (← getExpr).bindingBody!
  -- let n := n.append "domVar"
  let stxN ← annotateCurPos (mkIdent n)
  withBindingBody n $ d stxN

/-- `delabBinders` modified to never group -/
private partial def delabBinders (delabGroup : Array Syntax → Syntax → Delab) : optParam (Array Syntax) #[] → Delab
  | curNames => do
      -- don't group => delab body and prepend current binder group
      let (stx, stxN) ← withBindingBodyUnusedName fun stxN => return (← delab, stxN)
      delabGroup (curNames.push stxN) stx

/-- `delabLam` modified to always have type info and never group -/
@[delab lam]
def delabLam : Delab :=
  delabBinders fun curNames stxBody => do
    let e ← getExpr
    let stxT ← withBindingDomain delab
    let ppTypes := true
    let usedDownstream := curNames.any (fun n => hasIdent n.getId stxBody)

    let blockImplicitLambda := true

    if !blockImplicitLambda then
      pure stxBody -- empty case
    else
      let defaultCase (_ : Unit) : Delab := do
        if ppTypes then -- always true
          -- "default" binder group is the only one that expects binder names
          -- as a term, i.e. a single `Syntax.ident` or an application thereof
          let stxCurNames ←
            if curNames.size > 1 then -- never
              `($(curNames.get! 0) $(curNames.eraseIdx 0)*)
            else -- always ungrouped
              pure $ curNames.get! 0;
          `(funBinder| ($stxCurNames : $stxT))
        else -- never
          pure curNames.back  -- here `curNames.size == 1`
      let group ← match e.binderInfo, ppTypes with
        | BinderInfo.default,        _      => defaultCase ()
        | BinderInfo.implicit,       true   => `(funBinder| {$curNames* : $stxT})
        | BinderInfo.implicit,       false  => `(funBinder| {$curNames*})
        | BinderInfo.strictImplicit, true   => `(funBinder| ⦃$curNames* : $stxT⦄)
        | BinderInfo.strictImplicit, false  => `(funBinder| ⦃$curNames*⦄)
        | BinderInfo.instImplicit,   _     =>
          if usedDownstream then `(funBinder| [$curNames.back : $stxT])  -- here `curNames.size == 1`
          else  `(funBinder| [$stxT])
      let (binders, stxBody) :=
        match stxBody with
        | `(fun $binderGroups* => $stxBody) => (#[group] ++ binderGroups, stxBody)
        | _                                 => (#[group], stxBody)
      -- if ← getPPOption getPPUnicodeFun then
      `(fun $binders* ↦ $stxBody)
      -- else
      --   `(fun $binders* => $stxBody)

/--
Similar to `delabBinders`, but tracking whether `forallE` is dependent or not.

See issue #1571
-/
private partial def delabForallBinders (delabGroup : Array Syntax → Bool → Syntax → Delab) (curNames : Array Syntax := #[]) (curDep := false) : Delab := do
  let dep := !(← getExpr).isArrow
  if !curNames.isEmpty && dep != curDep then
    -- don't group
    delabGroup curNames curDep (← delabVerbose)
  else
    let curDep := dep
    -- if ← shouldGroupWithNext then
    --   -- group with nested binder => recurse immediately
    --   withBindingBodyUnusedName fun stxN => delabForallBinders delabGroup (curNames.push stxN) curDep
    -- else
      -- don't group => delab body and prepend current binder group
      let (stx, stxN) ← withBindingBodyUnusedName fun stxN => return (← delab, stxN)
      delabGroup (curNames.push stxN) curDep stx

@[delab forallE]
def delabForall : Delab := do
  delabForallBinders fun curNames dependent stxBody => do
    let e ← getExpr
    let prop ← try isProp e catch _ => pure false
    let stxT ← withBindingDomain delab
    let group ← match e.binderInfo with
    | BinderInfo.implicit       => `(bracketedBinderF|{$curNames* : $stxT})
    | BinderInfo.strictImplicit => `(bracketedBinderF|⦃$curNames* : $stxT⦄)
    -- here `curNames.size == 1`
    | BinderInfo.instImplicit   => `(bracketedBinderF|[$curNames.back : $stxT])
    | _                         =>
      -- NOTE: non-dependent arrows are available only for the default binder info
      -- if dependent then
      --   if prop && !(← getPPOption getPPPiBinderTypes) then
      --     return ← `(∀ $curNames:ident*, $stxBody)
      --   else
          `(bracketedBinderF|($curNames* : $stxT))
      -- else
      --   return ← curNames.foldrM (fun _ stxBody => `($stxT → $stxBody)) stxBody
    if prop then
      match stxBody with
      | `(∀ $groups*, $stxBody) => `(∀ $group $groups*, $stxBody)
      | _                       => `(∀ $group, $stxBody)
    else
      `($group:bracketedBinder → $stxBody)

@[delab letE]
def delabLetE : Delab := do
  -- checkDepth
  let Expr.letE n t v b _ ← getExpr | unreachable!
  let n ← getUnusedName n b
  let stxV ← descend v 1 delabVerbose
  let stxB ← withLetDecl n t v fun fvar =>
    let b := b.instantiate1 fvar
    descend b 2 delabVerbose
  if ← getPPOption getPPLetVarTypes <||> getPPOption getPPAnalysisLetVarType then
    let stxT ← descend t 0 delab
    `(let $(mkIdent n) : $stxT := $stxV; $stxB)
  else `(let $(mkIdent n) := $stxV; $stxB)

@[delab app.dite]
def delabDIte : Delab := whenPPOption getPPNotation do
  -- Note: we keep this as a delaborator for now because it actually accesses the expression.
  guard $ (← getExpr).getAppNumArgs == 5
  let c ← withAppFn $ withAppFn $ withAppFn $ withAppArg delabVerbose
  let (t, h) ← withAppFn $ withAppArg $ delabBranch none
  let (e, _) ← withAppArg $ delabBranch h
  `(if $(mkIdent h):ident : $c then $t else $e)
where
  delabBranch (h? : Option Name) : DelabM (Syntax × Name) := do
    let e ← getExpr
    guard e.isLambda
    let h ← match h? with
      | some h => return (← withBindingBody h delabVerbose, h)
      | none   => withBindingBodyUnusedName fun h => do
        return (← delabVerbose, h.getId)

@[delab app.cond]
def delabCond : Delab := whenPPOption getPPNotation do
  -- checkDepth
  guard $ (← getExpr).getAppNumArgs == 4
  let c ← withAppFn $ withAppFn $ withAppArg delabVerbose
  let t ← withAppFn $ withAppArg delabVerbose
  let e ← withAppArg delabVerbose
  `(bif $c then $t else $e)

@[delab app.namedPattern]
def delabNamedPattern : Delab := do
  -- checkDepth
  -- Note: we keep this as a delaborator because it accesses the DelabM context
  guard (← read).inPattern
  guard $ (← getExpr).getAppNumArgs == 4
  let x ← withAppFn $ withAppFn $ withAppArg delab
  let p ← withAppFn $ withAppArg delab
  -- TODO: we should hide `h` if it has an inaccessible name and is not used in the rhs
  let h ← withAppArg delab
  guard x.raw.isIdent
  `($x:ident@$h:ident:$p:term)

-- Sigma and PSigma delaborators
def delabSigmaCore (sigma : Bool) : Delab := whenPPOption getPPNotation do
  checkDepth
  guard $ (← getExpr).getAppNumArgs == 2
  guard $ (← getExpr).appArg!.isLambda
  withAppArg do
    let α ← withBindingDomain delab
    let bodyExpr := (← getExpr).bindingBody!
    withBindingBodyUnusedName fun n => do
      let b ← delabVerbose
      if bodyExpr.hasLooseBVars then
        if sigma then `(($n:ident : $α) × $b) else `(($n:ident : $α) ×' $b)
      else
        if sigma then `((_ : $α) × $b) else `((_ : $α) ×' $b)

@[delab app.Sigma]
def delabSigma : Delab := delabSigmaCore (sigma := true)

@[delab app.PSigma]
def delabPSigma : Delab := delabSigmaCore (sigma := false)

partial def delabDoElems : DelabM (List Syntax) := do
  let e ← getExpr
  checkExprDepth e
  if e.isAppOfArity ``Bind.bind 6 then
    -- Bind.bind.{u, v} : {m : Type u → Type v} → [self : Bind m] → {α β : Type u} → m α → (α → m β) → m β
    let α := e.getAppArgs[2]!
    let ma ← withAppFn $ withAppArg delabVerbose
    withAppArg do
      match (← getExpr) with
      | Expr.lam _ _ body _ =>
        withBindingBodyUnusedName fun n => do
          if body.hasLooseBVars then
            prependAndRec `(doElem|let $n:term ← $ma:term)
          else if α.isConstOf ``Unit || α.isConstOf ``PUnit then
            prependAndRec `(doElem|$ma:term)
          else
            prependAndRec `(doElem|let _ ← $ma:term)
      | _ => failure
  else if e.isLet then
    let Expr.letE n t v b _ ← getExpr | unreachable!
    let n ← getUnusedName n b
    let stxT ← descend t 0 delab
    let stxV ← descend v 1 delabVerbose
    withLetDecl n t v fun fvar =>
      let b := b.instantiate1 fvar
      descend b 2 $
        prependAndRec `(doElem|let $(mkIdent n) : $stxT := $stxV)
  else
    let stx ← delabVerbose
    return [← `(doElem|$stx:term)]
  where
    prependAndRec x : DelabM _ := List.cons <$> x <*> delabDoElems

-- @[delab app.Bind.bind]
-- def delabDo : Delab := whenPPOption getPPNotation do
--   guard <| (← getExpr).isAppOfArity ``Bind.bind 6
--   let elems ← delabDoElems
--   let items ← elems.toArray.mapM (`(doSeqItem|$(·):doElem))
--   `(do $items:doSeqItem*)

structure NameGroups where
  constNames : Array <| Name × Nat := #[]
  freeVarNames : Array Name := #[]
  domVarNames : Array Name := #[]
deriving Inhabited, Repr

def NameGroups.append (base: NameGroups) (n: Name)(d: Nat): NameGroups :=
  match n with
  | Name.str p "freeVar"  =>
    match p with
    | Name.str q "domVar"  => ⟨base.constNames, base.freeVarNames.push q, base.domVarNames⟩
    | _ => ⟨base.constNames, base.freeVarNames.push p, base.domVarNames⟩
  | Name.str q "domVar"  =>
      ⟨base.constNames, base.freeVarNames, base.domVarNames.push q⟩
  | _ => ⟨base.constNames.push (n, d), base.freeVarNames, base.domVarNames⟩

def groupedNames (nd : Array <| Name × Nat) : NameGroups :=
  nd.foldl (fun gp (n, d) => gp.append n d) {}

def lambdaStx?(stx : Syntax) : MetaM <| Option (Syntax × Array Syntax) := do
  match stx with
  | `(fun $args:funBinder* ↦ $body) =>
    return some (body, args)
  | `((fun $args:funBinder* ↦ $body)) =>
    return some (body, args)
  | _ => return none

def appStx?(stx : Syntax) : MetaM <| Option (Syntax × Syntax) := do
  match stx with
  | `($f:term $arg:term) =>
    return some (f, arg)
  | _ => return none

#check Parser.mkIdent

def proofWithProp? (stx : Syntax) : MetaM <| Option (Syntax × Syntax) := do
  match stx with
  | `(($stx =: $typeStx)) =>
    return some (stx, typeStx)
  | _ => return none

def getVar (stx: Syntax) : Option Name :=
match stx with
| `(funBinder|($n:ident)) => some n.getId
| `(funBinder|($n:ident : $_)) => some n.getId
| `(funBinder|{$n:ident : $_}) => some n.getId
| `(funBinder|⦃$n:ident : $_⦄) => some n.getId
| _ => none

def namedArgument? (stx : Syntax) : MetaM <| Option (Syntax × Syntax) := do
  match stx with
  | `(namedArgument|($n:ident := $stx)) =>
    return some (stx, n)
  | _ => return none

end LeanAide.Meta


import condensed.tensor
import for_mathlib.preserves_finite_limits

noncomputable theory

universes u
open_locale tensor_product

open category_theory category_theory.limits opposite

namespace AddCommGroup

@[reassoc]
lemma map_tensor_flip {A B C D : AddCommGroup} (f : A ⟶ B) (g : C ⟶ D) :
  map_tensor f g ≫ (tensor_flip _ _).hom = (tensor_flip _ _).hom ≫ map_tensor g f :=
by { apply AddCommGroup.tensor_ext, intros a c, refl }

end AddCommGroup

namespace Condensed

def tensor_tunit (A : AddCommGroup) (h : AddCommGroup.is_tensor_unit A) :
  tensor_functor.flip.obj A ≅ 𝟭 _ :=
begin
  refine _ ≪≫ (Condensed_ExtrSheaf_equiv Ab).counit_iso,
  refine nat_iso.of_components _ _,
  { intro M,
    refine (Condensed_ExtrSheaf_equiv Ab).functor.map_iso _,
    refine Sheaf.iso.mk _ _ _,
    refine nat_iso.of_components _ _,
    { intro S,
      refine (AddCommGroup.tensor_functor_iso_flip.app _).app _ ≪≫ _,
      refine AddCommGroup.tensor_unit_iso _ _ h, },
    { intros S T f,
      dsimp [ExtrSheaf.tensor, AddCommGroup.tensor_functor_iso_flip],
      simp only [category.assoc],
      erw AddCommGroup.tensor_unit_iso_naturality,
      rw ← AddCommGroup.map_tensor_flip_assoc, refl, } },
  { intros M N f,
    dsimp only [tensor_functor, map_tensor, functor.flip_obj_map,
      functor.comp_map, functor.map_iso_hom],
    simp only [← functor.map_comp], congr' 1,
    ext S : 3,
    dsimp only [Sheaf.category_theory.category_comp_val, ExtrSheaf.map_tensor_val, Sheaf.iso.mk_hom_val,
      nat_iso.of_components_hom_app, nat_trans.comp_app,
      ExtrSheafProd.map_tensor_val_app, iso.trans_hom],
    simp only [category.assoc],
    dsimp [AddCommGroup.tensor_functor_iso_flip],
    rw [AddCommGroup.map_tensor_flip_assoc], congr' 1,
    symmetry, apply AddCommGroup.tensor_unit_iso_naturality, }
end

def tensor_punit :
  tensor_functor.flip.obj (AddCommGroup.of (punit →₀ ℤ)) ≅ 𝟭 _ :=
tensor_tunit _ $
begin
  dsimp [AddCommGroup.is_tensor_unit],
  refine ⟨finsupp.single punit.star 1, _⟩,
  intro B, split,
  { intros f g h, ext ⟨⟩, exact h },
  { intros b, refine ⟨(finsupp.total _ _ _ _).to_add_monoid_hom, _⟩,
    { intro, exact b },
    { dsimp, simp only [finsupp.total_single, one_zsmul], } }
end

-- See comment around L20
instance preserves_mono_tensor_functor (A : Condensed.{u} Ab.{u+1})
  [∀ S : ExtrDisc.{u}, no_zero_smul_divisors ℤ (A.val.obj (op S.val))]
  {X Y : Ab} (f : X ⟶ Y) [mono f] :
  mono ((tensor_functor.obj A).map f) :=
begin
  suffices : mono (ExtrSheaf.map_tensor ((Condensed_ExtrSheaf_equiv Ab).inverse.map (𝟙 A)) f),
  { dsimp only [tensor_functor, map_tensor], resetI, apply_instance },
  constructor, intros X φ ψ h, ext S : 3,
  apply_fun (λ η, η.val.app S) at h,
  dsimp [ExtrSheaf.map_tensor] at h,
  refine (@cancel_mono _ _ _ _ _ _ (id _) _ _).mp h,
  apply_with AddCommGroup.tensor_obj_map_preserves_mono {instances:=ff},
  apply_instance, apply_assumption
end
.

/-
We need one of the following two sorries.
If we prove the first, we can deduce the second using `exact_functor.lean`
But maybe it is easier to just prove `preserves_finite_limits_tensor_functor` second directly.
-/

-- lemma tensor_eval_iso_natural_right
--   (A : (Condensed.{u} Ab.{u+1})) {X Y : Ab} (f : X ⟶ Y) (S : ExtrDisc) :
--   AddCommGroup.map_tensor (𝟙 (A.val.obj (op S.val))) f ≫ (tensor_eval_iso A Y S).inv =
--   (tensor_eval_iso A X S).inv ≫ ((tensor_functor.obj A).map f).val.app (op S.val) :=
-- begin
--   rw [iso.comp_inv_eq],
--   dsimp only [tensor_eval_iso, tensor_functor, map_tensor,
--     functor.map_iso_hom, iso.app_hom, functor.map_iso_inv, iso.app_inv, iso.symm_hom, iso.symm_inv,
--     Sheaf_to_presheaf_map],
--   -- erw [equivalence.unit_app_inverse],
--   admit
-- end

-- lemma tensor_short_exact (A : (Condensed.{u} Ab.{u+1}))
--   [∀ S : ExtrDisc.{u}, no_zero_smul_divisors ℤ (A.val.obj (op S.val))]
--   {X Y Z : Ab} (f : X ⟶ Y) (g : Y ⟶ Z) (hfg : short_exact f g) :
--   short_exact ((tensor_functor.obj A).map f) ((tensor_functor.obj A).map g) :=
-- begin
--   rw short_exact_iff_ExtrDisc, intro S,
--   let eX := tensor_eval_iso A X S,
--   let eY := tensor_eval_iso A Y S,
--   let eZ := tensor_eval_iso A Z S,
--   refine commsq.short_exact.of_iso eX.inv eY.inv eZ.inv _ _ _,
--   { refine (AddCommGroup.tensor_functor.obj _).map f, },
--   { refine (AddCommGroup.tensor_functor.obj _).map g, },
--   { apply AddCommGroup.tensor_short_exact, exact hfg },
--   { apply commsq.of_eq, apply tensor_eval_iso_natural_right },
--   { apply commsq.of_eq, apply tensor_eval_iso_natural_right },
-- end

-- See comment around L20
instance preserves_finite_limits_tensor_functor (A : Condensed.{u} Ab.{u+1})
  [∀ S : ExtrDisc.{u}, no_zero_smul_divisors ℤ (A.val.obj (op S.val))] :
  preserves_finite_limits (tensor_functor.obj A) :=
preserves_finite_limits_of_preserves_mono_preserves_finite_colimits _ $
λ X Y f hf, by { resetI, apply_instance }

end Condensed


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
  have h1 : ∀ A B : Type*, ∀ h : (A ⊕ B) = V, (G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) → (G.colorable 2), from
    assume A B : Type*, assume h : (A ⊕ B) = V, assume h1 : (G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)),
    begin
      have h2 : ∀ a : A, ∃ b : B, (cast (congr_arg _ h) (complete_bipartite_graph A B)) a b, from by auto using [complete_bipartite_graph.fintype_complete],
      have h3 : ∀ b : B, ∃ a : A, (cast (congr_arg _ h) (complete_bipartite_graph A B)) a b, from by auto using [complete_bipartite_graph.fintype_complete],

      have h4 : ∀ v : V, (G v) → (∃ a : A, v = cast (congr_arg _ h) (sum.inl a)) ∨ (∃ b : B, v = cast (congr_arg _ h) (sum.inr b)), from
        assume v : V, assume h4 : (G v),
        begin
          have h5 : (v ∈ set.range (cast (congr_arg _ h) sum.inl)) ∨ (v ∈ set.range (cast (congr_arg _ h) sum.inr)), from by auto [sum.range_iff, set.mem_range],
          cases h5 with h5 h5,
          { show (∃ a : A, v = cast (congr_arg _ h) (sum.inl a)) ∨ (∃ b : B, v = cast (congr_arg _ h) (sum.inr b)), from by auto [set.mem_range, exists.intro] },
          { show (∃ a : A, v = cast (congr_arg _ h) (sum.inl a)) ∨ (∃ b : B, v = cast (congr_arg _ h) (sum.inr b)), from by auto [set.mem_range, exists.intro] },
        end,

      have h5 : ∀ v : V, (G v) → (∃ a : A, v = cast (congr_arg _ h) (sum.inl a)), from
        assume v : V, assume h5 : (G v),
        begin
          have h6 : (∃ a : A, v = cast (congr_arg _ h) (sum.inl a)) ∨ (∃ b : B, v = cast (congr_arg _ h) (sum.inr b)), from by auto [h4],
          cases h6 with h6 h6,
          { show (∃ a : A, v = cast (congr_arg _ h) (sum.inl a)), from by auto [exists.intro] },
          { have h7 : ∀ v : V, (G v) → (∀ b : B, ¬(v = cast (congr_arg _ h) (sum.inr b))), from
              assume v : V, assume h7 : (G v), assume b : B, assume h8 : (v = cast (congr_arg _ h) (sum.inr b)),
              have h9 : (cast (congr_arg _ h) (complete_bipartite_graph A B)) (cast (congr_arg _ h) (sum.inl (classical.some h6))) b, from by auto [complete_bipartite_graph.fintype_complete],
              have h10 : (G (cast (congr_arg _ h) (sum.inl (classical.some h6)))) ∧ (G (cast (congr_arg _ h) (sum.inr b))), from by auto [G.fintype_complete, h1, h9],
              have h11 : (G (cast (congr_arg _ h) (sum.inl (classical.some h6)))), from by auto [h10],
              have h12 : (G (cast (congr_arg _ h) (sum.inr b))), from by auto [h10],
              have h13 : (cast (congr_arg _ h) (sum.inl (classical.some h6))) = (cast (congr_arg _ h) (sum.inr b)), from by auto [h8],
              have h14 : (∃ a : A, (cast (congr_arg _ h) (sum.inl (classical.some h6))) = (cast (congr_arg _ h) (sum.inl a))), from by auto [exists.intro],
              have h15 : (∃ b : B, (cast (congr_arg _ h) (sum.inr b)) = (cast (congr_arg _ h) (sum.inr b))), from by auto [exists.intro],
              have h16 : (∃ a : A, (cast (congr_arg _ h) (sum.inr b)) = (cast (congr_arg _ h) (sum.inl a))), from by auto [exists.intro],
              have h17 : (∃ b : B, (cast (congr_arg _ h) (sum.inl (classical.some h6))) = (cast (congr_arg _ h) (sum.inr b))), from by auto [exists.intro],
              have h18 : (∃ a : A, (cast (congr_arg _ h) (sum.inl (classical.some h6))) = (cast (congr_arg _ h) (sum.inl a))), from by auto [exists.intro],
              have h19 : (∃ a : A, (cast (congr_arg _ h) (sum.inr b)) = (cast (congr_arg _ h) (sum.inl a))), from by auto [exists.intro],
              have h20 : (cast (congr_arg _ h) (sum.inl (classical.some h6))) = (cast (congr_arg _ h) (sum.inr b)), from by auto [h8],
              have h21 : (∃ b : B, (cast (congr_arg _ h) (sum.inl (classical.some h6))) = (cast (congr_arg _ h) (sum.inr b))), from by auto [exists.intro],
              have h22 : (∃ a : A, (cast (congr_arg _ h) (sum.inl (classical.some h6))) = (cast (congr_arg _ h) (sum.inl a))), from by auto [exists.intro],
              have h23 : (∃ a : A, (cast (congr_arg _ h) (sum.inr b)) = (cast (congr_arg _ h) (sum.inl a))), from by auto [exists.intro],
              have h24 : (cast (congr_arg _ h) (sum.inr b)) = (cast (congr_arg _ h) (sum.inl (classical.some h6))), from by auto [h8],
              have h25 : (∃ a : A, (cast (congr_arg _ h) (sum.inr b)) = (cast (congr_arg _ h) (sum.inl a))), from by auto [exists.intro],
              have h26 : (∃ b : B, (cast (congr_arg _ h) (sum.inr b)) = (cast (congr_arg _ h) (sum.inr b))), from by auto [exists.intro],
              have h27 : (∃ a : A, (cast (congr_arg _ h) (sum.inl (classical.some h6))) = (cast (congr_arg _ h) (sum.inl a))), from by auto [exists.intro],
              have h28 : (∃ b : B, (cast (congr_arg _ h) (sum.inl (classical.some h6))) = (cast (congr_arg _ h) (sum.inr b))),
end --Needs more than 2000 tokens!

--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
  have h1: (∀ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) → (G.colorable 2), from
  begin
    assume h,
    have h1: ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from h,
    have h2: ∃ A B, A ⊕ B = V, from h1.elim,
    have h3: ∃ A B, A ⊕ B = V, from h1.elim,
    have h4: ∃ A B, A ⊕ B = V, from h1.elim,
    have h5: G ≤ cast (congr_arg _ h4.2) (complete_bipartite_graph A B), from h1.elim,
    have h6: G ≤ cast (congr_arg _ h4.2) (complete_bipartite_graph A B), from h1.elim,
    have h7: G ≤ cast (congr_arg _ h4.2) (complete_bipartite_graph A B), from h1.elim,
    have h8: G ≤ complete_bipartite_graph A B, from by auto [h7],
    have h9: G ≤ complete_bipartite_graph A B, from h8,
    have h10: G ≤ complete_bipartite_graph A B, from h8,
    have h11: G.colorable 2, from (complete_bipartite_graph A B).colorable 2,
    show G.colorable 2, from h11,
  end,

  have h2: (G.colorable 2) → (∀ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)), from
  begin
    assume h,
    have h1: G.colorable 2, from h,
    have h2: (∀ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)), from
    begin
      assume A B h,
      have h1: G.colorable 2, from h,
      have h2: G.colorable 2, from h1,
      have h3: G.colorable 2, from h1,
      have h4: G ≠ ∅, from (fintype.card G) ≠ 0,
      have h5: G ≠ ∅, from h4,
      have h6: G ≠ ∅, from h4,
      have h7: ∃ v, v ∈ G.vertices, from by auto [exists_mem_of_ne_empty, h6],
      have h8: ∃ v, v ∈ G.vertices, from h7,
      have h9: ∃ v, v ∈ G.vertices, from h7,
      have h10: ∃ v, v ∈ G.vertices, from h7,
      have h11: ∃ v, v ∈ G.vertices, from h7,
      have h12: ∃ v, v ∈ G.vertices, from h7,
      have h13: ∃ v, v ∈ G.vertices, from h7,
      have h14: ∃ v, v ∈ G.vertices, from h7,
      have h15: ∃ v, v ∈ G.vertices, from h7,
      have h16: ∃ v, v ∈ G.vertices, from h7,
      have h17: ∃ v, v ∈ G.vertices, from h7,
      have h18: ∃ v, v ∈ G.vertices, from h7,
      have h19: ∃ v, v ∈ G.vertices, from h7,
      have h20: ∃ v, v ∈ G.vertices, from h7,
      have h21: ∃ v, v ∈ G.vertices, from h7,
      have h22: ∃ v, v ∈ G.vertices, from h7,
      have h23: ∃ v, v ∈ G.vertices, from h7,
      have h24: ∃ v, v ∈ G.vertices, from h7,
      have h25: ∃ v, v ∈ G.vertices, from h7,
      have h26: ∃ v, v ∈ G.vertices, from h7,
      have h27: ∃ v, v ∈ G.vertices, from h7,
      have h28: ∃ v, v ∈ G.vertices, from h7,
      have h29: ∃ v, v ∈ G.vertices, from h7,
      have h30: ∃ v, v ∈ G.vertices, from h7,
      have h31: ∃ v, v ∈ G.vertices, from h7,
      have h32: ∃ v, v ∈ G.vertices, from h7,
      have h33: ∃ v, v ∈ G.vertices, from h7,
      have h34: ∃ v, v ∈ G.vertices, from h7,
      have h35: ∃ v, v ∈ G.vertices, from h7,
      have h36: ∃ v, v ∈ G.vertices, from h7,
      have h37: ∃ v, v ∈ G.vertices, from h7,
      have h38: ∃ v, v ∈ G.vertices, from h7,
      have h39: ∃ v, v ∈ G.vertices, from h7,
      have h40: ∃ v, v ∈ G.vertices, from h7,
      have h41: ∃ v, v ∈ G.vertices, from h7,
      have h42: ∃ v, v ∈ G.vertices, from h7,
      have h43: ∃ v, v ∈ G.vertices, from h7,
      have h44: ∃ v, v ∈ G.vertices, from h7,
      have h45: ∃ v, v ∈ G.vertices, from h7,
      have h46: ∃ v, v ∈ G.vertices, from h7,
      have h47: ∃ v, v ∈ G.vertices, from h7,
      have h48: ∃ v, v ∈ G.vertices, from h7,
      have h49: ∃ v, v ∈ G.vertices, from h7,
      have h50: ∃ v, v ∈ G.vertices, from h7,
      have h51: ∃ v, v ∈ G.vertices, from h7,
      have h52: ∃ v, v ∈ G.vertices, from h7,
      have h53: ∃ v, v ∈ G.vertices, from h7,
      have h54: ∃ v, v ∈ G.vertices, from h7,
      have h55: ∃ v, v ∈ G.vertices, from h7,
      have h56: ∃ v, v ∈ G.vertices, from h7,
      have h57: ∃ v, v ∈ G.vertices, from h7,
      have h58: ∃ v, v ∈ G.vertices, from h7,
      have h59: ∃ v, v ∈ G.vertices, from h7,
      have h60: ∃ v, v ∈ G.vertices, from h7,
      have h61: ∃ v, v ∈ G.vertices, from h7,
      have h62: ∃ v, v ∈ G.vertices, from h7,
      have h63: ∃ v, v ∈ G.vertices, from h7,
      have h64: ∃ v, v ∈ G.vertices, from h7,
      have h65: ∃ v, v ∈ G.vertices, from h7,

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
  have h1 : ∀ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B) → G.colorable 2, from by auto using [complete_bipartite_graph.colorable],
  have h2 : ∀ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)), from by auto using [congr_arg],
  show (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)), from by auto [h1, h2],
end

--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
  split,
  {
    intro h1,
    have h2 : ∀ v : V, ∃ c : fin 2, G.color_vertex v c, from by auto [h1],
    have h3 : ∀ v : V, ∃ c : ℕ, c ∈ {0,1} ∧ G.color_vertex v (c : fin 2), from by auto [h2],
    have h4 : ∀ v : V, ∃ c : ℕ, c = 1 ∧ G.color_vertex v (1 : fin 2) ∨ c = 0 ∧ G.color_vertex v (0 : fin 2), from by auto [h3],
    have h5 : ∀ v : V, ∃ c : ℕ, c = 1 ∧ (G.color_vertex v 1) ∨ c = 0 ∧ (G.color_vertex v 0), from by auto [h4],
    have h6 : ∀ v : V, ∃ c : ℕ, c = 1 ∧ (∀ w : V, G.adj v w → (G.color_vertex w 1)) ∨ c = 0 ∧ (∀ w : V, G.adj v w → (G.color_vertex w 0)), from by auto [h5],
    have h7 : ∀ v : V, ∃ c : ℕ, c = 1 ∧ (∀ w : V, ¬G.adj v w ∨ (G.color_vertex w 1)) ∨ c = 0 ∧ (∀ w : V, ¬G.adj v w ∨ (G.color_vertex w 0)), from by auto [h6],
    have h8 : ∀ v : V, ∃ c : ℕ, c = 1 ∧ (∀ w : V, ¬G.adj v w ∨ (G.color_vertex w 1 ∧ (G.color_vertex w 1 → w = v))) ∨ c = 0 ∧ (∀ w : V, ¬G.adj v w ∨ (G.color_vertex w 0 ∧ (G.color_vertex w 0 → w = v))), from by auto [h7],
    have h9 : ∀ v : V, ∃ c : ℕ, c = 1 ∧ (∀ w : V, ¬G.adj v w ∨ (w = v)) ∨ c = 0 ∧ (∀ w : V, ¬G.adj v w ∨ (w = v)), from by auto [h8],
    have h10 : ∀ v : V, ∃ c : ℕ, c = 1 ∧ (∀ w : V, ¬G.adj v w ∨ (w = v)) ∨ c = 0 ∧ (∀ w : V, ¬G.adj v w ∨ (w = v)), from by auto [h9],
    have h11 : ∀ v : V, ∃ c : ℕ, c = 1 ∧ (∀ w : V, G.adj v w → (w = v)) ∨ c = 0 ∧ (∀ w : V, G.adj v w → (w = v)), from by auto [h10],
    have h12 : ∀ v : V, ∃ c : ℕ, c = 1 ∧ (∀ w : V, G.adj v w → (v = w)) ∨ c = 0 ∧ (∀ w : V, G.adj v w → (v = w)), from by auto [h11],
    have h13 : ∀ v : V, ∃ c : ℕ, c = 1 ∧ (∀ w : V, v = w ∨ ¬G.adj v w) ∨ c = 0 ∧ (∀ w : V, v = w ∨ ¬G.adj v w), from by auto [h12],
    have h14 : ∀ v : V, ∃ c : ℕ, c = 1 ∧ (∀ w : V, v = w ∨ ¬G.adj v w) ∨ c = 0 ∧ (∀ w : V, v = w ∨ ¬G.adj v w), from by auto [h13],

    have h15 : ∃ c : ℕ, ∀ v : V, c = 1 ∨ c = 0, from by auto [h14, exists_or_distrib, forall_and_distrib],
    have h16 : ∃ c : ℕ, ∀ v : V, c = 1 ∨ c = 0, from by auto [h15],
    have h17 : ∃ c : ℕ, ∀ v : V, c = 1 ∨ c = 0, from by auto [h16],
    have h18 : ∃ c : ℕ, ∀ v : V, c = 1 ∨ c = 0, from by auto [h17],
    have h19 : ∃ c : ℕ, ∀ v : V, c = 1 ∨ c = 0, from by auto [h18],
    have h20 : ∃ c : ℕ, ∀ v : V, c = 1 ∨ c = 0, from by auto [h19],
    have h21 : ∃ c : ℕ, ∀ v : V, c = 1 ∨ c = 0, from by auto [h20],
    have h22 : ∃ c : ℕ, ∀ v : V, c = 1 ∨ c = 0, from by auto [h21],
    have h23 : ∃ c : ℕ, ∀ v : V, c = 1 ∨ c = 0, from by auto [h22],
    have h24 : ∃ c : ℕ, ∀ v : V, c = 1 ∨ c = 0, from by auto [h23],
    have h25 : ∃ c : ℕ, ∀ v : V, c = 1 ∨ c = 0, from by auto [h24],
    have h26 : ∃ c : ℕ, ∀ v : V, c = 1 ∨ c = 0, from by auto [h25],
    have h27 : ∃ c : ℕ, ∀ v : V, c = 1 ∨ c = 0, from by auto [h26],
    have h28 : ∃ c : ℕ, ∀ v : V, c = 1 ∨ c = 0, from by auto [h27],
    have h29 : ∃ c : ℕ, ∀ v : V, c = 1 ∨ c = 0, from by auto [h28],
    have h30 : ∃ c : ℕ, ∀ v : V, c = 1 ∨ c = 0, from by auto [h29],
    have h31 : ∃ c : ℕ, ∀ v : V, c = 1 ∨ c = 0, from by auto [h30],
    have h32 : ∃ c : ℕ, ∀ v : V, c = 1 ∨ c = 0, from by auto [h31],
    have h33 : ∃ c : ℕ, ∀ v : V, c = 1 ∨ c = 0, from by auto [h32],
    have h34 : ∃ c : ℕ, ∀ v : V, c = 1 ∨ c = 0, from by auto [h33],
    have h35 : ∃ c : ℕ, ∀ v : V, c = 1 ∨ c = 0, from by auto [h34],
    have h36 : ∃ c : ℕ, ∀ v : V, c = 1 ∨ c = 0, from by auto [h35],
    have h37 : ∃ c : ℕ, ∀ v : V, c = 1 ∨ c = 0, from by auto [h36],
    have h38 : ∃ c : ℕ, ∀ v : V, c = 1 ∨ c = 0, from by auto [h37],
    have h39 : ∃ c : ℕ, ∀ v : V, c = 1 ∨ c = 0, from by auto [h38],
    have h40 : ∃ c : ℕ, ∀ v : V, c = 1 ∨ c = 0, from by auto [h39],
    have h41 : ∃ c : ℕ, ∀ v : V, c = 1 ∨ c = 0, from by auto [h40],
    have h42 : ∃ c : ℕ, ∀ v : V,
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
  have h0 : 2 = 2, from rfl,
  have h1 : ∀ A B : Type*, A ⊕ B ≃ A × B, from by auto using [equiv.prod_congr_right],
  have h2 : ∀ A B : Type*, (A ⊕ B) ≃ (A × B), from by auto using [equiv.prod_congr_right],
  have h3 : ∀ A B : Type*, (A ⊕ B) ≃ (A × B), from by auto using [equiv.prod_congr_right],
  have h4 : ∀ A B : Type*, (A ⊕ B) ≃ (A × B), from by auto using [equiv.prod_congr_right],
  have h5 : ∀ A B : Type*, (A ⊕ B) ≃ (A × B), from by auto using [equiv.prod_congr_right],
  have h6 : ∀ A B : Type*, (A ⊕ B) ≃ (A × B), from by auto using [equiv.prod_congr_right],
  have h7 : ∀ A B : Type*, (A ⊕ B) ≃ (A × B), from by auto using [equiv.prod_congr_right],
  have h8 : ∀ A B : Type*, (A ⊕ B) ≃ (A × B), from by auto using [equiv.prod_congr_right],
  have h9 : ∀ A B : Type*, (A ⊕ B) ≃ (A × B), from by auto using [equiv.prod_congr_right],
  have h10 : ∀ A B : Type*, (A ⊕ B) ≃ (A × B), from by auto using [equiv.prod_congr_right],
  have h11 : ∀ A B : Type*, (A ⊕ B) ≃ (A × B), from by auto using [equiv.prod_congr_right],
  have h12 : ∀ A B : Type*, (A ⊕ B) ≃ (A × B), from by auto using [equiv.prod_congr_right],
  have h13 : ∀ A B : Type*, (A ⊕ B) ≃ (A × B), from by auto using [equiv.prod_congr_right],
  have h14 : ∀ A B : Type*, (A ⊕ B) ≃ (A × B), from by auto using [equiv.prod_congr_right],
  have h15 : ∀ A B : Type*, (A ⊕ B) ≃ (A × B), from by auto using [equiv.prod_congr_right],
  have h16 : ∀ A B : Type*, (A ⊕ B) ≃ (A × B), from by auto using [equiv.prod_congr_right],
  have h17 : ∀ A B : Type*, (A ⊕ B) ≃ (A × B), from by auto using [equiv.prod_congr_right],
  have h18 : ∀ A B : Type*, (A ⊕ B) ≃ (A × B), from by auto using [equiv.prod_congr_right],
  have h19 : ∀ A B : Type*, (A ⊕ B) ≃ (A × B), from by auto using [equiv.prod_congr_right],
  have h20 : ∀ A B : Type*, (A ⊕ B) ≃ (A × B), from by auto using [equiv.prod_congr_right],
  have h21 : ∀ A B : Type*, (A ⊕ B) ≃ (A × B), from by auto using [equiv.prod_congr_right],
  have h22 : ∀ A B : Type*, (A ⊕ B) ≃ (A × B), from by auto using [equiv.prod_congr_right],
  have h23 : ∀ A B : Type*, (A ⊕ B) ≃ (A × B), from by auto using [equiv.prod_congr_right],
  have h24 : ∀ A B : Type*, (A ⊕ B) ≃ (A × B), from by auto using [equiv.prod_congr_right],
  have h25 : ∀ A B : Type*, (A ⊕ B) ≃ (A × B), from by auto using [equiv.prod_congr_right],
  have h26 : ∀ A B : Type*, (A ⊕ B) ≃ (A × B), from by auto using [equiv.prod_congr_right],
  have h27 : ∀ A B : Type*, (A ⊕ B) ≃ (A × B), from by auto using [equiv.prod_congr_right],
  have h28 : ∀ A B : Type*, (A ⊕ B) ≃ (A × B), from by auto using [equiv.prod_congr_right],
  have h29 : ∀ A B : Type*, (A ⊕ B) ≃ (A × B), from by auto using [equiv.prod_congr_right],
  have h30 : ∀ A B : Type*, (A ⊕ B) ≃ (A × B), from by auto using [equiv.prod_congr_right],
  have h31 : ∀ A B : Type*, (A ⊕ B) ≃ (A × B), from by auto using [equiv.prod_congr_right],
  have h32 : ∀ A B : Type*, (A ⊕ B) ≃ (A × B), from by auto using [equiv.prod_congr_right],
  have h33 : ∀ A B : Type*, (A ⊕ B) ≃ (A × B), from by auto using [equiv.prod_congr_right],
  have h34 : ∀ A B : Type*, (A ⊕ B) ≃ (A × B), from by auto using [equiv.prod_congr_right],
  have h35 : ∀ A B : Type*, (A ⊕ B) ≃ (A × B), from by auto using [equiv.prod_congr_right],
  have h36 : ∀ A B : Type*, (A ⊕ B) ≃ (A × B), from by auto using [equiv.prod_congr_right],
  have h37 : ∀ A B : Type*, (A ⊕ B) ≃ (A × B), from by auto using [equiv.prod_congr_right],
  have h38 : ∀ A B : Type*, (A ⊕ B) ≃ (A × B), from by auto using [equiv.prod_congr_right],
  have h39 : ∀ A B : Type*, (A ⊕ B) ≃ (A × B), from by auto using [equiv.prod_congr_right],
  have h40 : ∀ A B : Type*, (A ⊕ B) ≃ (A × B), from by auto using [equiv.prod_congr_right],
  have h41 : ∀ A B : Type*, (A ⊕ B) ≃ (A × B), from by auto using [equiv.prod_congr_right],
  have h42 : ∀ A B : Type*, (A ⊕ B) ≃ (A × B), from by auto using [equiv.prod_congr_right],
  have h43 : ∀ A B : Type*, (A ⊕ B) ≃ (A × B), from by auto using [equiv.prod_congr_right],
  have h44 : ∀ A B : Type*, (A ⊕ B) ≃ (A × B), from by auto using [equiv.prod_congr_right],
  have h45 : ∀ A B : Type*, (A ⊕ B) ≃ (A × B), from by auto using [equiv.prod_congr_right],
  have h46 : ∀ A B : Type*, (A ⊕ B) ≃ (A × B), from by auto using [equiv.prod_congr_right],
  have h47 : ∀ A
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,

  show ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
  obtain (f : V → fin 2) (h2 : ∀ (v w : V), f v = f w → v.adj w = ff), from h1,

  let f' : V → bool := λ (v : V), f v = 0,
  let A : Type* := f' ⁻¹' {b : bool | b},
  let B : Type* := f' ⁻¹' {b : bool | ¬ b},

  have h3 : A ⊕ B = V, from by auto [subtype.ext_iff, set.subset.antisymm],

  have h4 : ∀ (v : V), v ∈ A → v.adj w = ff, from by auto [set.subset.elim, h2],
  have h5 : ∀ (v : V), v ∈ B → v.adj w = ff, from by auto [set.subset.elim, h2],

  have h6 : G ≤ cast (congr_arg _ h3) (complete_bipartite_graph A B), from by auto [subgraph.subgraph_iff, subtype.subtype_ext_iff, h4, h5],

  show ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from ⟨A, B, h3, h6⟩,

  assume h1 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B),

  show G.colorable 2, from
  obtain (A B : Type*) (h2 : (A ⊕ B) = V) (h3 : G ≤ cast (congr_arg _ h2) (complete_bipartite_graph A B)), from h1,

  let f' : A ⊕ B → fin 2 := λ (v : A ⊕ B), ite (v.1 ∈ A) 0 1,
  let f : V → fin 2 := λ (v : V), f' v,

  have h4 : ∀ (v w : V), f v = f w → v.adj w = ff, from by auto [subtype.subtype_ext_iff, set.subset.elim, h3],

  show G.colorable 2, from ⟨f, h4⟩
end

--OUTPUT 7
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,
  {
    intro h,
    cases h with f hf,
    let A := (finset.image f (finset.filter (λ x, f x = (0 : ℕ)) (finset.univ))).to_set,
    let B := (finset.image f (finset.filter (λ x, f x = (1 : ℕ)) (finset.univ))).to_set,
    have h1 : G.V = A ∪ B,
    {
      apply set.ext,
      intro x,
      split,
      {
        intro h,
        cases h with h1 h2,
        cases h1,
        {
          have h3 : x ∈ (A : set V), from (finset.mem_image).mp h1,
          show x ∈ (A ∪ B), from set.mem_union_left (A ∪ B) (A : set V) h3,
        },
        {
          have h3 : x ∈ (B : set V), from (finset.mem_image).mp h1,
          show x ∈ (A ∪ B), from set.mem_union_right (A ∪ B) (B : set V) h3,
        },
      },
      {
        intro h,
        cases h with h1 h2,
        cases h1,
        {
          have h3 : x ∈ (A : set V), from h1,
          let a := x,
          have h4 : (a : V) ∈ (finset.univ : finset V), from set.mem_to_finset h3,
          have h5 : (a : V) ∈ (finset.filter (λ x, f x = (0 : ℕ)) (finset.univ : finset V)), from (finset.filter_mem).mp h4 h2,
          have h6 : (finset.mem_image).mpr h5 ∈ (finset.image f (finset.filter (λ x, f x = (0 : ℕ)) (finset.univ : finset V))), from h5,
          show x ∈ (A ∪ B), from set.mem_union_left (A ∪ B) (A : set V) h6,
        },
        {
          have h3 : x ∈ (B : set V), from h1,
          let b := x,
          have h4 : (b : V) ∈ (finset.univ : finset V), from set.mem_to_finset h3,
          have h5 : (b : V) ∈ (finset.filter (λ x, f x = (1 : ℕ)) (finset.univ : finset V)), from (finset.filter_mem).mp h4 h2,
          have h6 : (finset.mem_image).mpr h5 ∈ (finset.image f (finset.filter (λ x, f x = (1 : ℕ)) (finset.univ : finset V))), from h5,
          show x ∈ (A ∪ B), from set.mem_union_right (A ∪ B) (B : set V) h6,
        },
      },
    },
    have h2 : A ∩ B = ∅,
    {
      apply set.eq_empty_iff_forall_not_mem.mpr,
      intro x,
      intro h,
      cases h with h1 h2,
      let a := x,
      let b := x,
      have h3 : (a : V) ∈ (finset.univ : finset V), from set.mem_to_finset h1,
      have h4 : (a : V) ∈ (finset.filter (λ x, f x = (0 : ℕ)) (finset.univ : finset V)), from (finset.filter_mem).mp h3 h2.1,
      have h5 : (b : V) ∈ (finset.univ : finset V), from set.mem_to_finset h2.2,
      have h6 : (b : V) ∈ (finset.filter (λ x, f x = (1 : ℕ)) (finset.univ : finset V)), from (finset.filter_mem).mp h5 h2.2,
      have h7 : (finset.mem_image).mpr h4 ∈ (finset.image f (finset.filter (λ x, f x = (0 : ℕ)) (finset.univ : finset V))), from h4,
      have h8 : (finset.mem_image).mpr h6 ∈ (finset.image f (finset.filter (λ x, f x = (1 : ℕ)) (finset.univ : finset V))), from h6,
      have h9 : (a : V) = (b : V), from set.mem_of_mem_union_right (A : set V) (B : set V) h7 h8,
      have h10 : f a = f b, from congr_fun h9,
      show false, from h10.symm ▸ h2.2,
    },
    have h3 : G.E ⊆ (cartesian_product A B).to_set,
    {
      rintro ⟨x, y⟩ ⟨h4, h5⟩,
      split,
      {
        have h6 : x ∈ G.V, from hf.left,
        have h7 : y ∈ G.V, from hf.right,
        have h8 : x ∈ A ∪ B, from h1 x h6,
        have h9 : y ∈ A ∪ B, from h1 y h7,
        cases h8,
        {
          rw h8 at h9,
          have h10 : y ∈ B, from h9,
          rw ←h8 at h5,
          have h11 : y ∈ A, from h5,
          show y ∈ B ∧ x ∈ A, from ⟨h10, h11⟩
        },
        {
          cases h9,
          {
            rw h9 at h8,
            have h10 : x ∈ B, from h8,
            rw h9 at h5,
            have h11 : x ∈ A, from h5,
            show x ∈ B ∧ y ∈ A, from ⟨h10, h11⟩
          },
          {
            rw h8 at h9,
            rw h9 at h5,
            have h10 : x ∈ A, from h8,
            have h11 : y ∈ A, from h9,
            show x ∈ B ∧ y ∈ A, from ⟨h10, h11⟩
          }
        }
      },
      {
        show x ≠ y, from hf.right,
      }
    },
    have h4 : G.E = (cartesian_product A B).to_set, from set.subset.antisymm h3 (set.subset_univ _),
    let h5 := (set.eq_univ_iff_forall_mem).mp h4,
    have h6 : A ⊕ B = G.V, from set.ext h1,
    have h7 : (A ⊕ B) ≃ G.V, from set.equiv.ext _ h6.symm,
    have h8 : (A ⊕ B) ≃ G.V, from h7,
    have h9 : (A ⊕ B) ≃ G.V, from h8,
    have h10 : G ≤ cast (congr_arg _ h9) (complete_bipartite_graph A B), from
    begin
      unfold complete_bipartite_graph,
      unfold simple_graph,
      unfold graph.simple_graph,
      unfold graph.E,
      unfold graph.V,
      split,
      {
        rintros ⟨x, y⟩ h11
end --Needs more than 2000 tokens!

--OUTPUT 8
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 ⟨c, hc⟩ := h1,
        obtain ⟨A, B, h⟩ := hc,
        use [A, B, h],
        convert simple_graph.cast_mono (congr_arg _ h) hc,
        rw simple_graph.cast_eq_iff_eq_domain,
        intro x,
        cases x,
        refl,
    },
    {
        rintros ⟨A, B, h⟩,
        rw ← h,
        use [sum.inl, sum.inr],
        convert simple_graph.cast_mono (congr_arg _ h) complete_bipartite_graph_colorable,
        rw simple_graph.cast_eq_iff_eq_domain,
        intro x,
        cases x,
        refl,
    }
end

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

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

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

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

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

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

Thus $A \cap B \in \powerset S$ and closure is proved.
{{qed}}
-/
theorem power_set_intersection_closed {α : Type*} (S : set α) : ∀ A B ∈ 𝒫 S, (A ∩ B) ∈ 𝒫 S :=
begin
  assume (A : set α) (hA : A ∈ 𝒫 S) (B : set α) (hB : B ∈ 𝒫 S),
  have h1 : (A ⊆ S) ∧ (B ⊆ S), from by auto [set.subset_of_mem_powerset, set.subset_of_mem_powerset],
  have h2 : (A ∩ B) ⊆ A, from by auto [set.inter_subset_left],
  have h3 : (A ∩ B) ⊆ S, from by auto [set.subset.trans],
  show (A ∩ B) ∈  𝒫 S, from by auto [set.mem_powerset],
end

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

{{begin-eqn}}
{{eqn | l = \left({x + y}\right)^2
      | r = \left({x + y}\right) \cdot \left({x + y}\right)
}}
{{eqn | r = x \cdot \left({x + y}\right) + y \cdot \left({x + y}\right)
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x \cdot x + x \cdot y + y \cdot x + y \cdot y
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x^2 + 2xy + y^2
      | c =
}}
{{end-eqn}}
{{qed}}
-/
theorem square_of_sum (x y : ℝ) : (x + y)^2 = (x^2 + 2*x*y + y^2) :=
begin
  calc (x + y)^2 = (x+y)*(x+y) : by auto [sq]
  ... = x*(x+y) + y*(x+y) : by auto [add_mul]
  ... = x*x + x*y + y*x + y*y : by auto [mul_comm, add_mul] using [ring]
  ... = x^2 + 2*x*y + y^2 : by auto [sq, mul_comm] using [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
  have h1 : ∀ a b : G, ∃! x : G, a * x = b, from by auto using [use (a⁻¹ * b)],
  have h2 : ∀ a b : G, ∃! y : G, y * a = b, from by auto using [use b * a⁻¹],

  have h3 : ∀ a : G, ∃! x : G, a * x = a, from by auto [h1],
  have h4 : ∀ a : G, ∃! y : G, y * a = a, from by auto [h2],

  have h5 : ∀ a : G, classical.some (h3 a).exists = (1 : G), from by auto [exists_unique.unique, h3, classical.some_spec, exists_unique.exists, mul_one],
  have h6 : ∀ a : G, classical.some (h4 a).exists = (1 : G), from by auto [exists_unique.unique, h4, classical.some_spec, exists_unique.exists, one_mul],

  show ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a, from by auto [h3, h4, exists_unique.unique, classical.some_spec, exists_unique.exists] using [use (1 : G)],
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) 2016 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Leonardo de Moura

! This file was ported from Lean 3 source module init.data.punit
! leanprover-community/mathlib commit ab7b94ef22d18679460483c47458a58716eb47da
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
prelude
import Leanbin.Init.Logic

#print PUnit.subsingleton /-
theorem PUnit.subsingleton (a b : PUnit) : a = b :=
  PUnit.recOn a (PUnit.recOn b rfl)
#align punit_eq PUnit.subsingleton
-/

#print PUnit.eq_punit /-
theorem PUnit.eq_punit (a : PUnit) : a = PUnit.unit :=
  PUnit.subsingleton a PUnit.unit
#align punit_eq_star PUnit.eq_punit
-/

instance : Subsingleton PUnit :=
  Subsingleton.intro PUnit.subsingleton

instance : Inhabited PUnit :=
  ⟨PUnit.unit⟩

instance : DecidableEq PUnit := fun a b => isTrue (PUnit.subsingleton a b)