import LMT

variable {I} [Nonempty I] {E} [Nonempty E] [Nonempty (A I E)]

example {a1 a2 a3 : A I E} :
        (((a1).write i1 (v3)).write i3 (v3)) ≠ (((a1).write i3 (v3)).write i1 (v3)) → False := by
  arr


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

Binder elimination
-/
import order

namespace old_conv
open tactic monad

meta instance : monad_fail old_conv :=
{ fail := λ α s, (λr e, tactic.fail (to_fmt s) : old_conv α), ..old_conv.monad }

meta instance : has_monad_lift tactic old_conv :=
⟨λα, lift_tactic⟩

meta instance (α : Type) : has_coe (tactic α) (old_conv α) :=
⟨monad_lift⟩

meta def current_relation : old_conv name := λr lhs, return ⟨r, lhs, none⟩

meta def head_beta : old_conv unit :=
λ r e, do n ← tactic.head_beta e, return ⟨(), n, none⟩

/- congr should forward data! -/
meta def congr_arg : old_conv unit → old_conv unit := congr_core (return ())
meta def congr_fun : old_conv unit → old_conv unit := λc, congr_core c (return ())

meta def congr_rule (congr : expr) (cs : list (list expr → old_conv unit)) :
  old_conv unit :=
λr lhs, do
  meta_rhs ← infer_type lhs >>= mk_meta_var, -- is maybe overly restricted for `heq`
  t ← mk_app r [lhs, meta_rhs],
  ((), meta_pr) ← solve_aux t (do
    apply congr,
    focus $ cs.map $ λc, (do
      xs ← intros,
      conversion (head_beta >> c xs)),
    done),
  rhs ← instantiate_mvars meta_rhs,
  pr ← instantiate_mvars meta_pr,
  return ⟨(), rhs, some pr⟩

meta def congr_binder (congr : name) (cs : expr → old_conv unit) : old_conv unit := do
  e ← mk_const congr,
  congr_rule e [λbs, do [b] ← return bs, cs b]

meta def funext' : (expr → old_conv unit) → old_conv unit := congr_binder ``_root_.funext

meta def propext' {α : Type} (c : old_conv α) : old_conv α := λr lhs, (do
  guard (r = `iff),
  c r lhs)
<|> (do
  guard (r = `eq),
  ⟨res, rhs, pr⟩ ← c `iff lhs,
  match pr with
  | some pr := return ⟨res, rhs, (expr.const `propext [] : expr) lhs rhs pr⟩
  | none := return ⟨res, rhs, none⟩
  end)

meta def apply (pr : expr) : old_conv unit :=
λ r e, do
  sl ← simp_lemmas.mk.add pr,
  apply_lemmas sl r e

meta def applyc (n : name) : old_conv unit :=
λ r e, do
  sl ← simp_lemmas.mk.add_simp n,
  apply_lemmas sl r e

meta def apply' (n : name) : old_conv unit := do
  e ← mk_const n,
  congr_rule e []

end old_conv

open expr tactic old_conv

/- Binder elimination:

We assume a binder `B : p → Π (α : Sort u), (α → t) → t`, where `t` is a type depending on `p`.
Examples:
  ∃: there is no `p` and `t` is `Prop`.
  ⨅, ⨆: here p is `β` and `[complete_lattice β]`, `p` is `β`

Problem: ∀x, _ should be a binder, but is not a constant!

Provide a mechanism to rewrite:

  B (x : α) ..x.. (h : x = t), p x  =  B ..x/t.., p t

Here ..x.. are binders, maybe also some constants which provide commutativity rules with `B`.

-/

meta structure binder_eq_elim :=
(match_binder  : expr → tactic (expr × expr))    -- returns the bound type and body
(adapt_rel     : old_conv unit → old_conv unit)          -- optionally adapt `eq` to `iff`
(apply_comm    : old_conv unit)                      -- apply commutativity rule
(apply_congr   : (expr → old_conv unit) → old_conv unit) -- apply congruence rule
(apply_elim_eq : old_conv unit)                      -- (B (x : β) (h : x = t), s x) = s t

meta def binder_eq_elim.check_eq (b : binder_eq_elim) (x : expr) : expr → tactic unit
| `(@eq %%β %%l %%r) := guard ((l = x ∧ ¬ x.occurs r) ∨ (r = x ∧ ¬ x.occurs l))
| _ := fail "no match"

meta def binder_eq_elim.pull (b : binder_eq_elim) (x : expr) : old_conv unit := do
  (β, f) ← lhs >>= (lift_tactic ∘ b.match_binder),
  guard (¬ x.occurs β)
  <|> b.check_eq x β
  <|> (do
    b.apply_congr $ λx, binder_eq_elim.pull,
    b.apply_comm)

meta def binder_eq_elim.push (b : binder_eq_elim) : old_conv unit :=
  b.apply_elim_eq
<|> (do
  b.apply_comm,
  b.apply_congr $ λx, binder_eq_elim.push)
<|> (do
  b.apply_congr $ b.pull,
  binder_eq_elim.push)

meta def binder_eq_elim.check (b : binder_eq_elim) (x : expr) : expr → tactic unit
| e := do
  (β, f) ← b.match_binder e,
  b.check_eq x β
  <|> (do
    (lam n bi d bd) ← return f,
    x ← mk_local' n bi d,
    binder_eq_elim.check $ bd.instantiate_var x)

meta def binder_eq_elim.old_conv (b : binder_eq_elim) : old_conv unit := do
  (β, f) ← lhs >>= (lift_tactic ∘ b.match_binder),
  (lam n bi d bd) ← return f,
  x ← mk_local' n bi d,
  b.check x (bd.instantiate_var x),
  b.adapt_rel b.push

theorem {u v} exists_elim_eq_left {α : Sort u} (a : α) (p : Π(a':α), a' = a → Prop) :
  (∃(a':α)(h : a' = a), p a' h) ↔ p a rfl :=
⟨λ⟨a', ⟨h, p_h⟩⟩, match a', h, p_h with ._, rfl, h := h end, λh, ⟨a, rfl, h⟩⟩

theorem {u v} exists_elim_eq_right {α : Sort u} (a : α) (p : Π(a':α), a = a' → Prop) :
  (∃(a':α)(h : a = a'), p a' h) ↔ p a rfl :=
⟨λ⟨a', ⟨h, p_h⟩⟩, match a', h, p_h with ._, rfl, h := h end, λh, ⟨a, rfl, h⟩⟩

meta def exists_eq_elim : binder_eq_elim :=
{ match_binder  := λe, (do `(@Exists %%β %%f) ← return e, return (β, f)),
  adapt_rel     := propext',
  apply_comm    := applyc ``exists_comm,
  apply_congr   := congr_binder ``exists_congr,
  apply_elim_eq := apply' ``exists_elim_eq_left <|> apply' ``exists_elim_eq_right }

theorem {u v} forall_comm {α : Sort u} {β : Sort v} (p : α → β → Prop) :
  (∀a b, p a b) ↔ (∀b a, p a b) :=
⟨assume h b a, h a b, assume h b a, h a b⟩

