/-
Copyright (c) 2021 Shing Tak Lam. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Shing Tak Lam
-/

import topology.algebra.order.proj_Icc
import topology.continuous_function.ordered
import topology.compact_open
import topology.unit_interval

/-!
# Homotopy between functions

In this file, we define a homotopy between two functions `f₀` and `f₁`. First we define
`continuous_map.homotopy` between the two functions, with no restrictions on the intermediate
maps. Then, as in the formalisation in HOL-Analysis, we define
`continuous_map.homotopy_with f₀ f₁ P`, for homotopies between `f₀` and `f₁`, where the
intermediate maps satisfy the predicate `P`. Finally, we define
`continuous_map.homotopy_rel f₀ f₁ S`, for homotopies between `f₀` and `f₁` which are fixed
on `S`.

## Definitions

* `continuous_map.homotopy f₀ f₁` is the type of homotopies between `f₀` and `f₁`.
* `continuous_map.homotopy_with f₀ f₁ P` is the type of homotopies between `f₀` and `f₁`, where
  the intermediate maps satisfy the predicate `P`.
* `continuous_map.homotopy_rel f₀ f₁ S` is the type of homotopies between `f₀` and `f₁` which
  are fixed on `S`.

For each of the above, we have

* `refl f`, which is the constant homotopy from `f` to `f`.
* `symm F`, which reverses the homotopy `F`. For example, if `F : continuous_map.homotopy f₀ f₁`,
  then `F.symm : continuous_map.homotopy f₁ f₀`.
* `trans F G`, which concatenates the homotopies `F` and `G`. For example, if
  `F : continuous_map.homotopy f₀ f₁` and `G : continuous_map.homotopy f₁ f₂`, then
  `F.trans G : continuous_map.homotopy f₀ f₂`.

We also define the relations

* `continuous_map.homotopic f₀ f₁` is defined to be `nonempty (continuous_map.homotopy f₀ f₁)`
* `continuous_map.homotopic_with f₀ f₁ P` is defined to be
  `nonempty (continuous_map.homotopy_with f₀ f₁ P)`
* `continuous_map.homotopic_rel f₀ f₁ P` is defined to be
  `nonempty (continuous_map.homotopy_rel f₀ f₁ P)`

and for `continuous_map.homotopic` and `continuous_map.homotopic_rel`, we also define the
`setoid` and `quotient` in `C(X, Y)` by these relations.

## References

