/-
Copyright (c) 2019 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel
-/
import topology.local_homeomorph
import topology.algebra.ordered.basic
import data.bundle

/-!
# Fiber bundles

A topological fiber bundle with fiber `F` over a base `B` is a space projecting on `B` for which the
fibers are all homeomorphic to `F`, such that the local situation around each point is a direct
product. We define a predicate `is_topological_fiber_bundle F p` saying that `p : Z → B` is a
topological fiber bundle with fiber `F`.

It is in general nontrivial to construct a fiber bundle. A way is to start from the knowledge of
how changes of local trivializations act on the fiber. From this, one can construct the total space
of the bundle and its topology by a suitable gluing construction. The main content of this file is
an implementation of this construction: starting from an object of type
`topological_fiber_bundle_core` registering the trivialization changes, one gets the corresponding
fiber bundle and projection.

Similarly we implement the object `topological_fiber_prebundle` which allows to define a topological
fiber bundle from trivializations given as local equivalences with minimum additional properties.

## Main definitions

### Basic definitions

* `trivialization F p` : structure extending local homeomorphisms, defining a local
                  trivialization of a topological space `Z` with projection `p` and fiber `F`.

* `is_topological_fiber_bundle F p` : Prop saying that the map `p` between topological spaces is a
                  fiber bundle with fiber `F`.

* `is_trivial_topological_fiber_bundle F p` : Prop saying that the map `p : Z → B` between
  topological spaces is a trivial topological fiber bundle, i.e., there exists a homeomorphism
  `h : Z ≃ₜ B × F` such that `proj x = (h x).1`.

### Operations on bundles

We provide the following operations on `trivialization`s.

* `trivialization.comap`: given a local trivialization `e` of a fiber bundle `p : Z → B`, a
  continuous map `f : B' → B` and a point `b' : B'` such that `f b' ∈ e.base_set`,
  `e.comap f hf b' hb'` is a trivialization of the pullback bundle. The pullback bundle
  (a.k.a., the induced bundle) has total space `{(x, y) : B' × Z | f x = p y}`, and is given by
  `λ ⟨(x, y), h⟩, x`.

* `is_topological_fiber_bundle.comap`: if `p : Z → B` is a topological fiber bundle, then its
  pullback along a continuous map `f : B' → B` is a topological fiber bundle as well.

* `trivialization.comp_homeomorph`: given a local trivialization `e` of a fiber bundle
  `p : Z → B` and a homeomorphism `h : Z' ≃ₜ Z`, returns a local trivialization of the fiber bundle
  `p ∘ h`.

* `is_topological_fiber_bundle.comp_homeomorph`: if `p : Z → B` is a topological fiber bundle
  and `h : Z' ≃ₜ Z` is a homeomorphism, then `p ∘ h : Z' → B` is a topological fiber bundle with
  the same fiber.

### Construction of a bundle from trivializations

* `bundle.total_space E` is a type synonym for `Σ (x : B), E x`, that we can endow with a suitable
  topology.
* `topological_fiber_bundle_core ι B F` : structure registering how changes of coordinates act
  on the fiber `F` above open subsets of `B`, where local trivializations are indexed by `ι`.

Let `Z : topological_fiber_bundle_core ι B F`. Then we define

* `Z.fiber x`     : the fiber above `x`, homeomorphic to `F` (and defeq to `F` as a type).
* `Z.total_space` : the total space of `Z`, defined as a `Type` as `Σ (b : B), F`, but with a
  twisted topology coming from the fiber bundle structure. It is (reducibly) the same as
  `bundle.total_space Z.fiber`.
* `Z.proj`        : projection from `Z.total_space` to `B`. It is continuous.
* `Z.local_triv i`: for `i : ι`, bundle trivialization above the set `Z.base_set i`, which is an
                    open set in `B`.

* `pretrivialization F proj` : trivialization as a local equivalence, mainly used when the
                                      topology on the total space has not yet been defined.
* `topological_fiber_prebundle F proj` : structure registering a cover of prebundle trivializations
  and requiring that the relative transition maps are local homeomorphisms.
* `topological_fiber_prebundle.total_space_topology a` : natural topology of the total space, making
  the prebundle into a bundle.

## Implementation notes

A topological fiber bundle with fiber `F` over a base `B` is a family of spaces isomorphic to `F`,
indexed by `B`, which is locally trivial in the following sense: there is a covering of `B` by open
sets such that, on each such open set `s`, the bundle is isomorphic to `s × F`.

To construct a fiber bundle formally, the main data is what happens when one changes trivializations
from `s × F` to `s' × F` on `s ∩ s'`: one should get a family of homeomorphisms of `F`, depending
continuously on the base point, satisfying basic compatibility conditions (cocycle property).
Useful classes of bundles can then be specified by requiring that these homeomorphisms of `F`
belong to some subgroup, preserving some structure (the "structure group of the bundle"): then
these structures are inherited by the fibers of the bundle.

Given such trivialization change data (encoded below in a structure called
`topological_fiber_bundle_core`), one can construct the fiber bundle. The intrinsic canonical
mathematical construction is the following.
The fiber above `x` is the disjoint union of `F` over all trivializations, modulo the gluing
identifications: one gets a fiber which is isomorphic to `F`, but non-canonically
(each choice of one of the trivializations around `x` gives such an isomorphism). Given a
trivialization over a set `s`, one gets an isomorphism between `s × F` and `proj^{-1} s`, by using
the identification corresponding to this trivialization. One chooses the topology on the bundle that
makes all of these into homeomorphisms.

For the practical implementation, it turns out to be more convenient to avoid completely the
gluing and quotienting construction above, and to declare above each `x` that the fiber is `F`,
but thinking that it corresponds to the `F` coming from the choice of one trivialization around `x`.
This has several practical advantages:
* without any work, one gets a topological space structure on the fiber. And if `F` has more
structure it is inherited for free by the fiber.
* In the case of the tangent bundle of manifolds, this implies that on vector spaces the derivative
(from `F` to `F`) and the manifold derivative (from `tangent_space I x` to `tangent_space I' (f x)`)
are equal.

A drawback is that some silly constructions will typecheck: in the case of the tangent bundle, one
can add two vectors in different tangent spaces (as they both are elements of `F` from the point of
view of Lean). To solve this, one could mark the tangent space as irreducible, but then one would
lose the identification of the tangent space to `F` with `F`. There is however a big advantage of
this situation: even if Lean can not check that two basepoints are defeq, it will accept the fact
that the tangent spaces are the same. For instance, if two maps `f` and `g` are locally inverse to
each other, one can express that the composition of their derivatives is the identity of
`tangent_space I x`. One could fear issues as this composition goes from `tangent_space I x` to
`tangent_space I (g (f x))` (which should be the same, but should not be obvious to Lean
as it does not know that `g (f x) = x`). As these types are the same to Lean (equal to `F`), there
are in fact no dependent type difficulties here!

For this construction of a fiber bundle from a `topological_fiber_bundle_core`, we should thus
choose for each `x` one specific trivialization around it. We include this choice in the definition
of the `topological_fiber_bundle_core`, as it makes some constructions more
functorial and it is a nice way to say that the trivializations cover the whole space `B`.

With this definition, the type of the fiber bundle space constructed from the core data is just
`Σ (b : B), F `, but the topology is not the product one, in general.

We also take the indexing type (indexing all the trivializations) as a parameter to the fiber bundle
core: it could always be taken as a subtype of all the maps from open subsets of `B` to continuous
maps of `F`, but in practice it will sometimes be something else. For instance, on a manifold, one
will use the set of charts as a good parameterization for the trivializations of the tangent bundle.
Or for the pullback of a `topological_fiber_bundle_core`, the indexing type will be the same as
for the initial bundle.

## Tags
Fiber bundle, topological bundle, local trivialization, structure group
-/

variables {ι : Type*} {B : Type*} {F : Type*}

open topological_space filter set
open_locale topological_space classical

/-! ### General definition of topological fiber bundles -/

section topological_fiber_bundle

variables (F) {Z : Type*} [topological_space B] [topological_space F] {proj : Z → B}

/-- This structure contains the information left for a local trivialization (which is implemented
below as `trivialization F proj`) if the total space has not been given a topology, but we
have a topology on both the fiber and the base space. Through the construction
`topological_fiber_prebundle F proj` it will be possible to promote a
`pretrivialization F proj` to a `trivialization F proj`. -/
@[nolint has_inhabited_instance]
structure topological_fiber_bundle.pretrivialization (proj : Z → B) extends local_equiv Z (B × F) :=
(open_target   : is_open target)
(base_set      : set B)
(open_base_set : is_open base_set)
(source_eq     : source = proj ⁻¹' base_set)
(target_eq     : target = set.prod base_set univ)
(proj_to_fun   : ∀ p ∈ source, (to_fun p).1 = proj p)

open topological_fiber_bundle

namespace topological_fiber_bundle.pretrivialization

instance : has_coe_to_fun (pretrivialization F proj) (λ _, Z → (B × F)) := ⟨λ e, e.to_fun⟩

variables {F} (e : pretrivialization F proj) {x : Z}

@[simp, mfld_simps] lemma coe_coe : ⇑e.to_local_equiv = e := rfl
@[simp, mfld_simps] lemma coe_fst (ex : x ∈ e.source) : (e x).1 = proj x := e.proj_to_fun x ex
lemma mem_source : x ∈ e.source ↔ proj x ∈ e.base_set := by rw [e.source_eq, mem_preimage]
lemma coe_fst' (ex : proj x ∈ e.base_set) : (e x).1 = proj x := e.coe_fst (e.mem_source.2 ex)
protected lemma eq_on : eq_on (prod.fst ∘ e) proj e.source := λ x hx, e.coe_fst hx
lemma mk_proj_snd (ex : x ∈ e.source) : (proj x, (e x).2) = e x := prod.ext (e.coe_fst ex).symm rfl
lemma mk_proj_snd' (ex : proj x ∈ e.base_set) : (proj x, (e x).2) = e x :=
prod.ext (e.coe_fst' ex).symm rfl

/-- Composition of inverse and coercion from the subtype of the target. -/
def set_symm : e.target → Z := set.restrict e.to_local_equiv.symm e.target

lemma mem_target {x : B × F} : x ∈ e.target ↔ x.1 ∈ e.base_set :=
by rw [e.target_eq, prod_univ, mem_preimage]

lemma proj_symm_apply {x : B × F} (hx : x ∈ e.target) : proj (e.to_local_equiv.symm x) = x.1 :=
begin
  have := (e.coe_fst (e.to_local_equiv.map_target hx)).symm,
  rwa [← e.coe_coe, e.to_local_equiv.right_inv hx] at this
end

lemma proj_symm_apply' {b : B} {x : F} (hx : b ∈ e.base_set) :
  proj (e.to_local_equiv.symm (b, x)) = b :=
e.proj_symm_apply (e.mem_target.2 hx)

lemma apply_symm_apply {x : B × F} (hx : x ∈ e.target) : e (e.to_local_equiv.symm x) = x :=
e.to_local_equiv.right_inv hx

lemma apply_symm_apply' {b : B} {x : F} (hx : b ∈ e.base_set) :
  e (e.to_local_equiv.symm (b, x)) = (b, x) :=
e.apply_symm_apply (e.mem_target.2 hx)

@[simp, mfld_simps] lemma symm_apply_mk_proj {x : Z} (ex : x ∈ e.source) :
  e.to_local_equiv.symm (proj x, (e x).2) = x :=
by rw [← e.coe_fst ex, prod.mk.eta, ← e.coe_coe, e.to_local_equiv.left_inv ex]

@[simp, mfld_simps] lemma preimage_symm_proj_base_set :
  (e.to_local_equiv.symm ⁻¹' (proj ⁻¹' e.base_set)) ∩ e.target  = e.target :=
begin
  refine inter_eq_right_iff_subset.mpr (λ x hx, _),
  simp only [mem_preimage, local_equiv.inv_fun_as_coe, e.proj_symm_apply hx],
  exact e.mem_target.mp hx,
end

@[simp, mfld_simps] lemma preimage_symm_proj_inter (s : set B) :
  (e.to_local_equiv.symm ⁻¹' (proj ⁻¹' s)) ∩ e.base_set.prod univ = (s ∩ e.base_set).prod univ :=
begin
  refine subset.antisymm_iff.mpr ⟨(λ x hx, _), (λ x hx, mem_inter _ _)⟩,
  { rw [←e.target_eq] at hx,
    simp only [mem_inter_iff, mem_preimage, e.proj_symm_apply hx.2] at hx,
    simp only [mem_inter_eq, and_true, mem_univ, mem_prod],
    exact ⟨hx.1, e.mem_target.mp hx.2⟩, },
  { simp only [mem_inter_eq, and_true, mem_univ, mem_prod, e.mem_target.symm] at hx,
    simp only [mem_preimage, e.proj_symm_apply hx.2],
    exact hx.1, },
  { rw [←inter_univ univ, ←prod_inter_prod, mem_inter_eq] at hx,
    exact hx.2, }
end

end topological_fiber_bundle.pretrivialization

variable [topological_space Z]

/--
A structure extending local homeomorphisms, defining a local trivialization of a projection
`proj : Z → B` with fiber `F`, as a local homeomorphism between `Z` and `B × F` defined between two
sets of the form `proj ⁻¹' base_set` and `base_set × F`, acting trivially on the first coordinate.
-/
@[nolint has_inhabited_instance]
structure topological_fiber_bundle.trivialization (proj : Z → B)
  extends local_homeomorph Z (B × F) :=