theorem {u v} forall_elim_eq_left {α : Sort u} (a : α) (p : Π(a':α), a' = a → Prop) :
  (∀(a':α)(h : a' = a), p a' h) ↔ p a rfl :=
⟨λh, h a rfl, λh a' h_eq, match a', h_eq with ._, rfl := h end⟩

theorem {u v} forall_elim_eq_right {α : Sort u} (a : α) (p : Π(a':α), a = a' → Prop) :
  (∀(a':α)(h : a = a'), p a' h) ↔ p a rfl :=
⟨λh, h a rfl, λh a' h_eq, match a', h_eq with ._, rfl := h end⟩

meta def forall_eq_elim : binder_eq_elim :=
{ match_binder  := λe, (do (expr.pi n bi d bd) ← return e, return (d, expr.lam n bi d bd)),
  adapt_rel     := propext',
  apply_comm    := applyc ``forall_comm,
  apply_congr   := congr_binder ``forall_congr,
  apply_elim_eq := apply' ``forall_elim_eq_left <|> apply' ``forall_elim_eq_right }

meta def supr_eq_elim : binder_eq_elim :=
{ match_binder  := λe, (do `(@supr %%α %%cl %%β %%f) ← return e, return (β, f)),
  adapt_rel     := λc, (do r ← current_relation, guard (r = `eq), c),
  apply_comm    := applyc ``supr_comm,
  apply_congr   := congr_arg ∘ funext',
  apply_elim_eq := applyc ``supr_supr_eq_left <|> applyc ``supr_supr_eq_right }

meta def infi_eq_elim : binder_eq_elim :=
{ match_binder  := λe, (do `(@infi %%α %%cl %%β %%f) ← return e, return (β, f)),
  adapt_rel     := λc, (do r ← current_relation, guard (r = `eq), c),
  apply_comm    := applyc ``infi_comm,
  apply_congr   := congr_arg ∘ funext',
  apply_elim_eq := applyc ``infi_infi_eq_left <|> applyc ``infi_infi_eq_right }

universes u v w w₂
variables {α : Type u} {β : Type v} {ι : Sort w} {ι₂ : Sort w₂} {s t : set α} {a : α}

section
variables [complete_lattice α]

example {s : set β} {f : β → α} : Inf (set.image f s) = (⨅ a ∈ s, f a) :=
begin
  simp [Inf_eq_infi, infi_and],
  conversion infi_eq_elim.old_conv,
end

example {s : set β} {f : β → α} : Sup (set.image f s) = (⨆ a ∈ s, f a) :=
begin
  simp [Sup_eq_supr, supr_and],
  conversion supr_eq_elim.old_conv,
end

end


import category_theory.colimits
import category_theory.isomorphism
import category_theory.preserves_colimits
import category_theory.replete
import .definitions
import category_theory.functor

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

universes v u

namespace homotopy_theory.cylinder

section hep

variables {C : Type u} [category.{v} C] [inst1 : has_cylinder C] [inst2 : has_cylinder_with_involution C]

include inst1

-- The homotopy extension property with respect to the given cylinder
-- functor, "on side ε".
def hep (ε) {A X : C} (j : A ⟶ X) : Prop :=
∀ Y (f : X ⟶ Y) (H : I.obj A ⟶ Y), f ∘ j = H ∘ i ε @> A →
  ∃ H' : I.obj X ⟶ Y, H' ∘ i ε @> X = f ∧ H' ∘ I &> j = H

lemma hep_of_isomorphism (ε) {A X : C} (h : iso A X) : hep ε h.hom :=
assume Y f H e,
  ⟨H ∘ I &> h.inv,
   by erw [←assoc, ←(i ε).naturality, assoc, ←e, iso.inv_hom_id_assoc],
   by erw [←functor.map_iso_hom, iso.hom_inv_id_assoc]⟩

lemma hep_id (ε) {X : C} : hep ε (𝟙 X) :=
hep_of_isomorphism ε (iso.refl X)

lemma hep_comp (ε) {A B X : C} {f : A ⟶ B} {g : B ⟶ X} (hf : hep ε f) (hg : hep ε g) :
  hep ε (g ∘ f) :=
assume Y k H e,
  let ⟨J, Je₁, Je₂⟩ := hf Y (k ∘ g) H (by convert e using 1; simp) in
  let ⟨K, Ke₁, Ke₂⟩ := hg Y k J Je₁.symm in
  ⟨K, Ke₁, by rw [I.map_comp, assoc, Ke₂, Je₂]⟩

instance hep_replete (ε) : replete_wide_subcategory.{v} C (λ a b, hep ε) :=
replete_wide_subcategory.mk' (λ a b, hep_of_isomorphism ε) (λ a b c f g, hep_comp ε)

lemma hep_pushout (ε) {A B A' B' : C} {f : A ⟶ B} {g : A ⟶ A'} {f' : A' ⟶ B'} {g' : B ⟶ B'}
  (po : Is_pushout f g g' f') (po' : Is_pushout (I &> f) (I &> g) (I &> g') (I &> f'))
  (hf : hep ε f) : hep ε f' :=
assume Y h H e,
  have (h ∘ g') ∘ f = (H ∘ (I &> g)) ∘ i ε @> A, begin
    erw [←assoc, ←assoc, po.commutes, ←(i ε).naturality],
    simp [e]
  end,
  let ⟨J, Je₁, Je₂⟩ := hf Y (h ∘ g') (H ∘ (I &> g)) this in
  let K := po'.induced J H Je₂ in
  ⟨K,
   begin
     apply po.uniqueness; erw [←assoc, (i ε).naturality, assoc],
     { rw [←Je₁], simp },
     { rw [e], simp }
   end,
   po'.induced_commutes₁ J H Je₂⟩

lemma hep_pushout' [preserves_pushouts (I : C ↝ C)] (ε) {A B A' B' : C}
  {f : A ⟶ B} {g : A ⟶ A'} {f' : A' ⟶ B'} {g' : B ⟶ B'} (po : Is_pushout f g g' f')
  (hf : hep ε f) : hep ε f' :=
hep_pushout ε po (preserves_pushouts.Is_pushout_of_Is_pushout po) hf

lemma hep_iff_pushout_retract (ε) {A X : C} {j : A ⟶ X}
  {Z : C} {i' : X ⟶ Z} {j' : I.obj A ⟶ Z} (po : Is_pushout j (i ε @> A) i' j') :
  hep ε j ↔ ∃ r : I.obj X ⟶ Z,
    r ∘ po.induced (i ε @> X) (I &> j) ((i ε).naturality _) = 𝟙 _ :=
iff.intro
  (assume h,
    let ⟨r, hr₁, hr₂⟩ := h Z i' j' po.commutes in
    ⟨r, by apply po.uniqueness; rw ←assoc; simpa⟩)
  (assume ⟨r, hr⟩ Y f H e,
    have hr₁ : r ∘ i ε @> X = i', from eq.symm $ calc
      i' = 𝟙 _ ∘ i' : by simp
     ... = (r ∘ _) ∘ i' : by rw hr
     ... = _ : by rw ←assoc; simp,
    have hr₂ : r ∘ I &> j = j', from eq.symm $ calc
      j' = 𝟙 _ ∘ j' : by simp
     ... = (r ∘ _) ∘ j' : by rw hr
     ... = _ : by rw ←assoc; simp,
    ⟨po.induced f H e ∘ r,
     by rw [←assoc, hr₁]; simp,
     by rw [←assoc, hr₂]; simp⟩)

lemma hep_initial_induced (ε) {A X : C} {j : A ⟶ X}
  (Ai : Is_initial_object.{v} A) (IAi : Is_initial_object.{v} (I.obj A)) :
  hep ε j :=
let po : Is_pushout j (i ε @> A) (𝟙 X) IAi.induced := begin
  convert Is_pushout_of_isomorphic (Is_pushout.refl j) j (i ε @> A)
    (iso.refl A) (iso.refl X) (initial_object.unique IAi Ai)
    (Ai.uniqueness _ _) (Ai.uniqueness _ _), { simp }, { apply IAi.uniqueness }
end in
(hep_iff_pushout_retract ε po).mpr ⟨p @> X, po.uniqueness
  (by rw [←assoc, po.induced_commutes₀]; simp)
  (IAi.uniqueness _ _)⟩

-- The two-sided homotopy extension property.
@[reducible] def two_sided_hep {A X : C} (j : A ⟶ X) : Prop := ∀ ε, hep ε j

omit inst1
include inst2

lemma hep_involution {ε} {A X : C} {j : A ⟶ X} (h : hep ε j) : hep ε.v j :=
assume Y f H e,
  let ⟨H₁, h₁, h₂⟩ := h Y f (H ∘ v @> A)
    (by convert e using 1; rw [←assoc]; simp) in
  ⟨H₁ ∘ v @> X,
   by rw ←assoc; simpa using h₁,
   calc
     H₁ ∘ v @> X ∘ I &> j
       = H₁ ∘ (v @> X ∘ I &> j) : by rw assoc
   ... = H₁ ∘ (I &> j ∘ v @> A) : by erw v.naturality; refl
   ... = (H₁ ∘ I &> j) ∘ v @> A : by simp
   ... = (H ∘ v @> A) ∘ v @> A  : by rw h₂
   ... = H                      : by rw ←assoc; simp; dsimp; simp⟩

lemma two_sided_hep_iff_hep {ε} {A X : C} {j : A ⟶ X} : two_sided_hep j ↔ hep ε j :=
have ∀ ε', ε' = ε ∨ ε' = ε.v, by intro ε'; cases ε; cases ε'; simp; refl,
iff.intro (assume h, h ε)
  (assume h ε', begin
    cases this ε'; subst ε', { exact h }, { exact hep_involution h }
  end)

end hep

end homotopy_theory.cylinder


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

import category_theory.limits.shapes
import category_theory.limits.types
import pullbacks
import to_mathlib
import sub
import subobject_classifier
import binary_products

/-!
# Power objects

Define power objects
-/
universes v u v₂ u₂

open category_theory category_theory.category category_theory.limits

attribute [instance] has_pullbacks_of_has_finite_limits

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

lemma cone_is_pullback {X Y Z : C} (f : X ⟶ Z) (g : Y ⟶ Z) [has_limit (cospan f g)] :
  is_limit (pullback_cone.mk _ _ pullback.condition : pullback_cone f g) :=
begin
  apply is_limit.of_iso_limit,
  apply limit.is_limit,
  refine cones.ext _ _, refl,
  intro j,
  erw id_comp,
  cases j, refl, refl,
  rw limit.cone_π,
  erw ← limit.w (cospan _ _) walking_cospan.hom.inl,
  refl
end

section faithful

variables {D : Type u₂} [𝒟 : category.{v₂} D]
include 𝒟
instance right_op_faithful {F : Cᵒᵖ ⥤ D} [faithful F] : faithful F.right_op :=
{ injectivity' :=
  begin
    dsimp,
    intros X Y f g h,
    have := has_hom.hom.op_inj ((faithful.injectivity F (has_hom.hom.op_inj h))),
    exact this
  end
}
end faithful

def op_equiv (A : C) (B : Cᵒᵖ): (opposite.op A ⟶ B) ≃ (B.unop ⟶ A) :=
{ to_fun := λ f, f.unop,
  inv_fun := λ g, g.op,
  left_inv := λ _, rfl,
  right_inv := λ _, rfl }

variables [has_finite_limits.{v} C]

structure powerises {A PA niA B R : C} (memA : niA ⟶ PA ⨯ A) (m : R ⟶ B ⨯ A) (mhat : B ⟶ PA) :=
(top : R ⟶ niA)
(commutes : top ≫ memA = m ≫ limits.prod.map mhat (𝟙 A))
(forms_pullback' : is_limit (pullback_cone.mk _ _ commutes))
restate_axiom powerises.forms_pullback'

class has_power_object (A : C) :=
(PA niA : C)
(memA : niA ⟶ PA ⨯ A)
(mem_mono' : @mono _ 𝒞 _ _ memA)
(hat : ∀ {B R} (m : R ⟶ B ⨯ A) [hm : @mono _ 𝒞 _ _ m], B ⟶ PA)
(powerises' : ∀ {B R} (m : R ⟶ B ⨯ A) [hm : @mono _ 𝒞 _ _ m], powerises memA m (hat m))
(uniquely' : ∀ {B R} (m : R ⟶ B ⨯ A) [hm : @mono _ 𝒞 _ _ m] (hat' : B ⟶ PA), powerises memA m hat' → hat' = hat m)

variable (C)

class has_power_objects :=
(has_power_object : Π (A : C), has_power_object.{v} A)

variable {C}

instance has_power_object_of_has_all [has_power_objects.{v} C] {A : C} :
  has_power_object.{v} A := has_power_objects.has_power_object A

section convenience

variables (A : C) [has_power_object.{v} A]

def P : C := @has_power_object.PA _ 𝒞 _ A _
def ni : C := @has_power_object.niA _ 𝒞 _ A _
def mem : ni A ⟶ P A ⨯ A := has_power_object.memA A
instance mem_mono : mono (mem A) := has_power_object.mem_mono' A

variables {A} {B R : C} (m : R ⟶ B ⨯ A) [mono m]

def hat : B ⟶ P A := has_power_object.hat m
def hat_powerises : powerises (mem A) m (hat m) := has_power_object.powerises' m
def square.top : R ⟶ ni A := (hat_powerises m).top
def square.commutes : square.top m ≫ mem A = m ≫ limits.prod.map (hat m) (𝟙 A) := (hat_powerises m).commutes
def square.is_pullback : is_limit (pullback_cone.mk _ _ (square.commutes m)) := (hat_powerises m).forms_pullback
lemma unique_hat (hat' : B ⟶ P A) (hp : powerises (mem A) m hat') : hat' = hat m := has_power_object.uniquely' m hat' hp
end convenience

section functor_setup
variables {A B : C} (f : A ⟶ B) [has_power_object.{v} B]
def E : C := pullback (mem B) (limits.prod.map (𝟙 _) f)
def Emap : E f ⟶ P B ⨯ A := pullback.snd
instance : mono (Emap f) := pullback.snd_of_mono
lemma Esquare : (pullback.fst : E f ⟶ _) ≫ mem B = Emap f ≫ limits.prod.map (𝟙 _) f := pullback.condition
lemma Epb : is_limit (pullback_cone.mk _ _ (Esquare f)) :=
cone_is_pullback _ _

variable [has_power_object.{v} A]
def P_map : P B ⟶ P A :=
hat (Emap f)

lemma Psquare : square.top (Emap f) ≫ mem A = Emap f ≫ limits.prod.map (P_map f) (𝟙 A) :=
square.commutes (Emap f)

lemma Ppb : is_limit (pullback_cone.mk _ _ (Psquare f)) :=
square.is_pullback (Emap f)

lemma easy_lemma {D R : C} (m : R ⟶ D ⨯ B) [hm : mono m] :
  hat (pullback.snd : pullback m (limits.prod.map (𝟙 D) f) ⟶ D ⨯ A) = hat m ≫ P_map f :=
begin
  symmetry,
  apply unique_hat,
  set p : pullback m (limits.prod.map (𝟙 D) f) ⟶ R := pullback.fst,
  set q : pullback m (limits.prod.map (𝟙 D) f) ⟶ D ⨯ A := pullback.snd,
  have := (pasting pullback.fst _ pullback.snd m _ (limits.prod.map (𝟙 D) f) _ pullback.condition (square.commutes m) (square.is_pullback m)).inv (cone_is_pullback _ _),
  have comm'': limits.prod.map (𝟙 D) f ≫ limits.prod.map (hat m) (𝟙 B) = _ := prod_map_comm _ _,
  set f2 : pullback m (limits.prod.map (𝟙 D) f) ⟶ P B ⨯ A := q ≫ limits.prod.map (hat m) (𝟙 A),
  set f1 : pullback m (limits.prod.map (𝟙 D) f) ⟶ ni B := p ≫ square.top m,
  have comm: f1 ≫ mem B = f2 ≫ limits.prod.map (𝟙 (P B)) f,
    slice_rhs 2 3 {rw comm''.symm},
    slice_lhs 2 3 {rw square.commutes m},
    slice_lhs 1 2 {rw pullback.condition},
    rw ← assoc,
  have comm' : f1 ≫ mem B = pullback.snd ≫ limits.prod.map (hat m) (𝟙 A) ≫ limits.prod.map (𝟙 (P B)) f,
    rw comm, rw assoc,
  have newlim: is_limit (pullback_cone.mk f1 pullback.snd comm' : pullback_cone (mem B) (limits.prod.map (hat m) (𝟙 A) ≫ limits.prod.map (𝟙 (P B)) f)),
    convert this using 2, exact comm''.symm, exact comm''.symm,
  set r := pullback.lift f1 f2 comm,
  have comm''' : r ≫ Emap f = q ≫ limits.prod.map (hat m) (𝟙 A),
    erw limit.lift_π, refl,
  have := (pasting r pullback.fst q (Emap f) (mem B) (limits.prod.map (hat m) (𝟙 A)) (limits.prod.map (𝟙 (P B)) f) comm''' pullback.condition (Epb f)).hom _,
    swap, convert newlim using 2, erw limit.lift_π, refl,
  have := (pasting r (square.top (Emap f)) q (Emap f) (mem A) (limits.prod.map (hat m) (𝟙 A)) (limits.prod.map (P_map f) (𝟙 A)) comm''' (Psquare f) (square.is_pullback _)).inv this,
  have comm4: limits.prod.map (hat m) (𝟙 A) ≫ limits.prod.map (P_map f) (𝟙 A) = limits.prod.map (hat m ≫ P_map f) (𝟙 A),
    apply prod.hom_ext,
    simp, simp, erw comp_id,
  refine ⟨r ≫ square.top (Emap f), _, _⟩,
    slice_lhs 2 3 {rw square.commutes},
    slice_lhs 1 2 {rw comm'''},
    slice_lhs 2 3 {erw comm4},
  convert this using 2,
  exact comm4.symm,
  exact comm4.symm
end

-- We need to assume g₁ = hom ≫ g₂. From here if we know that hom,inv cancel then we get g₂ = inv ≫ g₁.
-- Instead we assume this and derive that hom,inv cancel
lemma lifting {A B R₁ R₂ : C} [has_power_object.{v} A] {g₁ : R₁ ⟶ B ⨯ A} {g₂ : R₂ ⟶ B ⨯ A} [mono g₁] [mono g₂] (hom : R₁ ⟶ R₂) (inv : R₂ ⟶ R₁) :
  g₁ = hom ≫ g₂ → g₂ = inv ≫ g₁ → hat g₁ = hat g₂ :=
begin
  intros k l,
  have hi: hom ≫ inv = 𝟙 _,
    rw ← cancel_mono g₁,
    conv_rhs {rw [k, l]}, simp,
  have ih: inv ≫ hom = 𝟙 _,
    rw ← cancel_mono g₂,
    conv_rhs {rw [l, k]}, simp,
  apply unique_hat,
  refine ⟨inv ≫ square.top g₁, _, _⟩,
  slice_lhs 2 3 {rw square.commutes g₁},
  slice_lhs 1 2 {rw ← l},
  apply is_limit.of_iso_limit (square.is_pullback g₁),
  ext, swap,
  refine ⟨hom, inv, ‹_›, ‹_›⟩,
  cases j, simp, slice_rhs 1 2 {rw hi},
  erw id_comp,
  simpa,
  simp, show _ ≫ _ = _ ≫ _ ≫ _, slice_rhs 1 2 {rw hi},
  erw id_comp
end
def how_inj_is_hat {A B R₁ R₂ : C} [has_power_object.{v} A] {f₁ : R₁ ⟶ B ⨯ A} {f₂ : R₂ ⟶ B ⨯ A} [mono f₁] [mono f₂] (h : hat f₁ = hat f₂) :
  R₁ ≅ R₂ :=
{ hom := (square.is_pullback f₂).lift (pullback_cone.mk (square.top f₁) f₁ (h ▸ square.commutes f₁)),
  inv := (square.is_pullback f₁).lift (pullback_cone.mk (square.top f₂) f₂ (h.symm ▸ square.commutes f₂)),
  hom_inv_id' :=
  begin
    erw [← cancel_mono f₁, assoc,
         (square.is_pullback f₁).fac _ walking_cospan.right,
         (square.is_pullback f₂).fac _ walking_cospan.right],
    simp
  end,
  inv_hom_id' :=
  begin
    erw [← cancel_mono f₂, assoc,
         (square.is_pullback f₂).fac _ walking_cospan.right,
         (square.is_pullback f₁).fac _ walking_cospan.right],
    simp
  end }

lemma very_inj {A B R₁ R₂ : C} [has_power_object.{v} A] {f₁ : R₁ ⟶ B ⨯ A} {f₂ : R₂ ⟶ B ⨯ A} [mono f₁] [mono f₂] (h : hat f₁ = hat f₂) :
  (how_inj_is_hat h).hom ≫ f₂ = f₁ :=
(square.is_pullback f₂).fac _ walking_cospan.right

lemma liftable {A B : C} [has_power_object.{v} A] (a b : sub' (B ⨯ A)) : (a ≈ b) → @hat _ _ _ _ _ _ _ a.1.hom a.2 = @hat _ _ _ _ _ _ _ b.1.hom b.2 :=
begin
  rintros ⟨⟨hom, k⟩, ⟨inv, l⟩⟩,
  exact @lifting _ _ _ _ _ _ _ _ _ _ a.2 b.2 _ _ k l,
end
def hat_sub {A B : C} [has_power_object.{v} A] : sub (B ⨯ A) → (B ⟶ P A) :=
quotient.lift (λ (f : sub' (B ⨯ A)), @hat _ _ _ _ _ _ _ f.1.hom f.2) liftable

def hat_sub' {A B : C} [has_power_object.{v} A] (k : B ⟶ P A) : sub (B ⨯ A) :=
quotient.mk ⟨over.mk (pullback.snd : pullback (mem A) (limits.prod.map k (𝟙 _)) ⟶ B ⨯ A), pullback.snd_of_mono⟩

def hat_natural_right {A A' B R : C} [has_power_object.{v} A] [has_power_object.{v} A'] (k : R ⟶ B ⨯ A) [mono k] (g : A' ⟶ A) :
  hat k ≫ P_map g = hat (pullback.snd : pullback k (limits.prod.map (𝟙 B) g) ⟶ B ⨯ A') :=
begin
  rw easy_lemma
end
def hat_natural_left {A B B' R : C} [has_power_object.{v} A] (k : R ⟶ B ⨯ A) [mono k] (g : B' ⟶ B) : g ≫ hat k = hat (pullback.snd : pullback k (limits.prod.map g (𝟙 A)) ⟶ B' ⨯ A) := -- hat_sub (sub_map (limits.prod.map g (𝟙 A)) k) :=
begin
  apply unique_hat,
  refine ⟨pullback.fst ≫ square.top k, _, _⟩,
  slice_lhs 2 3 {rw square.commutes},
  slice_lhs 1 2 {rw pullback.condition},
  rw assoc,
  rw ← prod_functorial,
  have := (pasting pullback.fst _ pullback.snd k _ (limits.prod.map g (𝟙 A)) _ _ _ (square.is_pullback k)).inv (cone_is_pullback _ _),
  convert this,
  rw prod_functorial,
  rw prod_functorial,
end

def hat_sub_natural_left (A B B' : C) [has_power_object.{v} A] (k : sub (B ⨯ A)) (g : B' ⟶ B) : g ≫ hat_sub k = hat_sub (sub_map (limits.prod.map g (𝟙 A)) k) :=
begin
  apply quotient.induction_on k,
  dsimp [hat_sub, sub_map], intro a,
  rw hat_natural_left
end

def hat_sub_natural_right {A A' B : C} [has_power_object.{v} A] [has_power_object.{v} A'] (k : sub (B ⨯ A)) (g : A' ⟶ A) : hat_sub k ≫ P_map g = hat_sub (sub_map (limits.prod.map (𝟙 B) g) k) :=
begin
  apply quotient.induction_on k,
  dsimp [hat_sub, sub_map],
  intro a,
  rw ← easy_lemma
end

def hat_sub'' {A B : C} [has_power_object.{v} A] : (B ⟶ P A) ≃ sub (B ⨯ A) :=
{ to_fun := hat_sub',
  inv_fun := hat_sub,
  left_inv :=
  begin
    intro g,
    dsimp [hat_sub, hat_sub'],
    symmetry,
    apply unique_hat,
    exact ⟨_, pullback.condition, cone_is_pullback _ _⟩
  end,
  right_inv :=
  begin
    intro g,
    dsimp [hat_sub, hat_sub'],
    apply quotient.induction_on g,
    intro g',
    haveI := g'.2,
    apply quotient.sound,
    dsimp,
    split,
    refine ⟨_, _⟩,
    apply (square.is_pullback g'.1.hom).lift (pullback_cone.mk pullback.fst pullback.snd pullback.condition),
    dsimp, erw (square.is_pullback g'.1.hom).fac _ walking_cospan.right, refl,
    refine ⟨_, _⟩,
    apply pullback.lift (square.top g'.1.hom) g'.1.hom (square.commutes g'.1.hom),
    simp
  end }

def hat_sub'_natural_right (A A' B : C) [has_power_object.{v} A] [has_power_object.{v} A'] (k : B ⟶ P A) (g : A' ⟶ A) : hat_sub' (k ≫ P_map g) = sub_map (limits.prod.map (𝟙 B) g) (hat_sub' k) :=
begin
  erw ← hat_sub''.eq_symm_apply,
  dsimp [hat_sub''],
  rw ← hat_sub_natural_right,
  congr' 1,
  apply (hat_sub''.left_inv k).symm
end

def hat_sub'_natural_left {A B B' : C} [has_power_object.{v} A] (k : B ⟶ P A) (g : B' ⟶ B) : hat_sub' (g ≫ k) = sub_map (limits.prod.map g (𝟙 A)) (hat_sub' k) :=
begin
  erw ← hat_sub''.eq_symm_apply,
  dsimp [hat_sub''],
  rw ← hat_sub_natural_left,
  congr' 1,
  apply (hat_sub''.left_inv k).symm
end

lemma P_map_id (X : C) [has_power_object.{v} X] : P_map (𝟙 X) = 𝟙 (P X) :=
begin
  symmetry, apply unique_hat,
  refine ⟨pullback.fst, pullback.condition, cone_is_pullback _ _⟩
end
lemma P_map_comp {X Y Z : C} [has_power_object.{v} X] [has_power_object.{v} Y] [has_power_object.{v} Z] (f : X ⟶ Y) (g : Y ⟶ Z) :
  P_map (f ≫ g) = P_map g ≫ P_map f :=
begin
  erw ← easy_lemma,
  rw P_map,
  refine lifting _ _ _ _,
  { refine pullback.lift (pullback.lift pullback.fst (pullback.snd ≫ limits.prod.map (𝟙 _) f) _) pullback.snd _,
    { rw pullback.condition, rw assoc, congr' 1, apply prod.hom_ext; simp,
      erw comp_id, erw comp_id, erw comp_id },
    { erw limit.lift_π, refl } },
  { refine pullback.lift _ _ _,
    apply pullback.fst ≫ pullback.fst, apply pullback.snd,
    slice_lhs 2 3 {rw pullback.condition},
    slice_lhs 1 2 {erw pullback.condition},
    rw assoc, apply prod.hom_ext; simp,
    erw comp_id },
  { simp, refl },
  { erw limit.lift_π, refl }
end

def P_functor [has_power_objects.{v} C] : Cᵒᵖ ⥤ C :=
{ obj := λ X, P X.unop,
  map := λ X Y f, P_map f.unop,
  map_id' := λ X, P_map_id _,
  map_comp' := λ X Y Z f g, P_map_comp _ _ }
end functor_setup

def thing (X Y Z : C) (g : Y ⟶ Z) :
  is_limit (pullback_cone.mk (limits.prod.map g (𝟙 X)) (prod.lift limits.prod.snd limits.prod.fst) (begin apply prod.hom_ext; simp end) : pullback_cone (prod.lift limits.prod.snd limits.prod.fst) (limits.prod.map (𝟙 X) g)) :=
begin
  refine ⟨_, _, _⟩,
  intro c,
  apply pullback_cone.snd c ≫ (limits.prod.braiding _ _).hom,
  intro c,
  apply pi_app_left (pullback_cone.mk (limits.prod.map g (𝟙 X)) (limits.prod.lift limits.prod.snd limits.prod.fst) _) c,
  change (pullback_cone.snd c ≫ (limits.prod.braiding _ _).hom) ≫ (limits.prod.map _ _) = pullback_cone.fst c,
  apply prod.hom_ext,
  have := pullback_cone.condition c =≫ limits.prod.snd,
  simp at this, simp, exact this.symm,
  simp,
  have := pullback_cone.condition c =≫ limits.prod.fst,
  simp at this, exact this.symm,
  change (pullback_cone.snd c ≫ (limits.prod.braiding _ _).hom) ≫ (limits.prod.lift limits.prod.snd limits.prod.fst) = pullback_cone.snd c,
  rw category.assoc, apply prod.hom_ext,
  simp, simp,
  intros c m J,
  rw ← cancel_mono (limits.prod.braiding X Y).inv,
  rw category.assoc, rw iso.hom_inv_id, rw comp_id,
  apply J walking_cospan.right,
end

def self_adj [has_power_objects.{v} C] : is_right_adjoint (@P_functor C 𝒞 _ _) :=
{ left := P_functor.right_op,
  adj := adjunction.mk_of_hom_equiv
  { hom_equiv :=
    begin
      intros A B,
      apply equiv.trans _ hat_sub''.symm,
      apply equiv.trans (op_equiv (P_functor.obj (opposite.op A)) B),
      apply equiv.trans hat_sub'',
      apply sub_iso_compose (limits.prod.braiding _ _),
    end,
    hom_equiv_naturality_left_symm' :=
    begin
      intros X' X Y f g,
      dsimp [hat_sub''],
      simp,
      change (hat_sub ((sub_iso_compose (prod.braiding (opposite.unop Y) X')).inv_fun (hat_sub' (f ≫ g)))).op =
      (P_functor.map (has_hom.hom.op f)).op ≫
        (hat_sub ((sub_iso_compose (prod.braiding (opposite.unop Y) X)).inv_fun (hat_sub' g))).op,
      rw ← op_comp,
      congr' 1,
      erw hat_sub_natural_right,
      congr' 1,
      rw has_hom.hom.unop_op,
      dsimp [sub_iso_compose],
      rw hat_sub'_natural_left,
      apply postcompose_sub_comm,
      swap,
      apply prod.hom_ext, simp, simp,
      apply thing
    end,
    hom_equiv_naturality_right' :=
    begin
      intros X Y Y' f g,
      dsimp [hat_sub'', sub_iso_compose, op_equiv],
      erw hat_sub_natural_right, congr' 1,
      rw hat_sub'_natural_left,
      apply postcompose_sub_comm,
      swap,
      apply prod.hom_ext,
      simp,
      simp,
      apply thing
    end
  }
}

@[reducible]
def diagonal (A : C) : A ⟶ A ⨯ A := limits.prod.lift (𝟙 A) (𝟙 A)
instance mono_prod_lift_of_left {X Y Z : C} (f : X ⟶ Y) (g : X ⟶ Z) [mono f] : mono (limits.prod.lift f g) :=
begin
  split, intros W h k l,
  have := l =≫ limits.prod.fst,
  simp at this,
  rwa cancel_mono at this,
end

instance mono_prod_lift_of_right {X Y Z : C} (f : X ⟶ Y) (g : X ⟶ Z) [mono g] : mono (limits.prod.lift f g) :=
begin
  split, intros W h k l,
  have := l =≫ limits.prod.snd,
  simp at this,
  rwa cancel_mono at this,
end

def singleton_arrow (A : C) [has_power_object.{v} A] : A ⟶ P A := hat (diagonal A)

lemma seven_six_one {A B : C} [has_power_object.{v} B] (f : A ⟶ B) : hat (limits.prod.lift (𝟙 A) f) = f ≫ singleton_arrow B :=
begin
  erw hat_natural_left,
  refine lifting (pullback.lift f (limits.prod.lift (𝟙 A) f) _) (pullback.snd ≫ limits.prod.fst) _ _,
  apply prod.hom_ext,
  simp, erw id_comp, simp, erw comp_id,
  simp, apply prod.hom_ext, simp,
  slice_rhs 3 4 {rw limit.lift_π},
  have: (_ ≫ diagonal B) ≫ _ = (_ ≫ limits.prod.map f (𝟙 B)) ≫ _ := pullback.condition =≫ limits.prod.fst,
  simp at this, erw ← this,
  have: (_ ≫ diagonal B) ≫ _ = (_ ≫ limits.prod.map f (𝟙 B)) ≫ _ := pullback.condition =≫ limits.prod.snd,
  simp at this, rw this, dsimp, rw comp_id
end

lemma seven_six_two {A B : C} [has_power_object.{v} A] [has_power_object.{v} B] (f : A ⟶ B) :
  hat (limits.prod.lift f (𝟙 A)) = singleton_arrow B ≫ P_map f :=
begin
  erw hat_natural_right,
  refine lifting (pullback.lift f (limits.prod.lift f (𝟙 A)) _) (pullback.snd ≫ limits.prod.snd) _ _,
  apply prod.hom_ext, simp, erw comp_id,
  simp, erw id_comp,
  simp, apply prod.hom_ext,
  simp,
  have: (_ ≫ diagonal B) ≫ _ = (_ ≫ limits.prod.map (𝟙 B) f) ≫ _ := pullback.condition =≫ limits.prod.snd,
  simp at this, erw ← this,
  have: (_ ≫ diagonal B) ≫ _ = (_ ≫ limits.prod.map (𝟙 B) f) ≫ _ := pullback.condition =≫ limits.prod.fst,
  simp at this, rw this, dsimp, simp,
  simp
end

instance singleton_mono (A : C) [has_power_object.{v} A] : mono (singleton_arrow A) :=
begin
  split,
  intros,
  rw ← seven_six_one at w, rw ← seven_six_one at w,
  have q := very_inj w =≫ limits.prod.fst,
  simp at q,
  have r := very_inj w =≫ limits.prod.snd,
  simp [q] at r,
  rw r
end

instance pfaithful [has_power_objects.{v} C] : faithful (@P_functor _ 𝒞 _ _) :=
begin
  refine ⟨_⟩,
  dsimp, intros A B f g k,
  have w: hat (limits.prod.lift f.unop (𝟙 B.unop)) = hat (limits.prod.lift g.unop (𝟙 B.unop)),
    rw seven_six_two, rw seven_six_two,
    show _ ≫ P_functor.map f = _ ≫ P_map (has_hom.hom.unop g),
    rw k, refl,
  have q := very_inj w =≫ limits.prod.snd,
  simp at q,
  have r := very_inj w =≫ limits.prod.fst,
  simp [q] at r,
  apply has_hom.hom.unop_inj, symmetry, assumption
end

lemma p_faithful {A B : C} [has_power_object.{v} A] [has_power_object.{v} B] (f g : A ⟶ B) : P_map f = P_map g → f = g :=
begin
  intro k,
  have w: hat (limits.prod.lift f (𝟙 _)) = hat (limits.prod.lift g (𝟙 _)),
    rw [seven_six_two, seven_six_two, k],
  have q := very_inj w =≫ limits.prod.snd,
  simp at q,
  have r := very_inj w =≫ limits.prod.fst,
  simp [q] at r,
  symmetry, assumption
end

instance mono_prod_map {X Y Z W : C} (f : X ⟶ Y) (g : W ⟶ Z) [mono f] [mono g] : mono (limits.prod.map f g) :=
begin
  split, intros A h k l,
  apply prod.hom_ext,
  rw ← cancel_mono f,
  rw assoc, rw assoc,
  have := l =≫ limits.prod.fst,
  simp at this, assumption,
  have := l =≫ limits.prod.snd,
  simp at this,
  rwa ← cancel_mono g, simpa
end

def internal_image {A B : C} [has_power_object.{v} A] [has_power_object.{v} B] (f : A ⟶ B) [mono f] : P A ⟶ P B :=
hat (mem A ≫ limits.prod.map (𝟙 (P A)) f)

-- TODO: this doesn't use pasting so it's super long. can we make it nicer by using pasting?
lemma naturalish {A B : C} [has_power_object.{v} A] [has_power_object.{v} B] (f : A ⟶ B) [mono f] {R D : C} (m : R ⟶ D ⨯ A) [mono m] :
  hat m ≫ internal_image f = hat (m ≫ limits.prod.map (𝟙 D) f) :=
begin
  apply unique_hat,
  refine ⟨square.top m ≫ square.top (mem A ≫ limits.prod.map (𝟙 (P A)) f), _, _⟩,
  slice_lhs 2 3 {rw square.commutes},
  slice_lhs 1 2 {rw square.commutes},
  repeat {rw assoc},
  congr' 1, apply prod.hom_ext,
  simp, erw id_comp, erw id_comp, refl,
  simp, erw comp_id, erw id_comp,
  refine ⟨_, _, _⟩,
  { intro c,
    have qcomm: pullback_cone.fst c ≫ mem B = (pullback_cone.snd c ≫ limits.prod.map (hat m) (𝟙 B)) ≫ limits.prod.map (internal_image f) (𝟙 B),
    { rw pullback_cone.condition, rw assoc, congr' 1, apply prod_functorial },
    set q : c.X ⟶ ni A := (square.is_pullback (mem A ≫ limits.prod.map (𝟙 (P A)) f)).lift (pullback_cone.mk (pullback_cone.fst c) (pullback_cone.snd c ≫ limits.prod.map (hat m) (𝟙 B)) qcomm),
    have: q ≫ mem A ≫ limits.prod.map (𝟙 (P A)) f = c.π.app walking_cospan.right ≫ (limits.prod.map (hat m) (𝟙 B)),
    { erw (square.is_pullback (mem A ≫ limits.prod.map (𝟙 (P A)) f)).fac _ walking_cospan.right, refl },
    refine (square.is_pullback m).lift (pullback_cone.mk q _ _),
    { apply limits.prod.lift (pullback_cone.snd c ≫ limits.prod.fst) (q ≫ mem A ≫ limits.prod.snd) },
    { apply prod.hom_ext,
      { simp, have := this =≫ limits.prod.fst, simp at this, rw ← this, erw comp_id },
      { simp, erw comp_id } } },
  { intros c, dsimp, refine pi_app_left (pullback_cone.mk (square.top m ≫ square.top (mem A ≫ limits.prod.map (𝟙 (P A)) f)) (m ≫ limits.prod.map (𝟙 D) f) _) c _ _ _,
    erw ← assoc, erw (square.is_pullback m).fac _ walking_cospan.left, dsimp, erw (square.is_pullback _).fac _ walking_cospan.left,
    refl,
    erw ← assoc, erw (square.is_pullback m).fac _ walking_cospan.right, dsimp, apply prod.hom_ext,
    simp, erw comp_id,

    simp,
    have qcomm: pullback_cone.fst c ≫ mem B = (pullback_cone.snd c ≫ limits.prod.map (hat m) (𝟙 B)) ≫ limits.prod.map (internal_image f) (𝟙 B),
    { rw pullback_cone.condition, rw assoc, congr' 1, apply prod_functorial },
    set q : c.X ⟶ ni A := (square.is_pullback (mem A ≫ limits.prod.map (𝟙 (P A)) f)).lift (pullback_cone.mk (pullback_cone.fst c) (pullback_cone.snd c ≫ limits.prod.map (hat m) (𝟙 B)) qcomm),

    have: q ≫ mem A ≫ limits.prod.map (𝟙 (P A)) f = c.π.app walking_cospan.right ≫ (limits.prod.map (hat m) (𝟙 B)),
    { erw (square.is_pullback (mem A ≫ limits.prod.map (𝟙 (P A)) f)).fac _ walking_cospan.right, refl },
    show q ≫ _ ≫ _ ≫ _ = _,
    have := this =≫ limits.prod.snd,
    simp at this,
    rw this, erw comp_id },
  { dsimp, intros c k J,
    apply (square.is_pullback m).hom_ext, apply pullback_cone.equalizer_ext (pullback_cone.mk (square.top m) m _),
    { apply (square.is_pullback (mem A ≫ limits.prod.map (𝟙 (P A)) f)).hom_ext, apply pullback_cone.equalizer_ext (pullback_cone.mk _ _ _),
      simp, exact J walking_cospan.left,
      change (k ≫ square.top m) ≫ (mem A ≫ limits.prod.map (𝟙 (P A)) f) =
      ((square.is_pullback m).lift
            (pullback_cone.mk
                ((square.is_pullback (mem A ≫ limits.prod.map (𝟙 (P A)) f)).lift
                  (pullback_cone.mk (pullback_cone.fst c) (_ ≫ limits.prod.map (hat m) (𝟙 B)) _))
                (prod.lift (_ ≫ limits.prod.fst)
                  ((square.is_pullback (mem A ≫ limits.prod.map (𝟙 (P A)) f)).lift
                        (pullback_cone.mk (pullback_cone.fst c) (_ ≫ limits.prod.map (hat m) (𝟙 B)) _) ≫
                      mem A ≫ limits.prod.snd))
                _) ≫
          square.top m) ≫ (mem A ≫ limits.prod.map (𝟙 (P A)) f),
      erw (square.is_pullback m).fac _ walking_cospan.left, dsimp,
      erw (square.is_pullback (mem A ≫ limits.prod.map (𝟙 (P A)) f)).fac _ walking_cospan.right, dsimp,
      have: k ≫ (m ≫ limits.prod.map (𝟙 D) f) = pullback_cone.snd c := J walking_cospan.right, erw ← this,
      conv_lhs { rw ← assoc, congr, rw assoc, congr, skip, rw square.commutes m }, apply prod.hom_ext; simp, congr' 3,
      dsimp, simp,
      dsimp, simp },
    { apply prod.hom_ext,
      { erw (square.is_pullback m).fac _ walking_cospan.right, dsimp,
        simp,
        have: k ≫ (m ≫ limits.prod.map (𝟙 D) f) = pullback_cone.snd c := J walking_cospan.right, erw ← this,
        simp, congr' 2, erw comp_id },
      { rw ← cancel_mono f, simp,
        have qcomm: pullback_cone.fst c ≫ mem B = (pullback_cone.snd c ≫ limits.prod.map (hat m) (𝟙 B)) ≫ limits.prod.map (internal_image f) (𝟙 B),
        { rw pullback_cone.condition, rw assoc, congr' 1, apply prod_functorial },
        set q : c.X ⟶ ni A := (square.is_pullback (mem A ≫ limits.prod.map (𝟙 (P A)) f)).lift (pullback_cone.mk (pullback_cone.fst c) (pullback_cone.snd c ≫ limits.prod.map (hat m) (𝟙 B)) qcomm),

        have: q ≫ mem A ≫ limits.prod.map (𝟙 (P A)) f = c.π.app walking_cospan.right ≫ (limits.prod.map (hat m) (𝟙 B)),
        { erw (square.is_pullback (mem A ≫ limits.prod.map (𝟙 (P A)) f)).fac _ walking_cospan.right, refl },
        have := this =≫ limits.prod.snd,
        simp at this, rw this,
        erw ← J walking_cospan.right,
        simp, congr' 3,
        erw comp_id
      }
    }
  }
end

lemma internal_image_map_comp {X Y Z : C} [has_power_object.{v} X] [has_power_object.{v} Y] [has_power_object.{v} Z]
  (f : X ⟶ Y) (g : Y ⟶ Z) [mono f] [mono g] :
  internal_image (f ≫ g) = internal_image f ≫ internal_image g :=
begin
  erw naturalish, rw internal_image,
  congr' 1, rw prod_functorial',
  simp
end

def powerises_id (A : C) [has_power_object.{v} A] : powerises (mem A) (mem A) (𝟙 (P A)) :=
{ top := 𝟙 _,
  commutes := begin apply prod.hom_ext; simp, erw comp_id, erw comp_id end,
  forms_pullback' := begin convert pullback.with_id_l' (mem A), all_goals {apply prod.hom_ext; simp, erw comp_id, erw comp_id },  end
}
lemma internal_image_map_id {X : C} [has_power_object.{v} X] : internal_image (𝟙 X) = 𝟙 (P X) :=
begin
  symmetry, apply unique_hat,
  convert powerises_id X,
  apply prod.hom_ext; simp, erw comp_id, erw comp_id
end

theorem beck_chevalley {A B C' D : C}
  [has_power_object.{v} A] [has_power_object.{v} B]
  [has_power_object.{v} C'] [has_power_object.{v} D]
  (h : D ⟶ A) (f : A ⟶ C') (k : D ⟶ B) (g : B ⟶ C') (comm : h ≫ f = k ≫ g) [mono f] [mono k]
  (t : is_limit (pullback_cone.mk h k comm)) :
  internal_image f ≫ P_map g = P_map h ≫ internal_image k :=
begin
  erw naturalish,
  erw hat_natural_right,
  set X := pullback (mem A ≫ limits.prod.map (𝟙 (P A)) f) (limits.prod.map (𝟙 (P A)) g),
  set π₁ : X ⟶ ni A := pullback.fst,
  set π₂ : X ⟶ P A ⨯ B := pullback.snd,
  have comm2: (π₁ ≫ mem A ≫ limits.prod.snd) ≫ f = (π₂ ≫ limits.prod.snd) ≫ g,
    have: (π₁ ≫ _) ≫ _ = (_ ≫ _) ≫ _ := pullback.condition =≫ limits.prod.snd,
    simp at this, rwa [assoc, assoc, assoc],
  set l: X ⟶ D := t.lift (pullback_cone.mk (π₁ ≫ mem A ≫ limits.prod.snd) (π₂ ≫ limits.prod.snd) comm2),
  have lprop₁: l ≫ h = π₁ ≫ mem A ≫ limits.prod.snd,
    exact t.fac (pullback_cone.mk (π₁ ≫ mem A ≫ limits.prod.snd) (π₂ ≫ limits.prod.snd) comm2) walking_cospan.left,
  have lprop₂: l ≫ k = π₂ ≫ limits.prod.snd,
    exact t.fac (pullback_cone.mk (π₁ ≫ mem A ≫ limits.prod.snd) (π₂ ≫ limits.prod.snd) comm2) walking_cospan.right,
  have comm3: π₁ ≫ mem A ≫ limits.prod.fst = π₂ ≫ limits.prod.fst,
    have: (π₁ ≫ _) ≫ _ = (_ ≫ _) ≫ _ := pullback.condition =≫ limits.prod.fst,
    simp at this, erw [comp_id, comp_id] at this, assumption,
  refine lifting _ _ _ _,
  { apply pullback.lift π₁ (limits.prod.lift (π₂ ≫ limits.prod.fst) l) _,
    apply prod.hom_ext, rw [assoc, comm3], simp, erw comp_id, rw [assoc, ← lprop₁], simp },
  { refine pullback.lift pullback.fst (pullback.snd ≫ limits.prod.map (𝟙 _) k) _,
    slice_lhs 1 2 {rw pullback.condition},
    rw [assoc, assoc, ← prod_functorial', comm, prod_functorial'] },
  { rw ← assoc, erw limit.lift_π, apply prod.hom_ext; simp, erw comp_id,
    exact lprop₂.symm },
  { erw limit.lift_π, refl }
end

def classifying_powers [has_power_object.{v} (⊤_ C)] {U X : C} (f : U ⟶ X) [mono f] :
  classifying (mem (⊤_ C) ≫ limits.prod.fst) f (hat (f ≫ prod.lift (𝟙 X) (terminal.from X))) :=
{ k := square.top (f ≫ prod.lift (𝟙 X) (terminal.from X)),
  commutes :=
  begin
    rw ← assoc,
    rw square.commutes (f ≫ limits.prod.lift (𝟙 X) (terminal.from X)),
    simp, erw id_comp,
  end,
  forms_pullback' :=
  { lift := λ s,
    begin
      apply (square.is_pullback (f ≫ limits.prod.lift (𝟙 X) (terminal.from X))).lift (pullback_cone.mk (pullback_cone.fst s) _ _),
      apply pullback_cone.snd s ≫ (prod.right_unitor _).inv,
      apply prod.hom_ext,
      simp, rw pullback_cone.condition s, erw id_comp,
      apply subsingleton.elim,
    end,
    fac' := λ s,
    begin
      have comm: pullback_cone.fst s ≫ mem (⊤_ C) = (pullback_cone.snd s ≫ (prod.right_unitor X).inv) ≫ limits.prod.map (hat (f ≫ limits.prod.lift (𝟙 X) (terminal.from X))) (𝟙 (⊤_ C)),
        apply prod.hom_ext,
        simp, rw pullback_cone.condition s, erw id_comp,
        apply subsingleton.elim,
      apply pi_app_left (pullback_cone.mk (square.top (f ≫ prod.lift (𝟙 X) (terminal.from X))) f _) s,
      exact (square.is_pullback (f ≫ limits.prod.lift (𝟙 X) (terminal.from X))).fac (pullback_cone.mk (pullback_cone.fst s) _ comm) walking_cospan.left,
      have := (square.is_pullback (f ≫ limits.prod.lift (𝟙 X) (terminal.from X))).fac (pullback_cone.mk (pullback_cone.fst s) (pullback_cone.snd s ≫ (prod.right_unitor _).inv) comm) walking_cospan.right =≫ limits.prod.fst,
      dsimp at this, rw [assoc, assoc, assoc] at this, simp at this, exact this
    end,
    uniq' := λ s m J,
    begin
      have comm: pullback_cone.fst s ≫ mem (⊤_ C) = (pullback_cone.snd s ≫ (prod.right_unitor X).inv) ≫ limits.prod.map (hat (f ≫ limits.prod.lift (𝟙 X) (terminal.from X))) (𝟙 (⊤_ C)),
          apply prod.hom_ext,
          simp, rw pullback_cone.condition s, erw id_comp,
          apply subsingleton.elim,
      apply (square.is_pullback (f ≫ limits.prod.lift (𝟙 X) (terminal.from X))).uniq (pullback_cone.mk (pullback_cone.fst s) _ comm),
      apply pi_app_left (pullback_cone.mk (square.top (f ≫ limits.prod.lift (𝟙 X) (terminal.from X))) (f ≫ limits.prod.lift (𝟙 X) (terminal.from X)) _) (pullback_cone.mk (pullback_cone.fst s) (pullback_cone.snd s ≫ (prod.right_unitor X).inv) comm),
      dsimp,
      -- change m ≫ (square.top (f ≫ limits.prod.lift (𝟙 X) (terminal.from X))) = (pullback_cone.fst s),
      exact J walking_cospan.left,
      change m ≫ (f ≫ prod.lift (𝟙 X) (terminal.from X)) = pullback_cone.snd s ≫ (prod.right_unitor X).inv,
      apply prod.hom_ext,
      simp, exact J walking_cospan.right,
      apply subsingleton.elim
    end
  }
}

def classifying_powers' [has_power_object.{v} (⊤_ C)] {U X : C} (f : U ⟶ X) [mono f]
  (χ₁ : X ⟶ P (⊤_ C)) (k : classifying (mem (⊤_ C) ≫ (prod.right_unitor (P (⊤_ C))).hom) f χ₁) :
  powerises (mem (⊤_ C)) (f ≫ prod.lift (𝟙 X) (terminal.from X)) χ₁ :=
begin
  set top := k.k,
  have comm: top ≫ _ = _ ≫ _ := k.commutes,
  have pb: is_limit (pullback_cone.mk _ _ comm) := k.forms_pullback',
  refine ⟨top, _, _⟩,
  { apply prod.hom_ext,
    { rw assoc, erw comm, simp, erw id_comp },
    { apply subsingleton.elim } },
  { refine ⟨_, _, _⟩,
    { intro s,
      apply pb.lift (pullback_cone.mk (pullback_cone.fst s) (pullback_cone.snd s ≫ limits.prod.fst) _),
      rw assoc,
      have := pullback_cone.condition s =≫ limits.prod.fst,
      simp at this, exact this },
    { intro s, apply pi_app_left (pullback_cone.mk top (f ≫ prod.lift (𝟙 X) (terminal.from X)) _) _,
      exact pb.fac (pullback_cone.mk (pullback_cone.fst s) (pullback_cone.snd s ≫ limits.prod.fst) _) walking_cospan.left,
      erw ← assoc,
      erw pb.fac (pullback_cone.mk (pullback_cone.fst s) (pullback_cone.snd s ≫ limits.prod.fst) _) walking_cospan.right,
      erw assoc,
      erw (prod.right_unitor X).hom_inv_id,
      erw comp_id },
    { intros s m J,
      apply pb.uniq (pullback_cone.mk (pullback_cone.fst s) (pullback_cone.snd s ≫ limits.prod.fst) _),
      apply pi_app_left (pullback_cone.mk top f comm) (pullback_cone.mk (pullback_cone.fst s) (pullback_cone.snd s ≫ limits.prod.fst) _),
      exact J walking_cospan.left,
      dunfold pullback_cone.snd, dsimp,
      conv_rhs {rw [← J walking_cospan.right, assoc]},
      dsimp,
      simp }
  }
end

instance weak_topos_has_subobj [has_power_object.{v} (⊤_ C)] : has_subobject_classifier.{v} C :=
{ Ω := P (⊤_ C),
  Ω₀ := ni (⊤_ C),
  truth := mem (⊤_ C) ≫ (prod.right_unitor _).hom,
  truth_mono' := begin apply_instance end,
  classifier_of := λ U X f hf,
  begin
    haveI := hf,
    apply hat (f ≫ limits.prod.lift (𝟙 _) (terminal.from _))
  end,
  classifies' := λ U X f hf, @classifying_powers _ _ _ _ _ _ _ hf,
  uniquely' := λ U X f hf χ₁ k,
  begin
    haveI := hf,
    apply unique_hat,
    apply classifying_powers' f,
    exact k
  end
}

instance p_conservative [has_power_objects.{v} C] {A B : C} (f : A ⟶ B) [is_iso (P_map f)] : is_iso f :=
begin
  apply @balanced _ 𝒞 _ _ _ _ _ _,
  { split,
    intros,
    apply p_faithful g h,
    rw [← cancel_mono (P_map f), ← P_map_comp, w, P_map_comp] },
  { split,
    intros,
    apply p_faithful g h,
    rw [← cancel_epi (P_map f), ← P_map_comp, w, P_map_comp] }
end

namespace intersect

variables (A : C) [has_power_object.{v} A]

@[reducible]
def π₁₃ : (P A ⨯ P A) ⨯ A ⟶ P A ⨯ A := limits.prod.map limits.prod.fst (𝟙 A)
@[reducible]
def π₂₃ : (P A ⨯ P A) ⨯ A ⟶ P A ⨯ A := limits.prod.map limits.prod.snd (𝟙 A)

def L1 : C := pullback (mem A) (π₁₃ A)
def R1 : C := pullback (mem A) (π₂₃ A)

@[reducible]
def left : L1 A ⟶ (P A ⨯ P A) ⨯ A := pullback.snd
def right : R1 A ⟶ (P A ⨯ P A) ⨯ A := pullback.snd

instance mono_right: mono (right A) :=
begin
  dunfold right,
  apply_instance
end

@[reducible]
def both : pullback (left A) (right A) ⟶ (P A ⨯ P A) ⨯ A := pullback.fst ≫ left A

def intersect : P A ⨯ P A ⟶ P A := hat (both A)

end intersect

-- lemma intersect_prop (R₁ R₂ : C) (f₁ : R₁ ⟶ B ⨯ A) (f₂ : R₂ ⟶ B ⨯ A) [mono f₁] [mono f₂] :
--   hat ((pullback.fst : pullback f₁ f₂ ⟶ R₁) ≫ f₁) = limits.prod.lift (hat f₁) (hat f₂) ≫ intersect.intersect A :=
-- begin
--   symmetry,
--   apply unique_hat,
--   refine ⟨_ ≫ square.top (intersect.both A), _, _⟩,
--   { apply pullback.lift _ _ _,
--     { apply pullback.lift _ _ _,
--       { apply pullback.fst ≫ square.top f₁ },
--       { apply pullback.fst ≫ f₁ ≫ limits.prod.map (limits.prod.lift (hat f₁) (hat f₂)) (𝟙 A) },
--       { slice_lhs 2 3 {rw square.commutes f₁},
--         rw [assoc, assoc, ← prod_functorial, limit.lift_π], refl } },
--     { apply pullback.lift _ _ _,
--       { apply pullback.snd ≫ square.top f₂ },
--       { apply pullback.fst ≫ f₁ ≫ limits.prod.map (limits.prod.lift (hat f₁) (hat f₂)) (𝟙 A) },
--       { slice_lhs 2 3 {rw square.commutes f₂},
--         slice_lhs 1 2 {rw ← pullback.condition},
--         rw [assoc, assoc, assoc, ← prod_functorial, limit.lift_π], refl } },
--     { rw [limit.lift_π], dsimp, erw [limit.lift_π], dsimp, refl } },
--   { slice_lhs 2 3 {rw square.commutes (intersect.both A)},
--     dunfold intersect.both,
--     slice_lhs 1 2 {rw limit.lift_π},
--     dsimp,
--     slice_lhs 1 2 {rw limit.lift_π},
--     dsimp,
--     rw [assoc, assoc, assoc],
--     rw prod_functorial,
--     refl },
--   { refine ⟨_, _, _⟩,
--     { intro s,
--       set toB' : s.X ⟶ pullback (intersect.left A) (intersect.right A) := (square.is_pullback (intersect.both A)).lift (pullback_cone.mk (pullback_cone.fst s) (pullback_cone.snd s ≫ limits.prod.map (limits.prod.lift (hat f₁) (hat f₂)) (𝟙 A)) _),

--     }

--   }
-- end


import Duper.MClause
import Duper.RuleM
import Duper.Simp
import Duper.Util.ProofReconstruction

namespace Duper
open Lean
open Meta
open RuleM
open SimpResult

initialize Lean.registerTraceClass `Rule.existsHoist

theorem exists_hoist_proof {y : α → Prop} (x : α) (f : Prop → Prop) (h : f (∃ z : α, y z)) : f True ∨ y x = False := by
  by_cases z_hyp : ∃ z : α, y z
  . exact Or.inl (eq_true z_hyp ▸ h)
  . simp at z_hyp
    exact Or.inr (eq_false (z_hyp x))

def mkExistsHoistProof (pos : ClausePos) (premises : List Expr) (parents : List ProofParent)
  (transferExprs : Array Expr) (c : Clause) : MetaM Expr :=
  Meta.forallTelescope c.toForallExpr fun xs body => do
    let cLits := c.lits.map (fun l => l.map (fun e => e.instantiateRev xs))
    let (parentsLits, appliedPremises, transferExprs) ← instantiatePremises parents premises xs transferExprs
    let parentLits := parentsLits[0]!
    let appliedPremise := appliedPremises[0]!

    let #[freshVar1] := transferExprs
      | throwError "mkExistsHoistProof :: Wrong number of number of newVarIndices"

    let mut caseProofs := Array.mkEmpty parentLits.size
    for i in [:parentLits.size] do
      let lit := parentLits[i]!
      let pr : Expr ← Meta.withLocalDeclD `h lit.toExpr fun h => do
        if i == pos.lit then
          let substLitPos : LitPos := ⟨pos.side, pos.pos⟩
          let abstrLit ← (lit.abstractAtPos! substLitPos)
          let abstrExp := abstrLit.toExpr
          let abstrLam := mkLambda `x BinderInfo.default (mkSort levelZero) abstrExp
          let lastTwoLitsProof ← Meta.mkAppM ``exists_hoist_proof #[freshVar1, abstrLam, h]
          Meta.mkLambdaFVars #[h] $ ← orSubclause (cLits.map Lit.toExpr) 2 lastTwoLitsProof
        else
          let idx := if i ≥ pos.lit then i - 1 else i
          Meta.mkLambdaFVars #[h] $ ← orIntro (cLits.map Lit.toExpr) idx h
      caseProofs := caseProofs.push pr
    let r ← orCases (parentLits.map Lit.toExpr) caseProofs
    Meta.mkLambdaFVars xs $ mkApp r appliedPremise

def existsHoistAtExpr (e : Expr) (pos : ClausePos) (given : Clause) (c : MClause) : RuleM (Array ClauseStream) :=
  withoutModifyingMCtx do
    let lit := c.lits[pos.lit]!
    if e.getTopSymbol.isMVar then -- Check condition 4
      -- If the head of e is a variable then it must be applied and the affected literal must be either
      -- e = True, e = False, or e = e' where e' is another variable headed term
      if not e.isApp then -- e is a non-applied variable and so we cannot apply neHoist
        return #[]
      if pos.pos != #[] then
        return #[] -- e is not at the top level so the affected literal cannot have the form e = ...
      if not lit.sign then
        return #[] -- The affected literal is not positive and so it cannot have the form e = ...
      let otherSide := lit.getOtherSide pos.side
      if otherSide != (mkConst ``True) && otherSide != (mkConst ``False) && not otherSide.getTopSymbol.isMVar then
        return #[] -- The other side is not True, False, or variable headed, so the affected literal cannot have the required form
    -- Check conditions 1 and 3 (condition 2 is guaranteed by construction)
    let eligibility ← eligibilityPreUnificationCheck c pos.lit
    if eligibility == Eligibility.notEligible then
      return #[]
    -- Make freshVars, freshVarExistsExpr and newLitLhs
    let freshVar1 ← mkFreshExprMVar none
    let freshVar1Ty ← inferType freshVar1
    let freshVar2Ty := Expr.forallE .anonymous freshVar1Ty (mkSort levelZero) BinderInfo.default -- freshVar1Ty → Prop
    let freshVar2 ← mkFreshExprMVar freshVar2Ty
    let freshVarExistsExpr ← mkAppM ``Exists #[freshVar2]
    let newLitLhs := .app freshVar2 freshVar1
    -- Perform unification
    let ug ← unifierGenerator #[(e, freshVarExistsExpr)]
    let loaded ← getLoadedClauses
    let yC := do
      setLoadedClauses loaded
      if not $ ← eligibilityPostUnificationCheck c pos.lit eligibility (strict := lit.sign) then
        return none
      let eSide ← instantiateMVars $ lit.getSide pos.side
      let otherSide ← instantiateMVars $ lit.getOtherSide pos.side
      let cmp ← compare eSide otherSide
      if cmp == Comparison.LessThan || cmp == Comparison.Equal then -- If eSide ≤ otherSide then e is not in an eligible position
        return none
      -- All side conditions have been met. Yield the appropriate clause
      let cErased := c.eraseLit pos.lit
      -- Need to instantiate mvars in newLitLhs because unification assigned to mvars in it
      let newLitLhs ← instantiateMVars newLitLhs
      let newClause := cErased.appendLits #[← lit.replaceAtPos! ⟨pos.side, pos.pos⟩ (mkConst ``True), Lit.fromSingleExpr newLitLhs (sign := false)]
      trace[Rule.existsHoist] "Created {newClause.lits} from {c.lits}"
      yieldClause newClause "existsHoist" (some (mkExistsHoistProof pos)) (transferExprs := #[freshVar1])
    return #[ClauseStream.mk ug given yC "existsHoist"]

def existsHoist (given : Clause) (c : MClause) (cNum : Nat) : RuleM (Array ClauseStream) := do
  trace[Rule.existsHoist] "Running ExistsHoist on {c.lits}"
  let fold_fn := fun streams e pos => do
    let str ← existsHoistAtExpr e.consumeMData pos given c
    return streams.append str
  c.foldGreenM fold_fn #[]


import model_theory.substructures
import model_theory.bundled

--OUTPUT 1
theorem overflow {L : first_order.language} {F : L.Theory} (h : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin) : ∃ (M : F.Model), infinite M :=
begin
  have h1 : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin, from h,
  have h2 : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin, from h1,
  have h3 : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin, from h2,
  have h4 : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin, from h3,
  have h5 : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin, from h4,
  have h6 : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin, from h5,
  have h7 : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin, from h6,
  have h8 : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin, from h7,
  have h9 : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin, from h8,
  have h10 : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin, from h9,
  have h11 : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin, from h10,
  have h12 : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin, from h11,
  have h13 : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin, from h12,
  have h14 : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin, from h13,
  have h15 : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin, from h14,
  have h16 : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin, from h15,
  have h17 : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin, from h16,
  have h18 : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin, from h17,
  have h19 : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin, from h18,
  have h20 : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin, from h19,
  have h21 : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin, from h20,
  have h22 : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin, from h21,
  have h23 : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin, from h22,
  have h24 : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin, from h23,
  have h25 : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin, from h24,
  have h26 : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin, from h25,
  have h27 : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin, from h26,
  have h28 : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin, from h27,
  have h29 : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin, from h28,
  have h30 : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin, from h29,
  have h31 : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin, from h30,
  have h32 : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin, from h31,
  have h33 : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin, from h32,
  have h34 : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin, from h33,
  have h35 : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin, from h34,
  have h36 : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin, from h35,
  have h37 : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin, from h36,
  have h38 : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin, from h37,
  have h39 : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin, from h38,
  have h40 : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin, from h39,
  have h41 : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin, from h40,
  have h42 : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m
end --Needs more than 2000 tokens!

--OUTPUT 2
theorem overflow {L : first_order.language} {F : L.Theory} (h : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin) : ∃ (M : F.Model), infinite M :=
begin
  -- For each $n$, let $\mathbf A_n$ be the formula:
  -- $\exists x_1 \exists x_2 \ldots \exists x_n: \{x_1 \ne x_2 \land x_1 \ne x_3 \land \ldots \land x_{n - 1} \ne x_n\}$
  have h1 : ∀ n : ℕ, ∃ (A : L.Formula), ∀ (m : F.Model) [mfin : fintype m], (m ⊨ A) ↔ (n ≤ @fintype.card m mfin), from by {
    assume n : ℕ,
    have h1 : ∃ (A : L.Formula), ∀ (m : F.Model) [mfin : fintype m], (m ⊨ A) ↔ (∃ (x₁ x₂ : m), x₁ ≠ x₂), from by {
      use (∃ (x₁ x₂ : L.Var), L.Eq x₁ x₂),
      assume (m : F.Model) [mfin : fintype m],
      have h1 : ∃ (x₁ x₂ : m), x₁ ≠ x₂, from by {
        cases @fintype.card m mfin with n hn,
        cases n with n hn,
        use m.default, use m.default, obviously,
        cases hn with x hx,
        use x, use x, obviously,
      },
      have h2 : (m ⊨ ∃ (x₁ x₂ : L.Var), L.Eq x₁ x₂) ↔ (∃ (x₁ x₂ : m), x₁ ≠ x₂), from by {
        split,
        assume h2 : (m ⊨ ∃ (x₁ x₂ : L.Var), L.Eq x₁ x₂),
        cases h2 with x hx,
        cases hx with y hy,
        cases hy with hxy hxy,
        use x, use y,
        have h3 : x ≠ y, from by {
          assume h3 : x = y,
          have h4 : m ⊨ L.Eq x y, from by {
            apply F.Model.eval_eq,
            rw ← hxy,
            rw h3,
          },
          have h5 : m ⊨ L.Not (L.Eq x y), from by {
            apply F.Model.eval_not,
            apply F.Model.eval_eq,
            rw ← hxy,
            rw h3,
          },
          have h6 : ¬(m ⊨ L.Eq x y), from by {
            apply F.Model.eval_not_iff,
            exact h5,
          },
          cases h6 h4,
        },
        exact h3,
        assume h2 : (∃ (x₁ x₂ : m), x₁ ≠ x₂),
        cases h2 with x hx,
        cases hx with y hy,
        use x, use y,
        have h3 : m ⊨ L.Eq x y, from by {
          apply F.Model.eval_eq,
          rw ← hxy,
          rw hy,
        },
        have h4 : m ⊨ L.Not (L.Eq x y), from by {
          apply F.Model.eval_not,
          apply F.Model.eval_eq,
          rw ← hxy,
          rw hy,
        },
        have h5 : ¬(m ⊨ L.Eq x y), from by {
          apply F.Model.eval_not_iff,
          exact h4,
        },
        have h6 : m ⊨ L.Not (L.Eq x y), from by {
          apply F.Model.eval_not,
          apply F.Model.eval_eq,
          rw ← hxy,
          rw hy,
        },
        have h7 : ¬(m ⊨ L.Eq x y), from by {
          apply F.Model.eval_not_iff,
          exact h6,
        },
        cases h7 h3,
      },
      exact h2,
    },
    cases h1 with A hA,
    have h2 : ∃ (A : L.Formula), ∀ (m : F.Model) [mfin : fintype m], (m ⊨ A) ↔ (∃ (x₁ x₂ : m), x₁ ≠ x₂), from by {
      use (∃ (x₁ x₂ : L.Var), L.Eq x₁ x₂),
      assume (m : F.Model) [mfin : fintype m],
      have h1 : ∃ (x₁ x₂ : m), x₁ ≠ x₂, from by {
        cases @fintype.card m mfin with n hn,
        cases n with n hn,
        use m.default, use m.default, obviously,
        cases hn with x hx,
        use x, use x, obviously,
      },
      have h2 : (m ⊨ ∃ (x₁ x₂ : L.Var), L.Eq x₁ x₂) ↔ (∃ (x₁ x₂ : m), x₁ ≠ x₂), from by {
        split,
        assume h2 : (m ⊨ ∃ (x₁ x₂ : L.Var), L.Eq x₁ x₂),
        cases h2 with x hx,
        cases hx with y hy,
        cases hy with hxy hxy,
        use x, use y,
        have h3 : x ≠ y, from by {
          assume h3 : x = y,
          have h4 : m ⊨ L.Eq x y, from by {
            apply F.Model.eval_eq,
            rw ← hxy,
            rw h3,
          },
          have h5 : m ⊨ L.Not (L.Eq x y), from by {
            apply F.Model.eval_not,
            apply F.Model.eval_eq,
            rw ← hxy,
            rw h3,
          },
          have h6 : ¬(m ⊨ L.Eq x y), from by {
            apply F.Model.eval_not_iff,
            exact h5,
          },
          cases h6 h4,
        },
        exact h3,
        assume h2 : (∃ (x₁ x₂ : m), x₁ ≠ x₂),
        cases h2 with x hx,
        cases hx with y hy,
        use x, use y,
        have h3 : m ⊨ L.Eq x y, from by {
          apply F.Model.eval_eq,
          rw ← hxy,
          rw hy,
        },
        have h4 : m ⊨ L.Not (L.Eq x y), from by {
          apply F.Model.eval_not,
          apply F.Model.eval_eq,
          rw ← hxy,
          rw hy,
        },
        have h5 : ¬(m ⊨ L.Eq x y), from by {
          apply F.Model.eval_not_iff,
          exact h4,
        },
        have h6 : m ⊨ L.Not (L.Eq x y), from by {
          apply F.Model.eval_not,
          apply F.Model.eval_eq,
          rw ← hxy,
          rw hy,
        },
        have h7 : ¬(m ⊨ L.Eq x y), from by {
          apply F.Model.eval_not_iff,
          exact h6,
        },
        cases h7 h
end --Needs more than 2000 tokens!

--OUTPUT 3
theorem overflow {L : first_order.language} {F : L.Theory} (h : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin) : ∃ (M : F.Model), infinite M :=
begin
  -- For each $n$, let $\mathbf A_n$ be the formula:
  -- $\exists x_1 \exists x_2 \ldots \exists x_n: \{x_1 \ne x_2 \land x_1 \ne x_3 \land \ldots \land x_{n - 1} \ne x_n\}$
  -- Then $\mathbf A_i$ is true in a structure $\AA$ iff $\AA$ has at least $n$ elements.
  have h1 : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin, from h,
  have h2 : ∀ n : ℕ, ∃ (M : F.Model), @fintype.card M (fintype.of_injective M.to_fun) ≤ n, from assume n : ℕ,
    let ⟨M,mfin,h3⟩ := h1 n in ⟨M,by {rw ← nat.le_sub_left_iff_add_le h3, rw nat.add_comm, apply nat.le_add_left, apply nat.zero_le}⟩,
  have h3 : ∀ n : ℕ, ∃ (M : F.Model), @fintype.card M (fintype.of_injective M.to_fun) = n, from assume n : ℕ,
    let ⟨M,h4⟩ := h2 n in ⟨M,by {rw nat.eq_iff_le_and_le, split, apply nat.le_of_eq_zero_or_pos, apply nat.zero_le, apply h4}⟩,
  have h4 : ∀ n : ℕ, ∃ (M : F.Model), @fintype.card M (fintype.of_injective M.to_fun) ≥ n, from assume n : ℕ,
    let ⟨M,h5⟩ := h3 n in ⟨M,by {rw nat.le_iff_exists_add, existsi (n - 1), rw nat.add_sub_cancel, apply nat.zero_le}⟩,
  have h5 : ∀ n : ℕ, ∃ (M : F.Model), @fintype.card M (fintype.of_injective M.to_fun) ≥ n + 1, from assume n : ℕ,
    let ⟨M,h6⟩ := h4 n in ⟨M,by {rw nat.le_iff_exists_add, existsi (n - 1), rw nat.add_sub_cancel, apply nat.zero_le}⟩,
  have h6 : ∀ n : ℕ, ∃ (M : F.Model), @fintype.card M (fintype.of_injective M.to_fun) > n, from assume n : ℕ,
    let ⟨M,h7⟩ := h5 n in ⟨M,by {rw nat.lt_iff_le_and_ne, split, apply h7, apply nat.ne_of_lt h7}⟩,
  have h7 : ∀ n : ℕ, ∃ (M : F.Model), @fintype.card M (fintype.of_injective M.to_fun) ≥ n + 2, from assume n : ℕ,
    let ⟨M,h8⟩ := h6 n in ⟨M,by {rw nat.le_iff_exists_add, existsi (n - 1), rw nat.add_sub_cancel, apply nat.zero_le}⟩,
  have h8 : ∀ n : ℕ, ∃ (M : F.Model), @fintype.card M (fintype.of_injective M.to_fun) > n + 1, from assume n : ℕ,
    let ⟨M,h9⟩ := h7 n in ⟨M,by {rw nat.lt_iff_le_and_ne, split, apply h9, apply nat.ne_of_lt h9}⟩,

  -- Take:
  -- $$ \Gamma := F \cup \bigcup_{i \mathop = 1}^\infty A_i $$
  have h9 : ∀ n : ℕ, ∃ (M : F.Model), @fintype.card M (fintype.of_injective M.to_fun) > n + 1, from h8,
  have h10 : ∀ n : ℕ, ∃ (M : F.Model), @fintype.card M (fintype.of_injective M.to_fun) ≥ n + 2, from h7,
  have h11 : ∀ n : ℕ, ∃ (M : F.Model), @fintype.card M (fintype.of_injective M.to_fun) > n, from h6,
  have h12 : ∀ n : ℕ, ∃ (M : F.Model), @fintype.card M (fintype.of_injective M.to_fun) ≥ n + 1, from h5,
  have h13 : ∀ n : ℕ, ∃ (M : F.Model), @fintype.card M (fintype.of_injective M.to_fun) = n, from h3,
  have h14 : ∀ n : ℕ, ∃ (M : F.Model), @fintype.card M (fintype.of_injective M.to_fun) ≤ n, from h2,
  have h15 : ∀ n : ℕ, ∃ (M : F.Model) [mfin : fintype M], @fintype.card M mfin ≥ n + 1, from assume n : ℕ,
    let ⟨M,h16⟩ := h12 n in ⟨M,fintype.of_injective M.to_fun,h16⟩,
  have h16 : ∀ n : ℕ, ∃ (M : F.Model) [mfin : fintype M], @fintype.card M mfin ≥ n + 2, from assume n : ℕ,
    let ⟨M,h17⟩ := h10 n in ⟨M,fintype.of_injective M.to_fun,h17⟩,
  have h17 : ∀ n : ℕ, ∃ (M : F.Model) [mfin : fintype M], @fintype.card M mfin > n + 1, from assume n : ℕ,
    let ⟨M,h18⟩ := h9 n in ⟨M,fintype.of_injective M.to_fun,h18⟩,
  have h18 : ∀ n : ℕ, ∃ (M : F.Model) [mfin : fintype M], @fintype.card M mfin > n, from assume n : ℕ,
    let ⟨M,h19⟩ := h11 n in ⟨M,fintype.of_injective M.to_fun,h19⟩,
  have h19 : ∀ n : ℕ, ∃ (M : F.Model) [mfin : fintype M], @fintype.card M mfin = n, from assume n : ℕ,
    let ⟨M,h20⟩ := h13 n in ⟨M,fintype.of_injective M.to_fun,h20⟩,
  have h20 : ∀ n : ℕ, ∃ (M : F.Model) [mfin : fintype M], @fintype.card M mfin ≤ n, from assume n : ℕ,
    let ⟨M,h21⟩ := h14 n in ⟨M,fintype.of_injective M.to_fun,h21⟩,
  have h21 : ∀ n : ℕ, ∃ (M : F.Model) [mfin
end --Needs more than 2000 tokens!

--OUTPUT 4
theorem overflow {L : first_order.language} {F : L.Theory} (h : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin) : ∃ (M : F.Model), infinite M :=
begin
  -- For each $n$, let $\mathbf A_n$ be the formula:
  -- $\exists x_1 \exists x_2 \ldots \exists x_n: \{x_1 \ne x_2 \land x_1 \ne x_3 \land \ldots \land x_{n - 1} \ne x_n\}$
  let A (n : ℕ) := first_order.exists_list (list.repeat (L.sorts.default _) n) (first_order.and_list (list.map (λ i : fin n, first_order.ne (L.sorts.default _) (L.var (i.1)) (L.var (i.2))) (list.product (fin n) (fin n)))),

  -- Then $\mathbf A_i$ is true in a structure $\AA$ iff $\AA$ has at least $n$ elements.
  have h1 : ∀ (n : ℕ) (M : F.Model), M ⊨ A n ↔ M.card ≥ n, from by {
    assume n : ℕ,
    assume M : F.Model,
    split,
    assume hA : M ⊨ A n,
    have h1 : ∃ (l : list M.carrier), list.length l = n ∧ ∀ (i j : fin n), i ≠ j → l.nth i ≠ l.nth j, from by {
      apply first_order.exists_list_iff.mp hA,
      assume i : fin n,
      assume j : fin n,
      assume hne : i ≠ j,
      apply first_order.and_list_iff.mp,
      apply first_order.and_list_iff.mpr,
      apply list.mem_map.mp,
      apply list.mem_product.mpr,
      split,
      exact i,
      split,
      exact j,
      exact hne,
    },
    have h2 : ∃ (l : list M.carrier), list.length l = n ∧ list.nodup l, from by {
      cases h1 with l h1,
      use l,
      split,
      exact h1.left,
      apply list.nodup_of_nodup_of_eq_length_of_ne,
      apply list.nodup_iff_inj_on.mpr,
      assume x y hx hy hxy,
      exact h1.right hx hy hxy,
      exact h1.left,
      exact h1.left,
    },
    have h3 : ∃ (l : list M.carrier), list.length l = n ∧ list.nodup l ∧ ∀ (x : M.carrier), x ∈ l, from by {
      cases h2 with l h2,
      use l,
      split,
      exact h2.left,
      split,
      exact h2.right,
      assume x : M.carrier,
      apply list.mem_of_nodup_of_mem_of_length_eq,
      exact h2.right,
      apply list.mem_repeat,
      exact h2.left,
    },
    cases h3 with l h3,
    cases h3 with h3 h4,
    cases h3 with h3 h5,
    cases h3 with h3 h6,
    have h7 : M.card ≥ list.length l, from by {
      apply le_of_eq_of_le,
      apply card_of_nodup_of_mem_of_length_eq,
      exact h3,
      exact h5,
      exact h3,
    },
    rw h3 at h7,
    assumption,
    assume hcard : M.card ≥ n,
    have h1 : ∃ (l : list M.carrier), list.length l = n ∧ list.nodup l ∧ ∀ (x : M.carrier), x ∈ l, from by {
      cases exists_list_of_card_ge_length hcard with l h1,
      use l,
      split,
      exact h1.left,
      split,
      exact h1.right,
      assume x : M.carrier,
      apply list.mem_of_nodup_of_mem_of_length_eq,
      exact h1.right,
      apply list.mem_repeat,
      exact h1.left,
    },
    cases h1 with l h1,
    cases h1 with h1 h2,
    cases h1 with h1 h3,
    cases h1 with h1 h4,
    have h5 : ∀ (i j : fin n), i ≠ j → l.nth i ≠ l.nth j, from by {
      assume i : fin n,
      assume j : fin n,
      assume hne : i ≠ j,
      apply ne_of_mem_of_nodup_of_mem_of_ne,
      exact h4 (l.nth i),
      exact h1,
      exact h4 (l.nth j),
      exact hne,
    },
    have h6 : ∃ (l : list M.carrier), list.length l = n ∧ ∀ (i j : fin n), i ≠ j → l.nth i ≠ l.nth j, from ⟨l,h1,h5⟩,
    have h7 : ∃ (l : list M.carrier), list.length l = n ∧ ∀ (i j : fin n), i ≠ j → l.nth i ≠ l.nth j, from ⟨l,h1,h5⟩,
    apply first_order.exists_list_iff.mpr,
    exact h7,
    assume i : fin n,
    assume j : fin n,
    assume hne : i ≠ j,
    apply first_order.and_list_iff.mp,
    apply first_order.and_list_iff.mpr,
    apply list.mem_map.mp,
    apply list.mem_product.mpr,
    split,
    exact i,
    split,
    exact j,
    exact hne,
  },

  -- Take:
  -- $$ \Gamma := F \cup \bigcup_{i \mathop = 1}^\infty A_i $$
  let Γ : L.Theory := L.Theory.mk (F.to_formula_set ∪ {A n | n ∈ ℕ}),

  -- Since $F$ has models of arbitrarily large size, every finite subset of $\Gamma$ is satisfiable.
  have h2 : ∀ (Γ' : set L.formula), finite Γ' → Γ'.to_formula_set ⊆ Γ.to_formula_set → ∃ (M : F.Model), M ⊨ Γ', from by {
    assume Γ' : set L.formula,
    assume hfinite : finite Γ',
    assume hsub : Γ'.to_formula_set ⊆ Γ.to_formula_set,
    have h1 : ∃ (n : ℕ), ∀ (A : L.formula), A ∈ Γ' → A ∈ {A n | n ∈ ℕ}, from by {
      apply exists_nat_of_finite_subset_of_union_of_union hfinite hsub,
      exact set.univ,
      exact set.univ,
    },
    cases h1 with n h1,
    have h2 : ∃ (M : F.Model) [mfin : fintype M], n ≤ @fintype.card M mfin, from h n,
    cases h2 with M h2,
    cases h2 with mfin h2,
    use M,
    apply first_order.and_list_iff.mpr,
    apply list.mem_map.mp,
    apply list.mem_union_left,
    exact hsub,
    apply list.mem_union_right,
    apply set.mem_of_mem_image,
    split,
    exact h2,
    exact h1,
  },

  -- From the Compactness Theorem, $\Gam
end --Needs more than 2000 tokens!

--OUTPUT 5
theorem overflow {L : first_order.language} {F : L.Theory} (h : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin) : ∃ (M : F.Model), infinite M :=
begin
  -- For each $n$, let $\mathbf A_n$ be the formula:
  let A : ℕ → L.Formula,
  -- $\exists x_1 \exists x_2 \ldots \exists x_n: \{x_1 \ne x_2 \land x_1 \ne x_3 \land \ldots \land x_{n - 1} \ne x_n\}$
  { assume n : ℕ,
    let A' : L.Formula,
    { apply L.exists,
      assume x1 : L.Var,
      apply L.exists,
      assume x2 : L.Var,
      induction n with n hn,
      -- base case
      { exact L.true, },
      -- inductive case
      { apply L.exists,
        assume xn : L.Var,
        have h1 : n ≤ n, from le_refl n,
        have h2 : ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin, from h n,
        have h3 : ∃ (m : F.Model) [mfin : fintype m], n + 1 ≤ @fintype.card m mfin, from by {
          cases h2 with m h2,
          cases h2 with mfin h2,
          use m,
          use mfin,
          have h4 : n + 1 ≤ @fintype.card m mfin, from by {
            apply le_trans h2,
            apply nat.succ_le_succ,
            apply le_refl n,
          },
          exact h4,
        },
        have h4 : ∃ (m : F.Model) [mfin : fintype m], n + 1 ≤ @fintype.card m mfin, from by {
          cases h2 with m h2,
          cases h2 with mfin h2,
          use m,
          use mfin,
          have h4 : n + 1 ≤ @fintype.card m mfin, from by {
            apply le_trans h2,
            apply nat.succ_le_succ,
            apply le_refl n,
          },
          exact h4,
        },
        cases h4 with m h4,
        cases h4 with mfin h4,
        cases h4 with h4 h5,
        have h6 : n + 1 ≤ @fintype.card m mfin, from by {
          apply le_trans h2,
          apply nat.succ_le_succ,
          apply le_refl n,
        },
        have h7 : ∀ (a b : m), a ≠ b → L.Eq a b = L.false, from
          assume (a b : m) (hab : a ≠ b), L.Eq.ne a b hab,
        have h8 : ∀ (a b : m), a ≠ b → L.Eq a b = L.false, from
          assume (a b : m) (hab : a ≠ b), L.Eq.ne a b hab,
        have h9 : ∀ (a b : m), a ≠ b → L.Eq a b = L.false, from
          assume (a b : m) (hab : a ≠ b), L.Eq.ne a b hab,
        have h10 : ∀ (a b : m), a ≠ b → L.Eq a b = L.false, from
          assume (a b : m) (hab : a ≠ b), L.Eq.ne a b hab,
        have h11 : ∀ (a b : m), a ≠ b → L.Eq a b = L.false, from
          assume (a b : m) (hab : a ≠ b), L.Eq.ne a b hab,
        have h12 : ∀ (a b : m), a ≠ b → L.Eq a b = L.false, from
          assume (a b : m) (hab : a ≠ b), L.Eq.ne a b hab,
        have h13 : ∀ (a b : m), a ≠ b → L.Eq a b = L.false, from
          assume (a b : m) (hab : a ≠ b), L.Eq.ne a b hab,
        have h14 : ∀ (a b : m), a ≠ b → L.Eq a b = L.false, from
          assume (a b : m) (hab : a ≠ b), L.Eq.ne a b hab,
        have h15 : ∀ (a b : m), a ≠ b → L.Eq a b = L.false, from
          assume (a b : m) (hab : a ≠ b), L.Eq.ne a b hab,
        have h16 : ∀ (a b : m), a ≠ b → L.Eq a b = L.false, from
          assume (a b : m) (hab : a ≠ b), L.Eq.ne a b hab,
        have h17 : ∀ (a b : m), a ≠ b → L.Eq a b = L.false, from
          assume (a b : m) (hab : a ≠ b), L.Eq.ne a b hab,
        have h18 : ∀ (a b : m), a ≠ b → L.Eq a b = L.false, from
          assume (a b : m) (hab : a ≠ b), L.Eq.ne a b hab,
        have h19 : ∀ (a b : m), a ≠ b → L.Eq a b = L.false, from
          assume (a b : m) (hab : a ≠ b), L.Eq.ne a b hab,
        have h20 : ∀ (a b : m), a ≠ b → L.Eq a b = L.false, from
          assume (a b : m) (hab : a ≠ b), L.Eq.ne a b hab,
        have h21 : ∀ (a b : m), a ≠ b → L.Eq a b = L.false, from
          assume (a b : m) (hab : a ≠ b), L.Eq.ne a b hab,
        have h22 : ∀ (a b : m), a ≠ b → L.Eq a b = L.false, from
          assume (a b : m) (hab : a ≠ b), L.Eq.ne a b hab,
        have h23 : ∀ (a b : m), a ≠ b → L.Eq a b = L.false, from
          assume (a b : m) (hab : a ≠ b), L.Eq.ne a b hab,
        have h24 : ∀ (a b : m), a ≠ b → L.Eq a b = L.false, from
          assume (a b : m) (hab : a ≠ b), L.Eq.ne a b hab,
        have h25 : ∀ (a b : m), a ≠ b → L.Eq a b = L.false, from
          assume (a b : m) (hab : a ≠ b), L.Eq.ne a b hab,
        have h26 : ∀ (a b : m), a ≠ b → L.Eq a b = L.false, from
          assume (a b : m) (hab : a ≠ b), L.Eq.ne a b hab,
        have h27 : ∀ (a b : m), a ≠ b → L.Eq a b = L.false, from
          assume (a b : m) (hab : a ≠ b), L.Eq.ne a b hab,
        have h28 : ∀ (a b : m), a ≠ b → L.Eq a b = L.false, from
          assume (a b : m) (hab : a ≠ b), L.Eq.ne a b hab,
        have h29 : ∀ (a b : m), a ≠ b → L.Eq a b = L.false, from
          assume (a b : m) (hab : a ≠ b), L.Eq.ne a b hab,
        have h30 : ∀ (a b
end --Needs more than 2000 tokens!

--OUTPUT 6
theorem overflow {L : first_order.language} {F : L.Theory} (h : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin) : ∃ (M : F.Model), infinite M :=
begin
  -- For each $n$, let $\mathbf A_n$ be the formula:
  -- $\exists x_1 \exists x_2 \ldots \exists x_n: \{x_1 \ne x_2 \land x_1 \ne x_3 \land \ldots \land x_{n - 1} \ne x_n\}$
  let A : ℕ → L.formula,
  { assume n,
    let x : ℕ → L.term,
    { assume i, term.var (i - 1) },
    let y : ℕ → L.term,
    { assume i, term.var (i - 1) },
    let z : ℕ → L.formula,
    { assume i, formula.rel (term.app (term.const "≠") (term.app x i)) (term.app y i) },
    let w : ℕ → L.formula,
    { assume i, formula.rel (term.app (term.const "≠") (term.app y i)) (term.app x i) },
    let u : ℕ → L.formula,
    { assume i, formula.and (z i) (w i) },
    let v : ℕ → L.formula,
    { assume i, formula.exists (u i) },
    formula.and (v 1) (formula.and (v 2) (formula.and (v 3) (formula.and (v 4) (formula.and (v 5) (formula.and (v 6) (formula.and (v 7) (formula.and (v 8) (formula.and (v 9) (formula.and (v 10) (formula.and (v 11) (formula.and (v 12) (formula.and (v 13) (formula.and (v 14) (formula.and (v 15) (formula.and (v 16) (formula.and (v 17) (formula.and (v 18) (formula.and (v 19) (formula.and (v 20) (formula.and (v 21) (formula.and (v 22) (formula.and (v 23) (formula.and (v 24) (formula.and (v 25) (formula.and (v 26) (formula.and (v 27) (formula.and (v 28) (formula.and (v 29) (formula.and (v 30) (formula.and (v 31) (formula.and (v 32) (formula.and (v 33) (formula.and (v 34) (formula.and (v 35) (formula.and (v 36) (formula.and (v 37) (formula.and (v 38) (formula.and (v 39) (formula.and (v 40) (formula.and (v 41) (formula.and (v 42) (formula.and (v 43) (formula.and (v 44) (formula.and (v 45) (formula.and (v 46) (formula.and (v 47) (formula.and (v 48) (formula.and (v 49) (formula.and (v 50) (formula.and (v 51) (formula.and (v 52) (formula.and (v 53) (formula.and (v 54) (formula.and (v 55) (formula.and (v 56) (formula.and (v 57) (formula.and (v 58) (formula.and (v 59) (formula.and (v 60) (formula.and (v 61) (formula.and (v 62) (formula.and (v 63) (formula.and (v 64) (formula.and (v 65) (formula.and (v 66) (formula.and (v 67) (formula.and (v 68) (formula.and (v 69) (formula.and (v 70) (formula.and (v 71) (formula.and (v 72) (formula.and (v 73) (formula.and (v 74) (formula.and (v 75) (formula.and (v 76) (formula.and (v 77) (formula.and (v 78) (formula.and (v 79) (formula.and (v 80) (formula.and (v 81) (formula.and (v 82) (formula.and (v 83) (formula.and (v 84) (formula.and (v 85) (formula.and (v 86) (formula.and (v 87) (formula.and (v 88) (formula.and (v 89) (formula.and (v 90) (formula.and (v 91) (formula.and (v 92) (formula.and (v 93) (formula.and (v 94) (formula.and (v 95) (formula.and (v 96) (formula.and (v 97) (formula.and (v 98) (formula.and (v 99) (formula.and (v 100) (formula.and (v 101) (formula.and (v 102) (formula.and (v 103) (formula.and (v 104) (formula.and (v 105) (formula.and (v 106) (formula.and (v 107) (formula.and (v 108) (formula.and (v 109) (formula.and (v 110) (formula.and (v 111) (formula.and (v 112) (formula.and (v 113) (formula.and (v 114) (formula.and (v 115) (formula.and (v 116) (formula.and (v 117) (formula.and (v 118) (formula.and (v 119) (formula.and (v 120) (formula.and (v 121) (formula.and (v 122) (formula.and (v 123) (formula.and (v 124) (formula.and (v 125) (formula.and (v 126) (formula.and (v 127) (formula.and (v 128) (formula.and (v 129) (formula.and (v 130) (formula.and (v 131) (formula.and (v 132) (formula.and (v 133) (formula.and (v 134) (formula.and (v 135) (formula.and (v 136) (formula.and (v 137) (formula.and (v 138) (formula.and (v 139) (formula.and (v 140) (formula.and (v 141) (formula.and (v 142) (formula.and (v 143) (formula.and (v 144) (formula.and (v 145) (formula.and (v 146) (formula.and (v 147) (formula.and (v 148) (formula.and (v 149) (formula.and (v 150) (formula.and (v 151) (formula.and (v 152) (formula.and (v 153) (formula.and (v 154) (formula.and (v 155) (formula.and (v 156) (formula.and (v 157) (formula.and (v 158) (formula.and (v 159) (formula.and (v 160) (formula.and (v 161) (formula.and (v 162) (formula.and (v 163) (formula.and (v 164) (formula.and (v 165) (formula.and (v 166) (formula.and (v 167) (formula.and (v 168) (formula.and (v 169) (formula.and (v 170) (formula.and (v 171) (formula.and (v 172) (formula.and (v 173) (formula.and (v 174) (formula.and (v 175) (formula.and (v 176) (formula.and (v 177) (formula.and (v 178) (formula.and (v 179) (formula.and (v 180) (formula.and (v 181) (formula.and (v 182) (formula.and (v 183) (formula.and (v 184) (formula.and (v 185) (formula.and (v 186) (
end --Needs more than 2000 tokens!

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

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

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

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

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

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

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

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

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

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

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

Setting $b = a$, this becomes:

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

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

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

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

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

  show ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a, from by {
    use (1 : G),
    have h7 : ∀ e : G, (∀ a : G, e * a = a ∧ a * e = a) → e = 1, from by {
      assume (e : G) (hident : ∀ a : G, e * a = a ∧ a * e = a),
      have h8 : ∀ a : G, e = classical.some (h3 a).exists, from assume (a : G),
        exists_unique.unique (h3 a) (hident a).right
        (classical.some_spec (exists_unique.exists (h3 a))),
      have h9 : ∀ a : G, e = classical.some (h4 a).exists, from assume (a : G),
        exists_unique.unique (h4 a) (hident a).left
        (classical.some_spec (exists_unique.exists (h4 a))),
      show e = (1 : G), from eq.trans (h9 e) (h6 _),
    },
    exact ⟨by obviously, h7⟩,
  }
end

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

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

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

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

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

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

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

So $F$ has an infinite model.

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


import data.set.lattice order.order_iso data.quot
#print fintype
universes u v
Π (X Y : C), (f : X ⟶ Z) (g : Y ⟶ Z)
noncomputable theory

axiom choice2_aux {α : Sort u} : { choice : α → α // ∀ (a b : α), choice a = choice b }

def choice2 : Π {α : Sort u}, α → α := λ _, choice2_aux.1

lemma choice2_spec : ∀ {α : Sort u} (a b : α), choice2 a = choice2 b := λ _, choice2_aux.2

axiom univalence : ∀ {α β : Sort u}, α ≃ β → α = β

lemma trunc.out2 {α : Sort u} (a : trunc α) : α := trunc.lift_on a choice2 choice2_spec

variables {α : Type*} {β : Type*}

inductive eq' (a : α) : α → Type
| refl : eq' a
infix ` =' `:50 := eq'

def eq'.symm : ∀ {a b : α}, a =' b → b =' a
| _ _ (eq'.refl _) := (eq'.refl _)

def eq'.trans : ∀ {a b c : α}, a =' b → b =' c → a =' c
| _ _ _ (eq'.refl _) (eq'.refl _) := (eq'.refl _)

def eq'.congr_arg (f : α → β): ∀ {a b : α}, a =' b → f a =' f b
| _ _ (eq'.refl a) := eq'.refl _

def eq'.cast : ∀ {a b : Type}, a =' b → a → b
| _ _ (eq'.refl a) := id

section diaconescu
variable p : Sort u
include p

private def U (x : Sort u) := trunc (psum (trunc x) p)
private def V (x : Sort u) := trunc (psum (x → false) p)

private lemma exU : trunc (Σ' x : Sort u, U p x) :=
  trunc.mk ⟨punit, trunc.mk (psum.inl (trunc.mk punit.star))⟩
private lemma exV : trunc (Σ' x : Sort u, V p x) :=
  trunc.mk ⟨pempty, trunc.mk (psum.inl (λ h, pempty.rec_on _ h))⟩

/- TODO(Leo): check why the code generator is not ignoring (some exU)
   when we mark u as def. -/
private def u : Sort u := psigma.fst (choice2 (trunc.out2 (exU p)))

private def v : Sort u := psigma.fst (choice2 (trunc.out2 (exV p)))

set_option type_context.unfold_lemmas true
private lemma u_def : U p (u p) := psigma.snd (choice2 (trunc.out2 (exU p)))
private lemma v_def : V p (v p) := psigma.snd (choice2 (trunc.out2 (exV p)))

private lemma not_uv_or_p : psum ((u p) ≠ (v p)) p :=
psum.cases_on (trunc.out2 (u_def p))
  (assume hut : trunc (u p),
    psum.cases_on (trunc.out2 (v_def p))
      (assume hvf : v p → false,
        psum.inl (λ h, hvf (eq.rec_on h (trunc.out2 hut))))
      psum.inr)
  psum.inr

private lemma p_implies_uv (hp : p) : u p = v p :=
have hpred : U p = V p, from
  funext (assume x : Sort u,
    univalence
      { to_fun := λ _, trunc.mk (psum.inr hp),
        inv_fun := λ _, trunc.mk (psum.inr hp),
        left_inv := λ x, show trunc.mk _ = _, from subsingleton.elim _ _,
        right_inv := λ x, show trunc.mk _ = _, from subsingleton.elim _ _ }),
show (choice2 (trunc.out2 (exU p))).fst = (choice2 (trunc.out2 (exV p))).fst,
  from @eq.drec_on _ (U p)
    (λ α (h : (U p) = α),
      (choice2 (trunc.out2 (exU p))).fst =
      (@choice2 (Σ' x : Sort u, α x) (trunc.out2
        (eq.rec_on (show V p = α, from hpred.symm.trans h) (exV p)))).fst)
    (V p) hpred (by congr)

#print axioms p_implies_uv

theorem em : psum p (p → false) :=
psum.rec_on (not_uv_or_p p)
  (assume hne : u p ≠ v p, psum.inr (λ hp, hne (p_implies_uv p hp)))
  psum.inl