/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Mario Carneiro, Patrick Massot

Constructions of new topological spaces from old ones: product, sum, subtype, quotient, list, vector
-/
import topology.maps topology.subset_properties topology.separation topology.bases
noncomputable theory

open set filter lattice
local attribute [instance] classical.prop_decidable

variables {α : Type*} {β : Type*} {γ : Type*} {δ : Type*}

section prod
open topological_space
variables [topological_space α] [topological_space β] [topological_space γ]

lemma continuous_fst : continuous (@prod.fst α β) :=
continuous_sup_dom_left continuous_induced_dom

lemma continuous_snd : continuous (@prod.snd α β) :=
continuous_sup_dom_right continuous_induced_dom

lemma continuous.prod_mk {f : γ → α} {g : γ → β}
  (hf : continuous f) (hg : continuous g) : continuous (λx, prod.mk (f x) (g x)) :=
continuous_sup_rng (continuous_induced_rng hf) (continuous_induced_rng hg)

lemma continuous_swap : continuous (prod.swap : α × β → β × α) :=
continuous.prod_mk continuous_snd continuous_fst

lemma is_open_prod {s : set α} {t : set β} (hs : is_open s) (ht : is_open t) :
  is_open (set.prod s t) :=
is_open_inter (continuous_fst s hs) (continuous_snd t ht)

lemma nhds_prod_eq {a : α} {b : β} : nhds (a, b) = filter.prod (nhds a) (nhds b) :=
by rw [filter.prod, prod.topological_space, nhds_sup, nhds_induced_eq_comap, nhds_induced_eq_comap]

instance [topological_space α] [discrete_topology α] [topological_space β] [discrete_topology β] :
  discrete_topology (α × β) :=
⟨eq_of_nhds_eq_nhds $ assume ⟨a, b⟩,
  by rw [nhds_prod_eq, nhds_discrete α, nhds_discrete β, nhds_top, filter.prod_pure_pure]⟩

lemma prod_mem_nhds_sets {s : set α} {t : set β} {a : α} {b : β}
  (ha : s ∈ nhds a) (hb : t ∈ nhds b) : set.prod s t ∈ nhds (a, b) :=
by rw [nhds_prod_eq]; exact prod_mem_prod ha hb

lemma nhds_swap (a : α) (b : β) : nhds (a, b) = (nhds (b, a)).map prod.swap :=
by rw [nhds_prod_eq, filter.prod_comm, nhds_prod_eq]; refl

lemma tendsto_prod_mk_nhds {γ} {a : α} {b : β} {f : filter γ} {ma : γ → α} {mb : γ → β}
  (ha : tendsto ma f (nhds a)) (hb : tendsto mb f (nhds b)) :
  tendsto (λc, (ma c, mb c)) f (nhds (a, b)) :=
by rw [nhds_prod_eq]; exact filter.tendsto.prod_mk ha hb

lemma prod_generate_from_generate_from_eq {s : set (set α)} {t : set (set β)}
  (hs : ⋃₀ s = univ) (ht : ⋃₀ t = univ) :
  @prod.topological_space α β (generate_from s) (generate_from t) =
  generate_from {g | ∃u∈s, ∃v∈t, g = set.prod u v} :=