(base_set      : set B)
(open_base_set : is_open base_set)
(source_eq     : source = proj ⁻¹' base_set)
(target_eq     : target = set.prod base_set univ)
(proj_to_fun   : ∀ p ∈ source, (to_local_homeomorph p).1 = proj p)

open topological_fiber_bundle

namespace topological_fiber_bundle.trivialization

variables {F} (e : trivialization F proj) {x : Z}

/-- Natural identification as a `pretrivialization`. -/
def to_pretrivialization : topological_fiber_bundle.pretrivialization F proj := { ..e }

instance : has_coe_to_fun (trivialization F proj) (λ _, Z → B × F) := ⟨λ e, e.to_fun⟩
instance : has_coe (trivialization F proj) (pretrivialization F proj) :=
⟨to_pretrivialization⟩

@[simp, mfld_simps] lemma coe_coe : ⇑e.to_local_homeomorph = e := rfl
@[simp, mfld_simps] lemma coe_fst (ex : x ∈ e.source) : (e x).1 = proj x := e.proj_to_fun x ex
protected lemma eq_on : eq_on (prod.fst ∘ e) proj e.source := λ x hx, e.coe_fst hx
lemma mem_source : x ∈ e.source ↔ proj x ∈ e.base_set := by rw [e.source_eq, mem_preimage]
lemma coe_fst' (ex : proj x ∈ e.base_set) : (e x).1 = proj x := e.coe_fst (e.mem_source.2 ex)
lemma mk_proj_snd (ex : x ∈ e.source) : (proj x, (e x).2) = e x := prod.ext (e.coe_fst ex).symm rfl
lemma mk_proj_snd' (ex : proj x ∈ e.base_set) : (proj x, (e x).2) = e x :=
prod.ext (e.coe_fst' ex).symm rfl

lemma source_inter_preimage_target_inter (s : set (B × F)) :
  e.source ∩ (e ⁻¹' (e.target ∩ s)) = e.source ∩ (e ⁻¹' s) :=
e.to_local_homeomorph.source_inter_preimage_target_inter s

@[simp, mfld_simps] lemma coe_mk (e : local_homeomorph Z (B × F)) (i j k l m) (x : Z) :
  (trivialization.mk e i j k l m : trivialization F proj) x = e x := rfl

lemma mem_target {x : B × F} : x ∈ e.target ↔ x.1 ∈ e.base_set :=
e.to_pretrivialization.mem_target

lemma map_target {x : B × F} (hx : x ∈ e.target) : e.to_local_homeomorph.symm x ∈ e.source :=
e.to_local_homeomorph.map_target hx

lemma proj_symm_apply {x : B × F} (hx : x ∈ e.target) : proj (e.to_local_homeomorph.symm x) = x.1 :=
e.to_pretrivialization.proj_symm_apply hx

lemma proj_symm_apply' {b : B} {x : F}
  (hx : b ∈ e.base_set) : proj (e.to_local_homeomorph.symm (b, x)) = b :=
e.to_pretrivialization.proj_symm_apply' hx

lemma apply_symm_apply {x : B × F} (hx : x ∈ e.target) : e (e.to_local_homeomorph.symm x) = x :=
e.to_local_homeomorph.right_inv hx

lemma apply_symm_apply'
  {b : B} {x : F} (hx : b ∈ e.base_set) : e (e.to_local_homeomorph.symm (b, x)) = (b, x) :=
e.to_pretrivialization.apply_symm_apply' hx

@[simp, mfld_simps] lemma symm_apply_mk_proj (ex : x ∈ e.source) :
  e.to_local_homeomorph.symm (proj x, (e x).2) = x :=
e.to_pretrivialization.symm_apply_mk_proj ex

lemma coe_fst_eventually_eq_proj (ex : x ∈ e.source) : prod.fst ∘ e =ᶠ[𝓝 x] proj  :=
mem_nhds_iff.2 ⟨e.source, λ y hy, e.coe_fst hy, e.open_source, ex⟩

lemma coe_fst_eventually_eq_proj' (ex : proj x ∈ e.base_set) : prod.fst ∘ e =ᶠ[𝓝 x] proj :=
e.coe_fst_eventually_eq_proj (e.mem_source.2 ex)

lemma map_proj_nhds (ex : x ∈ e.source) : map proj (𝓝 x) = 𝓝 (proj x) :=
by rw [← e.coe_fst ex, ← map_congr (e.coe_fst_eventually_eq_proj ex), ← map_map, ← e.coe_coe,
  e.to_local_homeomorph.map_nhds_eq ex, map_fst_nhds]

/-- In the domain of a bundle trivialization, the projection is continuous-/
lemma continuous_at_proj (ex : x ∈ e.source) : continuous_at proj x :=
(e.map_proj_nhds ex).le

/-- Composition of a `trivialization` and a `homeomorph`. -/
def comp_homeomorph {Z' : Type*} [topological_space Z'] (h : Z' ≃ₜ Z) :
  trivialization F (proj ∘ h) :=
{ to_local_homeomorph := h.to_local_homeomorph.trans e.to_local_homeomorph,
  base_set := e.base_set,
  open_base_set := e.open_base_set,
  source_eq := by simp [e.source_eq, preimage_preimage],
  target_eq := by simp [e.target_eq],
  proj_to_fun := λ p hp,
    have hp : h p ∈ e.source, by simpa using hp,
    by simp [hp] }

end topological_fiber_bundle.trivialization

/-- A topological fiber bundle with fiber `F` over a base `B` is a space projecting on `B`
for which the fibers are all homeomorphic to `F`, such that the local situation around each point
is a direct product. -/
def is_topological_fiber_bundle (proj : Z → B) : Prop :=
∀ x : B, ∃e : trivialization F proj, x ∈ e.base_set

/-- A trivial topological fiber bundle with fiber `F` over a base `B` is a space `Z`
projecting on `B` for which there exists a homeomorphism to `B × F` that sends `proj`
to `prod.fst`. -/
def is_trivial_topological_fiber_bundle (proj : Z → B) : Prop :=
∃ e : Z ≃ₜ (B × F), ∀ x, (e x).1 = proj x

variables {F}

lemma is_trivial_topological_fiber_bundle.is_topological_fiber_bundle
  (h : is_trivial_topological_fiber_bundle F proj) :
  is_topological_fiber_bundle F proj :=
let ⟨e, he⟩ := h in λ x,
⟨⟨e.to_local_homeomorph, univ, is_open_univ, rfl, univ_prod_univ.symm, λ x _, he x⟩, mem_univ x⟩

/-- The projection from a topological fiber bundle to its base is continuous. -/
lemma is_topological_fiber_bundle.continuous_proj (h : is_topological_fiber_bundle F proj) :
  continuous proj :=
begin
  rw continuous_iff_continuous_at,
  assume x,
  rcases h (proj x) with ⟨e, ex⟩,
  apply e.continuous_at_proj,
  rwa e.source_eq
end

/-- The projection from a topological fiber bundle to its base is an open map. -/
lemma is_topological_fiber_bundle.is_open_map_proj (h : is_topological_fiber_bundle F proj) :
  is_open_map proj :=
begin
  refine is_open_map_iff_nhds_le.2 (λ x, _),
  rcases h (proj x) with ⟨e, ex⟩,
  refine (e.map_proj_nhds _).ge,
  rwa e.source_eq
end

/-- The first projection in a product is a trivial topological fiber bundle. -/
lemma is_trivial_topological_fiber_bundle_fst :
  is_trivial_topological_fiber_bundle F (prod.fst : B × F → B) :=
⟨homeomorph.refl _, λ x, rfl⟩

/-- The first projection in a product is a topological fiber bundle. -/
lemma is_topological_fiber_bundle_fst : is_topological_fiber_bundle F (prod.fst : B × F → B) :=
is_trivial_topological_fiber_bundle_fst.is_topological_fiber_bundle

/-- The second projection in a product is a trivial topological fiber bundle. -/
lemma is_trivial_topological_fiber_bundle_snd :
  is_trivial_topological_fiber_bundle F (prod.snd : F × B → B) :=
⟨homeomorph.prod_comm _ _, λ x, rfl⟩

/-- The second projection in a product is a topological fiber bundle. -/
lemma is_topological_fiber_bundle_snd : is_topological_fiber_bundle F (prod.snd : F × B → B) :=
is_trivial_topological_fiber_bundle_snd.is_topological_fiber_bundle

lemma is_topological_fiber_bundle.comp_homeomorph {Z' : Type*} [topological_space Z']
  (e : is_topological_fiber_bundle F proj) (h : Z' ≃ₜ Z) :
  is_topological_fiber_bundle F (proj ∘ h) :=
λ x, let ⟨e, he⟩ := e x in
⟨e.comp_homeomorph h, by simpa [topological_fiber_bundle.trivialization.comp_homeomorph] using he⟩

namespace topological_fiber_bundle.trivialization

/-- If `e` is a `trivialization` of `proj : Z → B` with fiber `F` and `h` is a homeomorphism
`F ≃ₜ F'`, then `e.trans_fiber_homeomorph h` is the trivialization of `proj` with the fiber `F'`
that sends `p : Z` to `((e p).1, h (e p).2)`. -/
def trans_fiber_homeomorph {F' : Type*} [topological_space F']
  (e : trivialization F proj) (h : F ≃ₜ F') : trivialization F' proj :=
{ to_local_homeomorph := e.to_local_homeomorph.trans
    ((homeomorph.refl _).prod_congr h).to_local_homeomorph,
  base_set := e.base_set,
  open_base_set := e.open_base_set,
  source_eq := by simp [e.source_eq],
  target_eq := by { ext, simp [e.target_eq] },
  proj_to_fun := λ p hp, have p ∈ e.source, by simpa using hp, by simp [this] }

@[simp] lemma trans_fiber_homeomorph_apply {F' : Type*} [topological_space F']
  (e : trivialization F proj) (h : F ≃ₜ F') (x : Z) :
  e.trans_fiber_homeomorph h x = ((e x).1, h (e x).2) :=
rfl

/-- Coordinate transformation in the fiber induced by a pair of bundle trivializations. See also
`trivialization.coord_change_homeomorph` for a version bundled as `F ≃ₜ F`. -/
def coord_change (e₁ e₂ : trivialization F proj) (b : B) (x : F) : F :=
(e₂ $ e₁.to_local_homeomorph.symm (b, x)).2

lemma mk_coord_change
  (e₁ e₂ : trivialization F proj) {b : B}
  (h₁ : b ∈ e₁.base_set) (h₂ : b ∈ e₂.base_set) (x : F) :
  (b, e₁.coord_change e₂ b x) = e₂ (e₁.to_local_homeomorph.symm (b, x)) :=
begin
  refine prod.ext _ rfl,
  rw [e₂.coe_fst', ← e₁.coe_fst', e₁.apply_symm_apply' h₁],
  { rwa [e₁.proj_symm_apply' h₁] },
  { rwa [e₁.proj_symm_apply' h₁] }
end

lemma coord_change_apply_snd
  (e₁ e₂ : trivialization F proj) {p : Z}
  (h : proj p ∈ e₁.base_set) :
  e₁.coord_change e₂ (proj p) (e₁ p).snd = (e₂ p).snd :=
by rw [coord_change, e₁.symm_apply_mk_proj (e₁.mem_source.2 h)]

lemma coord_change_same_apply
  (e : trivialization F proj) {b : B} (h : b ∈ e.base_set) (x : F) :
  e.coord_change e b x = x :=
by rw [coord_change, e.apply_symm_apply' h]

lemma coord_change_same
  (e : trivialization F proj) {b : B} (h : b ∈ e.base_set) :
  e.coord_change e b = id :=
funext $ e.coord_change_same_apply h

lemma coord_change_coord_change
  (e₁ e₂ e₃ : trivialization F proj) {b : B}
  (h₁ : b ∈ e₁.base_set) (h₂ : b ∈ e₂.base_set) (x : F) :
  e₂.coord_change e₃ b (e₁.coord_change e₂ b x) = e₁.coord_change e₃ b x :=
begin
  rw [coord_change, e₁.mk_coord_change _ h₁ h₂, ← e₂.coe_coe,
    e₂.to_local_homeomorph.left_inv, coord_change],
  rwa [e₂.mem_source, e₁.proj_symm_apply' h₁]
end

lemma continuous_coord_change (e₁ e₂ : trivialization F proj) {b : B}
  (h₁ : b ∈ e₁.base_set) (h₂ : b ∈ e₂.base_set) :
  continuous (e₁.coord_change e₂ b) :=
begin
  refine continuous_snd.comp (e₂.to_local_homeomorph.continuous_on.comp_continuous
    (e₁.to_local_homeomorph.continuous_on_symm.comp_continuous _ _) _),
  { exact continuous_const.prod_mk continuous_id },
  { exact λ x, e₁.mem_target.2 h₁ },
  { intro x,
    rwa [e₂.mem_source, e₁.proj_symm_apply' h₁] }
end

/-- Coordinate transformation in the fiber induced by a pair of bundle trivializations,
as a homeomorphism. -/
def coord_change_homeomorph
  (e₁ e₂ : trivialization F proj) {b : B} (h₁ : b ∈ e₁.base_set) (h₂ : b ∈ e₂.base_set) :
  F ≃ₜ F :=
{ to_fun := e₁.coord_change e₂ b,
  inv_fun := e₂.coord_change e₁ b,
  left_inv := λ x, by simp only [*, coord_change_coord_change, coord_change_same_apply],
  right_inv := λ x, by simp only [*, coord_change_coord_change, coord_change_same_apply],
  continuous_to_fun := e₁.continuous_coord_change e₂ h₁ h₂,
  continuous_inv_fun := e₂.continuous_coord_change e₁ h₂ h₁ }

@[simp] lemma coord_change_homeomorph_coe
  (e₁ e₂ : trivialization F proj) {b : B} (h₁ : b ∈ e₁.base_set) (h₂ : b ∈ e₂.base_set) :
  ⇑(e₁.coord_change_homeomorph e₂ h₁ h₂) = e₁.coord_change e₂ b :=
rfl

end topological_fiber_bundle.trivialization

section comap

open_locale classical

variables {B' : Type*} [topological_space B']

/-- Given a bundle trivialization of `proj : Z → B` and a continuous map `f : B' → B`,
construct a bundle trivialization of `φ : {p : B' × Z | f p.1 = proj p.2} → B'`
given by `φ x = (x : B' × Z).1`. -/
noncomputable def topological_fiber_bundle.trivialization.comap
  (e : trivialization F proj) (f : B' → B) (hf : continuous f)
  (b' : B') (hb' : f b' ∈ e.base_set) :
  trivialization F (λ x : {p : B' × Z | f p.1 = proj p.2}, (x : B' × Z).1) :=
{ to_fun := λ p, ((p : B' × Z).1, (e (p : B' × Z).2).2),
  inv_fun := λ p, if h : f p.1 ∈ e.base_set
    then ⟨⟨p.1, e.to_local_homeomorph.symm (f p.1, p.2)⟩, by simp [e.proj_symm_apply' h]⟩
    else ⟨⟨b', e.to_local_homeomorph.symm (f b', p.2)⟩, by simp [e.proj_symm_apply' hb']⟩,
  source := {p | f (p : B' × Z).1 ∈ e.base_set},
  target := {p | f p.1 ∈ e.base_set},
  map_source' := λ p hp, hp,
  map_target' := λ p (hp : f p.1 ∈ e.base_set), by simp [hp],
  left_inv' :=
    begin
      rintro ⟨⟨b, x⟩, hbx⟩ hb,
      dsimp at *,
      have hx : x ∈ e.source, from e.mem_source.2 (hbx ▸ hb),
      ext; simp *
    end,
  right_inv' := λ p (hp : f p.1 ∈ e.base_set), by simp [*, e.apply_symm_apply'],
  open_source := e.open_base_set.preimage (hf.comp $ continuous_fst.comp continuous_subtype_coe),
  open_target := e.open_base_set.preimage (hf.comp continuous_fst),
  continuous_to_fun := ((continuous_fst.comp continuous_subtype_coe).continuous_on).prod $
    continuous_snd.comp_continuous_on $ e.continuous_to_fun.comp
      (continuous_snd.comp continuous_subtype_coe).continuous_on $
      by { rintro ⟨⟨b, x⟩, (hbx : f b = proj x)⟩ (hb : f b ∈ e.base_set),
           rw hbx at hb,
           exact e.mem_source.2 hb },
  continuous_inv_fun :=
    begin
      rw [embedding_subtype_coe.continuous_on_iff],
      suffices : continuous_on (λ p : B' × F, (p.1, e.to_local_homeomorph.symm (f p.1, p.2)))
        {p : B' × F | f p.1 ∈ e.base_set},
      { refine this.congr (λ p (hp : f p.1 ∈ e.base_set), _),
        simp [hp] },
      { refine continuous_on_fst.prod (e.to_local_homeomorph.symm.continuous_on.comp _ _),
        { exact ((hf.comp continuous_fst).prod_mk continuous_snd).continuous_on },
        { exact λ p hp, e.mem_target.2 hp } }
    end,
  base_set := f ⁻¹' e.base_set,
  source_eq := rfl,
  target_eq := by { ext, simp },
  open_base_set := e.open_base_set.preimage hf,
  proj_to_fun := λ _ _, rfl }

/-- If `proj : Z → B` is a topological fiber bundle with fiber `F` and `f : B' → B` is a continuous
map, then the pullback bundle (a.k.a. induced bundle) is the topological bundle with the total space
`{(x, y) : B' × Z | f x = proj y}` given by `λ ⟨(x, y), h⟩, x`. -/
lemma is_topological_fiber_bundle.comap (h : is_topological_fiber_bundle F proj)
  {f : B' → B} (hf : continuous f) :
  is_topological_fiber_bundle F (λ x : {p : B' × Z | f p.1 = proj p.2}, (x : B' × Z).1) :=
λ x, let ⟨e, he⟩ := h (f x) in ⟨e.comap f hf x he, he⟩

end comap

namespace topological_fiber_bundle.trivialization

lemma is_image_preimage_prod (e : trivialization F proj) (s : set B) :
  e.to_local_homeomorph.is_image (proj ⁻¹' s) (s.prod univ) :=
λ x hx, by simp [e.coe_fst', hx]

/-- Restrict a `trivialization` to an open set in the base. `-/
def restr_open (e : trivialization F proj) (s : set B)
  (hs : is_open s) : trivialization F proj :=
{ to_local_homeomorph := ((e.is_image_preimage_prod s).symm.restr
    (is_open.inter e.open_target (hs.prod is_open_univ))).symm,
  base_set := e.base_set ∩ s,
  open_base_set := is_open.inter e.open_base_set hs,
  source_eq := by simp [e.source_eq],
  target_eq := by simp [e.target_eq, prod_univ],
  proj_to_fun := λ p hp, e.proj_to_fun p hp.1 }

section piecewise

lemma frontier_preimage (e : trivialization F proj) (s : set B) :
  e.source ∩ frontier (proj ⁻¹' s) = proj ⁻¹' (e.base_set ∩ frontier s) :=
by rw [← (e.is_image_preimage_prod s).frontier.preimage_eq, frontier_prod_univ_eq,
  (e.is_image_preimage_prod _).preimage_eq, e.source_eq, preimage_inter]

/-- Given two bundle trivializations `e`, `e'` of `proj : Z → B` and a set `s : set B` such that
the base sets of `e` and `e'` intersect `frontier s` on the same set and `e p = e' p` whenever
`proj p ∈ e.base_set ∩ frontier s`, `e.piecewise e' s Hs Heq` is the bundle trivialization over
`set.ite s e.base_set e'.base_set` that is equal to `e` on `proj ⁻¹ s` and is equal to `e'`
otherwise. -/
noncomputable def piecewise (e e' : trivialization F proj) (s : set B)
  (Hs : e.base_set ∩ frontier s = e'.base_set ∩ frontier s)
  (Heq : eq_on e e' $ proj ⁻¹' (e.base_set ∩ frontier s)) :
  trivialization F proj :=
{ to_local_homeomorph := e.to_local_homeomorph.piecewise e'.to_local_homeomorph
    (proj ⁻¹' s) (s.prod univ) (e.is_image_preimage_prod s) (e'.is_image_preimage_prod s)
    (by rw [e.frontier_preimage, e'.frontier_preimage, Hs])
    (by rwa e.frontier_preimage),
  base_set := s.ite e.base_set e'.base_set,
  open_base_set := e.open_base_set.ite e'.open_base_set Hs,
  source_eq := by simp [e.source_eq, e'.source_eq],
  target_eq := by simp [e.target_eq, e'.target_eq, prod_univ],
  proj_to_fun := by rintro p (⟨he, hs⟩|⟨he, hs⟩); simp * }

/-- Given two bundle trivializations `e`, `e'` of a topological fiber bundle `proj : Z → B`
over a linearly ordered base `B` and a point `a ∈ e.base_set ∩ e'.base_set` such that
`e` equals `e'` on `proj ⁻¹' {a}`, `e.piecewise_le_of_eq e' a He He' Heq` is the bundle
trivialization over `set.ite (Iic a) e.base_set e'.base_set` that is equal to `e` on points `p`
such that `proj p ≤ a` and is equal to `e'` otherwise. -/
noncomputable def piecewise_le_of_eq [linear_order B] [order_topology B]
  (e e' : trivialization F proj) (a : B) (He : a ∈ e.base_set) (He' : a ∈ e'.base_set)
  (Heq : ∀ p, proj p = a → e p = e' p) :
  trivialization F proj :=
e.piecewise e' (Iic a)
  (set.ext $ λ x, and.congr_left_iff.2 $ λ hx,
    by simp [He, He', mem_singleton_iff.1 (frontier_Iic_subset _ hx)])
  (λ p hp, Heq p $ frontier_Iic_subset _ hp.2)

/-- Given two bundle trivializations `e`, `e'` of a topological fiber bundle `proj : Z → B` over a
linearly ordered base `B` and a point `a ∈ e.base_set ∩ e'.base_set`, `e.piecewise_le e' a He He'`
is the bundle trivialization over `set.ite (Iic a) e.base_set e'.base_set` that is equal to `e` on
points `p` such that `proj p ≤ a` and is equal to `((e' p).1, h (e' p).2)` otherwise, where
`h = `e'.coord_change_homeomorph e _ _` is the homeomorphism of the fiber such that
`h (e' p).2 = (e p).2` whenever `e p = a`. -/
noncomputable def piecewise_le [linear_order B] [order_topology B]
  (e e' : trivialization F proj) (a : B) (He : a ∈ e.base_set) (He' : a ∈ e'.base_set) :
  trivialization F proj :=
e.piecewise_le_of_eq (e'.trans_fiber_homeomorph (e'.coord_change_homeomorph e He' He))
  a He He' $ by { unfreezingI {rintro p rfl },
    ext1,
    { simp [e.coe_fst', e'.coe_fst', *] },
    { simp [e'.coord_change_apply_snd, *] } }

/-- Given two bundle trivializations `e`, `e'` over disjoint sets, `e.disjoint_union e' H` is the
bundle trivialization over the union of the base sets that agrees with `e` and `e'` over their
base sets. -/
noncomputable def disjoint_union (e e' : trivialization F proj)
  (H : disjoint e.base_set e'.base_set) :
  trivialization F proj :=
{ to_local_homeomorph := e.to_local_homeomorph.disjoint_union e'.to_local_homeomorph
    (λ x hx, by { rw [e.source_eq, e'.source_eq] at hx, exact H hx })
    (λ x hx, by { rw [e.target_eq, e'.target_eq] at hx, exact H ⟨hx.1.1, hx.2.1⟩ }),
  base_set := e.base_set ∪ e'.base_set,
  open_base_set := is_open.union e.open_base_set e'.open_base_set,
  source_eq := congr_arg2 (∪) e.source_eq e'.source_eq,
  target_eq := (congr_arg2 (∪) e.target_eq e'.target_eq).trans union_prod.symm,
  proj_to_fun :=
    begin
      rintro p (hp|hp'),
      { show (e.source.piecewise e e' p).1 = proj p,
        rw [piecewise_eq_of_mem, e.coe_fst]; exact hp },
      { show (e.source.piecewise e e' p).1 = proj p,
        rw [piecewise_eq_of_not_mem, e'.coe_fst hp'],
        simp only [e.source_eq, e'.source_eq] at hp' ⊢,
        exact λ h, H ⟨h, hp'⟩ }
    end }

/-- If `h` is a topological fiber bundle over a conditionally complete linear order,
then it is trivial over any closed interval. -/
lemma _root_.is_topological_fiber_bundle.exists_trivialization_Icc_subset
  [conditionally_complete_linear_order B] [order_topology B]
  (h : is_topological_fiber_bundle F proj) (a b : B) :
  ∃ e : trivialization F proj, Icc a b ⊆ e.base_set :=
begin
  classical,
  obtain ⟨ea, hea⟩ : ∃ ea : trivialization F proj, a ∈ ea.base_set := h a,
  -- If `a < b`, then `[a, b] = ∅`, and the statement is trivial
  cases le_or_lt a b with hab hab; [skip, exact ⟨ea, by simp *⟩],
  /- Let `s` be the set of points `x ∈ [a, b]` such that `proj` is trivializable over `[a, x]`.
  We need to show that `b ∈ s`. Let `c = Sup s`. We will show that `c ∈ s` and `c = b`. -/
  set s : set B := {x ∈ Icc a b | ∃ e : trivialization F proj, Icc a x ⊆ e.base_set},
  have ha : a ∈ s, from ⟨left_mem_Icc.2 hab, ea, by simp [hea]⟩,
  have sne : s.nonempty := ⟨a, ha⟩,
  have hsb : b ∈ upper_bounds s, from λ x hx, hx.1.2,
  have sbd : bdd_above s := ⟨b, hsb⟩,
  set c := Sup s,
  have hsc : is_lub s c, from is_lub_cSup sne sbd,
  have hc : c ∈ Icc a b, from ⟨hsc.1 ha, hsc.2 hsb⟩,
  obtain ⟨-, ec : trivialization F proj, hec : Icc a c ⊆ ec.base_set⟩ : c ∈ s,
  { cases hc.1.eq_or_lt with heq hlt, { rwa ← heq },
    refine ⟨hc, _⟩,
    /- In order to show that `c ∈ s`, consider a trivialization `ec` of `proj` over a neighborhood
    of `c`. Its base set includes `(c', c]` for some `c' ∈ [a, c)`. -/
    rcases h c with ⟨ec, hc⟩,
    obtain ⟨c', hc', hc'e⟩ : ∃ c' ∈ Ico a c, Ioc c' c ⊆ ec.base_set :=
      (mem_nhds_within_Iic_iff_exists_mem_Ico_Ioc_subset hlt).1
        (mem_nhds_within_of_mem_nhds $ is_open.mem_nhds ec.open_base_set hc),
    /- Since `c' < c = Sup s`, there exists `d ∈ s ∩ (c', c]`. Let `ead` be a trivialization of
    `proj` over `[a, d]`. Then we can glue `ead` and `ec` into a trivialization over `[a, c]`. -/
    obtain ⟨d, ⟨hdab, ead, had⟩, hd⟩ : ∃ d ∈ s, d ∈ Ioc c' c := hsc.exists_between hc'.2,
    refine ⟨ead.piecewise_le ec d (had ⟨hdab.1, le_rfl⟩) (hc'e hd), subset_ite.2 _⟩,
    refine ⟨λ x hx, had ⟨hx.1.1, hx.2⟩, λ x hx, hc'e ⟨hd.1.trans (not_le.1 hx.2), hx.1.2⟩⟩ },
  /- So, `c ∈ s`. Let `ec` be a trivialization of `proj` over `[a, c]`.  If `c = b`, then we are
  done. Otherwise we show that `proj` can be trivialized over a larger interval `[a, d]`,
  `d ∈ (c, b]`, hence `c` is not an upper bound of `s`. -/
  cases hc.2.eq_or_lt with heq hlt, { exact ⟨ec, heq ▸ hec⟩ },
  suffices : ∃ (d ∈ Ioc c b) (e : trivialization F proj), Icc a d ⊆ e.base_set,
  { rcases this with ⟨d, hdcb, hd⟩,
    exact ((hsc.1 ⟨⟨hc.1.trans hdcb.1.le, hdcb.2⟩, hd⟩).not_lt hdcb.1).elim },
  /- Since the base set of `ec` is open, it includes `[c, d)` (hence, `[a, d)`) for some
  `d ∈ (c, b]`. -/
  obtain ⟨d, hdcb, hd⟩ : ∃ d ∈ Ioc c b, Ico c d ⊆ ec.base_set :=
    (mem_nhds_within_Ici_iff_exists_mem_Ioc_Ico_subset hlt).1
      (mem_nhds_within_of_mem_nhds $ is_open.mem_nhds ec.open_base_set (hec ⟨hc.1, le_rfl⟩)),
  have had : Ico a d ⊆ ec.base_set,
    from subset.trans Ico_subset_Icc_union_Ico (union_subset hec hd),
  by_cases he : disjoint (Iio d) (Ioi c),
  { /- If `(c, d) = ∅`, then let `ed` be a trivialization of `proj` over a neighborhood of `d`.
    Then the disjoint union of `ec` restricted to `(-∞, d)` and `ed` restricted to `(c, ∞)` is
    a trivialization over `[a, d]`. -/
    rcases h d with ⟨ed, hed⟩,
    refine ⟨d, hdcb, (ec.restr_open (Iio d) is_open_Iio).disjoint_union
      (ed.restr_open (Ioi c) is_open_Ioi) (he.mono (inter_subset_right _ _)
        (inter_subset_right _ _)), λ x hx, _⟩,
    rcases hx.2.eq_or_lt with rfl|hxd,
    exacts [or.inr ⟨hed, hdcb.1⟩, or.inl ⟨had ⟨hx.1, hxd⟩, hxd⟩] },
  { /- If `(c, d)` is nonempty, then take `d' ∈ (c, d)`. Since the base set of `ec` includes
    `[a, d)`, it includes `[a, d'] ⊆ [a, d)` as well. -/
    rw [disjoint_left] at he, push_neg at he, rcases he with ⟨d', hdd' : d' < d, hd'c⟩,
    exact ⟨d', ⟨hd'c, hdd'.le.trans hdcb.2⟩, ec, subset.trans (Icc_subset_Ico_right hdd') had⟩ }
end

end piecewise

end topological_fiber_bundle.trivialization

end topological_fiber_bundle

/-! ### Constructing topological fiber bundles -/

namespace bundle

variable (E : B → Type*)

attribute [mfld_simps] proj total_space_mk coe_fst coe_snd_map_apply coe_snd_map_smul

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)) :=
topological_space.induced (proj (trivial B F)) t₁ ⊓
  topological_space.induced (trivial.proj_snd B F) t₂

end bundle

/-- Core data defining a locally trivial topological bundle with fiber `F` over a topological
space `B`. Note that "bundle" is used in its mathematical sense. This is the (computer science)
bundled version, i.e., all the relevant data is contained in the following structure. A family of
local trivializations is indexed by a type `ι`, on open subsets `base_set i` for each `i : ι`.
Trivialization changes from `i` to `j` are given by continuous maps `coord_change i j` from
`base_set i ∩ base_set j` to the set of homeomorphisms of `F`, but we express them as maps
`B → F → F` and require continuity on `(base_set i ∩ base_set j) × F` to avoid the topology on the
space of continuous maps on `F`. -/
@[nolint has_inhabited_instance]
structure topological_fiber_bundle_core (ι : Type*) (B : Type*) [topological_space B]
  (F : Type*) [topological_space F] :=
(base_set          : ι → set B)
(is_open_base_set  : ∀ i, is_open (base_set i))
(index_at          : B → ι)
(mem_base_set_at   : ∀ x, x ∈ base_set (index_at x))
(coord_change      : ι → ι → B → F → F)
(coord_change_self : ∀ i, ∀ x ∈ base_set i, ∀ v, coord_change i i x v = v)
(coord_change_continuous : ∀ i j, continuous_on (λp : B × F, coord_change i j p.1 p.2)
                                               (set.prod ((base_set i) ∩ (base_set j)) univ))
(coord_change_comp : ∀ i j k, ∀ x ∈ (base_set i) ∩ (base_set j) ∩ (base_set k), ∀ v,
  (coord_change j k x) (coord_change i j x v) = coord_change i k x v)

namespace topological_fiber_bundle_core

variables [topological_space B] [topological_space F] (Z : topological_fiber_bundle_core ι B F)

include Z

/-- The index set of a topological fiber bundle core, as a convenience function for dot notation -/
@[nolint unused_arguments has_inhabited_instance]
def index := ι

/-- The base space of a topological fiber bundle core, as a convenience function for dot notation -/
@[nolint unused_arguments, reducible]
def base := B

/-- The fiber of a topological fiber bundle core, as a convenience function for dot notation and
typeclass inference -/
@[nolint unused_arguments has_inhabited_instance]
def fiber (x : B) := F

section fiber_instances
local attribute [reducible] fiber

instance topological_space_fiber (x : B) : topological_space (Z.fiber x) := by apply_instance

end fiber_instances

/-- The total space of the topological fiber bundle, as a convenience function for dot notation.
It is by definition equal to `bundle.total_space Z.fiber`, a.k.a. `Σ x, Z.fiber x` but with a
different name for typeclass inference. -/
@[nolint unused_arguments, reducible]
def total_space := bundle.total_space Z.fiber

/-- The projection from the total space of a topological fiber bundle core, on its base. -/
@[reducible, simp, mfld_simps] def proj : Z.total_space → B := bundle.proj Z.fiber

/-- Local homeomorphism version of the trivialization change. -/
def triv_change (i j : ι) : local_homeomorph (B × F) (B × F) :=
{ source      := set.prod (Z.base_set i ∩ Z.base_set j) univ,
  target      := set.prod (Z.base_set i ∩ Z.base_set j) univ,
  to_fun      := λp, ⟨p.1, Z.coord_change i j p.1 p.2⟩,
  inv_fun     := λp, ⟨p.1, Z.coord_change j i p.1 p.2⟩,
  map_source' := λp hp, by simpa using hp,
  map_target' := λp hp, by simpa using hp,
  left_inv'   := begin
    rintros ⟨x, v⟩ hx,
    simp only [prod_mk_mem_set_prod_eq, mem_inter_eq, and_true, mem_univ] at hx,
    rw [Z.coord_change_comp, Z.coord_change_self],
    { exact hx.1 },
    { simp [hx] }
  end,
  right_inv'  := begin
    rintros ⟨x, v⟩ hx,
    simp only [prod_mk_mem_set_prod_eq, mem_inter_eq, and_true, mem_univ] at hx,
    rw [Z.coord_change_comp, Z.coord_change_self],
    { exact hx.2 },
    { simp [hx] },
  end,
  open_source :=
    (is_open.inter (Z.is_open_base_set i) (Z.is_open_base_set j)).prod is_open_univ,
  open_target :=
    (is_open.inter (Z.is_open_base_set i) (Z.is_open_base_set j)).prod is_open_univ,
  continuous_to_fun  :=
    continuous_on.prod continuous_fst.continuous_on (Z.coord_change_continuous i j),
  continuous_inv_fun := by simpa [inter_comm]
    using continuous_on.prod continuous_fst.continuous_on (Z.coord_change_continuous j i) }

@[simp, mfld_simps] lemma mem_triv_change_source (i j : ι) (p : B × F) :
  p ∈ (Z.triv_change i j).source ↔ p.1 ∈ Z.base_set i ∩ Z.base_set j :=
by { erw [mem_prod], simp }

/-- Associate to a trivialization index `i : ι` the corresponding trivialization, i.e., a bijection
between `proj ⁻¹ (base_set i)` and `base_set i × F`. As the fiber above `x` is `F` but read in the
chart with index `index_at x`, the trivialization in the fiber above x is by definition the
coordinate change from i to `index_at x`, so it depends on `x`.
The local trivialization will ultimately be a local homeomorphism. For now, we only introduce the
local equiv version, denoted with a prime. In further developments, avoid this auxiliary version,
and use `Z.local_triv` instead.
-/
def local_triv_as_local_equiv (i : ι) : local_equiv Z.total_space (B × F) :=
{ source      := Z.proj ⁻¹' (Z.base_set i),
  target      := set.prod (Z.base_set i) univ,
  inv_fun     := λp, ⟨p.1, Z.coord_change i (Z.index_at p.1) p.1 p.2⟩,
  to_fun      := λp, ⟨p.1, Z.coord_change (Z.index_at p.1) i p.1 p.2⟩,
  map_source' := λp hp,
    by simpa only [set.mem_preimage, and_true, set.mem_univ, set.prod_mk_mem_set_prod_eq] using hp,
  map_target' := λp hp,
    by simpa only [set.mem_preimage, and_true, set.mem_univ, set.mem_prod] using hp,
  left_inv'   := begin
    rintros ⟨x, v⟩ hx,
    change x ∈ Z.base_set i at hx,
    dsimp only,
    rw [Z.coord_change_comp, Z.coord_change_self],
    { exact Z.mem_base_set_at _ },
    { simp only [hx, mem_inter_eq, and_self, mem_base_set_at] }
  end,
  right_inv' := begin
    rintros ⟨x, v⟩ hx,
    simp only [prod_mk_mem_set_prod_eq, and_true, mem_univ] at hx,
    rw [Z.coord_change_comp, Z.coord_change_self],
    { exact hx },
    { simp only [hx, mem_inter_eq, and_self, mem_base_set_at] }
  end }

variable (i : ι)

lemma mem_local_triv_as_local_equiv_source (p : Z.total_space) :
  p ∈ (Z.local_triv_as_local_equiv i).source ↔ p.1 ∈ Z.base_set i :=
iff.rfl

lemma mem_local_triv_as_local_equiv_target (p : B × F) :
  p ∈ (Z.local_triv_as_local_equiv i).target ↔ p.1 ∈ Z.base_set i :=
by { erw [mem_prod], simp only [and_true, mem_univ] }

lemma local_triv_as_local_equiv_apply (p : Z.total_space) :
  (Z.local_triv_as_local_equiv i) p = ⟨p.1, Z.coord_change (Z.index_at p.1) i p.1 p.2⟩ := rfl

/-- The composition of two local trivializations is the trivialization change Z.triv_change i j. -/
lemma local_triv_as_local_equiv_trans (i j : ι) :
  (Z.local_triv_as_local_equiv i).symm.trans
    (Z.local_triv_as_local_equiv j) ≈ (Z.triv_change i j).to_local_equiv :=
begin
  split,
  { ext x, simp only [mem_local_triv_as_local_equiv_target] with mfld_simps, refl, },
  { rintros ⟨x, v⟩ hx,
    simp only [triv_change, local_triv_as_local_equiv, local_equiv.symm, true_and, prod.mk.inj_iff,
      prod_mk_mem_set_prod_eq, local_equiv.trans_source, mem_inter_eq, and_true, mem_preimage, proj,
      mem_univ, local_equiv.coe_mk, eq_self_iff_true, local_equiv.coe_trans, bundle.proj] at hx ⊢,
    simp only [Z.coord_change_comp, hx, mem_inter_eq, and_self, mem_base_set_at], }
end

variable (ι)

/-- Topological structure on the total space of a topological bundle created from core, designed so
that all the local trivialization are continuous. -/
instance to_topological_space : topological_space (bundle.total_space Z.fiber) :=
topological_space.generate_from $ ⋃ (i : ι) (s : set (B × F)) (s_open : is_open s),
  {(Z.local_triv_as_local_equiv i).source ∩ (Z.local_triv_as_local_equiv i) ⁻¹' s}

variable {ι}

lemma open_source' (i : ι) : is_open (Z.local_triv_as_local_equiv i).source :=
begin
  apply topological_space.generate_open.basic,
  simp only [exists_prop, mem_Union, mem_singleton_iff],
  refine ⟨i, set.prod (Z.base_set i) univ, (Z.is_open_base_set i).prod is_open_univ, _⟩,
  ext p,
  simp only [local_triv_as_local_equiv_apply, prod_mk_mem_set_prod_eq, mem_inter_eq, and_self,
    mem_local_triv_as_local_equiv_source, and_true, mem_univ, mem_preimage],
end

open topological_fiber_bundle

/-- Extended version of the local trivialization of a fiber bundle constructed from core,
registering additionally in its type that it is a local bundle trivialization. -/
def local_triv (i : ι) : trivialization F Z.proj :=
{ base_set      := Z.base_set i,
  open_base_set := Z.is_open_base_set i,
  source_eq     := rfl,
  target_eq     := rfl,
  proj_to_fun   := λ p hp, by { simp only with mfld_simps, refl },
  open_source := Z.open_source' i,
  open_target := (Z.is_open_base_set i).prod is_open_univ,
  continuous_to_fun := begin
    rw continuous_on_open_iff (Z.open_source' i),
    assume s s_open,
    apply topological_space.generate_open.basic,
    simp only [exists_prop, mem_Union, mem_singleton_iff],
    exact ⟨i, s, s_open, rfl⟩
  end,
  continuous_inv_fun := begin
    apply continuous_on_open_of_generate_from ((Z.is_open_base_set i).prod is_open_univ),
    assume t ht,
    simp only [exists_prop, mem_Union, mem_singleton_iff] at ht,
    obtain ⟨j, s, s_open, ts⟩ : ∃ j s, is_open s ∧ t =
      (local_triv_as_local_equiv Z j).source ∩ (local_triv_as_local_equiv Z j) ⁻¹' s := ht,
    rw ts,
    simp only [local_equiv.right_inv, preimage_inter, local_equiv.left_inv],
    let e := Z.local_triv_as_local_equiv i,
    let e' := Z.local_triv_as_local_equiv j,
    let f := e.symm.trans e',
    have : is_open (f.source ∩ f ⁻¹' s),
    { rw [(Z.local_triv_as_local_equiv_trans i j).source_inter_preimage_eq],
      exact (continuous_on_open_iff (Z.triv_change i j).open_source).1
        ((Z.triv_change i j).continuous_on) _ s_open },
    convert this using 1,
    dsimp [local_equiv.trans_source],
    rw [← preimage_comp, inter_assoc],
    refl,
  end,
  to_local_equiv := Z.local_triv_as_local_equiv i }

/-- A topological fiber bundle constructed from core is indeed a topological fiber bundle. -/
protected theorem is_topological_fiber_bundle : is_topological_fiber_bundle F Z.proj :=
λx, ⟨Z.local_triv (Z.index_at x), Z.mem_base_set_at x⟩

/-- The projection on the base of a topological bundle created from core is continuous -/
lemma continuous_proj : continuous Z.proj :=
Z.is_topological_fiber_bundle.continuous_proj

/-- The projection on the base of a topological bundle created from core is an open map -/
lemma is_open_map_proj : is_open_map Z.proj :=
Z.is_topological_fiber_bundle.is_open_map_proj

/-- Preferred local trivialization of a fiber bundle constructed from core, at a given point, as
a bundle trivialization -/
def local_triv_at (b : B) : trivialization F Z.proj :=
Z.local_triv (Z.index_at b)

@[simp, mfld_simps] lemma local_triv_at_def (b : B) :
  Z.local_triv (Z.index_at b) = Z.local_triv_at b := rfl

/-- If an element of `F` is invariant under all coordinate changes, then one can define a
corresponding section of the fiber bundle, which is continuous. This applies in particular to the
zero section of a vector bundle. Another example (not yet defined) would be the identity
section of the endomorphism bundle of a vector bundle. -/
lemma continuous_const_section (v : F)
  (h : ∀ i j, ∀ x ∈ (Z.base_set i) ∩ (Z.base_set j), Z.coord_change i j x v = v) :
  continuous (show B → Z.total_space, from λ x, ⟨x, v⟩) :=
begin
  apply continuous_iff_continuous_at.2 (λ x, _),
  have A : Z.base_set (Z.index_at x) ∈ 𝓝 x :=
    is_open.mem_nhds (Z.is_open_base_set (Z.index_at x)) (Z.mem_base_set_at x),
  apply ((Z.local_triv_at x).to_local_homeomorph.continuous_at_iff_continuous_at_comp_left _).2,
  { simp only [(∘)] with mfld_simps,
    apply continuous_at_id.prod,
    have : continuous_on (λ (y : B), v) (Z.base_set (Z.index_at x)) := continuous_on_const,
    apply (this.congr _).continuous_at A,
    assume y hy,
    simp only [h, hy, mem_base_set_at] with mfld_simps },
  { exact A }
end

@[simp, mfld_simps] lemma local_triv_as_local_equiv_coe :
  ⇑(Z.local_triv_as_local_equiv i) = Z.local_triv i := rfl

@[simp, mfld_simps] lemma local_triv_as_local_equiv_source :
  (Z.local_triv_as_local_equiv i).source = (Z.local_triv i).source := rfl

@[simp, mfld_simps] lemma local_triv_as_local_equiv_target :
  (Z.local_triv_as_local_equiv i).target = (Z.local_triv i).target := rfl

@[simp, mfld_simps] lemma local_triv_as_local_equiv_symm :
  (Z.local_triv_as_local_equiv i).symm = (Z.local_triv i).to_local_equiv.symm := rfl

@[simp, mfld_simps] lemma base_set_at : Z.base_set i = (Z.local_triv i).base_set := rfl

@[simp, mfld_simps] lemma local_triv_apply (p : Z.total_space) :
  (Z.local_triv i) p = ⟨p.1, Z.coord_change (Z.index_at p.1) i p.1 p.2⟩ := rfl

@[simp, mfld_simps] lemma mem_local_triv_source (p : Z.total_space) :
  p ∈ (Z.local_triv i).source ↔ p.1 ∈ (Z.local_triv i).base_set := iff.rfl

@[simp, mfld_simps] lemma mem_local_triv_target (p : B × F) :
  p ∈ (Z.local_triv i).target ↔ p.1 ∈ (Z.local_triv i).base_set :=
trivialization.mem_target _

@[simp, mfld_simps] lemma local_triv_symm_fst (p : B × F) :
  (Z.local_triv i).to_local_homeomorph.symm p =
    ⟨p.1, Z.coord_change i (Z.index_at p.1) p.1 p.2⟩ := rfl

@[simp, mfld_simps] lemma local_triv_at_apply (b : B) (a : F) :
  ((Z.local_triv_at b) ⟨b, a⟩) = ⟨b, a⟩ :=
by { rw [local_triv_at, local_triv_apply, coord_change_self], exact Z.mem_base_set_at b }

@[simp, mfld_simps] lemma mem_local_triv_at_base_set (b : B) :
  b ∈ (Z.local_triv_at b).base_set :=
by { rw [local_triv_at, ←base_set_at], exact Z.mem_base_set_at b, }

open bundle

/-- The inclusion of a fiber into the total space is a continuous map. -/
lemma continuous_total_space_mk (b : B) : continuous (λ a, total_space_mk Z.fiber b a) :=
begin
  rw [continuous_iff_le_induced, topological_fiber_bundle_core.to_topological_space],
  apply le_induced_generate_from,
  simp only [total_space_mk, mem_Union, mem_singleton_iff, local_triv_as_local_equiv_source,
    local_triv_as_local_equiv_coe],
  rintros s ⟨i, t, ht, rfl⟩,
  rw [←((Z.local_triv i).source_inter_preimage_target_inter t), preimage_inter, ←preimage_comp,
    trivialization.source_eq],
  apply is_open.inter,
  { simp only [bundle.proj, proj, ←preimage_comp],
    by_cases (b ∈ (Z.local_triv i).base_set),
    { rw preimage_const_of_mem h, exact is_open_univ, },
    { rw preimage_const_of_not_mem h, exact is_open_empty, }},
  { simp only [function.comp, local_triv_apply],
    rw [preimage_inter, preimage_comp],
    by_cases (b ∈ Z.base_set i),
    { have hc : continuous (λ (x : Z.fiber b), (Z.coord_change (Z.index_at b) i b) x) := begin
        rw continuous_iff_continuous_on_univ,
        refine ((Z.coord_change_continuous (Z.index_at b) i).comp ((continuous_const).prod_mk
          continuous_id).continuous_on) (by { convert (subset_univ univ),
            exact mk_preimage_prod_right (mem_inter (Z.mem_base_set_at b) h), }) end,
      exact hc.is_open_preimage _ ((continuous.prod.mk b).is_open_preimage _
        ((Z.local_triv i).open_target.inter ht)), },
    { rw [(Z.local_triv i).target_eq, ←base_set_at, mk_preimage_prod_right_eq_empty h,
        preimage_empty, empty_inter],
      exact is_open_empty, }}
end

end topological_fiber_bundle_core

variables (F) {Z : Type*} [topological_space B] [topological_space F] {proj : Z → B}

open topological_fiber_bundle

/-- This structure permits to define a fiber bundle when trivializations are given as local
equivalences but there is not yet a topology on the total space. The total space is hence given a
topology in such a way that there is a fiber bundle structure for which the local equivalences
are also local homeomorphism and hence local trivializations. -/
@[nolint has_inhabited_instance]
structure topological_fiber_prebundle (proj : Z → B) :=
(pretrivialization_at : B → pretrivialization F proj)
(mem_base_pretrivialization_at : ∀ x : B, x ∈ (pretrivialization_at x).base_set)
(continuous_triv_change : ∀ x y : B, continuous_on ((pretrivialization_at x) ∘
  (pretrivialization_at y).to_local_equiv.symm) ((pretrivialization_at y).target ∩
  ((pretrivialization_at y).to_local_equiv.symm ⁻¹' (pretrivialization_at x).source)))

namespace topological_fiber_prebundle

variables {F} (a : topological_fiber_prebundle F proj) (x : B)

/-- Topology on the total space that will make the prebundle into a bundle. -/
def total_space_topology (a : topological_fiber_prebundle F proj) : topological_space Z :=
⨆ x : B, coinduced (a.pretrivialization_at x).set_symm (subtype.topological_space)

lemma continuous_symm_pretrivialization_at : @continuous_on _ _ _ a.total_space_topology
  (a.pretrivialization_at x).to_local_equiv.symm (a.pretrivialization_at x).target :=
begin
  refine id (λ z H, id (λ U h, preimage_nhds_within_coinduced' H
    (a.pretrivialization_at x).open_target (le_def.1 (nhds_mono _) U h))),
  exact le_supr _ x,
end

lemma is_open_source_pretrivialization_at :
  @is_open _ a.total_space_topology (a.pretrivialization_at x).source :=
begin
  letI := a.total_space_topology,
  refine is_open_supr_iff.mpr (λ y, is_open_coinduced.mpr (is_open_induced_iff.mpr
    ⟨(a.pretrivialization_at x).target, (a.pretrivialization_at x).open_target, _⟩)),
  rw [pretrivialization.set_symm, restrict, (a.pretrivialization_at x).target_eq,
    (a.pretrivialization_at x).source_eq, preimage_comp, subtype.preimage_coe_eq_preimage_coe_iff,
    (a.pretrivialization_at y).target_eq, prod_inter_prod, inter_univ,
    pretrivialization.preimage_symm_proj_inter],
end

lemma is_open_target_pretrivialization_at_inter (x y : B) :
  is_open ((a.pretrivialization_at y).to_local_equiv.target ∩
  (a.pretrivialization_at y).to_local_equiv.symm ⁻¹' (a.pretrivialization_at x).source) :=
begin
  letI := a.total_space_topology,
  obtain ⟨u, hu1, hu2⟩ := continuous_on_iff'.mp (a.continuous_symm_pretrivialization_at y)
    (a.pretrivialization_at x).source (a.is_open_source_pretrivialization_at x),
  rw [inter_comm, hu2],
  exact hu1.inter (a.pretrivialization_at y).open_target,
end

/-- Promotion from a `pretrivialization` to a `trivialization`. -/
def trivialization_at (a : topological_fiber_prebundle F proj) (x : B) :
  @trivialization B F Z _ _ a.total_space_topology proj :=
{ open_source := a.is_open_source_pretrivialization_at x,
  continuous_to_fun := begin
    letI := a.total_space_topology,
    refine continuous_on_iff'.mpr (λ s hs, ⟨(a.pretrivialization_at x) ⁻¹' s ∩
      (a.pretrivialization_at x).source, (is_open_supr_iff.mpr (λ y, _)),
      by { rw [inter_assoc, inter_self], refl }⟩),
    rw [is_open_coinduced, is_open_induced_iff],
    obtain ⟨u, hu1, hu2⟩ := continuous_on_iff'.mp (a.continuous_triv_change x y) s hs,
    have hu3 := congr_arg (λ s, (λ x : (a.pretrivialization_at y).target, (x : B × F)) ⁻¹' s) hu2,
    simp only [subtype.coe_preimage_self, preimage_inter, univ_inter] at hu3,
    refine ⟨u ∩ (a.pretrivialization_at y).to_local_equiv.target ∩
      ((a.pretrivialization_at y).to_local_equiv.symm ⁻¹' (a.pretrivialization_at x).source), _, by
      { simp only [preimage_inter, inter_univ, subtype.coe_preimage_self, hu3.symm], refl }⟩,
    rw inter_assoc,
    exact hu1.inter (a.is_open_target_pretrivialization_at_inter x y),
  end,
  continuous_inv_fun := a.continuous_symm_pretrivialization_at x,
  ..(a.pretrivialization_at x) }

lemma is_topological_fiber_bundle :
  @is_topological_fiber_bundle B F Z _ _ a.total_space_topology proj :=
λ x, ⟨a.trivialization_at x, a.mem_base_pretrivialization_at x ⟩

lemma continuous_proj : @continuous _ _ a.total_space_topology _ proj :=
by { letI := a.total_space_topology, exact a.is_topological_fiber_bundle.continuous_proj, }

end topological_fiber_prebundle


import ..logic ..list .preformula .formula -- .has_ptm .has_atom

open list

def preterm_lia.const : preterm_lia → int
| (preterm_lia.var k)     := 0
| (preterm_lia.cst c)     := c
| (preterm_lia.lmul c k)  := 0
| (preterm_lia.rmul k c)  := 0
| (preterm_lia.neg t)     := -t.const
| (preterm_lia.add t1 t2) := t1.const + t2.const
| (preterm_lia.sub t1 t2) := t1.const - t2.const

def preterm_lia.coeffs : preterm_lia → list int
| (preterm_lia.var k)     := update_nth_force [] k 1 0
| (preterm_lia.cst c)     := []
| (preterm_lia.lmul c k)  := update_nth_force [] k c 0
| (preterm_lia.rmul k c)  := update_nth_force [] k c 0
| (preterm_lia.neg t)     := map_neg t.coeffs
| (preterm_lia.add t1 t2) := comp_add t1.coeffs t2.coeffs
| (preterm_lia.sub t1 t2) := comp_sub t1.coeffs t2.coeffs.

def preatom_lia.normalize : preatom_lia → atom
| (preatom_lia.le t1 t2) :=
  atom.le (t1.const - t2.const).to_znum
    (map int.to_znum (comp_sub t2.coeffs t1.coeffs))
| (preatom_lia.dvd d t) :=
  atom.dvd d.to_znum t.const.to_znum (map int.to_znum t.coeffs)
| (preatom_lia.ndvd d t) :=
  atom.ndvd d.to_znum t.const.to_znum (map int.to_znum t.coeffs)

def preformula_lia.normalize : preformula_lia → formula
| preformula_lia.true      := formula.true
| preformula_lia.false     := formula.false
| (preformula_lia.atom a)  := formula.atom a.normalize
| (preformula_lia.not p)   := p.normalize.not
| (preformula_lia.or  p q) := formula.or  p.normalize q.normalize
| (preformula_lia.and p q) := formula.and p.normalize q.normalize
| (preformula_lia.imp p q) := formula.or p.normalize.not q.normalize
| (preformula_lia.iff p q) :=
  formula.or (formula.and p.normalize q.normalize)
    (formula.and p.normalize.not q.normalize.not)
| (preformula_lia.fa p)    := p.normalize.not.ex.not
| (preformula_lia.ex p)    := p.normalize.ex

lemma preterm_lia.eval_eq_aux {z} : ∀ {k zs},
  z * option.iget (nth zs k) = int.dot_prod (update_nth_force nil k z 0) zs
| 0 [] :=
  by simp [int.dot_prod, update_nth_force]
| 0 (z::zs) :=
  begin
    simp [nth, update_nth_force,
    int.dot_prod, int.nil_dot_prod]
  end
| (k+1) [] :=
  by simp [int.dot_prod, update_nth_force]
| (k+1) (z::zs) :=
  begin simp [nth, update_nth_force, int.dot_prod], apply preterm_lia.eval_eq_aux end

lemma preterm_lia.eval_eq {zs} :
  ∀ (t), preterm_lia.eval zs t = t.const + (int.dot_prod t.coeffs zs)
| (preterm_lia.var k) :=
  begin
    simp [preterm_lia.const, preterm_lia.coeffs, preterm_lia.eval],
          rw preterm_lia.eval_eq_aux.symm, simp [one_mul]
  end
| (preterm_lia.cst c) :=
  begin
    simp [preterm_lia.const, preterm_lia.coeffs,
          preterm_lia.eval, int.nil_dot_prod]
  end
| (preterm_lia.lmul k z) :=
  begin
    simp [preterm_lia.const, preterm_lia.coeffs, preterm_lia.eval],
    apply preterm_lia.eval_eq_aux
  end
| (preterm_lia.rmul z k) :=
  begin
    simp [preterm_lia.const, preterm_lia.coeffs, preterm_lia.eval, mul_comm _ k],
    apply preterm_lia.eval_eq_aux
  end
| (preterm_lia.neg t) :=
  begin
    simp [preterm_lia.eval, preterm_lia.const, preterm_lia.coeffs,
    preterm_lia.eval_eq t, neg_add, int.map_neg_dot_prod.symm]
  end
| (preterm_lia.add t1 t2) :=
  begin
    simp [preterm_lia.eval, preterm_lia.const, preterm_lia.coeffs,
    preterm_lia.eval_eq t1, preterm_lia.eval_eq t2, int.comp_add_dot_prod]
  end
| (preterm_lia.sub t1 t2) :=
  begin
    simp [preterm_lia.eval, preterm_lia.const, preterm_lia.coeffs,
    preterm_lia.eval_eq t1, preterm_lia.eval_eq t2, int.comp_sub_dot_prod]
  end

lemma preatom_lia.eval_normalize (zs : list int) :
∀ (p : preatom_lia), p.normalize.eval (map int.to_znum zs) ↔ p.eval zs
| (t1 ≤* t2):=
begin
  simp [preatom_lia.normalize, formula.eval, atom.eval,
    preterm_lia.const, preterm_lia.coeffs, preatom_lia.eval],
  rw [preterm_lia.eval_eq, preterm_lia.eval_eq, ← znum.le_to_int',
    int.to_znum_to_int, znum.dot_prod_to_int'], simp [map],
  have hf : (znum.to_int ∘ int.to_znum) = id,
  { rw function.funext_iff, intro x, simp [znum.to_int, int.to_znum] },
  rw [hf, map_id, map_id, int.comp_sub_dot_prod,
    ← add_sub_assoc, ← int.add_le_iff_le_sub],
end
| (d ∣* t):=
  begin
    simp [preatom_lia.normalize, formula.eval, atom.eval,
      preterm_lia.const, preterm_lia.coeffs, preatom_lia.eval],
    rw [preterm_lia.eval_eq, ← znum.dvd_to_int',
      int.to_znum_to_int, znum.add_to_int,
      int.to_znum_to_int, znum.dot_prod_to_int',
      int.map_to_znum_to_int, int.map_to_znum_to_int]
  end
| (d ∤* t):=
  begin
    simp [preatom_lia.normalize, formula.eval, atom.eval,
      preterm_lia.const, preterm_lia.coeffs, preatom_lia.eval],
    rw [preterm_lia.eval_eq, ← znum.dvd_to_int',
      int.to_znum_to_int, znum.add_to_int,
      int.to_znum_to_int, znum.dot_prod_to_int',
      int.map_to_znum_to_int, int.map_to_znum_to_int]
  end

meta def preformula_lia.eval_normalize_simp :=
`[simp [formula.eval, preformula_lia.eval,
  preformula_lia.normalize, preformula_lia.eval_normalize]] --, preatom_lia.eval_normalize_iff]]

lemma preformula_lia.eval_normalize :
forall {p : preformula_lia} {zs : list int},
  p.normalize.eval (map int.to_znum zs) ↔ p.eval zs
| ⊤* ds := by preformula_lia.eval_normalize_simp
| ⊥* ds := by preformula_lia.eval_normalize_simp
| (A* a) ds :=
  begin
    preformula_lia.eval_normalize_simp,
    apply preatom_lia.eval_normalize
  end
| (¬* φ) ds := begin preformula_lia.eval_normalize_simp end
| (φ ∨* ψ) ds :=
begin preformula_lia.eval_normalize_simp end
| (φ ∧* ψ) ds :=
begin preformula_lia.eval_normalize_simp end
| (φ →* ψ) ds :=
begin
  preformula_lia.eval_normalize_simp,
  simp [@imp_iff_not_or _ _ (classical.dec _)]
end
| (φ ↔* ψ) ds :=
  begin
    preformula_lia.eval_normalize_simp,
    apply iff_iff_and_or_not_and_not.symm,
    apply classical.dec
  end
| (∀* φ) ds :=
  begin
    preformula_lia.eval_normalize_simp, simp [not_not_iff],
    constructor; intros h x,
    { apply preformula_lia.eval_normalize.elim_left, apply h },
    { cases ((int.bijective_to_znum).right x) with a ha,
      subst ha, have h := preformula_lia.eval_normalize.elim_right (h a), apply h }
  end
| (∃* φ) ds :=
  begin
    preformula_lia.eval_normalize_simp,
    constructor; intro h; cases h with x hx,
    { cases ((int.bijective_to_znum).right x) with a ha,
      subst ha, existsi a, apply preformula_lia.eval_normalize.elim_left, apply hx },
    { existsi (x.to_znum),
      have h := preformula_lia.eval_normalize.elim_right hx, apply h }
  end

meta def normalize : tactic unit :=
pexact ``(preformula_lia.eval_normalize.elim_left _)


import Mathlib.Logic.Basic

variable {α : Type} [LT α] [LE α] [DecidableRel $ @LT.lt α _] [DecidableRel $ @LE.le α _]

-- mathlib3 stuff (not ported yet)
theorem not_le {a b : α} : ¬ a ≤ b ↔ b < a := sorry
theorem lt_min_iff {a b c : α} : a < min b c ↔ (a < b ∧ a < c) := sorry
theorem max_lt_iff {a b c : α} : max a b < c ↔ (a < c ∧ b < c) := sorry

theorem leOfLes {a₁ a₁' a₂ a₂' : α}
    (h : ¬(a₂ ≤ a₁' ∨ a₂' ≤ a₁))
    (hle  : (a₁, a₂).1 < (a₁, a₂).2)
    (hle' : (a₁', a₂').1 < (a₁', a₂').2) :
    (max a₁ a₁', min a₂ a₂').fst < (max a₁ a₁', min a₂ a₂').snd := by
  rw [not_or_distrib] at h
  simp only [lt_min_iff, max_lt_iff]
  simp only [not_le] at h
  cases h
  constructor
  all_goals (constructor assumption assumption)

/- This structure characterizes my open interval -/
structure Interval (α : Type) [LT α] where
  i  : α × α
  le : i.1 < i.2

/- A set is a list of intervals -/
abbrev Set α [LT α] := List (Interval α)

namespace Set

/- Whether a set contains a cetain element -/
def hasMem : Set α → α → Prop
  | ⟨(a₁, a₂), _⟩ :: is, a => (a₁ < a ∧ a < a₂) ∨ hasMem is a
  | []                 , _ => False

theorem hasMemOfAppendRight {S S' : Set α} (h : hasMem S a) :
    hasMem (S' ++ S) a := by
  induction S' with
    | nil         => exact h
    | cons _ _ hi => exact Or.inr hi

theorem hasMemOfAppendLeft {S S' : Set α} (h : hasMem S a) :
    hasMem (S ++ S') a := by
  induction S with
    | nil          => simp only [hasMem] at h
    | cons i ss hi => cases h with
      | inl h' => exact Or.inl h'
      | inr h' => exact Or.inr $ hi h'

theorem hasMemOrOfAppend {S S' : Set α} (h : hasMem (S ++ S') a) :
    hasMem S a ∨ hasMem S' a := by
  induction S with
    | nil =>
      simp [hasMem] at *
      exact h
    | cons i ss hi => cases h with
      | inl h' => exact Or.inl $ Or.inl h'
      | inr h' => cases hi h' with
        | inl hi' => exact Or.inl $ Or.inr hi'
        | inr hi' => exact Or.inr hi'

/- Removes parts of a set that are outside of a certain interval -/
def prune : Set α → Interval α → Set α
  | ⟨(a₁, a₂), hle⟩ :: ss, ⟨(a₁', a₂'), hle'⟩ =>
    if h : a₂ ≤ a₁' ∨ a₂' ≤ a₁ then
      -- throwing current interval away
      prune ss ⟨(a₁', a₂'), hle'⟩
    else
      -- pruning cutting current interval
      ⟨(max a₁ a₁', min a₂ a₂'), leOfLes h hle hle'⟩ :: (prune ss ⟨(a₁', a₂'), hle'⟩)
  | [], _ => []

theorem hasMemOfPrune {S : Set α} {i : Interval α} {a : α} (h : (S.prune i).hasMem a) :
    S.hasMem a := sorry

theorem hasMemOfPruneWith {S : Set α} {i : Interval α} {a : α}
    (h : S.hasMem a) (hi : i.i.1 < a ∧ a < i.i.2) :
    (S.prune i).hasMem a := sorry

theorem inLimitsOfHasMemPrune {S : Set α} {i : Interval α}
    (h : hasMem (prune S i) a) :
    i.1.1 < a ∧ a < i.1.2 := sorry

/- (A₁ ∪ A₂ ∪ ⋯) ∩ (B₁ ∪ B₂ ∪ ⋯) = ((A₁ ∪ A₂ ∪ ⋯) ∩ B₁) ∪ ((A₁ ∪ A₂ ∪ ⋯) ∩ B₂) ∪ ⋯ -/
def intersec : Set α → Set α → Set α
  | ss, i :: ss' => (ss.prune i) ++ ss.intersec ss'
  | _, _         => []

theorem intersecIsCorrectMP {S₁ S₂ : Set α} {a : α}
    (h : S₁.hasMem a ∧ S₂.hasMem a) :
    (S₁.intersec S₂).hasMem a := by
  induction S₂ with
    | nil => simp [hasMem] at h
    | cons i ss hi =>
      have h₁ := h.1
      have h₂ := h.2
      cases h₂ with
        | inl h₂' => exact hasMemOfAppendLeft $ hasMemOfPruneWith h₁ h₂'
        | inr h₂' => exact hasMemOfAppendRight $ hi $ And.intro h₁ h₂'

theorem intersecIsCorrectMPR {S₁ S₂ : Set α} {a : α}
    (h : (S₁.intersec S₂).hasMem a) : S₁.hasMem a ∧ S₂.hasMem a := by
  constructor
  induction S₂ with
    | nil         => simp only [hasMem] at h
    | cons _ _ hi =>
      cases hasMemOrOfAppend h with
        | inl h' => exact hasMemOfPrune h'
        | inr h' => exact hi h'
  induction S₂ with
    | nil         => simp only [hasMem] at h
    | cons _ _ hi =>
      cases hasMemOrOfAppend h with
        | inl h' => exact Or.inl $ inLimitsOfHasMemPrune h'
        | inr h' => exact Or.inr $ hi h'

theorem intersecIsCorrect {S₁ S₂ : Set α} {a : α} :
    S₁.hasMem a ∧ S₂.hasMem a ↔ (S₁.intersec S₂).hasMem a :=
  Iff.intro intersecIsCorrectMP intersecIsCorrectMPR

end Set


/-
Copyright (c) 2022 Daniel Roca González. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Daniel Roca González
-/
import analysis.inner_product_space.projection
import analysis.inner_product_space.dual
import analysis.normed_space.banach
import analysis.normed_space.operator_norm
import topology.metric_space.antilipschitz

/-!
# The Lax-Milgram Theorem

We consider an Hilbert space `V` over `ℝ`
equipped with a bounded bilinear form `B : V →L[ℝ] V →L[ℝ] ℝ`.

Recall that a bilinear form `B : V →L[ℝ] V →L[ℝ] ℝ` is *coercive*
iff `∃ C, (0 < C) ∧ ∀ u, C * ∥u∥ * ∥u∥ ≤ B u u`.
Under the hypothesis that `B` is coercive
we prove the Lax-Milgram theorem:
that is, the map `inner_product_space.continuous_linear_map_of_bilin` from
`analysis.inner_product_space.dual` can be upgraded to a continuous equivalence
`is_coercive.continuous_linear_equiv_of_bilin : V ≃L[ℝ] V`.

## References

* We follow the notes of Peter Howard's Spring 2020 *M612: Partial Differential Equations* lecture,
  see[howard]

## Tags

dual, Lax-Milgram
-/

noncomputable theory
open is_R_or_C linear_map continuous_linear_map inner_product_space
open_locale real_inner_product_space nnreal

universe u

namespace is_coercive
variables {V : Type u} [inner_product_space ℝ V] [complete_space V]
variables {B : V →L[ℝ] V →L[ℝ] ℝ}

local postfix `♯`:1025 := @continuous_linear_map_of_bilin ℝ V _ _ _

lemma bounded_below (coercive : is_coercive B) :
  ∃ C, 0 < C ∧ ∀ v, C * ∥v∥ ≤ ∥B♯ v∥ :=
begin
  rcases coercive with ⟨C, C_ge_0, coercivity⟩,
  refine ⟨C, C_ge_0, _⟩,
  intro v,
  by_cases h : 0 < ∥v∥,
  { refine (mul_le_mul_right h).mp _,
    calc C * ∥v∥ * ∥v∥
        ≤ B v v : coercivity v
    ... = ⟪B♯ v, v⟫_ℝ : (continuous_linear_map_of_bilin_apply ℝ B v v).symm
    ... ≤ ∥B♯ v∥ * ∥v∥ : real_inner_le_norm (B♯ v) v, },
  { have : v = 0 := by simpa using h,
    simp [this], }
end

lemma antilipschitz (coercive : is_coercive B) :
  ∃ C : ℝ≥0, 0 < C ∧ antilipschitz_with C B♯ :=
begin
  rcases coercive.bounded_below with ⟨C, C_pos, below_bound⟩,
  refine ⟨(C⁻¹).to_nnreal, real.to_nnreal_pos.mpr (inv_pos.mpr C_pos), _⟩,
  refine continuous_linear_map.antilipschitz_of_bound B♯ _,
  simp_rw [real.coe_to_nnreal',
    max_eq_left_of_lt (inv_pos.mpr C_pos),
    ←inv_mul_le_iff (inv_pos.mpr C_pos)],
  simpa using below_bound,
end

lemma ker_eq_bot (coercive : is_coercive B) : B♯.ker = ⊥ :=
begin
  rw [←ker_coe, linear_map.ker_eq_bot],
  rcases coercive.antilipschitz with ⟨_, _, antilipschitz⟩,
  exact antilipschitz.injective,
end

lemma closed_range (coercive : is_coercive B) : is_closed (B♯.range : set V) :=
begin
  rcases coercive.antilipschitz with ⟨_, _, antilipschitz⟩,
  exact antilipschitz.is_closed_range B♯.uniform_continuous,
end

lemma range_eq_top (coercive : is_coercive B) : B♯.range = ⊤ :=
begin
  haveI := coercive.closed_range.complete_space_coe,
  rw ← B♯.range.orthogonal_orthogonal,
  rw submodule.eq_top_iff',
  intros v w mem_w_orthogonal,
  rcases coercive with ⟨C, C_pos, coercivity⟩,
  obtain rfl : w = 0,
  { rw [←norm_eq_zero, ←mul_self_eq_zero, ←mul_right_inj' C_pos.ne', mul_zero, ←mul_assoc],
    apply le_antisymm,
    { calc C * ∥w∥ * ∥w∥
          ≤ B w w : coercivity w
      ... = ⟪B♯ w, w⟫_ℝ : (continuous_linear_map_of_bilin_apply ℝ B w w).symm
      ... = 0 : mem_w_orthogonal _ ⟨w, rfl⟩ },
    { exact mul_nonneg (mul_nonneg C_pos.le (norm_nonneg w)) (norm_nonneg w) } },
  exact inner_zero_left,
end

/--
The Lax-Milgram equivalence of a coercive bounded bilinear operator:
for all `v : V`, `continuous_linear_equiv_of_bilin B v` is the unique element `V`
such that `⟪continuous_linear_equiv_of_bilin B v, w⟫ = B v w`.
The Lax-Milgram theorem states that this is a continuous equivalence.
-/
def continuous_linear_equiv_of_bilin (coercive : is_coercive B) : V ≃L[ℝ] V :=
continuous_linear_equiv.of_bijective
  B♯
  coercive.ker_eq_bot
  coercive.range_eq_top

@[simp]
lemma continuous_linear_equiv_of_bilin_apply (coercive : is_coercive B) (v w : V) :
  ⟪coercive.continuous_linear_equiv_of_bilin v, w⟫_ℝ = B v w :=
continuous_linear_map_of_bilin_apply ℝ B v w

lemma unique_continuous_linear_equiv_of_bilin (coercive : is_coercive B) {v f : V}
  (is_lax_milgram : (∀ w, ⟪f, w⟫_ℝ = B v w)) :
  f = coercive.continuous_linear_equiv_of_bilin v :=
unique_continuous_linear_map_of_bilin ℝ B is_lax_milgram

end is_coercive


import tactic.norm_num

example : 374 + (32 - (2 * 8123) : ℤ) - 61 * 50 = 86 + 32 * 32 - 4 * 5000
      ∧ 43 ≤ 74 + (33 : ℤ) :=
by { norm_num }

example : (1103 : ℤ) ≤ (2102 : ℤ) :=
by { norm_num }

example : (11047462383473829263 : ℤ) ≤ (21048574677772382462 : ℤ) :=
by { norm_num,  }

example : (210485742382937847263 : ℤ) ≤ (1104857462382937847262 : ℤ) :=
by { norm_num }

example : (210485987642382937847263 : ℕ) ≤ (11048512347462382937847262 : ℕ) :=
by { norm_num }

example : (210485987642382937847263 : ℚ) ≤ (11048512347462382937847262 : ℚ) :=
by { norm_num }

example : (210485987642382937847263 : ℚ) < (11048512347462382937847262 : ℚ) :=
by { norm_num }

example : (210485987642382937847263 : ℚ) ≠ (11048512347462382937847262 : ℚ) :=
by { norm_num }

example (x : ℕ) : ℕ :=
let n : ℕ := by apply_normed (2^32 - 71) in n

#eval by apply_normed (2^32 - 71)


import breen_deligne.homotopy

noncomputable theory

open_locale nnreal big_operators

namespace breen_deligne

namespace data

variables (BD : data) (r r' : ℝ≥0)

lemma b_exists [hr : fact (r < 1)] (x : ℝ≥0) [fact (0 < x)] :
  ∃ b : ℕ, r ^ b ≤ x⁻¹ :=
begin
  suffices : ∃ b : ℕ, (r ^ b : ℝ) < x⁻¹,
  { rcases this with ⟨b, hb⟩,
    refine ⟨b, le_of_lt _⟩,
    rwa [← nnreal.coe_lt_coe, nnreal.coe_pow, nnreal.coe_inv] },
  refine exists_pow_lt_of_lt_one _ hr.out,
  simp only [nnreal.coe_pos, inv_pos],
  exact ‹fact (0 < x)›.out
end

/-- The smallest `b` such that `r ^ b ≤ x⁻¹`.  -/
def b [hr : fact (r < 1)] (x : ℝ≥0) [fact (0 < x)] := nat.find (b_exists r x)

/-- Example of a very suitable sequence of constants for given Breen--Deligne data. -/
noncomputable def κ (BD : data) (r r' : ℝ≥0) [hr : fact (r < 1)] : ℕ → ℝ≥0
| 0     := 1
| (n+1) := (max 1 (BD.d (n+1) n).factor)⁻¹ * (r' ^ (b r $ max 1 (BD.d (n+1) n).bound) * κ n)

instance c__pos [hr : fact (r < 1)] [hr' : fact (0 < r')] :
  Π (n : ℕ), fact (0 < κ BD r r' n)
| 0     := ⟨zero_lt_one⟩
| (n+1) :=
begin
  dsimp [κ],
  refine ⟨mul_pos (nnreal.inv_pos.mpr _) (mul_pos (pow_pos hr'.1 _) $ (c__pos _).1)⟩,
  exact lt_of_lt_of_le zero_lt_one (le_max_left _ _)
end

instance c_very_suitable [hr : fact (r < 1)] [hr' : fact (0 < r')] :
  BD.very_suitable r r' (BD.κ r r') :=
very_suitable.of_succ _ _ _ _
begin
  intro n,
  let N := max 1 (BD.d (n+1) n).bound,
  let b : ℕ := b r (max 1 (BD.d (n+1) n).bound),
  let c : ℝ≥0 := max 1 (BD.d (n+1) n).factor,
  refine ⟨N, b, c * BD.κ r r' (n+1), le_max_right _ _, _, _, _⟩,
  { intros g hg i,
    exact mul_le_mul' ((universal_map.le_factor _ _ hg _).trans $ le_max_right _ _) le_rfl },
  { rw [mul_comm, nnreal.mul_le_iff_le_inv, mul_one],
    convert nat.find_spec (b_exists r (max 1 (BD.d (n+1) n).bound)),
    { simp only [nat.cast_max, nat.cast_one], refl },
    { apply ne_of_gt,
      simp only [lt_max_iff, nat.cast_max, nat.cast_one, nat.cast_pos, zero_lt_one, true_or], } },
  { by_cases hc : c = 0,
    { simp only [hc, zero_mul, zero_le'] },
    rw nnreal.mul_le_iff_le_inv hc,
    dsimp [κ], exact le_rfl }
end
(λ i, (data.c__pos _ _ _ i).1)

end data

namespace package

variables (BD : package) (r r' : ℝ≥0)

/-- Example of an adept sequence of constants for
a given Breen--Deligne package `BD` and constants `κ`. -/
def κ' (BD : package) (κ : ℕ → ℝ≥0) : ℕ → ℝ≥0
| 0     := 1
| (n+1) := (BD.homotopy.hom n (n + 1)).factor * rescale_constants κ 2 n * (κ (n + 1))⁻¹

instance κ'_adept (κ : ℕ → ℝ≥0) [∀ i, fact (0 < κ i)] :
  package.adept BD κ (κ' BD κ) :=
{ htpy_suitable' :=
  begin
    intros n,
    apply universal_map.suitable_of_factor_le,
    dsimp [κ'],
    rw [inv_mul_cancel_right₀, mul_inv_cancel_right₀],
    { dsimp [rescale_constants], refine mul_ne_zero (ne_of_gt $ fact.out _) _, norm_num, },
    { exact ne_of_gt (fact.out _) }
  end }

end package

end breen_deligne

#lint-


/-
Copyright (c) 2022 Georgi Kocharyan. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.txt.
Author: Georgi Kocharyan.
-/

import .isomaction
import .quasiisometry
import .geodesicspace
import .cayleygraphs
import tactic
import data.real.basic
import topology.metric_space.isometry
import data.list.basic

import algebra.big_operators

open_locale big_operators

open classical

lemma sum_le_prod (n:ℕ) (x: ℕ → ℝ) (l:ℝ)
  (h: ∀ i, x i ≤ l) : ∑i in finset.range (n+1), x i ≤ ((n+1):ℝ)*l :=
begin
  induction n with d hd,
    {dsimp,
    rw finset.sum_singleton,
    have g : x 0 ≤ l,
      {exact h 0, },
    simp [h],},
    {
      rw [finset.sum_range_succ, add_mul],
      apply add_le_add,
      simp ,
      exact hd,
      simp [h d.succ],
    }
end

variables {α : Type*} {β : Type*} [inhabited β] [group α] [inhabited α]

lemma intS  (c : ℝ) (b : ℝ) (cpos: c > 0) (bnonneg: b ≥ 0)  [quasigeodesic_space β c b cpos bnonneg]
  [isom_action α β] (s : set β) (g : α) (h : α) (x : β) (y : β) (hx: x ∈ isom_img g s)
  (hy : y ∈ isom_img h s) (hd : dist x y ≤ 2*b)
  : ∃ t ∈ (proper_action_set α (set_closed_ball s (2*b))), g*t = h
   :=
begin
use g⁻¹*h,
split,
have hy' : y ∈ set_closed_ball (isom_img g s) (2*b),
  {use x, split, exact hx, rw dist_comm, exact hd,},
rw ← isom_of_set_closed_ball at hy',
have hy'' : y ∈ isom_img h (set_closed_ball s (2*b)),
rcases hy with ⟨ w, ⟨ ws, hw ⟩⟩, dsimp at hw,
use w,
split,
{ apply self_set_closed_ball, linarith, exact ws },
exact hw, rw proper_action_set, dsimp,
have i1 : g⁻¹ • y ∈ isom_img (g⁻¹ * g) (set_closed_ball s (2 * b)),
  { apply isom_img_mul, exact hy', },
simp at i1,
rw ← isom_img_one at i1,
have i2 : g⁻¹ • y ∈ isom_img (g⁻¹ * h) (set_closed_ball s (2 * b)),
  { apply isom_img_mul, exact hy'', },
apply set.nonempty.ne_empty,
rw set.nonempty_def,
use g⁻¹ • y,
exact ⟨i1, i2⟩,
simp,
end

-- lemma intS'  (c : ℝ) (b : ℝ) (cpos: c > 0) (bnonneg: b ≥ 0)  [quasigeodesic_space β c b cpos bnonneg]
--   [isom_action α β] (s : set β) (g : α) (h : α) (x : β) (y : β) (hx: x ∈ isom_img g s)
--   (hy : y ∈ isom_img h s) (hd : dist x y ≤ 2*b)
--   : g⁻¹ * h ∈ (@proper_action_set α _ _ _ _ (set_closed_ball s (2*b))) :=
-- begin
--   have h : ∃ t ∈ (@proper_action_set α _ _ _ _ (set_closed_ball s (2*b))), g*t = h,
--     apply intS c b cpos bnonneg s g h x y hx hy hd,
--   rcases h with ⟨t, ⟨ht1, ht2⟩ ⟩,
--   have hi : t = g⁻¹ * h,
--     rw ← ht2, simp,
--   rw ← hi,
--   exact ht1,
-- end

-- namespace list

-- theorem subdiv {L : ℝ} (Lnonneg : L ≥ 0) {d : ℝ} (dpos : d > 0)
--  : ∃ l : list ℝ, l.head = 0 ∧ (l.reverse).head = L ∧ (∀ i : ℕ, (l.inth i)-(l.inth (i-1)) ≤ d ∧ l.inth i ≥ 0 ∧ l.inth i ≤ L) :=
-- begin
-- sorry
-- end

-- def right_inv_list (g : α) : list α → list α
-- | nil := [g]
-- | (cons a l) :=  (g* a⁻¹) :: ((a*(l.head)) :: (erasep (λ x, true) (right_inv_list l)))

-- lemma prod_of_inv (g : α) (l : list α) : g = list.prod (right_inv_list g l) :=
-- begin
-- sorry
-- end

lemma closure_mul (g' : α) (K : set α) (hg : g' ∈ subgroup.closure K)(g : α) : (∃ k ∈ K, g'*k = g) → g ∈ subgroup.closure K :=
sorry

lemma sm_aux (c : ℝ) (b : ℝ) (cpos: c > 0) (bpos: b > 0)  [quasigeodesic_space β c b cpos (le_of_lt bpos)]
  [isom_action α β] (s : set β) (htrans: translates_cover α s) (f : ℝ → β) (x : β) (xs : x ∈ s) (n : ℕ)
   : ∀ (g : α) (L : ℝ) (Lnonneg : L ≥ 0) (hL' : L ≤ (n : ℝ)*(b/c)), ((∃ y ∈ isom_img g s, quasigeodesic L Lnonneg f x y c b) → g ∈ subgroup.closure (proper_action_set α (set_closed_ball s (2*b)))) :=
begin
-- have harch : ∃ n : ℕ, L ≤ (n : real)*b/c,
-- --apply real.archimedean.arch,
--   sorry,
-- cases harch with n hn,
induction n with d hd,
rintros g L Lnonneg hL ⟨ y, ⟨hy, qg⟩⟩,
simp at hL,
have Lzero : L = 0, by apply le_antisymm hL Lnonneg,
have gfix : y = x,
  apply degenerate_quasigeodesic f y x c b,
  -- rw Lzero at qg,
  sorry,
apply subgroup.subset_closure,
rw @isom_img_one α β _ _ _ s at xs,
have dzero : dist x y ≤ 2*b,
  begin
    rw gfix,
    rw dist_self x,
    apply mul_nonneg,
    linarith,
    exact le_of_lt bpos,
  end,
have hg : ∃ (t : α) (H : t ∈ proper_action_set α (set_closed_ball s (2 * b))), 1 * t = g, from intS c b cpos (le_of_lt bpos) s 1 g x y xs hy dzero,
simp at hg,
exact hg,
let L' := (d : real)*(b/c),
have L'nonneg : L' ≥ 0,
  { apply mul_nonneg, simp, apply (le_of_lt (div_pos bpos cpos)), },
rintros g L Lnonneg hL ⟨y, ⟨hy, qg⟩⟩,
by_cases L ≤ d*(b/c),
  apply hd g L Lnonneg h,
  use y,
  exact ⟨hy, qg⟩,
have hL' : L' ≤ L,
  apply le_of_lt,
  apply lt_of_not_ge,
  exact h,
have hq : quasigeodesic L' L'nonneg f x (f L') c b, from trunc_quasigeodesic L Lnonneg f x y c b hL' L'nonneg qg,
simp at *,
have L'cov : ∃ g' : α, (f L') ∈ isom_img g' s, from exists_cover_element htrans (f L'),
cases L'cov with g' hg',
have g'_mem_closure : g' ∈ subgroup.closure (proper_action_set α (set_closed_ball s (2 * b))),
  from hd g' L' L'nonneg le_rfl (f L') hg' hq,
have smalldistdom : abs (L' - L) ≤ b/c,
{ rw abs_sub_comm,
  rw abs_of_nonneg,
  simp,
  rw ← one_mul (b/c),
  rw ← add_mul,
  rwa add_comm,
  linarith, },
have smalldistimg : dist (f L') (f L) ≤ 2*b,
  calc
    dist (f L') (f L) ≤ c * abs(L' - L) + b : begin exact (qg.2.2 L' ⟨L'nonneg, hL'⟩ L ⟨Lnonneg, le_rfl⟩).2, end
    ...               ≤ c * (b/c) + b : begin exact add_le_add (mul_le_mul_of_nonneg_left smalldistdom (le_of_lt cpos)) (le_rfl), end
    ...               = b + b : by sorry
    ...               = 2*b : by linarith,
apply closure_mul g' (proper_action_set α (set_closed_ball s (2 * b))) g'_mem_closure g,
apply intS c b cpos (le_of_lt bpos) s g' g (f L') (f L) hg' _ smalldistimg,
rw qg.2.1,
exact hy,
end

-- Svarc-Milnor part 1: S generates G

theorem metric_svarcmilnor1  (c : ℝ) (b : ℝ) (cpos: c > 0) (bpos: b > 0)
  [quasigeodesic_space β c b cpos (le_of_lt bpos)] [isom_action α β]
  (s : set β) (htrans: translates_cover α s) (finitediam : metric.bounded s)
   : α = subgroup.closure (proper_action_set α (set_closed_ball s (2*b))) :=
begin
  rw generates_iff_subset,
  intro g,
  let x' : β, exact default,
  let a := cover_element htrans x',
  have snonempty: ∃ x, x ∈ s,
    sorry,
  let x := classical.some snonempty,
  have xs : x ∈ s, from classical.some_spec snonempty,
  -- have imgnonempty: ∃ x, x ∈ isom_img g s,
  --   use g • x,
  --   apply isom_img_self,
  --   apply classical.some_spec snonempty,
  -- let y := classical.some imgnonempty,
  have h : conn_by_quasigeodesic' x (g • x) c b, by apply quasigeodesic_space.quasigeodesics x (g • x),
  rcases h with ⟨ L, Lnonneg, f, qif⟩,
  have harch : ∃ n : ℕ, L ≤ (n : real)*(b/c),
  --  apply archimedean.arch L (div_pos bpos cpos),
    sorry,
  cases harch with n hn,
  apply sm_aux c b cpos bpos s htrans f x xs n g L Lnonneg hn,
  use g • x,
  exact ⟨isom_img_self g s xs, qif⟩,

end

variables (c : ℝ) (b : ℝ) (cpos: c > 0) (bpos: b > 0)

open metric

-- auxiliary lemmas about metric spaces

lemma svarcmilnor_qdense
  [quasigeodesic_space β c b cpos (le_of_lt bpos)] [isom_action α β]
  (s : set β) (htrans: translates_cover α s) (finitediam : metric.bounded s) (x : β) (xs : x ∈ s)
   : has_quasidense_image (λ g : α, g • x) :=
begin
  cases finitediam with k hk,
  have knonneg : k ≥ 0,
    rw ← dist_self x,
    apply hk x xs x xs,
  use (k+1),
  split,
  { linarith, },
  intro y,
  have h : ∃ g : α, y ∈ isom_img g s, from exists_cover_element htrans y,
  rcases h with ⟨g, ⟨z, hz⟩ ⟩,
  use g,
  dsimp at *,
  rw ← hz.2,
  rw ← dist_of_isom,
  have dxz : dist x z ≤ k, from hk x xs z hz.1,
  linarith,
end

lemma proper_action_set_bound (b : ℝ) [pseudo_metric_space β] [isom_action α β]
  (s : set β) (finitediam : metric.bounded s)
  (x : β) (xs : x ∈ s)
  : ∃ k : ℝ, ∀ t ∈ proper_action_set α (set_closed_ball s (2*b)), dist x (t • x) ≤ k :=
  begin
  cases finitediam with k hk,
  use 2*(k+2*b),
  intros t ht,
  have h : ∃ y : β, y ∈ set_closed_ball s (2*b) ∩ (isom_img t (set_closed_ball s (2*b))),
    rw ← set.nonempty_def,
    rw ← set.ne_empty_iff_nonempty,
    exact ht,
  rcases h with ⟨y, ⟨⟨z, ⟨zs, hz⟩⟩, ⟨a, ⟨⟨m, ⟨ms, hm⟩⟩, ha⟩⟩⟩ ⟩,
  have dxy : dist x y ≤ k + 2*b,
  { apply le_trans (dist_triangle x z y),
    apply add_le_add (hk x xs z zs),
    rwa dist_comm, },
  dsimp at ha,
  have dyt : dist y (t • x) ≤ k + 2*b,
    rw ← ha,
    rw ← dist_of_isom,
  { apply le_trans (dist_triangle a m x),
    rw add_comm,
    apply add_le_add (hk m ms x xs),
    exact hm, },
  apply le_trans (dist_triangle x y (t • x)),
  linarith,
  end

variables (s : set β) [quasigeodesic_space β c b cpos (le_of_lt bpos)]
  [isom_action α β]
  (htrans: @translates_cover α β _ _ _ s) (finitediam : metric.bounded s)

-- auxiliary lemmas about word metric

lemma word_metric_bound_of_quasigeodesic
  (L : ℝ) (Lnonneg : L ≥ 0) (f : ℝ → β)
  (g : α) (x : β)
  (hf : quasigeodesic L Lnonneg f x (g • x) c b) (n : ℕ)
  (hL : (n:ℝ)*(b/c) ≤ L ∧ L < ((n : ℝ)+1)*(b/c)) :
  ((@word_metric α _ _ (@proper_action_set α β _ _ _ (set_closed_ball s (2*b)))
  (metric_svarcmilnor1 c b cpos bpos s htrans finitediam))).dist 1 g ≤ n := sorry

variables (g : α)

#check (((@word_metric α _ _ (@proper_action_set α β _ _ _ (set_closed_ball s (2*b)))
 (metric_svarcmilnor1 c b cpos bpos s htrans finitediam))).dist) g g

lemma gen_bound
  :
  ∃ k > 0, ∀ g : α, ∀ x ∈ s, dist x (g • x) ≤
  k * (@word_metric α _ _ (@proper_action_set α β _ _ _ (set_closed_ball s (2*b)))
   (metric_svarcmilnor1 c b cpos bpos s htrans finitediam)).dist 1 g :=
  sorry

-- notation `cayleydist` := word_metric
--(@word_metric α _ _ (@proper_action_set α β _ _ _ (set_closed_ball s (2*b))) (metric_svarcmilnor1 c b cpos bpos s htrans finitediam)).dist

theorem metric_svarcmilnor2
  (x : β) (xs : x ∈ s)
   : @is_QI α β (@word_metric α _ _ (@proper_action_set α β _ _ _ (set_closed_ball s (2*b)))
    (metric_svarcmilnor1 c b cpos bpos s htrans finitediam)) _ (λ g : α, g • x) :=
begin
let cayleydist := (@word_metric α _ _ (@proper_action_set α β _ _ _ (set_closed_ball s (2*b)))
  (metric_svarcmilnor1 c b cpos bpos s htrans finitediam)).dist,
apply QIE_with_quasidense_image_is_QI,
have hk : ∃ k > 0, ∀ g : α, ∀ x ∈ s, dist x (g • x) ≤ k * (cayleydist 1 g), from gen_bound c b cpos bpos s htrans finitediam,
rcases hk with ⟨k, ⟨kpos, hk⟩⟩,
apply QIE_from_different_constants _ k 1 ((c^2)/b) (b + (b/(c^2))) kpos zero_lt_one,
apply div_pos (sq_pos_of_pos cpos) bpos,
apply add_pos bpos (div_pos bpos (sq_pos_of_pos cpos)),
intros g h,
simp,
have coverx : ∃ a : α, x ∈ isom_img a s,
begin
rw ← set.mem_Union, exact htrans x,
end,
rcases coverx with ⟨a, ⟨z, ⟨zs, hz⟩⟩⟩,
dsimp at hz,
rw ← hz,
rw dist_of_inv_isom,
repeat {rw smul_smul,},

rw dist_of_inv (@proper_action_set α β _ _ _ (set_closed_ball  s (2*b))) (metric_svarcmilnor1 c b cpos bpos s htrans finitediam) g h,

end


/-
Copyright (c) 2020 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/
import algebra.group_ring_action
import algebra.hom.group_action
import data.polynomial.algebra_map
import data.polynomial.monic
import group_theory.group_action.quotient

/-!
# Group action on rings applied to polynomials

This file contains instances and definitions relating `mul_semiring_action` to `polynomial`.
-/

variables (M : Type*) [monoid M]

open_locale polynomial
namespace polynomial

variables (R : Type*) [semiring R]

variables {M}

lemma smul_eq_map [mul_semiring_action M R] (m : M) :
  ((•) m) = map (mul_semiring_action.to_ring_hom M R m) :=
begin
  suffices :
    distrib_mul_action.to_add_monoid_hom R[X] m =
      (map_ring_hom (mul_semiring_action.to_ring_hom M R m)).to_add_monoid_hom,
  { ext1 r, exact add_monoid_hom.congr_fun this r, },
  ext n r : 2,
  change m • monomial n r = map (mul_semiring_action.to_ring_hom M R m) (monomial n r),
  simpa only [polynomial.map_monomial, polynomial.smul_monomial],
end

variables (M)

noncomputable instance [mul_semiring_action M R] : mul_semiring_action M R[X] :=
{ smul := (•),
  smul_one := λ m,
    (smul_eq_map R m).symm ▸ polynomial.map_one (mul_semiring_action.to_ring_hom M R m),
  smul_mul := λ m p q,
    (smul_eq_map R m).symm ▸ polynomial.map_mul (mul_semiring_action.to_ring_hom M R m),
  ..polynomial.distrib_mul_action }

variables {M R}

variables [mul_semiring_action M R]

@[simp] lemma smul_X (m : M) : (m • X : R[X]) = X :=
(smul_eq_map R m).symm ▸ map_X _

variables (S : Type*) [comm_semiring S] [mul_semiring_action M S]

theorem smul_eval_smul (m : M) (f : S[X]) (x : S) :
  (m • f).eval (m • x) = m • f.eval x :=
polynomial.induction_on f
  (λ r, by rw [smul_C, eval_C, eval_C])
  (λ f g ihf ihg, by rw [smul_add, eval_add, ihf, ihg, eval_add, smul_add])
  (λ n r ih, by rw [smul_mul', smul_pow', smul_C, smul_X, eval_mul, eval_C, eval_pow, eval_X,
      eval_mul, eval_C, eval_pow, eval_X, smul_mul', smul_pow'])

variables (G : Type*) [group G]

theorem eval_smul' [mul_semiring_action G S] (g : G) (f : S[X]) (x : S) :
  f.eval (g • x) = g • (g⁻¹ • f).eval x :=
by rw [← smul_eval_smul, smul_inv_smul]

theorem smul_eval [mul_semiring_action G S] (g : G) (f : S[X]) (x : S) :
  (g • f).eval x = g • f.eval (g⁻¹ • x) :=
by rw [← smul_eval_smul, smul_inv_smul]

end polynomial

section comm_ring

variables (G : Type*) [group G] [fintype G]
variables (R : Type*) [comm_ring R] [mul_semiring_action G R]
open mul_action
open_locale classical

/-- the product of `(X - g • x)` over distinct `g • x`. -/
noncomputable def prod_X_sub_smul (x : R) : R[X] :=
(finset.univ : finset (G ⧸ mul_action.stabilizer G x)).prod $
λ g, polynomial.X - polynomial.C (of_quotient_stabilizer G x g)

theorem prod_X_sub_smul.monic (x : R) : (prod_X_sub_smul G R x).monic :=
polynomial.monic_prod_of_monic _ _ $ λ g _, polynomial.monic_X_sub_C _

theorem prod_X_sub_smul.eval (x : R) : (prod_X_sub_smul G R x).eval x = 0 :=
(monoid_hom.map_prod
  ((polynomial.aeval x).to_ring_hom.to_monoid_hom : R[X] →* R) _ _).trans $
  finset.prod_eq_zero (finset.mem_univ $ quotient_group.mk 1) $
  by simp

theorem prod_X_sub_smul.smul (x : R) (g : G) :
  g • prod_X_sub_smul G R x = prod_X_sub_smul G R x :=
finset.smul_prod.trans $ fintype.prod_bijective _ (mul_action.bijective g) _ _
  (λ g', by rw [of_quotient_stabilizer_smul, smul_sub, polynomial.smul_X, polynomial.smul_C])

theorem prod_X_sub_smul.coeff (x : R) (g : G) (n : ℕ) :
  g • (prod_X_sub_smul G R x).coeff n =
  (prod_X_sub_smul G R x).coeff n :=
by rw [← polynomial.coeff_smul, prod_X_sub_smul.smul]

end comm_ring

namespace mul_semiring_action_hom
variables {M}
variables {P : Type*} [comm_semiring P] [mul_semiring_action M P]
variables {Q : Type*} [comm_semiring Q] [mul_semiring_action M Q]
open polynomial

/-- An equivariant map induces an equivariant map on polynomials. -/
protected noncomputable def polynomial (g : P →+*[M] Q) : P[X] →+*[M] Q[X] :=
{ to_fun := map g,
  map_smul' := λ m p, polynomial.induction_on p
    (λ b, by rw [smul_C, map_C, coe_fn_coe, g.map_smul, map_C, coe_fn_coe, smul_C])
    (λ p q ihp ihq, by rw [smul_add, polynomial.map_add, ihp, ihq, polynomial.map_add, smul_add])
    (λ n b ih, by rw [smul_mul', smul_C, smul_pow', smul_X, polynomial.map_mul, map_C,
        polynomial.map_pow, map_X, coe_fn_coe, g.map_smul, polynomial.map_mul, map_C,
        polynomial.map_pow, map_X, smul_mul', smul_C, smul_pow', smul_X, coe_fn_coe]),
  map_zero' := polynomial.map_zero g,
  map_add' := λ p q, polynomial.map_add g,
  map_one' := polynomial.map_one g,
  map_mul' := λ p q, polynomial.map_mul g }

@[simp] theorem coe_polynomial (g : P →+*[M] Q) :
  (g.polynomial : P[X] → Q[X]) = map g :=
rfl

end mul_semiring_action_hom


import algebraic_topology.simplex_category
import category_theory.arrow
import category_theory.discrete_category
import category_theory.limits.shapes.terminal
import category_theory.limits.shapes.products
import category_theory.limits.shapes.equalizers
import category_theory.limits.presheaf
import category_theory.limits.preserves.shapes.equalizers

open category_theory

noncomputable theory

open_locale simplicial

universe u

variables {m n : ℕ}
variables {i j k : fin (n + 2)}

lemma hole_decomposition {X} (f : X ⟶ [n + 1]) (h : i ∉ set.range f.to_order_hom)
  : ∃ f', f = f' ≫ simplex_category.δ i :=
begin
  simp only [simplex_category.δ, simplex_category.hom.comp, simplex_category.mk_hom, simplex_category.small_category_comp,
    simplex_category.hom.to_order_hom_mk, set.mem_range, not_exists] at *,
  cases lt_or_eq_of_le (fin.le_last i),

  case or.inl : h' {
    set j := i.cast_pred,
    have hj : i = j.cast_succ := by rwa [fin.cast_succ_cast_pred],
    fconstructor,
    apply simplex_category.hom.mk,
    dsimp at *,
    exact order_hom.comp ⟨j.pred_above, fin.pred_above_right_monotone _⟩ f.to_order_hom,
    dsimp [simplex_category.δ],
    ext1, ext1, ext1,
    simp only [simplex_category.hom.to_order_hom_mk, order_hom.comp_coe, order_embedding.to_order_hom_coe, order_hom.coe_fun_mk,
      function.comp_app],
    set y := f.to_order_hom x with hy,
    simp_rw [←hy, hj],
    rw [fin.cast_pred_cast_succ],
    rw [fin.succ_above_pred_above],
    rw [hy, ←hj],
    apply h,
  },

  case or.inr : h' {
    fconstructor,
    apply simplex_category.hom.mk,
    exact order_hom.comp ⟨fin.cast_pred, fin.cast_pred_monotone⟩ f.to_order_hom,
    ext1, ext1, ext1,
    simp only [h', simplex_category.hom.to_order_hom_mk, order_hom.comp_coe, order_embedding.to_order_hom_coe, order_hom.coe_fun_mk,
      function.comp_app],
    set y := f.to_order_hom x with ←hy,
    simp_rw [hy],
    dsimp,
    rw [fin.succ_above_last],
    rw [fin.cast_succ_cast_pred],
    cases lt_or_eq_of_le (fin.le_last y),
    assumption,
    exfalso,
    specialize h x,
    simp_rw [h', h_1] at *,
    contradiction,
  }
end

@[irreducible]
lemma hole_decomposition' {X} (f : X ⟶ [n + 1]) (h : i ∉ set.range f.to_order_hom)
  : { f' // f = f' ≫ simplex_category.δ i } :=
begin
  have h' := hole_decomposition f h,
  fconstructor,
  exact classical.some h',
  exact classical.some_spec h',
end

def δ_cancel {X} {i} {f g : X ⟶ [n]}
  (h : f ≫ simplex_category.δ i = g ≫ simplex_category.δ i) : f = g :=
begin
  cases lt_or_eq_of_le (fin.le_last i),

  case or.inl : h' {
    let j := i.cast_pred,
    have hj : i = j.cast_succ := by rwa [fin.cast_succ_cast_pred],
    clear_value j,
    subst hj, clear h',
    let h' := congr_arg (λ x, x ≫ simplex_category.σ j) h,
    unfold at h',
    simp_rw [category.assoc', simplex_category.δ_comp_σ_self] at h',
    simp only [simplex_category.hom.comp, simplex_category.hom.id, simplex_category.small_category_id,
      simplex_category.small_category_comp, simplex_category.hom.to_order_hom_mk, order_hom.id_comp,
      simplex_category.hom.mk_to_order_hom] at h',
    assumption,
  },

  case or.inr : h' {
    subst h',
    let h' := congr_arg (λ x, x ≫ simplex_category.σ (fin.last n)) h,
    unfold at h',
    have h'' : fin.last (n + 1) = (fin.last n).succ := by simp only [fin.succ_last],
    simp_rw [category.assoc', h'', simplex_category.δ_comp_σ_succ] at h',
    simp only [simplex_category.hom.comp, simplex_category.hom.id, simplex_category.small_category_id,
      simplex_category.small_category_comp, simplex_category.hom.to_order_hom_mk, order_hom.id_comp,
      simplex_category.hom.mk_to_order_hom] at h',
    assumption,
  },
end

def δ_pullback_cone (h : i ≤ j) := limits.pullback_cone.mk (simplex_category.δ i) (simplex_category.δ j) (simplex_category.δ_comp_δ h)

def δ_pullback_morphism_prop₁ {n : ℕ}
  {i j : fin (n + 2)}
  (h : i ≤ j)
  (s : limits.pullback_cone (simplex_category.δ j.succ)
    (simplex_category.δ i.cast_succ))
  : i ∉ set.range s.fst.to_order_hom :=
begin
  intro hi, cases hi,
  have h' := congr_arg (simplex_category.δ j.succ).to_order_hom hi_h,
  have h'' : (simplex_category.δ j.succ).to_order_hom i = i := by {
    simp [simplex_category.δ],
    apply fin.succ_above_below,
    rw fin.cast_succ_lt_iff_succ_le,
    rwa fin.succ_le_succ_iff,
  },
  have hc := s.condition,
  have hc' := congr_arg (order_hom.to_fun) (congr_arg (simplex_category.hom.to_order_hom) hc),
  simp at hc',
  have hc'' := congr_arg (λ f : fin (s.X.len + 1) → fin ([n + 1 + 1].len + 1), f hi_w) hc',
  simp at hc'',
  rw h' at hc'',
  rw [h''] at hc'',
  simp [simplex_category.δ, simplex_category] at hc'',
  fapply fin.succ_above_ne (fin.cast_succ i) _, exact hc''.symm,
end

def δ_pullback_morphism_prop₂ {n : ℕ}
  {i j : fin (n + 2)}
  (h : i ≤ j)
  (s : limits.pullback_cone (simplex_category.δ j.succ)
    (simplex_category.δ i.cast_succ))
  : j ∉ set.range s.snd.to_order_hom :=
begin
  intro hi, cases hi,
  have h' := congr_arg (simplex_category.δ i.cast_succ).to_order_hom hi_h,
  have h'' : (simplex_category.δ i.cast_succ).to_order_hom j = j.succ := by {
    apply fin.succ_above_above,
    exact order_hom_class.mono fin.cast_succ h,
  },
  have hc := s.condition,
  have hc' := congr_arg (order_hom.to_fun) (congr_arg (simplex_category.hom.to_order_hom) hc),
  simp at hc',
  have hc'' := congr_arg (λ f : fin (s.X.len + 1) → fin ([n + 1 + 1].len + 1), f hi_w) hc',
  simp at hc'',
  rw h' at hc'',
  rw [h''] at hc'',
  simp [simplex_category.δ, simplex_category] at hc'',
  fapply fin.succ_above_ne (fin.succ j) _, exact hc'',
end

def δ_pullback (h : i ≤ j) : limits.is_limit (δ_pullback_cone h) :=
begin
  fapply limits.pullback_cone.is_limit_aux',
  intro s,
  have dec₁ := hole_decomposition' s.fst (δ_pullback_morphism_prop₁ h s),
  have dec₂ := hole_decomposition' s.snd (δ_pullback_morphism_prop₂ h s),
  have dec_eq : dec₁.val = dec₂.val := by {
    cases dec₁, cases dec₂, dsimp,
    fapply δ_cancel, exact i,
    fapply δ_cancel, exact j.succ,
    simp_rw [category.assoc],
    nth_rewrite 1 [simplex_category.δ_comp_δ h],
    simp_rw [←category.assoc],
    rw [←dec₁_property, ←dec₂_property],
    exact s.condition,
  },
  fconstructor,
  exact dec₁.val,
  split,
  dsimp only [δ_pullback_cone],
  rw [limits.pullback_cone.mk_fst],
  rw [←dec₁.property],
  split,
  rw [dec_eq],
  dsimp only [δ_pullback_cone],
  rw [limits.pullback_cone.mk_snd],
  rw [←dec₂.property],
  change (∀ {m : s.X ⟶ [n]},
    m ≫ (δ_pullback_cone h).fst = s.fst → m ≫ (δ_pullback_cone h).snd = s.snd → m = dec₁.val),
  dsimp only [δ_pullback_cone],
  simp_rw [limits.pullback_cone.mk_fst, limits.pullback_cone.mk_snd],
  intros m e₁ e₂,
  fapply δ_cancel, exact i,
  rw [e₁, ←dec₁.property],
end