import category_theory.preadditive
import category_theory.abelian.exact
import algebra.homology.exact
import category_theory.limits.preserves.shapes.terminal
import category_theory.limits.shapes.zero_morphisms

namespace category_theory
namespace limits

open category_theory.limits

variables {C : Type*} [category C] [has_zero_morphisms C]

open_locale zero_object

lemma is_zero_iff_id_eq_zero {X : C} : is_zero X ↔ 𝟙 X = 0 :=
begin
  split,
  { exact λ h, h.eq_of_src _ _, },
  { intro e, split; intro Y; use 0; intro f,
    { rw [← cancel_epi (𝟙 _), e, comp_zero, zero_comp], apply_instance },
    { rw [← cancel_mono (𝟙 _), e, comp_zero, zero_comp], apply_instance }, }
end

lemma is_zero_of_mono {X Y : C} (f : X ⟶ Y) [mono f] (h : is_zero Y) : is_zero X :=
by rw [is_zero_iff_id_eq_zero, ← cancel_mono f, zero_comp, h.eq_of_tgt (𝟙 _ ≫ f)]

lemma is_zero_of_epi {X Y : C} (f : X ⟶ Y) [epi f] (h : is_zero X) : is_zero Y :=
by rw [is_zero_iff_id_eq_zero, ← cancel_epi f, comp_zero, h.eq_of_src (f ≫ 𝟙 Y)]

lemma is_zero_of_top_le_bot [has_zero_object C] (X : C)
  (h : (⊤ : subobject X) ≤ ⊥) : is_zero X :=
{ unique_to := λ Y,
  begin
    use 0, intro f,
    rw [← cancel_epi ((⊤ : subobject X).arrow), ← subobject.of_le_arrow h],
    simp only [subobject.bot_arrow, comp_zero, zero_comp],
  end,
  unique_from := λ Y,
  begin
    use 0, intro f,
    rw ← subobject.bot_factors_iff_zero,
    exact subobject.factors_of_le f h (subobject.top_factors f),
  end }

-- inline this
lemma is_zero_of_iso_of_zero {C : Type*} [category C] [has_zero_morphisms C]
  {X : C} (hX : is_zero X) {Y : C} (h : X ≅ Y) : is_zero Y :=
hX.of_iso h.symm

lemma is_zero_of_exact_zero_zero {C : Type*} [category C] [abelian C]
  {X Y Z : C} (h : exact (0 : X ⟶ Y) (0 : Y ⟶ Z)) : is_zero Y :=
is_zero_of_top_le_bot _
begin
  rw abelian.exact_iff_image_eq_kernel at h,
  rw [← @kernel_subobject_zero _ _ _ Y Z, ← @image_subobject_zero _ _ _ _ X Y, h],
end

lemma exact_of_is_zero {C : Type*} [category C] [abelian C]
  {X Y Z : C} (hY : is_zero Y) (f : X ⟶ Y) (g : Y ⟶ Z) : exact f g :=
by simp only [abelian.exact_iff, is_zero.eq_zero_of_tgt hY f,
  is_zero.eq_zero_of_tgt hY (kernel.ι g), zero_comp, eq_self_iff_true, and_self]

lemma is_zero_iff_exact_zero_zero {C : Type*} [category C] [abelian C]
  {X Y Z : C} : is_zero Y ↔ exact (0 : X ⟶ Y) (0 : Y ⟶ Z) :=
⟨λ h, exact_of_is_zero h 0 0, is_zero_of_exact_zero_zero⟩

lemma is_zero_of_exact_zero_zero' {C : Type*} [category C] [abelian C]
  {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) (h : exact f g) (hf : f = 0) (hg : g = 0) : is_zero Y :=
by { rw [hf, hg] at h, exact is_zero_of_exact_zero_zero h }

lemma is_zero_of_exact_is_zero_is_zero {C : Type*} [category C] [abelian C] {X Y Z : C}
  (f : X ⟶ Y) (g : Y ⟶ Z) (h : exact f g) (hX : is_zero X) (hZ : is_zero Z) : is_zero Y :=
is_zero_of_exact_zero_zero' f g h (hX.eq_of_src f _) (hZ.eq_of_tgt g _)

lemma is_zero_cokernel_of_epi {C : Type*} [category C] [abelian C] {X Y : C}
  (f : X ⟶ Y) [epi f] : is_zero (cokernel f) :=
begin
  have h1 : cokernel.π f = 0, by rwa ← abelian.epi_iff_cokernel_π_eq_zero,
  have h2 : exact (cokernel.π f) 0 := category_theory.exact_epi_zero (cokernel.π f),
  exact is_zero_of_exact_zero_zero' (cokernel.π f) 0 h2 h1 rfl,
end

lemma epi_iff_is_zero_cokernel {C : Type*} [category C] [abelian C] {X Y : C}
  (f : X ⟶ Y) : epi f ↔ is_zero (cokernel f) :=
begin
  split,
  { introsI, apply is_zero_cokernel_of_epi },
  { intros h,
    rw abelian.epi_iff_cokernel_π_eq_zero,
    apply h.eq_of_tgt }
end

lemma is_zero_kernel_of_mono {C : Type*} [category C] [abelian C] {X Y : C}
  (f : X ⟶ Y) [mono f] : is_zero (kernel f) :=
begin
  have h1 : kernel.ι f = 0, by rwa ← abelian.mono_iff_kernel_ι_eq_zero,
  have h2 : exact 0 (kernel.ι f) := category_theory.exact_zero_mono (kernel.ι f),
  exact is_zero_of_exact_zero_zero' 0 (kernel.ι f) h2 rfl h1
end

lemma mono_iff_is_zero_kernel {C : Type*} [category C] [abelian C] {X Y : C}
  (f : X ⟶ Y) : mono f ↔ is_zero (kernel f) :=
begin
  split,
  { introsI, apply is_zero_kernel_of_mono },
  { intros h,
    rw abelian.mono_iff_kernel_ι_eq_zero,
    apply h.eq_of_src }
end

noncomputable def image_iso_of_eq [category C] [abelian C] {A B : C} {f f' : A ⟶ B} (h : f = f') : image f ≅ image f' :=
eq_to_iso (by rw h)

noncomputable def image.is_iso_comp {𝓐 : Type*} [category 𝓐] [abelian 𝓐] {A B C : 𝓐} {f : A ⟶ B} [is_iso f] (g : B ⟶ C) : image (f ≫ g) ≅ image g :=
{ hom := image.lift (({ I := _,
  m := image.ι _,
  m_mono := infer_instance,
  e := f ≫ factor_thru_image g,
  fac' := by simp only [category.assoc, image.fac]} : mono_factorisation _)),
  inv := image.lift (({ I := _,
  m := image.ι _,
  m_mono := infer_instance,
  e := (inv f) ≫ factor_thru_image (f ≫ g),
  fac' := by simp only [category.assoc, image.fac, is_iso.inv_hom_id_assoc]} : mono_factorisation _)) }

lemma is_iso_of_is_zero_of_is_zero {𝓐 : Type*} [category 𝓐] [abelian 𝓐] {a b : 𝓐} (ha : is_zero a) (hb : is_zero b)
  (f : a ⟶ b) : is_iso f :=
begin
  rw is_zero.eq_zero_of_src ha f,
  apply (is_iso_zero_equiv a b).symm.to_fun,
  exact ⟨is_zero.eq_of_src ha (𝟙 a) 0, is_zero.eq_of_src hb (𝟙 b) 0⟩,
end

lemma obj_is_zero_of_iso {𝓐 : Type*} [category 𝓐] [abelian 𝓐] {𝓑 : Type*} [category 𝓑] [abelian 𝓑] {F G : 𝓐 ⥤ 𝓑}
  (h : F ≅ G) {a : 𝓐} (ha : is_zero (F.obj a)) : is_zero (G.obj a) :=
is_zero_of_iso_of_zero ha (h.app a)

lemma map_is_iso_of_iso_of_map_is_iso {𝓐 : Type*} [category 𝓐] [abelian 𝓐] {𝓑 : Type*} [category 𝓑] [abelian 𝓑] {F G : 𝓐 ⥤ 𝓑}
  (h : F ≅ G) {a₁ a₂ : 𝓐} (f : a₁ ⟶ a₂) (ha : is_iso (F.map f)) : is_iso (G.map f) :=
begin
  rw ← nat_iso.naturality_1 h,
  exact is_iso.comp_is_iso,
end

@[simp] lemma epi_comp_iso_iff_epi {V : Type*} [category V] {A B C : V} (e : A ≅ B) (f : B ⟶ C) :
  epi (e.hom ≫ f) ↔ epi f :=
begin
  split,
  { rintro ⟨h⟩,
    constructor,
    intros Z s t h2,
    apply h,
    simp [h2], },
  { rintro ⟨h⟩,
    constructor,
    intros Z s t h2,
    apply h,
    simpa using h2,
  },
end

@[simp] lemma epi_iso_comp_iff_epi {V : Type*} [category V] {A B C : V} (f : A ⟶ B) (e : B ≅ C) :
  epi (f ≫ e.hom) ↔ epi f :=
begin
  split,
  { introI h,
    constructor,
    intros Z s t h2,
    suffices : e.inv ≫ s = e.inv ≫ t,
      simpa,
    rw ← cancel_epi (f ≫ e.hom),
    simpa using h2, },
  { introI h,
    constructor,
    intros Z s t h2,
    simp only [category.assoc] at h2,
    rw cancel_epi at h2,
    rwa cancel_epi at h2, },
end

lemma is_iso_iff_is_iso_comp_left {V : Type*} [category V] {A B C : V} (f : A ⟶ B) {e : B ⟶ C}
  [is_iso f] : is_iso (f ≫ e) ↔ is_iso e :=
begin
  split,
  { introI h, exact is_iso.of_is_iso_comp_left f e },
  { introI h, exact is_iso.comp_is_iso },
end

lemma is_iso_iff_is_iso_comp_right {V : Type*} [category V] {A B C : V} {f : A ⟶ B} (g : B ⟶ C)
  [is_iso g] : is_iso (f ≫ g) ↔ is_iso f :=
begin
  split,
  { introI, exact is_iso.of_is_iso_comp_right f g},
  { introI h, exact is_iso_of_op (f ≫ g), },
end

@[simp] lemma epi_comp_is_iso_iff_epi {V : Type*} [category V] {A B C : V} (e : A ⟶ B) (f : B ⟶ C)
  [is_iso e] : epi (e ≫ f) ↔ epi f :=
epi_comp_iso_iff_epi (as_iso e) f

@[simp] lemma epi_is_iso_comp_iff_epi {V : Type*} [category V] {A B C : V} (f : A ⟶ B) (e : B ⟶ C)
  [is_iso e] : epi (f ≫ e) ↔ epi f :=
epi_iso_comp_iff_epi f (as_iso e)

lemma zero_of_epi_comp_zero {V : Type*} [category V] [abelian V]
  {A B C : V} {f : A ⟶ B} {g : B ⟶ C} (w : f ≫ g = 0) [epi f] : g = 0 :=
(preadditive.epi_iff_cancel_zero f).mp infer_instance C g w

@[simp] lemma comp_mono_zero_iff {V : Type*} [category V] [abelian V]
  {A B C : V} {f : A ⟶ B} {g : B ⟶ C} [mono g] : f ≫ g = 0 ↔ f = 0 :=
⟨(preadditive.mono_iff_cancel_zero g).1 infer_instance A f, λ f, f.symm ▸ zero_comp⟩

lemma epi_of_epi_of_comp_epi_of_mono {V : Type*} [category V] [abelian V]
  {A B C : V} (f : A ⟶ B) (g : B ⟶ C) [epi (f ≫ g)] [mono g] : epi f :=
begin
  haveI foo : is_iso g,
  { rw is_iso_iff_mono_and_epi,
    refine ⟨infer_instance, _⟩,
    apply epi_of_epi f,
  },
  simp * at *,
end

lemma is_zero_initial {C : Type*} [category C] [abelian C] : is_zero (⊥_ C) :=
is_zero_of_iso_of_zero (is_zero_zero _) $
{ hom := 0,
  inv := 0 }

lemma is_zero_terminal {C : Type*} [category C] [abelian C] : is_zero (⊤_ C) :=
is_zero_of_iso_of_zero (is_zero_zero _) $
{ hom := 0,
  inv := 0 }

universes v u₁ u₂

class preserves_zero_objects {C D : Type*} [category C] [has_zero_morphisms C]
  [category D] [has_zero_morphisms D] (F : C ⥤ D) : Prop :=
(preserves : ∀ (X : C), is_zero X → is_zero (F.obj X))

instance preserves_zero_of_preserves_initial {C : Type u₁} {D : Type u₂}
  [category.{v} C] [abelian C] [category.{v} D] [abelian D] (F : C ⥤ D)
  [preserves_colimit (functor.empty C) F] :
  preserves_zero_objects F := preserves_zero_objects.mk $ λ X hX,
begin
  have e : X ≅ ⊥_ _ := hX.iso is_zero_initial,
  replace e : F.obj X ≅ F.obj ⊥_ _ := F.map_iso e,
  apply is_zero_of_iso_of_zero _ e.symm,
  have : F.obj ⊥_ _ ≅ ⊥_ _,
  { apply_with limits.preserves_initial.iso { instances := ff }, assumption },
  apply is_zero_of_iso_of_zero _ this.symm,
  exact is_zero_initial,
end

-- sanity check
example {C : Type u₁} {D : Type u₂}
  [category.{v} C] [abelian C] [category.{v} D] [abelian D] (F : C ⥤ D)
  [preserves_colimits F] : preserves_zero_objects F := infer_instance

instance preserves_zero_of_preserves_terminal {C : Type u₁} {D : Type u₂}
  [category.{v} C] [abelian C] [category.{v} D] [abelian D] (F : C ⥤ D)
  [preserves_limit (functor.empty C) F] :
  preserves_zero_objects F := preserves_zero_objects.mk $ λ X hX,
begin
  have e : X ≅ ⊤_ _ := hX.iso is_zero_terminal,
  replace e : F.obj X ≅ F.obj ⊤_ _ := F.map_iso e,
  apply is_zero_of_iso_of_zero _ e.symm,
  have : F.obj ⊤_ _ ≅ ⊤_ _,
  { apply_with limits.preserves_terminal.iso { instances := ff }, assumption },
  apply is_zero_of_iso_of_zero _ this.symm,
  exact is_zero_terminal,
end

-- sanity check
example {C : Type u₁} {D : Type u₂}
  [category.{v} C] [abelian C] [category.{v} D] [abelian D] (F : C ⥤ D)
  [preserves_limits F] : preserves_zero_objects F := infer_instance

lemma is_zero_of_preserves {C D : Type*} [category C] [has_zero_morphisms C]
  [category D] [has_zero_morphisms D] {X : C} (F : C ⥤ D)
  [preserves_zero_objects F] (e : is_zero X) : is_zero (F.obj X) :=
preserves_zero_objects.preserves _ e

lemma is_zero_biprod {C : Type u₁} [category.{v} C] [abelian C] (X Y : C)
  (hX : is_zero X) (hY : is_zero Y) : is_zero (biprod X Y) :=
begin
  constructor,
  { intro W, use 0, intro f, ext, simp, apply hX.eq_of_src, simp, apply hY.eq_of_src },
  { intro W, use 0, intro f, ext, simp, apply hX.eq_of_tgt, simp, apply hY.eq_of_tgt }
end

end limits

end category_theory


import data.real.irrational
import topology.basic
import algebra.order.floor

--OUTPUT 1
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=
begin
  have h1 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff, hα_irrat, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff
end --Needs more than 2000 tokens!

--OUTPUT 2
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=
begin
  have h1 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from
  begin
    assume (i j : ℤ) (h1 : i ≠ j),
    assume h2 : int.fract (α * ↑i) = int.fract (α * ↑j),
    have h3 : α * ↑i - int.floor (α * ↑i) = int.fract (α * ↑i), from by auto [int.fract_eq_iff_of_nonneg],
    have h4 : α * ↑j - int.floor (α * ↑j) = int.fract (α * ↑j), from by auto [int.fract_eq_iff_of_nonneg],
    have h5 : α = (int.floor (α * ↑i) - int.floor (α * ↑j))/(i - j), from by auto [h2, h3, h4],
    have h6 : (i - j) ≠ 0, from by auto [h1],
    have h7 : (int.floor (α * ↑i) - int.floor (α * ↑j))/(i - j) ∈ ℚ, from by auto [h5, h6],
    show false, from by auto [hα_irrat, h7],
  end,

  have h2 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h1],

  have h3 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h2],

  have h4 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h3],

  have h5 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h4],

  have h6 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h5],

  have h7 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h6],

  have h8 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h7],

  have h9 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h8],

  have h10 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h9],

  have h11 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h10],

  have h12 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h11],

  have h13 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h12],

  have h14 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h13],

  have h15 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h14],

  have h16 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h15],

  have h17 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h16],

  have h18 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h17],

  have h19 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h18],

  have h20 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h19],

  have h21 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h20],

  have h22 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h21],

  have h23 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h22],

  have h24 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h23],

  have h25 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h24],

  have h26 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h25],

  have h27 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h26],

  have h28 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h27],

  have h29 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h28],

  have h30 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h29],

  have h31 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h30],

  have h32 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h31],

  have h33 : ∀ (i j : ℤ), (i ≠ j) →
