/-
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 data.equiv.local_equiv
import topology.opens

/-!
# Local homeomorphisms

This file defines homeomorphisms between open subsets of topological spaces. An element `e` of
`local_homeomorph α β` is an extension of `local_equiv α β`, i.e., it is a pair of functions
`e.to_fun` and `e.inv_fun`, inverse of each other on the sets `e.source` and `e.target`.
Additionally, we require that these sets are open, and that the functions are continuous on them.
Equivalently, they are homeomorphisms there.

As in equivs, we register a coercion to functions, and we use `e x` and `e.symm x` throughout
instead of `e.to_fun x` and `e.inv_fun x`.

## Main definitions

`homeomorph.to_local_homeomorph`: associating a local homeomorphism to a homeomorphism, with
                                  source = target = univ
`local_homeomorph.symm`  : the inverse of a local homeomorphism
`local_homeomorph.trans` : the composition of two local homeomorphisms
`local_homeomorph.refl`  : the identity local homeomorphism
`local_homeomorph.of_set`: the identity on a set `s`
`eq_on_source`           : equivalence relation describing the "right" notion of equality for local
                           homeomorphisms

## Implementation notes

Most statements are copied from their local_equiv versions, although some care is required
especially when restricting to subsets, as these should be open subsets.

For design notes, see `local_equiv.lean`.

### Local coding conventions

If a lemma deals with the intersection of a set with either source or target of a `local_equiv`,
then it should use `e.source ∩ s` or `e.target ∩ t`, not `s ∩ e.source` or `t ∩ e.target`.
-/

open function set filter topological_space (second_countable_topology)
open_locale topological_space

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

/-- local homeomorphisms, defined on open subsets of the space -/
@[nolint has_inhabited_instance]
structure local_homeomorph (α : Type*) (β : Type*) [topological_space α] [topological_space β]
  extends local_equiv α β :=
(open_source        : is_open source)
(open_target        : is_open target)
(continuous_to_fun  : continuous_on to_fun source)
(continuous_inv_fun : continuous_on inv_fun target)

/-- A homeomorphism induces a local homeomorphism on the whole space -/
def homeomorph.to_local_homeomorph (e : α ≃ₜ β) :
  local_homeomorph α β :=
{ open_source        := is_open_univ,
  open_target        := is_open_univ,
  continuous_to_fun  := by { erw ← continuous_iff_continuous_on_univ, exact e.continuous_to_fun },
  continuous_inv_fun := by { erw ← continuous_iff_continuous_on_univ, exact e.continuous_inv_fun },
  ..e.to_equiv.to_local_equiv }

namespace local_homeomorph

