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

Here we define an inductive type of nonempty lists, and subtypes
of lists with specified starting and ending points.  These can be
used for paths in a graph, or a more constructive approach to
the equivalence relation generated by an arbitrary relation,
or for ordered simplices in a simplicial complex, for example.

An alternative approach would be to define
`(pos_list α) := (list α) × α`.  That might be better.

-/

import data.list.basic

inductive pos_list (α : Type) : Type
| const : α → pos_list
| cons : α → pos_list → pos_list

namespace pos_list

variable {α : Type}
variables (p q r : pos_list α)

def steps : pos_list α → list (α × α)
| (const a) := list.nil
| (cons a (const b)) := [⟨a,b⟩]
| (cons a (cons b p)) := ⟨a,b⟩ :: (cons b p).steps

def length : pos_list α → ℕ
| (const a) := 0
| (cons a p) := p.length.succ

lemma steps_length : ∀ p : pos_list α, p.steps.length = p.length
| (const a) := rfl
| (cons a (const b)) := rfl
| (cons a (cons b p)) := by {
    rw[steps,length,← steps_length (cons b p),list.length],
  }

def to_list : pos_list α → list α
| (const a) := [a]
| (cons a p) := list.cons a (to_list p)

lemma to_list_length : ∀ p : pos_list α, p.to_list.length = p.length.succ
| (const a) := rfl
| (cons a p) := by {rw[to_list,length,list.length,p.to_list_length],}

def head : pos_list α → α
| (const a) := a
| (cons a p) := a

def foot : pos_list α → α
| (const a) := a
| (cons a p) := p.foot

def append : pos_list α → pos_list α → pos_list α
| (const a) q := cons a q
| (cons a p) q := cons a (append p q)

lemma head_append : ∀ (p q : pos_list α),
 head (append p q) = head p
| (const a) q := rfl
| (cons a p) q := rfl

lemma foot_append : ∀ (p q : pos_list α),
 foot (append p q) = foot q
| (const a) q := rfl
| (cons a p) q := foot_append p q

lemma append_assoc : ∀ (p q r : pos_list α),
 append (append p q) r = append p (append q r)
| (const a) q r := rfl
| (cons a p) q r := by {dsimp[append],rw[append_assoc p q r],}

lemma length_append : ∀ (p q : pos_list α),
 length (append p q) = p.length + q.length + 1
| (const a) q := by {rw[append,length,length,zero_add],}
| (cons a p) q := by {
    rw[append,length,length,length_append p q,← nat.add_one,← nat.add_one],
    rw[add_assoc p.length 1 q.length,add_comm 1 q.length],
    repeat { rw[add_assoc] },
  }

lemma steps_cons : ∀ (a : α) (p : pos_list α),
 steps (cons a p) = ⟨a,p.head⟩ :: p.steps
| a (const b) := rfl
| a (cons b p) := rfl

lemma steps_append : ∀ (p q : pos_list α) ,
 steps (append p q) = p.steps ++ (⟨p.foot,q.head⟩ :: q.steps)
| (const a) q := by {rw[append,steps,foot,steps_cons],refl}
| (cons a p) q := by {
    rw[append,steps_cons,steps_cons,foot,head_append],
    rw[steps_append p q,list.cons_append],repeat {rw[list.append_assoc]},
}

def reverse : pos_list α → pos_list α
| (const a) := const a
| (cons a p) := p.reverse.append (const a)

lemma head_reverse : ∀ (p : pos_list α), p.reverse.head = p.foot
| (const a) := rfl
| (cons a p) := by {dsimp[reverse,foot],rw[head_append,head_reverse p],}

lemma foot_reverse : ∀ (p : pos_list α), p.reverse.foot = p.head
| (const a) := rfl
| (cons a p) := by {dsimp[reverse,head],rw[foot_append],refl,}

lemma reverse_append : ∀ (p q : pos_list α),
 reverse (append p q) = append (reverse q) (reverse p)
| (const a) q := rfl
| (cons a p) q := by {dsimp[append,reverse],rw[reverse_append p q,append_assoc],}

lemma reverse_reverse : ∀ (p : pos_list α), p.reverse.reverse = p
| (const a) := rfl
| (cons a p) := begin
 dsimp[reverse],rw[reverse_append,reverse_reverse p],refl,
end

lemma length_reverse : ∀ (p : pos_list α), p.reverse.length = p.length
| (const a) := rfl
| (cons a p) := by {
    rw[reverse,length_append,length,length,length_reverse p],
    rw[← nat.add_one,add_zero (length p)],
}

def swap : (α × α) → (α × α)
| ⟨a,b⟩ := ⟨b,a⟩

lemma steps_reverse : ∀ (p : pos_list α),
 p.reverse.steps = (p.steps.map swap).reverse
| (const a) := rfl
| (cons a p) := by {
 rw[reverse,steps_append,steps_reverse p,foot_reverse,head,steps],
 rw[steps_cons,list.map,swap,list.reverse_cons],
}

def all (r : α → Prop) : pos_list α → Prop
| (const a) := r a
| (cons a p) := (r a) ∧ (all p)

def chain (r : α → α → Prop) : pos_list α → Prop
| (const a) := true
| (cons a (const b)) := r a b
| (cons a (cons b p)) := (r a b) ∧ (chain (cons b p))

def pairwise (r : α → α → Prop) : pos_list α → Prop
| (const a) := true
| (cons a p) := (all (r a) p) ∧ (pairwise p)

def splice0 : ∀ (p q : pos_list α), pos_list α
| (const a) q := q
| (cons a p) q := cons a (splice0 p q)

lemma length_splice0 : ∀ (p q : pos_list α),
 (splice0 p q).length = p.length + q.length
| (const a) q := by {rw[splice0,length,zero_add],}
| (cons a p) q := by {
    rw[splice0,length,length,length_splice0 p q,← nat.add_one,← nat.add_one],
    rw[add_assoc,add_assoc,add_comm 1],
}

lemma head_splice0 : ∀ (p q : pos_list α) (e : p.foot = q.head),
 (splice0 p q).head = p.head
| (const a) q e := e.symm
| (cons a p) q e := rfl

lemma foot_splice0 : ∀ (p q : pos_list α),
 foot (splice0 p q) = q.foot
| (const a) q := rfl
| (cons a p) q := foot_splice0 p q

lemma splice0_cons_append : ∀ (p : pos_list α) (b : α) (q : pos_list α) (e : p.foot = b),
 splice0 p (cons b q) = append p q
| (const a) b q e := by {rw[splice0,append,← e],refl}
| (cons a p) b q e := by {rw[splice0,append,splice0_cons_append p b q e],}

lemma const_splice0 (a : α) (q : pos_list α) :
 splice0 (const a) q = q := rfl

lemma splice0_const : ∀ (p : pos_list α) (b : α) (e : p.foot = b),
 splice0 p (const b) = p
| (const a) b e := by {rw[splice0],congr,exact e.symm}
| (cons a p) b e := by {rw[splice0,splice0_const p b e],}

lemma splice0_append : ∀ (p q r : pos_list α),
 splice0 p (append q r) = append (splice0 p q) r
| (const a) q r := rfl
| (cons a p) q r := by {rw[splice0,splice0,append,splice0_append p q r],}

lemma splice0_assoc : ∀ (p q r : pos_list α),
 splice0 (splice0 p q) r = splice0 p (splice0 q r)
| (const a) q r := rfl
| (cons a p) q r := by {rw[splice0,splice0,splice0,splice0_assoc p q r],}

lemma steps_splice0 : ∀ (p q : pos_list α) (e : p.foot = q.head),
 (splice0 p q).steps = p.steps ++ q.steps
| (const a) q e := by {rw[splice0,steps],refl}
| (cons a p) q e := by {
    change p.foot = q.head at e,
    rw[splice0,steps_cons,steps_cons,steps_splice0 p q e,list.cons_append,head_splice0],
    exact e
  }

lemma reverse_splice0 : ∀ (p q : pos_list α) (e : p.foot = q.head),
 (splice0 p q).reverse = splice0 q.reverse p.reverse
| (const a) q e := by {
    rw[reverse,splice0,splice0_const q.reverse a (q.foot_reverse.trans e.symm)],
  }
| (cons a p) q e := by {
    rw[splice0,reverse,reverse_splice0 p q e,reverse,splice0_append],
  }

