/-
Copyright (c) 2018 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau, Chris Hughes, Mario Carneiro
-/
import algebra.associated
import linear_algebra.basic
import order.zorn
import order.atoms
import order.compactly_generated
/-!

# Ideals over a ring

This file defines `ideal R`, the type of ideals over a commutative ring `R`.

## Implementation notes

`ideal R` is implemented using `submodule R R`, where `•` is interpreted as `*`.

## TODO

Support one-sided ideals, and ideals over non-commutative rings.

See `algebra.ring_quot` for quotients of non-commutative rings.
-/

universes u v w
variables {α : Type u} {β : Type v}
open set function

open_locale classical big_operators

/-- An ideal in a commutative semiring `R` is an additive submonoid `s` such that
`a * b ∈ s` whenever `b ∈ s`. If `R` is a ring, then `s` is an additive subgroup.  -/
@[reducible] def ideal (R : Type u) [comm_semiring R] := submodule R R

section comm_semiring

namespace ideal
variables [comm_semiring α] (I : ideal α) {a b : α}

protected lemma zero_mem : (0 : α) ∈ I := I.zero_mem

protected lemma add_mem : a ∈ I → b ∈ I → a + b ∈ I := I.add_mem

variables (a)
lemma mul_mem_left : b ∈ I → a * b ∈ I := I.smul_mem a
variables {a}

variables (b)
lemma mul_mem_right (h : a ∈ I) : a * b ∈ I := mul_comm b a ▸ I.mul_mem_left b h
variables {b}

lemma pow_mem_of_mem (ha : a ∈ I) (n : ℕ) (hn : 0 < n) : a ^ n ∈ I :=
nat.cases_on n (not.elim dec_trivial) (λ m hm, (pow_succ a m).symm ▸ I.mul_mem_right (a^m) ha) hn

end ideal

variables {a b : α}

-- A separate namespace definition is needed because the variables were historically in a different
-- order.
namespace ideal
variables [comm_semiring α] (I : ideal α)

@[ext] lemma ext {I J : ideal α} (h : ∀ x, x ∈ I ↔ x ∈ J) : I = J :=
submodule.ext h

theorem eq_top_of_unit_mem
  (x y : α) (hx : x ∈ I) (h : y * x = 1) : I = ⊤ :=
eq_top_iff.2 $ λ z _, calc
    z = z * (y * x) : by simp [h]
  ... = (z * y) * x : eq.symm $ mul_assoc z y x
  ... ∈ I : I.mul_mem_left _ hx

theorem eq_top_of_is_unit_mem {x} (hx : x ∈ I) (h : is_unit x) : I = ⊤ :=
let ⟨y, hy⟩ := is_unit_iff_exists_inv'.1 h in eq_top_of_unit_mem I x y hx hy

theorem eq_top_iff_one : I = ⊤ ↔ (1:α) ∈ I :=
⟨by rintro rfl; trivial,
 λ h, eq_top_of_unit_mem _ _ 1 h (by simp)⟩

theorem ne_top_iff_one : I ≠ ⊤ ↔ (1:α) ∉ I :=
not_congr I.eq_top_iff_one

@[simp]
theorem unit_mul_mem_iff_mem {x y : α} (hy : is_unit y) : y * x ∈ I ↔ x ∈ I :=
begin
  refine ⟨λ h, _, λ h, I.mul_mem_left y h⟩,
  obtain ⟨y', hy'⟩ := is_unit_iff_exists_inv.1 hy,
  have := I.mul_mem_left y' h,
  rwa [← mul_assoc, mul_comm y' y, hy', one_mul] at this,
end

@[simp]
theorem mul_unit_mem_iff_mem {x y : α} (hy : is_unit y) : x * y ∈ I ↔ x ∈ I :=
mul_comm y x ▸ unit_mul_mem_iff_mem I hy

/-- The ideal generated by a subset of a ring -/
def span (s : set α) : ideal α := submodule.span α s

lemma subset_span {s : set α} : s ⊆ span s := submodule.subset_span

lemma span_le {s : set α} {I} : span s ≤ I ↔ s ⊆ I := submodule.span_le

lemma span_mono {s t : set α} : s ⊆ t → span s ≤ span t := submodule.span_mono

@[simp] lemma span_eq : span (I : set α) = I := submodule.span_eq _

@[simp] lemma span_singleton_one : span (1 : set α) = ⊤ :=
(eq_top_iff_one _).2 $ subset_span $ mem_singleton _

lemma mem_span_insert {s : set α} {x y} :
  x ∈ span (insert y s) ↔ ∃ a (z ∈ span s), x = a * y + z := submodule.mem_span_insert

lemma mem_span_singleton' {x y : α} :
  x ∈ span ({y} : set α) ↔ ∃ a, a * y = x := submodule.mem_span_singleton

lemma mem_span_singleton {x y : α} :
  x ∈ span ({y} : set α) ↔ y ∣ x :=
mem_span_singleton'.trans $ exists_congr $ λ _, by rw [eq_comm, mul_comm]

lemma span_singleton_le_span_singleton {x y : α} :
  span ({x} : set α) ≤ span ({y} : set α) ↔ y ∣ x :=
span_le.trans $ singleton_subset_iff.trans mem_span_singleton

lemma span_singleton_eq_span_singleton {α : Type u} [integral_domain α] {x y : α} :
  span ({x} : set α) = span ({y} : set α) ↔ associated x y :=
begin
  rw [←dvd_dvd_iff_associated, le_antisymm_iff, and_comm],
  apply and_congr;
  rw span_singleton_le_span_singleton,
end

lemma span_eq_bot {s : set α} : span s = ⊥ ↔ ∀ x ∈ s, (x:α) = 0 := submodule.span_eq_bot

@[simp] lemma span_singleton_eq_bot {x} : span ({x} : set α) = ⊥ ↔ x = 0 :=
submodule.span_singleton_eq_bot

@[simp] lemma span_zero : span (0 : set α) = ⊥ := by rw [←set.singleton_zero, span_singleton_eq_bot]

lemma span_singleton_eq_top {x} : span ({x} : set α) = ⊤ ↔ is_unit x :=
by rw [is_unit_iff_dvd_one, ← span_singleton_le_span_singleton, singleton_one, span_singleton_one,
  eq_top_iff]

lemma span_singleton_mul_right_unit {a : α} (h2 : is_unit a) (x : α) :
  span ({x * a} : set α) = span {x} :=
begin
  apply le_antisymm,
  { rw span_singleton_le_span_singleton, use a},
  { rw span_singleton_le_span_singleton, rw is_unit.mul_right_dvd h2}
end

lemma span_singleton_mul_left_unit {a : α} (h2 : is_unit a) (x : α) :
  span ({a * x} : set α) = span {x} := by rw [mul_comm, span_singleton_mul_right_unit h2]

/--
The ideal generated by an arbitrary binary relation.
-/
def of_rel (r : α → α → Prop) : ideal α :=
submodule.span α { x | ∃ (a b) (h : r a b), x + b = a }

