/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import algebraic_geometry.presheafed_space
import category_theory.limits.final
import topology.sheaves.stalks

/-!
# Stalks for presheaved spaces

This file lifts constructions of stalks and pushforwards of stalks to work with
the category of presheafed spaces. Additionally, we prove that restriction of
presheafed spaces does not change the stalks.
-/

noncomputable theory

universes v u v' u'

open category_theory
open category_theory.limits category_theory.category category_theory.functor
open algebraic_geometry
open topological_space
open opposite

variables {C : Type u} [category.{v} C] [has_colimits C]

local attribute [tidy] tactic.op_induction'

open Top.presheaf

namespace algebraic_geometry.PresheafedSpace

/--
The stalk at `x` of a `PresheafedSpace`.
-/
def stalk (X : PresheafedSpace C) (x : X) : C := X.presheaf.stalk x

/--
A morphism of presheafed spaces induces a morphism of stalks.
-/
def stalk_map {X Y : PresheafedSpace C} (α : X ⟶ Y) (x : X) : Y.stalk (α.base x) ⟶ X.stalk x :=
(stalk_functor C (α.base x)).map (α.c) ≫ X.presheaf.stalk_pushforward C α.base x

@[simp, elementwise, reassoc]
lemma stalk_map_germ {X Y : PresheafedSpace C} (α : X ⟶ Y) (U : opens Y.carrier)
  (x : (opens.map α.base).obj U) :
  Y.presheaf.germ ⟨α.base x, x.2⟩ ≫ stalk_map α ↑x = α.c.app (op U) ≫ X.presheaf.germ x :=
by rw [stalk_map, stalk_functor_map_germ_assoc, stalk_pushforward_germ]

section restrict

/--
For an open embedding `f : U ⟶ X` and a point `x : U`, we get an isomorphism between the stalk
of `X` at `f x` and the stalk of the restriction of `X` along `f` at t `x`.
-/
def restrict_stalk_iso {U : Top} (X : PresheafedSpace C)
  {f : U ⟶ (X : Top.{v})} (h : open_embedding f) (x : U) :
  (X.restrict h).stalk x ≅ X.stalk (f x) :=
begin
  -- As a left adjoint, the functor `h.is_open_map.functor_nhds x` is initial.
  haveI := initial_of_adjunction (h.is_open_map.adjunction_nhds x),
  -- Typeclass resolution knows that the opposite of an initial functor is final. The result
  -- follows from the general fact that postcomposing with a final functor doesn't change colimits.
  exact final.colimit_iso (h.is_open_map.functor_nhds x).op
    ((open_nhds.inclusion (f x)).op ⋙ X.presheaf),
end

@[simp, elementwise, reassoc]
lemma restrict_stalk_iso_hom_eq_germ {U : Top} (X : PresheafedSpace C) {f : U ⟶ (X : Top.{v})}
  (h : open_embedding f) (V : opens U) (x : U) (hx : x ∈ V) :
  (X.restrict h).presheaf.germ ⟨x, hx⟩ ≫ (restrict_stalk_iso X h x).hom =
  X.presheaf.germ ⟨f x, show f x ∈ h.is_open_map.functor.obj V, from ⟨x, hx, rfl⟩⟩ :=
colimit.ι_pre ((open_nhds.inclusion (f x)).op ⋙ X.presheaf)
  (h.is_open_map.functor_nhds x).op (op ⟨V, hx⟩)

@[simp, elementwise, reassoc]
lemma restrict_stalk_iso_inv_eq_germ {U : Top} (X : PresheafedSpace C) {f : U ⟶ (X : Top.{v})}
  (h : open_embedding f) (V : opens U) (x : U) (hx : x ∈ V) :
  X.presheaf.germ ⟨f x, show f x ∈ h.is_open_map.functor.obj V, from ⟨x, hx, rfl⟩⟩ ≫
  (restrict_stalk_iso X h x).inv = (X.restrict h).presheaf.germ ⟨x, hx⟩ :=
by rw [← restrict_stalk_iso_hom_eq_germ, category.assoc, iso.hom_inv_id, category.comp_id]

lemma restrict_stalk_iso_inv_eq_of_restrict {U : Top} (X : PresheafedSpace C)
  {f : U ⟶ (X : Top.{v})} (h : open_embedding f) (x : U) :
    (X.restrict_stalk_iso h x).inv = stalk_map (X.of_restrict h) x :=
begin
  ext V,
  induction V using opposite.rec,
  let i : (h.is_open_map.functor_nhds x).obj ((open_nhds.map f x).obj V) ⟶ V :=
    hom_of_le (set.image_preimage_subset f _),
  erw [iso.comp_inv_eq, colimit.ι_map_assoc, colimit.ι_map_assoc, colimit.ι_pre],
  simp_rw category.assoc,
  erw colimit.ι_pre ((open_nhds.inclusion (f x)).op ⋙ X.presheaf)
    (h.is_open_map.functor_nhds x).op,
  erw ← X.presheaf.map_comp_assoc,
  exact (colimit.w ((open_nhds.inclusion (f x)).op ⋙ X.presheaf) i.op).symm,
end

instance of_restrict_stalk_map_is_iso {U : Top} (X : PresheafedSpace C)
  {f : U ⟶ (X : Top.{v})} (h : open_embedding f) (x : U) :
  is_iso (stalk_map (X.of_restrict h) x) :=
by { rw ← restrict_stalk_iso_inv_eq_of_restrict, apply_instance }

end restrict

namespace stalk_map

@[simp] lemma id (X : PresheafedSpace C) (x : X) : stalk_map (𝟙 X) x = 𝟙 (X.stalk x) :=
begin
  dsimp [stalk_map],
  simp only [stalk_pushforward.id],
  rw [←map_comp],
  convert (stalk_functor C x).map_id X.presheaf,
  tidy,
end

-- TODO understand why this proof is still gross (i.e. requires using `erw`)
@[simp] lemma comp {X Y Z : PresheafedSpace C} (α : X ⟶ Y) (β : Y ⟶ Z) (x : X) :
  stalk_map (α ≫ β) x =
    (stalk_map β (α.base x) : Z.stalk (β.base (α.base x)) ⟶ Y.stalk (α.base x)) ≫
    (stalk_map α x : Y.stalk (α.base x) ⟶ X.stalk x) :=
begin
  dsimp [stalk_map, stalk_functor, stalk_pushforward],
  ext U,
  induction U using opposite.rec,
  cases U,
  simp only [colimit.ι_map_assoc, colimit.ι_pre_assoc, colimit.ι_pre,
    whisker_left_app, whisker_right_app,
    assoc, id_comp, map_id, map_comp],
  dsimp,
  simp only [map_id, assoc, pushforward.comp_inv_app],
  -- FIXME Why doesn't simp do this:
  erw [category_theory.functor.map_id],
  erw [category_theory.functor.map_id],
  erw [id_comp, id_comp],
end

