open classical

variables (α : Type*) (p : α → Prop)

example (h : ¬ ∀ x, ¬ p x) : ∃ x, p x :=
by_contradiction
  (assume h1 : ¬ ∃ x, p x,
    have h2 : ∀ x, ¬ p x, from
      assume x,
      assume h3 : p x,
      have h4 : ∃ x, p x, from ⟨x, h3⟩,
      show false, from h1 h4,
    show false, from h h2)


/-
Copyright (c) 2021 OpenAI. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kunhao Zheng, Stanislas Polu, David Renshaw, OpenAI GPT-f
-/
import mathzoo.imports.miniF2F

open_locale nat rat real big_operators topological_space

theorem mathd_algebra_129
  (a : ℝ)
  (h₀ : a ≠ 0)
  (h₁ : 8⁻¹ / 4⁻¹ - a⁻¹ = 1) :
  a = -2 :=
begin
  field_simp at h₁,
  linarith,
end


import data.real.basic

#check lt_trichotomy

-- BEGIN
example {x : ℝ} (h : x ≠ 0) : x < 0 ∨ x > 0 :=
begin
  cases lt_trichotomy x 0 with xlt xle,
    left,
    { sorry,},
    right,
    sorry,
end
-- END


/-
Copyright (c) 2021 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov, Mario Carneiro, Sean Leather
-/
import data.finset.card
import order.hom.basic

/-!
# Finite sets in `option α`

In this file we define

* `option.to_finset`: construct an empty or singleton `finset α` from an `option α`;
* `finset.insert_none`: given `s : finset α`, lift it to a finset on `option α` using `option.some`
  and then insert `option.none`;
* `finset.erase_none`: given `s : finset (option α)`, returns `t : finset α` such that
  `x ∈ t ↔ some x ∈ s`.

Then we prove some basic lemmas about these definitions.

## Tags

finset, option
-/

variables {α β : Type*}

open function

namespace option

/-- Construct an empty or singleton finset from an `option` -/
def to_finset (o : option α) : finset α := o.elim ∅ singleton

@[simp] theorem to_finset_none : none.to_finset = (∅ : finset α) := rfl

@[simp] theorem to_finset_some {a : α} : (some a).to_finset = {a} := rfl

@[simp] theorem mem_to_finset {a : α} {o : option α} : a ∈ o.to_finset ↔ a ∈ o :=
by cases o; simp [eq_comm]

theorem card_to_finset (o : option α) : o.to_finset.card = o.elim 0 1 :=
by cases o; refl

end option

namespace finset

/-- Given a finset on `α`, lift it to being a finset on `option α`
using `option.some` and then insert `option.none`. -/
def insert_none : finset α ↪o finset (option α) :=
order_embedding.of_map_le_iff (λ s, cons none (s.map embedding.some) $ by simp) $ λ s t,
  cons_subset_cons.trans map_subset_map

/-⟨none ::ₘ s.1.map some, multiset.nodup_cons.2
  ⟨by simp, s.nodup.map $ λ a b, option.some.inj⟩⟩-/

@[simp] theorem mem_insert_none {s : finset α} : ∀ {o : option α},
  o ∈ s.insert_none ↔ ∀ a ∈ o, a ∈ s
| none     := iff_of_true (multiset.mem_cons_self _ _) (λ a h, by cases h)
| (some a) := multiset.mem_cons.trans $ by simp; refl

theorem some_mem_insert_none {s : finset α} {a : α} :
  some a ∈ s.insert_none ↔ a ∈ s := by simp

@[simp] theorem card_insert_none (s : finset α) : s.insert_none.card = s.card + 1 :=
by simp [insert_none]

/-- Given `s : finset (option α)`, `s.erase_none : finset α` is the set of `x : α` such that
`some x ∈ s`. -/
def erase_none : finset (option α) →o finset α :=
(finset.map_embedding (equiv.option_is_some_equiv α).to_embedding).to_order_hom.comp
  ⟨finset.subtype _, subtype_mono⟩

@[simp] lemma mem_erase_none {s : finset (option α)} {x : α} :
  x ∈ s.erase_none ↔ some x ∈ s :=
by simp [erase_none]

lemma erase_none_eq_bUnion [decidable_eq α] (s : finset (option α)) :
  s.erase_none = s.bUnion option.to_finset :=
by { ext, simp }

@[simp] lemma erase_none_map_some (s : finset α) : (s.map embedding.some).erase_none = s :=
by { ext, simp }

@[simp] lemma erase_none_image_some [decidable_eq (option α)] (s : finset α) :
  (s.image some).erase_none = s :=
by simpa only [map_eq_image] using erase_none_map_some s

@[simp] lemma coe_erase_none (s : finset (option α)) :
  (s.erase_none : set α) = some ⁻¹' s :=
set.ext $ λ x, mem_erase_none

@[simp] lemma erase_none_union [decidable_eq (option α)] [decidable_eq α]
  (s t : finset (option α)) :
  (s ∪ t).erase_none = s.erase_none ∪ t.erase_none :=
by { ext, simp }

@[simp] lemma erase_none_inter [decidable_eq (option α)] [decidable_eq α]
  (s t : finset (option α)) :
  (s ∩ t).erase_none = s.erase_none ∩ t.erase_none :=
by { ext, simp }

@[simp] lemma erase_none_empty : (∅ : finset (option α)).erase_none = ∅ := by { ext, simp }

@[simp] lemma erase_none_none : ({none} : finset (option α)).erase_none = ∅ := by { ext, simp }

@[simp] lemma image_some_erase_none [decidable_eq (option α)] (s : finset (option α)) :
  s.erase_none.image some = s.erase none :=
by ext (_|x); simp

@[simp] lemma map_some_erase_none [decidable_eq (option α)] (s : finset (option α)) :
  s.erase_none.map embedding.some = s.erase none :=
by rw [map_eq_image, embedding.some_apply, image_some_erase_none]

@[simp] lemma insert_none_erase_none [decidable_eq (option α)] (s : finset (option α)) :
  insert_none (erase_none s) = insert none s :=
by ext (_|x); simp

@[simp] lemma erase_none_insert_none (s : finset α) : erase_none (insert_none s) = s :=
by { ext, simp }

end finset


/-
Copyright (c) 2018 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Jens Wagemaker

Theory of unique factorization domains.

@TODO: setup the complete lattice structure on `factor_set`.
-/
import ring_theory.associated algebra.gcd_domain

variables {α : Type*}
local infix ` ~ᵤ ` : 50 := associated

/-- Unique factorization domains.

In a unique factorization domain each element (except zero) is uniquely represented as a multiset
of irreducible factors. Uniqueness is only up to associated elements.
-/
class unique_factorization_domain (α : Type*) [integral_domain α] :=
(factors : α → multiset α)
(factors_prod : ∀{a : α}, a ≠ 0 → (factors a).prod ~ᵤ a)
(irreducible_factors : ∀{a : α}, a ≠ 0 →  ∀x∈factors a, irreducible x)
(unique : ∀{f g : multiset α},
  (∀x∈f, irreducible x) → (∀x∈g, irreducible x) → f.prod ~ᵤ g.prod → multiset.rel associated f g)

namespace associates
open unique_factorization_domain associated lattice
variables [integral_domain α] [unique_factorization_domain α] [decidable_eq (associates α)]

/-- `factor_set α` representation elements of unique factorization domain as multisets.

`multiset α` produced by `factors` are only unique up to associated elements, while the multisets in
`factor_set α` are unqiue by equality and restricted to irreducible elements. This gives us a
representation of each element as a unique multisets (or the added ⊤ for 0), which has a complete
lattice struture. Infimum is the greatest common divisor and supremum is the least common multiple.
-/
@[reducible] def {u} factor_set (α : Type u) [integral_domain α] [unique_factorization_domain α] :
  Type u :=