/-- An ideal `P` of a ring `R` is prime if `P ≠ R` and `xy ∈ P → x ∈ P ∨ y ∈ P` -/
class is_prime (I : ideal α) : Prop :=
(ne_top' : I ≠ ⊤)
(mem_or_mem' : ∀ {x y : α}, x * y ∈ I → x ∈ I ∨ y ∈ I)

theorem is_prime_iff {I : ideal α} :
  is_prime I ↔ I ≠ ⊤ ∧ ∀ {x y : α}, x * y ∈ I → x ∈ I ∨ y ∈ I :=
⟨λ h, ⟨h.1, h.2⟩, λ h, ⟨h.1, h.2⟩⟩

theorem is_prime.ne_top {I : ideal α} (hI : I.is_prime) : I ≠ ⊤ := hI.1

theorem is_prime.mem_or_mem {I : ideal α} (hI : I.is_prime) :
  ∀ {x y : α}, x * y ∈ I → x ∈ I ∨ y ∈ I := hI.2

theorem is_prime.mul_mem_iff_mem_or_mem {I : ideal α} (hI : I.is_prime) :
  ∀ {x y : α}, x * y ∈ I ↔ x ∈ I ∨ y ∈ I :=
λ x y, ⟨hI.mem_or_mem, by { rintro (h | h), exacts [I.mul_mem_right y h, I.mul_mem_left x h] }⟩

theorem is_prime.mem_or_mem_of_mul_eq_zero {I : ideal α} (hI : I.is_prime)
  {x y : α} (h : x * y = 0) : x ∈ I ∨ y ∈ I :=
hI.mem_or_mem (h.symm ▸ I.zero_mem)

theorem is_prime.mem_of_pow_mem {I : ideal α} (hI : I.is_prime)
  {r : α} (n : ℕ) (H : r^n ∈ I) : r ∈ I :=
begin
  induction n with n ih,
  { rw pow_zero at H, exact (mt (eq_top_iff_one _).2 hI.1).elim H },
  { rw pow_succ at H, exact or.cases_on (hI.mem_or_mem H) id ih }
end

theorem is_prime.pow_mem_iff_mem {I : ideal α} (hI : I.is_prime)
  {r : α} (n : ℕ) (hn : 0 < n) : r ^ n ∈ I ↔ r ∈ I :=
⟨hI.mem_of_pow_mem n, (λ hr, I.pow_mem_of_mem hr n hn)⟩

lemma not_is_prime_iff {I : ideal α} : ¬ I.is_prime ↔ I = ⊤ ∨ ∃ (x ∉ I) (y ∉ I), x * y ∈ I :=
begin
  simp_rw [ideal.is_prime_iff, not_and_distrib, ne.def, not_not, not_forall, not_or_distrib],
  exact or_congr iff.rfl
    ⟨λ ⟨x, y, hxy, hx, hy⟩, ⟨x, hx, y, hy, hxy⟩, λ ⟨x, hx, y, hy, hxy⟩, ⟨x, y, hxy, hx, hy⟩⟩
end

theorem zero_ne_one_of_proper {I : ideal α} (h : I ≠ ⊤) : (0:α) ≠ 1 :=
λ hz, I.ne_top_iff_one.1 h $ hz ▸ I.zero_mem

theorem span_singleton_prime {p : α} (hp : p ≠ 0) :
  is_prime (span ({p} : set α)) ↔ prime p :=
by simp [is_prime_iff, prime, span_singleton_eq_top, hp, mem_span_singleton]

lemma bot_prime {R : Type*} [integral_domain R] : (⊥ : ideal R).is_prime :=
⟨λ h, one_ne_zero (by rwa [ideal.eq_top_iff_one, submodule.mem_bot] at h),
 λ x y h, mul_eq_zero.mp (by simpa only [submodule.mem_bot] using h)⟩

/-- An ideal is maximal if it is maximal in the collection of proper ideals. -/
class is_maximal (I : ideal α) : Prop := (out : is_coatom I)

theorem is_maximal_def {I : ideal α} : I.is_maximal ↔ is_coatom I := ⟨λ h, h.1, λ h, ⟨h⟩⟩

theorem is_maximal.ne_top {I : ideal α} (h : I.is_maximal) : I ≠ ⊤ := (is_maximal_def.1 h).1

theorem is_maximal_iff {I : ideal α} : I.is_maximal ↔
  (1:α) ∉ I ∧ ∀ (J : ideal α) x, I ≤ J → x ∉ I → x ∈ J → (1:α) ∈ J :=
is_maximal_def.trans $ and_congr I.ne_top_iff_one $ forall_congr $ λ J,
by rw [lt_iff_le_not_le]; exact
 ⟨λ H x h hx₁ hx₂, J.eq_top_iff_one.1 $
    H ⟨h, not_subset.2 ⟨_, hx₂, hx₁⟩⟩,
  λ H ⟨h₁, h₂⟩, let ⟨x, xJ, xI⟩ := not_subset.1 h₂ in
   J.eq_top_iff_one.2 $ H x h₁ xI xJ⟩

theorem is_maximal.eq_of_le {I J : ideal α}
  (hI : I.is_maximal) (hJ : J ≠ ⊤) (IJ : I ≤ J) : I = J :=
eq_iff_le_not_lt.2 ⟨IJ, λ h, hJ (hI.1.2 _ h)⟩

theorem is_maximal.is_prime {I : ideal α} (H : I.is_maximal) : I.is_prime :=
⟨H.1.1, λ x y hxy, or_iff_not_imp_left.2 $ λ hx, begin
  let J : ideal α := submodule.span α (insert x ↑I),
  have IJ : I ≤ J  := (set.subset.trans (subset_insert _ _) subset_span),
  have xJ : x ∈ J := ideal.subset_span (set.mem_insert x I),
  cases is_maximal_iff.1 H with _ oJ,
  specialize oJ J x IJ hx xJ,
  rcases submodule.mem_span_insert.mp oJ with ⟨a, b, h, oe⟩,
  obtain (F : y * 1 = y * (a • x + b)) := congr_arg (λ g : α, y * g) oe,
  rw [← mul_one y, F, mul_add, mul_comm, smul_eq_mul, mul_assoc],
  refine submodule.add_mem I (I.mul_mem_left a hxy) (submodule.smul_mem I y _),
  rwa submodule.span_eq at h,
end⟩

@[priority 100] -- see Note [lower instance priority]
instance is_maximal.is_prime' (I : ideal α) : ∀ [H : I.is_maximal], I.is_prime :=
is_maximal.is_prime

instance : is_coatomic (ideal α) :=
begin
  apply complete_lattice.coatomic_of_top_compact,
  rw ←span_singleton_one,
  exact submodule.singleton_span_is_compact_element 1,
end

/-- Krull's theorem: if `I` is an ideal that is not the whole ring, then it is included in some
    maximal ideal. -/
theorem exists_le_maximal (I : ideal α) (hI : I ≠ ⊤) :
  ∃ M : ideal α, M.is_maximal ∧ I ≤ M :=
let ⟨m, hm⟩ := (eq_top_or_exists_le_coatom I).resolve_left hI in ⟨m, ⟨⟨hm.1⟩, hm.2⟩⟩

variables (α)

/-- Krull's theorem: a nontrivial ring has a maximal ideal. -/
theorem exists_maximal [nontrivial α] : ∃ M : ideal α, M.is_maximal :=
let ⟨I, ⟨hI, _⟩⟩ := exists_le_maximal (⊥ : ideal α) bot_ne_top in ⟨I, hI⟩

variables {α}

instance [nontrivial α] : nontrivial (ideal α) :=
begin
  rcases @exists_maximal α _ _ with ⟨M, hM, _⟩,
  exact nontrivial_of_ne M ⊤ hM
end

/-- If P is not properly contained in any maximal ideal then it is not properly contained
  in any proper ideal -/
lemma maximal_of_no_maximal {R : Type u} [comm_semiring R] {P : ideal R}
(hmax : ∀ m : ideal R, P < m → ¬is_maximal m) (J : ideal R) (hPJ : P < J) : J = ⊤ :=
begin
  by_contradiction hnonmax,
  rcases exists_le_maximal J hnonmax with ⟨M, hM1, hM2⟩,
  exact hmax M (lt_of_lt_of_le hPJ hM2) hM1,
end

theorem mem_span_pair {x y z : α} :
  z ∈ span ({x, y} : set α) ↔ ∃ a b, a * x + b * y = z :=
by simp [mem_span_insert, mem_span_singleton', @eq_comm _ _ z]

lemma span_singleton_lt_span_singleton [integral_domain β] {x y : β} :
  span ({x} : set β) < span ({y} : set β) ↔ dvd_not_unit y x :=
by rw [lt_iff_le_not_le, span_singleton_le_span_singleton, span_singleton_le_span_singleton,
  dvd_and_not_dvd_iff]

lemma factors_decreasing [integral_domain β] (b₁ b₂ : β) (h₁ : b₁ ≠ 0) (h₂ : ¬ is_unit b₂) :
  span ({b₁ * b₂} : set β) < span {b₁} :=
lt_of_le_not_le (ideal.span_le.2 $ singleton_subset_iff.2 $
  ideal.mem_span_singleton.2 ⟨b₂, rfl⟩) $ λ h,
h₂ $ is_unit_of_dvd_one _ $ (mul_dvd_mul_iff_left h₁).1 $
by rwa [mul_one, ← ideal.span_singleton_le_span_singleton]

theorem is_maximal.exists_inv {I : ideal α}
  (hI : I.is_maximal) {x} (hx : x ∉ I) : ∃ y, ∃ i ∈ I, y * x + i = 1 :=
begin
  cases is_maximal_iff.1 hI with H₁ H₂,
  rcases mem_span_insert.1 (H₂ (span (insert x I)) x
    (set.subset.trans (subset_insert _ _) subset_span)
    hx (subset_span (mem_insert _ _))) with ⟨y, z, hz, hy⟩,
  refine ⟨y, z, _, hy.symm⟩,
  rwa ← span_eq I,
end

end ideal

end comm_semiring

namespace ideal

variables [comm_ring α] (I : ideal α) {a b : α}

lemma neg_mem_iff : -a ∈ I ↔ a ∈ I := I.neg_mem_iff

lemma add_mem_iff_left : b ∈ I → (a + b ∈ I ↔ a ∈ I) := I.add_mem_iff_left

lemma add_mem_iff_right : a ∈ I → (a + b ∈ I ↔ b ∈ I) := I.add_mem_iff_right

protected lemma sub_mem : a ∈ I → b ∈ I → a - b ∈ I := I.sub_mem

lemma mem_span_insert' {s : set α} {x y} :
  x ∈ span (insert y s) ↔ ∃a, x + a * y ∈ span s := submodule.mem_span_insert'

/-- The quotient `R/I` of a ring `R` by an ideal `I`. -/
def quotient (I : ideal α) := I.quotient

namespace quotient
variables {I} {x y : α}

instance (I : ideal α) : has_one I.quotient := ⟨submodule.quotient.mk 1⟩

instance (I : ideal α) : has_mul I.quotient :=
⟨λ a b, quotient.lift_on₂' a b (λ a b, submodule.quotient.mk (a * b)) $
 λ a₁ a₂ b₁ b₂ h₁ h₂, quot.sound $ begin
  have F := I.add_mem (I.mul_mem_left a₂ h₁) (I.mul_mem_right b₁ h₂),
  have : a₁ * a₂ - b₁ * b₂ = a₂ * (a₁ - b₁) + (a₂ - b₂) * b₁,
  { rw [mul_sub, sub_mul, sub_add_sub_cancel, mul_comm, mul_comm b₁] },
  rw ← this at F,
  change _ ∈ _, convert F,
end⟩

instance (I : ideal α) : comm_ring I.quotient :=
{ mul := (*),
  one := 1,
  mul_assoc := λ a b c, quotient.induction_on₃' a b c $
    λ a b c, congr_arg submodule.quotient.mk (mul_assoc a b c),
  mul_comm := λ a b, quotient.induction_on₂' a b $
    λ a b, congr_arg submodule.quotient.mk (mul_comm a b),
  one_mul := λ a, quotient.induction_on' a $
    λ a, congr_arg submodule.quotient.mk (one_mul a),
  mul_one := λ a, quotient.induction_on' a $
    λ a, congr_arg submodule.quotient.mk (mul_one a),
  left_distrib := λ a b c, quotient.induction_on₃' a b c $
    λ a b c, congr_arg submodule.quotient.mk (left_distrib a b c),
  right_distrib := λ a b c, quotient.induction_on₃' a b c $
    λ a b c, congr_arg submodule.quotient.mk (right_distrib a b c),
  ..submodule.quotient.add_comm_group I }

/-- The ring homomorphism from a ring `R` to a quotient ring `R/I`. -/
def mk (I : ideal α) : α →+* I.quotient :=
⟨λ a, submodule.quotient.mk a, rfl, λ _ _, rfl, rfl, λ _ _, rfl⟩

instance : inhabited (quotient I) := ⟨mk I 37⟩

protected theorem eq : mk I x = mk I y ↔ x - y ∈ I := submodule.quotient.eq I

@[simp] theorem mk_eq_mk (x : α) : (submodule.quotient.mk x : quotient I) = mk I x := rfl

lemma eq_zero_iff_mem {I : ideal α} : mk I a = 0 ↔ a ∈ I :=
by conv {to_rhs, rw ← sub_zero a }; exact quotient.eq'

theorem zero_eq_one_iff {I : ideal α} : (0 : I.quotient) = 1 ↔ I = ⊤ :=
eq_comm.trans $ eq_zero_iff_mem.trans (eq_top_iff_one _).symm

theorem zero_ne_one_iff {I : ideal α} : (0 : I.quotient) ≠ 1 ↔ I ≠ ⊤ :=
not_congr zero_eq_one_iff

protected theorem nontrivial {I : ideal α} (hI : I ≠ ⊤) : nontrivial I.quotient :=
⟨⟨0, 1, zero_ne_one_iff.2 hI⟩⟩

lemma mk_surjective : function.surjective (mk I) :=
λ y, quotient.induction_on' y (λ x, exists.intro x rfl)

instance (I : ideal α) [hI : I.is_prime] : integral_domain I.quotient :=
{ eq_zero_or_eq_zero_of_mul_eq_zero := λ a b,
    quotient.induction_on₂' a b $ λ a b hab,
      (hI.mem_or_mem (eq_zero_iff_mem.1 hab)).elim
        (or.inl ∘ eq_zero_iff_mem.2)
        (or.inr ∘ eq_zero_iff_mem.2),
  .. quotient.comm_ring I,
  .. quotient.nontrivial hI.1 }

lemma is_integral_domain_iff_prime (I : ideal α) : is_integral_domain I.quotient ↔ I.is_prime :=
⟨ λ ⟨h1, h2, h3⟩, ⟨zero_ne_one_iff.1 $ @zero_ne_one _ _ ⟨h1⟩, λ x y h,
    by { simp only [←eq_zero_iff_mem, (mk I).map_mul] at ⊢ h, exact h3 _ _ h}⟩,
  λ h, by exactI integral_domain.to_is_integral_domain I.quotient⟩

lemma exists_inv {I : ideal α} [hI : I.is_maximal] :
  ∀ {a : I.quotient}, a ≠ 0 → ∃ b : I.quotient, a * b = 1 :=
begin
  rintro ⟨a⟩ h,
  rcases hI.exists_inv (mt eq_zero_iff_mem.2 h) with ⟨b, c, hc, abc⟩,
  rw [mul_comm] at abc,
  refine ⟨mk _ b, quot.sound _⟩, --quot.sound hb
  rw ← eq_sub_iff_add_eq' at abc,
  rw [abc, ← neg_mem_iff, neg_sub] at hc,
  convert hc,
end

/-- quotient by maximal ideal is a field. def rather than instance, since users will have
computable inverses in some applications -/
protected noncomputable def field (I : ideal α) [hI : I.is_maximal] : field I.quotient :=
{ inv := λ a, if ha : a = 0 then 0 else classical.some (exists_inv ha),
  mul_inv_cancel := λ a (ha : a ≠ 0), show a * dite _ _ _ = _,
    by rw dif_neg ha;
    exact classical.some_spec (exists_inv ha),
  inv_zero := dif_pos rfl,
  ..quotient.integral_domain I }

/-- If the quotient by an ideal is a field, then the ideal is maximal. -/
theorem maximal_of_is_field (I : ideal α)
  (hqf : is_field I.quotient) : I.is_maximal :=
begin
  apply ideal.is_maximal_iff.2,
  split,
  { intro h,
    rcases hqf.exists_pair_ne with ⟨⟨x⟩, ⟨y⟩, hxy⟩,
    exact hxy (ideal.quotient.eq.2 (mul_one (x - y) ▸ I.mul_mem_left _ h)) },
  { intros J x hIJ hxnI hxJ,
    rcases hqf.mul_inv_cancel (mt ideal.quotient.eq_zero_iff_mem.1 hxnI) with ⟨⟨y⟩, hy⟩,
    rw [← zero_add (1 : α), ← sub_self (x * y), sub_add],
    refine J.sub_mem (J.mul_mem_right _ hxJ) (hIJ (ideal.quotient.eq.1 hy)) }
end

/-- The quotient of a ring by an ideal is a field iff the ideal is maximal. -/
theorem maximal_ideal_iff_is_field_quotient (I : ideal α) :
  I.is_maximal ↔ is_field I.quotient :=
⟨λ h, @field.to_is_field I.quotient (@ideal.quotient.field _ _ I h),
 λ h, maximal_of_is_field I h⟩

variable [comm_ring β]

/-- Given a ring homomorphism `f : α →+* β` sending all elements of an ideal to zero,
lift it to the quotient by this ideal. -/
def lift (S : ideal α) (f : α →+* β) (H : ∀ (a : α), a ∈ S → f a = 0) :
  quotient S →+* β :=
{ to_fun := λ x, quotient.lift_on' x f $ λ (a b) (h : _ ∈ _),
    eq_of_sub_eq_zero $ by rw [← f.map_sub, H _ h],
  map_one' := f.map_one,
  map_zero' := f.map_zero,
  map_add' := λ a₁ a₂, quotient.induction_on₂' a₁ a₂ f.map_add,
  map_mul' := λ a₁ a₂, quotient.induction_on₂' a₁ a₂ f.map_mul }

@[simp] lemma lift_mk (S : ideal α) (f : α →+* β) (H : ∀ (a : α), a ∈ S → f a = 0) :
  lift S f H (mk S a) = f a := rfl

end quotient

section lattice
variables {R : Type u} [comm_semiring R]

lemma mem_sup_left {S T : ideal R} : ∀ {x : R}, x ∈ S → x ∈ S ⊔ T :=
show S ≤ S ⊔ T, from le_sup_left

lemma mem_sup_right {S T : ideal R} : ∀ {x : R}, x ∈ T → x ∈ S ⊔ T :=
show T ≤ S ⊔ T, from le_sup_right

lemma mem_Sup_of_mem {S : set (ideal R)} {s : ideal R}
  (hs : s ∈ S) : ∀ {x : R}, x ∈ s → x ∈ Sup S :=
show s ≤ Sup S, from le_Sup hs

theorem mem_Inf {s : set (ideal R)} {x : R} :
  x ∈ Inf s ↔ ∀ ⦃I⦄, I ∈ s → x ∈ I :=
⟨λ hx I his, hx I ⟨I, infi_pos his⟩, λ H I ⟨J, hij⟩, hij ▸ λ S ⟨hj, hS⟩, hS ▸ H hj⟩

@[simp] lemma mem_inf {I J : ideal R} {x : R} : x ∈ I ⊓ J ↔ x ∈ I ∧ x ∈ J := iff.rfl

@[simp] lemma mem_infi {ι : Type*} {I : ι → ideal R} {x : R} : x ∈ infi I ↔ ∀ i, x ∈ I i :=
submodule.mem_infi _

@[simp] lemma mem_bot {x : R} : x ∈ (⊥ : ideal R) ↔ x = 0 :=
submodule.mem_bot _

end lattice

/-- All ideals in a field are trivial. -/
lemma eq_bot_or_top {K : Type u} [field K] (I : ideal K) :
  I = ⊥ ∨ I = ⊤ :=
begin
  rw or_iff_not_imp_right,
  change _ ≠ _ → _,
  rw ideal.ne_top_iff_one,
  intro h1,
  rw eq_bot_iff,
  intros r hr,
  by_cases H : r = 0, {simpa},
  simpa [H, h1] using I.mul_mem_left r⁻¹ hr,
end

lemma eq_bot_of_prime {K : Type u} [field K] (I : ideal K) [h : I.is_prime] :
  I = ⊥ :=
or_iff_not_imp_right.mp I.eq_bot_or_top h.1

lemma bot_is_maximal {K : Type u} [field K] : is_maximal (⊥ : ideal K) :=
⟨⟨λ h, absurd ((eq_top_iff_one (⊤ : ideal K)).mp rfl) (by rw ← h; simp),
λ I hI, or_iff_not_imp_left.mp (eq_bot_or_top I) (ne_of_gt hI)⟩⟩

section pi
variables (ι : Type v)

/-- `I^n` as an ideal of `R^n`. -/
def pi : ideal (ι → α) :=
{ carrier := { x | ∀ i, x i ∈ I },
  zero_mem' := λ i, I.zero_mem,
  add_mem' := λ a b ha hb i, I.add_mem (ha i) (hb i),
  smul_mem' := λ a b hb i, I.mul_mem_left (a i) (hb i) }

lemma mem_pi (x : ι → α) : x ∈ I.pi ι ↔ ∀ i, x i ∈ I := iff.rfl

/-- `R^n/I^n` is a `R/I`-module. -/
instance module_pi : module (I.quotient) (I.pi ι).quotient :=
begin
  refine { smul := λ c m, quotient.lift_on₂' c m (λ r m, submodule.quotient.mk $ r • m) _, .. },
  { intros c₁ m₁ c₂ m₂ hc hm,
    change c₁ - c₂ ∈ I at hc,
    change m₁ - m₂ ∈ (I.pi ι) at hm,
    apply ideal.quotient.eq.2,
    have : c₁ • (m₂ - m₁) ∈ I.pi ι,
    { rw ideal.mem_pi,
      intro i,
      simp only [smul_eq_mul, pi.smul_apply, pi.sub_apply],
      apply ideal.mul_mem_left,
      rw ←ideal.neg_mem_iff,
      simpa only [neg_sub] using hm i },
    rw [←ideal.add_mem_iff_left (I.pi ι) this, sub_eq_add_neg, add_comm, ←add_assoc, ←smul_add,
      sub_add_cancel, ←sub_eq_add_neg, ←sub_smul, ideal.mem_pi],
    exact λ i, I.mul_mem_right _ hc },
  all_goals { rintro ⟨a⟩ ⟨b⟩ ⟨c⟩ <|> rintro ⟨a⟩,
    simp only [(•), submodule.quotient.quot_mk_eq_mk, ideal.quotient.mk_eq_mk],
    change ideal.quotient.mk _ _ = ideal.quotient.mk _ _,
    congr' with i, simp [mul_assoc, mul_add, add_mul] }
end

/-- `R^n/I^n` is isomorphic to `(R/I)^n` as an `R/I`-module. -/
noncomputable def pi_quot_equiv : (I.pi ι).quotient ≃ₗ[I.quotient] (ι → I.quotient) :=
{ to_fun := λ x, quotient.lift_on' x (λ f i, ideal.quotient.mk I (f i)) $
    λ a b hab, funext (λ i, ideal.quotient.eq.2 (hab i)),
  map_add' := by { rintros ⟨_⟩ ⟨_⟩, refl },
  map_smul' := by { rintros ⟨_⟩ ⟨_⟩, refl },
  inv_fun := λ x, ideal.quotient.mk (I.pi ι) $ λ i, quotient.out' (x i),
  left_inv :=
  begin
    rintro ⟨x⟩,
    exact ideal.quotient.eq.2 (λ i, ideal.quotient.eq.1 (quotient.out_eq' _))
  end,
  right_inv :=
  begin
    intro x,
    ext i,
    obtain ⟨r, hr⟩ := @quot.exists_rep _ _ (x i),
    simp_rw ←hr,
    convert quotient.out_eq' _
  end }

/-- If `f : R^n → R^m` is an `R`-linear map and `I ⊆ R` is an ideal, then the image of `I^n` is
    contained in `I^m`. -/
lemma map_pi {ι} [fintype ι] {ι' : Type w} (x : ι → α) (hi : ∀ i, x i ∈ I)
  (f : (ι → α) →ₗ[α] (ι' → α)) (i : ι') : f x i ∈ I :=
begin
  rw pi_eq_sum_univ x,
  simp only [finset.sum_apply, smul_eq_mul, linear_map.map_sum, pi.smul_apply, linear_map.map_smul],
  exact I.sum_mem (λ j hj, I.mul_mem_right _ (hi j))
end

end pi

end ideal

namespace ring

variables {R : Type*} [comm_ring R]

lemma not_is_field_of_subsingleton {R : Type*} [ring R] [subsingleton R] : ¬ is_field R :=
λ ⟨⟨x, y, hxy⟩, _, _⟩, hxy (subsingleton.elim x y)

lemma exists_not_is_unit_of_not_is_field [nontrivial R] (hf : ¬ is_field R) :
  ∃ x ≠ (0 : R), ¬ is_unit x :=
begin
  have : ¬ _ := λ h, hf ⟨exists_pair_ne R, mul_comm, h⟩,
  simp_rw is_unit_iff_exists_inv,
  push_neg at ⊢ this,
  obtain ⟨x, hx, not_unit⟩ := this,
  exact ⟨x, hx, not_unit⟩
end

lemma not_is_field_iff_exists_ideal_bot_lt_and_lt_top [nontrivial R] :
  ¬ is_field R ↔ ∃ I : ideal R, ⊥ < I ∧ I < ⊤ :=
begin
  split,
  { intro h,
    obtain ⟨x, nz, nu⟩ := exists_not_is_unit_of_not_is_field h,
    use ideal.span {x},
    rw [bot_lt_iff_ne_bot, lt_top_iff_ne_top],
    exact ⟨mt ideal.span_singleton_eq_bot.mp nz, mt ideal.span_singleton_eq_top.mp nu⟩ },
  { rintros ⟨I, bot_lt, lt_top⟩ hf,
    obtain ⟨x, mem, ne_zero⟩ := set_like.exists_of_lt bot_lt,
    rw submodule.mem_bot at ne_zero,
    obtain ⟨y, hy⟩ := hf.mul_inv_cancel ne_zero,
    rw [lt_top_iff_ne_top, ne.def, ideal.eq_top_iff_one, ← hy] at lt_top,
    exact lt_top (I.mul_mem_right _ mem), }
end

lemma not_is_field_iff_exists_prime [nontrivial R] :
  ¬ is_field R ↔ ∃ p : ideal R, p ≠ ⊥ ∧ p.is_prime :=
not_is_field_iff_exists_ideal_bot_lt_and_lt_top.trans
  ⟨λ ⟨I, bot_lt, lt_top⟩, let ⟨p, hp, le_p⟩ := I.exists_le_maximal (lt_top_iff_ne_top.mp lt_top) in
    ⟨p, bot_lt_iff_ne_bot.mp (lt_of_lt_of_le bot_lt le_p), hp.is_prime⟩,
   λ ⟨p, ne_bot, prime⟩, ⟨p, bot_lt_iff_ne_bot.mpr ne_bot, lt_top_iff_ne_top.mpr prime.1⟩⟩

/-- When a ring is not a field, the maximal ideals are nontrivial. -/
lemma ne_bot_of_is_maximal_of_not_is_field [nontrivial R] {M : ideal R} (max : M.is_maximal)
  (not_field : ¬ is_field R) : M ≠ ⊥ :=
begin
  rintros h,
  rw h at max,
  rcases max with ⟨⟨h1, h2⟩⟩,
  obtain ⟨I, hIbot, hItop⟩ := not_is_field_iff_exists_ideal_bot_lt_and_lt_top.mp not_field,
  exact ne_of_lt hItop (h2 I hIbot),
end

end ring

namespace ideal

/-- Maximal ideals in a non-field are nontrivial. -/
variables {R : Type u} [comm_ring R] [nontrivial R]
lemma bot_lt_of_maximal (M : ideal R) [hm : M.is_maximal] (non_field : ¬ is_field R) : ⊥ < M :=
begin
  rcases (ring.not_is_field_iff_exists_ideal_bot_lt_and_lt_top.1 non_field)
    with ⟨I, Ibot, Itop⟩,
  split, finish,
  intro mle,
  apply @irrefl _ (<) _ (⊤ : ideal R),
  have : M = ⊥ := eq_bot_iff.mpr mle,
  rw this at *,
  rwa hm.1.2 I Ibot at Itop,
end

end ideal

variables {a b : α}

/-- The set of non-invertible elements of a monoid. -/
def nonunits (α : Type u) [monoid α] : set α := { a | ¬is_unit a }

@[simp] theorem mem_nonunits_iff [comm_monoid α] : a ∈ nonunits α ↔ ¬ is_unit a := iff.rfl

theorem mul_mem_nonunits_right [comm_monoid α] :
  b ∈ nonunits α → a * b ∈ nonunits α :=
mt is_unit_of_mul_is_unit_right

theorem mul_mem_nonunits_left [comm_monoid α] :
  a ∈ nonunits α → a * b ∈ nonunits α :=
mt is_unit_of_mul_is_unit_left

theorem zero_mem_nonunits [semiring α] : 0 ∈ nonunits α ↔ (0:α) ≠ 1 :=
not_congr is_unit_zero_iff

@[simp] theorem one_not_mem_nonunits [monoid α] : (1:α) ∉ nonunits α :=
not_not_intro is_unit_one

theorem coe_subset_nonunits [comm_semiring α] {I : ideal α} (h : I ≠ ⊤) :
  (I : set α) ⊆ nonunits α :=
λ x hx hu, h $ I.eq_top_of_is_unit_mem hx hu

lemma exists_max_ideal_of_mem_nonunits [comm_semiring α] (h : a ∈ nonunits α) :
  ∃ I : ideal α, I.is_maximal ∧ a ∈ I :=
begin
  have : ideal.span ({a} : set α) ≠ ⊤,
  { intro H, rw ideal.span_singleton_eq_top at H, contradiction },
  rcases ideal.exists_le_maximal _ this with ⟨I, Imax, H⟩,
  use [I, Imax], apply H, apply ideal.subset_span, exact set.mem_singleton a
end

/-- A commutative ring is local if it has a unique maximal ideal. Note that
  `local_ring` is a predicate. -/
class local_ring (α : Type u) [comm_ring α] extends nontrivial α : Prop :=
(is_local : ∀ (a : α), (is_unit a) ∨ (is_unit (1 - a)))

namespace local_ring

variables [comm_ring α] [local_ring α]

lemma is_unit_or_is_unit_one_sub_self (a : α) :
  (is_unit a) ∨ (is_unit (1 - a)) :=
is_local a

lemma is_unit_of_mem_nonunits_one_sub_self (a : α) (h : (1 - a) ∈ nonunits α) :
  is_unit a :=
or_iff_not_imp_right.1 (is_local a) h

lemma is_unit_one_sub_self_of_mem_nonunits (a : α) (h : a ∈ nonunits α) :
  is_unit (1 - a) :=
or_iff_not_imp_left.1 (is_local a) h

lemma nonunits_add {x y} (hx : x ∈ nonunits α) (hy : y ∈ nonunits α) :
  x + y ∈ nonunits α :=
begin
  rintros ⟨u, hu⟩,
  apply hy,
  suffices : is_unit ((↑u⁻¹ : α) * y),
  { rcases this with ⟨s, hs⟩,
    use u * s,
    convert congr_arg (λ z, (u : α) * z) hs,
    rw ← mul_assoc, simp },
  rw show (↑u⁻¹ * y) = (1 - ↑u⁻¹ * x),
  { rw eq_sub_iff_add_eq,
    replace hu := congr_arg (λ z, (↑u⁻¹ : α) * z) hu.symm,
    simpa [mul_add, add_comm] using hu },
  apply is_unit_one_sub_self_of_mem_nonunits,
  exact mul_mem_nonunits_right hx
end

variable (α)

/-- The ideal of elements that are not units. -/
def maximal_ideal : ideal α :=
{ carrier := nonunits α,
  zero_mem' := zero_mem_nonunits.2 $ zero_ne_one,
  add_mem' := λ x y hx hy, nonunits_add hx hy,
  smul_mem' := λ a x, mul_mem_nonunits_right }

instance maximal_ideal.is_maximal : (maximal_ideal α).is_maximal :=
begin
  rw ideal.is_maximal_iff,
  split,
  { intro h, apply h, exact is_unit_one },
  { intros I x hI hx H,
    erw not_not at hx,
    rcases hx with ⟨u,rfl⟩,
    simpa using I.mul_mem_left ↑u⁻¹ H }
end

lemma maximal_ideal_unique :
  ∃! I : ideal α, I.is_maximal :=
⟨maximal_ideal α, maximal_ideal.is_maximal α,
  λ I hI, hI.eq_of_le (maximal_ideal.is_maximal α).1.1 $
  λ x hx, hI.1.1 ∘ I.eq_top_of_is_unit_mem hx⟩

variable {α}

lemma eq_maximal_ideal {I : ideal α} (hI : I.is_maximal) : I = maximal_ideal α :=
unique_of_exists_unique (maximal_ideal_unique α) hI $ maximal_ideal.is_maximal α

lemma le_maximal_ideal {J : ideal α} (hJ : J ≠ ⊤) : J ≤ maximal_ideal α :=
begin
  rcases ideal.exists_le_maximal J hJ with ⟨M, hM1, hM2⟩,
  rwa ←eq_maximal_ideal hM1
end

@[simp] lemma mem_maximal_ideal (x) :
  x ∈ maximal_ideal α ↔ x ∈ nonunits α := iff.rfl

end local_ring

lemma local_of_nonunits_ideal [comm_ring α] (hnze : (0:α) ≠ 1)
  (h : ∀ x y ∈ nonunits α, x + y ∈ nonunits α) : local_ring α :=
{ exists_pair_ne := ⟨0, 1, hnze⟩,
  is_local := λ x, or_iff_not_imp_left.mpr $ λ hx,
  begin
    by_contra H,
    apply h _ _ hx H,
    simp [-sub_eq_add_neg, add_sub_cancel'_right]
  end }

lemma local_of_unique_max_ideal [comm_ring α] (h : ∃! I : ideal α, I.is_maximal) :
  local_ring α :=
local_of_nonunits_ideal
(let ⟨I, Imax, _⟩ := h in (λ (H : 0 = 1), Imax.1.1 $ I.eq_top_iff_one.2 $ H ▸ I.zero_mem))
$ λ x y hx hy H,
let ⟨I, Imax, Iuniq⟩ := h in
let ⟨Ix, Ixmax, Hx⟩ := exists_max_ideal_of_mem_nonunits hx in
let ⟨Iy, Iymax, Hy⟩ := exists_max_ideal_of_mem_nonunits hy in
have xmemI : x ∈ I, from ((Iuniq Ix Ixmax) ▸ Hx),
have ymemI : y ∈ I, from ((Iuniq Iy Iymax) ▸ Hy),
Imax.1.1 $ I.eq_top_of_is_unit_mem (I.add_mem xmemI ymemI) H

lemma local_of_unique_nonzero_prime (R : Type u) [comm_ring R]
  (h : ∃! P : ideal R, P ≠ ⊥ ∧ ideal.is_prime P) : local_ring R :=
local_of_unique_max_ideal begin
  rcases h with ⟨P, ⟨hPnonzero, hPnot_top, _⟩, hPunique⟩,
  refine ⟨P, ⟨⟨hPnot_top, _⟩⟩, λ M hM, hPunique _ ⟨_, ideal.is_maximal.is_prime hM⟩⟩,
  { refine ideal.maximal_of_no_maximal (λ M hPM hM, ne_of_lt hPM _),
    exact (hPunique _ ⟨ne_bot_of_gt hPM, ideal.is_maximal.is_prime hM⟩).symm },
  { rintro rfl,
    exact hPnot_top (hM.1.2 P (bot_lt_iff_ne_bot.2 hPnonzero)) },
end

lemma local_of_surjective {A B : Type*} [comm_ring A] [local_ring A] [comm_ring B] [nontrivial B]
  (f : A →+* B) (hf : function.surjective f) :
  local_ring B :=
{ is_local :=
  begin
    intros b,
    obtain ⟨a, rfl⟩ := hf b,
    apply (local_ring.is_unit_or_is_unit_one_sub_self a).imp f.is_unit_map _,
    rw [← f.map_one, ← f.map_sub],
    apply f.is_unit_map,
  end,
  .. ‹nontrivial B› }

/-- A local ring homomorphism is a homomorphism between local rings
  such that the image of the maximal ideal of the source is contained within
  the maximal ideal of the target. -/
class is_local_ring_hom [semiring α] [semiring β] (f : α →+* β) : Prop :=
(map_nonunit : ∀ a, is_unit (f a) → is_unit a)

instance is_local_ring_hom_id (A : Type*) [semiring A] : is_local_ring_hom (ring_hom.id A) :=
{ map_nonunit := λ a, id }

@[simp] lemma is_unit_map_iff {A B : Type*} [semiring A] [semiring B] (f : A →+* B)
  [is_local_ring_hom f] (a) :
  is_unit (f a) ↔ is_unit a :=
⟨is_local_ring_hom.map_nonunit a, f.is_unit_map⟩

instance is_local_ring_hom_comp {A B C : Type*} [semiring A] [semiring B] [semiring C]
  (g : B →+* C) (f : A →+* B) [is_local_ring_hom g] [is_local_ring_hom f] :
  is_local_ring_hom (g.comp f) :=
{ map_nonunit := λ a, is_local_ring_hom.map_nonunit a ∘ is_local_ring_hom.map_nonunit (f a) }

@[simp] lemma is_unit_of_map_unit [semiring α] [semiring β] (f : α →+* β) [is_local_ring_hom f]
  (a) (h : is_unit (f a)) : is_unit a :=
is_local_ring_hom.map_nonunit a h

theorem of_irreducible_map [semiring α] [semiring β] (f : α →+* β) [h : is_local_ring_hom f] {x : α}
  (hfx : irreducible (f x)) : irreducible x :=
⟨λ h, hfx.not_unit $ is_unit.map f.to_monoid_hom h, λ p q hx, let ⟨H⟩ := h in
or.imp (H p) (H q) $ hfx.is_unit_or_is_unit $ f.map_mul p q ▸ congr_arg f hx⟩

section
open local_ring
variables [comm_ring α] [local_ring α] [comm_ring β] [local_ring β]
variables (f : α →+* β) [is_local_ring_hom f]

lemma map_nonunit (a) (h : a ∈ maximal_ideal α) : f a ∈ maximal_ideal β :=
λ H, h $ is_unit_of_map_unit f a H

end

namespace local_ring
variables [comm_ring α] [local_ring α] [comm_ring β] [local_ring β]

variable (α)
/-- The residue field of a local ring is the quotient of the ring by its maximal ideal. -/
def residue_field := (maximal_ideal α).quotient

noncomputable instance residue_field.field : field (residue_field α) :=
ideal.quotient.field (maximal_ideal α)

noncomputable instance : inhabited (residue_field α) := ⟨37⟩

/-- The quotient map from a local ring to its residue field. -/
def residue : α →+* (residue_field α) :=
ideal.quotient.mk _

namespace residue_field

variables {α β}
/-- The map on residue fields induced by a local homomorphism between local rings -/
noncomputable def map (f : α →+* β) [is_local_ring_hom f] :
  residue_field α →+* residue_field β :=
ideal.quotient.lift (maximal_ideal α) ((ideal.quotient.mk _).comp f) $
λ a ha,
begin
  erw ideal.quotient.eq_zero_iff_mem,
  exact map_nonunit f a ha
end

end residue_field

end local_ring

namespace field
variables [field α]

@[priority 100] -- see Note [lower instance priority]
instance : local_ring α :=
{ is_local := λ a,
  if h : a = 0
  then or.inr (by rw [h, sub_zero]; exact is_unit_one)
  else or.inl $ is_unit.mk0 a h }

end field


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies

! This file was ported from Lean 3 source module order.heyting.regular
! leanprover-community/mathlib commit c3291da49cfa65f0d43b094750541c0731edc932
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Order.GaloisConnection

/-!
# Heyting regular elements

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

This file defines Heyting regular elements, elements of an Heyting algebra that are their own double
complement, and proves that they form a boolean algebra.

From a logic standpoint, this means that we can perform classical logic within intuitionistic logic
by simply double-negating all propositions. This is practical for synthetic computability theory.

## Main declarations

* `is_regular`: `a` is Heyting-regular if `aᶜᶜ = a`.
* `regular`: The subtype of Heyting-regular elements.
* `regular.boolean_algebra`: Heyting-regular elements form a boolean algebra.

## References

* [Francis Borceux, *Handbook of Categorical Algebra III*][borceux-vol3]
-/

open Function

variable {α : Type _}

namespace Heyting

section HasCompl

variable [HasCompl α] {a : α}

#print Heyting.IsRegular /-
/-- An element of an Heyting algebra is regular if its double complement is itself. -/
def IsRegular (a : α) : Prop :=
  aᶜᶜ = a
#align heyting.is_regular Heyting.IsRegular
-/

#print Heyting.IsRegular.eq /-
protected theorem IsRegular.eq : IsRegular a → aᶜᶜ = a :=
  id
#align heyting.is_regular.eq Heyting.IsRegular.eq
-/

#print Heyting.IsRegular.decidablePred /-
instance IsRegular.decidablePred [DecidableEq α] : @DecidablePred α IsRegular := fun _ =>
  ‹DecidableEq α› _ _
#align heyting.is_regular.decidable_pred Heyting.IsRegular.decidablePred
-/

end HasCompl

section HeytingAlgebra

variable [HeytingAlgebra α] {a b : α}

/- warning: heyting.is_regular_bot -> Heyting.isRegular_bot is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : HeytingAlgebra.{u1} α], Heyting.IsRegular.{u1} α (HeytingAlgebra.toHasCompl.{u1} α _inst_1) (Bot.bot.{u1} α (HeytingAlgebra.toHasBot.{u1} α _inst_1))
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : HeytingAlgebra.{u1} α], Heyting.IsRegular.{u1} α (HeytingAlgebra.toHasCompl.{u1} α _inst_1) (Bot.bot.{u1} α (HeytingAlgebra.toBot.{u1} α _inst_1))
Case conversion may be inaccurate. Consider using '#align heyting.is_regular_bot Heyting.isRegular_botₓ'. -/
theorem isRegular_bot : IsRegular (⊥ : α) := by rw [IsRegular, compl_bot, compl_top]
#align heyting.is_regular_bot Heyting.isRegular_bot

/- warning: heyting.is_regular_top -> Heyting.isRegular_top is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : HeytingAlgebra.{u1} α], Heyting.IsRegular.{u1} α (HeytingAlgebra.toHasCompl.{u1} α _inst_1) (Top.top.{u1} α (GeneralizedHeytingAlgebra.toHasTop.{u1} α (HeytingAlgebra.toGeneralizedHeytingAlgebra.{u1} α _inst_1)))
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : HeytingAlgebra.{u1} α], Heyting.IsRegular.{u1} α (HeytingAlgebra.toHasCompl.{u1} α _inst_1) (Top.top.{u1} α (GeneralizedHeytingAlgebra.toTop.{u1} α (HeytingAlgebra.toGeneralizedHeytingAlgebra.{u1} α _inst_1)))
Case conversion may be inaccurate. Consider using '#align heyting.is_regular_top Heyting.isRegular_topₓ'. -/
theorem isRegular_top : IsRegular (⊤ : α) := by rw [IsRegular, compl_top, compl_bot]
#align heyting.is_regular_top Heyting.isRegular_top

/- warning: heyting.is_regular.inf -> Heyting.IsRegular.inf is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : HeytingAlgebra.{u1} α] {a : α} {b : α}, (Heyting.IsRegular.{u1} α (HeytingAlgebra.toHasCompl.{u1} α _inst_1) a) -> (Heyting.IsRegular.{u1} α (HeytingAlgebra.toHasCompl.{u1} α _inst_1) b) -> (Heyting.IsRegular.{u1} α (HeytingAlgebra.toHasCompl.{u1} α _inst_1) (Inf.inf.{u1} α (SemilatticeInf.toHasInf.{u1} α (Lattice.toSemilatticeInf.{u1} α (GeneralizedHeytingAlgebra.toLattice.{u1} α (HeytingAlgebra.toGeneralizedHeytingAlgebra.{u1} α _inst_1)))) a b))
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : HeytingAlgebra.{u1} α] {a : α} {b : α}, (Heyting.IsRegular.{u1} α (HeytingAlgebra.toHasCompl.{u1} α _inst_1) a) -> (Heyting.IsRegular.{u1} α (HeytingAlgebra.toHasCompl.{u1} α _inst_1) b) -> (Heyting.IsRegular.{u1} α (HeytingAlgebra.toHasCompl.{u1} α _inst_1) (Inf.inf.{u1} α (Lattice.toInf.{u1} α (GeneralizedHeytingAlgebra.toLattice.{u1} α (HeytingAlgebra.toGeneralizedHeytingAlgebra.{u1} α _inst_1))) a b))
Case conversion may be inaccurate. Consider using '#align heyting.is_regular.inf Heyting.IsRegular.infₓ'. -/
theorem IsRegular.inf (ha : IsRegular a) (hb : IsRegular b) : IsRegular (a ⊓ b) := by
  rw [IsRegular, compl_compl_inf_distrib, ha.eq, hb.eq]
#align heyting.is_regular.inf Heyting.IsRegular.inf

/- warning: heyting.is_regular.himp -> Heyting.IsRegular.himp is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : HeytingAlgebra.{u1} α] {a : α} {b : α}, (Heyting.IsRegular.{u1} α (HeytingAlgebra.toHasCompl.{u1} α _inst_1) a) -> (Heyting.IsRegular.{u1} α (HeytingAlgebra.toHasCompl.{u1} α _inst_1) b) -> (Heyting.IsRegular.{u1} α (HeytingAlgebra.toHasCompl.{u1} α _inst_1) (HImp.himp.{u1} α (GeneralizedHeytingAlgebra.toHasHimp.{u1} α (HeytingAlgebra.toGeneralizedHeytingAlgebra.{u1} α _inst_1)) a b))
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : HeytingAlgebra.{u1} α] {a : α} {b : α}, (Heyting.IsRegular.{u1} α (HeytingAlgebra.toHasCompl.{u1} α _inst_1) a) -> (Heyting.IsRegular.{u1} α (HeytingAlgebra.toHasCompl.{u1} α _inst_1) b) -> (Heyting.IsRegular.{u1} α (HeytingAlgebra.toHasCompl.{u1} α _inst_1) (HImp.himp.{u1} α (GeneralizedHeytingAlgebra.toHImp.{u1} α (HeytingAlgebra.toGeneralizedHeytingAlgebra.{u1} α _inst_1)) a b))
Case conversion may be inaccurate. Consider using '#align heyting.is_regular.himp Heyting.IsRegular.himpₓ'. -/
theorem IsRegular.himp (ha : IsRegular a) (hb : IsRegular b) : IsRegular (a ⇨ b) := by
  rw [IsRegular, compl_compl_himp_distrib, ha.eq, hb.eq]
#align heyting.is_regular.himp Heyting.IsRegular.himp

#print Heyting.isRegular_compl /-
theorem isRegular_compl (a : α) : IsRegular (aᶜ) :=
  compl_compl_compl _
#align heyting.is_regular_compl Heyting.isRegular_compl
-/

#print Heyting.IsRegular.disjoint_compl_left_iff /-
protected theorem IsRegular.disjoint_compl_left_iff (ha : IsRegular a) : Disjoint (aᶜ) b ↔ b ≤ a :=
  by rw [← le_compl_iff_disjoint_left, ha.eq]
#align heyting.is_regular.disjoint_compl_left_iff Heyting.IsRegular.disjoint_compl_left_iff
-/

#print Heyting.IsRegular.disjoint_compl_right_iff /-
protected theorem IsRegular.disjoint_compl_right_iff (hb : IsRegular b) : Disjoint a (bᶜ) ↔ a ≤ b :=
  by rw [← le_compl_iff_disjoint_right, hb.eq]
#align heyting.is_regular.disjoint_compl_right_iff Heyting.IsRegular.disjoint_compl_right_iff
-/

/- warning: boolean_algebra.of_regular -> BooleanAlgebra.ofRegular is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : HeytingAlgebra.{u1} α], (forall (a : α), Heyting.IsRegular.{u1} α (HeytingAlgebra.toHasCompl.{u1} α _inst_1) (Sup.sup.{u1} α (SemilatticeSup.toHasSup.{u1} α (Lattice.toSemilatticeSup.{u1} α (GeneralizedHeytingAlgebra.toLattice.{u1} α (HeytingAlgebra.toGeneralizedHeytingAlgebra.{u1} α _inst_1)))) a (HasCompl.compl.{u1} α (HeytingAlgebra.toHasCompl.{u1} α _inst_1) a))) -> (BooleanAlgebra.{u1} α)
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : HeytingAlgebra.{u1} α], (forall (a : α), Heyting.IsRegular.{u1} α (HeytingAlgebra.toHasCompl.{u1} α _inst_1) (Sup.sup.{u1} α (SemilatticeSup.toSup.{u1} α (Lattice.toSemilatticeSup.{u1} α (GeneralizedHeytingAlgebra.toLattice.{u1} α (HeytingAlgebra.toGeneralizedHeytingAlgebra.{u1} α _inst_1)))) a (HasCompl.compl.{u1} α (HeytingAlgebra.toHasCompl.{u1} α _inst_1) a))) -> (BooleanAlgebra.{u1} α)
Case conversion may be inaccurate. Consider using '#align boolean_algebra.of_regular BooleanAlgebra.ofRegularₓ'. -/
-- See note [reducible non-instances]
/-- A Heyting algebra with regular excluded middle is a boolean algebra. -/
@[reducible]
def BooleanAlgebra.ofRegular (h : ∀ a : α, IsRegular (a ⊔ aᶜ)) : BooleanAlgebra α :=
  have : ∀ a : α, IsCompl a (aᶜ) := fun a =>
    ⟨disjoint_compl_right,
      codisjoint_iff.2 <| by erw [← (h a).Eq, compl_sup, inf_compl_eq_bot, compl_bot]⟩
  { ‹HeytingAlgebra α›,
    GeneralizedHeytingAlgebra.toDistribLattice with
    himp_eq := fun a b =>
      eq_of_forall_le_iff fun c => le_himp_iff.trans (this _).le_sup_right_iff_inf_left_le.symm
    inf_compl_le_bot := fun a => (this _).1.le_bot
    top_le_sup_compl := fun a => (this _).2.top_le }
#align boolean_algebra.of_regular BooleanAlgebra.ofRegular

variable (α)

#print Heyting.Regular /-
/-- The boolean algebra of Heyting regular elements. -/
def Regular : Type _ :=
  { a : α // IsRegular a }
#align heyting.regular Heyting.Regular
-/

variable {α}

namespace Regular

instance : Coe (Regular α) α :=
  coeSubtype

#print Heyting.Regular.coe_injective /-
theorem coe_injective : Injective (coe : Regular α → α) :=
  Subtype.coe_injective
#align heyting.regular.coe_injective Heyting.Regular.coe_injective
-/

#print Heyting.Regular.coe_inj /-
@[simp]
theorem coe_inj {a b : Regular α} : (a : α) = b ↔ a = b :=
  Subtype.coe_inj
#align heyting.regular.coe_inj Heyting.Regular.coe_inj
-/

instance : Top (Regular α) :=
  ⟨⟨⊤, isRegular_top⟩⟩

instance : Bot (Regular α) :=
  ⟨⟨⊥, isRegular_bot⟩⟩

instance : Inf (Regular α) :=
  ⟨fun a b => ⟨a ⊓ b, a.2.inf b.2⟩⟩

instance : HImp (Regular α) :=
  ⟨fun a b => ⟨a ⇨ b, a.2.himp b.2⟩⟩

instance : HasCompl (Regular α) :=
  ⟨fun a => ⟨aᶜ, isRegular_compl _⟩⟩

/- warning: heyting.regular.coe_top -> Heyting.Regular.coe_top is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : HeytingAlgebra.{u1} α], Eq.{succ u1} α ((fun (a : Type.{u1}) (b : Type.{u1}) [self : HasLiftT.{succ u1, succ u1} a b] => self.0) (Heyting.Regular.{u1} α _inst_1) α (HasLiftT.mk.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (CoeTCₓ.coe.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (coeBase.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (Heyting.Regular.hasCoe.{u1} α _inst_1)))) (Top.top.{u1} (Heyting.Regular.{u1} α _inst_1) (Heyting.Regular.hasTop.{u1} α _inst_1))) (Top.top.{u1} α (GeneralizedHeytingAlgebra.toHasTop.{u1} α (HeytingAlgebra.toGeneralizedHeytingAlgebra.{u1} α _inst_1)))
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : HeytingAlgebra.{u1} α], Eq.{succ u1} α (Heyting.Regular.val.{u1} α _inst_1 (Top.top.{u1} (Heyting.Regular.{u1} α _inst_1) (Heyting.Regular.top.{u1} α _inst_1))) (Top.top.{u1} α (GeneralizedHeytingAlgebra.toTop.{u1} α (HeytingAlgebra.toGeneralizedHeytingAlgebra.{u1} α _inst_1)))
Case conversion may be inaccurate. Consider using '#align heyting.regular.coe_top Heyting.Regular.coe_topₓ'. -/
@[simp, norm_cast]
theorem coe_top : ((⊤ : Regular α) : α) = ⊤ :=
  rfl
#align heyting.regular.coe_top Heyting.Regular.coe_top

/- warning: heyting.regular.coe_bot -> Heyting.Regular.coe_bot is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : HeytingAlgebra.{u1} α], Eq.{succ u1} α ((fun (a : Type.{u1}) (b : Type.{u1}) [self : HasLiftT.{succ u1, succ u1} a b] => self.0) (Heyting.Regular.{u1} α _inst_1) α (HasLiftT.mk.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (CoeTCₓ.coe.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (coeBase.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (Heyting.Regular.hasCoe.{u1} α _inst_1)))) (Bot.bot.{u1} (Heyting.Regular.{u1} α _inst_1) (Heyting.Regular.hasBot.{u1} α _inst_1))) (Bot.bot.{u1} α (HeytingAlgebra.toHasBot.{u1} α _inst_1))
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : HeytingAlgebra.{u1} α], Eq.{succ u1} α (Heyting.Regular.val.{u1} α _inst_1 (Bot.bot.{u1} (Heyting.Regular.{u1} α _inst_1) (Heyting.Regular.bot.{u1} α _inst_1))) (Bot.bot.{u1} α (HeytingAlgebra.toBot.{u1} α _inst_1))
Case conversion may be inaccurate. Consider using '#align heyting.regular.coe_bot Heyting.Regular.coe_botₓ'. -/
@[simp, norm_cast]
theorem coe_bot : ((⊥ : Regular α) : α) = ⊥ :=
  rfl