/--
If `α = β` and `x = x'`, we would like to say that `stalk_map α x = stalk_map β x'`.
Unfortunately, this equality is not well-formed, as their types are not _definitionally_ the same.
To get a proper congruence lemma, we therefore have to introduce these `eq_to_hom` arrows on
either side of the equality.
-/
lemma congr {X Y : PresheafedSpace C} (α β : X ⟶ Y) (h₁ : α = β) (x x': X) (h₂ : x = x') :
  stalk_map α x ≫ eq_to_hom (show X.stalk x = X.stalk x', by rw h₂) =
  eq_to_hom (show Y.stalk (α.base x) = Y.stalk (β.base x'), by rw [h₁, h₂]) ≫ stalk_map β x' :=
stalk_hom_ext _ $ λ U hx, by { subst h₁, subst h₂, simp }

lemma congr_hom {X Y : PresheafedSpace C} (α β : X ⟶ Y) (h : α = β) (x : X) :
  stalk_map α x =
  eq_to_hom (show Y.stalk (α.base x) = Y.stalk (β.base x), by rw h) ≫ stalk_map β x :=
by rw [← stalk_map.congr α β h x x rfl, eq_to_hom_refl, category.comp_id]

lemma congr_point {X Y : PresheafedSpace C} (α : X ⟶ Y) (x x' : X) (h : x = x') :
  stalk_map α x ≫ eq_to_hom (show X.stalk x = X.stalk x', by rw h) =
  eq_to_hom (show Y.stalk (α.base x) = Y.stalk (α.base x'), by rw h) ≫ stalk_map α x' :=
by rw stalk_map.congr α α rfl x x' h

instance is_iso {X Y : PresheafedSpace C} (α : X ⟶ Y) [is_iso α] (x : X) :
  is_iso (stalk_map α x) :=
{ out := begin
  let β : Y ⟶ X := category_theory.inv α,
  have h_eq : (α ≫ β).base x = x,
  { rw [is_iso.hom_inv_id α, id_base, Top.id_app] },
  -- Intuitively, the inverse of the stalk map of `α` at `x` should just be the stalk map of `β`
  -- at `α x`. Unfortunately, we have a problem with dependent type theory here: Because `x`
  -- is not *definitionally* equal to `β (α x)`, the map `stalk_map β (α x)` has not the correct
  -- type for an inverse.
  -- To get a proper inverse, we need to compose with the `eq_to_hom` arrow
  -- `X.stalk x ⟶ X.stalk ((α ≫ β).base x)`.
  refine ⟨eq_to_hom (show X.stalk x = X.stalk ((α ≫ β).base x), by rw h_eq) ≫
    (stalk_map β (α.base x) : _), _, _⟩,
  { rw [← category.assoc, congr_point α x ((α ≫ β).base x) h_eq.symm, category.assoc],
    erw ← stalk_map.comp β α (α.base x),
    rw [congr_hom _ _ (is_iso.inv_hom_id α), stalk_map.id, eq_to_hom_trans_assoc,
      eq_to_hom_refl, category.id_comp] },
  { rw [category.assoc, ← stalk_map.comp, congr_hom _ _ (is_iso.hom_inv_id α),
    stalk_map.id, eq_to_hom_trans_assoc, eq_to_hom_refl, category.id_comp] },
end }

/--
An isomorphism between presheafed spaces induces an isomorphism of stalks.
-/
def stalk_iso {X Y : PresheafedSpace C} (α : X ≅ Y) (x : X) :
  Y.stalk (α.hom.base x) ≅ X.stalk x :=
as_iso (stalk_map α.hom x)

end stalk_map

end algebraic_geometry.PresheafedSpace


/-
Copyright (c) 2021 Jakob Scholbach. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jakob Scholbach
-/
import category_theory.limits.shapes.terminal
import category_theory.arrow

/-!
# Lifting properties

This file defines the lifting property of two arrows in a category and shows basic properties of
this notion.
We also construct the subcategory consisting of those morphisms which have the right lifting
property with respect to arrows in a given diagram.

## Main results
- `has_lifting_property`: the definition of the lifting property
- `iso_has_right_lifting_property`: any isomorphism satisfies the right lifting property (rlp)
- `id_has_right_lifting_property`: any identity has the rlp
- `right_lifting_property_initial_iff`: spells out the rlp with respect to a map whose source is an
  initial object
- `right_lifting_subcat`: given a set of arrows `F : D → arrow C`, we construct the subcategory
  of those morphisms `p` in `C` that satisfy the rlp w.r.t. `F i`, for any element `i` of `D`.

## Tags
lifting property
-/

open category_theory.limits

namespace category_theory

universes v u v₁
variables {C : Type u} [category.{v} C]
variables {D : Type v₁}

variables {X Y Z : C}

/-- The lifting property of a morphism `i` with respect to a morphism `p`.
This can be interpreted as the right lifting property of `i` with respect to `p`,
or the left lifting property of `p` with respect to `i`. -/
class has_lifting_property (i p : arrow C) : Prop :=
(sq_has_lift : ∀ (sq : i ⟶ p), arrow.has_lift sq)

@[priority 100] -- see Note [lower instance priority]
instance has_lifting_property' {i p : arrow C} [has_lifting_property i p] (sq : i ⟶ p) :
  arrow.has_lift sq :=
has_lifting_property.sq_has_lift sq

/-- Any isomorphism has the right lifting property with respect to any map.
A    → X
↓i    ↓p≅
B    → Y
-/
lemma iso_has_right_lifting_property (i : arrow C) (p : X ≅ Y) :
  has_lifting_property i (arrow.mk p.hom) :=
⟨λ sq, ⟨⟨{ lift := sq.right ≫ p.inv, }⟩⟩⟩ -- the lift is obtained by p⁻¹ ∘ (B → Y)

/-- Any identity has the right lifting property with respect to any map. -/
lemma id_has_right_lifting_property (i : arrow C) : has_lifting_property i (arrow.mk (𝟙 X)) :=
iso_has_right_lifting_property i (iso.refl _)

/-- An equivalent characterization for right lifting with respect to a map `i` whose source is
initial.
∅ → X
↓   ↓
B → Y has a lifting iff there is a map B → X making the right part commute.
-/
lemma right_lifting_property_initial_iff (i p : arrow C) (h : is_initial i.left) :
  has_lifting_property i p ↔ ∀ {e : i.right ⟶ p.right}, ∃ l : i.right ⟶ p.left, l ≫ p.hom = e :=
begin
  fsplit,
  { introsI hlift e,
    have comm : (is_initial.to h p.left) ≫ p.hom = i.hom ≫ e :=
      is_initial.hom_ext h _ _,
    use arrow.lift (arrow.hom_mk comm),
    simp },
  { refine λ hlift, ⟨λ sq, _⟩,
    obtain ⟨l, hl⟩ : ∃ (l : i.right ⟶ p.left), l ≫ p.hom = sq.right := hlift,
    exact arrow.has_lift.mk ⟨l, is_initial.hom_ext h _ _⟩, }
end

/-- The condition of having the rlp with respect to a morphism `i` is stable under composition. -/
lemma has_right_lifting_property_comp {i : arrow C} {f : X ⟶ Y} {g : Y ⟶ Z}
  (hf : has_lifting_property i (arrow.mk f))
  (hg : has_lifting_property i (arrow.mk g)) :
  has_lifting_property i (arrow.mk (f ≫ g)) :=
{ sq_has_lift := λ sq1,
    -- construct a square i ⟶ f
    let sq2 : i ⟶ (arrow.mk f) := ⟨sq1.left, arrow.lift (arrow.square_to_snd sq1)⟩ in
    -- show that the lift of this square is a lift of i with respect to g ∘ f
    ⟨⟨⟨(arrow.lift sq2 : _ ⟶ _), by simp⟩⟩⟩ }

/-- The objects of the subcategory `right_lifting_subcategory` are the ones in the
underlying category. -/
def right_lifting_subcat (R : Type u) := R

instance right_lifting_subcat.inhabited  (R : Type u) [inhabited R] :
  inhabited (right_lifting_subcat R) :=
{ default := (default R : R) }

/-- The objects of the subcategory `right_lifting_subcategory` are the ones in the
underlying category. -/
def right_lifting_subcat.X {R : Type u} (x : right_lifting_subcat R) : R := x

lemma id_has_right_lifting_property' {F : D → arrow C} (X : C) :
  ∀ i : D, has_lifting_property (F i) (arrow.mk (𝟙 X)) :=
λ i, id_has_right_lifting_property (F i)

lemma has_right_lifting_property_comp'
  {F : D → arrow C} {f : X ⟶ Y} (hf : ∀ i : D, has_lifting_property (F i) (arrow.mk f))
  {g : Y ⟶ Z} (hg : ∀ i : D, has_lifting_property (F i) (arrow.mk g)) :
  ∀ i : D,  has_lifting_property (F i) (arrow.mk (f ≫ g)) :=
λ i, has_right_lifting_property_comp (hf i) (hg i)

/-- Given a set of arrows in C, indexed by `F : D → arrow C`,
we construct the (non-full) subcategory of `C`
spanned by those morphisms that have the right lifting property relative to all maps
of the form `F i`, where `i` is any element in `D`. -/
def right_lifting_subcategory (F : D → arrow C) : category (right_lifting_subcat C) :=
{ hom := λ X Y, { p : X ⟶ Y // ∀ {i : D}, has_lifting_property (F i) (arrow.mk p) },
  id := λ X, ⟨𝟙 X, id_has_right_lifting_property' X⟩,
  comp := λ X Y Z f g, ⟨f.val ≫ g.val, has_right_lifting_property_comp' f.property g.property⟩ }

end category_theory


/-
Copyright (c) 2020 Jean Lo. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jean Lo
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.topology.algebra.group
import Mathlib.logic.function.iterate
import Mathlib.PostPort

universes u_1 u_2 l u_3

namespace Mathlib

/-!
# Flows and invariant sets

This file defines a flow on a topological space `α` by a topological
monoid `τ` as a continuous monoid-act of `τ` on `α`. Anticipating the
cases where `τ` is one of `ℕ`, `ℤ`, `ℝ⁺`, or `ℝ`, we use additive
notation for the monoids, though the definition does not require
commutativity.

A subset `s` of `α` is invariant under a family of maps `ϕₜ : α → α`
if `ϕₜ s ⊆ s` for all `t`. In many cases `ϕ` will be a flow on
`α`. For the cases where `ϕ` is a flow by an ordered (additive,
commutative) monoid, we additionally define forward invariance, where
`t` ranges over those elements which are nonnegative.

Additionally, we define such constructions as the restriction of a
flow onto an invariant subset, and the time-reveral of a flow by a
group.
-/

/-!
### Invariant sets
-/

/-- A set `s ⊆ α` is invariant under `ϕ : τ → α → α` if
    `ϕ t s ⊆ s` for all `t` in `τ`. -/
def is_invariant {τ : Type u_1} {α : Type u_2} (ϕ : τ → α → α) (s : set α) :=
  ∀ (t : τ), set.maps_to (ϕ t) s s

theorem is_invariant_iff_image {τ : Type u_1} {α : Type u_2} (ϕ : τ → α → α) (s : set α) : is_invariant ϕ s ↔ ∀ (t : τ), ϕ t '' s ⊆ s := sorry

/-- A set `s ⊆ α` is forward-invariant under `ϕ : τ → α → α` if
    `ϕ t s ⊆ s` for all `t ≥ 0`. -/
def is_fw_invariant {τ : Type u_1} {α : Type u_2} [preorder τ] [HasZero τ] (ϕ : τ → α → α) (s : set α) :=
  ∀ {t : τ}, 0 ≤ t → set.maps_to (ϕ t) s s

theorem is_invariant.is_fw_invariant {τ : Type u_1} {α : Type u_2} [preorder τ] [HasZero τ] {ϕ : τ → α → α} {s : set α} (h : is_invariant ϕ s) : is_fw_invariant ϕ s :=
  fun (t : τ) (ht : 0 ≤ t) => h t

/-- If `τ` is a `canonically_ordered_add_monoid` (e.g., `ℕ` or `ℝ≥0`), then the notions
`is_fw_invariant` and `is_invariant` are equivalent. -/
theorem is_fw_invariant.is_invariant {τ : Type u_1} {α : Type u_2} [canonically_ordered_add_monoid τ] {ϕ : τ → α → α} {s : set α} (h : is_fw_invariant ϕ s) : is_invariant ϕ s :=
  fun (t : τ) => h (zero_le t)

/-- If `τ` is a `canonically_ordered_add_monoid` (e.g., `ℕ` or `ℝ≥0`), then the notions
`is_fw_invariant` and `is_invariant` are equivalent. -/
theorem is_fw_invariant_iff_is_invariant {τ : Type u_1} {α : Type u_2} [canonically_ordered_add_monoid τ] {ϕ : τ → α → α} {s : set α} : is_fw_invariant ϕ s ↔ is_invariant ϕ s :=
  { mp := is_fw_invariant.is_invariant, mpr := is_invariant.is_fw_invariant }

/-!
### Flows
-/

/-- A flow on a topological space `α` by an a additive topological
    monoid `τ` is a continuous monoid action of `τ` on `α`.-/
structure flow (τ : Type u_1) [topological_space τ] [add_monoid τ] [has_continuous_add τ] (α : Type u_2) [topological_space α]
where
  to_fun : τ → α → α
  cont' : continuous (function.uncurry to_fun)
  map_add' : ∀ (t₁ t₂ : τ) (x : α), to_fun (t₁ + t₂) x = to_fun t₁ (to_fun t₂ x)
  map_zero' : ∀ (x : α), to_fun 0 x = x

namespace flow

protected instance inhabited {τ : Type u_1} [add_monoid τ] [topological_space τ] [has_continuous_add τ] {α : Type u_2} [topological_space α] : Inhabited (flow τ α) :=
  { default := mk (fun (_x : τ) (x : α) => x) continuous_snd sorry sorry }

protected instance has_coe_to_fun {τ : Type u_1} [add_monoid τ] [topological_space τ] [has_continuous_add τ] {α : Type u_2} [topological_space α] : has_coe_to_fun (flow τ α) :=
  has_coe_to_fun.mk (fun (x : flow τ α) => τ → α → α) to_fun

theorem ext {τ : Type u_1} [add_monoid τ] [topological_space τ] [has_continuous_add τ] {α : Type u_2} [topological_space α] {ϕ₁ : flow τ α} {ϕ₂ : flow τ α} : (∀ (t : τ) (x : α), coe_fn ϕ₁ t x = coe_fn ϕ₂ t x) → ϕ₁ = ϕ₂ := sorry

protected theorem continuous {τ : Type u_1} [add_monoid τ] [topological_space τ] [has_continuous_add τ] {α : Type u_2} [topological_space α] (ϕ : flow τ α) {β : Type u_3} [topological_space β] {t : β → τ} (ht : continuous t) {f : β → α} (hf : continuous f) : continuous fun (x : β) => coe_fn ϕ (t x) (f x) :=
  continuous.comp (cont' ϕ) (continuous.prod_mk ht hf)

theorem Mathlib.continuous.flow {τ : Type u_1} [add_monoid τ] [topological_space τ] [has_continuous_add τ] {α : Type u_2} [topological_space α] (ϕ : flow τ α) {β : Type u_3} [topological_space β] {t : β → τ} (ht : continuous t) {f : β → α} (hf : continuous f) : continuous fun (x : β) => coe_fn ϕ (t x) (f x) :=
  flow.continuous

theorem map_add {τ : Type u_1} [add_monoid τ] [topological_space τ] [has_continuous_add τ] {α : Type u_2} [topological_space α] (ϕ : flow τ α) (t₁ : τ) (t₂ : τ) (x : α) : coe_fn ϕ (t₁ + t₂) x = coe_fn ϕ t₁ (coe_fn ϕ t₂ x) :=
  map_add' ϕ t₁ t₂ x

@[simp] theorem map_zero {τ : Type u_1} [add_monoid τ] [topological_space τ] [has_continuous_add τ] {α : Type u_2} [topological_space α] (ϕ : flow τ α) : coe_fn ϕ 0 = id :=
  funext (map_zero' ϕ)

theorem map_zero_apply {τ : Type u_1} [add_monoid τ] [topological_space τ] [has_continuous_add τ] {α : Type u_2} [topological_space α] (ϕ : flow τ α) (x : α) : coe_fn ϕ 0 x = x :=
  map_zero' ϕ x

/-- Iterations of a continuous function from a topological space `α`
    to itself defines a semiflow by `ℕ` on `α`. -/
def from_iter {α : Type u_2} [topological_space α] {g : α → α} (h : continuous g) : flow ℕ α :=
  mk (fun (n : ℕ) (x : α) => nat.iterate g n x) sorry (function.iterate_add_apply g) sorry

/-- Restriction of a flow onto an invariant set. -/
def restrict {τ : Type u_1} [add_monoid τ] [topological_space τ] [has_continuous_add τ] {α : Type u_2} [topological_space α] (ϕ : flow τ α) {s : set α} (h : is_invariant (⇑ϕ) s) : flow τ ↥s :=
  mk (fun (t : τ) => set.maps_to.restrict (coe_fn ϕ t) s s (h t)) sorry sorry sorry

end flow

namespace flow

theorem is_invariant_iff_image_eq {τ : Type u_1} [add_comm_group τ] [topological_space τ] [topological_add_group τ] {α : Type u_2} [topological_space α] (ϕ : flow τ α) (s : set α) : is_invariant (⇑ϕ) s ↔ ∀ (t : τ), coe_fn ϕ t '' s = s := sorry

/-- The time-reversal of a flow `ϕ` by a (commutative, additive) group
    is defined `ϕ.reverse t x = ϕ (-t) x`. -/
def reverse {τ : Type u_1} [add_comm_group τ] [topological_space τ] [topological_add_group τ] {α : Type u_2} [topological_space α] (ϕ : flow τ α) : flow τ α :=
  mk (fun (t : τ) => coe_fn ϕ (-t)) sorry sorry sorry

/-- The map `ϕ t` as a homeomorphism. -/
def to_homeomorph {τ : Type u_1} [add_comm_group τ] [topological_space τ] [topological_add_group τ] {α : Type u_2} [topological_space α] (ϕ : flow τ α) (t : τ) : α ≃ₜ α :=
  homeomorph.mk (equiv.mk (coe_fn ϕ t) (coe_fn ϕ (-t)) sorry sorry)

theorem image_eq_preimage {τ : Type u_1} [add_comm_group τ] [topological_space τ] [topological_add_group τ] {α : Type u_2} [topological_space α] (ϕ : flow τ α) (t : τ) (s : set α) : coe_fn ϕ t '' s = coe_fn ϕ (-t) ⁻¹' s :=
  equiv.image_eq_preimage (homeomorph.to_equiv (to_homeomorph ϕ t)) s


import IMO2020.N4.N4_basic extra.number_theory.totient_bound data.nat.prime_norm_num

/-! # IMO 2020 N4, Generalized Version (Part 1) -/

namespace IMOSL
namespace IMO2020N4

open finset function

def alternating (p a b : ℕ) :=
  {i : ℕ | (F p)^[i] a < (F p^[i]) b}.infinite ∧ {i : ℕ | (F p)^[i] b < (F p^[i]) a}.infinite

def good (p : ℕ) := ∃ a b : ℕ, a.coprime p ∧ b.coprime p ∧ alternating p a b

section extra_lemmas

private lemma pow_sub_one_gcd (n k m : ℕ) :
  nat.gcd (n ^ k - 1) (n ^ m - 1) = n ^ (nat.gcd k m) - 1 :=
begin
  ---- The case `n = 0` is about the implementation of `nat.sub`
  rcases n.eq_zero_or_pos with rfl | h,
  suffices : ∀ n : ℕ, 0 ^ n - 1 = 0,
    rw [this, this, this, nat.gcd_self],
  intros n; rcases n.eq_zero_or_pos with rfl | h,
  rw [pow_zero, nat.sub_self],
  rw zero_pow h,

  ---- This is the real case: gcd induction is a standard way
  refine nat.gcd.induction k m (λ i, _) (λ i j hi h, _); clear k m,
  rw [pow_zero, nat.sub_self, nat.gcd_zero_left, nat.gcd_zero_left],
  rw [nat.gcd_rec i j, ← h, nat.gcd_comm]; clear h,
  refine nat.modeq.gcd_eq_of_modeq (nat.modeq.add_right_cancel' 1 _),
  obtain ⟨q, r, h0, rfl⟩ : ∃ q r : ℕ, r < i ∧ q * i + r = j :=
    ⟨j / i, j % i, j.mod_lt hi, nat.div_add_mod' j i⟩,
  replace h : ∀ k : ℕ, 1 ≤ n ^ k := λ k, nat.one_le_pow k n h,
  rw [nat.mul_add_mod, nat.mod_eq_of_lt h0, nat.sub_add_cancel (h _),
      nat.sub_add_cancel (h _), ← one_mul (n ^ r), pow_add, mul_comm q, pow_mul],
  nth_rewrite 1 ← one_pow q,
  exact nat.modeq.mul_right _ (nat.modeq.pow _ (nat.modeq_sub (h i)))
end

private lemma add_lt_mul {a b : ℕ} (ha : 3 ≤ a) (hb : 3 ≤ b) : a + b < a * b :=
begin
  have h : ∀ n : ℕ, 3 ≤ n → ∃ m : ℕ, n = m.succ :=
    λ n Y, nat.exists_eq_succ_of_ne_zero (ne_of_gt (lt_of_lt_of_le three_pos Y)),
  rcases h a ha with ⟨c, rfl⟩,
  rcases h b hb with ⟨d, rfl⟩,
  rw [nat.mul_succ, add_comm, nat.succ_mul, nat.succ_eq_one_add,
      add_lt_add_iff_right, add_lt_add_iff_right],
  rw [nat.succ_le_succ_iff, nat.succ_le_iff] at ha hb,
  exact nat.mul_lt_mul ha (le_of_lt hb) one_pos
end

private lemma two_pow_add_two_pow_ne_Mersenne {k : ℕ} (h : 3 ≤ k) :
  ∀ i j : ℕ, 2 ^ i + 2 ^ j ≠ 2 ^ k - 1 :=
begin
  suffices : ∀ i : ℕ, 2 ^ i + 1 + 1 ≠ 2 ^ k,
  { intros i j h0,
    rw eq_tsub_iff_add_eq_of_le (nat.one_le_two_pow k) at h0,
    rcases i.eq_zero_or_pos with rfl | hi,
    rw [pow_zero, add_comm 1] at h0; exact this j h0,
    rcases j.eq_zero_or_pos with rfl | hj,
    exact this i h0,
    replace h0 : even (2 ^ i + 2 ^ j + 1) ↔ even (2 ^ k) := by rw h0,
    revert h0; rw [imp_false, nat.even_add_one, ← not_iff, not_not, nat.even_add],
    replace this : ∀ c : ℕ, 0 < c → even (2 ^ c) :=
      λ c hc, (nat.even_pow' (ne_of_gt hc)).mpr even_two,
    replace h : 0 < k := lt_of_lt_of_le three_pos h,
    simp only [this, hi, hj, h, iff_self] },

  intros i h0,
  replace h0 : 2 ^ 3 ∣ 2 ^ i + 1 + 1 := by rw h0; exact pow_dvd_pow 2 h,
  clear h; revert h0; rw [add_assoc, imp_false],
  cases le_or_lt 3 i with h h,
  rw ← nat.dvd_add_iff_right (pow_dvd_pow 2 h),
  all_goals { apply nat.not_dvd_of_pos_of_lt; norm_num },
  rw nat.lt_succ_iff at h,
  refine lt_of_le_of_lt (add_le_add_right (pow_mono one_le_two h) _) _,
  norm_num
end

private lemma two_pow_or_sub_two_pow {k : ℕ} (h : k = 3 ∨ k = 4) :
  ∀ {x : ℕ}, x.coprime (2 ^ k - 1) → x < 2 ^ k - 1 →
    ∃ i : ℕ, i < k ∧ (x = 2 ^ i ∨ x = 2 ^ k - 1 - 2 ^ i) :=
begin
  ---- First reduce to a set equality
  suffices : (image (λ i, 2 ^ i) (range k) ∪ image (λ i, 2 ^ k - 1 - 2 ^ i) (range k)) =
    (filter (nat.coprime (2 ^ k - 1)) (range (2 ^ k - 1))),
  { intros x h0 h1,
    replace h1 : x ∈ filter (nat.coprime (2 ^ k - 1)) (range (2 ^ k - 1)) :=
      by rw [mem_filter, mem_range]; exact ⟨h1, h0.symm⟩,
    clear h0; rw [← this, mem_union, mem_image, mem_image] at h1,
    rcases h1 with ⟨i, h1, rfl⟩ | ⟨i, h1, rfl⟩; rw mem_range at h1,
    exacts [⟨i, h1, or.inl rfl⟩, ⟨i, h1, or.inr rfl⟩] },

  have h0 : 1 < k := by rcases h with rfl | rfl; norm_num,
  refine eq_of_subset_of_card_le (λ x h1, _) (le_of_eq _),

  ---- RHS contains LHS
  { rw [mem_filter, mem_range],
    simp only [mem_union, mem_image, mem_range] at h1,
    rcases h1 with ⟨i, h1, rfl⟩ | ⟨i, h1, rfl⟩; split,
    exact two_pow_lt_Mersenne h0 h1,
    exact (two_coprime_p (Mersenne_odd (pos_of_gt h0))).symm.pow_right i,
    rw [tsub_lt_self_iff, tsub_pos_iff_lt],
    exact ⟨nat.one_lt_two_pow k (pos_of_gt h0), pow_pos two_pos i⟩,
    replace h1 := two_pow_lt_Mersenne h0 h1,
    rw lt_iff_exists_add at h1,
    rcases h1 with ⟨c, h1, h2⟩,
    rw [h2, nat.add_sub_cancel_left, nat.coprime_add_self_left,
        ← nat.coprime_add_self_right, add_comm, ← h2],
    exact (two_coprime_p (Mersenne_odd (pos_of_gt h0))).pow_left i },

  ---- LHS and RHS has the same cardinality
  { have X : ∀ i j, 2 ^ i = 2 ^ j → i = j := nat.pow_right_injective (le_refl 2),
    rw [← nat.totient, card_union_eq, card_image_of_injective _ X,
        card_image_of_inj_on (λ i hi j hj h1, X i j _), card_range],

    -- The main equality: `φ(2^k - 1) = 2k` for `k = 3, 4`
    { rcases h with rfl | rfl; norm_num,
      rw nat.totient_prime (by norm_num : nat.prime 7),
      change 15 with 3 * 5,
      rw [nat.totient_mul, nat.totient_prime, nat.totient_prime],
      all_goals { norm_num } },

    -- If `2^k - 1 - 2^i = 2^k - 1 - 2^j`, then `i = j`
    { rw [mem_coe, mem_range] at hi hj,
      replace X : ∀ i : ℕ, i < k → 2 ^ i ≤ 2 ^ k - 1 :=
        λ i Y, le_of_lt (two_pow_lt_Mersenne h0 Y),
      exact (tsub_right_inj (X i hi) (X j hj)).mp h1 },

    -- `2^i ≠ 2^k - 1 - 2^j` for any `i, j < k`
    { rw [disjoint_iff, inf_eq_inter, bot_eq_empty, eq_empty_iff_forall_not_mem],
      intros c h1,
      simp only [inf_eq_inter, mem_image, mem_inter, le_eq_subset] at h1,
      rcases h1 with ⟨⟨i, -, rfl⟩, ⟨j, h1, h2⟩⟩,
      rw mem_range at h1,
      revert h2; rw nat.sub_eq_iff_eq_add (le_of_lt (two_pow_lt_Mersenne h0 h1)),
      refine (two_pow_add_two_pow_ne_Mersenne _ i j).symm,
      rcases h with rfl | rfl; norm_num } }
end

end extra_lemmas

/-! ## Equivalent criterion for `p` to be good -/
section good_iff

variables {p : ℕ} (h : odd p)
include h

private lemma alternating_S0_eq {a b : ℕ} (h0 : alternating p a b) : S0 h a = S0 h b :=
begin
  contrapose h0; rw [alternating, not_and_distrib],
  rw [← ne.def, ne_iff_lt_or_gt, gt_iff_lt] at h0,
  wlog h0 : S0 h a < S0 h b := h0 using [a b, b a],
  replace h0 := eventually_F_lt_of_S0_lt h h0,
  cases h0 with N h0,
  right; intros h1,
  replace h1 := h1.exists_nat_lt N,
  rcases h1 with ⟨n, h1, h2⟩,
  rw set.mem_set_of_eq at h1,
  exact lt_asymm h1 (h0 n (le_of_lt h2))
end

private lemma alternating_consecutive {a b : ℕ} (h0 : alternating p a b) :
  ∃ N : ℕ, (F p)^[N] b < (F p^[N]) a ∧ (F p^[N + 1]) a < (F p^[N + 1]) b :=
begin
  ---- First find some `K` with `F_p^K(b) < F_p^K(a)`.
  cases h0 with h0 h1,
  replace h1 := h1.nonempty,
  cases h1 with K h1,

  ---- Next find the minimum `N > K` with `F_p^N(a) < F_p^N(b)`.
  replace h0 := h0.exists_nat_lt K,
  cases nat.find_spec h0 with h2 h3,
  have h4 := nat.find_min h0 (nat.pred_lt (ne_of_gt (pos_of_gt h3))),
  generalize_hyp : nat.find h0 = N at h2 h3 h4,
  clear h0; rw set.mem_set_of_eq at h1 h2,
  simp only [exists_prop, not_and, exists_prop_congr', set.mem_set_of_eq, nat.pred_succ] at h4,

  ---- We have `N > 0`. Replace `N` with `N + 1` and show that `N` is the desired index.
  cases N with _ N,
  exfalso; exact not_lt_of_le K.zero_le h3,
  refine ⟨N, _, h2⟩; clear h2,
  contrapose! h4,
  rw nat.pred_succ; split,
  { refine ne.lt_of_le _ h4,
    clear h4; intros h4,
    replace h4 := injective.iterate (F_injective h) N h4,
    subst h4; exact ne_of_gt h1 rfl },
  { rw nat.lt_succ_iff at h3,
    refine ne.lt_of_le _ h3,
    clear h3; intros h3,
    subst h3; exact not_le_of_lt h1 h4 }
end

/-- Theorem 2 in the .tex file -/
private theorem good_iff' : good p ↔
  (∃ x y : ℕ, x.coprime p ∧ y.coprime p ∧ p / 2 + x < y ∧ y < p ∧ S0 h x = S0 h y) :=
begin
  refine ⟨λ h0, _, λ h0, _⟩,

  ---- Left-to-right direction
  { -- Replace `a` and `b` with `c` and `d` with `d < c` and `F_p(c) < F_p(d)`
    rcases h0 with ⟨a, b, ha, hb, h0⟩,
    have h2 := alternating_S0_eq h h0,
    replace h0 := alternating_consecutive h h0,
    rcases h0 with ⟨N, h0, h1⟩,
    rw [iterate_succ', comp_app, comp_app] at h1,
    replace ha := F_iterate_coprime h ha N,
    replace hb := F_iterate_coprime h hb N,
    rw [← S0_F_iterate h N, ← S0_F_iterate h N b] at h2,
    generalize_hyp : (F p^[N]) a = c at ha h2 h0 h1,
    generalize_hyp : (F p^[N]) b = d at hb h2 h0 h1,

    -- Finishing
    replace h1 := F_switch_sign h0 h1,
    clear h0 a b,
    rcases h1 with ⟨k, x, y, h0, h1, rfl, rfl⟩,
    rw nat.coprime_add_mul_right_left at ha hb,
    rw [S0_mod_p, nat.add_mul_mod_self_right, ← S0_mod_p,
        S0_mod_p h (y + _), nat.add_mul_mod_self_right, ← S0_mod_p] at h2,
    exact ⟨x, y, ha, hb, h0, h1, h2⟩ },

  ---- Right-to-left direction
  { rcases h0 with ⟨x, y, hx, hy, h0, h1, h2⟩,
    refine ⟨x + p, y, by rwa nat.coprime_add_self_left, hy, _⟩,
    have X : injective (λ k, k * order_two_mod_p h) :=
      mul_left_injective₀ (ne_of_gt (order_two_mod_p_pos h)),
    clear hx hy; split,

    -- `F_p^{kT + 1}(x + p) < F_p^{kT + 1}(y)` for all `k ≥ 0`
    { refine set.infinite_of_injective_forall_mem (injective.comp (add_left_injective 1) X) _,
      clear X; intros k; simp only [comp_app, set.mem_set_of_eq],
      have h3 : x < p := lt_trans (lt_of_le_of_lt le_add_self h0) h1,
      rw [← nat.add_mul_div_left _ _ two_pos, add_comm, nat.div_lt_iff_lt_mul two_pos] at h0,
      rwa [F_iterate_mul_ord_add, F_iterate_mul_ord_add, S_one, S_one, add_right_comm, S0_mod_p,
           nat.add_mod_right, nat.mod_eq_of_lt h3, add_right_comm x, add_right_comm _ (k * _),
           h2, add_lt_add_iff_right, nat.mod_eq_of_lt h1, ← two_mul, ← mul_two] },

    -- `F_p^{kT}(x + p) > F_p^{kT}(y)` for all `k ≥ 0`
    { refine set.infinite_of_injective_forall_mem X _,
      clear X h0; intros k,
      rw [set.mem_set_of_eq, F_iterate_mul_ord, F_iterate_mul_ord, S0_mod_p h (x + p),
          nat.add_mod_right, ← S0_mod_p, h2, add_lt_add_iff_right],
      exact lt_of_lt_of_le h1 le_add_self } }
end

end good_iff

/-! # Computations determining goodness -/
section computation

private lemma not_Mersenne_good {p : ℕ} (h : odd p) (h0 : ∀ k : ℕ, p ≠ 2 ^ k - 1) : good p :=
begin
  ---- Find the minimal `c` with `p ≤ 2^c`, and replace `c` with `c + 1`, as `c > 0`
  rw good_iff' h,
  obtain ⟨c, h1, h2⟩ : ∃ c : ℕ, p ≤ 2 ^ c ∧ ∀ b : ℕ, b < c → 2 ^ b < p :=
  begin
    have X : ∃ a : ℕ, p ≤ 2 ^ a := ⟨p, le_of_lt p.lt_two_pow⟩,
    refine ⟨nat.find X, nat.find_spec X, λ b h1, _⟩,
    replace h1 := nat.find_min X h1,
    rw ← not_le; exact h1
  end,
  cases c with _ c,
  { rw [pow_zero, le_iff_lt_or_eq, nat.lt_one_iff] at h1,
    rcases h1 with rfl | rfl,
    exfalso; exact h0 0 (by rw pow_zero),
    exfalso; exact h0 1 (by rw pow_one) },

  ---- Reduce to proving `p + 2 < 2^{c + 1}` and then proceed
  refine ⟨1, 2 ^ c, p.coprime_one_left, (two_coprime_p h).pow_left c,
    _, h2 c c.lt_succ_self, by rw [← mul_one (2 ^ c), S0_two_pow_mul]⟩,
  rw [← nat.add_mul_div_right _ _ two_pos, nat.div_lt_iff_lt_mul two_pos, ← pow_succ', one_mul],
  contrapose! h0; use c.succ,
  replace h2 : even (2 ^ c.succ) := nat.even_pow.mpr ⟨even_two, c.succ_ne_zero⟩,
  rw nat.odd_iff_not_even at h,
  rw [le_iff_eq_or_lt, ← nat.add_one_le_iff] at h1,
  rcases h1 with rfl | h1,
  exfalso; exact h h2,
  rw [le_iff_eq_or_lt, nat.lt_succ_iff] at h0,
  cases h0 with h0 h0,
  rw [h0, nat.even_add, iff_true_intro even_two, iff_true] at h2,
  exfalso; exact h h2,
  rw [le_antisymm h0 h1, nat.add_sub_cancel]
end

private lemma Mersenne_big_good {k : ℕ} (h : 5 ≤ k) : good (2 ^ k - 1) :=
begin
  ---- First, solve the case `k = 6`.
  have X : odd (2 ^ k - 1) := Mersenne_odd (lt_of_lt_of_le (by norm_num : 0 < 5) h),
  rw good_iff' X; rcases eq_or_ne k 6 with rfl | h0,
  refine ⟨5, 2 ^ 3 * 5, _, _, _, _, by rw S0_two_pow_mul⟩; norm_num,

  ---- Now focus on the case `k ≠ 6`. Reduce to the main inequality.
  replace h0 := extra.exists_nontrivial_coprime h h0,
  rcases h0 with ⟨c, d, h0, h1, h2, rfl⟩,
  replace h : nat.coprime (2 ^ c - 1) (2 ^ (c + d) - 1) :=
    by unfold nat.coprime at h2 ⊢; rw [pow_sub_one_gcd, nat.gcd_self_add_right, h2, pow_one],
  refine ⟨2 ^ c - 1, 2 ^ d * (2 ^ c - 1), h, ((two_coprime_p X).pow_left _).mul h, _⟩,
  rw and_comm; refine ⟨⟨_, by rw S0_two_pow_mul⟩, _⟩,
  rw [nat.mul_sub_left_distrib, mul_one, ← pow_add, add_comm],
  exact tsub_lt_tsub_left_of_le (nat.pow_le_pow_of_le_right two_pos le_add_self)
    (nat.one_lt_two_pow d (lt_trans one_pos h1)),

  ---- Now focus on the main inequality.
  replace X : 1 ≤ 2 := one_le_two,
  rw ← nat.succ_le_iff at h0 h1,
  replace h0 := pow_le_pow X h0,
  replace h1 := pow_le_pow X h1,
  rw pow_add,
  generalize_hyp : 2 ^ c = M at h0 ⊢,
  generalize_hyp : 2 ^ d = N at h1 ⊢,
  norm_num at h0 h1,
  replace h : ∀ n : ℕ, 4 ≤ n → ∃ m : ℕ, n = m.succ :=
    λ n Y, nat.exists_eq_succ_of_ne_zero (ne_of_gt (lt_of_lt_of_le four_pos Y)),
  obtain ⟨m, rfl⟩ := h M h0,
  obtain ⟨n, rfl⟩ := h N h1,
  clear X h h2,
  rw nat.succ_le_succ_iff at h0 h1,
  rw [nat.succ_sub_one, nat.succ_mul, nat.mul_succ, nat.succ_mul, add_lt_add_iff_right,
      nat.succ_eq_add_one, ← add_assoc, nat.add_sub_cancel, nat.div_lt_iff_lt_mul two_pos,
      mul_comm, mul_two, add_assoc, add_lt_add_iff_left, mul_comm],
  exact add_lt_mul h0 h1
end

private lemma Mersenne_small_bad {k : ℕ} (h : 0 < k) (h0 : k < 5) : ¬good (2 ^ k - 1) :=
begin
  have X : odd (2 ^ k - 1) := Mersenne_odd h,
  rw [nat.lt_succ_iff, le_iff_lt_or_eq, nat.lt_succ_iff, le_iff_lt_or_eq, or_assoc] at h0,
  rw good_iff' X; rcases h0 with h0 | h0,

  ---- Easy case: `k ≤ 2`
  { rw [nat.lt_succ_iff, le_iff_lt_or_eq, nat.lt_succ_iff, le_iff_lt_or_eq, nat.lt_one_iff] at h0,
    rintros ⟨x, y, h1, -, h2, h3, -⟩; clear X,
    rcases h0 with (rfl | rfl) | rfl,
    exact lt_irrefl 0 h,
    rw [pow_one, bit0, nat.add_sub_cancel, nat.lt_one_iff] at h3,
    exact ne_of_gt (pos_of_gt h2) h3,
    norm_num at h1 h2 h3,
    rw [← nat.add_one_le_iff, le_iff_exists_add] at h2,
    rcases h2 with ⟨c, rfl⟩,
    rw [add_right_comm, nat.succ_lt_succ_iff, add_assoc, add_comm,
        nat.succ_lt_succ_iff, nat.lt_one_iff, add_eq_zero_iff] at h3,
    rcases h3 with ⟨rfl, -⟩,
    rw nat.coprime_zero_left at h1,
    revert h1; norm_num },

  ---- Hard case: `k = 3` and `k = 4`
  {  -- Setup
    set n := 2 ^ k - 1,
    have Y : ∀ x : ℕ, x.coprime n → x < n → ∃ i : ℕ, i < k ∧ (x = 2 ^ i ∨ x = n - 2 ^ i) :=
      λ x, two_pow_or_sub_two_pow h0,
    rintros ⟨x, y, h1, h2, h3, h4, h5⟩,
    replace h1 := Y x h1 (lt_trans (lt_of_le_of_lt le_add_self h3) h4),
    replace h2 := Y y h2 h4,
    revert h3 h5; rw [imp_false, imp_iff_not_or, not_lt],
    replace h : 2 < k := by rcases h0 with rfl | rfl; norm_num,
    replace h4 : n ≠ (k - 1) * n := ne_of_lt (lt_mul_left X.pos (lt_tsub_iff_left.mpr h)),
    replace h0 : 1 < k := lt_trans one_lt_two h,
    replace Y : ∀ i j : ℕ, i < k → 2 ^ i ≤ n / 2 + 2 ^ j :=
    begin
      intros i j hi,
      refine le_trans _ (add_le_add_left j.one_le_two_pow _),
      rw [← nat.add_mul_div_right _ _ two_pos, one_mul,
          nat.le_div_iff_mul_le two_pos, ← pow_succ'],
      rw ← nat.succ_le_iff at hi; refine le_trans (pow_mono one_le_two hi) _,
      change 2 ^ k ≤ 2 ^ k - 1 + 1 + 1,
      rw nat.sub_add_cancel k.one_le_two_pow; exact le_self_add
    end,

    -- Case divisions
    rcases h1 with ⟨i, h1, rfl | rfl⟩; rcases h2 with ⟨j, h2, rfl | rfl⟩,
    left; exact Y j i h2,
    right; rw [S0_two_pow, S0_Mersenne_one X h0, S0_Mersenne_neg_two_pow X h0 h2]; exact h4,
    right; rw [S0_two_pow, S0_Mersenne_one X h0, S0_Mersenne_neg_two_pow X h0 h1]; exact h4.symm,
    left; replace Y := Y i j h1,
    rw [tsub_le_iff_right, add_right_comm, ← nat.add_sub_assoc,
        le_tsub_iff_left (le_trans Y le_self_add), add_le_add_iff_right],
    exacts [Y, le_of_lt (two_pow_lt_Mersenne h0 h1)] }
end

private theorem final_solution_part1' {p : ℕ} (h : odd p) :
  good p ↔ ¬∃ (k : ℕ) (_ : k ∈ range 4), 2 ^ k.succ - 1 = p :=
begin
  by_cases h0 : ∀ k : ℕ, p ≠ 2 ^ k - 1,

  ---- Case 1: `p` is not Mersenne
  { rw [iff_true_intro (not_Mersenne_good h h0), true_iff],
    rintros ⟨k, -, rfl⟩; exact h0 k.succ rfl },

  simp only [not_forall, not_not] at h0,
  rcases h0 with ⟨k, rfl⟩,
  cases k with _ k,
  rw [pow_zero, nat.sub_self, nat.odd_iff_not_even] at h,
  exfalso; exact h even_zero,
  by_cases h0 : 5 ≤ k.succ,

  ---- Case 2: `p = 2^{k + 1} - 1`, `k + 1 ≥ 5`
  { rw [iff_true_intro (Mersenne_big_good h0), true_iff],
    rintros ⟨m, h1, h2⟩,
    have X : ∀ n : ℕ, 1 ≤ 2 ^ n := λ n, nat.one_le_pow n 2 two_pos,
    rw [← add_left_inj 1, nat.sub_add_cancel (X _), nat.sub_add_cancel (X _)] at h2,
    replace h2 := nat.succ_injective (nat.pow_right_injective (le_refl 2) h2),
    rw [← h2, nat.succ_le_succ_iff] at h0,
    rw mem_range at h1; exact not_lt_of_le h0 h1 },

  ---- Case 3: `p = 2^k - 1`, `k < 5`
  { rw not_le at h0,
    rw [iff_false_intro (Mersenne_small_bad k.succ_pos h0), false_iff, not_not],
    rw [nat.succ_lt_succ_iff, ← mem_range] at h0,
    exact ⟨k, h0, rfl⟩ }
end

end computation

/-- Final solution, part 1 -/
theorem final_solution_part1 {p : ℕ} (h : odd p) :
  good p ↔ p ∉ ({1, 3, 7, 15} : finset ℕ) :=
  by rw [final_solution_part1' h, not_iff_not, ← mem_image]; congr'

end IMO2020N4
end IMOSL


/-
Copyright (c) 2020 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel, Floris van Doorn
-/
import geometry.manifold.charted_space

/-!
# Local properties invariant under a groupoid

We study properties of a triple `(g, s, x)` where `g` is a function between two spaces `H` and `H'`,
`s` is a subset of `H` and `x` is a point of `H`. Our goal is to register how such a property
should behave to make sense in charted spaces modelled on `H` and `H'`.

The main examples we have in mind are the properties "`g` is differentiable at `x` within `s`", or
"`g` is smooth at `x` within `s`". We want to develop general results that, when applied in these
specific situations, say that the notion of smooth function in a manifold behaves well under
restriction, intersection, is local, and so on.

## Main definitions

* `local_invariant_prop G G' P` says that a property `P` of a triple `(g, s, x)` is local, and
  invariant under composition by elements of the groupoids `G` and `G'` of `H` and `H'`
  respectively.
* `charted_space.lift_prop_within_at` (resp. `lift_prop_at`, `lift_prop_on` and `lift_prop`):
  given a property `P` of `(g, s, x)` where `g : H → H'`, define the corresponding property
  for functions `M → M'` where `M` and `M'` are charted spaces modelled respectively on `H` and
  `H'`. We define these properties within a set at a point, or at a point, or on a set, or in the
  whole space. This lifting process (obtained by restricting to suitable chart domains) can always
  be done, but it only behaves well under locality and invariance assumptions.

Given `hG : local_invariant_prop G G' P`, we deduce many properties of the lifted property on the
charted spaces. For instance, `hG.lift_prop_within_at_inter` says that `P g s x` is equivalent to
`P g (s ∩ t) x` whenever `t` is a neighborhood of `x`.

## Implementation notes

We do not use dot notation for properties of the lifted property. For instance, we have
`hG.lift_prop_within_at_congr` saying that if `lift_prop_within_at P g s x` holds, and `g` and `g'`
coincide on `s`, then `lift_prop_within_at P g' s x` holds. We can't call it
`lift_prop_within_at.congr` as it is in the namespace associated to `local_invariant_prop`, not
in the one for `lift_prop_within_at`.
-/

noncomputable theory
open_locale classical manifold topology

open set filter

variables {H M H' M' X : Type*}
variables [topological_space H] [topological_space M] [charted_space H M]
variables [topological_space H'] [topological_space M'] [charted_space H' M']
variables [topological_space X]

namespace structure_groupoid

variables (G : structure_groupoid H) (G' : structure_groupoid H')

/-- Structure recording good behavior of a property of a triple `(f, s, x)` where `f` is a function,
`s` a set and `x` a point. Good behavior here means locality and invariance under given groupoids
(both in the source and in the target). Given such a good behavior, the lift of this property
to charted spaces admitting these groupoids will inherit the good behavior. -/
structure local_invariant_prop (P : (H → H') → (set H) → H → Prop) : Prop :=
(is_local : ∀ {s x u} {f : H → H'}, is_open u → x ∈ u → (P f s x ↔ P f (s ∩ u) x))
(right_invariance' : ∀ {s x f} {e : local_homeomorph H H}, e ∈ G → x ∈ e.source → P f s x →
                      P (f ∘ e.symm) (e.symm ⁻¹' s) (e x))
(congr_of_forall : ∀ {s x} {f g : H → H'}, (∀ y ∈ s, f y = g y) → f x = g x → P f s x → P g s x)
(left_invariance' : ∀ {s x f} {e' : local_homeomorph H' H'}, e' ∈ G' → s ⊆ f ⁻¹' e'.source →
                     f x ∈ e'.source → P f s x → P (e' ∘ f) s x)

variables {G G'} {P : (H → H') → (set H) → H → Prop} {s t u : set H} {x : H}

variable (hG : G.local_invariant_prop G' P)
include hG

namespace local_invariant_prop

lemma congr_set {s t : set H} {x : H} {f : H → H'} (hu : s =ᶠ[𝓝 x] t) :
  P f s x ↔ P f t x :=
begin
  obtain ⟨o, host, ho, hxo⟩ := mem_nhds_iff.mp hu.mem_iff,
  simp_rw [subset_def, mem_set_of, ← and.congr_left_iff, ← mem_inter_iff, ← set.ext_iff] at host,
  rw [hG.is_local ho hxo, host, ← hG.is_local ho hxo]
end

lemma is_local_nhds {s u : set H} {x : H} {f : H → H'} (hu : u ∈ 𝓝[s] x) :
  P f s x ↔ P f (s ∩ u) x :=
hG.congr_set $ mem_nhds_within_iff_eventually_eq.mp hu

lemma congr_iff_nhds_within {s : set H} {x : H} {f g : H → H'} (h1 : f =ᶠ[𝓝[s] x] g)
  (h2 : f x = g x) : P f s x ↔ P g s x :=
by { simp_rw [hG.is_local_nhds h1],
  exact ⟨hG.congr_of_forall (λ y hy, hy.2) h2, hG.congr_of_forall (λ y hy, hy.2.symm) h2.symm⟩ }

lemma congr_nhds_within {s : set H} {x : H} {f g : H → H'} (h1 : f =ᶠ[𝓝[s] x] g) (h2 : f x = g x)
  (hP : P f s x) : P g s x :=
(hG.congr_iff_nhds_within h1 h2).mp hP

lemma congr_nhds_within' {s : set H} {x : H} {f g : H → H'} (h1 : f =ᶠ[𝓝[s] x] g) (h2 : f x = g x)
  (hP : P g s x) : P f s x :=
(hG.congr_iff_nhds_within h1 h2).mpr hP

lemma congr_iff {s : set H} {x : H} {f g : H → H'} (h : f =ᶠ[𝓝 x] g) : P f s x ↔ P g s x :=
hG.congr_iff_nhds_within (mem_nhds_within_of_mem_nhds h) (mem_of_mem_nhds h : _)

lemma congr {s : set H} {x : H} {f g : H → H'} (h : f =ᶠ[𝓝 x] g) (hP : P f s x) : P g s x :=
(hG.congr_iff h).mp hP

lemma congr' {s : set H} {x : H} {f g : H → H'} (h : f =ᶠ[𝓝 x] g) (hP : P g s x) : P f s x :=
hG.congr h.symm hP

lemma left_invariance {s : set H} {x : H} {f : H → H'} {e' : local_homeomorph H' H'}
  (he' : e' ∈ G') (hfs : continuous_within_at f s x) (hxe' : f x ∈ e'.source) :
  P (e' ∘ f) s x ↔ P f s x :=
begin
  have h2f := hfs.preimage_mem_nhds_within (e'.open_source.mem_nhds hxe'),
  have h3f := (((e'.continuous_at hxe').comp_continuous_within_at hfs).preimage_mem_nhds_within $
    e'.symm.open_source.mem_nhds $ e'.maps_to hxe'),
  split,
  { intro h,
    rw [hG.is_local_nhds h3f] at h,
    have h2 := hG.left_invariance' (G'.symm he') (inter_subset_right _ _)
      (by exact e'.maps_to hxe') h,
    rw [← hG.is_local_nhds h3f] at h2,
    refine hG.congr_nhds_within _ (e'.left_inv hxe') h2,
    exact eventually_of_mem h2f (λ x', e'.left_inv) },
  { simp_rw [hG.is_local_nhds h2f],
    exact hG.left_invariance' he' (inter_subset_right _ _) hxe' }
end

lemma right_invariance {s : set H} {x : H} {f : H → H'} {e : local_homeomorph H H}
  (he : e ∈ G) (hxe : x ∈ e.source) : P (f ∘ e.symm) (e.symm ⁻¹' s) (e x) ↔ P f s x :=
begin
  refine ⟨λ h, _, hG.right_invariance' he hxe⟩,
  have := hG.right_invariance' (G.symm he) (e.maps_to hxe) h,
  rw [e.symm_symm, e.left_inv hxe] at this,
  refine hG.congr _ ((hG.congr_set _).mp this),
  { refine eventually_of_mem (e.open_source.mem_nhds hxe) (λ x' hx', _),
    simp_rw [function.comp_apply, e.left_inv hx'] },
  { rw [eventually_eq_set],
    refine eventually_of_mem (e.open_source.mem_nhds hxe) (λ x' hx', _),
    simp_rw [mem_preimage, e.left_inv hx'] },
end

end local_invariant_prop
end structure_groupoid

namespace charted_space

/-- Given a property of germs of functions and sets in the model space, then one defines
a corresponding property in a charted space, by requiring that it holds at the preferred chart at
this point. (When the property is local and invariant, it will in fact hold using any chart, see
`lift_prop_within_at_indep_chart`). We require continuity in the lifted property, as otherwise one
single chart might fail to capture the behavior of the function.
-/
def lift_prop_within_at (P : (H → H') → set H → H → Prop)
  (f : M → M') (s : set M) (x : M) : Prop :=
continuous_within_at f s x ∧
P (chart_at H' (f x) ∘ f ∘ (chart_at H x).symm) ((chart_at H x).symm ⁻¹' s) (chart_at H x x)

/-- Given a property of germs of functions and sets in the model space, then one defines
a corresponding property of functions on sets in a charted space, by requiring that it holds
around each point of the set, in the preferred charts. -/
def lift_prop_on (P : (H → H') → set H → H → Prop) (f : M → M') (s : set M) :=
∀ x ∈ s, lift_prop_within_at P f s x

/-- Given a property of germs of functions and sets in the model space, then one defines
a corresponding property of a function at a point in a charted space, by requiring that it holds
in the preferred chart. -/
def lift_prop_at (P : (H → H') → set H → H → Prop) (f : M → M') (x : M) :=
lift_prop_within_at P f univ x

lemma lift_prop_at_iff {P : (H → H') → set H → H → Prop} {f : M → M'} {x : M} :
  lift_prop_at P f x ↔ continuous_at f x ∧
  P (chart_at H' (f x) ∘ f ∘ (chart_at H x).symm) univ (chart_at H x x) :=
by rw [lift_prop_at, lift_prop_within_at, continuous_within_at_univ, preimage_univ]

/-- Given a property of germs of functions and sets in the model space, then one defines
a corresponding property of a function in a charted space, by requiring that it holds
in the preferred chart around every point. -/
def lift_prop (P : (H → H') → set H → H → Prop) (f : M → M') :=
∀ x, lift_prop_at P f x

lemma lift_prop_iff {P : (H → H') → set H → H → Prop} {f : M → M'} :
  lift_prop P f ↔ continuous f ∧
  ∀ x, P (chart_at H' (f x) ∘ f ∘ (chart_at H x).symm) univ (chart_at H x x) :=
by simp_rw [lift_prop, lift_prop_at_iff, forall_and_distrib, continuous_iff_continuous_at]

end charted_space
open charted_space

namespace structure_groupoid

variables {G : structure_groupoid H} {G' : structure_groupoid H'}
{e e' : local_homeomorph M H} {f f' : local_homeomorph M' H'}
{P : (H → H') → set H → H → Prop} {g g' : M → M'} {s t : set M} {x : M}
{Q : (H → H) → set H → H → Prop}

lemma lift_prop_within_at_univ : lift_prop_within_at P g univ x ↔ lift_prop_at P g x :=
iff.rfl

lemma lift_prop_on_univ : lift_prop_on P g univ ↔ lift_prop P g :=
by simp [lift_prop_on, lift_prop, lift_prop_at]

lemma lift_prop_within_at_self {f : H → H'} {s : set H} {x : H} :
  lift_prop_within_at P f s x ↔ continuous_within_at f s x ∧ P f s x :=
iff.rfl

lemma lift_prop_within_at_self_source {f : H → M'} {s : set H} {x : H} :
  lift_prop_within_at P f s x ↔ continuous_within_at f s x ∧ P (chart_at H' (f x) ∘ f) s x :=
iff.rfl

lemma lift_prop_within_at_self_target {f : M → H'} :
  lift_prop_within_at P f s x ↔
    continuous_within_at f s x ∧
    P (f ∘ (chart_at H x).symm) ((chart_at H x).symm ⁻¹' s) (chart_at H x x) :=
iff.rfl

namespace local_invariant_prop

variable (hG : G.local_invariant_prop G' P)
include hG

/-- `lift_prop_within_at P f s x` is equivalent to a definition where we restrict the set we are
  considering to the domain of the charts at `x` and `f x`. -/
lemma lift_prop_within_at_iff {f : M → M'} :
  lift_prop_within_at P f s x ↔
  continuous_within_at f s x ∧ P ((chart_at H' (f x)) ∘ f ∘ (chart_at H x).symm)
  ((chart_at H x).target ∩ (chart_at H x).symm ⁻¹' (s ∩ f ⁻¹' (chart_at H' (f x)).source))
  (chart_at H x x) :=
begin
  refine and_congr_right (λ hf, hG.congr_set _),
  exact local_homeomorph.preimage_eventually_eq_target_inter_preimage_inter hf
    (mem_chart_source H x) (chart_source_mem_nhds H' (f x))
end

lemma lift_prop_within_at_indep_chart_source_aux (g : M → H')
  (he : e ∈ G.maximal_atlas M) (xe : x ∈ e.source)
  (he' : e' ∈ G.maximal_atlas M) (xe' : x ∈ e'.source) :
  P (g ∘ e.symm) (e.symm ⁻¹' s) (e x) ↔ P (g ∘ e'.symm) (e'.symm ⁻¹' s) (e' x) :=
begin
  rw [← hG.right_invariance (compatible_of_mem_maximal_atlas he he')],
  swap, { simp only [xe, xe'] with mfld_simps },
  simp_rw [local_homeomorph.trans_apply, e.left_inv xe],
  rw [hG.congr_iff],
  { refine hG.congr_set _,
    refine (eventually_of_mem _ $ λ y (hy : y ∈ e'.symm ⁻¹' e.source), _).set_eq,
    { refine (e'.symm.continuous_at $ e'.maps_to xe').preimage_mem_nhds (e.open_source.mem_nhds _),
      simp_rw [e'.left_inv xe', xe] },
    simp_rw [mem_preimage, local_homeomorph.coe_trans_symm, local_homeomorph.symm_symm,
      function.comp_apply, e.left_inv hy] },
  { refine ((e'.eventually_nhds' _ xe').mpr $ e.eventually_left_inverse xe).mono (λ y hy, _),
    simp only with mfld_simps,
    rw [hy] },
end

lemma lift_prop_within_at_indep_chart_target_aux2 (g : H → M') {x : H} {s : set H}
  (hf : f ∈ G'.maximal_atlas M') (xf : g x ∈ f.source)
  (hf' : f' ∈ G'.maximal_atlas M') (xf' : g x ∈ f'.source)
  (hgs : continuous_within_at g s x) :
  P (f ∘ g) s x ↔ P (f' ∘ g) s x :=
begin
  have hcont : continuous_within_at (f ∘ g) s x :=
    (f.continuous_at xf).comp_continuous_within_at hgs,
  rw [← hG.left_invariance (compatible_of_mem_maximal_atlas hf hf') hcont
      (by simp only [xf, xf'] with mfld_simps)],
  refine hG.congr_iff_nhds_within _ (by simp only [xf] with mfld_simps),
  exact (hgs.eventually $ f.eventually_left_inverse xf).mono (λ y, congr_arg f')
end

lemma lift_prop_within_at_indep_chart_target_aux {g : X → M'} {e : local_homeomorph X H} {x : X}
  {s : set X} (xe : x ∈ e.source)
  (hf : f ∈ G'.maximal_atlas M') (xf : g x ∈ f.source)
  (hf' : f' ∈ G'.maximal_atlas M') (xf' : g x ∈ f'.source)
  (hgs : continuous_within_at g s x) :
  P (f ∘ g ∘ e.symm) (e.symm ⁻¹' s) (e x) ↔ P (f' ∘ g ∘ e.symm) (e.symm ⁻¹' s) (e x) :=
begin
  rw [← e.left_inv xe] at xf xf' hgs,
  refine hG.lift_prop_within_at_indep_chart_target_aux2 (g ∘ e.symm) hf xf hf' xf' _,
  exact hgs.comp (e.symm.continuous_at $ e.maps_to xe).continuous_within_at subset.rfl
end

/-- If a property of a germ of function `g` on a pointed set `(s, x)` is invariant under the
structure groupoid (by composition in the source space and in the target space), then
expressing it in charted spaces does not depend on the element of the maximal atlas one uses
both in the source and in the target manifolds, provided they are defined around `x` and `g x`
respectively, and provided `g` is continuous within `s` at `x` (otherwise, the local behavior
of `g` at `x` can not be captured with a chart in the target). -/
lemma lift_prop_within_at_indep_chart_aux
  (he : e ∈ G.maximal_atlas M) (xe : x ∈ e.source)
  (he' : e' ∈ G.maximal_atlas M) (xe' : x ∈ e'.source)
  (hf : f ∈ G'.maximal_atlas M') (xf : g x ∈ f.source)
  (hf' : f' ∈ G'.maximal_atlas M') (xf' : g x ∈ f'.source)
  (hgs : continuous_within_at g s x) :
  P (f ∘ g ∘ e.symm) (e.symm ⁻¹' s) (e x) ↔ P (f' ∘ g ∘ e'.symm) (e'.symm ⁻¹' s) (e' x) :=
by rw [hG.lift_prop_within_at_indep_chart_source_aux (f ∘ g) he xe he' xe',
    hG.lift_prop_within_at_indep_chart_target_aux xe' hf xf hf' xf' hgs]

lemma lift_prop_within_at_indep_chart [has_groupoid M G] [has_groupoid M' G']
  (he : e ∈ G.maximal_atlas M) (xe : x ∈ e.source)
  (hf : f ∈ G'.maximal_atlas M') (xf : g x ∈ f.source) :
  lift_prop_within_at P g s x ↔
    continuous_within_at g s x ∧ P (f ∘ g ∘ e.symm) (e.symm ⁻¹' s) (e x) :=
and_congr_right $ hG.lift_prop_within_at_indep_chart_aux (chart_mem_maximal_atlas _ _)
  (mem_chart_source _ _) he xe (chart_mem_maximal_atlas _ _) (mem_chart_source _ _) hf xf

/-- A version of `lift_prop_within_at_indep_chart`, only for the source. -/
lemma lift_prop_within_at_indep_chart_source [has_groupoid M G]
  (he : e ∈ G.maximal_atlas M) (xe : x ∈ e.source) :
  lift_prop_within_at P g s x ↔ lift_prop_within_at P (g ∘ e.symm) (e.symm ⁻¹' s) (e x) :=
begin
  have := e.symm.continuous_within_at_iff_continuous_within_at_comp_right xe,
  rw [e.symm_symm] at this,
  rw [lift_prop_within_at_self_source, lift_prop_within_at, ← this],
  simp_rw [function.comp_app, e.left_inv xe],
  refine and_congr iff.rfl _,
  rw hG.lift_prop_within_at_indep_chart_source_aux (chart_at H' (g x) ∘ g)
    (chart_mem_maximal_atlas G x) (mem_chart_source H x) he xe,
end

/-- A version of `lift_prop_within_at_indep_chart`, only for the target. -/
lemma lift_prop_within_at_indep_chart_target [has_groupoid M' G']
  (hf : f ∈ G'.maximal_atlas M') (xf : g x ∈ f.source) :
  lift_prop_within_at P g s x ↔ continuous_within_at g s x ∧ lift_prop_within_at P (f ∘ g) s x :=
begin
  rw [lift_prop_within_at_self_target, lift_prop_within_at, and.congr_right_iff],
  intro hg,
  simp_rw [(f.continuous_at xf).comp_continuous_within_at hg, true_and],
  exact hG.lift_prop_within_at_indep_chart_target_aux (mem_chart_source _ _)
    (chart_mem_maximal_atlas _ _) (mem_chart_source _ _) hf xf hg
end

/-- A version of `lift_prop_within_at_indep_chart`, that uses `lift_prop_within_at` on both sides.
-/
lemma lift_prop_within_at_indep_chart' [has_groupoid M G] [has_groupoid M' G']
  (he : e ∈ G.maximal_atlas M) (xe : x ∈ e.source)
  (hf : f ∈ G'.maximal_atlas M') (xf : g x ∈ f.source) :
  lift_prop_within_at P g s x ↔
    continuous_within_at g s x ∧ lift_prop_within_at P (f ∘ g ∘ e.symm) (e.symm ⁻¹' s) (e x) :=
begin
  rw [hG.lift_prop_within_at_indep_chart he xe hf xf, lift_prop_within_at_self, and.left_comm,
    iff.comm, and_iff_right_iff_imp],
  intro h,
  have h1 := (e.symm.continuous_within_at_iff_continuous_within_at_comp_right xe).mp h.1,
  have : continuous_at f ((g ∘ e.symm) (e x)),
  { simp_rw [function.comp, e.left_inv xe, f.continuous_at xf] },
  exact this.comp_continuous_within_at h1,
end

lemma lift_prop_on_indep_chart [has_groupoid M G] [has_groupoid M' G']
  (he : e ∈ G.maximal_atlas M) (hf : f ∈ G'.maximal_atlas M') (h : lift_prop_on P g s)
  {y : H} (hy : y ∈ e.target ∩ e.symm ⁻¹'  (s ∩ g ⁻¹' f.source)) :
  P (f ∘ g ∘ e.symm) (e.symm ⁻¹' s) y :=
begin
  convert ((hG.lift_prop_within_at_indep_chart he (e.symm_maps_to hy.1) hf hy.2.2).1
    (h _ hy.2.1)).2,
  rw [e.right_inv hy.1],
end

lemma lift_prop_within_at_inter' (ht : t ∈ 𝓝[s] x) :
  lift_prop_within_at P g (s ∩ t) x ↔ lift_prop_within_at P g s x :=
begin
  rw [lift_prop_within_at, lift_prop_within_at, continuous_within_at_inter' ht, hG.congr_set],
  simp_rw [eventually_eq_set, mem_preimage,
    (chart_at H x).eventually_nhds' (λ x, x ∈ s ∩ t ↔ x ∈ s) (mem_chart_source H x)],
  exact (mem_nhds_within_iff_eventually_eq.mp ht).symm.mem_iff
end

lemma lift_prop_within_at_inter (ht : t ∈ 𝓝 x) :
  lift_prop_within_at P g (s ∩ t) x ↔ lift_prop_within_at P g s x :=
hG.lift_prop_within_at_inter' (mem_nhds_within_of_mem_nhds ht)

lemma lift_prop_at_of_lift_prop_within_at (h : lift_prop_within_at P g s x) (hs : s ∈ 𝓝 x) :
  lift_prop_at P g x :=
by rwa [← univ_inter s, hG.lift_prop_within_at_inter hs] at h

lemma lift_prop_within_at_of_lift_prop_at_of_mem_nhds (h : lift_prop_at P g x) (hs : s ∈ 𝓝 x) :
  lift_prop_within_at P g s x :=
by rwa [← univ_inter s, hG.lift_prop_within_at_inter hs]

lemma lift_prop_on_of_locally_lift_prop_on
  (h : ∀ x ∈ s, ∃ u, is_open u ∧ x ∈ u ∧ lift_prop_on P g (s ∩ u)) :
  lift_prop_on P g s :=
begin
  assume x hx,
  rcases h x hx with ⟨u, u_open, xu, hu⟩,
  have := hu x ⟨hx, xu⟩,
  rwa hG.lift_prop_within_at_inter at this,
  exact is_open.mem_nhds u_open xu,
end

lemma lift_prop_of_locally_lift_prop_on (h : ∀ x, ∃ u, is_open u ∧ x ∈ u ∧ lift_prop_on P g u) :
  lift_prop P g :=
begin
  rw ← lift_prop_on_univ,
  apply hG.lift_prop_on_of_locally_lift_prop_on (λ x hx, _),
  simp [h x],
end

lemma lift_prop_within_at_congr_of_eventually_eq
  (h : lift_prop_within_at P g s x) (h₁ : g' =ᶠ[𝓝[s] x] g) (hx : g' x = g x) :
  lift_prop_within_at P g' s x :=
begin
  refine ⟨h.1.congr_of_eventually_eq h₁ hx, _⟩,
  refine hG.congr_nhds_within' _ (by simp_rw [function.comp_apply,
    (chart_at H x).left_inv (mem_chart_source H x), hx]) h.2,
  simp_rw [eventually_eq, function.comp_app, (chart_at H x).eventually_nhds_within'
    (λ y, chart_at H' (g' x) (g' y) = chart_at H' (g x) (g y))
    (mem_chart_source H x)],
  exact h₁.mono (λ y hy, by rw [hx, hy])
end

lemma lift_prop_within_at_congr_iff_of_eventually_eq (h₁ :  g' =ᶠ[𝓝[s] x] g) (hx : g' x = g x) :
  lift_prop_within_at P g' s x ↔ lift_prop_within_at P g s x :=
⟨λ h, hG.lift_prop_within_at_congr_of_eventually_eq h h₁.symm hx.symm,
 λ h, hG.lift_prop_within_at_congr_of_eventually_eq h h₁ hx⟩

lemma lift_prop_within_at_congr_iff
  (h₁ : ∀ y ∈ s, g' y = g y) (hx : g' x = g x) :
  lift_prop_within_at P g' s x ↔ lift_prop_within_at P g s x :=
hG.lift_prop_within_at_congr_iff_of_eventually_eq (eventually_nhds_within_of_forall h₁) hx

lemma lift_prop_within_at_congr
  (h : lift_prop_within_at P g s x) (h₁ : ∀ y ∈ s, g' y = g y) (hx : g' x = g x) :
  lift_prop_within_at P g' s x :=
(hG.lift_prop_within_at_congr_iff h₁ hx).mpr h

lemma lift_prop_at_congr_iff_of_eventually_eq
  (h₁ : g' =ᶠ[𝓝 x] g) : lift_prop_at P g' x ↔ lift_prop_at P g x :=
hG.lift_prop_within_at_congr_iff_of_eventually_eq (by simp_rw [nhds_within_univ, h₁]) h₁.eq_of_nhds

lemma lift_prop_at_congr_of_eventually_eq (h : lift_prop_at P g x) (h₁ : g' =ᶠ[𝓝 x] g) :
  lift_prop_at P g' x :=
(hG.lift_prop_at_congr_iff_of_eventually_eq h₁).mpr h

lemma lift_prop_on_congr (h : lift_prop_on P g s) (h₁ : ∀ y ∈ s, g' y = g y) :
  lift_prop_on P g' s :=
λ x hx, hG.lift_prop_within_at_congr (h x hx) h₁ (h₁ x hx)

lemma lift_prop_on_congr_iff (h₁ : ∀ y ∈ s, g' y = g y) :
  lift_prop_on P g' s ↔ lift_prop_on P g s :=
⟨λ h, hG.lift_prop_on_congr h (λ y hy, (h₁ y hy).symm), λ h, hG.lift_prop_on_congr h h₁⟩

omit hG

lemma lift_prop_within_at_mono_of_mem
  (mono_of_mem : ∀ ⦃s x t⦄ ⦃f : H → H'⦄, s ∈ 𝓝[t] x → P f s x → P f t x)
  (h : lift_prop_within_at P g s x) (hst : s ∈ 𝓝[t] x) :
  lift_prop_within_at P g t x :=
begin
  refine ⟨h.1.mono_of_mem hst, mono_of_mem _ h.2⟩,
  simp_rw [← mem_map, (chart_at H x).symm.map_nhds_within_preimage_eq (mem_chart_target H x),
    (chart_at H x).left_inv (mem_chart_source H x), hst]
end

lemma lift_prop_within_at_mono
  (mono : ∀ ⦃s x t⦄ ⦃f : H → H'⦄, t ⊆ s → P f s x → P f t x)
  (h : lift_prop_within_at P g s x) (hts : t ⊆ s) :
  lift_prop_within_at P g t x :=
begin
  refine ⟨h.1.mono hts, _⟩,
  apply mono (λ y hy, _) h.2,
  simp only with mfld_simps at hy,
  simp only [hy, hts _] with mfld_simps,
end

lemma lift_prop_within_at_of_lift_prop_at
  (mono : ∀ ⦃s x t⦄ ⦃f : H → H'⦄, t ⊆ s → P f s x → P f t x) (h : lift_prop_at P g x) :
  lift_prop_within_at P g s x :=
begin
  rw ← lift_prop_within_at_univ at h,
  exact lift_prop_within_at_mono mono h (subset_univ _),
end

lemma lift_prop_on_mono (mono : ∀ ⦃s x t⦄ ⦃f : H → H'⦄, t ⊆ s → P f s x → P f t x)
  (h : lift_prop_on P g t) (hst : s ⊆ t) :
  lift_prop_on P g s :=
λ x hx, lift_prop_within_at_mono mono (h x (hst hx)) hst

lemma lift_prop_on_of_lift_prop
  (mono : ∀ ⦃s x t⦄ ⦃f : H → H'⦄, t ⊆ s → P f s x → P f t x) (h : lift_prop P g) :
  lift_prop_on P g s :=
begin
  rw ← lift_prop_on_univ at h,
  exact lift_prop_on_mono mono h (subset_univ _)
end

lemma lift_prop_at_of_mem_maximal_atlas [has_groupoid M G]
  (hG : G.local_invariant_prop G Q) (hQ : ∀ y, Q id univ y)
  (he : e ∈ maximal_atlas M G) (hx : x ∈ e.source) : lift_prop_at Q e x :=
begin
  simp_rw [lift_prop_at,
    hG.lift_prop_within_at_indep_chart he hx G.id_mem_maximal_atlas (mem_univ _),
    (e.continuous_at hx).continuous_within_at, true_and],
  exact hG.congr' (e.eventually_right_inverse' hx) (hQ _)
end

lemma lift_prop_at_symm_of_mem_maximal_atlas [has_groupoid M G] {x : H}
  (hG : G.local_invariant_prop G Q) (hQ : ∀ y, Q id univ y)
  (he : e ∈ maximal_atlas M G) (hx : x ∈ e.target) : lift_prop_at Q e.symm x :=
begin
  suffices h : Q (e ∘ e.symm) univ x,
  { have A : e.symm ⁻¹' e.source ∩ e.target = e.target,
      by mfld_set_tac,
    have : e.symm x ∈ e.source, by simp only [hx] with mfld_simps,
    rw [lift_prop_at,
      hG.lift_prop_within_at_indep_chart G.id_mem_maximal_atlas (mem_univ _) he this],
    refine ⟨(e.symm.continuous_at hx).continuous_within_at, _⟩,
    simp only [h] with mfld_simps },
  exact hG.congr' (e.eventually_right_inverse hx) (hQ x)
end

lemma lift_prop_on_symm_of_mem_maximal_atlas [has_groupoid M G]
  (hG : G.local_invariant_prop G Q) (hQ : ∀ y, Q id univ y) (he : e ∈ maximal_atlas M G) :
  lift_prop_on Q e.symm e.target :=
begin
  assume x hx,
  apply hG.lift_prop_within_at_of_lift_prop_at_of_mem_nhds
    (hG.lift_prop_at_symm_of_mem_maximal_atlas hQ he hx),
  exact is_open.mem_nhds e.open_target hx,
end

lemma lift_prop_at_chart [has_groupoid M G]
  (hG : G.local_invariant_prop G Q) (hQ : ∀ y, Q id univ y) : lift_prop_at Q (chart_at H x) x :=
hG.lift_prop_at_of_mem_maximal_atlas hQ (chart_mem_maximal_atlas G x) (mem_chart_source H x)

lemma lift_prop_on_chart [has_groupoid M G]
  (hG : G.local_invariant_prop G Q) (hQ : ∀ y, Q id univ y) :
  lift_prop_on Q (chart_at H x) (chart_at H x).source :=
hG.lift_prop_on_of_mem_maximal_atlas hQ (chart_mem_maximal_atlas G x)

lemma lift_prop_at_chart_symm [has_groupoid M G]
  (hG : G.local_invariant_prop G Q) (hQ : ∀ y, Q id univ y) :
  lift_prop_at Q (chart_at H x).symm ((chart_at H x) x) :=
hG.lift_prop_at_symm_of_mem_maximal_atlas hQ (chart_mem_maximal_atlas G x) (by simp)

lemma lift_prop_on_chart_symm [has_groupoid M G]
  (hG : G.local_invariant_prop G Q) (hQ : ∀ y, Q id univ y) :
  lift_prop_on Q (chart_at H x).symm (chart_at H x).target :=
hG.lift_prop_on_symm_of_mem_maximal_atlas hQ (chart_mem_maximal_atlas G x)

lemma lift_prop_at_of_mem_groupoid (hG : G.local_invariant_prop G Q) (hQ : ∀ y, Q id univ y)
  {f : local_homeomorph H H} (hf : f ∈ G) {x : H} (hx : x ∈ f.source) :
  lift_prop_at Q f x :=
lift_prop_at_of_mem_maximal_atlas hG hQ (G.mem_maximal_atlas_of_mem_groupoid hf) hx

lemma lift_prop_on_of_mem_groupoid (hG : G.local_invariant_prop G Q) (hQ : ∀ y, Q id univ y)
  {f : local_homeomorph H H} (hf : f ∈ G) :
  lift_prop_on Q f f.source :=
lift_prop_on_of_mem_maximal_atlas hG hQ (G.mem_maximal_atlas_of_mem_groupoid hf)

lemma lift_prop_id (hG : G.local_invariant_prop G Q) (hQ : ∀ y, Q id univ y) :
  lift_prop Q (id : M → M) :=
begin
  simp_rw [lift_prop_iff, continuous_id, true_and],
  exact λ x, hG.congr' ((chart_at H x).eventually_right_inverse $ mem_chart_target H x) (hQ _)
end

end local_invariant_prop

section local_structomorph

variables (G)
open local_homeomorph

/-- A function from a model space `H` to itself is a local structomorphism, with respect to a
structure groupoid `G` for `H`, relative to a set `s` in `H`, if for all points `x` in the set, the
function agrees with a `G`-structomorphism on `s` in a neighbourhood of `x`. -/
def is_local_structomorph_within_at (f : H → H) (s : set H) (x : H) : Prop :=
x ∈ s → ∃ (e : local_homeomorph H H), e ∈ G ∧ eq_on f e.to_fun (s ∩ e.source) ∧ x ∈ e.source

/-- For a groupoid `G` which is `closed_under_restriction`, being a local structomorphism is a local
invariant property. -/
lemma is_local_structomorph_within_at_local_invariant_prop [closed_under_restriction G] :
  local_invariant_prop G G (is_local_structomorph_within_at G) :=
{ is_local := begin
    intros s x u f hu hux,
    split,
    { rintros h hx,
      rcases h hx.1 with ⟨e, heG, hef, hex⟩,
      have : s ∩ u ∩ e.source ⊆ s ∩ e.source := by mfld_set_tac,
      exact ⟨e, heG, hef.mono this, hex⟩ },
    { rintros h hx,
      rcases h ⟨hx, hux⟩ with ⟨e, heG, hef, hex⟩,
      refine ⟨e.restr (interior u), _, _, _⟩,
      { exact closed_under_restriction' heG (is_open_interior) },
      { have : s ∩ u ∩ e.source = s ∩ (e.source ∩ u) := by mfld_set_tac,
        simpa only [this, interior_interior, hu.interior_eq] with mfld_simps using hef },
      { simp only [*, interior_interior, hu.interior_eq] with mfld_simps } }
  end,
  right_invariance' := begin
    intros s x f e' he'G he'x h hx,
    have hxs : x ∈ s := by simpa only [e'.left_inv he'x] with mfld_simps using hx,
    rcases h hxs with ⟨e, heG, hef, hex⟩,
    refine ⟨e'.symm.trans e, G.trans (G.symm he'G) heG, _, _⟩,
    { intros y hy,
      simp only with mfld_simps at hy,
      simp only [hef ⟨hy.1, hy.2.2⟩] with mfld_simps },
    { simp only [hex, he'x] with mfld_simps }
  end,
  congr_of_forall := begin
    intros s x f g hfgs hfg' h hx,
    rcases h hx with ⟨e, heG, hef, hex⟩,
    refine ⟨e, heG, _, hex⟩,
    intros y hy,
    rw [← hef hy, hfgs y hy.1]
  end,
  left_invariance' := begin
    intros s x f e' he'G he' hfx h hx,
    rcases h hx with ⟨e, heG, hef, hex⟩,
    refine ⟨e.trans e', G.trans heG he'G, _, _⟩,
    { intros y hy,
      simp only with mfld_simps at hy,
      simp only [hef ⟨hy.1, hy.2.1⟩] with mfld_simps },
    { simpa only [hex, hef ⟨hx, hex⟩] with mfld_simps using hfx }
  end }

/-- A slight reformulation of `is_local_structomorph_within_at` when `f` is a local homeomorph.
  This gives us an `e` that is defined on a subset of `f.source`. -/
lemma _root_.local_homeomorph.is_local_structomorph_within_at_iff {G : structure_groupoid H}
  [closed_under_restriction G]
  (f : local_homeomorph H H) {s : set H} {x : H} (hx : x ∈ f.source ∪ sᶜ) :
  G.is_local_structomorph_within_at ⇑f s x ↔
  x ∈ s → ∃ (e : local_homeomorph H H), e ∈ G ∧ e.source ⊆ f.source ∧
  eq_on f ⇑e (s ∩ e.source) ∧ x ∈ e.source :=
begin
  split,
  { intros hf h2x,
    obtain ⟨e, he, hfe, hxe⟩ := hf h2x,
    refine ⟨e.restr f.source, closed_under_restriction' he f.open_source, _, _, hxe, _⟩,
    { simp_rw [local_homeomorph.restr_source],
      refine (inter_subset_right _ _).trans interior_subset },
    { intros x' hx', exact hfe ⟨hx'.1, hx'.2.1⟩ },
    { rw [f.open_source.interior_eq], exact or.resolve_right hx (not_not.mpr h2x) } },
  { intros hf hx, obtain ⟨e, he, h2e, hfe, hxe⟩ := hf hx, exact ⟨e, he, hfe, hxe⟩ }
end

/-- A slight reformulation of `is_local_structomorph_within_at` when `f` is a local homeomorph and
  the set we're considering is a superset of `f.source`. -/
lemma _root_.local_homeomorph.is_local_structomorph_within_at_iff' {G : structure_groupoid H}
  [closed_under_restriction G]
  (f : local_homeomorph H H) {s : set H} {x : H} (hs : f.source ⊆ s) (hx : x ∈ f.source ∪ sᶜ) :
  G.is_local_structomorph_within_at ⇑f s x ↔
  x ∈ s → ∃ (e : local_homeomorph H H), e ∈ G ∧ e.source ⊆ f.source ∧
  eq_on f ⇑e e.source ∧ x ∈ e.source :=
begin
  simp_rw [f.is_local_structomorph_within_at_iff hx],
  refine imp_congr_right (λ hx, exists_congr $ λ e, and_congr_right $ λ he, _),
  refine and_congr_right (λ h2e, _),
  rw [inter_eq_right_iff_subset.mpr (h2e.trans hs)],
end

/-- A slight reformulation of `is_local_structomorph_within_at` when `f` is a local homeomorph and
  the set we're considering is `f.source`. -/
lemma _root_.local_homeomorph.is_local_structomorph_within_at_source_iff {G : structure_groupoid H}
  [closed_under_restriction G]
  (f : local_homeomorph H H) {x : H} :
  G.is_local_structomorph_within_at ⇑f f.source x ↔
  x ∈ f.source → ∃ (e : local_homeomorph H H), e ∈ G ∧ e.source ⊆ f.source ∧
  eq_on f ⇑e e.source ∧ x ∈ e.source :=
begin
  have : x ∈ f.source ∪ f.sourceᶜ, { simp_rw [union_compl_self] },
  exact f.is_local_structomorph_within_at_iff' subset.rfl this,
end

variables {H₁ : Type*} [topological_space H₁] {H₂ : Type*} [topological_space H₂]
   {H₃ : Type*} [topological_space H₃] [charted_space H₁ H₂] [charted_space H₂ H₃]
   {G₁ : structure_groupoid H₁} [has_groupoid H₂ G₁] [closed_under_restriction G₁]
   (G₂ : structure_groupoid H₂) [has_groupoid H₃ G₂]

variables (G₂)
lemma has_groupoid.comp
  (H : ∀ e ∈ G₂, lift_prop_on (is_local_structomorph_within_at G₁) (e : H₂ → H₂) e.source) :
  @has_groupoid H₁ _ H₃ _ (charted_space.comp H₁ H₂ H₃) G₁ :=
{ compatible := begin
    rintros _ _ ⟨e, f, he, hf, rfl⟩ ⟨e', f', he', hf', rfl⟩,
    apply G₁.locality,
    intros x hx,
    simp only with mfld_simps at hx,
    have hxs : x ∈ f.symm ⁻¹' (e.symm ≫ₕ e').source,
    { simp only [hx] with mfld_simps },
    have hxs' : x ∈ f.target ∩ (f.symm) ⁻¹' ((e.symm ≫ₕ e').source ∩ (e.symm ≫ₕ e') ⁻¹' f'.source),
    { simp only [hx] with mfld_simps },
    obtain ⟨φ, hφG₁, hφ, hφ_dom⟩ := local_invariant_prop.lift_prop_on_indep_chart
      (is_local_structomorph_within_at_local_invariant_prop G₁) (G₁.subset_maximal_atlas hf)
      (G₁.subset_maximal_atlas hf') (H _ (G₂.compatible he he')) hxs' hxs,
    simp_rw [← local_homeomorph.coe_trans, local_homeomorph.trans_assoc] at hφ,
    simp_rw [local_homeomorph.trans_symm_eq_symm_trans_symm, local_homeomorph.trans_assoc],
    have hs : is_open (f.symm ≫ₕ e.symm ≫ₕ e' ≫ₕ f').source :=
      (f.symm ≫ₕ e.symm ≫ₕ e' ≫ₕ f').open_source,
    refine ⟨_, hs.inter φ.open_source, _, _⟩,
    { simp only [hx, hφ_dom] with mfld_simps, },
    { refine G₁.eq_on_source (closed_under_restriction' hφG₁ hs) _,
      rw local_homeomorph.restr_source_inter,
      refine (hφ.mono _).restr_eq_on_source,
      mfld_set_tac },
  end }

end local_structomorph

end structure_groupoid