import lib.lib order.bounded_order

universe u

open_locale logic_symbol

class intuitionistic_logic {F : Sort*} [has_logic_symbol F] (P : F → Prop) :=
(modus_ponens {p q : F} : P (p ⟶ q) → P p → P q)
(imply₁ {p q : F} : P (p ⟶ q ⟶ p))
(imply₂ {p q r : F} : P ((p ⟶ q ⟶ r) ⟶ (p ⟶ q) ⟶ p ⟶ r))
(conj₁ {p q : F} : P (p ⊓ q ⟶ p))
(conj₂ {p q : F} : P (p ⊓ q ⟶ q))
(conj₃ {p q : F} : P (p ⟶ q ⟶ p ⊓ q))
(disj₁ {p q : F} : P (p ⟶ p ⊔ q))
(disj₂ {p q : F} : P (q ⟶ p ⊔ q))
(disj₃ {p q r : F} : P ((p ⟶ r) ⟶ (q ⟶ r) ⟶ p ⊔ q ⟶ r))
(neg₁ {p q : F} : P ((p ⟶ q) ⟶ (p ⟶ ∼q) ⟶ ∼p))
(neg₂ {p q : F} : P (p ⟶ ∼p ⟶ q))
(provable_top : P ⊤)
(bot_eq : (⊥ : F) = ∼⊤)

class classical_logic {F : Sort*} [has_logic_symbol F] (P : set F) :=
(modus_ponens {p q : F} : p ⟶ q ∈ P → p ∈ P → q ∈ P)
(imply₁ {p q : F} : p ⟶ q ⟶ p ∈ P)
(imply₂ {p q r : F} : (p ⟶ q ⟶ r) ⟶ (p ⟶ q) ⟶ p ⟶ r ∈ P)
(contraposition {p q : F} : (∼p ⟶ ∼q) ⟶ q ⟶ p ∈ P)
(provable_top : ⊤ ∈ P)
(bot_eq : (⊥ : F) = ∼⊤)
(and_def {p q : F} : p ⊓ q = ∼(p ⟶ ∼q))
(or_def {p q : F} : p ⊔ q = ∼p ⟶ q)

attribute [simp] classical_logic.imply₁ classical_logic.imply₂ classical_logic.contraposition
  classical_logic.provable_top

class axiomatic_classical_logic' (F : Sort*) [has_logic_symbol F] extends has_turnstile F :=
(classical {T : set F} : classical_logic ((⊢) T : F → Prop))
(by_axiom {T : set F} {p : F} : p ∈ T → T ⊢ p)

