/-
Copyright (c) 2022 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import linear_algebra.pi
import algebra.category.Module.basic

/-!
# The concrete products in the category of modules are products in the categorical sense.
-/

open category_theory
open category_theory.limits

universes u v w

namespace Module
variables {R : Type u} [ring R]

variables {ι : Type v} (Z : ι → Module.{max v w} R)

/-- The product cone induced by the concrete product. -/
def product_cone : fan Z :=
fan.mk (Module.of R (Π i : ι, Z i)) (λ i, (linear_map.proj i : (Π i : ι, Z i) →ₗ[R] Z i))

/-- The concrete product cone is limiting. -/
def product_cone_is_limit : is_limit (product_cone Z) :=
{ lift := λ s, (linear_map.pi (λ j, s.π.app ⟨j⟩) : s.X →ₗ[R] (Π i : ι, Z i)),
  fac' := λ s j, by { cases j, tidy, },
  uniq' := λ s m w, by { ext x i, exact linear_map.congr_fun (w ⟨i⟩) x, }, }

-- While we could use this to construct a `has_products (Module R)` instance,
-- we already have `has_limits (Module R)` in `algebra.category.Module.limits`.

variables [has_product Z]

/--
The categorical product of a family of objects in `Module`
agrees with the usual module-theoretical product.
-/
noncomputable def pi_iso_pi :
  ∏ Z ≅ Module.of R (Π i, Z i) :=
limit.iso_limit_cone ⟨_, product_cone_is_limit Z⟩

-- We now show this isomorphism commutes with the inclusion of the kernel into the source.

@[simp, elementwise] lemma pi_iso_pi_inv_kernel_ι (i : ι) :
  (pi_iso_pi Z).inv ≫ pi.π Z i = (linear_map.proj i : (Π i : ι, Z i) →ₗ[R] Z i) :=
limit.iso_limit_cone_inv_π _ _

@[simp, elementwise] lemma pi_iso_pi_hom_ker_subtype (i : ι) :
  (pi_iso_pi Z).hom ≫ (linear_map.proj i : (Π i : ι, Z i) →ₗ[R] Z i) = pi.π Z i :=
is_limit.cone_point_unique_up_to_iso_inv_comp _ (limit.is_limit _) (discrete.mk i)

end Module


import ModelChecking.Chapter2

variable (t : TransSys)

-- Definition 3.3
structure StateGraph where
  E : Set (t.S × t.S)
  wfE : ∀ e ∈ E, e.2 ∈ t.post₂ e.1

namespace StateGraph

variable {t} (g : StateGraph t)

-- Definition 3.3
abbrev V (g : StateGraph t) := t.S

-- Definition 3.3
inductive reachable : g.V → g.V → Prop
  | rfl (s) : reachable s s
  | edge (s₁ s₂) : (s₁, s₂) ∈ g.E → reachable s₁ s₂
  | trans (s₁ s₂ s₃) : reachable s₁ s₂ → reachable s₂ s₃ → reachable s₁ s₃

-- Definition 3.3
def post₁ (s : g.V) : Set g.V := { s' | g.reachable s s' }

-- Definition 3.3
def post₂ (c : Set g.V) : Set g.V := { s' | ∃ s ∈ c, s' ∈ g.post₁ s }

-- Definition 3.3
def pre₁ (s : g.V) : Set g.V := { s' | g.reachable s' s }

-- Definition 3.3
def pre₂ (c : Set g.V) : Set g.V := { s' | ∃ s ∈ c, s' ∈ g.pre₁ s }

-- Page 95
theorem reach_of_ts_eq_post₂_I : t.reach = g.post₂ t.I := by
  simp only [TransSys.reach, TransSys.reachable, post₂, post₁]
  ext s
  apply Iff.intro
  case h.a.mp =>
    sorry
  case h.a.mpr =>
    intro h
    obtain ⟨v, ⟨hv, hs⟩⟩ := h
    have hs := Set.mem_set_of_eq.mp hs
    apply Set.mem_set_of_eq.mpr
    cases hs
    case rfl =>
      exists TransSys.ExecFragment.singleton t s
      exists TransSys.ExecFragment.singleton_finite t s
      exact ⟨hv, TransSys.ExecFragment.singleton_last t s⟩
    case edge => sorry
    case trans => sorry

end StateGraph


import .basic

namespace data.containers
namespace rbtree
section insert

parameters {E:Type _}
open color

-----------------------------------------------------------------------
-- defs.

section insert

def balanceL : color → rbtree E → E → rbtree E → rbtree E
| black (bin red (bin red lll llx llr) lx lr) x r := bin red (bin black lll llx llr) lx (bin black lr x r)
| black (bin red ll lx (bin red lrl lrx lrr)) x r := bin red (bin black ll lx lrl) lrx (bin black lrr x r)
| c l x r := bin c l x r

def balanceR : color → rbtree E → E → rbtree E → rbtree E
| black l x (bin red (bin red rll rlx rlr) rx rr) := bin red (bin black l x rll) rlx (bin black rlr rx rr)
| black l x (bin red rl rx (bin red rrl rrx rrr)) := bin red (bin black l x rl) rx (bin black rrl rrx rrr)
| color l x r := bin color l x r

parameters [has_preordering E]

def insert_core (y : E) : rbtree E → rbtree E
| empty := bin red empty y empty
| (bin color l x r) :=
  match has_ordering.cmp y x with
  | ordering.lt := balanceL color (insert_core l) x r
  | ordering.eq := bin color l y r
  | ordering.gt := balanceR color l x (insert_core r)
  end

def insert (y : E) (t : rbtree E) : rbtree E := set_black (insert_core y t)

end insert

-----------------------------------------------------------------------
-- to_list

section to_list_theorems

theorem to_list_balanceL (c : color) (l r : rbtree E) (x : E)
: to_list (balanceL c l x r)  = to_list l ++ [x] ++ to_list r :=
begin
  cases c,
  tactic.swap,
  cases l with lc ll lx lr;
  try {
    cases lc;
    cases ll with llc lll llx llr; try { cases llc };
    cases lr with lrc lrl lrx lrr; try { cases lrc },
  },
  all_goals { simp [balanceL, to_list, *], },
end

theorem to_list_balanceR (c : color) (l r : rbtree E) (x : E)
: to_list (balanceR c l x r)  = to_list l ++ [x] ++ to_list r :=
begin
  cases c,
  tactic.swap,
  cases r with rc rl rx rr;
  try {
    cases rc;
    cases rl with rlc rll rlx rlr; try { cases rlc };
    cases rr with rrc rrl rrx rrr; try { cases rrc },
  },
  all_goals { simp [balanceR, to_list, *], },
end

parameters [has_preordering E]

theorem to_list_insert_core (y : E) (t : rbtree E)
: is_ordered t
→ to_list (insert_core y t)
    = t.to_list.filter (key_is_lt y) ++ y :: t.to_list.filter (key_is_gt y) :=
begin
  induction t,
  case empty {
    simp [insert_core, to_list],
  },
  case bin color l x r l_ind r_ind {
    simp [insert_core, to_list, is_ordered, list.filter, key_is_lt, key_is_gt],

    have g1 : (ordering.gt ≠ ordering.lt), exact dec_trivial,
    have g2 : ordering.lt ≤ ordering.eq, exact dec_trivial,
    have g3 : ordering.eq ≤ ordering.eq, exact dec_trivial,
    have g4 : ordering.eq ≠ ordering.lt, exact dec_trivial,

    have cmp_k_key_eq : has_ordering.cmp x y = (has_ordering.cmp y x).swap,
    { rw [has_preordering.swap_cmp], },

    intros is_ordered_l is_ordered_r all_gt_r_x all_lt_l_x,
    have all_lt_r_key := all_lt_congr l x y,
    have all_gt_r_key := all_gt_congr r y x,
    have l_lt := filter_lt_of_all_lt l y,
    have l_gt := filter_gt_of_all_lt l y,
    have r_lt := filter_lt_of_all_gt r y,
    have r_gt := filter_gt_of_all_gt r y,

    destruct (has_ordering.cmp y x);
      intros cmp_key_k;
      simp [cmp_key_k, ordering.swap] at cmp_k_key_eq;
      simp [*, insert_core, to_list, to_list_balanceL, to_list_balanceR] at *,
  },
end

theorem to_list_insert (y : E) (t : rbtree E)
: is_ordered t → to_list (insert y t)
    = t.to_list.filter (key_is_lt y) ++ y :: t.to_list.filter (key_is_gt y) :=
begin
  intros,
  simp [insert, to_list_set_black, to_list_insert_core, *],
end

theorem insert_eq (y : E)
: ∀{t u : rbtree E},
   is_ordered t
   → is_ordered u
   → t.to_list = u.to_list
   → to_list (insert y t) = to_list (insert y t) :=
begin
  intros x y x_order y_order x_eq_y,
  simp [to_list_insert, *],
end

end to_list_theorems

-----------------------------------------------------------------------
-- is_ordered_insert

section is_ordered_theorems
parameters [has_preordering E]

def all_lt_balanceL (c : color) (y : E) (l r : rbtree E) (bnd : E)
  (all_lt_l : all_lt l y)
  (y_lt_bnd : has_ordering.cmp y bnd = ordering.lt)
  (all_lt_r : all_lt r bnd)
: all_lt (balanceL c l y r) bnd :=
begin
  cases c,
  tactic.swap,
  cases l with lc ll lx lr;
  try {
    cases lc;
    cases ll with llc lll llx llr; try { cases llc };
    cases lr with lrc lrl lrx lrr; try { cases lrc },
  },
  all_goals {
     try { simp [all_lt] at all_lt_l, },
     simp [balanceL, all_lt, *],
  },
  all_goals {
    apply has_preordering.lt_of_lt_of_lt _ y bnd _ y_lt_bnd,
    simp [*],
  },
end

def all_gt_balanceL (c : color) (y : E) (l r : rbtree E) (bnd : E)
  (iso : is_ordered l)
  (bnd_lt_y : has_ordering.cmp bnd y = ordering.lt)
  (all_gt_r : all_gt l bnd)
: all_gt (balanceL c l y r) bnd :=
begin
  cases c,
  tactic.swap,
  cases l with lc ll lx lr;
  try {
    cases lc;
    cases ll with llc lll llx llr; try { cases llc };
    cases lr with lrc lrl lrx lrr; try { cases lrc },
  },
  all_goals {
     try { simp [all_gt] at all_gt_r, },
     simp [balanceL, all_gt, *],
  },
  all_goals {
    simp [is_ordered, all_gt] at iso,
    apply has_preordering.lt_of_lt_of_lt bnd lx lrx; simp [*],
  },
end

def is_ordered_balanceL (c : color) (y : E) (l r : rbtree E)
  (iso_l : is_ordered l)
  (all_lt_l_y : all_lt l y)
  (all_gt_r_y : all_gt r y)
  (iso_r : is_ordered r)
: is_ordered (balanceL c l y r) :=
begin
  cases c,
  tactic.swap,
  cases l with lc ll lx lr;
  try {
    cases lc;
    cases ll with llc lll llx llr; try { cases llc };
    cases lr with lrc lrl lrx lrr; try { cases lrc },
  },
  all_goals {
    try { simp [is_ordered, all_lt, all_gt] at iso_l,},
    try { simp [all_lt] at all_lt_l_y, },
    simp [balanceL, all_lt, all_gt, is_ordered, *],
  },
end

def all_lt_balanceR (c : color) (y : E) (l r : rbtree E) (bnd : E)
  (iso : is_ordered r)
  (key_lt_u : has_ordering.cmp y bnd = ordering.lt)
  (all_lt_r : all_lt r bnd)
: all_lt (balanceR c l y r) bnd :=
begin
  cases c,
  tactic.swap,
  cases r with rc rl rx rr;
  try {
    cases rc;
    cases rl with rlc rll rlx rlr; try { cases rlc };
    cases rr with rrc rrl rrx rrr; try { cases rrc },
  },
  all_goals {
    try { simp [is_ordered, all_lt, all_gt] at iso, },
    try { simp [all_lt] at all_lt_r, },
    simp [balanceR, all_lt, *],
  },
  -- Remaining obligations have form:
  --  has_ordering.cmp rlx bnd = ordering.lt
  all_goals {
    apply has_preordering.lt_of_lt_of_lt rlx rx bnd; cc,
  },
end

def all_gt_balanceR (c : color) (y : E) (l r : rbtree E) (bnd : E)
  (iso : is_ordered r)
  (bnd_lt_y : has_ordering.cmp bnd y = ordering.lt)
  (all_gt_l : all_gt l bnd)
  (all_gt_r : all_gt r y)
: all_gt (balanceR c l y r) bnd :=
begin
  cases c,
  tactic.swap,
  cases r with rc rl rx rr;
  try {
    cases rc;
    cases rl with rlc rll rlx rlr; try { cases rlc };
    cases rr with rrc rrl rrx rrr; try { cases rrc },
  },

  all_goals {
    try { simp [is_ordered, all_lt, all_gt] at iso, },
    try { simp [all_gt] at all_gt_r, },
    simp [balanceR, all_gt, *],
  },
  all_goals {
    try { apply has_preordering.lt_of_lt_of_lt bnd y rx; cc, },
    try { apply has_preordering.lt_of_lt_of_lt bnd y rlx; cc, },
  },
end

def is_ordered_balanceR (c : color) (y : E) (l r : rbtree E)
  (iso_l : is_ordered l)
  (all_lt_l_y : all_lt l y)
  (all_gt_r_y : all_gt r y)
  (iso_r : is_ordered r)
: is_ordered (balanceR c l y r) :=
begin
  cases c,
  case red { simp [balanceR, is_ordered, *], },
  case black {
    cases r,
    case empty { simp [balanceR, is_ordered, *], },
    case bin lc ll lx lr {
      cases lc;
        cases ll with llc lll llx llr;
        try { cases llc };
        cases lr with lrc lrl lrx lrr;
        try { cases lrc },
      all_goals {
        simp [is_ordered, all_lt, all_gt] at iso_r,
        simp [all_gt] at all_gt_r_y,
        simp [balanceR, all_lt, all_gt, is_ordered, *],
      },
    },
  },
end

def insert_core_preserves (y : E) {t : rbtree E}
  (iso : is_ordered t)
: is_ordered (insert_core y t)
∧ (∀ (bnd : E),
    has_ordering.cmp y bnd = ordering.lt
               → all_lt t bnd
               → all_lt (insert_core y t) bnd)
∧ (∀ (bnd : E),
    has_ordering.cmp bnd y = ordering.lt
               → all_gt t bnd
               → all_gt (insert_core y t) bnd) :=
begin
  induction t,
  case empty {
    intros,
    simp [insert_core, all_lt, all_gt, is_ordered, *],
  },
  case bin c l x r l_ind r_ind {
    simp only [is_ordered] at iso,
    simp only [iso, true_implies_iff] at l_ind r_ind,
      destruct (has_ordering.cmp y x);
      intro cmp_y_s;
      simp only [cmp_y_s, insert_core, all_lt],
    { apply and.intro,
      { apply is_ordered_balanceL,
        apply and.left l_ind,
        apply and.left (and.right l_ind),
        all_goals { simp [*], },
      },
      apply and.intro,
      { intros bnd cmp_y_bnd pr,
        apply all_lt_balanceL,
        all_goals { simp [*], },
      },
      { intros bnd cmp_y_bnd pr,
        simp [all_gt] at pr,
        apply all_gt_balanceL,
        all_goals { simp [*], },
      }
    },
    { simp [is_ordered, *],
      apply and.intro,
      { apply all_gt_congr r y x; simp [*],
      },
      apply and.intro,
      { have h0 := has_preordering.eq_symm y x,
        apply all_lt_congr l x y; simp [*],
      },
      simp [all_gt],
      apply and.intro; cc,
    },
    { apply and.intro,
      { apply is_ordered_balanceR; try { cc, },
        { apply and.right (and.right r_ind);
            simp [has_preordering.gt_lt_symm, *] at *,
        },
      },
      apply and.intro,
      { intros,
        apply all_lt_balanceR; try { cc, },
        { apply and.left (and.right r_ind); cc, },
      },
      { simp [all_gt],
        intros,
        simp [has_preordering.gt_lt_symm, *] at *,
        apply all_gt_balanceR; try { cc },
        { apply and.left (and.right r_ind); cc, },
      },
    },
  },
end

theorem is_ordered_insert (y : E) (t : rbtree E)
: is_ordered t → is_ordered (insert y t) :=
begin
  intro iso,
  simp [insert],
  have h := insert_core_preserves y iso,
  cc,
end
end is_ordered_theorems

end insert
end rbtree
end data.containers


import data.real.basic

theorem IMO_Shortlist_A4_2001 (f : ℝ → ℝ) :
(∀ x y : ℝ, f(x^2 - y^2) = x*f(x) - y * f(y)) → ∃ l : ℝ, ∀ x  : ℝ, f(x) = l*x := sorry


import MyNat.Definition
import MyNat.Inequality -- le_iff_exists_add
import Mathlib.Tactic.Use -- use tactic
namespace MyNat
open MyNat
/-!

# Inequality world.

## Level 10: `le_succ_self`

Another simple one.

## Lemma : le_succ_self
For all naturals `a`, `a ≤ succ a.`
-/
lemma le_succ_self (a : MyNat) : a ≤ succ a := by
  use 1

/-!
Next up [Level 11](./Level11.lean.md)
-/


/-
Copyright (c) 2020 The Xena project. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Kevin Buzzard
Thanks: Imperial College London, leanprover-community
-/

-- Import levels 1 to 5
import complex.Level_05_field

 -- Import the theory polynomials in one variable over rings
import data.polynomial
/-!

# Level 6: The complex numbers are algebraically closed

-/

namespace complex

open polynomial

lemma exists_root {f : polynomial ℂ} (hf : 0 < degree f) :
  ∃ z : ℂ, is_root f z :=
begin
  sorry
end

end complex

/-
Chris Hughes, an undergraduate mathematician at Imperial College London, proved
this result in Lean and PR'ed it to Lean's maths library.

Here is the link to the docs
https://leanprover-community.github.io/mathlib_docs/analysis/complex/polynomial.html

and here is the code
https://github.com/leanprover-community/mathlib/blob/3710744/src/analysis/complex/polynomial.lean#L34
-/


/- LoVe Demo 11: Logical Foundations of Mathematics -/

import .love05_inductive_predicates_demo_master

namespace LoVe

set_option pp.beta true

/- Type Universes -/

#check @and.intro
#check ∀a b : Prop, a → b → a ∧ b
#check Prop
#check ℕ
#check Type
#check Type 1
#check Type 2
-- ...

universe variables u v

#check Type u

#check Sort 0
#check Sort 1
#check Sort 2
#check Sort u

#check Type*

/- Impredicativity -/

section impredicativity

variables (α : Type u) (β : Type v)

#check α → β

#check Πa : Type, a → a
#check ∀a : Prop, a → a

end impredicativity

/- Proof Irrelevance -/

#check proof_irrel

lemma proof_irrel {a : Prop} (h₁ h₂ : a) :
  h₁ = h₂ :=
by refl

/- Large Elimination -/

inductive square_roots (sq : ℤ) : Type u
| intro (z : ℤ) (h : sq = z * z) : square_roots
-- `square_roots sq` contains all square roots of a number `sq`.
-- * It is empty if `sq` is not square.
-- * It has one element if `sq = 0`.
-- * It has two elements if `sq > 0` is square.

def two_as_root : square_roots 4 :=
square_roots.intro 2 (by refl)

def neg_two_as_root : square_roots 4 :=
square_roots.intro (-2) (by refl)

def large_elim {sq : ℤ} {α : Sort v} :
  square_roots sq → (Π(z : ℤ) (h : sq = z * z), α) → α
| (square_roots.intro z h) f := f z h

#eval large_elim two_as_root (λz _, z)       -- result: 2
#eval large_elim neg_two_as_root (λz _, z)   -- result: -2

example :
  two_as_root ≠ neg_two_as_root :=
begin
  have hne : large_elim two_as_root (λz _, z)
      ≠ large_elim neg_two_as_root (λz _, z) :=
    by intro h; cases h,
  intro hr,
  apply hne,
  rw hr
end
-- Above, we could also have used `cases hr`.

example (sq : ℤ) (r : square_roots sq) :
  sq ≥ 0 :=
begin
  apply large_elim r,
  intros z hz,
  rw hz,
  apply mul_self_nonneg
end
-- Above, we could also have used `cases r`.

/- Small Elimination -/

inductive square_number (sq : ℤ) : Prop
| intro (z : ℤ) (h : sq = z * z) : square_number
-- only difference: `Prop` instead of `Type u`

lemma four_is_square :
  square_number 4 :=
square_number.intro 2 (by refl)

lemma four_is_square' :
  square_number 4 :=
square_number.intro (-2) (by refl)

example :
  four_is_square = four_is_square' :=
by apply proof_irrel
-- The "no confusion" principle does not hold for inductive predicates,
-- only for inductive types.

-- If we could define a large eliminator, this would lead to a contradiction.
def large_elim' {sq : ℤ} {α : Sort v} :
  square_number sq → (∀(z : ℤ) (h : sq = z * z), α) → α
| (square_number.intro z h) f := f z h
-- induction tactic failed, recursor
-- 'LoVe.square_number.dcases_on' can only eliminate into Prop

-- We cannot extract the information that `four_is_square` was
-- constructed using `2` and `four_is_square'` was constructed
-- using `-2`.

def small_elim {sq : ℤ} {α : Prop} :
  square_number sq → (∀(z : ℤ) (h : sq = z * z), α) → α
| (square_number.intro z h) f := f z h

-- It is called a small eliminator because it eliminates only
-- into `Prop`, whereas a large eliminator can eliminate into
-- an arbitrary large type universe `Sort v`.

example (sq : ℤ) (h : square_number sq) :
  sq ≥ 0 :=
begin
  apply small_elim h,
  intros z hz,
  rw hz,
  apply mul_self_nonneg
end

/- Axiom of Choice -/

#print nonempty

/-
inductive nonempty (α : Sort u) : Prop
| intro (val : α) : nonempty
-/

lemma nat.nonempty :
  nonempty ℕ :=
nonempty.intro 0

#print classical.choice

-- classical.choice is noncomputable:
#eval classical.choice nat.nonempty
#reduce classical.choice nat.nonempty

-- definitions using it need to be marked as noncomputable:
def some_natural_number :=
classical.choice nat.nonempty

noncomputable def some_natural_number' :=
classical.choice nat.nonempty

-- Law of excluded middle:

#check classical.em -- excluded middle
#check classical.by_contradiction

local attribute [instance, priority 0] classical.prop_decidable
-- This enables the tactic `by_cases` to be used on any proposition.

example (a : Prop) :
  a ∨ ¬ a :=
begin
  by_cases h : a,
  { exact or.intro_left (¬ a) h },
  { exact or.intro_right a h }
end
-- `by_cases` makes a case distinction on the truth of a proposition,
-- whereas `cases` makes a case distinction on an inductive predicate/datatype.

-- Hilbert choice: classical.some

variables (p : ℕ → Prop) (h : ∃n : ℕ, p n)

#check classical.some h
#check classical.some_spec h
-- In contrast to `cases` this can also be used in definitions.

-- Set-theoretic axiom of choice:

#check @classical.axiom_of_choice

example (x : list ℕ)
    (h : ∀y : list ℕ, ∃z : list ℕ, [0] ++ z = x ++ y) :
  x.head = 0 :=
begin
  choose z h using h,
  have hx : x = [0] ++ z [] :=
    by simp [h []],
  simp [hx]
end

/- Subtype Example: Full Binary Trees -/

#check btree
#check is_full
#check mirror
#check is_full_mirror
#check mirror_mirror

def full_btree (α : Type) : Type :=
{t : btree α // is_full t}

/- This is syntactic sugar for:
def full_btree (α : Type) :=
@subtype (btree α) is_full
-/

#check subtype

-- To define elements of this subtype,
-- we need to provide a btree and a proof that it is full:
def some_full_btree : full_btree ℕ :=
subtype.mk empty is_full.empty

#check subtype.mk

def another_full_btree : full_btree ℕ :=
subtype.mk (node 6 empty empty)
  begin
    apply is_full.node,
    apply is_full.empty,
    apply is_full.empty,
    refl
  end

#reduce subtype.val another_full_btree
  -- returns: node 6 empty empty

#check subtype.property another_full_btree
  -- returns: is_full (subtype.val another_full_btree)

def full_btree.mirror {α : Type} (t : full_btree α) :
  full_btree α :=
subtype.mk
  (mirror (subtype.val t))
  begin
    apply is_full_mirror,
    apply subtype.property t
  end

#reduce subtype.val (full_btree.mirror another_full_btree)

lemma full_btree.mirror_mirror {α : Type} (t : full_btree α) :
  (full_btree.mirror (full_btree.mirror t)) = t :=
begin
  apply subtype.eq,
  simp [full_btree.mirror],
  apply mirror_mirror
end

#check subtype.eq

/- Subtype Example: Vectors -/

#check vector
def vector (α : Type u) (n : ℕ) : Type u :=
{l : list α // l.length = n}

def some_vector : vector ℤ 3 :=
subtype.mk ([1, 2, 3]) (by refl)

def vector.neg {n : ℕ} (v : vector ℤ n) : vector ℤ n :=
subtype.mk (list.map int.neg (subtype.val v))
  begin rw list.length_map, exact subtype.property v end

lemma int.neg_comp_neg :
  int.neg ∘ int.neg = id :=
begin
  apply funext,
  apply neg_neg
end

lemma vector.neg_neg (n : ℕ) (v : vector ℤ n) :
  vector.neg (vector.neg v) = v :=
begin
  apply subtype.eq,
  simp [vector.neg],
  rw [int.neg_comp_neg, list.map_id]
end

/- Quotient Types -/

-- `quotient` for equivalence relations
#check quotient
#print setoid

def base : Type :=
sorry

def e : base → base → Prop :=
sorry

instance base.setoid : setoid base :=
{ r := e,
  iseqv := sorry }

def my_quotient : Type :=
quotient base.setoid

variables (a : base)

#check quotient.mk a
#check ⟦a⟧
#check @quotient.sound base base.setoid
#check @quotient.exact base base.setoid

variables (q q' : my_quotient) (β : Type) (f : base → β) (g : base → base → β)

#check quotient.lift f
#check quotient.lift₂ g
#check quotient.induction_on
#check quotient.induction_on₂
#check quotient.induction_on₃

/- Integers as a Quotient -/

/- Basic idea: `(p, n)` represents `p - n` -/

instance myℤ.rel : setoid (ℕ × ℕ) :=
{ r     := λa b, a.1 + b.2 = b.1 + a.2,
  iseqv :=
  begin
    apply and.intro,
    { intro a,
      refl },
    apply and.intro,
    { intros a b h,
      rw h },
    { intros a b c eq_ab eq_bc,
      apply eq_of_add_eq_add_right,
      calc  (a.1 + c.2) + b.2
		      = (a.1 + b.2) + c.2 :
        by ac_refl
      ... = a.2 + (b.1 + c.2) :
        by rw [eq_ab]; ac_refl
      ... = (c.1 + a.2) + b.2 :
        by rw [eq_bc]; ac_refl }
  end }

#print equivalence

def myℤ : Type :=
quotient myℤ.rel

lemma rel_iff (a b : ℕ × ℕ) :
  a ≈ b ↔ a.1 + b.2 = b.1 + a.2 :=
by refl

def zero : myℤ := ⟦(0, 0)⟧

example (n : ℕ) : zero = ⟦(n, n)⟧ :=
begin
  rw zero,
  apply quotient.sound,
  rw [rel_iff],
  simp
end

#check quotient.lift₂

def add : myℤ → myℤ → myℤ :=
quotient.lift₂
  (λa b : ℕ × ℕ, ⟦(a.1 + b.1, a.2 + b.2)⟧)
  begin
    intros a₁ b₁ a₂ b₂ ha hb,
    apply quotient.sound,
    rw [rel_iff] at ha hb ⊢,
    calc  (a₁.1 + b₁.1) + (a₂.2 + b₂.2)
        = (a₁.1 + a₂.2) + (b₁.1 + b₂.2) :
	  by ac_refl
    ... = (a₂.1 + a₁.2) + (b₂.1 + b₁.2) :
      by rw [ha, hb]
    ... = (a₂.1 + b₂.1) + (a₁.2 + b₁.2) :
	  by ac_refl
  end

lemma add_mk (ap an bp bn : ℕ) :
  add ⟦(ap, an)⟧ ⟦(bp, bn)⟧ = ⟦(ap + bp, an + bn)⟧ :=
by refl

lemma add_zero (i : myℤ) :
  add zero i = i :=
begin
  apply quotient.induction_on i,
  intro p,
  rw zero,
  cases p,
  rw add_mk,
  apply quotient.sound,
  simp
end

end LoVe


/- Author : Felix Weilacher -/
import measure_theory.constructions.polish

--Reference for everything in this file: Chapter 6 of Kechris

open topological_space
open set

section res

open list

parameter {α : Type*}

-- returns the first n entries of x as a list, but in reverse order.
-- this order works more naturally with the topology on ℕ → α
def res (x : ℕ → α) : ℕ → list α
  | 0 := nil
  | (nat.succ n) := (x n) :: res n

@[simp] theorem res_zero (x : ℕ → α) : res x 0 = @nil α := rfl
@[simp] theorem res_succ (x : ℕ → α) (n : ℕ) : res x n.succ = (x n) :: (res x n) := rfl

@[simp] theorem res_length (x : ℕ → α) (n : ℕ) : (res x n).length = n :=
begin
  induction n with n ih,
  { refl, },
  simp[ih],
end

-- The restrictions of x and y to n are equal if and only if their first n entries are equal
theorem res_eq_iff (x y : ℕ → α) (n : ℕ) : res x n = res y n ↔ ∀ m < n, x m = y m :=
begin
  split; intro h; induction n with n ih, { simp, },
  { intros m hm,
    rw nat.lt_succ_iff_lt_or_eq at hm,
    simp only [res_succ] at h,
    cases hm with hm hm,
    { apply ih h.2, assumption},
    rw hm,
    exact h.1, },
  { simp },
  { simp only [res_succ],
    split,
    { apply h,
      apply nat.lt_succ_self, },
    apply ih,
    intros m hm,
    apply h,
    apply nat.lt_succ_of_lt hm, }
end

-- Two infniite sequences are equal if and only if all their restrictions are.
theorem eq_iff_res_eq (x y : ℕ → α) : (∀ n, res x n = res y n) ↔ x = y :=
begin
  split; intro h,
  { ext n,
    specialize h n.succ,
    rw res_eq_iff at h,
    apply h,
    apply nat.lt_succ_self, },
  rw h,
  simp,
end

--relates res to the basic clopen sets pi_nat.cylinder
theorem cylinder_eq (x : ℕ → α) (n : ℕ) : pi_nat.cylinder x n = {y | res y n = res x n} :=
begin
  ext y, dsimp[pi_nat.cylinder],
  rw res_eq_iff,
end

theorem cylinder_open [topological_space α] [discrete_topology α] (x : ℕ → α) (n : ℕ) :
  is_open (pi_nat.cylinder x n) :=
begin
  --copy pasted from library
  rw pi_nat.cylinder_eq_pi,
  exact is_open_set_pi (finset.range n).finite_to_set (λ a ha, is_open_discrete _),
end

end res

section set_seq

open metric
open filter

/- The proof of Cantor-Bendixson we follow makes use a sequence of sets with the same order
(w.r.t. reverse inclusion) structure as 2^{<ω}.
This sort of thing is sometimes called a scheme.
Before definining schemes, we establish some basic definitions and theorems
for sequences of sets with order type ω-/
parameters {α : Type*} (A : ℕ → set α)

--The diameter of our sets goes to 0 as n → ∞
def seq_vanishing_diam [pseudo_metric_space α]: Prop := ∀ ε > 0,
  (∀ᶠ (n : ℕ) in at_top, bounded (A n) ∧ diam (A n) < ε)

--Our sequence is monotone w.r.t. ⊇
def seq_mono : Prop := ∀ n : ℕ, (A n.succ) ⊆ A n

--Our definition of monotone in terms of the successor matches the more natural one
theorem seq_mono_iff : seq_mono ↔ ∀ n m : ℕ, m ≥ n → A m ⊆ A n :=
begin
  split; intro h,
  { intros n m hnm,
    obtain ⟨k, rfl : m = n + k⟩ := le_iff_exists_add.mp hnm,
    clear hnm,
    induction k with k ih,
    { refl, },
    apply subset_trans _ ih,
      rw [nat.add_succ],
      apply subset_trans _ (h _),
      refl, },
  intros n,
  apply h n n.succ,
  exact nat.le_succ n,
end

--some basic unpacking of seq_vanishing_diam
theorem small_dist_of_vanishing_diam [pseudo_metric_space α]:
  seq_vanishing_diam → ∀ ε > 0, ∃ n : ℕ, ∀ x y ∈ (A n), dist x y < ε :=
begin
  intros H ε ε_pos,
  specialize H ε ε_pos,
  rw eventually_at_top at H,
  rcases H with ⟨N,hN⟩,
  use N,
  intros x hx y hy,
  specialize hN N (le_refl _),
  apply lt_of_le_of_lt _ hN.2,
  apply dist_le_diam_of_mem hN.1; assumption,
end

--the above theorem is an equivalence
theorem mono_vanishing_diam_iff [pseudo_metric_space α] (hmono : seq_mono) :
  seq_vanishing_diam ↔ ∀ ε > 0, ∃ n : ℕ, ∀ x y ∈ (A n), dist x y < ε :=
begin
  split, { exact small_dist_of_vanishing_diam, },
  intros h ε ε_pos,
  cases h (ε / 2) (by linarith) with N hN,
  rw eventually_at_top,
  use N,
  intros n hn,
  have : ∀ (x : α), x ∈ A n → ∀ (y : α), y ∈ A n → dist x y ≤ ε / 2,
  { intros x hx y hy,
    apply le_of_lt,
    rw seq_mono_iff at hmono,
    apply hN; apply hmono _ _ hn; assumption, },
  use ε / 2, {exact this},
  calc
  diam (A n) ≤ ε / 2 : by
  { apply diam_le_of_forall_dist_le, {linarith},
    exact this, }
  ... < ε : by linarith
end

--this strengthens monotonicity by requiring the closures of later sets to be contained in previous ones
def seq_closure_mono [topological_space α]: Prop := ∀ n : ℕ, closure (A n.succ) ⊆ A n

theorem seq_mono_of_seq_closure_mono [topological_space α] : seq_closure_mono → seq_mono :=
begin
  intros h n,
  apply subset_trans _ (h _),
  apply subset_closure,
end

--The intersection of a sequence with vanishing diameter and the
--"closure_mono" condition is a singleton if the space is complete.
theorem exists_unique_of_closure_mono_of_vanishing_diam [metric_space α] [complete_space α]
  (hnonempty : ∀ n, (A n).nonempty) (hmono : seq_closure_mono) (hdiam : seq_vanishing_diam) :
  exists_unique (λ x : α, ∀ n, x ∈ A n) :=
begin
  have Amono : ∀ n : ℕ, ∀ m ≥ n, A m ⊆ A n,
  { rw ← seq_mono_iff,
    exact seq_mono_of_seq_closure_mono hmono, },
  have hdist := small_dist_of_vanishing_diam hdiam,
  choose u hu using hnonempty,
  have : cauchy_seq u,
  { rw metric.cauchy_seq_iff',
    intros ε ε_pos,
    cases hdist ε ε_pos with N hN,
    use N,
    intros n hn,
    apply hN, { apply Amono _ _ hn, apply hu, },
    apply hu, },
  cases cauchy_seq_tendsto_of_complete this with x hx,
  have : ∀ n, x ∈ A n,
  { intros n,
    apply hmono,
    apply (is_closed_closure).mem_of_tendsto hx,
    rw eventually_at_top,
    use n.succ,
    intros m hm,
    apply subset_closure,
    apply Amono _ _ hm,
    apply hu, },
  use [x,this],
  dsimp,
  intros y hy,
  apply eq_of_forall_dist_le,
  intros ε ε_pos,
  cases hdist ε ε_pos with n hn,
  apply le_of_lt,
  rw dist_comm,
  apply hn, {apply this,}, apply hy,
end

end set_seq

--The aforementinoed notion of a scheme
def scheme (β α : Type*) := list β → set α

namespace scheme

open metric
open filter

variables {β α : Type*} (A : scheme β α)

def nonempty : Prop := ∀ s, (A s).nonempty

def branch (x : ℕ → β) : ℕ → set α := λ n, A (res x n)

def vanishing_diam [pseudo_metric_space α] : Prop :=
  ∀ x : (ℕ → β), seq_vanishing_diam (A.branch x)

--A typical way to establish that diameter is vanishing along all branches of a scheme
--is to know that it vanishes uniformly along each one.
theorem  vanishing_diam_of_vanishing_with_length [pseudo_metric_space α]
  (u : ℕ → ℝ) (hu : tendsto u at_top (nhds 0))
  (h : ∀ s : list β, ∀ b : β, bounded (A (b :: s)) ∧ diam (A (b :: s)) < u s.length) :
  A.vanishing_diam :=
begin
  intros x ε ε_pos,
  rw eventually_at_top,
  rw at_top_basis.tendsto_iff metric.nhds_basis_ball at hu,
  swap, {apply_instance},
  cases hu ε ε_pos with N hN,
  simp at hN,
  use N.succ, intros m hm,
  dsimp[branch],
  obtain ⟨m, rfl⟩ : ∃ n : ℕ, m = n.succ,
  { apply nat.exists_eq_succ_of_ne_zero,
    apply ne_of_gt,
    apply lt_of_lt_of_le _ hm,
    apply nat.succ_pos, },
  simp,
  split, {exact (h _ _).1},
  apply (h _ _).2.trans,
  simp,
  apply lt_of_abs_lt,
  apply hN,
  exact nat.le_of_succ_le_succ hm,
end

def disjoint : Prop := ∀ s : list β, ∀ {a b : β}, a ≠ b → disjoint (A (a :: s)) (A (b :: s))

def closure_mono [topological_space α] : Prop := ∀ s : list β, ∀ a : β,
  closure (A (a :: s)) ⊆ A s

--The scheme version of closure_mono yields the sequence version along each branch
theorem seq_closure_mono_branch_of_closure_mono [topological_space α] (h: closure_mono A) :
  ∀ x : ℕ → β, seq_closure_mono (A.branch x) :=
begin
  intros x n,
  simp[branch],
  apply h,
end

section map

/-The main purpose of a scheme list β → set α is to build a limiting map (ℕ → β) → α
This section proves an existence theorem for such maps,
and relates their properties to properties of the scheme.
Much will have to be added here, and probably the definition of a scheme_map generalized,
in order to carry out scheme-style proofs beyond Cantor-Bendixson,
but I think this section should be a good start.
-/
structure scheme_map {β α : Type*} (A : scheme β α) :=
  (map : (ℕ → β) → α)
  (mem : ∀ x : ℕ → β, ∀ n : ℕ, map x ∈ (A.branch x n))

--A scheme map exists if the scheme has nonempty sets, has vanishing diameter along each branch,
--and has the closure_mono condition
noncomputable
def map_from_closed_mono_and_vanishing_diam [metric_space α] [complete_space α]
  (hnonempty : A.nonempty) (hmono : A.closure_mono) (hdiam : A.vanishing_diam) : A.scheme_map :=
begin
  have := λ x, exists_unique_of_closure_mono_of_vanishing_diam (A.branch x) _ _ _,
  swap,
  { dsimp[branch],
    dsimp[nonempty] at hnonempty,
    intro n,
    apply hnonempty, }, swap,
  { apply seq_closure_mono_branch_of_closure_mono,
    assumption, }, swap,
  { apply hdiam, },
  choose f hf using this,
  constructor, swap,
  { exact f, },
  intros x,
  exact (hf _).1,
end

open function

--A scheme map is injective if the children of a given node are always pairwise disjoint
theorem map_inj_of_disjoint (f : scheme_map A) (hdisj : A.disjoint) : injective f.map :=
begin
  intros x y hxy,
  rw ← eq_iff_res_eq,
  intro n,
  induction n with n ih; simp,
  split,
  { have hx := f.mem x n.succ,
    have hy := f.mem y n.succ,
    dsimp [branch] at hx,
    dsimp [branch] at hy,
    rw [hxy,ih] at hx,
    by_contradiction,
    have := hdisj (res y n) h,
    rw set.disjoint_iff at this,
    apply this, swap, {exact f.map y},
    simp[hy,hx], },
  exact ih,
end

--to avoid conflict with metric.eventually_nhds_iff. Not sure if there is a better way
--to accomplish this
/- @[protected] lemma eventually_nhds_iff' {α : Type*} [topological_space α] {a : α} {p : α → Prop} :
  (∀ᶠ (x : α) in nhds a, p x) ↔ ∃ (t : set α), (∀ (x : α), x ∈ t → p x) ∧ is_open t ∧ a ∈ t :=
  eventually_nhds_iff -/

--A scheme map is continuous if diameter vanishes along each branch
theorem map_cts_of_vanishing_diam [pseudo_metric_space α] [topological_space β]
  [discrete_topology β] (f:scheme_map A) (hdiam : A.vanishing_diam) :
  continuous f.map :=
begin
  rw continuous_iff',
  intros x ε ε_pos,
  have := small_dist_of_vanishing_diam _ (hdiam x),
  cases this ε ε_pos with n hn,
  rw _root_.eventually_nhds_iff,
  use pi_nat.cylinder x n,
  split,
  { intros y hy,
    apply hn,
    { dsimp[branch],
      rw cylinder_eq at hy,
      dsimp at hy,
      rw ← hy,
      apply f.mem, },
    apply f.mem, }, split,
  { apply cylinder_open, },
  exact pi_nat.self_mem_cylinder x n,
end

end map

end scheme

variables {α : Type*}

/- A set in a topological space is called perfect if it is closed and has no isolated points
Some authors exclude the empty set from being counted as perfect.
This is often useful, and is a separate definition: perf_nonempty -/
def perfect [topological_space α ] (C : set α) : Prop :=
  is_closed C ∧ ∀ x ∈ C, ∀ U ∈ nhds x, ∃ y ∈ U ∩ C, y ≠ x

namespace perfect

variable [topological_space α]

-- The closure of the intersection of a perfect set and an open set is perfect
theorem perfect_of_open_inter {C : set α} (hC : perfect C) (U : set α) (hU : is_open U) :
  perfect (closure (U ∩ C)) :=
begin
  split, {
    exact is_closed_closure, },
  intros x hx V hV,
  have : x ∈ C,
  { rw ← hC.1.closure_eq,
    apply closure_mono _ hx,
    apply inter_subset_right, },
  rw mem_closure_iff_nhds at hx,
  specialize hx V hV,
  cases hx with z hz,
  by_cases z = x,
  { rw h at hz,
    have := hC.2 x hz.2.2 (V ∩ U) _,
    { rcases this with ⟨y,hy,ynex⟩,
      use y,
      split,
      { use hy.1.1,
        apply subset_closure,
        exact ⟨hy.1.2,hy.2⟩, },
    assumption, },
    apply filter.inter_mem hV,
    rw mem_nhds_iff,
    use[U,by refl, hU, hz.2.1], },
  use [z,hz.1],
  apply subset_closure,
  exact hz.2,
end

end perfect

def perf_nonempty [topological_space α] (C : set α) : Prop := set.nonempty C ∧ perfect C

namespace perf_nonempty

-- The closure of the intersection of a nonempty perfect set and an open set is nonempty perfect,
-- provided the open set is a neighborhood of some point in the perfect set
theorem perf_nonempty_of_open_nhd_inter [topological_space α] {C : set α}
  (hC : perf_nonempty C) (x : α) (xC : x ∈ C) (U : set α) (xU : x ∈ U) (Uop : is_open U) : perf_nonempty (closure (U ∩ C)) :=
begin
  split,
  { use x,
    apply subset_closure,
    exact ⟨xU,xC⟩, },
  apply hC.2.perfect_of_open_inter,
  assumption,
end

open metric

section splitting

/- This section provides the inductive step in the construction of a scheme list bool → α,
where α is a metric space, of perfect nonempty sets, satisfying
the disjointness, closure_mono, and vanishing diameter conditions.
If α is complete, then by the results in the scheme_map section,
this will yield an injective continuous function from (ℕ → bool) to α.
-/

lemma splitting_aux [metric_space α] {C : set α} (hC : perf_nonempty C)
  (x : α) (xC : x ∈ C) (δ : ℝ) (δ_pos : δ > 0) : perf_nonempty (closure ((ball x δ) ∩ C)) ∧
  bounded (closure ((ball x δ) ∩ C)) ∧ ( diam (closure ((ball x δ) ∩ C)) ≤ 2 * δ) ∧
  ((closure ((ball x δ) ∩ C) ⊆ C)) :=
begin
  split,
  { apply hC.perf_nonempty_of_open_nhd_inter x xC,
    { apply mem_ball_self δ_pos, },
    apply is_open_ball, },
  split,
  { rw bounded_closure_iff,
    apply metric.bounded.mono, { apply inter_subset_left, },
    exact bounded_ball, },
  split,
  { rw diam_closure,
    apply le_trans (diam_mono (inter_subset_left _ C) bounded_ball),
    apply diam_ball,
    linarith, },
  rw hC.2.1.closure_subset_iff,
  apply inter_subset_right,
end

-- The inductive step: we need to "split" a nonempty perfect set into
-- two disjoint nonempty perfect subsets with small diameters.
lemma splitting [metric_space α] {C : set α} (hC : perf_nonempty C) (ε : ℝ) (ε_pos : ε > 0) :
  ∃ C₀ C₁ : set α, (perf_nonempty C₀ ∧ bounded C₀ ∧ diam C₀ < ε ∧ C₀ ⊆ C) ∧
  (perf_nonempty C₁ ∧ bounded C₁ ∧ diam C₁ < ε ∧ C₁ ⊆ C) ∧ disjoint C₀ C₁ :=
begin
  cases hC.1 with x xC,
  rcases hC.2.2 x xC univ _ with ⟨y,hy,ynex⟩,
  swap,
  { exact filter.univ_mem },
  cases hy with dum yC,
  clear dum,
  let δ := (min (ε) (dist x y)) / 3,
  have δ_pos : δ > 0,
  { apply div_pos,
    rw lt_min_iff,
    split,
    { linarith, },
    rw dist_pos,
    exact ne_comm.mp ynex,
    norm_num, },
  let U₀ := ball x δ,
  let U₁ := ball y δ,
  let C₀ := closure (U₀ ∩ C),
  let C₁ := closure (U₁ ∩ C),
  use [C₀,C₁],
  split,
  { obtain ⟨h1,h2,h3,h4⟩ := hC.splitting_aux x xC δ δ_pos,
    refine ⟨h1,h2,_,h4⟩,
    apply lt_of_le_of_lt h3,
    dsimp[δ],
    linarith[min_le_left ε (dist x y)], }, split,
  { obtain ⟨h1,h2,h3,h4⟩ := hC.splitting_aux y yC δ δ_pos,
    refine ⟨h1,h2,_,h4⟩,
    apply lt_of_le_of_lt h3,
    dsimp[δ],
    linarith[min_le_left ε (dist x y)], },
  rw [set.disjoint_iff],
  rintros z ⟨hzx,hzy⟩,
  have hzx' : dist z x ≤ δ,
  { rw ← mem_closed_ball,
    apply closure_ball_subset_closed_ball,
    apply closure_mono _ hzx,
    apply inter_subset_left, },
  have hzy' : dist z y ≤ δ,
  { rw ← mem_closed_ball,
    apply closure_ball_subset_closed_ball,
    apply closure_mono _ hzy,
    apply inter_subset_left, },
  rw dist_comm at hzx',
  have := dist_triangle x z y,
  have : dist x y ≤ 2 * δ := by linarith,
  have : δ ≤ (dist x y / 3),
  { apply div_le_div dist_nonneg,
    { apply min_le_right, },
    norm_num,
    refl, },
  linarith,
end

end splitting

end perf_nonempty

open function

--Any nonempty perfect subset of a complete metric space contains a homeomorphic image of
--the Cantor space ℕ → bool.
theorem cantor_of_perf_nonempty [metric_space α] [complete_space α] {C : set α}
  (hC : perf_nonempty C) : ∃ f : (ℕ → bool) → α,
  (range f) ⊆ C ∧ continuous f ∧ injective f:=
begin
  let P := subtype (λ E : set α, perf_nonempty E),
  choose C0 C1 h0 h1 hdisj using @perf_nonempty.splitting α infer_instance,
  let DP : (list bool → P) := begin
    intro s,
    induction s with a s Ds,
    { exact ⟨C,hC⟩, },
    cases a,
    { use C0 Ds.2 (1/2^s.length:ℝ) (by simp),
      exact (h0 _ _ _).1, },
    use C1 Ds.2 (1/2^s.length:ℝ)  (by simp),
    exact (h1 _ _ _).1,
  end,
  let D : scheme bool α := λ s, (DP s).1,
  have Dperf : ∀ s, perf_nonempty (D s),
  { intro s,
    exact (DP s).2, },
  have Dclosed : ∀ s, is_closed (D s) := λ s, (Dperf s).2.1,
  have Dnonempty : D.nonempty := λ s, (Dperf s).1,
  have Dmono : D.closure_mono,
  { intros s a,
    rw (Dclosed (a :: s)).closure_eq,
    cases a; dsimp[D],
    exact (h0 _ _ _).2.2.2,
    exact (h1 _ _ _).2.2.2, },
  have Ddiam : D.vanishing_diam,
  { apply D.vanishing_diam_of_vanishing_with_length (λ n, 1/2^n) _,
    { intros s a,
      cases a; dsimp[D],
      exact ⟨(h0 _ _ _).2.1,(h0 _ _ _).2.2.1⟩,
      exact ⟨(h1 _ _ _).2.1,(h1 _ _ _).2.2.1⟩, },
    simp only [← one_div_pow],
    apply tendsto_pow_at_top_nhds_0_of_lt_1; norm_num, },
  have f := D.map_from_closed_mono_and_vanishing_diam Dnonempty Dmono Ddiam,
  use f.map, split,
  { rintros y ⟨x, rfl⟩,
    exact f.mem x 0, },
  split, { exact D.map_cts_of_vanishing_diam f Ddiam, },
  apply D.map_inj_of_disjoint,
  intros s a b aneb,
  cases b,
  { rw bool.eq_tt_of_ne_ff aneb,
    dsimp[D],
    apply disjoint.symm _ ,
    apply hdisj, },
  rw bool.eq_ff_of_ne_tt aneb,
  dsimp[D],
  apply hdisj,
end

section kernel

variable [topological_space α]

/- Any closed subset of a second countable space can be written as
the union of a perfect set and a countable set.
The perfect set is sometimes called the ``perfect kernel'' of the closed set.
This result is sometimes called ``The Cantor-Bendixson Theorem''.
In fact this conclusion can easily be strengthened in a number of ways which we do not need:
V is open, V and D are disjoint, and this decomposition is the unique one with these properties.-/
theorem ctble_union_perfect_of_closed [second_countable_topology α] {C : set α} (hclosed : is_closed C) :
∃ V D : set α, (V.countable) ∧ (perfect D) ∧ (C = V ∪ D) :=
begin
  have := topological_space.exists_countable_basis α,
  rcases this with ⟨b,bct,bnontrivial,bbasis⟩,
  let v := {U ∈ b | (U ∩ C).countable},
  let V := ⋃ U ∈ v, U,
  let D := C ∩ Vᶜ, --C \ V did not work
  have Vct : (V ∩ C).countable, {
    simp[V,Union_inter],
    apply set.countable.bUnion,
    { apply @set.countable.mono _ _ b,
      { apply set.inter_subset_left, },
      exact bct, },
    apply set.inter_subset_right, },
  use [V ∩ C,D],
  split, swap, split, split,
  { apply is_closed.inter hclosed,
    rw is_closed_compl_iff,
    apply is_open_bUnion,
    rintros U ⟨Ub,-⟩,
    exact is_topological_basis.is_open bbasis Ub, },
  { intros x xD E xE,
    have : ¬ (E ∩ D).countable,
    { intro h,
      obtain ⟨U,hUb,xU,hU⟩ : ∃ U ∈ b, x ∈ U ∧ U ⊆ E,
      { exact (is_topological_basis.mem_nhds_iff bbasis).mp xE, },
      have : U ∈ v,
      { use hUb,
        dsimp,
        apply @countable.mono _ _ ((E ∩ D) ∪ (V ∩ C)),
        { rintros y ⟨yU,yC⟩,
          by_cases y ∈ V,
          { right,
            exact ⟨h,yC⟩, },
          left,
          split,
          { exact hU yU, },
          exact ⟨yC, h⟩, },
        apply countable.union h Vct, },
      apply xD.2,
      exact mem_bUnion this xU, },
    by_contradiction,
    push_neg at h,
    apply this,
    have : E ∩ D ⊆ {x}, {exact h},
    apply countable.mono this,
    apply set.countable_singleton, },
  { dsimp[D],
    rw[inter_comm,inter_union_compl], },
  assumption,
end

-- If the closed set in the previous theorem is uncountable, the kernel must be nonempty perfect
theorem perf_nonempty_of_closed_unctble [second_countable_topology α] {C : set α}
  (hclosed : is_closed C) (hunc : ¬ C.countable) : ∃ D : set α, (perf_nonempty D) ∧ (D ⊆ C) :=
begin
  rcases ctble_union_perfect_of_closed hclosed with ⟨V,D,Vct,Dperf,VD⟩,
  use D,
  split,
  { split,
    { rw ← ne_empty_iff_nonempty,
      by_contradiction,
      rw [h, union_empty] at VD,
      rw VD at hunc,
      contradiction, },
    exact Dperf, },
  rw VD,
  apply subset_union_right,
end

/- This combines the above version of Cantor-Bendixson with cantor_of_perf_nonempty.
This result itself is sometimes called ``The Cantor-Bendixson Theorem"-/
theorem cantor_of_closed_unc [polish_space α] {C : set α}
  (hclosed : is_closed C) (hunc : ¬ C.countable) :
  ∃ f : (ℕ → bool) → α, (range f) ⊆ C ∧ continuous f ∧ function.injective f :=
begin
  letI := upgrade_polish_space α,
  rcases perf_nonempty_of_closed_unctble hclosed hunc with ⟨D, Dperf, DC⟩,
  rcases cantor_of_perf_nonempty Dperf with ⟨f,hf⟩,
  use f,
  simp[hf],
  exact hf.1.trans DC,
end

end kernel


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Johannes Hölzl
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.equiv.list
import Mathlib.data.set.finite
import Mathlib.PostPort

universes u v u_1

namespace Mathlib

/-!
# Countable sets
-/

namespace set

/-- A set is countable if there exists an encoding of the set into the natural numbers.
An encoding is an injection with a partial inverse, which can be viewed as a
constructive analogue of countability. (For the most part, theorems about
`countable` will be classical and `encodable` will be constructive.)
-/
def countable {α : Type u} (s : set α) :=
  Nonempty (encodable ↥s)

theorem countable_iff_exists_injective {α : Type u} {s : set α} : countable s ↔ ∃ (f : ↥s → ℕ), function.injective f := sorry

/-- A set `s : set α` is countable if and only if there exists a function `α → ℕ` injective
on `s`. -/
theorem countable_iff_exists_inj_on {α : Type u} {s : set α} : countable s ↔ ∃ (f : α → ℕ), inj_on f s := sorry

theorem countable_iff_exists_surjective {α : Type u} [ne : Nonempty α] {s : set α} : countable s ↔ ∃ (f : ℕ → α), s ⊆ range f := sorry

/--
A non-empty set is countable iff there exists a surjection from the
natural numbers onto the subtype induced by the set.
-/
theorem countable_iff_exists_surjective_to_subtype {α : Type u} {s : set α} (hs : set.nonempty s) : countable s ↔ ∃ (f : ℕ → ↥s), function.surjective f := sorry

/-- Convert `countable s` to `encodable s` (noncomputable). -/
def countable.to_encodable {α : Type u} {s : set α} : countable s → encodable ↥s :=
  Classical.choice

theorem countable_encodable' {α : Type u} (s : set α) [H : encodable ↥s] : countable s :=
  Nonempty.intro H

theorem countable_encodable {α : Type u} [encodable α] (s : set α) : countable s :=
  Nonempty.intro encodable.subtype

/-- If `s : set α` is a nonempty countable set, then there exists a map
`f : ℕ → α` such that `s = range f`. -/
theorem countable.exists_surjective {α : Type u} {s : set α} (hc : countable s) (hs : set.nonempty s) : ∃ (f : ℕ → α), s = range f := sorry

@[simp] theorem countable_empty {α : Type u} : countable ∅ :=
  Nonempty.intro
    (encodable.mk (fun (x : ↥∅) => false.elim (subtype.property x)) (fun (n : ℕ) => none)
      fun (x : ↥∅) => false.elim (subtype.property x))

@[simp] theorem countable_singleton {α : Type u} (a : α) : countable (singleton a) :=
  Nonempty.intro (encodable.of_equiv PUnit (equiv.set.singleton a))

theorem countable.mono {α : Type u} {s₁ : set α} {s₂ : set α} (h : s₁ ⊆ s₂) : countable s₂ → countable s₁ := sorry

theorem countable.image {α : Type u} {β : Type v} {s : set α} (hs : countable s) (f : α → β) : countable (f '' s) := sorry

theorem countable_range {α : Type u} {β : Type v} [encodable α] (f : α → β) : countable (range f) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (countable (range f))) (Eq.symm image_univ)))
    (countable.image (countable_encodable univ) f)

theorem exists_seq_supr_eq_top_iff_countable {α : Type u} [complete_lattice α] {p : α → Prop} (h : ∃ (x : α), p x) : (∃ (s : ℕ → α), (∀ (n : ℕ), p (s n)) ∧ (supr fun (n : ℕ) => s n) = ⊤) ↔
  ∃ (S : set α), countable S ∧ (∀ (s : α), s ∈ S → p s) ∧ Sup S = ⊤ := sorry

theorem exists_seq_cover_iff_countable {α : Type u} {p : set α → Prop} (h : ∃ (s : set α), p s) : (∃ (s : ℕ → set α), (∀ (n : ℕ), p (s n)) ∧ (Union fun (n : ℕ) => s n) = univ) ↔
  ∃ (S : set (set α)), countable S ∧ (∀ (s : set α), s ∈ S → p s) ∧ ⋃₀S = univ :=
  exists_seq_supr_eq_top_iff_countable h

theorem countable_of_injective_of_countable_image {α : Type u} {β : Type v} {s : set α} {f : α → β} (hf : inj_on f s) (hs : countable (f '' s)) : countable s := sorry

theorem countable_Union {α : Type u} {β : Type v} {t : α → set β} [encodable α] (ht : ∀ (a : α), countable (t a)) : countable (Union fun (a : α) => t a) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (countable (Union fun (a : α) => t a))) (Union_eq_range_sigma fun (a : α) => t a)))
    (countable_range fun (a : sigma fun (i : α) => ↥(t i)) => ↑(sigma.snd a))

