/-
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.baire
import analysis.normed_space.operator_norm
import analysis.normed_space.affine_isometry

/-!
# Banach open mapping theorem

This file contains the Banach open mapping theorem, i.e., the fact that a bijective
bounded linear map between Banach spaces has a bounded inverse.
-/

open function metric set filter finset
open_locale classical topological_space big_operators nnreal

variables {𝕜 : Type*} [nondiscrete_normed_field 𝕜]
{E : Type*} [normed_group E] [normed_space 𝕜 E]
{F : Type*} [normed_group F] [normed_space 𝕜 F]
(f : E →L[𝕜] F)
include 𝕜

namespace continuous_linear_map

/-- A (possibly nonlinear) right inverse to a continuous linear map, which doesn't have to be
linear itself but which satisfies a bound `∥inverse x∥ ≤ C * ∥x∥`. A surjective continuous linear
map doesn't always have a continuous linear right inverse, but it always has a nonlinear inverse
in this sense, by Banach's open mapping theorem. -/
structure nonlinear_right_inverse :=
(to_fun : F → E)
(nnnorm : ℝ≥0)
(bound' : ∀ y, ∥to_fun y∥ ≤ nnnorm * ∥y∥)
(right_inv' : ∀ y, f (to_fun y) = y)

instance : has_coe_to_fun (nonlinear_right_inverse f) (λ _, F → E) := ⟨λ fsymm, fsymm.to_fun⟩

@[simp] lemma nonlinear_right_inverse.right_inv {f : E →L[𝕜] F} (fsymm : nonlinear_right_inverse f)
  (y : F) : f (fsymm y) = y :=
fsymm.right_inv' y

lemma nonlinear_right_inverse.bound {f : E →L[𝕜] F} (fsymm : nonlinear_right_inverse f) (y : F) :
  ∥fsymm y∥ ≤ fsymm.nnnorm * ∥y∥ :=
fsymm.bound' y

end continuous_linear_map

/-- Given a continuous linear equivalence, the inverse is in particular an instance of
`nonlinear_right_inverse` (which turns out to be linear). -/
noncomputable def continuous_linear_equiv.to_nonlinear_right_inverse (f : E ≃L[𝕜] F) :
  continuous_linear_map.nonlinear_right_inverse (f : E →L[𝕜] F) :=
{ to_fun := f.inv_fun,
  nnnorm := nnnorm (f.symm : F →L[𝕜] E),
  bound' := λ y, continuous_linear_map.le_op_norm (f.symm : F →L[𝕜] E) _,
  right_inv' := f.apply_symm_apply }

noncomputable instance (f : E ≃L[𝕜] F) :
  inhabited (continuous_linear_map.nonlinear_right_inverse (f : E →L[𝕜] F)) :=
⟨f.to_nonlinear_right_inverse⟩

/-! ### Proof of the Banach open mapping theorem -/

variable [complete_space F]

/--
First step of the proof of the Banach open mapping theorem (using completeness of `F`):
by Baire's theorem, there exists a ball in `E` whose image closure has nonempty interior.
Rescaling everything, it follows that any `y ∈ F` is arbitrarily well approached by
images of elements of norm at most `C * ∥y∥`.
For further use, we will only need such an element whose image
is within distance `∥y∥/2` of `y`, to apply an iterative process. -/
lemma exists_approx_preimage_norm_le (surj : surjective f) :
  ∃C ≥ 0, ∀y, ∃x, dist (f x) y ≤ 1/2 * ∥y∥ ∧ ∥x∥ ≤ C * ∥y∥ :=
begin
  have A : (⋃n:ℕ, closure (f '' (ball 0 n))) = univ,
  { refine subset.antisymm (subset_univ _) (λy hy, _),
    rcases surj y with ⟨x, hx⟩,
    rcases exists_nat_gt (∥x∥) with ⟨n, hn⟩,
    refine mem_Union.2 ⟨n, subset_closure _⟩,
    refine (mem_image _ _ _).2 ⟨x, ⟨_, hx⟩⟩,
    rwa [mem_ball, dist_eq_norm, sub_zero] },
  have : ∃ (n : ℕ) x, x ∈ interior (closure (f '' (ball 0 n))) :=
    nonempty_interior_of_Union_of_closed (λn, is_closed_closure) A,
  simp only [mem_interior_iff_mem_nhds, metric.mem_nhds_iff] at this,
  rcases this with ⟨n, a, ε, ⟨εpos, H⟩⟩,
  rcases normed_field.exists_one_lt_norm 𝕜 with ⟨c, hc⟩,
  refine ⟨(ε/2)⁻¹ * ∥c∥ * 2 * n, _, λy, _⟩,
  { refine mul_nonneg (mul_nonneg (mul_nonneg _ (norm_nonneg _)) (by norm_num)) _,
    exacts [inv_nonneg.2 (div_nonneg (le_of_lt εpos) (by norm_num)), n.cast_nonneg] },
  { by_cases hy : y = 0,
    { use 0, simp [hy] },
    { rcases rescale_to_shell hc (half_pos εpos) hy with ⟨d, hd, ydlt, leyd, dinv⟩,
      let δ := ∥d∥ * ∥y∥/4,
      have δpos : 0 < δ :=
        div_pos (mul_pos (norm_pos_iff.2 hd) (norm_pos_iff.2 hy)) (by norm_num),
      have : a + d • y ∈ ball a ε,
        by simp [dist_eq_norm, lt_of_le_of_lt ydlt.le (half_lt_self εpos)],
      rcases metric.mem_closure_iff.1 (H this) _ δpos with ⟨z₁, z₁im, h₁⟩,
      rcases (mem_image _ _ _).1 z₁im with ⟨x₁, hx₁, xz₁⟩,
      rw ← xz₁ at h₁,
      rw [mem_ball, dist_eq_norm, sub_zero] at hx₁,
      have : a ∈ ball a ε, by { simp, exact εpos },
      rcases metric.mem_closure_iff.1 (H this) _ δpos with ⟨z₂, z₂im, h₂⟩,
      rcases (mem_image _ _ _).1 z₂im with ⟨x₂, hx₂, xz₂⟩,
      rw ← xz₂ at h₂,
      rw [mem_ball, dist_eq_norm, sub_zero] at hx₂,
      let x := x₁ - x₂,
      have I : ∥f x - d • y∥ ≤ 2 * δ := calc
        ∥f x - d • y∥ = ∥f x₁ - (a + d • y) - (f x₂ - a)∥ :
          by { congr' 1, simp only [x, f.map_sub], abel }
        ... ≤ ∥f x₁ - (a + d • y)∥ + ∥f x₂ - a∥ :
          norm_sub_le _ _
        ... ≤ δ + δ : begin
            apply add_le_add,
            { rw [← dist_eq_norm, dist_comm], exact le_of_lt h₁ },
            { rw [← dist_eq_norm, dist_comm], exact le_of_lt h₂ }
          end
        ... = 2 * δ : (two_mul _).symm,
      have J : ∥f (d⁻¹ • x) - y∥ ≤ 1/2 * ∥y∥ := calc
        ∥f (d⁻¹ • x) - y∥ = ∥d⁻¹ • f x - (d⁻¹ * d) • y∥ :
          by rwa [f.map_smul _, inv_mul_cancel, one_smul]
        ... = ∥d⁻¹ • (f x - d • y)∥ : by rw [mul_smul, smul_sub]
        ... = ∥d∥⁻¹ * ∥f x - d • y∥ : by rw [norm_smul, normed_field.norm_inv]
        ... ≤ ∥d∥⁻¹ * (2 * δ) : begin
            apply mul_le_mul_of_nonneg_left I,
            rw inv_nonneg,
            exact norm_nonneg _
          end
        ... = (∥d∥⁻¹ * ∥d∥) * ∥y∥ /2 : by { simp only [δ], ring }
        ... = ∥y∥/2 : by { rw [inv_mul_cancel, one_mul],  simp [norm_eq_zero, hd] }
        ... = (1/2) * ∥y∥ : by ring,
      rw ← dist_eq_norm at J,
      have K : ∥d⁻¹ • x∥ ≤ (ε / 2)⁻¹ * ∥c∥ * 2 * ↑n * ∥y∥ := calc
        ∥d⁻¹ • x∥ = ∥d∥⁻¹ * ∥x₁ - x₂∥ : by rw [norm_smul, normed_field.norm_inv]
        ... ≤ ((ε / 2)⁻¹ * ∥c∥ * ∥y∥) * (n + n) : begin
            refine mul_le_mul dinv _ (norm_nonneg _) _,
            { exact le_trans (norm_sub_le _ _) (add_le_add (le_of_lt hx₁) (le_of_lt hx₂)) },
            { apply mul_nonneg (mul_nonneg _ (norm_nonneg _)) (norm_nonneg _),
              exact inv_nonneg.2 (le_of_lt (half_pos εpos)) }
          end
        ... = (ε / 2)⁻¹ * ∥c∥ * 2 * ↑n * ∥y∥ : by ring,
      exact ⟨d⁻¹ • x, J, K⟩ } },
end

variable [complete_space E]

/-- The Banach open mapping theorem: if a bounded linear map between Banach spaces is onto, then
any point has a preimage with controlled norm. -/
theorem exists_preimage_norm_le (surj : surjective f) :
  ∃C > 0, ∀y, ∃x, f x = y ∧ ∥x∥ ≤ C * ∥y∥ :=
begin
  obtain ⟨C, C0, hC⟩ := exists_approx_preimage_norm_le f surj,
  /- Second step of the proof: starting from `y`, we want an exact preimage of `y`. Let `g y` be
  the approximate preimage of `y` given by the first step, and `h y = y - f(g y)` the part that
  has no preimage yet. We will iterate this process, taking the approximate preimage of `h y`,
  leaving only `h^2 y` without preimage yet, and so on. Let `u n` be the approximate preimage
  of `h^n y`. Then `u` is a converging series, and by design the sum of the series is a
  preimage of `y`. This uses completeness of `E`. -/
  choose g hg using hC,
  let h := λy, y - f (g y),
  have hle : ∀y, ∥h y∥ ≤ (1/2) * ∥y∥,
  { assume y,
    rw [← dist_eq_norm, dist_comm],
    exact (hg y).1 },
  refine ⟨2 * C + 1, by linarith, λy, _⟩,
  have hnle : ∀n:ℕ, ∥(h^[n]) y∥ ≤ (1/2)^n * ∥y∥,
  { assume n,
    induction n with n IH,
    { simp only [one_div, nat.nat_zero_eq_zero, one_mul, iterate_zero_apply,
        pow_zero] },
    { rw [iterate_succ'],
      apply le_trans (hle _) _,
      rw [pow_succ, mul_assoc],
      apply mul_le_mul_of_nonneg_left IH,
      norm_num } },
  let u := λn, g((h^[n]) y),
  have ule : ∀n, ∥u n∥ ≤ (1/2)^n * (C * ∥y∥),
  { assume n,
    apply le_trans (hg _).2 _,
    calc C * ∥(h^[n]) y∥ ≤ C * ((1/2)^n * ∥y∥) : mul_le_mul_of_nonneg_left (hnle n) C0
         ... = (1 / 2) ^ n * (C * ∥y∥) : by ring },
  have sNu : summable (λn, ∥u n∥),
  { refine summable_of_nonneg_of_le (λn, norm_nonneg _) ule _,
    exact summable.mul_right _ (summable_geometric_of_lt_1 (by norm_num) (by norm_num)) },
  have su : summable u := summable_of_summable_norm sNu,
  let x := tsum u,
  have x_ineq : ∥x∥ ≤ (2 * C + 1) * ∥y∥ := calc
    ∥x∥ ≤ ∑'n, ∥u n∥ : norm_tsum_le_tsum_norm sNu
    ... ≤ ∑'n, (1/2)^n * (C * ∥y∥) :
      tsum_le_tsum ule sNu (summable.mul_right _ summable_geometric_two)
    ... = (∑'n, (1/2)^n) * (C * ∥y∥) : tsum_mul_right
    ... = 2 * C * ∥y∥ : by rw [tsum_geometric_two, mul_assoc]
    ... ≤ 2 * C * ∥y∥ + ∥y∥ : le_add_of_nonneg_right (norm_nonneg y)
    ... = (2 * C + 1) * ∥y∥ : by ring,
  have fsumeq : ∀n:ℕ, f (∑ i in range n, u i) = y - (h^[n]) y,
  { assume n,
    induction n with n IH,
    { simp [f.map_zero] },
    { rw [sum_range_succ, f.map_add, IH, iterate_succ', sub_add] } },
  have : tendsto (λn, ∑ i in range n, u i) at_top (𝓝 x) :=
    su.has_sum.tendsto_sum_nat,
  have L₁ : tendsto (λn, f (∑ i in range n, u i)) at_top (𝓝 (f x)) :=
    (f.continuous.tendsto _).comp this,
  simp only [fsumeq] at L₁,
  have L₂ : tendsto (λn, y - (h^[n]) y) at_top (𝓝 (y - 0)),
  { refine tendsto_const_nhds.sub _,
    rw tendsto_iff_norm_tendsto_zero,
    simp only [sub_zero],
    refine squeeze_zero (λ_, norm_nonneg _) hnle _,
    rw [← zero_mul ∥y∥],
    refine (tendsto_pow_at_top_nhds_0_of_lt_1 _ _).mul tendsto_const_nhds; norm_num },
  have feq : f x = y - 0 := tendsto_nhds_unique L₁ L₂,
  rw sub_zero at feq,
  exact ⟨x, feq, x_ineq⟩
end

/-- The Banach open mapping theorem: a surjective bounded linear map between Banach spaces is
open. -/
theorem open_mapping (surj : surjective f) : is_open_map f :=
begin
  assume s hs,
  rcases exists_preimage_norm_le f surj with ⟨C, Cpos, hC⟩,
  refine is_open_iff.2 (λy yfs, _),
  rcases mem_image_iff_bex.1 yfs with ⟨x, xs, fxy⟩,
  rcases is_open_iff.1 hs x xs with ⟨ε, εpos, hε⟩,
  refine ⟨ε/C, div_pos εpos Cpos, λz hz, _⟩,
  rcases hC (z-y) with ⟨w, wim, wnorm⟩,
  have : f (x + w) = z, by { rw [f.map_add, wim, fxy, add_sub_cancel'_right] },
  rw ← this,
  have : x + w ∈ ball x ε := calc
    dist (x+w) x = ∥w∥ : by { rw dist_eq_norm, simp }
    ... ≤ C * ∥z - y∥ : wnorm
    ... < C * (ε/C) : begin
        apply mul_lt_mul_of_pos_left _ Cpos,
        rwa [mem_ball, dist_eq_norm] at hz,
      end
    ... = ε : mul_div_cancel' _ (ne_of_gt Cpos),
  exact set.mem_image_of_mem _ (hε this)
end

lemma open_mapping_affine {P Q : Type*}
  [metric_space P] [normed_add_torsor E P] [metric_space Q] [normed_add_torsor F Q]
  {f : P →ᵃ[𝕜] Q} (hf : continuous f) (surj : surjective f) :
  is_open_map f :=
begin
  rw ← affine_map.is_open_map_linear_iff,
  exact open_mapping
    { cont := affine_map.continuous_linear_iff.mpr hf, .. f.linear }
    (f.surjective_iff_linear_surjective.mpr surj),
end

/-! ### Applications of the Banach open mapping theorem -/

namespace continuous_linear_map

lemma exists_nonlinear_right_inverse_of_surjective (f : E →L[𝕜] F) (hsurj : f.range = ⊤) :
  ∃ (fsymm : nonlinear_right_inverse f), 0 < fsymm.nnnorm :=
begin
  choose C hC fsymm h using exists_preimage_norm_le _ (linear_map.range_eq_top.mp hsurj),
  use { to_fun := fsymm,
        nnnorm := ⟨C, hC.lt.le⟩,
        bound' := λ y, (h y).2,
        right_inv' := λ y, (h y).1 },
  exact hC
end

/-- A surjective continuous linear map between Banach spaces admits a (possibly nonlinear)
controlled right inverse. In general, it is not possible to ensure that such a right inverse
is linear (take for instance the map from `E` to `E/F` where `F` is a closed subspace of `E`
without a closed complement. Then it doesn't have a continuous linear right inverse.) -/
@[irreducible] noncomputable def nonlinear_right_inverse_of_surjective
  (f : E →L[𝕜] F) (hsurj : f.range = ⊤) : nonlinear_right_inverse f :=
classical.some (exists_nonlinear_right_inverse_of_surjective f hsurj)

lemma nonlinear_right_inverse_of_surjective_nnnorm_pos (f : E →L[𝕜] F) (hsurj : f.range = ⊤) :
  0 < (nonlinear_right_inverse_of_surjective f hsurj).nnnorm :=
begin
  rw nonlinear_right_inverse_of_surjective,
  exact classical.some_spec (exists_nonlinear_right_inverse_of_surjective f hsurj)
end

end continuous_linear_map

namespace linear_equiv

/-- If a bounded linear map is a bijection, then its inverse is also a bounded linear map. -/
@[continuity]
theorem continuous_symm (e : E ≃ₗ[𝕜] F) (h : continuous e) :
  continuous e.symm :=
begin
  rw continuous_def,
  intros s hs,
  rw [← e.image_eq_preimage],
  rw [← e.coe_coe] at h ⊢,
  exact open_mapping ⟨↑e, h⟩ e.surjective s hs
end

/-- Associating to a linear equivalence between Banach spaces a continuous linear equivalence when
the direct map is continuous, thanks to the Banach open mapping theorem that ensures that the
inverse map is also continuous. -/
def to_continuous_linear_equiv_of_continuous (e : E ≃ₗ[𝕜] F) (h : continuous e) :
  E ≃L[𝕜] F :=
{ continuous_to_fun := h,
  continuous_inv_fun := e.continuous_symm h,
  ..e }

@[simp] lemma coe_fn_to_continuous_linear_equiv_of_continuous (e : E ≃ₗ[𝕜] F) (h : continuous e) :
  ⇑(e.to_continuous_linear_equiv_of_continuous h) = e := rfl

@[simp] lemma coe_fn_to_continuous_linear_equiv_of_continuous_symm (e : E ≃ₗ[𝕜] F)
  (h : continuous e) :
  ⇑(e.to_continuous_linear_equiv_of_continuous h).symm = e.symm := rfl

end linear_equiv

namespace continuous_linear_equiv

/-- Convert a bijective continuous linear map `f : E →L[𝕜] F` between two Banach spaces
to a continuous linear equivalence. -/
noncomputable def of_bijective (f : E →L[𝕜] F) (hinj : f.ker = ⊥) (hsurj : f.range = ⊤) :
  E ≃L[𝕜] F :=
(linear_equiv.of_bijective ↑f (linear_map.ker_eq_bot.mp hinj) (linear_map.range_eq_top.mp hsurj))
.to_continuous_linear_equiv_of_continuous f.continuous

@[simp] lemma coe_fn_of_bijective (f : E →L[𝕜] F) (hinj : f.ker = ⊥) (hsurj : f.range = ⊤) :
  ⇑(of_bijective f hinj hsurj) = f := rfl

lemma coe_of_bijective (f : E →L[𝕜] F) (hinj : f.ker = ⊥) (hsurj : f.range = ⊤) :
  ↑(of_bijective f hinj hsurj) = f := by { ext, refl }

@[simp] lemma of_bijective_symm_apply_apply (f : E →L[𝕜] F) (hinj : f.ker = ⊥)
  (hsurj : f.range = ⊤) (x : E) :
  (of_bijective f hinj hsurj).symm (f x) = x :=
(of_bijective f hinj hsurj).symm_apply_apply x

@[simp] lemma of_bijective_apply_symm_apply (f : E →L[𝕜] F) (hinj : f.ker = ⊥)
  (hsurj : f.range = ⊤) (y : F) :
  f ((of_bijective f hinj hsurj).symm y) = y :=
(of_bijective f hinj hsurj).apply_symm_apply y

end continuous_linear_equiv

namespace continuous_linear_map

/-- Intermediate definition used to show
`continuous_linear_map.closed_complemented_range_of_is_compl_of_ker_eq_bot`.

This is `f.coprod G.subtypeL` as an `continuous_linear_equiv`. -/
noncomputable def coprod_subtypeL_equiv_of_is_compl
  (f : E →L[𝕜] F) {G : submodule 𝕜 F}
  (h : is_compl f.range G) [complete_space G] (hker : f.ker = ⊥) : (E × G) ≃L[𝕜] F :=
continuous_linear_equiv.of_bijective (f.coprod G.subtypeL)
  (begin
    rw ker_coprod_of_disjoint_range,
    { rw [hker, submodule.ker_subtypeL, submodule.prod_bot] },
    { rw submodule.range_subtypeL,
      exact h.disjoint }
  end)
  (by simp only [range_coprod, h.sup_eq_top, submodule.range_subtypeL])

lemma range_eq_map_coprod_subtypeL_equiv_of_is_compl
  (f : E →L[𝕜] F) {G : submodule 𝕜 F}
  (h : is_compl f.range G) [complete_space G] (hker : f.ker = ⊥) :
    f.range = ((⊤ : submodule 𝕜 E).prod (⊥ : submodule 𝕜 G)).map
      (f.coprod_subtypeL_equiv_of_is_compl h hker : E × G →ₗ[𝕜] F) :=
by rw [coprod_subtypeL_equiv_of_is_compl, _root_.coe_coe, continuous_linear_equiv.coe_of_bijective,
    coe_coprod, linear_map.coprod_map_prod, submodule.map_bot, sup_bot_eq, submodule.map_top,
    range]

/- TODO: remove the assumption `f.ker = ⊥` in the next lemma, by using the map induced by `f` on
`E / f.ker`, once we have quotient normed spaces. -/
lemma closed_complemented_range_of_is_compl_of_ker_eq_bot (f : E →L[𝕜] F) (G : submodule 𝕜 F)
  (h : is_compl f.range G) (hG : is_closed (G : set F)) (hker : f.ker = ⊥) :
  is_closed (f.range : set F) :=
begin
  haveI : complete_space G := complete_space_coe_iff_is_complete.2 hG.is_complete,
  let g := coprod_subtypeL_equiv_of_is_compl f h hker,
  rw congr_arg coe (range_eq_map_coprod_subtypeL_equiv_of_is_compl f h hker ),
  apply g.to_homeomorph.is_closed_image.2,
  exact is_closed_univ.prod is_closed_singleton,
end

end continuous_linear_map


inductive CList where
| node (data : Nat) (next : CList)

def CList.data : CList → Nat | node data _ => data
def CList.next : CList → CList | node _ next => next

example (l : CList) : False :=
  l.rec λ _ _ => id

def double (x : Thunk Nat) : Nat :=
  x.get + x.get
-- #eval double ⟨λ _ => 4⟩

section
private inductive InfList (α : Type u) where
| cons (head : α) (tail : Thunk (InfList α))
end

def InfList.take {α} : Nat → InfList α → List α
  | 0,   _     => .nil
  | n + 1, .cons a as => .cons a (take n as.get)

def InfList.head {α} : InfList α → α
  | .cons a _ => a

def InfList.tail {α} : InfList α → InfList α
  | .cons _ as => as.get

unsafe def InfList.const {α} (x : α) : InfList α :=
  cons x ⟨λ _ => const x⟩
-- #eval (InfList.const 0).take 3

theorem Thunk.eq_of_getEq {α} : {a b : Thunk α} → a.get = b.get → a = b
  | ⟨_⟩, ⟨_⟩, h => congrArg _ (funext λ _ => h)

theorem InfList.coRec {α} (r : InfList α → InfList α → Prop)
  (h_head : ∀ a b : InfList α, r a b → head a = head b)
  (h_tail : ∀ a b : InfList α, r a b → r (tail a) (tail b))
  (a b : InfList α) (h : r a b)
  : a = b :=
  have h1 := h_head a b h
  have h2 := h_tail a b h
  match a, b with
  | cons a as, cons b bs =>
    have h1 : a = b := h1
    have h2 := Thunk.eq_of_getEq <| coRec r h_head h_tail as.get bs.get h2
    h2 ▸ h1 ▸ rfl


/-
Copyright (c) 2019 Reid Barton. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl
-/
import topology.constructions
import topology.algebra.group
/-!
# Topology on lists and vectors

-/
open topological_space set filter
open_locale topological_space filter

variables {α : Type*} {β : Type*} [topological_space α] [topological_space β]

instance : topological_space (list α) :=
topological_space.mk_of_nhds (traverse nhds)

lemma nhds_list (as : list α) : 𝓝 as = traverse 𝓝 as :=
begin
  refine nhds_mk_of_nhds _ _ _ _,
  { assume l, induction l,
    case list.nil { exact le_refl _ },
    case list.cons : a l ih {
      suffices : list.cons <$> pure a <*> pure l ≤ list.cons <$> 𝓝 a <*> traverse 𝓝 l,
      { simpa only [] with functor_norm using this },
      exact filter.seq_mono (filter.map_mono $ pure_le_nhds a) ih } },
  { assume l s hs,
    rcases (mem_traverse_sets_iff _ _).1 hs with ⟨u, hu, hus⟩, clear as hs,
    have : ∃v:list (set α), l.forall₂ (λa s, is_open s ∧ a ∈ s) v ∧ sequence v ⊆ s,
    { induction hu generalizing s,
      case list.forall₂.nil : hs this
        { existsi [], simpa only [list.forall₂_nil_left_iff, exists_eq_left] },
      case list.forall₂.cons : a s as ss ht h ih t hts {
        rcases mem_nhds_sets_iff.1 ht with ⟨u, hut, hu⟩,
        rcases ih (subset.refl _) with ⟨v, hv, hvss⟩,
        exact ⟨u::v, list.forall₂.cons hu hv,
          subset.trans (set.seq_mono (set.image_subset _ hut) hvss) hts⟩ } },
    rcases this with ⟨v, hv, hvs⟩,
    refine ⟨sequence v, mem_traverse_sets _ _ _, hvs, _⟩,
    { exact hv.imp (assume a s ⟨hs, ha⟩, mem_nhds_sets hs ha) },
    { assume u hu,
      have hu := (list.mem_traverse _ _).1 hu,
      have : list.forall₂ (λa s, is_open s ∧ a ∈ s) u v,
      { refine list.forall₂.flip _,
        replace hv := hv.flip,
        simp only [list.forall₂_and_left, flip] at ⊢ hv,
        exact ⟨hv.1, hu.flip⟩ },
      refine mem_sets_of_superset _ hvs,
      exact mem_traverse_sets _ _ (this.imp $ assume a s ⟨hs, ha⟩, mem_nhds_sets hs ha) } }
end

@[simp] lemma nhds_nil : 𝓝 ([] : list α) = pure [] :=
by rw [nhds_list, list.traverse_nil _]; apply_instance

lemma nhds_cons (a : α) (l : list α) :
  𝓝 (a :: l) = list.cons <$> 𝓝 a <*> 𝓝 l  :=
by rw [nhds_list, list.traverse_cons _, ← nhds_list]; apply_instance

lemma list.tendsto_cons {a : α} {l : list α} :
  tendsto (λp:α×list α, list.cons p.1 p.2) (𝓝 a ×ᶠ 𝓝 l) (𝓝 (a :: l)) :=
by rw [nhds_cons, tendsto, map_prod]; exact le_refl _

lemma filter.tendsto.cons {α : Type*} {f : α → β} {g : α → list β}
  {a : _root_.filter α} {b : β} {l : list β} (hf : tendsto f a (𝓝 b)) (hg : tendsto g a (𝓝 l)) :
  tendsto (λa, list.cons (f a) (g a)) a (𝓝 (b :: l)) :=
list.tendsto_cons.comp (tendsto.prod_mk hf hg)

namespace list

lemma tendsto_cons_iff {β : Type*} {f : list α → β} {b : _root_.filter β} {a : α} {l : list α} :
  tendsto f (𝓝 (a :: l)) b ↔ tendsto (λp:α×list α, f (p.1 :: p.2)) (𝓝 a ×ᶠ 𝓝 l) b :=
have 𝓝 (a :: l) = (𝓝 a ×ᶠ 𝓝 l).map (λp:α×list α, (p.1 :: p.2)),
begin
  simp only
    [nhds_cons, filter.prod_eq, (filter.map_def _ _).symm, (filter.seq_eq_filter_seq _ _).symm],
  simp [-filter.seq_eq_filter_seq, -filter.map_def, (∘)] with functor_norm,
end,
by rw [this, filter.tendsto_map'_iff]

lemma continuous_cons : continuous (λ x : α × list α, (x.1 :: x.2 : list α)) :=
continuous_iff_continuous_at.mpr $ λ ⟨x, y⟩, continuous_at_fst.cons continuous_at_snd

lemma tendsto_nhds {β : Type*} {f : list α → β} {r : list α → _root_.filter β}
  (h_nil : tendsto f (pure []) (r []))
  (h_cons : ∀l a, tendsto f (𝓝 l) (r l) →
    tendsto (λp:α×list α, f (p.1 :: p.2)) (𝓝 a ×ᶠ 𝓝 l) (r (a::l))) :
  ∀l, tendsto f (𝓝 l) (r l)
| []     := by rwa [nhds_nil]
| (a::l) := by rw [tendsto_cons_iff]; exact h_cons l a (tendsto_nhds l)

lemma continuous_at_length :
  ∀(l : list α), continuous_at list.length l :=
begin
  simp only [continuous_at, nhds_discrete],
  refine tendsto_nhds _ _,
  { exact tendsto_pure_pure _ _ },
  { assume l a ih,
    dsimp only [list.length],
    refine tendsto.comp (tendsto_pure_pure (λx, x + 1) _) _,
    refine tendsto.comp ih tendsto_snd }
end

lemma tendsto_insert_nth' {a : α} : ∀{n : ℕ} {l : list α},
  tendsto (λp:α×list α, insert_nth n p.1 p.2) (𝓝 a ×ᶠ 𝓝 l) (𝓝 (insert_nth n a l))
| 0     l  := tendsto_cons
| (n+1) [] := by simp
| (n+1) (a'::l) :=
  have 𝓝 a ×ᶠ 𝓝 (a' :: l) =
    (𝓝 a ×ᶠ (𝓝 a' ×ᶠ 𝓝 l)).map (λp:α×α×list α, (p.1, p.2.1 :: p.2.2)),
  begin
    simp only [nhds_cons, filter.prod_eq, ← filter.map_def, ← filter.seq_eq_filter_seq],
    simp [-filter.seq_eq_filter_seq, -filter.map_def, (∘)] with functor_norm
  end,
  begin
    rw [this, tendsto_map'_iff],
    exact (tendsto_fst.comp tendsto_snd).cons
      ((@tendsto_insert_nth' n l).comp $ tendsto_fst.prod_mk $ tendsto_snd.comp tendsto_snd)
  end

lemma tendsto_insert_nth {β} {n : ℕ} {a : α} {l : list α} {f : β → α} {g : β → list α}
  {b : _root_.filter β} (hf : tendsto f b (𝓝 a)) (hg : tendsto g b (𝓝 l)) :
  tendsto (λb:β, insert_nth n (f b) (g b)) b (𝓝 (insert_nth n a l)) :=
tendsto_insert_nth'.comp (tendsto.prod_mk hf hg)

lemma continuous_insert_nth {n : ℕ} : continuous (λp:α×list α, insert_nth n p.1 p.2) :=
continuous_iff_continuous_at.mpr $
  assume ⟨a, l⟩, by rw [continuous_at, nhds_prod_eq]; exact tendsto_insert_nth'

lemma tendsto_remove_nth : ∀{n : ℕ} {l : list α},
  tendsto (λl, remove_nth l n) (𝓝 l) (𝓝 (remove_nth l n))
| _ []      := by rw [nhds_nil]; exact tendsto_pure_nhds _ _
| 0 (a::l) := by rw [tendsto_cons_iff]; exact tendsto_snd
| (n+1) (a::l) :=
  begin
    rw [tendsto_cons_iff],
    dsimp [remove_nth],
    exact tendsto_fst.cons ((@tendsto_remove_nth n l).comp tendsto_snd)
  end

lemma continuous_remove_nth {n : ℕ} : continuous (λl : list α, remove_nth l n) :=
continuous_iff_continuous_at.mpr $ assume a, tendsto_remove_nth

@[to_additive]
lemma tendsto_prod [monoid α] [has_continuous_mul α] {l : list α} :
  tendsto list.prod (𝓝 l) (𝓝 l.prod) :=
begin
  induction l with x l ih, { simp [nhds_nil, mem_of_nhds, tendsto_pure_left] {contextual := tt} },
  simp_rw [tendsto_cons_iff, prod_cons],
  have := continuous_iff_continuous_at.mp continuous_mul (x, l.prod),
  rw [continuous_at, nhds_prod_eq] at this,
  exact this.comp (tendsto_id.prod_map ih)
end

@[to_additive]
lemma continuous_prod [monoid α] [has_continuous_mul α] : continuous (prod : list α → α) :=
continuous_iff_continuous_at.mpr $ λ l, tendsto_prod

end list

namespace vector
open list

instance (n : ℕ) : topological_space (vector α n) :=
by unfold vector; apply_instance

lemma tendsto_insert_nth
  {n : ℕ} {i : fin (n+1)} {a:α} :
  ∀{l:vector α n}, tendsto (λp:α×vector α n, insert_nth p.1 i p.2)
    (𝓝 a ×ᶠ 𝓝 l) (𝓝 (insert_nth a i l))
| ⟨l, hl⟩ :=
begin
  rw [insert_nth, tendsto_subtype_rng],
  simp [insert_nth_val],
  exact list.tendsto_insert_nth tendsto_fst (tendsto.comp continuous_at_subtype_coe tendsto_snd : _)
end

lemma continuous_insert_nth' {n : ℕ} {i : fin (n+1)} :
  continuous (λp:α×vector α n, insert_nth p.1 i p.2) :=
continuous_iff_continuous_at.mpr $ assume ⟨a, l⟩,
  by rw [continuous_at, nhds_prod_eq]; exact tendsto_insert_nth

lemma continuous_insert_nth {n : ℕ} {i : fin (n+1)}
  {f : β → α} {g : β → vector α n} (hf : continuous f) (hg : continuous g) :
  continuous (λb, insert_nth (f b) i (g b)) :=
continuous_insert_nth'.comp (hf.prod_mk hg : _)

lemma continuous_at_remove_nth {n : ℕ} {i : fin (n+1)} :
  ∀{l:vector α (n+1)}, continuous_at (remove_nth i) l
| ⟨l, hl⟩ :=
--  ∀{l:vector α (n+1)}, tendsto (remove_nth i) (𝓝 l) (𝓝 (remove_nth i l))
--| ⟨l, hl⟩ :=
begin
  rw [continuous_at, remove_nth, tendsto_subtype_rng],
  simp only [← subtype.val_eq_coe, vector.remove_nth_val],
  exact tendsto.comp list.tendsto_remove_nth continuous_at_subtype_coe,
end

lemma continuous_remove_nth {n : ℕ} {i : fin (n+1)} :
  continuous (remove_nth i : vector α (n+1) → vector α n) :=
continuous_iff_continuous_at.mpr $ assume ⟨a, l⟩, continuous_at_remove_nth

end vector


/-
Copyright (c) 2018 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Kenny Lau, Johan Commelin, Mario Carneiro
-/
import algebra.big_operators
import data.finset
import tactic.subtype_instance

variables {α : Type*} [monoid α] {s : set α}
variables {β : Type*} [add_monoid β] {t : set β}

/-- `s` is a submonoid: a set containing 1 and closed under multiplication. -/
class is_submonoid (s : set α) : Prop :=
(one_mem : (1:α) ∈ s)
(mul_mem {a b} : a ∈ s → b ∈ s → a * b ∈ s)

/-- `s` is an additive submonoid: a set containing 0 and closed under addition. -/
class is_add_submonoid (s : set β) : Prop :=
(zero_mem : (0:β) ∈ s)
(add_mem {a b} : a ∈ s → b ∈ s → a + b ∈ s)

attribute [to_additive is_add_submonoid] is_submonoid
attribute [to_additive is_add_submonoid.zero_mem] is_submonoid.one_mem
attribute [to_additive is_add_submonoid.add_mem] is_submonoid.mul_mem
attribute [to_additive is_add_submonoid.mk] is_submonoid.mk

instance additive.is_add_submonoid
  (s : set α) : ∀ [is_submonoid s], @is_add_submonoid (additive α) _ s
| ⟨h₁, h₂⟩ := ⟨h₁, @h₂⟩

theorem additive.is_add_submonoid_iff
  {s : set α} : @is_add_submonoid (additive α) _ s ↔ is_submonoid s :=
⟨λ ⟨h₁, h₂⟩, ⟨h₁, @h₂⟩, λ h, by resetI; apply_instance⟩

instance multiplicative.is_submonoid
  (s : set β) : ∀ [is_add_submonoid s], @is_submonoid (multiplicative β) _ s
| ⟨h₁, h₂⟩ := ⟨h₁, @h₂⟩

theorem multiplicative.is_submonoid_iff
  {s : set β} : @is_submonoid (multiplicative β) _ s ↔ is_add_submonoid s :=
⟨λ ⟨h₁, h₂⟩, ⟨h₁, @h₂⟩, λ h, by resetI; apply_instance⟩

section powers

def powers (x : α) : set α := {y | ∃ n:ℕ, x^n = y}
def multiples (x : β) : set β := {y | ∃ n:ℕ, add_monoid.smul n x = y}
attribute [to_additive multiples] powers

lemma powers.one_mem {x : α} : (1 : α) ∈ powers x := ⟨0, pow_zero _⟩

lemma multiples.zero_mem {x : β} : (0 : β) ∈ multiples x := ⟨0, add_monoid.zero_smul _⟩
attribute [to_additive multiples.zero_mem] powers.one_mem

lemma powers.self_mem {x : α} : x ∈ powers x := ⟨1, pow_one _⟩

lemma multiples.self_mem {x : β} : x ∈ multiples x := ⟨1, add_monoid.one_smul _⟩
attribute [to_additive multiples.self_mem] powers.self_mem

instance powers.is_submonoid (x : α) : is_submonoid (powers x) :=
{ one_mem := ⟨0, by simp⟩,
  mul_mem := λ x₁ x₂ ⟨n₁, hn₁⟩ ⟨n₂, hn₂⟩, ⟨n₁ + n₂, by simp [pow_add, *]⟩ }

instance multiples.is_add_submonoid (x : β) : is_add_submonoid (multiples x) :=
multiplicative.is_submonoid_iff.1 $ powers.is_submonoid _
attribute [to_additive multiples.is_add_submonoid] powers.is_submonoid

lemma is_submonoid.pow_mem {a : α} [is_submonoid s] (h : a ∈ s) : ∀ {n : ℕ}, a ^ n ∈ s
| 0 := is_submonoid.one_mem s
| (n + 1) := is_submonoid.mul_mem h is_submonoid.pow_mem

lemma is_add_submonoid.smul_mem {a : β} [is_add_submonoid t] :
  ∀ (h : a ∈ t) {n : ℕ}, add_monoid.smul n a ∈ t :=
@is_submonoid.pow_mem (multiplicative β) _ _ _ _
attribute [to_additive is_add_submonoid.smul_mem] is_submonoid.pow_mem

lemma is_submonoid.power_subset {a : α} [is_submonoid s] (h : a ∈ s) : powers a ⊆ s :=
assume x ⟨n, hx⟩, hx ▸ is_submonoid.pow_mem h

lemma is_add_submonoid.multiple_subset {a : β} [is_add_submonoid t] :
  a ∈ t → multiples a ⊆ t :=
@is_submonoid.power_subset (multiplicative β) _ _ _ _
attribute [to_additive is_add_submonoid.multiple_subset] is_add_submonoid.multiple_subset

end powers

namespace is_submonoid

@[to_additive is_add_submonoid.list_sum_mem]
lemma list_prod_mem [is_submonoid s] : ∀{l : list α}, (∀x∈l, x ∈ s) → l.prod ∈ s
| []     h := one_mem s
| (a::l) h :=
  suffices a * l.prod ∈ s, by simpa,
  have a ∈ s ∧ (∀x∈l, x ∈ s), by simpa using h,
  is_submonoid.mul_mem this.1 (list_prod_mem this.2)

@[to_additive is_add_submonoid.multiset_sum_mem]
lemma multiset_prod_mem {α} [comm_monoid α] (s : set α) [is_submonoid s] (m : multiset α) :
  (∀a∈m, a ∈ s) → m.prod ∈ s :=
begin
  refine quotient.induction_on m (assume l hl, _),
  rw [multiset.quot_mk_to_coe, multiset.coe_prod],
  exact list_prod_mem hl
end

@[to_additive is_add_submonoid.finset_sum_mem]
lemma finset_prod_mem {α β} [comm_monoid α] (s : set α) [is_submonoid s] (f : β → α) :
  ∀(t : finset β), (∀b∈t, f b ∈ s) → t.prod f ∈ s
| ⟨m, hm⟩ hs :=
  begin
    refine multiset_prod_mem s _ _,
    simp,
    rintros a b hb rfl,
    exact hs _ hb
  end

end is_submonoid

instance subtype.monoid {s : set α} [is_submonoid s] : monoid s :=
by subtype_instance

attribute [to_additive subtype.add_monoid._proof_1] subtype.monoid._proof_1
attribute [to_additive subtype.add_monoid._proof_2] subtype.monoid._proof_2
attribute [to_additive subtype.add_monoid._proof_3] subtype.monoid._proof_3
attribute [to_additive subtype.add_monoid._proof_4] subtype.monoid._proof_4
attribute [to_additive subtype.add_monoid._proof_5] subtype.monoid._proof_5
attribute [to_additive subtype.add_monoid] subtype.monoid

@[simp, to_additive is_add_submonoid.coe_zero]
lemma is_submonoid.coe_one [is_submonoid s] : ((1 : s) : α) = 1 := rfl

@[simp, to_additive is_add_submonoid.coe_add]
lemma is_submonoid.coe_mul [is_submonoid s] (a b : s) : ((a * b : s) : α) = a * b := rfl

@[simp] lemma is_submonoid.coe_pow [is_submonoid s] (a : s) (n : ℕ) : ((a ^ n : s) : α) = a ^ n :=
by induction n; simp [*, pow_succ]

@[simp] lemma is_add_submonoid.smul_coe {β : Type*} [add_monoid β] {s : set β}
  [is_add_submonoid s] (a : s) (n : ℕ) : ((add_monoid.smul n a : s) : β) = add_monoid.smul n a :=
by induction n; [refl, simp [*, succ_smul]]
attribute [to_additive is_add_submonoid.smul_coe] is_submonoid.coe_pow

namespace monoid

inductive in_closure (s : set α) : α → Prop
| basic {a : α} : a ∈ s → in_closure a
| one : in_closure 1
| mul {a b : α} : in_closure a → in_closure b → in_closure (a * b)

def closure (s : set α) : set α := {a | in_closure s a }

instance closure.is_submonoid (s : set α) : is_submonoid (closure s) :=
{ one_mem := in_closure.one s, mul_mem := assume a b, in_closure.mul }

theorem subset_closure {s : set α} : s ⊆ closure s :=
assume a, in_closure.basic

theorem closure_subset {s t : set α} [is_submonoid t] (h : s ⊆ t) : closure s ⊆ t :=
assume a ha, by induction ha; simp [h _, *, is_submonoid.one_mem, is_submonoid.mul_mem]

theorem closure_mono {s t : set α} (h : s ⊆ t) : closure s ⊆ closure t :=
closure_subset $ set.subset.trans h subset_closure

theorem closure_singleton {x : α} : closure ({x} : set α) = powers x :=
set.eq_of_subset_of_subset (closure_subset $ set.singleton_subset_iff.2 $ powers.self_mem) $
  is_submonoid.power_subset $ set.singleton_subset_iff.1 $ subset_closure

theorem exists_list_of_mem_closure {s : set α} {a : α} (h : a ∈ closure s) :
  (∃l:list α, (∀x∈l, x ∈ s) ∧ l.prod = a) :=
begin
  induction h,
  case in_closure.basic : a ha { existsi ([a]), simp [ha] },
  case in_closure.one { existsi ([]), simp },
  case in_closure.mul : a b _ _ ha hb {
    rcases ha with ⟨la, ha, eqa⟩,
    rcases hb with ⟨lb, hb, eqb⟩,
    existsi (la ++ lb),
    simp [eqa.symm, eqb.symm, or_imp_distrib],
    exact assume a, ⟨ha a, hb a⟩
  }
end

theorem mem_closure_union_iff {α : Type*} [comm_monoid α] {s t : set α} {x : α} :
  x ∈ closure (s ∪ t) ↔ ∃ y ∈ closure s, ∃ z ∈ closure t, y * z = x :=
⟨λ hx, let ⟨L, HL1, HL2⟩ := exists_list_of_mem_closure hx in HL2 ▸
  list.rec_on L (λ _, ⟨1, is_submonoid.one_mem _, 1, is_submonoid.one_mem _, mul_one _⟩)
    (λ hd tl ih HL1, let ⟨y, hy, z, hz, hyzx⟩ := ih (list.forall_mem_of_forall_mem_cons HL1) in
      or.cases_on (HL1 hd $ list.mem_cons_self _ _)
        (λ hs, ⟨hd * y, is_submonoid.mul_mem (subset_closure hs) hy, z, hz, by rw [mul_assoc, list.prod_cons, ← hyzx]; refl⟩)
        (λ ht, ⟨y, hy, z * hd, is_submonoid.mul_mem hz (subset_closure ht), by rw [← mul_assoc, list.prod_cons, ← hyzx, mul_comm hd]; refl⟩)) HL1,
λ ⟨y, hy, z, hz, hyzx⟩, hyzx ▸ is_submonoid.mul_mem (closure_mono (set.subset_union_left _ _) hy)
  (closure_mono (set.subset_union_right _ _) hz)⟩

end monoid

namespace add_monoid

def closure (s : set β) : set β := @monoid.closure (multiplicative β) _ s
attribute [to_additive add_monoid.closure] monoid.closure

instance closure.is_add_submonoid (s : set β) : is_add_submonoid (closure s) :=
multiplicative.is_submonoid_iff.1 $ monoid.closure.is_submonoid s
attribute [to_additive add_monoid.closure.is_add_submonoid] monoid.closure.is_submonoid

theorem subset_closure {s : set β} : s ⊆ closure s :=
monoid.subset_closure
attribute [to_additive add_monoid.subset_closure] monoid.subset_closure

theorem closure_subset {s t : set β} [is_add_submonoid t] : s ⊆ t → closure s ⊆ t :=
monoid.closure_subset
attribute [to_additive add_monoid.closure_subset] monoid.closure_subset

theorem closure_mono {s t : set β} (h : s ⊆ t) : closure s ⊆ closure t :=
closure_subset $ set.subset.trans h subset_closure
attribute [to_additive add_monoid.closure_mono] monoid.closure_mono

theorem closure_singleton {x : β} : closure ({x} : set β) = multiples x :=
monoid.closure_singleton
attribute [to_additive add_monoid.closure_singleton] monoid.closure_singleton

theorem exists_list_of_mem_closure {s : set β} {a : β} :
  a ∈ closure s → ∃l:list β, (∀x∈l, x ∈ s) ∧ l.sum = a :=
monoid.exists_list_of_mem_closure
attribute [to_additive add_monoid.exists_list_of_mem_closure] monoid.exists_list_of_mem_closure

@[elab_as_eliminator]
theorem in_closure.rec_on {s : set β} {C : β → Prop}
  {a : β} (H : a ∈ closure s)
  (H1 : ∀ {a : β}, a ∈ s → C a) (H2 : C 0)
  (H3 : ∀ {a b : β}, a ∈ closure s → b ∈ closure s → C a → C b → C (a + b)) :
  C a :=
monoid.in_closure.rec_on H (λ _, H1) H2 (λ _ _, H3)

theorem mem_closure_union_iff {β : Type*} [add_comm_monoid β] {s t : set β} {x : β} :
  x ∈ closure (s ∪ t) ↔ ∃ y ∈ closure s, ∃ z ∈ closure t, y + z = x :=
monoid.mem_closure_union_iff

end add_monoid


/-
Copyright (c) 2021 Oliver Nash. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Oliver Nash
-/
import analysis.normed_space.finite_dimension
import analysis.calculus.affine_map
import analysis.convex.combination
import linear_algebra.affine_space.finite_dimensional

/-!
# Bases in normed affine spaces.

This file contains results about bases in normed affine spaces.

## Main definitions:

 * `continuous_barycentric_coord`
 * `is_open_map_barycentric_coord`
 * `affine_basis.interior_convex_hull`
 * `exists_subset_affine_independent_span_eq_top_of_open`
 * `interior_convex_hull_nonempty_iff_affine_span_eq_top`
-/

section barycentric

variables {ι 𝕜 E P : Type*} [nontrivially_normed_field 𝕜] [complete_space 𝕜]
variables [normed_add_comm_group E] [normed_space 𝕜 E]
variables [metric_space P] [normed_add_torsor E P]

include E

lemma is_open_map_barycentric_coord [nontrivial ι] (b : affine_basis ι 𝕜 P) (i : ι) :
  is_open_map (b.coord i) :=
affine_map.is_open_map_linear_iff.mp $ (b.coord i).linear.is_open_map_of_finite_dimensional $
  (b.coord i).linear_surjective_iff.mpr (b.surjective_coord i)

variables [finite_dimensional 𝕜 E] (b : affine_basis ι 𝕜 P)

@[continuity]
lemma continuous_barycentric_coord (i : ι) : continuous (b.coord i) :=
(b.coord i).continuous_of_finite_dimensional

lemma smooth_barycentric_coord (b : affine_basis ι 𝕜 E) (i : ι) : cont_diff 𝕜 ⊤ (b.coord i) :=
(⟨b.coord i, continuous_barycentric_coord b i⟩ : E →A[𝕜] 𝕜).cont_diff

end barycentric

open set

/-- Given a finite-dimensional normed real vector space, the interior of the convex hull of an
affine basis is the set of points whose barycentric coordinates are strictly positive with respect
to this basis.

TODO Restate this result for affine spaces (instead of vector spaces) once the definition of
convexity is generalised to this setting. -/
lemma affine_basis.interior_convex_hull {ι E : Type*} [finite ι] [normed_add_comm_group E]
  [normed_space ℝ E] (b : affine_basis ι ℝ E) :
  interior (convex_hull ℝ (range b)) = {x | ∀ i, 0 < b.coord i x} :=
begin
  casesI subsingleton_or_nontrivial ι,
  { -- The zero-dimensional case.
    have : range b = univ,
      from affine_subspace.eq_univ_of_subsingleton_span_eq_top (subsingleton_range _) b.tot,
    simp [this] },
  { -- The positive-dimensional case.
    haveI : finite_dimensional ℝ E := b.finite_dimensional,
    have : convex_hull ℝ (range b) = ⋂ i, (b.coord i)⁻¹' Ici 0,
    { rw [b.convex_hull_eq_nonneg_coord, set_of_forall], refl },
    ext,
    simp only [this, interior_Inter, ← is_open_map.preimage_interior_eq_interior_preimage
      (is_open_map_barycentric_coord b _) (continuous_barycentric_coord b _),
      interior_Ici, mem_Inter, mem_set_of_eq, mem_Ioi, mem_preimage], },
end

variables {V P : Type*} [normed_add_comm_group V] [normed_space ℝ V] [metric_space P]
  [normed_add_torsor V P]
include V

open affine_map

/-- Given a set `s` of affine-independent points belonging to an open set `u`, we may extend `s` to
an affine basis, all of whose elements belong to `u`. -/
lemma is_open.exists_between_affine_independent_span_eq_top {s u : set P} (hu : is_open u)
  (hsu : s ⊆ u) (hne : s.nonempty) (h : affine_independent ℝ (coe : s → P)) :
  ∃ t : set P, s ⊆ t ∧ t ⊆ u ∧ affine_independent ℝ (coe : t → P) ∧ affine_span ℝ t = ⊤ :=
begin
  obtain ⟨q, hq⟩ := hne,
  obtain ⟨ε, ε0, hεu⟩ := metric.nhds_basis_closed_ball.mem_iff.1 (hu.mem_nhds $ hsu hq),
  obtain ⟨t, ht₁, ht₂, ht₃⟩ := exists_subset_affine_independent_affine_span_eq_top h,
  let f : P → P := λ y, line_map q y (ε / dist y q),
  have hf : ∀ y, f y ∈ u,
  { refine λ y, hεu _,
    simp only [f],
    rw [metric.mem_closed_ball, line_map_apply, dist_vadd_left, norm_smul, real.norm_eq_abs,
      dist_eq_norm_vsub V y q, abs_div, abs_of_pos ε0, abs_of_nonneg (norm_nonneg _), div_mul_comm],
    exact mul_le_of_le_one_left ε0.le (div_self_le_one _) },
  have hεyq : ∀ y ∉ s, ε / dist y q ≠ 0,
    from λ y hy, div_ne_zero ε0.ne' (dist_ne_zero.2 (ne_of_mem_of_not_mem hq hy).symm),
  classical,
  let w : t → ℝˣ := λ p, if hp : (p : P) ∈ s then 1 else units.mk0 _ (hεyq ↑p hp),
  refine ⟨set.range (λ (p : t), line_map q p (w p : ℝ)), _, _, _, _⟩,
  { intros p hp, use ⟨p, ht₁ hp⟩, simp [w, hp], },
  { rintros y ⟨⟨p, hp⟩, rfl⟩,
    by_cases hps : p ∈ s; simp only [w, hps, line_map_apply_one, units.coe_mk0, dif_neg, dif_pos,
      not_false_iff, units.coe_one, subtype.coe_mk];
      [exact hsu hps, exact hf p], },
  { exact (ht₂.units_line_map ⟨q, ht₁ hq⟩ w).range, },
  { rw [affine_span_eq_affine_span_line_map_units (ht₁ hq) w, ht₃], },
end

lemma is_open.exists_subset_affine_independent_span_eq_top {u : set P} (hu : is_open u)
  (hne : u.nonempty) :
  ∃ s ⊆ u, affine_independent ℝ (coe : s → P) ∧ affine_span ℝ s = ⊤ :=
begin
  rcases hne with ⟨x, hx⟩,
  rcases hu.exists_between_affine_independent_span_eq_top (singleton_subset_iff.mpr hx)
    (singleton_nonempty _) (affine_independent_of_subsingleton _ _) with ⟨s, -, hsu, hs⟩,
  exact ⟨s, hsu, hs⟩
end

/-- The affine span of a nonempty open set is `⊤`. -/
lemma is_open.affine_span_eq_top {u : set P} (hu : is_open u) (hne : u.nonempty) :
  affine_span ℝ u = ⊤ :=
let ⟨s, hsu, hs, hs'⟩ := hu.exists_subset_affine_independent_span_eq_top hne
in top_unique $ hs' ▸ affine_span_mono _ hsu

lemma affine_span_eq_top_of_nonempty_interior {s : set V}
  (hs : (interior $ convex_hull ℝ s).nonempty) :
  affine_span ℝ s = ⊤ :=
top_unique $ is_open_interior.affine_span_eq_top hs ▸
  (affine_span_mono _ interior_subset).trans_eq (affine_span_convex_hull _)

lemma affine_basis.centroid_mem_interior_convex_hull {ι} [fintype ι] (b : affine_basis ι ℝ V) :
  finset.univ.centroid ℝ b ∈ interior (convex_hull ℝ (range b)) :=
begin
  haveI := b.nonempty,
  simp only [b.interior_convex_hull, mem_set_of_eq, b.coord_apply_centroid (finset.mem_univ _),
    inv_pos, nat.cast_pos, finset.card_pos, finset.univ_nonempty, forall_true_iff]
end

lemma interior_convex_hull_nonempty_iff_affine_span_eq_top [finite_dimensional ℝ V] {s : set V} :
  (interior (convex_hull ℝ s)).nonempty ↔ affine_span ℝ s = ⊤ :=
begin
  refine ⟨affine_span_eq_top_of_nonempty_interior, λ h, _⟩,
  obtain ⟨t, hts, b, hb⟩ := affine_basis.exists_affine_subbasis h,
  suffices : (interior (convex_hull ℝ (range b))).nonempty,
  { rw [hb, subtype.range_coe_subtype, set_of_mem_eq] at this,
    refine this.mono _,
    mono* },
  lift t to finset V using b.finite_set,
  exact ⟨_, b.centroid_mem_interior_convex_hull⟩
end

lemma convex.interior_nonempty_iff_affine_span_eq_top [finite_dimensional ℝ V] {s : set V}
  (hs : convex ℝ s) : (interior s).nonempty ↔ affine_span ℝ s = ⊤ :=
by rw [← interior_convex_hull_nonempty_iff_affine_span_eq_top, hs.convex_hull_eq]


/-
## Refinement
This file defines a refinement of semantics.
-/

import MLIR.Semantics.Semantics
import MLIR.Semantics.UB
open MLIR.AST

/-
### Refinement of SSA environment

One SSA environment `e1` is a refinement of an environment `e2` if all variables
defined in `e2` are also defined by `e1`, and have the same values.
-/

def SSAEnv.refines (env1 env2: SSAEnv δ) : Prop :=
  ∀ v val, env2.getT v = some val -> env1.getT v = some val

theorem SSAEnv.refines_set :
    refines env1 env2 ->
    refines (SSAEnv.set name τ val env1) (SSAEnv.set name τ val env2) := by
  simp [refines, SSAEnv.refines]
  intros Href name' val' Hget
  by_cases H: name = name'

  . subst H;
    rw [SSAEnv.getT_set_eq] <;> try assumption
    rw [SSAEnv.getT_set_eq] <;> try assumption
    intros K; assumption;
  . rw [SSAEnv.getT_set_ne] <;> try assumption
    rw [SSAEnv.getT_set_ne] <;> try assumption
    intros K;
    apply Href; assumption;

/-
### Refinement of programs

A program `p1` refines a program `p2` if `p1` succeed whenever `p2` succeed,
with the same return value, and an environment refining `p2` environment.
-/

def TopM.refines {Δ: Dialect α' σ' ε'} {R} (t1 t2: TopM Δ R) :=
  ∀ env,
  match run t2 env, run t1 env with
  | .error _, _ => true
  | .ok (v2, env2), .ok (v1, env1) => v1 = v2 ∧ env1.refines env2
  | _, _ => false


/-
Copyright (c) 2021 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang

! This file was ported from Lean 3 source module category_theory.sites.cover_lifting
! leanprover-community/mathlib commit 14b69e9f3c16630440a2cbd46f1ddad0d561dee7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Sites.Sheaf
import Mathbin.CategoryTheory.Limits.KanExtension
import Mathbin.CategoryTheory.Sites.CoverPreserving

/-!
# Cover-lifting functors between sites.

We define cover-lifting functors between sites as functors that pull covering sieves back to
covering sieves. This concept is also known as *cocontinuous functors* or
*cover-reflecting functors*, but we have chosen this name following [MM92] in order to avoid
potential naming collision or confusion with the general definition of cocontinuous functors
between categories as functors preserving small colimits.

The definition given here seems stronger than the definition found elsewhere,
but they are actually equivalent via `category_theory.grothendieck_topology.superset_covering`.
(The precise statement is not formalized, but follows from it quite trivially).

## Main definitions

* `category_theory.sites.cover_lifting`: a functor between sites is cover-lifting if it
  pulls back covering sieves to covering sieves
* `category_theory.sites.copullback`: A cover-lifting functor `G : (C, J) ⥤ (D, K)` induces a
  morphism of sites in the same direction as the functor.

## Main results
* `category_theory.sites.Ran_is_sheaf_of_cover_lifting`: If `G : C ⥤ D` is cover_lifting, then
  `Ran G.op` (`ₚu`) as a functor `(Cᵒᵖ ⥤ A) ⥤ (Dᵒᵖ ⥤ A)` of presheaves maps sheaves to sheaves.
* `category_theory.pullback_copullback_adjunction`: If `G : (C, J) ⥤ (D, K)` is cover-lifting,
  cover-preserving, and compatible-preserving, then `pullback G` and `copullback G` are adjoint.

## References

* [Elephant]: *Sketches of an Elephant*, P. T. Johnstone: C2.3.
* [S. MacLane, I. Moerdijk, *Sheaves in Geometry and Logic*][MM92]
* https://stacks.math.columbia.edu/tag/00XI

-/

universe w v v₁ v₂ v₃ u u₁ u₂ u₃

noncomputable section

open CategoryTheory

open Opposite

open CategoryTheory.Presieve.FamilyOfElements

open CategoryTheory.Presieve

open CategoryTheory.Limits

namespace CategoryTheory

section CoverLifting

variable {C : Type _} [Category C] {D : Type _} [Category D] {E : Type _} [Category E]

variable (J : GrothendieckTopology C) (K : GrothendieckTopology D)

variable {L : GrothendieckTopology E}

/-- A functor `G : (C, J) ⥤ (D, K)` between sites is called to have the cover-lifting property
if for all covering sieves `R` in `D`, `R.pullback G` is a covering sieve in `C`.
-/
@[nolint has_nonempty_instance]
structure CoverLifting (G : C ⥤ D) : Prop where
  cover_lift : ∀ {U : C} {S : Sieve (G.obj U)} (hS : S ∈ K (G.obj U)), S.functorPullback G ∈ J U
#align category_theory.cover_lifting CategoryTheory.CoverLifting

/-- The identity functor on a site is cover-lifting. -/
theorem idCoverLifting : CoverLifting J J (𝟭 _) :=
  ⟨fun _ _ h => by simpa using h⟩
#align category_theory.id_cover_lifting CategoryTheory.idCoverLifting

variable {J K}

/-- The composition of two cover-lifting functors are cover-lifting -/
theorem compCoverLifting {F : C ⥤ D} (hu : CoverLifting J K F) {G : D ⥤ E}
    (hv : CoverLifting K L G) : CoverLifting J L (F ⋙ G) :=
  ⟨fun _ S h => hu.cover_lift (hv.cover_lift h)⟩
#align category_theory.comp_cover_lifting CategoryTheory.compCoverLifting

end CoverLifting

/-!
We will now prove that `Ran G.op` (`ₚu`) maps sheaves to sheaves if `G` is cover-lifting. This can
be found in <https://stacks.math.columbia.edu/tag/00XK>. However, the proof given here uses the
amalgamation definition of sheaves, and thus does not require that `C` or `D` has categorical
pullbacks.

For the following proof sketch, `⊆` denotes the homs on `C` and `D` as in the topological analogy.
By definition, the presheaf `𝒢 : Dᵒᵖ ⥤ A` is a sheaf if for every sieve `S` of `U : D`, and every
compatible family of morphisms `X ⟶ 𝒢(V)` for each `V ⊆ U : S` with a fixed source `X`,
we can glue them into a morphism `X ⟶ 𝒢(U)`.

Since the presheaf `𝒢 := (Ran G.op).obj ℱ.val` is defined via `𝒢(U) = lim_{G(V) ⊆ U} ℱ(V)`, for
gluing the family `x` into a `X ⟶ 𝒢(U)`, it suffices to provide a `X ⟶ ℱ(Y)` for each
`G(Y) ⊆ U`. This can be done since `{ Y' ⊆ Y : G(Y') ⊆ U ∈ S}` is a covering sieve for `Y` on
`C` (by the cover-lifting property of `G`). Thus the morphisms `X ⟶ 𝒢(G(Y')) ⟶ ℱ(Y')` can be
glued into a morphism `X ⟶ ℱ(Y)`. This is done in `get_sections`.

In `glued_limit_cone`, we verify these obtained sections are indeed compatible, and thus we obtain
A `X ⟶ 𝒢(U)`. The remaining work is to verify that this is indeed the amalgamation and is unique.
-/

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

variable {A : Type w} [Category.{max u v} A] [HasLimits A]

variable {J : GrothendieckTopology C} {K : GrothendieckTopology D}

namespace RanIsSheafOfCoverLifting

variable {G : C ⥤ D} (hu : CoverLifting J K G) (ℱ : Sheaf J A)

variable {X : A} {U : D} (S : Sieve U) (hS : S ∈ K U)

instance (X : Dᵒᵖ) : HasLimitsOfShape (StructuredArrow X G.op) A :=
  haveI := Limits.hasLimitsOfSizeShrink.{v, max u v, max u v, max u v} A
  has_limits_of_size.has_limits_of_shape _

variable (x : S.arrows.FamilyOfElements ((ran G.op).obj ℱ.val ⋙ coyoneda.obj (op X)))

variable (hx : x.Compatible)

/-- The family of morphisms `X ⟶ 𝒢(G(Y')) ⟶ ℱ(Y')` defined on `{ Y' ⊆ Y : G(Y') ⊆ U ∈ S}`. -/
def pulledbackFamily (Y : StructuredArrow (op U) G.op) :=
  ((x.pullback Y.Hom.unop).functorPullback G).compPresheafMap
    (show _ ⟶ _ from whiskerRight ((Ran.adjunction A G.op).counit.app ℱ.val) (coyoneda.obj (op X)))
#align category_theory.Ran_is_sheaf_of_cover_lifting.pulledback_family CategoryTheory.RanIsSheafOfCoverLifting.pulledbackFamily

@[simp]
theorem pulledbackFamily_apply (Y : StructuredArrow (op U) G.op) {W} {f : W ⟶ _} (Hf) :
    pulledbackFamily ℱ S x Y f Hf =
      x (G.map f ≫ Y.Hom.unop) Hf ≫ ((Ran.adjunction A G.op).counit.app ℱ.val).app (op W) :=
  rfl
#align category_theory.Ran_is_sheaf_of_cover_lifting.pulledback_family_apply CategoryTheory.RanIsSheafOfCoverLifting.pulledbackFamily_apply

variable {x} {S}

include hu hS hx

/-- Given a `G(Y) ⊆ U`, we can find a unique section `X ⟶ ℱ(Y)` that agrees with `x`. -/
def getSection (Y : StructuredArrow (op U) G.op) : X ⟶ ℱ.val.obj Y.right :=
  by
  let hom_sh := whisker_right ((Ran.adjunction A G.op).counit.app ℱ.val) (coyoneda.obj (op X))
  have S' := K.pullback_stable Y.hom.unop hS
  have hs' := ((hx.pullback Y.3.unop).functorPullback G).compPresheafMap hom_sh
  exact (ℱ.2 X _ (hu.cover_lift S')).amalgamate _ hs'
#align category_theory.Ran_is_sheaf_of_cover_lifting.get_section CategoryTheory.RanIsSheafOfCoverLifting.getSection

theorem getSection_isAmalgamation (Y : StructuredArrow (op U) G.op) :
    (pulledbackFamily ℱ S x Y).IsAmalgamation (getSection hu ℱ hS hx Y) :=
  IsSheafFor.isAmalgamation _ _
#align category_theory.Ran_is_sheaf_of_cover_lifting.get_section_is_amalgamation CategoryTheory.RanIsSheafOfCoverLifting.getSection_isAmalgamation

theorem getSection_is_unique (Y : StructuredArrow (op U) G.op) {y}
    (H : (pulledbackFamily ℱ S x Y).IsAmalgamation y) : y = getSection hu ℱ hS hx Y :=
  by
  apply is_sheaf_for.is_separated_for _ (pulledback_family ℱ S x Y)
  · exact H
  · apply get_section_is_amalgamation
  · exact ℱ.2 X _ (hu.cover_lift (K.pullback_stable Y.hom.unop hS))
#align category_theory.Ran_is_sheaf_of_cover_lifting.get_section_is_unique CategoryTheory.RanIsSheafOfCoverLifting.getSection_is_unique

@[simp]
theorem getSection_commute {Y Z : StructuredArrow (op U) G.op} (f : Y ⟶ Z) :
    getSection hu ℱ hS hx Y ≫ ℱ.val.map f.right = getSection hu ℱ hS hx Z :=
  by
  apply get_section_is_unique
  intro V' fV' hV'
  have eq : Z.hom = Y.hom ≫ (G.map f.right.unop).op :=
    by
    convert f.w
    erw [category.id_comp]
  rw [Eq] at hV'
  convert get_section_is_amalgamation hu ℱ hS hx Y (fV' ≫ f.right.unop) _ using 1
  · tidy
  ·
    simp only [Eq, Quiver.Hom.unop_op, pulledback_family_apply, functor.map_comp, unop_comp,
      category.assoc]
  · change S (G.map _ ≫ Y.hom.unop)
    simpa only [functor.map_comp, category.assoc] using hV'
#align category_theory.Ran_is_sheaf_of_cover_lifting.get_section_commute CategoryTheory.RanIsSheafOfCoverLifting.getSection_commute

/-- The limit cone in order to glue the sections obtained via `get_section`. -/
def gluedLimitCone : Limits.Cone (Ran.diagram G.op ℱ.val (op U)) :=
  { pt
    π :=
      { app := fun Y => getSection hu ℱ hS hx Y
        naturality' := fun Y Z f => by tidy } }
#align category_theory.Ran_is_sheaf_of_cover_lifting.glued_limit_cone CategoryTheory.RanIsSheafOfCoverLifting.gluedLimitCone

@[simp]
theorem gluedLimitCone_π_app (W) : (gluedLimitCone hu ℱ hS hx).π.app W = getSection hu ℱ hS hx W :=
  rfl
#align category_theory.Ran_is_sheaf_of_cover_lifting.glued_limit_cone_π_app CategoryTheory.RanIsSheafOfCoverLifting.gluedLimitCone_π_app

/-- The section obtained by passing `glued_limit_cone` into `category_theory.limits.limit.lift`. -/
def gluedSection : X ⟶ ((ran G.op).obj ℱ.val).obj (op U) :=
  limit.lift _ (gluedLimitCone hu ℱ hS hx)
#align category_theory.Ran_is_sheaf_of_cover_lifting.glued_section CategoryTheory.RanIsSheafOfCoverLifting.gluedSection

/--
A helper lemma for the following two lemmas. Basically stating that if the section `y : X ⟶ 𝒢(V)`
coincides with `x` on `G(V')` for all `G(V') ⊆ V ∈ S`, then `X ⟶ 𝒢(V) ⟶ ℱ(W)` is indeed the
section obtained in `get_sections`. That said, this is littered with some more categorical jargon
in order to be applied in the following lemmas easier.
-/
theorem helper {V} (f : V ⟶ U) (y : X ⟶ ((ran G.op).obj ℱ.val).obj (op V)) (W)
    (H : ∀ {V'} {fV : G.obj V' ⟶ V} (hV), y ≫ ((ran G.op).obj ℱ.val).map fV.op = x (fV ≫ f) hV) :
    y ≫ limit.π (Ran.diagram G.op ℱ.val (op V)) W =
      (gluedLimitCone hu ℱ hS hx).π.app ((StructuredArrow.map f.op).obj W) :=
  by
  dsimp only [glued_limit_cone_π_app]
  apply get_section_is_unique hu ℱ hS hx ((structured_arrow.map f.op).obj W)
  intro V' fV' hV'
  dsimp only [Ran.adjunction, Ran.equiv, pulledback_family_apply]
  erw [adjunction.adjunction_of_equiv_right_counit_app]
  have :
    y ≫ ((Ran G.op).obj ℱ.val).map (G.map fV' ≫ W.hom.unop).op =
      x (G.map fV' ≫ W.hom.unop ≫ f) (by simpa only using hV') :=
    by
    convert H (show S ((G.map fV' ≫ W.hom.unop) ≫ f) by simpa only [category.assoc] using hV') using
      2
    simp only [category.assoc]
  simp only [Quiver.Hom.unop_op, Equiv.symm_symm, structured_arrow.map_obj_hom, unop_comp,
    Equiv.coe_fn_mk, functor.comp_map, coyoneda_obj_map, category.assoc, ← this, op_comp,
    Ran_obj_map, nat_trans.id_app]
  erw [category.id_comp, limit.pre_π]
  congr
  convert limit.w (Ran.diagram G.op ℱ.val (op V)) (structured_arrow.hom_mk' W fV'.op)
  rw [structured_arrow.map_mk]
  erw [category.comp_id]
  simp only [Quiver.Hom.unop_op, functor.op_map, Quiver.Hom.op_unop]
#align category_theory.Ran_is_sheaf_of_cover_lifting.helper CategoryTheory.RanIsSheafOfCoverLifting.helper

/-- Verify that the `glued_section` is an amalgamation of `x`. -/
theorem gluedSection_isAmalgamation : x.IsAmalgamation (gluedSection hu ℱ hS hx) :=
  by
  intro V fV hV
  ext W
  simp only [functor.comp_map, limit.lift_pre, coyoneda_obj_map, Ran_obj_map, glued_section]
  erw [limit.lift_π]
  symm
  convert helper hu ℱ hS hx _ (x fV hV) _ _ using 1
  intro V' fV' hV'
  convert hx fV' (𝟙 _) hV hV' (by rw [category.id_comp])
  simp only [op_id, functor_to_types.map_id_apply]
#align category_theory.Ran_is_sheaf_of_cover_lifting.glued_section_is_amalgamation CategoryTheory.RanIsSheafOfCoverLifting.gluedSection_isAmalgamation

/-- Verify that the amalgamation is indeed unique. -/
theorem gluedSection_is_unique (y) (hy : x.IsAmalgamation y) : y = gluedSection hu ℱ hS hx :=
  by
  unfold glued_section limit.lift
  ext W
  erw [limit.lift_π]
  convert helper hu ℱ hS hx (𝟙 _) y W _
  · simp only [op_id, structured_arrow.map_id]
  · intro V' fV' hV'
    convert hy fV' (by simpa only [category.comp_id] using hV')
    erw [category.comp_id]
#align category_theory.Ran_is_sheaf_of_cover_lifting.glued_section_is_unique CategoryTheory.RanIsSheafOfCoverLifting.gluedSection_is_unique

end RanIsSheafOfCoverLifting

/-- If `G` is cover_lifting, then `Ran G.op` pushes sheaves to sheaves.

This result is basically https://stacks.math.columbia.edu/tag/00XK,
but without the condition that `C` or `D` has pullbacks.
-/
theorem ran_isSheaf_of_coverLifting {G : C ⥤ D} (hG : CoverLifting J K G) (ℱ : Sheaf J A) :
    Presheaf.IsSheaf K ((ran G.op).obj ℱ.val) :=
  by
  intro X U S hS x hx
  constructor; swap
  · apply Ran_is_sheaf_of_cover_lifting.glued_section hG ℱ hS hx
  constructor
  · apply Ran_is_sheaf_of_cover_lifting.glued_section_is_amalgamation
  · apply Ran_is_sheaf_of_cover_lifting.glued_section_is_unique
#align category_theory.Ran_is_sheaf_of_cover_lifting CategoryTheory.ran_isSheaf_of_coverLifting

variable (A)

/-- A cover-lifting functor induces a morphism of sites in the same direction as the functor. -/
def Sites.copullback {G : C ⥤ D} (hG : CoverLifting J K G) : Sheaf J A ⥤ Sheaf K A
    where
  obj ℱ := ⟨(ran G.op).obj ℱ.val, ran_isSheaf_of_coverLifting hG ℱ⟩
  map _ _ f := ⟨(ran G.op).map f.val⟩
  map_id' ℱ := Sheaf.Hom.ext _ _ <| (ran G.op).map_id ℱ.val
  map_comp' _ _ _ f g := Sheaf.Hom.ext _ _ <| (ran G.op).map_comp f.val g.val
#align category_theory.sites.copullback CategoryTheory.Sites.copullback

/--
Given a functor between sites that is cover-preserving, cover-lifting, and compatible-preserving,
the pullback and copullback along `G` are adjoint to each other
-/
@[simps unit_app_val counit_app_val]
noncomputable def Sites.pullbackCopullbackAdjunction {G : C ⥤ D} (Hp : CoverPreserving J K G)
    (Hl : CoverLifting J K G) (Hc : CompatiblePreserving K G) :
    Sites.pullback A Hc Hp ⊣ Sites.copullback A Hl
    where
  homEquiv X Y :=
    { toFun := fun f => ⟨(Ran.adjunction A G.op).homEquiv X.val Y.val f.val⟩
      invFun := fun f => ⟨((Ran.adjunction A G.op).homEquiv X.val Y.val).symm f.val⟩
      left_inv := fun f => by
        ext1
        dsimp
        rw [Equiv.symm_apply_apply]
      right_inv := fun f => by
        ext1
        dsimp
        rw [Equiv.apply_symm_apply] }
  Unit :=
    { app := fun X => ⟨(Ran.adjunction A G.op).Unit.app X.val⟩
      naturality' := fun _ _ f =>
        Sheaf.Hom.ext _ _ <| (Ran.adjunction A G.op).Unit.naturality f.val }
  counit :=
    { app := fun X => ⟨(Ran.adjunction A G.op).counit.app X.val⟩
      naturality' := fun _ _ f =>
        Sheaf.Hom.ext _ _ <| (Ran.adjunction A G.op).counit.naturality f.val }
  homEquiv_unit X Y f := by
    ext1
    apply (Ran.adjunction A G.op).homEquiv_unit
  homEquiv_counit X Y f := by
    ext1
    apply (Ran.adjunction A G.op).homEquiv_counit
#align category_theory.sites.pullback_copullback_adjunction CategoryTheory.Sites.pullbackCopullbackAdjunction

end CategoryTheory


/-
Copyright (c) 2017 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn, Ulrik Buchholtz

Quotients. This is a quotient without truncation for an arbitrary type-valued binary relation
(graph).
See also .set_quotient
-/

/-
  The hit quotient is primitive, declared in init.hit.
  The constructors are, given {A : Type _} (R : A → A → Type _),
  * class_of : A → quotient R (A implicit, R explicit)
  * eq_of_rel : Π{a a' : A}, R a a' → class_of a = class_of a' (R explicit)
-/

import hott.arity hott.cubical.squareover hott.types.arrow hott.cubical.pathover2 hott.types.pointed
universes u v w
hott_theory

namespace hott
open hott.eq hott.equiv hott.pi is_trunc pointed hott.sigma

namespace quotient
section
variables {A : Type _} {R : A → A → Type _}

@[hott, induction, priority 1500] protected def elim {P : Type _} (Pc : A → P) (Pp : Π⦃a a' : A⦄
  (H : R a a'), Pc a = Pc a') (x : quotient R) : P :=
begin hinduction x, exact Pc a, exact pathover_of_eq _ (Pp H) end

@[hott, reducible] protected def elim_on {P : Type _} (x : quotient R)
  (Pc : A → P) (Pp : Π⦃a a' : A⦄ (H : R a a'), Pc a = Pc a') : P :=
quotient.elim Pc Pp x

@[hott] theorem elim_eq_of_rel {P : Type _} (Pc : A → P)
  (Pp : Π⦃a a' : A⦄ (H : R a a'), Pc a = Pc a') {a a' : A} (H : R a a')
  : ap (quotient.elim Pc Pp) (eq_of_rel R H) = Pp H :=
begin
  apply eq_of_fn_eq_fn_inv ((pathover_constant (eq_of_rel R H)) _ _),
  refine (apd_eq_pathover_of_eq_ap _ _)⁻¹ ⬝ rec_eq_of_rel _ _ _
end

@[hott] protected def rec_prop {A : Type _} {R : A → A → Type _} {P : quotient R → Type _}
  [H : Πx, is_prop (P x)] (Pc : Π(a : A), P (class_of R a)) (x : quotient R) : P x :=
quotient.rec Pc (λa a' H, is_prop.elimo _ _ _) x

@[hott] protected def elim_prop {P : Type _} [H : is_prop P] (Pc : A → P) (x : quotient R) : P :=
quotient.elim Pc (λa a' H, is_prop.elim _ _) x

@[hott] protected def elim_type (Pc : A → Type _)
  (Pp : Π⦃a a' : A⦄ (H : R a a'), Pc a ≃ Pc a') : quotient R → Type _ :=
quotient.elim Pc (λa a' H, ua (Pp H))

@[hott, reducible] protected def elim_type_on (x : quotient R) (Pc : A → Type _)
  (Pp : Π⦃a a' : A⦄ (H : R a a'), Pc a ≃ Pc a') : Type _ :=
quotient.elim_type Pc Pp x

@[hott] theorem elim_type_eq_of_rel_fn (Pc : A → Type _)
  (Pp : Π⦃a a' : A⦄ (H : R a a'), Pc a ≃ Pc a') {a a' : A} (H : R a a')
  : transport (quotient.elim_type Pc Pp) (eq_of_rel R H) = to_fun (Pp H) :=
begin
  refine tr_eq_cast_ap_fn _ ⬝ ap cast _ ⬝ cast_ua_fn _,
  apply elim_eq_of_rel
end

-- rename to elim_type_eq_of_rel_fn_inv
@[hott] theorem elim_type_eq_of_rel_inv (Pc : A → Type _)
  (Pp : Π⦃a a' : A⦄ (H : R a a'), Pc a ≃ Pc a') {a a' : A} (H : R a a')
  : transport (quotient.elim_type Pc Pp) (eq_of_rel R H)⁻¹ = to_inv (Pp H) :=
begin
  hsimp [tr_eq_cast_ap_fn, quotient.elim_type, ap_inv, elim_eq_of_rel, cast_ua_inv_fn], refl
end

-- remove '
@[hott] theorem elim_type_eq_of_rel_inv' (Pc : A → Type _)
  (Pp : Π⦃a a' : A⦄ (H : R a a'), Pc a ≃ Pc a') {a a' : A} (H : R a a') (x : Pc a')
  : transport (quotient.elim_type Pc Pp) (eq_of_rel R H)⁻¹ x = to_inv (Pp H) x :=
ap10 (elim_type_eq_of_rel_inv Pc Pp H) x

@[hott] theorem elim_type_eq_of_rel (Pc : A → Type u)
  (Pp : Π⦃a a' : A⦄ (H : R a a'), Pc a ≃ Pc a') {a a' : A} (H : R a a') (p : Pc a)
  : transport (quotient.elim_type Pc Pp) (eq_of_rel R H) p = to_fun (Pp H) p :=
ap10 (elim_type_eq_of_rel_fn Pc Pp H) p

@[hott] def elim_type_eq_of_rel' (Pc : A → Type _)
  (Pp : Π⦃a a' : A⦄ (H : R a a'), Pc a ≃ Pc a') {a a' : A} (H : R a a') (p : Pc a)
  : @pathover _ (class_of _ a) (quotient.elim_type Pc Pp) p _ (eq_of_rel R H) (to_fun (Pp H) p) :=
pathover_of_tr_eq (elim_type_eq_of_rel Pc Pp H p)

@[hott] def elim_type_uncurried (H : Σ(Pc : A → Type _),  Π⦃a a' : A⦄ (H : R a a'), Pc a ≃ Pc a')
  : quotient R → Type _ :=
quotient.elim_type H.1 H.2

/- The dependent universal property -/
@[hott] def quotient_pi_equiv (C : quotient R → Type _) : (Πx, C x) ≃
  (Σ(f : Π(a : A), C (class_of R a)),  Π⦃a a' : A⦄ (H : R a a'), f a =[eq_of_rel R H] f a') :=
begin
  fapply equiv.MK,
  { intro f, exact ⟨λa, f (class_of R a), λa a' H, apd f (eq_of_rel R H)⟩},
  { intros v x, induction v with i p, hinduction x,
      exact (i a),
      exact (p H)},
  { intro v, induction v with i p,
    apply ap (sigma.mk i), apply eq_of_homotopy3, intros a a' H, apply rec_eq_of_rel},
  { intro f, apply eq_of_homotopy, intro x, hinduction x, reflexivity,
    apply eq_pathover_dep, rwr rec_eq_of_rel, exact hrflo},
end

@[hott] def pquotient {A : Type*} (R : A → A → Type _) : Type* :=
pType.mk (quotient R) (class_of R pt)
end

/- the flattening lemma -/

namespace flattening
section

parameters {A : Type u} (R : A → A → Type v) (C : A → Type w) (f : Π⦃a a'⦄, R a a' → C a ≃ C a')
include f
variables {a a' : A} {r : R a a'}

private def P : quotient R → Type w := quotient.elim_type C f

@[hott] def flattening_type : Type (max u w) := Σa, C a
private def X := flattening_type
inductive flattening_rel : X → X → Type (max u v w)
| mk : Π⦃a a' : A⦄ (r : R a a') (c : C a), flattening_rel ⟨a, c⟩ ⟨a', f r c⟩

@[hott] def Ppt (c : C a) : sigma P :=
⟨class_of R a, c⟩

@[hott] def Peq (r : R a a') (c : C a) : Ppt c = Ppt (f r c) :=
begin
  fapply sigma_eq,
  { apply eq_of_rel R r},
  { refine elim_type_eq_of_rel' C f r c}
end

@[hott] def rec {Q : sigma P → Type _} (Qpt : Π{a : A} (x : C a), Q (Ppt x))
  (Qeq : Π⦃a a' : A⦄ (r : R a a') (c : C a), Qpt c =[Peq r c] Qpt (f r c))
  (v : sigma P) : Q v :=
begin
  induction v with q p,
  hinduction q,
  { exact Qpt p},
  { apply pi_pathover_left, intro c,
    refine _ ⬝op apdt Qpt (elim_type_eq_of_rel C f H c)⁻¹ᵖ,
    refine _ ⬝op (tr_compose Q (Ppt R C f) _ _)⁻¹,
    rwr ap_inv,
    refine pathover_cancel_right _ (tr_pathover _ _)⁻¹ᵒ,
    refine change_path _ (Qeq H c),
    symmetry, dsimp [Ppt, Peq],
    refine whisker_left _ (ap_dpair _) ⬝ _,
    refine (dpair_eq_dpair_con _ _ _ _)⁻¹ ⬝ _,
    apply ap (dpair_eq_dpair _), symmetry,
    exact pathover_of_tr_eq_eq_concato _ },
end

@[hott] def elim' {Q : Type _} (Qpt : Π{a : A}, C a → Q)
  (Qeq : Π⦃a a' : A⦄ (r : R a a') (c : C a), Qpt c = Qpt (f r c))
  (q : quotient R) (p : P q) : Q :=
begin
  hinduction q,
  { exact Qpt p},
  { apply arrow_pathover_constant_right,
    intro c, exact Qeq H c ⬝ ap Qpt (elim_type_eq_of_rel C f H c)⁻¹},
end

@[hott] def elim {Q : Type _} (Qpt : Π{a : A}, C a → Q)
  (Qeq : Π⦃a a' : A⦄ (r : R a a') (c : C a), Qpt c = Qpt (f r c))
  (v : sigma P) : Q :=
begin
  induction v with q p, exact elim' R C f @Qpt Qeq q p,
end

@[hott] theorem elim_Peq {Q : Type _} (Qpt : Π{a : A}, C a → Q)
  (Qeq : Π⦃a a' : A⦄ (r : R a a') (c : C a), Qpt c = Qpt (f r c)) {a a' : A} (r : R a a')
  (c : C a) : ap (elim @Qpt Qeq) (Peq r c) = Qeq r c :=
begin
  refine ap_dpair_eq_dpair _ _ _ ⬝ _,
  refine apd011_eq_apo11_apd (elim' R C f @Qpt Qeq) _ _ ⬝ _,
  delta elim', dsimp, rwr [rec_eq_of_rel], dsimp,
  refine @apo11_arrow_pathover_constant_right _ _ _ _ _ _ _ _ _ _ _
    (λc : P R C f (class_of R a), Qeq r c ⬝ ap Qpt (elim_type_eq_of_rel C f r c)⁻¹) ⬝ _,
    -- we need the @ because otherwise the elaborator unfolds too much
  dsimp [elim_type_eq_of_rel'],
  refine idp ◾ idp ◾ ap02 _ begin exact to_right_inv (pathover_equiv_tr_eq _ _ _) _ end ⬝ _,
  rwr [ap_inv], apply inv_con_cancel_right
end

open flattening_rel
@[hott] def flattening_lemma : sigma P ≃ quotient flattening_rel :=
begin
  fapply equiv.MK,
  { refine elim R C f _ _,
    { intros a c, exact class_of _ ⟨a, c⟩},
    { intros a a' r c, apply eq_of_rel, constructor}},
  { intro q, hinduction q with x x x' H,
    { exact Ppt R C f x.2},
    { induction H, apply Peq}},
  { intro q, hinduction q with x x x' H,
    { induction x with a c, reflexivity},
    { induction H, apply eq_pathover, apply hdeg_square,
      refine ap_compose (elim R C f _ _) (quotient.elim _ _) _ ⬝ _,
      rwr [elim_eq_of_rel, ap_id],
      apply elim_Peq }},
  { refine rec R C f (λa x, idp) _, intros,
    apply eq_pathover, apply hdeg_square,
      refine ap_compose (quotient.elim _ _) (elim R C f _ _) _ ⬝ _,
      rwr [elim_Peq, ap_id],
      apply elim_eq_of_rel }
end

end
end flattening

section
open hott.is_equiv hott.equiv prod
variables {A : Type _} {R : A → A → Type _}
          {B : Type _} {Q : B → B → Type _}
          {C : Type _} {S : C → C → Type _}
          (f : A → B) (k : Πa a' : A, R a a' → Q (f a) (f a'))
          (g : B → C) (l : Πb b' : B, Q b b' → S (g b) (g b'))

@[hott] protected def functor : quotient R → quotient Q :=
quotient.elim (λa, class_of Q (f a)) (λa a' r, eq_of_rel Q (k a a' r))

@[hott, hsimp] def functor_class_of (a : A) :
  quotient.functor f k (class_of R a) = class_of Q (f a) :=
by refl

@[hott, hsimp] def functor_eq_of_rel {a a' : A} (r : R a a') :
  ap (quotient.functor f k) (eq_of_rel R r) = eq_of_rel Q (k a a' r) :=
elim_eq_of_rel _ _ r

@[hott] protected def functor_compose :
  quotient.functor (g ∘ f) (λa a' r, l (f a) (f a') (k a a' r)) ~
  quotient.functor g l ∘ quotient.functor f k :=
begin
  intro x, hinduction x,
  { refl },
  { dsimp, apply eq_pathover_compose_right, apply hdeg_square, hsimp }
end

@[hott] protected def functor_homotopy {f f' : A → B} {k : Πa a' : A, R a a' → Q (f a) (f a')}
  {k' : Πa a' : A, R a a' → Q (f' a) (f' a')} (h : f ~ f')
  (h2 : Π(a a' : A) (r : R a a'), transport11 Q (h a) (h a') (k a a' r) = k' a a' r) :
  quotient.functor f k ~ quotient.functor f' k' :=
begin
  intro x, hinduction x with a a a' r,
  { exact ap (class_of Q) (h a) },
  { dsimp, apply eq_pathover, hsimp, apply transpose, apply natural_square2, apply h2 }
end

@[hott] protected def functor_id (x : quotient R) :
  quotient.functor id (λa a' r, r) x = x :=
begin
  hinduction x,
  { refl },
  { apply eq_pathover_id_right, apply hdeg_square, hsimp }
end

variables [F : is_equiv f] [K : Πa a', is_equiv (k a a')]
include F K

@[hott] instance is_equiv : is_equiv (quotient.functor f k) :=
begin
  apply adjointify _ (quotient.functor f⁻¹ᶠ
    (λb b' q, (k (f⁻¹ᶠ b) (f⁻¹ᶠ b'))⁻¹ᶠ (transport11 Q (right_inv f b)⁻¹ (right_inv f b')⁻¹ q))),
  abstract { intro x, refine (quotient.functor_compose _ _ _ _ x)⁻¹ ⬝ _ ⬝ quotient.functor_id x,
    apply quotient.functor_homotopy (right_inv f), intros a a' r,
    rwr [right_inv (k _ _), ←transport11_con, con.left_inv, con.left_inv] },
  abstract { intro x, refine (quotient.functor_compose _ _ _ _ x)⁻¹ ⬝ _ ⬝ quotient.functor_id x,
    apply quotient.functor_homotopy (left_inv f), intros a a' r,
    rwr [adj f, adj f, ←ap_inv, ←ap_inv, transport11_ap,
         ←fn_transport11_eq_transport11_fn _ _ _ _ k, left_inv (k _ _), ←transport11_con,
         con.left_inv, con.left_inv] }
end
end

section
variables {A : Type _} (R : A → A → Type _)
           {B : Type _} (Q : B → B → Type _)
           (f : A ≃ B) (k : Πa a' : A, R a a' ≃ Q (f a) (f a'))
include f k

@[hott] protected def equiv : quotient R ≃ quotient Q :=
equiv.mk (quotient.functor f (λa a', k a a')) (quotient.is_equiv _ _)
end

end quotient
end hott


/-
Copyright (c) 2020 Oliver Nash. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Oliver Nash
-/
import algebra.invertible
import data.matrix.basis
import data.matrix.dmatrix
import algebra.lie.abelian
import linear_algebra.matrix.trace
import algebra.lie.skew_adjoint

/-!
# Classical Lie algebras

This file is the place to find definitions and basic properties of the classical Lie algebras:
  * Aₗ = sl(l+1)
  * Bₗ ≃ so(l+1, l) ≃ so(2l+1)
  * Cₗ = sp(l)
  * Dₗ ≃ so(l, l) ≃ so(2l)

## Main definitions

  * `lie_algebra.special_linear.sl`
  * `lie_algebra.symplectic.sp`
  * `lie_algebra.orthogonal.so`
  * `lie_algebra.orthogonal.so'`
  * `lie_algebra.orthogonal.so_indefinite_equiv`
  * `lie_algebra.orthogonal.type_D`
  * `lie_algebra.orthogonal.type_B`
  * `lie_algebra.orthogonal.type_D_equiv_so'`
  * `lie_algebra.orthogonal.type_B_equiv_so'`

## Implementation notes

### Matrices or endomorphisms

Given a finite type and a commutative ring, the corresponding square matrices are equivalent to the
endomorphisms of the corresponding finite-rank free module as Lie algebras, see `lie_equiv_matrix'`.
We can thus define the classical Lie algebras as Lie subalgebras either of matrices or of
endomorphisms. We have opted for the former. At the time of writing (August 2020) it is unclear
which approach should be preferred so the choice should be assumed to be somewhat arbitrary.

### Diagonal quadratic form or diagonal Cartan subalgebra

For the algebras of type `B` and `D`, there are two natural definitions. For example since the
the `2l × 2l` matrix:
$$
  J = \left[\begin{array}{cc}
              0_l & 1_l\\
              1_l & 0_l
            \end{array}\right]
$$
defines a symmetric bilinear form equivalent to that defined by the identity matrix `I`, we can
define the algebras of type `D` to be the Lie subalgebra of skew-adjoint matrices either for `J` or
for `I`. Both definitions have their advantages (in particular the `J`-skew-adjoint matrices define
a Lie algebra for which the diagonal matrices form a Cartan subalgebra) and so we provide both.
We thus also provide equivalences `type_D_equiv_so'`, `so_indefinite_equiv` which show the two
definitions are equivalent. Similarly for the algebras of type `B`.

## Tags

classical lie algebra, special linear, symplectic, orthogonal
-/

universes u₁ u₂

namespace lie_algebra
open matrix
open_locale matrix

variables (n p q l : Type*) (R : Type u₂)
variables [decidable_eq n] [decidable_eq p] [decidable_eq q] [decidable_eq l]
variables [comm_ring R]

@[simp] lemma matrix_trace_commutator_zero [fintype n] (X Y : matrix n n R) :
  matrix.trace n R R ⁅X, Y⁆ = 0 :=
calc _ = matrix.trace n R R (X ⬝ Y) - matrix.trace n R R (Y ⬝ X) : linear_map.map_sub _ _ _
   ... = matrix.trace n R R (X ⬝ Y) - matrix.trace n R R (X ⬝ Y) :
     congr_arg (λ x, _ - x) (matrix.trace_mul_comm Y X)
   ... = 0 : sub_self _

namespace special_linear

/-- The special linear Lie algebra: square matrices of trace zero. -/
def sl [fintype n] : lie_subalgebra R (matrix n n R) :=
{ lie_mem' := λ X Y _ _, linear_map.mem_ker.2 $ matrix_trace_commutator_zero _ _ _ _,
  ..linear_map.ker (matrix.trace n R R) }

lemma sl_bracket [fintype n] (A B : sl n R) : ⁅A, B⁆.val = A.val ⬝ B.val - B.val ⬝ A.val := rfl

section elementary_basis

variables {n} [fintype n] (i j : n)

/-- When j ≠ i, the elementary matrices are elements of sl n R, in fact they are part of a natural
basis of sl n R. -/
def Eb (h : j ≠ i) : sl n R :=
⟨matrix.std_basis_matrix i j (1 : R),
  show matrix.std_basis_matrix i j (1 : R) ∈ linear_map.ker (matrix.trace n R R),
  from matrix.std_basis_matrix.trace_zero i j (1 : R) h⟩

@[simp] lemma Eb_val (h : j ≠ i) : (Eb R i j h).val = matrix.std_basis_matrix i j 1 := rfl

end elementary_basis

end special_linear

namespace symplectic

/-- The matrix defining the canonical skew-symmetric bilinear form. -/
def J : matrix (l ⊕ l) (l ⊕ l) R := matrix.from_blocks 0 (-1) 1 0

/-- The symplectic Lie algebra: skew-adjoint matrices with respect to the canonical skew-symmetric
bilinear form. -/
def sp [fintype l] : lie_subalgebra R (matrix (l ⊕ l) (l ⊕ l) R) :=
  skew_adjoint_matrices_lie_subalgebra (J l R)

end symplectic

namespace orthogonal

/-- The definite orthogonal Lie subalgebra: skew-adjoint matrices with respect to the symmetric
bilinear form defined by the identity matrix. -/
def so [fintype n] : lie_subalgebra R (matrix n n R) :=
  skew_adjoint_matrices_lie_subalgebra (1 : matrix n n R)

@[simp] lemma mem_so [fintype n] (A : matrix n n R) : A ∈ so n R ↔ Aᵀ = -A :=
begin
  erw mem_skew_adjoint_matrices_submodule,
  simp only [matrix.is_skew_adjoint, matrix.is_adjoint_pair, matrix.mul_one, matrix.one_mul],
end

/-- The indefinite diagonal matrix with `p` 1s and `q` -1s. -/
def indefinite_diagonal : matrix (p ⊕ q) (p ⊕ q) R :=
  matrix.diagonal $ sum.elim (λ _, 1) (λ _, -1)

/-- The indefinite orthogonal Lie subalgebra: skew-adjoint matrices with respect to the symmetric
bilinear form defined by the indefinite diagonal matrix. -/
def so' [fintype p] [fintype q] : lie_subalgebra R (matrix (p ⊕ q) (p ⊕ q) R) :=
  skew_adjoint_matrices_lie_subalgebra $ indefinite_diagonal p q R

/-- A matrix for transforming the indefinite diagonal bilinear form into the definite one, provided
the parameter `i` is a square root of -1. -/
def Pso (i : R) : matrix (p ⊕ q) (p ⊕ q) R :=
  matrix.diagonal $ sum.elim (λ _, 1) (λ _, i)

variables [fintype p] [fintype q]

lemma Pso_inv {i : R} (hi : i*i = -1) : (Pso p q R i) * (Pso p q R (-i)) = 1 :=
begin
  ext x y, rcases x; rcases y,
  { -- x y : p
    by_cases h : x = y; simp [Pso, indefinite_diagonal, h], },
  { -- x : p, y : q
    simp [Pso, indefinite_diagonal], },
  { -- x : q, y : p
    simp [Pso, indefinite_diagonal], },
  { -- x y : q
    by_cases h : x = y; simp [Pso, indefinite_diagonal, h, hi], },
end

/-- There is a constructive inverse of `Pso p q R i`. -/
def invertible_Pso {i : R} (hi : i*i = -1) : invertible (Pso p q R i) :=
invertible_of_right_inverse _ _ (Pso_inv p q R hi)

lemma indefinite_diagonal_transform {i : R} (hi : i*i = -1) :
  (Pso p q R i)ᵀ ⬝ (indefinite_diagonal p q R) ⬝ (Pso p q R i) = 1 :=
begin
  ext x y, rcases x; rcases y,
  { -- x y : p
    by_cases h : x = y; simp [Pso, indefinite_diagonal, h], },
  { -- x : p, y : q
    simp [Pso, indefinite_diagonal], },
  { -- x : q, y : p
    simp [Pso, indefinite_diagonal], },
  { -- x y : q
    by_cases h : x = y; simp [Pso, indefinite_diagonal, h, hi], },
end

/-- An equivalence between the indefinite and definite orthogonal Lie algebras, over a ring
containing a square root of -1. -/
def so_indefinite_equiv {i : R} (hi : i*i = -1) : so' p q R ≃ₗ⁅R⁆ so (p ⊕ q) R :=
begin
  apply (skew_adjoint_matrices_lie_subalgebra_equiv
    (indefinite_diagonal p q R) (Pso p q R i) (invertible_Pso p q R hi)).trans,
  apply lie_equiv.of_eq,
  ext A, rw indefinite_diagonal_transform p q R hi, refl,
end

lemma so_indefinite_equiv_apply {i : R} (hi : i*i = -1) (A : so' p q R) :
  (so_indefinite_equiv p q R hi A : matrix (p ⊕ q) (p ⊕ q) R) =
    (Pso p q R i)⁻¹ ⬝ (A : matrix (p ⊕ q) (p ⊕ q) R) ⬝ (Pso p q R i) :=
by erw [lie_equiv.trans_apply, lie_equiv.of_eq_apply,
        skew_adjoint_matrices_lie_subalgebra_equiv_apply]

/-- A matrix defining a canonical even-rank symmetric bilinear form.

It looks like this as a `2l x 2l` matrix of `l x l` blocks:

   [ 0 1 ]
   [ 1 0 ]
-/
def JD : matrix (l ⊕ l) (l ⊕ l) R := matrix.from_blocks 0 1 1 0

/-- The classical Lie algebra of type D as a Lie subalgebra of matrices associated to the matrix
`JD`. -/
def type_D [fintype l] := skew_adjoint_matrices_lie_subalgebra (JD l R)

/-- A matrix transforming the bilinear form defined by the matrix `JD` into a split-signature
diagonal matrix.

It looks like this as a `2l x 2l` matrix of `l x l` blocks:

   [ 1 -1 ]
   [ 1  1 ]
-/
def PD : matrix (l ⊕ l) (l ⊕ l) R := matrix.from_blocks 1 (-1) 1 1

/-- The split-signature diagonal matrix. -/
def S := indefinite_diagonal l l R

lemma S_as_blocks : S l R = matrix.from_blocks 1 0 0 (-1) :=
begin
  rw [← matrix.diagonal_one, matrix.diagonal_neg, matrix.from_blocks_diagonal],
  refl,
end

lemma JD_transform [fintype l] : (PD l R)ᵀ ⬝ (JD l R) ⬝ (PD l R) = (2 : R) • (S l R) :=
begin
  have h : (PD l R)ᵀ ⬝ (JD l R) = matrix.from_blocks 1 1 1 (-1) := by
  { simp [PD, JD, matrix.from_blocks_transpose, matrix.from_blocks_multiply], },
  erw [h, S_as_blocks, matrix.from_blocks_multiply, matrix.from_blocks_smul],
  congr; simp [two_smul],
end

lemma PD_inv [fintype l] [invertible (2 : R)] : (PD l R) * (⅟(2 : R) • (PD l R)ᵀ) = 1 :=
begin
  have h : ⅟(2 : R) • (1 : matrix l l R) + ⅟(2 : R) • 1 = 1 := by
    rw [← smul_add, ← (two_smul R _), smul_smul, inv_of_mul_self, one_smul],
  erw [matrix.from_blocks_transpose, matrix.from_blocks_smul, matrix.mul_eq_mul,
    matrix.from_blocks_multiply],
  simp [h],
end

instance invertible_PD [fintype l] [invertible (2 : R)] : invertible (PD l R) :=
invertible_of_right_inverse _ _ (PD_inv l R)

/-- An equivalence between two possible definitions of the classical Lie algebra of type D. -/
def type_D_equiv_so' [fintype l] [invertible (2 : R)] :
  type_D l R ≃ₗ⁅R⁆ so' l l R :=
begin
  apply (skew_adjoint_matrices_lie_subalgebra_equiv (JD l R) (PD l R) (by apply_instance)).trans,
  apply lie_equiv.of_eq,
  ext A,
  rw [JD_transform, ← coe_unit_of_invertible (2 : R), ←units.smul_def, lie_subalgebra.mem_coe,
      mem_skew_adjoint_matrices_lie_subalgebra_unit_smul],
  refl,
end

/-- A matrix defining a canonical odd-rank symmetric bilinear form.

It looks like this as a `(2l+1) x (2l+1)` matrix of blocks:

   [ 2 0 0 ]
   [ 0 0 1 ]
   [ 0 1 0 ]

where sizes of the blocks are:

   [`1 x 1` `1 x l` `1 x l`]
   [`l x 1` `l x l` `l x l`]
   [`l x 1` `l x l` `l x l`]
-/
def JB := matrix.from_blocks ((2 : R) • 1 : matrix unit unit R) 0 0 (JD l R)

/-- The classical Lie algebra of type B as a Lie subalgebra of matrices associated to the matrix
`JB`. -/
def type_B  [fintype l] := skew_adjoint_matrices_lie_subalgebra(JB l R)

/-- A matrix transforming the bilinear form defined by the matrix `JB` into an
almost-split-signature diagonal matrix.

It looks like this as a `(2l+1) x (2l+1)` matrix of blocks:

   [ 1 0  0 ]
   [ 0 1 -1 ]
   [ 0 1  1 ]

where sizes of the blocks are:

   [`1 x 1` `1 x l` `1 x l`]
   [`l x 1` `l x l` `l x l`]
   [`l x 1` `l x l` `l x l`]
-/
def PB := matrix.from_blocks (1 : matrix unit unit R) 0 0 (PD l R)

variable [fintype l]

lemma PB_inv [invertible (2 : R)] : PB l R * matrix.from_blocks 1 0 0 (⅟(PD l R)) = 1 :=
begin
  rw [PB, matrix.mul_eq_mul, matrix.from_blocks_multiply, matrix.mul_inv_of_self],
  simp only [matrix.mul_zero, matrix.mul_one, matrix.zero_mul, zero_add, add_zero,
    matrix.from_blocks_one]
end

instance invertible_PB [invertible (2 : R)] : invertible (PB l R) :=
invertible_of_right_inverse _ _ (PB_inv l R)

lemma JB_transform : (PB l R)ᵀ ⬝ (JB l R) ⬝ (PB l R) = (2 : R) • matrix.from_blocks 1 0 0 (S l R) :=
by simp [PB, JB, JD_transform, matrix.from_blocks_transpose, matrix.from_blocks_multiply,
         matrix.from_blocks_smul]

lemma indefinite_diagonal_assoc :
  indefinite_diagonal (unit ⊕ l) l R =
  matrix.reindex_lie_equiv (equiv.sum_assoc unit l l).symm
    (matrix.from_blocks 1 0 0 (indefinite_diagonal l l R)) :=
begin
  ext i j,
  rcases i with ⟨⟨i₁ | i₂⟩ | i₃⟩;
  rcases j with ⟨⟨j₁ | j₂⟩ | j₃⟩;
  simp only [indefinite_diagonal, matrix.diagonal, equiv.sum_assoc_apply_in1,
    matrix.reindex_lie_equiv_apply, matrix.minor_apply, equiv.symm_symm, matrix.reindex_apply,
    sum.elim_inl, if_true, eq_self_iff_true, matrix.one_apply_eq, matrix.from_blocks_apply₁₁,
    dmatrix.zero_apply, equiv.sum_assoc_apply_in2, if_false, matrix.from_blocks_apply₁₂,
    matrix.from_blocks_apply₂₁, matrix.from_blocks_apply₂₂, equiv.sum_assoc_apply_in3,
    sum.elim_inr];
  congr,
end

/-- An equivalence between two possible definitions of the classical Lie algebra of type B. -/
def type_B_equiv_so' [invertible (2 : R)] :
  type_B l R ≃ₗ⁅R⁆ so' (unit ⊕ l) l R :=
begin
  apply (skew_adjoint_matrices_lie_subalgebra_equiv (JB l R) (PB l R) (by apply_instance)).trans,
  symmetry,
  apply (skew_adjoint_matrices_lie_subalgebra_equiv_transpose
    (indefinite_diagonal (unit ⊕ l) l R)
    (matrix.reindex_alg_equiv _ (equiv.sum_assoc punit l l)) (matrix.transpose_reindex _ _)).trans,
  apply lie_equiv.of_eq,
  ext A,
  rw [JB_transform, ← coe_unit_of_invertible (2 : R), ←units.smul_def, lie_subalgebra.mem_coe,
      lie_subalgebra.mem_coe, mem_skew_adjoint_matrices_lie_subalgebra_unit_smul],
  simpa [indefinite_diagonal_assoc],
end

end orthogonal

end lie_algebra


/-
Copyright (c) 2016 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura

Auxiliary lemmas used to compare int numerals.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.data.int.order

namespace Mathlib

namespace int

/- Auxiliary lemmas for proving that to int numerals are different -/

/- 1. Lemmas for reducing the problem to the case where the numerals are positive -/

protected theorem ne_neg_of_ne {a : ℤ} {b : ℤ} : a ≠ b → -a ≠ -b :=
  fun (h₁ : a ≠ b) (h₂ : -a = -b) => absurd (int.neg_inj h₂) h₁

protected theorem neg_ne_zero_of_ne {a : ℤ} : a ≠ 0 → -a ≠ 0 :=
  fun (h₁ : a ≠ 0) (h₂ : -a = 0) =>
    (fun (this : -a = -0) => (fun (this : a = 0) => absurd this h₁) (int.neg_inj this))
      (eq.mpr (id (Eq._oldrec (Eq.refl (-a = -0)) int.neg_zero)) h₂)

protected theorem zero_ne_neg_of_ne {a : ℤ} (h : 0 ≠ a) : 0 ≠ -a :=
  ne.symm (int.neg_ne_zero_of_ne (ne.symm h))

protected theorem neg_ne_of_pos {a : ℤ} {b : ℤ} : a > 0 → b > 0 → -a ≠ b := sorry

protected theorem ne_neg_of_pos {a : ℤ} {b : ℤ} : a > 0 → b > 0 → a ≠ -b :=
  fun (h₁ : a > 0) (h₂ : b > 0) => ne.symm (int.neg_ne_of_pos h₂ h₁)

/- 2. Lemmas for proving that positive int numerals are nonneg and positive -/

protected theorem one_pos : 1 > 0 :=
  int.zero_lt_one

protected theorem bit0_pos {a : ℤ} : a > 0 → bit0 a > 0 :=
  fun (h : a > 0) => int.add_pos h h

protected theorem bit1_pos {a : ℤ} : a ≥ 0 → bit1 a > 0 :=
  fun (h : a ≥ 0) => int.lt_add_of_le_of_pos (int.add_nonneg h h) int.zero_lt_one

protected theorem zero_nonneg : 0 ≥ 0 :=
  le_refl 0

protected theorem one_nonneg : 1 ≥ 0 :=
  le_of_lt int.zero_lt_one

protected theorem bit0_nonneg {a : ℤ} : a ≥ 0 → bit0 a ≥ 0 :=
  fun (h : a ≥ 0) => int.add_nonneg h h

protected theorem bit1_nonneg {a : ℤ} : a ≥ 0 → bit1 a ≥ 0 :=
  fun (h : a ≥ 0) => le_of_lt (int.bit1_pos h)

protected theorem nonneg_of_pos {a : ℤ} : a > 0 → a ≥ 0 :=
  le_of_lt

/- 3. nat_abs auxiliary lemmas -/

theorem neg_succ_of_nat_lt_zero (n : ℕ) : Int.negSucc n < 0 := sorry

theorem of_nat_ge_zero (n : ℕ) : Int.ofNat n ≥ 0 :=
  le.intro
    (eq.mpr (id (Eq._oldrec (Eq.refl (0 + ↑n = Int.ofNat n)) (int.zero_add ↑n)))
      (eq.mpr (id (Eq._oldrec (Eq.refl (↑n = Int.ofNat n)) (int.coe_nat_eq n))) (Eq.refl (Int.ofNat n))))

theorem of_nat_nat_abs_eq_of_nonneg {a : ℤ} : a ≥ 0 → Int.ofNat (nat_abs a) = a := sorry

theorem ne_of_nat_abs_ne_nat_abs_of_nonneg {a : ℤ} {b : ℤ} (ha : a ≥ 0) (hb : b ≥ 0) (h : nat_abs a ≠ nat_abs b) : a ≠ b := sorry

protected theorem ne_of_nat_ne_nonneg_case {a : ℤ} {b : ℤ} {n : ℕ} {m : ℕ} (ha : a ≥ 0) (hb : b ≥ 0) (e1 : nat_abs a = n) (e2 : nat_abs b = m) (h : n ≠ m) : a ≠ b :=
  (fun (this : nat_abs a ≠ nat_abs b) => ne_of_nat_abs_ne_nat_abs_of_nonneg ha hb this)
    (eq.mpr (id (Eq._oldrec (Eq.refl (nat_abs a ≠ nat_abs b)) e1))
      (eq.mpr (id (Eq._oldrec (Eq.refl (n ≠ nat_abs b)) e2)) h))

/- 4. Aux lemmas for pushing nat_abs inside numerals
   nat_abs_zero and nat_abs_one are defined at init/data/int/basic.lean -/

theorem nat_abs_of_nat_core (n : ℕ) : nat_abs (Int.ofNat n) = n :=
  rfl

theorem nat_abs_of_neg_succ_of_nat (n : ℕ) : nat_abs (Int.negSucc n) = Nat.succ n :=
  rfl

protected theorem nat_abs_add_nonneg {a : ℤ} {b : ℤ} : a ≥ 0 → b ≥ 0 → nat_abs (a + b) = nat_abs a + nat_abs b := sorry

protected theorem nat_abs_add_neg {a : ℤ} {b : ℤ} : a < 0 → b < 0 → nat_abs (a + b) = nat_abs a + nat_abs b := sorry

protected theorem nat_abs_bit0 (a : ℤ) : nat_abs (bit0 a) = bit0 (nat_abs a) := sorry

protected theorem nat_abs_bit0_step {a : ℤ} {n : ℕ} (h : nat_abs a = n) : nat_abs (bit0 a) = bit0 n :=
  eq.mpr (id (Eq._oldrec (Eq.refl (nat_abs (bit0 a) = bit0 n)) (Eq.symm h))) (int.nat_abs_bit0 a)

protected theorem nat_abs_bit1_nonneg {a : ℤ} (h : a ≥ 0) : nat_abs (bit1 a) = bit1 (nat_abs a) := sorry

protected theorem nat_abs_bit1_nonneg_step {a : ℤ} {n : ℕ} (h₁ : a ≥ 0) (h₂ : nat_abs a = n) : nat_abs (bit1 a) = bit1 n :=
  eq.mpr (id (Eq._oldrec (Eq.refl (nat_abs (bit1 a) = bit1 n)) (Eq.symm h₂))) (int.nat_abs_bit1_nonneg h₁)


namespace ch3_2
  section
    variables p q : Prop

    theorem t1 : p → q → p := by { intros hp hq, assumption }

    section
      variables r : Prop

      theorem t2 (h₁ : q → r) (h₂ : p → q) : p → r :=
        by { intros hp, simp * }
    end
  end
end ch3_2

namespace ch3_3
  section
    variables p q : Prop

    example (hp : p) (hq : q) : p ∧ q := by simp *

    example (h : p ∧ q) : p := by simp *
    example (h : p ∧ q) : q := by simp *

    example (h : p ∧ q) : q ∧ p := by simp *

    section
      variables (hp : p) (hq : q)

      example : p ∧ q := let hp := hp, hq := hq in by simp *
    end

    example (h : p ∧ q) : q ∧ p := by simp *

    example (h : p ∧ q) : q ∧ p ∧ q := by simp *
    example (h : p ∧ q) : q ∧ p ∧ q := by simp *

    example (hp : p) : p ∨ q := by simp *
    example (hq : q) : p ∨ q := by simp *

    example (h : p ∨ q) : q ∨ p := by { cases h with hp hq; simp * }

    example (hpq : p → q) (hnq: ¬q) : ¬p := by { intro hp, have hq := hpq hp, contradiction }

    example (hp : p) (hnp: ¬p) : q := by contradiction

    section
      variables r : Prop

      example (hnp : ¬p) (hq : q) (hqp : q → p) : r := by { have hp := hqp hq, contradiction }
    end

    theorem and_swap : p ∧ q ↔ q ∧ p := by { split; intro h; simp * }
  end
end ch3_3

namespace ch3_5
  open classical

  theorem dne {p : Prop} (h : ¬¬p) : p := by_contradiction (by contradiction)

  section
    variables (p q : Prop)

    example (h : ¬(p ∧ q)) : ¬p ∨ ¬q :=
    begin
      apply by_cases,
        show p → ¬p ∨ ¬q, intro hp, right, intro hq, apply h, simp *,
        show ¬p → ¬p ∨ ¬q, intro hnp, simp *
    end
  end
end ch3_5

namespace ch4_1
  section
    variables (α : Type) (p q : α → Prop)

    example : (∀ x : α, p x ∧ q x) -> ∀ y : α, p y := by { intro hpq, simp * }
  end

  section
    variables (α : Type) (r : α → α → Prop)

    variable refl_r : ∀ x, r x x
    variable symm_r : ∀ {x y}, r x y → r y x
    variable trans_r : ∀ {x y z}, r x y → r y z → r x z

    include refl_r symm_r trans_r
    example (a b c d : α) (hab : r a b) (hcb : r c b) (hcd : r c d) : r a d :=
      begin
        apply trans_r _ hcd,
        apply trans_r hab,
        apply symm_r,
        assumption
      end
  end
end ch4_1

namespace ch4_2
  section
    universe u
    variables (α : Type u) (a b c d : α)
    variables (hab : a = b) (hcb : c = b) (hcd : c = d)

    include hab hcb hcd
    example : a = d := by rw [hab, ←hcb, hcd]
  end

  section
    universe u
    variables (α β : Type u)

    example (f : α → β) (a : α) : (λ x, f x) a = f a := by refl
    example (a : α) (b : α) : (a, b).1 = a := by refl
    example : 2 + 3 = 5 := by refl
  end

  section
    universe u

    example (α : Type u) (a b : α) (p : α → Prop) (h1 : a = b) (h2 : p a) : p b :=
      by { rw ←h1, assumption }
  end

  section
    variable α : Type
    variables a b : α
    variables f g : α → ℕ
    variable h₁ : a = b
    variable h₂ : f = g

    include h₁ h₂
    example : f a = f b := by { simp [h₁] }
    example : f a = g a := by { simp [h₂] }
    example : f a = g b := by { simp [h₁, h₂] }
  end

  section
    variables a b c d : ℤ

    example : a + 0 = a := by simp *
    example : 0 + a = a := by simp *
    example : a * 1 = a := by simp *
    example : 1 * a = a := by simp *
    example : -a + a = 0 := by simp *
    example : a + -a = 0 := by simp *
    example : a - a = 0 := by simp [sub_eq_add_neg]
    example : a + b = b + a := by simp [add_comm]
    example : a + b + c = a + (b + c) := by simp *
    example : a * b = b * a := by rw mul_comm
    example : a * b * c = a * (b * c) := by rw mul_assoc
    example : a * (b + c) = a * b + a * c := by rw mul_add
    example : (a + b) * c = a * c + b * c := by rw add_mul
    example : a * (b - c) = a * b - a * c := by rw mul_sub
    example : (a - b) * c = a * c - b * c := by rw sub_mul
  end

  section
    variables x y z : ℤ

    example (x y z : ℕ) : x * (y + z) = x * y + x * z := by rw mul_add
    example (x y z : ℕ) : (x + y) * z = x * z + y * z := by rw add_mul
    example (x y z : ℕ) : x + y + z = x + (y + z) := by rw add_assoc

    example (x y : ℕ) : (x + y) * (x + y) = x * x + y * x + x * y + y * y :=
      by simp [mul_add, add_mul, add_left_comm]
  end
end ch4_2

namespace ch4_3
  section
    variables (a b c d e : ℕ)
    variable h1 : a = b
    variable h2 : b = c + 1
    variable h3 : c = d
    variable h4 : e = 1 + d

    include h1 h2 h3 h4
    theorem T : a = e := by simp [add_comm, *]
  end

  theorem T2 (a b c d : ℕ) (h1 : a = b) (h2 : b ≤ c) (h3 : c + 1 < d) : a < d :=
  begin
    rw h1,
    apply nat.lt_trans, from nat.lt_succ_self b,
    apply nat.lt_of_le_of_lt, from nat.succ_le_succ h2,
    assumption
  end

  example (x y : ℕ) : (x + y) * (x + y) = x * x + y * x + x * y + y * y :=
    by simp [mul_add, add_mul, add_left_comm]
end ch4_3

namespace ch4_4
  open nat

  example : ∃ x : ℕ, x > 0 := by { existsi 1, apply zero_lt_one }

  example (x : ℕ) (h : x > 0) : ∃ y, y < x := by { existsi 0, assumption }

  example (x y z : ℕ) (hxy : x < y) (hyz : y < z) : ∃ w, x < w ∧ w < z :=
    by { existsi y, apply and.intro; assumption }

  section
    variable g : ℕ → ℕ → ℕ
    variable hg : g 0 0 = 0

    include hg
    theorem gex1 : ∃ x, g x x = x := by { existsi 0, assumption }
    theorem gex2 : ∃ x, g x 0 = x := by { existsi 0, assumption }
    theorem gex3 : ∃ x, g 0 0 = x := by { existsi 0, assumption }
    theorem gex4 : ∃ x, g x x = 0 := by { existsi 0, assumption }
  end

  section
    variables (α : Type) (p q : α → Prop)

    example (h : ∃ x, p x ∧ q x) : ∃ x, q x ∧ p x :=
      by { cases h with w hpqw, existsi w, simp * }
  end

  def is_even (a : ℕ) := ∃ b, a = 2 * b

  theorem even_plus_even {a b : ℕ} (h1 : is_even a) (h2 : is_even b) : is_even (a + b) :=
  begin
    cases h1 with n hn,
    cases h2 with m hm,
    existsi (n + m),
    simp [hn, hm, mul_add],
  end

  namespace ch4_4_classical
    open classical

    section
      variables (α : Type) (p : α → Prop)

      example (h : ¬ ∀ x, ¬ p x) : ∃ x, p x :=
        by_contradiction
          begin
            intro,
            have : ∀ x, ¬ p x,
            show false, contradiction,
            intro w, intro,
            have : ∃ x, p x,
            show false, contradiction,
            existsi w, assumption
          end
    end

    section
      variables (α : Type) (p q : α → Prop)
      variable a : α
      variable r : Prop

      include a
      example : (∃ x : α, r) → r := by { intro h, cases h, assumption }
      example : r → (∃ x : α, r) := by { intro h, existsi a, assumption }
      example : (∃ x, p x ∧ r) ↔ (∃ x, p x) ∧ r :=
      begin
        split; intro h;
        repeat { any_goals { cases h with h }};
        repeat { existsi h <|> split };
        simp *
      end
      example : (∃ x, p x ∨ q x) ↔ (∃ x, p x) ∨ (∃ x, q x) :=
      begin
        split; intro h;
        cases h;
        try { cases h; existsi h_w };
        try { cases h_h };
        { left, try { existsi h_w }, assumption } <|> { right, try { existsi h_w }, assumption }
      end

      example : (∀ x, p x) ↔ ¬ (∃ x, ¬ p x) :=
      begin
        split; intro h,
          { intro hnp, cases hnp with w, have := h w, contradiction },
          { intro w, apply by_contradiction,
            intro, apply h, existsi w, assumption }
      end
      example : (∃ x, p x) ↔ ¬ (∀ x, ¬ p x) :=
      begin
        split; intro h,
          { cases h with w hpw, intro hnp, have := hnp w, contradiction },
          { apply by_contradiction,
            intro hne, apply h, intros w hnpw, apply hne, existsi w, assumption }
      end
      example : (¬ ∃ x, p x) ↔ (∀ x, ¬ p x) :=
      begin
        split; intro h,
          { intros w hpw, apply h, existsi w, assumption },
          { intros hp, cases hp with w hpw, apply h; assumption }
      end
      example : (¬ ∀ x, p x) ↔ (∃ x, ¬ p x) :=
      begin
        split; intro h,
          { apply by_contradiction,
            intro hnen, apply h, intro w,
            apply by_contradiction,
            intro hnpw, apply hnen, existsi w, assumption },
          { cases h with w hnpw, intro hup, apply hnpw, simp * }
      end

      example : (∀ x, p x → r) ↔ (∃ x, p x) → r :=
      begin
        split; intros h w; try { intro hpw };
        try { cases w with w hpw };
        apply h; try { existsi w }; assumption
      end
      example : (∃ x, p x → r) ↔ (∀ x, p x) → r :=
      begin
        split; intro h,
          { cases h with w hpw2r, intro hup, simp * },
          { apply by_cases,
            { intro hup,
              have := h hup,
              existsi a, simp * },
            { intro hnup,
              apply by_contradiction,
              intro hnep2r,
              apply hnup,
              intro w,
              apply by_contradiction,
              intro hnpw,
              apply hnep2r,
              existsi w, contradiction }}
      end
      example : (∃ x, r → p x) ↔ (r → ∃ x, p x) :=
      begin
        split; intro h,
          { cases h with w hr2pw, intro hr, existsi w, simp * },
          { apply by_cases,
            { intro hr,
              have := h hr, cases this with w hpw,
              existsi w, simp * },
            { intro hnr, existsi a, contradiction, }
          }
      end
    end
  end ch4_4_classical
end ch4_4

namespace ch4_5
  variable f : ℕ → ℕ
  variable h : ∀ x : ℕ, f x ≤ f (x + 1)

  include h

  example : f 0 ≤ f 3 :=
    by repeat { apply le_trans, from h _, rw [add_comm], simp * }

  example : f 0 ≥ f 1 → f 0 = f 1 :=
    by { intro, apply le_antisymm, simp *, assumption }

  example : f 0 ≥ f 1 → f 1 ≥ f 2 → f 0 = f 2 :=
    begin
      intros, apply le_antisymm; apply le_trans,
        { from h _ },
        { simp * },
      all_goals { assumption }
    end
end ch4_5

namespace ch4_6
  section
    variables (α : Type) (p q : α → Prop)

    example : (∀ x, p x ∧ q x) ↔ (∀ x, p x) ∧ (∀ x, q x) :=
    begin
      split; intros; split; try { intro };
      { apply and.left, simp * } <|> { apply and.right, simp * },
    end
    example : (∀ x, p x → q x) → (∀ x, p x) → (∀ x, q x) :=
      by { intros, simp * }
    example : (∀ x, p x) ∨ (∀ x, q x) → ∀ x, p x ∨ q x :=
      by { intros, cases a; simp * }
  end

  namespace ch4_6_classical
    open classical

    variables (α : Type) (p q : α → Prop)
    variable r : Prop

    example : α → ((∀ x : α, r) ↔ r) :=
      by { intro, split; intros; try { apply ‹α → r› }; assumption }
    example : (∀ x, p x ∨ r) ↔ (∀ x, p x) ∨ r :=
    begin
      split; intros,
      { apply by_cases; intros,
          { right, assumption },
          { left,
            intro,
            have : p x ∨ r;
            try { cases ‹p x ∨ r› };
            try { contradiction };
            all_goals { simp * } } },
      { cases ‹(∀ (x : α), p x) ∨ r›; simp * }
    end
    example : (∀ x, r → p x) ↔ (r → ∀ x, p x) :=
      by { split; intros; simp * }
  end ch4_6_classical

  section
    variables (men : Type) (barber : men)
    variable (shaves : men → men → Prop)

    example (h : ∀ x : men, shaves barber x ↔ ¬ shaves x x) : false :=
    begin
      have : shaves barber barber ↔ ¬ shaves barber barber, from h _,
      have : ¬ shaves barber barber,
      intro,
      any_goals { apply ‹¬_› },
      all_goals { apply ‹_ ↔ ¬_›.mp <|> rw ‹_ ↔ ¬_› },
      all_goals { assumption }
    end
  end

  section
    variables (real : Type) [ordered_ring real]
    variables (log exp : real → real)
    variable log_exp_eq : ∀ x, log (exp x) = x
    variable exp_log_eq : ∀ {x}, x > 0 → exp (log x) = x
    variable exp_pos : ∀ x, exp x > 0
    variable exp_add : ∀ x y, exp (x + y) = exp x * exp y

    include log_exp_eq exp_log_eq exp_pos exp_add

    example (x y z : real) : exp (x + y + z) = exp x * exp y * exp z :=
      by rw [exp_add, exp_add]

    example (y : real) (h : y > 0)  : exp (log y) = y :=
      exp_log_eq h

    theorem log_mul {x y : real} (hx : x > 0) (hy : y > 0) : log (x * y) = log x + log y :=
      by rw [←exp_log_eq hx, ←exp_log_eq hy, ←exp_add, log_exp_eq, log_exp_eq, log_exp_eq]
  end

  example (x : ℤ) : x * 0 = 0 :=
    by rw [←sub_self (1 : ℤ), mul_sub, mul_one, sub_self, sub_self]
end ch4_6