let G := generate_from {g | ∃u∈s, ∃v∈t, g = set.prod u v} in
le_antisymm
  (sup_le
    (induced_le_iff_le_coinduced.mpr $ generate_from_le $ assume u hu,
      have (⋃v∈t, set.prod u v) = prod.fst ⁻¹' u,
        from calc (⋃v∈t, set.prod u v) = set.prod u univ :
            set.ext $ assume ⟨a, b⟩, by rw ← ht; simp [and.left_comm] {contextual:=tt}
          ... = prod.fst ⁻¹' u : by simp [set.prod, preimage],
      show G.is_open (prod.fst ⁻¹' u),
        from this ▸ @is_open_Union _ _ G _ $ assume v, @is_open_Union _ _ G _ $ assume hv,
          generate_open.basic _ ⟨_, hu, _, hv, rfl⟩)
    (induced_le_iff_le_coinduced.mpr $ generate_from_le $ assume v hv,
      have (⋃u∈s, set.prod u v) = prod.snd ⁻¹' v,
        from calc (⋃u∈s, set.prod u v) = set.prod univ v:
            set.ext $ assume ⟨a, b⟩, by rw [←hs]; by_cases b ∈ v; simp [h] {contextual:=tt}
          ... = prod.snd ⁻¹' v : by simp [set.prod, preimage],
      show G.is_open (prod.snd ⁻¹' v),
        from this ▸ @is_open_Union _ _ G _ $ assume u, @is_open_Union _ _ G _ $ assume hu,
          generate_open.basic _ ⟨_, hu, _, hv, rfl⟩))
  (generate_from_le $ assume g ⟨u, hu, v, hv, g_eq⟩, g_eq.symm ▸
    @is_open_prod _ _ (generate_from s) (generate_from t) _ _
      (generate_open.basic _ hu) (generate_open.basic _ hv))

lemma prod_eq_generate_from [tα : topological_space α] [tβ : topological_space β] :
  prod.topological_space =
  generate_from {g | ∃(s:set α) (t:set β), is_open s ∧ is_open t ∧ g = set.prod s t} :=
le_antisymm
  (sup_le
    (ball_image_of_ball $ λt ht, generate_open.basic _ ⟨t, univ, by simpa [set.prod_eq] using ht⟩)
    (ball_image_of_ball $ λt ht, generate_open.basic _ ⟨univ, t, by simpa [set.prod_eq] using ht⟩))
  (generate_from_le $ assume g ⟨s, t, hs, ht, g_eq⟩, g_eq.symm ▸ is_open_prod hs ht)

lemma is_open_prod_iff {s : set (α×β)} : is_open s ↔
  (∀a b, (a, b) ∈ s → ∃u v, is_open u ∧ is_open v ∧ a ∈ u ∧ b ∈ v ∧ set.prod u v ⊆ s) :=
begin
  rw [is_open_iff_nhds],
  simp [nhds_prod_eq, mem_prod_iff],
  simp [mem_nhds_sets_iff],
  exact forall_congr (assume a, ball_congr $ assume b h,
    ⟨assume ⟨u', ⟨u, us, uo, au⟩, v', ⟨v, vs, vo, bv⟩, h⟩,
      ⟨u, uo, v, vo, au, bv, subset.trans (set.prod_mono us vs) h⟩,
      assume ⟨u, uo, v, vo, au, bv, h⟩,
      ⟨u, ⟨u, subset.refl u, uo, au⟩, v, ⟨v, subset.refl v, vo, bv⟩, h⟩⟩)
end

lemma closure_prod_eq {s : set α} {t : set β} :
  closure (set.prod s t) = set.prod (closure s) (closure t) :=
set.ext $ assume ⟨a, b⟩,
have filter.prod (nhds a) (nhds b) ⊓ principal (set.prod s t) =
  filter.prod (nhds a ⊓ principal s) (nhds b ⊓ principal t),
  by rw [←prod_inf_prod, prod_principal_principal],
by simp [closure_eq_nhds, nhds_prod_eq, this]; exact prod_neq_bot

lemma mem_closure2 [topological_space α] [topological_space β] [topological_space γ]
  {s : set α} {t : set β} {u : set γ} {f : α → β → γ} {a : α} {b : β}
  (hf : continuous (λp:α×β, f p.1 p.2)) (ha : a ∈ closure s) (hb : b ∈ closure t)
  (hu : ∀a b, a ∈ s → b ∈ t → f a b ∈ u) :
  f a b ∈ closure u :=
have (a, b) ∈ closure (set.prod s t), by rw [closure_prod_eq]; from ⟨ha, hb⟩,
show (λp:α×β, f p.1 p.2) (a, b) ∈ closure u, from
  mem_closure hf this $ assume ⟨a, b⟩ ⟨ha, hb⟩, hu a b ha hb

lemma is_closed_prod [topological_space α] [topological_space β] {s₁ : set α} {s₂ : set β}
  (h₁ : is_closed s₁) (h₂ : is_closed s₂) : is_closed (set.prod s₁ s₂) :=
closure_eq_iff_is_closed.mp $ by simp [h₁, h₂, closure_prod_eq, closure_eq_of_is_closed]

protected lemma is_open_map.prod
  [topological_space α] [topological_space β] [topological_space γ] [topological_space δ]
  {f : α → β} {g : γ → δ}
  (hf : is_open_map f) (hg : is_open_map g) : is_open_map (λ p : α × γ, (f p.1, g p.2)) :=
begin
  rw [is_open_map_iff_nhds_le],
  rintros ⟨a, b⟩,
  rw [nhds_prod_eq, nhds_prod_eq, ← filter.prod_map_map_eq],
  exact filter.prod_mono ((is_open_map_iff_nhds_le f).1 hf a) ((is_open_map_iff_nhds_le g).1 hg b)
end

section tube_lemma

def nhds_contain_boxes (s : set α) (t : set β) : Prop :=
∀ (n : set (α × β)) (hn : is_open n) (hp : set.prod s t ⊆ n),
∃ (u : set α) (v : set β), is_open u ∧ is_open v ∧ s ⊆ u ∧ t ⊆ v ∧ set.prod u v ⊆ n

lemma nhds_contain_boxes.symm {s : set α} {t : set β} :
  nhds_contain_boxes s t → nhds_contain_boxes t s :=
assume H n hn hp,
  let ⟨u, v, uo, vo, su, tv, p⟩ :=
    H (prod.swap ⁻¹' n)
      (continuous_swap n hn)
      (by rwa [←image_subset_iff, prod.swap, image_swap_prod]) in
  ⟨v, u, vo, uo, tv, su,
    by rwa [←image_subset_iff, prod.swap, image_swap_prod] at p⟩

lemma nhds_contain_boxes.comm {s : set α} {t : set β} :
  nhds_contain_boxes s t ↔ nhds_contain_boxes t s :=
iff.intro nhds_contain_boxes.symm nhds_contain_boxes.symm

lemma nhds_contain_boxes_of_singleton {x : α} {y : β} :
  nhds_contain_boxes ({x} : set α) ({y} : set β) :=
assume n hn hp,
  let ⟨u, v, uo, vo, xu, yv, hp'⟩ :=
    is_open_prod_iff.mp hn x y (hp $ by simp) in
  ⟨u, v, uo, vo, by simpa, by simpa, hp'⟩

lemma nhds_contain_boxes_of_compact {s : set α} (hs : compact s) (t : set β)
  (H : ∀ x ∈ s, nhds_contain_boxes ({x} : set α) t) : nhds_contain_boxes s t :=
assume n hn hp,
have ∀x : subtype s, ∃uv : set α × set β,
     is_open uv.1 ∧ is_open uv.2 ∧ {↑x} ⊆ uv.1 ∧ t ⊆ uv.2 ∧ set.prod uv.1 uv.2 ⊆ n,
  from assume ⟨x, hx⟩,
    have set.prod {x} t ⊆ n, from
      subset.trans (prod_mono (by simpa) (subset.refl _)) hp,
    let ⟨ux,vx,H1⟩ := H x hx n hn this in ⟨⟨ux,vx⟩,H1⟩,
let ⟨uvs, h⟩ := classical.axiom_of_choice this in
have us_cover : s ⊆ ⋃i, (uvs i).1, from
  assume x hx, set.subset_Union _ ⟨x,hx⟩ (by simpa using (h ⟨x,hx⟩).2.2.1),
let ⟨s0, _, s0_fin, s0_cover⟩ :=
  compact_elim_finite_subcover_image hs (λi _, (h i).1) $
    by rw bUnion_univ; exact us_cover in
let u := ⋃(i ∈ s0), (uvs i).1 in
let v := ⋂(i ∈ s0), (uvs i).2 in
have is_open u, from is_open_bUnion (λi _, (h i).1),
have is_open v, from is_open_bInter s0_fin (λi _, (h i).2.1),
have t ⊆ v, from subset_bInter (λi _, (h i).2.2.2.1),
have set.prod u v ⊆ n, from assume ⟨x',y'⟩ ⟨hx',hy'⟩,
  have ∃i ∈ s0, x' ∈ (uvs i).1, by simpa using hx',
  let ⟨i,is0,hi⟩ := this in
  (h i).2.2.2.2 ⟨hi, (bInter_subset_of_mem is0 : v ⊆ (uvs i).2) hy'⟩,
⟨u, v, ‹is_open u›, ‹is_open v›, s0_cover, ‹t ⊆ v›, ‹set.prod u v ⊆ n›⟩

lemma generalized_tube_lemma {s : set α} (hs : compact s) {t : set β} (ht : compact t)
  {n : set (α × β)} (hn : is_open n) (hp : set.prod s t ⊆ n) :
  ∃ (u : set α) (v : set β), is_open u ∧ is_open v ∧ s ⊆ u ∧ t ⊆ v ∧ set.prod u v ⊆ n :=
have _, from
  nhds_contain_boxes_of_compact hs t $ assume x _, nhds_contain_boxes.symm $
    nhds_contain_boxes_of_compact ht {x} $ assume y _, nhds_contain_boxes_of_singleton,
this n hn hp

end tube_lemma

lemma is_closed_diagonal [topological_space α] [t2_space α] : is_closed {p:α×α | p.1 = p.2} :=
is_closed_iff_nhds.mpr $ assume ⟨a₁, a₂⟩ h, eq_of_nhds_neq_bot $ assume : nhds a₁ ⊓ nhds a₂ = ⊥, h $
  let ⟨t₁, ht₁, t₂, ht₂, (h' : t₁ ∩ t₂ ⊆ ∅)⟩ :=
    by rw [←empty_in_sets_eq_bot, mem_inf_sets] at this; exact this in
  begin
    change t₁ ∈ nhds a₁ at ht₁,
    change t₂ ∈ nhds a₂ at ht₂,
    rw [nhds_prod_eq, ←empty_in_sets_eq_bot],
    apply filter.sets_of_superset,
    apply inter_mem_inf_sets (prod_mem_prod ht₁ ht₂) (mem_principal_sets.mpr (subset.refl _)),
    exact assume ⟨x₁, x₂⟩ ⟨⟨hx₁, hx₂⟩, (heq : x₁ = x₂)⟩,
      show false, from @h' x₁ ⟨hx₁, heq.symm ▸ hx₂⟩
  end

lemma is_closed_eq [topological_space α] [t2_space α] [topological_space β] {f g : β → α}
  (hf : continuous f) (hg : continuous g) : is_closed {x:β | f x = g x} :=
continuous_iff_is_closed.mp (hf.prod_mk hg) _ is_closed_diagonal

lemma diagonal_eq_range_diagonal_map : {p:α×α | p.1 = p.2} = range (λx, (x,x)) :=
ext $ assume p, iff.intro
  (assume h, ⟨p.1, prod.ext_iff.2 ⟨rfl, h⟩⟩)
  (assume ⟨x, hx⟩, show p.1 = p.2, by rw ←hx)

lemma prod_subset_compl_diagonal_iff_disjoint {s t : set α} :
  set.prod s t ⊆ - {p:α×α | p.1 = p.2} ↔ s ∩ t = ∅ :=
by rw [eq_empty_iff_forall_not_mem, subset_compl_comm,
       diagonal_eq_range_diagonal_map, range_subset_iff]; simp

lemma compact_compact_separated [t2_space α] {s t : set α}
  (hs : compact s) (ht : compact t) (hst : s ∩ t = ∅) :
  ∃u v : set α, is_open u ∧ is_open v ∧ s ⊆ u ∧ t ⊆ v ∧ u ∩ v = ∅ :=
by simp only [prod_subset_compl_diagonal_iff_disjoint.symm] at ⊢ hst;
   exact generalized_tube_lemma hs ht is_closed_diagonal hst

lemma closed_of_compact [t2_space α] (s : set α) (hs : compact s) : is_closed s :=
is_open_compl_iff.mpr $ is_open_iff_forall_mem_open.mpr $ assume x hx,
  let ⟨u, v, uo, vo, su, xv, uv⟩ :=
    compact_compact_separated hs (compact_singleton : compact {x})
      (by rwa [inter_comm, ←subset_compl_iff_disjoint, singleton_subset_iff]) in
  have v ⊆ -s, from
    subset_compl_comm.mp (subset.trans su (subset_compl_iff_disjoint.mpr uv)),
⟨v, this, vo, by simpa using xv⟩

lemma locally_compact_of_compact_nhds [topological_space α] [t2_space α]
  (h : ∀ x : α, ∃ s, s ∈ nhds x ∧ compact s) :
  locally_compact_space α :=
⟨assume x n hn,
  let ⟨u, un, uo, xu⟩ := mem_nhds_sets_iff.mp hn in
  let ⟨k, kx, kc⟩ := h x in
  -- K is compact but not necessarily contained in N.
  -- K \ U is again compact and doesn't contain x, so
  -- we may find open sets V, W separating x from K \ U.
  -- Then K \ W is a compact neighborhood of x contained in U.
  let ⟨v, w, vo, wo, xv, kuw, vw⟩ :=
    compact_compact_separated compact_singleton (compact_diff kc uo)
      (by rw [singleton_inter_eq_empty]; exact λ h, h.2 xu) in
  have wn : -w ∈ nhds x, from
   mem_nhds_sets_iff.mpr
     ⟨v, subset_compl_iff_disjoint.mpr vw, vo, singleton_subset_iff.mp xv⟩,
  ⟨k - w,
   filter.inter_mem_sets kx wn,
   subset.trans (diff_subset_comm.mp kuw) un,
   compact_diff kc wo⟩⟩

instance locally_compact_of_compact [topological_space α] [t2_space α] [compact_space α] :
  locally_compact_space α :=
locally_compact_of_compact_nhds (assume x, ⟨univ, mem_nhds_sets is_open_univ trivial, compact_univ⟩)

-- We can't make this an instance because it could cause an instance loop.
lemma normal_of_compact_t2 [topological_space α] [compact_space α] [t2_space α] : normal_space α :=
begin
  refine ⟨assume s t hs ht st, _⟩,
  simp only [disjoint_iff],
  exact compact_compact_separated (compact_of_closed hs) (compact_of_closed ht) st.eq_bot
end

/- TODO: more fine grained instances for first_countable_topology, separable_space, t2_space, ... -/
instance [second_countable_topology α] [second_countable_topology β] :
  second_countable_topology (α × β) :=
⟨let ⟨a, ha₁, ha₂, ha₃, ha₄, ha₅⟩ := is_open_generated_countable_inter α in
  let ⟨b, hb₁, hb₂, hb₃, hb₄, hb₅⟩ := is_open_generated_countable_inter β in
  ⟨{g | ∃u∈a, ∃v∈b, g = set.prod u v},
    have {g | ∃u∈a, ∃v∈b, g = set.prod u v} = (⋃u∈a, ⋃v∈b, {set.prod u v}),
      by apply set.ext; simp,
    by rw [this]; exact (countable_bUnion ha₁ $ assume u hu, countable_bUnion hb₁ $ by simp),
    by rw [ha₅, hb₅, prod_generate_from_generate_from_eq ha₄ hb₄]⟩⟩

lemma compact_prod (s : set α) (t : set β) (ha : compact s) (hb : compact t) : compact (set.prod s t) :=
begin
  rw compact_iff_ultrafilter_le_nhds at ha hb ⊢,
  intros f hf hfs,
  rw le_principal_iff at hfs,
  rcases ha (map prod.fst f) (ultrafilter_map hf)
    (le_principal_iff.2 (mem_map_sets_iff.2
      ⟨_, hfs, image_subset_iff.2 (λ s h, h.1)⟩)) with ⟨a, sa, ha⟩,
  rcases hb (map prod.snd f) (ultrafilter_map hf)
    (le_principal_iff.2 (mem_map_sets_iff.2
      ⟨_, hfs, image_subset_iff.2 (λ s h, h.2)⟩)) with ⟨b, tb, hb⟩,
  rw map_le_iff_le_comap at ha hb,
  refine ⟨⟨a, b⟩, ⟨sa, tb⟩, _⟩,
  rw nhds_prod_eq, exact le_inf ha hb
end

instance [compact_space α] [compact_space β] : compact_space (α × β) :=
⟨begin
  have A : compact (set.prod (univ : set α) (univ : set β)) :=
    compact_prod univ univ compact_univ compact_univ,
  have : set.prod (univ : set α) (univ : set β) = (univ : set (α × β)) := by simp,
  rwa this at A,
end⟩

end prod

section sum
variables [topological_space α] [topological_space β] [topological_space γ]

lemma continuous_inl : continuous (@sum.inl α β) :=
continuous_inf_rng_left continuous_coinduced_rng

lemma continuous_inr : continuous (@sum.inr α β) :=
continuous_inf_rng_right continuous_coinduced_rng

lemma continuous_sum_rec {f : α → γ} {g : β → γ}
  (hf : continuous f) (hg : continuous g) : @continuous (α ⊕ β) γ _ _ (@sum.rec α β (λ_, γ) f g) :=
continuous_inf_dom hf hg

lemma embedding_inl : embedding (@sum.inl α β) :=
⟨λ _ _, sum.inl.inj_iff.mp,
  begin
    unfold sum.topological_space,
    apply le_antisymm,
    { intros u hu, existsi (sum.inl '' u),
      change
        (is_open (sum.inl ⁻¹' (@sum.inl α β '' u)) ∧
         is_open (sum.inr ⁻¹' (@sum.inl α β '' u))) ∧
        sum.inl ⁻¹' (sum.inl '' u) = u,
      have : sum.inl ⁻¹' (@sum.inl α β '' u) = u :=
        preimage_image_eq u (λ _ _, sum.inl.inj_iff.mp), rw this,
      have : sum.inr ⁻¹' (@sum.inl α β '' u) = ∅ :=
        eq_empty_iff_forall_not_mem.mpr (assume a ⟨b, _, h⟩, sum.inl_ne_inr h), rw this,
      exact ⟨⟨hu, is_open_empty⟩, rfl⟩ },
    { rw induced_le_iff_le_coinduced, exact lattice.inf_le_left }
  end⟩

lemma embedding_inr : embedding (@sum.inr α β) :=
⟨λ _ _, sum.inr.inj_iff.mp,
  begin
    unfold sum.topological_space,
    apply le_antisymm,
    { intros u hu, existsi (sum.inr '' u),
      change
        (is_open (sum.inl ⁻¹' (@sum.inr α β '' u)) ∧
         is_open (sum.inr ⁻¹' (@sum.inr α β '' u))) ∧
        sum.inr ⁻¹' (sum.inr '' u) = u,
      have : sum.inl ⁻¹' (@sum.inr α β '' u) = ∅ :=
        eq_empty_iff_forall_not_mem.mpr (assume b ⟨a, _, h⟩, sum.inr_ne_inl h), rw this,
      have : sum.inr ⁻¹' (@sum.inr α β '' u) = u :=
        preimage_image_eq u (λ _ _, sum.inr.inj_iff.mp), rw this,
      exact ⟨⟨is_open_empty, hu⟩, rfl⟩ },
    { rw induced_le_iff_le_coinduced, exact lattice.inf_le_right }
  end⟩

instance [topological_space α] [topological_space β] [compact_space α] [compact_space β] :
  compact_space (α ⊕ β) :=
⟨begin
  have A : compact (@sum.inl α β '' univ) := compact_image compact_univ continuous_inl,
  have B : compact (@sum.inr α β '' univ) := compact_image compact_univ continuous_inr,
  have C := compact_union_of_compact A B,
  have : (@sum.inl α β '' univ) ∪ (@sum.inr α β '' univ) = univ := by ext; cases x; simp,
  rwa this at C,
end⟩

end sum

section subtype
variables [topological_space α] [topological_space β] [topological_space γ] {p : α → Prop}

lemma embedding_graph {f : α → β} (hf : continuous f) : embedding (λx, (x, f x)) :=
embedding_of_embedding_compose (continuous_id.prod_mk hf) continuous_fst embedding_id

lemma embedding_subtype_val : embedding (@subtype.val α p) :=
⟨subtype.val_injective, rfl⟩

lemma continuous_subtype_val : continuous (@subtype.val α p) :=
continuous_induced_dom

lemma continuous_subtype_mk {f : β → α}
  (hp : ∀x, p (f x)) (h : continuous f) : continuous (λx, (⟨f x, hp x⟩ : subtype p)) :=
continuous_induced_rng h

lemma continuous_at_subtype_val [topological_space α] {p : α → Prop} {a : subtype p} :
  continuous_at subtype.val a :=
continuous_iff_continuous_at.mp continuous_subtype_val _

lemma map_nhds_subtype_val_eq {a : α} (ha : p a) (h : {a | p a} ∈ nhds a) :
  map (@subtype.val α p) (nhds ⟨a, ha⟩) = nhds a :=
map_nhds_induced_eq (by simp [subtype.val_image, h])

lemma nhds_subtype_eq_comap {a : α} {h : p a} :
  nhds (⟨a, h⟩ : subtype p) = comap subtype.val (nhds a) :=
nhds_induced_eq_comap

lemma tendsto_subtype_rng [topological_space α] {p : α → Prop} {b : filter β} {f : β → subtype p} :
  ∀{a:subtype p}, tendsto f b (nhds a) ↔ tendsto (λx, subtype.val (f x)) b (nhds a.val)
| ⟨a, ha⟩ := by rw [nhds_subtype_eq_comap, tendsto_comap_iff]

lemma continuous_subtype_nhds_cover {ι : Sort*} {f : α → β} {c : ι → α → Prop}
  (c_cover : ∀x:α, ∃i, {x | c i x} ∈ nhds x)
  (f_cont  : ∀i, continuous (λ(x : subtype (c i)), f x.val)) :
  continuous f :=
continuous_iff_continuous_at.mpr $ assume x,
  let ⟨i, (c_sets : {x | c i x} ∈ nhds x)⟩ := c_cover x in
  let x' : subtype (c i) := ⟨x, mem_of_nhds c_sets⟩ in
  calc map f (nhds x) = map f (map subtype.val (nhds x')) :
      congr_arg (map f) (map_nhds_subtype_val_eq _ $ c_sets).symm
    ... = map (λx:subtype (c i), f x.val) (nhds x') : rfl
    ... ≤ nhds (f x) : continuous_iff_continuous_at.mp (f_cont i) x'

lemma continuous_subtype_is_closed_cover {ι : Sort*} {f : α → β} (c : ι → α → Prop)
  (h_lf : locally_finite (λi, {x | c i x}))
  (h_is_closed : ∀i, is_closed {x | c i x})
  (h_cover : ∀x, ∃i, c i x)
  (f_cont  : ∀i, continuous (λ(x : subtype (c i)), f x.val)) :
  continuous f :=
continuous_iff_is_closed.mpr $
  assume s hs,
  have ∀i, is_closed (@subtype.val α {x | c i x} '' (f ∘ subtype.val ⁻¹' s)),
    from assume i,
    embedding_is_closed embedding_subtype_val
      (by simp [subtype.val_range]; exact h_is_closed i)
      (continuous_iff_is_closed.mp (f_cont i) _ hs),
  have is_closed (⋃i, @subtype.val α {x | c i x} '' (f ∘ subtype.val ⁻¹' s)),
    from is_closed_Union_of_locally_finite
      (locally_finite_subset h_lf $ assume i x ⟨⟨x', hx'⟩, _, heq⟩, heq ▸ hx')
      this,
  have f ⁻¹' s = (⋃i, @subtype.val α {x | c i x} '' (f ∘ subtype.val ⁻¹' s)),
  begin
    apply set.ext,
    have : ∀ (x : α), f x ∈ s ↔ ∃ (i : ι), c i x ∧ f x ∈ s :=
      λ x, ⟨λ hx, let ⟨i, hi⟩ := h_cover x in ⟨i, hi, hx⟩,
            λ ⟨i, hi, hx⟩, hx⟩,
    simp [and.comm, and.left_comm], simpa [(∘)],
  end,
  by rwa [this]

lemma closure_subtype {x : {a // p a}} {s : set {a // p a}}:
  x ∈ closure s ↔ x.val ∈ closure (subtype.val '' s) :=
closure_induced $ assume x y, subtype.eq

lemma compact_iff_compact_image_of_embedding {s : set α} {f : α → β} (hf : embedding f) :
  compact s ↔ compact (f '' s) :=
iff.intro (assume h, compact_image h hf.continuous) $ assume h, begin
  rw compact_iff_ultrafilter_le_nhds at ⊢ h,
  intros u hu us',
  let u' : filter β := map f u,
  have : u' ≤ principal (f '' s), begin
    rw [map_le_iff_le_comap, comap_principal], convert us',
    exact preimage_image_eq _ hf.1
  end,
  rcases h u' (ultrafilter_map hu) this with ⟨_, ⟨a, ha, ⟨⟩⟩, _⟩,
  refine ⟨a, ha, _⟩,
  rwa [hf.2, nhds_induced_eq_comap, ←map_le_iff_le_comap]
end

lemma compact_iff_compact_in_subtype {s : set {a // p a}} :
  compact s ↔ compact (subtype.val '' s) :=
compact_iff_compact_image_of_embedding embedding_subtype_val

lemma compact_iff_compact_univ {s : set α} : compact s ↔ compact (univ : set (subtype s)) :=
by rw [compact_iff_compact_in_subtype, image_univ, subtype.val_range]; refl

lemma compact_iff_compact_space {s : set α} : compact s ↔ compact_space s :=
compact_iff_compact_univ.trans ⟨λ h, ⟨h⟩, @compact_space.compact_univ _ _⟩

end subtype

section quotient
variables [topological_space α] [topological_space β] [topological_space γ]
variables {r : α → α → Prop} {s : setoid α}

lemma quotient_map_quot_mk : quotient_map (@quot.mk α r) :=
⟨quot.exists_rep, rfl⟩

lemma continuous_quot_mk : continuous (@quot.mk α r) :=
continuous_coinduced_rng

lemma continuous_quot_lift {f : α → β} (hr : ∀ a b, r a b → f a = f b)
  (h : continuous f) : continuous (quot.lift f hr : quot r → β) :=
continuous_coinduced_dom h

lemma quotient_map_quotient_mk : quotient_map (@quotient.mk α s) :=
quotient_map_quot_mk

lemma continuous_quotient_mk : continuous (@quotient.mk α s) :=
continuous_coinduced_rng

lemma continuous_quotient_lift {f : α → β} (hs : ∀ a b, a ≈ b → f a = f b)
  (h : continuous f) : continuous (quotient.lift f hs : quotient s → β) :=
continuous_coinduced_dom h

instance quot.compact_space {r : α → α → Prop} [topological_space α] [compact_space α] :
  compact_space (quot r) :=
⟨begin
   have : quot.mk r '' univ = univ,
     by rw [image_univ, range_iff_surjective]; exact quot.exists_rep,
   rw ←this,
   exact compact_image compact_univ continuous_quot_mk
 end⟩

instance quotient.compact_space {s : setoid α} [topological_space α] [compact_space α] :
  compact_space (quotient s) :=
quot.compact_space

end quotient

section pi
variables {ι : Type*} {π : ι → Type*}
open topological_space

lemma continuous_pi [topological_space α] [∀i, topological_space (π i)] {f : α → Πi:ι, π i}
  (h : ∀i, continuous (λa, f a i)) : continuous f :=
continuous_supr_rng $ assume i, continuous_induced_rng $ h i

lemma continuous_apply [∀i, topological_space (π i)] (i : ι) :
  continuous (λp:Πi, π i, p i) :=
continuous_supr_dom continuous_induced_dom

lemma nhds_pi [t : ∀i, topological_space (π i)] {a : Πi, π i} :
  nhds a = (⨅i, comap (λx, x i) (nhds (a i))) :=
calc nhds a = (⨅i, @nhds _ (@topological_space.induced _ _ (λx:Πi, π i, x i) (t i)) a) : nhds_supr
  ... = (⨅i, comap (λx, x i) (nhds (a i))) : by simp [nhds_induced_eq_comap]

/-- Tychonoff's theorem -/
lemma compact_pi_infinite [∀i, topological_space (π i)] {s : Πi:ι, set (π i)} :
  (∀i, compact (s i)) → compact {x : Πi:ι, π i | ∀i, x i ∈ s i} :=
begin
  simp [compact_iff_ultrafilter_le_nhds, nhds_pi],
  exact assume h f hf hfs,
    let p : Πi:ι, filter (π i) := λi, map (λx:Πi:ι, π i, x i) f in
    have ∀i:ι, ∃a, a∈s i ∧ p i ≤ nhds a,
      from assume i, h i (p i) (ultrafilter_map hf) $
      show (λx:Πi:ι, π i, x i) ⁻¹' s i ∈ f.sets,
        from mem_sets_of_superset hfs $ assume x (hx : ∀i, x i ∈ s i), hx i,
    let ⟨a, ha⟩ := classical.axiom_of_choice this in
    ⟨a, assume i, (ha i).left, assume i, map_le_iff_le_comap.mp $ (ha i).right⟩
end

lemma is_open_set_pi [∀a, topological_space (π a)] {i : set ι} {s : Πa, set (π a)}
  (hi : finite i) (hs : ∀a∈i, is_open (s a)) : is_open (pi i s) :=
by rw [pi_def]; exact (is_open_bInter hi $ assume a ha, continuous_apply a _ $ hs a ha)

lemma pi_eq_generate_from [∀a, topological_space (π a)] :
  Pi.topological_space =
  generate_from {g | ∃(s:Πa, set (π a)) (i : finset ι), (∀a∈i, is_open (s a)) ∧ g = pi ↑i s} :=
le_antisymm
  (supr_le $ assume a s ⟨t, ht, s_eq⟩, generate_open.basic _ $
    ⟨function.update (λa, univ) a t, {a}, by simpa using ht, by ext f; simp [s_eq.symm, pi]⟩)
  (generate_from_le $ assume g ⟨s, i, hi, eq⟩, eq.symm ▸ is_open_set_pi (finset.finite_to_set _) hi)

lemma pi_generate_from_eq {g : Πa, set (set (π a))} :
  @Pi.topological_space ι π (λa, generate_from (g a)) =
  generate_from {t | ∃(s:Πa, set (π a)) (i : finset ι), (∀a∈i, s a ∈ g a) ∧ t = pi ↑i s} :=
let G := {t | ∃(s:Πa, set (π a)) (i : finset ι), (∀a∈i, s a ∈ g a) ∧ t = pi ↑i s} in
begin
  rw [pi_eq_generate_from],
  refine le_antisymm (generate_from_le _) (generate_from_mono _),
  { rintros s ⟨t, i, hi, rfl⟩,
    rw [pi_def],
    apply is_open_bInter (finset.finite_to_set _),
    assume a ha, show ((generate_from G).coinduced (λf:Πa, π a, f a)).is_open (t a),
    refine generate_from_le _ _ (hi a ha),
    exact assume s hs, generate_open.basic _ ⟨function.update (λa, univ) a s, {a}, by simp [hs]⟩ },
  exact assume s ⟨t, i, ht, eq⟩, ⟨t, i, assume a ha, generate_open.basic _ (ht a ha), eq⟩
end

lemma pi_generate_from_eq_fintype {g : Πa, set (set (π a))} [fintype ι] (hg : ∀a, ⋃₀ g a = univ) :
  @Pi.topological_space ι π (λa, generate_from (g a)) =
  generate_from {t | ∃(s:Πa, set (π a)), (∀a, s a ∈ g a) ∧ t = pi univ s} :=
let G := {t | ∃(s:Πa, set (π a)), (∀a, s a ∈ g a) ∧ t = pi univ s} in
begin
  rw [pi_generate_from_eq],
  refine le_antisymm (generate_from_le _) (generate_from_mono _),
  { rintros s ⟨t, i, ht, rfl⟩,
    apply is_open_iff_forall_mem_open.2 _,
    assume f hf,
    choose c hc using show ∀a, ∃s, s ∈ g a ∧ f a ∈ s,
    { assume a, have : f a ∈ ⋃₀ g a, { rw [hg], apply mem_univ }, simpa },
    refine ⟨pi univ (λa, if a ∈ i then t a else (c : Πa, set (π a)) a), _, _, _⟩,
    { simp [pi_if] },
    { refine generate_open.basic _ ⟨_, assume a, _, rfl⟩,
      by_cases a ∈ i; simp [*, pi] at * },
    { have : f ∈ pi {a | a ∉ i} c, { simp [*, pi] at * },
      simpa [pi_if, hf] } },
  exact assume s ⟨t, ht, eq⟩, ⟨t, finset.univ, by simp [ht, eq]⟩
end

instance second_countable_topology_fintype
  [fintype ι] [t : ∀a, topological_space (π a)] [sc : ∀a, second_countable_topology (π a)] :
  second_countable_topology (∀a, π a) :=
have ∀i, ∃b : set (set (π i)), countable b ∧ ∅ ∉ b ∧ is_topological_basis b, from
  assume a, @is_open_generated_countable_inter (π a) _ (sc a),
let ⟨g, hg⟩ := classical.axiom_of_choice this in
have t = (λa, generate_from (g a)), from funext $ assume a, (hg a).2.2.2.2,
begin
  constructor,
  refine ⟨pi univ '' pi univ g, countable_image _ _, _⟩,
  { suffices : countable {f : Πa, set (π a) | ∀a, f a ∈ g a}, { simpa [pi] },
    exact countable_pi (assume i, (hg i).1), },
  rw [this, pi_generate_from_eq_fintype],
  { congr' 1, ext f, simp [pi, eq_comm] },
  exact assume a, (hg a).2.2.2.1
end

instance pi.compact [∀i:ι, topological_space (π i)] [∀i:ι, compact_space (π i)] : compact_space (Πi, π i) :=
⟨begin
  have A : compact {x : Πi:ι, π i | ∀i, x i ∈ (univ : set (π i))} :=
    compact_pi_infinite (λi, compact_univ),
  have : {x : Πi:ι, π i | ∀i, x i ∈ (univ : set (π i))} = univ := by ext; simp,
  rwa this at A,
end⟩

end pi

namespace list
variables [topological_space α] [topological_space β]

lemma tendsto_cons' {a : α} {l : list α} :
  tendsto (λp:α×list α, list.cons p.1 p.2) ((nhds a).prod (nhds l)) (nhds (a :: l)) :=
by rw [nhds_cons, tendsto, map_prod]; exact le_refl _

lemma tendsto_cons {f : α → β} {g : α → list β}
  {a : _root_.filter α} {b : β} {l : list β} (hf : tendsto f a (nhds b)) (hg : tendsto g a (nhds l)):
  tendsto (λa, list.cons (f a) (g a)) a (nhds (b :: l)) :=
(tendsto.prod_mk hf hg).comp tendsto_cons'

lemma tendsto_cons_iff [topological_space β]
  {f : list α → β} {b : _root_.filter β} {a : α} {l : list α} :
  tendsto f (nhds (a :: l)) b ↔ tendsto (λp:α×list α, f (p.1 :: p.2)) ((nhds a).prod (nhds l)) b :=
have nhds (a :: l) = ((nhds a).prod (nhds l)).map (λp:α×list α, (p.1 :: p.2)),
begin
  simp only
    [nhds_cons, filter.prod_eq, (filter.map_def _ _).symm, (filter.seq_eq_filter_seq _ _).symm],
  simp [-filter.seq_eq_filter_seq, -filter.map_def, (∘)] with functor_norm,
end,
by rw [this, filter.tendsto_map'_iff]

lemma tendsto_nhds [topological_space β]
  {f : list α → β} {r : list α → _root_.filter β}
  (h_nil : tendsto f (pure []) (r []))
  (h_cons : ∀l a, tendsto f (nhds l) (r l) → tendsto (λp:α×list α, f (p.1 :: p.2)) ((nhds a).prod (nhds l)) (r (a::l))) :
  ∀l, tendsto f (nhds l) (r l)
| []     := by rwa [nhds_nil]
| (a::l) := by rw [tendsto_cons_iff]; exact h_cons l a (tendsto_nhds l)

lemma continuous_at_length [topological_space α] :
  ∀(l : list α), continuous_at list.length l :=
begin
  simp only [continuous_at, nhds_discrete],
  refine tendsto_nhds _ _,
  { exact tendsto_pure_pure _ _ },
  { assume l a ih,
    dsimp only [list.length],
    refine tendsto.comp _ (tendsto_pure_pure (λx, x + 1) _),
    refine tendsto.comp tendsto_snd ih }
end

lemma tendsto_insert_nth' {a : α} : ∀{n : ℕ} {l : list α},
  tendsto (λp:α×list α, insert_nth n p.1 p.2) ((nhds a).prod (nhds l)) (nhds (insert_nth n a l))
| 0     l  := tendsto_cons'
| (n+1) [] :=
  suffices tendsto (λa, []) (nhds a) (nhds ([] : list α)),
    by simpa [nhds_nil, tendsto, map_prod, -filter.pure_def, (∘), insert_nth],
  tendsto_const_nhds
| (n+1) (a'::l) :=
  have (nhds a).prod (nhds (a' :: l)) =
    ((nhds a).prod ((nhds a').prod (nhds l))).map (λp:α×α×list α, (p.1, p.2.1 :: p.2.2)),
  begin
    simp only
      [nhds_cons, filter.prod_eq, (filter.map_def _ _).symm, (filter.seq_eq_filter_seq _ _).symm],
    simp [-filter.seq_eq_filter_seq, -filter.map_def, (∘)] with functor_norm
  end,
  begin
    rw [this, tendsto_map'_iff],
    exact tendsto_cons
      (tendsto_snd.comp tendsto_fst)
      ((tendsto.prod_mk tendsto_fst (tendsto_snd.comp tendsto_snd)).comp (@tendsto_insert_nth' n l))
  end

lemma tendsto_insert_nth {n : ℕ} {a : α} {l : list α} {f : β → α} {g : β → list α}
  {b : _root_.filter β} (hf : tendsto f b (nhds a)) (hg : tendsto g b (nhds l)) :
  tendsto (λb:β, insert_nth n (f b) (g b)) b (nhds (insert_nth n a l)) :=
(tendsto.prod_mk hf hg).comp tendsto_insert_nth'

lemma continuous_insert_nth {n : ℕ} : continuous (λp:α×list α, insert_nth n p.1 p.2) :=
continuous_iff_continuous_at.mpr $
  assume ⟨a, l⟩, by rw [continuous_at, nhds_prod_eq]; exact tendsto_insert_nth'

lemma tendsto_remove_nth : ∀{n : ℕ} {l : list α},
  tendsto (λl, remove_nth l n) (nhds l) (nhds (remove_nth l n))
| _ []      := by rw [nhds_nil]; exact tendsto_pure_nhds _ _
| 0 (a::l) := by rw [tendsto_cons_iff]; exact tendsto_snd
| (n+1) (a::l) :=
  begin
    rw [tendsto_cons_iff],
    dsimp [remove_nth],
    exact tendsto_cons tendsto_fst (tendsto_snd.comp (@tendsto_remove_nth n l))
  end

lemma continuous_remove_nth {n : ℕ} : continuous (λl : list α, remove_nth l n) :=
continuous_iff_continuous_at.mpr $ assume a, tendsto_remove_nth

end list

namespace vector
open list filter

instance (n : ℕ) [topological_space α] : topological_space (vector α n) :=
by unfold vector; apply_instance

lemma cons_val {n : ℕ} {a : α} : ∀{v : vector α n}, (a :: v).val = a :: v.val
| ⟨l, hl⟩ := rfl

lemma tendsto_cons [topological_space α] {n : ℕ} {a : α} {l : vector α n}:
  tendsto (λp:α×vector α n, vector.cons p.1 p.2) ((nhds a).prod (nhds l)) (nhds (a :: l)) :=
by
  simp [tendsto_subtype_rng, cons_val];
  exact tendsto_cons tendsto_fst (tendsto.comp tendsto_snd continuous_at_subtype_val)

lemma tendsto_insert_nth
  [topological_space α] {n : ℕ} {i : fin (n+1)} {a:α} :
  ∀{l:vector α n}, tendsto (λp:α×vector α n, insert_nth p.1 i p.2)
    ((nhds a).prod (nhds l)) (nhds (insert_nth a i l))
| ⟨l, hl⟩ :=
begin
  rw [insert_nth, tendsto_subtype_rng],
  simp [insert_nth_val],
  exact list.tendsto_insert_nth tendsto_fst (tendsto.comp tendsto_snd continuous_at_subtype_val)
end

lemma continuous_insert_nth' [topological_space α] {n : ℕ} {i : fin (n+1)} :
  continuous (λp:α×vector α n, insert_nth p.1 i p.2) :=
continuous_iff_continuous_at.mpr $ assume ⟨a, l⟩,
  by rw [continuous_at, nhds_prod_eq]; exact tendsto_insert_nth

lemma continuous_insert_nth [topological_space α] [topological_space β] {n : ℕ} {i : fin (n+1)}
  {f : β → α} {g : β → vector α n} (hf : continuous f) (hg : continuous g) :
  continuous (λb, insert_nth (f b) i (g b)) :=
continuous.comp (continuous.prod_mk hf hg) continuous_insert_nth'

lemma continuous_at_remove_nth [topological_space α] {n : ℕ} {i : fin (n+1)} :
  ∀{l:vector α (n+1)}, continuous_at (remove_nth i) l
| ⟨l, hl⟩ :=
--  ∀{l:vector α (n+1)}, tendsto (remove_nth i) (nhds l) (nhds (remove_nth i l))
--| ⟨l, hl⟩ :=
begin
  rw [continuous_at, remove_nth, tendsto_subtype_rng],
  simp [remove_nth_val],
  exact continuous_at_subtype_val.comp list.tendsto_remove_nth
end

lemma continuous_remove_nth [topological_space α] {n : ℕ} {i : fin (n+1)} :
  continuous (remove_nth i : vector α (n+1) → vector α n) :=
continuous_iff_continuous_at.mpr $ assume ⟨a, l⟩, continuous_at_remove_nth

end vector

namespace dense_embedding
variables [topological_space α] [topological_space β] [topological_space γ] [topological_space δ]

/-- The product of two dense embeddings is a dense embedding -/
protected def prod {e₁ : α → β} {e₂ : γ → δ} (de₁ : dense_embedding e₁) (de₂ : dense_embedding e₂) :
  dense_embedding (λ(p : α × γ), (e₁ p.1, e₂ p.2)) :=
{ dense_embedding .
  dense   :=
    have closure (range (λ(p : α × γ), (e₁ p.1, e₂ p.2))) =
        set.prod (closure (range e₁)) (closure (range e₂)),
      by rw [←closure_prod_eq, prod_range_range_eq],
    assume ⟨b, d⟩, begin rw [this], simp, constructor, apply de₁.dense, apply de₂.dense end,
  inj     := assume ⟨x₁, x₂⟩ ⟨y₁, y₂⟩,
    by simp; exact assume h₁ h₂, ⟨de₁.inj h₁, de₂.inj h₂⟩,
  induced := assume ⟨a, b⟩,
    by rw [nhds_prod_eq, nhds_prod_eq, ←prod_comap_comap_eq, de₁.induced, de₂.induced] }

def subtype_emb (p : α → Prop) {e : α → β} (de : dense_embedding e) (x : {x // p x}) :
  {x // x ∈ closure (e '' {x | p x})} :=
⟨e x.1, subset_closure $ mem_image_of_mem e x.2⟩

protected def subtype (p : α → Prop) {e : α → β} (de : dense_embedding e) :
  dense_embedding (de.subtype_emb p) :=
{ dense_embedding .
  dense   := assume ⟨x, hx⟩, closure_subtype.mpr $
    have (λ (x : {x // p x}), e (x.val)) = e ∘ subtype.val, from rfl,
    begin
      rw ← image_univ,
      simp [(image_comp _ _ _).symm, (∘), subtype_emb, -image_univ],
      rw [this, image_comp, subtype.val_image],
      simp,
      assumption
    end,
  inj     := assume ⟨x, hx⟩ ⟨y, hy⟩ h, subtype.eq $ de.inj $ @@congr_arg subtype.val h,
  induced := assume ⟨x, hx⟩,
    by simp [subtype_emb, nhds_subtype_eq_comap, comap_comap_comp, (∘), (de.induced x).symm] }

end dense_embedding

lemma is_closed_property [topological_space α] [topological_space β] {e : α → β} {p : β → Prop}
  (he : closure (range e) = univ) (hp : is_closed {x | p x}) (h : ∀a, p (e a)) :
  ∀b, p b :=
have univ ⊆ {b | p b},
  from calc univ = closure (range e) : he.symm
    ... ⊆ closure {b | p b} : closure_mono $ range_subset_iff.mpr h
    ... = _ : closure_eq_of_is_closed hp,
assume b, this trivial

lemma is_closed_property2 [topological_space α] [topological_space β] {e : α → β} {p : β → β → Prop}
  (he : dense_embedding e) (hp : is_closed {q:β×β | p q.1 q.2}) (h : ∀a₁ a₂, p (e a₁) (e a₂)) :
  ∀b₁ b₂, p b₁ b₂ :=
have ∀q:β×β, p q.1 q.2,
  from is_closed_property (he.prod he).closure_range hp $ assume a, h _ _,
assume b₁ b₂, this ⟨b₁, b₂⟩

lemma is_closed_property3 [topological_space α] [topological_space β] {e : α → β} {p : β → β → β → Prop}
  (he : dense_embedding e) (hp : is_closed {q:β×β×β | p q.1 q.2.1 q.2.2}) (h : ∀a₁ a₂ a₃, p (e a₁) (e a₂) (e a₃)) :
  ∀b₁ b₂ b₃, p b₁ b₂ b₃ :=
have ∀q:β×β×β, p q.1 q.2.1 q.2.2,
  from is_closed_property (he.prod $ he.prod he).closure_range hp $ assume ⟨a₁, a₂, a₃⟩, h _ _ _,
assume b₁ b₂ b₃, this ⟨b₁, b₂, b₃⟩

lemma mem_closure_of_continuous [topological_space α] [topological_space β]
  {f : α → β} {a : α} {s : set α} {t : set β}
  (hf : continuous f) (ha : a ∈ closure s) (h : ∀a∈s, f a ∈ closure t) :
  f a ∈ closure t :=
calc f a ∈ f '' closure s : mem_image_of_mem _ ha
  ... ⊆ closure (f '' s) : image_closure_subset_closure_image hf
  ... ⊆ closure (closure t) : closure_mono $ image_subset_iff.mpr $ h
  ... ⊆ closure t : begin rw [closure_eq_of_is_closed], exact subset.refl _, exact is_closed_closure end

lemma mem_closure_of_continuous2 [topological_space α] [topological_space β] [topological_space γ]
  {f : α → β → γ} {a : α} {b : β} {s : set α} {t : set β} {u : set γ}
  (hf : continuous (λp:α×β, f p.1 p.2)) (ha : a ∈ closure s) (hb : b ∈ closure t)
  (h : ∀a∈s, ∀b∈t, f a b ∈ closure u) :
  f a b ∈ closure u :=
have (a,b) ∈ closure (set.prod s t),
  by simp [closure_prod_eq, ha, hb],
show f (a, b).1 (a, b).2 ∈ closure u,
  from @mem_closure_of_continuous (α×β) _ _ _ (λp:α×β, f p.1 p.2) (a,b) _ u hf this $
    assume ⟨p₁, p₂⟩ ⟨h₁, h₂⟩, h p₁ h₁ p₂ h₂

/-- α and β are homeomorph, also called topological isomoph -/
structure homeomorph (α : Type*) (β : Type*) [topological_space α] [topological_space β]
  extends α ≃ β :=
(continuous_to_fun  : continuous to_fun)
(continuous_inv_fun : continuous inv_fun)

infix ` ≃ₜ `:50 := homeomorph

namespace homeomorph
variables [topological_space α] [topological_space β] [topological_space γ] [topological_space δ]

instance : has_coe_to_fun (α ≃ₜ β) := ⟨λ_, α → β, λe, e.to_equiv⟩

lemma coe_eq_to_equiv (h : α ≃ₜ β) (a : α) : h a = h.to_equiv a := rfl

protected def refl (α : Type*) [topological_space α] : α ≃ₜ α :=
{ continuous_to_fun := continuous_id, continuous_inv_fun := continuous_id, .. equiv.refl α }

protected def trans (h₁ : α ≃ₜ β) (h₂ : β ≃ₜ γ) : α ≃ₜ γ :=
{ continuous_to_fun  := h₁.continuous_to_fun.comp h₂.continuous_to_fun,
  continuous_inv_fun := h₂.continuous_inv_fun.comp h₁.continuous_inv_fun,
  .. equiv.trans h₁.to_equiv h₂.to_equiv }

protected def symm (h : α ≃ₜ β) : β ≃ₜ α :=
{ continuous_to_fun  := h.continuous_inv_fun,
  continuous_inv_fun := h.continuous_to_fun,
  .. h.to_equiv.symm }

protected def continuous (h : α ≃ₜ β) : continuous h := h.continuous_to_fun

lemma symm_comp_self (h : α ≃ₜ β) : ⇑h.symm ∘ ⇑h = id :=
funext $ assume a, h.to_equiv.left_inv a

lemma self_comp_symm (h : α ≃ₜ β) : ⇑h ∘ ⇑h.symm = id :=
funext $ assume a, h.to_equiv.right_inv a

lemma range_coe (h : α ≃ₜ β) : range h = univ :=
eq_univ_of_forall $ assume b, ⟨h.symm b, congr_fun h.self_comp_symm b⟩

lemma image_symm (h : α ≃ₜ β) : image h.symm = preimage h :=
image_eq_preimage_of_inverse h.symm.to_equiv.left_inv h.symm.to_equiv.right_inv

lemma preimage_symm (h : α ≃ₜ β) : preimage h.symm = image h :=
(image_eq_preimage_of_inverse h.to_equiv.left_inv h.to_equiv.right_inv).symm

lemma induced_eq
  {α : Type*} {β : Type*} [tα : topological_space α] [tβ : topological_space β] (h : α ≃ₜ β) :
  tβ.induced h = tα :=
le_antisymm
  (induced_le_iff_le_coinduced.2 h.continuous)
  (calc tα = (tα.induced h.symm).induced h : by rw [induced_compose, symm_comp_self, induced_id]
    ... ≤ tβ.induced h : induced_mono $ (induced_le_iff_le_coinduced.2 h.symm.continuous))

lemma coinduced_eq
  {α : Type*} {β : Type*} [tα : topological_space α] [tβ : topological_space β] (h : α ≃ₜ β) :
  tα.coinduced h = tβ :=
le_antisymm
  (calc tα.coinduced h ≤ (tβ.coinduced h.symm).coinduced h : coinduced_mono h.symm.continuous
    ... = tβ : by rw [coinduced_compose, self_comp_symm, coinduced_id])
  h.continuous

lemma compact_image {s : set α} (h : α ≃ₜ β) : compact (h '' s) ↔ compact s :=
⟨λ hs, by have := compact_image hs h.symm.continuous;
  rwa [← image_comp, symm_comp_self, image_id] at this,
λ hs, compact_image hs h.continuous⟩

lemma compact_preimage {s : set β} (h : α ≃ₜ β) : compact (h ⁻¹' s) ↔ compact s :=
by rw ← image_symm; exact h.symm.compact_image

protected lemma embedding (h : α ≃ₜ β) : embedding h :=
⟨h.to_equiv.injective, h.induced_eq.symm⟩

protected lemma dense_embedding (h : α ≃ₜ β) : dense_embedding h :=
{ dense   := assume a, by rw [h.range_coe, closure_univ]; trivial,
  inj     := h.to_equiv.injective,
  induced := assume a, by rw [← nhds_induced_eq_comap, h.induced_eq] }

protected lemma is_open_map (h : α ≃ₜ β) : is_open_map h :=
begin
  assume s,
  rw ← h.preimage_symm,
  exact h.symm.continuous s
end

protected lemma quotient_map (h : α ≃ₜ β) : quotient_map h :=
⟨h.to_equiv.surjective, h.coinduced_eq.symm⟩

def prod_congr (h₁ : α ≃ₜ β) (h₂ : γ ≃ₜ δ) : (α × γ) ≃ₜ (β × δ) :=
{ continuous_to_fun  :=
    continuous.prod_mk (continuous_fst.comp h₁.continuous) (continuous_snd.comp h₂.continuous),
  continuous_inv_fun :=
    continuous.prod_mk (continuous_fst.comp h₁.symm.continuous) (continuous_snd.comp h₂.symm.continuous),
  .. h₁.to_equiv.prod_congr h₂.to_equiv }

section
variables (α β γ)

def prod_comm : (α × β) ≃ₜ (β × α) :=
{ continuous_to_fun  := continuous.prod_mk continuous_snd continuous_fst,
  continuous_inv_fun := continuous.prod_mk continuous_snd continuous_fst,
  .. equiv.prod_comm α β }

def prod_assoc : ((α × β) × γ) ≃ₜ (α × (β × γ)) :=
{ continuous_to_fun  :=
    continuous.prod_mk (continuous_fst.comp continuous_fst)
      (continuous.prod_mk (continuous_fst.comp continuous_snd) continuous_snd),
  continuous_inv_fun := continuous.prod_mk
      (continuous.prod_mk continuous_fst (continuous_snd.comp continuous_fst))
      (continuous_snd.comp continuous_snd),
  .. equiv.prod_assoc α β γ }

end

end homeomorph


import lambda_calculus.utlc.beta.distance
import complexity.basic
import lambda_calculus.utlc.beta.encoding.basic

namespace lambda_calculus
namespace utlc
namespace β
namespace encoding
namespace nat

@[reducible] def iterate (f: utlc) (n: ℕ) (g: utlc): utlc := (λ x, f·x)^[n] g

section
local notation a `[` b `:=` c  `]` : 70 := has_substitution.substitution a b c

@[simp] theorem iterate_substitution {n m: ℕ} {f g x: utlc}:
  (iterate f n g)[m:=x] = (iterate (f[m:=x]) n (g[m:=x])) :=
begin
  induction n;
  simp[iterate, function.iterate_succ'],
  apply n_ih
end

@[simp] theorem iterate_shift {n m: ℕ} {f g: utlc}:
  (iterate f n g) ↑¹ m = (iterate (f ↑¹ m) n (g ↑¹ m)) :=
begin
  induction n,
  all_goals { simp[iterate, function.iterate_succ'] },
  apply n_ih
end
end

instance church_nat_encoding:
  complexity.has_encoding church_model ℕ := ⟨ ⟨ λ n,
    ⟨ (Λ Λ iterate (↓1:utlc) n ↓0: utlc),
      begin
        induction n,
        { simp [iterate] },
        simp only [iterate, lambda_reduced, lambda_closed_below,
          zero_add, one_add_one_eq_two, closed] at n_ih,
        simp [function.iterate_succ', iterate, n_ih],
      end
    ⟩,
    begin
      intros x y,
      cases le_total x y;
      cases nat.exists_eq_add_of_le h with z h;
      rw [h];
      clear h;
      simp only [iterate, value_inj, lambda_eq_lambda_iff, self_eq_add_right];
      cases z;
      try { { simp } };
      clear h,
      { induction x,
        { simp [function.iterate_succ'] },
        simp [function.iterate_succ', nat.succ_add, x_ih] },
      { induction y,
        { simp [function.iterate_succ'] },
        simp [function.iterate_succ', nat.succ_add, y_ih], }
    end ⟩ ⟩

-- instance compute_nat_encoding:
--   complexity.has_encoding compute_model ℕ := ⟨ ⟨ λ n,

--   end ⟩ ⟩

end nat
end encoding
end β
end utlc
end lambda_calculus


import data.complex.basic
import data.nat.totient

open nat
open complex

local notation `φ` := totient

structure arithmetic : Type :=
(f : ℕ → ℂ)

notation `𝔸` := arithmetic

@[simp] theorem eta : ∀ f : 𝔸, arithmetic.mk f.f = f
| ⟨a⟩ := rfl

@[extensionality] theorem ext : ∀ {f g : 𝔸}, f.f = g.f → f = g
| ⟨_⟩ ⟨_⟩ rfl := rfl

@[extensionality] theorem ext' : ∀ {f g : 𝔸}, (∀ (n : ℕ), f.f n = g.f n) → f = g :=
begin
    intros f g h,
    have w := funext h,
    simp at w,
    exact (ext w),
end

instance : has_zero 𝔸 := ⟨arithmetic.mk (λ n, 0)⟩
instance : inhabited 𝔸 := ⟨0⟩
instance : has_add 𝔸 := ⟨λ f g, arithmetic.mk (λ n, f.f n + g.f n)⟩

lemma zerof (n : ℕ) : ((0 : 𝔸).f n) = 0 := by refl
lemma zerof_re (n : ℕ) : ((0 : 𝔸).f n).re = 0 := by {rw [zerof], refl}
lemma zerof_im (n : ℕ) : ((0 : 𝔸).f n).im = 0 := by {rw [zerof], refl}

theorem arithmetic_add_zero (f : 𝔸) : f + 0 = f :=
begin
    apply ext',
    intros n,
    dsimp [(+), 0],
    rw [zerof_re, zerof_im],
    have w_re : distrib.add (f.f n).re 0 = (f.f n).re := by exact add_zero _,
    have w_im : distrib.add (f.f n).im 0 = (f.f n).im := by exact add_zero _,
    rw [w_re, w_im],
    simp only [complex.eta],
end

theorem arithmetic_add_comm (f g : 𝔸) : f + g = g + f :=
begin
    apply ext',
    intros n,
    dsimp [(+)],
    have w₁ : distrib.add (f.f n).re (g.f n).re = distrib.add (g.f n).re (f.f n).re := by exact add_comm _ _,
    have w₂ : distrib.add (f.f n).im (g.f n).im = distrib.add (g.f n).im (f.f n).im := by exact add_comm _ _,
    rw [w₁, w₂],
end

theorem arithmetic_zero_add (f : 𝔸) : 0 + f = f :=
begin
    rw [arithmetic_add_comm],
    exact arithmetic_add_zero f,
end

theorem arithmetic_add_assoc (f g h : 𝔸) : (f + g) + h = f + (g + h) :=
begin
    apply ext',
    intros n,
    dsimp [(+)],
    have w₁ : distrib.add (distrib.add ((f.f n).re) ((g.f n).re)) ((h.f n).re) = distrib.add ((f.f n).re) (distrib.add ((g.f n).re) ((h.f n).re)) := by exact add_assoc _ _ _,
    have w₂ : distrib.add (distrib.add ((f.f n).im) ((g.f n).im)) ((h.f n).im) = distrib.add ((f.f n).im) (distrib.add ((g.f n).im) ((h.f n).im)) := by exact add_assoc _ _ _,
    rw [w₁, w₂],
end

instance : add_comm_monoid 𝔸 :=
{add := (+), add_assoc := arithmetic_add_assoc, zero := 0, zero_add := arithmetic_zero_add, add_zero := arithmetic_add_zero, add_comm := arithmetic_add_comm}

instance : has_neg 𝔸 := ⟨λ f, arithmetic.mk (λ n, - f.f n)⟩

theorem arithmetic_add_left_neg (f : 𝔸) : -f + f = 0 :=
begin
    apply ext',
    intros n,
    dsimp [(+), has_neg.neg],
    have w₁ : distrib.add (add_group.neg ((f.f n).re)) ((f.f n).re) = ((0 : 𝔸).f n).re := begin
        have k₁ := sub_self (f.f n).re,
        have k₂ : distrib.add (add_group.neg ((f.f n).re)) ((f.f n).re) = -((f.f n).re) + ((f.f n).re) := by refl,
        have k₃ : (f.f n).re - (f.f n).re = (f.f n).re + -(f.f n).re := by refl,
        have k₄ : ((0 : 𝔸).f n).re = 0 := by refl,
        rw [add_comm, ←k₃, k₁, ←k₄] at k₂,
        exact k₂,
    end,
    have w₂ : distrib.add (add_group.neg ((f.f n).im)) ((f.f n).im) = ((0 : 𝔸).f n).im := begin
        have k₁ := sub_self (f.f n).im,
        have k₂ : distrib.add (add_group.neg ((f.f n).im)) ((f.f n).im) = -((f.f n).im) + ((f.f n).im) := by refl,
        have k₃ : (f.f n).im - (f.f n).im = (f.f n).im + -(f.f n).im := by refl,
        have k₄ : ((0 : 𝔸).f n).im = 0 := by refl,
        rw [add_comm, ←k₃, k₁, ←k₄] at k₂,
        exact k₂,
    end,
    rw [w₁, w₂],
    refl,
end

instance : add_comm_group 𝔸 :=
{neg := (has_neg.neg), add_left_neg := arithmetic_add_left_neg, .. (by apply_instance : add_comm_monoid 𝔸)}

instance : has_one 𝔸 := ⟨arithmetic.mk (λ n, if n ≤ 1 then 1 else 0)⟩
instance : has_mul 𝔸 := ⟨λ f g, arithmetic.mk (λ n, if n ≤ 1 then (f.f n) * (g.f n) else list.sum (list.map (λ d, f.f d * g.f (n / d)) (factors n)))⟩

lemma mul_one_case_zero (f : 𝔸) : (f * 1).f 0 = f.f 0 :=
begin
    dsimp [(*)],
    simp,
    have w₁ : ((1 : 𝔸).f 0).re = 1 := by refl,
    have w₂ : ((1 : 𝔸).f 0).im = 0 := by refl,
    have w₃ : no_zero_divisors.mul ((f.f 0).re) 1 = (f.f 0).re := by exact mul_one _,
    have w₄ : (no_zero_divisors.mul ((f.f 0).im)) 0 = 0 := by exact mul_zero _,
    have w₅ : no_zero_divisors.mul ((f.f 0).im) 1 = (f.f 0).im := by exact mul_one _,
    have w₆ : (no_zero_divisors.mul ((f.f 0).re)) 0 = 0 := by exact mul_zero _,
    rw [w₁, w₂, w₃, w₄, w₅, w₆],
    simp,
end

lemma mul_one_case_one (f : 𝔸) : (f * 1).f 1 = f.f 1 :=
begin
    dsimp [(*)],
    have w : 1 ≤ 1 := by linarith,
    simp [w],
    have w₁ : ((1 : 𝔸).f 1).re = 1 := by refl,
    have w₂ : ((1 : 𝔸).f 1).im = 0 := by refl,
    have w₃ : no_zero_divisors.mul ((f.f 1).re) 1 = (f.f 1).re := by exact mul_one _,
    have w₄ : (no_zero_divisors.mul ((f.f 1).im)) 0 = 0 := by exact mul_zero _,
    have w₅ : no_zero_divisors.mul ((f.f 1).im) 1 = (f.f 1).im := by exact mul_one _,
    have w₆ : (no_zero_divisors.mul ((f.f 1).re)) 0 = 0 := by exact mul_zero _,
    rw [w₁, w₂, w₃, w₄, w₅, w₆],
    simp,
end
.

theorem arithmetic_mul_one (f : 𝔸) : f * 1 = f :=
begin
    apply ext',
    intros n,
    cases n,

    exact mul_one_case_zero f,

    cases n,

    exact mul_one_case_one f,

    dsimp [(*)],
    have w : n + 2 > 1 := by linarith,
    dsimp [(>)] at w,
    rw [lt_iff_not_ge] at w,
    dsimp [(≥)] at w,
    simp [w],

    sorry,

end

lemma mul_comm_case_zero (f g : 𝔸) : (f*g).f 0 = (g*f).f 0 :=
begin
    dsimp [(*)],
    simp,
    split,

    have k₁ : no_zero_divisors.mul ((f.f 0).re) ((g.f 0).re) = no_zero_divisors.mul ((g.f 0).re) ((f.f 0).re) := by exact mul_comm _ _,
    have k₂ : no_zero_divisors.mul ((f.f 0).im) ((g.f 0).im) = no_zero_divisors.mul ((g.f 0).im) ((f.f 0).im) := by exact mul_comm _ _,
    rw [k₁, k₂],

    rw [add_comm],
    have k₁ : no_zero_divisors.mul ((f.f 0).re) ((g.f 0).im) = no_zero_divisors.mul ((g.f 0).im) ((f.f 0).re) := by exact mul_comm _ _,
    have k₂ : no_zero_divisors.mul ((f.f 0).im) ((g.f 0).re) = no_zero_divisors.mul ((g.f 0).re) ((f.f 0).im) := by exact mul_comm _ _,
    rw [k₁, k₂],
end

lemma mul_comm_case_one (f g : 𝔸) : (f*g).f 1 = (g*f).f 1 :=
begin
    dsimp [(*)],
    have w : 1 ≤ 1 := by linarith,
    simp [w],
    split,

    have k₁ : no_zero_divisors.mul ((f.f 1).re) ((g.f 1).re) = no_zero_divisors.mul ((g.f 1).re) ((f.f 1).re) := by exact mul_comm _ _,
    have k₂ : no_zero_divisors.mul ((f.f 1).im) ((g.f 1).im) = no_zero_divisors.mul ((g.f 1).im) ((f.f 1).im) := by exact mul_comm _ _,
    rw [k₁, k₂],

    rw [add_comm],
    have k₁ : no_zero_divisors.mul ((f.f 1).re) ((g.f 1).im) = no_zero_divisors.mul ((g.f 1).im) ((f.f 1).re) := by exact mul_comm _ _,
    have k₂ : no_zero_divisors.mul ((f.f 1).im) ((g.f 1).re) = no_zero_divisors.mul ((g.f 1).re) ((f.f 1).im) := by exact mul_comm _ _,
    rw [k₁, k₂],
end

theorem arithmetic_mul_comm (f g : 𝔸) : f*g = g*f :=
begin
    apply ext',
    intros n,
    cases n,

    exact mul_comm_case_zero f g,

    cases n,

    exact mul_comm_case_one f g,

    sorry,
end

theorem arithmetic_one_mul (f : 𝔸) : 1 * f = f :=
begin
    rw [arithmetic_mul_comm],
    exact arithmetic_mul_one f,
end

lemma mul_assoc_case_zero (f g h : 𝔸) : ((f*g)*h).f 0 = (f*(g*h)).f 0 :=
begin
    dsimp [(*)],
    simp,
    split,

    sorry,
    sorry,
end

lemma mul_assoc_case_one (f g h : 𝔸) : ((f*g)*h).f 1 = (f*(g*h)).f 1 :=
begin
    sorry,
end

theorem arithmetic_mul_assoc (f g h : 𝔸) : (f * g) * h = f * (g * h) :=
begin
    apply ext',
    intros n,
    cases n,

    exact mul_assoc_case_zero f g h,

    cases n,

    exact mul_assoc_case_one f g h,

    sorry,
end

theorem arithmetic_left_distrib (f g h : 𝔸) : f * (g + h) = f * g + f * h :=
begin
    apply ext',
    intros n,

    sorry,
end

theorem arithmetic_right_distrib (f g h : 𝔸) : (f + g) * h = f * h + g * h :=
begin
    rw [arithmetic_mul_comm, arithmetic_left_distrib],
    repeat {rw [arithmetic_mul_comm h]},
end

instance : comm_ring 𝔸 :=
{mul := (*), mul_one := arithmetic_mul_one, mul_assoc := arithmetic_mul_assoc,
 one := 1, one_mul := arithmetic_one_mul, left_distrib := arithmetic_left_distrib,
 right_distrib := arithmetic_right_distrib, mul_comm := arithmetic_mul_comm,
 .. (by apply_instance : add_comm_group 𝔸)}

def mult (f : 𝔸) := f.f 0 = 0 ∧ f.f 1 = 1 ∧ (∀ (a b : ℕ), gcd a b = 1 → f.f (a*b) = f.f a * f.f b)

@[simp] lemma val_of_zero_one (f : 𝔸) (h : mult f) : f.f 0 = 0 :=
begin
    dsimp [mult] at h,
    cases h,
    exact h_left,
end

@[simp] lemma val_if_one_one (f : 𝔸) (h : mult f) : f.f 1 = 1 :=
begin
    dsimp [mult] at h,
    cases h,
    cases h_right,
    exact h_right_left,
end

def Φ : 𝔸 := arithmetic.mk (λ n, of_real ( φ n : ℝ))

theorem Φ_mult : mult Φ :=
begin
    dsimp [mult],
    repeat {split},

    dsimp[Φ],
    have h : φ 1 = 1 := rfl,
    rw h,
    simp,

    intros a b h,
    dsimp [Φ],
    simp,
    sorry,

end


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import logic.equiv.basic
import tactic.clear
import tactic.simp_result
import tactic.apply
import control.equiv_functor.instances -- these make equiv_rw more powerful!
import logic.equiv.functor              -- so do these!

/-!
# The `equiv_rw` tactic transports goals or hypotheses along equivalences.

The basic syntax is `equiv_rw e`, where `e : α ≃ β` is an equivalence.
This will try to replace occurrences of `α` in the goal with `β`, for example
transforming
* `⊢ α` to `⊢ β`,
* `⊢ option α` to `⊢ option β`
* `⊢ {a // P}` to `{b // P (⇑(equiv.symm e) b)}`

The tactic can also be used to rewrite hypotheses, using the syntax `equiv_rw e at h`.

## Implementation details

The main internal function is `equiv_rw_type e t`,
which attempts to turn an expression `e : α ≃ β` into a new equivalence with left hand side `t`.
As an example, with `t = option α`, it will generate `functor.map_equiv option e`.

This is achieved by generating a new synthetic goal `%%t ≃ _`,
and calling `solve_by_elim` with an appropriate set of congruence lemmas.
To avoid having to specify the relevant congruence lemmas by hand,
we mostly rely on `equiv_functor.map_equiv` and `bifunctor.map_equiv`
along with some structural congruence lemmas such as
* `equiv.arrow_congr'`,
* `equiv.subtype_equiv_of_subtype'`,
* `equiv.sigma_congr_left'`, and
* `equiv.Pi_congr_left'`.

The main `equiv_rw` function, when operating on the goal, simply generates a new equivalence `e'`
with left hand side matching the target, and calls `apply e'.inv_fun`.

When operating on a hypothesis `x : α`, we introduce a new fact `h : x = e.symm (e x)`, revert this,
and then attempt to `generalize`, replacing all occurrences of `e x` with a new constant `y`, before
`intro`ing and `subst`ing `h`, and renaming `y` back to `x`.

## Future improvements
In a future PR I anticipate that `derive equiv_functor` should work on many examples,
(internally using `transport`, which is in turn based on `equiv_rw`)
and we can incrementally bootstrap the strength of `equiv_rw`.

An ambitious project might be to add `equiv_rw!`,
a tactic which, when failing to find appropriate `equiv_functor` instances,
attempts to `derive` them on the spot.

For now `equiv_rw` is entirely based on `equiv`,
but the framework can readily be generalised to also work with other types of equivalences,
for example specific notations such as ring equivalence (`≃+*`),
or general categorical isomorphisms (`≅`).

This will allow us to transport across more general types of equivalences,
but this will wait for another subsequent PR.
-/

namespace tactic

/-- A list of lemmas used for constructing congruence equivalences. -/

-- Although this looks 'hard-coded', in fact the lemma `equiv_functor.map_equiv`
-- allows us to extend `equiv_rw` simply by constructing new instance so `equiv_functor`.

-- TODO: We should also use `category_theory.functorial` and `category_theory.hygienic` instances.
-- (example goal: we could rewrite along an isomorphism of rings (either as `R ≅ S` or `R ≃+* S`)
-- and turn an `x : mv_polynomial σ R` into an `x : mv_polynomial σ S`.).

meta def equiv_congr_lemmas : list (tactic expr) :=
[ `equiv.of_iff,
  -- TODO decide what to do with this; it's an equiv_bifunctor?
  `equiv.equiv_congr,
  -- The function arrow is technically a bifunctor `Typeᵒᵖ → Type → Type`,
  -- but the pattern matcher will never see this.
  `equiv.arrow_congr',
  -- Allow rewriting in subtypes:
  `equiv.subtype_equiv_of_subtype',
  -- Allow rewriting in the first component of a sigma-type:
  `equiv.sigma_congr_left',
  -- Allow rewriting ∀s:
  -- (You might think that repeated application of `equiv.forall_congr'
  -- would handle the higher arity cases, but unfortunately unification is not clever enough.)
  `equiv.forall₃_congr',
  `equiv.forall₂_congr',
  `equiv.forall_congr',
  -- Allow rewriting in argument of Pi types:
   `equiv.Pi_congr_left',
  -- Handles `sum` and `prod`, and many others:
  `bifunctor.map_equiv,
  -- Handles `list`, `option`, `unique`, and many others:
  `equiv_functor.map_equiv,
  -- We have to filter results to ensure we don't cheat and use exclusively
  -- `equiv.refl` and `iff.refl`!
  `equiv.refl,
  `iff.refl
  ].map (λ n, mk_const n)

declare_trace equiv_rw_type

/--
Configuration structure for `equiv_rw`.

* `max_depth` bounds the search depth for equivalences to rewrite along.
  The default value is 10.
  (e.g., if you're rewriting along `e : α ≃ β`, and `max_depth := 2`,
  you can rewrite `option (option α))` but not `option (option (option α))`.
-/
meta structure equiv_rw_cfg :=
(max_depth : ℕ := 10)

/--
Implementation of `equiv_rw_type`, using `solve_by_elim`.
Expects a goal of the form `t ≃ _`,
and tries to solve it using `eq : α ≃ β` and congruence lemmas.
-/
meta def equiv_rw_type_core (eq : expr) (cfg : equiv_rw_cfg) : tactic unit :=
do
  /-
    We now call `solve_by_elim` to try to generate the requested equivalence.
    There are a few subtleties!
    * We make sure that `eq` is the first lemma, so it is applied whenever possible.
    * In `equiv_congr_lemmas`, we put `equiv.refl` last so it is only used when it is not possible
      to descend further.
    * Since some congruence lemmas generate subgoals with `∀` statements,
      we use the `pre_apply` subtactic of `solve_by_elim` to preprocess each new goal with `intros`.
  -/
  solve_by_elim
  { use_symmetry := false,
    use_exfalso := false,
    lemma_thunks := some (pure eq :: equiv_congr_lemmas),
    ctx_thunk := pure [],
    max_depth := cfg.max_depth,
    -- Subgoals may contain function types,
    -- and we want to continue trying to construct equivalences after the binders.
    pre_apply := tactic.intros >> skip,
    backtrack_all_goals := tt,
    -- If solve_by_elim gets stuck, make sure it isn't because there's a later `≃` or `↔` goal
    -- that we should still attempt.
    discharger :=
      `[success_if_fail { match_target _ ≃ _ }] >> `[success_if_fail { match_target _ ↔ _ }] >>
      (`[show _ ≃ _] <|> `[show _ ↔ _]) <|>
      trace_if_enabled `equiv_rw_type "Failed, no congruence lemma applied!" >> failed,
    -- We use the `accept` tactic in `solve_by_elim` to provide tracing.
    accept := λ goals, lock_tactic_state (do
      when_tracing `equiv_rw_type (do
        goals.mmap pp >>= λ goals, trace format!"So far, we've built: {goals}"),
      done <|>
      when_tracing `equiv_rw_type (do
        gs ← get_goals,
        gs ← gs.mmap (λ g, infer_type g >>= pp),
        trace format!"Attempting to adapt to {gs}")) }

/--
`equiv_rw_type e t` rewrites the type `t` using the equivalence `e : α ≃ β`,
returning a new equivalence `t ≃ t'`.
-/
meta def equiv_rw_type (eqv : expr) (ty : expr) (cfg : equiv_rw_cfg) : tactic expr :=
do
  when_tracing `equiv_rw_type (do
    ty_pp ← pp ty,
    eqv_pp ← pp eqv,
    eqv_ty_pp ← infer_type eqv >>= pp,
    trace format!"Attempting to rewrite the type `{ty_pp}` using `{eqv_pp} : {eqv_ty_pp}`."),
  `(_ ≃ _) ← infer_type eqv | fail format!"{eqv} must be an `equiv`",
  -- We prepare a synthetic goal of type `(%%ty ≃ _)`, for some placeholder right hand side.
  equiv_ty ← to_expr ``(%%ty ≃ _),
  -- Now call `equiv_rw_type_core`.
  new_eqv ← prod.snd <$> (solve_aux equiv_ty $ equiv_rw_type_core eqv cfg),
  -- Check that we actually used the equivalence `eq`
  -- (`equiv_rw_type_core` will always find `equiv.refl`,
  -- but hopefully only after all other possibilities)
  new_eqv ← instantiate_mvars new_eqv,
  -- We previously had `guard (eqv.occurs new_eqv)` here, but `kdepends_on` is more reliable.
  kdepends_on new_eqv eqv >>= guardb <|> (do
    eqv_pp ← pp eqv,
    ty_pp ← pp ty,
    fail format!"Could not construct an equivalence from {eqv_pp} of the form: {ty_pp} ≃ _"),
  -- Finally we simplify the resulting equivalence,
  -- to compress away some `map_equiv equiv.refl` subexpressions.
  prod.fst <$> new_eqv.simp {fail_if_unchanged := ff}

mk_simp_attribute equiv_rw_simp "The simpset `equiv_rw_simp` is used by the tactic `equiv_rw` to
simplify applications of equivalences and their inverses."

attribute [equiv_rw_simp] equiv.symm_symm equiv.apply_symm_apply equiv.symm_apply_apply

/--
Attempt to replace the hypothesis with name `x`
by transporting it along the equivalence in `e : α ≃ β`.
-/
meta def equiv_rw_hyp (x : name) (e : expr) (cfg : equiv_rw_cfg := {}) : tactic unit :=
-- We call `dsimp_result` to perform the beta redex introduced by `revert`
dsimp_result (do
  x' ← get_local x,
  x_ty ← infer_type x',
  -- Adapt `e` to an equivalence with left-hand-side `x_ty`.
  e ← equiv_rw_type e x_ty cfg,
  eq ← to_expr ``(%%x' = equiv.symm %%e (equiv.to_fun %%e %%x')),
  prf ← to_expr ``((equiv.symm_apply_apply %%e %%x').symm),
  h ← note_anon eq prf,
  -- Revert the new hypothesis, so it is also part of the goal.
  revert h,
  ex ← to_expr ``(equiv.to_fun %%e %%x'),
  -- Now call `generalize`,
  -- attempting to replace all occurrences of `e x`,
  -- calling it for now `j : β`, with `k : x = e.symm j`.
  generalize ex (by apply_opt_param) transparency.none,
  -- Reintroduce `x` (now of type `b`), and the hypothesis `h`.
  intro x,
  h ← intro1,
  -- Finally, if we're working on properties, substitute along `h`, then do some cleanup,
  -- and if we're working on data, just throw out the old `x`.
  b ← target >>= is_prop,
  if b then do
    subst h,
    `[try { simp only with equiv_rw_simp }]
  else
    -- We may need to unfreeze `x` before we can `clear` it.
    unfreezing_hyp x' (clear' tt [x']) <|> fail
      format!"equiv_rw expected to be able to clear the original hypothesis {x}, but couldn't.",
  skip)
  {fail_if_unchanged := ff} tt -- call `dsimp_result` with `no_defaults := tt`.

/-- Rewrite the goal using an equiv `e`. -/
meta def equiv_rw_target (e : expr) (cfg : equiv_rw_cfg := {}) : tactic unit :=
do
  t ← target,
  e ← equiv_rw_type e t cfg,
  s ← to_expr ``(equiv.inv_fun %%e),
  tactic.eapply s,
  skip

end tactic

namespace tactic.interactive

open tactic
setup_tactic_parser

/-- Auxiliary function to call `equiv_rw_hyp` on a `list pexpr` recursively. -/
meta def equiv_rw_hyp_aux (hyp : name) (cfg : equiv_rw_cfg) (permissive : bool := ff) :
  list expr → itactic
| []       := skip
| (e :: t) := do
  if permissive then equiv_rw_hyp hyp e cfg <|> skip
  else equiv_rw_hyp hyp e cfg,
  equiv_rw_hyp_aux t

/-- Auxiliary function to call `equiv_rw_target` on a `list pexpr` recursively. -/
meta def equiv_rw_target_aux (cfg : equiv_rw_cfg) (permissive : bool) :
  list expr → itactic
| []       := skip
| (e :: t) := do
  if permissive then equiv_rw_target e cfg <|> skip
  else equiv_rw_target e cfg,
  equiv_rw_target_aux t

/--
`equiv_rw e at h₁ h₂ ⋯`, where each `hᵢ : α` is a hypothesis, and `e : α ≃ β`,
will attempt to transport each `hᵢ` along `e`, producing a new hypothesis `hᵢ : β`,
with all occurrences of `hᵢ` in other hypotheses and the goal replaced with `e.symm hᵢ`.

`equiv_rw e` will attempt to transport the goal along an equivalence `e : α ≃ β`.
In its minimal form it replaces the goal `⊢ α` with `⊢ β` by calling `apply e.inv_fun`.

`equiv_rw [e₁, e₂, ⋯] at h₁ h₂ ⋯` is equivalent to
`{ equiv_rw [e₁, e₂, ⋯] at h₁, equiv_rw [e₁, e₂, ⋯] at h₂, ⋯ }`.

`equiv_rw [e₁, e₂, ⋯] at *` will attempt to apply `equiv_rw [e₁, e₂, ⋯]` on the goal
and on each expression available in the local context (except on the `eᵢ`s themselves),
failing silently when it can't. Failing on a rewrite for a certain `eᵢ` at a certain
hypothesis `h` doesn't stop `equiv_rw` from trying the other equivalences on the list
at `h`. This only happens for the wildcard location.

`equiv_rw` will also try rewriting under (equiv_)functors, so it can turn
a hypothesis `h : list α` into `h : list β` or
a goal `⊢ unique α` into `⊢ unique β`.

The maximum search depth for rewriting in subexpressions is controlled by
`equiv_rw e {max_depth := n}`.
-/
meta def equiv_rw
  (l : parse pexpr_list_or_texpr)
  (locat : parse location)
  (cfg : equiv_rw_cfg := {}) : itactic := do
es ← l.mmap (λ e, to_expr e),
match locat with
| loc.wildcard := do
  equiv_rw_target_aux cfg tt es,
  ctx ← local_context,
  ctx.mmap (λ e, if e ∈ es then skip else equiv_rw_hyp_aux e.local_pp_name cfg tt es),
  skip
| loc.ns names := do
  names.mmap
    (λ hyp', match hyp' with
    | some hyp := equiv_rw_hyp_aux hyp cfg ff es
    | none     := equiv_rw_target_aux cfg ff es
    end),
  skip
end

add_tactic_doc
{ name        := "equiv_rw",
  category    := doc_category.tactic,
  decl_names  := [`tactic.interactive.equiv_rw],
  tags        := ["rewriting", "equiv", "transport"] }

/--
Solve a goal of the form `t ≃ _`,
by constructing an equivalence from `e : α ≃ β`.
This is the same equivalence that `equiv_rw` would use to rewrite a term of type `t`.

A typical usage might be:
```
have e' : option α ≃ option β := by equiv_rw_type e
```
-/
meta def equiv_rw_type (e : parse texpr) (cfg : equiv_rw_cfg := {}) : itactic :=
do
 `(%%t ≃ _) ← target | fail "`equiv_rw_type` solves goals of the form `t ≃ _`.",
 e ← to_expr e,
 tactic.equiv_rw_type e t cfg >>= tactic.exact

add_tactic_doc
{ name        := "equiv_rw_type",
  category    := doc_category.tactic,
  decl_names  := [`tactic.interactive.equiv_rw_type],
  tags        := ["rewriting", "equiv", "transport"] }

end tactic.interactive


def f (xs : List Nat) : Nat :=
  match xs with
  | [] => 1
  | [a, b] => (a + b).succ
  | _ => 2

theorem ex1 (xs : List Nat) (hr : xs.reverse = xs) (ys : Nat) : ys > 0 → f xs > 0 := by
  simp [f]
  split
  next => intro hys; decide
  next => intro hys; apply Nat.zero_lt_succ
  next zs n₁ n₂ => intro hys; decide

def g (xs : List Nat) : Nat :=
  match xs with
  | [a, b, c, d, e] => a + e + 1
  | _               => 1

theorem ex2 (xs : List Nat) : g xs > 0 := by
  simp [g]
  split
  next a b c d e => apply Nat.zero_lt_succ
  next h => decide


import soundness.soundnessCL
import completeness.canonical
import syntax.axiomsCL
import syntax.consistency_lemmas
import tactic.induction

local attribute [instance] classical.prop_decidable

open set list formCL axCL

namespace canonical
----------------------------------------------------------
-- Canonical Model CL
----------------------------------------------------------

def M_CL (agents : Type) [ha : nonempty agents] : modelCL agents :=
canonical_model_CL agents (formCL agents) nprfalseCL

/-- Allows us to write `φ ∈ s` instead of `φ ∈ s` -/
instance M_CL.f.states.set_like {agents form : Type} [ha : nonempty agents]
 [pf : Pformula form] [pax : Pformula_ax form] [clf : CLformula agents form] :
  set_like ((M_CL agents).f.states) (formCL agents) :=
{ coe := λ s, s.1,
  coe_injective' := subtype.coe_injective }

----------------------------------------------------------
-- Truth Lemma
----------------------------------------------------------
lemma truth_lemma_CL {agents : Type} [ha : nonempty agents]
  (φ : formCL agents) (s : (M_CL agents).f.states) :
  (⟨(M_CL agents), s⟩ '⊨ φ) ↔ (φ ∈ s) :=
begin
  let M := @M_CL agents ha,
  -- This proof is by induction on φ.
  induction' φ with n φ ψ _ _ φ ψ _ _,

  { -- case bot
    simp [s_entails_CL],
    exact @bot_not_mem_of_ax_consistent (formCL agents) _ _ s.1 s.2.1, },

  { -- case var
    simpa, },

  { -- case and
    simp [s_entails_CL, ih_φ, ih_ψ],
    split,

    { intro h,
      apply max_ax_contains_by_set_proof_2h s.2 h.left h.right Prop4, },

    { intro h,
      split,
      apply max_ax_contains_by_set_proof s.2 h Prop5,
      apply max_ax_contains_by_set_proof s.2 h Prop6, }, },

  { -- case imp
    simp [s_entails_CL, ih_φ, ih_ψ],
    split,

    { intro h,
      exact max_ax_contains_imp_by_proof s.2 h, },

    { intros h hφ,
      apply max_ax_contains_by_set_proof_2h s.2 hφ h likemp, }, },

  { -- case E
    let states := {Γ : (set (formCL agents)) // (max_ax_consistent Γ)},
    have hE : (M).f.E.E = λ s, λ G : set agents, _,
      from rfl,

    -- It is sufficient to consider the case when G ⊂ N, because ⊢ '[N]φ ↔ '¬ '[∅]'¬ φ
    cases set.eq_or_ssubset_of_subset (set.subset_univ G) with hG hG,
    -- Case G = N

    { -- ⊢ [N]φ ↔ ¬ [∅] ¬ φ
      have hempty : axCL (('[univ] φ) '↔ '¬ ('[∅]('¬ φ))), from
        @univ_iff_empty agents (formCL agents) _ _ _ _,
      simp [hG] at *, clear hG,

      split,

      { -- M s ⊨ [N] φ ⇒ '[N] φ ∈ s
        intro h,
        simp [s_entails_CL, hE] at h,
        have hnin : ('[∅] ('¬ φ)) ∉ s, from
        begin
          apply h ('¬ φ),
          apply @eq.subset _ _ {t : (M_CL agents).f.states | ⟨M_CL agents, t⟩ '⊨ φ}ᶜ,
          simp [ih],
          exact complement_from_contra,
        end,

        have hin : ('¬ '[∅]'¬ φ) ∈ s, from not_in_from_notin s.2 hnin,

        apply max_ax_contains_by_set_proof s.2 hin (MP (Prop6) hempty), },

      { -- '[N] φ ∈ s ⇒ M s ⊨ '[N] φ
        intro h,
        simp [s_entails_CL, hE, ih],
        intros ψ hsubseteq hf,

        simp [set.subset_def] at hsubseteq,

        have himp : ∀ (x : M.f.states), ψ ∈ x → ('¬ φ) ∈ x, from
          λ t ht, not_in_from_notin t.2 (hsubseteq t ht),

        have hin : ('¬ '[∅] '¬ φ) ∈ s,
          from by apply max_ax_contains_by_set_proof s.2 h (MP (Prop5) hempty),

        have hnin : ('[∅] '¬ φ) ∉ s, from
          λ hf, contra_contains_pr_false s.2 hf hin,

        have hax : axCL (ψ '→ ('¬ φ)), from
          ax_imp_from_ex himp,

        have hin' : ('[∅] '¬ φ) ∈ s,
        { apply max_ax_contains_by_set_proof s.2 hf,
          apply @derived_monoticity_rule agents (formCL agents),
          exact hax, },

        exact hnin hin', }, },

    { -- Case G ⊂ N
      split,
      -- M, s ⊨ '[G]φ ⇒ '[G]φ ∈ s, when G ⊂ N

      { -- Assume M, s ⊨ '[G]φ
        intro h,
        -- {s ∈ S| M, s ⊨ φ} ∈ E(s)(G), from h, by definition ⊨
        simp [s_entails_CL] at h,
        -- ∃ψ˜ ⊆ {t ∈ S| M, t ⊨ φ} : '[G]ψ ∈ s, from above, by definition E
        have huniv : G ≠ univ, from (set.ssubset_iff_subset_ne.mp hG).right,
        simp [hE, huniv] at h, clear huniv,
        -- ∃ψ˜ ⊆ {t ∈ S| M, φ ∈ t} : '[G]ψ ∈ s, from above, by IH
        cases h with ψ hψ,
        have hψih : ∀ (a : (M_CL agents).f.states), ψ ∈ ↑a → φ ∈ a, from
          begin
            intros t ht,
            apply (ih t).mp,
            apply hψ.left,
            exact ht,
          end,
        -- ∃ψ˜ ⊆ φ˜ : '[G]ψ ∈ s, from hih, by definition ψ˜
        have hGψ : ('[G]ψ) ∈ s, from hψ.right,
        -- ⊢ ψ → φ, since ψ˜ ⊆ φ˜ in hψih
        have himp : axCL (ψ '→ φ), from ax_imp_from_ex hψih,
        -- ⊢ '[G]ψ → '[G]φ, from himp, by the derived monoticity rule
        have hGimp : axCL (('[G] ψ) '→ ('[G] φ)), from
          @derived_monoticity_rule agents (formCL agents) _ _ _ _ _ _ himp,
        -- '[G]φ ∈ s, from hGimp and hGψ
        apply max_ax_contains_by_set_proof s.2 hGψ hGimp, },
      -- '[G]φ ∈ s ⇒ M, s ⊨ '[G]φ, when G ⊂ N

      { -- Assume '[G]φ ∈ s
        intro h,
        -- ˜φ ⊆ {t ∈ S| φ ∈ t} : '[G]φ ∈ s, from 4.1
        simp [s_entails_CL],
        -- {t ∈ S| φ ∈ t} ∈ E (s)(G), from 4.2, by definition E(s)(G).
        simp [hE, (set.ssubset_iff_subset_ne.mp hG).right],
        apply exists.intro φ,
        -- {t ∈ S | M, t ⊨ φ} ∈ E(s)(G), from 4.3, by IH
        split,

        { intros t ht,
          simp [ih],
          exact ht, },

        { exact h, }, }, }, },
end

----------------------------------------------------------
-- Completeness
----------------------------------------------------------
theorem completenessCL {agents : Type} [ha : nonempty agents]
  (φ : formCL agents) : ('⊨ φ) → '⊢ φ :=
begin
  -- Taking the contrapositive
  rw ←not_imp_not,
  -- Assume ¬ ⊢ φ.
  intro hnax,
  -- {¬φ} is a consistent set, from hnax.
  -- With Lindenbaum’s lemma, {¬φ} can be extended into a maximally consistent set Σ.
  obtain ⟨s, hmax, hnφ⟩ := @exists_max_ax_consistent_neg_mem (formCL agents) _ _ _ hnax,
  -- Take the state s ∈ SC , where s = Σ.
  simp [global_valid],
  apply exists.intro (M_CL agents),
  simp [valid_m],
  apply exists.intro (subtype.mk s hmax),
  -- Assume towards a contradiction that M C s ⊨ φ.
  intro hf,
  -- φ ∈ s, by the truth lemma, from hf
  have hφ, from (truth_lemma_CL φ (subtype.mk s hmax)).mp hf,
  -- Contradiction from hφ & hnφ.
  apply contra_contains_pr_false hmax hφ hnφ,
end

end canonical


/-
Copyright (c) 2020 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon, Patrick Massot, Eric Wieser
-/
import tactic.split_ifs
import tactic.simpa
import tactic.congr
import algebra.group.to_additive
/-!
# Instances and theorems on pi types

This file provides basic definitions and notation instances for Pi types.

Instances of more sophisticated classes are defined in `pi.lean` files elsewhere.
-/

universes u v₁ v₂ v₃
variable {I : Type u}     -- The indexing type
-- The families of types already equipped with instances
variables {f : I → Type v₁} {g : I → Type v₂} {h : I → Type v₃}
variables (x y : Π i, f i) (i : I)

namespace pi

/-! `1`, `0`, `+`, `*`, `-`, `⁻¹`, and `/` are defined pointwise. -/

@[to_additive] instance has_one [∀ i, has_one $ f i] :
  has_one (Π i : I, f i) :=
⟨λ _, 1⟩
@[simp, to_additive] lemma one_apply [∀ i, has_one $ f i] : (1 : Π i, f i) i = 1 := rfl

@[to_additive] lemma one_def [Π i, has_one $ f i] : (1 : Π i, f i) = λ i, 1 := rfl

@[to_additive]
instance has_mul [∀ i, has_mul $ f i] :
  has_mul (Π i : I, f i) :=
⟨λ f g i, f i * g i⟩
@[simp, to_additive] lemma mul_apply [∀ i, has_mul $ f i] : (x * y) i = x i * y i := rfl

@[to_additive] lemma mul_def [Π i, has_mul $ f i] : x * y = λ i, x i * y i := rfl

@[to_additive] instance has_inv [∀ i, has_inv $ f i] :
  has_inv (Π i : I, f i) :=
  ⟨λ f i, (f i)⁻¹⟩
@[simp, to_additive] lemma inv_apply [∀ i, has_inv $ f i] : x⁻¹ i = (x i)⁻¹ := rfl

@[to_additive] instance has_div [Π i, has_div $ f i] :
  has_div (Π i : I, f i) :=
⟨λ f g i, f i / g i⟩
@[simp, to_additive] lemma div_apply [Π i, has_div $ f i] : (x / y) i = x i / y i := rfl
@[to_additive] lemma div_def [Π i, has_div $ f i] : x / y = λ i, x i / y i := rfl

section

variables [decidable_eq I]
variables [Π i, has_zero (f i)] [Π i, has_zero (g i)] [Π i, has_zero (h i)]

/-- The function supported at `i`, with value `x` there. -/
def single (i : I) (x : f i) : Π i, f i :=
function.update 0 i x

@[simp] lemma single_eq_same (i : I) (x : f i) : single i x i = x :=
function.update_same i x _

@[simp] lemma single_eq_of_ne {i i' : I} (h : i' ≠ i) (x : f i) : single i x i' = 0 :=
function.update_noteq h x _

@[simp] lemma single_zero (i : I) : single i (0 : f i) = 0 :=
function.update_eq_self _ _

lemma apply_single (f' : Π i, f i → g i) (hf' : ∀ i, f' i 0 = 0) (i : I) (x : f i) (j : I):
  f' j (single i x j) = single i (f' i x) j :=
by simpa only [pi.zero_apply, hf', single] using function.apply_update f' 0 i x j

lemma apply_single₂ (f' : Π i, f i → g i → h i) (hf' : ∀ i, f' i 0 0 = 0)
  (i : I) (x : f i) (y : g i) (j : I):
  f' j (single i x j) (single i y j) = single i (f' i x y) j :=
begin
  by_cases h : j = i,
  { subst h, simp only [single_eq_same] },
  { simp only [single_eq_of_ne h, hf'] },
end

lemma single_op {g : I → Type*} [Π i, has_zero (g i)] (op : Π i, f i → g i) (h : ∀ i, op i 0 = 0)
  (i : I) (x : f i) :
  single i (op i x) = λ j, op j (single i x j) :=
eq.symm $ funext $ apply_single op h i x

lemma single_op₂ {g₁ g₂ : I → Type*} [Π i, has_zero (g₁ i)] [Π i, has_zero (g₂ i)]
  (op : Π i, g₁ i → g₂ i → f i) (h : ∀ i, op i 0 0 = 0) (i : I) (x₁ : g₁ i) (x₂ : g₂ i) :
  single i (op i x₁ x₂) = λ j, op j (single i x₁ j) (single i x₂ j) :=
eq.symm $ funext $ apply_single₂ op h i x₁ x₂

variables (f)

lemma single_injective (i : I) : function.injective (single i : f i → Π i, f i) :=
function.update_injective _ i

end
end pi

lemma subsingleton.pi_single_eq {α : Type*} [decidable_eq I] [subsingleton I] [has_zero α]
  (i : I) (x : α) :
  pi.single i x = λ _, x :=
funext $ λ j, by rw [subsingleton.elim j i, pi.single_eq_same]


/-
Copyright (c) 2022 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import group_theory.group_action.group
import group_theory.group_action.pi

/-!
# Group actions on embeddings

This file provides a `mul_action G (α ↪ β)` instance that agrees with the `mul_action G (α → β)`
instances defined by `pi.mul_action`.

Note that unlike the `pi` instance, this requires `G` to be a group.
-/

universes u v w
variables {G G' α β : Type*}

namespace function.embedding

@[to_additive function.embedding.has_vadd]
instance [group G] [mul_action G β] : has_smul G (α ↪ β) :=
⟨λ g f, f.trans (mul_action.to_perm g).to_embedding⟩

@[to_additive]
lemma smul_def [group G] [mul_action G β] (g : G) (f : α ↪ β) :
  g • f = f.trans (mul_action.to_perm g).to_embedding := rfl
@[simp, to_additive]
lemma smul_apply [group G] [mul_action G β] (g : G) (f : α ↪ β) (a : α) : (g • f) a = g • f a :=
rfl
@[to_additive]
lemma coe_smul [group G] [mul_action G β] (g : G) (f : α ↪ β) : ⇑(g • f) = g • f := rfl

instance [group G] [group G'] [has_smul G G'] [mul_action G β] [mul_action G' β]
  [is_scalar_tower G G' β] : is_scalar_tower G G' (α ↪ β) :=
⟨λ x y z, function.embedding.ext $ λ i, smul_assoc x y (z i)⟩

@[to_additive]
instance [group G] [group G'] [mul_action G β] [mul_action G' β] [smul_comm_class G G' β] :
  smul_comm_class G G' (α ↪ β) :=
⟨λ x y z, function.embedding.ext $ λ i, smul_comm x y (z i)⟩

instance [group G] [mul_action G β] [mul_action Gᵐᵒᵖ β] [is_central_scalar G β] :
  is_central_scalar G (α ↪ β) :=
⟨λ r m, function.embedding.ext $ λ i, op_smul_eq_smul _ _⟩

@[to_additive]
instance [group G] [mul_action G β] : mul_action G (α ↪ β) :=
fun_like.coe_injective.mul_action _ coe_smul

end function.embedding