/-
Copyright (c) 2019 Neil Strickland. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Neil Strickland
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.pnat.prime
import Mathlib.data.multiset.sort
import Mathlib.data.int.gcd
import Mathlib.algebra.group.default
import Mathlib.PostPort

namespace Mathlib

/-- The type of multisets of prime numbers.  Unique factorization
 gives an equivalence between this set and ℕ+, as we will formalize
 below. -/
def prime_multiset :=
  multiset nat.primes

namespace prime_multiset

protected instance inhabited : Inhabited prime_multiset :=
  eq.mpr sorry multiset.inhabited

protected instance has_repr : has_repr prime_multiset :=
  id multiset.has_repr

protected instance canonically_ordered_add_monoid : canonically_ordered_add_monoid prime_multiset :=
  id multiset.canonically_ordered_add_monoid

protected instance distrib_lattice : distrib_lattice prime_multiset :=
  id multiset.distrib_lattice

protected instance semilattice_sup_bot : semilattice_sup_bot prime_multiset :=
  id multiset.semilattice_sup_bot

protected instance has_sub : Sub prime_multiset :=
  id multiset.has_sub

theorem add_sub_of_le {u : prime_multiset} {v : prime_multiset} : u ≤ v → u + (v - u) = v :=
  multiset.add_sub_of_le

/-- The multiset consisting of a single prime
-/
def of_prime (p : nat.primes) : prime_multiset :=
  p ::ₘ 0

theorem card_of_prime (p : nat.primes) : coe_fn multiset.card (of_prime p) = 1 :=
  rfl

/-- We can forget the primality property and regard a multiset
 of primes as just a multiset of positive integers, or a multiset
 of natural numbers.  In the opposite direction, if we have a
 multiset of positive integers or natural numbers, together with
 a proof that all the elements are prime, then we can regard it
 as a multiset of primes.  The next block of results records
 obvious properties of these coercions.
-/
def to_nat_multiset : prime_multiset → multiset ℕ :=
  fun (v : prime_multiset) => multiset.map (fun (p : nat.primes) => ↑p) v

protected instance coe_nat : has_coe prime_multiset (multiset ℕ) :=
  has_coe.mk to_nat_multiset

protected instance coe_nat_hom : is_add_monoid_hom coe :=
  eq.mpr
    (id
      ((fun (f f_1 : prime_multiset → multiset ℕ) (e_3 : f = f_1) => congr_arg is_add_monoid_hom e_3) coe to_nat_multiset
        (Eq.trans (Eq.trans (Eq.trans coe.equations._eqn_1 lift_t.equations._eqn_1) coe_t.equations._eqn_1)
          coe_b.equations._eqn_1)))
    (id (multiset.map.is_add_monoid_hom coe))

theorem coe_nat_injective : function.injective coe :=
  multiset.map_injective nat.primes.coe_nat_inj

theorem coe_nat_of_prime (p : nat.primes) : ↑(of_prime p) = ↑p ::ₘ 0 :=
  rfl

theorem coe_nat_prime (v : prime_multiset) (p : ℕ) (h : p ∈ ↑v) : nat.prime p := sorry

/-- Converts a `prime_multiset` to a `multiset ℕ+`. -/
def to_pnat_multiset : prime_multiset → multiset ℕ+ :=
  fun (v : prime_multiset) => multiset.map (fun (p : nat.primes) => ↑p) v

protected instance coe_pnat : has_coe prime_multiset (multiset ℕ+) :=
  has_coe.mk to_pnat_multiset

protected instance coe_pnat_hom : is_add_monoid_hom coe :=
  eq.mpr
    (id
      ((fun (f f_1 : prime_multiset → multiset ℕ+) (e_3 : f = f_1) => congr_arg is_add_monoid_hom e_3) coe
        to_pnat_multiset
        (Eq.trans (Eq.trans (Eq.trans coe.equations._eqn_1 lift_t.equations._eqn_1) coe_t.equations._eqn_1)
          coe_b.equations._eqn_1)))
    (id (multiset.map.is_add_monoid_hom coe))

theorem coe_pnat_injective : function.injective coe :=
  multiset.map_injective nat.primes.coe_pnat_inj

theorem coe_pnat_of_prime (p : nat.primes) : ↑(of_prime p) = ↑p ::ₘ 0 :=
  rfl

theorem coe_pnat_prime (v : prime_multiset) (p : ℕ+) (h : p ∈ ↑v) : pnat.prime p := sorry

protected instance coe_multiset_pnat_nat : has_coe (multiset ℕ+) (multiset ℕ) :=
  has_coe.mk fun (v : multiset ℕ+) => multiset.map (fun (n : ℕ+) => ↑n) v

theorem coe_pnat_nat (v : prime_multiset) : ↑↑v = ↑v := sorry

/-- The product of a `prime_multiset`, as a `ℕ+`. -/
def prod (v : prime_multiset) : ℕ+ :=
  multiset.prod ↑v

theorem coe_prod (v : prime_multiset) : ↑(prod v) = multiset.prod ↑v := sorry

theorem prod_of_prime (p : nat.primes) : prod (of_prime p) = ↑p := sorry

/-- If a `multiset ℕ` consists only of primes, it can be recast as a `prime_multiset`. -/
def of_nat_multiset (v : multiset ℕ) (h : ∀ (p : ℕ), p ∈ v → nat.prime p) : prime_multiset :=
  multiset.pmap (fun (p : ℕ) (hp : nat.prime p) => { val := p, property := hp }) v h

theorem to_of_nat_multiset (v : multiset ℕ) (h : ∀ (p : ℕ), p ∈ v → nat.prime p) : ↑(of_nat_multiset v h) = v := sorry

theorem prod_of_nat_multiset (v : multiset ℕ) (h : ∀ (p : ℕ), p ∈ v → nat.prime p) : ↑(prod (of_nat_multiset v h)) = multiset.prod v :=
  eq.mpr (id (Eq._oldrec (Eq.refl (↑(prod (of_nat_multiset v h)) = multiset.prod v)) (coe_prod (of_nat_multiset v h))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (multiset.prod ↑(of_nat_multiset v h) = multiset.prod v)) (to_of_nat_multiset v h)))
      (Eq.refl (multiset.prod v)))

/-- If a `multiset ℕ+` consists only of primes, it can be recast as a `prime_multiset`. -/
def of_pnat_multiset (v : multiset ℕ+) (h : ∀ (p : ℕ+), p ∈ v → pnat.prime p) : prime_multiset :=
  multiset.pmap (fun (p : ℕ+) (hp : pnat.prime p) => { val := ↑p, property := hp }) v h

theorem to_of_pnat_multiset (v : multiset ℕ+) (h : ∀ (p : ℕ+), p ∈ v → pnat.prime p) : ↑(of_pnat_multiset v h) = v := sorry

theorem prod_of_pnat_multiset (v : multiset ℕ+) (h : ∀ (p : ℕ+), p ∈ v → pnat.prime p) : prod (of_pnat_multiset v h) = multiset.prod v := sorry

/-- Lists can be coerced to multisets; here we have some results
 about how this interacts with our constructions on multisets.
-/
def of_nat_list (l : List ℕ) (h : ∀ (p : ℕ), p ∈ l → nat.prime p) : prime_multiset :=
  of_nat_multiset (↑l) h

theorem prod_of_nat_list (l : List ℕ) (h : ∀ (p : ℕ), p ∈ l → nat.prime p) : ↑(prod (of_nat_list l h)) = list.prod l :=
  eq.mp (Eq._oldrec (Eq.refl (↑(prod (of_nat_multiset (↑l) h)) = multiset.prod ↑l)) (multiset.coe_prod l))
    (prod_of_nat_multiset (↑l) h)

/-- If a `list ℕ+` consists only of primes, it can be recast as a `prime_multiset` with
  the coercion from lists to multisets. -/
def of_pnat_list (l : List ℕ+) (h : ∀ (p : ℕ+), p ∈ l → pnat.prime p) : prime_multiset :=
  of_pnat_multiset (↑l) h