#align heyting.regular.coe_bot Heyting.Regular.coe_bot

/- warning: heyting.regular.coe_inf -> Heyting.Regular.coe_inf is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : HeytingAlgebra.{u1} α] (a : Heyting.Regular.{u1} α _inst_1) (b : Heyting.Regular.{u1} α _inst_1), Eq.{succ u1} α ((fun (a : Type.{u1}) (b : Type.{u1}) [self : HasLiftT.{succ u1, succ u1} a b] => self.0) (Heyting.Regular.{u1} α _inst_1) α (HasLiftT.mk.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (CoeTCₓ.coe.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (coeBase.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (Heyting.Regular.hasCoe.{u1} α _inst_1)))) (Inf.inf.{u1} (Heyting.Regular.{u1} α _inst_1) (Heyting.Regular.hasInf.{u1} α _inst_1) a b)) (Inf.inf.{u1} α (SemilatticeInf.toHasInf.{u1} α (Lattice.toSemilatticeInf.{u1} α (GeneralizedHeytingAlgebra.toLattice.{u1} α (HeytingAlgebra.toGeneralizedHeytingAlgebra.{u1} α _inst_1)))) ((fun (a : Type.{u1}) (b : Type.{u1}) [self : HasLiftT.{succ u1, succ u1} a b] => self.0) (Heyting.Regular.{u1} α _inst_1) α (HasLiftT.mk.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (CoeTCₓ.coe.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (coeBase.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (Heyting.Regular.hasCoe.{u1} α _inst_1)))) a) ((fun (a : Type.{u1}) (b : Type.{u1}) [self : HasLiftT.{succ u1, succ u1} a b] => self.0) (Heyting.Regular.{u1} α _inst_1) α (HasLiftT.mk.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (CoeTCₓ.coe.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (coeBase.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (Heyting.Regular.hasCoe.{u1} α _inst_1)))) b))
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : HeytingAlgebra.{u1} α] (a : Heyting.Regular.{u1} α _inst_1) (b : Heyting.Regular.{u1} α _inst_1), Eq.{succ u1} α (Heyting.Regular.val.{u1} α _inst_1 (Inf.inf.{u1} (Heyting.Regular.{u1} α _inst_1) (Heyting.Regular.inf.{u1} α _inst_1) a b)) (Inf.inf.{u1} α (Lattice.toInf.{u1} α (GeneralizedHeytingAlgebra.toLattice.{u1} α (HeytingAlgebra.toGeneralizedHeytingAlgebra.{u1} α _inst_1))) (Heyting.Regular.val.{u1} α _inst_1 a) (Heyting.Regular.val.{u1} α _inst_1 b))
Case conversion may be inaccurate. Consider using '#align heyting.regular.coe_inf Heyting.Regular.coe_infₓ'. -/
@[simp, norm_cast]
theorem coe_inf (a b : Regular α) : (↑(a ⊓ b) : α) = a ⊓ b :=
  rfl
