/-
Copyright (c) 2020 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/
import category_theory.limits.shapes.finite_products
import category_theory.limits.shapes.kernels
import category_theory.limits.shapes.normal_mono.equalizers
import category_theory.abelian.images
import category_theory.preadditive

/-!
# Every non_preadditive_abelian category is preadditive

In mathlib, we define an abelian category as a preadditive category with a zero object,
kernels and cokernels, products and coproducts and in which every monomorphism and epimorphis is
normal.

While virtually every interesting abelian category has a natural preadditive structure (which is why
it is included in the definition), preadditivity is not actually needed: Every category that has
all of the other properties appearing in the definition of an abelian category admits a preadditive
structure. This is the construction we carry out in this file.

The proof proceeds in roughly five steps:
1. Prove some results (for example that all equalizers exist) that would be trivial if we already
   had the preadditive structure but are a bit of work without it.
2. Develop images and coimages to show that every monomorphism is the kernel of its cokernel.

The results of the first two steps are also useful for the "normal" development of abelian
categories, and will be used there.

3. For every object `A`, define a "subtraction" morphism `σ : A ⨯ A ⟶ A` and use it to define
   subtraction on morphisms as `f - g := prod.lift f g ≫ σ`.
4. Prove a small number of identities about this subtraction from the definition of `σ`.
5. From these identities, prove a large number of other identities that imply that defining
   `f + g := f - (0 - g)` indeed gives an abelian group structure on morphisms such that composition
   is bilinear.

The construction is non-trivial and it is quite remarkable that this abelian group structure can
be constructed purely from the existence of a few limits and colimits. Even more remarkably,
since abelian categories admit exactly one preadditive structure (see
`subsingleton_preadditive_of_has_binary_biproducts`), the construction manages to exactly
reconstruct any natural preadditive structure the category may have.

## References

* [F. Borceux, *Handbook of Categorical Algebra 2*][borceux-vol2]

-/

noncomputable theory

open category_theory
open category_theory.limits

namespace category_theory
section
universes v u

variables (C : Type u) [category.{v} C]

/-- We call a category `non_preadditive_abelian` if it has a zero object, kernels, cokernels, binary
    products and coproducts, and every monomorphism and every epimorphism is normal. -/
class non_preadditive_abelian extends has_zero_morphisms C, normal_mono_category C,
  normal_epi_category C :=
[has_zero_object : has_zero_object C]
[has_kernels : has_kernels C]
[has_cokernels : has_cokernels C]
[has_finite_products : has_finite_products C]
[has_finite_coproducts : has_finite_coproducts C]

set_option default_priority 100

attribute [instance] non_preadditive_abelian.has_zero_object
attribute [instance] non_preadditive_abelian.has_kernels
attribute [instance] non_preadditive_abelian.has_cokernels
attribute [instance] non_preadditive_abelian.has_finite_products
attribute [instance] non_preadditive_abelian.has_finite_coproducts

end
end category_theory

open category_theory

universes v u

variables {C : Type u} [category.{v} C] [non_preadditive_abelian C]

namespace category_theory.non_preadditive_abelian

section factor

variables {P Q : C} (f : P ⟶ Q)

/-- The map `p : P ⟶ image f` is an epimorphism -/
instance : epi (abelian.factor_thru_image f) :=
let I := abelian.image f, p := abelian.factor_thru_image f,
    i := kernel.ι (cokernel.π f) in