theorem prod_of_pnat_list (l : List ℕ+) (h : ∀ (p : ℕ+), p ∈ l → pnat.prime p) : prod (of_pnat_list l h) = list.prod l :=
  eq.mp (Eq._oldrec (Eq.refl (prod (of_pnat_multiset (↑l) h) = multiset.prod ↑l)) (multiset.coe_prod l))
    (prod_of_pnat_multiset (↑l) h)

/-- The product map gives a homomorphism from the additive monoid
 of multisets to the multiplicative monoid ℕ+.
-/
theorem prod_zero : prod 0 = 1 :=
  id multiset.prod_zero

theorem prod_add (u : prime_multiset) (v : prime_multiset) : prod (u + v) = prod u * prod v := sorry

theorem prod_smul (d : ℕ) (u : prime_multiset) : prod (d •ℕ u) = prod u ^ d := sorry

end prime_multiset

namespace pnat

/-- The prime factors of n, regarded as a multiset -/
def factor_multiset (n : ℕ+) : prime_multiset :=
  prime_multiset.of_nat_list (nat.factors ↑n) sorry

/-- The product of the factors is the original number -/
theorem prod_factor_multiset (n : ℕ+) : prime_multiset.prod (factor_multiset n) = n := sorry

theorem coe_nat_factor_multiset (n : ℕ+) : ↑(factor_multiset n) = ↑(nat.factors ↑n) :=
  prime_multiset.to_of_nat_multiset (↑(nat.factors ↑n)) nat.mem_factors

end pnat

namespace prime_multiset

/-- If we start with a multiset of primes, take the product and
 then factor it, we get back the original multiset. -/
theorem factor_multiset_prod (v : prime_multiset) : pnat.factor_multiset (prod v) = v := sorry

end prime_multiset

namespace pnat

/-- Positive integers biject with multisets of primes. -/
def factor_multiset_equiv : ℕ+ ≃ prime_multiset :=
  equiv.mk factor_multiset prime_multiset.prod prod_factor_multiset prime_multiset.factor_multiset_prod

/-- Factoring gives a homomorphism from the multiplicative
 monoid ℕ+ to the additive monoid of multisets. -/
theorem factor_multiset_one : factor_multiset 1 = 0 :=
  rfl

theorem factor_multiset_mul (n : ℕ+) (m : ℕ+) : factor_multiset (n * m) = factor_multiset n + factor_multiset m := sorry

theorem factor_multiset_pow (n : ℕ+) (m : ℕ) : factor_multiset (n ^ m) = m •ℕ factor_multiset n := sorry

/-- Factoring a prime gives the corresponding one-element multiset. -/
theorem factor_multiset_of_prime (p : nat.primes) : factor_multiset ↑p = prime_multiset.of_prime p := sorry

/-- We now have four different results that all encode the
 idea that inequality of multisets corresponds to divisibility
 of positive integers. -/
theorem factor_multiset_le_iff {m : ℕ+} {n : ℕ+} : factor_multiset m ≤ factor_multiset n ↔ m ∣ n := sorry

theorem factor_multiset_le_iff' {m : ℕ+} {v : prime_multiset} : factor_multiset m ≤ v ↔ m ∣ prime_multiset.prod v := sorry

end pnat

namespace prime_multiset

theorem prod_dvd_iff {u : prime_multiset} {v : prime_multiset} : prod u ∣ prod v ↔ u ≤ v :=
  let h : pnat.factor_multiset (prod u) ≤ v ↔ prod u ∣ prod v := pnat.factor_multiset_le_iff';
  iff.symm (eq.mp (Eq._oldrec (Eq.refl (pnat.factor_multiset (prod u) ≤ v ↔ prod u ∣ prod v)) (factor_multiset_prod u)) h)

theorem prod_dvd_iff' {u : prime_multiset} {n : ℕ+} : prod u ∣ n ↔ u ≤ pnat.factor_multiset n := sorry

end prime_multiset

namespace pnat

/-- The gcd and lcm operations on positive integers correspond
 to the inf and sup operations on multisets.
-/
theorem factor_multiset_gcd (m : ℕ+) (n : ℕ+) : factor_multiset (gcd m n) = factor_multiset m ⊓ factor_multiset n := sorry

theorem factor_multiset_lcm (m : ℕ+) (n : ℕ+) : factor_multiset (lcm m n) = factor_multiset m ⊔ factor_multiset n := sorry

/-- The number of occurrences of p in the factor multiset of m
 is the same as the p-adic valuation of m. -/
theorem count_factor_multiset (m : ℕ+) (p : nat.primes) (k : ℕ) : ↑p ^ k ∣ m ↔ k ≤ multiset.count p (factor_multiset m) := sorry

end pnat

namespace prime_multiset

theorem prod_inf (u : prime_multiset) (v : prime_multiset) : prod (u ⊓ v) = pnat.gcd (prod u) (prod v) := sorry

theorem prod_sup (u : prime_multiset) (v : prime_multiset) : prod (u ⊔ v) = pnat.lcm (prod u) (prod v) := sorry


/-
Copyright (c) 2019 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel
-/
import topology.metric_space.hausdorff_distance
import topology.compacts
import analysis.specific_limits

/-!
# Closed subsets

This file defines the metric and emetric space structure on the types of closed subsets and nonempty
compact subsets of a metric or emetric space.

The Hausdorff distance induces an emetric space structure on the type of closed subsets
of an emetric space, called `closeds`. Its completeness, resp. compactness, resp.
second-countability, follow from the corresponding properties of the original space.

In a metric space, the type of nonempty compact subsets (called `nonempty_compacts`) also
inherits a metric space structure from the Hausdorff distance, as the Hausdorff edistance is
always finite in this context.
-/

noncomputable theory
open_locale classical topological_space ennreal

universe u
open classical set function topological_space filter

namespace emetric
section
variables {α : Type u} [emetric_space α] {s : set α}

/-- In emetric spaces, the Hausdorff edistance defines an emetric space structure
on the type of closed subsets -/
instance closeds.emetric_space : emetric_space (closeds α) :=
{ edist               := λs t, Hausdorff_edist s.val t.val,
  edist_self          := λs, Hausdorff_edist_self,
  edist_comm          := λs t, Hausdorff_edist_comm,
  edist_triangle      := λs t u, Hausdorff_edist_triangle,
  eq_of_edist_eq_zero :=
    λs t h, subtype.eq ((Hausdorff_edist_zero_iff_eq_of_closed s.property t.property).1 h) }

/-- The edistance to a closed set depends continuously on the point and the set -/
lemma continuous_inf_edist_Hausdorff_edist :
  continuous (λp : α × (closeds α), inf_edist p.1 (p.2).val) :=
begin
  refine continuous_of_le_add_edist 2 (by simp) _,
  rintros ⟨x, s⟩ ⟨y, t⟩,
  calc inf_edist x (s.val) ≤ inf_edist x (t.val) + Hausdorff_edist (t.val) (s.val) :
    inf_edist_le_inf_edist_add_Hausdorff_edist
  ... ≤ (inf_edist y (t.val) + edist x y) + Hausdorff_edist (t.val) (s.val) :
    add_le_add_right inf_edist_le_inf_edist_add_edist _
  ... = inf_edist y (t.val) + (edist x y + Hausdorff_edist (s.val) (t.val)) :
    by simp [add_comm, add_left_comm, Hausdorff_edist_comm, -subtype.val_eq_coe]
  ... ≤ inf_edist y (t.val) + (edist (x, s) (y, t) + edist (x, s) (y, t)) :
    add_le_add_left (add_le_add (le_max_left _ _) (le_max_right _ _)) _
  ... = inf_edist y (t.val) + 2 * edist (x, s) (y, t) :
    by rw [← mul_two, mul_comm]
end

/-- Subsets of a given closed subset form a closed set -/
lemma is_closed_subsets_of_is_closed (hs : is_closed s) :
  is_closed {t : closeds α | t.val ⊆ s} :=