#align heyting.regular.coe_inf Heyting.Regular.coe_inf

/- warning: heyting.regular.coe_himp -> Heyting.Regular.coe_himp is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : HeytingAlgebra.{u1} α] (a : Heyting.Regular.{u1} α _inst_1) (b : Heyting.Regular.{u1} α _inst_1), Eq.{succ u1} α ((fun (a : Type.{u1}) (b : Type.{u1}) [self : HasLiftT.{succ u1, succ u1} a b] => self.0) (Heyting.Regular.{u1} α _inst_1) α (HasLiftT.mk.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (CoeTCₓ.coe.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (coeBase.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (Heyting.Regular.hasCoe.{u1} α _inst_1)))) (HImp.himp.{u1} (Heyting.Regular.{u1} α _inst_1) (Heyting.Regular.hasHimp.{u1} α _inst_1) a b)) (HImp.himp.{u1} α (GeneralizedHeytingAlgebra.toHasHimp.{u1} α (HeytingAlgebra.toGeneralizedHeytingAlgebra.{u1} α _inst_1)) ((fun (a : Type.{u1}) (b : Type.{u1}) [self : HasLiftT.{succ u1, succ u1} a b] => self.0) (Heyting.Regular.{u1} α _inst_1) α (HasLiftT.mk.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (CoeTCₓ.coe.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (coeBase.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (Heyting.Regular.hasCoe.{u1} α _inst_1)))) a) ((fun (a : Type.{u1}) (b : Type.{u1}) [self : HasLiftT.{succ u1, succ u1} a b] => self.0) (Heyting.Regular.{u1} α _inst_1) α (HasLiftT.mk.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (CoeTCₓ.coe.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (coeBase.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (Heyting.Regular.hasCoe.{u1} α _inst_1)))) b))
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : HeytingAlgebra.{u1} α] (a : Heyting.Regular.{u1} α _inst_1) (b : Heyting.Regular.{u1} α _inst_1), Eq.{succ u1} α (Heyting.Regular.val.{u1} α _inst_1 (HImp.himp.{u1} (Heyting.Regular.{u1} α _inst_1) (Heyting.Regular.himp.{u1} α _inst_1) a b)) (HImp.himp.{u1} α (GeneralizedHeytingAlgebra.toHImp.{u1} α (HeytingAlgebra.toGeneralizedHeytingAlgebra.{u1} α _inst_1)) (Heyting.Regular.val.{u1} α _inst_1 a) (Heyting.Regular.val.{u1} α _inst_1 b))
Case conversion may be inaccurate. Consider using '#align heyting.regular.coe_himp Heyting.Regular.coe_himpₓ'. -/
@[simp, norm_cast]
theorem coe_himp (a b : Regular α) : (↑(a ⇨ b) : α) = a ⇨ b :=
  rfl
