/-
Copyright (c) 2020 Anne Baanen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Anne Baanen, Filippo A. E. Nuccio
-/
import ring_theory.localization
import ring_theory.noetherian
import ring_theory.principal_ideal_domain
import tactic.field_simp

/-!
# Fractional ideals

This file defines fractional ideals of an integral domain and proves basic facts about them.

## Main definitions
Let `S` be a submonoid of an integral domain `R`, `P` the localization of `R` at `S`, and `f` the
natural ring hom from `R` to `P`.
 * `is_fractional` defines which `R`-submodules of `P` are fractional ideals
 * `fractional_ideal f` is the type of fractional ideals in `P`
 * `has_coe (ideal R) (fractional_ideal f)` instance
 * `comm_semiring (fractional_ideal f)` instance:
   the typical ideal operations generalized to fractional ideals
 * `lattice (fractional_ideal f)` instance
 * `map` is the pushforward of a fractional ideal along an algebra morphism

Let `K` be the localization of `R` at `R \ {0}` and `g` the natural ring hom from `R` to `K`.
 * `has_div (fractional_ideal g)` instance:
   the ideal quotient `I / J` (typically written $I : J$, but a `:` operator cannot be defined)

## Main statements

  * `mul_left_mono` and `mul_right_mono` state that ideal multiplication is monotone
  * `prod_one_self_div_eq` states that `1 / I` is the inverse of `I` if one exists
  * `is_noetherian` states that very fractional ideal of a noetherian integral domain is noetherian

## Implementation notes

Fractional ideals are considered equal when they contain the same elements,
independent of the denominator `a : R` such that `a I ⊆ R`.
Thus, we define `fractional_ideal` to be the subtype of the predicate `is_fractional`,
instead of having `fractional_ideal` be a structure of which `a` is a field.

Most definitions in this file specialize operations from submodules to fractional ideals,
proving that the result of this operation is fractional if the input is fractional.
Exceptions to this rule are defining `(+) := (⊔)` and `⊥ := 0`,
in order to re-use their respective proof terms.
We can still use `simp` to show `I.1 + J.1 = (I + J).1` and `⊥.1 = 0.1`.

In `ring_theory.localization`, we define a copy of the localization map `f`'s codomain `P`
(`f.codomain`) so that the `R`-algebra instance on `P` can 'know' the map needed to induce
the `R`-algebra structure.

We don't assume that the localization is a field until we need it to define ideal quotients.
When this assumption is needed, we replace `S` with `non_zero_divisors R`, making the localization
a field.

## References

  * https://en.wikipedia.org/wiki/Fractional_ideal

## Tags

fractional ideal, fractional ideals, invertible ideal
-/

open localization_map

namespace ring

section defs

variables {R : Type*} [comm_ring R] {S : submonoid R} {P : Type*} [comm_ring P]
  (f : localization_map S P)

/-- A submodule `I` is a fractional ideal if `a I ⊆ R` for some `a ≠ 0`. -/
def is_fractional (I : submodule R f.codomain) :=
∃ a ∈ S, ∀ b ∈ I, f.is_integer (f.to_map a * b)

/-- The fractional ideals of a domain `R` are ideals of `R` divided by some `a ∈ R`.

  More precisely, let `P` be a localization of `R` at some submonoid `S`,
  then a fractional ideal `I ⊆ P` is an `R`-submodule of `P`,
  such that there is a nonzero `a : R` with `a I ⊆ R`.
