import measure_theory.integration
import data.real.ereal

/-
This file contains some lemmas that were used elsewhere but did not fit in that
file.
-/

noncomputable theory
open_locale classical big_operators nnreal ennreal

variables {α β : Type*}

open ennreal set

section tsum

open filter

lemma summable_of_nonneg_of_le_succ {f g : ℕ → ℝ}
  (hg : ∀ n, 0 ≤ g n) (hgf : ∀ n, g n ≤ f n.succ) (hf : summable f) : summable g :=
summable_of_nonneg_of_le hg hgf $ summable.comp_injective hf nat.succ_injective

lemma nnreal.summable_coe_of_summable {f : ℕ → ℝ}
  (hf₁ : ∀ n, 0 ≤ f n) (hf₂ : summable f) :
  @summable (ℝ≥0) _ _ _ (λ n, ⟨f n, hf₁ n⟩) :=
begin
  lift f to ℕ → ℝ≥0,
  { exact nnreal.summable_coe.mp hf₂ },
  { exact hf₁ }
end

lemma nnreal.tsum_coe_eq_of_nonneg {f : ℕ → ℝ} (hf₁ : ∀ n, 0 ≤ f n) :
  (∑' n, ⟨f n, hf₁ n⟩ : ℝ≥0) = ⟨∑' n, f n, tsum_nonneg hf₁⟩ :=
begin
  lift f to ℕ → ℝ≥0,
  { simp_rw [← nnreal.coe_tsum, subtype.coe_eta] },
  { exact hf₁ }
end

lemma tsum_cond [add_comm_monoid α] [topological_space α] [t2_space α]
  (f : bool → α) : ∑' i : bool, f i = f false + f true :=
begin
  rw [tsum_fintype, finset.sum_eq_add];
  simp,
end

end tsum

section filter

open filter

lemma tendsto_top_of_pos_summable_inv
  [linear_ordered_field α] [topological_space α] [order_topology α] {f : ℕ → α}
  (hf : summable f⁻¹) (hf' : ∀ n, 0 < f n) : tendsto f at_top at_top :=
begin
  rw [show f = f⁻¹⁻¹, by { ext, simp }],
  apply filter.tendsto.inv_tendsto_zero,
  apply tendsto_nhds_within_of_tendsto_nhds_of_eventually_within _
    (summable.tendsto_at_top_zero hf),
  rw eventually_iff_exists_mem,
  refine ⟨set.Ioi 0, Ioi_mem_at_top _, λ _ _, _⟩,
  rw [set.mem_Ioi, inv_eq_one_div, one_div, pi.inv_apply, _root_.inv_pos],
  exact hf' _,
end

lemma exists_tendsto_Inf {S : set ℝ} (hS : ∃ x, x ∈ S) (hS' : ∃ x, ∀ y ∈ S, x ≤ y) :
  ∃ (f : ℕ → ℝ) (hf : ∀ n, f n ∈ S), tendsto f at_top (nhds (Inf S)) :=
begin
  have : ∀ n : ℕ, ∃ t ∈ S, t < Inf S + 1 / (n + 1 : ℝ),
  { exact λ n, (real.Inf_lt _ hS hS').1 ((lt_add_iff_pos_right _).2 nat.one_div_pos_of_nat) },
  choose f hf using this,
  refine ⟨f, λ n, (hf n).1, _⟩,
  rw tendsto_iff_dist_tendsto_zero,
  refine squeeze_zero_norm _ tendsto_one_div_add_at_top_nhds_0_nat,
  intro n,
  obtain ⟨hf₁, hf₂⟩ := hf n,
  rw [real.dist_eq, real.norm_eq_abs, abs_abs,
      abs_of_nonneg (sub_nonneg.2 (real.Inf_le S hS' hf₁))],
  linarith,
end

lemma exists_tendsto_Sup {S : set ℝ} (hS : ∃ x, x ∈ S) (hS' : ∃ x, ∀ y ∈ S, y ≤ x) :
  ∃ (f : ℕ → ℝ) (hf : ∀ n, f n ∈ S), tendsto f at_top (nhds (Sup S)) :=
begin
  have : ∀ n : ℕ, ∃ t ∈ S, Sup S - 1 / (n + 1 : ℝ) < t,
  { intro n,
    apply (real.lt_Sup _ hS hS').1,
    rw [sub_lt, _root_.sub_self],
    exact nat.one_div_pos_of_nat },
  choose f hf using this,
  refine ⟨f, λ n, (hf n).1, _⟩,
  rw tendsto_iff_dist_tendsto_zero,
  refine squeeze_zero_norm _ tendsto_one_div_add_at_top_nhds_0_nat,
  intro n,
  obtain ⟨hf₁, hf₂⟩ := hf n,
  rw [real.dist_eq, real.norm_eq_abs, abs_abs, abs_of_nonpos],
  { linarith },
  { rw [sub_le, _root_.sub_zero],
    exact real.le_Sup S hS' hf₁ },
end

lemma Sup_to_real_eq_Sup_image_to_real {S : set ℝ≥0∞} {x r : ℝ≥0∞}
  (hr₁ : r < ⊤) (hr₂ : ∀ (y : ℝ≥0∞), y ∈ S → y ≤ r)
  (hx : x ∈ S) (hmem : x.to_real ∈ ennreal.to_real '' S) :
  Sup (ennreal.to_real '' S) = (Sup S).to_real :=
begin
  have hbdd : ∀ (y : ℝ≥0∞), y ∈ S → y < ⊤ := λ y hy, lt_of_le_of_lt (hr₂ y hy) hr₁,

  have : ∀ (y : ℝ), y ∈ ennreal.to_real '' S → y ≤ r.to_real,
  { rintro _ ⟨y, hy, rfl⟩,
    exact (to_real_le_to_real (ne_of_lt (hbdd y hy)) (ne_of_lt hr₁)).2 (hr₂ y hy) },

  have hnonneg : 0 ≤ Sup (ennreal.to_real '' S),
  { exact le_trans (@to_real_nonneg x) (real.le_Sup _ ⟨r.to_real, this⟩ hmem) },

  have hSlt : Sup S < ⊤ := (lt_of_le_of_lt (Sup_le (λ b hb, hr₂ b hb)) hr₁),
  apply le_antisymm,
  { rw real.Sup_le _ ⟨x.to_real, hmem⟩ ⟨r.to_real, this⟩,
    { rintro _ ⟨y, hy, rfl⟩,
      rw to_real_le_to_real (ne_of_lt (hbdd y hy)) (ne_of_lt hSlt),
      exact le_Sup hy } },
  { rwa [← of_real_le_of_real_iff hnonneg, of_real_to_real _],
    { refine Sup_le (λ b hb, _),
      rw le_of_real_iff_to_real_le (ne_of_lt (hbdd _ hb)) hnonneg,
      refine real.le_Sup _ ⟨r.to_real, this⟩ ⟨b, hb, rfl⟩ },
    exact ne_of_lt hSlt },
end

private lemma ennreal.exists_tendsto_Sup_bdd {S : set ℝ≥0∞}
  (hS : ∃ x, x ∈ S) (h : ∃ x < ⊤, ∀ y ∈ S, y ≤ x) :
  ∃ (f : ℕ → ℝ≥0∞) (hf : ∀ n, f n ∈ S), tendsto f at_top (nhds (Sup S)) :=
begin
  obtain ⟨r, hr₁, hr₂⟩ := h,
  obtain ⟨x, hx⟩ := hS,
  have hmem : x.to_real ∈ ennreal.to_real '' S := ⟨x, hx, rfl⟩,
  have hbdd : ∀ y ∈ S, y < ⊤ := λ _ hy, lt_of_le_of_lt (hr₂ _ hy) hr₁,
  obtain ⟨f, hf₁, hf₂⟩ := exists_tendsto_Sup ⟨x.to_real, hmem⟩ _,
  { have  hnonneg : ∀ n, 0 ≤ f n,
    { intro n,
      obtain ⟨_, -, hy⟩ := hf₁ n,
      exact hy ▸ to_real_nonneg },
    refine ⟨λ x, some (⟨f x, hnonneg x⟩ : ℝ≥0), λ n, _, _⟩,
    { obtain ⟨s, hs₁, hs₂⟩ := hf₁ n,
      lift s to ℝ≥0 using ne_of_lt (hbdd _ hs₁),
      simp only [← hs₂, some_eq_coe, subtype.coe_eta, coe_to_real, hs₁] },
    { lift f to ℕ → ℝ≥0,
      { have hS₁ : Sup S = some ⟨(Sup S).to_real, to_real_nonneg⟩,
        { lift Sup S to ℝ≥0 using ne_of_lt (lt_of_le_of_lt (Sup_le (λ b hb, hr₂ b hb)) hr₁),
          simp only [some_eq_coe, subtype.coe_eta, coe_to_real] },
        have hS₂ : 0 ≤ Sup (ennreal.to_real '' S),
        { refine le_trans (@to_real_nonneg x) (real.le_Sup _ ⟨r.to_real, _⟩ hmem),
          rintro _ ⟨y, hy, rfl⟩,
          exact (to_real_le_to_real (ne_of_lt (hbdd y hy)) (ne_of_lt hr₁)).2 (hr₂ y hy) },
        rw hS₁, simp only [some_eq_coe, subtype.coe_eta],
        rw ennreal.tendsto_coe,
        rw [← nnreal.coe_mk _ hS₂, nnreal.tendsto_coe] at hf₂,
        convert hf₂,
        exact (Sup_to_real_eq_Sup_image_to_real hr₁ hr₂ hx hmem).symm },
      { exact hnonneg } } },
  { refine ⟨r.to_real, _⟩,
    rintro _ ⟨y, hy₁, rfl⟩,
    rw to_real_le_to_real,
    { exact hr₂ _ hy₁ },
    { exact ne_of_lt (hbdd y hy₁) },
    { exact ne_of_lt hr₁ } }
end

private lemma ennreal.exists_tendsto_Sup_not_bdd {S : set ℝ≥0∞}
  (hS : ∃ x, x ∈ S) (h : ¬ ∃ x < ⊤, ∀ y ∈ S, y ≤ x) :
  ∃ (f : ℕ → ℝ≥0∞) (hf : ∀ n, f n ∈ S), tendsto f at_top (nhds (Sup S)) :=
begin
  push_neg at h,
  replace h : ∀ n : ℕ, (∃ (y : ℝ≥0∞), y ∈ S ∧ (n : ℝ≥0∞) < y),
  { intro n, refine h n _,
    rw ← coe_nat,
    exact coe_lt_top },
  choose f hf₁ hf₂ using h,
  have : Sup S = ⊤,
  { rw Sup_eq_top,
    intros r hr,
    lift r to ℝ≥0 using ne_of_lt hr,
    obtain ⟨n, hn⟩ := exists_nat_gt r,
    rw [← coe_lt_coe, coe_nat] at hn,
    exact ⟨f n, hf₁ n, lt_trans hn (hf₂ n)⟩ },
  rw this,
  exact ⟨f, hf₁, tendsto_nhds_top (λ n, eventually_iff_exists_mem.2
    ⟨Ioi n, Ioi_mem_at_top _, λ m hm, lt_trans (by simp [mem_Ioi.1 hm]) (hf₂ m)⟩)⟩
end

lemma ennreal.exists_tendsto_Sup {S : set ℝ≥0∞} (hS : ∃ x, x ∈ S) :
  ∃ (f : ℕ → ℝ≥0∞) (hf : ∀ n, f n ∈ S), tendsto f at_top (nhds (Sup S)) :=
begin
  by_cases ∃ x < ⊤, ∀ y ∈ S, y ≤ x,
  { exact ennreal.exists_tendsto_Sup_bdd hS h },
  { exact ennreal.exists_tendsto_Sup_not_bdd hS h }
end

end filter

section nat

lemma nat.sub_one_lt {n : ℕ} (hn : 1 ≤ n) : n - 1 < n :=
begin
  exact buffer.lt_aux_2 hn,
end

lemma not_forall_le_neg_nat (a : ℝ) (ha : ∀ n : ℕ, a ≤ -n) : false :=
begin
  suffices : ¬ ∀ n : ℕ, a ≤ -n,
  { exact this ha },
  push_neg,
  rcases exists_nat_gt (-a) with ⟨n, hn⟩,
  exact ⟨n, neg_lt.1 hn⟩,
end

end nat

section set

lemma set.union_Union_neq_eq_Union {ι} (f : ι → set α) (j : ι) :
  (f j ∪ ⋃ (i : ι) (hi : i ≠ j), f i) = ⋃ i, f i :=
begin
  ext x,
  simp only [exists_prop, mem_Union, mem_union_eq],
  split,
  { rintro (hj | ⟨i, hij, hi⟩),
    { exact ⟨j, hj⟩ },
    { exact ⟨i, hi⟩ } },
  { rintro ⟨i, hi⟩,
    by_cases i = j,
    { exact or.inl (h ▸ hi) },
    { exact or.inr ⟨i, h, hi⟩ } }
end

lemma set.union_inter_diff_eq {a b c : set α} (habc : a ⊆ b ∪ c) :
  a ∩ b ∪ a ∩ c \ (a ∩ b) = a :=
by rwa [union_diff_self, ← inter_union_distrib_left, inter_eq_left_iff_subset]

lemma set.union_inter_diff_disjoint {a b c : set α} :
  disjoint (a ∩ b) (a ∩ c \ (a ∩ b)) :=
begin
  rintro x ⟨⟨hxa, hxb⟩, _, hxab⟩,
  exact hxab ⟨hxa, hxb⟩,
end

lemma set.Union_inter_diff_eq {f : ℕ → set α} {a : set α} (ha : a ⊆ ⋃ n, f n) :
  (⋃ n, a ∩ f n \ ⋃ k < n, f k) = a :=
begin
  ext x,
  simp only [not_exists, exists_prop, mem_Union, mem_inter_eq, not_and, mem_diff],
  split,
  { rintro ⟨_, ⟨_, _⟩, _⟩, assumption },
  { intro hx,
    let n := nat.find (mem_Union.1 (ha hx)),
    exact ⟨n, ⟨hx, nat.find_spec (mem_Union.1 (ha hx))⟩, λ m hm, nat.find_min _ hm⟩ }
end

lemma set.Union_inter_diff_disjoint {f : ℕ → set α} {a : set α} :
  pairwise $ disjoint on (λ n,  a ∩ f n \ ⋃ k < n, f k) :=
begin
  rintro n m hnm x ⟨⟨hxn₁, hxn₂⟩, hxm₁, hxm₂⟩,
  simp only [not_exists, exists_prop, mem_Union, mem_empty_eq, mem_inter_eq,
             not_and, bot_eq_empty, ne.def] at *,
  rcases lt_or_gt_of_ne hnm with (h | h),
  { exact hxm₂ _ h hxn₁.2 },
  { exact hxn₂ _ h hxm₁.2 }
end

lemma set.disjoint_compl (b : set α) : disjoint b bᶜ :=
is_compl.disjoint is_compl_compl

lemma set.disjoint_inter_compl (a b : set α) : disjoint (a ∩ b) (a ∩ bᶜ) :=
disjoint.mono (inter_subset_right _ _) (inter_subset_right _ _) b.disjoint_compl

end set

section real

lemma real.norm_of_neg {x : ℝ} (hx : x < 0) : ∥x∥ = -x :=
abs_of_neg hx

end real

section nnreal

lemma nnreal.eq_zero_of_le_pos (a : ℝ≥0) (ha : ∀ b : ℝ≥0, 0 < b → a ≤ b) : a = 0 :=
begin
  by_contra,
  have := ha (a / 2) (nnreal.half_pos (zero_lt_iff.2 h)),
  rw ← @not_not (a ≤ a / 2) at this,
  exact this (not_le.2 (nnreal.half_lt_self h)),
end

lemma nnreal.eq_zero_of_le_one_div_nat_plus_one {a b : ℝ≥0}
  (h : ∀ n : ℕ, a ≤ (1 / (n + 1)) * b) : a = 0 :=
begin
  by_cases hb : 0 < b,
  { have hb₁ : (0 : ℝ) < b⁻¹, { rw _root_.inv_pos, exact hb },
    apply nnreal.eq_zero_of_le_pos,
    intros c hc,
    have : ∃ n : ℕ, 1 / (n + 1 : ℝ) < c * b⁻¹, refine exists_nat_one_div_lt _,
    { refine mul_pos hc _,
      rw _root_.inv_pos, exact hb },
    rcases this with ⟨n, hn⟩,
    have h' : 1 / (↑n + 1) * b < c,
    { rw [← nnreal.coe_lt_coe, ← mul_lt_mul_right hb₁, nnreal.coe_mul, mul_assoc,
          ← nnreal.coe_inv, ← nnreal.coe_mul, _root_.mul_inv_cancel, ← nnreal.coe_mul,
          mul_one, nnreal.coe_inv],
      { convert hn, simp },
      { exact ne.symm (ne_of_lt hb) } },
    exact le_trans (h n) (le_of_lt h') },
  { rw [not_lt, le_zero_iff] at hb,
    specialize h 0,
    rw [hb, mul_zero] at h,
    exact le_zero_iff.1 h }
end

end nnreal

section ennreal

lemma ennreal.eq_zero_of_le_one_div_nat_plus_one {a b : ℝ≥0∞}
  (hat : a ≠ ⊤) (hbt : b ≠ ⊤)
  (h : ∀ n : ℕ, a ≤ (1 / (n + 1)) * b) : a = 0 :=
begin
  lift a to ℝ≥0 using hat,
  lift b to ℝ≥0 using hbt,
  rw ennreal.coe_eq_zero,
  apply nnreal.eq_zero_of_le_one_div_nat_plus_one,
  intro n,
  rw [← ennreal.coe_le_coe, ennreal.coe_mul],
  convert h n, simp,
end

end ennreal

section lintegral

open measure_theory

variables [measurable_space α] {μ : measure α}

@[simp] -- Surprised this is not in mathlib
lemma lintegral_univ_eq (f : α → ℝ≥0∞) :
  ∫⁻ a in set.univ, f a ∂μ = ∫⁻ a, f a ∂μ :=
begin
  congr, rw measure.restrict_univ,
end

end lintegral


/-
Copyright (c) 2020 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 algebra.ring_quot
! leanprover-community/mathlib commit 565eb991e264d0db702722b4bde52ee5173c9950
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Algebra.Hom
import Mathbin.RingTheory.Ideal.Quotient

/-!
# Quotients of non-commutative rings

Unfortunately, ideals have only been developed in the commutative case as `ideal`,
and it's not immediately clear how one should formalise ideals in the non-commutative case.

In this file, we directly define the quotient of a semiring by any relation,
by building a bigger relation that represents the ideal generated by that relation.

We prove the universal properties of the quotient, and recommend avoiding relying on the actual
definition, which is made irreducible for this purpose.

Since everything runs in parallel for quotients of `R`-algebras, we do that case at the same time.
-/

universe u₁ u₂ u₃ u₄

variable {R : Type u₁} [Semiring R]

variable {S : Type u₂} [CommSemiring S]

variable {A : Type u₃} [Semiring A] [Algebra S A]

namespace RingQuot

/-- Given an arbitrary relation `r` on a ring, we strengthen it to a relation `rel r`,
such that the equivalence relation generated by `rel r` has `x ~ y` if and only if
`x - y` is in the ideal generated by elements `a - b` such that `r a b`.
-/
inductive Rel (r : R → R → Prop) : R → R → Prop
  | of ⦃x y : R⦄ (h : r x y) : Rel x y
  | add_left ⦃a b c⦄ : Rel a b → Rel (a + c) (b + c)
  | mul_left ⦃a b c⦄ : Rel a b → Rel (a * c) (b * c)
  | mul_right ⦃a b c⦄ : Rel b c → Rel (a * b) (a * c)
#align ring_quot.rel RingQuot.Rel

theorem Rel.add_right {r : R → R → Prop} ⦃a b c : R⦄ (h : Rel r b c) : Rel r (a + b) (a + c) :=
  by
  rw [add_comm a b, add_comm a c]
  exact rel.add_left h
#align ring_quot.rel.add_right RingQuot.Rel.add_right

theorem Rel.neg {R : Type u₁} [Ring R] {r : R → R → Prop} ⦃a b : R⦄ (h : Rel r a b) :
    Rel r (-a) (-b) := by simp only [neg_eq_neg_one_mul a, neg_eq_neg_one_mul b, rel.mul_right h]
#align ring_quot.rel.neg RingQuot.Rel.neg

theorem Rel.sub_left {R : Type u₁} [Ring R] {r : R → R → Prop} ⦃a b c : R⦄ (h : Rel r a b) :
    Rel r (a - c) (b - c) := by simp only [sub_eq_add_neg, h.add_left]
#align ring_quot.rel.sub_left RingQuot.Rel.sub_left

theorem Rel.sub_right {R : Type u₁} [Ring R] {r : R → R → Prop} ⦃a b c : R⦄ (h : Rel r b c) :
    Rel r (a - b) (a - c) := by simp only [sub_eq_add_neg, h.neg.add_right]
#align ring_quot.rel.sub_right RingQuot.Rel.sub_right

theorem Rel.smul {r : A → A → Prop} (k : S) ⦃a b : A⦄ (h : Rel r a b) : Rel r (k • a) (k • b) := by
  simp only [Algebra.smul_def, rel.mul_right h]
#align ring_quot.rel.smul RingQuot.Rel.smul

end RingQuot

/-- The quotient of a ring by an arbitrary relation. -/
structure RingQuot (r : R → R → Prop) where
  toQuot : Quot (RingQuot.Rel r)
#align ring_quot RingQuot

namespace RingQuot

variable (r : R → R → Prop)

private irreducible_def nat_cast (n : ℕ) : RingQuot r :=
  ⟨Quot.mk _ n⟩
#align ring_quot.nat_cast ring_quot.nat_cast

private irreducible_def zero : RingQuot r :=
  ⟨Quot.mk _ 0⟩
#align ring_quot.zero ring_quot.zero

private irreducible_def one : RingQuot r :=
  ⟨Quot.mk _ 1⟩
#align ring_quot.one ring_quot.one

private irreducible_def add : RingQuot r → RingQuot r → RingQuot r
  | ⟨a⟩, ⟨b⟩ => ⟨Quot.map₂ (· + ·) Rel.add_right Rel.add_left a b⟩
#align ring_quot.add ring_quot.add

private irreducible_def mul : RingQuot r → RingQuot r → RingQuot r
  | ⟨a⟩, ⟨b⟩ => ⟨Quot.map₂ (· * ·) Rel.mul_right Rel.mul_left a b⟩
#align ring_quot.mul ring_quot.mul

private irreducible_def neg {R : Type u₁} [Ring R] (r : R → R → Prop) : RingQuot r → RingQuot r
  | ⟨a⟩ => ⟨Quot.map (fun a => -a) Rel.neg a⟩
#align ring_quot.neg ring_quot.neg

private irreducible_def sub {R : Type u₁} [Ring R] (r : R → R → Prop) :
  RingQuot r → RingQuot r → RingQuot r
  | ⟨a⟩, ⟨b⟩ => ⟨Quot.map₂ Sub.sub Rel.sub_right Rel.sub_left a b⟩
#align ring_quot.sub ring_quot.sub

private irreducible_def npow (n : ℕ) : RingQuot r → RingQuot r
  | ⟨a⟩ =>
    ⟨Quot.lift (fun a => Quot.mk (RingQuot.Rel r) (a ^ n))
        (fun a b (h : Rel r a b) =>
          by
          -- note we can't define a `rel.pow` as `rel` isn't reflexive so `rel r 1 1` isn't true
          dsimp only
          induction n
          · rw [pow_zero, pow_zero]
          · rw [pow_succ, pow_succ]
            simpa only [mul] using congr_arg₂ (fun x y => mul r ⟨x⟩ ⟨y⟩) (Quot.sound h) n_ih)
        a⟩
#align ring_quot.npow ring_quot.npow

private irreducible_def smul [Algebra S R] (n : S) : RingQuot r → RingQuot r
  | ⟨a⟩ => ⟨Quot.map (fun a => n • a) (Rel.smul n) a⟩
#align ring_quot.smul ring_quot.smul

instance : Zero (RingQuot r) :=
  ⟨zero r⟩

instance : One (RingQuot r) :=
  ⟨one r⟩

instance : Add (RingQuot r) :=
  ⟨add r⟩

instance : Mul (RingQuot r) :=
  ⟨mul r⟩

instance : Pow (RingQuot r) ℕ :=
  ⟨fun x n => npow r n x⟩

instance {R : Type u₁} [Ring R] (r : R → R → Prop) : Neg (RingQuot r) :=
  ⟨neg r⟩

instance {R : Type u₁} [Ring R] (r : R → R → Prop) : Sub (RingQuot r) :=
  ⟨sub r⟩

instance [Algebra S R] : SMul S (RingQuot r) :=
  ⟨smul r⟩

theorem zero_quot : (⟨Quot.mk _ 0⟩ : RingQuot r) = 0 :=
  show _ = zero r by rw [zero]
#align ring_quot.zero_quot RingQuot.zero_quot

theorem one_quot : (⟨Quot.mk _ 1⟩ : RingQuot r) = 1 :=
  show _ = one r by rw [one]
#align ring_quot.one_quot RingQuot.one_quot

theorem add_quot {a b} : (⟨Quot.mk _ a⟩ + ⟨Quot.mk _ b⟩ : RingQuot r) = ⟨Quot.mk _ (a + b)⟩ :=
  by
  show add r _ _ = _
  rw [add]
  rfl
#align ring_quot.add_quot RingQuot.add_quot

theorem mul_quot {a b} : (⟨Quot.mk _ a⟩ * ⟨Quot.mk _ b⟩ : RingQuot r) = ⟨Quot.mk _ (a * b)⟩ :=
  by
  show mul r _ _ = _
  rw [mul]
  rfl
#align ring_quot.mul_quot RingQuot.mul_quot

theorem pow_quot {a} {n : ℕ} : (⟨Quot.mk _ a⟩ ^ n : RingQuot r) = ⟨Quot.mk _ (a ^ n)⟩ :=
  by
  show npow r _ _ = _
  rw [npow]
#align ring_quot.pow_quot RingQuot.pow_quot

theorem neg_quot {R : Type u₁} [Ring R] (r : R → R → Prop) {a} :
    (-⟨Quot.mk _ a⟩ : RingQuot r) = ⟨Quot.mk _ (-a)⟩ :=
  by
  show neg r _ = _
  rw [neg]
  rfl
#align ring_quot.neg_quot RingQuot.neg_quot

theorem sub_quot {R : Type u₁} [Ring R] (r : R → R → Prop) {a b} :
    (⟨Quot.mk _ a⟩ - ⟨Quot.mk _ b⟩ : RingQuot r) = ⟨Quot.mk _ (a - b)⟩ :=
  by
  show sub r _ _ = _
  rw [sub]
  rfl
#align ring_quot.sub_quot RingQuot.sub_quot

theorem smul_quot [Algebra S R] {n : S} {a : R} :
    (n • ⟨Quot.mk _ a⟩ : RingQuot r) = ⟨Quot.mk _ (n • a)⟩ :=
  by
  show smul r _ _ = _
  rw [smul]
  rfl
#align ring_quot.smul_quot RingQuot.smul_quot

instance (r : R → R → Prop) : Semiring (RingQuot r)
    where
  add := (· + ·)
  mul := (· * ·)
  zero := 0
  one := 1
  natCast := natCast r
  natCast_zero := by simp [Nat.cast, nat_cast, ← zero_quot]
  natCast_succ := by simp [Nat.cast, nat_cast, ← one_quot, add_quot]
  add_assoc := by
    rintro ⟨⟨⟩⟩ ⟨⟨⟩⟩ ⟨⟨⟩⟩
    simp [add_quot, add_assoc]
  zero_add := by
    rintro ⟨⟨⟩⟩
    simp [add_quot, ← zero_quot]
  add_zero := by
    rintro ⟨⟨⟩⟩
    simp [add_quot, ← zero_quot]
  zero_mul := by
    rintro ⟨⟨⟩⟩
    simp [mul_quot, ← zero_quot]
  mul_zero := by
    rintro ⟨⟨⟩⟩
    simp [mul_quot, ← zero_quot]
  add_comm := by
    rintro ⟨⟨⟩⟩ ⟨⟨⟩⟩
    simp [add_quot, add_comm]
  mul_assoc := by
    rintro ⟨⟨⟩⟩ ⟨⟨⟩⟩ ⟨⟨⟩⟩
    simp [mul_quot, mul_assoc]
  one_mul := by
    rintro ⟨⟨⟩⟩
    simp [mul_quot, ← one_quot]
  mul_one := by
    rintro ⟨⟨⟩⟩
    simp [mul_quot, ← one_quot]
  left_distrib := by
    rintro ⟨⟨⟩⟩ ⟨⟨⟩⟩ ⟨⟨⟩⟩
    simp [mul_quot, add_quot, left_distrib]
  right_distrib := by
    rintro ⟨⟨⟩⟩ ⟨⟨⟩⟩ ⟨⟨⟩⟩
    simp [mul_quot, add_quot, right_distrib]
  npow n x := x ^ n
  npow_zero := by
    rintro ⟨⟨⟩⟩
    simp [pow_quot, ← one_quot]
  npow_succ := by
    rintro n ⟨⟨⟩⟩
    simp [pow_quot, mul_quot, pow_succ]
  nsmul := (· • ·)
  nsmul_zero := by
    rintro ⟨⟨⟩⟩
    simp [smul_quot, ← zero_quot]
  nsmul_succ := by
    rintro n ⟨⟨⟩⟩
    simp [smul_quot, add_quot, add_mul, add_comm]

instance {R : Type u₁} [Ring R] (r : R → R → Prop) : Ring (RingQuot r) :=
  { RingQuot.semiring r with
    neg := Neg.neg
    add_left_neg := by
      rintro ⟨⟨⟩⟩
      simp [neg_quot, add_quot, ← zero_quot]
    sub := Sub.sub
    sub_eq_add_neg := by
      rintro ⟨⟨⟩⟩ ⟨⟨⟩⟩
      simp [neg_quot, sub_quot, add_quot, sub_eq_add_neg]
    zsmul := (· • ·)
    zsmul_zero' := by
      rintro ⟨⟨⟩⟩
      simp [smul_quot, ← zero_quot]
    zsmul_succ' := by
      rintro n ⟨⟨⟩⟩
      simp [smul_quot, add_quot, add_mul, add_comm]
    zsmul_neg' := by
      rintro n ⟨⟨⟩⟩
      simp [smul_quot, neg_quot, add_mul] }

instance {R : Type u₁} [CommSemiring R] (r : R → R → Prop) : CommSemiring (RingQuot r) :=
  { RingQuot.semiring r with
    mul_comm := by
      rintro ⟨⟨⟩⟩ ⟨⟨⟩⟩
      simp [mul_quot, mul_comm] }

instance {R : Type u₁} [CommRing R] (r : R → R → Prop) : CommRing (RingQuot r) :=
  { RingQuot.commSemiring r, RingQuot.ring r with }

instance (r : R → R → Prop) : Inhabited (RingQuot r) :=
  ⟨0⟩

instance [Algebra S R] (r : R → R → Prop) : Algebra S (RingQuot r)
    where
  smul := (· • ·)
  toFun r := ⟨Quot.mk _ (algebraMap S R r)⟩
  map_one' := by simp [← one_quot]
  map_mul' := by simp [mul_quot]
  map_zero' := by simp [← zero_quot]
  map_add' := by simp [add_quot]
  commutes' r := by
    rintro ⟨⟨a⟩⟩
    simp [Algebra.commutes, mul_quot]
  smul_def' r := by
    rintro ⟨⟨a⟩⟩
    simp [smul_quot, Algebra.smul_def, mul_quot]

/-- The quotient map from a ring to its quotient, as a homomorphism of rings.
-/
irreducible_def mkRingHom (r : R → R → Prop) : R →+* RingQuot r :=
  { toFun := fun x => ⟨Quot.mk _ x⟩
    map_one' := by simp [← one_quot]
    map_mul' := by simp [mul_quot]
    map_zero' := by simp [← zero_quot]
    map_add' := by simp [add_quot] }
#align ring_quot.mk_ring_hom RingQuot.mkRingHom

theorem mkRingHom_rel {r : R → R → Prop} {x y : R} (w : r x y) : mkRingHom r x = mkRingHom r y := by
  simp [mk_ring_hom, Quot.sound (rel.of w)]
#align ring_quot.mk_ring_hom_rel RingQuot.mkRingHom_rel

theorem mkRingHom_surjective (r : R → R → Prop) : Function.Surjective (mkRingHom r) :=
  by
  dsimp [mk_ring_hom]
  rintro ⟨⟨⟩⟩
  simp
#align ring_quot.mk_ring_hom_surjective RingQuot.mkRingHom_surjective

@[ext]
theorem ringQuot_ext {T : Type u₄} [Semiring T] {r : R → R → Prop} (f g : RingQuot r →+* T)
    (w : f.comp (mkRingHom r) = g.comp (mkRingHom r)) : f = g :=
  by
  ext
  rcases mk_ring_hom_surjective r x with ⟨x, rfl⟩
  exact (RingHom.congr_fun w x : _)
#align ring_quot.ring_quot_ext RingQuot.ringQuot_ext

variable {T : Type u₄} [Semiring T]

/-- Any ring homomorphism `f : R →+* T` which respects a relation `r : R → R → Prop`
factors uniquely through a morphism `ring_quot r →+* T`.
-/
irreducible_def lift {r : R → R → Prop} :
  { f : R →+* T // ∀ ⦃x y⦄, r x y → f x = f y } ≃ (RingQuot r →+* T) :=
  { toFun := fun f' =>
      let f := (f' : R →+* T)
      { toFun := fun x =>
          Quot.lift f
            (by
              rintro _ _ r
              induction r
              case of _ _ r => exact f'.prop r
              case add_left _ _ _ _ r' => simp [r']
              case mul_left _ _ _ _ r' => simp [r']
              case mul_right _ _ _ _ r' => simp [r'])
            x.toQuot
        map_zero' := by simp [← zero_quot, f.map_zero]
        map_add' := by
          rintro ⟨⟨x⟩⟩ ⟨⟨y⟩⟩
          simp [add_quot, f.map_add x y]
        map_one' := by simp [← one_quot, f.map_one]
        map_mul' := by
          rintro ⟨⟨x⟩⟩ ⟨⟨y⟩⟩
          simp [mul_quot, f.map_mul x y] }
    invFun := fun F =>
      ⟨F.comp (mkRingHom r), fun x y h => by
        dsimp
        rw [mk_ring_hom_rel h]⟩
    left_inv := fun f => by
      ext
      simp [mk_ring_hom]
    right_inv := fun F => by
      ext
      simp [mk_ring_hom] }
#align ring_quot.lift RingQuot.lift

@[simp]
theorem lift_mkRingHom_apply (f : R →+* T) {r : R → R → Prop} (w : ∀ ⦃x y⦄, r x y → f x = f y) (x) :
    lift ⟨f, w⟩ (mkRingHom r x) = f x :=
  by
  simp_rw [lift, mk_ring_hom]
  rfl
#align ring_quot.lift_mk_ring_hom_apply RingQuot.lift_mkRingHom_apply

-- note this is essentially `lift.symm_apply_eq.mp h`
theorem lift_unique (f : R →+* T) {r : R → R → Prop} (w : ∀ ⦃x y⦄, r x y → f x = f y)
    (g : RingQuot r →+* T) (h : g.comp (mkRingHom r) = f) : g = lift ⟨f, w⟩ :=
  by
  ext
  simp [h]
#align ring_quot.lift_unique RingQuot.lift_unique

theorem eq_lift_comp_mkRingHom {r : R → R → Prop} (f : RingQuot r →+* T) :
    f =
      lift
        ⟨f.comp (mkRingHom r), fun x y h => by
          dsimp
          rw [mk_ring_hom_rel h]⟩ :=
  by
  conv_lhs => rw [← lift.apply_symm_apply f]
  rw [lift]
  rfl
#align ring_quot.eq_lift_comp_mk_ring_hom RingQuot.eq_lift_comp_mkRingHom

section CommRing

/-!
We now verify that in the case of a commutative ring, the `ring_quot` construction
agrees with the quotient by the appropriate ideal.
-/

variable {B : Type u₁} [CommRing B]

/-- The universal ring homomorphism from `ring_quot r` to `B ⧸ ideal.of_rel r`. -/
def ringQuotToIdealQuotient (r : B → B → Prop) : RingQuot r →+* B ⧸ Ideal.ofRel r :=
  lift
    ⟨Ideal.Quotient.mk (Ideal.ofRel r), fun x y h =>
      Ideal.Quotient.eq.2 <| Submodule.mem_infₛ.mpr fun p w => w ⟨x, y, h, sub_add_cancel x y⟩⟩
#align ring_quot.ring_quot_to_ideal_quotient RingQuot.ringQuotToIdealQuotient

@[simp]
theorem ringQuotToIdealQuotient_apply (r : B → B → Prop) (x : B) :
    ringQuotToIdealQuotient r (mkRingHom r x) = Ideal.Quotient.mk _ x :=
  by
  simp_rw [ring_quot_to_ideal_quotient, lift, mk_ring_hom]
  rfl
#align ring_quot.ring_quot_to_ideal_quotient_apply RingQuot.ringQuotToIdealQuotient_apply

/-- The universal ring homomorphism from `B ⧸ ideal.of_rel r` to `ring_quot r`. -/
def idealQuotientToRingQuot (r : B → B → Prop) : B ⧸ Ideal.ofRel r →+* RingQuot r :=
  Ideal.Quotient.lift (Ideal.ofRel r) (mkRingHom r)
    (by
      refine' fun x h => Submodule.span_induction h _ _ _ _
      · rintro y ⟨a, b, h, su⟩
        symm at su
        rw [← sub_eq_iff_eq_add] at su
        rw [← su, RingHom.map_sub, mk_ring_hom_rel h, sub_self]
      · simp
      · intro a b ha hb
        simp [ha, hb]
      · intro a x hx
        simp [hx])
#align ring_quot.ideal_quotient_to_ring_quot RingQuot.idealQuotientToRingQuot

@[simp]
theorem idealQuotientToRingQuot_apply (r : B → B → Prop) (x : B) :
    idealQuotientToRingQuot r (Ideal.Quotient.mk _ x) = mkRingHom r x :=
  rfl
#align ring_quot.ideal_quotient_to_ring_quot_apply RingQuot.idealQuotientToRingQuot_apply

/-- The ring equivalence between `ring_quot r` and `(ideal.of_rel r).quotient`
-/
def ringQuotEquivIdealQuotient (r : B → B → Prop) : RingQuot r ≃+* B ⧸ Ideal.ofRel r :=
  RingEquiv.ofHomInv (ringQuotToIdealQuotient r) (idealQuotientToRingQuot r)
    (by
      ext
      simp_rw [ring_quot_to_ideal_quotient, lift, mk_ring_hom]
      dsimp
      rw [mk_ring_hom]
      rfl)
    (by
      ext
      simp_rw [ring_quot_to_ideal_quotient, lift, mk_ring_hom]
      dsimp
      rw [mk_ring_hom]
      rfl)
#align ring_quot.ring_quot_equiv_ideal_quotient RingQuot.ringQuotEquivIdealQuotient

end CommRing

section StarRing

variable [StarRing R] (r) (hr : ∀ a b, r a b → r (star a) (star b))

include hr

theorem Rel.star ⦃a b : R⦄ (h : Rel r a b) : Rel r (star a) (star b) :=
  by
  induction h
  · exact rel.of (hr _ _ h_h)
  · rw [star_add, star_add]
    exact rel.add_left h_ih
  · rw [star_mul, star_mul]
    exact rel.mul_right h_ih
  · rw [star_mul, star_mul]
    exact rel.mul_left h_ih
#align ring_quot.rel.star RingQuot.Rel.star

private irreducible_def star' : RingQuot r → RingQuot r
  | ⟨a⟩ => ⟨Quot.map (star : R → R) (Rel.star r hr) a⟩
#align ring_quot.star' ring_quot.star'

theorem star'_quot (hr : ∀ a b, r a b → r (star a) (star b)) {a} :
    (star' r hr ⟨Quot.mk _ a⟩ : RingQuot r) = ⟨Quot.mk _ (star a)⟩ :=
  by
  show star' r _ _ = _
  rw [star']
  rfl
#align ring_quot.star'_quot RingQuot.star'_quot

/-- Transfer a star_ring instance through a quotient, if the quotient is invariant to `star` -/
def starRing {R : Type u₁} [Semiring R] [StarRing R] (r : R → R → Prop)
    (hr : ∀ a b, r a b → r (star a) (star b)) : StarRing (RingQuot r)
    where
  unit := star' r hr
  star_involutive := by
    rintro ⟨⟨⟩⟩
    simp [star'_quot]
  star_mul := by
    rintro ⟨⟨⟩⟩ ⟨⟨⟩⟩
    simp [star'_quot, mul_quot, star_mul]
  star_add := by
    rintro ⟨⟨⟩⟩ ⟨⟨⟩⟩
    simp [star'_quot, add_quot, star_add]
#align ring_quot.star_ring RingQuot.starRing

end StarRing

section Algebra

variable (S)

/-- The quotient map from an `S`-algebra to its quotient, as a homomorphism of `S`-algebras.
-/
irreducible_def mkAlgHom (s : A → A → Prop) : A →ₐ[S] RingQuot s :=
  { mkRingHom s with
    commutes' := fun r => by
      simp [mk_ring_hom]
      rfl }
#align ring_quot.mk_alg_hom RingQuot.mkAlgHom

@[simp]
theorem mkAlgHom_coe (s : A → A → Prop) : (mkAlgHom S s : A →+* RingQuot s) = mkRingHom s :=
  by
  simp_rw [mk_alg_hom, mk_ring_hom]
  rfl
#align ring_quot.mk_alg_hom_coe RingQuot.mkAlgHom_coe

theorem mkAlgHom_rel {s : A → A → Prop} {x y : A} (w : s x y) : mkAlgHom S s x = mkAlgHom S s y :=
  by simp [mk_alg_hom, mk_ring_hom, Quot.sound (rel.of w)]
#align ring_quot.mk_alg_hom_rel RingQuot.mkAlgHom_rel

theorem mkAlgHom_surjective (s : A → A → Prop) : Function.Surjective (mkAlgHom S s) :=
  by
  dsimp [mk_alg_hom, mk_ring_hom]
  rintro ⟨⟨a⟩⟩
  use a
  rfl
#align ring_quot.mk_alg_hom_surjective RingQuot.mkAlgHom_surjective

variable {B : Type u₄} [Semiring B] [Algebra S B]

@[ext]
theorem ringQuot_ext' {s : A → A → Prop} (f g : RingQuot s →ₐ[S] B)
    (w : f.comp (mkAlgHom S s) = g.comp (mkAlgHom S s)) : f = g :=
  by
  ext
  rcases mk_alg_hom_surjective S s x with ⟨x, rfl⟩
  exact (AlgHom.congr_fun w x : _)
#align ring_quot.ring_quot_ext' RingQuot.ringQuot_ext'

/-- Any `S`-algebra homomorphism `f : A →ₐ[S] B` which respects a relation `s : A → A → Prop`
factors uniquely through a morphism `ring_quot s →ₐ[S]  B`.
-/
irreducible_def liftAlgHom {s : A → A → Prop} :
  { f : A →ₐ[S] B // ∀ ⦃x y⦄, s x y → f x = f y } ≃ (RingQuot s →ₐ[S] B) :=
  { toFun := fun f' =>
      let f := (f' : A →ₐ[S] B)
      { toFun := fun x =>
          Quot.lift f
            (by
              rintro _ _ r
              induction r
              case of _ _ r => exact f'.prop r
              case add_left _ _ _ _ r' => simp [r']
              case mul_left _ _ _ _ r' => simp [r']
              case mul_right _ _ _ _ r' => simp [r'])
            x.toQuot
        map_zero' := by simp [← zero_quot, f.map_zero]
        map_add' := by
          rintro ⟨⟨x⟩⟩ ⟨⟨y⟩⟩
          simp [add_quot, f.map_add x y]
        map_one' := by simp [← one_quot, f.map_one]
        map_mul' := by
          rintro ⟨⟨x⟩⟩ ⟨⟨y⟩⟩
          simp [mul_quot, f.map_mul x y]
        commutes' := by
          rintro x
          simp [← one_quot, smul_quot, Algebra.algebraMap_eq_smul_one] }
    invFun := fun F =>
      ⟨F.comp (mkAlgHom S s), fun _ _ h => by
        dsimp
        erw [mk_alg_hom_rel S h]⟩
    left_inv := fun f => by
      ext
      simp [mk_alg_hom, mk_ring_hom]
    right_inv := fun F => by
      ext
      simp [mk_alg_hom, mk_ring_hom] }
#align ring_quot.lift_alg_hom RingQuot.liftAlgHom

@[simp]
theorem liftAlgHom_mkAlgHom_apply (f : A →ₐ[S] B) {s : A → A → Prop}
    (w : ∀ ⦃x y⦄, s x y → f x = f y) (x) : (liftAlgHom S ⟨f, w⟩) ((mkAlgHom S s) x) = f x :=
  by
  simp_rw [lift_alg_hom, mk_alg_hom, mk_ring_hom]
  rfl
#align ring_quot.lift_alg_hom_mk_alg_hom_apply RingQuot.liftAlgHom_mkAlgHom_apply

-- note this is essentially `(lift_alg_hom S).symm_apply_eq.mp h`
theorem liftAlgHom_unique (f : A →ₐ[S] B) {s : A → A → Prop} (w : ∀ ⦃x y⦄, s x y → f x = f y)
    (g : RingQuot s →ₐ[S] B) (h : g.comp (mkAlgHom S s) = f) : g = liftAlgHom S ⟨f, w⟩ :=
  by
  ext
  simp [h]
#align ring_quot.lift_alg_hom_unique RingQuot.liftAlgHom_unique

theorem eq_liftAlgHom_comp_mkAlgHom {s : A → A → Prop} (f : RingQuot s →ₐ[S] B) :
    f =
      liftAlgHom S
        ⟨f.comp (mkAlgHom S s), fun x y h => by
          dsimp
          erw [mk_alg_hom_rel S h]⟩ :=
  by
  conv_lhs => rw [← (lift_alg_hom S).apply_symm_apply f]
  rw [lift_alg_hom]
  rfl
#align ring_quot.eq_lift_alg_hom_comp_mk_alg_hom RingQuot.eq_liftAlgHom_comp_mkAlgHom

end Algebra

end RingQuot


import init.data.nat
import init.data.set

namespace set
  universes u
  variables {α : Type u}
  def set_union (s₁ s₂ : set α) : set α := {a | a ∈ s₁ ∨ a ∈ s₂}
  instance : has_union (set α) := ⟨set_union⟩
end set

/- Types -/
/- Inductive Types: Formula -/
inductive formula
| atom (SYMBOL : ℕ) : formula
| implication (ANTECEDENT CONSEQUENT : formula) : formula
export formula (atom implication)
notation (name := FORMULA_01) #SYMBOL := formula.atom SYMBOL
notation (name := FORMULA_02) ANTECEDENT >> CONSEQUENT := formula.implication ANTECEDENT CONSEQUENT
/- Instances of Decidability: Equality -/
instance formula.decidable_eq :
  ∀(f1 f2 : formula),
  ---------------------------------
  decidable (f1 = f2)
-- ATOM:
| (atom SBL1) (atom SBL2) := begin simp [eq.decidable], from @nat.decidable_eq SBL1 SBL2 end
| (atom _) (implication _ _) := begin simp [eq.decidable], from is_false not_false end
-- IMPLICATION:
| (implication _ _) (atom _) := begin simp [eq.decidable], from is_false not_false end
| (implication ANT1 CON1) (implication ANT2 CON2) := begin
  simp [eq.decidable],
  from @and.decidable (ANT1 = ANT2) (CON1 = CON2) (@formula.decidable_eq ANT1 ANT2) (@formula.decidable_eq CON1 CON2)
end

/- Inductive Types: Dag-Like Derivability Structure -/
/- DLDS: Node -/
inductive node
| vertex (LEVEL : ℕ)
         (NUMBER : ℕ)
         (FORMULA : formula)
export node (vertex)
notation (name := NODE_03) LEVEL && NUMBER && FORMULA := node.vertex LEVEL NUMBER FORMULA
/- Instances of Decidability: Equality -/
instance node.decidable_eq :
  ∀(n1 n2 : node),
  ---------------------------------
  decidable (n1 = n2)
-- VERTEX:
| (vertex LVL_1 NBR_1 FML_1) (vertex LVL_2 NBR_2 FML_2) := begin
  simp [eq.decidable],
  have decidable_and, from @and.decidable (NBR_1 = NBR_2)
                                          (FML_1 = FML_2)
                                          (@nat.decidable_eq NBR_1 NBR_2)
                                          (@formula.decidable_eq FML_1 FML_2),
  from @and.decidable (LVL_1 = LVL_2)
                      (NBR_1 = NBR_2 ∧ FML_1 = FML_2)
                      (@nat.decidable_eq LVL_1 LVL_2)
                      (decidable_and)
end

/- Inductive Types: Dag-Like Derivability Structure -/
/- DLDS: Deduction Edges -/
inductive deduction
| edge (START : node)
       (END : node)
       (COLOUR : list ℕ)
       (DEPENDENT : set formula)
export deduction (edge)
/- DLDS: Ancestral Edges -/
inductive ancestral
| path (START : node)
       (END : node)
       (PATH : list ℕ)
export ancestral (path)
/- DLDS: Neighborhoods -/
inductive neighborhood
| dag (CENTER : node)
      (IN : list deduction)
      (OUT : list deduction)
      (ANCESTRAL : list ancestral)
export neighborhood (dag)

/- Methods -/
/- Auxiliary Definitions: -/
/- Rewrite: Nodes -/
def node_rewrite : node → node → node → node
| NODE OLD NEW := if NODE = OLD then NEW else NODE
def list_node_rewrite : list node → node → node → list node
| [] OLD NEW := []
| (HEAD::TAIL) OLD NEW := (node_rewrite HEAD OLD NEW)::(list_node_rewrite TAIL OLD NEW)
/- Rewrite: Deduction Edges -/
def deduction_rewrite : deduction → node → node → deduction
| (edge STR END CLR DEP) OLD NEW := edge (node_rewrite STR OLD NEW)
                                         (node_rewrite END OLD NEW)
                                         CLR
                                         DEP
def list_deduction_rewrite : list deduction → node → node → list deduction
| [] OLD NEW := []
| (HEAD::TAIL) OLD NEW := (deduction_rewrite HEAD OLD NEW)::(list_deduction_rewrite TAIL OLD NEW)
/- Rewrite: Ancestral Edges -/
def ancestral_rewrite : ancestral → node → node → ancestral
| (path STR END PTH) OLD NEW := path (node_rewrite STR OLD NEW)
                                     (node_rewrite END OLD NEW)
                                     PTH
def list_ancestral_rewrite : list ancestral → node → node → list ancestral
| [] OLD NEW := []
| (HEAD::TAIL) OLD NEW := (ancestral_rewrite HEAD OLD NEW)::(list_ancestral_rewrite TAIL OLD NEW)
/- Rewrite: Neighborhoods -/
def neighborhood_rewrite : neighborhood → node → node → neighborhood
| (dag CTR IN OUT ANC) OLD NEW := dag (node_rewrite CTR OLD NEW)
                                      (list_deduction_rewrite IN OLD NEW)
                                      (list_deduction_rewrite OUT OLD NEW)
                                      (list_ancestral_rewrite ANC OLD NEW)
/- Paint: Deduction Edges -/
def colour_paint : list ℕ → ℕ → list ℕ
| COLOUR PAINT := if COLOUR = [] then [PAINT] else COLOUR
def deduction_paint : deduction → ℕ → deduction
| (edge STR END CLR DEP) PAINT := edge STR
                                       END
                                       (colour_paint CLR PAINT)
                                       DEP
def list_deduction_paint : list deduction → ℕ → list deduction
| [] PAINT := []
| (HEAD::TAIL) PAINT := (deduction_paint HEAD PAINT)::(list_deduction_paint TAIL PAINT)

/- Neighborhoods of Non-Collapsed Nodes (Without Incoming Ancestral Edges): -/
/- Neighborhood: Type 0 ⊇-Elimination -/
def elimination_neighborhood : neighborhood → Prop
| (dag (vertex LVL NBR FML) IN OUT ANC) := ( ∃(antecedent out_frm : formula),
                                             ∃(minor out_nbr : ℕ),
                                             ∃(minor_dep major_dep : set formula),
                                             ------------------------------------------------------
                                             IN = [ edge (vertex (LVL+1) minor antecedent)
                                                         (vertex LVL NBR FML)
                                                         []
                                                         minor_dep,
                                                    edge (vertex (LVL+1) (minor+1) (antecedent>>FML))
                                                         (vertex LVL NBR FML)
                                                         []
                                                         major_dep ]
                                           ∧ OUT = [ edge (vertex LVL NBR FML)
                                                          (vertex (LVL-1) out_nbr out_frm)
                                                          []
                                                          (minor_dep ∪ major_dep) ]
                                           ∧ ANC = [] )
/- Neighborhood: Type 0 ⊇-Introduction -/
def introduction_neighborhood : neighborhood → Prop
| (dag (vertex LVL NBR FML) IN OUT ANC) := ( ∃(antecedent consequent out_frm : formula),
                                             ∃(intro out_nbr : ℕ),
                                             ∃(dep : set formula),
                                           ------------------------------------------------------
                                             FML = antecedent>>consequent
                                           ∧ IN = [ edge (vertex (LVL+1) intro antecedent)
                                                          (vertex LVL NBR FML)
                                                          []
                                                          {x | x = antecedent ∨ x ∈ dep} ]
                                           ∧ OUT = [edge (vertex LVL NBR FML)
                                                         (vertex (LVL-1) out_nbr out_frm)
                                                         []
                                                         {x | x ≠ antecedent ∧ x ∈ dep} ]
                                           ∧ ANC = [] )
/- Neighborhood: Type 0 Hypothesis -/
def hypothesis_neighborhood : neighborhood → Prop
| (dag (vertex LVL NBR FML) IN OUT ANC) := ( ∃(out_frm : formula),
                                             ∃(out_nbr : ℕ),
                                           ------------------------------------------------------
                                             IN = []
                                           ∧ OUT = [edge (vertex LVL NBR FML)
                                                         (vertex (LVL-1) out_nbr out_frm)
                                                         []
                                                         {FML} ]
                                           ∧ ANC = [] )

/- Colapse: -/
/- Conditions for Collapse -/
def check_nodes : neighborhood → neighborhood → Prop
| (dag (vertex LVL_U NBR_U FML_U) IN_U OUT_U ANC_U)
  (dag (vertex LVL_V NBR_V FML_V) IN_V OUT_V ANC_V) := (LVL_U = LVL_V)
                                                     ∧ (LVL_U > 0)
                                                     ∧ (LVL_V > 0)
                                                     ∧ (NBR_U ≠ NBR_V)
                                                     ∧ (FML_U = FML_V)
/- Colapse: Ancestral Edges-/
def loop_ancestral : ℕ → deduction → deduction → ancestral
| COLOUR
  (edge IN_STR IN_END IN_CLR IN_DEP)
  (edge OUT_STR OUT_END OUT_CLR OUT_DEP) := path OUT_END
                                                 IN_STR
                                                 [COLOUR]
def create_ancestral : ℕ → list deduction → list deduction → list ancestral
| COLOUR (HEAD::TAIL) [OUT] := (loop_ancestral COLOUR HEAD OUT)::(create_ancestral COLOUR TAIL [OUT])
| COLOUR IN OUT := []
/- Collapse: Neighborhoods -/
def pre_collapse : neighborhood → neighborhood
| (dag (vertex LVL NBR FML) IN OUT ANC) := dag (vertex LVL NBR FML)
                                               IN
                                               (list_deduction_paint OUT NBR)
                                               (create_ancestral NBR IN OUT)
def horizontal_collapse : neighborhood → neighborhood → neighborhood
| (dag (vertex LVL_U NBR_U FML_U) IN_U OUT_U ANC_U)
  (dag (vertex LVL_V NBR_V FML_V) IN_V OUT_V ANC_V) := dag (vertex LVL_U NBR_U FML_U)
                                                           (   IN_U
                                                            ++ list_deduction_rewrite IN_V
                                                                                (vertex LVL_V NBR_V FML_V)
                                                                                (vertex LVL_U NBR_U FML_U)   )
                                                           (   (list_deduction_paint OUT_U NBR_U)
                                                            ++ list_deduction_rewrite (list_deduction_paint OUT_V NBR_V)
                                                                                (vertex LVL_V NBR_V FML_V)
                                                                                (vertex LVL_U NBR_U FML_U)   )
                                                           (   (create_ancestral NBR_U IN_U OUT_U)
                                                            ++ list_ancestral_rewrite (create_ancestral NBR_V IN_V OUT_V)
                                                                                (vertex LVL_V NBR_V FML_V)
                                                                                (vertex LVL_U NBR_U FML_U)   )

/- Neighborhoods of Collapsed Nodes Without Incoming Ancestral Edges: -/
/- Neighborhood: Type 1 Ancestral Edges -/
def loop_loop_ancestral_set : deduction → deduction → ancestral
| (edge IN_STR IN_END IN_CLR IN_DEP)
  (edge OUT_STR OUT_END OUT_CLR OUT_DEP) := path OUT_END
                                                 IN_STR
                                                 OUT_CLR
def loop_ancestral_set : deduction → list deduction → list ancestral
| IN [] := []
| IN (HEAD::TAIL) := (loop_loop_ancestral_set IN HEAD)::(loop_ancestral_set IN TAIL)
def ancestral_set : list deduction → list deduction → list ancestral
| [] OUT := []
| (HEAD::TAIL) OUT := (loop_ancestral_set HEAD OUT) ++ (ancestral_set TAIL OUT)
/- Neighborhood: Type 1 Collapsed Node -/
def neighborhood_type_01 : neighborhood → Prop
| (dag (vertex LVL NBR FML) IN OUT ANC) := ( IN = IN
                                           ∧ OUT = OUT
                                           ∧ list.length ANC = list.length IN
                                           ∧ ∀(a : ancestral), a ∈ ANC → a ∈ ancestral_set IN OUT )

/- Proofs -/
lemma Add_Lemma :
  ∀{n : ℕ},
  ---------------------------
  ¬( n+1 = n )
| 0 := begin
  rewrite[nat.add_one 0],
  from nat.one_ne_zero,
end
| (n+1) := begin
  rewrite[←nat.succ_eq_add_one (n+1)],
  rewrite[←nat.succ_eq_add_one n],
  simp at ⊢,
  from Add_Lemma,
end
lemma Sub_Lemma :
  ∀{n : ℕ},
  ( n > 0 ) →
  ---------------------------
  ¬( n-1 = n )
| 0 := begin
  assume n_gt_zero,
  have not_n_gt_zero, from gt_irrefl 0,
  from false.elim (not_n_gt_zero n_gt_zero)
end
| (n+1) := begin
  assume n_gt_zero,
  rewrite[←nat.succ_eq_add_one n],
  simp at ⊢,
  have n_lt_succ, from nat.lt_succ_of_le (le_refl n),
  from ne_of_lt n_lt_succ
end

/- Proof Steps: -/
/- Rule 1: ⊇-Introduction = ⊇-Elimination -/
theorem Main_Theorem_Rule_01 :
  ∀(u v : neighborhood),
  ( check_nodes u v ) →
  ( introduction_neighborhood u ) →
  ( elimination_neighborhood v ) →
  ---------------------------
  ( neighborhood_type_01 (horizontal_collapse u v) )
| (dag (vertex LVL_U NBR_U FML_U) IN_U OUT_U ANC_U)
  (dag (vertex LVL_V NBR_V FML_V) IN_V OUT_V ANC_V) := begin
  assume prop_nodes prop_u prop_v,

  simp [check_nodes] at prop_nodes,
  cases prop_nodes with prop_eq_lvl prop_nodes,
  cases prop_nodes with prop_lvl_u prop_nodes,
  cases prop_nodes with prop_lvl_v prop_nodes,
  cases prop_nodes with prop_ne_nbr prop_eq_fml,

  simp [horizontal_collapse],

  simp [elimination_neighborhood] at prop_v,
  cases prop_v with antecedent_v prop_v,
  cases prop_v with out_frm_v prop_v,
  cases prop_v with minor_v prop_v,
  cases prop_v with out_nbr_v prop_v,
  cases prop_v with minor_dep_v prop_v,
  cases prop_v with major_dep_v prop_v,
  cases prop_v with prop_in_v prop_v,
  cases prop_v with prop_out_v prop_anc_v,

  rewrite [prop_in_v],
  simp [list_deduction_rewrite, deduction_rewrite],
  simp [node_rewrite, Add_Lemma],

  rewrite [prop_out_v],
  simp [list_deduction_paint, deduction_paint, colour_paint],
  simp [list_deduction_rewrite, deduction_rewrite],
  simp [node_rewrite, Sub_Lemma prop_lvl_v],

  simp [create_ancestral, loop_ancestral],
  simp [list_ancestral_rewrite, ancestral_rewrite],
  simp [node_rewrite, Add_Lemma, Sub_Lemma prop_lvl_v],

  simp [introduction_neighborhood] at prop_u,
  cases prop_u with antecedent_u prop_u,
  cases prop_u with consequent_u prop_u,
  cases prop_u with out_frm_u prop_u,
  cases prop_u with intro_u prop_u,
  cases prop_u with out_nbr_u prop_u,
  cases prop_u with dep_u prop_u,
  cases prop_u with prop_fml_u prop_u,
  cases prop_u with prop_in_u prop_u,
  cases prop_u with prop_out_u prop_anc_u,

  rewrite [prop_in_u, prop_out_u],
  simp [list_deduction_paint, deduction_paint, colour_paint],
  simp [create_ancestral, loop_ancestral],

  simp [neighborhood_type_01],
  simp [ancestral_set],
  simp [loop_ancestral_set],
  simp [loop_loop_ancestral_set],

  assume a a_cases,
  cases a_cases with a_case_01 a_cases,
  case or.inl { simp [a_case_01] },
  cases a_cases with a_case_02 a_case_03,
  case or.inl { simp [a_case_02] },
  case or.inr { simp [a_case_03] },
end
/- Rule 2: Hypothesis = ⊇-Elimination -/
theorem Main_Theorem_Rule_02 :
  ∀(u v : neighborhood),
  ( check_nodes u v ) →
  ( hypothesis_neighborhood u ) →
  ( elimination_neighborhood v ) →
  ---------------------------
  ( neighborhood_type_01 (horizontal_collapse u v) )
| (dag (vertex LVL_U NBR_U FML_U) IN_U OUT_U ANC_U)
  (dag (vertex LVL_V NBR_V FML_V) IN_V OUT_V ANC_V) := begin
  assume prop_nodes prop_u prop_v,

  simp [check_nodes] at prop_nodes,
  cases prop_nodes with prop_eq_lvl prop_nodes,
  cases prop_nodes with prop_lvl_u prop_nodes,
  cases prop_nodes with prop_lvl_v prop_nodes,
  cases prop_nodes with prop_ne_nbr prop_eq_fml,

  simp [horizontal_collapse],

  simp [elimination_neighborhood] at prop_v,
  cases prop_v with antecedent_v prop_v,
  cases prop_v with out_frm_v prop_v,
  cases prop_v with minor_v prop_v,
  cases prop_v with out_nbr_v prop_v,
  cases prop_v with minor_dep_v prop_v,
  cases prop_v with major_dep_v prop_v,
  cases prop_v with prop_in_v prop_v,
  cases prop_v with prop_out_v prop_anc_v,

  rewrite [prop_in_v],
  simp [list_deduction_rewrite, deduction_rewrite],
  simp [node_rewrite, Add_Lemma],

  rewrite [prop_out_v],
  simp [list_deduction_paint, deduction_paint, colour_paint],
  simp [list_deduction_rewrite, deduction_rewrite],
  simp [node_rewrite, Sub_Lemma prop_lvl_v],

  simp [create_ancestral, loop_ancestral],
  simp [list_ancestral_rewrite, ancestral_rewrite],
  simp [node_rewrite, Add_Lemma, Sub_Lemma prop_lvl_v],

  simp [hypothesis_neighborhood] at prop_u,
  cases prop_u with out_frm_u prop_u,
  cases prop_u with out_nbr_u prop_u,
  cases prop_u with prop_in_u prop_u,
  cases prop_u with prop_out_u prop_anc_u,

  rewrite [prop_in_u, prop_out_u],
  simp [list_deduction_paint, deduction_paint, colour_paint],
  simp [create_ancestral, loop_ancestral],

  simp [neighborhood_type_01],
  simp [ancestral_set],
  simp [loop_ancestral_set],
  simp [loop_loop_ancestral_set],

  assume a a_cases,
  cases a_cases with a_case_01 a_case_02,
  case or.inl { simp [a_case_01] },
  case or.inr { simp [a_case_02] },
end
/- Rule 3: ⊇-Introduction = Hypothesis -/
theorem Main_Theorem_Rule_03 :
  ∀(u v : neighborhood),
  ( check_nodes u v ) →
  ( introduction_neighborhood u ) →
  ( hypothesis_neighborhood v ) →
  ---------------------------
  ( neighborhood_type_01 (horizontal_collapse u v) )
| (dag (vertex LVL_U NBR_U FML_U) IN_U OUT_U ANC_U)
  (dag (vertex LVL_V NBR_V FML_V) IN_V OUT_V ANC_V) := begin
  assume prop_nodes prop_u prop_v,

  simp [check_nodes] at prop_nodes,
  cases prop_nodes with prop_eq_lvl prop_nodes,
  cases prop_nodes with prop_lvl_u prop_nodes,
  cases prop_nodes with prop_lvl_v prop_nodes,
  cases prop_nodes with prop_ne_nbr prop_eq_fml,

  simp [horizontal_collapse],

  simp [hypothesis_neighborhood] at prop_v,
  cases prop_v with out_frm_v prop_v,
  cases prop_v with out_nbr_v prop_v,
  cases prop_v with prop_in_v prop_v,
  cases prop_v with prop_out_v prop_anc_v,

  rewrite [prop_in_v],
  simp [list_deduction_rewrite, deduction_rewrite],

  rewrite [prop_out_v],
  simp [list_deduction_paint, deduction_paint, colour_paint],
  simp [list_deduction_rewrite, deduction_rewrite],
  simp [node_rewrite, Sub_Lemma prop_lvl_v],

  simp [create_ancestral, loop_ancestral],
  simp [list_ancestral_rewrite, ancestral_rewrite],

  simp [introduction_neighborhood] at prop_u,
  cases prop_u with antecedent_u prop_u,
  cases prop_u with consequent_u prop_u,
  cases prop_u with out_frm_u prop_u,
  cases prop_u with intro_u prop_u,
  cases prop_u with out_nbr_u prop_u,
  cases prop_u with dep_u prop_u,
  cases prop_u with prop_fml_u prop_u,
  cases prop_u with prop_in_u prop_u,
  cases prop_u with prop_out_u prop_anc_u,

  rewrite [prop_in_u, prop_out_u],
  simp [list_deduction_paint, deduction_paint, colour_paint],
  simp [create_ancestral, loop_ancestral],

  simp [neighborhood_type_01],
  simp [ancestral_set],
  simp [loop_ancestral_set],
  simp [loop_loop_ancestral_set],

  assume a a_cases,
  simp [a_cases],
end
/- Rule 4: Hypothesis = Hypothesis -/
theorem Main_Theorem_Rule_04 :
  ∀(u v : neighborhood),
  ( check_nodes u v ) →
  ( hypothesis_neighborhood u ) →
  ( hypothesis_neighborhood v ) →
  ---------------------------
  ( neighborhood_type_01 (horizontal_collapse u v) )
| (dag (vertex LVL_U NBR_U FML_U) IN_U OUT_U ANC_U)
  (dag (vertex LVL_V NBR_V FML_V) IN_V OUT_V ANC_V) := begin
  assume prop_nodes prop_u prop_v,

  simp [check_nodes] at prop_nodes,
  cases prop_nodes with prop_eq_lvl prop_nodes,
  cases prop_nodes with prop_lvl_u prop_nodes,
  cases prop_nodes with prop_lvl_v prop_nodes,
  cases prop_nodes with prop_ne_nbr prop_eq_fml,

  simp [horizontal_collapse],

  simp [hypothesis_neighborhood] at prop_v,
  cases prop_v with out_frm_v prop_v,
  cases prop_v with out_nbr_v prop_v,
  cases prop_v with prop_in_v prop_v,
  cases prop_v with prop_out_v prop_anc_v,

  rewrite [prop_in_v],
  simp [list_deduction_rewrite, deduction_rewrite],

  rewrite [prop_out_v],
  simp [list_deduction_paint, deduction_paint, colour_paint],
  simp [list_deduction_rewrite, deduction_rewrite],
  simp [node_rewrite, Sub_Lemma prop_lvl_v],

  simp [create_ancestral, loop_ancestral],
  simp [list_ancestral_rewrite, ancestral_rewrite],

  simp [hypothesis_neighborhood] at prop_u,
  cases prop_u with out_frm_u prop_u,
  cases prop_u with out_nbr_u prop_u,
  cases prop_u with prop_in_u prop_u,
  cases prop_u with prop_out_u prop_anc_u,

  rewrite [prop_in_u, prop_out_u],
  simp [list_deduction_paint, deduction_paint, colour_paint],
  simp [create_ancestral, loop_ancestral],

  simp [neighborhood_type_01],
  simp [ancestral_set],

  assume a a_cases,
  from false.elim a_cases,
end
/- New Rule 1: ⊇-Elimination = ⊇-Elimination -/
theorem Main_Theorem_New_Rule_01 :
  ∀(u v : neighborhood),
  ( check_nodes u v ) →
  ( elimination_neighborhood u ) →
  ( elimination_neighborhood v ) →
  ---------------------------
  ( neighborhood_type_01 (horizontal_collapse u v) )
| (dag (vertex LVL_U NBR_U FML_U) IN_U OUT_U ANC_U)
  (dag (vertex LVL_V NBR_V FML_V) IN_V OUT_V ANC_V) := begin
  assume prop_nodes prop_u prop_v,

  simp [check_nodes] at prop_nodes,
  cases prop_nodes with prop_eq_lvl prop_nodes,
  cases prop_nodes with prop_lvl_u prop_nodes,
  cases prop_nodes with prop_lvl_v prop_nodes,
  cases prop_nodes with prop_ne_nbr prop_eq_fml,

  simp [horizontal_collapse],

  simp [elimination_neighborhood] at prop_v,
  cases prop_v with antecedent_v prop_v,
  cases prop_v with out_frm_v prop_v,
  cases prop_v with minor_v prop_v,
  cases prop_v with out_nbr_v prop_v,
  cases prop_v with minor_dep_v prop_v,
  cases prop_v with major_dep_v prop_v,
  cases prop_v with prop_in_v prop_v,
  cases prop_v with prop_out_v prop_anc_v,

  rewrite [prop_in_v],
  simp [list_deduction_rewrite, deduction_rewrite],
  simp [node_rewrite, Add_Lemma],

  rewrite [prop_out_v],
  simp [list_deduction_paint, deduction_paint, colour_paint],
  simp [list_deduction_rewrite, deduction_rewrite],
  simp [node_rewrite, Sub_Lemma prop_lvl_v],

  simp [create_ancestral, loop_ancestral],
  simp [list_ancestral_rewrite, ancestral_rewrite],
  simp [node_rewrite, Add_Lemma, Sub_Lemma prop_lvl_v],

  simp [elimination_neighborhood] at prop_u,
  cases prop_u with antecedent_u prop_u,
  cases prop_u with out_frm_u prop_u,
  cases prop_u with minor_u prop_u,
  cases prop_u with out_nbr_u prop_u,
  cases prop_u with minor_dep_u prop_u,
  cases prop_u with major_dep_u prop_u,
  cases prop_u with prop_in_u prop_u,
  cases prop_u with prop_out_u prop_anc_u,

  rewrite [prop_in_u, prop_out_u],
  simp [list_deduction_paint, deduction_paint, colour_paint],
  simp [create_ancestral, loop_ancestral],

  simp [neighborhood_type_01],
  simp [ancestral_set],
  simp [loop_ancestral_set],
  simp [loop_loop_ancestral_set],

  assume a a_cases,
  cases a_cases with a_case_01 a_cases,
  case or.inl { simp [a_case_01] },
  cases a_cases with a_case_02 a_cases,
  case or.inl { simp [a_case_02] },
  cases a_cases with a_case_03 a_case_04,
  case or.inl { simp [a_case_03] },
  case or.inr { simp [a_case_04] },
end
/- New Rule 2: ⊇-Introduction = ⊇-Introduction -/
theorem Main_Theorem_New_Rule_02 :
  ∀(u v : neighborhood),
  ( check_nodes u v ) →
  ( introduction_neighborhood u ) →
  ( introduction_neighborhood v ) →
  ---------------------------
  ( neighborhood_type_01 (horizontal_collapse u v) )
| (dag (vertex LVL_U NBR_U FML_U) IN_U OUT_U ANC_U)
  (dag (vertex LVL_V NBR_V FML_V) IN_V OUT_V ANC_V) := begin
  assume prop_nodes prop_u prop_v,

  simp [check_nodes] at prop_nodes,
  cases prop_nodes with prop_eq_lvl prop_nodes,
  cases prop_nodes with prop_lvl_u prop_nodes,
  cases prop_nodes with prop_lvl_v prop_nodes,
  cases prop_nodes with prop_ne_nbr prop_eq_fml,

  simp [horizontal_collapse],

  simp [introduction_neighborhood] at prop_v,
  cases prop_v with antecedent_v prop_v,
  cases prop_v with consequent_v prop_v,
  cases prop_v with out_frm_v prop_v,
  cases prop_v with intro_v prop_v,
  cases prop_v with out_nbr_v prop_v,
  cases prop_v with dep_v prop_v,
  cases prop_v with prop_fml_v prop_v,
  cases prop_v with prop_in_v prop_v,
  cases prop_v with prop_out_v prop_anc_v,

  rewrite [prop_in_v],
  simp [list_deduction_rewrite, deduction_rewrite],
  simp [node_rewrite, Add_Lemma],

  rewrite [prop_out_v],
  simp [list_deduction_paint, deduction_paint, colour_paint],
  simp [list_deduction_rewrite, deduction_rewrite],
  simp [node_rewrite, Sub_Lemma prop_lvl_v],

  simp [create_ancestral, loop_ancestral],
  simp [list_ancestral_rewrite, ancestral_rewrite],
  simp [node_rewrite, Add_Lemma, Sub_Lemma prop_lvl_v],

  simp [introduction_neighborhood] at prop_u,
  cases prop_u with antecedent_u prop_u,
  cases prop_u with consequent_u prop_u,
  cases prop_u with out_frm_u prop_u,
  cases prop_u with intro_u prop_u,
  cases prop_u with out_nbr_u prop_u,
  cases prop_u with dep_u prop_u,
  cases prop_u with prop_fml_u prop_u,
  cases prop_u with prop_in_u prop_u,
  cases prop_u with prop_out_u prop_anc_u,

  rewrite [prop_in_u, prop_out_u],
  simp [list_deduction_paint, deduction_paint, colour_paint],
  simp [create_ancestral, loop_ancestral],

  simp [neighborhood_type_01],
  simp [ancestral_set],
  simp [loop_ancestral_set],
  simp [loop_loop_ancestral_set],

  assume a a_cases,
  cases a_cases with a_case_01 a_case_02,
  case or.inl { simp [a_case_01] },
  case or.inr { simp [a_case_02] },
end

/- Tests -/
constants LVL_U LVL_V : ℕ
--def LVL_U : ℕ := 10
--def LVL_V : ℕ := 10
constants NBR_U NBR_V : ℕ
--def NBR_U : ℕ := 1
--def NBR_V : ℕ := 2
constants FML_U FML_V : formula
--def FML_U : formula := #1
--def FML_V : formula := #2
constants minor_u out_nbr_u : ℕ
--def minor_u : ℕ := 11
--def out_nbr_u : ℕ := 13
constants antecedent_u out_frm_u : formula
--def antecedent_u : formula := #11
--def out_frm_u : formula := #13
constants minor_dep_u major_dep_u : set formula
--def minor_dep_u : set formula := ∅
--def major_dep_u : set formula := ∅
constants minor_v out_nbr_v : ℕ
--def minor_v : ℕ := 21
--def out_nbr_v : ℕ := 23
constants antecedent_v out_frm_v : formula
--def antecedent_v : formula := #21
--def out_frm_v : formula := #23
constants minor_dep_v major_dep_v : set formula
--def minor_dep_v : set formula := ∅
--def major_dep_v : set formula := ∅

--ancestral_set
--  [ edge ((LVL_U + 1)&&minor_u&&antecedent_u) (LVL_U&&NBR_U&&FML_U) [] minor_dep_u,
--    edge ((LVL_U + 1)&&(minor_u + 1)&&antecedent_u>>FML_U) (LVL_U&&NBR_U&&FML_U) [] major_dep_u,
--    edge ((LVL_V + 1)&&minor_v&&antecedent_v) (LVL_U&&NBR_U&&FML_U) [] minor_dep_v,
--	edge ((LVL_V + 1)&&(minor_v + 1)&&antecedent_v>>FML_V) (LVL_U&&NBR_U&&FML_U) [] major_dep_v ]
--  [ edge (LVL_U&&NBR_U&&FML_U) ((LVL_U - 1)&&out_nbr_u&&out_frm_u) [NBR_U] (minor_dep_u ∪ major_dep_u),
--    edge (LVL_U&&NBR_U&&FML_U) ((LVL_V - 1)&&out_nbr_v&&out_frm_v) [NBR_V] (minor_dep_v ∪ major_dep_v) ]
--=
--[ path (nat.pred LVL_U&&out_nbr_u&&out_frm_u) (nat.succ LVL_U&&minor_u&&antecedent_u) [NBR_U],
--  path (nat.pred LVL_V&&out_nbr_v&&out_frm_v) (nat.succ LVL_U&&minor_u&&antecedent_u) [NBR_V],
--  path (nat.pred LVL_U&&out_nbr_u&&out_frm_u) (nat.succ LVL_U&&nat.succ minor_u&&antecedent_u>>FML_U) [NBR_U],
--  path (nat.pred LVL_V&&out_nbr_v&&out_frm_v) (nat.succ LVL_U&&nat.succ minor_u&&antecedent_u>>FML_U) [NBR_V],
--  path (nat.pred LVL_U&&out_nbr_u&&out_frm_u) (nat.succ LVL_V&&minor_v&&antecedent_v) [NBR_U],
--  path (nat.pred LVL_V&&out_nbr_v&&out_frm_v) (nat.succ LVL_V&&minor_v&&antecedent_v) [NBR_V],
--  path (nat.pred LVL_U&&out_nbr_u&&out_frm_u) (nat.succ LVL_V&&nat.succ minor_v&&antecedent_v>>FML_V) [NBR_U],
--  path (nat.pred LVL_V&&out_nbr_v&&out_frm_v) (nat.succ LVL_V&&nat.succ minor_v&&antecedent_v>>FML_V) [NBR_V] ]

def ANC := ancestral_set  [ edge ((LVL_U + 1)&&minor_u&&antecedent_u) (LVL_U&&NBR_U&&FML_U) [] minor_dep_u, edge ((LVL_U + 1)&&(minor_u + 1)&&antecedent_u>>FML_U) (LVL_U&&NBR_U&&FML_U) [] major_dep_u, edge ((LVL_V + 1)&&minor_v&&antecedent_v) (LVL_U&&NBR_U&&FML_U) [] minor_dep_v, edge ((LVL_V + 1)&&(minor_v + 1)&&antecedent_v>>FML_V) (LVL_U&&NBR_U&&FML_U) [] major_dep_v ]  [ edge (LVL_U&&NBR_U&&FML_U) ((LVL_U - 1)&&out_nbr_u&&out_frm_u) [NBR_U] (minor_dep_u ∪ major_dep_u), edge (LVL_U&&NBR_U&&FML_U) ((LVL_V - 1)&&out_nbr_v&&out_frm_v) [NBR_V] (minor_dep_v ∪ major_dep_v) ]

#check ANC
#print ANC
#reduce ANC


import order.filter.basic -- the basics

/-
# Filters

## Introduction

A topological space structure on a type `α` is a collection of subsets of `α`
(the open sets) satisfying some axioms. A filter is a similar kind of thing --
it's a collection of subsets of `α` satisfying some different axioms.

Before we go into the formal definition, let us start with the picture.
A filter on `α` is an extremely powerful generalisation of the concept
of a subset of `α`. If `S : set α` is a subset, then there is a principal
filter `𝓟 S` corresponding to `S` -- it is just the collection of all subsets
of `α` which contain `S`. However there may be other filters on `α`
corresponding to things which are a bit more general than subsets. For example
if `α` is a topological space and `x : α` then there is a filter `𝓝 x`
corresponding to "an infinitesimal neighbourhood of `x`" even if
there is no smallest open set containing `x`. As another example, if `α` has an
ordering then there is a filter of "neighbourhoods of infinity" on `α` even
though there might be no `∞` in `α`.

If `F` is a filter, then you can think of `F` as a generalised kind of
subset `F` of `α`, and you should think of `S ∈ F` as meaning `F ⊆ S`.
Keeping this in mind will help to motivate the axioms below.

## Definition

Here's the formal definition. A filter on `α` is a collection `F` of subsets
of `α` satisfying the following three axioms:

1) `α ∈ F` (in Lean this is written `univ ∈ F` because a distinction is made
between the type `α` and the term `univ : set α` corresponding to `α`)

2) If `S ∈ F` and `S ⊆ T` then `T ∈ F` -- i.e. `F` is "upwards-closed",

3) If `A ∈ F` and `B ∈ F` then `A ∩ B ∈ F` -- i.e. `F` is closed under
binary intersections.

Note that (1) and (3) together imply (and are indeed equivalent to)
the statement that `F` is closed under all finite intersections,
i.e. the intersection of finitely many elements of `F` is in `F`.

Here's the Lean definition:

```
structure filter (α : Type*) :=
(sets                   : set (set α))
(univ_sets              : set.univ ∈ sets)
(sets_of_superset {x y} : x ∈ sets → x ⊆ y → y ∈ sets)
(inter_sets {x y}       : x ∈ sets → y ∈ sets → x ∩ y ∈ sets)
```

In words, `filter α` is the type of filters on `α`, so to give a filter
on `α` is to give a term `F : filter α` of type `filter α`. To make a term
of type `filter α` you need to give a collection `sets` of subsets of `α`
and then three proofs of the three axioms.

A rather simple example of a filter is the filter of *all* subsets of `α`.
Those of you who have seen definitions of filters in other places (for
example in Bourbaki) might have seen an extra axiom in the definition of a
filter, saying that a filter is not allowed to be the collection of all
subsets of `α`. This turns out to be rather an unnatural axiom, it is like
demanding in ideal theory that if `R` is a ring then `R` is not allowed to be
an ideal of `R`. An advantage of such a definition of an ideal would be that
a maximal ideal of `R` would literally be a maximal element of the ideals
of `R`, but this advantage is outweighed by the disadvantage that the
definition then becomes much less functorial -- e.g. the image of an ideal
along a ring homomorphism might not be an ideal, you cannot in general add two
ideals etc). To preserve the functoriality of filters, mathlib does not have
this Bourbaki axiom as an axiom for filters. As a result there are two
"extreme" filters on `α`, namely the one which only contains
`univ` (note that this is forced by `univ_sets`), and then the one we mentioned
above, which contains all subsets of `α`. These two filters are called
`⊥` and `⊤`, although you might be surprised to find out which one is which!
The filter consisting of all subsets of `α` is the one corresponding to
the empty set, so it is `⊥`, and the one consisting of just `univ` is the
one corresponding to the whole of `α` so it is `⊤`.

## Notation, helpful tactics and helpful theorems

We are not going to build filters from first principles, we will be
using Lean's API for filters.

Say `α : Type` and `F : filter α` and `S : set α`. The notation `S ∈ F` is
defined to mean `S ∈ F.sets`.

The `ext` tactic can be used to reduce a goal `F = G` to a goal of
the form `∀ S, S ∈ F ↔ S ∈ G`.

The fields of the structure mention things like `S ∈ F.sets`, so the
axioms are restated with different names, but using the `S ∈ F` notation.
The lemmas corresponding to the definitions are:

`univ_mem_sets : univ ∈ F`
`mem_sets_of_superset : S ∈ F → S ⊆ T → T ∈ F`
`inter_mem_sets : S ∈ F → T ∈ F → S ∩ T ∈ F`

These lemmas in the `filter` namespace, i.e. their full names are
`filter.univ_mem_sets` etc. But we are about to say `open filter`
which means that you don't have to type this `filter.` thing in front of every
lemma you need about filters. In fact we'll also be using a bunch of
stuff about sets, like `set.inter_subset_left`, so why don't we `open set`
as well.
-/

open filter set

-- Variables!
-- let `α` be a type, let `F` be a filter on `α`, and let `S` and `T`
-- denote subsets of `α`.

variables (α : Type) (F : filter α) (S T : set α)

/-
Here's a lemma about filters: Two sets `S` and `T` are both in
a filter `F` iff their intersection is. See if you can deduce
it from the axioms of a filter.

For this one it's useful to know the following results (from the set namespace)
`inter_subset_left S T : S ∩ T ⊆ S`
and
`inter_subset_right S T : S ∩ T ⊆ T`
-/
example : S ∩ T ∈ F ↔ S ∈ F ∧ T ∈ F :=
begin
  sorry,
end

/-
The principal filter `𝓟 X` generated by `X : set α` is the subsets of `α`
which contain `X`. Prove that it's a filter.

Helpful for this exercise:
`mem_univ s : s ∈ univ`
`subset.trans : A ⊆ B → B ⊆ C → A ⊆ C`
`subset_inter : X ⊆ S → X ⊆ T → X ⊆ S ∩ T`
(note that you could probably prove those last two things directly yourself,
but we may as well use the interface for sets given that it's there)
`mem_set_of_eq : x ∈ {a : α | p a} = p x`
(this one is definitional, so you could use `change` instead, or just
not rewrite it at all)
-/

-- this is called `𝓟 X` in mathlib but let's just make it ourselves.
example (X : set α) : filter α :=
{ sets := {S : set α | X ⊆ S},
  univ_sets := begin
    sorry,
  end,
  sets_of_superset := begin
    sorry,
  end,
  inter_sets := begin
    sorry,
  end }

-- The notation for the principal filter generated by `X : set α` is `𝓟 X`.
-- This notation is in the "filter locale", which is just a posh way
-- of saying that you have to type

open_locale filter

-- in order to get the notation.

/-

## The order (≤) on filters

The following is unsurprising: the collection of all filters on `α` is
partially ordered. Perhaps more surprising: the order is the other way
around to what you think it should be! If `F` and `G` are filters
on `α`, then `F ≤ G` is defined to mean that `G.sets ⊆ F.sets`, i.e.
every set in the `G`-filter is also in the `F`-filter. Why is this?
Well, think about principal filters. If `S ⊆ T` are two subsets,
then `X ∈ 𝓟 T` implies `T ⊆ X`, so `S ⊆ X`, so `X ∈ 𝓟 S`.
The smaller the set, the bigger the collection of sets in the filter.

Let's formalise this. Show that 𝓟 S ≤ 𝓟 T ↔ S ⊆ T.
Note that this is called `principal_mono` in mathlib but
there's no harm in proving it yourself.

Some helpful lemmas:
`mem_principal_sets : T ∈ 𝓟 S ↔ S ⊆ T`
`mem_principal_self S : S ∈ 𝓟 S`
`le_def : F ≤ G ↔ ∀ (S : set α), S ∈ G → S ∈ F`
-/
example (S T : set α) : 𝓟 S ≤ 𝓟 T ↔ S ⊆ T :=
begin
  sorry,
end

-- Here's another useful lemma about principal filters.
-- It's called `le_principal_iff` in mathlib but why
-- not try proving it yourself?

example : F ≤ 𝓟 S ↔ S ∈ F :=
begin
  sorry,
end

/-

## Filters are a complete lattice

Just like it's possible to talk about the topological space generated
by a collection of subsets of `α` -- this is the smallest topology
for which the given subsets are all open -- it's also possible to talk
about the filter generated by a collection of subsets of `α`. One
can define it as the intersection of all the filters that contain your
given collection of subsets.

In order theory, given a partial order (like the partial order on filters)
you can start asking whether infs and sups exist. Filters are an example
where all these things exist (finite and infinite infs and sups) and they
satisfy a natural collection of axioms, making them into what is called a
*complete lattice*. One can prove this by showing that "filter generated by
these sets" and "underlying sets of a filter" are adjoint functors and then
using the theory of Galois insertions. I talked about this a bit when doing
subgroups, and won't talk about it again.

-/

/-

## Other examples of filters.

### `at_top` filter on a totally ordered set

Let `L` be a non-empty totally ordered set. Let's say that a subset `X` of `L` is
"big" if there exists `x : L` such for all `y ≥ x`, `y ∈ X`.

I claim that the big subsets are a filter. Check this. The mathematical idea
is that the "big subsets" are the neighbourhoods of `∞`, so the corresponding
filter is some representation of an infinitesimal neighbourhood of `∞`.

Implementation notes: `linear_order L` is the type of linear orders on `L`.
`e : L` is just an easy way of saying that `L` is nonempty.

Recall that `max x y` is the max of x and y in a `linear_order`, and
`le_max_left a b : a ≤ max a b` and similarly `le_max_right`.
-/
def at_top (L : Type) [linear_order L] (e : L) : filter L :=
{ sets := {X : set L | ∃ x : L, ∀ y, x ≤ y → y ∈ X},
  univ_sets := begin
    sorry,
  end,
  sets_of_superset := begin
    sorry,
  end,
  inter_sets := begin
    sorry,
  end }

/-

### the cofinite filter

The _cofinite filter_ on a type `α` has as its sets the subsets `S : set α`
with the property that `Sᶜ`, the complement of `S`, is finite.
Let's show that these are a filter.

Things you might find helpful:

`compl_univ : univᶜ = ∅`
`finite_empty : finite ∅`
`compl_subset_compl : Xᶜ ⊆ Yᶜ ↔ Y ⊆ X`
`finite.subset : S.finite → ∀ {T : set α}, T ⊆ S → T.finite`
`compl_inter S T : (S ∩ T)ᶜ = Sᶜ ∪ Tᶜ`
`finite.union : S.finite → T.finite → (S ∪ T).finite`

NB if you are thinking "I could never use Lean by myself, I don't know
the names of all the lemmas so I have to rely on Kevin telling them all to
me" then what you don't realise is that I myself don't know the names
of all the lemmas either -- I am literally just guessing them and pressing
ctrl-space to check. Look at the names of the lemmas and begin to understand
that you can probably guess them yourself.
-/

def cofinite (α : Type) : filter α :=
{ sets := { S : set α | (Sᶜ).finite },
  univ_sets := begin
    sorry,
  end,
  sets_of_superset := begin
    sorry,
  end,
  inter_sets := begin
    sorry,
  end }

/-

### Exercises (to do on paper):

You don't need to be able to do these in order to move onto the topology part
of this workshop.

(1) prove that the cofinite filter on a finite type is the entire power set filter.
(2) prove that the cofinite filter on `ℕ` is equal to the `at_top` filter.
(3) Prove that the cofinite filter on `ℤ` is not equal to the `at_top` filter.
(4) Prove that the cofinite filter on `ℕ` is not principal.

You can try them in Lean but you will have to be a master of finiteness.
Here, for example, are some of the ideas you'll need to do (4) in Lean.
The proof uses a bunch of lemmas from the set API.

Here are some of the things I used:

`filter.ext_iff : F = G ↔ ∀ (S : set α), s ∈ F ↔ s ∈ G`

Facts about `S \ {a}` and other sets:

`diff_eq_compl_inter`, `compl_inter`, `compl_compl`, `finite_singleton`,
`mem_diff_singleton`.

I also needed the following two lemmas, which weren't in mathlib
so I had to prove them myself (my proof of the first one was longer;
thanks to Yakov Pechersky on Zulip for coming up with the one-linear)
-/

lemma infinite_of_finite_compl {α : Type} [infinite α] {s : set α}
  (hs : sᶜ.finite) : s.infinite :=
λ h, set.infinite_univ (by simpa using hs.union h)

lemma set.infinite.nonempty {α} {s : set α} (h : s.infinite) : ∃ a : α, a ∈ s :=
let a := set.infinite.nat_embedding s h 37 in ⟨a.1, a.2⟩

-- This is also convenient for rewriting purposes:
lemma mem_cofinite {S : set ℕ} : S ∈ cofinite ℕ ↔ Sᶜ.finite :=
begin
  -- true by definition
  refl
end

-- Here's a proof which I formalised: if natural_cofinite = 𝓟 S then S must
-- be cofinite and hence infinite and hence non-empty, but then if a ∈ S
-- then S \ {a} causes us problems as it's cofinite but doesn't contain `S`.
-- This is harder than anything else in this file and is not necessary
-- for the application to topological spaces in Part B so feel free
-- to skip it.
theorem cofinite_not_principal : ∀ S : set ℕ, cofinite ℕ ≠ 𝓟 S :=
begin
  sorry,
end


/-
Copyright (c) 2020 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 category_theory.graded_object
! leanprover-community/mathlib commit 6876fa15e3158ff3e4a4e2af1fb6e1945c6e8803
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.GroupPower.Lemmas
import Mathbin.CategoryTheory.Pi.Basic
import Mathbin.CategoryTheory.Shift.Basic
import Mathbin.CategoryTheory.ConcreteCategory.Basic

/-!
# The category of graded objects

For any type `β`, a `β`-graded object over some category `C` is just
a function `β → C` into the objects of `C`.
We put the "pointwise" category structure on these, as the non-dependent specialization of
`category_theory.pi`.

We describe the `comap` functors obtained by precomposing with functions `β → γ`.

As a consequence a fixed element (e.g. `1`) in an additive group `β` provides a shift
functor on `β`-graded objects

When `C` has coproducts we construct the `total` functor `graded_object β C ⥤ C`,
show that it is faithful, and deduce that when `C` is concrete so is `graded_object β C`.
-/

open CategoryTheory.pi

open CategoryTheory.Limits

namespace CategoryTheory

universe w v u

/-- A type synonym for `β → C`, used for `β`-graded objects in a category `C`. -/
def GradedObject (β : Type w) (C : Type u) : Type max w u :=
  β → C
#align category_theory.graded_object CategoryTheory.GradedObject

-- Satisfying the inhabited linter...
instance inhabitedGradedObject (β : Type w) (C : Type u) [Inhabited C] :
    Inhabited (GradedObject β C) :=
  ⟨fun b => Inhabited.default⟩
#align category_theory.inhabited_graded_object CategoryTheory.inhabitedGradedObject

-- `s` is here to distinguish type synonyms asking for different shifts
/-- A type synonym for `β → C`, used for `β`-graded objects in a category `C`
with a shift functor given by translation by `s`.
-/
@[nolint unused_arguments]
abbrev GradedObjectWithShift {β : Type w} [AddCommGroup β] (s : β) (C : Type u) : Type max w u :=
  GradedObject β C
#align category_theory.graded_object_with_shift CategoryTheory.GradedObjectWithShift

namespace GradedObject

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

instance categoryOfGradedObjects (β : Type w) : Category.{max w v} (GradedObject β C) :=
  CategoryTheory.pi fun _ => C
#align category_theory.graded_object.category_of_graded_objects CategoryTheory.GradedObject.categoryOfGradedObjects

/-- The projection of a graded object to its `i`-th component. -/
@[simps]
def eval {β : Type w} (b : β) : GradedObject β C ⥤ C
    where
  obj X := X b
  map X Y f := f b
#align category_theory.graded_object.eval CategoryTheory.GradedObject.eval

section

variable (C)

/-- The natural isomorphism comparing between
pulling back along two propositionally equal functions.
-/
@[simps]
def comapEq {β γ : Type w} {f g : β → γ} (h : f = g) : comap (fun _ => C) f ≅ comap (fun _ => C) g
    where
  Hom := { app := fun X b => eqToHom (by dsimp [comap]; subst h) }
  inv := { app := fun X b => eqToHom (by dsimp [comap]; subst h) }
#align category_theory.graded_object.comap_eq CategoryTheory.GradedObject.comapEq

theorem comapEq_symm {β γ : Type w} {f g : β → γ} (h : f = g) :
    comapEq C h.symm = (comapEq C h).symm := by tidy
#align category_theory.graded_object.comap_eq_symm CategoryTheory.GradedObject.comapEq_symm

theorem comapEq_trans {β γ : Type w} {f g h : β → γ} (k : f = g) (l : g = h) :
    comapEq C (k.trans l) = comapEq C k ≪≫ comapEq C l :=
  by
  ext (X b)
  simp
#align category_theory.graded_object.comap_eq_trans CategoryTheory.GradedObject.comapEq_trans

@[simp]
theorem eqToHom_apply {β : Type w} {X Y : ∀ b : β, C} (h : X = Y) (b : β) :
    (eqToHom h : X ⟶ Y) b = eqToHom (by subst h) :=
  by
  subst h
  rfl
#align category_theory.graded_object.eq_to_hom_apply CategoryTheory.GradedObject.eqToHom_apply

/-- The equivalence between β-graded objects and γ-graded objects,
given an equivalence between β and γ.
-/
@[simps]
def comapEquiv {β γ : Type w} (e : β ≃ γ) : GradedObject β C ≌ GradedObject γ C
    where
  Functor := comap (fun _ => C) (e.symm : γ → β)
  inverse := comap (fun _ => C) (e : β → γ)
  counitIso :=
    (comapComp (fun _ => C) _ _).trans
      (comapEq C
        (by
          ext
          simp))
  unitIso :=
    (comapEq C
          (by
            ext
            simp)).trans
      (comapComp _ _ _).symm
  functor_unitIso_comp' X := by
    ext b
    dsimp
    simp
#align category_theory.graded_object.comap_equiv CategoryTheory.GradedObject.comapEquiv

-- See note [dsimp, simp].
end

instance hasShift {β : Type _} [AddCommGroup β] (s : β) : HasShift (GradedObjectWithShift s C) ℤ :=
  hasShiftMk _ _
    { f := fun n => comap (fun _ => C) fun b : β => b + n • s
      zero :=
        comapEq C
            (by
              ext
              simp) ≪≫
          comapId β fun _ => C
      add := fun m n =>
        comapEq C
            (by
              ext
              simp [add_zsmul, add_comm]) ≪≫
          (comapComp _ _ _).symm
      assoc_hom_app := fun m₁ m₂ m₃ X => by
        ext
        dsimp
        simp
      zero_add_hom_app := fun n X => by
        ext
        dsimp
        simpa
      add_zero_hom_app := fun n X => by
        ext
        dsimp
        simpa }
#align category_theory.graded_object.has_shift CategoryTheory.GradedObject.hasShift

@[simp]
theorem shiftFunctor_obj_apply {β : Type _} [AddCommGroup β] (s : β) (X : β → C) (t : β) (n : ℤ) :
    (shiftFunctor (GradedObjectWithShift s C) n).obj X t = X (t + n • s) :=
  rfl
#align category_theory.graded_object.shift_functor_obj_apply CategoryTheory.GradedObject.shiftFunctor_obj_apply

@[simp]
theorem shiftFunctor_map_apply {β : Type _} [AddCommGroup β] (s : β)
    {X Y : GradedObjectWithShift s C} (f : X ⟶ Y) (t : β) (n : ℤ) :
    (shiftFunctor (GradedObjectWithShift s C) n).map f t = f (t + n • s) :=
  rfl
#align category_theory.graded_object.shift_functor_map_apply CategoryTheory.GradedObject.shiftFunctor_map_apply

instance hasZeroMorphisms [HasZeroMorphisms C] (β : Type w) :
    HasZeroMorphisms.{max w v} (GradedObject β C) where Zero X Y := { zero := fun b => 0 }
#align category_theory.graded_object.has_zero_morphisms CategoryTheory.GradedObject.hasZeroMorphisms

@[simp]
theorem zero_apply [HasZeroMorphisms C] (β : Type w) (X Y : GradedObject β C) (b : β) :
    (0 : X ⟶ Y) b = 0 :=
  rfl
#align category_theory.graded_object.zero_apply CategoryTheory.GradedObject.zero_apply

section

open ZeroObject

instance hasZeroObject [HasZeroObject C] [HasZeroMorphisms C] (β : Type w) :
    HasZeroObject.{max w v} (GradedObject β C) := by
  refine'
      ⟨⟨fun b => 0, fun X => ⟨⟨⟨fun b => 0⟩, fun f => _⟩⟩, fun X =>
          ⟨⟨⟨fun b => 0⟩, fun f => _⟩⟩⟩⟩ <;>
    ext
#align category_theory.graded_object.has_zero_object CategoryTheory.GradedObject.hasZeroObject

end

end GradedObject

namespace GradedObject

-- The universes get a little hairy here, so we restrict the universe level for the grading to 0.
-- Since we're typically interested in grading by ℤ or a finite group, this should be okay.
-- If you're grading by things in higher universes, have fun!
variable (β : Type)

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

variable [HasCoproducts.{0} C]

section

attribute [local tidy] tactic.discrete_cases

/-- The total object of a graded object is the coproduct of the graded components.
-/
noncomputable def total : GradedObject β C ⥤ C
    where
  obj X := ∐ fun i : β => X i
  map X Y f := Limits.Sigma.map fun i => f i
#align category_theory.graded_object.total CategoryTheory.GradedObject.total

end

variable [HasZeroMorphisms C]

/--
The `total` functor taking a graded object to the coproduct of its graded components is faithful.
To prove this, we need to know that the coprojections into the coproduct are monomorphisms,
which follows from the fact we have zero morphisms and decidable equality for the grading.
-/
instance : Faithful (total β C)
    where map_injective' X Y f g w := by
    classical
      ext i
      replace w := sigma.ι (fun i : β => X i) i ≫= w
      erw [colimit.ι_map, colimit.ι_map] at w
      simp at *
      exact mono.right_cancellation _ _ w

end GradedObject

namespace GradedObject

noncomputable section

variable (β : Type)

variable (C : Type (u + 1)) [LargeCategory C] [ConcreteCategory C] [HasCoproducts.{0} C]
  [HasZeroMorphisms C]

instance : ConcreteCategory (GradedObject β C) where forget := total β C ⋙ forget C

instance : HasForget₂ (GradedObject β C) C where forget₂ := total β C

end GradedObject

end CategoryTheory


import .abstract

variables {α : Type*} [bounded_graded α] {a : α}

/-- Connectivity is reflexive. -/
@[refl]
theorem connected.refl : proper a → connected a a :=
connected.start a

variable {b : α}

/-- Comparable proper elements are connected. -/
theorem comp_to_connected (ha : proper a) : proper b → comparable a b → connected a b :=
(connected.next a a b) (connected.refl ha)

/-- If `a` and `b` are comparable proper elements, and `b` and `c` are connected,
    then `a` and `c` are connected. -/
lemma connected.append {c : α} (ha : proper a) (hab : comparable a b) (hbc : connected b c) :
  connected a c :=
begin
  induction hbc with _ hx _ y z _ hz hyz h,
    { exact comp_to_connected ha hx hab },
    { exact (connected.next a y z) (h hab) hz hyz }
end

/-- Connectedness is symmetric. -/
@[symm]
theorem connected.symm (hab : connected a b) : connected b a :=
begin
  induction hab with a pa _ _ _ _ pz hyz hyx,
    { exact connected.start a pa },
    { exact connected.append pz hyz.symm hyx }
end

/-- If `a` and `b` are comparable, then `a` is proper. -/
lemma connected.proper (hab : connected a b) : proper a :=
by induction hab with _ h _ _ _ _ _ _ h; exact h

/-- If `a` and `b` are comparable, then `b` is proper. -/
lemma connected.proper' (hab : connected a b) : proper b :=
hab.symm.proper

/-- Connectedness is transitive. -/
theorem connected.trans {c : α} (hab : connected a b) (hbc : connected b c) : connected a c :=
begin
  induction hab with _ _ _ _ _ hxy _ hyz h,
    { exact hbc },
    { exact h (connected.append hxy.proper' hyz hbc) }
end