#align heyting.regular.coe_himp Heyting.Regular.coe_himp

#print Heyting.Regular.coe_compl /-
@[simp, norm_cast]
theorem coe_compl (a : Regular α) : (↑(aᶜ) : α) = aᶜ :=
  rfl
#align heyting.regular.coe_compl Heyting.Regular.coe_compl
-/

instance : Inhabited (Regular α) :=
  ⟨⊥⟩

instance : SemilatticeInf (Regular α) :=
  coe_injective.SemilatticeInf _ coe_inf

instance : BoundedOrder (Regular α) :=
  BoundedOrder.lift coe (fun _ _ => id) coe_top coe_bot

/- warning: heyting.regular.coe_le_coe -> Heyting.Regular.coe_le_coe is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : HeytingAlgebra.{u1} α] {a : Heyting.Regular.{u1} α _inst_1} {b : Heyting.Regular.{u1} α _inst_1}, Iff (LE.le.{u1} α (Preorder.toLE.{u1} α (PartialOrder.toPreorder.{u1} α (SemilatticeInf.toPartialOrder.{u1} α (Lattice.toSemilatticeInf.{u1} α (GeneralizedHeytingAlgebra.toLattice.{u1} α (HeytingAlgebra.toGeneralizedHeytingAlgebra.{u1} α _inst_1)))))) ((fun (a : Type.{u1}) (b : Type.{u1}) [self : HasLiftT.{succ u1, succ u1} a b] => self.0) (Heyting.Regular.{u1} α _inst_1) α (HasLiftT.mk.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (CoeTCₓ.coe.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (coeBase.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (Heyting.Regular.hasCoe.{u1} α _inst_1)))) a) ((fun (a : Type.{u1}) (b : Type.{u1}) [self : HasLiftT.{succ u1, succ u1} a b] => self.0) (Heyting.Regular.{u1} α _inst_1) α (HasLiftT.mk.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (CoeTCₓ.coe.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (coeBase.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (Heyting.Regular.hasCoe.{u1} α _inst_1)))) b)) (LE.le.{u1} (Heyting.Regular.{u1} α _inst_1) (Preorder.toLE.{u1} (Heyting.Regular.{u1} α _inst_1) (PartialOrder.toPreorder.{u1} (Heyting.Regular.{u1} α _inst_1) (SemilatticeInf.toPartialOrder.{u1} (Heyting.Regular.{u1} α _inst_1) (Heyting.Regular.semilatticeInf.{u1} α _inst_1)))) a b)
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : HeytingAlgebra.{u1} α] {a : Heyting.Regular.{u1} α _inst_1} {b : Heyting.Regular.{u1} α _inst_1}, Iff (LE.le.{u1} α (Preorder.toLE.{u1} α (PartialOrder.toPreorder.{u1} α (SemilatticeInf.toPartialOrder.{u1} α (Lattice.toSemilatticeInf.{u1} α (GeneralizedHeytingAlgebra.toLattice.{u1} α (HeytingAlgebra.toGeneralizedHeytingAlgebra.{u1} α _inst_1)))))) (Heyting.Regular.val.{u1} α _inst_1 a) (Heyting.Regular.val.{u1} α _inst_1 b)) (LE.le.{u1} (Heyting.Regular.{u1} α _inst_1) (Preorder.toLE.{u1} (Heyting.Regular.{u1} α _inst_1) (PartialOrder.toPreorder.{u1} (Heyting.Regular.{u1} α _inst_1) (SemilatticeInf.toPartialOrder.{u1} (Heyting.Regular.{u1} α _inst_1) (Heyting.Regular.instSemilatticeInfRegular.{u1} α _inst_1)))) a b)
Case conversion may be inaccurate. Consider using '#align heyting.regular.coe_le_coe Heyting.Regular.coe_le_coeₓ'. -/
@[simp, norm_cast]
theorem coe_le_coe {a b : Regular α} : (a : α) ≤ b ↔ a ≤ b :=
  Iff.rfl