end --Needs more than 2000 tokens!

--OUTPUT 3
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=
begin
  have h1 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff_eq_of_mul_int_eq_int_add_one_mul_fract, hα_irrat],

  have h2 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff_eq_of_mul_int_eq_int_add_one_mul_fract, hα_irrat],

  have h3 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff_eq_of_mul_int_eq_int_add_one_mul_fract, hα_irrat],

  have h4 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff_eq_of_mul_int_eq_int_add_one_mul_fract, hα_irrat],

  have h5 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff_eq_of_mul_int_eq_int_add_one_mul_fract, hα_irrat],

  have h6 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff_eq_of_mul_int_eq_int_add_one_mul_fract, hα_irrat],

  have h7 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff_eq_of_mul_int_eq_int_add_one_mul_fract, hα_irrat],

  have h8 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff_eq_of_mul_int_eq_int_add_one_mul_fract, hα_irrat],

  have h9 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff_eq_of_mul_int_eq_int_add_one_mul_fract, hα_irrat],

  have h10 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff_eq_of_mul_int_eq_int_add_one_mul_fract, hα_irrat],

  have h11 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff_eq_of_mul_int_eq_int_add_one_mul_fract, hα_irrat],

  have h12 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff_eq_of_mul_int_eq_int_add_one_mul_fract, hα_irrat],

  have h13 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff_eq_of_mul_int_eq_int_add_one_mul_fract, hα_irrat],

  have h14 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff_eq_of_mul_int_eq_int_add_one_mul_fract, hα_irrat],

  have h15 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff_eq_of_mul_int_eq_int_add_one_mul_fract, hα_irrat],

  have h16 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff_eq_of_mul_int_eq_int_add_one_mul_fract, hα_irrat],

  have h17 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff_eq_of_mul_int_eq_int_add_one_mul_fract, hα_irrat],

  have h18 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff_eq_of_mul_int_eq_int_add_one_mul_fract, hα_irrat],

  have h19 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff_eq_of_mul_int_eq_int_add_one_mul_fract, hα_irrat],

  have h20 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff_eq_of_mul_int_eq_int_add_one_mul_fract, hα_irrat],

  have h21 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff_eq_of_mul_int_eq_int_add_one_mul_fract, hα_irrat],

  have h22 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff_eq_of_mul_int_eq_int_add_one_mul_fract, hα_irrat],

  have h23 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff_eq_of
end --Needs more than 2000 tokens!

/- FEW SHOT PROMPTS TO CODEX(START)
/--`theorem`
Power Set is Closed under Intersection
Let $S$ be a set.

Let $\powerset S$ be the power set of $S$.

Then:
:$\forall A, B \in \powerset S: A \cap B \in \powerset S$
`proof`
Let $A, B \in \powerset S$.

Then by the definition of power set, $A \subseteq S$ and $B \subseteq S$.

From Intersection is Subset we have that $A \cap B \subseteq A$.

It follows from Subset Relation is Transitive that $A \cap B \subseteq S$.

Thus $A \cap B \in \powerset S$ and closure is proved.
{{qed}}
-/
theorem power_set_intersection_closed {α : Type*} (S : set α) : ∀ A B ∈ 𝒫 S, (A ∩ B) ∈ 𝒫 S :=
begin
  assume (A : set α) (hA : A ∈ 𝒫 S) (B : set α) (hB : B ∈ 𝒫 S),
  have h1 : (A ⊆ S) ∧ (B ⊆ S), from by auto [set.subset_of_mem_powerset, set.subset_of_mem_powerset],
  have h2 : (A ∩ B) ⊆ A, from by auto [set.inter_subset_left],
  have h3 : (A ∩ B) ⊆ S, from by auto [set.subset.trans],
  show (A ∩ B) ∈  𝒫 S, from by auto [set.mem_powerset],
end

/--`theorem`
Square of Sum
 :$\forall x, y \in \R: \paren {x + y}^2 = x^2 + 2 x y + y^2$
`proof`
Follows from the distribution of multiplication over addition:

{{begin-eqn}}
{{eqn | l = \left({x + y}\right)^2
      | r = \left({x + y}\right) \cdot \left({x + y}\right)
}}
{{eqn | r = x \cdot \left({x + y}\right) + y \cdot \left({x + y}\right)
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x \cdot x + x \cdot y + y \cdot x + y \cdot y
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x^2 + 2xy + y^2
      | c =
}}
{{end-eqn}}
{{qed}}
-/
theorem square_of_sum (x y : ℝ) : (x + y)^2 = (x^2 + 2*x*y + y^2) :=
begin
  calc (x + y)^2 = (x+y)*(x+y) : by auto [sq]
  ... = x*(x+y) + y*(x+y) : by auto [add_mul]
  ... = x*x + x*y + y*x + y*y : by auto [mul_comm, add_mul] using [ring]
  ... = x^2 + 2*x*y + y^2 : by auto [sq, mul_comm] using [ring]
end

/--`theorem`
Identity of Group is Unique
Let $\struct {G, \circ}$ be a group. Then there is a unique identity element $e \in G$.
`proof`
From Group has Latin Square Property, there exists a unique $x \in G$ such that:
:$a x = b$

and there exists a unique $y \in G$ such that:
:$y a = b$

Setting $b = a$, this becomes:

There exists a unique $x \in G$ such that:
:$a x = a$

and there exists a unique $y \in G$ such that:
:$y a = a$

These $x$ and $y$ are both $e$, by definition of identity element.
{{qed}}
-/
theorem group_identity_unique {G : Type*} [group G] : ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a :=
begin
  have h1 : ∀ a b : G, ∃! x : G, a * x = b, from by auto using [use (a⁻¹ * b)],
  have h2 : ∀ a b : G, ∃! y : G, y * a = b, from by auto using [use b * a⁻¹],

  have h3 : ∀ a : G, ∃! x : G, a * x = a, from by auto [h1],
  have h4 : ∀ a : G, ∃! y : G, y * a = a, from by auto [h2],

  have h5 : ∀ a : G, classical.some (h3 a).exists = (1 : G), from by auto [exists_unique.unique, h3, classical.some_spec, exists_unique.exists, mul_one],
  have h6 : ∀ a : G, classical.some (h4 a).exists = (1 : G), from by auto [exists_unique.unique, h4, classical.some_spec, exists_unique.exists, one_mul],

  show ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a, from by auto [h3, h4, exists_unique.unique, classical.some_spec, exists_unique.exists] using [use (1 : G)],
end

/--`theorem`
Squeeze Theorem for Real Numbers
Let $\sequence {x_n}$, $\sequence {y_n}$ and $\sequence {z_n}$ be sequences in $\R$.

Let $\sequence {y_n}$ and $\sequence {z_n}$ both be convergent to the following limit:
:$\ds \lim_{n \mathop \to \infty} y_n = l, \lim_{n \mathop \to \infty} z_n = l$

Suppose that:
:$\forall n \in \N: y_n \le x_n \le z_n$

Then:
:$x_n \to l$ as $n \to \infty$
that is:
:$\ds \lim_{n \mathop \to \infty} x_n = l$

`proof`
From Negative of Absolute Value:
:$\size {x - l} < \epsilon \iff l - \epsilon < x < l + \epsilon$

Let $\epsilon > 0$.

We need to prove that:
:$\exists N: \forall n > N: \size {x_n - l} < \epsilon$

As $\ds \lim_{n \mathop \to \infty} y_n = l$ we know that:
:$\exists N_1: \forall n > N_1: \size {y_n - l} < \epsilon$

As $\ds \lim_{n \mathop \to \infty} z_n = l$ we know that:
:$\exists N_2: \forall n > N_2: \size {z_n - l} < \epsilon$

Let $N = \max \set {N_1, N_2}$.

Then if $n > N$, it follows that $n > N_1$ and $n > N_2$.

So:
:$\forall n > N: l - \epsilon < y_n < l + \epsilon$
:$\forall n > N: l - \epsilon < z_n < l + \epsilon$

But:
:$\forall n \in \N: y_n \le x_n \le z_n$

So:
:$\forall n > N: l - \epsilon < y_n \le x_n \le z_n < l + \epsilon$

and so:
:$\forall n > N: l - \epsilon < x_n < l + \epsilon$

So:
:$\forall n > N: \size {x_n - l} < \epsilon$

Hence the result.
{{qed}}

-/
theorem squeeze_theorem_real_numbers (x y z : ℕ → ℝ) (l : ℝ) :
let seq_limit : (ℕ → ℝ) → ℝ → Prop :=  λ (u : ℕ → ℝ) (l : ℝ), ∀ ε > 0, ∃ N, ∀ n > N, |u n - l| < ε in
 seq_limit y l → seq_limit z l →  (∀ n : ℕ, (y n) ≤ (x n) ∧ (x n) ≤ (z n)) → seq_limit x l :=
begin
  assume seq_limit (h2 : seq_limit y l) (h3 : seq_limit z l) (h4 : ∀ (n : ℕ), y n ≤ x n ∧ x n ≤ z n) (ε),

  have h5 : ∀ x, |x - l| < ε ↔ (((l - ε) < x) ∧ (x < (l + ε))),
  from by auto [abs_sub_lt_iff] using [linarith],

  assume (h7 : ε > 0),

  cases h2 ε h7 with N1 h8,
  cases h3 ε h7 with N2 h9,
  let N := max N1 N2,
  use N,

  have h10 : ∀ n > N, n > N1 ∧ n > N2 := by auto [lt_of_le_of_lt, le_max_left, le_max_right],

  have h11 : ∀ n > N, (((l - ε) < (y n)) ∧ ((y n) ≤ (x n))) ∧ (((x n) ≤ (z n)) ∧ ((z n) < l+ε)),
  from by auto [h8, h10, h5, h9],

  have h15 : ∀ n > N, ((l - ε) < (x n)) ∧ ((x n) < (l+ε)),
  from by auto [h11] using [linarith],

  show  ∀ (n : ℕ), n > N → |x n - l| < ε,
  from by auto [h5, h15],

end

/--`theorem`
Density of irrational orbit
The fractional parts of the integer multiples of an irrational number form a dense subset of the unit interval
`proof`
Let $\alpha$ be an irrational number. Then for distinct $i, j \in \mathbb{Z}$, we must have $\{i \alpha\} \neq\{j \alpha\}$. If this were not true, then
$$
i \alpha-\lfloor i \alpha\rfloor=\{i \alpha\}=\{j \alpha\}=j \alpha-\lfloor j \alpha\rfloor,
$$
which yields the false statement $\alpha=\frac{\lfloor i \alpha\rfloor-\lfloor j \alpha\rfloor}{i-j} \in \mathbb{Q}$. Hence,
$$
S:=\{\{i \alpha\} \mid i \in \mathbb{Z}\}
$$
is an infinite subset of $\left[0,1\right]$.

By the Bolzano-Weierstrass theorem, $S$ has a limit point in $[0, 1]$. One can thus find pairs of elements of $S$ that are arbitrarily close. Since (the absolute value of) the difference of any two elements of $S$ is also an element of $S$, it follows that $0$ is a limit point of $S$.

To show that $S$ is dense in $[0, 1]$, consider $y \in[0,1]$, and $\epsilon>0$. Then by selecting $x \in S$ such that $\{x\}<\epsilon$ (which exists as $0$ is a limit point), and $N$ such that $N \cdot\{x\} \leq y<(N+1) \cdot\{x\}$, we get: $|y-\{N x\}|<\epsilon$.

QED
-/
theorem  irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=
FEW SHOT PROMPTS TO CODEX(END)-/


inductive nested : Type
| nest : list nested → nested

namespace nested

@[elab_as_eliminator] protected def cases_on' :
  Π {C : nested → Sort*} (x : nested),
    (Π (a : list nested), C (nest a)) → C x
| C (nest L) ih := ih L

