import .size data.list.perm
open nnf list

namespace list
universes u v w

variables {α : Type u} {β : Type v} {γ : Type w}

theorem mapp {p : β → Prop} (f : α → β) : Π (l : list α) (h : ∀ x∈l, p (f x)) x, x ∈ list.map f l → p x
| [] h x := by simp
| (hd::tl) h x :=
begin
  intro hmem, cases hmem,
  { simp [hmem, h] },
  { apply mapp tl _ _ hmem, intros a ha, simp [h, ha] }
end

def ne_empty_head : Π l : list α, l ≠ [] → α
| []       h := by contradiction
| (a :: l) h := a

end list

@[simp] def unbox : list nnf → list nnf
| [] := []
| ((box φ) :: l) := φ :: unbox l
| (e :: l) := unbox l

theorem unbox_sublist_cons {Γ : list nnf} {φ} : unbox Γ <+ unbox (φ :: Γ) :=
by cases heq : φ ; { simp }

theorem unbox_sublist : Π {Γ₁ Γ₂ : list nnf} (h : Γ₁ <+ Γ₂),
unbox Γ₁ <+ unbox Γ₂
| [] Γ₂ h := by simp
| (hd::tl) [] h := by have := eq_nil_of_sublist_nil h; contradiction
| (hd₁::tl₁) (hd₂::tl₂) h :=
begin
  cases h with _ _ _ c₁ _ _ _ c₂,
  { simp [sublist.trans (unbox_sublist c₁), unbox_sublist_cons] },
  { cases heq : hd₁,
    case nnf.box : ψ { simp [sublist.cons2, unbox_sublist c₂] },
    all_goals { simp [unbox_sublist c₂] } }
end

theorem unbox_erase : Π {Γ : list nnf} {φ},
(unbox Γ).erase φ = unbox (Γ.erase (box φ))
| [] φ := by simp
| (hd::tl) φ :=
begin
  cases heq : hd,
  case nnf.box : ψ
  { dsimp, by_cases hφ : ψ = φ,
    { simp [hφ] },
    { rw [erase_cons_tail, erase_cons_tail], simp,
     apply unbox_erase, intro hbe, simp at hbe, apply hφ hbe, exact hφ} },
  all_goals { simp [unbox_erase] }
end

theorem unbox_erase_of_ne_box : Π {Γ : list nnf} {φ : nnf} (h : ∀ ψ, φ ≠ box ψ), unbox (Γ.erase φ) = unbox Γ
| [] φ h := by simp
| (hd::tl) φ h :=
begin
cases heq : hd,
case nnf.box : ψ
{ dsimp, by_cases hφ : φ = box ψ,
  { exfalso, apply h _ hφ },
  { rw erase_cons_tail, simp,
    apply unbox_erase_of_ne_box h,
    intro, rw a at hφ, contradiction } },
all_goals
{ dsimp, by_cases hφ : φ = hd,
 { simp [hφ, heq] },
 { rw heq at hφ, rw erase_cons_tail, simp,
   apply unbox_erase_of_ne_box h,
   intro, rw a at hφ, contradiction } }
end

theorem unbox_diff : Π {Γ₁ Γ₂ : list nnf},
(unbox Γ₂).diff (unbox Γ₁) = unbox (Γ₂.diff Γ₁)
| [] Γ₂ := by simp
| (hd::tl) Γ₂ :=
begin
  cases heq : hd,
  case nnf.box : ψ { simp [unbox_diff, unbox_erase] },
  all_goals
  { by_cases hin : hd ∈ Γ₂,
   { simp, rw [←heq, ←(@unbox_diff tl (Γ₂.erase hd)), unbox_erase_of_ne_box],
    intros ψ hψ, rw heq at hψ, contradiction },
  { simp, rw [←heq, erase_of_not_mem hin], apply unbox_diff } }
end

theorem unbox_iff : Π {Γ φ}, box φ ∈ Γ ↔ φ ∈ unbox Γ
| [] φ := begin split, repeat {intro h, simpa using h} end
| (hd::tl) φ :=
begin
  split,
  { intro h, cases h₁ : hd,
    case nnf.box : ψ
    { cases h,
       {left, rw h₁ at h, injection h},
       {right, exact (@unbox_iff tl φ).1 h} },
    all_goals
    { cases h,
       {rw h₁ at h, contradiction},
       {exact (@unbox_iff tl φ).1 h} } },
  { intro h, cases h₁ : hd,
    case nnf.box : ψ
    { rw h₁ at h, cases h,
       {simp [h]}, {right, exact (@unbox_iff tl φ).2 h} },
    all_goals
    { rw h₁ at h, right, exact (@unbox_iff tl φ).2 h } }
end

theorem unbox_size_aux : Π {Γ}, node_size (unbox Γ) ≤ node_size Γ
| [] := by simp
| (hd::tl) :=
begin
  cases h : hd,
  case nnf.box : ψ
  { apply add_le_add,
     { dsimp [sizeof, has_sizeof.sizeof, nnf.sizeof],
       rw add_comm, apply nat.le_succ },
     { apply unbox_size_aux } },
  all_goals
  { dsimp, apply le_add_of_nonneg_of_le,
    { dsimp [sizeof, has_sizeof.sizeof, nnf.sizeof], rw add_comm, apply nat.zero_le },
    { apply unbox_size_aux } }
end

theorem unbox_size : Π {Γ φ}, dia φ ∈ Γ →
                     node_size (unbox Γ) + sizeof φ < node_size Γ
| [] := by simp
| (hd::tl) :=
begin
  intros φ h,
  cases h₁ : hd,
  case nnf.box : ψ
  { dsimp, cases h,
    { rw h₁ at h, contradiction },
    { rw add_assoc, apply add_lt_add,
      { dsimp [sizeof, has_sizeof.sizeof, nnf.sizeof], rw add_comm, apply nat.lt_succ_self },
      { apply unbox_size h } } },
  case nnf.dia : ψ
  { dsimp, rw add_comm, cases h,
    { rw h₁ at h, have : φ = ψ, { injection h }, rw this,
      apply add_lt_add_of_lt_of_le,
      { dsimp [sizeof, has_sizeof.sizeof, nnf.sizeof], rw add_comm, apply nat.lt_succ_self },
      { apply unbox_size_aux } },
    { apply lt_add_of_pos_of_lt,
     { dsimp [sizeof, has_sizeof.sizeof, nnf.sizeof], rw add_comm, apply nat.succ_pos },
     { rw add_comm, apply unbox_size h } } },
  all_goals
  { dsimp, apply nat.lt_add_left, apply unbox_size,
    cases h, rw h₁ at h, contradiction, exact h }
end

@[simp] def rebox : list nnf → list nnf
| [] := []
| (hd::tl) := box hd :: rebox tl

theorem rebox_unbox_of_mem : Π {Γ} (h : ∀ {φ}, φ ∈ unbox Γ → box φ ∈ Γ), rebox (unbox Γ) ⊆ Γ
| [] h := by simp
| (hd::tl) h :=
begin
  cases hψ : hd,
  case nnf.box : φ {simp [cons_subset_cons, subset_cons_of_subset, rebox_unbox_of_mem, unbox_iff]},
  all_goals {simp [subset_cons_of_subset, rebox_unbox_of_mem, unbox_iff]}
end

theorem unbox_rebox : Π {Γ}, unbox (rebox Γ) = Γ
| [] := by simp
| (hd::tl) := by simp [unbox_rebox]

def box_only_rebox : Π {Γ}, box_only (rebox Γ)
| [] := {no_var := by simp,
         no_neg := by simp,
         no_and := by simp,
         no_or  := by simp,
         no_dia := by simp}
| (hd::tl) :=
begin
  cases h : hd,
  all_goals {
  exact { no_var := begin
                      intros n hn, cases hn, contradiction,
                      apply (@box_only_rebox tl).no_var, exact hn
                    end,
          no_neg := begin
                      intros n hn, cases hn, contradiction,
                      apply (@box_only_rebox tl).no_neg, exact hn
                    end,
          no_and := begin
                      intros φ ψ hand, cases hand, contradiction,
                      apply (@box_only_rebox tl).no_and, exact hand
                    end,
          no_or := begin
                     intros φ ψ hor, cases hor, contradiction,
                     apply (@box_only_rebox tl).no_or, exact hor
                   end,
          no_dia := begin
                      intros φ hdia, cases hdia, contradiction,
                      apply (@box_only_rebox tl).no_dia, exact hdia
                    end} }
end

theorem rebox_iff : Π {φ Γ}, box φ ∈ rebox Γ ↔ φ ∈ Γ
| φ [] := by simp
| φ (hd::tl) :=
begin
  split,
  { intro h, cases h₁ : hd,
    all_goals { cases h,
               { left, rw ←h₁, injection h },
               { right, exact (@rebox_iff φ tl).1 h } } },
  { intro h, cases h₁ : hd,
    all_goals { dsimp, cases h,
               { left, rw [←h₁, h]},
               { right, exact (@rebox_iff φ tl).2 h } } }
end

@[simp] def undia : list nnf → list nnf
| [] := []
| ((dia φ) :: l) := φ :: undia l
| (e :: l) := undia l

theorem undia_iff : Π {Γ φ}, dia φ ∈ Γ ↔ φ ∈ undia Γ
| [] φ := begin split, repeat {intro h, simpa using h} end
| (hd::tl) φ :=
begin
  split,
  { intro h, cases h₁ : hd,
    case nnf.dia : ψ
    { cases h,
       { left, rw h₁ at h, injection h },
       { right, exact (@undia_iff tl φ).1 h} },
    all_goals
    { cases h,
       { rw h₁ at h, contradiction },
       { exact (@undia_iff tl φ).1 h } } },
  { intro h, cases h₁ : hd,
    case nnf.dia : ψ
    { rw h₁ at h, cases h,
       { simp [h] }, {right, exact (@undia_iff tl φ).2 h} },
    all_goals
    { rw h₁ at h, right, exact (@undia_iff tl φ).2 h } }
end

theorem undia_size : Π {Γ φ}, φ ∈ undia Γ →
                     sizeof φ + node_size (unbox Γ) < node_size Γ
:=
begin intros Γ φ h, rw add_comm, apply unbox_size, rw undia_iff, exact h end

@[simp] def get_modal : list nnf → list nnf
| [] := []
| (φ@(dia ψ) :: l) := φ :: get_modal l
| (φ@(box ψ) :: l) := φ :: get_modal l
| (e :: l) := get_modal l

theorem get_modal_iff_dia : Π {Γ} {φ : nnf},
dia φ ∈ get_modal Γ ↔ dia φ ∈ Γ
| [] φ := by simp
| (hd::tl) φ :=
begin
  split,
  { intro h, cases heq : hd,
    case nnf.dia : ψ
    { rw heq at h, cases h, left, exact h, right, exact (@get_modal_iff_dia tl φ).1 h },
    case nnf.box : ψ
    { rw heq at h, cases h, contradiction, right, exact (@get_modal_iff_dia tl φ).1 h },
    all_goals
    { rw heq at h, right, exact (@get_modal_iff_dia tl φ).1 h } },
  { intro h, cases heq : hd,
    case nnf.dia : ψ
    { rw heq at h, cases h, left, exact h, right, exact (@get_modal_iff_dia tl φ).2 h },
    case nnf.box : ψ
    { rw heq at h, cases h, contradiction, right, exact (@get_modal_iff_dia tl φ).2 h },
    all_goals
    { rw heq at h, cases h, contradiction, exact (@get_modal_iff_dia tl φ).2 h } }
end

theorem get_modal_iff_box : Π {Γ} {φ : nnf},
box φ ∈ get_modal Γ ↔ box φ ∈ Γ
| [] φ := by simp
| (hd::tl) φ :=
begin
  split,
  { intro h, cases heq : hd,
    case nnf.box : ψ
    { rw heq at h, cases h, left, exact h, right, exact (@get_modal_iff_box tl φ).1 h },
    case nnf.dia : ψ
    { rw heq at h, cases h, contradiction, right, exact (@get_modal_iff_box tl φ).1 h },
    all_goals
    {rw heq at h, right, exact (@get_modal_iff_box tl φ).1 h } },
  { intro h, cases heq : hd,
    case nnf.box : ψ
    { rw heq at h, cases h, left, exact h, right, exact (@get_modal_iff_box tl φ).2 h },
    case nnf.dia : ψ
    { rw heq at h, cases h, contradiction, right, exact (@get_modal_iff_box tl φ).2 h },
    all_goals
    { rw heq at h, cases h, contradiction, exact (@get_modal_iff_box tl φ).2 h } }
end

