/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.monoidal.natural_transformation
import Mathlib.PostPort

universes u₁ u₂ v₁ v₂

namespace Mathlib

/-!
# Transport a monoidal structure along an equivalence.

When `C` and `D` are equivalent as categories,
we can transport a monoidal structure on `C` along the equivalence,
obtaining a monoidal structure on `D`.

We don't yet prove anything about this transported structure!
The next step would be to show that the original functor can be upgraded
to a monoidal functor with respect to this new structure.
-/

namespace category_theory.monoidal

/--
Transport a monoidal structure along an equivalence of (plain) categories.
-/
@[simp] theorem transport_tensor_unit {C : Type u₁} [category C] [monoidal_category C] {D : Type u₂}
    [category D] (e : C ≌ D) : 𝟙_ = functor.obj (equivalence.functor e) 𝟙_ :=
  Eq.refl 𝟙_

/-- A type synonym for `D`, which will carry the transported monoidal structure. -/
def transported {C : Type u₁} [category C] [monoidal_category C] {D : Type u₂} [category D]
    (e : C ≌ D) :=
  D

protected instance transported.category_theory.monoidal_category {C : Type u₁} [category C]
    [monoidal_category C] {D : Type u₂} [category D] (e : C ≌ D) :
    monoidal_category (transported e) :=
  transport e

protected instance transported.inhabited {C : Type u₁} [category C] [monoidal_category C]
    {D : Type u₂} [category D] (e : C ≌ D) : Inhabited (transported e) :=
  { default := 𝟙_ }

/--
We can upgrade `e.functor` to a lax monoidal functor from `C` to `D` with the transported structure.
-/
@[simp] theorem lax_to_transported_to_functor_map {C : Type u₁} [category C] [monoidal_category C]
    {D : Type u₂} [category D] (e : C ≌ D) {X : C} {Y : C} :
    ∀ (ᾰ : X ⟶ Y),
        functor.map (lax_monoidal_functor.to_functor (lax_to_transported e)) ᾰ =
          functor.map (equivalence.functor e) ᾰ :=
  fun (ᾰ : X ⟶ Y) =>
    Eq.refl (functor.map (lax_monoidal_functor.to_functor (lax_to_transported e)) ᾰ)

/--
We can upgrade `e.functor` to a monoidal functor from `C` to `D` with the transported structure.
-/
@[simp] theorem to_transported_ε_is_iso {C : Type u₁} [category C] [monoidal_category C]
    {D : Type u₂} [category D] (e : C ≌ D) :
    monoidal_functor.ε_is_iso (to_transported e) =
        id (is_iso.id (functor.obj (equivalence.functor e) 𝟙_)) :=
  Eq.refl (monoidal_functor.ε_is_iso (to_transported e))

/--
We can upgrade `e.inverse` to a lax monoidal functor from `D` with the transported structure to `C`.
-/
def lax_from_transported {C : Type u₁} [category C] [monoidal_category C] {D : Type u₂} [category D]
    (e : C ≌ D) : lax_monoidal_functor (transported e) C :=
  lax_monoidal_functor.mk
    (functor.mk (functor.obj (equivalence.inverse e)) (functor.map (equivalence.inverse e)))
    (nat_trans.app (equivalence.unit e) 𝟙_)
    fun (X Y : transported e) =>
      nat_trans.app (equivalence.unit e)
        (functor.obj (equivalence.inverse e) X ⊗ functor.obj (equivalence.inverse e) Y)

/--
We can upgrade `e.inverse` to a monoidal functor from `D` with the transported structure to `C`.
-/
def from_transported {C : Type u₁} [category C] [monoidal_category C] {D : Type u₂} [category D]
    (e : C ≌ D) : monoidal_functor (transported e) C :=
  monoidal_functor.mk
    (lax_monoidal_functor.mk (lax_monoidal_functor.to_functor (lax_from_transported e))
      (lax_monoidal_functor.ε (lax_from_transported e))
      (lax_monoidal_functor.μ (lax_from_transported e)))

/-- The unit isomorphism upgrades to a monoidal isomorphism. -/
def transported_monoidal_unit_iso {C : Type u₁} [category C] [monoidal_category C] {D : Type u₂}
    [category D] (e : C ≌ D) :
    lax_monoidal_functor.id C ≅ lax_to_transported e ⊗⋙ lax_from_transported e :=
  monoidal_nat_iso.of_components (fun (X : C) => iso.app (equivalence.unit_iso e) X) sorry sorry
    sorry

/-- The counit isomorphism upgrades to a monoidal isomorphism. -/
@[simp] theorem transported_monoidal_counit_iso_hom_to_nat_trans_app {C : Type u₁} [category C]
    [monoidal_category C] {D : Type u₂} [category D] (e : C ≌ D) (X : transported e) :
    nat_trans.app (monoidal_nat_trans.to_nat_trans (iso.hom (transported_monoidal_counit_iso e)))
          X =
        nat_trans.app (iso.hom (equivalence.counit_iso e)) X :=
  Eq.refl (nat_trans.app (iso.hom (equivalence.counit_iso e)) X)

end Mathlib


/-
Copyright (c) 2022 Henrik Böving. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Henrik Böving, Simon Hudon
-/
import LSpec.SlimCheck.Gen

/-!
# `SampleableExt` Class
This class permits the creation samples of a given type
controlling the size of those values using the `Gen` monad`.
# `Shrinkable` Class
This class helps minimize examples by creating smaller versions of
given values.
When testing a proposition like `∀ n : ℕ, prime n → n ≤ 100`,
`SlimCheck` requires that `ℕ` have an instance of `SampleableExt` and for
`prime n` to be decidable.  `SlimCheck` will then use the instance of
`SampleableExt` to generate small examples of ℕ and progressively increase
in size. For each example `n`, `prime n` is tested. If it is false,
the example will be rejected (not a test success nor a failure) and
`SlimCheck` will move on to other examples. If `prime n` is true, `n
≤ 100` will be tested. If it is false, `n` is a counter-example of `∀
n : ℕ, prime n → n ≤ 100` and the test fails. If `n ≤ 100` is true,
the test passes and `SlimCheck` moves on to trying more examples.
This is a port of the Haskell QuickCheck library.
## Main definitions
  * `SampleableExt` class
  * `Shrinkable` class
### `SampleableExt`
`SampleableExt` can be used in two ways. The first (and most common)
is to simply generate values of a type directly using the `Gen` monad,
if this is what you want to do then `SampleableExt.mkSelfContained` is
the way to go.
Furthermore it makes it possible to express generators for types that
do not lend themselves to introspection, such as `ℕ → ℕ`.
If we test a quantification over functions the
counter-examples cannot be shrunken or printed meaningfully.
For that purpose, `SampleableExt` provides a proxy representation
`proxy` that can be printed and shrunken as well
as interpreted (using `interp`) as an object of the right type. If you
are using it in the first way, this proxy type will simply be the type
itself and the `interp` function `id`.
### `Shrinkable
Given an example `x : α`, `Shrinkable α` gives us a way to shrink it
and suggest simpler examples.
## Shrinking
Shrinking happens when `SlimCheck` find a counter-example to a
property.  It is likely that the example will be more complicated than
necessary so `SlimCheck` proceeds to shrink it as much as
possible. Although equally valid, a smaller counter-example is easier
for a user to understand and use.
The `Shrinkable` class, , has a `shrink` function so that we can use
specialized knowledge while shrinking a value. It is not responsible
for the whole shrinking process however. It only has to take one step
in the shrinking process. `SlimCheck` will repeatedly call `shrink`
until no more steps can be taken. Because `shrink` guarantees that the
size of the candidates it produces is strictly smaller than the
argument, we know that `SlimCheck` is guaranteed to terminate.
## Tags
random testing
## References
  * https://hackage.haskell.org/package/QuickCheck
-/

namespace SlimCheck

open Random

/-- Given an example `x : α`, `Shrinkable α` gives us a way to shrink it
and suggest simpler examples. -/
class Shrinkable (α : Type u) extends WellFoundedRelation α where
  shrink : (x : α) → List α := λ _ => []

/-- `SampleableExt` can be used in two ways. The first (and most common)
is to simply generate values of a type directly using the `Gen` monad,
if this is what you want to do then `SampleableExt.mkSelfContained` is
the way to go.
Furthermore it makes it possible to express generators for types that
do not lend themselves to introspection, such as `ℕ → ℕ`.
If we test a quantification over functions the
counter-examples cannot be shrunken or printed meaningfully.
For that purpose, `SampleableExt` provides a proxy representation
`proxy` that can be printed and shrunken as well
as interpreted (using `interp`) as an object of the right type. -/
class SampleableExt (α : Sort u) where
  proxy : Type v
  [proxyRepr : Repr proxy]
  [shrink : Shrinkable proxy]
  sample : Gen proxy
  interp : proxy → α

attribute [instance] SampleableExt.proxyRepr
attribute [instance] SampleableExt.shrink

namespace SampleableExt

/-- Use to generate instance whose purpose is to simply generate values
of a type directly using the `Gen` monad -/
def mkSelfContained [Repr α] [Shrinkable α] (sample : Gen α) : SampleableExt α where
  proxy := α
  proxyRepr := inferInstance
  shrink := inferInstance
  sample := sample
  interp := id

/-- First samples a proxy value and interprets it. Especially useful if
the proxy and target type are the same. -/
def interpSample (α : Type u) [SampleableExt α] : Gen α := SampleableExt.interp <$> SampleableExt.sample

end SampleableExt

section Shrinkers

/-- `Nat.shrink' n` creates a list of smaller natural numbers by
successively dividing `n` by 2 . For example, `Nat.shrink 5 = [2, 1, 0]`. -/
partial def Nat.shrink (n : Nat) : List Nat :=
  if 0 < n then
    let m := n / 2
    let rest := shrink m
    m :: rest
  else
    []

instance Nat.shrinkable : Shrinkable Nat where
  shrink := Nat.shrink

/-- `Fin.shrink` works like `Nat.shrink` but instead operates on `Fin`. -/
partial def Fin.shrink {n : Nat} (m : Fin n.succ) : List (Fin n.succ) :=
  if 0 < m then
    let m := m / 2
    let rest := shrink m
    m :: rest
  else
    []

instance Fin.shrinkable {n : Nat} : Shrinkable (Fin n.succ) where
  shrink := Fin.shrink

local instance Int_sizeOfAbs : SizeOf Int := ⟨Int.natAbs⟩

/-- `Int.shrinkable` operates like `Nat.shrinkable` but also includes the negative variants. -/
instance Int.shrinkable : Shrinkable Int where
  shrink n :=
    Nat.shrink n.natAbs |>.map fun x => - Int.ofNat x

instance Bool.shrinkable : Shrinkable Bool := {}
instance Char.shrinkable : Shrinkable Char := {}

instance Prod.shrinkable [shrA : Shrinkable α] [shrB : Shrinkable β] : Shrinkable (Prod α β) where
  shrink := λ (fst,snd) =>
    let shrink1 := shrA.shrink fst |>.map fun x => (x, snd)
    let shrink2 := shrB.shrink snd |>.map fun x => (fst, x)
    shrink1 ++ shrink2

end Shrinkers

section Samplers

open Gen SampleableExt

instance Nat.sampleableExt : SampleableExt Nat :=
  mkSelfContained (do choose Nat 0 (← getSize))

instance Fin.sampleableExt {n : Nat} : SampleableExt (Fin (n.succ)) :=
  mkSelfContained (do choose (Fin n.succ) (Fin.ofNat 0) (Fin.ofNat (← getSize)))

instance Int.sampleableExt : SampleableExt Int :=
  mkSelfContained (do choose Int (-(← getSize)) (← getSize))

instance Bool.sampleableExt : SampleableExt Bool :=
  mkSelfContained $ chooseAny Bool

/-- This can be specialized into customized `SampleableExt Char` instances.
The resulting instance has `1 / length` chances of making an unrestricted choice of characters
and it otherwise chooses a character from `chars` with uniform probabilities.  -/
def Char.sampleable (length : Nat) (chars : List Char) : SampleableExt Char :=
    mkSelfContained do
      let x ←  choose Nat 0 length
      if x == 0 then
        let n ←  interpSample Nat
        pure $ Char.ofNat n
      else
        elements chars

instance Char.sampleableDefault : SampleableExt Char :=
  Char.sampleable 3 " 0123abcABC:,;`\\/".toList

instance Prod.sampleableExt {α β : Type u} [SampleableExt α] [SampleableExt β] :
    SampleableExt (α × β) where
  proxy := Prod (proxy α) (proxy β)
  proxyRepr := inferInstance
  shrink := inferInstance
  sample := prodOf sample sample
  interp := Prod.map interp interp

