import category_theory.shift
import algebra.homology.homological_complex
import algebra.homology.homotopy_category
import data.int.parity
import category_theory.arrow
import category_theory.preadditive
import tactic.ring

import for_mathlib.homology_iso
import for_mathlib.neg_one_pow

local attribute [simp] category_theory.preadditive.zsmul_comp category_theory.preadditive.comp_zsmul

universes v u

open category_theory category_theory.limits category_theory.preadditive

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

namespace homological_complex

lemma complex_shape.up'_add_right_cancel {α : Type*} [add_cancel_comm_monoid α] (a : α)
  {i j} (k : α) : (complex_shape.up' a).rel (i+k) (j+k) ↔ (complex_shape.up' a).rel i j :=
by { dsimp, rw [add_assoc, add_comm k a, ← add_assoc], exact add_left_inj _ }

lemma complex_shape.up_add_right_cancel {α : Type*} [add_cancel_comm_monoid α] [has_one α]
  {i j} (k : α) : (complex_shape.up α).rel (i+k) (j+k) ↔ (complex_shape.up α).rel i j :=
complex_shape.up'_add_right_cancel 1 k

@[simps]
def shift_functor (n : ℤ) : cochain_complex V ℤ ⥤ cochain_complex V ℤ :=
{ obj := λ X,
  { X := λ i, X.X (i + n),
    d := λ i j, n.neg_one_pow • X.d _ _,
    shape' := λ i j h, by { rw [X.shape (i+n) (j+n), smul_zero],
      rwa complex_shape.up_add_right_cancel } },
  map := λ X Y f, { f := λ i, f.f _ } }

variables {V} {ι : Type*} {c : complex_shape ι}

def X_eq_to_iso (X : homological_complex V c) {i j : ι} (h : i = j) : X.X i ≅ X.X j :=
eq_to_iso $ congr_arg X.X h

@[simp]
lemma X_eq_to_iso_inv (X : homological_complex V c) {i j : ι} (h : i = j) :
  (X.X_eq_to_iso h).inv = (X.X_eq_to_iso h.symm).hom := rfl

@[simp, reassoc]
lemma X_eq_to_iso_d (X : homological_complex V c) {i j k : ι} (h : i = j) :
  (X.X_eq_to_iso h).hom ≫ X.d j k = X.d i k := by { subst h, exact category.id_comp _ }

@[simp, reassoc]
lemma X_d_eq_to_iso (X : homological_complex V c) {i j k : ι} (h : j = k) :
  X.d i j ≫ (X.X_eq_to_iso h).hom = X.d i k := by { subst h, exact category.comp_id _ }

@[simp, reassoc]
lemma X_eq_to_iso_trans (X : homological_complex V c) {i j k : ι} (h : i = j) (h' : j = k) :
  (X.X_eq_to_iso h).hom ≫ (X.X_eq_to_iso h').hom = (X.X_eq_to_iso (h.trans h')).hom :=
by { simp [X_eq_to_iso] }

@[simp]
lemma X_eq_to_iso_refl (X : homological_complex V c) {i : ι} :
  (X.X_eq_to_iso (refl i)).hom = 𝟙 _ := rfl

@[simp, reassoc]
lemma X_eq_to_iso_f {X Y : homological_complex V c} (f : X ⟶ Y) {i j : ι} (h : i = j) :
  (X.X_eq_to_iso h).hom ≫ f.f j = f.f i ≫ (Y.X_eq_to_iso h).hom :=
by { subst h, simp [X_eq_to_iso] }

variables (V)

instance : has_shift (cochain_complex V ℤ) ℤ :=
has_shift_mk _ _
{ F := shift_functor V,
  ε := nat_iso.of_components (λ X, hom.iso_of_components (λ i, X.X_eq_to_iso (add_zero _).symm)
    (λ i j r, by { dsimp, simp })) (λ X Y f, by { ext, dsimp, simp }),
  μ := λ n m, nat_iso.of_components (λ X, hom.iso_of_components
    (λ i, X.X_eq_to_iso (by rw [add_comm n m, add_assoc]))
    (λ i j r, by { dsimp, simp [smul_smul, mul_comm] })) (λ i j f, by { ext, dsimp, simp }),
  associativity := λ m₁ m₂ m₃ X, by { ext, dsimp, simp [X_eq_to_iso] },
  left_unitality := λ n X, by { ext, dsimp, simpa [X_eq_to_iso] },
  right_unitality := λ n X, by { ext, dsimp, simpa [X_eq_to_iso] } }

local attribute[instance] endofunctor_monoidal_category

@[simp] lemma shift_X (X : cochain_complex V ℤ) (n m : ℤ) :
  (X⟦n⟧).X m = X.X (m + n) := rfl

@[simp] lemma shift_d (X : cochain_complex V ℤ) (n i j : ℤ) :
  (X⟦n⟧).d i j = n.neg_one_pow • X.d (i + n) (j + n) := rfl