#align heyting.regular.coe_le_coe Heyting.Regular.coe_le_coe

/- warning: heyting.regular.coe_lt_coe -> Heyting.Regular.coe_lt_coe is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : HeytingAlgebra.{u1} α] {a : Heyting.Regular.{u1} α _inst_1} {b : Heyting.Regular.{u1} α _inst_1}, Iff (LT.lt.{u1} α (Preorder.toLT.{u1} α (PartialOrder.toPreorder.{u1} α (SemilatticeInf.toPartialOrder.{u1} α (Lattice.toSemilatticeInf.{u1} α (GeneralizedHeytingAlgebra.toLattice.{u1} α (HeytingAlgebra.toGeneralizedHeytingAlgebra.{u1} α _inst_1)))))) ((fun (a : Type.{u1}) (b : Type.{u1}) [self : HasLiftT.{succ u1, succ u1} a b] => self.0) (Heyting.Regular.{u1} α _inst_1) α (HasLiftT.mk.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (CoeTCₓ.coe.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (coeBase.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (Heyting.Regular.hasCoe.{u1} α _inst_1)))) a) ((fun (a : Type.{u1}) (b : Type.{u1}) [self : HasLiftT.{succ u1, succ u1} a b] => self.0) (Heyting.Regular.{u1} α _inst_1) α (HasLiftT.mk.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (CoeTCₓ.coe.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (coeBase.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (Heyting.Regular.hasCoe.{u1} α _inst_1)))) b)) (LT.lt.{u1} (Heyting.Regular.{u1} α _inst_1) (Preorder.toLT.{u1} (Heyting.Regular.{u1} α _inst_1) (PartialOrder.toPreorder.{u1} (Heyting.Regular.{u1} α _inst_1) (SemilatticeInf.toPartialOrder.{u1} (Heyting.Regular.{u1} α _inst_1) (Heyting.Regular.semilatticeInf.{u1} α _inst_1)))) a b)
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : HeytingAlgebra.{u1} α] {a : Heyting.Regular.{u1} α _inst_1} {b : Heyting.Regular.{u1} α _inst_1}, Iff (LT.lt.{u1} α (Preorder.toLT.{u1} α (PartialOrder.toPreorder.{u1} α (SemilatticeInf.toPartialOrder.{u1} α (Lattice.toSemilatticeInf.{u1} α (GeneralizedHeytingAlgebra.toLattice.{u1} α (HeytingAlgebra.toGeneralizedHeytingAlgebra.{u1} α _inst_1)))))) (Heyting.Regular.val.{u1} α _inst_1 a) (Heyting.Regular.val.{u1} α _inst_1 b)) (LT.lt.{u1} (Heyting.Regular.{u1} α _inst_1) (Preorder.toLT.{u1} (Heyting.Regular.{u1} α _inst_1) (PartialOrder.toPreorder.{u1} (Heyting.Regular.{u1} α _inst_1) (SemilatticeInf.toPartialOrder.{u1} (Heyting.Regular.{u1} α _inst_1) (Heyting.Regular.instSemilatticeInfRegular.{u1} α _inst_1)))) a b)
Case conversion may be inaccurate. Consider using '#align heyting.regular.coe_lt_coe Heyting.Regular.coe_lt_coeₓ'. -/
@[simp, norm_cast]
theorem coe_lt_coe {a b : Regular α} : (a : α) < b ↔ a < b :=
  Iff.rfl