@[simp] lemma cases_on'_def {C : nested → Sort*}
  (L : list nested) (ih : Π (a : list nested), C (nest a)) :
  (nested.cases_on' (nest L) ih : C (nest L)) = ih L :=
nested.cases_on'.equations._eqn_1 C L ih

def mem : nested → nested → Prop
| x (nest L) := x ∈ L

instance : has_mem nested nested := ⟨mem⟩

def to_list : nested → list nested
| (nest L) := L

@[simp] lemma to_list_def (L : list nested) :
  to_list (nest L) = L :=
nested.to_list.equations._eqn_1 L

@[simp] lemma mem_def (x : nested) (L : list nested) :
  x ∈ (nest L) ↔ x ∈ L :=
show mem _ _ ↔ _, by rw nested.mem.equations._eqn_1

theorem mem_sizeof (x y : nested) (H : x ∈ y) :
  sizeof x < sizeof y :=
begin
  cases y with L,
  change sizeof x < nested.sizeof (nest L),
  rw nested.nest.sizeof_spec L,
  rw mem_def at H,
  induction L with hd tl ih,
  { exfalso, simp at H, assumption },
  change sizeof x < 1 + (1 + sizeof hd + sizeof tl),
  cases H with H H,
  { subst H, rw add_comm,
    apply nat.lt_succ_of_le,
    rw [add_comm 1, add_assoc],
    apply nat.le_add_right },
  specialize ih H,
  apply lt_trans ih,
  apply nat.add_lt_add_left,
  rw [add_comm, add_comm 1],
  apply nat.lt_succ_of_le,
  apply nat.le_add_right
end

theorem mem_wf : well_founded (@has_mem.mem nested _ _) :=
@subrelation.wf _ (inv_image nat.lt sizeof) has_mem.mem mem_sizeof $
inv_image.wf _ nat.lt_wf

@[elab_as_eliminator] protected def rec_on
  {C : nested → Sort*} (x : nested)
  (ih : ∀ L : list nested, (∀ z ∈ L, C z) → C (nest L)) : C x :=
well_founded.fix mem_wf
  (λ y, nested.cases_on' y $ λ L ih', ih L $ λ z h, ih' z $ (mem_def z L).2 h) _

@[simp] lemma rec_on_def
  {C : nested → Sort*} (L : list nested)
  (ih : ∀ L : list nested, (∀ z ∈ L, C z) → C (nest L)) :
  (nested.rec_on (nest L) ih : C (nest L))
  = ih _ (λ z HL, nested.rec_on z ih) :=
by unfold nested.rec_on; rw well_founded.fix_eq; simp

instance : decidable_eq nested :=
λ x, nested.rec_on x $ λ L1,
list.rec_on L1 (λ _ y, nested.cases_on' y $ λ L2,
    list.cases_on L2 (is_true rfl) (λ hd tl, is_false $ λ H, by injections)) $ λ hd1 tl1 ih1 ih2 y,
nested.rec_on y $ λ L2,
list.rec_on L2 (λ _, is_false $ λ H, by injections) $ λ hd2 tl2 ih3 ih4,
@decidable_of_decidable_of_iff (hd1 = hd2 ∧ nest tl1 = nest tl2) _
  (@@and.decidable (ih2 _ (or.inl rfl) _) (ih1 (λ z H b, ih2 _ (or.inr H) _) _)) $
⟨λ H, congr_arg nest (by simp [H.1, nest.inj H.2] : hd1 :: tl1 = hd2 :: tl2),
λ H, by split; injections; simp*⟩

instance mem.decidable_rel :
  decidable_rel (@has_mem.mem nested _ _)
| x (nest L) := decidable_of_decidable_of_iff (list.decidable_mem x L) (mem_def x L).symm

end nested


import .temporal

universes u

namespace temporal
namespace classical

lemma not_always_not_implies_eventually {T : Type u} (P : tProp T)
  : ⊩ tNot (□ (tNot P)) => ◇ P
:= begin
intros tr notalways,
apply classical.by_contradiction,
intros contra, apply notalways,
intros n contra', apply contra,
constructor, assumption
end

end classical
end temporal


/-
Copyright (c) 2018 Michael Jendrusch. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Michael Jendrusch, Scott Morrison
-/
import category_theory.monoidal.of_chosen_finite_products
import category_theory.limits.shapes.types
import logic.equiv.fin

/-!
# The category of types is a symmetric monoidal category
-/

open category_theory
open category_theory.limits
open tactic

universes v u

namespace category_theory

instance types_monoidal : monoidal_category.{u} (Type u) :=
monoidal_of_chosen_finite_products (types.terminal_limit_cone) (types.binary_product_limit_cone)

instance types_symmetric : symmetric_category.{u} (Type u) :=
symmetric_of_chosen_finite_products (types.terminal_limit_cone) (types.binary_product_limit_cone)

@[simp] lemma tensor_apply {W X Y Z : Type u} (f : W ⟶ X) (g : Y ⟶ Z) (p : W ⊗ Y) :
  (f ⊗ g) p = (f p.1, g p.2) := rfl

@[simp] lemma left_unitor_hom_apply {X : Type u} {x : X} {p : punit} :
  ((λ_ X).hom : (𝟙_ (Type u)) ⊗ X → X) (p, x) = x := rfl
@[simp] lemma left_unitor_inv_apply {X : Type u} {x : X} :
  ((λ_ X).inv : X ⟶ (𝟙_ (Type u)) ⊗ X) x = (punit.star, x) := rfl

@[simp] lemma right_unitor_hom_apply {X : Type u} {x : X} {p : punit} :
  ((ρ_ X).hom : X ⊗ (𝟙_ (Type u)) → X) (x, p) = x := rfl
@[simp] lemma right_unitor_inv_apply {X : Type u} {x : X} :
  ((ρ_ X).inv : X ⟶ X ⊗ (𝟙_ (Type u))) x = (x, punit.star) := rfl

@[simp] lemma associator_hom_apply {X Y Z : Type u} {x : X} {y : Y} {z : Z} :
  ((α_ X Y Z).hom : (X ⊗ Y) ⊗ Z → X ⊗ (Y ⊗ Z)) ((x, y), z) = (x, (y, z)) := rfl
@[simp] lemma associator_inv_apply {X Y Z : Type u} {x : X} {y : Y} {z : Z} :
  ((α_ X Y Z).inv : X ⊗ (Y ⊗ Z) → (X ⊗ Y) ⊗ Z) (x, (y, z)) = ((x, y), z) := rfl

@[simp] lemma braiding_hom_apply {X Y : Type u} {x : X} {y : Y} :
  ((β_ X Y).hom : X ⊗ Y → Y ⊗ X) (x, y) = (y, x) := rfl
@[simp] lemma braiding_inv_apply {X Y : Type u} {x : X} {y : Y} :
  ((β_ X Y).inv : Y ⊗ X → X ⊗ Y) (y, x) = (x, y) := rfl

open opposite

open monoidal_category

/-- `(𝟙_ C ⟶ -)` is a lax monoidal functor to `Type`. -/
def coyoneda_tensor_unit (C : Type u) [category.{v} C] [monoidal_category C] :
  lax_monoidal_functor C (Type v) :=
{ ε := λ p, 𝟙 _,
  μ := λ X Y p, (λ_ (𝟙_ C)).inv ≫ (p.1 ⊗ p.2),
  μ_natural' := by tidy,
  associativity' := λ X Y Z, begin
    ext ⟨⟨f, g⟩, h⟩, dsimp at f g h,
    dsimp, simp only [iso.cancel_iso_inv_left, category.assoc],
    conv_lhs { rw [←category.id_comp h, tensor_comp, category.assoc, associator_naturality,
      ←category.assoc, unitors_inv_equal, triangle_assoc_comp_right_inv], },
    conv_rhs { rw [←category.id_comp f, tensor_comp], },
  end,
  left_unitality' := by tidy,
  right_unitality' := λ X, begin
    ext ⟨f, ⟨⟩⟩, dsimp at f,
    dsimp, simp only [category.assoc],
    rw [right_unitor_naturality, unitors_inv_equal, iso.inv_hom_id_assoc],
  end,
  ..coyoneda.obj (op (𝟙_ C)) }.

noncomputable theory

/-- If `F` is a monoidal functor out of `Type`, it takes the (n+1)st cartesian power
of a type to the image of that type, tensored with the image of the nth cartesian power. -/
-- We don't yet have an API for tensor products indexed by finite ordered types,
-- but it would be nice to state how monoidal functors preserve these.
def monoidal_functor.map_pi {C : Type*} [category C] [monoidal_category C]
  (F : monoidal_functor Type* C) (n : ℕ) (β : Type*) :
  F.obj (fin (n+1) → β) ≅ F.obj β ⊗ F.obj (fin n → β) :=
functor.map_iso _ (equiv.pi_fin_succ n β).to_iso ≪≫ (as_iso (F.μ β (fin n → β))).symm

end category_theory


inductive Bit where
  | zero
  | one

instance inst0 : OfNat Bit 0 where
  ofNat := Bit.zero

instance : OfNat Bit 1 where
  ofNat := Bit.one

example : Bit := 0
example : Bit := 1


import SciLean.Core.Differential
import SciLean.Core.Adjoint

namespace SciLean

variable {α β γ : Type}
variable {X Y Z W : Type} [SemiHilbert X] [SemiHilbert Y] [SemiHilbert Z] [SemiHilbert W]
variable {Y₁ Y₂ Y₃ : Type} [SemiHilbert Y₁] [SemiHilbert Y₂] [SemiHilbert Y₃]
variable {ι : Type} [Enumtype ι]

-- /-- Transitive closure of `HasAdjDiffN`
-- -/
-- class HasAdjDiffNT {X Y : Type} {Xs Y' : Type} [SemiHilbert Xs] [SemiHilbert Y']
--   (n : Nat) (f : X → Y) [Prod.Uncurry n (X → Y) Xs Y'] : Prop where
--   proof : IsSmoothNT n f ∧ ∀ x, HasAdjointT (∂ (uncurryN n f) x)

-- class HasAdjDiffN {X Y : Type} {Xs Y' : Type} [SemiHilbert Xs] [SemiHilbert Y']
--   (n : Nat) (f : X → Y) [Prod.Uncurry n (X → Y) Xs Y'] extends HasAdjDiffNT n f : Prop

-- abbrev HasAdjDiffT {X Y : Type} [SemiHilbert X] [SemiHilbert Y] (f : X → Y) := HasAdjDiffNT 1 f
-- abbrev HasAdjDiff {X Y : Type} [SemiHilbert X] [SemiHilbert Y] (f : X → Y) := HasAdjDiffN 1 f

-- class HasAdjDiff (f : X → Y) : Prop where
--   isSmooth : IsSmooth f
--   hasAdjDiff : ∀ x, HasAdjoint $ ∂ f x
instance (priority:=low-10) {X Y : Type} {Xs Y' : Type} [SemiHilbert Xs] [SemiHilbert Y']
  (n : Nat) (f : X → Y) [Prod.Uncurry n (X → Y) Xs Y']
  [sf : IsSmoothN n f] [∀ x, HasAdjoint (∂ (uncurryN n f) x)]
  : HasAdjDiffN n f
  := HasAdjDiffN.mk (toHasAdjDiffNT:= by constructor; apply sf.1; infer_instance)

theorem infer_HasAdjDiff {X Y : Type} {Xs Y' : Type} [SemiHilbert Xs] [SemiHilbert Y']
  {n : Nat} {f : X → Y} [Prod.Uncurry n (X → Y) Xs Y'] [IsSmoothT (uncurryN n f)]
  : (∀ x, HasAdjointT $ ∂ (uncurryN n f) x) → HasAdjDiffNT n f
  := λ h => by constructor; infer_instance; apply h

theorem infer_HasAdjDiff' {X Y : Type} {Xs Y' : Type} [SemiHilbert Xs] [SemiHilbert Y']
  {n : Nat} {f : X → Y} [Prod.Uncurry n (X → Y) Xs Y'] [IsSmoothT (uncurryN n f)]
  : (∀ x, HasAdjointT $ ∂ (uncurryN n f) x) → HasAdjDiffN n f
  := λ h => sorry

-- instance (priority := low-9) HasAdjoint_HasAdjDiff (f : X → Y) [HasAdjoint f] : HasAdjDiff f :=
-- by apply infer_HasAdjDiff'; symdiff; infer_instance; done

--------------------------------------------------------------------------------

--- Removing arguments - generalized this

instance HasAdjDiff2_apply_2 (f : X → Y → Z) [HasAdjDiffNT 2 f] (y : Y)
  : HasAdjDiffT (λ x => f x y) := sorry_proof

instance HasAdjDiff2_apply_1 (f : X → Y → Z) [HasAdjDiffNT 2 f] (x : X)
  : HasAdjDiffT (λ y => f x y) := sorry_proof

instance (f : X → Y → Z → W) [HasAdjDiffNT 3 f] (y z)
  : HasAdjDiffT (λ x => f x y z) := sorry_proof

instance (f : X → Y → Z → W) [HasAdjDiffNT 3 f] (x z)
  : HasAdjDiffT (λ y => f x y z) := sorry_proof

instance (f : X → Y → Z → W) [HasAdjDiffNT 3 f] (x y)
  : HasAdjDiffT (λ z => f x y z) := sorry_proof

--- Adding arguments - generalized this

instance HasAdjDiff_add_extra_2_1 (f : X → Y) [hf : HasAdjDiffT f]
  : HasAdjDiffNT 2 (λ (z : Z) x => f x) := sorry_proof

instance HasAdjDiff_add_extra_2_2 (f : X → Y) [HasAdjDiffT f]
  : HasAdjDiffNT 2 (λ x (z : Z) => f x) := sorry_proof

instance HasAdjDiff_add_extra_3_1 (f : Y → Z → W) [HasAdjDiffNT 2 f]
  : HasAdjDiffNT 3 (λ (x : X) y z => f y z) := sorry_proof

instance HasAdjDiff_add_extra_3_2 (f : X → Z → W) [HasAdjDiffNT 2 f]
  : HasAdjDiffNT 3 (λ x (y : Y) z => f x z) := sorry_proof

instance HasAdjDiff_add_extra_3_3 (f : X → Y → W) [HasAdjDiffNT 2 f]
  : HasAdjDiffNT 3 (λ x y (z : Z) => f x y) := sorry_proof

--------------------------------------------------------------------------------

instance id.arg_x.hasAdjDiff
  : HasAdjDiffT (λ x : X => x) := by apply infer_HasAdjDiff; intro; simp[uncurryN, Prod.Uncurry.uncurry]; infer_instance

instance const.arg_x.hasAdjDiff
  : HasAdjDiffT (λ (x : X) (i : ι) => x) := by apply infer_HasAdjDiff; intro; simp[uncurryN, Prod.Uncurry.uncurry]; infer_instance; done

instance const.arg_y.hasAdjDiff (x : X)
  : HasAdjDiffT (λ (y : Y) => x) := by apply infer_HasAdjDiff; intro; simp[uncurryN, Prod.Uncurry.uncurry]; infer_instance

instance (priority := low) swap.arg_y.hasAdjDiff
  (f : ι → Y → Z) [inst : ∀ x, HasAdjDiffT (f x)]
  : HasAdjDiffT (λ y x => f x y) :=
by
  have is := λ x => (inst x).1
  have ia := λ x => (inst x).2
  apply infer_HasAdjDiff; intro;
  simp[uncurryN, Prod.Uncurry.uncurry]; infer_instance; done

instance (priority := mid-1) subst.arg_x.hasAdjDiff
  (f : X → Y → Z) [instf : HasAdjDiffNT 2 f]
  (g : X → Y) [instg : HasAdjDiffT g]
  : HasAdjDiffT (λ x => f x (g x)) :=
by
  have isf := instf.1
  have iaf := instf.2
  have isg := instg.1
  have iag := instg.2

  have : ∀ x, IsSmoothT (f x) := sorry_proof
  have : IsSmoothT (λ x => λ y ⟿ f x y) := sorry_proof

  sorry_proof
  -- apply infer_HasAdjDiff; intro x;
  -- simp[uncurryN, Prod.Uncurry.uncurry, tangentMap];
  -- -- Thise should follow from `iaf`
  -- have : ∀ x y, HasAdjointT λ dx => ∂ f x dx y := sorry_proof
  -- have : ∀ x y, HasAdjointT λ dy => ∂ (f x) y dy := sorry_proof
  -- infer_instance; done

instance (priority := mid-1) subst2.arg_x.hasAdjDiff
  (f : X → Y → Y₁ → Z) [HasAdjDiffNT 3 f]
  (g : X → Y → Y₁) [HasAdjDiffNT 2 g] :
  HasAdjDiffNT 2 (λ x y => f x y (g x y)) := sorry_proof

instance (priority := mid-1) subst3.arg_x.hasAdjDiff
  (f : X → Y → Z → Y₁ → W) [HasAdjDiffNT 4 f]
  (g : X → Y → Z → Y₁) [HasAdjDiffNT 3 g] :
  HasAdjDiffNT 3 (λ x y z => f x y z (g x y z)) := sorry_proof

instance comp.arg_x.hasAdjDiff
  (f : Y → Z) [instf : HasAdjDiffT f]
  (g : X → Y) [instg : HasAdjDiffT g]
  : HasAdjDiffT (λ x => f (g x)) := by infer_instance

instance {Ws W' : Type} [SemiHilbert Ws] [SemiHilbert W']
  (f : Z → W) [Prod.Uncurry n W Ws W'] [HasAdjDiffNT (n+1) f]
  (g : X → Y → Z) [HasAdjDiffNT 2 g]
  : HasAdjDiffNT (n+2) fun x y => f (g x y) := sorry_proof

instance {Ws W' : Type} [SemiHilbert Ws] [SemiHilbert W']
  (f : Y₁ → Y₂→ W) [Prod.Uncurry n W Ws W'] [HasAdjDiffNT (n+2) f]
  (g₁ : X → Y → Z → Y₁) [HasAdjDiffNT 3 g₁]
  (g₂ : X → Y → Z → Y₂) [HasAdjDiffNT 3 g₂]
  : HasAdjDiffNT (n+3) fun x y z => f (g₁ x y z) (g₂ x y z) := sorry_proof

instance comp2.arg_x.HasAdjDiff
  (f : Y₁ → Y₂ → Z) [HasAdjDiffNT 2 f]
  (g₁ : X → Y → Y₁) [HasAdjDiffNT 2 g₁]
  (g₂ : X → Y → Y₂) [HasAdjDiffNT 2 g₂]
  : HasAdjDiffNT 2 (λ x y => f (g₁ x y) (g₂ x y)) :=
by
  have : HasAdjDiffNT 3 fun x y => f (g₁ x y) := by infer_instance
  infer_instance

instance comp3.arg_x.HasAdjDiff
  (f : Y₁ → Y₂ → Y₃ → W) [HasAdjDiffNT 3 f]
  (g₁ : X → Y → Z → Y₁) [HasAdjDiffNT 3 g₁]
  (g₂ : X → Y → Z → Y₂) [HasAdjDiffNT 3 g₂]
  (g₃ : X → Y → Z → Y₃) [HasAdjDiffNT 3 g₃]
  : HasAdjDiffNT 3 (λ x y z => f (g₁ x y z) (g₂ x y z) (g₃ x y z)) :=
by
  -- have : HasAdjDiffNT 4 fun x y z => f (g₁ x y z) (g₂ x y z) := by apply hoho
  infer_instance

instance diag.arg_x.hasAdjDiff
  (f : Y₁ → Y₂ → Z) [instf : HasAdjDiffNT 2 f]
  (g₁ : X → Y₁) [instg1 : HasAdjDiffT g₁]
  (g₂ : X → Y₂) [instg2 : HasAdjDiffT g₂]
  : HasAdjDiffT (λ x => f (g₁ x) (g₂ x)) := by infer_instance

instance eval.arg_x.parm1.hasAdjDiff
  (f : X → ι → Z) [inst : HasAdjDiffT f] (i : ι)
  : HasAdjDiffT (λ x => f x i) :=
  by
    have := inst.1
    have := inst.2

    apply infer_HasAdjDiff; intro; simp[uncurryN, Prod.Uncurry.uncurry]; infer_instance

----------------------------------------------------------------------

instance comp.arg_x.parm1.hasAdjDiff
  (a : α)
  (f : Y → α → Z) [HasAdjDiffT λ y => f y a]
  (g : X → Y) [HasAdjDiffT g]
  : HasAdjDiffT λ x => f (g x) a :=
  by
    apply comp.arg_x.hasAdjDiff (λ y => f y a) g
    done

instance diag.arg_x.parm1.hasAdjDiff
  (a : α)
  (f : Y₁ → Y₂ → α → Z) [HasAdjDiffNT 2 λ y₁ y₂ => f y₁ y₂ a]
  (g₁ : X → Y₁) [HasAdjDiffT g₁]
  (g₂ : X → Y₂) [HasAdjDiffT g₂]
  : HasAdjDiffT λ x => f (g₁ x) (g₂ x) a :=
  by
    apply diag.arg_x.hasAdjDiff (λ y₁ y₂ => f y₁ y₂ a) g₁ g₂
    done


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.monoidal.braided
import category_theory.monoidal.discrete
import category_theory.monoidal.coherence_lemmas
import category_theory.limits.shapes.terminal
import algebra.punit_instances

/-!
# The category of monoids in a monoidal category.

We define monoids in a monoidal category `C` and show that the category of monoids is equivalent to
the category of lax monoidal functors from the unit monoidal category to `C`.  We also show that if
`C` is braided, then the category of monoids is naturally monoidal.

-/

universes v₁ v₂ u₁ u₂ u

open category_theory
open category_theory.monoidal_category

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

/--
A monoid object internal to a monoidal category.

When the monoidal category is preadditive, this is also sometimes called an "algebra object".
-/
structure Mon_ :=
(X : C)
(one : 𝟙_ C ⟶ X)
(mul : X ⊗ X ⟶ X)
(one_mul' : (one ⊗ 𝟙 X) ≫ mul = (λ_ X).hom . obviously)
(mul_one' : (𝟙 X ⊗ one) ≫ mul = (ρ_ X).hom . obviously)
-- Obviously there is some flexibility stating this axiom.
-- This one has left- and right-hand sides matching the statement of `monoid.mul_assoc`,
-- and chooses to place the associator on the right-hand side.
-- The heuristic is that unitors and associators "don't have much weight".
(mul_assoc' : (mul ⊗ 𝟙 X) ≫ mul = (α_ X X X).hom ≫ (𝟙 X ⊗ mul) ≫ mul . obviously)

restate_axiom Mon_.one_mul'
restate_axiom Mon_.mul_one'
restate_axiom Mon_.mul_assoc'
attribute [reassoc] Mon_.one_mul Mon_.mul_one -- We prove a more general `@[simp]` lemma below.
attribute [simp, reassoc] Mon_.mul_assoc

namespace Mon_

/--
The trivial monoid object. We later show this is initial in `Mon_ C`.
-/
@[simps]
def trivial : Mon_ C :=
{ X := 𝟙_ C,
  one := 𝟙 _,
  mul := (λ_ _).hom,
  mul_assoc' := by coherence,
  mul_one' := by coherence }

instance : inhabited (Mon_ C) := ⟨trivial C⟩

variables {C} {M : Mon_ C}

@[simp] lemma one_mul_hom {Z : C} (f : Z ⟶ M.X) : (M.one ⊗ f) ≫ M.mul = (λ_ Z).hom ≫ f :=
by rw [←id_tensor_comp_tensor_id, category.assoc, M.one_mul, left_unitor_naturality]

@[simp] lemma mul_one_hom {Z : C} (f : Z ⟶ M.X) : (f ⊗ M.one) ≫ M.mul = (ρ_ Z).hom ≫ f :=
by rw [←tensor_id_comp_id_tensor, category.assoc, M.mul_one, right_unitor_naturality]

lemma assoc_flip : (𝟙 M.X ⊗ M.mul) ≫ M.mul = (α_ M.X M.X M.X).inv ≫ (M.mul ⊗ 𝟙 M.X) ≫ M.mul :=
by simp

/-- A morphism of monoid objects. -/
@[ext]
structure hom (M N : Mon_ C) :=
(hom : M.X ⟶ N.X)
(one_hom' : M.one ≫ hom = N.one . obviously)
(mul_hom' : M.mul ≫ hom = (hom ⊗ hom) ≫ N.mul . obviously)

restate_axiom hom.one_hom'
restate_axiom hom.mul_hom'
attribute [simp, reassoc] hom.one_hom hom.mul_hom

/-- The identity morphism on a monoid object. -/
@[simps]
def id (M : Mon_ C) : hom M M :=
{ hom := 𝟙 M.X, }

instance hom_inhabited (M : Mon_ C) : inhabited (hom M M) := ⟨id M⟩

/-- Composition of morphisms of monoid objects. -/
@[simps]
def comp {M N O : Mon_ C} (f : hom M N) (g : hom N O) : hom M O :=
{ hom := f.hom ≫ g.hom, }

instance : category (Mon_ C) :=
{ hom := λ M N, hom M N,
  id := id,
  comp := λ M N O f g, comp f g, }

@[simp] lemma id_hom' (M : Mon_ C) : (𝟙 M : hom M M).hom = 𝟙 M.X := rfl
@[simp] lemma comp_hom' {M N K : Mon_ C} (f : M ⟶ N) (g : N ⟶ K) :
  (f ≫ g : hom M K).hom = f.hom ≫ g.hom := rfl

section
variables (C)

/-- The forgetful functor from monoid objects to the ambient category. -/
@[simps]
def forget : Mon_ C ⥤ C :=
{ obj := λ A, A.X,
  map := λ A B f, f.hom, }

end

instance forget_faithful : faithful (@forget C _ _) := { }

instance {A B : Mon_ C} (f : A ⟶ B) [e : is_iso ((forget C).map f)] : is_iso f.hom := e

/-- The forgetful functor from monoid objects to the ambient category reflects isomorphisms. -/
instance : reflects_isomorphisms (forget C) :=
{ reflects := λ X Y f e, by exactI ⟨⟨
{ hom := inv f.hom,
  mul_hom' :=
  begin
    simp only [is_iso.comp_inv_eq, hom.mul_hom, category.assoc, ←tensor_comp_assoc,
      is_iso.inv_hom_id, tensor_id, category.id_comp],
  end }, by tidy⟩⟩ }

/--
Construct an isomorphism of monoids by giving an isomorphism between the underlying objects
and checking compatibility with unit and multiplication only in the forward direction.
-/
def iso_of_iso {M N : Mon_ C}
  (f : M.X ≅ N.X)
  (one_f : M.one ≫ f.hom = N.one)
  (mul_f : M.mul ≫ f.hom = (f.hom ⊗ f.hom) ≫ N.mul) :
  M ≅ N :=
{ hom := { hom := f.hom, one_hom' := one_f, mul_hom' := mul_f },
  inv :=
  { hom := f.inv,
    one_hom' := by { rw ←one_f, simp },
    mul_hom' :=
    begin
      rw ←(cancel_mono f.hom),
      slice_rhs 2 3 { rw mul_f },
      simp,
    end } }

instance unique_hom_from_trivial (A : Mon_ C) : unique (trivial C ⟶ A) :=
{ default :=
  { hom := A.one,
    one_hom' := by { dsimp, simp, },
    mul_hom' := by { dsimp, simp [A.one_mul, unitors_equal], } },
  uniq := λ f,
  begin
    ext, simp,
    rw [←category.id_comp f.hom],
    erw f.one_hom,
  end }

open category_theory.limits

instance : has_initial (Mon_ C) :=
has_initial_of_unique (trivial C)

end Mon_

namespace category_theory.lax_monoidal_functor

variables {C} {D : Type u₂} [category.{v₂} D] [monoidal_category.{v₂} D]

/--
A lax monoidal functor takes monoid objects to monoid objects.

That is, a lax monoidal functor `F : C ⥤ D` induces a functor `Mon_ C ⥤ Mon_ D`.
-/
-- TODO: map_Mod F A : Mod A ⥤ Mod (F.map_Mon A)
@[simps]
def map_Mon (F : lax_monoidal_functor C D) : Mon_ C ⥤ Mon_ D :=
{ obj := λ A,
  { X := F.obj A.X,
    one := F.ε ≫ F.map A.one,
    mul := F.μ _ _ ≫ F.map A.mul,
    one_mul' :=
    begin
      conv_lhs { rw [comp_tensor_id, ←F.to_functor.map_id], },
      slice_lhs 2 3 { rw [F.μ_natural], },
      slice_lhs 3 4 { rw [←F.to_functor.map_comp, A.one_mul], },
      rw [F.to_functor.map_id],
      rw [F.left_unitality],
    end,
    mul_one' :=
    begin
      conv_lhs { rw [id_tensor_comp, ←F.to_functor.map_id], },
      slice_lhs 2 3 { rw [F.μ_natural], },
      slice_lhs 3 4 { rw [←F.to_functor.map_comp, A.mul_one], },
      rw [F.to_functor.map_id],
      rw [F.right_unitality],
    end,
    mul_assoc' :=
    begin
      conv_lhs { rw [comp_tensor_id, ←F.to_functor.map_id], },
      slice_lhs 2 3 { rw [F.μ_natural], },
      slice_lhs 3 4 { rw [←F.to_functor.map_comp, A.mul_assoc], },
      conv_lhs { rw [F.to_functor.map_id] },
      conv_lhs { rw [F.to_functor.map_comp, F.to_functor.map_comp] },
      conv_rhs { rw [id_tensor_comp, ←F.to_functor.map_id], },
      slice_rhs 3 4 { rw [F.μ_natural], },
      conv_rhs { rw [F.to_functor.map_id] },
      slice_rhs 1 3 { rw [←F.associativity], },
      simp only [category.assoc],
    end, },
  map := λ A B f,
  { hom := F.map f.hom,
    one_hom' := by { dsimp, rw [category.assoc, ←F.to_functor.map_comp, f.one_hom], },
    mul_hom' :=
    begin
      dsimp,
      rw [category.assoc, F.μ_natural_assoc, ←F.to_functor.map_comp, ←F.to_functor.map_comp,
        f.mul_hom],
    end },
  map_id' := λ A, by { ext, simp, },
  map_comp' := λ A B C f g, by { ext, simp, }, }

variables (C D)

/-- `map_Mon` is functorial in the lax monoidal functor. -/
def map_Mon_functor : (lax_monoidal_functor C D) ⥤ (Mon_ C ⥤ Mon_ D) :=
{ obj := map_Mon,
  map := λ F G α,
  { app := λ A,
    { hom := α.app A.X, } } }

end category_theory.lax_monoidal_functor

namespace Mon_

open category_theory.lax_monoidal_functor

namespace equiv_lax_monoidal_functor_punit

/-- Implementation of `Mon_.equiv_lax_monoidal_functor_punit`. -/
@[simps]
def lax_monoidal_to_Mon : lax_monoidal_functor (discrete punit.{u+1}) C ⥤ Mon_ C :=
{ obj := λ F, (F.map_Mon : Mon_ _ ⥤ Mon_ C).obj (trivial (discrete punit)),
  map := λ F G α, ((map_Mon_functor (discrete punit) C).map α).app _ }

/-- Implementation of `Mon_.equiv_lax_monoidal_functor_punit`. -/
@[simps]
def Mon_to_lax_monoidal : Mon_ C ⥤ lax_monoidal_functor (discrete punit.{u+1}) C :=
{ obj := λ A,
  { obj := λ _, A.X,
    map := λ _ _ _, 𝟙 _,
    ε := A.one,
    μ := λ _ _, A.mul,
    map_id' := λ _, rfl,
    map_comp' := λ _ _ _ _ _, (category.id_comp (𝟙 A.X)).symm, },
  map := λ A B f,
  { app := λ _, f.hom,
    naturality' := λ _ _ _, by { dsimp, rw [category.id_comp, category.comp_id], },
    unit' := f.one_hom,
    tensor' := λ _ _, f.mul_hom, }, }

local attribute [tidy] tactic.discrete_cases
local attribute [simp] eq_to_iso_map

/-- Implementation of `Mon_.equiv_lax_monoidal_functor_punit`. -/
@[simps]
def unit_iso :
  𝟭 (lax_monoidal_functor (discrete punit.{u+1}) C) ≅
    lax_monoidal_to_Mon C ⋙ Mon_to_lax_monoidal C :=
nat_iso.of_components (λ F,
  monoidal_nat_iso.of_components
    (λ _, F.to_functor.map_iso (eq_to_iso (by ext)))
    (by tidy) (by tidy) (by tidy))
  (by tidy)

/-- Implementation of `Mon_.equiv_lax_monoidal_functor_punit`. -/
@[simps]
def counit_iso : Mon_to_lax_monoidal C ⋙ lax_monoidal_to_Mon C ≅ 𝟭 (Mon_ C) :=
nat_iso.of_components (λ F, { hom := { hom := 𝟙 _, }, inv := { hom := 𝟙 _, } })
  (by tidy)

end equiv_lax_monoidal_functor_punit

open equiv_lax_monoidal_functor_punit

local attribute [simp] eq_to_iso_map

/--
Monoid objects in `C` are "just" lax monoidal functors from the trivial monoidal category to `C`.
-/
@[simps]
def equiv_lax_monoidal_functor_punit : lax_monoidal_functor (discrete punit.{u+1}) C ≌ Mon_ C :=
{ functor := lax_monoidal_to_Mon C,
  inverse := Mon_to_lax_monoidal C,
  unit_iso := unit_iso C,
  counit_iso := counit_iso C, }

end Mon_

namespace Mon_

/-!
In this section, we prove that the category of monoids in a braided monoidal category is monoidal.

Given two monoids `M` and `N` in a braided monoidal category `C`, the multiplication on the tensor
product `M.X ⊗ N.X` is defined in the obvious way: it is the tensor product of the multiplications
on `M` and `N`, except that the tensor factors in the source come in the wrong order, which we fix
by pre-composing with a permutation isomorphism constructed from the braiding.

A more conceptual way of understanding this definition is the following: The braiding on `C` gives
rise to a monoidal structure on the tensor product functor from `C × C` to `C`.  A pair of monoids
in `C` gives rise to a monoid in `C × C`, which the tensor product functor by being monoidal takes
to a monoid in `C`.  The permutation isomorphism appearing in the definition of the multiplication
on the tensor product of two monoids is an instance of a more general family of isomorphisms which
together form a strength that equips the tensor product functor with a monoidal structure, and the
monoid axioms for the tensor product follow from the monoid axioms for the tensor factors plus the
properties of the strength (i.e., monoidal functor axioms).  The strength `tensor_μ` of the tensor
product functor has been defined in `category_theory.monoidal.braided`.  Its properties, stated as
independent lemmas in that module, are used extensively in the proofs below.  Notice that we could
have followed the above plan not only conceptually but also as a possible implementation and could
have constructed the tensor product of monoids via `map_Mon`, but we chose to give a more explicit
definition directly in terms of `tensor_μ`.

To complete the definition of the monoidal category structure on the category of monoids, we need
to provide definitions of associator and unitors.  The obvious candidates are the associator and
unitors from `C`, but we need to prove that they are monoid morphisms, i.e., compatible with unit
and multiplication.  These properties translate to the monoidality of the associator and unitors
(with respect to the monoidal structures on the functors they relate), which have also been proved
in `category_theory.monoidal.braided`.

-/

variable {C}

-- The proofs that associators and unitors preserve monoid units don't require braiding.

lemma one_associator {M N P : Mon_ C} :
    ((λ_ (𝟙_ C)).inv ≫ ((λ_ (𝟙_ C)).inv ≫ (M.one ⊗ N.one) ⊗ P.one)) ≫ (α_ M.X N.X P.X).hom
  = (λ_ (𝟙_ C)).inv ≫ (M.one ⊗ (λ_ (𝟙_ C)).inv ≫ (N.one ⊗ P.one)) :=
begin
  simp,
  slice_lhs 1 3 { rw [←category.id_comp P.one, tensor_comp] },
  slice_lhs 2 3 { rw associator_naturality },
  slice_rhs 1 2 { rw [←category.id_comp M.one, tensor_comp] },
  slice_lhs 1 2 { rw [←left_unitor_tensor_inv] },
  rw ←(cancel_epi (λ_ (𝟙_ C)).inv),
  slice_lhs 1 2 { rw [left_unitor_inv_naturality] },
  simp only [category.assoc],
end

lemma one_left_unitor {M : Mon_ C} :
  ((λ_ (𝟙_ C)).inv ≫ (𝟙 (𝟙_ C) ⊗ M.one)) ≫ (λ_ M.X).hom = M.one :=
by { slice_lhs 2 3 { rw left_unitor_naturality }, simp }

lemma one_right_unitor {M : Mon_ C} :
  ((λ_ (𝟙_ C)).inv ≫ (M.one ⊗ 𝟙 (𝟙_ C))) ≫ (ρ_ M.X).hom = M.one :=
by { slice_lhs 2 3 { rw [right_unitor_naturality, ←unitors_equal] }, simp }

variable [braided_category C]

lemma Mon_tensor_one_mul (M N : Mon_ C) :
    ((λ_ (𝟙_ C)).inv ≫ (M.one ⊗ N.one) ⊗ 𝟙 (M.X ⊗ N.X)) ≫
    tensor_μ C (M.X, N.X) (M.X, N.X) ≫ (M.mul ⊗ N.mul)
  = (λ_ (M.X ⊗ N.X)).hom :=
begin
  rw [←category.id_comp (𝟙 (M.X ⊗ N.X)), tensor_comp],
  slice_lhs 2 3 { rw [←tensor_id, tensor_μ_natural] },
  slice_lhs 3 4 { rw [←tensor_comp, one_mul M, one_mul N] },
  symmetry,
  exact tensor_left_unitality C M.X N.X,
end

lemma Mon_tensor_mul_one (M N : Mon_ C) :
    (𝟙 (M.X ⊗ N.X) ⊗ (λ_ (𝟙_ C)).inv ≫ (M.one ⊗ N.one)) ≫
    tensor_μ C (M.X, N.X) (M.X, N.X) ≫ (M.mul ⊗ N.mul)
  = (ρ_ (M.X ⊗ N.X)).hom :=
begin
  rw [←category.id_comp (𝟙 (M.X ⊗ N.X)), tensor_comp],
  slice_lhs 2 3 { rw [←tensor_id, tensor_μ_natural] },
  slice_lhs 3 4 { rw [←tensor_comp, mul_one M, mul_one N] },
  symmetry,
  exact tensor_right_unitality C M.X N.X,
end

lemma Mon_tensor_mul_assoc (M N : Mon_ C) :
    (tensor_μ C (M.X, N.X) (M.X, N.X) ≫ (M.mul ⊗ N.mul) ⊗ 𝟙 (M.X ⊗ N.X)) ≫
    tensor_μ C (M.X, N.X) (M.X, N.X) ≫
    (M.mul ⊗ N.mul)
  = (α_ (M.X ⊗ N.X) (M.X ⊗ N.X) (M.X ⊗ N.X)).hom ≫
    (𝟙 (M.X ⊗ N.X) ⊗ tensor_μ C (M.X, N.X) (M.X, N.X) ≫ (M.mul ⊗ N.mul)) ≫
    tensor_μ C (M.X, N.X) (M.X, N.X) ≫
    (M.mul ⊗ N.mul) :=
begin
  rw [←category.id_comp (𝟙 (M.X ⊗ N.X)), tensor_comp],
  slice_lhs 2 3 { rw [←tensor_id, tensor_μ_natural] },
  slice_lhs 3 4 { rw [←tensor_comp, mul_assoc M, mul_assoc N, tensor_comp, tensor_comp] },
  slice_lhs 1 3 { rw [tensor_associativity] },
  slice_lhs 3 4 { rw [←tensor_μ_natural] },
  slice_lhs 2 3 { rw [←tensor_comp, tensor_id] },
  simp only [category.assoc],
end

lemma mul_associator {M N P : Mon_ C} :
    (tensor_μ C (M.X ⊗ N.X, P.X) (M.X ⊗ N.X, P.X) ≫
      (tensor_μ C (M.X, N.X) (M.X, N.X) ≫ (M.mul ⊗ N.mul) ⊗ P.mul)) ≫
    (α_ M.X N.X P.X).hom
  = ((α_ M.X N.X P.X).hom ⊗ (α_ M.X N.X P.X).hom) ≫
    tensor_μ C (M.X, N.X ⊗ P.X) (M.X, N.X ⊗ P.X) ≫
    (M.mul ⊗ tensor_μ C (N.X, P.X) (N.X, P.X) ≫ (N.mul ⊗ P.mul)) :=
begin
  simp,
  slice_lhs 2 3 { rw [←category.id_comp P.mul, tensor_comp] },
  slice_lhs 3 4 { rw [associator_naturality] },
  slice_rhs 3 4 { rw [←category.id_comp M.mul, tensor_comp] },
  slice_lhs 1 3 { rw associator_monoidal },
  simp only [category.assoc],
end

lemma mul_left_unitor {M : Mon_ C}:
    (tensor_μ C (𝟙_ C, M.X) (𝟙_ C, M.X) ≫ ((λ_ (𝟙_ C)).hom ⊗ M.mul)) ≫ (λ_ M.X).hom
  = ((λ_ M.X).hom ⊗ (λ_ M.X).hom) ≫ M.mul :=
begin
  rw [←(category.comp_id (λ_ (𝟙_ C)).hom), ←(category.id_comp M.mul), tensor_comp],
  slice_lhs 3 4 { rw left_unitor_naturality },
  slice_lhs 1 3 { rw ←left_unitor_monoidal },
  simp only [category.assoc, category.id_comp],
end

lemma mul_right_unitor {M : Mon_ C} :
    (tensor_μ C (M.X, 𝟙_ C) (M.X, 𝟙_ C) ≫ (M.mul ⊗ (λ_ (𝟙_ C)).hom)) ≫ (ρ_ M.X).hom
  = ((ρ_ M.X).hom ⊗ (ρ_ M.X).hom) ≫ M.mul :=
begin
  rw [←(category.id_comp M.mul), ←(category.comp_id (λ_ (𝟙_ C)).hom), tensor_comp],
  slice_lhs 3 4 { rw right_unitor_naturality },
  slice_lhs 1 3 { rw ←right_unitor_monoidal },
  simp only [category.assoc, category.id_comp],
end

instance Mon_monoidal : monoidal_category (Mon_ C) :=
{ tensor_obj := λ M N,
  { X := M.X ⊗ N.X,
    one := (λ_ (𝟙_ C)).inv ≫ (M.one ⊗ N.one),
    mul := tensor_μ C (M.X, N.X) (M.X, N.X) ≫ (M.mul ⊗ N.mul),
    one_mul' := Mon_tensor_one_mul M N,
    mul_one' := Mon_tensor_mul_one M N,
    mul_assoc' := Mon_tensor_mul_assoc M N },
  tensor_hom := λ M N P Q f g,
  { hom := f.hom ⊗ g.hom,
    one_hom' :=
    begin
      dsimp,
      slice_lhs 2 3 { rw [←tensor_comp, hom.one_hom f, hom.one_hom g] },
    end,
    mul_hom' :=
    begin
      dsimp,
      slice_rhs 1 2 { rw [tensor_μ_natural] },
      slice_lhs 2 3 { rw [←tensor_comp, hom.mul_hom f, hom.mul_hom g, tensor_comp] },
      simp only [category.assoc],
    end },
  tensor_id' := by { intros, ext, apply tensor_id },
  tensor_comp' := by { intros, ext, apply tensor_comp },
  tensor_unit := trivial C,
  associator := λ M N P, iso_of_iso (α_ M.X N.X P.X) one_associator mul_associator,
  associator_naturality' := by { intros, ext, dsimp, apply associator_naturality },
  left_unitor := λ M, iso_of_iso (λ_ M.X) one_left_unitor mul_left_unitor,
  left_unitor_naturality' := by { intros, ext, dsimp, apply left_unitor_naturality },
  right_unitor := λ M, iso_of_iso (ρ_ M.X) one_right_unitor mul_right_unitor,
  right_unitor_naturality' := by { intros, ext, dsimp, apply right_unitor_naturality },
  pentagon' := by { intros, ext, dsimp, apply pentagon },
  triangle' := by { intros, ext, dsimp, apply triangle } }

end Mon_

/-!
Projects:
* Check that `Mon_ Mon ≌ CommMon`, via the Eckmann-Hilton argument.
  (You'll have to hook up the cartesian monoidal structure on `Mon` first, available in #3463)
* Check that `Mon_ Top ≌ [bundled topological monoids]`.
* Check that `Mon_ AddCommGroup ≌ Ring`.
  (We've already got `Mon_ (Module R) ≌ Algebra R`, in `category_theory.monoidal.internal.Module`.)
* Can you transport this monoidal structure to `Ring` or `Algebra R`?
  How does it compare to the "native" one?
* Show that when `C` is braided, the forgetful functor `Mon_ C ⥤ C` is monoidal.
* Show that when `F` is a lax braided functor `C ⥤ D`, the functor `map_Mon F : Mon_ C ⥤ Mon_ D`
  is lax monoidal.
-/


import category_theory.preadditive
import category_theory.arrow

-- TODO : generalize to comma categories?

namespace category_theory

variables {A : Type*} [category A] [preadditive A]

local attribute [simp] preadditive.comp_nsmul preadditive.nsmul_comp
    preadditive.comp_zsmul preadditive.zsmul_comp

instance arrow.has_zero (P Q : arrow A) : has_zero (P ⟶ Q) :=
⟨arrow.hom_mk (show 0 ≫ Q.hom = P.hom ≫ 0, by simp)⟩
instance arrow.has_add (P Q : arrow A) : has_add (P ⟶ Q) :=
⟨λ f g, arrow.hom_mk (show (f.left + g.left) ≫ Q.hom = P.hom ≫ (f.right + g.right), by simp)⟩
instance arrow.has_neg (P Q : arrow A) : has_neg (P ⟶ Q) :=
⟨λ f, arrow.hom_mk (show (-f.left) ≫ Q.hom = P.hom ≫ (-f.right), by simp)⟩
instance arrow.has_sub (P Q : arrow A) : has_sub (P ⟶ Q) :=
⟨λ f g, arrow.hom_mk (show (f.left - g.left) ≫ Q.hom = P.hom ≫ (f.right - g.right), by simp)⟩
instance arrow.has_nsmul (P Q : arrow A) : has_smul ℕ (P ⟶ Q) :=
⟨λ n f, arrow.hom_mk (show (n • f.left) ≫ Q.hom = P.hom ≫ (n • f.right), by simp)⟩
instance arrow.has_zsmul (P Q : arrow A) : has_smul ℤ (P ⟶ Q) :=
⟨λ n f, arrow.hom_mk (show (n • f.left) ≫ Q.hom = P.hom ≫ (n • f.right), by simp)⟩
.
@[simp] lemma arrow.has_add_left {P Q : arrow A} (f g : P ⟶ Q) :
  (f + g).left = f.left + g.left := rfl
@[simp] lemma arrow.has_add_right {P Q : arrow A} (f g : P ⟶ Q) :
  (f + g).right = f.right + g.right := rfl
@[simp] lemma arrow.has_neg_left {P Q : arrow A} (f : P ⟶ Q) :
  (-f).left = -(f.left) := rfl
@[simp] lemma arrow.has_neg_right {P Q : arrow A} (f : P ⟶ Q) :
  (-f).right = -(f.right) := rfl
@[simp] lemma arrow.has_sub_left {P Q : arrow A} (f g : P ⟶ Q) :
  (f - g).left = f.left - g.left := rfl
@[simp] lemma arrow.has_sub_right {P Q : arrow A} (f g : P ⟶ Q) :
  (f - g).right = f.right - g.right := rfl

instance arrow.add_comm_group (P Q : arrow A) : add_comm_group (P ⟶ Q) :=
{ add_assoc := λ f g h, by ext; apply add_assoc,
  zero_add := λ f, by ext; apply zero_add,
  add_zero := λ f, by ext; apply add_zero,
  add_left_neg := λ f, by ext; apply add_left_neg,
  add_comm := λ f g, by ext; apply add_comm,
  ..arrow.has_add P Q,
  ..arrow.has_zero P Q,
  ..arrow.has_neg P Q,
  ..arrow.has_nsmul P Q,
  ..arrow.has_zsmul P Q }
.
instance arrow.preadditive : preadditive (arrow A) :=
⟨infer_instance, by { introv P, ext; apply preadditive.add_comp },
  by { introv P, ext; apply preadditive.comp_add }⟩

end category_theory


import parlang.defs
import parlang.lemmas_state
import parlang.lemmas_exec
import parlang.nonmono

namespace parlang

variables {σ σ₁ σ₂ σ₃ : Type} {ι₁ ι₂ : Type} {τ₁ : ι₁ → Type} {τ₂ : ι₂ → Type} [decidable_eq ι₁] [decidable_eq ι₂]

@[reducible]
def rhl_kernel_assertion := Π n₁:ℕ, state n₁ σ₁ τ₁ → vector bool n₁ → Π n₂:ℕ, state n₂ σ₂ τ₂ → vector bool n₂ → Prop

/-- Relational Hoare logic on kernels.  -/
def rel_hoare_state (P : rhl_kernel_assertion) (k₁ : kernel σ₁ τ₁) (k₂ : kernel σ₂ τ₂)
    (Q : rhl_kernel_assertion) : Prop :=
    ∀ (n₁ n₂ : ℕ) (s₁ s₁' : state n₁ σ₁ τ₁) (s₂ : state n₂ σ₂ τ₂) ac₁ ac₂, P n₁ s₁ ac₁ n₂ s₂ ac₂ → exec_state k₁ ac₁ s₁ s₁' →
    ∃ s₂', exec_state k₂ ac₂ s₂ s₂' ∧ Q n₁ s₁' ac₁ n₂ s₂' ac₂

notation `{* ` P : 1 ` *} ` k₁ : 1 ` ~> ` k₂ : 1 ` {* ` Q : 1 ` *}` := rel_hoare_state P k₁ k₂ Q

namespace rel_hoare

-- lemma seq {P Q R} {k₁ k₁' k₂ k₂' : kernel σ τ} : {* P *} k₁ ~ k₁' {* Q *} → {* Q *} k₂ ~ k₂' {* R *} → {* P *} (k₁ ;; k₂) ~ (k₁' ;; k₂') {* R *} := begin
--     intros h₁ h₂ n s u ac m m' o o' hp hseq₁ hseq₂,
--     cases hseq₁,
--     cases hseq₂,
--     cases hseq₁_hk,
--     cases hseq₂_hk,
--     unfold rel_hoare at h₁ h₂,
--     apply h₂ n _ _ _ _ _ _ _ _ _ hseq₁_hk_a_1 hseq₂_hk_a_1,
-- end

end rel_hoare

/-- Relational Hoare logic on Parlang programs with assertions on memory -/
def rel_hoare_program (init₁ : ℕ → σ₁) (init₂ : ℕ → σ₂) (P : memory τ₁ → memory τ₂ → Prop) (p₁ : program σ₁ τ₁) (p₂ : program σ₂ τ₂) (Q : memory τ₁ → memory τ₂ → Prop) :=
∀ m₁ m₁' m₂, P m₁ m₂ → exec_prog init₁ p₁ m₁ m₁' → ∃ m₂', exec_prog init₂ p₂ m₂ m₂' ∧ Q m₁' m₂'

-- notation `{* ` P : 1 ` *} ` p₁ : 1 ` ~ ` p₂ : 1 ` {* ` Q : 1 ` *}` := rel_hoare_state P p₁ p₂ Q

/-- The initial kernel assertion that holds on state and ac
    TODO: change to a struct to get projections for free?
-/
def initial_kernel_assertion (init₁ : ℕ → σ₁) (init₂ : ℕ → σ₂) (P : memory τ₁ → memory τ₂ → Prop)
(f₁ : memory τ₁ → ℕ) (f₂ : memory τ₂ → ℕ) (m₁ : memory τ₁) (m₂ : memory τ₂)
(n₁) (s₁ : state n₁ σ₁ τ₁) (ac₁ : vector bool n₁) (n₂) (s₂ : state n₂ σ₂ τ₂) (ac₂ : vector bool n₂) :=
s₁.syncable m₁ ∧ s₂.syncable m₂ ∧ n₁ = f₁ m₁ ∧ n₂ = f₂ m₂ ∧
(∀ i : fin n₁, s₁.threads.nth i = { tlocal := init₁ i, shared := m₁, stores := ∅, loads := ∅ }) ∧
(∀ i : fin n₂, s₂.threads.nth i = { tlocal := init₂ i, shared := m₂, stores := ∅, loads := ∅ }) ∧
P m₁ m₂ ∧ all_threads_active ac₁ ∧ all_threads_active ac₂

/- Projections of initial_kernel_assertion -/
section

    def initial_kernel_assertion_left_thread_state {init₁ : ℕ → σ₁} {init₂ : ℕ → σ₂} {P : memory τ₁ → memory τ₂ → Prop}
    {f₁ : memory τ₁ → ℕ} {f₂ : memory τ₂ → ℕ} {m₁ : memory τ₁} {m₂ : memory τ₂}
    {n₁} {s₁ : state n₁ σ₁ τ₁} {ac₁ : vector bool n₁} {n₂} {s₂ : state n₂ σ₂ τ₂} {ac₂ : vector bool n₂}
    (i : initial_kernel_assertion init₁ init₂ P f₁ f₂ m₁ m₂ n₁ s₁ ac₁ n₂ s₂ ac₂) := i.right.right.right.right.left

    def initial_kernel_assertion.right_thread_state {init₁ : ℕ → σ₁} {init₂ : ℕ → σ₂} {P : memory τ₁ → memory τ₂ → Prop}
    {f₁ : memory τ₁ → ℕ} {f₂ : memory τ₂ → ℕ} {m₁ : memory τ₁} {m₂ : memory τ₂}
    {n₁} {s₁ : state n₁ σ₁ τ₁} {ac₁ : vector bool n₁} {n₂} {s₂ : state n₂ σ₂ τ₂} {ac₂ : vector bool n₂}
    (i : initial_kernel_assertion init₁ init₂ P f₁ f₂ m₁ m₂ n₁ s₁ ac₁ n₂ s₂ ac₂) := i.right.right.right.right.right.left

    def initial_kernel_assertion.left_all_threads_active {init₁ : ℕ → σ₁} {init₂ : ℕ → σ₂} {P : memory τ₁ → memory τ₂ → Prop}
    {f₁ : memory τ₁ → ℕ} {f₂ : memory τ₂ → ℕ} {m₁ : memory τ₁} {m₂ : memory τ₂}
    {n₁} {s₁ : state n₁ σ₁ τ₁} {ac₁ : vector bool n₁} {n₂} {s₂ : state n₂ σ₂ τ₂} {ac₂ : vector bool n₂}
    (i : initial_kernel_assertion init₁ init₂ P f₁ f₂ m₁ m₂ n₁ s₁ ac₁ n₂ s₂ ac₂) := i.right.right.right.right.right.right.right.left

    def initial_kernel_assertion.precondition {init₁ : ℕ → σ₁} {init₂ : ℕ → σ₂} {P : memory τ₁ → memory τ₂ → Prop}
    {f₁ : memory τ₁ → ℕ} {f₂ : memory τ₂ → ℕ} {m₁ : memory τ₁} {m₂ : memory τ₂}
    {n₁} {s₁ : state n₁ σ₁ τ₁} {ac₁ : vector bool n₁} {n₂} {s₂ : state n₂ σ₂ τ₂} {ac₂ : vector bool n₂}
    (i : initial_kernel_assertion init₁ init₂ P f₁ f₂ m₁ m₂ n₁ s₁ ac₁ n₂ s₂ ac₂) := i.right.right.right.right.right.right.left

    lemma initial_kernel_assertion.initial_state_eq {init₁ : ℕ → σ₁}
    {f₁ : memory τ₁ → ℕ} {f₂ : memory τ₁ → ℕ} {m₁ : memory τ₁} {m₂ : memory τ₁}
    {n₁} {s₁ : state n₁ σ₁ τ₁} {ac₁ : vector bool n₁} {s₂ : state n₁ σ₁ τ₁} {ac₂ : vector bool n₁} :
    initial_kernel_assertion init₁ init₁ eq f₁ f₂ m₁ m₂ n₁ s₁ ac₁ n₁ s₂ ac₂ →
    s₁ = s₂ |
    (and.intro _ (and.intro _ (and.intro _ (and.intro _ (and.intro s_eq (and.intro s'_eq _)))))) := begin
        clear initial_kernel_assertion.initial_state_eq,
        cases s₁,
        cases s₂,
        simp,
        apply vector.eq_element_wise,
        intro tid,
        simp *,
    end

end

/- Reduces proofs on programs to proofs on kernels -/
lemma rel_kernel_to_program {k₁ : kernel σ₁ τ₁} {k₂ : kernel σ₂ τ₂} {init₁ : ℕ → σ₁} {init₂ : ℕ → σ₂} {P Q : memory τ₁ → memory τ₂ → Prop} {f₁ : memory τ₁ → ℕ} {f₂ : memory τ₂ → ℕ}
 (h : {* λ n₁ s₁ ac₁ n₂ s₂ ac₂, ∃ m₁ m₂, initial_kernel_assertion init₁ init₂ P f₁ f₂ m₁ m₂ n₁ s₁ ac₁ n₂ s₂ ac₂ *} k₁ ~> k₂
 {* λ n₁ s₁ ac₁ n₂ s₂ ac₂, (∃ m₁, s₁.syncable m₁) → ∃ m₁ m₂, s₁.syncable m₁ ∧ s₂.syncable m₂ ∧ Q m₁ m₂ *} )
 (hg : ∀ {m₁ m₂}, P m₁ m₂ → 0 < f₁ m₁) :
 rel_hoare_program init₁ init₂ P (program.intro f₁ k₁) (program.intro f₂ k₂) Q :=
begin
    unfold rel_hoare_state at h,
    unfold rel_hoare_program,
    intros m₁ m₁' m₂ hp hep,
    cases hep,
    specialize h (f₁ m₁) (f₂ m₂)
        (init_state init₁ f₁ m₁)
        hep_s'
        (init_state init₂ f₂ m₂)
        (vector.repeat tt (f₁ m₁))
        (vector.repeat tt (f₂ m₂)),
    have hh : (∃ (s₂' : state (f₂ m₂) σ₂ τ₂), exec_state k₂ (vector.repeat tt (f₂ m₂)) (init_state init₂ f₂ m₂) s₂' ∧
    ((∃ m₁, hep_s'.syncable m₁) → ∃ (m₁_1 : memory τ₁) (m₂_1 : memory τ₂), state.syncable hep_s' m₁_1 ∧ state.syncable s₂' m₂_1 ∧ Q m₁_1 m₂_1)) := begin
        apply h,
        {
            apply exists.intro m₁,
            apply exists.intro m₂,
            apply and.intro,
            {
                apply init_state_syncable,
            }, {
                apply and.intro,
                {
                    apply init_state_syncable,
                },
                {
                    apply and.intro,
                    {
                        refl,
                    },
                    {
                        apply and.intro,
                        {
                            refl,
                        },
                        {
                            apply and.intro,
                            {
                                simp,
                                intro i,
                                rw vector.range_nth,
                            },
                            {
                                apply and.intro,
                                {
                                    simp,
                                    intro i,
                                    rw vector.range_nth,
                                }, {
                                    apply and.intro,
                                    {
                                        exact hp,
                                    }, {
                                        apply and.intro,
                                        {
                                            apply all_threads_active_repeat,
                                        }, {
                                            apply all_threads_active_repeat,
                                        }
                                    }
                                }
                            }
                        }
                    }
                }
            }
        }, {
            exact hep_he,
        }
    end,
    cases hh,
    cases hh_h,
    specialize hh_h_right ⟨_, hep_hsync⟩,
    cases hh_h_right with m₁'',
    cases hh_h_right_h with m₂',
    apply exists.intro m₂',
    apply and.intro,
    {
        apply exec_prog.intro _ _ _ _ _ hh_w,
        { exact hh_h_right_h_h.right.left, },
        { exact hh_h_left, },
    }, {
        have hu : m₁' = m₁'' := begin
            have hz : 0 < (f₁ m₁) := hg hp,
            apply state.syncable_unique hep_hsync hh_h_right_h_h.left hz,
        end,
        subst hu,
        exact hh_h_right_h_h.right.right,
    }
end

/-
    Inference rules
 -/

-- TODO: define the alias skip for (compute id)
lemma single_step_left {P Q} {k₁ k : kernel σ₁ τ₁} {k₂ : kernel σ₂ τ₂} (R)
    (h₁ : {* P *} k ~> (kernel.compute id) {* R *})
    (h₂ : {* R *} k₁ ~> k₂ {* Q *}) :
    {* P *} (k ;; k₁) ~> k₂ {* Q *} := begin
    intros n₁ n₂ s₁ s₁'' s₂ ac₁ ac₂ hp hek₁,
    cases hek₁,
    specialize h₁ n₁ n₂ s₁ _ s₂ ac₁ ac₂ hp hek₁_a,
    cases h₁ with s₂' h₁,
    cases h₁,
    have : s₂ = s₂' := begin
        cases h₁_left,
        cases s₂,
        sorry, -- trivial
    end,
    apply h₂,
    rw this,
    exact h₁_right,
    exact hek₁_a_1,
end

lemma single_step_right {P Q} {k₁ : kernel σ₁ τ₁} {k₂ k : kernel σ₂ τ₂} (R)
    (h₁ : {* P *} (kernel.compute id) ~> k  {* R *})
    (h₂ : {* R *} k₁ ~> k₂ {* Q *}) :
    {* P *} k₁ ~> k ;; k₂ {* Q *} := sorry

variables {P Q R P' Q' I : Π n₁:ℕ, state n₁ σ₁ τ₁ → vector bool n₁ → Π n₂:ℕ, state n₂ σ₂ τ₂ → vector bool n₂ → Prop} {k₁ k₁' : kernel σ₁ τ₁} {k₂ k₂' : kernel σ₂ τ₂}

-- intuition of the proof (to be repurposed by further proofs):
-- we get the intermediate state of after k₁ by cases
-- from h₁ we get state after k₂
-- from h₂ we get state after k₂'
lemma seq (Q)
    (h₁ : {* P *} k₁ ~> k₂ {* Q *})
    (h₂ : {* Q *} k₁' ~> k₂' {* R *}) :
    {* P *} (k₁ ;; k₁') ~> (k₂ ;; k₂') {* R *} := begin
        intros _ _ _ _ _ _ _ hp hek₁k₁',
        cases hek₁k₁',
        specialize h₁ n₁ n₂ s₁ hek₁k₁'_t s₂ ac₁ ac₂ hp hek₁k₁'_a,
        cases h₁ with t₂,
        cases h₁_h with hek₂ hq,
        specialize h₂ n₁ n₂ hek₁k₁'_t _ t₂ ac₁ ac₂ hq hek₁k₁'_a_1,
        cases h₂ with s₂',
        apply exists.intro s₂',
        apply and.intro,
        apply exec_state.seq _ _ _ _ _ _ hek₂ (h₂_h.left),
        exact h₂_h.right,
end

-- sometimes called sub
lemma consequence (h : {* P *} k₁ ~> k₂ {* Q *})
(hp : ∀ n₁ s₁ ac₁ n₂ s₂ ac₂, P' n₁ s₁ ac₁ n₂ s₂ ac₂ → P n₁ s₁ ac₁ n₂ s₂ ac₂)
(hq : ∀ n₁ s₁ ac₁ n₂ s₂ ac₂, Q n₁ s₁ ac₁ n₂ s₂ ac₂ → Q' n₁ s₁ ac₁ n₂ s₂ ac₂) : {* P' *} k₁ ~> k₂ {* Q' *} := begin
    intros _ _ _ _ _ _ _ hp' he₁,
    specialize h n₁ n₂ s₁ s₁' s₂ ac₁ ac₂ _ he₁,
    cases h with s₂ h,
    use s₂,cases h,
    apply and.intro,
    assumption,
    apply hq,
    assumption,
    apply hp,
    assumption,
end

lemma consequence_pre (h : {* P *} k₁ ~> k₂ {* Q *})
(hp : ∀ n₁ s₁ ac₁ n₂ s₂ ac₂, P' n₁ s₁ ac₁ n₂ s₂ ac₂ → P n₁ s₁ ac₁ n₂ s₂ ac₂) :
{* P' *} k₁ ~> k₂ {* Q *} := begin
    apply consequence,
    exact h,
    exact hp,
    intros,
    exact a,
end

lemma consequence_post (h : {* P *} k₁ ~> k₂ {* Q *})
(hp : ∀ n₁ s₁ ac₁ n₂ s₂ ac₂, Q n₁ s₁ ac₁ n₂ s₂ ac₂ → Q' n₁ s₁ ac₁ n₂ s₂ ac₂) :
{* P *} k₁ ~> k₂ {* Q' *} := begin
    apply consequence,
    exact h,
    intros,
    exact a,
    exact hp,
end

def assertion_swap_side (P : @rhl_kernel_assertion σ₁ σ₂ _ _ τ₁ τ₂ _ _) := λ n₁ s₁ ac₁ n₂ s₂ ac₂, P n₂ s₂ ac₂ n₁ s₁ ac₁

lemma swap' (h : {* λ n₁ s₁ ac₁ n₂ s₂ ac₂, P n₁ s₁ ac₁ n₂ s₂ ac₂ ∧ ∃ t, exec_state k₂ ac₂ s₂ t *} k₁ ~> k₂ {* Q *}) (he₁ : ∀ {n₁ s₁ ac₁ n₂ s₂ ac₂}, P n₁ s₁ ac₁ n₂ s₂ ac₂ → ∃ s₁', exec_state k₁ ac₁ s₁ s₁') :
{* assertion_swap_side P *} k₂ ~> k₁ {* assertion_swap_side Q *} := begin
    sorry,
end

-- k₁ must terminate
lemma swap (h : {* P *} k₁ ~> k₂ {* Q *}) (he₁ : ∀ {n₁ s₁ ac₁ n₂ s₂ ac₂}, P n₁ s₁ ac₁ n₂ s₂ ac₂ → ∃ s₁', exec_state k₁ ac₁ s₁ s₁') :
{* assertion_swap_side P *} k₂ ~> k₁ {* assertion_swap_side Q *} := begin
    intros n₂ n₁ s₂ s₂' s₁ ac₂ ac₁ hp he₂,
    simp,
    have : ∃ s₁', exec_state k₁ ac₁ s₁ s₁' := he₁ hp,
    cases this with s₁' he₂,
    use s₁',
    split,
    assumption,
    specialize h n₁ n₂ s₁ _ s₂ ac₁ ac₂ hp he₂,
    cases h,
    have : h_w = s₂' := sorry, -- by uniqueness
    subst this,
    exact h_h.right,
end

theorem trans (p₁ : program σ₁ τ₁) (p₂ : program σ₂ τ₁) (p₃ : program σ₃ τ₁) (init₁ init₂ init₃) (h₁ : rel_hoare_program init₁ init₂ eq p₁ p₂ eq) (h₂ : rel_hoare_program init₂ init₃ eq p₂ p₃ eq) :
rel_hoare_program init₁ init₃ eq p₁ p₃ eq := begin
    unfold rel_hoare_program at *,
    intros _ _ _ heq he,
    specialize h₁ m₁ m₁' m₂ heq he,
    cases h₁ with m h,
    cases h,
    subst heq,
    subst h_right,
    specialize h₂ m₁ m₁' m₁ rfl h_left,
    exact h₂,
end

theorem compute_right (f) : {* λ n₁ s₁ ac₁ n₂ s₂ ac₂, Q n₁ s₁ ac₁ n₂ (s₂.map_active_threads ac₂ $ thread_state.compute f) ac₂ *} (kernel.compute id) ~> (kernel.compute f) {* Q *} := begin
    intros _ _ _ _ _ _ _ hp he,
    use (s₂.map_active_threads ac₂ $ thread_state.compute f),
    split,
    {
        apply exec_state.compute,
    }, {
        cases he,
        sorry, -- trivial
    }
end

theorem store_right (f : σ₂ → (Σ (i : ι₂), τ₂ i)) :
{* λ n₁ s₁ ac₁ n₂ s₂ ac₂, Q n₁ s₁ ac₁ n₂ (s₂.map_active_threads ac₂ $ thread_state.store f) ac₂ *}
(kernel.compute id) ~> (kernel.store f)
{* Q *} := begin
    intros _ _ _ _ _ _ _ hp he,
    use (s₂.map_active_threads ac₂ $ thread_state.store f),
    split, {
        apply exec_state.store,
    }, {
        cases he,
        sorry, -- trivial
    }
end

-- TODO: move to another file
theorem else_skip {n} (k : kernel σ τ₁) (c) (ac : vector bool n) (s s' : state n σ τ₁):
exec_state k (deactivate_threads (bnot ∘ c) ac s) s s' ↔
exec_state (kernel.ite c k (kernel.compute id)) ac s s' := begin
    split, {
        intro h,
        apply exec_state.ite s s',
        exact h,
        apply exec_skip,
    }, {
        intro h,
        cases h,
        have := eq.symm (exec_skip_eq h_a_1),
        subst this,
        exact h_a,
    }
end

/--
Breaks a ite-instruction into the individual branches
The assertions can be used to carry information about the active map from before the branch to after the branch
In the if-branch, the condition holds on all active threads (similar in else-branch). The inverse is not true. Just because the condition *c* holds, does not mean that the thread is active (e.g. if the thread was already inactive). -/
theorem ite_right (c : σ₂ → bool) (th) (el) (AC : ∀ {n₂ : ℕ}, vector bool n₂ → Prop)
(h₁ : ∀ n₁ s₁ ac₁ n₂ s₂ ac₂, P n₁ s₁ ac₁ n₂ s₂ ac₂ → P n₁ s₁ ac₁ n₂ s₂ (deactivate_threads (bnot ∘ c) ac₂ s₂))
(h₂ : ∀ n₁ s₁ ac₁ n₂ s₂ ac₂ (s' : state n₂ σ₂ τ₂), Q n₁ s₁ ac₁ n₂ s₂ (deactivate_threads (bnot ∘ c) ac₂ s') → Q n₁ s₁ ac₁ n₂ s₂ ac₂)
(h₃ : ∀ n₁ s₁ ac₁ n₂ s₂ ac₂ (s' : state n₂ σ₂ τ₂), Q n₁ s₁ ac₁ n₂ s₂ ac₂ → Q n₁ s₁ ac₁ n₂ s₂ (deactivate_threads c ac₂ s'))
(h₄ : ∀ n₁ s₁ ac₁ n₂ s₂ ac₂ (s' : state n₂ σ₂ τ₂), R n₁ s₁ ac₁ n₂ s₂ (deactivate_threads c ac₂ s') → R n₁ s₁ ac₁ n₂ s₂ ac₂) :
{* λ n₁ s₁ ac₁ n₂ s₂ ac₂, P n₁ s₁ ac₁ n₂ s₂ ac₂ ∧ (s₂.active_threads ac₂).all (λts, c ts.tlocal) *} kernel.compute id ~> th {* Q *} →
{* λ n₁ s₁ ac₁ n₂ s₂ ac₂, Q n₁ s₁ ac₁ n₂ s₂ ac₂ ∧ (s₂.active_threads ac₂).all (λts, bnot $ c ts.tlocal) *} kernel.compute id ~> el {* R *} →
{* λ n₁ s₁ ac₁ n₂ s₂ ac₂, P n₁ s₁ ac₁ n₂ s₂ ac₂ ∧ AC ac₂ *} kernel.compute id ~> kernel.ite c th el {* λ n₁ s₁ ac₁ n₂ s₂ ac₂, R n₁ s₁ ac₁ n₂ s₂ ac₂ ∧ AC ac₂ *}
:= begin
    intros hth hel,
    intros _ _ _ _ _ _ _ hp he,
    specialize hth n₁ n₂ s₁ s₁ s₂ ac₁ (deactivate_threads (bnot ∘ c) ac₂ s₂) _ exec_skip,
    swap, {
        split, {
            apply h₁ _ _ _ _ _ _ hp.left,
        }, {
            sorry, -- not trivial
        }
    },
    cases hth with s₂' hth,
    specialize hel n₁ n₂ s₁ s₁ s₂' ac₁ (deactivate_threads c ac₂ s₂) _ (exec_skip),
    swap, {
        split, {
            apply h₃,
            apply h₂ _ _ _ _ _ _ s₂,
            exact hth.right,
        }, {
            sorry, -- not trivial
        }
    },
    cases hel with s₂'' hel,
    have := eq.symm (exec_skip_eq he),
    subst this,
    use s₂'',
    split, {
        apply exec_state.ite,
        exact hth.left,
        exact hel.left,
    },
    simp,
    split, {
        apply h₄,
        exact hel.right,
    }, {
        exact hp.right,
    }
end

/-- *ite_right* w/o an assertion on the active map -/
theorem ite_right' (c : σ₂ → bool) (th) (el)
(h₁ : ∀ n₁ s₁ ac₁ n₂ s₂ ac₂, P n₁ s₁ ac₁ n₂ s₂ ac₂ → P n₁ s₁ ac₁ n₂ s₂ (deactivate_threads (bnot ∘ c) ac₂ s₂))
(h₂ : ∀ n₁ s₁ ac₁ n₂ s₂ ac₂ (s' : state n₂ σ₂ τ₂), Q n₁ s₁ ac₁ n₂ s₂ (deactivate_threads (bnot ∘ c) ac₂ s') → Q n₁ s₁ ac₁ n₂ s₂ ac₂)
(h₃ : ∀ n₁ s₁ ac₁ n₂ s₂ ac₂ (s' : state n₂ σ₂ τ₂), Q n₁ s₁ ac₁ n₂ s₂ ac₂ → Q n₁ s₁ ac₁ n₂ s₂ (deactivate_threads c ac₂ s'))
(h₄ : ∀ n₁ s₁ ac₁ n₂ s₂ ac₂ (s' : state n₂ σ₂ τ₂), R n₁ s₁ ac₁ n₂ s₂ (deactivate_threads c ac₂ s') → R n₁ s₁ ac₁ n₂ s₂ ac₂) :
{* λ n₁ s₁ ac₁ n₂ s₂ ac₂, P n₁ s₁ ac₁ n₂ s₂ ac₂ ∧ (s₂.active_threads ac₂).all (λts, c ts.tlocal) *} kernel.compute id ~> th {* Q *} →
{* λ n₁ s₁ ac₁ n₂ s₂ ac₂, Q n₁ s₁ ac₁ n₂ s₂ ac₂ ∧ (s₂.active_threads ac₂).all (λts, bnot $ c ts.tlocal) *} kernel.compute id ~> el {* R *} →
{* P *} kernel.compute id ~> kernel.ite c th el {* R *}
:= begin
    intros _ _,
    suffices : {* λ n₁ s₁ ac₁ n₂ s₂ ac₂, P n₁ s₁ ac₁ n₂ s₂ ac₂ ∧ (λ_, true) ac₂ *} kernel.compute id ~> kernel.ite c th el {* λ n₁ s₁ ac₁ n₂ s₂ ac₂, R n₁ s₁ ac₁ n₂ s₂ ac₂ ∧ (λ_, true) ac₂ *},
    simp at this,
    exact this,
    apply ite_right,
    repeat { assumption, },
    exact h₂,
end

-- TODO: use ite_right
theorem then_right (c : σ₂ → bool) (th)
(h₁ : ∀ n₁ s₁ ac₁ n₂ s₂ ac₂, P n₁ s₁ ac₁ n₂ s₂ ac₂ → P n₁ s₁ ac₁ n₂ s₂ (deactivate_threads (bnot ∘ c) ac₂ s₂))
(h₂ : ∀ n₁ s₁ ac₁ n₂ s₂ ac₂ (s : state n₂ σ₂ τ₂), Q n₁ s₁ ac₁ n₂ s₂ (deactivate_threads (bnot ∘ c) ac₂ s) → Q n₁ s₁ ac₁ n₂ s₂ ac₂) :
{* λ n₁ s₁ ac₁ n₂ s₂ ac₂, P n₁ s₁ ac₁ n₂ s₂ ac₂ ∧ (s₂.active_threads ac₂).all (λts, c ts.tlocal) *} kernel.compute id ~> th {* Q *} →
{* P *} kernel.compute id ~> kernel.ite c th (kernel.compute id) {* Q *}
:= begin
    intros hth,
    intros _ _ _ _ _ _ _ hp he,
    have := eq.symm (exec_skip_eq he),
    subst this,
    specialize hth n₁ n₂ s₁ s₁ s₂ ac₁ (deactivate_threads (bnot ∘ c) ac₂ s₂) _ he,
    swap, {
        split, {
            apply h₁,
            apply hp,
        }, {
            sorry, -- not trivial
        }
    },
    cases hth with s₂' hth,
    use s₂',
    split, {
        apply exec_state.ite,
        exact hth.left,
        apply exec_skip,
    }, {
        apply h₂,
        apply hth.right,
    }
end

/-- TODO:
    - add post-condition: condition is false on all active threads
    - rename n
    - drop h₃ and deactivate threads in the post condition of hb ()
-/
/- theorem while_right.aux (c : σ₂ → bool) (k) (V : ∀ {n₂} (s₂ : state n₂ σ₂ τ₂) (ac₂ : vector bool n₂), ℕ)
(h₁ : ∀ {n₁ s₁ ac₁ n₂ s₂ ac₂}, P n₁ s₁ ac₁ n₂ s₂ ac₂ → P n₁ s₁ ac₁ n₂ s₂ (deactivate_threads (bnot ∘ c) ac₂ s₂))
(h₂ : ∀ {n₁ s₁ ac₁ n₂ s₂ ac₂} {s : state n₂ σ₂ τ₂}, P n₁ s₁ ac₁ n₂ s₂ (deactivate_threads (bnot ∘ c) ac₂ s) → P n₁ s₁ ac₁ n₂ s₂ ac₂)
(h₃ : ∀ {n₂} (s₂ : state n₂ σ₂ τ₂) (ac₂ : vector bool n₂), V s₂ (deactivate_threads (bnot ∘ c) ac₂ s₂) ≤ V s₂ ac₂)
(hb : ∀ n, {* λ n₁ s₁ ac₁ n₂ s₂ ac₂, P n₁ s₁ ac₁ n₂ s₂ ac₂ ∧ (s₂.active_threads ac₂).all (λts, c ts.tlocal) ∧ V s₂ ac₂ = n *} kernel.compute id ~> k {* λ n₁ s₁ ac₁ n₂ s₂ ac₂, P n₁ s₁ ac₁ n₂ s₂ ac₂ ∧ V s₂ ac₂ < n *}) :
∀ (n : ℕ), {* λ n₁ s₁ ac₁ n₂ s₂ ac₂, P n₁ s₁ ac₁ n₂ s₂ ac₂ ∧ V s₂ (deactivate_threads (bnot ∘ c) ac₂ s₂) = n *} kernel.compute id ~> kernel.loop c k {* P *}
| n n₁ n₂ s₁ s₁' s₂ ac₁ ac₂ ⟨hp, hv⟩ he :=
let ha := (any_thread_active (deactivate_threads (bnot ∘ c) ac₂ s₂)) in
let goal := ∃ (s₂' : state n₂ σ₂ τ₂), exec_state (kernel.loop c k) ac₂ s₂ s₂' ∧ P n₁ s₁' ac₁ n₂ s₂' ac₂ in
have base : ha = ff → goal, from begin
    intro ha,
    {
        use s₂,
        split, {
            apply exec_state.loop_stop,
            sorry
        }, {
            sorry, -- trivial
        }
    }
end,
have it : ha = tt → goal, from (
    assume hha,
    /- precondition holds in the first loop iteration -/
    have hp' : P n₁ s₁ ac₁ n₂ s₂ (deactivate_threads (bnot ∘ c) ac₂ s₂) := begin
        exact h₁ hp,
    end,
    /- the condition is true for all active threads in the first loop iteration -/
    have hc : list.all (state.active_threads (deactivate_threads (bnot ∘ c) ac₂ s₂) s₂) (λ ts , c (ts.tlocal)) = tt := begin
        sorry, -- not trivial
    end,
    /- proof of first iteration -/
    have step : _ := hb (V s₂ (deactivate_threads (bnot ∘ c) ac₂ s₂)) n₁ n₂ s₁ s₁ s₂ ac₁ (deactivate_threads (bnot ∘ c) ac₂ s₂) ⟨hp', ⟨hc, rfl⟩⟩ exec_skip,
    /- s₂' is the state after first iteration -/
    show goal, from match step with ⟨s₂', step⟩ :=
        /- condition holds after first iteration -/
        have hp'' : P n₁ s₁ ac₁ n₂ s₂' (deactivate_threads (bnot ∘ c) ac₂ s₂) := begin
            simp at step,
            exact step.right.left,
        end,
        have wf : V s₂' (deactivate_threads (bnot ∘ c) (deactivate_threads (bnot ∘ c) ac₂ s₂) s₂') < n := begin
            simp at step,
            subst hv,
            specialize h₃ s₂' (deactivate_threads (bnot ∘ c) ac₂ s₂),
            rw le_iff_eq_or_lt at h₃,
            cases h₃,
            {
                rw h₃,
                exact step.right.right,
            }, {
                apply lt_trans h₃ step.right.right,
            }
        end,
        have ih : _ := while_right.aux (V s₂' (deactivate_threads (bnot ∘ c) (deactivate_threads (bnot ∘ c) ac₂ s₂) s₂')) n₁ n₂ s₁ s₁ s₂' ac₁ (deactivate_threads (bnot ∘ c) ac₂ s₂) ⟨hp'', rfl⟩ exec_skip,
        show goal, from match ih with ⟨s₂'', ih⟩ := (begin
            use  s₂'',
            split, {
                apply exec_state.loop_step,
                exact ha,
                exact step.left,
                exact ih.left,
            }, {
                have := exec_skip_eq he,
                clear _match _match,
                subst this,
                apply h₂ ih.right,
            },
        end)
        end -- end match
    end
),
show goal, from begin
    cases a : ha,
    exact base a,
    exact it a,
end -/

theorem while_right (c : σ₂ → bool) (k) (V : ∀ {n₂} (s₂ : state n₂ σ₂ τ₂) (ac₂ : vector bool n₂), ℕ)
(h₁ : ∀ {n₁ s₁ ac₁ n₂ s₂ ac₂}, I n₁ s₁ ac₁ n₂ s₂ ac₂ → I n₁ s₁ ac₁ n₂ s₂ (deactivate_threads (bnot ∘ c) ac₂ s₂))
(h₂ : ∀ {n₁ s₁ ac₁ n₂ s₂ ac₂} {s : state n₂ σ₂ τ₂}, I n₁ s₁ ac₁ n₂ s₂ (deactivate_threads (bnot ∘ c) ac₂ s) → I n₁ s₁ ac₁ n₂ s₂ ac₂)
(hb : ∀ n, {* λ n₁ s₁ ac₁ n₂ s₂ ac₂, I n₁ s₁ ac₁ n₂ s₂ ac₂ ∧ (s₂.active_threads ac₂).all (λts, c ts.tlocal) ∧ V s₂ ac₂ = n *} kernel.compute id ~> k {* λ n₁ s₁ ac₁ n₂ s₂ ac₂, I n₁ s₁ ac₁ n₂ s₂ ac₂ ∧ V s₂ (deactivate_threads (bnot ∘ c) ac₂ s₂) < n *}) :
{* I *} kernel.compute id ~> kernel.loop c k {* I *} := sorry

theorem while_left (c : σ₁ → bool) (k) (V : ∀ {n₂} (s₂ : state n₂ σ₂ τ₂) (ac₂ : vector bool n₂), ℕ)
(h₁ : ∀ {n₁ s₁ ac₁ n₂ s₂ ac₂}, I n₁ s₁ ac₁ n₂ s₂ ac₂ → I n₁ s₁ (deactivate_threads (bnot ∘ c) ac₁ s₁) n₂ s₂ ac₂)
(h₂ : ∀ {n₁ s₁ ac₁ n₂ s₂ ac₂} {s : state n₁ σ₁ τ₁}, I n₁ s₁ (deactivate_threads (bnot ∘ c) ac₁ s) n₂ s₂ ac₂ → I n₁ s₁ ac₁ n₂ s₂ ac₂)
(hb : {* λ n₁ s₁ ac₁ n₂ s₂ ac₂, I n₁ s₁ ac₁ n₂ s₂ ac₂ ∧ (s₁.active_threads ac₁).all (λts, c ts.tlocal) *} k ~> kernel.compute id {* λ n₁ s₁ ac₁ n₂ s₂ ac₂, I n₁ s₁ ac₁ n₂ s₂ ac₂ *}) :
{* I *} kernel.loop c k ~> kernel.compute id {* I *} := begin
    apply swap,
    {
        sorry, -- we need the assumption that the loop terminates here
    },
    sorry,
end

theorem ite_left' (c : σ₁ → bool) (th) (el)
(h₁ : ∀ n₁ s₁ ac₁ n₂ s₂ ac₂, P n₁ s₁ ac₁ n₂ s₂ ac₂ → P n₁ s₁ (deactivate_threads (bnot ∘ c) ac₁ s₁) n₂ s₂ ac₂)
(h₂ : ∀ n₁ s₁ ac₁ n₂ s₂ ac₂ (s' : state n₁ σ₁ τ₁), Q n₁ s₁ (deactivate_threads (bnot ∘ c) ac₁ s') n₂ s₂ ac₂ → Q n₁ s₁ ac₁ n₂ s₂ ac₂)
(h₃ : ∀ n₁ s₁ ac₁ n₂ s₂ ac₂ (s' : state n₁ σ₁ τ₁), Q n₁ s₁ ac₁ n₂ s₂ ac₂ → Q n₁ s₁ (deactivate_threads c ac₁ s') n₂ s₂ ac₂)
(h₄ : ∀ n₁ s₁ ac₁ n₂ s₂ ac₂ (s' : state n₁ σ₁ τ₁), R n₁ s₁ (deactivate_threads c ac₁ s') n₂ s₂ ac₂ → R n₁ s₁ ac₁ n₂ s₂ ac₂) :
{* λ n₁ s₁ ac₁ n₂ s₂ ac₂, P n₁ s₁ ac₁ n₂ s₂ ac₂ ∧ (s₁.active_threads ac₁).all (λts, c ts.tlocal) *} th ~> kernel.compute id {* Q *} →
{* λ n₁ s₁ ac₁ n₂ s₂ ac₂, Q n₁ s₁ ac₁ n₂ s₂ ac₂ ∧ (s₁.active_threads ac₁).all (λts, bnot $ c ts.tlocal) *} el ~> kernel.compute id {* R *} →
{* P *} kernel.ite c th el ~> kernel.compute id {* R *} := begin
    intros hth hel,
    apply swap',
    {
        apply ite_right',
        swap 5, {
            apply swap,
            apply consequence,
            apply hth,
            {
                intros,
                exact ⟨a.left.left, a.right⟩,
            }, {
                intros,
                exact a,
            },
            intros,
            cases a.left.right,
            cases h,

            sorry, -- we need proof that th terminates
        },
        swap 5, {
            apply swap,
            apply hel,
            sorry, -- we need proof that el terminates
        }, {
            intros,
            split,
            apply h₁,
            exact a.left,
            sorry,
        }, {
            intros,
            apply h₂,
            exact a,
        }, {
            intros,
            apply h₃,
            exact a,
        }, {
            sorry,
        }
    }, {
        intros,
        use s₁,
        apply exec_skip,
    }
end

lemma kernel_foldr_skip_right {k : kernel σ₂ τ₂} {ks} :
{* P *} k₁ ~> list.foldr kernel.seq k ks {* Q *} ↔ {* P *} k₁ ~> list.foldr kernel.seq (kernel.compute id) ks ;; k {* Q *} := sorry

lemma rhl_eq :
{* λn₁ (s₁ : state n₁ σ₁ τ₁) ac₁ n₂ s₂ ac₂, n₁ = n₂ ∧ ∀ h : n₁ = n₂, s₁ = (by rw h; exact s₂) ∧ ac₁ = (by rw h; exact ac₂) *}
k₁ ~> k₁
{* λn₁ s₁ ac₁ n₂ s₂ ac₂, n₁ = n₂ ∧ ∀ h : n₁ = n₂, s₁ = (by rw h; exact s₂) ∧ ac₁ = (by rw h; exact ac₂) *} := begin
    intros _ _ _ _ _ _ _ hp  he,
    cases hp,
    subst hp_left,
    specialize hp_right rfl,
    have : s₁ = s₂ := hp_right.left,
    subst this,
    have : ac₁ = ac₂ := hp_right.right,
    subst this,
    use s₁',
    split,
    exact he,
    simp,
    split,
    refl,
    refl,
end

theorem known_branch_left (c : σ₁ → bool) (th) (el)
(h₁ : ∀ n₁ s₁ ac₁ n₂ s₂ ac₂, P n₁ s₁ ac₁ n₂ s₂ ac₂ → ∀ tid : fin n₁, c $ (s₁.threads.nth tid).tlocal)
(h₂ : {* P *} th ~> k₂ {* Q *}) :
{* P *} kernel.ite c th el ~> k₂ {* Q *} := begin
    intros _ _ _ _ _ _ _ hp he,
    cases he,
    specialize h₁ n₁ s₁ ac₁ n₂ s₂ ac₂ hp,
    apply h₂ n₁ n₂ s₁ s₁' s₂ ac₁ ac₂ hp,
    have : (deactivate_threads (bnot ∘ c) ac₁ s₁) = ac₁ := begin
        apply ac_deac_ge',
        intros _ h' _,
        specialize h₁ t,
        simp [deactivate_threads, *] at h',
        exact h',
    end,
    rw this at he_a,
    have : no_thread_active (deactivate_threads c ac₁ s₁) = tt := sorry,
    have : exec_state el (deactivate_threads c ac₁ s₁) he_t he_t := exec_no_threads_active this,
    have : he_t = s₁' := exec_state_unique he_a_1 this,
    subst this,
    exact he_a,
end

end parlang


/-
Copyright (c) 2017 Daniel Selsam. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Daniel Selsam

Identifiers.
-/
import .util .label

namespace certigrad

inductive ID : Type
| str : label → ID
| nat : ℕ → ID

namespace ID

instance : decidable_eq ID := by tactic.mk_dec_eq_instance
instance : inhabited ID := ⟨ID.str label.default⟩

private def add : ID → ID → ID
| (ID.nat n₁) (ID.nat n₂) := ID.nat (n₁ + n₂)
| _           _           := default ID

def to_str : ID → string
| (str l) := to_string l
| (nat n) := "#" ++ to_string n

instance : has_to_string ID := ⟨to_str⟩

def less_than : ID → ID → Prop
| (nat n)  (str s) := true
| (str s)  (nat n) := false
| (nat n₁) (nat n₂) := n₁ < n₂
| (str s₁) (str s₂) := s₁ < s₂

instance : has_lt ID := ⟨less_than⟩

instance decidable_less_than : Π (x y : ID), decidable (x < y)
| (nat n)  (str s) := decidable.true
| (str s)  (nat n) := decidable.false
| (nat n₁) (nat n₂) := show decidable (n₁ < n₂), by apply_instance
| (str s₁) (str s₂) := by apply label.decidable_less_than

end ID

lemma id_str_ne_nat (x : label) (n : ℕ) : (ID.str x ≠ ID.nat n) = true :=
begin apply pextt, intro H, injection H end

lemma id_nat_ne_str (x : label) (n : ℕ) : (ID.nat n ≠ ID.str x) = true :=
begin apply pextt, intro H, injection H end

lemma id_str_ne_str (x₁ x₂ : label) : (ID.str x₁ ≠ ID.str x₂) = (x₁ ≠ x₂) :=
begin
apply propext,
split,
intros H_ne H_eq,
subst H_eq,
exact H_ne rfl,
intros H_ne H_eq,
injection H_eq with H,
exact H_ne H
end

lemma id_nat_ne_nat (n₁ n₂ : ℕ) : (ID.nat n₁ ≠ ID.nat n₂) = (n₁ ≠ n₂) :=
begin
apply propext,
split,
intros H_ne H_eq,
subst H_eq,
exact H_ne rfl,
intros H_ne H_eq,
injection H_eq with H,
exact H_ne H
end

end certigrad