with_top (multiset { a : associates α // irreducible a })

local attribute [instance] associated.setoid

theorem unique' {p q : multiset (associates α)} :
  (∀a∈p, irreducible a) → (∀a∈q, irreducible a) → p.prod = q.prod → p = q :=
begin
  apply multiset.induction_on_multiset_quot p,
  apply multiset.induction_on_multiset_quot q,
  assume s t hs ht eq,
  refine multiset.map_mk_eq_map_mk_of_rel (unique_factorization_domain.unique _ _ _),
  { exact assume a ha, ((irreducible_mk_iff _).1 $ hs _ $ multiset.mem_map_of_mem _ ha) },
  { exact assume a ha, ((irreducible_mk_iff _).1 $ ht _ $ multiset.mem_map_of_mem _ ha) },
  simpa [quot_mk_eq_mk, prod_mk, mk_eq_mk_iff_associated] using eq
end

private theorem forall_map_mk_factors_irreducible (x : α) (hx : x ≠ 0) :
  ∀(a : associates α), a ∈ multiset.map associates.mk (factors x) → irreducible a :=
begin
  assume a ha,
  rcases multiset.mem_map.1 ha with ⟨c, hc, rfl⟩,
  exact (irreducible_mk_iff c).2 (irreducible_factors hx _ hc)
end

theorem prod_le_prod_iff_le {p q : multiset (associates α)}
  (hp : ∀a∈p, irreducible a) (hq : ∀a∈q, irreducible a) :
  p.prod ≤ q.prod ↔ p ≤ q :=
iff.intro
  begin
    rintros ⟨⟨c⟩, eq⟩,
    have : c ≠ 0, from (mt mk_eq_zero_iff_eq_zero.2 $
      assume (hc : quot.mk setoid.r c = 0),
      have (0 : associates α) ∈ q, from prod_eq_zero_iff.1 $ eq ▸ hc.symm ▸ mul_zero _,
      not_irreducible_zero ((irreducible_mk_iff 0).1 $ hq _ this)),
    have : associates.mk (factors c).prod = quot.mk setoid.r c,
      from mk_eq_mk_iff_associated.2 (factors_prod this),

    refine le_iff_exists_add.2 ⟨(factors c).map associates.mk, unique' hq _ _⟩,
    { assume x hx,
      rcases multiset.mem_add.1 hx with h | h,
      exact hp x h,
      exact forall_map_mk_factors_irreducible c ‹c ≠ 0› _ h },
    { simp [multiset.prod_add, prod_mk, *] at * }
  end
  prod_le_prod

@[simp] theorem factor_set.coe_add {a b : multiset { a : associates α // irreducible a }} :
  (↑a + ↑b : factor_set α) = ↑(a + b) :=
with_top.coe_add

lemma factor_set.sup_add_inf_eq_add : ∀(a b : factor_set α), a ⊔ b + a ⊓ b = a + b
| none     b        := show ⊤ ⊔ b + ⊤ ⊓ b = ⊤ + b, by simp
| a        none     := show a ⊔ ⊤ + a ⊓ ⊤ = a + ⊤, by simp
| (some a) (some b) := show (a : factor_set α) ⊔ b + a ⊓ b = a + b, from
  begin
    rw [← with_top.coe_sup, ← with_top.coe_inf, ← with_top.coe_add, ← with_top.coe_add,
      with_top.coe_eq_coe],
    exact multiset.union_add_inter _ _
  end

def factors' (a : α) (ha : a ≠ 0) : multiset { a : associates α // irreducible a } :=
(factors a).pmap (λa ha, ⟨associates.mk a, (irreducible_mk_iff _).2 ha⟩)
  (irreducible_factors $ ha)

@[simp] theorem map_subtype_val_factors' {a : α} (ha : a ≠ 0) :
  (factors' a ha).map subtype.val = (factors a).map associates.mk :=
by simp [factors', multiset.map_pmap, multiset.pmap_eq_map]

theorem factors'_cong {a b : α} (ha : a ≠ 0) (hb : b ≠ 0) (h : a ~ᵤ b) :
  factors' a ha = factors' b hb :=
have multiset.rel associated (factors a) (factors b), from
  unique (irreducible_factors ha) (irreducible_factors hb)
    ((factors_prod ha).trans $ h.trans $ (factors_prod hb).symm),
by simpa [(multiset.map_eq_map subtype.val_injective).symm, rel_associated_iff_map_eq_map.symm]

def factors (a : associates α) : factor_set α :=
begin
  refine (if h : a = 0 then ⊤ else
    quotient.hrec_on a (λx h, some $ factors' x (mt mk_eq_zero_iff_eq_zero.2 h)) _ h),

  assume a b hab,
  apply function.hfunext,
  { have : a ~ᵤ 0 ↔ b ~ᵤ 0, from
      iff.intro (assume ha0, hab.symm.trans ha0) (assume hb0, hab.trans hb0),
    simp [quotient_mk_eq_mk, mk_eq_zero_iff_eq_zero, (associated_zero_iff_eq_zero _).symm, this] },
  exact (assume ha hb eq, heq_of_eq $ congr_arg some $ factors'_cong _ _ hab)
end

@[simp] theorem factors_0 : (0 : associates α).factors = ⊤ :=
dif_pos rfl

@[simp] theorem factors_mk (a : α) (h : a ≠ 0) : (associates.mk a).factors = factors' a h :=
dif_neg (mt mk_eq_zero_iff_eq_zero.1 h)

def factor_set.prod : factor_set α → associates α
| none     := 0
| (some s) := (s.map subtype.val).prod

@[simp] theorem prod_top : (⊤ : factor_set α).prod = 0 := rfl

@[simp] theorem prod_coe {s : multiset { a : associates α // irreducible a }} :
  (s : factor_set α).prod = (s.map subtype.val).prod :=
rfl

theorem prod_factors : ∀(s : factor_set α), s.prod.factors = s
| none     := by simp [factor_set.prod]; refl
| (some s) :=
  begin
    unfold factor_set.prod,
    generalize eq_a : (s.map subtype.val).prod = a,
    rcases a with ⟨a⟩,
    rw quot_mk_eq_mk at *,

    have : (s.map subtype.val).prod ≠ 0, from assume ha,
      let ⟨⟨a, ha⟩, h, eq⟩ := multiset.mem_map.1 (prod_eq_zero_iff.1 ha) in
      have irreducible (0 : associates α), from eq ▸ ha,
      not_irreducible_zero ((irreducible_mk_iff _).1 this),
    have ha : a ≠ 0, by simp [*] at *,
    suffices : (unique_factorization_domain.factors a).map associates.mk = s.map subtype.val,
    { rw [factors_mk a ha],
      apply congr_arg some _,
      simpa [(multiset.map_eq_map subtype.val_injective).symm] },

    refine unique'
      (forall_map_mk_factors_irreducible _ ha)
      (assume a ha, let ⟨⟨x, hx⟩, ha, eq⟩ := multiset.mem_map.1 ha in eq ▸ hx)
      _,
    rw [prod_mk, eq_a, mk_eq_mk_iff_associated],
    exact factors_prod ha
  end

theorem factors_prod (a : associates α) : a.factors.prod = a :=
quotient.induction_on a $ assume a, decidable.by_cases
  (assume : associates.mk a = 0, by simp [quotient_mk_eq_mk, this])
  (assume : associates.mk a ≠ 0,
    have a ≠ 0, by simp * at *,
    by simp [this, quotient_mk_eq_mk, prod_mk, mk_eq_mk_iff_associated.2 (factors_prod this)])

theorem eq_of_factors_eq_factors {a b : associates α} (h : a.factors = b.factors) : a = b :=
have a.factors.prod = b.factors.prod, by rw h,
by rwa [factors_prod, factors_prod] at this

theorem eq_of_prod_eq_prod {a b : factor_set α} (h : a.prod = b.prod) : a = b :=
have a.prod.factors = b.prod.factors, by rw h,
by rwa [prod_factors, prod_factors] at this

@[simp] theorem prod_add : ∀(a b : factor_set α), (a + b).prod = a.prod * b.prod
| none b    := show (⊤ + b).prod = (⊤:factor_set α).prod * b.prod, by simp
| a    none := show (a + ⊤).prod = a.prod * (⊤:factor_set α).prod, by simp
| (some a) (some b) :=
  show (↑a + ↑b:factor_set α).prod = (↑a:factor_set α).prod * (↑b:factor_set α).prod,
    by rw [factor_set.coe_add, prod_coe, prod_coe, prod_coe, multiset.map_add, multiset.prod_add]

theorem prod_mono : ∀{a b : factor_set α}, a ≤ b → a.prod ≤ b.prod
| none b h := have b = ⊤, from top_unique h, by rw [this, prod_top]; exact le_refl _
| a none h := show a.prod ≤ (⊤ : factor_set α).prod, by simp; exact le_top
| (some a) (some b) h := prod_le_prod $ multiset.map_le_map $ with_top.coe_le_coe.1 $ h

@[simp] theorem factors_mul (a b : associates α) : (a * b).factors = a.factors + b.factors :=
eq_of_prod_eq_prod $ eq_of_factors_eq_factors $
  by rw [prod_add, factors_prod, factors_prod, factors_prod]

theorem factors_mono : ∀{a b : associates α}, a ≤ b → a.factors ≤ b.factors
| s t ⟨d, rfl⟩ := by rw [factors_mul] ; exact le_add_of_nonneg_right' bot_le

theorem factors_le {a b : associates α} : a.factors ≤ b.factors ↔ a ≤ b :=
iff.intro
  (assume h, have a.factors.prod ≤ b.factors.prod, from prod_mono h,
    by rwa [factors_prod, factors_prod] at this)
  factors_mono

theorem prod_le {a b : factor_set α} : a.prod ≤ b.prod ↔ a ≤ b :=
iff.intro
  (assume h, have a.prod.factors ≤ b.prod.factors, from factors_mono h,
    by rwa [prod_factors, prod_factors] at this)
  prod_mono

instance : has_sup (associates α) := ⟨λa b, (a.factors ⊔ b.factors).prod⟩
instance : has_inf (associates α) := ⟨λa b, (a.factors ⊓ b.factors).prod⟩

instance : bounded_lattice (associates α) :=
{ sup          := (⊔),
  inf          := (⊓),
  sup_le       :=
    assume a b c hac hbc, factors_prod c ▸ prod_mono (sup_le (factors_mono hac) (factors_mono hbc)),
  le_sup_left  := assume a b,
    le_trans (le_of_eq (factors_prod a).symm) $ prod_mono $ le_sup_left,
  le_sup_right := assume a b,
    le_trans (le_of_eq (factors_prod b).symm) $ prod_mono $ le_sup_right,
  le_inf :=
    assume a b c hac hbc, factors_prod a ▸ prod_mono (le_inf (factors_mono hac) (factors_mono hbc)),
  inf_le_left  := assume a b,
    le_trans (prod_mono inf_le_left) (le_of_eq (factors_prod a)),
  inf_le_right := assume a b,
    le_trans (prod_mono inf_le_right) (le_of_eq (factors_prod b)),
  .. associates.partial_order,
  .. associates.lattice.order_top,
  .. associates.lattice.order_bot }

lemma sup_mul_inf (a b : associates α) : (a ⊔ b) * (a ⊓ b) = a * b :=
show (a.factors ⊔ b.factors).prod * (a.factors ⊓ b.factors).prod = a * b,
begin
  refine eq_of_factors_eq_factors _,
  rw [← prod_add, prod_factors, factors_mul, factor_set.sup_add_inf_eq_add]
end

end associates

section
open associates unique_factorization_domain lattice

/-- `to_gcd_domain` constructs a GCD domain out of a unique factorization domain over a normalization
domain. -/
def unique_factorization_domain.to_gcd_domain
  (α : Type*) [normalization_domain α] [unique_factorization_domain α] [decidable_eq (associates α)] :
  gcd_domain α :=
{ gcd := λa b, (associates.mk a ⊓ associates.mk b).out,
  lcm := λa b, (associates.mk a ⊔ associates.mk b).out,
  gcd_dvd_left := assume a b, (out_dvd_iff a (associates.mk a ⊓ associates.mk b)).2 $ inf_le_left,
  gcd_dvd_right := assume a b, (out_dvd_iff b (associates.mk a ⊓ associates.mk b)).2 $ inf_le_right,
  dvd_gcd := assume a b c hac hab, show a ∣ (associates.mk c ⊓ associates.mk b).out,
    by rw [dvd_out_iff, le_inf_iff, mk_le_mk_iff_dvd_iff, mk_le_mk_iff_dvd_iff]; exact ⟨hac, hab⟩,
  lcm_zero_left := assume a, show (⊤ ⊔ associates.mk a).out = 0, by simp,
  lcm_zero_right := assume a, show (associates.mk a ⊔ ⊤).out = 0, by simp,
  gcd_mul_lcm := assume a b,
    show (associates.mk a ⊓ associates.mk b).out * (associates.mk a ⊔ associates.mk b).out =
      a * b * norm_unit (a * b),
    by rw [← out_mk, ← out_mul, mul_comm, sup_mul_inf]; refl,
  norm_unit_gcd := assume a b, norm_unit_out _,
  .. ‹normalization_domain α› }

end


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

import linear_algebra.basic
import linear_algebra.basis

/-!
# Basics on bilinear maps

This file provides basics on bilinear maps. The most general form considered are maps that are
semilinear in both arguments. They are of type `M →ₛₗ[ρ₁₂] N →ₛₗ[σ₁₂] P`, where `M` and `N`
are modules over `R` and `S` respectively, `P` is a module over both `R₂` and `S₂` with
commuting actions, and `ρ₁₂ : R →+* R₂` and `σ₁₂ : S →+* S₂`.

## Main declarations

* `linear_map.mk₂`: a constructor for bilinear maps,
  taking an unbundled function together with proof witnesses of bilinearity
* `linear_map.flip`: turns a bilinear map `M × N → P` into `N × M → P`
* `linear_map.lcomp` and `linear_map.llcomp`: composition of linear maps as a bilinear map
* `linear_map.compl₂`: composition of a bilinear map `M × N → P` with a linear map `Q → M`
* `linear_map.compr₂`: composition of a bilinear map `M × N → P` with a linear map `Q → N`
* `linear_map.lsmul`: scalar multiplication as a bilinear map `R × M → M`

## Tags

bilinear
-/

variables {ι₁ ι₂ : Type*}

namespace linear_map

section semiring

-- the `ₗ` subscript variables are for special cases about linear (as opposed to semilinear) maps
variables {R : Type*} [semiring R] {S : Type*} [semiring S]
variables {R₂ : Type*} [semiring R₂] {S₂ : Type*} [semiring S₂]
variables {M : Type*} {N : Type*} {P : Type*}
variables {M₂ : Type*} {N₂ : Type*} {P₂ : Type*}
variables {Nₗ : Type*} {Pₗ : Type*}
variables {M' : Type*} {N' : Type*} {P' : Type*}

variables [add_comm_monoid M] [add_comm_monoid N] [add_comm_monoid P]
variables [add_comm_monoid M₂] [add_comm_monoid N₂] [add_comm_monoid P₂]
variables [add_comm_monoid Nₗ] [add_comm_monoid Pₗ]
variables [add_comm_group M'] [add_comm_group N'] [add_comm_group P']
variables [module R M] [module S N] [module R₂ P] [module S₂ P]
variables [module R M₂] [module S N₂] [module R P₂] [module S₂ P₂]
variables [module R Pₗ] [module S Pₗ]
variables [module R M'] [module S N'] [module R₂ P'] [module S₂ P']
variables [smul_comm_class S₂ R₂ P] [smul_comm_class S R Pₗ] [smul_comm_class S₂ R₂ P']
variables [smul_comm_class S₂ R P₂]
variables {ρ₁₂ : R →+* R₂} {σ₁₂ : S →+* S₂}

variables (ρ₁₂ σ₁₂)
/-- Create a bilinear map from a function that is semilinear in each component.
See `mk₂'` and `mk₂` for the linear case. -/
def mk₂'ₛₗ (f : M → N → P)
  (H1 : ∀ m₁ m₂ n, f (m₁ + m₂) n = f m₁ n + f m₂ n)
  (H2 : ∀ (c:R) m n, f (c • m) n = (ρ₁₂ c) • f m n)
  (H3 : ∀ m n₁ n₂, f m (n₁ + n₂) = f m n₁ + f m n₂)
  (H4 : ∀ (c:S) m n, f m (c • n) = (σ₁₂ c) • f m n) : M →ₛₗ[ρ₁₂] N →ₛₗ[σ₁₂] P :=
{ to_fun := λ m, { to_fun := f m, map_add' := H3 m, map_smul' := λ c, H4 c m},
  map_add' := λ m₁ m₂, linear_map.ext $ H1 m₁ m₂,
  map_smul' := λ c m, linear_map.ext $ H2 c m }
variables {ρ₁₂ σ₁₂}

@[simp] theorem mk₂'ₛₗ_apply
  (f : M → N → P) {H1 H2 H3 H4} (m : M) (n : N) :
  (mk₂'ₛₗ ρ₁₂ σ₁₂ f H1 H2 H3 H4 : M →ₛₗ[ρ₁₂] N →ₛₗ[σ₁₂] P) m n = f m n := rfl

variables (R S)
/-- Create a bilinear map from a function that is linear in each component.
See `mk₂` for the special case where both arguments come from modules over the same ring. -/
def mk₂' (f : M → N → Pₗ)
  (H1 : ∀ m₁ m₂ n, f (m₁ + m₂) n = f m₁ n + f m₂ n)
  (H2 : ∀ (c:R) m n, f (c • m) n = c • f m n)
  (H3 : ∀ m n₁ n₂, f m (n₁ + n₂) = f m n₁ + f m n₂)
  (H4 : ∀ (c:S) m n, f m (c • n) = c • f m n) : M →ₗ[R] N →ₗ[S] Pₗ :=
mk₂'ₛₗ (ring_hom.id R) (ring_hom.id S) f H1 H2 H3 H4
variables {R S}

@[simp] theorem mk₂'_apply
  (f : M → N → Pₗ) {H1 H2 H3 H4} (m : M) (n : N) :
  (mk₂' R S f H1 H2 H3 H4 : M →ₗ[R] N →ₗ[S] Pₗ) m n = f m n := rfl

theorem ext₂ {f g : M →ₛₗ[ρ₁₂] N →ₛₗ[σ₁₂] P}
  (H : ∀ m n, f m n = g m n) : f = g :=
linear_map.ext (λ m, linear_map.ext $ λ n, H m n)

lemma congr_fun₂ {f g : M →ₛₗ[ρ₁₂] N →ₛₗ[σ₁₂] P} (h : f = g) (x y) : f x y = g x y :=
linear_map.congr_fun (linear_map.congr_fun h x) y

section

local attribute [instance] smul_comm_class.symm

/-- Given a linear map from `M` to linear maps from `N` to `P`, i.e., a bilinear map from `M × N` to
`P`, change the order of variables and get a linear map from `N` to linear maps from `M` to `P`. -/
def flip (f : M →ₛₗ[ρ₁₂] N →ₛₗ[σ₁₂] P) : N →ₛₗ[σ₁₂] M →ₛₗ[ρ₁₂] P :=
mk₂'ₛₗ σ₁₂ ρ₁₂ (λ n m, f m n)
  (λ n₁ n₂ m, (f m).map_add _ _)
  (λ c n m, (f m).map_smulₛₗ _ _)
  (λ n m₁ m₂, by rw f.map_add; refl)
  (λ c n m, by rw f.map_smulₛₗ; refl)

end

@[simp] theorem flip_apply (f : M →ₛₗ[ρ₁₂] N →ₛₗ[σ₁₂] P) (m : M) (n : N) : flip f n m = f m n := rfl

@[simp] lemma flip_flip [smul_comm_class R₂ S₂ P] (f : M →ₛₗ[ρ₁₂] N →ₛₗ[σ₁₂] P) :
  f.flip.flip = f := linear_map.ext₂ (λ x y, ((f.flip).flip_apply _ _).trans (f.flip_apply _ _))

open_locale big_operators

variables {R}
theorem flip_inj {f g : M →ₛₗ[ρ₁₂] N →ₛₗ[σ₁₂] P} (H : flip f = flip g) : f = g :=
ext₂ $ λ m n, show flip f n m = flip g n m, by rw H

theorem map_zero₂ (f : M →ₛₗ[ρ₁₂] N →ₛₗ[σ₁₂] P) (y) : f 0 y = 0 :=
(flip f y).map_zero

theorem map_neg₂ (f : M' →ₛₗ[ρ₁₂] N →ₛₗ[σ₁₂] P') (x y) : f (-x) y = -f x y :=
(flip f y).map_neg _

theorem map_sub₂ (f : M' →ₛₗ[ρ₁₂] N →ₛₗ[σ₁₂] P') (x y z) : f (x - y) z = f x z - f y z :=
(flip f z).map_sub _ _

theorem map_add₂ (f : M →ₛₗ[ρ₁₂] N →ₛₗ[σ₁₂] P) (x₁ x₂ y) : f (x₁ + x₂) y = f x₁ y + f x₂ y :=
(flip f y).map_add _ _

theorem map_smul₂ (f : M₂ →ₗ[R] N₂ →ₛₗ[σ₁₂] P₂) (r : R) (x y) : f (r • x) y = r • f x y :=
(flip f y).map_smul _ _

theorem map_smulₛₗ₂ (f : M →ₛₗ[ρ₁₂] N →ₛₗ[σ₁₂] P) (r : R) (x y) : f (r • x) y = (ρ₁₂ r) • f x y :=
(flip f y).map_smulₛₗ _ _

theorem map_sum₂ {ι : Type*} (f : M →ₛₗ[ρ₁₂] N →ₛₗ[σ₁₂] P) (t : finset ι) (x : ι → M) (y) :
  f (∑ i in t, x i) y = ∑ i in t, f (x i) y :=
(flip f y).map_sum

/-- Restricting a bilinear map in the second entry -/
def dom_restrict₂ (f : M →ₛₗ[ρ₁₂] N →ₛₗ[σ₁₂] P) (q : submodule S N) :
  M →ₛₗ[ρ₁₂] q →ₛₗ[σ₁₂] P :=
{ to_fun := λ m, (f m).dom_restrict q,
  map_add' := λ m₁ m₂, linear_map.ext $ λ _, by simp only [map_add, dom_restrict_apply, add_apply],
  map_smul' := λ c m, linear_map.ext $ λ _, by simp only [map_smulₛₗ, dom_restrict_apply,
    smul_apply]}

lemma dom_restrict₂_apply (f : M →ₛₗ[ρ₁₂] N →ₛₗ[σ₁₂] P) (q : submodule S N) (x : M) (y : q) :
  f.dom_restrict₂ q x y = f x y := rfl

/-- Restricting a bilinear map in both components -/
def dom_restrict₁₂ (f : M →ₛₗ[ρ₁₂] N →ₛₗ[σ₁₂] P) (p : submodule R M) (q : submodule S N) :
  p →ₛₗ[ρ₁₂] q →ₛₗ[σ₁₂] P := (f.dom_restrict p).dom_restrict₂ q

lemma dom_restrict₁₂_apply (f : M →ₛₗ[ρ₁₂] N →ₛₗ[σ₁₂] P) (p : submodule R M) (q : submodule S N)
  (x : p) (y : q) : f.dom_restrict₁₂ p q x y = f x y := rfl

end semiring

section comm_semiring

variables {R : Type*} [comm_semiring R] {R₂ : Type*} [comm_semiring R₂]
variables {R₃ : Type*} [comm_semiring R₃] {R₄ : Type*} [comm_semiring R₄]
variables {M : Type*} {N : Type*} {P : Type*} {Q : Type*}
variables {Nₗ : Type*} {Pₗ : Type*} {Qₗ : Type*}

variables [add_comm_monoid M] [add_comm_monoid N] [add_comm_monoid P] [add_comm_monoid Q]
variables [add_comm_monoid Nₗ] [add_comm_monoid Pₗ] [add_comm_monoid Qₗ]
variables [module R M] [module R₂ N] [module R₃ P] [module R₄ Q]
variables [module R Nₗ] [module R Pₗ] [module R Qₗ]
variables {σ₁₂ : R →+* R₂} {σ₂₃ : R₂ →+* R₃} {σ₁₃ : R →+* R₃}
variables {σ₄₂ : R₄ →+* R₂} {σ₄₃ : R₄ →+* R₃}
variables [ring_hom_comp_triple σ₁₂ σ₂₃ σ₁₃] [ring_hom_comp_triple σ₄₂ σ₂₃ σ₄₃]

variables (R)

/-- Create a bilinear map from a function that is linear in each component.

This is a shorthand for `mk₂'` for the common case when `R = S`. -/
def mk₂ (f : M → Nₗ → Pₗ)
  (H1 : ∀ m₁ m₂ n, f (m₁ + m₂) n = f m₁ n + f m₂ n)
  (H2 : ∀ (c:R) m n, f (c • m) n = c • f m n)
  (H3 : ∀ m n₁ n₂, f m (n₁ + n₂) = f m n₁ + f m n₂)
  (H4 : ∀ (c:R) m n, f m (c • n) = c • f m n) : M →ₗ[R] Nₗ →ₗ[R] Pₗ :=
mk₂' R R f H1 H2 H3 H4

@[simp] theorem mk₂_apply
  (f : M → Nₗ → Pₗ) {H1 H2 H3 H4} (m : M) (n : Nₗ) :
  (mk₂ R f H1 H2 H3 H4 : M →ₗ[R] Nₗ →ₗ[R] Pₗ) m n = f m n := rfl

variables (R M N P)
/-- Given a linear map from `M` to linear maps from `N` to `P`, i.e., a bilinear map `M → N → P`,
change the order of variables and get a linear map from `N` to linear maps from `M` to `P`. -/
def lflip : (M →ₛₗ[σ₁₃] N →ₛₗ[σ₂₃] P) →ₗ[R₃] N →ₛₗ[σ₂₃] M →ₛₗ[σ₁₃] P :=
{ to_fun := flip, map_add' := λ _ _, rfl, map_smul' := λ _ _, rfl }
variables {R M N P}

variables (f : M →ₛₗ[σ₁₃] N →ₛₗ[σ₂₃] P)

@[simp] theorem lflip_apply (m : M) (n : N) : lflip R M N P f n m = f m n := rfl

variables (R Pₗ)
/-- Composing a linear map `M → N` and a linear map `N → P` to form a linear map `M → P`. -/
def lcomp (f : M →ₗ[R] Nₗ) : (Nₗ →ₗ[R] Pₗ) →ₗ[R] M →ₗ[R] Pₗ :=
flip $ linear_map.comp (flip id) f

variables {R Pₗ}

@[simp] theorem lcomp_apply (f : M →ₗ[R] Nₗ) (g : Nₗ →ₗ[R] Pₗ) (x : M) :
  lcomp R Pₗ f g x = g (f x) := rfl

variables (P σ₂₃)
/-- Composing a semilinear map `M → N` and a semilinear map `N → P` to form a semilinear map
`M → P` is itself a linear map. -/
def lcompₛₗ (f : M →ₛₗ[σ₁₂] N) : (N →ₛₗ[σ₂₃] P) →ₗ[R₃] M →ₛₗ[σ₁₃] P :=
flip $ linear_map.comp (flip id) f
variables {P σ₂₃}

include σ₁₃
@[simp] theorem lcompₛₗ_apply (f : M →ₛₗ[σ₁₂] N) (g : N →ₛₗ[σ₂₃] P) (x : M) :
  lcompₛₗ P σ₂₃ f g x = g (f x) := rfl
omit σ₁₃

variables (R M Nₗ Pₗ)
/-- Composing a linear map `M → N` and a linear map `N → P` to form a linear map `M → P`. -/
def llcomp : (Nₗ →ₗ[R] Pₗ) →ₗ[R] (M →ₗ[R] Nₗ) →ₗ[R] M →ₗ[R] Pₗ :=
flip { to_fun := lcomp R Pₗ,
       map_add' := λ f f', ext₂ $ λ g x, g.map_add _ _,
       map_smul' := λ (c : R) f, ext₂ $ λ g x, g.map_smul _ _ }
variables {R M Nₗ Pₗ}

section
@[simp] theorem llcomp_apply (f : Nₗ →ₗ[R] Pₗ) (g : M →ₗ[R] Nₗ) (x : M) :
  llcomp R M Nₗ Pₗ f g x = f (g x) := rfl
end

/-- Composing a linear map `Q → N` and a bilinear map `M → N → P` to
form a bilinear map `M → Q → P`. -/
def compl₂ (g : Q →ₛₗ[σ₄₂] N) : M →ₛₗ[σ₁₃] Q →ₛₗ[σ₄₃] P := (lcompₛₗ _ _ g).comp f

include σ₄₃
@[simp]

/-- Composing a linear map `P → Q` and a bilinear map `M → N → P` to
form a bilinear map `M → N → Q`. -/
def compr₂ (f : M →ₗ[R] Nₗ →ₗ[R] Pₗ) (g : Pₗ →ₗ[R] Qₗ) : M →ₗ[R] Nₗ →ₗ[R] Qₗ :=
(llcomp R Nₗ Pₗ Qₗ g) ∘ₗ f

@[simp] theorem compr₂_apply (f : M →ₗ[R] Nₗ →ₗ[R] Pₗ) (g : Pₗ →ₗ[R] Qₗ) (m : M) (n : Nₗ) :
  f.compr₂ g m n = g (f m n) := rfl

variables (R M)
/-- Scalar multiplication as a bilinear map `R → M → M`. -/
def lsmul : R →ₗ[R] M →ₗ[R] M :=
mk₂ R (•) add_smul (λ _ _ _, mul_smul _ _ _) smul_add
(λ r s m, by simp only [smul_smul, smul_eq_mul, mul_comm])
variables {R M}

@[simp] theorem lsmul_apply (r : R) (m : M) : lsmul R M r m = r • m := rfl

end comm_semiring

section comm_ring

variables {R R₂ S S₂ M N P : Type*}
variables [comm_ring R] [comm_ring S] [comm_ring R₂] [comm_ring S₂]
variables [add_comm_group M] [add_comm_group N] [add_comm_group P]
variables [module R M] [module S N] [module R₂ P] [module S₂ P]
variables [smul_comm_class S₂ R₂ P]
variables {ρ₁₂ : R →+* R₂} {σ₁₂ : S →+* S₂}
variables (b₁ : basis ι₁ R M) (b₂ : basis ι₂ S N)

lemma lsmul_injective [no_zero_smul_divisors R M] {x : R} (hx : x ≠ 0) :
  function.injective (lsmul R M x) :=
smul_right_injective _ hx

lemma ker_lsmul [no_zero_smul_divisors R M] {a : R} (ha : a ≠ 0) :
  (linear_map.lsmul R M a).ker = ⊥ :=
linear_map.ker_eq_bot_of_injective (linear_map.lsmul_injective ha)

/-- Two bilinear maps are equal when they are equal on all basis vectors. -/
lemma ext_basis {B B' : M →ₛₗ[ρ₁₂] N →ₛₗ[σ₁₂] P}
  (h : ∀ i j, B (b₁ i) (b₂ j) = B' (b₁ i) (b₂ j)) : B = B' :=
b₁.ext $ λ i, b₂.ext $ λ j, h i j

/-- Write out `B x y` as a sum over `B (b i) (b j)` if `b` is a basis. -/
lemma sum_repr_mul_repr_mul {B : M →ₛₗ[ρ₁₂] N →ₛₗ[σ₁₂] P} (x y) :
  (b₁.repr x).sum (λ i xi, (b₂.repr y).sum (λ j yj, (ρ₁₂ xi) • (σ₁₂ yj) • B (b₁ i) (b₂ j))) =
  B x y :=
begin
  conv_rhs { rw [← b₁.total_repr x, ← b₂.total_repr y] },
  simp_rw [finsupp.total_apply, finsupp.sum, map_sum₂, map_sum, map_smulₛₗ₂, map_smulₛₗ],
end

end comm_ring

end linear_map


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Markus Himmel
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.homology.chain_complex
import Mathlib.algebra.homology.image_to_kernel_map
import Mathlib.PostPort

universes u v

namespace Mathlib

/-!
# (Co)homology groups for complexes

We setup that part of the theory of homology groups which works in
any category with kernels and images.

We define the homology groups themselves, and show that they induce maps on kernels.

Under the additional assumption that our category has equalizers and functorial images, we construct
induced morphisms on images and functorial induced morphisms in homology.

## Chains and cochains

Throughout we work with complexes graded by an arbitrary `[add_comm_group β]`,
with a differential with grading `b : β`.
Thus we're simultaneously doing homology and cohomology groups
(and in future, e.g., enabling computing homologies for successive pages of spectral sequences).

At the end of the file we set up abbreviations `cohomology` and `graded_cohomology`,
so that when you're working with a `C : cochain_complex V`, you can write `C.cohomology i`
rather than the confusing `C.homology i`.
-/

namespace homological_complex

/-- The map induced by a chain map between the kernels of the differentials. -/
def kernel_map {V : Type u} [category_theory.category V] [category_theory.limits.has_zero_morphisms V] {β : Type} [add_comm_group β] {b : β} [category_theory.limits.has_kernels V] {C : homological_complex V b} {C' : homological_complex V b} (f : C ⟶ C') (i : β) : category_theory.limits.kernel (category_theory.differential_object.d C i) ⟶
  category_theory.limits.kernel (category_theory.differential_object.d C' i) :=
  category_theory.limits.kernel.lift (category_theory.differential_object.d C' i)
    (category_theory.limits.kernel.ι (category_theory.differential_object.d C i) ≫
      category_theory.differential_object.hom.f f i)
    sorry

@[simp] theorem kernel_map_condition {V : Type u} [category_theory.category V] [category_theory.limits.has_zero_morphisms V] {β : Type} [add_comm_group β] {b : β} [category_theory.limits.has_kernels V] {C : homological_complex V b} {C' : homological_complex V b} (f : C ⟶ C') (i : β) : kernel_map f i ≫ category_theory.limits.kernel.ι (category_theory.differential_object.d C' i) =
  category_theory.limits.kernel.ι (category_theory.differential_object.d C i) ≫
    category_theory.differential_object.hom.f f i := sorry

@[simp] theorem kernel_map_id {V : Type u} [category_theory.category V] [category_theory.limits.has_zero_morphisms V] {β : Type} [add_comm_group β] {b : β} [category_theory.limits.has_kernels V] (C : homological_complex V b) (i : β) : kernel_map 𝟙 i = 𝟙 := sorry

@[simp] theorem kernel_map_comp {V : Type u} [category_theory.category V] [category_theory.limits.has_zero_morphisms V] {β : Type} [add_comm_group β] {b : β} [category_theory.limits.has_kernels V] {C : homological_complex V b} {C' : homological_complex V b} {C'' : homological_complex V b} (f : C ⟶ C') (g : C' ⟶ C'') (i : β) : kernel_map (f ≫ g) i = kernel_map f i ≫ kernel_map g i := sorry

/-- The kernels of the differentials of a complex form a `β`-graded object. -/
def kernel_functor {V : Type u} [category_theory.category V] [category_theory.limits.has_zero_morphisms V] {β : Type} [add_comm_group β] {b : β} [category_theory.limits.has_kernels V] : homological_complex V b ⥤ category_theory.graded_object β V :=
  category_theory.functor.mk
    (fun (C : homological_complex V b) (i : β) =>
      category_theory.limits.kernel (category_theory.differential_object.d C i))
    fun (X Y : homological_complex V b) (f : X ⟶ Y) (i : β) => kernel_map f i

/-- A morphism of complexes induces a morphism on the images of the differentials in every
    degree. -/
def image_map {V : Type u} [category_theory.category V] [category_theory.limits.has_zero_morphisms V] {β : Type} [add_comm_group β] {b : β} [category_theory.limits.has_images V] [category_theory.limits.has_image_maps V] {C : homological_complex V b} {C' : homological_complex V b} (f : C ⟶ C') (i : β) : category_theory.limits.image (category_theory.differential_object.d C i) ⟶
  category_theory.limits.image (category_theory.differential_object.d C' i) :=
  category_theory.limits.image.map (category_theory.arrow.hom_mk' sorry)

@[simp] theorem image_map_ι {V : Type u} [category_theory.category V] [category_theory.limits.has_zero_morphisms V] {β : Type} [add_comm_group β] {b : β} [category_theory.limits.has_images V] [category_theory.limits.has_image_maps V] {C : homological_complex V b} {C' : homological_complex V b} (f : C ⟶ C') (i : β) : image_map V _inst_1 _inst_2 β _inst_3 b _inst_4 _inst_5 C C' f i ≫
    category_theory.limits.image.ι (category_theory.differential_object.d C' i) =
  category_theory.limits.image.ι (category_theory.differential_object.d C i) ≫
    category_theory.differential_object.hom.f f (i + b) :=
  category_theory.limits.image.map_hom_mk'_ι (Eq.symm (comm_at V _inst_1 _inst_2 β _inst_3 b C C' f i))

/--
The connecting morphism from the image of `d i` to the kernel of `d (i ± 1)`.
-/
def image_to_kernel_map {V : Type u} [category_theory.category V] [category_theory.limits.has_zero_morphisms V] {β : Type} [add_comm_group β] {b : β} [category_theory.limits.has_images V] [category_theory.limits.has_equalizers V] (C : homological_complex V b) (i : β) : category_theory.limits.image (category_theory.differential_object.d C i) ⟶
  category_theory.limits.kernel (category_theory.differential_object.d C (i + b)) :=
  category_theory.image_to_kernel_map (category_theory.differential_object.d C i)
    (category_theory.differential_object.d C (i + b)) sorry

@[simp] theorem image_to_kernel_map_condition {V : Type u} [category_theory.category V] [category_theory.limits.has_zero_morphisms V] {β : Type} [add_comm_group β] {b : β} [category_theory.limits.has_images V] [category_theory.limits.has_equalizers V] (C : homological_complex V b) (i : β) : image_to_kernel_map V _inst_1 _inst_2 β _inst_3 b _inst_4 _inst_5 C i ≫
    category_theory.limits.kernel.ι (category_theory.differential_object.d C (i + b)) =
  category_theory.limits.image.ι (category_theory.differential_object.d C i) := sorry

theorem image_to_kernel_map_comp_kernel_map {V : Type u} [category_theory.category V] [category_theory.limits.has_zero_morphisms V] {β : Type} [add_comm_group β] {b : β} [category_theory.limits.has_images V] [category_theory.limits.has_equalizers V] [category_theory.limits.has_image_maps V] {C : homological_complex V b} {C' : homological_complex V b} (f : C ⟶ C') (i : β) : image_to_kernel_map V _inst_1 _inst_2 β _inst_3 b _inst_4 _inst_5 C i ≫ kernel_map f (i + b) =
  image_map V _inst_1 _inst_2 β _inst_3 b _inst_4 _inst_6 C C' f i ≫
    image_to_kernel_map V _inst_1 _inst_2 β _inst_3 b _inst_4 _inst_5 C' i := sorry

/-- The `i`-th homology group of the complex `C`. -/
def homology_group {V : Type u} [category_theory.category V] [category_theory.limits.has_zero_morphisms V] {β : Type} [add_comm_group β] {b : β} [category_theory.limits.has_images V] [category_theory.limits.has_equalizers V] [category_theory.limits.has_cokernels V] (i : β) (C : homological_complex V b) : V :=
  category_theory.limits.cokernel (image_to_kernel_map V _inst_1 _inst_2 β _inst_3 b _inst_4 _inst_5 C (i - b))

/-- A chain map induces a morphism in homology at every degree. -/
def homology_map {V : Type u} [category_theory.category V] [category_theory.limits.has_zero_morphisms V] {β : Type} [add_comm_group β] {b : β} [category_theory.limits.has_images V] [category_theory.limits.has_equalizers V] [category_theory.limits.has_cokernels V] [category_theory.limits.has_image_maps V] {C : homological_complex V b} {C' : homological_complex V b} (f : C ⟶ C') (i : β) : homology_group V _inst_1 _inst_2 β _inst_3 b _inst_4 _inst_5 _inst_6 i C ⟶
  homology_group V _inst_1 _inst_2 β _inst_3 b _inst_4 _inst_5 _inst_6 i C' :=
  category_theory.limits.cokernel.desc (image_to_kernel_map V _inst_1 _inst_2 β _inst_3 b _inst_4 _inst_5 C (i - b))
    (kernel_map f (i - b + b) ≫
      category_theory.limits.cokernel.π (image_to_kernel_map V _inst_1 _inst_2 β _inst_3 b _inst_4 _inst_5 C' (i - b)))
    sorry

@[simp] theorem homology_map_condition {V : Type u} [category_theory.category V] [category_theory.limits.has_zero_morphisms V] {β : Type} [add_comm_group β] {b : β} [category_theory.limits.has_images V] [category_theory.limits.has_equalizers V] [category_theory.limits.has_cokernels V] [category_theory.limits.has_image_maps V] {C : homological_complex V b} {C' : homological_complex V b} (f : C ⟶ C') (i : β) : category_theory.limits.cokernel.π (image_to_kernel_map V _inst_1 _inst_2 β _inst_3 b _inst_4 _inst_5 C (i - b)) ≫
    homology_map ((fun (_x : β) => V) (i - b)) _inst_1 _inst_2 β _inst_3 b _inst_4 _inst_5 _inst_6 _inst_7 C C' f i =
  kernel_map f (i - b + b) ≫
    category_theory.limits.cokernel.π
      (image_to_kernel_map ((fun (_x : β) => V) (i - b)) _inst_1 _inst_2 β _inst_3 b _inst_4 _inst_5 C' (i - b)) := sorry

@[simp] theorem homology_map_id {V : Type u} [category_theory.category V] [category_theory.limits.has_zero_morphisms V] {β : Type} [add_comm_group β] {b : β} [category_theory.limits.has_images V] [category_theory.limits.has_equalizers V] [category_theory.limits.has_cokernels V] [category_theory.limits.has_image_maps V] (C : homological_complex V b) (i : β) : homology_map V _inst_1 _inst_2 β _inst_3 b _inst_4 _inst_5 _inst_6 _inst_7 C C 𝟙 i = 𝟙 := sorry

@[simp] theorem homology_map_comp {V : Type u} [category_theory.category V] [category_theory.limits.has_zero_morphisms V] {β : Type} [add_comm_group β] {b : β} [category_theory.limits.has_images V] [category_theory.limits.has_equalizers V] [category_theory.limits.has_cokernels V] [category_theory.limits.has_image_maps V] {C : homological_complex V b} {C' : homological_complex V b} {C'' : homological_complex V b} (f : C ⟶ C') (g : C' ⟶ C'') (i : β) : homology_map V _inst_1 _inst_2 β _inst_3 b _inst_4 _inst_5 _inst_6 _inst_7 C C'' (f ≫ g) i =
  homology_map V _inst_1 _inst_2 β _inst_3 b _inst_4 _inst_5 _inst_6 _inst_7 C C' f i ≫
    homology_map V _inst_1 _inst_2 β _inst_3 b _inst_4 _inst_5 _inst_6 _inst_7 C' C'' g i := sorry

/-- The `i`-th homology functor from `β` graded complexes to `V`. -/
def homology (V : Type u) [category_theory.category V] [category_theory.limits.has_zero_morphisms V] {β : Type} [add_comm_group β] {b : β} [category_theory.limits.has_images V] [category_theory.limits.has_equalizers V] [category_theory.limits.has_cokernels V] [category_theory.limits.has_image_maps V] (i : β) : homological_complex V b ⥤ V :=
  category_theory.functor.mk
    (fun (C : homological_complex V b) => homology_group V _inst_1 _inst_2 β _inst_3 b _inst_4 _inst_5 _inst_6 i C)
    fun (C C' : homological_complex V b) (f : C ⟶ C') =>
      homology_map V _inst_1 _inst_2 β _inst_3 b _inst_4 _inst_5 _inst_6 _inst_7 C C' f i

/-- The homology functor from `β` graded complexes to `β` graded objects in `V`. -/
def graded_homology (V : Type u) [category_theory.category V] [category_theory.limits.has_zero_morphisms V] {β : Type} [add_comm_group β] {b : β} [category_theory.limits.has_images V] [category_theory.limits.has_equalizers V] [category_theory.limits.has_cokernels V] [category_theory.limits.has_image_maps V] : homological_complex V b ⥤ category_theory.graded_object β V :=
  category_theory.functor.mk
    (fun (C : homological_complex V b) (i : β) =>
      homology_group V _inst_1 _inst_2 β _inst_3 b _inst_4 _inst_5 _inst_6 i C)
    fun (C C' : homological_complex V b) (f : C ⟶ C') (i : β) =>
      homology_map ((fun (_x : β) => V) i) _inst_1 _inst_2 β _inst_3 b _inst_4 _inst_5 _inst_6 _inst_7 C C' f i

end homological_complex

/-!
We now set up abbreviations so that you can write `C.cohomology i` or `(graded_cohomology V).map f`,
etc., when `C` is a cochain complex.
-/

namespace cochain_complex

/-- The `i`-th cohomology group of the cochain complex `C`. -/
def cohomology_group {V : Type u} [category_theory.category V] [category_theory.limits.has_zero_morphisms V] [category_theory.limits.has_images V] [category_theory.limits.has_equalizers V] [category_theory.limits.has_cokernels V] (C : cochain_complex V) (i : ℤ) : V :=
  homological_complex.homology_group V _inst_1 _inst_2 ℤ (linear_ordered_add_comm_group.to_add_comm_group ℤ) 1 _inst_4
    _inst_5 _inst_6 i C

/-- A chain map induces a morphism in cohomology at every degree. -/
def cohomology_map {V : Type u} [category_theory.category V] [category_theory.limits.has_zero_morphisms V] [category_theory.limits.has_images V] [category_theory.limits.has_equalizers V] [category_theory.limits.has_cokernels V] [category_theory.limits.has_image_maps V] {C : cochain_complex V} {C' : cochain_complex V} (f : C ⟶ C') (i : ℤ) : cohomology_group V _inst_1 _inst_2 _inst_4 _inst_5 _inst_6 C i ⟶
  cohomology_group V _inst_1 _inst_2 _inst_4 _inst_5 _inst_6 C' i :=
  homological_complex.homology_map V _inst_1 _inst_2 ℤ (linear_ordered_add_comm_group.to_add_comm_group ℤ) 1 _inst_4
    _inst_5 _inst_6 _inst_7 C C' f i

/-- The `i`-th homology functor from cohain complexes to `V`. -/
def cohomology (V : Type u) [category_theory.category V] [category_theory.limits.has_zero_morphisms V] [category_theory.limits.has_images V] [category_theory.limits.has_equalizers V] [category_theory.limits.has_cokernels V] [category_theory.limits.has_image_maps V] (i : ℤ) : cochain_complex V ⥤ V :=
  homological_complex.homology V _inst_1 _inst_2 ℤ (linear_ordered_add_comm_group.to_add_comm_group ℤ) 1 _inst_4 _inst_5
    _inst_6 _inst_7 i

/-- The cohomology functor from cochain complexes to `ℤ`-graded objects in `V`. -/
def graded_cohomology (V : Type u) [category_theory.category V] [category_theory.limits.has_zero_morphisms V] [category_theory.limits.has_images V] [category_theory.limits.has_equalizers V] [category_theory.limits.has_cokernels V] [category_theory.limits.has_image_maps V] : cochain_complex V ⥤ category_theory.graded_object ℤ V :=
  homological_complex.graded_homology V _inst_1 _inst_2 ℤ (linear_ordered_add_comm_group.to_add_comm_group ℤ) 1 _inst_4
    _inst_5 _inst_6 _inst_7


/-
Copyright (c) 2018 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl

Transitive reflexive as well as reflexive closure of relations.
-/
import tactic.interactive tactic.mk_iff_of_inductive_prop logic.relator
variables {α : Type*} {β : Type*} {γ : Type*} {δ : Type*}

namespace relation

section comp
variables {r : α → β → Prop} {p : β → γ → Prop} {q : γ → δ → Prop}

def comp (r : α → β → Prop) (p : β → γ → Prop) (a : α) (c : γ) : Prop := ∃b, r a b ∧ p b c

local infixr ` ∘r ` : 80 := relation.comp

lemma comp_eq : r ∘r (=) = r :=
funext $ assume a, funext $ assume b, propext $ iff.intro
  (assume ⟨c, h, eq⟩, eq ▸ h)
  (assume h, ⟨b, h, rfl⟩)

lemma eq_comp : (=) ∘r r = r :=
funext $ assume a, funext $ assume b, propext $ iff.intro
  (assume ⟨c, eq, h⟩, eq.symm ▸ h)
  (assume h, ⟨a, rfl, h⟩)

lemma iff_comp {r : Prop → α → Prop} : (↔) ∘r r = r :=
have (↔) = (=), by funext a b; exact iff_eq_eq,
by rw [this, eq_comp]

lemma comp_iff {r : α → Prop → Prop} : r ∘r (↔) = r :=
have (↔) = (=), by funext a b; exact iff_eq_eq,
by rw [this, comp_eq]

lemma comp_assoc : (r ∘r p) ∘r q = r ∘r p ∘r q :=
begin
  funext a d, apply propext,
  split,
  exact assume ⟨c, ⟨b, hab, hbc⟩, hcd⟩, ⟨b, hab, c, hbc, hcd⟩,
  exact assume ⟨b, hab, c, hbc, hcd⟩, ⟨c, ⟨b, hab, hbc⟩, hcd⟩
end

lemma flip_comp : flip (r ∘r p) = (flip p) ∘r (flip r) :=
begin
  funext c a, apply propext,
  split,
  exact assume ⟨b, hab, hbc⟩, ⟨b, hbc, hab⟩,
  exact assume ⟨b, hbc, hab⟩, ⟨b, hab, hbc⟩
end

end comp

protected def map (r : α → β → Prop) (f : α → γ) (g : β → δ) : γ → δ → Prop :=
λc d, ∃a b, r a b ∧ f a = c ∧ g b = d

variables {r : α → α → Prop} {a b c d : α}

/-- `refl_trans_gen r`: reflexive transitive closure of `r` -/
inductive refl_trans_gen (r : α → α → Prop) (a : α) : α → Prop
| refl {} : refl_trans_gen a
| tail {b c} : refl_trans_gen b → r b c → refl_trans_gen c

attribute [refl] refl_trans_gen.refl

run_cmd tactic.mk_iff_of_inductive_prop `relation.refl_trans_gen `relation.refl_trans_gen.cases_tail_iff

/-- `refl_gen r`: reflexive closure of `r` -/
inductive refl_gen (r : α → α → Prop) (a : α) : α → Prop
| refl {} : refl_gen a
| single {b} : r a b → refl_gen b

run_cmd tactic.mk_iff_of_inductive_prop `relation.refl_gen `relation.refl_gen_iff

/-- `trans_gen r`: transitive closure of `r` -/
inductive trans_gen (r : α → α → Prop) (a : α) : α → Prop
| single {b} : r a b → trans_gen b
| tail {b c} : trans_gen b → r b c → trans_gen c

run_cmd tactic.mk_iff_of_inductive_prop `relation.trans_gen `relation.trans_gen_iff

attribute [refl] refl_gen.refl

lemma refl_gen.to_refl_trans_gen : ∀{a b}, refl_gen r a b → refl_trans_gen r a b
| a _ refl_gen.refl := by refl
| a b (refl_gen.single h) := refl_trans_gen.tail refl_trans_gen.refl h

namespace refl_trans_gen

@[trans] lemma trans (hab : refl_trans_gen r a b) (hbc : refl_trans_gen r b c) : refl_trans_gen r a c :=
begin
  induction hbc,
  case refl_trans_gen.refl { assumption },
  case refl_trans_gen.tail : c d hbc hcd hac { exact hac.tail hcd }
end

lemma single (hab : r a b) : refl_trans_gen r a b :=
refl.tail hab

lemma head (hab : r a b) (hbc : refl_trans_gen r b c) : refl_trans_gen r a c :=
begin
  induction hbc,
  case refl_trans_gen.refl { exact refl.tail hab },
  case refl_trans_gen.tail : c d hbc hcd hac { exact hac.tail hcd }
end

lemma cases_tail : refl_trans_gen r a b → b = a ∨ (∃c, refl_trans_gen r a c ∧ r c b) :=
(cases_tail_iff r a b).1

lemma head_induction_on
  {P : ∀(a:α), refl_trans_gen r a b → Prop}
  {a : α} (h : refl_trans_gen r a b)
  (refl : P b refl)
  (head : ∀{a c} (h' : r a c) (h : refl_trans_gen r c b), P c h → P a (h.head h')) :
  P a h :=
begin
  induction h generalizing P,
  case refl_trans_gen.refl { exact refl },
  case refl_trans_gen.tail : b c hab hbc ih {
    apply ih,
    show P b _, from head hbc _ refl,
    show ∀a a', r a a' → refl_trans_gen r a' b → P a' _ → P a _, from assume a a' hab hbc, head hab _
  }
end

lemma trans_induction_on
  {P : ∀{a b : α}, refl_trans_gen r a b → Prop}
  {a b : α} (h : refl_trans_gen r a b)
  (ih₁ : ∀a, @P a a refl)
  (ih₂ : ∀{a b} (h : r a b), P (single h))
  (ih₃ : ∀{a b c} (h₁ : refl_trans_gen r a b) (h₂ : refl_trans_gen r b c), P h₁ → P h₂ → P (h₁.trans h₂)) :
  P h :=
begin
  induction h,
  case refl_trans_gen.refl { exact ih₁ a },
  case refl_trans_gen.tail : b c hab hbc ih { exact ih₃ hab (single hbc) ih (ih₂ hbc) }
end

lemma cases_head (h : refl_trans_gen r a b) : a = b ∨ (∃c, r a c ∧ refl_trans_gen r c b) :=
begin
  induction h using relation.refl_trans_gen.head_induction_on,
  { left, refl },
  { right, existsi _, split; assumption }
end

lemma cases_head_iff : refl_trans_gen r a b ↔ a = b ∨ (∃c, r a c ∧ refl_trans_gen r c b) :=
begin
  split,
  { exact cases_head },
  { assume h,
    rcases h with rfl | ⟨c, hac, hcb⟩,
    { refl },
    { exact head hac hcb } }
end

lemma total_of_right_unique (U : relator.right_unique r)
  (ab : refl_trans_gen r a b) (ac : refl_trans_gen r a c) :
  refl_trans_gen r b c ∨ refl_trans_gen r c b :=
begin
  induction ab with b d ab bd IH,
  { exact or.inl ac },
  { rcases IH with IH | IH,
    { rcases cases_head IH with rfl | ⟨e, be, ec⟩,
      { exact or.inr (single bd) },
      { cases U bd be, exact or.inl ec } },
    { exact or.inr (IH.tail bd) } }
end

end refl_trans_gen

namespace trans_gen

lemma to_refl {a b} (h : trans_gen r a b) : refl_trans_gen r a b :=
begin
  induction h with b h b c _ bc ab,
  exact refl_trans_gen.single h,
  exact refl_trans_gen.tail ab bc
end

@[trans] lemma trans_left (hab : trans_gen r a b) (hbc : refl_trans_gen r b c) : trans_gen r a c :=
begin
  induction hbc,
  case refl_trans_gen.refl : c hab { assumption },
  case refl_trans_gen.tail : c d hbc hcd hac { exact hac.tail hcd }
end

@[trans] lemma trans (hab : trans_gen r a b) (hbc : trans_gen r b c) : trans_gen r a c :=
trans_left hab hbc.to_refl

lemma head' (hab : r a b) (hbc : refl_trans_gen r b c) : trans_gen r a c :=
trans_left (single hab) hbc

lemma tail' (hab : refl_trans_gen r a b) (hbc : r b c) : trans_gen r a c :=
begin
  induction hab generalizing c,
  case refl_trans_gen.refl : c hac { exact single hac },
  case refl_trans_gen.tail : d b hab hdb IH { exact tail (IH hdb) hbc }
end

@[trans] lemma trans_right (hab : refl_trans_gen r a b) (hbc : trans_gen r b c) : trans_gen r a c :=
begin
  induction hbc,
  case trans_gen.single : c hbc { exact tail' hab hbc },
  case trans_gen.tail : c d hbc hcd hac { exact hac.tail hcd }
end

lemma head (hab : r a b) (hbc : trans_gen r b c) : trans_gen r a c :=
head' hab hbc.to_refl

lemma tail'_iff : trans_gen r a c ↔ ∃ b, refl_trans_gen r a b ∧ r b c :=
begin
  refine ⟨λ h, _, λ ⟨b, hab, hbc⟩, tail' hab hbc⟩,
  cases h with _ hac b _ hab hbc,
  { exact ⟨_, by refl, hac⟩ },
  { exact ⟨_, hab.to_refl, hbc⟩ }
end

lemma head'_iff : trans_gen r a c ↔ ∃ b, r a b ∧ refl_trans_gen r b c :=
begin
  refine ⟨λ h, _, λ ⟨b, hab, hbc⟩, head' hab hbc⟩,
  induction h,
  case trans_gen.single : c hac { exact ⟨_, hac, by refl⟩ },
  case trans_gen.tail : b c hab hbc IH {
    rcases IH with ⟨d, had, hdb⟩, exact ⟨_, had, hdb.tail hbc⟩ }
end

end trans_gen

section refl_trans_gen
open refl_trans_gen

lemma refl_trans_gen_iff_eq (h : ∀b, ¬ r a b) : refl_trans_gen r a b ↔ b = a :=
by rw [cases_head_iff]; simp [h, eq_comm]

lemma refl_trans_gen_iff_eq_or_trans_gen :
  refl_trans_gen r a b ↔ b = a ∨ trans_gen r a b :=
begin
  refine ⟨λ h, _, λ h, _⟩,
  { cases h with c _ hac hcb,
    { exact or.inl rfl },
    { exact or.inr (trans_gen.tail' hac hcb) } },
  { rcases h with rfl | h, {refl}, {exact h.to_refl} }
end

lemma refl_trans_gen_lift {p : β → β → Prop} {a b : α} (f : α → β)
  (h : ∀a b, r a b → p (f a) (f b)) (hab : refl_trans_gen r a b) : refl_trans_gen p (f a) (f b) :=
hab.trans_induction_on (assume a, refl) (assume a b, refl_trans_gen.single ∘ h _ _) (assume a b c _ _, trans)

lemma refl_trans_gen_mono {p : α → α → Prop} :
  (∀a b, r a b → p a b) → refl_trans_gen r a b → refl_trans_gen p a b :=
refl_trans_gen_lift id

lemma refl_trans_gen_eq_self (refl : reflexive r) (trans : transitive r) :
  refl_trans_gen r = r :=
funext $ λ a, funext $ λ b, propext $
⟨λ h, begin
  induction h with b c h₁ h₂ IH, {apply refl},
  exact trans IH h₂,
end, single⟩

lemma reflexive_refl_trans_gen : reflexive (refl_trans_gen r) :=
assume a, refl

lemma transitive_refl_trans_gen : transitive (refl_trans_gen r) :=
assume a b c, trans

lemma refl_trans_gen_idem :
  refl_trans_gen (refl_trans_gen r) = refl_trans_gen r :=
refl_trans_gen_eq_self reflexive_refl_trans_gen transitive_refl_trans_gen

lemma refl_trans_gen_lift' {p : β → β → Prop} {a b : α} (f : α → β)
  (h : ∀a b, r a b → refl_trans_gen p (f a) (f b)) (hab : refl_trans_gen r a b) : refl_trans_gen p (f a) (f b) :=
by simpa [refl_trans_gen_idem] using refl_trans_gen_lift f h hab

lemma refl_trans_gen_closed {p : α → α → Prop} :
  (∀ a b, r a b → refl_trans_gen p a b) → refl_trans_gen r a b → refl_trans_gen p a b :=
refl_trans_gen_lift' id

end refl_trans_gen

def join (r : α → α → Prop) : α → α → Prop := λa b, ∃c, r a c ∧ r b c

section join
open refl_trans_gen refl_gen

lemma church_rosser
  (h : ∀a b c, r a b → r a c → ∃d, refl_gen r b d ∧ refl_trans_gen r c d)
  (hab : refl_trans_gen r a b) (hac : refl_trans_gen r a c) : join (refl_trans_gen r) b c :=
begin
  induction hab,
  case refl_trans_gen.refl { exact ⟨c, hac, refl⟩ },
  case refl_trans_gen.tail : d e had hde ih {
    clear hac had a,
    rcases ih with ⟨b, hdb, hcb⟩,
    have : ∃a, refl_trans_gen r e a ∧ refl_gen r b a,
    { clear hcb, induction hdb,
      case refl_trans_gen.refl { exact ⟨e, refl, refl_gen.single hde⟩ },
      case refl_trans_gen.tail : f b hdf hfb ih {
        rcases ih with ⟨a, hea, hfa⟩,
        cases hfa with _ hfa,
        { exact ⟨b, hea.tail hfb, refl_gen.refl⟩ },
        { rcases h _ _ _ hfb hfa with ⟨c, hbc, hac⟩,
          exact ⟨c, hea.trans hac, hbc⟩ } } },
    rcases this with ⟨a, hea, hba⟩, cases hba with _ hba,
    { exact ⟨b, hea, hcb⟩ },
    { exact ⟨a, hea, hcb.tail hba⟩ } }
end

lemma join_of_single (h : reflexive r) (hab : r a b) : join r a b :=
⟨b, hab, h b⟩

lemma symmetric_join : symmetric (join r) :=
assume a b ⟨c, hac, hcb⟩, ⟨c, hcb, hac⟩

lemma reflexive_join (h : reflexive r) : reflexive (join r) :=
assume a, ⟨a, h a, h a⟩

lemma transitive_join (ht : transitive r) (h : ∀a b c, r a b → r a c → join r b c) :
  transitive (join r) :=
assume a b c ⟨x, hax, hbx⟩ ⟨y, hby, hcy⟩,
let ⟨z, hxz, hyz⟩ := h b x y hbx hby in
⟨z, ht hax hxz, ht hcy hyz⟩

lemma equivalence_join (hr : reflexive r)  (ht : transitive r) (h : ∀a b c, r a b → r a c → join r b c) :
  equivalence (join r) :=
⟨reflexive_join hr, symmetric_join, transitive_join ht h⟩

lemma equivalence_join_refl_trans_gen
  (h : ∀a b c, r a b → r a c → ∃d, refl_gen r b d ∧ refl_trans_gen r c d) :
  equivalence (join (refl_trans_gen r)) :=
equivalence_join reflexive_refl_trans_gen transitive_refl_trans_gen (assume a b c, church_rosser h)

lemma join_of_equivalence {r' : α → α → Prop} (hr : equivalence r)
  (h : ∀a b, r' a b → r a b) : join r' a b → r a b
| ⟨c, hac, hbc⟩ := hr.2.2 (h _ _ hac) (hr.2.1 $ h _ _ hbc)

lemma refl_trans_gen_of_transitive_reflexive {r' : α → α → Prop} (hr : reflexive r) (ht : transitive r)
  (h : ∀a b, r' a b → r a b) (h' : refl_trans_gen r' a b) : r a b :=
begin
  induction h' with b c hab hbc ih,
  { exact hr _ },
  { exact ht ih (h _ _ hbc) }
end

lemma refl_trans_gen_of_equivalence {r' : α → α → Prop} (hr : equivalence r) :
  (∀a b, r' a b → r a b) → refl_trans_gen r' a b → r a b :=
refl_trans_gen_of_transitive_reflexive hr.1 hr.2.2

end join

section eqv_gen

lemma eqv_gen_iff_of_equivalence (h : equivalence r) : eqv_gen r a b ↔ r a b :=
iff.intro
  begin
    assume h,
    induction h,
    case eqv_gen.rel { assumption },
    case eqv_gen.refl { exact h.1 _ },
    case eqv_gen.symm { apply h.2.1, assumption },
    case eqv_gen.trans : a b c _ _ hab hbc {  exact h.2.2 hab hbc }
  end
  (eqv_gen.rel a b)

lemma eqv_gen_mono {r p : α → α → Prop}
  (hrp : ∀a b, r a b → p a b) (h : eqv_gen r a b) : eqv_gen p a b :=
begin
  induction h,
  case eqv_gen.rel : a b h { exact eqv_gen.rel _ _ (hrp _ _ h) },
  case eqv_gen.refl : { exact eqv_gen.refl _ },
  case eqv_gen.symm : a b h ih { exact eqv_gen.symm _ _ ih },
  case eqv_gen.trans : a b c ih1 ih2 hab hbc { exact eqv_gen.trans _ _ _ hab hbc }
end

end eqv_gen

end relation


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

! This file was ported from Lean 3 source module topology.algebra.group.compact
! leanprover-community/mathlib commit f2ce6086713c78a7f880485f7917ea547a215982
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Topology.Algebra.Group.Basic
import Mathlib.Topology.CompactOpen
import Mathlib.Topology.Sets.Compacts

/-!
# Additional results on topological groups

Two results on topological groups that have been separated out as they require more substantial
imports developing either positive compacts or the compact open topology.

-/

open Classical Set Filter TopologicalSpace Function

open Classical Topology Filter Pointwise

universe u v w x

variable {α : Type u} {β : Type v} {G : Type w} {H : Type x}

section

/-! Some results about an open set containing the product of two sets in a topological group. -/

variable [TopologicalSpace G] [Group G] [TopologicalGroup G]

/-- Every separated topological group in which there exists a compact set with nonempty interior
is locally compact. -/
@[to_additive
      "Every separated topological group in which there exists a compact set with nonempty
      interior is locally compact."]
theorem TopologicalSpace.PositiveCompacts.locallyCompactSpace_of_Group [T2Space G]
    (K : PositiveCompacts G) : LocallyCompactSpace G := by
  refine' locally_compact_of_compact_nhds fun x => _
  obtain ⟨y, hy⟩ := K.interior_nonempty
  let F := Homeomorph.mulLeft (x * y⁻¹)
  refine' ⟨F '' K, _, K.isCompact.image F.continuous⟩
  suffices F.symm ⁻¹' K ∈ 𝓝 x by
    convert this using 1
    apply Equiv.image_eq_preimage
  apply ContinuousAt.preimage_mem_nhds F.symm.continuous.continuousAt
  have : F.symm x = y := by simp only [Homeomorph.mulLeft_symm, mul_inv_rev,
      inv_inv, Homeomorph.coe_mulLeft, inv_mul_cancel_right]
  rw [this]
  exact mem_interior_iff_mem_nhds.1 hy
#align topological_space.positive_compacts.locally_compact_space_of_group TopologicalSpace.PositiveCompacts.locallyCompactSpace_of_Group
#align topological_space.positive_compacts.locally_compact_space_of_add_group TopologicalSpace.PositiveCompacts.locallyCompactSpace_of_AddGroup

end

section Quotient

variable [Group G] [TopologicalSpace G] [TopologicalGroup G] {Γ : Subgroup G}

@[to_additive]
instance QuotientGroup.continuousSMul [LocallyCompactSpace G] : ContinuousSMul G (G ⧸ Γ)
    where
  continuous_smul := by
    let F : G × G ⧸ Γ → G ⧸ Γ := fun p => p.1 • p.2
    change Continuous F
    have H : Continuous (F ∘ fun p : G × G => (p.1, QuotientGroup.mk p.2)) :=
      by
      change Continuous fun p : G × G => QuotientGroup.mk (p.1 * p.2)
      refine' continuous_coinduced_rng.comp continuous_mul
    exact QuotientMap.continuous_lift_prod_right quotientMap_quotient_mk' H
#align quotient_group.has_continuous_smul QuotientGroup.continuousSMul
#align quotient_add_group.has_continuous_vadd QuotientAddGroup.continuousVAdd

end Quotient


/-
Copyright (c) 2020 Johan Commelin and Robert Y. Lewis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin and Robert Y. Lewis
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.padics.padic_integers
import Mathlib.PostPort

universes u_1

namespace Mathlib

/-!

# Relating `ℤ_[p]` to `zmod (p ^ n)`

In this file we establish connections between the `p`-adic integers $\mathbb{Z}_p$
and the integers modulo powers of `p`, $\mathbb{Z}/p^n\mathbb{Z}$.

## Main declarations

We show that $\mathbb{Z}_p$ has a ring hom to $\mathbb{Z}/p^n\mathbb{Z}$ for each `n`.
The case for `n = 1` is handled separately, since it is used in the general construction
and we may want to use it without the `^1` getting in the way.
* `padic_int.to_zmod`: ring hom to `zmod p`
* `padic_int.to_zmod_pow`: ring hom to `zmod (p^n)`
* `padic_int.ker_to_zmod` / `padic_int.ker_to_zmod_pow`: the kernels of these maps are the ideals
  generated by `p^n`

We also establish the universal property of $\mathbb{Z}_p$ as a projective limit.
Given a family of compatible ring homs $f_k : R \to \mathbb{Z}/p^n\mathbb{Z}$,
there is a unique limit $R \to \mathbb{Z}_p$.
* `padic_int.lift`: the limit function
* `padic_int.lift_spec` / `padic_int.lift_unique`: the universal property

## Implementation notes

The ring hom constructions go through an auxiliary constructor `padic_int.to_zmod_hom`,
which removes some boilerplate code.

-/

namespace padic_int

/-! ### Ring homomorphisms to `zmod p` and `zmod (p ^ n)` -/

/--
`mod_part p r` is an integer that satisfies
`∥(r - mod_part p r : ℚ_[p])∥ < 1` when `∥(r : ℚ_[p])∥ ≤ 1`,
see `padic_int.norm_sub_mod_part`.
It is the unique non-negative integer that is `< p` with this property.

(Note that this definition assumes `r : ℚ`.
See `padic_int.zmod_repr` for a version that takes values in `ℕ`
and works for arbitrary `x : ℤ_[p]`.) -/
def mod_part (p : ℕ) (r : ℚ) : ℤ := rat.num r * nat.gcd_a (rat.denom r) p % ↑p

theorem mod_part_lt_p {p : ℕ} [hp_prime : fact (nat.prime p)] (r : ℚ) : mod_part p r < ↑p := sorry

theorem mod_part_nonneg {p : ℕ} [hp_prime : fact (nat.prime p)] (r : ℚ) : 0 ≤ mod_part p r := sorry

theorem is_unit_denom {p : ℕ} [hp_prime : fact (nat.prime p)] (r : ℚ) (h : norm ↑r ≤ 1) :
    is_unit ↑(rat.denom r) :=
  sorry

theorem norm_sub_mod_part_aux {p : ℕ} [hp_prime : fact (nat.prime p)] (r : ℚ) (h : norm ↑r ≤ 1) :
    ↑p ∣ rat.num r - rat.num r * nat.gcd_a (rat.denom r) p % ↑p * ↑(rat.denom r) :=
  sorry

theorem norm_sub_mod_part {p : ℕ} [hp_prime : fact (nat.prime p)] (r : ℚ) (h : norm ↑r ≤ 1) :
    norm ({ val := ↑r, property := h } - ↑(mod_part p r)) < 1 :=
  sorry

theorem exists_mem_range_of_norm_rat_le_one {p : ℕ} [hp_prime : fact (nat.prime p)] (r : ℚ)
    (h : norm ↑r ≤ 1) : ∃ (n : ℤ), 0 ≤ n ∧ n < ↑p ∧ norm ({ val := ↑r, property := h } - ↑n) < 1 :=
  Exists.intro (mod_part p r)
    { left := mod_part_nonneg r,
      right := { left := mod_part_lt_p r, right := norm_sub_mod_part r h } }

theorem zmod_congr_of_sub_mem_span_aux {p : ℕ} [hp_prime : fact (nat.prime p)] (n : ℕ)
    (x : padic_int p) (a : ℤ) (b : ℤ) (ha : x - ↑a ∈ ideal.span (singleton (↑p ^ n)))
    (hb : x - ↑b ∈ ideal.span (singleton (↑p ^ n))) : ↑a = ↑b :=
  sorry

theorem zmod_congr_of_sub_mem_span {p : ℕ} [hp_prime : fact (nat.prime p)] (n : ℕ) (x : padic_int p)
    (a : ℕ) (b : ℕ) (ha : x - ↑a ∈ ideal.span (singleton (↑p ^ n)))
    (hb : x - ↑b ∈ ideal.span (singleton (↑p ^ n))) : ↑a = ↑b :=
  zmod_congr_of_sub_mem_span_aux n x (↑a) (↑b) ha hb

theorem zmod_congr_of_sub_mem_max_ideal {p : ℕ} [hp_prime : fact (nat.prime p)] (x : padic_int p)
    (m : ℕ) (n : ℕ) (hm : x - ↑m ∈ local_ring.maximal_ideal (padic_int p))
    (hn : x - ↑n ∈ local_ring.maximal_ideal (padic_int p)) : ↑m = ↑n :=
  sorry

theorem exists_mem_range {p : ℕ} [hp_prime : fact (nat.prime p)] (x : padic_int p) :
    ∃ (n : ℕ), n < p ∧ x - ↑n ∈ local_ring.maximal_ideal (padic_int p) :=
  sorry

/--
`zmod_repr x` is the unique natural number smaller than `p`
satisfying `∥(x - zmod_repr x : ℤ_[p])∥ < 1`.
-/
def zmod_repr {p : ℕ} [hp_prime : fact (nat.prime p)] (x : padic_int p) : ℕ :=
  classical.some (exists_mem_range x)

theorem zmod_repr_spec {p : ℕ} [hp_prime : fact (nat.prime p)] (x : padic_int p) :
    zmod_repr x < p ∧ x - ↑(zmod_repr x) ∈ local_ring.maximal_ideal (padic_int p) :=
  classical.some_spec (exists_mem_range x)

theorem zmod_repr_lt_p {p : ℕ} [hp_prime : fact (nat.prime p)] (x : padic_int p) :
    zmod_repr x < p :=
  and.left (zmod_repr_spec x)

theorem sub_zmod_repr_mem {p : ℕ} [hp_prime : fact (nat.prime p)] (x : padic_int p) :
    x - ↑(zmod_repr x) ∈ local_ring.maximal_ideal (padic_int p) :=
  and.right (zmod_repr_spec x)

/--
`to_zmod_hom` is an auxiliary constructor for creating ring homs from `ℤ_[p]` to `zmod v`.
-/
def to_zmod_hom {p : ℕ} [hp_prime : fact (nat.prime p)] (v : ℕ) (f : padic_int p → ℕ)
    (f_spec : ∀ (x : padic_int p), x - ↑(f x) ∈ ideal.span (singleton ↑v))
    (f_congr :
      ∀ (x : padic_int p) (a b : ℕ),
        x - ↑a ∈ ideal.span (singleton ↑v) → x - ↑b ∈ ideal.span (singleton ↑v) → ↑a = ↑b) :
    padic_int p →+* zmod v :=
  ring_hom.mk (fun (x : padic_int p) => ↑(f x)) sorry sorry sorry sorry

/--
`to_zmod` is a ring hom from `ℤ_[p]` to `zmod p`,
with the equality `to_zmod x = (zmod_repr x : zmod p)`.
-/
def to_zmod {p : ℕ} [hp_prime : fact (nat.prime p)] : padic_int p →+* zmod p :=
  to_zmod_hom p zmod_repr sorry sorry

/--
`z - (to_zmod z : ℤ_[p])` is contained in the maximal ideal of `ℤ_[p]`, for every `z : ℤ_[p]`.

The coercion from `zmod p` to `ℤ_[p]` is `zmod.has_coe_t`,
which coerces `zmod p` into artibrary rings.
This is unfortunate, but a consequence of the fact that we allow `zmod p`
to coerce to rings of arbitrary characteristic, instead of only rings of characteristic `p`.
This coercion is only a ring homomorphism if it coerces into a ring whose characteristic divides
`p`. While this is not the case here we can still make use of the coercion.
-/
theorem to_zmod_spec {p : ℕ} [hp_prime : fact (nat.prime p)] (z : padic_int p) :
    z - ↑(coe_fn to_zmod z) ∈ local_ring.maximal_ideal (padic_int p) :=
  sorry

theorem ker_to_zmod {p : ℕ} [hp_prime : fact (nat.prime p)] :
    ring_hom.ker to_zmod = local_ring.maximal_ideal (padic_int p) :=
  sorry

/-- `appr n x` gives a value `v : ℕ` such that `x` and `↑v : ℤ_p` are congruent mod `p^n`.
See `appr_spec`. -/
def appr {p : ℕ} [hp_prime : fact (nat.prime p)] : padic_int p → ℕ → ℕ := sorry

theorem appr_lt {p : ℕ} [hp_prime : fact (nat.prime p)] (x : padic_int p) (n : ℕ) :
    appr x n < p ^ n :=
  sorry

theorem appr_mono {p : ℕ} [hp_prime : fact (nat.prime p)] (x : padic_int p) : monotone (appr x) :=
  sorry

theorem dvd_appr_sub_appr {p : ℕ} [hp_prime : fact (nat.prime p)] (x : padic_int p) (m : ℕ) (n : ℕ)
    (h : m ≤ n) : p ^ m ∣ appr x n - appr x m :=
  sorry

theorem appr_spec {p : ℕ} [hp_prime : fact (nat.prime p)] (n : ℕ) (x : padic_int p) :
    x - ↑(appr x n) ∈ ideal.span (singleton (↑p ^ n)) :=
  sorry

/-- A ring hom from `ℤ_[p]` to `zmod (p^n)`, with underlying function `padic_int.appr n`. -/
def to_zmod_pow {p : ℕ} [hp_prime : fact (nat.prime p)] (n : ℕ) : padic_int p →+* zmod (p ^ n) :=
  to_zmod_hom (p ^ n) (fun (x : padic_int p) => appr x n) sorry sorry

theorem ker_to_zmod_pow {p : ℕ} [hp_prime : fact (nat.prime p)] (n : ℕ) :
    ring_hom.ker (to_zmod_pow n) = ideal.span (singleton (↑p ^ n)) :=
  sorry

@[simp] theorem zmod_cast_comp_to_zmod_pow {p : ℕ} [hp_prime : fact (nat.prime p)] (m : ℕ) (n : ℕ)
    (h : m ≤ n) :
    ring_hom.comp (zmod.cast_hom (pow_dvd_pow p h) (zmod (p ^ m))) (to_zmod_pow n) =
        to_zmod_pow m :=
  sorry

@[simp] theorem cast_to_zmod_pow {p : ℕ} [hp_prime : fact (nat.prime p)] (m : ℕ) (n : ℕ) (h : m ≤ n)
    (x : padic_int p) : ↑(coe_fn (to_zmod_pow n) x) = coe_fn (to_zmod_pow m) x :=
  sorry

theorem dense_range_nat_cast {p : ℕ} [hp_prime : fact (nat.prime p)] : dense_range nat.cast := sorry

theorem dense_range_int_cast {p : ℕ} [hp_prime : fact (nat.prime p)] : dense_range int.cast := sorry

/-! ### Universal property as projective limit -/

/--
Given a family of ring homs `f : Π n : ℕ, R →+* zmod (p ^ n)`,
`nth_hom f r` is an integer-valued sequence
whose `n`th value is the unique integer `k` such that `0 ≤ k < p ^ n`
and `f n r = (k : zmod (p ^ n))`.
-/
def nth_hom {p : ℕ} {R : Type u_1} [comm_ring R] (f : (k : ℕ) → R →+* zmod (p ^ k)) (r : R) :
    ℕ → ℤ :=
  fun (n : ℕ) => ↑(zmod.val (coe_fn (f n) r))

@[simp] theorem nth_hom_zero {p : ℕ} {R : Type u_1} [comm_ring R]
    (f : (k : ℕ) → R →+* zmod (p ^ k)) : nth_hom f 0 = 0 :=
  sorry

theorem pow_dvd_nth_hom_sub {p : ℕ} [hp_prime : fact (nat.prime p)] {R : Type u_1} [comm_ring R]
    {f : (k : ℕ) → R →+* zmod (p ^ k)}
    (f_compat :
      ∀ (k1 k2 : ℕ) (hk : k1 ≤ k2),
        ring_hom.comp (zmod.cast_hom (pow_dvd_pow p hk) (zmod (p ^ k1))) (f k2) = f k1)
    (r : R) (i : ℕ) (j : ℕ) (h : i ≤ j) : ↑p ^ i ∣ nth_hom f r j - nth_hom f r i :=
  sorry

theorem is_cau_seq_nth_hom {p : ℕ} [hp_prime : fact (nat.prime p)] {R : Type u_1} [comm_ring R]
    {f : (k : ℕ) → R →+* zmod (p ^ k)}
    (f_compat :
      ∀ (k1 k2 : ℕ) (hk : k1 ≤ k2),
        ring_hom.comp (zmod.cast_hom (pow_dvd_pow p hk) (zmod (p ^ k1))) (f k2) = f k1)
    (r : R) : is_cau_seq (padic_norm p) fun (n : ℕ) => ↑(nth_hom f r n) :=
  sorry

/--
`nth_hom_seq f_compat r` bundles `padic_int.nth_hom f r`
as a Cauchy sequence of rationals with respect to the `p`-adic norm.
The `n`th value of the sequence is `((f n r).val : ℚ)`.
-/
def nth_hom_seq {p : ℕ} [hp_prime : fact (nat.prime p)] {R : Type u_1} [comm_ring R]
    {f : (k : ℕ) → R →+* zmod (p ^ k)}
    (f_compat :
      ∀ (k1 k2 : ℕ) (hk : k1 ≤ k2),
        ring_hom.comp (zmod.cast_hom (pow_dvd_pow p hk) (zmod (p ^ k1))) (f k2) = f k1)
    (r : R) : padic_seq p :=
  { val := fun (n : ℕ) => ↑(nth_hom f r n), property := is_cau_seq_nth_hom f_compat r }

theorem nth_hom_seq_one {p : ℕ} [hp_prime : fact (nat.prime p)] {R : Type u_1} [comm_ring R]
    {f : (k : ℕ) → R →+* zmod (p ^ k)}
    (f_compat :
      ∀ (k1 k2 : ℕ) (hk : k1 ≤ k2),
        ring_hom.comp (zmod.cast_hom (pow_dvd_pow p hk) (zmod (p ^ k1))) (f k2) = f k1) :
    nth_hom_seq f_compat 1 ≈ 1 :=
  sorry

theorem nth_hom_seq_add {p : ℕ} [hp_prime : fact (nat.prime p)] {R : Type u_1} [comm_ring R]
    {f : (k : ℕ) → R →+* zmod (p ^ k)}
    (f_compat :
      ∀ (k1 k2 : ℕ) (hk : k1 ≤ k2),
        ring_hom.comp (zmod.cast_hom (pow_dvd_pow p hk) (zmod (p ^ k1))) (f k2) = f k1)
    (r : R) (s : R) :
    nth_hom_seq f_compat (r + s) ≈ nth_hom_seq f_compat r + nth_hom_seq f_compat s :=
  sorry

theorem nth_hom_seq_mul {p : ℕ} [hp_prime : fact (nat.prime p)] {R : Type u_1} [comm_ring R]
    {f : (k : ℕ) → R →+* zmod (p ^ k)}
    (f_compat :
      ∀ (k1 k2 : ℕ) (hk : k1 ≤ k2),
        ring_hom.comp (zmod.cast_hom (pow_dvd_pow p hk) (zmod (p ^ k1))) (f k2) = f k1)
    (r : R) (s : R) :
    nth_hom_seq f_compat (r * s) ≈ nth_hom_seq f_compat r * nth_hom_seq f_compat s :=
  sorry

/--
`lim_nth_hom f_compat r` is the limit of a sequence `f` of compatible ring homs `R →+* zmod (p^k)`.
This is itself a ring hom: see `padic_int.lift`.
-/
def lim_nth_hom {p : ℕ} [hp_prime : fact (nat.prime p)] {R : Type u_1} [comm_ring R]
    {f : (k : ℕ) → R →+* zmod (p ^ k)}
    (f_compat :
      ∀ (k1 k2 : ℕ) (hk : k1 ≤ k2),
        ring_hom.comp (zmod.cast_hom (pow_dvd_pow p hk) (zmod (p ^ k1))) (f k2) = f k1)
    (r : R) : padic_int p :=
  of_int_seq (nth_hom f r) (is_cau_seq_nth_hom f_compat r)

theorem lim_nth_hom_spec {p : ℕ} [hp_prime : fact (nat.prime p)] {R : Type u_1} [comm_ring R]
    {f : (k : ℕ) → R →+* zmod (p ^ k)}
    (f_compat :
      ∀ (k1 k2 : ℕ) (hk : k1 ≤ k2),
        ring_hom.comp (zmod.cast_hom (pow_dvd_pow p hk) (zmod (p ^ k1))) (f k2) = f k1)
    (r : R) (ε : ℝ) :
    0 < ε → ∃ (N : ℕ), ∀ (n : ℕ), n ≥ N → norm (lim_nth_hom f_compat r - ↑(nth_hom f r n)) < ε :=
  sorry

theorem lim_nth_hom_zero {p : ℕ} [hp_prime : fact (nat.prime p)] {R : Type u_1} [comm_ring R]
    {f : (k : ℕ) → R →+* zmod (p ^ k)}
    (f_compat :
      ∀ (k1 k2 : ℕ) (hk : k1 ≤ k2),
        ring_hom.comp (zmod.cast_hom (pow_dvd_pow p hk) (zmod (p ^ k1))) (f k2) = f k1) :
    lim_nth_hom f_compat 0 = 0 :=
  sorry

theorem lim_nth_hom_one {p : ℕ} [hp_prime : fact (nat.prime p)] {R : Type u_1} [comm_ring R]
    {f : (k : ℕ) → R →+* zmod (p ^ k)}
    (f_compat :
      ∀ (k1 k2 : ℕ) (hk : k1 ≤ k2),
        ring_hom.comp (zmod.cast_hom (pow_dvd_pow p hk) (zmod (p ^ k1))) (f k2) = f k1) :
    lim_nth_hom f_compat 1 = 1 :=
  subtype.ext (quot.sound (nth_hom_seq_one f_compat))

theorem lim_nth_hom_add {p : ℕ} [hp_prime : fact (nat.prime p)] {R : Type u_1} [comm_ring R]
    {f : (k : ℕ) → R →+* zmod (p ^ k)}
    (f_compat :
      ∀ (k1 k2 : ℕ) (hk : k1 ≤ k2),
        ring_hom.comp (zmod.cast_hom (pow_dvd_pow p hk) (zmod (p ^ k1))) (f k2) = f k1)
    (r : R) (s : R) :
    lim_nth_hom f_compat (r + s) = lim_nth_hom f_compat r + lim_nth_hom f_compat s :=
  subtype.ext (quot.sound (nth_hom_seq_add f_compat r s))

theorem lim_nth_hom_mul {p : ℕ} [hp_prime : fact (nat.prime p)] {R : Type u_1} [comm_ring R]
    {f : (k : ℕ) → R →+* zmod (p ^ k)}
    (f_compat :
      ∀ (k1 k2 : ℕ) (hk : k1 ≤ k2),
        ring_hom.comp (zmod.cast_hom (pow_dvd_pow p hk) (zmod (p ^ k1))) (f k2) = f k1)
    (r : R) (s : R) :
    lim_nth_hom f_compat (r * s) = lim_nth_hom f_compat r * lim_nth_hom f_compat s :=
  subtype.ext (quot.sound (nth_hom_seq_mul f_compat r s))

-- TODO: generalize this to arbitrary complete discrete valuation rings

/--
`lift f_compat` is the limit of a sequence `f` of compatible ring homs `R →+* zmod (p^k)`,
with the equality `lift f_compat r = padic_int.lim_nth_hom f_compat r`.
-/
def lift {p : ℕ} [hp_prime : fact (nat.prime p)] {R : Type u_1} [comm_ring R]
    {f : (k : ℕ) → R →+* zmod (p ^ k)}
    (f_compat :
      ∀ (k1 k2 : ℕ) (hk : k1 ≤ k2),
        ring_hom.comp (zmod.cast_hom (pow_dvd_pow p hk) (zmod (p ^ k1))) (f k2) = f k1) :
    R →+* padic_int p :=
  ring_hom.mk (lim_nth_hom f_compat) sorry sorry sorry sorry

theorem lift_sub_val_mem_span {p : ℕ} [hp_prime : fact (nat.prime p)] {R : Type u_1} [comm_ring R]
    {f : (k : ℕ) → R →+* zmod (p ^ k)}
    (f_compat :
      ∀ (k1 k2 : ℕ) (hk : k1 ≤ k2),
        ring_hom.comp (zmod.cast_hom (pow_dvd_pow p hk) (zmod (p ^ k1))) (f k2) = f k1)
    (r : R) (n : ℕ) :
    coe_fn (lift f_compat) r - ↑(zmod.val (coe_fn (f n) r)) ∈ ideal.span (singleton (↑p ^ n)) :=
  sorry

/--
One part of the universal property of `ℤ_[p]` as a projective limit.
See also `padic_int.lift_unique`.
-/
theorem lift_spec {p : ℕ} [hp_prime : fact (nat.prime p)] {R : Type u_1} [comm_ring R]
    {f : (k : ℕ) → R →+* zmod (p ^ k)}
    (f_compat :
      ∀ (k1 k2 : ℕ) (hk : k1 ≤ k2),
        ring_hom.comp (zmod.cast_hom (pow_dvd_pow p hk) (zmod (p ^ k1))) (f k2) = f k1)
    (n : ℕ) : ring_hom.comp (to_zmod_pow n) (lift f_compat) = f n :=
  sorry

/--
One part of the universal property of `ℤ_[p]` as a projective limit.
See also `padic_int.lift_spec`.
-/
theorem lift_unique {p : ℕ} [hp_prime : fact (nat.prime p)] {R : Type u_1} [comm_ring R]
    {f : (k : ℕ) → R →+* zmod (p ^ k)}
    (f_compat :
      ∀ (k1 k2 : ℕ) (hk : k1 ≤ k2),
        ring_hom.comp (zmod.cast_hom (pow_dvd_pow p hk) (zmod (p ^ k1))) (f k2) = f k1)
    (g : R →+* padic_int p) (hg : ∀ (n : ℕ), ring_hom.comp (to_zmod_pow n) g = f n) :
    lift f_compat = g :=
  sorry

@[simp] theorem lift_self {p : ℕ} [hp_prime : fact (nat.prime p)] (z : padic_int p) :
    coe_fn (lift zmod_cast_comp_to_zmod_pow) z = z :=
  sorry

theorem ext_of_to_zmod_pow {p : ℕ} [hp_prime : fact (nat.prime p)] {x : padic_int p}
    {y : padic_int p} : (∀ (n : ℕ), coe_fn (to_zmod_pow n) x = coe_fn (to_zmod_pow n) y) ↔ x = y :=
  sorry

theorem to_zmod_pow_eq_iff_ext {p : ℕ} [hp_prime : fact (nat.prime p)] {R : Type u_1} [comm_ring R]
    {g : R →+* padic_int p} {g' : R →+* padic_int p} :
    (∀ (n : ℕ), ring_hom.comp (to_zmod_pow n) g = ring_hom.comp (to_zmod_pow n) g') ↔ g = g' :=
  sorry

end Mathlib


import data.nat.basic

def mul (n m : ℕ) : ℕ :=
  nat.rec_on m
    0
    (λ _ m, n + m)

#reduce mul 2 5

#print nat.rec
#print nat.rec_on
#print nat.cases_on

def sub (n m : ℕ) : ℕ :=
  nat.rec_on m
    n
    (λ _ n, n - 1)

#reduce sub 0 2
#reduce sub 2 0
#reduce sub 10 15
#reduce sub 15 10

def exp (n m : ℕ) : ℕ :=
  nat.rec_on m
    1
    (λ _ n', mul n n')

#reduce exp 2 0
#reduce exp 3 3

variable {α : Type}

local attribute [simp]
def len (xs : list α) : ℕ :=
  list.rec_on xs
    0
    (λ _ _ l, 1 + l)

local attribute [simp]
def rev (xs : list α) : list α :=
  list.rec_on xs
    []
    (λ x _ r, r ++ [x]) /- too lazy to do this right -/

#reduce rev [1,2,3]

local attribute [simp]
theorem len_cons (x : α) (xs : list α) :
  len (x::xs) = 1 + len xs := by simp

local attribute [simp]
theorem len_app (s : list α) (t : list α) :
  len (s ++ t) = len s + len t := by induction s; simp [*, add_assoc]

theorem len_rev (as : list α) :
  len (rev as) = len as :=
begin
  induction as with a as ih,
    refl,
  have : len (rev (a :: as)) = len (rev as ++ [a]), by refl,
  rw this,
  rw len_app,
  rw ih,
  simp [ih, add_comm]
end

inductive data
| const : ℕ → data
| var : ℕ → data
| plus : data → data → data
| times : data → data → data

open list
open data

def eval (d: data) (v : list ℕ) : option ℕ :=
begin
  induction d,
    case const : n { exact n },
    case var : n { exact v.nth n },
    case plus : _ _ s t { exact do s ← s, t ← t, return (s + t) },
    case times : _ _ s t { exact s >>= (λ s, t.map (λ t, s * t)) },
end

#reduce eval (plus (const 1) (const 2)) []
#reduce eval (times (var 0) (plus (var 1) (var 2))) [2,3,5]


import Zmodn
import prime

namespace Zmodn

lemma mul_inv_of_prime_n :
∀ (a : Zmodn) [a ≠ zero], ∃ b, a *ₘ b =ₘ one :=
begin
  intros a ha,
  sorry,
end

end Zmodn

/-
lemma different_remainders (a : Zmodn) :
∀ (c,d ∈ {0,..,n-1}) [c ≠ d],
c*a ≠ₘ d*a :=
begin
  intros c d hcd,
  by_contradiction H, -- assume c*a =ₘ d*a

  have A : n|a*(c-d), {
    sorry, --
  },
  have B : n|a*(c-d) → n|a ∨ n|(c-d),
  by rw prime

  have C : ¬ n|a ∧ ¬ n|(c-d) → ¬ n|a*(c-d),
  by negate_B

  have D : ¬ n∣a ∧ ¬ n∣(c-d), {
    sorry,
    -- first part because n prime
    -- second part because 0 < |c-d| < p
  },
  have E : ¬ n|a*(c-d),
  by exact C D

  -- E contradicts A
end

lemma different_remainders_minus_one (a : Zmodn) :
∀ (c,d ∈ {0,..,n-1}) [c ≠ d],
c*a - 1 ≠ₘ d*a - 1 :=
by simp [different_remainders]

lemma n_different_possible_remainders :
... := sorry

lemma so_one_of_the_remainders_zero :
∀ a, ∃ b ∈ {0,..,n-1},
b*a - 1 =ₘ 0 := sorry

theorem exists_mul_inv :
∀ a, ∃ b ∈ {0,..,n-1},
b*a =ₘ 1 :=
by simp [so_one_of_the_remainders_zero]

-- all the elements are different from each other
-- each element ≠ each other element
-/

/-
the n elements can take values from zero to p-1

if each element ≠ each other element
and each element can take values zero to p-1
then one of them is zero
-/

/-
References

SE answer:
https://math.stackexchange.com/questions/1975080/prove-existence-of-multiplicative-inverse-modulo-p-when-p-is-prime
-/


/-
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
-/

import control.functor.multivariate
import data.pfunctor.multivariate.basic
import data.pfunctor.multivariate.M
import 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_locale mvfunctor

namespace mvqpf
open typevec mvpfunctor
open mvfunctor (liftp liftr)

variables {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 _ (λ x, repr (g x))

theorem corecF_eq {α : typevec n} {β : Type*} (g : β → F (α.append1 β)) (x : β) :
  M.dest q.P (corecF g x) = append_fun id (corecF g) <$$> repr (g x) :=
by rw [corecF, M.dest_corec]

/-- Characterization of desirable equivalence relations on M-types -/
def is_precongr {α : typevec n} (r : q.P.M α → q.P.M α → Prop) : Prop :=
  ∀ ⦃x y⦄, r x y →
    abs (append_fun id (quot.mk r) <$$> M.dest q.P x) =
      abs (append_fun id (quot.mk r) <$$> M.dest q.P y)

/-- Equivalence relation on M-types representing a value of type `cofix F` -/
def Mcongr {α : typevec n} (x y : q.P.M α) : Prop :=
∃ r, is_precongr r ∧ r x y

/-- 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 α)

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)

/-- the map function for the functor `cofix F` -/
def cofix.map {α β : typevec n} (g : α ⟹ β) : cofix F α → cofix F β :=
quot.lift (λ x : q.P.M α, quot.mk Mcongr (g <$$> x))
  begin
    rintros 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', split,
    { show is_precongr r',
      rintros b₁ b₂ ⟨a₁, a₂, ra₁a₂, b₁eq, b₂eq⟩,
      let u : quot r → quot r' := quot.lift (λ x : q.P.M α, quot.mk r' (g <$$> x))
        (by { intros a₁ a₂ ra₁a₂, apply quot.sound, exact ⟨a₁, a₂, ra₁a₂, rfl, rfl⟩ }),
      have hu : (quot.mk r' ∘ λ x : q.P.M α, g <$$> x) = u ∘ quot.mk r,
        { ext x, refl },
      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₂), from ⟨aa₁, aa₂, ra₁a₂, rfl, rfl⟩
  end

instance cofix.mvfunctor : mvfunctor (cofix F) :=
{ map := @cofix.map _ _ _ _}

/-- Corecursor for `cofix F` -/
def cofix.corec {α : typevec n} {β : Type u} (g : β → F (α.append1 β)) : β → cofix F α :=
λ x, quot.mk  _ (corecF g x)

/-- Destructor for `cofix F` -/
def cofix.dest {α : typevec n} : cofix F α → F (α.append1 (cofix F α)) :=
quot.lift
  (λ x, append_fun id (quot.mk Mcongr) <$$> (abs (M.dest q.P x)))
  begin
    rintros x y ⟨r, pr, rxy⟩, dsimp,
    have : ∀ x y, r x y → Mcongr x y,
    { intros x y h, exact ⟨r, pr, h⟩ },
    rw [←quot.factor_mk_eq _ _ this], dsimp,
    conv { to_lhs,
      rw [append_fun_comp_id, comp_map, ←abs_map, pr rxy, abs_map, ←comp_map,
        ←append_fun_comp_id] }
  end

/-- Abstraction function for `cofix F α` -/
def cofix.abs {α} : q.P.M α → cofix F α :=
quot.mk _

/-- Representation function for `cofix F α` -/
def cofix.repr {α} : cofix F α → q.P.M α :=
M.corec _ $ repr ∘ cofix.dest

/-- Corecursor for `cofix F` -/
def cofix.corec'₁ {α : typevec n} {β : Type u}
  (g : Π {X}, (β → X) → F (α.append1 X)) (x : β) : cofix F α :=
cofix.corec (λ x, g id) x

/-- 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 (cofix F α ⊕ β))) (x : β) :
  cofix F α :=
let f : α ::: cofix F α ⟹ α ::: (cofix F α ⊕ β) := id ::: sum.inl in
cofix.corec
(sum.elim (mvfunctor.map f ∘ cofix.dest) g)
(sum.inr x : cofix F α ⊕ β)

/-- 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' (λ x, g sum.inl sum.inr x) x

theorem cofix.dest_corec {α : typevec n} {β : Type u} (g : β → F (α.append1 β)) (x : β) :
  cofix.dest (cofix.corec g x) = append_fun id (cofix.corec g) <$$> g x :=
begin
  conv { to_lhs, rw [cofix.dest, cofix.corec] }, dsimp,
  rw [corecF_eq, abs_map, abs_repr, ←comp_map, ←append_fun_comp], reflexivity
end

/-- constructor for `cofix F` -/
def cofix.mk {α : typevec n} : F (α.append1 $ cofix F α) → cofix F α :=
cofix.corec (λ x, append_fun id (λ i : cofix F α, cofix.dest.{u} i) <$$> x)

/-!
## 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 →
      append_fun id (quot.mk r) <$$> cofix.dest x = append_fun id (quot.mk r) <$$> cofix.dest y) :
  ∀ x y, r x y → x = y :=
begin
  intro x, apply quot.induction_on x, clear x,
  intros x y, apply quot.induction_on y, clear y,
  intros y rxy,
  apply quot.sound,
  let r' := λ x y, r (quot.mk _ x) (quot.mk _ y),
  have : is_precongr r',
  { intros 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,
    { intros 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₁)
      begin
        intro c, apply quot.induction_on c, clear c,
        intros c d, apply quot.induction_on d, clear d,
        intros d rcd, apply quot.sound, apply rcd
      end,
    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⟩
end

/-- 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 →
      append_fun id (quot.mk r) <$$> cofix.dest x = append_fun id (quot.mk r) <$$> cofix.dest y) :
  ∀ x y, r x y → x = y :=
let r' x y := x = y ∨ r x y in
begin
  intros x y rxy,
  apply cofix.bisim_aux r',
  { intro x, left, reflexivity },
  { intros x y r'xy,
    cases r'xy, { rw r'xy },
    have : ∀ x y, r x y → r' x y := λ 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
end

/-- 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 (rel_last α r) (cofix.dest x) (cofix.dest y)) :
  ∀ x y, r x y → x = y :=
begin
  apply cofix.bisim_rel,
  intros 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 },
end

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' (rel_last' α 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

/-- 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.append_contents f' f₀⟩ ∧
      cofix.dest (v x) = abs ⟨a, q.P.append_contents f' f₁⟩ ∧
      ∀ i, ∃ x', Q x' ∧ f₀ i = u x' ∧ f₁ i = v x') :
  ∀ x, Q x → u x = v x :=
λ x Qx,
let R := λ w z : cofix F α, ∃ x', Q x' ∧ w = u x' ∧ z = v x' in
cofix.bisim R
  (λ x y ⟨x', Qx', xeq, yeq⟩,
    begin
      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 },
    end)
  _ _ ⟨x, Qx, rfl, rfl⟩

lemma cofix.dest_mk {α : typevec n} (x : F (α.append1 $ cofix F α)) : cofix.dest (cofix.mk x) = x :=
begin
  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]
end

lemma 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]

lemma 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]

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

section liftr_map

omit q

theorem liftr_map {α β : typevec n} {F' : typevec n → Type u} [mvfunctor F']
  [is_lawful_mvfunctor F']
  (R : β ⊗ β ⟹ repeat n Prop) (x : F' α) (f g : α ⟹ β)
  (h : α ⟹ subtype_ R)
  (hh : subtype_val _ ⊚ h = (f ⊗' g) ⊚ prod.diag) :
  liftr' R (f <$$> x) (g <$$> x) :=
begin
  rw liftr_def,
  existsi 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'], split; refl,
end

open function

theorem liftr_map_last [is_lawful_mvfunctor F] {α : typevec n} {ι ι'}
  (R : ι' → ι' → Prop) (x : F (α ::: ι)) (f g : ι → ι')
  (hh : ∀ x : ι, R (f x) (g x)) :
  liftr' (rel_last' _ R) ((id ::: f) <$$> x) ((id ::: g) <$$> x) :=
let h : ι → { x : ι' × ι' // uncurry R x } := λ x, ⟨ (f x,g x), hh x ⟩ in
let b : α ::: ι ⟹ _ := @diag_sub n α ::: h,
    c : subtype_ α.repeat_eq ::: {x // uncurry R x} ⟹
        (λ (i : fin2 (n)), {x // of_repeat (α.rel_last' R i.fs x)}) ::: subtype (uncurry R) :=
      of_subtype _ ::: id
in
have hh : subtype_val _ ⊚ to_subtype _ ⊚ from_append1_drop_last ⊚ 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_except,
         ext i x : 2, induction i,
         refl,  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, refl },
liftr_map _ _ _ _ (to_subtype _ ⊚ from_append1_drop_last ⊚ c ⊚ b) hh

theorem liftr_map_last' [is_lawful_mvfunctor F] {α : typevec n} {ι}
  (R : ι → ι → Prop) (x : F (α ::: ι)) (f : ι → ι)
  (hh : ∀ x : ι, R (f x) x) :
  liftr' (rel_last' _ R) ((id ::: f) <$$> x) x :=
begin
  have := liftr_map_last R x f id hh,
  rwa [append_fun_id_id,mvfunctor.id_map] at this,
end

end liftr_map

lemma cofix.abs_repr {α} (x : cofix F α) :
  quot.mk _ (cofix.repr x) = x :=
begin
  let R := λ x y : cofix F α,
    cofix.abs (cofix.repr y) = x,
  refine cofix.bisim₂ R _ _ _ rfl,
  clear x, rintros 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 (λ 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_app, last_fun_append_fun,
               last_fun_subtype_val, last_fun_comp, last_fun_split_fun],
    dsimp [drop_fun_rel_last,last_fun,prod.diag],
    split; refl, },
  dsimp [rel_last',split_fun,function.uncurry,R],
  refl,
end

section tactic

setup_tactic_parser
open tactic
omit q

/-- tactic for proof by bisimulation -/
meta def mv_bisim (e : parse texpr) (ids : parse with_ident_list) : tactic unit :=
do e ← to_expr e,
   (expr.pi n bi d b) ← retrieve $ do {
     generalize e,
     target },
   `(@eq %%t %%l %%r) ← pure b,
   x ← mk_local_def `n d,
   v₀ ← mk_local_def `a t,
   v₁ ← mk_local_def `b t,
   x₀ ← mk_app ``eq [v₀,l.instantiate_var x],
   x₁ ← mk_app ``eq [v₁,r.instantiate_var x],
   xx ← mk_app ``and [x₀,x₁],
   ex ← lambdas [x] xx,
   ex ← mk_app ``Exists [ex] >>= lambdas [v₀,v₁],
   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.repeat `_ 5).zip_with f [`a,`b,`x,`Ha,`Hb],
   (ids₀,w::ids₁) ← pure $ list.split_at 2 ids,
   intro_lst ids₀,
   h ← intro1,
   [(_,[w,h],_)] ← cases_core h [w],
   cases h ids₁,
   pure ()

run_cmd add_interactive [``mv_bisim]

end tactic

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₀) :=
begin
  mv_bisim x₀,
  rw [Ha,Hb,cofix.dest_corec,cofix.dest_corec],
  rw [mvfunctor.map_map,← append_fun_comp_id],
  refine liftr_map_last _ _ _ _ _,
  intros a, refine ⟨a,rfl,rfl⟩
end

theorem cofix.dest_corec' {α : typevec n} {β : Type u}
  (g : β → F (α.append1 (cofix F α ⊕ β))) (x : β) :
  cofix.dest (cofix.corec' g x) = append_fun id (sum.elim id (cofix.corec' g)) <$$> g x :=
begin
  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] },
end

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]; refl

instance mvqpf_cofix : mvqpf (cofix F) :=
{ P         := q.P.Mp,
  abs       := λ α, quot.mk Mcongr,
  repr      := λ α, cofix.repr,
  abs_repr  := λ α, cofix.abs_repr,
  abs_map   := λ α β g x, rfl
}

end mvqpf