#align heyting.regular.coe_lt_coe Heyting.Regular.coe_lt_coe

/- warning: heyting.regular.to_regular -> Heyting.Regular.toRegular is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : HeytingAlgebra.{u1} α], OrderHom.{u1, u1} α (Heyting.Regular.{u1} α _inst_1) (PartialOrder.toPreorder.{u1} α (SemilatticeInf.toPartialOrder.{u1} α (Lattice.toSemilatticeInf.{u1} α (GeneralizedHeytingAlgebra.toLattice.{u1} α (HeytingAlgebra.toGeneralizedHeytingAlgebra.{u1} α _inst_1))))) (PartialOrder.toPreorder.{u1} (Heyting.Regular.{u1} α _inst_1) (SemilatticeInf.toPartialOrder.{u1} (Heyting.Regular.{u1} α _inst_1) (Heyting.Regular.semilatticeInf.{u1} α _inst_1)))
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : HeytingAlgebra.{u1} α], OrderHom.{u1, u1} α (Heyting.Regular.{u1} α _inst_1) (PartialOrder.toPreorder.{u1} α (SemilatticeInf.toPartialOrder.{u1} α (Lattice.toSemilatticeInf.{u1} α (GeneralizedHeytingAlgebra.toLattice.{u1} α (HeytingAlgebra.toGeneralizedHeytingAlgebra.{u1} α _inst_1))))) (PartialOrder.toPreorder.{u1} (Heyting.Regular.{u1} α _inst_1) (SemilatticeInf.toPartialOrder.{u1} (Heyting.Regular.{u1} α _inst_1) (Heyting.Regular.instSemilatticeInfRegular.{u1} α _inst_1)))
Case conversion may be inaccurate. Consider using '#align heyting.regular.to_regular Heyting.Regular.toRegularₓ'. -/
/-- **Regularization** of `a`. The smallest regular element greater than `a`. -/
def toRegular : α →o Regular α :=
  ⟨fun a => ⟨aᶜᶜ, isRegular_compl _⟩, fun a b h =>
    coe_le_coe.1 <| compl_le_compl <| compl_le_compl h⟩
#align heyting.regular.to_regular Heyting.Regular.toRegular

#print Heyting.Regular.coe_toRegular /-
@[simp, norm_cast]
theorem coe_toRegular (a : α) : (toRegular a : α) = aᶜᶜ :=
  rfl
#align heyting.regular.coe_to_regular Heyting.Regular.coe_toRegular
-/

#print Heyting.Regular.toRegular_coe /-
@[simp]
theorem toRegular_coe (a : Regular α) : toRegular (a : α) = a :=
  coe_injective a.2
#align heyting.regular.to_regular_coe Heyting.Regular.toRegular_coe
-/

/- warning: heyting.regular.gi -> Heyting.Regular.gi is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : HeytingAlgebra.{u1} α], GaloisInsertion.{u1, u1} α (Heyting.Regular.{u1} α _inst_1) (PartialOrder.toPreorder.{u1} α (SemilatticeInf.toPartialOrder.{u1} α (Lattice.toSemilatticeInf.{u1} α (GeneralizedHeytingAlgebra.toLattice.{u1} α (HeytingAlgebra.toGeneralizedHeytingAlgebra.{u1} α _inst_1))))) (PartialOrder.toPreorder.{u1} (Heyting.Regular.{u1} α _inst_1) (SemilatticeInf.toPartialOrder.{u1} (Heyting.Regular.{u1} α _inst_1) (Heyting.Regular.semilatticeInf.{u1} α _inst_1))) (coeFn.{succ u1, succ u1} (OrderHom.{u1, u1} α (Heyting.Regular.{u1} α _inst_1) (PartialOrder.toPreorder.{u1} α (SemilatticeInf.toPartialOrder.{u1} α (Lattice.toSemilatticeInf.{u1} α (GeneralizedHeytingAlgebra.toLattice.{u1} α (HeytingAlgebra.toGeneralizedHeytingAlgebra.{u1} α _inst_1))))) (PartialOrder.toPreorder.{u1} (Heyting.Regular.{u1} α _inst_1) (SemilatticeInf.toPartialOrder.{u1} (Heyting.Regular.{u1} α _inst_1) (Heyting.Regular.semilatticeInf.{u1} α _inst_1)))) (fun (_x : OrderHom.{u1, u1} α (Heyting.Regular.{u1} α _inst_1) (PartialOrder.toPreorder.{u1} α (SemilatticeInf.toPartialOrder.{u1} α (Lattice.toSemilatticeInf.{u1} α (GeneralizedHeytingAlgebra.toLattice.{u1} α (HeytingAlgebra.toGeneralizedHeytingAlgebra.{u1} α _inst_1))))) (PartialOrder.toPreorder.{u1} (Heyting.Regular.{u1} α _inst_1) (SemilatticeInf.toPartialOrder.{u1} (Heyting.Regular.{u1} α _inst_1) (Heyting.Regular.semilatticeInf.{u1} α _inst_1)))) => α -> (Heyting.Regular.{u1} α _inst_1)) (OrderHom.hasCoeToFun.{u1, u1} α (Heyting.Regular.{u1} α _inst_1) (PartialOrder.toPreorder.{u1} α (SemilatticeInf.toPartialOrder.{u1} α (Lattice.toSemilatticeInf.{u1} α (GeneralizedHeytingAlgebra.toLattice.{u1} α (HeytingAlgebra.toGeneralizedHeytingAlgebra.{u1} α _inst_1))))) (PartialOrder.toPreorder.{u1} (Heyting.Regular.{u1} α _inst_1) (SemilatticeInf.toPartialOrder.{u1} (Heyting.Regular.{u1} α _inst_1) (Heyting.Regular.semilatticeInf.{u1} α _inst_1)))) (Heyting.Regular.toRegular.{u1} α _inst_1)) ((fun (a : Type.{u1}) (b : Type.{u1}) [self : HasLiftT.{succ u1, succ u1} a b] => self.0) (Heyting.Regular.{u1} α _inst_1) α (HasLiftT.mk.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (CoeTCₓ.coe.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (coeBase.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (Heyting.Regular.hasCoe.{u1} α _inst_1)))))
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : HeytingAlgebra.{u1} α], GaloisInsertion.{u1, u1} α (Heyting.Regular.{u1} α _inst_1) (PartialOrder.toPreorder.{u1} α (SemilatticeInf.toPartialOrder.{u1} α (Lattice.toSemilatticeInf.{u1} α (GeneralizedHeytingAlgebra.toLattice.{u1} α (HeytingAlgebra.toGeneralizedHeytingAlgebra.{u1} α _inst_1))))) (PartialOrder.toPreorder.{u1} (Heyting.Regular.{u1} α _inst_1) (SemilatticeInf.toPartialOrder.{u1} (Heyting.Regular.{u1} α _inst_1) (Heyting.Regular.instSemilatticeInfRegular.{u1} α _inst_1))) (OrderHom.toFun.{u1, u1} α (Heyting.Regular.{u1} α _inst_1) (PartialOrder.toPreorder.{u1} α (SemilatticeInf.toPartialOrder.{u1} α (Lattice.toSemilatticeInf.{u1} α (GeneralizedHeytingAlgebra.toLattice.{u1} α (HeytingAlgebra.toGeneralizedHeytingAlgebra.{u1} α _inst_1))))) (PartialOrder.toPreorder.{u1} (Heyting.Regular.{u1} α _inst_1) (SemilatticeInf.toPartialOrder.{u1} (Heyting.Regular.{u1} α _inst_1) (Heyting.Regular.instSemilatticeInfRegular.{u1} α _inst_1))) (Heyting.Regular.toRegular.{u1} α _inst_1)) (Heyting.Regular.val.{u1} α _inst_1)
Case conversion may be inaccurate. Consider using '#align heyting.regular.gi Heyting.Regular.giₓ'. -/
/-- The Galois insertion between `regular.to_regular` and `coe`. -/
def gi : GaloisInsertion toRegular (coe : Regular α → α)
    where
  choice a ha := ⟨a, ha.antisymm le_compl_compl⟩
  gc a b :=
    coe_le_coe.symm.trans <|
      ⟨le_compl_compl.trans, fun h => (compl_anti <| compl_anti h).trans_eq b.2⟩
  le_l_u _ := le_compl_compl
  choice_eq a ha := coe_injective <| le_compl_compl.antisymm ha
#align heyting.regular.gi Heyting.Regular.gi

instance : Lattice (Regular α) :=
  gi.liftLattice