instance Prop.sampleableExt : SampleableExt Prop where
  proxy := Bool
  proxyRepr := inferInstance
  sample := interpSample Bool
  shrink := inferInstance
  interp := Coe.coe

end Samplers

/-- An annotation for values that should never get shrinked. -/
def NoShrink (α : Type u) := α

namespace NoShrink

def mk (x : α) : NoShrink α := x
def get (x : NoShrink α) : α := x

instance inhabited [inst : Inhabited α] : Inhabited (NoShrink α) := inst
instance repr [inst : Repr α] : Repr (NoShrink α) := inst

instance shrinkable : Shrinkable (NoShrink α) where
  shrink := λ _ => []

instance sampleableExt [SampleableExt α] [Repr α] : SampleableExt (NoShrink α) :=
  SampleableExt.mkSelfContained $ (NoShrink.mk ∘ SampleableExt.interp) <$> SampleableExt.sample

end NoShrink

end SlimCheck


import topology.path_connected
import topology.urysohns_lemma
import topology.uniform_space.separation
import linear_algebra.affine_space.independent
import analysis.normed_space.finite_dimension
import topology.algebra.order.floor
import topology.shrinking_lemma
import topology.metric_space.emetric_paracompact
import analysis.convex.normed

noncomputable theory

open set function filter topological_space
open_locale unit_interval topology uniformity filter classical

section to_specific_limits

lemma tendsto_self_div_add_at_top_nhds_1_nat :
  tendsto (λ n : ℕ, (n : ℝ) / (n + 1)) at_top (𝓝 1) :=
begin
  suffices : tendsto (λ n : ℕ, (1 : ℝ) - 1 / (n + 1)) at_top (𝓝 (1 - 0)),
  { have hn : ∀ n : ℕ, (n : ℝ) + 1 ≠ 0 := λ n, n.cast_add_one_pos.ne',
    simp_rw [one_sub_div (hn _), add_sub_cancel, sub_zero] at this, exact this },
  exact tendsto_const_nhds.sub tendsto_one_div_add_at_top_nhds_0_nat
end

end to_specific_limits

section maps
open function set
variables {α β : Type*} [topological_space α] [topological_space β] {f : α → β} {g : β → α}

lemma function.left_inverse.mem_preimage_iff (hfg : left_inverse g f) {s : set α} {x : α} :
  f x ∈ g ⁻¹' s ↔ x ∈ s :=
by rw [set.mem_preimage, hfg x]

-- to set.basic
lemma function.left_inverse.image_eq (hfg : left_inverse g f) (s : set α) :
  f '' s = range f ∩ g ⁻¹' s :=
-- begin
--   simp_rw [set.ext_iff, mem_image, mem_inter_iff, mem_range, and_comm (_ ∈ _),
--     @eq_comm _ (f _), ← exists_and_distrib_right, ← exists_prop],
--   simp only [hfg _, iff_true_intro iff.rfl, implies_true_iff, hfg.mem_preimage_iff] {contextual := tt},
-- end
begin
  ext x, split,
  { rintro ⟨x, hx, rfl⟩, exact ⟨mem_range_self x, hfg.mem_preimage_iff.mpr hx⟩ },
  { rintro ⟨⟨x, rfl⟩, b⟩, exact mem_image_of_mem f (hfg.mem_preimage_iff.mp b) }
end

lemma function.left_inverse.is_open_map {f : α → β} {g : β → α} (hfg : left_inverse g f)
  (hf : is_open (range f)) (hg : continuous_on g (range f)) : is_open_map f :=
by { intros U hU, rw [hfg.image_eq], exact hg.preimage_open_of_open hf hU }

end maps

section -- to separation

lemma filter.eventually.closed_neighborhood {α} [topological_space α] [normal_space α] {C : set α}
  {P : α → Prop} (hP : ∀ᶠ x in 𝓝ˢ C, P x) (hC : is_closed C) :
    ∃ C' ∈ 𝓝ˢ C, is_closed C' ∧ ∀ᶠ x in 𝓝ˢ C', P x :=
begin
  obtain ⟨O, hO, hCO, hPO⟩ := mem_nhds_set_iff_exists.mp hP,
  obtain ⟨U, hU, hCU, hUO⟩ := normal_exists_closure_subset hC hO hCO,
  exact ⟨closure U, mem_of_superset (hU.mem_nhds_set.mpr hCU) subset_closure, is_closed_closure,
    eventually_of_mem (hO.mem_nhds_set.mpr hUO) hPO⟩
end

end

section

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

lemma continuous_at.eventually {f : α → β} {a₀ : α} (hf : continuous_at f a₀)
  (P : β → Prop) (hP : is_open {b | P b}) (ha₀ : P (f a₀)) :
  ∀ᶠ a in 𝓝 a₀, P (f a) :=
hf (is_open_iff_mem_nhds.mp hP _ ha₀)

lemma continuous_at.eventually' {f : α → β} {a₀ : α} (hf : continuous_at f a₀)
  (P : β → Prop)(hP : ∀ᶠ y in 𝓝 (f a₀), P y) :
  ∀ᶠ a in 𝓝 a₀, P (f a) :=
begin
  rw [continuous_at, tendsto_iff_comap] at hf,
  exact eventually.filter_mono hf (hP.comap f)
end

lemma continuous.eventually {f : α → β} {a₀ : α} (hf : continuous f) (P : β → Prop)
  (hP : is_open {b | P b}) (ha₀ : P (f a₀)) :
  ∀ᶠ a in 𝓝 a₀, P (f a) :=
hf.continuous_at.eventually P hP ha₀

-- (unused)
lemma nhds_set_prod_le {s : set α} {t : set β} : 𝓝ˢ (s ×ˢ t) ≤ (𝓝ˢ s).prod (𝓝ˢ t) :=
begin
  intros w hw,
  obtain ⟨u, hu, v, hv, huv⟩ := mem_prod_iff.mp hw,
  rw [← subset_interior_iff_mem_nhds_set] at hu hv ⊢,
  refine (prod_mono hu hv).trans _,
  rw [← interior_prod_eq],
  exact interior_mono huv
end

instance [sigma_compact_space α] [sigma_compact_space β] : sigma_compact_space (α × β) :=
begin
  refine ⟨⟨λ n, compact_covering α n.unpair.1 ×ˢ compact_covering β n.unpair.2, λ n,
    (is_compact_compact_covering _ _).prod (is_compact_compact_covering _ _), _⟩⟩,
  simp_rw [set.Union_unpair (λ n m, compact_covering α n ×ˢ compact_covering β m), ← prod_Union,
    ← Union_prod_const, Union_compact_covering, univ_prod_univ]
end

end

section

lemma support_norm {α E : Type*} [normed_add_comm_group E] (f : α → E) : support (λ a, ‖f a‖) = support f :=
function.support_comp_eq norm (λ x, norm_eq_zero) f

@[to_additive]
lemma has_compact_mul_support_of_subset {α β : Type*} [topological_space α] [t2_space α]
  [has_one β] {f : α → β} {K : set α} (hK : is_compact K) (hf : mul_support f ⊆ K) :
  has_compact_mul_support f :=
is_compact_of_is_closed_subset hK (is_closed_mul_tsupport f) (closure_minimal hf hK.is_closed)

lemma periodic_const {α β : Type*} [has_add α] {a : α} {b : β} : periodic (λ x, b) a :=
λ x, rfl

lemma real.ball_zero_eq (r : ℝ) : metric.ball (0 : ℝ) r = Ioo (-r) r :=
by { ext x, simp [real.norm_eq_abs, abs_lt] }

end

section
/-! ## The standard ℤ action on ℝ is properly discontinuous

TODO: use that in to_mathlib.topology.periodic?
-/
instance : has_vadd ℤ ℝ := ⟨λ n x, (n : ℝ) + x⟩