@[simp] lemma shift_f {X Y : cochain_complex V ℤ} (f : X ⟶ Y) (n i : ℤ) :
  (f⟦n⟧').f i = f.f (i + n) := rfl

instance (n : ℤ) : functor.additive ((shift_monoidal_functor (cochain_complex V ℤ) ℤ).obj ⟨n⟩) :=
  {}
instance shift_functor_additive (n : ℤ) : functor.additive (shift_functor V n) := {}

variable {V}

def homotopy_shift {X Y : cochain_complex V ℤ} {f g : X ⟶ Y} (h : homotopy f g) (n : ℤ)  :
  homotopy (f⟦n⟧') (g⟦n⟧') :=
{ hom := λ i j, n.neg_one_pow • h.hom _ _,
  zero' := λ i j r, by { rw ← complex_shape.up_add_right_cancel n at r, simp [h.zero _ _ r] },
  comm := λ i, begin
    dsimp, delta d_from d_to from_next to_prev,
    simp only [h.comm (i+n), d_next, prev_d, add_left_inj, add_monoid_hom.mk'_apply,
      shift_d, shift_X, zsmul_comp, comp_zsmul, int.neg_one_pow_smul_self],
    delta X_next X_prev, dsimp,
    congr' 3; simp only [cochain_complex.next, cochain_complex.prev]; ring,
  end }

variable (V)

def homotopy_category.shift_functor (n : ℤ) :
  (homotopy_category V (complex_shape.up ℤ)) ⥤ (homotopy_category V (complex_shape.up ℤ)) :=
category_theory.quotient.lift _ (shift_functor _ n ⋙ homotopy_category.quotient _ _)
begin
  rintros X Y f g ⟨h⟩,
  apply homotopy_category.eq_of_homotopy,
  exact homotopy_shift h n,
end

def homotopy_category.shift_ε :
  𝟭 _ ≅ homotopy_category.shift_functor V 0 :=
begin
  refine nat_iso.of_components _ _,
  { rintro ⟨X⟩,
    refine (homotopy_category.quotient _ _).map_iso (hom.iso_of_components _ _),
    exact (λ i, X.X_eq_to_iso (add_zero _).symm),
    { introv, dsimp, simp } },
  { rintro ⟨X⟩ ⟨Y⟩ f, dsimp,
    rw ← homotopy_category.quotient_map_out f,
    erw quotient.lift_map_functor_map,
    simp only [functor.comp_map, ← functor.map_comp],
    congr' 1, ext, dsimp, simp }
end

def homotopy_category.shift_functor_add (n m : ℤ) :
  homotopy_category.shift_functor V n ⋙ homotopy_category.shift_functor V m ≅
    homotopy_category.shift_functor V (n + m) :=
begin
  refine nat_iso.of_components _ _,
  { rintro ⟨X⟩,
    refine (homotopy_category.quotient _ _).map_iso (hom.iso_of_components _ _),
    exact (λ i, X.X_eq_to_iso (by rw [add_comm n m, add_assoc])),
    { introv r, dsimp [homotopy_category.shift_functor], simp [smul_smul, mul_comm] } },
  { rintro ⟨X⟩ ⟨Y⟩ f, dsimp,
    rw ← homotopy_category.quotient_map_out f,
    erw quotient.lift_map_functor_map,
    conv_rhs { erw quotient.lift_map_functor_map },
    simp only [functor.comp_map, ← functor.map_comp],
    congr' 1, ext, dsimp, simp }
end

@[simp]
lemma homotopy_category.shift_functor_obj_as {X : cochain_complex V ℤ} (n : ℤ) :
  (homotopy_category.shift_functor V n).obj ⟨X⟩ = ⟨X⟦n⟧⟩ := rfl

@[simp]
lemma homotopy_category.shift_functor_map_quotient (n : ℤ) {X Y : cochain_complex V ℤ} (f : X ⟶ Y) :
  (homotopy_category.shift_functor V n).map ((homotopy_category.quotient V _).map f) =
  (homotopy_category.quotient V _).map (f⟦n⟧') := rfl

lemma quotient_eq_to_hom {X Y : homotopy_category V (complex_shape.up ℤ)} (h : X = Y) :
  eq_to_hom h = (homotopy_category.quotient V (complex_shape.up ℤ)).map (eq_to_hom (by rw h)) :=
by { subst h, simpa }

lemma homotopy_category.has_shift_associativity_aux :
  ∀ (m₁ m₂ m₃ : ℤ) (X : homotopy_category V (complex_shape.up ℤ)),
    (homotopy_category.shift_functor V m₃).map
          ((homotopy_category.shift_functor_add V m₁ m₂).hom.app X) ≫
        (homotopy_category.shift_functor_add V (m₁ + m₂) m₃).hom.app X ≫
          eq_to_hom (by rw add_assoc) =
      (homotopy_category.shift_functor_add V m₂ m₃).hom.app
          ((homotopy_category.shift_functor V m₁).obj X) ≫
        (homotopy_category.shift_functor_add V m₁ (m₂ + m₃)).hom.app X :=
λ m₁ m₂ m₃ ⟨X⟩, by { dsimp [homotopy_category.shift_functor_add],
  rw quotient_eq_to_hom, simp only [← functor.map_comp], congr' 1, ext, simp [X_eq_to_iso] }

lemma homotopy_category.has_shift_left_unitality_aux :
  ∀ (n : ℤ) (X : homotopy_category V (complex_shape.up ℤ)),
    (homotopy_category.shift_functor V n).map
          ((homotopy_category.shift_ε V).hom.app X) ≫
        (homotopy_category.shift_functor_add V 0 n).hom.app X =
      eq_to_hom (by { dsimp, rw zero_add }) :=
λ n ⟨X⟩, by { dsimp [homotopy_category.shift_ε,
  homotopy_category.shift_functor_add], rw quotient_eq_to_hom, simp only [← functor.map_comp],
  congr' 1, ext, simp [X_eq_to_iso] }

lemma homotopy_category.has_shift_right_unitality_aux :
  ∀ (n : ℤ) (X : homotopy_category V (complex_shape.up ℤ)),
    (homotopy_category.shift_ε V).hom.app
          ((homotopy_category.shift_functor V n).obj X) ≫
        (homotopy_category.shift_functor_add V n 0).hom.app X =
      eq_to_hom (by { dsimp, rw add_zero }) :=
λ n ⟨X⟩, by { dsimp [homotopy_category.shift_ε,
  homotopy_category.shift_functor_add], rw quotient_eq_to_hom, simp only [← functor.map_comp],
  congr' 1, ext, simp [X_eq_to_iso] }

instance homotopy_category.has_shift : has_shift (homotopy_category V (complex_shape.up ℤ)) ℤ :=
has_shift_mk _ _
{ F := homotopy_category.shift_functor V,
  ε := homotopy_category.shift_ε V,
  μ := homotopy_category.shift_functor_add V,
  associativity := by simpa using homotopy_category.has_shift_associativity_aux _,
  left_unitality := by simpa using homotopy_category.has_shift_left_unitality_aux _,
  right_unitality := by simpa using homotopy_category.has_shift_right_unitality_aux _ }

@[simp] lemma homotopy_category.quotient_obj_shift (X : cochain_complex V ℤ) (n : ℤ) :
  ((homotopy_category.quotient V _).obj X)⟦n⟧ = ⟨X⟦n⟧⟩ := rfl

@[simp] lemma homotopy_category.shift_as (X : homotopy_category V (complex_shape.up ℤ)) (n : ℤ) :
  (X⟦n⟧).as = X.as⟦n⟧ := rfl

@[simp] lemma homotopy_category.quotient_map_shift {X Y : cochain_complex V ℤ} (f : X ⟶ Y) (n : ℤ) :
  ((homotopy_category.quotient V _).map f)⟦n⟧' = (homotopy_category.quotient V _).map (f⟦n⟧') := rfl

@[simp] lemma shift_ε_app (X : cochain_complex V ℤ) :
  (shift_monoidal_functor _ ℤ).ε.app ((homotopy_category.quotient _ _).obj X) =
    (homotopy_category.quotient _ _).map ((shift_monoidal_functor _ ℤ).ε.app X) := rfl

@[simp]
lemma shift_ε_inv_app (X : cochain_complex V ℤ) :
  (shift_monoidal_functor _ ℤ).ε_iso.inv.app ((homotopy_category.quotient _ _).obj X) =
    (homotopy_category.quotient _ _).map ((shift_monoidal_functor _ ℤ).ε_iso.inv.app X) :=
begin
  rw [← cancel_mono ((shift_monoidal_functor _ ℤ).ε.app ((homotopy_category.quotient _ _).obj X)),
    ε_inv_hom_app, shift_ε_app, ← functor.map_comp, ε_inv_hom_app],
  refl
end

@[simp] lemma shift_μ_app (i j : ℤ) (X : cochain_complex V ℤ) :
  ((shift_monoidal_functor _ ℤ).μ ⟨i⟩ ⟨j⟩).app ((homotopy_category.quotient _ _).obj X) =
    (homotopy_category.quotient _ _).map (((shift_monoidal_functor _ ℤ).μ ⟨i⟩ ⟨j⟩).app X) := rfl

@[simp]
lemma shift_μ_inv_app (i j : ℤ) (X : cochain_complex V ℤ) :
  ((shift_monoidal_functor _ ℤ).μ_iso ⟨i⟩ ⟨j⟩).inv.app ((homotopy_category.quotient _ _).obj X) =
    (homotopy_category.quotient _ _).map (((shift_monoidal_functor _ ℤ).μ_iso ⟨i⟩ ⟨j⟩).inv.app X) :=
begin
  rw [← cancel_mono (((shift_monoidal_functor _ ℤ).μ ⟨i⟩ ⟨j⟩).app
      ((homotopy_category.quotient _ _).obj X)),
    μ_inv_hom_app, shift_μ_app, ← functor.map_comp, μ_inv_hom_app],
  refl
end
local attribute [reducible] discrete.add_monoidal

@[simp] lemma shift_μ_hom_app_f (A : cochain_complex V ℤ) (i j k : ℤ) :
  hom.f (((shift_monoidal_functor _ ℤ).μ ⟨i⟩ ⟨j⟩).app A) k =
    (A.X_eq_to_iso $ by { dsimp, ring }).hom := rfl

@[simp] lemma shift_μ_inv_app_f (A : cochain_complex V ℤ) (i j k : ℤ) :
  hom.f (((shift_monoidal_functor _ ℤ).μ_iso ⟨i⟩ ⟨j⟩).inv.app A) k =
    (A.X_eq_to_iso $ by { dsimp, ring }).hom :=
begin
  generalize_proofs h,
  rw ← cancel_epi (A.X_eq_to_iso h.symm).hom,
  conv_lhs { rw [← shift_μ_hom_app_f, ← comp_f] },
  simpa [-comp_f]
end

@[simp] lemma shift_ε_hom_app_f (A : cochain_complex V ℤ) (i : ℤ) :
  hom.f ((shift_monoidal_functor _ ℤ).ε.app A) i = (A.X_eq_to_iso $ by { dsimp, ring }).hom :=
rfl

@[simp]
lemma shift_ε_inv_app_f (A : cochain_complex V ℤ) (i : ℤ) :
  hom.f ((shift_monoidal_functor _ ℤ).ε_iso.inv.app A) i =
    (A.X_eq_to_iso $ by { dsimp, ring }).hom :=
begin
  haveI : epi (hom.f ((shift_monoidal_functor _ ℤ).ε.app A) i),
  { rw shift_ε_hom_app_f, apply_instance },
  rw [← cancel_epi (hom.f ((shift_monoidal_functor _ ℤ).ε.app A) i), ← comp_f,
    category_theory.ε_hom_inv_app, homological_complex.id_f],
  dsimp, simpa
end

open category_theory.abelian
variables {A : Type u} [category.{v} A] [abelian A]

noncomputable
def homology_shift_obj_iso (X : cochain_complex A ℤ) (i j : ℤ) :
  (homology_functor _ _ j).obj (X⟦i⟧) ≅ (homology_functor _ _ (j + i)).obj X :=
begin
  refine homology_iso _ (j-1) j (j+1) _ _ ≪≫ _ ≪≫
    (homology_iso _ (j - 1 + i) (j+i) (j+1+i) _ _).symm,
  { simp },
  { simp },
  { exact homology.map_iso _ _
      (int.neg_one_pow_arrow_iso_left _ _).symm (int.neg_one_pow_arrow_iso_right _ _).symm rfl },
  { dsimp, abel },
  { dsimp, abel },
end

@[simp, reassoc]
lemma homology.π'_ι {X Y Z : A} (f : X ⟶ Y) (g : Y ⟶ Z) (w : f ≫ g = 0) :
  homology.π' f g w ≫ homology.ι f g w = kernel.ι g ≫ cokernel.π f :=
by { delta homology.π' homology.ι homology_iso_kernel_desc, simp }

@[simp, reassoc]
lemma homology.desc'_ι {X X' Y Z Z' : A} (f : X ⟶ Y) (g : Y ⟶ Z) (w : f ≫ g = 0)
  (f' : X' ⟶ Y) (g' : Y ⟶ Z') (w' : f' ≫ g' = 0) (h₁) (h₂) (h₃) :
  homology.desc' _ _ w (kernel.lift _ (kernel.ι _) h₁ ≫ homology.π' _ _ _) h₂ ≫
  homology.ι _ _ w' = homology.ι _ _ _ ≫ cokernel.desc _ (cokernel.π _) h₃ :=
by { ext, simp, }

@[simp, reassoc]
lemma homology.π'_lift {X X' Y Z Z' : A} (f : X ⟶ Y) (g : Y ⟶ Z) (w : f ≫ g = 0)
  (f' : X' ⟶ Y) (g' : Y ⟶ Z') (w' : f' ≫ g' = 0) (h₁) (h₂) (h₃) :
  homology.π' _ _ w ≫ homology.lift _ _ w' (homology.ι _ _ _ ≫
    cokernel.desc _ (cokernel.π _) h₁) h₂ =
  kernel.lift _ (kernel.ι _) h₃ ≫ homology.π' _ _ _ :=
by { ext, simp }

variable (A)

@[simp]
lemma shift_functor_eq (V : Type*) [category V] [preadditive V] (i) :
  homological_complex.shift_functor V i = category_theory.shift_functor _ i := rfl

noncomputable
def homology_shift_iso (i j : ℤ) :
  shift_functor _ i ⋙ homology_functor A (complex_shape.up ℤ) j ≅
    homology_functor A (complex_shape.up ℤ) (j + i) :=
nat_iso.of_components (λ X, homology_shift_obj_iso X i j : _)
begin
  intros X Y f,
  ext,
  dsimp [homology_shift_obj_iso, homology_iso, homology.map_iso],
  simp,
end

end homological_complex


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

Proof that the memoization part of stochastic backpropagation is correct.
-/
import .graph .estimators .predicates .compute_grad

namespace certigrad
namespace theorems
open list

lemma step_congr (costs : list ID) (callback₁ callback₂ : list node → Π (tgt : reference), T tgt.2)
                 (nodes : list node) (m : env) (tgt : reference) :
   ∀ (n : node)
    (H_callback_tgt : callback₁ nodes tgt = callback₂ nodes tgt)
    (H_callback_node : callback₁ nodes n^.ref = callback₂ nodes n^.ref),
    compute_grad_step costs callback₁ (n::nodes) m tgt = compute_grad_step costs callback₂ (n::nodes) m tgt
| ⟨ref, parents, operator.det op⟩ :=
assume H_callback_tgt H_callback_node,
begin dunfold compute_grad_step, rw [H_callback_tgt, H_callback_node] end

| ⟨ref, parents, operator.rand op⟩ :=
assume H_callback_tgt H_callback_node,
begin dunfold compute_grad_step, rw [H_callback_tgt] end

lemma step_correct {costs : list ID} {callback : list node → Π (tgt : reference), T tgt.2}
              {nodes : list node} {m : env} {tgt : reference} :
  ∀ {n : node}
    (H_callback_tgt : callback nodes tgt = compute_grad_slow costs nodes m tgt)
    (H_callback_node : callback nodes n^.ref = compute_grad_slow costs nodes m n^.ref),
    compute_grad_step costs callback (n::nodes) m tgt = compute_grad_slow costs (n::nodes) m tgt

| ⟨ref, parents, operator.det op⟩ :=
assume H_callback_tgt H_callback_node,
begin dunfold compute_grad_step compute_grad_slow, rw [sumrd_sumr, H_callback_tgt, H_callback_node] end

| ⟨ref, parents, operator.rand op⟩ :=
assume H_callback_tgt H_callback_node,
begin dunfold compute_grad_step compute_grad_slow, rw [sumrd_sumr, H_callback_tgt] end

lemma strip_foldr_base {costs : list ID} {m : env} :
      Π {tgts : list reference} {tgt₀ : reference} {idx : ℕ},
        at_idx tgts idx tgt₀ →
       nodup tgts →
env.get tgt₀
         (foldr (λ (ref : reference) (dict₀ : env),
                    (env.insert ref
                                 (compute_grad_step costs (λ (nodes' : list node) (tgt' : reference), T.error "backprop-end") [] m ref)
                                 dict₀))
                 env.mk
                 tgts)
=
compute_grad_step costs (λ (nodes : list node) (ref : reference), env.get ref env.mk) [] m tgt₀
| [] _ _ H_at_idx _ := false.rec _ (nat.not_lt_zero _ H_at_idx^.left)

| (tgt::tgts) tgt₀ 0 H_at_idx H_nodup :=
have H_eq : tgt = tgt₀, from at_idx_inj at_idx_0 H_at_idx,
begin
rw -H_eq,
dunfold foldr,
rw env.get_insert_same,
reflexivity
end

| (tgt::tgts) tgt₀ (idx+1) H_at_idx H_nodup :=
have H_neq : tgt₀ ≠ tgt, from nodup_at_idx_neq H_nodup H_at_idx,
have H_at_idx_next : at_idx tgts idx tgt₀, from at_idx_of_cons H_at_idx,
begin
dunfold foldr,
rw (env.get_insert_diff _ _ H_neq),
exact (strip_foldr_base H_at_idx_next (nodup_of_nodup_cons H_nodup)),
end

lemma strip_foldr_step {costs : list ID} {nodes : list node} {m old_dict : env} :
  Π {tgts : list reference} {tgt₀ : reference} {idx : ℕ},
    at_idx tgts idx tgt₀ →
    nodup tgts →
    env.get tgt₀
             (foldr (λ (tgt' : reference) (dict' : env),
                       (env.insert tgt'
                                    (compute_grad_step costs (λ (nodes : list node) (ref : reference), env.get ref old_dict)
                                                       nodes m tgt')
                                    dict'))
                    env.mk
                    tgts)
    =
    compute_grad_step costs (λ (nodes : list node) (tgt : reference), env.get tgt old_dict) nodes m tgt₀
| [] _ _ H_idx _ := false.rec _ (nat.not_lt_zero _ H_idx^.left)

| (tgt::tgts) tgt₀ 0 H_at_idx H_nodup :=
begin
dunfold at_idx dnth at H_at_idx,
rw H_at_idx^.right,
dunfold foldr,
rw env.get_insert_same
end

| (tgt::tgts) tgt₀ (idx+1) H_at_idx H_nodup :=
have H_neq : tgt₀ ≠ tgt, from nodup_at_idx_neq H_nodup H_at_idx,
have H_at_idx_next : at_idx tgts idx tgt₀, from at_idx_of_cons H_at_idx,
begin
dunfold foldr,
rw env.get_insert_diff _ _ H_neq,
exact (strip_foldr_step H_at_idx_next (nodup_of_nodup_cons H_nodup)),
end

lemma memoize_correct (costs : list ID) :
  ∀ (nodes : list node) (m : env) {tgts : list reference},
  ∀ {tgt₀ : reference} {idx : ℕ}, at_idx tgts idx tgt₀ →
  nodup (tgts ++ map node.ref nodes) →
  env.get tgt₀ (backprop_core costs nodes m tgts)
  =
  compute_grad_slow costs nodes m tgt₀

| _ _ [] _ _ H_at_idx _ := false.rec _ (nat.not_lt_zero _ H_at_idx^.left)

| [] m (tgt::tgts) tgt₀ idx H_at_idx H_nodup :=
have H_nodup_tgts : nodup (tgt::tgts), from nodup_of_nodup_append_left H_nodup,
begin
dunfold backprop_core backprop_core_helper compute_init_dict,
rw (strip_foldr_base H_at_idx H_nodup_tgts),
dunfold compute_grad_step,
rw sumr_sumr₁,
reflexivity,
end

| (n::nodes) m (tgt::tgts) tgt₀ idx H_at_idx H_nodup :=
have H_nodup_tgts : nodup (tgt::tgts), from nodup_of_nodup_append_left H_nodup,
have H_nodup_n : nodup ((n^.ref :: tgt :: tgts) ++ map node.ref nodes), from nodup_append_swap H_nodup,
have H_at_idx_tgt₀ : at_idx (n^.ref :: tgt :: tgts) (idx+1) tgt₀, from at_idx_cons H_at_idx,
have H_at_idx_n : at_idx (n^.ref :: tgt :: tgts) 0 n^.ref, from at_idx_0,
begin
dunfold backprop_core backprop_core_helper compute_init_dict,
rw (strip_foldr_step H_at_idx H_nodup_tgts),
dunfold compute_grad_step compute_grad_slow,
apply step_correct,
apply (memoize_correct _ _ H_at_idx_tgt₀ H_nodup_n),
apply (memoize_correct _ _ H_at_idx_n H_nodup_n)
end
end theorems
end certigrad


structure U (α : Type) where
  a : α

theorem mk_inj (w : U.mk a = U.mk b) : a = b := by
  injection w


import ReactorModel.Objects.Reactor.WellFounded

open Reactor (Component)

namespace ReactorType

variable [ReactorType α] [ReactorType β]

-- TODO: Find a better name for this.
def RootEqualUpTo (cpt : Component) (i : ID) (rtr₁ rtr₂ : α) : Prop :=
  ∀ {c j}, (c ≠ cpt ∨ j ≠ i) → cpt? c rtr₁ j = cpt? c rtr₂ j

theorem RootEqualUpTo.mem_iff {rtr₁ : α} (e : RootEqualUpTo cpt i rtr₁ rtr₂)
    (h : c ≠ cpt ∨ j ≠ i) : (j ∈ cpt? c rtr₁) ↔ (j ∈ cpt? c rtr₂) := by
  simp [Partial.mem_iff]
  exact ⟨(e h ▸ ·), (e h ▸ ·)⟩

-- Note: Without ID-uniqueness this can be satisfied by updating exactly one of the occurrences of
--       the target. Since we have a choice of which target we update, this type isn't a `Prop`.
--       (We need to be able to eliminate into `Type` in `Member.fromLawfulUpdate`).
inductive LawfulMemUpdate (cpt : Component.Valued) (i : ID) (f : cpt.type → cpt.type) : α → α → Type
  | final :
    (RootEqualUpTo cpt i rtr₁ rtr₂) → (cpt? cpt rtr₁ i = some o) → (cpt? cpt rtr₂ i = f o) →
    LawfulMemUpdate cpt i f rtr₁ rtr₂
  | nest :
    (RootEqualUpTo .rtr j rtr₁ rtr₂) → (cpt? .rtr rtr₁ j = some n₁) → (cpt? .rtr rtr₂ j = some n₂) →
    (LawfulMemUpdate cpt i f n₁ n₂) → LawfulMemUpdate cpt i f rtr₁ rtr₂

-- Note: This isn't a `Prop` because of the explanation on `LawfulMemUpdate`.
inductive LawfulUpdate (cpt : Component.Valued) (i : ID) (f : cpt.type → cpt.type) (rtr₁ rtr₂ : α)
  | update (u : LawfulMemUpdate cpt i f rtr₁ rtr₂)
  | notMem (h : IsEmpty $ Member cpt i rtr₁) (eq : rtr₁ = rtr₂)

class Updatable (α) extends ReactorType.WellFounded α where
  update : α → (cpt : Component.Valued) → ID → (cpt.type → cpt.type) → α

class LawfulUpdatable (α) extends Updatable α where
  lawful : ∀ rtr cpt i f, LawfulUpdate cpt i f rtr (update rtr cpt i f)

end ReactorType


/-
Copyright (c) 2018 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Mitchell Rowett, Scott Morrison, Johan Commelin, Mario Carneiro,
  Michael Howes
-/
import group_theory.subgroup.basic
import deprecated.submonoid

/-!
# Unbundled subgroups (deprecated)

This file is deprecated, and is no longer imported by anything in mathlib other than other
deprecated files, and test files. You should not need to import it.

This file defines unbundled multiplicative and additive subgroups. Instead of using this file,
please use `subgroup G` and `add_subgroup A`, defined in `group_theory.subgroup.basic`.

## Main definitions

`is_add_subgroup (S : set A)` : the predicate that `S` is the underlying subset of an additive
subgroup of `A`. The bundled variant `add_subgroup A` should be used in preference to this.

`is_subgroup (S : set G)` : the predicate that `S` is the underlying subset of a subgroup
of `G`. The bundled variant `subgroup G` should be used in preference to this.

## Tags

subgroup, subgroups, is_subgroup
-/
open set function

variables {G : Type*} {H : Type*} {A : Type*} {a a₁ a₂ b c: G}

section group
variables [group G] [add_group A]

/-- `s` is an additive subgroup: a set containing 0 and closed under addition and negation. -/
structure is_add_subgroup (s : set A) extends is_add_submonoid s : Prop :=
(neg_mem {a} : a ∈ s → -a ∈ s)

/-- `s` is a subgroup: a set containing 1 and closed under multiplication and inverse. -/
@[to_additive]
structure is_subgroup (s : set G) extends is_submonoid s : Prop :=
(inv_mem {a} : a ∈ s → a⁻¹ ∈ s)

@[to_additive]
lemma is_subgroup.div_mem {s : set G} (hs : is_subgroup s) {x y : G} (hx : x ∈ s) (hy : y ∈ s) :
  x / y ∈ s :=
by simpa only [div_eq_mul_inv] using hs.mul_mem hx (hs.inv_mem hy)

lemma additive.is_add_subgroup
  {s : set G} (hs : is_subgroup s) : @is_add_subgroup (additive G) _ s :=
@is_add_subgroup.mk (additive G) _ _ (additive.is_add_submonoid hs.to_is_submonoid)
  hs.inv_mem

theorem additive.is_add_subgroup_iff
  {s : set G} : @is_add_subgroup (additive G) _ s ↔ is_subgroup s :=
⟨by rintro ⟨⟨h₁, h₂⟩, h₃⟩; exact @is_subgroup.mk G _ _ ⟨h₁, @h₂⟩ @h₃,
  λ h, by exactI additive.is_add_subgroup h⟩

lemma multiplicative.is_subgroup
  {s : set A} (hs : is_add_subgroup s) : @is_subgroup (multiplicative A) _ s :=
@is_subgroup.mk (multiplicative A) _ _ (multiplicative.is_submonoid hs.to_is_add_submonoid)
  hs.neg_mem

theorem multiplicative.is_subgroup_iff
  {s : set A} : @is_subgroup (multiplicative A) _ s ↔ is_add_subgroup s :=
⟨by rintro ⟨⟨h₁, h₂⟩, h₃⟩; exact @is_add_subgroup.mk A _ _ ⟨h₁, @h₂⟩ @h₃,
  λ h, by exactI multiplicative.is_subgroup h⟩

@[to_additive of_add_neg]
theorem is_subgroup.of_div (s : set G)
  (one_mem : (1:G) ∈ s) (div_mem : ∀{a b:G}, a ∈ s → b ∈ s → a * b⁻¹ ∈ s) :
  is_subgroup s :=
have inv_mem : ∀a, a ∈ s → a⁻¹ ∈ s, from
  assume a ha,
  have 1 * a⁻¹ ∈ s, from div_mem one_mem ha,
  by simpa,
{ inv_mem := inv_mem,
  mul_mem := assume a b ha hb,
    have a * b⁻¹⁻¹ ∈ s, from div_mem ha (inv_mem b hb),
    by simpa,
  one_mem := one_mem }

theorem is_add_subgroup.of_sub (s : set A)
  (zero_mem : (0:A) ∈ s) (sub_mem : ∀{a b:A}, a ∈ s → b ∈ s → a - b ∈ s) :
  is_add_subgroup s :=
is_add_subgroup.of_add_neg s zero_mem
  (λ x y hx hy, by simpa only [sub_eq_add_neg] using sub_mem hx hy)

@[to_additive]
lemma is_subgroup.inter {s₁ s₂ : set G} (hs₁ : is_subgroup s₁) (hs₂ : is_subgroup s₂) :
  is_subgroup (s₁ ∩ s₂) :=
{ inv_mem := λ x hx, ⟨hs₁.inv_mem hx.1, hs₂.inv_mem hx.2⟩,
  ..is_submonoid.inter hs₁.to_is_submonoid hs₂.to_is_submonoid}

@[to_additive]
lemma is_subgroup.Inter {ι : Sort*} {s : ι → set G} (hs : ∀ y : ι, is_subgroup (s y)) :
  is_subgroup (set.Inter s) :=
{ inv_mem := λ x h, set.mem_Inter.2 $ λ y, is_subgroup.inv_mem (hs _) (set.mem_Inter.1 h y),
  ..is_submonoid.Inter (λ y, (hs y).to_is_submonoid) }

@[to_additive]
lemma is_subgroup_Union_of_directed {ι : Type*} [hι : nonempty ι]
  {s : ι → set G} (hs : ∀ i, is_subgroup (s i))
  (directed : ∀ i j, ∃ k, s i ⊆ s k ∧ s j ⊆ s k) :
  is_subgroup (⋃i, s i) :=
{ inv_mem := λ a ha,
    let ⟨i, hi⟩ := set.mem_Union.1 ha in
    set.mem_Union.2 ⟨i, (hs i).inv_mem hi⟩,
  to_is_submonoid := is_submonoid_Union_of_directed (λ i, (hs i).to_is_submonoid) directed }

end group

namespace is_subgroup
open is_submonoid
variables [group G] {s : set G} (hs : is_subgroup s)

include hs

@[to_additive]
lemma inv_mem_iff : a⁻¹ ∈ s ↔ a ∈ s :=
⟨λ h, by simpa using hs.inv_mem h, inv_mem hs⟩

@[to_additive]
lemma mul_mem_cancel_right (h : a ∈ s) : b * a ∈ s ↔ b ∈ s :=
⟨λ hba, by simpa using hs.mul_mem hba (hs.inv_mem h), λ hb, hs.mul_mem hb h⟩

@[to_additive]
lemma mul_mem_cancel_left (h : a ∈ s) : a * b ∈ s ↔ b ∈ s :=
⟨λ hab, by simpa using hs.mul_mem (hs.inv_mem h) hab, hs.mul_mem h⟩

end is_subgroup

/-- `is_normal_add_subgroup (s : set A)` expresses the fact that `s` is a normal additive subgroup
of the additive group `A`. Important: the preferred way to say this in Lean is via bundled
subgroups `S : add_subgroup A` and `hs : S.normal`, and not via this structure. -/
structure is_normal_add_subgroup [add_group A] (s : set A) extends is_add_subgroup s : Prop :=
(normal : ∀ n ∈ s, ∀ g : A, g + n + -g ∈ s)

/-- `is_normal_subgroup (s : set G)` expresses the fact that `s` is a normal subgroup
of the group `G`. Important: the preferred way to say this in Lean is via bundled
subgroups `S : subgroup G` and not via this structure. -/
@[to_additive]
structure is_normal_subgroup [group G] (s : set G) extends is_subgroup s : Prop :=
(normal : ∀ n ∈ s, ∀ g : G, g * n * g⁻¹ ∈ s)

@[to_additive]
lemma is_normal_subgroup_of_comm_group [comm_group G] {s : set G} (hs : is_subgroup s) :
  is_normal_subgroup s :=
{ normal := λ n hn g, by rwa [mul_right_comm, mul_right_inv, one_mul],
  ..hs }

lemma additive.is_normal_add_subgroup [group G]
  {s : set G} (hs : is_normal_subgroup s) : @is_normal_add_subgroup (additive G) _ s :=
@is_normal_add_subgroup.mk (additive G) _ _
  (additive.is_add_subgroup hs.to_is_subgroup)
  (is_normal_subgroup.normal hs)

theorem additive.is_normal_add_subgroup_iff [group G]
  {s : set G} : @is_normal_add_subgroup (additive G) _ s ↔ is_normal_subgroup s :=
⟨by rintro ⟨h₁, h₂⟩; exact
    @is_normal_subgroup.mk G _ _ (additive.is_add_subgroup_iff.1 h₁) @h₂,
  λ h, by exactI additive.is_normal_add_subgroup h⟩

lemma multiplicative.is_normal_subgroup [add_group A]
  {s : set A} (hs : is_normal_add_subgroup s) : @is_normal_subgroup (multiplicative A) _ s :=
@is_normal_subgroup.mk (multiplicative A) _ _
  (multiplicative.is_subgroup hs.to_is_add_subgroup)
  (is_normal_add_subgroup.normal hs)

theorem multiplicative.is_normal_subgroup_iff [add_group A]
  {s : set A} : @is_normal_subgroup (multiplicative A) _ s ↔ is_normal_add_subgroup s :=
⟨by rintro ⟨h₁, h₂⟩; exact
    @is_normal_add_subgroup.mk A _ _ (multiplicative.is_subgroup_iff.1 h₁) @h₂,
  λ h, by exactI multiplicative.is_normal_subgroup h⟩

namespace is_subgroup
variable [group G]

-- Normal subgroup properties
@[to_additive]
lemma mem_norm_comm {s : set G} (hs : is_normal_subgroup s) {a b : G} (hab : a * b ∈ s) :
  b * a ∈ s :=
have h : a⁻¹ * (a * b) * a⁻¹⁻¹ ∈ s, from hs.normal (a * b) hab a⁻¹,
by simp at h; exact h

@[to_additive]
lemma mem_norm_comm_iff {s : set G} (hs : is_normal_subgroup s) {a b : G} : a * b ∈ s ↔ b * a ∈ s :=
⟨mem_norm_comm hs, mem_norm_comm hs⟩

/-- The trivial subgroup -/
@[to_additive "the trivial additive subgroup"]
def trivial (G : Type*) [group G] : set G := {1}

@[simp, to_additive]
lemma mem_trivial {g : G} : g ∈ trivial G ↔ g = 1 :=
mem_singleton_iff

@[to_additive]
lemma trivial_normal : is_normal_subgroup (trivial G) :=
by refine {..}; simp [trivial] {contextual := tt}

@[to_additive]
lemma eq_trivial_iff {s : set G} (hs : is_subgroup s) :
  s = trivial G ↔ (∀ x ∈ s, x = (1 : G)) :=
by simp only [set.ext_iff, is_subgroup.mem_trivial];
  exact ⟨λ h x, (h x).1, λ h x, ⟨h x, λ hx, hx.symm ▸ hs.to_is_submonoid.one_mem⟩⟩

@[to_additive]
lemma univ_subgroup : is_normal_subgroup (@univ G) :=
by refine {..}; simp

/-- The underlying set of the center of a group. -/
@[to_additive add_center "The underlying set of the center of an additive group."]
def center (G : Type*) [group G] : set G := {z | ∀ g, g * z = z * g}

@[to_additive mem_add_center]
lemma mem_center {a : G} : a ∈ center G ↔ ∀g, g * a = a * g := iff.rfl

@[to_additive add_center_normal]
lemma center_normal : is_normal_subgroup (center G) :=
{ one_mem := by simp [center],
  mul_mem := assume a b ha hb g,
    by rw [←mul_assoc, mem_center.2 ha g, mul_assoc, mem_center.2 hb g, ←mul_assoc],
  inv_mem := assume a ha g,
    calc
      g * a⁻¹ = a⁻¹ * (g * a) * a⁻¹ : by simp [ha g]
      ...     = a⁻¹ * g             : by rw [←mul_assoc, mul_assoc]; simp,
  normal := assume n ha g h,
    calc
      h * (g * n * g⁻¹) = h * n           : by simp [ha g, mul_assoc]
      ...               = g * g⁻¹ * n * h : by rw ha h; simp
      ...               = g * n * g⁻¹ * h : by rw [mul_assoc g, ha g⁻¹, ←mul_assoc] }

/-- The underlying set of the normalizer of a subset `S : set G` of a group `G`. That is,
  the elements `g : G` such that `g * S * g⁻¹ = S`. -/
@[to_additive add_normalizer "The underlying set of the normalizer of a subset `S : set A` of an
  additive group `A`. That is, the elements `a : A` such that `a + S - a = S`."]
def normalizer (s : set G) : set G :=
{g : G | ∀ n, n ∈ s ↔ g * n * g⁻¹ ∈ s}

@[to_additive]
lemma normalizer_is_subgroup (s : set G) : is_subgroup (normalizer s) :=
{ one_mem := by simp [normalizer],
  mul_mem := λ a b (ha : ∀ n, n ∈ s ↔ a * n * a⁻¹ ∈ s)
    (hb : ∀ n, n ∈ s ↔ b * n * b⁻¹ ∈ s) n,
    by rw [mul_inv_rev, ← mul_assoc, mul_assoc a, mul_assoc a, ← ha, ← hb],
  inv_mem := λ a (ha : ∀ n, n ∈ s ↔ a * n * a⁻¹ ∈ s) n,
    by rw [ha (a⁻¹ * n * a⁻¹⁻¹)];
    simp [mul_assoc] }

@[to_additive subset_add_normalizer]
lemma subset_normalizer {s : set G} (hs : is_subgroup s) : s ⊆ normalizer s :=
λ g hg n, by rw [is_subgroup.mul_mem_cancel_right hs ((is_subgroup.inv_mem_iff hs).2 hg),
  is_subgroup.mul_mem_cancel_left hs hg]

end is_subgroup

-- Homomorphism subgroups
namespace is_group_hom
open is_submonoid is_subgroup

/-- `ker f : set G` is the underlying subset of the kernel of a map `G → H`. -/
@[to_additive "`ker f : set A` is the underlying subset of the kernel of a map `A → B`"]
def ker [group H] (f : G → H) : set G := preimage f (trivial H)

@[to_additive]
lemma mem_ker [group H] (f : G → H) {x : G} : x ∈ ker f ↔ f x = 1 :=
mem_trivial

variables [group G] [group H]

@[to_additive]
lemma one_ker_inv {f : G → H} (hf : is_group_hom f) {a b : G} (h : f (a * b⁻¹) = 1) : f a = f b :=
begin
  rw [hf.map_mul, hf.map_inv] at h,
  rw [←inv_inv (f b), eq_inv_of_mul_eq_one_left h]
end

@[to_additive]
lemma one_ker_inv' {f : G → H} (hf : is_group_hom f) {a b : G} (h : f (a⁻¹ * b) = 1) : f a = f b :=
begin
  rw [hf.map_mul, hf.map_inv] at h,
  apply inv_injective,
  rw eq_inv_of_mul_eq_one_left h
end

@[to_additive]
lemma inv_ker_one {f : G → H} (hf : is_group_hom f) {a b : G} (h : f a = f b) : f (a * b⁻¹) = 1 :=
have f a * (f b)⁻¹ = 1, by rw [h, mul_right_inv],
by rwa [←hf.map_inv, ←hf.map_mul] at this

@[to_additive]
lemma inv_ker_one' {f : G → H} (hf : is_group_hom f) {a b : G} (h : f a = f b) : f (a⁻¹ * b) = 1 :=
have (f a)⁻¹ * f b = 1, by rw [h, mul_left_inv],
by rwa [←hf.map_inv, ←hf.map_mul] at this

@[to_additive]
lemma one_iff_ker_inv {f : G → H} (hf : is_group_hom f) (a b : G) : f a = f b ↔ f (a * b⁻¹) = 1 :=
⟨hf.inv_ker_one, hf.one_ker_inv⟩

@[to_additive]
lemma one_iff_ker_inv' {f : G → H} (hf : is_group_hom f) (a b : G) : f a = f b ↔ f (a⁻¹ * b) = 1 :=
⟨hf.inv_ker_one', hf.one_ker_inv'⟩

@[to_additive]
lemma inv_iff_ker {f : G → H} (hf : is_group_hom f) (a b : G) : f a = f b ↔ a * b⁻¹ ∈ ker f :=
by rw [mem_ker]; exact one_iff_ker_inv hf _ _

@[to_additive]
lemma inv_iff_ker' {f : G → H} (hf : is_group_hom f) (a b : G) : f a = f b ↔ a⁻¹ * b ∈ ker f :=
by rw [mem_ker]; exact one_iff_ker_inv' hf _ _

@[to_additive]
lemma image_subgroup {f : G → H} (hf : is_group_hom f) {s : set G} (hs : is_subgroup s) :
  is_subgroup (f '' s) :=
{ mul_mem := assume a₁ a₂ ⟨b₁, hb₁, eq₁⟩ ⟨b₂, hb₂, eq₂⟩,
             ⟨b₁ * b₂, hs.mul_mem hb₁ hb₂, by simp [eq₁, eq₂, hf.map_mul]⟩,
  one_mem := ⟨1, hs.to_is_submonoid.one_mem, hf.map_one⟩,
  inv_mem := assume a ⟨b, hb, eq⟩, ⟨b⁻¹, hs.inv_mem hb, by { rw hf.map_inv, simp * }⟩ }

@[to_additive]
lemma range_subgroup {f : G → H} (hf : is_group_hom f) : is_subgroup (set.range f) :=
@set.image_univ _ _ f ▸ hf.image_subgroup univ_subgroup.to_is_subgroup

local attribute [simp] one_mem inv_mem mul_mem is_normal_subgroup.normal

@[to_additive]
lemma preimage {f : G → H} (hf : is_group_hom f) {s : set H} (hs : is_subgroup s) :
  is_subgroup (f ⁻¹' s) :=
by { refine {..};
     simp [hs.one_mem, hs.mul_mem, hs.inv_mem, hf.map_mul, hf.map_one, hf.map_inv,
           inv_mem_class.inv_mem]
     {contextual := tt} }

@[to_additive]
lemma preimage_normal {f : G → H} (hf : is_group_hom f) {s : set H} (hs : is_normal_subgroup s) :
  is_normal_subgroup (f ⁻¹' s) :=
{ one_mem := by simp [hf.map_one, hs.to_is_subgroup.one_mem],
  mul_mem := by simp [hf.map_mul, hs.to_is_subgroup.mul_mem] {contextual := tt},
  inv_mem := by simp [hf.map_inv, hs.to_is_subgroup.inv_mem] {contextual := tt},
  normal := by simp [hs.normal, hf.map_mul, hf.map_inv] {contextual := tt}}

@[to_additive]
lemma is_normal_subgroup_ker {f : G → H} (hf : is_group_hom f) : is_normal_subgroup (ker f) :=
hf.preimage_normal (trivial_normal)

@[to_additive]
lemma injective_of_trivial_ker {f : G → H} (hf : is_group_hom f) (h : ker f = trivial G) :
  function.injective f :=
begin
  intros a₁ a₂ hfa,
  simp [ext_iff, ker, is_subgroup.trivial] at h,
  have ha : a₁ * a₂⁻¹ = 1, by rw ←h; exact hf.inv_ker_one hfa,
  rw [eq_inv_of_mul_eq_one_left ha, inv_inv a₂]
end

@[to_additive]
lemma trivial_ker_of_injective {f : G → H} (hf : is_group_hom f) (h : function.injective f) :
  ker f = trivial G :=
set.ext $ assume x, iff.intro
  (assume hx,
    suffices f x = f 1, by simpa using h this,
    by simp [hf.map_one]; rwa [mem_ker] at hx)
  (by simp [mem_ker, hf.map_one] {contextual := tt})

@[to_additive]
lemma injective_iff_trivial_ker {f : G → H} (hf : is_group_hom f) :
  function.injective f ↔ ker f = trivial G :=
⟨hf.trivial_ker_of_injective, hf.injective_of_trivial_ker⟩

@[to_additive]
lemma trivial_ker_iff_eq_one {f : G → H} (hf : is_group_hom f) :
  ker f = trivial G ↔ ∀ x, f x = 1 → x = 1 :=
by rw set.ext_iff; simp [ker]; exact
⟨λ h x hx, (h x).1 hx, λ h x, ⟨h x, λ hx, by rw [hx, hf.map_one]⟩⟩

end is_group_hom

namespace add_group

variables [add_group A]

/-- If `A` is an additive group and `s : set A`, then `in_closure s : set A` is the underlying
subset of the subgroup generated by `s`. -/
inductive in_closure (s : set A) : A → Prop
| basic {a : A} : a ∈ s → in_closure a
| zero : in_closure 0
| neg {a : A} : in_closure a → in_closure (-a)
| add {a b : A} : in_closure a → in_closure b → in_closure (a + b)

end add_group

namespace group
open is_submonoid is_subgroup

variables [group G] {s : set G}

/-- If `G` is a group and `s : set G`, then `in_closure s : set G` is the underlying
subset of the subgroup generated by `s`. -/
@[to_additive]
inductive in_closure (s : set G) : G → Prop
| basic {a : G} : a ∈ s → in_closure a
| one : in_closure 1
| inv {a : G} : in_closure a → in_closure a⁻¹
| mul {a b : G} : in_closure a → in_closure b → in_closure (a * b)

/-- `group.closure s` is the subgroup generated by `s`, i.e. the smallest subgroup containg `s`. -/
@[to_additive "`add_group.closure s` is the additive subgroup generated by `s`, i.e., the
  smallest additive subgroup containing `s`."]
def closure (s : set G) : set G := {a | in_closure s a }

@[to_additive]
lemma mem_closure {a : G} : a ∈ s → a ∈ closure s := in_closure.basic

@[to_additive]
lemma closure.is_subgroup (s : set G) : is_subgroup (closure s) :=
{ one_mem := in_closure.one,
  mul_mem := assume a b, in_closure.mul,
  inv_mem := assume a, in_closure.inv }

@[to_additive]
theorem subset_closure {s : set G} : s ⊆ closure s := λ a, mem_closure

@[to_additive]
theorem closure_subset {s t : set G} (ht : is_subgroup t) (h : s ⊆ t) : closure s ⊆ t :=
assume a ha, by induction ha; simp [h _, *, ht.one_mem, ht.mul_mem, is_subgroup.inv_mem_iff]

@[to_additive]
lemma closure_subset_iff {s t : set G} (ht : is_subgroup t) : closure s ⊆ t ↔ s ⊆ t :=
⟨assume h b ha, h (mem_closure ha), assume h b ha, closure_subset ht h ha⟩

@[to_additive]
theorem closure_mono {s t : set G} (h : s ⊆ t) : closure s ⊆ closure t :=
closure_subset (closure.is_subgroup _) $ set.subset.trans h subset_closure

@[simp, to_additive]
lemma closure_subgroup {s : set G} (hs : is_subgroup s) : closure s = s :=
set.subset.antisymm (closure_subset hs $ set.subset.refl s) subset_closure

@[to_additive]

@[to_additive]
lemma image_closure [group H] {f : G → H} (hf : is_group_hom f) (s : set G) :
  f '' closure s = closure (f '' s) :=
le_antisymm
  begin
    rintros _ ⟨x, hx, rfl⟩,
    apply in_closure.rec_on hx; intros,
    { solve_by_elim [subset_closure, set.mem_image_of_mem] },
    { rw [hf.to_is_monoid_hom.map_one],
      apply is_submonoid.one_mem (closure.is_subgroup _).to_is_submonoid, },
    { rw [hf.map_inv],
      apply is_subgroup.inv_mem (closure.is_subgroup _), assumption },
    { rw [hf.to_is_monoid_hom.map_mul],
      solve_by_elim [is_submonoid.mul_mem (closure.is_subgroup _).to_is_submonoid] }
  end
  (closure_subset (hf.image_subgroup $ closure.is_subgroup _) $ set.image_subset _ subset_closure)

@[to_additive]
theorem mclosure_subset {s : set G} : monoid.closure s ⊆ closure s :=
monoid.closure_subset (closure.is_subgroup _).to_is_submonoid $ subset_closure

@[to_additive]
theorem mclosure_inv_subset {s : set G} : monoid.closure (has_inv.inv ⁻¹' s) ⊆ closure s :=
monoid.closure_subset (closure.is_subgroup _).to_is_submonoid $ λ x hx,
  inv_inv x ▸ ((closure.is_subgroup _).inv_mem $ subset_closure hx)

@[to_additive]
theorem closure_eq_mclosure {s : set G} : closure s = monoid.closure (s ∪ has_inv.inv ⁻¹' s) :=
set.subset.antisymm
  (@closure_subset _ _ _ (monoid.closure (s ∪ has_inv.inv ⁻¹' s))
    { one_mem := (monoid.closure.is_submonoid _).one_mem,
      mul_mem := (monoid.closure.is_submonoid _).mul_mem,
      inv_mem := λ x hx, monoid.in_closure.rec_on hx
      (λ x hx, or.cases_on hx (λ hx, monoid.subset_closure $ or.inr $
        show x⁻¹⁻¹ ∈ s, from (inv_inv x).symm ▸ hx)
        (λ hx, monoid.subset_closure $ or.inl hx))
      ((@inv_one G _).symm ▸ is_submonoid.one_mem (monoid.closure.is_submonoid _))
      (λ x y hx hy ihx ihy,
        (mul_inv_rev x y).symm ▸ is_submonoid.mul_mem (monoid.closure.is_submonoid _) ihy ihx) }
    (set.subset.trans (set.subset_union_left _ _) monoid.subset_closure))
  (monoid.closure_subset (closure.is_subgroup _).to_is_submonoid $ set.union_subset subset_closure $
    λ x hx, inv_inv x ▸ (is_subgroup.inv_mem (closure.is_subgroup _) $ subset_closure hx))

@[to_additive]
theorem mem_closure_union_iff {G : Type*} [comm_group G] {s t : set G} {x : G} :
  x ∈ closure (s ∪ t) ↔ ∃ y ∈ closure s, ∃ z ∈ closure t, y * z = x :=
begin
  simp only [closure_eq_mclosure, monoid.mem_closure_union_iff, exists_prop, preimage_union], split,
  { rintro ⟨_, ⟨ys, hys, yt, hyt, rfl⟩, _, ⟨zs, hzs, zt, hzt, rfl⟩, rfl⟩,
    refine ⟨_, ⟨_, hys, _, hzs, rfl⟩, _, ⟨_, hyt, _, hzt, rfl⟩, _⟩,
    rw [mul_assoc, mul_assoc, mul_left_comm zs] },
  { rintro ⟨_, ⟨ys, hys, zs, hzs, rfl⟩, _, ⟨yt, hyt, zt, hzt, rfl⟩, rfl⟩,
    refine ⟨_, ⟨ys, hys, yt, hyt, rfl⟩, _, ⟨zs, hzs, zt, hzt, rfl⟩, _⟩,
    rw [mul_assoc, mul_assoc, mul_left_comm yt] }
end

end group

namespace is_subgroup
variable [group G]

@[to_additive]
lemma trivial_eq_closure : trivial G = group.closure ∅ :=
subset.antisymm
  (by simp [set.subset_def, (group.closure.is_subgroup _).one_mem])
  (group.closure_subset (trivial_normal).to_is_subgroup $ by simp)

end is_subgroup

/-The normal closure of a set s is the subgroup closure of all the conjugates of
elements of s. It is the smallest normal subgroup containing s. -/

namespace group
variables {s : set G} [group G]

lemma conjugates_of_subset {t : set G} (ht : is_normal_subgroup t) {a : G} (h : a ∈ t) :
  conjugates_of a ⊆ t :=
λ x hc,
begin
  obtain ⟨c, w⟩ := is_conj_iff.1 hc,
  have H := is_normal_subgroup.normal ht a h c,
  rwa ←w,
end

theorem conjugates_of_set_subset' {s t : set G} (ht : is_normal_subgroup t) (h : s ⊆ t) :
  conjugates_of_set s ⊆ t :=
set.Union₂_subset (λ x H, conjugates_of_subset ht (h H))

/-- The normal closure of a set s is the subgroup closure of all the conjugates of
elements of s. It is the smallest normal subgroup containing s. -/
def normal_closure (s : set G) : set G := closure (conjugates_of_set s)

theorem conjugates_of_set_subset_normal_closure : conjugates_of_set s ⊆ normal_closure s :=
subset_closure

theorem subset_normal_closure : s ⊆ normal_closure s :=
set.subset.trans subset_conjugates_of_set conjugates_of_set_subset_normal_closure

/-- The normal closure of a set is a subgroup. -/
lemma normal_closure.is_subgroup (s : set G) : is_subgroup (normal_closure s) :=
closure.is_subgroup (conjugates_of_set s)

/-- The normal closure of s is a normal subgroup. -/
lemma normal_closure.is_normal : is_normal_subgroup (normal_closure s) :=
{ normal := λ n h g,
begin
  induction h with x hx x hx ihx x y hx hy ihx ihy,
  {exact (conjugates_of_set_subset_normal_closure (conj_mem_conjugates_of_set hx))},
  {simpa using (normal_closure.is_subgroup s).one_mem},
  {rw ←conj_inv,
   exact ((normal_closure.is_subgroup _).inv_mem ihx)},
  {rw ←conj_mul,
   exact ((normal_closure.is_subgroup _).to_is_submonoid.mul_mem ihx ihy)},
end,
..normal_closure.is_subgroup _ }

/-- The normal closure of s is the smallest normal subgroup containing s. -/
theorem normal_closure_subset {s t : set G} (ht : is_normal_subgroup t) (h : s ⊆ t) :
  normal_closure s ⊆ t :=
λ a w,
begin
  induction w with x hx x hx ihx x y hx hy ihx ihy,
  {exact (conjugates_of_set_subset' ht h $ hx)},
  {exact ht.to_is_subgroup.to_is_submonoid.one_mem},
  {exact ht.to_is_subgroup.inv_mem ihx},
  {exact ht.to_is_subgroup.to_is_submonoid.mul_mem ihx ihy}
end

lemma normal_closure_subset_iff {s t : set G} (ht : is_normal_subgroup t) :
  s ⊆ t ↔ normal_closure s ⊆ t :=
⟨normal_closure_subset ht, set.subset.trans (subset_normal_closure)⟩

theorem normal_closure_mono {s t : set G} : s ⊆ t → normal_closure s ⊆ normal_closure t :=
λ h, normal_closure_subset normal_closure.is_normal (set.subset.trans h (subset_normal_closure))

end group

/-- Create a bundled subgroup from a set `s` and `[is_subgroup s]`. -/
@[to_additive "Create a bundled additive subgroup from a set `s` and `[is_add_subgroup s]`."]
def subgroup.of [group G] {s : set G} (h : is_subgroup s) : subgroup G :=
{ carrier := s,
  one_mem' := h.1.1,
  mul_mem' := h.1.2,
  inv_mem' := h.2 }

@[to_additive]
lemma subgroup.is_subgroup [group G] (K : subgroup G) : is_subgroup (K : set G) :=
{ one_mem := K.one_mem',
  mul_mem := K.mul_mem',
  inv_mem := K.inv_mem' }

-- this will never fire if it's an instance
@[to_additive]
lemma subgroup.of_normal [group G] (s : set G) (h : is_subgroup s) (n : is_normal_subgroup s) :
  subgroup.normal (subgroup.of h) :=
{ conj_mem := n.normal, }


/-
Copyright (c) 2022 Joël Riou. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Joël Riou
-/

import for_mathlib.algebraic_topology.homotopical_algebra.factorisation_axiom

open category_theory

variables {C : Type*} [category C] (F : morphism_property C) {F' : morphism_property Cᵒᵖ}

namespace category_theory

namespace morphism_property

def three_of_two_of_comp_left : Prop :=
∀ ⦃X Y Z : C⦄ (f : X ⟶ Y) (g : Y ⟶ Z) (hf : F f) (hfg : F (f ≫ g)), F g

def three_of_two_of_comp_right : Prop :=
∀ ⦃X Y Z : C⦄ (f : X ⟶ Y) (g : Y ⟶ Z) (hg : F g) (hfg : F (f ≫ g)), F f

namespace three_of_two_of_comp_left

variable {F}

lemma inverse_image {D : Type*} [category D] (h : F.three_of_two_of_comp_left) (G : D ⥤ C) :
  (F.inverse_image G).three_of_two_of_comp_left := λ X Y Z f g hf hfg,
begin
  dsimp [morphism_property.inverse_image] at hf hfg ⊢,
  rw G.map_comp at hfg,
  exact h _ _ hf hfg,
end

lemma op (h : F.three_of_two_of_comp_left) : F.op.three_of_two_of_comp_right :=
λ X Y Z f g hg hgf, h g.unop f.unop hg hgf

lemma unop (h : F'.three_of_two_of_comp_left) : F'.unop.three_of_two_of_comp_right :=
λ X Y Z f g hg hgf, h g.op f.op hg hgf

end three_of_two_of_comp_left

namespace three_of_two_of_comp_right

variable {F}

lemma inverse_image {D : Type*} [category D] (h : F.three_of_two_of_comp_right) (G : D ⥤ C) :
  (F.inverse_image G).three_of_two_of_comp_right := λ X Y Z f g hg hfg,
begin
  dsimp [morphism_property.inverse_image] at hg hfg ⊢,
  rw G.map_comp at hfg,
  exact h _ _ hg hfg,
end

lemma op (h : F.three_of_two_of_comp_right) : F.op.three_of_two_of_comp_left :=
λ X Y Z f g hg hgf, h g.unop f.unop hg hgf

lemma unop (h : F'.three_of_two_of_comp_right) : F'.unop.three_of_two_of_comp_left :=
λ X Y Z f g hg hgf, h g.op f.op hg hgf

variables (F F')

lemma iff_op : F.three_of_two_of_comp_right ↔ F.op.three_of_two_of_comp_left :=
⟨op, three_of_two_of_comp_left.unop⟩

lemma iff_unop : F'.three_of_two_of_comp_right ↔ F'.unop.three_of_two_of_comp_left :=
⟨unop, three_of_two_of_comp_left.op⟩

end three_of_two_of_comp_right

namespace three_of_two_of_comp_left

lemma iff_op : F.three_of_two_of_comp_left ↔ F.op.three_of_two_of_comp_right :=
⟨op, three_of_two_of_comp_right.unop⟩

lemma iff_unop : F'.three_of_two_of_comp_left ↔ F'.unop.three_of_two_of_comp_right :=
⟨unop, three_of_two_of_comp_right.op⟩

end three_of_two_of_comp_left

variable (F)

structure three_of_two : Prop :=
(of_comp : F.stable_under_composition)
(of_comp_left : F.three_of_two_of_comp_left)
(of_comp_right : F.three_of_two_of_comp_right)

namespace three_of_two

variables {F F'}

lemma op (h : three_of_two F) : three_of_two F.op :=
{ of_comp := h.of_comp.op,
  of_comp_left := h.of_comp_right.op,
  of_comp_right := h.of_comp_left.op, }

lemma unop (h : three_of_two F') : three_of_two F'.unop :=
{ of_comp := h.of_comp.unop,
  of_comp_left := h.of_comp_right.unop,
  of_comp_right := h.of_comp_left.unop, }

variables (F F')

lemma iff_op : F.three_of_two ↔ F.op.three_of_two :=
⟨op, λ h, by simpa only [F.unop_op] using h.unop⟩

lemma iff_unop : F'.three_of_two ↔ F'.unop.three_of_two :=
⟨unop, λ h, by simpa only [F'.op_unop] using h.op⟩

variable {F}

lemma for_inverse_image {D : Type*} [category D] (h : three_of_two F) (G : D ⥤ C) :
  (F.inverse_image G).three_of_two :=
{ of_comp := h.of_comp.inverse_image G,
  of_comp_left := h.of_comp_left.inverse_image G,
  of_comp_right := h.of_comp_right.inverse_image G, }

variable (C)

lemma for_isomorphisms : (isomorphisms C).three_of_two :=
{ of_comp := stable_under_composition.isomorphisms C,
  of_comp_left := λ X Y Z f g hf hfg, begin
    dsimp [isomorphisms] at hf hfg ⊢,
    haveI := hf,
    haveI := hfg,
    exact is_iso.of_is_iso_comp_left f g,
  end,
  of_comp_right :=λ X Y Z f g hg hfg, begin
    dsimp [isomorphisms] at hg hfg ⊢,
    haveI := hg,
    haveI := hfg,
    exact is_iso.of_is_iso_comp_right f g,
  end, }

end three_of_two

end morphism_property

end category_theory


import category_theory.preadditive.injective
import category_theory.adjunction
import category_theory.limits.constructions.epi_mono
import category_theory.abelian.exact
import enough_injectives.preserves_exact_seq

noncomputable theory

namespace category_theory

open limits

universes u v

variables {𝓐 𝓑 : Type u} [category.{v} 𝓐] [category.{v} 𝓑]
variables [abelian 𝓐] [abelian 𝓑]
variables [enough_injectives 𝓑]
variables (L : 𝓐 ⥤ 𝓑) (R : 𝓑 ⥤ 𝓐)
variables [faithful L] [preserves_finite_limits L] [preserves_finite_colimits L]
variables (adj : L ⊣ R)

namespace enough_injectives

section

def injective_presentation_of_apply (A : 𝓐) :
  injective_presentation (L.obj A) :=
(nonempty.some (enough_injectives.presentation (L.obj A)))

def injective_object_of_adjunction (A : 𝓐) : 𝓐 :=
  R.obj $ (injective_presentation_of_apply L A).J

include adj
variables {L R}

def to_J_of_injective_presentation_of_apply {A X Y : 𝓐}
  (g : X ⟶ injective_object_of_adjunction L R A)
  (f : X ⟶ Y) [mono f] :
  L.obj Y ⟶ (injective_presentation_of_apply L A).J :=
let factors := (injective_presentation_of_apply L A).injective.factors in
(factors ((adj.hom_equiv X (injective_presentation_of_apply L A).J).symm g) (L.map f)).some

lemma comp_to_J_of_injective_presentation_of_apply {A X Y : 𝓐}
  (g : X ⟶ injective_object_of_adjunction L R A)
  (f : X ⟶ Y) [mono f] :
  L.map f ≫ (to_J_of_injective_presentation_of_apply adj g f) =
  (adj.hom_equiv X (injective_presentation_of_apply L A).J).symm g :=
let factors := (injective_presentation_of_apply L A).injective.factors in
(factors ((adj.hom_equiv _ _).symm g) (L.map f)).some_spec

def injective_object_of_adjunction.factor {A X Y : 𝓐}
  (g: X ⟶ injective_object_of_adjunction L R A)
  (f : X ⟶ Y) [mono f] :
  Y ⟶ injective_object_of_adjunction L R A :=
adj.hom_equiv _ _ $ to_J_of_injective_presentation_of_apply adj g f

lemma injective_object_of_adjunction.comp {A X Y : 𝓐}
  (g: X ⟶ injective_object_of_adjunction L R A)
  (f : X ⟶ Y) [mono f]:
  f ≫ injective_object_of_adjunction.factor adj g f = g :=
begin
  have := comp_to_J_of_injective_presentation_of_apply adj g f,
  rw ←adj.hom_equiv_apply_eq at this,
  rw [←this],
  simp only [injective_object_of_adjunction.factor, to_J_of_injective_presentation_of_apply, adjunction.hom_equiv_counit,
    adjunction.hom_equiv_naturality_left_symm, adjunction.hom_equiv_naturality_right_symm,
    adjunction.left_triangle_components, category.id_comp, adjunction.hom_equiv_naturality_left,
    adjunction.hom_equiv_unit, functor.map_comp, adjunction.unit_naturality_assoc],
  congr,
  ext,
  generalize_proofs h1,
  rw h1.some_spec,
end

lemma injective_object_of_adjunction_is_injective (A : 𝓐) :
  injective (injective_object_of_adjunction L R A) :=
{ factors := λ X Y g f m,
  ⟨by resetI; exact injective_object_of_adjunction.factor adj g f,
    by apply injective_object_of_adjunction.comp⟩ }

def of_adjunction.presentation.J (A : 𝓐) : 𝓐 :=
injective_object_of_adjunction L R A

def of_adjunction.presentation.injective (A : 𝓐) :
  injective (of_adjunction.presentation.J adj A) :=
by apply injective_object_of_adjunction_is_injective adj

def of_adjunction.presentation.f (A : 𝓐) :
  A ⟶ injective_object_of_adjunction L R A :=
adj.hom_equiv A (injective_presentation_of_apply L A).J (injective_presentation_of_apply L A).f

instance of_adjunction.presentation.mono (A : 𝓐) :
  mono $ of_adjunction.presentation.f adj A :=
have e1 : exact _ (of_adjunction.presentation.f adj A) := exact_kernel_ι,
have e2 : exact (L.map (kernel.ι (of_adjunction.presentation.f adj A))) (L.map (of_adjunction.presentation.f adj A)), from exact_of_exact_functor L _ _ e1,
have eq1 : L.map (of_adjunction.presentation.f adj A) ≫ (adj.counit.app _) = (injective_presentation_of_apply L A).f, begin
  dunfold of_adjunction.presentation.f,
  simp only [adjunction.hom_equiv_unit, functor.map_comp, category.assoc, adjunction.counit_naturality,
    adjunction.left_triangle_components_assoc],
end,
have m2 : mono (L.map (of_adjunction.presentation.f adj A)), from begin
  haveI : mono (L.map (of_adjunction.presentation.f adj A) ≫ (adj.counit.app _)),
  { rw eq1,
    exactI (injective_presentation_of_apply L A).mono, },
  exactI mono_of_mono (L.map (of_adjunction.presentation.f adj A)) (adj.counit.app (injective_presentation_of_apply L A).J),
end,
have eq2 : L.map (kernel.ι (of_adjunction.presentation.f adj A)) = 0, begin
  rw abelian.mono_iff_kernel_ι_eq_zero at m2,
  have : L.map (kernel.ι (of_adjunction.presentation.f adj A)) = (preserves_kernel.iso L (of_adjunction.presentation.f adj A)).hom ≫ kernel.ι (L.map (of_adjunction.presentation.f adj A)),
  { simp only [preserves_kernel.iso_hom, kernel_comparison_comp_ι], },
  rw [this, m2, comp_zero],
end,
have eq3 : kernel.ι (of_adjunction.presentation.f adj A) = 0, from L.zero_of_map_zero _ eq2,
by rw [abelian.mono_iff_kernel_ι_eq_zero, eq3]

instance of_adjunction : enough_injectives 𝓐 :=
{ presentation := λ A, nonempty.intro
  { J := of_adjunction.presentation.J adj _,
    injective := of_adjunction.presentation.injective adj _,
    f := of_adjunction.presentation.f adj _,
    mono := of_adjunction.presentation.mono adj _ } }

end

end enough_injectives

end category_theory


import for_mathlib.chain_complex_cons
import for_mathlib.mapping_cone
import for_mathlib.exact_seq3
import for_mathlib.commsq
import for_mathlib.complex_extend
import for_mathlib.derived.K_projective

noncomputable theory

open category_theory category_theory.limits

variables {𝓐 : Type*} [category 𝓐] [abelian 𝓐]

variables {A₁₁ A₁₂ A₁₃ A₁₄ A₁₅ : 𝓐}
variables {A₂₁ A₂₂ A₂₃ A₂₄ A₂₅ : 𝓐}
variables {A₃₁ A₃₂ A₃₃ A₃₄ A₃₅ : 𝓐}
variables {A₄₁ A₄₂ A₄₃ A₄₄ A₄₅ : 𝓐}
variables {A₅₁ A₅₂ A₅₃ A₅₄ A₅₅ : 𝓐}

variables {f₁₁ : A₁₁ ⟶ A₁₂} {f₁₂ : A₁₂ ⟶ A₁₃} {f₁₃ : A₁₃ ⟶ A₁₄} {f₁₄ : A₁₄ ⟶ A₁₅}
variables {g₁₁ : A₁₁ ⟶ A₂₁} {g₁₂ : A₁₂ ⟶ A₂₂} {g₁₃ : A₁₃ ⟶ A₂₃} {g₁₄ : A₁₄ ⟶ A₂₄} {g₁₅ : A₁₅ ⟶ A₂₅}
variables {f₂₁ : A₂₁ ⟶ A₂₂} {f₂₂ : A₂₂ ⟶ A₂₃} {f₂₃ : A₂₃ ⟶ A₂₄} {f₂₄ : A₂₄ ⟶ A₂₅}
variables {g₂₁ : A₂₁ ⟶ A₃₁} {g₂₂ : A₂₂ ⟶ A₃₂} {g₂₃ : A₂₃ ⟶ A₃₃} {g₂₄ : A₂₄ ⟶ A₃₄} {g₂₅ : A₂₅ ⟶ A₃₅}
variables {f₃₁ : A₃₁ ⟶ A₃₂} {f₃₂ : A₃₂ ⟶ A₃₃} {f₃₃ : A₃₃ ⟶ A₃₄} {f₃₄ : A₃₄ ⟶ A₃₅}
variables {g₃₁ : A₃₁ ⟶ A₄₁} {g₃₂ : A₃₂ ⟶ A₄₂} {g₃₃ : A₃₃ ⟶ A₄₃} {g₃₄ : A₃₄ ⟶ A₄₄} {g₃₅ : A₃₅ ⟶ A₄₅}
variables {f₄₁ : A₄₁ ⟶ A₄₂} {f₄₂ : A₄₂ ⟶ A₄₃} {f₄₃ : A₄₃ ⟶ A₄₄} {f₄₄ : A₄₄ ⟶ A₄₅}
variables {g₄₁ : A₄₁ ⟶ A₅₁} {g₄₂ : A₄₂ ⟶ A₅₂} {g₄₃ : A₄₃ ⟶ A₅₃} {g₄₄ : A₄₄ ⟶ A₅₄} {g₄₅ : A₄₅ ⟶ A₅₅}
variables {f₅₁ : A₅₁ ⟶ A₅₂} {f₅₂ : A₅₂ ⟶ A₅₃} {f₅₃ : A₅₃ ⟶ A₅₄} {f₅₄ : A₅₄ ⟶ A₅₅}

namespace bicartesian

def quatro_cons (h : exact_seq 𝓐 [f₁₁, f₁₂, f₁₃, f₁₄]) : cochain_complex 𝓐 ℕ :=
((((((cochain_complex.cons homological_complex.zero (cokernel f₁₄) 0 zero_comp).cons
  _ (cokernel.π _) comp_zero).cons
  _ f₁₄ $ cokernel.condition _).cons
  _ f₁₃ $ (h.drop 2).pair.w).cons
  _ f₁₂ $ (h.drop 1).pair.w).cons
  _ f₁₁ $ (h.drop 0).pair.w).cons
  _ (kernel.ι _) $ kernel.condition _

open cochain_complex.hom (cons)

def quatro_cons_hom
  (h₁ : exact_seq 𝓐 [f₁₁, f₁₂, f₁₃, f₁₄])
  (h₂ : exact_seq 𝓐 [f₂₁, f₂₂, f₂₃, f₂₄])
  (sq₁ : commsq f₁₁ g₁₁ g₁₂ f₂₁)
  (sq₂ : commsq f₁₂ g₁₂ g₁₃ f₂₂)
  (sq₃ : commsq f₁₃ g₁₃ g₁₄ f₂₃)
  (sq₄ : commsq f₁₄ g₁₄ g₁₅ f₂₄) :
  quatro_cons h₁ ⟶ quatro_cons h₂ :=
cochain_complex.hom.cons _ _ (kernel.map _ _ _ _ sq₁.w)
  (cons _ _ g₁₁
  (cons _ _ g₁₂
  (cons _ _ g₁₃
  (cons _ _ g₁₄
  (cons _ _ g₁₅
  (cons _ _ (cokernel.map _ _ _ _ sq₄.w) 0 $
    comp_zero.trans comp_zero.symm) $
    (cokernel.π_desc _ _ _).symm) $
    sq₄.w.symm) sq₃.w.symm) sq₂.w.symm) sq₁.w.symm) $
    kernel.lift_ι _ _ _

variables
  (h₁ : exact_seq 𝓐 [f₁₁, f₁₂, f₁₃, f₁₄])
  (h₂ : exact_seq 𝓐 [f₂₁, f₂₂, f₂₃, f₂₄])
  (sq₁ : commsq f₁₁ g₁₁ g₁₂ f₂₁)
  (sq₂ : commsq f₁₂ g₁₂ g₁₃ f₂₂)
  (sq₃ : commsq f₁₃ g₁₃ g₁₄ f₂₃)
  (sq₄ : commsq f₁₄ g₁₄ g₁₅ f₂₄)

def quatro_cone : cochain_complex 𝓐 ℤ :=
homological_complex.cone $
  (homological_complex.embed complex_shape.embedding.nat_up_int_up).map $
  quatro_cons_hom h₁ h₂ sq₁ sq₂ sq₃ sq₄

@[simp] lemma quatro_cone_X_1 :
  (quatro_cone h₁ h₂ sq₁ sq₂ sq₃ sq₄).X 1 = (A₁₂ ⊞ A₂₁) := rfl

@[simp] lemma quatro_cone_X_2 :
  (quatro_cone h₁ h₂ sq₁ sq₂ sq₃ sq₄).X 2 = (A₁₃ ⊞ A₂₂) := rfl

@[simp] lemma quatro_cone_X_3 :
  (quatro_cone h₁ h₂ sq₁ sq₂ sq₃ sq₄).X 3 = (A₁₄ ⊞ A₂₃) := rfl

-- move me
def biprod.matrix
  (f₁₁ : A₁₁ ⟶ A₂₁) (f₂₁ : A₁₂ ⟶ A₂₁) (f₁₂ : A₁₁ ⟶ A₂₂) (f₂₂ : A₁₂ ⟶ A₂₂) :
  A₁₁ ⊞ A₁₂ ⟶ A₂₁ ⊞ A₂₂ :=
biprod.lift (biprod.desc f₁₁ f₂₁) (biprod.desc f₁₂ f₂₂)

@[simp] lemma quatro_cone_d_12' :
  (quatro_cone h₁ h₂ sq₁ sq₂ sq₃ sq₄).d 1 2 =
  biprod.matrix (-f₁₂) 0 (g₁₂ ≫ 𝟙 _) f₂₁ :=
rfl

@[simp] lemma quatro_cone_d_23' :
  (quatro_cone h₁ h₂ sq₁ sq₂ sq₃ sq₄).d 2 3 =
  biprod.matrix (-f₁₃) 0 (g₁₃ ≫ 𝟙 _) f₂₂ :=
rfl

@[simp] lemma quatro_cone_d_34' :
  (quatro_cone h₁ h₂ sq₁ sq₂ sq₃ sq₄).d 3 4 =
  biprod.matrix (-f₁₄) 0 (g₁₄ ≫ 𝟙 _) f₂₃ :=
rfl

section homotopy_category
open homotopy_category

instance quatro_cons_acyclic : is_acyclic $
  (homotopy_category.quotient _ _).obj $
  (homological_complex.embed complex_shape.embedding.nat_up_int_up).obj $
  quatro_cons h₁ :=
begin
  constructor,
  intro n,
  obtain ⟨n, rfl⟩ : ∃ k, k+1 = n := ⟨n-1, sub_add_cancel _ _⟩,
  refine is_zero.of_iso _ (homology_iso _ n (n+1) (n+1+1) rfl rfl),
  refine exact.homology_is_zero _ _ _,
  rcases n with ((_|_|_|_|_|_|n)|(_|n)),
  { exact exact_kernel_ι },
  { exact (h₁.drop 0).pair },
  { exact (h₁.drop 1).pair },
  { exact (h₁.drop 2).pair },
  { exact abelian.exact_cokernel _ },
  { show exact (cokernel.π _) _, exact exact_epi_zero _, },
  { exact exact_of_zero _ _ },
  { show exact _ (kernel.ι _), exact exact_zero_mono _ },
  { exact exact_of_zero _ _ },
end

instance quatro_cons_hom_quasi_iso : is_quasi_iso $
  (homotopy_category.quotient _ _).map $
  (homological_complex.embed complex_shape.embedding.nat_up_int_up).map $
  quatro_cons_hom h₁ h₂ sq₁ sq₂ sq₃ sq₄ :=
begin
  constructor,
  intro n,
  refine is_zero.is_iso _ _ _;
  apply is_acyclic.cond,
end

instance quatro_cone_acyclic : is_acyclic $
  (homotopy_category.quotient _ _).obj $
  quatro_cone h₁ h₂ sq₁ sq₂ sq₃ sq₄ :=
begin
  let f := (homological_complex.embed complex_shape.embedding.nat_up_int_up).map
    (quatro_cons_hom h₁ h₂ sq₁ sq₂ sq₃ sq₄),
  have := cone_triangleₕ_mem_distinguished_triangles _ _ f,
  refine (is_quasi_iso_iff_is_acyclic _ this).mp _,
  apply bicartesian.quatro_cons_hom_quasi_iso
end

end homotopy_category

-- #check biprod.matrix (-f₁₂) 0 (g₁₂ ≫ 𝟙 _) f₂₁

end bicartesian


import parlang.defs
import data.rat
open parlang

notation `v[` v:(foldr `, ` (h t, vector.cons h t) vector.nil `]`) := v

namespace mcl
variables {n : ℕ}

inductive type
| int
| float
| bool

open type

instance : has_sizeof type :=
⟨λt, match t with
| type.int := 1
| type.float := 1
| type.bool := 2
end⟩

structure array :=
(dim : ℕ)
(type : type)
-- (sizes : vector ℕ dim)

inductive scope
| tlocal
| shared

structure variable_def :=
(type : array)
(scope : scope)

@[reducible]
def signature_core := string → variable_def

@[reducible]
def type_map : type → Type
| int := ℕ
| float := rat
| bool := _root_.bool

instance (t) : inhabited (type_map t) := ⟨
    match t with
    | type.int := 0
    | type.float := 0
    | type.bool := ff
    end
⟩

#eval default (type_map int)

@[reducible]
def type_of : variable_def → type := λ v, v.type.type

def signature := { sig : signature_core //
    type_of (sig "tid") = type.int ∧
    (sig "tid").type.dim = 1 ∧
    (sig "tid").scope = scope.tlocal }

-- todo: make sig parameter (instead of variable). That way I don't have to mention signature anywhere (see section 6.2)
variables {sig : signature}

@[reducible]
def lean_type_of : variable_def → Type := λ v, type_map (type_of v)
@[reducible]
def signature.type_of (n : string) (sig :signature) := type_of (sig.val n)
@[reducible]
def signature.lean_type_of (n : string) (sig : signature) := lean_type_of (sig.val n)
@[reducible]
def is_tlocal (v : variable_def) := v.scope = scope.tlocal
@[reducible]
def is_shared (v : variable_def) := v.scope = scope.shared

-- @[reducible]
-- def create_signature : list (string × variable_def) → signature
-- | [] n := { scope := scope.tlocal, type := ⟨1, int⟩} -- by default all variables are tlocal int's
-- | ((m, v) :: xs) n := if m = n then v else create_signature xs n

-- We use vectors for idx. If we compare two variable accesses to the same array: when using vectors we only have to reason about equality of elements, otherwise we have to reason about length as well
@[reducible]
def mcl_address (sig : signature) := (Σ n: string, vector ℕ (sig.val n).type.dim)
/-- Type map for shared memory -/
@[reducible]
def parlang_mcl_shared (sig : signature) := (λ i : mcl_address sig, sig.lean_type_of i.1)
/-- Type map for thread local memory -/
@[reducible]
def parlang_mcl_tlocal (sig : signature) := (λ i : mcl_address sig, sig.lean_type_of i.1)
@[reducible]
def parlang_mcl_kernel (sig : signature) := kernel (memory $ parlang_mcl_tlocal sig) (parlang_mcl_shared sig)

lemma address_eq {sig : mcl.signature} {a b : mcl.mcl_address sig} (h : a.1 = b.1) (g: a.2 = begin rw h, exact b.2, end) : a = b := begin
    cases a,
    cases b,
    simp at h,
    subst h,
    simp,
    simp[eq.mpr.intro] at g,
    exact g,
end

/-- all addresses of array *var* -/
def array_address_range {sig : signature} (var : string) : set (mcl_address sig) := {i | i.1 = var}

-- expression is an inductive family over types
-- type is called an index
inductive expression (sig : signature) : type → Type
| tlocal_var {t} {dim : ℕ} (n : string) (idx : fin dim → (expression int)) (h₁ : type_of (sig.val n) = t) (h₂ : (sig.val n).type.dim = dim) (h₃ : is_tlocal (sig.val n)) : expression t
| shared_var {t} {dim : ℕ} (n : string) (idx : fin dim → (expression int)) (h₁ : type_of (sig.val n) = t) (h₂ : (sig.val n).type.dim = dim) (h₃ : is_shared (sig.val n)) : expression t
| add {t} : expression t → expression t → expression t
| mult {t} : expression t → expression t → expression t
| literal_int {} {t} (n : ℕ) (h : t = type.int) : expression t
| lt {t} (h : t = type.bool) : expression int → expression int → expression t

open expression

instance (t : type) : has_add (expression sig t) := ⟨expression.add⟩
instance (t : type) : has_mul (expression sig t) := ⟨expression.mult⟩
instance : has_zero (expression sig int) := ⟨expression.literal_int 0 rfl⟩
instance : has_one (expression sig int) := ⟨expression.literal_int 1 rfl⟩
infix < := expression.lt (show type.bool = type.bool, by refl)
notation `v(` n `)`:= expression.tlocal_var n (by refl)
notation `i(` n `)`:= expression.literal_int n (by refl)

def type_map_add : Π{t : type}, type_map t → type_map t → type_map t
| int a b := a + b
| float a b := a + b
| bool a b := a && b

def type_map_mult : Π{t : type}, type_map t → type_map t → type_map t
| int a b := a * b
| float a b := a * b
| bool a b := a || b

-- we have C on idx
-- use recursor directly
#print expression.rec_on
#print expression.brec_on
#print nat.rec_on
#check ((λ n, nat.rec_on n _ _) : ℕ → ℕ)

-- pattern matching does not work due to problems with the parser
-- implicit argument C of recursor is filled in by the special elaborator "eliminator"
-- arguments sig t and expr must be named, otherwise the eliminator elaborator fails
def expression_size {sig : signature} {t : type} (expr : expression sig t) : ℕ := expression.rec_on expr
    -- tlocal
    (λ t dim n idx h₁ h₂ h₃ ih, 1 + (vector.of_fn ih).to_list.sum)
    -- shared
    (λ t dim n idx h₁ h₂ h₃ ih, 1 + (vector.of_fn ih).to_list.sum)
    -- add
    (λ t a b ih_a ih_b, (1 : ℕ) + (ih_a : ℕ) + (ih_b : ℕ))
    -- mult
    (λ t a b ih_a ih_b, (1 : ℕ) + (ih_a : ℕ) + (ih_b : ℕ))
    -- literal_int
    (λ t n h, (n : ℕ))
    -- lt
    (λ t h a b ih_a ih_b, ih_a + ih_b + 1)

-- def s₁ : signature
-- | _ := { scope := scope.shared, type := ⟨1, type.int⟩ }
-- -- appearently not true
-- def test : (7 : expression s₁ int) = (literal_int 7 (by refl)) := begin
--     sorry, -- not by refl
-- end
-- def idx₁ : fin 1 → expression s₁ int
-- | _ := 7
-- #eval expression_size (tlocal_var "n" idx₁ sorry sorry sorry  : expression s₁ int)
-- #eval expression_size (expression.add (literal_int 123 (by refl)) (literal_int 123 (by refl)) : expression s₁ int)

#print expression_size

@[simp]
lemma abc (t) (expr : expression sig t) : 0 < expression_size expr := sorry

#print psigma.has_well_founded
#print psigma.lex
#print has_well_founded_of_has_sizeof
#print expression.sizeof

-- should we make this an inductive predicate
-- it would have implications on parlang
def eval {sig : signature} (m : memory $ parlang_mcl_tlocal sig) {t : type} (expr : expression sig t) : type_map t := expression.rec_on expr
    -- tlocal
    (λ t dim n idx h₁ h₂ h₃ ih, by rw ← h₁; rw ← h₂ at ih; exact m.get ⟨n, vector.of_fn ih⟩)
    -- shared
    -- requires that the shared variable has been loaded into tstate under the same name
    (λ t dim n idx h₁ h₂ h₃ ih, by rw ← h₁; rw ← h₂ at ih; exact m.get ⟨n, vector.of_fn ih⟩)
    -- add
    (λ t a b ih_a ih_b, type_map_add ih_a ih_b)
    -- mult
    (λ t a b ih_a ih_b, type_map_mult ih_a ih_b)
    -- literal_int
    (λ t n h, (by rw [h]; exact n))
    -- lt
    (λ t h a b ih_a ih_b, (by rw h; exact (ih_a < ih_b)))

/-- h₂ corresponds to h₂ of expr and mclk -/
def mcl_addr_from_var {sig : signature} {n dim} (h₂ : (sig.val n).type.dim = dim) (idx : vector (expression sig type.int) dim) (m : memory $ parlang_mcl_tlocal sig) : mcl_address sig :=
⟨n, by rw ← h₂ at idx; exact idx.map (eval m)⟩

def load_shared_vars_for_expr {sig : signature} {t : type} (expr : expression sig t) : list (parlang_mcl_kernel sig) := expression.rec_on expr
    -- tlocal
    (λ t dim n idx h₁ h₂ h₃ ih, (vector.of_fn ih).to_list.foldl list.append [])
    -- shared
    -- loads the shared variable in the tlocal memory under the same name
    (λ t dim n idx h₁ h₂ h₃ ih, (vector.of_fn ih).to_list.foldl list.append [] ++ [kernel.load (λ m, ⟨mcl_addr_from_var h₂ (vector.of_fn idx) m, λ v, m.update (mcl_addr_from_var h₂ (vector.of_fn idx) m) v⟩)])
    -- add
    (λ t a b ih_a ih_b, ih_a ++ ih_b)
    -- mult
    (λ t a b ih_a ih_b, ih_a ++ ih_b)
    -- literal_int
    (λ t n h, [])
    -- lt
    (λ t h a b ih_a ih_b, ih_a ++ ih_b)

def prepend_load_expr {sig : signature} {t : type} (expr : expression sig t) (k : parlang_mcl_kernel sig) :=
(load_shared_vars_for_expr expr).foldr kernel.seq k
--list_to_kernel_seq (load_shared_vars_for_expr expr ++ [k])

def append_load_expr  {sig : signature} {t : type} (expr : expression sig t) (k : parlang_mcl_kernel sig) :=
(load_shared_vars_for_expr expr).foldl kernel.seq k
--list_to_kernel_seq ([k] ++ load_shared_vars_for_expr expr)

example (k) : prepend_load_expr (7 : expression sig int) k = k := by refl
example (k) (n idx h₁ h₂ h₃) : prepend_load_expr (@shared_var sig _ 1 n idx h₁ h₂ h₃ : expression sig int) k = k := begin
    rw prepend_load_expr,
    rw load_shared_vars_for_expr,
    repeat { rw list.foldr },
    sorry
end

example (k) : append_load_expr (7 : expression sig int) k = k := by refl
example (k) (n idx h₁ h₂ h₃) : append_load_expr (@shared_var sig _ 1 n idx h₁ h₂ h₃ : expression sig int) k = k := begin
    rw append_load_expr,
    rw load_shared_vars_for_expr,
    repeat { rw list.foldl },
    sorry
end

-- TODO prove lemma
-- eval expression (specifically the loads only influence the expression)
-- prove more lemmas to make sure loads are placed correctly
-- do I need a small step seantic for this?

def expr_reads (n : string) {t : type} (expr : expression sig t) : _root_.bool := expression.rec_on expr
    -- tlocal
    (λ t dim m idx h₁ h₂ h₃ ih, (m = n) || (vector.of_fn ih).to_list.any id)
    -- shared
    (λ t dim m idx h₁ h₂ h₃ ih, (m = n) || (vector.of_fn ih).to_list.any id)
    -- add
    (λ t a b ih_a ih_b, ih_a || ih_b)
    -- mult
    (λ t a b ih_a ih_b, ih_a || ih_b)
    -- literal_int
    (λ t n h, ff)
    -- lt
    (λ t h a b ih_a ih_b, ih_a || ih_b)

meta def eqt : tactic unit := do
    t ← tactic.target,
    match t with
    | `(eq.mpr %%x %%p = eq.mpr %%y %%z) := do
        s ← tactic.infer_type x,
        tactic.trace s,
        s ← tactic.infer_type y,
        tactic.trace s
    | _ := tactic.fail ()
    end

lemma eval_update_ignore {sig : signature} {t t₂ : type} {n} {idx₂ : vector ℕ ((sig.val n).type).dim} {v} {expr : expression sig t} {s : memory $ parlang_mcl_tlocal sig} (h : expr_reads n expr = ff) :
eval (s.update ⟨n, idx₂⟩ v) expr = eval s expr := begin
    induction expr,
    {
        simp [eval],
        simp [eval] at expr_ih,
        eqt,
        sorry,
    },
    repeat { sorry },
end

-- can we make use of functor abstraction
lemma eval_update_ignore' {sig : signature} {t t₂ : type} {dim n} {idx₂ : vector ℕ ((sig.val n).type).dim} {v} {idx : vector (expression sig t) dim} {s : memory $ parlang_mcl_tlocal sig} (h : (idx.to_list.all $ bnot ∘ expr_reads n) = tt) :
vector.map (eval (s.update ⟨n, idx₂⟩ v)) idx = vector.map (eval s) idx := begin
    admit
end

-- TODO variable assign constructors should include shared and local proof
-- expression sig (type_of (sig n)) is not definitionally equal if sig is not computable
inductive mclk (sig : signature)
| tlocal_assign {t : type} {dim : ℕ} (n : string) (idx : vector (expression sig int) dim) (h₁ : type_of (sig.val n) = t) (h₂ : (sig.val n).type.dim = idx.length) : (expression sig t) → mclk
| shared_assign {t : type} {dim : ℕ} (n) (idx : vector (expression sig int) dim) (h₁ : type_of (sig.val n) = t) (h₂ : (sig.val n).type.dim = idx.length) : (expression sig t) → mclk
| seq : mclk → mclk → mclk
| for (n : string) (h : sig.type_of n = int) (h₂ : (sig.val n).type.dim = 1) :
  expression sig int → expression sig bool → mclk → mclk → mclk
| ite : expression sig bool → mclk → mclk → mclk
| skip {} : mclk
| sync {} : mclk

infixr ` ;; `:90 := mclk.seq

open mclk

def mclk_reads (n : string) : mclk sig → _root_.bool
| (tlocal_assign _ idx _ _ expr) := expr_reads n expr || (idx.to_list.any (λ e, expr_reads n e))
| (shared_assign _ idx _ _ expr) := expr_reads n expr || (idx.to_list.any (λ e, expr_reads n e))
| (seq k₁ k₂) := mclk_reads k₁ || mclk_reads k₂
| (for _ _ _ init c inc body) := expr_reads n init || expr_reads n c || mclk_reads inc || mclk_reads body
| (ite c th el) := expr_reads n c || mclk_reads th || mclk_reads el
| skip := false
| sync := false

--lemma mclk_expr_reads (k) : mclk_reads n k → ∃ expr, (expr_reads n expr ∧ subexpr expr k)

/-- A variation of *memory.update*, that is optimized for the arguments of MCL -/
def memory.update_assign {sig : signature} {t : type} {dim : ℕ} (n : string) (idx : vector (expression sig int) dim) (h₁ : type_of (sig.val n) = t) (h₂ : (sig.val n).type.dim = idx.length)
(expr : expression sig t)
(m : memory $ parlang_mcl_tlocal sig) : memory $ parlang_mcl_tlocal sig := m.update (mcl_addr_from_var h₂ idx m) (by rw ← h₁ at expr; exact (eval m expr))

def mclk_to_kernel {sig : signature} : mclk sig → parlang_mcl_kernel sig
| (seq k₁ k₂) := kernel.seq (mclk_to_kernel k₁) (mclk_to_kernel k₂)
| skip := kernel.compute id
| sync := kernel.sync
| (tlocal_assign n idx h₁ h₂ expr) := idx.to_list.foldr (λexpr' k, prepend_load_expr expr' k) $ prepend_load_expr expr (kernel.compute $ memory.update_assign n idx h₁ h₂ expr)
| (shared_assign n idx h₁ h₂ expr) := idx.to_list.foldr (λexpr' k, prepend_load_expr expr' k) $ prepend_load_expr expr (kernel.compute $ memory.update_assign n idx h₁ h₂ expr) ;; kernel.store (λ m, ⟨mcl_addr_from_var h₂ idx m, m.get $ mcl_addr_from_var h₂ idx m⟩)
| (ite c th el) := prepend_load_expr c (kernel.ite (λm, eval m c) (mclk_to_kernel th) (mclk_to_kernel el))
| (for n h h₂ expr c k_inc k_body) := prepend_load_expr expr (kernel.compute $ memory.update_assign n v[0] h h₂ expr) ;;
    prepend_load_expr c (
        kernel.loop (λ s, eval s c) (mclk_to_kernel k_body ;; append_load_expr c (mclk_to_kernel k_inc))
    )

-- if a kernel does not contain a shared referencce it must not contain any loads
/- example (k : mclk sig) (h : ∀ n, is_shared (sig.val n) → ¬mclk_reads n k) : ∀ sk, subkernel sk (mclk_to_kernel k) → ¬∃ f, sk = (kernel.load f) := begin
    intros sk hsk hl,
    cases hl with f hl,
    subst hl,
    induction k,
    {
        rw mclk_to_kernel at hsk,
        sorry,
    }, {
        rw mclk_to_kernel at hsk,
        sorry,
    }, {
        rw mclk_to_kernel at hsk,
        rw subkernel at hsk,
        cases hsk,
        {
            sorry, -- trivial but cumbersome
        }, {
            cases hsk,
            {
                sorry,
            }, {
                cases hsk,
                {
                    apply k_ih_a,
                    {
                        intros n hg hr,
                        apply h n hg,
                        unfold mclk_reads,
                        sorry,
                    }, {
                        assumption,
                    }
                }, {
                    apply k_ih_a_1,
                    {
                        intros n hg hr,
                        apply h n hg,
                        sorry,
                    }, {
                        assumption,
                    }
                }
            }
        }
    }, {
        sorry,
    }, {
        unfold mclk_to_kernel at hsk,
        rw subkernel at hsk,
        contradiction,
    }
end -/

inductive mclp (sig : signature)
| intro (f : memory (parlang_mcl_shared sig) → ℕ) (k : mclk sig) : mclp

def mclp_to_program {sig : signature} : mclp sig → parlang.program (memory $ parlang_mcl_tlocal sig) (parlang_mcl_shared sig)
| (mclp.intro f k) := parlang.program.intro f (mclk_to_kernel k)

def empty_state {sig : signature} : (memory $ parlang_mcl_tlocal sig) := λ var, default (type_map (type_of (sig.val var.1)))

-- we need an assumption on the signature, i.e. tid must be int
def mcl_init {sig : signature} : ℕ → (memory $ parlang_mcl_tlocal sig) := λ n : ℕ, empty_state.update ⟨"tid", begin rw sig.property.right.left, exact v[0] end⟩ (begin unfold parlang_mcl_tlocal signature.lean_type_of lean_type_of, rw sig.property.left, exact n end)

end mcl


import .lovelib

/-! # LoVe Demo 8: Operational Semantics

In this and the next two lectures, we will see how to use Lean to specify the
syntax and semantics of programming languages and to reason about the
semantics. -/

set_option pp.beta true

namespace LoVe

/-! ## Formal Semantics

A formal semantics helps specify and reason about the programming language
itself, and about individual programs.

It can form the basis of verified compilers, interpreters, verifiers, static
analyzers, type checkers, etc. Without formal proofs, these tools are
**almost always wrong**.

In this area, proof assistants are widely used. Every year, about 10-20% of POPL
papers are partially or totally formalized. Reasons for this success:

* Little machinery (background libraries, tactics) is needed to get started,
  beyond inductive types and predicates and recursive functions.

* The proofs tend to have lots of cases, which is a good match for computers.

* Proof assistants keep track of what needs to be changed when as extend the
  programming language with more features.

Case in point: WebAssembly. To quote Conrad Watt (with some abbreviations):

    We have produced a full Isabelle mechanisation of the core execution
    semantics and type system of the WebAssembly language. To complete this
    proof, **several deficiencies** in the official WebAssembly specification,
    uncovered by our proof and modelling work, needed to be corrected. In some
    cases, these meant that the type system was **originally unsound**.

    We have maintained a constructive dialogue with the working group,
    verifying new features as they are added. In particular, the mechanism by
    which a WebAssembly implementation interfaces with its host environment was
    not formally specified in the working group's original paper. Extending our
    mechanisation to model this feature revealed a deficiency in the WebAssembly
    specification that **sabotaged the soundness** of the type system.

## A Minimalistic Imperative Language

__WHILE__ is a minimalistic imperative language with the following grammar:

    S  ::=  skip                 -- no-op
         |  x := a               -- assignment
         |  S ; S                -- sequential composition
         |  if b then S else S   -- conditional statement
         |  while b do S         -- while loop

where `S` stands for a statement (also called command or program), `x` for a
variable, `a` for an arithmetic expression, and `b` for a Boolean expression. -/

inductive stmt : Type
| skip   : stmt
| assign : string → (state → ℕ) → stmt
| seq    : stmt → stmt → stmt
| ite    : (state → Prop) → stmt → stmt → stmt
| while  : (state → Prop) → stmt → stmt

infixr ` ;; ` : 90 := stmt.seq

/-! In our grammer, we deliberately leave the syntax of arithmetic and Boolean
expressions unspecified. In Lean, we have the choice:

* We could use a type such as `aexp` from lecture 1 and similarly for Boolean
  expressions.

* Supposing a state `s` is a function from variable names to values
  (`string → ℕ`), we could decide that an arithmetic expression is simply a
  function from states to natural numbers (`state → ℕ`) and a Boolean expression
  is a predicate (`state → Prop` or `state → bool`).

This corresponds to the difference between deep and shallow embeddings:

* A __deep embedding__ of some syntax (expression, formula, program, etc.)
  consists of an abstract syntax tree specified in the proof assistant
  (e.g., `aexp`) with a semantics (e.g., `eval`).

* In contrast, a __shallow embedding__ simply reuses the corresponding
  mechanisms from the logic (e.g., λ-terms, functions and predicate types).

A deep embedding allows us to reason about the syntax (and its semantics). A
shallow embedding is more lightweight, because we can use it directly, without
having to define a semantics.

We will use a deep embedding of programs (which we find interesting), and
shallow embeddings of assignments and Boolean expressions (which we find
boring).

Examples:

    `λs : state, s "x" + s "y" + 1`   -- x + y + 1
    `λs : state, s "a" ≠ s "b"`       -- a ≠ b

## Big-Step Semantics

An __operational semantics__ corresponds to an idealized interpreter (specified
in a Prolog-like language). Two main variants:

* big-step semantics;

* small-step semantics.

In a __big-step semantics__ (also called __natural semantics__), judgments have
the form `(S, s) ⟹ t`:

    Starting in a state `s`, executing `S` terminates in the state `t`.

Example:

    `(x := x + y; y := 0, [x ↦ 3, y ↦ 5]) ⟹ [x ↦ 8, y ↦ 0]`

Derivation rules:

    ——————————————— Skip
    (skip, s) ⟹ s

    ——————————————————————————— Asn
    (x := a, s) ⟹ s[x ↦ s(a)]

    (S, s) ⟹ s'   (S', s') ⟹ s''
    ——————————————————————————————— Seq
    (S; S', s) ⟹ s''

    (S, s) ⟹ s'
    ——————————————————————————————— If-True   if s(b) is true
    (if b then S else S', s) ⟹ s'

    (S', s) ⟹ s'
    ——————————————————————————————— If-False   if s(b) is false
    (if b then S else S', s) ⟹ s'

    (S, s) ⟹ s'   (while b do S, s') ⟹ s''
    —————————————————————————————————————————— While-True   if s(b) is true
    (while b do S, s) ⟹ s''

    ————————————————————————— While-False   if s(b) is false
    (while b do S, s) ⟹ s

Above, `s(e)` denotes the value of expression `e` in state `s`.

In Lean, the judgment corresponds to an inductive predicate, and the derivation
rules correspond to the predicate's introduction rules. Using an inductive
predicate as opposed to a recursive function allows us to cope with
nontermination (e.g., a diverging `while`) and nondeterminism (e.g.,
multithreading). -/

inductive big_step : stmt × state → state → Prop
| skip {s} :
  big_step (stmt.skip, s) s
| assign {x a s} :
  big_step (stmt.assign x a, s) (s{x ↦ a s})
| seq {S T s t u} (hS : big_step (S, s) t)
    (hT : big_step (T, t) u) :
  big_step (S ;; T, s) u
| ite_true {b : state → Prop} {S T s t} (hcond : b s)
    (hbody : big_step (S, s) t) :
  big_step (stmt.ite b S T, s) t
| ite_false {b : state → Prop} {S T s t} (hcond : ¬ b s)
    (hbody : big_step (T, s) t) :
  big_step (stmt.ite b S T, s) t
| while_true {b : state → Prop} {S s t u} (hcond : b s)
    (hbody : big_step (S, s) t)
    (hrest : big_step (stmt.while b S, t) u) :
  big_step (stmt.while b S, s) u
| while_false {b : state → Prop} {S s} (hcond : ¬ b s) :
  big_step (stmt.while b S, s) s

infix ` ⟹ ` : 110 := big_step

/-! ## Properties of the Big-Step Semantics

Equipped with a big-step semantics, we can

* prove properties of the programming language, such as **equivalence proofs**
  between programs and **determinism**;

* reason about **concrete programs**, proving theorems relating final states `t`
  with initial states `s`. -/

lemma big_step_deterministic {S s l r} (hl : (S, s) ⟹ l)
    (hr : (S, s) ⟹ r) :
  l = r :=
begin
    induction hl generalizing r,
    case big_step.skip : s t {
        cases hr,
        refl },
    case big_step.assign : x a s {
        cases hr,
        refl },
    case big_step.seq : S T s t l hS hT ihS ihT {
        cases hr with _ _ _ _ _ _ _ t' _ hS' hT',
        cases ihS hS',
        cases ihT hT',
        refl },
    case big_step.ite_true : b S T s t hb hS ih {
        cases hr,
        { apply ih,
        assumption },
        { apply ih,
        cc } },
    case big_step.ite_false : b S T s t hb hT ih {
        cases hr,
        { apply ih,
        cc },
        { apply ih,
        assumption } },
    case big_step.while_true : b S s t u hb hS hw ihS ihw {
        cases hr,
        { cases ihS hr_hbody,
        cases ihw hr_hrest,
        refl },
        { cc } },
    { cases hr,
        { cc },
        { refl } }
end

lemma big_step_terminates {S s} :
  ∃t, (S, s) ⟹ t :=
sorry   -- unprovable

lemma big_step_doesnt_terminate {S s t} :
  ¬ (stmt.while (λ_, true) S, s) ⟹ t :=
begin
  generalize hws : (stmt.while (λ_, true) S, s) = ws,
  intro hw,
  induction hw generalizing s,
  case big_step.while_true : b S s t u hcond hbody hrest ih_body
      ih_rest {
    cases hws,
    apply ih_rest,
    refl },
  case big_step.while_false : b S s hcond {
    cases hws,
    apply hcond,
    apply true.intro },
  all_goals { cases hws }
end

@[simp] lemma big_step_skip_iff {s t} :
  (stmt.skip, s) ⟹ t ↔ t = s :=
begin
  apply iff.intro,
  { intro h,
    cases h,
    refl },
  { intro h,
    rewrite h,
    exact big_step.skip }
end

@[simp] lemma big_step_assign_iff {x a s t} :
  (stmt.assign x a, s) ⟹ t ↔ t = s{x ↦ a s} :=
begin
  apply iff.intro,
  { intro h,
    cases h,
    refl },
  { intro h,
    rewrite h,
    exact big_step.assign }
end

@[simp] lemma big_step_seq_iff {S T s t} :
  (S ;; T, s) ⟹ t ↔ (∃u, (S, s) ⟹ u ∧ (T, u) ⟹ t) :=
begin
  apply iff.intro,
  { intro h,
    cases h,
    apply exists.intro,
    apply and.intro; assumption },
  { intro h,
    cases h,
    cases h_h,
    apply big_step.seq; assumption }
end

@[simp] lemma big_step_ite_iff {b S T s t} :
  (stmt.ite b S T, s) ⟹ t ↔
  (b s ∧ (S, s) ⟹ t) ∨ (¬ b s ∧ (T, s) ⟹ t) :=
begin
  apply iff.intro,
  { intro h,
    cases h,
    { apply or.intro_left,
      cc },
    { apply or.intro_right,
      cc } },
  { intro h,
    cases h; cases h,
    { apply big_step.ite_true; assumption },
    { apply big_step.ite_false; assumption } }
end

lemma big_step_while_iff {b S s u} :
  (stmt.while b S, s) ⟹ u ↔
  (∃t, b s ∧ (S, s) ⟹ t ∧ (stmt.while b S, t) ⟹ u)
  ∨ (¬ b s ∧ u = s) :=
begin
  apply iff.intro,
  { intro h,
    cases h,
    { apply or.intro_left,
      apply exists.intro h_t,
      cc },
    { apply or.intro_right,
      cc } },
  { intro h,
    cases h,
    case or.inl {
      cases h with t h,
      cases h with hb h,
      cases h with hS hwhile,
      exact big_step.while_true hb hS hwhile },
    case or.inr {
      cases h with hb hus,
      rewrite hus,
      exact big_step.while_false hb } }
end

lemma big_step_while_true_iff {b : state → Prop} {S s u}
    (hcond : b s) :
  (stmt.while b S, s) ⟹ u ↔
  (∃t, (S, s) ⟹ t ∧ (stmt.while b S, t) ⟹ u) :=
by rewrite big_step_while_iff; simp [hcond]

@[simp] lemma big_step_while_false_iff {b : state → Prop}
    {S s t} (hcond : ¬ b s) :
  (stmt.while b S, s) ⟹ t ↔ t = s :=
by rewrite big_step_while_iff; simp [hcond]

/-! ## Small-Step Semantics

A big-step semantics

* does not let us reason about intermediate states;

* does not let us express nontermination or interleaving (for multithreading).

__Small-step semantics__ (also called __structural operational semantics__)
solve the above issues.

A judgment has the form `(S, s) ⇒ (T, t)`:

    Starting in a state `s`, executing one step of `S` leaves us in the
    state `t`, with the program `T` remaining to be executed.

An execution is a finite or infinite chain `(S₀, s₀) ⇒ (S₁, s₁) ⇒ …`.

A pair `(S, s)` is called a __configuration__. It is __final__ if no transition
of the form `(S, s) ⇒ _` is possible.

Example:

      `(x := x + y; y := 0, [x ↦ 3, y ↦ 5])`
    `⇒ (skip; y := 0,       [x ↦ 8, y ↦ 5])`
    `⇒ (y := 0,             [x ↦ 8, y ↦ 5])`
    `⇒ (skip,               [x ↦ 8, y ↦ 0])`

Derivation rules:

    ————————————————————————————————— Asn
    (x := a, s) ⇒ (skip, s[x ↦ s(a)])

    (S, s) ⇒ (S', s')
    ———————————————————————— Seq-Step
    (S; T, s) ⇒ (S' ; T, s')

    —————————————————————— Seq-Skip
    (skip ; S, s) ⇒ (S, s)

    ————————————————————————————————— If-True   if s(b) is true
    (if b then S else S', s) ⇒ (S, s)

    —————————————————————————————————— If-False   if s(b) is false
    (if b then S else S', s) ⇒ (S', s)

    ————————————————————————————————————————————————————————————————— While
    (while b do S, s) ⇒ (if b then (S ; while b do S) else skip, s)

There is no rule for `skip` (why?). -/

inductive small_step : stmt × state → stmt × state → Prop
| assign {x a s} :
  small_step (stmt.assign x a, s) (stmt.skip, s{x ↦ a s})
| seq_step {S S' T s s'} (hS : small_step (S, s) (S', s')) :
  small_step (S ;; T, s) (S' ;; T, s')
| seq_skip {T s} :
  small_step (stmt.skip ;; T, s) (T, s)
| ite_true {b : state → Prop} {S T s} (hcond : b s) :
  small_step (stmt.ite b S T, s) (S, s)
| ite_false {b : state → Prop} {S T s} (hcond : ¬ b s) :
  small_step (stmt.ite b S T, s) (T, s)
| while {b : state → Prop} {S s} :
  small_step (stmt.while b S, s)
    (stmt.ite b (S ;; stmt.while b S) stmt.skip, s)

infixr ` ⇒ ` := small_step
infixr ` ⇒* ` : 100 := star small_step

/-! Equipped with a small-step semantics, we can **define** a big-step
semantics:

> `(S, s) ⟹ s'` if and only if `(S, s) ⇒* (skip, s')`

where `r*` denotes the reflexive transitive closure of a relation `r`.

Alternatively, if we have already defined a big-step semantics, we can **prove**
the above equivalence theorem to validate our definitions.

The main disadvantage of small-step semantics is that we now have two relations,
`⇒` and `⇒*`, and reasoning tends to be more complicated.

## Properties of the Small-Step Semantics

We can prove that a configuration `(S, s)` is final if and only if `S = skip`.
This ensures that we have not forgotten a derivation rule. -/

lemma small_step_final {S s} :
  (¬ ∃T t, (S, s) ⇒ (T, t)) ↔ S = stmt.skip :=
begin
  induction S,
  case stmt.skip {
    simp,
    intros T t hstep,
    cases hstep },
  case stmt.assign : x a {
    simp,
    intro hall,
    exact hall _ _ small_step.assign },
  case stmt.seq : S T ihS ihT {
    simp,
    intro hall,
    cases classical.em (S = stmt.skip),
    case or.inl {
      apply hall T s,
      rewrite h,
      exact small_step.seq_skip },
    case or.inr {
      simp [h, auto.not_forall_eq, auto.not_not_eq] at ihS,
      cases ihS with S' hS',
      cases hS' with s' hs',
      apply hall (S' ;; T) s',
      exact small_step.seq_step hs' } },
  case stmt.ite : b S T ihS ihT {
    simp,
    intro hall,
    cases classical.em (b s),
    repeat {
      apply hall,
      exact small_step.ite_true h
      <|> exact small_step.ite_false h } },
  case stmt.while {
    simp,
    intro hall,
    apply hall,
    exact small_step.while }
end

lemma small_step_deterministic {S s Ll Rr}
    (hl : (S, s) ⇒ Ll) (hr : (S, s) ⇒ Rr) :
  Ll = Rr :=
begin
  induction hl generalizing Rr,
  case small_step.assign : x a s {
    cases hr,
    refl },
  case small_step.seq_step : S S₁ T s s₁ hS₁ ih {
    cases hr,
    case small_step.seq_step : S₂ s₂ hS₂ {
      have hSs₁₂ := ih hS₂,
      cc },
    case small_step.seq_skip {
      cases hS₁ } },
  case small_step.seq_skip : T s {
    cases hr,
    case small_step.seq_step : S₂ s₂ hS₂ {
      cases hS₂ },
    case small_step.seq_skip {
      refl } },
  case small_step.ite_true : b S T s hcond {
    cases hr,
    case small_step.ite_true {
      refl },
    case small_step.ite_false {
      cc } },
  case small_step.ite_false : b S T s hcond {
    cases hr,
    case small_step.ite_true {
      cc },
    case small_step.ite_false {
      refl } },
  case small_step.while : b S s {
    cases hr,
    refl }
end

/-! We can define inversion rules also about the small-step semantics. Here are
three examples: -/

lemma small_step_skip {S s t} :
  ¬ ((stmt.skip, s) ⇒ (S, t)) :=
by intro h; cases h

@[simp] lemma small_step_seq_iff {S T s Ut} :
  (S ;; T, s) ⇒ Ut ↔
  (∃S' t, (S, s) ⇒ (S', t) ∧ Ut = (S' ;; T, t))
  ∨ (S = stmt.skip ∧ Ut = (T, s)) :=
begin
  apply iff.intro,
  { intro h,
    cases h,
    { apply or.intro_left,
      apply exists.intro h_S',
      apply exists.intro h_s',
      cc },
    { apply or.intro_right,
      cc } },
  { intro h,
    cases h,
    { cases h,
      cases h_h,
      cases h_h_h,
      rewrite h_h_h_right,
      apply small_step.seq_step,
      assumption },
    { cases h,
      rewrite h_left,
      rewrite h_right,
      apply small_step.seq_skip } }
end

@[simp] lemma small_step_ite_iff {b S T s Us} :
  (stmt.ite b S T, s) ⇒ Us ↔
  (b s ∧ Us = (S, s)) ∨ (¬ b s ∧ Us = (T, s)) :=
begin
  apply iff.intro,
  { intro h,
    cases h,
    { apply or.intro_left,
      cc },
    { apply or.intro_right,
      cc } },
  { intro h,
    cases h,
    { cases h,
      rewrite h_right,
      apply small_step.ite_true,
      assumption },
    { cases h,
      rewrite h_right,
      apply small_step.ite_false,
      assumption } }
end

/-! ### Equivalence of the Big-Step and the Small-Step Semantics (**optional**)

A more important result is the connection between the big-step and the
small-step semantics:

    `(S, s) ⟹ t ↔ (S, s) ⇒* (stmt.skip, t)`

Its proof, given below, is beyond the scope of this course. -/

lemma star_small_step_seq {S T s u}
    (h : (S, s) ⇒* (stmt.skip, u)) :
  (S ;; T, s) ⇒* (stmt.skip ;; T, u) :=
begin
  apply star.lift (λSs, (prod.fst Ss ;; T, prod.snd Ss)) _ h,
  intros Ss Ss' h,
  cases Ss,
  cases Ss',
  simp,
  apply small_step.seq_step,
  assumption
end

lemma star_small_step_of_big_step {S s t} (h : (S, s) ⟹ t) :
  (S, s) ⇒* (stmt.skip, t) :=
begin
  induction h,
  case big_step.skip {
    refl },
  case big_step.assign {
    exact star.single small_step.assign },
  case big_step.seq : S T s t u hS hT ihS ihT {
    transitivity,
    exact star_small_step_seq ihS,
    apply star.head small_step.seq_skip ihT },
  case big_step.ite_true : b S T s t hs hst ih {
    exact star.head (small_step.ite_true hs) ih },
  case big_step.ite_false : b S T s t hs hst ih {
    exact star.head (small_step.ite_false hs) ih },
  case big_step.while_true : b S s t u hb hS hw ihS ihw {
    exact (star.head small_step.while
      (star.head (small_step.ite_true hb)
         (star.trans (star_small_step_seq ihS)
            (star.head small_step.seq_skip ihw)))) },
  case big_step.while_false : b S s hb {
    exact star.tail (star.single small_step.while)
      (small_step.ite_false hb) }
end

lemma big_step_of_small_step_of_big_step {S₀ S₁ s₀ s₁ s₂} :
  (S₀, s₀) ⇒ (S₁, s₁) → (S₁, s₁) ⟹ s₂ → (S₀, s₀) ⟹ s₂ :=
begin
  generalize hSs₀ : (S₀, s₀) = Ss₀,
  generalize hSs₁ : (S₁, s₁) = Ss₁,
  intro h,
  induction h generalizing S₀ s₀ S₁ s₁ s₂;
    cases hSs₁; clear hSs₁; cases hSs₀; clear hSs₀;
    simp [*, big_step_while_true_iff] { contextual := tt },
  { intros u hS' hT,
    apply exists.intro u,
    exact and.intro (h_ih (eq.refl _) (eq.refl _) hS') hT }
end

lemma big_step_of_star_small_step {S s t} :
  (S, s) ⇒* (stmt.skip, t) → (S, s) ⟹ t :=
begin
  generalize hSs : (S, s) = Ss,
  intro h,
  induction h
      using LoVe.rtc.star.head_induction_on
      with _ S's' h h' ih
      generalizing S s;
    cases hSs; clear hSs,
  { exact big_step.skip },
  { cases S's' with S' s',
    apply big_step_of_small_step_of_big_step h,
    apply ih,
    refl }
end

lemma big_step_iff_star_small_step {S s t} :
  (S, s) ⟹ t ↔ (S, s) ⇒* (stmt.skip, t) :=
iff.intro star_small_step_of_big_step
  big_step_of_star_small_step

/-! ## Parallelism (**optional**) -/

inductive par_step :
    nat → list stmt × state → list stmt × state → Prop
| intro {Ss Ss' S S' s s' i}
    (hi : i < list.length Ss)
    (hS : S = list.nth_le Ss i hi)
    (hs : (S, s) ⇒ (S', s'))
    (hS' : Ss' = list.update_nth Ss i S') :
  par_step i (Ss, s) (Ss', s')

lemma par_step_diamond {i j Ss Ts Ts' s t t'}
    (hi : i < list.length Ss)
    (hj : j < list.length Ss)
    (hij : i ≠ j)
    (hT : par_step i (Ss, s) (Ts, t))
    (hT' : par_step j (Ss, s) (Ts', t')) :
  ∃u Us, par_step j (Ts, t) (Us, u) ∧
    par_step i (Ts', t') (Us, u) :=
sorry   -- unprovable

def stmt.W : stmt → set string
| stmt.skip         := ∅
| (stmt.assign x _) := {x}
| (stmt.seq S T)    := stmt.W S ∪ stmt.W T
| (stmt.ite _ S T)  := stmt.W S ∪ stmt.W T
| (stmt.while _ S)  := stmt.W S

def exp.R {α : Type} : (state → α) → set string
| f := {x | ∀s n, f (s{x ↦ n}) ≠ f s}

def stmt.R : stmt → set string
| stmt.skip         := ∅
| (stmt.assign _ a) := exp.R a
| (stmt.seq S T)    := stmt.R S ∪ stmt.R T
| (stmt.ite b S T)  := exp.R b ∪ stmt.R S ∪ stmt.R T
| (stmt.while b S)  := exp.R b ∪ stmt.R S

def stmt.V : stmt → set string
| S := stmt.W S ∪ stmt.R S

lemma par_step_diamond_VW_disjoint {i j Ss Ts Ts' s t t'}
    (hiS : i < list.length Ss)
    (hjT : j < list.length Ts)
    (hij : i ≠ j)
    (hT : par_step i (Ss, s) (Ts, t))
    (hT' : par_step j (Ss, s) (Ts', t'))
    (hWV : stmt.W (list.nth_le Ss i hiS)
       ∩ stmt.V (list.nth_le Ts j hjT) = ∅)
    (hVW : stmt.V (list.nth_le Ss i hiS)
       ∩ stmt.W (list.nth_le Ts j hjT) = ∅) :
  ∃u Us, par_step j (Ts, t) (Us, u) ∧
    par_step i (Ts', t') (Us, u) :=
sorry   -- this should be provable

end LoVe


axiom Foo : Type
axiom foo : Foo

/- This works -/
def works : Prop :=
-- ∀ (x : Foo),
let ⟨foo₁, foo₂⟩ := (foo, foo);
false

/-
The following tests fail because the elaborator fails to propagate the expected type. The main issue is that the elaborator is missing the following case:

If the expected type is `Prop` for an expression `Forall (x : A), t`, then we should also elaborate `t` with expected type `Prop`. Note that every single example works if we write them as `Forall (x : A), (t : Prop)`.
-/

/- Uncommenting breaks it -/
def fails₁ : Prop :=
∀ (x : Foo),
let ⟨foo₁, foo₂⟩ := (foo, foo);
false
-- let_destruct_inside_forall.lean:11:4: error: invalid match/convoy expression, expected type is not known

/- All the following variations fail as well with the same message -/
def fails₂ : Prop :=
∀ (x : Foo),
let (⟨foo₁, foo₂⟩ : Foo × Foo) := (foo, foo);
foo₁ = foo₂

def fails₃ : Prop :=
∀ (x : Foo),
let (⟨foo₁, foo₂⟩ : Foo × Foo) := (foo, foo);
false

def fails₄ : Prop :=
∀ (x : Foo),
let (⟨foo₁, foo₂⟩ : Foo × Foo) := ((foo, foo) : Foo × Foo);
false

def fails₅ : Prop :=
∀ (x : Foo),
let p : Foo × Foo := (foo, foo);
let ⟨foo₁, foo₂⟩ := p;
foo₁ = foo₂