/- warning: heyting.regular.coe_sup -> Heyting.Regular.coe_sup is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : HeytingAlgebra.{u1} α] (a : Heyting.Regular.{u1} α _inst_1) (b : Heyting.Regular.{u1} α _inst_1), Eq.{succ u1} α ((fun (a : Type.{u1}) (b : Type.{u1}) [self : HasLiftT.{succ u1, succ u1} a b] => self.0) (Heyting.Regular.{u1} α _inst_1) α (HasLiftT.mk.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (CoeTCₓ.coe.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (coeBase.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (Heyting.Regular.hasCoe.{u1} α _inst_1)))) (Sup.sup.{u1} (Heyting.Regular.{u1} α _inst_1) (SemilatticeSup.toHasSup.{u1} (Heyting.Regular.{u1} α _inst_1) (Lattice.toSemilatticeSup.{u1} (Heyting.Regular.{u1} α _inst_1) (Heyting.Regular.lattice.{u1} α _inst_1))) a b)) (HasCompl.compl.{u1} α (HeytingAlgebra.toHasCompl.{u1} α _inst_1) (HasCompl.compl.{u1} α (HeytingAlgebra.toHasCompl.{u1} α _inst_1) (Sup.sup.{u1} α (SemilatticeSup.toHasSup.{u1} α (Lattice.toSemilatticeSup.{u1} α (GeneralizedHeytingAlgebra.toLattice.{u1} α (HeytingAlgebra.toGeneralizedHeytingAlgebra.{u1} α _inst_1)))) ((fun (a : Type.{u1}) (b : Type.{u1}) [self : HasLiftT.{succ u1, succ u1} a b] => self.0) (Heyting.Regular.{u1} α _inst_1) α (HasLiftT.mk.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (CoeTCₓ.coe.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (coeBase.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (Heyting.Regular.hasCoe.{u1} α _inst_1)))) a) ((fun (a : Type.{u1}) (b : Type.{u1}) [self : HasLiftT.{succ u1, succ u1} a b] => self.0) (Heyting.Regular.{u1} α _inst_1) α (HasLiftT.mk.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (CoeTCₓ.coe.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (coeBase.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (Heyting.Regular.hasCoe.{u1} α _inst_1)))) b))))
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : HeytingAlgebra.{u1} α] (a : Heyting.Regular.{u1} α _inst_1) (b : Heyting.Regular.{u1} α _inst_1), Eq.{succ u1} α (Heyting.Regular.val.{u1} α _inst_1 (Sup.sup.{u1} (Heyting.Regular.{u1} α _inst_1) (SemilatticeSup.toSup.{u1} (Heyting.Regular.{u1} α _inst_1) (Lattice.toSemilatticeSup.{u1} (Heyting.Regular.{u1} α _inst_1) (Heyting.Regular.lattice.{u1} α _inst_1))) a b)) (HasCompl.compl.{u1} α (HeytingAlgebra.toHasCompl.{u1} α _inst_1) (HasCompl.compl.{u1} α (HeytingAlgebra.toHasCompl.{u1} α _inst_1) (Sup.sup.{u1} α (SemilatticeSup.toSup.{u1} α (Lattice.toSemilatticeSup.{u1} α (GeneralizedHeytingAlgebra.toLattice.{u1} α (HeytingAlgebra.toGeneralizedHeytingAlgebra.{u1} α _inst_1)))) (Heyting.Regular.val.{u1} α _inst_1 a) (Heyting.Regular.val.{u1} α _inst_1 b))))
Case conversion may be inaccurate. Consider using '#align heyting.regular.coe_sup Heyting.Regular.coe_supₓ'. -/
@[simp, norm_cast]
theorem coe_sup (a b : Regular α) : (↑(a ⊔ b) : α) = (a ⊔ b)ᶜᶜ :=
  rfl
#align heyting.regular.coe_sup Heyting.Regular.coe_sup

instance : BooleanAlgebra (Regular α) :=
  { Regular.lattice, Regular.boundedOrder, Regular.hasHimp,
    Regular.hasCompl with
    le_sup_inf := fun a b c =>
      coe_le_coe.1 <| by
        dsimp
        rw [sup_inf_left, compl_compl_inf_distrib]
    inf_compl_le_bot := fun a => coe_le_coe.1 <| disjoint_iff_inf_le.1 disjoint_compl_right
    top_le_sup_compl := fun a =>
      coe_le_coe.1 <| by
        dsimp
        rw [compl_sup, inf_compl_eq_bot, compl_bot]
        rfl
    himp_eq := fun a b =>
      coe_injective
        (by
          dsimp
          rw [compl_sup, a.prop.eq]
          refine' eq_of_forall_le_iff fun c => le_himp_iff.trans _
          rw [le_compl_iff_disjoint_right, disjoint_left_comm, b.prop.disjoint_compl_left_iff]) }

/- warning: heyting.regular.coe_sdiff -> Heyting.Regular.coe_sdiff is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : HeytingAlgebra.{u1} α] (a : Heyting.Regular.{u1} α _inst_1) (b : Heyting.Regular.{u1} α _inst_1), Eq.{succ u1} α ((fun (a : Type.{u1}) (b : Type.{u1}) [self : HasLiftT.{succ u1, succ u1} a b] => self.0) (Heyting.Regular.{u1} α _inst_1) α (HasLiftT.mk.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (CoeTCₓ.coe.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (coeBase.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (Heyting.Regular.hasCoe.{u1} α _inst_1)))) (SDiff.sdiff.{u1} (Heyting.Regular.{u1} α _inst_1) (BooleanAlgebra.toHasSdiff.{u1} (Heyting.Regular.{u1} α _inst_1) (Heyting.Regular.booleanAlgebra.{u1} α _inst_1)) a b)) (Inf.inf.{u1} α (SemilatticeInf.toHasInf.{u1} α (Lattice.toSemilatticeInf.{u1} α (GeneralizedHeytingAlgebra.toLattice.{u1} α (HeytingAlgebra.toGeneralizedHeytingAlgebra.{u1} α _inst_1)))) ((fun (a : Type.{u1}) (b : Type.{u1}) [self : HasLiftT.{succ u1, succ u1} a b] => self.0) (Heyting.Regular.{u1} α _inst_1) α (HasLiftT.mk.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (CoeTCₓ.coe.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (coeBase.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (Heyting.Regular.hasCoe.{u1} α _inst_1)))) a) (HasCompl.compl.{u1} α (HeytingAlgebra.toHasCompl.{u1} α _inst_1) ((fun (a : Type.{u1}) (b : Type.{u1}) [self : HasLiftT.{succ u1, succ u1} a b] => self.0) (Heyting.Regular.{u1} α _inst_1) α (HasLiftT.mk.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (CoeTCₓ.coe.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (coeBase.{succ u1, succ u1} (Heyting.Regular.{u1} α _inst_1) α (Heyting.Regular.hasCoe.{u1} α _inst_1)))) b)))
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : HeytingAlgebra.{u1} α] (a : Heyting.Regular.{u1} α _inst_1) (b : Heyting.Regular.{u1} α _inst_1), Eq.{succ u1} α (Heyting.Regular.val.{u1} α _inst_1 (SDiff.sdiff.{u1} (Heyting.Regular.{u1} α _inst_1) (BooleanAlgebra.toSDiff.{u1} (Heyting.Regular.{u1} α _inst_1) (Heyting.Regular.instBooleanAlgebraRegular.{u1} α _inst_1)) a b)) (Inf.inf.{u1} α (Lattice.toInf.{u1} α (GeneralizedHeytingAlgebra.toLattice.{u1} α (HeytingAlgebra.toGeneralizedHeytingAlgebra.{u1} α _inst_1))) (Heyting.Regular.val.{u1} α _inst_1 a) (HasCompl.compl.{u1} α (HeytingAlgebra.toHasCompl.{u1} α _inst_1) (Heyting.Regular.val.{u1} α _inst_1 b)))
Case conversion may be inaccurate. Consider using '#align heyting.regular.coe_sdiff Heyting.Regular.coe_sdiffₓ'. -/
@[simp, norm_cast]
theorem coe_sdiff (a b : Regular α) : (↑(a \ b) : α) = a ⊓ bᶜ :=
  rfl
#align heyting.regular.coe_sdiff Heyting.Regular.coe_sdiff

end Regular

end HeytingAlgebra

variable [BooleanAlgebra α]

#print Heyting.isRegular_of_boolean /-
theorem isRegular_of_boolean : ∀ a : α, IsRegular a :=
  compl_compl
#align heyting.is_regular_of_boolean Heyting.isRegular_of_boolean
-/

#print Heyting.isRegular_of_decidable /-
/-- A decidable proposition is intuitionistically Heyting-regular. -/
@[nolint decidable_classical]
theorem isRegular_of_decidable (p : Prop) [Decidable p] : IsRegular p :=
  propext <| Decidable.not_not_iff _
#align heyting.is_regular_of_decidable Heyting.isRegular_of_decidable
-/

end Heyting


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

This file gives some basic definitions for graph theory.
It supports only graphs with no loops or multiple edges.

It should be refactored to use definitions and results from
data/pos_list.lean

-/

import data.pos_list
import tactic.interactive

namespace combinatorics

class graph (V : Type) : Type :=
(edge : V → V → Prop)
(symm : ∀ {u v : V}, edge u v → edge v u)
(asymm : ∀ v : V, ¬ edge v v)

namespace graph

variables {V : Type} [graph V]

def is_path : pos_list V → Prop
| (pos_list.const _) := true
| (pos_list.cons v p) := (edge v p.head) ∧ is_path p

lemma is_path_append (p q : pos_list V) :
 is_path (pos_list.append p q) ↔
  is_path p ∧ edge p.foot q.head ∧ is_path q :=
begin
 induction p with a a p ih,
 {dsimp[is_path,pos_list.foot,pos_list.append,is_path],
  rw[true_and]
 },
 {dsimp[pos_list.append,pos_list.foot,is_path],
  rw[pos_list.head_append,ih,and_assoc],
 }
end

lemma is_path_reverse : ∀ {p : pos_list V},
 is_path p → is_path p.reverse
| (pos_list.const a) _ := by {dsimp[pos_list.reverse,is_path],trivial}
| (pos_list.cons a p) h := begin
 dsimp[pos_list.reverse,is_path],
 dsimp[is_path] at h,
 rw[is_path_append,pos_list.head,pos_list.foot_reverse,is_path,and_true],
 exact ⟨is_path_reverse h.right,symm h.left⟩,
end
variable (V)

def path : Type := { p : pos_list V // is_path p }

variable {V}

def path_between (a b : V) : Type :=
 { p : pos_list V // is_path p ∧ p.head = a ∧ p.foot = b }

namespace path

def head (p : path V) : V := p.val.head

def foot (p : path V) : V := p.val.foot

def length (p : path V) : ℕ := p.val.length

def cons (v : V) (p : path V) (h : edge v p.head) : path V :=
 ⟨pos_list.cons v p.val,⟨h,p.property⟩⟩

def const (v : V) : path_between v v :=
 ⟨pos_list.const v,⟨trivial,rfl,rfl⟩⟩

def reverse {u v : V} : ∀ (p : path_between u v), path_between v u
| ⟨p,⟨p_path,p_head,p_foot⟩⟩  :=
 ⟨p.reverse,⟨is_path_reverse p_path,
            (pos_list.head_reverse p).trans p_foot,
            (pos_list.foot_reverse p).trans p_head⟩⟩

def splice {u v w : V} :
 ∀ (p : path_between u v) (q : path_between v w),
     path_between u w
| ⟨p,⟨p_path,p_head,p_foot⟩⟩ ⟨pos_list.const x,⟨q_path,q_head,q_foot⟩⟩ :=
    ⟨p,begin
        change x = v at q_head,
        change x = w at q_foot,
        replace p_foot := p_foot.trans (q_head.symm.trans q_foot),
        exact ⟨p_path,p_head,p_foot⟩
       end⟩
| ⟨p,⟨p_path,p_head,p_foot⟩⟩ ⟨pos_list.cons x q,⟨q_path,q_head,q_foot⟩⟩ :=
   ⟨pos_list.append p q,
    begin
     change x = v at q_head,
     change q.foot = w at q_foot,
     rw[pos_list.head_append,p_head,pos_list.foot_append,q_foot],
     split,
     {dsimp[is_path] at q_path,rw[is_path_append,p_foot,← q_head],
      exact ⟨p_path,q_path⟩},
     {split;refl,}
    end
   ⟩

instance are_connected : setoid V := {
  r := λ a b, nonempty (path_between a b),
  iseqv := ⟨
   λ a, nonempty.intro (const a),
   λ a b ⟨p⟩, nonempty.intro (reverse p),
   λ a b c ⟨p⟩ ⟨q⟩, nonempty.intro (splice p q)
  ⟩
}

/-
 For finite graphs with decidable equality:
 define valence, prove that there are two vertices with
 the same valence.
-/

end path
end graph
end combinatorics