-- It will suffice to consider some g : I ⟶ R such that p ≫ g = 0 and show that g = 0.
normal_mono_category.epi_of_zero_cancel _ $ λ R (g : I ⟶ R) (hpg : p ≫ g = 0),
begin
  -- Since C is abelian, u := ker g ≫ i is the kernel of some morphism h.
  let u := kernel.ι g ≫ i,
  haveI : mono u := mono_comp _ _,
  haveI hu := normal_mono_of_mono u,
  let h := hu.g,
  -- By hypothesis, p factors through the kernel of g via some t.
  obtain ⟨t, ht⟩ := kernel.lift' g p hpg,
  have fh : f ≫ h = 0, calc
    f ≫ h = (p ≫ i) ≫ h : (abelian.image.fac f).symm ▸ rfl
       ... = ((t ≫ kernel.ι g) ≫ i) ≫ h : ht ▸ rfl
       ... = t ≫ u ≫ h : by simp only [category.assoc]; conv_lhs { congr, skip, rw ←category.assoc }
       ... = t ≫ 0 : hu.w ▸ rfl
       ... = 0 : has_zero_morphisms.comp_zero _ _,
  -- h factors through the cokernel of f via some l.
  obtain ⟨l, hl⟩ := cokernel.desc' f h fh,
  have hih : i ≫ h = 0, calc
    i ≫ h = i ≫ cokernel.π f ≫ l : hl ▸ rfl
       ... = 0 ≫ l : by rw [←category.assoc, kernel.condition]
       ... = 0 : zero_comp,
  -- i factors through u = ker h via some s.
  obtain ⟨s, hs⟩ := normal_mono.lift' u i hih,
  have hs' : (s ≫ kernel.ι g) ≫ i = 𝟙 I ≫ i, by rw [category.assoc, hs, category.id_comp],
  haveI : epi (kernel.ι g) := epi_of_epi_fac ((cancel_mono _).1 hs'),
  -- ker g is an epimorphism, but ker g ≫ g = 0 = ker g ≫ 0, so g = 0 as required.
  exact zero_of_epi_comp _ (kernel.condition g)
end

instance is_iso_factor_thru_image [mono f] : is_iso (abelian.factor_thru_image f) :=
is_iso_of_mono_of_epi _

/-- The canonical morphism `i : coimage f ⟶ Q` is a monomorphism -/
instance : mono (abelian.factor_thru_coimage f) :=
let I := abelian.coimage f, i := abelian.factor_thru_coimage f,
    p := cokernel.π (kernel.ι f) in
normal_epi_category.mono_of_cancel_zero _ $ λ R (g : R ⟶ I) (hgi : g ≫ i = 0),
begin
  -- Since C is abelian, u := p ≫ coker g is the cokernel of some morphism h.
  let u := p ≫ cokernel.π g,
  haveI : epi u := epi_comp _ _,
  haveI hu := normal_epi_of_epi u,
  let h := hu.g,
  -- By hypothesis, i factors through the cokernel of g via some t.
  obtain ⟨t, ht⟩ := cokernel.desc' g i hgi,
  have hf : h ≫ f = 0, calc
    h ≫ f = h ≫ (p ≫ i) : (abelian.coimage.fac f).symm ▸ rfl
    ... = h ≫ (p ≫ (cokernel.π g ≫ t)) : ht ▸ rfl
    ... = h ≫ u ≫ t : by simp only [category.assoc]; conv_lhs { congr, skip, rw ←category.assoc }
    ... = 0 ≫ t : by rw [←category.assoc, hu.w]
    ... = 0 : zero_comp,
  -- h factors through the kernel of f via some l.
  obtain ⟨l, hl⟩ := kernel.lift' f h hf,
  have hhp : h ≫ p = 0, calc
    h ≫ p = (l ≫ kernel.ι f) ≫ p : hl ▸ rfl
    ... = l ≫ 0 : by rw [category.assoc, cokernel.condition]
    ... = 0 : comp_zero,
  -- p factors through u = coker h via some s.
  obtain ⟨s, hs⟩ := normal_epi.desc' u p hhp,
  have hs' : p ≫ cokernel.π g ≫ s = p ≫ 𝟙 I, by rw [←category.assoc, hs, category.comp_id],
  haveI : mono (cokernel.π g) := mono_of_mono_fac ((cancel_epi _).1 hs'),
  -- coker g is a monomorphism, but g ≫ coker g = 0 = 0 ≫ coker g, so g = 0 as required.
  exact zero_of_comp_mono _ (cokernel.condition g)
end

instance is_iso_factor_thru_coimage [epi f] :
  is_iso (abelian.factor_thru_coimage f) :=
is_iso_of_mono_of_epi _

end factor

section cokernel_of_kernel
variables {X Y : C} {f : X ⟶ Y}

/-- In a `non_preadditive_abelian` category, an epi is the cokernel of its kernel. More precisely:
    If `f` is an epimorphism and `s` is some limit kernel cone on `f`, then `f` is a cokernel
    of `fork.ι s`. -/
def epi_is_cokernel_of_kernel [epi f] (s : fork f 0) (h : is_limit s) :
  is_colimit (cokernel_cofork.of_π f (kernel_fork.condition s)) :=
is_cokernel.cokernel_iso _ _
  (cokernel.of_iso_comp _ _
    (limits.is_limit.cone_point_unique_up_to_iso (limit.is_limit _) h)
    (cone_morphism.w (limits.is_limit.unique_up_to_iso (limit.is_limit _) h).hom _))
  (as_iso $ abelian.factor_thru_coimage f) (abelian.coimage.fac f)

/-- In a `non_preadditive_abelian` category, a mono is the kernel of its cokernel. More precisely:
    If `f` is a monomorphism and `s` is some colimit cokernel cocone on `f`, then `f` is a kernel
    of `cofork.π s`. -/
def mono_is_kernel_of_cokernel [mono f] (s : cofork f 0) (h : is_colimit s) :
  is_limit (kernel_fork.of_ι f (cokernel_cofork.condition s)) :=
is_kernel.iso_kernel _ _
  (kernel.of_comp_iso _ _
    (limits.is_colimit.cocone_point_unique_up_to_iso h (colimit.is_colimit _))
    (cocone_morphism.w (limits.is_colimit.unique_up_to_iso h $ colimit.is_colimit _).hom _))
  (as_iso $ abelian.factor_thru_image f) (abelian.image.fac f)

end cokernel_of_kernel
section

/-- The composite `A ⟶ A ⨯ A ⟶ cokernel (Δ A)`, where the first map is `(𝟙 A, 0)` and the second map
    is the canonical projection into the cokernel. -/
abbreviation r (A : C) : A ⟶ cokernel (diag A) := prod.lift (𝟙 A) 0 ≫ cokernel.π (diag A)

instance mono_Δ {A : C} : mono (diag A) := mono_of_mono_fac $ prod.lift_fst _ _

instance mono_r {A : C} : mono (r A) :=
begin
  let hl : is_limit (kernel_fork.of_ι (diag A) (cokernel.condition (diag A))),
  { exact mono_is_kernel_of_cokernel _ (colimit.is_colimit _) },
  apply normal_epi_category.mono_of_cancel_zero,
  intros Z x hx,
  have hxx : (x ≫ prod.lift (𝟙 A) (0 : A ⟶ A)) ≫ cokernel.π (diag A) = 0,
  { rw [category.assoc, hx] },
  obtain ⟨y, hy⟩ := kernel_fork.is_limit.lift' hl _ hxx,
  rw kernel_fork.ι_of_ι at hy,
  have hyy : y = 0,
  { erw [←category.comp_id y, ←limits.prod.lift_snd (𝟙 A) (𝟙 A),  ←category.assoc, hy,
      category.assoc, prod.lift_snd, has_zero_morphisms.comp_zero] },
  haveI : mono (prod.lift (𝟙 A) (0 : A ⟶ A)) := mono_of_mono_fac (prod.lift_fst _ _),
  apply (cancel_mono (prod.lift (𝟙 A) (0 : A ⟶ A))).1,
  rw [←hy, hyy, zero_comp, zero_comp]
end

instance epi_r {A : C} : epi (r A) :=
begin
  have hlp : prod.lift (𝟙 A) (0 : A ⟶ A) ≫ limits.prod.snd = 0 := prod.lift_snd _ _,
  let hp1 : is_limit (kernel_fork.of_ι (prod.lift (𝟙 A) (0 : A ⟶ A)) hlp),
  { refine fork.is_limit.mk _ (λ s, fork.ι s ≫ limits.prod.fst) _ _,
    { intro s,
      ext; simp, erw category.comp_id },
    { intros s m h,
      haveI : mono (prod.lift (𝟙 A) (0 : A ⟶ A)) := mono_of_mono_fac (prod.lift_fst _ _),
      apply (cancel_mono (prod.lift (𝟙 A) (0 : A ⟶ A))).1,
      convert h walking_parallel_pair.zero,
      ext; simp } },
  let hp2 : is_colimit (cokernel_cofork.of_π (limits.prod.snd : A ⨯ A ⟶ A) hlp),
  { exact epi_is_cokernel_of_kernel _ hp1 },
  apply normal_mono_category.epi_of_zero_cancel,
  intros Z z hz,
  have h : prod.lift (𝟙 A) (0 : A ⟶ A) ≫ cokernel.π (diag A) ≫ z = 0,
  { rw [←category.assoc, hz] },
  obtain ⟨t, ht⟩ := cokernel_cofork.is_colimit.desc' hp2 _ h,
  rw cokernel_cofork.π_of_π at ht,
  have htt : t = 0,
  { rw [←category.id_comp t],
    change 𝟙 A ≫ t = 0,
    rw [←limits.prod.lift_snd (𝟙 A) (𝟙 A), category.assoc, ht, ←category.assoc,
      cokernel.condition, zero_comp] },
  apply (cancel_epi (cokernel.π (diag A))).1,
  rw [←ht, htt, comp_zero, comp_zero]
end

instance is_iso_r {A : C} : is_iso (r A) :=
is_iso_of_mono_of_epi _

/-- The composite `A ⨯ A ⟶ cokernel (diag A) ⟶ A` given by the natural projection into the cokernel
    followed by the inverse of `r`. In the category of modules, using the normal kernels and
    cokernels, this map is equal to the map `(a, b) ↦ a - b`, hence the name `σ` for
    "subtraction". -/
abbreviation σ {A : C} : A ⨯ A ⟶ A := cokernel.π (diag A) ≫ inv (r A)

end

@[simp, reassoc] lemma diag_σ {X : C} : diag X ≫ σ = 0 :=
by rw [cokernel.condition_assoc, zero_comp]

@[simp, reassoc] lemma lift_σ {X : C} : prod.lift (𝟙 X) 0 ≫ σ = 𝟙 X :=
by rw [←category.assoc, is_iso.hom_inv_id]

@[reassoc] lemma lift_map {X Y : C} (f : X ⟶ Y) :
  prod.lift (𝟙 X) 0 ≫ limits.prod.map f f = f ≫ prod.lift (𝟙 Y) 0 :=
by simp

/-- σ is a cokernel of Δ X. -/
def is_colimit_σ {X : C} : is_colimit (cokernel_cofork.of_π σ diag_σ) :=
cokernel.cokernel_iso _ σ (as_iso (r X)).symm (by rw [iso.symm_hom, as_iso_inv])

/-- This is the key identity satisfied by `σ`. -/
lemma σ_comp {X Y : C} (f : X ⟶ Y) : σ ≫ f = limits.prod.map f f ≫ σ :=
begin
  obtain ⟨g, hg⟩ :=
    cokernel_cofork.is_colimit.desc' is_colimit_σ (limits.prod.map f f ≫ σ) (by simp),
  suffices hfg : f = g,
  { rw [←hg, cofork.π_of_π, hfg] },
  calc f = f ≫ prod.lift (𝟙 Y) 0 ≫ σ : by rw [lift_σ, category.comp_id]
    ... = prod.lift (𝟙 X) 0 ≫ limits.prod.map f f ≫ σ : by rw lift_map_assoc
    ... = prod.lift (𝟙 X) 0 ≫ σ ≫ g : by rw [←hg, cokernel_cofork.π_of_π]
    ... = g : by rw [←category.assoc, lift_σ, category.id_comp]
end

section

/- We write `f - g` for `prod.lift f g ≫ σ`. -/
/-- Subtraction of morphisms in a `non_preadditive_abelian` category. -/
def has_sub {X Y : C} : has_sub (X ⟶ Y) := ⟨λ f g, prod.lift f g ≫ σ⟩
local attribute [instance] has_sub

/- We write `-f` for `0 - f`. -/
/-- Negation of morphisms in a `non_preadditive_abelian` category. -/
def has_neg {X Y : C} : has_neg (X ⟶ Y) := ⟨λ f, 0 - f⟩
local attribute [instance] has_neg

/- We write `f + g` for `f - (-g)`. -/
/-- Addition of morphisms in a `non_preadditive_abelian` category. -/
def has_add {X Y : C} : has_add (X ⟶ Y) := ⟨λ f g, f - (-g)⟩
local attribute [instance] has_add

lemma sub_def {X Y : C} (a b : X ⟶ Y) : a - b = prod.lift a b ≫ σ := rfl
lemma add_def {X Y : C} (a b : X ⟶ Y) : a + b = a - (-b) := rfl
lemma neg_def {X Y : C} (a : X ⟶ Y) : -a = 0 - a := rfl

lemma sub_self {X Y : C} (a : X ⟶ Y) : a - a = 0 :=
by rw [sub_def, ←category.comp_id a, ← prod.comp_lift, category.assoc, diag_σ, comp_zero]

lemma lift_sub_lift {X Y : C} (a b c d : X ⟶ Y) :
  prod.lift a b - prod.lift c d = prod.lift (a - c) (b - d) :=
begin
  simp only [sub_def],
  ext,
  { rw [category.assoc, σ_comp, prod.lift_map_assoc, prod.lift_fst, prod.lift_fst, prod.lift_fst] },
  { rw [category.assoc, σ_comp, prod.lift_map_assoc, prod.lift_snd, prod.lift_snd, prod.lift_snd] }
end

lemma sub_sub_sub {X Y : C} (a b c d : X ⟶ Y) : (a - c) - (b - d) = (a - b) - (c - d) :=
begin
  rw [sub_def, ←lift_sub_lift, sub_def, category.assoc, σ_comp, prod.lift_map_assoc], refl
end

lemma neg_sub {X Y : C} (a b : X ⟶ Y) : (-a) - b = (-b) - a :=
by conv_lhs { rw [neg_def, ←sub_zero b, sub_sub_sub, sub_zero, ←neg_def] }

lemma neg_neg {X Y : C} (a : X ⟶ Y) : -(-a) = a :=
begin
  rw [neg_def, neg_def],
  conv_lhs { congr, rw ←sub_self a },
  rw [sub_sub_sub, sub_zero, sub_self, sub_zero]
end

lemma add_comm {X Y : C} (a b : X ⟶ Y) : a + b = b + a :=
begin
  rw [add_def],
  conv_lhs { rw ←neg_neg a },
  rw [neg_def, neg_def, neg_def, sub_sub_sub],
  conv_lhs {congr, skip, rw [←neg_def, neg_sub] },
  rw [sub_sub_sub, add_def, ←neg_def, neg_neg b, neg_def]
end

lemma add_neg {X Y : C} (a b : X ⟶ Y) : a + (-b) = a - b :=
by rw [add_def, neg_neg]

lemma add_neg_self {X Y : C} (a : X ⟶ Y) : a + (-a) = 0 :=
by rw [add_neg, sub_self]

lemma neg_add_self {X Y : C} (a : X ⟶ Y) : (-a) + a = 0 :=
by rw [add_comm, add_neg_self]

lemma neg_sub' {X Y : C} (a b : X ⟶ Y) : -(a - b) = (-a) + b :=
begin
  rw [neg_def, neg_def],
  conv_lhs { rw ←sub_self (0 : X ⟶ Y) },
  rw [sub_sub_sub, add_def, neg_def]
end

lemma neg_add {X Y : C} (a b : X ⟶ Y) : -(a + b) = (-a) - b :=
by rw [add_def, neg_sub', add_neg]

lemma sub_add {X Y : C} (a b c : X ⟶ Y) : (a - b) + c = a - (b - c) :=
by rw [add_def, neg_def, sub_sub_sub, sub_zero]

lemma add_assoc {X Y : C} (a b c : X ⟶ Y) : (a + b) + c = a + (b + c) :=
begin
  conv_lhs { congr, rw add_def },
  rw [sub_add, ←add_neg, neg_sub', neg_neg]
end

lemma add_zero {X Y : C} (a : X ⟶ Y) : a + 0 = a :=
by rw [add_def, neg_def, sub_self, sub_zero]

lemma comp_sub {X Y Z : C} (f : X ⟶ Y) (g h : Y ⟶ Z) : f ≫ (g - h) = f ≫ g - f ≫ h :=
by rw [sub_def, ←category.assoc, prod.comp_lift, sub_def]

lemma sub_comp {X Y Z : C} (f g : X ⟶ Y) (h : Y ⟶ Z) : (f - g) ≫ h = f ≫ h - g ≫ h :=
by rw [sub_def, category.assoc, σ_comp, ←category.assoc, prod.lift_map, sub_def]

lemma comp_add (X Y Z : C) (f : X ⟶ Y) (g h : Y ⟶ Z) : f ≫ (g + h) = f ≫ g + f ≫ h :=
by rw [add_def, comp_sub, neg_def, comp_sub, comp_zero, add_def, neg_def]

lemma add_comp (X Y Z : C) (f g : X ⟶ Y) (h : Y ⟶ Z) : (f + g) ≫ h = f ≫ h + g ≫ h :=
by rw [add_def, sub_comp, neg_def, sub_comp, zero_comp, add_def, neg_def]

/-- Every `non_preadditive_abelian` category is preadditive. -/
def preadditive : preadditive C :=
{ hom_group := λ X Y,
  { add := (+),
    add_assoc := add_assoc,
    zero := 0,
    zero_add := neg_neg,
    add_zero := add_zero,
    neg := λ f, -f,
    add_left_neg := neg_add_self,
    add_comm := add_comm },
  add_comp' := add_comp,
  comp_add' := comp_add }

end

end category_theory.non_preadditive_abelian


import data.cpi.species data.cpi.process.basic

namespace cpi
namespace process

variables {ℂ ℍ : Type} {ω Γ : context} [has_add ℂ] [∀ Γ, setoid (species ℍ ω Γ)]

/-- Structural congruence of processes. -/
inductive equiv : process ℂ ℍ ω Γ → process ℂ ℍ ω Γ → Prop
| refl  {A}     : equiv A A
| trans {A B C} : equiv A B → equiv B C → equiv A C
| symm  {A B}   : equiv A B → equiv B A

-- Projection
| ξ_species   {c : ℂ} {A B} : A ≈ B → equiv (c ◯ A) (c ◯ B)
| ξ_parallel₁ {P P' Q} : equiv P P' → equiv (P |ₚ Q) (P' |ₚ Q)
| ξ_parallel₂ {P Q Q'} : equiv Q Q' → equiv (P |ₚ Q) (P |ₚ Q')

-- Monoidic properties
| parallel_nil   {P} {c : ℂ} : equiv (P |ₚ c ◯ species.nil) P
| parallel_symm  {P Q} : equiv (P |ₚ Q) (Q |ₚ P)
| parallel_assoc {P Q R} : equiv ((P |ₚ Q) |ₚ R) (P |ₚ (Q |ₚ R))

-- Join identical species together.
| join  {A} {c d} : equiv (c ◯ A |ₚ d ◯ A) ((c + d) ◯ A)
| split {A B} {c : ℂ} : equiv (c ◯ (A |ₛ B)) (c ◯ A |ₚ c ◯ B)

instance : is_equiv (process ℂ ℍ ω Γ) equiv :=
  { refl := @equiv.refl _ _ _ _ _ _, symm := @equiv.symm _ _ _ _ _ _, trans := @equiv.trans _ _ _ _ _ _ }
instance : is_refl (process ℂ ℍ ω Γ) equiv := ⟨ λ _, equiv.refl ⟩
instance : setoid (process ℂ ℍ ω Γ) :=
  ⟨ equiv, ⟨ @equiv.refl _ _ _ _ _ _, @equiv.symm _ _ _ _ _ _, @equiv.trans _ _ _ _ _ _ ⟩ ⟩
instance setoid.is_equiv : is_equiv (process ℂ ℍ ω Γ) has_equiv.equiv :=
  process.is_equiv

namespace equiv
  lemma parallel_symm₁ {P Q R : process ℂ ℍ ω Γ} : (P |ₚ Q |ₚ R) ≈ (Q |ₚ P |ₚ R) :=
    calc  (P |ₚ (Q |ₚ R))
        ≈ ((P |ₚ Q) |ₚ R) : symm parallel_assoc
    ... ≈ ((Q |ₚ P) |ₚ R) : ξ_parallel₁ parallel_symm
    ... ≈ (Q |ₚ (P |ₚ R)) : parallel_assoc

  lemma parallel_symm₂ {P Q R : process ℂ ℍ ω Γ} : ((P |ₚ Q) |ₚ R) ≈ ((P |ₚ R) |ₚ Q) :=
    calc  ((P |ₚ Q) |ₚ R)
        ≈ (P |ₚ (Q |ₚ R)) : parallel_assoc
    ... ≈ (P |ₚ (R |ₚ Q)) : ξ_parallel₂ parallel_symm
    ... ≈ ((P |ₚ R) |ₚ Q) : symm parallel_assoc
end equiv

namespace parallel.quot
  /-- Make a parallel process from a quotient of two process. -/
  def mk : quotient (@process.setoid ℂ ℍ ω Γ _ _) → quotient (@process.setoid ℂ ℍ ω Γ _ _) → quotient (@process.setoid ℂ ℍ ω Γ _ _)
  | A B := quotient.lift_on₂ A B (λ A B, ⟦ A |ₚ B ⟧)
      (λ A B A' B' eqA eqB, quot.sound (trans (equiv.ξ_parallel₁ eqA) ((equiv.ξ_parallel₂ eqB))))

  lemma assoc (A B C : quotient (@process.setoid ℂ ℍ ω Γ _ _))
    : mk A (mk B C) = mk (mk A B) C
    := begin
      rcases quot.exists_rep A with ⟨ A, ⟨ _ ⟩ ⟩,
      rcases quot.exists_rep B with ⟨ B, ⟨ _ ⟩ ⟩,
      rcases quot.exists_rep C with ⟨ C, ⟨ _ ⟩ ⟩,
      from quot.sound (symm equiv.parallel_assoc),
    end
end parallel.quot

end process

/-- A quotient of all structurally congruent processes. -/
@[nolint has_inhabited_instance]
def process' (ℂ ℍ : Type) (ω Γ : context) [has_add ℂ] [∀ {Γ}, setoid (species ℍ ω Γ)]
  := quotient (@process.setoid ℂ ℍ ω Γ _ _)

section prime
  variables {ℂ ℍ : Type} {ω Γ : context} [∀ Γ, setoid (species ℍ ω Γ)]

  /-- Convert a list of prime species into a process-/
  def process.from_primes [add_monoid ℂ] {Γ} (f : prime_species' ℍ ω Γ → ℂ)
    : list (prime_species' ℍ ω Γ) → process' ℂ ℍ ω Γ
  | [] := ⟦ 0 ◯ nil ⟧
  | (A :: As) :=
    let A' := quot.lift_on A (λ B, ⟦ f A ◯ B.val ⟧)
                (λ A B r, quot.sound (process.equiv.ξ_species r))
    in process.parallel.quot.mk A' (process.from_primes As)

  /-- Convert a multiset of prime species into a process. -/
  def process.from_prime_multiset [add_monoid ℂ] {Γ} (f : prime_species' ℍ ω Γ → ℂ)
    : multiset (prime_species' ℍ ω Γ) → process' ℂ ℍ ω Γ
  | Ps := quot.lift_on Ps (process.from_primes f) (λ P Q r, begin
    induction r,
    case list.perm.nil { from rfl },
    case list.perm.trans : A B C _ _ ab bc { from trans ab bc },
    case list.perm.skip : A As Bs _ ih { simp only [process.from_primes, ih] },
    case list.perm.swap : A B As {
      simp only [process.from_primes],
      rcases quot.exists_rep A with ⟨ A, eq ⟩, subst eq,
      rcases quot.exists_rep B with ⟨ B, eq ⟩, subst eq,
      rcases quot.exists_rep (process.from_primes f As) with ⟨ As, eq ⟩, rw ← eq, clear eq,
      from quot.sound process.equiv.parallel_symm₁,
    },
  end)
end prime
end cpi

#lint-


/-
Copyright (c) 2018-2019 Minchao Wu. All rights reserved.
Released under MIT license as described in the file LICENSE.
Author: Minchao Wu
-/

import defs data.list.perm .data
open nnf tactic

meta def frame_restriction : tactic unit :=
do intro `a >> `[simp]

structure S4 (states : Type) extends kripke states :=
(refl  : reflexive rel . frame_restriction)
(trans : transitive rel . frame_restriction)

instance inhabited_S4 : inhabited (S4 ℕ) :=
⟨ { val := λ a b, tt, rel := λ a b, tt } ⟩

@[simp] def force {states : Type} (k : S4 states) : states → nnf → Prop
| s (var n)    := k.val n s
| s (neg n)    := ¬ k.val n s
| s (and φ ψ)  := force s φ ∧ force s ψ
| s (or φ ψ)   := force s φ ∨ force s ψ
| s (box φ)    := ∀ s', k.rel s s' → force s' φ
| s (dia φ)    := ∃ s', k.rel s s' ∧ force s' φ

def sat {st} (k : S4 st) (s) (Γ : list nnf) : Prop :=
∀ φ ∈ Γ, force k s φ

def unsatisfiable (Γ : list nnf) : Prop :=
∀ (st) (k : S4 st) s, ¬ sat k s Γ

theorem unsat_singleton {φ} : unsatisfiable [φ] → ∀ (st) (k : S4 st) s, ¬ force k s φ
 :=
begin
  intros h _ _ _ hf,
  apply h, intros ψ hψ, rw list.mem_singleton at hψ, rw hψ, exact hf
end

theorem sat_of_empty {st} (k : S4 st) (s) : sat k s [] :=
λ φ h, absurd h $ list.not_mem_nil _

theorem ne_empty_of_unsat {Γ} (h : unsatisfiable Γ): Γ ≠ [] :=
begin
  intro heq, rw heq at h,
  apply h, apply sat_of_empty, exact nat,
  apply inhabited_S4.1, exact 0
end

open tmodel

@[simp] def minfo : Π m : tmodel, info
| (cons i l ba) := i

@[simp] def htk : Π m : tmodel, list nnf
| (cons i l ba) := i.htk

def hist : Π m : tmodel, list nnf
| (cons i l ba) := i.id.h

@[simp] def msig : Π m : tmodel, sig
| (cons i l ba) := i.id.s

@[simp] def manc : Π m : tmodel, list psig
| (cons i l ba) := i.id.a

def bhist : Π m : tmodel, list nnf
| (cons i l ba) := i.id.b

@[simp] def request : Π m : tmodel, list psig
| (cons i l ba) := ba

@[simp] def proper_request_box : Π m : tmodel, Prop
| (cons i l ba) := ∀ rq : psig, rq ∈ ba → ∀ φ, (box φ ∈ i.htk ∨ box φ ∈ i.id.b) → box φ ∈ rq.b

@[simp] def subset_request : Π m : tmodel, Prop
| (cons i l ba) := ba ⊆ i.id.a

@[simp] def tmodel_step_bhist : Π m : tmodel, Prop
| m@(cons i l ba) := ∀ s ∈ l, ∀ φ, box φ ∈ i.id.b → box φ ∈ htk s

@[simp] def tmodel_step_box : Π m : tmodel, Prop
| m@(cons i l ba) := ∀ s ∈ l, ∀ φ, box φ ∈ i.htk → box φ ∈ htk s

-- Can be strenghtened
@[simp] def tmodel_dia : Π m : tmodel, Prop
| m@(cons i l ba) := ∀ φ, dia φ ∈ i.htk → (∃ rq : psig, rq ∈ ba ∧ rq.d = φ) ∨ ∃ s ∈ l, φ ∈ htk s

@[simp] def child : tmodel → tmodel → bool
| s (cons i l ba) := s ∈ l

inductive tc' {α : Type} (r : α → α → Prop) : α → α → Prop
| base : ∀ a b, r a b → tc' a b
| step : ∀ a b c, r a b → tc' b c → tc' a c

theorem tc'.trans {α : Type} {r : α → α → Prop} {a b c : α} :
tc' r a b → tc' r b c → tc' r a c :=
begin
intros h₁ h₂,
induction h₁,
apply tc'.step, exact h₁_a_1, exact h₂,
apply tc'.step, exact h₁_a_1, apply h₁_ih, exact h₂
end

def desc : tmodel → tmodel → Prop := tc' (λ s m, child s m)

theorem desc_not_nil : Π c i ba m, m = cons i [] ba → desc c m → false :=
begin
intros c i ba m heq h,
induction h,
{rw heq at h_a_1, simp at h_a_1, exact h_a_1},
{apply h_ih, exact heq}
end

theorem desc_iff_eq_child_aux : Π i₁ i₂ s₁ s₂ l₁ l₂ m₁ m₂ m₃,
m₁ = cons i₁ l₁ s₁ → m₂ = cons i₂ l₂ s₂ → l₁ = l₂ →
(desc m₃ m₁ ↔ desc m₃ m₂) :=
begin
intros i₁ i₂ s₁ s₂ l₁ l₂ m₁ m₂ m₃ heq₁ heq₂ heq,
split,
{intro hd, induction hd,
 {rw heq₁ at hd_a_1, simp at hd_a_1,
 rw heq at hd_a_1,
 apply tc'.base, rw heq₂, simp, exact hd_a_1},
 {apply tc'.trans, apply tc'.base, exact hd_a_1, apply hd_ih, exact heq₁}},
{intro hd, induction hd,
 {rw heq₂ at hd_a_1, simp at hd_a_1,
 rw ←heq at hd_a_1,
 apply tc'.base, rw heq₁, simp, exact hd_a_1},
 {apply tc'.trans, apply tc'.base, exact hd_a_1, apply hd_ih, exact heq₂}}
end

theorem eq_desc_of_eq_children {i₁ i₂ s₁ s₂ l c} :
desc c (cons i₁ l s₁) = desc c (cons i₂ l s₂) :=
begin rw desc_iff_eq_child_aux, repeat {refl} end

theorem desc_step : Π c i l ba, c ∈ l → desc c (cons i l ba)
| c i [] ba h := absurd h $ list.not_mem_nil _
| c i (hd::tl) ba h :=
begin
constructor,
simp, cases h,
left, exact h, right, exact h
end

theorem desc_ex : Π c i l ba, (∃ m ∈ l, desc c m) → desc c (cons i l ba)
| c i [] ba h := begin rcases h with ⟨w, hmem, hw⟩, exact (absurd hmem $ list.not_mem_nil _) end
| c i (hd::tl) ba h :=
begin
rcases h with ⟨w, hmem, hw⟩,
cases hw,
{apply tc'.step,
swap 3, {exact w},
{exact hw_a_1},
{apply tc'.base, simp, cases hmem, left, exact hmem, right, exact hmem}},
{apply tc'.step, exact hw_a_1, apply tc'.trans, exact hw_a_2, apply tc'.base, simp, exact hmem}
end

theorem ex_desc : Π c i l ba m, m = (cons i l ba) → desc c m → (c ∈ l ∨ ∃ m ∈ l, desc c m) :=
begin
intros c i l ba m heq h,
induction h,
{left, rw heq at h_a_1, simp at h_a_1, exact h_a_1},
{cases h_ih heq,
 {right, split, split, exact h, apply tc'.base, exact h_a_1},
 {rcases h with ⟨w, hmem, hw⟩, right, split, split, exact hmem, apply tc'.step, exact h_a_1, exact hw}}
end

theorem ex_desc' : Π c i l ba, desc c (cons i l ba) → (c ∈ l ∨ ∃ m ∈ l, desc c m) :=
begin intros c i l ba h, apply ex_desc, repeat {refl}, exact h end

@[simp] def tmodel_anc : Π m : tmodel, Prop
| m@(cons i l ba) := ∀ s rq, desc s m → rq ∈ request s →
                     (rq ∈ manc m) ∨
                     (∃ d, desc d m ∧ some rq = msig d)

structure ptmodel (m : tmodel) : Prop :=
(bhist : tmodel_step_bhist m)
(sbox : tmodel_step_box m)
(pdia : tmodel_dia m)
(bdia : tmodel_anc m)
(reqb : proper_request_box m)
(sreq : subset_request m)

def global_pt (m : tmodel) := ∀ s, desc s m → ptmodel s

open subtype

def model : Type := {m : tmodel // ptmodel m ∧ global_pt m}

def rmodel : Type := {m : tmodel // ptmodel m}

inductive reach_step : rmodel → rmodel → Prop
| fwd_base (s : rmodel) (i l ba h) : s.1 ∈ l → reach_step ⟨(cons i l ba), h⟩  s
| bwd_base (s : rmodel) (i l ba h) : (∃ rq ∈ ba, some rq = msig s.1) → reach_step ⟨(cons i l ba), h⟩ s

theorem reach_step_box (s₁ s₂ φ) (h₁ : reach_step s₁ s₂) (h₂ : box φ ∈ htk s₁.1) : box φ ∈ htk s₂.1 :=
begin
cases h₁,
{cases s₂ with s₂ ps₂,
 cases s₂ with i₂ l₂ sg₂,
 simp,
 have := h₁_h.sbox,
 simp at this, simp at h₂,
 have hmem := this _ h₁_a _ h₂,
 simp at hmem, exact hmem },
{cases s₂ with s₂ ps₂,
 cases s₂ with i₂ l₂ sg₂,
 simp,
 rcases h₁_a with ⟨w,hmem,hw⟩,
 simp at hw,
 apply i₂.mhtk,
 have := i₂.id.ps₂,
 rw ←hw at this,
 have hneq : some w ≠ none,
   {intro heq, contradiction},
 have hsub := this hneq,
 apply hsub,
 have := h₁_h.reqb,
 simp at this, simp at h₂,
 have hc := this w hmem φ (or.inl h₂),
 cases w,
 dsimp [bsig], exact hc}
end

inductive rtc {α : Type} (r : α → α → Prop) : α → α → Prop
| refl   : Π a, rtc a a
| step   : Π a b c, r a b → rtc b c → rtc a c

theorem rtc.trans {α : Type} {r : α → α → Prop} {a b c : α} :
rtc r a b → rtc r b c → rtc r a c :=
begin
intros h₁ h₂,
induction h₁,
exact h₂,
apply rtc.step, exact h₁_a_1, apply h₁_ih, exact h₂
end

theorem rtc_step {α : Type} {r : α → α → Prop} {a b : α} (h : r a b) :
rtc r a b :=
by apply rtc.step _ _ _ h; apply rtc.refl

def reach (s₁ s₂ : rmodel) := rtc reach_step s₁ s₂

theorem refl_reach : Π s, reach s s := λ s, rtc.refl s

theorem trans_reach : Π s₁ s₂ s₃, reach s₁ s₂ → reach s₂ s₃ → reach s₁ s₃ := λ s₁ s₂ s₃ h₁ h₂, rtc.trans h₁ h₂

@[simp] def builder (m : tmodel) : S4 {x : rmodel // x.1 = m ∨ desc x.1 m} :=
{val := λ v s, var v ∈ htk s.1.1,
 rel := λ s₁ s₂, reach s₁ s₂,
 refl := λ s, refl_reach s,
 trans := λ a b c, trans_reach a b c}

open rtc

theorem reach_box (s₁ s₂ φ) (h₁ : reach s₁ s₂) (h₂ : box φ ∈ htk s₁.1) : φ ∈ htk s₂.1 :=
begin
induction h₁ with m m₁ m₂ m₃ h₁₂ h₂₃ ih,
{cases m with tm hm, cases tm with i l sg,
simp,
apply i.hhtk.hbox,
simp at h₂, exact h₂},
{apply ih,
 apply reach_step_box,
 exact h₁₂, exact h₂}
end

theorem reach_step_dia (s : rmodel) (rt : model) (φ)
(h₁ : desc s.1 rt.1)
(h₂ : manc rt.1 = []) (h₃ : dia φ ∈ htk s.1) :
∃ s', reach_step s s' ∧ φ ∈ htk s'.1 ∧ desc s'.1 rt.1 :=
begin
cases s with s ps,
cases s with i l sg,
have := ps.pdia,
simp at this, simp at h₃,
have hc := this _ h₃,
cases hc,
{cases rt with rt prt,
 cases rt with irt lrt sgrt,
 rcases hc with ⟨w, hmem, hw⟩,
 have := prt.1.bdia,
 simp at this, simp at h₁,
 have hcaux := this _ w h₁,
 simp at hcaux,
 have hcc := hcaux hmem,
 simp at h₂,
 cases hcc,
 {rw h₂ at hcc, exfalso, apply list.not_mem_nil, exact hcc},
 {rcases hcc with ⟨m, hml, hmr⟩,
  have pm := prt.2 m hml,
  split, split,
  swap 3, exact ⟨m, pm⟩,
  apply reach_step.bwd_base,
  split, split, exact hmem, simp, exact hmr,
  split,
  {cases m with im lm sgm, simp,
   apply im.mhtk,
   have := im.id.ps₁,
   simp at hmr, rw ←hmr at this,
   have hneq : some w ≠ none, {intro, contradiction},
   have hmem := this hneq,
   cases w, dsimp [dsig] at hmem,
   rw ←hw, exact hmem_1 },
  {exact hml} } },
{rcases hc with ⟨m, pml, pmr⟩,
 have hdm : desc m rt.1,
  {apply tc'.trans, apply tc'.base,
   swap 3, exact (⟨cons i l sg, ps⟩ : rmodel).val,
   simp, exact pml, exact h₁},
 cases rt with rt prt,
 cases rt with irt lrt sgrt,
 have pm := prt.2 m hdm,
 split, split, swap 3,
 exact ⟨m, pm⟩,
 apply reach_step.fwd_base,
 exact pml, split,
 {exact pmr},
 {exact hdm} }
end

theorem reach_dia (s : rmodel) (rt : model) (φ)
(h₁ : desc s.1 rt.1)
(h₂ : manc rt.1 = []) (h₃ : dia φ ∈ htk s.1) :
∃ s', reach s s' ∧ φ ∈ htk s'.1 ∧ desc s'.1 rt.1:=
begin
have := reach_step_dia s rt φ h₁ h₂ h₃,
rcases this with ⟨w, hwl, hwr⟩,
split, split, swap 3, exact w,
apply rtc_step hwl, exact hwr
end

theorem reach_step_dia_root (s : rmodel) (rt : model) (φ)
(h₁ : s.1 = rt.1)
(h₂ : manc rt.1 = []) (h₃ : dia φ ∈ htk s.1) :
∃ s', reach_step s s' ∧ φ ∈ htk s'.1 ∧ desc s'.1 rt.1 :=
begin
cases s with s ps,
cases s with is ls sgs,
have := ps.pdia,
simp at this, simp at h₃,
have hc := this _ h₃,
cases hc,
{have := ps.sreq, simp at this,
 rcases hc with ⟨w, hmw, hw⟩,
 have hmem := this hmw,
 cases rt with rt prt,
 rw ←h₁ at h₂,
 simp at h₂, rw h₂ at hmem,
 exfalso, apply list.not_mem_nil, exact hmem},
{cases rt with rt prt,
 rcases hc with ⟨w, hwl, hwr⟩,
 have ptw : ptmodel w,
   {apply prt.2, apply tc'.base, simp at h₁, rw ←h₁, simp, exact hwl},
 split, split, swap 3, exact ⟨w, ptw⟩,
 apply reach_step.fwd_base, exact hwl, split,
 {exact hwr},
 {apply tc'.base, simp, simp at h₁, rw ←h₁, simp, exact hwl} }
end

theorem reach_dia_root (s : rmodel) (rt : model) (φ)
(h₁ : s.1 = rt.1)
(h₂ : manc rt.1 = []) (h₃ : dia φ ∈ htk s.1) :
∃ s', reach s s' ∧ φ ∈ htk s'.1 ∧ desc s'.1 rt.1 :=
begin
have := reach_step_dia_root s rt φ h₁ h₂ h₃,
rcases this with ⟨w, hwl, hwr⟩,
split, split, swap 3, exact w,
apply rtc_step hwl, exact hwr
end

theorem good_model (m : model) (hrt : manc m.1 = []):
Π (s : {x : rmodel // x.1 = m.1 ∨ desc x.1 m.1}) (φ : nnf),
  φ ∈ htk s.1.1 → force (builder m.1) s φ
| s (var n) h   := begin simp, exact h end
| s (neg n) h   := begin
                     simp, intro hin,
                     cases s with s ps,
                     cases s with s pts,
                     cases s with i l sg,
                     have := i.hhtk.hno_contra,
                     simp at hin,
                     apply this hin, simp at h, exact h
                   end
| s (and φ ψ) h := begin
                   split,
                   {apply good_model,
                   cases s with s ps,
                   cases s with s pts,
                   cases s with i l sg,
                   have := i.hhtk.hand_left,
                   simp, apply this, simp at h, exact h},
                   {apply good_model,
                   cases s with s ps,
                   cases s with s pts,
                   cases s with i l sg,
                   have := i.hhtk.hand_right,
                   simp, apply this, simp at h, exact h}
                   end
| s (or φ ψ) h  := begin
                   cases s with s ps,
                   cases s with s pts,
                   cases s with i l sg,
                   have := i.hhtk.hor,
                   simp at h,
                   have hc := this h,
                   cases hc,
                   {simp, left, apply good_model, simp, exact hc},
                   {simp, right, apply good_model, simp, exact hc}
                   end
| s (box φ) h   := begin
                   intros m hm,
                   apply good_model,
                   apply reach_box,
                   exact hm,
                   exact h
                   end
| s (dia φ) h   := begin
                   cases s with s ps,
                   cases ps,
                   {simp, simp at h,
                    have := reach_dia_root _ _ _ ps hrt h,
                    rcases this with ⟨s', hs'l, hs'm, hs'r⟩,
                    split, split,
                    exact hs'l, split, apply good_model, simp,
                    exact hs'm, right, exact hs'r },
                   {simp, simp at h,
                    have := reach_dia _ _ _ ps hrt h,
                    rcases this with ⟨s', hs'l, hs'm, hs'r⟩,
                    split, split,
                    exact hs'l, split, apply good_model, simp,
                    exact hs'm, right, exact hs'r}
                   end


namespace Smt.Reconstruction.Certifying

open Classical

universe u

theorem instForAll {α : Sort u} {f : α → Prop} {a : α} :
  (forall a' : α, f a') → f a := λ h => h a

theorem instEqual₁ {A : Type u} {P : A → Prop} {t : A} :
  (forall x : A, x = t → P x) → P t := λ h => h t rfl

theorem instEqual₂ {A : Type u} {P : A → Prop} {t : A} :
  P t → (forall x : A, x = t → P x) := by
  intros h x r
  rewrite [r]
  exact h

theorem instEqual {A : Type u} {P : A → Prop} {t : A} :
  (forall x : A, x = t → P x) ↔ P t := ⟨instEqual₁, instEqual₂⟩

theorem skolem₁ {α : Sort u} [i : Nonempty α] (p : α → Prop) : (∃ x, p x) → p (epsilon p) :=
  (strongIndefiniteDescription p i).property

theorem skolem₂ {α : Sort u} [Nonempty α] (p : α → Prop) : p (epsilon p) → ∃ x, p x := λ h =>
  ⟨epsilon p, h⟩

theorem smtSkolem {α : Sort u} [h: Nonempty α] (p : α → Prop) : (∃ x, p x) ↔ p (epsilon p) :=
  ⟨@skolem₁ α h p, @skolem₂ α h p⟩

def f: Prop := ∃ _: Nat, True
axiom g : f

#check Iff.mp (smtSkolem (λ _ => True)) g

end Smt.Reconstruction.Certifying


import .open_subspace

variables {X : Type*} [topological_space X]
variables {H : top_subspace X}
variables {G : top_subspace X} (h : H ≤ G)
variables {a b : H}

noncomputable theory

#check topological_space.opens

open_locale classical topological_space filter unit_interval
open filter set function unit_interval

def subspace_path_lift (p : path a b) : path (incl a) (incl b) :=
begin
  fconstructor,
  {
    exact { to_fun := i ∘ p.to_continuous_map,
            continuous_to_fun := continuous_induced_dom.comp (map_continuous p.to_continuous_map)}
  },
  {
    simp only [path.coe_to_continuous_map, function.comp_app, path.source], unfold i, unfold incl, refl,
  },
  {
    simp only [path.target, path.coe_to_continuous_map, function.comp_app], unfold i, unfold incl, refl,
  }
end

def  subspace_path_incl (p : path a b) : path (open_incl h a) (open_incl h b) :=
begin
  fconstructor, exact continuous_map.comp (top_subspace_incl h) p.to_continuous_map,
  simp only [path.coe_to_continuous_map, continuous_map.comp_apply, path.source, continuous_map.to_fun_eq_coe],
  unfold top_subspace_incl, simp only [continuous_map.coe_mk, eq_self_iff_true],
  simp only [path.target, path.coe_to_continuous_map, continuous_map.comp_apply, continuous_map.to_fun_eq_coe],
  unfold top_subspace_incl, simp only [continuous_map.coe_mk, eq_self_iff_true],
end

notation `πₓ` := fundamental_groupoid.fundamental_groupoid_functor.obj
notation `π` := fundamental_groupoid.fundamental_groupoid_functor
notation `πₘ` := fundamental_groupoid.fundamental_groupoid_functor.map

def grpd_induced_incl : πₓ (Top.of H) ⟶ πₓ (Top.of G) := πₘ (top_subspace_incl h)

-- projection of a subspace to a subspace --

structure proj_subspace {H G : top_subspace X} (h : H ≤ G) :=
(obj : C(H, G))
(path : ∀ (a b : H), path a b → path (obj a) (obj b))

def Id {H G : top_subspace X} (h : H ≤ G) : proj_subspace h :=
{
  obj := top_subspace_incl h,
  path := λa b, subspace_path_incl h
}

-- projection of a space to a groupoid --

local attribute [instance] path.homotopic.setoid

structure proj_grpd (H : top_subspace X) (G : category_theory.Groupoid):=
(obj : H → G)
(path {a b : H} : path a b → (obj a ⟶ obj b))

def self_grpd (H : top_subspace X) : proj_grpd H (πₓ (Top.of H)):=
{
  obj := λx, x,
  path :=
  begin
    intros a b pab, exact ⟦pab⟧
  end,
}

-- lift of a path to subspace from inclusion --

def b_incl (a : X) (ha : a ∈ H) : H :=
begin
  fconstructor, exact a, exact ha,
end

@[simp] lemma incl_inv (a : H) : b_incl (incl a) (incl_carrier a) = a :=
begin
  simp_rw b_incl, simp_rw incl,cases a,simp,
end

lemma bincl_open (a : H) : b_incl (incl a) (openincl_carrier h a) = open_incl h a :=
begin
  simp_rw open_incl, rw b_incl, simp_rw incl, cases a, simp,
end

def path_lift_func {a b : X} (p : path a b) (hp : set.range p ⊆ H.carrier)
: I → H :=
begin
  intro x, let fx := p.to_fun x,
  have pfx : fx ∈ H.carrier,
  {
    apply hp, have hfx : fx = p.to_fun x, tauto,rw hfx, simp only [path.coe_to_continuous_map, set.mem_range_self, continuous_map.to_fun_eq_coe]
  }, exact b_incl fx pfx,
end

lemma path_lift_eq {a b : X} (p : path a b) (hp : set.range p ⊆ H) : incl ∘ (path_lift_func p hp) = p :=
begin
  ext1, rw function.comp, simp only [], rw path_lift_func, simp only [path.coe_to_continuous_map, continuous_map.to_fun_eq_coe],
  simp_rw b_incl,
end

lemma continuous_lift {a b : X} (p : path a b) (hp : set.range p ⊆ H) : continuous (path_lift_func p hp) :=
begin
  fconstructor, intro s, intro hs,
  have hp : path_lift_func p hp ⁻¹' s = (incl ∘ path_lift_func p hp) ⁻¹' (incl '' s),
  {
    rw @set.preimage_comp _ _ _ (path_lift_func p hp) incl (incl '' s),
    rw set.preimage_image_eq, exact incl_inj,
  },
  rw path_lift_eq at hp, rw hp,
  have hp2 : is_open (incl '' s),
  {
    apply incl_open_map, assumption,
  },
  have hp3 : continuous p,
  {
    continuity,
  },
  set k := incl ''s, cases hp3, apply hp3, assumption,
end

lemma range_in_init {a b : X} (p : path a b) (hp : set.range p ⊆ H) : a ∈ H :=
begin
  apply hp, rw range, simp only [set.mem_set_of_eq], use 0, exact p.source,
end

lemma range_in_end {a b : X} (p : path a b) (hp : set.range p ⊆ H) : b ∈ H :=
begin
  apply hp, rw range, simp only [set.mem_set_of_eq], use 1, exact p.target,
end

def path_lift_def {a b : X} (p : path a b) (hp : set.range p ⊆ H) : path (b_incl a (range_in_init p hp)) (b_incl b (range_in_end p hp)) :=
{ to_fun := path_lift_func p hp,
  continuous_to_fun := continuous_lift p hp ,
  source' :=
  begin
    simp only [],rw path_lift_func, rw b_incl, simp only [path.coe_to_continuous_map, path.source, continuous_map.to_fun_eq_coe],
    rw b_incl,
  end,
  target' :=
  begin
    simp only [],rw path_lift_func, rw b_incl, simp only [path.target, path.coe_to_continuous_map, continuous_map.to_fun_eq_coe],
    rw b_incl,
  end
}

theorem path_lift_def_eq {a b : X} (p : path a b) (hp : set.range p ⊆ H.carrier) : subspace_path_lift (path_lift_def p hp) = p :=
begin
  rw subspace_path_lift, rw path_lift_def, simp, cases p,simp, ext1, finish,
end

theorem path_incl_point_eq {a b : H} (p : path a b) (x : I) : ↑(p x) = (subspace_path_lift p) x :=
begin
  rw subspace_path_lift, unfold_coes, simp,
end

-- lemma t {K : Type} (f : K → H) (s : set K) : (f '' s) = incl ''

theorem path_incl_set_eq {a b : H} (p : path a b) (s : set I) : ↑(p '' s) = (subspace_path_lift p) '' s :=
begin
  unfold_coes, rw ←set.image_comp, apply set.image_congr', simp_rw path_incl_point_eq, rw subspace_path_lift, simp,
  --  cases p with p _ _, cases p  with p _, simp_rw set.image,unfold_coes, simp,
end

theorem path_incl_range_eq {a b : H} (p : path a b) : ↑(set.range p) = set.range (subspace_path_lift p) :=
begin
  unfold_coes, rw ←set.image_univ, rw ← set.image_univ, apply path_incl_set_eq,
  --  cases p with p _ _, cases p  with p _, simp_rw set.image,unfold_coes, simp,
end

theorem path_incl_range {a b : H} (p : path a b) (K : set X) (hp : ↑(set.range p) ⊆ K) :
set.range (subspace_path_lift p) ⊆ K :=
begin
  rw path_incl_range_eq at *, assumption,
end


import analysis.calculus.mean_value
import topology.continuous_map
import measure_theory.interval_integral
import topology.metric_space.contracting
import topology.metric_space.cau_seq_filter
import topology.algebra.continuous_functions

import picard_lindelof.other.to_mathlib

noncomputable theory
open metric set asymptotics filter real measure_theory interval_integral topological_space uniform_space
open_locale topological_space classical filter uniformity

-- NOTE: This is meant to be [a, b].
variables {A : Type*} [linear_order A] [measurable_space A]
          [topological_space A] [compact_space A] [nonempty A]
          [uniform_space A] [complete_space A] -- Maybe

-- NOTE: This is meant to be ℝ^n.
variables {B : Type*} [normed_group B] [normed_space ℝ B]
          [second_countable_topology B]
          [complete_space B] [measurable_space B]
          [borel_space B] [nonempty B]
          [complete_lattice B] [ring B] [topological_ring B] -- Maybe

instance : nonempty C(A, B) := ⟨⟨λ (a : A), @nonempty.some B (by apply_instance), continuous_const⟩⟩

-- TODO: Isn't this deduced from has_dist?
instance : has_norm C(A, B) := ⟨λ x, supr (λ t, norm (x t))⟩

instance : has_edist C(A, B) := ⟨λ x y, supr (λ t, edist (x t) (y t))⟩

instance : emetric_space C(A, B) := {
    edist_self := begin
        intros x, unfold edist, erw [supr_eq_bot],
        intros t, erw [metric_space.edist_dist, metric_space.dist_self],
        norm_num,
    end,
    eq_of_edist_eq_zero := begin
        intros x y h, unfold edist at h, erw [supr_eq_bot] at h,
        ext i, replace h := h i, erw [metric_space.edist_dist, ennreal.of_real_eq_zero] at h,
        replace h := le_antisymm h dist_nonneg,
        exact metric_space.eq_of_dist_eq_zero h,
    end,
    edist_comm := begin
        intros x y, unfold edist, apply le_antisymm,
        { rw supr_le_iff, intros i,
          erw [metric_space.edist_dist, metric_space.dist_comm, ←metric_space.edist_dist],
          exact (le_supr (λ t, metric_space.edist (y t) (x t)) i), },
        { -- TODO: Avoid repetition.
          rw supr_le_iff, intros i,
          erw [metric_space.edist_dist, metric_space.dist_comm, ←metric_space.edist_dist],
          exact (le_supr (λ t, metric_space.edist (x t) (y t)) i), }
    end,
    edist_triangle := begin
        intros x y z, unfold edist,
        suffices hle1 :
            supr (λ t, metric_space.edist (x t) (z t)) ≤
            supr (λ t, (metric_space.edist (x t) (y t)) + (metric_space.edist (y t) (z t))),
        { have hle2 := supr_add_le_add_supr
            (λ t, metric_space.edist (x t) (y t))
            (λ t, metric_space.edist (y t) (z t)),
          exact (le_trans hle1 hle2), },
        rw supr_le_iff, intros i,
        have hxyz := metric_space.dist_triangle (x i) (y i) (z i),
        replace hxyz := ennreal.of_real_le_of_real hxyz,
        replace hxyz := le_trans hxyz ennreal.of_real_add_le,
        repeat { rw [←metric_space.edist_dist] at hxyz, },
        exact (@le_supr_of_le _ _ _ (λ t, metric_space.edist (x t) (y t) + metric_space.edist (y t) (z t)) _ i hxyz),
    end,
}

open continuous_functions

instance : ring C(A, B) := continuous_map_ring

-- TODO: Move
private lemma ennreal.of_real_supr {ι : Type*} (f : ι → ℝ)
: ennreal.of_real (supr f) = supr (λ t, ennreal.of_real (f t)) :=
begin
    ext, split,
    { sorry, },
    { sorry, }
end

instance : complete_space C(A, B) :=
begin
    apply emetric.complete_of_cauchy_seq_tendsto,
    intros u hu,
    have huε : is_cau_seq norm u,
    { cases cauchy_iff.1 hu with hu1 hu2,
      intros ε hε,
      have hεrw := (ennreal.of_real_lt_of_real_iff hε),
      have hennε := hεrw.2 hε,
      rw ennreal.of_real_zero at hennε,
      rcases hu2 {x | edist x.1 x.2 < ennreal.of_real ε} (edist_mem_uniformity hennε) with ⟨t, ⟨ht, htsub⟩⟩,
      simp at ht, cases ht with N hN,
      existsi N, intros j hj,
      unfold has_norm.norm,
      have hujN := @htsub (u j, u N) (set.mk_mem_prod (hN j hj) (hN N (le_refl N))),
      simp at hujN,
      unfold edist at hujN,
      -- TODO: Prove some nice properties of edist.
      have heq : (λ (t : A), metric_space.edist ((u j) t) ((u N) t)) =
                 (λ (t : A), ennreal.of_real (norm (((u j) - (u N)) t))),
      { funext, erw [←dist_eq_norm, metric_space.edist_dist], },
      apply (ennreal.of_real_lt_of_real_iff hε).1,
      rw ennreal.of_real_supr,
      sorry,
      -- TODO: So close. Will this work when ennreal.of_real_supr is proved?
      --erw ←heq,
      --exact hujN,
      },

    let fn := λ x n, (u n) x,
    let f := λ x, (lim at_top (fn x)),
    have hf : continuous f := sorry,
    --have h := tendsto_nhds_lim,
    use [⟨f, hf⟩],
    rw emetric.cauchy_seq_iff at hu,
    rw emetric.tendsto_nhds,
    intros ε hε,

    sorry,
end


/-
Copyright (c) 2022 Henrik Böving. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Henrik Böving, Simon Hudon
-/
import Mathlib.Testing.SlimCheck.Gen
/-!
# `SampleableExt` Class
This class permits the creation samples of a given type
controlling the size of those values using the `Gen` monad`.

# `Shrinkable` Class
This class helps minimize examples by creating smaller versions of
given values.

When testing a proposition like `∀ n : ℕ, prime n → n ≤ 100`,
`SlimCheck` requires that `ℕ` have an instance of `SampleableExt` and for
`prime n` to be decidable.  `SlimCheck` will then use the instance of
`SampleableExt` to generate small examples of ℕ and progressively increase
in size. For each example `n`, `prime n` is tested. If it is false,
the example will be rejected (not a test success nor a failure) and
`SlimCheck` will move on to other examples. If `prime n` is true, `n
≤ 100` will be tested. If it is false, `n` is a counter-example of `∀
n : ℕ, prime n → n ≤ 100` and the test fails. If `n ≤ 100` is true,
the test passes and `SlimCheck` moves on to trying more examples.

This is a port of the Haskell QuickCheck library.

## Main definitions
  * `SampleableExt` class
  * `Shrinkable` class

### `SampleableExt`
`SampleableExt` can be used in two ways. The first (and most common)
is to simply generate values of a type directly using the `Gen` monad,
if this is what you want to do then `SampleableExt.mkSelfContained` is
the way to go.

Furthermore it makes it possible to express generators for types that
do not lend themselves to introspection, such as `ℕ → ℕ`.
If we test a quantification over functions the
counter-examples cannot be shrunken or printed meaningfully.
For that purpose, `SampleableExt` provides a proxy representation
`proxy` that can be printed and shrunken as well
as interpreted (using `interp`) as an object of the right type. If you
are using it in the first way, this proxy type will simply be the type
itself and the `interp` function `id`.

### `Shrinkable
Given an example `x : α`, `Shrinkable α` gives us a way to shrink it
and suggest simpler examples.

## Shrinking
Shrinking happens when `SlimCheck` find a counter-example to a
property.  It is likely that the example will be more complicated than
necessary so `SlimCheck` proceeds to shrink it as much as
possible. Although equally valid, a smaller counter-example is easier
for a user to understand and use.

The `Shrinkable` class, , has a `shrink` function so that we can use
specialized knowledge while shrinking a value. It is not responsible
for the whole shrinking process however. It only has to take one step
in the shrinking process. `SlimCheck` will repeatedly call `shrink`
until no more steps can be taken. Because `shrink` guarantees that the
size of the candidates it produces is strictly smaller than the
argument, we know that `SlimCheck` is guaranteed to terminate.

## Tags

random testing

## References
  * https://hackage.haskell.org/package/QuickCheck
-/

namespace SlimCheck

open Random Gen

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

/-- `SampleableExt` can be used in two ways. The first (and most common)
is to simply generate values of a type directly using the `Gen` monad,
if this is what you want to do then `SampleableExt.mkSelfContained` is
the way to go.

Furthermore it makes it possible to express generators for types that
do not lend themselves to introspection, such as `ℕ → ℕ`.
If we test a quantification over functions the
counter-examples cannot be shrunken or printed meaningfully.
For that purpose, `SampleableExt` provides a proxy representation
`proxy` that can be printed and shrunken as well
as interpreted (using `interp`) as an object of the right type. -/
class SampleableExt (α : Sort u) where
  proxy : Type v
  [proxyRepr : Repr proxy]
  [shrink : Shrinkable proxy]
  sample : Gen proxy
  interp : proxy → α

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

namespace SampleableExt

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

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

end SampleableExt

section Shrinkers

/-- `Nat.shrink' n` creates a list of smaller natural numbers by
successively dividing `n` by 2 . For example, `Nat.shrink 5 = [2, 1, 0]`. -/
def Nat.shrink (n : Nat) : List { y : Nat // WellFoundedRelation.rel y n } :=
  if h : 0 < n then
    let m := n/2
    have h : m < n := by
      apply Nat.div_lt_self h
      decide
    let rest := shrink m
    let current := ⟨m, h⟩
    current ::
      rest.map (λ x => {x with property := Nat.lt_trans x.property h})
  else
    []

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

/-- `Fin.shrink` works like `Nat.shrink` but instead operates on `Fin`. -/
def Fin.shrink {n : Nat} (m : Fin n.succ) :
    List { y : Fin n.succ // WellFoundedRelation.rel y m } :=
  let shrinks := Nat.shrink m.val
  shrinks.map (λ x => { x with property := (by
    simp_wf
    exact lt_of_le_of_lt (Nat.mod_le _ _) x.property) })

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

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

/-- `Int.shrinkable` operates like `Nat.shrinkable` but also includes the negative variants. -/
instance Int.shrinkable : Shrinkable Int where
  shrink n := Nat.shrink n.natAbs |>.map λ ⟨x, h⟩ =>
    ⟨-x, (by simp_wf; simp only [SizeOf.sizeOf]; rw [Int.natAbs_neg]; exact h)⟩

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

instance Prod.shrinkable [shrA : Shrinkable α] [shrB : Shrinkable β] : Shrinkable (Prod α β) where
  shrink := λ (fst,snd) =>
    let shrink1 := shrA.shrink fst |>.map
      fun ⟨x, _⟩ ↦ ⟨(x, snd), by simp_wf; apply Prod.Lex.left; simp_all_arith⟩
    let shrink2 := shrB.shrink snd |>.map
      fun ⟨x, _⟩ ↦ ⟨(fst, x), by simp_wf; apply Prod.Lex.right; simp_all_arith⟩
    shrink1 ++ shrink2

end Shrinkers

section Samplers

open SampleableExt

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

instance Fin.sampleableExt {n : Nat} : SampleableExt (Fin (n.succ)) :=
  mkSelfContained (do choose (Fin n.succ) (Fin.ofNat 0) (Fin.ofNat (←getSize)) (by
    simp [Fin.ofNat, LE.le]
    exact Nat.zero_le _
  ))

instance Int.sampleableExt : SampleableExt Int :=
  mkSelfContained (do
    choose Int (-(←getSize)) (←getSize)
      (le_trans (Int.neg_nonpos_of_nonneg (Int.ofNat_zero_le _)) (Int.ofNat_zero_le _)))

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

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

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

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

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

end Samplers

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

namespace NoShrink

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

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

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

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

end NoShrink

end SlimCheck


import tactic
import data.list.alist
import data.equiv.denumerable
import data.equiv.encodable.basic

/-- Formulas of modal logic
form vars ∷= ⦃x : vars⦄ | ⊥ | ~ form | form ⋀ form | form ⋁ form -/
inductive form (vars : Type) : Type
| Bottom : form
| Var    : vars → form
| Not    : form → form
| And    : form → form → form
| Or     : form → form → form
| Imply  : form → form → form
| Box    : form → form

-- get the ⊥ notation for Bottom
-- and allow simp to use this definition
instance {vars : Type} : has_bot (form vars) := ⟨form.Bottom⟩
@[simp] lemma bottom_eq_bot {vars : Type} : ⊥ = (form.Bottom : form vars) := rfl

notation `⦃` x `⦄` := form.Var x
prefix `~`:75 := form.Not
prefix `□`:75 := form.Box
infixl ` ⋀ `:70 := form.And
infixl ` ⋁ `:65 := form.Or
infixr ` ⟹ `:60 := form.Imply

-- Since we intend to use a classical semantics, ◇ can be implemented in terms
-- of □
prefix `◇`:75 := form.Not ∘ form.Box ∘ form.Not

@[simp] lemma diamond_eq_not_box_not {vars : Type} {A : form vars}
  : ◇ A = ~ □ ~ A := rfl

variables {vars : Type} [denumerable vars]
variables {A B C : form vars}

instance vars_decidable_eq : decidable_eq vars :=
encodable.decidable_eq_of_encodable _

instance form_inhabited : inhabited (form vars) := ⟨form.Bottom⟩

/-- A simultaneous substitution on formulas is an association list (key-value)
mapping from variables to the formula that it should be substituted by.-/
def subst (vars : Type) : Type := alist (λ _ : vars, form vars)

-- can't resolve these implicitly for some reason, even after importing.
instance : has_mem vars (subst vars) := alist.has_mem
instance : has_emptyc (subst vars) := alist.has_emptyc
instance : has_union (subst vars) := alist.has_union

def subst.get (s : subst vars) (x : vars) : form vars :=
(s.lookup x).get_or_else ⦃x⦄

/-- This function applies a simultaneous substitution to a formula. -/
def subst.apply (s : subst vars) : form vars → form vars
| form.Bottom := form.Bottom
| ⦃x⦄      := s.get x
| ~ A      := ~ (subst.apply A)
| □ A      := □ (subst.apply A)
| (A ⋀ B)  := (subst.apply A) ⋀ (subst.apply B)
| (A ⋁ B)  := (subst.apply A) ⋁ (subst.apply B)
| (A ⟹ B) := (subst.apply A) ⟹ (subst.apply B)

theorem subst.apply_empty_id : subst.apply ∅ A = A :=
begin
  induction A,
  case form.Bottom { simp [subst.apply] },
  case form.Var { simp [subst.apply, subst.get] },
  case form.Not : A ih { simp [subst.apply, ih] },
  case form.Box : A ih { simp [subst.apply, ih] },
  case form.And : A B ihA ihB { simp [subst.apply, ihA, ihB] },
  case form.Or : A B ihA ihB { simp [subst.apply, ihA, ihB] },
  case form.Imply : A B ihA ihB { simp [subst.apply, ihA, ihB] }
end


/-
Copyright (c) 2018 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau, Yury Kudryashov
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.algebra.operations
import Mathlib.PostPort

universes u v l w u_1 u_2 u_3

namespace Mathlib

/-!
# Subalgebras over Commutative Semiring

In this file we define `subalgebra`s and the usual operations on them (`map`, `comap`).

More lemmas about `adjoin` can be found in `ring_theory.adjoin`.
-/

/-- A subalgebra is a sub(semi)ring that includes the range of `algebra_map`. -/
structure subalgebra (R : Type u) (A : Type v) [comm_semiring R] [semiring A] [algebra R A]
extends subsemiring A
where
  algebra_map_mem' : ∀ (r : R), coe_fn (algebra_map R A) r ∈ carrier

/-- Reinterpret a `subalgebra` as a `subsemiring`. -/
namespace subalgebra

protected instance subsemiring.has_coe {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] : has_coe (subalgebra R A) (subsemiring A) :=
  has_coe.mk fun (S : subalgebra R A) => subsemiring.mk (carrier S) (one_mem' S) (mul_mem' S) (zero_mem' S) (add_mem' S)

protected instance has_mem {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] : has_mem A (subalgebra R A) :=
  has_mem.mk fun (x : A) (S : subalgebra R A) => x ∈ ↑S

theorem mem_coe {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] {x : A} {s : subalgebra R A} : x ∈ ↑s ↔ x ∈ s :=
  iff.rfl

theorem ext {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] {S : subalgebra R A} {T : subalgebra R A} (h : ∀ (x : A), x ∈ S ↔ x ∈ T) : S = T := sorry

theorem ext_iff {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] {S : subalgebra R A} {T : subalgebra R A} : S = T ↔ ∀ (x : A), x ∈ S ↔ x ∈ T :=
  { mp := fun (h : S = T) (x : A) => eq.mpr (id (Eq._oldrec (Eq.refl (x ∈ S ↔ x ∈ T)) h)) (iff.refl (x ∈ T)), mpr := ext }

theorem algebra_map_mem {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] (S : subalgebra R A) (r : R) : coe_fn (algebra_map R A) r ∈ S :=
  algebra_map_mem' S r

theorem srange_le {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] (S : subalgebra R A) : ring_hom.srange (algebra_map R A) ≤ ↑S := sorry

theorem range_subset {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] (S : subalgebra R A) : set.range ⇑(algebra_map R A) ⊆ ↑S := sorry

theorem range_le {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] (S : subalgebra R A) : set.range ⇑(algebra_map R A) ≤ ↑S :=
  range_subset S

theorem one_mem {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] (S : subalgebra R A) : 1 ∈ S :=
  subsemiring.one_mem ↑S

theorem mul_mem {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] (S : subalgebra R A) {x : A} {y : A} (hx : x ∈ S) (hy : y ∈ S) : x * y ∈ S :=
  subsemiring.mul_mem (↑S) hx hy

theorem smul_mem {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] (S : subalgebra R A) {x : A} (hx : x ∈ S) (r : R) : r • x ∈ S :=
  Eq.symm (algebra.smul_def r x) ▸ mul_mem S (algebra_map_mem S r) hx

theorem pow_mem {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] (S : subalgebra R A) {x : A} (hx : x ∈ S) (n : ℕ) : x ^ n ∈ S :=
  subsemiring.pow_mem (↑S) hx n

theorem zero_mem {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] (S : subalgebra R A) : 0 ∈ S :=
  subsemiring.zero_mem ↑S

theorem add_mem {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] (S : subalgebra R A) {x : A} {y : A} (hx : x ∈ S) (hy : y ∈ S) : x + y ∈ S :=
  subsemiring.add_mem (↑S) hx hy

theorem neg_mem {R : Type u} {A : Type v} [comm_ring R] [ring A] [algebra R A] (S : subalgebra R A) {x : A} (hx : x ∈ S) : -x ∈ S :=
  neg_one_smul R x ▸ smul_mem S hx (-1)

theorem sub_mem {R : Type u} {A : Type v} [comm_ring R] [ring A] [algebra R A] (S : subalgebra R A) {x : A} {y : A} (hx : x ∈ S) (hy : y ∈ S) : x - y ∈ S := sorry

theorem nsmul_mem {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] (S : subalgebra R A) {x : A} (hx : x ∈ S) (n : ℕ) : n •ℕ x ∈ S :=
  subsemiring.nsmul_mem (↑S) hx n

theorem gsmul_mem {R : Type u} {A : Type v} [comm_ring R] [ring A] [algebra R A] (S : subalgebra R A) {x : A} (hx : x ∈ S) (n : ℤ) : n •ℤ x ∈ S :=
  int.cases_on n (fun (i : ℕ) => nsmul_mem S hx i) fun (i : ℕ) => neg_mem S (nsmul_mem S hx (Nat.succ i))

theorem coe_nat_mem {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] (S : subalgebra R A) (n : ℕ) : ↑n ∈ S :=
  subsemiring.coe_nat_mem (↑S) n

theorem coe_int_mem {R : Type u} {A : Type v} [comm_ring R] [ring A] [algebra R A] (S : subalgebra R A) (n : ℤ) : ↑n ∈ S :=
  int.cases_on n (fun (i : ℕ) => coe_nat_mem S i) fun (i : ℕ) => neg_mem S (coe_nat_mem S (i + 1))

theorem list_prod_mem {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] (S : subalgebra R A) {L : List A} (h : ∀ (x : A), x ∈ L → x ∈ S) : list.prod L ∈ S :=
  subsemiring.list_prod_mem (↑S) h

theorem list_sum_mem {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] (S : subalgebra R A) {L : List A} (h : ∀ (x : A), x ∈ L → x ∈ S) : list.sum L ∈ S :=
  subsemiring.list_sum_mem (↑S) h

theorem multiset_prod_mem {R : Type u} {A : Type v} [comm_semiring R] [comm_semiring A] [algebra R A] (S : subalgebra R A) {m : multiset A} (h : ∀ (x : A), x ∈ m → x ∈ S) : multiset.prod m ∈ S :=
  subsemiring.multiset_prod_mem (↑S) m h

theorem multiset_sum_mem {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] (S : subalgebra R A) {m : multiset A} (h : ∀ (x : A), x ∈ m → x ∈ S) : multiset.sum m ∈ S :=
  subsemiring.multiset_sum_mem (↑S) m h

theorem prod_mem {R : Type u} {A : Type v} [comm_semiring R] [comm_semiring A] [algebra R A] (S : subalgebra R A) {ι : Type w} {t : finset ι} {f : ι → A} (h : ∀ (x : ι), x ∈ t → f x ∈ S) : (finset.prod t fun (x : ι) => f x) ∈ S :=
  subsemiring.prod_mem (↑S) h

theorem sum_mem {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] (S : subalgebra R A) {ι : Type w} {t : finset ι} {f : ι → A} (h : ∀ (x : ι), x ∈ t → f x ∈ S) : (finset.sum t fun (x : ι) => f x) ∈ S :=
  subsemiring.sum_mem (↑S) h

protected instance is_add_submonoid {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] (S : subalgebra R A) : is_add_submonoid ↑S :=
  is_add_submonoid.mk (zero_mem S) fun (_x _x_1 : A) => add_mem S

protected instance is_submonoid {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] (S : subalgebra R A) : is_submonoid ↑S :=
  is_submonoid.mk (one_mem S) fun (_x _x_1 : A) => mul_mem S

/-- A subalgebra over a ring is also a `subring`. -/
def to_subring {R : Type u} {A : Type v} [comm_ring R] [ring A] [algebra R A] (S : subalgebra R A) : subring A :=
  subring.mk (subsemiring.carrier (to_subsemiring S)) sorry sorry sorry sorry sorry

protected instance is_subring {R : Type u} {A : Type v} [comm_ring R] [ring A] [algebra R A] (S : subalgebra R A) : is_subring ↑S :=
  is_subring.mk

protected instance inhabited {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] (S : subalgebra R A) : Inhabited ↥S :=
  { default := 0 }

protected instance semiring (R : Type u) (A : Type v) [comm_semiring R] [semiring A] [algebra R A] (S : subalgebra R A) : semiring ↥S :=
  subsemiring.to_semiring ↑S

protected instance comm_semiring (R : Type u) (A : Type v) [comm_semiring R] [comm_semiring A] [algebra R A] (S : subalgebra R A) : comm_semiring ↥S :=
  subsemiring.to_comm_semiring ↑S

protected instance ring (R : Type u) (A : Type v) [comm_ring R] [ring A] [algebra R A] (S : subalgebra R A) : ring ↥S :=
  subtype.ring

protected instance comm_ring (R : Type u) (A : Type v) [comm_ring R] [comm_ring A] [algebra R A] (S : subalgebra R A) : comm_ring ↥S :=
  subtype.comm_ring

protected instance algebra {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] (S : subalgebra R A) : algebra R ↥S :=
  algebra.mk (ring_hom.mk (ring_hom.to_fun (ring_hom.cod_srestrict (algebra_map R A) ↑S sorry)) sorry sorry sorry sorry)
    sorry sorry

protected instance to_algebra {R : Type u_1} {A : Type u_2} {B : Type u_3} [comm_semiring R] [comm_semiring A] [semiring B] [algebra R A] [algebra A B] (A₀ : subalgebra R A) : algebra (↥A₀) B :=
  algebra.of_subsemiring ↑A₀

protected instance nontrivial {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] (S : subalgebra R A) [nontrivial A] : nontrivial ↥S :=
  subsemiring.nontrivial ↑S

-- todo: standardize on the names these morphisms

-- compare with submodule.subtype

/-- Embedding of a subalgebra into the algebra. -/
def val {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] (S : subalgebra R A) : alg_hom R (↥S) A :=
  alg_hom.mk coe sorry sorry sorry sorry sorry

@[simp] theorem coe_val {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] (S : subalgebra R A) : ⇑(val S) = coe :=
  rfl

theorem val_apply {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] (S : subalgebra R A) (x : ↥S) : coe_fn (val S) x = ↑x :=
  rfl

/-- Convert a `subalgebra` to `submodule` -/
def to_submodule {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] (S : subalgebra R A) : submodule R A :=
  submodule.mk ↑S sorry sorry sorry

protected instance coe_to_submodule {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] : has_coe (subalgebra R A) (submodule R A) :=
  has_coe.mk to_submodule

protected instance to_submodule.is_subring {R : Type u} {A : Type v} [comm_ring R] [ring A] [algebra R A] (S : subalgebra R A) : is_subring ↑↑S :=
  subalgebra.is_subring S

@[simp] theorem mem_to_submodule {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] (S : subalgebra R A) {x : A} : x ∈ ↑S ↔ x ∈ S :=
  iff.rfl

theorem to_submodule_injective {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] {S : subalgebra R A} {U : subalgebra R A} (h : ↑S = ↑U) : S = U := sorry

theorem to_submodule_inj {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] {S : subalgebra R A} {U : subalgebra R A} : ↑S = ↑U ↔ S = U :=
  { mp := to_submodule_injective, mpr := congr_arg fun {S : subalgebra R A} => ↑S }

/-- As submodules, subalgebras are idempotent. -/
@[simp] theorem mul_self {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] (S : subalgebra R A) : ↑S * ↑S = ↑S := sorry

/-- Linear equivalence between `S : submodule R A` and `S`. Though these types are equal,
we define it as a `linear_equiv` to avoid type equalities. -/
def to_submodule_equiv {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] (S : subalgebra R A) : linear_equiv R ↥↑S ↥S :=
  linear_equiv.of_eq (↑S) (has_coe_t_aux.coe S) sorry

protected instance partial_order {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] : partial_order (subalgebra R A) :=
  partial_order.mk (fun (S T : subalgebra R A) => ↑S ⊆ ↑T) (preorder.lt._default fun (S T : subalgebra R A) => ↑S ⊆ ↑T)
    sorry sorry sorry

/-- Reinterpret an `S`-subalgebra as an `R`-subalgebra in `comap R S A`. -/
def comap {R : Type u} {S : Type v} {A : Type w} [comm_semiring R] [comm_semiring S] [semiring A] [algebra R S] [algebra S A] (iSB : subalgebra S A) : subalgebra R (algebra.comap R S A) :=
  mk (carrier iSB) (one_mem' iSB) (mul_mem' iSB) (zero_mem' iSB) (add_mem' iSB) sorry

/-- If `S` is an `R`-subalgebra of `A` and `T` is an `S`-subalgebra of `A`,
then `T` is an `R`-subalgebra of `A`. -/
def under {R : Type u} {A : Type v} [comm_semiring R] [comm_semiring A] {i : algebra R A} (S : subalgebra R A) (T : subalgebra (↥S) A) : subalgebra R A :=
  mk (carrier T) sorry sorry sorry sorry sorry

/-- Transport a subalgebra via an algebra homomorphism. -/
def map {R : Type u} {A : Type v} {B : Type w} [comm_semiring R] [semiring A] [algebra R A] [semiring B] [algebra R B] (S : subalgebra R A) (f : alg_hom R A B) : subalgebra R B :=
  mk (subsemiring.carrier (subsemiring.map ↑f ↑S)) sorry sorry sorry sorry sorry

/-- Preimage of a subalgebra under an algebra homomorphism. -/
def comap' {R : Type u} {A : Type v} {B : Type w} [comm_semiring R] [semiring A] [algebra R A] [semiring B] [algebra R B] (S : subalgebra R B) (f : alg_hom R A B) : subalgebra R A :=
  mk (subsemiring.carrier (subsemiring.comap ↑f ↑S)) sorry sorry sorry sorry sorry

theorem map_mono {R : Type u} {A : Type v} {B : Type w} [comm_semiring R] [semiring A] [algebra R A] [semiring B] [algebra R B] {S₁ : subalgebra R A} {S₂ : subalgebra R A} {f : alg_hom R A B} : S₁ ≤ S₂ → map S₁ f ≤ map S₂ f :=
  set.image_subset ⇑f

theorem map_le {R : Type u} {A : Type v} {B : Type w} [comm_semiring R] [semiring A] [algebra R A] [semiring B] [algebra R B] {S : subalgebra R A} {f : alg_hom R A B} {U : subalgebra R B} : map S f ≤ U ↔ S ≤ comap' U f :=
  set.image_subset_iff

theorem map_injective {R : Type u} {A : Type v} {B : Type w} [comm_semiring R] [semiring A] [algebra R A] [semiring B] [algebra R B] {S₁ : subalgebra R A} {S₂ : subalgebra R A} (f : alg_hom R A B) (hf : function.injective ⇑f) (ih : map S₁ f = map S₂ f) : S₁ = S₂ :=
  ext
    (iff.mp set.ext_iff
      (iff.mpr set.image_injective hf (fun (x : A) => x ∈ ↑S₁) (fun (x : A) => x ∈ ↑S₂) (set.ext (iff.mp ext_iff ih))))

theorem mem_map {R : Type u} {A : Type v} {B : Type w} [comm_semiring R] [semiring A] [algebra R A] [semiring B] [algebra R B] {S : subalgebra R A} {f : alg_hom R A B} {y : B} : y ∈ map S f ↔ ∃ (x : A), ∃ (H : x ∈ S), coe_fn f x = y :=
  subsemiring.mem_map

protected instance no_zero_divisors {R : Type u_1} {A : Type u_2} [comm_ring R] [semiring A] [no_zero_divisors A] [algebra R A] (S : subalgebra R A) : no_zero_divisors ↥S :=
  subsemiring.no_zero_divisors (to_subsemiring S)

protected instance integral_domain {R : Type u_1} {A : Type u_2} [comm_ring R] [integral_domain A] [algebra R A] (S : subalgebra R A) : integral_domain ↥S :=
  subring.domain ↑S

end subalgebra

namespace alg_hom

/-- Range of an `alg_hom` as a subalgebra. -/
protected def range {R : Type u} {A : Type v} {B : Type w} [comm_semiring R] [semiring A] [semiring B] [algebra R A] [algebra R B] (φ : alg_hom R A B) : subalgebra R B :=
  subalgebra.mk (subsemiring.carrier (ring_hom.srange (to_ring_hom φ))) sorry sorry sorry sorry sorry

@[simp] theorem mem_range {R : Type u} {A : Type v} {B : Type w} [comm_semiring R] [semiring A] [semiring B] [algebra R A] [algebra R B] (φ : alg_hom R A B) {y : B} : y ∈ alg_hom.range φ ↔ ∃ (x : A), coe_fn φ x = y :=
  ring_hom.mem_srange

@[simp] theorem coe_range {R : Type u} {A : Type v} {B : Type w} [comm_semiring R] [semiring A] [semiring B] [algebra R A] [algebra R B] (φ : alg_hom R A B) : ↑(alg_hom.range φ) = set.range ⇑φ := sorry

/-- Restrict the codomain of an algebra homomorphism. -/
def cod_restrict {R : Type u} {A : Type v} {B : Type w} [comm_semiring R] [semiring A] [semiring B] [algebra R A] [algebra R B] (f : alg_hom R A B) (S : subalgebra R B) (hf : ∀ (x : A), coe_fn f x ∈ S) : alg_hom R A ↥S :=
  mk (ring_hom.to_fun (ring_hom.cod_srestrict (↑f) (↑S) hf)) sorry sorry sorry sorry sorry

theorem injective_cod_restrict {R : Type u} {A : Type v} {B : Type w} [comm_semiring R] [semiring A] [semiring B] [algebra R A] [algebra R B] (f : alg_hom R A B) (S : subalgebra R B) (hf : ∀ (x : A), coe_fn f x ∈ S) : function.injective ⇑(cod_restrict f S hf) ↔ function.injective ⇑f := sorry

/-- Restrict an injective algebra homomorphism to an algebra isomorphism -/
def alg_equiv.of_injective {R : Type u} {A : Type v} {B : Type w} [comm_semiring R] [semiring A] [semiring B] [algebra R A] [algebra R B] (f : alg_hom R A B) (hf : function.injective ⇑f) : alg_equiv R A ↥(alg_hom.range f) :=
  alg_equiv.of_bijective (cod_restrict f (alg_hom.range f) sorry) sorry

@[simp] theorem alg_equiv.of_injective_apply {R : Type u} {A : Type v} {B : Type w} [comm_semiring R] [semiring A] [semiring B] [algebra R A] [algebra R B] (f : alg_hom R A B) (hf : function.injective ⇑f) (x : A) : ↑(coe_fn (alg_equiv.of_injective f hf) x) = coe_fn f x :=
  rfl

/-- Restrict an algebra homomorphism between fields to an algebra isomorphism -/
def alg_equiv.of_injective_field {R : Type u} [comm_semiring R] {E : Type u_1} {F : Type u_2} [division_ring E] [semiring F] [nontrivial F] [algebra R E] [algebra R F] (f : alg_hom R E F) : alg_equiv R E ↥(alg_hom.range f) :=
  alg_equiv.of_injective f sorry

/-- The equalizer of two R-algebra homomorphisms -/
def equalizer {R : Type u} {A : Type v} {B : Type w} [comm_semiring R] [semiring A] [semiring B] [algebra R A] [algebra R B] (ϕ : alg_hom R A B) (ψ : alg_hom R A B) : subalgebra R A :=
  subalgebra.mk (set_of fun (a : A) => coe_fn ϕ a = coe_fn ψ a) sorry sorry sorry sorry sorry

@[simp] theorem mem_equalizer {R : Type u} {A : Type v} {B : Type w} [comm_semiring R] [semiring A] [semiring B] [algebra R A] [algebra R B] (ϕ : alg_hom R A B) (ψ : alg_hom R A B) (x : A) : x ∈ equalizer ϕ ψ ↔ coe_fn ϕ x = coe_fn ψ x :=
  iff.rfl

end alg_hom

namespace algebra

/-- The minimal subalgebra that includes `s`. -/
def adjoin (R : Type u) {A : Type v} [comm_semiring R] [semiring A] [algebra R A] (s : set A) : subalgebra R A :=
  subalgebra.mk (subsemiring.carrier (subsemiring.closure (set.range ⇑(algebra_map R A) ∪ s))) sorry sorry sorry sorry
    sorry

protected theorem gc {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] : galois_connection (adjoin R) coe := sorry

/-- Galois insertion between `adjoin` and `coe`. -/
protected def gi {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] : galois_insertion (adjoin R) coe :=
  galois_insertion.mk (fun (s : set A) (hs : ↑(adjoin R s) ≤ s) => adjoin R s) algebra.gc sorry sorry

protected instance subalgebra.complete_lattice {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] : complete_lattice (subalgebra R A) :=
  galois_insertion.lift_complete_lattice algebra.gi

protected instance subalgebra.inhabited {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] : Inhabited (subalgebra R A) :=
  { default := ⊥ }

theorem mem_bot {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] {x : A} : x ∈ ⊥ ↔ x ∈ set.range ⇑(algebra_map R A) := sorry

theorem to_submodule_bot {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] : ↑⊥ = submodule.span R (singleton 1) := sorry

@[simp] theorem mem_top {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] {x : A} : x ∈ ⊤ :=
  subsemiring.subset_closure (Or.inr trivial)

@[simp] theorem coe_top {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] : ↑⊤ = ⊤ :=
  submodule.ext fun (x : A) => iff_of_true mem_top trivial

@[simp] theorem coe_bot {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] : ↑⊥ = set.range ⇑(algebra_map R A) := sorry

theorem eq_top_iff {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] {S : subalgebra R A} : S = ⊤ ↔ ∀ (x : A), x ∈ S := sorry

@[simp] theorem map_top {R : Type u} {A : Type v} {B : Type w} [comm_semiring R] [semiring A] [algebra R A] [semiring B] [algebra R B] (f : alg_hom R A B) : subalgebra.map ⊤ f = alg_hom.range f := sorry

@[simp] theorem map_bot {R : Type u} {A : Type v} {B : Type w} [comm_semiring R] [semiring A] [algebra R A] [semiring B] [algebra R B] (f : alg_hom R A B) : subalgebra.map ⊥ f = ⊥ := sorry

@[simp] theorem comap_top {R : Type u} {A : Type v} {B : Type w} [comm_semiring R] [semiring A] [algebra R A] [semiring B] [algebra R B] (f : alg_hom R A B) : subalgebra.comap' ⊤ f = ⊤ :=
  iff.mpr eq_top_iff fun (x : A) => mem_top

/-- `alg_hom` to `⊤ : subalgebra R A`. -/
def to_top {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] : alg_hom R A ↥⊤ :=
  alg_hom.mk (fun (x : A) => { val := x, property := mem_top }) sorry sorry sorry sorry sorry

theorem surjective_algebra_map_iff {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] : function.surjective ⇑(algebra_map R A) ↔ ⊤ = ⊥ := sorry

theorem bijective_algebra_map_iff {R : Type u_1} {A : Type u_2} [field R] [semiring A] [nontrivial A] [algebra R A] : function.bijective ⇑(algebra_map R A) ↔ ⊤ = ⊥ :=
  { mp := fun (h : function.bijective ⇑(algebra_map R A)) => iff.mp surjective_algebra_map_iff (and.right h),
    mpr :=
      fun (h : ⊤ = ⊥) => { left := ring_hom.injective (algebra_map R A), right := iff.mpr surjective_algebra_map_iff h } }

/-- The bottom subalgebra is isomorphic to the base ring. -/
def bot_equiv_of_injective {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] (h : function.injective ⇑(algebra_map R A)) : alg_equiv R (↥⊥) R :=
  alg_equiv.symm (alg_equiv.of_bijective (of_id R ↥⊥) sorry)

/-- The bottom subalgebra is isomorphic to the field. -/
def bot_equiv (F : Type u_1) (R : Type u_2) [field F] [semiring R] [nontrivial R] [algebra F R] : alg_equiv F (↥⊥) F :=
  bot_equiv_of_injective sorry

/-- The top subalgebra is isomorphic to the field. -/
def top_equiv {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] : alg_equiv R (↥⊤) A :=
  alg_equiv.symm (alg_equiv.of_bijective to_top sorry)

end algebra

namespace subalgebra

theorem range_val {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] (S : subalgebra R A) : alg_hom.range (val S) = S :=
  ext (iff.mp set.ext_iff (Eq.trans (alg_hom.coe_range (val S)) subtype.range_val))

protected instance unique {R : Type u} [comm_semiring R] : unique (subalgebra R R) :=
  unique.mk { default := Inhabited.default } sorry

end subalgebra

/-- A subsemiring is a `ℕ`-subalgebra. -/
def subalgebra_of_subsemiring {R : Type u_1} [semiring R] (S : subsemiring R) : subalgebra ℕ R :=
  subalgebra.mk (subsemiring.carrier S) (subsemiring.one_mem' S) (subsemiring.mul_mem' S) (subsemiring.zero_mem' S)
    (subsemiring.add_mem' S) sorry

@[simp] theorem mem_subalgebra_of_subsemiring {R : Type u_1} [semiring R] {x : R} {S : subsemiring R} : x ∈ subalgebra_of_subsemiring S ↔ x ∈ S :=
  iff.rfl

/-- A subring is a `ℤ`-subalgebra. -/
def subalgebra_of_subring {R : Type u_1} [ring R] (S : subring R) : subalgebra ℤ R :=
  subalgebra.mk (subring.carrier S) (subring.one_mem' S) (subring.mul_mem' S) (subring.zero_mem' S) (subring.add_mem' S)
    sorry

/-- A subset closed under the ring operations is a `ℤ`-subalgebra. -/
def subalgebra_of_is_subring {R : Type u_1} [ring R] (S : set R) [is_subring S] : subalgebra ℤ R :=
  subalgebra_of_subring (set.to_subring S)

@[simp] theorem mem_subalgebra_of_subring {R : Type u_1} [ring R] {x : R} {S : subring R} : x ∈ subalgebra_of_subring S ↔ x ∈ S :=
  iff.rfl

@[simp] theorem mem_subalgebra_of_is_subring {R : Type u_1} [ring R] {x : R} {S : set R} [is_subring S] : x ∈ subalgebra_of_is_subring S ↔ x ∈ S :=
  iff.rfl


/-
Copyright (c) 2018 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Reid Barton, Bhavik Mehta
-/
import category_theory.over
import category_theory.limits.shapes.pullbacks
import category_theory.limits.shapes.wide_pullbacks
import category_theory.limits.shapes.finite_products

/-!
# Products in the over category

Shows that products in the over category can be derived from wide pullbacks in the base category.
The main result is `over_product_of_wide_pullback`, which says that if `C` has `J`-indexed wide
pullbacks, then `over B` has `J`-indexed products.
-/
universes v u -- morphism levels before object levels. See note [category_theory universes].

open category_theory category_theory.limits

variables {J : Type v}
variables {C : Type u} [category.{v} C]
variable {X : C}

namespace category_theory.over

namespace construct_products

/--
(Implementation)
Given a product diagram in `C/B`, construct the corresponding wide pullback diagram
in `C`.
-/
@[reducible]
def wide_pullback_diagram_of_diagram_over (B : C) {J : Type v} (F : discrete J ⥤ over B) :
  wide_pullback_shape J ⥤ C :=
wide_pullback_shape.wide_cospan B (λ j, (F.obj ⟨j⟩).left) (λ j, (F.obj ⟨j⟩).hom)

/-- (Impl) A preliminary definition to avoid timeouts. -/
@[simps]
def cones_equiv_inverse_obj (B : C) {J : Type v} (F : discrete J ⥤ over B) (c : cone F) :
  cone (wide_pullback_diagram_of_diagram_over B F) :=
{ X := c.X.left,
  π :=
  { app := λ X, option.cases_on X c.X.hom (λ (j : J), (c.π.app ⟨j⟩).left),
  -- `tidy` can do this using `case_bash`, but let's try to be a good `-T50000` citizen:
    naturality' := λ X Y f,
    begin
      dsimp, cases X; cases Y; cases f,
      { rw [category.id_comp, category.comp_id], },
      { rw [over.w, category.id_comp], },
      { rw [category.id_comp, category.comp_id], },
    end } }

/-- (Impl) A preliminary definition to avoid timeouts. -/
@[simps]
def cones_equiv_inverse (B : C) {J : Type v} (F : discrete J ⥤ over B) :
  cone F ⥤ cone (wide_pullback_diagram_of_diagram_over B F) :=
{ obj := cones_equiv_inverse_obj B F,
  map := λ c₁ c₂ f,
  { hom := f.hom.left,
    w' := λ j,
    begin
      cases j,
      { simp },
      { dsimp,
        rw ← f.w ⟨j⟩,
        refl }
    end } }

local attribute [tidy] tactic.discrete_cases

/-- (Impl) A preliminary definition to avoid timeouts. -/
@[simps]
def cones_equiv_functor (B : C) {J : Type v} (F : discrete J ⥤ over B) :
  cone (wide_pullback_diagram_of_diagram_over B F) ⥤ cone F :=
{ obj := λ c,
  { X := over.mk (c.π.app none),
    π :=
    { app := λ ⟨j⟩, over.hom_mk (c.π.app (some j))
                    (by apply c.w (wide_pullback_shape.hom.term j)) } },
  map := λ c₁ c₂ f,
  { hom := over.hom_mk f.hom } }

local attribute [tidy] tactic.case_bash

/-- (Impl) A preliminary definition to avoid timeouts. -/
@[simp]
def cones_equiv_unit_iso (B : C) (F : discrete J ⥤ over B) :
  𝟭 (cone (wide_pullback_diagram_of_diagram_over B F)) ≅
    cones_equiv_functor B F ⋙ cones_equiv_inverse B F :=
nat_iso.of_components (λ _, cones.ext {hom := 𝟙 _, inv := 𝟙 _} (by tidy)) (by tidy)

/-- (Impl) A preliminary definition to avoid timeouts. -/
@[simp]
def cones_equiv_counit_iso (B : C) (F : discrete J ⥤ over B) :
  cones_equiv_inverse B F ⋙ cones_equiv_functor B F ≅ 𝟭 (cone F) :=
nat_iso.of_components
  (λ _, cones.ext {hom := over.hom_mk (𝟙 _), inv := over.hom_mk (𝟙 _)} (by tidy)) (by tidy)

-- TODO: Can we add `. obviously` to the second arguments of `nat_iso.of_components` and
--       `cones.ext`?
/--
(Impl) Establish an equivalence between the category of cones for `F` and for the "grown" `F`.
-/
@[simps]
def cones_equiv (B : C) (F : discrete J ⥤ over B) :
  cone (wide_pullback_diagram_of_diagram_over B F) ≌ cone F :=
{ functor := cones_equiv_functor B F,
  inverse := cones_equiv_inverse B F,
  unit_iso := cones_equiv_unit_iso B F,
  counit_iso := cones_equiv_counit_iso B F, }

/-- Use the above equivalence to prove we have a limit. -/
lemma has_over_limit_discrete_of_wide_pullback_limit {B : C} (F : discrete J ⥤ over B)
  [has_limit (wide_pullback_diagram_of_diagram_over B F)] :
  has_limit F :=
has_limit.mk
{ cone := _,
  is_limit := is_limit.of_right_adjoint
    (cones_equiv B F).functor (limit.is_limit (wide_pullback_diagram_of_diagram_over B F)) }

/-- Given a wide pullback in `C`, construct a product in `C/B`. -/
lemma over_product_of_wide_pullback [has_limits_of_shape (wide_pullback_shape J) C] {B : C} :
  has_limits_of_shape (discrete J) (over B) :=
{ has_limit := λ F, has_over_limit_discrete_of_wide_pullback_limit F }

/-- Given a pullback in `C`, construct a binary product in `C/B`. -/
lemma over_binary_product_of_pullback [has_pullbacks C] {B : C} :
  has_binary_products (over B) :=
over_product_of_wide_pullback

/-- Given all wide pullbacks in `C`, construct products in `C/B`. -/
lemma over_products_of_wide_pullbacks [has_wide_pullbacks C] {B : C} :
  has_products (over B) :=
λ J, over_product_of_wide_pullback

/-- Given all finite wide pullbacks in `C`, construct finite products in `C/B`. -/
lemma over_finite_products_of_finite_wide_pullbacks [has_finite_wide_pullbacks C] {B : C} :
  has_finite_products (over B) :=
⟨λ J 𝒥, by exactI over_product_of_wide_pullback⟩

end construct_products

local attribute [tidy] tactic.discrete_cases

/--
Construct terminal object in the over category. This isn't an instance as it's not typically the
way we want to define terminal objects.
(For instance, this gives a terminal object which is different from the generic one given by
`over_product_of_wide_pullback` above.)
-/
lemma over_has_terminal (B : C) : has_terminal (over B) :=
{ has_limit := λ F, has_limit.mk
  { cone :=
    { X := over.mk (𝟙 _),
      π := { app := λ p, p.as.elim } },
    is_limit :=
      { lift := λ s, over.hom_mk _,
        fac' := λ _ j, j.as.elim,
        uniq' := λ s m _,
          begin
            ext,
            rw over.hom_mk_left,
            have := m.w,
            dsimp at this,
            rwa [category.comp_id, category.comp_id] at this
          end } } }

end category_theory.over


/-
Copyright (c) 2015 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Leonardo de Moura

Tuples are lists of a fixed size.
It is implemented as a subtype.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.data.list.default
import Mathlib.Lean3Lib.init.data.subtype.default
import Mathlib.Lean3Lib.init.meta.interactive
import Mathlib.Lean3Lib.init.data.fin.default

universes u u_1 v w

namespace Mathlib

def vector (α : Type u) (n : ℕ) := Subtype fun (l : List α) => list.length l = n

namespace vector

protected instance decidable_eq {α : Type u} {n : ℕ} [DecidableEq α] : DecidableEq (vector α n) :=
  eq.mpr sorry fun (a b : Subtype fun (l : List α) => list.length l = n) => subtype.decidable_eq a b

def nil {α : Type u} : vector α 0 := { val := [], property := sorry }

def cons {α : Type u} {n : ℕ} : α → vector α n → vector α (Nat.succ n) := sorry

def length {α : Type u} {n : ℕ} (v : vector α n) : ℕ := n

def head {α : Type u} {n : ℕ} : vector α (Nat.succ n) → α := sorry

theorem head_cons {α : Type u} {n : ℕ} (a : α) (v : vector α n) : head (cons a v) = a := sorry

def tail {α : Type u} {n : ℕ} : vector α n → vector α (n - 1) := sorry

theorem tail_cons {α : Type u} {n : ℕ} (a : α) (v : vector α n) : tail (cons a v) = v := sorry

@[simp] theorem cons_head_tail {α : Type u} {n : ℕ} (v : vector α (Nat.succ n)) :
    cons (head v) (tail v) = v :=
  sorry

def to_list {α : Type u} {n : ℕ} (v : vector α n) : List α := subtype.val v

def nth {α : Type u} {n : ℕ} (v : vector α n) : fin n → α := sorry

def append {α : Type u} {n : ℕ} {m : ℕ} : vector α n → vector α m → vector α (n + m) := sorry

def elim {α : Type u_1} {C : {n : ℕ} → vector α n → Sort u}
    (H : (l : List α) → C { val := l, property := elim._proof_1 l }) {n : ℕ} (v : vector α n) :
    C v :=
  sorry

/- map -/

def map {α : Type u} {β : Type v} {n : ℕ} (f : α → β) : vector α n → vector β n := sorry

@[simp] theorem map_nil {α : Type u} {β : Type v} (f : α → β) : map f nil = nil := rfl

theorem map_cons {α : Type u} {β : Type v} {n : ℕ} (f : α → β) (a : α) (v : vector α n) :
    map f (cons a v) = cons (f a) (map f v) :=
  sorry

def map₂ {α : Type u} {β : Type v} {φ : Type w} {n : ℕ} (f : α → β → φ) :
    vector α n → vector β n → vector φ n :=
  sorry

def repeat {α : Type u} (a : α) (n : ℕ) : vector α n :=
  { val := list.repeat a n, property := list.length_repeat a n }

def drop {α : Type u} {n : ℕ} (i : ℕ) : vector α n → vector α (n - i) := sorry

def take {α : Type u} {n : ℕ} (i : ℕ) : vector α n → vector α (min i n) := sorry

def remove_nth {α : Type u} {n : ℕ} (i : fin n) : vector α n → vector α (n - 1) := sorry

def of_fn {α : Type u} {n : ℕ} : (fin n → α) → vector α n := sorry

def map_accumr {α : Type u} {β : Type v} {n : ℕ} {σ : Type} (f : α → σ → σ × β) :
    vector α n → σ → σ × vector β n :=
  sorry

def map_accumr₂ {n : ℕ} {α : Type} {β : Type} {σ : Type} {φ : Type} (f : α → β → σ → σ × φ) :
    vector α n → vector β n → σ → σ × vector φ n :=
  sorry

protected theorem eq {α : Type u} {n : ℕ} (a1 : vector α n) (a2 : vector α n) :
    to_list a1 = to_list a2 → a1 = a2 :=
  sorry

protected theorem eq_nil {α : Type u} (v : vector α 0) : v = nil :=
  vector.eq v nil (list.eq_nil_of_length_eq_zero (subtype.property v))

@[simp] theorem to_list_mk {α : Type u} {n : ℕ} (v : List α) (P : list.length v = n) :
    to_list { val := v, property := P } = v :=
  rfl

@[simp] theorem to_list_nil {α : Type u} : to_list nil = [] := rfl

@[simp] theorem to_list_length {α : Type u} {n : ℕ} (v : vector α n) :
    list.length (to_list v) = n :=
  subtype.property v

@[simp] theorem to_list_cons {α : Type u} {n : ℕ} (a : α) (v : vector α n) :
    to_list (cons a v) = a :: to_list v :=
  subtype.cases_on v
    fun (v_val : List α) (v_property : list.length v_val = n) =>
      Eq.refl (to_list (cons a { val := v_val, property := v_property }))

@[simp] theorem to_list_append {α : Type u} {n : ℕ} {m : ℕ} (v : vector α n) (w : vector α m) :
    to_list (append v w) = to_list v ++ to_list w :=
  sorry

@[simp] theorem to_list_drop {α : Type u} {n : ℕ} {m : ℕ} (v : vector α m) :
    to_list (drop n v) = list.drop n (to_list v) :=
  subtype.cases_on v
    fun (v_val : List α) (v_property : list.length v_val = m) =>
      Eq.refl (to_list (drop n { val := v_val, property := v_property }))

@[simp] theorem to_list_take {α : Type u} {n : ℕ} {m : ℕ} (v : vector α m) :
    to_list (take n v) = list.take n (to_list v) :=
  subtype.cases_on v
    fun (v_val : List α) (v_property : list.length v_val = m) =>
      Eq.refl (to_list (take n { val := v_val, property := v_property }))

end Mathlib


import .lang

namespace ralg
universes v u

variables (L : lang.{v}) (S : Type u)

namespace free

inductive tp : Type (max v u)
| of : S → tp
| op {n} : L n → (fin n → tp) → tp

end free

def free : ralg L :=
{ carrier := free.tp L S,
  appo := λ _ t as, free.tp.op t as }

namespace free

def univ : S → free L S := tp.of

variables (L) {S}
def lift {B : ralg L} (f : S → B) : (free L S) →% B :=
{ to_fn := λ t, tp.rec_on t f
    (λ _ t _ bs, applyo t $ vector.of_fn bs),
  applyo_map := λ n t as,
  begin
    have : as = vector.of_fn as, by rw vector.of_fn_to_fn,
    conv_lhs {rw this},
    rw vector.map_of_fn,
    refl,
  end }

theorem univ_comp_lift {B : ralg L} (f : S → B) : (lift _ f) ∘ (univ L S) = f := rfl

theorem lift_unique {B : ralg L} (f : S → B) (g : (free L S) →% B) :
  g ∘ (univ _ _) = f → g = lift _ f := λ hyp,
begin
  ext,
  induction x with _ n t as h,
  { change (g ∘ (univ _ _)) x = _,
    rw hyp, refl },
  { have : as = vector.of_fn as,
    { change _ = vector.to_fn _,
      rw vector.to_fn_of_fn },
    dsimp only [] at h,
    rw this,
    change g.to_fn (applyo _ _) = (lift _ f).to_fn (applyo _ _),
    simp_rw ←ralgHom.applyo_map,
    apply congr_arg,
    simp only [vector.map_of_fn],
    rw vector.eq_iff_to_fn_eq_to_fn,
    funext,
    change vector.to_fn _ _ = vector.to_fn _ _,
    simp only [vector.to_fn_of_fn], apply h }
end

end free

end ralg


import data.finset.basic

import guidelines.protocol

structure proposal (ballot_t value_t : Type) := (b : ballot_t) (v : value_t)

structure paxos_defs (sys_state_t pid_t ballot_t value_t : Type) :=
  (curr : sys_state_t → pid_t → ballot_t)
  (stored : sys_state_t → pid_t → option (proposal ballot_t value_t))
  (proposed : sys_state_t → ballot_t → value_t → Prop)
  (voted : sys_state_t → pid_t → ballot_t → Prop)
  (quorum : finset pid_t → Prop)

namespace paxos_defs

variables {sys_state_t pid_t ballot_t value_t : Type}

def chosen_ballot
  (defs : paxos_defs sys_state_t pid_t ballot_t value_t) :
    sys_state_t → ballot_t → Prop :=
  (λ state ballot,
    ∃ q : finset pid_t, defs.quorum q ∧
      ∀ voter ∈ q, defs.voted state voter ballot)

def choosable [linear_order ballot_t]
  (defs : paxos_defs sys_state_t pid_t ballot_t value_t) :
    sys_state_t → ballot_t → Prop :=
  (λ state ballot,
    ∃ q : finset pid_t, defs.quorum q ∧
      ∀ voter ∈ q,
        defs.voted state voter ballot ∨ defs.curr state voter ≤ ballot)

def chosen
  (defs : paxos_defs sys_state_t pid_t ballot_t value_t) :
    sys_state_t → value_t → Prop :=
  (λ state value,
    ∃ ballot, defs.chosen_ballot state ballot ∧ defs.proposed state ballot value)

lemma chosen_imp_choosable {s : sys_state_t} {b : ballot_t} [linear_order ballot_t]
  (defs : paxos_defs sys_state_t pid_t ballot_t value_t) :
  defs.chosen_ballot s b → defs.choosable s b :=
begin
rintros ⟨q, q_quorum, q_voted⟩,
exact ⟨q, q_quorum,
  by {intros voter voter_in_q, left, exact q_voted voter voter_in_q }⟩
end

end paxos_defs

structure interval (ballot_t value_t : Type) :=
  (upper : ballot_t) (lower : option (proposal ballot_t value_t))

variables {sys_state_t pid_t ballot_t value_t : Type}

def proto_with_intervals_recorded
  (defs : paxos_defs sys_state_t pid_t ballot_t value_t)
  (proto : protocol sys_state_t) : protocol (sys_state_t × (pid_t → set (interval ballot_t value_t))) :=
{ init := (λ hist_state, proto.init hist_state.fst ∧
  (∀ p, hist_state.snd p =
        {{upper := defs.curr hist_state.fst p, lower := defs.stored hist_state.fst p}})),
  next := (λ fst_state snd_state, proto.next fst_state.fst snd_state.fst ∧
  (∀ p, snd_state.snd p = fst_state.snd p ∪
        {{upper := defs.curr snd_state.fst p, lower := defs.stored snd_state.fst p}})) }

lemma reachable_implies_reachable_in_proto_with_intervals_recorded
  (defs : paxos_defs sys_state_t pid_t ballot_t value_t)
  (proto : protocol sys_state_t) :
  ∀ s, proto.reachable s → ∃ lift_s, (proto_with_intervals_recorded defs proto).reachable lift_s ∧ lift_s.fst = s :=
begin
suffices : ∀ n s,
  proto.reachable_in n s →
  ∃ lift_s, (proto_with_intervals_recorded defs proto).reachable lift_s ∧ lift_s.fst = s,
by { rintros s ⟨n, hn⟩, exact this n s hn },
intro n,
induction n with k hk,
{ intros s hs,
  use ⟨s, (λ p, {{ upper := defs.curr s p, lower := defs.stored s p}})⟩,
  use ⟨0, hs, by {intro p, refl }⟩ },
rintros s ⟨u, u_reach_in_k, u_next_s⟩,
specialize hk u u_reach_in_k,
rcases hk with ⟨lift_u, ⟨j, hj⟩, lift_u_has_u⟩,
use ⟨s, (λ p, lift_u.snd p ∪ {{ upper := defs.curr s p, lower := defs.stored s p}})⟩,
split,
{ use [j.succ, lift_u, hj],
  split,
  { rw lift_u_has_u, exact u_next_s },
  intros p, refl },
refl
end

lemma reachable_in_proto_with_intervals_recorded_implies_first_reachable
  (defs : paxos_defs sys_state_t pid_t ballot_t value_t)
  (proto : protocol sys_state_t) :
  ∀ lift_s, (proto_with_intervals_recorded defs proto).reachable lift_s →
    proto.reachable lift_s.fst :=
begin
suffices : ∀ n lift_s,
  (proto_with_intervals_recorded defs proto).reachable_in n lift_s →
  proto.reachable lift_s.fst,
by { rintros lift_s ⟨n, hn⟩, exact this n lift_s hn },
intro n,
induction n with k hk,
{ intros s hs,
  use ⟨0, hs.left⟩ },
rintros lift_s ⟨lift_u, lift_u_reach_in_k, lift_u_next_lift_s⟩,
specialize hk lift_u lift_u_reach_in_k,
rcases hk with ⟨j, hj⟩,
exact ⟨j.succ, lift_u.fst, hj, lift_u_next_lift_s.left⟩
end