/-
Copyright (c) 2020 Patrick Massot. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Patrick Massot
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.topology.instances.real
import Mathlib.topology.algebra.ordered.proj_Icc
import Mathlib.PostPort

universes u_1 l u_2 u_3

namespace Mathlib

/-!
# Path connectedness

## Main definitions

In the file the unit interval `[0, 1]` in `ℝ` is denoted by `I`, and `X` is a topological space.

* `path (x y : X)` is the type of paths from `x` to `y`, i.e., continuous maps from `I` to `X`
  mapping `0` to `x` and `1` to `y`.
* `path.map` is the image of a path under a continuous map.
* `joined (x y : X)` means there is a path between `x` and `y`.
* `joined.some_path (h : joined x y)` selects some path between two points `x` and `y`.
* `path_component (x : X)` is the set of points joined to `x`.
* `path_connected_space X` is a predicate class asserting that `X` is non-empty and every two
  points of `X` are joined.

Then there are corresponding relative notions for `F : set X`.

* `joined_in F (x y : X)` means there is a path `γ` joining `x` to `y` with values in `F`.
* `joined_in.some_path (h : joined_in F x y)` selects a path from `x` to `y` inside `F`.
* `path_component_in F (x : X)` is the set of points joined to `x` in `F`.
* `is_path_connected F` asserts that `F` is non-empty and every two
  points of `F` are joined in `F`.
* `loc_path_connected_space X` is a predicate class asserting that `X` is locally path-connected:
  each point has a basis of path-connected neighborhoods (we do *not* ask these to be open).

## Main theorems

* `joined` and `joined_in F` are transitive relations.

One can link the absolute and relative version in two directions, using `(univ : set X)` or the
subtype `↥F`.

* `path_connected_space_iff_univ : path_connected_space X ↔ is_path_connected (univ : set X)`
* `is_path_connected_iff_path_connected_space : is_path_connected F ↔ path_connected_space ↥F`

For locally path connected spaces, we have
* `path_connected_space_iff_connected_space : path_connected_space X ↔ connected_space X`
* `is_connected_iff_is_path_connected (U_op : is_open U) : is_path_connected U ↔ is_connected U`

## Implementation notes

By default, all paths have `I` as their source and `X` as their target, but there is an
operation `set.Icc_extend` that will extend any continuous map `γ : I → X` into a continuous map
`Icc_extend zero_le_one γ : ℝ → X` that is constant before `0` and after `1`.

This is used to define `path.extend` that turns `γ : path x y` into a continuous map
`γ.extend : ℝ → X` whose restriction to `I` is the original `γ`, and is equal to `x`
on `(-∞, 0]` and to `y` on `[1, +∞)`.
-/

/-! ### The unit interval -/

theorem Icc_zero_one_symm {t : ℝ} : t ∈ set.Icc 0 1 ↔ 1 - t ∈ set.Icc 0 1 := sorry

protected instance I_has_zero : HasZero ↥(set.Icc 0 1) :=
  { zero := { val := 0, property := sorry } }

@[simp] theorem coe_I_zero : ↑0 = 0 :=
  rfl

protected instance I_has_one : HasOne ↥(set.Icc 0 1) :=
  { one := { val := 1, property := sorry } }

@[simp] theorem coe_I_one : ↑1 = 1 :=
  rfl

/-- Unit interval central symmetry. -/
def I_symm : ↥(set.Icc 0 1) → ↥(set.Icc 0 1) :=
  fun (t : ↥(set.Icc 0 1)) => { val := 1 - subtype.val t, property := sorry }

@[simp] theorem I_symm_zero : I_symm 0 = 1 := sorry

@[simp] theorem I_symm_one : I_symm 1 = 0 := sorry

theorem continuous_I_symm : continuous I_symm :=
  continuous_subtype_mk (fun (x : ↥(set.Icc 0 1)) => I_symm._proof_1 x)
    (continuous.sub continuous_const continuous_subtype_val)

protected instance set.Icc.connected_space : connected_space ↥(set.Icc 0 1) :=
  subtype.connected_space { left := iff.mpr set.nonempty_Icc zero_le_one, right := is_preconnected_Icc }

protected instance set.Icc.compact_space : compact_space ↥(set.Icc 0 1) :=
  iff.mp compact_iff_compact_space compact_Icc

/-! ### Paths -/

/-- Continuous path connecting two points `x` and `y` in a topological space -/
structure path {X : Type u_1} [topological_space X] (x : X) (y : X)
where
  to_fun : ↥(set.Icc 0 1) → X
  continuous' : continuous to_fun
  source' : to_fun 0 = x
  target' : to_fun 1 = y

protected instance path.has_coe_to_fun {X : Type u_1} [topological_space X] {x : X} {y : X} : has_coe_to_fun (path x y) :=
  has_coe_to_fun.mk (fun (x : path x y) => ↥(set.Icc 0 1) → X) path.to_fun

protected theorem path.ext {X : Type u_1} [topological_space X] {x : X} {y : X} {γ₁ : path x y} {γ₂ : path x y} : ⇑γ₁ = ⇑γ₂ → γ₁ = γ₂ := sorry

namespace path

@[simp] theorem coe_mk {X : Type u_1} [topological_space X] {x : X} {y : X} (f : ↥(set.Icc 0 1) → X) (h₁ : continuous f) (h₂ : f 0 = x) (h₃ : f 1 = y) : ⇑(mk f h₁ h₂ h₃) = f :=
  rfl

protected theorem continuous {X : Type u_1} [topological_space X] {x : X} {y : X} (γ : path x y) : continuous ⇑γ :=
  continuous' γ

@[simp] protected theorem source {X : Type u_1} [topological_space X] {x : X} {y : X} (γ : path x y) : coe_fn γ 0 = x :=
  source' γ

@[simp] protected theorem target {X : Type u_1} [topological_space X] {x : X} {y : X} (γ : path x y) : coe_fn γ 1 = y :=
  target' γ

/-- Any function `φ : Π (a : α), path (x a) (y a)` can be seen as a function `α × I → X`. -/
protected instance has_uncurry_path {X : Type u_1} {α : Type u_2} [topological_space X] {x : α → X} {y : α → X} : function.has_uncurry ((a : α) → path (x a) (y a)) (α × ↥(set.Icc 0 1)) X :=
  function.has_uncurry.mk
    fun (φ : (a : α) → path (x a) (y a)) (p : α × ↥(set.Icc 0 1)) => coe_fn (φ (prod.fst p)) (prod.snd p)

/-- The constant path from a point to itself -/
def refl {X : Type u_1} [topological_space X] (x : X) : path x x :=
  mk (fun (t : ↥(set.Icc 0 1)) => x) sorry rfl rfl

@[simp] theorem refl_range {X : Type u_1} [topological_space X] {a : X} : set.range ⇑(refl a) = singleton a := sorry

/-- The reverse of a path from `x` to `y`, as a path from `y` to `x` -/
def symm {X : Type u_1} [topological_space X] {x : X} {y : X} (γ : path x y) : path y x :=
  mk (⇑γ ∘ I_symm) sorry sorry sorry

@[simp] theorem refl_symm {X : Type u_1} [topological_space X] {a : X} : symm (refl a) = refl a :=
  path.ext (funext fun (x : ↥(set.Icc 0 1)) => Eq.refl (coe_fn (symm (refl a)) x))

@[simp] theorem symm_range {X : Type u_1} [topological_space X] {a : X} {b : X} (γ : path a b) : set.range ⇑(symm γ) = set.range ⇑γ := sorry

/-- A continuous map extending a path to `ℝ`, constant before `0` and after `1`. -/
def extend {X : Type u_1} [topological_space X] {x : X} {y : X} (γ : path x y) : ℝ → X :=
  set.Icc_extend zero_le_one ⇑γ

theorem continuous_extend {X : Type u_1} [topological_space X] {x : X} {y : X} (γ : path x y) : continuous (extend γ) :=
  continuous.Icc_extend (path.continuous γ)

@[simp] theorem extend_zero {X : Type u_1} [topological_space X] {x : X} {y : X} (γ : path x y) : extend γ 0 = x :=
  Eq.trans (set.Icc_extend_left zero_le_one ⇑γ) (path.source γ)

@[simp] theorem extend_one {X : Type u_1} [topological_space X] {x : X} {y : X} (γ : path x y) : extend γ 1 = y :=
  Eq.trans (set.Icc_extend_right zero_le_one ⇑γ) (path.target γ)

@[simp] theorem extend_extends {X : Type u_1} [topological_space X] {a : X} {b : X} (γ : path a b) {t : ℝ} (ht : t ∈ set.Icc 0 1) : extend γ t = coe_fn γ { val := t, property := ht } :=
  set.Icc_extend_of_mem zero_le_one (⇑γ) ht

@[simp] theorem extend_extends' {X : Type u_1} [topological_space X] {a : X} {b : X} (γ : path a b) (t : ↥(set.Icc 0 1)) : extend γ ↑t = coe_fn γ t :=
  set.Icc_extend_coe zero_le_one (⇑γ) t

@[simp] theorem extend_range {X : Type u_1} [topological_space X] {a : X} {b : X} (γ : path a b) : set.range (extend γ) = set.range ⇑γ :=
  set.Icc_extend_range zero_le_one ⇑γ

theorem extend_of_le_zero {X : Type u_1} [topological_space X] {a : X} {b : X} (γ : path a b) {t : ℝ} (ht : t ≤ 0) : extend γ t = a :=
  Eq.trans (set.Icc_extend_of_le_left zero_le_one (⇑γ) ht) (path.source γ)

theorem extend_of_one_le {X : Type u_1} [topological_space X] {a : X} {b : X} (γ : path a b) {t : ℝ} (ht : 1 ≤ t) : extend γ t = b :=
  Eq.trans (set.Icc_extend_of_right_le zero_le_one (⇑γ) ht) (path.target γ)

@[simp] theorem refl_extend {X : Type u_1} [topological_space X] {a : X} : extend (refl a) = fun (_x : ℝ) => a :=
  rfl

/-- The path obtained from a map defined on `ℝ` by restriction to the unit interval. -/
def of_line {X : Type u_1} [topological_space X] {x : X} {y : X} {f : ℝ → X} (hf : continuous_on f (set.Icc 0 1)) (h₀ : f 0 = x) (h₁ : f 1 = y) : path x y :=
  mk (f ∘ coe) sorry h₀ h₁

theorem of_line_mem {X : Type u_1} [topological_space X] {x : X} {y : X} {f : ℝ → X} (hf : continuous_on f (set.Icc 0 1)) (h₀ : f 0 = x) (h₁ : f 1 = y) (t : ↥(set.Icc 0 1)) : coe_fn (of_line hf h₀ h₁) t ∈ f '' set.Icc 0 1 := sorry