instance : properly_discontinuous_vadd ℤ ℝ :=
⟨begin
  intros K L hK hL,
  rcases eq_empty_or_nonempty K with rfl | hK' ; rcases eq_empty_or_nonempty L with rfl | hL' ;
  try { simp },
  have hSK:= (hK.is_lub_Sup hK').1,
  have hIK:= (hK.is_glb_Inf hK').1,
  have hSL:= (hL.is_lub_Sup hL').1,
  have hIL:= (hL.is_glb_Inf hL').1,
  apply (finite_Icc ⌈Inf L - Sup K⌉ ⌊Sup L - Inf K⌋).subset,
  rintros n (hn : has_vadd.vadd n '' K ∩ L ≠ ∅),
  rcases nonempty_iff_ne_empty.mpr hn with ⟨l, ⟨k, hk, rfl⟩, hnk : (n : ℝ) + k ∈ L⟩,
  split,
  { rw int.ceil_le,
    linarith [hIL hnk, hSK hk] },
  { rw int.le_floor,
    linarith [hSL hnk, hIK hk] }
end⟩

end

section fract

open int
/- properties of the (dis)continuity of `int.fract` on `ℝ`.
To be PRed to topology.algebra.floor_ring
-/

lemma floor_eq_self_iff {x : ℝ} : (⌊x⌋ : ℝ) = x ↔ ∃ n : ℤ, x = n :=
begin
  split,
  { intro h,
    exact ⟨⌊x⌋, h.symm⟩ },
  { rintros ⟨n, rfl⟩,
    rw floor_int_cast }
end

lemma fract_eq_zero_iff {x : ℝ} : fract x = 0 ↔ ∃ n : ℤ, x = n :=
by rw [fract, sub_eq_zero, eq_comm, floor_eq_self_iff]

lemma fract_ne_zero_iff {x : ℝ} : fract x ≠ 0 ↔ ∀ n : ℤ, x ≠ n :=
by rw [← not_exists, not_iff_not, fract_eq_zero_iff]

lemma Ioo_floor_mem_nhds {x : ℝ} (h : ∀ (n : ℤ), x ≠ n) : Ioo (⌊x⌋ : ℝ) (⌊x⌋ + 1 : ℝ) ∈ 𝓝 x :=
Ioo_mem_nhds ((floor_le x).eq_or_lt.elim (λ H, (h ⌊x⌋ H.symm).elim) id) (lt_floor_add_one x)

lemma loc_constant_floor {x : ℝ} (h : ∀ (n : ℤ), x ≠ n) : floor =ᶠ[𝓝 x] (λ x', ⌊x⌋) :=
begin
  filter_upwards [Ioo_floor_mem_nhds h],
  intros y hy,
  rw floor_eq_on_Ico,
  exact mem_Ico_of_Ioo hy
end

lemma fract_eventually_eq {x : ℝ}
  (h : fract x ≠ 0) : fract =ᶠ[𝓝 x] (λ x', x' - floor x) :=
begin
  rw fract_ne_zero_iff at h,
  exact eventually_eq.rfl.sub ((loc_constant_floor h).fun_comp _)
end

-- todo: make iff
lemma continuous_at_fract {x : ℝ} (h : fract x ≠ 0) : continuous_at fract x :=
(continuous_at_id.sub continuous_at_const).congr (fract_eventually_eq h).symm

lemma Ioo_inter_Iio {α : Type*} [linear_order α] {a b c : α} : Ioo a b ∩ Iio c = Ioo a (min b c) :=
by { ext, simp [and_assoc] }

lemma fract_lt {x y : ℝ} {n : ℤ} (h1 : (n : ℝ) ≤ x) (h2 : x < n + y) : fract x < y :=
begin
  cases le_total y 1 with hy hy,
  { rw [← fract_sub_int x n, fract_eq_self.mpr],
    linarith,
    split; linarith },
  { exact (fract_lt_one x).trans_le hy }
end

lemma one_sub_lt_fract {x y : ℝ} {n : ℤ} (hy : y ≤ 1) (h1 : (n : ℝ) - y < x) (h2 : x < n) :
  1 - y < fract x :=
begin
  have I₁ : 1 - y < x - (n-1), by linarith,
  have I₂ : x - (n-1) < 1, by linarith,
  norm_cast at I₁ I₂,
  rw [← fract_sub_int x (n-1), fract_eq_self.mpr],
  exact I₁,
  split; linarith,
end

lemma is_open.preimage_fract' {s : set ℝ} (hs : is_open s)
  (h2s : 0 ∈ s → s ∈ 𝓝[<] (1 : ℝ)) : is_open (fract ⁻¹' s) :=
begin
  rw is_open_iff_mem_nhds,
  rintros x (hx : fract x ∈ s),
  rcases eq_or_ne (fract x)  0 with hx' | hx',
  { have H : (0 : ℝ) ∈ s, by rwa hx' at hx,
    specialize h2s H,
    rcases fract_eq_zero_iff.mp hx' with ⟨n, rfl⟩, clear hx hx',
    have s_mem_0 := hs.mem_nhds H,
    rcases (nhds_basis_zero_abs_sub_lt ℝ).mem_iff.mp s_mem_0 with ⟨δ, δ_pos, hδ⟩,
    rcases (nhds_within_has_basis (nhds_basis_Ioo_pos (1 : ℝ)) _).mem_iff.mp h2s with ⟨ε, ε_pos, hε⟩,
    rw [Ioo_inter_Iio, min_eq_right (le_add_of_nonneg_right ε_pos.le)] at hε,
    set ε' := min ε (1/2),
    have ε'_pos : 0 < ε',
      from lt_min ε_pos (by norm_num : (0 : ℝ) < 1/2),
    have hε' : Ioo (1 - ε') 1 ⊆ s,
    { apply subset.trans _ hε,
      apply Ioo_subset_Ioo_left,
      linarith [min_le_left ε (1/2)] },
    have mem : Ioo ((n : ℝ)-ε') (n+δ) ∈ 𝓝 (n : ℝ),
    { apply Ioo_mem_nhds ; linarith },
    apply mem_of_superset mem,
    rintros x ⟨hx, hx'⟩,
    cases le_or_gt (n : ℝ) x with hx'' hx'',
    { apply hδ,
      rw [mem_set_of_eq, abs_eq_self.mpr (fract_nonneg x)],
      exact fract_lt hx'' hx' },
    { apply hε',
      split,
      { refine one_sub_lt_fract (by linarith [min_le_right ε (1/2)]) (by linarith) hx'' },
      { exact fract_lt_one x }, } },
  { rw fract_ne_zero_iff at hx',
    have H : Ico (⌊x⌋ : ℝ) (⌊x⌋ + 1) ∈ 𝓝 x,
      from mem_of_superset (Ioo_floor_mem_nhds hx') Ioo_subset_Ico_self,
    exact (continuous_on_fract ⌊x⌋).continuous_at H (hs.mem_nhds hx) },
end

lemma is_open.preimage_fract {s : set ℝ} (hs : is_open s)
  (h2s : (0 : ℝ) ∈ s → (1 : ℝ) ∈ s) : is_open (fract ⁻¹' s) :=
hs.preimage_fract' $ λ h, nhds_within_le_nhds $ hs.mem_nhds (h2s h)

-- is `sᶜ ∉ 𝓝[<] (1 : ℝ)` equivalent to something like `cluster_pt (𝓝[Iio (1 : ℝ) ∩ s] (1 : ℝ)` ?
lemma is_closed.preimage_fract {s : set ℝ} (hs : is_closed s)
  (h2s : sᶜ ∉ 𝓝[<] (1 : ℝ) → (0 : ℝ) ∈ s) : is_closed (fract ⁻¹' s) :=
is_open_compl_iff.mp $ hs.is_open_compl.preimage_fract' $ λ h, by_contra $ λ h', h $ h2s h'

lemma fract_preimage_mem_nhds {s : set ℝ} {x : ℝ} (h1 : s ∈ 𝓝 (fract x))
  (h2 : fract x = 0 → s ∈ 𝓝 (1 : ℝ)) : fract ⁻¹' s ∈ 𝓝 x :=
begin
  by_cases hx : fract x = 0,
  { obtain ⟨u, hus, hu, hxu⟩ := mem_nhds_iff.mp h1,
    obtain ⟨v, hvs, hv, h1v⟩ := mem_nhds_iff.mp (h2 hx),
    rw [mem_nhds_iff],
    refine ⟨fract ⁻¹' (u ∪ v), preimage_mono (union_subset hus hvs),
      (hu.union hv).preimage_fract (λ _, subset_union_right _ _ h1v), subset_union_left _ _ hxu⟩ },
  { exact (continuous_at_fract hx).preimage_mem_nhds h1 }
end

end fract

section
-- to normed_space
variables {E F : Type*} [normed_add_comm_group E] [normed_add_comm_group F]
variables [normed_space ℝ E] [normed_space ℝ F]

lemma dist_smul_add_one_sub_smul_le {r : ℝ} {x y : E} (h : r ∈ unit_interval) :
  dist (r • x + (1 - r) • y) x ≤ dist y x :=
calc
  dist (r • x + (1 - r) • y) x = ‖1 - r‖ * ‖x - y‖ : by simp_rw [dist_eq_norm', ← norm_smul,
    sub_smul, one_smul, smul_sub, ← sub_sub, ← sub_add, sub_right_comm]
  ... = (1 - r) * dist y x :
    by rw [real.norm_eq_abs, abs_eq_self.mpr (sub_nonneg.mpr h.2), dist_eq_norm']
  ... ≤ (1 - 0) * dist y x : mul_le_mul_of_nonneg_right (sub_le_sub_left h.1 _) dist_nonneg
  ... = dist y x : by rw [sub_zero, one_mul]

end

section -- to ???

-- needs classical
variables {α β γ δ ι : Type*} [topological_space α] [topological_space β] {x : α}

lemma is_open_slice_of_is_open_over {Ω : set (α × β)} {x₀ : α}
  (hΩ_op : ∃ U ∈ 𝓝 x₀, is_open (Ω ∩ prod.fst ⁻¹' U)) : is_open (prod.mk x₀ ⁻¹' Ω) :=
begin
  rcases hΩ_op with ⟨U, hU, hU_op⟩, convert hU_op.preimage (continuous.prod.mk x₀) using 1,
  simp_rw [preimage_inter, preimage_preimage, preimage_const, mem_of_mem_nhds hU, if_pos,
    inter_univ]
end

end

section proj_I

variables {α β : Type*} [linear_ordered_semiring α] {x c : α}

/-- If `α` is a `linear_ordered_semiring`, then `proj_I : α → α` projection of `α` onto the unit
interval `[0, 1]`. -/
def proj_I : α → α := λ x, proj_Icc (0 : α) 1 zero_le_one x

lemma proj_I_def : proj_I x = max 0 (min 1 x) := rfl

lemma proj_Icc_eq_proj_I : (proj_Icc (0 : α) 1 zero_le_one x : α) = proj_I x := rfl

lemma proj_I_of_le_zero (hx : x ≤ 0) : proj_I x = 0 :=
congr_arg coe $ proj_Icc_of_le_left _ hx

@[simp] lemma proj_I_zero : proj_I (0 : α) = 0 :=
congr_arg coe $ proj_Icc_left _

lemma proj_I_of_one_le (hx : 1 ≤ x) : proj_I x = 1 :=
congr_arg coe $ proj_Icc_of_right_le _ hx

@[simp] lemma proj_I_one : proj_I (1 : α) = 1 :=
congr_arg coe $ proj_Icc_right _

@[simp] lemma proj_I_eq_zero [nontrivial α] : proj_I x = 0 ↔ x ≤ 0 :=
by { rw [← proj_Icc_eq_left (zero_lt_one' α), subtype.ext_iff], refl }

@[simp] lemma proj_I_eq_one : proj_I x = 1 ↔ 1 ≤ x :=
by { rw [← proj_Icc_eq_right (zero_lt_one' α), subtype.ext_iff], refl }

lemma proj_I_mem_Icc : proj_I x ∈ Icc (0 : α) 1 :=
(proj_Icc (0 : α) 1 zero_le_one x).prop

lemma proj_I_eq_self : proj_I x = x ↔ x ∈ Icc (0 : α) 1 :=
⟨λ h, h ▸ proj_I_mem_Icc, λ h, congr_arg coe $ proj_Icc_of_mem _ h⟩

@[simp] lemma proj_I_proj_I : proj_I (proj_I x) = proj_I x :=
proj_I_eq_self.mpr proj_I_mem_Icc

@[simp] lemma proj_Icc_proj_I :
  proj_Icc (0 : α) 1 zero_le_one (proj_I x) = proj_Icc 0 1 zero_le_one x :=
proj_Icc_of_mem _ proj_I_mem_Icc

@[simp] lemma range_proj_I : range (proj_I) = Icc 0 1 :=
by rw [proj_I, range_comp, range_proj_Icc, image_univ, subtype.range_coe]

lemma monotone_proj_I : monotone (proj_I : α → α) :=
monotone_proj_Icc _

lemma strict_mono_on_proj_I : strict_mono_on proj_I (Icc (0 : α) 1) :=
strict_mono_on_proj_Icc _

lemma proj_I_le_max : proj_I x ≤ max 0 x :=
max_le_max le_rfl $ min_le_right _ _

lemma min_le_proj_I : min 1 x ≤ proj_I x :=
le_max_right _ _

lemma proj_I_le_iff : proj_I x ≤ c ↔ 0 ≤ c ∧ (1 ≤ c ∨ x ≤ c) :=
by simp_rw [proj_I_def, max_le_iff, min_le_iff]

@[simp] lemma proj_I_eq_min : proj_I x = min 1 x ↔ 0 ≤ x :=
by simp_rw [proj_I_def, max_eq_right_iff, le_min_iff, zero_le_one, true_and]

lemma min_proj_I (h2 : 0 ≤ c) : min c (proj_I x) = proj_I (min c x) :=
by { cases le_total c x with h3 h3; simp [h2, h3, proj_I_le_iff, proj_I_eq_min.mpr],
     simp [proj_I_eq_min.mpr, h2.trans h3, min_left_comm c, h3] }

lemma continuous_proj_I [topological_space α] [order_topology α] :
  continuous (proj_I : α → α) :=
continuous_proj_Icc.subtype_coe

lemma proj_I_mapsto {α : Type*} [linear_ordered_semiring α] {s : set α} (h0s : (0 : α) ∈ s)
  (h1s : (1 : α) ∈ s) : maps_to proj_I s s :=
λ x hx, (le_total 1 x).elim (λ h2x, by rwa [proj_I_eq_one.mpr h2x]) $
  λ h2x, (le_total 0 x).elim (λ h3x, by rwa [proj_I_eq_self.mpr ⟨h3x, h2x⟩]) $
  λ h3x, by rwa [proj_I_eq_zero.mpr h3x]
-- about path.truncate

lemma truncate_proj_I_right {X : Type*} [topological_space X] {a b : X}
  (γ : path a b) (t₀ t₁ : ℝ) (s : I) :
  γ.truncate t₀ (proj_I t₁) s = γ.truncate t₀ t₁ s :=
begin
  simp_rw [path.truncate, path.coe_mk, path.extend, Icc_extend, function.comp],
  rw [min_proj_I (s.prop.1.trans $ le_max_left _ _), proj_Icc_proj_I],
end

end proj_I

section

open encodable option
variables {α β γ : Type*} [topological_space α] [topological_space β]
-- can we restate this nicely?

/-- Given a locally finite sequence of sets indexed by an encodable type, we can naturally reindex
  this sequence to get a sequence indexed by `ℕ` (by adding some `∅` values).
  This new sequence is still locally finite. -/
lemma decode₂_locally_finite {ι} [encodable ι] {s : ι → set α}
  (hs : locally_finite s) : locally_finite (λ i, (s <$> decode₂ ι i).get_or_else ∅) :=
begin
  intro x,
  obtain ⟨U, hxU, hU⟩ := hs x,
  refine ⟨U, hxU, _⟩,
  have : encode ⁻¹' {i : ℕ | ((s <$> decode₂ ι i).get_or_else ∅ ∩ U).nonempty} =
     {i : ι | (s i ∩ U).nonempty},
  { simp_rw [preimage_set_of_eq, decode₂_encode, map_some, get_or_else_some] },
  rw [← this] at hU,
  refine finite_of_finite_preimage hU _,
  intros n hn,
  rw [← decode₂_ne_none_iff],
  intro h,
  simp_rw [mem_set_of_eq, h, map_none, get_or_else_none, empty_inter] at hn,
  exact (not_nonempty_empty hn).elim
end

open topological_space

variables {X : Type*} [emetric_space X] [locally_compact_space X] [second_countable_topology X]

lemma exists_locally_finite_subcover_of_locally {C : set X} (hC : is_closed C) {P : set X → Prop}
  (hP : antitone P) (h0 : P ∅) (hX : ∀ x ∈ C, ∃ V ∈ 𝓝 (x : X), P V) :
∃ (K : ℕ → set X) (W : ℕ → set X), (∀ n, is_compact (K n)) ∧ (∀ n, is_open (W n)) ∧
  (∀ n, P (W n)) ∧ (∀ n, K n ⊆ W n) ∧ locally_finite W ∧ C ⊆ ⋃ n, K n :=
begin
  choose V' hV' hPV' using set_coe.forall'.mp hX,
  choose V hV hVV' hcV using λ x : C, locally_compact_space.local_compact_nhds ↑x (V' x) (hV' x),
  simp_rw [← mem_interior_iff_mem_nhds] at hV,
  have : C ⊆ (⋃ x : C, interior (V x)) :=
  λ x hx, by { rw [mem_Union], exact ⟨⟨x, hx⟩, hV _⟩ },
  obtain ⟨s, hs, hsW₂⟩ := is_open_Union_countable (λ x, interior (V x)) (λ x, is_open_interior),
  rw [← hsW₂, bUnion_eq_Union] at this, clear hsW₂,
  obtain ⟨W, hW, hUW, hlW, hWV⟩ :=
    precise_refinement_set hC (λ x : s, interior (V x)) (λ x, is_open_interior) this,
  obtain ⟨K, hCK, hK, hKW⟩ :=
    exists_subset_Union_closed_subset hC (λ x : s, hW x) (λ x _, hlW.point_finite x) hUW,
  haveI : encodable s := hs.to_encodable,
  let K' : ℕ → set X := λ n, (K <$> (decode₂ s n)).get_or_else ∅,
  let W' : ℕ → set X := λ n, (W <$> (decode₂ s n)).get_or_else ∅,
  refine ⟨K', W', _, _, _, _, _, _⟩,
  { intro n, cases h : decode₂ s n with i,
    { simp_rw [K', h, map_none, get_or_else_none, is_compact_empty] },
    { simp_rw [K', h, map_some, get_or_else_some],
      exact is_compact_of_is_closed_subset (hcV i) (hK i)
        ((hKW i).trans $ (hWV i).trans interior_subset) }},
  { intro n, cases h : decode₂ s n,
    { simp_rw [W', h, map_none, get_or_else_none, is_open_empty] },
    { simp_rw [W', h, map_some, get_or_else_some, hW] }},
  { intro n, cases h : decode₂ s n with i,
    { simp_rw [W', h, map_none, get_or_else_none, h0] },
    { simp_rw [W', h, map_some, get_or_else_some], refine hP _ (hPV' i),
      refine (hWV i).trans (interior_subset.trans $ hVV' i) }},
  { intro n, cases h : decode₂ s n,
    { simp_rw [K', W', h, map_none] },
    { simp_rw [K', W', h, map_some, get_or_else_some, hKW] }},
  { exact decode₂_locally_finite hlW },
  { intros x hx, obtain ⟨i, hi⟩ := mem_Union.mp (hCK hx),
    refine mem_Union.mpr ⟨encode i, _⟩,
    simp_rw [K', decode₂_encode, map_some, get_or_else_some, hi] }
end

end

section -- to subset_properties

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

lemma is_compact.eventually_forall_mem {x₀ : α} {K : set β} (hK : is_compact K)
  {f : α → β → γ} (hf : continuous ↿f) {U : set γ} (hU : ∀ y ∈ K, U ∈ 𝓝 (f x₀ y)) :
  ∀ᶠ x in 𝓝 x₀, ∀ y ∈ K, f x y ∈ U :=
hK.eventually_forall_of_forall_eventually $ λ y hy, (hf.tendsto _).eventually $
  show U ∈ 𝓝 (↿f (x₀, y)), from hU y hy

end

section -- to separation

variables {α : Type*} [topological_space α]

/-
needs
import linear_algebra.affine_space.independent
import analysis.normed_space.finite_dimension
-/
lemma is_open_affine_independent (𝕜 E : Type*) {ι : Type*} [nontrivially_normed_field 𝕜]
  [normed_add_comm_group E] [normed_space 𝕜 E] [complete_space 𝕜] [finite ι] :
  is_open {p : ι → E | affine_independent 𝕜 p} :=
begin
  classical,
  cases is_empty_or_nonempty ι, { resetI, exact is_open_discrete _ },
  obtain ⟨i₀⟩ := h,
  simp_rw [affine_independent_iff_linear_independent_vsub 𝕜 _ i₀],
  let ι' := {x // x ≠ i₀},
  casesI nonempty_fintype ι,
  haveI : fintype ι' := subtype.fintype _,
  convert_to
    is_open ((λ (p : ι → E) (i : ι'), p i -ᵥ p i₀) ⁻¹' {p : ι' → E | linear_independent 𝕜 p}),
  refine is_open.preimage _ is_open_set_of_linear_independent,
  refine continuous_pi (λ i', continuous.vsub (continuous_apply i') $ continuous_apply i₀),
end

end

section convex

variables {E : Type*} [add_comm_group E] [module ℝ E] [topological_space E]
  [topological_add_group E] [has_continuous_smul ℝ E] {s : set E}

lemma convex.is_preconnected' (hs : convex ℝ s) : is_preconnected s :=
by { rcases s.eq_empty_or_nonempty with rfl|h, exact is_preconnected_empty,
     exact (hs.is_path_connected h).is_connected.is_preconnected }

end convex

section

open metric

lemma continuous.inf_dist {α β : Type*} [topological_space α] [pseudo_metric_space β] {s : set β}
  {f : α → β} (hf : continuous f) : continuous (λ x, inf_dist (f x) s) :=
(continuous_inf_dist_pt _).comp hf

end

section normed_space
open metric

variables {E : Type*} [normed_add_comm_group E] [normed_space ℝ E]

lemma is_preconnected_ball (x : E) (r : ℝ) : is_preconnected (ball x r) :=
(convex_ball x r).is_preconnected'

lemma is_connected_ball {x : E} {r : ℝ} : is_connected (ball x r) ↔ 0 < r :=
begin
  rw [← @nonempty_ball _ _ x],
  refine ⟨λ h, h.nonempty, λ h, ((convex_ball x r).is_path_connected $ h).is_connected⟩
end

-- todo: make metric.mem_nhds_iff protected

end normed_space

section connected_component_in

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

lemma continuous.image_connected_component_in_subset {f : α → β} {s : set α} {x : α}
  (hf : continuous f) (hx : x ∈ s) :
  f '' connected_component_in s x ⊆ connected_component_in (f '' s) (f x) :=
(is_preconnected_connected_component_in.image _ hf.continuous_on).subset_connected_component_in
  (mem_image_of_mem _ $ mem_connected_component_in hx)
  (image_subset _ $ connected_component_in_subset _ _)

lemma homeomorph.image_connected_component_in (f : α ≃ₜ β) {s : set α} {x : α} (hx : x ∈ s) :
  f '' connected_component_in s x = connected_component_in (f '' s) (f x) :=
begin
  refine (f.continuous.image_connected_component_in_subset hx).antisymm _,
  have := f.symm.continuous.image_connected_component_in_subset (mem_image_of_mem _ hx),
  rwa [image_subset_iff, f.preimage_symm, f.image_symm, f.preimage_image, f.symm_apply_apply]
    at this,
end

end connected_component_in

namespace topological_space -- to topology.bases
lemma cover_nat_nhds_within {α} [topological_space α] [second_countable_topology α] {f : α → set α}
  {s : set α} (hf : ∀ x ∈ s, f x ∈ 𝓝[s] x) (hs : s.nonempty) :
  ∃ x : ℕ → α, range x ⊆ s ∧ s ⊆ ⋃ n, f (x n) :=
begin
  obtain ⟨t, hts, ht, hsf⟩ := topological_space.countable_cover_nhds_within hf,
  have hnt : t.nonempty,
  { by_contra,
    rw [not_nonempty_iff_eq_empty] at h,
    rw [h, bUnion_empty, subset_empty_iff] at hsf,
    exact hs.ne_empty hsf },
  obtain ⟨x, rfl⟩ := ht.exists_eq_range hnt,
  rw [bUnion_range] at hsf,
  exact ⟨x, hts, hsf⟩
end

/-- A version of `topological_space.cover_nat_nhds_within` where `f` is only defined on `s`. -/
lemma cover_nat_nhds_within' {α} [topological_space α] [second_countable_topology α] {s : set α}
  {f : ∀ x ∈ s, set α} (hf : ∀ x (hx : x ∈ s), f x hx ∈ 𝓝[s] x) (hs : s.nonempty) :
  ∃ (x : ℕ → α) (hx : range x ⊆ s), s ⊆ ⋃ n, f (x n) (range_subset_iff.mp hx n) :=
begin
  let g := λ x, if hx : x ∈ s then f x hx else ∅,
  have hg : ∀ x ∈ s, g x ∈ 𝓝[s] x, { intros x hx, simp_rw [g, dif_pos hx], exact hf x hx },
  obtain ⟨x, hx, h⟩ := topological_space.cover_nat_nhds_within hg hs,
  simp_rw [g, dif_pos (range_subset_iff.mp hx _)] at h,
  refine ⟨x, hx, h⟩,
end

end topological_space

namespace set
namespace subtype
open _root_.subtype
variables {α : Type*}

lemma image_coe_eq_iff_eq_univ {s : set α} {t : set s} : (coe : s → α) '' t = s ↔ t = univ :=
by { convert coe_injective.image_injective.eq_iff, rw coe_image_univ }

@[simp] lemma preimage_coe_eq_univ {s t : set α} : (coe : s → α) ⁻¹' t = univ ↔ s ⊆ t :=
by rw [← inter_eq_right_iff_subset, ← image_preimage_coe, image_coe_eq_iff_eq_univ]

end subtype
end set
open set

section paracompact_space

-- a version of `precise_refinement_set` for open `s`.
/-- When `s : set X` is open and paracompact, we can find a precise refinement on `s`. Note that
 in this case we only get the locally finiteness condition on `s`, which is weaker than the local
 finiteness condition on all of `X` (the collection might not be locally finite on the boundary of
 `s`). -/
theorem precise_refinement_set' {ι X : Type*} [topological_space X] {s : set X}
  [paracompact_space s] (hs : is_open s)
  (u : ι → set X) (uo : ∀ i, is_open (u i)) (us : s ⊆ ⋃ i, u i) :
  ∃ (v : ι → set X), (∀ i, is_open (v i)) ∧ (s ⊆ ⋃ i, v i) ∧
  locally_finite (λ i, (coe : s → X) ⁻¹' v i) ∧ (∀ i, v i ⊆ s) ∧ (∀ i, v i ⊆ u i) :=
begin
  obtain ⟨v, vo, vs, vl, vu⟩ := precise_refinement (λ i, (coe : s → X) ⁻¹' u i)
    (λ i, (uo i).preimage continuous_subtype_coe)
    (by rwa [← preimage_Union, subtype.preimage_coe_eq_univ]),
  refine ⟨λ i, coe '' v i, λ i, hs.is_open_map_subtype_coe _ (vo i),
    by rw [← image_Union, vs, subtype.coe_image_univ],
    by simp_rw [preimage_image_eq _ subtype.coe_injective, vl],
    λ i, subtype.coe_image_subset _ _,
    by { intro i, rw [image_subset_iff], exact vu i }⟩,
end

lemma point_finite_of_locally_finite_coe_preimage {ι X : Type*} [topological_space X] {s : set X}
  {f : ι → set X} (hf : locally_finite (λ i, (coe : s → X) ⁻¹' f i)) (hfs : ∀ i, f i ⊆ s) {x : X} :
  {i | x ∈ f i}.finite :=
begin
  by_cases hx : x ∈ s,
  { exact hf.point_finite ⟨x, hx⟩ },
  { have : ∀ i, x ∉ f i := λ i hxf, hx (hfs i hxf),
    simp only [this, set_of_false, finite_empty] }
end

end paracompact_space

section shrinking_lemma

variables {ι X : Type*} [topological_space X]
variables {u : ι → set X} {s : set X} [normal_space s]

-- this lemma is currently formulated a little weirdly, since we have a collection of open sets
-- as the input and a collection of closed/compact sets as output.
-- Perhaps we can formulate it so that the input is a collection of compact sets whose interiors
-- cover s.
lemma exists_subset_Union_interior_of_is_open (hs : is_open s) (uo : ∀ i, is_open (u i))
  (uc : ∀ i, is_compact (closure (u i)))
  (us : ∀ i, closure (u i) ⊆ s)
  (uf : ∀ x ∈ s, {i | x ∈ u i}.finite) (uU : s ⊆ ⋃ i, u i) :
  ∃ v : ι → set X, s ⊆ (⋃ i, interior (v i)) ∧ (∀ i, is_compact (v i)) ∧ ∀ i, v i ⊆ u i :=
begin
  obtain ⟨v, vU, vo, hv⟩ := exists_Union_eq_closure_subset
    (λ i, (uo i).preimage (continuous_subtype_coe : continuous (coe : s → X)))
    (λ x, uf x x.prop)
    (by simp_rw [← preimage_Union, subtype.preimage_coe_eq_univ, uU]),
  have : ∀ i, is_compact (closure ((coe : _ → X) '' (v i))),
  { intro i, refine is_compact_of_is_closed_subset (uc i) is_closed_closure _,
    apply closure_mono, rw image_subset_iff, refine subset_closure.trans (hv i) },
  refine ⟨λ i, closure (coe '' (v i)), _, this, _⟩,
  { refine subset.trans _ (Union_mono $
      λ i, interior_maximal subset_closure (hs.is_open_map_subtype_coe _ (vo i))),
    simp_rw [← image_Union, vU, subtype.coe_image_univ] },
  { intro i,
    have : coe '' v i ⊆ u i,
    { rintro _ ⟨x, hx, rfl⟩, exact hv i (subset_closure hx) },
    intros x hx,
    have hxs : x ∈ s := us i (closure_mono this hx),
    have : (⟨x, hxs⟩ : s) ∈ closure (v i),
    { rw embedding_subtype_coe.closure_eq_preimage_closure_image (v i), exact hx },
    exact hv i this }
end

end shrinking_lemma

open_locale filter

lemma filter.eventually_eq.slice {α β γ : Type*} [topological_space α] [topological_space β]
  {f g : α × β → γ} {a : α} {b : β} (h : f =ᶠ[𝓝 (a, b)] g) : (λ y, f (a, y)) =ᶠ[𝓝 b] (λ y, g(a, y)) :=
begin
  rw nhds_prod_eq at h,
  have : (pure a : filter α) ×ᶠ 𝓝 b ≤ (𝓝 a) ×ᶠ (𝓝 b),
  exact prod_mono (by apply pure_le_nhds) le_rfl,
  have := h.filter_mono this,
  rw [pure_prod] at this,
  exact eventually_map.mp this
end

lemma exists_compact_between' {α : Type*} [topological_space α] [locally_compact_space α]
  {K U : set α} (hK : is_compact K) (hU : is_open U) (h_KU : K ⊆ U) :
  ∃ L, is_compact L ∧ L ∈ 𝓝ˢ K ∧ L ⊆ U :=
let ⟨L, L_cpct, L_in, LU⟩ := exists_compact_between hK hU h_KU in
  ⟨L, L_cpct, subset_interior_iff_mem_nhds_set.mp L_in, LU⟩

section -- to topology/basic

@[simp] lemma finset.is_closed_bUnion {α} [topological_space α]
  {ι : Type*} (s : finset ι) (f : ι → set α) (hf : ∀ i ∈ s, is_closed (f i)) :
  is_closed (⋃ i ∈ s, f i) :=
is_closed_bUnion s.finite_to_set hf

end


import data.pfun
import logic.relation
import logic.function.iterate
import tactic.apply_fun
import tactic.linear_combination

namespace option

@[simp] lemma map_eq_some'_symm {α β : Type*} (f : α → β) (x : option α) (y : β) :
  some y = x.map f ↔ ∃ a, x = some a ∧ f a = y := by { cases x; simp, exact comm, }

@[simp] lemma map_eq_none'_symm {α β : Type*} (f : α → β) (x : option α) :
  none = x.map f ↔ none = x := by cases x; simp

end option

namespace part

@[simp] lemma restrict_dom {α : Type*} (x : part α) {p : Prop} (hp : p → x.dom) :
  (x.restrict p hp).dom ↔ p := by refl

end part

namespace pfun

@[simp] lemma res_dom {α β : Type*} (f : α →. β) {p : set α} (hp : p ⊆ f.dom) :
  (f.restrict hp).dom = p := by simp [pfun.dom, pfun.restrict]

/-- Restrict with the intersection of a set -/
def res_inter {α β : Type*} (f : α →. β) (p : set α) : α →. β :=
f.restrict (set.inter_subset_right p f.dom)

@[simp] lemma mem_res_inter {α β : Type*} {f : α →. β} {p : set α} {x y} :
  y ∈ f.res_inter p x ↔ x ∈ p ∧ y ∈ f x :=
by { simp [res_inter], tauto, }

@[simp] lemma res_inter_res_inter {α β : Type*} {f : α →. β} {p₁ p₂ : set α} :
  (f.res_inter p₁).res_inter p₂ = f.res_inter (p₁ ∩ p₂) :=
by { ext, simp, tauto, }

@[simp] lemma res_inter_dom {α β : Type*} (f : α →. β) (p : set α) :
  (f.res_inter p).dom = p ∩ f.dom := by simp [res_inter]

@[simp] lemma res_inter_dom' {α β : Type*} {f : α →. β} {p : set α} :
  ∀ {x}, (f.res_inter p x).dom ↔ x ∈ p ∧ (f x).dom :=
set.ext_iff.mp (res_inter_dom f p)

@[simp] lemma coe_res_inter {α β : Type*} (f : α → β) (p : set α) :
  (f : α →. β).res_inter p = pfun.res f p :=
by { ext x, simp [mem_res], tauto, }

end pfun

open relation
open nat (iterate)
open function (update iterate_succ iterate_succ_apply iterate_succ'
  iterate_succ_apply' iterate_zero_apply)

namespace part_eval

/-- Run a state transition function `σ → option σ` "to completion". The return value is the last
state returned before a `none` result. If the state transition function always returns `some` or any step of the
transition function diverges, then the computation diverges, returning `part.none`. -/
def eval {σ} (f : σ →. option σ) : σ → part σ :=
pfun.fix (λ s, (f s).map (λ x, x.elim (sum.inl s) sum.inr))

/-- The reflexive transitive closure of a state transition function. `reaches f a b` means
there is a finite sequence of steps `f a = some a₁`, `f a₁ = some a₂`, ... such that `aₙ = b`.
This relation permits zero steps of the state transition function. -/
def reaches {σ} (f : σ →. option σ) : σ → σ → Prop :=
refl_trans_gen (λ a b, some b ∈ f a)

@[refl] lemma reaches.refl {σ} (f : σ →. option σ) (x : σ) :
  reaches f x x := refl_trans_gen.refl

@[trans] lemma reaches.trans {σ} {f : σ →. option σ} {x y z : σ} :
  reaches f x y → reaches f y z → reaches f x z := refl_trans_gen.trans

lemma reaches_fwd {σ} {f : σ →. option σ} {x y : σ} :
  some y ∈ f x → reaches f x y := @refl_trans_gen.single _ _ x y

theorem reaches_mono {σ} {f : σ →. option σ} (S : set σ) (hS : S ⊆ f.dom) {x y} (hf : reaches (f.restrict hS) x y) :
  reaches f x y :=
by { apply refl_trans_gen.mono _ hf, simp, }

theorem reaches_mono' {σ} {f g : σ →. option σ} (hfg : ∀ ⦃x y⦄, y ∈ f x → y ∈ g x) {x y} (hf : reaches f x y) :
  reaches g x y :=
by { apply refl_trans_gen.mono _ hf, intros _ _, apply hfg, }

theorem invariant_of_reaches {σ} {f : σ →. option σ} (S : set σ) (hS : ∀ ⦃x y⦄, x ∈ S → some y ∈ f x → y ∈ S)
  {x y} (hx : x ∈ S) (hf : reaches f x y) : y ∈ S :=
by { induction hf with x' y' hfx' hfy' ih, { exact hx, }, exact hS ih hfy', }

theorem reaches_of_invariant {σ} {f : σ →. option σ} (S : set σ) (hS : ∀ ⦃x y⦄, x ∈ S → some y ∈ f x → y ∈ S)
  {x y} (hx : x ∈ S) (hf : reaches f x y) : reaches (f.res_inter S) x y :=
begin
  induction hf using relation.refl_trans_gen.head_induction_on with x' y' hx' hy' ih, { refl, },
  apply reaches.trans (reaches_fwd _) (ih _),
  { simp only [pfun.mem_res_inter], exact ⟨hx, hx'⟩, }, { exact hS hx hx', }
end

/-- The transitive closure of a state transition function. `reaches₁ f a b` means there is a
nonempty finite sequence of steps `f a = some a₁`, `f a₁ = some a₂`, ... such that `aₙ = b`.
This relation does not permit zero steps of the state transition function. -/
def reaches₁ {σ} (f : σ →. option σ) : σ → σ → Prop :=
trans_gen (λ a b, some b ∈ f a)

theorem reaches_iff_eq_or_reaches₁ {σ} {f : σ →. option σ} {a b} :
  reaches f a b ↔ b = a ∨ reaches₁ f a b := refl_trans_gen_iff_eq_or_trans_gen

theorem reaches₁_head'_iff {σ} {f : σ →. option σ} {a b} :
  reaches₁ f a b ↔ ∃ c : σ, some c ∈ f a ∧ reaches f c b := trans_gen.head'_iff

theorem reaches₁_eq {σ} {f : σ →. option σ} {a b c}
  (h : f a = f b) : reaches₁ f a c ↔ reaches₁ f b c :=
trans_gen.head'_iff.trans (trans_gen.head'_iff.trans $ by rw h).symm

theorem reaches_total {σ} {f : σ →. option σ}
  {a b c} (hab : reaches f a b) (hac : reaches f a c) :
  reaches f b c ∨ reaches f c b :=
refl_trans_gen.total_of_right_unique (λ x y z hx hy, option.some_injective _ (part.mem_unique hx hy)) hab hac

theorem reaches₁_fwd {σ} {f : σ →. option σ}
  {a b c} (h₁ : reaches₁ f a c) (h₂ : some b ∈ f a) : reaches f b c :=
begin
  rw reaches₁_head'_iff at h₁, rcases h₁ with ⟨b', ⟨h₂', H⟩⟩,
  cases part.mem_unique h₂ h₂', exact H,
end

theorem reaches₁_single {σ} {f : σ →. option σ}
  {a b} : some b ∈ f a → reaches₁ f a b :=
@trans_gen.single σ _ a b

/-- A variation on `reaches`. `reaches₀ f a b` holds if whenever `reaches₁ f b c` then
`reaches₁ f a c`. This is a weaker property than `reaches` and is useful for replacing states with
equivalent states without taking a step. -/
def reaches₀ {σ} (f : σ →. option σ) (a b : σ) : Prop :=
∀ c, reaches₁ f b c → reaches₁ f a c

theorem reaches₀.trans {σ} {f : σ →. option σ} {a b c : σ}
  (h₁ : reaches₀ f a b) (h₂ : reaches₀ f b c) : reaches₀ f a c
| d h₃ := h₁ _ (h₂ _ h₃)

@[refl] theorem reaches₀.refl {σ} {f : σ →. option σ} (a : σ) : reaches₀ f a a
| b h := h

theorem reaches₀.single {σ} {f : σ →. option σ} {a b : σ}
  (h : some b ∈ f a) : reaches₀ f a b
| c h₂ := h₂.head h

theorem reaches₀.head {σ} {f : σ →. option σ} {a b c : σ}
  (h : some b ∈ f a) (h₂ : reaches₀ f b c) : reaches₀ f a c :=
(reaches₀.single h).trans h₂

theorem reaches₀.tail {σ} {f : σ →. option σ} {a b c : σ}
  (h₁ : reaches₀ f a b) (h : some c ∈ f b) : reaches₀ f a c :=
h₁.trans (reaches₀.single h)

theorem reaches₀_eq {σ} {f : σ →. option σ} {a b}
  (e : f a = f b) : reaches₀ f a b
| d h := (reaches₁_eq e).2 h

theorem reaches₁.to₀ {σ} {f : σ →. option σ} {a b : σ}
  (h : reaches₁ f a b) : reaches₀ f a b
| c h₂ := h.trans h₂

theorem reaches.to₀ {σ} {f : σ →. option σ} {a b : σ}
  (h : reaches f a b) : reaches₀ f a b
| c h₂ := h₂.trans_right h

theorem reaches₀.tail' {σ} {f : σ →. option σ} {a b c : σ}
  (h : reaches₀ f a b) (h₂ : some c ∈ f b) : reaches₁ f a c :=
h _ (trans_gen.single h₂)

/-- (co-)Induction principle for `eval`. If a property `C` holds of any point `a` evaluating to `b`
which is either terminal (meaning `a = b`) or where the next point also satisfies `C`, then it
holds of any point where `eval f a` evaluates to `b`. This formalizes the notion that if
`eval f a` evaluates to `b` then it reaches terminal state `b` in finitely many steps. -/
@[elab_as_eliminator] def eval_induction {σ}
  {f : σ →. option σ} {b : σ} {C : σ → Sort*} {a : σ} (h : b ∈ eval f a)
  (H : ∀ a, b ∈ eval f a →
    (∀ a', f a = part.some (some a') → C a') → C a) : C a :=
by { dsimp only [eval] at *, exact pfun.fix_induction h (λ _ b ih, H _ b (λ _ ha, ih _ (by simp [ha]))) }

theorem mem_eval {σ} {f : σ →. option σ} {a b} :
  b ∈ eval f a ↔ reaches f a b ∧ f b = part.some none :=
begin
  split,
  { intro h,
    apply eval_induction h, clear h a, intros a hb ih,
    have : (f a).dom := by simpa using pfun.dom_of_mem_fix hb,
    rw part.dom_iff_mem at this,
    rcases this with ⟨a'|a', ha'⟩, rw ← part.eq_some_iff at ha',
    { rw [eval] at hb, cases (part.mem_unique hb (pfun.fix_stop a _) : b = a),
      { exact ⟨by refl, ha'⟩, }, { simp [ha'], } },
    specialize ih a' (by rwa part.eq_some_iff),
    exact ⟨(reaches_fwd ha').trans ih.1, ih.2⟩, },
  { rintro ⟨h₁, h₂⟩,
    induction h₁ using relation.refl_trans_gen.head_induction_on with a' b' ha' hb ih,
    { apply pfun.fix_stop, simp [h₂], },
    rw [eval, pfun.fix_fwd _ b'], { exact ih, },
    rw ← part.eq_some_iff at ha', simp [ha'], }
end

lemma eval_mono {σ} {f g : σ →. option σ} (hfg : ∀ ⦃x y⦄, y ∈ f x → y ∈ g x) {x y} (h : y ∈ eval f x) :
  y ∈ eval g x :=
by { rw [mem_eval, part.eq_some_iff] at *, exact ⟨reaches_mono' hfg h.1, hfg h.2⟩, }

lemma eval_eq_of_invariant {σ} (f : σ →. option σ) (S : set σ) (hS : ∀ ⦃x y⦄, x ∈ S → some y ∈ f x → y ∈ S) {x} (hx : x ∈ S) :
  eval f x = eval (f.res_inter S) x :=
by { ext y, split, swap, { intro h, apply eval_mono _ h, simp, }, simp [mem_eval, part.eq_some_iff],
     intros H₁ H₂, exact ⟨reaches_of_invariant S hS hx H₁, invariant_of_reaches _ hS hx H₁, H₂⟩, }

@[simp] lemma eval_next_iter_eq_none {σ} (f : σ →. option σ) (a : σ) (h : (eval f a).dom) :
  f ((eval f a).get h) = part.some none :=
by { have := part.get_mem h, rw mem_eval at this, exact this.2, }

theorem eval_maximal₁ {σ} {f : σ →. option σ} {a b : σ}
  (h : b ∈ eval f a) (c) : ¬ reaches₁ f b c | bc :=
let ⟨ab, b0⟩ := mem_eval.1 h, ⟨b', h', _⟩ := trans_gen.head'_iff.1 bc in
by { rw b0 at h', simpa using h', }

theorem eval_maximal {σ} {f : σ →. option σ} {a b}
  (h : b ∈ eval f a) {c} : reaches f b c ↔ c = b :=
let ⟨ab, b0⟩ := mem_eval.1 h in
refl_trans_gen_iff_eq $ λ b' h',
by { rw b0 at h', simpa using h', }

theorem reaches_eval {σ} {f : σ →. option σ} {a b}
  (ab : reaches f a b) : eval f a = eval f b :=
part.ext $ λ c,
 ⟨λ h, let ⟨ac, c0⟩ := mem_eval.1 h in
    mem_eval.2 ⟨(or_iff_left_of_imp $ by exact
      λ cb, (eval_maximal h).1 cb ▸ refl_trans_gen.refl).1
      (reaches_total ab ac), c0⟩,
  λ h, let ⟨bc, c0⟩ := mem_eval.1 h in mem_eval.2 ⟨ab.trans bc, c0⟩,⟩

/-- Given a relation `tr : σ₁ → σ₂ → Prop` between state spaces, and state transition functions
`f₁ : σ₁ → option σ₁` and `f₂ : σ₂ → option σ₂`, `respects f₁ f₂ tr` means that if `tr a₁ a₂` holds
initially and `f₁` takes a step to `a₂` then `f₂` will take one or more steps before reaching a
state `b₂` satisfying `tr a₂ b₂`, and if `f₁ a₁` terminates then `f₂ a₂` also terminates.
Such a relation `tr` is also known as a refinement. -/
-- def respects {σ₁ σ₂}
--   (f₁ : σ₁ →. option σ₁) (f₂ : σ₂ →. option σ₂) (tr : σ₁ → σ₂ → Prop) :=
-- ∀ ⦃a₁ a₂⦄, tr a₁ a₂ → (match f₁ a₁ with
--   | part.none := f₂ a₂ = part.none
--   | part.some (some b₁) := ∃ b₂, tr b₁ b₂ ∧ reaches₁ f₂ a₂ b₂
--   | part.some none := f₂ a₂ = none
--   end : Prop)

structure respects {σ₁ σ₂} (f₁ : σ₁ →. option σ₁) (f₂ : σ₂ →. option σ₂) (tr : σ₁ → σ₂ → Prop) : Prop :=
(dom_of_dom : ∀ ⦃a₁ a₂⦄, tr a₁ a₂ → (f₂ a₂).dom → (f₁ a₁).dom)
(some_of_some : ∀ ⦃a₁ a₂ b₁⦄, tr a₁ a₂ → some b₁ ∈ (f₁ a₁) → ∃ b₂, tr b₁ b₂ ∧ reaches₁ f₂ a₂ b₂)
(none_of_none : ∀ ⦃a₁ a₂⦄, tr a₁ a₂ → none ∈ (f₁ a₁) → none ∈ (f₂ a₂))

variables {σ₁ σ₂ : Type*} {f₁ : σ₁ →. option σ₁} {f₂ : σ₂ →. option σ₂} {tr : σ₁ → σ₂ → Prop}

lemma respects.exists_some {a₁ a₂ b₁} (H : respects f₁ f₂ tr) (aa : tr a₁ a₂) (hb₁ : some b₁ ∈ f₁ a₁) :
  ∃ b₂, some b₂ ∈ f₂ a₂ :=
by { obtain ⟨b₂, ⟨_, hb₂⟩⟩ := H.some_of_some aa hb₁, rw reaches₁_head'_iff at hb₂, tauto, }

lemma respects.dom_iff_domm {a₁ a₂} (H : respects f₁ f₂ tr) (aa : tr a₁ a₂) :
  (f₁ a₁).dom ↔ (f₂ a₂).dom :=
begin
  refine ⟨λ h, _, H.dom_of_dom aa⟩,
  rw [part.dom_iff_mem] at h ⊢, cases h with b₁ hb,
  cases b₁,
  { use none, exact H.none_of_none aa hb, },
  { obtain ⟨b₂, hb₂⟩ := H.exists_some aa hb, exact ⟨_, hb₂⟩, }
end

lemma respects.none_iff_none {a₁ a₂} (H : respects f₁ f₂ tr) (aa : tr a₁ a₂) :
  none ∈ f₁ a₁ ↔ none ∈ f₂ a₂ :=
begin
  refine ⟨H.none_of_none aa, λ h, _⟩,
  obtain ⟨x, hx⟩ : ∃ x, x ∈ f₁ a₁, { rw [← part.dom_iff_mem, H.dom_iff_domm aa, part.dom_iff_mem], exact ⟨_, h⟩, },
  cases x, { exact hx, },
  obtain ⟨_, hb⟩ := H.exists_some aa hx, cases part.mem_unique h hb,
end

lemma respects.some_iff_some {a₁ a₂} (H : respects f₁ f₂ tr) (aa : tr a₁ a₂) :
  (∃ b₁, some b₁ ∈ f₁ a₁) ↔ (∃ b₂, some b₂ ∈ f₂ a₂) :=
begin
  refine ⟨λ ⟨b₁, hb₁⟩, H.exists_some aa hb₁, _⟩,
  rintro ⟨b₂, hb₂⟩,
  obtain ⟨x, hx⟩ : ∃ x, x ∈ f₁ a₁, { rw [← part.dom_iff_mem, H.dom_iff_domm aa, part.dom_iff_mem], exact ⟨_, hb₂⟩, },
  cases x, { rw H.none_iff_none aa at hx, cases part.mem_unique hb₂ hx, },
  exact ⟨_, hx⟩,
end

theorem tr_reaches₁
  (H : respects f₁ f₂ tr) {a₁ a₂} (aa : tr a₁ a₂) {b₁} (ab : reaches₁ f₁ a₁ b₁) :
  ∃ b₂, tr b₁ b₂ ∧ reaches₁ f₂ a₂ b₂ :=
begin
  induction ab with c₁ ac c₁ d₁ ac cd IH,
  { exact H.some_of_some aa ac, },
  { rcases IH with ⟨c₂, cc, ac₂⟩,
    obtain ⟨b₂, ⟨h₁, h₂⟩⟩ := H.some_of_some cc cd,
    exact ⟨b₂, ⟨h₁, ac₂.trans h₂⟩⟩, }
end

theorem tr_reaches {σ₁ σ₂ f₁ f₂} {tr : σ₁ → σ₂ → Prop}
  (H : respects f₁ f₂ tr) {a₁ a₂} (aa : tr a₁ a₂) {b₁} (ab : reaches f₁ a₁ b₁) :
  ∃ b₂, tr b₁ b₂ ∧ reaches f₂ a₂ b₂ :=
begin
  rcases refl_trans_gen_iff_eq_or_trans_gen.1 ab with rfl | ab,
  { exact ⟨_, aa, refl_trans_gen.refl⟩ },
  { exact let ⟨b₂, bb, h⟩ := tr_reaches₁ H aa ab in
    ⟨b₂, bb, h.to_refl⟩ }
end

theorem tr_reaches_rev {σ₁ σ₂ f₁ f₂} {tr : σ₁ → σ₂ → Prop}
  (H : respects f₁ f₂ tr) {a₁ a₂} (aa : tr a₁ a₂) {b₂} (ab : reaches f₂ a₂ b₂) :
  ∃ c₁ c₂, reaches f₂ b₂ c₂ ∧ tr c₁ c₂ ∧ reaches f₁ a₁ c₁ :=
begin
  induction ab with a₂' a₂'' ha₂ ha₂' ih,
  { refine ⟨a₁, a₂, _, aa, _⟩; refl, },
  rcases ih with ⟨c₁, c₂, c₂h, trh, c₁h⟩,
  by_cases H : c₂ = a₂',
  { subst H, clear c₂h,
    obtain ⟨c₁', hc₁'⟩ := (H.some_iff_some trh).mpr ⟨_, ha₂'⟩,
    obtain ⟨c₂', hc₂, hc₂'⟩ := H.some_of_some trh hc₁',
    exact ⟨c₁', c₂', reaches₁_fwd hc₂' ha₂', hc₂, c₁h.trans (reaches_fwd hc₁')⟩, },
  refine ⟨c₁, c₂, _, trh, c₁h⟩,
  simp_rw [reaches_iff_eq_or_reaches₁, H, false_or] at c₂h,
  apply reaches₁_fwd c₂h ha₂',
end

theorem tr_eval {σ₁ σ₂ f₁ f₂} {tr : σ₁ → σ₂ → Prop}
  (H : respects f₁ f₂ tr) {a₁ b₁ a₂} (aa : tr a₁ a₂)
  (ab : b₁ ∈ eval f₁ a₁) : ∃ b₂, tr b₁ b₂ ∧ b₂ ∈ eval f₂ a₂ :=
begin
  cases mem_eval.1 ab with ab b0,
  rcases tr_reaches H aa ab with ⟨b₂, bb, ab⟩,
  refine ⟨_, bb, mem_eval.2 ⟨ab, _⟩⟩,
  rw part.eq_some_iff at ⊢ b0, rwa ← H.none_iff_none bb,
end

theorem tr_eval_rev {σ₁ σ₂ f₁ f₂} {tr : σ₁ → σ₂ → Prop}
  (H : respects f₁ f₂ tr) {a₁ b₂ a₂} (aa : tr a₁ a₂)
  (ab : b₂ ∈ eval f₂ a₂) : ∃ b₁, tr b₁ b₂ ∧ b₁ ∈ eval f₁ a₁ :=
begin
  cases mem_eval.1 ab with ab b0,
  rcases tr_reaches_rev H aa ab with ⟨c₁, c₂, bc, cc, ac⟩,
  cases (refl_trans_gen_iff_eq _).1 bc,
  swap, { intros _ h, rw b0 at h, simpa using h, },
  refine ⟨_, cc, mem_eval.2 ⟨ac, _⟩⟩,
  rw part.eq_some_iff at b0 ⊢, rwa H.none_iff_none cc,
end

theorem tr_eval_dom {σ₁ σ₂ f₁ f₂} {tr : σ₁ → σ₂ → Prop}
  (H : respects f₁ f₂ tr) {a₁ a₂} (aa : tr a₁ a₂) :
  (eval f₂ a₂).dom ↔ (eval f₁ a₁).dom :=
⟨λ h, let ⟨b₂, tr, h, _⟩ := tr_eval_rev H aa ⟨h, rfl⟩ in h,
 λ h, let ⟨b₂, tr, h, _⟩ := tr_eval H aa ⟨h, rfl⟩ in h⟩

/-- A simpler version of `respects` when the state transition relation `tr` is a function. -/
structure frespects {σ₁ σ₂} (f₁ : σ₁ →. option σ₁) (f₂ : σ₂ →. option σ₂) (tr : σ₁ → σ₂) : Prop :=
(dom_of_dom : ∀ ⦃a : σ₁⦄, (f₂ (tr a)).dom → (f₁ a).dom)
(some_of_some : ∀ ⦃a b : σ₁⦄, some b ∈ f₁ a → reaches₁ f₂ (tr a) (tr b))
(none_of_none : ∀ ⦃a⦄, none ∈ f₁ a → none ∈ f₂ (tr a))

/-- An even simpler version where both take only one step each time -/
structure fcommutes {σ₁ σ₂} (f₁ : σ₁ →. option σ₁) (f₂ : σ₂ →. option σ₂) (tr : σ₁ → σ₂) : Prop :=
(dom_of_dom : ∀ ⦃a : σ₁⦄, (f₂ (tr a)).dom → (f₁ a).dom)
(some_of_some : ∀ ⦃a b : σ₁⦄, some b ∈ f₁ a → some (tr b) ∈ f₂ (tr a))
(none_of_none : ∀ ⦃a⦄, none ∈ f₁ a → none ∈ f₂ (tr a))

variable {ftr : σ₁ → σ₂}
theorem fcommutes.to_frespects (H : fcommutes f₁ f₂ ftr) : frespects f₁ f₂ ftr :=
{ dom_of_dom := H.dom_of_dom,
  some_of_some := λ a b h, by { apply reaches₁_single, exact H.some_of_some h, },
  none_of_none := H.none_of_none }

lemma fcommutes.some_of_some' (H : fcommutes f₁ f₂ ftr) {a b : σ₁}
  (h : some (ftr b) ∈ f₂ (ftr a)) :
  ∃ y, ftr y = ftr b ∧ some y ∈ f₁ a :=
begin
  obtain ⟨y, hy⟩ := part.dom_iff_mem.mp (H.dom_of_dom (part.dom_iff_mem.mpr ⟨_, h⟩)),
  cases y, { cases part.mem_unique h (H.none_of_none hy), },
  refine ⟨_, _, hy⟩, exact (option.some.inj (part.mem_unique h (H.some_of_some hy))).symm,
end

theorem fun_respects : respects f₁ f₂ (λ a b, ftr a = b) ↔ frespects f₁ f₂ ftr :=
begin
  split,
  { intro H,
    refine ⟨λ a, H.dom_of_dom rfl, λ a b hab, _, λ a ha, H.none_of_none rfl ha⟩,
    simpa using H.some_of_some rfl hab, },
  { intro H,
    refine ⟨_, _, _⟩, { rintro a₁ a₂ rfl h, exact H.dom_of_dom h, },
    { rintro a₁ a₂ b₁ rfl h, exact ⟨_, rfl, H.some_of_some h⟩, },
    rintro a₁ a₂ rfl h, exact H.none_of_none h, }
end

lemma frespects.dom_iff_dom (H : frespects f₁ f₂ ftr) ⦃x : σ₁⦄ :
  (f₁ x).dom ↔ (f₂ (ftr x)).dom :=
respects.dom_iff_domm (fun_respects.mpr H) rfl
-- f(g(x)) = x
-- S(g(a)) -->  a'
-- g(a)  --> a
-- theorem fcommutes.symm (H : fcommutes f₁ f₂ ftr) {ftr_inv : σ₂ → σ₁} (hinv : function.right_inverse ftr_inv ftr) :
--   fcommutes f₂ f₁ ftr_inv :=
-- { dom_of_dom := λ a, by simp [(fun_respects.mpr H.to_frespects).dom_iff_domm (hinv a)],
--   some_of_some := λ a b h,
-- begin
--   rw [← hinv b, ← hinv a] at h, have := H.some_of_some' h,
-- end,
--   none_of_none := _ }

theorem frespects.eval_eq (H : frespects f₁ f₂ ftr)
  (a₁ : σ₁) : eval f₂ (ftr a₁) = (eval f₁ a₁).map ftr :=
begin
  rw ← fun_respects at H,
  apply part.ext', { exact tr_eval_dom H rfl, },
  intros h₂ h₁, simp at h₁,
  have := tr_eval H rfl (part.get_mem h₁),
  simp at this ⊢, rwa part.get_eq_iff_mem,
end

theorem frespects.of_eval (H : frespects f₁ f₂ ftr)
  {a b : σ₁} (h : b ∈ eval f₁ a) : (ftr b) ∈ eval f₂ (ftr a) :=
by { rw H.eval_eq, exact part.mem_map ftr h, }

theorem frespects.none_iff_none (H : frespects f₁ f₂ ftr) (a : σ₁) :
  none ∈ f₁ a ↔ none ∈ f₂ (ftr a) :=
by { rw ← fun_respects at H, rw H.none_iff_none rfl, }

theorem frespects.eval_dom (H : frespects f₁ f₂ ftr) (x : σ₁) :
  (eval f₂ (ftr x)).dom ↔ (eval f₁ x).dom := by simp [H.eval_eq]

theorem frespects.eval_get_eq (H : frespects f₁ f₂ ftr) (a : σ₁) :
  ∀ h, ftr ((eval f₁ a).get h) = (eval f₂ (ftr a)).get (by rwa H.eval_dom) :=
by { intros, simp [H.eval_eq], refl, }

section track_with
variables {σ α : Type*} (f : σ →. option σ) (t : σ →. ℕ)

def with_time : ℕ × σ →. option (ℕ × σ) :=
λ tx, (f tx.2).bind (λ r₁, (t tx.2).bind (λ r₂ : ℕ, part.some (r₁.map $ λ r₁', (tx.1 + r₂, r₁'))))

theorem with_time_respects {f : σ →. option σ} {t : σ →. ℕ} (ht : ∀ x, (t x).dom ↔ (f x).dom) : frespects (with_time f t) f prod.snd :=
{ dom_of_dom := λ a, by simp [with_time, ht],
  some_of_some := λ ⟨a₁, x₁⟩ ⟨a₂, x₂⟩ h, by { apply reaches₁_single, simp [with_time] at h, rcases h with ⟨_, h, _, _, rfl, rfl⟩, exact h, },
  none_of_none := λ ⟨a, x⟩, by { simp [with_time], exact λ h _ _, h, } }

theorem with_time_respects_self (n : ℕ) : frespects (with_time f t) (with_time f t) (prod.map (+n) id) :=
{ dom_of_dom := λ a, by { simp [with_time], exact and.intro, },
  some_of_some := λ ⟨a₁, x₁⟩ ⟨a₂, x₂⟩ h,
begin
  apply reaches₁_single,
  simp [with_time] at h ⊢,
  rcases h with ⟨a, ha, t, ht₁, rfl, rfl⟩,
  exact ⟨_, ha, t, ht₁, rfl, by ac_refl⟩,
end,
  none_of_none := by { simp [with_time], tauto, } }

def time_iter : σ →. ℕ :=
λ s, (eval (with_time f t) (0, s)).bind (λ r, (t r.2).map (+r.1))

variables {f t}
lemma with_time_restrict (S : set σ) :
  with_time (f.res_inter S) t = (with_time f t).res_inter (prod.snd⁻¹' S) :=
by { ext, simp [with_time], tauto, }

theorem time_iter_dom_iff (ht : ∀ x, (t x).dom ↔ (f x).dom) {x} :
  (time_iter f t x).dom ↔ (eval f x).dom :=
begin
  simp [time_iter],
  have := with_time_respects ht,
  simp_rw [← this.eval_dom (0, x), this.eval_get_eq (0, x), ht, eval_next_iter_eq_none f x], simp,
end

lemma with_time_mono {g : σ →. option σ} (hfg : ∀ ⦃x y⦄, y ∈ f x → y ∈ g x) :
  ∀ ⦃x y⦄, y ∈ with_time f t x → y ∈ with_time g t x := by { simp [with_time], tauto, }

lemma time_iter_mono {g : σ →. option σ} (hfg : ∀ ⦃x y⦄, y ∈ f x → y ∈ g x) {x y} (hx : y ∈ time_iter f t x) :
  y ∈ time_iter g t x :=
begin
  simp [time_iter] at hx ⊢, rcases hx with ⟨a, b, h₁, ⟨a', h₂, rfl⟩⟩,
  refine ⟨a, b, _, ⟨a', h₂, rfl⟩⟩, apply eval_mono (with_time_mono hfg) h₁,
end

theorem time_iter_eq_iff (ht : ∀ x, (t x).dom ↔ (f x).dom) (x : σ) (n : ℕ) :
  n ∈ time_iter f t x ↔ ∃ t' b, reaches (with_time f t) (0, x) (t', b) ∧ none ∈ f b ∧ n ∈ (+t') <$> (t b) :=
begin
  simp [time_iter, mem_eval],
  apply exists₂_congr, intros a b,
  conv_lhs { rw and_assoc, }, apply and_congr, { refl, },
  apply and_congr, { rw ← (with_time_respects ht).none_iff_none (a, b), exact part.eq_some_iff, }, { refl, },
end

lemma time_iter_invariant {g : σ →. option σ} (S : set σ) (hS : ∀ ⦃x y⦄, x ∈ S → some y ∈ g x → y ∈ S) {x} (hx : x ∈ S) :
  time_iter g t x = time_iter (g.res_inter S) t x :=
begin
  simp only [time_iter], rw eval_eq_of_invariant (with_time g t) (prod.snd⁻¹' S), { simp [with_time_restrict], },
  { rintros ⟨x₁, x₂⟩ ⟨y₁, y₂⟩, simp [with_time], rintros hx₂ x' hx' t' ht' rfl rfl, exact hS hx₂ hx', },
  simpa,
end

theorem time_iter_eq_iff_of_eval (ht : ∀ x, (t x).dom ↔ (f x).dom) {x n b} (hb : b ∈ eval f x) :
  n ∈ time_iter f t x ↔ ∃ t', reaches (with_time f t) (0, x) (t', b) ∧ none ∈ f b ∧ n ∈ (+t') <$> (t b) :=
begin
  suffices : ∀ {t' b'}, reaches (with_time f t) (0, x) (t', b') → none ∈ f b' → b = b',
  { rw time_iter_eq_iff ht, apply exists_congr, intro n, split, { rintro ⟨b, h₁, h₂, h₃⟩, cases this h₁ h₂, tauto, }, intro, use b, tauto, },
  intros n b' h₁ h₂, rw [← (with_time_respects ht).none_iff_none (n, b'), ← part.eq_some_iff] at h₂,
  exact part.mem_unique hb ((with_time_respects ht).of_eval (mem_eval.mpr ⟨h₁, h₂⟩)),
end

@[simp] lemma one_def : (1 : part ℕ) = part.some 1 := rfl

lemma time_eval_const_respects (ht : ∀ ⦃x⦄, (f x).dom → (t x).dom) (J : ℕ) :
  respects (with_time (f.res_inter {s | ∀ k ∈ t s, k ≤ J}) (λ _, 1))
           (with_time (f.res_inter {s | ∀ k ∈ t s, k ≤ J}) t)
           (λ s₁ s₂, s₁.2 = s₂.2 ∧ s₂.1 ≤ J * s₁.1) :=
{ dom_of_dom := by { rintro ⟨t₁, s⟩ ⟨t₂, s⟩, dsimp only, rintro ⟨rfl, _⟩, simp [with_time], tauto, },
  some_of_some :=
begin
  rintro ⟨t₁, s₁⟩ ⟨t₂, s₁⟩ ⟨t₃, s₂⟩, dsimp only, rintro ⟨rfl, hb⟩,
  simp [with_time], rintros s₂' hs hn rfl rfl,
  rcases part.dom_iff_mem.mp (ht (part.dom_iff_mem.mpr ⟨_, hn⟩)) with ⟨tn, htn⟩,
  use [t₂ + tn, s₂, rfl], { mono, }, apply reaches₁_single, simp, refine ⟨⟨_, _⟩, _⟩; assumption,
end,
  none_of_none :=
begin
  rintro ⟨t₁, s₁⟩ ⟨t₂, s₁⟩, dsimp only, rintro ⟨rfl, _⟩,
  simp [with_time, ← part.dom_iff_mem],
  refine λ h₁ h₂, ⟨⟨h₁, h₂⟩, ht _⟩, rw part.dom_iff_mem, exact ⟨_, h₂⟩,
end }

lemma with_time_le_of_iters_le {x : σ} {n J : ℕ} (ht : ∀ x, (f x).dom → (t x).dom)
  (h : n ∈ time_iter (f.res_inter {s | ∀ k ∈ t s, k ≤ J}) (pfun.pure 1) x) :
  ∃ k ∈ time_iter f t x, k ≤ n * J :=
begin
  simp [time_iter, pfun.pure] at h, rcases h with ⟨n, ⟨⟨s, hs⟩, rfl⟩⟩,
  obtain ⟨⟨tf, sf⟩, h₁, h₂⟩ := tr_eval (time_eval_const_respects ht J) _ hs, swap, { use (0, x), }, swap, { split; refl, },
  dsimp only at h₁, rcases h₁ with ⟨rfl, h₁⟩,
  simp [time_iter],
  obtain ⟨tl, htl, tl_le⟩ : ∃ tl ∈ t s, tl ≤ J,
  { rw mem_eval at h₂, rcases h₂ with ⟨_, h₂⟩, simp [part.eq_some_iff, with_time] at h₂,
    rcases h₂ with ⟨⟨H, _⟩, ⟨tl, htl⟩⟩, use [tl, htl, H _ htl], },
  refine ⟨tf + tl, ⟨⟨tf, s, _, ⟨tl, htl, by ac_refl⟩⟩, _⟩⟩,
  { apply eval_mono (with_time_mono _) h₂, simp, },
  conv_rhs { rw [add_mul, add_comm], }, mono, { rw mul_comm, exact h₁, }, simpa using tl_le,
end

theorem fcommutes.to_time_frespects (H : fcommutes f₁ f₂ ftr) :
  fcommutes (with_time f₁ (pfun.pure 1)) (with_time f₂ (pfun.pure 1)) (prod.map id ftr) :=
{ dom_of_dom := by { simpa [with_time, pfun.pure] using H.dom_of_dom, },
  some_of_some :=
begin
  simp [with_time, pfun.pure], rintro a₁ b₁ ⟨a₂, b₂⟩ x hx x rfl,
  simp, rintro rfl rfl, refine ⟨some (ftr x), _, rfl, rfl⟩,
  exact H.some_of_some hx,
end,
  none_of_none := by simpa [with_time, pfun.pure] using H.none_of_none }

theorem eq_time_of_fcommutes (H : fcommutes f₁ f₂ ftr) (x : σ₁) :
  time_iter f₁ (pfun.pure 1) x = time_iter f₂ (pfun.pure 1) (ftr x) :=
begin
  have := H.to_time_frespects.to_frespects.eval_eq, simp [pfun.pure] at this,
  simp [time_iter, this, pfun.pure],
end

theorem fcommutes.restrict (H : fcommutes f₁ f₂ ftr) (S : set σ₂) :
  fcommutes (f₁.res_inter (ftr⁻¹' S)) (f₂.res_inter S) ftr :=
{ dom_of_dom := λ x, by { simp, rw ← H.to_frespects.dom_iff_dom, tauto, },
  some_of_some := λ a b, by { simp, intros h₁ h₂, exact ⟨h₁, H.some_of_some h₂⟩, },
  none_of_none := λ a, by { simp, intros h₁ h₂, exact ⟨h₁, H.none_of_none h₂⟩, } }

end track_with

end part_eval


/- Copying out split_ifs from mathlib so I can understand it. -/

open expr tactic

namespace tactic
open interactive

-- meta def fold_test (e : expr) : tactic unit :=
--     trace $ expr.fold e [] (λ e n l, (e,n) :: l)
-- constant α : Type
-- constant f : α → α
-- example : true :=
-- begin
--   (to_expr ```(λ x : α, (λ y, x) $ f $ f x) >>= fold_test)
-- end

/-- Returns the condition of a  -/
meta def find_if_cond : expr → option expr | e := -- note the `| e` style.
e.fold none $ λ e _ acc, acc <|> do
    c ← match e with
        | `(@ite %%c %%_ _ _ _) := some c
        | `(@dite %%c %%_ _ _ _) := some c
        | _ := none
        end,
    guard ¬c.has_var,
    find_if_cond c <|> -- Why does this need to be recursive?
    return c

/-- Find an if condition at one of the locations. -/
meta def find_if_cond_at (at_ : loc) : tactic (option expr) := do
lctx ← at_.get_locals, -- get the local context
lctx ← lctx.mmap infer_type, --get the types
tgt ← target,
let es := if at_.include_goal then tgt::lctx else lctx,
pure $ find_if_cond $ es.foldr app (default expr) -- jam all of the terms into one giant expression and run find_if_cond on it.

-- make a new simp attribute called "split_if_reduction"
run_cmd mk_simp_attr `split_if_reduction
-- Add "split_if_reduction" attributes to these if-reductions
attribute [split_if_reduction] if_pos if_neg dif_pos dif_neg

meta def reduce_ifs_at (at_ : loc) : tactic unit := do
sls ← get_user_simp_lemmas `split_if_reduction,
let cfg : simp_config := { fail_if_unchanged := ff },
let discharger := assumption <|> (applyc `not_not_intro >> assumption),
hs ← at_.get_locals,
hs.mmap' (λ h, simp_hyp sls [] h cfg discharger >> skip),
when at_.include_goal (simp_target sls [] cfg discharger)

/-- Perform an if-split with the condition `c`, give the new hypothesis the name `n`. -/
meta def split_if1 (c : expr) (n : name) (at_ : loc) : tactic unit :=
by_cases c n *> reduce_ifs_at at_

/--Pull a name from a ref list and use that, otherwise get a boring fresh name. -/
private meta def get_next_name (names : ref (list name)) : tactic name := do
ns ← read_ref names,
match ns with
| [] := get_unused_name `h
| (n::ns) := do write_ref names ns, return n
end

/-- Check that the given condition isn't already in the local context. -/
private meta def value_known (c : expr) : tactic bool :=
(find_assumption c $> tt)
<|> (find_assumption `(¬%%c) $> tt)
<|> (pure ff)

private meta def split_ifs_core (at_: loc) (names : ref (list name)) : list expr → tactic unit := λ done, do
some cond ← find_if_cond_at at_ | fail "no ite or dite expressions found",
let cond := match cond with `(¬%%p) := p | p := p end, -- strip off the ¬
if cond ∈ done then skip else do -- skip conditions which have already been done.
no_split ← value_known cond,
if no_split then do
    reduce_ifs_at at_,
    try (split_ifs_core (cond :: done))
else do
    n ← get_next_name names, -- pull a new name off the shelf.
    split_if1 cond n at_,
    try (split_ifs_core (cond :: done))

meta def split_ifs (names : list name) (at_ : loc := loc.ns [none]) /-by default do the target.-/ :=
using_new_ref names $ λ names, split_ifs_core at_ names []

namespace interactive
open interactive.types
/-- Splits all if-then-else-expressions into multiple goals.

Given a goal of the form `g (if p then x else y)`, `split_ifs` will produce
two goals: `p ⊢ g x` and `¬p ⊢ g y`.

If there are multiple ite-expressions, then `split_ifs` will split them all,
starting with a top-most one whose condition does not contain another
ite-expression.

`split_ifs at *` splits all ite-expressions in all hypotheses as well as the goal.

`split_ifs with h₁ h₂ h₃` overrides the default names for the hypotheses.
-/
meta def split_ifs (at_ : parse location) (names : parse with_ident_list) : tactic unit :=
tactic.split_ifs names at_

end interactive
end tactic


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

! This file was ported from Lean 3 source module algebra.group_ring_action.basic
! leanprover-community/mathlib commit 207cfac9fcd06138865b5d04f7091e46d9320432
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.Ring.Equiv
import Mathlib.Algebra.Field.Defs
import Mathlib.GroupTheory.GroupAction.Group

/-!
# Group action on rings

This file defines the typeclass of monoid acting on semirings `MulSemiringAction M R`,
and the corresponding typeclass of invariant subrings.

Note that `Algebra` does not satisfy the axioms of `MulSemiringAction`.

## Implementation notes

There is no separate typeclass for group acting on rings, group acting on fields, etc.
They are all grouped under `MulSemiringAction`.

## Tags

group action, invariant subring

-/

universe u v

/-- Typeclass for multiplicative actions by monoids on semirings.

This combines `DistribMulAction` with `MulDistribMulAction`. -/
class MulSemiringAction (M : Type u) (R : Type v) [Monoid M] [Semiring R] extends
  DistribMulAction M R where
  /-- Multipliying `1` by a scalar gives `1` -/
  smul_one : ∀ g : M, (g • (1 : R) : R) = 1
  /-- Scalara multiplication distributes across multiplication -/
  smul_mul : ∀ (g : M) (x y : R), g • (x * y) = g • x * g • y
#align mul_semiring_action MulSemiringAction

section Semiring

variable (M N G : Type _) [Monoid M] [Monoid N] [Group G]

variable (A R S F : Type v) [AddMonoid A] [Semiring R] [CommSemiring S] [DivisionRing F]

-- note we could not use `extends` since these typeclasses are made with `old_structure_cmd`
instance (priority := 100) MulSemiringAction.toMulDistribMulAction [h : MulSemiringAction M R] :
    MulDistribMulAction M R :=
  { h with }
#align mul_semiring_action.to_mul_distrib_mul_action MulSemiringAction.toMulDistribMulAction

/-- Each element of the monoid defines a semiring homomorphism. -/
@[simps!]
def MulSemiringAction.toRingHom [MulSemiringAction M R] (x : M) : R →+* R :=
  { MulDistribMulAction.toMonoidHom R x, DistribMulAction.toAddMonoidHom R x with }
#align mul_semiring_action.to_ring_hom MulSemiringAction.toRingHom
#align mul_semiring_action.to_ring_hom_apply MulSemiringAction.toRingHom_apply

theorem toRingHom_injective [MulSemiringAction M R] [FaithfulSMul M R] :
    Function.Injective (MulSemiringAction.toRingHom M R) := fun _ _ h =>
  eq_of_smul_eq_smul fun r => RingHom.ext_iff.1 h r
#align to_ring_hom_injective toRingHom_injective

/-- Each element of the group defines a semiring isomorphism. -/
@[simps!]
def MulSemiringAction.toRingEquiv [MulSemiringAction G R] (x : G) : R ≃+* R :=
  { DistribMulAction.toAddEquiv R x, MulSemiringAction.toRingHom G R x with }
#align mul_semiring_action.to_ring_equiv MulSemiringAction.toRingEquiv
#align mul_semiring_action.to_ring_equiv_symm_apply MulSemiringAction.toRingEquiv_symm_apply
#align mul_semiring_action.to_ring_equiv_apply MulSemiringAction.toRingEquiv_apply

section

variable {M N}

/-- Compose a `MulSemiringAction` with a `MonoidHom`, with action `f r' • m`.
See note [reducible non-instances]. -/
@[reducible]
def MulSemiringAction.compHom (f : N →* M) [MulSemiringAction M R] : MulSemiringAction N R :=
  { DistribMulAction.compHom R f, MulDistribMulAction.compHom R f with smul := SMul.comp.smul f }
#align mul_semiring_action.comp_hom MulSemiringAction.compHom

end

section SimpLemmas

variable {M G A R F}

attribute [simp] smul_one smul_mul' smul_zero smul_add

/-- Note that `smul_inv'` refers to the group case, and `smul_inv` has an additional inverse
on `x`. -/
@[simp]
theorem smul_inv'' [MulSemiringAction M F] (x : M) (m : F) : x • m⁻¹ = (x • m)⁻¹ :=
  map_inv₀ (MulSemiringAction.toRingHom M F x) _
#align smul_inv'' smul_inv''

end SimpLemmas

end Semiring


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

/-!
# Functors with two arguments

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

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