variables (e : local_homeomorph α β) (e' : local_homeomorph β γ)

instance : has_coe_to_fun (local_homeomorph α β) := ⟨_, λ e, e.to_local_equiv.to_fun⟩

/-- The inverse of a local homeomorphism -/
protected def symm : local_homeomorph β α :=
{ open_source        := e.open_target,
  open_target        := e.open_source,
  continuous_to_fun  := e.continuous_inv_fun,
  continuous_inv_fun := e.continuous_to_fun,
  ..e.to_local_equiv.symm }

/-- See Note [custom simps projection]. We need to specify this projection explicitly in this case,
  because it is a composition of multiple projections. -/
def simps.apply (e : local_homeomorph α β) : α → β := e
/-- See Note [custom simps projection] -/
def simps.symm_apply (e : local_homeomorph α β) : β → α := e.symm

initialize_simps_projections local_homeomorph
  (to_local_equiv_to_fun → apply, to_local_equiv_inv_fun → symm_apply,
   to_local_equiv_source → source, to_local_equiv_target → target, -to_local_equiv)

protected lemma continuous_on : continuous_on e e.source := e.continuous_to_fun

lemma continuous_on_symm : continuous_on e.symm e.target := e.continuous_inv_fun

@[simp, mfld_simps] lemma mk_coe (e : local_equiv α β) (a b c d) :
  (local_homeomorph.mk e a b c d : α → β) = e := rfl

@[simp, mfld_simps] lemma mk_coe_symm (e : local_equiv α β) (a b c d) :
  ((local_homeomorph.mk e a b c d).symm : β → α) = e.symm := rfl

/- Register a few simp lemmas to make sure that `simp` puts the application of a local
homeomorphism in its normal form, i.e., in terms of its coercion to a function. -/

@[simp, mfld_simps] lemma to_fun_eq_coe (e : local_homeomorph α β) : e.to_fun = e := rfl

@[simp, mfld_simps] lemma inv_fun_eq_coe (e : local_homeomorph α β) : e.inv_fun = e.symm := rfl

@[simp, mfld_simps] lemma coe_coe : (e.to_local_equiv : α → β) = e := rfl

@[simp, mfld_simps] lemma coe_coe_symm : (e.to_local_equiv.symm : β → α) = e.symm := rfl

@[simp, mfld_simps] lemma map_source {x : α} (h : x ∈ e.source) : e x ∈ e.target :=
e.map_source' h

@[simp, mfld_simps] lemma map_target {x : β} (h : x ∈ e.target) : e.symm x ∈ e.source :=
e.map_target' h

@[simp, mfld_simps] lemma left_inv {x : α} (h : x ∈ e.source) : e.symm (e x) = x :=
e.left_inv' h

@[simp, mfld_simps] lemma right_inv {x : β} (h : x ∈ e.target) : e (e.symm x) = x :=
e.right_inv' h

protected lemma maps_to : maps_to e e.source e.target := λ x, e.map_source
protected lemma symm_maps_to : maps_to e.symm e.target e.source := e.symm.maps_to
protected lemma left_inv_on : left_inv_on e.symm e e.source := λ x, e.left_inv
protected lemma right_inv_on : right_inv_on e.symm e e.target := λ x, e.right_inv
protected lemma inv_on : inv_on e.symm e e.source e.target := ⟨e.left_inv_on, e.right_inv_on⟩
protected lemma inj_on : inj_on e e.source := e.left_inv_on.inj_on
protected lemma bij_on : bij_on e e.source e.target := e.inv_on.bij_on e.maps_to e.symm_maps_to
protected lemma surj_on : surj_on e e.source e.target := e.bij_on.surj_on

/-- Replace `to_local_equiv` field to provide better definitional equalities. -/
def replace_equiv (e : local_homeomorph α β) (e' : local_equiv α β) (h : e.to_local_equiv = e') :
  local_homeomorph α β :=
{ to_local_equiv := e',
  open_source := h ▸ e.open_source,
  open_target := h ▸ e.open_target,
  continuous_to_fun := h ▸ e.continuous_to_fun,
  continuous_inv_fun := h ▸ e.continuous_inv_fun }

lemma replace_equiv_eq_self (e : local_homeomorph α β) (e' : local_equiv α β)
  (h : e.to_local_equiv = e') :
  e.replace_equiv e' h = e :=
by { cases e, subst e', refl }

lemma source_preimage_target : e.source ⊆ e ⁻¹' e.target := e.maps_to

lemma eq_of_local_equiv_eq {e e' : local_homeomorph α β}
  (h : e.to_local_equiv = e'.to_local_equiv) : e = e' :=
by { cases e, cases e', cases h, refl }

lemma eventually_left_inverse (e : local_homeomorph α β) {x} (hx : x ∈ e.source) :
  ∀ᶠ y in 𝓝 x, e.symm (e y) = y :=
(e.open_source.eventually_mem hx).mono e.left_inv'

lemma eventually_left_inverse' (e : local_homeomorph α β) {x} (hx : x ∈ e.target) :
  ∀ᶠ y in 𝓝 (e.symm x), e.symm (e y) = y :=
e.eventually_left_inverse (e.map_target hx)

lemma eventually_right_inverse (e : local_homeomorph α β) {x} (hx : x ∈ e.target) :
  ∀ᶠ y in 𝓝 x, e (e.symm y) = y :=
(e.open_target.eventually_mem hx).mono e.right_inv'

lemma eventually_right_inverse' (e : local_homeomorph α β) {x} (hx : x ∈ e.source) :
  ∀ᶠ y in 𝓝 (e x), e (e.symm y) = y :=
e.eventually_right_inverse (e.map_source hx)

lemma eventually_ne_nhds_within (e : local_homeomorph α β) {x} (hx : x ∈ e.source) :
  ∀ᶠ x' in 𝓝[{x}ᶜ] x, e x' ≠ e x :=
eventually_nhds_within_iff.2 $ (e.eventually_left_inverse hx).mono $
  λ x' hx', mt $ λ h, by rw [mem_singleton_iff, ← e.left_inv hx, ← h, hx']

lemma nhds_within_source_inter {x} (hx : x ∈ e.source) (s : set α) :
  𝓝[e.source ∩ s] x = 𝓝[s] x :=
nhds_within_inter_of_mem (mem_nhds_within_of_mem_nhds $ mem_nhds_sets e.open_source hx)

lemma nhds_within_target_inter {x} (hx : x ∈ e.target) (s : set β) :
  𝓝[e.target ∩ s] x = 𝓝[s] x :=
e.symm.nhds_within_source_inter hx s

lemma image_eq_target_inter_inv_preimage {s : set α} (h : s ⊆ e.source) :
  e '' s = e.target ∩ e.symm ⁻¹' s :=
e.to_local_equiv.image_eq_target_inter_inv_preimage h

lemma image_source_inter_eq' (s : set α) :
  e '' (e.source ∩ s) = e.target ∩ e.symm ⁻¹' s :=
e.to_local_equiv.image_source_inter_eq' s

lemma image_source_inter_eq (s : set α) :
  e '' (e.source ∩ s) = e.target ∩ e.symm ⁻¹' (e.source ∩ s) :=
e.to_local_equiv.image_source_inter_eq s

lemma symm_image_eq_source_inter_preimage {s : set β} (h : s ⊆ e.target) :
  e.symm '' s = e.source ∩ e ⁻¹' s :=
e.symm.image_eq_target_inter_inv_preimage h

lemma symm_image_target_inter_eq (s : set β) :
  e.symm '' (e.target ∩ s) = e.source ∩ e ⁻¹' (e.target ∩ s) :=
e.symm.image_source_inter_eq _

lemma source_inter_preimage_inv_preimage (s : set α) :
  e.source ∩ e ⁻¹' (e.symm ⁻¹' s) = e.source ∩ s :=
e.to_local_equiv.source_inter_preimage_inv_preimage s

lemma target_inter_inv_preimage_preimage (s : set β) :
  e.target ∩ e.symm ⁻¹' (e ⁻¹' s) = e.target ∩ s :=
e.symm.source_inter_preimage_inv_preimage _

/-- Two local homeomorphisms are equal when they have equal `to_fun`, `inv_fun` and `source`.
It is not sufficient to have equal `to_fun` and `source`, as this only determines `inv_fun` on
the target. This would only be true for a weaker notion of equality, arguably the right one,
called `eq_on_source`. -/
@[ext]
protected lemma ext (e' : local_homeomorph α β) (h : ∀x, e x = e' x)
  (hinv : ∀x, e.symm x = e'.symm x) (hs : e.source = e'.source) : e = e' :=
eq_of_local_equiv_eq (local_equiv.ext h hinv hs)

@[simp, mfld_simps] lemma symm_to_local_equiv : e.symm.to_local_equiv = e.to_local_equiv.symm := rfl
-- The following lemmas are already simp via local_equiv
lemma symm_source : e.symm.source = e.target := rfl
lemma symm_target : e.symm.target = e.source := rfl
@[simp, mfld_simps] lemma symm_symm : e.symm.symm = e := eq_of_local_equiv_eq $ by simp

/-- A local homeomorphism is continuous at any point of its source -/
protected

/-- A local homeomorphism inverse is continuous at any point of its target -/
lemma continuous_at_symm {x : β} (h : x ∈ e.target) : continuous_at e.symm x :=
e.symm.continuous_at h

lemma tendsto_symm {x} (hx : x ∈ e.source) :
  tendsto e.symm (𝓝 (e x)) (𝓝 x) :=
by simpa only [continuous_at, e.left_inv hx] using e.continuous_at_symm (e.map_source hx)

lemma map_nhds_eq {x} (hx : x ∈ e.source) : map e (𝓝 x) = 𝓝 (e x) :=
le_antisymm (e.continuous_at hx) $
  le_map_of_right_inverse (e.eventually_right_inverse' hx) (e.tendsto_symm hx)

lemma symm_map_nhds_eq {x} (hx : x ∈ e.source) :
  map e.symm (𝓝 (e x)) = 𝓝 x :=
(e.symm.map_nhds_eq $ e.map_source hx).trans $ by rw e.left_inv hx

lemma image_mem_nhds {x} (hx : x ∈ e.source) {s : set α} (hs : s ∈ 𝓝 x) :
  e '' s ∈ 𝓝 (e x) :=
e.map_nhds_eq hx ▸ filter.image_mem_map hs

lemma map_nhds_within_eq (e : local_homeomorph α β) {x} (hx : x ∈ e.source) (s : set α) :
  map e (𝓝[s] x) = 𝓝[e '' (e.source ∩ s)] (e x) :=
calc map e (𝓝[s] x) = map e (𝓝[e.source ∩ s] x) :
  congr_arg (map e) (e.nhds_within_source_inter hx _).symm
... = 𝓝[e '' (e.source ∩ s)] (e x) :
  (e.left_inv_on.mono $ inter_subset_left _ _).map_nhds_within_eq (e.left_inv hx)
    (e.continuous_at_symm (e.map_source hx)).continuous_within_at
    (e.continuous_at hx).continuous_within_at

lemma map_nhds_within_preimage_eq (e : local_homeomorph α β) {x} (hx : x ∈ e.source) (s : set β) :
  map e (𝓝[e ⁻¹' s] x) = 𝓝[s] (e x) :=
by rw [e.map_nhds_within_eq hx, e.image_source_inter_eq', e.target_inter_inv_preimage_preimage,
  e.nhds_within_target_inter (e.map_source hx)]

lemma preimage_open_of_open {s : set β} (hs : is_open s) : is_open (e.source ∩ e ⁻¹' s) :=
e.continuous_on.preimage_open_of_open e.open_source hs

/-!
### `local_homeomorph.is_image` relation

We say that `t : set β` is an image of `s : set α` under a local homeomorphism `e` if any of the
following equivalent conditions hold:

* `e '' (e.source ∩ s) = e.target ∩ t`;
* `e.source ∩ e ⁻¹ t = e.source ∩ s`;
* `∀ x ∈ e.source, e x ∈ t ↔ x ∈ s` (this one is used in the definition).

This definition is a restatement of `local_equiv.is_image` for local homeomorphisms. In this section
we transfer API about `local_equiv.is_image` to local homeomorphisms and add a few
`local_homeomorph`-specific lemmas like `local_homeomorph.is_image.closure`.
-/

/-- We say that `t : set β` is an image of `s : set α` under a local homeomorphism `e` if any of the
following equivalent conditions hold:

* `e '' (e.source ∩ s) = e.target ∩ t`;
* `e.source ∩ e ⁻¹ t = e.source ∩ s`;
* `∀ x ∈ e.source, e x ∈ t ↔ x ∈ s` (this one is used in the definition).
-/
def is_image (s : set α) (t : set β) : Prop := ∀ ⦃x⦄, x ∈ e.source → (e x ∈ t ↔ x ∈ s)

namespace is_image

variables {e} {s : set α} {t : set β} {x : α} {y : β}

lemma to_local_equiv (h : e.is_image s t) : e.to_local_equiv.is_image s t := h

lemma apply_mem_iff (h : e.is_image s t) (hx : x ∈ e.source) : e x ∈ t ↔ x ∈ s := h hx

protected lemma symm (h : e.is_image s t) : e.symm.is_image t s := h.to_local_equiv.symm

lemma symm_apply_mem_iff (h : e.is_image s t) (hy : y ∈ e.target) : (e.symm y ∈ s ↔ y ∈ t) :=
h.symm hy

@[simp] lemma symm_iff : e.symm.is_image t s ↔ e.is_image s t := ⟨λ h, h.symm, λ h, h.symm⟩

protected lemma maps_to (h : e.is_image s t) : maps_to e (e.source ∩ s) (e.target ∩ t) :=
h.to_local_equiv.maps_to

lemma symm_maps_to (h : e.is_image s t) : maps_to e.symm (e.target ∩ t) (e.source ∩ s) :=
h.symm.maps_to

lemma image_eq (h : e.is_image s t) : e '' (e.source ∩ s) = e.target ∩ t :=
h.to_local_equiv.image_eq

lemma symm_image_eq (h : e.is_image s t) : e.symm '' (e.target ∩ t) = e.source ∩ s :=
h.symm.image_eq

lemma iff_preimage_eq : e.is_image s t ↔ e.source ∩ e ⁻¹' t = e.source ∩ s :=
local_equiv.is_image.iff_preimage_eq

alias iff_preimage_eq ↔ local_homeomorph.is_image.preimage_eq
  local_homeomorph.is_image.of_preimage_eq

lemma iff_symm_preimage_eq : e.is_image s t ↔ e.target ∩ e.symm ⁻¹' s = e.target ∩ t :=
symm_iff.symm.trans iff_preimage_eq

alias iff_symm_preimage_eq ↔ local_homeomorph.is_image.symm_preimage_eq
  local_homeomorph.is_image.of_symm_preimage_eq

lemma iff_symm_preimage_eq' :
  e.is_image s t ↔ e.target ∩ e.symm ⁻¹' (e.source ∩ s) = e.target ∩ t :=
by rw [iff_symm_preimage_eq, ← image_source_inter_eq, ← image_source_inter_eq']

alias iff_symm_preimage_eq' ↔ local_homeomorph.is_image.symm_preimage_eq'
  local_homeomorph.is_image.of_symm_preimage_eq'

lemma iff_preimage_eq' : e.is_image s t ↔ e.source ∩ e ⁻¹' (e.target ∩ t) = e.source ∩ s :=
symm_iff.symm.trans iff_symm_preimage_eq'

alias iff_preimage_eq' ↔ local_homeomorph.is_image.preimage_eq'
  local_homeomorph.is_image.of_preimage_eq'

lemma of_image_eq (h : e '' (e.source ∩ s) = e.target ∩ t) : e.is_image s t :=
local_equiv.is_image.of_image_eq h

lemma of_symm_image_eq (h : e.symm '' (e.target ∩ t) = e.source ∩ s) : e.is_image s t :=
local_equiv.is_image.of_symm_image_eq h

protected lemma compl (h : e.is_image s t) : e.is_image sᶜ tᶜ :=
λ x hx, not_congr (h hx)

protected lemma inter {s' t'} (h : e.is_image s t) (h' : e.is_image s' t') :
  e.is_image (s ∩ s') (t ∩ t') :=
λ x hx, and_congr (h hx) (h' hx)

protected lemma union {s' t'} (h : e.is_image s t) (h' : e.is_image s' t') :
  e.is_image (s ∪ s') (t ∪ t') :=
λ x hx, or_congr (h hx) (h' hx)

protected lemma diff {s' t'} (h : e.is_image s t) (h' : e.is_image s' t') :
  e.is_image (s \ s') (t \ t') :=
h.inter h'.compl

lemma left_inv_on_piecewise {e' : local_homeomorph α β} [∀ i, decidable (i ∈ s)]
  [∀ i, decidable (i ∈ t)] (h : e.is_image s t) (h' : e'.is_image s t) :
  left_inv_on (t.piecewise e.symm e'.symm) (s.piecewise e e') (s.ite e.source e'.source) :=
h.to_local_equiv.left_inv_on_piecewise h'

lemma inter_eq_of_inter_eq_of_eq_on {e' : local_homeomorph α β} (h : e.is_image s t)
  (h' : e'.is_image s t) (hs : e.source ∩ s = e'.source ∩ s) (Heq : eq_on e e' (e.source ∩ s)) :
  e.target ∩ t = e'.target ∩ t :=
h.to_local_equiv.inter_eq_of_inter_eq_of_eq_on h' hs Heq

lemma symm_eq_on_of_inter_eq_of_eq_on {e' : local_homeomorph α β} (h : e.is_image s t)
  (hs : e.source ∩ s = e'.source ∩ s) (Heq : eq_on e e' (e.source ∩ s)) :
  eq_on e.symm e'.symm (e.target ∩ t) :=
h.to_local_equiv.symm_eq_on_of_inter_eq_of_eq_on hs Heq

lemma map_nhds_within_eq (h : e.is_image s t) (hx : x ∈ e.source) :
  map e (𝓝[s] x) = 𝓝[t] (e x) :=
by rw [e.map_nhds_within_eq hx, h.image_eq, e.nhds_within_target_inter (e.map_source hx)]

protected lemma closure (h : e.is_image s t) : e.is_image (closure s) (closure t) :=
λ x hx, by simp only [mem_closure_iff_nhds_within_ne_bot, ← h.map_nhds_within_eq hx, map_ne_bot_iff]

protected lemma interior (h : e.is_image s t) : e.is_image (interior s) (interior t) :=
by simpa only [closure_compl, compl_compl] using h.compl.closure.compl

protected lemma frontier (h : e.is_image s t) :
  e.is_image (frontier s) (frontier t) :=
h.closure.diff h.interior

lemma is_open_iff (h : e.is_image s t) :
  is_open (e.source ∩ s) ↔ is_open (e.target ∩ t) :=
⟨λ hs, h.symm_preimage_eq' ▸ e.symm.preimage_open_of_open hs,
  λ hs, h.preimage_eq' ▸ e.preimage_open_of_open hs⟩

/-- Restrict a `local_homeomorph` to a pair of corresponding open sets. -/
@[simps to_local_equiv] def restr (h : e.is_image s t) (hs : is_open (e.source ∩ s)) :
  local_homeomorph α β :=
{ to_local_equiv := h.to_local_equiv.restr,
  open_source := hs,
  open_target := h.is_open_iff.1 hs,
  continuous_to_fun := e.continuous_on.mono (inter_subset_left _ _),
  continuous_inv_fun := e.symm.continuous_on.mono (inter_subset_left _ _) }

end is_image

lemma is_image_source_target : e.is_image e.source e.target :=
e.to_local_equiv.is_image_source_target

lemma is_image_source_target_of_disjoint (e' : local_homeomorph α β)
  (hs : disjoint e.source e'.source) (ht : disjoint e.target e'.target) :
  e.is_image e'.source e'.target :=
e.to_local_equiv.is_image_source_target_of_disjoint e'.to_local_equiv hs ht

/-- Preimage of interior or interior of preimage coincide for local homeomorphisms, when restricted
to the source. -/
lemma preimage_interior (s : set β) :
  e.source ∩ e ⁻¹' (interior s) = e.source ∩ interior (e ⁻¹' s) :=
(is_image.of_preimage_eq rfl).interior.preimage_eq

lemma preimage_closure (s : set β) :
  e.source ∩ e ⁻¹' (closure s) = e.source ∩ closure (e ⁻¹' s) :=
(is_image.of_preimage_eq rfl).closure.preimage_eq

lemma preimage_frontier (s : set β) :
  e.source ∩ e ⁻¹' (frontier s) = e.source ∩ frontier (e ⁻¹' s) :=
(is_image.of_preimage_eq rfl).frontier.preimage_eq

lemma preimage_open_of_open_symm {s : set α} (hs : is_open s) :
  is_open (e.target ∩ e.symm ⁻¹' s) :=
e.symm.continuous_on.preimage_open_of_open e.open_target hs

/-- The image of an open set in the source is open. -/
lemma image_open_of_open {s : set α} (hs : is_open s) (h : s ⊆ e.source) : is_open (e '' s) :=
begin
  have : e '' s = e.target ∩ e.symm ⁻¹' s :=
    e.to_local_equiv.image_eq_target_inter_inv_preimage h,
  rw this,
  exact e.continuous_on_symm.preimage_open_of_open e.open_target hs
end

/-- The image of the restriction of an open set to the source is open. -/
lemma image_open_of_open' {s : set α} (hs : is_open s) : is_open (e '' (e.source ∩ s)) :=
image_open_of_open _ (is_open_inter e.open_source hs) (inter_subset_left _ _)

/-- A `local_equiv` with continuous open forward map and an open source is a `local_homeomorph`. -/
def of_continuous_open_restrict (e : local_equiv α β) (hc : continuous_on e e.source)
  (ho : is_open_map (e.source.restrict e)) (hs : is_open e.source) :
  local_homeomorph α β :=
{ to_local_equiv := e,
  open_source := hs,
  open_target := by simpa only [range_restrict, e.image_source_eq_target] using ho.is_open_range,
  continuous_to_fun := hc,
  continuous_inv_fun := e.image_source_eq_target ▸
    ho.continuous_on_image_of_left_inv_on e.left_inv_on }

/-- A `local_equiv` with continuous open forward map and an open source is a `local_homeomorph`. -/
def of_continuous_open (e : local_equiv α β) (hc : continuous_on e e.source)
  (ho : is_open_map e) (hs : is_open e.source) :
  local_homeomorph α β :=
of_continuous_open_restrict e hc (ho.restrict hs) hs

/-- Restricting a local homeomorphism `e` to `e.source ∩ s` when `s` is open. This is sometimes hard
to use because of the openness assumption, but it has the advantage that when it can
be used then its local_equiv is defeq to local_equiv.restr -/
protected def restr_open (s : set α) (hs : is_open s) :
  local_homeomorph α β :=
(@is_image.of_symm_preimage_eq α β _ _ e s (e.symm ⁻¹' s) rfl).restr
  (is_open_inter e.open_source hs)

@[simp, mfld_simps] lemma restr_open_to_local_equiv (s : set α) (hs : is_open s) :
  (e.restr_open s hs).to_local_equiv = e.to_local_equiv.restr s := rfl

-- Already simp via local_equiv
lemma restr_open_source (s : set α) (hs : is_open s) :
  (e.restr_open s hs).source = e.source ∩ s := rfl

/-- Restricting a local homeomorphism `e` to `e.source ∩ interior s`. We use the interior to make
sure that the restriction is well defined whatever the set s, since local homeomorphisms are by
definition defined on open sets. In applications where `s` is open, this coincides with the
restriction of local equivalences -/
@[simps apply symm_apply (mfld_cfg), simps source target {attrs := []}]
protected def restr (s : set α) : local_homeomorph α β :=
e.restr_open (interior s) is_open_interior

@[simp, mfld_simps] lemma restr_to_local_equiv (s : set α) :
  (e.restr s).to_local_equiv = (e.to_local_equiv).restr (interior s) := rfl

lemma restr_source' (s : set α) (hs : is_open s) : (e.restr s).source = e.source ∩ s :=
by rw [e.restr_source, hs.interior_eq]

lemma restr_to_local_equiv' (s : set α) (hs : is_open s):
  (e.restr s).to_local_equiv = e.to_local_equiv.restr s :=
by rw [e.restr_to_local_equiv, hs.interior_eq]

lemma restr_eq_of_source_subset {e : local_homeomorph α β} {s : set α} (h : e.source ⊆ s) :
  e.restr s = e :=
begin
  apply eq_of_local_equiv_eq,
  rw restr_to_local_equiv,
  apply local_equiv.restr_eq_of_source_subset,
  exact interior_maximal h e.open_source
end

@[simp, mfld_simps] lemma restr_univ {e : local_homeomorph α β} : e.restr univ = e :=
restr_eq_of_source_subset (subset_univ _)

lemma restr_source_inter (s : set α) : e.restr (e.source ∩ s) = e.restr s :=
begin
  refine local_homeomorph.ext _ _ (λx, rfl) (λx, rfl) _,
  simp [e.open_source.interior_eq, ← inter_assoc]
end

/-- The identity on the whole space as a local homeomorphism. -/
@[simps apply (mfld_cfg), simps source target {attrs := []}]
protected def refl (α : Type*) [topological_space α] : local_homeomorph α α :=
(homeomorph.refl α).to_local_homeomorph

@[simp, mfld_simps] lemma refl_local_equiv :
  (local_homeomorph.refl α).to_local_equiv = local_equiv.refl α := rfl
@[simp, mfld_simps] lemma refl_symm : (local_homeomorph.refl α).symm = local_homeomorph.refl α :=
rfl

section
variables {s : set α} (hs : is_open s)

/-- The identity local equiv on a set `s` -/
@[simps apply (mfld_cfg), simps source target {attrs := []}]
def of_set (s : set α) (hs : is_open s) : local_homeomorph α α :=
{ open_source        := hs,
  open_target        := hs,
  continuous_to_fun  := continuous_id.continuous_on,
  continuous_inv_fun := continuous_id.continuous_on,
  ..local_equiv.of_set s }

@[simp, mfld_simps] lemma of_set_to_local_equiv :
  (of_set s hs).to_local_equiv = local_equiv.of_set s := rfl
@[simp, mfld_simps] lemma of_set_symm : (of_set s hs).symm = of_set s hs := rfl

@[simp, mfld_simps] lemma of_set_univ_eq_refl :
  of_set univ is_open_univ = local_homeomorph.refl α :=
by ext; simp

end

/-- Composition of two local homeomorphisms when the target of the first and the source of
the second coincide. -/
protected def trans' (h : e.target = e'.source) : local_homeomorph α γ :=
{ open_source       := e.open_source,
  open_target       := e'.open_target,
  continuous_to_fun := begin
    apply continuous_on.comp e'.continuous_to_fun e.continuous_to_fun,
    rw ← h,
    exact e.to_local_equiv.source_subset_preimage_target
  end,
  continuous_inv_fun := begin
    apply continuous_on.comp e.continuous_inv_fun e'.continuous_inv_fun,
    rw h,
    exact e'.to_local_equiv.target_subset_preimage_source
  end,
  ..local_equiv.trans' e.to_local_equiv e'.to_local_equiv h }

/-- Composing two local homeomorphisms, by restricting to the maximal domain where their
composition is well defined. -/
protected def trans : local_homeomorph α γ :=
  local_homeomorph.trans' (e.symm.restr_open e'.source e'.open_source).symm
    (e'.restr_open e.target e.open_target) (by simp [inter_comm])

@[simp, mfld_simps] lemma trans_to_local_equiv :
  (e.trans e').to_local_equiv = e.to_local_equiv.trans e'.to_local_equiv := rfl
@[simp, mfld_simps] lemma coe_trans : (e.trans e' : α → γ) = e' ∘ e := rfl
@[simp, mfld_simps] lemma coe_trans_symm : ((e.trans e').symm : γ → α) = e.symm ∘ e'.symm := rfl

lemma trans_symm_eq_symm_trans_symm : (e.trans e').symm = e'.symm.trans e.symm :=
by cases e; cases e'; refl

/- This could be considered as a simp lemma, but there are many situations where it makes something
simple into something more complicated. -/
lemma trans_source : (e.trans e').source = e.source ∩ e ⁻¹' e'.source :=
local_equiv.trans_source e.to_local_equiv e'.to_local_equiv

lemma trans_source' : (e.trans e').source = e.source ∩ e ⁻¹' (e.target ∩ e'.source) :=
local_equiv.trans_source' e.to_local_equiv e'.to_local_equiv

lemma trans_source'' : (e.trans e').source = e.symm '' (e.target ∩ e'.source) :=
local_equiv.trans_source'' e.to_local_equiv e'.to_local_equiv

lemma image_trans_source : e '' (e.trans e').source = e.target ∩ e'.source :=
local_equiv.image_trans_source e.to_local_equiv e'.to_local_equiv

lemma trans_target : (e.trans e').target = e'.target ∩ e'.symm ⁻¹' e.target := rfl

lemma trans_target' : (e.trans e').target = e'.target ∩ e'.symm ⁻¹' (e'.source ∩ e.target) :=
trans_source' e'.symm e.symm

lemma trans_target'' : (e.trans e').target = e' '' (e'.source ∩ e.target) :=
trans_source'' e'.symm e.symm

lemma inv_image_trans_target : e'.symm '' (e.trans e').target = e'.source ∩ e.target :=
image_trans_source e'.symm e.symm

lemma trans_assoc (e'' : local_homeomorph γ δ) :
  (e.trans e').trans e'' = e.trans (e'.trans e'') :=
eq_of_local_equiv_eq $ local_equiv.trans_assoc e.to_local_equiv e'.to_local_equiv e''.to_local_equiv

@[simp, mfld_simps] lemma trans_refl : e.trans (local_homeomorph.refl β) = e :=
eq_of_local_equiv_eq $ local_equiv.trans_refl e.to_local_equiv

@[simp, mfld_simps] lemma refl_trans : (local_homeomorph.refl α).trans e = e :=
eq_of_local_equiv_eq $ local_equiv.refl_trans e.to_local_equiv

lemma trans_of_set {s : set β} (hs : is_open s) :
  e.trans (of_set s hs) = e.restr (e ⁻¹' s) :=
local_homeomorph.ext _ _ (λx, rfl) (λx, rfl) $
  by simp [local_equiv.trans_source, (e.preimage_interior _).symm, hs.interior_eq]

lemma trans_of_set' {s : set β} (hs : is_open s) :
  e.trans (of_set s hs) = e.restr (e.source ∩ e ⁻¹' s) :=
by rw [trans_of_set, restr_source_inter]

lemma of_set_trans {s : set α} (hs : is_open s) :
  (of_set s hs).trans e = e.restr s :=
local_homeomorph.ext _ _ (λx, rfl) (λx, rfl) $
  by simp [local_equiv.trans_source, hs.interior_eq, inter_comm]

lemma of_set_trans' {s : set α} (hs : is_open s) :
  (of_set s hs).trans e = e.restr (e.source ∩ s) :=
by rw [of_set_trans, restr_source_inter]

@[simp, mfld_simps] lemma of_set_trans_of_set
  {s : set α} (hs : is_open s) {s' : set α} (hs' : is_open s') :
  (of_set s hs).trans (of_set s' hs') = of_set (s ∩ s') (is_open_inter hs hs')  :=
begin
  rw (of_set s hs).trans_of_set hs',
  ext; simp [hs'.interior_eq]
end

lemma restr_trans (s : set α) :
  (e.restr s).trans e' = (e.trans e').restr s :=
eq_of_local_equiv_eq $ local_equiv.restr_trans e.to_local_equiv e'.to_local_equiv (interior s)

/-- `eq_on_source e e'` means that `e` and `e'` have the same source, and coincide there. They
should really be considered the same local equiv. -/
def eq_on_source (e e' : local_homeomorph α β) : Prop :=
e.source = e'.source ∧ (eq_on e e' e.source)

lemma eq_on_source_iff (e e' : local_homeomorph α β) :
eq_on_source e e' ↔ local_equiv.eq_on_source e.to_local_equiv e'.to_local_equiv :=
iff.rfl

/-- `eq_on_source` is an equivalence relation -/
instance : setoid (local_homeomorph α β) :=
{ r     := eq_on_source,
  iseqv := ⟨
    λe, (@local_equiv.eq_on_source_setoid α β).iseqv.1 e.to_local_equiv,
    λe e' h, (@local_equiv.eq_on_source_setoid α β).iseqv.2.1 ((eq_on_source_iff e e').1 h),
    λe e' e'' h h', (@local_equiv.eq_on_source_setoid α β).iseqv.2.2
      ((eq_on_source_iff e e').1 h) ((eq_on_source_iff e' e'').1 h')⟩ }

lemma eq_on_source_refl : e ≈ e := setoid.refl _

/-- If two local homeomorphisms are equivalent, so are their inverses -/
lemma eq_on_source.symm' {e e' : local_homeomorph α β} (h : e ≈ e') : e.symm ≈ e'.symm :=
local_equiv.eq_on_source.symm' h

/-- Two equivalent local homeomorphisms have the same source -/
lemma eq_on_source.source_eq {e e' : local_homeomorph α β} (h : e ≈ e') : e.source = e'.source :=
h.1

/-- Two equivalent local homeomorphisms have the same target -/
lemma eq_on_source.target_eq {e e' : local_homeomorph α β} (h : e ≈ e') : e.target = e'.target :=
h.symm'.1

/-- Two equivalent local homeomorphisms have coinciding `to_fun` on the source -/
lemma eq_on_source.eq_on {e e' : local_homeomorph α β} (h : e ≈ e') :
  eq_on e e' e.source :=
h.2

/-- Two equivalent local homeomorphisms have coinciding `inv_fun` on the target -/
lemma eq_on_source.symm_eq_on_target {e e' : local_homeomorph α β} (h : e ≈ e') :
  eq_on e.symm e'.symm e.target :=
h.symm'.2

/-- Composition of local homeomorphisms respects equivalence -/
lemma eq_on_source.trans' {e e' : local_homeomorph α β} {f f' : local_homeomorph β γ}
  (he : e ≈ e') (hf : f ≈ f') : e.trans f ≈ e'.trans f' :=
local_equiv.eq_on_source.trans' he hf

/-- Restriction of local homeomorphisms respects equivalence -/
lemma eq_on_source.restr {e e' : local_homeomorph α β} (he : e ≈ e') (s : set α) :
  e.restr s ≈ e'.restr s :=
local_equiv.eq_on_source.restr he _

/-- Composition of a local homeomorphism and its inverse is equivalent to the restriction of the
identity to the source -/
lemma trans_self_symm :
  e.trans e.symm ≈ local_homeomorph.of_set e.source e.open_source :=
local_equiv.trans_self_symm _

lemma trans_symm_self :
  e.symm.trans e ≈ local_homeomorph.of_set e.target e.open_target :=
e.symm.trans_self_symm

lemma eq_of_eq_on_source_univ {e e' : local_homeomorph α β} (h : e ≈ e')
  (s : e.source = univ) (t : e.target = univ) : e = e' :=
eq_of_local_equiv_eq $ local_equiv.eq_of_eq_on_source_univ _ _ h s t

section prod

/-- The product of two local homeomorphisms, as a local homeomorphism on the product space. -/
@[simps to_local_equiv apply (mfld_cfg), simps source target symm_apply {attrs := []}]
def prod (e : local_homeomorph α β) (e' : local_homeomorph γ δ) :
  local_homeomorph (α × γ) (β × δ) :=
{ open_source := e.open_source.prod e'.open_source,
  open_target := e.open_target.prod e'.open_target,
  continuous_to_fun := e.continuous_on.prod_map e'.continuous_on,
  continuous_inv_fun := e.continuous_on_symm.prod_map e'.continuous_on_symm,
  to_local_equiv := e.to_local_equiv.prod e'.to_local_equiv }

@[simp, mfld_simps] lemma prod_symm (e : local_homeomorph α β) (e' : local_homeomorph γ δ) :
  (e.prod e').symm = (e.symm.prod e'.symm) :=
rfl

@[simp, mfld_simps] lemma prod_trans
  {η : Type*} {ε : Type*} [topological_space η] [topological_space ε]
  (e : local_homeomorph α β) (f : local_homeomorph β γ)
  (e' : local_homeomorph δ η) (f' : local_homeomorph η ε) :
  (e.prod e').trans (f.prod f') = (e.trans f).prod (e'.trans f') :=
local_homeomorph.eq_of_local_equiv_eq $
  by dsimp only [trans_to_local_equiv, prod_to_local_equiv]; apply local_equiv.prod_trans

end prod

section piecewise

/-- Combine two `local_homeomorph`s using `set.piecewise`. The source of the new `local_homeomorph`
is `s.ite e.source e'.source = e.source ∩ s ∪ e'.source \ s`, and similarly for target.  The
function sends `e.source ∩ s` to `e.target ∩ t` using `e` and `e'.source \ s` to `e'.target \ t`
using `e'`, and similarly for the inverse function. To ensure that the maps `to_fun` and `inv_fun`
are inverse of each other on the new `source` and `target`, the definition assumes that the sets `s`
and `t` are related both by `e.is_image` and `e'.is_image`. To ensure that the new maps are
continuous on `source`/`target`, it also assumes that `e.source` and `e'.source` meet `frontier s`
on the same set and `e x = e' x` on this intersection. -/
@[simps to_local_equiv apply {fully_applied := ff}]
def piecewise (e e' : local_homeomorph α β) (s : set α) (t : set β)
  [∀ x, decidable (x ∈ s)] [∀ y, decidable (y ∈ t)] (H : e.is_image s t) (H' : e'.is_image s t)
  (Hs : e.source ∩ frontier s = e'.source ∩ frontier s)
  (Heq : eq_on e e' (e.source ∩ frontier s)) :
  local_homeomorph α β :=
{ to_local_equiv := e.to_local_equiv.piecewise e'.to_local_equiv s t H H',
  open_source := e.open_source.ite e'.open_source Hs,
  open_target := e.open_target.ite e'.open_target $
    H.frontier.inter_eq_of_inter_eq_of_eq_on H'.frontier Hs Heq,
  continuous_to_fun := continuous_on_piecewise_ite e.continuous_on e'.continuous_on Hs Heq,
  continuous_inv_fun := continuous_on_piecewise_ite e.continuous_on_symm e'.continuous_on_symm
    (H.frontier.inter_eq_of_inter_eq_of_eq_on H'.frontier Hs Heq)
    (H.frontier.symm_eq_on_of_inter_eq_of_eq_on Hs Heq) }

@[simp] lemma symm_piecewise (e e' : local_homeomorph α β) {s : set α} {t : set β}
  [∀ x, decidable (x ∈ s)] [∀ y, decidable (y ∈ t)] (H : e.is_image s t) (H' : e'.is_image s t)
  (Hs : e.source ∩ frontier s = e'.source ∩ frontier s)
  (Heq : eq_on e e' (e.source ∩ frontier s)) :
  (e.piecewise e' s t H H' Hs Heq).symm =
    e.symm.piecewise e'.symm t s H.symm H'.symm
      (H.frontier.inter_eq_of_inter_eq_of_eq_on H'.frontier Hs Heq)
      (H.frontier.symm_eq_on_of_inter_eq_of_eq_on Hs Heq) :=
rfl

/-- Combine two `local_homeomorph`s with disjoint sources and disjoint targets. We reuse
`local_homeomorph.piecewise` then override `to_local_equiv` to `local_equiv.disjoint_union`.
This way we have better definitional equalities for `source` and `target`. -/
def disjoint_union (e e' : local_homeomorph α β)
  [∀ x, decidable (x ∈ e.source)] [∀ y, decidable (y ∈ e.target)]
  (Hs : disjoint e.source e'.source) (Ht : disjoint e.target e'.target) :
  local_homeomorph α β :=
(e.piecewise e' e.source e.target e.is_image_source_target
  (e'.is_image_source_target_of_disjoint e Hs.symm Ht.symm)
  (by rw [e.open_source.inter_frontier_eq, e'.open_source.inter_frontier_eq_empty_of_disjoint Hs])
  (by { rw e.open_source.inter_frontier_eq, exact eq_on_empty _ _ })).replace_equiv
    (e.to_local_equiv.disjoint_union e'.to_local_equiv Hs Ht)
    (local_equiv.disjoint_union_eq_piecewise _ _ _ _).symm

end piecewise

section pi

variables {ι : Type*} [fintype ι] {Xi Yi : ι → Type*} [Π i, topological_space (Xi i)]
  [Π i, topological_space (Yi i)] (ei : Π i, local_homeomorph (Xi i) (Yi i))

/-- The product of a finite family of `local_homeomorph`s. -/
@[simps to_local_equiv] def pi : local_homeomorph (Π i, Xi i) (Π i, Yi i) :=
{ to_local_equiv := local_equiv.pi (λ i, (ei i).to_local_equiv),
  open_source := is_open_set_pi finite_univ $ λ i hi, (ei i).open_source,
  open_target := is_open_set_pi finite_univ $ λ i hi, (ei i).open_target,
  continuous_to_fun := continuous_on_pi.2 $ λ i, (ei i).continuous_on.comp
    (continuous_apply _).continuous_on (λ f hf, hf i trivial),
  continuous_inv_fun := continuous_on_pi.2 $ λ i, (ei i).continuous_on_symm.comp
    (continuous_apply _).continuous_on (λ f hf, hf i trivial) }

end pi

section continuity

/-- Continuity within a set at a point can be read under right composition with a local
homeomorphism, if the point is in its target -/
lemma continuous_within_at_iff_continuous_within_at_comp_right
  {f : β → γ} {s : set β} {x : β} (h : x ∈ e.target) :
  continuous_within_at f s x ↔ continuous_within_at (f ∘ e) (e ⁻¹' s) (e.symm x) :=
by simp_rw [continuous_within_at, ← @tendsto_map'_iff _ _ _ _ e,
  e.map_nhds_within_preimage_eq (e.map_target h), (∘), e.right_inv h]

/-- Continuity at a point can be read under right composition with a local homeomorphism, if the
point is in its target -/
lemma continuous_at_iff_continuous_at_comp_right
  {f : β → γ} {x : β} (h : x ∈ e.target) :
  continuous_at f x ↔ continuous_at (f ∘ e) (e.symm x) :=
by rw [← continuous_within_at_univ, e.continuous_within_at_iff_continuous_within_at_comp_right h,
       preimage_univ, continuous_within_at_univ]

/-- A function is continuous on a set if and only if its composition with a local homeomorphism
on the right is continuous on the corresponding set. -/
lemma continuous_on_iff_continuous_on_comp_right {f : β → γ} {s : set β} (h : s ⊆ e.target) :
  continuous_on f s ↔ continuous_on (f ∘ e) (e.source ∩ e ⁻¹' s) :=
begin
  simp only [← e.symm_image_eq_source_inter_preimage h, continuous_on, ball_image_iff],
  refine forall_congr (λ x, forall_congr $ λ hx, _),
  rw [e.continuous_within_at_iff_continuous_within_at_comp_right (h hx),
    e.symm_image_eq_source_inter_preimage h, inter_comm, continuous_within_at_inter],
  exact mem_nhds_sets e.open_source (e.map_target (h hx))
end

/-- Continuity within a set at a point can be read under left composition with a local
homeomorphism if a neighborhood of the initial point is sent to the source of the local
homeomorphism-/
lemma continuous_within_at_iff_continuous_within_at_comp_left
  {f : γ → α} {s : set γ} {x : γ} (hx : f x ∈ e.source) (h : f ⁻¹' e.source ∈ 𝓝[s] x) :
  continuous_within_at f s x ↔ continuous_within_at (e ∘ f) s x :=
begin
  refine ⟨(e.continuous_at hx).tendsto.comp, λ fe_cont, _⟩,
  rw [← continuous_within_at_inter' h] at fe_cont ⊢,
  have : continuous_within_at (e.symm ∘ (e ∘ f)) (s ∩ f ⁻¹' e.source) x,
  { have : continuous_within_at e.symm univ (e (f x))
      := (e.continuous_at_symm (e.map_source hx)).continuous_within_at,
    exact continuous_within_at.comp this fe_cont (subset_univ _) },
  exact this.congr (λy hy, by simp [e.left_inv hy.2]) (by simp [e.left_inv hx])
end

/-- Continuity at a point can be read under left composition with a local homeomorphism if a
neighborhood of the initial point is sent to the source of the local homeomorphism-/
lemma continuous_at_iff_continuous_at_comp_left {f : γ → α} {x : γ} (h : f ⁻¹' e.source ∈ 𝓝 x) :
  continuous_at f x ↔ continuous_at (e ∘ f) x :=
begin
  have hx : f x ∈ e.source := (mem_of_nhds h : _),
  have h' : f ⁻¹' e.source ∈ 𝓝[univ] x, by rwa nhds_within_univ,
  rw [← continuous_within_at_univ, ← continuous_within_at_univ,
      e.continuous_within_at_iff_continuous_within_at_comp_left hx h']
end

/-- A function is continuous on a set if and only if its composition with a local homeomorphism
on the left is continuous on the corresponding set. -/
lemma continuous_on_iff_continuous_on_comp_left {f : γ → α} {s : set γ} (h : s ⊆ f ⁻¹' e.source) :
  continuous_on f s ↔ continuous_on (e ∘ f) s :=
forall_congr $ λ x, forall_congr $ λ hx, e.continuous_within_at_iff_continuous_within_at_comp_left
  (h hx) (mem_sets_of_superset self_mem_nhds_within h)

end continuity

/-- A local homeomrphism defines a homeomorphism between its source and target. -/
def to_homeomorph_source_target : e.source ≃ₜ e.target :=
{ to_fun := e.maps_to.restrict _ _ _,
  inv_fun := e.symm_maps_to.restrict _ _ _,
  left_inv := λ x, subtype.eq $ e.left_inv x.2,
  right_inv := λ x, subtype.eq $ e.right_inv x.2,
  continuous_to_fun := continuous_subtype_mk _ $
    continuous_on_iff_continuous_restrict.1 e.continuous_on,
  continuous_inv_fun := continuous_subtype_mk _ $
    continuous_on_iff_continuous_restrict.1 e.symm.continuous_on }

lemma second_countable_topology_source [second_countable_topology β]
  (e : local_homeomorph α β) :
  second_countable_topology e.source :=
e.to_homeomorph_source_target.second_countable_topology

/-- If a local homeomorphism has source and target equal to univ, then it induces a homeomorphism
between the whole spaces, expressed in this definition. -/
@[simps apply symm_apply (mfld_cfg)]
def to_homeomorph_of_source_eq_univ_target_eq_univ (h : e.source = (univ : set α))
  (h' : e.target = univ) : α ≃ₜ β :=
{ to_fun := e,
  inv_fun := e.symm,
  left_inv := λx, e.left_inv $ by { rw h, exact mem_univ _ },
  right_inv := λx, e.right_inv $ by { rw h', exact mem_univ _ },
  continuous_to_fun := begin
    rw [continuous_iff_continuous_on_univ],
    convert e.continuous_to_fun,
    rw h
  end,
  continuous_inv_fun := begin
    rw [continuous_iff_continuous_on_univ],
    convert e.continuous_inv_fun,
    rw h'
  end }

/-- A local homeomorphism whose source is all of `α` defines an open embedding of `α` into `β`.  The
converse is also true; see `open_embedding.to_local_homeomorph`. -/
lemma to_open_embedding (h : e.source = set.univ) : open_embedding e :=
begin
  apply open_embedding_of_continuous_injective_open,
  { apply continuous_iff_continuous_on_univ.mpr,
    rw ← h,
    exact e.continuous_to_fun },
  { apply set.injective_iff_inj_on_univ.mpr,
    rw ← h,
    exact e.inj_on },
  { intros U hU,
    simpa only [h, subset_univ] with mfld_simps using e.image_open_of_open hU}
end

end local_homeomorph

namespace homeomorph
variables (e : α ≃ₜ β) (e' : β ≃ₜ γ)
/- Register as simp lemmas that the fields of a local homeomorphism built from a homeomorphism
correspond to the fields of the original homeomorphism. -/

attribute [simps apply source target {simp_rhs := tt, .. mfld_cfg}] to_local_homeomorph

@[simp, mfld_simps] lemma to_local_homeomorph_coe_symm :
  (e.to_local_homeomorph.symm : β → α) = e.symm := rfl
@[simp, mfld_simps] lemma refl_to_local_homeomorph :
  (homeomorph.refl α).to_local_homeomorph = local_homeomorph.refl α := rfl
@[simp, mfld_simps] lemma symm_to_local_homeomorph :
  e.symm.to_local_homeomorph = e.to_local_homeomorph.symm := rfl
@[simp, mfld_simps] lemma trans_to_local_homeomorph :
  (e.trans e').to_local_homeomorph = e.to_local_homeomorph.trans e'.to_local_homeomorph :=
local_homeomorph.eq_of_local_equiv_eq $ equiv.trans_to_local_equiv _ _

end homeomorph

namespace open_embedding
variables (f : α → β) (h : open_embedding f)

/-- An open embedding of `α` into `β`, with `α` nonempty, defines a local homeomorphism whose source
is all of `α`.  The converse is also true; see `local_homeomorph.to_open_embedding`. -/
@[simps apply source target (mfld_cfg)]
noncomputable def to_local_homeomorph [nonempty α] : local_homeomorph α β :=
local_homeomorph.of_continuous_open
  ((h.to_embedding.inj.inj_on univ).to_local_equiv _ _)
  h.continuous.continuous_on h.is_open_map is_open_univ

lemma continuous_at_iff
  {f : α → β} {g : β → γ} (hf : open_embedding f) {x : α} :
  continuous_at (g ∘ f) x ↔ continuous_at g (f x) :=
begin
  haveI : nonempty α := ⟨x⟩,
  convert (((hf.to_local_homeomorph f).continuous_at_iff_continuous_at_comp_right) _).symm,
  { apply (local_homeomorph.left_inv _ _).symm,
    simp, },
  { simp, },
end

end open_embedding

namespace topological_space.opens

open topological_space
variables (s : opens α) [nonempty s]

/-- The inclusion of an open subset `s` of a space `α` into `α` is a local homeomorphism from the
subtype `s` to `α`. -/
noncomputable def local_homeomorph_subtype_coe : local_homeomorph s α :=
open_embedding.to_local_homeomorph _ s.2.open_embedding_subtype_coe

@[simp, mfld_simps] lemma local_homeomorph_subtype_coe_coe :
  (s.local_homeomorph_subtype_coe : s → α) = coe := rfl

@[simp, mfld_simps] lemma local_homeomorph_subtype_coe_source :
  s.local_homeomorph_subtype_coe.source = set.univ := rfl

@[simp, mfld_simps] lemma local_homeomorph_subtype_coe_target :
  s.local_homeomorph_subtype_coe.target = s :=
by { simp only [local_homeomorph_subtype_coe, subtype.range_coe_subtype] with mfld_simps, refl }

end topological_space.opens

namespace local_homeomorph

open topological_space
variables (e : local_homeomorph α β)
variables (s : opens α) [nonempty s]

/-- The restriction of a local homeomorphism `e` to an open subset `s` of the domain type produces a
local homeomorphism whose domain is the subtype `s`.-/
noncomputable def subtype_restr : local_homeomorph s β := s.local_homeomorph_subtype_coe.trans e

lemma subtype_restr_def : e.subtype_restr s = s.local_homeomorph_subtype_coe.trans e := rfl

@[simp, mfld_simps] lemma subtype_restr_coe : ((e.subtype_restr s : local_homeomorph s β) : s → β)
  = set.restrict (e : α → β) s := rfl

@[simp, mfld_simps] lemma subtype_restr_source : (e.subtype_restr s).source = coe ⁻¹' e.source :=
by simp only [subtype_restr_def] with mfld_simps

/- This lemma characterizes the transition functions of an open subset in terms of the transition
functions of the original space. -/
lemma subtype_restr_symm_trans_subtype_restr (f f' : local_homeomorph α β) :
  (f.subtype_restr s).symm.trans (f'.subtype_restr s)
  ≈ (f.symm.trans f').restr (f.target ∩ (f.symm) ⁻¹' s) :=
begin
  simp only [subtype_restr_def, trans_symm_eq_symm_trans_symm],
  have openness₁ : is_open (f.target ∩ f.symm ⁻¹' s) := f.preimage_open_of_open_symm s.2,
  rw [← of_set_trans _ openness₁, ← trans_assoc, ← trans_assoc],
  refine eq_on_source.trans' _ (eq_on_source_refl _),
  -- f' has been eliminated !!!
  have sets_identity : f.symm.source ∩ (f.target ∩ (f.symm) ⁻¹' s) = f.symm.source ∩ f.symm ⁻¹' s,
  { mfld_set_tac },
  have openness₂ : is_open (s : set α) := s.2,
  rw [of_set_trans', sets_identity, ← trans_of_set' _ openness₂, trans_assoc],
  refine eq_on_source.trans' (eq_on_source_refl _) _,
  -- f has been eliminated !!!
  refine setoid.trans (trans_symm_self s.local_homeomorph_subtype_coe) _,
  simp only with mfld_simps,
end

end local_homeomorph


import .love08_operational_semantics_demo

/-! # LoVe Demo 9: Hoare Logic

We review a second way to specify the semantics of a programming language: Hoare
logic. If operational semantics corresponds to an idealized interpreter,
__Hoare logic__ (also called __axiomatic semantics__) corresponds to a verifier.
Hoare logic is particularly convenient to reason about concrete programs. -/

set_option pp.beta true
set_option pp.generalized_field_notation false

namespace LoVe

/-! ## First Things First: Formalization Projects

Instead of two of the homework sheets, you can do a verification project, worth
20 points. If you choose to do so, please send your lecturer a message by email
by the end of the week. For a fully successful project, we expect about 200 (or
more) lines of Lean, including definitions and proofs.

Some ideas for projects follow.

Computer science:

* extended WHILE language with static arrays or other features;
* functional data structures (e.g., balanced trees);
* functional algorithms (e.g., bubble sort, merge sort, Tarjan's algorithm);
* compiler from expressions or imperative programs to, e.g., stack machine;
* type systems (e.g., Benjamin Pierce's __Types and Programming Languages__);
* security properties (e.g., Volpano–Smith-style noninterference analysis);
* theory of first-order terms, including matching, term rewriting;
* automata theory;
* normalization of context-free grammars or regular expressions;
* process algebras and bisimilarity;
* soundness and possibly completeness of proof systems (e.g., Genzen's sequent
  calculus, natural deduction, tableaux);
* separation logic;
* verified program using Hoare logic.

Mathematics:

* graphs;
* combinatorics;
* number theory.

Evaluation from 2018–2019:

Q: How did you find the project?

A: Enjoyable.

A: Fun and hard.

A: Good, I think the format was excellent in a way that it gave people the
   chance to do challenging exercises and hand them in incomplete.

A: I really really liked it. I think it's a great way of learning—find
   something you like, dig in it a little, get stuck, ask for help. I wish I
   could do more of that!

A: It was great to have some time to try to work out some stuff you find
   interesting yourself.

A: lots of fun actually!!!

A: Very helpful. It gave the opportunity to spend some more time on a
   particular aspect of the course.

## Hoare Triples

The basic judgments of Hoare logic are often called __Hoare triples__. They have
the form

    `{P} S {Q}`

where `S` is a statement, and `P` and `Q` (called __precondition__ and
__postcondition__) are logical formulas over the state variables.

Intended meaning:

    If `P` holds before `S` is executed and the execution terminates normally,
    `Q` holds at termination.

This is a __partial correctness__ statement: The program is correct if it
terminates normally (i.e., no run-time error, no infinite loop or divergence).

All of these Hoare triples are valid (with respect to the intended meaning):

    `{true} b := 4 {b = 4}`
    `{a = 2} b := 2 * a {a = 2 ∧ b = 4}`
    `{b ≥ 5} b := b + 1 {b ≥ 6}`
    `{false} skip {b = 100}`
    `{true} while i ≠ 100 do i := i + 1 {i = 100}`

## Hoare Rules

The following is a complete set of rules for reasoning about WHILE programs:

    ———————————— Skip
    {P} skip {P}

    ——————————————————— Asn
    {Q[a/x]} x := a {Q}

    {P} S {R}   {R} S' {Q}
    —————————————————————— Seq
    {P} S; S' {Q}

    {P ∧ b} S {Q}   {P ∧ ¬b} S' {Q}
    ——————————————————————————————— If
    {P} if b then S else S' {Q}

    {I ∧ b} S {I}
    ————————————————————————— While
    {I} while b do S {I ∧ ¬b}

    P' → P   {P} S {Q}   Q → Q'
    ——————————————————————————— Conseq
    {P'} S {Q'}

`Q[a/x]` denotes `Q` with `x` replaced by `a`.

In the `While` rule, `I` is called an __invariant__.

Except for `Conseq`, the rules are syntax-driven: by looking at a program, we
see immediately which rule to apply.

Example derivations:

    —————————————————————— Asn   —————————————————————— Asn
    {a = 2} b := a {b = 2}       {b = 2} c := b {c = 2}
    ——————————————————————————————————————————————————— Seq
    {a = 2} b := a; c := b {c = 2}

                     —————————————————————— Asn
    x > 10 → x > 5   {x > 5} y := x {y > 5}   y > 5 → y > 0
    ——————————————————————————————————————————————————————— Conseq
    {x > 10} y := x {y > 0}

Various __derived rules__ can be proved to be correct in terms of the standard
rules. For example, we can derive bidirectional rules for `skip`, `:=`, and
`while`:

    P → Q
    ———————————— Skip'
    {P} skip {Q}

    P → Q[a/x]
    —————————————— Asn'
    {P} x := a {Q}

    {P ∧ b} S {P}   P ∧ ¬b → Q
    —————————————————————————— While'
    {P} while b do S {Q}

## A Semantic Approach to Hoare Logic

We can, and will, define Hoare triples **semantically** in Lean.

We will use predicates on states (`state → Prop`) to represent pre- and
postconditions, following the shallow embedding style. -/

def partial_hoare (P : state → Prop) (S : stmt)
  (Q : state → Prop) : Prop :=
∀s t, P s → (S, s) ⟹ t → Q t

notation `{* ` P : 1 ` *} ` S : 1 ` {* ` Q : 1 ` *}` :=
partial_hoare P S Q

namespace partial_hoare

lemma skip_intro {P} :
  {* P *} stmt.skip {* P *} :=
begin
  intros s t hs hst,
  cases' hst,
  assumption
end

lemma assign_intro (P : state → Prop) {x} {a : state → ℕ} :
  {* λs, P (s{x ↦ a s}) *} stmt.assign x a {* P *} :=
begin
  intros s t P hst,
  cases' hst,
  assumption
end

lemma seq_intro {P Q R S T} (hS : {* P *} S {* Q *})
    (hT : {* Q *} T {* R *}) :
  {* P *} S ;; T {* R *} :=
begin
  intros s t hs hst,
  cases' hst,
  apply hT,
  { apply hS,
    { exact hs },
    { assumption } },
  { assumption }
end

lemma ite_intro {b P Q : state → Prop} {S T}
    (hS : {* λs, P s ∧ b s *} S {* Q *})
    (hT : {* λs, P s ∧ ¬ b s *} T {* Q *}) :
  {* P *} stmt.ite b S T {* Q *} :=
begin
  intros s t hs hst,
  cases' hst,
  { apply hS,
    exact and.intro hs hcond,
    assumption },
  { apply hT,
    exact and.intro hs hcond,
    assumption }
end

lemma while_intro (P : state → Prop) {b : state → Prop} {S}
    (h : {* λs, P s ∧ b s *} S {* P *}) :
  {* P *} stmt.while b S {* λs, P s ∧ ¬ b s *} :=
begin
  intros s t hs hst,
  induction' hst,
  case while_true {
    apply ih_hst_1 P h,
    exact h _ _ (and.intro hs hcond) hst },
  case while_false {
    exact and.intro hs hcond }
end

lemma consequence {P P' Q Q' : state → Prop} {S}
    (h : {* P *} S {* Q *}) (hp : ∀s, P' s → P s)
    (hq : ∀s, Q s → Q' s) :
  {* P' *} S {* Q' *} :=
fix s t,
assume hs : P' s,
assume hst : (S, s) ⟹ t,
show Q' t, from
  hq _ (h s t (hp s hs) hst)

lemma consequence_left (P' : state → Prop) {P Q S}
    (h : {* P *} S {* Q *}) (hp : ∀s, P' s → P s) :
  {* P' *} S {* Q *} :=
consequence h hp (by cc)

lemma consequence_right (Q) {Q' : state → Prop} {P S}
    (h : {* P *} S {* Q *}) (hq : ∀s, Q s → Q' s) :
  {* P *} S {* Q' *} :=
consequence h (by cc) hq

lemma skip_intro' {P Q : state → Prop} (h : ∀s, P s → Q s) :
  {* P *} stmt.skip {* Q *} :=
consequence skip_intro h (by cc)

lemma assign_intro' {P Q : state → Prop} {x} {a : state → ℕ}
    (h : ∀s, P s → Q (s{x ↦ a s})):
  {* P *} stmt.assign x a {* Q *} :=
consequence (assign_intro Q) h (by cc)

lemma seq_intro' {P Q R S T} (hT : {* Q *} T {* R *})
    (hS : {* P *} S {* Q *}) :
  {* P *} S ;; T {* R *} :=
seq_intro hS hT

lemma while_intro' {b P Q : state → Prop} {S}
    (I : state → Prop)
    (hS : {* λs, I s ∧ b s *} S {* I *})
    (hP : ∀s, P s → I s)
    (hQ : ∀s, ¬ b s → I s → Q s) :
  {* P *} stmt.while b S {* Q *} :=
consequence (while_intro I hS) hP (by finish)

/-! `finish` applies a combination of techniques, including normalization of
logical connectives and quantifiers, simplification, congruence closure, and
quantifier instantiation. It either fully succeeds or fails. -/

lemma assign_intro_forward (P) {x a} :
  {* P *}
  stmt.assign x a
  {* λs, ∃n₀, P (s{x ↦ n₀}) ∧ s x = a (s{x ↦ n₀}) *} :=
begin
  apply assign_intro',
  intros s hP,
  apply exists.intro (s x),
  simp [*]
end

lemma assign_intro_backward (Q : state → Prop) {x}
    {a : state → ℕ} :
  {* λs, ∃n', Q (s{x ↦ n'}) ∧ n' = a s *}
  stmt.assign x a
  {* Q *} :=
begin
  apply assign_intro',
  intros s hP,
  cases' hP,
  cc
end

end partial_hoare

/-! ## First Program: Exchanging Two Variables -/

def SWAP : stmt :=
stmt.assign "t" (λs, s "a") ;;
stmt.assign "a" (λs, s "b") ;;
stmt.assign "b" (λs, s "t")

lemma SWAP_correct (a₀ b₀ : ℕ) :
  {* λs, s "a" = a₀ ∧ s "b" = b₀ *}
  SWAP
  {* λs, s "a" = b₀ ∧ s "b" = a₀ *} :=
begin
  apply partial_hoare.seq_intro',
  apply partial_hoare.seq_intro',
  apply partial_hoare.assign_intro,
  apply partial_hoare.assign_intro,
  apply partial_hoare.assign_intro',
  simp { contextual := tt }
end

lemma SWAP_correct₂ (a₀ b₀ : ℕ) :
  {* λs, s "a" = a₀ ∧ s "b" = b₀ *}
  SWAP
  {* λs, s "a" = b₀ ∧ s "b" = a₀ *} :=
begin
  intros s t hP hstep,
  cases' hstep,
  cases' hstep,
  cases' hstep_1,
  cases' hstep_1_1,
  cases' hstep_1,
  finish
end

/-! ## Second Program: Adding Two Numbers -/

def ADD : stmt :=
stmt.while (λs, s "n" ≠ 0)
  (stmt.assign "n" (λs, s "n" - 1) ;;
   stmt.assign "m" (λs, s "m" + 1))

lemma ADD_correct (n₀ m₀ : ℕ) :
  {* λs, s "n" = n₀ ∧ s "m" = m₀ *}
  ADD
  {* λs, s "n" = 0 ∧ s "m" = n₀ + m₀ *} :=
partial_hoare.while_intro' (λs, s "n" + s "m" = n₀ + m₀)
  begin
    apply partial_hoare.seq_intro',
    { apply partial_hoare.assign_intro },
    { apply partial_hoare.assign_intro',
      simp,
      intros s hnm hnz,
      rw ←hnm,
      cases s "n",
      { finish },
      { simp [nat.succ_eq_add_one],
        linarith } }
  end
  (by simp { contextual := true })
  (by simp { contextual := true })

/-! How did we come up with this invariant? The invariant must

1. be true before we enter the loop;

2. remain true after each iteration of the loop if it was true before the
   iteration;

3. be strong enough to imply the desired loop postcondition.

The invariant `true` meets 1 and 2 but usually not 3. Similarly, `false` meets
2 and 3 but usually not 1. Suitable invariants are often of the form

__work done__ + __work remaining__ = __desired result__

where `+` is some suitable operator. When we enter the loop, __work done__ will
often be `0`. And when we exit the loop, __work remaining__ should be `0`.

For the `ADD` loop:

* __work done__ is `m`;
* __work remaining__ is `n`;
* __desired result__ is `n₀ + m₀`.

## A Verification Condition Generator

__Verification condition generators__ (VCGs) are programs that apply Hoare rules
automatically, producing __verification conditions__ that must be proved by the
user. The user must usually also provide strong enough loop invariants, as an
annotation in their programs.

We can use Lean's metaprogramming framework to define a simple VCG.

Hundreds of program verification tools are based on these principles.

VCGs typically work backwards from the postcondition, using backward rules
(rules stated to have an arbitrary `Q` as their postcondition). This works well
because `Asn` is backward. -/

def stmt.while_inv (I b : state → Prop) (S : stmt) : stmt :=
stmt.while b S

namespace partial_hoare

lemma while_inv_intro {b I Q : state → Prop} {S}
    (hS : {* λs, I s ∧ b s *} S {* I *})
    (hQ : ∀s, ¬ b s → I s → Q s) :
  {* I *} stmt.while_inv I b S {* Q *} :=
while_intro' I hS (by cc) hQ

lemma while_inv_intro' {b I P Q : state → Prop} {S}
    (hS : {* λs, I s ∧ b s *} S {* I *})
    (hP : ∀s, P s → I s) (hQ : ∀s, ¬ b s → I s → Q s) :
  {* P *} stmt.while_inv I b S {* Q *} :=
while_intro' I hS hP hQ

end partial_hoare

meta def vcg : tactic unit :=
do
  t ← tactic.target,
  match t with
  | `({* %%P *} %%S {* _ *}) :=
    match S with
    | `(stmt.skip)            :=
      tactic.applyc
        (if expr.is_mvar P then ``partial_hoare.skip_intro
         else ``partial_hoare.skip_intro')
    | `(stmt.assign _ _)      :=
      tactic.applyc
        (if expr.is_mvar P then ``partial_hoare.assign_intro
         else ``partial_hoare.assign_intro')
    | `(stmt.seq _ _)         :=
      tactic.applyc ``partial_hoare.seq_intro'; vcg
    | `(stmt.ite _ _ _)       :=
      tactic.applyc ``partial_hoare.ite_intro; vcg
    | `(stmt.while_inv _ _ _) :=
      tactic.applyc
        (if expr.is_mvar P then ``partial_hoare.while_inv_intro
         else ``partial_hoare.while_inv_intro');
        vcg
    | _                       :=
      tactic.fail (to_fmt "cannot analyze " ++ to_fmt S)
    end
  | _                        := pure ()
  end

end LoVe

/-! Register `vcg` as a proper tactic: -/

meta def tactic.interactive.vcg : tactic unit :=
LoVe.vcg

namespace LoVe

/-! ## Second Program Revisited: Adding Two Numbers -/

lemma ADD_correct₂ (n₀ m₀ : ℕ) :
  {* λs, s "n" = n₀ ∧ s "m" = m₀ *}
  ADD
  {* λs, s "n" = 0 ∧ s "m" = n₀ + m₀ *} :=
show {* λs, s "n" = n₀ ∧ s "m" = m₀ *}
     stmt.while_inv (λs, s "n" + s "m" = n₀ + m₀)
       (λs, s "n" ≠ 0)
       (stmt.assign "n" (λs, s "n" - 1) ;;
        stmt.assign "m" (λs, s "m" + 1))
     {* λs, s "n" = 0 ∧ s "m" = n₀ + m₀ *}, from
  begin
    vcg; simp { contextual := tt },
    intros s hnm hnz,
    rw ←hnm,
    cases s "n",
    { finish },
    { simp [nat.succ_eq_add_one],
      linarith }
  end

/-! ## Hoare Triples for Total Correctness

__Total correctness__ asserts that the program not only is partially correct but
also that it always terminates normally. Hoare triples for total correctness
have the form

    [P] S [Q]

Intended meaning:

    If `P` holds before `S` is executed, the execution terminates normally and
    `Q` holds in the final state.

For deterministic programs, an equivalent formulation is as follows:

    If `P` holds before `S` is executed, there exists a state in which execution
    terminates normally and `Q` holds in that state.

Example:

    `[i ≤ 100] while i ≠ 100 do i := i + 1 [i = 100]`

In our WHILE language, this only affects while loops, which must now be
annotated by a __variant__ `V` (a natural number that decreases with each
iteration):

    [I ∧ b ∧ V = v₀] S [I ∧ V < v₀]
    ——————————————————————————————— While-Var
    [I] while b do S [I ∧ ¬b]

What is a suitable variant for the example above? -/

end LoVe


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

import category_theory.sites.canonical

/-!
# Grothendieck Topology and Sheaves on the Category of Types

In this file we define a Grothendieck topology on the category of types,
and construct the canonical functor that sends a type to a sheaf over
the category of types, and make this an equivalence of categories.

Then we prove that the topology defined is the canonical topology.
-/

universe u

namespace category_theory
open_locale category_theory.Type

/-- A Grothendieck topology associated to the category of all types.
A sieve is a covering iff it is jointly surjective. -/
def types_grothendieck_topology : grothendieck_topology (Type u) :=
{ sieves := λ α S, ∀ x : α, S (λ _ : punit, x),
  top_mem' := λ α x, trivial,
  pullback_stable' := λ α β S f hs x, hs (f x),
  transitive' := λ α S hs R hr x, hr (hs x) punit.star }

/-- The discrete sieve on a type, which only includes arrows whose image is a subsingleton. -/
@[simps] def discrete_sieve (α : Type u) : sieve α :=
{ arrows := λ β f, ∃ x, ∀ y, f y = x,
  downward_closed' := λ β γ f ⟨x, hx⟩ g, ⟨x, λ y, hx $ g y⟩ }

lemma discrete_sieve_mem (α : Type u) : discrete_sieve α ∈ types_grothendieck_topology α :=
λ x, ⟨x, λ y, rfl⟩

/-- The discrete presieve on a type, which only includes arrows whose domain is a singleton. -/
def discrete_presieve (α : Type u) : presieve α :=
λ β f, ∃ x : β, ∀ y : β, y = x

lemma generate_discrete_presieve_mem (α : Type u) :
  sieve.generate (discrete_presieve α) ∈ types_grothendieck_topology α :=
λ x, ⟨punit, id, λ _, x, ⟨punit.star, λ _, subsingleton.elim _ _⟩, rfl⟩

open presieve

theorem is_sheaf_yoneda' {α : Type u} : is_sheaf types_grothendieck_topology (yoneda.obj α) :=
λ β S hs x hx, ⟨λ y, x _ (hs y) punit.star,
λ γ f h, funext $ λ z,
  have _ := congr_fun (hx (𝟙 _) (λ _, z) (hs $ f z) h rfl) punit.star,
  by { convert this, exact rfl },
λ f hf, funext $ λ y, by convert congr_fun (hf _ (hs y)) punit.star⟩

/-- The yoneda functor that sends a type to a sheaf over the category of types -/
@[simps] def yoneda' : Type u ⥤ SheafOfTypes types_grothendieck_topology :=
{ obj := λ α, ⟨yoneda.obj α, is_sheaf_yoneda'⟩,
  map := λ α β f, ⟨yoneda.map f⟩ }

@[simp] lemma yoneda'_comp : yoneda'.{u} ⋙ SheafOfTypes_to_presheaf _ = yoneda := rfl

open opposite

/-- Given a presheaf `P` on the category of types, construct
a map `P(α) → (α → P(*))` for all type `α`. -/
def eval (P : (Type u)ᵒᵖ ⥤ Type u) (α : Type u) (s : P.obj (op α)) (x : α) : P.obj (op punit) :=
P.map (↾λ _, x).op s

/-- Given a sheaf `S` on the category of types, construct a map
`(α → S(*)) → S(α)` that is inverse to `eval`. -/
noncomputable def types_glue (S : (Type u)ᵒᵖ ⥤ Type u)
  (hs : is_sheaf types_grothendieck_topology S)
  (α : Type u) (f : α → S.obj (op punit)) : S.obj (op α) :=
(hs.is_sheaf_for _ _ (generate_discrete_presieve_mem α)).amalgamate
  (λ β g hg, S.map (↾λ x, punit.star).op $ f $ g $ classical.some hg)
  (λ β γ δ g₁ g₂ f₁ f₂ hf₁ hf₂ h,
    (hs.is_sheaf_for _ _ (generate_discrete_presieve_mem δ)).is_separated_for.ext $
    λ ε g ⟨x, hx⟩, have f₁ (classical.some hf₁) = f₂ (classical.some hf₂),
      from classical.some_spec hf₁ (g₁ $ g x) ▸ classical.some_spec hf₂ (g₂ $ g x) ▸ congr_fun h _,
      by { simp_rw [← functor_to_types.map_comp_apply, this, ← op_comp], refl })

lemma eval_types_glue {S hs α} (f) : eval.{u} S α (types_glue S hs α f) = f :=
funext $ λ x, (is_sheaf_for.valid_glue _ _ _ $
  by exact ⟨punit.star, λ _, subsingleton.elim _ _⟩).trans $
by { convert functor_to_types.map_id_apply _ _, rw ← op_id, congr }

lemma types_glue_eval {S hs α} (s) : types_glue.{u} S hs α (eval S α s) = s :=
(hs.is_sheaf_for _ _ (generate_discrete_presieve_mem α)).is_separated_for.ext $ λ β f hf,
(is_sheaf_for.valid_glue _ _ _ hf).trans $ (functor_to_types.map_comp_apply _ _ _ _).symm.trans $
by { rw ← op_comp, congr' 2, exact funext (λ x, congr_arg f (classical.some_spec hf x).symm) }

/-- Given a sheaf `S`, construct an equivalence `S(α) ≃ (α → S(*))`. -/
@[simps] noncomputable def eval_equiv (S : (Type u)ᵒᵖ ⥤ Type u)
  (hs : is_sheaf types_grothendieck_topology S)
  (α : Type u) : S.obj (op α) ≃ (α → S.obj (op punit)) :=
{ to_fun := eval S α,
  inv_fun := types_glue S hs α,
  left_inv := types_glue_eval,
  right_inv := eval_types_glue }

lemma eval_map (S : (Type u)ᵒᵖ ⥤ Type u) (α β) (f : β ⟶ α) (s x) :
  eval S β (S.map f.op s) x = eval S α s (f x) :=
by { simp_rw [eval, ← functor_to_types.map_comp_apply, ← op_comp], refl }

/-- Given a sheaf `S`, construct an isomorphism `S ≅ [-, S(*)]`. -/
@[simps] noncomputable def equiv_yoneda (S : (Type u)ᵒᵖ ⥤ Type u)
  (hs : is_sheaf types_grothendieck_topology S) :
  S ≅ yoneda.obj (S.obj (op punit)) :=
nat_iso.of_components (λ α, equiv.to_iso $ eval_equiv S hs $ unop α) $ λ α β f,
funext $ λ s, funext $ λ x, eval_map S (unop α) (unop β) f.unop _ _

/-- Given a sheaf `S`, construct an isomorphism `S ≅ [-, S(*)]`. -/
@[simps] noncomputable def equiv_yoneda'
  (S : SheafOfTypes types_grothendieck_topology) :
  S ≅ yoneda'.obj (S.1.obj (op punit)) :=
{ hom := ⟨(equiv_yoneda S.1 S.2).hom⟩,
  inv := ⟨(equiv_yoneda S.1 S.2).inv⟩,
  hom_inv_id' := by { ext1, apply (equiv_yoneda S.1 S.2).hom_inv_id },
  inv_hom_id' := by { ext1, apply (equiv_yoneda S.1 S.2).inv_hom_id } }

/-- `yoneda'` induces an equivalence of category between `Type u` and
`Sheaf types_grothendieck_topology`. -/
@[simps] noncomputable def type_equiv :
  Type u ≌ SheafOfTypes types_grothendieck_topology :=
equivalence.mk
  yoneda'
  (SheafOfTypes_to_presheaf _ ⋙ (evaluation _ _).obj (op punit))
  (nat_iso.of_components
    (λ α, /- α ≅ punit ⟶ α -/
      { hom := λ x _, x,
        inv := λ f, f punit.star,
        hom_inv_id' := funext $ λ x, rfl,
        inv_hom_id' := funext $ λ f, funext $ λ y, punit.cases_on y rfl })
    (λ α β f, rfl))
  (iso.symm $ nat_iso.of_components
    (λ S, equiv_yoneda' S)
    (λ S₁ S₂ f, SheafOfTypes.hom.ext _ _ $
      nat_trans.ext _ _ $ funext $ λ α, funext $ λ s, funext $ λ x,
      eval_app S₁ S₂ f (unop α) s x))

lemma subcanonical_types_grothendieck_topology :
  sheaf.subcanonical types_grothendieck_topology.{u} :=
sheaf.subcanonical.of_yoneda_is_sheaf _ (λ X, is_sheaf_yoneda')

lemma types_grothendieck_topology_eq_canonical :
  types_grothendieck_topology.{u} = sheaf.canonical_topology (Type u) :=
le_antisymm subcanonical_types_grothendieck_topology $ Inf_le ⟨yoneda.obj (ulift bool), ⟨_, rfl⟩,
grothendieck_topology.ext $ funext $ λ α, set.ext $ λ S,
⟨λ hs x, classical.by_contradiction $ λ hsx,
  have (λ _, ulift.up tt : (yoneda.obj (ulift bool)).obj (op punit)) = λ _, ulift.up ff :=
    (hs punit (λ _, x)).is_separated_for.ext $ λ β f hf, funext $ λ y, hsx.elim $ S.2 hf $ λ _, y,
  bool.no_confusion $ ulift.up.inj $ (congr_fun this punit.star : _),
λ hs β f, is_sheaf_yoneda' _ $ λ y, hs _⟩⟩

end category_theory


/-
Copyright (c) 2019 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Johannes Hölzl

Linear structures on function with finit support `α →₀ β` and multivariate polynomials.
-/
import data.matrix
import linear_algebra.dimension linear_algebra.tensor_product
noncomputable theory

local attribute [instance, priority 0] classical.prop_decidable

open lattice set linear_map submodule

namespace matrix
universes u v
variables {l m n o : Type u} [fintype l] [fintype m] [fintype n] [fintype o]

instance [decidable_eq m] [decidable_eq n] (α) [fintype α] : fintype (matrix m n α) :=
by unfold matrix; apply_instance

section ring
variables {α : Type v} [comm_ring α]

def eval : (matrix m n α) →ₗ[α] ((n → α) →ₗ[α] (m → α)) :=
begin
  refine linear_map.mk₂ α mul_vec _ _ _ _,
  { assume M N v, funext x,
    change finset.univ.sum (λy:n, (M x y + N x y) * v y) = _,
    simp only [_root_.add_mul, finset.sum_add_distrib],
    refl },
  { assume c M v, funext x,
    change finset.univ.sum (λy:n, (c * M x y) * v y) = _,
    simp only [_root_.mul_assoc, finset.mul_sum.symm],
    refl },
  { assume M v w, funext x,
    change finset.univ.sum (λy:n, M x y * (v y + w y)) = _,
    simp [_root_.mul_add, finset.sum_add_distrib],
    refl },
  { assume c M v, funext x,
    change finset.univ.sum (λy:n, M x y * (c * v y)) = _,
    rw [show (λy:n, M x y * (c * v y)) = (λy:n, c * (M x y * v y)), { funext n, ac_refl },
      ← finset.mul_sum],
    refl }
end

def to_lin : matrix m n α → (n → α) →ₗ[α] (m → α) := eval.to_fun

lemma to_lin_add (M N : matrix m n α) : (M + N).to_lin = M.to_lin + N.to_lin :=
matrix.eval.map_add M N

@[simp] lemma to_lin_zero : (0 : matrix m n α).to_lin = 0 :=
matrix.eval.map_zero

instance to_lin.is_linear_map :
  @is_linear_map α (matrix m n α) ((n → α) →ₗ[α] (m → α)) _ _ _ _ _ to_lin :=
matrix.eval.is_linear

instance to_lin.is_add_monoid_hom :
  @is_add_monoid_hom (matrix m n α) ((n → α) →ₗ[α] (m → α)) _ _ to_lin :=
{ map_zero := to_lin_zero, map_add := to_lin_add }

@[simp] lemma to_lin_apply (M : matrix m n α) (v : n → α) :
  (M.to_lin : (n → α) → (m → α)) v = mul_vec M v := rfl

lemma mul_to_lin [decidable_eq l] (M : matrix m n α) (N : matrix n l α) :
  (M.mul N).to_lin = M.to_lin.comp N.to_lin :=
begin
  ext v x,
  simp [to_lin_apply, mul_vec, matrix.mul, finset.sum_mul, finset.mul_sum],
  rw [finset.sum_comm],
  congr, funext x, congr, funext y,
  rw [mul_assoc]
end

section
open linear_map

lemma proj_diagonal [decidable_eq m] (i : m) (w : m → α) :
  (proj i).comp (to_lin (diagonal w)) = (w i) • proj i :=
by ext j; simp [mul_vec_diagonal]

lemma diagonal_comp_std_basis [decidable_eq n] (w : n → α) (i : n) :
  (diagonal w).to_lin.comp (std_basis α (λ_:n, α) i) = (w i) • std_basis α (λ_:n, α) i :=
begin
  ext a j,
  simp only [linear_map.comp_apply, smul_apply, to_lin_apply, mul_vec_diagonal, smul_apply,
    pi.smul_apply, smul_eq_mul],
  by_cases i = j,
  { subst h },
  { rw [std_basis_ne α (λ_:n, α) _ _ (ne.symm h), _root_.mul_zero, _root_.mul_zero] }
end
end

end ring

section vector_space
variables {α : Type u} [discrete_field α] -- maybe try to relax the universe constraint

open linear_map

lemma rank_vec_mul_vec [decidable_eq n] (w : m → α) (v : n → α) :
  rank (vec_mul_vec w v).to_lin ≤ 1 :=
begin
  rw [vec_mul_vec_eq, mul_to_lin],
  refine le_trans (rank_comp_le1 _ _) _,
  refine le_trans (rank_le_domain _) _,
  rw [dim_fun', ← cardinal.fintype_card],
  exact le_refl _
end

set_option class.instance_max_depth 100

lemma diagonal_to_lin [decidable_eq m] (w : m → α) :
  (diagonal w).to_lin = linear_map.pi (λi, w i • linear_map.proj i) :=
by ext v j; simp [mul_vec_diagonal]

lemma ker_diagonal_to_lin [decidable_eq m] (w : m → α) :
  ker (diagonal w).to_lin = (⨆i∈{i | w i = 0 }, range (std_basis α (λi, α) i)) :=
begin
  rw [← comap_bot, ← infi_ker_proj],
  simp only [comap_infi, (ker_comp _ _).symm, proj_diagonal, ker_smul'],
  have : univ ⊆ {i : m | w i = 0} ∪ -{i : m | w i = 0}, { rw set.union_compl_self },
  exact (supr_range_std_basis_eq_infi_ker_proj α (λi:m, α)
    (disjoint_compl {i | w i = 0}) this (finite.of_fintype _)).symm
end

lemma range_diagonal [decidable_eq m] (w : m → α) :
  (diagonal w).to_lin.range = (⨆ i ∈ {i | w i ≠ 0}, (std_basis α (λi, α) i).range) :=
begin
  dsimp only [mem_set_of_eq],
  rw [← map_top, ← supr_range_std_basis, map_supr],
  congr, funext i,
  rw [← linear_map.range_comp, diagonal_comp_std_basis, range_smul'],
end

local attribute [instance] classical.prop_decidable
lemma rank_diagonal [decidable_eq m] [decidable_eq α] (w : m → α) :
  rank (diagonal w).to_lin = fintype.card { i // w i ≠ 0 } :=
begin
  have hu : univ ⊆ - {i : m | w i = 0} ∪ {i : m | w i = 0}, { rw set.compl_union_self },
  have hd : disjoint {i : m | w i ≠ 0} {i : m | w i = 0} := (disjoint_compl {i | w i = 0}).symm,
  have h₁ := supr_range_std_basis_eq_infi_ker_proj α (λi:m, α) hd hu (finite.of_fintype _),
  have h₂ := infi_ker_proj_equiv α (λi:m, α) hd hu,
  rw [rank, range_diagonal, h₁, (linear_equiv.dim_eq.{u u} h₂)],
  exact dim_fun'
end

end vector_space

end matrix


/-
Copyright (c) 2021 Yaël Dillies, Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies, Bhavik Mehta
-/
import algebra.hom.freiman
import analysis.asymptotics.asymptotics
import analysis.convex.strict_convex_space

/-!
# Salem-Spencer sets and Roth numbers

This file defines Salem-Spencer sets and the Roth number of a set.

A Salem-Spencer set is a set without arithmetic progressions of length `3`. Equivalently, the
average of any two distinct elements is not in the set.

The Roth number of a finset is the size of its biggest Salem-Spencer subset. This is a more general
definition than the one often found in mathematical litterature, where the `n`-th Roth number is
the size of the biggest Salem-Spencer subset of `{0, ..., n - 1}`.

## Main declarations

* `mul_salem_spencer`: Predicate for a set to be multiplicative Salem-Spencer.
* `add_salem_spencer`: Predicate for a set to be additive Salem-Spencer.
* `mul_roth_number`: The multiplicative Roth number of a finset.
* `add_roth_number`: The additive Roth number of a finset.
* `roth_number_nat`: The Roth number of a natural. This corresponds to
  `add_roth_number (finset.range n)`.

## TODO

* Can `add_salem_spencer_iff_eq_right` be made more general?
* Generalize `mul_salem_spencer.image` to Freiman homs

## Tags

Salem-Spencer, Roth, arithmetic progression, average, three-free
-/

open finset function metric nat
open_locale pointwise

variables {F α β 𝕜 E : Type*}

section salem_spencer

open set

section monoid
variables [monoid α] [monoid β] (s t : set α)

/-- A multiplicative Salem-Spencer, aka non averaging, set `s` in a monoid is a set such that the
multiplicative average of any two distinct elements is not in the set. -/
@[to_additive "A Salem-Spencer, aka non averaging, set `s` in an additive monoid
is a set such that the average of any two distinct elements is not in the set."]
def mul_salem_spencer : Prop := ∀ ⦃a b c⦄, a ∈ s → b ∈ s → c ∈ s → a * b = c * c → a = b

/-- Whether a given finset is Salem-Spencer is decidable. -/
@[to_additive "Whether a given finset is Salem-Spencer is decidable."]
instance {α : Type*} [decidable_eq α] [monoid α] {s : finset α} :
  decidable (mul_salem_spencer (s : set α)) :=
decidable_of_iff (∀ a ∈ s, ∀ b ∈ s, ∀ c ∈ s, a * b = c * c → a = b)
  ⟨λ h a b c ha hb hc, h a ha b hb c hc, λ h a ha b hb c hc, h ha hb hc⟩

variables {s t}

@[to_additive]
lemma mul_salem_spencer.mono (h : t ⊆ s) (hs : mul_salem_spencer s) : mul_salem_spencer t :=
λ a b c ha hb hc, hs (h ha) (h hb) (h hc)

@[simp, to_additive]
lemma mul_salem_spencer_empty : mul_salem_spencer (∅ : set α) := λ a _ _ ha, ha.elim

@[to_additive]
lemma set.subsingleton.mul_salem_spencer (hs : s.subsingleton) : mul_salem_spencer s :=
λ a b _ ha hb _ _, hs ha hb

@[simp, to_additive]
lemma mul_salem_spencer_singleton (a : α) : mul_salem_spencer ({a} : set α) :=
subsingleton_singleton.mul_salem_spencer

@[to_additive add_salem_spencer.prod]
lemma mul_salem_spencer.prod {t : set β} (hs : mul_salem_spencer s) (ht : mul_salem_spencer t) :
  mul_salem_spencer (s ×ˢ t) :=
λ a b c ha hb hc h,
  prod.ext (hs ha.1 hb.1 hc.1 (prod.ext_iff.1 h).1) (ht ha.2 hb.2 hc.2 (prod.ext_iff.1 h).2)

@[to_additive]
lemma mul_salem_spencer_pi {ι : Type*} {α : ι → Type*} [Π i, monoid (α i)] {s : Π i, set (α i)}
  (hs : ∀ i, mul_salem_spencer (s i)) :
  mul_salem_spencer ((univ : set ι).pi s) :=
λ a b c ha hb hc h, funext $ λ i, hs i (ha i trivial) (hb i trivial) (hc i trivial) $ congr_fun h i

end monoid

section comm_monoid
variables [comm_monoid α] [comm_monoid β] {s : set α} {a : α}

@[to_additive]
lemma mul_salem_spencer.of_image [fun_like F α (λ _, β)] [freiman_hom_class F s β 2] (f : F)
  (hf : s.inj_on f) (h : mul_salem_spencer (f '' s)) :
  mul_salem_spencer s :=
λ a b c ha hb hc habc, hf ha hb $ h (mem_image_of_mem _ ha) (mem_image_of_mem _ hb)
  (mem_image_of_mem _ hc) $ map_mul_map_eq_map_mul_map f ha hb hc hc habc

-- TODO: Generalize to Freiman homs
@[to_additive]
lemma mul_salem_spencer.image [mul_hom_class F α β] (f : F) (hf : (s * s).inj_on f)
  (h : mul_salem_spencer s) :
  mul_salem_spencer (f '' s) :=
begin
  rintro _ _ _ ⟨a, ha, rfl⟩ ⟨b, hb, rfl⟩ ⟨c, hc, rfl⟩ habc,
  rw h ha hb hc (hf (mul_mem_mul ha hb) (mul_mem_mul hc hc) $ by rwa [map_mul, map_mul]),
end

end comm_monoid

section cancel_comm_monoid
variables [cancel_comm_monoid α] {s : set α} {a : α}

@[to_additive]
lemma mul_salem_spencer_insert :
  mul_salem_spencer (insert a s) ↔ mul_salem_spencer s ∧
    (∀ ⦃b c⦄, b ∈ s → c ∈ s → a * b = c * c → a = b) ∧
    ∀ ⦃b c⦄, b ∈ s → c ∈ s → b * c = a * a → b = c :=
begin
  refine ⟨λ hs, ⟨hs.mono (subset_insert _ _),
    λ b c hb hc, hs (or.inl rfl) (or.inr hb) (or.inr hc),
    λ b c hb hc, hs (or.inr hb) (or.inr hc) (or.inl rfl)⟩, _⟩,
  rintro ⟨hs, ha, ha'⟩ b c d hb hc hd h,
  rw mem_insert_iff at hb hc hd,
  obtain rfl | hb := hb;
  obtain rfl | hc := hc,
  { refl },
  all_goals { obtain rfl | hd := hd },
  { exact (mul_left_cancel h).symm },
  { exact ha hc hd h },
  { exact mul_right_cancel h },
  { exact (ha hb hd $ (mul_comm _ _).trans h).symm },
  { exact ha' hb hc h },
  { exact hs hb hc hd h }
end

@[simp, to_additive]
lemma mul_salem_spencer_pair (a b : α) : mul_salem_spencer ({a, b} : set α) :=
begin
  rw mul_salem_spencer_insert,
  refine ⟨mul_salem_spencer_singleton _, _, _⟩,
  { rintro c d (rfl : c = b) (rfl : d = c),
    exact mul_right_cancel },
  { rintro c d (rfl : c = b) (rfl : d = c) _,
    refl }
end

@[to_additive]
lemma mul_salem_spencer.mul_left (hs : mul_salem_spencer s) : mul_salem_spencer ((*) a '' s) :=
begin
  rintro _ _ _ ⟨b, hb, rfl⟩ ⟨c, hc, rfl⟩ ⟨d, hd, rfl⟩ h,
  rw [mul_mul_mul_comm, mul_mul_mul_comm a d] at h,
  rw hs hb hc hd (mul_left_cancel h),
end

@[to_additive]
lemma mul_salem_spencer.mul_right (hs : mul_salem_spencer s) : mul_salem_spencer ((* a) '' s) :=
begin
  rintro _ _ _ ⟨b, hb, rfl⟩ ⟨c, hc, rfl⟩ ⟨d, hd, rfl⟩ h,
  rw [mul_mul_mul_comm, mul_mul_mul_comm d] at h,
  rw hs hb hc hd (mul_right_cancel h),
end

@[to_additive]
lemma mul_salem_spencer_mul_left_iff : mul_salem_spencer ((*) a '' s) ↔ mul_salem_spencer s :=
⟨λ hs b c d hb hc hd h, mul_left_cancel (hs (mem_image_of_mem _ hb) (mem_image_of_mem _ hc)
  (mem_image_of_mem _ hd) $ by rw [mul_mul_mul_comm, h, mul_mul_mul_comm]),
  mul_salem_spencer.mul_left⟩

@[to_additive]
lemma mul_salem_spencer_mul_right_iff :
  mul_salem_spencer ((* a) '' s) ↔ mul_salem_spencer s :=
⟨λ hs b c d hb hc hd h, mul_right_cancel (hs (set.mem_image_of_mem _ hb) (set.mem_image_of_mem _ hc)
  (set.mem_image_of_mem _ hd) $ by rw [mul_mul_mul_comm, h, mul_mul_mul_comm]),
  mul_salem_spencer.mul_right⟩

end cancel_comm_monoid

section ordered_cancel_comm_monoid
variables [ordered_cancel_comm_monoid α] {s : set α} {a : α}

@[to_additive]
lemma mul_salem_spencer_insert_of_lt (hs : ∀ i ∈ s, i < a) :
  mul_salem_spencer (insert a s) ↔ mul_salem_spencer s ∧
    ∀ ⦃b c⦄, b ∈ s → c ∈ s → a * b = c * c → a = b :=
begin
  refine mul_salem_spencer_insert.trans _,
  rw ←and_assoc,
  exact and_iff_left (λ b c hb hc h, ((mul_lt_mul_of_lt_of_lt (hs _ hb) (hs _ hc)).ne h).elim),
end

end ordered_cancel_comm_monoid

section cancel_comm_monoid_with_zero
variables [cancel_comm_monoid_with_zero α] [no_zero_divisors α] {s : set α} {a : α}

lemma mul_salem_spencer.mul_left₀ (hs : mul_salem_spencer s) (ha : a ≠ 0) :
  mul_salem_spencer ((*) a '' s) :=
begin
  rintro _ _ _ ⟨b, hb, rfl⟩ ⟨c, hc, rfl⟩ ⟨d, hd, rfl⟩ h,
  rw [mul_mul_mul_comm, mul_mul_mul_comm a d] at h,
  rw hs hb hc hd (mul_left_cancel₀ (mul_ne_zero ha ha) h),
end

lemma mul_salem_spencer.mul_right₀ (hs : mul_salem_spencer s) (ha : a ≠ 0) :
  mul_salem_spencer ((* a) '' s) :=
begin
  rintro _ _ _ ⟨b, hb, rfl⟩ ⟨c, hc, rfl⟩ ⟨d, hd, rfl⟩ h,
  rw [mul_mul_mul_comm, mul_mul_mul_comm d] at h,
  rw hs hb hc hd (mul_right_cancel₀ (mul_ne_zero ha ha) h),
end

lemma mul_salem_spencer_mul_left_iff₀ (ha : a ≠ 0) :
  mul_salem_spencer ((*) a '' s) ↔ mul_salem_spencer s :=
⟨λ hs b c d hb hc hd h, mul_left_cancel₀ ha
  (hs (set.mem_image_of_mem _ hb) (set.mem_image_of_mem _ hc) (set.mem_image_of_mem _ hd) $
  by rw [mul_mul_mul_comm, h, mul_mul_mul_comm]),
  λ hs, hs.mul_left₀ ha⟩

lemma mul_salem_spencer_mul_right_iff₀ (ha : a ≠ 0) :
  mul_salem_spencer ((* a) '' s) ↔ mul_salem_spencer s :=
⟨λ hs b c d hb hc hd h, mul_right_cancel₀ ha
  (hs (set.mem_image_of_mem _ hb) (set.mem_image_of_mem _ hc) (set.mem_image_of_mem _ hd) $
  by rw [mul_mul_mul_comm, h, mul_mul_mul_comm]),
  λ hs, hs.mul_right₀ ha⟩

end cancel_comm_monoid_with_zero

section nat

lemma add_salem_spencer_iff_eq_right {s : set ℕ} :
  add_salem_spencer s ↔ ∀ ⦃a b c⦄, a ∈ s → b ∈ s → c ∈ s → a + b = c + c → a = c :=
begin
  refine forall₄_congr (λ a b c _, forall₃_congr $ λ _ _ habc, ⟨_, _⟩),
  { rintro rfl,
    simp_rw ←two_mul at habc,
    exact mul_left_cancel₀ two_ne_zero habc },
  { rintro rfl,
    exact (add_left_cancel habc).symm }
end

end nat

/-- The frontier of a closed strictly convex set only contains trivial arithmetic progressions.
The idea is that an arithmetic progression is contained on a line and the frontier of a strictly
convex set does not contain lines. -/
lemma add_salem_spencer_frontier [linear_ordered_field 𝕜] [topological_space E] [add_comm_monoid E]
  [module 𝕜 E] {s : set E} (hs₀ : is_closed s) (hs₁ : strict_convex 𝕜 s) :
  add_salem_spencer (frontier s) :=
begin
  intros a b c ha hb hc habc,
  obtain rfl : (1 / 2 : 𝕜) • a + (1 / 2 : 𝕜) • b = c,
  { rwa [←smul_add, one_div, inv_smul_eq_iff₀ (show (2 : 𝕜) ≠ 0, by norm_num), two_smul] },
  exact hs₁.eq (hs₀.frontier_subset ha) (hs₀.frontier_subset hb) one_half_pos one_half_pos
    (add_halves _) hc.2,
end

lemma add_salem_spencer_sphere [normed_add_comm_group E] [normed_space ℝ E]
  [strict_convex_space ℝ E] (x : E) (r : ℝ) : add_salem_spencer (sphere x r) :=
begin
  obtain rfl | hr := eq_or_ne r 0,
  { rw sphere_zero,
    exact add_salem_spencer_singleton _ },
  { convert add_salem_spencer_frontier is_closed_ball (strict_convex_closed_ball ℝ x r),
    exact (frontier_closed_ball _ hr).symm }
end

end salem_spencer

open finset

section roth_number
variables [decidable_eq α]

section monoid
variables [monoid α] [decidable_eq β] [monoid β] (s t : finset α)

/-- The multiplicative Roth number of a finset is the cardinality of its biggest multiplicative
Salem-Spencer subset. -/
@[to_additive "The additive Roth number of a finset is the cardinality of its biggest additive
Salem-Spencer subset. The usual Roth number corresponds to `add_roth_number (finset.range n)`, see
`roth_number_nat`. "]
def mul_roth_number : finset α →o ℕ :=
⟨λ s, nat.find_greatest (λ m, ∃ t ⊆ s, t.card = m ∧ mul_salem_spencer (t : set α)) s.card,
begin
  rintro t u htu,
  refine nat.find_greatest_mono (λ m, _) (card_le_of_subset htu),
  rintro ⟨v, hvt, hv⟩,
  exact ⟨v, hvt.trans htu, hv⟩,
end⟩

@[to_additive]
lemma mul_roth_number_le : mul_roth_number s ≤ s.card := by convert nat.find_greatest_le s.card

@[to_additive]
lemma mul_roth_number_spec : ∃ t ⊆ s, t.card = mul_roth_number s ∧ mul_salem_spencer (t : set α) :=
@nat.find_greatest_spec _ _ (λ m, ∃ t ⊆ s, t.card = m ∧ mul_salem_spencer (t : set α)) _
  (nat.zero_le _) ⟨∅, empty_subset _, card_empty, mul_salem_spencer_empty⟩

variables {s t} {n : ℕ}

@[to_additive]
lemma mul_salem_spencer.le_mul_roth_number (hs : mul_salem_spencer (s : set α)) (h : s ⊆ t) :
  s.card ≤ mul_roth_number t :=
le_find_greatest (card_le_of_subset h) ⟨s, h, rfl, hs⟩

@[to_additive]
lemma mul_salem_spencer.roth_number_eq (hs : mul_salem_spencer (s : set α)) :
  mul_roth_number s = s.card :=
(mul_roth_number_le _).antisymm $ hs.le_mul_roth_number $ subset.refl _

@[simp, to_additive]
lemma mul_roth_number_empty : mul_roth_number (∅ : finset α) = 0 :=
nat.eq_zero_of_le_zero $ (mul_roth_number_le _).trans card_empty.le

@[simp, to_additive]
lemma mul_roth_number_singleton (a : α) : mul_roth_number ({a} : finset α) = 1 :=
begin
  convert mul_salem_spencer.roth_number_eq _,
  rw coe_singleton,
  exact mul_salem_spencer_singleton a,
end

@[to_additive]
lemma mul_roth_number_union_le (s t : finset α) :
  mul_roth_number (s ∪ t) ≤ mul_roth_number s + mul_roth_number t :=
let ⟨u, hus, hcard, hu⟩ := mul_roth_number_spec (s ∪ t) in
calc
  mul_roth_number (s ∪ t)
      = u.card : hcard.symm
  ... = (u ∩ s ∪ u ∩ t).card
      : by rw [←inter_distrib_left, (inter_eq_left_iff_subset _ _).2 hus]
  ... ≤ (u ∩ s).card + (u ∩ t).card : card_union_le _ _
  ... ≤ mul_roth_number s + mul_roth_number t
      : add_le_add ((hu.mono $ inter_subset_left _ _).le_mul_roth_number $ inter_subset_right _ _)
          ((hu.mono $ inter_subset_left _ _).le_mul_roth_number $ inter_subset_right _ _)

@[to_additive]
lemma le_mul_roth_number_product (s : finset α) (t : finset β) :
  mul_roth_number s * mul_roth_number t ≤ mul_roth_number (s ×ˢ t) :=
begin
  obtain ⟨u, hus, hucard, hu⟩ := mul_roth_number_spec s,
  obtain ⟨v, hvt, hvcard, hv⟩ := mul_roth_number_spec t,
  rw [←hucard, ←hvcard, ←card_product],
  refine mul_salem_spencer.le_mul_roth_number _ (product_subset_product hus hvt),
  rw coe_product,
  exact hu.prod hv,
end

@[to_additive]
lemma mul_roth_number_lt_of_forall_not_mul_salem_spencer
  (h : ∀ t ∈ powerset_len n s, ¬mul_salem_spencer ((t : finset α) : set α)) :
  mul_roth_number s < n :=
begin
  obtain ⟨t, hts, hcard, ht⟩ := mul_roth_number_spec s,
  rw [←hcard, ←not_le],
  intro hn,
  obtain ⟨u, hut, rfl⟩ := exists_smaller_set t n hn,
  exact h _ (mem_powerset_len.2 ⟨hut.trans hts, rfl⟩) (ht.mono hut),
end

end monoid

section cancel_comm_monoid
variables [cancel_comm_monoid α] (s : finset α) (a : α)

@[simp, to_additive] lemma mul_roth_number_map_mul_left :
  mul_roth_number (s.map $ mul_left_embedding a) = mul_roth_number s :=
begin
  refine le_antisymm _ _,
  { obtain ⟨u, hus, hcard, hu⟩ := mul_roth_number_spec (s.map $ mul_left_embedding a),
    rw subset_map_iff at hus,
    obtain ⟨u, hus, rfl⟩ := hus,
    rw coe_map at hu,
    rw [←hcard, card_map],
    exact (mul_salem_spencer_mul_left_iff.1 hu).le_mul_roth_number hus },
  { obtain ⟨u, hus, hcard, hu⟩ := mul_roth_number_spec s,
    have h : mul_salem_spencer (u.map $ mul_left_embedding a : set α),
    { rw coe_map,
      exact hu.mul_left },
    convert h.le_mul_roth_number (map_subset_map.2 hus),
    rw [card_map, hcard] }
end

@[simp, to_additive] lemma mul_roth_number_map_mul_right :
  mul_roth_number (s.map $ mul_right_embedding a) = mul_roth_number s :=
by rw [←mul_left_embedding_eq_mul_right_embedding, mul_roth_number_map_mul_left s a]

end cancel_comm_monoid
end roth_number

section roth_number_nat
variables {s : finset ℕ} {k n : ℕ}

/-- The Roth number of a natural `N` is the largest integer `m` for which there is a subset of
`range N` of size `m` with no arithmetic progression of length 3.
Trivially, `roth_number_nat N ≤ N`, but Roth's theorem (proved in 1953) shows that
`roth_number_nat N = o(N)` and the construction by Behrend gives a lower bound of the form
`N * exp(-C sqrt(log(N))) ≤ roth_number_nat N`.
A significant refinement of Roth's theorem by Bloom and Sisask announced in 2020 gives
`roth_number_nat N = O(N / (log N)^(1+c))` for an absolute constant `c`. -/
def roth_number_nat : ℕ →o ℕ :=
⟨λ n, add_roth_number (range n), add_roth_number.mono.comp range_mono⟩

lemma roth_number_nat_def (n : ℕ) : roth_number_nat n = add_roth_number (range n) := rfl

lemma roth_number_nat_le (N : ℕ) : roth_number_nat N ≤ N :=
(add_roth_number_le _).trans (card_range _).le

lemma roth_number_nat_spec (n : ℕ) :
  ∃ t ⊆ range n, t.card = roth_number_nat n ∧ add_salem_spencer (t : set ℕ) :=
add_roth_number_spec _

/-- A verbose specialization of `add_salem_spencer.le_add_roth_number`, sometimes convenient in
practice. -/
lemma add_salem_spencer.le_roth_number_nat (s : finset ℕ) (hs : add_salem_spencer (s : set ℕ))
  (hsn : ∀ x ∈ s, x < n) (hsk : s.card = k) :
  k ≤ roth_number_nat n :=
hsk.ge.trans $ hs.le_add_roth_number $ λ x hx, mem_range.2 $ hsn x hx

/-- The Roth number is a subadditive function. Note that by Fekete's lemma this shows that
the limit `roth_number_nat N / N` exists, but Roth's theorem gives the stronger result that this
limit is actually `0`. -/
lemma roth_number_nat_add_le (M N : ℕ) :
  roth_number_nat (M + N) ≤ roth_number_nat M + roth_number_nat N :=
begin
  simp_rw roth_number_nat_def,
  rw [range_add_eq_union, ←add_roth_number_map_add_left (range N) M],
  exact add_roth_number_union_le _ _,
end

@[simp] lemma roth_number_nat_zero : roth_number_nat 0 = 0 := rfl

lemma add_roth_number_Ico (a b : ℕ) : add_roth_number (Ico a b) = roth_number_nat (b - a) :=
begin
  obtain h | h := le_total b a,
  { rw [tsub_eq_zero_of_le h, Ico_eq_empty_of_le h, roth_number_nat_zero, add_roth_number_empty] },
  convert add_roth_number_map_add_left _ a,
  rw [range_eq_Ico, map_eq_image],
  convert (image_add_left_Ico 0 (b - a) _).symm,
  exact (add_tsub_cancel_of_le h).symm,
end

open asymptotics filter

lemma roth_number_nat_is_O_with_id :
  is_O_with 1 at_top (λ N, (roth_number_nat N : ℝ)) (λ N, (N : ℝ)) :=
is_O_with_of_le _ $ by simpa only [real.norm_coe_nat, nat.cast_le] using roth_number_nat_le

/-- The Roth number has the trivial bound `roth_number_nat N = O(N)`. -/
lemma roth_number_nat_is_O_id : (λ N, (roth_number_nat N : ℝ)) =O[at_top] (λ N, (N : ℝ)) :=
roth_number_nat_is_O_with_id.is_O

end roth_number_nat