theorem countable.bUnion {α : Type u} {β : Type v} {s : set α} {t : (x : α) → x ∈ s → set β} (hs : countable s) (ht : ∀ (a : α) (H : a ∈ s), countable (t a H)) : countable (Union fun (a : α) => Union fun (H : a ∈ s) => t a H) := sorry

theorem countable.sUnion {α : Type u} {s : set (set α)} (hs : countable s) (h : ∀ (a : set α), a ∈ s → countable a) : countable (⋃₀s) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (countable (⋃₀s))) sUnion_eq_bUnion)) (countable.bUnion hs h)

theorem countable_Union_Prop {β : Type v} {p : Prop} {t : p → set β} (ht : ∀ (h : p), countable (t h)) : countable (Union fun (h : p) => t h) := sorry

theorem countable.union {α : Type u} {s₁ : set α} {s₂ : set α} (h₁ : countable s₁) (h₂ : countable s₂) : countable (s₁ ∪ s₂) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (countable (s₁ ∪ s₂))) union_eq_Union))
    (countable_Union (iff.mpr bool.forall_bool { left := h₂, right := h₁ }))

theorem countable.insert {α : Type u} {s : set α} (a : α) (h : countable s) : countable (insert a s) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (countable (insert a s))) (insert_eq a s))) (countable.union (countable_singleton a) h)