- [HOL-Analysis formalisation](https://isabelle.in.tum.de/library/HOL/HOL-Analysis/Homotopy.html)
-/

noncomputable theory

universes u v w

variables {F : Type*} {X : Type u} {Y : Type v} {Z : Type w}
variables [topological_space X] [topological_space Y] [topological_space Z]

open_locale unit_interval

namespace continuous_map

/-- `continuous_map.homotopy f₀ f₁` is the type of homotopies from `f₀` to `f₁`.

When possible, instead of parametrizing results over `(f : homotopy f₀ f₁)`,
you should parametrize over `{F : Type*} [homotopy_like F f₀ f₁] (f : F)`.

When you extend this structure, make sure to extend `continuous_map.homotopy_like`. -/
structure homotopy (f₀ f₁ : C(X, Y)) extends C(I × X, Y) :=
(map_zero_left' : ∀ x, to_fun (0, x) = f₀ x)
(map_one_left' : ∀ x, to_fun (1, x) = f₁ x)

/-- `continuous_map.homotopy_like F f₀ f₁` states that `F` is a type of homotopies between `f₀` and
`f₁`.

You should extend this class when you extend `continuous_map.homotopy`. -/
class homotopy_like (F : Type*) (f₀ f₁ : out_param $ C(X, Y))
  extends continuous_map_class F (I × X) Y :=
(map_zero_left (f : F) : ∀ x, f (0, x) = f₀ x)
(map_one_left (f : F) : ∀ x, f (1, x) = f₁ x)

-- `f₀` and `f₁` are `out_param` so this is not dangerous
attribute [nolint dangerous_instance] homotopy_like.to_continuous_map_class

namespace homotopy

section

variables {f₀ f₁ : C(X, Y)}

instance : homotopy_like (homotopy f₀ f₁) f₀ f₁ :=
{ coe := λ f, f.to_fun,
  coe_injective' := λ f g h, by { obtain ⟨⟨_, _⟩, _⟩ := f, obtain ⟨⟨_, _⟩, _⟩ := g, congr' },
  map_continuous := λ f, f.continuous_to_fun,
  map_zero_left := λ f, f.map_zero_left',
  map_one_left := λ f, f.map_one_left' }

/-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`
directly. -/
instance : has_coe_to_fun (homotopy f₀ f₁) (λ _, I × X → Y) := fun_like.has_coe_to_fun

@[ext]
lemma ext {F G : homotopy f₀ f₁} (h : ∀ x, F x = G x) : F = G := fun_like.ext _ _ h

/-- 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 (F : homotopy f₀ f₁) : I × X → Y := F

initialize_simps_projections homotopy (to_continuous_map_to_fun -> apply, -to_continuous_map)

/-- Deprecated. Use `map_continuous` instead. -/
protected lemma continuous (F : homotopy f₀ f₁) : continuous F := F.continuous_to_fun

@[simp]
lemma apply_zero (F : homotopy f₀ f₁) (x : X) : F (0, x) = f₀ x := F.map_zero_left' x

@[simp]
lemma apply_one (F : homotopy f₀ f₁) (x : X) : F (1, x) = f₁ x := F.map_one_left' x

@[simp]
lemma coe_to_continuous_map (F : homotopy f₀ f₁) : ⇑F.to_continuous_map = F := rfl

/--
Currying a homotopy to a continuous function fron `I` to `C(X, Y)`.
-/
def curry (F : homotopy f₀ f₁) : C(I, C(X, Y)) := F.to_continuous_map.curry

@[simp]
lemma curry_apply (F : homotopy f₀ f₁) (t : I) (x : X) : F.curry t x = F (t, x) := rfl

/--
Continuously extending a curried homotopy to a function from `ℝ` to `C(X, Y)`.
-/
def extend (F : homotopy f₀ f₁) : C(ℝ, C(X, Y)) := F.curry.Icc_extend zero_le_one

lemma extend_apply_of_le_zero (F : homotopy f₀ f₁) {t : ℝ} (ht : t ≤ 0) (x : X) :
  F.extend t x = f₀ x :=
begin
  rw [←F.apply_zero],
  exact continuous_map.congr_fun (set.Icc_extend_of_le_left (@zero_le_one ℝ _) F.curry ht) x,
end

lemma extend_apply_of_one_le (F : homotopy f₀ f₁) {t : ℝ} (ht : 1 ≤ t) (x : X) :
  F.extend t x = f₁ x :=
begin
  rw [←F.apply_one],
  exact continuous_map.congr_fun (set.Icc_extend_of_right_le (@zero_le_one ℝ _) F.curry ht) x,
end

@[simp]
lemma extend_apply_coe (F : homotopy f₀ f₁) (t : I) (x : X) : F.extend t x = F (t, x) :=
continuous_map.congr_fun (set.Icc_extend_coe (@zero_le_one ℝ _) F.curry t) x

@[simp]
lemma extend_apply_of_mem_I (F : homotopy f₀ f₁) {t : ℝ} (ht : t ∈ I) (x : X) :
  F.extend t x = F (⟨t, ht⟩, x) :=
continuous_map.congr_fun (set.Icc_extend_of_mem (@zero_le_one ℝ _) F.curry ht) x

lemma congr_fun {F G : homotopy f₀ f₁} (h : F = G) (x : I × X) : F x = G x :=
continuous_map.congr_fun (congr_arg _ h) x

lemma congr_arg (F : homotopy f₀ f₁) {x y : I × X} (h : x = y) : F x = F y :=
F.to_continuous_map.congr_arg h

end

/--
Given a continuous function `f`, we can define a `homotopy f f` by `F (t, x) = f x`
-/
@[simps]
def refl (f : C(X, Y)) : homotopy f f :=
{ to_fun := λ x, f x.2,
  map_zero_left' := λ _, rfl,
  map_one_left' := λ _, rfl }

instance : inhabited (homotopy (continuous_map.id X) (continuous_map.id X)) := ⟨homotopy.refl _⟩

/--
Given a `homotopy f₀ f₁`, we can define a `homotopy f₁ f₀` by reversing the homotopy.
-/
@[simps]
def symm {f₀ f₁ : C(X, Y)} (F : homotopy f₀ f₁) : homotopy f₁ f₀ :=
{ to_fun := λ x, F (σ x.1, x.2),
  map_zero_left' := by norm_num,
  map_one_left' := by norm_num }

@[simp]
lemma symm_symm {f₀ f₁ : C(X, Y)} (F : homotopy f₀ f₁) : F.symm.symm = F :=
by { ext, simp }

/--
Given `homotopy f₀ f₁` and `homotopy f₁ f₂`, we can define a `homotopy f₀ f₂` by putting the first
homotopy on `[0, 1/2]` and the second on `[1/2, 1]`.
-/
def trans {f₀ f₁ f₂ : C(X, Y)} (F : homotopy f₀ f₁) (G : homotopy f₁ f₂) :
  homotopy f₀ f₂ :=
{ to_fun := λ x, if (x.1 : ℝ) ≤ 1/2 then F.extend (2 * x.1) x.2 else G.extend (2 * x.1 - 1) x.2,
  continuous_to_fun := begin
    refine continuous_if_le (continuous_induced_dom.comp continuous_fst) continuous_const
      (F.continuous.comp (by continuity)).continuous_on
      (G.continuous.comp (by continuity)).continuous_on _,
    rintros x hx,
    norm_num [hx],
  end,
  map_zero_left' := λ x, by norm_num,
  map_one_left' := λ x, by norm_num }

lemma trans_apply {f₀ f₁ f₂ : C(X, Y)} (F : homotopy f₀ f₁) (G : homotopy f₁ f₂)
  (x : I × X) : (F.trans G) x =
  if h : (x.1 : ℝ) ≤ 1/2 then
    F (⟨2 * x.1, (unit_interval.mul_pos_mem_iff zero_lt_two).2 ⟨x.1.2.1, h⟩⟩, x.2)
  else
    G (⟨2 * x.1 - 1, unit_interval.two_mul_sub_one_mem_iff.2 ⟨(not_le.1 h).le, x.1.2.2⟩⟩, x.2) :=
show ite _ _ _ = _,
by split_ifs; { rw [extend, continuous_map.coe_Icc_extend, set.Icc_extend_of_mem], refl }

lemma symm_trans {f₀ f₁ f₂ : C(X, Y)} (F : homotopy f₀ f₁) (G : homotopy f₁ f₂) :
  (F.trans G).symm = G.symm.trans F.symm :=
begin
  ext x,
  simp only [symm_apply, trans_apply],
  split_ifs with h₁ h₂,
  { change (x.1 : ℝ) ≤ _ at h₂,
    change (1 : ℝ) - x.1 ≤ _ at h₁,
    have ht : (x.1 : ℝ) = 1/2,
    { linarith },
    norm_num [ht] },
  { congr' 2,
    apply subtype.ext,
    simp only [unit_interval.coe_symm_eq, subtype.coe_mk],
    linarith },
  { congr' 2,
    apply subtype.ext,
    simp only [unit_interval.coe_symm_eq, subtype.coe_mk],
    linarith },
  { change ¬ (x.1 : ℝ) ≤ _ at h,
    change ¬ (1 : ℝ) - x.1 ≤ _ at h₁,
    exfalso, linarith }
end

/--
Casting a `homotopy f₀ f₁` to a `homotopy g₀ g₁` where `f₀ = g₀` and `f₁ = g₁`.
-/
@[simps]
def cast {f₀ f₁ g₀ g₁ : C(X, Y)} (F : homotopy f₀ f₁) (h₀ : f₀ = g₀) (h₁ : f₁ = g₁) :
  homotopy g₀ g₁ :=
{ to_fun := F,
  map_zero_left' := by simp [←h₀],
  map_one_left' := by simp [←h₁] }

/--
If we have a `homotopy f₀ f₁` and a `homotopy g₀ g₁`, then we can compose them and get a
`homotopy (g₀.comp f₀) (g₁.comp f₁)`.
-/
@[simps]
def hcomp {f₀ f₁ : C(X, Y)} {g₀ g₁ : C(Y, Z)} (F : homotopy f₀ f₁) (G : homotopy g₀ g₁) :
  homotopy (g₀.comp f₀) (g₁.comp f₁) :=
{ to_fun := λ x, G (x.1, F x),
  map_zero_left' := by simp,
  map_one_left' := by simp }

end homotopy

/--
Given continuous maps `f₀` and `f₁`, we say `f₀` and `f₁` are homotopic if there exists a
`homotopy f₀ f₁`.
-/
def homotopic (f₀ f₁ : C(X, Y)) : Prop :=
nonempty (homotopy f₀ f₁)

namespace homotopic

@[refl]
lemma refl (f : C(X, Y)) : homotopic f f := ⟨homotopy.refl f⟩

@[symm]
lemma symm ⦃f g : C(X, Y)⦄ (h : homotopic f g) : homotopic g f := h.map homotopy.symm

@[trans]

lemma hcomp {f₀ f₁ : C(X, Y)} {g₀ g₁ : C(Y, Z)} (h₀ : homotopic f₀ f₁) (h₁ : homotopic g₀ g₁) :
  homotopic (g₀.comp f₀) (g₁.comp f₁) :=
h₀.map2 homotopy.hcomp h₁

lemma equivalence : equivalence (@homotopic X Y _ _) := ⟨refl, symm, trans⟩

end homotopic

/--
The type of homotopies between `f₀ f₁ : C(X, Y)`, where the intermediate maps satisfy the predicate
`P : C(X, Y) → Prop`
-/
structure homotopy_with (f₀ f₁ : C(X, Y)) (P : C(X, Y) → Prop) extends homotopy f₀ f₁ :=
(prop' : ∀ t, P ⟨λ x, to_fun (t, x),
  continuous.comp continuous_to_fun (continuous_const.prod_mk continuous_id')⟩)

namespace homotopy_with

section

variables {f₀ f₁ : C(X, Y)} {P : C(X, Y) → Prop}

instance : has_coe_to_fun (homotopy_with f₀ f₁ P) (λ _, I × X → Y) := ⟨λ F, F.to_fun⟩

lemma coe_fn_injective : @function.injective (homotopy_with f₀ f₁ P) (I × X → Y) coe_fn :=
begin
  rintros ⟨⟨⟨F, _⟩, _⟩, _⟩ ⟨⟨⟨G, _⟩, _⟩, _⟩ h,
  congr' 3,
end

@[ext]
lemma ext {F G : homotopy_with f₀ f₁ P} (h : ∀ x, F x = G x) : F = G :=
coe_fn_injective $ funext h

/-- 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 (F : homotopy_with f₀ f₁ P) : I × X → Y := F

initialize_simps_projections homotopy_with
  (to_homotopy_to_continuous_map_to_fun -> apply, -to_homotopy_to_continuous_map)

@[continuity]
protected lemma continuous (F : homotopy_with f₀ f₁ P) : continuous F := F.continuous_to_fun

@[simp]
lemma apply_zero (F : homotopy_with f₀ f₁ P) (x : X) : F (0, x) = f₀ x := F.map_zero_left' x

@[simp]
lemma apply_one (F : homotopy_with f₀ f₁ P) (x : X) : F (1, x) = f₁ x := F.map_one_left' x

@[simp]
lemma coe_to_continuous_map (F : homotopy_with f₀ f₁ P) : ⇑F.to_continuous_map = F := rfl

@[simp]
lemma coe_to_homotopy (F : homotopy_with f₀ f₁ P) : ⇑F.to_homotopy = F := rfl

lemma prop (F : homotopy_with f₀ f₁ P) (t : I) : P (F.to_homotopy.curry t) := F.prop' t

lemma extend_prop (F : homotopy_with f₀ f₁ P) (t : ℝ) : P (F.to_homotopy.extend t) :=
begin
  by_cases ht₀ : 0 ≤ t,
  { by_cases ht₁ : t ≤ 1,
    { convert F.prop ⟨t, ht₀, ht₁⟩,
      ext,
      rw [F.to_homotopy.extend_apply_of_mem_I ⟨ht₀, ht₁⟩, F.to_homotopy.curry_apply] },
    { convert F.prop 1,
      ext,
      rw [F.to_homotopy.extend_apply_of_one_le (le_of_not_le ht₁), F.to_homotopy.curry_apply,
          F.to_homotopy.apply_one] } },
  { convert F.prop 0,
    ext,
    rw [F.to_homotopy.extend_apply_of_le_zero (le_of_not_le ht₀), F.to_homotopy.curry_apply,
        F.to_homotopy.apply_zero] }
end

end

variable {P : C(X, Y) → Prop}

/--
Given a continuous function `f`, and a proof `h : P f`, we can define a `homotopy_with f f P` by
`F (t, x) = f x`
-/
@[simps]
def refl (f : C(X, Y)) (hf : P f) : homotopy_with f f P :=
{ prop' := λ t, by { convert hf, cases f, refl },
  ..homotopy.refl f }

instance : inhabited (homotopy_with (continuous_map.id X) (continuous_map.id X) (λ f, true)) :=
⟨homotopy_with.refl _ trivial⟩

/--
Given a `homotopy_with f₀ f₁ P`, we can define a `homotopy_with f₁ f₀ P` by reversing the homotopy.
-/
@[simps]
def symm {f₀ f₁ : C(X, Y)} (F : homotopy_with f₀ f₁ P) : homotopy_with f₁ f₀ P :=
{ prop' := λ t, by simpa using F.prop (σ t),
  ..F.to_homotopy.symm }

@[simp]
lemma symm_symm {f₀ f₁ : C(X, Y)} (F : homotopy_with f₀ f₁ P) : F.symm.symm = F :=
ext $ homotopy.congr_fun $ homotopy.symm_symm _

/--
Given `homotopy_with f₀ f₁ P` and `homotopy_with f₁ f₂ P`, we can define a `homotopy_with f₀ f₂ P`
by putting the first homotopy on `[0, 1/2]` and the second on `[1/2, 1]`.
-/
def trans {f₀ f₁ f₂ : C(X, Y)} (F : homotopy_with f₀ f₁ P) (G : homotopy_with f₁ f₂ P) :
  homotopy_with f₀ f₂ P :=
{ prop' := λ t, begin
    simp only [homotopy.trans],
    change P ⟨λ _, ite ((t : ℝ) ≤ _) _ _, _⟩,
    split_ifs,
    { exact F.extend_prop _ },
    { exact G.extend_prop _ }
  end,
  ..F.to_homotopy.trans G.to_homotopy }

lemma trans_apply {f₀ f₁ f₂ : C(X, Y)} (F : homotopy_with f₀ f₁ P) (G : homotopy_with f₁ f₂ P)
  (x : I × X) : (F.trans G) x =
  if h : (x.1 : ℝ) ≤ 1/2 then
    F (⟨2 * x.1, (unit_interval.mul_pos_mem_iff zero_lt_two).2 ⟨x.1.2.1, h⟩⟩, x.2)
  else
    G (⟨2 * x.1 - 1, unit_interval.two_mul_sub_one_mem_iff.2 ⟨(not_le.1 h).le, x.1.2.2⟩⟩, x.2) :=
homotopy.trans_apply _ _ _

lemma symm_trans {f₀ f₁ f₂ : C(X, Y)} (F : homotopy_with f₀ f₁ P) (G : homotopy_with f₁ f₂ P) :
  (F.trans G).symm = G.symm.trans F.symm :=
ext $ homotopy.congr_fun $ homotopy.symm_trans _ _

/--
Casting a `homotopy_with f₀ f₁ P` to a `homotopy_with g₀ g₁ P` where `f₀ = g₀` and `f₁ = g₁`.
-/
@[simps]
def cast {f₀ f₁ g₀ g₁ : C(X, Y)} (F : homotopy_with f₀ f₁ P) (h₀ : f₀ = g₀) (h₁ : f₁ = g₁) :
  homotopy_with g₀ g₁ P :=
{ prop' := F.prop,
  ..F.to_homotopy.cast h₀ h₁ }

end homotopy_with

/--
Given continuous maps `f₀` and `f₁`, we say `f₀` and `f₁` are homotopic with respect to the
predicate `P` if there exists a `homotopy_with f₀ f₁ P`.
-/
def homotopic_with (f₀ f₁ : C(X, Y)) (P : C(X, Y) → Prop) : Prop :=
nonempty (homotopy_with f₀ f₁ P)

namespace homotopic_with

variable {P : C(X, Y) → Prop}

@[refl]
lemma refl (f : C(X, Y)) (hf : P f) : homotopic_with f f P :=
⟨homotopy_with.refl f hf⟩

@[symm]
lemma symm ⦃f g : C(X, Y)⦄ (h : homotopic_with f g P) : homotopic_with g f P := ⟨h.some.symm⟩

@[trans]
lemma trans ⦃f g h : C(X, Y)⦄ (h₀ : homotopic_with f g P) (h₁ : homotopic_with g h P) :
  homotopic_with f h P :=
⟨h₀.some.trans h₁.some⟩

end homotopic_with

/--
A `homotopy_rel f₀ f₁ S` is a homotopy between `f₀` and `f₁` which is fixed on the points in `S`.
-/
abbreviation homotopy_rel (f₀ f₁ : C(X, Y)) (S : set X) :=
homotopy_with f₀ f₁ (λ f, ∀ x ∈ S, f x = f₀ x ∧ f x = f₁ x)

namespace homotopy_rel

section

variables {f₀ f₁ : C(X, Y)} {S : set X}

lemma eq_fst (F : homotopy_rel f₀ f₁ S) (t : I) {x : X} (hx : x ∈ S) :
  F (t, x) = f₀ x := (F.prop t x hx).1

lemma eq_snd (F : homotopy_rel f₀ f₁ S) (t : I) {x : X} (hx : x ∈ S) :
  F (t, x) = f₁ x := (F.prop t x hx).2

lemma fst_eq_snd (F : homotopy_rel f₀ f₁ S) {x : X} (hx : x ∈ S) :
  f₀ x = f₁ x := F.eq_fst 0 hx ▸ F.eq_snd 0 hx

end

variables {f₀ f₁ f₂ : C(X, Y)} {S : set X}

/--
Given a map `f : C(X, Y)` and a set `S`, we can define a `homotopy_rel f f S` by setting
`F (t, x) = f x` for all `t`. This is defined using `homotopy_with.refl`, but with the proof
filled in.
-/
@[simps]
def refl (f : C(X, Y)) (S : set X) : homotopy_rel f f S :=
homotopy_with.refl f (λ x hx, ⟨rfl, rfl⟩)

/--
Given a `homotopy_rel f₀ f₁ S`, we can define a `homotopy_rel f₁ f₀ S` by reversing the homotopy.
-/
@[simps]
def symm (F : homotopy_rel f₀ f₁ S) : homotopy_rel f₁ f₀ S :=
{ prop' := λ t x hx, by simp [F.eq_snd _ hx, F.fst_eq_snd hx],
  ..homotopy_with.symm F }

@[simp]
lemma symm_symm (F : homotopy_rel f₀ f₁ S) : F.symm.symm = F :=
homotopy_with.symm_symm F

/--
Given `homotopy_rel f₀ f₁ S` and `homotopy_rel f₁ f₂ S`, we can define a `homotopy_rel f₀ f₂ S`
by putting the first homotopy on `[0, 1/2]` and the second on `[1/2, 1]`.
-/
def trans (F : homotopy_rel f₀ f₁ S) (G : homotopy_rel f₁ f₂ S) : homotopy_rel f₀ f₂ S :=
{ prop' := λ t, begin
    intros x hx,
    simp only [homotopy.trans],
    change (⟨λ _, ite ((t : ℝ) ≤ _) _ _, _⟩ : C(X, Y)) _ = _ ∧ _ = _,
    split_ifs,
    { simp [(homotopy_with.extend_prop F (2 * t) x hx).1, F.fst_eq_snd hx, G.fst_eq_snd hx] },
    { simp [(homotopy_with.extend_prop G (2 * t - 1) x hx).1, F.fst_eq_snd hx, G.fst_eq_snd hx] },
  end,
  ..homotopy.trans F.to_homotopy G.to_homotopy }

lemma trans_apply (F : homotopy_rel f₀ f₁ S) (G : homotopy_rel f₁ f₂ S)
  (x : I × X) : (F.trans G) x =
  if h : (x.1 : ℝ) ≤ 1/2 then
    F (⟨2 * x.1, (unit_interval.mul_pos_mem_iff zero_lt_two).2 ⟨x.1.2.1, h⟩⟩, x.2)
  else
    G (⟨2 * x.1 - 1, unit_interval.two_mul_sub_one_mem_iff.2 ⟨(not_le.1 h).le, x.1.2.2⟩⟩, x.2) :=
homotopy.trans_apply _ _ _

lemma symm_trans (F : homotopy_rel f₀ f₁ S) (G : homotopy_rel f₁ f₂ S) :
  (F.trans G).symm = G.symm.trans F.symm :=
homotopy_with.ext $ homotopy.congr_fun $ homotopy.symm_trans _ _

/--
Casting a `homotopy_rel f₀ f₁ S` to a `homotopy_rel g₀ g₁ S` where `f₀ = g₀` and `f₁ = g₁`.
-/
@[simps]
def cast {f₀ f₁ g₀ g₁ : C(X, Y)} (F : homotopy_rel f₀ f₁ S) (h₀ : f₀ = g₀) (h₁ : f₁ = g₁) :
  homotopy_rel g₀ g₁ S :=
{ prop' := λ t x hx, by { simpa [←h₀, ←h₁] using F.prop t x hx },
  ..homotopy.cast F.to_homotopy h₀ h₁ }

end homotopy_rel

/--
Given continuous maps `f₀` and `f₁`, we say `f₀` and `f₁` are homotopic relative to a set `S` if
there exists a `homotopy_rel f₀ f₁ S`.
-/
def homotopic_rel (f₀ f₁ : C(X, Y)) (S : set X) : Prop :=
nonempty (homotopy_rel f₀ f₁ S)

namespace homotopic_rel

variable {S : set X}

@[refl]
lemma refl (f : C(X, Y)) : homotopic_rel f f S := ⟨homotopy_rel.refl f S⟩

@[symm]
lemma symm ⦃f g : C(X, Y)⦄ (h : homotopic_rel f g S) : homotopic_rel g f S :=
  h.map homotopy_rel.symm

@[trans]
lemma trans ⦃f g h : C(X, Y)⦄ (h₀ : homotopic_rel f g S) (h₁ : homotopic_rel g h S) :
  homotopic_rel f h S :=
h₀.map2 homotopy_rel.trans h₁

lemma equivalence : equivalence (λ f g : C(X, Y), homotopic_rel f g S) :=
⟨refl, symm, trans⟩

end homotopic_rel

end continuous_map


import localization_UMP
import massot_indexed_products
import data.fintype
import data.set.finite
import group_theory.submonoid
import tactic.ring
import chris_ring_lemma
local attribute [instance] classical.prop_decidable
-- Chris' proof of exactness
universes u v w

open finset classical quotient

section
variables {α : Type u} {β : Type v} {γ : Type w}

lemma is_ring_hom.inj_of_kernel_eq_zero [comm_ring α] [comm_ring β] {f : α → β} [hf : is_ring_hom f]
    (h : ∀ {x}, f x = 0 → x = 0) : function.injective f :=
λ x y hxy, by rw [← sub_eq_zero_iff_eq, ← is_ring_hom.map_sub f] at hxy;
  exact sub_eq_zero_iff_eq.1 (h hxy)

instance indexed_product.is_ring_hom [comm_ring α] {I : Type v} {f : I → Type w} [∀ i, comm_ring (f i)]
(g : α → Π i : I, f i) [rh : ∀ i : I, is_ring_hom (λ a : α, g a i)] : is_ring_hom g :=
{ map_add := λ x y, funext $ λ i, @is_ring_hom.map_add _ _ _ _ _ (rh i) x y,
  map_mul := λ x y, funext $ λ i, @is_ring_hom.map_mul _ _ _ _ _ (rh i) x y,
  map_one := funext $ λ i, @is_ring_hom.map_one _ _ _ _ _ (rh i) }

open finset

lemma exists_sum_iff_mem_span_finset {x : β} [ring α] [module α β] {s : finset β}
    : x ∈ span (↑s : set β) ↔ ∃ r : β → α, x = s.sum (λ y, r y • y) :=
⟨λ ⟨r, hr⟩, ⟨r, hr.2.symm ▸ sum_bij_ne_zero (λ a _ _, a)
  (λ a has ha, classical.by_contradiction (λ h, ha (by simp [hr.1 _ h])))
  (λ _ _ _ _ _ _, id)
  (λ b hbr hb, ⟨b, (finsupp.mem_support_iff).2 (λ h, hb (by simp [h])), hb, rfl⟩)
  (λ _ _ _, rfl)⟩,
λ ⟨r, hr⟩, hr.symm ▸ is_submodule.sum (λ c hc, is_submodule.smul _ (subset_span hc))⟩

lemma exists_sum_iff_mem_span_image_finset {x : β} [ring α] [module α β] {s : finset γ}
    {f : γ → β} : x ∈ span (↑(s.image f) : set β) ↔
    ∃ r : γ → α, x = s.sum (λ b, r b • f b) :=
⟨λ h, let ⟨r, hr⟩ := exists_sum_iff_mem_span_finset.1 h in
have hc : ∀ y ∈ s, ∃ z ∈ s, f z = f y := λ y hy, ⟨y, hy, rfl⟩,
⟨λ y, if ∃ hy : y ∈ s, y = some (hc y hy) then r (f y) else 0,
  hr.symm ▸ sum_bij_ne_zero (λ a ha _, some (mem_image.1 ha))
    (λ a ha _, let ⟨h, _⟩ := some_spec (mem_image.1 ha) in h)
    (λ a₁ a₂ ha₁ _ ha₂ _ h,
      let ⟨_, h₁⟩ := some_spec (mem_image.1 ha₁) in
      let ⟨_, h₂⟩ := some_spec (mem_image.1 ha₂) in
      h₁ ▸ h₂ ▸ h ▸ rfl)
    (λ b hbs hb0,
      have hfb : f b ∈ image f s := mem_image.2 ⟨b, hbs, rfl⟩,
      have hb : b = some (mem_image.1 hfb) := classical.by_contradiction
        (λ h, have h' : ¬∃ (x : b ∈ s), b = some _ := not_exists.2 (λ hy : b ∈ s, h),
        by rw [if_neg h', zero_smul] at hb0; exact hb0 rfl),
      ⟨f b, hfb, by rwa if_pos at hb0; exact ⟨hbs, hb⟩, hb⟩)
    (λ a ha ha0, let ⟨h₁, h₂⟩ := some_spec (mem_image.1 ha) in
      by rw [if_pos, h₂]; exact ⟨h₁, by simp only [h₂]⟩)⟩,
λ ⟨r, hr⟩, hr.symm ▸ is_submodule.sum (λ c hc, is_submodule.smul _
    (subset_span (mem_image.2 ⟨c, hc, rfl⟩)))⟩

lemma sum_pow_mem_span {α R : Type*} [comm_ring R] (s : finset α)
    (f : α → R) (n : α → ℕ) (r : α → R) : s.sum (λ a, r a • f a) ^ (s.sum n + 1) ∈ span
    (↑(s.image (λ a, f a ^ n a)) : set R) :=
finset.induction_on s (by simp) $ λ a s has hi,
begin
  rw [sum_insert has, add_pow],
  refine @is_submodule.sum R R _ _ (span _) _ _ _ _ _ (λ k hk, _),
  cases le_total (n a) k with hak hak,
  { rw [← nat.add_sub_cancel' hak, pow_add],
    simp only [mul_assoc, smul_eq_mul, mul_pow, mul_left_comm _ (f a ^ n a)],
    exact is_submodule.smul' _ (subset_span (mem_image.2 ⟨a, mem_insert_self _ _, rfl⟩)) },
  { rw [sum_insert has, add_assoc, add_comm (n a), nat.add_sub_assoc hak, pow_add],
    simp only [mul_assoc, smul_eq_mul, mul_pow, mul_left_comm _ (sum s _ ^ (sum s n + 1))],
    have : span ↑(image (λ a, f a ^ n a) s) ⊆ span ↑(image (λ a, f a ^ n a) (insert a s)) :=
      span_minimal is_submodule_span (set.subset.trans
        (by rw [image_insert,coe_subset]; exact subset_insert _ _) subset_span),
    exact is_submodule.smul' _ (this hi), }
end

lemma one_mem_span_pow_of_mem_span {α R : Type*} [comm_ring R] {s : finset α}
    {f : α → R} (n : α → ℕ) (h : (1 : R) ∈ span (↑(s.image f) : set R)) :
    (1 : R) ∈ span (↑(s.image (λ x, f x ^ n x)) : set R) :=
let ⟨r, hr⟩ := exists_sum_iff_mem_span_image_finset.1 h in
@one_pow R _ (s.sum n + 1) ▸ hr.symm ▸ sum_pow_mem_span _ _ _ _

end

variables {R : Type u} {γ : Type v} [comm_ring R] [fintype γ]
open localization

def tag00EJ.α (f : γ → R) (x : R) : Π i, loc R (powers (f i)) :=
  λ i, of_comm_ring R _ x

noncomputable def tag00EJ.β {f : γ → R}
    (r : Π i, loc R (powers (f i))) (j k : γ) :
    loc R (powers (f j * f k)) :=
localize_more_left (f j) (f k) (r j) - localize_more_right (f j) (f k) (r k)

-- β not a ring hom but it's β₁ - β₂ with ring homs defined below.

noncomputable def tag00EJ.β₁ {f : γ → R}
    (r : Π i, loc R (powers (f i))) (j k : γ) :
    loc R (powers (f j * f k)) :=
localize_more_left (f j) (f k) (r j)

noncomputable def tag00EJ.β₂ {f : γ → R}
    (r : Π i, loc R (powers (f i))) (j k : γ) :
    loc R (powers (f j * f k)) :=
localize_more_right (f j) (f k) (r k)

open tag00EJ

lemma localize_more_left_eq (f g x : R) (n : ℕ) :
    localize_more_left f g ⟦⟨x, ⟨f^n, n, rfl⟩⟩⟧ = ⟦⟨x * g^n, (f * g)^n, n, rfl⟩⟧ :=
begin
  let h,
  show ⟦_⟧ * classical.some h = ⟦_⟧,
  have := some_spec h,
  rw ← quotient.out_eq (some h) at *,
  rcases out (some h) with ⟨s₁, s₂, hs⟩, intro this,
  rcases quotient.exact this with ⟨r, hr₁, hr₂⟩,
  refine quot.sound ⟨r, hr₁, _⟩,
  rw [sub_mul, sub_eq_zero_iff_eq] at hr₂,
  have hr₂' : s₂ * r = f ^ n * s₁ * r,
  { simpa using hr₂ },
  suffices : (s₂ * (x * g ^ n) - ((f * g) ^ n * (x * s₁))) * r = 0,
  { rw ← this, simp },
  simp only [sub_mul, mul_pow, mul_assoc, mul_left_comm s₂,
      mul_comm r, mul_left_comm r, hr₂'],
  ring
end

lemma localize_more_right_eq (f g x : R) (n : ℕ) :
    localize_more_right f g ⟦⟨x, ⟨g^n, n, rfl⟩⟩⟧ = ⟦⟨x * f^n, (f * g)^n, n, rfl⟩⟧ :=
begin
  let h,
  show ⟦_⟧ * classical.some h = ⟦_⟧,
  have := some_spec h,
  rw ← quotient.out_eq (some h) at *,
  rcases out (some h) with ⟨s₁, s₂, hs⟩, intro this,
  rcases quotient.exact this with ⟨r, hr₁, hr₂⟩,
  refine quot.sound ⟨r, hr₁, _⟩,
  rw [sub_mul, sub_eq_zero_iff_eq] at hr₂,
  have hr₂' : s₂ * r = g ^ n * s₁ * r,
  { simpa using hr₂ },
  suffices : (s₂ * (x * f ^ n) - ((f * g) ^ n * (x * s₁))) * r = 0,
  { rw ← this, simp },
  simp only [sub_mul, mul_pow, mul_assoc, mul_left_comm s₂,
      mul_comm r, mul_left_comm r, hr₂'],
  ring
end

lemma lemma_standard_covering₁ {f : γ → R}
    (h : (1 : R) ∈ span (↑(univ.image f) : set R)) : function.injective (α f) :=
@is_ring_hom.inj_of_kernel_eq_zero _ _ _ _ (α f)
  (@indexed_product.is_ring_hom _ _ _ _ _ (α f)
  (λ i, by unfold α; apply_instance))
begin
  assume x hx,
  replace hx := congr_fun hx,
  have : ∀ i, ∃ e : ℕ, f i ^ e * x = 0 := λ i, begin
    rcases (quotient.eq.1 (hx i)) with ⟨r, hr₁, hr₂⟩,
    cases hr₁ with e he,
    have : x * r = 0 := by simpa using hr₂,
    exact ⟨e, by rwa [mul_comm, he]⟩
  end,
  let e : γ → ℕ := λ i, classical.some (this i),
  have he : ∀ i, f i ^ e i * x = 0 := λ i, some_spec (this i),
  cases exists_sum_iff_mem_span_image_finset.1 (one_mem_span_pow_of_mem_span e h) with r hr,
  rw [← one_mul x, hr, sum_mul, ← @sum_const_zero _ _ (univ : finset γ)],
  refine finset.sum_congr rfl (λ i _, _),
  rw [smul_eq_mul, mul_assoc, he, mul_zero],
end

lemma lemma_standard_covering₂ (f : γ → R)
    (H : (1:R) ∈ span (↑(univ.image f) : set R)) (s : Π i, loc R (powers (f i))) :
    β s = 0 ↔ ∃ r : R, α f r = s :=
⟨λ h : β s = 0,
let t := λ i, out (s i) in
let r := λ i, some (t i).2.2 in
have hst : ∀ i, s i = ⟦⟨(t i).1, (f i) ^ (r i), r i, rfl⟩⟧ :=
    λ i, by simp [r, some_spec (t i).2.2],
have hi : ∀ i, s i = ⟦⟨(t i).1, (t i).2.1, (t i).2.2⟩⟧ := λ i, by simp,
have hβ : _ := λ i j, sub_eq_zero_iff_eq.1 $ show β s i j = 0, by rw h; refl,
have hβ : ∀ i j,
    (⟦⟨(t i).1 * f j ^ r i, ⟨(f i * f j) ^ r i, r i, rfl⟩⟩⟧ : loc R (powers (f i * f j))) =
    ⟦⟨(t j).1 * f i ^ r j, ⟨(f i * f j) ^ r j, r j, rfl⟩⟩⟧ := by conv at hβ in (_ = _) {rw [hst, hst,
      localize_more_left_eq, localize_more_right_eq] }; exact hβ,
have ∀ i j, ∃ n,
    ((f i * f j) ^ r i * ((t j).1 * f i ^ r j) -
    ((f i * f j) ^ r j * ((t i).1 * f j ^ r i)))
    * (f i * f j) ^ n = 0 :=
  λ i j, let ⟨t, ⟨n, hn⟩, hnt⟩ := quotient.exact (hβ i j)
      in ⟨n, by rw hn; exact hnt⟩,
let n := λ i j, some (this i j) + r i + r j in
have hn : ∀ i j, (f i ^ r i * (t j).1 -
    f j ^ r j * (t i).1) * (f i * f j) ^ n i j = 0 :=
  λ i j, by rw [← zero_mul (f i ^ r i),
      ← zero_mul (f j ^ r j), ← some_spec (this i j)];
    simp [n, pow_add, mul_pow];
    ring,
let N := finset.sum (univ : finset (_ × _)) (λ ij, n ij.1 ij.2) in
have Nlt : ∀ i j, n i j ≤ N := λ i j,
  @single_le_sum _ _ _ (λ h : γ × γ, n h.1 h.2) _
  _ (λ _ _, nat.zero_le _) _ (mem_univ (i, j)),
have hN : ∀ i j, (f i ^ r i * (t j).1 -
    f j ^ r j * (t i).1) * (f i * f j) ^ N = 0 := λ i j,
  begin rw [← nat.sub_add_cancel (Nlt i j),
      ← zero_mul ((f i * f j) ^ (N - n i j)), ← hn i j,
      pow_add _ (N - n i j), mul_pow, mul_pow],
    simp [mul_add, add_mul, mul_comm, mul_left_comm, mul_assoc],
  end,
let ⟨a, ha⟩ := exists_sum_iff_mem_span_image_finset.1
    (one_mem_span_pow_of_mem_span (λ i, N + r i) H) in
⟨univ.sum (λ j, a j * (f j) ^ N * (t j).1),
funext (λ i, (hst i).symm ▸ quot.sound ⟨(f i) ^ N, ⟨N, rfl⟩,
have (λ j, f i ^ r i * (a j * f j ^ N * (t j).fst) * f i ^ N) =
      (λ j, (a j • (f j) ^ (N + r j) * (t i).1) * (f i) ^ N) := funext (λ j, begin
  rw [← sub_eq_zero_iff_eq, smul_eq_mul],
  simp only [mul_assoc, mul_left_comm _ (a j)],
  rw [← mul_sub],
  suffices : (f i ^ r i * (f j ^ N * ((t j).fst * f i ^ N))) -
      (f j ^ (N + r j) * ((t i).fst * f i ^ N)) = 0,
  { rw [this, mul_zero] },
  rw ← hN i j,
  simp [pow_add, mul_pow],
  ring,
  end),
begin
  suffices : ((t i).fst - (f i ^ r i * sum univ (λ j, a j * f j ^ N * (t j).1))) * f i ^ N = 0,
    simpa using this,
  rw [mul_sum, sub_mul, sum_mul, this, ← sum_mul, ← sum_mul, ← ha, one_mul, sub_self]
end⟩)⟩,
λ ⟨r, hr⟩, hr ▸ show β (α f r) = λ i j, 0, from funext $ λ i, funext $ λ j,
  sub_eq_zero_iff_eq.2 $ loc_commutes _ _ _⟩


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

import analysis.specific_limits

/-!
# Hofer's lemma

This is an elementary lemma about complete metric spaces. It is motivated by an
application to the bubbling-off analysis for holomorphic curves in symplectic topology.
We are *very* far away from having these applications, but the proof here is a nice
example of a proof needing to construct a sequence by induction in the middle of the proof.

## References:

* H. Hofer and C. Viterbo, *The Weinstein conjecture in the presence of holomorphic spheres*
-/

open_locale classical topological_space big_operators
open filter finset

local notation `d` := dist

lemma hofer {X: Type*} [metric_space X] [complete_space X]
  (x : X) (ε : ℝ) (ε_pos : 0 < ε)
  {ϕ : X → ℝ} (cont : continuous ϕ) (nonneg : ∀ y, 0 ≤ ϕ y) :
  ∃ (ε' > 0) (x' : X), ε' ≤ ε ∧
                       d x' x ≤ 2*ε ∧
                       ε * ϕ(x) ≤ ε' * ϕ x' ∧
                       ∀ y, d x' y ≤ ε' → ϕ y ≤ 2*ϕ x' :=
begin
  by_contradiction H,
  have reformulation : ∀ x' (k : ℕ), ε * ϕ x ≤ ε / 2 ^ k * ϕ x' ↔ 2^k * ϕ x ≤ ϕ x',
  { intros x' k,
    rw [div_mul_eq_mul_div, le_div_iff, mul_assoc, mul_le_mul_left ε_pos, mul_comm],
    exact pow_pos (by norm_num) k, },
  -- Now let's specialize to `ε/2^k`
  replace H : ∀ k : ℕ, ∀ x', d x' x ≤ 2 * ε ∧ 2^k * ϕ x ≤ ϕ x' →
    ∃ y, d x' y ≤ ε/2^k ∧ 2 * ϕ x' < ϕ y,
  { intros k x',
    push_neg at H,
    simpa [reformulation] using
      H (ε/2^k) (by simp [ε_pos, zero_lt_two]) x' (by simp [ε_pos, zero_lt_two, one_le_two]) },
  clear reformulation,
  haveI : nonempty X := ⟨x⟩,
  choose! F hF using H,  -- Use the axiom of choice
  -- Now define u by induction starting at x, with u_{n+1} = F(n, u_n)
  let u : ℕ → X := λ n, nat.rec_on n x F,
  have hu0 : u 0 = x := rfl,
  -- The properties of F translate to properties of u
  have hu :
    ∀ n,
      d (u n) x ≤ 2 * ε ∧ 2^n * ϕ x ≤ ϕ (u n) →
      d (u n) (u $ n + 1) ≤ ε / 2 ^ n ∧ 2 * ϕ (u n) < ϕ (u $ n + 1),
  { intro n,
    exact hF n (u n) },
  clear hF,
  -- Key properties of u, to be proven by induction
  have key : ∀ n, d (u n) (u (n + 1)) ≤ ε / 2 ^ n ∧ 2 * ϕ (u n) < ϕ (u (n + 1)),
  { intro n,
    induction n using nat.case_strong_induction_on with n IH,
    { specialize hu 0,
      simpa [hu0, mul_nonneg_iff, zero_le_one, ε_pos.le, le_refl] using hu },
    have A : d (u (n+1)) x ≤ 2 * ε,
    { rw [dist_comm],
      let r := range (n+1), -- range (n+1) = {0, ..., n}
      calc
      d (u 0) (u (n + 1))
          ≤ ∑ i in r, d (u i) (u $ i+1) : dist_le_range_sum_dist u (n + 1)
      ... ≤ ∑ i in r, ε/2^i             : sum_le_sum (λ i i_in, (IH i $ nat.lt_succ_iff.mp $
                                                                  finset.mem_range.mp i_in).1)
      ... = ∑ i in r, (1/2)^i*ε         : by { congr' with i, field_simp }
      ... = (∑ i in r, (1/2)^i)*ε       : finset.sum_mul.symm
      ... ≤ 2*ε                         : mul_le_mul_of_nonneg_right (sum_geometric_two_le _)
                                            (le_of_lt ε_pos), },
    have B : 2^(n+1) * ϕ x ≤ ϕ (u (n + 1)),
    { refine @geom_le (ϕ ∘ u) _ zero_le_two (n + 1) (λ m hm, _),
      exact (IH _ $ nat.lt_add_one_iff.1 hm).2.le },
    exact hu (n+1) ⟨A, B⟩, },
  cases forall_and_distrib.mp key with key₁ key₂,
  clear hu key,
  -- Hence u is Cauchy
  have cauchy_u : cauchy_seq u,
  { refine cauchy_seq_of_le_geometric _ ε one_half_lt_one (λ n, _),
    simpa only [one_div, inv_pow'] using key₁ n },
  -- So u converges to some y
  obtain ⟨y, limy⟩ : ∃ y, tendsto u at_top (𝓝 y),
    from complete_space.complete cauchy_u,
  -- And ϕ ∘ u goes to +∞
  have lim_top : tendsto (ϕ ∘ u) at_top at_top,
  { let v := λ n, (ϕ ∘ u) (n+1),
    suffices : tendsto v at_top at_top,
      by rwa tendsto_add_at_top_iff_nat at this,
    have hv₀ : 0 < v 0,
    { have : 0 ≤ ϕ (u 0) := nonneg x,
      calc 0 ≤ 2 * ϕ (u 0) : by linarith
      ... < ϕ (u (0 + 1)) : key₂ 0 },
    apply tendsto_at_top_of_geom_le hv₀ one_lt_two,
    exact λ n, (key₂ (n+1)).le },
  -- But ϕ ∘ u also needs to go to ϕ(y)
  have lim : tendsto (ϕ ∘ u) at_top (𝓝 (ϕ y)),
    from tendsto.comp cont.continuous_at limy,
  -- So we have our contradiction!
  exact not_tendsto_at_top_of_tendsto_nhds lim lim_top,
end


import GMLInit.Prelude

-- Stable Propositions --

class inductive Stable (a : Prop) : Prop
| protected intro : (¬¬a → a) → Stable a

abbrev inferStable (a : Prop) [inst : Stable a] := inst

protected def Stable.by_contradiction {a : Prop} [inst : Stable a] : ¬¬a → a :=
  match inst with | Stable.intro h => h

/-- double negation elimination (DNE) -/
theorem Stable.dne (a : Prop) [inst : Stable a] : ¬¬a → a :=
  match inst with | Stable.intro h => h

/-- Pierces's law -/
theorem Stable.pierce (a b : Prop) [Stable a] : ((a → b) → a) → a :=
  λ h => Stable.by_contradiction λ na => na (h λ ha => absurd ha na)

abbrev StablePred {α} (p : α → Prop) := (x : α) → Stable (p x)

abbrev StableRel {α β} (r : α → β → Prop) := (x : α) → (y : β) → Stable (r x y)

abbrev StableEq (α) := StableRel (@Eq α)

class inductive StableList : List Prop → Prop
| nil : StableList []
| cons {a as} : Stable a → StableList as → StableList (a :: as)

namespace StableList

instance : StableList [] := StableList.nil

instance (a as) [Stable a] [StableList as] : StableList (a :: as) :=
  StableList.cons inferInstance inferInstance

protected def head (a as) : [StableList (a :: as)] → Stable a
| StableList.cons inst _ => inst

protected def tail (a as) : [StableList (a :: as)] → StableList as
| StableList.cons _ inst => inst

end StableList

-- Complemented Propositions --

class inductive Complemented (a : Prop) : Prop
| isTrue : a → Complemented a
| isFalse : ¬a → Complemented a

abbrev inferComplemented (a : Prop) [inst : Complemented a] := inst

/-- eliminator for `Complemented` -/
protected def Complemented.by_cases (a : Prop) [inst : Complemented a] {motive : Prop} (isTrue : a → motive) (isFalse : ¬a → motive) : motive :=
  match inst with
  | .isTrue h => isTrue h
  | .isFalse h => isFalse h

/-- excluded middle (EM) -/
theorem Complemented.em (a : Prop) [Complemented a] : a ∨ ¬a := Complemented.by_cases a Or.inl Or.inr

abbrev ComplementedPred {α} (p : α → Prop) := (x : α) → Complemented (p x)

abbrev ComplementedRel {α β} (r : α → β → Prop) := (x : α) → (y : β) → Complemented (r x y)

abbrev ComplementedEq (α) := ComplementedRel (@Eq α)

class inductive ComplementedList : List Prop → Prop
| nil : ComplementedList []
| cons {a as} : Complemented a → ComplementedList as → ComplementedList (a :: as)

namespace ComplementedList

instance : ComplementedList [] := ComplementedList.nil

instance (a as) [Complemented a] [ComplementedList as] : ComplementedList (a :: as) :=
  ComplementedList.cons inferInstance inferInstance

protected def head (a as) : [ComplementedList (a :: as)] → Complemented a
| ComplementedList.cons inst _ => inst

protected def tail (a as) : [ComplementedList (a :: as)] → ComplementedList as
| ComplementedList.cons _ inst => inst

instance instMap {α} (a : α → Prop) [ComplementedPred a] : (xs : List α) → ComplementedList (xs.map a)
| [] => ComplementedList.nil
| _::xs => ComplementedList.cons inferInstance (instMap a xs)

end ComplementedList

instance (a : Prop) : [Complemented a] → Stable a
| Complemented.isTrue h => Stable.intro (λ _ => h)
| Complemented.isFalse h => Stable.intro (absurd h)

-- Decidable Propositions --

abbrev inferDecidable (a : Prop) [inst : Decidable a] := inst

class inductive DecidableList : List Prop → Type
| nil : DecidableList []
| cons {a as} : Decidable a → DecidableList as → DecidableList (a :: as)

namespace DecidableList

instance : DecidableList [] := DecidableList.nil

instance (a as) [Decidable a] [DecidableList as] : DecidableList (a :: as) :=
  DecidableList.cons inferInstance inferInstance

protected def head (a as) : [DecidableList (a :: as)] → Decidable a
| DecidableList.cons inst _ => inst

protected def tail (a as) : [DecidableList (a :: as)] → DecidableList as
| DecidableList.cons _ inst => inst

instance instMap {α} (a : α → Prop) [DecidablePred a] : (xs : List α) → DecidableList (xs.map a)
| [] => DecidableList.nil
| _::xs => DecidableList.cons inferInstance (instMap a xs)

end DecidableList

instance (a : Prop) : [Decidable a] → Complemented a
| Decidable.isTrue h => Complemented.isTrue h
| Decidable.isFalse h => Complemented.isFalse h

-- Weakly Complemented Propositions --

class inductive WeaklyComplemented (a : Prop) : Prop
| protected isFalse : ¬a → WeaklyComplemented a
| protected isIrrefutable : ¬¬a → WeaklyComplemented a

abbrev inferWeaklyComplemented (a : Prop) [inst : WeaklyComplemented a] := inst

/-- weak excluded middle (WEM) -/
theorem WeaklyComplemented.wem (a : Prop) : [WeaklyComplemented a] → ¬¬a ∨ ¬a
| WeaklyComplemented.isIrrefutable h => Or.inl h
| WeaklyComplemented.isFalse h => Or.inr h

abbrev WeaklyComplementedPred {α} (p : α → Prop) := (x : α) → WeaklyComplemented (p x)

abbrev WeaklyComplementedRel {α β} (r : α → β → Prop) := (x : α) → (y : β) → WeaklyComplemented (r x y)

abbrev WeaklyComplementedEq (α) := WeaklyComplementedRel (@Eq α)

class inductive WeaklyComplementedList : List Prop → Prop
| nil : WeaklyComplementedList []
| cons {a as} : WeaklyComplemented a → WeaklyComplementedList as → WeaklyComplementedList (a :: as)

namespace WeaklyComplementedList

instance : WeaklyComplementedList [] := WeaklyComplementedList.nil

instance (a as) [WeaklyComplemented a] [WeaklyComplementedList as] : WeaklyComplementedList (a :: as) :=
  WeaklyComplementedList.cons inferInstance inferInstance

protected def head (a as) : [WeaklyComplementedList (a :: as)] → WeaklyComplemented a
| WeaklyComplementedList.cons inst _ => inst

protected def tail (a as) : [WeaklyComplementedList (a :: as)] → WeaklyComplementedList as
| WeaklyComplementedList.cons _ inst => inst

instance instMap {α} (a : α → Prop) [WeaklyComplementedPred a] : (xs : List α) → WeaklyComplementedList (xs.map a)
| [] => WeaklyComplementedList.nil
| _::xs => WeaklyComplementedList.cons inferInstance (instMap a xs)

end WeaklyComplementedList

def complementedOfStableOfWeaklyComplemented (a : Prop) [Stable a] : [WeaklyComplemented a] → Complemented a
| WeaklyComplemented.isFalse h => Complemented.isFalse h
| WeaklyComplemented.isIrrefutable h => Complemented.isTrue (Stable.by_contradiction h)

instance (a : Prop) : [Complemented a] → WeaklyComplemented a
| Complemented.isTrue h => WeaklyComplemented.isIrrefutable (absurd h)
| Complemented.isFalse h => WeaklyComplemented.isFalse h

instance (a : Prop) : [WeaklyComplemented a] → Complemented (¬a)
| WeaklyComplemented.isFalse h => Complemented.isTrue h
| WeaklyComplemented.isIrrefutable h => Complemented.isFalse h

-- Weakly Decidable Propositions --

class inductive WeaklyDecidable (a : Prop) : Type
| protected isFalse : ¬a → WeaklyDecidable a
| protected isIrrefutable : ¬¬a → WeaklyDecidable a

abbrev inferWeaklyDecidable (a : Prop) [inst : WeaklyDecidable a] := inst

abbrev WeaklyDecidablePred {α} (p : α → Prop) := (x : α) → WeaklyDecidable (p x)

abbrev WeaklyDecidableRel {α β} (r : α → β → Prop) := (x : α) → (y : β) → WeaklyDecidable (r x y)

abbrev WeaklyDecidableEq (α) := WeaklyDecidableRel (@Eq α)

class inductive WeaklyDecidableList : List Prop → Type
| nil : WeaklyDecidableList []
| cons {a as} : WeaklyDecidable a → WeaklyDecidableList as → WeaklyDecidableList (a :: as)

namespace WeaklyDecidableList

instance : WeaklyDecidableList [] := WeaklyDecidableList.nil

instance (a as) [WeaklyDecidable a] [WeaklyDecidableList as] : WeaklyDecidableList (a :: as) :=
  WeaklyDecidableList.cons inferInstance inferInstance

protected def head (a as) : [WeaklyDecidableList (a :: as)] → WeaklyDecidable a
| WeaklyDecidableList.cons inst _ => inst

protected def tail (a as) : [WeaklyDecidableList (a :: as)] → WeaklyDecidableList as
| WeaklyDecidableList.cons _ inst => inst

instance instMap {α} (a : α → Prop) [WeaklyDecidablePred a] : (xs : List α) → WeaklyDecidableList (xs.map a)
| [] => WeaklyDecidableList.nil
| _::xs => WeaklyDecidableList.cons inferInstance (instMap a xs)

end WeaklyDecidableList

def decidableOfStableOfWeaklyDecidable (a : Prop) [Stable a] : [WeaklyDecidable a] → Decidable a
| WeaklyDecidable.isFalse h => Decidable.isFalse h
| WeaklyDecidable.isIrrefutable h => Decidable.isTrue (Stable.by_contradiction h)

instance (a : Prop) : [Decidable a] → WeaklyDecidable a
| Decidable.isTrue h => WeaklyDecidable.isIrrefutable (absurd h)
| Decidable.isFalse h => WeaklyDecidable.isFalse h

instance (a : Prop) : [WeaklyDecidable a] → Decidable (¬a)
| WeaklyDecidable.isFalse h => Decidable.isTrue h
| WeaklyDecidable.isIrrefutable h => Decidable.isFalse h


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import data.sum
import logic.function.basic
import control.functor
import tactic.core

/-!
# Functors with two arguments

This file defines bifunctors.

A bifunctor is a function `F : Type* → Type* → Type*` along with a bimap which turns `F α β` into
`F α' β'` given two functions `α → α'` and `β → β'`. It further
* respects the identity: `bimap id id = id`
* composes in the obvious way: `(bimap f' g') ∘ (bimap f g) = bimap (f' ∘ f) (g' ∘ g)`

## Main declarations

* `bifunctor`: A typeclass for the bare bimap of a bifunctor.
* `is_lawful_bifunctor`: A typeclass asserting this bimap respects the bifunctor laws.
-/

universes u₀ u₁ u₂ v₀ v₁ v₂

open function

/-- Lawless bifunctor. This typeclass only holds the data for the bimap. -/
class bifunctor (F : Type u₀ → Type u₁ → Type u₂) :=
(bimap : Π {α α' β β'}, (α → α') → (β → β') → F α β → F α' β')
export bifunctor ( bimap )

/-- Bifunctor. This typeclass asserts that a lawless `bifunctor` is lawful. -/
class is_lawful_bifunctor (F : Type u₀ → Type u₁ → Type u₂) [bifunctor F] :=
(id_bimap : Π {α β} (x : F α β), bimap id id x = x)
(bimap_bimap : Π {α₀ α₁ α₂ β₀ β₁ β₂} (f : α₀ → α₁) (f' : α₁ → α₂)
  (g : β₀ → β₁) (g' : β₁ → β₂) (x : F α₀ β₀),
  bimap f' g' (bimap f g x) = bimap (f' ∘ f) (g' ∘ g) x)

export is_lawful_bifunctor (id_bimap bimap_bimap)

attribute [higher_order bimap_id_id] id_bimap
attribute [higher_order bimap_comp_bimap] bimap_bimap

export is_lawful_bifunctor (bimap_id_id bimap_comp_bimap)
variables {F : Type u₀ → Type u₁ → Type u₂} [bifunctor F]

namespace bifunctor

/-- Left map of a bifunctor. -/
@[reducible] def fst {α α' β} (f : α → α') : F α β → F α' β := bimap f id

/-- Right map of a bifunctor. -/
@[reducible] def snd {α β β'} (f : β → β') : F α β → F α β' := bimap id f

variable [is_lawful_bifunctor F]

@[higher_order fst_id]
lemma id_fst : Π {α β} (x : F α β), fst id x = x :=
@id_bimap _ _ _

@[higher_order snd_id]
lemma id_snd : Π {α β} (x : F α β), snd id x = x :=
@id_bimap _ _ _

@[higher_order fst_comp_fst]

@[higher_order fst_comp_snd]
lemma fst_snd {α₀ α₁ β₀ β₁}
  (f : α₀ → α₁) (f' : β₀ → β₁) (x : F α₀ β₀) :
  fst f (snd f' x) = bimap f f' x :=
by simp [fst,bimap_bimap]

@[higher_order snd_comp_fst]
lemma snd_fst {α₀ α₁ β₀ β₁}
  (f : α₀ → α₁) (f' : β₀ → β₁) (x : F α₀ β₀) :
  snd f' (fst f x) = bimap f f' x :=
by simp [snd,bimap_bimap]

@[higher_order snd_comp_snd]
lemma comp_snd {α β₀ β₁ β₂}
  (g : β₀ → β₁) (g' : β₁ → β₂) (x : F α β₀) :
  snd g' (snd g x) = snd (g' ∘ g) x :=
by simp [snd,bimap_bimap]

attribute [functor_norm] bimap_bimap comp_snd comp_fst
  snd_comp_snd snd_comp_fst fst_comp_snd fst_comp_fst bimap_comp_bimap
  bimap_id_id fst_id snd_id

end bifunctor
open functor
instance : bifunctor prod :=
{ bimap := @prod.map }

instance : is_lawful_bifunctor prod :=
by refine { .. }; intros; cases x; refl

instance bifunctor.const : bifunctor const :=
{ bimap := (λ α α' β β f _, f) }

instance is_lawful_bifunctor.const : is_lawful_bifunctor const  :=
by refine { .. }; intros; refl

instance bifunctor.flip : bifunctor (flip F) :=
{ bimap := (λ α α' β β' f f' x, (bimap f' f x : F β' α')) }

instance is_lawful_bifunctor.flip [is_lawful_bifunctor F] : is_lawful_bifunctor (flip F)  :=
by refine { .. }; intros; simp [bimap] with functor_norm

instance : bifunctor sum :=
{ bimap := @sum.map }

instance : is_lawful_bifunctor sum :=
by refine { .. }; intros; cases x; refl

open bifunctor functor

@[priority 10]
instance bifunctor.functor {α} : functor (F α) :=
{ map := λ _ _, snd }

@[priority 10]
instance bifunctor.is_lawful_functor [is_lawful_bifunctor F] {α} : is_lawful_functor (F α) :=
by refine {..}; intros; simp [functor.map] with functor_norm

section bicompl

variables (G : Type* → Type u₀) (H : Type* → Type u₁) [functor G] [functor H]

instance : bifunctor (bicompl F G H) :=
{ bimap := λ α α' β β' f f' x, (bimap (map f) (map f') x : F (G α') (H β')) }

instance [is_lawful_functor G]  [is_lawful_functor H] [is_lawful_bifunctor F] :
  is_lawful_bifunctor (bicompl F G H) :=
by constructor; intros; simp [bimap,map_id,map_comp_map] with functor_norm

end bicompl
section bicompr

variables (G : Type u₂ → Type*) [functor G]

instance : bifunctor (bicompr G F) :=
{ bimap := λ α α' β β' f f' x, (map (bimap f f') x : G (F α' β')) }

instance [is_lawful_functor G] [is_lawful_bifunctor F] :
  is_lawful_bifunctor (bicompr G F) :=
by constructor; intros; simp [bimap] with functor_norm

end bicompr


/-
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 topology.sheaves.sheaf

/-!
# Sheafed spaces

Introduces the category of topological spaces equipped with a sheaf (taking values in an
arbitrary target category `C`.)

We further describe how to apply functors and natural transformations to the values of the
presheaves.
-/

universes v u

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

variables (C : Type u) [category.{v} C] [limits.has_products C]

local attribute [tidy] tactic.op_induction'

namespace algebraic_geometry

/-- A `SheafedSpace C` is a topological space equipped with a sheaf of `C`s. -/
structure SheafedSpace extends PresheafedSpace C :=
(sheaf_condition : presheaf.sheaf_condition)

variables {C}

namespace SheafedSpace

instance coe_carrier : has_coe (SheafedSpace C) Top :=
{ coe := λ X, X.carrier }

/-- Extract the `sheaf C (X : Top)` from a `SheafedSpace C`. -/
def sheaf (X : SheafedSpace C) : sheaf C (X : Top.{v}) := ⟨X.presheaf, X.sheaf_condition⟩

@[simp] lemma as_coe (X : SheafedSpace C) : X.carrier = (X : Top.{v}) := rfl
@[simp] lemma mk_coe (carrier) (presheaf) (h) :
  (({ carrier := carrier, presheaf := presheaf, sheaf_condition := h } : SheafedSpace.{v} C) :
  Top.{v}) = carrier :=
rfl

instance (X : SheafedSpace.{v} C) : topological_space X := X.carrier.str

/-- The trivial `punit` valued sheaf on any topological space. -/
noncomputable
def punit (X : Top) : SheafedSpace (discrete punit) :=
{ sheaf_condition := presheaf.sheaf_condition_punit _,
  ..@PresheafedSpace.const (discrete punit) _ X punit.star }

noncomputable
instance : inhabited (SheafedSpace (discrete _root_.punit)) := ⟨punit (Top.of pempty)⟩

instance : category (SheafedSpace C) :=
show category (induced_category (PresheafedSpace C) SheafedSpace.to_PresheafedSpace),
by apply_instance

/-- Forgetting the sheaf condition is a functor from `SheafedSpace C` to `PresheafedSpace C`. -/
def forget_to_PresheafedSpace : (SheafedSpace C) ⥤ (PresheafedSpace C) :=
induced_functor _

variables {C}

section
local attribute [simp] id comp

@[simp] lemma id_base (X : SheafedSpace C) :
  ((𝟙 X) : X ⟶ X).base = (𝟙 (X : Top.{v})) := rfl

lemma id_c (X : SheafedSpace C) :
  ((𝟙 X) : X ⟶ X).c =
  (((functor.left_unitor _).inv) ≫
  (whisker_right (nat_trans.op (opens.map_id (X.carrier)).hom) _)) := rfl

@[simp] lemma id_c_app (X : SheafedSpace C) (U) :
  ((𝟙 X) : X ⟶ X).c.app U = eq_to_hom (by { op_induction U, cases U, refl }) :=
by { op_induction U, cases U, simp only [id_c], dsimp, simp, }

@[simp] lemma comp_base {X Y Z : SheafedSpace C} (f : X ⟶ Y) (g : Y ⟶ Z) :
  (f ≫ g).base = f.base ≫ g.base := rfl

@[simp] lemma comp_c_app {X Y Z : SheafedSpace C} (α : X ⟶ Y) (β : Y ⟶ Z) (U) :
  (α ≫ β).c.app U = (β.c).app U ≫ (α.c).app (op ((opens.map (β.base)).obj (unop U))) ≫
    (Top.presheaf.pushforward.comp _ _ _).inv.app U := rfl

variables (C)

/-- The forgetful functor from `SheafedSpace` to `Top`. -/
def forget : SheafedSpace C ⥤ Top :=
{ obj := λ X, (X : Top.{v}),
  map := λ X Y f, f.base }

end

open Top.presheaf

/--
The restriction of a sheafed space along an open embedding into the space.
-/
noncomputable
def restrict {U : Top} (X : SheafedSpace C)
  (f : U ⟶ (X : Top.{v})) (h : open_embedding f) : SheafedSpace C :=
{ sheaf_condition := λ ι 𝒰, is_limit.of_iso_limit
    ((is_limit.postcompose_inv_equiv _ _).inv_fun (X.sheaf_condition _))
    (sheaf_condition_equalizer_products.fork.iso_of_open_embedding h 𝒰).symm,
  ..X.to_PresheafedSpace.restrict f h }

/--
The global sections, notated Gamma.
-/
def Γ : (SheafedSpace C)ᵒᵖ ⥤ C :=
forget_to_PresheafedSpace.op ⋙ PresheafedSpace.Γ

lemma Γ_def : (Γ : _ ⥤ C) = forget_to_PresheafedSpace.op ⋙ PresheafedSpace.Γ := rfl

@[simp]

lemma Γ_obj_op (X : SheafedSpace C) : Γ.obj (op X) = X.presheaf.obj (op ⊤) := rfl

@[simp] lemma Γ_map {X Y : (SheafedSpace C)ᵒᵖ} (f : X ⟶ Y) :
  Γ.map f = f.unop.c.app (op ⊤) ≫ (unop Y).presheaf.map (opens.le_map_top _ _).op := rfl

lemma Γ_map_op {X Y : SheafedSpace C} (f : X ⟶ Y) :
  Γ.map f.op = f.c.app (op ⊤) ≫ X.presheaf.map (opens.le_map_top _ _).op := rfl

end SheafedSpace

end algebraic_geometry


/-
Copyright (c) 2018 Sean Leather. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sean Leather, Mario Carneiro
-/
import data.list.alist
import data.finset.basic
import data.pfun
/-!
# Finite maps over `multiset`
-/

universes u v w
open list
variables {α : Type u} {β : α → Type v}

/-! ### multisets of sigma types-/

namespace multiset

/-- Multiset of keys of an association multiset. -/
def keys (s : multiset (sigma β)) : multiset α :=
s.map sigma.fst

@[simp] theorem coe_keys {l : list (sigma β)} :
  keys (l : multiset (sigma β)) = (l.keys : multiset α) :=
rfl

/-- `nodupkeys s` means that `s` has no duplicate keys. -/
def nodupkeys (s : multiset (sigma β)) : Prop :=
quot.lift_on s list.nodupkeys (λ s t p, propext $ perm_nodupkeys p)

@[simp] theorem coe_nodupkeys {l : list (sigma β)} : @nodupkeys α β l ↔ l.nodupkeys := iff.rfl

end multiset

/-! ### finmap -/

/-- `finmap β` is the type of finite maps over a multiset. It is effectively
  a quotient of `alist β` by permutation of the underlying list. -/
structure finmap (β : α → Type v) : Type (max u v) :=
(entries : multiset (sigma β))
(nodupkeys : entries.nodupkeys)

/-- The quotient map from `alist` to `finmap`. -/
def alist.to_finmap (s : alist β) : finmap β := ⟨s.entries, s.nodupkeys⟩

local notation `⟦`:max a `⟧`:0 := alist.to_finmap a

theorem alist.to_finmap_eq {s₁ s₂ : alist β} :
  ⟦s₁⟧ = ⟦s₂⟧ ↔ s₁.entries ~ s₂.entries :=
by cases s₁; cases s₂; simp [alist.to_finmap]

@[simp] theorem alist.to_finmap_entries (s : alist β) : ⟦s⟧.entries = s.entries := rfl

/-- Given `l : list (sigma β)`, create a term of type `finmap β` by removing
entries with duplicate keys. -/
def list.to_finmap [decidable_eq α] (s : list (sigma β)) : finmap β := s.to_alist.to_finmap

namespace finmap
open alist

/-! ### lifting from alist -/

/-- Lift a permutation-respecting function on `alist` to `finmap`. -/
@[elab_as_eliminator] def lift_on
  {γ} (s : finmap β) (f : alist β → γ)
  (H : ∀ a b : alist β, a.entries ~ b.entries → f a = f b) : γ :=
begin
  refine (quotient.lift_on s.1 (λ l, (⟨_, λ nd, f ⟨l, nd⟩⟩ : roption γ))
    (λ l₁ l₂ p, roption.ext' (perm_nodupkeys p) _) : roption γ).get _,
  { exact λ h₁ h₂, H _ _ (by exact p) },
  { have := s.nodupkeys, rcases s.entries with ⟨l⟩, exact id }
end

@[simp] theorem lift_on_to_finmap {γ} (s : alist β) (f : alist β → γ) (H) :
  lift_on ⟦s⟧ f H = f s := by cases s; refl

/-- Lift a permutation-respecting function on 2 `alist`s to 2 `finmap`s. -/
@[elab_as_eliminator] def lift_on₂
  {γ} (s₁ s₂ : finmap β) (f : alist β → alist β → γ)
  (H : ∀ a₁ b₁ a₂ b₂ : alist β, a₁.entries ~ a₂.entries → b₁.entries ~ b₂.entries →
    f a₁ b₁ = f a₂ b₂) : γ :=
lift_on s₁
  (λ l₁, lift_on s₂ (f l₁) (λ b₁ b₂ p, H _ _ _ _ (perm.refl _) p))
  (λ a₁ a₂ p, have H' : f a₁ = f a₂ := funext (λ _, H _ _ _ _ p (perm.refl _)), by simp only [H'])

@[simp] theorem lift_on₂_to_finmap {γ} (s₁ s₂ : alist β) (f : alist β → alist β → γ) (H) :
  lift_on₂ ⟦s₁⟧ ⟦s₂⟧ f H = f s₁ s₂ :=
by cases s₁; cases s₂; refl

/-! ### induction -/

@[elab_as_eliminator] theorem induction_on
  {C : finmap β → Prop} (s : finmap β) (H : ∀ (a : alist β), C ⟦a⟧) : C s :=
by rcases s with ⟨⟨a⟩, h⟩; exact H ⟨a, h⟩

@[elab_as_eliminator] theorem induction_on₂ {C : finmap β → finmap β → Prop}
  (s₁ s₂ : finmap β) (H : ∀ (a₁ a₂ : alist β), C ⟦a₁⟧ ⟦a₂⟧) : C s₁ s₂ :=
induction_on s₁ $ λ l₁, induction_on s₂ $ λ l₂, H l₁ l₂

@[elab_as_eliminator] theorem induction_on₃ {C : finmap β →  finmap β → finmap β → Prop}
  (s₁ s₂ s₃ : finmap β) (H : ∀ (a₁ a₂ a₃ : alist β), C ⟦a₁⟧ ⟦a₂⟧ ⟦a₃⟧) : C s₁ s₂ s₃ :=
induction_on₂ s₁ s₂ $ λ l₁ l₂, induction_on s₃ $ λ l₃, H l₁ l₂ l₃

/-! ### extensionality -/

@[ext] theorem ext : ∀ {s t : finmap β}, s.entries = t.entries → s = t
| ⟨l₁, h₁⟩ ⟨l₂, h₂⟩ H := by congr'

@[simp] theorem ext_iff {s t : finmap β} : s.entries = t.entries ↔ s = t :=
⟨ext, congr_arg _⟩

/-! ### mem -/

/-- The predicate `a ∈ s` means that `s` has a value associated to the key `a`. -/
instance : has_mem α (finmap β) := ⟨λ a s, a ∈ s.entries.keys⟩

theorem mem_def {a : α} {s : finmap β} :
  a ∈ s ↔ a ∈ s.entries.keys := iff.rfl

@[simp] theorem mem_to_finmap {a : α} {s : alist β} :
  a ∈ ⟦s⟧ ↔ a ∈ s := iff.rfl

/-! ### keys -/

/-- The set of keys of a finite map. -/
def keys (s : finmap β) : finset α :=
⟨s.entries.keys, induction_on s keys_nodup⟩

@[simp] theorem keys_val (s : alist β) : (keys ⟦s⟧).val = s.keys := rfl

@[simp] theorem keys_ext {s₁ s₂ : alist β} :
  keys ⟦s₁⟧ = keys ⟦s₂⟧ ↔ s₁.keys ~ s₂.keys :=
by simp [keys, alist.keys]

theorem mem_keys {a : α} {s : finmap β} : a ∈ s.keys ↔ a ∈ s :=
induction_on s $ λ s, alist.mem_keys

/-! ### empty -/

/-- The empty map. -/
instance : has_emptyc (finmap β) := ⟨⟨0, nodupkeys_nil⟩⟩

instance : inhabited (finmap β) := ⟨∅⟩

@[simp] theorem empty_to_finmap : (⟦∅⟧ : finmap β) = ∅ := rfl

@[simp] theorem to_finmap_nil [decidable_eq α] : ([].to_finmap : finmap β) = ∅ := rfl

theorem not_mem_empty {a : α} : a ∉ (∅ : finmap β) :=
multiset.not_mem_zero a

@[simp] theorem keys_empty : (∅ : finmap β).keys = ∅ := rfl

/-! ### singleton -/

/-- The singleton map. -/
def singleton (a : α) (b : β a) : finmap β := ⟦alist.singleton a b⟧

@[simp] theorem keys_singleton (a : α) (b : β a) :
  (singleton a b).keys = {a} := rfl

@[simp] lemma mem_singleton (x y : α) (b : β y) : x ∈ singleton y b ↔ x = y :=
by simp only [singleton]; erw [mem_cons_eq, mem_nil_iff, or_false]

section

variables [decidable_eq α]

instance has_decidable_eq [∀ a, decidable_eq (β a)] : decidable_eq (finmap β)
| s₁ s₂ := decidable_of_iff _ ext_iff

/-! ### lookup -/

/-- Look up the value associated to a key in a map. -/
def lookup (a : α) (s : finmap β) : option (β a) :=
lift_on s (lookup a) (λ s t, perm_lookup)

@[simp] theorem lookup_to_finmap (a : α) (s : alist β) :
  lookup a ⟦s⟧ = s.lookup a := rfl

@[simp] theorem lookup_list_to_finmap (a : α) (s : list (sigma β)) :
  lookup a s.to_finmap = s.lookup a :=
by rw [list.to_finmap, lookup_to_finmap, lookup_to_alist]

@[simp] theorem lookup_empty (a) : lookup a (∅ : finmap β) = none :=
rfl

theorem lookup_is_some {a : α} {s : finmap β} :
  (s.lookup a).is_some ↔ a ∈ s :=
induction_on s $ λ s, alist.lookup_is_some

theorem lookup_eq_none {a} {s : finmap β} : lookup a s = none ↔ a ∉ s :=
induction_on s $ λ s, alist.lookup_eq_none

@[simp] lemma lookup_singleton_eq {a : α} {b : β a} : (singleton a b).lookup a = some b :=
by rw [singleton, lookup_to_finmap, alist.singleton, alist.lookup, lookup_cons_eq]

instance (a : α) (s : finmap β) : decidable (a ∈ s) :=
decidable_of_iff _ lookup_is_some

lemma mem_iff {a : α} {s : finmap β} : a ∈ s ↔ ∃ b, s.lookup a = some b :=
induction_on s $ λ s,
iff.trans list.mem_keys $ exists_congr $ λ b,
(mem_lookup_iff s.nodupkeys).symm

lemma mem_of_lookup_eq_some {a : α} {b : β a} {s : finmap β} (h : s.lookup a = some b) : a ∈ s :=
mem_iff.mpr ⟨_, h⟩

theorem ext_lookup {s₁ s₂ : finmap β} : (∀ x, s₁.lookup x = s₂.lookup x) → s₁ = s₂ :=
induction_on₂ s₁ s₂ $ λ s₁ s₂ h,
begin
  simp only [alist.lookup, lookup_to_finmap] at h,
  rw [alist.to_finmap_eq],
  apply lookup_ext s₁.nodupkeys s₂.nodupkeys,
  intros x y,
  rw h,
end

/-! ### replace -/

/-- Replace a key with a given value in a finite map.
  If the key is not present it does nothing. -/
def replace (a : α) (b : β a) (s : finmap β) : finmap β :=
lift_on s (λ t, ⟦replace a b t⟧) $
λ s₁ s₂ p, to_finmap_eq.2 $ perm_replace p

@[simp] theorem replace_to_finmap (a : α) (b : β a) (s : alist β) :
  replace a b ⟦s⟧ = ⟦s.replace a b⟧ := by simp [replace]

@[simp] theorem keys_replace (a : α) (b : β a) (s : finmap β) :
  (replace a b s).keys = s.keys :=
induction_on s $ λ s, by simp

@[simp] theorem mem_replace {a a' : α} {b : β a} {s : finmap β} :
  a' ∈ replace a b s ↔ a' ∈ s :=
induction_on s $ λ s, by simp

end

/-! ### foldl -/

/-- Fold a commutative function over the key-value pairs in the map -/
def foldl {δ : Type w} (f : δ → Π a, β a → δ)
  (H : ∀ d a₁ b₁ a₂ b₂, f (f d a₁ b₁) a₂ b₂ = f (f d a₂ b₂) a₁ b₁)
  (d : δ) (m : finmap β) : δ :=
m.entries.foldl (λ d s, f d s.1 s.2) (λ d s t, H _ _ _ _ _) d

/-- `any f s` returns `tt` iff there exists a value `v` in `s` such that `f v = tt`. -/
def any (f : Π x, β x → bool) (s : finmap β) : bool :=
s.foldl (λ x y z, x ∨ f y z) (by { intros,  simp [or.right_comm] }) ff

/-- `all f s` returns `tt` iff `f v = tt` for all values `v` in `s`. -/
def all (f : Π x, β x → bool) (s : finmap β) : bool :=
s.foldl (λ x y z, x ∧ f y z) (by { intros, simp [and.right_comm] }) ff

/-! ### erase -/

section

variables [decidable_eq α]

/-- Erase a key from the map. If the key is not present it does nothing. -/
def erase (a : α) (s : finmap β) : finmap β :=
lift_on s (λ t, ⟦erase a t⟧) $
λ s₁ s₂ p, to_finmap_eq.2 $ perm_erase p

@[simp] theorem erase_to_finmap (a : α) (s : alist β) :
  erase a ⟦s⟧ = ⟦s.erase a⟧ := by simp [erase]

@[simp]

@[simp] theorem keys_erase (a : α) (s : finmap β) :
  (erase a s).keys = s.keys.erase a :=
induction_on s $ λ s, by simp

@[simp] theorem mem_erase {a a' : α} {s : finmap β} : a' ∈ erase a s ↔ a' ≠ a ∧ a' ∈ s :=
induction_on s $ λ s, by simp

theorem not_mem_erase_self {a : α} {s : finmap β} : ¬ a ∈ erase a s :=
by rw [mem_erase, not_and_distrib, not_not]; left; refl

@[simp] theorem lookup_erase (a) (s : finmap β) : lookup a (erase a s) = none :=
induction_on s $ lookup_erase a

@[simp] theorem lookup_erase_ne {a a'} {s : finmap β} (h : a ≠ a') :
  lookup a (erase a' s) = lookup a s :=
induction_on s $ λ s, lookup_erase_ne h

theorem erase_erase {a a' : α} {s : finmap β} : erase a (erase a' s) = erase a' (erase a s) :=
induction_on s $ λ s, ext (by simp only [erase_erase, erase_to_finmap])

/-! ### sdiff -/

/-- `sdiff s s'` consists of all key-value pairs from `s` and `s'` where the keys are in `s` or
`s'` but not both. -/
def sdiff (s s' : finmap β) : finmap β :=
s'.foldl (λ s x _, s.erase x) (λ a₀ a₁ _ a₂ _, erase_erase) s

instance : has_sdiff (finmap β) := ⟨sdiff⟩

/-! ### insert -/

/-- Insert a key-value pair into a finite map, replacing any existing pair with
  the same key. -/
def insert (a : α) (b : β a) (s : finmap β) : finmap β :=
lift_on s (λ t, ⟦insert a b t⟧) $
λ s₁ s₂ p, to_finmap_eq.2 $ perm_insert p

@[simp] theorem insert_to_finmap (a : α) (b : β a) (s : alist β) :
  insert a b ⟦s⟧ = ⟦s.insert a b⟧ := by simp [insert]

theorem insert_entries_of_neg {a : α} {b : β a} {s : finmap β} : a ∉ s →
  (insert a b s).entries = ⟨a, b⟩ ::ₘ s.entries :=
induction_on s $ λ s h,
by simp [insert_entries_of_neg (mt mem_to_finmap.1 h)]

@[simp] theorem mem_insert {a a' : α} {b' : β a'} {s : finmap β} :
  a ∈ insert a' b' s ↔ a = a' ∨ a ∈ s :=
induction_on s mem_insert

@[simp] theorem lookup_insert {a} {b : β a} (s : finmap β) :
  lookup a (insert a b s) = some b :=
induction_on s $ λ s,
by simp only [insert_to_finmap, lookup_to_finmap, lookup_insert]

@[simp] theorem lookup_insert_of_ne {a a'} {b : β a} (s : finmap β) (h : a' ≠ a) :
  lookup a' (insert a b s) = lookup a' s :=
induction_on s $ λ s,
by simp only [insert_to_finmap, lookup_to_finmap, lookup_insert_ne h]

@[simp] theorem insert_insert {a} {b b' : β a} (s : finmap β) :
  (s.insert a b).insert a b' = s.insert a b' :=
induction_on s $ λ s,
by simp only [insert_to_finmap, insert_insert]

theorem insert_insert_of_ne {a a'} {b : β a} {b' : β a'} (s : finmap β) (h : a ≠ a') :
  (s.insert a b).insert a' b' = (s.insert a' b').insert a b :=
induction_on s $ λ s,
by simp only [insert_to_finmap, alist.to_finmap_eq, insert_insert_of_ne _ h]

theorem to_finmap_cons (a : α) (b : β a) (xs : list (sigma β)) :
  list.to_finmap (⟨a,b⟩ :: xs) = insert a b xs.to_finmap := rfl

theorem mem_list_to_finmap (a : α) (xs : list (sigma β)) :
  a ∈ xs.to_finmap ↔ (∃ b : β a, sigma.mk a b ∈ xs) :=
by { induction xs with x xs; [skip, cases x];
     simp only [to_finmap_cons, *, not_mem_empty, exists_or_distrib, not_mem_nil, to_finmap_nil,
                exists_false, mem_cons_iff, mem_insert, exists_and_distrib_left];
     apply or_congr _ iff.rfl,
     conv { to_lhs, rw ← and_true (a = x_fst) },
     apply and_congr_right, rintro ⟨⟩, simp only [exists_eq, iff_self, heq_iff_eq] }

@[simp] theorem insert_singleton_eq {a : α} {b b' : β a} :
  insert a b (singleton a b') = singleton a b :=
by simp only [singleton, finmap.insert_to_finmap, alist.insert_singleton_eq]

/-! ### extract -/

/-- Erase a key from the map, and return the corresponding value, if found. -/
def extract (a : α) (s : finmap β) : option (β a) × finmap β :=
lift_on s (λ t, prod.map id to_finmap (extract a t)) $
λ s₁ s₂ p, by simp [perm_lookup p, to_finmap_eq, perm_erase p]

@[simp] theorem extract_eq_lookup_erase (a : α) (s : finmap β) :
  extract a s = (lookup a s, erase a s) :=
induction_on s $ λ s, by simp [extract]

/-! ### union -/

/-- `s₁ ∪ s₂` is the key-based union of two finite maps. It is left-biased: if
there exists an `a ∈ s₁`, `lookup a (s₁ ∪ s₂) = lookup a s₁`. -/
def union (s₁ s₂ : finmap β) : finmap β :=
lift_on₂ s₁ s₂ (λ s₁ s₂, ⟦s₁ ∪ s₂⟧) $
λ s₁ s₂ s₃ s₄ p₁₃ p₂₄, to_finmap_eq.mpr $ perm_union p₁₃ p₂₄

instance : has_union (finmap β) := ⟨union⟩

@[simp] theorem mem_union {a} {s₁ s₂ : finmap β} :
  a ∈ s₁ ∪ s₂ ↔ a ∈ s₁ ∨ a ∈ s₂ :=
induction_on₂ s₁ s₂ $ λ _ _, mem_union

@[simp] theorem union_to_finmap (s₁ s₂ : alist β) : ⟦s₁⟧ ∪ ⟦s₂⟧ = ⟦s₁ ∪ s₂⟧ :=
by simp [(∪), union]

theorem keys_union {s₁ s₂ : finmap β} : (s₁ ∪ s₂).keys = s₁.keys ∪ s₂.keys :=
induction_on₂ s₁ s₂ $ λ s₁ s₂, finset.ext $ by simp [keys]

@[simp] theorem lookup_union_left {a} {s₁ s₂ : finmap β} :
  a ∈ s₁ → lookup a (s₁ ∪ s₂) = lookup a s₁ :=
induction_on₂ s₁ s₂ $ λ s₁ s₂, lookup_union_left

@[simp] theorem lookup_union_right {a} {s₁ s₂ : finmap β} :
  a ∉ s₁ → lookup a (s₁ ∪ s₂) = lookup a s₂ :=
induction_on₂ s₁ s₂ $ λ s₁ s₂, lookup_union_right

theorem lookup_union_left_of_not_in {a} {s₁ s₂ : finmap β} (h : a ∉ s₂) :
  lookup a (s₁ ∪ s₂) = lookup a s₁ :=
begin
  by_cases h' : a ∈ s₁,
  { rw lookup_union_left h' },
  { rw [lookup_union_right h', lookup_eq_none.mpr h, lookup_eq_none.mpr h'] }
end

@[simp] theorem mem_lookup_union {a} {b : β a} {s₁ s₂ : finmap β} :
  b ∈ lookup a (s₁ ∪ s₂) ↔ b ∈ lookup a s₁ ∨ a ∉ s₁ ∧ b ∈ lookup a s₂ :=
induction_on₂ s₁ s₂ $ λ s₁ s₂, mem_lookup_union

theorem mem_lookup_union_middle {a} {b : β a} {s₁ s₂ s₃ : finmap β} :
  b ∈ lookup a (s₁ ∪ s₃) → a ∉ s₂ → b ∈ lookup a (s₁ ∪ s₂ ∪ s₃) :=
induction_on₃ s₁ s₂ s₃ $ λ s₁ s₂ s₃, mem_lookup_union_middle

theorem insert_union {a} {b : β a} {s₁ s₂ : finmap β} :
  insert a b (s₁ ∪ s₂) = insert a b s₁ ∪ s₂ :=
induction_on₂ s₁ s₂ $ λ a₁ a₂, by simp [insert_union]

theorem union_assoc {s₁ s₂ s₃ : finmap β} : (s₁ ∪ s₂) ∪ s₃ = s₁ ∪ (s₂ ∪ s₃) :=
induction_on₃ s₁ s₂ s₃ $ λ s₁ s₂ s₃,
by simp only [alist.to_finmap_eq, union_to_finmap, alist.union_assoc]

@[simp] theorem empty_union {s₁ : finmap β} : ∅ ∪ s₁ = s₁ :=
induction_on s₁ $ λ s₁, by rw ← empty_to_finmap;
  simp [- empty_to_finmap, alist.to_finmap_eq, union_to_finmap, alist.union_assoc]

@[simp] theorem union_empty {s₁ : finmap β} : s₁ ∪ ∅ = s₁ :=
induction_on s₁ $ λ s₁, by rw ← empty_to_finmap;
  simp [- empty_to_finmap, alist.to_finmap_eq, union_to_finmap, alist.union_assoc]

theorem erase_union_singleton (a : α) (b : β a) (s : finmap β) (h : s.lookup a = some b) :
  s.erase a ∪ singleton a b = s :=
ext_lookup
(λ x, by { by_cases h' : x = a,
      { subst a, rw [lookup_union_right not_mem_erase_self, lookup_singleton_eq, h], },
      { have : x ∉ singleton a b, { rwa mem_singleton },
        rw [lookup_union_left_of_not_in this, lookup_erase_ne h'] } } )

end

/-! ### disjoint -/

/-- `disjoint s₁ s₂` holds if `s₁` and `s₂` have no keys in common. -/
def disjoint (s₁ s₂ : finmap β) : Prop :=
∀ x ∈ s₁, ¬ x ∈ s₂

lemma disjoint_empty (x : finmap β) : disjoint ∅ x .

@[symm]
lemma disjoint.symm (x y : finmap β) (h : disjoint x y) : disjoint y x :=
λ p hy hx, h p hx hy

lemma disjoint.symm_iff (x y : finmap β) : disjoint x y ↔ disjoint y x :=
⟨disjoint.symm x y, disjoint.symm y x⟩

section

variables [decidable_eq α]

instance : decidable_rel (@disjoint α β) :=
λ x y, by dsimp only [disjoint]; apply_instance

lemma disjoint_union_left (x y z : finmap β) : disjoint (x ∪ y) z ↔ disjoint x z ∧ disjoint y z :=
by simp [disjoint, finmap.mem_union, or_imp_distrib, forall_and_distrib]

lemma disjoint_union_right (x y z : finmap β) : disjoint x (y ∪ z) ↔ disjoint x y ∧ disjoint x z :=
by rw [disjoint.symm_iff, disjoint_union_left, disjoint.symm_iff _ x, disjoint.symm_iff _ x]

theorem union_comm_of_disjoint {s₁ s₂ : finmap β} : disjoint s₁ s₂ → s₁ ∪ s₂ = s₂ ∪ s₁ :=
induction_on₂ s₁ s₂ $ λ s₁ s₂,
by { intros h, simp only [alist.to_finmap_eq, union_to_finmap, alist.union_comm_of_disjoint h] }

theorem union_cancel {s₁ s₂ s₃ : finmap β} (h : disjoint s₁ s₃) (h' : disjoint s₂ s₃) :
  s₁ ∪ s₃ = s₂ ∪ s₃ ↔ s₁ = s₂ :=
⟨λ h'', begin
          apply ext_lookup, intro x,
          have : (s₁ ∪ s₃).lookup x = (s₂ ∪ s₃).lookup x, from h'' ▸ rfl,
          by_cases hs₁ : x ∈ s₁,
          { rwa [lookup_union_left hs₁, lookup_union_left_of_not_in (h _ hs₁)] at this, },
          { by_cases hs₂ : x ∈ s₂,
            { rwa [lookup_union_left_of_not_in (h' _ hs₂), lookup_union_left hs₂] at this, },
            { rw [lookup_eq_none.mpr hs₁, lookup_eq_none.mpr hs₂] } }
        end,
 λ h, h ▸ rfl⟩

end

end finmap