/-
Copyright (c) 2022 Floris van Doorn, Heather Macbeth. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn, Heather Macbeth
-/
import geometry.manifold.vector_bundle.fiberwise_linear
import topology.vector_bundle.constructions

/-! # Smooth vector bundles

This file defines smooth vector bundles over a smooth manifold.

Let `E` be a topological vector bundle, with model fiber `F` and base space `B`.  We consider `E` as
carrying a charted space structure given by its trivializations -- these are charts to `B × F`.
Then, by "composition", if `B` is itself a charted space over `H` (e.g. a smooth manifold), then `E`
is also a charted space over `H × F`

Now, we define `smooth_vector_bundle` as the `Prop` of having smooth transition functions.
Recall the structure groupoid `smooth_fiberwise_linear` on `B × F` consisting of smooth, fiberwise
linear local homeomorphisms.  We show that our definition of "smooth vector bundle" implies
`has_groupoid` for this groupoid, and show (by a "composition" of `has_groupoid` instances) that
this means that a smooth vector bundle is a smooth manifold.

Since `smooth_vector_bundle` is a mixin, it should be easy to make variants and for many such
variants to coexist -- vector bundles can be smooth vector bundles over several different base
fields, they can also be C^k vector bundles, etc.

## Main definitions and constructions

* `fiber_bundle.charted_space`: A fiber bundle `E` over a base `B` with model fiber `F` is naturally
  a charted space modelled on `B × F`.

* `fiber_bundle.charted_space'`: Let `B` be a charted space modelled on `HB`.  Then a fiber bundle
  `E` over a base `B` with model fiber `F` is naturally a charted space modelled on `HB.prod F`.

* `smooth_vector_bundle`: Mixin class stating that a (topological) `vector_bundle` is smooth, in the
  sense of having smooth transition functions.

* `smooth_fiberwise_linear.has_groupoid`: For a smooth vector bundle `E` over `B` with fiber
  modelled on `F`, the change-of-co-ordinates between two trivializations `e`, `e'` for `E`,
  considered as charts to `B × F`, is smooth and fiberwise linear, in the sense of belonging to the
  structure groupoid `smooth_fiberwise_linear`.

* `bundle.total_space.smooth_manifold_with_corners`: A smooth vector bundle is naturally a smooth
  manifold.

* `vector_bundle_core.smooth_vector_bundle`: If a (topological) `vector_bundle_core` is smooth, in
  the sense of having smooth transition functions, then the vector bundle constructed from it is a
  smooth vector bundle.

* `bundle.prod.smooth_vector_bundle`: The direct sum of two smooth vector bundles is a smooth vector
  bundle.
-/

assert_not_exists mfderiv

open bundle set local_homeomorph function (id_def) filter
open_locale manifold bundle topology