theorem finite.countable {α : Type u} {s : set α} : finite s → countable s := sorry

/-- The set of finite subsets of a countable set is countable. -/
theorem countable_set_of_finite_subset {α : Type u} {s : set α} : countable s → countable (set_of fun (t : set α) => finite t ∧ t ⊆ s) := sorry

theorem countable_pi {α : Type u} {π : α → Type u_1} [fintype α] {s : (a : α) → set (π a)} (hs : ∀ (a : α), countable (s a)) : countable (set_of fun (f : (a : α) → π a) => ∀ (a : α), f a ∈ s a) := sorry

theorem countable_prod {α : Type u} {β : Type v} {s : set α} {t : set β} (hs : countable s) (ht : countable t) : countable (set.prod s t) := sorry

/-- Enumerate elements in a countable set.-/
def enumerate_countable {α : Type u} {s : set α} (h : countable s) (default : α) : ℕ → α :=
  fun (n : ℕ) => sorry

theorem subset_range_enumerate {α : Type u} {s : set α} (h : countable s) (default : α) : s ⊆ range (enumerate_countable h default) := sorry

end set

theorem finset.countable_to_set {α : Type u} (s : finset α) : set.countable ↑s :=
  set.finite.countable (finset.finite_to_set s)


import tactic --imports extra tactics from mathlib (good to import by default)