def get_contra : Π Γ : list nnf,
                 psum {p : nat // var p ∈ Γ ∧ neg p ∈ Γ}
                      (∀ n, var n ∈ Γ → neg n ∉ Γ)
| []             := psum.inr $ λ _ h, absurd h $ not_mem_nil _
| (hd :: tl)     :=
begin
  cases h : hd,
  case nnf.var : n
  {apply dite (neg n ∈ tl),
    { intro t, exact psum.inl ⟨n, ⟨mem_cons_self _ _, mem_cons_of_mem _ t⟩⟩ },
    {intro e, cases (get_contra tl),
     {left, split, split,
      apply mem_cons_of_mem _ val.2.1,
      apply mem_cons_of_mem _ val.2.2},
     {right,
      intros m hm hin,
      by_cases eq : m=n,
      {apply e, cases hin, contradiction, rw ←eq, assumption},
      {cases hm, apply eq, injection hm, apply val _ hm,
       cases hin, contradiction, assumption} } }
  },
  case nnf.neg : n
  { apply dite (var n ∈ tl),
    { intro t, exact psum.inl ⟨n, ⟨mem_cons_of_mem _ t, mem_cons_self _ _⟩⟩ },
    { intro e,
      cases (get_contra tl),
      {left, split, split,
      apply mem_cons_of_mem _ val.2.1,
      apply mem_cons_of_mem _  val.2.2 },
      { right,
        intros m hm hin,
        by_cases eq : m=n,
        { apply e, cases hm, contradiction, rw ←eq, assumption },
        { cases hin, apply eq, injection hin, apply val,
          swap, exact hin, cases hm, contradiction, assumption } } } },
  all_goals
  { cases (get_contra tl),
    { left, constructor, constructor,
      apply mem_cons_of_mem, exact val.2.1,
      apply mem_cons_of_mem, exact val.2.2  },
    { right,
      intros m hm hin,
      {apply val, swap 3, exact m,
      cases hm, contradiction, assumption,
      cases hin, contradiction, assumption} } }
end

def get_and : Π Γ : list nnf,
              psum {p : nnf × nnf // and p.1 p.2 ∈ Γ}
                   (∀ φ ψ, nnf.and φ ψ ∉ Γ)
| []               := psum.inr $ λ _ _, not_mem_nil _
| (hd :: tl)       :=
begin
  cases h : hd,
  case nnf.and : φ ψ { left, constructor,swap,
                       constructor, exact φ, exact ψ, simp },
  all_goals
  { cases (get_and tl),
    { left, constructor,
      apply mem_cons_of_mem _ val.2},
      { right, intros γ ψ h,
        cases h, contradiction,
        apply val, assumption } }
end

def get_or : Π Γ : list nnf,
              psum {p : nnf × nnf // or p.1 p.2 ∈ Γ}
                   (∀ φ ψ, nnf.or φ ψ ∉ Γ)
| []               := psum.inr $ λ _ _, not_mem_nil _
| (hd :: tl)       :=
begin
  cases h : hd,
  case nnf.or : φ ψ { left, constructor,swap,
                       constructor, exact φ, exact ψ, simp },
  all_goals
  { cases (get_or tl),
    { left, constructor,
      apply mem_cons_of_mem _ val.2},
    { right, intros γ ψ h,
      cases h, contradiction,
      apply val, assumption } }
end

def get_dia : Π Γ : list nnf,
              psum {p : nnf // dia p ∈ Γ}
                   (∀ φ, nnf.dia φ ∉ Γ)
| []               := psum.inr $ λ _, not_mem_nil _
| (hd :: tl)       :=
begin
  cases h : hd,
  case nnf.dia : φ { left, constructor, swap, exact φ, simp },
  all_goals
  { cases (get_dia tl),
    { left, constructor,
      apply mem_cons_of_mem _ val.2},
    { right, intros γ h,
      cases h, contradiction,
      apply val, assumption } }
end

@[simp] def get_var : list nnf → list ℕ
| [] := []
| ((var n) :: l) := n :: get_var l
| (e :: l) := get_var l

theorem get_var_iff : Π {Γ n}, var n ∈ Γ ↔ n ∈ get_var Γ
| [] φ := begin split, repeat {intro h, simpa using h} end
| (hd::tl) φ :=
begin
  split,
  { intro h, cases h₁ : hd,
    case nnf.var : n
    { cases h,
       { left, rw h₁ at h, injection h },
       { right, exact (@get_var_iff tl φ).1 h } },
    all_goals
    { cases h,
       { rw h₁ at h, contradiction },
       { exact (@get_var_iff tl φ).1 h } } },
  { intro h, cases h₁ : hd,
    case nnf.var : n
    { rw h₁ at h, cases h,
       { simp [h] }, { right, exact (@get_var_iff tl φ).2 h } },
    all_goals
    { rw h₁ at h, right, exact (@get_var_iff tl φ).2 h } }
end


import algebra.category.Group.biproducts
import algebra.category.Group.abelian
import algebra.direct_sum.basic
import category_theory.preadditive.yoneda
import for_mathlib.AddCommGroup.epi

open category_theory
open category_theory.limits

def dfinsupp.add_equiv_pi_on_fintype {α : Type*} [fintype α] (X : α → Type*)
  [∀ i, add_comm_group (X i)] :
  (Π₀ i, X i) ≃+ (Π i, X i) :=
{ map_add' := λ x y, by { ext, simp, },
  ..dfinsupp.equiv_fun_on_fintype }

namespace AddCommGroup

universes v u

def pi_π {α : Type v} (X : α → AddCommGroup.{max v u}) (i) :
  AddCommGroup.of (Π i, X i) ⟶ X i :=
pi.eval_add_monoid_hom _ _

def pi_fan {α : Type v} (X : α → AddCommGroup.{max v u}) : fan X :=
fan.mk (AddCommGroup.of $ Π i, X i)
(λ b, pi_π _ _)

def pi_lift {α : Type v} {Y : AddCommGroup.{max v u}} (X : α → AddCommGroup.{max v u})
  (f : Π a, Y ⟶ X a) : Y ⟶ AddCommGroup.of (Π i, X i) :=
{ to_fun := λ y i, f _ y,
  map_zero' := by { ext, simp },
  map_add' := λ x y, by { ext, simp } }

@[simp, reassoc]
lemma pi_lift_π {α : Type v} {Y : AddCommGroup.{max v u}} (X : α → AddCommGroup.{max v u})
  (f : Π a, Y ⟶ X a) (i) :
  pi_lift X f ≫ pi_π _ i = f _ := by { ext, refl }

lemma pi_hom_ext {α : Type v} {Y : AddCommGroup.{max v u}} (X : α → AddCommGroup.{max v u})
  (f g : Y ⟶ AddCommGroup.of (Π i, X i))
  (h : ∀ i, f ≫ pi_π _ i = g ≫ pi_π _ i) : f = g :=
by { ext y a, specialize h a, apply_fun (λ e, e y) at h, exact h }

def is_limit_pi_fan {α : Type v} (X : α → AddCommGroup.{max v u}) :
  is_limit (pi_fan X) :=
{ lift := λ S, pi_lift _ $ S.π.app,
  fac' := begin
    intros S j,
    apply pi_lift_π,
  end,
  uniq' := begin
    intros S m hm,
    apply pi_hom_ext,
    intros i,
    erw [hm, pi_lift_π],
  end }

noncomputable
def hom_product_comparison
  {α : Type v}
  (A : AddCommGroup.{max v u})
  (X : α → AddCommGroup.{max v u}) :
  AddCommGroup.of (A ⟶ ∏ X) ⟶ ∏ (λ i, AddCommGroup.of (A ⟶ (X i))) :=
limits.pi.lift $ λ a, (preadditive_yoneda.flip.obj (opposite.op A)).map (limits.pi.π _ _)

instance is_iso_hom_product_comparison
  {α : Type v}
  (A : AddCommGroup.{max v u})
  (X : α → AddCommGroup.{max v u}) :
  is_iso (hom_product_comparison A X) :=
begin
  --haveI : balanced Ab.{max v u} := AddcommGroup.abelian
  let t : (∏ λ (i : α), AddCommGroup.of (A ⟶ X i)) ≅ AddCommGroup.of
    (Π i, AddCommGroup.of (A ⟶ X i)) :=
    (limits.limit.is_limit _).cone_point_unique_up_to_iso
    (is_limit_pi_fan (λ i, of (A ⟶ X i))),
  suffices : is_iso (A.hom_product_comparison X ≫ t.hom),
  { apply is_iso.of_is_iso_comp_right _ t.hom, exact this },
  have ht : A.hom_product_comparison X ≫ t.hom =
    (is_limit_pi_fan (λ i, of (A ⟶ X i))).lift
    ⟨_, discrete.nat_trans $ λ i, (preadditive_yoneda.flip.obj (opposite.op A)).map
      (limits.pi.π _ _)⟩,
  { apply (is_limit_pi_fan _).hom_ext, intros j,
    simp [hom_product_comparison] },
  rw ht, clear ht,
  apply_with is_iso_of_mono_of_epi { instances := ff },
  apply_instance,
  { rw mono_iff_injective,
    intros f g h,
    ext1 j,
    apply_fun (λ e, e j) at h,
    exact h },
  { rw epi_iff_surjective,
    intros f,
    use limits.pi.lift (λ i, f i),
    dsimp [is_limit_pi_fan, pi_lift],
    simp [pi_lift_π] }
end

def direct_sum_π {α : Type v} (X : α → AddCommGroup.{max v u}) (i) :
  AddCommGroup.of (direct_sum α (λ i, X i)) ⟶ X i :=
{ to_fun := λ f, let e : Π₀ (i : α), (X i) := f in e i,
  map_zero' := by simp,
  map_add' := λ x y, by { dsimp, simp } }

def direct_sum_fan {α : Type v} (X : α → AddCommGroup.{max v u}) : fan X :=
fan.mk (AddCommGroup.of (direct_sum α (λ i, X i)))
(λ b, direct_sum_π _ _)

open_locale classical

def direct_sum_lift {α : Type v} [fintype α]
  {Y : AddCommGroup.{max v u}} (X : α → AddCommGroup.{max v u})
  (f : Π a, Y ⟶ X a) :
  Y ⟶ AddCommGroup.of (direct_sum α (λ i, X i)) :=
{ to_fun := λ y, (dfinsupp.add_equiv_pi_on_fintype _).symm $ λ i, f i y,
  map_zero' := begin
    simp_rw map_zero,
    change ((dfinsupp.add_equiv_pi_on_fintype (λ (i : α), ↥(X i))).symm) 0 = _,
    simp,
  end,
  map_add' := begin
    intros x y,
    simp_rw map_add,
    change ((dfinsupp.add_equiv_pi_on_fintype (λ (i : α), ↥(X i))).symm)
      ((λ (i : α), (f i) x) + (λ (i : α), (f i) y)) = _,
    simp,
  end }

@[simp, reassoc]
lemma direct_sum_lift_π {α : Type v} [fintype α]
  {Y : AddCommGroup.{max v u}} (X : α → AddCommGroup.{max v u})
  (f : Π a, Y ⟶ X a) (i) :
  direct_sum_lift X f ≫ direct_sum_π _ i = f i :=
by { ext, refl }

lemma direct_sum_hom_ext {α : Type v} [fintype α]
  {Y : AddCommGroup.{max v u}} (X : α → AddCommGroup.{max v u})
  (f g : Y ⟶ AddCommGroup.of (direct_sum α (λ i, X i)))
  (h : ∀ i, f ≫ direct_sum_π _ i = g ≫ direct_sum_π _ i) :
  f = g :=
begin
  ext,
  specialize h i,
  apply_fun (λ e, e x) at h, exact h
end

def is_limit_direct_sum_fan {α : Type v} [fintype α]
  (X : α → AddCommGroup.{max v u}) : is_limit (direct_sum_fan X) :=
{ lift := λ S, direct_sum_lift _ $ S.π.app,
  fac' := begin
    intros S j,
    apply direct_sum_lift_π,
  end,
  uniq' := begin
    intros S m hm,
    apply direct_sum_hom_ext,
    intros i,
    specialize hm i,
    erw [hm, direct_sum_lift_π],
  end }

noncomputable theory

def to_direct_sum {α : Type v} (X : α → AddCommGroup.{max v u})
  (i : α) : X i ⟶ AddCommGroup.of (direct_sum α (λ i, X i)) :=
direct_sum.of (λ i, X i) i

def direct_sum_punit_iso (A : AddCommGroup.{max v u}) :
  AddCommGroup.of (direct_sum _ (λ i : punit.{v+1}, A)) ≅ A :=
{ hom := direct_sum_π _ punit.star,
  inv := to_direct_sum (λ i, A) punit.star,
  hom_inv_id' := begin
    ext ⟨⟩ ⟨⟩,
    ext t ⟨⟩, -- WAT?
    dsimp [direct_sum_π, to_direct_sum],
    simp,
  end,
  inv_hom_id' := begin
    ext a,
    dsimp [direct_sum_π, to_direct_sum],
    simp,
  end }

def direct_sum_ι {α : Type v} (X : α → AddCommGroup.{max v u})
  (i : α) : X i ⟶ AddCommGroup.of (direct_sum α (λ i, X i)) :=
direct_sum.of _ i

def direct_sum_desc {α : Type v} {Y : AddCommGroup.{max v u}} (X : α → AddCommGroup.{max v u})
  (f : Π i, X i ⟶ Y) :
  AddCommGroup.of (direct_sum α (λ i, X i)) ⟶ Y :=
direct_sum.to_add_monoid f

@[simp, reassoc]
lemma direct_sum_ι_desc {α : Type v} {Y : AddCommGroup.{max v u}}
  (X : α → AddCommGroup.{max v u})
  (f : Π i, X i ⟶ Y) (i) :
  direct_sum_ι X i ≫ direct_sum_desc X f = f _ :=
by { ext, dsimp [direct_sum_ι, direct_sum_desc], simp }

lemma direct_sum_hom_ext' {α : Type v} {Y : AddCommGroup.{max v u}}
  (X : α → AddCommGroup.{max v u})
  (f g : AddCommGroup.of (direct_sum α (λ i, X i)) ⟶ Y)
  (h : ∀ i, direct_sum_ι X i ≫ f = direct_sum_ι X i ≫ g) :
  f = g :=
begin
  have hf : f = direct_sum_desc X (λ i, direct_sum_ι X i ≫ f),
  { ext t, apply direct_sum.to_add_monoid.unique },
  have hg : g = direct_sum_desc X (λ i, direct_sum_ι X i ≫ g),
  { ext t, apply direct_sum.to_add_monoid.unique },
  rw [hf, hg],
  congr' 1, ext i, rw h,
end

def direct_sum_cofan {α : Type v}
  (X : α → AddCommGroup.{max v u}) : cofan X :=
cofan.mk _ (direct_sum_ι _)

def is_colimit_direct_sum_cofan {α : Type v}
  (X : α → AddCommGroup.{max v u}) : is_colimit (direct_sum_cofan X) :=
{ desc := λ S, direct_sum_desc X S.ι.app,
  fac' := begin
    intros X j,
    apply direct_sum_ι_desc,
  end,
  uniq' := begin
    intros S m hm,
    apply direct_sum_hom_ext',
    intros i,
    specialize hm i,
    erw hm, rw direct_sum_ι_desc,
  end }

lemma direct_sum_ι_π {α : Type v} (X : α → AddCommGroup.{max v u}) (i : α) :
  direct_sum_ι.{v u} X i ≫ direct_sum_π.{v u} X i = 𝟙 _ :=
begin
  ext,
  dsimp [direct_sum_ι, direct_sum_π, direct_sum.of],
  simp only [comp_apply, dfinsupp.single_add_hom_apply, add_monoid_hom.coe_mk,
    dfinsupp.single_apply],
  split_ifs, refl, refl,
end

lemma direct_sum_ι_π_of_ne {α : Type v} (X : α → AddCommGroup.{max v u}) (i j : α) (h : i ≠ j):
  direct_sum_ι.{v u} X i ≫ direct_sum_π.{v u} X j = 0 :=
begin
  ext,
  dsimp [direct_sum_ι, direct_sum_π, direct_sum.of],
  simp only [comp_apply, dfinsupp.single_add_hom_apply, add_monoid_hom.coe_mk,
    dfinsupp.single_apply],
  split_ifs, contradiction, refl,
end

-- `bicone` is not sufficiently universe polymorphic.
def direct_sum_bicone {α : Type u} [fintype α]
  (X : α → AddCommGroup.{u}) : bicone X :=
{ X := AddCommGroup.of (direct_sum α (λ i, X i)),
  π := direct_sum_π.{u u} _,
  ι := direct_sum_ι.{u u} _,
  ι_π := λ i j, begin
    ext t,
    dsimp [direct_sum_ι, direct_sum_π, direct_sum.of],
    simp only [comp_apply, dfinsupp.single_add_hom_apply, add_monoid_hom.coe_mk,
      dfinsupp.single_apply],
    split_ifs, subst h, refl, refl,
  end }

def is_bilimit_direct_sum_bicone {α : Type u} [fintype α]
  (X : α → AddCommGroup.{u}) :
  bicone.is_bilimit (direct_sum_bicone X) :=
{ is_limit := is_limit_direct_sum_fan.{u u} X,
  is_colimit := is_colimit_direct_sum_cofan.{u u} X }

end AddCommGroup


import cdclt
import cdclt
import euf

open proof
open proof.sort proof.term
open rules

open eufRules

def U := atom 50
def a₁ := const 100 U
def a₂ := const 101 U
def a₃ := const 102 U
def a₄ := const 103 U
def b₁ := const 104 U
def b₂ := const 105 U
def f₁ := const 106 (mkArrowN [U, U, U])
def f₂ := const 107 (mkArrowN [U, U, U])
def f₃ := const 108 (mkArrowN [U, U])

noncomputable theorem binCong :
  thHolds (mkEq a₁ a₂) → thHolds (mkEq b₁ b₂) → (thHolds (mkEq (mkApp (mkApp f₁ a₁) b₁) (mkApp (mkApp f₁ a₂) b₂))) :=
assume s0 : thHolds (mkEq a₁ a₂),
assume s1 : thHolds (mkEq b₁ b₂),
have s2 : thHolds (mkEq f₁ f₁), from refl,
show (thHolds (mkEq (mkApp (mkApp f₁ a₁) b₁) (mkApp (mkApp f₁ a₂) b₂))), from cong (cong s2 s0) s1

-- constant c0 : thHolds (mkEq (mkApp f₃ a₁) (mkApp f₃ a₂))
-- #check c0
-- #check (const eq_num dep)
-- #check cong

-- #eval mkApp (const eq_num dep) (mkApp f₃ a₁)

-- constant c1 : (cong (const eq_num dep) c0)

-- noncomputable theorem rwCong :
--   thHolds (mkEq a₁ a₂) → thHolds (mkEq (mkEq (mkApp f₃ a₁) b₁) (mkEq (mkApp f₃ a₂) b₁)) :=
-- assume s0 : thHolds (mkEq a₁ a₂),
-- have s1 : thHolds (mkEq (mkApp f₃ a₁) (mkApp f₃ a₂)), from (cong f₃ s0),
-- have s2 : thHolds (mkEq b₁ b₁), from refl,
-- show thHolds (mkEq (mkEq (mkApp f₃ a₁) b₁) (mkEq (mkApp f₃ a₂) b₁)), from congHO (cong (const eq_num dep) s1) s2

noncomputable theorem threeTrans :
  thHolds (mkEq a₁ a₂) → thHolds (mkEq a₂ a₃) → thHolds (mkEq a₃ a₄) → thHolds (mkEq a₁ a₄) :=
assume s0 : thHolds (mkEq a₁ a₂),
assume s1 : thHolds (mkEq a₂ a₃),
assume s2 : thHolds (mkEq a₃ a₄),
show thHolds (mkEq a₁ a₄), from trans (trans s0 s1) s2

def a1a2 := mkEq a₁ a₂
def f3a1 := (mkApp f₃ a₁)
def f3a2 := (mkApp f₃ a₂)
def f3a1f3a2 := mkEq f3a1 f3a2
def nf3a1f3a2 := mkNot f3a1f3a2

noncomputable theorem test1 :
  thHolds a1a2 → thHolds nf3a1f3a2 → holds [] :=
assume s0 : thHolds a1a2,
assume s1 : thHolds nf3a1f3a2,
have s2 : thHolds (mkEq f₃ f₃), from refl,
have s3 : thHolds f3a1f3a2, from cong s2 s0,
have s4 : holds [mkNot a1a2, f3a1f3a2], from clOr (scope s0 s3),
show holds [], from R0 (R0 (clAssume s0) s4 a1a2) (clAssume s1) f3a1f3a2

def p := const 109 boolsort
def np := mkNot p

noncomputable theorem test2 :
  thHolds a1a2 → thHolds (mkOr np nf3a1f3a2) → thHolds p → holds [] :=
assume s0 : thHolds a1a2,
assume s1 : thHolds (mkOr np nf3a1f3a2),
assume s2 : thHolds p,
have s3 : thHolds (mkEq f₃ f₃), from refl,
have s4 : holds [np, nf3a1f3a2], from clOr s1,
have s5 : thHolds f3a1f3a2, from cong s3 s0,
have s6 : holds [mkNot a1a2, f3a1f3a2], from clOr (scope s0 s5),
show holds [], from R0 (R0 (clAssume s0) s6 a1a2) (R0 (clAssume s2) s4 p) f3a1f3a2

def b1b2 := mkEq b₁ b₂
def f1a1 := mkApp f₁ a₁
def f1a1b1 := mkApp f1a1 b₁
def f1a2 := mkApp f₁ a₂
def f1a2b2 := mkApp f1a2 b₂
def eqf1ab := mkEq f1a1b1 f1a2b2
def neqf1ab := mkNot eqf1ab

noncomputable theorem test3 :
  thHolds a1a2 → thHolds b1b2 → thHolds neqf1ab  → holds [] :=
assume s0 : thHolds a1a2,
assume s1 : thHolds b1b2,
assume s2 : thHolds neqf1ab,
have s3 : thHolds (mkEq f₁ f₁), from refl,
have s4 : thHolds eqf1ab, from cong (cong s3 s0) s1,
have s5 : holds [mkNot a1a2, mkNot b1b2, eqf1ab], from clOr (scope s0 (scope s1 s4)),
show holds [], from R0 (R0 (clAssume s1) (R0 (clAssume s0) s5 a1a2) b1b2) (clAssume s2) eqf1ab


/-
Copyright (c) 2019 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Bhavik Mehta
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.comma
import Mathlib.category_theory.punit
import Mathlib.category_theory.reflects_isomorphisms
import Mathlib.category_theory.epi_mono
import Mathlib.PostPort

universes v₁ u₁ v₂ u₂

namespace Mathlib

/-!
# Over and under categories

Over (and under) categories are special cases of comma categories.
* If `L` is the identity functor and `R` is a constant functor, then `comma L R` is the "slice" or
  "over" category over the object `R` maps to.
* Conversely, if `L` is a constant functor and `R` is the identity functor, then `comma L R` is the
  "coslice" or "under" category under the object `L` maps to.

## Tags

comma, slice, coslice, over, under
-/

namespace category_theory

/--
The over category has as objects arrows in `T` with codomain `X` and as morphisms commutative
triangles.

See https://stacks.math.columbia.edu/tag/001G.
-/
def over {T : Type u₁} [category T] (X : T) := comma 𝟭 (functor.from_punit X)

-- Satisfying the inhabited linter

protected instance over.inhabited {T : Type u₁} [category T] [Inhabited T] :
    Inhabited (over Inhabited.default) :=
  { default := comma.mk 𝟙 }

namespace over

theorem over_morphism.ext {T : Type u₁} [category T] {X : T} {U : over X} {V : over X} {f : U ⟶ V}
    {g : U ⟶ V} (h : comma_morphism.left f = comma_morphism.left g) : f = g :=
  sorry

@[simp] theorem over_right {T : Type u₁} [category T] {X : T} (U : over X) :
    comma.right U = PUnit.unit :=
  of_as_true trivial

@[simp] theorem id_left {T : Type u₁} [category T] {X : T} (U : over X) :
    comma_morphism.left 𝟙 = 𝟙 :=
  rfl

@[simp] theorem comp_left {T : Type u₁} [category T] {X : T} (a : over X) (b : over X) (c : over X)
    (f : a ⟶ b) (g : b ⟶ c) :
    comma_morphism.left (f ≫ g) = comma_morphism.left f ≫ comma_morphism.left g :=
  rfl

@[simp] theorem w {T : Type u₁} [category T] {X : T} {A : over X} {B : over X} (f : A ⟶ B) :
    comma_morphism.left f ≫ comma.hom B = comma.hom A :=
  sorry

/-- To give an object in the over category, it suffices to give a morphism with codomain `X`. -/
@[simp] theorem mk_left {T : Type u₁} [category T] {X : T} {Y : T} (f : Y ⟶ X) :
    comma.left (mk f) = Y :=
  Eq.refl (comma.left (mk f))

/-- We can set up a coercion from arrows with codomain `X` to `over X`. This most likely should not
    be a global instance, but it is sometimes useful. -/
def coe_from_hom {T : Type u₁} [category T] {X : T} {Y : T} : has_coe (Y ⟶ X) (over X) :=
  has_coe.mk mk

@[simp] theorem coe_hom {T : Type u₁} [category T] {X : T} {Y : T} (f : Y ⟶ X) : comma.hom ↑f = f :=
  rfl

/-- To give a morphism in the over category, it suffices to give an arrow fitting in a commutative
    triangle. -/
def hom_mk {T : Type u₁} [category T] {X : T} {U : over X} {V : over X}
    (f : comma.left U ⟶ comma.left V)
    (w :
      autoParam (f ≫ comma.hom V = comma.hom U)
        (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
          (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])) :
    U ⟶ V :=
  comma_morphism.mk

/--
Construct an isomorphism in the over category given isomorphisms of the objects whose forward
direction gives a commutative triangle.
-/
@[simp] theorem iso_mk_inv_left {T : Type u₁} [category T] {X : T} {f : over X} {g : over X}
    (hl : comma.left f ≅ comma.left g)
    (hw :
      autoParam (iso.hom hl ≫ comma.hom g = comma.hom f)
        (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
          (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])) :
    comma_morphism.left (iso.inv (iso_mk hl)) = iso.inv hl :=
  Eq.refl (iso.inv hl)

/--
The forgetful functor mapping an arrow to its domain.

See https://stacks.math.columbia.edu/tag/001G.
-/
def forget {T : Type u₁} [category T] (X : T) : over X ⥤ T := comma.fst 𝟭 (functor.from_punit X)

@[simp] theorem forget_obj {T : Type u₁} [category T] {X : T} {U : over X} :
    functor.obj (forget X) U = comma.left U :=
  rfl

@[simp] theorem forget_map {T : Type u₁} [category T] {X : T} {U : over X} {V : over X}
    {f : U ⟶ V} : functor.map (forget X) f = comma_morphism.left f :=
  rfl

/--
A morphism `f : X ⟶ Y` induces a functor `over X ⥤ over Y` in the obvious way.

See https://stacks.math.columbia.edu/tag/001G.
-/
def map {T : Type u₁} [category T] {X : T} {Y : T} (f : X ⟶ Y) : over X ⥤ over Y :=
  comma.map_right 𝟭 (discrete.nat_trans fun (_x : discrete PUnit) => f)

@[simp] theorem map_obj_left {T : Type u₁} [category T] {X : T} {Y : T} {f : X ⟶ Y} {U : over X} :
    comma.left (functor.obj (map f) U) = comma.left U :=
  rfl

@[simp] theorem map_obj_hom {T : Type u₁} [category T] {X : T} {Y : T} {f : X ⟶ Y} {U : over X} :
    comma.hom (functor.obj (map f) U) = comma.hom U ≫ f :=
  rfl

@[simp] theorem map_map_left {T : Type u₁} [category T] {X : T} {Y : T} {f : X ⟶ Y} {U : over X}
    {V : over X} {g : U ⟶ V} :
    comma_morphism.left (functor.map (map f) g) = comma_morphism.left g :=
  rfl

/-- Mapping by the identity morphism is just the identity functor. -/
def map_id {T : Type u₁} [category T] {Y : T} : map 𝟙 ≅ 𝟭 :=
  nat_iso.of_components (fun (X : over Y) => iso_mk (iso.refl (comma.left (functor.obj (map 𝟙) X))))
    sorry

/-- Mapping by the composite morphism `f ≫ g` is the same as mapping by `f` then by `g`. -/
def map_comp {T : Type u₁} [category T] {X : T} {Y : T} {Z : T} (f : X ⟶ Y) (g : Y ⟶ Z) :
    map (f ≫ g) ≅ map f ⋙ map g :=
  nat_iso.of_components
    (fun (X_1 : over X) => iso_mk (iso.refl (comma.left (functor.obj (map (f ≫ g)) X_1)))) sorry

protected instance forget_reflects_iso {T : Type u₁} [category T] {X : T} :
    reflects_isomorphisms (forget X) :=
  reflects_isomorphisms.mk
    fun (Y Z : over X) (f : Y ⟶ Z) (t : is_iso (functor.map (forget X) f)) =>
      is_iso.mk (hom_mk (inv (functor.map (forget X) f)))

protected instance forget_faithful {T : Type u₁} [category T] {X : T} : faithful (forget X) :=
  faithful.mk

/--
If `k.left` is an epimorphism, then `k` is an epimorphism. In other words, `over.forget X` reflects
epimorphisms.
The converse does not hold without additional assumptions on the underlying category.
-/
-- TODO: Show the converse holds if `T` has binary products or pushouts.

theorem epi_of_epi_left {T : Type u₁} [category T] {X : T} {f : over X} {g : over X} (k : f ⟶ g)
    [hk : epi (comma_morphism.left k)] : epi k :=
  faithful_reflects_epi (forget X) hk

/--
If `k.left` is a monomorphism, then `k` is a monomorphism. In other words, `over.forget X` reflects
monomorphisms.
The converse of `category_theory.over.mono_left_of_mono`.

This lemma is not an instance, to avoid loops in type class inference.
-/
theorem mono_of_mono_left {T : Type u₁} [category T] {X : T} {f : over X} {g : over X} (k : f ⟶ g)
    [hk : mono (comma_morphism.left k)] : mono k :=
  faithful_reflects_mono (forget X) hk

/--
If `k` is a monomorphism, then `k.left` is a monomorphism. In other words, `over.forget X` preserves
monomorphisms.
The converse of `category_theory.over.mono_of_mono_left`.
-/
protected instance mono_left_of_mono {T : Type u₁} [category T] {X : T} {f : over X} {g : over X}
    (k : f ⟶ g) [mono k] : mono (comma_morphism.left k) :=
  mono.mk
    fun (Y : T) (l m : Y ⟶ comma.left f)
      (a : l ≫ comma_morphism.left k = m ≫ comma_morphism.left k) =>
      let l' : mk (m ≫ comma.hom f) ⟶ f := hom_mk l;
      congr_arg comma_morphism.left
        (eq.mpr (id (Eq._oldrec (Eq.refl (l' = hom_mk m)) (Eq.symm (propext (cancel_mono k)))))
          (over_morphism.ext a))

/-- Given f : Y ⟶ X, this is the obvious functor from (T/X)/f to T/Y -/
@[simp] theorem iterated_slice_forward_obj {T : Type u₁} [category T] {X : T} (f : over X)
    (α : over f) :
    functor.obj (iterated_slice_forward f) α = mk (comma_morphism.left (comma.hom α)) :=
  Eq.refl (functor.obj (iterated_slice_forward f) α)

/-- Given f : Y ⟶ X, this is the obvious functor from T/Y to (T/X)/f -/
@[simp] theorem iterated_slice_backward_map {T : Type u₁} [category T] {X : T} (f : over X)
    (g : over (comma.left f)) (h : over (comma.left f)) (α : g ⟶ h) :
    functor.map (iterated_slice_backward f) α = hom_mk (hom_mk (comma_morphism.left α)) :=
  Eq.refl (functor.map (iterated_slice_backward f) α)

/-- Given f : Y ⟶ X, we have an equivalence between (T/X)/f and T/Y -/
@[simp] theorem iterated_slice_equiv_counit_iso {T : Type u₁} [category T] {X : T} (f : over X) :
    equivalence.counit_iso (iterated_slice_equiv f) =
        nat_iso.of_components
          (fun (g : over (comma.left f)) =>
            iso_mk
              (iso.refl
                (comma.left
                  (functor.obj (iterated_slice_backward f ⋙ iterated_slice_forward f) g))))
          (iterated_slice_equiv._proof_5 f) :=
  Eq.refl (equivalence.counit_iso (iterated_slice_equiv f))

theorem iterated_slice_forward_forget {T : Type u₁} [category T] {X : T} (f : over X) :
    iterated_slice_forward f ⋙ forget (comma.left f) = forget f ⋙ forget X :=
  rfl

theorem iterated_slice_backward_forget_forget {T : Type u₁} [category T] {X : T} (f : over X) :
    iterated_slice_backward f ⋙ forget f ⋙ forget X = forget (comma.left f) :=
  rfl

/-- A functor `F : T ⥤ D` induces a functor `over X ⥤ over (F.obj X)` in the obvious way. -/
@[simp] theorem post_map_right {T : Type u₁} [category T] {X : T} {D : Type u₂} [category D]
    (F : T ⥤ D) (Y₁ : over X) (Y₂ : over X) (f : Y₁ ⟶ Y₂) :
    comma_morphism.right (functor.map (post F) f) =
        id
          (fun (F : T ⥤ D) (Y₁ Y₂ : over X) (f : Y₁ ⟶ Y₂) =>
            ulift.up (eq.mpr post._proof_1 (plift.up (of_as_true trivial))))
          F Y₁ Y₂ f :=
  Eq.refl (comma_morphism.right (functor.map (post F) f))

end over

/-- The under category has as objects arrows with domain `X` and as morphisms commutative
    triangles. -/
def under {T : Type u₁} [category T] (X : T) := comma (functor.from_punit X) 𝟭

-- Satisfying the inhabited linter

protected instance under.inhabited {T : Type u₁} [category T] [Inhabited T] :
    Inhabited (under Inhabited.default) :=
  { default := comma.mk 𝟙 }

namespace under

theorem under_morphism.ext {T : Type u₁} [category T] {X : T} {U : under X} {V : under X}
    {f : U ⟶ V} {g : U ⟶ V} (h : comma_morphism.right f = comma_morphism.right g) : f = g :=
  sorry

@[simp] theorem under_left {T : Type u₁} [category T] {X : T} (U : under X) :
    comma.left U = PUnit.unit :=
  of_as_true trivial

@[simp] theorem id_right {T : Type u₁} [category T] {X : T} (U : under X) :
    comma_morphism.right 𝟙 = 𝟙 :=
  rfl

@[simp] theorem comp_right {T : Type u₁} [category T] {X : T} (a : under X) (b : under X)
    (c : under X) (f : a ⟶ b) (g : b ⟶ c) :
    comma_morphism.right (f ≫ g) = comma_morphism.right f ≫ comma_morphism.right g :=
  rfl

@[simp] theorem w {T : Type u₁} [category T] {X : T} {A : under X} {B : under X} (f : A ⟶ B) :
    comma.hom A ≫ comma_morphism.right f = comma.hom B :=
  sorry

/-- To give an object in the under category, it suffices to give an arrow with domain `X`. -/
@[simp] theorem mk_left {T : Type u₁} [category T] {X : T} {Y : T} (f : X ⟶ Y) :
    comma.left (mk f) = PUnit.unit :=
  Eq.refl (comma.left (mk f))

/-- To give a morphism in the under category, it suffices to give a morphism fitting in a
    commutative triangle. -/
@[simp] theorem hom_mk_left {T : Type u₁} [category T] {X : T} {U : under X} {V : under X}
    (f : comma.right U ⟶ comma.right V)
    (w :
      autoParam (comma.hom U ≫ f = comma.hom V)
        (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
          (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])) :
    comma_morphism.left (hom_mk f) =
        id
          (fun {X : T} {U V : under X} (f : comma.right U ⟶ comma.right V)
            (w : comma.hom U ≫ f = comma.hom V) =>
            eq.mpr hom_mk._proof_1
              (ulift.up (eq.mpr hom_mk._proof_2 (plift.up (of_as_true trivial)))))
          X U V f w :=
  Eq.refl (comma_morphism.left (hom_mk f))

/--
Construct an isomorphism in the over category given isomorphisms of the objects whose forward
direction gives a commutative triangle.
-/
def iso_mk {T : Type u₁} [category T] {X : T} {f : under X} {g : under X}
    (hr : comma.right f ≅ comma.right g) (hw : comma.hom f ≫ iso.hom hr = comma.hom g) : f ≅ g :=
  comma.iso_mk (eq_to_iso sorry) hr sorry

@[simp] theorem iso_mk_hom_right {T : Type u₁} [category T] {X : T} {f : under X} {g : under X}
    (hr : comma.right f ≅ comma.right g) (hw : comma.hom f ≫ iso.hom hr = comma.hom g) :
    comma_morphism.right (iso.hom (iso_mk hr hw)) = iso.hom hr :=
  rfl

@[simp] theorem iso_mk_inv_right {T : Type u₁} [category T] {X : T} {f : under X} {g : under X}
    (hr : comma.right f ≅ comma.right g) (hw : comma.hom f ≫ iso.hom hr = comma.hom g) :
    comma_morphism.right (iso.inv (iso_mk hr hw)) = iso.inv hr :=
  rfl

/-- The forgetful functor mapping an arrow to its domain. -/
def forget {T : Type u₁} [category T] (X : T) : under X ⥤ T := comma.snd (functor.from_punit X) 𝟭

@[simp] theorem forget_obj {T : Type u₁} [category T] {X : T} {U : under X} :
    functor.obj (forget X) U = comma.right U :=
  rfl

@[simp] theorem forget_map {T : Type u₁} [category T] {X : T} {U : under X} {V : under X}
    {f : U ⟶ V} : functor.map (forget X) f = comma_morphism.right f :=
  rfl

/-- A morphism `X ⟶ Y` induces a functor `under Y ⥤ under X` in the obvious way. -/
def map {T : Type u₁} [category T] {X : T} {Y : T} (f : X ⟶ Y) : under Y ⥤ under X :=
  comma.map_left 𝟭 (discrete.nat_trans fun (_x : discrete PUnit) => f)

@[simp] theorem map_obj_right {T : Type u₁} [category T] {X : T} {Y : T} {f : X ⟶ Y} {U : under Y} :
    comma.right (functor.obj (map f) U) = comma.right U :=
  rfl

@[simp] theorem map_obj_hom {T : Type u₁} [category T] {X : T} {Y : T} {f : X ⟶ Y} {U : under Y} :
    comma.hom (functor.obj (map f) U) = f ≫ comma.hom U :=
  rfl

@[simp] theorem map_map_right {T : Type u₁} [category T] {X : T} {Y : T} {f : X ⟶ Y} {U : under Y}
    {V : under Y} {g : U ⟶ V} :
    comma_morphism.right (functor.map (map f) g) = comma_morphism.right g :=
  rfl

/-- Mapping by the identity morphism is just the identity functor. -/
def map_id {T : Type u₁} [category T] {Y : T} : map 𝟙 ≅ 𝟭 :=
  nat_iso.of_components
    (fun (X : under Y) => iso_mk (iso.refl (comma.right (functor.obj (map 𝟙) X))) sorry) sorry

/-- Mapping by the composite morphism `f ≫ g` is the same as mapping by `f` then by `g`. -/
def map_comp {T : Type u₁} [category T] {X : T} {Y : T} {Z : T} (f : X ⟶ Y) (g : Y ⟶ Z) :
    map (f ≫ g) ≅ map g ⋙ map f :=
  nat_iso.of_components
    (fun (X_1 : under Z) => iso_mk (iso.refl (comma.right (functor.obj (map (f ≫ g)) X_1))) sorry)
    sorry

/-- A functor `F : T ⥤ D` induces a functor `under X ⥤ under (F.obj X)` in the obvious way. -/
@[simp] theorem post_map_left {T : Type u₁} [category T] {D : Type u₂} [category D] {X : T}
    (F : T ⥤ D) (Y₁ : under X) (Y₂ : under X) (f : Y₁ ⟶ Y₂) :
    comma_morphism.left (functor.map (post F) f) =
        id
          (fun {X : T} (F : T ⥤ D) (Y₁ Y₂ : under X) (f : Y₁ ⟶ Y₂) =>
            ulift.up (eq.mpr post._proof_1 (plift.up (of_as_true trivial))))
          X F Y₁ Y₂ f :=
  Eq.refl (comma_morphism.left (functor.map (post F) f))

end Mathlib


import FOL.deduction

universes u v
open_locale logic_symbol

namespace fol
open logic formula

structure Structure (L : language.{u}) :=
(dom : Type u)
(inhabited : inhabited dom)
(fn : ∀ {n}, L.fn n → (fin n → dom) → dom)
(pr : ∀ {n}, L.pr n → (fin n → dom) → Prop)

local notation (name := dom) `|`M`|` := Structure.dom M

variables {L : language.{u}} {M : Structure L}

instance (M : Structure L) : inhabited M.dom := M.inhabited

variables (M)

@[simp] def term.val (e : ℕ → |M|) : term L → |M|
| (#x)           := e x
| (term.app f v) := M.fn f (λ i, (v i).val)

@[simp] def formula.val : ∀ (e : ℕ → |M|), formula L → Prop
| _ ⊤                 := true
| e (formula.app p v) := M.pr p (λ i, (v i).val M e)
| e (t =' u)          := t.val M e = u.val M e
| e (p ⟶ q)          := p.val e → q.val e
| e (∼p)              := ¬(p.val e)
| e (∀.p)            := ∀ d : M.dom, (p.val (d ⌢ e))

notation M` ⊧[`:80 e`] `p :50 := @formula.val _ M e p

def models (M : Structure L) (p : formula L) : Prop := ∀ (e : ℕ → |M|), M ⊧[e] p

instance : semantics (formula L) (Structure L) := ⟨models⟩

lemma models_def {M : Structure L} {p : formula L} : M ⊧ p ↔ (∀ (e : ℕ → |M|), M ⊧[e] p) := by refl

abbreviation satisfiable (p : formula L) : Prop := semantics.satisfiable (Structure L) p

abbreviation Satisfiable (T : Theory L) : Prop := semantics.Satisfiable (Structure L) T

instance : has_double_turnstile (Theory L) (formula L) := ⟨semantics.consequence (Structure L)⟩

lemma consequence_def {T : Theory L} {p : formula L} :
  T ⊧ p ↔ ∀ S : Structure L, S ⊧ T → S ⊧ p := by refl

variables {M}

lemma rew_val_eq (s : ℕ → term L) (e : ℕ → |M|) : ∀ (t : term L),
  (t.rew s).val M e = t.val M (λ n, (s n).val M e)
| (#x)                := by simp
| (@term.app _ n f v) := by simp[λ i : fin n, rew_val_eq (v i)]

@[simp] lemma pow_val_concat (e : ℕ → |M|) (d : |M|) (t : term L) : (t^1).val M (d ⌢ e) = t.val M e :=
by simp[term.pow_eq, rew_val_eq]

lemma rew_val_iff : ∀ (s : ℕ → term L) (p : formula L) (e : ℕ → |M|),
  (p.rew s).val M e ↔ p.val M (λ n, (s n).val M e)
| _ ⊤                 _ := by simp
| _ (formula.app p v) _ := by simp[formula.rew, rew_val_eq]
| _ (t =' u)          _ := by simp[formula.rew, term.val, rew_val_eq]
| _ (p ⟶ q)           _ := by simp[formula.rew, rew_val_iff _ p, rew_val_iff _ q]
| _ (∼p)              _ := by simp[formula.rew, rew_val_iff _ p]
| s (∀.p)            e :=
  by { simp[formula.rew, rew_val_iff _ p], refine forall_congr (λ d, _),
       have : (λ n, ((s ^ 1) n).val M (d ⌢ e) ) = (d ⌢ λ n, ((s n).val M e)),
       { funext n, cases n; simp[concat, term.val, term.val], exact pow_val_concat _ _ _ },
       simp[this] }

@[simp] lemma pow_val_concat_iff : ∀ (p : formula L) (e : ℕ → |M|) d, (p^1).val M (d ⌢ e) = p.val M e :=
by simp[formula.pow_eq, rew_val_iff]

@[simp] lemma Structure_zero_val [has_zero_symbol L] {e : ℕ → |M|} : (0 : term L).val M e = M.fn has_zero_symbol.zero finitary.nil :=
by simp[has_zero.zero]; congr

@[simp] lemma Structure_succ_val [has_succ_symbol L] (t : term L) {e : ℕ → |M|} :
  (Succ t).val M e = M.fn has_succ_symbol.succ ‹t.val M e› :=
by simp[has_succ.succ]; congr; ext; simp

private lemma modelsth_sf {T : Theory L} : M ⊧ T → M ⊧ ⤊T := λ h p hyp_p e,
by { rcases hyp_p with ⟨p, hyp_p', rfl⟩, simp[formula.pow_eq, rew_val_iff],
     refine h hyp_p' _ }

@[simp] lemma models_ex {p : formula L} {e : ℕ → |M|} : (∃.p).val M e ↔ ∃ d, p.val M (d ⌢ e) :=
by simp[has_exists_quantifier.ex, formula.ex, models, rew_val_iff]

lemma models_univs {p : formula L} {e : ℕ → |M|} {n} :
  (∀.[n] p).val M e ↔ ∀ d : finitary (|M|) n, p.val M (λ i, if h : i < n then d ⟨i, h⟩ else e (i - n)) :=
begin
  induction n with n IH generalizing e; simp,
  { refine ⟨λ h _, h, λ h, h ∅⟩ },
  { simp[IH], split,
    { intros h D, refine cast _ (h D.head_inv D.tail_inv), congr, funext i, simp[concat, slide],
      have C : i < n ∨ i = n ∨ n < i, exact trichotomous i n,
      cases C,
      { simp[C, nat.lt.step C, finitary.tail_inv] }, rcases C with (rfl | C),
      { simp[←nat.add_one], refl },
      { simp[show ¬i < n, from asymm C, show ¬i < n.succ, by omega, C, ←nat.add_one,
             show i - n - 1 = i - (n + 1), from tsub_tsub i n 1] } },
    { intros h d D, refine cast _ (h (D ᶠ:: d)), congr, funext i, simp[concat, slide],
      have C : i < n ∨ i = n ∨ n < i, exact trichotomous i n,
      cases C,
      { simp[C, nat.lt.step C, finitary.cons_inv] }, rcases C with (rfl | C),
      { simp[←nat.add_one] },
      { simp[show ¬i < n, from asymm C, show ¬i < n.succ, by omega, C, ←nat.add_one,
             show i - n - 1 = i - (n + 1), from tsub_tsub i n 1] } } }
end

@[simp] lemma models_and {p q : formula L} {e : ℕ → |M|} : (p ⊓ q).val M e ↔ (p.val M e ∧ q.val M e) :=
by simp[has_inf.inf, formula.and]

@[simp] lemma models_or {p q : formula L} {e : ℕ → |M|} : (p ⊔ q).val M e ↔ (p.val M e ∨ q.val M e) :=
by {simp[has_sup.sup, formula.or], exact or_iff_not_imp_left.symm }

@[simp] lemma models_iff {p q : formula L} {e : ℕ → |M|} : (p ⟷ q).val M e ↔ (p.val M e ↔ q.val M e) :=
by simp[lrarrow_def]; exact iff_def.symm

@[simp] lemma models_conjunction' {n : ℕ} {P : finitary (formula L) n} {e : ℕ → |M|} :
  (finitary.conjunction n P).val M e ↔ ∀ i, (P i).val M e :=
by { induction n with n IH; simp,
     { simp [IH], split,
       { rintros ⟨h0, h1⟩, intros i,
         have : i.val < n ∨ i.val = n := nat.lt_succ_iff_lt_or_eq.mp i.property,
         cases this,
         { have := h1 ⟨↑i, this⟩, simp at this, refine this },
         { simp[←this] at*, refine h0 } },
       { intros h, refine ⟨h _, λ _, h _⟩ } } }

@[simp] lemma models_pow {p : formula L} {i : ℕ} {e : ℕ → |M| } : (p^i).val M e ↔ p.val M (λ n, e (n + i)) :=
by simp[formula.pow_eq, rew_val_iff]

lemma models_subst {p : formula L} {i : ℕ} {t : term L} {e : ℕ → |M| } :
  (p.rew ı[i ⇝ t]).val M e ↔ p.val M (λ n, if n < i then e n else if i < n then e (n - 1) else t.val M e) :=
by { simp[rew_val_iff],
     have : (λ (n : ℕ), term.val M e (ı[i ⇝ t] n)) = (λ n, if n < i then e n else if i < n then e (n - 1) else t.val M e),
     { funext n,
       have C : n < i ∨ n = i ∨ i < n, exact trichotomous n i,
       cases C, simp[C],
       cases C; simp[C], simp[asymm C] },
     simp[this] }

@[simp] lemma models_subst_0 {p : formula L} {t : term L} {e : ℕ → |M|} :
  (p.rew ı[0 ⇝ t]).val M e ↔ p.val M (t.val M e ⌢ e) :=
by { have := @models_subst _ _ p 0 t e, simp at this,
     have eqn : (λ n, ite (0 < n) (e (n - 1)) (t.val M e)) = t.val M e ⌢ e,
     { funext n, cases n; simp }, rw[←eqn], exact this }

@[simp] lemma models_subst_1 {p : formula L} {t : term L} {e : ℕ → |M| } :
  (p.rew ı[1 ⇝ t]).val M e ↔ p.val M (e 0 ⌢ t.val M e ⌢ (λ x, e (x + 1))) :=
by { have := @models_subst _ _ p 1 t e,
     have eqn : (λ n, ite (n < 1) (e n) (ite (1 < n) (e (n - 1)) (t.val M e))) =
       e 0 ⌢ t.val M e ⌢ (λ x, e (x + 1)),
     { funext n, cases n; simp[←nat.add_one], cases n; simp }, rw[←eqn], exact this }

lemma nfal_models_iff : ∀ {n} {p : formula L}, M ⊧ nfal p n ↔ M ⊧ p
| 0     _ := iff.rfl
| (n+1) p := by { simp[←@nfal_models_iff n p], refine ⟨λ h e, _, λ h e d, h _⟩,
  have : ((e 0) ⌢ λ x, e (x + 1) )= e, { ext x, cases x; simp[concat] },
  have := h (λ x, e (x + 1)) (e 0), simp* at* }

theorem soundness {T : Theory L} : ∀ {p}, T ⊢ p → T ⊧ p := λ p hyp,
begin
  rcases hyp,
  induction hyp,
  case generalize : T p hyp_p IH
  { intros M hyp_T e d, exact IH (modelsth_sf hyp_T) _ },
  case mdp : T p q hyp_pq hyp_p IH_pq IH_p
  { intros M hyp_T e, exact IH_pq hyp_T e (IH_p hyp_T e) },
  case by_axiom : T p hyp_p
  { intros M hyp_T e, exact hyp_T hyp_p _ },
  case verum : T
  { intros M hyp_T e, simp },
  case imply₁ : T p q
  { intros M hyp_T e h₁ h₂, exact h₁ },
  case imply₂ : T p q r
  { intros M hyp_T e h₁ h₂ h₃, exact (h₁ h₃) (h₂ h₃) },
  case contraposition : T p q
  { intros M hyp_T e h₁, simp[formula.val], contrapose, exact h₁ },
  case specialize : T p t
  { intros M hyp_T e h, simp[rew_val_iff] at h ⊢,
    have : (λ n, (ı[0 ⇝ t] n).val M e) = (t.val M e) ⌢ e,
    { funext n, cases n; simp[term.val, term.val, concat] },
    rw this, exact h _ },
  case univ_K : T p q
  { intros M hyp_T e h₁ h₂ d, exact (h₁ d) (h₂ d) },
  case dummy_univ : T p
  { intros M hyp_T e h d, simp, exact h },
  case eq_reflexivity : T
  { intros M hyp_T e t, simp[formula.val] },
  case eq_symmetry : T
  { intros M hyp_T e t₁ t₂, simp[formula.val], refine eq.symm },
  case eq_transitivity : T
  { intros M hyp_T e t₁ t₂ t₃, simp[formula.val], refine eq.trans },
  case function_ext : T n f
  { intros M hyp_T, simp[eq_axiom4, nfal_models_iff], intros e, simp,
    intros h, simp[h] },
  case predicate_ext : T n f
  { intros M hyp_T, simp[eq_axiom5, nfal_models_iff], intros e, simp,
    intros h, simp[h] }
end

theorem Structure_consistent {T : Theory L} : M ⊧ T → Theory.consistent T :=
by { contrapose, simp[Theory.consistent], intros p hp₁ hp₂ hyp,
     exact soundness hp₂ hyp (λ _, default) (soundness hp₁ hyp (λ _, default)) }

lemma eval_eq : ∀ {t : term L} {e₁ e₂ : ℕ → |M|},
  (∀ n, n < t.arity → e₁ n = e₂ n) → t.val M e₁ = t.val M e₂
| (#n)               _  _  eqs := by simp at *; refine eqs _ _; simp
| (@term.app _ n f v)  e₁ e₂ eqs := by { simp at *, congr, funext i, refine @eval_eq (v i) _ _ (λ n eqn, _),
  have : (v i).arity ≤ ⨆ᶠ i, (v i).arity, from le_fintype_sup (λ i, (v i).arity) i,
  refine eqs n (lt_of_lt_of_le eqn this) }

lemma eval_iff : ∀ {p : formula L} {e₁ e₂ : ℕ → |M|},
  (∀ n, n < p.arity → e₁ n = e₂ n) → (M ⊧[e₁] p ↔ M ⊧[e₂] p)
| ⊤                      _  _  _   := by simp
| (@formula.app _ n p v) e₁ e₂ eqs := by { simp at*,
    suffices : (λ i, term.val M e₁ (v i)) = (λ i, term.val M e₂ (v i)), { simp[this] },
    funext i, refine @eval_eq _ M (v i) _ _ (λ n eqn, eqs n _),
    have : (v i).arity ≤ ⨆ᶠ i, (v i).arity, from le_fintype_sup (λ i, (v i).arity) i,
    refine (lt_of_lt_of_le eqn this) }
| (t =' u)               e₁ e₂ eqs := by { simp[formula.arity] at*,
    simp[eval_eq (λ n h, eqs _ (or.inl h)), eval_eq (λ n h, eqs _ (or.inr h))] }
| (p ⟶ q)                e₁ e₂ eqs := by { simp[formula.arity] at*,
    simp[eval_iff (λ n h, eqs _ (or.inl h)), eval_iff (λ n h, eqs _ (or.inr h))] }
| (∼p)                   e₁ e₂ eqs := by { simp[formula.arity] at*,
    simp[eval_iff eqs] }
| (∀.p)                 e₁ e₂ eqs := by { simp[formula.arity] at*,
    have : ∀ (d : |M|), p.val M (d ⌢ e₁) ↔ p.val M (d ⌢ e₂),
    { intros d, refine eval_iff (λ n eqn, _),
      cases n; simp[concat], refine eqs _ (by omega) },
    exact forall_congr this }

lemma eval_is_sentence_iff {p : formula L} (e : ℕ → |M|) (a : is_sentence p) : M ⊧[e] p ↔ M ⊧ p :=
⟨λ h e, by { refine (eval_iff $ λ n h, _).1 h, exfalso,
 simp[is_sentence] at*, rw[a] at h, exact nat.not_lt_zero n h},
 λ h, h e⟩

lemma models_neg_iff_of_is_sentence {p : formula L} (hp : is_sentence p) : M ⊧ ∼p ↔ ¬M ⊧ p :=
by { have : M ⊧[default] ∼p ↔ ¬M ⊧[default] p, by simp,
     simp only [hp, show is_sentence (∼p), by simp[hp], eval_is_sentence_iff] at this, exact this }

end fol


import SciLean.Core
-- import SciLean.Tactic.AutoDiff

open SciLean

variable {α β γ : Type}
variable {X Y Z W : Type} [Vec X] [Vec Y] [Vec Z] [Vec W]
variable {Y₁ Y₂ : Type} [Vec Y₁] [Vec Y₂]

set_option maxHeartbeats 4000
set_option synthInstance.maxHeartbeats 1000
set_option synthInstance.maxSize 80

example (f : Y → Z) [IsSmoothT f] (g : X → Y) [IsSmoothT g]
  : ∂ (λ x => f (g x)) = λ x dx => ∂ f (g x) (∂ g x dx) := by symdiff

example (a : α) (f : Y → α → Z) [IsSmoothT f] (g : X → Y) [IsSmoothT g]
  : ∂ (λ x => f (g x) a) = λ x dx => ∂ f (g x) (∂ g x dx) a := by symdiff

example (f : Y → Z) [IsSmoothT f]
  : ∂ (λ (g : α → Y) (a : α) => f (g a)) = λ g dg a => ∂ f (g a) (dg a) := by symdiff

example
  : ∂ (λ (f : β → Z) (g : α → β) (a : α) => f (g a)) = λ f df (g : α → β) a => df (g a) := by symdiff

example (f : Y → β → Z) (g : X → Y) [IsSmoothT f] [IsSmoothT g] (b)
  : ∂ (λ x => f (g x) b) = λ x dx => ∂ f (g x) (∂ g x dx) b := by symdiff

example (f : Y → β → Z) [IsSmoothT f] (b)
  : ∂ (λ (g : α → Y) a => f (g a) b) = λ g dg a => ∂ f (g a) (dg a) b := by symdiff

example (f : β → Y → Z) (g : β → X → Y) [∀ b, IsSmoothT (f b)] [∀ b, IsSmoothT (g b)]
  : ∂ (λ x b => f b (g b x)) = λ x dx b => ∂ (f b) (g b x) (∂ (g b) x dx) := by symdiff

example (f : Y → β → Z) (g : X → Y) [IsSmoothT f] [IsSmoothT g]
  : ∂ (λ x b => f (g x) b) = λ x dx b => ∂ f (g x) (∂ g x dx) b := by symdiff

example (f : Y → β → Z) [IsSmoothT f]
  : ∂ (λ (g : α → Y) a b => f (g a) b) = λ g dg a b => ∂ f (g a) (dg a) b := by symdiff

example (f : Y₁ → β2 → Z) (g2 : α → β2) [IsSmoothT f] (g dg)
  : ∂ (λ  (g1 : α → Y₁) a => f (g1 a) (g2 a)) g dg = λ a => ∂ f (g a) (dg a) (g2 a) := by symdiff

example (f : β1 → Y₂ → Z) (g1 : α → β1) [∀ y1, IsSmoothT (f y1)]
  : ∂ (λ (g2 : α → Y₂) a => f (g1 a) (g2 a)) = λ g dg a => ∂ (f (g1 a)) (g a) (dg a) := by symdiff

example {α : Type} {β : α → Type} (a : α) [∀ a, Add (β a)]
  : (λ (f g : (a:α) → β a) a => (f + g) a) = (λ (f g : (a:α) → β a) a => f a + g a) := by symdiff; done

set_option synthInstance.maxSize 100 in
set_option synthInstance.maxHeartbeats 2000 in
example (f g : X → α → Y) [IsSmoothT f] [IsSmoothT g]
  : ∂ (λ x a => f x a + g x a)
    =
    λ x dx a => ∂ f x dx a + ∂ g x dx a := by symdiff; done

-- set_option maxHeartbeats 70000 in
-- set_option synthInstance.maxSize 2000 in
-- set_option synthInstance.maxHeartbeats 200000 in
-- example (f : Y₁ → Y₂ → β → Z) (g1 : X → Y₁) (g2 : X → Y₂)
--   [∀ y₁, IsSmoothT (f y₁)] [IsSmoothT λ y₁ => λ y₂ ⟿ f y₁ y₂] [IsSmoothT g1] [IsSmoothT g2]
--   : ∂ (λ (x : X) (b : β) => f (g1 x) (g2 x) b)
--     =
--     λ x dx b => ∂ f (g1 x) (∂ g1 x dx) (g2 x) b + ∂ (f (g1 x)) (g2 x) (∂ g2 x dx) b :=
-- by symdiff; done

example {X} [Hilbert X] : ∂ (λ x : X => ⟪x, x⟫) = λ x dx =>  ⟪dx, x⟫ + ⟪x, dx⟫ := by symdiff; done

example
  (f : Y → α → Z) [IsSmoothT f]
  (g : X → Y) [IsSmoothT g]
  (a : α)
  : ∂ (λ x => f (g x) a)
    =
    λ x dx =>
      ∂ f (g x) (∂ g x dx) a
  := by symdiff; done

--- Other a bit more disorganized tests

variable (f : Y → Z) [IsSmoothT f]
variable (g : X → Y) [IsSmoothT g]
variable (f1 : X → X) [IsSmoothT f1]
variable (f2 : Y → Y) [IsSmoothT f2]
variable (f3 : Z → Z) [IsSmoothT f3]
variable (F : X → Y → Z) [∀ x, IsSmoothT (F x)] [IsSmoothT λ x => λ y ⟿ F x y]
variable (G : X × Y → Z) [IsSmoothT G]

variable (x dx : X) (y dy : Y) (z dz : Z)

example : ∂ (λ x => f (g (f1 x))) x dx = ∂ f (g (f1 x)) (∂ g (f1 x) (∂ f1 x dx)) := by symdiff; done
example : ∂ (λ x : X => x + x) x dx = (2:ℝ) * dx := by symdiff; done

example : ∂ (λ (x : X) => F x (g x)) x dx = ∂ F x dx (g x) + ∂ (F x) (g x) (∂ g x dx) := by symdiff; done
example : ∂ (λ (x : X) => f3 (F x (g x))) x dx = ∂ f3 (F x (g x)) (∂ F x dx (g x) + ∂ (F x) (g x) (∂ g x dx)) := by symdiff; done
example g dg x : ∂ (λ (g : X → Y) => f (g x)) g dg = ∂ f (g x) (dg x) := by symdiff; done
example g dg x : ∂ (λ (g : X → Y) (x : X) => F x (g x)) g dg x = ∂ (F x) (g x) (dg x) := by symdiff; done
example g dg x : ∂ (λ (g : X → X) (y : Y) => F (g x) y) g dg y = ∂ F (g x) (dg x) y := by symdiff; done
set_option maxHeartbeats 5000 in
set_option synthInstance.maxHeartbeats 2000 in
example (r dr : ℝ) : ∂ (λ x : ℝ => x*x + x) r dr = dr * r + r * dr + dr := by symdiff; done
example g dg y : ∂ (λ (g : X → X) (x : X) => F (g x) y) g dg x = ∂ F (g x) (dg x) y := by symdiff; done
set_option maxHeartbeats 6000 in
set_option synthInstance.maxHeartbeats 2000 in
example (r dr : ℝ) : ∂ (λ x : ℝ => x*x*x + x) r dr = (dr * r + r * dr) * r + r * r * dr + dr := by symdiff; done

example : ⅆ (λ x : ℝ => ‖x‖²) = λ x => (2:ℝ) * x := by symdiff; done
example {X} [Hilbert X] (m k : ℝ) (p : X) : ∇ (λ x : X => 1/2*m * ‖p‖² + 1/2*k * ‖x‖²) = λ x : X => k * x := by symdiff; done
example {X} [Hilbert X] (m k : ℝ) (x : X) : ∇ (λ p : X => 1/(2*m) * ‖p‖² + 1/2*k * ‖x‖²) = λ p : X => 1/m * p := by symdiff; done


/-
Copyright (c) 2019 Reid Barton. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Reid Barton
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.fin_category
import Mathlib.category_theory.limits.cones
import Mathlib.category_theory.adjunction.basic
import Mathlib.order.bounded_lattice
import Mathlib.PostPort

universes v u l v₁ u₁

namespace Mathlib

/-!
# Filtered categories

A category is filtered if every finite diagram admits a cocone.
We give a simple characterisation of this condition as
1. for every pair of objects there exists another object "to the right",
2. for every pair of parallel morphisms there exists a morphism to the right so the compositions
   are equal, and
3. there exists some object.

Filtered colimits are often better behaved than arbitrary colimits.
See `category_theory/limits/types` for some details.

Filtered categories are nice because colimits indexed by filtered categories tend to be
easier to describe than general colimits (and often often preserved by functors).

In this file we show that any functor from a finite category to a filtered category admits a cocone:
* `cocone_nonempty [fin_category J] [is_filtered C] (F : J ⥤ C) : nonempty (cocone F)`
More generally,
for any finite collection of objects and morphisms between them in a filtered category
(even if not closed under composition) there exists some object `Z` receiving maps from all of them,
so that all the triangles (one edge from the finite set, two from morphisms to `Z`) commute.
This formulation is often more useful in practice. We give two variants,
`sup_exists'`, which takes a single finset of objects, and a finset of morphisms
(bundled with their sources and targets), and
`sup_exists`, which takes a finset of objects, and an indexed family (indexed by source and target)
of finsets of morphisms.

## Future work
* Finite limits commute with filtered colimits
* Forgetful functors for algebraic categories typically preserve filtered colimits.
-/

namespace category_theory

/--
A category `is_filtered_or_empty` if
1. for every pair of objects there exists another object "to the right", and
2. for every pair of parallel morphisms there exists a morphism to the right so the compositions
   are equal.
-/
class is_filtered_or_empty (C : Type u) [category C] where
  cocone_objs : ∀ (X Y : C), ∃ (Z : C), ∃ (f : X ⟶ Z), ∃ (g : Y ⟶ Z), True
  cocone_maps : ∀ {X Y : C} (f g : X ⟶ Y), ∃ (Z : C), ∃ (h : Y ⟶ Z), f ≫ h = g ≫ h

/--
A category `is_filtered` if
1. for every pair of objects there exists another object "to the right",
2. for every pair of parallel morphisms there exists a morphism to the right so the compositions
   are equal, and
3. there exists some object.

See https://stacks.math.columbia.edu/tag/002V. (They also define a diagram being filtered.)
-/
class is_filtered (C : Type u) [category C] extends is_filtered_or_empty C where
  nonempty : Nonempty C

protected instance is_filtered_or_empty_of_semilattice_sup (α : Type u) [semilattice_sup α] :
    is_filtered_or_empty α :=
  is_filtered_or_empty.mk
    (fun (X Y : α) =>
      Exists.intro (X ⊔ Y)
        (Exists.intro (hom_of_le le_sup_left) (Exists.intro (hom_of_le le_sup_right) trivial)))
    fun (X Y : α) (f g : X ⟶ Y) =>
      Exists.intro Y
        (Exists.intro 𝟙
          (ulift.ext (f ≫ 𝟙) (g ≫ 𝟙) (plift.ext (ulift.down (f ≫ 𝟙)) (ulift.down (g ≫ 𝟙)))))

protected instance is_filtered_of_semilattice_sup_top (α : Type u) [semilattice_sup_top α] :
    is_filtered α :=
  is_filtered.mk

namespace is_filtered

/--
`max j j'` is an arbitrary choice of object to the right of both `j` and `j'`,
whose existence is ensured by `is_filtered`.
-/
def max {C : Type u} [category C] [is_filtered C] (j : C) (j' : C) : C := Exists.some sorry

/--
`left_to_max j j'` is an arbitrarily choice of morphism from `j` to `max j j'`,
whose existence is ensured by `is_filtered`.
-/
def left_to_max {C : Type u} [category C] [is_filtered C] (j : C) (j' : C) : j ⟶ max j j' :=
  Exists.some sorry

/--
`right_to_max j j'` is an arbitrarily choice of morphism from `j'` to `max j j'`,
whose existence is ensured by `is_filtered`.
-/
def right_to_max {C : Type u} [category C] [is_filtered C] (j : C) (j' : C) : j' ⟶ max j j' :=
  Exists.some sorry

/--
`coeq f f'`, for morphisms `f f' : j ⟶ j'`, is an arbitrary choice of object
which admits a morphism `coeq_hom f f' : j' ⟶ coeq f f'` such that
`coeq_condition : f ≫ coeq_hom f f' = f' ≫ coeq_hom f f'`.
Its existence is ensured by `is_filtered`.
-/
def coeq {C : Type u} [category C] [is_filtered C] {j : C} {j' : C} (f : j ⟶ j') (f' : j ⟶ j') :
    C :=
  Exists.some sorry

/--
`coeq_hom f f'`, for morphisms `f f' : j ⟶ j'`, is an arbitrary choice of morphism
`coeq_hom f f' : j' ⟶ coeq f f'` such that
`coeq_condition : f ≫ coeq_hom f f' = f' ≫ coeq_hom f f'`.
Its existence is ensured by `is_filtered`.
-/
def coeq_hom {C : Type u} [category C] [is_filtered C] {j : C} {j' : C} (f : j ⟶ j') (f' : j ⟶ j') :
    j' ⟶ coeq f f' :=
  Exists.some sorry

/--
`coeq_condition f f'`, for morphisms `f f' : j ⟶ j'`, is the proof that
`f ≫ coeq_hom f f' = f' ≫ coeq_hom f f'`.
-/
@[simp] theorem coeq_condition_assoc {C : Type u} [category C] [is_filtered C] {j : C} {j' : C}
    (f : j ⟶ j') (f' : j ⟶ j') {X' : C} :
    ∀ (f'_1 : coeq f f' ⟶ X'), f ≫ coeq_hom f f' ≫ f'_1 = f' ≫ coeq_hom f f' ≫ f'_1 :=
  sorry

/--
Any finite collection of objects in a filtered category has an object "to the right".
-/
theorem sup_objs_exists {C : Type u} [category C] [is_filtered C] (O : finset C) :
    ∃ (S : C), ∀ {X : C}, X ∈ O → Nonempty (X ⟶ S) :=
  sorry

/--
Given any `finset` of objects `{X, ...}` and
indexed collection of `finset`s of morphisms `{f, ...}` in `C`,
there exists an object `S`, with a morphism `T X : X ⟶ S` from each `X`,
such that the triangles commute: `f ≫ T X = T Y`, for `f : X ⟶ Y` in the `finset`.
-/
theorem sup_exists {C : Type u} [category C] [is_filtered C] (O : finset C)
    (H :
      finset
        (psigma
          fun (X : C) =>
            psigma fun (Y : C) => psigma fun (mX : X ∈ O) => psigma fun (mY : Y ∈ O) => X ⟶ Y)) :
    ∃ (S : C),
        ∃ (T : {X : C} → X ∈ O → (X ⟶ S)),
          ∀ {X Y : C} (mX : X ∈ O) (mY : Y ∈ O) {f : X ⟶ Y},
            psigma.mk X (psigma.mk Y (psigma.mk mX (psigma.mk mY f))) ∈ H → f ≫ T mY = T mX :=
  sorry

/--
An arbitrary choice of object "to the right" of a finite collection of objects `O` and morphisms `H`,
making all the triangles commute.
-/
def sup {C : Type u} [category C] [is_filtered C] (O : finset C)
    (H :
      finset
        (psigma
          fun (X : C) =>
            psigma fun (Y : C) => psigma fun (mX : X ∈ O) => psigma fun (mY : Y ∈ O) => X ⟶ Y)) :
    C :=
  Exists.some (sup_exists O H)

/--
The morphisms to `sup O H`.
-/
def to_sup {C : Type u} [category C] [is_filtered C] (O : finset C)
    (H :
      finset
        (psigma
          fun (X : C) =>
            psigma fun (Y : C) => psigma fun (mX : X ∈ O) => psigma fun (mY : Y ∈ O) => X ⟶ Y))
    {X : C} (m : X ∈ O) : X ⟶ sup O H :=
  Exists.some sorry X m

/--
The triangles of consisting of a morphism in `H` and the maps to `sup O H` commute.
-/
theorem to_sup_commutes {C : Type u} [category C] [is_filtered C] (O : finset C)
    (H :
      finset
        (psigma
          fun (X : C) =>
            psigma fun (Y : C) => psigma fun (mX : X ∈ O) => psigma fun (mY : Y ∈ O) => X ⟶ Y))
    {X : C} {Y : C} (mX : X ∈ O) (mY : Y ∈ O) {f : X ⟶ Y}
    (mf : psigma.mk X (psigma.mk Y (psigma.mk mX (psigma.mk mY f))) ∈ H) :
    f ≫ to_sup O H mY = to_sup O H mX :=
  Exists.some_spec (Exists.some_spec (sup_exists O H)) X Y mX mY f mf

/--
If we have `is_filtered C`, then for any functor `F : J ⥤ C` with `fin_category J`,
there exists a cocone over `F`.
-/
theorem cocone_nonempty {C : Type u} [category C] [is_filtered C] {J : Type v} [small_category J]
    [fin_category J] (F : J ⥤ C) : Nonempty (limits.cocone F) :=
  sorry

/--
An arbitrary choice of cocone over `F : J ⥤ C`, for `fin_category J` and `is_filtered C`.
-/
def cocone {C : Type u} [category C] [is_filtered C] {J : Type v} [small_category J]
    [fin_category J] (F : J ⥤ C) : limits.cocone F :=
  nonempty.some (cocone_nonempty F)

/--
If `C` is filtered, and we have a functor `R : C ⥤ D` with a left adjoint, then `D` is filtered.
-/
theorem of_right_adjoint {C : Type u} [category C] [is_filtered C] {D : Type u₁} [category D]
    {L : D ⥤ C} {R : C ⥤ D} (h : L ⊣ R) : is_filtered D :=
  mk

/-- If `C` is filtered, and we have a right adjoint functor `R : C ⥤ D`, then `D` is filtered. -/
theorem of_is_right_adjoint {C : Type u} [category C] [is_filtered C] {D : Type u₁} [category D]
    (R : C ⥤ D) [is_right_adjoint R] : is_filtered D :=
  of_right_adjoint (adjunction.of_right_adjoint R)

/-- Being filtered is preserved by equivalence of categories. -/
theorem of_equivalence {C : Type u} [category C] [is_filtered C] {D : Type u₁} [category D]
    (h : C ≌ D) : is_filtered D :=
  of_right_adjoint (equivalence.to_adjunction (equivalence.symm h))

end Mathlib


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon, Scott Morrison
-/
import tactic.solve_by_elim
import tactic.rcases
import tactic.interactive

example {a b : Prop} (h₀ : a → b) (h₁ : a) : b :=
begin
  apply_assumption,
  apply_assumption,
end

example {X : Type} (x : X) : x = x :=
by solve_by_elim

example : true :=
by solve_by_elim

example {a b : Prop} (h₀ : a → b) (h₁ : a) : b :=
by solve_by_elim

example {α : Type} {a b : α → Prop} (h₀ : ∀ x : α, b x = a x) (y : α) : a y = b y :=
by solve_by_elim

example {α : Type} {a b : α → Prop} (h₀ : b = a) (y : α) : a y = b y :=
by solve_by_elim

example {α : Type} {a b : α → Prop} (h₀ : b = a) (y : α) : a y = b y :=
begin
  success_if_fail { solve_by_elim only [], },
  success_if_fail { solve_by_elim only [h₀], },
  solve_by_elim only [h₀, congr_fun]
end

example {α : Type} {a b : α → Prop} (h₀ : b = a) (y : α) : a y = b y :=
by solve_by_elim [h₀]

example {α : Type} {a b : α → Prop} (h₀ : b = a) (y : α) : a y = b y :=
begin
 success_if_fail { solve_by_elim [*, -h₀] },
 solve_by_elim [*]
end

example {α β : Type} (a b : α) (f : α → β) (i : function.injective f) (h : f a = f b) : a = b :=
begin
  success_if_fail { solve_by_elim only [i] },
  success_if_fail { solve_by_elim only [h] },
  solve_by_elim only [i,h]
end

@[user_attribute]
meta def ex : user_attribute := {
  name := `ex,
  descr := "An example attribute for testing solve_by_elim."
}

@[ex] def f : ℕ := 0

example : ℕ := by solve_by_elim [f]

example : ℕ :=
begin
  success_if_fail { solve_by_elim },
  success_if_fail { solve_by_elim [-f] with ex },
  solve_by_elim with ex,
end

example {α : Type} {p : α → Prop} (h₀ : ∀ x, p x) (y : α) : p y :=
begin
  apply_assumption,
end

open tactic

example : true :=
begin
  (do gs ← get_goals,
     set_goals [],
     success_if_fail `[solve_by_elim],
     set_goals gs),
  trivial
end

example {α : Type} (r : α → α → Prop) (f : α → α → α)
  (l : ∀ a b c : α, r a b → r a (f b c) → r a c)
  (a b c : α) (h₁ : r a b) (h₂ : r a (f b c)) : r a c :=
begin
  solve_by_elim,
end

-- Verifying that `solve_by_elim*` acts on all remaining goals.
example (n : ℕ) : ℕ × ℕ :=
begin
  split,
  solve_by_elim*,
end

-- Verifying that `solve_by_elim*` backtracks when given multiple goals.
example (n m : ℕ) (f : ℕ → ℕ → Prop) (h : f n m) : ∃ p : ℕ × ℕ, f p.1 p.2 :=
begin
  repeat { fsplit },
  solve_by_elim*,
end

example {a b c : ℕ} (h₁ : a ≤ b) (h₂ : b ≤ c) : a ≤ c :=
begin
  apply le_trans,
  solve_by_elim { backtrack_all_goals := true },
end

-- test that metavariables created for implicit arguments don't get stuck
example (P : ℕ → Type) (f : Π {n : ℕ}, P n) : P 2 × P 3 :=
begin
  fsplit,
  solve_by_elim* only [f],
end

example : 6 = 6 ∧ [7] = [7] :=
begin
  split,
  solve_by_elim* only [@rfl _],
end

example (P Q R : Prop) : P ∧ Q → P ∧ Q :=
begin
  solve_by_elim [and.imp, id],
end

/-
We now test the `accept` feature of `solve_by_elim`.

Recall that the `accept` parameter has type `list expr → tactic unit`.
At each branch (not just leaf) of the backtracking search tree,
`accept` is invoked with the list of metavariables
reported by `get_goals` when `solve_by_elim` was called
(which by now may have been partially solved by previous `apply` steps),
and if it fails this branch of the search is ignored.

Non-leaf nodes of the search tree will contain metavariables,
so we can test using `expr.has_meta_var` when we're only interesting in
filtering complete solutions.

In this example, we only accept solutions that contain
a given subexpression.
-/
def solve_by_elim_use_b (a b : ℕ) : ℕ × ℕ × ℕ :=
begin
  split; [skip, split],
  (do
    b ← get_local `b,
    tactic.solve_by_elim
    { backtrack_all_goals := tt,
      -- We require that in some goal, the expression `b` is used.
      accept := (λ gs, gs.any_of (λ g, guard $ g.contains_expr_or_mvar b)) })
end

-- We verify that the solution did use `b`.
example : solve_by_elim_use_b 1 2 = (1, 1, 2) := rfl

-- Test that `solve_by_elim*`, which works on multiple goals,
-- successfully uses the relevant local hypotheses for each goal.
example (f g : ℕ → Prop) : (∃ k : ℕ, f k) ∨ (∃ k : ℕ, g k) ↔ ∃ k : ℕ, f k ∨ g k :=
begin
  dsimp at *,
  fsplit,
  rintro (⟨n, fn⟩ | ⟨n, gn⟩),
  swap 3,
  rintro ⟨n, hf | hg⟩,
  solve_by_elim* [or.inl, or.inr, Exists.intro] { max_depth := 20 },
end

-- Check that no list of arguments is needed when using a config object
example (a : ℤ) (h : a = 2) : a = 2 :=
by apply_assumption {use_exfalso := ff}


import .definitions3 .progress .preservation

lemma true_true_freevars: FV (prop.term value.true ⋀ prop.term value.true) = FV (prop.term value.true) :=
  have h1: FV (prop.term value.true ⋀ prop.term value.true) = ∅, from set.eq_empty_of_forall_not_mem (
    assume x: var,
    assume : x ∈ FV (prop.term value.true ⋀ prop.term value.true),
    have x ∈ FV (prop.term value.true) ∨ x ∈ FV (prop.term value.true), from free_in_prop.and.inv this,
    or.elim this (
      assume : x ∈ FV (prop.term value.true),
      have x ∈ FV (term.value value.true), from free_in_prop.term.inv this,
      show «false», from free_in_term.value.inv this
    ) (
      assume : x ∈ FV (prop.term value.true),
      have x ∈ FV (term.value value.true), from free_in_prop.term.inv this,
      show «false», from free_in_term.value.inv this
    )
  ),
  have h2: FV (prop.term value.true) = ∅, from set.eq_empty_of_forall_not_mem (
    assume x: var,
    assume : x ∈ FV (prop.term value.true),
    have x ∈ FV (term.value value.true), from free_in_prop.term.inv this,
    show «false», from free_in_term.value.inv this
  ),
  show FV (prop.term value.true ⋀ prop.term value.true) = FV (prop.term value.true), from eq.trans h1 h2.symm

lemma true_true_implies_true {σ: env}:
      σ ⊨ vc.implies (prop.term value.true ⋀ prop.term value.true).to_vc (prop.term value.true).to_vc :=
  begin
    apply valid_env.mpr,
    assume h1,
    unfold prop.to_vc,
    from valid_env.true
  end

lemma true_spec_freevars: FV (spec.to_prop (spec.term value.true)) ⊆ FV (prop.term value.true) :=
  begin
    assume x,
    assume h1,
    unfold spec.to_prop at h1,
    have h2, from free_in_prop.term.inv h1,
    have h3: ¬ free_in_term x ↑value.true, from free_in_term.value.inv,
    contradiction
  end

lemma true_spec_valid: env.empty ⊨ prop.to_vc (spec.to_prop (spec.term ↑value.true)) :=
  begin
    unfold vc.subst_env,
    unfold spec.to_prop,
    unfold prop.to_vc,
    from valid.tru
  end

lemma dsoundness {s s': dstack} {Q: propctx}: (s ⟹* s') → (⊩ₛ s: Q) → (is_dvalue s' ∨ ∃s'', s' ⟹ s'') :=
  begin
    have : ∀{s s': dstack} {Q: propctx}, (s ⟹* s') → (⊩ₛ s: Q) → (∃Q': propctx, ⊩ₛ s' : Q'), by begin
      assume s s' Q steps_to_s',
      induction steps_to_s',
      case trans_dstep.rfl s₁ {
        assume s₁_verified,
        existsi Q,
        from s₁_verified
      },
      case trans_dstep.trans s₁ s₂ s₃ s₁_steps_to_s₂ s₂_steps_to_s₃ ih {
        assume s₁_verified,
        cases ih s₁_verified with Q₂ h1,
        cases preservation h1 s₃ s₂_steps_to_s₃ with Q₃ h2,
        from exists.intro Q₃ h2.left
      }
    end,
    assume h1 h2,
    cases this h1 h2 with Q' h3,
    from progress h3
  end

lemma soundness_source_programs {e: exp} {s: stack} {Q: propctx}:
  (value.true ⊢ e: Q) → ((env.empty, e) ⟶* s) → (is_value s ∨ ∃s', s ⟶ s') :=
  assume : value.true ⊢ e: Q,
  have value.true ⊩ e: Q, from exp.vcgen.extension this,
  have value.true ⋀ value.true ⊩ e : Q,
  from strengthen_exp this (value.true ⋀ value.true) true_true_freevars (λσ, true_true_implies_true),
  have h1: ⊩ₛ (spec.term value.true, env.empty, e) : value.true ⋀ Q,
  from stack.dvcgen.top env.dvcgen.empty true_spec_freevars true_spec_valid this,
  assume : (env.empty, e) ⟶* s,
  have ∃d', ((spec.term value.true, env.empty, e) ⟹* d') ∧ stack_equiv_dstack s d',
  from dstep_of_step_trans this (spec.term value.true, env.empty, e) stack_equiv_dstack.top,
  let ⟨d', h2⟩ := this in
  have is_dvalue d' ∨ ∃d'', d' ⟹ d'', from dsoundness h2.left h1,
  show is_value s ∨ ∃s', s ⟶ s', from value_or_step_of_dvalue_or_dstep h2.right this


import mcl.defs
import parlang.rhl

namespace mcl
namespace rhl

open parlang
open mclk

@[reducible]
def state_assert (sig₁ sig₂ : signature) := Π n₁:ℕ, parlang.state n₁ (memory (parlang_mcl_tlocal sig₁)) (parlang_mcl_shared sig₁) → vector bool n₁ → Π n₂:ℕ, parlang.state n₂ (memory (parlang_mcl_tlocal sig₂)) (parlang_mcl_shared sig₂) → vector bool n₂ → Prop

def mclk_rel {sig₁ sig₂ : signature}
    (P : state_assert sig₁ sig₂)
    (k₁ : mclk sig₁) (k₂ : mclk sig₂)
    (Q : state_assert sig₁ sig₂) :=
rel_hoare_state P (mclk_to_kernel k₁) (mclk_to_kernel k₂) Q

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

def mclp_rel {sig₁ sig₂ : signature} (P) (p₁ : mclp sig₁) (p₂ : mclp sig₂) (Q) := rel_hoare_program mcl_init mcl_init P (mclp_to_program p₁) (mclp_to_program p₂) Q

--def eq_assert (sig₁ : signature) : state_assert sig₁ sig₁ := λ n₁ s₁ ac₁ n₂ s₂ ac₂, n₁ = n₂ ∧ s₁ = s₂ ∧ ac₁ = ac₂

-- we have to show some sort of non-interference
-- example {sig : signature} {n} {k₁} {P Q : state_assert sig sig} (h : sig "i" = { scope := scope.shared, type := ⟨_, [0], type.int⟩}) (hpi : ∀ n₁ s₁ ac₁ n₂ s₂ ac₂, P n₁ s₁ ac₁ n₂ s₂ ac₂ → n₁ = n ∧ n₂ = 1) :
-- mclk_rel P k₁ (for "i" h _ 0 (λ s, s.get' h < n) (tlocal_assign "i" (var "i" (by refl) + (literal_int 1 h))) k₁) Q := begin
--     sorry
-- end

-- example {t : type} {n : string} {sig₁ sig₂ : signature} {P Q} {expr} {k₂ : mclk sig₂} (hu : ¬expr_reads n expr)
-- (hr : @mclk_rel sig₁ sig₂ P (tlocal_assign n idx _ _ expr ;; tlocal_assign n idx _ _ expr) k₂ Q) :
-- @mclk_rel sig₁ sig₂ P (tlocal_assign n expr) k₂ Q := begin
--     unfold mclk_rel,
--     rw mclk_to_kernel,
--     intros _ _ _ _ _ _ _ hp hek₁,
--     specialize hr n₁ n₂ s₁ s₁' s₂ ac₁ ac₂ hp,
--     apply hr,
--     unfold mclk_to_kernel,
--     apply exec_state.seq,
--     {
--         apply exec_state.compute,
--     }, {
--         suffices : s₁' = state.map_active_threads ac₁ (thread_state.map (λ (s : state sig₁), state.update' _ (eval expr s) s)) (state.map_active_threads ac₁ (thread_state.map (λ (s : state sig₁), state.update' _ (eval expr s) s)) s₁),
--         {
--             subst this,
--             apply exec_state.compute,
--         }, {
--             sorry,
--         }
--     }
-- end

variables {sig sig₁ sig₂ : signature} {k₁ k₁' : mclk sig₁} {k₂ k₂' : mclk sig₂} {P P' Q Q' R : Π n₁:ℕ, parlang.state n₁ (memory $ parlang_mcl_tlocal sig₁) (parlang_mcl_shared sig₁) → vector bool n₁ → Π n₂:ℕ, parlang.state n₂ (memory $ parlang_mcl_tlocal sig₂) (parlang_mcl_shared sig₂) → vector bool n₂ → Prop}

lemma rel_mclk_to_mclp {sig₁ sig₂ : signature} (f₁ : memory (parlang_mcl_shared sig₁) → ℕ) (f₂ : memory (parlang_mcl_shared sig₂) → ℕ)
(P Q : memory (parlang_mcl_shared sig₁) → memory (parlang_mcl_shared sig₂) → Prop)
(k₁ : mclk sig₁) (k₂ : mclk sig₂) (h : mclk_rel
(λ n₁ s₁ ac₁ n₂ s₂ ac₂, ∃ m₁ m₂, initial_kernel_assertion mcl_init mcl_init P f₁ f₂ m₁ m₂ n₁ s₁ ac₁ n₂ s₂ ac₂)
    k₁ k₂
(λ n₁ s₁ ac₁ n₂ s₂ ac₂, (∃ m₁, s₁.syncable m₁) → ∃ m₁ m₂, s₁.syncable m₁ ∧ s₂.syncable m₂ ∧ Q m₁ m₂))
(hg : ∀ {m₁ m₂}, P m₁ m₂ → 0 < f₁ m₁) :
mclp_rel P (mclp.intro f₁ k₁) (mclp.intro f₂ k₂) Q := rel_kernel_to_program h @hg

-- lemma assign_swap {sig : signature} {t : type} (n₁ n₂) (dim₁ dim₂) (idx₁ : vector (expression sig type.int) dim₁) (idx₂ : vector (expression sig type.int) dim₂) (h₁ h₂) (expr₁ : expression sig (type_of (sig n₁))) (expr₂ : expression sig (type_of (sig n₂))) (q) (ac : vector _ q) (s u) :
-- exec_state (mclk_to_kernel ((tlocal_assign n₁ idx₁ h₁ expr₁) ;; tlocal_assign n₂ idx₂ h₂ expr₂)) ac s u →
-- exec_state (mclk_to_kernel ((tlocal_assign n₂ idx₂ h₂ expr₂) ;; (tlocal_assign n₁ idx₁ h₁ expr₁))) ac s u := begin
--     intro h,
--     cases h,
--     rename h_t t,
--     rename h_a hl,
--     rename h_a_1 hr,
--     -- break out the compute and replace it with skip
--     apply exec_state.seq,
--     {

--     }
-- end

--todo define interference (maybe choose another name) and define swap on non-interference
--lemma rel_assign_swap {sig₁ sig₂ : signature}

/-- Prepend skip to the left program -/
lemma add_skip_left : {* P *} k₁ ~> k₂ {* Q *} ↔
{* P *} skip ;; k₁ ~> k₂ {* Q *} := begin
    -- this only solves ltr
    unfold mclk_rel,
    apply iff.intro,
    {
        intro h,
        intros n₁ n₂ s₁ s₁' s₂ ac₁ ac₂ hp he₁,
        apply h,
        exact hp,
        cases he₁,
        cases he₁_a,
        sorry --trivial from he₁_a_1
    }, {
        intro h,
        intros n₁ n₂ s₁ s₁' s₂ ac₁ ac₂ hp he₁,
        apply h,
        exact hp,
        apply exec_state.seq _ _ _ _ _ _ _ he₁,
        sorry,
    }
end

lemma skip_left_after : {* P *} k₁ ~> k₂ {* Q *} ↔
{* P *} k₁ ;; skip ~> k₂ {* Q *} := sorry
lemma skip_right : {* P *} k₁ ~> k₂ {* Q *} ↔
{* P *}  k₁ ~> skip ;; k₂ {* Q *} := sorry
lemma skip_right_after : {* P *} k₁ ~> k₂ {* Q *} ↔
{* P *} k₁ ~> k₂ ;; skip {* Q *} := sorry

lemma single_step_left :
{* P *} k₁ ~> skip {* Q *} →
{* Q *} k₁' ~> k₂ {* R *} →
{* P *} (k₁ ;; k₁') ~> k₂ {* R *} := parlang.single_step_left Q

@[irreducible]
def exprs_to_indices {n dim} {idx : vector (expression sig type.int) dim} (h : ((sig.val n).type).dim = vector.length idx) (s : (memory $ parlang_mcl_tlocal sig)) :
(sig.val n).type.dim = (idx.map (eval s)).length := h

open expression

lemma seq (Q) (h₁ : {* P *} k₁ ~> k₂ {* Q *}) (h₂ : {* Q *} k₁' ~> k₂' {* R *}) :
{* P *} k₁ ;; k₁' ~> k₂ ;; k₂' {* R *} := parlang.seq Q h₁ h₂

lemma seq_left {P R} (Q) (h₁ : {* P *} k₁ ~> skip {* Q *}) (h₂ : {* Q *} k₁' ~> k₂' {* R *}) :
mclk_rel P (k₁ ;; k₁') k₂' R := skip_right.mpr (seq Q h₁ h₂)

lemma consequence (h : {* P *} k₁ ~> k₂ {* Q *})
(hp : ∀ n₁ s₁ ac₁ n₂ s₂ ac₂, P' n₁ s₁ ac₁ n₂ s₂ ac₂ → P n₁ s₁ ac₁ n₂ s₂ ac₂)
(hq : ∀ n₁ s₁ ac₁ n₂ s₂ ac₂, Q n₁ s₁ ac₁ n₂ s₂ ac₂ → Q' n₁ s₁ ac₁ n₂ s₂ ac₂) :
{* P' *} k₁ ~> k₂ {* Q' *} := consequence h hp hq

lemma swap_skip (h : {* parlang.assertion_swap_side P *} skip ~> k₁ {* parlang.assertion_swap_side Q *}) :
{* P *} k₁ ~> skip {* Q *} := begin
    apply parlang.swap h,
    intros,
    use s₁,
    apply exec_skip,
end

-- todo relate to load_shared_vars_for_expr
/-- Copy values from shared to tlocal memory for all occurences of shared variables in *expr*. If there are no references, this definition is equal to *id*. This definition is the equivalent of load_shared_vars_for_expr for *thread_state*. -/
def thread_state.update_shared_vars_for_expr {t : type} (expr : expression sig t) :
thread_state (memory $ parlang_mcl_tlocal sig) (parlang_mcl_shared sig) → thread_state (memory $ parlang_mcl_tlocal sig) (parlang_mcl_shared sig) :=
expression.rec_on expr
    -- tlocal
    (λ t dim n idx h₁ h₂ h₃ ih, id)
    -- shared
    (λ t dim n idx h₁ h₂ h₃ ih, λ ts,
    ((list.range_fin dim).foldl (λ ts e, ih e ts) ts
    ).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_b ∘ ih_a)
    -- mult
    (λ t a b ih_a ih_b, ih_b ∘ ih_a)
    -- literal_int
    (λ t n h, id)
    -- lt
    (λ t h a b ih_a ih_b, ih_b ∘ ih_a)

/-- Lifts *thread_state.update_shared_vars_for_expr* to a vector -/
def thread_state.update_shared_vars_for_exprs {n} {t : type} (exprs : vector (expression sig t) n) :
thread_state (memory $ parlang_mcl_tlocal sig) (parlang_mcl_shared sig) → thread_state (memory $ parlang_mcl_tlocal sig) (parlang_mcl_shared sig) :=
λts, exprs.to_list.foldr (λexpr ts, thread_state.update_shared_vars_for_expr expr ts) ts

-- TODO: change to double implication
/-- Resolve semantics of loading_shared_vars_for_expr to the relation on state -/
lemma update_load_shared_vars_for_expr {sig t} {expr : expression sig t} {n} {ac : vector bool n} {s u} :
exec_state (list.foldr kernel.seq (kernel.compute id) (load_shared_vars_for_expr expr)) ac s u ↔
u = s.map_active_threads ac (thread_state.update_shared_vars_for_expr expr) := begin
    sorry,
    -- apply iff.intro,
    -- {
    --     induction expr generalizing s u,
    --     case mcl.expression.tlocal_var {
    --         intro h,
    --         delta thread_state.update_shared_vars_for_expr,
    --         unfold load_shared_vars_for_expr at h,
    --         cases h,
    --         have : (λ (a : state sig), a) = id := by refl,
    --         rw this,
    --         rw ← parlang.state.map_active_threads_id s ac,
    --         simp [state.map_active_threads],
    --         sorry,
    --     },
    --     case mcl.expression.shared_var {
    --         cases h,
    --         cases h_a_1,
    --         cases h_a,
    --         have : (λ (a : state sig), a) = id := by refl,
    --         rw this,
    --         sorry,
    --     },
    --     case mcl.expression.add {
    --         rw load_shared_vars_for_expr at h,
    --         simp at h,
    --         rw kernel_foldr_skip at h,
    --         cases h,
    --         specialize expr_ih_a h_a,
    --         specialize expr_ih_a_1 h_a_1,
    --         subst expr_ih_a_1,
    --         subst expr_ih_a,
    --         rw parlang.state.map_map_active_threads',
    --         refl,
    --     },
    --     case mcl.expression.literal_int {
    --         cases h,
    --         sorry,
    --     },
    --     case mcl.expression.lt {
    --         rw load_shared_vars_for_expr at h,
    --         simp at h,
    --         rw kernel_foldr_skip at h,
    --         cases h,
    --         specialize expr_ih_a h_a,
    --         specialize expr_ih_a_1 h_a_1,
    --         subst expr_ih_a_1,
    --         subst expr_ih_a,
    --         rw parlang.state.map_map_active_threads',
    --         refl,
    --     }
    -- }
end

lemma update_load_shared_vars_for_exprs {sig t m} {exprs : vector (expression sig t) m} {n} {ac : vector bool n} {s u} :
exec_state (exprs.to_list.foldr (λexpr' k, prepend_load_expr expr' k) (kernel.compute id)) ac s u ↔
u = s.map_active_threads ac (thread_state.update_shared_vars_for_exprs exprs) := begin
    unfold thread_state.update_shared_vars_for_exprs,
    cases exprs,
    simp,
    sorry, -- induction exprs_val and update_load_shared_vars_for_expr
end

lemma foldr_prepend_load_expr_skip {sig t} {k : kernel (memory $ parlang_mcl_tlocal sig) (parlang_mcl_shared sig)} {n} {s u} {ac : vector bool n} {v : list $ expression sig t} : exec_state
    (list.foldr (λ expr' k, prepend_load_expr expr' k) k v)
    ac s u ↔
    exec_state
    ((list.foldr (λ expr' k, prepend_load_expr expr' k) (kernel.compute id) v) ;; k)
    ac s u := sorry

/-- Single-sided inference rule -/
lemma update_load_shared_vars_for_expr_right {t} {expr : expression sig₂ t} :
{* λn₁ s₁ ac₁ n₂ (s₂ : state n₂ (memory (parlang_mcl_tlocal sig₂)) (parlang_mcl_shared sig₂)) ac₂, P n₁ s₁ ac₁ n₂ (s₂.map_active_threads ac₂ (thread_state.update_shared_vars_for_expr expr)) ac₂ *}
kernel.compute id ~> list.foldr kernel.seq (kernel.compute id) (load_shared_vars_for_expr expr)
{* P *} := begin
    intros _ _ _ _ _ _ _ hp he,
    use (s₂.map_active_threads ac₂ (thread_state.update_shared_vars_for_expr expr)),
    split, {
        rw update_load_shared_vars_for_expr,
    }, {
        cases he,
        sorry, -- trivial
    }
end

def f := λ n, n * 2
def g := λ(n : nat), n + 1
#check g
#eval (f ∘ g) 4

-- TODO should this moved to defs?
/-- Stores the locally computed value in the shadow memory. This is an abstraction over *thread_state.store*, which hides the lambda-term. This makes it easier to rewrite. -/
@[irreducible]
def thread_state.tlocal_to_shared {sig : signature} {t} {dim} (var : string) (idx : vector (expression sig type.int) dim) (h₁ : type_of (sig.val var) = t) (h₂ : ((sig.val var).type).dim = dim) :=
@thread_state.store _ _ (parlang_mcl_shared sig) _ (λ (m : memory $ parlang_mcl_tlocal sig), ⟨mcl_addr_from_var h₂ idx m, m.get $ mcl_addr_from_var h₂ idx m⟩)

/-- Evaluates an expressions and assigns the value -/
def thread_state.assign_expr {sig : signature} (var) (expr : expression sig $ sig.type_of var)
(idx : vector (expression sig type.int) (sig.val var).type.dim) :=
@thread_state.compute (memory $ parlang_mcl_tlocal sig) _ (parlang_mcl_shared sig) _
    $ λs, s.update ⟨var, idx.map (eval s)⟩ $ eval s expr

/-- Processes a single tlocal assign on the right side. Proven by operational semantics -/
lemma tlocal_assign_right {var}
{expr : expression sig₂ $ sig₂.type_of var}
{idx : vector (expression sig₂ type.int) (sig₂.val var).type.dim} :
{* (λ n₁ s₁ ac₁ n₂ s₂ ac₂, P n₁ s₁ ac₁ n₂
    ((s₂ : parlang.state n₂ (memory $ parlang_mcl_tlocal sig₂) (parlang_mcl_shared sig₂)).map_active_threads ac₂ (
        thread_state.assign_expr var expr idx ∘
        thread_state.update_shared_vars_for_expr expr
    )) ac₂) *}
(skip : mclk sig₁) ~> tlocal_assign var idx rfl rfl expr {* P *} := begin
    unfold mclk_rel,
    unfold mclk_to_kernel,
    unfold prepend_load_expr,
    sorry,
end

-- lemma tlocal_assign_right {t dim n expr} {idx : vector (expression sig₂ type.int) dim} {h₁ : type_of (sig₂ n) = t} {h₂ : ((sig₂ n).type).dim = vector.length idx} :
-- mclk_rel (λ n₁ s₁ ac₁ n₂ s₂ ac₂, P n₁ s₁ ac₁ n₂ (s₂.map_active_threads ac₂ (λ ts, (thread_state.update_shared_vars_for_expr expr ts).map (λ s, s.update' h₁ (exprs_to_indices h₂ s) (eval s expr)))) ac₂) (skip : mclk sig₁) (tlocal_assign n idx h₁ h₂ expr) P := begin
--     intros n₁ n₂ s₁ s₁' s₂ ac₁ ac₂ hp he₁,
--     use (s₂.map_active_threads ac₂ (λ ts, (thread_state.update_shared_vars_for_expr expr ts).map (λ s, s.update' h₁ (exprs_to_indices h₂ s) (eval s expr)))),
--     split, {
--         unfold mclk_to_kernel,
--         unfold prepend_load_expr,
--         rw kernel_foldr_skip,
--         apply exec_state.seq,
--         {
--             rw update_load_shared_vars_for_expr,
--         }, {
--             rw [← parlang.state.map_map_active_threads'],
--             apply exec_state.compute,
--         }
--     }, {
--         have : s₁ = s₁' := sorry, -- trivial skip
--         subst this,
--         exact hp,
--     }
-- end

-- lemma tlocal_assign_right' {t dim n expr} {idx : vector (expression sig₂ type.int) dim} {h₁ : type_of (sig₂ n) = t} {h₂ : ((sig₂ n).type).dim = vector.length idx}
-- (hi : ∀ n₁ s₁ ac₁ n₂ s₂ ac₂, P n₁ s₁ ac₁ n₂ s₂ ac₂ → Q n₁ s₁ ac₁ n₂ (s₂.map_active_threads ac₂ (λ ts, (thread_state.update_shared_vars_for_expr ts expr).map (λ s, s.update' h₁ (exprs_to_indices h₂ s) (eval s expr)))) ac₂) :
-- mclk_rel P (skip : mclk sig₁) (tlocal_assign n idx h₁ h₂ expr) Q := begin
--     apply consequence tlocal_assign_right hi,
--     intros _ _ _ _ _ _ _,
--     assumption,
-- end

-- lemma tlocal_assign_left {t dim n expr} {idx : vector (expression sig₁ type.int) dim} {h₁ : type_of (sig₁ n) = t} {h₂ : ((sig₁ n).type).dim = vector.length idx} :
-- mclk_rel (λ n₁ s₁ ac₁ n₂ s₂ ac₂, P n₁ (s₁.map_active_threads ac₁ (λ ts, (thread_state.update_shared_vars_for_expr ts expr).map (λ s, s.update' h₁ (exprs_to_indices h₂ s) (eval s expr)))) ac₁ n₂ s₂ ac₂)
-- (tlocal_assign n idx h₁ h₂ expr) (skip : mclk sig₂) P := begin
--     apply swap_skip tlocal_assign_right,
-- end

-- lemma tlocal_assign_left' {t dim n expr} {idx : vector (expression sig₁ type.int) dim} {h₁ : type_of (sig₁ n) = t} {h₂ : ((sig₁ n).type).dim = vector.length idx}
-- (hi : ∀ n₁ s₁ ac₁ n₂ s₂ ac₂, P n₁ s₁ ac₁ n₂ s₂ ac₂ → Q n₁ (s₁.map_active_threads ac₁ (λ ts, (thread_state.update_shared_vars_for_expr ts expr).map (λ s, s.update' h₁ (exprs_to_indices h₂ s) (eval s expr)))) ac₁ n₂ s₂ ac₂) :
-- mclk_rel P (tlocal_assign n idx h₁ h₂ expr) (skip : mclk sig₂) Q := begin
--     apply consequence tlocal_assign_left hi,
--     intros _ _ _ _ _ _ _,
--     assumption,
-- end

-- todo define in terms of
/-- Processes a single shared assign on the right side. Proven by operational semantics -/
lemma shared_assign_right'' {var}
{expr : expression sig₂ $ sig₂.type_of var}
{idx : vector (expression sig₂ type.int) (sig₂.val var).type.dim} :
{* (λ n₁ s₁ ac₁ n₂ s₂ ac₂, P n₁ s₁ ac₁ n₂
    ((s₂ : parlang.state n₂ (memory $ parlang_mcl_tlocal sig₂) (parlang_mcl_shared sig₂)).map_active_threads ac₂ (
        thread_state.tlocal_to_shared var idx rfl rfl ∘
        thread_state.assign_expr var expr idx ∘
        thread_state.update_shared_vars_for_expr expr ∘
        thread_state.update_shared_vars_for_exprs idx
    )) ac₂) *}
(skip : mclk sig₁) ~> shared_assign var idx rfl rfl expr {* P *} := begin
    unfold mclk_rel,
    unfold mclk_to_kernel,
    unfold prepend_load_expr,
    sorry,
end

/-- Processes a single shared assign on the right side. Proven by operational semantics -/
lemma shared_assign_right {t dim n} {idx : vector (expression sig₂ type.int) dim} {h₁ : type_of (sig₂.val n) = t} {h₂ : ((sig₂.val n).type).dim = dim} {expr : expression sig₂ t} :
{* (λ n₁ s₁ ac₁ n₂ s₂ ac₂, P n₁ s₁ ac₁ n₂
    ((s₂ : parlang.state n₂ (memory $ parlang_mcl_tlocal sig₂) (parlang_mcl_shared sig₂)).map_active_threads ac₂ (
        thread_state.tlocal_to_shared n idx h₁ h₂ ∘
        thread_state.compute (memory.update_assign n idx h₁ h₂ expr) ∘
        thread_state.update_shared_vars_for_expr expr ∘
        thread_state.update_shared_vars_for_exprs idx
    )) ac₂) *}
(skip : mclk sig₁) ~> shared_assign n idx h₁ h₂ expr {* P *} := begin
    intros n₁ n₂ s₁ s₁' s₂ ac₁ ac₂ hp he₁,
    use ((s₂ : parlang.state n₂ (memory $ parlang_mcl_tlocal sig₂) (parlang_mcl_shared sig₂)).map_active_threads ac₂ (
        thread_state.tlocal_to_shared n idx h₁ h₂ ∘
        thread_state.compute (memory.update_assign n idx h₁ h₂ expr) ∘
        thread_state.update_shared_vars_for_expr expr ∘
        thread_state.update_shared_vars_for_exprs idx
    )),
    split, {
        unfold mclk_to_kernel,
        rw foldr_prepend_load_expr_skip,
        apply exec_state.seq,
        {
            rw update_load_shared_vars_for_exprs,
        },
        apply exec_state.seq,
        {
            unfold prepend_load_expr,
            rw kernel_foldr_skip,
            apply exec_state.seq,
            {
                rw update_load_shared_vars_for_expr,
            }, {
                apply exec_state.compute,
            }
        }, {
            rw parlang.state.map_map_active_threads',
            rw parlang.state.map_map_active_threads',
            unfold thread_state.tlocal_to_shared,
            rw [← parlang.state.map_map_active_threads' _ (thread_state.store _)],
            apply exec_state.store,
        }
    }, {
        have : s₁ = s₁' := sorry, -- trivial skip
        subst this,
        exact hp,
    },
end

/-- Proven by Parlang inference rules -/
lemma shared_assign_right' {t dim n} {idx : vector (expression sig₂ type.int) dim} {h₁ : type_of (sig₂.val n) = t} {h₂ : ((sig₂.val n).type).dim = dim} {expr : expression sig₂ t} :
{* (λ n₁ s₁ ac₁ n₂ s₂ ac₂, P n₁ s₁ ac₁ n₂
    ((s₂ : parlang.state n₂ (memory $ parlang_mcl_tlocal sig₂) (parlang_mcl_shared sig₂)).map_active_threads ac₂ (
        thread_state.tlocal_to_shared n idx h₁ h₂ ∘
        thread_state.compute (λ s : memory $ parlang_mcl_tlocal sig₂, s.update ⟨n, by rw h₂; exact idx.map (eval s)⟩ (begin unfold parlang_mcl_tlocal signature.lean_type_of lean_type_of, rw h₁, exact (eval s expr) end)) ∘
        thread_state.update_shared_vars_for_expr expr ∘
        thread_state.update_shared_vars_for_exprs idx
    )) ac₂) *}
(skip : mclk sig₁) ~> shared_assign n idx h₁ h₂ expr {* P *} := begin
    rw skip_left_after,
    rw skip_left_after,
    unfold mclk_rel mclk_to_kernel,
    sorry,
    /- apply parlang.seq,
    swap, {
        apply parlang.store_right,
    }, {
        unfold prepend_load_expr,
        rw kernel_foldr_skip_right,
        apply parlang.seq,
        swap,
        apply parlang.compute_right,
        apply parlang.consequence_pre,
        exact update_load_shared_vars_for_expr_right,
        {
            intros,
            repeat { rw parlang.state.map_map_active_threads },
            sorry,
        }
    } -/
end

lemma shared_assign_left {t dim n expr} {idx : vector (expression sig₁ type.int) dim} {h₁ : type_of (sig₁.val n) = t} {h₂ : ((sig₁.val n).type).dim = vector.length idx} :
mclk_rel (λ n₁ s₁ ac₁ n₂ s₂ ac₂, P n₁
    ((s₁ : parlang.state n₁ (memory $ parlang_mcl_tlocal sig₁) (parlang_mcl_shared sig₁)).map_active_threads ac₁ (
        thread_state.tlocal_to_shared n idx h₁ h₂ ∘
        thread_state.compute (memory.update_assign n idx h₁ h₂ expr) ∘
        thread_state.update_shared_vars_for_expr expr ∘
        thread_state.update_shared_vars_for_exprs idx
    )) ac₁ n₂ s₂ ac₂)
(shared_assign n idx h₁ h₂ expr) (skip : mclk sig₂) P := begin
    apply swap_skip shared_assign_right,
end

lemma shared_assign_left' {t dim n expr} {idx : vector (expression sig₁ type.int) dim} {h₁ : type_of (sig₁.val n) = t} {h₂ : ((sig₁.val n).type).dim = vector.length idx}
(hi : ∀ n₁ s₁ ac₁ n₂ s₂ ac₂, P n₁ s₁ ac₁ n₂ s₂ ac₂ → Q n₁
    (s₁.map_active_threads ac₁ (
        thread_state.tlocal_to_shared n idx h₁ h₂ ∘
        thread_state.compute (memory.update_assign n idx h₁ h₂ expr) ∘
        thread_state.update_shared_vars_for_expr expr ∘
        thread_state.update_shared_vars_for_exprs idx
    )) ac₁ n₂ s₂ ac₂) :
mclk_rel P (shared_assign n idx h₁ h₂ expr) (skip : mclk sig₂) Q := begin
    apply consequence shared_assign_left hi,
    intros _ _ _ _ _ _ _,
    assumption,
end

end rhl
end mcl