-/
def fractional_ideal :=
{I : submodule R f.codomain // is_fractional f I}

end defs

namespace fractional_ideal

open set
open submodule

variables {R : Type*} [comm_ring R] {S : submonoid R} {P : Type*} [comm_ring P]
  {f : localization_map S P}

instance : has_coe (fractional_ideal f) (submodule R f.codomain) := ⟨λ I, I.val⟩

@[simp] lemma val_eq_coe (I : fractional_ideal f) : I.val = I := rfl

@[simp, norm_cast] lemma coe_mk (I : submodule R f.codomain) (hI : is_fractional f I) :
  (subtype.mk I hI : submodule R f.codomain) = I := rfl

instance : has_mem P (fractional_ideal f) := ⟨λ x I, x ∈ (I : submodule R f.codomain)⟩

lemma mem_coe {x : f.codomain} {I : fractional_ideal f} :
  x ∈ (I : submodule R f.codomain) ↔ x ∈ I :=
iff.rfl

/-- Fractional ideals are equal if their submodules are equal.

  Combined with `submodule.ext` this gives that fractional ideals are equal if
  they have the same elements.
-/
@[ext]
lemma ext {I J : fractional_ideal f} : (I : submodule R f.codomain) = J → I = J :=
subtype.ext_iff_val.mpr

lemma ext_iff {I J : fractional_ideal f} : (∀ x, (x ∈ I ↔ x ∈ J)) ↔ I = J :=
⟨ λ h, ext (submodule.ext h), λ h x, h ▸ iff.rfl ⟩

lemma fractional_of_subset_one (I : submodule R f.codomain)
  (h : I ≤ (submodule.span R {1})) :
  is_fractional f I :=
begin
  use [1, S.one_mem],
  intros b hb,
  rw [f.to_map.map_one, one_mul],
  rw ←submodule.one_eq_span at h,
  obtain ⟨b', b'_mem, b'_eq_b⟩ := h hb,
  rw (show b = f.to_map b', from b'_eq_b.symm),
  exact set.mem_range_self b',
end

lemma is_fractional_of_le {I : submodule R f.codomain} {J : fractional_ideal f}
  (hIJ : I ≤ J) : is_fractional f I :=
begin
  obtain ⟨a, a_mem, ha⟩ := J.2,
  use [a, a_mem],
  intros b b_mem,
  exact ha b (hIJ b_mem)
end

instance coe_to_fractional_ideal : has_coe (ideal R) (fractional_ideal f) :=
⟨ λ I, ⟨f.coe_submodule I, fractional_of_subset_one _ $ λ x ⟨y, hy, h⟩,
  submodule.mem_span_singleton.2 ⟨y, by rw ←h; exact mul_one _⟩⟩ ⟩

@[simp, norm_cast] lemma coe_coe_ideal (I : ideal R) :
  ((I : fractional_ideal f) : submodule R f.codomain) = f.coe_submodule I := rfl

@[simp] lemma mem_coe_ideal {x : f.codomain} {I : ideal R} :
  x ∈ (I : fractional_ideal f) ↔ ∃ (x' ∈ I), f.to_map x' = x :=
⟨ λ ⟨x', hx', hx⟩, ⟨x', hx', hx⟩,
  λ ⟨x', hx', hx⟩, ⟨x', hx', hx⟩ ⟩

instance : has_zero (fractional_ideal f) := ⟨(0 : ideal R)⟩

@[simp] lemma mem_zero_iff {x : P} : x ∈ (0 : fractional_ideal f) ↔ x = 0 :=
⟨ (λ ⟨x', x'_mem_zero, x'_eq_x⟩,
    have x'_eq_zero : x' = 0 := x'_mem_zero,
    by simp [x'_eq_x.symm, x'_eq_zero]),
  (λ hx, ⟨0, rfl, by simp [hx]⟩) ⟩

@[simp, norm_cast] lemma coe_zero : ↑(0 : fractional_ideal f) = (⊥ : submodule R f.codomain) :=
submodule.ext $ λ _, mem_zero_iff

@[simp, norm_cast] lemma coe_to_fractional_ideal_bot : ((⊥ : ideal R) : fractional_ideal f) = 0 :=
rfl

@[simp] lemma exists_mem_to_map_eq {x : R} {I : ideal R} (h : S ≤ non_zero_divisors R) :
  (∃ x', x' ∈ I ∧ f.to_map x' = f.to_map x) ↔ x ∈ I :=
⟨λ ⟨x', hx', eq⟩, f.injective h eq ▸ hx', λ h, ⟨x, h, rfl⟩⟩

lemma coe_to_fractional_ideal_injective (h : S ≤ non_zero_divisors R) :
  function.injective (coe : ideal R → fractional_ideal f) :=
λ I J heq, have
  ∀ (x : R), f.to_map x ∈ (I : fractional_ideal f) ↔ f.to_map x ∈ (J : fractional_ideal f) :=
λ x, heq ▸ iff.rfl,
ideal.ext (by { simpa only [mem_coe_ideal, exists_prop, exists_mem_to_map_eq h] using this })

lemma coe_to_fractional_ideal_eq_zero {I : ideal R} (hS : S ≤ non_zero_divisors R) :
  (I : fractional_ideal f) = 0 ↔ I = (⊥ : ideal R) :=
⟨λ h, coe_to_fractional_ideal_injective hS h,
 λ h, by rw [h, coe_to_fractional_ideal_bot]⟩

lemma coe_to_fractional_ideal_ne_zero {I : ideal R} (hS : S ≤ non_zero_divisors R) :
  (I : fractional_ideal f) ≠ 0 ↔ I ≠ (⊥ : ideal R) :=
not_iff_not.mpr (coe_to_fractional_ideal_eq_zero hS)

lemma coe_to_submodule_eq_bot {I : fractional_ideal f} :
  (I : submodule R f.codomain) = ⊥ ↔ I = 0 :=
⟨λ h, ext (by simp [h]),
 λ h, by simp [h] ⟩

lemma coe_to_submodule_ne_bot {I : fractional_ideal f} :
  ↑I ≠ (⊥ : submodule R f.codomain) ↔ I ≠ 0 :=
not_iff_not.mpr coe_to_submodule_eq_bot

instance : inhabited (fractional_ideal f) := ⟨0⟩

instance : has_one (fractional_ideal f) :=
⟨(1 : ideal R)⟩

lemma mem_one_iff {x : P} : x ∈ (1 : fractional_ideal f) ↔ ∃ x' : R, f.to_map x' = x :=
iff.intro (λ ⟨x', _, h⟩, ⟨x', h⟩) (λ ⟨x', h⟩, ⟨x', ⟨x', set.mem_univ _, rfl⟩, h⟩)

lemma coe_mem_one (x : R) : f.to_map x ∈ (1 : fractional_ideal f) :=
mem_one_iff.mpr ⟨x, rfl⟩

lemma one_mem_one : (1 : P) ∈ (1 : fractional_ideal f) :=
mem_one_iff.mpr ⟨1, f.to_map.map_one⟩

/-- `(1 : fractional_ideal f)` is defined as the R-submodule `f(R) ≤ K`.

However, this is not definitionally equal to `1 : submodule R K`,
which is proved in the actual `simp` lemma `coe_one`. -/
lemma coe_one_eq_coe_submodule_one :
  ↑(1 : fractional_ideal f) = f.coe_submodule (1 : ideal R) :=
rfl

@[simp, norm_cast] lemma coe_one :
  (↑(1 : fractional_ideal f) : submodule R f.codomain) = 1 :=
begin
  simp only [coe_one_eq_coe_submodule_one, ideal.one_eq_top],
  convert (submodule.one_eq_map_top).symm,
end

section lattice

/-!
### `lattice` section

Defines the order on fractional ideals as inclusion of their underlying sets,
and ports the lattice structure on submodules to fractional ideals.
-/

instance : partial_order (fractional_ideal f) :=
{ le := λ I J, I.1 ≤ J.1,
  le_refl := λ I, le_refl I.1,
  le_antisymm := λ ⟨I, hI⟩ ⟨J, hJ⟩ hIJ hJI, by { congr, exact le_antisymm hIJ hJI },
  le_trans := λ _ _ _ hIJ hJK, le_trans hIJ hJK }

lemma le_iff_mem {I J : fractional_ideal f} : I ≤ J ↔ (∀ x ∈ I, x ∈ J) :=
iff.rfl

@[simp] lemma coe_le_coe {I J : fractional_ideal f} :
  (I : submodule R f.codomain) ≤ (J : submodule R f.codomain) ↔ I ≤ J :=
iff.rfl

lemma zero_le (I : fractional_ideal f) : 0 ≤ I :=
begin
  intros x hx,
  convert submodule.zero_mem _,
  simpa using hx
end

instance order_bot : order_bot (fractional_ideal f) :=
{ bot := 0,
  bot_le := zero_le,
  ..fractional_ideal.partial_order }

@[simp] lemma bot_eq_zero : (⊥ : fractional_ideal f) = 0 :=
rfl

@[simp] lemma le_zero_iff {I : fractional_ideal f} : I ≤ 0 ↔ I = 0 :=
le_bot_iff

lemma eq_zero_iff {I : fractional_ideal f} : I = 0 ↔ (∀ x ∈ I, x = (0 : P)) :=
⟨ (λ h x hx, by simpa [h, mem_zero_iff] using hx),
  (λ h, le_bot_iff.mp (λ x hx, mem_zero_iff.mpr (h x hx))) ⟩

lemma fractional_sup (I J : fractional_ideal f) : is_fractional f (I.1 ⊔ J.1) :=
begin
  rcases I.2 with ⟨aI, haI, hI⟩,
  rcases J.2 with ⟨aJ, haJ, hJ⟩,
  use aI * aJ,
  use S.mul_mem haI haJ,
  intros b hb,
  rcases mem_sup.mp hb with
    ⟨bI, hbI, bJ, hbJ, hbIJ⟩,
  rw [←hbIJ, mul_add],
  apply is_integer_add,
  { rw [mul_comm aI, f.to_map.map_mul, mul_assoc],
    apply is_integer_smul (hI bI hbI), },
  { rw [f.to_map.map_mul, mul_assoc],
    apply is_integer_smul (hJ bJ hbJ) }
end

lemma fractional_inf (I J : fractional_ideal f) : is_fractional f (I.1 ⊓ J.1) :=
begin
  rcases I.2 with ⟨aI, haI, hI⟩,
  use aI,
  use haI,
  intros b hb,
  rcases mem_inf.mp hb with ⟨hbI, hbJ⟩,
  exact (hI b hbI)
end

instance lattice : lattice (fractional_ideal f) :=
{ inf := λ I J, ⟨I.1 ⊓ J.1, fractional_inf I J⟩,
  sup := λ I J, ⟨I.1 ⊔ J.1, fractional_sup I J⟩,
  inf_le_left := λ I J, show I.1 ⊓ J.1 ≤ I.1, from inf_le_left,
  inf_le_right := λ I J, show I.1 ⊓ J.1 ≤ J.1, from inf_le_right,
  le_inf := λ I J K hIJ hIK, show I.1 ≤ (J.1 ⊓ K.1), from le_inf hIJ hIK,
  le_sup_left := λ I J, show I.1 ≤ I.1 ⊔ J.1, from le_sup_left,
  le_sup_right := λ I J, show J.1 ≤ I.1 ⊔ J.1, from le_sup_right,
  sup_le := λ I J K hIK hJK, show (I.1 ⊔ J.1) ≤ K.1, from sup_le hIK hJK,
  ..fractional_ideal.partial_order }

instance : semilattice_sup_bot (fractional_ideal f) :=
{ ..fractional_ideal.order_bot, ..fractional_ideal.lattice }

@[simp]
lemma coe_ideal_le {I : ideal R} {J : fractional_ideal f} :
  ↑I ≤ J ↔ ∀ x ∈ I, f.to_map x ∈ J :=
⟨λ h x hx, h ⟨x, hx, rfl⟩,
 λ h x hx, let ⟨x', hx', eq_x⟩ := fractional_ideal.mem_coe_ideal.mp hx in eq_x ▸ h x' hx'⟩

end lattice

section semiring

instance : has_add (fractional_ideal f) := ⟨(⊔)⟩

@[simp]
lemma sup_eq_add (I J : fractional_ideal f) : I ⊔ J = I + J := rfl

@[simp, norm_cast]
lemma coe_add (I J : fractional_ideal f) : (↑(I + J) : submodule R f.codomain) = I + J := rfl

lemma fractional_mul (I J : fractional_ideal f) : is_fractional f (I.1 * J.1) :=
begin
  rcases I with ⟨I, aI, haI, hI⟩,
  rcases J with ⟨I, aJ, haJ, hJ⟩,
  use aI * aJ,
  use S.mul_mem haI haJ,
  intros b hb,
  apply submodule.mul_induction_on hb,
  { intros m hm n hn,
    obtain ⟨n', hn'⟩ := hJ n hn,
    rw [f.to_map.map_mul, mul_comm m, ←mul_assoc, mul_assoc _ _ n],
    erw ←hn', rw mul_assoc,
    apply hI,
    exact submodule.smul_mem _ _ hm },
  { rw [mul_zero],
    exact ⟨0, f.to_map.map_zero⟩ },
  { intros x y hx hy,
    rw [mul_add],
    apply is_integer_add hx hy },
  { intros r x hx,
    show f.is_integer (_ * (f.to_map r * x)),
    rw [←mul_assoc, ←f.to_map.map_mul, mul_comm _ r, f.to_map.map_mul, mul_assoc],
    apply is_integer_smul hx },
end

/-- `fractional_ideal.mul` is the product of two fractional ideals,
used to define the `has_mul` instance.

This is only an auxiliary definition: the preferred way of writing `I.mul J` is `I * J`.

Elaborated terms involving `fractional_ideal` tend to grow quite large,
so by making definitions irreducible, we hope to avoid deep unfolds.
-/
@[irreducible]
def mul (I J : fractional_ideal f) : fractional_ideal f :=
⟨I.1 * J.1, fractional_mul I J⟩

local attribute [semireducible] mul

instance : has_mul (fractional_ideal f) := ⟨λ I J, mul I J⟩

@[simp] lemma mul_eq_mul (I J : fractional_ideal f) : mul I J = I * J := rfl

@[simp, norm_cast]
lemma coe_mul (I J : fractional_ideal f) : (↑(I * J) : submodule R f.codomain) = I * J := rfl

lemma mul_left_mono (I : fractional_ideal f) : monotone ((*) I) :=
λ J J' h, mul_le.mpr (λ x hx y hy, mul_mem_mul hx (h hy))

lemma mul_right_mono (I : fractional_ideal f) : monotone (λ J, J * I) :=
λ J J' h, mul_le.mpr (λ x hx y hy, mul_mem_mul (h hx) hy)

lemma mul_mem_mul {I J : fractional_ideal f} {i j : f.codomain} (hi : i ∈ I) (hj : j ∈ J) :
  i * j ∈ I * J := submodule.mul_mem_mul hi hj

lemma mul_le {I J K : fractional_ideal f} :
  I * J ≤ K ↔ (∀ (i ∈ I) (j ∈ J), i * j ∈ K) :=
submodule.mul_le

@[elab_as_eliminator] protected theorem mul_induction_on
  {I J : fractional_ideal f}
  {C : f.codomain → Prop} {r : f.codomain} (hr : r ∈ I * J)
  (hm : ∀ (i ∈ I) (j ∈ J), C (i * j))
  (h0 : C 0) (ha : ∀ x y, C x → C y → C (x + y))
  (hs : ∀ (r : R) x, C x → C (r • x)) : C r :=
submodule.mul_induction_on hr hm h0 ha hs

@[simp, norm_cast]
lemma coe_ideal_mul (I J : ideal R) :
  (↑(I * J) : fractional_ideal f) = I * J :=
begin
  apply le_antisymm,
  { rw fractional_ideal.coe_ideal_le,
    intros x hx,
    refine submodule.mul_induction_on hx (λ x hx y hy, _) _ (λ x y hx hy, _) (λ r x hx, _),
    { rw f.to_map.map_mul,
      apply fractional_ideal.mul_mem_mul; rw fractional_ideal.mem_coe_ideal,
      { exact ⟨x, hx, rfl⟩ },
      { exact ⟨y, hy, rfl⟩ } },
    { rw f.to_map.map_zero,
      exact submodule.zero_mem _ },
    { rw f.to_map.map_add,
      exact submodule.add_mem _ hx hy },
    { rw [smul_eq_mul, f.to_map.map_mul],
      exact submodule.smul_mem _ _ hx } },
  { rw fractional_ideal.mul_le,
    intros x hx y hy,
    obtain ⟨x', hx', rfl⟩ := fractional_ideal.mem_coe_ideal.mp hx,
    obtain ⟨y', hy', rfl⟩ := fractional_ideal.mem_coe_ideal.mp hy,
    rw fractional_ideal.mem_coe_ideal,
    exact ⟨x' * y', ideal.mul_mem_mul hx' hy', f.to_map.map_mul _ _⟩ },
end

instance comm_semiring : comm_semiring (fractional_ideal f) :=
{ add_assoc := λ I J K, sup_assoc,
  add_comm := λ I J, sup_comm,
  add_zero := λ I, sup_bot_eq,
  zero_add := λ I, bot_sup_eq,
  mul_assoc := λ I J K, ext (submodule.mul_assoc _ _ _),
  mul_comm := λ I J, ext (submodule.mul_comm _ _),
  mul_one := λ I, begin
    ext,
    split; intro h,
    { apply mul_le.mpr _ h,
      rintros x hx y ⟨y', y'_mem_R, y'_eq_y⟩,
      rw [←y'_eq_y, mul_comm],
      exact submodule.smul_mem _ _ hx },
    { have : x * 1 ∈ (I * 1) := mul_mem_mul h one_mem_one,
      rwa [mul_one] at this }
  end,
  one_mul := λ I, begin
    ext,
    split; intro h,
    { apply mul_le.mpr _ h,
      rintros x ⟨x', x'_mem_R, x'_eq_x⟩ y hy,
      rw ←x'_eq_x,
      exact submodule.smul_mem _ _ hy },
    { have : 1 * x ∈ (1 * I) := mul_mem_mul one_mem_one h,
      rwa [one_mul] at this }
  end,
  mul_zero := λ I, eq_zero_iff.mpr (λ x hx, submodule.mul_induction_on hx
    (λ x hx y hy, by simp [mem_zero_iff.mp hy])
    rfl
    (λ x y hx hy, by simp [hx, hy])
    (λ r x hx, by simp [hx])),
  zero_mul := λ I, eq_zero_iff.mpr (λ x hx, submodule.mul_induction_on hx
    (λ x hx y hy, by simp [mem_zero_iff.mp hx])
    rfl
    (λ x y hx hy, by simp [hx, hy])
    (λ r x hx, by simp [hx])),
  left_distrib := λ I J K, ext (mul_add _ _ _),
  right_distrib := λ I J K, ext (add_mul _ _ _),
  ..fractional_ideal.has_zero,
  ..fractional_ideal.has_add,
  ..fractional_ideal.has_one,
  ..fractional_ideal.has_mul }

section order

lemma add_le_add_left {I J : fractional_ideal f} (hIJ : I ≤ J) (J' : fractional_ideal f) :
  J' + I ≤ J' + J :=
sup_le_sup_left hIJ J'

lemma mul_le_mul_left {I J : fractional_ideal f} (hIJ : I ≤ J) (J' : fractional_ideal f) :
  J' * I ≤ J' * J :=
mul_le.mpr (λ k hk j hj, mul_mem_mul hk (hIJ hj))

lemma le_self_mul_self {I : fractional_ideal f} (hI: 1 ≤ I) : I ≤ I * I :=
begin
  convert mul_left_mono I hI,
  exact (mul_one I).symm
end

lemma mul_self_le_self {I : fractional_ideal f} (hI: I ≤ 1) : I * I ≤ I :=
begin
  convert mul_left_mono I hI,
  exact (mul_one I).symm
end

lemma coe_ideal_le_one {I : ideal R} : (I : fractional_ideal f) ≤ 1 :=
λ x hx, let ⟨y, _, hy⟩ := fractional_ideal.mem_coe_ideal.mp hx
  in fractional_ideal.mem_one_iff.mpr ⟨y, hy⟩

lemma le_one_iff_exists_coe_ideal {J : fractional_ideal f} :
  J ≤ (1 : fractional_ideal f) ↔ ∃ (I : ideal R), ↑I = J :=
begin
  split,
  { intro hJ,
    refine ⟨⟨{x : R | f.to_map x ∈ J}, _, _, _⟩, _⟩,
    { rw [mem_set_of_eq, ring_hom.map_zero],
      exact J.val.zero_mem },
    { intros a b ha hb,
      rw [mem_set_of_eq, ring_hom.map_add],
      exact J.val.add_mem ha hb },
    { intros c x hx,
      rw [smul_eq_mul, mem_set_of_eq, ring_hom.map_mul],
      exact J.val.smul_mem c hx },
    { ext x,
      split,
      { rintros ⟨y, hy, eq_y⟩,
        rwa ← eq_y },
      { intro hx,
        obtain ⟨y, eq_x⟩ := fractional_ideal.mem_one_iff.mp (hJ hx),
        rw ← eq_x at *,
        exact ⟨y, hx, rfl⟩ } } },
  { rintro ⟨I, hI⟩,
    rw ← hI,
    apply coe_ideal_le_one },
end

end order

variables {P' : Type*} [comm_ring P'] {f' : localization_map S P'}
variables {P'' : Type*} [comm_ring P''] {f'' : localization_map S P''}

lemma fractional_map (g : f.codomain →ₐ[R] f'.codomain) (I : fractional_ideal f) :
  is_fractional f' (submodule.map g.to_linear_map I.1) :=
begin
  rcases I with ⟨I, a, a_nonzero, hI⟩,
  use [a, a_nonzero],
  intros b hb,
  obtain ⟨b', b'_mem, hb'⟩ := submodule.mem_map.mp hb,
  obtain ⟨x, hx⟩ := hI b' b'_mem,
  use x,
  erw [←g.commutes, hx, g.map_smul, hb'],
  refl
end

/-- `I.map g` is the pushforward of the fractional ideal `I` along the algebra morphism `g` -/
def map (g : f.codomain →ₐ[R] f'.codomain) :
  fractional_ideal f → fractional_ideal f' :=
λ I, ⟨submodule.map g.to_linear_map I.1, fractional_map g I⟩

@[simp, norm_cast] lemma coe_map (g : f.codomain →ₐ[R] f'.codomain) (I : fractional_ideal f) :
  ↑(map g I) = submodule.map g.to_linear_map I := rfl

@[simp] lemma mem_map {I : fractional_ideal f} {g : f.codomain →ₐ[R] f'.codomain}
  {y : f'.codomain} : y ∈ I.map g ↔ ∃ x, x ∈ I ∧ g x = y :=
submodule.mem_map

variables (I J : fractional_ideal f) (g : f.codomain →ₐ[R] f'.codomain)

@[simp] lemma map_id : I.map (alg_hom.id _ _) = I :=
ext (submodule.map_id I.1)

@[simp] lemma map_comp (g' : f'.codomain →ₐ[R] f''.codomain) :
  I.map (g'.comp g) = (I.map g).map g' :=
ext (submodule.map_comp g.to_linear_map g'.to_linear_map I.1)

@[simp, norm_cast] lemma map_coe_ideal (I : ideal R) :
  (I : fractional_ideal f).map g = I :=
begin
  ext x,
  simp only [coe_coe_ideal, mem_coe_submodule],
  split,
  { rintro ⟨_, ⟨y, hy, rfl⟩, rfl⟩,
    exact ⟨y, hy, (g.commutes y).symm⟩ },
  { rintro ⟨y, hy, rfl⟩,
    exact ⟨_, ⟨y, hy, rfl⟩, g.commutes y⟩ },
end

@[simp] lemma map_one :
  (1 : fractional_ideal f).map g = 1 :=
map_coe_ideal g 1

@[simp] lemma map_zero :
  (0 : fractional_ideal f).map g = 0 :=
map_coe_ideal g 0

@[simp] lemma map_add : (I + J).map g = I.map g + J.map g :=
ext (submodule.map_sup _ _ _)

@[simp] lemma map_mul : (I * J).map g = I.map g * J.map g :=
ext (submodule.map_mul _ _ _)

@[simp] lemma map_map_symm (g : f.codomain ≃ₐ[R] f'.codomain) :
  (I.map (g : f.codomain →ₐ[R] f'.codomain)).map (g.symm : f'.codomain →ₐ[R] f.codomain) = I :=
by rw [←map_comp, g.symm_comp, map_id]

@[simp] lemma map_symm_map (I : fractional_ideal f') (g : f.codomain ≃ₐ[R] f'.codomain) :
  (I.map (g.symm : f'.codomain →ₐ[R] f.codomain)).map (g : f.codomain →ₐ[R] f'.codomain) = I :=
by rw [←map_comp, g.comp_symm, map_id]

/-- If `g` is an equivalence, `map g` is an isomorphism -/
def map_equiv (g : f.codomain ≃ₐ[R] f'.codomain) :
  fractional_ideal f ≃+* fractional_ideal f' :=
{ to_fun := map g,
  inv_fun := map g.symm,
  map_add' := λ I J, map_add I J _,
  map_mul' := λ I J, map_mul I J _,
  left_inv := λ I, by { rw [←map_comp, alg_equiv.symm_comp, map_id] },
  right_inv := λ I, by { rw [←map_comp, alg_equiv.comp_symm, map_id] } }

@[simp] lemma coe_fun_map_equiv (g : f.codomain ≃ₐ[R] f'.codomain) :
  ⇑(map_equiv g) = map g :=
rfl

@[simp] lemma map_equiv_apply (g : f.codomain ≃ₐ[R] f'.codomain) (I : fractional_ideal f) :
  map_equiv g I = map ↑g I := rfl

@[simp] lemma map_equiv_symm (g : f.codomain ≃ₐ[R] f'.codomain) :
  (map_equiv g).symm = map_equiv g.symm := rfl

@[simp] lemma map_equiv_refl :
  map_equiv alg_equiv.refl = ring_equiv.refl (fractional_ideal f) :=
ring_equiv.ext (λ x, by simp)

lemma is_fractional_span_iff {s : set f.codomain} :
is_fractional f (span R s) ↔ ∃ a ∈ S, ∀ (b : P), b ∈ s → f.is_integer (f.to_map a * b) :=
⟨ λ ⟨a, a_mem, h⟩, ⟨a, a_mem, λ b hb, h b (subset_span hb)⟩,
  λ ⟨a, a_mem, h⟩, ⟨a, a_mem, λ b hb, span_induction hb
    h
    (by { rw mul_zero, exact f.is_integer_zero })
    (λ x y hx hy, by { rw mul_add, exact is_integer_add hx hy })
    (λ s x hx, by { rw algebra.mul_smul_comm, exact is_integer_smul hx }) ⟩ ⟩

lemma is_fractional_of_fg {I : submodule R f.codomain} (hI : I.fg) :
  is_fractional f I :=
begin
  rcases hI with ⟨I, rfl⟩,
  rcases localization_map.exist_integer_multiples_of_finset f I with ⟨⟨s, hs1⟩, hs⟩,
  rw is_fractional_span_iff,
  exact ⟨s, hs1, hs⟩,
end

/-- `canonical_equiv f f'` is the canonical equivalence between the fractional
ideals in `f.codomain` and in `f'.codomain` -/
@[irreducible]
noncomputable def canonical_equiv (f : localization_map S P) (f' : localization_map S P') :
  fractional_ideal f ≃+* fractional_ideal f' :=
map_equiv
  { commutes' := λ r, ring_equiv_of_ring_equiv_eq _ _ _,
    ..ring_equiv_of_ring_equiv f f' (ring_equiv.refl R)
      (by rw [ring_equiv.to_monoid_hom_refl, submonoid.map_id]) }

@[simp] lemma mem_canonical_equiv_apply {I : fractional_ideal f} {x : f'.codomain} :
  x ∈ canonical_equiv f f' I ↔
    ∃ y ∈ I, @localization_map.map _ _ _ _ _ _ _ f (ring_hom.id _) _ (λ ⟨y, hy⟩, hy) _ _ f' y = x :=
begin
  rw [canonical_equiv, map_equiv_apply, mem_map],
  exact ⟨λ ⟨y, mem, eq⟩, ⟨y, mem, eq⟩, λ ⟨y, mem, eq⟩, ⟨y, mem, eq⟩⟩
end

@[simp] lemma canonical_equiv_symm (f : localization_map S P) (f' : localization_map S P') :
  (canonical_equiv f f').symm = canonical_equiv f' f :=
ring_equiv.ext $ λ I, fractional_ideal.ext_iff.mp $ λ x,
by { erw [mem_canonical_equiv_apply, canonical_equiv, map_equiv_symm, map_equiv, mem_map],
    exact ⟨λ ⟨y, mem, eq⟩, ⟨y, mem, eq⟩, λ ⟨y, mem, eq⟩, ⟨y, mem, eq⟩⟩ }

@[simp] lemma canonical_equiv_flip (f : localization_map S P) (f' : localization_map S P') (I) :
  canonical_equiv f f' (canonical_equiv f' f I) = I :=
by rw [←canonical_equiv_symm, ring_equiv.symm_apply_apply]

end semiring

section fraction_map

/-!
### `fraction_map` section

This section concerns fractional ideals in the field of fractions,
i.e. the type `fractional_ideal g` when `g` is a `fraction_map R K`.
-/

variables {K K' : Type*} [field K] [field K'] {g : fraction_map R K} {g' : fraction_map R K'}
variables {I J : fractional_ideal g} (h : g.codomain →ₐ[R] g'.codomain)

/-- Nonzero fractional ideals contain a nonzero integer. -/
lemma exists_ne_zero_mem_is_integer [nontrivial R] (hI : I ≠ 0) :
  ∃ x ≠ (0 : R), g.to_map x ∈ I :=
begin
  obtain ⟨y, y_mem, y_not_mem⟩ := submodule.exists_of_lt (bot_lt_iff_ne_bot.mpr hI),
  have y_ne_zero : y ≠ 0 := by simpa using y_not_mem,
  obtain ⟨z, ⟨x, hx⟩⟩ := g.exists_integer_multiple y,
  refine ⟨x, _, _⟩,
  { rw [ne.def, ← g.to_map_eq_zero_iff, hx],
    exact mul_ne_zero (g.to_map_ne_zero_of_mem_non_zero_divisors _) y_ne_zero },
  { rw hx,
    exact smul_mem _ _ y_mem }
end

lemma map_ne_zero [nontrivial R] (hI : I ≠ 0) : I.map h ≠ 0 :=
begin
  obtain ⟨x, x_ne_zero, hx⟩ := exists_ne_zero_mem_is_integer hI,
  contrapose! x_ne_zero with map_eq_zero,
  refine g'.to_map_eq_zero_iff.mp (eq_zero_iff.mp map_eq_zero _ (mem_map.mpr _)),
  exact ⟨g.to_map x, hx, h.commutes x⟩,
end

@[simp] lemma map_eq_zero_iff [nontrivial R] : I.map h = 0 ↔ I = 0 :=
⟨imp_of_not_imp_not _ _ (map_ne_zero _),
 λ hI, hI.symm ▸ map_zero h⟩

@[simp, norm_cast]
lemma coe_ideal_le_coe_ideal {I J : ideal R} :
(I : fractional_ideal g) ≤ (J : fractional_ideal g) ↔ I ≤ J :=
begin
  split,
  { intros h x hI,
    rw le_iff_mem at h,
    specialize h (g.to_map x),
    simp only [mem_coe_ideal, exists_prop, exists_mem_to_map_eq] at h,
    exact h hI },
  { rintros h x hx,
    simp only [val_eq_coe, coe_coe_ideal, localization_map.mem_coe_submodule] at hx ⊢,
    obtain ⟨y, hy, y_eq⟩ := hx,
    exact ⟨y, h hy, y_eq⟩ },
end

end fraction_map

section quotient

/-!
### `quotient` section

This section defines the ideal quotient of fractional ideals.

In this section we need that each non-zero `y : R` has an inverse in
the localization, i.e. that the localization is a field. We satisfy this
assumption by taking `S = non_zero_divisors R`, `R`'s localization at which
is a field because `R` is a domain.
-/

open_locale classical

variables {R₁ : Type*} [integral_domain R₁] {K : Type*} [field K] {g : fraction_map R₁ K}

instance : nontrivial (fractional_ideal g) :=
⟨⟨0, 1, λ h,
  have this : (1 : K) ∈ (0 : fractional_ideal g) :=
    by rw ←g.to_map.map_one; convert coe_mem_one _,
  one_ne_zero (mem_zero_iff.mp this) ⟩⟩

lemma fractional_div_of_nonzero {I J : fractional_ideal g} (h : J ≠ 0) :
  is_fractional g (I.1 / J.1) :=
begin
  rcases I with ⟨I, aI, haI, hI⟩,
  rcases J with ⟨J, aJ, haJ, hJ⟩,
  obtain ⟨y, mem_J, not_mem_zero⟩ := exists_of_lt (bot_lt_iff_ne_bot.mpr h),
  obtain ⟨y', hy'⟩ := hJ y mem_J,
  use (aI * y'),
  split,
  { apply (non_zero_divisors R₁).mul_mem haI (mem_non_zero_divisors_iff_ne_zero.mpr _),
    intro y'_eq_zero,
    have : g.to_map aJ * y = 0 := by rw [←hy', y'_eq_zero, g.to_map.map_zero],
    obtain aJ_zero | y_zero := mul_eq_zero.mp this,
    { have : aJ = 0 := g.to_map.injective_iff.1 g.injective _ aJ_zero,
      have : aJ ≠ 0 := mem_non_zero_divisors_iff_ne_zero.mp haJ,
      contradiction },
    { exact not_mem_zero (mem_zero_iff.mpr y_zero) } },
  intros b hb,
  rw [g.to_map.map_mul, mul_assoc, mul_comm _ b, hy'],
  exact hI _ (hb _ (submodule.smul_mem _ aJ mem_J)),
end

noncomputable instance fractional_ideal_has_div :
  has_div (fractional_ideal g) :=
⟨ λ I J, if h : J = 0 then 0 else ⟨I.1 / J.1, fractional_div_of_nonzero h⟩ ⟩

variables {I J : fractional_ideal g} [ J ≠ 0 ]

@[simp] lemma div_zero {I : fractional_ideal g} :
  I / 0 = 0 :=
dif_pos rfl

lemma div_nonzero {I J : fractional_ideal g} (h : J ≠ 0) :
  (I / J) = ⟨I.1 / J.1, fractional_div_of_nonzero h⟩ :=
dif_neg h

@[simp] lemma coe_div {I J : fractional_ideal g} (hJ : J ≠ 0) :
  (↑(I / J) : submodule R₁ g.codomain) = ↑I / (↑J : submodule R₁ g.codomain) :=
begin
  unfold has_div.div,
  simp only [dif_neg hJ, coe_mk, val_eq_coe],
end

lemma mem_div_iff_of_nonzero {I J : fractional_ideal g} (h : J ≠ 0) {x} :
  x ∈ I / J ↔ ∀ y ∈ J, x * y ∈ I :=
by { rw div_nonzero h, exact submodule.mem_div_iff_forall_mul_mem }

lemma mul_one_div_le_one {I : fractional_ideal g} : I * (1 / I) ≤ 1 :=
begin
  by_cases hI : I = 0,
  { rw [hI, div_zero, mul_zero],
    exact zero_le 1 },
  { rw [← coe_le_coe, coe_mul, coe_div hI, coe_one],
    apply submodule.mul_one_div_le_one },
end

lemma le_self_mul_one_div {I : fractional_ideal g} (hI : I ≤ (1 : fractional_ideal g)) :
  I ≤ I * (1 / I) :=
begin
  by_cases hI_nz : I = 0,
  { rw [hI_nz, div_zero, mul_zero], exact zero_le 0 },
  { rw [← coe_le_coe, coe_mul, coe_div hI_nz, coe_one],
    rw [← coe_le_coe, coe_one] at hI,
    exact submodule.le_self_mul_one_div hI },
end

lemma le_div_iff_of_nonzero {I J J' : fractional_ideal g} (hJ' : J' ≠ 0) :
  I ≤ J / J' ↔ ∀ (x ∈ I) (y ∈ J'), x * y ∈ J :=
⟨ λ h x hx, (mem_div_iff_of_nonzero hJ').mp (h hx),
  λ h x hx, (mem_div_iff_of_nonzero hJ').mpr (h x hx) ⟩

lemma le_div_iff_mul_le {I J J' : fractional_ideal g} (hJ' : J' ≠ 0) : I ≤ J / J' ↔ I * J' ≤ J :=
begin
  rw div_nonzero hJ',
  convert submodule.le_div_iff_mul_le using 1,
  rw [val_eq_coe, val_eq_coe, ←coe_mul],
  refl,
end

lemma mul_one_div_le_div {I J : fractional_ideal g} : I * (1 / J) ≤ I / J :=
if hJ : J = 0 then by simp [hJ] else (le_div_iff_mul_le hJ).mpr $
calc I * (1 / J) * J
    = I * (J * (1 / J)) : by rw [mul_assoc, mul_comm (1 / J)]
... ≤ I * 1 : mul_left_mono _ mul_one_div_le_one
... = I : mul_one _

@[simp] lemma div_one {I : fractional_ideal g} : I / 1 = I :=
begin
  rw [div_nonzero (@one_ne_zero (fractional_ideal g) _ _)],
  ext,
  split; intro h,
  { convert mem_div_iff_forall_mul_mem.mp h 1
      (g.to_map.map_one ▸ coe_mem_one 1), simp },
  { apply mem_div_iff_forall_mul_mem.mpr,
    rintros y ⟨y', _, y_eq_y'⟩,
    rw mul_comm,
    convert submodule.smul_mem _ y' h,
    rw ←y_eq_y',
    refl }
end

lemma ne_zero_of_mul_eq_one (I J : fractional_ideal g) (h : I * J = 1) : I ≠ 0 :=
λ hI, @zero_ne_one (fractional_ideal g) _ _ (by { convert h, simp [hI], })

theorem eq_one_div_of_mul_eq_one (I J : fractional_ideal g) (h : I * J = 1) :
  J = 1 / I :=
begin
  have hI : I ≠ 0 := ne_zero_of_mul_eq_one I J h,
  suffices h' : I * (1 / I) = 1,
  { exact (congr_arg units.inv $
      @units.ext _ _ (units.mk_of_mul_eq_one _ _ h) (units.mk_of_mul_eq_one _ _ h') rfl) },
  apply le_antisymm,
  { apply mul_le.mpr _,
    intros x hx y hy,
    rw mul_comm,
    exact (mem_div_iff_of_nonzero hI).mp hy x hx },
  rw ← h,
  apply mul_left_mono I,
  apply (le_div_iff_of_nonzero hI).mpr _,
  intros y hy x hx,
  rw mul_comm,
  exact mul_mem_mul hx hy,
end

theorem mul_div_self_cancel_iff {I : fractional_ideal g} :
  I * (1 / I) = 1 ↔ ∃ J, I * J = 1 :=
⟨λ h, ⟨(1 / I), h⟩, λ ⟨J, hJ⟩, by rwa [← eq_one_div_of_mul_eq_one I J hJ]⟩

variables {K' : Type*} [field K'] {g' : fraction_map R₁ K'}

@[simp] lemma map_div (I J : fractional_ideal g) (h : g.codomain ≃ₐ[R₁] g'.codomain) :
  (I / J).map (h : g.codomain →ₐ[R₁] g'.codomain) = I.map h / J.map h :=
begin
  by_cases H : J = 0,
  { rw [H, div_zero, map_zero, div_zero] },
  { ext x,
    simp [div_nonzero H, div_nonzero (map_ne_zero _ H), submodule.map_div] }
end

@[simp] lemma map_one_div (I : fractional_ideal g) (h : g.codomain ≃ₐ[R₁] g'.codomain) :
  (1 / I).map (h : g.codomain →ₐ[R₁] g'.codomain) = 1 / I.map h :=
by rw [map_div, map_one]

end quotient

section principal_ideal_ring

variables {R₁ : Type*} [integral_domain R₁] {K : Type*} [field K] {g : fraction_map R₁ K}

open_locale classical

open submodule submodule.is_principal

lemma is_fractional_span_singleton (x : f.codomain) : is_fractional f (span R {x}) :=
let ⟨a, ha⟩ := f.exists_integer_multiple x in
is_fractional_span_iff.mpr ⟨ a.1, a.2, λ x hx, (mem_singleton_iff.mp hx).symm ▸ ha⟩

/-- `span_singleton x` is the fractional ideal generated by `x` if `0 ∉ S` -/
@[irreducible]
def span_singleton (x : f.codomain) : fractional_ideal f :=
⟨span R {x}, is_fractional_span_singleton x⟩

local attribute [semireducible] span_singleton

@[simp] lemma coe_span_singleton (x : f.codomain) :
  (span_singleton x : submodule R f.codomain) = span R {x} := rfl

@[simp] lemma mem_span_singleton {x y : f.codomain} :
  x ∈ span_singleton y ↔ ∃ (z : R), z • y = x :=
submodule.mem_span_singleton

lemma mem_span_singleton_self (x : f.codomain) :
  x ∈ span_singleton x :=
mem_span_singleton.mpr ⟨1, one_smul _ _⟩

lemma eq_span_singleton_of_principal (I : fractional_ideal f)
  [is_principal (I : submodule R f.codomain)] :
  I = span_singleton (generator (I : submodule R f.codomain)) :=
ext (span_singleton_generator I.1).symm

lemma is_principal_iff (I : fractional_ideal f) :
  is_principal (I : submodule R f.codomain) ↔ ∃ x, I = span_singleton x :=
⟨λ h, ⟨@generator _ _ _ _ _ I.1 h, @eq_span_singleton_of_principal _ _ _ _ _ _ I h⟩,
 λ ⟨x, hx⟩, { principal := ⟨x, trans (congr_arg _ hx) (coe_span_singleton x)⟩ } ⟩

@[simp] lemma span_singleton_zero : span_singleton (0 : f.codomain) = 0 :=
by { ext, simp [submodule.mem_span_singleton, eq_comm] }

lemma span_singleton_eq_zero_iff {y : f.codomain} : span_singleton y = 0 ↔ y = 0 :=
⟨λ h, span_eq_bot.mp (by simpa using congr_arg subtype.val h : span R {y} = ⊥) y (mem_singleton y),
 λ h, by simp [h] ⟩

lemma span_singleton_ne_zero_iff {y : f.codomain} : span_singleton y ≠ 0 ↔ y ≠ 0 :=
not_congr span_singleton_eq_zero_iff

@[simp] lemma span_singleton_one : span_singleton (1 : f.codomain) = 1 :=
begin
  ext,
  refine mem_span_singleton.trans ((exists_congr _).trans mem_one_iff.symm),
  intro x',
  refine eq.congr (mul_one _) rfl,
end

@[simp]
lemma span_singleton_mul_span_singleton (x y : f.codomain) :
  span_singleton x * span_singleton y = span_singleton (x * y) :=
begin
  ext,
  simp_rw [coe_mul, coe_span_singleton, span_mul_span, singleton.is_mul_hom.map_mul]
end

@[simp]
lemma coe_ideal_span_singleton (x : R) :
  (↑(span R {x} : ideal R) : fractional_ideal f) = span_singleton (f.to_map x) :=
begin
  ext y,
  refine mem_coe_ideal.trans (iff.trans _ mem_span_singleton.symm),
  split,
  { rintros ⟨y', hy', rfl⟩,
    obtain ⟨x', rfl⟩ := submodule.mem_span_singleton.mp hy',
    use x',
    rw [smul_eq_mul, f.to_map.map_mul],
    refl },
  { rintros ⟨y', rfl⟩,
    exact ⟨y' * x, submodule.mem_span_singleton.mpr ⟨y', rfl⟩, f.to_map.map_mul _ _⟩ }
end

@[simp]
lemma canonical_equiv_span_singleton (f : localization_map S P) {P'} [comm_ring P']
  (f' : localization_map S P') (x : f.codomain) :
  canonical_equiv f f' (span_singleton x) =
    span_singleton (f.map (show ∀ (y : S), ring_hom.id _ y.1 ∈ S, from λ y, y.2) f' x) :=
begin
  apply ext_iff.mp,
  intro y,
  split; intro h,
  { apply mem_span_singleton.mpr,
    obtain ⟨x', hx', rfl⟩ := mem_canonical_equiv_apply.mp h,
    obtain ⟨z, rfl⟩ := mem_span_singleton.mp hx',
    use z,
    rw localization_map.map_smul,
    refl },
  { apply mem_canonical_equiv_apply.mpr,
    obtain ⟨z, rfl⟩ := mem_span_singleton.mp h,
    use f.to_map z * x,
    use mem_span_singleton.mpr ⟨z, rfl⟩,
    rw [ring_hom.map_mul, localization_map.map_eq],
    refl }
end

lemma mem_singleton_mul {x y : f.codomain} {I : fractional_ideal f} :
  y ∈ span_singleton x * I ↔ ∃ y' ∈ I, y = x * y' :=
begin
  split,
  { intro h,
    apply fractional_ideal.mul_induction_on h,
    { intros x' hx' y' hy',
      obtain ⟨a, ha⟩ := mem_span_singleton.mp hx',
      use [a • y', I.1.smul_mem a hy'],
      rw [←ha, algebra.mul_smul_comm, algebra.smul_mul_assoc] },
    { exact ⟨0, I.1.zero_mem, (mul_zero x).symm⟩ },
    { rintros _ _ ⟨y, hy, rfl⟩ ⟨y', hy', rfl⟩,
      exact ⟨y + y', I.1.add_mem hy hy', (mul_add _ _ _).symm⟩ },
    { rintros r _ ⟨y', hy', rfl⟩,
      exact ⟨r • y', I.1.smul_mem r hy', (algebra.mul_smul_comm _ _ _).symm ⟩ } },
  { rintros ⟨y', hy', rfl⟩,
    exact mul_mem_mul (mem_span_singleton.mpr ⟨1, one_smul _ _⟩) hy' }
end

lemma one_div_span_singleton (x : g.codomain) :
  1 / span_singleton x = span_singleton (x⁻¹) :=
if h : x = 0 then by simp [h] else (eq_one_div_of_mul_eq_one _ _ (by simp [h])).symm

@[simp] lemma div_span_singleton (J : fractional_ideal g) (d : g.codomain) :
  J / span_singleton d = span_singleton (d⁻¹) * J :=
begin
  rw ← one_div_span_singleton,
  by_cases hd : d = 0,
  { simp only [hd, span_singleton_zero, div_zero, zero_mul] },
  have h_spand : span_singleton d ≠ 0 := mt span_singleton_eq_zero_iff.mp hd,
  apply le_antisymm,
  { intros x hx,
    rw [val_eq_coe, coe_div h_spand, submodule.mem_div_iff_forall_mul_mem] at hx,
    specialize hx d (mem_span_singleton_self d),
    have h_xd : x = d⁻¹ * (x * d), { field_simp },
    rw [val_eq_coe, coe_mul, one_div_span_singleton, h_xd],
    exact submodule.mul_mem_mul (mem_span_singleton_self _) hx },
  { rw [le_div_iff_mul_le h_spand, mul_assoc, mul_left_comm, one_div_span_singleton,
    span_singleton_mul_span_singleton, inv_mul_cancel hd, span_singleton_one, mul_one],
    exact le_refl J },
end

lemma exists_eq_span_singleton_mul (I : fractional_ideal g) :
  ∃ (a : R₁) (aI : ideal R₁), a ≠ 0 ∧ I = span_singleton (g.to_map a)⁻¹ * aI :=
begin
  obtain ⟨a_inv, nonzero, ha⟩ := I.2,
  have nonzero := mem_non_zero_divisors_iff_ne_zero.mp nonzero,
  have map_a_nonzero := mt g.to_map_eq_zero_iff.mp nonzero,
  use a_inv,
  use (span_singleton (g.to_map a_inv) * I).1.comap g.lin_coe,
  split, exact nonzero,
  ext,
  refine iff.trans _ mem_singleton_mul.symm,
  split,
  { intro hx,
    obtain ⟨x', hx'⟩ := ha x hx,
    refine ⟨g.to_map x', mem_coe_ideal.mpr ⟨x', (mem_singleton_mul.mpr ⟨x, hx, hx'⟩), rfl⟩, _⟩,
    erw [hx', ←mul_assoc, inv_mul_cancel map_a_nonzero, one_mul] },
  { rintros ⟨y, hy, rfl⟩,
    obtain ⟨x', hx', rfl⟩ := mem_coe_ideal.mp hy,
    obtain ⟨y', hy', hx'⟩ := mem_singleton_mul.mp hx',
    rw lin_coe_apply at hx',
    erw [hx', ←mul_assoc, inv_mul_cancel map_a_nonzero, one_mul],
    exact hy' }
end

instance is_principal {R} [integral_domain R] [is_principal_ideal_ring R] {f : fraction_map R K}
  (I : fractional_ideal f) : (I : submodule R f.codomain).is_principal :=
begin
  obtain ⟨a, aI, -, ha⟩ := exists_eq_span_singleton_mul I,
  use (f.to_map a)⁻¹ * f.to_map (generator aI),
  suffices : I = span_singleton ((f.to_map a)⁻¹ * f.to_map (generator aI)),
  { exact congr_arg subtype.val this },
  conv_lhs { rw [ha, ←span_singleton_generator aI] },
  rw [coe_ideal_span_singleton (generator aI), span_singleton_mul_span_singleton]
end

end principal_ideal_ring

variables {R₁ : Type*} [integral_domain R₁]
variables {K : Type*} [field K] {g : fraction_map R₁ K}

local attribute [instance] classical.prop_decidable

lemma is_noetherian_zero : is_noetherian R₁ (0 : fractional_ideal g) :=
is_noetherian_submodule.mpr (λ I (hI : I ≤ (0 : fractional_ideal g)),
  by { rw coe_zero at hI, rw le_bot_iff.mp hI, exact fg_bot })

lemma is_noetherian_iff {I : fractional_ideal g} :
  is_noetherian R₁ I ↔ ∀ J ≤ I, (J : submodule R₁ g.codomain).fg :=
is_noetherian_submodule.trans ⟨λ h J hJ, h _ hJ, λ h J hJ, h ⟨J, is_fractional_of_le hJ⟩ hJ⟩

lemma is_noetherian_coe_to_fractional_ideal [is_noetherian_ring R₁] (I : ideal R₁) :
  is_noetherian R₁ (I : fractional_ideal g) :=
begin
  rw is_noetherian_iff,
  intros J hJ,
  obtain ⟨J, rfl⟩ := le_one_iff_exists_coe_ideal.mp (le_trans hJ coe_ideal_le_one),
  exact fg_map (is_noetherian.noetherian J),
end

lemma is_noetherian_span_singleton_inv_to_map_mul (x : R₁) {I : fractional_ideal g}
  (hI : is_noetherian R₁ I) :
  is_noetherian R₁ (span_singleton (g.to_map x)⁻¹ * I : fractional_ideal g) :=
begin
  by_cases hx : x = 0,
  { rw [hx, g.to_map.map_zero, _root_.inv_zero, span_singleton_zero, zero_mul],
    exact is_noetherian_zero },
  have h_gx : g.to_map x ≠ 0,
    from mt (g.to_map.injective_iff.mp (fraction_map.injective g) x) hx,
  have h_spanx : span_singleton (g.to_map x) ≠ (0 : fractional_ideal g),
    from span_singleton_ne_zero_iff.mpr h_gx,
  rw is_noetherian_iff at ⊢ hI,
  intros J hJ,
  rw [← div_span_singleton, le_div_iff_mul_le h_spanx] at hJ,
  obtain ⟨s, hs⟩ := hI _ hJ,
  use s * {(g.to_map x)⁻¹},
  rw [finset.coe_mul, finset.coe_singleton, ← span_mul_span, hs, ← coe_span_singleton, ← coe_mul,
      mul_assoc, span_singleton_mul_span_singleton, mul_inv_cancel h_gx,
      span_singleton_one, mul_one],
end

/-- Every fractional ideal of a noetherian integral domain is noetherian. -/
theorem is_noetherian [is_noetherian_ring R₁] (I : fractional_ideal g) : is_noetherian R₁ I :=
begin
  obtain ⟨d, J, h_nzd, rfl⟩ := exists_eq_span_singleton_mul I,
  apply is_noetherian_span_singleton_inv_to_map_mul,
  apply is_noetherian_coe_to_fractional_ideal,
end

section field

lemma eq_zero_or_one {K L : Type*} [field K] [field L] {f : fraction_map K L}
  (I : fractional_ideal f) : I = 0 ∨ I = 1 :=
begin
  rw or_iff_not_imp_left,
  intro hI,
  simp only [← fractional_ideal.ext_iff, fractional_ideal.mem_one_iff],
  intro x,
  split,
  { intro x_mem,
    obtain ⟨n, d, rfl⟩ := f.mk'_surjective x,
    refine ⟨n / d, _⟩,
    rw [ring_hom.map_div, f.mk'_eq_div] },
  { rintro ⟨x, rfl⟩,
    obtain ⟨y, y_ne, y_mem⟩ := fractional_ideal.exists_ne_zero_mem_is_integer hI,
    rw [← div_mul_cancel x y_ne, ring_hom.map_mul],
    exact submodule.smul_mem I _ y_mem }
end

lemma eq_zero_or_one_of_is_field (hF : is_field R₁)
  (I : fractional_ideal g) : I = 0 ∨ I = 1 :=
by { letI : field R₁ := hF.to_field R₁, exact eq_zero_or_one I }

end field

end fractional_ideal

end ring


/-
Copyright (c) 2019 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel
-/
import data.bundle
import topology.algebra.order.field
import topology.local_homeomorph

/-!
# Trivializations

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

## Main definitions

### Basic definitions

* `trivialization F p` : structure extending local homeomorphisms, defining a local
                  trivialization of a topological space `Z` with projection `p` and fiber `F`.

* `pretrivialization F proj` : trivialization as a local equivalence, mainly used when the
                                      topology on the total space has not yet been defined.

### Operations on bundles

We provide the following operations on `trivialization`s.

* `trivialization.comp_homeomorph`: given a local trivialization `e` of a fiber bundle
  `p : Z → B` and a homeomorphism `h : Z' ≃ₜ Z`, returns a local trivialization of the fiber bundle
  `p ∘ h`.

## Implementation notes

Previously, in mathlib, there was a structure `topological_vector_bundle.trivialization` which
extended another structure `topological_fiber_bundle.trivialization` by a linearity hypothesis. As
of PR #17359, we have changed this to a single structure `trivialization` (no namespace), together
with a mixin class `trivialization.is_linear`.

This permits all the *data* of a vector bundle to be held at the level of fiber bundles, so that the
same trivializations can underlie an object's structure as (say) a vector bundle over `ℂ` and as a
vector bundle over `ℝ`, as well as its structure simply as a fiber bundle.

This might be a little surprising, given the general trend of the library to ever-increased
bundling.  But in this case the typical motivation for more bundling does not apply: there is no
algebraic or order structure on the whole type of linear (say) trivializations of a bundle.
Indeed, since trivializations only have meaning on their base sets (taking junk values outside), the
type of linear trivializations is not even particularly well-behaved.

-/

open topological_space filter set bundle
open_locale topology classical bundle

variables {ι : Type*} {B : Type*} {F : Type*} {E : B → Type*}
variables (F) {Z : Type*} [topological_space B] [topological_space F] {proj : Z → B}

/-- This structure contains the information left for a local trivialization (which is implemented
below as `trivialization F proj`) if the total space has not been given a topology, but we
have a topology on both the fiber and the base space. Through the construction
`topological_fiber_prebundle F proj` it will be possible to promote a
`pretrivialization F proj` to a `trivialization F proj`. -/
@[ext, nolint has_nonempty_instance]
structure pretrivialization (proj : Z → B) extends local_equiv Z (B × F) :=
(open_target   : is_open target)
(base_set      : set B)
(open_base_set : is_open base_set)
(source_eq     : source = proj ⁻¹' base_set)
(target_eq     : target = base_set ×ˢ univ)
(proj_to_fun   : ∀ p ∈ source, (to_fun p).1 = proj p)

namespace pretrivialization

instance : has_coe_to_fun (pretrivialization F proj) (λ _, Z → (B × F)) := ⟨λ e, e.to_fun⟩

variables {F} (e : pretrivialization F proj) {x : Z}

@[simp, mfld_simps] lemma coe_coe : ⇑e.to_local_equiv = e := rfl
@[simp, mfld_simps] lemma coe_fst (ex : x ∈ e.source) : (e x).1 = proj x := e.proj_to_fun x ex
lemma mem_source : x ∈ e.source ↔ proj x ∈ e.base_set := by rw [e.source_eq, mem_preimage]
lemma coe_fst' (ex : proj x ∈ e.base_set) : (e x).1 = proj x := e.coe_fst (e.mem_source.2 ex)
protected lemma eq_on : eq_on (prod.fst ∘ e) proj e.source := λ x hx, e.coe_fst hx
lemma mk_proj_snd (ex : x ∈ e.source) : (proj x, (e x).2) = e x := prod.ext (e.coe_fst ex).symm rfl
lemma mk_proj_snd' (ex : proj x ∈ e.base_set) : (proj x, (e x).2) = e x :=
prod.ext (e.coe_fst' ex).symm rfl

/-- Composition of inverse and coercion from the subtype of the target. -/
def set_symm : e.target → Z := e.target.restrict e.to_local_equiv.symm

lemma mem_target {x : B × F} : x ∈ e.target ↔ x.1 ∈ e.base_set :=
by rw [e.target_eq, prod_univ, mem_preimage]

lemma proj_symm_apply {x : B × F} (hx : x ∈ e.target) : proj (e.to_local_equiv.symm x) = x.1 :=
begin
  have := (e.coe_fst (e.to_local_equiv.map_target hx)).symm,
  rwa [← e.coe_coe, e.to_local_equiv.right_inv hx] at this
end

lemma proj_symm_apply' {b : B} {x : F} (hx : b ∈ e.base_set) :
  proj (e.to_local_equiv.symm (b, x)) = b :=
e.proj_symm_apply (e.mem_target.2 hx)

lemma proj_surj_on_base_set [nonempty F] : set.surj_on proj e.source e.base_set :=
λ b hb, let ⟨y⟩ := ‹nonempty F› in ⟨e.to_local_equiv.symm (b, y),
  e.to_local_equiv.map_target $ e.mem_target.2 hb, e.proj_symm_apply' hb⟩

lemma apply_symm_apply {x : B × F} (hx : x ∈ e.target) : e (e.to_local_equiv.symm x) = x :=
e.to_local_equiv.right_inv hx

lemma apply_symm_apply' {b : B} {x : F} (hx : b ∈ e.base_set) :
  e (e.to_local_equiv.symm (b, x)) = (b, x) :=
e.apply_symm_apply (e.mem_target.2 hx)

lemma symm_apply_apply {x : Z} (hx : x ∈ e.source) : e.to_local_equiv.symm (e x) = x :=
e.to_local_equiv.left_inv hx

@[simp, mfld_simps] lemma symm_apply_mk_proj {x : Z} (ex : x ∈ e.source) :
  e.to_local_equiv.symm (proj x, (e x).2) = x :=
by rw [← e.coe_fst ex, prod.mk.eta, ← e.coe_coe, e.to_local_equiv.left_inv ex]

@[simp, mfld_simps] lemma preimage_symm_proj_base_set :
  (e.to_local_equiv.symm ⁻¹' (proj ⁻¹' e.base_set)) ∩ e.target  = e.target :=
begin
  refine inter_eq_right_iff_subset.mpr (λ x hx, _),
  simp only [mem_preimage, local_equiv.inv_fun_as_coe, e.proj_symm_apply hx],
  exact e.mem_target.mp hx,
end

@[simp, mfld_simps] lemma preimage_symm_proj_inter (s : set B) :
  (e.to_local_equiv.symm ⁻¹' (proj ⁻¹' s)) ∩ e.base_set ×ˢ univ = (s ∩ e.base_set) ×ˢ univ :=
begin
  ext ⟨x, y⟩,
  suffices : x ∈ e.base_set → (proj (e.to_local_equiv.symm (x, y)) ∈ s ↔ x ∈ s),
    by simpa only [prod_mk_mem_set_prod_eq, mem_inter_iff, and_true, mem_univ, and.congr_left_iff],
  intro h,
  rw [e.proj_symm_apply' h]
end

lemma target_inter_preimage_symm_source_eq (e f : pretrivialization F proj) :
  f.target ∩ (f.to_local_equiv.symm) ⁻¹' e.source = (e.base_set ∩ f.base_set) ×ˢ univ :=
by rw [inter_comm, f.target_eq, e.source_eq, f.preimage_symm_proj_inter]

lemma trans_source (e f : pretrivialization F proj) :
  (f.to_local_equiv.symm.trans e.to_local_equiv).source = (e.base_set ∩ f.base_set) ×ˢ univ :=
by rw [local_equiv.trans_source, local_equiv.symm_source, e.target_inter_preimage_symm_source_eq]

lemma symm_trans_symm (e e' : pretrivialization F proj) :
  (e.to_local_equiv.symm.trans e'.to_local_equiv).symm =
  e'.to_local_equiv.symm.trans e.to_local_equiv :=
by rw [local_equiv.trans_symm_eq_symm_trans_symm, local_equiv.symm_symm]

lemma symm_trans_source_eq (e e' : pretrivialization F proj) :
  (e.to_local_equiv.symm.trans e'.to_local_equiv).source = (e.base_set ∩ e'.base_set) ×ˢ univ :=
by rw [local_equiv.trans_source, e'.source_eq, local_equiv.symm_source, e.target_eq, inter_comm,
  e.preimage_symm_proj_inter, inter_comm]

lemma symm_trans_target_eq (e e' : pretrivialization F proj) :
  (e.to_local_equiv.symm.trans e'.to_local_equiv).target = (e.base_set ∩ e'.base_set) ×ˢ univ :=
by rw [← local_equiv.symm_source, symm_trans_symm, symm_trans_source_eq, inter_comm]

variables {B F} (e' : pretrivialization F (π E)) {x' : total_space E} {b : B} {y : E b}

lemma coe_mem_source : ↑y ∈ e'.source ↔ b ∈ e'.base_set := e'.mem_source

@[simp, mfld_simps]

lemma mk_mem_target {x : B} {y : F} : (x, y) ∈ e'.target ↔ x ∈ e'.base_set :=
e'.mem_target

lemma symm_coe_proj {x : B} {y : F} (e' : pretrivialization F (π E)) (h : x ∈ e'.base_set) :
  (e'.to_local_equiv.symm (x, y)).1 = x :=
e'.proj_symm_apply' h

section has_zero
variables [∀ x, has_zero (E x)]

/-- A fiberwise inverse to `e`. This is the function `F → E b` that induces a local inverse
`B × F → total_space E` of `e` on `e.base_set`. It is defined to be `0` outside `e.base_set`. -/
protected noncomputable def symm (e : pretrivialization F (π E)) (b : B) (y : F) : E b :=
if hb : b ∈ e.base_set
then cast (congr_arg E (e.proj_symm_apply' hb)) (e.to_local_equiv.symm (b, y)).2
else 0

lemma symm_apply (e : pretrivialization F (π E)) {b : B} (hb : b ∈ e.base_set) (y : F) :
  e.symm b y = cast (congr_arg E (e.symm_coe_proj hb)) (e.to_local_equiv.symm (b, y)).2 :=
dif_pos hb

lemma symm_apply_of_not_mem (e : pretrivialization F (π E)) {b : B} (hb : b ∉ e.base_set) (y : F) :
  e.symm b y = 0 :=
dif_neg hb

lemma coe_symm_of_not_mem (e : pretrivialization F (π E)) {b : B} (hb : b ∉ e.base_set) :
  (e.symm b : F → E b) = 0 :=
funext $ λ y, dif_neg hb

lemma mk_symm (e : pretrivialization F (π E)) {b : B} (hb : b ∈ e.base_set) (y : F) :
  total_space_mk b (e.symm b y) = e.to_local_equiv.symm (b, y) :=
by rw [e.symm_apply hb, total_space.mk_cast, total_space.eta]

lemma symm_proj_apply (e : pretrivialization F (π E)) (z : total_space E)
  (hz : z.proj ∈ e.base_set) : e.symm z.proj (e z).2 = z.2 :=
by rw [e.symm_apply hz, cast_eq_iff_heq, e.mk_proj_snd' hz,
  e.symm_apply_apply (e.mem_source.mpr hz)]

lemma symm_apply_apply_mk (e : pretrivialization F (π E)) {b : B} (hb : b ∈ e.base_set) (y : E b) :
  e.symm b (e (total_space_mk b y)).2 = y :=
e.symm_proj_apply (total_space_mk b y) hb

lemma apply_mk_symm (e : pretrivialization F (π E)) {b : B} (hb : b ∈ e.base_set) (y : F) :
  e (total_space_mk b (e.symm b y)) = (b, y) :=
by rw [e.mk_symm hb, e.apply_symm_apply (e.mk_mem_target.mpr hb)]

end has_zero

end pretrivialization

variables [topological_space Z] [topological_space (total_space E)]

/--
A structure extending local homeomorphisms, defining a local trivialization of a projection
`proj : Z → B` with fiber `F`, as a local homeomorphism between `Z` and `B × F` defined between two
sets of the form `proj ⁻¹' base_set` and `base_set × F`, acting trivially on the first coordinate.
-/
@[ext, nolint has_nonempty_instance]
structure trivialization (proj : Z → B)
  extends local_homeomorph Z (B × F) :=
(base_set      : set B)
(open_base_set : is_open base_set)
(source_eq     : source = proj ⁻¹' base_set)
(target_eq     : target = base_set ×ˢ univ)
(proj_to_fun   : ∀ p ∈ source, (to_local_homeomorph p).1 = proj p)

namespace trivialization

variables {F} (e : trivialization F proj) {x : Z}

/-- Natural identification as a `pretrivialization`. -/
def to_pretrivialization : pretrivialization F proj := { ..e }

instance : has_coe_to_fun (trivialization F proj) (λ _, Z → B × F) := ⟨λ e, e.to_fun⟩
instance : has_coe (trivialization F proj) (pretrivialization F proj) :=
⟨to_pretrivialization⟩

lemma to_pretrivialization_injective :
  function.injective (λ e : trivialization F proj, e.to_pretrivialization) :=
by { intros e e', rw [pretrivialization.ext_iff, trivialization.ext_iff,
  ← local_homeomorph.to_local_equiv_injective.eq_iff], exact id }

@[simp, mfld_simps] lemma coe_coe : ⇑e.to_local_homeomorph = e := rfl
@[simp, mfld_simps] lemma coe_fst (ex : x ∈ e.source) : (e x).1 = proj x := e.proj_to_fun x ex
protected lemma eq_on : eq_on (prod.fst ∘ e) proj e.source := λ x hx, e.coe_fst hx
lemma mem_source : x ∈ e.source ↔ proj x ∈ e.base_set := by rw [e.source_eq, mem_preimage]
lemma coe_fst' (ex : proj x ∈ e.base_set) : (e x).1 = proj x := e.coe_fst (e.mem_source.2 ex)
lemma mk_proj_snd (ex : x ∈ e.source) : (proj x, (e x).2) = e x := prod.ext (e.coe_fst ex).symm rfl
lemma mk_proj_snd' (ex : proj x ∈ e.base_set) : (proj x, (e x).2) = e x :=
prod.ext (e.coe_fst' ex).symm rfl

lemma source_inter_preimage_target_inter (s : set (B × F)) :
  e.source ∩ (e ⁻¹' (e.target ∩ s)) = e.source ∩ (e ⁻¹' s) :=
e.to_local_homeomorph.source_inter_preimage_target_inter s

@[simp, mfld_simps] lemma coe_mk (e : local_homeomorph Z (B × F)) (i j k l m) (x : Z) :
  (trivialization.mk e i j k l m : trivialization F proj) x = e x := rfl

lemma mem_target {x : B × F} : x ∈ e.target ↔ x.1 ∈ e.base_set :=
e.to_pretrivialization.mem_target

lemma map_target {x : B × F} (hx : x ∈ e.target) : e.to_local_homeomorph.symm x ∈ e.source :=
e.to_local_homeomorph.map_target hx

lemma proj_symm_apply {x : B × F} (hx : x ∈ e.target) : proj (e.to_local_homeomorph.symm x) = x.1 :=
e.to_pretrivialization.proj_symm_apply hx

lemma proj_symm_apply' {b : B} {x : F}
  (hx : b ∈ e.base_set) : proj (e.to_local_homeomorph.symm (b, x)) = b :=
e.to_pretrivialization.proj_symm_apply' hx

lemma proj_surj_on_base_set [nonempty F] : set.surj_on proj e.source e.base_set :=
e.to_pretrivialization.proj_surj_on_base_set

lemma apply_symm_apply {x : B × F} (hx : x ∈ e.target) : e (e.to_local_homeomorph.symm x) = x :=
e.to_local_homeomorph.right_inv hx

lemma apply_symm_apply'
  {b : B} {x : F} (hx : b ∈ e.base_set) : e (e.to_local_homeomorph.symm (b, x)) = (b, x) :=
e.to_pretrivialization.apply_symm_apply' hx

@[simp, mfld_simps] lemma symm_apply_mk_proj (ex : x ∈ e.source) :
  e.to_local_homeomorph.symm (proj x, (e x).2) = x :=
e.to_pretrivialization.symm_apply_mk_proj ex

lemma symm_trans_source_eq (e e' : trivialization F proj) :
  (e.to_local_equiv.symm.trans e'.to_local_equiv).source = (e.base_set ∩ e'.base_set) ×ˢ univ :=
pretrivialization.symm_trans_source_eq e.to_pretrivialization e'

lemma symm_trans_target_eq (e e' : trivialization F proj) :
  (e.to_local_equiv.symm.trans e'.to_local_equiv).target = (e.base_set ∩ e'.base_set) ×ˢ univ :=
pretrivialization.symm_trans_target_eq e.to_pretrivialization e'

lemma coe_fst_eventually_eq_proj (ex : x ∈ e.source) : prod.fst ∘ e =ᶠ[𝓝 x] proj  :=
mem_nhds_iff.2 ⟨e.source, λ y hy, e.coe_fst hy, e.open_source, ex⟩

lemma coe_fst_eventually_eq_proj' (ex : proj x ∈ e.base_set) : prod.fst ∘ e =ᶠ[𝓝 x] proj :=
e.coe_fst_eventually_eq_proj (e.mem_source.2 ex)

lemma map_proj_nhds (ex : x ∈ e.source) : map proj (𝓝 x) = 𝓝 (proj x) :=
by rw [← e.coe_fst ex, ← map_congr (e.coe_fst_eventually_eq_proj ex), ← map_map, ← e.coe_coe,
  e.to_local_homeomorph.map_nhds_eq ex, map_fst_nhds]

lemma preimage_subset_source {s : set B} (hb : s ⊆ e.base_set) : proj ⁻¹' s ⊆ e.source :=
λ p hp, e.mem_source.mpr (hb hp)

lemma image_preimage_eq_prod_univ {s : set B} (hb : s ⊆ e.base_set) :
  e '' (proj ⁻¹' s) = s ×ˢ univ :=
subset.antisymm (image_subset_iff.mpr (λ p hp,
  ⟨(e.proj_to_fun p (e.preimage_subset_source hb hp)).symm ▸ hp, trivial⟩)) (λ p hp,
  let hp' : p ∈ e.target := e.mem_target.mpr (hb hp.1) in
  ⟨e.inv_fun p, mem_preimage.mpr ((e.proj_symm_apply hp').symm ▸ hp.1), e.apply_symm_apply hp'⟩)

/-- The preimage of a subset of the base set is homeomorphic to the product with the fiber. -/
def preimage_homeomorph {s : set B} (hb : s ⊆ e.base_set) : proj ⁻¹' s ≃ₜ s × F :=
(e.to_local_homeomorph.homeomorph_of_image_subset_source (e.preimage_subset_source hb)
  (e.image_preimage_eq_prod_univ hb)).trans
  ((homeomorph.set.prod s univ).trans ((homeomorph.refl s).prod_congr (homeomorph.set.univ F)))

@[simp] lemma preimage_homeomorph_apply {s : set B} (hb : s ⊆ e.base_set) (p : proj ⁻¹' s) :
  e.preimage_homeomorph hb p = (⟨proj p, p.2⟩, (e p).2) :=
prod.ext (subtype.ext (e.proj_to_fun p (e.mem_source.mpr (hb p.2)))) rfl

@[simp] lemma preimage_homeomorph_symm_apply {s : set B} (hb : s ⊆ e.base_set) (p : s × F) :
  (e.preimage_homeomorph hb).symm p = ⟨e.symm (p.1, p.2), ((e.preimage_homeomorph hb).symm p).2⟩ :=
rfl

/-- The source is homeomorphic to the product of the base set with the fiber. -/
def source_homeomorph_base_set_prod : e.source ≃ₜ e.base_set × F :=
(homeomorph.set_congr e.source_eq).trans (e.preimage_homeomorph subset_rfl)

@[simp] lemma source_homeomorph_base_set_prod_apply (p : e.source) :
  e.source_homeomorph_base_set_prod p = (⟨proj p, e.mem_source.mp p.2⟩, (e p).2) :=
e.preimage_homeomorph_apply subset_rfl ⟨p, e.mem_source.mp p.2⟩

@[simp] lemma source_homeomorph_base_set_prod_symm_apply (p : e.base_set × F) :
  e.source_homeomorph_base_set_prod.symm p =
    ⟨e.symm (p.1, p.2), (e.source_homeomorph_base_set_prod.symm p).2⟩ :=
rfl

/-- Each fiber of a trivialization is homeomorphic to the specified fiber. -/
def preimage_singleton_homeomorph {b : B} (hb : b ∈ e.base_set) : proj ⁻¹' {b} ≃ₜ F :=
(e.preimage_homeomorph (set.singleton_subset_iff.mpr hb)).trans (((homeomorph.homeomorph_of_unique
  ({b} : set B) punit).prod_congr (homeomorph.refl F)).trans (homeomorph.punit_prod F))

@[simp] lemma preimage_singleton_homeomorph_apply {b : B} (hb : b ∈ e.base_set)
  (p : proj ⁻¹' {b}) : e.preimage_singleton_homeomorph hb p = (e p).2 :=
rfl

@[simp] lemma preimage_singleton_homeomorph_symm_apply {b : B} (hb : b ∈ e.base_set) (p : F) :
  (e.preimage_singleton_homeomorph hb).symm p =
    ⟨e.symm (b, p), by rw [mem_preimage, e.proj_symm_apply' hb, mem_singleton_iff]⟩ :=
rfl

/-- In the domain of a bundle trivialization, the projection is continuous-/
lemma continuous_at_proj (ex : x ∈ e.source) : continuous_at proj x :=
(e.map_proj_nhds ex).le

/-- Composition of a `trivialization` and a `homeomorph`. -/
protected def comp_homeomorph {Z' : Type*} [topological_space Z'] (h : Z' ≃ₜ Z) :
  trivialization F (proj ∘ h) :=
{ to_local_homeomorph := h.to_local_homeomorph.trans e.to_local_homeomorph,
  base_set := e.base_set,
  open_base_set := e.open_base_set,
  source_eq := by simp [e.source_eq, preimage_preimage],
  target_eq := by simp [e.target_eq],
  proj_to_fun := λ p hp,
    have hp : h p ∈ e.source, by simpa using hp,
    by simp [hp] }

/-- Read off the continuity of a function `f : Z → X` at `z : Z` by transferring via a
trivialization of `Z` containing `z`. -/
lemma continuous_at_of_comp_right {X : Type*} [topological_space X] {f : Z → X} {z : Z}
  (e : trivialization F proj) (he : proj z ∈ e.base_set)
  (hf : continuous_at (f ∘ e.to_local_equiv.symm) (e z)) :
  continuous_at f z :=
begin
  have hez : z ∈ e.to_local_equiv.symm.target,
  { rw [local_equiv.symm_target, e.mem_source],
    exact he },
  rwa [e.to_local_homeomorph.symm.continuous_at_iff_continuous_at_comp_right hez,
   local_homeomorph.symm_symm]
end

/-- Read off the continuity of a function `f : X → Z` at `x : X` by transferring via a
trivialization of `Z` containing `f x`. -/
lemma continuous_at_of_comp_left {X : Type*} [topological_space X] {f : X → Z} {x : X}
  (e : trivialization F proj) (hf_proj : continuous_at (proj ∘ f) x) (he : proj (f x) ∈ e.base_set)
  (hf : continuous_at (e ∘ f) x) :
  continuous_at f x :=
begin
  rw e.to_local_homeomorph.continuous_at_iff_continuous_at_comp_left,
  { exact hf },
  rw [e.source_eq, ← preimage_comp],
  exact hf_proj.preimage_mem_nhds (e.open_base_set.mem_nhds he),
end

variables {E} (e' : trivialization F (π E)) {x' : total_space E} {b : B} {y : E b}

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

lemma coe_mem_source : ↑y ∈ e'.source ↔ b ∈ e'.base_set := e'.mem_source

lemma open_target : is_open e'.target :=
by { rw e'.target_eq, exact e'.open_base_set.prod is_open_univ }

@[simp, mfld_simps] lemma coe_coe_fst (hb : b ∈ e'.base_set) : (e' y).1 = b :=
e'.coe_fst (e'.mem_source.2 hb)

lemma mk_mem_target {y : F} : (b, y) ∈ e'.target ↔ b ∈ e'.base_set :=
e'.to_pretrivialization.mem_target

lemma symm_apply_apply {x : total_space E} (hx : x ∈ e'.source) :
  e'.to_local_homeomorph.symm (e' x) = x :=
e'.to_local_equiv.left_inv hx

@[simp, mfld_simps] lemma symm_coe_proj {x : B} {y : F}
  (e : trivialization F (π E)) (h : x ∈ e.base_set) :
  (e.to_local_homeomorph.symm (x, y)).1 = x := e.proj_symm_apply' h

section has_zero
variables [∀ x, has_zero (E x)]

/-- A fiberwise inverse to `e'`. The function `F → E x` that induces a local inverse
`B × F → total_space E` of `e'` on `e'.base_set`. It is defined to be `0` outside `e'.base_set`. -/
protected noncomputable def symm (e : trivialization F (π E)) (b : B) (y : F) : E b :=
e.to_pretrivialization.symm b y

lemma symm_apply (e : trivialization F (π E)) {b : B} (hb : b ∈ e.base_set) (y : F) :
  e.symm b y = cast (congr_arg E (e.symm_coe_proj hb)) (e.to_local_homeomorph.symm (b, y)).2 :=
dif_pos hb

lemma symm_apply_of_not_mem (e : trivialization F (π E)) {b : B} (hb : b ∉ e.base_set) (y : F) :
  e.symm b y = 0 :=
dif_neg hb

lemma mk_symm (e : trivialization F (π E)) {b : B} (hb : b ∈ e.base_set) (y : F) :
  total_space_mk b (e.symm b y) = e.to_local_homeomorph.symm (b, y) :=
e.to_pretrivialization.mk_symm hb y

lemma symm_proj_apply (e : trivialization F (π E)) (z : total_space E)
  (hz : z.proj ∈ e.base_set) : e.symm z.proj (e z).2 = z.2 :=
e.to_pretrivialization.symm_proj_apply z hz

lemma symm_apply_apply_mk (e : trivialization F (π E)) {b : B} (hb : b ∈ e.base_set) (y : E b) :
  e.symm b (e (total_space_mk b y)).2 = y :=
e.symm_proj_apply (total_space_mk b y) hb

lemma apply_mk_symm (e : trivialization F (π E)) {b : B} (hb : b ∈ e.base_set) (y : F) :
  e (total_space_mk b (e.symm b y)) = (b, y) :=
e.to_pretrivialization.apply_mk_symm hb y

lemma continuous_on_symm (e : trivialization F (π E)) :
  continuous_on (λ z : B × F, total_space_mk z.1 (e.symm z.1 z.2)) (e.base_set ×ˢ univ) :=
begin
  have : ∀ (z : B × F) (hz : z ∈ e.base_set ×ˢ (univ : set F)),
    total_space_mk z.1 (e.symm z.1 z.2) = e.to_local_homeomorph.symm z,
  { rintro x ⟨hx : x.1 ∈ e.base_set, _⟩, simp_rw [e.mk_symm hx, prod.mk.eta] },
  refine continuous_on.congr _ this,
  rw [← e.target_eq],
  exact e.to_local_homeomorph.continuous_on_symm
end

end has_zero

/-- If `e` is a `trivialization` of `proj : Z → B` with fiber `F` and `h` is a homeomorphism
`F ≃ₜ F'`, then `e.trans_fiber_homeomorph h` is the trivialization of `proj` with the fiber `F'`
that sends `p : Z` to `((e p).1, h (e p).2)`. -/
def trans_fiber_homeomorph {F' : Type*} [topological_space F']
  (e : trivialization F proj) (h : F ≃ₜ F') : trivialization F' proj :=
{ to_local_homeomorph := e.to_local_homeomorph.trans_homeomorph $ (homeomorph.refl _).prod_congr h,
  base_set := e.base_set,
  open_base_set := e.open_base_set,
  source_eq := e.source_eq,
  target_eq := by simp [e.target_eq, prod_univ, preimage_preimage],
  proj_to_fun := e.proj_to_fun }

@[simp] lemma trans_fiber_homeomorph_apply {F' : Type*} [topological_space F']
  (e : trivialization F proj) (h : F ≃ₜ F') (x : Z) :
  e.trans_fiber_homeomorph h x = ((e x).1, h (e x).2) :=
rfl

/-- Coordinate transformation in the fiber induced by a pair of bundle trivializations. See also
`trivialization.coord_change_homeomorph` for a version bundled as `F ≃ₜ F`. -/
def coord_change (e₁ e₂ : trivialization F proj) (b : B) (x : F) : F :=
(e₂ $ e₁.to_local_homeomorph.symm (b, x)).2

lemma mk_coord_change
  (e₁ e₂ : trivialization F proj) {b : B}
  (h₁ : b ∈ e₁.base_set) (h₂ : b ∈ e₂.base_set) (x : F) :
  (b, e₁.coord_change e₂ b x) = e₂ (e₁.to_local_homeomorph.symm (b, x)) :=
begin
  refine prod.ext _ rfl,
  rw [e₂.coe_fst', ← e₁.coe_fst', e₁.apply_symm_apply' h₁],
  { rwa [e₁.proj_symm_apply' h₁] },
  { rwa [e₁.proj_symm_apply' h₁] }
end

lemma coord_change_apply_snd
  (e₁ e₂ : trivialization F proj) {p : Z}
  (h : proj p ∈ e₁.base_set) :
  e₁.coord_change e₂ (proj p) (e₁ p).snd = (e₂ p).snd :=
by rw [coord_change, e₁.symm_apply_mk_proj (e₁.mem_source.2 h)]

lemma coord_change_same_apply
  (e : trivialization F proj) {b : B} (h : b ∈ e.base_set) (x : F) :
  e.coord_change e b x = x :=
by rw [coord_change, e.apply_symm_apply' h]

lemma coord_change_same
  (e : trivialization F proj) {b : B} (h : b ∈ e.base_set) :
  e.coord_change e b = id :=
funext $ e.coord_change_same_apply h

lemma coord_change_coord_change
  (e₁ e₂ e₃ : trivialization F proj) {b : B}
  (h₁ : b ∈ e₁.base_set) (h₂ : b ∈ e₂.base_set) (x : F) :
  e₂.coord_change e₃ b (e₁.coord_change e₂ b x) = e₁.coord_change e₃ b x :=
begin
  rw [coord_change, e₁.mk_coord_change _ h₁ h₂, ← e₂.coe_coe,
    e₂.to_local_homeomorph.left_inv, coord_change],
  rwa [e₂.mem_source, e₁.proj_symm_apply' h₁]
end

lemma continuous_coord_change (e₁ e₂ : trivialization F proj) {b : B}
  (h₁ : b ∈ e₁.base_set) (h₂ : b ∈ e₂.base_set) :
  continuous (e₁.coord_change e₂ b) :=
begin
  refine continuous_snd.comp (e₂.to_local_homeomorph.continuous_on.comp_continuous
    (e₁.to_local_homeomorph.continuous_on_symm.comp_continuous _ _) _),
  { exact continuous_const.prod_mk continuous_id },
  { exact λ x, e₁.mem_target.2 h₁ },
  { intro x,
    rwa [e₂.mem_source, e₁.proj_symm_apply' h₁] }
end

/-- Coordinate transformation in the fiber induced by a pair of bundle trivializations,
as a homeomorphism. -/
protected def coord_change_homeomorph
  (e₁ e₂ : trivialization F proj) {b : B} (h₁ : b ∈ e₁.base_set) (h₂ : b ∈ e₂.base_set) :
  F ≃ₜ F :=
{ to_fun := e₁.coord_change e₂ b,
  inv_fun := e₂.coord_change e₁ b,
  left_inv := λ x, by simp only [*, coord_change_coord_change, coord_change_same_apply],
  right_inv := λ x, by simp only [*, coord_change_coord_change, coord_change_same_apply],
  continuous_to_fun := e₁.continuous_coord_change e₂ h₁ h₂,
  continuous_inv_fun := e₂.continuous_coord_change e₁ h₂ h₁ }

@[simp] lemma coord_change_homeomorph_coe
  (e₁ e₂ : trivialization F proj) {b : B} (h₁ : b ∈ e₁.base_set) (h₂ : b ∈ e₂.base_set) :
  ⇑(e₁.coord_change_homeomorph e₂ h₁ h₂) = e₁.coord_change e₂ b :=
rfl

variables {F} {B' : Type*} [topological_space B']

lemma is_image_preimage_prod (e : trivialization F proj) (s : set B) :
  e.to_local_homeomorph.is_image (proj ⁻¹' s) (s ×ˢ univ) :=
λ x hx, by simp [e.coe_fst', hx]

/-- Restrict a `trivialization` to an open set in the base. `-/
protected def restr_open (e : trivialization F proj) (s : set B)
  (hs : is_open s) : trivialization F proj :=
{ to_local_homeomorph := ((e.is_image_preimage_prod s).symm.restr
    (is_open.inter e.open_target (hs.prod is_open_univ))).symm,
  base_set := e.base_set ∩ s,
  open_base_set := is_open.inter e.open_base_set hs,
  source_eq := by simp [e.source_eq],
  target_eq := by simp [e.target_eq, prod_univ],
  proj_to_fun := λ p hp, e.proj_to_fun p hp.1 }

section piecewise

lemma frontier_preimage (e : trivialization F proj) (s : set B) :
  e.source ∩ frontier (proj ⁻¹' s) = proj ⁻¹' (e.base_set ∩ frontier s) :=
by rw [← (e.is_image_preimage_prod s).frontier.preimage_eq, frontier_prod_univ_eq,
  (e.is_image_preimage_prod _).preimage_eq, e.source_eq, preimage_inter]

/-- Given two bundle trivializations `e`, `e'` of `proj : Z → B` and a set `s : set B` such that
the base sets of `e` and `e'` intersect `frontier s` on the same set and `e p = e' p` whenever
`proj p ∈ e.base_set ∩ frontier s`, `e.piecewise e' s Hs Heq` is the bundle trivialization over
`set.ite s e.base_set e'.base_set` that is equal to `e` on `proj ⁻¹ s` and is equal to `e'`
otherwise. -/
noncomputable def piecewise (e e' : trivialization F proj) (s : set B)
  (Hs : e.base_set ∩ frontier s = e'.base_set ∩ frontier s)
  (Heq : eq_on e e' $ proj ⁻¹' (e.base_set ∩ frontier s)) :
  trivialization F proj :=
{ to_local_homeomorph := e.to_local_homeomorph.piecewise e'.to_local_homeomorph
    (proj ⁻¹' s) (s ×ˢ univ) (e.is_image_preimage_prod s) (e'.is_image_preimage_prod s)
    (by rw [e.frontier_preimage, e'.frontier_preimage, Hs])
    (by rwa e.frontier_preimage),
  base_set := s.ite e.base_set e'.base_set,
  open_base_set := e.open_base_set.ite e'.open_base_set Hs,
  source_eq := by simp [e.source_eq, e'.source_eq],
  target_eq := by simp [e.target_eq, e'.target_eq, prod_univ],
  proj_to_fun := by rintro p (⟨he, hs⟩|⟨he, hs⟩); simp * }

/-- Given two bundle trivializations `e`, `e'` of a topological fiber bundle `proj : Z → B`
over a linearly ordered base `B` and a point `a ∈ e.base_set ∩ e'.base_set` such that
`e` equals `e'` on `proj ⁻¹' {a}`, `e.piecewise_le_of_eq e' a He He' Heq` is the bundle
trivialization over `set.ite (Iic a) e.base_set e'.base_set` that is equal to `e` on points `p`
such that `proj p ≤ a` and is equal to `e'` otherwise. -/
noncomputable def piecewise_le_of_eq [linear_order B] [order_topology B]
  (e e' : trivialization F proj) (a : B) (He : a ∈ e.base_set) (He' : a ∈ e'.base_set)
  (Heq : ∀ p, proj p = a → e p = e' p) :
  trivialization F proj :=
e.piecewise e' (Iic a)
  (set.ext $ λ x, and.congr_left_iff.2 $ λ hx,
    by simp [He, He', mem_singleton_iff.1 (frontier_Iic_subset _ hx)])
  (λ p hp, Heq p $ frontier_Iic_subset _ hp.2)

/-- Given two bundle trivializations `e`, `e'` of a topological fiber bundle `proj : Z → B` over a
linearly ordered base `B` and a point `a ∈ e.base_set ∩ e'.base_set`, `e.piecewise_le e' a He He'`
is the bundle trivialization over `set.ite (Iic a) e.base_set e'.base_set` that is equal to `e` on
points `p` such that `proj p ≤ a` and is equal to `((e' p).1, h (e' p).2)` otherwise, where
`h = `e'.coord_change_homeomorph e _ _` is the homeomorphism of the fiber such that
`h (e' p).2 = (e p).2` whenever `e p = a`. -/
noncomputable def piecewise_le [linear_order B] [order_topology B]
  (e e' : trivialization F proj) (a : B) (He : a ∈ e.base_set) (He' : a ∈ e'.base_set) :
  trivialization F proj :=
e.piecewise_le_of_eq (e'.trans_fiber_homeomorph (e'.coord_change_homeomorph e He' He))
  a He He' $ by { unfreezingI {rintro p rfl },
    ext1,
    { simp [e.coe_fst', e'.coe_fst', *] },
    { simp [e'.coord_change_apply_snd, *] } }

/-- Given two bundle trivializations `e`, `e'` over disjoint sets, `e.disjoint_union e' H` is the
bundle trivialization over the union of the base sets that agrees with `e` and `e'` over their
base sets. -/
noncomputable def disjoint_union (e e' : trivialization F proj)
  (H : disjoint e.base_set e'.base_set) :
  trivialization F proj :=
{ to_local_homeomorph := e.to_local_homeomorph.disjoint_union e'.to_local_homeomorph
    (by { rw [e.source_eq, e'.source_eq], exact H.preimage _, })
    (by { rw [e.target_eq, e'.target_eq, disjoint_iff_inf_le],
          intros x hx, exact H.le_bot ⟨hx.1.1, hx.2.1⟩ }),
  base_set := e.base_set ∪ e'.base_set,
  open_base_set := is_open.union e.open_base_set e'.open_base_set,
  source_eq := congr_arg2 (∪) e.source_eq e'.source_eq,
  target_eq := (congr_arg2 (∪) e.target_eq e'.target_eq).trans union_prod.symm,
  proj_to_fun :=
    begin
      rintro p (hp|hp'),
      { show (e.source.piecewise e e' p).1 = proj p,
        rw [piecewise_eq_of_mem, e.coe_fst]; exact hp },
      { show (e.source.piecewise e e' p).1 = proj p,
        rw [piecewise_eq_of_not_mem, e'.coe_fst hp'],
        simp only [e.source_eq, e'.source_eq] at hp' ⊢,
        exact λ h, H.le_bot ⟨h, hp'⟩ }
    end }

end piecewise

end trivialization


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

! This file was ported from Lean 3 source module data.qpf.multivariate.constructions.cofix
! leanprover-community/mathlib commit f694c7dead66f5d4c80f446c796a5aad14707f0e
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Control.Functor.Multivariate
import Mathbin.Data.Pfunctor.Multivariate.Basic
import Mathbin.Data.Pfunctor.Multivariate.M
import Mathbin.Data.Qpf.Multivariate.Basic

/-!
# The final co-algebra of a multivariate qpf is again a qpf.

For a `(n+1)`-ary QPF `F (α₀,..,αₙ)`, we take the least fixed point of `F` with
regards to its last argument `αₙ`. The result is a `n`-ary functor: `fix F (α₀,..,αₙ₋₁)`.
Making `fix F` into a functor allows us to take the fixed point, compose with other functors
and take a fixed point again.

## Main definitions

 * `cofix.mk`     - constructor
 * `cofix.dest`   - destructor
 * `cofix.corec`  - corecursor: useful for formulating infinite, productive computations
 * `cofix.bisim`  - bisimulation: proof technique to show the equality of possibly infinite values
                    of `cofix F α`

## Implementation notes

For `F` a QPF, we define `cofix F α` in terms of the M-type of the polynomial functor `P` of `F`.
We define the relation `Mcongr` and take its quotient as the definition of `cofix F α`.

`Mcongr` is taken as the weakest bisimulation on M-type. See
[avigad-carneiro-hudon2019] for more details.

## Reference

 * Jeremy Avigad, Mario M. Carneiro and Simon Hudon.
   [*Data Types as Quotients of Polynomial Functors*][avigad-carneiro-hudon2019]
-/

universe u

open MvFunctor

namespace MvQPF

open TypeVec MvPFunctor

open MvFunctor (Liftp Liftr)

variable {n : ℕ} {F : TypeVec.{u} (n + 1) → Type u} [MvFunctor F] [q : MvQPF F]

include q

/-- `corecF` is used as a basis for defining the corecursor of `cofix F α`. `corecF`
uses corecursion to construct the M-type generated by `q.P` and uses function on `F`
as a corecursive step -/
def corecF {α : TypeVec n} {β : Type _} (g : β → F (α.append1 β)) : β → q.p.M α :=
  M.corec _ fun x => repr (g x)
#align mvqpf.corecF MvQPF.corecF

theorem corecF_eq {α : TypeVec n} {β : Type _} (g : β → F (α.append1 β)) (x : β) :
    M.dest q.p (corecF g x) = appendFun id (corecF g) <$$> repr (g x) := by
  rw [corecF, M.dest_corec]
#align mvqpf.corecF_eq MvQPF.corecF_eq

/-- Characterization of desirable equivalence relations on M-types -/
def IsPrecongr {α : TypeVec n} (r : q.p.M α → q.p.M α → Prop) : Prop :=
  ∀ ⦃x y⦄,
    r x y →
      abs (appendFun id (Quot.mk r) <$$> M.dest q.p x) =
        abs (appendFun id (Quot.mk r) <$$> M.dest q.p y)
#align mvqpf.is_precongr MvQPF.IsPrecongr

/-- Equivalence relation on M-types representing a value of type `cofix F` -/
def Mcongr {α : TypeVec n} (x y : q.p.M α) : Prop :=
  ∃ r, IsPrecongr r ∧ r x y
#align mvqpf.Mcongr MvQPF.Mcongr

/-- Greatest fixed point of functor F. The result is a functor with one fewer parameters
than the input. For `F a b c` a ternary functor, fix F is a binary functor such that

```lean
cofix F a b = F a b (cofix F a b)
```
-/
def Cofix (F : TypeVec (n + 1) → Type u) [MvFunctor F] [q : MvQPF F] (α : TypeVec n) :=
  Quot (@Mcongr _ F _ q α)
#align mvqpf.cofix MvQPF.Cofix

instance {α : TypeVec n} [Inhabited q.p.A] [∀ i : Fin2 n, Inhabited (α i)] :
    Inhabited (Cofix F α) :=
  ⟨Quot.mk _ default⟩

/-- maps every element of the W type to a canonical representative -/
def mrepr {α : TypeVec n} : q.p.M α → q.p.M α :=
  corecF (abs ∘ M.dest q.p)
#align mvqpf.Mrepr MvQPF.mrepr

/-- the map function for the functor `cofix F` -/
def Cofix.map {α β : TypeVec n} (g : α ⟹ β) : Cofix F α → Cofix F β :=
  Quot.lift (fun x : q.p.M α => Quot.mk Mcongr (g <$$> x))
    (by
      rintro aa₁ aa₂ ⟨r, pr, ra₁a₂⟩; apply Quot.sound
      let r' b₁ b₂ := ∃ a₁ a₂ : q.P.M α, r a₁ a₂ ∧ b₁ = g <$$> a₁ ∧ b₂ = g <$$> a₂
      use r'; constructor
      · show is_precongr r'
        rintro b₁ b₂ ⟨a₁, a₂, ra₁a₂, b₁eq, b₂eq⟩
        let u : Quot r → Quot r' :=
          Quot.lift (fun x : q.P.M α => Quot.mk r' (g <$$> x))
            (by
              intro a₁ a₂ ra₁a₂
              apply Quot.sound
              exact ⟨a₁, a₂, ra₁a₂, rfl, rfl⟩)
        have hu : (Quot.mk r' ∘ fun x : q.P.M α => g <$$> x) = u ∘ Quot.mk r :=
          by
          ext x
          rfl
        rw [b₁eq, b₂eq, M.dest_map, M.dest_map, ← q.P.comp_map, ← q.P.comp_map]
        rw [← append_fun_comp, id_comp, hu, hu, ← comp_id g, append_fun_comp]
        rw [q.P.comp_map, q.P.comp_map, abs_map, pr ra₁a₂, ← abs_map]
      show r' (g <$$> aa₁) (g <$$> aa₂); exact ⟨aa₁, aa₂, ra₁a₂, rfl, rfl⟩)
#align mvqpf.cofix.map MvQPF.Cofix.map

instance Cofix.mvfunctor : MvFunctor (Cofix F) where map := @Cofix.map _ _ _ _
#align mvqpf.cofix.mvfunctor MvQPF.Cofix.mvfunctor

/-- Corecursor for `cofix F` -/
def Cofix.corec {α : TypeVec n} {β : Type u} (g : β → F (α.append1 β)) : β → Cofix F α := fun x =>
  Quot.mk _ (corecF g x)
#align mvqpf.cofix.corec MvQPF.Cofix.corec

/-- Destructor for `cofix F` -/
def Cofix.dest {α : TypeVec n} : Cofix F α → F (α.append1 (Cofix F α)) :=
  Quot.lift (fun x => appendFun id (Quot.mk Mcongr) <$$> abs (M.dest q.p x))
    (by
      rintro x y ⟨r, pr, rxy⟩
      dsimp
      have : ∀ x y, r x y → Mcongr x y := by
        intro x y h
        exact ⟨r, pr, h⟩
      rw [← Quot.factor_mk_eq _ _ this]
      dsimp
      conv =>
        lhs
        rw [append_fun_comp_id, comp_map, ← abs_map, pr rxy, abs_map, ← comp_map, ←
          append_fun_comp_id])
#align mvqpf.cofix.dest MvQPF.Cofix.dest

/-- Abstraction function for `cofix F α` -/
def Cofix.abs {α} : q.p.M α → Cofix F α :=
  Quot.mk _
#align mvqpf.cofix.abs MvQPF.Cofix.abs

/-- Representation function for `cofix F α` -/
def Cofix.repr {α} : Cofix F α → q.p.M α :=
  M.corec _ <| repr ∘ Cofix.dest
#align mvqpf.cofix.repr MvQPF.Cofix.repr

/-- Corecursor for `cofix F` -/
def Cofix.corec'₁ {α : TypeVec n} {β : Type u} (g : ∀ {X}, (β → X) → F (α.append1 X)) (x : β) :
    Cofix F α :=
  Cofix.corec (fun x => g id) x
#align mvqpf.cofix.corec'₁ MvQPF.Cofix.corec'₁

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/-- More flexible corecursor for `cofix F`. Allows the return of a fully formed
value instead of making a recursive call -/
def Cofix.corec' {α : TypeVec n} {β : Type u} (g : β → F (α.append1 (Sum (Cofix F α) β))) (x : β) :
    Cofix F α :=
  let f : (α ::: Cofix F α) ⟹ (α ::: Sum (Cofix F α) β) := id ::: Sum.inl
  Cofix.corec (Sum.elim (MvFunctor.map f ∘ Cofix.dest) g) (Sum.inr x : Sum (Cofix F α) β)
#align mvqpf.cofix.corec' MvQPF.Cofix.corec'

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/-- Corecursor for `cofix F`. The shape allows recursive calls to
look like recursive calls. -/
def Cofix.corec₁ {α : TypeVec n} {β : Type u}
    (g : ∀ {X}, (Cofix F α → X) → (β → X) → β → F (α ::: X)) (x : β) : Cofix F α :=
  Cofix.corec' (fun x => g Sum.inl Sum.inr x) x
#align mvqpf.cofix.corec₁ MvQPF.Cofix.corec₁

theorem Cofix.dest_corec {α : TypeVec n} {β : Type u} (g : β → F (α.append1 β)) (x : β) :
    Cofix.dest (Cofix.corec g x) = appendFun id (Cofix.corec g) <$$> g x :=
  by
  conv =>
    lhs
    rw [cofix.dest, cofix.corec];
  dsimp
  rw [corecF_eq, abs_map, abs_repr, ← comp_map, ← append_fun_comp]; rfl
#align mvqpf.cofix.dest_corec MvQPF.Cofix.dest_corec

/-- constructor for `cofix F` -/
def Cofix.mk {α : TypeVec n} : F (α.append1 <| Cofix F α) → Cofix F α :=
  Cofix.corec fun x => (appendFun id fun i : Cofix F α => Cofix.dest.{u} i) <$$> x
#align mvqpf.cofix.mk MvQPF.Cofix.mk

/-!
## Bisimulation principles for `cofix F`

The following theorems are bisimulation principles. The general idea
is to use a bisimulation relation to prove the equality between
specific values of type `cofix F α`.

A bisimulation relation `R` for values `x y : cofix F α`:

 * holds for `x y`: `R x y`
 * for any values `x y` that satisfy `R`, their root has the same shape
   and their children can be paired in such a way that they satisfy `R`.

-/

private theorem cofix.bisim_aux {α : TypeVec n} (r : Cofix F α → Cofix F α → Prop) (h' : ∀ x, r x x)
    (h :
      ∀ x y,
        r x y →
          appendFun id (Quot.mk r) <$$> Cofix.dest x = appendFun id (Quot.mk r) <$$> Cofix.dest y) :
    ∀ x y, r x y → x = y := by
  intro x
  apply Quot.inductionOn x
  clear x
  intro x y
  apply Quot.inductionOn y
  clear y
  intro y rxy
  apply Quot.sound
  let r' x y := r (Quot.mk _ x) (Quot.mk _ y)
  have : is_precongr r' := by
    intro a b r'ab
    have h₀ :
      append_fun id (Quot.mk r ∘ Quot.mk Mcongr) <$$> abs (M.dest q.P a) =
        append_fun id (Quot.mk r ∘ Quot.mk Mcongr) <$$> abs (M.dest q.P b) :=
      by rw [append_fun_comp_id, comp_map, comp_map] <;> exact h _ _ r'ab
    have h₁ : ∀ u v : q.P.M α, Mcongr u v → Quot.mk r' u = Quot.mk r' v :=
      by
      intro u v cuv
      apply Quot.sound
      dsimp [r']
      rw [Quot.sound cuv]
      apply h'
    let f : Quot r → Quot r' :=
      Quot.lift (Quot.lift (Quot.mk r') h₁)
        (by
          intro c; apply Quot.inductionOn c; clear c
          intro c d; apply Quot.inductionOn d; clear d
          intro d rcd; apply Quot.sound; apply rcd)
    have : f ∘ Quot.mk r ∘ Quot.mk Mcongr = Quot.mk r' := rfl
    rw [← this, append_fun_comp_id, q.P.comp_map, q.P.comp_map, abs_map, abs_map, abs_map, abs_map,
      h₀]
  refine' ⟨r', this, rxy⟩
#align mvqpf.cofix.bisim_aux mvqpf.cofix.bisim_aux

/-- Bisimulation principle using `map` and `quot.mk` to match and relate children of two trees. -/
theorem Cofix.bisim_rel {α : TypeVec n} (r : Cofix F α → Cofix F α → Prop)
    (h :
      ∀ x y,
        r x y →
          appendFun id (Quot.mk r) <$$> Cofix.dest x = appendFun id (Quot.mk r) <$$> Cofix.dest y) :
    ∀ x y, r x y → x = y := by
  let r' (x y) := x = y ∨ r x y
  intro x y rxy
  apply cofix.bisim_aux r'
  · intro x
    left
    rfl
  · intro x y r'xy
    cases r'xy
    · rw [r'xy]
    have : ∀ x y, r x y → r' x y := fun x y h => Or.inr h
    rw [← Quot.factor_mk_eq _ _ this]
    dsimp
    rw [append_fun_comp_id, append_fun_comp_id]
    rw [@comp_map _ _ _ q _ _ _ (append_fun id (Quot.mk r)),
      @comp_map _ _ _ q _ _ _ (append_fun id (Quot.mk r))]
    rw [h _ _ r'xy]
  right; exact rxy
#align mvqpf.cofix.bisim_rel MvQPF.Cofix.bisim_rel

/-- Bisimulation principle using `liftr` to match and relate children of two trees. -/
theorem Cofix.bisim {α : TypeVec n} (r : Cofix F α → Cofix F α → Prop)
    (h : ∀ x y, r x y → LiftR (RelLast α r) (Cofix.dest x) (Cofix.dest y)) : ∀ x y, r x y → x = y :=
  by
  apply cofix.bisim_rel
  intro x y rxy
  rcases(liftr_iff (rel_last α r) _ _).mp (h x y rxy) with ⟨a, f₀, f₁, dxeq, dyeq, h'⟩
  rw [dxeq, dyeq, ← abs_map, ← abs_map, MvPFunctor.map_eq, MvPFunctor.map_eq]
  rw [← split_drop_fun_last_fun f₀, ← split_drop_fun_last_fun f₁]
  rw [append_fun_comp_split_fun, append_fun_comp_split_fun]
  rw [id_comp, id_comp]
  congr 2 with (i j); cases' i with _ i <;> dsimp
  · apply Quot.sound
    apply h' _ j
  · change f₀ _ j = f₁ _ j
    apply h' _ j
#align mvqpf.cofix.bisim MvQPF.Cofix.bisim

open MvFunctor

/-- Bisimulation principle using `liftr'` to match and relate children of two trees. -/
theorem Cofix.bisim₂ {α : TypeVec n} (r : Cofix F α → Cofix F α → Prop)
    (h : ∀ x y, r x y → LiftR' (RelLast' α r) (Cofix.dest x) (Cofix.dest y)) :
    ∀ x y, r x y → x = y :=
  Cofix.bisim _ <| by intros <;> rw [← liftr_last_rel_iff] <;> apply h <;> assumption
#align mvqpf.cofix.bisim₂ MvQPF.Cofix.bisim₂

/-- Bisimulation principle the values `⟨a,f⟩` of the polynomial functor representing
`cofix F α` as well as an invariant `Q : β → Prop` and a state `β` generating the
left-hand side and right-hand side of the equality through functions `u v : β → cofix F α` -/
theorem Cofix.bisim' {α : TypeVec n} {β : Type _} (Q : β → Prop) (u v : β → Cofix F α)
    (h :
      ∀ x,
        Q x →
          ∃ a f' f₀ f₁,
            Cofix.dest (u x) = abs ⟨a, q.p.appendContents f' f₀⟩ ∧
              Cofix.dest (v x) = abs ⟨a, q.p.appendContents f' f₁⟩ ∧
                ∀ i, ∃ x', Q x' ∧ f₀ i = u x' ∧ f₁ i = v x') :
    ∀ x, Q x → u x = v x := fun x Qx =>
  let R := fun w z : Cofix F α => ∃ x', Q x' ∧ w = u x' ∧ z = v x'
  Cofix.bisim R
    (fun x y ⟨x', Qx', xeq, yeq⟩ =>
      by
      rcases h x' Qx' with ⟨a, f', f₀, f₁, ux'eq, vx'eq, h'⟩
      rw [liftr_iff]
      refine'
        ⟨a, q.P.append_contents f' f₀, q.P.append_contents f' f₁, xeq.symm ▸ ux'eq,
          yeq.symm ▸ vx'eq, _⟩
      intro i; cases i
      · apply h'
      · intro j
        apply Eq.refl)
    _ _ ⟨x, Qx, rfl, rfl⟩
#align mvqpf.cofix.bisim' MvQPF.Cofix.bisim'

theorem Cofix.mk_dest {α : TypeVec n} (x : Cofix F α) : Cofix.mk (Cofix.dest x) = x :=
  by
  apply cofix.bisim_rel (fun x y : cofix F α => x = cofix.mk (cofix.dest y)) _ _ _ rfl; dsimp
  intro x y h; rw [h]
  conv =>
    lhs
    congr
    skip
    rw [cofix.mk]
    rw [cofix.dest_corec]
  rw [← comp_map, ← append_fun_comp, id_comp]
  rw [← comp_map, ← append_fun_comp, id_comp, ← cofix.mk]
  congr 2 with u; apply Quot.sound; rfl
#align mvqpf.cofix.mk_dest MvQPF.Cofix.mk_dest

theorem Cofix.dest_mk {α : TypeVec n} (x : F (α.append1 <| Cofix F α)) :
    Cofix.dest (Cofix.mk x) = x :=
  by
  have : cofix.mk ∘ cofix.dest = @_root_.id (cofix F α) := funext cofix.mk_dest
  rw [cofix.mk, cofix.dest_corec, ← comp_map, ← cofix.mk, ← append_fun_comp, this, id_comp,
    append_fun_id_id, MvFunctor.id_map]
#align mvqpf.cofix.dest_mk MvQPF.Cofix.dest_mk

theorem Cofix.ext {α : TypeVec n} (x y : Cofix F α) (h : x.dest = y.dest) : x = y := by
  rw [← cofix.mk_dest x, h, cofix.mk_dest]
#align mvqpf.cofix.ext MvQPF.Cofix.ext

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem Cofix.ext_mk {α : TypeVec n} (x y : F (α ::: Cofix F α)) (h : Cofix.mk x = Cofix.mk y) :
    x = y := by rw [← cofix.dest_mk x, h, cofix.dest_mk]
#align mvqpf.cofix.ext_mk MvQPF.Cofix.ext_mk

/-!
`liftr_map`, `liftr_map_last` and `liftr_map_last'` are useful for reasoning about
the induction step in bisimulation proofs.
-/

section LiftrMap

omit q

theorem liftr_map {α β : TypeVec n} {F' : TypeVec n → Type u} [MvFunctor F'] [LawfulMvFunctor F']
    (R : β ⊗ β ⟹ repeat n Prop) (x : F' α) (f g : α ⟹ β) (h : α ⟹ Subtype_ R)
    (hh : subtypeVal _ ⊚ h = (f ⊗' g) ⊚ prod.diag) : LiftR' R (f <$$> x) (g <$$> x) :=
  by
  rw [liftr_def]
  exists h <$$> x
  rw [MvFunctor.map_map, comp_assoc, hh, ← comp_assoc, fst_prod_mk, comp_assoc, fst_diag]
  rw [MvFunctor.map_map, comp_assoc, hh, ← comp_assoc, snd_prod_mk, comp_assoc, snd_diag]
  dsimp [liftr']; constructor <;> rfl
#align mvqpf.liftr_map MvQPF.liftr_map

open Function

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem liftr_map_last [LawfulMvFunctor F] {α : TypeVec n} {ι ι'} (R : ι' → ι' → Prop)
    (x : F (α ::: ι)) (f g : ι → ι') (hh : ∀ x : ι, R (f x) (g x)) :
    LiftR' (RelLast' _ R) ((id ::: f) <$$> x) ((id ::: g) <$$> x) :=
  let h : ι → { x : ι' × ι' // uncurry R x } := fun x => ⟨(f x, g x), hh x⟩
  let b : (α ::: ι) ⟹ _ := @diagSub n α ::: h
  let c :
    (Subtype_ α.repeatEq ::: { x // uncurry R x }) ⟹
      ((fun i : Fin2 n => { x // ofRepeat (α.RelLast' R i.fs x) }) ::: Subtype (uncurry R)) :=
    ofSubtype _ ::: id
  have hh :
    subtypeVal _ ⊚ toSubtype _ ⊚ fromAppend1DropLast ⊚ c ⊚ b =
      ((id ::: f) ⊗' (id ::: g)) ⊚ prod.diag :=
    by
    dsimp [c, b]
    apply eq_of_drop_last_eq
    · dsimp
      simp only [prod_map_id, drop_fun_prod, drop_fun_append_fun, drop_fun_diag, id_comp,
        drop_fun_to_subtype]
      erw [to_subtype_of_subtype_assoc, id_comp]
      clear * -
      ext (i x) : 2
      induction i
      rfl
      apply i_ih
    simp only [h, last_fun_from_append1_drop_last, last_fun_to_subtype, last_fun_append_fun,
      last_fun_subtype_val, comp.left_id, last_fun_comp, last_fun_prod]
    dsimp
    ext1
    rfl
  liftr_map _ _ _ _ (toSubtype _ ⊚ fromAppend1DropLast ⊚ c ⊚ b) hh
#align mvqpf.liftr_map_last MvQPF.liftr_map_last

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem liftr_map_last' [LawfulMvFunctor F] {α : TypeVec n} {ι} (R : ι → ι → Prop) (x : F (α ::: ι))
    (f : ι → ι) (hh : ∀ x : ι, R (f x) x) : LiftR' (RelLast' _ R) ((id ::: f) <$$> x) x :=
  by
  have := liftr_map_last R x f id hh
  rwa [append_fun_id_id, MvFunctor.id_map] at this
#align mvqpf.liftr_map_last' MvQPF.liftr_map_last'

end LiftrMap

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem Cofix.abs_repr {α} (x : Cofix F α) : Quot.mk _ (Cofix.repr x) = x :=
  by
  let R := fun x y : cofix F α => cofix.abs (cofix.repr y) = x
  refine' cofix.bisim₂ R _ _ _ rfl
  clear x; rintro x y h; dsimp [R] at h; subst h
  dsimp [cofix.dest, cofix.abs]
  induction y using Quot.ind
  simp only [cofix.repr, M.dest_corec, abs_map, abs_repr]
  conv =>
    congr
    skip
    rw [cofix.dest]
  dsimp; rw [MvFunctor.map_map, MvFunctor.map_map, ← append_fun_comp_id, ← append_fun_comp_id]
  let f : (α ::: (P F).M α) ⟹ subtype_ (α.rel_last' R) :=
    split_fun diag_sub fun x => ⟨(cofix.abs (cofix.abs x).repr, cofix.abs x), _⟩
  refine' liftr_map _ _ _ _ f _
  · simp only [← append_prod_append_fun, prod_map_id]
    apply eq_of_drop_last_eq
    · dsimp
      simp only [drop_fun_diag]
      erw [subtype_val_diag_sub]
    ext1
    simp only [cofix.abs, Prod.mk.inj_iff, Prod_map, Function.comp_apply, last_fun_append_fun,
      last_fun_subtype_val, last_fun_comp, last_fun_split_fun]
    dsimp [drop_fun_rel_last, last_fun, prod.diag]
    constructor <;> rfl
  dsimp [rel_last', split_fun, Function.uncurry, R]
  rfl
#align mvqpf.cofix.abs_repr MvQPF.Cofix.abs_repr

section Tactic

/- ./././Mathport/Syntax/Translate/Tactic/Mathlib/Core.lean:38:34: unsupported: setup_tactic_parser -/
open Tactic

omit q

/-- tactic for proof by bisimulation -/
unsafe def mv_bisim (e : parse texpr) (ids : parse with_ident_list) : tactic Unit := do
  let e ← to_expr e
  let expr.pi n bi d b ←
    retrieve do
        generalize e
        target
  let q(@Eq $(t) $(l) $(r)) ← pure b
  let x ← mk_local_def `n d
  let v₀ ← mk_local_def `a t
  let v₁ ← mk_local_def `b t
  let x₀ ← mk_app `` Eq [v₀, l.instantiate_var x]
  let x₁ ← mk_app `` Eq [v₁, r.instantiate_var x]
  let xx ← mk_app `` And [x₀, x₁]
  let ex ← lambdas [x] xx
  let ex ← mk_app `` Exists [ex] >>= lambdas [v₀, v₁]
  let R ← pose `R none ex
  refine ``(Cofix.bisim₂ $(R) _ _ _ ⟨_, rfl, rfl⟩)
  let f (a b : Name) : Name := if a = `_ then b else a
  let ids := (ids ++ List.replicate 5 `_).zipWith f [`a, `b, `x, `Ha, `Hb]
  let (ids₀, w :: ids₁) ← pure <| List.splitAt 2 ids
  intro_lst ids₀
  let h ← intro1
  let [(_, [w, h], _)] ← cases_core h [w]
  cases h ids₁
  pure ()
#align mvqpf.mv_bisim mvqpf.mv_bisim

run_cmd
  add_interactive [`` mv_bisim]

end Tactic

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem corec_roll {α : TypeVec n} {X Y} {x₀ : X} (f : X → Y) (g : Y → F (α ::: X)) :
    Cofix.corec (g ∘ f) x₀ = Cofix.corec (MvFunctor.map (id ::: f) ∘ g) (f x₀) :=
  by
  mv_bisim x₀
  rw [Ha, Hb, cofix.dest_corec, cofix.dest_corec]
  rw [MvFunctor.map_map, ← append_fun_comp_id]
  refine' liftr_map_last _ _ _ _ _
  intro a; refine' ⟨a, rfl, rfl⟩
#align mvqpf.corec_roll MvQPF.corec_roll

theorem Cofix.dest_corec' {α : TypeVec n} {β : Type u} (g : β → F (α.append1 (Sum (Cofix F α) β)))
    (x : β) :
    Cofix.dest (Cofix.corec' g x) = appendFun id (Sum.elim id (Cofix.corec' g)) <$$> g x :=
  by
  rw [cofix.corec', cofix.dest_corec]; dsimp
  congr with (i | i) <;> rw [corec_roll] <;> dsimp [cofix.corec']
  · mv_bisim i
    rw [Ha, Hb, cofix.dest_corec]
    dsimp [(· ∘ ·)]
    repeat' rw [MvFunctor.map_map, ← append_fun_comp_id]
    apply liftr_map_last'
    dsimp [(· ∘ ·), R]
    intros
    exact ⟨_, rfl, rfl⟩
  · congr with y
    erw [append_fun_id_id]
    simp [MvFunctor.id_map]
#align mvqpf.cofix.dest_corec' MvQPF.Cofix.dest_corec'

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem Cofix.dest_corec₁ {α : TypeVec n} {β : Type u}
    (g : ∀ {X}, (Cofix F α → X) → (β → X) → β → F (α.append1 X)) (x : β)
    (h :
      ∀ (X Y) (f : Cofix F α → X) (f' : β → X) (k : X → Y),
        g (k ∘ f) (k ∘ f') x = (id ::: k) <$$> g f f' x) :
    Cofix.dest (Cofix.corec₁ (@g) x) = g id (Cofix.corec₁ @g) x := by
  rw [cofix.corec₁, cofix.dest_corec', ← h] <;> rfl
#align mvqpf.cofix.dest_corec₁ MvQPF.Cofix.dest_corec₁

instance mvqpfCofix : MvQPF (Cofix F) where
  p := q.p.mp
  abs α := Quot.mk Mcongr
  repr α := Cofix.repr
  abs_repr α := Cofix.abs_repr
  abs_map α β g x := rfl
#align mvqpf.mvqpf_cofix MvQPF.mvqpfCofix

end MvQPF


/- This file includes the proofs of the axioms for the encapsulation operator.-/
import .iff_lemmas

open mcrl2

variable {α : Type}
variable [comm_semigroup_with_zero α]

lemma transition.encap_deadlock (A z) (a : α):
transition (encap A (δ : mcrl2 α)) a z ↔ transition (δ : mcrl2 α) a z :=
begin
  simp [transition.encap_iff, transition.deadlock_iff],
end

lemma transition.encap_success (a₁ : α) (A) (h : a₁ ∉ A) (z a₂) :
transition (encap A (atom a₁)) a₂ z ↔ transition (atom a₁) a₂ z :=
begin
  simp [transition.encap_iff, transition.atom_iff, h, ←and_assoc, h],
  intros _ _ h,
  rw h,
  assumption
end

lemma transition.encap_fail (a₁ : α) (A) (h : a₁ ∈ A) (z a₂) :
transition (encap A (atom a₁)) a₂ z ↔ transition δ a₂ z :=
begin
  simp [transition.deadlock_iff, transition.encap_iff, transition.atom_iff, h],
  intros _ _ _ _ h,
  rw h,
  assumption
end

lemma transition.encap_alt (x : mcrl2 α) (y A z) (a : α) :
transition (encap A (x + y)) a z ↔ transition ((encap A x) + (encap A y)) a z:=
begin
  simp [transition.encap_iff, transition.alt_iff, ←exists_and_distrib_right, and_or_distrib_left, or_and_distrib_right, exists_or_distrib]
end

/- encap_seq (∂_H(x ⬝ y) = ∂_H(x) ⬝ ∂_H(y)) needs to be proved via bisimulation. -/


/-
Copyright (c) 2019 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import category_theory.concrete_category.bundled
import category_theory.discrete_category
import category_theory.types
import category_theory.bicategory.strict

/-!
# Category of categories

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

This file contains the definition of the category `Cat` of all categories.
In this category objects are categories and
morphisms are functors between these categories.

## Implementation notes

Though `Cat` is not a concrete category, we use `bundled` to define
its carrier type.
-/

universes v u

namespace category_theory

/-- Category of categories. -/
@[nolint check_univs] -- intended to be used with explicit universe parameters
def Cat := bundled category.{v u}

namespace Cat

instance : inhabited Cat := ⟨⟨Type u, category_theory.types⟩⟩

instance : has_coe_to_sort Cat (Type u) := ⟨bundled.α⟩

instance str (C : Cat.{v u}) : category.{v u} C := C.str

/-- Construct a bundled `Cat` from the underlying type and the typeclass. -/
def of (C : Type u) [category.{v} C] : Cat.{v u} := bundled.of C

/-- Bicategory structure on `Cat` -/
instance bicategory : bicategory.{(max v u) (max v u)} Cat.{v u} :=
{ hom := λ C D, C ⥤ D,
  id := λ C, 𝟭 C,
  comp := λ C D E F G, F ⋙ G,
  hom_category := λ C D, functor.category C D,
  whisker_left := λ C D E F G H η, whisker_left F η,
  whisker_right := λ C D E F G η H, whisker_right η H,
  associator := λ A B C D, functor.associator,
  left_unitor :=  λ A B, functor.left_unitor,
  right_unitor := λ A B, functor.right_unitor,
  pentagon' := λ A B C D E, functor.pentagon,
  triangle' := λ A B C, functor.triangle }

/-- `Cat` is a strict bicategory. -/
instance bicategory.strict : bicategory.strict Cat.{v u} :=
{ id_comp' := λ C D F, by cases F; refl,
  comp_id' := λ C D F, by cases F; refl,
  assoc' := by intros; refl }

/-- Category structure on `Cat` -/
instance category : large_category.{max v u} Cat.{v u} := strict_bicategory.category Cat.{v u}

@[simp]
lemma id_map {C : Cat} {X Y : C} (f : X ⟶ Y) : (𝟙 C : C ⥤ C).map f = f :=
functor.id_map f

@[simp]
lemma comp_obj {C D E : Cat} (F : C ⟶ D) (G : D ⟶ E) (X : C) :
  (F ≫ G).obj X = G.obj (F.obj X) :=
functor.comp_obj F G X

@[simp]
lemma comp_map {C D E : Cat} (F : C ⟶ D) (G : D ⟶ E) {X Y : C} (f : X ⟶ Y) :
  (F ≫ G).map f = G.map (F.map f) :=
functor.comp_map F G f

/-- Functor that gets the set of objects of a category. It is not
called `forget`, because it is not a faithful functor. -/
def objects : Cat.{v u} ⥤ Type u :=
{ obj := λ C, C,
  map := λ C D F, F.obj }

section
local attribute [simp] eq_to_hom_map

/-- Any isomorphism in `Cat` induces an equivalence of the underlying categories. -/
def equiv_of_iso {C D : Cat} (γ : C ≅ D) : C ≌ D :=
{ functor := γ.hom,
  inverse := γ.inv,
  unit_iso := eq_to_iso $ eq.symm γ.hom_inv_id,
  counit_iso := eq_to_iso γ.inv_hom_id }

end

end Cat

/--
Embedding `Type` into `Cat` as discrete categories.

This ought to be modelled as a 2-functor!
-/
@[simps]
def Type_to_Cat : Type u ⥤ Cat :=
{ obj := λ X, Cat.of (discrete X),
  map := λ X Y f, discrete.functor (discrete.mk ∘ f),
  map_id' := λ X, begin apply functor.ext, tidy, end,
  map_comp' := λ X Y Z f g, begin apply functor.ext, tidy, end }

instance : faithful Type_to_Cat.{u} :=
{ map_injective' := λ X Y f g h, funext (λ x, congr_arg discrete.as (functor.congr_obj h ⟨x⟩)), }

instance : full Type_to_Cat.{u} :=
{ preimage := λ X Y F, discrete.as ∘ F.obj ∘ discrete.mk,
  witness' :=
  begin
    intros X Y F,
    apply functor.ext,
    { intros x y f, dsimp, ext, },
    { rintros ⟨x⟩, ext, refl, }
  end }

end category_theory