def list_between (a b : α) : Type* :=
 { p : pos_list α // p.head = a ∧ p.foot = b }

namespace list_between

def const (a : α) : list_between a a := ⟨pos_list.const a,⟨rfl,rfl⟩⟩

def reverse {a b : α} (p : list_between a b) : list_between b a :=
 ⟨p.val.reverse,⟨p.val.head_reverse.trans p.property.right,
                p.val.foot_reverse.trans p.property.left⟩⟩

def match_eq {a b c : α} (p : list_between a b) (q : list_between b c) :
 p.val.foot = q.val.head := p.property.right.trans q.property.left.symm

def splice {a b c : α} (p : list_between a b) (q : list_between b c) :
 (list_between a c) := ⟨splice0 p.val q.val,begin
   rw[head_splice0 p.val q.val (match_eq p q),foot_splice0],
   exact ⟨p.property.left,q.property.right⟩
  end⟩

def length {a b : α} (p : list_between a b) : ℕ := p.val.length

lemma length_const (a : α) : (const a).length = 0 := rfl

lemma length_reverse {a b : α} (p : list_between a b) :
 p.reverse.length = p.length :=
  p.val.length_reverse

lemma length_splice {a b c : α} (p : list_between a b) (q : list_between b c) :
 (splice p q).length = p.length + q.length :=
  pos_list.length_splice0 p.val q.val

lemma const_splice {a b : α} (p : list_between a b) :
 splice (const a) p = p :=
  subtype.eq (const_splice0 a p.val)

lemma splice_const {a b : α} (p : list_between a b) :
 splice p (const b) = p :=
  subtype.eq (splice0_const p.val b p.property.right)

lemma reverse_splice {a b c : α} (p : list_between a b) (q : list_between b c) :
 (splice p q).reverse = splice q.reverse p.reverse :=
  subtype.eq (reverse_splice0 p.val q.val (match_eq p q))

lemma splice_assoc {a b c d : α}
 (p : list_between a b) (q : list_between b c) (r : list_between c d) :
  splice (splice p q) r = splice p (splice q r) :=
   subtype.eq (splice0_assoc p.val q.val r.val)

end list_between

end pos_list


/-
A formalization of Hao Huang's sensitivity theorem: in the hypercube of
dimension n ≥ 1, if one colors more than half the vertices then at least one
vertex has at least √n colored neighbors.

A fun summer collaboration by
Reid Barton, Johan Commelin, Jesse Han, Chris Hughes, Rob Lewis, and Patrick Massot,
based on Don Knuth's account of the story
(https://www.cs.stanford.edu/~knuth/papers/huang.pdf),
using the Lean theorem prover (http://leanprover.github.io/),
by Leonardo de Moura at Microsoft Research, and his collaborators
(https://leanprover.github.io/people/),
and using Lean's user maintained mathematics library
(https://github.com/leanprover-community/mathlib).
-/
import tactic.fin_cases
import tactic.apply_fun
import linear_algebra.finite_dimensional
import analysis.normed_space.basic
import for_mathlib

-- The next three lines assert we do not want to give a constructive proof,
-- but rather use classical logic.
noncomputable theory
local attribute [instance, priority 1] classical.prop_decidable
local attribute [instance, priority 0] set.decidable_mem_of_fintype

notation `|`x`|` := abs x
notation `√` := real.sqrt

open function bool linear_map fintype finite_dimensional dual_pair

/- -------------------------------------------------------------------------\
|  The hypercube.                                                           |
\---------------------------------------------------------------------------/

/-
Notations:
ℕ denotes natural numbers (including zero).
fin n = {0, ⋯ , n - 1}.
bool = {tt, ff}.
-/

/-- The hypercube in dimension n. -/
def Q (n : ℕ) := fin n → bool

/-- The projection from Q (n + 1) to Q n forgetting the first value
(ie. the image of zero). -/
def π {n : ℕ} : Q (n + 1) → Q n := λ p, p ∘ fin.succ

namespace Q
-- n will always denote a natural number.
variable (n : ℕ)

/-- Q n is not empty -/
instance : inhabited (Q n) := ⟨λ i, tt⟩

/-- Q 0 has a unique element. -/
instance : unique (Q 0) :=
⟨⟨λ _, tt⟩, by { intro, ext x, fin_cases x }⟩

/-- Q n is finite. -/
instance : fintype (Q n) := by delta Q; apply_instance

/-- Q n has 2^n elements. -/
lemma card : card (Q n) = 2^n :=
by simp [Q]

/-- The ℝ-module structure on functions from Q n to ℝ (with finite support). -/
instance coeffs_module (n) : module ℝ (Q n →₀ ℝ) := finsupp.module (Q n) ℝ

-- Until the end of this namespace, n will be an implicit argument (still
-- a natural number).
variable {n}

lemma succ_n_eq (p q : Q (n+1)) : p = q ↔ (p 0 = q 0 ∧ π p = π q) :=
begin
  split,
  { intro h, rw h, exact ⟨rfl, rfl⟩, },
  { rintros ⟨h₀, h⟩,
    ext x,
    by_cases hx : x = 0,
    { rwa hx },
    { rw ← fin.succ_pred x hx,
      convert congr_fun h (fin.pred x hx) } }
end

/-- The adjacency relation defining the graph structure on Q n:
p.adjacent q if there is an edge from p to q in Q n -/
def adjacent {n : ℕ} (p : Q n) : set (Q n) := λ q, ∃! i, p i ≠ q i

/-- In Q 0, no two vertices are adjacent. -/
lemma not_adjacent_zero (p q : Q 0) : ¬ p.adjacent q :=
by rintros ⟨v, _⟩; apply fin_zero_elim v

/-- If p and q in Q (n+1) have different values at zero then they are adjacent
iff their projections to Q n are equal. -/
lemma adj_succ_of_zero_neq {p q : Q (n+1)} (h₀ : p 0 ≠ q 0) :
  p.adjacent q ↔ π p = π q :=
begin
  split,
  { rintros ⟨i, h_eq, h_uni⟩,
    ext x, by_contradiction hx,
    apply fin.succ_ne_zero x,
    rw [h_uni _ hx, h_uni _ h₀] },
    { intro heq,
    use [0, h₀],
    intros y hy,
    contrapose! hy,
    rw ←fin.succ_pred _ hy,
    apply congr_fun heq }
end

/-- If p and q in Q (n+1) have the same value at zero then they are adjacent
iff their projections to Q n are adjacent. -/
lemma adj_succ_of_zero_eq {p q : Q (n+1)} (h₀ : p 0 = q 0) :
  p.adjacent q ↔ (π p).adjacent (π q) :=
begin
  split,
  { rintros ⟨i, h_eq, h_uni⟩,
    have h_i : i ≠ 0, from λ h_i, absurd h₀ (by rwa h_i at h_eq),
    use [i.pred h_i,
         show p (fin.succ (fin.pred i _)) ≠ q (fin.succ (fin.pred i _)),
           by rwa fin.succ_pred],
    intros y hy,
    simp [eq.symm (h_uni _ hy)] },
  { rintros ⟨i, h_eq, h_uni⟩,
    use [i.succ, h_eq],
    intros y hy,
    rw [←fin.pred_inj, fin.pred_succ],
    { apply h_uni,
      change p (fin.pred _ _).succ ≠ q (fin.pred _ _).succ,
      simp [hy] },
    { contrapose! hy,
      rw [hy, h₀] },
    { apply fin.succ_ne_zero } }
end

@[symm] lemma adjacent.symm {p q : Q n} : p.adjacent q ↔ q.adjacent p :=
by simp only [adjacent, ne_comm]

end Q

/- -------------------------------------------------------------------------\
|  The vector space.                                                        |
\---------------------------------------------------------------------------/

/-- The free vector space on vertices of a hypercube, defined inductively. -/
def V : ℕ → Type
| 0 := ℝ
| (n+1) := V n × V n

namespace V
variables (n : ℕ)

-- V n is a real vector space whose equality relation is computable.

instance : decidable_eq (V n) :=
by { induction n ; { dunfold V, resetI, apply_instance } }

instance : add_comm_group (V n) :=
by { induction n ; { dunfold V, resetI, apply_instance } }

instance : vector_space ℝ (V n) :=
by { induction n ; { dunfold V, resetI, apply_instance } }

-- The next five definitions are short circuits helping Lean to quickly find
-- relevant structures on V n
def module : module ℝ (V n) := by apply_instance
def add_comm_semigroup : add_comm_semigroup (V n) := by apply_instance
def add_comm_monoid : add_comm_monoid (V n) := by apply_instance
def has_scalar : has_scalar ℝ (V n) := by apply_instance
def has_add : has_add (V n) := by apply_instance

end V

local attribute [instance, priority 100000]
  V.module V.add_comm_semigroup V.add_comm_monoid V.has_scalar V.has_add

/-- The basis of V indexed by the hypercube, defined inductively. -/
noncomputable def e : Π {n}, Q n → V n
| 0     := λ _, (1:ℝ)
| (n+1) := λ x, cond (x 0) (e (π x), 0) (0, e (π x))

@[simp] lemma e_zero_apply (x : Q 0) : e x = (1 : ℝ) := rfl

/-- The dual basis to e, defined inductively. -/
noncomputable def ε : Π {n : ℕ} (p : Q n), V n →ₗ[ℝ] ℝ
| 0 _ := linear_map.id
| (n+1) p := cond (p 0) ((ε $ π p).comp $ linear_map.fst _ _ _) ((ε $ π p).comp $ linear_map.snd _ _ _)

variable {n : ℕ}

lemma duality (p q : Q n) : ε p (e q) = if p = q then 1 else 0 :=
begin
  induction n with n IH,
  { rw (show p = q, from subsingleton.elim p q),
    dsimp [ε, e],
    simp },
  { dsimp [ε, e],
    cases hp : p 0 ; cases hq : q 0,
    all_goals {
      repeat {rw cond_tt},
      repeat {rw cond_ff},
      simp only [linear_map.fst_apply, linear_map.snd_apply, linear_map.comp_apply, IH],
      try { congr' 1, rw Q.succ_n_eq, finish },
      try {
        erw (ε _).map_zero,
        have : p ≠ q, { intro h, rw p.succ_n_eq q at h, finish },
        simp [this] } } }
end

/-- Any vector in V n annihilated by all ε p's is zero. -/
lemma epsilon_total {v : V n} (h : ∀ p : Q n, (ε p) v = 0) : v = 0 :=
begin
  induction n with n ih,
  { dsimp [ε] at h, exact h (λ _, tt) },
  { cases v with v₁ v₂,
    ext ; change _ = (0 : V n) ; simp only [] ; apply ih ; intro p ;
    [ let q : Q (n+1) := λ i, if h : i = 0 then tt else p (i.pred h),
      let q : Q (n+1) := λ i, if h : i = 0 then ff else p (i.pred h)],
    all_goals {
      specialize h q,
      rw [ε, show q 0 = tt, from rfl, cond_tt] at h <|> rw [ε, show q 0 = ff, from rfl, cond_ff] at h,
      rwa show p = π q, by { ext, simp [q, fin.succ_ne_zero, π] } } }
end

/-- e and ε are dual families of vectors. It implies that e is indeed a basis
and ε computes coefficients of decompositions of vectors on that basis. -/
def dual_pair_e_ε (n : ℕ) : dual_pair (@e n) (@ε n) :=
{ eval := duality,
  total := @epsilon_total _ }

-- We will now derive the dimension of V, first as a cardinal in dim_V and,
-- since this cardinal is finite, as a natural number in findim_V

lemma dim_V : vector_space.dim ℝ (V n) = 2^n :=
have vector_space.dim ℝ (V n) = ↑(2^n : ℕ),
  by convert dim_eq_card (dual_pair_e_ε _).is_basis using 1; rw Q.card,
by assumption_mod_cast

instance : finite_dimensional ℝ (V n) :=
fin_dim_of_finite_basis (dual_pair_e_ε _).is_basis

-- TODO: fix this in mathlib
local attribute [-elim_cast] cardinal.nat_cast_pow
local attribute [move_cast] cardinal.nat_cast_pow

lemma findim_V : findim ℝ (V n) = 2^n :=
have _ := @dim_V n,
by rw ←findim_eq_dim at this; assumption_mod_cast

/- -------------------------------------------------------------------------\
|  The linear map.                                                          |
\---------------------------------------------------------------------------/

/-- The linear operator f_n corresponding to Huang's matrix A_n,
defined inductively as a ℝ-linear map from V n to V n. -/
noncomputable def f : Π n, V n →ₗ[ℝ] V n
| 0 := 0
| (n+1) := linear_map.pair
             (linear_map.copair (f n) linear_map.id)
             (linear_map.copair linear_map.id (-f n))

-- The preceding definition use linear map constructions to automatically
-- get that f is linear, but its values are somewhat buried as a side-effect.
-- The next two lemmas unbury them.

@[simp] lemma f_zero : f 0 = 0 := rfl

lemma f_succ_apply (v : V (n+1)) :
  (f (n+1) : V (n+1) → V (n+1)) v = (f n v.1 + v.2, v.1 - f n v.2) :=
begin
  cases v,
  rw f,
  simp only [linear_map.id_apply, linear_map.pair_apply, prod.mk.inj_iff,
    linear_map.neg_apply, sub_eq_add_neg, linear_map.copair_apply],
  exact ⟨rfl, rfl⟩
end

-- In the next statement, the explicit conversion (n : ℝ) of n to a real number
-- is necessary since otherwise `n • v` refers to the multiplication defined
-- using only the addition of V.

lemma f_squared : ∀ v : V n, (f n) (f n v) = (n : ℝ) • v :=
begin
  induction n with n IH; intro,
  { simpa only [nat.cast_zero, zero_smul] },
  { cases v, simp [f_succ_apply, IH, add_smul] }
end

-- We now compute the matrix of f in the e basis (p is the line index,
-- q the column index.)

lemma f_matrix :
  ∀ p q : Q n, |ε q (f n (e p))| = if q.adjacent p then 1 else 0 :=
begin
  induction n with n IH,
  { intros p q,
    dsimp [f],
    simp [Q.not_adjacent_zero] },
  { intros p q,
    have ite_nonneg : ite (π q = π p) (1 : ℝ) 0 ≥ 0,
    { split_ifs ; norm_num },
    have f_map_zero := (show linear_map ℝ (V (n+0)) (V n), from f n).map_zero,
    dsimp [e, ε, f], cases hp : p 0 ; cases hq : q 0,
    all_goals
    { repeat {rw cond_tt}, repeat {rw cond_ff},
      simp [f_map_zero, hp, hq, IH, duality, abs_of_nonneg ite_nonneg, Q.adj_succ_of_zero_neq,
            Q.adj_succ_of_zero_eq],
      congr' 1 } }
end

/-- The linear operator g_m corresponding to Knuth's matrix B_m. -/
noncomputable def g (m : ℕ) : V m →ₗ[ℝ] V (m+1) :=
linear_map.pair (f m + √(m+1) • linear_map.id) linear_map.id

-- in the following lemmas, m will denote a natural number
variables {m : ℕ}

-- again we unpack what are the values of g
lemma g_apply : ∀ v, g m v = (f m v + √(m+1) • v, v) :=
by delta g; simp

lemma g_injective : injective (g m) :=
begin
  rw g,
  intros x₁ x₂ h,
  simp only [linear_map.pair_apply, linear_map.id_apply, prod.mk.inj_iff] at h,
  exact h.right
end

lemma f_image_g (w : V (m + 1)) (hv : ∃ v, g m v = w) :
  (f (m + 1) : _) w = √(m + 1) • w :=
begin
  rcases hv with ⟨v, rfl⟩,
  have : √(m+1) * √(m+1) = m+1 :=
    real.mul_self_sqrt (by exact_mod_cast zero_le _),
  simp [-add_comm, this, f_succ_apply, g_apply, f_squared, smul_add, add_smul, smul_smul],
end

/- -------------------------------------------------------------------------\
|  The main proof.                                                          |
\---------------------------------------------------------------------------/

-- In this section, in order to enforce that n is positive, we write it as
-- m + 1 for some natural number m.

-- dim X will denote the dimension of a subspace X as a cardinal
notation `dim` X:70 := vector_space.dim ℝ ↥X
-- fdim X will denote the (finite) dimension of a subspace X as a natural number
notation `fdim` := findim ℝ

-- Span S will denote the ℝ-subspace spanned by S
notation `Span` := submodule.span ℝ

-- Card X will denote the cardinal of a subset of a finite type, as a
-- natural number.
notation `Card` X:70 := X.to_finset.card

-- In the following, ⊓ and ⊔ will denote intersection and sums of ℝ-subspaces,
-- equipped with their subspace structures. The notations come from the general
-- theory of lattices, with inf and sup (also known as meet and join).

/-- If a subset H of Q (m+1) has cardinal at least 2^m + 1 then the
subspace of V (m+1) spanned by the corresponding basis vectors non-trivially
intersects the range of g m. -/
lemma exists_eigenvalue (H : set (Q (m + 1))) (hH : Card H ≥ 2^m + 1) :
  ∃ y ∈ Span (e '' H) ⊓ (g m).range, y ≠ (0 : _) :=
begin
  let W := Span (e '' H),
  let img := (g m).range,
  suffices : 0 < dim (W ⊓ img),
  { simp only [exists_prop],
    exact_mod_cast exists_mem_ne_zero_of_dim_pos this },
  have dim_le : dim (W ⊔ img) ≤ 2^(m + 1),
  { convert ← dim_submodule_le (W ⊔ img),
    apply dim_V },
  have dim_add : dim (W ⊔ img) + dim (W ⊓ img) = dim W + 2^m,
  { convert ← dim_sup_add_dim_inf_eq W img,
    rw ← dim_eq_injective (g m) g_injective,
    apply dim_V },
  have dimW : dim W = card H,
  { have li : linear_independent ℝ (restrict e H) :=
      linear_independent.comp (dual_pair_e_ε _).is_basis.1 _ subtype.val_injective,
    have hdW := dim_span li,
    rw set.range_restrict at hdW,
    convert hdW,
    rw [cardinal.mk_image_eq ((dual_pair_e_ε _).is_basis.injective zero_ne_one), cardinal.fintype_card] },
  rw ← findim_eq_dim ℝ at ⊢ dim_le dim_add dimW,
  rw [← findim_eq_dim ℝ, ← findim_eq_dim ℝ] at dim_add,
  norm_cast at ⊢ dim_le dim_add dimW,
  rw nat.pow_succ at dim_le,
  rw set.to_finset_card at hH,
  linarith
end

theorem huang_degree_theorem (H : set (Q (m + 1))) (hH : Card H ≥ 2^m + 1) :
  ∃ q, q ∈ H ∧ √(m + 1) ≤ Card (H ∩ q.adjacent) :=
begin
  rcases exists_eigenvalue H hH with ⟨y, ⟨⟨y_mem_H, y_mem_g⟩, y_ne⟩⟩,
  have coeffs_support : ((dual_pair_e_ε (m+1)).coeffs y).support ⊆ H.to_finset,
  { intros p p_in,
    rw finsupp.mem_support_iff at p_in,
    rw set.mem_to_finset,
    exact (dual_pair_e_ε _).mem_of_mem_span y_mem_H p p_in },
  obtain ⟨q, H_max⟩ : ∃ q : Q (m+1), ∀ q' : Q (m+1), |(ε q' : _) y| ≤ |ε q y|,
    from fintype.exists_max _,
  have H_q_pos : 0 < |ε q y|,
  { contrapose! y_ne,
    exact epsilon_total (λ p, abs_nonpos_iff.mp (le_trans (H_max p) y_ne)) },
  refine ⟨q, (dual_pair_e_ε _).mem_of_mem_span y_mem_H q (abs_pos_iff.mp H_q_pos), _⟩,
  let s := √(m+1),
  suffices : s * |ε q y| ≤ ↑(_) * |ε q y|,
    from (mul_le_mul_right H_q_pos).mp ‹_›,

  let coeffs := (dual_pair_e_ε (m+1)).coeffs,
  let φ : V (m+1) → V (m+1) := f (m+1),
  calc
    s * (abs (ε q y))
        = abs (ε q (s • y)) : by rw [map_smul, smul_eq_mul, abs_mul, abs_of_nonneg (real.sqrt_nonneg _)]
    ... = abs (ε q (φ y)) : by rw [← f_image_g y (by simpa using y_mem_g)]
    ... = abs (ε q (φ (lc _ (coeffs y)))) : by rw (dual_pair_e_ε _).decomposition y
    ... = abs ((coeffs y).sum (λ (i : Q (m + 1)) (a : ℝ), a • ((ε q) ∘ (f (m + 1)) ∘ λ (i : Q (m + 1)), e i) i)): by
                  { dsimp only [φ],
                    erw [(f $ m+1).map_finsupp_total, (ε q).map_finsupp_total, finsupp.total_apply] ; apply_instance }
    ... ≤ (coeffs y).support.sum (λ p,
           |(coeffs y p) * (ε q $ φ $ e p)| ) : norm_triangle_sum _ $ λ p, coeffs y p * _
    ... = (coeffs y).support.sum (λ p, |coeffs y p| * ite (q.adjacent p) 1 0) : by simp only [abs_mul, f_matrix]
    ... = ((coeffs y).support ∩ (Q.adjacent q).to_finset).sum (λ p, |coeffs y p| ) : finset.sum_ite _ _ _
    ... ≤ ((coeffs y).support ∩ (Q.adjacent q).to_finset).sum (λ p, |coeffs y q| ) : finset.sum_le_sum (λ p _, H_max p)
    ... = (finset.card ((coeffs y).support ∩ (Q.adjacent q).to_finset): ℝ) * |coeffs y q| : by rw [← smul_eq_mul, ← finset.sum_const']
    ... ≤ (finset.card ((H ∩ Q.adjacent q).to_finset )) * |ε q y| :
     (mul_le_mul_right H_q_pos).mpr (by {
             norm_cast,
             exact finset.card_le_of_subset (by rw finset.to_finset_inter ; apply finset.inter_subset_inter_right coeffs_support) })
end


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Mario Carneiro, Yury Kudryashov
-/
import topology.bases
import data.finset.order
import data.set.accumulate

/-!
# Properties of subsets of topological spaces

In this file we define various properties of subsets of a topological space, and some classes on
topological spaces.

## Main definitions

We define the following properties for sets in a topological space:

* `is_compact`: each open cover has a finite subcover. This is defined in mathlib using filters.
  The main property of a compact set is `is_compact.elim_finite_subcover`.
* `is_clopen`: a set that is both open and closed.
* `is_irreducible`: a nonempty set that has contains no non-trivial pair of disjoint opens.
  See also the section below in the module doc.

For each of these definitions (except for `is_clopen`), we also have a class stating that the whole
space satisfies that property:
`compact_space`, `irreducible_space`

Furthermore, we have two more classes:
* `locally_compact_space`: for every point `x`, every open neighborhood of `x` contains a compact
  neighborhood of `x`. The definition is formulated in terms of the neighborhood filter.
* `sigma_compact_space`: a space that is the union of a countably many compact subspaces.

## On the definition of irreducible and connected sets/spaces

In informal mathematics, irreducible spaces are assumed to be nonempty.
We formalise the predicate without that assumption as `is_preirreducible`.
In other words, the only difference is whether the empty space counts as irreducible.
There are good reasons to consider the empty space to be “too simple to be simple”
See also https://ncatlab.org/nlab/show/too+simple+to+be+simple,
and in particular
https://ncatlab.org/nlab/show/too+simple+to+be+simple#relationship_to_biased_definitions.
-/

open set filter classical topological_space
open_locale classical topological_space filter

universes u v
variables {α : Type u} {β : Type v} [topological_space α] {s t : set α}

/- compact sets -/
section compact

/-- A set `s` is compact if for every nontrivial filter `f` that contains `s`,
    there exists `a ∈ s` such that every set of `f` meets every neighborhood of `a`. -/
def is_compact (s : set α) := ∀ ⦃f⦄ [ne_bot f], f ≤ 𝓟 s → ∃a∈s, cluster_pt a f

/-- The complement to a compact set belongs to a filter `f` if it belongs to each filter
`𝓝 a ⊓ f`, `a ∈ s`. -/
lemma is_compact.compl_mem_sets (hs : is_compact s) {f : filter α} (hf : ∀ a ∈ s, sᶜ ∈ 𝓝 a ⊓ f) :
  sᶜ ∈ f :=
begin
  contrapose! hf,
  simp only [not_mem_iff_inf_principal_compl, compl_compl, inf_assoc, ← exists_prop] at hf ⊢,
  exact @hs _ hf inf_le_right
end

/-- The complement to a compact set belongs to a filter `f` if each `a ∈ s` has a neighborhood `t`
within `s` such that `tᶜ` belongs to `f`. -/
lemma is_compact.compl_mem_sets_of_nhds_within (hs : is_compact s) {f : filter α}
  (hf : ∀ a ∈ s, ∃ t ∈ 𝓝[s] a, tᶜ ∈ f) :
  sᶜ ∈ f :=
begin
  refine hs.compl_mem_sets (λ a ha, _),
  rcases hf a ha with ⟨t, ht, hst⟩,
  replace ht := mem_inf_principal.1 ht,
  refine mem_inf_sets.2 ⟨_, ht, _, hst, _⟩,
  rintros x ⟨h₁, h₂⟩ hs,
  exact h₂ (h₁ hs)
end

/-- If `p : set α → Prop` is stable under restriction and union, and each point `x`
  of a compact set `s` has a neighborhood `t` within `s` such that `p t`, then `p s` holds. -/
@[elab_as_eliminator]
lemma is_compact.induction_on {s : set α} (hs : is_compact s) {p : set α → Prop} (he : p ∅)
  (hmono : ∀ ⦃s t⦄, s ⊆ t → p t → p s) (hunion : ∀ ⦃s t⦄, p s → p t → p (s ∪ t))
  (hnhds : ∀ x ∈ s, ∃ t ∈ 𝓝[s] x, p t) :
  p s :=
let f : filter α :=
  { sets := {t | p tᶜ},
    univ_sets := by simpa,
    sets_of_superset := λ t₁ t₂ ht₁ ht, hmono (compl_subset_compl.2 ht) ht₁,
    inter_sets := λ t₁ t₂ ht₁ ht₂, by simp [compl_inter, hunion ht₁ ht₂] } in
have sᶜ ∈ f, from hs.compl_mem_sets_of_nhds_within (by simpa using hnhds),
by simpa

/-- The intersection of a compact set and a closed set is a compact set. -/
lemma is_compact.inter_right (hs : is_compact s) (ht : is_closed t) :
  is_compact (s ∩ t) :=
begin
  introsI f hnf hstf,
  obtain ⟨a, hsa, ha⟩ : ∃ a ∈ s, cluster_pt a f :=
    hs (le_trans hstf (le_principal_iff.2 (inter_subset_left _ _))),
  have : a ∈ t :=
    (ht.mem_of_nhds_within_ne_bot $ ha.mono $
      le_trans hstf (le_principal_iff.2 (inter_subset_right _ _))),
  exact ⟨a, ⟨hsa, this⟩, ha⟩
end

/-- The intersection of a closed set and a compact set is a compact set. -/
lemma is_compact.inter_left (ht : is_compact t) (hs : is_closed s) : is_compact (s ∩ t) :=
inter_comm t s ▸ ht.inter_right hs

/-- The set difference of a compact set and an open set is a compact set. -/
lemma compact_diff (hs : is_compact s) (ht : is_open t) : is_compact (s \ t) :=
hs.inter_right (is_closed_compl_iff.mpr ht)

/-- A closed subset of a compact set is a compact set. -/
lemma compact_of_is_closed_subset (hs : is_compact s) (ht : is_closed t) (h : t ⊆ s) :
  is_compact t :=
inter_eq_self_of_subset_right h ▸ hs.inter_right ht

lemma is_compact.adherence_nhdset {f : filter α}
  (hs : is_compact s) (hf₂ : f ≤ 𝓟 s) (ht₁ : is_open t) (ht₂ : ∀a∈s, cluster_pt a f → a ∈ t) :
  t ∈ f :=
classical.by_cases mem_sets_of_eq_bot $
  assume : f ⊓ 𝓟 tᶜ ≠ ⊥,
  let ⟨a, ha, (hfa : cluster_pt a $ f ⊓ 𝓟 tᶜ)⟩ := @@hs ⟨this⟩ $ inf_le_left_of_le hf₂ in
  have a ∈ t,
    from ht₂ a ha (hfa.of_inf_left),
  have tᶜ ∩ t ∈ 𝓝[tᶜ] a,
    from inter_mem_nhds_within _ (mem_nhds_sets ht₁ this),
  have A : 𝓝[tᶜ] a = ⊥,
    from empty_in_sets_eq_bot.1 $ compl_inter_self t ▸ this,
  have 𝓝[tᶜ] a ≠ ⊥,
    from hfa.of_inf_right.ne,
  absurd A this

lemma compact_iff_ultrafilter_le_nhds :
  is_compact s ↔ (∀f : ultrafilter α, ↑f ≤ 𝓟 s → ∃a∈s, ↑f ≤ 𝓝 a) :=
begin
  refine (forall_ne_bot_le_iff _).trans _,
  { rintro f g hle ⟨a, has, haf⟩,
    exact ⟨a, has, haf.mono hle⟩ },
  { simp only [ultrafilter.cluster_pt_iff] }
end

alias compact_iff_ultrafilter_le_nhds ↔ is_compact.ultrafilter_le_nhds _

/-- For every open directed cover of a compact set, there exists a single element of the
cover which itself includes the set. -/
lemma is_compact.elim_directed_cover {ι : Type v} [hι : nonempty ι] (hs : is_compact s)
  (U : ι → set α) (hUo : ∀i, is_open (U i)) (hsU : s ⊆ ⋃ i, U i) (hdU : directed (⊆) U) :
  ∃ i, s ⊆ U i :=
hι.elim $ λ i₀, is_compact.induction_on hs ⟨i₀, empty_subset _⟩
  (λ s₁ s₂ hs ⟨i, hi⟩, ⟨i, subset.trans hs hi⟩)
  (λ s₁ s₂ ⟨i, hi⟩ ⟨j, hj⟩, let ⟨k, hki, hkj⟩ := hdU i j in
    ⟨k, union_subset (subset.trans hi hki) (subset.trans hj hkj)⟩)
  (λ x hx, let ⟨i, hi⟩ := mem_Union.1 (hsU hx) in
    ⟨U i, mem_nhds_within_of_mem_nhds (mem_nhds_sets (hUo i) hi), i, subset.refl _⟩)

/-- For every open cover of a compact set, there exists a finite subcover. -/
lemma is_compact.elim_finite_subcover {ι : Type v} (hs : is_compact s)
  (U : ι → set α) (hUo : ∀i, is_open (U i)) (hsU : s ⊆ ⋃ i, U i) :
  ∃ t : finset ι, s ⊆ ⋃ i ∈ t, U i :=
hs.elim_directed_cover _ (λ t, is_open_bUnion $ λ i _, hUo i) (Union_eq_Union_finset U ▸ hsU)
  (directed_of_sup $ λ t₁ t₂ h, bUnion_subset_bUnion_left h)

lemma is_compact.elim_nhds_subcover' (hs : is_compact s) (U : Π x ∈ s, set α)
  (hU : ∀ x ∈ s, U x ‹x ∈ s› ∈ 𝓝 x) :
  ∃ t : finset s, s ⊆ ⋃ x ∈ t, U (x : s) x.2 :=
(hs.elim_finite_subcover (λ x : s, interior (U x x.2)) (λ x, is_open_interior)
  (λ x hx, mem_Union.2 ⟨⟨x, hx⟩, mem_interior_iff_mem_nhds.2 $ hU _ _⟩)).imp $ λ t ht,
subset.trans ht $ bUnion_subset_bUnion_right $ λ _ _, interior_subset

lemma is_compact.elim_nhds_subcover (hs : is_compact s) (U : α → set α) (hU : ∀ x ∈ s, U x ∈ 𝓝 x) :
  ∃ t : finset α, (∀ x ∈ t, x ∈ s) ∧ s ⊆ ⋃ x ∈ t, U x :=
let ⟨t, ht⟩ := hs.elim_nhds_subcover' (λ x _, U x) hU
in ⟨t.image coe, λ x hx, let ⟨y, hyt, hyx⟩ := finset.mem_image.1 hx in hyx ▸ y.2,
  by rwa finset.set_bUnion_finset_image⟩

/-- For every family of closed sets whose intersection avoids a compact set,
there exists a finite subfamily whose intersection avoids this compact set. -/
lemma is_compact.elim_finite_subfamily_closed {s : set α} {ι : Type v} (hs : is_compact s)
  (Z : ι → set α) (hZc : ∀i, is_closed (Z i)) (hsZ : s ∩ (⋂ i, Z i) = ∅) :
  ∃ t : finset ι, s ∩ (⋂ i ∈ t, Z i) = ∅ :=
let ⟨t, ht⟩ := hs.elim_finite_subcover (λ i, (Z i)ᶜ) (λ i, (hZc i).is_open_compl)
  (by simpa only [subset_def, not_forall, eq_empty_iff_forall_not_mem, mem_Union,
    exists_prop, mem_inter_eq, not_and, iff_self, mem_Inter, mem_compl_eq] using hsZ)
    in
⟨t, by simpa only [subset_def, not_forall, eq_empty_iff_forall_not_mem, mem_Union,
    exists_prop, mem_inter_eq, not_and, iff_self, mem_Inter, mem_compl_eq] using ht⟩

/-- If `s` is a compact set in a topological space `α` and `f : ι → set α` is a locally finite
family of sets, then `f i ∩ s` is nonempty only for a finitely many `i`. -/
lemma locally_finite.finite_nonempty_inter_compact {ι : Type*} {f : ι → set α}
  (hf : locally_finite f) {s : set α} (hs : is_compact s) :
  finite {i | (f i ∩ s).nonempty} :=
begin
  choose U hxU hUf using hf,
  rcases hs.elim_nhds_subcover U (λ x _, hxU x) with ⟨t, -, hsU⟩,
  refine (t.finite_to_set.bUnion (λ x _, hUf x)).subset _,
  rintro i ⟨x, hx⟩,
  rcases mem_bUnion_iff.1 (hsU hx.2) with ⟨c, hct, hcx⟩,
  exact mem_bUnion hct ⟨x, hx.1, hcx⟩
end

/-- To show that a compact set intersects the intersection of a family of closed sets,
  it is sufficient to show that it intersects every finite subfamily. -/
lemma is_compact.inter_Inter_nonempty {s : set α} {ι : Type v} (hs : is_compact s)
  (Z : ι → set α) (hZc : ∀i, is_closed (Z i)) (hsZ : ∀ t : finset ι, (s ∩ ⋂ i ∈ t, Z i).nonempty) :
  (s ∩ ⋂ i, Z i).nonempty :=
begin
  simp only [← ne_empty_iff_nonempty] at hsZ ⊢,
  apply mt (hs.elim_finite_subfamily_closed Z hZc), push_neg, exact hsZ
end

/-- Cantor's intersection theorem:
the intersection of a directed family of nonempty compact closed sets is nonempty. -/
lemma is_compact.nonempty_Inter_of_directed_nonempty_compact_closed
  {ι : Type v} [hι : nonempty ι] (Z : ι → set α) (hZd : directed (⊇) Z)
  (hZn : ∀ i, (Z i).nonempty) (hZc : ∀ i, is_compact (Z i)) (hZcl : ∀ i, is_closed (Z i)) :
  (⋂ i, Z i).nonempty :=
begin
  apply hι.elim,
  intro i₀,
  let Z' := λ i, Z i ∩ Z i₀,
  suffices : (⋂ i, Z' i).nonempty,
  { exact nonempty.mono (Inter_subset_Inter $ assume i, inter_subset_left (Z i) (Z i₀)) this },
  rw ← ne_empty_iff_nonempty,
  intro H,
  obtain ⟨t, ht⟩ : ∃ (t : finset ι), ((Z i₀) ∩ ⋂ (i ∈ t), Z' i) = ∅,
    from (hZc i₀).elim_finite_subfamily_closed Z'
      (assume i, is_closed_inter (hZcl i) (hZcl i₀)) (by rw [H, inter_empty]),
  obtain ⟨i₁, hi₁⟩ : ∃ i₁ : ι, Z i₁ ⊆ Z i₀ ∧ ∀ i ∈ t, Z i₁ ⊆ Z' i,
  { rcases directed.finset_le hZd t with ⟨i, hi⟩,
    rcases hZd i i₀ with ⟨i₁, hi₁, hi₁₀⟩,
    use [i₁, hi₁₀],
    intros j hj,
    exact subset_inter (subset.trans hi₁ (hi j hj)) hi₁₀ },
  suffices : ((Z i₀) ∩ ⋂ (i ∈ t), Z' i).nonempty,
  { rw ← ne_empty_iff_nonempty at this, contradiction },
  refine nonempty.mono _ (hZn i₁),
  exact subset_inter hi₁.left (subset_bInter hi₁.right)
end

/-- Cantor's intersection theorem for sequences indexed by `ℕ`:
the intersection of a decreasing sequence of nonempty compact closed sets is nonempty. -/
lemma is_compact.nonempty_Inter_of_sequence_nonempty_compact_closed
  (Z : ℕ → set α) (hZd : ∀ i, Z (i+1) ⊆ Z i)
  (hZn : ∀ i, (Z i).nonempty) (hZ0 : is_compact (Z 0)) (hZcl : ∀ i, is_closed (Z i)) :
  (⋂ i, Z i).nonempty :=
have Zmono : _, from @monotone_of_monotone_nat (order_dual _) _ Z hZd,
have hZd : directed (⊇) Z, from directed_of_sup Zmono,
have ∀ i, Z i ⊆ Z 0, from assume i, Zmono $ zero_le i,
have hZc : ∀ i, is_compact (Z i), from assume i, compact_of_is_closed_subset hZ0 (hZcl i) (this i),
is_compact.nonempty_Inter_of_directed_nonempty_compact_closed Z hZd hZn hZc hZcl

/-- For every open cover of a compact set, there exists a finite subcover. -/
lemma is_compact.elim_finite_subcover_image {b : set β} {c : β → set α}
  (hs : is_compact s) (hc₁ : ∀i∈b, is_open (c i)) (hc₂ : s ⊆ ⋃i∈b, c i) :
  ∃b'⊆b, finite b' ∧ s ⊆ ⋃i∈b', c i :=
begin
  rcases hs.elim_finite_subcover (λ i, c i : b → set α) _ _ with ⟨d, hd⟩;
    [skip, simpa using hc₁, simpa using hc₂],
  refine ⟨↑(d.image coe), _, finset.finite_to_set _, _⟩; simp *
end

/-- A set `s` is compact if for every family of closed sets whose intersection avoids `s`,
there exists a finite subfamily whose intersection avoids `s`. -/
theorem compact_of_finite_subfamily_closed
  (h : Π {ι : Type u} (Z : ι → (set α)), (∀ i, is_closed (Z i)) →
    s ∩ (⋂ i, Z i) = ∅ → (∃ (t : finset ι), s ∩ (⋂ i ∈ t, Z i) = ∅)) :
  is_compact s :=
assume f hfn hfs, classical.by_contradiction $ assume : ¬ (∃x∈s, cluster_pt x f),
  have hf : ∀x∈s, 𝓝 x ⊓ f = ⊥,
    by simpa only [cluster_pt, not_exists, not_not, ne_bot_iff],
  have ¬ ∃x∈s, ∀t∈f.sets, x ∈ closure t,
    from assume ⟨x, hxs, hx⟩,
    have ∅ ∈ 𝓝 x ⊓ f, by rw [empty_in_sets_eq_bot, hf x hxs],
    let ⟨t₁, ht₁, t₂, ht₂, ht⟩ := by rw [mem_inf_sets] at this; exact this in
    have ∅ ∈ 𝓝[t₂] x,
      from (𝓝[t₂] x).sets_of_superset (inter_mem_inf_sets ht₁ (subset.refl t₂)) ht,
    have 𝓝[t₂] x = ⊥,
      by rwa [empty_in_sets_eq_bot] at this,
    by simp only [closure_eq_cluster_pts] at hx; exact (hx t₂ ht₂).ne this,
  let ⟨t, ht⟩ := h (λ i : f.sets, closure i.1) (λ i, is_closed_closure)
    (by simpa [eq_empty_iff_forall_not_mem, not_exists]) in
  have (⋂i∈t, subtype.val i) ∈ f,
    from t.Inter_mem_sets.2 $ assume i hi, i.2,
  have s ∩ (⋂i∈t, subtype.val i) ∈ f,
    from inter_mem_sets (le_principal_iff.1 hfs) this,
  have ∅ ∈ f,
    from mem_sets_of_superset this $ assume x ⟨hxs, hx⟩,
    let ⟨i, hit, hxi⟩ := (show ∃i ∈ t, x ∉ closure (subtype.val i),
      by { rw [eq_empty_iff_forall_not_mem] at ht, simpa [hxs, not_forall] using ht x }) in
    have x ∈ closure i.val, from subset_closure (mem_bInter_iff.mp hx i hit),
    show false, from hxi this,
  hfn.ne $ by rwa [empty_in_sets_eq_bot] at this

/-- A set `s` is compact if for every open cover of `s`, there exists a finite subcover. -/
lemma compact_of_finite_subcover
  (h : Π {ι : Type u} (U : ι → (set α)), (∀ i, is_open (U i)) →
    s ⊆ (⋃ i, U i) → (∃ (t : finset ι), s ⊆ (⋃ i ∈ t, U i))) :
  is_compact s :=
compact_of_finite_subfamily_closed $
  assume ι Z hZc hsZ,
  let ⟨t, ht⟩ := h (λ i, (Z i)ᶜ) (assume i, is_open_compl_iff.mpr $ hZc i)
    (by simpa only [subset_def, not_forall, eq_empty_iff_forall_not_mem, mem_Union,
      exists_prop, mem_inter_eq, not_and, iff_self, mem_Inter, mem_compl_eq] using hsZ)
      in
  ⟨t, by simpa only [subset_def, not_forall, eq_empty_iff_forall_not_mem, mem_Union,
      exists_prop, mem_inter_eq, not_and, iff_self, mem_Inter, mem_compl_eq] using ht⟩

/-- A set `s` is compact if and only if
for every open cover of `s`, there exists a finite subcover. -/
lemma compact_iff_finite_subcover :
  is_compact s ↔ (Π {ι : Type u} (U : ι → (set α)), (∀ i, is_open (U i)) →
    s ⊆ (⋃ i, U i) → (∃ (t : finset ι), s ⊆ (⋃ i ∈ t, U i))) :=
⟨assume hs ι, hs.elim_finite_subcover, compact_of_finite_subcover⟩

/-- A set `s` is compact if and only if
for every family of closed sets whose intersection avoids `s`,
there exists a finite subfamily whose intersection avoids `s`. -/
theorem compact_iff_finite_subfamily_closed :
  is_compact s ↔ (Π {ι : Type u} (Z : ι → (set α)), (∀ i, is_closed (Z i)) →
    s ∩ (⋂ i, Z i) = ∅ → (∃ (t : finset ι), s ∩ (⋂ i ∈ t, Z i) = ∅)) :=
⟨assume hs ι, hs.elim_finite_subfamily_closed, compact_of_finite_subfamily_closed⟩

@[simp]
lemma compact_empty : is_compact (∅ : set α) :=
assume f hnf hsf, not.elim hnf.ne $
empty_in_sets_eq_bot.1 $ le_principal_iff.1 hsf

@[simp]
lemma compact_singleton {a : α} : is_compact ({a} : set α) :=
λ f hf hfa, ⟨a, rfl, cluster_pt.of_le_nhds'
  (hfa.trans $ by simpa only [principal_singleton] using pure_le_nhds a) hf⟩

lemma set.subsingleton.is_compact {s : set α} (hs : s.subsingleton) : is_compact s :=
subsingleton.induction_on hs compact_empty $ λ x, compact_singleton

lemma set.finite.compact_bUnion {s : set β} {f : β → set α} (hs : finite s)
  (hf : ∀i ∈ s, is_compact (f i)) :
  is_compact (⋃i ∈ s, f i) :=
compact_of_finite_subcover $ assume ι U hUo hsU,
  have ∀i : subtype s, ∃t : finset ι, f i ⊆ (⋃ j ∈ t, U j), from
    assume ⟨i, hi⟩, (hf i hi).elim_finite_subcover _ hUo
      (calc f i ⊆ ⋃i ∈ s, f i : subset_bUnion_of_mem hi
            ... ⊆ ⋃j, U j     : hsU),
  let ⟨finite_subcovers, h⟩ := axiom_of_choice this in
  by haveI : fintype (subtype s) := hs.fintype; exact
  let t := finset.bUnion finset.univ finite_subcovers in
  have (⋃i ∈ s, f i) ⊆ (⋃ i ∈ t, U i), from bUnion_subset $
    assume i hi, calc
    f i ⊆ (⋃ j ∈ finite_subcovers ⟨i, hi⟩, U j) : (h ⟨i, hi⟩)
    ... ⊆ (⋃ j ∈ t, U j) : bUnion_subset_bUnion_left $
      assume j hj, finset.mem_bUnion.mpr ⟨_, finset.mem_univ _, hj⟩,
  ⟨t, this⟩

lemma finset.compact_bUnion (s : finset β) {f : β → set α} (hf : ∀i ∈ s, is_compact (f i)) :
  is_compact (⋃i ∈ s, f i) :=
s.finite_to_set.compact_bUnion hf

lemma compact_accumulate {K : ℕ → set α} (hK : ∀ n, is_compact (K n)) (n : ℕ) :
  is_compact (accumulate K n) :=
(finite_le_nat n).compact_bUnion $ λ k _, hK k

lemma compact_Union {f : β → set α} [fintype β]
  (h : ∀i, is_compact (f i)) : is_compact (⋃i, f i) :=
by rw ← bUnion_univ; exact finite_univ.compact_bUnion (λ i _, h i)

lemma set.finite.is_compact (hs : finite s) : is_compact s :=
bUnion_of_singleton s ▸ hs.compact_bUnion (λ _ _, compact_singleton)

lemma finite_of_is_compact_of_discrete [discrete_topology α] (s : set α) (hs : is_compact s) :
  s.finite :=
begin
  have := hs.elim_finite_subcover (λ x : α, ({x} : set α))
    (λ x, is_open_discrete _),
  simp only [set.subset_univ, forall_prop_of_true, set.Union_of_singleton] at this,
  rcases this with ⟨t, ht⟩,
  suffices : (⋃ (i : α) (H : i ∈ t), {i} : set α) = (t : set α),
  { rw this at ht, exact t.finite_to_set.subset ht },
  ext x,
  simp only [exists_prop, set.mem_Union, set.mem_singleton_iff, exists_eq_right', finset.mem_coe]
end

lemma is_compact.union (hs : is_compact s) (ht : is_compact t) : is_compact (s ∪ t) :=
by rw union_eq_Union; exact compact_Union (λ b, by cases b; assumption)

lemma is_compact.insert (hs : is_compact s) (a) : is_compact (insert a s) :=
compact_singleton.union hs

/-- `filter.cocompact` is the filter generated by complements to compact sets. -/
def filter.cocompact (α : Type*) [topological_space α] : filter α :=
⨅ (s : set α) (hs : is_compact s), 𝓟 (sᶜ)

lemma filter.has_basis_cocompact : (filter.cocompact α).has_basis is_compact compl :=
has_basis_binfi_principal'
  (λ s hs t ht, ⟨s ∪ t, hs.union ht, compl_subset_compl.2 (subset_union_left s t),
    compl_subset_compl.2 (subset_union_right s t)⟩)
  ⟨∅, compact_empty⟩

lemma filter.mem_cocompact : s ∈ filter.cocompact α ↔ ∃ t, is_compact t ∧ tᶜ ⊆ s :=
filter.has_basis_cocompact.mem_iff.trans $ exists_congr $ λ t,  exists_prop

lemma filter.mem_cocompact' : s ∈ filter.cocompact α ↔ ∃ t, is_compact t ∧ sᶜ ⊆ t :=
filter.mem_cocompact.trans $ exists_congr $ λ t, and_congr_right $ λ ht, compl_subset_comm

lemma is_compact.compl_mem_cocompact (hs : is_compact s) : sᶜ ∈ filter.cocompact α :=
filter.has_basis_cocompact.mem_of_mem hs

section tube_lemma

variables [topological_space β]

/-- `nhds_contain_boxes s t` means that any open neighborhood of `s × t` in `α × β` includes
a product of an open neighborhood of `s` by an open neighborhood of `t`. -/
def nhds_contain_boxes (s : set α) (t : set β) : Prop :=
∀ (n : set (α × β)) (hn : is_open n) (hp : set.prod s t ⊆ n),
∃ (u : set α) (v : set β), is_open u ∧ is_open v ∧ s ⊆ u ∧ t ⊆ v ∧ set.prod u v ⊆ n

lemma nhds_contain_boxes.symm {s : set α} {t : set β} :
  nhds_contain_boxes s t → nhds_contain_boxes t s :=
assume H n hn hp,
  let ⟨u, v, uo, vo, su, tv, p⟩ :=
    H (prod.swap ⁻¹' n)
      (hn.preimage continuous_swap)
      (by rwa [←image_subset_iff, image_swap_prod]) in
  ⟨v, u, vo, uo, tv, su,
    by rwa [←image_subset_iff, image_swap_prod] at p⟩

lemma nhds_contain_boxes.comm {s : set α} {t : set β} :
  nhds_contain_boxes s t ↔ nhds_contain_boxes t s :=
iff.intro nhds_contain_boxes.symm nhds_contain_boxes.symm

lemma nhds_contain_boxes_of_singleton {x : α} {y : β} :
  nhds_contain_boxes ({x} : set α) ({y} : set β) :=
assume n hn hp,
  let ⟨u, v, uo, vo, xu, yv, hp'⟩ :=
    is_open_prod_iff.mp hn x y (hp $ by simp) in
  ⟨u, v, uo, vo, by simpa, by simpa, hp'⟩

lemma nhds_contain_boxes_of_compact {s : set α} (hs : is_compact s) (t : set β)
  (H : ∀ x ∈ s, nhds_contain_boxes ({x} : set α) t) : nhds_contain_boxes s t :=
assume n hn hp,
have ∀x : subtype s, ∃uv : set α × set β,
     is_open uv.1 ∧ is_open uv.2 ∧ {↑x} ⊆ uv.1 ∧ t ⊆ uv.2 ∧ set.prod uv.1 uv.2 ⊆ n,
  from assume ⟨x, hx⟩,
    have set.prod {x} t ⊆ n, from
      subset.trans (prod_mono (by simpa) (subset.refl _)) hp,
    let ⟨ux,vx,H1⟩ := H x hx n hn this in ⟨⟨ux,vx⟩,H1⟩,
let ⟨uvs, h⟩ := classical.axiom_of_choice this in
have us_cover : s ⊆ ⋃i, (uvs i).1, from
  assume x hx, subset_Union _ ⟨x,hx⟩ (by simpa using (h ⟨x,hx⟩).2.2.1),
let ⟨s0, s0_cover⟩ :=
  hs.elim_finite_subcover _ (λi, (h i).1) us_cover in
let u := ⋃(i ∈ s0), (uvs i).1 in
let v := ⋂(i ∈ s0), (uvs i).2 in
have is_open u, from is_open_bUnion (λi _, (h i).1),
have is_open v, from is_open_bInter s0.finite_to_set (λi _, (h i).2.1),
have t ⊆ v, from subset_bInter (λi _, (h i).2.2.2.1),
have set.prod u v ⊆ n, from assume ⟨x',y'⟩ ⟨hx',hy'⟩,
  have ∃i ∈ s0, x' ∈ (uvs i).1, by simpa using hx',
  let ⟨i,is0,hi⟩ := this in
  (h i).2.2.2.2 ⟨hi, (bInter_subset_of_mem is0 : v ⊆ (uvs i).2) hy'⟩,
⟨u, v, ‹is_open u›, ‹is_open v›, s0_cover, ‹t ⊆ v›, ‹set.prod u v ⊆ n›⟩

/-- If `s` and `t` are compact sets and `n` is an open neighborhood of `s × t`, then there exist
open neighborhoods `u ⊇ s` and `v ⊇ t` such that `u × v ⊆ n`. -/
lemma generalized_tube_lemma {s : set α} (hs : is_compact s) {t : set β} (ht : is_compact t)
  {n : set (α × β)} (hn : is_open n) (hp : set.prod s t ⊆ n) :
  ∃ (u : set α) (v : set β), is_open u ∧ is_open v ∧ s ⊆ u ∧ t ⊆ v ∧ set.prod u v ⊆ n :=
have _, from
  nhds_contain_boxes_of_compact hs t $ assume x _, nhds_contain_boxes.symm $
    nhds_contain_boxes_of_compact ht {x} $ assume y _, nhds_contain_boxes_of_singleton,
this n hn hp

end tube_lemma

/-- Type class for compact spaces. Separation is sometimes included in the definition, especially
in the French literature, but we do not include it here. -/
class compact_space (α : Type*) [topological_space α] : Prop :=
(compact_univ : is_compact (univ : set α))

@[priority 10] -- see Note [lower instance priority]
instance subsingleton.compact_space [subsingleton α] : compact_space α :=
⟨subsingleton_univ.is_compact⟩

lemma compact_univ [h : compact_space α] : is_compact (univ : set α) := h.compact_univ

lemma cluster_point_of_compact [compact_space α] (f : filter α) [ne_bot f] :
  ∃ x, cluster_pt x f :=
by simpa using compact_univ (show f ≤ 𝓟 univ, by simp)

lemma compact_space.elim_nhds_subcover {α : Type*} [topological_space α] [compact_space α]
  (U : α → set α) (hU : ∀ x, U x ∈ 𝓝 x) :
  ∃ t : finset α, (⋃ x ∈ t, U x) = ⊤ :=
begin
  obtain ⟨t, -, s⟩ := is_compact.elim_nhds_subcover compact_univ U (λ x m, hU x),
  exact ⟨t, by { rw eq_top_iff, exact s }⟩,
end

theorem compact_space_of_finite_subfamily_closed {α : Type u} [topological_space α]
  (h : Π {ι : Type u} (Z : ι → (set α)), (∀ i, is_closed (Z i)) →
    (⋂ i, Z i) = ∅ → ∃ (t : finset ι), (⋂ i ∈ t, Z i) = ∅) :
  compact_space α :=
{ compact_univ :=
  begin
    apply compact_of_finite_subfamily_closed,
    intros ι Z, specialize h Z,
    simpa using h
  end }

lemma is_closed.compact [compact_space α] {s : set α} (h : is_closed s) :
  is_compact s :=
compact_of_is_closed_subset compact_univ h (subset_univ _)

/-- A compact discrete space is finite. -/
noncomputable
def fintype_of_compact_of_discrete [compact_space α] [discrete_topology α] :
  fintype α :=
fintype_of_univ_finite $ finite_of_is_compact_of_discrete _ compact_univ

lemma finite_cover_nhds_interior [compact_space α] {U : α → set α} (hU : ∀ x, U x ∈ 𝓝 x) :
  ∃ t : finset α, (⋃ x ∈ t, interior (U x)) = univ :=
let ⟨t, ht⟩ := compact_univ.elim_finite_subcover (λ x, interior (U x)) (λ x, is_open_interior)
  (λ x _, mem_Union.2 ⟨x, mem_interior_iff_mem_nhds.2 (hU x)⟩)
in ⟨t, univ_subset_iff.1 ht⟩

lemma finite_cover_nhds [compact_space α] {U : α → set α} (hU : ∀ x, U x ∈ 𝓝 x) :
  ∃ t : finset α, (⋃ x ∈ t, U x) = univ :=
let ⟨t, ht⟩ := finite_cover_nhds_interior hU in ⟨t, univ_subset_iff.1 $
  ht ▸ bUnion_subset_bUnion_right (λ x hx, interior_subset)⟩

/-- If `α` is a compact space, then a locally finite family of sets of `α` can have only finitely
many nonempty elements. -/
lemma locally_finite.finite_nonempty_of_compact {ι : Type*} [compact_space α] {f : ι → set α}
  (hf : locally_finite f) :
  finite {i | (f i).nonempty} :=
by simpa only [inter_univ]  using hf.finite_nonempty_inter_compact compact_univ

/-- If `α` is a compact space, then a locally finite family of nonempty sets of `α` can have only
finitely many elements, `set.finite` version. -/
lemma locally_finite.finite_of_compact {ι : Type*} [compact_space α] {f : ι → set α}
  (hf : locally_finite f) (hne : ∀ i, (f i).nonempty) :
  finite (univ : set ι) :=
by simpa only [hne] using hf.finite_nonempty_of_compact

/-- If `α` is a compact space, then a locally finite family of nonempty sets of `α` can have only
finitely many elements, `fintype` version. -/
noncomputable def locally_finite.fintype_of_compact {ι : Type*} [compact_space α] {f : ι → set α}
  (hf : locally_finite f) (hne : ∀ i, (f i).nonempty) :
  fintype ι :=
fintype_of_univ_finite (hf.finite_of_compact hne)

variables [topological_space β]

lemma is_compact.image_of_continuous_on {f : α → β} (hs : is_compact s) (hf : continuous_on f s) :
  is_compact (f '' s) :=
begin
  intros l lne ls,
  have : ne_bot (l.comap f ⊓ 𝓟 s) :=
    comap_inf_principal_ne_bot_of_image_mem lne (le_principal_iff.1 ls),
  obtain ⟨a, has, ha⟩ : ∃ a ∈ s, cluster_pt a (l.comap f ⊓ 𝓟 s) := @@hs this inf_le_right,
  use [f a, mem_image_of_mem f has],
  have : tendsto f (𝓝 a ⊓ (comap f l ⊓ 𝓟 s)) (𝓝 (f a) ⊓ l),
  { convert (hf a has).inf (@tendsto_comap _ _ f l) using 1,
    rw nhds_within,
    ac_refl },
  exact @@tendsto.ne_bot _ this ha,
end

lemma is_compact.image {f : α → β} (hs : is_compact s) (hf : continuous f) :
  is_compact (f '' s) :=
hs.image_of_continuous_on hf.continuous_on

lemma compact_range [compact_space α] {f : α → β} (hf : continuous f) :
  is_compact (range f) :=
by rw ← image_univ; exact compact_univ.image hf

/-- If X is is_compact then pr₂ : X × Y → Y is a closed map -/
theorem is_closed_proj_of_compact
  {X : Type*} [topological_space X] [compact_space X]
  {Y : Type*} [topological_space Y]  :
  is_closed_map (prod.snd : X × Y → Y) :=
begin
  set πX := (prod.fst : X × Y → X),
  set πY := (prod.snd : X × Y → Y),
  assume C (hC : is_closed C),
  rw is_closed_iff_cluster_pt at hC ⊢,
  assume y (y_closure : cluster_pt y $ 𝓟 (πY '' C)),
  have : ne_bot (map πX (comap πY (𝓝 y) ⊓ 𝓟 C)),
  { suffices : ne_bot (map πY (comap πY (𝓝 y) ⊓ 𝓟 C)),
      by simpa only [map_ne_bot_iff],
    convert y_closure,
    calc map πY (comap πY (𝓝 y) ⊓ 𝓟 C) =
       𝓝 y ⊓ map πY (𝓟 C) : filter.push_pull' _ _ _
      ... = 𝓝 y ⊓ 𝓟 (πY '' C) : by rw map_principal },
  resetI,
  obtain ⟨x, hx⟩ : ∃ x, cluster_pt x (map πX (comap πY (𝓝 y) ⊓ 𝓟 C)),
    from cluster_point_of_compact _,
  refine ⟨⟨x, y⟩, _, by simp [πY]⟩,
  apply hC,
  rw [cluster_pt, ← filter.map_ne_bot_iff πX],
  convert hx,
  calc map πX (𝓝 (x, y) ⊓ 𝓟 C)
      = map πX (comap πX (𝓝 x) ⊓ comap πY (𝓝 y) ⊓ 𝓟 C) : by rw [nhds_prod_eq, filter.prod]
  ... = map πX (comap πY (𝓝 y) ⊓ 𝓟 C ⊓ comap πX (𝓝 x)) : by ac_refl
  ... = map πX (comap πY (𝓝 y) ⊓ 𝓟 C) ⊓ 𝓝 x            : by rw filter.push_pull
  ... = 𝓝 x ⊓ map πX (comap πY (𝓝 y) ⊓ 𝓟 C)            : by rw inf_comm
end

lemma embedding.compact_iff_compact_image {f : α → β} (hf : embedding f) :
  is_compact s ↔ is_compact (f '' s) :=
iff.intro (assume h, h.image hf.continuous) $ assume h, begin
  rw compact_iff_ultrafilter_le_nhds at ⊢ h,
  intros u us',
  have : ↑(u.map f) ≤ 𝓟 (f '' s), begin
    rw [ultrafilter.coe_map, map_le_iff_le_comap, comap_principal], convert us',
    exact preimage_image_eq _ hf.inj
  end,
  rcases h (u.map f) this with ⟨_, ⟨a, ha, ⟨⟩⟩, _⟩,
  refine ⟨a, ha, _⟩,
  rwa [hf.induced, nhds_induced, ←map_le_iff_le_comap]
end

lemma compact_iff_compact_in_subtype {p : α → Prop} {s : set {a // p a}} :
  is_compact s ↔ is_compact ((coe : _ → α) '' s) :=
embedding_subtype_coe.compact_iff_compact_image

lemma compact_iff_compact_univ {s : set α} : is_compact s ↔ is_compact (univ : set s) :=
by rw [compact_iff_compact_in_subtype, image_univ, subtype.range_coe]; refl

lemma compact_iff_compact_space {s : set α} : is_compact s ↔ compact_space s :=
compact_iff_compact_univ.trans ⟨λ h, ⟨h⟩, @compact_space.compact_univ _ _⟩

lemma is_compact.prod {s : set α} {t : set β} (hs : is_compact s) (ht : is_compact t) :
  is_compact (set.prod s t) :=
begin
  rw compact_iff_ultrafilter_le_nhds at hs ht ⊢,
  intros f hfs,
  rw le_principal_iff at hfs,
  obtain ⟨a : α, sa : a ∈ s, ha : map prod.fst ↑f ≤ 𝓝 a⟩ :=
    hs (f.map prod.fst) (le_principal_iff.2 $ mem_map.2 $ mem_sets_of_superset hfs (λ x, and.left)),
  obtain ⟨b : β, tb : b ∈ t, hb : map prod.snd ↑f ≤ 𝓝 b⟩ :=
    ht (f.map prod.snd) (le_principal_iff.2 $ mem_map.2 $
      mem_sets_of_superset hfs (λ x, and.right)),
  rw map_le_iff_le_comap at ha hb,
  refine ⟨⟨a, b⟩, ⟨sa, tb⟩, _⟩,
  rw nhds_prod_eq, exact le_inf ha hb
end

lemma inducing.is_compact_iff {f : α → β} (hf : inducing f) {s : set α} :
  is_compact (f '' s) ↔ is_compact s :=
begin
  split,
  { introsI hs F F_ne_bot F_le,
    obtain ⟨_, ⟨x, x_in : x ∈ s, rfl⟩, hx : cluster_pt (f x) (map f F)⟩ :=
      hs (calc map f F ≤ map f (𝓟 s) : map_mono F_le
                  ... = 𝓟 (f '' s) : map_principal),
    use [x, x_in],
    suffices : (map f (𝓝 x ⊓ F)).ne_bot, by simpa [filter.map_ne_bot_iff],
    rwa calc map f (𝓝 x ⊓ F) = map f ((comap f $ 𝓝 $ f x) ⊓ F) : by rw hf.nhds_eq_comap
                          ... = 𝓝 (f x) ⊓ map f F : filter.push_pull' _ _ _ },
  { intro hs,
    exact hs.image hf.continuous }
end

/-- Finite topological spaces are compact. -/
@[priority 100] instance fintype.compact_space [fintype α] : compact_space α :=
{ compact_univ := finite_univ.is_compact }

/-- The product of two compact spaces is compact. -/
instance [compact_space α] [compact_space β] : compact_space (α × β) :=
⟨by { rw ← univ_prod_univ, exact compact_univ.prod compact_univ }⟩

/-- The disjoint union of two compact spaces is compact. -/
instance [compact_space α] [compact_space β] : compact_space (α ⊕ β) :=
⟨begin
  rw ← range_inl_union_range_inr,
  exact (compact_range continuous_inl).union (compact_range continuous_inr)
end⟩

/-- The coproduct of the cocompact filters on two topological spaces is the cocompact filter on
their product. -/
lemma filter.coprod_cocompact {β : Type*} [topological_space β]:
  (filter.cocompact α).coprod (filter.cocompact β) = filter.cocompact (α × β) :=
begin
  ext S,
  simp only [mem_coprod_iff, exists_prop, mem_comap_sets, filter.mem_cocompact],
  split,
  { rintro ⟨⟨A, ⟨t, ht, hAt⟩, hAS⟩, B, ⟨t', ht', hBt'⟩, hBS⟩,
    refine ⟨t.prod t', ht.prod ht', _⟩,
    refine subset.trans _ (union_subset hAS hBS),
    rw compl_subset_comm at ⊢ hAt hBt',
    refine subset.trans _ (set.prod_mono hAt hBt'),
    intros x,
    simp only [compl_union, mem_inter_eq, mem_prod, mem_preimage, mem_compl_eq],
    tauto },
  { rintros ⟨t, ht, htS⟩,
    refine ⟨⟨(prod.fst '' t)ᶜ, _, _⟩, ⟨(prod.snd '' t)ᶜ, _, _⟩⟩,
    { exact ⟨prod.fst '' t, ht.image continuous_fst, subset.rfl⟩ },
    { rw preimage_compl,
      rw compl_subset_comm at ⊢ htS,
      exact subset.trans htS (subset_preimage_image prod.fst _) },
    { exact ⟨prod.snd '' t, ht.image continuous_snd, subset.rfl⟩ },
    { rw preimage_compl,
      rw compl_subset_comm at ⊢ htS,
      exact subset.trans htS (subset_preimage_image prod.snd _) } }
end

section tychonoff
variables {ι : Type*} {π : ι → Type*} [∀ i, topological_space (π i)]

/-- Tychonoff's theorem -/
lemma compact_pi_infinite {s : Π i, set (π i)} :
  (∀ i, is_compact (s i)) → is_compact {x : Π i, π i | ∀ i, x i ∈ s i} :=
begin
  simp only [compact_iff_ultrafilter_le_nhds, nhds_pi, exists_prop, mem_set_of_eq, le_infi_iff,
    le_principal_iff],
  intros h f hfs,
  have : ∀i:ι, ∃a, a∈s i ∧ tendsto (λx:Πi:ι, π i, x i) f (𝓝 a),
  { refine λ i, h i (f.map _) (mem_map.2 _),
    exact mem_sets_of_superset hfs (λ x hx, hx i) },
  choose a ha,
  exact  ⟨a, assume i, (ha i).left, assume i, (ha i).right.le_comap⟩
end

/-- A version of Tychonoff's theorem that uses `set.pi`. -/
lemma compact_univ_pi {s : Π i, set (π i)} (h : ∀ i, is_compact (s i)) :
  is_compact (pi univ s) :=
by { convert compact_pi_infinite h, simp only [pi, forall_prop_of_true, mem_univ] }

instance pi.compact_space [∀ i, compact_space (π i)] : compact_space (Πi, π i) :=
⟨by { rw [← pi_univ univ], exact compact_univ_pi (λ i, compact_univ) }⟩

/-- Product of compact sets is compact -/
lemma filter.Coprod_cocompact {δ : Type*} {κ : δ → Type*} [Π d, topological_space (κ d)] :
  filter.Coprod (λ d, filter.cocompact (κ d)) = filter.cocompact (Π d, κ d) :=
begin
  ext S,
  simp only [mem_coprod_iff, exists_prop, mem_comap_sets, filter.mem_cocompact],
  split,
  { intros h,
    rw filter.mem_Coprod_iff at h,
    choose t ht1 ht2 using h,
    choose t1 ht11 ht12 using λ d, filter.mem_cocompact.mp (ht1 d),
    refine ⟨set.pi set.univ t1, _, _⟩,
    { convert compact_pi_infinite ht11,
      ext,
      simp },
    { refine subset.trans _ (set.Union_subset ht2),
      intros x,
      simp only [mem_Union, mem_univ_pi, exists_imp_distrib, mem_compl_eq, not_forall],
      intros d h,
      exact ⟨d, ht12 d h⟩ } },
  { rintros ⟨t, h1, h2⟩,
    rw filter.mem_Coprod_iff,
    intros d,
    refine ⟨((λ (k : Π (d : δ), κ d), k d) '' t)ᶜ, _, _⟩,
    { rw filter.mem_cocompact,
      refine ⟨(λ (k : Π (d : δ), κ d), k d) '' t, _, set.subset.refl _⟩,
      exact is_compact.image h1 (continuous_pi_iff.mp (continuous_id) d) },
    refine subset.trans _ h2,
    intros x hx,
    simp only [not_exists, mem_image, mem_preimage, mem_compl_eq] at hx,
    simpa using mt (hx x) },
end

end tychonoff

instance quot.compact_space {r : α → α → Prop} [compact_space α] :
  compact_space (quot r) :=
⟨by { rw ← range_quot_mk, exact compact_range continuous_quot_mk }⟩

instance quotient.compact_space {s : setoid α} [compact_space α] :
  compact_space (quotient s) :=
quot.compact_space

/-- There are various definitions of "locally compact space" in the literature, which agree for
Hausdorff spaces but not in general. This one is the precise condition on X needed for the
evaluation `map C(X, Y) × X → Y` to be continuous for all `Y` when `C(X, Y)` is given the
compact-open topology. -/
class locally_compact_space (α : Type*) [topological_space α] : Prop :=
(local_compact_nhds : ∀ (x : α) (n ∈ 𝓝 x), ∃ s ∈ 𝓝 x, s ⊆ n ∧ is_compact s)

lemma compact_basis_nhds [locally_compact_space α] (x : α) :
  (𝓝 x).has_basis (λ s, s ∈ 𝓝 x ∧ is_compact s) (λ s, s) :=
has_basis_self.2 $ by simpa only [and_comm] using locally_compact_space.local_compact_nhds x

lemma locally_compact_space_of_has_basis {ι : α → Type*} {p : Π x, ι x → Prop}
  {s : Π x, ι x → set α} (h : ∀ x, (𝓝 x).has_basis (p x) (s x))
  (hc : ∀ x i, p x i → is_compact (s x i)) :
  locally_compact_space α :=
⟨λ x t ht, let ⟨i, hp, ht⟩ := (h x).mem_iff.1 ht in ⟨s x i, (h x).mem_of_mem hp, ht, hc x i hp⟩⟩

instance locally_compact_space.prod (α : Type*) (β : Type*) [topological_space α]
  [topological_space β] [locally_compact_space α] [locally_compact_space β] :
  locally_compact_space (α × β) :=
have _ := λ x : α × β, (compact_basis_nhds x.1).prod_nhds' (compact_basis_nhds x.2),
locally_compact_space_of_has_basis this $ λ x s ⟨⟨_, h₁⟩, _, h₂⟩, h₁.prod h₂

/-- A reformulation of the definition of locally compact space: In a locally compact space,
  every open set containing `x` has a compact subset containing `x` in its interior. -/
lemma exists_compact_subset [locally_compact_space α] {x : α} {U : set α}
  (hU : is_open U) (hx : x ∈ U) : ∃ (K : set α), is_compact K ∧ x ∈ interior K ∧ K ⊆ U :=
begin
  rcases locally_compact_space.local_compact_nhds x U (mem_nhds_sets hU hx) with ⟨K, h1K, h2K, h3K⟩,
  exact ⟨K, h3K, mem_interior_iff_mem_nhds.2 h1K, h2K⟩,
end

/-- In a locally compact space every point has a compact neighborhood. -/
lemma exists_compact_mem_nhds [locally_compact_space α] (x : α) :
  ∃ K, is_compact K ∧ K ∈ 𝓝 x :=
let ⟨K, hKc, hx, H⟩ := exists_compact_subset is_open_univ (mem_univ x)
in ⟨K, hKc, mem_interior_iff_mem_nhds.1 hx⟩

/-- In a locally compact space, every compact set is contained in the interior of a compact set. -/
lemma exists_compact_superset [locally_compact_space α] {K : set α} (hK : is_compact K) :
  ∃ K', is_compact K' ∧ K ⊆ interior K' :=
begin
  choose U hUc hxU using λ x : K, exists_compact_mem_nhds (x : α),
  have : K ⊆ ⋃ x, interior (U x),
    from λ x hx, mem_Union.2 ⟨⟨x, hx⟩, mem_interior_iff_mem_nhds.2 (hxU _)⟩,
  rcases hK.elim_finite_subcover _ _ this with ⟨t, ht⟩,
  { refine ⟨_, t.compact_bUnion (λ x _, hUc x), λ x hx, _⟩,
    rcases mem_bUnion_iff.1 (ht hx) with ⟨y, hyt, hy⟩,
    exact interior_mono (subset_bUnion_of_mem hyt) hy },
  { exact λ _, is_open_interior }
end

lemma ultrafilter.le_nhds_Lim [compact_space α] (F : ultrafilter α) :
  ↑F ≤ 𝓝 (@Lim _ _ (F : filter α).nonempty_of_ne_bot F) :=
begin
  rcases compact_univ.ultrafilter_le_nhds F (by simp) with ⟨x, -, h⟩,
  exact le_nhds_Lim ⟨x,h⟩,
end

theorem is_closed.exists_minimal_nonempty_closed_subset [compact_space α]
  {S : set α} (hS : is_closed S) (hne : S.nonempty) :
  ∃ (V : set α),
    V ⊆ S ∧ V.nonempty ∧ is_closed V ∧
      (∀ (V' : set α), V' ⊆ V → V'.nonempty → is_closed V' → V' = V) :=
begin
  let opens := {U : set α | Sᶜ ⊆ U ∧ is_open U ∧ Uᶜ.nonempty},
  obtain ⟨U, ⟨Uc, Uo, Ucne⟩, h⟩ := zorn.zorn_subset opens (λ c hc hz, begin
    by_cases hcne : c.nonempty,
    { obtain ⟨U₀, hU₀⟩ := hcne,
      haveI : nonempty {U // U ∈ c} := ⟨⟨U₀, hU₀⟩⟩,
      obtain ⟨U₀compl, U₀opn, U₀ne⟩ := hc hU₀,
      use ⋃₀ c,
      refine ⟨⟨_, _, _⟩, λ U hU a ha, ⟨U, hU, ha⟩⟩,
      { exact λ a ha, ⟨U₀, hU₀, U₀compl ha⟩ },
      { exact is_open_sUnion (λ _ h, (hc h).2.1) },
      { convert_to (⋂(U : {U // U ∈ c}), U.1ᶜ).nonempty,
        { ext,
          simp only [not_exists, exists_prop, not_and, set.mem_Inter, subtype.forall,
            set.mem_set_of_eq, set.mem_compl_eq, subtype.val_eq_coe],
          refl, },
        apply is_compact.nonempty_Inter_of_directed_nonempty_compact_closed,
        { rintros ⟨U, hU⟩ ⟨U', hU'⟩,
          obtain ⟨V, hVc, hVU, hVU'⟩ := zorn.chain.directed_on hz U hU U' hU',
          exact ⟨⟨V, hVc⟩, set.compl_subset_compl.mpr hVU, set.compl_subset_compl.mpr hVU'⟩, },
        { exact λ U, (hc U.2).2.2, },
        { exact λ U, is_closed.compact (is_closed_compl_iff.mpr (hc U.2).2.1), },
        { exact λ U, (is_closed_compl_iff.mpr (hc U.2).2.1), } } },
    { use Sᶜ,
      refine ⟨⟨set.subset.refl _, is_open_compl_iff.mpr hS, _⟩, λ U Uc, (hcne ⟨U, Uc⟩).elim⟩,
      rw compl_compl,
      exact hne, }
  end),
  refine ⟨Uᶜ, set.compl_subset_comm.mp Uc, Ucne, is_closed_compl_iff.mpr Uo, _⟩,
  intros V' V'sub V'ne V'cls,
  have : V'ᶜ = U,
  { refine h V'ᶜ ⟨_, is_open_compl_iff.mpr V'cls, _⟩ (set.subset_compl_comm.mp V'sub),
    exact set.subset.trans Uc (set.subset_compl_comm.mp V'sub),
    simp only [compl_compl, V'ne], },
  rw [←this, compl_compl],
end

/-- A σ-compact space is a space that is the union of a countable collection of compact subspaces.
  Note that a locally compact separable T₂ space need not be σ-compact.
  The sequence can be extracted using `topological_space.compact_covering`. -/
class sigma_compact_space (α : Type*) [topological_space α] : Prop :=
(exists_compact_covering : ∃ K : ℕ → set α, (∀ n, is_compact (K n)) ∧ (⋃ n, K n) = univ)

@[priority 200] -- see Note [lower instance priority]
instance compact_space.sigma_compact [compact_space α] : sigma_compact_space α :=
⟨⟨λ _, univ, λ _, compact_univ, Union_const _⟩⟩

lemma sigma_compact_space.of_countable (S : set (set α)) (Hc : countable S)
  (Hcomp : ∀ s ∈ S, is_compact s) (HU : ⋃₀ S = univ) : sigma_compact_space α :=
⟨(exists_seq_cover_iff_countable ⟨_, compact_empty⟩).2 ⟨S, Hc, Hcomp, HU⟩⟩

@[priority 100] -- see Note [lower instance priority]
instance sigma_compact_space_of_locally_compact_second_countable [locally_compact_space α]
  [second_countable_topology α] : sigma_compact_space α :=
begin
  choose K hKc hxK using λ x : α, exists_compact_mem_nhds x,
  rcases countable_cover_nhds hxK with ⟨s, hsc, hsU⟩,
  refine sigma_compact_space.of_countable _ (hsc.image K) (ball_image_iff.2 $ λ x _, hKc x) _,
  rwa sUnion_image
end

variables (α) [sigma_compact_space α]
open sigma_compact_space

/-- A choice of compact covering for a σ-compact space, chosen to be monotone. -/
def compact_covering : ℕ → set α :=
accumulate exists_compact_covering.some

lemma is_compact_compact_covering (n : ℕ) : is_compact (compact_covering α n) :=
compact_accumulate (classical.some_spec sigma_compact_space.exists_compact_covering).1 n

lemma Union_compact_covering : (⋃ n, compact_covering α n) = univ :=
begin
  rw [compact_covering, Union_accumulate],
  exact (classical.some_spec sigma_compact_space.exists_compact_covering).2
end

@[mono] lemma compact_covering_subset ⦃m n : ℕ⦄ (h : m ≤ n) :
  compact_covering α m ⊆ compact_covering α n :=
monotone_accumulate h

variable {α}

/-- If `α` is a `σ`-compact space, then a locally finite family of nonempty sets of `α` can have
only countably many elements, `set.countable` version. -/
lemma locally_finite.countable_of_sigma_compact {ι : Type*} {f : ι → set α} (hf : locally_finite f)
  (hne : ∀ i, (f i).nonempty) :
  countable (univ : set ι) :=
begin
  have := λ n, hf.finite_nonempty_inter_compact (is_compact_compact_covering α n),
  refine (countable_Union (λ n, (this n).countable)).mono (λ i hi, _),
  rcases hne i with ⟨x, hx⟩,
  rcases Union_eq_univ_iff.1 (Union_compact_covering α) x with ⟨n, hn⟩,
  exact mem_Union.2 ⟨n, x, hx, hn⟩
end

/-- In a topological space with sigma compact topology, if `f` is a function that sends each
point `x` to a neighborhood of `x`, then for some countable set `s`, the neighborhoods `f x`,
`x ∈ s`, cover the whole space. -/
lemma countable_cover_nhds_of_sigma_compact {f : α → set α}
  (hf : ∀ x, f x ∈ 𝓝 x) : ∃ s : set α, countable s ∧ (⋃ x ∈ s, f x) = univ :=
begin
  choose t ht hsub using λ n, (is_compact_compact_covering α n).elim_nhds_subcover f (λ x _, hf x),
  refine ⟨⋃ n, (t n : set α), countable_Union $ λ n, (t n).countable_to_set, _⟩,
  simp only [eq_univ_iff_forall, mem_Union, exists_prop],
  intro x,
  rcases Union_eq_univ_iff.1 (Union_compact_covering α) x with ⟨n, hn⟩,
  rcases mem_bUnion_iff.1 (hsub n hn) with ⟨c, hct, hfx⟩,
  exact ⟨c, ⟨n, hct⟩, hfx⟩
end

end compact

/-- An [exhaustion by compact sets](https://en.wikipedia.org/wiki/Exhaustion_by_compact_sets) of a
topological space is a sequence of compact sets `K n` such that `K n ⊆ interior (K (n + 1))` and
`(⋃ n, K n) = univ`.

If `X` is a locally compact sigma compact space, then `compact_exhaustion.choice X` provides
a choice of an exhaustion by compact sets. This choice is also available as
`(default : compact_exhaustion X)`. -/
structure compact_exhaustion (X : Type*) [topological_space X] :=
(to_fun : ℕ → set X)
(is_compact' : ∀ n, is_compact (to_fun n))
(subset_interior_succ' : ∀ n, to_fun n ⊆ interior (to_fun (n + 1)))
(Union_eq' : (⋃ n, to_fun n) = univ)

namespace compact_exhaustion

instance : has_coe_to_fun (compact_exhaustion α) := ⟨_, to_fun⟩

variables {α} (K : compact_exhaustion α)

protected lemma is_compact (n : ℕ) : is_compact (K n) := K.is_compact' n

lemma subset_interior_succ (n : ℕ) : K n ⊆ interior (K (n + 1)) :=
K.subset_interior_succ' n

lemma subset_succ (n : ℕ) : K n ⊆ K (n + 1) :=
subset.trans (K.subset_interior_succ n) interior_subset

@[mono] protected lemma subset ⦃m n : ℕ⦄ (h : m ≤ n) : K m ⊆ K n :=
show K m ≤ K n, from monotone_of_monotone_nat K.subset_succ h

lemma subset_interior ⦃m n : ℕ⦄ (h : m < n) : K m ⊆ interior (K n) :=
subset.trans (K.subset_interior_succ m) $ interior_mono $ K.subset h

lemma Union_eq : (⋃ n, K n) = univ := K.Union_eq'

lemma exists_mem (x : α) : ∃ n, x ∈ K n := Union_eq_univ_iff.1 K.Union_eq x

/-- The minimal `n` such that `x ∈ K n`. -/
protected noncomputable def find (x : α) : ℕ := nat.find (K.exists_mem x)

lemma mem_find (x : α) : x ∈ K (K.find x) := nat.find_spec (K.exists_mem x)

lemma mem_iff_find_le {x : α} {n : ℕ} : x ∈ K n ↔ K.find x ≤ n :=
⟨λ h, nat.find_min' (K.exists_mem x) h, λ h, K.subset h $ K.mem_find x⟩

/-- Prepend the empty set to a compact exhaustion `K n`. -/
def shiftr : compact_exhaustion α :=
{ to_fun := λ n, nat.cases_on n ∅ K,
  is_compact' := λ n, nat.cases_on n compact_empty K.is_compact,
  subset_interior_succ' := λ n, nat.cases_on n (empty_subset _) K.subset_interior_succ,
  Union_eq' := Union_eq_univ_iff.2 $ λ x, ⟨K.find x + 1, K.mem_find x⟩ }

@[simp] lemma find_shiftr (x : α) : K.shiftr.find x = K.find x + 1 :=
nat.find_comp_succ _ _ (not_mem_empty _)

lemma mem_diff_shiftr_find (x : α) : x ∈ K.shiftr (K.find x + 1) \ K.shiftr (K.find x) :=
⟨K.mem_find _, mt K.shiftr.mem_iff_find_le.1 $
  by simp only [find_shiftr, not_le, nat.lt_succ_self]⟩

/-- A choice of an
[exhaustion by compact sets](https://en.wikipedia.org/wiki/Exhaustion_by_compact_sets)
of a locally compact sigma compact space. -/
noncomputable def choice (X : Type*) [topological_space X] [locally_compact_space X]
  [sigma_compact_space X] : compact_exhaustion X :=
begin
  apply classical.choice,
  let K : ℕ → {s : set X // is_compact s} :=
    λ n, nat.rec_on n ⟨∅, compact_empty⟩
      (λ n s, ⟨(exists_compact_superset s.2).some ∪ compact_covering X n,
        (exists_compact_superset s.2).some_spec.1.union (is_compact_compact_covering _ _)⟩),
  refine ⟨⟨λ n, K n, λ n, (K n).2, λ n, _, _⟩⟩,
  { exact subset.trans (exists_compact_superset (K n).2).some_spec.2
      (interior_mono $ subset_union_left _ _) },
  { refine univ_subset_iff.1 (Union_compact_covering X ▸ _),
    exact Union_subset_Union2 (λ n, ⟨n + 1, subset_union_right _ _⟩) }
end

noncomputable instance [locally_compact_space α] [sigma_compact_space α] :
  inhabited (compact_exhaustion α) :=
⟨compact_exhaustion.choice α⟩

end compact_exhaustion

section clopen

/-- A set is clopen if it is both open and closed. -/
def is_clopen (s : set α) : Prop :=
is_open s ∧ is_closed s

theorem is_clopen_union {s t : set α} (hs : is_clopen s) (ht : is_clopen t) : is_clopen (s ∪ t) :=
⟨is_open_union hs.1 ht.1, is_closed_union hs.2 ht.2⟩

theorem is_clopen_inter {s t : set α} (hs : is_clopen s) (ht : is_clopen t) : is_clopen (s ∩ t) :=
⟨is_open_inter hs.1 ht.1, is_closed_inter hs.2 ht.2⟩

@[simp] theorem is_clopen_empty : is_clopen (∅ : set α) :=
⟨is_open_empty, is_closed_empty⟩

@[simp] theorem is_clopen_univ : is_clopen (univ : set α) :=
⟨is_open_univ, is_closed_univ⟩

theorem is_clopen_compl {s : set α} (hs : is_clopen s) : is_clopen sᶜ :=
⟨hs.2.is_open_compl, is_closed_compl_iff.2 hs.1⟩

@[simp] theorem is_clopen_compl_iff {s : set α} : is_clopen sᶜ ↔ is_clopen s :=
⟨λ h, compl_compl s ▸ is_clopen_compl h, is_clopen_compl⟩

theorem is_clopen_diff {s t : set α} (hs : is_clopen s) (ht : is_clopen t) : is_clopen (s \ t) :=
is_clopen_inter hs (is_clopen_compl ht)

lemma is_clopen_Inter {β : Type*} [fintype β] {s : β → set α}
  (h : ∀ i, is_clopen (s i)) : is_clopen (⋂ i, s i) :=
⟨(is_open_Inter (forall_and_distrib.1 h).1), (is_closed_Inter (forall_and_distrib.1 h).2)⟩

lemma is_clopen_bInter {β : Type*} {s : finset β} {f : β → set α} (h : ∀i∈s, is_clopen (f i)) :
  is_clopen (⋂i∈s, f i) :=
⟨ is_open_bInter ⟨finset_coe.fintype s⟩ (λ i hi, (h i hi).1),
  by {show is_closed (⋂ (i : β) (H : i ∈ (↑s : set β)), f i), rw bInter_eq_Inter,
    apply is_closed_Inter, rintro ⟨i, hi⟩, exact (h i hi).2}⟩

lemma continuous_on.preimage_clopen_of_clopen {β: Type*} [topological_space β]
  {f : α → β} {s : set α} {t : set β} (hf : continuous_on f s) (hs : is_clopen s)
  (ht : is_clopen t) : is_clopen (s ∩ f⁻¹' t) :=
⟨continuous_on.preimage_open_of_open hf hs.1 ht.1,
  continuous_on.preimage_closed_of_closed hf hs.2 ht.2⟩

/-- The intersection of a disjoint covering by two open sets of a clopen set will be clopen. -/
theorem is_clopen_inter_of_disjoint_cover_clopen {Z a b : set α} (h : is_clopen Z)
  (cover : Z ⊆ a ∪ b) (ha : is_open a) (hb : is_open b) (hab : a ∩ b = ∅) : is_clopen (Z ∩ a) :=
begin
  refine ⟨is_open_inter h.1 ha, _⟩,
  have : is_closed (Z ∩ bᶜ) := is_closed_inter h.2 (is_closed_compl_iff.2 hb),
  convert this using 1,
  apply subset.antisymm,
  { exact inter_subset_inter_right Z (subset_compl_iff_disjoint.2 hab) },
  { rintros x ⟨hx₁, hx₂⟩,
    exact ⟨hx₁, by simpa [not_mem_of_mem_compl hx₂] using cover hx₁⟩ }
end

end clopen

section preirreducible

/-- A preirreducible set `s` is one where there is no non-trivial pair of disjoint opens on `s`. -/
def is_preirreducible (s : set α) : Prop :=
∀ (u v : set α), is_open u → is_open v →
  (s ∩ u).nonempty → (s ∩ v).nonempty → (s ∩ (u ∩ v)).nonempty

/-- An irreducible set `s` is one that is nonempty and
where there is no non-trivial pair of disjoint opens on `s`. -/
def is_irreducible (s : set α) : Prop :=
s.nonempty ∧ is_preirreducible s

lemma is_irreducible.nonempty {s : set α} (h : is_irreducible s) :
  s.nonempty := h.1

lemma is_irreducible.is_preirreducible {s : set α} (h : is_irreducible s) :
  is_preirreducible s := h.2

theorem is_preirreducible_empty : is_preirreducible (∅ : set α) :=
λ _ _ _ _ _ ⟨x, h1, h2⟩, h1.elim

theorem is_irreducible_singleton {x} : is_irreducible ({x} : set α) :=
⟨singleton_nonempty x,
 λ u v _ _ ⟨y, h1, h2⟩ ⟨z, h3, h4⟩, by rw mem_singleton_iff at h1 h3;
 substs y z; exact ⟨x, rfl, h2, h4⟩⟩

theorem is_preirreducible.closure {s : set α} (H : is_preirreducible s) :
  is_preirreducible (closure s) :=
λ u v hu hv ⟨y, hycs, hyu⟩ ⟨z, hzcs, hzv⟩,
let ⟨p, hpu, hps⟩ := mem_closure_iff.1 hycs u hu hyu in
let ⟨q, hqv, hqs⟩ := mem_closure_iff.1 hzcs v hv hzv in
let ⟨r, hrs, hruv⟩ := H u v hu hv ⟨p, hps, hpu⟩ ⟨q, hqs, hqv⟩ in
⟨r, subset_closure hrs, hruv⟩

lemma is_irreducible.closure {s : set α} (h : is_irreducible s) :
  is_irreducible (closure s) :=
⟨h.nonempty.closure, h.is_preirreducible.closure⟩

theorem exists_preirreducible (s : set α) (H : is_preirreducible s) :
  ∃ t : set α, is_preirreducible t ∧ s ⊆ t ∧ ∀ u, is_preirreducible u → t ⊆ u → u = t :=
let ⟨m, hm, hsm, hmm⟩ := zorn.zorn_subset_nonempty {t : set α | is_preirreducible t}
  (λ c hc hcc hcn, let ⟨t, htc⟩ := hcn in
    ⟨⋃₀ c, λ u v hu hv ⟨y, hy, hyu⟩ ⟨z, hz, hzv⟩,
      let ⟨p, hpc, hyp⟩ := mem_sUnion.1 hy,
          ⟨q, hqc, hzq⟩ := mem_sUnion.1 hz in
      or.cases_on (zorn.chain.total hcc hpc hqc)
        (assume hpq : p ⊆ q, let ⟨x, hxp, hxuv⟩ := hc hqc u v hu hv
            ⟨y, hpq hyp, hyu⟩ ⟨z, hzq, hzv⟩ in
          ⟨x, mem_sUnion_of_mem hxp hqc, hxuv⟩)
        (assume hqp : q ⊆ p, let ⟨x, hxp, hxuv⟩ := hc hpc u v hu hv
            ⟨y, hyp, hyu⟩ ⟨z, hqp hzq, hzv⟩ in
          ⟨x, mem_sUnion_of_mem hxp hpc, hxuv⟩),
    λ x hxc, subset_sUnion_of_mem hxc⟩) s H in
⟨m, hm, hsm, λ u hu hmu, hmm _ hu hmu⟩

/-- A maximal irreducible set that contains a given point. -/
def irreducible_component (x : α) : set α :=
classical.some (exists_preirreducible {x} is_irreducible_singleton.is_preirreducible)

lemma irreducible_component_property (x : α) :
  is_preirreducible (irreducible_component x) ∧ {x} ⊆ (irreducible_component x) ∧
  ∀ u, is_preirreducible u → (irreducible_component x) ⊆ u → u = (irreducible_component x) :=
classical.some_spec (exists_preirreducible {x} is_irreducible_singleton.is_preirreducible)

theorem mem_irreducible_component {x : α} : x ∈ irreducible_component x :=
singleton_subset_iff.1 (irreducible_component_property x).2.1

theorem is_irreducible_irreducible_component {x : α} : is_irreducible (irreducible_component x) :=
⟨⟨x, mem_irreducible_component⟩, (irreducible_component_property x).1⟩

theorem eq_irreducible_component {x : α} :
  ∀ {s : set α}, is_preirreducible s → irreducible_component x ⊆ s → s = irreducible_component x :=
(irreducible_component_property x).2.2

theorem is_closed_irreducible_component {x : α} :
  is_closed (irreducible_component x) :=
closure_eq_iff_is_closed.1 $ eq_irreducible_component
  is_irreducible_irreducible_component.is_preirreducible.closure
  subset_closure

/-- A preirreducible space is one where there is no non-trivial pair of disjoint opens. -/
class preirreducible_space (α : Type u) [topological_space α] : Prop :=
(is_preirreducible_univ [] : is_preirreducible (univ : set α))

/-- An irreducible space is one that is nonempty
and where there is no non-trivial pair of disjoint opens. -/
class irreducible_space (α : Type u) [topological_space α] extends preirreducible_space α : Prop :=
(to_nonempty [] : nonempty α)

-- see Note [lower instance priority]
attribute [instance, priority 50] irreducible_space.to_nonempty

theorem nonempty_preirreducible_inter [preirreducible_space α] {s t : set α} :
  is_open s → is_open t → s.nonempty → t.nonempty → (s ∩ t).nonempty :=
by simpa only [univ_inter, univ_subset_iff] using
  @preirreducible_space.is_preirreducible_univ α _ _ s t

theorem is_preirreducible.image [topological_space β] {s : set α} (H : is_preirreducible s)
  (f : α → β) (hf : continuous_on f s) : is_preirreducible (f '' s) :=
begin
  rintros u v hu hv ⟨_, ⟨⟨x, hx, rfl⟩, hxu⟩⟩ ⟨_, ⟨⟨y, hy, rfl⟩, hyv⟩⟩,
  rw ← mem_preimage at hxu hyv,
  rcases continuous_on_iff'.1 hf u hu with ⟨u', hu', u'_eq⟩,
  rcases continuous_on_iff'.1 hf v hv with ⟨v', hv', v'_eq⟩,
  have := H u' v' hu' hv',
  rw [inter_comm s u', ← u'_eq] at this,
  rw [inter_comm s v', ← v'_eq] at this,
  rcases this ⟨x, hxu, hx⟩ ⟨y, hyv, hy⟩ with ⟨z, hzs, hzu', hzv'⟩,
  refine ⟨f z, mem_image_of_mem f hzs, _, _⟩,
  all_goals
  { rw ← mem_preimage,
    apply mem_of_mem_inter_left,
    show z ∈ _ ∩ s,
    simp [*] }
end

theorem is_irreducible.image [topological_space β] {s : set α} (H : is_irreducible s)
  (f : α → β) (hf : continuous_on f s) : is_irreducible (f '' s) :=
⟨nonempty_image_iff.mpr H.nonempty, H.is_preirreducible.image f hf⟩

lemma subtype.preirreducible_space {s : set α} (h : is_preirreducible s) :
  preirreducible_space s :=
{ is_preirreducible_univ :=
  begin
    intros u v hu hv hsu hsv,
    rw is_open_induced_iff at hu hv,
    rcases hu with ⟨u, hu, rfl⟩,
    rcases hv with ⟨v, hv, rfl⟩,
    rcases hsu with ⟨⟨x, hxs⟩, hxs', hxu⟩,
    rcases hsv with ⟨⟨y, hys⟩, hys', hyv⟩,
    rcases h u v hu hv ⟨x, hxs, hxu⟩ ⟨y, hys, hyv⟩ with ⟨z, hzs, ⟨hzu, hzv⟩⟩,
    exact ⟨⟨z, hzs⟩, ⟨set.mem_univ _, ⟨hzu, hzv⟩⟩⟩
  end }

lemma subtype.irreducible_space {s : set α} (h : is_irreducible s) :
  irreducible_space s :=
{ is_preirreducible_univ :=
  (subtype.preirreducible_space h.is_preirreducible).is_preirreducible_univ,
  to_nonempty := h.nonempty.to_subtype }

/-- A set `s` is irreducible if and only if
for every finite collection of open sets all of whose members intersect `s`,
`s` also intersects the intersection of the entire collection
(i.e., there is an element of `s` contained in every member of the collection). -/
lemma is_irreducible_iff_sInter {s : set α} :
  is_irreducible s ↔
  ∀ (U : finset (set α)) (hU : ∀ u ∈ U, is_open u) (H : ∀ u ∈ U, (s ∩ u).nonempty),
  (s ∩ ⋂₀ ↑U).nonempty :=
begin
  split; intro h,
  { intro U, apply finset.induction_on U,
    { intros, simpa using h.nonempty },
    { intros u U hu IH hU H,
      rw [finset.coe_insert, sInter_insert],
      apply h.2,
      { solve_by_elim [finset.mem_insert_self] },
      { apply is_open_sInter (finset.finite_to_set U),
        intros, solve_by_elim [finset.mem_insert_of_mem] },
      { solve_by_elim [finset.mem_insert_self] },
      { apply IH,
        all_goals { intros, solve_by_elim [finset.mem_insert_of_mem] } } } },
  { split,
    { simpa using h ∅ _ _; intro u; simp },
    intros u v hu hv hu' hv',
    simpa using h {u,v} _ _,
    all_goals
    { intro t,
      rw [finset.mem_insert, finset.mem_singleton],
      rintro (rfl|rfl); assumption } }
end

/-- A set is preirreducible if and only if
for every cover by two closed sets, it is contained in one of the two covering sets. -/
lemma is_preirreducible_iff_closed_union_closed {s : set α} :
  is_preirreducible s ↔
  ∀ (z₁ z₂ : set α), is_closed z₁ → is_closed z₂ → s ⊆ z₁ ∪ z₂ → s ⊆ z₁ ∨ s ⊆ z₂ :=
begin
  split,
  all_goals
  { intros h t₁ t₂ ht₁ ht₂,
    specialize h t₁ᶜ t₂ᶜ,
    simp only [is_open_compl_iff, is_closed_compl_iff] at h,
    specialize h ht₁ ht₂ },
  { contrapose!, simp only [not_subset],
    rintro ⟨⟨x, hx, hx'⟩, ⟨y, hy, hy'⟩⟩,
    rcases h ⟨x, hx, hx'⟩ ⟨y, hy, hy'⟩ with ⟨z, hz, hz'⟩,
    rw ← compl_union at hz',
    exact ⟨z, hz, hz'⟩ },
  { rintro ⟨x, hx, hx'⟩ ⟨y, hy, hy'⟩,
    rw ← compl_inter at h,
    delta set.nonempty,
    rw imp_iff_not_or at h,
    contrapose! h,
    split,
    { intros z hz hz', exact h z ⟨hz, hz'⟩ },
    { split; intro H; refine H _ ‹_›; assumption } }
end

/-- A set is irreducible if and only if
for every cover by a finite collection of closed sets,
it is contained in one of the members of the collection. -/
lemma is_irreducible_iff_sUnion_closed {s : set α} :
  is_irreducible s ↔
  ∀ (Z : finset (set α)) (hZ : ∀ z ∈ Z, is_closed z) (H : s ⊆ ⋃₀ ↑Z),
  ∃ z ∈ Z, s ⊆ z :=
begin
  rw [is_irreducible, is_preirreducible_iff_closed_union_closed],
  split; intro h,
  { intro Z, apply finset.induction_on Z,
    { intros, rw [finset.coe_empty, sUnion_empty] at H,
      rcases h.1 with ⟨x, hx⟩,
      exfalso, tauto },
    { intros z Z hz IH hZ H,
      cases h.2 z (⋃₀ ↑Z) _ _ _
        with h' h',
      { exact ⟨z, finset.mem_insert_self _ _, h'⟩ },
      { rcases IH _ h' with ⟨z', hz', hsz'⟩,
        { exact ⟨z', finset.mem_insert_of_mem hz', hsz'⟩ },
        { intros, solve_by_elim [finset.mem_insert_of_mem] } },
      { solve_by_elim [finset.mem_insert_self] },
      { rw sUnion_eq_bUnion,
        apply is_closed_bUnion (finset.finite_to_set Z),
        { intros, solve_by_elim [finset.mem_insert_of_mem] } },
      { simpa using H } } },
  { split,
    { by_contradiction hs,
      simpa using h ∅ _ _,
      { intro z, simp },
      { simpa [set.nonempty] using hs } },
    intros z₁ z₂ hz₁ hz₂ H,
    have := h {z₁, z₂} _ _,
    simp only [exists_prop, finset.mem_insert, finset.mem_singleton] at this,
    { rcases this with ⟨z, rfl|rfl, hz⟩; tauto },
    { intro t,
      rw [finset.mem_insert, finset.mem_singleton],
      rintro (rfl|rfl); assumption },
    { simpa using H } }
end

end preirreducible


open Nat

/-
The function `skip n` function maps `Nat` to `Nat` skipping the natural number `n`,
with numbers less than `n` mapped to themselves and those above mapped to the next number.
The image is the complement of `n` among natural numbers.

We need various properties of `skip`, so we define first a function with associated identities,
and project to the value and the desired properties. The structure `ProvedSkip` consists of the
result of `skip` and the associated identities.
-/
structure ProvedSkip(n m: Nat) where
  result : Nat
  lt : m < n → result = m
  ge : n ≤ m → result = m + 1

def provedSkip (n m : Nat) : ProvedSkip n m :=
  if c : m < n then
    ⟨m, fun _ => rfl, fun hyp => False.elim (Nat.lt_irrefl m (Nat.lt_of_lt_of_le c hyp))⟩
  else
    ⟨m + 1, fun hyp => absurd hyp c, fun _ => rfl⟩

-- the `skip` function
def skip: Nat → Nat → Nat
  | n, m => (provedSkip n m).result

-- equations for `skip` below and above the skipped value

theorem skip_below_eq(n m : Nat) : m < n → (skip n m = m)
  | hyp => (provedSkip n m).lt hyp

theorem skip_above_eq(n m : Nat) : n ≤ m → (skip n m = m + 1)
  | hyp => (provedSkip n m).ge hyp

theorem skip_not_below_eq(n m : Nat) : Not (m < n) → (skip n m = m + 1)
  | hyp =>
    let lem : n ≤ m :=
      match Nat.lt_or_ge m n with
      | Or.inl lt => absurd lt hyp
      | Or.inr ge => ge
    skip_above_eq n m lem

/- We prove that skip has an inverse for points different from the point skipped.
We need some helpers. As usual, we have a proved version of the function first.
-/
structure NatSucc (n: Nat) where
  pred: Nat
  eqn : n = succ (pred)

def posSucc : (n : Nat) → Not (zero = n) → NatSucc n
  | zero, w => absurd rfl w
  | l + 1, _ => ⟨l, rfl⟩

structure SkipProvedInv(n m : Nat) where
  k : Nat
  eqn : skip n k = m

def provedSkipInverse : (n : Nat) → (m : Nat) → (m ≠ n) →  SkipProvedInv n m :=
  fun n m eqn =>
  if m_lt_n : m < n then
    ⟨m, skip_below_eq n m m_lt_n⟩
  else
    have n_lt_m : n < m :=
        match Nat.lt_or_ge m n with
        | Or.inl p => absurd p m_lt_n
        | Or.inr p =>
          match Nat.eq_or_lt_of_le p with
          | Or.inl q => absurd (Eq.symm q) eqn
          | Or.inr q => q
    have notZero : Not (zero = m) := by
        intro hyp
        let nLt0 : n < zero := by
          rw [hyp]
          exact n_lt_m
        let n_lt_n : n < n :=
          Nat.lt_of_lt_of_le nLt0 (Nat.zero_le _)
        exact Nat.lt_irrefl n n_lt_n
    let ⟨p, seq⟩ := posSucc m notZero
    have n_le_p : n ≤ p :=
      Nat.le_of_succ_le_succ (by
        rw [← seq]
        exact n_lt_m)
    have imeq : skip n p = m := by
      rw [seq]
      exact (skip_above_eq n p n_le_p)
    ⟨p, imeq⟩

def skipInverse (n m : Nat) : (m ≠ n) → Nat :=
        fun eqn =>  (provedSkipInverse n m eqn).k

theorem skip_inverse_eq(n m : Nat)(eqn : m ≠ n): skip n (skipInverse n m eqn) = m  :=
        (provedSkipInverse n m eqn).eqn

-- Various bounds on the `skip` function.
theorem skip_lt: (k j: Nat) →  skip k j < j + 2 :=
    fun k j =>
      if c : j < k then
        let eqn := skip_below_eq k j c
        by
          rw [eqn]
          apply Nat.le_step
          apply Nat.le_refl
      else
        let eqn := skip_not_below_eq k j c
        by
          rw [eqn]
          apply Nat.le_refl

theorem skip_ge :(k j: Nat) →  j ≤ skip k j  :=
    fun k j =>
      if c : j < k then
        let eqn := skip_below_eq k j c
          by
            rw [eqn]
            apply Nat.le_refl
      else
        let eqn := skip_not_below_eq k j c
        by
          rw [eqn]
          apply Nat.le_step
          apply Nat.le_refl

theorem skip_gt_or_arg_below :(k j: Nat) →  Or (j + 1 ≤ skip k j) (j <  k)  :=
    fun k j =>
      if c : j < k then Or.inr c
      else
          let eqn := skip_not_below_eq k j c
          Or.inl (by
                    rw [eqn]
                    apply Nat.le_refl)

theorem skip_le_succ {n k j : Nat} : j < n → skip k j < n + 1 :=
   by
    intro hyp
    apply Nat.le_trans (skip_lt k j)
    apply Nat.succ_lt_succ
    exact hyp

theorem skip_preimage_lt {i j k n : Nat}: (k < n + 1) → (j < n + 1) →
                                skip k i = j → i < n :=
          fun kw jw eqn =>
            match skip_gt_or_arg_below k i with
              | Or.inl ineq =>
                by
                  have lem1 : i <  j :=
                  by
                    rw [← eqn]
                    exact ineq
                  apply Nat.lt_of_lt_of_le lem1
                  apply Nat.le_of_succ_le_succ
                  apply jw
              | Or.inr ineqn => by
                  apply Nat.lt_of_lt_of_le ineqn
                  apply Nat.le_of_succ_le_succ
                  apply kw

-- Injectivity and image of the skip function.
theorem skip_injective: (n: Nat) → (j1 : Nat) → (j2 : Nat) →
                              (skip n j1 = skip n j2) → j1 = j2 :=
      fun n j1 j2 hyp =>
        match Nat.lt_or_ge j1 n with
        | Or.inl p1 =>
          let eq1 : skip n j1 = j1 := skip_below_eq n j1 p1
          match Nat.lt_or_ge j2 n with
          | Or.inl p2 =>
            let eq2 : skip n j2 = j2 := skip_below_eq n j2 p2
            by
              rw [← eq1]
              rw [← eq2]
              exact hyp
              done
          | Or.inr p2 =>
            let ineq1 : j1 < j2 := Nat.lt_of_lt_of_le p1 p2
            let ineq2 : j1 < skip n j2 := Nat.lt_of_lt_of_le ineq1 (skip_ge n j2)
            let ineq3 : j1 < skip n j1 := Nat.lt_of_lt_of_le ineq2 (Nat.le_of_eq (Eq.symm hyp))
            let ineq4 : j1 < j1 := Nat.lt_of_lt_of_le ineq3 (Nat.le_of_eq eq1)
            False.elim (Nat.lt_irrefl j1 ineq4)
        | Or.inr p1 =>
          let eq1 : skip n j1 = succ j1 := skip_above_eq n j1 p1
          match Nat.lt_or_ge j2 n with
          | Or.inl p2 =>
            let ineq1 : j2 < j1 := Nat.lt_of_lt_of_le p2 p1
            let ineq2 : j2 < skip n j1 := Nat.lt_of_lt_of_le ineq1 (skip_ge n j1)
            let ineq3 : j2 < skip n j2 := Nat.lt_of_lt_of_le ineq2 (Nat.le_of_eq (hyp))
            let eq2 : skip n j2 = j2 := skip_below_eq n j2 p2
            let ineq4 : j2 < j2 := Nat.lt_of_lt_of_le ineq3 (Nat.le_of_eq eq2)
            False.elim (Nat.lt_irrefl j2 ineq4)
          | Or.inr p2 =>
            let eq2 : skip n j2 = succ j2 := skip_above_eq n j2 p2
            let eq3 : succ j1 = succ j2 := by
              rw [← eq1]
              rw [← eq2]
              exact hyp
              done
            by
              injection eq3
              assumption
              done

theorem skip_no_fixedpoints (k: Nat) : (j: Nat) → Not (skip k j = k) :=
  fun j =>
    if c : j < k then
      let eqn := skip_below_eq k j c
      fun hyp =>
        let lem1 : k ≤  j := by
          rw [←hyp]
          rw [eqn]
          apply Nat.le_refl
          done
        let lem2  := Nat.lt_of_lt_of_le c lem1
        not_succ_le_self j lem2
    else
      let eqn := skip_not_below_eq k j c
      fun hyp =>
        let lemEq : j + 1 = k := by
          rw [←hyp]
          rw [eqn]
        let lemIneq : j < k := by
          rw [←lemEq]
          apply Nat.lt_succ_self
        c lemIneq


open classical

variables { α : Type } { p q : α → Prop }
variable { a : α }
variable { r: Prop }

theorem not_all_iff_ex_not : (¬ ∀ x, p x) ↔ (∃ x, ¬ p x) :=
by { split; intro h,
    { apply by_contradiction, intro h1, apply h,
        intro h2, apply by_contradiction, intro h3,
        apply h1, split, exact h3 },
    { intro h1, cases h with h2 h3, exact h3 (h1 h2) } }

theorem not_ex_iff_all_not : (¬ ∃ x, p x) ↔ (∀ x, ¬ p x) :=
by { split; intro h,
    { intros _ h1, apply h, split, exact h1 },
    { intro h1, cases h1 with h2 h3, exact h h2 h3 } }

theorem not_all_not_iff_ex : (¬ ∀ x, ¬ p x) ↔ (∃ x, p x) :=
by { split; intro h,
    { apply by_contradiction, intro h1, apply h,
        intros _ h2, apply h1, split, exact h2 },
    { intro h1, cases h with h h2, exact h1 h h2 } }

theorem not_ex_not_iff_all : (¬ ∃ x, ¬ p x) ↔ (∀ x, p x) :=
by { split; intros h h1,
    { apply by_contradiction, intro h2,
        apply h, split, exact h2 },
    { cases h1 with h1 h2, exact h2 (h h1) } }

theorem all_and_iff_and_all :
    (∀ x, p x ∧ q x) ↔ ((∀ x, p x) ∧ (∀ x, q x)) :=
by { split; intro h,
    { split; intro h1, exact (h h1).left, exact (h h1).right },
    { intro, split, apply h.left, apply h.right } }

theorem ex_or_iff_or_ex :
    (∃ x, (p x ∨ q x)) ↔ ((∃ x, p x) ∨ (∃ x, q x)) :=
by { split; intro h,
    { cases h with _ h, cases h with h h,
        { left, constructor, exact h },
        { right, constructor, exact h } },
    { cases h with h h; cases h with _ h; constructor,
        { left, exact h }, { right, exact h } } }

theorem ex_and_reduce : (∃ x, r ∧ p x) ↔ (r ∧ ∃ x, p x) :=
by { split; intro h,
    { cases h with _ h, split, exact h.left,
        { split, exact h.right } },
    { cases h with h h1, cases h1 with h1 h2,
        existsi h1, split, exact h, exact h2 } }

theorem all_or_reduce : (∀ x, r ∨ p x) ↔ (r ∨ ∀ x, p x) :=
by { split; intro h,
    { apply @by_cases r; intro h1,
        { left, exact h1 },
        { right, intro h2, cases (h h2) with h h,
            exact absurd h h1, exact h } },
    { intro h1, cases h with h h,
        { left, exact h }, { right, exact h h1 } } }

theorem all_mp_reduce_all : (∀ x, r → p x) ↔ (r → ∀ x, p x) :=
by { split; intros h h1 h2; exact h h2 h1 }

theorem all_mpr_reduce_ex : (∀ x, p x → r) ↔ ((∃ x, p x) → r) :=
by { split; intro h,
    { intro h1, cases h1 with h1 h2, exact h h1 h2 },
    { intros h1 h2, apply h, split, exact h2 } }

include a
theorem all_not_free_reduce : (∀ x : α, r) ↔ r :=
by { split; intro h, exact h a, { intro, exact h } }

theorem ex_not_free_reduce : (∃ x : α, r) ↔ r :=
by { split; intro h,
    { cases h with _ h, exact h},
    { existsi a, exact h } }

theorem ex_mp_reduce_ex : (∃ x, r → p x) ↔ (r → ∃ x, p x) :=
by { split; intro h,
    { intro h1, cases h with h h2, existsi h, exact h2 h1},
    { apply @by_cases r; intro h1,
        { cases (h h1) with _ h, split, intro, exact h },
        { existsi a, intro h2, exact absurd h2 h1 } } }

theorem ex_mpr_reduce_all : (∃ x, p x → r) ↔ ((∀ x, p x) → r) :=
by { split; intro h,
    { intro h1, cases h with h h2, exact h2 (h1 h) },
    { apply @by_cases (∀ (x : α), p x); intro h1,
        { existsi a, intro, exact h h1 },
        { have h2 := not_all_iff_ex_not.mp h1, cases h2 with h2 h3,
            existsi h2, intro h4, exact absurd h4 h3 } } }
omit a


import data.nat.basic
import data.nat.parity
import data.int.basic
import data.equiv.denumerable
import data.int.modeq
import tactic

-- Determine all possible colorings of the integers that satisfy these rules.

structure coloring :=
-- Each integer on the number line is colored with exactly one of three possible colors—red, green or blue
(red green blue : set ℤ)
(total : ∀ n, red n ∨ blue n ∨ green n)
--according to the following two rules:
-- the negative of a red number must be colored blue,
(neg_red : ∀ n, red n → blue (-n))
--and the sum of two blue numbers (not necessarily distinct) must be colored red.
(add_blue : ∀ n m ∈ blue, n + m ∈ red)

-- Show that the negative of a blue number must be colored red

lemma neg_blue (x : coloring) : ∀ n, x.blue n → x.red (-n) := begin
intros n hn,
have calc1 := x.add_blue _ _ hn hn,
have calc2 := x.neg_red _ calc1,
have calc3 := x.add_blue _ _ hn calc2,
have calc4 : n + -(n + n) = (-n), ring,
rw calc4 at calc3, exact calc3,
end

-- and the sum of two red numbers must be colored blue.

lemma add_red (x : coloring) : ∀ n m ∈ x.red, n + m ∈ x.blue :=
begin
intros n m hn hm,
have calc1 := x.neg_red _ hn,
have calc2 := x.neg_red _ hm,
have calc3 := x.add_blue _ _ calc1 calc2,
have calc4 := x.neg_red _ calc3,
simp only [neg_add_rev, neg_neg] at calc4,
rw add_comm, exact calc4,
end

-- Determine all possible colorings of the integers that satisfy these rules.
#print notation ≡

-- if x is blue, then 2^n * x is blue when n is even and red when n is odd
-- so coloring behavior is determined by behavior on 2 and odd numbers
-- if 2 is blue and 1 is red, then all numbers 1 mod 4 are red and 3 mod 4 are blue

example : 3 - 5 = 0 :=
begin
norm_num,
end

example : (3 : ℤ) - 5 ≠ 0 :=
begin
norm_num,
end

lemma mod_four (x : coloring) (h1 : x.red 1) : ∀ n, x.red n ↔ n ≡ 1 [ZMOD 4] := begin

end


inductive aexpr : Type
| const : ℕ → aexpr
| var : ℕ → aexpr
| plus : aexpr → aexpr → aexpr
| times : aexpr → aexpr → aexpr

open aexpr

def sample_aexpr : aexpr :=
plus (times (var 0) (const 7)) (times (const 2) (var 1))

-- BEGIN
def aeval (v : ℕ → ℕ) : aexpr → ℕ
| (const n)    := n
| (var n)      := v n
| (plus e₁ e₂)  := (aeval e₁) + (aeval e₂)
| (times e₁ e₂) := (aeval e₁) * (aeval e₂)

def sample_val : ℕ → ℕ
| 0 := 5
| 1 := 6
| _ := 0

-- Try it out. You should get 47 here.
#eval aeval sample_val sample_aexpr
-- END

-- BEGIN
def simp_const : aexpr → aexpr
| (plus (const n₁) (const n₂))  := const (n₁ + n₂)
| (times (const n₁) (const n₂)) := const (n₁ * n₂)
| e                             := e

def fuse : aexpr → aexpr
| (plus e₁ e₂)  := simp_const (plus (fuse e₁) (fuse e₂))
| (times e₁ e₂) := simp_const (times (fuse e₁) (fuse e₂))
| e := e

#eval aeval sample_val (fuse sample_aexpr)

theorem simp_const_eq (v : ℕ → ℕ) :
  ∀ e : aexpr, aeval v (simp_const e) = aeval v e
| (const n) := rfl
| (var n) := rfl
| (plus e1 e2) := begin
  cases e1, {
    cases e2, reflexivity,
    repeat { dsimp [simp_const], reflexivity }
  },
  repeat {
    dsimp [simp_const], reflexivity
  }
end
| (times e1 e2) := begin
  cases e1, {
    cases e2, reflexivity,
    repeat { dsimp [simp_const], reflexivity }
  },
  repeat {
    dsimp [simp_const], reflexivity
  }
end

theorem fuse_eq (v : ℕ → ℕ) :
  ∀ e : aexpr, aeval v (fuse e) = aeval v e
| (plus e1 e2) := begin
  dsimp [fuse],
  simp [simp_const_eq],
  dsimp [aeval],
  simp [fuse_eq e1, fuse_eq e2],
end
| (times e1 e2) := begin
  dsimp [fuse],
  simp [simp_const_eq],
  dsimp [aeval],
  simp [fuse_eq e1, fuse_eq e2],
end
| (const _) := rfl
| (var _) := rfl
-- END