variables {𝕜 B B' F M : Type*} {E : B → Type*}

/-! ### Charted space structure on a fiber bundle -/

section
variables [topological_space F] [topological_space (total_space E)] [∀ x, topological_space (E x)]
  {HB : Type*} [topological_space HB]
  [topological_space B] [charted_space HB B] [fiber_bundle F E]

/-- A fiber bundle `E` over a base `B` with model fiber `F` is naturally a charted space modelled on
`B × F`. -/
instance fiber_bundle.charted_space : charted_space (B × F) (total_space E) :=
{ atlas := (λ e : trivialization F (π E), e.to_local_homeomorph) '' trivialization_atlas F E,
  chart_at := λ x, (trivialization_at F E x.proj).to_local_homeomorph,
  mem_chart_source := λ x, (trivialization_at F E x.proj).mem_source.mpr
    (mem_base_set_trivialization_at F E x.proj),
  chart_mem_atlas := λ x, mem_image_of_mem _ (trivialization_mem_atlas F E _) }

section
local attribute [reducible] model_prod

/-- Let `B` be a charted space modelled on `HB`.  Then a fiber bundle `E` over a base `B` with model
fiber `F` is naturally a charted space modelled on `HB.prod F`. -/
instance fiber_bundle.charted_space' : charted_space (model_prod HB F) (total_space E) :=
charted_space.comp _ (model_prod B F) _
end

lemma fiber_bundle.charted_space_chart_at (x : total_space E) :
  chart_at (model_prod HB F) x =
  (trivialization_at F E x.proj).to_local_homeomorph ≫ₕ
  (chart_at HB x.proj).prod (local_homeomorph.refl F) :=
begin
  dsimp only [fiber_bundle.charted_space', charted_space.comp, fiber_bundle.charted_space,
    prod_charted_space, charted_space_self],
  rw [trivialization.coe_coe,
    trivialization.coe_fst' _ (mem_base_set_trivialization_at F E x.proj)]
end

lemma fiber_bundle.charted_space_chart_at_symm_fst (x : total_space E) (y : model_prod HB F)
  (hy : y ∈ (chart_at (model_prod HB F) x).target) :
  ((chart_at (model_prod HB F) x).symm y).proj = (chart_at HB x.proj).symm y.1 :=
begin
  simp only [fiber_bundle.charted_space_chart_at] with mfld_simps at hy ⊢,
  exact (trivialization_at F E x.proj).proj_symm_apply hy.2,
end

end

section
variables [nontrivially_normed_field 𝕜]
  [normed_add_comm_group F] [normed_space 𝕜 F]
  [topological_space (total_space E)] [∀ x, topological_space (E x)]

  {EB : Type*} [normed_add_comm_group EB] [normed_space 𝕜 EB]
  {HB : Type*} [topological_space HB] (IB : model_with_corners 𝕜 EB HB)
  (E' : B → Type*) [Π x, has_zero (E' x)]
  {EM : Type*} [normed_add_comm_group EM] [normed_space 𝕜 EM]
  {HM : Type*} [topological_space HM] {IM : model_with_corners 𝕜 EM HM}
  [topological_space M] [charted_space HM M] [Is : smooth_manifold_with_corners IM M]
  {n : ℕ∞}

variables [topological_space B] [charted_space HB B] [fiber_bundle F E]

protected lemma fiber_bundle.ext_chart_at (x : total_space E) :
  ext_chart_at (IB.prod 𝓘(𝕜, F)) x =
  (trivialization_at F E x.proj).to_local_equiv ≫
  (ext_chart_at IB x.proj).prod (local_equiv.refl F) :=
begin
  simp_rw [ext_chart_at, fiber_bundle.charted_space_chart_at, extend],
  simp only [local_equiv.trans_assoc] with mfld_simps,
end

/-! ### Smoothness of maps in/out fiber bundles

Note: For these results we don't need that the bundle is a smooth vector bundle, or even a vector
bundle at all, just that it is a fiber bundle over a charted base space.
-/

namespace bundle
variables {F E IB}

/-- Characterization of C^n functions into a smooth vector bundle. -/
lemma cont_mdiff_within_at_total_space (f : M → total_space E) {s : set M} {x₀ : M} :
  cont_mdiff_within_at IM (IB.prod (𝓘(𝕜, F))) n f s x₀ ↔
  cont_mdiff_within_at IM IB n (λ x, (f x).proj) s x₀ ∧
  cont_mdiff_within_at IM 𝓘(𝕜, F) n (λ x, (trivialization_at F E (f x₀).proj (f x)).2) s x₀ :=
begin
  simp only [cont_mdiff_within_at_iff_target] {single_pass := tt},
  rw [and_and_and_comm, ← continuous_within_at_total_space, and.congr_right_iff],
  intros hf,
  simp_rw [model_with_corners_self_prod, fiber_bundle.ext_chart_at, function.comp,
    local_equiv.trans_apply, local_equiv.prod_coe, local_equiv.refl_coe,
    ext_chart_at_self_apply, model_with_corners_self_coe, id_def],
  refine (cont_mdiff_within_at_prod_iff _).trans _, -- rw doesn't do this?
  have h1 : (λ x, (f x).proj) ⁻¹' (trivialization_at F E (f x₀).proj).base_set ∈ 𝓝[s] x₀ :=
    ((continuous_proj F E).continuous_within_at.comp hf (maps_to_image f s))
      .preimage_mem_nhds_within
      ((trivialization.open_base_set _).mem_nhds (mem_base_set_trivialization_at F E _)),
  refine and_congr (eventually_eq.cont_mdiff_within_at_iff (eventually_of_mem h1 $ λ x hx, _) _)
    iff.rfl,
  { simp_rw [function.comp, local_homeomorph.coe_coe, trivialization.coe_coe],
    rw [trivialization.coe_fst'],
    exact hx },
  { simp only with mfld_simps },
end

/-- Characterization of C^n functions into a smooth vector bundle. -/

variables (E)
lemma cont_mdiff_proj : cont_mdiff (IB.prod 𝓘(𝕜, F)) IB n (π E) :=
begin
  intro x,
  rw [cont_mdiff_at, cont_mdiff_within_at_iff'],
  refine ⟨(continuous_proj F E).continuous_within_at, _⟩,
  simp_rw [(∘), fiber_bundle.ext_chart_at],
  apply cont_diff_within_at_fst.congr,
  { rintros ⟨a, b⟩ hab,
    simp only with mfld_simps at hab,
    have : ((chart_at HB x.1).symm (IB.symm a), b) ∈ (trivialization_at F E x.fst).target,
    { simp only [hab] with mfld_simps },
    simp only [trivialization.proj_symm_apply _ this, hab] with mfld_simps },
  { simp only with mfld_simps }
end

lemma smooth_proj : smooth (IB.prod 𝓘(𝕜, F)) IB (π E) :=
cont_mdiff_proj E

lemma cont_mdiff_on_proj {s : set (total_space E)} :
  cont_mdiff_on (IB.prod 𝓘(𝕜, F)) IB n (π E) s :=
(bundle.cont_mdiff_proj E).cont_mdiff_on

lemma smooth_on_proj {s : set (total_space E)} :
  smooth_on (IB.prod 𝓘(𝕜, F)) IB (π E) s :=
cont_mdiff_on_proj E

lemma cont_mdiff_at_proj {p : total_space E} :
  cont_mdiff_at (IB.prod 𝓘(𝕜, F)) IB n
    (π E) p :=
(bundle.cont_mdiff_proj E).cont_mdiff_at

lemma smooth_at_proj {p : total_space E} :
  smooth_at (IB.prod 𝓘(𝕜, F)) IB (π E) p :=
bundle.cont_mdiff_at_proj E

lemma cont_mdiff_within_at_proj
  {s : set (total_space E)}
  {p : total_space E} :
  cont_mdiff_within_at (IB.prod 𝓘(𝕜, F)) IB n (π E) s p :=
(bundle.cont_mdiff_at_proj E).cont_mdiff_within_at

lemma smooth_within_at_proj
  {s : set (total_space E)}
  {p : total_space E} :
  smooth_within_at (IB.prod 𝓘(𝕜, F)) IB (π E) s p :=
bundle.cont_mdiff_within_at_proj E

variables (𝕜 E) [∀ x, add_comm_monoid (E x)] [∀ x, module 𝕜 (E x)] [vector_bundle 𝕜 F E]

lemma smooth_zero_section : smooth IB (IB.prod 𝓘(𝕜, F)) (zero_section E) :=
begin
  intro x,
  rw [bundle.cont_mdiff_at_total_space],
  refine ⟨cont_mdiff_at_id, cont_mdiff_at_const.congr_of_eventually_eq _⟩,
  { exact 0 },
  refine eventually_of_mem ((trivialization_at F E x).open_base_set.mem_nhds
    (mem_base_set_trivialization_at F E x)) (λ x' hx', _),
  simp_rw [zero_section_proj, (trivialization_at F E x).zero_section 𝕜 hx']
end

end bundle

end

/-! ### Smooth vector bundles -/

variables [nontrivially_normed_field 𝕜] [∀ x, add_comm_monoid (E x)] [∀ x, module 𝕜 (E x)]
  [normed_add_comm_group F] [normed_space 𝕜 F]
  [topological_space (total_space E)] [∀ x, topological_space (E x)]

  {EB : Type*} [normed_add_comm_group EB] [normed_space 𝕜 EB]
  {HB : Type*} [topological_space HB] (IB : model_with_corners 𝕜 EB HB)
  [topological_space B] [charted_space HB B] [smooth_manifold_with_corners IB B]
  {EM : Type*} [normed_add_comm_group EM] [normed_space 𝕜 EM]
  {HM : Type*} [topological_space HM] {IM : model_with_corners 𝕜 EM HM}
  [topological_space M] [charted_space HM M] [Is : smooth_manifold_with_corners IM M]
  {n : ℕ∞}

variables (F E) [fiber_bundle F E] [vector_bundle 𝕜 F E]

/-- When `B` is a smooth manifold with corners with respect to a model `IB` and `E` is a
topological vector bundle over `B` with fibers isomorphic to `F`, then `smooth_vector_bundle F E IB`
registers that the bundle is smooth, in the sense of having smooth transition functions.
This is a mixin, not carrying any new data`. -/
class smooth_vector_bundle : Prop :=
(smooth_on_coord_change : ∀ (e e' : trivialization F (π E))
  [mem_trivialization_atlas e] [mem_trivialization_atlas e'],
  smooth_on IB 𝓘(𝕜, F →L[𝕜] F) (λ b : B, (e.coord_changeL 𝕜 e' b : F →L[𝕜] F))
  (e.base_set ∩ e'.base_set))

export smooth_vector_bundle (smooth_on_coord_change)

variables [smooth_vector_bundle F E IB]

/-- For a smooth vector bundle `E` over `B` with fiber modelled on `F`, the change-of-co-ordinates
between two trivializations `e`, `e'` for `E`, considered as charts to `B × F`, is smooth and
fiberwise linear. -/
instance : has_groupoid (total_space E) (smooth_fiberwise_linear B F IB) :=
{ compatible := begin
    rintros _ _ ⟨e, he, rfl⟩ ⟨e', he', rfl⟩,
    haveI : mem_trivialization_atlas e := ⟨he⟩,
    haveI : mem_trivialization_atlas e' := ⟨he'⟩,
    resetI,
    rw mem_smooth_fiberwise_linear_iff,
    refine ⟨_, _, e.open_base_set.inter e'.open_base_set, smooth_on_coord_change e e', _, _, _⟩,
    { rw inter_comm,
      apply cont_mdiff_on.congr (smooth_on_coord_change e' e),
      { intros b hb,
        rw e.symm_coord_changeL e' hb },
      { apply_instance },
      { apply_instance }, },
    { simp only [e.symm_trans_source_eq e', fiberwise_linear.local_homeomorph,
      trans_to_local_equiv, symm_to_local_equiv]},
    { rintros ⟨b, v⟩ hb,
      have hb' : b ∈ e.base_set ∩ e'.base_set,
      { simpa only [trans_to_local_equiv, symm_to_local_equiv, e.symm_trans_source_eq e',
          coe_coe_symm, prod_mk_mem_set_prod_eq, mem_univ, and_true] using hb },
      exact e.apply_symm_apply_eq_coord_changeL e' hb' v, }
  end }

/-- A smooth vector bundle `E` is naturally a smooth manifold. -/
instance : smooth_manifold_with_corners (IB.prod 𝓘(𝕜, F)) (total_space E) :=
begin
  refine { .. structure_groupoid.has_groupoid.comp (smooth_fiberwise_linear B F IB) _ },
  intros e he,
  rw mem_smooth_fiberwise_linear_iff at he,
  obtain ⟨φ, U, hU, hφ, h2φ, heφ⟩ := he,
  rw [is_local_structomorph_on_cont_diff_groupoid_iff],
  refine ⟨cont_mdiff_on.congr _ heφ.eq_on, cont_mdiff_on.congr _ heφ.symm'.eq_on⟩,
  { rw heφ.source_eq,
    apply smooth_on_fst.prod_mk,
    exact (hφ.comp cont_mdiff_on_fst $ prod_subset_preimage_fst _ _).clm_apply cont_mdiff_on_snd },
  { rw heφ.target_eq,
    apply smooth_on_fst.prod_mk,
    exact (h2φ.comp cont_mdiff_on_fst $ prod_subset_preimage_fst _ _).clm_apply cont_mdiff_on_snd },
end

/-! ### Core construction for smooth vector bundles -/

namespace vector_bundle_core
variables {ι : Type*} {F} (Z : vector_bundle_core 𝕜 B F ι)

/-- Mixin for a `vector_bundle_core` stating smoothness (of transition functions). -/
class is_smooth (IB : model_with_corners 𝕜 EB HB) : Prop :=
(smooth_on_coord_change [] :
  ∀ i j, smooth_on IB 𝓘(𝕜, F →L[𝕜] F) (Z.coord_change i j) (Z.base_set i ∩ Z.base_set j))

export is_smooth (renaming smooth_on_coord_change → vector_bundle_core.smooth_on_coord_change)

variables [Z.is_smooth IB]

/-- If a `vector_bundle_core` has the `is_smooth` mixin, then the vector bundle constructed from it
is a smooth vector bundle. -/
instance smooth_vector_bundle : smooth_vector_bundle F Z.fiber IB :=
{ smooth_on_coord_change := begin
    rintros - - ⟨i, rfl⟩ ⟨i', rfl⟩,
    refine (Z.smooth_on_coord_change IB i i').congr (λ b hb, _),
    ext v,
    exact Z.local_triv_coord_change_eq i i' hb v,
  end }

end vector_bundle_core

/-! ### The trivial smooth vector bundle -/

/-- A trivial vector bundle over a smooth manifold is a smooth vector bundle. -/
instance bundle.trivial.smooth_vector_bundle : smooth_vector_bundle F (bundle.trivial B F) IB :=
{ smooth_on_coord_change := begin
    introsI e e' he he',
    unfreezingI { obtain rfl := bundle.trivial.eq_trivialization B F e },
    unfreezingI { obtain rfl := bundle.trivial.eq_trivialization B F e' },
    simp_rw bundle.trivial.trivialization.coord_changeL,
    exact smooth_const.smooth_on
  end }

/-! ### Direct sums of smooth vector bundles -/

section prod
variables (F₁ : Type*) [normed_add_comm_group F₁] [normed_space 𝕜 F₁]
  (E₁ : B → Type*) [topological_space (total_space E₁)]
  [Π x, add_comm_monoid (E₁ x)] [Π x, module 𝕜 (E₁ x)]

variables (F₂ : Type*) [normed_add_comm_group F₂] [normed_space 𝕜 F₂]
  (E₂ : B → Type*) [topological_space (total_space E₂)]
  [Π x, add_comm_monoid (E₂ x)] [Π x, module 𝕜 (E₂ x)]

variables [Π x : B, topological_space (E₁ x)] [Π x : B, topological_space (E₂ x)]
  [fiber_bundle F₁ E₁] [fiber_bundle F₂ E₂]
  [vector_bundle 𝕜 F₁ E₁] [vector_bundle 𝕜 F₂ E₂]
  [smooth_vector_bundle F₁ E₁ IB] [smooth_vector_bundle F₂ E₂ IB]

/-- The direct sum of two smooth vector bundles over the same base is a smooth vector bundle. -/
instance bundle.prod.smooth_vector_bundle :
  smooth_vector_bundle (F₁ × F₂) (E₁ ×ᵇ E₂) IB :=
{ smooth_on_coord_change := begin
    rintros _ _ ⟨e₁, e₂, i₁, i₂, rfl⟩ ⟨e₁', e₂', i₁', i₂', rfl⟩,
    resetI,
    rw [smooth_on],
    refine cont_mdiff_on.congr _ (e₁.coord_changeL_prod 𝕜 e₁' e₂ e₂'),
    refine cont_mdiff_on.clm_prod_map _ _,
    { refine (smooth_on_coord_change e₁ e₁').mono _,
      simp only [trivialization.base_set_prod] with mfld_simps,
      mfld_set_tac },
    { refine (smooth_on_coord_change e₂ e₂').mono _,
      simp only [trivialization.base_set_prod] with mfld_simps,
      mfld_set_tac },
  end }

end prod


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

import topology.homotopy.basic

/-!

# Homotopy equivalences between topological spaces

In this file, we define homotopy equivalences between topological spaces `X` and `Y` as a pair of
functions `f : C(X, Y)` and `g : C(Y, X)` such that `f.comp g` and `g.comp f` are both homotopic
to `id`.

## Main definitions

- `continuous_map.homotopy_equiv` is the type of homotopy equivalences between topological spaces.

## Notation

We introduce the notation `X ≃ₕ Y` for `continuous_map.homotopy_equiv X Y` in the `continuous_map`
locale.

-/

universes u v w

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

namespace continuous_map

/--
A homotopy equivalence between topological spaces `X` and `Y` are a pair of functions
`to_fun : C(X, Y)` and `inv_fun : C(Y, X)` such that `to_fun.comp inv_fun` and `inv_fun.comp to_fun`
are both homotopic to `id`.
-/
@[ext]
structure homotopy_equiv (X : Type u) (Y : Type v) [topological_space X] [topological_space Y] :=
(to_fun : C(X, Y))
(inv_fun : C(Y, X))
(left_inv : (inv_fun.comp to_fun).homotopic id)
(right_inv : (to_fun.comp inv_fun).homotopic id)

localized "infix ` ≃ₕ `:25 := continuous_map.homotopy_equiv" in continuous_map

namespace homotopy_equiv

instance : has_coe_to_fun (homotopy_equiv X Y) (λ _, X → Y) := ⟨λ h, h.to_fun⟩

@[simp]
lemma to_fun_eq_coe (h : homotopy_equiv X Y) : (h.to_fun : X → Y) = h := rfl

@[continuity]
lemma continuous (h : homotopy_equiv X Y) : continuous h := h.to_fun.continuous

end homotopy_equiv

end continuous_map

open_locale continuous_map

namespace homeomorph

/--
Any homeomorphism is a homotopy equivalence.
-/
def to_homotopy_equiv (h : X ≃ₜ Y) : X ≃ₕ Y :=
{ to_fun := ⟨h⟩,
  inv_fun := ⟨h.symm⟩,
  left_inv := by { convert continuous_map.homotopic.refl _, ext, simp },
  right_inv := by { convert continuous_map.homotopic.refl _, ext, simp } }

@[simp]
lemma coe_to_homotopy_equiv (h : X ≃ₜ Y) : ⇑(h.to_homotopy_equiv) = h := rfl

end homeomorph

namespace continuous_map

namespace homotopy_equiv

/--
If `X` is homotopy equivalent to `Y`, then `Y` is homotopy equivalent to `X`.
-/
def symm (h : X ≃ₕ Y) : Y ≃ₕ X :=
{ to_fun := h.inv_fun,
  inv_fun := h.to_fun,
  left_inv := h.right_inv,
  right_inv := h.left_inv }

@[simp]
lemma coe_inv_fun (h : homotopy_equiv X Y) : (⇑h.inv_fun : Y → X) = ⇑h.symm := rfl

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

initialize_simps_projections homotopy_equiv (to_fun_to_fun -> apply,
  inv_fun_to_fun -> symm_apply, -to_fun, -inv_fun)

/--
Any topological space is homotopy equivalent to itself.
-/
@[simps]
def refl (X : Type u) [topological_space X] : X ≃ₕ X :=
(homeomorph.refl X).to_homotopy_equiv

instance : inhabited (homotopy_equiv unit unit) := ⟨refl unit⟩

/--
If `X` is homotopy equivalent to `Y`, and `Y` is homotopy equivalent to `Z`, then `X` is homotopy
equivalent to `Z`.
-/
@[simps]
def trans (h₁ : X ≃ₕ Y) (h₂ : Y ≃ₕ Z) : X ≃ₕ Z :=
{ to_fun := h₂.to_fun.comp h₁.to_fun,
  inv_fun := h₁.inv_fun.comp h₂.inv_fun,
  left_inv := begin
    refine homotopic.trans _ h₁.left_inv,
    change ((h₁.inv_fun.comp h₂.inv_fun).comp (h₂.to_fun.comp h₁.to_fun)) with
      h₁.inv_fun.comp ((h₂.inv_fun.comp h₂.to_fun).comp h₁.to_fun),
    refine homotopic.hcomp _ (homotopic.refl _),
    refine homotopic.trans ((homotopic.refl _).hcomp h₂.left_inv) _,
    -- simp,
    rw continuous_map.id_comp,
  end,
  right_inv := begin
    refine homotopic.trans _ h₂.right_inv,
    change ((h₂.to_fun.comp h₁.to_fun).comp (h₁.inv_fun.comp h₂.inv_fun)) with
      h₂.to_fun.comp ((h₁.to_fun.comp h₁.inv_fun).comp h₂.inv_fun),
    refine homotopic.hcomp _ (homotopic.refl _),
    refine homotopic.trans ((homotopic.refl _).hcomp h₁.right_inv) _,
    rw id_comp,
  end }

lemma symm_trans (h₁ : X ≃ₕ Y) (h₂ : Y ≃ₕ Z) :
  (h₁.trans h₂).symm = h₂.symm.trans h₁.symm := by ext; refl

end homotopy_equiv

end continuous_map

open continuous_map

namespace homeomorph

@[simp]
lemma refl_to_homotopy_equiv (X : Type u) [topological_space X] :
  (homeomorph.refl X).to_homotopy_equiv = homotopy_equiv.refl X := rfl

@[simp]
lemma symm_to_homotopy_equiv (h : X ≃ₜ Y) :
  h.symm.to_homotopy_equiv = h.to_homotopy_equiv.symm := rfl

@[simp]
lemma trans_to_homotopy_equiv (h₀ : X ≃ₜ Y) (h₁ : Y ≃ₜ Z) :
  (h₀.trans h₁).to_homotopy_equiv = h₀.to_homotopy_equiv.trans h₁.to_homotopy_equiv := rfl

end homeomorph


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

! This file was ported from Lean 3 source module control.fix
! leanprover-community/mathlib commit c3291da49cfa65f0d43b094750541c0731edc932
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Part
import Mathbin.Data.Nat.Upto
import Mathbin.Data.Stream.Defs

/-!
# Fixed point

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

This module defines a generic `fix` operator for defining recursive
computations that are not necessarily well-founded or productive.
An instance is defined for `part`.

## Main definition

 * class `has_fix`
 * `part.fix`
-/

universe u v

open Classical

variable {α : Type _} {β : α → Type _}

#print Fix /-
/-- `has_fix α` gives us a way to calculate the fixed point
of function of type `α → α`. -/
class Fix (α : Type _) where
  fix : (α → α) → α
#align has_fix Fix
-/

namespace Part

open Part Nat Nat.Upto

section Basic

variable (f : (∀ a, Part <| β a) → ∀ a, Part <| β a)

#print Part.Fix.approx /-
/-- A series of successive, finite approximation of the fixed point of `f`, defined by
`approx f n = f^[n] ⊥`. The limit of this chain is the fixed point of `f`. -/
def Fix.approx : Stream' <| ∀ a, Part <| β a
  | 0 => ⊥
  | Nat.succ i => f (fix.approx i)
#align part.fix.approx Part.Fix.approx
-/

#print Part.fixAux /-
/-- loop body for finding the fixed point of `f` -/
def fixAux {p : ℕ → Prop} (i : Nat.Upto p) (g : ∀ j : Nat.Upto p, i < j → ∀ a, Part <| β a) :
    ∀ a, Part <| β a :=
  f fun x : α => assert (¬p i.val) fun h : ¬p i.val => g (i.succ h) (Nat.lt_succ_self _) x
#align part.fix_aux Part.fixAux
-/

#print Part.fix /-
/-- The least fixed point of `f`.

If `f` is a continuous function (according to complete partial orders),
it satisfies the equations:

  1. `fix f = f (fix f)`          (is a fixed point)
  2. `∀ X, f X ≤ X → fix f ≤ X`   (least fixed point)
-/
protected def fix (x : α) : Part <| β x :=
  Part.assert (∃ i, (Fix.approx f i x).Dom) fun h =>
    WellFounded.fix.{1} (Nat.Upto.wf h) (fixAux f) Nat.Upto.zero x
#align part.fix Part.fix
-/

#print Part.fix_def /-
protected theorem fix_def {x : α} (h' : ∃ i, (Fix.approx f i x).Dom) :
    Part.fix f x = Fix.approx f (Nat.succ <| Nat.find h') x :=
  by
  let p := fun i : ℕ => (fix.approx f i x).Dom
  have : p (Nat.find h') := Nat.find_spec h'
  generalize hk : Nat.find h' = k
  replace hk : Nat.find h' = k + (@upto.zero p).val := hk
  rw [hk] at this
  revert hk
  dsimp [Part.fix]; rw [assert_pos h']; revert this
  generalize upto.zero = z; intros
  suffices : ∀ x', WellFounded.fix (fix._proof_1 f x h') (fix_aux f) z x' = fix.approx f (succ k) x'
  exact this _
  induction k generalizing z <;> intro
  · rw [fix.approx, WellFounded.fix_eq, fix_aux]
    congr
    ext : 1
    rw [assert_neg]
    rfl
    rw [Nat.zero_add] at this
    simpa only [Classical.not_not, Subtype.val_eq_coe]
  · rw [fix.approx, WellFounded.fix_eq, fix_aux]
    congr
    ext : 1
    have hh : ¬(fix.approx f z.val x).Dom :=
      by
      apply Nat.find_min h'
      rw [hk, Nat.succ_add, ← Nat.add_succ]
      apply Nat.lt_of_succ_le
      apply Nat.le_add_left
    rw [succ_add_eq_succ_add] at this hk
    rw [assert_pos hh, k_ih (upto.succ z hh) this hk]
#align part.fix_def Part.fix_def
-/

#print Part.fix_def' /-
theorem fix_def' {x : α} (h' : ¬∃ i, (Fix.approx f i x).Dom) : Part.fix f x = none := by
  dsimp [Part.fix] <;> rw [assert_neg h']
#align part.fix_def' Part.fix_def'
-/

end Basic

end Part

namespace Part

instance : Fix (Part α) :=
  ⟨fun f => Part.fix (fun x u => f (x u)) ()⟩

end Part

open Sigma

namespace Pi

#print Pi.Part.hasFix /-
instance Part.hasFix {β} : Fix (α → Part β) :=
  ⟨Part.fix⟩
#align pi.part.has_fix Pi.Part.hasFix
-/

end Pi


/-
Copyright (c) 2018 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Mario Carneiro, Simon Hudon
-/
import data.fin.fin2
import logic.function.basic
import tactic.basic

/-!

# Tuples of types, and their categorical structure.

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

## Features

* `typevec n` - n-tuples of types
* `α ⟹ β`    - n-tuples of maps
* `f ⊚ g`     - composition

Also, support functions for operating with n-tuples of types, such as:

* `append1 α β`    - append type `β` to n-tuple `α` to obtain an (n+1)-tuple
* `drop α`         - drops the last element of an (n+1)-tuple
* `last α`         - returns the last element of an (n+1)-tuple
* `append_fun f g` - appends a function g to an n-tuple of functions
* `drop_fun f`     - drops the last function from an n+1-tuple
* `last_fun f`     - returns the last function of a tuple.

Since e.g. `append1 α.drop α.last` is propositionally equal to `α` but not definitionally equal
to it, we need support functions and lemmas to mediate between constructions.
-/

universes u v w

/--
n-tuples of types, as a category
-/
def typevec (n : ℕ) := fin2 n → Type*

instance {n} : inhabited (typevec.{u} n) := ⟨ λ _, punit ⟩

namespace typevec

variable {n : ℕ}

/-- arrow in the category of `typevec` -/
def arrow (α β : typevec n) := Π i : fin2 n, α i → β i

localized "infixl (name := typevec.arrow) ` ⟹ `:40 := typevec.arrow" in mvfunctor

instance arrow.inhabited (α β : typevec n) [Π i, inhabited (β i)] : inhabited (α ⟹ β) :=
⟨ λ _ _, default ⟩

/-- identity of arrow composition -/
def id {α : typevec n} : α ⟹ α := λ i x, x

/-- arrow composition in the category of `typevec` -/
def comp {α β γ : typevec n} (g : β ⟹ γ) (f : α ⟹ β) : α ⟹ γ :=
λ i x, g i (f i x)

localized "infixr (name := typevec.comp) ` ⊚ `:80 := typevec.comp" in mvfunctor -- type as \oo

@[simp] theorem id_comp {α β : typevec n} (f : α ⟹ β) : id ⊚ f = f :=
rfl

@[simp] theorem comp_id {α β : typevec n} (f : α ⟹ β) : f ⊚ id = f :=
rfl

theorem comp_assoc {α β γ δ : typevec n} (h : γ ⟹ δ) (g : β ⟹ γ) (f : α ⟹ β) :
  (h ⊚ g) ⊚ f = h ⊚ g ⊚ f := rfl

/--
Support for extending a typevec by one element.
-/
def append1 (α : typevec n) (β : Type*) : typevec (n+1)
| (fin2.fs i) := α i
| fin2.fz      := β

infixl (name := typevec.append1) ` ::: `:67 := append1

/-- retain only a `n-length` prefix of the argument -/
def drop (α : typevec.{u} (n+1)) : typevec n := λ i, α i.fs

/-- take the last value of a `(n+1)-length` vector -/
def last (α : typevec.{u} (n+1)) : Type* := α fin2.fz

instance last.inhabited (α : typevec (n+1)) [inhabited (α fin2.fz)] : inhabited (last α) :=
⟨show α fin2.fz, from default⟩

theorem drop_append1 {α : typevec n} {β : Type*} {i : fin2 n} : drop (append1 α β) i = α i := rfl

theorem drop_append1' {α : typevec n} {β : Type*} : drop (append1 α β) = α :=
by ext; apply drop_append1

theorem last_append1 {α : typevec n} {β : Type*} : last (append1 α β) = β := rfl

@[simp]
theorem append1_drop_last (α : typevec (n+1)) : append1 (drop α) (last α) = α :=
funext $ λ i, by cases i; refl

/-- cases on `(n+1)-length` vectors -/
@[elab_as_eliminator] def append1_cases
  {C : typevec (n+1) → Sort u} (H : ∀ α β, C (append1 α β)) (γ) : C γ :=
by rw [← @append1_drop_last _ γ]; apply H

@[simp] theorem append1_cases_append1 {C : typevec (n+1) → Sort u}
  (H : ∀ α β, C (append1 α β)) (α β) :
  @append1_cases _ C H (append1 α β) = H α β := rfl

/-- append an arrow and a function for arbitrary source and target
type vectors -/
def split_fun {α α' : typevec (n+1)}
  (f : drop α ⟹ drop α') (g : last α → last α') : α ⟹ α'
| (fin2.fs i) := f i
| fin2.fz      := g

/-- append an arrow and a function as well as their respective source
and target types / typevecs -/
def append_fun {α α' : typevec n} {β β' : Type*}
  (f : α ⟹ α') (g : β → β') : append1 α β ⟹ append1 α' β' := split_fun f g

infixl (name := typevec.append_fun) ` ::: ` := append_fun

/-- split off the prefix of an arrow -/
def drop_fun {α β : typevec (n+1)} (f : α ⟹ β) : drop α ⟹ drop β :=
λ i, f i.fs

/-- split off the last function of an arrow -/
def last_fun {α β : typevec (n+1)} (f : α ⟹ β) : last α → last β :=
f fin2.fz

/-- arrow in the category of `0-length` vectors -/
def nil_fun {α : typevec 0} {β : typevec 0} : α ⟹ β :=
λ i, fin2.elim0 i

theorem eq_of_drop_last_eq {α β : typevec (n+1)} {f g : α ⟹ β}
  (h₀ : drop_fun f = drop_fun g) (h₁ : last_fun f = last_fun g) : f = g :=
by replace h₀ := congr_fun h₀;
   ext1 ⟨⟩; apply_assumption

@[simp]

/-- turn an equality into an arrow -/
def arrow.mp {α β : typevec n} (h : α = β) : α ⟹ β
| i := eq.mp (congr_fun h _)

/-- turn an equality into an arrow, with reverse direction -/
def arrow.mpr {α β : typevec n} (h : α = β) : β ⟹ α
| i := eq.mpr (congr_fun h _)

/-- decompose a vector into its prefix appended with its last element -/
def to_append1_drop_last {α : typevec (n+1)} : α ⟹ drop α ::: last α :=
arrow.mpr (append1_drop_last _)

/-- stitch two bits of a vector back together -/
def from_append1_drop_last {α : typevec (n+1)} : drop α ::: last α ⟹ α :=
arrow.mp (append1_drop_last _)

@[simp] theorem last_fun_split_fun {α α' : typevec (n+1)}
  (f : drop α ⟹ drop α') (g : last α → last α') :
  last_fun (split_fun f g) = g := rfl

@[simp] theorem drop_fun_append_fun {α α' : typevec n} {β β' : Type*} (f : α ⟹ α') (g : β → β') :
  drop_fun (f ::: g) = f := rfl

@[simp] theorem last_fun_append_fun {α α' : typevec n} {β β' : Type*} (f : α ⟹ α') (g : β → β') :
  last_fun (f ::: g) = g := rfl

theorem split_drop_fun_last_fun {α α' : typevec (n+1)} (f : α ⟹ α') :
  split_fun (drop_fun f) (last_fun f) = f :=
eq_of_drop_last_eq rfl rfl

theorem split_fun_inj
  {α α' : typevec (n+1)} {f f' : drop α ⟹ drop α'} {g g' : last α → last α'}
  (H : split_fun f g = split_fun f' g') : f = f' ∧ g = g' :=
by rw [← drop_fun_split_fun f g, H, ← last_fun_split_fun f g, H]; simp

theorem append_fun_inj {α α' : typevec n} {β β' : Type*} {f f' : α ⟹ α'} {g g' : β → β'} :
  f ::: g = f' ::: g' →  f = f' ∧ g = g' :=
split_fun_inj

theorem split_fun_comp {α₀ α₁ α₂ : typevec (n+1)}
    (f₀ : drop α₀ ⟹ drop α₁) (f₁ : drop α₁ ⟹ drop α₂)
    (g₀ : last α₀ → last α₁) (g₁ : last α₁ → last α₂) :
  split_fun (f₁ ⊚ f₀) (g₁ ∘ g₀) = split_fun f₁ g₁ ⊚ split_fun f₀ g₀ :=
eq_of_drop_last_eq rfl rfl

theorem append_fun_comp_split_fun
  {α γ : typevec n} {β δ : Type*} {ε : typevec (n + 1)}
    (f₀ : drop ε ⟹ α) (f₁ : α ⟹ γ)
    (g₀ : last ε → β) (g₁ : β → δ) :
  append_fun f₁ g₁ ⊚ split_fun f₀ g₀ = split_fun (f₁ ⊚ f₀) (g₁ ∘ g₀) :=
(split_fun_comp _ _ _ _).symm

lemma append_fun_comp {α₀ α₁ α₂ : typevec n} {β₀ β₁ β₂ : Type*}
    (f₀ : α₀ ⟹ α₁) (f₁ : α₁ ⟹ α₂) (g₀ : β₀ → β₁) (g₁ : β₁ → β₂) :
  f₁ ⊚ f₀ ::: g₁ ∘ g₀ = (f₁ ::: g₁) ⊚ (f₀ ::: g₀) :=
eq_of_drop_last_eq rfl rfl

lemma append_fun_comp' {α₀ α₁ α₂ : typevec n} {β₀ β₁ β₂ : Type*}
    (f₀ : α₀ ⟹ α₁) (f₁ : α₁ ⟹ α₂) (g₀ : β₀ → β₁) (g₁ : β₁ → β₂) :
  (f₁ ::: g₁) ⊚ (f₀ ::: g₀) = f₁ ⊚ f₀ ::: g₁ ∘ g₀ :=
eq_of_drop_last_eq rfl rfl

lemma nil_fun_comp {α₀ : typevec 0} (f₀ : α₀ ⟹ fin2.elim0) : nil_fun ⊚ f₀ = f₀ :=
funext $ λ x, fin2.elim0 x

theorem append_fun_comp_id {α : typevec n} {β₀ β₁ β₂ : Type*}
    (g₀ : β₀ → β₁) (g₁ : β₁ → β₂) :
  @id _ α ::: g₁ ∘ g₀ = (id ::: g₁) ⊚ (id ::: g₀) :=
eq_of_drop_last_eq rfl rfl

@[simp]
theorem drop_fun_comp {α₀ α₁ α₂ : typevec (n+1)} (f₀ : α₀ ⟹ α₁) (f₁ : α₁ ⟹ α₂) :
  drop_fun (f₁ ⊚ f₀) = drop_fun f₁ ⊚ drop_fun f₀ := rfl

@[simp]
theorem last_fun_comp {α₀ α₁ α₂ : typevec (n+1)} (f₀ : α₀ ⟹ α₁) (f₁ : α₁ ⟹ α₂) :
  last_fun (f₁ ⊚ f₀) = last_fun f₁ ∘ last_fun f₀ := rfl

theorem append_fun_aux {α α' : typevec n} {β β' : Type*}
  (f : α ::: β ⟹ α' ::: β') : drop_fun f ::: last_fun f = f :=
eq_of_drop_last_eq rfl rfl

theorem append_fun_id_id {α : typevec n} {β : Type*} :
  @typevec.id n α ::: @_root_.id β = typevec.id :=
eq_of_drop_last_eq rfl rfl

instance subsingleton0 : subsingleton (typevec 0) :=
⟨ λ a b, funext $ λ a, fin2.elim0 a  ⟩

run_cmd do
  mk_simp_attr `typevec,
  tactic.add_doc_string `simp_attr.typevec
"simp set for the manipulation of typevec and arrow expressions"

local prefix `♯`:0 := cast (by try { simp }; congr' 1; try { simp })

/-- cases distinction for 0-length type vector -/
protected def cases_nil {β : typevec 0 → Sort*} (f : β fin2.elim0) :
  Π v, β v :=
λ v, ♯ f

/-- cases distinction for (n+1)-length type vector -/
protected def cases_cons (n : ℕ) {β : typevec (n+1) → Sort*}
  (f : Π t (v : typevec n), β (v ::: t)) :
  Π v, β v :=
λ v : typevec (n+1), ♯ f v.last v.drop

protected lemma cases_nil_append1 {β : typevec 0 → Sort*} (f : β fin2.elim0) :
  typevec.cases_nil f fin2.elim0 = f := rfl

protected lemma cases_cons_append1 (n : ℕ) {β : typevec (n+1) → Sort*}
      (f : Π t (v : typevec n), β (v ::: t))
      (v : typevec n) (α) :
  typevec.cases_cons n f (v ::: α) = f α v := rfl

/-- cases distinction for an arrow in the category of 0-length type vectors -/
def typevec_cases_nil₃ {β : Π v v' : typevec 0, v ⟹ v' → Sort*}
  (f : β fin2.elim0 fin2.elim0 nil_fun) :
  Π v v' fs, β v v' fs :=
λ v v' fs,
begin
  refine cast _ f; congr' 1; ext; try { intros; casesm fin2 0 }, refl
end

/-- cases distinction for an arrow in the category of (n+1)-length type vectors -/
def typevec_cases_cons₃ (n : ℕ) {β : Π v v' : typevec (n+1), v ⟹ v' → Sort*}
  (F : Π t t' (f : t → t') (v v' : typevec n) (fs : v ⟹ v'), β (v ::: t) (v' ::: t') (fs ::: f)) :
  Π v v' fs, β v v' fs :=
begin
  intros v v',
  rw [←append1_drop_last v, ←append1_drop_last v'],
  intro fs,
  rw [←split_drop_fun_last_fun fs],
  apply F
end

/-- specialized cases distinction for an arrow in the category of 0-length type vectors -/
def typevec_cases_nil₂ {β : fin2.elim0 ⟹ fin2.elim0 → Sort*}
  (f : β nil_fun) :
  Π f, β f :=
begin
  intro g, have : g = nil_fun, ext ⟨ ⟩,
  rw this, exact f
end

/-- specialized cases distinction for an arrow in the category of (n+1)-length type vectors -/
def typevec_cases_cons₂ (n : ℕ) (t t' : Type*) (v v' : typevec (n))
  {β : (v ::: t) ⟹ (v' ::: t') → Sort*} (F : Π (f : t → t') (fs : v ⟹ v'), β (fs ::: f)) :
  Π fs, β fs :=
begin
  intro fs,
  rw [←split_drop_fun_last_fun fs],
  apply F
end

lemma typevec_cases_nil₂_append_fun {β : fin2.elim0 ⟹ fin2.elim0 → Sort*}
  (f : β nil_fun) :
  typevec_cases_nil₂ f nil_fun = f := rfl

lemma typevec_cases_cons₂_append_fun (n : ℕ) (t t' : Type*)
  (v v' : typevec (n)) {β : (v ::: t) ⟹ (v' ::: t') → Sort*}
  (F : Π (f : t → t') (fs : v ⟹ v'), β (fs ::: f)) (f fs) :
  typevec_cases_cons₂ n t t' v v' F (fs ::: f) = F f fs := rfl

/- for lifting predicates and relations -/

/-- `pred_last α p x` predicates `p` of the last element of `x : α.append1 β`. -/
def pred_last (α : typevec n) {β : Type*} (p : β → Prop) : Π ⦃i⦄, (α.append1 β) i → Prop
| (fin2.fs i) := λ x, true
| fin2.fz      := p

/-- `rel_last α r x y` says that `p` the last elements of `x y : α.append1 β` are related by `r` and
all the other elements are equal. -/
def rel_last (α : typevec n) {β γ : Type*} (r : β → γ → Prop) :
  Π ⦃i⦄, (α.append1 β) i → (α.append1 γ) i → Prop
| (fin2.fs i) := eq
| fin2.fz      := r

section liftp'
open nat

/-- `repeat n t` is a `n-length` type vector that contains `n` occurences of `t` -/
def repeat : Π (n : ℕ) (t : Sort*), typevec n
| 0 t := fin2.elim0
| (nat.succ i) t := append1 (repeat i t) t

/-- `prod α β` is the pointwise product of the components of `α` and `β` -/
def prod : Π {n} (α β : typevec.{u} n), typevec n
| 0 α β := fin2.elim0
| (n+1) α β := prod (drop α) (drop β) ::: (last α × last β)

localized "infix (name := typevec.prod) ` ⊗ `:45 := typevec.prod" in mvfunctor

/-- `const x α` is an arrow that ignores its source and constructs a `typevec` that
contains nothing but `x` -/
protected def const {β} (x : β) : Π {n} (α : typevec n), α ⟹ repeat _ β
| (succ n) α (fin2.fs i) := const (drop α) _
| (succ n) α fin2.fz := λ _, x

open function (uncurry)

/-- vector of equality on a product of vectors -/
def repeat_eq : Π {n} (α : typevec n), α ⊗ α ⟹ repeat _ Prop
| 0 α := nil_fun
| (succ n) α := repeat_eq (drop α) ::: uncurry eq

lemma const_append1 {β γ} (x : γ) {n} (α : typevec n) :
  typevec.const x (α ::: β) = append_fun (typevec.const x α) (λ _, x) :=
by ext i : 1; cases i; refl

lemma eq_nil_fun {α β : typevec 0} (f : α ⟹ β) : f = nil_fun :=
by ext x; cases x

lemma id_eq_nil_fun {α : typevec 0} : @id _ α = nil_fun :=
by ext x; cases x

lemma const_nil {β} (x : β) (α : typevec 0) : typevec.const x α = nil_fun :=
by ext i : 1; cases i; refl

@[typevec]
lemma repeat_eq_append1 {β} {n} (α : typevec n) :
  repeat_eq (α ::: β) = split_fun (repeat_eq α) (uncurry eq) :=
by induction n; refl

@[typevec]
lemma repeat_eq_nil (α : typevec 0) : repeat_eq α = nil_fun :=
by ext i : 1; cases i; refl

/-- predicate on a type vector to constrain only the last object -/
def pred_last' (α : typevec n) {β : Type*} (p : β → Prop) : α ::: β ⟹ repeat (n+1) Prop :=
split_fun (typevec.const true α) p

/-- predicate on the product of two type vectors to constrain only their last object -/
def rel_last' (α : typevec n) {β : Type*} (p : β → β → Prop) :
  (α ::: β ⊗ α ::: β) ⟹ repeat (n+1) Prop :=
split_fun (repeat_eq α) (uncurry p)

/-- given `F : typevec.{u} (n+1) → Type u`, `curry F : Type u → typevec.{u} → Type u`,
i.e. its first argument can be fed in separately from the rest of the vector of arguments -/
def curry (F : typevec.{u} (n+1) → Type*) (α : Type u) (β : typevec.{u} n) : Type* :=
F (β ::: α)

instance curry.inhabited (F : typevec.{u} (n+1) → Type*) (α : Type u) (β : typevec.{u} n)
  [I : inhabited (F $ β ::: α)]:
  inhabited (curry F α β) := I

/-- arrow to remove one element of a `repeat` vector -/
def drop_repeat (α : Type*) : Π {n}, drop (repeat (succ n) α) ⟹ repeat n α
| (succ n) (fin2.fs i) := drop_repeat i
| (succ n) fin2.fz := _root_.id

/-- projection for a repeat vector -/
def of_repeat {α : Sort*} : Π {n i}, repeat n α i → α
| ._ fin2.fz := _root_.id
| ._ (fin2.fs i) := @of_repeat _ i

lemma const_iff_true {α : typevec n} {i x p} : of_repeat (typevec.const p α i x) ↔ p :=
by induction i; [refl, erw [typevec.const,@i_ih (drop α) x]]

-- variables  {F : typevec.{u} n → Type*} [mvfunctor F]
variables {α β γ : typevec.{u} n}
variables (p : α ⟹ repeat n Prop) (r : α ⊗ α ⟹ repeat n Prop)

/-- left projection of a `prod` vector -/
def prod.fst : Π {n} {α β : typevec.{u} n}, α ⊗ β ⟹ α
| (succ n) α β (fin2.fs i) := @prod.fst _ (drop α) (drop β) i
| (succ n) α β fin2.fz := _root_.prod.fst

/-- right projection of a `prod` vector -/
def prod.snd : Π {n} {α β : typevec.{u} n}, α ⊗ β ⟹ β
| (succ n) α β (fin2.fs i) := @prod.snd _ (drop α) (drop β) i
| (succ n) α β fin2.fz := _root_.prod.snd

/-- introduce a product where both components are the same -/
def prod.diag : Π {n} {α : typevec.{u} n}, α ⟹ α ⊗ α
| (succ n) α (fin2.fs i) x := @prod.diag _ (drop α) _ x
| (succ n) α fin2.fz x := (x,x)

/-- constructor for `prod` -/
def prod.mk : Π {n} {α β : typevec.{u} n} (i : fin2 n), α i → β i → (α ⊗ β) i
| (succ n) α β (fin2.fs i) := prod.mk i
| (succ n) α β fin2.fz := _root_.prod.mk

@[simp]
lemma prod_fst_mk {α β : typevec n} (i : fin2 n) (a : α i) (b : β i) :
  typevec.prod.fst i (prod.mk i a b) = a :=
by induction i; simp [prod.fst, prod.mk, *] at *

@[simp]
lemma prod_snd_mk {α β : typevec n} (i : fin2 n) (a : α i) (b : β i) :
  typevec.prod.snd i (prod.mk i a b) = b :=
by induction i; simp [prod.snd, prod.mk, *] at *

/-- `prod` is functorial -/
protected def prod.map : Π {n} {α α' β β' : typevec.{u} n}, (α ⟹ β) → (α' ⟹ β') → α ⊗ α' ⟹ β ⊗ β'
| (succ n) α α' β β' x y (fin2.fs i) a :=
  @prod.map _ (drop α) (drop α') (drop β) (drop β') (drop_fun x) (drop_fun y) _ a
| (succ n) α α' β β' x y fin2.fz a := (x _ a.1,y _ a.2)

localized "infix (name := typevec.prod.map) ` ⊗' `:45 := typevec.prod.map" in mvfunctor

theorem fst_prod_mk {α α' β β' : typevec n} (f : α ⟹ β) (g : α' ⟹ β') :
  typevec.prod.fst ⊚ (f ⊗' g) = f ⊚ typevec.prod.fst :=
by ext i; induction i; [refl, apply i_ih]

theorem snd_prod_mk {α α' β β' : typevec n} (f : α ⟹ β) (g : α' ⟹ β') :
  typevec.prod.snd ⊚ (f ⊗' g) = g ⊚ typevec.prod.snd :=
by ext i; induction i; [refl, apply i_ih]

theorem fst_diag {α : typevec n} : typevec.prod.fst ⊚ (prod.diag : α ⟹ _) = id :=
by ext i; induction i; [refl, apply i_ih]

theorem snd_diag {α : typevec n} : typevec.prod.snd ⊚ (prod.diag : α ⟹ _) = id :=
by ext i; induction i; [refl, apply i_ih]

lemma repeat_eq_iff_eq {α : typevec n} {i x y} :
  of_repeat (repeat_eq α i (prod.mk _ x y)) ↔ x = y :=
by induction i; [refl, erw [repeat_eq,@i_ih (drop α) x y]]

/-- given a predicate vector `p` over vector `α`, `subtype_ p` is the type of vectors
that contain an `α` that satisfies `p` -/
def subtype_ : Π {n} {α : typevec.{u} n} (p : α ⟹ repeat n Prop), typevec n
| ._ α p fin2.fz := _root_.subtype (λ x, p fin2.fz x)
| ._ α p (fin2.fs i) := subtype_ (drop_fun p) i

/-- projection on `subtype_` -/
def subtype_val : Π {n} {α : typevec.{u} n} (p : α ⟹ repeat n Prop), subtype_ p ⟹ α
| (succ n) α p (fin2.fs i) := @subtype_val n _ _ i
| (succ n) α p fin2.fz := _root_.subtype.val

/-- arrow that rearranges the type of `subtype_` to turn a subtype of vector into
a vector of subtypes -/
def to_subtype : Π {n} {α : typevec.{u} n} (p : α ⟹ repeat n Prop),
  (λ (i : fin2 n), { x // of_repeat $ p i x }) ⟹ subtype_ p
| (succ n) α p (fin2.fs i) x := to_subtype (drop_fun p) i x
| (succ n) α p fin2.fz x := x

/-- arrow that rearranges the type of `subtype_` to turn a vector of subtypes
into a subtype of vector -/
def of_subtype : Π {n} {α : typevec.{u} n} (p : α ⟹ repeat n Prop),
  subtype_ p ⟹ (λ (i : fin2 n), { x // of_repeat $ p i x })
| (succ n) α p (fin2.fs i) x := of_subtype _ i x
| (succ n) α p fin2.fz x := x

/-- similar to `to_subtype` adapted to relations (i.e. predicate on product) -/
def to_subtype' : Π {n} {α : typevec.{u} n} (p : α ⊗ α ⟹ repeat n Prop),
  (λ (i : fin2 n), { x : α i × α i // of_repeat $ p i (prod.mk _ x.1 x.2) }) ⟹ subtype_ p
| (succ n) α p (fin2.fs i) x := to_subtype' (drop_fun p) i x
| (succ n) α p fin2.fz x := ⟨x.val,cast (by congr; simp [prod.mk]) x.property⟩

/-- similar to `of_subtype` adapted to relations (i.e. predicate on product) -/
def of_subtype' : Π {n} {α : typevec.{u} n} (p : α ⊗ α ⟹ repeat n Prop),
  subtype_ p ⟹ (λ (i : fin2 n), { x : α i × α i // of_repeat $ p i (prod.mk _ x.1 x.2) })
| ._ α p (fin2.fs i) x := of_subtype' _ i x
| ._ α p fin2.fz x := ⟨x.val,cast (by congr; simp [prod.mk]) x.property⟩

/-- similar to `diag` but the target vector is a `subtype_`
guaranteeing the equality of the components -/
def diag_sub  : Π {n} {α : typevec.{u} n}, α ⟹ subtype_ (repeat_eq α)
| (succ n) α (fin2.fs i) x := @diag_sub _ (drop α) _ x
| (succ n) α fin2.fz x := ⟨(x,x), rfl⟩

lemma subtype_val_nil {α : typevec.{u} 0} (ps : α ⟹ repeat 0 Prop) :
  typevec.subtype_val ps = nil_fun :=
funext $ by rintro ⟨ ⟩; refl

lemma diag_sub_val {n} {α : typevec.{u} n} :
  subtype_val (repeat_eq α) ⊚ diag_sub = prod.diag :=
by ext i; induction i; [refl, apply i_ih]

lemma prod_id : Π {n} {α β : typevec.{u} n}, (id ⊗' id) = (id : α ⊗ β ⟹ _) :=
begin
  intros, ext i a, induction i,
  { cases a, refl },
  { apply i_ih },
end

lemma append_prod_append_fun {n} {α α' β β' : typevec.{u} n}
  {φ φ' ψ ψ' : Type u}
  {f₀ : α ⟹ α'} {g₀ : β ⟹ β'}
  {f₁ : φ → φ'}  {g₁ : ψ → ψ'} :
  (f₀ ⊗' g₀) ::: _root_.prod.map f₁ g₁ = ((f₀ ::: f₁) ⊗' (g₀ ::: g₁)) :=
by ext i a; cases i; [cases a, skip]; refl

end liftp'

@[simp]
lemma drop_fun_diag {α} :
  drop_fun (@prod.diag (n+1) α) = prod.diag :=
by { ext i : 2, induction i; simp [drop_fun, *]; refl }

@[simp]
lemma drop_fun_subtype_val {α} (p : α ⟹ repeat (n+1) Prop) :
  drop_fun (subtype_val p) = subtype_val _ := rfl

@[simp]
lemma last_fun_subtype_val {α} (p : α ⟹ repeat (n+1) Prop) :
  last_fun (subtype_val p) = subtype.val := rfl

@[simp]
lemma drop_fun_to_subtype {α} (p : α ⟹ repeat (n+1) Prop) :
  drop_fun (to_subtype p) = to_subtype _ :=
by { ext i : 2, induction i; simp [drop_fun, *]; refl }

@[simp]
lemma last_fun_to_subtype {α} (p : α ⟹ repeat (n+1) Prop) :
  last_fun (to_subtype p) = _root_.id :=
by { ext i : 2, induction i; simp [drop_fun, *]; refl }

@[simp]
lemma drop_fun_of_subtype {α} (p : α ⟹ repeat (n+1) Prop) :
  drop_fun (of_subtype p) = of_subtype _ :=
by { ext i : 2, induction i; simp [drop_fun, *]; refl }

@[simp]
lemma last_fun_of_subtype {α} (p : α ⟹ repeat (n+1) Prop) :
  last_fun (of_subtype p) = _root_.id :=
by { ext i : 2, induction i; simp [drop_fun, *]; refl }

@[simp]
lemma drop_fun_rel_last {α : typevec n} {β}
  (R : β → β → Prop) :
  drop_fun (rel_last' α R) = repeat_eq α := rfl

attribute [simp] drop_append1'
open_locale mvfunctor

@[simp]
lemma drop_fun_prod {α α' β β' : typevec (n+1)} (f : α ⟹ β) (f' : α' ⟹ β') :
  drop_fun (f ⊗' f') = (drop_fun f ⊗' drop_fun f') :=
by { ext i : 2, induction i; simp [drop_fun, *]; refl }

@[simp]
lemma last_fun_prod {α α' β β' : typevec (n+1)} (f : α ⟹ β) (f' : α' ⟹ β') :
  last_fun (f ⊗' f') = _root_.prod.map (last_fun f) (last_fun f') :=
by { ext i : 1, induction i; simp [last_fun, *]; refl }

@[simp]
lemma drop_fun_from_append1_drop_last {α : typevec (n+1)} :
  drop_fun (@from_append1_drop_last _ α) = id := rfl

@[simp]
lemma last_fun_from_append1_drop_last {α : typevec (n+1)} :
  last_fun (@from_append1_drop_last _ α) = _root_.id := rfl

@[simp]
lemma drop_fun_id {α : typevec (n+1)} :
  drop_fun (@typevec.id _ α) = id := rfl

@[simp]
lemma prod_map_id {α β : typevec n} :
  (@typevec.id _ α ⊗' @typevec.id _ β) = id :=
by { ext i : 2, induction i; simp only [typevec.prod.map, *, drop_fun_id],
     cases x, refl, refl }

@[simp]
lemma subtype_val_diag_sub {α : typevec n} :
  subtype_val (repeat_eq α) ⊚ diag_sub = prod.diag :=
by { clear_except, ext i, induction i; [refl, apply i_ih], }

@[simp]
lemma to_subtype_of_subtype {α : typevec n} (p : α ⟹ repeat n Prop) :
  to_subtype p ⊚ of_subtype p = id :=
by ext i x; induction i; dsimp only [id, to_subtype, comp, of_subtype] at *; simp *

@[simp]
lemma subtype_val_to_subtype {α : typevec n} (p : α ⟹ repeat n Prop) :
  subtype_val p ⊚ to_subtype p = λ _, subtype.val :=
by ext i x; induction i; dsimp only [to_subtype, comp, subtype_val] at *; simp *

@[simp]
lemma to_subtype_of_subtype_assoc {α β : typevec n} (p : α ⟹ repeat n Prop)
  (f : β ⟹ subtype_ p) :
  @to_subtype n _ p ⊚ of_subtype _ ⊚ f = f :=
by rw [← comp_assoc,to_subtype_of_subtype]; simp

@[simp]
lemma to_subtype'_of_subtype' {α : typevec n} (r : α ⊗ α ⟹ repeat n Prop) :
  to_subtype' r ⊚ of_subtype' r = id :=
by ext i x; induction i; dsimp only [id, to_subtype', comp, of_subtype'] at *; simp [subtype.eta, *]

lemma subtype_val_to_subtype' {α : typevec n} (r : α ⊗ α ⟹ repeat n Prop) :
  subtype_val r ⊚ to_subtype' r = λ i x, prod.mk i x.1.fst x.1.snd :=
by ext i x; induction i; dsimp only [id, to_subtype', comp, subtype_val, prod.mk] at *; simp *

end typevec


/- Exercise 3.2: Program Semantics — Hoare Logic -/

/- Download `x32_library.lean` from the "Logical Verification" homepage and put it in the same
directory as this exercise sheet. -/

import .x32_library

namespace lecture

/- Background material from the lecture. Do not prove the `sorry`s below. -/

def program.while_inv (I : state → Prop) (c : state → Prop) (p : program) : program :=
program.while c p

open program

variables
  {c : state → Prop} {f : state → ℕ} {n : string}
  {p p₀ p₁ p₂ : program} {s s₀ s₁ s₂ t u : state}
  {P P' P₁ P₂ P₃ Q Q' : state → Prop}

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

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

namespace partial_hoare

lemma consequence (h : {* P *} p {* Q *}) (hp : ∀s, P' s → P s) (hq : ∀s, Q s → Q' s) :
  {* P' *} p {* Q' *} :=
sorry

lemma consequence_left (P' : state → Prop) (h : {* P *} p {* Q *}) (hp : ∀s, P' s → P s) :
  {* P' *} p {* Q *} :=
sorry

lemma consequence_right (Q : state → Prop) (h : {* P *} p {* Q *}) (hq : ∀s, Q s → Q' s) :
  {* P *} p {* Q' *} :=
sorry

lemma skip_intro :
  {* P *} skip {* P *} :=
sorry

lemma assign_intro (P : state → Prop) :
  {* λs, P (s.update n (f s)) *} assign n f {* P *} :=
sorry

lemma seq_intro (h₁ : {* P₁ *} p₁ {* P₂ *}) (h₂ : {* P₂ *} p₂ {* P₃ *}) :
  {* P₁ *} seq p₁ p₂ {* P₃ *} :=
sorry

lemma ite_intro (h₁ : {* λs, P s ∧ c s *} p₁ {* Q *}) (h₂ : {* λs, P s ∧ ¬ c s *} p₂ {* Q *}) :
  {* P *} ite c p₁ p₂ {* Q *} :=
sorry

lemma while_intro (P : state → Prop) (h₁ : {* λs, P s ∧ c s *} p {* P *}) :
  {* P *} while c p {* λs, P s ∧ ¬ c s *} :=
sorry

lemma skip_intro' (h : ∀s, P s → Q s):
  {* P *} skip {* Q *} :=
sorry

lemma assign_intro' (h : ∀s, P s → Q (s.update n (f s))):
  {* P *} assign n f {* Q *} :=
sorry

lemma seq_intro' (h₂ : {* P₂ *} p₂ {* P₃ *}) (h₁ : {* P₁ *} p₁ {* P₂ *}) :
  {* P₁ *} p₁ ;; p₂ {* P₃ *} :=
sorry

lemma while_intro_inv (I : state → Prop)
  (h₁ : {* λs, I s ∧ c s *} p {* I *}) (hp : ∀s, P s → I s) (hq : ∀s, ¬ c s → I s → Q s) :
  {* P *} while c p {* Q *} :=
sorry

lemma while_inv_intro {I : state → Prop}
  (h₁ : {* λs, I s ∧ c s *} p {* I *}) (hq : ∀s, ¬ c s → I s → Q s) :
  {* I *} while_inv I c p {* Q *} :=
sorry

lemma while_inv_intro' {I : state → Prop}
  (h₁ : {* λs, I s ∧ c s *} p {* I *}) (hp : ∀s, P s → I s) (hq : ∀s, ¬ c s → I s → Q s) :
  {* P *} while_inv I c p {* Q *} :=
sorry

end partial_hoare

end lecture

namespace tactic.interactive

open lecture.partial_hoare lecture tactic

meta def is_meta {elab : bool} : expr elab → bool
| (expr.mvar _ _ _) := tt
| _                 := ff

meta def vcg : tactic unit := do
  `({* %%P *} %%p {* %%Q *}) ← target
  | skip, -- do nothing if the goal is not a Hoare triple
match p with
| `(program.skip)            := applyc (if is_meta P then ``skip_intro else ``skip_intro')
| `(program.assign _ _)      := applyc (if is_meta P then ``assign_intro else ``assign_intro')
| `(program.ite _ _ _)       := do applyc ``ite_intro; vcg
| `(program.seq _ _)         := do applyc ``seq_intro'; vcg
| `(program.while_inv _ _ _) :=
  do applyc (if is_meta P then ``while_inv_intro else ``while_inv_intro'); vcg
| _                          := fail (to_fmt "cannot analyze " ++ to_fmt p)

end

end tactic.interactive

namespace lecture

open program partial_hoare

/- Question 1: Program verification -/

section GAUSS

/- The following WHILE program is intended to compute the Gaussian sum up to `n`, leaving the result
in `r`. -/

def GAUSS : program :=
assign "r" (λs, 0) ;;
while (λs, s "n" ≠ 0)
( assign "r" (λs, s "r" + s "n") ;;
  assign "n" (λs, s "n" - 1) )

/- The summation function: -/

def sum_upto : ℕ → ℕ
| 0       := 0
| (n + 1) := n + 1 + sum_upto n

/- 1.1. Prove the correctness of `GAUSS`, using `vcg`. The main challenge is to figure out which
invariant to use for the while loop. The invariant should capture both the work that has been done
already (the intermediate result) and the work that remains to be done. -/

lemma GAUSS_correct (n : ℕ) :
  {* λs, s "n" = n *} GAUSS {* λs, s "r" = sum_upto n *} :=
sorry

end GAUSS

section MUL

/- The following WHILE program is intended to compute the product of `n` and `m`, leaving the
result in `r`. -/

def MUL : program :=
assign "r" (λs, 0) ;;
while (λs, s "n" ≠ 0)
( assign "r" (λs, s "r" + s "m") ;;
  assign "n" (λs, s "n" - 1) )

/- 1.2 Prove the correctness of `MUL`, using `vcg`.

Hint: If a variable `x` does not change in a program, it might be useful to record this in the
invariant, by adding a conjunct `s "x" = x`. -/

lemma MUL_correct (n m : ℕ) :
  {* λs, s "n" = n ∧ s "m" = m *} MUL {* λs, s "r" = n * m *} :=
sorry

end MUL

/- Question 2: Hoare triples for total correctness -/

def total_hoare (P : state → Prop) (p : program) (Q : state → Prop) : Prop :=
∀s, P s → ∃t, (p, s) ⟹ t ∧ Q t

notation `[* ` P : 1 ` *] ` p : 1 ` [* ` Q : 1 ` *]` := total_hoare P p Q

namespace total_hoare
variables {P P' P₁ P₂ P₃ Q Q' : state → Prop} {n : string}
variables {p p₀ p₁ p₂ : program}
variables {c : state → Prop} {f : state → ℕ}
  {s s₀ s₁ s₂ t u : state}

/- 2.1. Prove the consequence rule. -/

lemma consequence (h : [* P *] p [* Q *]) (hp : ∀s, P' s → P s) (hq : ∀s, Q s → Q' s) :
  [* P' *] p [* Q' *] :=
sorry

/- 2.2. Prove the rule for `skip`. -/

lemma skip_intro :
  [* P *] skip [* P *] :=
sorry

/- 2.3. Prove the rule for `assign`. -/

lemma assign_intro (P : state → Prop) :
  [* λs, P (s.update n (f s)) *] assign n f [* P *] :=
sorry

/- 2.4. Prove the rule for `seq`. -/

lemma seq_intro (h₁ : [* P₁ *] p₁ [* P₂ *]) (h₂ : [* P₂ *] p₂ [* P₃ *]) :
  [* P₁ *] p₁ ;; p₂ [* P₃ *] :=
sorry

/- 2.5. Prove the rule for `ite`. This requires `c s ∨ ¬ c s`. `classical.em (c s)` provides a
proof, even when `c` is not decidable. -/

lemma ite_intro (h₁ : [* λs, P s ∧ c s *] p₁ [* Q *]) (h₂ : [* λs, P s ∧ ¬ c s *] p₂ [* Q *]) :
  [* P *] ite c p₁ p₂ [* Q *] :=
sorry

/- 2.6. Try to prove the rule for `while`.

Before we prove our final goal, we introduce an auxiliary proof. This proof requires
well-founded induction. When using `while_intro.aux` as induction hypothesis we recommend
to do it directly after proving that the argument is less than `n`:

    have ih : ∃u, (while c p, t) ⟹ u ∧ I u ∧ ¬c u :=
      have M < n := ..., -- necessary for Lean to figure out the well-founded induction
      while_intro.aux M ...,

Similar to `ite`, this requires `c s ∨ ¬ c s`. `classical.em (c s)` provides a proof. -/

lemma while_intro.aux
  (I : state → Prop)
  (V : state → ℕ)
  (h_inv : ∀n, [* λs, I s ∧ c s ∧ V s = n *] p [* λs, I s ∧ V s < n *]) :
  ∀n s, V s = n → I s → ∃t, (while c p, s) ⟹ t ∧ I t ∧ ¬ c t
| n s V_eq hs :=
sorry

lemma while_intro
  (I : state → Prop)  -- invariant in the loop
  (V : state → ℕ)  -- variant in the loop body (a.k.a. termination measure)
  (h_inv : ∀n, [* λs, I s ∧ c s ∧ V s = n *] p [* λs, I s ∧ V s < n *]) :
  [* I *] while c p [* λs, I s ∧ ¬ c s *] :=
sorry

end total_hoare

end lecture


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

! This file was ported from Lean 3 source module data.set.Union_lift
! 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.Data.Set.Lattice
import Mathlib.Order.Directed

/-!
# Union lift
This file defines `Set.unionᵢLift` to glue together functions defined on each of a collection of
sets to make a function on the Union of those sets.

## Main definitions

* `Set.unionᵢLift` -  Given a Union of sets `unionᵢ S`, define a function on any subset of the Union
  by defining it on each component, and proving that it agrees on the intersections.
* `Set.liftCover` - Version of `Set.unionᵢLift` for the special case that the sets cover the
  entire type.

## Main statements

There are proofs of the obvious properties of `unionᵢLift`, i.e. what it does to elements of
each of the sets in the `unionᵢ`, stated in different ways.

There are also three lemmas about `unionᵢLift` intended to aid with proving that `unionᵢLift` is a
homomorphism when defined on a Union of substructures. There is one lemma each to show that
constants, unary functions, or binary functions are preserved. These lemmas are:

*`Set.unionᵢLift_const`
*`Set.unionᵢLift_unary`
*`Set.unionᵢLift_binary`

## Tags

directed union, directed supremum, glue, gluing
-/

variable {α ι β : Type _}

namespace Set

section UnionLift

/- The unused argument is left in the definition so that the `simp` lemmas
`unionᵢLift_inclusion` will work without the user having to provide it explicitly to
simplify terms involving `unionᵢLift`. -/
/-- Given a union of sets `unionᵢ S`, define a function on the Union by defining
it on each component, and proving that it agrees on the intersections. -/
@[nolint unusedArguments]
noncomputable def unionᵢLift (S : ι → Set α) (f : ∀ (i) (_ : S i), β)
    (_ : ∀ (i j) (x : α) (hxi : x ∈ S i) (hxj : x ∈ S j), f i ⟨x, hxi⟩ = f j ⟨x, hxj⟩) (T : Set α)
    (hT : T ⊆ unionᵢ S) (x : T) : β :=
  let i := Classical.indefiniteDescription _ (mem_unionᵢ.1 (hT x.prop))
  f i ⟨x, i.prop⟩
#align set.Union_lift Set.unionᵢLift

variable {S : ι → Set α} {f : ∀ (i) (_ : S i), β}
  {hf : ∀ (i j) (x : α) (hxi : x ∈ S i) (hxj : x ∈ S j), f i ⟨x, hxi⟩ = f j ⟨x, hxj⟩} {T : Set α}
  {hT : T ⊆ unionᵢ S} (hT' : T = unionᵢ S)

@[simp]
theorem unionᵢLift_mk {i : ι} (x : S i) (hx : (x : α) ∈ T) :
    unionᵢLift S f hf T hT ⟨x, hx⟩ = f i x := hf _ i x _ _
#align set.Union_lift_mk Set.unionᵢLift_mk

@[simp]
theorem unionᵢLift_inclusion {i : ι} (x : S i) (h : S i ⊆ T) :
    unionᵢLift S f hf T hT (Set.inclusion h x) = f i x :=
  unionᵢLift_mk x _
#align set.Union_lift_inclusion Set.unionᵢLift_inclusion

theorem unionᵢLift_of_mem (x : T) {i : ι} (hx : (x : α) ∈ S i) :
    unionᵢLift S f hf T hT x = f i ⟨x, hx⟩ := by cases' x with x hx; exact hf _ _ _ _ _
#align set.Union_lift_of_mem Set.unionᵢLift_of_mem

theorem preimage_unionᵢLift (t : Set β) :
    unionᵢLift S f hf T hT ⁻¹' t =
      inclusion hT ⁻¹' (⋃ i, inclusion (subset_unionᵢ S i) '' (f i ⁻¹' t)) := by
  ext x
  simp only [mem_preimage, mem_unionᵢ, mem_image]
  constructor
  · rcases mem_unionᵢ.1 (hT x.prop) with ⟨i, hi⟩
    refine fun h => ⟨i, ⟨x, hi⟩, ?_, rfl⟩
    rwa [unionᵢLift_of_mem x hi] at h
  · rintro ⟨i, ⟨y, hi⟩, h, hxy⟩
    obtain rfl : y = x := congr_arg Subtype.val hxy
    rwa [unionᵢLift_of_mem x hi]

/-- `unionᵢLift_const` is useful for proving that `unionᵢLift` is a homomorphism
  of algebraic structures when defined on the Union of algebraic subobjects.
  For example, it could be used to prove that the lift of a collection
  of group homomorphisms on a union of subgroups preserves `1`. -/
theorem unionᵢLift_const (c : T) (ci : ∀ i, S i) (hci : ∀ i, (ci i : α) = c) (cβ : β)
    (h : ∀ i, f i (ci i) = cβ) : unionᵢLift S f hf T hT c = cβ := by
  let ⟨i, hi⟩ := Set.mem_unionᵢ.1 (hT c.prop)
  have : ci i = ⟨c, hi⟩ := Subtype.ext (hci i)
  rw [unionᵢLift_of_mem _ hi, ← this, h]
#align set.Union_lift_const Set.unionᵢLift_const

/-- `unionᵢLift_unary` is useful for proving that `unionᵢLift` is a homomorphism
  of algebraic structures when defined on the Union of algebraic subobjects.
  For example, it could be used to prove that the lift of a collection
  of linear_maps on a union of submodules preserves scalar multiplication. -/
theorem unionᵢLift_unary (u : T → T) (ui : ∀ i, S i → S i)
    (hui :
      ∀ (i) (x : S i),
        u (Set.inclusion (show S i ⊆ T from hT'.symm ▸ Set.subset_unionᵢ S i) x) =
          Set.inclusion (show S i ⊆ T from hT'.symm ▸ Set.subset_unionᵢ S i) (ui i x))
    (uβ : β → β) (h : ∀ (i) (x : S i), f i (ui i x) = uβ (f i x)) (x : T) :
    unionᵢLift S f hf T (le_of_eq hT') (u x) = uβ (unionᵢLift S f hf T (le_of_eq hT') x) := by
  subst hT'
  cases' Set.mem_unionᵢ.1 x.prop with i hi
  rw [unionᵢLift_of_mem x hi, ← h i]
  have : x = Set.inclusion (Set.subset_unionᵢ S i) ⟨x, hi⟩ := by
    cases x
    rfl
  conv_lhs => rw [this, hui, unionᵢLift_inclusion]
#align set.Union_lift_unary Set.unionᵢLift_unary

/-- `unionᵢLift_binary` is useful for proving that `unionᵢLift` is a homomorphism
  of algebraic structures when defined on the Union of algebraic subobjects.
  For example, it could be used to prove that the lift of a collection
  of group homomorphisms on a union of subgroups preserves `*`. -/
theorem unionᵢLift_binary (dir : Directed (· ≤ ·) S) (op : T → T → T) (opi : ∀ i, S i → S i → S i)
    (hopi :
      ∀ i x y,
        Set.inclusion (show S i ⊆ T from hT'.symm ▸ Set.subset_unionᵢ S i) (opi i x y) =
          op (Set.inclusion (show S i ⊆ T from hT'.symm ▸ Set.subset_unionᵢ S i) x)
            (Set.inclusion (show S i ⊆ T from hT'.symm ▸ Set.subset_unionᵢ S i) y))
    (opβ : β → β → β) (h : ∀ (i) (x y : S i), f i (opi i x y) = opβ (f i x) (f i y)) (x y : T) :
    unionᵢLift S f hf T (le_of_eq hT') (op x y) =
      opβ (unionᵢLift S f hf T (le_of_eq hT') x) (unionᵢLift S f hf T (le_of_eq hT') y) := by
  subst hT'
  cases' Set.mem_unionᵢ.1 x.prop with i hi
  cases' Set.mem_unionᵢ.1 y.prop with j hj
  rcases dir i j with ⟨k, hik, hjk⟩
  rw [unionᵢLift_of_mem x (hik hi), unionᵢLift_of_mem y (hjk hj), ← h k]
  have hx : x = Set.inclusion (Set.subset_unionᵢ S k) ⟨x, hik hi⟩ := by
    cases x
    rfl
  have hy : y = Set.inclusion (Set.subset_unionᵢ S k) ⟨y, hjk hj⟩ := by
    cases y
    rfl
  have hxy : (Set.inclusion (Set.subset_unionᵢ S k) (opi k ⟨x, hik hi⟩ ⟨y, hjk hj⟩) : α) ∈ S k :=
    (opi k ⟨x, hik hi⟩ ⟨y, hjk hj⟩).prop
  conv_lhs => rw [hx, hy, ← hopi, unionᵢLift_of_mem _ hxy]
#align set.Union_lift_binary Set.unionᵢLift_binary

end UnionLift

variable {S : ι → Set α} {f : ∀ (i) (_ : S i), β}
  {hf : ∀ (i j) (x : α) (hxi : x ∈ S i) (hxj : x ∈ S j), f i ⟨x, hxi⟩ = f j ⟨x, hxj⟩}
  {hS : unionᵢ S = univ}

/-- Glue together functions defined on each of a collection `S` of sets that cover a type. See
  also `Set.unionᵢLift`.   -/
noncomputable def liftCover (S : ι → Set α) (f : ∀ (i) (_ : S i), β)
    (hf : ∀ (i j) (x : α) (hxi : x ∈ S i) (hxj : x ∈ S j), f i ⟨x, hxi⟩ = f j ⟨x, hxj⟩)
    (hS : unionᵢ S = univ) (a : α) : β :=
  unionᵢLift S f hf univ hS.symm.subset ⟨a, trivial⟩
#align set.lift_cover Set.liftCover

@[simp]
theorem liftCover_coe {i : ι} (x : S i) : liftCover S f hf hS x = f i x :=
  unionᵢLift_mk x _
#align set.lift_cover_coe Set.liftCover_coe

theorem liftCover_of_mem {i : ι} {x : α} (hx : (x : α) ∈ S i) :
    liftCover S f hf hS x = f i ⟨x, hx⟩ :=
  unionᵢLift_of_mem (⟨x, trivial⟩ : {_z // True}) hx
#align set.lift_cover_of_mem Set.liftCover_of_mem

theorem preimage_liftCover (t : Set β) : liftCover S f hf hS ⁻¹' t = ⋃ i, (↑) '' (f i ⁻¹' t) := by
  change (unionᵢLift S f hf univ hS.symm.subset ∘ fun a => ⟨a, mem_univ a⟩) ⁻¹' t = _
  rw [preimage_comp, preimage_unionᵢLift]
  ext; simp

end Set


/-
Copyright (c) 2019 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau, Johan Commelin
-/
import data.equiv.functor
import data.mv_polynomial.equiv
import data.mv_polynomial.comm_ring
import ring_theory.free_ring
import deprecated.ring

/-!
# Free commutative rings

The theory of the free commutative ring generated by a type `α`.
It is isomorphic to the polynomial ring over ℤ with variables
in `α`

## Main definitions

* `free_comm_ring α`     : the free commutative ring on a type α
* `lift (f : α → R)` : the ring hom `free_comm_ring α →+* R` induced by functoriality from `f`.
* `map (f : α → β)`      : the ring hom `free_comm_ring α →*+ free_comm_ring β` induced by
                           functoriality from f.

## Main results

`free_comm_ring` has functorial properties (it is an adjoint to the forgetful functor).
In this file we have:

* `of : α → free_comm_ring α`
* `lift (f : α → R) : free_comm_ring α →+* R`
* `map (f : α → β) : free_comm_ring α →+* free_comm_ring β`

* `free_comm_ring_equiv_mv_polynomial_int : free_comm_ring α ≃+* mv_polynomial α ℤ` :
    `free_comm_ring α` is isomorphic to a polynomial ring.

## Implementation notes

`free_comm_ring α` is implemented not using `mv_polynomial` but
directly as the free abelian group on `multiset α`, the type
of monomials in this free commutative ring.

## Tags

free commutative ring, free ring
-/

noncomputable theory
open_locale classical

universes u v

variables (α : Type u)

/-- `free_comm_ring α` is the free commutative ring on the type `α`. -/
@[derive [comm_ring, inhabited]]
def free_comm_ring (α : Type u) : Type u :=
free_abelian_group $ multiplicative $ multiset α

namespace free_comm_ring

variables {α}

/-- The canonical map from `α` to the free commutative ring on `α`. -/
def of (x : α) : free_comm_ring α :=
free_abelian_group.of $ multiplicative.of_add ({x} : multiset α)

lemma of_injective : function.injective (of : α → free_comm_ring α) :=
free_abelian_group.of_injective.comp (λ x y,
  (multiset.coe_eq_coe.trans list.singleton_perm_singleton).mp)

@[elab_as_eliminator] protected lemma induction_on
  {C : free_comm_ring α → Prop} (z : free_comm_ring α)
  (hn1 : C (-1)) (hb : ∀ b, C (of b))
  (ha : ∀ x y, C x → C y → C (x + y))
  (hm : ∀ x y, C x → C y → C (x * y)) : C z :=
have hn : ∀ x, C x → C (-x), from λ x ih, neg_one_mul x ▸ hm _ _ hn1 ih,
have h1 : C 1, from neg_neg (1 : free_comm_ring α) ▸ hn _ hn1,
free_abelian_group.induction_on z
  (add_left_neg (1 : free_comm_ring α) ▸ ha _ _ hn1 h1)
  (λ m, multiset.induction_on m h1 $ λ a m ih, hm _ _ (hb a) ih)
  (λ m ih, hn _ ih)
  ha
section lift

variables {R : Type v} [comm_ring R] (f : α → R)

/-- A helper to implement `lift`. This is essentially `free_comm_monoid.lift`, but this does not
currently exist. -/
private def lift_to_multiset : (α → R) ≃ (multiplicative (multiset α) →* R) :=
{ to_fun := λ f,
  { to_fun := λ s, (s.to_add.map f).prod,
    map_mul' := λ x y, calc _ = multiset.prod ((multiset.map f x) + (multiset.map f y)) :
                                    by {congr' 1, exact multiset.map_add _ _ _}
                          ... = _ : multiset.prod_add _ _,
    map_one' := rfl},
  inv_fun := λ F x, F (multiplicative.of_add ({x} : multiset α)),
  left_inv := λ f, funext $ λ x, show (multiset.map f {x}).prod = _, by simp,
  right_inv := λ F, monoid_hom.ext $ λ x,
    let F' := F.to_additive'', x' := x.to_add in show (multiset.map (λ a, F' {a}) x').sum = F' x',
    begin
      rw [←multiset.map_map, ←add_monoid_hom.map_multiset_sum],
      exact F.congr_arg (multiset.sum_map_singleton x'),
    end }

/-- Lift a map `α → R` to a additive group homomorphism `free_comm_ring α → R`.
For a version producing a bundled homomorphism, see `lift_hom`. -/
def lift : (α → R) ≃ (free_comm_ring α →+* R) :=
equiv.trans lift_to_multiset free_abelian_group.lift_monoid

@[simp] lemma lift_of (x : α) : lift f (of x) = f x :=
(free_abelian_group.lift.of _ _).trans $ mul_one _

@[simp] lemma lift_comp_of (f : free_comm_ring α →+* R) : lift (f ∘ of) = f :=
ring_hom.ext $ λ x, free_comm_ring.induction_on x
  (by rw [ring_hom.map_neg, ring_hom.map_one, f.map_neg, f.map_one])
  (lift_of _)
  (λ x y ihx ihy, by rw [ring_hom.map_add, f.map_add, ihx, ihy])
  (λ x y ihx ihy, by rw [ring_hom.map_mul, f.map_mul, ihx, ihy])

@[ext]
lemma hom_ext ⦃f g : free_comm_ring α →+* R⦄ (h : ∀ x, f (of x) = g (of x)) :
  f = g :=
lift.symm.injective (funext h)

end lift

variables {β : Type v} (f : α → β)

/-- A map `f : α → β` produces a ring homomorphism `free_comm_ring α →+* free_comm_ring β`. -/
def map : free_comm_ring α →+* free_comm_ring β :=
lift $ of ∘ f

@[simp]
lemma map_of (x : α) : map f (of x) = of (f x) := lift_of _ _

/-- `is_supported x s` means that all monomials showing up in `x` have variables in `s`. -/
def is_supported (x : free_comm_ring α) (s : set α) : Prop :=
x ∈ subring.closure (of '' s)

section is_supported
variables {x y : free_comm_ring α} {s t : set α}

theorem is_supported_upwards (hs : is_supported x s) (hst : s ⊆ t) :
  is_supported x t :=
subring.closure_mono (set.monotone_image hst) hs

theorem is_supported_add (hxs : is_supported x s) (hys : is_supported y s) :
  is_supported (x + y) s :=
subring.add_mem _ hxs hys

theorem is_supported_neg (hxs : is_supported x s) :
  is_supported (-x) s :=
subring.neg_mem _ hxs

theorem is_supported_sub (hxs : is_supported x s) (hys : is_supported y s) :
  is_supported (x - y) s :=
subring.sub_mem _ hxs hys

theorem is_supported_mul (hxs : is_supported x s) (hys : is_supported y s) :
  is_supported (x * y) s :=
subring.mul_mem _ hxs hys

theorem is_supported_zero : is_supported 0 s :=
subring.zero_mem _

theorem is_supported_one : is_supported 1 s :=
subring.one_mem _

theorem is_supported_int {i : ℤ} {s : set α} : is_supported ↑i s :=
int.induction_on i is_supported_zero
  (λ i hi, by rw [int.cast_add, int.cast_one]; exact is_supported_add hi is_supported_one)
  (λ i hi, by rw [int.cast_sub, int.cast_one]; exact is_supported_sub hi is_supported_one)

end is_supported

/-- The restriction map from `free_comm_ring α` to `free_comm_ring s` where `s : set α`, defined
  by sending all variables not in `s` to zero. -/
def restriction (s : set α) [decidable_pred (∈ s)] : free_comm_ring α →+* free_comm_ring s :=
lift (λ p, if H : p ∈ s then of (⟨p, H⟩ : s) else 0)

section restriction
variables (s : set α) [decidable_pred (∈ s)] (x y : free_comm_ring α)
@[simp] lemma restriction_of (p) :
  restriction s (of p) = if H : p ∈ s then of ⟨p, H⟩ else 0 := lift_of _ _

end restriction

theorem is_supported_of {p} {s : set α} : is_supported (of p) s ↔ p ∈ s :=
suffices is_supported (of p) s → p ∈ s, from ⟨this, λ hps, subring.subset_closure ⟨p, hps, rfl⟩⟩,
assume hps : is_supported (of p) s, begin
  haveI := classical.dec_pred s,
  have : ∀ x, is_supported x s →
    ∃ (n : ℤ), lift (λ a, if a ∈ s then (0 : polynomial ℤ) else polynomial.X) x = n,
  { intros x hx, refine subring.in_closure.rec_on hx _ _ _ _,
    { use 1, rw [ring_hom.map_one], norm_cast },
    { use -1, rw [ring_hom.map_neg, ring_hom.map_one], norm_cast },
    { rintros _ ⟨z, hzs, rfl⟩ _ _, use 0, rw [ring_hom.map_mul, lift_of, if_pos hzs, zero_mul],
      norm_cast },
    { rintros x y ⟨q, hq⟩ ⟨r, hr⟩, refine ⟨q+r, _⟩, rw [ring_hom.map_add, hq, hr], norm_cast } },
  specialize this (of p) hps, rw [lift_of] at this, split_ifs at this, { exact h },
  exfalso, apply ne.symm int.zero_ne_one,
  rcases this with ⟨w, H⟩, rw ←polynomial.C_eq_int_cast at H,
  have : polynomial.X.coeff 1 = (polynomial.C ↑w).coeff 1, by rw H,
  rwa [polynomial.coeff_C, if_neg (one_ne_zero : 1 ≠ 0), polynomial.coeff_X, if_pos rfl] at this
end

theorem map_subtype_val_restriction {x} (s : set α) [decidable_pred (∈ s)]
  (hxs : is_supported x s) :
  map (subtype.val : s → α) (restriction s x) = x :=
begin
  refine subring.in_closure.rec_on hxs _ _ _ _,
  { rw ring_hom.map_one, refl },
  { rw [ring_hom.map_neg, ring_hom.map_neg, ring_hom.map_one], refl },
  { rintros _ ⟨p, hps, rfl⟩ n ih,
    rw [ring_hom.map_mul, restriction_of, dif_pos hps, ring_hom.map_mul, map_of, ih] },
  { intros x y ihx ihy, rw [ring_hom.map_add, ring_hom.map_add, ihx, ihy] }
end

theorem exists_finite_support (x : free_comm_ring α) :
  ∃ s : set α, set.finite s ∧ is_supported x s :=
free_comm_ring.induction_on x
  ⟨∅, set.finite_empty, is_supported_neg is_supported_one⟩
  (λ p, ⟨{p}, set.finite_singleton p, is_supported_of.2 $ set.mem_singleton _⟩)
  (λ x y ⟨s, hfs, hxs⟩ ⟨t, hft, hxt⟩, ⟨s ∪ t, hfs.union hft, is_supported_add
    (is_supported_upwards hxs $ set.subset_union_left s t)
    (is_supported_upwards hxt $ set.subset_union_right s t)⟩)
  (λ x y ⟨s, hfs, hxs⟩ ⟨t, hft, hxt⟩, ⟨s ∪ t, hfs.union hft, is_supported_mul
    (is_supported_upwards hxs $ set.subset_union_left s t)
    (is_supported_upwards hxt $ set.subset_union_right s t)⟩)

theorem exists_finset_support (x : free_comm_ring α) : ∃ s : finset α, is_supported x ↑s :=
let ⟨s, hfs, hxs⟩ := exists_finite_support x in ⟨hfs.to_finset, by rwa set.finite.coe_to_finset⟩

end free_comm_ring

namespace free_ring
open function
variable (α)

/-- The canonical ring homomorphism from the free ring generated by `α` to the free commutative ring
    generated by `α`. -/
def to_free_comm_ring {α} : free_ring α →+* free_comm_ring α :=
free_ring.lift free_comm_ring.of

instance : has_coe (free_ring α) (free_comm_ring α) := ⟨to_free_comm_ring⟩

/-- The natural map `free_ring α → free_comm_ring α`, as a `ring_hom`. -/
def coe_ring_hom : free_ring α →+* free_comm_ring α := to_free_comm_ring

@[simp, norm_cast] protected lemma coe_zero : ↑(0 : free_ring α) = (0 : free_comm_ring α) := rfl
@[simp, norm_cast] protected lemma coe_one : ↑(1 : free_ring α) = (1 : free_comm_ring α) := rfl

variable {α}

@[simp] protected lemma coe_of (a : α) : ↑(free_ring.of a) = free_comm_ring.of a :=
free_ring.lift_of _ _
@[simp, norm_cast] protected lemma coe_neg (x : free_ring α) : ↑(-x) = -(x : free_comm_ring α) :=
(free_ring.lift _).map_neg _
@[simp, norm_cast] protected lemma coe_add (x y : free_ring α) :
  ↑(x + y) = (x : free_comm_ring α) + y :=
(free_ring.lift _).map_add _ _
@[simp, norm_cast] protected lemma coe_sub (x y : free_ring α) :
  ↑(x - y) = (x : free_comm_ring α) - y :=
(free_ring.lift _).map_sub _ _
@[simp, norm_cast] protected lemma coe_mul (x y : free_ring α) :
  ↑(x * y) = (x : free_comm_ring α) * y :=
(free_ring.lift _).map_mul _ _

variable (α)

protected lemma coe_surjective : surjective (coe : free_ring α → free_comm_ring α) :=
λ x,
begin
  apply free_comm_ring.induction_on x,
  { use -1, refl },
  { intro x, use free_ring.of x, refl },
  { rintros _ _ ⟨x, rfl⟩ ⟨y, rfl⟩, use x + y, exact (free_ring.lift _).map_add _ _ },
  { rintros _ _ ⟨x, rfl⟩ ⟨y, rfl⟩, use x * y, exact (free_ring.lift _).map_mul _ _ }
end

lemma coe_eq :
  (coe : free_ring α → free_comm_ring α) =
  @functor.map free_abelian_group _ _ _ (λ (l : list α), (l : multiset α)) :=
funext $ λ x, free_abelian_group.lift.unique _ _ $ λ L,
by { simp_rw [free_abelian_group.lift.of, (∘)], exact free_monoid.rec_on L rfl
(λ hd tl ih, by { rw [(free_monoid.lift _).map_mul, free_monoid.lift_eval_of, ih], refl }) }

-- FIXME This was in `deprecated.ring`, but only used here.
-- It would be good to inline it into the next construction.
/-- Interpret an equivalence `f : R ≃ S` as a ring equivalence `R ≃+* S`. -/
def of' {R S : Type*} [ring R] [ring S] (e : R ≃ S) (he : is_ring_hom e) : R ≃+* S :=
{ .. e,
  .. monoid_hom.of he.to_is_semiring_hom.to_is_monoid_hom,
  .. add_monoid_hom.of he.to_is_semiring_hom.to_is_add_monoid_hom }

/-- If α has size at most 1 then the natural map from the free ring on `α` to the
    free commutative ring on `α` is an isomorphism of rings. -/
def subsingleton_equiv_free_comm_ring [subsingleton α] :
  free_ring α ≃+* free_comm_ring α :=
@of' (free_ring α) (free_comm_ring α) _ _
  (functor.map_equiv free_abelian_group (multiset.subsingleton_equiv α)) $
  begin
    delta functor.map_equiv,
    rw congr_arg is_ring_hom _,
    work_on_goal 2 { symmetry, exact coe_eq α },
    exact (coe_ring_hom _).to_is_ring_hom,
  end

instance [subsingleton α] : comm_ring (free_ring α) :=
{ mul_comm := λ x y,
  by { rw [← (subsingleton_equiv_free_comm_ring α).symm_apply_apply (y * x),
        ((subsingleton_equiv_free_comm_ring α)).map_mul,
        mul_comm,
        ← ((subsingleton_equiv_free_comm_ring α)).map_mul,
        (subsingleton_equiv_free_comm_ring α).symm_apply_apply], },
  .. free_ring.ring α }

end free_ring

/-- The free commutative ring on `α` is isomorphic to the polynomial ring over ℤ with
    variables in `α` -/
def free_comm_ring_equiv_mv_polynomial_int :
  free_comm_ring α ≃+* mv_polynomial α ℤ :=
ring_equiv.of_hom_inv
  (free_comm_ring.lift $ λ a, mv_polynomial.X a)
  (mv_polynomial.eval₂_hom (int.cast_ring_hom (free_comm_ring α)) free_comm_ring.of)
  (by { ext, simp })
  (by ext; simp )

/-- The free commutative ring on the empty type is isomorphic to `ℤ`. -/
def free_comm_ring_pempty_equiv_int : free_comm_ring pempty.{u+1} ≃+* ℤ :=
ring_equiv.trans (free_comm_ring_equiv_mv_polynomial_int _)
  (mv_polynomial.is_empty_ring_equiv _ pempty)

/-- The free commutative ring on a type with one term is isomorphic to `ℤ[X]`. -/
def free_comm_ring_punit_equiv_polynomial_int : free_comm_ring punit.{u+1} ≃+* polynomial ℤ :=
(free_comm_ring_equiv_mv_polynomial_int _).trans (mv_polynomial.punit_alg_equiv ℤ).to_ring_equiv

open free_ring

/-- The free ring on the empty type is isomorphic to `ℤ`. -/
def free_ring_pempty_equiv_int : free_ring pempty.{u+1} ≃+* ℤ :=
ring_equiv.trans (subsingleton_equiv_free_comm_ring _) free_comm_ring_pempty_equiv_int

/-- The free ring on a type with one term is isomorphic to `ℤ[X]`. -/
def free_ring_punit_equiv_polynomial_int : free_ring punit.{u+1} ≃+* polynomial ℤ :=
ring_equiv.trans (subsingleton_equiv_free_comm_ring _) free_comm_ring_punit_equiv_polynomial_int