/-
Copyright (c) 2022 Bhavik Mehta All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta, Yaël Dillies
-/
import analysis.convex.cone
import analysis.convex.gauge

/-!
# Separation Hahn-Banach theorem

In this file we prove the geometric Hahn-Banach theorem. For any two disjoint convex sets, there
exists a continuous linear functional separating them, geometrically meaning that we can intercalate
a plane between them.

We provide many variations to stricten the result under more assumptions on the convex sets:
* `geometric_hahn_banach_open`: One set is open. Weak separation.
* `geometric_hahn_banach_open_point`, `geometric_hahn_banach_point_open`: One set is open, the
  other is a singleton. Weak separation.
* `geometric_hahn_banach_open_open`: Both sets are open. Semistrict separation.
* `geometric_hahn_banach_compact_closed`, `geometric_hahn_banach_closed_compact`: One set is closed,
  the other one is compact. Strict separation.
* `geometric_hahn_banach_point_closed`, `geometric_hahn_banach_closed_point`: One set is closed, the
  other one is a singleton. Strict separation.
* `geometric_hahn_banach_point_point`: Both sets are singletons. Strict separation.

## TODO

* Eidelheit's theorem
* `convex ℝ s → interior (closure s) ⊆ s`
-/

open set
open_locale pointwise

variables {𝕜 E : Type*}

/-- Given a set `s` which is a convex neighbourhood of `0` and a point `x₀` outside of it, there is
a continuous linear functional `f` separating `x₀` and `s`, in the sense that it sends `x₀` to 1 and
all of `s` to values strictly below `1`. -/
lemma separate_convex_open_set [semi_normed_group E] [normed_space ℝ E] {s : set E}
  (hs₀ : (0 : E) ∈ s) (hs₁ : convex ℝ s) (hs₂ : is_open s) {x₀ : E} (hx₀ : x₀ ∉ s) :
  ∃ f : E →L[ℝ] ℝ, f x₀ = 1 ∧ ∀ x ∈ s, f x < 1 :=