class axiomatic_classical_logic (F : Sort*) [has_logic_symbol F] extends axiomatic_classical_logic' F :=
(deduction' {T : set F} {p q : F} : insert p T ⊢ q → T ⊢ p ⟶ q)
(weakening {T : set F} {U : set F} {p : F} : T ⊆ U → T ⊢ p → U ⊢ p)

namespace classical_logic

variables {F : Type*} [has_logic_symbol F]
  (P : set F) (T : set F) [CL : classical_logic P]
include CL

@[simp] lemma neg_top_eq : (∼⊤ : F) = ⊥ := eq.symm (bot_eq P)

variables {P}

@[simp] lemma not_top_eq_bot : (∼⊤ : F) = ⊥ := eq.symm (classical_logic.bot_eq P)

local infixl ` ⨀ `:90 := modus_ponens

@[simp] lemma refl (p : F) : p ⟶ p ∈ P :=
begin
  have l₀ : (p ⟶ (p ⟶ p) ⟶ p) ⟶ (p ⟶ p ⟶ p) ⟶ p ⟶ p ∈ P, simp,
  have l₁ : p ⟶ (p ⟶ p) ⟶ p ∈ P, simp,
  have l₂ : (p ⟶ p ⟶ p) ⟶ p ⟶ p ∈ P, refine l₀ ⨀ l₁,
  have l₃ : p ⟶ p ⟶ p ∈ P, simp,
  simp[set.mem_def],
  refine l₂ ⨀ l₃
end

variables {T}

@[simp] lemma hyp_right {p : F} (h : p ∈ P) (q) : q ⟶ p ∈ P :=
by { have : p ⟶ q ⟶ p ∈ P, simp, exact this ⨀ h }

@[simp] lemma T_hyp_eliminate {p} : ⊤ ⟶ p ∈ P ↔ p ∈ P :=
⟨λ h, by { have : ⊤ ∈ P, simp, exact h ⨀ this }, λ h, by simp[h]⟩

lemma modus_ponens_hyp {p q r : F} (hqr : p ⟶ q ⟶ r ∈ P) (hq : p ⟶ q ∈ P) : p ⟶ r ∈ P :=
by { have : (p ⟶ q ⟶ r) ⟶ (p ⟶ q) ⟶ p ⟶ r ∈ P, simp, exact this ⨀ hqr ⨀ hq }

local infixl ` ⨀₁ `:90 := modus_ponens_hyp

lemma modus_ponens_hyp₂ {p q r s : F} (hqr : p ⟶ q ⟶ r ⟶ s ∈ P) (hq : p ⟶ q ⟶ r ∈ P) : p ⟶ q ⟶ s ∈ P :=
by { have : p ⟶ (q ⟶ r ⟶ s) ⟶ (q ⟶ r) ⟶ q ⟶ s ∈ P, simp, exact this ⨀₁ hqr ⨀₁ hq }

local infixl ` ⨀₂ `:90 := modus_ponens_hyp₂

lemma modus_ponens_hyp₃ {p q r s t : F} (hqr : p ⟶ q ⟶ r ⟶ s ⟶ t ∈ P) (hq : p ⟶ q ⟶ r ⟶ s ∈ P) : p ⟶ q ⟶ r ⟶ t ∈ P :=
by { have : p ⟶ q ⟶ (r ⟶ s ⟶ t) ⟶ (r ⟶ s) ⟶ r ⟶ t ∈ P, simp, exact this ⨀₂ hqr ⨀₂ hq }

local infixl ` ⨀₃ `:90 := modus_ponens_hyp₃

lemma impl_trans {p q r : F} : (p ⟶ q ∈ P) → (q ⟶ r ∈ P) → (p ⟶ r ∈ P) := λ h₁ h₂,
begin
  have l₁ : (p ⟶ q ⟶ r) ⟶ (p ⟶ q) ⟶ (p ⟶ r) ∈ P, simp,
  have l₂ : (p ⟶ q ⟶ r) ∈ P, simp[h₂],
  have l₃ : (p ⟶ q) ⟶ (p ⟶ r) ∈ P, from l₁ ⨀ l₂,
  exact l₃ ⨀ h₁
end

@[simp] lemma imply₁' {p q r : F} : p ⟶ q ⟶ r ⟶ p ∈ P :=
begin
  have lmm₁ : p ⟶ q ⟶ p ⟶ r ⟶ p ∈ P, simp,
  have lmm₂ : p ⟶ q ⟶ p ∈ P, simp,
  exact lmm₁ ⨀₂ lmm₂
end

@[simp] lemma dne (p : F) : ∼∼p ⟶ p ∈ P :=
begin
  have lmm₁ : ∼∼p ⟶ (∼∼∼∼p ⟶ ∼∼p) ⟶ ∼p ⟶ ∼∼∼p ∈ P, simp,
  have lmm₂ : ∼∼p ⟶ ∼∼∼∼p ⟶ ∼∼p ∈ P, simp,
  have lmm₃ : ∼∼p ⟶ (∼p ⟶ ∼∼∼p) ⟶ ∼∼p ⟶ p ∈ P, simp,
  have lmm₄ : ∼∼p ⟶ ∼p ⟶ ∼∼∼p ∈ P, from lmm₁ ⨀₁ lmm₂,
  have lmm₅ : ∼∼p ⟶ ∼∼p ⟶ p ∈ P, from lmm₃ ⨀₁ lmm₄,
  have lmm₆ : ∼∼p ⟶ ∼∼p ∈ P, simp,
  exact lmm₅ ⨀₁ lmm₆
end

@[simp] lemma dni (p : F) : p ⟶ ∼∼p ∈ P :=
by { have : (∼∼∼p ⟶ ∼p) ⟶ p ⟶ ∼∼p ∈ P, simp, exact this ⨀ (by simp) }

@[simp] lemma dn_iff {p : F} : ∼∼p ∈ P ↔ p ∈ P :=
⟨λ h, (show ∼∼p ⟶ p ∈ P, by simp) ⨀ h, λ h, (show p ⟶ ∼∼p ∈ P, by simp) ⨀ h⟩

@[simp] lemma dn1_iff {p q : F} : (∼∼p ⟶ q ∈ P) ↔ (p ⟶ q ∈ P) :=
⟨impl_trans (dni _), impl_trans (dne _)⟩

@[simp] lemma dn2_iff {p q : F} : (p ⟶ ∼∼q ∈ P) ↔ (p ⟶ q ∈ P) :=
⟨λ h, impl_trans h (dne _), λ h, impl_trans h (dni _)⟩

lemma explosion {p : F} (h₁ : p ∈ P) (h₂ : ∼p ∈ P) {q : F} : q ∈ P :=
begin
  have : ∼p ⟶ ∼q ⟶ ∼p ∈ P, simp,
  have : ∼q ⟶ ∼p ∈ P, from this ⨀ h₂,
  have : p ⟶ q ∈ P, from (show (∼q ⟶ ∼p) ⟶ p ⟶ q ∈ P, by simp) ⨀ this,
  exact this ⨀ h₁
end

lemma explosion_hyp {p q : F} (h₁ : p ⟶ q ∈ P) (h₂ : p ⟶ ∼q ∈ P) {r : F} : p ⟶ r ∈ P :=
begin
  have : p ⟶ ∼q ⟶ ∼r ⟶ ∼q ∈ P, simp,
  have : p ⟶ ∼r ⟶ ∼q ∈ P, from this ⨀₁ h₂,
  have : p ⟶ q ⟶ r ∈ P, from (show p ⟶ (∼r ⟶ ∼q) ⟶ q ⟶ r ∈ P, by simp) ⨀₁ this,
  exact this ⨀₁ h₁
end

lemma explosion_hyp₂ {p q r : F} (h₁ : p ⟶ q ⟶ r ∈ P) (h₂ : p ⟶ q ⟶ ∼r ∈ P) {s : F} : p ⟶ q ⟶ s ∈ P :=
begin
  have : p ⟶ q ⟶ ∼r ⟶ ∼s ⟶ ∼r ∈ P, simp,
  have : p ⟶ q ⟶ ∼s ⟶ ∼r ∈ P, from this ⨀₂ h₂,
  have : p ⟶ q ⟶ r ⟶ s ∈ P, from (show p ⟶ q ⟶ (∼s ⟶ ∼r) ⟶ r ⟶ s ∈ P, by simp) ⨀₂ this,
  exact this ⨀₂ h₁
end

@[simp] lemma hyp_bot (p : F) : ⊥ ⟶ p ∈ P :=
explosion_hyp (show (⊥ ⟶ ⊤ : F) ∈ P, by simp) (show (⊥ : F) ⟶ ∼⊤ ∈ P, by simp[neg_top_eq P])

lemma contrapose {p q : F} : (∼p ⟶ ∼q ∈ P) ↔ (q ⟶ p ∈ P) :=
⟨λ h, (show (∼p ⟶ ∼q) ⟶ q ⟶ p ∈ P, by simp) ⨀ h, λ h,
  by { have : ∼∼q ⟶ p ∈ P, from impl_trans (show ∼∼q ⟶ q ∈ P, by simp) h,
       exact (show (∼∼q ⟶ ∼∼p) ⟶ ∼p ⟶ ∼q ∈ P, by simp) ⨀ (impl_trans this (show p ⟶ ∼∼p ∈ P, by simp)) }⟩

lemma neg_hyp {p : F} (h : p ⟶ ∼p ∈ P) : ∼p ∈ P :=
begin
  have : p ⟶ ∼(p ⟶ ∼p) ∈ P,
  { have lmm₁ : p ⟶ p ∈ P, { simp }, exact explosion_hyp lmm₁ h },
  have : (p ⟶ ∼p) ⟶ ∼p ∈ P, from impl_trans (dni _) (contrapose.mpr this),
  exact this ⨀ h
end

lemma raa {p : F} (q : F) (h₁ : p ⟶ q ∈ P) (h₂ : p ⟶ ∼q ∈ P) : ∼p ∈ P :=
neg_hyp (explosion_hyp h₁ h₂)

@[simp] lemma and_left (p q : F) : p ⊓ q ⟶ p ∈ P :=
begin
  simp[and_def P],
  have : ∼p ⟶ p ⟶ ∼q ∈ P, from explosion_hyp₂ (show ∼p ⟶ p ⟶ p ∈ P, by simp) (show ∼p ⟶ p ⟶ ∼p ∈ P, by simp),
  have : ∼(p ⟶ ∼q) ⟶ ∼∼p ∈ P, from contrapose.mpr this,
  simp* at*
end

@[simp] lemma and_right (p q : F) : p ⊓ q ⟶ q ∈ P :=
begin
  simp[and_def P],
  have : ∼q ⟶ p ⟶ ∼q ∈ P, simp,
  have : ∼(p ⟶ ∼q) ⟶ q ∈ P, from impl_trans (contrapose.mpr this) (by simp),
  exact this
end

@[simp] lemma and_inply_left {p₁ p₂ q : F} : (p₁ ⟶ q) ⟶ p₁ ⊓ p₂ ⟶ q ∈ P :=
(show (p₁ ⟶ q) ⟶ p₁ ⊓ p₂ ⟶ p₁ ⟶ q ∈ P, by simp) ⨀₂ (show (p₁ ⟶ q) ⟶ p₁ ⊓ p₂ ⟶ p₁ ∈ P, by simp)

lemma and_imply_of_imply_left {p₁ p₂ q : F} (h : p₁ ⟶ q ∈ P) : p₁ ⊓ p₂ ⟶ q ∈ P :=
(show (p₁ ⟶ q) ⟶ p₁ ⊓ p₂ ⟶ q ∈ P, by simp) ⨀ h

@[simp] lemma and_imply_right {p₁ p₂ q : F} : (p₂ ⟶ q) ⟶ p₁ ⊓ p₂ ⟶ q ∈ P :=
(show (p₂ ⟶ q) ⟶ p₁ ⊓ p₂ ⟶ p₂ ⟶ q ∈ P, by simp) ⨀₂ (show (p₂ ⟶ q) ⟶ p₁ ⊓ p₂ ⟶ p₂ ∈ P, by simp)

lemma and_imply_of_imply_right {p₁ p₂ q : F} (h : p₂ ⟶ q ∈ P) : p₁ ⊓ p₂ ⟶ q ∈ P :=
(show (p₂ ⟶ q) ⟶ p₁ ⊓ p₂ ⟶ q ∈ P, by simp) ⨀ h

@[simp] lemma iff_and_p {p q : F} : (p ⊓ q ∈ P) ↔ (p ∈ P ∧ q ∈ P) :=
⟨λ h, by { split,
   { exact modus_ponens (show p ⊓ q ⟶ p ∈ P, by simp) h },
   { exact modus_ponens (show p ⊓ q ⟶ q ∈ P, by simp) h } },
 λ h, by { simp[and_def P], rcases h with ⟨h₁, h₂⟩,
   have : (p ⟶ ∼q) ⟶ ∼q ∈ P, from (show (p ⟶ ∼q) ⟶ p ⟶ ∼q ∈ P, by simp) ⨀₁ (by simp[h₁]),
   have : q ⟶ ∼(p ⟶ ∼q) ∈ P, from impl_trans (dni _) (contrapose.mpr this),
   exact modus_ponens this h₂ }⟩

@[simp] lemma conjunction_iff {n} {p : finitary F n} : (finitary.conjunction n p ∈ P) ↔ (∀ i, p i ∈ P) :=
by { induction n with n IH; simp*,
     { split,
       { rintros h i, refine fin.last_cases _ _ i; simp[h] },
       { intros h, simp[h] } } }

@[simp] lemma list_conjunction_iff {l : list F} : (l.conjunction ∈ P) ↔ (∀ p ∈ l, p ∈ P) :=
by induction l with a l IH; simp*

lemma iff_equiv_p {p q : F} : (p ⟷ q ∈ P) ↔ (p ⟶ q ∈ P ∧ q ⟶ p ∈ P) :=
by simp[lrarrow_def, iff_and_p]

lemma iff_of_equiv {p q : F} (h : p ⟷ q ∈ P) : p ∈ P ↔ q ∈ P :=
by { simp[iff_equiv_p] at h, refine ⟨λ hp, h.1 ⨀ hp, λ hq, h.2 ⨀ hq⟩ }

lemma of_equiv {p₁ p₂ : F} (h : p₁ ∈ P) (hp : p₁ ⟷ p₂ ∈ P) : p₂ ∈ P :=
by { simp[iff_equiv_p] at hp, refine hp.1 ⨀ h }

lemma equiv_imply_of_equiv {p₁ q₁ p₂ q₂ : F} (hp : p₁ ⟷ p₂ ∈ P) (hq : q₁ ⟷ q₂ ∈ P) : (p₁ ⟶ q₁) ⟷ (p₂ ⟶ q₂) ∈ P :=
begin
  simp[iff_equiv_p] at*, split,
  { have : (p₁ ⟶ q₁) ⟶ p₂ ⟶ q₁ ∈ P, from (show (p₁ ⟶ q₁) ⟶ p₂ ⟶ p₁ ⟶ q₁ ∈ P, by simp) ⨀₂ (by simp[hp]),
    exact (show (p₁ ⟶ q₁) ⟶ p₂ ⟶ q₁ ⟶ q₂ ∈ P, by simp[hq]) ⨀₂ this },
  { have : (p₂ ⟶ q₂) ⟶ p₁ ⟶ q₂ ∈ P, from (show (p₂ ⟶ q₂) ⟶ p₁ ⟶ p₂ ⟶ q₂ ∈ P, by simp) ⨀₂ (by simp[hp]),
    exact (show (p₂ ⟶ q₂) ⟶ p₁ ⟶ q₂ ⟶ q₁ ∈ P, by simp[hq]) ⨀₂ this }
end

lemma imply_of_equiv {p₁ q₁ p₂ q₂ : F} (h : p₁ ⟶ q₁ ∈ P) (hp : p₁ ⟷ p₂ ∈ P) (hq : q₁ ⟷ q₂ ∈ P) : p₂ ⟶ q₂ ∈ P :=
by { have : (p₁ ⟶ q₁) ⟶ p₂ ⟶ q₂ ∈ P ∧ (p₂ ⟶ q₂) ⟶ p₁ ⟶ q₁ ∈ P, from iff_equiv_p.mp (equiv_imply_of_equiv hp hq),
     exact this.1 ⨀ h }

lemma equiv_neg_of_equiv {p₁ p₂ : F} (hp : p₁ ⟷ p₂ ∈ P) : ∼p₁ ⟷ ∼p₂ ∈ P :=
by simp[iff_equiv_p, contrapose] at*; simp[hp]

lemma neg_of_equiv {p₁ p₂ : F} (h : ∼p₁ ∈ P) (hp : p₁ ⟷ p₂ ∈ P) : ∼p₂ ∈ P :=
by { have : ∼p₁ ⟶ ∼p₂ ∈ P, from (iff_equiv_p.mp (equiv_neg_of_equiv hp)).1, exact this ⨀ h }

lemma equiv_and_of_equiv {p₁ q₁ p₂ q₂: F} (hp : p₁ ⟷ p₂ ∈ P) (hq : q₁ ⟷ q₂ ∈ P) : p₁ ⊓ q₁ ⟷ p₂ ⊓ q₂ ∈ P :=
by { simp only [and_def P], refine equiv_neg_of_equiv (equiv_imply_of_equiv hp (equiv_neg_of_equiv hq)) }

lemma equiv_conjunction_of_equiv {n} {p₁ p₂ : finitary F n} (hp : ∀ i, p₁ i ⟷ p₂ i ∈ P) :
  finitary.conjunction n p₁ ⟷ finitary.conjunction n p₂ ∈ P :=
by { induction n with n IH; simp[- iff_equiv_p], { simp[iff_equiv_p] },
     { refine equiv_and_of_equiv (hp _) (IH _), intros i, exact hp _ } }

lemma and_of_equiv {p₁ q₁ p₂ q₂: F} (h : p₁ ⊓ q₁ ∈ P) (hp : p₁ ⟷ p₂ ∈ P) (hq : q₁ ⟷ q₂ ∈ P) : p₂ ⊓ q₂ ∈ P :=
by { have : p₁ ⊓ q₁ ⟶ p₂ ⊓ q₂ ∈ P, from (iff_equiv_p.mp (equiv_and_of_equiv hp hq)).1, exact this ⨀ h }

lemma equiv_or_of_equiv {p₁ q₁ p₂ q₂: F} (hp : p₁ ⟷ p₂ ∈ P) (hq : q₁ ⟷ q₂ ∈ P) : p₁ ⊔ q₁ ⟷ p₂ ⊔ q₂ ∈ P :=
by { simp only [or_def P], refine (equiv_imply_of_equiv (equiv_neg_of_equiv hp) hq) }

lemma or_of_equiv {p₁ q₁ p₂ q₂: F} (h : p₁ ⊔ q₁ ∈ P) (hp : p₁ ⟷ p₂ ∈ P) (hq : q₁ ⟷ q₂ ∈ P) : p₂ ⊔ q₂ ∈ P :=
by { have : p₁ ⊔ q₁ ⟶ p₂ ⊔ q₂ ∈ P, from (iff_equiv_p.mp (equiv_or_of_equiv hp hq)).1, exact this ⨀ h }

lemma equiv_equiv_of_equiv {p₁ q₁ p₂ q₂: F} (hp : p₁ ⟷ p₂ ∈ P) (hq : q₁ ⟷ q₂ ∈ P) : (p₁ ⟷ q₁) ⟷ (p₂ ⟷ q₂) ∈ P :=
by { refine (equiv_and_of_equiv (equiv_imply_of_equiv hp hq) (equiv_imply_of_equiv hq hp)) }

lemma equiv_of_equiv {p₁ q₁ p₂ q₂: F} (h : p₁ ⟷ q₁ ∈ P) (hp : p₁ ⟷ p₂ ∈ P) (hq : q₁ ⟷ q₂ ∈ P) : p₂ ⟷ q₂ ∈ P :=
by { have : (p₁ ⟷ q₁) ⟶ (p₂ ⟷ q₂) ∈ P, from (iff_equiv_p.mp (equiv_equiv_of_equiv hp hq)).1, exact this ⨀ h }

@[refl, simp] lemma equiv_refl (p : F) : p ⟷ p ∈ P := by simp[iff_equiv_p]

@[symm] lemma equiv_symm {p q : F} : p ⟷ q ∈ P → q ⟷ p ∈ P := by { simp[iff_equiv_p], intros, simp* }

@[trans] lemma equiv_trans {p q r : F} : p ⟷ q ∈ P → q ⟷ r ∈ P → p ⟷ r ∈ P :=
by { simp[iff_equiv_p], intros hpq hqp hqr hrq, exact ⟨impl_trans hpq hqr, impl_trans hrq hqp⟩ }

@[simp] lemma bot_of_neg_top : (∼⊤ : F) ⟶ ⊥ ∈ P := by simp[@not_top_eq_bot F _ P _]

@[simp] lemma neg_top : (∼⊥ : F) ∈ P := @neg_of_equiv _ _ P _ (∼⊤) _ (by simp) (by simp[iff_equiv_p])

variables (P)

@[reducible] def equiv (p q : F) : Prop := p ⟷ q ∈ P

variables {P}

@[refl, simp] lemma equiv.refl (p : F) : equiv P p p := equiv_refl p

@[symm] lemma equiv.symm {p q : F} : equiv P p q → equiv P q p := equiv_symm

@[trans] lemma equiv.trans {p q r : F} : equiv P p q → equiv P q r → equiv P p r := equiv_trans

variables (P)

theorem equiv_equivalence : equivalence (equiv P) :=
⟨equiv.refl, @equiv.symm _ _ _ _, @equiv.trans _ _ _ _⟩

variables {P}

@[simp] lemma iff_dn_refl_right (p : F) : p ⟷ ∼∼p ∈ P := by simp[iff_equiv_p]

@[simp] lemma iff_dn_refl_left (p : F) : ∼∼p ⟷ p ∈ P := by simp[iff_equiv_p]

@[simp] lemma contraposition_inv (p q : F) : (p ⟶ q) ⟶ (∼q ⟶ ∼p) ∈ P :=
by { have : (∼∼p ⟶ ∼∼q) ⟶ ∼q ⟶ ∼p ∈ P, simp,
     refine imply_of_equiv this (equiv_imply_of_equiv _ _) _; simp }

@[simp] lemma contraposition_iff (p q : F) : (p ⟶ q) ⟷ (∼q ⟶ ∼p) ∈ P :=
by simp[iff_equiv_p]

@[simp] lemma contraposition_iff₁ (p q : F) : (∼p ⟶ q) ⟷ (∼q ⟶ p) ∈ P :=
by { have : ∼p ⟶ q ⟷ ∼q ⟶ ∼∼p ∈ P, from contraposition_iff (∼p) q,
     refine equiv_of_equiv this (by simp) (equiv_imply_of_equiv (by simp) (by simp)) }

@[simp] lemma contraposition_iff₂ (p q : F) : (p ⟶ ∼q) ⟷ (q ⟶ ∼p) ∈ P :=
by { have : p ⟶ ∼q ⟷ ∼∼q ⟶ ∼p ∈ P, from contraposition_iff p (∼q),
     refine equiv_of_equiv this (by simp) (equiv_imply_of_equiv (by simp) (by simp)) }

@[simp] lemma contraposition_iff_inv (p q : F) : (∼p ⟶ ∼q) ⟷ (q ⟶ p) ∈ P :=
by simp[iff_equiv_p]

@[simp] lemma neg_hyp' (p : F) : (p ⟶ ∼p) ⟶ ∼p ∈ P :=
begin
  have : (p ⟶ ∼p) ⟶ p ⟶ ∼(p ⟶ ∼p) ∈ P,
  { have lmm₁ : (p ⟶ ∼p) ⟶ p ⟶ p ∈ P, { simp }, exact explosion_hyp₂ lmm₁ (by simp) },
  have : (p ⟶ ∼p) ⟶ ∼∼(p ⟶ ∼p) ⟶ ∼p ∈ P,
  { refine imply_of_equiv this _ _; simp[iff_equiv_p] },
  exact this ⨀₁ (show (p ⟶ ∼p) ⟶ ∼∼(p ⟶ ∼p) ∈ P, by simp)
end

@[simp] lemma neg_iff (p : F) : ∼p ⟷ (p ⟶ ⊥) ∈ P :=
begin
  simp[iff_equiv_p], split,
  { exact explosion_hyp₂ (show ∼p ⟶ p ⟶ p ∈ P, by simp) (show ∼p ⟶ p ⟶ ∼p ∈ P, by simp) },
  { have : (p ⟶ ⊥) ⟶ p ⟶ ∼p ∈ P,
      from explosion_hyp₂ (show (p ⟶ ⊥) ⟶ p ⟶ ⊤ ∈ P, by simp) (show (p ⟶ ⊥) ⟶ p ⟶ ∼⊤ ∈ P, by simp[bot_eq P]),
    refine (show (p ⟶ ⊥) ⟶ (p ⟶ ∼p) ⟶ ∼p ∈ P, by simp) ⨀₁ this }
end

@[simp] lemma imply_iff_of {p} (h : p ∈ P) (q) : (p ⟶ q) ⟷ q ∈ P :=
by simp[iff_equiv_p]; exact (show (p ⟶ q) ⟶ p ⟶ q ∈ P, by simp) ⨀₁ (by simp[h])

@[simp] lemma neg_impl_equiv_and (p q : F) : ∼(p ⟶ q) ⟷ p ⊓ ∼q ∈ P :=
by simp only [and_def P]; refine (equiv_neg_of_equiv (equiv_imply_of_equiv _ _)); simp

lemma neg_impl_iff_and_p {p q : F} : (∼(p ⟶ q) ∈ P) ↔ (p ⊓ ∼q ∈ P) :=
begin
  simp [and_def P], split; intros h,
  { refine neg_of_equiv h (equiv_imply_of_equiv _ _); simp },
  { refine neg_of_equiv h (equiv_imply_of_equiv _ _); simp }
end

@[simp] lemma impl_iff_or_p {p q : F} : (p ⟶ q) ⟷ (∼p ⊔ q) ∈ P :=
by {simp [or_def P, -iff_equiv_p], refine equiv_imply_of_equiv _ _; simp }

@[simp] lemma excluded_middle_p {p : F} : (p ⊔ ∼p) ∈ P :=
by simp[or_def P]

@[simp] lemma equiv_symm_and (p q : F) : p ⊓ q ⟷ q ⊓ p ∈ P :=
by { simp only [and_def P], refine equiv_neg_of_equiv _,
     refine equiv_of_equiv (show p ⟶ ∼q ⟷ ∼∼q ⟶ ∼p ∈ P, by simp) _ (equiv_imply_of_equiv _ _); simp }

@[simp] lemma equiv_symm_equiv (p q : F) : (p ⟷ q) ⟷ (q ⟷ p) ∈ P := equiv_symm_and _ _

@[simp] lemma equiv_or_symm (p q : F) : p ⊔ q ⟷ q ⊔ p ∈ P :=
by { simp only [or_def P],
     refine equiv_of_equiv (show ∼p ⟶ q ⟷ ∼q ⟶ ∼∼p ∈ P, by simp) _ (equiv_imply_of_equiv _ _); simp }

@[simp] lemma impl_iff_or'_p {p q : F} : (p ⟶ q) ⟷ (q ⊔ ∼p) ∈ P :=
equiv_trans (impl_iff_or_p) (by simp)

@[simp] lemma and_destruct (p q : F) : p ⟶ q ⟶ p ⊓ q ∈ P :=
by { simp only [and_def P],
     have : p ⟶ (p ⟶ ∼q) ⟶ ∼q ∈ P, from (show p ⟶ (p ⟶ ∼q) ⟶ p ⟶ ∼q ∈ P, by simp) ⨀₂ (show p ⟶ (p ⟶ ∼q) ⟶ p ∈ P, by simp),
     refine imply_of_equiv this (by simp) _,
     have : (p ⟶ ∼q) ⟶ ∼q ⟷ ∼∼q ⟶ ∼(p ⟶ ∼q) ∈ P, { simp }, refine equiv_of_equiv this _ (equiv_imply_of_equiv _ _); simp }

@[simp] lemma imply_or_left (p q : F) : p ⟶ p ⊔ q ∈ P :=
by simp[or_def P]; refine explosion_hyp₂ (show p ⟶ ∼p ⟶ p ∈ P, by simp) (show p ⟶ ∼p ⟶ ∼p ∈ P, by simp)

@[simp] lemma imply_or_right (p q : F) : q ⟶ p ⊔ q ∈ P :=
by simp[or_def P]

lemma disjunction_of {n} {p : finitary F n} (i) (h : p i ∈ P) : finitary.disjunction n p ∈ P :=
begin
  induction n with n IH; simp*,
  { exfalso, exact i.val.not_lt_zero i.property },
  { revert h, refine fin.last_cases _ _ i,
    { intros h, exact imply_or_right _ _ ⨀ h },
    { intros i h, exact imply_or_left _ _ ⨀ (IH i h) } }
end

lemma ldisj_of {l : list F} {p : F} (h : p ∈ l) (b : p ∈ P) : l.disjunction ∈ P :=
begin
  induction l with a l IH generalizing p; simp*,
  { exfalso, simp at h, contradiction },
  { simp at h, rcases h with (rfl | h),
    { exact imply_or_right _ _ ⨀ b },
    { exact imply_or_left _ _ ⨀ IH h b } }
end

lemma fdisj_of {s : finset F} {p : F} (h : p ∈ s) (b : p ∈ P) : s.disjunction ∈ P :=
by simp[finset.disjunction]; refine ldisj_of (by simpa using h) b

lemma fconj_of {s : finset F} {p : F} : s.conjunction ∈ P ↔ ∀ p ∈ s, p ∈ P:=
by simp[finset.conjunction]

@[simp] lemma imply_ldisj {l : list F} {p : F} (h : p ∈ l) : p ⟶ l.disjunction ∈ P :=
begin
  induction l with q l IH,
  { simp at h, contradiction },
  { simp at h ⊢, rcases h with (rfl| h),
    { simp },
    { refine impl_trans (IH h) (by simp) } }
end

@[simp] lemma lconj_imply {l : list F} {p : F} (h : p ∈ l) : l.conjunction ⟶ p ∈ P :=
begin
  induction l with q l IH,
  { simp at h, contradiction },
  { simp at h ⊢, rcases h with (rfl| h),
    { simp },
    { refine impl_trans (by simp) (IH h) } }
end

lemma imply_fdisj {s : finset F} {p : F} (h : p ∈ s) : p ⟶ s.disjunction ∈ P :=
by simp[finset.disjunction]; refine imply_ldisj (by simpa using h)

lemma fconj_imply {s : finset F} {p : F} (h : p ∈ s) : s.conjunction ⟶ p ∈ P :=
by simp[finset.conjunction]; refine lconj_imply (by simpa using h)

@[simp] lemma imply_and (p q r : F) : (p ⟶ q) ⟶ (p ⟶ r) ⟶ p ⟶ q ⊓ r ∈ P :=
begin
  have : (p ⟶ q) ⟶ (p ⟶ r) ⟶ p ⟶ r ⟶ q ⊓ r ∈ P,
    from (show (p ⟶ q) ⟶ (p ⟶ r) ⟶ p ⟶ q ⟶ r ⟶ q ⊓ r ∈ P, by simp) ⨀₃ (show (p ⟶ q) ⟶ (p ⟶ r) ⟶ p ⟶ q ∈ P, by simp),
  exact this ⨀₃ (show (p ⟶ q) ⟶ (p ⟶ r) ⟶ p ⟶ r ∈ P, by simp),
end

@[simp] lemma neg_and_equiv_or_neg (p q : F) : ∼(p ⊓ q) ⟷ ∼p ⊔ ∼q ∈ P :=
begin
  simp only [and_def P, or_def P],
  refine equiv_of_equiv (show p ⟶ ∼q ⟷ p ⟶ ∼q ∈ P, by simp) _ (equiv_imply_of_equiv _ _); simp
end

@[simp] lemma neg_conj_equiv_disj_neg {n} (p : finitary F n) : ∼(finitary.conjunction n p) ⟷ (⋁ i, ∼p i) ∈ P :=
begin
  induction n with n IH; simp[-iff_equiv_p],
  { simp[iff_equiv_p] },
  { have lmm₁ : ∼(p (fin.last n) ⊓ finitary.conjunction n (p ∘ fin.cast_succ)) ⟷
      ∼p (fin.last n) ⊔ ∼finitary.conjunction n (p ∘ fin.cast_succ) ∈ P, from neg_and_equiv_or_neg _ _,
    have lmm₂ : ∼p (fin.last n) ⊔ ∼finitary.conjunction n (p ∘ fin.cast_succ) ⟷
      ∼finitary.conjunction n (p ∘ fin.cast_succ) ⊔ ∼p (fin.last n) ∈ P, from equiv_or_symm _ _,
    refine equiv_of_equiv (equiv_trans lmm₁ lmm₂) (equiv_refl _) (equiv_or_of_equiv (IH (p ∘ fin.cast_succ)) (equiv_refl _)) }
end

@[simp] lemma neg_lconj_equiv_ldisj_neg (l : list F) : ∼l.conjunction ⟷ (l.map has_negation.neg).disjunction ∈ P :=
begin
  induction l with p l IH; simp[-iff_equiv_p],
  { simp[iff_equiv_p] },
  { have lmm₁ : ∼(p ⊓ l.conjunction) ⟷ ∼p ⊔ ∼l.conjunction ∈ P, from neg_and_equiv_or_neg _ _,
    have lmm₂ : ∼p ⊔ ∼l.conjunction ⟷ ∼l.conjunction ⊔ ∼p ∈ P, from equiv_or_symm _ _,
    refine equiv_of_equiv (equiv_trans lmm₁ lmm₂) (equiv_refl _)
    (equiv_or_of_equiv IH (equiv_refl _)) }
end

@[simp] lemma neg_or_equiv_and_neg (p q : F) : ∼(p ⊔ q) ⟷ ∼p ⊓ ∼q ∈ P :=
begin
  simp only [and_def P, or_def P],
  refine equiv_of_equiv (show ∼(∼p ⟶ q) ⟷ ∼(∼p ⟶ q) ∈ P, by simp) _ (equiv_neg_of_equiv (equiv_imply_of_equiv _ _)); simp
end

@[simp] lemma neg_disj_equiv_conj_neg {n} (p : finitary F n) : ∼(finitary.disjunction n p) ⟷ (⋀ i, ∼p i) ∈ P :=
begin
  induction n with n IH; simp[-iff_equiv_p],
  { simp[iff_equiv_p] },
  { have lmm₁ : ∼(finitary.disjunction n (p ∘ fin.cast_succ) ⊔ p (fin.last n)) ⟷
      ∼finitary.disjunction n (p ∘ fin.cast_succ) ⊓ ∼p (fin.last n) ∈ P, from neg_or_equiv_and_neg _ _,
    have lmm₂ : ∼finitary.disjunction n (p ∘ fin.cast_succ) ⊓ ∼p (fin.last n) ⟷
      ∼p (fin.last n) ⊓ ∼finitary.disjunction n (p ∘ fin.cast_succ) ∈ P, from equiv_symm_and _ _,
    refine equiv_of_equiv (equiv_trans lmm₁ lmm₂) (equiv_refl _) (equiv_and_of_equiv (equiv_refl _) (IH (p ∘ fin.cast_succ)))  }
end

@[simp] lemma or_imply (p q r : F) : (p ⟶ r) ⟶ (q ⟶ r) ⟶ p ⊔ q ⟶ r ∈ P :=
begin
  have : (∼r ⟶ ∼p) ⟶ (∼r ⟶ ∼q) ⟶ ∼r ⟶ ∼p ⊓ ∼q ∈ P, { simp },
  refine imply_of_equiv this (by simp) (equiv_imply_of_equiv (by simp) _),
  have : ∼r ⟶ ∼(p ⊔ q) ⟷ p ⊔ q ⟶ r ∈ P, { simp },
  refine equiv_of_equiv (show ∼r ⟶ ∼(p ⊔ q) ⟷ p ⊔ q ⟶ r ∈ P, by simp) (equiv_imply_of_equiv _ _) _; simp
end

@[simp] lemma le_sup_inf (p q r : F) : (p ⊔ q) ⊓ (p ⊔ r) ⟶ p ⊔ q ⊓ r ∈ P :=
begin
  simp[or_def P],
  exact (show (∼p ⟶ q) ⊓ (∼p ⟶ r) ⟶ (∼p ⟶ q) ⟶ (∼p ⟶ r) ⟶ ∼p ⟶ q ⊓ r ∈ P, by simp) ⨀₁
        (show (∼p ⟶ q) ⊓ (∼p ⟶ r) ⟶ (∼p ⟶ q) ∈ P, by simp) ⨀₁
        (show (∼p ⟶ q) ⊓ (∼p ⟶ r) ⟶ (∼p ⟶ r) ∈ P, by simp)
end

lemma case_of_p {p q r : F} (hpq : p ⊔ q ∈ P) (hpr : p ⟶ r ∈ P) (hqr : q ⟶ r ∈ P) : r ∈ P :=
(show (p ⟶ r) ⟶ (q ⟶ r) ⟶ p ⊔ q ⟶ r ∈ P, by simp) ⨀ hpr ⨀ hqr ⨀ hpq

@[simp] lemma and_imply_equiv_imply_imply (p q r : F) : (p ⟶ q ⟶ r) ⟷ (p ⊓ q ⟶ r) ∈ P :=
begin
  simp[iff_equiv_p], split,
  { exact (show (p ⟶ q ⟶ r) ⟶ p ⊓ q ⟶ p ⟶ q ⟶ r ∈ P, by simp) ⨀₂ (show (p ⟶ q ⟶ r) ⟶ p ⊓ q ⟶ p ∈ P, by simp) ⨀₂ (show (p ⟶ q ⟶ r) ⟶ p ⊓ q ⟶ q ∈ P, by simp) },
  { exact (show (p ⊓ q ⟶ r) ⟶ p ⟶ q ⟶ (p ⊓ q ⟶ r) ∈ P, by simp) ⨀₃ (show (p ⊓ q ⟶ r) ⟶ p ⟶ q ⟶ (p ⊓ q) ∈ P, by simp) }
end

lemma and_imply_of {p q r} : p ⊓ q ⟶ r ∈ P ↔ p ⟶ q ⟶ r ∈ P :=
(iff_of_equiv $ and_imply_equiv_imply_imply p q r).symm

@[simp] lemma imply_and_equiv_or_imply (p q r : F) : (p ⟶ r) ⊓ (q ⟶ r) ⟷ p ⊔ q ⟶ r ∈ P :=
begin
  simp[iff_equiv_p], split,
  { refine of_equiv (or_imply p q r) (and_imply_equiv_imply_imply _ _ _) },
  { have lmm₁ : (p ⊔ q ⟶ r) ⟶ p ⟶ r ∈ P, from (show (p ⊔ q ⟶ r) ⟶ p ⟶ p ⊔ q ⟶ r ∈ P, by simp) ⨀₂ (show (p ⊔ q ⟶ r) ⟶ p ⟶ p ⊔ q ∈ P, by simp),
    have lmm₂ : (p ⊔ q ⟶ r) ⟶ q ⟶ r ∈ P, from (show (p ⊔ q ⟶ r) ⟶ q ⟶ p ⊔ q ⟶ r ∈ P, by simp) ⨀₂ (show (p ⊔ q ⟶ r) ⟶ q ⟶ p ⊔ q ∈ P, by simp),
    refine imply_and _ _ _ ⨀ lmm₁ ⨀ lmm₂ }
end

@[simp] lemma conj_imply_iff_disj_imply {n} (p : finitary F n) (q : F) : (⋀ i, (p i ⟶ q)) ⟷ ((⋁ i, p i) ⟶ q) ∈ P :=
begin
  induction n with n IH, { simp[iff_equiv_p] },
  { simp[-iff_equiv_p, (∘)],
    have : (p (fin.last n) ⟶ q) ⊓ ((⋁ i, p i.cast_succ) ⟶ q) ⟷ (p (fin.last n) ⊔ ⋁ i, p i.cast_succ) ⟶ q ∈ P,
    from imply_and_equiv_or_imply (p (fin.last n)) (⋁ i, p i.cast_succ) q,
    refine equiv_of_equiv this (equiv_and_of_equiv (equiv_refl _) (equiv_symm (IH _)))
      (equiv_imply_of_equiv (equiv_or_symm _ _) (by refl)), }
end

@[simp] lemma lconj_imply_iff_ldisj_imply (l : list F) (q : F) :
  (l.map (λ p, (p ⟶ q))).conjunction ⟷ (l.disjunction ⟶ q) ∈ P :=
begin
  induction l with p l IH, { simp[iff_equiv_p] },
  { simp[-iff_equiv_p, (∘)],
    refine equiv_of_equiv (imply_and_equiv_or_imply p l.disjunction q)
      (equiv_and_of_equiv (equiv_refl _) (equiv_symm (IH)))
      (equiv_imply_of_equiv (equiv_or_symm _ _) (by refl)) }
end

@[simp] lemma imply_lconj_of {l : list F} {q : F} (h : ∀ p ∈ l, q ⟶ p ∈ P) : q ⟶ l.conjunction ∈ P :=
by { induction l with p l IH; simp,
     { simp at h, refine imply_and _ _ _ ⨀ _ ⨀ _,
       { exact h.1 },
       { exact IH h.2 } } }

@[simp] lemma ldisj_imply_of {l : list F} {q : F} (h : ∀ p ∈ l, p ⟶ q ∈ P) : l.disjunction ⟶ q ∈ P :=
by { have : (l.map (λ p, (p ⟶ q))).conjunction ∈ P, by simpa using h,
     exact (iff_equiv_p.mp $ lconj_imply_iff_ldisj_imply l q).1 ⨀ this }

@[simp] lemma imply_fconj_of {s : finset F} {q : F} (h : ∀ p ∈ s, q ⟶ p ∈ P) : q ⟶ s.conjunction ∈ P :=
by simp[finset.conjunction]; exact imply_lconj_of (by simpa using h)

@[simp] lemma fdisj_imply_of {s : finset F} {q : F} (h : ∀ p ∈ s, p ⟶ q ∈ P) : s.disjunction ⟶ q ∈ P :=
by simp[finset.disjunction]; exact ldisj_imply_of (by simpa using h)

@[simp] lemma equiv_or_assoc (p q r : F) : (p ⊔ q) ⊔ r ⟷ p ⊔ (q ⊔ r) ∈ P :=
begin
  simp[iff_equiv_p], split,
  { have l₁ : p ⟶ p ⊔ (q ⊔ r) ∈ P, from imply_or_left p (q ⊔ r),
    have l₂ : q ⟶ p ⊔ (q ⊔ r) ∈ P, from impl_trans (imply_or_left q r) (imply_or_right p (q ⊔ r)),
    have l₃ : r ⟶ p ⊔ (q ⊔ r) ∈ P, from impl_trans (imply_or_right q r) (imply_or_right p (q ⊔ r)),
    exact or_imply _ _ _ ⨀ (or_imply _ _ _ ⨀ l₁ ⨀ l₂) ⨀ l₃ },
  { have l₁ : p ⟶ (p ⊔ q) ⊔ r ∈ P, from impl_trans (imply_or_left p q) (imply_or_left (p ⊔ q) r),
    have l₂ : q ⟶ (p ⊔ q) ⊔ r ∈ P, from impl_trans (imply_or_right p q) (imply_or_left (p ⊔ q) r),
    have l₃ : r ⟶ (p ⊔ q) ⊔ r ∈ P, from imply_or_right (p ⊔ q) r,
    exact or_imply _ _ _ ⨀ l₁ ⨀ (or_imply _ _ _ ⨀ l₂ ⨀ l₃) }
end

lemma equiv_append (l₁ l₂ : list F) : (l₁ ++ l₂).disjunction ⟷ l₁.disjunction ⊔ l₂.disjunction ∈ P :=
begin
  induction l₁; simp[-iff_equiv_p],
  case nil { simp[iff_equiv_p], refine or_imply ⊥ l₂.disjunction l₂.disjunction ⨀ (hyp_bot l₂.disjunction) ⨀ (refl l₂.disjunction) },
  case cons : p l IH
  { have l₁ : (l ++ l₂).disjunction ⊔ p ⟷ l.disjunction ⊔ (l₂.disjunction ⊔ p) ∈ P,
      from equiv_trans (equiv_or_of_equiv IH (equiv_refl p)) (equiv_or_assoc l.disjunction l₂.disjunction p),
    have l₂ : l.disjunction ⊔ (l₂.disjunction ⊔ p) ⟷ l.disjunction ⊔ p ⊔ l₂.disjunction ∈ P,
      from equiv_trans (equiv_or_of_equiv (equiv_refl l.disjunction) (equiv_or_symm l₂.disjunction p))
      (equiv_symm (equiv_or_assoc _ _ _)),
    exact equiv_trans l₁ l₂ }
end

lemma fconj_insert_equiv_inf {s : finset F} {p : F} : (insert p s).conjunction ⟷ p ⊓ s.conjunction ∈ P :=
begin
  simp[iff_equiv_p], split,
  { refine imply_and _ _ _ ⨀ _ ⨀ _,
    refine fconj_imply (by simp),
    refine imply_fconj_of (by { intros q hq, refine fconj_imply (by simp[hq]) }) },
  { refine imply_fconj_of _, intros q hq, simp at hq, rcases hq with (rfl | hq),
    { simp }, { refine impl_trans (and_right _ _) (fconj_imply hq) } }
end

lemma fdisj_insert_equiv_sup {s : finset F} {p : F} : (insert p s).disjunction ⟷ s.disjunction ⊔ p ∈ P :=
begin
  simp[iff_equiv_p], split,
  { refine fdisj_imply_of _, intros q hq, simp at hq, rcases hq with (rfl | hq),
    { simp }, { refine impl_trans (imply_fdisj hq) (imply_or_left _ _) } },
  { refine or_imply _ _ _ ⨀ _ ⨀ _,
    refine fdisj_imply_of (by { intros q hq, refine imply_fdisj (by simp[hq]) }),
    refine imply_fdisj (by simp) }
end

variables (P)

def lindenbaum := quotient (⟨equiv P, equiv_equivalence P⟩ : setoid F)

variables {P}

def to_quo (p : F) : lindenbaum P := quotient.mk' p

local notation `⟦` p `⟧ᴾ` := to_quo p

namespace lindenbaum

@[elab_as_eliminator]
protected lemma ind_on {C : lindenbaum P → Prop} (d : lindenbaum P)
  (h : ∀ p : F, C (to_quo p)) : C d := quotient.induction_on' d h

@[elab_as_eliminator, reducible]
protected def lift_on {φ : Sort*} (p : lindenbaum P) (f : F → φ)
  (h : ∀ p q : F, p ⟷ q ∈ P → f p = f q) : φ := quotient.lift_on' p f h

@[simp]
protected lemma lift_on_eq {φ : Sort*} (p : F) (f : F → φ)
  (h : ∀ p q, p ⟷ q ∈ P → f p = f q) : classical_logic.lindenbaum.lift_on ⟦p⟧ᴾ f h = f p := rfl

@[elab_as_eliminator, reducible, simp]
protected def lift_on₂ {φ : Sort*} (p₁ p₂ : lindenbaum P) (f : F → F → φ)
  (h : ∀ p₁ p₂ q₁ q₂, p₁ ⟷ q₁ ∈ P → p₂ ⟷ q₂ ∈ P → f p₁ p₂ = f q₁ q₂) : φ :=
quotient.lift_on₂' p₁ p₂ f h

@[simp]
protected lemma lift_on₂_eq {φ : Sort*} (p₁ p₂ : F) (f : F → F → φ)
  (h : ∀ p₁ p₂ q₁ q₂, p₁ ⟷ q₁ ∈ P → p₂ ⟷ q₂ ∈ P → f p₁ p₂ = f q₁ q₂)  :
classical_logic.lindenbaum.lift_on₂ ⟦p₁⟧ᴾ ⟦p₂⟧ᴾ f h = f p₁ p₂ := rfl

@[elab_as_eliminator, reducible]
protected def lift_on_finitary {φ : Sort*} {n : ℕ} (v : finitary (lindenbaum P) n) (f : finitary F n → φ)
  (h : ∀ v₁ v₂ : finitary F n, (∀ n, v₁ n ⟷ v₂ n ∈ P) → f v₁ = f v₂) : φ :=
quotient.lift_on_finitary v f h

@[simp]
protected lemma lift_on_finitary_eq {φ : Sort*} {n : ℕ} (v : finitary F n) (f : finitary F n → φ)
  (h : ∀ v₁ v₂ : finitary F n, (∀ n, v₁ n ⟷ v₂ n ∈ P) → f v₁ = f v₂) :
classical_logic.lindenbaum.lift_on_finitary (λ x, ⟦v x⟧ᴾ) f h = f v :=
quotient.lift_on_finitary_eq v f h

lemma of_eq_of {p q : F} : (⟦p⟧ᴾ : lindenbaum P) = ⟦q⟧ᴾ ↔ p ⟷ q ∈ P :=
by simp[to_quo, equiv, quotient.eq']

instance : distrib_lattice (lindenbaum P) :=
{ le := λ p₁ p₂, classical_logic.lindenbaum.lift_on₂ p₁ p₂ (λ p₁ p₂, p₁ ⟶ p₂ ∈ P)
    (λ p₁ p₂ q₁ q₂ h₁ h₂,
      by { simp, exact ⟨λ h, imply_of_equiv h h₁ h₂, λ h, imply_of_equiv h (equiv_symm h₁) (equiv_symm h₂)⟩ }),
  le_refl := λ p, by induction p using classical_logic.lindenbaum.ind_on; simp,
  le_trans := λ p₁ p₂ p₃ h₁₂ h₂₃,
  by { induction p₁ using classical_logic.lindenbaum.ind_on,
       induction p₂ using classical_logic.lindenbaum.ind_on,
       induction p₃ using classical_logic.lindenbaum.ind_on,
       simp at h₁₂ h₂₃ ⊢, exact impl_trans h₁₂ h₂₃ },
  le_antisymm := λ p₁ p₂,
  by { induction p₁ using classical_logic.lindenbaum.ind_on,
       induction p₂ using classical_logic.lindenbaum.ind_on,
       simp[has_le.le], intros h₁ h₂, simp[*, of_eq_of, iff_equiv_p] },
  inf := λ p₁ p₂, classical_logic.lindenbaum.lift_on₂ p₁ p₂ (λ p₁ p₂, (⟦p₁ ⊓ p₂⟧ᴾ : lindenbaum P))
    (λ p₁ p₂ q₁ q₂ h₁ h₂, by { simp[of_eq_of], exact equiv_and_of_equiv h₁ h₂ }),
  sup := λ p₁ p₂, classical_logic.lindenbaum.lift_on₂ p₁ p₂ (λ p₁ p₂, (⟦p₁ ⊔ p₂⟧ᴾ : lindenbaum P))
    (λ p₁ p₂ q₁ q₂ h₁ h₂, by { simp[of_eq_of], exact equiv_or_of_equiv h₁ h₂ }),
  le_sup_left := λ p q,
  by { induction p using classical_logic.lindenbaum.ind_on,
       induction q using classical_logic.lindenbaum.ind_on,
       simp[has_le.le, preorder.le] },
  le_sup_right := λ p q,
  by { induction p using classical_logic.lindenbaum.ind_on,
       induction q using classical_logic.lindenbaum.ind_on,
       simp[has_le.le, preorder.le] },
  sup_le := λ p q r,
  by { induction p using classical_logic.lindenbaum.ind_on,
       induction q using classical_logic.lindenbaum.ind_on,
       induction r using classical_logic.lindenbaum.ind_on,
       simp[has_le.le, preorder.le],
       intros hpr hqr, exact (show (p ⟶ r) ⟶ (q ⟶ r) ⟶ p ⊔ q ⟶ r ∈ P, by simp) ⨀ hpr ⨀ hqr },
  inf_le_left := λ p q,
  by { induction p using classical_logic.lindenbaum.ind_on,
       induction q using classical_logic.lindenbaum.ind_on,
       simp[has_le.le, preorder.le] },
  inf_le_right := λ p q,
  by { induction p using classical_logic.lindenbaum.ind_on,
       induction q using classical_logic.lindenbaum.ind_on,
       simp[has_le.le, preorder.le] },
  le_inf := λ p q r,
  by { induction p using classical_logic.lindenbaum.ind_on,
       induction q using classical_logic.lindenbaum.ind_on,
       induction r using classical_logic.lindenbaum.ind_on,
       simp[has_le.le, preorder.le],
       intros hpq hpr, exact (show (p ⟶ q) ⟶ (p ⟶ r) ⟶ p ⟶ q ⊓ r ∈ P, by simp) ⨀ hpq ⨀ hpr },
  le_sup_inf := λ p q r,
  by { induction p using classical_logic.lindenbaum.ind_on,
       induction q using classical_logic.lindenbaum.ind_on,
       induction r using classical_logic.lindenbaum.ind_on,
       simp[has_le.le, preorder.le, partial_order.le, semilattice_inf.le,
         has_sup.sup, semilattice_sup.sup, has_inf.inf, semilattice_inf.inf] } }

instance : has_compl (lindenbaum P) := ⟨λ p, classical_logic.lindenbaum.lift_on p (λ p, (⟦∼p⟧ᴾ : lindenbaum P))
    (λ p q h, by { simp[of_eq_of], exact equiv_neg_of_equiv h })⟩

lemma le_def (p q : F) : (⟦p⟧ᴾ : lindenbaum P) ≤ ⟦q⟧ᴾ ↔ p ⟶ q ∈ P := by refl

lemma neg_def (p : F) : (⟦p⟧ᴾ : lindenbaum P)ᶜ = ⟦∼p⟧ᴾ := rfl

lemma inf_def (p q : F) : (⟦p⟧ᴾ : lindenbaum P) ⊓ ⟦q⟧ᴾ = ⟦p ⊓ q⟧ᴾ := rfl

lemma sup_def (p q : F) : (⟦p⟧ᴾ : lindenbaum P) ⊔ ⟦q⟧ᴾ = ⟦p ⊔ q⟧ᴾ := rfl

instance : boolean_algebra (lindenbaum P) :=
{ top := ⟦⊤⟧ᴾ,
  bot := ⟦⊥⟧ᴾ,
  le_top := λ p, by induction p using classical_logic.lindenbaum.ind_on; simp[le_def],
  bot_le := λ p, by induction p using classical_logic.lindenbaum.ind_on; simp[le_def],
  compl := has_compl.compl,
  inf_compl_le_bot := λ p,
  by { induction p using classical_logic.lindenbaum.ind_on, simp[bounded_order.bot],
       refine explosion_hyp (show p ⊓ ∼p ⟶ p ∈ P, by simp) (by simp) },
  top_le_sup_compl := λ p,
  by { induction p using classical_logic.lindenbaum.ind_on,
       simp[bounded_order.top, or_def P, le_def, sup_def, neg_def] },
  ..lindenbaum.distrib_lattice }

lemma top_def : (⊤ : lindenbaum P) = ⟦⊤⟧ᴾ := rfl

lemma bot_def : (⊥ : lindenbaum P) = ⟦⊥⟧ᴾ := rfl

lemma imply_eq (p q : F) : (⟦p ⟶ q⟧ᴾ : lindenbaum P) = ⟦p⟧ᴾ ⇨ ⟦q⟧ᴾ:=
by simp[of_eq_of, himp_eq, neg_def, sup_def]

lemma fconj_eq (s : finset F) : (⟦s.conjunction⟧ᴾ : lindenbaum P) = s.inf to_quo :=
begin
  induction s using finset.induction_on with p s hs IH,
  { simp, refl },
  { simp, rw[←IH, inf_def, of_eq_of], exact fconj_insert_equiv_inf }
end

lemma fdisj_eq (s : finset F) : (⟦s.disjunction⟧ᴾ : lindenbaum P) = s.sup to_quo :=
begin
  induction s using finset.induction_on with p s hs IH,
  { simp, refl },
  { simp, rw[sup_comm, ←IH, sup_def, of_eq_of], exact fdisj_insert_equiv_sup }
end

end lindenbaum

open lindenbaum

lemma equiv_of_lindenbaum {p q : F} : p ⟷ q ∈ P ↔ (⟦p⟧ᴾ : lindenbaum P) = ⟦q⟧ᴾ :=
lindenbaum.of_eq_of.symm

lemma fdisj_insert_equiv_fconj_imply (p : F) (s : finset F) :
  (insert p s).disjunction ⟷ ((s.image has_negation.neg).conjunction ⟶ p) ∈ P :=
by simp [equiv_of_lindenbaum, fdisj_eq, fconj_eq, imply_eq, himp_eq, ←neg_def, finset.sup_finset_image, (∘)]

lemma fconj_imply_equiv_fdisj_neg (p : F) (s : finset F) :
  (s.conjunction ⟶ p) ⟷ (insert p (s.image has_negation.neg)).disjunction ∈ P :=
by simp [equiv_of_lindenbaum, fdisj_eq, fconj_eq, imply_eq, himp_eq, ←neg_def, finset.sup_finset_image, (∘)]

@[simp] lemma neg_bot_equiv_top : (∼⊥ : F) ⟷ ⊤ ∈ P :=
by simp[equiv_of_lindenbaum, ←neg_def, ←top_def, ←bot_def]

end classical_logic

namespace axiomatic_classical_logic'
open classical_logic
variables {F : Type*} [has_logic_symbol F]
  (T : set F) [axiomatic_classical_logic' F]

instance : classical_logic ((⊢) T) := axiomatic_classical_logic'.classical

variables {T}

lemma modus_ponens {p q : F} : T ⊢ p ⟶ q → T ⊢ p → T ⊢ q := modus_ponens

lemma modus_ponens_hyp {p q r : F} : T ⊢ p ⟶ q ⟶ r → T ⊢ p ⟶ q → T ⊢ p ⟶ r :=
modus_ponens_hyp

lemma modus_ponens_hyp₂ {p q r s : F} : T ⊢ p ⟶ q ⟶ r ⟶ s → T ⊢ p ⟶ q ⟶ r → T ⊢ p ⟶ q ⟶ s :=
modus_ponens_hyp₂

lemma modus_ponens_hyp₃ {p q r s t : F} :
  T ⊢ p ⟶ q ⟶ r ⟶ s ⟶ t → T ⊢ p ⟶ q ⟶ r ⟶ s → T ⊢ p ⟶ q ⟶ r ⟶ t :=
modus_ponens_hyp₃

localized "infixl ` ⨀ `:90 := axiomatic_classical_logic'.modus_ponens" in aclogic
localized "infixl ` ⨀₁ `:90 := axiomatic_classical_logic'.modus_ponens_hyp" in aclogic
localized "infixl ` ⨀₂ `:90 := axiomatic_classical_logic'.modus_ponens_hyp₂" in aclogic
localized "infixl ` ⨀₃ `:90 := axiomatic_classical_logic'.modus_ponens_hyp₃" in aclogic

open_locale aclogic

@[simp] lemma mem_iff_prov (p : F) : (@has_mem.mem F (set F) _) p ((⊢) T : set F) ↔ T ⊢ p := by refl

@[simp] lemma imply₁ (p q : F) : T ⊢ p ⟶ q ⟶ p := imply₁

@[simp] lemma imply₂ (p q r : F) : T ⊢ (p ⟶ q ⟶ r) ⟶ (p ⟶ q) ⟶ p ⟶ r := imply₂

lemma imply_trans {p q r : F} : (T ⊢ p ⟶ q) → (T ⊢ q ⟶ r) → (T ⊢ p ⟶ r) :=
impl_trans

@[simp] lemma contraposition (p q : F) : T ⊢ (∼p ⟶ ∼q) ⟶ q ⟶ p := contraposition

@[simp] lemma provable_top : T ⊢ (⊤ : F) := provable_top

@[simp] lemma refl (p : F) : T ⊢ p ⟶ p := classical_logic.refl p

@[simp] lemma hyp_right {p : F} (h : T ⊢ p) (q) : T ⊢ q ⟶ p := hyp_right h q

@[simp] lemma T_hyp_eliminate {p : F} : T ⊢ ⊤ ⟶ p ↔ T ⊢ p := T_hyp_eliminate

@[simp] lemma dne (p : F) : T ⊢ ∼∼p ⟶ p := dne p

@[simp] lemma imply₁' {p q r : F} : T ⊢ p ⟶ q ⟶ r ⟶ p := imply₁'

@[simp] lemma dni (p : F) : T ⊢ p ⟶ ∼∼p := dni p

@[simp] lemma dn_iff {p : F} : T ⊢ ∼∼p ↔ T ⊢ p := dn_iff

@[simp] lemma dn1_iff {p q : F} : T ⊢ ∼∼p ⟶ q ↔ T ⊢ p ⟶ q := dn1_iff

@[simp] lemma dn2_iff {p q : F} : T ⊢ p ⟶ ∼∼q ↔ T ⊢ p ⟶ q := dn2_iff

@[simp] lemma hyp_bot (p : F) : T ⊢ ⊥ ⟶ p := hyp_bot p

@[simp] lemma and_left (p q : F) : T ⊢ p ⊓ q ⟶ p := and_left p q

@[simp] lemma and_right (p q : F) : T ⊢ p ⊓ q ⟶ q := and_right p q

@[simp] lemma iff_and {p q : F} : T ⊢ p ⊓ q ↔ (T ⊢ p ∧ T ⊢ q) := iff_and_p

@[simp] lemma conjunction_iff {n} {p : finitary F n} : (T ⊢ finitary.conjunction n p) ↔ (∀ i, T ⊢ p i) :=
conjunction_iff

lemma iff_equiv {p q : F} : T ⊢ p ⟷ q ↔ (T ⊢ p ⟶ q ∧ T ⊢ q ⟶ p) := iff_equiv_p

lemma equiv_mp {p q : F} (h : T ⊢ p ⟷ q) : T ⊢ p ⟶ q := (iff_equiv.mp h).1

lemma equiv_mpr {p q : F} (h : T ⊢ p ⟷ q) : T ⊢ q ⟶ p := (iff_equiv.mp h).2

lemma iff_of_equiv {p q : F} (h : T ⊢ p ⟷ q) : T ⊢ p ↔ T ⊢ q := iff_of_equiv h

@[refl, simp] lemma equiv_refl (p : F) : T ⊢ p ⟷ p := equiv_refl p

@[symm] lemma equiv_symm {p q : F} : T ⊢ p ⟷ q → T ⊢ q ⟷ p := equiv_symm

@[trans] lemma equiv_trans {p q r : F} : T ⊢ p ⟷ q → T ⊢ q ⟷ r → T ⊢ p ⟷ r := equiv_trans

@[simp] lemma iff_dn_refl_right (p : F) : T ⊢ p ⟷ ∼∼p := iff_dn_refl_right p

@[simp] lemma iff_dn_refl_left (p : F) : T ⊢ ∼∼p ⟷ p := iff_dn_refl_left p

@[simp] lemma contraposition_inv (p q : F) : T ⊢ (p ⟶ q) ⟶ (∼q ⟶ ∼p) := contraposition_inv p q

@[simp] lemma contraposition_iff (p q : F) : T ⊢ (p ⟶ q) ⟷ (∼q ⟶ ∼p) := contraposition_iff p q

@[simp] lemma contraposition_iff₁ (p q : F) : T ⊢ (∼p ⟶ q) ⟷ (∼q ⟶ p) := contraposition_iff₁ _ _

@[simp] lemma contraposition_iff₂ (p q : F) : T ⊢ (p ⟶ ∼q) ⟷ (q ⟶ ∼p) := contraposition_iff₂ _ _

@[simp] lemma contraposition_iff_inv (p q : F) : T ⊢ (∼p ⟶ ∼q) ⟷ (q ⟶ p) := contraposition_iff_inv p q

@[simp] lemma neg_hyp' (p : F) : T ⊢ (p ⟶ ∼p) ⟶ ∼p := neg_hyp' p

@[simp] lemma neg_iff (p : F) : T ⊢ ∼p ⟷ (p ⟶ ⊥) := neg_iff p

@[simp] lemma imply_iff_of {p} (h : T ⊢ p) (q) : T ⊢ (p ⟶ q) ⟷ q := imply_iff_of h q

@[simp] lemma neg_impl_equiv_and (p q : F) : T ⊢ ∼(p ⟶ q) ⟷ p ⊓ ∼q := neg_impl_equiv_and p q

lemma neg_impl_iff_and {p q : F} : T ⊢ ∼(p ⟶ q) ↔ T ⊢ p ⊓ ∼q := neg_impl_iff_and_p

lemma of_equiv {p₁ p₂ : F} (h : T ⊢ p₁) (hp : T ⊢ p₁ ⟷ p₂) : T ⊢ p₂ := of_equiv h hp

@[simp] lemma impl_iff_or {p q : F} : T ⊢ (p ⟶ q) ⟷ (∼p ⊔ q) := impl_iff_or_p

@[simp] lemma impl_iff_or' {p q : F} : T ⊢ (p ⟶ q) ⟷ (q ⊔ ∼p) := impl_iff_or'_p

@[simp] lemma excluded_middle {p : F} : T ⊢ p ⊔ ∼p := excluded_middle_p

@[simp] lemma equiv_symm_and (p q : F) : T ⊢ p ⊓ q ⟷ q ⊓ p := equiv_symm_and p q

@[simp] lemma equiv_symm_equiv (p q : F) : T ⊢ (p ⟷ q) ⟷ (q ⟷ p) := equiv_symm_equiv p q

@[simp] lemma equiv_or_symm (p q : F) : T ⊢ p ⊔ q ⟷ q ⊔ p := equiv_or_symm _ _

@[simp] lemma and_destruct (p q : F) : T ⊢ p ⟶ q ⟶ p ⊓ q := and_destruct p q

@[simp] lemma imply_or_left (p q : F) : T ⊢ p ⟶ p ⊔ q := imply_or_left p q

@[simp] lemma imply_or_right (p q : F) : T ⊢ q ⟶ p ⊔ q := imply_or_right p q

lemma disjunction_of {n} {p : finitary F n} (i) (h : T ⊢ p i) : T ⊢ finitary.disjunction n p :=
disjunction_of i h

@[simp] lemma imply_and (p q r : F) : T ⊢ (p ⟶ q) ⟶ (p ⟶ r) ⟶ p ⟶ q ⊓ r := imply_and p q r

@[simp] lemma neg_and_equiv_or_neg (p q : F) : T ⊢ ∼(p ⊓ q) ⟷ ∼p ⊔ ∼q := neg_and_equiv_or_neg p q

@[simp] lemma neg_conj_equiv_disj_neg {n} (p : finitary F n) : T ⊢ ∼(finitary.conjunction n p) ⟷ (⋁ i, ∼p i) :=
neg_conj_equiv_disj_neg p

@[simp] lemma neg_or_equiv_and_neg (p q : F) : T ⊢ ∼(p ⊔ q) ⟷ ∼p ⊓ ∼q := neg_or_equiv_and_neg p q

@[simp] lemma neg_disj_equiv_conj_neg {n} (p : finitary F n) : T ⊢ ∼(finitary.disjunction n p) ⟷ (⋀ i, ∼p i) :=
neg_disj_equiv_conj_neg p

@[simp] lemma or_imply (p q r : F) : T ⊢ (p ⟶ r) ⟶ (q ⟶ r) ⟶ p ⊔ q ⟶ r := or_imply p q r

lemma cases_of (p q : F) (ht : T ⊢ p ⟶ q) (hf : T ⊢ ∼p ⟶ q) : T ⊢ q :=
or_imply p (∼p) q ⨀ ht ⨀ hf ⨀ (by simp)

@[simp] lemma and_imply_equiv_imply_imply (p q r : F) : T ⊢ (p ⟶ q ⟶ r) ⟷ (p ⊓ q ⟶ r) := and_imply_equiv_imply_imply p q r

@[simp] lemma and_imply_of {p q r : F} : T ⊢ p ⊓ q ⟶ r ↔ T ⊢ p ⟶ q ⟶ r :=
and_imply_of

@[simp] lemma imply_and_equiv_or_imply (p q r : F) : T ⊢ (p ⟶ r) ⊓ (q ⟶ r) ⟷ p ⊔ q ⟶ r := imply_and_equiv_or_imply p q r

@[simp] lemma conj_imply_iff_disj_imply {n} (p : finitary F n) (q : F) : T ⊢ (⋀ i, (p i ⟶ q)) ⟷ ((⋁ i, p i) ⟶ q) := conj_imply_iff_disj_imply p q

lemma explosion {p : F} (h₁ : T ⊢ p) (h₂ : T ⊢ ∼p) {q : F} : T ⊢ q :=
explosion h₁ h₂

lemma contrapose {p q : F} : T ⊢ ∼p ⟶ ∼q ↔ T ⊢ q ⟶ p :=
contrapose

lemma and_imply_of_imply_left {p₁ p₂ q : F} (h : T ⊢ p₁ ⟶ q) : T ⊢ p₁ ⊓ p₂ ⟶ q :=
and_imply_of_imply_left h

lemma and_imply_of_imply_right {p₁ p₂ q : F} (h : T ⊢ p₂ ⟶ q) : T ⊢ p₁ ⊓ p₂ ⟶ q :=
and_imply_of_imply_right h

lemma equiv_imply_of_equiv {p₁ q₁ p₂ q₂ : F} (hp : T ⊢ p₁ ⟷ p₂) (hq : T ⊢ q₁ ⟷ q₂) : T ⊢ (p₁ ⟶ q₁) ⟷ (p₂ ⟶ q₂) :=
equiv_imply_of_equiv hp hq

lemma imply_of_equiv {p₁ q₁ p₂ q₂ : F} (h : T ⊢ p₁ ⟶ q₁) (hp : T ⊢ p₁ ⟷ p₂) (hq : T ⊢ q₁ ⟷ q₂) : T ⊢ p₂ ⟶ q₂ :=
imply_of_equiv h hp hq

lemma equiv_neg_of_equiv {p₁ p₂ : F} (hp : T ⊢ p₁ ⟷ p₂) : T ⊢ ∼p₁ ⟷ ∼p₂ :=
equiv_neg_of_equiv hp

lemma neg_of_equiv {p₁ p₂ : F} (h : T ⊢ ∼p₁) (hp : T ⊢ p₁ ⟷ p₂) : T ⊢ ∼p₂ :=
neg_of_equiv h hp

lemma equiv_and_of_equiv {p₁ q₁ p₂ q₂ : F} (hp : T ⊢ p₁ ⟷ p₂) (hq : T ⊢ q₁ ⟷ q₂) : T ⊢ p₁ ⊓ q₁ ⟷ p₂ ⊓ q₂ :=
equiv_and_of_equiv hp hq

lemma and_of_equiv {p₁ q₁ p₂ q₂: F} (h : T ⊢ p₁ ⊓ q₁) (hp : T ⊢ p₁ ⟷ p₂) (hq : T ⊢ q₁ ⟷ q₂) : T ⊢ p₂ ⊓ q₂ :=
and_of_equiv h hp hq

lemma equiv_or_of_equiv {p₁ q₁ p₂ q₂: F} (hp :  T ⊢ p₁ ⟷ p₂) (hq :  T ⊢ q₁ ⟷ q₂) : T ⊢ p₁ ⊔ q₁ ⟷ p₂ ⊔ q₂ :=
equiv_or_of_equiv hp hq

lemma or_of_equiv {p₁ q₁ p₂ q₂: F} (h : T ⊢ p₁ ⊔ q₁) (hp :  T ⊢ p₁ ⟷ p₂) (hq :  T ⊢ q₁ ⟷ q₂) : T ⊢ p₂ ⊔ q₂ :=
or_of_equiv h hp hq

lemma equiv_equiv_of_equiv {p₁ q₁ p₂ q₂: F} (hp :  T ⊢ p₁ ⟷ p₂) (hq :  T ⊢ q₁ ⟷ q₂) : T ⊢ (p₁ ⟷ q₁) ⟷ (p₂ ⟷ q₂) :=
equiv_equiv_of_equiv hp hq

lemma equiv_of_equiv {p₁ q₁ p₂ q₂: F} (h : T ⊢ p₁ ⟷ q₁) (hp :  T ⊢ p₁ ⟷ p₂) (hq :  T ⊢ q₁ ⟷ q₂) : T ⊢ p₂ ⟷ q₂ :=
equiv_of_equiv h hp hq

lemma case_of_ax {p q r : F} (hpq : T ⊢ p ⊔ q) (hpr : T ⊢ p ⟶ r) (hqr : T ⊢ q ⟶ r) : T ⊢ r :=
case_of_p hpq hpr hqr

@[simp] lemma neg_lconj_equiv_ldisj_neg (l : list F) : T ⊢ ∼l.conjunction ⟷ (l.map has_negation.neg).disjunction :=
neg_lconj_equiv_ldisj_neg l

lemma ldisj_of {l : list F} (p) (hp : p ∈ l) (h : T ⊢ p) : T ⊢ l.disjunction :=
ldisj_of hp h

lemma fdisj_of {s : finset F} (p) (hp : p ∈ s) (h : T ⊢ p) : T ⊢ s.disjunction :=
fdisj_of hp h

@[simp] lemma imply_ldisj {l : list F} {p : F} (h : p ∈ l) : T ⊢ p ⟶ l.disjunction :=
imply_ldisj h

lemma imply_fdisj {s : finset F} {p : F} (h : p ∈ s) : T ⊢ p ⟶ s.disjunction :=
imply_fdisj h

@[simp] lemma ldisj_imply_of {l : list F} {q : F} (h : ∀ p ∈ l, T ⊢ p ⟶ q) : T ⊢ l.disjunction ⟶ q :=
ldisj_imply_of h

@[simp] lemma fdisj_imply_of {s : finset F} {q : F} (h : ∀ p ∈ s, T ⊢ p ⟶ q) : T ⊢ s.disjunction ⟶ q :=
fdisj_imply_of h

lemma fdisj_insert_equiv_sup {s : finset F} {p : F} : T ⊢ (insert p s).disjunction ⟷ s.disjunction ⊔ p :=
fdisj_insert_equiv_sup

lemma fconj_imply_equiv_fdisj_neg (p : F) (s : finset F) :
  T ⊢ (s.conjunction ⟶ p) ⟷ (insert p (s.image has_negation.neg)).disjunction :=
fconj_imply_equiv_fdisj_neg p s

@[simp] lemma insert (p) : T +{ p } ⊢ p := by_axiom (by simp)

@[simp] lemma singleton (p) : (singleton p : set F) ⊢ p := by_axiom (by simp)

lemma by_axiom' {T : set F} {p : F} : T p → T ⊢ p := by_axiom

@[simp] lemma provable_not_bot_iff : T ⊢ ⊥ ⟷ ∼(⊤ : F) := by simp[@not_top_eq_bot F _ ((⊢) T) _]

@[simp] lemma provable_not_bot_iff' : T ⊢ ∼(⊤ : F) ⟷ ⊥ := by simp[@not_top_eq_bot F _ ((⊢) T) _]

@[simp] lemma neg_bot_equiv_top : T ⊢ (∼⊥ : F) ⟷ ⊤ :=
neg_bot_equiv_top

variables (T)

@[reducible] def equiv : F → F → Prop := equiv ((⊢) T)

end axiomatic_classical_logic'

namespace axiomatic_classical_logic
open axiomatic_classical_logic'
open_locale aclogic

variables {F : Type*} [has_logic_symbol F]
  (T : set F) [axiomatic_classical_logic F]

variables {T}

@[simp] lemma weakening_insert {q : F} (h : T ⊢ q) (p) : T +{ p } ⊢ q :=
weakening (show T ⊆ T +{ p }, by { intros x h, simp[h] }) h

theorem deduction {p q} : (T +{ p } ⊢ q) ↔ (T ⊢ p ⟶ q) :=
⟨deduction', λ h, by { have : T +{ p } ⊢ p ⟶ q, simp[h], exact this ⨀ (by simp) }⟩

@[simp]
lemma axiom_and {p₁ p₂ q : F} : T +{ p₁ ⊓ p₂ } ⊢ q ↔ T +{ p₁ } +{ p₂ } ⊢ q :=
⟨λ h,
 by { have lmm₁ : T +{ p₁ } +{ p₂ } ⊢ p₁ ⊓ p₂, by simp[axiomatic_classical_logic'.iff_and],
      have lmm₂ : T +{ p₁ } +{ p₂ } ⊢ p₁ ⊓ p₂ ⟶ q, simp[deduction.mp h],
      exact lmm₂ ⨀ lmm₁ },
 λ h,
 by { have lmm₁ : T +{ p₁ ⊓ p₂ } ⊢ p₁ ⟶ p₂ ⟶ q, simp[deduction.mp (deduction.mp h)],
      have lmm₂ : T +{ p₁ ⊓ p₂ } ⊢ p₁ ⊓ p₂, from insert _, simp only [axiomatic_classical_logic'.iff_and] at lmm₂,
      exact lmm₁ ⨀ lmm₂.1 ⨀ lmm₂.2 } ⟩

lemma axiom_lconj {l : list F} {q : F} : T +{ l.conjunction } ⊢ q ↔ T ∪ { p | p ∈ l } ⊢ q :=
begin
  induction l with p l IH generalizing T,
  { simp[deduction] },
  { simp[IH, show insert p T ∪ {p : F | p ∈ l} = T ∪ {r : F | r = p ∨ r ∈ l}, by ext r; simp; tauto] }
end

lemma axiom_fconj {s : finset F} {q : F} : T +{ s.conjunction } ⊢ q ↔ T ∪ ↑s ⊢ q :=
by simp[finset.conjunction, axiom_lconj]

lemma fdisj_insert {s : finset F} {p : F} : ∅ ⊢ (insert p s).disjunction ↔ has_negation.neg '' ↑s ⊢ p :=
begin
  have empty_iff : {(finset.image has_negation.neg s).conjunction} ⊢ p ↔ has_negation.neg '' ↑s ⊢ p,
  by simpa using @axiom_fconj F _ ∅ _ (s.image has_negation.neg) p,
  have : ∅ ⊢ (insert p s).disjunction ↔ ∅ ⊢ ((s.image has_negation.neg).conjunction ⟶ p),
  from iff_of_equiv (classical_logic.fdisj_insert_equiv_fconj_imply p s),
  simp[this, ←deduction], exact empty_iff
end

@[simp] lemma axiom_and' {p₁ p₂ q : F} : singleton (p₁ ⊓ p₂) ⊢ q ↔ singleton p₁ +{ p₂ } ⊢ q :=
by simpa using @axiom_and _ _ ∅ _ p₁ p₂ q

lemma raa {p : F} (q : F) (h₁ : T+{p} ⊢ q) (h₂ : T+{p} ⊢ ∼q) : T ⊢ ∼p :=
classical_logic.neg_hyp (deduction.mp (classical_logic.explosion h₁ h₂))

lemma list_conjunction_mem {P : list F} : ∀ {p}, p ∈ P → T ⊢ P.conjunction ⟶ p :=
by { induction P with p P IH; simp; intros q hq, exact hyp_right (IH hq) p }

lemma list_conjunction_weakening {P Q : list F} :
  Q ⊆ P → T ⊢ P.conjunction ⟶ Q.conjunction :=
begin
  induction Q with q Q IH; simp,
  intros hyp_q hyp_Q,
  have lmm₁ : T+{P.conjunction} ⊢ q, from deduction.mpr (list_conjunction_mem hyp_q),
  have lmm₂ : T+{P.conjunction} ⊢ Q.conjunction, from deduction.mpr (IH hyp_Q),
  refine deduction.mp _, simp[axiomatic_classical_logic'.iff_and, *]
end

lemma list_conjunction_provable : ∀ {P : list F} (h : ∀ p, p ∈ P → T ⊢ p), T ⊢ P.conjunction
| []       h := by simp
| (p :: P) h := by {
    have lmm₁ : T ⊢ p, { refine h _ _, simp },
    have lmm₂ : T ⊢ P.conjunction,
    { refine list_conjunction_provable (λ p hyp, h _ _), simp, right, exact hyp },
    simp, refine ⟨lmm₁, lmm₂⟩ }

/-
lemma finitary.conjunction_mem {n : ℕ} {P : finitary F n} :
  ∀ {p}, p ∈ P → T ⊢ finitary.conjunction n P ⟶ p :=
begin
  induction n with n IH; simp[finitary.conjunction],
  { simp[has_mem.mem, finitary.mem] },
  { intros p hp, rcases hp with (_ | _), }
  --simp[has_mem.mem, finitary.mem],
  --intros p mem,
  --exact and_imply_of_imply_right (IH mem)
end
-/

@[reducible] def empty_axiom (p : F) : Prop := ∅ ⊢ p

prefix `⬝⊢ `:45 := empty_axiom

section empty_axiom
variables (T)

lemma of_empty_axiom {p : F} (hp : ⬝⊢ p) : T ⊢ p := weakening (by simp) hp

end empty_axiom

variables (T)

@[reducible] def lindenbaum := classical_logic.lindenbaum ((⊢) T : F → Prop)

notation (name := classical_logic.equiv) p ` ≈[`:50 T :50 `] `:0 q:50 := classical_logic.equiv ((⊢) T) p q

namespace lindenbaum

instance : boolean_algebra (lindenbaum T) := classical_logic.lindenbaum.boolean_algebra

end lindenbaum

end axiomatic_classical_logic


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

import category_theory.category
import pseudoelements
import tactic.combinators
import tactic.chase_tactic
import tactic.commutativity

open category_theory
open category_theory.abelian
open category_theory.abelian.pseudoelements
open tactic

namespace tactic.chase

meta def pushforward_single (e : expr) (m : morphism) (n : name) : chase_tactic expr :=
do
  cr ← pose n none (expr.app m.app e),
  hyp_name ← get_unused_name ("h" ++ n),
  ty ← i_to_expr ``(%%(expr.app m.app e) = %%cr),
  x ← mk_eq_refl cr,
  hyp ← assertv hyp_name ty x,
  some l ← as_element_lemma hyp,
  add_elem_lemma l,
  return cr

meta def pushforward : expr → morphism_chain → name → chase_tactic (option expr)
| _ [] _ := return none
| e (m::[]) n := some <$> pushforward_single e m n
| e (m::ms) n := do
  nn ← mk_fresh_name,
  some f ← pushforward e ms nn,
  some <$> pushforward_single f m n

meta def pullback (e : expr) (m : morphism_chain) (n : name) : chase_tactic (option expr) :=
do
exactness_lemmas_for m >>= list.mfoldl (λ r l,
  match r with
  | some r := return $ some r
  | none := do
    z ← diagram_term.zero ⟨l.rhs, e⟩,
    cond ← find_proof ⟨l.rhs, e⟩ z,
    match cond with
    | none := return none
    | some p := do
      s ← i_to_expr ``(exists.elim ((pseudo_exact_of_exact %%l.ex).2 %%e %%p)),
      tactic.apply s,
      f ← tactic.intro n,
      hyp_name ← get_unused_name ("h" ++ n),
      hyp ← tactic.intro hyp_name,
      some hy ← as_element_lemma hyp,
      add_elem_lemma hy,
      return f
    end
  end) none

meta def chase : expr → list morphism_chain → list name → chase_tactic unit
| e [] _ := skip
| e (m::ms) [] := do n ← get_unused_name "x", chase e (m::ms) [n]
| e (m::ms) (n::ns) :=
  do
    ca ← morphism_chain.can_apply e m,
    some ne ← if ca then pushforward e m n else pullback e m n,
    chase ne ms ns

end tactic.chase

namespace tactic.interactive

open interactive (parse)
open lean.parser (tk pexpr)
open interactive.types (texpr with_ident_list pexpr_list)

meta def chase (s : parse pexpr) (maps : parse (tk "using" *> pexpr_list))
  (ids : parse with_ident_list) (loc : parse ((tk "at" *> some <$> pexpr) <|> return none)) : tactic unit :=
do
  e ← i_to_expr s,
  l ← match loc with
      | none := return none
      | some m := some <$> to_expr m
      end,
  mps ← list.mmap
    (λ p, do q ← i_to_expr p, some ch ← tactic.chase.as_morphism q, return [ch]) maps,
  tactic.chase.run_chase_tactic l $ tactic.chase.chase e mps ids

end tactic.interactive


/-
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, Patrick Massot
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.topology.order
import Mathlib.PostPort

universes u_1 u_2 l u_3

namespace Mathlib

/-!
# Specific classes of maps between topological spaces

This file introduces the following properties of a map `f : X → Y` between topological spaces:

* `is_open_map f` means the image of an open set under `f` is open.
* `is_closed_map f` means the image of a closed set under `f` is closed.

(Open and closed maps need not be continuous.)

* `inducing f` means the topology on `X` is the one induced via `f` from the topology on `Y`.
  These behave like embeddings except they need not be injective. Instead, points of `X` which
  are identified by `f` are also indistinguishable in the topology on `X`.
* `embedding f` means `f` is inducing and also injective. Equivalently, `f` identifies `X` with
  a subspace of `Y`.
* `open_embedding f` means `f` is an embedding with open image, so it identifies `X` with an
  open subspace of `Y`. Equivalently, `f` is an embedding and an open map.
* `closed_embedding f` similarly means `f` is an embedding with closed image, so it identifies
  `X` with a closed subspace of `Y`. Equivalently, `f` is an embedding and a closed map.

* `quotient_map f` is the dual condition to `embedding f`: `f` is surjective and the topology
  on `Y` is the one coinduced via `f` from the topology on `X`. Equivalently, `f` identifies
  `Y` with a quotient of `X`. Quotient maps are also sometimes known as identification maps.

## References

* <https://en.wikipedia.org/wiki/Open_and_closed_maps>
* <https://en.wikipedia.org/wiki/Embedding#General_topology>
* <https://en.wikipedia.org/wiki/Quotient_space_(topology)#Quotient_map>

## Tags

open map, closed map, embedding, quotient map, identification map

-/

structure inducing {α : Type u_1} {β : Type u_2} [tα : topological_space α]
    [tβ : topological_space β] (f : α → β)
    where
  induced : tα = topological_space.induced f tβ

theorem inducing_id {α : Type u_1} [topological_space α] : inducing id :=
  inducing.mk (Eq.symm induced_id)

protected theorem inducing.comp {α : Type u_1} {β : Type u_2} {γ : Type u_3} [topological_space α]
    [topological_space β] [topological_space γ] {g : β → γ} {f : α → β} (hg : inducing g)
    (hf : inducing f) : inducing (g ∘ f) :=
  sorry

theorem inducing_of_inducing_compose {α : Type u_1} {β : Type u_2} {γ : Type u_3}
    [topological_space α] [topological_space β] [topological_space γ] {f : α → β} {g : β → γ}
    (hf : continuous f) (hg : continuous g) (hgf : inducing (g ∘ f)) : inducing f :=
  sorry

theorem inducing_open {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β]
    {f : α → β} {s : set α} (hf : inducing f) (h : is_open (set.range f)) (hs : is_open s) :
    is_open (f '' s) :=
  sorry

theorem inducing_is_closed {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β]
    {f : α → β} {s : set α} (hf : inducing f) (h : is_closed (set.range f)) (hs : is_closed s) :
    is_closed (f '' s) :=
  sorry

theorem inducing.nhds_eq_comap {α : Type u_1} {β : Type u_2} [topological_space α]
    [topological_space β] {f : α → β} (hf : inducing f) (a : α) :
    nhds a = filter.comap f (nhds (f a)) :=
  iff.mp (induced_iff_nhds_eq f) (inducing.induced hf)

theorem inducing.map_nhds_eq {α : Type u_1} {β : Type u_2} [topological_space α]
    [topological_space β] {f : α → β} (hf : inducing f) (a : α) (h : set.range f ∈ nhds (f a)) :
    filter.map f (nhds a) = nhds (f a) :=
  Eq.symm (inducing.induced hf) ▸ map_nhds_induced_eq h

theorem inducing.tendsto_nhds_iff {β : Type u_2} {γ : Type u_3} [topological_space β]
    [topological_space γ] {ι : Type u_1} {f : ι → β} {g : β → γ} {a : filter ι} {b : β}
    (hg : inducing g) : filter.tendsto f a (nhds b) ↔ filter.tendsto (g ∘ f) a (nhds (g b)) :=
  sorry

theorem inducing.continuous_iff {α : Type u_1} {β : Type u_2} {γ : Type u_3} [topological_space α]
    [topological_space β] [topological_space γ] {f : α → β} {g : β → γ} (hg : inducing g) :
    continuous f ↔ continuous (g ∘ f) :=
  sorry

theorem inducing.continuous {α : Type u_1} {β : Type u_2} [topological_space α]
    [topological_space β] {f : α → β} (hf : inducing f) : continuous f :=
  iff.mp (inducing.continuous_iff hf) continuous_id

/-- A function between topological spaces is an embedding if it is injective,
  and for all `s : set α`, `s` is open iff it is the preimage of an open set. -/
structure embedding {α : Type u_1} {β : Type u_2} [tα : topological_space α]
    [tβ : topological_space β] (f : α → β)
    extends inducing f where
  inj : function.injective f

theorem embedding.mk' {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β]
    (f : α → β) (inj : function.injective f)
    (induced : ∀ (a : α), filter.comap f (nhds (f a)) = nhds a) : embedding f :=
  embedding.mk (inducing.mk (iff.mpr (induced_iff_nhds_eq f) fun (a : α) => Eq.symm (induced a)))
    inj

theorem embedding_id {α : Type u_1} [topological_space α] : embedding id :=
  embedding.mk inducing_id fun (a₁ a₂ : α) (h : id a₁ = id a₂) => h

theorem embedding.comp {α : Type u_1} {β : Type u_2} {γ : Type u_3} [topological_space α]
    [topological_space β] [topological_space γ] {g : β → γ} {f : α → β} (hg : embedding g)
    (hf : embedding f) : embedding (g ∘ f) :=
  embedding.mk
    (inducing.mk
      (inducing.induced (inducing.comp (embedding.to_inducing hg) (embedding.to_inducing hf))))
    fun (a₁ a₂ : α) (h : function.comp g f a₁ = function.comp g f a₂) =>
      embedding.inj hf (embedding.inj hg h)

theorem embedding_of_embedding_compose {α : Type u_1} {β : Type u_2} {γ : Type u_3}
    [topological_space α] [topological_space β] [topological_space γ] {f : α → β} {g : β → γ}
    (hf : continuous f) (hg : continuous g) (hgf : embedding (g ∘ f)) : embedding f :=
  sorry

theorem embedding_open {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β]
    {f : α → β} {s : set α} (hf : embedding f) (h : is_open (set.range f)) (hs : is_open s) :
    is_open (f '' s) :=
  inducing_open (embedding.to_inducing hf) h hs

theorem embedding_is_closed {α : Type u_1} {β : Type u_2} [topological_space α]
    [topological_space β] {f : α → β} {s : set α} (hf : embedding f) (h : is_closed (set.range f))
    (hs : is_closed s) : is_closed (f '' s) :=
  inducing_is_closed (embedding.to_inducing hf) h hs

theorem embedding.map_nhds_eq {α : Type u_1} {β : Type u_2} [topological_space α]
    [topological_space β] {f : α → β} (hf : embedding f) (a : α) (h : set.range f ∈ nhds (f a)) :
    filter.map f (nhds a) = nhds (f a) :=
  inducing.map_nhds_eq (embedding.to_inducing hf) a h

theorem embedding.tendsto_nhds_iff {β : Type u_2} {γ : Type u_3} [topological_space β]
    [topological_space γ] {ι : Type u_1} {f : ι → β} {g : β → γ} {a : filter ι} {b : β}
    (hg : embedding g) : filter.tendsto f a (nhds b) ↔ filter.tendsto (g ∘ f) a (nhds (g b)) :=
  sorry

theorem embedding.continuous_iff {α : Type u_1} {β : Type u_2} {γ : Type u_3} [topological_space α]
    [topological_space β] [topological_space γ] {f : α → β} {g : β → γ} (hg : embedding g) :
    continuous f ↔ continuous (g ∘ f) :=
  inducing.continuous_iff (embedding.to_inducing hg)

theorem embedding.continuous {α : Type u_1} {β : Type u_2} [topological_space α]
    [topological_space β] {f : α → β} (hf : embedding f) : continuous f :=
  inducing.continuous (embedding.to_inducing hf)

theorem embedding.closure_eq_preimage_closure_image {α : Type u_1} {β : Type u_2}
    [topological_space α] [topological_space β] {e : α → β} (he : embedding e) (s : set α) :
    closure s = e ⁻¹' closure (e '' s) :=
  sorry

/-- A function between topological spaces is a quotient map if it is surjective,
  and for all `s : set β`, `s` is open iff its preimage is an open set. -/
def quotient_map {α : Type u_1} {β : Type u_2} [tα : topological_space α] [tβ : topological_space β]
    (f : α → β) :=
  function.surjective f ∧ tβ = topological_space.coinduced f tα

theorem quotient_map_iff {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β]
    {f : α → β} :
    quotient_map f ↔ function.surjective f ∧ ∀ (s : set β), is_open s ↔ is_open (f ⁻¹' s) :=
  and_congr iff.rfl topological_space_eq_iff

namespace quotient_map

protected theorem id {α : Type u_1} [topological_space α] : quotient_map id :=
  { left := fun (a : α) => Exists.intro a rfl, right := Eq.symm coinduced_id }

protected theorem comp {α : Type u_1} {β : Type u_2} {γ : Type u_3} [topological_space α]
    [topological_space β] [topological_space γ] {g : β → γ} {f : α → β} (hg : quotient_map g)
    (hf : quotient_map f) : quotient_map (g ∘ f) :=
  sorry

protected theorem of_quotient_map_compose {α : Type u_1} {β : Type u_2} {γ : Type u_3}
    [topological_space α] [topological_space β] [topological_space γ] {f : α → β} {g : β → γ}
    (hf : continuous f) (hg : continuous g) (hgf : quotient_map (g ∘ f)) : quotient_map g :=
  sorry

protected theorem continuous_iff {α : Type u_1} {β : Type u_2} {γ : Type u_3} [topological_space α]
    [topological_space β] [topological_space γ] {f : α → β} {g : β → γ} (hf : quotient_map f) :
    continuous g ↔ continuous (g ∘ f) :=
  sorry

protected theorem continuous {α : Type u_1} {β : Type u_2} [topological_space α]
    [topological_space β] {f : α → β} (hf : quotient_map f) : continuous f :=
  iff.mp (quotient_map.continuous_iff hf) continuous_id

protected theorem surjective {α : Type u_1} {β : Type u_2} [topological_space α]
    [topological_space β] {f : α → β} (hf : quotient_map f) : function.surjective f :=
  and.left hf

protected theorem is_open_preimage {α : Type u_1} {β : Type u_2} [topological_space α]
    [topological_space β] {f : α → β} (hf : quotient_map f) {s : set β} :
    is_open (f ⁻¹' s) ↔ is_open s :=
  iff.symm (and.right (iff.mp quotient_map_iff hf) s)

end quotient_map

/-- A map `f : α → β` is said to be an *open map*, if the image of any open `U : set α`
is open in `β`. -/
def is_open_map {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β]
    (f : α → β) :=
  ∀ (U : set α), is_open U → is_open (f '' U)

namespace is_open_map

protected theorem id {α : Type u_1} [topological_space α] : is_open_map id :=
  fun (s : set α) (hs : is_open s) =>
    eq.mpr (id (Eq._oldrec (Eq.refl (is_open (id '' s))) (set.image_id s))) hs

protected theorem comp {α : Type u_1} {β : Type u_2} {γ : Type u_3} [topological_space α]
    [topological_space β] [topological_space γ] {g : β → γ} {f : α → β} (hg : is_open_map g)
    (hf : is_open_map f) : is_open_map (g ∘ f) :=
  id
    fun (s : set α) (hs : is_open s) =>
      eq.mpr (id (Eq._oldrec (Eq.refl (is_open (g ∘ f '' s))) (set.image_comp g f s)))
        (hg (f '' s) (hf s hs))

theorem is_open_range {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β]
    {f : α → β} (hf : is_open_map f) : is_open (set.range f) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (is_open (set.range f))) (Eq.symm set.image_univ)))
    (hf set.univ is_open_univ)

theorem image_mem_nhds {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β]
    {f : α → β} (hf : is_open_map f) {x : α} {s : set α} (hx : s ∈ nhds x) : f '' s ∈ nhds (f x) :=
  sorry

theorem nhds_le {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β]
    {f : α → β} (hf : is_open_map f) (a : α) : nhds (f a) ≤ filter.map f (nhds a) :=
  filter.le_map fun (s : set α) => image_mem_nhds hf

theorem of_nhds_le {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β]
    {f : α → β} (hf : ∀ (a : α), nhds (f a) ≤ filter.map f (nhds a)) : is_open_map f :=
  sorry

theorem of_inverse {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β]
    {f : α → β} {f' : β → α} (h : continuous f') (l_inv : function.left_inverse f f')
    (r_inv : function.right_inverse f f') : is_open_map f :=
  sorry

theorem to_quotient_map {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β]
    {f : α → β} (open_map : is_open_map f) (cont : continuous f) (surj : function.surjective f) :
    quotient_map f :=
  sorry

end is_open_map

theorem is_open_map_iff_nhds_le {α : Type u_1} {β : Type u_2} [topological_space α]
    [topological_space β] {f : α → β} :
    is_open_map f ↔ ∀ (a : α), nhds (f a) ≤ filter.map f (nhds a) :=
  { mp := fun (hf : is_open_map f) => is_open_map.nhds_le hf, mpr := is_open_map.of_nhds_le }

/-- A map `f : α → β` is said to be a *closed map*, if the image of any closed `U : set α`
is closed in `β`. -/
def is_closed_map {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β]
    (f : α → β) :=
  ∀ (U : set α), is_closed U → is_closed (f '' U)

namespace is_closed_map

protected theorem id {α : Type u_1} [topological_space α] : is_closed_map id :=
  fun (s : set α) (hs : is_closed s) =>
    eq.mpr (id (Eq._oldrec (Eq.refl (is_closed (id '' s))) (set.image_id s))) hs

protected theorem comp {α : Type u_1} {β : Type u_2} {γ : Type u_3} [topological_space α]
    [topological_space β] [topological_space γ] {g : β → γ} {f : α → β} (hg : is_closed_map g)
    (hf : is_closed_map f) : is_closed_map (g ∘ f) :=
  id
    fun (s : set α) (hs : is_closed s) =>
      eq.mpr (id (Eq._oldrec (Eq.refl (is_closed (g ∘ f '' s))) (set.image_comp g f s)))
        (hg (f '' s) (hf s hs))

theorem of_inverse {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β]
    {f : α → β} {f' : β → α} (h : continuous f') (l_inv : function.left_inverse f f')
    (r_inv : function.right_inverse f f') : is_closed_map f :=
  sorry

theorem of_nonempty {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β]
    {f : α → β} (h : ∀ (s : set α), is_closed s → set.nonempty s → is_closed (f '' s)) :
    is_closed_map f :=
  sorry

end is_closed_map

/-- An open embedding is an embedding with open image. -/
structure open_embedding {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β]
    (f : α → β)
    extends embedding f where
  open_range : is_open (set.range f)

theorem open_embedding.open_iff_image_open {α : Type u_1} {β : Type u_2} [topological_space α]
    [topological_space β] {f : α → β} (hf : open_embedding f) {s : set α} :
    is_open s ↔ is_open (f '' s) :=
  sorry

theorem open_embedding.is_open_map {α : Type u_1} {β : Type u_2} [topological_space α]
    [topological_space β] {f : α → β} (hf : open_embedding f) : is_open_map f :=
  fun (s : set α) => iff.mp (open_embedding.open_iff_image_open hf)

theorem open_embedding.continuous {α : Type u_1} {β : Type u_2} [topological_space α]
    [topological_space β] {f : α → β} (hf : open_embedding f) : continuous f :=
  embedding.continuous (open_embedding.to_embedding hf)

theorem open_embedding.open_iff_preimage_open {α : Type u_1} {β : Type u_2} [topological_space α]
    [topological_space β] {f : α → β} (hf : open_embedding f) {s : set β} (hs : s ⊆ set.range f) :
    is_open s ↔ is_open (f ⁻¹' s) :=
  sorry

theorem open_embedding_of_embedding_open {α : Type u_1} {β : Type u_2} [topological_space α]
    [topological_space β] {f : α → β} (h₁ : embedding f) (h₂ : is_open_map f) : open_embedding f :=
  sorry

theorem open_embedding_of_continuous_injective_open {α : Type u_1} {β : Type u_2}
    [topological_space α] [topological_space β] {f : α → β} (h₁ : continuous f)
    (h₂ : function.injective f) (h₃ : is_open_map f) : open_embedding f :=
  sorry

theorem open_embedding_id {α : Type u_1} [topological_space α] : open_embedding id :=
  open_embedding.mk embedding_id
    (eq.mpr
      ((fun (s s_1 : set α) (e_2 : s = s_1) => congr_arg is_open e_2) (set.range id) set.univ
        set.range_id)
      is_open_univ)

theorem open_embedding.comp {α : Type u_1} {β : Type u_2} {γ : Type u_3} [topological_space α]
    [topological_space β] [topological_space γ] {g : β → γ} {f : α → β} (hg : open_embedding g)
    (hf : open_embedding f) : open_embedding (g ∘ f) :=
  sorry

/-- A closed embedding is an embedding with closed image. -/
structure closed_embedding {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β]
    (f : α → β)
    extends embedding f where
  closed_range : is_closed (set.range f)

theorem closed_embedding.continuous {α : Type u_1} {β : Type u_2} [topological_space α]
    [topological_space β] {f : α → β} (hf : closed_embedding f) : continuous f :=
  embedding.continuous (closed_embedding.to_embedding hf)

theorem closed_embedding.closed_iff_image_closed {α : Type u_1} {β : Type u_2} [topological_space α]
    [topological_space β] {f : α → β} (hf : closed_embedding f) {s : set α} :
    is_closed s ↔ is_closed (f '' s) :=
  sorry

theorem closed_embedding.is_closed_map {α : Type u_1} {β : Type u_2} [topological_space α]
    [topological_space β] {f : α → β} (hf : closed_embedding f) : is_closed_map f :=
  fun (s : set α) => iff.mp (closed_embedding.closed_iff_image_closed hf)

theorem closed_embedding.closed_iff_preimage_closed {α : Type u_1} {β : Type u_2}
    [topological_space α] [topological_space β] {f : α → β} (hf : closed_embedding f) {s : set β}
    (hs : s ⊆ set.range f) : is_closed s ↔ is_closed (f ⁻¹' s) :=
  sorry

theorem closed_embedding_of_embedding_closed {α : Type u_1} {β : Type u_2} [topological_space α]
    [topological_space β] {f : α → β} (h₁ : embedding f) (h₂ : is_closed_map f) :
    closed_embedding f :=
  sorry

theorem closed_embedding_of_continuous_injective_closed {α : Type u_1} {β : Type u_2}
    [topological_space α] [topological_space β] {f : α → β} (h₁ : continuous f)
    (h₂ : function.injective f) (h₃ : is_closed_map f) : closed_embedding f :=
  sorry

theorem closed_embedding_id {α : Type u_1} [topological_space α] : closed_embedding id :=
  closed_embedding.mk embedding_id
    (eq.mpr
      ((fun (s s_1 : set α) (e_2 : s = s_1) => congr_arg is_closed e_2) (set.range id) set.univ
        set.range_id)
      is_closed_univ)

theorem closed_embedding.comp {α : Type u_1} {β : Type u_2} {γ : Type u_3} [topological_space α]
    [topological_space β] [topological_space γ] {g : β → γ} {f : α → β} (hg : closed_embedding g)
    (hf : closed_embedding f) : closed_embedding (g ∘ f) :=
  sorry

end Mathlib


def A.foo {α : Type} [Add α] (a : α) : α × α :=
(a, a + a)

def B.foo {α : Type} (a : α) : α × α :=
(a, a)

open A
open B

set_option trace.Meta.synthInstance true
-- `foo` is overloaded, the case `A.foo` is discarded because we don't have an instance `[Add String]`.
-- However, we still want to see the trace since we used trace.Meta.synthInstance
#check foo "hello"

theorem ex : foo true = (true, true) :=
rfl


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison

! This file was ported from Lean 3 source module algebraic_geometry.presheafed_space
! leanprover-community/mathlib commit d39590fc8728fbf6743249802486f8c91ffe07bc
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Topology.Sheaves.Presheaf
import Mathbin.CategoryTheory.Adjunction.FullyFaithful

/-!
# Presheafed spaces

Introduces the category of topological spaces equipped with a presheaf (taking values in an
arbitrary target category `C`.)

We further describe how to apply functors and natural transformations to the values of the
presheaves.
-/

universe w v u

open CategoryTheory

open TopCat

open TopologicalSpace

open Opposite

open CategoryTheory.Category CategoryTheory.Functor

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

attribute [local tidy] tactic.op_induction' tactic.auto_cases_opens

namespace AlgebraicGeometry

/-- A `PresheafedSpace C` is a topological space equipped with a presheaf of `C`s. -/
structure PresheafedSpace where
  carrier : TopCat.{w}
  Presheaf : carrier.Presheaf C
#align algebraic_geometry.PresheafedSpace AlgebraicGeometry.PresheafedSpace

variable {C}

namespace PresheafedSpace

attribute [protected] presheaf

instance coeCarrier : Coe (PresheafedSpace.{w, v, u} C) TopCat.{w} where coe X := X.carrier
#align algebraic_geometry.PresheafedSpace.coe_carrier AlgebraicGeometry.PresheafedSpace.coeCarrier

@[simp]
theorem as_coe (X : PresheafedSpace.{w, v, u} C) : X.carrier = (X : TopCat.{w}) :=
  rfl
#align algebraic_geometry.PresheafedSpace.as_coe AlgebraicGeometry.PresheafedSpace.as_coe

@[simp]
theorem mk_coe (carrier) (presheaf) :
    (({     carrier
            Presheaf } : PresheafedSpace.{v} C) : TopCat.{v}) = carrier :=
  rfl
#align algebraic_geometry.PresheafedSpace.mk_coe AlgebraicGeometry.PresheafedSpace.mk_coe

instance (X : PresheafedSpace.{v} C) : TopologicalSpace X :=
  X.carrier.str

/-- The constant presheaf on `X` with value `Z`. -/
def const (X : TopCat) (Z : C) : PresheafedSpace C
    where
  carrier := X
  Presheaf :=
    { obj := fun U => Z
      map := fun U V f => 𝟙 Z }
#align algebraic_geometry.PresheafedSpace.const AlgebraicGeometry.PresheafedSpace.const

instance [Inhabited C] : Inhabited (PresheafedSpace C) :=
  ⟨const (TopCat.of PEmpty) default⟩

/-- A morphism between presheafed spaces `X` and `Y` consists of a continuous map
    `f` between the underlying topological spaces, and a (notice contravariant!) map
    from the presheaf on `Y` to the pushforward of the presheaf on `X` via `f`. -/
structure Hom (X Y : PresheafedSpace.{w, v, u} C) where
  base : (X : TopCat.{w}) ⟶ (Y : TopCat.{w})
  c : Y.Presheaf ⟶ base _* X.Presheaf
#align algebraic_geometry.PresheafedSpace.hom AlgebraicGeometry.PresheafedSpace.Hom

@[ext]
theorem ext {X Y : PresheafedSpace C} (α β : Hom X Y) (w : α.base = β.base)
    (h : α.c ≫ whiskerRight (eqToHom (by rw [w])) _ = β.c) : α = β :=
  by
  cases α; cases β
  dsimp [presheaf.pushforward_obj] at *
  tidy
#align algebraic_geometry.PresheafedSpace.ext AlgebraicGeometry.PresheafedSpace.ext

-- TODO including `injections` would make tidy work earlier.
theorem hext {X Y : PresheafedSpace C} (α β : Hom X Y) (w : α.base = β.base) (h : HEq α.c β.c) :
    α = β := by
  cases α
  cases β
  congr
  exacts[w, h]
#align algebraic_geometry.PresheafedSpace.hext AlgebraicGeometry.PresheafedSpace.hext

/-- The identity morphism of a `PresheafedSpace`. -/
def id (X : PresheafedSpace.{w, v, u} C) : Hom X X
    where
  base := 𝟙 (X : TopCat.{w})
  c := eqToHom (Presheaf.Pushforward.id_eq X.Presheaf).symm
#align algebraic_geometry.PresheafedSpace.id AlgebraicGeometry.PresheafedSpace.id

instance homInhabited (X : PresheafedSpace C) : Inhabited (Hom X X) :=
  ⟨id X⟩
#align algebraic_geometry.PresheafedSpace.hom_inhabited AlgebraicGeometry.PresheafedSpace.homInhabited

/-- Composition of morphisms of `PresheafedSpace`s. -/
def comp {X Y Z : PresheafedSpace C} (α : Hom X Y) (β : Hom Y Z) : Hom X Z
    where
  base := α.base ≫ β.base
  c := β.c ≫ (Presheaf.pushforward _ β.base).map α.c
#align algebraic_geometry.PresheafedSpace.comp AlgebraicGeometry.PresheafedSpace.comp

theorem comp_c {X Y Z : PresheafedSpace C} (α : Hom X Y) (β : Hom Y Z) :
    (comp α β).c = β.c ≫ (Presheaf.pushforward _ β.base).map α.c :=
  rfl
#align algebraic_geometry.PresheafedSpace.comp_c AlgebraicGeometry.PresheafedSpace.comp_c

variable (C)

section

attribute [local simp] id comp

/- The proofs below can be done by `tidy`, but it is too slow,
   and we don't have a tactic caching mechanism. -/
/-- The category of PresheafedSpaces. Morphisms are pairs, a continuous map and a presheaf map
    from the presheaf on the target to the pushforward of the presheaf on the source. -/
instance categoryOfPresheafedSpaces : Category (PresheafedSpace.{v, v, u} C)
    where
  Hom := Hom
  id := id
  comp X Y Z f g := comp f g
  id_comp' X Y f := by
    ext1
    · rw [comp_c]
      erw [eq_to_hom_map]
      simp only [eq_to_hom_refl, assoc, whisker_right_id']
      erw [comp_id, comp_id]
    apply id_comp
  comp_id' X Y f := by
    ext1
    · rw [comp_c]
      erw [congr_hom (presheaf.id_pushforward _) f.c]
      simp only [comp_id, functor.id_map, eq_to_hom_refl, assoc, whisker_right_id']
      erw [eq_to_hom_trans_assoc]
      simp only [id_comp, eq_to_hom_refl]
      erw [comp_id]
    apply comp_id
  assoc' W X Y Z f g h := by
    ext1
    repeat' rw [comp_c]
    simp only [eq_to_hom_refl, assoc, functor.map_comp, whisker_right_id']
    erw [comp_id]
    congr
    rfl
#align algebraic_geometry.PresheafedSpace.category_of_PresheafedSpaces AlgebraicGeometry.PresheafedSpace.categoryOfPresheafedSpaces

end

variable {C}

attribute [local simp] eq_to_hom_map

@[simp]
theorem id_base (X : PresheafedSpace.{v, v, u} C) : (𝟙 X : X ⟶ X).base = 𝟙 (X : TopCat.{v}) :=
  rfl
#align algebraic_geometry.PresheafedSpace.id_base AlgebraicGeometry.PresheafedSpace.id_base

theorem id_c (X : PresheafedSpace.{v, v, u} C) :
    (𝟙 X : X ⟶ X).c = eqToHom (Presheaf.Pushforward.id_eq X.Presheaf).symm :=
  rfl
#align algebraic_geometry.PresheafedSpace.id_c AlgebraicGeometry.PresheafedSpace.id_c

@[simp]
theorem id_c_app (X : PresheafedSpace.{v, v, u} C) (U) :
    (𝟙 X : X ⟶ X).c.app U =
      X.Presheaf.map
        (eqToHom
          (by
            induction U using Opposite.rec
            cases U
            rfl)) :=
  by
  induction U using Opposite.rec
  cases U
  simp only [id_c]
  dsimp
  simp
#align algebraic_geometry.PresheafedSpace.id_c_app AlgebraicGeometry.PresheafedSpace.id_c_app

@[simp]
theorem comp_base {X Y Z : PresheafedSpace.{v, v, u} C} (f : X ⟶ Y) (g : Y ⟶ Z) :
    (f ≫ g).base = f.base ≫ g.base :=
  rfl
#align algebraic_geometry.PresheafedSpace.comp_base AlgebraicGeometry.PresheafedSpace.comp_base

instance (X Y : PresheafedSpace.{v, v, u} C) : CoeFun (X ⟶ Y) fun _ => X → Y :=
  ⟨fun f => f.base⟩

theorem coe_to_fun_eq {X Y : PresheafedSpace.{v, v, u} C} (f : X ⟶ Y) : (f : X → Y) = f.base :=
  rfl
#align algebraic_geometry.PresheafedSpace.coe_to_fun_eq AlgebraicGeometry.PresheafedSpace.coe_to_fun_eq

-- The `reassoc` attribute was added despite the LHS not being a composition of two homs,
-- for the reasons explained in the docstring.
/-- Sometimes rewriting with `comp_c_app` doesn't work because of dependent type issues.
In that case, `erw comp_c_app_assoc` might make progress.
The lemma `comp_c_app_assoc` is also better suited for rewrites in the opposite direction. -/
@[reassoc.1, simp]
theorem comp_c_app {X Y Z : PresheafedSpace.{v, v, u} C} (α : X ⟶ Y) (β : Y ⟶ Z) (U) :
    (α ≫ β).c.app U = β.c.app U ≫ α.c.app (op ((Opens.map β.base).obj (unop U))) :=
  rfl
#align algebraic_geometry.PresheafedSpace.comp_c_app AlgebraicGeometry.PresheafedSpace.comp_c_app

theorem congr_app {X Y : PresheafedSpace.{v, v, u} C} {α β : X ⟶ Y} (h : α = β) (U) :
    α.c.app U = β.c.app U ≫ X.Presheaf.map (eqToHom (by subst h)) :=
  by
  subst h
  dsimp
  simp
#align algebraic_geometry.PresheafedSpace.congr_app AlgebraicGeometry.PresheafedSpace.congr_app

section

variable (C)

/-- The forgetful functor from `PresheafedSpace` to `Top`. -/
@[simps]
def forget : PresheafedSpace.{v, v, u} C ⥤ TopCat
    where
  obj X := (X : TopCat.{v})
  map X Y f := f.base
#align algebraic_geometry.PresheafedSpace.forget AlgebraicGeometry.PresheafedSpace.forget

end

section Iso

variable {X Y : PresheafedSpace.{v, v, u} C}

/-- An isomorphism of PresheafedSpaces is a homeomorphism of the underlying space, and a
natural transformation between the sheaves.
-/
@[simps Hom inv]
def isoOfComponents (H : X.1 ≅ Y.1) (α : H.Hom _* X.2 ≅ Y.2) : X ≅ Y
    where
  Hom :=
    { base := H.Hom
      c := α.inv }
  inv :=
    { base := H.inv
      c := Presheaf.toPushforwardOfIso H α.Hom }
  hom_inv_id' := by
    ext
    · simp
      erw [category.id_comp]
      simpa
    simp
  inv_hom_id' := by
    ext x
    induction x using Opposite.rec
    simp only [comp_c_app, whisker_right_app, presheaf.to_pushforward_of_iso_app,
      nat_trans.comp_app, eq_to_hom_app, id_c_app, category.assoc]
    erw [← α.hom.naturality]
    have := nat_trans.congr_app α.inv_hom_id (op x)
    cases x
    rw [nat_trans.comp_app] at this
    convert this
    · dsimp
      simp
    · simp
    · simp
#align algebraic_geometry.PresheafedSpace.iso_of_components AlgebraicGeometry.PresheafedSpace.isoOfComponents

/-- Isomorphic PresheafedSpaces have natural isomorphic presheaves. -/
@[simps]
def sheafIsoOfIso (H : X ≅ Y) : Y.2 ≅ H.Hom.base _* X.2
    where
  Hom := H.Hom.c
  inv := Presheaf.pushforwardToOfIso ((forget _).mapIso H).symm H.inv.c
  hom_inv_id' := by
    ext U
    have := congr_app H.inv_hom_id U
    simp only [comp_c_app, id_c_app, eq_to_hom_map, eq_to_hom_trans] at this
    generalize_proofs h  at this
    simpa using congr_arg (fun f => f ≫ eq_to_hom h.symm) this
  inv_hom_id' := by
    ext U
    simp only [presheaf.pushforward_to_of_iso_app, nat_trans.comp_app, category.assoc,
      nat_trans.id_app, H.hom.c.naturality]
    have := congr_app H.hom_inv_id ((opens.map H.hom.base).op.obj U)
    generalize_proofs h  at this
    simpa using congr_arg (fun f => f ≫ X.presheaf.map (eq_to_hom h.symm)) this
#align algebraic_geometry.PresheafedSpace.sheaf_iso_of_iso AlgebraicGeometry.PresheafedSpace.sheafIsoOfIso

instance base_isIso_of_iso (f : X ⟶ Y) [IsIso f] : IsIso f.base :=
  IsIso.of_iso ((forget _).mapIso (asIso f))
#align algebraic_geometry.PresheafedSpace.base_is_iso_of_iso AlgebraicGeometry.PresheafedSpace.base_isIso_of_iso

instance c_isIso_of_iso (f : X ⟶ Y) [IsIso f] : IsIso f.c :=
  IsIso.of_iso (sheafIsoOfIso (asIso f))
#align algebraic_geometry.PresheafedSpace.c_is_iso_of_iso AlgebraicGeometry.PresheafedSpace.c_isIso_of_iso

/-- This could be used in conjunction with `category_theory.nat_iso.is_iso_of_is_iso_app`. -/
theorem isIso_of_components (f : X ⟶ Y) [IsIso f.base] [IsIso f.c] : IsIso f :=
  by
  convert is_iso.of_iso (iso_of_components (as_iso f.base) (as_iso f.c).symm)
  ext; · simpa; · simp
#align algebraic_geometry.PresheafedSpace.is_iso_of_components AlgebraicGeometry.PresheafedSpace.isIso_of_components

end Iso

section Restrict

/-- The restriction of a presheafed space along an open embedding into the space.
-/
@[simps]
def restrict {U : TopCat} (X : PresheafedSpace.{v, v, u} C) {f : U ⟶ (X : TopCat.{v})}
    (h : OpenEmbedding f) : PresheafedSpace C
    where
  carrier := U
  Presheaf := h.IsOpenMap.Functor.op ⋙ X.Presheaf
#align algebraic_geometry.PresheafedSpace.restrict AlgebraicGeometry.PresheafedSpace.restrict

/-- The map from the restriction of a presheafed space.
-/
@[simps]
def ofRestrict {U : TopCat} (X : PresheafedSpace.{v, v, u} C) {f : U ⟶ (X : TopCat.{v})}
    (h : OpenEmbedding f) : X.restrict h ⟶ X
    where
  base := f
  c :=
    { app := fun V => X.Presheaf.map (h.IsOpenMap.Adjunction.counit.app V.unop).op
      naturality' := fun U V f =>
        show _ = _ ≫ X.Presheaf.map _ by
          rw [← map_comp, ← map_comp]
          rfl }
#align algebraic_geometry.PresheafedSpace.of_restrict AlgebraicGeometry.PresheafedSpace.ofRestrict

instance ofRestrict_mono {U : TopCat} (X : PresheafedSpace C) (f : U ⟶ X.1) (hf : OpenEmbedding f) :
    Mono (X.of_restrict hf) :=
  by
  haveI : mono f := (TopCat.mono_iff_injective _).mpr hf.inj
  constructor
  intro Z g₁ g₂ eq
  ext V
  · induction V using Opposite.rec
    have hV : (opens.map (X.of_restrict hf).base).obj (hf.is_open_map.functor.obj V) = V :=
      by
      ext1
      exact Set.preimage_image_eq _ hf.inj
    haveI :
      is_iso (hf.is_open_map.adjunction.counit.app (unop (op (hf.is_open_map.functor.obj V)))) :=
      (nat_iso.is_iso_app_of_is_iso
          (whisker_left hf.is_open_map.functor hf.is_open_map.adjunction.counit) V :
        _)
    have := PresheafedSpace.congr_app Eq (op (hf.is_open_map.functor.obj V))
    simp only [PresheafedSpace.comp_c_app, PresheafedSpace.of_restrict_c_app, category.assoc,
      cancel_epi] at this
    have h : _ ≫ _ = _ ≫ _ ≫ _ :=
      congr_arg (fun f => (X.restrict hf).Presheaf.map (eq_to_hom hV).op ≫ f) this
    erw [g₁.c.naturality, g₂.c.naturality_assoc] at h
    simp only [presheaf.pushforward_obj_map, eq_to_hom_op, category.assoc, eq_to_hom_map,
      eq_to_hom_trans] at h
    rw [← is_iso.comp_inv_eq] at h
    simpa using h
  · have := congr_arg PresheafedSpace.hom.base Eq
    simp only [PresheafedSpace.comp_base, PresheafedSpace.of_restrict_base] at this
    rw [cancel_mono] at this
    exact this
#align algebraic_geometry.PresheafedSpace.of_restrict_mono AlgebraicGeometry.PresheafedSpace.ofRestrict_mono

theorem restrict_top_presheaf (X : PresheafedSpace C) :
    (X.restrict (Opens.openEmbedding ⊤)).Presheaf =
      (Opens.inclusionTopIso X.carrier).inv _* X.Presheaf :=
  by
  dsimp
  rw [opens.inclusion_top_functor X.carrier]
  rfl
#align algebraic_geometry.PresheafedSpace.restrict_top_presheaf AlgebraicGeometry.PresheafedSpace.restrict_top_presheaf

theorem ofRestrict_top_c (X : PresheafedSpace C) :
    (X.of_restrict (Opens.openEmbedding ⊤)).c =
      eqToHom
        (by
          rw [restrict_top_presheaf, ← presheaf.pushforward.comp_eq]
          erw [iso.inv_hom_id]
          rw [presheaf.pushforward.id_eq]) :=
  by
  /- another approach would be to prove the left hand side
       is a natural isoomorphism, but I encountered a universe
       issue when `apply nat_iso.is_iso_of_is_iso_app`. -/
  ext U;
  change X.presheaf.map _ = _; convert eq_to_hom_map _ _ using 1
  congr ; simpa
  · induction U using Opposite.rec
    dsimp
    congr
    ext
    exact ⟨fun h => ⟨⟨x, trivial⟩, h, rfl⟩, fun ⟨⟨_, _⟩, h, rfl⟩ => h⟩
#align algebraic_geometry.PresheafedSpace.of_restrict_top_c AlgebraicGeometry.PresheafedSpace.ofRestrict_top_c

/- or `rw [opens.inclusion_top_functor, ←comp_obj, ←opens.map_comp_eq],
         erw iso.inv_hom_id, cases U, refl` after `dsimp` -/
/-- The map to the restriction of a presheafed space along the canonical inclusion from the top
subspace.
-/
@[simps]
def toRestrictTop (X : PresheafedSpace C) : X ⟶ X.restrict (Opens.openEmbedding ⊤)
    where
  base := (Opens.inclusionTopIso X.carrier).inv
  c := eqToHom (restrict_top_presheaf X)
#align algebraic_geometry.PresheafedSpace.to_restrict_top AlgebraicGeometry.PresheafedSpace.toRestrictTop

/-- The isomorphism from the restriction to the top subspace.
-/
@[simps]
def restrictTopIso (X : PresheafedSpace C) : X.restrict (Opens.openEmbedding ⊤) ≅ X
    where
  Hom := X.of_restrict _
  inv := X.toRestrictTop
  hom_inv_id' :=
    ext _ _ (ConcreteCategory.hom_ext _ _ fun ⟨x, _⟩ => rfl) <|
      by
      erw [comp_c]
      rw [X.of_restrict_top_c]
      ext
      simp
  inv_hom_id' :=
    ext _ _ rfl <| by
      erw [comp_c]
      rw [X.of_restrict_top_c]
      ext
      simpa [-eq_to_hom_refl]
#align algebraic_geometry.PresheafedSpace.restrict_top_iso AlgebraicGeometry.PresheafedSpace.restrictTopIso

end Restrict

/-- The global sections, notated Gamma.
-/
@[simps]
def Γ : (PresheafedSpace.{v, v, u} C)ᵒᵖ ⥤ C
    where
  obj X := (unop X).Presheaf.obj (op ⊤)
  map X Y f := f.unop.c.app (op ⊤)
#align algebraic_geometry.PresheafedSpace.Γ AlgebraicGeometry.PresheafedSpace.Γ

theorem Γ_obj_op (X : PresheafedSpace C) : Γ.obj (op X) = X.Presheaf.obj (op ⊤) :=
  rfl
#align algebraic_geometry.PresheafedSpace.Γ_obj_op AlgebraicGeometry.PresheafedSpace.Γ_obj_op

theorem Γ_map_op {X Y : PresheafedSpace.{v, v, u} C} (f : X ⟶ Y) : Γ.map f.op = f.c.app (op ⊤) :=
  rfl
#align algebraic_geometry.PresheafedSpace.Γ_map_op AlgebraicGeometry.PresheafedSpace.Γ_map_op

end PresheafedSpace

end AlgebraicGeometry

open AlgebraicGeometry AlgebraicGeometry.PresheafedSpace

variable {C}

namespace CategoryTheory

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

attribute [local simp] presheaf.pushforward_obj

namespace Functor

/-- We can apply a functor `F : C ⥤ D` to the values of the presheaf in any `PresheafedSpace C`,
    giving a functor `PresheafedSpace C ⥤ PresheafedSpace D` -/
def mapPresheaf (F : C ⥤ D) : PresheafedSpace.{v, v, u} C ⥤ PresheafedSpace.{v, v, u} D
    where
  obj X :=
    { carrier := X.carrier
      Presheaf := X.Presheaf ⋙ F }
  map X Y f :=
    { base := f.base
      c := whiskerRight f.c F }
#align category_theory.functor.map_presheaf CategoryTheory.Functor.mapPresheaf

@[simp]
theorem mapPresheaf_obj_X (F : C ⥤ D) (X : PresheafedSpace C) :
    (F.mapPresheaf.obj X : TopCat.{v}) = (X : TopCat.{v}) :=
  rfl
#align category_theory.functor.map_presheaf_obj_X CategoryTheory.Functor.mapPresheaf_obj_X

@[simp]
theorem mapPresheaf_obj_presheaf (F : C ⥤ D) (X : PresheafedSpace C) :
    (F.mapPresheaf.obj X).Presheaf = X.Presheaf ⋙ F :=
  rfl
#align category_theory.functor.map_presheaf_obj_presheaf CategoryTheory.Functor.mapPresheaf_obj_presheaf

@[simp]
theorem mapPresheaf_map_f (F : C ⥤ D) {X Y : PresheafedSpace.{v, v, u} C} (f : X ⟶ Y) :
    (F.mapPresheaf.map f).base = f.base :=
  rfl
#align category_theory.functor.map_presheaf_map_f CategoryTheory.Functor.mapPresheaf_map_f

@[simp]
theorem mapPresheaf_map_c (F : C ⥤ D) {X Y : PresheafedSpace.{v, v, u} C} (f : X ⟶ Y) :
    (F.mapPresheaf.map f).c = whiskerRight f.c F :=
  rfl
#align category_theory.functor.map_presheaf_map_c CategoryTheory.Functor.mapPresheaf_map_c

end Functor

namespace NatTrans

/-- A natural transformation induces a natural transformation between the `map_presheaf` functors.
-/
def onPresheaf {F G : C ⥤ D} (α : F ⟶ G) : G.mapPresheaf ⟶ F.mapPresheaf
    where app X :=
    { base := 𝟙 _
      c := whiskerLeft X.Presheaf α ≫ eqToHom (Presheaf.Pushforward.id_eq _).symm }
#align category_theory.nat_trans.on_presheaf CategoryTheory.NatTrans.onPresheaf

-- TODO Assemble the last two constructions into a functor
--   `(C ⥤ D) ⥤ (PresheafedSpace C ⥤ PresheafedSpace D)`
end NatTrans

end CategoryTheory


example (p : Prop) [Decidable p] (hnp : ¬ p) :
    if decide p then 0 = 1 else 1 = 1 := by
  simp [hnp, decide_eq_false Unit]


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon, Patrick Massot
-/
import tactic.pi_instances
import algebra.group.pi
import algebra.ring.basic

/-!
# Pi instances for ring

This file defines instances for ring, semiring and related structures on Pi Types
-/

namespace pi
universes u v w
variable {I : Type u}     -- The indexing type
variable {f : I → Type v} -- The family of types already equipped with instances
variables (x y : Π i, f i) (i : I)

instance distrib [Π i, distrib $ f i] : distrib (Π i : I, f i) :=
by refine_struct { add := (+), mul := (*), .. }; tactic.pi_instance_derive_field

instance non_unital_non_assoc_semiring [∀ i, non_unital_non_assoc_semiring $ f i] :
  non_unital_non_assoc_semiring (Π i : I, f i) :=
by refine_struct { zero := (0 : Π i, f i), add := (+), mul := (*), .. };
  tactic.pi_instance_derive_field

instance non_unital_semiring [∀ i, non_unital_semiring $ f i] :
  non_unital_semiring (Π i : I, f i) :=
by refine_struct { zero := (0 : Π i, f i), add := (+), mul := (*), .. };
  tactic.pi_instance_derive_field

instance non_assoc_semiring [∀ i, non_assoc_semiring $ f i] :
  non_assoc_semiring (Π i : I, f i) :=
by refine_struct { zero := (0 : Π i, f i), one := 1, add := (+), mul := (*), .. };
  tactic.pi_instance_derive_field

instance semiring [∀ i, semiring $ f i] : semiring (Π i : I, f i) :=
by refine_struct { zero := (0 : Π i, f i), one := 1, add := (+), mul := (*),
  nsmul := add_monoid.nsmul, npow := monoid.npow };
tactic.pi_instance_derive_field

instance comm_semiring [∀ i, comm_semiring $ f i] : comm_semiring (Π i : I, f i) :=
by refine_struct { zero := (0 : Π i, f i), one := 1, add := (+), mul := (*),
  nsmul := add_monoid.nsmul, npow := monoid.npow };
tactic.pi_instance_derive_field

instance non_unital_non_assoc_ring [∀ i, non_unital_non_assoc_ring $ f i] :
  non_unital_non_assoc_ring (Π i : I, f i) :=
by refine_struct { zero := (0 : Π i, f i), add := (+), mul := (*),
  neg := has_neg.neg, nsmul := add_monoid.nsmul, zsmul := sub_neg_monoid.zsmul };
tactic.pi_instance_derive_field

instance ring [∀ i, ring $ f i] : ring (Π i : I, f i) :=
by refine_struct { zero := (0 : Π i, f i), one := 1, add := (+), mul := (*),
  neg := has_neg.neg, nsmul := add_monoid.nsmul, zsmul := sub_neg_monoid.zsmul,
  npow := monoid.npow };
tactic.pi_instance_derive_field

instance comm_ring [∀ i, comm_ring $ f i] : comm_ring (Π i : I, f i) :=
by refine_struct { zero := (0 : Π i, f i), one := 1, add := (+), mul := (*),
  neg := has_neg.neg, nsmul := add_monoid.nsmul, zsmul := sub_neg_monoid.zsmul,
  npow := monoid.npow };
tactic.pi_instance_derive_field

/-- A family of ring homomorphisms `f a : γ →+* β a` defines a ring homomorphism
`pi.ring_hom f : γ →+* Π a, β a` given by `pi.ring_hom f x b = f b x`. -/
@[simps]
protected def ring_hom {γ : Type w} [Π i, non_assoc_semiring (f i)] [non_assoc_semiring γ]
  (g : Π i, γ →+* f i) : γ →+* Π i, f i :=
{ to_fun := λ x b, g b x,
  map_add' := λ x y, funext $ λ z, (g z).map_add x y,
  map_mul' := λ x y, funext $ λ z, (g z).map_mul x y,
  map_one' := funext $ λ z, (g z).map_one,
  map_zero' := funext $ λ z, (g z).map_zero }

lemma ring_hom_injective {γ : Type w} [nonempty I] [Π i, non_assoc_semiring (f i)]
  [non_assoc_semiring γ] (g : Π i, γ →+* f i) (hg : ∀ i, function.injective (g i)) :
  function.injective (pi.ring_hom g) :=
λ x y h, let ⟨i⟩ := ‹nonempty I› in hg i ((function.funext_iff.mp h : _) i)

end pi

section ring_hom

universes u v
variable {I : Type u}

/-- Evaluation of functions into an indexed collection of monoids at a point is a monoid
homomorphism. This is `function.eval` as a `ring_hom`. -/
@[simps]
def pi.eval_ring_hom (f : I → Type v) [Π i, non_assoc_semiring (f i)] (i : I) :
  (Π i, f i) →+* f i :=
{ ..(pi.eval_monoid_hom f i),
  ..(pi.eval_add_monoid_hom f i) }

/-- `function.const` as a `ring_hom`. -/
@[simps]
def pi.const_ring_hom (α β : Type*) [non_assoc_semiring β] : β →+* (α → β) :=
{ to_fun := function.const _,
  .. pi.ring_hom (λ _, ring_hom.id β) }

/-- Ring homomorphism between the function spaces `I → α` and `I → β`, induced by a ring
homomorphism `f` between `α` and `β`. -/
@[simps] protected def ring_hom.comp_left {α β : Type*} [non_assoc_semiring α]
  [non_assoc_semiring β] (f : α →+* β) (I : Type*) :
  (I → α) →+* (I → β) :=
{ to_fun := λ h, f ∘ h,
  .. f.to_monoid_hom.comp_left I,
  .. f.to_add_monoid_hom.comp_left I }

end ring_hom