begin
  refine is_closed_of_closure_subset (λt ht x hx, _),
  -- t : closeds α,  ht : t ∈ closure {t : closeds α | t.val ⊆ s},
  -- x : α,  hx : x ∈ t.val
  -- goal : x ∈ s
  have : x ∈ closure s,
  { refine mem_closure_iff.2 (λε εpos, _),
    rcases mem_closure_iff.1 ht ε εpos with ⟨u, hu, Dtu⟩,
    -- u : closeds α,  hu : u ∈ {t : closeds α | t.val ⊆ s},  hu' : edist t u < ε
    rcases exists_edist_lt_of_Hausdorff_edist_lt hx Dtu with ⟨y, hy, Dxy⟩,
    -- y : α,  hy : y ∈ u.val, Dxy : edist x y < ε
    exact ⟨y, hu hy, Dxy⟩ },
  rwa hs.closure_eq at this,
end

/-- By definition, the edistance on `closeds α` is given by the Hausdorff edistance -/
lemma closeds.edist_eq {s t : closeds α} : edist s t = Hausdorff_edist s.val t.val := rfl

/-- In a complete space, the type of closed subsets is complete for the
Hausdorff edistance. -/
instance closeds.complete_space [complete_space α] : complete_space (closeds α) :=
begin
  /- We will show that, if a sequence of sets `s n` satisfies
  `edist (s n) (s (n+1)) < 2^{-n}`, then it converges. This is enough to guarantee
  completeness, by a standard completeness criterion.
  We use the shorthand `B n = 2^{-n}` in ennreal. -/
  let B : ℕ → ℝ≥0∞ := λ n, (2⁻¹)^n,
  have B_pos : ∀ n, (0:ℝ≥0∞) < B n,
    by simp [B, ennreal.pow_pos],
  have B_ne_top : ∀ n, B n ≠ ⊤,
    by simp [B, ennreal.pow_ne_top],
  /- Consider a sequence of closed sets `s n` with `edist (s n) (s (n+1)) < B n`.
  We will show that it converges. The limit set is t0 = ⋂n, closure (⋃m≥n, s m).
  We will have to show that a point in `s n` is close to a point in `t0`, and a point
  in `t0` is close to a point in `s n`. The completeness then follows from a
  standard criterion. -/
  refine complete_of_convergent_controlled_sequences B B_pos (λs hs, _),
  let t0 := ⋂n, closure (⋃m≥n, (s m).val),
  let t : closeds α := ⟨t0, is_closed_Inter (λ_, is_closed_closure)⟩,
  use t,
  -- The inequality is written this way to agree with `edist_le_of_edist_le_geometric_of_tendsto₀`
  have I1 : ∀n:ℕ, ∀x ∈ (s n).val, ∃y ∈ t0, edist x y ≤ 2 * B n,
  { /- This is the main difficulty of the proof. Starting from `x ∈ s n`, we want
       to find a point in `t0` which is close to `x`. Define inductively a sequence of
       points `z m` with `z n = x` and `z m ∈ s m` and `edist (z m) (z (m+1)) ≤ B m`. This is
       possible since the Hausdorff distance between `s m` and `s (m+1)` is at most `B m`.
       This sequence is a Cauchy sequence, therefore converging as the space is complete, to
       a limit which satisfies the required properties. -/
    assume n x hx,
    obtain ⟨z, hz₀, hz⟩ : ∃ z : Π l, (s (n+l)).val, (z 0:α) = x ∧
      ∀ k, edist (z k:α) (z (k+1):α) ≤ B n / 2^k,
    { -- We prove existence of the sequence by induction.
      have : ∀ (l : ℕ) (z : (s (n+l)).val), ∃ z' : (s (n+l+1)).val, edist (z:α) z' ≤ B n / 2^l,
      { assume l z,
        obtain ⟨z', z'_mem, hz'⟩ : ∃ z' ∈ (s (n+l+1)).val, edist (z:α) z' < B n / 2^l,
        { apply exists_edist_lt_of_Hausdorff_edist_lt z.2,
          simp only [B, ennreal.inv_pow, div_eq_mul_inv],
          rw [← pow_add],
          apply hs; simp },
        exact ⟨⟨z', z'_mem⟩, le_of_lt hz'⟩ },
      use [λ k, nat.rec_on k ⟨x, hx⟩ (λl z, some (this l z)), rfl],
      exact λ k, some_spec (this k _) },
    -- it follows from the previous bound that `z` is a Cauchy sequence
    have : cauchy_seq (λ k, ((z k):α)),
      from cauchy_seq_of_edist_le_geometric_two (B n) (B_ne_top n) hz,
    -- therefore, it converges
    rcases cauchy_seq_tendsto_of_complete this with ⟨y, y_lim⟩,
    use y,
    -- the limit point `y` will be the desired point, in `t0` and close to our initial point `x`.
    -- First, we check it belongs to `t0`.
    have : y ∈ t0 := mem_Inter.2 (λk, mem_closure_of_tendsto y_lim
    begin
      simp only [exists_prop, set.mem_Union, filter.eventually_at_top, set.mem_preimage,
        set.preimage_Union],
      exact ⟨k, λ m hm, ⟨n+m, zero_add k ▸ add_le_add (zero_le n) hm, (z m).2⟩⟩
    end),
    use this,
    -- Then, we check that `y` is close to `x = z n`. This follows from the fact that `y`
    -- is the limit of `z k`, and the distance between `z n` and `z k` has already been estimated.
    rw [← hz₀],
    exact edist_le_of_edist_le_geometric_two_of_tendsto₀ (B n) hz y_lim },
  have I2 : ∀n:ℕ, ∀x ∈ t0, ∃y ∈ (s n).val, edist x y ≤ 2 * B n,
  { /- For the (much easier) reverse inequality, we start from a point `x ∈ t0` and we want
        to find a point `y ∈ s n` which is close to `x`.
        `x` belongs to `t0`, the intersection of the closures. In particular, it is well
        approximated by a point `z` in `⋃m≥n, s m`, say in `s m`. Since `s m` and
        `s n` are close, this point is itself well approximated by a point `y` in `s n`,
        as required. -/
    assume n x xt0,
    have : x ∈ closure (⋃m≥n, (s m).val), by apply mem_Inter.1 xt0 n,
    rcases mem_closure_iff.1 this (B n) (B_pos n) with ⟨z, hz, Dxz⟩,
    -- z : α,  Dxz : edist x z < B n,
    simp only [exists_prop, set.mem_Union] at hz,
    rcases hz with ⟨m, ⟨m_ge_n, hm⟩⟩,
    -- m : ℕ, m_ge_n : m ≥ n, hm : z ∈ (s m).val
    have : Hausdorff_edist (s m).val (s n).val < B n := hs n m n m_ge_n (le_refl n),
    rcases exists_edist_lt_of_Hausdorff_edist_lt hm this with ⟨y, hy, Dzy⟩,
    -- y : α,  hy : y ∈ (s n).val,  Dzy : edist z y < B n
    exact ⟨y, hy, calc
      edist x y ≤ edist x z + edist z y : edist_triangle _ _ _
            ... ≤ B n + B n : add_le_add (le_of_lt Dxz) (le_of_lt Dzy)
            ... = 2 * B n : (two_mul _).symm ⟩ },
  -- Deduce from the above inequalities that the distance between `s n` and `t0` is at most `2 B n`.
  have main : ∀n:ℕ, edist (s n) t ≤ 2 * B n := λn, Hausdorff_edist_le_of_mem_edist (I1 n) (I2 n),
  -- from this, the convergence of `s n` to `t0` follows.
  refine tendsto_at_top.2 (λε εpos, _),
  have : tendsto (λn, 2 * B n) at_top (𝓝 (2 * 0)),
    from ennreal.tendsto.const_mul
      (ennreal.tendsto_pow_at_top_nhds_0_of_lt_1 $ by simp [ennreal.one_lt_two])
      (or.inr $ by simp),
  rw mul_zero at this,
  obtain ⟨N, hN⟩ : ∃ N, ∀ b ≥ N, ε > 2 * B b,
    from ((tendsto_order.1 this).2 ε εpos).exists_forall_of_at_top,
  exact ⟨N, λn hn, lt_of_le_of_lt (main n) (hN n hn)⟩
end

/-- In a compact space, the type of closed subsets is compact. -/
instance closeds.compact_space [compact_space α] : compact_space (closeds α) :=
⟨begin
  /- by completeness, it suffices to show that it is totally bounded,
    i.e., for all ε>0, there is a finite set which is ε-dense.
    start from a set `s` which is ε-dense in α. Then the subsets of `s`
    are finitely many, and ε-dense for the Hausdorff distance. -/
  refine compact_of_totally_bounded_is_closed (emetric.totally_bounded_iff.2 (λε εpos, _))
    is_closed_univ,
  rcases exists_between εpos with ⟨δ, δpos, δlt⟩,
  rcases emetric.totally_bounded_iff.1
    (compact_iff_totally_bounded_complete.1 (@compact_univ α _ _)).1 δ δpos with ⟨s, fs, hs⟩,
  -- s : set α,  fs : finite s,  hs : univ ⊆ ⋃ (y : α) (H : y ∈ s), eball y δ
  -- we first show that any set is well approximated by a subset of `s`.
  have main : ∀ u : set α, ∃v ⊆ s, Hausdorff_edist u v ≤ δ,
  { assume u,
    let v := {x : α | x ∈ s ∧ ∃y∈u, edist x y < δ},
    existsi [v, ((λx hx, hx.1) : v ⊆ s)],
    refine Hausdorff_edist_le_of_mem_edist _ _,
    { assume x hx,
      have : x ∈ ⋃y ∈ s, ball y δ := hs (by simp),
      rcases mem_bUnion_iff.1 this with ⟨y, ys, dy⟩,
      have : edist y x < δ := by simp at dy; rwa [edist_comm] at dy,
      exact ⟨y, ⟨ys, ⟨x, hx, this⟩⟩, le_of_lt dy⟩ },
    { rintros x ⟨hx1, ⟨y, yu, hy⟩⟩,
      exact ⟨y, yu, le_of_lt hy⟩ }},
  -- introduce the set F of all subsets of `s` (seen as members of `closeds α`).
  let F := {f : closeds α | f.val ⊆ s},
  use F,
  split,
  -- `F` is finite
  { apply @finite_of_finite_image _ _ F (λf, f.val),
    { exact subtype.val_injective.inj_on F },
    { refine fs.finite_subsets.subset (λb, _),
      simp only [and_imp, set.mem_image, set.mem_set_of_eq, exists_imp_distrib],
      assume x hx hx',
      rwa hx' at hx }},
  -- `F` is ε-dense
  { assume u _,
    rcases main u.val with ⟨t0, t0s, Dut0⟩,
    have : is_closed t0 := (fs.subset t0s).is_compact.is_closed,
    let t : closeds α := ⟨t0, this⟩,
    have : t ∈ F := t0s,
    have : edist u t < ε := lt_of_le_of_lt Dut0 δlt,
    apply mem_bUnion_iff.2,
    exact ⟨t, ‹t ∈ F›, this⟩ }
end⟩

/-- In an emetric space, the type of non-empty compact subsets is an emetric space,
where the edistance is the Hausdorff edistance -/
instance nonempty_compacts.emetric_space : emetric_space (nonempty_compacts α) :=
{ edist               := λs t, Hausdorff_edist s.val t.val,
  edist_self          := λs, Hausdorff_edist_self,
  edist_comm          := λs t, Hausdorff_edist_comm,
  edist_triangle      := λs t u, Hausdorff_edist_triangle,
  eq_of_edist_eq_zero := λs t h, subtype.eq $ begin
    have : closure (s.val) = closure (t.val) := Hausdorff_edist_zero_iff_closure_eq_closure.1 h,
    rwa [s.property.2.is_closed.closure_eq,
              t.property.2.is_closed.closure_eq] at this,
  end }

/-- `nonempty_compacts.to_closeds` is a uniform embedding (as it is an isometry) -/
lemma nonempty_compacts.to_closeds.uniform_embedding :
  uniform_embedding (@nonempty_compacts.to_closeds α _ _) :=
isometry.uniform_embedding $ λx y, rfl

/-- The range of `nonempty_compacts.to_closeds` is closed in a complete space -/
lemma nonempty_compacts.is_closed_in_closeds [complete_space α] :
  is_closed (range $ @nonempty_compacts.to_closeds α _ _) :=
begin
  have : range nonempty_compacts.to_closeds = {s : closeds α | s.val.nonempty ∧ is_compact s.val},
    from range_inclusion _,
  rw this,
  refine is_closed_of_closure_subset (λs hs, ⟨_, _⟩),
  { -- take a set set t which is nonempty and at a finite distance of s
    rcases mem_closure_iff.1 hs ⊤ ennreal.coe_lt_top with ⟨t, ht, Dst⟩,
    rw edist_comm at Dst,
    -- since `t` is nonempty, so is `s`
    exact nonempty_of_Hausdorff_edist_ne_top ht.1 (ne_of_lt Dst) },
  { refine compact_iff_totally_bounded_complete.2 ⟨_, s.property.is_complete⟩,
    refine totally_bounded_iff.2 (λε εpos, _),
    -- we have to show that s is covered by finitely many eballs of radius ε
    -- pick a nonempty compact set t at distance at most ε/2 of s
    rcases mem_closure_iff.1 hs (ε/2) (ennreal.half_pos εpos) with ⟨t, ht, Dst⟩,
    -- cover this space with finitely many balls of radius ε/2
    rcases totally_bounded_iff.1 (compact_iff_totally_bounded_complete.1 ht.2).1 (ε/2)
      (ennreal.half_pos εpos) with ⟨u, fu, ut⟩,
    refine ⟨u, ⟨fu, λx hx, _⟩⟩,
    -- u : set α,  fu : finite u,  ut : t.val ⊆ ⋃ (y : α) (H : y ∈ u), eball y (ε / 2)
    -- then s is covered by the union of the balls centered at u of radius ε
    rcases exists_edist_lt_of_Hausdorff_edist_lt hx Dst with ⟨z, hz, Dxz⟩,
    rcases mem_bUnion_iff.1 (ut hz) with ⟨y, hy, Dzy⟩,
    have : edist x y < ε := calc
      edist x y ≤ edist x z + edist z y : edist_triangle _ _ _
      ... < ε/2 + ε/2 : ennreal.add_lt_add Dxz Dzy
      ... = ε : ennreal.add_halves _,
    exact mem_bUnion hy this },
end

/-- In a complete space, the type of nonempty compact subsets is complete. This follows
from the same statement for closed subsets -/
instance nonempty_compacts.complete_space [complete_space α] :
  complete_space (nonempty_compacts α) :=
(complete_space_iff_is_complete_range
  nonempty_compacts.to_closeds.uniform_embedding.to_uniform_inducing).2 $
  nonempty_compacts.is_closed_in_closeds.is_complete

/-- In a compact space, the type of nonempty compact subsets is compact. This follows from
the same statement for closed subsets -/
instance nonempty_compacts.compact_space [compact_space α] : compact_space (nonempty_compacts α) :=
⟨begin
  rw nonempty_compacts.to_closeds.uniform_embedding.embedding.compact_iff_compact_image,
  rw [image_univ],
  exact nonempty_compacts.is_closed_in_closeds.compact
end⟩

/-- In a second countable space, the type of nonempty compact subsets is second countable -/
instance nonempty_compacts.second_countable_topology [second_countable_topology α] :
  second_countable_topology (nonempty_compacts α) :=
begin
  haveI : separable_space (nonempty_compacts α) :=
  begin
    /- To obtain a countable dense subset of `nonempty_compacts α`, start from
    a countable dense subset `s` of α, and then consider all its finite nonempty subsets.
    This set is countable and made of nonempty compact sets. It turns out to be dense:
    by total boundedness, any compact set `t` can be covered by finitely many small balls, and
    approximations in `s` of the centers of these balls give the required finite approximation
    of `t`. -/
    rcases exists_countable_dense α with ⟨s, cs, s_dense⟩,
    let v0 := {t : set α | finite t ∧ t ⊆ s},
    let v : set (nonempty_compacts α) := {t : nonempty_compacts α | t.val ∈ v0},
    refine  ⟨⟨v, ⟨_, _⟩⟩⟩,
    { have : countable (subtype.val '' v),
      { refine (countable_set_of_finite_subset cs).mono (λx hx, _),
        rcases (mem_image _ _ _).1 hx with ⟨y, ⟨hy, yx⟩⟩,
        rw ← yx,
        exact hy },
      apply countable_of_injective_of_countable_image _ this,
      apply subtype.val_injective.inj_on },
    { refine λt, mem_closure_iff.2 (λε εpos, _),
      -- t is a compact nonempty set, that we have to approximate uniformly by a a set in `v`.
      rcases exists_between εpos with ⟨δ, δpos, δlt⟩,
      -- construct a map F associating to a point in α an approximating point in s, up to δ/2.
      have Exy : ∀x, ∃y, y ∈ s ∧ edist x y < δ/2,
      { assume x,
        rcases mem_closure_iff.1 (s_dense x) (δ/2) (ennreal.half_pos δpos) with ⟨y, ys, hy⟩,
        exact ⟨y, ⟨ys, hy⟩⟩ },
      let F := λx, some (Exy x),
      have Fspec : ∀x, F x ∈ s ∧ edist x (F x) < δ/2 := λx, some_spec (Exy x),

      -- cover `t` with finitely many balls. Their centers form a set `a`
      have : totally_bounded t.val := (compact_iff_totally_bounded_complete.1 t.property.2).1,
      rcases totally_bounded_iff.1 this (δ/2) (ennreal.half_pos δpos) with ⟨a, af, ta⟩,
      -- a : set α,  af : finite a,  ta : t.val ⊆ ⋃ (y : α) (H : y ∈ a), eball y (δ / 2)
      -- replace each center by a nearby approximation in `s`, giving a new set `b`
      let b := F '' a,
      have : finite b := af.image _,
      have tb : ∀x ∈ t.val, ∃y ∈ b, edist x y < δ,
      { assume x hx,
        rcases mem_bUnion_iff.1 (ta hx) with ⟨z, za, Dxz⟩,
        existsi [F z, mem_image_of_mem _ za],
        calc edist x (F z) ≤ edist x z + edist z (F z) : edist_triangle _ _ _
             ... < δ/2 + δ/2 : ennreal.add_lt_add Dxz (Fspec z).2
             ... = δ : ennreal.add_halves _ },
      -- keep only the points in `b` that are close to point in `t`, yielding a new set `c`
      let c := {y ∈ b | ∃x∈t.val, edist x y < δ},
      have : finite c := ‹finite b›.subset (λx hx, hx.1),
      -- points in `t` are well approximated by points in `c`
      have tc : ∀x ∈ t.val, ∃y ∈ c, edist x y ≤ δ,
      { assume x hx,
        rcases tb x hx with ⟨y, yv, Dxy⟩,
        have : y ∈ c := by simp [c, -mem_image]; exact ⟨yv, ⟨x, hx, Dxy⟩⟩,
        exact ⟨y, this, le_of_lt Dxy⟩ },
      -- points in `c` are well approximated by points in `t`
      have ct : ∀y ∈ c, ∃x ∈ t.val, edist y x ≤ δ,
      { rintros y ⟨hy1, ⟨x, xt, Dyx⟩⟩,
        have : edist y x ≤ δ := calc
          edist y x = edist x y : edist_comm _ _
          ... ≤ δ : le_of_lt Dyx,
        exact ⟨x, xt, this⟩ },
      -- it follows that their Hausdorff distance is small
      have : Hausdorff_edist t.val c ≤ δ :=
        Hausdorff_edist_le_of_mem_edist tc ct,
      have Dtc : Hausdorff_edist t.val c < ε := lt_of_le_of_lt this δlt,
      -- the set `c` is not empty, as it is well approximated by a nonempty set
      have hc : c.nonempty,
        from nonempty_of_Hausdorff_edist_ne_top t.property.1 (ne_top_of_lt Dtc),
      -- let `d` be the version of `c` in the type `nonempty_compacts α`
      let d : nonempty_compacts α := ⟨c, ⟨hc, ‹finite c›.is_compact⟩⟩,
      have : c ⊆ s,
      { assume x hx,
        rcases (mem_image _ _ _).1 hx.1 with ⟨y, ⟨ya, yx⟩⟩,
        rw ← yx,
        exact (Fspec y).1 },
      have : d ∈ v := ⟨‹finite c›, this⟩,
      -- we have proved that `d` is a good approximation of `t` as requested
      exact ⟨d, ‹d ∈ v›, Dtc⟩ },
  end,
  apply second_countable_of_separable,
end

end --section
end emetric --namespace

namespace metric
section

variables {α : Type u} [metric_space α]

/-- `nonempty_compacts α` inherits a metric space structure, as the Hausdorff
edistance between two such sets is finite. -/
instance nonempty_compacts.metric_space : metric_space (nonempty_compacts α) :=
emetric_space.to_metric_space $ λx y, Hausdorff_edist_ne_top_of_nonempty_of_bounded x.2.1 y.2.1
  (bounded_of_compact x.2.2) (bounded_of_compact y.2.2)

/-- The distance on `nonempty_compacts α` is the Hausdorff distance, by construction -/
lemma nonempty_compacts.dist_eq {x y : nonempty_compacts α} :
  dist x y = Hausdorff_dist x.val y.val := rfl

lemma lipschitz_inf_dist_set (x : α) :
  lipschitz_with 1 (λ s : nonempty_compacts α, inf_dist x s.val) :=
lipschitz_with.of_le_add $ assume s t,
by { rw dist_comm,
  exact inf_dist_le_inf_dist_add_Hausdorff_dist (edist_ne_top t s) }

lemma uniform_continuous_inf_dist_Hausdorff_dist :
  uniform_continuous (λp : α × (nonempty_compacts α), inf_dist p.1 (p.2).val) :=
lipschitz_inf_dist.uniform_continuous

end --section
end metric --namespace


import Aesop
import Mathlib.Data.Nat.Basic
import Mathlib.Algebra.Group.Basic

/-!
# `Aesop` demo

This file demonstrates some of the out-of-the-box
capabilities of the `Aesop` automation tool for `Lean4`.

The focus is on theorems that `Aesop` can directly prove
without any additional configuration.
-/

section PropositionalLogic

/-!
## Propositional logic using `Aesop`

`Aesop` can prove routine theorems in
propositional logic automatically.
-/

variable (P Q R : Prop)

example : P → P := by aesop

example : P → (Q → P) := by aesop

example : P ∧ Q → P ∨ Q := by aesop

example : P ∨ P ↔ P ∧ P := by aesop

example : (P → Q) → (¬Q → ¬P) := by aesop

example : (P ∨ Q)  ↔  (Q ∨ P) := by aesop

example : (P ∧ Q) → R  ↔  P → (Q → R) := by aesop

example : (P → (Q → R)) → ((P → R) → (P → R)) := by aesop

end PropositionalLogic

section TrivialLemmas

/-!

## Proving trivial lemmas with `Aesop`

`Aesop` uses Lean's simplifier internally, which
allows it to prove trivial lemmas by simplification.

-/

example {a b : ℕ} (h₁ : a = 5) (h₂ : b = 2 + 3) : a = b :=
  by aesop

example {a : ℕ} : a + 0 = 0 → a = 0 + 0 := by aesop

example {G : Type} [Group G] {g : G} : 1⁻¹ * 1 = g * 1 * g⁻¹ :=
  by aesop

example : [1, 2, 3] ≠ [] := by aesop

example {l : List α} {a : α} : a ∈ l → l ≠ [] := by aesop

end TrivialLemmas

/-
section TermConstruction

/-!
## Constructing terms of types

Just as `Aesop` can produce proofs of some propositions,
it can construct terms of some types.
-/

variable (A B C : Type _)

-- the identity function
example : A → A := by aesop

-- projection onto the first coordinate
example : A → B → A := by aesop

-- formally similar to the adjoint of a linear transformation
example : (A → B) → ((B → C) → (A → C)) := by aesop

-- formally similar to the differential map between tangent spaces of manifolds
example (f : A → B) : ((A → C) → C) → ((B → C) → C) := by aesop

end TermConstruction
-/


import GroundZero.HITs.Colimit
import GroundZero.Structures

open GroundZero.Structures
open GroundZero.Types
open GroundZero

namespace GroundZero.Types.Nat

universe u v w

def glue : ℕ → ℕ + 𝟏
| Nat.zero   => Coproduct.inr ★
| Nat.succ n => Coproduct.inl n

def peelOff : ℕ + 𝟏 → ℕ
| Coproduct.inr _ => Nat.zero
| Coproduct.inl n => Nat.succ n

hott def closedNat : ℕ ≃ ℕ + 𝟏 :=
begin
  existsi glue; apply Prod.mk <;> existsi peelOff <;> intro n;
  { induction n using Nat.casesOn <;> reflexivity };
  { induction n using Sum.casesOn <;> reflexivity }
end

hott def equivAddition {A : Type u} {B : Type v} (C : Type w) (e : A ≃ B) : A + C ≃ B + C :=
begin
  let f : A + C → B + C := λ x, match x with
  | Coproduct.inl a => Coproduct.inl (e a)
  | Coproduct.inr c => Coproduct.inr c;
  let g : B + C → A + C := λ x, match x with
  | Coproduct.inl b => Coproduct.inl (e.left b)
  | Coproduct.inr c => Coproduct.inr c;

  existsi f; apply Prod.mk <;> existsi g;
  { intro x; induction x using Sum.casesOn;
    apply Id.map Sum.inl; apply e.leftForward; reflexivity };
  { intro x; induction x using Sum.casesOn;
    apply Id.map Sum.inl; apply e.forwardLeft; reflexivity }
end

example : ℕ ≃ (ℕ + 𝟏) + 𝟏 :=
begin transitivity; exact closedNat; apply equivAddition; exact closedNat end

hott def natPlusUnit : Π n, ℕ ≃ pt ℕ n
| Nat.zero   => Equiv.ideqv _
| Nat.succ n => Equiv.trans closedNat (equivAddition 𝟏 (natPlusUnit n))

hott def liftUnit (n : ℕ) : pt 𝟏 n → pt 𝟏 (n + 1) :=
Coproduct.inl

hott def liftToTop (x : 𝟏) : Π n, pt 𝟏 n
| Nat.zero   => x
| Nat.succ n => Coproduct.inl (liftToTop x n)

hott def Iterated := HITs.Colimit (pt 𝟏) liftUnit

def Iterated.encode : ℕ → Iterated
| Nat.zero   => HITs.Colimit.inclusion 0 ★
| Nat.succ n => HITs.Colimit.inclusion (n + 1) (Coproduct.inr ★)

hott def code : ℕ → ℕ → Type
| Nat.zero,   Nat.zero   => 𝟏
| Nat.succ m, Nat.zero   => 𝟎
| Nat.zero,   Nat.succ n => 𝟎
| Nat.succ m, Nat.succ n => code m n

hott def r : Π n, code n n
| Nat.zero   => ★
| Nat.succ n => r n

hott def encode {m n : ℕ} (p : m = n) : code m n :=
Equiv.subst p (r m)

hott def decode : Π {m n : ℕ}, code m n → m = n
| Nat.zero,   Nat.zero,   p => idp 0
| Nat.succ m, Nat.zero,   p => Proto.Empty.elim p
| Nat.zero,   Nat.succ n, p => Proto.Empty.elim p
| Nat.succ m, Nat.succ n, p => Id.map Nat.succ (decode p)

hott def decodeEncodeIdp : Π m, decode (encode (idp m)) = idp m
| Nat.zero   => idp _
| Nat.succ m => Id.map _ (decodeEncodeIdp m)

hott def decodeEncode {m n : ℕ} (p : m = n) : decode (encode p) = p :=
begin induction p; apply decodeEncodeIdp end

hott def encodeDecode : Π {m n : ℕ} (p : code m n), encode (decode p) = p
| Nat.zero,   Nat.zero,   ★ => idp ★
| Nat.succ m, Nat.zero,   p => Proto.Empty.elim p
| Nat.zero,   Nat.succ n, p => Proto.Empty.elim p
| Nat.succ m, Nat.succ n, p => begin
  transitivity; symmetry;
  apply @Equiv.transportComp ℕ ℕ (code (m + 1)) m n
        Nat.succ (decode p) (r (m + 1));
  apply encodeDecode
end

hott def recognize (m n : ℕ) : m = n ≃ code m n :=
⟨encode, (⟨decode, decodeEncode⟩, ⟨decode, encodeDecode⟩)⟩

end GroundZero.Types.Nat


/-
Copyright (c) 2019 The Flypitch Project. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.

Authors: Jesse Han, Floris van Doorn
-/
/- Show that every theory can be extended to a complete theory -/

import .compactness order.zorn

local attribute [instance, priority 0] classical.prop_decidable
open fol set

universe variables u v
section
parameter L : Language.{u}

open classical zorn

lemma inconsis_not_of_provable {L} {T : Theory L} {f : sentence L} :
  T ⊢' f → ¬ is_consistent (T ∪ {∼f}) :=
begin
  intro H, suffices : (T ∪ {∼f}) ⊢' (⊥ : sentence L), by tidy,
  apply snot_and_self' _, exact f, apply nonempty.intro, apply andI,
  apply weakening, show set (formula L), exact T.fst, tidy, exact or.inr (by assumption),
  exact classical.choice H, apply axm, tidy
end

lemma provable_of_inconsis_not {L} {T : Theory L} {f : sentence L} :
¬ is_consistent (T ∪ {∼f})  → T ⊢' f :=
begin
by_contra, simp[*,-a] at a, cases a with a1 a2, apply consis_not_of_not_provable a2,
exact classical.by_contradiction (by tidy)
end

/-- Given a theory T and a sentence ψ, either T ∪ {ψ} or T ∪ {∼ ψ} is consistent.--/
lemma can_extend {L : Language} (T : Theory L) (ψ : sentence L) (h : is_consistent T) :
  is_consistent (T ∪ {ψ}) ∨ is_consistent (T ∪ {∼ ψ}) :=
begin
  simp only [is_consistent, set.union_singleton], by_contra,
  rw[not_or_distrib] at a, rcases a with ⟨H1, H2⟩,
  suffices : T ⊢' (⊥ : sentence L), by contradiction,
  exact snot_and_self'' (simpI' (classical.by_contradiction H1)) (simpI' (classical.by_contradiction H2))
end
  -- simp[is_consistent],  by_contra,  rename a hc, rw[not_or_distrib] at hc,
  -- have hc1 := classical.by_contradiction hc.1,
  -- have hc2 := classical.by_contradiction hc.2,
  -- have hc_uno : T ⊢'  ∼ψ,
  --   exact hc1.map simpI,
  -- have hc_dos : T ⊢' ∼∼ψ,
  --   exact hc2.map simpI,
  -- exact hc_dos.map2 (impE _) hc_uno

/-
Now, we have to show that given an arbitrary chain in this poset, we can obtain an upper bound in this chain. We do this by taking the union.
-/

/- Given a set of theories and a proof that they form a chain under set-inclusion, return their union and a proof that this contains every theory in the chain
-/

lemma nonempty_of_not_empty {α : Type u} (s : set α) (h : ¬ s = ∅) : nonempty s :=
by rwa [coe_nonempty_iff_ne_empty]

/-- Theory_over T is the subtype of Theory L consisting of consistent theories T' such that T' ⊇ T--/
def Theory_over {L : Language.{u}} (T : Theory L) (hT : is_consistent T): Type u :=
{T' : Theory L // T ⊆ T' ∧ is_consistent T'}

/-- Every theory T is trivially a theory over itself --/
def over_self {L : Language} (T : Theory L) (hT : is_consistent T): Theory_over T hT:=
  by {refine ⟨T, _⟩, split, trivial, assumption}

/-- Given two consistent theories T₁ and T₂ over T, say that T₁ ⊆ T₂ if T₁ ⊆ T₂--/
def Theory_over_subset {L : Language.{u}} {T : Theory L} {hT : is_consistent T} : Theory_over T hT → Theory_over T hT→ Prop
:= λ T1 T2, T1.val ⊆ T2.val

instance {T : Theory L} {hT : is_consistent T} : has_subset (Theory_over T hT) := ⟨Theory_over_subset⟩

instance {T : Theory L} {hT : is_consistent T} : nonempty (Theory_over T hT) := ⟨over_self T hT⟩

/- Given a sentence and the hypothesis that ψ is provable from a theory T, return a list of sentences from T and a proof that this list proves ψ -/
-- TODO: refactor this away, use theory_proof_compactness
noncomputable def theory_proof_compactness' {L : Language} (T : Theory L) (ψ : sentence L) (hψ : T ⊢' ψ) : Σ' Γ : list (sentence L), {ϕ : sentence L | ϕ ∈ Γ} ⊢' ψ ∧ {ϕ : sentence L | ϕ ∈ Γ} ⊆ T :=
begin
  apply psigma_of_exists,
  rcases theory_proof_compactness hψ with ⟨Γ, H, K⟩,
  cases Γ with Γ hΓ, induction Γ, swap, refl,
  exact ⟨Γ, H, K⟩
end

/- Given a chain of sets with nonempty union, conclude that the chain is nonempty-/
def nonempty_chain_of_nonempty_union {α : Type u} {A_i : set $ set α} {h_chain : chain (⊆) A_i}
  (h : nonempty $ set.sUnion A_i) : nonempty A_i :=
by { unfreezeI, rcases h with ⟨a, s, hs, ha⟩, exact ⟨⟨s, hs⟩⟩ }

/- Given two elements in a chain of sets over T, their union over T is in the chain -/
lemma in_chain_of_union {α : Type u} (T : set α) (A_i : set $ set α)
  (h_chain : chain set.subset A_i) (as : list A_i) (h_over_T : ∀ A ∈ A_i, T ⊆ A) (A1 A2 ∈ A_i) :
  A1 ∪ A2 = A1 ∨ A1 ∪ A2 = A2 :=
begin
dedup,
unfold has_union.union set.union has_mem.mem set.mem,
unfold chain set.pairwise_on at h_chain,
by_cases A1 = A2,
  simp*, finish,
  have := h_chain A1 H A2 H_1 h, cases this,
  {fapply or.inr, apply funext, intro x, apply propext, split,
  intro h1, have : A1 x ∨ A2 x, by assumption, fapply or.elim, exact A1 x, exact A2 x, assumption,
  intro hx, dedup, unfold set.subset at this, exact this hx, finish,
  intro hx, apply or.inr, assumption},

  {fapply or.inl, apply funext, intro x, apply propext, split,
  intro hx, have : A1 x ∨ A2 x, by assumption, fapply or.elim, exact A2 x, exact A1 x, finish,
  intro h2x, dedup, unfold set.subset at this, exact this h2x, finish,
intro h3x, apply or.inl, assumption}
end

/--Given a chain and two elements from this chain, return their maximum. --/
noncomputable def max_in_chain {α : Type u} {R : α → α → Prop} {Ts : set α}
  {nonempty_Ts : nonempty Ts} (h_chain : chain R Ts) (S1 S2 : α) (h_S1 : S1 ∈ Ts) (h_S2 : S2 ∈ Ts) :
  Σ' (S : α), (S = S1 ∧ (R S2 S1 ∨ S1 = S2)) ∨ (S = S2 ∧ (R S1 S2 ∨ S1 = S2)) :=
begin
  unfold chain set.pairwise_on at h_chain,
  have := h_chain S1 h_S1 S2 h_S2,
  by_cases S1 = S2,

    refine ⟨S1, _ ⟩, fapply or.inl, fapply and.intro, exact rfl, exact or.inr h,

    have H := this h,
    by_cases R S1 S2,
      refine ⟨S2, _⟩, fapply or.inr, refine and.intro rfl _, exact or.inl h,

      tactic.unfreeze_local_instances, dedup, simp[*, -H] at H, refine ⟨S1, _⟩, fapply or.inl,
      refine and.intro rfl _, exact or.inl H
end

/--Given a nonempty chain under a transitive relation and a list of elements from this chain, return an upper bound, with the maximum of the empty list defined to be the witness to the nonempty --/
noncomputable def max_of_list_in_chain {α : Type u} {R : α → α → Prop} {trans : ∀{a b c}, R a b → R b c → R a c} {Ts : set α} {nonempty_Ts : nonempty Ts} (h_chain : chain R Ts) (Ss : list α) -- {nonempty_Ss : nonempty {S | S ∈ Ss}}
(h_fs : ∀ S ∈ Ss, S ∈ Ts) : Σ' (S : α), S ∈ Ts ∧ (∀ S' ∈ Ss, S' = S ∨ R S' S) :=
begin
  induction Ss,

  {tactic.unfreeze_local_instances, have := (classical.choice nonempty_Ts),
   from ⟨this.1, ⟨this.2, by finish⟩⟩},

  specialize Ss_ih (by simp at h_fs; from h_fs.right),
  rcases Ss_ih with ⟨S,H_mem,H_s⟩,
  by_cases (R S Ss_hd),
    {use Ss_hd, use (by simp*), intros S' HS', cases HS',
      from or.inl ‹_›, right, by_cases S' = S, rwa[h], finish},
    {use S, use H_mem, intros S' HS', cases HS',
      {subst HS', by_cases S' = S, from or.inl ‹_›,
       unfold chain pairwise_on at h_chain,
        specialize h_chain S' (by simp at h_fs; from h_fs.left) S ‹_› ‹_›, finish},
     finish}
end

/-- Given a xs : list α, it is naturally a list {x ∈ α | x ∈ xs} --/
def list_is_list_of_subtype : Π(α : Type u), Π (fs : list α),  Σ' xs : list ↥{f : α | f ∈ fs}, ∀ f, ∀ h : f ∈ fs, (⟨f,h⟩ : ↥{f : α | f ∈ fs}) ∈ xs :=
begin
  intros α fs, induction fs with fs_hd fs_tl ih,
    { exact ⟨[], by simp⟩ },
    {  let F : {f | f ∈ fs_tl} → {f | f ∈ list.cons fs_hd fs_tl},
         by {intro f, refine ⟨f, _⟩, fapply or.inr, exact f.property},
    refine ⟨_,_⟩,
      { refine _::_,
        { exact ⟨fs_hd, by simp⟩ },
        { exact list.map F ih.fst }  },
      { intro a, classical, by_cases a = fs_hd,
        { finish },
        { tidy, right, tidy }}},
end

/-- The limit theory of a chain of consistent theories over T is consistent --/
lemma consis_limit {L : Language} {T : Theory L} {hT : is_consistent T} (Ts : set (Theory_over T hT)) (h_chain : chain Theory_over_subset Ts) : is_consistent (T ∪ set.sUnion (subtype.val '' Ts)) :=
begin
  intro h_inconsis,
  by_cases nonempty Ts, swap,
  { simp at h, simp[*, -h_inconsis] at h_inconsis, unfold is_consistent at hT, apply hT,
    rw [←union_empty T], convert h_inconsis, symmetry, apply bUnion_empty },

  have Γpair := theory_proof_compactness' (T ∪ ⋃₀(subtype.val '' Ts)) ⊥ h_inconsis,
  have h_bad : ∃ T' : (Theory L), (T' ∈ (subtype.val '' Ts)) ∧ {ψ | ψ ∈ Γpair.fst} ⊆ T',

 {cases Γpair with fs Hfs, rename h hTs,
  have dSs : Π f ∈ fs, Σ' S_f : (Theory_over T hT), set.mem S_f Ts ∧ (set.mem (f) (S_f.val)), -- to each f in fs, associate an S_f containing f from the chain
    {  intros f hf, have H := Hfs.right,
  unfold set.image set.sUnion set.subset set.mem list.mem at H,
  have H' := H hf,  by_cases f ∈ T,
  split, swap, {exact (classical.choice hTs).val},
  {fapply and.intro, exact (choice hTs).property,
    have H := (choice hTs).val.property.left,
    exact H h},

    simp[*, -H'] at H',
    have witness := indefinite_description _ H', simp* at witness,
    split, swap, split, swap, exact witness.val, cases witness.property with case1 case2, cases case1 with case1' case1'', exact case1',
split, have witness_property := witness.property, cases witness_property with case1 case2, cases case1 with case1' case1'', exact case1'',
have witness_property := witness.property, cases witness_property with case1 case2, exact case2,},

  have T_max : Σ' (T_max : Theory_over T hT), (T_max ∈ Ts) ∧ ∀ ψ ∈ fs, (ψ) ∈ T_max.val,  -- get the theory and a proof that it contains all the f
    {  let F : {f | f ∈ fs} → Theory_over T hT :=
    begin intro f, exact (dSs f.val f.property).fst end,
 let fs_list_subtype := list_is_list_of_subtype _ fs,
 let T_list : list (Theory_over T hT) :=
    begin fapply list.map F, exact fs_list_subtype.fst end,
  have T_list_subset_Ts : (∀ (S : Theory_over T hT), S ∈ T_list → S ∈ Ts),
    intro S, simp [-sigma.exists, -sigma.forall], intros x h1 h2, simp [*,-h2] at h2, rw[<-h2.right],
    have := (dSs x h1).snd.left, assumption,

  have max_of_list := max_of_list_in_chain h_chain T_list T_list_subset_Ts,
  split, swap,
    {exact max_of_list.fst},
    {split, exact max_of_list.snd.left,
      {intros f hf,
        have almost_there : f ∈ (F ⟨f, begin simpa end⟩).val, simp*, exact (dSs f hf).snd.right,
        have nearly_there : (F ⟨f, begin simpa end⟩) ⊆ max_of_list.fst,
          have := max_of_list.snd.right (F ⟨f, begin simpa end⟩),
          have so_close : F ⟨f, _⟩ = max_of_list.fst ∨ Theory_over_subset (F ⟨f, _⟩) (max_of_list.fst),
            begin
            refine this _, simp [*, -sigma.exists], fapply exists.intro, exact f, fapply exists.intro,
            exact hf, fapply and.intro, unfold has_mem.mem list.mem,
            {apply fs_list_subtype.snd},
            {refl},
            end,
        cases so_close with case1 case2,
        rw[case1], intros a h, exact h,
        exact case2,
        exact nearly_there almost_there,
        },
      },
    {intros a b c, unfold Theory_over_subset, fapply subset.trans},
    {assumption}},

  fapply exists.intro, exact T_max.fst.val,
  fapply and.intro, fapply set.mem_image_of_mem, exact T_max.snd.left,
  have := T_max.snd.right, intros ψ hψ, exact this ψ hψ},

  let T_bad := @strong_indefinite_description (Theory L) (λ S, S ∈ (subtype.val '' Ts) ∧ ({ϕ | ϕ ∈ Γpair.fst} ⊆ S))  begin apply_instance end,
  have T_bad_inconsis : sprovable T_bad.val ⊥,
  fapply nonempty.intro,
  fapply sweakening (T_bad.property h_bad).right,
  exact classical.choice Γpair.snd.left,
  have T_bad_consis : is_consistent T_bad.val,
    {have almost_done := (T_bad.property h_bad).left,
    simp[set.image] at almost_done,
    cases almost_done with H _, from H.right},
    exact T_bad_consis T_bad_inconsis,
end

/-- Given a chain of consistent extensions of a theory T, return the union of those theories and a proof that this is a consistent extension of T --/
def limit_theory {L : Language} {T : Theory L} {hT : is_consistent T} (Ts : set (Theory_over T hT)) (h_chain : chain Theory_over_subset Ts) : Σ' T : Theory_over T hT, ∀ T' ∈ Ts, T' ⊆ T :=
begin
refine ⟨⟨T ∪ set.sUnion (subtype.val '' Ts), _⟩, _⟩, simp*, intro,
exact @consis_limit L T hT Ts h_chain begin simp* end,
intros T' hT' ψ hψ, right, split, swap, exact T'.val,
apply exists.intro, swap, exact hψ, simp*, exact T'.property
end

/-- Given a theory T, show that the poset of theories over T satisfies the hypotheses of Zorn's lemma --/
lemma can_use_zorn {L : Language.{u}} {T : Theory L} {hT : is_consistent T}  : (∀c, @chain (Theory_over T hT) Theory_over_subset c → ∃ub, ∀a∈c, a ⊆ ub) ∧ (∀(a b c : Theory_over T hT), a ⊆ b → b ⊆ c → a ⊆ c) :=
begin
  split,  intro Ts, intro h_chain, let S := limit_theory Ts h_chain,
  let T_infty := S.fst,  let H_infty := S.snd,
  refine exists.intro _ _,  exact T_infty, intro T', intro H',
  finish, tidy
end

/-- Given a consistent theory T, return a maximal extension of it given by Zorn's lemma, along with the proof that it is consistent and maximal --/
noncomputable def maximal_extension (L : Language.{u}) (T : Theory L) (hT : is_consistent T) :
  Σ' (T_max : Theory_over T hT), ∀ T' : Theory_over T hT, T_max ⊆ T' → T' ⊆ T_max :=
begin
  let X := strong_indefinite_description (λ T_max : Theory_over T hT, ∀ T' : Theory_over T hT, T_max ⊆ T' → T' ⊆ T_max ) begin apply_instance end,
  have := @can_use_zorn L T, rename this h_can_use,
  have := exists_maximal_of_chains_bounded h_can_use.left h_can_use.right, rename this h_zorn,
  let T_max := X.val, let H := X.property,
  exact ⟨T_max, H h_zorn⟩,
end

/-- The maximal extension returned by maximal_extension cannot be extended. --/
lemma cannot_extend_maximal_extension {L : Language} {T : Theory L} {hT : is_consistent T} (T_max' : Σ' (T_max : Theory_over T hT), ∀ T' : Theory_over T hT, T_max ⊆ T' → T' ⊆ T_max) (ψ : sentence L) (H : is_consistent (T_max'.fst.val ∪ {ψ}))(H1 : ψ ∉ T_max'.fst.val) : false :=
begin
  let T_bad : Theory_over T hT :=
    by {refine ⟨T_max'.fst.val ∪ {ψ}, ⟨_, H⟩⟩, simp[has_subset.subset], intros ψ hψT,
        dedup, have extension_assumption := T_max'.fst.property.left, simp[has_insert.insert],
        from or.inr (extension_assumption ‹_›)},
  have h_bad := T_max'.snd T_bad,
  from absurd (h_bad (by finish) (by simp[has_insert.insert])) H1
end

/-- Given a maximal consistent extension of consistent theory T, show it is complete --/
lemma complete_maximal_extension_of_consis {L : Language} {T : Theory L} {hT : is_consistent T}: @is_complete L (@maximal_extension L T hT).fst.val :=
begin
  refine ⟨(@maximal_extension L T hT).fst.property.right, _⟩,
  intro ψ, by_cases ψ ∈ (@maximal_extension L T hT).fst.val, exact or.inl h,
  apply or.inr,
  by_contra,
  have can_extend := @can_extend L (@maximal_extension L T hT).fst.val ψ (@maximal_extension L T hT).fst.property.right,
  have h_max := (@maximal_extension L T hT).snd,

  by_cases is_consistent ((@maximal_extension L T hT).fst.val ∪ {ψ}),
    {rename h h1,
      from cannot_extend_maximal_extension _ _ ‹_› ‹_›},
  {rename h h2,
  have q_of_not_p : ∀ p q : Prop, ∀ h1 : p ∨ q, ∀ h2 : ¬ p, q := by tauto,
  have h2' := q_of_not_p _ _ can_extend h2,
  from cannot_extend_maximal_extension _ _ ‹_› ‹_›}
end

/-- Given a consistent theory, return a complete extension of it --/
noncomputable def completion_of_consis : Π ( T : Theory L) (h_consis : is_consistent T), Σ' T' : (Theory_over T h_consis), is_complete T'.val :=
λ T h_consis, ⟨(maximal_extension L T h_consis).fst, by apply complete_maximal_extension_of_consis⟩

end