begin
  let f : linear_pmap ℝ E ℝ :=
    linear_pmap.mk_span_singleton x₀ 1 (ne_of_mem_of_not_mem hs₀ hx₀).symm,
  obtain ⟨r, hr, hrs⟩ := metric.mem_nhds_iff.1
    (filter.inter_mem (hs₂.mem_nhds hs₀) $ hs₂.neg.mem_nhds $ by rwa [mem_neg, neg_zero]),
  obtain ⟨φ, hφ₁, hφ₂⟩ := exists_extension_of_le_sublinear f (gauge s)
    (λ c hc, gauge_smul_of_nonneg hc.le)
    (gauge_add_le hs₁ $ absorbent_nhds_zero $ hs₂.mem_nhds hs₀) _,
  { refine ⟨φ.mk_continuous (r⁻¹) $ λ x, _, _, _⟩,
    { rw [real.norm_eq_abs, abs_le, neg_le, ←linear_map.map_neg],
      nth_rewrite 0 ←norm_neg x,
      suffices : ∀ x, φ x ≤ r⁻¹ * ∥x∥,
      { exact ⟨this _, this _⟩ },
      refine λ x, (hφ₂ _).trans _,
      rw [←div_eq_inv_mul, ←gauge_ball hr],
      exact gauge_mono (absorbent_ball_zero hr) (hrs.trans $ inter_subset_left _ _) x },
    { dsimp,
      rw [←submodule.coe_mk x₀ (submodule.mem_span_singleton_self _), hφ₁,
        linear_pmap.mk_span_singleton'_apply_self] },
    { exact λ x hx, (hφ₂ x).trans_lt (gauge_lt_one_of_mem_of_open hs₁ hs₀ hs₂ hx) } },
  rintro ⟨x, hx⟩,
  obtain ⟨y, rfl⟩ := submodule.mem_span_singleton.1 hx,
  rw linear_pmap.mk_span_singleton'_apply,
  simp only [mul_one, algebra.id.smul_eq_mul, submodule.coe_mk],
  obtain h | h := le_or_lt y 0,
  { exact h.trans (gauge_nonneg _) },
  { rw [gauge_smul_of_nonneg h.le, smul_eq_mul, le_mul_iff_one_le_right h],
    exact one_le_gauge_of_not_mem (hs₁.star_convex hs₀)
      ((absorbent_ball_zero hr).subset $ hrs.trans $ inter_subset_left _ _).absorbs hx₀,
    apply_instance }
end

variables [normed_group E] [normed_space ℝ E] {s t : set E} {x y : E}

/-- A version of the **Hahn-Banach theorem**: given disjoint convex sets `s`, `t` where `s` is open,
there is a continuous linear functional which separates them. -/
theorem geometric_hahn_banach_open (hs₁ : convex ℝ s) (hs₂ : is_open s) (ht : convex ℝ t)
  (disj : disjoint s t) :
  ∃ (f : E →L[ℝ] ℝ) (u : ℝ), (∀ a ∈ s, f a < u) ∧ ∀ b ∈ t, u ≤ f b :=
begin
  obtain rfl | ⟨a₀, ha₀⟩ := s.eq_empty_or_nonempty,
  { exact ⟨0, 0, by simp, λ b hb, le_rfl⟩ },
  obtain rfl | ⟨b₀, hb₀⟩ := t.eq_empty_or_nonempty,
  { exact ⟨0, 1, λ a ha, zero_lt_one, by simp⟩ },
  let x₀ := b₀ - a₀,
  let C := x₀ +ᵥ (s - t),
  have : (0:E) ∈ C := ⟨a₀ - b₀, sub_mem_sub ha₀ hb₀,
    by rw [vadd_eq_add, sub_add_sub_cancel', sub_self]⟩,
  have : convex ℝ C := (hs₁.sub ht).vadd _,
  have : x₀ ∉ C,
  { intro hx₀,
    rw ←add_zero x₀ at hx₀,
    exact disj.zero_not_mem_sub_set (vadd_mem_vadd_set_iff.1 hx₀) },
  obtain ⟨f, hf₁, hf₂⟩ := separate_convex_open_set ‹0 ∈ C› ‹_› (hs₂.sub_right.vadd _) ‹x₀ ∉ C›,
  have : f b₀ = f a₀ + 1 := by simp [←hf₁],
  have forall_le : ∀ (a ∈ s) (b ∈ t), f a ≤ f b,
  { intros a ha b hb,
    have := hf₂ (x₀ + (a - b)) (vadd_mem_vadd_set $ sub_mem_sub ha hb),
    simp only [f.map_add, f.map_sub, hf₁] at this,
    linarith },
  refine ⟨f, Inf (f '' t), image_subset_iff.1 (_ : f '' s ⊆ Iio (Inf (f '' t))), λ b hb, _⟩,
  { rw ←interior_Iic,
    refine interior_maximal (image_subset_iff.2 $ λ a ha, _) (f.is_open_map_of_ne_zero _ _ hs₂),
    { exact le_cInf (nonempty.image _ ⟨_, hb₀⟩) (ball_image_of_ball $ forall_le _ ha) },
    { rintro rfl,
      simpa using hf₁ } },
  { exact cInf_le ⟨f a₀, ball_image_of_ball $ forall_le _ ha₀⟩ (mem_image_of_mem _ hb) }
end

theorem geometric_hahn_banach_open_point (hs₁ : convex ℝ s) (hs₂ : is_open s) (disj : x ∉ s) :
  ∃ f : E →L[ℝ] ℝ, ∀ a ∈ s, f a < f x :=
let ⟨f, s, hs, hx⟩ := geometric_hahn_banach_open hs₁ hs₂ (convex_singleton x)
  (disjoint_singleton_right.2 disj)
  in ⟨f, λ a ha, lt_of_lt_of_le (hs a ha) (hx x (mem_singleton _))⟩

theorem geometric_hahn_banach_point_open (ht₁ : convex ℝ t) (ht₂ : is_open t) (disj : x ∉ t) :
  ∃ f : E →L[ℝ] ℝ, ∀ b ∈ t, f x < f b :=
let ⟨f, hf⟩ := geometric_hahn_banach_open_point ht₁ ht₂ disj in ⟨-f, by simpa⟩

theorem geometric_hahn_banach_open_open (hs₁ : convex ℝ s) (hs₂ : is_open s) (ht₁ : convex ℝ t)
  (ht₃ : is_open t) (disj : disjoint s t) :
  ∃ (f : E →L[ℝ] ℝ) (u : ℝ), (∀ a ∈ s, f a < u) ∧ ∀ b ∈ t, u < f b :=
begin
  obtain (rfl | ⟨a₀, ha₀⟩) := s.eq_empty_or_nonempty,
  { exact ⟨0, -1, by simp, λ b hb, by norm_num⟩ },
  obtain (rfl | ⟨b₀, hb₀⟩) := t.eq_empty_or_nonempty,
  { exact ⟨0, 1, λ a ha, by norm_num, by simp⟩ },
  obtain ⟨f, s, hf₁, hf₂⟩ := geometric_hahn_banach_open hs₁ hs₂ ht₁ disj,
  have hf : is_open_map f,
  { refine f.is_open_map_of_ne_zero _,
    rintro rfl,
    exact (hf₁ _ ha₀).not_le (hf₂ _ hb₀) },
  refine ⟨f, s, hf₁, image_subset_iff.1 (_ : f '' t ⊆ Ioi s)⟩,
  rw ←interior_Ici,
  refine interior_maximal (image_subset_iff.2 hf₂) (f.is_open_map_of_ne_zero _ _ ht₃),
  rintro rfl,
  exact (hf₁ _ ha₀).not_le (hf₂ _ hb₀),
end

/-- A version of the **Hahn-Banach theorem**: given disjoint convex sets `s`, `t` where `s` is
compact and `t` is closed, there is a continuous linear functional which strongly separates them. -/
theorem geometric_hahn_banach_compact_closed (hs₁ : convex ℝ s) (hs₂ : is_compact s)
  (ht₁ : convex ℝ t) (ht₂ : is_closed t) (disj : disjoint s t) :
  ∃ (f : E →L[ℝ] ℝ) (u v : ℝ), (∀ a ∈ s, f a < u) ∧ u < v ∧ ∀ b ∈ t, v < f b :=
begin
  obtain rfl | hs := s.eq_empty_or_nonempty,
  { exact ⟨0, -2, -1, by simp, by norm_num, λ b hb, by norm_num⟩ },
  unfreezingI { obtain rfl | ht := t.eq_empty_or_nonempty },
  { exact ⟨0, 1, 2, λ a ha, by norm_num, by norm_num, by simp⟩ },
  obtain ⟨U, V, hU, hV, hU₁, hV₁, sU, tV, disj'⟩ := disj.exists_open_convexes hs₁ hs₂ ht₁ ht₂,
  obtain ⟨f, u, hf₁, hf₂⟩ := geometric_hahn_banach_open_open hU₁ hU hV₁ hV disj',
  obtain ⟨x, hx₁, hx₂⟩ := hs₂.exists_forall_ge hs f.continuous.continuous_on,
  have : f x < u := hf₁ x (sU hx₁),
  exact ⟨f, (f x + u)/2, u, λ a ha, by linarith [hx₂ a ha], by linarith, λ b hb, hf₂ b (tV hb)⟩,
end

/-- A version of the **Hahn-Banach theorem**: given disjoint convex sets `s`, `t` where `s` is
closed, and `t` is compact, there is a continuous linear functional which strongly separates them.
-/
theorem geometric_hahn_banach_closed_compact (hs₁ : convex ℝ s) (hs₂ : is_closed s)
  (ht₁ : convex ℝ t) (ht₂ : is_compact t) (disj : disjoint s t) :
  ∃ (f : E →L[ℝ] ℝ) (u v : ℝ), (∀ a ∈ s, f a < u) ∧ u < v ∧ ∀ b ∈ t, v < f b :=
let ⟨f, s, t, hs, st, ht⟩ := geometric_hahn_banach_compact_closed ht₁ ht₂ hs₁ hs₂ disj.symm in
⟨-f, -t, -s, by simpa using ht, by simpa using st, by simpa using hs⟩

theorem geometric_hahn_banach_point_closed (ht₁ : convex ℝ t) (ht₂ : is_closed t) (disj : x ∉ t) :
  ∃ (f : E →L[ℝ] ℝ) (u : ℝ), f x < u ∧ ∀ b ∈ t, u < f b :=
let ⟨f, u, v, ha, hst, hb⟩ := geometric_hahn_banach_compact_closed (convex_singleton x)
  is_compact_singleton ht₁ ht₂ (disjoint_singleton_left.2 disj)
  in ⟨f, v, hst.trans' $ ha x $ mem_singleton _, hb⟩

theorem geometric_hahn_banach_closed_point (hs₁ : convex ℝ s) (hs₂ : is_closed s) (disj : x ∉ s) :
  ∃ (f : E →L[ℝ] ℝ) (u : ℝ), (∀ a ∈ s, f a < u) ∧ u < f x :=
let ⟨f, s, t, ha, hst, hb⟩ := geometric_hahn_banach_closed_compact hs₁ hs₂ (convex_singleton x)
  is_compact_singleton (disjoint_singleton_right.2 disj)
  in ⟨f, s, ha, hst.trans $ hb x $ mem_singleton _⟩

/-- Special case of `normed_space.eq_iff_forall_dual_eq`. -/
theorem geometric_hahn_banach_point_point (hxy : x ≠ y) : ∃ (f : E →L[ℝ] ℝ), f x < f y :=
begin
  obtain ⟨f, s, t, hs, st, ht⟩ :=
    geometric_hahn_banach_compact_closed (convex_singleton x) is_compact_singleton
      (convex_singleton y) is_closed_singleton (disjoint_singleton.2 hxy),
  exact ⟨f, by linarith [hs x rfl, ht y rfl]⟩,
end

/-- A closed convex set is the intersection of the halfspaces containing it. -/
lemma Inter_halfspaces_eq (hs₁ : convex ℝ s) (hs₂ : is_closed s) :
  (⋂ (l : E →L[ℝ] ℝ), {x | ∃ y ∈ s, l x ≤ l y}) = s :=
begin
  rw set.Inter_set_of,
  refine set.subset.antisymm (λ x hx, _) (λ x hx l, ⟨x, hx, le_rfl⟩),
  by_contra,
  obtain ⟨l, s, hlA, hl⟩ := geometric_hahn_banach_closed_point hs₁ hs₂ h,
  obtain ⟨y, hy, hxy⟩ := hx l,
  exact ((hxy.trans_lt (hlA y hy)).trans hl).not_le le_rfl,
end


import topology.algebra.infinite_sum
import topology.instances.nnreal

open_locale big_operators nnreal

lemma tsum_abs_eq_coe_tsum_nnabs {α : Type*} (f : α → ℝ) :
  (∑' i, abs (f i)) = ∑' i, real.nnabs (f i) :=
by simp only [real.coe_nnabs]

open nnreal finset

lemma has_sum_nat_add_iff'' {f : ℕ → ℝ≥0} (k : ℕ) {a : ℝ≥0} :
  has_sum (λ n, f (n + k)) a ↔ has_sum f (a + ∑ i in range k, f i) :=
begin
  unfold has_sum,
  rw ← tendsto_coe,
  rw ← tendsto_coe,
  simp only [coe_sum],
  convert _root_.has_sum_nat_add_iff k,
  refl,
  classical,
  rw nnreal.coe_add,
  simp only [coe_sum],
  apply_instance,
end
.
lemma sum_add_tsum_nat_add' {f : ℕ → ℝ≥0} (k : ℕ) (h : summable f) :
  (∑ i in range k, f i) + (∑' i, f (i + k)) = (∑' i, f i) :=
by simpa [add_comm] using
  ((has_sum_nat_add_iff'' k).1 ((nnreal.summable_nat_add_iff k).2 h).has_sum).unique h.has_sum

lemma tsum_eq_zero {ι} (f : ι → ℝ≥0) (h : ∀ b, f b = 0) : (∑' b, f b) = 0 :=
by simp only [h, tsum_zero]
#lint- only unused_arguments def_lemma doc_blame


/-
Copyright (c) 2020 Jujian Zhang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jujian Zhang, Johan Commelin
-/

import topology.category.Top
import ring_theory.graded_algebra.homogeneous_ideal

/-!
# Projective spectrum of a graded ring

The projective spectrum of a graded commutative ring is the subtype of all homogenous ideals that
are prime and do not contain the irrelevant ideal.
It is naturally endowed with a topology: the Zariski topology.

## Notation
- `R` is a commutative semiring;
- `A` is a commutative ring and an `R`-algebra;
- `𝒜 : ℕ → submodule R A` is the grading of `A`;

## Main definitions

* `projective_spectrum 𝒜`: The projective spectrum of a graded ring `A`, or equivalently, the set of
  all homogeneous ideals of `A` that is both prime and relevant i.e. not containing irrelevant
  ideal. Henceforth, we call elements of projective spectrum *relevant homogeneous prime ideals*.
* `projective_spectrum.zero_locus 𝒜 s`: The zero locus of a subset `s` of `A`
  is the subset of `projective_spectrum 𝒜` consisting of all relevant homogeneous prime ideals that
  contain `s`.
* `projective_spectrum.vanishing_ideal t`: The vanishing ideal of a subset `t` of
  `projective_spectrum 𝒜` is the intersection of points in `t` (viewed as relevant homogeneous prime
  ideals).
* `projective_spectrum.Top`: the topological space of `projective_spectrum 𝒜` endowed with the
  Zariski topology

-/

noncomputable theory
open_locale direct_sum big_operators pointwise
open direct_sum set_like Top topological_space category_theory opposite

variables {R A: Type*}
variables [comm_semiring R] [comm_ring A] [algebra R A]
variables (𝒜 : ℕ → submodule R A) [graded_algebra 𝒜]

/--
The projective spectrum of a graded commutative ring is the subtype of all homogenous ideals that
are prime and do not contain the irrelevant ideal.
-/
@[nolint has_inhabited_instance]
def projective_spectrum :=
{I : homogeneous_ideal 𝒜 // I.to_ideal.is_prime ∧ ¬(homogeneous_ideal.irrelevant 𝒜 ≤ I)}

namespace projective_spectrum

variable {𝒜}
/-- A method to view a point in the projective spectrum of a graded ring
as a homogeneous ideal of that ring. -/
abbreviation as_homogeneous_ideal (x : projective_spectrum 𝒜) : homogeneous_ideal 𝒜 := x.1

lemma as_homogeneous_ideal_def (x : projective_spectrum 𝒜) :
  x.as_homogeneous_ideal = x.1 := rfl

instance is_prime (x : projective_spectrum 𝒜) :
  x.as_homogeneous_ideal.to_ideal.is_prime := x.2.1

@[ext] lemma ext {x y : projective_spectrum 𝒜} :
  x = y ↔ x.as_homogeneous_ideal = y.as_homogeneous_ideal :=
subtype.ext_iff_val

variable (𝒜)
/-- The zero locus of a set `s` of elements of a commutative ring `A`
is the set of all relevant homogeneous prime ideals of the ring that contain the set `s`.

An element `f` of `A` can be thought of as a dependent function on the projective spectrum of `𝒜`.
At a point `x` (a homogeneous prime ideal)
the function (i.e., element) `f` takes values in the quotient ring `A` modulo the prime ideal `x`.
In this manner, `zero_locus s` is exactly the subset of `projective_spectrum 𝒜`
where all "functions" in `s` vanish simultaneously. -/
def zero_locus (s : set A) : set (projective_spectrum 𝒜) :=
{x | s ⊆ x.as_homogeneous_ideal}

@[simp] lemma mem_zero_locus (x : projective_spectrum 𝒜) (s : set A) :
  x ∈ zero_locus 𝒜 s ↔ s ⊆ x.as_homogeneous_ideal := iff.rfl

@[simp] lemma zero_locus_span (s : set A) :
  zero_locus 𝒜 (ideal.span s) = zero_locus 𝒜 s :=
by { ext x, exact (submodule.gi _ _).gc s x.as_homogeneous_ideal.to_ideal }

variable {𝒜}
/-- The vanishing ideal of a set `t` of points
of the prime spectrum of a commutative ring `R`
is the intersection of all the prime ideals in the set `t`.

An element `f` of `A` can be thought of as a dependent function on the projective spectrum of `𝒜`.
At a point `x` (a homogeneous prime ideal)
the function (i.e., element) `f` takes values in the quotient ring `A` modulo the prime ideal `x`.
In this manner, `vanishing_ideal t` is exactly the ideal of `A`
consisting of all "functions" that vanish on all of `t`. -/
def vanishing_ideal (t : set (projective_spectrum 𝒜)) : homogeneous_ideal 𝒜 :=
⨅ (x : projective_spectrum 𝒜) (h : x ∈ t), x.as_homogeneous_ideal

lemma coe_vanishing_ideal (t : set (projective_spectrum 𝒜)) :
  (vanishing_ideal t : set A) =
  {f | ∀ x : projective_spectrum 𝒜, x ∈ t → f ∈ x.as_homogeneous_ideal} :=
begin
  ext f,
  rw [vanishing_ideal, set_like.mem_coe, ← homogeneous_ideal.mem_iff,
    homogeneous_ideal.to_ideal_infi, submodule.mem_infi],
  apply forall_congr (λ x, _),
  rw [homogeneous_ideal.to_ideal_infi, submodule.mem_infi, homogeneous_ideal.mem_iff],
end

lemma mem_vanishing_ideal (t : set (projective_spectrum 𝒜)) (f : A) :
  f ∈ vanishing_ideal t ↔
  ∀ x : projective_spectrum 𝒜, x ∈ t → f ∈ x.as_homogeneous_ideal :=
by rw [← set_like.mem_coe, coe_vanishing_ideal, set.mem_set_of_eq]

@[simp] lemma vanishing_ideal_singleton (x : projective_spectrum 𝒜) :
  vanishing_ideal ({x} : set (projective_spectrum 𝒜)) = x.as_homogeneous_ideal :=
by simp [vanishing_ideal]

lemma subset_zero_locus_iff_le_vanishing_ideal (t : set (projective_spectrum 𝒜))
  (I : ideal A) :
  t ⊆ zero_locus 𝒜 I ↔ I ≤ (vanishing_ideal t).to_ideal :=
⟨λ h f k, (mem_vanishing_ideal _ _).mpr (λ x j, (mem_zero_locus _ _ _).mpr (h j) k), λ h,
  λ x j, (mem_zero_locus _ _ _).mpr (le_trans h (λ f h, ((mem_vanishing_ideal _ _).mp h) x j))⟩

variable (𝒜)
/-- `zero_locus` and `vanishing_ideal` form a galois connection. -/
lemma gc_ideal : @galois_connection
  (ideal A) (set (projective_spectrum 𝒜))ᵒᵈ _ _
  (λ I, zero_locus 𝒜 I) (λ t, (vanishing_ideal t).to_ideal) :=
λ I t, subset_zero_locus_iff_le_vanishing_ideal t I

/-- `zero_locus` and `vanishing_ideal` form a galois connection. -/
lemma gc_set : @galois_connection
  (set A) (set (projective_spectrum 𝒜))ᵒᵈ _ _
  (λ s, zero_locus 𝒜 s) (λ t, vanishing_ideal t) :=
have ideal_gc : galois_connection (ideal.span) coe := (submodule.gi A _).gc,
by simpa [zero_locus_span, function.comp] using galois_connection.compose ideal_gc (gc_ideal 𝒜)

lemma gc_homogeneous_ideal : @galois_connection
  (homogeneous_ideal 𝒜) (set (projective_spectrum 𝒜))ᵒᵈ _ _
  (λ I, zero_locus 𝒜 I) (λ t, (vanishing_ideal t)) :=
λ I t, by simpa [show I.to_ideal ≤ (vanishing_ideal t).to_ideal ↔ I ≤ (vanishing_ideal t),
  from iff.rfl] using subset_zero_locus_iff_le_vanishing_ideal t I.to_ideal

lemma subset_zero_locus_iff_subset_vanishing_ideal (t : set (projective_spectrum 𝒜))
  (s : set A) :
  t ⊆ zero_locus 𝒜 s ↔ s ⊆ vanishing_ideal t :=
(gc_set _) s t

lemma subset_vanishing_ideal_zero_locus (s : set A) :
  s ⊆ vanishing_ideal (zero_locus 𝒜 s) :=
(gc_set _).le_u_l s

lemma ideal_le_vanishing_ideal_zero_locus (I : ideal A) :
  I ≤ (vanishing_ideal (zero_locus 𝒜 I)).to_ideal :=
(gc_ideal _).le_u_l I

lemma homogeneous_ideal_le_vanishing_ideal_zero_locus (I : homogeneous_ideal 𝒜) :
  I ≤ vanishing_ideal (zero_locus 𝒜 I) :=
(gc_homogeneous_ideal _).le_u_l I

lemma subset_zero_locus_vanishing_ideal (t : set (projective_spectrum 𝒜)) :
  t ⊆ zero_locus 𝒜 (vanishing_ideal t) :=
(gc_ideal _).l_u_le t

lemma zero_locus_anti_mono {s t : set A} (h : s ⊆ t) : zero_locus 𝒜 t ⊆ zero_locus 𝒜 s :=
(gc_set _).monotone_l h

lemma zero_locus_anti_mono_ideal {s t : ideal A} (h : s ≤ t) :
  zero_locus 𝒜 (t : set A) ⊆ zero_locus 𝒜 (s : set A) :=
(gc_ideal _).monotone_l h

lemma zero_locus_anti_mono_homogeneous_ideal {s t : homogeneous_ideal 𝒜} (h : s ≤ t) :
  zero_locus 𝒜 (t : set A) ⊆ zero_locus 𝒜 (s : set A) :=
(gc_homogeneous_ideal _).monotone_l h

lemma vanishing_ideal_anti_mono {s t : set (projective_spectrum 𝒜)} (h : s ⊆ t) :
  vanishing_ideal t ≤ vanishing_ideal s :=
(gc_ideal _).monotone_u h

lemma zero_locus_bot :
  zero_locus 𝒜 ((⊥ : ideal A) : set A) = set.univ :=
(gc_ideal 𝒜).l_bot

@[simp] lemma zero_locus_singleton_zero :
  zero_locus 𝒜 ({0} : set A) = set.univ :=
zero_locus_bot _

@[simp] lemma zero_locus_empty :
  zero_locus 𝒜 (∅ : set A) = set.univ :=
(gc_set 𝒜).l_bot

@[simp] lemma vanishing_ideal_univ :
  vanishing_ideal (∅ : set (projective_spectrum 𝒜)) = ⊤ :=
by simpa using (gc_ideal _).u_top

lemma zero_locus_empty_of_one_mem {s : set A} (h : (1:A) ∈ s) :
  zero_locus 𝒜 s = ∅ :=
set.eq_empty_iff_forall_not_mem.mpr $ λ x hx,
  (infer_instance : x.as_homogeneous_ideal.to_ideal.is_prime).ne_top $
  x.as_homogeneous_ideal.to_ideal.eq_top_iff_one.mpr $ hx h

@[simp] lemma zero_locus_singleton_one :
  zero_locus 𝒜 ({1} : set A) = ∅ :=
zero_locus_empty_of_one_mem 𝒜 (set.mem_singleton (1 : A))

@[simp] lemma zero_locus_univ :
  zero_locus 𝒜 (set.univ : set A) = ∅ :=
zero_locus_empty_of_one_mem _ (set.mem_univ 1)

lemma zero_locus_sup_ideal (I J : ideal A) :
  zero_locus 𝒜 ((I ⊔ J : ideal A) : set A) = zero_locus _ I ∩ zero_locus _ J :=
(gc_ideal 𝒜).l_sup

lemma zero_locus_sup_homogeneous_ideal (I J : homogeneous_ideal 𝒜) :
  zero_locus 𝒜 ((I ⊔ J : homogeneous_ideal 𝒜) : set A) = zero_locus _ I ∩ zero_locus _ J :=
(gc_homogeneous_ideal 𝒜).l_sup

lemma zero_locus_union (s s' : set A) :
  zero_locus 𝒜 (s ∪ s') = zero_locus _ s ∩ zero_locus _ s' :=
(gc_set 𝒜).l_sup

lemma vanishing_ideal_union (t t' : set (projective_spectrum 𝒜)) :
  vanishing_ideal (t ∪ t') = vanishing_ideal t ⊓ vanishing_ideal t' :=
by ext1; convert (gc_ideal 𝒜).u_inf

lemma zero_locus_supr_ideal {γ : Sort*} (I : γ → ideal A) :
  zero_locus _ ((⨆ i, I i : ideal A) : set A) = (⋂ i, zero_locus 𝒜 (I i)) :=
(gc_ideal 𝒜).l_supr

lemma zero_locus_supr_homogeneous_ideal {γ : Sort*} (I : γ → homogeneous_ideal 𝒜) :
  zero_locus _ ((⨆ i, I i : homogeneous_ideal 𝒜) : set A) = (⋂ i, zero_locus 𝒜 (I i)) :=
(gc_homogeneous_ideal 𝒜).l_supr

lemma zero_locus_Union {γ : Sort*} (s : γ → set A) :
  zero_locus 𝒜 (⋃ i, s i) = (⋂ i, zero_locus 𝒜 (s i)) :=
(gc_set 𝒜).l_supr

lemma zero_locus_bUnion (s : set (set A)) :
  zero_locus 𝒜 (⋃ s' ∈ s, s' : set A) = ⋂ s' ∈ s, zero_locus 𝒜 s' :=
by simp only [zero_locus_Union]

lemma vanishing_ideal_Union {γ : Sort*} (t : γ → set (projective_spectrum 𝒜)) :
  vanishing_ideal (⋃ i, t i) = (⨅ i, vanishing_ideal (t i)) :=
homogeneous_ideal.to_ideal_injective $
by convert (gc_ideal 𝒜).u_infi; exact homogeneous_ideal.to_ideal_infi _

lemma zero_locus_inf (I J : ideal A) :
  zero_locus 𝒜 ((I ⊓ J : ideal A) : set A) = zero_locus 𝒜 I ∪ zero_locus 𝒜 J :=
set.ext $ λ x, by simpa using x.2.1.inf_le

lemma union_zero_locus (s s' : set A) :
  zero_locus 𝒜 s ∪ zero_locus 𝒜 s' = zero_locus 𝒜 ((ideal.span s) ⊓ (ideal.span s'): ideal A) :=
by { rw zero_locus_inf, simp }

lemma zero_locus_mul_ideal (I J : ideal A) :
  zero_locus 𝒜 ((I * J : ideal A) : set A) = zero_locus 𝒜 I ∪ zero_locus 𝒜 J :=
set.ext $ λ x, by simpa using x.2.1.mul_le

lemma zero_locus_mul_homogeneous_ideal (I J : homogeneous_ideal 𝒜) :
  zero_locus 𝒜 ((I * J : homogeneous_ideal 𝒜) : set A) = zero_locus 𝒜 I ∪ zero_locus 𝒜 J :=
set.ext $ λ x, by simpa using x.2.1.mul_le

lemma zero_locus_singleton_mul (f g : A) :
  zero_locus 𝒜 ({f * g} : set A) = zero_locus 𝒜 {f} ∪ zero_locus 𝒜 {g} :=
set.ext $ λ x, by simpa using x.2.1.mul_mem_iff_mem_or_mem

@[simp] lemma zero_locus_singleton_pow (f : A) (n : ℕ) (hn : 0 < n) :
  zero_locus 𝒜 ({f ^ n} : set A) = zero_locus 𝒜 {f} :=
set.ext $ λ x, by simpa using x.2.1.pow_mem_iff_mem n hn

lemma sup_vanishing_ideal_le (t t' : set (projective_spectrum 𝒜)) :
  vanishing_ideal t ⊔ vanishing_ideal t' ≤ vanishing_ideal (t ∩ t') :=
begin
  intros r,
  rw [← homogeneous_ideal.mem_iff, homogeneous_ideal.to_ideal_sup, mem_vanishing_ideal,
    submodule.mem_sup],
  rintro ⟨f, hf, g, hg, rfl⟩ x ⟨hxt, hxt'⟩,
  erw mem_vanishing_ideal at hf hg,
  apply submodule.add_mem; solve_by_elim
end

lemma mem_compl_zero_locus_iff_not_mem {f : A} {I : projective_spectrum 𝒜} :
  I ∈ (zero_locus 𝒜 {f} : set (projective_spectrum 𝒜))ᶜ ↔ f ∉ I.as_homogeneous_ideal :=
by rw [set.mem_compl_eq, mem_zero_locus, set.singleton_subset_iff]; refl

/-- The Zariski topology on the prime spectrum of a commutative ring
is defined via the closed sets of the topology:
they are exactly those sets that are the zero locus of a subset of the ring. -/
instance zariski_topology : topological_space (projective_spectrum 𝒜) :=
topological_space.of_closed (set.range (projective_spectrum.zero_locus 𝒜))
  (⟨set.univ, by simp⟩)
  begin
    intros Zs h,
    rw set.sInter_eq_Inter,
    let f : Zs → set _ := λ i, classical.some (h i.2),
    have hf : ∀ i : Zs, ↑i = zero_locus 𝒜 (f i) := λ i, (classical.some_spec (h i.2)).symm,
    simp only [hf],
    exact ⟨_, zero_locus_Union 𝒜 _⟩
  end
  (by { rintros _ ⟨s, rfl⟩ _ ⟨t, rfl⟩, exact ⟨_, (union_zero_locus 𝒜 s t).symm⟩ })

/--
The underlying topology of `Proj` is the projective spectrum of graded ring `A`.
-/
def Top : Top := Top.of (projective_spectrum 𝒜)

lemma is_open_iff (U : set (projective_spectrum 𝒜)) :
  is_open U ↔ ∃ s, Uᶜ = zero_locus 𝒜 s :=
by simp only [@eq_comm _ Uᶜ]; refl

lemma is_closed_iff_zero_locus (Z : set (projective_spectrum 𝒜)) :
  is_closed Z ↔ ∃ s, Z = zero_locus 𝒜 s :=
by rw [← is_open_compl_iff, is_open_iff, compl_compl]

lemma is_closed_zero_locus (s : set A) :
  is_closed (zero_locus 𝒜 s) :=
by { rw [is_closed_iff_zero_locus], exact ⟨s, rfl⟩ }

lemma zero_locus_vanishing_ideal_eq_closure (t : set (projective_spectrum 𝒜)) :
  zero_locus 𝒜 (vanishing_ideal t : set A) = closure t :=
begin
  apply set.subset.antisymm,
  { rintro x hx t' ⟨ht', ht⟩,
    obtain ⟨fs, rfl⟩ : ∃ s, t' = zero_locus 𝒜 s,
    by rwa [is_closed_iff_zero_locus] at ht',
    rw [subset_zero_locus_iff_subset_vanishing_ideal] at ht,
    exact set.subset.trans ht hx },
  { rw (is_closed_zero_locus _ _).closure_subset_iff,
    exact subset_zero_locus_vanishing_ideal 𝒜 t }
end

lemma vanishing_ideal_closure (t : set (projective_spectrum 𝒜)) :
  vanishing_ideal (closure t) = vanishing_ideal t :=
begin
  have := (gc_ideal 𝒜).u_l_u_eq_u t,
  dsimp only at this,
  ext1,
  erw zero_locus_vanishing_ideal_eq_closure 𝒜 t at this,
  exact this,
end

section basic_open

/-- `basic_open r` is the open subset containing all prime ideals not containing `r`. -/
def basic_open (r : A) : topological_space.opens (projective_spectrum 𝒜) :=
{ val := { x | r ∉ x.as_homogeneous_ideal },
  property := ⟨{r}, set.ext $ λ x, set.singleton_subset_iff.trans $ not_not.symm⟩ }

@[simp] lemma mem_basic_open (f : A) (x : projective_spectrum 𝒜) :
  x ∈ basic_open 𝒜 f ↔ f ∉ x.as_homogeneous_ideal := iff.rfl

lemma mem_coe_basic_open (f : A) (x : projective_spectrum 𝒜) :
  x ∈ (↑(basic_open 𝒜 f): set (projective_spectrum 𝒜)) ↔ f ∉ x.as_homogeneous_ideal := iff.rfl

lemma is_open_basic_open {a : A} : is_open ((basic_open 𝒜 a) :
  set (projective_spectrum 𝒜)) :=
(basic_open 𝒜 a).property

@[simp] lemma basic_open_eq_zero_locus_compl (r : A) :
  (basic_open 𝒜 r : set (projective_spectrum 𝒜)) = (zero_locus 𝒜 {r})ᶜ :=
set.ext $ λ x, by simpa only [set.mem_compl_eq, mem_zero_locus, set.singleton_subset_iff]

@[simp] lemma basic_open_one : basic_open 𝒜 (1 : A) = ⊤ :=
topological_space.opens.ext $ by simp

@[simp]

lemma basic_open_mul (f g : A) : basic_open 𝒜 (f * g) = basic_open 𝒜 f ⊓ basic_open 𝒜 g :=
topological_space.opens.ext $ by {simp [zero_locus_singleton_mul]}

lemma basic_open_mul_le_left (f g : A) : basic_open 𝒜 (f * g) ≤ basic_open 𝒜 f :=
by { rw basic_open_mul 𝒜 f g, exact inf_le_left }

lemma basic_open_mul_le_right (f g : A) : basic_open 𝒜 (f * g) ≤ basic_open 𝒜 g :=
by { rw basic_open_mul 𝒜 f g, exact inf_le_right }

@[simp] lemma basic_open_pow (f : A) (n : ℕ) (hn : 0 < n) :
  basic_open 𝒜 (f ^ n) = basic_open 𝒜 f :=
topological_space.opens.ext $ by simpa using zero_locus_singleton_pow 𝒜 f n hn

lemma basic_open_eq_union_of_projection (f : A) :
  basic_open 𝒜 f = ⨆ (i : ℕ), basic_open 𝒜 (graded_algebra.proj 𝒜 i f) :=
topological_space.opens.ext $ set.ext $ λ z, begin
  erw [mem_coe_basic_open, topological_space.opens.mem_Sup],
  split; intros hz,
  { rcases show ∃ i, graded_algebra.proj 𝒜 i f ∉ z.as_homogeneous_ideal, begin
      contrapose! hz with H,
      classical,
      rw ←direct_sum.sum_support_decompose 𝒜 f,
      apply ideal.sum_mem _ (λ i hi, H i)
    end with ⟨i, hi⟩,
    exact ⟨basic_open 𝒜 (graded_algebra.proj 𝒜 i f), ⟨i, rfl⟩, by rwa mem_basic_open⟩ },
  { obtain ⟨_, ⟨i, rfl⟩, hz⟩ := hz,
    exact λ rid, hz (z.1.2 i rid) },
end

lemma is_topological_basis_basic_opens : topological_space.is_topological_basis
  (set.range (λ (r : A), (basic_open 𝒜 r : set (projective_spectrum 𝒜)))) :=
begin
  apply topological_space.is_topological_basis_of_open_of_nhds,
  { rintros _ ⟨r, rfl⟩,
    exact is_open_basic_open 𝒜 },
  { rintros p U hp ⟨s, hs⟩,
    rw [← compl_compl U, set.mem_compl_eq, ← hs, mem_zero_locus, set.not_subset] at hp,
    obtain ⟨f, hfs, hfp⟩ := hp,
    refine ⟨basic_open 𝒜 f, ⟨f, rfl⟩, hfp, _⟩,
    rw [← set.compl_subset_compl, ← hs, basic_open_eq_zero_locus_compl, compl_compl],
    exact zero_locus_anti_mono 𝒜 (set.singleton_subset_iff.mpr hfs) }
end

end basic_open

section order

/-!
## The specialization order

We endow `projective_spectrum 𝒜` with a partial order,
where `x ≤ y` if and only if `y ∈ closure {x}`.
-/

instance : partial_order (projective_spectrum 𝒜) :=
subtype.partial_order _

@[simp] lemma as_ideal_le_as_ideal (x y : projective_spectrum 𝒜) :
  x.as_homogeneous_ideal ≤ y.as_homogeneous_ideal ↔ x ≤ y :=
subtype.coe_le_coe

@[simp] lemma as_ideal_lt_as_ideal (x y : projective_spectrum 𝒜) :
  x.as_homogeneous_ideal < y.as_homogeneous_ideal ↔ x < y :=
subtype.coe_lt_coe

lemma le_iff_mem_closure (x y : projective_spectrum 𝒜) :
  x ≤ y ↔ y ∈ closure ({x} : set (projective_spectrum 𝒜)) :=
begin
  rw [← as_ideal_le_as_ideal, ← zero_locus_vanishing_ideal_eq_closure,
    mem_zero_locus, vanishing_ideal_singleton],
  simp only [coe_subset_coe, subtype.coe_le_coe, coe_coe],
end

end order

end projective_spectrum


import .admits

set_option pp.parens true

open formula

inductive is_prop_axiom : formula → Prop

-- ⊢ ⊤
| prop_true_ :
  is_prop_axiom true_

-- ⊢ P → (Q → P)
| prop_1_
  (P Q : formula) :
  is_prop_axiom (P.imp_ (Q.imp_ P))

-- ⊢ (P → (Q → R)) → ((P → Q) → (P → R))
| prop_2_
  (P Q R : formula) :
  is_prop_axiom ((P.imp_ (Q.imp_ R)).imp_ ((P.imp_ Q).imp_ (P.imp_ R)))

-- ⊢ (¬ P → ¬ Q) → (Q → P)
| prop_3_
  (P Q : formula) :
  is_prop_axiom (((not_ P).imp_ (not_ Q)).imp_ (Q.imp_ P))

inductive is_prop_deduct (Δ : set formula) : formula → Prop

| axiom_
  (P : formula) :
  is_prop_axiom P →
  is_prop_deduct P

| assume_
  (P : formula) :
  P ∈ Δ →
  is_prop_deduct P

| mp_
  (P Q : formula) :
  is_prop_deduct (P.imp_ Q) →
  is_prop_deduct P →
  is_prop_deduct Q

def is_prop_proof (P : formula) : Prop := is_prop_deduct ∅ P

inductive is_axiom : formula → Prop

-- ⊢ ⊤
| prop_true_ :
  is_axiom true_

-- ⊢ P → (Q → P)
| prop_1_
  (P Q : formula) :
  is_axiom (P.imp_ (Q.imp_ P))

-- ⊢ (P → (Q → R)) → ((P → Q) → (P → R))
| prop_2_
  (P Q R : formula) :
  is_axiom ((P.imp_ (Q.imp_ R)).imp_ ((P.imp_ Q).imp_ (P.imp_ R)))

-- ⊢ (¬ P → ¬ Q) → (Q → P)
| prop_3_
  (P Q : formula) :
  is_axiom (((not_ P).imp_ (not_ Q)).imp_ (Q.imp_ P))

-- ⊢ (∀ v (P → Q)) → ((∀ v P) → (∀ v Q))
| pred_1_
  (v : variable_) (P Q : formula) :
  is_axiom ((forall_ v (P.imp_ Q)).imp_ ((forall_ v P).imp_ (forall_ v Q)))

-- ⊢ (∀ v P) → P(t/v)  provided P admits t for v
| pred_2_
  (v t : variable_) (P P' : formula) :
  fast_admits v t P →
  fast_replace_free v t P = P' →
  is_axiom ((forall_ v P).imp_ P')

-- ⊢ P → (∀ v P)  provided v is not free in P
| pred_3_
  (v : variable_) (P : formula) :
  ¬ is_free_in v P →
  is_axiom (P.imp_ (forall_ v P))

-- ⊢ ∀ v (v = v)
| eq_1_
  (v : variable_) :
  is_axiom (forall_ v (eq_ v v))

/-
⊢ ∀ x_0 ... ∀ x_n ∀ y_0 ... y_n ((x_0 = y_0) ∧ ... ∧ (x_n = y_n) ∧ ⊤) →
    ((pred_ name [x_0 ... x_n] ↔ pred_ name [y_0 ... y_n]))
-/
| eq_2_pred_
  (name : pred_name_) (n : ℕ) (xs ys : fin n → variable_) :
  is_axiom (Forall_ (list.of_fn xs) (Forall_ (list.of_fn ys)
    ((And_ (list.of_fn (fun (i : fin n), eq_ (xs i) (ys i)))).imp_
      ((pred_ name (list.of_fn xs)).iff_ (pred_ name (list.of_fn ys))))))

| eq_2_eq_
  (x_0 x_1 y_0 y_1 : variable_) :
  is_axiom (forall_ x_0 (forall_ x_1 (forall_ y_0 (forall_ y_1 ((and_ (eq_ x_0 y_0) (eq_ x_1 y_1)).imp_
    ((eq_ x_0 x_1).iff_ (eq_ y_0 y_1)))))))

-- ⊢ P ⇒ ⊢ ∀ v P
| gen_
  (v : variable_) (P : formula) :
  is_axiom P →
  is_axiom (forall_ v P)

inductive is_deduct (Δ : set formula) : formula → Prop

| axiom_
  (P : formula) :
  is_axiom P →
  is_deduct P

| assume_
  (P : formula) :
  P ∈ Δ →
  is_deduct P

| mp_
  (P Q : formula) :
  is_deduct (P.imp_ Q) →
  is_deduct P →
  is_deduct Q

def is_proof (P : formula) : Prop := is_deduct ∅ P

inductive is_proof_alt : formula → Prop

-- ⊢ ⊤
| prop_true_ :
  is_proof_alt true_

-- ⊢ P → (Q → P)
| prop_1_
  (P Q : formula) :
  is_proof_alt (P.imp_ (Q.imp_ P))

-- ⊢ (P → (Q → R)) → ((P → Q) → (P → R))
| prop_2_
  (P Q R : formula) :
  is_proof_alt ((P.imp_ (Q.imp_ R)).imp_ ((P.imp_ Q).imp_ (P.imp_ R)))

-- ⊢ (¬ P → ¬ Q) → (Q → P)
| prop_3_
  (P Q : formula) :
  is_proof_alt (((not_ P).imp_ (not_ Q)).imp_ (Q.imp_ P))

-- ⊢ (∀ v (P → Q)) → ((∀ v P) → (∀ v Q))
| pred_1_
  (v : variable_) (P Q : formula) :
  is_proof_alt ((forall_ v (P.imp_ Q)).imp_ ((forall_ v P).imp_ (forall_ v Q)))

-- ⊢ (∀ v P) → P(t/v)  provided P admits t for v
| pred_2_
  (v t : variable_) (P P' : formula) :
  fast_admits v t P →
  fast_replace_free v t P = P' →
  is_proof_alt ((forall_ v P).imp_ P')

-- ⊢ P → (∀ v P)  provided v is not free in P
| pred_3_
  (v : variable_) (P : formula) :
  ¬ is_free_in v P →
  is_proof_alt (P.imp_ (forall_ v P))

-- ⊢ ∀ v (v = v)
| eq_1_
  (v : variable_) :
  is_proof_alt (forall_ v (eq_ v v))

/-
⊢ ∀ x_0 ... ∀ x_n ∀ y_0 ... y_n ((x_0 = y_0) ∧ ... ∧ (x_n = y_n) ∧ ⊤) →
    ((pred_ name [x_0 ... x_n] ↔ pred_ name [y_0 ... y_n]))
-/
| eq_2_pred_
  (name : pred_name_) (n : ℕ) (xs ys : fin n → variable_) :
  is_proof_alt (Forall_ (list.of_fn xs) (Forall_ (list.of_fn ys)
    ((And_ (list.of_fn (fun (i : fin n), eq_ (xs i) (ys i)))).imp_
      ((pred_ name (list.of_fn xs)).iff_ (pred_ name (list.of_fn ys))))))

| eq_2_eq_
  (x_0 x_1 y_0 y_1 : variable_) :
  is_proof_alt (forall_ x_0 (forall_ x_1 (forall_ y_0 (forall_ y_1 ((and_ (eq_ x_0 y_0) (eq_ x_1 y_1)).imp_
    ((eq_ x_0 x_1).iff_ (eq_ y_0 y_1)))))))

-- ⊢ P ⇒ ⊢ ∀ v P
| gen_
  (v : variable_) (P : formula) :
  is_proof_alt P →
  is_proof_alt (forall_ v P)

-- ⊢ P → Q ⇒ ⊢ P ⇒ ⊢ Q
| mp_
  (P Q : formula) :
  is_proof_alt (P.imp_ Q) →
  is_proof_alt P →
  is_proof_alt Q

lemma proof_imp_deduct
  (P : formula)
  (h1 : is_proof P) :
  ∀ (Δ : set formula), is_deduct Δ P :=
begin
  unfold is_proof at h1,

  intros Δ,
  induction h1,
  case is_deduct.axiom_ : h1_P h1_1
  {
    apply is_deduct.axiom_,
    exact h1_1,
  },
  case is_deduct.assume_ : h1_P h1_1
  {
    simp only [set.mem_empty_eq] at h1_1,
    contradiction,
  },
  case is_deduct.mp_ : h1_P h1_Q h1_1 h1_2 h1_ih_1 h1_ih_2
  {
    exact is_deduct.mp_ h1_P h1_Q h1_ih_1 h1_ih_2,
  },
end

#lint


import tactic

inductive Bird
| Call : Bird -> Bird -> Bird
open Bird

reserve infix ` ⬝ ` : 99

universes u
class has_call (α : Type u) := (call : α → α → α)
infix ⬝ := has_call.call

instance : has_call Bird := ⟨Call⟩

/-
 Problem 9.1: The significance of the Mockingbird
-/

def composes(a b c: Bird): Prop := ∀ x, c ⬝ x = a ⬝ (b ⬝ x)
def is_mocking(m: Bird): Prop := ∀ x, m ⬝ x = x ⬝ x
def is_fond(a b: Bird): Prop := a ⬝ b = b

theorem fondness

  -- Composition condition
  (C₁: ∀ a b: Bird, ∃ c: Bird, composes a b c)
  -- A mocking bird exists
  (C₂: ∃ m: Bird, is_mocking m)

  : ∀ a: Bird, ∃ b, is_fond a b :=
begin
  intro a,
  cases C₂ with m Hm,
  cases (C₁ a m) with c Hc,
  -- CC:  c c = a (m c)
  have CC := Hc c,
  -- bind x with c
  -- Hmc: m c = c c
  have Hmc := Hm c,
  -- replace c c = a (m c) with
  -- c c = a (c c)
  rw Hmc at CC,
  -- bind x in the goal with c c
  -- ⊢ is_fond a (c ⬝ c)
  existsi c ⬝ c,
  -- ⊢  = c ⬝ c
  rw is_fond,
  -- ⊢ c ⬝ c = a ⬝ (c ⬝ c)
  symmetry,
  exact CC,
end

/-
 Problem 9.2: Egocentric?
-/

def is_egocentric(a: Bird): Prop := is_fond a a

theorem egocentric_exists

  -- Composition condition
  (C₁: ∀ a b: Bird, ∃ c: Bird, composes a b c)
  -- A mocking bird exists
  (C₂: ∃ m: Bird, is_mocking m)

  : ∃ x, is_egocentric x :=
begin
  cases C₂ with m Hm,
  cases (C₁ m m) with c Hc,
  have Hcc := Hc c,
  repeat {rw Hm at Hcc},
  existsi c ⬝ c,
  rw is_egocentric,
  rw is_fond,
  symmetry,
  exact Hcc,
end

/-
 Problem 9.3: Story of the Agrreable Bird
-/

def is_agreeable(a: Bird): Prop := ∀ b: Bird, ∃ x: Bird, a ⬝ x = b ⬝ x

theorem fondness_with_aggreable

  -- Composition condition
  (C₁: ∀ a b: Bird, ∃ c: Bird, composes a b c)
  -- A aggreable bird exists
  (C₂: ∃ a: Bird, is_agreeable a)

  : ∀ a: Bird, ∃ b, is_fond a b :=

begin
  intro a,
  cases C₂ with g Hg,
  rw is_agreeable at Hg,
  cases (C₁ a g) with c Hc,
  have Hgc := Hg c,
  cases Hgc with x₁ Hgcx,
  have Hcx := Hc x₁,
  rw Hgcx at Hcx,

  existsi c ⬝ x₁,
  rw is_fond,
  symmetry,
  exact Hcx,
end

/-
 Problem 9.4: A Question on Aggreable Birds

 This is not an easy one.
-/

theorem aggreableness (a b c: Bird)
  -- Composition condition
  (C₁: ∀ a₁ b₁: Bird, ∃ c₁: Bird, composes a₁ b₁ c₁)
  -- a b c particular instance
  (C₂: composes a b c)

  : is_agreeable c → is_agreeable a

:=
begin
  intro H_c_agr,
  -- Arbitrary bird which 'a' will agree with
  intro d,
  -- This is the main gotcha: introduce variable 'e'
  -- connecting 'd' and 'b'
  cases C₁ d b with e C_e,
  cases H_c_agr e with x_e Cagr_e,
  have Ce' := C_e x_e,
  have Ce'' := C₂ x_e,
  -- We show that 'a' and 'd' agree on bird 'b x_e'
  existsi b ⬝ x_e,
  rw← Ce',
  rw← Ce'',
  exact Cagr_e,
end

/-
 Problem 9.5: An exercise in composition
-/
theorem composition3 (a b c: Bird)

  -- Composition condition
  (C₁: ∀ a b: Bird, ∃ c: Bird, composes a b c)

  : ∃ d: Bird, ∀ x, d ⬝ x = a ⬝ (b ⬝ (c ⬝ x))
:=
begin
  cases C₁ b c with e C_e,
  rw composes at C_e,
  cases C₁ a e with d C_d,
  rw composes at C_d,
  existsi d,
  intro x',
  rw← C_e x',
  exact C_d x',
end

/-
 Problem 9.6: Compatible birds
-/
def is_compatible(a b: Bird): Prop := ∃ x y: Bird, a ⬝ y = x ∧ b ⬝ x = y

theorem compatible (a b: Bird)

  -- Composition condition
  (C₁: ∀ a b: Bird, ∃ c: Bird, composes a b c)
  -- A mocking bird exists
  (C₂: ∃ m: Bird, is_mocking m)

  : is_compatible a b
:=
begin
  cases C₂ with m C_m,
  -- Use solution to Problem 9.5
  cases composition3 a b m C₁ with d H,
  have H_d := H d,
  rw is_mocking at C_m,
  rw C_m at H_d,
  rw is_compatible,
  existsi d ⬝ d, -- x
  existsi b ⬝ (d ⬝ d), -- y
  split,

  -- Goal 1: a y = x
  symmetry,
  exact H_d,

  -- Goal 2: b x = y
  reflexivity,
end

/-
 Problem 9.7: Happy Birds
-/

def is_happy(a: Bird): Prop := is_compatible a a

def is_normal(a: Bird): Prop := ∃ x: Bird, is_fond a x

theorem normal_is_happy (a: Bird)
  (C₁: is_normal a)
  : is_happy a
:=
begin
  cases C₁ with x' C',
  rw is_happy,
  rw is_compatible,
  existsi x',
  existsi x',
  split,
  repeat {exact C'},
end

/-
 Problem 9.8: Normal Birds
-/

theorem happy_may_be_normal (h: Bird)
  (C₁: ∀ a b: Bird, ∃ c: Bird, composes a b c)
  (C₂: is_happy h)

  : ∃ x: Bird, is_normal x
:=
begin
  -- In human terms: if h is a happy bird,
  -- we can show that the bird c that composes
  -- h and h is normal
  cases C₂ with x' C₂,
  cases C₂ with y' C₂,
  have C₁hh := C₁ h h,
  cases C₁hh with c C₁hh,
  rw composes at C₁hh,
  have C₁hh' := C₁hh x',
  cases C₂ with C₂x C₂y,
  rw C₂y at C₁hh',
  rw C₂x at C₁hh',
  existsi c,
  rw is_normal,
  existsi x',
  exact C₁hh',
end

/-
 Problem 9.9: Hopelessly Egocentric
-/

def is_fixated(a b: Bird): Prop := ∀ x: Bird, a ⬝ x = b

def is_hopelessly_egocentric(a: Bird): Prop := is_fixated a a

def is_kestrel(k: Bird): Prop := ∀ x y: Bird, (k ⬝ x) ⬝ y = x

theorem hopelessly_egocentric
  (C₁: ∀ a b: Bird, ∃ c: Bird, composes a b c)
  (C₂: ∃ m, is_mocking m)
  (C₃: ∃ k, is_kestrel k)

  : ∃ x: Bird, is_hopelessly_egocentric x
:=
begin
  have T₁ := fondness C₁ C₂,
  cases C₃ with k C₃,
  have T₁ := T₁ k,
  cases T₁ with x' T₁',
  rw is_fond at T₁',
  rw is_kestrel at C₃,
  have C₃' := C₃ x',
  rw T₁' at C₃',
  existsi x',
  rw is_hopelessly_egocentric,
  rw is_fixated,
  exact C₃',
end

/-
 Problem 9.10: Fixation
-/
theorem fixation (a b: Bird)
  (C₁: is_fixated a b)
  : is_fond a b
:=
begin
  rw is_fixated at C₁,
  have C₁b := C₁ b,
  exact C₁b,
end

/-
 Problem 9.11: A Fact About Kestrels
-/
theorem hopelessly_egocentric_kestrel (k: Bird)
  (C₁: is_kestrel k)
  (C₂: is_egocentric k)
  : is_hopelessly_egocentric k
:=
begin
  rw is_kestrel at C₁,
  have C₁k := C₁ k,
  rw is_egocentric at C₂,
  rw is_fond at C₂,
  rw C₂ at C₁k,
  exact C₁k,
end

/-
 Problem 9.12: Another Fact About Kestrels
-/
theorem fond_kestrel (k a: Bird)
  (C₁: is_kestrel k)
  (C₂: is_egocentric (k ⬝ a))
  : is_fond k a
:=
begin
  rw is_kestrel at C₁,
  have C₁a := C₁ a (k ⬝ a),
  rw is_egocentric at C₂,
  rw is_fond at C₂,
  rw C₂ at C₁a,
  exact C₁a,
end

/-
 Problem 9.13: A Simple Exercise
-/
theorem simple_exercise (a: Bird)
  (C₁: is_hopelessly_egocentric a)
  : ∀ x y, a ⬝ x = a ⬝ y
:=
begin
  rw is_hopelessly_egocentric at C₁,
  rw is_fixated at C₁,
  intro x',
  intro y',
  have C₁x := C₁ x',
  have C₁y := C₁ y',
  rw C₁x,
  rw C₁y,
end

/-
 Problem 9.14: Another Exercise
-/
theorem another_exercise (a: Bird)
  (C₁: is_hopelessly_egocentric a)
  : ∀ x y, (a ⬝ x) ⬝ y = a
:=
begin
  rw is_hopelessly_egocentric at C₁,
  rw is_fixated at C₁,
  intro x',
  intro y',
  have C₁x := C₁ x',
  have C₁y := C₁ y',
  rw C₁x,
  rw C₁y,
end -- exact same proof as in simple_exercise!

/-
 Problem 9.15: Hopeless Egocentricity Is Contagious!
-/
theorem hopeless_egocentricity_is_contagious (a: Bird)
  (C₁: is_hopelessly_egocentric a)
  : ∀ x, is_hopelessly_egocentric (a ⬝ x)
  :=
begin
  intro x',
  rw C₁ x',
  exact C₁,
end

/-
 Problem 9.16: Another Fact About Kestrels
-/
theorem kestrel_left_cancellation (k a b: Bird)
  (C₁: is_kestrel k)
  (C₂: k ⬝ a = k ⬝ b)
  : a = b
:=
begin
  have C₁bb := C₁ b b,
  rw← C₂ at C₁bb,
  have C₁ab := C₁ a b,
  rw← C₁bb,
  rw C₁ab,
end

/-
 Problem 9.17: A Fact About Fixation
-/
theorem uniqueness_fixation (a b c: Bird)
  (C₁: is_fixated a b)
  (C₂: is_fixated a c)
  : b = c
:=
begin
  have C₁b := C₁ b,
  have C₂b := C₂ b,
  rw← C₁b,
  rw C₂b,
end

/-
 Problem 9.18: A Fact About Fixation
-/
theorem fond_kestrel_2 (k a: Bird)
  (C₁: is_kestrel k)
  (C₂: is_fond k (k ⬝ a))
  : is_fond k a
:=
begin
  rw is_kestrel at C₁,
  have C₁ka := C₁ (k ⬝ a) a,
  rw is_fond at C₂,
  rw C₂ at C₁ka,
  have C₁a := C₁ a a,
  rw C₁a at C₁ka,
  rw is_fond,
  symmetry,
  exact C₁ka,
end

/-
 Problem 9.19: A Riddle
-/
theorem egocentric_kestrel (k: Bird)
  (C₁: is_kestrel k)
  (C₂: is_egocentric k)
  : ∀ x: Bird, x = k
:=
begin
  have C₁k := C₁ k,
  rw is_egocentric at C₂,
  rw is_fond at C₂,
  rw C₂ at C₁k,
  intro x',
  have C₁' := C₁ x' k,
  rw C₁k at C₁',
  rw C₁k at C₁',
  symmetry,
  exact C₁',
end

/-
 Problem 9.20
-/
def is_identity(i: Bird): Prop := ∀ x: Bird, i ⬝ x = x

theorem agreeable_identity(i: Bird)
  (C₁: is_identity i)
  (C₂: is_agreeable i)
:  ∀ x: Bird, is_normal x
:=
begin
  rw is_agreeable at C₂,
  rw is_identity at C₁,
  intro a,
  have C₂a := C₂ a,
  cases C₂a with x' C₂a',
  have C₁' := C₁ x',
  rw C₁' at  C₂a',
  rw is_normal,
  existsi x',
  rw is_fond,
  symmetry,
  exact C₂a',
end

/-
 Problem 9.21
-/
theorem identity_and_normals(i: Bird)
  (C₁: is_identity i)
  (C₂: ∀ x: Bird, is_normal x)
: is_agreeable i
:=
begin
  rw is_agreeable,
  intro b,
  have C₂b := C₂ b,
  rw is_normal at C₂b,
  cases C₂b with x' C₂b',
  rw is_fond at C₂b',
  existsi x',
  rw C₂b',
  rw C₁,
end

/-
 Problem 9.22
-/
theorem identity_and_compatibles(i: Bird)
  (C₁: is_identity i)
  (C₂: ∀ x y: Bird, is_compatible x y)
: (∀ x: Bird, is_normal x) ∧ (is_agreeable i)
:=
begin
  rw is_identity at C₁,

  split,

  -- Goal 1
  intro b,
  rw is_normal,
  have C₂bi := C₂ b i,
  rw is_compatible at C₂bi,
  cases C₂bi with x' C₂bi',
  cases C₂bi' with y' C₂bi',
  cases C₂bi' with C₂byx C₂iyx,
  rw C₁ at C₂iyx,
  rw C₂iyx at C₂byx,
  existsi y',
  rw is_fond,
  exact C₂byx,

  -- Goal 2
  rw is_agreeable,
  intro b,
  -- TODO: the next 8 lines are the same as for Goal 1
  -- except for a different 'b'. How to reuse?
  have C₂bi := C₂ b i,
  rw is_compatible at C₂bi,
  cases C₂bi with x' C₂bi',
  cases C₂bi' with y' C₂bi',
  cases C₂bi' with C₂byx C₂iyx,
  rw C₁ at C₂iyx,
  rw C₂iyx at C₂byx,
  existsi y',
  have C₁y := C₁ y',
  rw C₁ y',
  symmetry,
  exact C₂byx,
end

/-
 Problem 9.23 - Why?
-/
theorem hopelessly_egocentric_identity(i: Bird)
  (C₁: is_identity i)
  (C₂: is_hopelessly_egocentric i)
  : ∀ x, x = i
:=
begin
  rw is_hopelessly_egocentric at C₂,
  rw is_fixated at C₂,
  rw is_identity at C₁,
  intro x',
  have C₁x := C₁ x',
  have C₂x := C₂ x',
  rw ←C₁x,
  rw C₂x,
end

/-
 Problem 9.24
-/

def is_lark(l: Bird): Prop := ∀ x y: Bird, (l ⬝ x) ⬝ y = x ⬝ (y ⬝ y)

theorem lark_and_identity(i l: Bird)
  (C₁: is_identity i)
  (C₂: is_lark l)
  : ∃ m, is_mocking m
:=
begin
  existsi (l ⬝ i),
  rw is_mocking,
  intro x',

  rw is_lark at C₂,
  have C₂ix := C₂ i x',
  rw is_identity at C₁,
  have C₁xx := C₁ (x' ⬝ x'),
  rw C₁xx at C₂ix,
  exact C₂ix,
end

/-
 Problem 9.25
-/

lemma lark_and_fondness(l: Bird)
  (C₁: is_lark l)
  : ∀ x, is_fond x ((l ⬝ x) ⬝ (l ⬝ x))
:=
begin
  intro x',
  rw is_fond,
  have C₁x := C₁ x',
  have C₁xlx := C₁x (l ⬝ x'),
  symmetry,
  exact C₁xlx,
end

theorem lark_and_happy(l: Bird)
  (C₁: is_lark l)
  : ∀ x, is_happy x
:=
begin
  have LF := lark_and_fondness l C₁,
  intro x',
  -- reduce Problem 9.to proving ∀ x, is_normal x.
  apply (normal_is_happy x'),
  rw is_normal,
  existsi ((l ⬝ x') ⬝ (l ⬝ x')),
  have LF' := LF  x',
  exact LF',
end

/-
 Problem 9.26
-/
theorem hopelessly_egocentric_lark(l: Bird)
  (C₁: is_lark l)
  (C₂: is_hopelessly_egocentric l)
  : ∀ x, is_fond x l
:=
begin
  intro x',
  rw is_fond,
  rw is_lark at C₁,
  rw is_hopelessly_egocentric at C₂,
  rw is_fixated at C₂,
  have C₁xl := C₁ x' l,
  repeat {rw C₂ at C₁xl},
  symmetry,
  exact C₁xl
end

/-
 Problem 9.27
-/

-- If lark is fond of kestrel, then all birds are egocentric
lemma lark_fond_of_kestrel_all_egocentric(k l: Bird)
  (C₁: is_kestrel k)
  (C₂: is_lark l)
  (C₃: is_fond l k)
  : ∀ x, is_egocentric x
:=
begin
  intro x',
  rw is_kestrel at C₁,
  rw is_lark at C₂,
  rw is_fond at C₃,

  have C₂kx' := C₂ k x',
  rw C₃ at C₂kx',

  have C₁xxk := C₁ (x' ⬝ x') k,
  rw← C₂kx' at C₁xxk,

  have C₁lk := C₁ x' k,
  rw C₁xxk at C₁lk,

  rw is_egocentric,
  rw is_fond,
  exact  C₁lk,
end

theorem lark_fond_of_kestrel_same(k l: Bird)
  (C₁: is_kestrel k)
  (C₂: is_lark l)
  (C₃: is_fond l k)
  : l = k
:=
begin
  rw is_kestrel at C₁,

  -- Goal 1: is_hopelessly_egocentric k
  let hego_k: is_hopelessly_egocentric k,
  intro x',
  have C₁kl := C₁ k x',
  have all_ego := lark_fond_of_kestrel_all_egocentric k l C₁ C₂ C₃,
  have ego_k := all_ego k,
  rw is_egocentric at ego_k,
  rw is_fond at ego_k,
  rw ego_k at C₁kl,
  exact C₁kl,

  -- Goal 2
  have C₁k := C₁ l k,
  repeat {rw hego_k at C₁k},
  symmetry,
  exact C₁k
end

/-
 Problem 9.28
-/
theorem kestrel_fond_of_lark(k l: Bird)
  (C₁: is_kestrel k)
  (C₂: is_lark l)
  (C₃: is_fond k l)
  : ∀ x, is_fond x l
:=
begin
  rw is_kestrel at C₁,
  rw is_fond at C₃,
  rw is_lark at C₂,
  intro x',
  rw is_fond,
  have C₁l := C₁ l,
  rw C₃ at C₁l,
  -- C₁l : l is hopelessly ego.
  have C₂x'l := C₂ x' l,
  rw C₁l x' at C₂x'l,
  rw C₁l l at C₂x'l,
  symmetry,
  exact C₂x'l,
end

/-
 Problem 10: Is There a Sage Bird
 (hard)
-/

lemma lark_exists(l m: Bird)
  (C₂: is_mocking m)
  (C₃: ∀ a: Bird, composes a m (l ⬝ a))
  : is_lark l
:=
begin
  rw is_lark,
  intro x,
  intro y,
  have C₃x := C₃ x,
  rw composes at C₃x,
  have C₃xy := C₃x y,
  rw C₂ at C₃xy,
  exact C₃xy,
end

def is_sage(θ: Bird): Prop := ∀ x: Bird, x ⬝ (θ ⬝ x) = θ ⬝ x

theorem sage_exists(m: Bird)
  (C₁: ∀ a b: Bird, ∃ c: Bird, composes a b c)
  (C₂: is_mocking m)
  (C₃: ∃ r, ∀ a: Bird, composes a m (r ⬝ a))
  : ∃ θ: Bird, is_sage θ
:=
begin
  -- We'll prove that the bird that composes m and l
  -- is the sage bird θ

  -- given C₂ C₃, a lark exists
  cases C₃ with l C₃l,
  have L := lark_exists l m C₂ C₃l,

  -- By definition: θ x = m (l x)
  have C₁ml := C₁ m l,
  cases C₁ml with θ C₁ml,
  existsi θ,
  rw is_sage,

  intro x',

  -- Use result that
  -- x' is fond of (l x' (l x'))
  have LF := lark_and_fondness l L,
  have LF' := LF x',
  rw is_fond at LF',

  -- Remove duplicates by using xx -> mx
  rw is_mocking at C₂,
  have C₂' := C₂ (l ⬝ x'),
  rw← C₂' at LF',

  -- Replace m (l x) by θ x
  rw composes at C₁ml,
  have C₁ml' := C₁ml x',
  rw← C₁ml' at LF',

  exact LF',
end

/-
 Problem 11.1
-/

def is_blue(b: Bird): Prop := ∀ x y z: Bird, b ⬝ x ⬝ y ⬝ z = x ⬝ (y ⬝ z)

theorem blue_implies_composition(b: Bird)
  (C₁: is_blue b)
  : ∀ x y: Bird, ∃ z: Bird, composes x y z :=
begin
  intro x,
  intro y,
  rw is_blue at C₁,
  existsi b ⬝ x ⬝ y,
  rw composes,
  intro z,
  exact C₁ x y z,
end

/-
 Problem 11.2 - blue birds and mocking birds
-/

theorem fond_of_blue_and_mocking(b m: Bird)
  (C₁: is_blue b)
  (C₂: is_mocking m)
  : ∀ x: Bird, is_fond x (m ⬝ (b ⬝ x ⬝ m)) :=
begin
  intro x,
  rw is_fond,
  rw is_mocking at C₂,
  rw is_blue at C₁,
  rw C₂ (b ⬝ x ⬝ m),

  have C' := C₁ x m (b ⬝ x ⬝ m),
  rw C₂ (b ⬝ x ⬝ m) at C',
  symmetry,
  exact C',
end

/-
 Problem 11.3 - egocentric
 (hard)

  Idea:
    From 11.2 we have
    x (m ⬝ (b ⬝ x ⬝ m)) = m ⬝ (b ⬝ x ⬝ m)

    [key step] Replace x with m:
    m (m ⬝ (b ⬝ m ⬝ m)) = m ⬝ (b ⬝ m ⬝ m)

    let e = m ⬝ (b ⬝ m ⬝ m):
    me = e

    using mx = xx:
    ee = e

    So m ⬝ (b ⬝ m ⬝ m) is egocentric
-/

theorem egocentric_from_blue_and_mocking(b m: Bird)
  (C₁: is_blue b)
  (C₂: is_mocking m)
  : is_egocentric (m ⬝ (b ⬝ m ⬝ m)) :=
begin
  have C₃ := fond_of_blue_and_mocking b m C₁ C₂,
  have C₃m := C₃ m,
  rw is_fond at C₃m,
  rw C₂ at C₃m,
  exact C₃m,
end

/-
 Problem 11.4 - hopelessly egocentric

  From 11.2 we have
  x (m (b x m)) = m (b x m)

  [key step] Replace x with k:
  k (m (b k m)) = m (b k m)

  let h = m (b k m)
  k h = h

  By kestrel
  k h y = h
  h y = h

-/
theorem hopelessly_egocentric_from_blue_kestrel_mocking(b k m: Bird)
  (C₁: is_blue b)
  (C₂: is_kestrel k)
  (C₃: is_mocking m)
  : is_hopelessly_egocentric (m ⬝ (b ⬝ k ⬝ m)) :=
begin
  have C₄ := fond_of_blue_and_mocking b m C₁ C₃,
  have C₄k := C₄ k,
  rw is_fond at C₄k,

  rw is_kestrel at C₂,
  have C₂' := C₂ (m ⬝ (b ⬝ k ⬝ m)),

  rw is_hopelessly_egocentric,
  rw is_fixated,
  intro x',

  have C₂x' := C₂' x',
  rw C₄k at C₂x',
  exact C₂x',
end

/-
 Problem 11.5 - doves
 -/
def is_dove(d: Bird): Prop :=
  ∀ x y z w: Bird, d ⬝ x ⬝ y ⬝ z ⬝ w = x ⬝ y ⬝ (z ⬝ w)

/-
  Prove that d = bb
-/
theorem dove_from_blue(b: Bird)
  (C₁: is_blue b)
  : is_dove(b ⬝ b) :=
begin
  rw is_dove,
  intro x',
  intro y',
  intro z',
  intro w',

  have H₁ := C₁ (x' ⬝ y') z' w',
  rw ←C₁,

  have H₂ := C₁ b x' y',
  rw H₂,
end

/-
 Problem 11.6 - blackbird
 -/
def is_blackbird(b₁: Bird): Prop :=
  ∀ x y z w: Bird, b₁ ⬝ x ⬝ y ⬝ z ⬝ w = x ⬝ (y ⬝ z ⬝ w)

/-
  Prove that b₁ = db
-/
theorem blackbird_from_blue(b: Bird)
  (C₁: is_blue b)
  : is_blackbird(b ⬝ b ⬝ b) :=
begin
  rw is_blackbird,
  intro x',
  intro y',
  intro z',
  intro w',

  have C₂ := dove_from_blue b C₁,
  rw is_dove at C₂,

  have H₁ := C₂ b x' y' z',
  rw H₁,

  have H₂ := C₁ x' (y' ⬝ z') w',
  exact H₂,
end

/-
 Problem 11.7 - eagle
 -/
def is_eagle(e: Bird): Prop :=
  ∀ x y z w v: Bird, e ⬝ x ⬝ y ⬝ z ⬝ w ⬝ v = x ⬝ y ⬝ (z ⬝ w ⬝ v)

/-
  Prove that e = b b₁
-/
theorem eagle_from_blue(b b₁: Bird)
  (C₁: is_blue b)
  (C₂: is_blackbird b₁)
  : is_eagle(b ⬝ b₁) :=
begin
  rw is_eagle,
  intro x',
  intro y',
  intro z',
  intro w',
  intro v',

  rw is_blackbird at C₂,
  have C₂ := C₂ (x' ⬝ y') z' w' v',

  rw is_blue at C₁,
  have C₁ := C₁ b₁ x' y',

  rw C₁,
  rw C₂,
end

/-
 Problem 11.8 - bunting
 -/
def is_bunting(b₂: Bird): Prop :=
  ∀ x y z w v: Bird, b₂ ⬝ x ⬝ y ⬝ z ⬝ w ⬝ v = x ⬝ (y ⬝ z ⬝ w ⬝ v)

/-
  Prove that b₂ = e b
-/
theorem bunting_from_blue(b e: Bird)
  (C₁: is_blue b)
  (C₂: is_eagle e)
  : is_bunting(e ⬝ b) :=
begin
  rw is_bunting,
  intro x',
  intro y',
  intro z',
  intro w',
  intro v',

  rw is_eagle at C₂,
  have C₂ := C₂ b x' y' z' w',

  rw is_blue at C₁,
  have C₁ := C₁ x' (y' ⬝ z' ⬝ w') v',

  rw C₂,
  rw C₁,
end

/-
 Problem 11.9 - dickcissel
 -/
def is_dickcissel(d₁: Bird): Prop :=
  ∀ x y z w v: Bird, d₁ ⬝ x ⬝ y ⬝ z ⬝ w ⬝ v = x ⬝ y ⬝ z ⬝ (w ⬝ v)

/-
  Prove that d₁ = b d
-/
theorem dickcissel_from_blue(b d: Bird)
  (C₁: is_blue b)
  (C₂: is_dove d)
  : is_dickcissel(b ⬝ d) :=
begin
  rw is_dickcissel,
  intro x',
  intro y',
  intro z',
  intro w',
  intro v',

  rw is_blue at C₁,
  have C₁ := C₁ d x' y',

  rw is_dove at C₂,
  have C₂ := C₂ (x' ⬝ y') z' w' v',

  rw C₁,
  rw C₂,
end

/-
 Problem 11.10 - becards
 -/
def is_becard(b₃: Bird): Prop :=
  ∀ x y z w: Bird, b₃ ⬝ x ⬝ y ⬝ z ⬝ w = x ⬝ (y ⬝ (z ⬝ w))

/-
  Prove that b₃ = d₁ b
-/
theorem becard_from_blue(b d₁: Bird)
  (C₁: is_blue b)
  (C₂: is_dickcissel d₁)
  : is_becard(d₁ ⬝ b) :=
begin
  rw is_becard,
  intro x',
  intro y',
  intro z',
  intro w',

  rw is_blue at C₁,
  have C₁ := C₁ x' y' (z' ⬝ w'),

  rw is_dickcissel at C₂,
  have C₂ := C₂ b x' y' z' w',

  rw C₂,
  rw C₁,
end

/-
 Problem 11.11 - dovekies
 -/
def is_dovekie(d₂: Bird): Prop :=
  ∀ x y z w v: Bird, d₂ ⬝ x ⬝ y ⬝ z ⬝ w ⬝ v = x ⬝ (y ⬝ z) ⬝ (w ⬝ v)

theorem dovekie_from_dove(d: Bird)
  (C₁: is_dove d) :
  is_dovekie(d ⬝ d) :=
begin
  rw is_dovekie,
  intro x',
  intro y',
  intro z',
  intro w',
  intro v',

  rw is_dove at C₁,
  have C₁' := C₁ x' (y' ⬝ z') w' v',

  have C₁'' := C₁ d x' y' z',

  rw C₁'',
  rw C₁',
end

/-
 Problem 11.12 - Bald eagles
 -/
def is_bald_eagle(e₁: Bird): Prop :=
  ∀ x y₁ y₂ y₃ z₁ z₂ z₃: Bird, e₁ ⬝ x ⬝ y₁ ⬝ y₂ ⬝ y₃ ⬝ z₁ ⬝ z₂ ⬝ z₃ = x ⬝ (y₁ ⬝ y₂ ⬝ y₃) ⬝ (z₁ ⬝ z₂ ⬝ z₃)

theorem bald_eagle_from_eagle(e: Bird)
  (C₁: is_eagle e) :
  is_bald_eagle(e ⬝ e) :=
begin
  rw is_bald_eagle,
  intro x',
  intro y₁',
  intro y₂',
  intro y₃',
  intro z₁',
  intro z₂',
  intro z₃',

  rw is_eagle at C₁,
  have C₁' := C₁ x' (y₁' ⬝ y₂' ⬝ y₃') z₁' z₂' z₃',

  have C₁'' := C₁ e x' y₁' y₂' y₃',

  rw C₁'',
  rw C₁',
end

def is_warbler(w: Bird): Prop :=
  ∀ x y: Bird, w ⬝ x ⬝ y = x ⬝ y ⬝ y

/-
 Problem 11.14
 -/
theorem mocking_from_warbler_and_identity(w i: Bird)
  (C₁: is_warbler w)
  (C₂: is_identity i) :
  is_mocking(w ⬝ i) :=
begin
  rw is_mocking,
  intro x,
  have C₁' := C₁ i x,
  rw C₁',
  rw C₂,
end

/-
 Problem 11.15
 -/
theorem identity_from_warbler_and_kestrel(w k: Bird)
  (C₁: is_warbler w)
  (C₂: is_kestrel k) :
  is_identity(w ⬝ k) :=
begin
  rw is_identity,
  intro x,
  have C₁' := C₁ k x,
  have C₂' := C₂ x x,
  rw C₁',
  exact C₂',
end

/-
  Problem 11.13 - warblers
 -/
theorem mocking_from_warbler_and_krestel(w k: Bird)
  (C₁: is_warbler w)
  (C₂: is_kestrel k) :
  is_mocking(w ⬝ (w ⬝ k)) :=
begin
  have I := identity_from_warbler_and_kestrel w k C₁ C₂,
  have M := mocking_from_warbler_and_identity w (w ⬝ k) C₁ I,
  exact M,
end

/-
 Problem 11.16
 -/
def is_cardinal(c: Bird): Prop :=
  ∀ x y z: Bird, c ⬝ x ⬝ y ⬝ z = x ⬝ z ⬝ y

theorem identity_from_cardinal_and_krestel(c k: Bird)
  (C₁: is_cardinal c)
  (C₂: is_kestrel k) :
  is_identity(c ⬝ k ⬝ k) :=
begin
  rw is_identity,
  intro x,
  have C₁' :=  C₁ k k x,
  have C₂' :=  C₂ x k,
  rw C₁',
  exact C₂',
end

/-
 Problem 11.17
 -/

def is_thrush(t: Bird): Prop :=
  ∀ x y: Bird, t ⬝ x ⬝ y = y ⬝ x

theorem trush_from_cardinal_and_identity(c i: Bird)
  (C₁: is_cardinal c)
  (C₂: is_identity i) :
  is_thrush(c ⬝ i) :=
begin
  rw is_thrush,
  intro x,
  intro y,
  have C₁' :=  C₁ i x y,
  rw C₂ at C₁',
  exact C₁',
end

/-
 Problem 11.18
 -/

theorem commuting_birds(t: Bird)
  (C₁: is_thrush t)
  (C₂: ∀ x: Bird, ∃ c: Bird, x ⬝ c = c) :
  ∃ a: Bird,  ∀ x: Bird, a ⬝ x = x ⬝ a :=
begin
  have C₂' := C₂ t,
  cases C₂' with ct C₂'t,
  existsi ct,
  intro x,
  have C₁' := C₁ ct x,
  rw C₂'t at C₁',
  exact C₁',
end

/-
 Problem 11.19
 -/

/- TODO -/

/-
 Problem 11.20
 -/
def is_robin(r: Bird): Prop :=
  ∀ x y z: Bird, r ⬝ x ⬝ y ⬝ z = y ⬝ z ⬝ x

theorem robin_from_blue_thrush(b t: Bird)
 (C₁: is_blue b)
 (C₂: is_thrush t) :
  is_robin(b ⬝ b ⬝ t) :=
begin
  rw is_robin,
  intro x,
  intro y,
  intro z,
  rw is_blue at C₁,
  rw C₁ b t x,
  rw C₁ (t ⬝ x) y z,
  rw C₂ x (y ⬝ z),
end

/-
 Problem 11.21
 -/
theorem cardinal_from_robin(r: Bird)
 (C₁: is_robin r) :
  is_cardinal(r ⬝ r ⬝ r) :=
begin
  rw is_cardinal,
  intro x,
  intro y,
  intro z,
  rw [C₁, C₁, C₁],
end

/-
  Bonus: cardinal from bt.
  Follows from c = r r r and b = b b t

  TODO: version with length 8
-/
theorem cardinal_from_bt(b t: Bird)
  (C₁: is_blue b)
  (C₂: is_thrush t) :
  is_cardinal((b ⬝ b ⬝ t) ⬝ (b ⬝ b ⬝ t) ⬝ (b ⬝ b ⬝ t)) :=
begin
  rw is_cardinal,
  intro x,
  intro y,
  intro z,
  rw [C₁, C₁, C₂, C₁, C₁, C₂, C₁, C₁, C₂],
end

/-
 Problem 11.22
 -/

 /- TODO -/

/-
 Problem 11.23
 -/

theorem robin_from_cardinal(c: Bird)
 (C₁: is_cardinal c) :
  is_robin(c ⬝ c) :=
begin
  rw is_robin,
  intro x,
  intro y,
  intro z,
  rw C₁,
  rw C₁,
end

/-
 Problem 11.24
 -/
def is_finch(f: Bird): Prop :=
  ∀ x y z: Bird, f ⬝ x ⬝ y ⬝ z = z ⬝ y ⬝ x

theorem finch_from_bcr(b c r: Bird)
 (C₁: is_blue b)
 (C₂: is_cardinal c)
 (C₃: is_robin r) :
  is_finch(b ⬝ c ⬝ r) :=
begin
  rw is_finch,
  intro x,
  intro y,
  intro z,
  rw C₁,
  rw C₂,
  rw C₃
end

/-
 Problem 11.25
 -/

theorem finch_from_et(e t: Bird)
 (C₁: is_eagle e)
 (C₂: is_thrush t) :
  is_finch(e ⬝ t ⬝ t ⬝ e ⬝ t) :=
begin
  rw is_finch,
  intro x,
  intro y,
  intro z,
  rw C₁,
  rw C₂,
  rw C₁,
  rw C₂,
  rw C₂,
end

/-
 Problem 11.26
 -/

/- TODO -/

/-
 Problem 11.27
 -/

def is_vireo(v: Bird): Prop :=
  ∀ x y z: Bird, v ⬝ x ⬝ y ⬝ z = z ⬝ x ⬝ y

def vireo_from_cf(c f: Bird)
  (C₁: is_cardinal c)
  (C₂: is_finch f) :
  is_vireo(c ⬝ f) :=
begin
  rw is_vireo,
  intro x,
  intro y,
  intro z,
  rw C₁,
  rw C₂,
end

/-
 Problem 11.28
 -/

def vireo_is_rfr(f r: Bird)
  (C₁: is_finch f)
  (C₂: is_robin r) :
  is_vireo(r ⬝ f ⬝ r) :=
begin
  rw is_vireo,
  intro x,
  intro y,
  intro z,
  rw C₂,
  rw C₂,
  rw C₁,
end

/-
 Problem 11.29
 -/

def finch_is_cv(c v: Bird)
  (C₁: is_cardinal c)
  (C₂: is_vireo v) :
  is_finch(c ⬝ v) :=
begin
  rw is_finch,
  intro x,
  intro y,
  intro z,
  rw C₁,
  rw C₂,
end

/-
 Problem 11.30
 -/

def identity_is_rkrk(k r: Bird)
  (C₁: is_kestrel k)
  (C₂: is_robin r) :
  is_identity(r ⬝ k ⬝ r ⬝ k) :=
begin
  rw is_identity,
  intro x,
  rw C₂,
  rw C₂,
  rw C₁,
end

/-
 Problem 11.31
 -/

def is_cardinal_once_removed(c₁: Bird): Prop :=
  ∀ x y z w: Bird, c₁ ⬝ x ⬝ y ⬝ z ⬝ w = x ⬝ y ⬝ w ⬝ z

def cardinal_once_removed_is_bc(b c: Bird)
  (C₁: is_blue b)
  (C₂: is_cardinal c) :
  is_cardinal_once_removed(b ⬝ c) :=
begin
  rw is_cardinal_once_removed,
  intro x,
  intro y,
  intro z,
  intro w,
  rw C₁,
  rw C₂,
end

/-
 Problem 11.32
 -/

def is_robin_once_removed(r₁: Bird): Prop :=
  ∀ x y z w: Bird, r₁ ⬝ x ⬝ y ⬝ z ⬝ w = x ⬝ z ⬝ w ⬝ y

def robin_once_removed_is_bcbc(b c: Bird)
  (C₁: is_blue b)
  (C₂: is_cardinal c) :
  is_robin_once_removed(b ⬝ c ⬝ (b ⬝ c)) :=
begin
  rw is_robin_once_removed,
  intro x,
  intro y,
  intro z,
  intro w,
  rw C₁,
  rw C₂,
  rw C₁,
  rw C₂,
end

/-
 Problem 11.33
 -/

def is_finch_once_removed(f₁: Bird): Prop :=
  ∀ x y z w: Bird, f₁ ⬝ x ⬝ y ⬝ z ⬝ w = x ⬝ w ⬝ z ⬝ y

def flich_once_removed_from_bc(b c: Bird)
  (C₁: is_blue b)
  (C₂: is_cardinal c) :
  is_finch_once_removed(b ⬝ (b ⬝ c ⬝ (b ⬝ c)) ⬝ c) :=
begin
  rw is_finch_once_removed,
  intro x,
  intro y,
  intro z,
  intro w,
  rw [C₁, C₁, C₂, C₁, C₂, C₂],
end

/-
 Problem 11.34
 -/

def is_vireo_once_removed(v₁: Bird): Prop :=
  ∀ x y z w: Bird, v₁ ⬝ x ⬝ y ⬝ z ⬝ w = x ⬝ w ⬝ y ⬝ z

def vireo_once_removed_from_bc(b c: Bird)
  (C₁: is_blue b)
  (C₂: is_cardinal c) :
  is_vireo_once_removed(b ⬝ (b ⬝ c) ⬝ c) :=
begin
  rw is_vireo_once_removed,
  intro x,
  intro y,
  intro z,
  intro w,
  rw [C₁, C₁, C₂, C₂],
end

/-
 Problem 11.35

 Each of the twice removed can be written as b ⬝ (once removed)

 Since the once removed can be written from b c, it suffices to
 show a twice removed can be obtained from b c.
 -/

def is_cardinal_twice_removed(c₂: Bird): Prop :=
  ∀ x y z₁ z₂ z₃: Bird, c₂ ⬝ x ⬝ y ⬝ z₁ ⬝ z₂ ⬝ z₃ = x ⬝ y ⬝ z₁ ⬝ z₃ ⬝ z₂

def is_robin_twice_removed(c₂: Bird): Prop :=
  ∀ x y z₁ z₂ z₃: Bird, c₂ ⬝ x ⬝ y ⬝ z₁ ⬝ z₂ ⬝ z₃ = x ⬝ y ⬝ z₂ ⬝ z₃ ⬝ z₁

def is_finch_twice_removed(c₂: Bird): Prop :=
  ∀ x y z₁ z₂ z₃: Bird, c₂ ⬝ x ⬝ y ⬝ z₁ ⬝ z₂ ⬝ z₃ = x ⬝ y ⬝ z₃ ⬝ z₂ ⬝ z₁

def is_vireo_twice_removed(c₂: Bird): Prop :=
  ∀ x y z₁ z₂ z₃: Bird, c₂ ⬝ x ⬝ y ⬝ z₁ ⬝ z₂ ⬝ z₃ = x ⬝ y ⬝ z₃ ⬝ z₁ ⬝ z₂

def cardinal_twice_removed_from_bc(b c₁: Bird)
  (C₁: is_blue b)
  (C₂: is_cardinal_once_removed c₁) :
  is_cardinal_twice_removed(b ⬝ c₁) :=
begin
  rw is_cardinal_twice_removed,
  intro x,
  intro y,
  intro z₁,
  intro z₂,
  intro z₃,
  rw [C₁, C₂],
end

def robin_twice_removed_from_bc(b c₁: Bird)
  (C₁: is_blue b)
  (C₂: is_robin_once_removed c₁) :
  is_robin_twice_removed(b ⬝ c₁) :=
begin
  rw is_robin_twice_removed,
  intro x,
  intro y,
  intro z₁,
  intro z₂,
  intro z₃,
  rw [C₁, C₂],
end

def finch_twice_removed_from_bc(b c₁: Bird)
  (C₁: is_blue b)
  (C₂: is_finch_once_removed c₁) :
  is_finch_twice_removed(b ⬝ c₁) :=
begin
  rw is_finch_twice_removed,
  intro x,
  intro y,
  intro z₁,
  intro z₂,
  intro z₃,
  rw [C₁, C₂],
end

def vireo_twice_removed_from_bc(b c₁: Bird)
  (C₁: is_blue b)
  (C₂: is_vireo_once_removed c₁) :
  is_vireo_twice_removed(b ⬝ c₁) :=
begin
  rw is_vireo_twice_removed,
  intro x,
  intro y,
  intro z₁,
  intro z₂,
  intro z₃,
  rw [C₁, C₂],
end

/-
  Problem 11.36
 -/

def vireo_from_from_c₁t(c₁ t: Bird)
  (C₁: is_cardinal_once_removed c₁)
  (C₂: is_thrush t) :
  is_vireo(c₁ ⬝ t) :=
begin
  rw is_vireo,
  intro x,
  intro y,
  intro z,
  rw [C₁, C₂]
end

/-
  Problem 11.37
 -/

def is_queer(q: Bird): Prop :=
  ∀ x y z: Bird, q ⬝ x ⬝ y ⬝ z =  y ⬝ (x ⬝ z)

/- c can be written from bt (cardinal_from_bt)  -/
def queer_from_bt(b c: Bird)
  (C₁: is_blue b)
  (C₂: is_cardinal c) :
  is_queer(c ⬝ b) :=
begin
  rw is_queer,
  intro x,
  intro y,
  intro z,
  rw [C₂, C₁],
end

/-
  Problem 11.38
 -/
def is_quixotic(q₁: Bird): Prop :=
  ∀ x y z: Bird, q₁ ⬝ x ⬝ y ⬝ z =  x ⬝ (z ⬝ y)

/-
  c₁ can be written from bc
  (cardinal_once_removed_is_bc) and thus from bt
-/
def quixotic_from_bc₁(b c₁: Bird)
  (C₁: is_blue b)
  (C₂: is_cardinal_once_removed c₁) :
  is_quixotic(c₁ ⬝ b) :=
begin
  rw is_quixotic,
  intro x,
  intro y,
  intro z,
  rw [C₂, C₁],
end

/-
  Problem 11.39
 -/
def is_quizical(q₂: Bird): Prop :=
  ∀ x y z: Bird, q₂ ⬝ x ⬝ y ⬝ z =  y ⬝ (z ⬝ x)

def quixotic_from_br₁(b r₁: Bird)
  (C₁: is_blue b)
  (C₂: is_robin_once_removed r₁) :
  is_quizical(r₁ ⬝ b) :=
begin
  rw is_quizical,
  intro x,
  intro y,
  intro z,
  rw [C₂, C₁],
end

/-
  Problem 11.40

  It suffices to show that
  q₂ = c ⬝ q₁
  q₁ = c ⬝ q₂
 -/
def quizical_from_cq₁(c q₁: Bird)
  (C₁: is_cardinal c)
  (C₂: is_quixotic q₁) :
  is_quizical(c ⬝ q₁) :=
begin
  rw is_quizical,
  intro x,
  intro y,
  intro z,
  rw [C₁, C₂],
end

def quixotic_from_cq₂(c q₂: Bird)
  (C₁: is_cardinal c)
  (C₂: is_quizical q₂) :
  is_quixotic(c ⬝ q₂) :=
begin
  rw is_quixotic,
  intro x,
  intro y,
  intro z,
  rw [C₁, C₂],
end

/-
  Problem 11.41
 -/

def is_quirky(q₃: Bird): Prop :=
  ∀ x y z: Bird, q₃ ⬝ x ⬝ y ⬝ z = z ⬝ (x ⬝ y)

def quirky_from_bt(b t: Bird)
  (C₁: is_blue b)
  (C₂: is_thrush t) :
  is_quirky(b ⬝ t) :=
begin
  rw is_quirky,
  intro x,
  intro y,
  intro z,
  rw [C₁, C₂],
end

/-
  Problem 11.42

  Note: This is one of the more interesting ones
  in terms of lean tactics
 -/
def is_quacky(q₄: Bird): Prop :=
  ∀ x y z: Bird, q₄ ⬝ x ⬝ y ⬝ z = z ⬝ (y ⬝ x)

def quacky_from_bt(b t: Bird)
  (C₁: is_blue b)
  (C₂: is_thrush t) :
  is_quacky(b ⬝ (b ⬝ t) ⬝ t) :=
begin
  rw is_quacky,
  intro x,
  intro y,
  intro z,
  rw [C₁, C₁],
  -- rewrite the inner t first
  nth_rewrite 1 C₂,
  rw C₂,
end

/-
  Problem 11.43
-/

def quirky_from_cq₄(c q₄: Bird)
  (C₁: is_cardinal c)
  (C₂: is_quacky q₄) :
  is_quirky(c ⬝ q₄) :=
begin
  rw is_quirky,
  intro x,
  intro y,
  intro z,
  rw [C₁, C₂],
end

def quacky_from_cq₃(c q₃: Bird)
  (C₁: is_cardinal c)
  (C₂: is_quirky q₃) :
  is_quacky(c ⬝ q₃) :=
begin
  rw is_quacky,
  intro x,
  intro y,
  intro z,
  rw [C₁, C₂],
end

/-
  Problem 11.44
-/

def quacky_from_q₁t(q₁ t: Bird)
  (C₁: is_quixotic q₁)
  (C₂: is_thrush t) :
  is_quacky(q₁ ⬝ t) :=
begin
  rw is_quacky,
  intro x,
  intro y,
  intro z,
  rw [C₁, C₂],
end

/-
  Problem 11.45
-/
def blue_from_qt(q t: Bird)
  (C₁: is_queer q)
  (C₂: is_thrush t) :
  is_blue(q ⬝ t ⬝ (q ⬝ q)) :=
begin
  rw is_blue,
  intro x,
  intro y,
  intro z,
  rw [C₁, C₁, C₂, C₁],
end

/-
  Problem 11.46
-/
def cardinal_from_qt(q t: Bird)
  (C₁: is_queer q)
  (C₂: is_thrush t) :
  is_cardinal(q ⬝ q ⬝ (q ⬝ t)) :=
begin
  rw is_cardinal,
  intro x,
  intro y,
  intro z,
  rw [C₁, C₁, C₁, C₂],
end

/-
  Problem 11.47
-/
def is_goldfinch(g: Bird): Prop :=
  ∀ x y z w: Bird, g ⬝ x ⬝ y ⬝ z ⬝ w =  x ⬝ w ⬝ (y ⬝ z)

/-
  Showing that g = bbc suffices since
  c = rrr (via 11.21)
  r = bbt (via 11.20)
-/
def goldfinch_from_bt(b c: Bird)
  (C₁: is_blue b)
  (C₂: is_cardinal c) :
  is_goldfinch(b ⬝ b ⬝ c) :=
begin
  rw is_goldfinch,
  intro x,
  intro y,
  intro z,
  intro w,
  rw [C₁, C₁, C₂],
end


/-
Copyright (c) 2020 Thomas Browning, Patrick Lutz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Thomas Browning, Patrick Lutz
-/

import field_theory.normal
import field_theory.primitive_element
import field_theory.fixed
import ring_theory.power_basis
import group_theory.group_action.fixing_subgroup

/-!
# Galois Extensions

In this file we define Galois extensions as extensions which are both separable and normal.

## Main definitions

- `is_galois F E` where `E` is an extension of `F`
- `fixed_field H` where `H : subgroup (E ≃ₐ[F] E)`
- `fixing_subgroup K` where `K : intermediate_field F E`
- `galois_correspondence` where `E/F` is finite dimensional and Galois

## Main results

- `intermediate_field.fixing_subgroup_fixed_field` : If `E/F` is finite dimensional (but not
  necessarily Galois) then `fixing_subgroup (fixed_field H) = H`
- `intermediate_field.fixed_field_fixing_subgroup`: If `E/F` is finite dimensional and Galois
  then `fixed_field (fixing_subgroup K) = K`

Together, these two results prove the Galois correspondence.

- `is_galois.tfae` : Equivalent characterizations of a Galois extension of finite degree
-/

open_locale polynomial

open finite_dimensional alg_equiv

section

variables (F : Type*) [field F] (E : Type*) [field E] [algebra F E]

/-- A field extension E/F is galois if it is both separable and normal. Note that in mathlib
a separable extension of fields is by definition algebraic. -/
class is_galois : Prop :=
[to_is_separable : is_separable F E]
[to_normal : normal F E]

variables {F E}

theorem is_galois_iff : is_galois F E ↔ is_separable F E ∧ normal F E :=
⟨λ h, ⟨h.1, h.2⟩, λ h, { to_is_separable := h.1, to_normal := h.2 }⟩

attribute [instance, priority 100] -- see Note [lower instance priority]
is_galois.to_is_separable is_galois.to_normal

variables (F E)

namespace is_galois

instance self : is_galois F F :=
⟨⟩

variables (F) {E}

lemma integral [is_galois F E] (x : E) : is_integral F x := normal.is_integral' x

lemma separable [is_galois F E] (x : E) : (minpoly F x).separable := is_separable.separable F x

lemma splits [is_galois F E] (x : E) : (minpoly F x).splits (algebra_map F E) := normal.splits' x

variables (F E)

instance of_fixed_field (G : Type*) [group G] [fintype G] [mul_semiring_action G E] :
  is_galois (fixed_points.subfield G E) E :=
⟨⟩

lemma intermediate_field.adjoin_simple.card_aut_eq_finrank
  [finite_dimensional F E] {α : E} (hα : is_integral F α)
  (h_sep : (minpoly F α).separable)
  (h_splits : (minpoly F α).splits (algebra_map F F⟮α⟯)) :
  fintype.card (F⟮α⟯ ≃ₐ[F] F⟮α⟯) = finrank F F⟮α⟯ :=
begin
  letI : fintype (F⟮α⟯ →ₐ[F] F⟮α⟯) := intermediate_field.fintype_of_alg_hom_adjoin_integral F hα,
  rw intermediate_field.adjoin.finrank hα,
  rw ← intermediate_field.card_alg_hom_adjoin_integral F hα h_sep h_splits,
  exact fintype.card_congr (alg_equiv_equiv_alg_hom F F⟮α⟯)
end

lemma card_aut_eq_finrank [finite_dimensional F E] [is_galois F E] :
  fintype.card (E ≃ₐ[F] E) = finrank F E :=
begin
  cases field.exists_primitive_element F E with α hα,
  let iso : F⟮α⟯ ≃ₐ[F] E :=
  { to_fun := λ e, e.val,
    inv_fun := λ e, ⟨e, by { rw hα, exact intermediate_field.mem_top }⟩,
    left_inv := λ _, by { ext, refl },
    right_inv := λ _, rfl,
    map_mul' := λ _ _, rfl,
    map_add' := λ _ _, rfl,
    commutes' := λ _, rfl },
  have H : is_integral F α := is_galois.integral F α,
  have h_sep : (minpoly F α).separable := is_galois.separable F α,
  have h_splits : (minpoly F α).splits (algebra_map F E) := is_galois.splits F α,
  replace h_splits : polynomial.splits (algebra_map F F⟮α⟯) (minpoly F α),
  { have p : iso.symm.to_alg_hom.to_ring_hom.comp (algebra_map F E) = (algebra_map F ↥F⟮α⟯),
    { ext, simp, },
    simpa [p] using polynomial.splits_comp_of_splits
      (algebra_map F E) iso.symm.to_alg_hom.to_ring_hom h_splits, },
  rw ← linear_equiv.finrank_eq iso.to_linear_equiv,
  rw ← intermediate_field.adjoin_simple.card_aut_eq_finrank F E H h_sep h_splits,
  apply fintype.card_congr,
  apply equiv.mk (λ ϕ, iso.trans (trans ϕ iso.symm)) (λ ϕ, iso.symm.trans (trans ϕ iso)),
  { intro ϕ, ext1, simp only [trans_apply, apply_symm_apply] },
  { intro ϕ, ext1, simp only [trans_apply, symm_apply_apply] },
end

end is_galois

end

section is_galois_tower

variables (F K E : Type*) [field F] [field K] [field E] {E' : Type*} [field E'] [algebra F E']
variables [algebra F K] [algebra F E] [algebra K E] [is_scalar_tower F K E]

lemma is_galois.tower_top_of_is_galois [is_galois F E] : is_galois K E :=
{ to_is_separable := is_separable_tower_top_of_is_separable F K E,
  to_normal := normal.tower_top_of_normal F K E }

variables {F E}

@[priority 100] -- see Note [lower instance priority]
instance is_galois.tower_top_intermediate_field (K : intermediate_field F E) [h : is_galois F E] :
  is_galois K E := is_galois.tower_top_of_is_galois F K E

lemma is_galois_iff_is_galois_bot : is_galois (⊥ : intermediate_field F E) E ↔ is_galois F E :=
begin
  split,
  { introI h,
    exact is_galois.tower_top_of_is_galois (⊥ : intermediate_field F E) F E },
  { introI h, apply_instance },
end

lemma is_galois.of_alg_equiv [h : is_galois F E] (f : E ≃ₐ[F] E') : is_galois F E' :=
{ to_is_separable := is_separable.of_alg_hom F E f.symm, to_normal := normal.of_alg_equiv f }

lemma alg_equiv.transfer_galois (f : E ≃ₐ[F] E') : is_galois F E ↔ is_galois F E' :=
⟨λ h, by exactI is_galois.of_alg_equiv f, λ h, by exactI is_galois.of_alg_equiv f.symm⟩

lemma is_galois_iff_is_galois_top : is_galois F (⊤ : intermediate_field F E) ↔ is_galois F E :=
(intermediate_field.top_equiv : (⊤ : intermediate_field F E) ≃ₐ[F] E).transfer_galois

instance is_galois_bot : is_galois F (⊥ : intermediate_field F E) :=
(intermediate_field.bot_equiv F E).transfer_galois.mpr (is_galois.self F)

end is_galois_tower

section galois_correspondence

variables {F : Type*} [field F] {E : Type*} [field E] [algebra F E]
variables (H : subgroup (E ≃ₐ[F] E)) (K : intermediate_field F E)

/-- The intermediate field of fixed points fixed by a monoid action that commutes with the
`F`-action on `E`. -/
def fixed_points.intermediate_field (M : Type*) [monoid M] [mul_semiring_action M E]
  [smul_comm_class M F E] : intermediate_field F E :=
{ carrier := mul_action.fixed_points M E,
  algebra_map_mem' := λ a g, by rw [algebra.algebra_map_eq_smul_one, smul_comm, smul_one],
  ..fixed_points.subfield M E }

namespace intermediate_field

/-- The intermediate_field fixed by a subgroup -/
def fixed_field : intermediate_field F E :=
fixed_points.intermediate_field H

lemma finrank_fixed_field_eq_card [finite_dimensional F E] [decidable_pred (∈ H)] :
  finrank (fixed_field H) E = fintype.card H :=
fixed_points.finrank_eq_card H E

/-- The subgroup fixing an intermediate_field -/
def fixing_subgroup : subgroup (E ≃ₐ[F] E) :=
fixing_subgroup (E ≃ₐ[F] E) (K : set E)

lemma le_iff_le : K ≤ fixed_field H ↔ H ≤ fixing_subgroup K :=
⟨λ h g hg x, h (subtype.mem x) ⟨g, hg⟩, λ h x hx g, h (subtype.mem g) ⟨x, hx⟩⟩

/-- The fixing_subgroup of `K : intermediate_field F E` is isomorphic to `E ≃ₐ[K] E` -/
def fixing_subgroup_equiv : fixing_subgroup K ≃* (E ≃ₐ[K] E) :=
{ to_fun := λ ϕ, { commutes' := ϕ.mem, ..alg_equiv.to_ring_equiv ↑ϕ },
  inv_fun := λ ϕ, ⟨ϕ.restrict_scalars _, ϕ.commutes⟩,
  left_inv := λ _, by { ext, refl },
  right_inv := λ _, by { ext, refl },
  map_mul' := λ _ _, by { ext, refl } }

theorem fixing_subgroup_fixed_field [finite_dimensional F E] :
  fixing_subgroup (fixed_field H) = H :=
begin
  have H_le : H ≤ (fixing_subgroup (fixed_field H)) := (le_iff_le _ _).mp le_rfl,
  classical,
  suffices : fintype.card H = fintype.card (fixing_subgroup (fixed_field H)),
  { exact set_like.coe_injective
      (set.eq_of_inclusion_surjective ((fintype.bijective_iff_injective_and_card
        (set.inclusion H_le)).mpr ⟨set.inclusion_injective H_le, this⟩).2).symm },
  apply fintype.card_congr,
  refine (fixed_points.to_alg_hom_equiv H E).trans _,
  refine (alg_equiv_equiv_alg_hom (fixed_field H) E).symm.trans _,
  exact (fixing_subgroup_equiv (fixed_field H)).to_equiv.symm
end

instance fixed_field.algebra : algebra K (fixed_field (fixing_subgroup K)) :=
{ smul := λ x y, ⟨x*y, λ ϕ, by rw [smul_mul', (show ϕ • ↑x = ↑x, by exact subtype.mem ϕ x),
    (show ϕ • ↑y = ↑y, by exact subtype.mem y ϕ)]⟩,
  to_fun := λ x, ⟨x, λ ϕ, subtype.mem ϕ x⟩,
  map_zero' := rfl,
  map_add' := λ _ _, rfl,
  map_one' := rfl,
  map_mul' := λ _ _, rfl,
  commutes' := λ _ _, mul_comm _ _,
  smul_def' := λ _ _, rfl }

instance fixed_field.is_scalar_tower : is_scalar_tower K (fixed_field (fixing_subgroup K)) E :=
⟨λ _ _ _, mul_assoc _ _ _⟩

end intermediate_field

namespace is_galois
theorem fixed_field_fixing_subgroup [finite_dimensional F E] [h : is_galois F E] :
  intermediate_field.fixed_field (intermediate_field.fixing_subgroup K) = K :=
begin
  have K_le : K ≤ intermediate_field.fixed_field (intermediate_field.fixing_subgroup K) :=
    (intermediate_field.le_iff_le _ _).mpr le_rfl,
  suffices : finrank K E =
    finrank (intermediate_field.fixed_field (intermediate_field.fixing_subgroup K)) E,
  { exact (intermediate_field.eq_of_le_of_finrank_eq' K_le this).symm },
  classical,
  rw [intermediate_field.finrank_fixed_field_eq_card,
    fintype.card_congr (intermediate_field.fixing_subgroup_equiv K).to_equiv],
  exact (card_aut_eq_finrank K E).symm,
end

lemma card_fixing_subgroup_eq_finrank [decidable_pred (∈ intermediate_field.fixing_subgroup K)]
  [finite_dimensional F E] [is_galois F E] :
  fintype.card (intermediate_field.fixing_subgroup K) = finrank K E :=
by conv { to_rhs, rw [←fixed_field_fixing_subgroup K,
  intermediate_field.finrank_fixed_field_eq_card] }

/-- The Galois correspondence from intermediate fields to subgroups -/
def intermediate_field_equiv_subgroup [finite_dimensional F E] [is_galois F E] :
  intermediate_field F E ≃o (subgroup (E ≃ₐ[F] E))ᵒᵈ :=
{ to_fun := intermediate_field.fixing_subgroup,
  inv_fun := intermediate_field.fixed_field,
  left_inv := λ K, fixed_field_fixing_subgroup K,
  right_inv := λ H, intermediate_field.fixing_subgroup_fixed_field H,
  map_rel_iff' := λ K L, by { rw [←fixed_field_fixing_subgroup L, intermediate_field.le_iff_le,
                                  fixed_field_fixing_subgroup L, ←order_dual.dual_le], refl } }

/-- The Galois correspondence as a galois_insertion -/
def galois_insertion_intermediate_field_subgroup [finite_dimensional F E] :
  galois_insertion (order_dual.to_dual ∘
      (intermediate_field.fixing_subgroup : intermediate_field F E → subgroup (E ≃ₐ[F] E)))
    ((intermediate_field.fixed_field : subgroup (E ≃ₐ[F] E) → intermediate_field F E) ∘
      order_dual.to_dual) :=
{ choice := λ K _, intermediate_field.fixing_subgroup K,
  gc := λ K H, (intermediate_field.le_iff_le H K).symm,
  le_l_u := λ H, le_of_eq (intermediate_field.fixing_subgroup_fixed_field H).symm,
  choice_eq := λ K _, rfl }

/-- The Galois correspondence as a galois_coinsertion -/
def galois_coinsertion_intermediate_field_subgroup [finite_dimensional F E] [is_galois F E] :
  galois_coinsertion (order_dual.to_dual ∘
      (intermediate_field.fixing_subgroup : intermediate_field F E → subgroup (E ≃ₐ[F] E)))
    ((intermediate_field.fixed_field : subgroup (E ≃ₐ[F] E) → intermediate_field F E) ∘
      order_dual.to_dual) :=
{ choice := λ H _, intermediate_field.fixed_field H,
  gc := λ K H, (intermediate_field.le_iff_le H K).symm,
  u_l_le := λ K, le_of_eq (fixed_field_fixing_subgroup K),
  choice_eq := λ H _, rfl }

end is_galois

end galois_correspondence

section galois_equivalent_definitions

variables (F : Type*) [field F] (E : Type*) [field E] [algebra F E]

namespace is_galois

lemma is_separable_splitting_field [finite_dimensional F E] [is_galois F E] :
  ∃ p : F[X], p.separable ∧ p.is_splitting_field F E :=
begin
  cases field.exists_primitive_element F E with α h1,
  use [minpoly F α, separable F α, is_galois.splits F α],
  rw [eq_top_iff, ←intermediate_field.top_to_subalgebra, ←h1],
  rw intermediate_field.adjoin_simple_to_subalgebra_of_integral F α (integral F α),
  apply algebra.adjoin_mono,
  rw [set.singleton_subset_iff, finset.mem_coe, multiset.mem_to_finset, polynomial.mem_roots],
  { dsimp only [polynomial.is_root],
    rw [polynomial.eval_map, ←polynomial.aeval_def],
    exact minpoly.aeval _ _ },
  { exact polynomial.map_ne_zero (minpoly.ne_zero (integral F α)) }
end

lemma of_fixed_field_eq_bot [finite_dimensional F E]
  (h : intermediate_field.fixed_field (⊤ : subgroup (E ≃ₐ[F] E)) = ⊥) : is_galois F E :=
begin
  rw [←is_galois_iff_is_galois_bot, ←h],
  classical,
  exact is_galois.of_fixed_field E (⊤ : subgroup (E ≃ₐ[F] E)),
end

lemma of_card_aut_eq_finrank [finite_dimensional F E]
  (h : fintype.card (E ≃ₐ[F] E) = finrank F E) : is_galois F E :=
begin
  apply of_fixed_field_eq_bot,
  have p : 0 < finrank (intermediate_field.fixed_field (⊤ : subgroup (E ≃ₐ[F] E))) E := finrank_pos,
  classical,
  rw [←intermediate_field.finrank_eq_one_iff, ←mul_left_inj' (ne_of_lt p).symm, finrank_mul_finrank,
      ←h, one_mul, intermediate_field.finrank_fixed_field_eq_card],
  apply fintype.card_congr,
  exact { to_fun := λ g, ⟨g, subgroup.mem_top g⟩, inv_fun := coe,
          left_inv := λ g, rfl, right_inv := λ _, by { ext, refl } },
end

variables {F} {E} {p : F[X]}

lemma of_separable_splitting_field_aux [hFE : finite_dimensional F E]
  [sp : p.is_splitting_field F E] (hp : p.separable) (K : intermediate_field F E) {x : E}
  (hx : x ∈ (p.map (algebra_map F E)).roots) :
  fintype.card ((↑K⟮x⟯ : intermediate_field F E) →ₐ[F] E) =
    fintype.card (K →ₐ[F] E) * finrank K K⟮x⟯ :=
begin
  have h : is_integral K x := is_integral_of_is_scalar_tower x
    (is_integral_of_noetherian (is_noetherian.iff_fg.2 hFE) x),
  have h1 : p ≠ 0 := λ hp, by rwa [hp, polynomial.map_zero, polynomial.roots_zero] at hx,
  have h2 : (minpoly K x) ∣ p.map (algebra_map F K),
  { apply minpoly.dvd,
    rw [polynomial.aeval_def, polynomial.eval₂_map, ←polynomial.eval_map],
    exact (polynomial.mem_roots (polynomial.map_ne_zero h1)).mp hx },
  let key_equiv : ((↑K⟮x⟯ : intermediate_field F E) →ₐ[F] E) ≃ Σ (f : K →ₐ[F] E),
    @alg_hom K K⟮x⟯ E _ _ _ _ (ring_hom.to_algebra f) :=
  equiv.trans (alg_equiv.arrow_congr (intermediate_field.lift2_alg_equiv K⟮x⟯) (alg_equiv.refl))
    alg_hom_equiv_sigma,
  haveI : Π (f : K →ₐ[F] E), fintype (@alg_hom K K⟮x⟯ E _ _ _ _ (ring_hom.to_algebra f)) := λ f, by
  { apply fintype.of_injective (sigma.mk f) (λ _ _ H, eq_of_heq ((sigma.mk.inj H).2)),
    exact fintype.of_equiv _ key_equiv },
  rw [fintype.card_congr key_equiv, fintype.card_sigma, intermediate_field.adjoin.finrank h],
  apply finset.sum_const_nat,
  intros f hf,
  rw ← @intermediate_field.card_alg_hom_adjoin_integral K _ E _ _ x E _ (ring_hom.to_algebra f) h,
  { apply fintype.card_congr, refl },
  { exact polynomial.separable.of_dvd ((polynomial.separable_map (algebra_map F K)).mpr hp) h2 },
  { refine polynomial.splits_of_splits_of_dvd _ (polynomial.map_ne_zero h1) _ h2,
    rw [polynomial.splits_map_iff, ←is_scalar_tower.algebra_map_eq],
    exact sp.splits },
end

lemma of_separable_splitting_field [sp : p.is_splitting_field F E] (hp : p.separable) :
  is_galois F E :=
begin
  haveI hFE : finite_dimensional F E := polynomial.is_splitting_field.finite_dimensional E p,
  letI := classical.dec_eq E,
  let s := (p.map (algebra_map F E)).roots.to_finset,
  have adjoin_root : intermediate_field.adjoin F ↑s = ⊤,
  { apply intermediate_field.to_subalgebra_injective,
    rw [intermediate_field.top_to_subalgebra, ←top_le_iff, ←sp.adjoin_roots],
    apply intermediate_field.algebra_adjoin_le_adjoin, },
  let P : intermediate_field F E → Prop := λ K, fintype.card (K →ₐ[F] E) = finrank F K,
  suffices : P (intermediate_field.adjoin F ↑s),
  { rw adjoin_root at this,
    apply of_card_aut_eq_finrank,
    rw ← eq.trans this (linear_equiv.finrank_eq intermediate_field.top_equiv.to_linear_equiv),
    exact fintype.card_congr (equiv.trans (alg_equiv_equiv_alg_hom F E)
      (alg_equiv.arrow_congr intermediate_field.top_equiv.symm alg_equiv.refl)) },
  apply intermediate_field.induction_on_adjoin_finset s P,
  { have key := intermediate_field.card_alg_hom_adjoin_integral F
      (show is_integral F (0 : E), by exact is_integral_zero),
    rw [minpoly.zero, polynomial.nat_degree_X] at key,
    specialize key polynomial.separable_X (polynomial.splits_X (algebra_map F E)),
    rw [←@subalgebra.finrank_bot F E _ _ _, ←intermediate_field.bot_to_subalgebra] at key,
    refine eq.trans _ key,
    apply fintype.card_congr,
    rw intermediate_field.adjoin_zero },
  intros K x hx hK,
  simp only [P] at *,
  rw [of_separable_splitting_field_aux hp K (multiset.mem_to_finset.mp hx),
    hK, finrank_mul_finrank],
  symmetry,
  exact linear_equiv.finrank_eq (alg_equiv.to_linear_equiv (intermediate_field.lift2_alg_equiv _))
end

/--Equivalent characterizations of a Galois extension of finite degree-/
theorem tfae [finite_dimensional F E] :
  tfae [is_galois F E,
    intermediate_field.fixed_field (⊤ : subgroup (E ≃ₐ[F] E)) = ⊥,
    fintype.card (E ≃ₐ[F] E) = finrank F E,
    ∃ p : F[X], p.separable ∧ p.is_splitting_field F E] :=
begin
  tfae_have : 1 → 2,
  { exact λ h, order_iso.map_bot (@intermediate_field_equiv_subgroup F _ E _ _ _ h).symm },
  tfae_have : 1 → 3,
  { introI _, exact card_aut_eq_finrank F E },
  tfae_have : 1 → 4,
  { introI _, exact is_separable_splitting_field F E },
  tfae_have : 2 → 1,
  { exact of_fixed_field_eq_bot F E },
  tfae_have : 3 → 1,
  { exact of_card_aut_eq_finrank F E },
  tfae_have : 4 → 1,
  { rintros ⟨h, hp1, _⟩, exactI of_separable_splitting_field hp1 },
  tfae_finish,
end

end is_galois

end galois_equivalent_definitions