/-
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, Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.set.finite
import Mathlib.algebra.big_operators.basic
import Mathlib.PostPort

universes u v u_1 x

namespace Mathlib

/-!
# Preimage of a `finset` under an injective map.
-/

namespace finset

/-- Preimage of `s : finset β` under a map `f` injective of `f ⁻¹' s` as a `finset`.  -/
def preimage {α : Type u} {β : Type v} (s : finset β) (f : α → β) (hf : set.inj_on f (f ⁻¹' ↑s)) : finset α :=
  set.finite.to_finset sorry

@[simp] theorem mem_preimage {α : Type u} {β : Type v} {f : α → β} {s : finset β} {hf : set.inj_on f (f ⁻¹' ↑s)} {x : α} : x ∈ preimage s f hf ↔ f x ∈ s :=
  set.finite.mem_to_finset

@[simp] theorem coe_preimage {α : Type u} {β : Type v} {f : α → β} (s : finset β) (hf : set.inj_on f (f ⁻¹' ↑s)) : ↑(preimage s f hf) = f ⁻¹' ↑s :=
  set.finite.coe_to_finset (preimage._proof_1 s f hf)

@[simp] theorem preimage_empty {α : Type u} {β : Type v} {f : α → β} : preimage ∅ f
    (eq.mpr
      (id
        (Eq.trans
          (Eq.trans
            (Eq.trans
              ((fun (f f_1 : α → β) (e_1 : f = f_1) (s s_1 : set α) (e_2 : s = s_1) =>
                  congr (congr_arg set.inj_on e_1) e_2)
                f f (Eq.refl f) (f ⁻¹' ↑∅) ∅
                (Eq.trans
                  ((fun (f f_1 : α → β) (e_1 : f = f_1) (s s_1 : set β) (e_2 : s = s_1) =>
                      congr (congr_arg set.preimage e_1) e_2)
                    f f (Eq.refl f) ↑∅ ∅ coe_empty)
                  set.preimage_empty))
              (set.inj_on.equations._eqn_1 f ∅))
            (forall_congr_eq
              fun (x₁ : α) =>
                Eq.trans
                  (imp_congr_eq (set.mem_empty_eq x₁)
                    (Eq.trans
                      (forall_congr_eq
                        fun (x₂ : α) =>
                          Eq.trans (imp_congr_eq (set.mem_empty_eq x₂) (Eq.refl (f x₁ = f x₂ → x₁ = x₂)))
                            (propext (forall_prop_of_false (iff.mpr not_false_iff True.intro))))
                      (propext forall_true_iff)))
                  (propext (forall_prop_of_false (iff.mpr not_false_iff True.intro)))))
          (propext forall_true_iff)))
      trivial) =
  ∅ := sorry

@[simp] theorem preimage_univ {α : Type u} {β : Type v} {f : α → β} [fintype α] [fintype β] (hf : set.inj_on f (f ⁻¹' ↑univ)) : preimage univ f hf = univ := sorry

@[simp] theorem preimage_inter {α : Type u} {β : Type v} [DecidableEq α] [DecidableEq β] {f : α → β} {s : finset β} {t : finset β} (hs : set.inj_on f (f ⁻¹' ↑s)) (ht : set.inj_on f (f ⁻¹' ↑t)) : (preimage (s ∩ t) f
    fun (x₁ : α) (hx₁ : x₁ ∈ f ⁻¹' ↑(s ∩ t)) (x₂ : α) (hx₂ : x₂ ∈ f ⁻¹' ↑(s ∩ t)) =>
      hs (mem_of_mem_inter_left hx₁) (mem_of_mem_inter_left hx₂)) =
  preimage s f hs ∩ preimage t f ht := sorry

@[simp] theorem preimage_union {α : Type u} {β : Type v} [DecidableEq α] [DecidableEq β] {f : α → β} {s : finset β} {t : finset β} (hst : set.inj_on f (f ⁻¹' ↑(s ∪ t))) : preimage (s ∪ t) f hst =
  (preimage s f
      fun (x₁ : α) (hx₁ : x₁ ∈ f ⁻¹' ↑s) (x₂ : α) (hx₂ : x₂ ∈ f ⁻¹' ↑s) =>
        hst (mem_union_left t hx₁) (mem_union_left t hx₂)) ∪
    preimage t f
      fun (x₁ : α) (hx₁ : x₁ ∈ f ⁻¹' ↑t) (x₂ : α) (hx₂ : x₂ ∈ f ⁻¹' ↑t) =>
        hst (mem_union_right s hx₁) (mem_union_right s hx₂) := sorry

@[simp] theorem preimage_compl {α : Type u} {β : Type v} [DecidableEq α] [DecidableEq β] [fintype α] [fintype β] {f : α → β} (s : finset β) (hf : function.injective f) : preimage (sᶜ) f (function.injective.inj_on hf (f ⁻¹' ↑(sᶜ))) = (preimage s f (function.injective.inj_on hf (f ⁻¹' ↑s))ᶜ) := sorry

theorem monotone_preimage {α : Type u} {β : Type v} {f : α → β} (h : function.injective f) : monotone fun (s : finset β) => preimage s f (function.injective.inj_on h (f ⁻¹' ↑s)) :=
  fun (s t : finset β) (hst : s ≤ t) (x : α)
    (hx : x ∈ (fun (s : finset β) => preimage s f (function.injective.inj_on h (f ⁻¹' ↑s))) s) =>
    iff.mpr mem_preimage (hst (iff.mp mem_preimage hx))

theorem image_subset_iff_subset_preimage {α : Type u} {β : Type v} [DecidableEq β] {f : α → β} {s : finset α} {t : finset β} (hf : set.inj_on f (f ⁻¹' ↑t)) : image f s ⊆ t ↔ s ⊆ preimage t f hf := sorry

theorem map_subset_iff_subset_preimage {α : Type u} {β : Type v} {f : α ↪ β} {s : finset α} {t : finset β} : map f s ⊆ t ↔ s ⊆ preimage t (⇑f) (function.injective.inj_on (function.embedding.injective f) (⇑f ⁻¹' ↑t)) := sorry

theorem image_preimage {α : Type u} {β : Type v} [DecidableEq β] (f : α → β) (s : finset β) [(x : β) → Decidable (x ∈ set.range f)] (hf : set.inj_on f (f ⁻¹' ↑s)) : image f (preimage s f hf) = filter (fun (x : β) => x ∈ set.range f) s := sorry

theorem image_preimage_of_bij {α : Type u} {β : Type v} [DecidableEq β] (f : α → β) (s : finset β) (hf : set.bij_on f (f ⁻¹' ↑s) ↑s) : image f (preimage s f (set.bij_on.inj_on hf)) = s := sorry

theorem sigma_preimage_mk {α : Type u} {β : α → Type u_1} [DecidableEq α] (s : finset (sigma fun (a : α) => β a)) (t : finset α) : (finset.sigma t
    fun (a : α) => preimage s (sigma.mk a) (function.injective.inj_on sigma_mk_injective (sigma.mk a ⁻¹' ↑s))) =
  filter (fun (a : sigma fun (a : α) => β a) => sigma.fst a ∈ t) s := sorry

theorem sigma_preimage_mk_of_subset {α : Type u} {β : α → Type u_1} [DecidableEq α] (s : finset (sigma fun (a : α) => β a)) {t : finset α} (ht : image sigma.fst s ⊆ t) : (finset.sigma t
    fun (a : α) => preimage s (sigma.mk a) (function.injective.inj_on sigma_mk_injective (sigma.mk a ⁻¹' ↑s))) =
  s := sorry

theorem sigma_image_fst_preimage_mk {α : Type u} {β : α → Type u_1} [DecidableEq α] (s : finset (sigma fun (a : α) => β a)) : (finset.sigma (image sigma.fst s)
    fun (a : α) => preimage s (sigma.mk a) (function.injective.inj_on sigma_mk_injective (sigma.mk a ⁻¹' ↑s))) =
  s :=
  sigma_preimage_mk_of_subset s (subset.refl (image sigma.fst s))

theorem prod_preimage' {α : Type u} {β : Type v} {γ : Type x} [comm_monoid β] (f : α → γ) [decidable_pred fun (x : γ) => x ∈ set.range f] (s : finset γ) (hf : set.inj_on f (f ⁻¹' ↑s)) (g : γ → β) : (finset.prod (preimage s f hf) fun (x : α) => g (f x)) =
  finset.prod (filter (fun (x : γ) => x ∈ set.range f) s) fun (x : γ) => g x := sorry

theorem prod_preimage {α : Type u} {β : Type v} {γ : Type x} [comm_monoid β] (f : α → γ) (s : finset γ) (hf : set.inj_on f (f ⁻¹' ↑s)) (g : γ → β) (hg : ∀ (x : γ), x ∈ s → ¬x ∈ set.range f → g x = 1) : (finset.prod (preimage s f hf) fun (x : α) => g (f x)) = finset.prod s fun (x : γ) => g x := sorry

theorem sum_preimage_of_bij {α : Type u} {β : Type v} {γ : Type x} [add_comm_monoid β] (f : α → γ) (s : finset γ) (hf : set.bij_on f (f ⁻¹' ↑s) ↑s) (g : γ → β) : (finset.sum (preimage s f (set.bij_on.inj_on hf)) fun (x : α) => g (f x)) = finset.sum s fun (x : γ) => g x :=
  sum_preimage f s (set.bij_on.inj_on hf) g
    fun (x : γ) (hxs : x ∈ s) (hxf : ¬x ∈ set.range f) => false.elim (hxf (set.bij_on.subset_range hf hxs))


opaque f (a : Nat) (h : a > 0) : Nat

example (h : a = b) : f (a + 1) (by simp_arith) = f (1 + b) (by simp_arith) := by
  conv => lhs; congr; rw [h]
  conv => lhs; congr; rw [Nat.add_comm]

opaque g (p : Prop) [Decidable p] (a : Nat) (h : a > 0) : Nat

example (h : a = b) : g True (a + 1) (by simp_arith) = g (1+1=2) (1 + b) (by simp_arith) := by
  conv =>
    lhs
    congr
    . rfl
    . rw [h]
  conv =>
    lhs
    congr
    . rfl
    . rw [Nat.add_comm]
  conv =>
    rhs
    congr
    . simp
    . rfl


import lang

open typ exp

def evals_to (e v:exp) : Prop := is_many_step e v ∧ is_val v
def normalizes (e:exp) : Prop := ∃ v, evals_to e v

-- Proof of strong normalization using a logical predicate
def SN : typ → exp → Prop
| unitT e := (empty_ctx ⊢ e : unitT) ∧ (normalizes e)
| (arrowT τ1 τ2) e := (empty_ctx ⊢ e : arrowT τ1 τ2) ∧
                      (normalizes e) ∧
                      (∀ (e':exp), (SN τ1 e') → (SN τ2 (ap e e')))

lemma sn_implies_closed :
∀ e τ,
 SN τ e → empty_ctx ⊢ e : τ :=
begin
  intros,
  cases τ; unfold SN at *; tauto
end

lemma sn_implies_normalizes :
∀ e τ, SN τ e → normalizes e :=
begin
 introv Hsn,
 cases τ, exact Hsn.2, exact Hsn.2.1
end

lemma sn_preservation :
  ∀ e e' τ,
  empty_ctx ⊢ e : τ →
  (e ↦str e') →
  (SN τ e' → SN τ e) -- ∧ (SN τ e → SN τ e')
:=
begin
introv Hty Hstep,
{ -- backwards preservation
  intros Hsn,
  generalize h : (empty_ctx = Γ),
  rw h at *,
  -- induction Hty generalizing e'; subst h,
  induction τ generalizing e' e; subst h,
  -- cases Hstep,
  -- induction Hty; subst h,
  {
    unfold SN,
    split, assumption,
    have h := (sn_implies_normalizes _ _ Hsn),
    cases h,
    existsi h_w,
    unfold evals_to at *,
    split,
    { apply is_many_step.many_steps_transitive,
      apply h_h.1, assumption
    },
    apply h_h.2,
  },
  { unfold SN,
    split,
    { assumption },
    split,
    {
      have h := (sn_implies_normalizes _ _ Hsn),
      cases h,
      existsi h_w,
      unfold evals_to at *,
      cases h_h,
      split,
      {
        apply is_many_step.many_steps_transitive,
        { assumption },
        assumption
      },
      assumption
    },
    cases Hstep,
    {
      unfold SN at Hsn,
      intros a Hsna,
      apply τ_ih_τ2,
      { constructor, assumption  },
      { apply Hsn.2.2, assumption },
      constructor,
      { assumption },
      cases τ_τ1; apply Hsna.1,
    },
    {
      intros a Hsna,
      unfold SN at Hsn,
      apply τ_ih_τ2,
      { constructor, assumption },
      { apply Hsn.2.2, assumption },
      constructor,
      { assumption },
      cases τ_τ1; apply Hsna.1,
    }
  },
},
end

-- XXX: this is a tricky lemma because of variable shadowing. If we worked
-- modulo α-equivalence, this trickiness might be avoided.
lemma env_sub_lam_step :
∀ γ c x τ1 e e',
is_env_ctx SN γ c →
SN τ1 e' →
(env_sub γ (lam x τ1 e)).ap e' ↦str (env_sub γ (substitute x e' e)) :=
begin
  introv Hctx Hsn,
  induction γ generalizing e c,
  { unfold env_sub, constructor },
  cases γ_hd with y vy,
  unfold env_sub,
  unfold substitute,
  by_cases (y = x),
  {
    simp *,
    cases c,
    { exfalso, unfold is_env_ctx at *, assumption },
    cases c_hd,
    unfold is_env_ctx at Hctx,
    rw double_substitute,
    { apply γ_ih, apply Hctx.2.1 },
    { apply sn_implies_closed, assumption },
    { apply sn_implies_closed, apply Hctx.2.2 },
  },
  {
    rw if_neg, tactic.swap, tauto,
    cases c,
    { exfalso, unfold is_env_ctx at *, assumption },
    cases c_hd,
    unfold is_env_ctx at Hctx,
    rw substitute_commute,
    {
      apply γ_ih,
      { apply Hctx.2.1 },
    },
    { apply sn_implies_closed, apply Hctx.2.2 },
    { apply sn_implies_closed, assumption },
    { assumption },
  }
end

theorem sn_general :
  ∀ Γ c γ e τ,
  Γ = mk_context c →
  Γ ⊢ e : τ →
  is_env_ctx SN γ c →
  SN τ (env_sub γ e) :=
begin
  introv HΓ Hty Henv,
  induction Hty generalizing γ c; subst HΓ,
  { -- case: unit
    rw env_sub_unit,
    unfold SN,
    split,
    { constructor },
    existsi exp.unit,
    unfold evals_to,
    split; constructor
  },
  { -- case: var
    induction γ generalizing c,
    {
      induction c,
      { exfalso, contradiction },
      { exfalso, unfold is_env_ctx at *, contradiction }
    },
    induction c,
    { exfalso, contradiction },
    cases γ_hd, cases c_hd,
    unfold is_env_ctx at *,
    unfold env_sub,
    cases Henv with Hre Henv,
    subst Hre,
    by_cases (Hty_x = γ_hd_fst),
    { -- the first thing in Γ/γ is the var Hty_x
      subst h,
      unfold env_sub substitute at c_ih,
      unfold substitute at *,
      simp * at *,
      unfold mk_context update_context at Hty_Hvar,
      simp * at Hty_Hvar,
      injection Hty_Hvar,
      subst h_1,
      rw (env_sub_closed _ _ _ _),
      { apply Henv.2 },
      tactic.swap, { apply sn_implies_closed, apply Henv.2 },
    },
    { -- induction
      unfold substitute, rw if_neg,
      tactic.swap, { tauto, },
      unfold mk_context update_context at Hty_Hvar,
      rw if_neg at Hty_Hvar,
      tactic.swap, { tauto },
      apply γ_ih,
      { apply Henv.1, },
      { assumption }
    },
  },
  { -- case: lam. This is the tricky case
    rename [Hty_x → x, Hty_τ1→τ1, Hty_τ2→τ2, Hty_e→e],
    unfold SN,
    split,
    { -- property 1 in notes
      apply substitution_property,
      { assumption },
      { intros, apply sn_implies_closed, assumption },
      { refl },
      constructor, assumption
    },
    split,
    { -- property 2 in notes
      existsi _,
      unfold evals_to,
      split,
      apply is_many_step.many_steps_reflexive,
      apply env_sub_lam_val,
    },
    -- property 3
    intros e' Hsn,
    have h := (sn_implies_normalizes _ _ Hsn),
    cases h with w Heval,
    cases Heval with Hsteps Hval,

    apply (sn_preservation _ _ τ2 _ _),
    tactic.rotate 2,
    {
      constructor,
      { apply substitution_property,
        assumption, apply sn_implies_closed,
        refl, constructor, assumption
      },
      cases τ1; apply Hsn.1, -- this could be a separate lemma
    },
    {
      apply env_sub_lam_step,
      { assumption },
      { assumption }
    },
    -- XXX: here, our proof diverges from the notes because we are doing
    -- call-by-name but the notes are doing call-by-value

    have h: (env_sub ((x,e')::γ) e) = (env_sub γ (substitute x e' e)),
    { unfold env_sub },
    rw <- h,
    apply Hty_ih _ ((x, τ1) :: c),
    { unfold mk_context },
    unfold is_env_ctx,
    split, refl,
    split, assumption,
    assumption,
  },
  { -- case: ap
    specialize Hty_ih_Hfunc _ _ _ Henv, trivial,
    specialize Hty_ih_Hargs _ _ _ Henv, trivial,
    unfold SN at Hty_ih_Hfunc,
    rw env_sub_ap,
    apply Hty_ih_Hfunc.2.2,
    apply Hty_ih_Hargs
  }
end

theorem strong_normalization :
  ∀ e τ, (empty_ctx ⊢ e : τ) → normalizes e :=
begin
  introv Hty,
  have h := (sn_general empty_ctx [] [] e τ _ Hty _),
  { apply sn_implies_normalizes, assumption },
  { unfold mk_context },
  { unfold is_env_ctx },
end


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Markus Himmel
-/
import category_theory.epi_mono
import category_theory.limits.has_limits

/-!
# Equalizers and coequalizers

This file defines (co)equalizers as special cases of (co)limits.

An equalizer is the categorical generalization of the subobject {a ∈ A | f(a) = g(a)} known
from abelian groups or modules. It is a limit cone over the diagram formed by `f` and `g`.

A coequalizer is the dual concept.

## Main definitions

* `walking_parallel_pair` is the indexing category used for (co)equalizer_diagrams
* `parallel_pair` is a functor from `walking_parallel_pair` to our category `C`.
* a `fork` is a cone over a parallel pair.
  * there is really only one interesting morphism in a fork: the arrow from the vertex of the fork
    to the domain of f and g. It is called `fork.ι`.
* an `equalizer` is now just a `limit (parallel_pair f g)`

Each of these has a dual.

## Main statements

* `equalizer.ι_mono` states that every equalizer map is a monomorphism
* `is_iso_limit_cone_parallel_pair_of_self` states that the identity on the domain of `f` is an
  equalizer of `f` and `f`.

## Implementation notes
As with the other special shapes in the limits library, all the definitions here are given as
`abbreviation`s of the general statements for limits, so all the `simp` lemmas and theorems about
general limits can be used.

## References

* [F. Borceux, *Handbook of Categorical Algebra 1*][borceux-vol1]
-/

noncomputable theory

open category_theory opposite

namespace category_theory.limits

local attribute [tidy] tactic.case_bash

universes v u u₂

/-- The type of objects for the diagram indexing a (co)equalizer. -/
@[derive decidable_eq, derive inhabited] inductive walking_parallel_pair : Type v
| zero | one

open walking_parallel_pair

/-- The type family of morphisms for the diagram indexing a (co)equalizer. -/
@[derive decidable_eq] inductive walking_parallel_pair_hom :
  walking_parallel_pair → walking_parallel_pair → Type v
| left : walking_parallel_pair_hom zero one
| right : walking_parallel_pair_hom zero one
| id : Π X : walking_parallel_pair.{v}, walking_parallel_pair_hom X X

/-- Satisfying the inhabited linter -/
instance : inhabited (walking_parallel_pair_hom zero one) :=
{ default := walking_parallel_pair_hom.left }

open walking_parallel_pair_hom

/-- Composition of morphisms in the indexing diagram for (co)equalizers. -/
def walking_parallel_pair_hom.comp :
  Π (X Y Z : walking_parallel_pair)
    (f : walking_parallel_pair_hom X Y) (g : walking_parallel_pair_hom Y Z),
    walking_parallel_pair_hom X Z
  | _ _ _ (id _) h := h
  | _ _ _ left   (id one) := left
  | _ _ _ right  (id one) := right
.

instance walking_parallel_pair_hom_category : small_category walking_parallel_pair :=
{ hom  := walking_parallel_pair_hom,
  id   := walking_parallel_pair_hom.id,
  comp := walking_parallel_pair_hom.comp }

@[simp]
lemma walking_parallel_pair_hom_id (X : walking_parallel_pair) :
  walking_parallel_pair_hom.id X = 𝟙 X :=
rfl

/--
The functor `walking_parallel_pair ⥤ walking_parallel_pairᵒᵖ` sending left to left and right to
right.
-/
def walking_parallel_pair_op : walking_parallel_pair.{u} ⥤ walking_parallel_pair.{u₂}ᵒᵖ :=
{ obj := (λ x, op $ by { cases x, exacts [one, zero] }),
  map := λ i j f, by { cases f; apply quiver.hom.op, exacts [left, right,
    walking_parallel_pair_hom.id _] },
  map_comp' := by { rintros (_|_) (_|_) (_|_) (_|_|_) (_|_|_); refl } }

@[simp] lemma walking_parallel_pair_op_zero :
  walking_parallel_pair_op.obj zero = op one := rfl
@[simp] lemma walking_parallel_pair_op_one :
  walking_parallel_pair_op.obj one = op zero := rfl
@[simp] lemma walking_parallel_pair_op_left :
  walking_parallel_pair_op.map left = @quiver.hom.op _ _ zero one left := rfl
@[simp] lemma walking_parallel_pair_op_right :
  walking_parallel_pair_op.map right = @quiver.hom.op _ _ zero one right := rfl

/--
The equivalence `walking_parallel_pair ⥤ walking_parallel_pairᵒᵖ` sending left to left and right to
right.
-/
@[simps functor inverse]
def walking_parallel_pair_op_equiv : walking_parallel_pair.{u} ≌ walking_parallel_pair.{u₂}ᵒᵖ :=
{ functor := walking_parallel_pair_op,
  inverse := walking_parallel_pair_op.left_op,
  unit_iso := nat_iso.of_components (λ j, eq_to_iso (by { cases j; refl }))
    (by { rintros (_|_) (_|_) (_|_|_); refl }),
  counit_iso := nat_iso.of_components (λ j, eq_to_iso
    (by { induction j using opposite.rec, cases j; refl }))
    (λ i j f, by { induction i using opposite.rec, induction j using opposite.rec,
      let g := f.unop, have : f = g.op := rfl, clear_value g, subst this,
      rcases i with (_|_); rcases j with (_|_); rcases g with (_|_|_); refl }) }

@[simp] lemma walking_parallel_pair_op_equiv_unit_iso_zero :
  walking_parallel_pair_op_equiv.{u u₂}.unit_iso.app zero = iso.refl zero := rfl
@[simp] lemma walking_parallel_pair_op_equiv_unit_iso_one :
  walking_parallel_pair_op_equiv.{u u₂}.unit_iso.app one = iso.refl one := rfl
@[simp] lemma walking_parallel_pair_op_equiv_counit_iso_zero :
  walking_parallel_pair_op_equiv.{u u₂}.counit_iso.app (op zero) = iso.refl (op zero) := rfl
@[simp] lemma walking_parallel_pair_op_equiv_counit_iso_one :
  walking_parallel_pair_op_equiv.{u u₂}.counit_iso.app (op one) = iso.refl (op one) := rfl

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

/-- `parallel_pair f g` is the diagram in `C` consisting of the two morphisms `f` and `g` with
    common domain and codomain. -/
def parallel_pair (f g : X ⟶ Y) : walking_parallel_pair.{v} ⥤ C :=
{ obj := λ x, match x with
  | zero := X
  | one := Y
  end,
  map := λ x y h, match x, y, h with
  | _, _, (id _) := 𝟙 _
  | _, _, left := f
  | _, _, right := g
  end,
  -- `tidy` can cope with this, but it's too slow:
  map_comp' := begin rintros (⟨⟩|⟨⟩) (⟨⟩|⟨⟩) (⟨⟩|⟨⟩) ⟨⟩⟨⟩; { unfold_aux, simp; refl }, end, }.

@[simp] lemma parallel_pair_obj_zero (f g : X ⟶ Y) : (parallel_pair f g).obj zero = X := rfl
@[simp] lemma parallel_pair_obj_one (f g : X ⟶ Y) : (parallel_pair f g).obj one = Y := rfl

@[simp] lemma parallel_pair_map_left (f g : X ⟶ Y) : (parallel_pair f g).map left = f := rfl
@[simp] lemma parallel_pair_map_right (f g : X ⟶ Y) : (parallel_pair f g).map right = g := rfl

@[simp] lemma parallel_pair_functor_obj
  {F : walking_parallel_pair ⥤ C} (j : walking_parallel_pair) :
  (parallel_pair (F.map left) (F.map right)).obj j = F.obj j :=
begin
  cases j; refl
end

/-- Every functor indexing a (co)equalizer is naturally isomorphic (actually, equal) to a
    `parallel_pair` -/
@[simps]
def diagram_iso_parallel_pair (F : walking_parallel_pair ⥤ C) :
  F ≅ parallel_pair (F.map left) (F.map right) :=
nat_iso.of_components (λ j, eq_to_iso $ by cases j; tidy) $ by tidy

/-- Construct a morphism between parallel pairs. -/
def parallel_pair_hom {X' Y' : C} (f g : X ⟶ Y) (f' g' : X' ⟶ Y') (p : X ⟶ X') (q : Y ⟶ Y')
  (wf : f ≫ q = p ≫ f') (wg : g ≫ q = p ≫ g') : parallel_pair f g ⟶ parallel_pair f' g' :=
{ app := λ j, match j with
  | zero := p
  | one := q
  end,
  naturality' := begin
    rintros (⟨⟩|⟨⟩) (⟨⟩|⟨⟩) ⟨⟩; { unfold_aux, simp [wf, wg], },
  end }

@[simp] lemma parallel_pair_hom_app_zero
  {X' Y' : C} (f g : X ⟶ Y) (f' g' : X' ⟶ Y') (p : X ⟶ X') (q : Y ⟶ Y')
  (wf : f ≫ q = p ≫ f') (wg : g ≫ q = p ≫ g') :
  (parallel_pair_hom f g f' g' p q wf wg).app zero = p := rfl

@[simp] lemma parallel_pair_hom_app_one
  {X' Y' : C} (f g : X ⟶ Y) (f' g' : X' ⟶ Y') (p : X ⟶ X') (q : Y ⟶ Y')
  (wf : f ≫ q = p ≫ f') (wg : g ≫ q = p ≫ g') :
  (parallel_pair_hom f g f' g' p q wf wg).app one = q := rfl

/-- A fork on `f` and `g` is just a `cone (parallel_pair f g)`. -/
abbreviation fork (f g : X ⟶ Y) := cone (parallel_pair f g)

/-- A cofork on `f` and `g` is just a `cocone (parallel_pair f g)`. -/
abbreviation cofork (f g : X ⟶ Y) := cocone (parallel_pair f g)

variables {f g : X ⟶ Y}

/-- A fork `t` on the parallel pair `f g : X ⟶ Y` consists of two morphisms `t.π.app zero : t.X ⟶ X`
    and `t.π.app one : t.X ⟶ Y`. Of these, only the first one is interesting, and we give it the
    shorter name `fork.ι t`. -/
abbreviation fork.ι (t : fork f g) := t.π.app zero

/-- A cofork `t` on the parallel_pair `f g : X ⟶ Y` consists of two morphisms
    `t.ι.app zero : X ⟶ t.X` and `t.ι.app one : Y ⟶ t.X`. Of these, only the second one is
    interesting, and we give it the shorter name `cofork.π t`. -/
abbreviation cofork.π (t : cofork f g) := t.ι.app one

@[simp] lemma fork.ι_eq_app_zero (t : fork f g) : t.ι = t.π.app zero := rfl
@[simp] lemma cofork.π_eq_app_one (t : cofork f g) : t.π = t.ι.app one := rfl

@[simp, reassoc] lemma fork.app_zero_left (s : fork f g) :
  s.π.app zero ≫ f = s.π.app one :=
by rw [←s.w left, parallel_pair_map_left]

@[simp, reassoc] lemma fork.app_zero_right (s : fork f g) :
  s.π.app zero ≫ g = s.π.app one :=
by rw [←s.w right, parallel_pair_map_right]

@[simp, reassoc] lemma cofork.left_app_one (s : cofork f g) :
  f ≫ s.ι.app one = s.ι.app zero :=
by rw [←s.w left, parallel_pair_map_left]

@[simp, reassoc] lemma cofork.right_app_one (s : cofork f g) :
  g ≫ s.ι.app one = s.ι.app zero :=
by rw [←s.w right, parallel_pair_map_right]

/-- A fork on `f g : X ⟶ Y` is determined by the morphism `ι : P ⟶ X` satisfying `ι ≫ f = ι ≫ g`.
-/
@[simps]
def fork.of_ι {P : C} (ι : P ⟶ X) (w : ι ≫ f = ι ≫ g) : fork f g :=
{ X := P,
  π :=
  { app := λ X, begin cases X, exact ι, exact ι ≫ f, end,
    naturality' := λ X Y f,
    begin
      cases X; cases Y; cases f; dsimp; simp,
      { dsimp, simp, }, -- See note [dsimp, simp].
      { exact w },
      { dsimp, simp, },
    end } }

/-- A cofork on `f g : X ⟶ Y` is determined by the morphism `π : Y ⟶ P` satisfying
    `f ≫ π = g ≫ π`. -/
@[simps]
def cofork.of_π {P : C} (π : Y ⟶ P) (w : f ≫ π = g ≫ π) : cofork f g :=
{ X := P,
  ι :=
  { app := λ X, walking_parallel_pair.cases_on X (f ≫ π) π,
    naturality' := λ i j f, by { cases f; dsimp; simp [w] } } } -- See note [dsimp, simp]

lemma fork.ι_of_ι {P : C} (ι : P ⟶ X) (w : ι ≫ f = ι ≫ g) :
  (fork.of_ι ι w).ι = ι := rfl
lemma cofork.π_of_π {P : C} (π : Y ⟶ P) (w : f ≫ π = g ≫ π) :
  (cofork.of_π π w).π = π := rfl

@[reassoc]
lemma fork.condition (t : fork f g) : t.ι ≫ f = t.ι ≫ g :=
by rw [t.app_zero_left, t.app_zero_right]
@[reassoc]
lemma cofork.condition (t : cofork f g) : f ≫ t.π = g ≫ t.π :=
by rw [t.left_app_one, t.right_app_one]

/-- To check whether two maps are equalized by both maps of a fork, it suffices to check it for the
    first map -/
lemma fork.equalizer_ext (s : fork f g) {W : C} {k l : W ⟶ s.X}
  (h : k ≫ fork.ι s = l ≫ fork.ι s) : ∀ (j : walking_parallel_pair),
    k ≫ s.π.app j = l ≫ s.π.app j
| zero := h
| one := by rw [←fork.app_zero_left, reassoc_of h]

/-- To check whether two maps are coequalized by both maps of a cofork, it suffices to check it for
    the second map -/

lemma fork.is_limit.hom_ext {s : fork f g} (hs : is_limit s) {W : C} {k l : W ⟶ s.X}
  (h : k ≫ fork.ι s = l ≫ fork.ι s) : k = l :=
hs.hom_ext $ fork.equalizer_ext _ h

lemma cofork.is_colimit.hom_ext {s : cofork f g} (hs : is_colimit s) {W : C} {k l : s.X ⟶ W}
  (h : cofork.π s ≫ k = cofork.π s ≫ l) : k = l :=
hs.hom_ext $ cofork.coequalizer_ext _ h

/-- If `s` is a limit fork over `f` and `g`, then a morphism `k : W ⟶ X` satisfying
    `k ≫ f = k ≫ g` induces a morphism `l : W ⟶ s.X` such that `l ≫ fork.ι s = k`. -/
def fork.is_limit.lift' {s : fork f g} (hs : is_limit s) {W : C} (k : W ⟶ X) (h : k ≫ f = k ≫ g) :
  {l : W ⟶ s.X // l ≫ fork.ι s = k} :=
⟨hs.lift $ fork.of_ι _ h, hs.fac _ _⟩

/-- If `s` is a colimit cofork over `f` and `g`, then a morphism `k : Y ⟶ W` satisfying
    `f ≫ k = g ≫ k` induces a morphism `l : s.X ⟶ W` such that `cofork.π s ≫ l = k`. -/
def cofork.is_colimit.desc' {s : cofork f g} (hs : is_colimit s) {W : C} (k : Y ⟶ W)
  (h : f ≫ k = g ≫ k) : {l : s.X ⟶ W // cofork.π s ≫ l = k} :=
⟨hs.desc $ cofork.of_π _ h, hs.fac _ _⟩

/-- This is a slightly more convenient method to verify that a fork is a limit cone. It
    only asks for a proof of facts that carry any mathematical content -/
def fork.is_limit.mk (t : fork f g)
  (lift : Π (s : fork f g), s.X ⟶ t.X)
  (fac : ∀ (s : fork f g), lift s ≫ fork.ι t = fork.ι s)
  (uniq : ∀ (s : fork f g) (m : s.X ⟶ t.X)
    (w : ∀ j : walking_parallel_pair, m ≫ t.π.app j = s.π.app j), m = lift s) :
  is_limit t :=
{ lift := lift,
  fac' := λ s j, walking_parallel_pair.cases_on j (fac s) $
    by erw [←s.w left, ←t.w left, ←category.assoc, fac]; refl,
  uniq' := uniq }

/-- This is another convenient method to verify that a fork is a limit cone. It
    only asks for a proof of facts that carry any mathematical content, and allows access to the
    same `s` for all parts. -/
def fork.is_limit.mk' {X Y : C} {f g : X ⟶ Y} (t : fork f g)
  (create : Π (s : fork f g), {l // l ≫ t.ι = s.ι ∧ ∀ {m}, m ≫ t.ι = s.ι → m = l}) :
is_limit t :=
fork.is_limit.mk t
  (λ s, (create s).1)
  (λ s, (create s).2.1)
  (λ s m w, (create s).2.2 (w zero))

/-- This is a slightly more convenient method to verify that a cofork is a colimit cocone. It
    only asks for a proof of facts that carry any mathematical content -/
def cofork.is_colimit.mk (t : cofork f g)
  (desc : Π (s : cofork f g), t.X ⟶ s.X)
  (fac : ∀ (s : cofork f g), cofork.π t ≫ desc s = cofork.π s)
  (uniq : ∀ (s : cofork f g) (m : t.X ⟶ s.X)
    (w : ∀ j : walking_parallel_pair, t.ι.app j ≫ m = s.ι.app j), m = desc s) :
  is_colimit t :=
{ desc := desc,
  fac' := λ s j, walking_parallel_pair.cases_on j
    (by erw [←s.w left, ←t.w left, category.assoc, fac]; refl) (fac s),
  uniq' := uniq }

/-- This is another convenient method to verify that a fork is a limit cone. It
    only asks for a proof of facts that carry any mathematical content, and allows access to the
    same `s` for all parts. -/
def cofork.is_colimit.mk' {X Y : C} {f g : X ⟶ Y} (t : cofork f g)
  (create : Π (s : cofork f g), {l : t.X ⟶ s.X // t.π ≫ l = s.π ∧ ∀ {m}, t.π ≫ m = s.π → m = l}) :
is_colimit t :=
cofork.is_colimit.mk t
  (λ s, (create s).1)
  (λ s, (create s).2.1)
  (λ s m w, (create s).2.2 (w one))

/--
Given a limit cone for the pair `f g : X ⟶ Y`, for any `Z`, morphisms from `Z` to its point are in
bijection with morphisms `h : Z ⟶ X` such that `h ≫ f = h ≫ g`.
Further, this bijection is natural in `Z`: see `fork.is_limit.hom_iso_natural`.
This is a special case of `is_limit.hom_iso'`, often useful to construct adjunctions.
-/
@[simps]
def fork.is_limit.hom_iso {X Y : C} {f g : X ⟶ Y} {t : fork f g} (ht : is_limit t) (Z : C) :
  (Z ⟶ t.X) ≃ {h : Z ⟶ X // h ≫ f = h ≫ g} :=
{ to_fun := λ k, ⟨k ≫ t.ι, by simp⟩,
  inv_fun := λ h, (fork.is_limit.lift' ht _ h.prop).1,
  left_inv := λ k, fork.is_limit.hom_ext ht (fork.is_limit.lift' _ _ _).prop,
  right_inv := λ h, subtype.ext (fork.is_limit.lift' ht _ _).prop }

/-- The bijection of `fork.is_limit.hom_iso` is natural in `Z`. -/
lemma fork.is_limit.hom_iso_natural {X Y : C} {f g : X ⟶ Y} {t : fork f g} (ht : is_limit t)
  {Z Z' : C} (q : Z' ⟶ Z) (k : Z ⟶ t.X) :
  (fork.is_limit.hom_iso ht _ (q ≫ k) : Z' ⟶ X) = q ≫ (fork.is_limit.hom_iso ht _ k : Z ⟶ X) :=
category.assoc _ _ _

/--
Given a colimit cocone for the pair `f g : X ⟶ Y`, for any `Z`, morphisms from the cocone point
to `Z` are in bijection with morphisms `h : Y ⟶ Z` such that `f ≫ h = g ≫ h`.
Further, this bijection is natural in `Z`: see `cofork.is_colimit.hom_iso_natural`.
This is a special case of `is_colimit.hom_iso'`, often useful to construct adjunctions.
-/
@[simps]
def cofork.is_colimit.hom_iso {X Y : C} {f g : X ⟶ Y} {t : cofork f g} (ht : is_colimit t) (Z : C) :
  (t.X ⟶ Z) ≃ {h : Y ⟶ Z // f ≫ h = g ≫ h} :=
{ to_fun := λ k, ⟨t.π ≫ k, by simp⟩,
  inv_fun := λ h, (cofork.is_colimit.desc' ht _ h.prop).1,
  left_inv := λ k, cofork.is_colimit.hom_ext ht (cofork.is_colimit.desc' _ _ _).prop,
  right_inv := λ h, subtype.ext (cofork.is_colimit.desc' ht _ _).prop }

/-- The bijection of `cofork.is_colimit.hom_iso` is natural in `Z`. -/
lemma cofork.is_colimit.hom_iso_natural {X Y : C} {f g : X ⟶ Y} {t : cofork f g} {Z Z' : C}
  (q : Z ⟶ Z') (ht : is_colimit t) (k : t.X ⟶ Z) :
    (cofork.is_colimit.hom_iso ht _ (k ≫ q) : Y ⟶ Z') =
    (cofork.is_colimit.hom_iso ht _ k : Y ⟶ Z) ≫ q :=
(category.assoc _ _ _).symm

/-- This is a helper construction that can be useful when verifying that a category has all
    equalizers. Given `F : walking_parallel_pair ⥤ C`, which is really the same as
    `parallel_pair (F.map left) (F.map right)`, and a fork on `F.map left` and `F.map right`,
    we get a cone on `F`.

    If you're thinking about using this, have a look at `has_equalizers_of_has_limit_parallel_pair`,
    which you may find to be an easier way of achieving your goal. -/
def cone.of_fork
  {F : walking_parallel_pair ⥤ C} (t : fork (F.map left) (F.map right)) : cone F :=
{ X := t.X,
  π :=
  { app := λ X, t.π.app X ≫ eq_to_hom (by tidy),
    naturality' := λ j j' g, by { cases j; cases j'; cases g; dsimp; simp } } }

/-- This is a helper construction that can be useful when verifying that a category has all
    coequalizers. Given `F : walking_parallel_pair ⥤ C`, which is really the same as
    `parallel_pair (F.map left) (F.map right)`, and a cofork on `F.map left` and `F.map right`,
    we get a cocone on `F`.

    If you're thinking about using this, have a look at
    `has_coequalizers_of_has_colimit_parallel_pair`, which you may find to be an easier way of
    achieving your goal. -/
def cocone.of_cofork
  {F : walking_parallel_pair ⥤ C} (t : cofork (F.map left) (F.map right)) : cocone F :=
{ X := t.X,
  ι :=
  { app := λ X, eq_to_hom (by tidy) ≫ t.ι.app X,
    naturality' := λ j j' g, by { cases j; cases j'; cases g; dsimp; simp } } }

@[simp] lemma cone.of_fork_π
  {F : walking_parallel_pair ⥤ C} (t : fork (F.map left) (F.map right)) (j) :
  (cone.of_fork t).π.app j = t.π.app j ≫ eq_to_hom (by tidy) := rfl

@[simp] lemma cocone.of_cofork_ι
  {F : walking_parallel_pair ⥤ C} (t : cofork (F.map left) (F.map right)) (j) :
  (cocone.of_cofork t).ι.app j = eq_to_hom (by tidy) ≫ t.ι.app j := rfl

/-- Given `F : walking_parallel_pair ⥤ C`, which is really the same as
    `parallel_pair (F.map left) (F.map right)` and a cone on `F`, we get a fork on
    `F.map left` and `F.map right`. -/
def fork.of_cone
  {F : walking_parallel_pair ⥤ C} (t : cone F) : fork (F.map left) (F.map right) :=
{ X := t.X,
  π := { app := λ X, t.π.app X ≫ eq_to_hom (by tidy) } }

/-- Given `F : walking_parallel_pair ⥤ C`, which is really the same as
    `parallel_pair (F.map left) (F.map right)` and a cocone on `F`, we get a cofork on
    `F.map left` and `F.map right`. -/
def cofork.of_cocone
  {F : walking_parallel_pair ⥤ C} (t : cocone F) : cofork (F.map left) (F.map right) :=
{ X := t.X,
  ι := { app := λ X, eq_to_hom (by tidy) ≫ t.ι.app X } }

@[simp] lemma fork.of_cone_π {F : walking_parallel_pair ⥤ C} (t : cone F) (j) :
  (fork.of_cone t).π.app j = t.π.app j ≫ eq_to_hom (by tidy) := rfl
@[simp] lemma cofork.of_cocone_ι {F : walking_parallel_pair ⥤ C} (t : cocone F) (j) :
  (cofork.of_cocone t).ι.app j = eq_to_hom (by tidy) ≫ t.ι.app j := rfl

/--
Helper function for constructing morphisms between equalizer forks.
-/
@[simps]
def fork.mk_hom {s t : fork f g} (k : s.X ⟶ t.X) (w : k ≫ t.ι = s.ι) : s ⟶ t :=
{ hom := k,
  w' :=
  begin
    rintro ⟨_|_⟩,
    { exact w },
    { simpa using w =≫ f },
  end }

/--
To construct an isomorphism between forks,
it suffices to give an isomorphism between the cone points
and check that it commutes with the `ι` morphisms.
-/
@[simps]
def fork.ext {s t : fork f g} (i : s.X ≅ t.X) (w : i.hom ≫ t.ι = s.ι) : s ≅ t :=
{ hom := fork.mk_hom i.hom w,
  inv := fork.mk_hom i.inv (by rw [← w, iso.inv_hom_id_assoc]) }

/--
Helper function for constructing morphisms between coequalizer coforks.
-/
@[simps]
def cofork.mk_hom {s t : cofork f g} (k : s.X ⟶ t.X) (w : s.π ≫ k = t.π) : s ⟶ t :=
{ hom := k,
  w' :=
  begin
    rintro ⟨_|_⟩,
    simpa using f ≫= w,
    exact w,
  end }

/--
To construct an isomorphism between coforks,
it suffices to give an isomorphism between the cocone points
and check that it commutes with the `π` morphisms.
-/
@[simps]
def cofork.ext {s t : cofork f g} (i : s.X ≅ t.X) (w : s.π ≫ i.hom = t.π) : s ≅ t :=
{ hom := cofork.mk_hom i.hom w,
  inv := cofork.mk_hom i.inv (by rw [iso.comp_inv_eq, w]) }

variables (f g)

section
/--
`has_equalizer f g` represents a particular choice of limiting cone
for the parallel pair of morphisms `f` and `g`.
-/
abbreviation has_equalizer := has_limit (parallel_pair f g)

variables [has_equalizer f g]

/-- If an equalizer of `f` and `g` exists, we can access an arbitrary choice of such by
    saying `equalizer f g`. -/
abbreviation equalizer : C := limit (parallel_pair f g)

/-- If an equalizer of `f` and `g` exists, we can access the inclusion
    `equalizer f g ⟶ X` by saying `equalizer.ι f g`. -/
abbreviation equalizer.ι : equalizer f g ⟶ X :=
limit.π (parallel_pair f g) zero

/--
An equalizer cone for a parallel pair `f` and `g`.
-/
abbreviation equalizer.fork : fork f g := limit.cone (parallel_pair f g)

@[simp] lemma equalizer.fork_ι :
  (equalizer.fork f g).ι = equalizer.ι f g := rfl

@[simp] lemma equalizer.fork_π_app_zero :
  (equalizer.fork f g).π.app zero = equalizer.ι f g := rfl

@[reassoc] lemma equalizer.condition : equalizer.ι f g ≫ f = equalizer.ι f g ≫ g :=
fork.condition $ limit.cone $ parallel_pair f g

/-- The equalizer built from `equalizer.ι f g` is limiting. -/
def equalizer_is_equalizer : is_limit (fork.of_ι (equalizer.ι f g) (equalizer.condition f g)) :=
is_limit.of_iso_limit (limit.is_limit _) (fork.ext (iso.refl _) (by tidy))

variables {f g}

/-- A morphism `k : W ⟶ X` satisfying `k ≫ f = k ≫ g` factors through the equalizer of `f` and `g`
    via `equalizer.lift : W ⟶ equalizer f g`. -/
abbreviation equalizer.lift {W : C} (k : W ⟶ X) (h : k ≫ f = k ≫ g) : W ⟶ equalizer f g :=
limit.lift (parallel_pair f g) (fork.of_ι k h)

@[simp, reassoc]
lemma equalizer.lift_ι {W : C} (k : W ⟶ X) (h : k ≫ f = k ≫ g) :
  equalizer.lift k h ≫ equalizer.ι f g = k :=
limit.lift_π _ _

/-- A morphism `k : W ⟶ X` satisfying `k ≫ f = k ≫ g` induces a morphism `l : W ⟶ equalizer f g`
    satisfying `l ≫ equalizer.ι f g = k`. -/
def equalizer.lift' {W : C} (k : W ⟶ X) (h : k ≫ f = k ≫ g) :
  {l : W ⟶ equalizer f g // l ≫ equalizer.ι f g = k} :=
⟨equalizer.lift k h, equalizer.lift_ι _ _⟩

/-- Two maps into an equalizer are equal if they are are equal when composed with the equalizer
    map. -/
@[ext] lemma equalizer.hom_ext {W : C} {k l : W ⟶ equalizer f g}
  (h : k ≫ equalizer.ι f g = l ≫ equalizer.ι f g) : k = l :=
fork.is_limit.hom_ext (limit.is_limit _) h

/-- An equalizer morphism is a monomorphism -/
instance equalizer.ι_mono : mono (equalizer.ι f g) :=
{ right_cancellation := λ Z h k w, equalizer.hom_ext w }

end

section
variables {f g}
/-- The equalizer morphism in any limit cone is a monomorphism. -/
lemma mono_of_is_limit_parallel_pair {c : cone (parallel_pair f g)} (i : is_limit c) :
  mono (fork.ι c) :=
{ right_cancellation := λ Z h k w, fork.is_limit.hom_ext i w }

end

section
variables {f g}

/-- The identity determines a cone on the equalizer diagram of `f` and `g` if `f = g`. -/
def id_fork (h : f = g) : fork f g :=
fork.of_ι (𝟙 X) $ h ▸ rfl

/-- The identity on `X` is an equalizer of `(f, g)`, if `f = g`. -/
def is_limit_id_fork (h : f = g) : is_limit (id_fork h) :=
fork.is_limit.mk _
  (λ s, fork.ι s)
  (λ s, category.comp_id _)
  (λ s m h, by { convert h zero, exact (category.comp_id _).symm })

/-- Every equalizer of `(f, g)`, where `f = g`, is an isomorphism. -/
lemma is_iso_limit_cone_parallel_pair_of_eq (h₀ : f = g) {c : cone (parallel_pair f g)}
  (h : is_limit c) : is_iso (c.π.app zero) :=
is_iso.of_iso $ is_limit.cone_point_unique_up_to_iso h $ is_limit_id_fork h₀

/-- The equalizer of `(f, g)`, where `f = g`, is an isomorphism. -/
lemma equalizer.ι_of_eq [has_equalizer f g] (h : f = g) : is_iso (equalizer.ι f g) :=
is_iso_limit_cone_parallel_pair_of_eq h $ limit.is_limit _

/-- Every equalizer of `(f, f)` is an isomorphism. -/
lemma is_iso_limit_cone_parallel_pair_of_self {c : cone (parallel_pair f f)} (h : is_limit c) :
  is_iso (c.π.app zero) :=
is_iso_limit_cone_parallel_pair_of_eq rfl h

/-- An equalizer that is an epimorphism is an isomorphism. -/
lemma is_iso_limit_cone_parallel_pair_of_epi {c : cone (parallel_pair f g)}
  (h : is_limit c) [epi (c.π.app zero)] : is_iso (c.π.app zero) :=
is_iso_limit_cone_parallel_pair_of_eq ((cancel_epi _).1 (fork.condition c)) h

end

instance has_equalizer_of_self : has_equalizer f f :=
has_limit.mk
{ cone := id_fork rfl,
  is_limit := is_limit_id_fork rfl }

/-- The equalizer inclusion for `(f, f)` is an isomorphism. -/
instance equalizer.ι_of_self : is_iso (equalizer.ι f f) :=
equalizer.ι_of_eq rfl

/-- The equalizer of a morphism with itself is isomorphic to the source. -/
def equalizer.iso_source_of_self : equalizer f f ≅ X :=
as_iso (equalizer.ι f f)

@[simp] lemma equalizer.iso_source_of_self_hom :
  (equalizer.iso_source_of_self f).hom = equalizer.ι f f :=
rfl

@[simp] lemma equalizer.iso_source_of_self_inv :
  (equalizer.iso_source_of_self f).inv = equalizer.lift (𝟙 X) (by simp) :=
by { ext, simp [equalizer.iso_source_of_self], }

section
/--
`has_coequalizer f g` represents a particular choice of colimiting cocone
for the parallel pair of morphisms `f` and `g`.
-/
abbreviation has_coequalizer := has_colimit (parallel_pair f g)

variables [has_coequalizer f g]

/-- If a coequalizer of `f` and `g` exists, we can access an arbitrary choice of such by
    saying `coequalizer f g`. -/
abbreviation coequalizer : C := colimit (parallel_pair f g)

/--  If a coequalizer of `f` and `g` exists, we can access the corresponding projection by
    saying `coequalizer.π f g`. -/
abbreviation coequalizer.π : Y ⟶ coequalizer f g :=
colimit.ι (parallel_pair f g) one

/--
An arbitrary choice of coequalizer cocone for a parallel pair `f` and `g`.
-/
abbreviation coequalizer.cofork : cofork f g := colimit.cocone (parallel_pair f g)

@[simp] lemma coequalizer.cofork_π :
  (coequalizer.cofork f g).π = coequalizer.π f g := rfl

@[simp] lemma coequalizer.cofork_ι_app_one :
  (coequalizer.cofork f g).ι.app one = coequalizer.π f g := rfl

@[reassoc] lemma coequalizer.condition : f ≫ coequalizer.π f g = g ≫ coequalizer.π f g :=
cofork.condition $ colimit.cocone $ parallel_pair f g

/-- The cofork built from `coequalizer.π f g` is colimiting. -/
def coequalizer_is_coequalizer :
  is_colimit (cofork.of_π (coequalizer.π f g) (coequalizer.condition f g)) :=
is_colimit.of_iso_colimit (colimit.is_colimit _) (cofork.ext (iso.refl _) (by tidy))

variables {f g}

/-- Any morphism `k : Y ⟶ W` satisfying `f ≫ k = g ≫ k` factors through the coequalizer of `f`
    and `g` via `coequalizer.desc : coequalizer f g ⟶ W`. -/
abbreviation coequalizer.desc {W : C} (k : Y ⟶ W) (h : f ≫ k = g ≫ k) : coequalizer f g ⟶ W :=
colimit.desc (parallel_pair f g) (cofork.of_π k h)

@[simp, reassoc]
lemma coequalizer.π_desc {W : C} (k : Y ⟶ W) (h : f ≫ k = g ≫ k) :
  coequalizer.π f g ≫ coequalizer.desc k h = k :=
colimit.ι_desc _ _

/-- Any morphism `k : Y ⟶ W` satisfying `f ≫ k = g ≫ k` induces a morphism
    `l : coequalizer f g ⟶ W` satisfying `coequalizer.π ≫ g = l`. -/
def coequalizer.desc' {W : C} (k : Y ⟶ W) (h : f ≫ k = g ≫ k) :
  {l : coequalizer f g ⟶ W // coequalizer.π f g ≫ l = k} :=
⟨coequalizer.desc k h, coequalizer.π_desc _ _⟩

/-- Two maps from a coequalizer are equal if they are equal when composed with the coequalizer
    map -/
@[ext] lemma coequalizer.hom_ext {W : C} {k l : coequalizer f g ⟶ W}
  (h : coequalizer.π f g ≫ k = coequalizer.π f g ≫ l) : k = l :=
cofork.is_colimit.hom_ext (colimit.is_colimit _) h

/-- A coequalizer morphism is an epimorphism -/
instance coequalizer.π_epi : epi (coequalizer.π f g) :=
{ left_cancellation := λ Z h k w, coequalizer.hom_ext w }

end

section
variables {f g}

/-- The coequalizer morphism in any colimit cocone is an epimorphism. -/
lemma epi_of_is_colimit_parallel_pair {c : cocone (parallel_pair f g)} (i : is_colimit c) :
  epi (c.ι.app one) :=
{ left_cancellation := λ Z h k w, cofork.is_colimit.hom_ext i w }

end

section
variables {f g}

/-- The identity determines a cocone on the coequalizer diagram of `f` and `g`, if `f = g`. -/
def id_cofork (h : f = g) : cofork f g :=
cofork.of_π (𝟙 Y) $ h ▸ rfl

/-- The identity on `Y` is a coequalizer of `(f, g)`, where `f = g`.  -/
def is_colimit_id_cofork (h : f = g) : is_colimit (id_cofork h) :=
cofork.is_colimit.mk _
  (λ s, cofork.π s)
  (λ s, category.id_comp _)
  (λ s m h, by { convert h one, exact (category.id_comp _).symm })

/-- Every coequalizer of `(f, g)`, where `f = g`, is an isomorphism. -/
lemma is_iso_colimit_cocone_parallel_pair_of_eq (h₀ : f = g) {c : cocone (parallel_pair f g)}
  (h : is_colimit c) : is_iso (c.ι.app one) :=
is_iso.of_iso $ is_colimit.cocone_point_unique_up_to_iso (is_colimit_id_cofork h₀) h

/-- The coequalizer of `(f, g)`, where `f = g`, is an isomorphism. -/
lemma coequalizer.π_of_eq [has_coequalizer f g] (h : f = g) :
  is_iso (coequalizer.π f g) :=
is_iso_colimit_cocone_parallel_pair_of_eq h $ colimit.is_colimit _

/-- Every coequalizer of `(f, f)` is an isomorphism. -/
lemma is_iso_colimit_cocone_parallel_pair_of_self {c : cocone (parallel_pair f f)}
  (h : is_colimit c) : is_iso (c.ι.app one) :=
is_iso_colimit_cocone_parallel_pair_of_eq rfl h

/-- A coequalizer that is a monomorphism is an isomorphism. -/
lemma is_iso_limit_cocone_parallel_pair_of_epi {c : cocone (parallel_pair f g)}
  (h : is_colimit c) [mono (c.ι.app one)] : is_iso (c.ι.app one) :=
is_iso_colimit_cocone_parallel_pair_of_eq ((cancel_mono _).1 (cofork.condition c)) h

end

instance has_coequalizer_of_self : has_coequalizer f f :=
has_colimit.mk
{ cocone := id_cofork rfl,
  is_colimit := is_colimit_id_cofork rfl }

/-- The coequalizer projection for `(f, f)` is an isomorphism. -/
instance coequalizer.π_of_self : is_iso (coequalizer.π f f) :=
coequalizer.π_of_eq rfl

/-- The coequalizer of a morphism with itself is isomorphic to the target. -/
def coequalizer.iso_target_of_self : coequalizer f f ≅ Y :=
(as_iso (coequalizer.π f f)).symm

@[simp] lemma coequalizer.iso_target_of_self_hom :
  (coequalizer.iso_target_of_self f).hom = coequalizer.desc (𝟙 Y) (by simp) :=
by { ext, simp [coequalizer.iso_target_of_self], }

@[simp] lemma coequalizer.iso_target_of_self_inv :
  (coequalizer.iso_target_of_self f).inv = coequalizer.π f f :=
rfl

section comparison

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

/--
The comparison morphism for the equalizer of `f,g`.
This is an isomorphism iff `G` preserves the equalizer of `f,g`; see
`category_theory/limits/preserves/shapes/equalizers.lean`
-/
def equalizer_comparison [has_equalizer f g] [has_equalizer (G.map f) (G.map g)] :
  G.obj (equalizer f g) ⟶ equalizer (G.map f) (G.map g) :=
equalizer.lift (G.map (equalizer.ι _ _)) (by simp only [←G.map_comp, equalizer.condition])

@[simp, reassoc]
lemma equalizer_comparison_comp_π [has_equalizer f g] [has_equalizer (G.map f) (G.map g)] :
  equalizer_comparison f g G ≫ equalizer.ι (G.map f) (G.map g) = G.map (equalizer.ι f g) :=
equalizer.lift_ι _ _

@[simp, reassoc]
lemma map_lift_equalizer_comparison [has_equalizer f g] [has_equalizer (G.map f) (G.map g)]
  {Z : C} {h : Z ⟶ X} (w : h ≫ f = h ≫ g) :
    G.map (equalizer.lift h w) ≫ equalizer_comparison f g G =
      equalizer.lift (G.map h) (by simp only [←G.map_comp, w]) :=
by { ext, simp [← G.map_comp] }

/-- The comparison morphism for the coequalizer of `f,g`. -/
def coequalizer_comparison [has_coequalizer f g] [has_coequalizer (G.map f) (G.map g)] :
  coequalizer (G.map f) (G.map g) ⟶ G.obj (coequalizer f g) :=
coequalizer.desc (G.map (coequalizer.π _ _)) (by simp only [←G.map_comp, coequalizer.condition])

@[simp, reassoc]
lemma ι_comp_coequalizer_comparison [has_coequalizer f g] [has_coequalizer (G.map f) (G.map g)] :
  coequalizer.π _ _ ≫ coequalizer_comparison f g G = G.map (coequalizer.π _ _) :=
coequalizer.π_desc _ _

@[simp, reassoc]
lemma coequalizer_comparison_map_desc [has_coequalizer f g] [has_coequalizer (G.map f) (G.map g)]
  {Z : C} {h : Y ⟶ Z} (w : f ≫ h = g ≫ h) :
  coequalizer_comparison f g G ≫ G.map (coequalizer.desc h w) =
    coequalizer.desc (G.map h) (by simp only [←G.map_comp, w]) :=
by { ext, simp [← G.map_comp] }

end comparison

variables (C)

/-- `has_equalizers` represents a choice of equalizer for every pair of morphisms -/
abbreviation has_equalizers := has_limits_of_shape walking_parallel_pair.{v} C

/-- `has_coequalizers` represents a choice of coequalizer for every pair of morphisms -/
abbreviation has_coequalizers := has_colimits_of_shape walking_parallel_pair.{v} C

/-- If `C` has all limits of diagrams `parallel_pair f g`, then it has all equalizers -/
lemma has_equalizers_of_has_limit_parallel_pair
  [Π {X Y : C} {f g : X ⟶ Y}, has_limit (parallel_pair f g)] : has_equalizers C :=
{ has_limit := λ F, has_limit_of_iso (diagram_iso_parallel_pair F).symm }

/-- If `C` has all colimits of diagrams `parallel_pair f g`, then it has all coequalizers -/
lemma has_coequalizers_of_has_colimit_parallel_pair
  [Π {X Y : C} {f g : X ⟶ Y}, has_colimit (parallel_pair f g)] : has_coequalizers C :=
{ has_colimit := λ F, has_colimit_of_iso (diagram_iso_parallel_pair F) }

section
-- In this section we show that a split mono `f` equalizes `(retraction f ≫ f)` and `(𝟙 Y)`.
variables {C} [split_mono f]

/--
A split mono `f` equalizes `(retraction f ≫ f)` and `(𝟙 Y)`.
Here we build the cone, and show in `split_mono_equalizes` that it is a limit cone.
-/
@[simps {rhs_md := semireducible}]
def cone_of_split_mono : cone (parallel_pair (𝟙 Y) (retraction f ≫ f)) :=
fork.of_ι f (by simp)

/--
A split mono `f` equalizes `(retraction f ≫ f)` and `(𝟙 Y)`.
-/
def split_mono_equalizes {X Y : C} (f : X ⟶ Y) [split_mono f] : is_limit (cone_of_split_mono f) :=
fork.is_limit.mk' _ $ λ s,
⟨s.ι ≫ retraction f,
 by { dsimp, rw [category.assoc, ←s.condition], apply category.comp_id },
 λ m hm, by simp [←hm]⟩

end

section
-- In this section we show that a split epi `f` coequalizes `(f ≫ section_ f)` and `(𝟙 X)`.
variables {C} [split_epi f]

/--
A split epi `f` coequalizes `(f ≫ section_ f)` and `(𝟙 X)`.
Here we build the cocone, and show in `split_epi_coequalizes` that it is a colimit cocone.
-/
@[simps {rhs_md := semireducible}]
def cocone_of_split_epi : cocone (parallel_pair (𝟙 X) (f ≫ section_ f)) :=
cofork.of_π f (by simp)

/--
A split epi `f` coequalizes `(f ≫ section_ f)` and `(𝟙 X)`.
-/
def split_epi_coequalizes {X Y : C} (f : X ⟶ Y) [split_epi f] :
  is_colimit (cocone_of_split_epi f) :=
cofork.is_colimit.mk' _ $ λ s,
⟨section_ f ≫ s.π,
 by { dsimp, rw [← category.assoc, ← s.condition, category.id_comp] },
 λ m hm, by simp [← hm]⟩

end

end category_theory.limits


import QL.FOL.fol provability consistency

universes u v

namespace fol
open_locale logic_symbol
open subterm subformula logic logic.Theory
variables {L : language.{u}} {m : ℕ}

localized "prefix (name := mlift) `𝗟`:max := fol.subformula.mlift" in aclogic
localized "prefix (name := bounded_preTheory.mlift) `𝗟'`:max := fol.bounded_preTheory.mlift" in aclogic
localized "prefix (name := push) `𝗠`:max := fol.subformula.push" in aclogic
localized "prefix (name := pull) `𝗡`:max := fol.subformula.pull" in aclogic
localized "prefix (name := dummy) `𝗗`:max := fol.subformula.dummy" in aclogic

inductive proof : Π {m}, bounded_preTheory L m → bounded_subformula L m 0 → Type u
| generalize   {m} {T : bounded_preTheory L m} : ∀ {p}, proof T.mlift p → proof T (∀'𝗡p)
| mdp          {m} {T : bounded_preTheory L m} : ∀ {p q}, proof T (p ⟶ q) → proof T p → proof T q
| by_axiom     {m} {T : bounded_preTheory L m} : ∀ {p}, p ∈ T → proof T p
| verum        {m} {T : bounded_preTheory L m} : proof T ⊤
| imply₁       {m} {T : bounded_preTheory L m} : ∀ {p q}, proof T (p ⟶ q ⟶ p)
| imply₂       {m} {T : bounded_preTheory L m} : ∀ {p q r}, proof T ((p ⟶ q ⟶ r) ⟶ (p ⟶ q) ⟶ p ⟶ r)
| contra       {m} {T : bounded_preTheory L m} : ∀ {p q}, proof T ((∼p ⟶ ∼q) ⟶ q ⟶ p)
| specialize   {m} {T : bounded_preTheory L m} : ∀ {p} {t}, proof T (∀'p ⟶ subst t p)
| dummy_univ   {m} {T : bounded_preTheory L m} : ∀ {p q}, proof T (∀'(dummy p ⟶ q) ⟶ p ⟶ ∀'q)

instance : has_Longarrow (bounded_formula L m) := ⟨proof⟩

def provable (T : bounded_preTheory L m) (p : bounded_formula L m) : Prop := nonempty (T ⟹ p)

instance : axiomatic_classical_logic' (bounded_formula L m) :=
{ turnstile := @provable _ m,
  classical := λ T,
  { modus_ponens := λ p q ⟨bpq⟩ ⟨bp⟩, ⟨bpq.mdp bp⟩,
    imply₁ := λ p q, ⟨proof.imply₁⟩,
    imply₂ := λ p q r, ⟨proof.imply₂⟩,
    contraposition := λ p q, ⟨proof.contra⟩,
    provable_top := ⟨proof.verum⟩,
    bot_eq := by refl,
    and_def := λ p q, rfl,
    or_def := λ p q, rfl },
  by_axiom := λ T p mem, ⟨proof.by_axiom mem⟩ }

open_locale aclogic

namespace proof
variables {T : bounded_preTheory L m}

def weakening' {p} (h : T ⟹ p) : ∀ {U}, T ⊆ U → U ⟹ p :=
begin
  induction h,
  case generalize : m T p hyp_p IH
  { intros U hyp, refine generalize (IH $ set.image_subset _ hyp) },
  case mdp : m T p q hyp_pq hyp_p IH₁ IH₂
  { intros U hyp, exact (IH₁ hyp).mdp (IH₂ hyp) },
  case by_axiom : m T p hyp_p
  { intros U hyp, exact by_axiom (hyp hyp_p) },
  { intros U ss, exact verum },
  { intros U ss, exact imply₁ },
  { intros U ss, exact imply₂ },
  { intros U ss, exact contra },
  { intros U ss, exact specialize },
  { intros U ss, exact dummy_univ },
end

end proof

namespace provable
open axiomatic_classical_logic' axiomatic_classical_logic
variables {T U : bounded_preTheory L m}

lemma generalize {p} (h : T.mlift ⊢ p) : T ⊢ ∀'p.pull := by rcases h; exact ⟨h.generalize⟩

lemma generalize' {T : bounded_preTheory L (m + 1)} {p} (h : T ⊢ p) (hT : T = U.mlift) : U ⊢ ∀'p.pull :=
by rcases hT with rfl; exact generalize h

lemma gen {p : bounded_subformula L m 1} (h : T.mlift ⊢ p.push) : T ⊢ ∀'p :=
by rw[←subformula.pull_push p]; exact generalize h

lemma by_axiom {p} (h : p ∈ T) : T ⊢ p := ⟨proof.by_axiom h⟩

variables (T)

@[simp] lemma specialize (p) (t) : T ⊢ ∀'p ⟶ subst t p := ⟨proof.specialize⟩

variables {T}

lemma forall_subst {p} (h : T ⊢ ∀'p) (t) : T ⊢ subst t p :=
specialize T p t ⨀ h

infix ` ⊚ `:60 := forall_subst

variables (T)

@[simp] lemma dummy_univ (p q) : T ⊢ ∀'(dummy p ⟶ q) ⟶ p ⟶ ∀'q := ⟨proof.dummy_univ⟩

variables {T U}

@[elab_as_eliminator]
theorem rec_on {C : Π {m} (T : bounded_preTheory L m) (p : bounded_subformula L m 0), T ⊢ p → Prop}
  {m : ℕ} {T : bounded_preTheory L m} {p : bounded_formula L m} (b : T ⊢ p)
  (generalize : ∀ {m} {T : bounded_preTheory L m} {p} (b : T.mlift ⊢ p), C T.mlift p b → C T (∀'p.pull) (generalize b))
  (mdp : ∀ {m} {T : bounded_preTheory L m} {p q} (b₁ : T ⊢ p ⟶ q) (b₂ : T ⊢ p), C T (p ⟶ q) b₁ → C T p b₂ → C T q (b₁ ⨀ b₂))
  (by_axiom : ∀ {m} {T : bounded_preTheory L m} {p} (h : p ∈ T), C T p (by_axiom h))
  (verum : ∀ {m} {T : bounded_preTheory L m}, C T ⊤ axiomatic_classical_logic'.provable_top)
  (imply₁ : ∀ {m} {T : bounded_preTheory L m} {p q}, C T (p ⟶ q ⟶ p) (axiomatic_classical_logic'.imply₁ p q))
  (imply₂ : ∀ {m} {T : bounded_preTheory L m} {p q r}, C T ((p ⟶ q ⟶ r) ⟶ (p ⟶ q) ⟶ p ⟶ r) (axiomatic_classical_logic'.imply₂ p q r))
  (contra : ∀ {m} {T : bounded_preTheory L m} {p q}, C T ((∼p ⟶ ∼q) ⟶ q ⟶ p) (axiomatic_classical_logic'.contraposition p q))
  (specialize : ∀ {m} {T : bounded_preTheory L m} {p} {t}, C T (∀'p ⟶ subst t p) (specialize T p t))
  (dummy_univ : ∀ {m} {T : bounded_preTheory L m} {p q}, C T (∀'(dummy p ⟶ q) ⟶ p ⟶ ∀'q) (dummy_univ T p q)) :
  C T p b :=
begin
  rcases b with ⟨b⟩,
  induction b,
  case generalize : m T p b IH { exact generalize ⟨b⟩ IH },
  case mdp : m T p q b₁ b₂ IH₁ IH₂ { exact mdp ⟨b₁⟩ ⟨b₂⟩ IH₁ IH₂ },
  case by_axiom : m T p hp { exact by_axiom hp },
  case verum : m T { exact verum },
  case imply₁ : m T p q { exact imply₁ },
  case imply₂ : m T p q r { exact imply₂ },
  case contra : m T p q { exact contra },
  case specialize : m T p t { exact specialize },
  case dummy_univ : m T p q { exact dummy_univ }
end

noncomputable def provable.proof {T : bounded_preTheory L m} {p : bounded_formula L m} (b : T ⊢ p) : T ⟹ p := nonempty.some b

def weakening_aux {p} (h : T ⊢ p) : ∀ {U}, T ⊆ U → U ⊢ p :=
begin
  apply rec_on h,
  { intros m T p b IH U hyp, refine generalize (IH $ set.image_subset _ hyp) },
  { intros m T p q hyp_pq hyp_p IH₁ IH₂ U hyp, exact (IH₁ hyp) ⨀ (IH₂ hyp) },
  { intros m T p hyp_p U hyp, exact by_axiom (hyp hyp_p) },
  { intros, simp },
  { intros, simp },
  { intros, simp },
  { intros, simp },
  { intros, simp },
  { intros, simp }
end

lemma deduction_aux {q} (h : T ⊢ q) : ∀ (U) (p) (hT : T = insert p U), U ⊢ p ⟶ q :=
begin
  apply rec_on h,
  { rintros m T q b IH U p rfl,
    have : U.mlift ⊢ p.mlift ⟶ q, from IH U.mlift p.mlift (by simp[bounded_preTheory.mlift_insert]),
    have IH : U ⊢ ∀'(p.dummy ⟶ q.pull), from generalize this,
    have : U ⊢ ∀'(p.dummy ⟶ q.pull) ⟶ p ⟶ ∀'q.pull, by simp,
    show U ⊢ p ⟶ ∀'q.pull, from this ⨀ IH },
  { rintros m T p₁ p₂ b₁ b₂ IH₁ IH₂ U p rfl,
    show U ⊢ p ⟶ p₂, from (IH₁ U p rfl) ⨀₁ (IH₂ U p rfl) },
  { rintros m T p hp U r rfl, rcases hp with (rfl | hp),
    { simp }, { have : U ⊢ p, from by_axiom hp, exact hyp_right this r } },
  { rintros m T U p rfl, simp },
  { rintros m T p q U r rfl, simp },
  { rintros m T p q r U s rfl, simp },
  { rintros m T p q U r rfl, simp },
  { rintros m T p t U q rfl, refine hyp_right (specialize _ p t) _ },
  { rintros m T p q U r rfl, refine hyp_right (dummy_univ _ p q) _ }
end

instance : axiomatic_classical_logic (bounded_formula L m) :=
{ deduction' := λ T p q h, deduction_aux h T p rfl,
  weakening := λ T U p ss b, weakening_aux b ss }

lemma empty_axiom_generalize {p : bounded_formula L (m + 1)} (hp : ⬝⊢ p) : ⬝⊢ ∀'p.pull :=
by { have : bounded_preTheory.mlift ∅ ⊢ p, by simpa[bounded_preTheory.mlift] using hp, exact generalize this }

private lemma mlift_list_conjunction (P₀ : list (bounded_formula L $ m + 1)) : (∀ p, p ∈ P₀ → p ∈ T.mlift) →
  ∃ P : list (bounded_formula L m), P.conjunction.mlift = P₀.conjunction ∧ (∀ p, p ∈ P → p ∈ T) :=
begin
  induction P₀ with p₀ P₀ IH,
  { intros _, refine ⟨[], by simp⟩ },
  { intros h,
    have : ∃ P : list (bounded_formula L m), P.conjunction.mlift = P₀.conjunction ∧ (∀ p, p ∈ P → p ∈ T),
    from IH (λ p hp, h p (by simp[hp])),
    rcases this with ⟨P, eq, hP⟩,
    have : p₀ ∈ T.mlift, from h p₀ (by simp), rcases this with ⟨p, hp, rfl⟩,
    refine ⟨p :: P, by simpa using eq, by { rintros q (rfl | hq), { exact hp }, { exact hP q hq } }⟩ }
end

theorem finite_character_aux {m} {T : bounded_preTheory L m} {p} :
  T ⊢ p → ∃ P : list (bounded_formula L m), (∀ p, p ∈ P → p ∈ T) ∧ ⬝⊢ P.conjunction ⟶ p := λ h,
begin
  apply rec_on h,
  { rintros m T p b ⟨P₀, IH, IHb⟩,
    have : ∃ P : list (bounded_formula L m), P.conjunction.mlift = P₀.conjunction ∧ ∀ p, p ∈ P → p ∈ T,
    from mlift_list_conjunction P₀ IH,
    rcases this with ⟨P, eqP, hP⟩,
    refine ⟨P, hP, _⟩,
    have : ⬝⊢ ∀'(P.conjunction.dummy ⟶ p.pull),
    { have := empty_axiom_generalize IHb, rw[←eqP] at this; exact this },
    exact dummy_univ _ P.conjunction p.pull ⨀ this },
  { rintros m T p q b₁ b₂ ⟨P₁, IH₁, IHb₁⟩ ⟨P₂, IH₂, IHb₂⟩,
    refine ⟨P₁ ++ P₂, _, _⟩,
    { simp, rintros p (hp | hp), { exact IH₁ p hp }, { exact IH₂ p hp } },
    { have    : ⬝⊢ (P₁ ++ P₂).conjunction ⟶ P₁.conjunction, from list_conjunction_weakening (by simp),
      have h₁ : ⬝⊢ (P₁ ++ P₂).conjunction ⟶ p ⟶ q, from imply_trans this IHb₁,
      have    : ⬝⊢ (P₁ ++ P₂).conjunction ⟶ P₂.conjunction, from list_conjunction_weakening (by simp),
      have h₂ : ⬝⊢ (P₁ ++ P₂).conjunction ⟶ p, from imply_trans this IHb₂,
      exact h₁ ⨀₁ h₂ } },
  { rintros m T p hp, refine ⟨[p], by simp[hp], _⟩, simp, refine deduction.mp (by simp) },
  { rintros m T, refine ⟨[], by simp, by simp[empty_axiom]⟩ },
  { rintros m T p q, refine ⟨[], by simp, by simp[empty_axiom]⟩ },
  { rintros m T p q r, refine ⟨[], by simp, by simp[empty_axiom]⟩ },
  { rintros m T p q, refine ⟨[], by simp, by simp[empty_axiom]⟩ },
  { rintros m T p t, refine ⟨[], by simp, by simp[empty_axiom]⟩ },
  { rintros m T p q, refine ⟨[], by simp, by simp[empty_axiom]⟩ }
end

instance : has_finite_character (bounded_formula L m) :=
finite_character_of_finite_provable (bounded_formula L m) (λ T p, finite_character_aux)

def le_of (h : ∀ p ∈ T, U ⊢ p) : T ≤ U :=
begin
  intros p b,
  rcases finite_character_aux b with ⟨P, hP, b⟩,
  have : U ⊢ P.conjunction, from list_conjunction_provable (λ p hp, h _ (hP p hp)),
  exact of_empty_axiom _ b ⨀ this
end

lemma exists_of_subst (p : bounded_subformula L m 1) (t) : T ⊢ subst t p ⟶ ∃'p :=
contrapose.mp (imply_of_equiv
  (show T ⊢ p.neg.fal ⟶ ∼subst t p, by simpa using specialize T (∼p) t)
  (iff_dn_refl_right $ ∀'∼p) (equiv_refl _))

lemma specialize' {T} (p : bounded_subformula L m 1) : T ⊢ ∀' 𝗟 p ⟶ 𝗠 p :=
by { have : T ⊢ ∀' 𝗟 p ⟶ subst &(fin.last _) p.mlift, from specialize T p.mlift &(fin.last _), simpa using this }

lemma use {p : bounded_subformula L m 1} (t) (h : T ⊢ subst t p) : T ⊢ ∃'p :=
exists_of_subst p t ⨀ h

@[simp] lemma forall_top : T ⊢ ∀'⊤ :=
gen (by simp)

lemma forallK (p q) : T ⊢ ∀'(p ⟶ q) ⟶ ∀'p ⟶ ∀'q :=
begin
  have lmm₁ : T ⊢ ∀'(p ⟶ q) ⟶ ∀'(𝗗 (∀' p) ⟶ q),
  { have : 𝗟'T +{ ∀'(𝗟 p ⟶ 𝗟 q) } ⊢ 𝗠 p ⟶ 𝗠 q, from deduction.mpr (by simpa using specialize' (p ⟶ q)),
    have : 𝗟'T +{ ∀'(𝗟 p ⟶ 𝗟 q) } ⊢ ∀'𝗟 p ⟶ 𝗠 q, from imply_trans (specialize' _) this,
    refine deduction.mp (gen _), simp[bounded_preTheory.mlift_insert], exact this },
  have lmm₂ : T ⊢ ∀'(𝗗 (∀'p) ⟶ q) ⟶ ∀'p ⟶ ∀'q, from dummy_univ T (∀'p) q,
  exact imply_trans lmm₁ lmm₂
end

lemma forall_of_equiv {p₁ p₂} (h : T ⊢ ∀' p₁) (hp : 𝗟'T ⊢ 𝗠 p₁ ⟷ 𝗠 p₂) : T ⊢ ∀' p₂ :=
by { have : T ⊢ ∀'(p₁ ⟶ p₂), by simpa using generalize (iff_equiv.mp hp).1,
     exact (forallK _ _) ⨀ this ⨀ h }

lemma equiv_forall_of_equiv {p₁ p₂} (hp : 𝗟'T ⊢ 𝗠 p₁ ⟷ 𝗠 p₂) : T ⊢ ∀'p₁ ⟷ ∀'p₂ :=
by { simp[iff_equiv], split,
  { have : T ⊢ ∀'(p₁ ⟶ p₂), by simpa using generalize (iff_equiv.mp hp).1,
    exact forallK _ _ ⨀ this },
  { have : T ⊢ ∀'(p₂ ⟶ p₁), by simpa using generalize (iff_equiv.mp hp).2,
    exact forallK _ _ ⨀ this } }

lemma equiv_forall_of_equiv' {p₁ p₂} (hp : 𝗟'T ⊢ p₁ ⟷ p₂) : T ⊢ ∀' 𝗡 p₁ ⟷ ∀' 𝗡 p₂ :=
@equiv_forall_of_equiv _ _ T (𝗡 p₁) (𝗡 p₂) (by simpa using hp)

lemma equiv_exists_of_equiv {p₁ p₂} (hp : 𝗟'T ⊢ 𝗠 p₁ ⟷ 𝗠 p₂) : T ⊢ ∃'p₁ ⟷ ∃'p₂ :=
by simp[ex_def]; refine equiv_neg_of_equiv (equiv_forall_of_equiv (by simpa using equiv_neg_of_equiv hp))

lemma equiv_exists_of_equiv' {p₁ p₂} (hp : 𝗟'T ⊢ p₁ ⟷ p₂) : T ⊢ ∃' 𝗡 p₁ ⟷ ∃' 𝗡 p₂ :=
@equiv_exists_of_equiv _ _ T (𝗡 p₁) (𝗡 p₂) (by simpa using hp)

lemma univ_imply_dummy (p : bounded_subformula L m 1) (q : bounded_subformula L m 0) :
  T ⊢ ∀'(p ⟶ 𝗗 q) ⟶ ∃'p ⟶ q :=
begin
  have : T ⊢ ∀'(∼𝗗 q ⟶ ∼p) ⟶ ∼q ⟶ ∀'∼p, by simpa using dummy_univ T (∼q) (∼p),
  refine imply_of_equiv this (equiv_forall_of_equiv (by simp)) (by simp[ex_def])
end

lemma exists_intro (p : bounded_subformula L m 1) (q : bounded_subformula L m 0)
  (h : 𝗟'T ⊢ 𝗠 p ⟶ 𝗟 q) : T ⊢ ∃'p ⟶ q :=
by { have : T ⊢ ∀'(p ⟶ 𝗗 q), by simpa using generalize h,
     exact univ_imply_dummy p q ⨀ this }

def Nonempty : bounded_preTheory L m := { ∃'⊤, }

instance preTheory_Nonempty (T : bounded_preTheory L (m + 1)) : Nonempty.extend T :=
⟨le_of (by simp[Nonempty]; refine use &0 (by simp))⟩

instance preTheory_of_inhabited [inhabited (L.fn 0)] : Nonempty.extend T :=
⟨le_of (by simp[Nonempty]; refine use default (by simp))⟩

@[simp] lemma non_empty [Nonempty.extend T] : T ⊢ ∃'⊤ :=
logic.Theory.extend.by_axiom Nonempty T (by simp[Nonempty])

@[simp] lemma forall_bot [Nonempty.extend T] : T ⊢ ∀'⊥ ⟷ ⊥ :=
by { simp[iff_equiv],
     have : T ⊢ ∼∀'∼⊤, by simp[←ex_def],
     refine of_equiv (neg_of_equiv this (equiv_forall_of_equiv (by simp)))
     (neg_iff (∀'⊥)) }

@[simp] lemma forall_dummy [Nonempty.extend T] (p : bounded_formula L m) : T ⊢ ∀'𝗗 p ⟷ p :=
begin
  simp[iff_equiv], split,
  { have : T ⊢ ∀'(⊤ ⟶ 𝗗 p) ⟶ ∃'⊤ ⟶ p, from univ_imply_dummy ⊤ p,
    refine imply_of_equiv this (equiv_forall_of_equiv $ by simp) (by simp) },
  { refine deduction.mp (gen $ by simp) }
end

section prenex_normal_form

lemma neg_forall_pnf (p) : T ⊢ ∼∀'p ⟷ ∃'∼p :=
equiv_neg_of_equiv (equiv_forall_of_equiv (by simp[neg_eq]))

lemma neg_exists_pnf (p) : T ⊢ ∼∃'p ⟷ ∀'∼p := by simp[ex_def]

/-
lemma neg_univ_closure_pnf {n} (p : bounded_subformula L m n) : T ⊢ ∼∀'*p ⟷ ∃'*∼p :=
begin
  induction n with n IH generalizing m, { simp },
  { simp[forall_comm, bounded_subformula.exists_comm],
    have lmm₁ : T ⊢ ∼∀'𝗡 (∀'* 𝗠 p) ⟷ ∃'∼𝗡 (∀'* 𝗠 p), from neg_forall_pnf _,
    have : 𝗟'T ⊢ ∼∀'* (𝗠 p) ⟷ ∃'* (∼𝗠 p), from IH (𝗠 p),
    have lmm₂ : T ⊢ ∃'∼𝗡 (∀'* 𝗠 p) ⟷ ∃'𝗡 (∃'* ∼𝗠 p), by simpa using equiv_exists_of_equiv' this,
    exact equiv_trans lmm₁ lmm₂ }
end

lemma neg_exists_closure_pnf {n} (p : bounded_subformula L m n) : T ⊢ ∼∃'*p ⟷ ∀'*∼p :=
begin
  induction n with n IH generalizing m, { simp },
  { simp[forall_comm, bounded_subformula.exists_comm],
    have lmm₁ : T ⊢ ∼∃'𝗡 (∃'* 𝗠 p) ⟷ ∀'∼𝗡 (∃'* 𝗠 p), from neg_exists_pnf _,
    have : 𝗟'T ⊢ ∼∃'* (𝗠 p) ⟷ ∀'* (∼𝗠 p), from IH (𝗠 p),
    have lmm₂ : T ⊢ ∀'∼𝗡 (∃'* 𝗠 p) ⟷ ∀'𝗡 (∀'* ∼𝗠 p), by simpa using equiv_forall_of_equiv' this,
    exact equiv_trans lmm₁ lmm₂ }
end
-/

@[simp] lemma or_forall_pnf (p q) : T ⊢ (∀'p) ⊔ q ⟷ ∀'(p ⊔ 𝗗 q) :=
begin
  have lmm₁ : T ⊢ (∀'p) ⊔ q ⟶ ∀'(p ⊔ 𝗗 q),
  { have : 𝗟'T ⊢ (∀'𝗟 p) ⊔ 𝗟 q ⟶ 𝗠 p ⊔ 𝗟 q,
    { have : 𝗟'T ⊢ ∀'𝗟 p ⟶ 𝗠 p, from specialize' p,
      exact or_imply (∀'𝗟 p) (𝗟 q) (𝗠 p ⊔ 𝗟 q) ⨀ (imply_trans this (by simp)) ⨀ (by simp) },
    have : 𝗟'(T +{ (∀'p) ⊔ q }) ⊢ 𝗠 p ⊔ 𝗟 q, simpa using deduction.mpr this,
    have : T +{ (∀'p) ⊔ q } ⊢ ∀'(p ⊔ 𝗗 q), by simpa using generalize this,
    exact deduction.mp this },
  have lmm₂ : T ⊢ ∀'(p ⊔ 𝗗 q) ⟶ (∀'p) ⊔ q,
  { simp[has_sup.sup, subformula.or, imply_eq, neg_eq],
    have : T ⊢ ∀'(∼p ⟶ 𝗗 q) ⟶ ∃'∼p ⟶ q, from univ_imply_dummy (∼p) q,
    refine imply_of_equiv this (by simp) (equiv_imply_of_equiv (equiv_symm (neg_forall_pnf p)) (by simp)) },
  refine iff_equiv.mpr ⟨lmm₁, lmm₂⟩
end

@[simp] lemma and_exists_pnf (p q) : T ⊢ (∃'p) ⊓ q ⟷ ∃'(p ⊓ 𝗗 q) :=
begin
  have : T ⊢ (∀'∼p) ⊔ ∼q ⟷ ∀'∼p ⊔ 𝗗 (∼q), from or_forall_pnf (∼p) (∼q),
  refine equiv_of_equiv (equiv_neg_of_equiv this) _ _,
  { show T ⊢ ∼((∀'∼p) ⊔ ∼q) ⟷ (∃'p) ⊓ q,
    refine equiv_of_equiv (neg_or_equiv_and_neg (∀'∼p) (∼q))
      (equiv_refl _) (equiv_and_of_equiv (equiv_refl _) (iff_dn_refl_left q)) },
  { show T ⊢ ∼∀'(∼p ⊔ 𝗗 (∼q)) ⟷ ∃'(p ⊓ 𝗗 q),
    refine equiv_neg_of_equiv (equiv_forall_of_equiv $ equiv_symm (by simp[neg_eq])) }
end

@[simp] lemma and_forall_pnf [Nonempty.extend T] (p q) : T ⊢ (∀'p) ⊓ q ⟷ ∀'(p ⊓ 𝗗 q) :=
begin
  have lmm₁ : T ⊢ (∀'p) ⊓ q ⟶ ∀'(p ⊓ 𝗗 q),
  { have : 𝗟'T ⊢ (∀'𝗟 p) ⊓ 𝗟 q ⟶ 𝗠 p ⊓ 𝗟 q,
    { have : 𝗟'T ⊢ ∀'𝗟 p ⟶ 𝗠 p, from specialize' p,
      exact imply_and ((∀'𝗟 p) ⊓ 𝗟 q) (𝗠 p) (𝗟 q) ⨀ (imply_trans (by simp) this) ⨀ (by simp) },
    have : 𝗟'(T +{ (∀'p) ⊓ q }) ⊢ 𝗠 p ⊓ 𝗟 q, simpa using deduction.mpr this,
    have : T +{ (∀'p) ⊓ q } ⊢ ∀'(p ⊓ 𝗗 q), by simpa using generalize this,
    exact deduction.mp this },
  have lmm₂ : T ⊢ ∀'(p ⊓ 𝗗 q) ⟶ (∀'p) ⊓ q,
  { have lmm₃ : T ⊢ ∀'(p ⊓ 𝗗 q) ⟶ ∀'p, from forallK (p ⊓ 𝗗 q) p ⨀ (gen $ by simp),
    have lmm₄ : T ⊢ ∀'(p ⊓ 𝗗 q) ⟶ q,
    { have : T ⊢ ∀'(p ⊓ 𝗗 q) ⟶ ∀'𝗗 q, from forallK (p ⊓ 𝗗 q) (𝗗 q) ⨀ (gen $ by simp),
      refine imply_trans this (equiv_mp (forall_dummy _)) },
    refine imply_and (∀'(p ⊓ 𝗗 q)) (∀'p) q ⨀ lmm₃ ⨀ lmm₄ },
  refine iff_equiv.mpr ⟨lmm₁, lmm₂⟩
end

@[simp] lemma or_exists_pnf [Nonempty.extend T] (p q) : T ⊢ (∃'p) ⊔ q ⟷ ∃'(p ⊔ 𝗗 q) :=
begin
  have : T ⊢ (∀'∼p) ⊓ ∼q ⟷ ∀'∼p ⊓ 𝗗 (∼q), from and_forall_pnf (∼p) (∼q),
  have := equiv_neg_of_equiv this,
  refine equiv_of_equiv this _ _,
  { show T ⊢ ∼((∀'∼p) ⊓ ∼q) ⟷ (∃'p) ⊔ q,
    refine equiv_of_equiv (neg_and_equiv_or_neg (∀'∼p) (∼q))
      (equiv_refl _) (equiv_or_of_equiv (equiv_refl _) (iff_dn_refl_left q)) },
  { show T ⊢ ∼∀'(∼p ⊓ 𝗗 (∼q)) ⟷ ∃'(p ⊔ 𝗗 q),
    refine equiv_neg_of_equiv (equiv_forall_of_equiv $ equiv_symm (by simp[neg_eq])) }
end

lemma imply_forall_pnf (p q) : T ⊢ (p ⟶ ∀'q) ⟷ ∀'(𝗗 p ⟶ q) :=
by { have : T ⊢ ((∀'q) ⊔ ∼p) ⟷ ∀'(q ⊔ ∼𝗗 p), by simpa using or_forall_pnf q ∼p,
     exact equiv_of_equiv this (equiv_symm (by simp))
       (equiv_forall_of_equiv (equiv_symm (by simp))) }

lemma imply_exists_pnf [Nonempty.extend T] (p q) : T ⊢ (p ⟶ ∃'q) ⟷ ∃'(𝗗 p ⟶ q) :=
by{ have : T ⊢ ((∃'q) ⊔ ∼p) ⟷ ∃'(q ⊔ ∼𝗗 p), by simpa using or_exists_pnf q ∼p,
    refine equiv_of_equiv this (equiv_symm impl_iff_or')
      (equiv_exists_of_equiv $ equiv_symm $ by simp)}

lemma exists_imply_pnf (p q) : T ⊢ (∃'p ⟶ q) ⟷ ∀'(p ⟶ 𝗗 q) :=
by{ have : T ⊢ ((∀'∼p) ⊔ q) ⟷ ∀'(∼p ⊔ 𝗗 q), by simp,
    refine equiv_of_equiv this _ _,
    { have : T ⊢ (∼∼∀'∼p) ⊔ q ⟷ ∃'p ⟶ q, from equiv_symm (by simp[ex_def]),
      refine equiv_trans (equiv_or_of_equiv _ _) this; simp },
    { refine equiv_forall_of_equiv (equiv_symm $ by simp) } }

lemma forall_imply_pnf [Nonempty.extend T] (p q) : T ⊢ (∀'p ⟶ q) ⟷ ∃'(p ⟶ 𝗗 q) :=
by{ have : T ⊢ ((∃'∼p) ⊔ q) ⟷ ∃'(∼p ⊔ 𝗗 q), by simp,
    refine equiv_of_equiv this _ _,
    { have : T ⊢ (∃'∼p) ⊔ q ⟷ ∀'∼∼p ⟶ q, from equiv_symm (by simp[ex_def]),
      refine equiv_trans this (equiv_imply_of_equiv (equiv_forall_of_equiv _) _); simp },
    { refine equiv_exists_of_equiv (equiv_symm $ by simp) } }

lemma forall_imply_forall_pnf [Nonempty.extend T] (p q) : T ⊢ (∀'p ⟶ ∀'q) ⟷ ∃' ∀'(𝗡 𝗗 𝗠 p ⟶ 𝗗 q) :=
begin
  have : 𝗟'T ⊢ (𝗠 p ⟶ ∀'𝗟 q) ⟷ ∀'(𝗗 𝗠 p ⟶ 𝗟 q), from imply_forall_pnf (𝗠 p) (𝗟 q),
  have lmm₁ : T ⊢ ∃'(p ⟶ ∀' 𝗗 q) ⟷ ∃' ∀'(𝗡 𝗗 𝗠 p ⟶ 𝗗 q),
    from equiv_exists_of_equiv (by simpa using this),
  have lmm₂ : T ⊢ (∀'p ⟶ ∀'q) ⟷ ∃'(p ⟶ ∀' 𝗗 q), by simpa using forall_imply_pnf p (∀'q),
  exact equiv_trans lmm₂ lmm₁
end

lemma forall_imply_exists_pnf [Nonempty.extend T] (p q) : T ⊢ (∀'p ⟶ ∃'q) ⟷ ∃' ∃'(𝗡 𝗗 𝗠 p ⟶ 𝗗 q) :=
begin
  have : 𝗟'T ⊢ (𝗠 p ⟶ ∃'𝗟 q) ⟷ ∃'(𝗗 𝗠 p ⟶ 𝗟 q), from imply_exists_pnf (𝗠 p) (𝗟 q),
  have lmm₁ : T ⊢ ∃'(p ⟶ ∃' 𝗗 q) ⟷ ∃' ∃'(𝗡 𝗗 𝗠 p ⟶ 𝗗 q),
    from equiv_exists_of_equiv (by simpa using this),
  have lmm₂ : T ⊢ (∀'p ⟶ ∃'q) ⟷ ∃'(p ⟶ ∃' 𝗗 q), by simpa using forall_imply_pnf p (∃'q),
  exact equiv_trans lmm₂ lmm₁
end

lemma exists_imply_forall_pnf (p q) : T ⊢ (∃'p ⟶ ∀'q) ⟷ ∀' ∀'(𝗡 𝗗 𝗠 p ⟶ 𝗗 q) :=
begin
  have : 𝗟'T ⊢ (𝗠 p ⟶ ∀'𝗟 q) ⟷ ∀'(𝗗 𝗠 p ⟶ 𝗟 q), from imply_forall_pnf (𝗠 p) (𝗟 q),
  have lmm₁ : T ⊢ ∀'(p ⟶ ∀' 𝗗 q) ⟷ ∀' ∀'(𝗡 𝗗 𝗠 p ⟶ 𝗗 q),
    from equiv_forall_of_equiv (by simpa using this),
  have lmm₂ : T ⊢ (∃'p ⟶ ∀'q) ⟷ ∀'(p ⟶ ∀' 𝗗 q), by simpa using exists_imply_pnf p (∀'q),
  exact equiv_trans lmm₂ lmm₁
end

lemma exists_imply_exists_pnf (p q) : T ⊢ (∃'p ⟶ ∃'q) ⟷ ∀' ∃'(𝗡 𝗗 𝗠 p ⟶ 𝗗 q) :=
begin
  have : 𝗟'T ⊢ (𝗠 p ⟶ ∃'𝗟 q) ⟷ ∃'(𝗗 𝗠 p ⟶ 𝗟 q), from imply_exists_pnf (𝗠 p) (𝗟 q),
  have lmm₁ : T ⊢ ∀'(p ⟶ ∃' 𝗗 q) ⟷ ∀' ∃'(𝗡 𝗗 𝗠 p ⟶ 𝗗 q),
    from equiv_forall_of_equiv (by simpa using this),
  have lmm₂ : T ⊢ (∃'p ⟶ ∃'q) ⟷ ∀'(p ⟶ ∃' 𝗗 q), by simpa using exists_imply_pnf p (∃'q),
  exact equiv_trans lmm₂ lmm₁
end

end prenex_normal_form

section quantifier
variables {m} {n : ℕ}
/-
lemma specialize_foralls (p : bounded_subformula L m n) (w : fin n → subterm L m 0) : T ⊢ ∀'*p ⟶ substs w p :=
begin
  induction n with n IH generalizing m,
  { simp },
  { have : 𝗟'T ⊢ ∀'* 𝗠 p ⟶ substs (mlift ∘ w ∘ fin.cast_succ) (𝗠 p),
    from IH (𝗠 p) (subterm.mlift ∘ w ∘ fin.cast_succ),
    have : T ⊢ ∀'(𝗡 (∀'*𝗠 p) ⟶ 𝗡 (substs (mlift ∘ w ∘ fin.cast_succ) (𝗠 p))),
    by simpa using generalize this,
    have lmm₁ : T ⊢ ∀'*p ⟶ ∀'𝗡 (substs (mlift ∘ w ∘ fin.cast_succ) (𝗠 p)),
    by simpa[forall_comm] using forallK _ _ ⨀ this,
    have lmm₂ : T ⊢ ∀'𝗡 (substs (mlift ∘ w ∘ fin.cast_succ) (𝗠 p)) ⟶ substs w p,
    from specialize T (𝗡 (substs (mlift ∘ w ∘ fin.cast_succ) (𝗠 p))) (w $ fin.last n),
    exact imply_trans lmm₁ lmm₂ }
end

lemma foralls_substs {p : bounded_subformula L m n} (h : T ⊢ ∀'*p) (w) : T ⊢ substs w p :=
specialize_foralls p w ⨀ h

@[simp] lemma exists_dn (p : bounded_subformula L m n) : T ⊢ ∃'*∼∼p ⟷ ∃'*p :=
begin
  induction n with n IH generalizing m; simp[bounded_subformula.exists_comm],
  refine equiv_exists_of_equiv (by simpa using IH (𝗠 p))
end

@[simp] lemma neg_univ_closure_neg (p : bounded_subformula L m n) : T ⊢ ∼∀'*(∼p) ⟷ ∃'*p :=
begin
  have : T ⊢ ∼∀'*(∼p) ⟷ ∃'*(∼∼p), from neg_univ_closure_pnf (∼p),
  refine equiv_trans this (by simp)
end

@[simp] lemma exists_substs (p : bounded_subformula L m n) (w : fin n → subterm L m 0) : T ⊢ substs w p ⟶ ∃'*p :=
begin
  have : T ⊢ ∼∼substs w p ⟶ ∼∀'* (∼p), by simpa using contrapose.mpr (specialize_foralls (∼p) w),
  refine imply_of_equiv this (by simp) (by simp)
end

lemma exists_of_substs {p : bounded_subformula L m n} (w) (h : T ⊢ substs w p) : T ⊢ ∃'*p :=
exists_substs p w ⨀ h
-/
end quantifier

end provable

namespace bounded_preTheory
variables {L m} (T U : bounded_preTheory L m)

--instance [T.extend U] : logic.Theory.extend T.mlift U.mlift := ⟨by { intros p h, sorry }⟩

end bounded_preTheory

section equal

def eq_axiom_schema_funext [L.has_equal] {m k} (f : L.fn k) : bounded_subformula L m 0 :=
∀'*((⋀ i, #(fin.cast_add k i) =' #(fin.nat_add k i)) ⟶
  (function f (var ∘ fin.cast_add k) =' function f (var ∘ fin.nat_add k)) : bounded_subformula L m (k + k))

def eq_axiom_schema_relext [L.has_equal] {m k} (r : L.pr k) : bounded_subformula L m 0 :=
∀'*((⋀ i : fin k, #(fin.cast_add k i) =' #(fin.nat_add k i)) ⟶
  (relation r (var ∘ fin.cast_add k) ⟷ relation r (var ∘ fin.nat_add k)))

variables {L m} [language.has_equal L]

inductive Eq : bounded_preTheory L m
| eq_refl : Eq (∀'(#0 =' #0))
| eq_symm : Eq (∀' ∀'((#0 =' #1) ⟶ (#1 =' #0)))
| eq_trans : Eq (∀' ∀' ∀'((#0 =' #1) ⟶ (#1 =' #2) ⟶ (#0 =' #2)))
| funext : ∀ {k} (f : L.fn k), Eq (eq_axiom_schema_funext f)
| relext : ∀ {k} (r : L.pr k), Eq (eq_axiom_schema_relext r)

attribute [simp] Eq.eq_refl Eq.eq_symm Eq.eq_trans Eq.funext Eq.relext

/-
@[simp] lemma mlift_Eq : (Eq : bounded_preTheory L m).mlift = Eq :=
begin
  ext p, simp[bounded_preTheory.mlift], split,
  { rintros ⟨p, hp, rfl⟩,
    cases hp; simp[fal_eq],
    { exact Eq.eq_refl },
    { exact Eq.eq_symm },
    { exact Eq.eq_trans },
    { exact Eq.funext _ },
    { exact Eq.relext _ } },
  { intros h, cases h,
    { simp[fal_eq], refine ⟨_, Eq.eq_refl, by simp⟩ },
    { simp[fal_eq], refine ⟨_, Eq.eq_symm, by simp⟩ },
    { simp[fal_eq], refine ⟨_, Eq.eq_trans, by simp⟩ },
    { refine ⟨_, Eq.funext _, by simp[eq_axiom_schema_funext]⟩ },
    { refine ⟨_, Eq.relext _, by simp[eq_axiom_schema_relext, (∘)]⟩ } }
end
-/
--def eq_extend {T : bounded_preTheory L m} [extend Eq T] : extend Eq 𝗟'T :=

end equal

end fol


import .tab

variables {p q r s : Prop}

open tactic

-- example (h1 : ¬ ((p → q) → r)) (h2 : p ∧ ¬ q) : r := by tab
--
-- example (h1 : ¬ ((p → q) → r)) (h2 : p ∧ ¬ q) : r :=
-- by do proof_by_contradiction,
--       -- trace "After pbc : ", trace_state,
--       normalize,
--       -- trace "After normalization : ", trace_state,
--       tab_aux,
--       skip
--
-- meta def tab_aux : tactic unit :=
-- do split_conjs,
--    contradiction <|>
--      (split_disj >> tab_aux >> tab_aux)


import group_theory.perm group_theory.order_of_element group_theory.quotient_group

universes u v
open finset is_subgroup equiv equiv.perm quotient_group

instance {α β : Type*} [group α] [group β] [decidable_eq β] (f : α → β) [is_group_hom f] :
  decidable_pred (is_group_hom.ker f) :=
λ _, decidable_of_iff _ (is_group_hom.mem_ker f).symm

def alternating (α : Type*) [decidable_eq α] [fintype α] : Type* :=
is_group_hom.ker (sign : perm α → units ℤ)

/- not definitionally equal to `subtype.decidable_eq`, since `subtype.decidable_eq` does
  not reduce in the kernel -/
instance (α : Type*) [decidable_eq α] [fintype α] : decidable_eq (alternating α) :=
λ a b, decidable_of_iff (a.1 = b.1) (by cases a; cases b; simp [subtype.mk.inj_eq])

instance (α : Type*) [decidable_eq α] [fintype α] : fintype (alternating α) :=
set_fintype _

instance (α : Type*) [decidable_eq α] [fintype α] : group (alternating α) :=
by unfold alternating; apply_instance

section classical

local attribute [instance] classical.prop_decidable

lemma card_alternating (α : Type*) [decidable_eq α] [fintype α] (h : 2 ≤ fintype.card α):
  fintype.card (alternating α) * 2 = (fintype.card α).fact :=
have (quotient_group.quotient (is_group_hom.ker (sign : perm α → units ℤ))) ≃ units ℤ,
  from quotient_ker_equiv_of_surjective _ (sign_surjective h),
calc fintype.card (alternating α) * 2 = fintype.card (units ℤ × alternating α) :
  by rw [mul_comm, fintype.card_prod, fintype.card_units_int]
... = fintype.card (perm α) : fintype.card_congr
  (calc (units ℤ × alternating α) ≃
    (quotient_group.quotient (is_group_hom.ker (sign : perm α → units ℤ)) × alternating α)  :
      equiv.prod_congr this.symm (by refl)
  ... ≃ perm α : (group_equiv_quotient_times_subgroup _).symm)
... = (fintype.card α).fact : fintype.card_perm

end classical

local notation `A5` := alternating (fin 5)
variables {α : Type*} [fintype α] [decidable_eq α]

section
local attribute [semireducible] reflected

meta instance fin_reflect (n : ℕ) : has_reflect (fin n) :=
λ a, `(@fin.mk %%`(n) %%(nat.reflect a.1) (of_as_true %%`(_root_.trivial)))

meta instance fin_fun.has_reflect : has_reflect (fin 5 → fin 5) :=
list.rec_on (quot.unquot (@univ (fin 5) _).1)
  (λ f, `(λ y : fin 5, y))
  (λ x l ih f, let e := ih f in
    if f x = x then e
    else let ex := fin_reflect 5 x in
      let efx := fin_reflect 5 (f x) in
      if e = `(λ y : fin 5, y)
      then `(λ y : fin 5, ite.{1} (y = %%ex) (%%efx) y)
      else `(λ y : fin 5, ite.{1} (y = %%ex) (%%efx) ((%%e : fin 5 → fin 5) y)))

meta instance : has_reflect (perm (fin 5)) :=
λ f, `(@equiv.mk.{1 1} (fin 5) (fin 5)
    %%(fin_fun.has_reflect f.to_fun)
  %%(fin_fun.has_reflect f.inv_fun)
  (of_as_true %%`(_root_.trivial)) (of_as_true %%`(_root_.trivial)))

meta instance I1 : has_reflect (alternating (fin 5)) :=
λ f, `(@subtype.mk (perm (fin 5)) (is_group_hom.ker (sign : perm (fin 5) → units ℤ))
   %%(@reflect (perm (fin 5)) f.1 (equiv.perm.has_reflect f.1))
  ((is_group_hom.mem_ker sign).2 %%`(@eq.refl (units ℤ) 1)))

meta instance multiset.has_reflect {α : Type} [reflected α] [has_reflect α] :
  has_reflect (multiset α) :=
λ s, let l : list α := quot.unquot s in `(@quotient.mk.{1} (list %%`(α)) _ %%`(l))

meta instance I2 (a : alternating (fin 5)) :
  has_reflect {b : alternating (fin 5) × alternating (fin 5) // b.2 * a * b.2⁻¹ = b.1} :=
λ b, `(@subtype.mk (alternating (fin 5) × alternating (fin 5))
  (λ b, b.2 * %%`(a) * b.2⁻¹ = b.1)
  %%(prod.has_reflect _ _ b.1) (of_as_true %%`(_root_.trivial)))

meta instance I3 (a : alternating (fin 5)) (m : reflected a) :
  reflected {b : alternating (fin 5) × alternating (fin 5) // b.2 * a * b.2⁻¹ = b.1} :=
`({b : alternating (fin 5) × alternating (fin 5) // b.2 * %%m * b.2⁻¹ = b.1})

meta instance I4 : has_reflect
  (Σ a : alternating (fin 5), multiset
  {b : alternating (fin 5) × alternating (fin 5) // b.2 * a * b.2⁻¹ = b.1}) :=
λ s, let ra : reflected s.1 := (I1 s.1) in
`(let a : alternating (fin 5) := %%ra in
  @sigma.mk (alternating (fin 5))
    (λ a, multiset {b : alternating (fin 5) × alternating (fin 5) // b.2 * a * b.2⁻¹ = b.1})
    a %%(@multiset.has_reflect _ (I3 s.1 ra) (I2 s.1) s.2))

end

meta def conjugacy_classes_A5_meta_aux : list (alternating (fin 5)) → list
  (Σ a : alternating (fin 5), list
  {b : alternating (fin 5) × alternating (fin 5) // b.2 * a * b.2⁻¹ = b.1})
| [] := []
| (a :: l) := let m : Σ a : alternating (fin 5), list
    {b : alternating (fin 5) × alternating (fin 5) // b.2 * a * b.2⁻¹ = b.1} :=
  ⟨a, ((quot.unquot (@univ (alternating (fin 5)) _).1).map
  (λ x, show {b : alternating (fin 5) × alternating (fin 5) // b.2 * a * b.2⁻¹ = b.1},
    from ⟨(x * a * x⁻¹, x), rfl⟩)).pw_filter (λ x y, x.1.1 ≠ y.1.1)⟩ in
m :: conjugacy_classes_A5_meta_aux (l.diff (m.2.map (prod.fst ∘ subtype.val)))

meta def conjugacy_classes_A5_meta : multiset (Σ a : alternating (fin 5), multiset
  {b : alternating (fin 5) × alternating (fin 5) // b.2 * a * b.2⁻¹ = b.1}) :=
(quotient.mk ((conjugacy_classes_A5_meta_aux (quot.unquot univ.1)).map
    (λ a, ⟨a.1, (quotient.mk a.2)⟩)))

meta def thing {α : Sort*} [has_reflect α] (a : α) : tactic unit :=
tactic.exact `(a)
set_option profiler true
@[irreducible] def conjugacy_classes_A5_aux : multiset (Σ a : alternating (fin 5), multiset
  {b : alternating (fin 5) × alternating (fin 5) // b.2 * a * b.2⁻¹ = b.1}) :=
by thing (conjugacy_classes_A5_meta)

def conjugacy_classes_A5_aux2 : multiset (multiset (alternating (fin 5))) :=
conjugacy_classes_A5_aux.map (λ s, s.2.map (λ b, b.1.1))

lemma nodup_conjugacy_classes_A5_aux2_bind :
  (conjugacy_classes_A5_aux2.bind id).nodup :=
dec_trivial

lemma nodup_conjugacy_classes_A5_aux2 : ∀ s : multiset (alternating (fin 5)),
  s ∈ conjugacy_classes_A5_aux2 → s.nodup :=
(multiset.nodup_bind.1 nodup_conjugacy_classes_A5_aux2_bind).1

def conjugacy_classes_A5 : finset (finset (alternating (fin 5))) :=
⟨conjugacy_classes_A5_aux2.pmap finset.mk nodup_conjugacy_classes_A5_aux2, dec_trivial⟩

lemma nodup_conjugacy_classes_A5_bind :
  (conjugacy_classes_A5.1.bind finset.val).nodup :=
have conjugacy_classes_A5.1.bind finset.val =
  conjugacy_classes_A5_aux2.bind id,
from multiset.ext.2 $ λ a,
  by rw [conjugacy_classes_A5, @multiset.count_bind A5, @multiset.count_bind A5,
    multiset.map_pmap, multiset.pmap_eq_map]; refl,
this.symm ▸ nodup_conjugacy_classes_A5_aux2_bind

lemma is_conj_conjugacy_classes_A5 (s : finset A5) (h : s ∈ conjugacy_classes_A5) :
  ∀ x y ∈ s, is_conj x y :=
assume x y hx hy,
begin
  simp only [conjugacy_classes_A5, finset.mem_def, multiset.mem_pmap,
    conjugacy_classes_A5_aux2] at h,
  rcases h with ⟨t, ht₁, ht₂⟩,
  rw [multiset.mem_map] at ht₁,
  rcases ht₁ with ⟨u, hu₁, hu₂⟩,
  have hx' : x ∈ multiset.map (λ (b : {b : A5 × A5 // b.2 * u.1 * b.2⁻¹ = b.1}), b.1.1) u.2,
  { simpa [ht₂.symm, hu₂] using hx },
  have hy' : y ∈ multiset.map (λ (b : {b : A5 × A5 // b.2 * u.1 * b.2⁻¹ = b.1}), b.1.1) u.2,
  { simpa [ht₂.symm, hu₂] using hy },
  cases multiset.mem_map.1 hx' with xc hxc,
  cases multiset.mem_map.1 hy' with yc hyc,
  exact is_conj_trans
    (is_conj_symm (show is_conj u.1 x, from hxc.2 ▸ ⟨_, xc.2⟩))
    (hyc.2 ▸ ⟨_, yc.2⟩)
end

lemma normal_subgroup_eq_bind_conjugacy_classes (s : finset (finset G)) (h₁ : ∀ x, ∃ t ∈ s, x ∈ t)
  (h₂ : ∀ t ∈ s, ∀ x y ∈ t, is_conj x y) (I : finset G) [nI : normal_subgroup (↑I : set G)] :
  ∃ u ⊆ s, I = u.bind id :=
⟨(s.powerset.filter (λ u : finset (finset G), u.bind id ⊆ I)).bind id,
    (λ x, by simp only [finset.subset_iff, mem_bind, mem_filter, exists_imp_distrib, mem_powerset,
      and_imp, id.def] {contextual := tt}; tauto),
  le_antisymm
    (λ x hxI, let ⟨t, ht₁, ht₂⟩ := h₁ x in
      mem_bind.2 ⟨t, mem_bind.2 ⟨(s.powerset.filter (λ u : finset (finset G), u.bind id ⊆ I)).bind id,
          mem_filter.2 ⟨mem_powerset.2
            (λ u hu, let ⟨v, hv₁, hv₂⟩ := mem_bind.1 hu in
              mem_powerset.1 (mem_filter.1 hv₁).1 hv₂),
          λ y hy, let ⟨u, hu₁, hu₂⟩ := mem_bind.1 hy in
            let ⟨v, hv₁, hv₂⟩ := mem_bind.1 hu₁ in
            (mem_filter.1 hv₁).2 (mem_bind.2 ⟨u, hv₂, hu₂⟩)⟩,
        mem_bind.2 ⟨{t}, mem_filter.2 ⟨by simp [ht₁, finset.subset_iff],
            λ y hy, let ⟨u, hu₁, hu₂⟩ := mem_bind.1 hy in
              let ⟨z, hz⟩ := h₂ t ht₁ x y ht₂ (by simp * at *) in
              hz ▸ @normal_subgroup.normal G _ I.to_set nI _ hxI _⟩,
          by simp⟩⟩,
        ht₂⟩)
    (λ x, by simp only [finset.subset_iff, mem_bind, exists_imp_distrib, mem_filter, mem_powerset]; tauto)⟩

lemma simple_of_card_conjugacy_classes [fintype G] [decidable_eq G] (s : finset (finset G))
  (h₁ : ∀ x, ∃ t ∈ s, x ∈ t) (h₂ : ∀ t ∈ s, ∀ x y ∈ t, is_conj x y)
  (hs : (s.1.bind finset.val).nodup)
  (h₃ : ∀ t ≤ s.1.map finset.card, 1 ∈ t → t.sum ∣ fintype.card G → t.sum = 1 ∨ t.sum = fintype.card G) :
  simple_group G :=
by haveI := classical.dec; exact
⟨λ H iH,
  let I := (set.to_finset H) in
  have Ii : normal_subgroup (↑I : set G), by simpa using iH,
  let ⟨u, hu₁, hu₂⟩ :=
    @normal_subgroup_eq_bind_conjugacy_classes G _ _ _ s h₁ h₂ I Ii in
  have hInd : ∀ (x : finset G), x ∈ u → ∀ (y : finset G), y ∈ u → x ≠ y → id x ∩ id y = ∅,
    from λ x hxu y hyu hxy,
      begin
        rw multiset.nodup_bind at hs,
        rw [← finset.disjoint_iff_inter_eq_empty, finset.disjoint_left],
        exact multiset.forall_of_pairwise
          (λ (a b : finset G) (h : multiset.disjoint a.1 b.1),
          multiset.disjoint.symm h) hs.2 x (hu₁ hxu) y (hu₁ hyu) hxy
      end,
  have hci : card I = u.sum finset.card,
    by rw [hu₂, card_bind hInd]; refl,
  have hu1 : (1 : G) ∈ u.bind id, by exactI hu₂ ▸ is_submonoid.one_mem (↑I : set G),
  let ⟨v, hv₁, hv₂⟩ := mem_bind.1 hu1 in
  have hv : v = finset.singleton (1 : G),
    from finset.ext.2 $ λ a, ⟨λ hav, mem_singleton.2 $
        is_conj_one_right.1 (h₂ v (hu₁ hv₁) _ _ hv₂ hav),
      by simp [show (1 : G) ∈ v, from hv₂] {contextual := tt}⟩,
  have hci' : card I = 1 ∨ card I = fintype.card G,
    begin
      rw [hci],
      exact h₃ _ (multiset.map_le_map (show u.1 ≤ s.1,
        from (multiset.le_iff_subset u.2).2 hu₁))
          (multiset.mem_map.2 ⟨finset.singleton 1, hv ▸ hv₁, rfl⟩)
          (calc u.sum finset.card = card I : hci.symm
            ... = fintype.card (↑I : set G) : (set.card_fintype_of_finset' I (by simp)).symm
            ... ∣ fintype.card G : by exactI card_subgroup_dvd_card _)
    end,
    hci'.elim
      (λ hci', or.inl (set.ext (λ x,
        let ⟨y, hy⟩ := finset.card_eq_one.1 hci' in
        by resetI;
          simp only [I, finset.ext, set.mem_to_finset, finset.mem_singleton] at hy;
          simp [is_subgroup.mem_trivial, hy, (hy 1).1 (is_submonoid.one_mem H)])))
      (λ hci', or.inr $
        suffices I = finset.univ,
          by simpa [I, set.ext_iff, finset.ext] using this,
        finset.eq_of_subset_of_card_le (λ _, by simp) (by rw hci'; refl))⟩

lemma card_A5 : fintype.card A5 = 60 :=
(nat.mul_right_inj (show 2 > 0, from dec_trivial)).1 $
have 2 ≤ fintype.card (fin 5), from dec_trivial,
  by rw [card_alternating _ this]; simp; refl

lemma conjugacy_classes_A5_bind_eq_univ :
  conjugacy_classes_A5.bind (λ t, t) = univ :=
eq_of_subset_of_card_le (λ _, by simp)
  (calc card univ = 60 : card_A5
    ... ≤ (conjugacy_classes_A5.1.bind finset.val).card : dec_trivial
    ... = (conjugacy_classes_A5.bind id).card :
      begin
        rw [finset.card_bind, multiset.card_bind], refl,
        { exact multiset.forall_of_pairwise (λ a b, by simp [finset.inter_comm])
            (by simp only [finset.disjoint_iff_inter_eq_empty.symm, finset.disjoint_left];
              exact (multiset.nodup_bind.1 nodup_conjugacy_classes_A5_bind).2) }
      end)

lemma A5_simple : simple_group A5 :=
simple_of_card_conjugacy_classes conjugacy_classes_A5
  (λ x, mem_bind.1 $ by rw [conjugacy_classes_A5_bind_eq_univ]; simp)
  is_conj_conjugacy_classes_A5
  nodup_conjugacy_classes_A5_bind
  (by simp only [multiset.mem_powerset.symm, card_A5];
    exact dec_trivial)


import phase2.approximation

open set sum
open_locale classical

universe u

namespace con_nf
variables [params.{u}] {α : Λ} [position_data.{}] [phase_2_assumptions α] {β : Iic α}
  (π : struct_approx β)

namespace struct_approx

open near_litter_approx hypothesis

lemma order_iso_apply_mem {S T : sublitter} {a} {L : litter}
  (h : (S.order_iso T a : atom) ∈ litter_set L) : T.litter = L :=
begin
  rw [← litter.litter_to_sublitter L, ← sublitter.inter_nonempty_iff],
  exact ⟨_, (S.order_iso T a).prop, h⟩,
end

lemma order_iso_apply_eq {S T U V : sublitter} {a b}
  (h : (S.order_iso T a : atom) = U.order_iso V b) :
  T.litter = V.litter :=
begin
  rw subtype.coe_eq_iff at h,
  exact (order_iso_apply_mem (T.subset h.some)).symm,
end

/-- Computes the action of a structural approximation `π` on an atom `a`. -/
noncomputable def atom_completion (a : atom) (A : extended_index β)
  (H : hypothesis ⟨inl a, A⟩) : atom :=
if h : a ∈ (π A).atom_perm.domain then π A • a else
((π A).largest_sublitter a.1).order_iso
  ((π A).largest_sublitter (H.near_litter_image a.1.to_near_litter A
    (relation.trans_gen.single $ constrains.atom a A)).1)
  ⟨a, (π A).mem_largest_sublitter_of_not_mem_domain a h⟩

end struct_approx

end con_nf


import category.bitraversable.basic

universes u

variables {t : Type u → Type u → Type u} [bitraversable t]
variables {β : Type u}

namespace bitraversable
open functor is_lawful_applicative
variables {F G : Type u → Type u}
          [applicative F] [applicative G]

@[reducible]
def tfst {α α'} (f : α → F α') : t α β → F (t α' β) :=
bitraverse f pure

@[reducible]
def tsnd {α α'} (f : α → F α') : t β α → F (t β α') :=
bitraverse pure f

variables [is_lawful_bitraversable t]
          [is_lawful_applicative F]
          [is_lawful_applicative G]

@[higher_order tfst_id]
lemma id_tfst : Π {α β} (x : t α β), tfst id.mk x = id.mk x :=
@id_bitraverse _ _ _

@[higher_order tsnd_id]
lemma id_tsnd : Π {α β} (x : t α β), tsnd id.mk x = id.mk x :=
@id_bitraverse _ _ _

@[higher_order tfst_comp_tfst]
lemma comp_tfst {α₀ α₁ α₂ β}
  (f : α₀ → F α₁) (f' : α₁ → G α₂) (x : t α₀ β) :
  comp.mk (tfst f' <$> tfst f x) = tfst (comp.mk ∘ map f' ∘ f) x :=
by rw ← comp_bitraverse; simp [tfst,map_comp_pure,has_pure.pure]

@[higher_order tfst_comp_tsnd]
lemma tfst_tsnd {α₀ α₁ β₀ β₁}
  (f : α₀ → F α₁) (f' : β₀ → G β₁) (x : t α₀ β₀) :
  comp.mk (tfst f <$> tsnd f' x) =
  bitraverse (comp.mk ∘ pure ∘ f) (comp.mk ∘ map pure ∘ f') x :=
by rw ← comp_bitraverse; simp [tfst,tsnd]

@[higher_order tsnd_comp_tfst]
lemma tsnd_tfst {α₀ α₁ β₀ β₁}
  (f : α₀ → F α₁) (f' : β₀ → G β₁) (x : t α₀ β₀) :
  comp.mk (tsnd f' <$> tfst f x) =
  bitraverse (comp.mk ∘ map pure ∘ f) (comp.mk ∘ pure ∘ f') x :=
by rw ← comp_bitraverse; simp [tfst,tsnd]

@[higher_order tsnd_comp_tsnd]
lemma comp_tsnd {α β₀ β₁ β₂}
  (g : β₀ → F β₁) (g' : β₁ → G β₂) (x : t α β₀) :
  comp.mk (tsnd g' <$> tsnd g x) = tsnd (comp.mk ∘ map g' ∘ g) x :=
by rw ← comp_bitraverse; simp [tsnd]; refl

open bifunctor

private lemma pure_eq_id_mk_comp_id {α} :
  pure = id.mk ∘ @id α := rfl

open function

@[higher_order]
lemma tfst_eq_fst_id {α α' β} (f : α → α') (x : t α β) :
  tfst (id.mk ∘ f) x = id.mk (fst f x) :=
by simp [tfst,fst,pure_eq_id_mk_comp_id,-comp.right_id,bitraverse_eq_bimap_id]

@[higher_order]
lemma tsnd_eq_snd_id {α β β'} (f : β → β') (x : t α β) :
  tsnd (id.mk ∘ f) x = id.mk (snd f x) :=
by simp [tsnd,snd,pure_eq_id_mk_comp_id,-comp.right_id,bitraverse_eq_bimap_id]

attribute [functor_norm] comp_bitraverse comp_tsnd comp_tfst
  tsnd_comp_tsnd tsnd_comp_tfst tfst_comp_tsnd tfst_comp_tfst
  bitraverse_comp bitraverse_id_id tfst_id tsnd_id

end bitraversable


/-
Copyright (c) 2021 Junyan Xu. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Junyan Xu
-/

import topology.sheaves.sheaf_condition.pairwise_intersections

/-!
# functors between categories of sheaves

Show that the pushforward of a sheaf is a sheaf, and define
the pushforward functor from the category of C-valued sheaves
on X to that of sheaves on Y, given a continuous map between
topological spaces X and Y.

TODO: pullback for presheaves and sheaves
-/

noncomputable theory

universes v u u₁

open category_theory
open category_theory.limits
open topological_space

variables {C : Type u₁} [category.{v} C]
variables {X Y : Top.{v}} (f : X ⟶ Y)
variables ⦃ι : Type v⦄ {U : ι → opens Y}

namespace Top
namespace presheaf.sheaf_condition_pairwise_intersections

lemma map_diagram :
  pairwise.diagram U ⋙ opens.map f = pairwise.diagram ((opens.map f).obj ∘ U) :=
begin
  apply functor.hext,
  abstract obj_eq {intro i, cases i; refl},
  intros i j g, apply subsingleton.helim,
  iterate 2 {rw map_diagram.obj_eq},
end

lemma map_cocone : (opens.map f).map_cocone (pairwise.cocone U)
                     == pairwise.cocone ((opens.map f).obj ∘ U) :=
begin
  unfold functor.map_cocone cocones.functoriality, dsimp, congr,
  iterate 2 {rw map_diagram, rw opens.map_supr},
  apply subsingleton.helim, rw [map_diagram, opens.map_supr],
  apply proof_irrel_heq,
end

theorem pushforward_sheaf_of_sheaf {F : presheaf C X}
  (h : F.is_sheaf_pairwise_intersections) :
  (f _* F).is_sheaf_pairwise_intersections :=
λ ι U, begin
  convert h ((opens.map f).obj ∘ U) using 2,
  rw ← map_diagram, refl,
  change F.map_cone ((opens.map f).map_cocone _).op == _,
  congr, iterate 2 {rw map_diagram}, apply map_cocone,
end

end presheaf.sheaf_condition_pairwise_intersections

namespace sheaf

open presheaf

variables [has_products.{v} C]

/--
The pushforward of a sheaf (by a continuous map) is a sheaf.
-/
theorem pushforward_sheaf_of_sheaf
  {F : presheaf C X} (h : F.is_sheaf) : (f _* F).is_sheaf :=
by rw is_sheaf_iff_is_sheaf_pairwise_intersections at h ⊢;
   exact sheaf_condition_pairwise_intersections.pushforward_sheaf_of_sheaf f h

/--
The pushforward functor.
-/
def pushforward (f : X ⟶ Y) : X.sheaf C ⥤ Y.sheaf C :=
{ obj := λ ℱ, ⟨f _* ℱ.1, pushforward_sheaf_of_sheaf f ℱ.2⟩,
  map := λ _ _, pushforward_map f }

end sheaf

end Top