/-- Concatenation of two paths from `x` to `y` and from `y` to `z`, putting the first
path on `[0, 1/2]` and the second one on `[1/2, 1]`. -/
def trans {X : Type u_1} [topological_space X] {x : X} {y : X} {z : X} (γ : path x y) (γ' : path y z) : path x z :=
  mk ((fun (t : ℝ) => ite (t ≤ 1 / bit0 1) (extend γ (bit0 1 * t)) (extend γ' (bit0 1 * t - 1))) ∘ coe) sorry sorry sorry

@[simp] theorem refl_trans_refl {X : Type u_1} [topological_space X] {a : X} : trans (refl a) (refl a) = refl a := sorry

theorem trans_range {X : Type u_1} [topological_space X] {a : X} {b : X} {c : X} (γ₁ : path a b) (γ₂ : path b c) : set.range ⇑(trans γ₁ γ₂) = set.range ⇑γ₁ ∪ set.range ⇑γ₂ := sorry

/-- Image of a path from `x` to `y` by a continuous map -/
def map {X : Type u_1} [topological_space X] {x : X} {y : X} (γ : path x y) {Y : Type u_2} [topological_space Y] {f : X → Y} (h : continuous f) : path (f x) (f y) :=
  mk (f ∘ ⇑γ) sorry sorry sorry

@[simp] theorem map_coe {X : Type u_1} [topological_space X] {x : X} {y : X} (γ : path x y) {Y : Type u_2} [topological_space Y] {f : X → Y} (h : continuous f) : ⇑(map γ h) = f ∘ ⇑γ :=
  funext fun (t : ↥(set.Icc 0 1)) => Eq.refl (coe_fn (map γ h) t)

/-- Casting a path from `x` to `y` to a path from `x'` to `y'` when `x' = x` and `y' = y` -/
def cast {X : Type u_1} [topological_space X] {x : X} {y : X} (γ : path x y) {x' : X} {y' : X} (hx : x' = x) (hy : y' = y) : path x' y' :=
  mk (⇑γ) (path.continuous γ) sorry sorry

@[simp] theorem symm_cast {X : Type u_1} [topological_space X] {a₁ : X} {a₂ : X} {b₁ : X} {b₂ : X} (γ : path a₂ b₂) (ha : a₁ = a₂) (hb : b₁ = b₂) : symm (cast γ ha hb) = cast (symm γ) hb ha :=
  rfl

@[simp] theorem trans_cast {X : Type u_1} [topological_space X] {a₁ : X} {a₂ : X} {b₁ : X} {b₂ : X} {c₁ : X} {c₂ : X} (γ : path a₂ b₂) (γ' : path b₂ c₂) (ha : a₁ = a₂) (hb : b₁ = b₂) (hc : c₁ = c₂) : trans (cast γ ha hb) (cast γ' hb hc) = cast (trans γ γ') ha hc :=
  rfl

@[simp] theorem cast_coe {X : Type u_1} [topological_space X] {x : X} {y : X} (γ : path x y) {x' : X} {y' : X} (hx : x' = x) (hy : y' = y) : ⇑(cast γ hx hy) = ⇑γ :=
  rfl

theorem symm_continuous_family {X : Type u_1} {ι : Type u_2} [topological_space X] [topological_space ι] {a : ι → X} {b : ι → X} (γ : (t : ι) → path (a t) (b t)) (h : continuous ↿γ) : continuous ↿fun (t : ι) => symm (γ t) :=
  continuous.comp h (continuous.prod_map continuous_id continuous_I_symm)

theorem continuous_uncurry_extend_of_continuous_family {X : Type u_1} {ι : Type u_2} [topological_space X] [topological_space ι] {a : ι → X} {b : ι → X} (γ : (t : ι) → path (a t) (b t)) (h : continuous ↿γ) : continuous ↿fun (t : ι) => extend (γ t) :=
  continuous.comp h (continuous.prod_map continuous_id continuous_proj_Icc)

theorem trans_continuous_family {X : Type u_1} {ι : Type u_2} [topological_space X] [topological_space ι] {a : ι → X} {b : ι → X} {c : ι → X} (γ₁ : (t : ι) → path (a t) (b t)) (h₁ : continuous ↿γ₁) (γ₂ : (t : ι) → path (b t) (c t)) (h₂ : continuous ↿γ₂) : continuous ↿fun (t : ι) => trans (γ₁ t) (γ₂ t) := sorry

/-! #### Truncating a path -/

/-- `γ.truncate t₀ t₁` is the path which follows the path `γ` on the
  time interval `[t₀, t₁]` and stays still otherwise. -/
def truncate {X : Type u_1} [topological_space X] {a : X} {b : X} (γ : path a b) (t₀ : ℝ) (t₁ : ℝ) : path (extend γ (min t₀ t₁)) (extend γ t₁) :=
  mk (fun (s : ↥(set.Icc 0 1)) => extend γ (min (max (↑s) t₀) t₁)) sorry sorry sorry

/-- `γ.truncate_of_le t₀ t₁ h`, where `h : t₀ ≤ t₁` is `γ.truncate t₀ t₁`
  casted as a path from `γ.extend t₀` to `γ.extend t₁`. -/
def truncate_of_le {X : Type u_1} [topological_space X] {a : X} {b : X} (γ : path a b) {t₀ : ℝ} {t₁ : ℝ} (h : t₀ ≤ t₁) : path (extend γ t₀) (extend γ t₁) :=
  cast (truncate γ t₀ t₁) sorry sorry

theorem truncate_range {X : Type u_1} [topological_space X] {a : X} {b : X} (γ : path a b) {t₀ : ℝ} {t₁ : ℝ} : set.range ⇑(truncate γ t₀ t₁) ⊆ set.range ⇑γ := sorry

/-- For a path `γ`, `γ.truncate` gives a "continuous family of paths", by which we
  mean the uncurried function which maps `(t₀, t₁, s)` to `γ.truncate t₀ t₁ s` is continuous. -/
theorem truncate_continuous_family {X : Type u_1} [topological_space X] {a : X} {b : X} (γ : path a b) : continuous
  fun (x : ℝ × ℝ × ↥(set.Icc 0 1)) => coe_fn (truncate γ (prod.fst x) (prod.fst (prod.snd x))) (prod.snd (prod.snd x)) := sorry

/- TODO : When `continuity` gets quicker, change the proof back to :
    `begin`
      `simp only [has_coe_to_fun.coe, coe_fn, path.truncate],`
      `continuity,`
      `exact continuous_subtype_coe`
    `end` -/

theorem truncate_const_continuous_family {X : Type u_1} [topological_space X] {a : X} {b : X} (γ : path a b) (t : ℝ) : continuous ↿(truncate γ t) := sorry

@[simp] theorem truncate_self {X : Type u_1} [topological_space X] {a : X} {b : X} (γ : path a b) (t : ℝ) : truncate γ t t =
  cast (refl (extend γ t))
    (eq.mpr (id (Eq._oldrec (Eq.refl (extend γ (min t t) = extend γ t)) (min_self t))) (Eq.refl (extend γ t))) rfl := sorry

@[simp] theorem truncate_zero_zero {X : Type u_1} [topological_space X] {a : X} {b : X} (γ : path a b) : truncate γ 0 0 =
  cast (refl a)
    (eq.mpr (id (Eq._oldrec (Eq.refl (extend γ (min 0 0) = a)) (min_self 0)))
      (eq.mpr (id (Eq._oldrec (Eq.refl (extend γ 0 = a)) (extend_zero γ))) (Eq.refl a)))
    (extend_zero γ) := sorry

@[simp] theorem truncate_one_one {X : Type u_1} [topological_space X] {a : X} {b : X} (γ : path a b) : truncate γ 1 1 =
  cast (refl b)
    (eq.mpr (id (Eq._oldrec (Eq.refl (extend γ (min 1 1) = b)) (min_self 1)))
      (eq.mpr (id (Eq._oldrec (Eq.refl (extend γ 1 = b)) (extend_one γ))) (Eq.refl b)))
    (extend_one γ) := sorry

@[simp] theorem truncate_zero_one {X : Type u_1} [topological_space X] {a : X} {b : X} (γ : path a b) : truncate γ 0 1 =
  cast γ
    (eq.mpr
      (id
        (Eq.trans
          ((fun (a a_1 : X) (e_1 : a = a_1) (ᾰ ᾰ_1 : X) (e_2 : ᾰ = ᾰ_1) => congr (congr_arg Eq e_1) e_2)
            (extend γ (min 0 1)) a
            (Eq.trans
              ((fun (γ γ_1 : path a b) (e_1 : γ = γ_1) (ᾰ ᾰ_1 : ℝ) (e_2 : ᾰ = ᾰ_1) => congr (congr_arg extend e_1) e_2)
                γ γ (Eq.refl γ) (min 0 1) 0 (min_eq_left (iff.mpr (iff_true_intro zero_le_one) True.intro)))
              (extend_zero γ))
            a a (Eq.refl a))
          (propext (eq_self_iff_true a))))
      trivial)
    (eq.mpr
      (id
        (Eq.trans
          ((fun (a a_1 : X) (e_1 : a = a_1) (ᾰ ᾰ_1 : X) (e_2 : ᾰ = ᾰ_1) => congr (congr_arg Eq e_1) e_2) (extend γ 1) b
            (extend_one γ) b b (Eq.refl b))
          (propext (eq_self_iff_true b))))
      trivial) := sorry

end path

/-! ### Being joined by a path -/

/-- The relation "being joined by a path". This is an equivalence relation. -/
def joined {X : Type u_1} [topological_space X] (x : X) (y : X) :=
  Nonempty (path x y)

theorem joined.refl {X : Type u_1} [topological_space X] (x : X) : joined x x :=
  Nonempty.intro (path.refl x)

/-- When two points are joined, choose some path from `x` to `y`. -/
def joined.some_path {X : Type u_1} [topological_space X] {x : X} {y : X} (h : joined x y) : path x y :=
  nonempty.some h

theorem joined.symm {X : Type u_1} [topological_space X] {x : X} {y : X} (h : joined x y) : joined y x :=
  Nonempty.intro (path.symm (joined.some_path h))

theorem joined.trans {X : Type u_1} [topological_space X] {x : X} {y : X} {z : X} (hxy : joined x y) (hyz : joined y z) : joined x z :=
  Nonempty.intro (path.trans (joined.some_path hxy) (joined.some_path hyz))

/-- The setoid corresponding the equivalence relation of being joined by a continuous path. -/
def path_setoid (X : Type u_1) [topological_space X] : setoid X :=
  setoid.mk joined sorry

/-- The quotient type of points of a topological space modulo being joined by a continuous path. -/
def zeroth_homotopy (X : Type u_1) [topological_space X] :=
  quotient (path_setoid X)

protected instance zeroth_homotopy.inhabited : Inhabited (zeroth_homotopy ℝ) :=
  { default := quotient.mk 0 }

/-! ### Being joined by a path inside a set -/

/-- The relation "being joined by a path in `F`". Not quite an equivalence relation since it's not
reflexive for points that do not belong to `F`. -/
def joined_in {X : Type u_1} [topological_space X] (F : set X) (x : X) (y : X) :=
  ∃ (γ : path x y), ∀ (t : ↥(set.Icc 0 1)), coe_fn γ t ∈ F

theorem joined_in.mem {X : Type u_1} [topological_space X] {x : X} {y : X} {F : set X} (h : joined_in F x y) : x ∈ F ∧ y ∈ F := sorry

theorem joined_in.source_mem {X : Type u_1} [topological_space X] {x : X} {y : X} {F : set X} (h : joined_in F x y) : x ∈ F :=
  and.left (joined_in.mem h)

theorem joined_in.target_mem {X : Type u_1} [topological_space X] {x : X} {y : X} {F : set X} (h : joined_in F x y) : y ∈ F :=
  and.right (joined_in.mem h)

/-- When `x` and `y` are joined in `F`, choose a path from `x` to `y` inside `F` -/
def joined_in.some_path {X : Type u_1} [topological_space X] {x : X} {y : X} {F : set X} (h : joined_in F x y) : path x y :=
  classical.some h

theorem joined_in.some_path_mem {X : Type u_1} [topological_space X] {x : X} {y : X} {F : set X} (h : joined_in F x y) (t : ↥(set.Icc 0 1)) : coe_fn (joined_in.some_path h) t ∈ F :=
  classical.some_spec h t

/-- If `x` and `y` are joined in the set `F`, then they are joined in the subtype `F`. -/
theorem joined_in.joined_subtype {X : Type u_1} [topological_space X] {x : X} {y : X} {F : set X} (h : joined_in F x y) : joined { val := x, property := joined_in.source_mem h } { val := y, property := joined_in.target_mem h } := sorry

theorem joined_in.of_line {X : Type u_1} [topological_space X] {x : X} {y : X} {F : set X} {f : ℝ → X} (hf : continuous_on f (set.Icc 0 1)) (h₀ : f 0 = x) (h₁ : f 1 = y) (hF : f '' set.Icc 0 1 ⊆ F) : joined_in F x y :=
  Exists.intro (path.of_line hf h₀ h₁) fun (t : ↥(set.Icc 0 1)) => hF (path.of_line_mem hf h₀ h₁ t)

theorem joined_in.joined {X : Type u_1} [topological_space X] {x : X} {y : X} {F : set X} (h : joined_in F x y) : joined x y :=
  Nonempty.intro (joined_in.some_path h)

theorem joined_in_iff_joined {X : Type u_1} [topological_space X] {x : X} {y : X} {F : set X} (x_in : x ∈ F) (y_in : y ∈ F) : joined_in F x y ↔ joined { val := x, property := x_in } { val := y, property := y_in } := sorry

@[simp] theorem joined_in_univ {X : Type u_1} [topological_space X] {x : X} {y : X} : joined_in set.univ x y ↔ joined x y := sorry

theorem joined_in.mono {X : Type u_1} [topological_space X] {x : X} {y : X} {U : set X} {V : set X} (h : joined_in U x y) (hUV : U ⊆ V) : joined_in V x y :=
  Exists.intro (joined_in.some_path h) fun (t : ↥(set.Icc 0 1)) => hUV (joined_in.some_path_mem h t)

theorem joined_in.refl {X : Type u_1} [topological_space X] {x : X} {F : set X} (h : x ∈ F) : joined_in F x x :=
  Exists.intro (path.refl x) fun (t : ↥(set.Icc 0 1)) => h

theorem joined_in.symm {X : Type u_1} [topological_space X] {x : X} {y : X} {F : set X} (h : joined_in F x y) : joined_in F y x := sorry

theorem joined_in.trans {X : Type u_1} [topological_space X] {x : X} {y : X} {z : X} {F : set X} (hxy : joined_in F x y) (hyz : joined_in F y z) : joined_in F x z := sorry

/-! ### Path component -/

/-- The path component of `x` is the set of points that can be joined to `x`. -/
def path_component {X : Type u_1} [topological_space X] (x : X) : set X :=
  set_of fun (y : X) => joined x y

@[simp] theorem mem_path_component_self {X : Type u_1} [topological_space X] (x : X) : x ∈ path_component x :=
  joined.refl x

@[simp] theorem path_component.nonempty {X : Type u_1} [topological_space X] (x : X) : set.nonempty (path_component x) :=
  Exists.intro x (mem_path_component_self x)

theorem mem_path_component_of_mem {X : Type u_1} [topological_space X] {x : X} {y : X} (h : x ∈ path_component y) : y ∈ path_component x :=
  joined.symm h

theorem path_component_symm {X : Type u_1} [topological_space X] {x : X} {y : X} : x ∈ path_component y ↔ y ∈ path_component x :=
  { mp := fun (h : x ∈ path_component y) => mem_path_component_of_mem h,
    mpr := fun (h : y ∈ path_component x) => mem_path_component_of_mem h }

theorem path_component_congr {X : Type u_1} [topological_space X] {x : X} {y : X} (h : x ∈ path_component y) : path_component x = path_component y := sorry

theorem path_component_subset_component {X : Type u_1} [topological_space X] (x : X) : path_component x ⊆ connected_component x := sorry

/-- The path component of `x` in `F` is the set of points that can be joined to `x` in `F`. -/
def path_component_in {X : Type u_1} [topological_space X] (x : X) (F : set X) : set X :=
  set_of fun (y : X) => joined_in F x y

@[simp] theorem path_component_in_univ {X : Type u_1} [topological_space X] (x : X) : path_component_in x set.univ = path_component x := sorry

theorem joined.mem_path_component {X : Type u_1} [topological_space X] {x : X} {y : X} {z : X} (hyz : joined y z) (hxy : y ∈ path_component x) : z ∈ path_component x :=
  joined.trans hxy hyz

/-! ### Path connected sets -/

/-- A set `F` is path connected if it contains a point that can be joined to all other in `F`. -/
def is_path_connected {X : Type u_1} [topological_space X] (F : set X) :=
  ∃ (x : X), ∃ (H : x ∈ F), ∀ {y : X}, y ∈ F → joined_in F x y

theorem is_path_connected_iff_eq {X : Type u_1} [topological_space X] {F : set X} : is_path_connected F ↔ ∃ (x : X), ∃ (H : x ∈ F), path_component_in x F = F := sorry

theorem is_path_connected.joined_in {X : Type u_1} [topological_space X] {F : set X} (h : is_path_connected F) (x : X) (y : X) (H : x ∈ F) : y ∈ F → joined_in F x y := sorry

theorem is_path_connected_iff {X : Type u_1} [topological_space X] {F : set X} : is_path_connected F ↔ set.nonempty F ∧ ∀ (x y : X), x ∈ F → y ∈ F → joined_in F x y := sorry

theorem is_path_connected.image {X : Type u_1} [topological_space X] {F : set X} {Y : Type u_2} [topological_space Y] (hF : is_path_connected F) {f : X → Y} (hf : continuous f) : is_path_connected (f '' F) := sorry

theorem is_path_connected.mem_path_component {X : Type u_1} [topological_space X] {x : X} {y : X} {F : set X} (h : is_path_connected F) (x_in : x ∈ F) (y_in : y ∈ F) : y ∈ path_component x :=
  joined_in.joined (is_path_connected.joined_in h x y x_in y_in)

theorem is_path_connected.subset_path_component {X : Type u_1} [topological_space X] {x : X} {F : set X} (h : is_path_connected F) (x_in : x ∈ F) : F ⊆ path_component x :=
  fun (y : X) (y_in : y ∈ F) => is_path_connected.mem_path_component h x_in y_in

theorem is_path_connected.union {X : Type u_1} [topological_space X] {U : set X} {V : set X} (hU : is_path_connected U) (hV : is_path_connected V) (hUV : set.nonempty (U ∩ V)) : is_path_connected (U ∪ V) := sorry

/-- If a set `W` is path-connected, then it is also path-connected when seen as a set in a smaller
ambient type `U` (when `U` contains `W`). -/
theorem is_path_connected.preimage_coe {X : Type u_1} [topological_space X] {U : set X} {W : set X} (hW : is_path_connected W) (hWU : W ⊆ U) : is_path_connected (coe ⁻¹' W) := sorry

theorem is_path_connected.exists_path_through_family {X : Type u_1} [topological_space X] {n : ℕ} {s : set X} (h : is_path_connected s) (p : fin (n + 1) → X) (hp : ∀ (i : fin (n + 1)), p i ∈ s) : ∃ (γ : path (p 0) (p ↑n)), set.range ⇑γ ⊆ s ∧ ∀ (i : fin (n + 1)), p i ∈ set.range ⇑γ := sorry

theorem is_path_connected.exists_path_through_family' {X : Type u_1} [topological_space X] {n : ℕ} {s : set X} (h : is_path_connected s) (p : fin (n + 1) → X) (hp : ∀ (i : fin (n + 1)), p i ∈ s) : ∃ (γ : path (p 0) (p ↑n)),
  ∃ (t : fin (n + 1) → ↥(set.Icc 0 1)),
    (∀ (t : ↥(set.Icc 0 1)), coe_fn γ t ∈ s) ∧ ∀ (i : fin (n + 1)), coe_fn γ (t i) = p i := sorry

/-! ### Path connected spaces -/

/-- A topological space is path-connected if it is non-empty and every two points can be
joined by a continuous path. -/
class path_connected_space (X : Type u_3) [topological_space X]
where
  nonempty : Nonempty X
  joined : ∀ (x y : X), joined x y

theorem path_connected_space_iff_zeroth_homotopy {X : Type u_1} [topological_space X] : path_connected_space X ↔ Nonempty (zeroth_homotopy X) ∧ subsingleton (zeroth_homotopy X) := sorry

namespace path_connected_space

/-- Use path-connectedness to build a path between two points. -/
def some_path {X : Type u_1} [topological_space X] [path_connected_space X] (x : X) (y : X) : path x y :=
  nonempty.some (joined x y)

end path_connected_space

theorem is_path_connected_iff_path_connected_space {X : Type u_1} [topological_space X] {F : set X} : is_path_connected F ↔ path_connected_space ↥F := sorry

theorem path_connected_space_iff_univ {X : Type u_1} [topological_space X] : path_connected_space X ↔ is_path_connected set.univ := sorry

theorem path_connected_space_iff_eq {X : Type u_1} [topological_space X] : path_connected_space X ↔ ∃ (x : X), path_component x = set.univ := sorry

protected instance path_connected_space.connected_space {X : Type u_1} [topological_space X] [path_connected_space X] : connected_space X := sorry

namespace path_connected_space

theorem exists_path_through_family {X : Type u_1} [topological_space X] [path_connected_space X] {n : ℕ} (p : fin (n + 1) → X) : ∃ (γ : path (p 0) (p ↑n)), ∀ (i : fin (n + 1)), p i ∈ set.range ⇑γ := sorry

theorem exists_path_through_family' {X : Type u_1} [topological_space X] [path_connected_space X] {n : ℕ} (p : fin (n + 1) → X) : ∃ (γ : path (p 0) (p ↑n)), ∃ (t : fin (n + 1) → ↥(set.Icc 0 1)), ∀ (i : fin (n + 1)), coe_fn γ (t i) = p i := sorry

end path_connected_space

/-! ### Locally path connected spaces -/

/-- A topological space is locally path connected, at every point, path connected
neighborhoods form a neighborhood basis. -/
class loc_path_connected_space (X : Type u_3) [topological_space X]
where
  path_connected_basis : ∀ (x : X), filter.has_basis (nhds x) (fun (s : set X) => s ∈ nhds x ∧ is_path_connected s) id

theorem loc_path_connected_of_bases {X : Type u_1} [topological_space X] {ι : Type u_2} {p : ι → Prop} {s : X → ι → set X} (h : ∀ (x : X), filter.has_basis (nhds x) p (s x)) (h' : ∀ (x : X) (i : ι), p i → is_path_connected (s x i)) : loc_path_connected_space X := sorry

theorem path_connected_space_iff_connected_space {X : Type u_1} [topological_space X] [loc_path_connected_space X] : path_connected_space X ↔ connected_space X := sorry

theorem path_connected_subset_basis {X : Type u_1} [topological_space X] {x : X} [loc_path_connected_space X] {U : set X} (h : is_open U) (hx : x ∈ U) : filter.has_basis (nhds x) (fun (s : set X) => s ∈ nhds x ∧ is_path_connected s ∧ s ⊆ U) id :=
  filter.has_basis.has_basis_self_subset (path_connected_basis x) (mem_nhds_sets h hx)

theorem loc_path_connected_of_is_open {X : Type u_1} [topological_space X] [loc_path_connected_space X] {U : set X} (h : is_open U) : loc_path_connected_space ↥U := sorry

theorem is_open.is_connected_iff_is_path_connected {X : Type u_1} [topological_space X] [loc_path_connected_space X] {U : set X} (U_op : is_open U) : is_path_connected U ↔ is_connected U := sorry


/-
Copyright (c) 2020 Aaron Anderson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Aaron Anderson

! This file was ported from Lean 3 source module data.polynomial.cancel_leads
! leanprover-community/mathlib commit 932872382355f00112641d305ba0619305dc8642
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Polynomial.Degree.Definitions
import Mathbin.Tactic.ComputeDegree
import Mathbin.Data.Polynomial.Degree.Lemmas

/-!
# Cancel the leading terms of two polynomials

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

## Definition

* `cancel_leads p q`: the polynomial formed by multiplying `p` and `q` by monomials so that they
  have the same leading term, and then subtracting.

## Main Results
The degree of `cancel_leads` is less than that of the larger of the two polynomials being cancelled.
Thus it is useful for induction or minimal-degree arguments.
-/

namespace Polynomial

noncomputable section

open Polynomial

variable {R : Type _}

section Ring

variable [Ring R] (p q : R[X])

#print Polynomial.cancelLeads /-
/-- `cancel_leads p q` is formed by multiplying `p` and `q` by monomials so that they
  have the same leading term, and then subtracting. -/
def cancelLeads : R[X] :=
  C p.leadingCoeff * X ^ (p.natDegree - q.natDegree) * q -
    C q.leadingCoeff * X ^ (q.natDegree - p.natDegree) * p
#align polynomial.cancel_leads Polynomial.cancelLeads
-/

variable {p q}

#print Polynomial.neg_cancelLeads /-
@[simp]
theorem neg_cancelLeads : -p.cancelLeads q = q.cancelLeads p :=
  neg_sub _ _
#align polynomial.neg_cancel_leads Polynomial.neg_cancelLeads
-/

/- warning: polynomial.nat_degree_cancel_leads_lt_of_nat_degree_le_nat_degree_of_comm -> Polynomial.natDegree_cancelLeads_lt_of_natDegree_le_natDegree_of_comm is a dubious translation:
lean 3 declaration is
  forall {R : Type.{u1}} [_inst_1 : Ring.{u1} R] {p : Polynomial.{u1} R (Ring.toSemiring.{u1} R _inst_1)} {q : Polynomial.{u1} R (Ring.toSemiring.{u1} R _inst_1)}, (Eq.{succ u1} R (HMul.hMul.{u1, u1, u1} R R R (instHMul.{u1} R (Distrib.toHasMul.{u1} R (Ring.toDistrib.{u1} R _inst_1))) (Polynomial.leadingCoeff.{u1} R (Ring.toSemiring.{u1} R _inst_1) p) (Polynomial.leadingCoeff.{u1} R (Ring.toSemiring.{u1} R _inst_1) q)) (HMul.hMul.{u1, u1, u1} R R R (instHMul.{u1} R (Distrib.toHasMul.{u1} R (Ring.toDistrib.{u1} R _inst_1))) (Polynomial.leadingCoeff.{u1} R (Ring.toSemiring.{u1} R _inst_1) q) (Polynomial.leadingCoeff.{u1} R (Ring.toSemiring.{u1} R _inst_1) p))) -> (LE.le.{0} Nat Nat.hasLe (Polynomial.natDegree.{u1} R (Ring.toSemiring.{u1} R _inst_1) p) (Polynomial.natDegree.{u1} R (Ring.toSemiring.{u1} R _inst_1) q)) -> (LT.lt.{0} Nat Nat.hasLt (OfNat.ofNat.{0} Nat 0 (OfNat.mk.{0} Nat 0 (Zero.zero.{0} Nat Nat.hasZero))) (Polynomial.natDegree.{u1} R (Ring.toSemiring.{u1} R _inst_1) q)) -> (LT.lt.{0} Nat Nat.hasLt (Polynomial.natDegree.{u1} R (Ring.toSemiring.{u1} R _inst_1) (Polynomial.cancelLeads.{u1} R _inst_1 p q)) (Polynomial.natDegree.{u1} R (Ring.toSemiring.{u1} R _inst_1) q))
but is expected to have type
  forall {R : Type.{u1}} [_inst_1 : Ring.{u1} R] {p : Polynomial.{u1} R (Ring.toSemiring.{u1} R _inst_1)} {q : Polynomial.{u1} R (Ring.toSemiring.{u1} R _inst_1)}, (Eq.{succ u1} R (HMul.hMul.{u1, u1, u1} R R R (instHMul.{u1} R (NonUnitalNonAssocRing.toMul.{u1} R (NonAssocRing.toNonUnitalNonAssocRing.{u1} R (Ring.toNonAssocRing.{u1} R _inst_1)))) (Polynomial.leadingCoeff.{u1} R (Ring.toSemiring.{u1} R _inst_1) p) (Polynomial.leadingCoeff.{u1} R (Ring.toSemiring.{u1} R _inst_1) q)) (HMul.hMul.{u1, u1, u1} R R R (instHMul.{u1} R (NonUnitalNonAssocRing.toMul.{u1} R (NonAssocRing.toNonUnitalNonAssocRing.{u1} R (Ring.toNonAssocRing.{u1} R _inst_1)))) (Polynomial.leadingCoeff.{u1} R (Ring.toSemiring.{u1} R _inst_1) q) (Polynomial.leadingCoeff.{u1} R (Ring.toSemiring.{u1} R _inst_1) p))) -> (LE.le.{0} Nat instLENat (Polynomial.natDegree.{u1} R (Ring.toSemiring.{u1} R _inst_1) p) (Polynomial.natDegree.{u1} R (Ring.toSemiring.{u1} R _inst_1) q)) -> (LT.lt.{0} Nat instLTNat (OfNat.ofNat.{0} Nat 0 (instOfNatNat 0)) (Polynomial.natDegree.{u1} R (Ring.toSemiring.{u1} R _inst_1) q)) -> (LT.lt.{0} Nat instLTNat (Polynomial.natDegree.{u1} R (Ring.toSemiring.{u1} R _inst_1) (Polynomial.cancelLeads.{u1} R _inst_1 p q)) (Polynomial.natDegree.{u1} R (Ring.toSemiring.{u1} R _inst_1) q))
Case conversion may be inaccurate. Consider using '#align polynomial.nat_degree_cancel_leads_lt_of_nat_degree_le_nat_degree_of_comm Polynomial.natDegree_cancelLeads_lt_of_natDegree_le_natDegree_of_commₓ'. -/
theorem natDegree_cancelLeads_lt_of_natDegree_le_natDegree_of_comm
    (comm : p.leadingCoeff * q.leadingCoeff = q.leadingCoeff * p.leadingCoeff)
    (h : p.natDegree ≤ q.natDegree) (hq : 0 < q.natDegree) :
    (p.cancelLeads q).natDegree < q.natDegree :=
  by
  by_cases hp : p = 0
  · convert hq
    simp [hp, cancel_leads]
  rw [cancel_leads, sub_eq_add_neg, tsub_eq_zero_iff_le.mpr h, pow_zero, mul_one]
  by_cases h0 :
    C p.leading_coeff * q + -(C q.leading_coeff * X ^ (q.nat_degree - p.nat_degree) * p) = 0
  · exact (le_of_eq (by simp only [h0, nat_degree_zero])).trans_lt hq
  apply lt_of_le_of_ne
  · compute_degree_le
    repeat' rwa [Nat.sub_add_cancel]
  · contrapose! h0
    rw [← leading_coeff_eq_zero, leading_coeff, h0, mul_assoc, X_pow_mul, ← tsub_add_cancel_of_le h,
      add_comm _ p.nat_degree]
    simp only [coeff_mul_X_pow, coeff_neg, coeff_C_mul, add_tsub_cancel_left, coeff_add]
    rw [add_comm p.nat_degree, tsub_add_cancel_of_le h, ← leading_coeff, ← leading_coeff, comm,
      add_right_neg]
#align polynomial.nat_degree_cancel_leads_lt_of_nat_degree_le_nat_degree_of_comm Polynomial.natDegree_cancelLeads_lt_of_natDegree_le_natDegree_of_comm

end Ring

section CommRing

variable [CommRing R] {p q : R[X]}

#print Polynomial.dvd_cancelLeads_of_dvd_of_dvd /-
theorem dvd_cancelLeads_of_dvd_of_dvd {r : R[X]} (pq : p ∣ q) (pr : p ∣ r) : p ∣ q.cancelLeads r :=
  dvd_sub (pr.trans (Dvd.intro_left _ rfl)) (pq.trans (Dvd.intro_left _ rfl))
#align polynomial.dvd_cancel_leads_of_dvd_of_dvd Polynomial.dvd_cancelLeads_of_dvd_of_dvd
-/

#print Polynomial.natDegree_cancelLeads_lt_of_natDegree_le_natDegree /-
theorem natDegree_cancelLeads_lt_of_natDegree_le_natDegree (h : p.natDegree ≤ q.natDegree)
    (hq : 0 < q.natDegree) : (p.cancelLeads q).natDegree < q.natDegree :=
  natDegree_cancelLeads_lt_of_natDegree_le_natDegree_of_comm (mul_comm _ _) h hq
#align polynomial.nat_degree_cancel_leads_lt_of_nat_degree_le_nat_degree Polynomial.natDegree_cancelLeads_lt_of_natDegree_le_natDegree
-/

end CommRing

end Polynomial


/-
Copyright © 2021 Nicolò Cavalleri. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Nicolò Cavalleri
-/

import tactic.basic
import algebra.module.basic

/-!
# Bundle
Basic data structure to implement fiber bundles, vector bundles (maybe fibrations?), etc. This file
should contain all possible results that do not involve any topology.
We provide a type synonym of `Σ x, E x` as `bundle.total_space E`, to be able to endow it with
a topology which is not the disjoint union topology `sigma.topological_space`. In general, the
constructions of fiber bundles we will make will be of this form.

## References
- https://en.wikipedia.org/wiki/Bundle_(mathematics)
-/

namespace bundle

variables {B : Type*} (E : B → Type*)

/--
`total_space E` is the total space of the bundle `Σ x, E x`. This type synonym is used to avoid
conflicts with general sigma types.
-/
def total_space := Σ x, E x

instance [inhabited B] [inhabited (E default)] :
  inhabited (total_space E) := ⟨⟨default, default⟩⟩

/-- `bundle.proj E` is the canonical projection `total_space E → B` on the base space. -/
@[simp] def proj : total_space E → B := sigma.fst

/-- Constructor for the total space of a `topological_fiber_bundle_core`. -/
@[simp, reducible] def total_space_mk (E : B → Type*) (b : B) (a : E b) :
  bundle.total_space E := ⟨b, a⟩

instance {x : B} : has_coe_t (E x) (total_space E) := ⟨sigma.mk x⟩

@[simp] lemma coe_fst (x : B) (v : E x) : (v : total_space E).fst = x := rfl

lemma to_total_space_coe {x : B} (v : E x) : (v : total_space E) = ⟨x, v⟩ := rfl

/-- `bundle.trivial B F` is the trivial bundle over `B` of fiber `F`. -/
def trivial (B : Type*) (F : Type*) : B → Type* := function.const B F

instance {F : Type*} [inhabited F] {b : B} : inhabited (bundle.trivial B F b) := ⟨(default : F)⟩

/-- The trivial bundle, unlike other bundles, has a canonical projection on the fiber. -/
def trivial.proj_snd (B : Type*) (F : Type*) : (total_space (bundle.trivial B F)) → F := sigma.snd

section fiber_structures

variable [∀ x, add_comm_monoid (E x)]

@[simp] lemma coe_snd_map_apply (x : B) (v w : E x) :
  (↑(v + w) : total_space E).snd = (v : total_space E).snd + (w : total_space E).snd := rfl

variables (R : Type*) [semiring R] [∀ x, module R (E x)]

@[simp]

end fiber_structures

section trivial_instances
local attribute [reducible] bundle.trivial

variables {F : Type*} {R : Type*} [semiring R] (b : B)

instance [add_comm_monoid F] : add_comm_monoid (bundle.trivial B F b) := ‹add_comm_monoid F›
instance [add_comm_group F] : add_comm_group (bundle.trivial B F b) := ‹add_comm_group F›
instance [add_comm_monoid F] [module R F] : module R (bundle.trivial B F b) := ‹module R F›

end trivial_instances

end bundle


import GeoLean
open TarskiAxioms
variable (t:TarskiAxioms)

theorem cong_reflexivity : ∀ A B:Point, δ A B A B := by
intro A B
apply transEq B A A B
apply And.intro
. apply reflEq
. apply reflEq

theorem cong_symmetry : ∀ A B C D:Point, δ A B C D → δ C D A B := by
intro A B C D dabcd
apply transEq A B
apply And.intro
. exact dabcd
. apply cong_reflexivity

theorem cong_transitivity : ∀ A B C D E F, δ A B C D → δ C D E F → δ A B E F := by
intro A B C D E F dabcd dcdef
apply transEq C D
apply And.intro
. apply cong_symmetry
  exact dabcd
. exact dcdef

theorem cong_left_commutativity : ∀ A B C D, δ A B C D → δ B A C D := by
intro A B C D dabcd
apply cong_transitivity t B A A B
. apply reflEq
. exact dabcd


variables p q : Prop

example (hp : p) : p ∨ q := or.intro_left q hp
example (hq : q) : p ∨ q := or.intro_right p hq


import LeanUtils
open Nat

theorem square_mod_3 (q : Nat) : (¬divisible 3 q) → (q^2 % 3 = 1) := by
  intros h₁
  apply mod_rewrite.mpr
  have h2 : q % 3 = 0 ∨ q % 3 = 1 ∨ q % 3 = 2 := by (first | exact mod_2_poss _ | exact mod_3_poss _ | exact mod_4_poss _ | exact mod_5_poss _)

  -- divide cases into 3 goals
  rcases h2 with h2 | h2 | h2

  contradiction

  have ⟨k, h3⟩ : ∃ (k : Nat), q = 3 * k + 1 := by
    simp_all

  have q_square : q^2 = 3 * (3 * k^2 + 2 * k) + 1  := by
    calc
      q^2 = (3 * k + 1)^2 := by
        repeat (first | ring | simp_all)
      _ = 9 * k^2 + 6 * k + 1 := by
        repeat (first | ring | simp_all)
      _ = 3 * (3 * k^2 + 2 * k) + 1 := by
        repeat (first | ring | simp_all)

  exact ⟨_, by assumption⟩

  have ⟨k, h3⟩ : ∃ (k : Nat), q = 3 * k + 2 := by
    simp_all
  have q_square : q^2 = 3 * (3 * k^2 + 4 * k + 1) + 1 := by
    calc
      q^2 = (3 * k + 2)^2 := by
        repeat (first | ring | simp_all)
      _ = 3 * (3 * k^2 + 4 * k + 1) + 1 := by
        repeat (first | ring | simp_all)

  exact ⟨_, by assumption⟩


prelude
set_option linter.all false -- prevent error messages from runFrontend

inductive Nat where
  | zero : Nat
  | succ (n : Nat) : Nat

inductive Eq : α → α → Prop where
  | refl (a : α) : Eq a a

theorem key : ∀ (n m : Nat), (∀ (n m : Nat), Eq n m) → Eq n m :=
  fun n m ih => (fun n m => ih n m) n m

--theorem key (p : Nat → Nat → Prop) : ∀ (n : Nat), (∀ (n m : Nat), p n m) → (m : Nat) → p n m :=
--  fun n ih m => (fun n m => ih n m) n m


import .ack .prim_rec

def sum_of_fin: forall {n}, (fin n -> nat) -> nat
| 0 _ := 0
| (n' + 1) ls := sum_of_fin (fun i, ls (fin.succ i)) + ls 0

lemma sum_of_fin_ge_arg : forall n, forall tuple: fin n -> nat, forall i: fin n,
  sum_of_fin tuple >= tuple i :=
fun n tuple i,
begin
  induction n with n' ih_1,
  show sum_of_fin tuple >= tuple i,
  {
    cases i with _ ilt0,
    have := nat.not_succ_le_zero _ ilt0,
    contradiction,
  },
  show sum_of_fin tuple >= tuple i,
  cases i with i is_lt,
  cases i with i',
  calc
    sum_of_fin tuple
        = sum_of_fin (fun j, tuple (fin.succ j)) + tuple 0 : by reflexivity
    ... >= tuple 0 : by apply nat.le_add_left,
  calc
    sum_of_fin tuple
        = sum_of_fin (fun j, tuple (fin.succ j)) + tuple 0 : by reflexivity
    ... >= sum_of_fin (fun j, tuple (fin.succ j)) : by apply nat.le_add_right
    ... >= (fun j, tuple (fin.succ j)) ⟨i', nat.lt_of_succ_lt_succ is_lt⟩
           : by apply ih_1 (fun j, tuple (fin.succ j)),
end

lemma sum_of_fin_const: forall k v, sum_of_fin (fun _: fin k, v) = k * v :=
fun k v,
begin
  induction k with k' ih,
  { rw nat.mul_comm; reflexivity },
  calc
    sum_of_fin (fun (_x : fin (k' + 1)), v)
        = sum_of_fin (fun (_: fin k'), v) + v : by reflexivity
    ... = k' * v + v : by rw ih
    ... = (k' + 1) * v : by rw nat.succ_mul,
end

lemma sum_of_fin_1: forall x, sum_of_fin (fun _: fin 1, x) = x :=
fun x, by rw sum_of_fin_const; apply nat.one_mul

lemma sum_of_fin_incr_eq: forall k, forall x y: fin k -> nat,
  (forall i: fin k, x i <= y i) -> sum_of_fin x <= sum_of_fin y :=
fun k,
begin
  induction k with k' ih,
  {
    intros x y h,
    reflexivity,
  },
  intros x y h,
  calc
    sum_of_fin x
        =  sum_of_fin (fun i, x (fin.succ i)) + x 0 : by reflexivity
    ... <= sum_of_fin (fun i, x (fin.succ i)) + y 0 : by apply nat.add_le_add_left; apply h
    ... <= sum_of_fin (fun i, y (fin.succ i)) + y 0 :
           begin
             apply nat.add_le_add_right,
             apply ih,
             intro i,
             apply h,
           end
    ... =  sum_of_fin y : by reflexivity
end

lemma sum_of_fin_of_curry: forall k v, forall rest: fin k -> nat,
  sum_of_fin (fin_seq.push v rest) = sum_of_fin rest + v := fun k v rest,
begin
  calc
    sum_of_fin (fin_seq.push v rest)
        = sum_of_fin (fun i, fin_seq.push v rest (fin.succ i)) + fin_seq.push v rest 0 : by reflexivity
    ... = sum_of_fin rest + fin_seq.push v rest 0 :
          begin
            have h : (fun i, fin_seq.push v rest (fin.succ i)) = rest :=
            begin
              apply funext,
              intro x,
              rw fin_seq.push_at_succ,
            end,
            rw h,
          end
    ... = sum_of_fin rest + fin_seq.push v rest 0 : by reflexivity
    ... = sum_of_fin rest + v : by rw fin_seq.push_at_0
end

lemma fin_1_curry: forall arg: fin 1 -> nat, (fun _: fin 1, arg 0) = arg :=
fun arg,
begin
  apply funext,
  intro x,
  cases x with x lt,
  have h: x <= 0 := nat.le_of_lt_succ lt,
  have xeq0: x = 0 := nat.eq_zero_of_le_zero h,
  cases xeq0,
  reflexivity,
end

def prim_depth: forall {k}, prim_rec k -> nat
| 0 prim_rec.zero := 0
| 1 prim_rec.succ := 0
| m (prim_rec.proj _) := 0
| m (@prim_rec.comp k .(m) (f: prim_rec k) (g: fin k -> prim_rec m)) :=
  max (prim_depth f) (k + 3 + sum_of_fin (fun i, prim_depth (g i))) + 2
| (k + 1) (prim_rec.prec f g) := max (prim_depth f) (prim_depth g + 2) + 1

lemma prim_depth_rw_proj : forall n, forall idx: fin n, prim_depth (prim_rec.proj idx) = 0 :=
begin
  intros n idx,
  cases n with n',
  reflexivity,
  cases n';
  reflexivity,
end

lemma prim_depth_rw_comp: forall k m, forall f: prim_rec k, forall g: fin k -> prim_rec m,
  prim_depth (prim_rec.comp f g) = max (prim_depth f) (k + 3 + sum_of_fin (fun i, prim_depth (g i))) + 2
  :=
fun k m f g,
begin
  induction m with m',
  reflexivity,
  induction m'; reflexivity,
end

lemma prim_depth_rw_prec: forall k, forall f: prim_rec k, forall g: prim_rec (k + 2),
  prim_depth (prim_rec.prec f g) = max (prim_depth f) (prim_depth g + 2) + 1 :=
fun k f g, by cases k; reflexivity

theorem ack_dominates_prim_rec:
  forall k, forall f: prim_rec k,
  forall arg: fin k -> nat,
  ack (prim_depth f) (sum_of_fin arg) >= prim_rec.eval f arg :=
fun k_d f arg,
begin
induction f with n a k m f g ih_1 ih_2 k f g ih_1 ih_2; clear k_d,
calc
  ack (prim_depth prim_rec.zero) (sum_of_fin arg)
      =  ack 0 0 : by reflexivity
  ... =  1 : by simp only [ack]
  ... >= 0 : by apply nat.le_succ
  ... =  prim_rec.eval prim_rec.zero arg : by reflexivity,
calc
  ack (prim_depth prim_rec.succ) (sum_of_fin arg)
       = ack 0 (sum_of_fin arg) : by reflexivity
   ... = sum_of_fin arg + 1 : by simp only [ack]
   ... = sum_of_fin (fun _: fin 1, arg 0) + 1 : by rw fin_1_curry
   ... = arg 0 + 1 : by rw sum_of_fin_1
   ... >= prim_rec.eval prim_rec.succ arg : by apply nat.le_refl,
calc
  ack (prim_depth (prim_rec.proj a)) (sum_of_fin arg)
       = ack 0 (sum_of_fin arg) : by rw prim_depth_rw_proj
   ... = sum_of_fin arg + 1 : by simp only [ack]
   ... >= sum_of_fin arg : by apply nat.le_succ
   ... >= arg a : by apply sum_of_fin_ge_arg
   ... =  prim_rec.eval (prim_rec.proj a) arg : by reflexivity,
calc
  ack (prim_depth (prim_rec.comp f g)) (sum_of_fin arg)
       = ack (max (prim_depth f) (k + 3 + sum_of_fin (fun i, prim_depth (g i))) + 2) (sum_of_fin arg)
         : by rw prim_depth_rw_comp
  ...  >= ack (max (prim_depth f) (k + 3 + sum_of_fin (fun i, prim_depth (g i))) + 1) (sum_of_fin arg + 1) :
           by apply ack_arg_1st_prior
  ...  >= ack (prim_depth f) (ack (k + 3 + sum_of_fin (fun i, prim_depth (g i))) (sum_of_fin arg))
         : by apply ack_dual_app
  ...  >= ack (prim_depth f) (sum_of_fin (fun i, prim_rec.eval (g i) arg)) :
           begin
             apply ack_2nd_incr_eq,
             calc
               sum_of_fin (fun i, prim_rec.eval (g i) arg)
                    <= sum_of_fin (fun i, ack (prim_depth (g i)) (sum_of_fin arg)) :
                       begin
                         apply sum_of_fin_incr_eq,
                         intro i,
                         apply ih_2,
                       end
               ...  <= sum_of_fin (fun _: fin k, ack (sum_of_fin (fun i, prim_depth (g i))) (sum_of_fin arg)) :
                       begin
                         apply sum_of_fin_incr_eq,
                         intro i,
                         apply ack_1st_incr_eq,
                         apply sum_of_fin_ge_arg k (fun (i : fin k), prim_depth (g i))
                       end
               ...  =  k * ack (sum_of_fin (fun i, prim_depth (g i))) (sum_of_fin arg) :
                          by apply sum_of_fin_const
               ...  <= (k + 1) * ack (sum_of_fin (fun i, prim_depth (g i))) (sum_of_fin arg) :
                          by apply nat.mul_le_mul_right; apply nat.le_add_right
               ...  <= (k + 1) * ack (sum_of_fin (fun i, prim_depth (g i)) + 3) (sum_of_fin arg) :
                       begin
                         apply nat.mul_le_mul_left,
                         apply ack_1st_incr_eq,
                         apply nat.le_add_right,
                       end
               ...  <= ack (sum_of_fin (fun i, prim_depth (g i)) + 3) (sum_of_fin arg + k) :
                       begin
                         apply ack_lemma_7,
                         apply nat.le_add_left,
                       end
               ...  <= ack (k + 3 + sum_of_fin (fun i, prim_depth (g i))) (sum_of_fin arg) :
                       begin
                         generalize : sum_of_fin (fun i, prim_depth (g i)) = y,
                         generalize : sum_of_fin arg = x,
                         calc
                           ack (y + 3) (x + k) <= ack (y + 3 + k) x :
                             by apply ack_arg_1st_prior_any
                           ... = ack (y + k + 3) x : by simp only [nat.succ_add]
                           ... = ack (y + (k + 3)) x : by reflexivity
                           ... = ack (k + 3 + y) x : by rw nat.add_comm y (k + 3)
                       end
           end
  ...  >= prim_rec.eval f (fun i, prim_rec.eval (g i) arg) : by apply ih_1
  ...  =  prim_rec.eval (prim_rec.comp f g) arg : by reflexivity,
  unfold prim_rec.eval,
  let h: nat -> (fin k -> nat) -> nat :=
    fun (v: nat) (arg: fin k -> nat),
      nat.rec (prim_rec.eval f arg) (fun v' prev, prim_rec.eval g (fin_seq.push prev (fin_seq.push v' arg))) v,
  show ack (prim_depth (prim_rec.prec f g)) (sum_of_fin arg) >= prim_rec.eval._match_1 k h (fin_seq.pop arg),
  rw fin_seq.push_of_pop arg,
  generalize : fin_seq.pop arg = pq,
  cases pq with v rest,
  rw sum_of_fin_of_curry,
  rw prim_depth_rw_prec,
  let fgdep := max (prim_depth f) (prim_depth g + 2) + 1,
  show ack fgdep (sum_of_fin rest + v) >= h v rest,
  induction v with v' ihinner,
  calc
    ack fgdep (sum_of_fin rest)
        >= ack (prim_depth f) (sum_of_fin rest) :
           begin
             apply ack_1st_incr_eq,
             apply nat.le_succ_of_le,
             apply le_max_left,
           end
    ... >= prim_rec.eval f rest : by apply ih_1
    ... =  h 0 rest : by reflexivity,
  calc
    ack fgdep (sum_of_fin rest + v' + 1)
    = ack (max (prim_depth f) (prim_depth g + 2)) (ack fgdep (sum_of_fin rest + v')) : by simp only [ack]
    ... >= ack (prim_depth g + 2) (ack fgdep (sum_of_fin rest + v')) : by apply ack_1st_incr_eq; apply le_max_right
    ... >= ack (prim_depth g + 1) (2 * ack fgdep (sum_of_fin rest + v')) : by apply nat.le_of_lt; apply ack_lemma_8; apply nat.le_add_left
    ... >= ack (prim_depth g) (2 * ack fgdep (sum_of_fin rest + v')) : by apply ack_1st_incr_eq; apply nat.le_add_right
    ... >= ack (prim_depth g) (sum_of_fin (fin_seq.push (h v' rest) (fin_seq.push v' rest))) :
           begin
             apply ack_2nd_incr_eq,
             calc
               2 * ack fgdep (sum_of_fin rest + v')
               >= sum_of_fin rest + v' + ack fgdep (sum_of_fin rest + v') :
                 begin
                   rw nat.succ_mul,
                   apply nat.add_le_add_right,
                   rw nat.one_mul,
                   apply nat.le_of_lt,
                   apply ack_2nd_lt_val,
                 end
               ... >= sum_of_fin rest + v' + h v' rest :
                 begin
                   apply nat.add_le_add_left,
                   exact ihinner,
                 end
               ... =  sum_of_fin (fin_seq.push (h v' rest) (fin_seq.push v' rest)) :
                   by repeat { rw sum_of_fin_of_curry },
           end
    ... >= prim_rec.eval g (fin_seq.push (h v' rest) (fin_seq.push v' rest)) : by apply ih_2
    ... =  h (v' + 1) rest : by reflexivity,
end

theorem ack_is_not_prim_rec:
  forall f: prim_rec 1, (forall x,
  ack x x = prim_rec.eval f (fun _, x)) -> false :=
begin
  intros f h,
  let x: nat := prim_depth f + 1,
  have ph := ack_dominates_prim_rec 1 f (fun _, x),
  rw sum_of_fin_1 at ph,
  rw <- (h x) at ph,
  apply lt_irrefl (ack (prim_depth f) x),
  calc
    ack (prim_depth f) x
        <  ack x x : by apply ack_1st_succ
    ... <= ack (prim_depth f) x : ph,
end

theorem ack_is_not_prim_rec_2:
  forall f: prim_rec 2, (forall x y,
  ack x y =  prim_rec.eval f (fin_seq.push x (fun _: fin 1, y))) -> false :=
begin
  intros f h,
  have one_arg_ver: forall x, ack x x = prim_rec.eval (prim_rec.comp f (fun _, prim_rec.id)) (fun _, x)
  :=
  begin
    intro x,
    show ack x x = prim_rec.eval f (fun _, prim_rec.eval prim_rec.id ({x}: fin_seq _ _)),
    rw prim_rec.id.is_id,
    rw h x x,
    apply congr_arg,
    apply funext,
    intro i,
    cases i with i is_lt,
    have h := nat.le_of_lt_succ is_lt,
    cases h with _ a, { reflexivity },
    have hp := nat.eq_zero_of_le_zero a,
    cases hp,
    reflexivity,
  end,
  exact ack_is_not_prim_rec _ one_arg_ver,
end


/-
Copyright (c) 2022 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import measure_theory.measure.measure_space

/-!
# Measures positive on nonempty opens

In this file we define a typeclass for measures that are positive on nonempty opens, see
`measure_theory.measure.is_open_pos_measure`. Examples include (additive) Haar measures, as well as
measures that have positive density with respect to a Haar measure. We also prove some basic facts
about these measures.

-/

open_locale topological_space ennreal measure_theory
open set function filter

namespace measure_theory

namespace measure

section basic

variables {X Y : Type*} [topological_space X] {m : measurable_space X}
  [topological_space Y] [t2_space Y] (μ ν : measure X)

/-- A measure is said to be `is_open_pos_measure` if it is positive on nonempty open sets. -/
class is_open_pos_measure : Prop :=
(open_pos : ∀ (U : set X), is_open U → U.nonempty → μ U ≠ 0)

variables [is_open_pos_measure μ] {s U : set X} {x : X}

lemma _root_.is_open.measure_ne_zero (hU : is_open U) (hne : U.nonempty) : μ U ≠ 0 :=
is_open_pos_measure.open_pos U hU hne

lemma _root_.is_open.measure_pos (hU : is_open U) (hne : U.nonempty) : 0 < μ U :=
(hU.measure_ne_zero μ hne).bot_lt

lemma _root_.is_open.measure_pos_iff (hU : is_open U) : 0 < μ U ↔ U.nonempty :=
⟨λ h, ne_empty_iff_nonempty.1 $ λ he, h.ne' $ he.symm ▸ measure_empty, hU.measure_pos μ⟩

lemma _root_.is_open.measure_eq_zero_iff (hU : is_open U) : μ U = 0 ↔ U = ∅ :=
by simpa only [not_lt, nonpos_iff_eq_zero, not_nonempty_iff_eq_empty]
  using not_congr (hU.measure_pos_iff μ)

lemma measure_pos_of_nonempty_interior (h : (interior s).nonempty) : 0 < μ s :=
(is_open_interior.measure_pos μ h).trans_le (measure_mono interior_subset)

lemma measure_pos_of_mem_nhds (h : s ∈ 𝓝 x) : 0 < μ s :=
measure_pos_of_nonempty_interior _ ⟨x, mem_interior_iff_mem_nhds.2 h⟩

lemma is_open_pos_measure_smul {c : ℝ≥0∞} (h : c ≠ 0) : is_open_pos_measure (c • μ) :=
⟨λ U Uo Une, mul_ne_zero h (Uo.measure_ne_zero μ Une)⟩

variables {μ ν}

protected lemma absolutely_continuous.is_open_pos_measure (h : μ ≪ ν) :
  is_open_pos_measure ν :=
⟨λ U ho hne h₀, ho.measure_ne_zero μ hne (h h₀)⟩

lemma _root_.has_le.le.is_open_pos_measure (h : μ ≤ ν) :
  is_open_pos_measure ν :=
h.absolutely_continuous.is_open_pos_measure

lemma _root_.is_open.eq_empty_of_measure_zero (hU : is_open U) (h₀ : μ U = 0) :
  U = ∅ :=
(hU.measure_eq_zero_iff μ).mp h₀

lemma interior_eq_empty_of_null (hs : μ s = 0) : interior s = ∅ :=
is_open_interior.eq_empty_of_measure_zero $ measure_mono_null interior_subset hs

/-- If two functions are a.e. equal on an open set and are continuous on this set, then they are
equal on this set. -/
lemma eq_on_open_of_ae_eq {f g : X → Y} (h : f =ᵐ[μ.restrict U] g) (hU : is_open U)
  (hf : continuous_on f U) (hg : continuous_on g U) :
  eq_on f g U :=
begin
  replace h := ae_imp_of_ae_restrict h,
  simp only [eventually_eq, ae_iff, not_imp] at h,
  have : is_open (U ∩ {a | f a ≠ g a}),
  { refine is_open_iff_mem_nhds.mpr (λ a ha, inter_mem (hU.mem_nhds ha.1) _),
    rcases ha with ⟨ha : a ∈ U, ha' : (f a, g a) ∈ (diagonal Y)ᶜ⟩,
    exact (hf.continuous_at (hU.mem_nhds ha)).prod_mk_nhds (hg.continuous_at (hU.mem_nhds ha))
      (is_closed_diagonal.is_open_compl.mem_nhds ha') },
  replace := (this.eq_empty_of_measure_zero h).le,
  exact λ x hx, not_not.1 (λ h, this ⟨hx, h⟩)
end

/-- If two continuous functions are a.e. equal, then they are equal. -/
lemma eq_of_ae_eq {f g : X → Y} (h : f =ᵐ[μ] g) (hf : continuous f) (hg : continuous g) : f = g :=
suffices eq_on f g univ, from funext (λ x, this trivial),
eq_on_open_of_ae_eq (ae_restrict_of_ae h) is_open_univ hf.continuous_on hg.continuous_on

lemma eq_on_of_ae_eq {f g : X → Y} (h : f =ᵐ[μ.restrict s] g) (hf : continuous_on f s)
  (hg : continuous_on g s) (hU : s ⊆ closure (interior s)) :
  eq_on f g s :=
have interior s ⊆ s, from interior_subset,
(eq_on_open_of_ae_eq (ae_restrict_of_ae_restrict_of_subset this h) is_open_interior
  (hf.mono this) (hg.mono this)).of_subset_closure hf hg this hU

variable (μ)

lemma _root_.continuous.ae_eq_iff_eq {f g : X → Y} (hf : continuous f) (hg : continuous g) :
  f =ᵐ[μ] g ↔ f = g :=
⟨λ h, eq_of_ae_eq h hf hg, λ h, h ▸ eventually_eq.rfl⟩

end basic

section linear_order

variables {X Y : Type*} [topological_space X] [linear_order X] [order_topology X]
  {m : measurable_space X} [topological_space Y] [t2_space Y] (μ : measure X)
  [is_open_pos_measure μ]

lemma measure_Ioi_pos [no_max_order X] (a : X) : 0 < μ (Ioi a) :=
is_open_Ioi.measure_pos μ nonempty_Ioi

lemma measure_Iio_pos [no_min_order X] (a : X) : 0 < μ (Iio a) :=
is_open_Iio.measure_pos μ nonempty_Iio

lemma measure_Ioo_pos [densely_ordered X] {a b : X} : 0 < μ (Ioo a b) ↔ a < b :=
(is_open_Ioo.measure_pos_iff μ).trans nonempty_Ioo

lemma measure_Ioo_eq_zero [densely_ordered X] {a b : X} : μ (Ioo a b) = 0 ↔ b ≤ a :=
(is_open_Ioo.measure_eq_zero_iff μ).trans (Ioo_eq_empty_iff.trans not_lt)

lemma eq_on_Ioo_of_ae_eq {a b : X} {f g : X → Y} (hfg : f =ᵐ[μ.restrict (Ioo a b)] g)
  (hf : continuous_on f (Ioo a b)) (hg : continuous_on g (Ioo a b)) : eq_on f g (Ioo a b) :=
eq_on_of_ae_eq hfg hf hg Ioo_subset_closure_interior

lemma eq_on_Ioc_of_ae_eq [densely_ordered X] {a b : X} {f g : X → Y}
  (hfg : f =ᵐ[μ.restrict (Ioc a b)] g) (hf : continuous_on f (Ioc a b))
  (hg : continuous_on g (Ioc a b)) : eq_on f g (Ioc a b) :=
eq_on_of_ae_eq hfg hf hg (Ioc_subset_closure_interior _ _)

lemma eq_on_Ico_of_ae_eq [densely_ordered X] {a b : X} {f g : X → Y}
  (hfg : f =ᵐ[μ.restrict (Ico a b)] g) (hf : continuous_on f (Ico a b))
  (hg : continuous_on g (Ico a b)) : eq_on f g (Ico a b) :=
eq_on_of_ae_eq hfg hf hg (Ico_subset_closure_interior _ _)

lemma eq_on_Icc_of_ae_eq [densely_ordered X] {a b : X} (hne : a ≠ b) {f g : X → Y}
  (hfg : f =ᵐ[μ.restrict (Icc a b)] g) (hf : continuous_on f (Icc a b))
  (hg : continuous_on g (Icc a b)) : eq_on f g (Icc a b) :=
eq_on_of_ae_eq hfg hf hg (closure_interior_Icc hne).symm.subset

end linear_order

end measure

end measure_theory

open measure_theory measure_theory.measure

namespace metric

variables {X : Type*} [pseudo_metric_space X] {m : measurable_space X} (μ : measure X)
  [is_open_pos_measure μ]

lemma measure_ball_pos (x : X) {r : ℝ} (hr : 0 < r) : 0 < μ (ball x r) :=
is_open_ball.measure_pos μ (nonempty_ball.2 hr)

lemma measure_closed_ball_pos (x : X) {r : ℝ} (hr : 0 < r) :
  0 < μ (closed_ball x r) :=
(measure_ball_pos μ x hr).trans_le (measure_mono ball_subset_closed_ball)

end metric

namespace emetric

variables {X : Type*} [pseudo_emetric_space X] {m : measurable_space X} (μ : measure X)
  [is_open_pos_measure μ]

lemma measure_ball_pos (x : X) {r : ℝ≥0∞} (hr : r ≠ 0) : 0 < μ (ball x r) :=
is_open_ball.measure_pos μ ⟨x, mem_ball_self hr.bot_lt⟩

lemma measure_closed_ball_pos (x : X) {r : ℝ≥0∞} (hr : r ≠ 0) :
  0 < μ (closed_ball x r) :=
(measure_ball_pos μ x hr).trans_le (measure_mono ball_subset_closed_ball)

end emetric


/-
Copyright (c) 2018 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Simon Hudon
-/

import data.pfunctor.multivariate.basic
import data.qpf.multivariate.basic

/-!
# The composition of QPFs is itself a QPF

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

We define composition between one `n`-ary functor and `n` `m`-ary functors
and show that it preserves the QPF structure
-/

universes u

namespace mvqpf
open_locale mvfunctor

variables {n m : ℕ}
  (F : typevec.{u} n → Type*) [fF : mvfunctor F] [q : mvqpf F]
  (G : fin2 n → typevec.{u} m → Type u) [fG : ∀ i, mvfunctor $ G i] [q' : ∀ i, mvqpf $ G i]

/-- Composition of an `n`-ary functor with `n` `m`-ary
functors gives us one `m`-ary functor -/
def comp (v : typevec.{u} m) : Type* :=
F $ λ i : fin2 n, G i v

namespace comp
open mvfunctor mvpfunctor
variables {F G} {α β : typevec.{u} m} (f : α ⟹ β)

instance [I : inhabited (F $ λ i : fin2 n, G i α)] : inhabited (comp F G α) := I

/-- Constructor for functor composition -/
protected def mk (x : F $ λ i, G i α) : (comp F G) α := x

/-- Destructor for functor composition -/
protected def get (x : (comp F G) α) : F $ λ i, G i α := x

@[simp] protected lemma mk_get (x : (comp F G) α) : comp.mk (comp.get x) = x := rfl

@[simp] protected lemma get_mk (x : F $ λ i, G i α) : comp.get (comp.mk x) = x := rfl

include fG

/-- map operation defined on a vector of functors -/
protected def map' : (λ (i : fin2 n), G i α) ⟹ λ (i : fin2 n), G i β :=
λ i, map f

include fF

/-- The composition of functors is itself functorial -/
protected def map : (comp F G) α → (comp F G) β :=
(map (λ i, map f) : F (λ i, G i α) → F (λ i, G i β))

instance : mvfunctor (comp F G) :=
{ map := λ α β, comp.map }

lemma map_mk (x : F $ λ i, G i α) :
  f <$$> comp.mk x = comp.mk ((λ i (x : G i α), f <$$> x) <$$> x) := rfl

lemma get_map (x : comp F G α) :
  comp.get (f <$$> x) = (λ i (x : G i α), f <$$> x) <$$> comp.get x := rfl

include q q'

instance : mvqpf (comp F G) :=
{ P         := mvpfunctor.comp (P F) (λ i, P $ G i),
  abs       := λ α, comp.mk ∘ map (λ i, abs) ∘ abs ∘ mvpfunctor.comp.get,
  repr      := λ α,  mvpfunctor.comp.mk ∘ repr ∘
                 map (λ i, (repr : G i α → (λ (i : fin2 n), obj (P (G i)) α) i)) ∘ comp.get,
  abs_repr  := by { intros, simp [(∘), mvfunctor.map_map, (⊚), abs_repr] },
  abs_map   := by { intros, simp [(∘)], rw [← abs_map],
                    simp [mvfunctor.id_map, (⊚), map_mk, mvpfunctor.comp.get_map, abs_map,
                      mvfunctor.map_map, abs_repr] } }

end comp

end mvqpf


/-
Copyright (c) 2022 Oliver Nash. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Oliver Nash
-/
import algebra.lie.nilpotent
import algebra.lie.cartan_subalgebra

/-!
# Engel's theorem

This file contains a proof of Engel's theorem providing necessary and sufficient conditions for Lie
algebras and Lie modules to be nilpotent.

The key result `lie_module.is_nilpotent_iff_forall` says that if `M` is a Lie module of a
Noetherian Lie algebra `L`, then `M` is nilpotent iff the image of `L → End(M)` consists of
nilpotent elements. In the special case that we have the adjoint representation `M = L`, this says
that a Lie algebra is nilpotent iff `ad x : End(L)` is nilpotent for all `x : L`.

Engel's theorem is true for any coefficients (i.e., it is really a theorem about Lie rings) and so
we work with coefficients in any commutative ring `R` throughout.

On the other hand, Engel's theorem is not true for infinite-dimensional Lie algebras and so a
finite-dimensionality assumption is required. We prove the theorem subject to the the assumption
that the Lie algebra is Noetherian as an `R`-module, though actually we only need the slightly
weaker property that the relation `>` is well-founded on the complete lattice of Lie subalgebras.

## Remarks about the proof

Engel's theorem is usually proved in the special case that the coefficients are a field, and uses
an inductive argument on the dimension of the Lie algebra. One begins by choosing either a maximal
proper Lie subalgebra (in some proofs) or a maximal nilpotent Lie subalgebra (in other proofs, at
the cost of obtaining a weaker end result).

Since we work with general coefficients, we cannot induct on dimension and an alternate approach
must be taken. The key ingredient is the concept of nilpotency, not just for Lie algebras, but for
Lie modules. Using this concept, we define an _Engelian Lie algebra_ `lie_algebra.is_engelian` to
be one for which a Lie module is nilpotent whenever the action consists of nilpotent endomorphisms.
The argument then proceeds by selecting a maximal Engelian Lie subalgebra and showing that it cannot
be proper.

The first part of the traditional statement of Engel's theorem consists of the statement that if `M`
is a non-trivial `R`-module and `L ⊆ End(M)` is a finite-dimensional Lie subalgebra of nilpotent
elements, then there exists a non-zero element `m : M` that is annihilated by every element of `L`.
This follows trivially from the result established here `lie_module.is_nilpotent_iff_forall`, that
`M` is a nilpotent Lie module over `L`, since the last non-zero term in the lower central series
will consist of such elements `m` (see: `lie_module.nontrivial_max_triv_of_is_nilpotent`). It seems
that this result has not previously been established at this level of generality.

The second part of the traditional statement of Engel's theorem concerns nilpotency of the Lie
algebra and a proof of this for general coefficients appeared in the literature as long ago
[as 1937](zorn1937). This also follows trivially from `lie_module.is_nilpotent_iff_forall` simply by
taking `M = L`.

It is pleasing that the two parts of the traditional statements of Engel's theorem are thus unified
into a single statement about nilpotency of Lie modules. This is not usually emphasised.

## Main definitions

  * `lie_algebra.is_engelian`
  * `lie_algebra.is_engelian_of_is_noetherian`
  * `lie_module.is_nilpotent_iff_forall`
  * `lie_algebra.is_nilpotent_iff_forall`

-/

universes u₁ u₂ u₃ u₄

variables {R : Type u₁} {L : Type u₂} {L₂ : Type u₃} {M : Type u₄}
variables [comm_ring R] [lie_ring L] [lie_algebra R L] [lie_ring L₂] [lie_algebra R L₂]
variables [add_comm_group M] [module R M] [lie_ring_module L M] [lie_module R L M]

include R L

namespace lie_submodule

open lie_module

variables {I : lie_ideal R L} {x : L} (hxI : (R ∙ x) ⊔ I = ⊤)

include hxI

lemma exists_smul_add_of_span_sup_eq_top (y : L) : ∃ (t : R) (z ∈ I), y = t • x + z :=
begin
  have hy : y ∈ (⊤ : submodule R L) := submodule.mem_top,
  simp only [← hxI, submodule.mem_sup, submodule.mem_span_singleton] at hy,
  obtain ⟨-, ⟨t, rfl⟩, z, hz, rfl⟩ := hy,
  exact ⟨t, z, hz, rfl⟩,
end

lemma lie_top_eq_of_span_sup_eq_top (N : lie_submodule R L M) :
  (↑⁅(⊤ : lie_ideal R L), N⁆ : submodule R M) =
  (N : submodule R M).map (to_endomorphism R L M x) ⊔ (↑⁅I, N⁆ : submodule R M) :=
begin
  simp only [lie_ideal_oper_eq_linear_span', submodule.sup_span, mem_top, exists_prop,
    exists_true_left, submodule.map_coe, to_endomorphism_apply_apply],
  refine le_antisymm (submodule.span_le.mpr _) (submodule.span_mono (λ z hz, _)),
  { rintros z ⟨y, n, hn : n ∈ N, rfl⟩,
    obtain ⟨t, z, hz, rfl⟩ := exists_smul_add_of_span_sup_eq_top hxI y,
    simp only [set_like.mem_coe, submodule.span_union, submodule.mem_sup],
    exact ⟨t • ⁅x, n⁆, submodule.subset_span ⟨t • n, N.smul_mem' t hn, lie_smul t x n⟩,
      ⁅z, n⁆, submodule.subset_span ⟨z, hz, n, hn, rfl⟩, by simp⟩, },
  { rcases hz with ⟨m, hm, rfl⟩ | ⟨y, hy, m, hm, rfl⟩,
    exacts [⟨x, m, hm, rfl⟩, ⟨y, m, hm, rfl⟩], },
end

lemma lcs_le_lcs_of_is_nilpotent_span_sup_eq_top {n i j : ℕ} (hxn : (to_endomorphism R L M x)^n = 0)
  (hIM : lower_central_series R L M i ≤ I.lcs M j) :
  lower_central_series R L M (i + n) ≤ I.lcs M (j + 1) :=
begin
  suffices : ∀ l, ((⊤ : lie_ideal R L).lcs M (i + l) : submodule R M) ≤
    (I.lcs M j : submodule R M).map
    ((to_endomorphism R L M x)^l) ⊔ (I.lcs M (j + 1) : submodule R M),
  { simpa only [bot_sup_eq, lie_ideal.incl_coe, submodule.map_zero, hxn] using this n, },
  intros l,
  induction l with l ih,
  { simp only [add_zero, lie_ideal.lcs_succ, pow_zero, linear_map.one_eq_id, submodule.map_id],
    exact le_sup_of_le_left hIM, },
  { simp only [lie_ideal.lcs_succ, i.add_succ l, lie_top_eq_of_span_sup_eq_top hxI, sup_le_iff],
    refine ⟨(submodule.map_mono ih).trans _, le_sup_of_le_right _⟩,
    { rw [submodule.map_sup, ← submodule.map_comp, ← linear_map.mul_eq_comp, ← pow_succ,
        ← I.lcs_succ],
      exact sup_le_sup_left coe_map_to_endomorphism_le _, },
    { refine le_trans (mono_lie_right _ _ I _) (mono_lie_right _ _ I hIM),
      exact antitone_lower_central_series R L M le_self_add, }, },
end

lemma is_nilpotent_of_is_nilpotent_span_sup_eq_top
  (hnp : is_nilpotent $ to_endomorphism R L M x) (hIM : is_nilpotent R I M) :
  is_nilpotent R L M :=
begin
  obtain ⟨n, hn⟩ := hnp,
  unfreezingI { obtain ⟨k, hk⟩ := hIM, },
  have hk' : I.lcs M k = ⊥,
  { simp only [← coe_to_submodule_eq_iff, I.coe_lcs_eq, hk, bot_coe_submodule], },
  suffices : ∀ l, lower_central_series R L M (l * n) ≤ I.lcs M l,
  { use k * n,
    simpa [hk'] using this k, },
  intros l,
  induction l with l ih,
  { simp, },
  { exact (l.succ_mul n).symm ▸ lcs_le_lcs_of_is_nilpotent_span_sup_eq_top hxI hn ih, },
end

end lie_submodule

section lie_algebra

open lie_module (hiding is_nilpotent)

variables (R L)

/-- A Lie algebra `L` is said to be Engelian if a sufficient condition for any `L`-Lie module `M` to
be nilpotent is that the image of the map `L → End(M)` consists of nilpotent elements.

Engel's theorem `lie_algebra.is_engelian_of_is_noetherian` states that any Noetherian Lie algebra is
Engelian. -/
def lie_algebra.is_engelian : Prop :=
  ∀ (M : Type u₄) [add_comm_group M], by exactI ∀ [module R M] [lie_ring_module L M], by exactI ∀
    [lie_module R L M], by exactI ∀ (h : ∀ (x : L), is_nilpotent (to_endomorphism R L M x)),
    lie_module.is_nilpotent R L M

variables {R L}

lemma lie_algebra.is_engelian_of_subsingleton [subsingleton L] : lie_algebra.is_engelian R L :=
begin
  intros M _i1 _i2 _i3 _i4 h,
  use 1,
  suffices : (⊤ : lie_ideal R L) = ⊥, { simp [this], },
  haveI := (lie_submodule.subsingleton_iff R L L).mpr infer_instance,
  apply subsingleton.elim,
end

lemma function.surjective.is_engelian
  {f : L →ₗ⁅R⁆ L₂} (hf : function.surjective f) (h : lie_algebra.is_engelian.{u₁ u₂ u₄} R L) :
  lie_algebra.is_engelian.{u₁ u₃ u₄} R L₂ :=
begin
  introsI M _i1 _i2 _i3 _i4 h',
  letI : lie_ring_module L M := lie_ring_module.comp_lie_hom M f,
  letI : lie_module R L M := comp_lie_hom M f,
  have hnp : ∀ x, is_nilpotent (to_endomorphism R L M x) := λ x, h' (f x),
  have surj_id : function.surjective (linear_map.id : M →ₗ[R] M) := function.surjective_id,
  haveI : lie_module.is_nilpotent R L M := h M hnp,
  apply hf.lie_module_is_nilpotent surj_id,
  simp,
end

lemma lie_equiv.is_engelian_iff (e : L ≃ₗ⁅R⁆ L₂) :
  lie_algebra.is_engelian.{u₁ u₂ u₄} R L ↔ lie_algebra.is_engelian.{u₁ u₃ u₄} R L₂ :=
⟨e.surjective.is_engelian, e.symm.surjective.is_engelian⟩

lemma lie_algebra.exists_engelian_lie_subalgebra_of_lt_normalizer
  {K : lie_subalgebra R L} (hK₁ : lie_algebra.is_engelian.{u₁ u₂ u₄} R K) (hK₂ : K < K.normalizer) :
  ∃ (K' : lie_subalgebra R L) (hK' : lie_algebra.is_engelian.{u₁ u₂ u₄} R K'), K < K' :=
begin
  obtain ⟨x, hx₁, hx₂⟩ := set_like.exists_of_lt hK₂,
  let K' : lie_subalgebra R L :=
  { lie_mem' := λ y z, lie_subalgebra.lie_mem_sup_of_mem_normalizer hx₁,
    .. (R ∙ x) ⊔ (K : submodule R L) },
  have hxK' : x ∈ K' := submodule.mem_sup_left (submodule.subset_span (set.mem_singleton _)),
  have hKK' : K ≤ K' := (lie_subalgebra.coe_submodule_le_coe_submodule K K').mp le_sup_right,
  have hK' : K' ≤ K.normalizer,
  { rw ← lie_subalgebra.coe_submodule_le_coe_submodule,
    exact sup_le ((submodule.span_singleton_le_iff_mem _ _).mpr hx₁) hK₂.le, },
  refine ⟨K', _, lt_iff_le_and_ne.mpr ⟨hKK', λ contra, hx₂ (contra.symm ▸ hxK')⟩⟩,
  introsI M _i1 _i2 _i3 _i4 h,
  obtain ⟨I, hI₁ : (I : lie_subalgebra R K') = lie_subalgebra.of_le hKK'⟩ :=
    lie_subalgebra.exists_nested_lie_ideal_of_le_normalizer hKK' hK',
  have hI₂ : (R ∙ (⟨x, hxK'⟩ : K')) ⊔ I = ⊤,
  { rw [← lie_ideal.coe_to_lie_subalgebra_to_submodule R K' I, hI₁],
    apply submodule.map_injective_of_injective (K' : submodule R L).injective_subtype,
    simpa, },
  have e : K ≃ₗ⁅R⁆ I := (lie_subalgebra.equiv_of_le hKK').trans
    (lie_equiv.of_eq _ _ ((lie_subalgebra.coe_set_eq _ _).mpr hI₁.symm)),
  have hI₃ : lie_algebra.is_engelian R I := e.is_engelian_iff.mp hK₁,
  exact lie_submodule.is_nilpotent_of_is_nilpotent_span_sup_eq_top hI₂ (h _) (hI₃ _ (λ x, h x)),
end

local attribute [instance] lie_subalgebra.subsingleton_bot

variables [is_noetherian R L]

/-- *Engel's theorem*.

Note that this implies all traditional forms of Engel's theorem via
`lie_module.nontrivial_max_triv_of_is_nilpotent`, `lie_module.is_nilpotent_iff_forall`,
`lie_algebra.is_nilpotent_iff_forall`. -/
lemma lie_algebra.is_engelian_of_is_noetherian : lie_algebra.is_engelian R L :=
begin
  introsI M _i1 _i2 _i3 _i4 h,
  rw ← is_nilpotent_range_to_endomorphism_iff,
  let L' := (to_endomorphism R L M).range,
  replace h : ∀ (y : L'), is_nilpotent (y : module.End R M),
  { rintros ⟨-, ⟨y, rfl⟩⟩,
    simp [h], },
  change lie_module.is_nilpotent R L' M,
  let s := { K : lie_subalgebra R L' | lie_algebra.is_engelian R K },
  have hs : s.nonempty := ⟨⊥, lie_algebra.is_engelian_of_subsingleton⟩,
  suffices : ⊤ ∈ s,
  { rw ← is_nilpotent_of_top_iff,
    apply this M,
    simp [lie_subalgebra.to_endomorphism_eq, h], },
  have : ∀ (K ∈ s), K ≠ ⊤ → ∃ (K' ∈ s), K < K',
  { rintros K (hK₁ : lie_algebra.is_engelian R K) hK₂,
    apply lie_algebra.exists_engelian_lie_subalgebra_of_lt_normalizer hK₁,
    apply lt_of_le_of_ne K.le_normalizer,
    rw [ne.def, eq_comm, K.normalizer_eq_self_iff, ← ne.def,
      ← lie_submodule.nontrivial_iff_ne_bot R K],
    haveI : nontrivial (L' ⧸ K.to_lie_submodule),
    { replace hK₂ : K.to_lie_submodule ≠ ⊤ :=
        by rwa [ne.def, ← lie_submodule.coe_to_submodule_eq_iff, K.coe_to_lie_submodule,
          lie_submodule.top_coe_submodule, ← lie_subalgebra.top_coe_submodule,
          K.coe_to_submodule_eq_iff],
      exact submodule.quotient.nontrivial_of_lt_top _ hK₂.lt_top, },
    haveI : lie_module.is_nilpotent R K (L' ⧸ K.to_lie_submodule),
    { refine hK₁ _ (λ x, _),
      have hx := lie_algebra.is_nilpotent_ad_of_is_nilpotent (h x),
      exact module.End.is_nilpotent.mapq _ hx, },
    exact nontrivial_max_triv_of_is_nilpotent R K (L' ⧸ K.to_lie_submodule), },
  haveI _i5 : is_noetherian R L' :=
    is_noetherian_of_surjective L _ (linear_map.range_range_restrict (to_endomorphism R L M)),
  obtain ⟨K, hK₁, hK₂⟩ :=
    well_founded.well_founded_iff_has_max'.mp (lie_subalgebra.well_founded_of_noetherian R L') s hs,
  have hK₃ : K = ⊤,
  { by_contra contra,
    obtain ⟨K', hK'₁, hK'₂⟩ := this K hK₁ contra,
    specialize hK₂ K' hK'₁ (le_of_lt hK'₂),
    replace hK'₂ := (ne_of_lt hK'₂).symm,
    contradiction, },
  exact hK₃ ▸ hK₁,
end

/-- Engel's theorem. -/
lemma lie_module.is_nilpotent_iff_forall :
  lie_module.is_nilpotent R L M ↔ ∀ x, is_nilpotent $ to_endomorphism R L M x :=
⟨begin
  introsI h,
  obtain ⟨k, hk⟩ := nilpotent_endo_of_nilpotent_module R L M,
  exact λ x, ⟨k, hk x⟩,
end,
λ h, lie_algebra.is_engelian_of_is_noetherian M h⟩

/-- Engel's theorem. -/
lemma lie_algebra.is_nilpotent_iff_forall :
  lie_algebra.is_nilpotent R L ↔ ∀ x, is_nilpotent $ lie_algebra.ad R L x :=
lie_module.is_nilpotent_iff_forall

end lie_algebra


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

import linear_algebra.linear_pmap
import topology.algebra.module.basic

/-!
# Partially defined linear operators over topological vector spaces

We define basic notions of partially defined linear operators, which we call unbounded operators
for short.
In this file we prove all elementary properties of unbounded operators that do not assume that the
underlying spaces are normed.

## Main definitions

* `linear_pmap.is_closed`: An unbounded operator is closed iff its graph is closed.
* `linear_pmap.is_closable`: An unbounded operator is closable iff the closure of its graph is a
  graph.
* `linear_pmap.closure`: For a closable unbounded operator `f : linear_pmap R E F` the closure is
  the smallest closed extension of `f`. If `f` is not closable, then `f.closure` is defined as `f`.
* `linear_pmap.has_core`: a submodule contained in the domain is a core if restricting to the core
  does not lose information about the unbounded operator.

## Main statements

* `linear_pmap.closable_iff_exists_closed_extension`: an unbounded operator is closable iff it has a
  closed extension.
* `linear_pmap.closable.exists_unique`: there exists a unique closure
* `linear_pmap.closure_has_core`: the domain of `f` is a core of its closure

## References

* [J. Weidmann, *Linear Operators in Hilbert Spaces*][weidmann_linear]

## Tags

Unbounded operators, closed operators
-/

open_locale topology

variables {R E F : Type*}

variables [comm_ring R] [add_comm_group E] [add_comm_group F]
variables [module R E] [module R F]
variables [topological_space E] [topological_space F]

namespace linear_pmap

/-! ### Closed and closable operators -/

/-- An unbounded operator is closed iff its graph is closed. -/
def is_closed (f : E →ₗ.[R] F) : Prop :=
is_closed (f.graph : set (E × F))

variables [has_continuous_add E] [has_continuous_add F]
variables [topological_space R] [has_continuous_smul R E] [has_continuous_smul R F]

/-- An unbounded operator is closable iff the closure of its graph is a graph. -/
def is_closable (f : E →ₗ.[R] F) : Prop :=
∃ (f' : linear_pmap R E F), f.graph.topological_closure = f'.graph

/-- A closed operator is trivially closable. -/
lemma is_closed.is_closable {f : E →ₗ.[R] F} (hf : f.is_closed) : f.is_closable :=
⟨f, hf.submodule_topological_closure_eq⟩

/-- If `g` has a closable extension `f`, then `g` itself is closable. -/
lemma is_closable.le_is_closable {f g : E →ₗ.[R] F} (hf : f.is_closable) (hfg : g ≤ f) :
  g.is_closable :=
begin
  cases hf with f' hf,
  have : g.graph.topological_closure ≤ f'.graph :=
  by { rw ←hf, exact submodule.topological_closure_mono (le_graph_of_le hfg) },
  refine ⟨g.graph.topological_closure.to_linear_pmap _, _⟩,
  { intros x hx hx',
    cases x,
    exact f'.graph_fst_eq_zero_snd (this hx) hx' },
  rw [submodule.to_linear_pmap_graph_eq],
end

/-- The closure is unique. -/
lemma is_closable.exists_unique {f : E →ₗ.[R] F} (hf : f.is_closable) :
  ∃! (f' : E →ₗ.[R] F), f.graph.topological_closure = f'.graph :=
begin
  refine exists_unique_of_exists_of_unique hf (λ _ _ hy₁ hy₂, eq_of_eq_graph _),
  rw [←hy₁, ←hy₂],
end

open_locale classical

/-- If `f` is closable, then `f.closure` is the closure. Otherwise it is defined
as `f.closure = f`. -/
noncomputable
def closure (f : E →ₗ.[R] F) : E →ₗ.[R] F :=
if hf : f.is_closable then hf.some else f

lemma closure_def {f : E →ₗ.[R] F} (hf : f.is_closable) :
  f.closure = hf.some :=
by simp [closure, hf]

lemma closure_def' {f : E →ₗ.[R] F} (hf : ¬f.is_closable) :
  f.closure = f :=
by simp [closure, hf]

/-- The closure (as a submodule) of the graph is equal to the graph of the closure
  (as a `linear_pmap`). -/
lemma is_closable.graph_closure_eq_closure_graph {f : E →ₗ.[R] F} (hf : f.is_closable) :
  f.graph.topological_closure = f.closure.graph :=
begin
  rw closure_def hf,
  exact hf.some_spec,
end

/-- A `linear_pmap` is contained in its closure. -/
lemma le_closure (f : E →ₗ.[R] F) : f ≤ f.closure :=
begin
  by_cases hf : f.is_closable,
  { refine le_of_le_graph _,
    rw ←hf.graph_closure_eq_closure_graph,
    exact (graph f).le_topological_closure },
  rw closure_def' hf,
end

lemma is_closable.closure_mono {f g : E →ₗ.[R] F} (hg : g.is_closable) (h : f ≤ g) :
  f.closure ≤ g.closure :=
begin
  refine le_of_le_graph _,
  rw ←(hg.le_is_closable h).graph_closure_eq_closure_graph,
  rw ←hg.graph_closure_eq_closure_graph,
  exact submodule.topological_closure_mono (le_graph_of_le h),
end

/-- If `f` is closable, then the closure is closed. -/
lemma is_closable.closure_is_closed {f : E →ₗ.[R] F} (hf : f.is_closable) :
  f.closure.is_closed :=
begin
  rw [is_closed, ←hf.graph_closure_eq_closure_graph],
  exact f.graph.is_closed_topological_closure,
end

/-- If `f` is closable, then the closure is closable. -/

lemma is_closable_iff_exists_closed_extension {f : E →ₗ.[R] F} : f.is_closable ↔
  ∃ (g : E →ₗ.[R] F) (hg : g.is_closed), f ≤ g :=
⟨λ h, ⟨f.closure, h.closure_is_closed, f.le_closure⟩, λ ⟨_, hg, h⟩, hg.is_closable.le_is_closable h⟩

/-! ### The core of a linear operator -/

/-- A submodule `S` is a core of `f` if the closure of the restriction of `f` to `S` is again `f`.-/
structure has_core (f : E →ₗ.[R] F) (S : submodule R E) : Prop :=
(le_domain : S ≤ f.domain)
(closure_eq : (f.dom_restrict S).closure = f)

lemma has_core_def {f : E →ₗ.[R] F} {S : submodule R E} (h : f.has_core S) :
(f.dom_restrict S).closure = f := h.2

/-- For every unbounded operator `f` the submodule `f.domain` is a core of its closure.

Note that we don't require that `f` is closable, due to the definition of the closure. -/
lemma closure_has_core (f : E →ₗ.[R] F) : f.closure.has_core f.domain :=
begin
  refine ⟨f.le_closure.1, _⟩,
  congr,
  ext,
  { simp only [dom_restrict_domain, submodule.mem_inf, and_iff_left_iff_imp],
    intro hx,
    exact f.le_closure.1 hx },
  intros x y hxy,
  let z : f.closure.domain := ⟨y.1, f.le_closure.1 y.2⟩,
  have hyz : (y : E) = z := by simp,
  rw f.le_closure.2 hyz,
  exact dom_restrict_apply (hxy.trans hyz),
end

end linear_pmap


import .love06_monads_demo

/- # LoVe Exercise 6: Monads -/

set_option pp.beta true
set_option pp.generalized_field_notation false

namespace LoVe

/- ## Question 1: A State Monad with Failure

We introduce a richer notion of lawful monad that provides an `orelse`
operator `<|>` satisfying some laws, given below. `emp` denotes failure.
`x <|> y` tries `x` first, falling back on `y` on failure. -/

@[class] structure lawful_monad_with_orelse (m : Type → Type)
  extends lawful_monad m, has_orelse m : Type 1 :=
(emp {} {α : Type} : m α)
(emp_orelse {α : Type} (a : m α) :
  (emp <|> a) = a)
(orelse_emp {α : Type} (a : m α) :
  (a <|> emp) = a)
(orelse_assoc {α : Type} (a b c : m α) :
  ((a <|> b) <|> c) = (a <|> (b <|> c)))
(emp_bind {α β : Type} (f : α → m β) :
  (emp >>= f) = emp)
(bind_emp {α β : Type} (f : m α) :
  (f >>= (λa, emp : α → m β)) = emp)

/- 1.1. We set up the `option` type constructor to be a
`lawful_monad_with_orelse`. Complete the proofs. -/

def option.orelse {α : Type} : option α → option α → option α
| option.none     ma' := ma'
| (option.some a) _   := option.some a

@[instance] def lawful_monad_with_orelse_option :
  lawful_monad_with_orelse option :=
{ emp          := λα, option.none,
  orelse       := @option.orelse,
  emp_orelse   :=
    begin
      intros α a,
      refl
    end,
  orelse_emp   :=
    begin
      intros α a,
      cases' a,
      { refl },
      { refl }
    end,
  orelse_assoc :=
    begin
      intros α a b c,
      cases' a,
      { refl },
      { refl }
    end,
  emp_bind     :=
    begin
      intros α β f,
      refl
    end,
  bind_emp     :=
    begin
      intros α β g,
      cases' g,
      { refl },
      { refl }
    end,
  .. option.lawful_monad }

@[simp] lemma option.some_bind {α β : Type} (a : α) (g : α → option β) :
  (option.some a >>= g) = g a :=
by refl

/- Let us enable some convenient pattern matching syntax, by instantiating
Lean's `monad_fail` type class. (Do not worry if you do not understand what
we are referring to.) -/

@[instance] def lawful_monad_with_orelse.monad_fail {m : Type → Type}
  [lawful_monad_with_orelse m] : monad_fail m :=
{ fail := λα msg, lawful_monad_with_orelse.emp }

/- Now we can write definitions such as the following: -/

def first_of_three {m : Type → Type} [lawful_monad_with_orelse m]
  (c : m (list ℕ)) : m ℕ :=
do
  [n, _, _] ← c,
  pure n

#eval first_of_three (option.some [1])
#eval first_of_three (option.some [1, 2, 3])
#eval first_of_three (option.some [1, 2, 3, 4])

/- Using `lawful_monad_with_orelse` and the `monad_fail` syntax, we can give a
concise definition for the `sum_2_5_7` function seen in the lecture. -/

def sum_2_5_7₇ {m : Type → Type} [lawful_monad_with_orelse m]
  (c : m (list ℕ)) : m ℕ :=
do
  (_ :: n2 :: _ :: _ :: n5 :: _ :: n7 :: _) ← c,
  pure (n2 + n5 + n7)

/- 1.2. Now we are ready to define `faction σ` ("eff action"): a monad with an
internal state of type `σ` that can fail (unlike `action σ`).

We start with defining `faction σ α`, where `σ` is the type of the internal
state, and `α` is the type of the value stored in the monad. We use `option` to
model failure. This means we can also use the monadic behavior of `option` when
defining the monadic operations on `faction`.

Hints:

* Remember that `faction σ α` is an alias for a function type, so you can use
  pattern matching and `λs, …` to define values of type `faction σ α`.

* `faction` is very similar to `action` from the lecture's demo. You can look
  there for inspiration. -/

def faction (σ : Type) (α : Type) :=
σ → option (α × σ)

/- 1.3. Define the `get` and `set` function for `faction`, where `get` returns
the state passed along the state monad and `set s` changes the state to `s`. -/

def get {σ : Type} : faction σ σ
| s := option.some (s, s)

def set {σ : Type} (s : σ) : faction σ unit
| _ := option.some ((), s)

/- We set up the `>>=` syntax on `faction`: -/

def faction.bind {σ α β : Type} (f : faction σ α) (g : α → faction σ β) :
  faction σ β
| s := f s >>= (λas, g (prod.fst as) (prod.snd as))

@[instance] def faction.has_bind {σ : Type} : has_bind (faction σ) :=
{ bind := @faction.bind σ }

lemma faction.bind_apply {σ α β : Type} (f : faction σ α) (g : α → faction σ β)
    (s : σ) :
  (f >>= g) s = (f s >>= (λas, g (prod.fst as) (prod.snd as))) :=
by refl

/- 1.4. Define the monadic operator `pure` for `faction`, in such a way that it
will satisfy the monad laws. -/

def faction.pure {σ α : Type} (a : α) : faction σ α
| s := option.some (a, s)

/- We set up the syntax for `pure` on `faction`: -/

@[instance] def faction.has_pure {σ : Type} : has_pure (faction σ) :=
{ pure := @faction.pure σ }

lemma faction.pure_apply {σ α : Type} (a : α) (s : σ) :
  (pure a : faction σ α) s = option.some (a, s) :=
by refl

/- 1.3. Register `faction` as a monad.

Hints:

* The `funext` lemma is useful when you need to prove equality between two
  functions.

* `cases' f s` only works when `f s` appears in your goal, so you may need to
  unfold some constants before you can invoke `cases'`. -/

@[instance] def faction.lawful_monad {σ : Type} : lawful_monad (faction σ) :=
{ pure_bind  :=
    begin
      intros α β a f,
      apply funext,
      intro s,
      refl
    end,
  bind_pure  :=
    begin
      intros α ma,
      apply funext,
      intro s,
      simp [faction.bind_apply, faction.pure_apply],
      apply lawful_monad.bind_pure
    end,
  bind_assoc :=
    begin
      intros α β γ f g ma,
      apply funext,
      intro s,
      simp [faction.bind_apply],
      cases' ma s,
      { refl },
      { cases' val,
        refl }
    end,
  .. faction.has_bind,
  .. faction.has_pure }

/- ## Question 2: Kleisli Operator

The Kleisli operator `>=>` (not to be confused with `>>=`) is useful for
pipelining monadic operations. Note that `λa, f a >>= g` is to be parsed as
`λa, (f a >>= g)`, not as `(λa, f a) >>= g`. -/

def kleisli {m : Type → Type} [lawful_monad m] {α β γ : Type} (f : α → m β)
  (g : β → m γ) : α → m γ :=
λa, f a >>= g

infixr ` >=> ` : 90 := kleisli

/- 2.1. Prove that `pure` is a left and right unit for the Kleisli operator. -/

lemma pure_kleisli {m : Type → Type} [lawful_monad m] {α β : Type}
    (f : α → m β) :
  (pure >=> f) = f :=
begin
  apply funext,
  intro a,
  exact lawful_monad.pure_bind a f
end

lemma kleisli_pure {m : Type → Type} [lawful_monad m] {α β : Type}
    (f : α → m β) :
  (f >=> pure) = f :=
begin
  apply funext,
  intro a,
  exact lawful_monad.bind_pure (f a)
end

/- 2.2. Prove associativity of the Kleisli operator. -/

lemma kleisli_assoc {m : Type → Type} [lawful_monad m] {α β γ δ : Type}
    (f : α → m β) (g : β → m γ) (h : γ → m δ) :
  ((f >=> g) >=> h) = (f >=> (g >=> h)) :=
begin
  apply funext,
  intro a,
  exact lawful_monad.bind_assoc g h (f a)
end

end LoVe


/-
Copyright (c) 2021 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/
import analysis.normed_space.basic

/-!
# The integers as normed ring

This file contains basic facts about the integers as normed ring.

Recall that `∥n∥` denotes the norm of `n` as real number.
This norm is always nonnegative, so we can bundle the norm together with this fact,
to obtain a term of type `nnreal` (the nonnegative real numbers).
The resulting nonnegative real number is denoted by `∥n∥₊`.
-/

open_locale big_operators

namespace int

lemma nnnorm_coe_units (e : ℤˣ) : ∥(e : ℤ)∥₊ = 1 :=
begin
  obtain (rfl|rfl) := int.units_eq_one_or e;
  simp only [units.coe_neg_one, units.coe_one, nnnorm_neg, nnnorm_one],
end

lemma norm_coe_units (e : ℤˣ) : ∥(e : ℤ)∥ = 1 :=
by rw [← coe_nnnorm, int.nnnorm_coe_units, nnreal.coe_one]

@[simp] lemma nnnorm_coe_nat (n : ℕ) : ∥(n : ℤ)∥₊ = n := real.nnnorm_coe_nat _

@[simp] lemma norm_coe_nat (n : ℕ) : ∥(n : ℤ)∥ = n := real.norm_coe_nat _

@[simp] lemma to_nat_add_to_nat_neg_eq_nnnorm (n : ℤ) : ↑(n.to_nat) + ↑((-n).to_nat) = ∥n∥₊ :=
by rw [← nat.cast_add, to_nat_add_to_nat_neg_eq_nat_abs, nnreal.coe_nat_abs]

@[simp] lemma to_nat_add_to_nat_neg_eq_norm (n : ℤ) : ↑(n.to_nat) + ↑((-n).to_nat) = ∥n∥ :=
by simpa only [nnreal.coe_nat_cast, nnreal.coe_add]
  using congr_arg (coe : _ → ℝ) (to_nat_add_to_nat_neg_eq_nnnorm n)

end int


import topology.homotopy.basic
import topology.constructions
import topology.homotopy.path
import category_theory.groupoid
import groupoid_products
import topology.homotopy.fundamental_groupoid
import topology.homotopy.product

noncomputable theory

namespace fundamental_groupoid

private abbreviation π := fundamental_groupoid_functor
universes u

section pi

variables {I : Type u} {X : I → Top.{u}}

/--
The projection map Π i, X i → X i induces a map π(Π i, X i) ⟶ π(X i).
-/
def proj (i : I) : (π.obj (Top.of (Π i, X i))).α ⥤ (π.obj (X i)).α := π.map ⟨_, continuous_apply i⟩

/-- The projection map is precisely path.homotopic.proj interpreted as a functor -/
@[simp] lemma proj_map (i : I) (x₀ x₁ : (π.obj (Top.of (Π i, X i))).α) (p : x₀ ⟶ x₁) :
  (proj i).map p = (@path.homotopic.proj _ _ _ _ _ i p) := rfl

/--
The map taking the pi product of a family of fundamental groupoids to the fundamental
groupoid of the pi product. This is actually an isomorphism (see `pi_fgrpd_iso_fgrpd_pi`)
-/
@[simps]
def pi_fgrpd_to_fgrpd_pi :
  (Π i, (π.obj (X i)).α) ⥤ (π.obj (Top.of (Π i, X i))).α :=
{ obj := λ g, g,
  map := λ v₁ v₂ p, path.homotopic.pi p,
  map_id' :=
  begin
    intro x,
    change path.homotopic.pi (λ i, 𝟙 (x i)) = _,
    simp only [id_eq_path_refl, path.homotopic.pi_lift],
    refl,
  end,
  map_comp' := λ x y z f g, (path.homotopic.comp_pi_eq_pi_comp f g).symm, }

/--
Shows `pi_fgrpd_to_fgrpd_pi` is an isomorphism, whose inverse is precisely the pi product
of the induced projections. This shows that `fundamental_groupoid_functor` preserves products.
-/
@[simps]
def pi_fgrpd_iso_fgrpd_pi :
  category_theory.Groupoid.of (Π i : I, (π.obj (X i)).α) ≅ (π.obj (Top.of (Π i, X i))) :=
{ hom := pi_fgrpd_to_fgrpd_pi,
  inv := category_theory.functor.pi' proj,
  hom_inv_id' :=
  begin
    change pi_fgrpd_to_fgrpd_pi ⋙ (category_theory.functor.pi' proj) = 𝟭 _,
    apply category_theory.functor.ext; intros,
    { ext, simp, }, { refl, },
  end,
  inv_hom_id' :=
  begin
    change (category_theory.functor.pi' proj) ⋙ pi_fgrpd_to_fgrpd_pi = 𝟭 _,
    apply category_theory.functor.ext; intros,
    { suffices : path.homotopic.pi ((category_theory.functor.pi' proj).map f) = f, { simpa, },
      change (category_theory.functor.pi' proj).map f
        with λ i, (category_theory.functor.pi' proj).map f i,
      simp, }, { refl, }
  end }

end pi

section prod

variables {A B : Top.{u}}

/-- The induced map of the left projection map X × Y → X -/
def proj_left : (π.obj (Top.of (A × B))).α ⥤ (π.obj A).α := π.map ⟨_, continuous_fst⟩

/-- The induced map of the right projection map X × Y → Y -/
def proj_right : (π.obj (Top.of (A × B))).α ⥤ (π.obj B).α := π.map ⟨_, continuous_snd⟩

@[simp] lemma proj_left_map (x₀ x₁ : (π.obj (Top.of (A × B))).α) (p : x₀ ⟶ x₁) :
  proj_left.map p = path.homotopic.proj_left p := rfl

@[simp] lemma proj_right_map (x₀ x₁ : (π.obj (Top.of (A × B))).α) (p : x₀ ⟶ x₁) :
  proj_right.map p = path.homotopic.proj_right p := rfl

/--
The map taking the product of two fundamental groupoids to the fundamental groupoid of the product
of the two topological spaces. This is in fact an isomorphism (see `prod_fgrpd_iso_fgrpd_prod`).
-/
@[simps]
def prod_fgrpd_to_fgrpd_prod : (π.obj A).α × (π.obj B).α ⥤ (π.obj (Top.of (A × B))).α :=
{ obj := λ g, g,
  map := λ x y p, match x, y, p with
    | (x₀, x₁), (y₀, y₁), (p₀, p₁) := path.homotopic.prod p₀ p₁
  end,
  map_id' :=
  begin
    rintro ⟨x₀, x₁⟩,
    simp only [category_theory.prod_id, id_eq_path_refl],
    unfold_aux, rw path.homotopic.prod_lift, refl,
  end,
  map_comp' := λ x y z f g, match x, y, z, f, g with
    | (x₀, x₁), (y₀, y₁), (z₀, z₁), (f₀, f₁), (g₀, g₁) :=
    (path.homotopic.comp_prod_eq_prod_comp f₀ f₁ g₀ g₁).symm
  end }

/--
Shows `prod_fgrpd_to_fgrpd_prod` is an isomorphism, whose inverse is precisely the product
of the induced left and right projections.
-/
@[simps]
def prod_fgrpd_iso_fgrpd_prod :
  category_theory.Groupoid.of ((π.obj A).α × (π.obj B).α) ≅ (π.obj (Top.of (A × B))) :=
{ hom := prod_fgrpd_to_fgrpd_prod,
  inv := proj_left.prod' proj_right,
  hom_inv_id' :=
  begin
    change prod_fgrpd_to_fgrpd_prod ⋙ (proj_left.prod' proj_right) = 𝟭 _,
    apply category_theory.functor.hext, { intros, ext; simp; refl, },
    rintros ⟨x₀, x₁⟩ ⟨y₀, y₁⟩ ⟨f₀, f₁⟩,
    have := and.intro (path.homotopic.proj_left_prod f₀ f₁) (path.homotopic.proj_right_prod f₀ f₁),
    simpa,
  end,
  inv_hom_id' :=
  begin
    change (proj_left.prod' proj_right) ⋙ prod_fgrpd_to_fgrpd_prod = 𝟭 _,
    apply category_theory.functor.hext, { intros, ext; simp; refl, },
    rintros ⟨x₀, x₁⟩ ⟨y₀, y₁⟩ f,
    have := path.homotopic.prod_proj_left_proj_right f,
    simpa,
  end }

end prod

end fundamental_groupoid