------------------------------------------------------------------------------------------
--Check mathlib is working

import topology.basic

#check topological_space

------------------------------------------------------------------------------------------
--Establishing equality of terms inside a match block

--https://leanprover.zulipchat.com/#narrow/stream/113488-general/topic/match.20hypothesis

example (b : bool) : {x : bool // x = tt} :=
match b with
| tt := ⟨tt, rfl⟩ --we want to be able to use some "h : b = tt" here, but we can't :(
| ff := ⟨tt, rfl⟩
end

-- "{x : bool // x = tt}" is subtype of bool with values that satisfy predicate "= tt"
-- details on subtype here: https://leanprover.github.io/theorem_proving_in_lean/inductive_types.html

--so we can use tactics
example (b : bool) : {x : bool // x = tt} :=
begin
  cases h : b with x y,
  exact ⟨tt, rfl⟩,
  exact ⟨b, h⟩ --now we can use our "h : b = tt"
end

--or we can use a (clever) explicit motive to "rec.on" for the relevant type
example (b : bool) : {x : bool // x = tt} := --inital
bool.rec_on
  b
  ⟨tt, rfl⟩
  ⟨tt, rfl⟩

example (b : bool) : {x : bool // x = tt} := --use explicit motive
@bool.rec_on
  (λ b', {x : bool // x = tt})
  b
  ⟨tt, rfl⟩
  ⟨tt, rfl⟩

example (b : bool) : {x : bool // x = tt} := --add "b = b' →" to beginning of motive and feed "rfl" in at the end
(
  @bool.rec_on
    (λ b', b = b' → {x : bool // x = tt})
    b
    (λ h, ⟨tt, rfl⟩)
    (λ h, ⟨b, h⟩) --now we can use our "h : b = tt"
) rfl

------------------------------------------------------------------------------------------
--Various dependent pair types

#check @Exists  --produces Prop
#check @psigma  --produces Type*
#check @subtype --psigma with                   Sort u_2 = Prop
#check @sigma   --psigma with Sort u_1 = Type*, Sort u_2 = Type*

universes u v
structure psigma' {α : Sort u} (β : α → Sort v) : Sort (max u v) :=
mk :: (fst : α) (snd : β fst)

--psigma' above is disallowed because lean needs to know statically whether something will
--return a Prop or a Type* (i.e. this cannot depend dynamically on the values passed in)

------------------------------------------------------------------------------------------
--Well founded recursion: https://leanprover-community.github.io/extras/well_founded_recursion.html

--For inductive types, there is a default-implemented function sizeof
--which will return the total number of constructors used in a given value of this type
#check @sizeof --Π {α : Sort u_1} [s : has_sizeof α], α → ℕ

--This is the type used by the well-founded recursion checker

--Essentially, at each recursive call site, Lean needs to establish that
--t'.sizeof < t.sizeof where t' is the term at the recursive site and t is the original term
--If it can't do this, you must explicitly provide this as a hypothesis using "have h : t'.sizeof < t.sizeof := ..."
--Alternatively, you can produce a different function from your inductive type to the natural numbers
--f : t → ℕ
--and use the following tactic at the very end of your recursive function:
--using_well_founded {rel_tac := λ _ _, `[exact ⟨_, measure_wf f⟩]}

------------------------------------------------------------------------------------------
--Various congruence theorems/definitions

--generic congruence of equality with function application
--can be used to specify congr_arg, congr_fun and congr_arg2 etc...
#check @congr                --f₁ = f₂ → a₁ = a₂ → f₁ a₁ = f₂ a₂

--these two are converses
#check @congr_fun            --f₁ = f₂ → (∀ (a : α), f₁ a = f₂ a)
#check @funext               --(∀ (a : α), f₁ a = f₂ a) → f₁ = f₂

--these two are converses (note that injective is only a property of *some* functions)
#check @congr_arg            --a₁ = a₂ → f a₁ = f a₂
#reduce @function.injective  --f a₁ = f a₂ → a₁ = a₂

--congruence of equality with a binary function's arguments
#check @congr_arg2           --a₁ = a₃ → a₂ = a₄ → f a₁ a₂ = f a₃ a₄

------------------------------------------------------------------------------------------
--Axioms: https://leanprover.github.io/theorem_proving_in_lean/axioms_and_computation.html

#print axioms       --asks what axioms are available generally
#print axioms congr --asks what axioms are used in given expression

--Core Axioms:
#check @propext           -- (a ↔ b) → a = b
#check @quot.sound        -- r a b → quot.mk r a = quot.mk r b
#check @classical.choice  -- nonempty α → α

--Derived "Axioms":
#check @funext            -- (∀ (x : α), f₁ x = f₂ x) → f₁ = f₂    --provable via quot.sound
#check @em                -- ∀ (p : Prop), p ∨ ¬p                  --provable via propext, funext and classical.choice

--Quotient Constants:
#check @quot      --quotient type constructor
#check @quot.mk   --quotient data constructor
#check @quot.ind  --essentially states there are no empty equivalence classes in "quot r"
#check @quot.lift --lifts a function (f : α → β) to (f' : quot r → β)

/-
"The four constants, quot, quot.mk, quot.ind, and quot.lift in and of themselves are not very strong.
They are, like inductively defined types and the associated constructors and recursors,
viewed as part of the logical framework."
-/

------------------------------------------------------------------------------------------
--Inductive Types

--Constructors for Inductive types are injective and their domains are disjoint
--This generates smallest possible equality on Inductive types, by default
--Equality can then be exteneded using quotients

inductive ex
| fromNat : ℕ → ex
| fromBool : bool → ex

#check @ex.fromNat.inj  --ex.fromNat n₁ = ex.fromNat n₂ → n₁ = n₂
#check @ex.fromBool.inj --ex.fromNat b₁ = ex.fromNat b₂ → b₁ = b₂

------------------------------------------------------------------------------------------
--Initial and Terminal types for Prop and Type

#check unit    --Terminal Type
#check ()      --value of unit
#check empty   --Initial Type
#check @empty.elim

#check true    --Terminal Prop
#check true.intro
#check trivial --value of true
#check false   --Initial Prop
#check @false.elim

------------------------------------------------------------------------------------------
--Tactics

--Use "induction" tactic instead of "cases" when you need to recursively call a theorem/function
--or use the "equation compiler" by doing ordinary pattern matching outside of a tactic block

------------------------------------------------------------------------------------------
--Congruence

  --Read: https://en.wikipedia.org/wiki/Congruence_relation
  --      https://en.wikipedia.org/wiki/Equivalence_class

------------------------------------------------------------------------------------------
--Universe Lifting
#check ulift

------------------------------------------------------------------------------------------
--Useful Links:
/-
vscode abbreviations: https://github.com/leanprover/vscode-lean/blob/master/src/abbreviation/abbreviations.json
lean community version github: https://github.com/leanprover-community/lean
lean community website: https://leanprover-community.github.io/
mathlib docs: https://leanprover-community.github.io/mathlib_docs/
theorem proving in lean: https://leanprover.github.io/theorem_proving_in_lean/
lean reference manual: https://leanprover.github.io/reference/
logic and proof: https://leanprover.github.io/logic_and_proof/
-/


/-
Copyright (c) 2021 . All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes
-/
import group_theory.group_action.basic
import group_theory.subgroup.basic
/-!
# Conjugation action of a group on itself

This file defines the conjugation action of a group on itself. See also `mul_aut.conj` for
the definition of conjugation as a homomorphism into the automorphism group.

## Main definitions

A type alias `conj_act G` is introduced for a group `G`. The group `conj_act G` acts on `G`
by conjugation. The group `conj_act G` also acts on any normal subgroup of `G` by conjugation.

## Implementation Notes

The scalar action in defined in this file can also be written using `mul_aut.conj g • h`. This
has the advantage of not using the type alias `conj_act`, but the downside of this approach
is that some theorems about the group actions will not apply when since this
`mul_aut.conj g • h` describes an action of `mul_aut G` on `G`, and not an action of `G`.

-/

variables (G : Type*)

/-- A type alias for a group `G`. `conj_act G` acts on `G` by conjugation -/
def conj_act : Type* := G

namespace conj_act
open mul_action subgroup

variable {G}

instance : Π [group G], group (conj_act G) := id
instance : Π [div_inv_monoid G], div_inv_monoid (conj_act G) := id
instance : Π [group_with_zero G], group_with_zero (conj_act G) := id
instance : Π [fintype G], fintype (conj_act G) := id

@[simp] lemma card [fintype G] : fintype.card (conj_act G) = fintype.card G := rfl

section div_inv_monoid

variable [div_inv_monoid G]

instance : inhabited (conj_act G) := ⟨1⟩

/-- Reinterpret `g : conj_act G` as an element of `G`. -/
def of_conj_act : conj_act G ≃* G := ⟨id, id, λ _, rfl, λ _, rfl, λ _ _, rfl⟩

/-- Reinterpret `g : G` as an element of `conj_act G`. -/
def to_conj_act : G ≃* conj_act G := of_conj_act.symm

/-- A recursor for `conj_act`, for use as `induction x using conj_act.rec` when `x : conj_act G`. -/
protected def rec {C : conj_act G → Sort*} (h : Π g, C (to_conj_act g)) : Π g, C g := h

@[simp] lemma of_mul_symm_eq : (@of_conj_act G _).symm = to_conj_act := rfl
@[simp] lemma to_mul_symm_eq : (@to_conj_act G _).symm = of_conj_act := rfl
@[simp] lemma to_conj_act_of_conj_act (x : conj_act G) : to_conj_act (of_conj_act x) = x := rfl
@[simp] lemma of_conj_act_to_conj_act (x : G) : of_conj_act (to_conj_act x) = x := rfl
@[simp] lemma of_conj_act_one : of_conj_act (1 : conj_act G) = 1 := rfl
@[simp] lemma to_conj_act_one : to_conj_act (1 : G) = 1 := rfl
@[simp] lemma of_conj_act_inv (x : conj_act G) : of_conj_act (x⁻¹) = (of_conj_act x)⁻¹ := rfl
@[simp] lemma to_conj_act_inv (x : G) : to_conj_act (x⁻¹) = (to_conj_act x)⁻¹ := rfl
@[simp] lemma of_conj_act_mul (x y : conj_act G) :
  of_conj_act (x * y) = of_conj_act x * of_conj_act y := rfl
@[simp] lemma to_conj_act_mul (x y : G) : to_conj_act (x * y) =
  to_conj_act x * to_conj_act y := rfl

instance : has_scalar (conj_act G) G :=
{ smul := λ g h, of_conj_act g * h * (of_conj_act g)⁻¹ }

lemma smul_def (g : conj_act G) (h : G) : g • h = of_conj_act g * h * (of_conj_act g)⁻¹ := rfl

@[simp] lemma «forall» (p : conj_act G → Prop) :
  (∀ (x : conj_act G), p x) ↔ ∀ x : G, p (to_conj_act x) := iff.rfl

end div_inv_monoid

section group_with_zero

variable [group_with_zero G]

@[simp] lemma of_conj_act_zero : of_conj_act (0 : conj_act G) = 0 := rfl
@[simp]

instance : mul_action (conj_act G) G :=
{ smul := (•),
  one_smul := by simp [smul_def],
  mul_smul := by simp [smul_def, mul_assoc, mul_inv_rev₀] }

end group_with_zero

variables [group G]

instance : mul_distrib_mul_action (conj_act G) G :=
{ smul := (•),
  smul_mul := by simp [smul_def, mul_assoc],
  smul_one := by simp [smul_def],
  one_smul := by simp [smul_def],
  mul_smul := by simp [smul_def, mul_assoc] }

lemma smul_eq_mul_aut_conj (g : conj_act G) (h : G) : g • h = mul_aut.conj (of_conj_act g) h := rfl

/-- The set of fixed points of the conjugation action of `G` on itself is the center of `G`. -/
lemma fixed_points_eq_center : fixed_points (conj_act G) G = center G :=
begin
  ext x,
  simp [mem_center_iff, smul_def, mul_inv_eq_iff_eq_mul]
end

/-- As normal subgroups are closed under conjugation, they inherit the conjugation action
  of the underlying group. -/
instance subgroup.conj_action {H : subgroup G} [hH : H.normal] :
  has_scalar (conj_act G) H :=
⟨λ g h, ⟨g • h, hH.conj_mem h.1 h.2 (of_conj_act g)⟩⟩

lemma subgroup.coe_conj_smul {H : subgroup G} [hH : H.normal] (g : conj_act G) (h : H) :
  ↑(g • h) = g • (h : G) := rfl

instance subgroup.conj_mul_distrib_mul_action {H : subgroup G} [hH : H.normal] :
  mul_distrib_mul_action (conj_act G) H :=
(subtype.coe_injective).mul_distrib_mul_action H.subtype subgroup.coe_conj_smul

/-- Group conjugation on a normal subgroup. Analogous to `mul_aut.conj`. -/
def _root_.mul_aut.conj_normal {H : subgroup G} [hH : H.normal] : G →* mul_aut H :=
(mul_distrib_mul_action.to_mul_aut (conj_act G) H).comp to_conj_act.to_monoid_hom

@[simp] lemma _root_.mul_aut.conj_normal_apply {H : subgroup G} [H.normal] (g : G) (h : H) :
  ↑(mul_aut.conj_normal g h) = g * h * g⁻¹ := rfl

@[simp] lemma _root_.mul_aut.conj_normal_symm_apply {H : subgroup G} [H.normal] (g : G) (h : H) :
  ↑((mul_aut.conj_normal g).symm h) = g⁻¹ * h * g :=
by { change _ * (_)⁻¹⁻¹ = _, rw inv_inv, refl }

@[simp] lemma _root_.mul_aut.conj_normal_inv_apply {H : subgroup G} [H.normal] (g : G) (h : H) :
  ↑((mul_aut.conj_normal g)⁻¹ h) = g⁻¹ * h * g :=
mul_aut.conj_normal_symm_apply g h

lemma _root_.mul_aut.conj_normal_coe {H : subgroup G} [H.normal] {h : H} :
  mul_aut.conj_normal ↑h = mul_aut.conj h :=
mul_equiv.ext (λ x, rfl)

instance normal_of_characteristic_of_normal {H : subgroup G} [hH : H.normal]
  {K : subgroup H} [h : K.characteristic] : (K.map H.subtype).normal :=
⟨λ a ha b, by
{ obtain ⟨a, ha, rfl⟩ := ha,
  exact K.apply_coe_mem_map H.subtype
    ⟨_, ((set_like.ext_iff.mp (h.fixed (mul_aut.conj_normal b)) a).mpr ha)⟩ }⟩

end conj_act


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

/-!
# Euclidean distance on a finite dimensional space

When we define a smooth bump function on a normed space, it is useful to have a smooth distance on
the space. Since the default distance is not guaranteed to be smooth, we define `to_euclidean` to be
an equivalence between a finite dimensional normed space and the standard Euclidean space of the
same dimension. Then we define `euclidean.dist x y = dist (to_euclidean x) (to_euclidean y)` and
provide some definitions (`euclidean.ball`, `euclidean.closed_ball`) and simple lemmas about this
distance. This way we hide the usage of `to_euclidean` behind an API.
-/

open_locale topological_space
open set

variables {E : Type*} [normed_group E] [normed_space ℝ E] [finite_dimensional ℝ E]

noncomputable theory

/-- If `E` is a finite dimensional space over `ℝ`, then `to_euclidean` is a continuous `ℝ`-linear
equivalence between `E` and the Euclidean space of the same dimension. -/
def to_euclidean : E ≃L[ℝ] euclidean_space ℝ (fin $ finite_dimensional.finrank ℝ E) :=
continuous_linear_equiv.of_finrank_eq finrank_euclidean_space_fin.symm

namespace euclidean

/-- If `x` and `y` are two points in a finite dimensional space over `ℝ`, then `euclidean.dist x y`
is the distance between these points in the metric defined by some inner product space structure on
`E`. -/
def dist (x y : E) : ℝ := dist (to_euclidean x) (to_euclidean y)

/-- Closed ball w.r.t. the euclidean distance. -/
def closed_ball (x : E) (r : ℝ) : set E := {y | dist y x ≤ r}

/-- Open ball w.r.t. the euclidean distance. -/
def ball (x : E) (r : ℝ) : set E := {y | dist y x < r}

lemma ball_eq_preimage (x : E) (r : ℝ) :
  ball x r = to_euclidean ⁻¹' (metric.ball (to_euclidean x) r) :=
rfl

lemma closed_ball_eq_preimage (x : E) (r : ℝ) :
  closed_ball x r = to_euclidean ⁻¹' (metric.closed_ball (to_euclidean x) r) :=
rfl

lemma ball_subset_closed_ball {x : E} {r : ℝ} : ball x r ⊆ closed_ball x r :=
λ y (hy : _ < _), le_of_lt hy

lemma is_open_ball {x : E} {r : ℝ} : is_open (ball x r) :=
metric.is_open_ball.preimage to_euclidean.continuous

lemma mem_ball_self {x : E} {r : ℝ} (hr : 0 < r) : x ∈ ball x r := metric.mem_ball_self hr

lemma closed_ball_eq_image (x : E) (r : ℝ) :
  closed_ball x r = to_euclidean.symm '' metric.closed_ball (to_euclidean x) r :=
by rw [to_euclidean.image_symm_eq_preimage, closed_ball_eq_preimage]

lemma compact_ball {x : E} {r : ℝ} : is_compact (closed_ball x r) :=
begin
  rw closed_ball_eq_image,
  exact (proper_space.compact_ball _ _).image to_euclidean.symm.continuous
end

lemma is_closed_closed_ball {x : E} {r : ℝ} : is_closed (closed_ball x r) :=
compact_ball.is_closed

lemma closure_ball (x : E) {r : ℝ} (h : 0 < r) : closure (ball x r) = closed_ball x r :=
by rw [ball_eq_preimage, ← to_euclidean.preimage_closure, closure_ball (to_euclidean x) h,
  closed_ball_eq_preimage]

lemma exists_pos_lt_subset_ball {R : ℝ} {s : set E} {x : E}
  (hR : 0 < R) (hs : is_closed s) (h : s ⊆ ball x R) :
  ∃ r ∈ Ioo 0 R, s ⊆ ball x r :=
begin
  rw [ball_eq_preimage, ← image_subset_iff] at h,
  rcases exists_pos_lt_subset_ball hR (to_euclidean.is_closed_image.2 hs) h with ⟨r, hr, hsr⟩,
  exact ⟨r, hr, image_subset_iff.1 hsr⟩
end

lemma nhds_basis_closed_ball {x : E} :
  (𝓝 x).has_basis (λ r : ℝ, 0 < r) (closed_ball x) :=
begin
  rw [to_euclidean.to_homeomorph.nhds_eq_comap],
  exact metric.nhds_basis_closed_ball.comap _
end

lemma closed_ball_mem_nhds {x : E} {r : ℝ} (hr : 0 < r) : closed_ball x r ∈ 𝓝 x :=
nhds_basis_closed_ball.mem_of_mem hr

lemma nhds_basis_ball {x : E} :
  (𝓝 x).has_basis (λ r : ℝ, 0 < r) (ball x) :=
begin
  rw [to_euclidean.to_homeomorph.nhds_eq_comap],
  exact metric.nhds_basis_ball.comap _
end

lemma ball_mem_nhds {x : E} {r : ℝ} (hr : 0 < r) : ball x r ∈ 𝓝 x :=
nhds_basis_ball.mem_of_mem hr

end euclidean

variables {F : Type*} [normed_group F] [normed_space ℝ F] {f g : F → E} {n : with_top ℕ}

lemma times_cont_diff.euclidean_dist (hf : times_cont_diff ℝ n f) (hg : times_cont_diff ℝ n g)
  (h : ∀ x, f x ≠ g x) :
  times_cont_diff ℝ n (λ x, euclidean.dist (f x) (g x)) :=
begin
  simp only [euclidean.dist],
  apply @times_cont_diff.dist ℝ,
  exacts [(@to_euclidean E _ _ _).times_cont_diff.comp hf,
    (@to_euclidean E _ _ _).times_cont_diff.comp hg, λ x, to_euclidean.injective.ne (h x)]
end


/-
Copyright © 2022 Nicolò Cavalleri. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Nicolò Cavalleri, Sébastien Gouëzel, Heather Macbeth, Floris van Doorn
-/
import topology.fiber_bundle.basic

/-!
# Standard constructions on fiber bundles

This file contains several standard constructions on fiber bundles:

* `bundle.trivial.fiber_bundle 𝕜 B F`: the trivial fiber bundle with model fiber `F` over the base
  `B`

* `fiber_bundle.prod`: for fiber bundles `E₁` and `E₂` over a common base, a fiber bundle structure
  on their fiberwise product `E₁ ×ᵇ E₂` (the notation stands for `λ x, E₁ x × E₂ x`).

* `fiber_bundle.pullback`: for a fiber bundle `E` over `B`, a fiber bundle structure on its
  pullback `f *ᵖ E` by a map `f : B' → B` (the notation is a type synonym for `E ∘ f`).

## Tags

fiber bundle, fibre bundle, fiberwise product, pullback

-/
open topological_space filter set bundle
open_locale topology classical bundle

/-! ### The trivial bundle -/

namespace bundle
namespace trivial

variables (B : Type*) (F : Type*)

instance [I : topological_space F] : ∀ x : B, topological_space (trivial B F x) := λ x, I

instance [t₁ : topological_space B] [t₂ : topological_space F] :
  topological_space (total_space (trivial B F)) :=
induced total_space.proj t₁ ⊓ induced (trivial.proj_snd B F) t₂

variables [topological_space B] [topological_space F]

/-- Local trivialization for trivial bundle. -/
def trivialization : trivialization F (π (bundle.trivial B F)) :=
{ to_fun := λ x, (x.fst, x.snd),
  inv_fun := λ y, ⟨y.fst, y.snd⟩,
  source := univ,
  target := univ,
  map_source' := λ x h, mem_univ (x.fst, x.snd),
  map_target' := λ y h,  mem_univ ⟨y.fst, y.snd⟩,
  left_inv' := λ x h, sigma.eq rfl rfl,
  right_inv' := λ x h, prod.ext rfl rfl,
  open_source := is_open_univ,
  open_target := is_open_univ,
  continuous_to_fun := by { rw [←continuous_iff_continuous_on_univ, continuous_iff_le_induced],
    simp only [prod.topological_space, induced_inf, induced_compose], exact le_rfl, },
  continuous_inv_fun := by { rw [←continuous_iff_continuous_on_univ, continuous_iff_le_induced],
    simp only [bundle.total_space.topological_space, induced_inf, induced_compose],
    exact le_rfl, },
  base_set := univ,
  open_base_set := is_open_univ,
  source_eq := rfl,
  target_eq := by simp only [univ_prod_univ],
  proj_to_fun := λ y hy, rfl }

@[simp]
lemma trivialization_source : (trivialization B F).source = univ := rfl

@[simp]
lemma trivialization_target : (trivialization B F).target = univ := rfl

/-- Fiber bundle instance on the trivial bundle. -/
instance fiber_bundle : fiber_bundle F (bundle.trivial B F) :=
{ trivialization_atlas := {bundle.trivial.trivialization B F},
  trivialization_at := λ x, bundle.trivial.trivialization B F,
  mem_base_set_trivialization_at := mem_univ,
  trivialization_mem_atlas := λ x, mem_singleton _,
  total_space_mk_inducing := λ b, ⟨begin
    have : (λ (x : trivial B F b), x) = @id F, by { ext x, refl },
    simp only [total_space.topological_space, induced_inf, induced_compose, function.comp,
      total_space.proj, induced_const, top_inf_eq, trivial.proj_snd, id.def,
      trivial.topological_space, this, induced_id],
  end⟩ }

lemma eq_trivialization (e : _root_.trivialization F (π (bundle.trivial B F)))
  [i : mem_trivialization_atlas e] :
  e = trivialization B F :=
i.out

end trivial
end bundle

/-! ### Fibrewise product of two bundles -/

section prod

variables {B : Type*}

section defs
variables (E₁ : B → Type*) (E₂ : B → Type*)
variables [topological_space (total_space E₁)] [topological_space (total_space E₂)]

/-- Equip the total space of the fiberwise product of two fiber bundles `E₁`, `E₂` with
the induced topology from the diagonal embedding into `total_space E₁ × total_space E₂`. -/
instance fiber_bundle.prod.topological_space : topological_space (total_space (E₁ ×ᵇ E₂)) :=
topological_space.induced
  (λ p, ((⟨p.1, p.2.1⟩ : total_space E₁), (⟨p.1, p.2.2⟩ : total_space E₂)))
  (by apply_instance : topological_space (total_space E₁ × total_space E₂))

/-- The diagonal map from the total space of the fiberwise product of two fiber bundles
`E₁`, `E₂` into `total_space E₁ × total_space E₂` is `inducing`. -/
lemma fiber_bundle.prod.inducing_diag : inducing
  (λ p, (⟨p.1, p.2.1⟩, ⟨p.1, p.2.2⟩) :
    total_space (E₁ ×ᵇ E₂) → total_space E₁ × total_space E₂) :=
⟨rfl⟩

end defs

open fiber_bundle

variables [topological_space B]
  (F₁ : Type*) [topological_space F₁] (E₁ : B → Type*) [topological_space (total_space E₁)]
  (F₂ : Type*) [topological_space F₂] (E₂ : B → Type*) [topological_space (total_space E₂)]

namespace trivialization
variables {F₁ E₁ F₂ E₂} (e₁ : trivialization F₁ (π E₁)) (e₂ : trivialization F₂ (π E₂))

/-- Given trivializations `e₁`, `e₂` for fiber bundles `E₁`, `E₂` over a base `B`, the forward
function for the construction `trivialization.prod`, the induced
trivialization for the fiberwise product of `E₁` and `E₂`. -/
def prod.to_fun' : total_space (E₁ ×ᵇ E₂) → B × (F₁ × F₂) :=
λ p, ⟨p.1, (e₁ ⟨p.1, p.2.1⟩).2, (e₂ ⟨p.1, p.2.2⟩).2⟩

variables {e₁ e₂}

lemma prod.continuous_to_fun : continuous_on (prod.to_fun' e₁ e₂)
  (@total_space.proj B (E₁ ×ᵇ E₂) ⁻¹' (e₁.base_set ∩ e₂.base_set)) :=
begin
  let f₁ : total_space (E₁ ×ᵇ E₂) → total_space E₁ × total_space E₂ :=
    λ p, ((⟨p.1, p.2.1⟩ : total_space E₁), (⟨p.1, p.2.2⟩ : total_space E₂)),
  let f₂ : total_space E₁ × total_space E₂ → (B × F₁) × (B × F₂) := λ p, ⟨e₁ p.1, e₂ p.2⟩,
  let f₃ : (B × F₁) × (B × F₂) → B × F₁ × F₂ := λ p, ⟨p.1.1, p.1.2, p.2.2⟩,
  have hf₁ : continuous f₁ := (prod.inducing_diag E₁ E₂).continuous,
  have hf₂ : continuous_on f₂ (e₁.source ×ˢ e₂.source) :=
    e₁.to_local_homeomorph.continuous_on.prod_map e₂.to_local_homeomorph.continuous_on,
  have hf₃ : continuous f₃ :=
    (continuous_fst.comp continuous_fst).prod_mk (continuous_snd.prod_map continuous_snd),
  refine ((hf₃.comp_continuous_on hf₂).comp hf₁.continuous_on _).congr _,
  { rw [e₁.source_eq, e₂.source_eq],
    exact maps_to_preimage _ _ },
  rintros ⟨b, v₁, v₂⟩ ⟨hb₁, hb₂⟩,
  simp only [prod.to_fun', prod.mk.inj_iff, eq_self_iff_true, and_true],
  rw e₁.coe_fst,
  rw [e₁.source_eq, mem_preimage],
  exact hb₁,
end

variables (e₁ e₂) [Π x, has_zero (E₁ x)] [∀ x, has_zero (E₂ x)]

/-- Given trivializations `e₁`, `e₂` for fiber bundles `E₁`, `E₂` over a base `B`, the inverse
function for the construction `trivialization.prod`, the induced
trivialization for the fiberwise product of `E₁` and `E₂`. -/
noncomputable def prod.inv_fun' (p : B × (F₁ × F₂)) : total_space (E₁ ×ᵇ E₂) :=
⟨p.1, e₁.symm p.1 p.2.1, e₂.symm p.1 p.2.2⟩

variables {e₁ e₂}

lemma prod.right_inv {x : B × F₁ × F₂}
  (h : x ∈ (e₁.base_set ∩ e₂.base_set) ×ˢ (univ : set (F₁ × F₂))) :
  prod.to_fun' e₁ e₂ (prod.inv_fun' e₁ e₂ x) = x :=
begin
  obtain ⟨x, w₁, w₂⟩ := x,
  obtain ⟨⟨h₁ : x ∈ e₁.base_set, h₂ : x ∈ e₂.base_set⟩, -⟩ := h,
  simp only [prod.to_fun', prod.inv_fun', apply_mk_symm, h₁, h₂]
end

lemma prod.continuous_inv_fun :
  continuous_on (prod.inv_fun' e₁ e₂) ((e₁.base_set ∩ e₂.base_set) ×ˢ univ) :=
begin
  rw (prod.inducing_diag E₁ E₂).continuous_on_iff,
  have H₁ : continuous (λ p : B × F₁ × F₂, ((p.1, p.2.1), (p.1, p.2.2))) :=
    (continuous_id.prod_map continuous_fst).prod_mk (continuous_id.prod_map continuous_snd),
  refine (e₁.continuous_on_symm.prod_map e₂.continuous_on_symm).comp H₁.continuous_on _,
  exact λ x h, ⟨⟨h.1.1, mem_univ _⟩, ⟨h.1.2, mem_univ _⟩⟩
end

variables (e₁ e₂ e₁ e₂)

/-- Given trivializations `e₁`, `e₂` for bundle types `E₁`, `E₂` over a base `B`, the induced
trivialization for the fiberwise product of `E₁` and `E₂`, whose base set is
`e₁.base_set ∩ e₂.base_set`. -/
noncomputable def prod : trivialization (F₁ × F₂) (π (E₁ ×ᵇ E₂)) :=
{ to_fun := prod.to_fun' e₁ e₂,
  inv_fun := prod.inv_fun' e₁ e₂,
  source := (@total_space.proj B (E₁ ×ᵇ E₂)) ⁻¹' (e₁.base_set ∩ e₂.base_set),
  target := (e₁.base_set ∩ e₂.base_set) ×ˢ set.univ,
  map_source' := λ x h, ⟨h, set.mem_univ _⟩,
  map_target' := λ x h, h.1,
  left_inv' := λ x, prod.left_inv,
  right_inv' := λ x, prod.right_inv,
  open_source := begin
    convert (e₁.open_source.prod e₂.open_source).preimage
      (fiber_bundle.prod.inducing_diag E₁ E₂).continuous,
    ext x,
    simp only [trivialization.source_eq] with mfld_simps,
  end,
  open_target := (e₁.open_base_set.inter e₂.open_base_set).prod is_open_univ,
  continuous_to_fun := prod.continuous_to_fun,
  continuous_inv_fun := prod.continuous_inv_fun,
  base_set := e₁.base_set ∩ e₂.base_set,
  open_base_set := e₁.open_base_set.inter e₂.open_base_set,
  source_eq := rfl,
  target_eq := rfl,
  proj_to_fun := λ x h, rfl }

@[simp] lemma base_set_prod : (prod e₁ e₂).base_set = e₁.base_set ∩ e₂.base_set :=
rfl

lemma prod_symm_apply (x : B) (w₁ : F₁) (w₂ : F₂) : (prod e₁ e₂).to_local_equiv.symm (x, w₁, w₂)
  = ⟨x, e₁.symm x w₁, e₂.symm x w₂⟩ :=
rfl

end trivialization

open trivialization

variables [Π x, has_zero (E₁ x)] [∀ x, has_zero (E₂ x)]
  [Π x : B, topological_space (E₁ x)] [Π x : B, topological_space (E₂ x)]
  [fiber_bundle F₁ E₁] [fiber_bundle F₂ E₂]

/-- The product of two fiber bundles is a fiber bundle. -/
noncomputable instance fiber_bundle.prod : fiber_bundle (F₁ × F₂) (E₁ ×ᵇ E₂) :=
{ total_space_mk_inducing := λ b,
  begin
    rw (prod.inducing_diag E₁ E₂).inducing_iff,
    exact (total_space_mk_inducing F₁ E₁ b).prod_mk (total_space_mk_inducing F₂ E₂ b),
  end,
  trivialization_atlas :=
    {e |  ∃ (e₁ : trivialization F₁ (π E₁)) (e₂ : trivialization F₂ (π E₂))
    [mem_trivialization_atlas e₁] [mem_trivialization_atlas e₂], by exactI
    e = trivialization.prod e₁ e₂},
  trivialization_at := λ b, (trivialization_at F₁ E₁ b).prod (trivialization_at F₂ E₂ b),
  mem_base_set_trivialization_at :=
    λ b, ⟨mem_base_set_trivialization_at F₁ E₁ b, mem_base_set_trivialization_at F₂ E₂ b⟩,
  trivialization_mem_atlas := λ b, ⟨trivialization_at F₁ E₁ b, trivialization_at F₂ E₂ b,
    by apply_instance, by apply_instance, rfl⟩ }

instance {e₁ : trivialization F₁ (π E₁)} {e₂ : trivialization F₂ (π E₂)}
  [mem_trivialization_atlas e₁] [mem_trivialization_atlas e₂] :
  mem_trivialization_atlas (e₁.prod e₂ : trivialization (F₁ × F₂) (π (E₁ ×ᵇ E₂))) :=
{ out := ⟨e₁, e₂, by apply_instance, by apply_instance, rfl⟩ }

end prod

/-! ### Pullbacks of fiber bundles -/

section
variables {B : Type*} (F : Type*) (E : B → Type*) {B' : Type*} (f : B' → B)

instance [∀ (x : B), topological_space (E x)] : ∀ (x : B'), topological_space ((f *ᵖ E) x) :=
by delta_instance bundle.pullback

variables [topological_space B'] [topological_space (total_space E)]

/-- Definition of `pullback.total_space.topological_space`, which we make irreducible. -/
@[irreducible] def pullback_topology : topological_space (total_space (f *ᵖ E)) :=
induced total_space.proj ‹topological_space B'› ⊓
induced (pullback.lift f) ‹topological_space (total_space E)›

/-- The topology on the total space of a pullback bundle is the coarsest topology for which both
the projections to the base and the map to the original bundle are continuous. -/
instance pullback.total_space.topological_space : topological_space (total_space (f *ᵖ E)) :=
pullback_topology E f

lemma pullback.continuous_proj (f : B' → B) : continuous (@total_space.proj _ (f *ᵖ E)) :=
begin
  rw [continuous_iff_le_induced, pullback.total_space.topological_space, pullback_topology],
  exact inf_le_left,
end

lemma pullback.continuous_lift (f : B' → B) : continuous (@pullback.lift B E B' f) :=
begin
  rw [continuous_iff_le_induced, pullback.total_space.topological_space, pullback_topology],
  exact inf_le_right,
end

lemma inducing_pullback_total_space_embedding (f : B' → B) :
  inducing (@pullback_total_space_embedding B E B' f) :=
begin
  constructor,
  simp_rw [prod.topological_space, induced_inf, induced_compose,
    pullback.total_space.topological_space, pullback_topology],
  refl
end

section fiber_bundle
variables (F) [topological_space F] [topological_space B]

lemma pullback.continuous_total_space_mk [∀ x, topological_space (E x)]
  [fiber_bundle F E] {f : B' → B} {x : B'} :
  continuous (@total_space_mk _ (f *ᵖ E) x) :=
begin
  simp only [continuous_iff_le_induced, pullback.total_space.topological_space, induced_compose,
    induced_inf, function.comp, total_space_mk, total_space.proj, induced_const, top_inf_eq,
    pullback_topology],
  exact le_of_eq (fiber_bundle.total_space_mk_inducing F E (f x)).induced,
end

variables {E F} [∀ b, has_zero (E b)] {K : Type*} [continuous_map_class K B' B]

/-- A fiber bundle trivialization can be pulled back to a trivialization on the pullback bundle. -/
noncomputable def trivialization.pullback (e : trivialization F (π E)) (f : K) :
  trivialization F (π ((f : B' → B) *ᵖ E)) :=
{ to_fun := λ z, (z.proj, (e (pullback.lift f z)).2),
  inv_fun := λ y, @total_space_mk _ (f *ᵖ E) y.1 (e.symm (f y.1) y.2),
  source := pullback.lift f ⁻¹' e.source,
  base_set := f ⁻¹' e.base_set,
  target := (f ⁻¹' e.base_set) ×ˢ univ,
  map_source' := λ x h, by { simp_rw [e.source_eq, mem_preimage, pullback.proj_lift] at h,
    simp_rw [prod_mk_mem_set_prod_eq, mem_univ, and_true, mem_preimage, h] },
  map_target' := λ y h, by { rw [mem_prod, mem_preimage] at h,
    simp_rw [e.source_eq, mem_preimage, pullback.proj_lift, h.1] },
  left_inv' := λ x h, by { simp_rw [mem_preimage, e.mem_source, pullback.proj_lift] at h,
    simp_rw [pullback.lift, e.symm_apply_apply_mk h, total_space.eta] },
  right_inv' := λ x h, by { simp_rw [mem_prod, mem_preimage, mem_univ, and_true] at h,
    simp_rw [total_space.proj_mk, pullback.lift_mk, e.apply_mk_symm h, prod.mk.eta] },
  open_source := by { simp_rw [e.source_eq, ← preimage_comp], exact ((map_continuous f).comp $
    pullback.continuous_proj E f).is_open_preimage _ e.open_base_set },
  open_target := ((map_continuous f).is_open_preimage _ e.open_base_set).prod is_open_univ,
  open_base_set := (map_continuous f).is_open_preimage _ e.open_base_set,
  continuous_to_fun := (pullback.continuous_proj E f).continuous_on.prod
    (continuous_snd.comp_continuous_on $
    e.continuous_on.comp (pullback.continuous_lift E f).continuous_on subset.rfl),
  continuous_inv_fun := begin
    dsimp only,
    simp_rw [(inducing_pullback_total_space_embedding E f).continuous_on_iff, function.comp,
      pullback_total_space_embedding, total_space.proj_mk],
    dsimp only [total_space.proj_mk],
    refine continuous_on_fst.prod (e.continuous_on_symm.comp
      ((map_continuous f).prod_map continuous_id).continuous_on subset.rfl)
  end,
  source_eq := by { dsimp only, rw e.source_eq, refl, },
  target_eq := rfl,
  proj_to_fun := λ y h, rfl }

noncomputable instance fiber_bundle.pullback [∀ x, topological_space (E x)]
  [fiber_bundle F E] (f : K) : fiber_bundle F ((f : B' → B) *ᵖ E) :=
{ total_space_mk_inducing := λ x, inducing_of_inducing_compose
    (pullback.continuous_total_space_mk F E) (pullback.continuous_lift E f)
    (total_space_mk_inducing F E (f x)),
  trivialization_atlas :=
    {ef | ∃ (e : trivialization F (π E)) [mem_trivialization_atlas e], ef = e.pullback f},
  trivialization_at := λ x, (trivialization_at F E (f x)).pullback f,
  mem_base_set_trivialization_at := λ x, mem_base_set_trivialization_at F E (f x),
  trivialization_mem_atlas := λ x, ⟨trivialization_at F E (f x), by apply_instance, rfl⟩ }

end fiber_bundle
end


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

! This file was ported from Lean 3 source module topology.homotopy.contractible
! leanprover-community/mathlib commit 16728b3064a1751103e1dc2815ed8d00560e0d87
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Topology.Homotopy.Path
import Mathbin.Topology.Homotopy.Equiv

/-!
# Contractible spaces

In this file, we define `contractible_space`, a space that is homotopy equivalent to `unit`.
-/

noncomputable section

namespace ContinuousMap

variable {X Y Z : Type _} [TopologicalSpace X] [TopologicalSpace Y] [TopologicalSpace Z]

/-- A map is nullhomotopic if it is homotopic to a constant map. -/
def Nullhomotopic (f : C(X, Y)) : Prop :=
  ∃ y : Y, Homotopic f (ContinuousMap.const _ y)
#align continuous_map.nullhomotopic ContinuousMap.Nullhomotopic

theorem nullhomotopic_of_constant (y : Y) : Nullhomotopic (ContinuousMap.const X y) :=
  ⟨y, by rfl⟩
#align continuous_map.nullhomotopic_of_constant ContinuousMap.nullhomotopic_of_constant

theorem Nullhomotopic.comp_right {f : C(X, Y)} (hf : f.Nullhomotopic) (g : C(Y, Z)) :
    (g.comp f).Nullhomotopic := by
  cases' hf with y hy
  use g y
  exact homotopic.hcomp hy (homotopic.refl g)
#align continuous_map.nullhomotopic.comp_right ContinuousMap.Nullhomotopic.comp_right

theorem Nullhomotopic.comp_left {f : C(Y, Z)} (hf : f.Nullhomotopic) (g : C(X, Y)) :
    (f.comp g).Nullhomotopic := by
  cases' hf with y hy
  use y
  exact homotopic.hcomp (homotopic.refl g) hy
#align continuous_map.nullhomotopic.comp_left ContinuousMap.Nullhomotopic.comp_left

end ContinuousMap

open ContinuousMap

open ContinuousMap

/- ./././Mathport/Syntax/Translate/Command.lean:388:30: infer kinds are unsupported in Lean 4: #[`hequiv_unit] [] -/
/-- A contractible space is one that is homotopy equivalent to `unit`. -/
class ContractibleSpace (X : Type _) [TopologicalSpace X] : Prop where
  hequiv_unit : Nonempty (X ≃ₕ Unit)
#align contractible_space ContractibleSpace

theorem id_nullhomotopic (X : Type _) [TopologicalSpace X] [ContractibleSpace X] :
    (ContinuousMap.id X).Nullhomotopic :=
  by
  obtain ⟨hv⟩ := ContractibleSpace.hequiv_unit X
  use hv.inv_fun ()
  convert hv.left_inv.symm
  ext; simp; congr
#align id_nullhomotopic id_nullhomotopic

theorem contractible_iff_id_nullhomotopic (Y : Type _) [TopologicalSpace Y] :
    ContractibleSpace Y ↔ (ContinuousMap.id Y).Nullhomotopic :=
  by
  constructor;
  · intro
    apply id_nullhomotopic
  rintro ⟨p, h⟩
  refine_struct
    {
      hequiv_unit :=
        ⟨{  toFun := ContinuousMap.const _ ()
            invFun := ContinuousMap.const _ p }⟩ }
  · exact h.symm;
  · convert homotopic.refl (ContinuousMap.id Unit)
    ext
#align contractible_iff_id_nullhomotopic contractible_iff_id_nullhomotopic

variable {X Y : Type _} [TopologicalSpace X] [TopologicalSpace Y]

protected theorem ContinuousMap.HomotopyEquiv.contractibleSpace [ContractibleSpace Y] (e : X ≃ₕ Y) :
    ContractibleSpace X :=
  ⟨(ContractibleSpace.hequiv_unit Y).map e.trans⟩
#align continuous_map.homotopy_equiv.contractible_space ContinuousMap.HomotopyEquiv.contractibleSpace

protected theorem ContinuousMap.HomotopyEquiv.contractibleSpace_iff (e : X ≃ₕ Y) :
    ContractibleSpace X ↔ ContractibleSpace Y :=
  ⟨by
    intro h
    exact e.symm.contractible_space, by
    intro h
    exact e.contractible_space⟩
#align continuous_map.homotopy_equiv.contractible_space_iff ContinuousMap.HomotopyEquiv.contractibleSpace_iff

protected theorem Homeomorph.contractibleSpace [ContractibleSpace Y] (e : X ≃ₜ Y) :
    ContractibleSpace X :=
  e.toHomotopyEquiv.ContractibleSpace
#align homeomorph.contractible_space Homeomorph.contractibleSpace

protected theorem Homeomorph.contractibleSpace_iff (e : X ≃ₜ Y) :
    ContractibleSpace X ↔ ContractibleSpace Y :=
  e.toHomotopyEquiv.contractibleSpace_iff
#align homeomorph.contractible_space_iff Homeomorph.contractibleSpace_iff

namespace ContractibleSpace

instance (priority := 100) [ContractibleSpace X] : PathConnectedSpace X :=
  by
  obtain ⟨p, ⟨h⟩⟩ := id_nullhomotopic X
  have : ∀ x, Joined p x := fun x => ⟨(h.eval_at x).symm⟩
  rw [pathConnectedSpace_iff_eq]; use p; ext; tauto

end ContractibleSpace