import for_mathlib.homology_exact
import for_mathlib.split_exact
import for_mathlib.sum_str
.

noncomputable theory

open category_theory category_theory.limits

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

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

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

section

variables (f₁₁ g₁₁ g₁₂ f₂₁)

/-- A *commutative square* is a commutative diagram of the following shape:
```
A₁₁ --- f₁₁ --> A₁₂
 |               |
g₁₁             g₁₂
 |               |
 v               v
A₂₁ --- f₂₁ --> A₂₂
```
The order of (explicit) variables is: top-to-bottom, left-to-right,
alternating between rows of horizontal maps and rows of vertical maps. -/
@[ext] structure commsq :=
(S : 𝓐)
(ι : A₁₁ ⟶ S)
(π : S ⟶ A₂₂)
(diag : A₁₁ ⟶ A₂₂)
(sum : sum_str A₁₂ A₂₁ S)
(ι_fst : ι ≫ sum.fst = f₁₁)
(ι_snd : ι ≫ sum.snd = g₁₁)
(inl_π : sum.inl ≫ π = g₁₂)
(inr_π : sum.inr ≫ π = f₂₁)
(tr₁ : g₁₁ ≫ f₂₁ = diag)
(tr₂ : f₁₁ ≫ g₁₂ = diag)

end

namespace commsq

attribute [simp, reassoc] ι_fst ι_snd inl_π inr_π

@[reassoc] lemma w (sq : commsq f₁₁ g₁₁ g₁₂ f₂₁) : f₁₁ ≫ g₁₂ = g₁₁ ≫ f₂₁ :=
by rw [sq.tr₁, sq.tr₂]

@[reassoc] lemma w_inv [is_iso g₁₁] [is_iso g₁₂] (sq : commsq f₁₁ g₁₁ g₁₂ f₂₁) :
  inv g₁₁ ≫ f₁₁ = f₂₁ ≫ inv g₁₂ :=
by rw [is_iso.eq_comp_inv, category.assoc, sq.w, is_iso.inv_hom_id_assoc]

def of_eq (w : f₁₁ ≫ g₁₂ = g₁₁ ≫ f₂₁) : commsq f₁₁ g₁₁ g₁₂ f₂₁ :=
{ S := A₁₂ ⊞ A₂₁,
  ι := biprod.lift f₁₁ g₁₁,
  π := biprod.desc g₁₂ f₂₁,
  diag := g₁₁ ≫ f₂₁,
  sum := sum_str.biprod _ _,
  ι_fst := biprod.lift_fst _ _,
  ι_snd := biprod.lift_snd _ _,
  inl_π := biprod.inl_desc _ _,
  inr_π := biprod.inr_desc _ _,
  tr₁ := rfl,
  tr₂ := w }

def symm (sq : commsq f₁₁ g₁₁ g₁₂ f₂₁) : commsq g₁₁ f₁₁ f₂₁ g₁₂ :=
{ sum := sq.sum.symm,
  ι_fst := sq.ι_snd,
  ι_snd := sq.ι_fst,
  inl_π := sq.inr_π,
  inr_π := sq.inl_π,
  tr₁ := sq.tr₂,
  tr₂ := sq.tr₁,
  .. sq }

lemma ι_eq (sq : commsq f₁₁ g₁₁ g₁₂ f₂₁) :
  sq.ι = f₁₁ ≫ sq.sum.inl + g₁₁ ≫ sq.sum.inr :=
begin
  rw [← cancel_mono (𝟙 sq.S), ← sq.sum.total],
  simp only [preadditive.add_comp, category.assoc, ι_fst_assoc, ι_snd_assoc, preadditive.comp_add,
    preadditive.add_comp_assoc, sum_str.inl_fst, category.comp_id, sum_str.inr_fst, comp_zero,
    add_zero, sum_str.inl_snd, sum_str.inr_snd, zero_add],
end

lemma π_eq (sq : commsq f₁₁ g₁₁ g₁₂ f₂₁) :
  sq.π = sq.sum.fst ≫ g₁₂ + sq.sum.snd ≫ f₂₁ :=
begin
  rw [← cancel_epi (𝟙 sq.S), ← sq.sum.total],
  simp only [preadditive.add_comp, category.assoc, inl_π, inr_π, preadditive.comp_add,
    preadditive.add_comp_assoc, sum_str.inl_fst, category.comp_id, sum_str.inr_fst, comp_zero,
    add_zero, sum_str.inl_snd, sum_str.inr_snd, zero_add],
end

section iso
open category_theory.preadditive

lemma ι_iso_hom (sq₁ sq₂ : commsq f₁₁ g₁₁ g₁₂ f₂₁) :
  sq₁.ι ≫ (sq₁.sum.iso sq₂.sum).hom = sq₂.ι :=
begin
  simp only [sum_str.iso_hom, comp_add, ι_fst_assoc, ι_snd_assoc],
  simp only [← sq₂.ι_fst_assoc, ← sq₂.ι_snd_assoc, ← comp_add, sum_str.total, category.comp_id],
end

lemma iso_hom_π (sq₁ sq₂ : commsq f₁₁ g₁₁ g₁₂ f₂₁) :
  (sq₁.sum.iso sq₂.sum).hom ≫ sq₂.π = sq₁.π :=
begin
  simp only [sum_str.iso_hom, add_comp, category.assoc, inl_π, inr_π],
  simp only [← sq₁.inl_π, ← sq₁.inr_π],
  simp only [← category.assoc, ← add_comp, sum_str.total, category.id_comp],
end

lemma ι_iso_inv (sq₁ sq₂ : commsq f₁₁ g₁₁ g₁₂ f₂₁) :
  sq₂.ι ≫ (sq₁.sum.iso sq₂.sum).inv = sq₁.ι :=
ι_iso_hom _ _

lemma iso_inv_π (sq₁ sq₂ : commsq f₁₁ g₁₁ g₁₂ f₂₁) :
  (sq₁.sum.iso sq₂.sum).inv ≫ sq₁.π = sq₂.π :=
iso_hom_π _ _

end iso

lemma of_iso (e₁₁ : A₁₁ ≅ A₃₃) (e₁₂ : A₁₂ ≅ A₃₄) (e₂₁ : A₂₁ ≅ A₄₃) (e₂₂ : A₂₂ ≅ A₄₄)
  (sqa : commsq f₁₁ e₁₁.hom e₁₂.hom f₃₃) (sqb : commsq g₁₁ e₁₁.hom e₂₁.hom g₃₃)
  (sqc : commsq g₁₂ e₁₂.hom e₂₂.hom g₃₄) (sqd : commsq f₂₁ e₂₁.hom e₂₂.hom f₄₃)
  (sq1 : commsq f₁₁ g₁₁ g₁₂ f₂₁) :
  commsq f₃₃ g₃₃ g₃₄ f₄₃ :=
of_eq $ by rw [← cancel_epi e₁₁.hom, ← sqa.w_assoc, ← sqc.w, ← sqb.w_assoc, ← sqd.w, sq1.w_assoc]

def kernel (sq : commsq f₁₁ g₁₁ g₁₂ f₂₁) :
  commsq (kernel.ι f₁₁) (kernel.map _ _ _ _ sq.w) g₁₁ (kernel.ι f₂₁) :=
commsq.of_eq $ by simp only [kernel.lift_ι]

def cokernel (sq : commsq f₁₁ g₁₁ g₁₂ f₂₁) :
  commsq (cokernel.π f₁₁) g₁₂ (cokernel.map _ _ _ _ sq.w) (cokernel.π f₂₁) :=
commsq.of_eq $ by simp only [cokernel.π_desc]

def bicartesian (sq : commsq f₁₁ g₁₁ g₁₂ f₂₁) : Prop :=
short_exact (-f₁₁ ≫ sq.sum.inl + g₁₁ ≫ sq.sum.inr) sq.π

def bicartesian.is_limit {sq : commsq f₁₁ g₁₁ g₁₂ f₂₁} (h : sq.bicartesian) :
  is_limit (pullback_cone.mk f₁₁ g₁₁ sq.w) :=
pullback_cone.is_limit.mk sq.w
  (λ s, (@abelian.is_limit_of_exact_of_mono _ _ _ _ _ _ _ _ h.mono h.exact).lift
      (fork.of_ι (-s.fst ≫ sq.sum.inl + s.snd ≫ sq.sum.inr)
        (by simp only [s.condition, preadditive.add_comp, preadditive.neg_comp, category.assoc,
          inl_π, inr_π, add_left_neg, comp_zero])))
  (λ s,
  begin
    have : f₁₁ = -((-f₁₁ ≫ sq.sum.inl + g₁₁ ≫ sq.sum.inr) ≫ sq.sum.fst),
    { simp only [preadditive.add_comp, preadditive.neg_comp, category.assoc, sum_str.inl_fst,
        category.comp_id, sum_str.inr_fst, comp_zero, add_zero, neg_neg] },
    conv_lhs { congr, skip, rw this },
    rw [preadditive.comp_neg, ← category.assoc],
    erw (@abelian.is_limit_of_exact_of_mono _ _ _ _ _ _ _ _ h.mono h.exact).fac _
      walking_parallel_pair.zero,
    simp only [preadditive.add_comp, preadditive.neg_comp, category.assoc, comp_zero,
      fork.of_ι_π_app, sum_str.inl_fst, category.comp_id, sum_str.inr_fst, add_zero, neg_neg],
  end)
  (λ s,
  begin
    have : g₁₁ = (-f₁₁ ≫ sq.sum.inl + g₁₁ ≫ sq.sum.inr) ≫ sq.sum.snd,
    { simp only [preadditive.add_comp, preadditive.neg_comp, category.assoc, sum_str.inl_snd,
        comp_zero, neg_zero, sum_str.inr_snd, category.comp_id, zero_add] },
    conv_lhs { congr, skip, rw this },
    rw ← category.assoc,
    erw (@abelian.is_limit_of_exact_of_mono _ _ _ _ _ _ _ _ h.mono h.exact).fac _
      walking_parallel_pair.zero,
    simp only [preadditive.add_comp, preadditive.neg_comp, category.assoc, comp_zero,
      fork.of_ι_π_app, sum_str.inl_snd, neg_zero, sum_str.inr_snd, category.comp_id, zero_add],
  end)
  (λ s m h₁ h₂,
  begin
    apply fork.is_limit.hom_ext (@abelian.is_limit_of_exact_of_mono _ _ _ _ _ _ _ _ h.mono h.exact),
    erw [is_limit.fac],
    simp only [reassoc_of h₁, reassoc_of h₂, kernel_fork.ι_of_ι, preadditive.comp_add,
      preadditive.comp_neg, fork.of_ι_π_app],
  end)

def bicartesian.is_colimit {sq : commsq f₁₁ g₁₁ g₁₂ f₂₁} (h : sq.bicartesian) :
  is_colimit (pushout_cocone.mk g₁₂ f₂₁ sq.w) :=
pushout_cocone.is_colimit.mk sq.w
  (λ s, (@abelian.is_colimit_of_exact_of_epi _ _ _ _ _ _ _ _ h.epi h.exact).desc
    (cofork.of_π (sq.sum.fst ≫ s.inl + sq.sum.snd ≫ s.inr)
      (by simp only [s.condition, preadditive.comp_add, preadditive.add_comp_assoc,
        preadditive.neg_comp, category.assoc, sum_str.inl_fst, category.comp_id, sum_str.inr_fst,
        comp_zero, add_zero, sum_str.inl_snd, neg_zero, sum_str.inr_snd, zero_add, add_left_neg,
        zero_comp])))
  (λ s,
  begin
    conv_lhs { congr, rw [← sq.inl_π] },
    rw category.assoc,
    erw (@abelian.is_colimit_of_exact_of_epi _ _ _ _ _ _ _ _ h.epi h.exact).fac _
      walking_parallel_pair.one,
    simp only [preadditive.comp_add, add_zero, zero_comp, cofork.of_π_ι_app, sum_str.inl_fst_assoc,
      sum_str.inl_snd_assoc],
  end)
  (λ s,
  begin
    conv_lhs { congr, rw [← sq.inr_π] },
    rw category.assoc,
    erw (@abelian.is_colimit_of_exact_of_epi _ _ _ _ _ _ _ _ h.epi h.exact).fac _
      walking_parallel_pair.one,
    simp only [preadditive.comp_add, zero_add, zero_comp, cofork.of_π_ι_app, sum_str.inr_fst_assoc,
      sum_str.inr_snd_assoc]
  end)
  (λ s m h₁ h₂,
  begin
    apply cofork.is_colimit.hom_ext
      (@abelian.is_colimit_of_exact_of_epi _ _ _ _ _ _ _ _ h.epi h.exact),
    erw [is_colimit.fac],
    simp only [cokernel_cofork.π_of_π, cofork.of_π_ι_app],
    conv_lhs { congr, rw [← category.id_comp sq.π] },
    rw [← sq.sum.total],
    simp only [h₁, h₂, preadditive.add_comp, category.assoc, inl_π, inr_π]
  end)

lemma bicartesian.of_is_limit_of_is_colimt {sq : commsq f₁₁ g₁₁ g₁₂ f₂₁}
  (hl : is_limit (pullback_cone.mk f₁₁ g₁₁ sq.w)) (hc : is_colimit (pushout_cocone.mk g₁₂ f₂₁ sq.w)) :
  sq.bicartesian :=
begin
  have h : (-f₁₁ ≫ sq.sum.inl + g₁₁ ≫ sq.sum.inr) ≫ sq.π = 0,
  { simp only [sq.w, preadditive.add_comp, preadditive.neg_comp, category.assoc, inl_π, inr_π,
      add_left_neg] },
  let hker : is_limit (kernel_fork.of_ι _ h),
  { fapply kernel_fork.is_limit.of_ι,
    { refine λ T g hg, hl.lift (pullback_cone.mk (-g ≫ sq.sum.fst) (g ≫ sq.sum.snd) _),
      rw [sq.π_eq, preadditive.comp_add] at hg,
      simp only [add_eq_zero_iff_eq_neg.1 hg, preadditive.neg_comp, category.assoc,
        neg_neg] },
    { intros T g hg,
      simp only [preadditive.comp_add, preadditive.comp_neg, ← category.assoc],
      erw [hl.fac _ walking_span.left, hl.fac _ walking_span.right],
      simp only [preadditive.neg_comp, category.assoc, neg_neg, pullback_cone.mk_π_app_left,
        pullback_cone.mk_π_app_right, ← preadditive.comp_add, sq.sum.total, category.comp_id] },
    { intros T g hg m hm,
      apply pullback_cone.is_limit.hom_ext hl,
      { erw [pullback_cone.mk_fst, hl.fac _ walking_span.left],
        simp only [← hm, preadditive.neg_comp, category.assoc, neg_neg, pullback_cone.mk_π_app_left,
        preadditive.comp_neg, preadditive.add_comp, sum_str.inl_fst, category.comp_id,
        sum_str.inr_fst, comp_zero, add_zero] },
      { erw [pullback_cone.mk_snd, hl.fac _ walking_span.right],
        simp only [← hm, preadditive.neg_comp, category.assoc, pullback_cone.mk_π_app_right,
          preadditive.add_comp, sum_str.inl_snd, comp_zero, neg_zero, sum_str.inr_snd,
          category.comp_id, zero_add] } } },
  let hcoker : is_colimit (cokernel_cofork.of_π _ h),
  { fapply cokernel_cofork.is_colimit.of_π,
    { refine λ T g hg, hc.desc (pushout_cocone.mk (sq.sum.inl ≫ g) (sq.sum.inr ≫ g) _),
      rwa [preadditive.add_comp, preadditive.neg_comp, add_eq_zero_iff_neg_eq, neg_neg,
        category.assoc, category.assoc] at hg },
    { intros T g hg,
      simp only [sq.π_eq, preadditive.add_comp, category.assoc],
      erw [hc.fac _ walking_cospan.left, hc.fac _ walking_cospan.right],
      simp only [pushout_cocone.mk_ι_app_left, pushout_cocone.mk_ι_app_right, ← category.assoc,
        ← preadditive.add_comp, sq.sum.total, category.id_comp] },
    { intros T g hg m hm,
      apply pushout_cocone.is_colimit.hom_ext hc,
      { erw [pushout_cocone.mk_inl, hc.fac _ walking_cospan.left],
        simp only [← hm, pushout_cocone.mk_ι_app_left, inl_π_assoc] },
      { erw [pushout_cocone.mk_inr, hc.fac _ walking_cospan.right],
        simp only [←hm, pushout_cocone.mk_ι_app_right, inr_π_assoc] } } },
  haveI : mono (-f₁₁ ≫ sq.sum.inl + g₁₁ ≫ sq.sum.inr) := mono_of_is_limit_fork hker,
  haveI : epi sq.π := epi_of_is_colimit_cofork hcoker,
  exact ⟨abelian.exact_of_is_kernel _ _ h hker⟩
end

open category_theory.preadditive

lemma bicartesian.congr {sq₁ : commsq f₁₁ g₁₁ g₁₂ f₂₁}
  (h : sq₁.bicartesian) (sq₂ : commsq f₁₁ g₁₁ g₁₂ f₂₁) :
  sq₂.bicartesian :=
begin
  have := h.mono, have := h.epi, resetI,
  have hm : mono (-f₁₁ ≫ sq₂.sum.inl + g₁₁ ≫ sq₂.sum.inr),
  { suffices : -f₁₁ ≫ sq₂.sum.inl + g₁₁ ≫ sq₂.sum.inr =
      (-f₁₁ ≫ sq₁.sum.inl + g₁₁ ≫ sq₁.sum.inr) ≫ (sq₁.sum.iso sq₂.sum).hom,
    { rw [this], apply mono_comp },
    simp only [sum_str.iso_hom, comp_add, add_comp_assoc, neg_comp, category.assoc,
      sum_str.inl_fst, category.comp_id, sum_str.inr_fst, comp_zero, add_zero,
      sum_str.inl_snd, neg_zero, sum_str.inr_snd, zero_add], },
  have he : epi sq₂.π, { rw [← sq₁.iso_inv_π sq₂], apply epi_comp },
  have H : exact (-f₁₁ ≫ sq₂.sum.inl + g₁₁ ≫ sq₂.sum.inr) sq₂.π,
  { apply exact_of_iso_of_exact' _ _ _ _
      (iso.refl _) (sq₁.sum.iso sq₂.sum) (iso.refl _) _ _ h.exact,
    { simp only [iso.refl_hom, comp_add, category.id_comp, sum_str.iso_hom, add_comp_assoc,
        neg_comp, category.assoc, sum_str.inl_fst, sum_str.inr_fst, comp_zero, add_zero,
        sum_str.inl_snd, neg_zero, sum_str.inr_snd, zero_add], },
    { simp only [iso.refl_hom, category.comp_id, iso_hom_π], }, },
  exactI ⟨H⟩
end

lemma bicartesian_iff (sq₁ sq₂ : commsq f₁₁ g₁₁ g₁₂ f₂₁) :
  sq₁.bicartesian ↔ sq₂.bicartesian :=
⟨λ h, h.congr _, λ h, h.congr _⟩

--move this (do we want this?)
instance {C : Type*} [category C] [preadditive C] {X Y : C} : has_neg (X ≅ Y) :=
⟨λ e, ⟨-e.hom, -e.inv, by simp, by simp⟩⟩

@[simp] lemma neg_iso_hom {C : Type*} [category C] [preadditive C] {X Y : C} {e : X ≅ Y} :
  (-e).hom = -(e.hom) := rfl

@[simp] lemma neg_iso_inv {C : Type*} [category C] [preadditive C] {X Y : C} {e : X ≅ Y} :
  (-e).inv = -(e.inv) := rfl

-- move me
@[simp] lemma _root_.category_theory.short_exact.neg_left (h : short_exact f₁₁ f₁₂) :
  short_exact (-f₁₁) f₁₂ :=
begin
  haveI := h.mono, haveI := h.epi,
  refine ⟨_⟩,
  have : -f₁₁ = (-iso.refl _).hom ≫ f₁₁,
  { simp only [neg_iso_hom, iso.refl_hom, category.id_comp, neg_comp], },
  rw [this, exact_iso_comp],
  exact h.exact
end

-- move me
@[simp] lemma _root_.category_theory.short_exact.neg_left_iff :
  short_exact (-f₁₁) f₁₂ ↔ short_exact f₁₁ f₁₂ :=
begin
  refine ⟨_, λ h, h.neg_left⟩,
  intro h, simpa only [neg_neg] using h.neg_left
end

lemma bicartesian.symm {sq : commsq f₁₁ g₁₁ g₁₂ f₂₁} (h : sq.bicartesian) :
  sq.symm.bicartesian :=
begin
  rw bicartesian at h ⊢,
  rw ← category_theory.short_exact.neg_left_iff,
  simp only [neg_add_rev, neg_neg],
  exact h
end

lemma bicartesian.symm_iff (sq : commsq f₁₁ g₁₁ g₁₂ f₂₁) :
  sq.symm.bicartesian ↔ sq.bicartesian :=
⟨λ h, h.symm, λ h, h.symm⟩

section
variables (g₁₁ g₁₂ g₁₃)

-- move me
lemma short_exact.of_iso (h : short_exact f₁₁ f₁₂)
  (sq1 : commsq f₁₁ g₁₁ g₁₂ f₂₁) (sq2 : commsq f₁₂ g₁₂ g₁₃ f₂₂)
  [is_iso g₁₁] [is_iso g₁₂] [is_iso g₁₃] :
  short_exact f₂₁ f₂₂ :=
begin
  have := h.mono, have := h.epi, resetI,
  have : mono f₂₁,
  { suffices : mono (f₂₁ ≫ inv g₁₂), { resetI, apply mono_of_mono f₂₁ (inv g₁₂), },
    rw ← sq1.w_inv, apply_instance },
  have : epi f₂₂,
  { suffices : epi (g₁₂ ≫ f₂₂), { resetI, apply epi_of_epi g₁₂ f₂₂ },
    { rw ← sq2.w, apply epi_comp } },
  resetI, refine ⟨_⟩,
  apply exact_of_iso_of_exact' _ _ _ _ (as_iso g₁₁) (as_iso g₁₂) (as_iso g₁₃)
    sq1.symm.w sq2.symm.w h.exact,
end

end

lemma bicartesian.of_iso (e₁₁ : A₁₁ ≅ A₃₃) (e₁₂ : A₁₂ ≅ A₃₄) (e₂₁ : A₂₁ ≅ A₄₃) (e₂₂ : A₂₂ ≅ A₄₄)
  {sq1 : commsq f₁₁ g₁₁ g₁₂ f₂₁} {sq2 : commsq f₃₃ g₃₃ g₃₄ f₄₃}
  (sqa : commsq f₁₁ e₁₁.hom e₁₂.hom f₃₃) (sqb : commsq g₁₁ e₁₁.hom e₂₁.hom g₃₃)
  (sqc : commsq g₁₂ e₁₂.hom e₂₂.hom g₃₄) (sqd : commsq f₂₁ e₂₁.hom e₂₂.hom f₄₃)
  (h : sq1.bicartesian) :
  sq2.bicartesian :=
begin
  let e : sq1.S ≅ sq2.S := _,
  apply short_exact.of_iso e₁₁.hom e.hom e₂₂.hom h,
  swap 3,
  { refine ⟨sq1.sum.fst ≫ e₁₂.hom ≫ sq2.sum.inl + sq1.sum.snd ≫ e₂₁.hom ≫ sq2.sum.inr,
            sq2.sum.fst ≫ e₁₂.inv ≫ sq1.sum.inl + sq2.sum.snd ≫ e₂₁.inv ≫ sq1.sum.inr,
            _, _⟩;
    { dsimp, simp only [comp_add, add_comp_assoc, category.assoc, sum_str.inl_fst,
        category.comp_id, sum_str.inr_fst, comp_zero, add_zero, iso.hom_inv_id_assoc,
        sum_str.inl_snd, sum_str.inr_snd, zero_add, sq1.sum.total, sq2.sum.total,
        iso.inv_hom_id_assoc], }, },
  { apply commsq.of_eq, dsimp,
    simp only [comp_add, add_comp_assoc, neg_comp, category.assoc, sum_str.inl_fst,
      category.comp_id, sum_str.inr_fst, comp_zero, add_zero, sum_str.inl_snd, neg_zero,
      sum_str.inr_snd, zero_add, comp_neg, sqa.w_assoc, sqb.w_assoc], },
  { apply commsq.of_eq, dsimp,
    simp only [add_comp, category.assoc, inl_π, inr_π, ← sqc.w, ← sqd.w, sq1.π_eq], }
end

end commsq


import parlang.defs
import parlang.lemmas_active_map
import parlang.lemmas_thread_state
import parlang.lemmas_state

namespace parlang
variables {n : ℕ} {σ : Type} {ι : Type} {τ : ι → Type} [decidable_eq ι]

@[simp]
lemma exec_skip {n} {ac : vector bool n} {s} : exec_state (kernel.compute id : kernel σ τ) ac s s := begin
  rw [state.map_active_threads_id s ac] { occs := occurrences.pos [2] },
  apply exec_state.compute,
end

lemma exec_state_unique {s u t : state n σ τ} {ac : vector bool n} {k} (h₁ : exec_state k ac s u) (h₂ : exec_state k ac s t) : t = u := begin
  induction h₁ generalizing t,
  case exec_state.load {
    cases h₂, refl,
  },
  case exec_state.store {
    cases h₂, refl,
  },
  case exec_state.compute {
    cases h₂, refl,
  },
  case exec_state.sync_all {
    cases h₂,
    case parlang.exec_state.sync_all {
      by_cases hl : 0 < n,
      {
        have : h₁_m = h₂_m := by apply state.syncable_unique h₁_hs h₂_hs hl,
        subst this,
        refl,
      },
      {
        have : n = 0 := by simpa using hl,
        subst this,
        simp [state.map_threads],
        rw [vector.vector_0_eq h₁_s.threads, vector.map_nil, vector.map_nil],
      }
    },
    case parlang.exec_state.sync_none {
      by_cases hl : 0 < n,
      exact false.elim (no_threads_active_not_all_threads hl h₂_h h₁_ha),
      have : n = 0 := by simpa using hl,
      subst this,
      rw [state.map_threads, vector.vector_0_eq h₁_s.threads, vector.map_nil],
      sorry,
    },
  },
  case exec_state.sync_none {
    cases h₂,
    case parlang.exec_state.sync_all {
      by_cases hl : 0 < n,
      -- contradiction
      {apply false.elim (no_threads_active_not_all_threads hl h₁_h h₂_ha),},
      {
        by_cases h' : n = 0,
        swap,
        {
          sorry,
        }, {
          subst h',
          cases h₁_s,
          cases h₁_s,
          sorry,
        }
      }
    },
    case parlang.exec_state.sync_none {
      refl,
    }
  },
  case parlang.exec_state.seq {
    cases h₂,
    specialize h₁_ih_a h₂_a,
    subst h₁_ih_a,
    specialize h₁_ih_a_1 h₂_a_1,
    assumption,
  },
  case parlang.exec_state.ite {
    cases h₂,
    specialize h₁_ih_a h₂_a,
    subst h₁_ih_a,
    specialize h₁_ih_a_1 h₂_a_1,
    assumption,
  },
  case parlang.exec_state.loop_stop {
    cases h₂,
    case parlang.exec_state.loop_stop {
      refl,
    },
    case parlang.exec_state.loop_step {
      apply false.elim (no_threads_active_no_active_thread h₁_a h₂_a),
    }
  },
  case parlang.exec_state.loop_step {
    cases h₂,
    case parlang.exec_state.loop_stop {
      apply false.elim (no_threads_active_no_active_thread h₂_a h₁_a),
    },
    case parlang.exec_state.loop_step {
      specialize h₁_ih_a h₂_a_1,
      subst h₁_ih_a,
      specialize h₁_ih_a_1 h₂_a_2,
      assumption,
    }
  }
end

lemma exec_state_precedes {s u : state n σ τ} {ac : vector bool n} {k} : exec_state (k) ac s u → s.precedes u := begin
  intro he,
  cases he,
  case parlang.exec_state.load {
    unfold state.precedes,
    simp,
    intros a b,
    induction n,
    case nat.zero {
      exact match ac with
      | ⟨[], h⟩ := begin
          sorry,
          -- rw vector.map₂_nil',
          -- rw vector.map₂_nil,
          -- intro,
          -- have : (a, b) ∉ (@vector.nil (thread_state σ τ × thread_state σ τ)) := by apply vector.mem_nil,
          -- contradiction,
        end
      end,
    },
    case nat.succ {
      exact match ac, s.threads with
      | ⟨list.cons a ac_tl, h ⟩ := begin
          sorry
        end
      end,
    },
  },
  repeat { admit }
end

lemma exec_state_seq_left {s u : state n σ τ} {ac : vector bool n} {k₁ k₂} : exec_state (k₁ ;; k₂) ac s u → ∃t, exec_state k₁ ac s t ∧ t.precedes u := begin
  intro he,
  cases he,
  apply Exists.intro he_t,
  apply and.intro he_a _,
  apply exec_state_precedes he_a_1,
end

lemma exec_state_inactive_threads_untouched {s u : state n σ τ} {ac : vector bool n} {k} : exec_state k ac s u → ∀ i, ¬ ac.nth i → s.threads.nth i = u.threads.nth i := begin
  intros he i hna,
  induction he,
  case parlang.exec_state.load {
    apply state.map_active_threads_nth_inac hna,
  },
  case parlang.exec_state.store {
    apply state.map_active_threads_nth_inac hna,
  },
  case parlang.exec_state.compute {
    apply state.map_active_threads_nth_inac hna,
  },
  case parlang.exec_state.sync_all {
    have : ↥(vector.nth he_ac i) := by apply all_threads_active_nth he_ha,
    contradiction,
  },
  case parlang.exec_state.sync_none {
    refl,
  },
  case parlang.exec_state.seq {
    rw he_ih_a hna,
    rw he_ih_a_1 hna,
  },
  case parlang.exec_state.ite {
    rw he_ih_a (deactivate_threads_deactivate_inactive_thread hna),
    rw ← he_ih_a_1 (deactivate_threads_deactivate_inactive_thread hna),
  },
  case parlang.exec_state.loop_stop {
    refl,
  },
  case parlang.exec_state.loop_step {
    rw he_ih_a (deactivate_threads_deactivate_inactive_thread hna),
    rw ← he_ih_a_1 (deactivate_threads_deactivate_inactive_thread hna),
  }
end

lemma exec_skip_eq {n} {ac : vector bool n} {s t} : exec_state (kernel.compute id : kernel σ τ) ac s t → t = s := exec_state_unique exec_skip

lemma kernel_transform_inhab {k : kernel σ τ} {n} {ac} {s u} : exec_state k ac s u → ¬contains_sync k → ∃ f, kernel_transform_func k f n ac := begin
  intros h hs,
  unfold kernel_transform_func,
  induction k generalizing s u,
  case parlang.kernel.load {
    apply exists.intro (thread_state.load k),
    intros s u,
    apply iff.intro,
    {
      intro he,
      cases he,
      simp [state.map_active_threads],
    }, {
      intro hm,
      subst hm,
      apply exec_state.load,
    }
  },
  case parlang.kernel.sync {
    apply hs.elim,
    rw contains_sync,
    apply true.intro,
  },
  case parlang.kernel.seq {
    rw contains_sync at hs,
    have h1 : ¬contains_sync k_a := sorry,
    have h2 : ¬contains_sync k_a_1 := sorry,
    cases h,
    specialize k_ih_a h1 h_a,
    specialize k_ih_a_1 h2 h_a_1,
    cases k_ih_a with f,
    cases k_ih_a_1 with g,
    apply exists.intro (g ∘ f),
    intros s' u',
    apply iff.intro,
    {
      intros he,
      cases he,
      have h3 : he_t = state.map_active_threads ac f s' := (k_ih_a_h _ _).mp he_a,
      have h4 : u' = state.map_active_threads ac g he_t := (k_ih_a_1_h _ _).mp he_a_1,
      rw ← state.map_map_active_threads,
      rw h3 at h4,
      exact h4,
    }, {
      intro hmac,
      subst hmac,
      apply exec_state.seq,
      repeat { sorry }
    }
  },
  repeat { sorry }
end

/-- order of exec_state can be changed if their ac's are distinct -/
lemma exec_state_comm_distinct_ac {s t u : state n σ τ} {ac₁ ac₂ : vector bool n} {k₁ k₂} :
  ac_distinct ac₁ ac₂ →
  exec_state k₁ ac₁ s t →
  exec_state k₂ ac₂ t u →
  ∃ t', exec_state k₂ ac₂ s t' ∧ exec_state k₁ ac₁ t' u :=
begin
  intros hd hk₁ hk₂,
  have hf₁ : _ := kernel_transform_inhab hk₁ sorry,
  have hf₂ : _ := kernel_transform_inhab hk₂ sorry,
  cases hf₁ with f₁ hf₁,
  cases hf₂ with f₂ hf₂,
  have h : u = state.map_active_threads ac₂ f₂ (state.map_active_threads ac₁ f₁ s) := begin
    have hkst : t = state.map_active_threads ac₁ f₁ s := ((hf₁ s t).mp hk₁), -- an underscore as a type would break the rw below
    have hktu : _ := (hf₂ t u).mp hk₂,
    rw ← hkst,
    exact hktu,
  end,
  rw state.map_active_threads_comm hd at h,
  apply exists.intro (state.map_active_threads ac₂ f₂ s),
  apply and.intro,
  {
    apply (hf₂ _ _).mpr,
    refl,
  }, {
    apply (hf₁ _ _).mpr,
    exact h,
  }
end

@[simp]
lemma init_state_syncable {init : ℕ → σ} {f : memory τ → ℕ} {m : memory τ} : (init_state init f m).syncable m := begin
  unfold state.syncable init_state,
  simp,
end

lemma kernel_foldr_skip {k : kernel σ τ} {n} {ks s u} {ac : vector bool n} : exec_state (list.foldr kernel.seq k ks) ac s u = exec_state (list.foldr kernel.seq (kernel.compute id) ks ;; k) ac s u := sorry

lemma exec_no_threads_active {k : kernel σ τ} {n} {s} {ac : vector bool n}
(h : no_thread_active ac = tt) :
exec_state k ac s s := begin
  induction k,
  {
    rw [← state.map_active_threads_no_thread_active s ac _ h] { occs := occurrences.pos [2] },
    apply exec_state.load,
  }, {
    rw [← state.map_active_threads_no_thread_active s ac _ h] { occs := occurrences.pos [2] },
    apply exec_state.store,
  }, {
    rw [← state.map_active_threads_no_thread_active s ac _ h] { occs := occurrences.pos [2] },
    apply exec_state.compute,
  }, {
    apply exec_state.seq,
    repeat { assumption },
  }, {
    apply exec_state.ite,
    rw ac_deac_ge',
    exact k_ih_a,
    apply no_thread_active_ge,
    exact h,
    rw ac_deac_ge',
    exact k_ih_a_1,
    apply no_thread_active_ge,
    exact h,
  }, {
    apply exec_state.loop_stop,
    rw ac_deac_ge',
    exact h,
    apply no_thread_active_ge,
    exact h,
  }, {
    apply exec_state.sync_none,
    exact h,
  }
end

end parlang


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

! This file was ported from Lean 3 source module init.meta.expr
! leanprover-community/mathlib commit 569fa1a97c0a3d52ccd7286c659e42bbba8eb006
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
prelude
import Leanbin.Init.Meta.Level
import Leanbin.Init.Control.Monad
import Leanbin.Init.Meta.RbMap

universe u v

open Native

/-- Column and line position in a Lean source file. -/
structure Pos where
  line : Nat
  column : Nat
#align pos Pos

instance : DecidableEq Pos
  | ⟨l₁, c₁⟩, ⟨l₂, c₂⟩ =>
    if h₁ : l₁ = l₂ then
      if h₂ : c₁ = c₂ then isTrue (Eq.recOn h₁ (Eq.recOn h₂ rfl))
      else isFalse fun contra => Pos.noConfusion contra fun e₁ e₂ => absurd e₂ h₂
    else isFalse fun contra => Pos.noConfusion contra fun e₁ e₂ => absurd e₁ h₁

unsafe instance : has_to_format Pos :=
  ⟨fun ⟨l, c⟩ => "⟨" ++ l ++ ", " ++ c ++ "⟩"⟩

/-- Auxiliary annotation for binders (Lambda and Pi).
    This information is only used for elaboration.
      The difference between `{}` and `⦃⦄` is how implicit arguments are treated that are *not* followed by explicit arguments.
  `{}` arguments are applied eagerly, while `⦃⦄` arguments are left partially applied:
```lean
def foo {x : ℕ} : ℕ := x
def bar ⦃x : ℕ⦄ : ℕ := x
#check foo -- foo : ℕ
#check bar -- bar : Π ⦃x : ℕ⦄, ℕ
```
    -/
inductive BinderInfo-- `(x : α)`

  | default-- `{x : α}`

  | implicit-- `⦃x:α⦄`

  | strict_implicit-- `[x : α]`. Should be inferred with typeclass resolution.

  |
  inst_implicit/- Auxiliary internal attribute used to mark local constants representing recursive functions
        in recursive equations and `match` statements. -/

  | aux_decl
#align binder_info BinderInfo

instance : Repr BinderInfo :=
  ⟨fun bi =>
    match bi with
    | BinderInfo.default => "default"
    | BinderInfo.implicit => "implicit"
    | BinderInfo.strict_implicit => "strict_implicit"
    | BinderInfo.inst_implicit => "inst_implicit"
    | BinderInfo.aux_decl => "aux_decl"⟩

/-- Macros are basically "promises" to build an expr by some C++ code, you can't build them in Lean.
   You can unfold a macro and force it to evaluate.
   They are used for
   - `sorry`.
   - Term placeholders (`_`) in `pexpr`s.
   - Expression annotations. See `expr.is_annotation`.
   - Meta-recursive calls. Eg:
     ```
     meta def Y : (α → α) → α | f := f (Y f)
     ```
     The `Y` that appears in `f (Y f)` is a macro.
   - Builtin projections:
     ```
     structure foo := (mynat : ℕ)
     #print foo.mynat
     -- @[reducible]
     -- def foo.mynat : foo → ℕ :=
     -- λ (c : foo), [foo.mynat c]
     ```
     The thing in square brackets is a macro.
   - Ephemeral structures inside certain specialised C++ implemented tactics.
  -/
unsafe axiom macro_def : Type
#align macro_def macro_def

/-- An expression. eg ```(4+5)```.

    The `elab` flag is indicates whether the `expr` has been elaborated and doesn't contain any placeholder macros.
    For example the equality `x = x` is represented in `expr ff` as ``app (app (const `eq _) x) x`` while in `expr tt` it is represented as ``app (app (app (const `eq _) t) x) x`` (one more argument).
    The VM replaces instances of this datatype with the C++ implementation. -/
unsafe inductive expr (elaborated : Bool := true)-- A bound variable with a de-Bruijn index.

  | var (i : Nat) : expr-- A type universe: `Sort u`

  |
  sort (l : level) :
    expr/- A global constant. These include definitions, constants and inductive type stuff present
in the environment as well as hard-coded definitions. -/

  |
  const (name : Name) (ls : List level) :
    expr/- [WARNING] Do not trust the types for `mvar` and `local_const`,
they are sometimes dummy values. Use `tactic.infer_type` instead. -/
-- An `mvar` is a 'hole' yet to be filled in by the elaborator or tactic state.

  |
  mvar (unique : Name) (pretty : Name) (type : expr) :
    expr-- A local constant. For example, if our tactic state was `h : P ⊢ Q`, `h` would be a local constant.

  |
  local_const (unique : Name) (pretty : Name) (bi : BinderInfo) (type : expr) :
    expr-- Function application.

  | app (f : expr) (x : expr) : expr-- Lambda abstraction. eg ```(λ a : α, x)``

  |
  lam (var_name : Name) (bi : BinderInfo) (var_type : expr) (body : expr) :
    expr-- Pi type constructor. eg ```(Π a : α, x)`` and ```(α → β)``

  |
  pi (var_name : Name) (bi : BinderInfo) (var_type : expr) (body : expr) :
    expr-- An explicit let binding.

  |
  elet (var_name : Name) (type : expr) (assignment : expr) (body : expr) :
    expr/- A macro, see the docstring for `macro_def`.
  The list of expressions are local constants and metavariables that the macro depends on.
  -/

  | macro (m : macro_def) (args : List expr) : expr
#align expr expr

variable {elab : Bool}

unsafe instance : Inhabited (expr elab) :=
  ⟨expr.sort level.zero⟩

/-- Get the name of the macro definition. -/
unsafe axiom expr.macro_def_name (d : macro_def) : Name
#align expr.macro_def_name expr.macro_def_name

unsafe def expr.mk_var (n : Nat) : expr :=
  expr.var n
#align expr.mk_var expr.mk_var

/-- Expressions can be annotated using an annotation macro during compilation.
For example, a `have x:X, from p, q` expression will be compiled to `(λ x:X,q)(p)`, but nested in an annotation macro with the name `"have"`.
These annotations have no real semantic meaning, but are useful for helping Lean's pretty printer. -/
unsafe axiom expr.is_annotation : expr elab → Option (Name × expr elab)
#align expr.is_annotation expr.is_annotation

unsafe axiom expr.is_string_macro : expr elab → Option (expr elab)
#align expr.is_string_macro expr.is_string_macro

/-- Remove all macro annotations from the given `expr`. -/
unsafe def expr.erase_annotations : expr elab → expr elab
  | e =>
    match e.is_annotation with
    | some (_, a) => expr.erase_annotations a
    | none => e
#align expr.erase_annotations expr.erase_annotations

/-- Compares expressions, including binder names. -/
unsafe axiom expr.has_decidable_eq : DecidableEq expr
#align expr.has_decidable_eq expr.has_decidable_eq

attribute [instance] expr.has_decidable_eq

/-- Compares expressions while ignoring binder names. -/
unsafe axiom expr.alpha_eqv : expr → expr → Bool
#align expr.alpha_eqv expr.alpha_eqv

protected unsafe axiom expr.to_string : expr elab → String
#align expr.to_string expr.to_string

unsafe instance : ToString (expr elab) :=
  ⟨expr.to_string⟩

unsafe instance : has_to_format (expr elab) :=
  ⟨fun e => e.toString⟩

/-- Coercion for letting users write (f a) instead of (expr.app f a) -/
unsafe instance : CoeFun (expr elab) fun e => expr elab → expr elab :=
  ⟨fun e => expr.app e⟩

/-- Each expression created by Lean carries a hash.
This is calculated upon creation of the expression.
Two structurally equal expressions will have the same hash. -/
unsafe axiom expr.hash : expr → Nat
#align expr.hash expr.hash

/-- Compares expressions, ignoring binder names, and sorting by hash. -/
unsafe axiom expr.lt : expr → expr → Bool
#align expr.lt expr.lt

/-- Compares expressions, ignoring binder names. -/
unsafe axiom expr.lex_lt : expr → expr → Bool
#align expr.lex_lt expr.lex_lt

/--
`expr.fold e a f`: Traverses each subexpression of `e`. The `nat` passed to the folder `f` is the binder depth. -/
unsafe axiom expr.fold {α : Type} : expr → α → (expr → Nat → α → α) → α
#align expr.fold expr.fold

/-- `expr.replace e f`
 Traverse over an expr `e` with a function `f` which can decide to replace subexpressions or not.
 For each subexpression `s` in the expression tree, `f s n` is called where `n` is how many binders are present above the given subexpression `s`.
 If `f s n` returns `none`, the children of `s` will be traversed.
 Otherwise if `some s'` is returned, `s'` will replace `s` and this subexpression will not be traversed further.
 -/
unsafe axiom expr.replace : expr → (expr → Nat → Option expr) → expr
#align expr.replace expr.replace

/--
`abstract_local e n` replaces each instance of the local constant with unique (not pretty) name `n` in `e` with a de-Bruijn variable. -/
unsafe axiom expr.abstract_local : expr → Name → expr
#align expr.abstract_local expr.abstract_local

/--
Multi version of `abstract_local`. Note that the given expression will only be traversed once, so this is not the same as `list.foldl expr.abstract_local`.-/
unsafe axiom expr.abstract_locals : expr → List Name → expr
#align expr.abstract_locals expr.abstract_locals

/-- `abstract e x` Abstracts the expression `e` over the local constant `x`.  -/
unsafe def expr.abstract : expr → expr → expr
  | e, expr.local_const n m bi t => e.abstract_local n
  | e, _ => e
#align expr.abstract expr.abstract

/-- Expressions depend on `level`s, and these may depend on universe parameters which have names.
`instantiate_univ_params e [(n₁,l₁), ...]` will traverse `e` and replace any universe parameters with name `nᵢ` with the corresponding level `lᵢ`.  -/
unsafe axiom expr.instantiate_univ_params : expr → List (Name × level) → expr
#align expr.instantiate_univ_params expr.instantiate_univ_params

/--
`instantiate_nth_var n a b` takes the `n`th de-Bruijn variable in `a` and replaces each occurrence with `b`. -/
unsafe axiom expr.instantiate_nth_var : Nat → expr → expr → expr
#align expr.instantiate_nth_var expr.instantiate_nth_var

/--
`instantiate_var a b` takes the 0th de-Bruijn variable in `a` and replaces each occurrence with `b`. -/
unsafe axiom expr.instantiate_var : expr → expr → expr
#align expr.instantiate_var expr.instantiate_var

/-- ``instantiate_vars `(#0 #1 #2) [x,y,z] = `(%%x %%y %%z)`` -/
unsafe axiom expr.instantiate_vars : expr → List expr → expr
#align expr.instantiate_vars expr.instantiate_vars

/-- Same as `instantiate_vars` except lifts and shifts the vars by the given amount.
``instantiate_vars_core `(#0 #1 #2 #3) 0 [x,y] = `(x y #0 #1)``
``instantiate_vars_core `(#0 #1 #2 #3) 1 [x,y] = `(#0 x y #1)``
``instantiate_vars_core `(#0 #1 #2 #3) 2 [x,y] = `(#0 #1 x y)``
-/
unsafe axiom expr.instantiate_vars_core : expr → Nat → List expr → expr
#align expr.instantiate_vars_core expr.instantiate_vars_core

/--
Perform beta-reduction if the left expression is a lambda, or construct an application otherwise.
That is: ``expr.subst `(λ x, %%Y) Z = Y[x/Z]``, and
``expr.subst X Z = X.app Z`` otherwise -/
protected unsafe axiom expr.subst : expr elab → expr elab → expr elab
#align expr.subst expr.subst

/--
`get_free_var_range e` returns one plus the maximum de-Bruijn value in `e`. Eg `get_free_var_range `(#1 #0)` yields `2` -/
unsafe axiom expr.get_free_var_range : expr → Nat
#align expr.get_free_var_range expr.get_free_var_range

/-- `has_var e` returns true iff e has free variables. -/
unsafe axiom expr.has_var : expr → Bool
#align expr.has_var expr.has_var

/-- `has_var_idx e n` returns true iff `e` has a free variable with de-Bruijn index `n`. -/
unsafe axiom expr.has_var_idx : expr → Nat → Bool
#align expr.has_var_idx expr.has_var_idx

/-- `has_local e` returns true if `e` contains a local constant. -/
unsafe axiom expr.has_local : expr → Bool
#align expr.has_local expr.has_local

/-- `has_meta_var e` returns true iff `e` contains a metavariable. -/
unsafe axiom expr.has_meta_var : expr → Bool
#align expr.has_meta_var expr.has_meta_var

/--
`lower_vars e s d` lowers the free variables >= s in `e` by `d`. Note that this can cause variable clashes.
    examples:
    -  ``lower_vars `(#2 #1 #0) 1 1 = `(#1 #0 #0)``
    -  ``lower_vars `(λ x, #2 #1 #0) 1 1 = `(λ x, #1 #1 #0 )``
    -/
unsafe axiom expr.lower_vars : expr → Nat → Nat → expr
#align expr.lower_vars expr.lower_vars

/--
Lifts free variables. `lift_vars e s d` will lift all free variables with index `≥ s` in `e` by `d`. -/
unsafe axiom expr.lift_vars : expr → Nat → Nat → expr
#align expr.lift_vars expr.lift_vars

/-- Get the position of the given expression in the Lean source file, if anywhere. -/
protected unsafe axiom expr.pos : expr elab → Option Pos
#align expr.pos expr.pos

/-- `copy_pos_info src tgt` copies position information from `src` to `tgt`. -/
unsafe axiom expr.copy_pos_info : expr → expr → expr
#align expr.copy_pos_info expr.copy_pos_info

/-- Returns `some n` when the given expression is a constant with the name `..._cnstr.n`
```
is_internal_cnstr : expr → option unsigned
|(const (mk_numeral n (mk_string "_cnstr" _)) _) := some n
|_ := none
```
[NOTE] This is not used anywhere in core Lean.
-/
unsafe axiom expr.is_internal_cnstr : expr → Option Unsigned
#align expr.is_internal_cnstr expr.is_internal_cnstr

/--
There is a macro called a "nat_value_macro" holding a natural number which are used during compilation.
This function extracts that to a natural number. [NOTE] This is not used anywhere in Lean. -/
unsafe axiom expr.get_nat_value : expr → Option Nat
#align expr.get_nat_value expr.get_nat_value

/-- Get a list of all of the universe parameters that the given expression depends on. -/
unsafe axiom expr.collect_univ_params : expr → List Name
#align expr.collect_univ_params expr.collect_univ_params

/--
`occurs e t` returns `tt` iff `e` occurs in `t` up to α-equivalence. Purely structural: no unification or definitional equality. -/
unsafe axiom expr.occurs : expr → expr → Bool
#align expr.occurs expr.occurs

/-- Returns true if any of the names in the given `name_set` are present in the given `expr`. -/
unsafe axiom expr.has_local_in : expr → name_set → Bool
#align expr.has_local_in expr.has_local_in

/-- Computes the number of sub-expressions (constant time). -/
unsafe axiom expr.get_weight : expr → ℕ
#align expr.get_weight expr.get_weight

/-- Computes the maximum depth of the expression (constant time). -/
unsafe axiom expr.get_depth : expr → ℕ
#align expr.get_depth expr.get_depth

/--
`mk_delayed_abstraction m ls` creates a delayed abstraction on the metavariable `m` with the unique names of the local constants `ls`.
    If `m` is not a metavariable then this is equivalent to `abstract_locals`.
 -/
unsafe axiom expr.mk_delayed_abstraction : expr → List Name → expr
#align expr.mk_delayed_abstraction expr.mk_delayed_abstraction

/-- If the given expression is a delayed abstraction macro, return `some ls`
where `ls` is a list of unique names of locals that will be abstracted. -/
unsafe axiom expr.get_delayed_abstraction_locals : expr → Option (List Name)
#align expr.get_delayed_abstraction_locals expr.get_delayed_abstraction_locals

/-- (reflected a) is a special opaque container for a closed `expr` representing `a`.
    It can only be obtained via type class inference, which will use the representation
    of `a` in the calling context. Local constants in the representation are replaced
    by nested inference of `reflected` instances.

    The quotation expression `` `(a) `` (outside of patterns) is equivalent to `reflect a`
    and thus can be used as an explicit way of inferring an instance of `reflected a`.

    Note that the `α` argument is explicit to prevent it being treated as reducible by typeclass
    inference, as this breaks `reflected` instances on type synonyms. -/
@[class]
unsafe def reflected (α : Sort u) : α → Type := fun _ => expr
#align reflected reflected

@[inline]
unsafe def reflected.to_expr {α : Sort u} {a : α} : reflected _ a → expr :=
  id
#align reflected.to_expr reflected.to_expr

/-- This is a more strongly-typed version of `expr.subst` that keeps track of the value being
reflected. To obtain a term of type `reflected _`, use `` (`(λ x y, foo x y).subst ex).subst ey`` instead of
using `` `(foo %%ex %%ey) `` (which returns an `expr`). -/
@[inline]
unsafe def reflected.subst {α : Sort v} {β : α → Sort u} {f : ∀ a : α, β a} {a : α} :
    reflected _ f → reflected _ a → reflected _ (f a) :=
  expr.subst
#align reflected.subst reflected.subst

@[instance]
protected unsafe axiom expr.reflect (e : expr elab) : reflected _ e
#align expr.reflect expr.reflect

@[instance]
protected unsafe axiom string.reflect (s : String) : reflected _ s
#align string.reflect string.reflect

@[inline]
unsafe instance {α : Sort u} (a : α) : Coe (reflected _ a) expr :=
  ⟨reflected.to_expr⟩

protected unsafe def reflect {α : Sort u} (a : α) [h : reflected _ a] : reflected _ a :=
  h
#align reflect reflect

unsafe instance {α} (a : α) : has_to_format (reflected _ a) :=
  ⟨fun h => to_fmt h.to_expr⟩

namespace Expr

open Decidable

unsafe def lt_prop (a b : expr) : Prop :=
  expr.lt a b = true
#align expr.lt_prop expr.lt_prop

unsafe instance : DecidableRel expr.lt_prop := fun a b => Bool.decidableEq _ _

/-- Compares expressions, ignoring binder names, and sorting by hash. -/
unsafe instance : LT expr :=
  ⟨expr.lt_prop⟩

unsafe def mk_true : expr :=
  const `true []
#align expr.mk_true expr.mk_true

unsafe def mk_false : expr :=
  const `false []
#align expr.mk_false expr.mk_false

/-- Returns the sorry macro with the given type. -/
unsafe axiom mk_sorry (type : expr) : expr
#align expr.mk_sorry expr.mk_sorry

/-- Checks whether e is sorry, and returns its type. -/
unsafe axiom is_sorry (e : expr) : Option expr
#align expr.is_sorry expr.is_sorry

/-- Replace each instance of the local constant with name `n` by the expression `s` in `e`. -/
unsafe def instantiate_local (n : Name) (s : expr) (e : expr) : expr :=
  instantiate_var (abstract_local e n) s
#align expr.instantiate_local expr.instantiate_local

unsafe def instantiate_locals (s : List (Name × expr)) (e : expr) : expr :=
  instantiate_vars (abstract_locals e (List.reverse (List.map Prod.fst s))) (List.map Prod.snd s)
#align expr.instantiate_locals expr.instantiate_locals

unsafe def is_var : expr → Bool
  | var _ => true
  | _ => false
#align expr.is_var expr.is_var

unsafe def app_of_list : expr → List expr → expr
  | f, [] => f
  | f, p :: ps => app_of_list (f p) ps
#align expr.app_of_list expr.app_of_list

unsafe def is_app : expr → Bool
  | app f a => true
  | e => false
#align expr.is_app expr.is_app

unsafe def app_fn : expr → expr
  | app f a => f
  | a => a
#align expr.app_fn expr.app_fn

unsafe def app_arg : expr → expr
  | app f a => a
  | a => a
#align expr.app_arg expr.app_arg

unsafe def get_app_fn : expr elab → expr elab
  | app f a => get_app_fn f
  | a => a
#align expr.get_app_fn expr.get_app_fn

unsafe def get_app_num_args : expr → Nat
  | app f a => get_app_num_args f + 1
  | e => 0
#align expr.get_app_num_args expr.get_app_num_args

unsafe def get_app_args_aux : List expr → expr → List expr
  | r, app f a => get_app_args_aux (a :: r) f
  | r, e => r
#align expr.get_app_args_aux expr.get_app_args_aux

unsafe def get_app_args : expr → List expr :=
  get_app_args_aux []
#align expr.get_app_args expr.get_app_args

unsafe def mk_app : expr → List expr → expr
  | e, [] => e
  | e, x :: xs => mk_app (e x) xs
#align expr.mk_app expr.mk_app

unsafe def mk_binding (ctor : Name → BinderInfo → expr → expr → expr) (e : expr) : ∀ l : expr, expr
  | local_const n pp_n bi ty => ctor pp_n bi ty (e.abstract_local n)
  | _ => e
#align expr.mk_binding expr.mk_binding

/-- (bind_pi e l) abstracts and pi-binds the local `l` in `e` -/
unsafe def bind_pi :=
  mk_binding pi
#align expr.bind_pi expr.bind_pi

/-- (bind_lambda e l) abstracts and lambda-binds the local `l` in `e` -/
unsafe def bind_lambda :=
  mk_binding lam
#align expr.bind_lambda expr.bind_lambda

unsafe def ith_arg_aux : expr → Nat → expr
  | app f a, 0 => a
  | app f a, n + 1 => ith_arg_aux f n
  | e, _ => e
#align expr.ith_arg_aux expr.ith_arg_aux

unsafe def ith_arg (e : expr) (i : Nat) : expr :=
  ith_arg_aux e (get_app_num_args e - i - 1)
#align expr.ith_arg expr.ith_arg

unsafe def const_name : expr elab → Name
  | const n ls => n
  | e => Name.anonymous
#align expr.const_name expr.const_name

unsafe def is_constant : expr elab → Bool
  | const n ls => true
  | e => false
#align expr.is_constant expr.is_constant

unsafe def is_local_constant : expr → Bool
  | local_const n m bi t => true
  | e => false
#align expr.is_local_constant expr.is_local_constant

unsafe def local_uniq_name : expr → Name
  | local_const n m bi t => n
  | e => Name.anonymous
#align expr.local_uniq_name expr.local_uniq_name

unsafe def local_pp_name : expr elab → Name
  | local_const x n bi t => n
  | e => Name.anonymous
#align expr.local_pp_name expr.local_pp_name

unsafe def local_type : expr elab → expr elab
  | local_const _ _ _ t => t
  | e => e
#align expr.local_type expr.local_type

unsafe def is_aux_decl : expr → Bool
  | local_const _ _ BinderInfo.aux_decl _ => true
  | _ => false
#align expr.is_aux_decl expr.is_aux_decl

unsafe def is_constant_of : expr elab → Name → Bool
  | const n₁ ls, n₂ => n₁ = n₂
  | e, n => false
#align expr.is_constant_of expr.is_constant_of

unsafe def is_app_of (e : expr) (n : Name) : Bool :=
  is_constant_of (get_app_fn e) n
#align expr.is_app_of expr.is_app_of

/-- The same as `is_app_of` but must also have exactly `n` arguments. -/
unsafe def is_napp_of (e : expr) (c : Name) (n : Nat) : Bool :=
  is_app_of e c ∧ get_app_num_args e = n
#align expr.is_napp_of expr.is_napp_of

unsafe def is_false : expr → Bool
  | q(False) => true
  | _ => false
#align expr.is_false expr.is_false

-- failed to format: unknown constant 'term.pseudo.antiquot'
unsafe
  def
    is_not
    : expr → Option expr
    | q( Not $ ( a ) ) => some a | q( $ ( a ) → False ) => some a | e => none
#align expr.is_not expr.is_not

unsafe def is_and : expr → Option (expr × expr)
  | q(And $(α) $(β)) => some (α, β)
  | _ => none
#align expr.is_and expr.is_and

unsafe def is_or : expr → Option (expr × expr)
  | q(Or $(α) $(β)) => some (α, β)
  | _ => none
#align expr.is_or expr.is_or

unsafe def is_iff : expr → Option (expr × expr)
  | q(($(a) : Prop) ↔ $(b)) => some (a, b)
  | _ => none
#align expr.is_iff expr.is_iff

unsafe def is_eq : expr → Option (expr × expr)
  | q(($(a) : $(_)) = $(b)) => some (a, b)
  | _ => none
#align expr.is_eq expr.is_eq

unsafe def is_ne : expr → Option (expr × expr)
  | q(($(a) : $(_)) ≠ $(b)) => some (a, b)
  | _ => none
#align expr.is_ne expr.is_ne

unsafe def is_bin_arith_app (e : expr) (op : Name) : Option (expr × expr) :=
  if is_napp_of e op 4 then some (app_arg (app_fn e), app_arg e) else none
#align expr.is_bin_arith_app expr.is_bin_arith_app

unsafe def is_lt (e : expr) : Option (expr × expr) :=
  is_bin_arith_app e `` LT.lt
#align expr.is_lt expr.is_lt

unsafe def is_gt (e : expr) : Option (expr × expr) :=
  is_bin_arith_app e `` GT.gt
#align expr.is_gt expr.is_gt

unsafe def is_le (e : expr) : Option (expr × expr) :=
  is_bin_arith_app e `` LE.le
#align expr.is_le expr.is_le

unsafe def is_ge (e : expr) : Option (expr × expr) :=
  is_bin_arith_app e `` GE.ge
#align expr.is_ge expr.is_ge

unsafe def is_heq : expr → Option (expr × expr × expr × expr)
  | q(@HEq $(α) $(a) $(β) $(b)) => some (α, a, β, b)
  | _ => none
#align expr.is_heq expr.is_heq

unsafe def is_lambda : expr → Bool
  | lam _ _ _ _ => true
  | e => false
#align expr.is_lambda expr.is_lambda

unsafe def is_pi : expr → Bool
  | pi _ _ _ _ => true
  | e => false
#align expr.is_pi expr.is_pi

unsafe def is_arrow : expr → Bool
  | pi _ _ _ b => not (has_var b)
  | e => false
#align expr.is_arrow expr.is_arrow

unsafe def is_let : expr → Bool
  | elet _ _ _ _ => true
  | e => false
#align expr.is_let expr.is_let

/-- The name of the bound variable in a pi, lambda or let expression. -/
unsafe def binding_name : expr → Name
  | pi n _ _ _ => n
  | lam n _ _ _ => n
  | elet n _ _ _ => n
  | e => Name.anonymous
#align expr.binding_name expr.binding_name

/-- The binder info of a pi or lambda expression. -/
unsafe def binding_info : expr → BinderInfo
  | pi _ bi _ _ => bi
  | lam _ bi _ _ => bi
  | e => BinderInfo.default
#align expr.binding_info expr.binding_info

/-- The domain (type of bound variable) of a pi, lambda or let expression. -/
unsafe def binding_domain : expr → expr
  | pi _ _ d _ => d
  | lam _ _ d _ => d
  | elet _ d _ _ => d
  | e => e
#align expr.binding_domain expr.binding_domain

/-- The body of a pi, lambda or let expression.
  This definition doesn't instantiate bound variables, and therefore produces a term that is open.
  See note [open expressions] in mathlib. -/
unsafe def binding_body : expr → expr
  | pi _ _ _ b => b
  | lam _ _ _ b => b
  | elet _ _ _ b => b
  | e => e
#align expr.binding_body expr.binding_body

/-- `nth_binding_body n e` iterates `binding_body` `n` times to an iterated pi expression `e`.
  This definition doesn't instantiate bound variables, and therefore produces a term that is open.
  See note [open expressions] in mathlib. -/
unsafe def nth_binding_body : ℕ → expr → expr
  | n + 1, pi _ _ _ b => nth_binding_body n b
  | _, e => e
#align expr.nth_binding_body expr.nth_binding_body

unsafe def is_macro : expr → Bool
  | macro d a => true
  | e => false
#align expr.is_macro expr.is_macro

unsafe def is_numeral : expr → Bool
  | q(@Zero.zero $(α) $(s)) => true
  | q(@One.one $(α) $(s)) => true
  | q(@bit0 $(α) $(s) $(v)) => is_numeral v
  | q(@bit1 $(α) $(s₁) $(s₂) $(v)) => is_numeral v
  | _ => false
#align expr.is_numeral expr.is_numeral

unsafe def pi_arity : expr → ℕ
  | pi _ _ _ b => pi_arity b + 1
  | _ => 0
#align expr.pi_arity expr.pi_arity

unsafe def lam_arity : expr → ℕ
  | lam _ _ _ b => lam_arity b + 1
  | _ => 0
#align expr.lam_arity expr.lam_arity

unsafe def imp (a b : expr) : expr :=
  pi `_ BinderInfo.default a b
#align expr.imp expr.imp

/-- `lambdas cs e` lambda binds `e` with each of the local constants in `cs`.  -/
unsafe def lambdas : List expr → expr → expr
  | local_const uniq pp info t :: es, f => lam pp info t (abstract_local (lambdas es f) uniq)
  | _, f => f
#align expr.lambdas expr.lambdas

/-- Same as `expr.lambdas` but with `pi`. -/
unsafe def pis : List expr → expr → expr
  | local_const uniq pp info t :: es, f => pi pp info t (abstract_local (pis es f) uniq)
  | _, f => f
#align expr.pis expr.pis

unsafe def extract_opt_auto_param : expr → expr
  | q(@optParam $(t) _) => extract_opt_auto_param t
  | q(@autoParam $(t) _) => extract_opt_auto_param t
  | e => e
#align expr.extract_opt_auto_param expr.extract_opt_auto_param

open Format

private unsafe def p : List format → format
  | [] => ""
  | [x] => x.paren
  | x :: y :: xs => p ((x ++ format.line ++ y).group :: xs)
#align expr.p expr.p

unsafe def to_raw_fmt : expr elab → format
  | var n => p ["var", to_fmt n]
  | sort l => p ["sort", to_fmt l]
  | const n ls => p ["const", to_fmt n, to_fmt ls]
  | mvar n m t => p ["mvar", to_fmt n, to_fmt m, to_raw_fmt t]
  | local_const n m bi t => p ["local_const", to_fmt n, to_fmt m, to_raw_fmt t]
  | app e f => p ["app", to_raw_fmt e, to_raw_fmt f]
  | lam n bi e t => p ["lam", to_fmt n, repr bi, to_raw_fmt e, to_raw_fmt t]
  | pi n bi e t => p ["pi", to_fmt n, repr bi, to_raw_fmt e, to_raw_fmt t]
  | elet n g e f => p ["elet", to_fmt n, to_raw_fmt g, to_raw_fmt e, to_raw_fmt f]
  | macro d args =>
    sbracket
      (format.join
        (List.intersperse " " ("macro" :: to_fmt (macro_def_name d) :: args.map to_raw_fmt)))
#align expr.to_raw_fmt expr.to_raw_fmt

/-- Fold an accumulator `a` over each subexpression in the expression `e`.
The `nat` passed to `fn` is the number of binders above the subexpression. -/
unsafe def mfold {α : Type} {m : Type → Type} [Monad m] (e : expr) (a : α)
    (fn : expr → Nat → α → m α) : m α :=
  fold e (return a) fun e n a => a >>= fn e n
#align expr.mfold expr.mfold

end Expr

/-- An dictionary from `data` to expressions. -/
@[reducible]
unsafe def expr_map (data : Type) :=
  rb_map expr data
#align expr_map expr_map

namespace ExprMap

export
  Native.RbMap (mk_core size Empty insert eraseₓ contains find min max fold keys values toList mfold of_list set_of_list map for filterₓ)

unsafe def mk (data : Type) : expr_map data :=
  rb_map.mk expr data
#align expr_map.mk expr_map.mk

end ExprMap

unsafe def mk_expr_map {data : Type} : expr_map data :=
  expr_map.mk data
#align mk_expr_map mk_expr_map

@[reducible]
unsafe def expr_set :=
  rb_set expr
#align expr_set expr_set

unsafe def mk_expr_set : expr_set :=
  mk_rb_set
#align mk_expr_set mk_expr_set


import ReactorModel.Objects.Reactor.Indexable

namespace ReactorType
namespace Indexable

variable [a : Indexable α]

variable {rtr rtr₁ rtr₂ : α}

theorem con?_eq_some (h : rtr[cpt][i]& = some con) :
    ∃ m : Member cpt i rtr, m.container = con := by
  simp [con?] at h
  split at h
  case inl n => exists n.some; injection h
  case inr => contradiction

theorem con?_to_obj?_and_cpt? (h : rtr[cpt][i]& = some con) :
    (rtr[.rtr][con.id] = con.rtr) ∧ ∃ o, (cpt? cpt con.rtr i = some o) := by
  sorry

theorem obj?_to_con?_and_cpt? {o} {i : ID} (h : rtr[cpt][i] = some o) :
    ∃ c, (rtr[cpt][i]& = some c) ∧ (cpt? cpt c.rtr i = some o) := by
  cases cpt
  all_goals
    simp [obj?, bind] at h
    assumption

theorem obj?_split {o} {i : ID} (h : rtr[cpt][i] = some o) :
    ∃ c con, (rtr[.rtr][c] = some con) ∧ (cpt? cpt con i = some o) := by
  have ⟨⟨c, con⟩, ho, _⟩ := obj?_to_con?_and_cpt? h
  have ⟨_, _, _⟩ := con?_to_obj?_and_cpt? ho
  exists c, con

theorem cpt?_to_con? {o} (h : cpt? cpt rtr i = some o) : rtr[cpt][i]& = some ⟨⊤, rtr⟩ := by
  let m := Member.final (Partial.mem_iff.mpr ⟨_, h⟩)
  simp [con?, Nonempty.intro m, ←a.unique_ids.allEq m, Member.container]

theorem cpt?_to_obj? {o} (h : cpt? cpt rtr i = some o) : rtr[cpt][i] = some o := by
  cases cpt
  all_goals
    simp [obj?, bind]
    exact ⟨⟨⊤, rtr⟩, cpt?_to_con? h, h⟩

theorem con?_nested {c : ID} (h : nest rtr₁ i = some rtr₂) (ho : rtr₂[cpt][j]& = some ⟨c, con⟩) :
    rtr₁[cpt][j]& = some ⟨c, con⟩ := by
  simp [con?] at ho ⊢
  split at ho
  case inr => contradiction
  case inl n =>
    set m := n.some
    cases hm : m
    case final hc =>
      simp [hm, Member.container] at ho
    case nest l₂ h₂ =>
      let l₁ := Member.nest h (.nest h₂ l₂)
      simp [hm, Member.container] at ho
      simp [Nonempty.intro l₁, ←a.unique_ids.allEq l₁, Member.container, ho]

theorem con?_eq_root (h : rtr[cpt][i]& = some ⟨⊤, con⟩) : rtr = con :=
  Member.container_eq_root (con?_eq_some h).choose_spec

theorem obj?_nested {o} {j : ID} (h : nest rtr₁ i = some rtr₂) (ho : rtr₂[cpt][j] = some o) :
    rtr₁[cpt][j] = some o := by
  cases cpt <;> try cases j
  all_goals
    simp [obj?, bind]
    have ⟨⟨c, con⟩, hc, ho⟩ := obj?_to_con?_and_cpt? ho
    cases c
    case some c =>
      have := con?_nested h hc
      exists ⟨c, con⟩
    case none =>
      replace hc := con?_eq_root hc
      simp at ho
      subst hc
      exists ⟨i, rtr₂⟩
      let m := Member.nest h (.final $ Partial.mem_iff.mpr ⟨_, ho⟩)
      simp [ho, con?, Nonempty.intro m, ←a.unique_ids.allEq m, Member.container]

-- Note: By `ho` we get `rtr₂ = rtr₃`.
theorem obj?_nested_root (h : nest rtr₁ i = some rtr₂) (ho : rtr₂[.rtr][⊤] = some rtr₃) :
    ∃ j, rtr₁[.rtr][j] = some rtr₃ := by
  simp [obj?] at ho
  exact ⟨i, ho ▸ cpt?_to_obj? h⟩

-- This is a version of `obj?_nested`, where we don't restrict `j` to be an `ID`. This makes a
-- difference when `cpt = .rtr`. Note that if `cpt = .rtr` and `j = ⊤`, then `j' = .nest i`.
theorem obj?_nested' {o j} (h : nest rtr₁ i = some rtr₂) (ho : rtr₂[cpt][j] = some o) :
    ∃ j', rtr₁[cpt][j'] = some o := by
  cases cpt <;> try cases j
  case rtr.none => exact obj?_nested_root h ho
  all_goals exact ⟨_, obj?_nested h ho⟩

theorem obj?_mem_nested {j : ID} (h : nest rtr₁ i = some rtr₂) (hm : ↑j ∈ rtr₂[cpt]) :
    ↑j ∈ rtr₁[cpt] :=
  Partial.mem_iff.mpr ⟨_, obj?_nested h (Partial.mem_iff.mp hm).choose_spec⟩

theorem mem_cpt?_rtr_eq (ho₁ : rtr[.rtr][c₁] = some con₁) (ho₂ : rtr[.rtr][c₂] = some con₂)
    (hc₁ : j ∈ cpt? cpt con₁) (hc₂ : j ∈ cpt? cpt con₂) : c₁ = c₂ := by
  cases c₁ <;> cases c₂
  case none.none => rfl
  case none.some => sorry
  case some.none => sorry
  case some.some =>
    -- TODO: We can build two `Member` instances here.
    --       One from ho₁ and hc₁ and one from ho₂ and hc₂.
    --       By `unique_ids` they are equal, from which we can extract that `c₁ = c₂`.
    --       The main difficulty is building the `Member` instances.
    sorry

theorem member_isEmpty_con?_none (h : IsEmpty (Member cpt i rtr)) : rtr[cpt][i]& = none := by
  cases cpt <;> simp [con?, not_nonempty_iff.mpr h]

theorem member_isEmpty_obj?_none (h : IsEmpty (Member cpt i rtr)) : rtr[cpt][i] = none := by
  cases cpt <;> simp [obj?, member_isEmpty_con?_none h, bind]

end Indexable

open Indexable Updatable

namespace LawfulMemUpdate

variable [Indexable α] {rtr₁ : α}

theorem obj?_preserved (u : LawfulMemUpdate cpt i f rtr₁ rtr₂) (h : c ≠ cpt ∨ j ≠ i) :
    rtr₂[c][j] = rtr₁[c][j] := by
  -- TODO: We need to somehow distinguish whether [c][j] even identifies a component, and if so,
  --       whether it lives in the same reactor as [cpt][i].
  induction u
  case final e _ _ =>
    have := e (c := c) (j := j) (by simp [h])
    sorry
  case nest =>
    sorry

theorem obj?_some₁ (u : LawfulMemUpdate cpt i f rtr₁ rtr₂) : ∃ o, rtr₁[cpt][i] = some o := by
  induction u
  case final         => exact ⟨_, cpt?_to_obj? ‹_›⟩
  case nest h _ _ hi => exact ⟨_, obj?_nested h hi.choose_spec⟩

theorem obj?_some₂ (u : LawfulMemUpdate cpt i f rtr₁ rtr₂) : ∃ o, rtr₂[cpt][i] = some o := by
  induction u
  case final       => exact ⟨_, cpt?_to_obj? ‹_›⟩
  case nest h _ hi => exact ⟨_, obj?_nested h hi.choose_spec⟩

theorem obj?_updated (u : LawfulMemUpdate cpt i f rtr₁ rtr₂) :
    rtr₂[cpt][i] = f <$> rtr₁[cpt][i] := by
  induction u
  case final h₁ h₂ =>
    rw [cpt?_to_obj? h₁, cpt?_to_obj? h₂, Option.map_some]
  case nest h₁ h₂ u hi =>
    have ⟨_, h₁'⟩ := u.obj?_some₁
    have ⟨_, h₂'⟩ := u.obj?_some₂
    rw [obj?_nested h₁ h₁', obj?_nested h₂ h₂']
    exact h₁' ▸ h₂' ▸ hi

end LawfulMemUpdate

namespace LawfulUpdate

variable [Indexable α] {rtr₁ : α}

theorem obj?_preserved (h : c ≠ cpt ∨ j ≠ i) :
    (LawfulUpdate cpt i f rtr₁ rtr₂) → rtr₂[c][j] = rtr₁[c][j]
  | update u   => u.obj?_preserved h
  | notMem _ h => h ▸ rfl

theorem obj?_updated : (LawfulUpdate cpt i f rtr₁ rtr₂) → rtr₂[cpt][i] = f <$> rtr₁[cpt][i]
  | update u => u.obj?_updated
  | notMem h e => by subst e; have h := member_isEmpty_obj?_none h; simp at h; simp [h]

end LawfulUpdate

namespace LawfulUpdatable

variable [Indexable α] {rtr : α}

theorem obj?_preserved (h : c ≠ cpt ∨ j ≠ i) : (update rtr cpt i f)[c][j] = rtr[c][j] :=
  lawful rtr cpt i f |>.obj?_preserved h

theorem obj?_preserved_cpt (h : c ≠ cpt := by exact (nomatch ·)) :
    (update rtr cpt i f)[c][j] = rtr[c][j] :=
  obj?_preserved $ .inl h

theorem obj?_preserved_id {c : Reactor.Component.Valued} (h : j ≠ i) :
    (update rtr cpt i f)[c][j] = rtr[c][j] :=
  obj?_preserved $ .inr h

theorem obj?_updated {rtr : α} : (update rtr cpt i f)[cpt][i] = f <$> rtr[cpt][i] :=
  lawful rtr cpt i f |>.obj?_updated

end LawfulUpdatable
end ReactorType


import group_theory.coset ring_theory.ideals algebra.gcd_domain algebra.euclidean_domain data.int.modeq group_theory.quotient_group data.equiv.algebra group_theory.subgroup tactic.ring tactic.fin_cases tactic.tidy algebra.ring algebra.field linear_algebra.multivariate_polynomial
open tactic prod native environment interactive lean.parser ideal classical lattice declaration rbtree
infixl ` ⬝ ` := has_mul.mul
notation x`²`:99 := x⬝x
notation ` ` binders ` ↦ ` f:(scoped f, f) := f
notation `⟮` binders ` ↦ ` f:(scoped f, f) `⟯`:= f

def flip_over_2{A B C D}(f: A→B→C→D) := z x y ↦ f x y z
infixl ` @₁`:99 := flip
infixl ` @₂`:99 := flip_over_2
infixr ` ∘₂ `:80 := (∘)∘(∘)

instance decidable_bool{b:bool}: decidable b := by{cases b, apply is_false, simp, apply is_true, simp}

instance{X}: monoid(list X) := {
	one := [],
	mul := (++),
	one_mul := by safe,
	mul_one := list.append_nil,
	mul_assoc := list.append_assoc,
}

instance endomonoid{t}: monoid(t → t) := {
	one := id,
	mul := (∘),
	mul_assoc := function.comp.assoc,
	one_mul := function.comp.left_id,
	mul_one := function.comp.right_id,
}

--option.cases_on has typing problems.
def option.maybe{A B}(no: B)(yes: A→B): option A → B
| none := no
| (some a) := yes a

def ifoldl_help{S T}(f: ℕ→S→T→T): ℕ → list S → T → T
| i [] r := r
| i (x::s) r := ifoldl_help (i+1) s (f i x r)
def list.ifoldl{S T}(f: ℕ→S→T→T) := ifoldl_help f 0

def list.imap{S T}(f: ℕ→S→T)(s: list S) := (s.ifoldl(list.cons ∘₂ f) []).reverse

universe U
def list.mfilter_map{A B : Type U}{M}[monad M](f: A → M(option B)): list A → M(list B)
| [] := pure[]
| (a::s) := do
	fa ← f a,
	s' ← s.mfilter_map,
	pure(fa.maybe s' ⟮b ↦ b::s'⟯)

@[simp] def map₂_default{X Z}(d)(f: X → X → Z): list X → list X → list Z
| [] [] := []
--| s l := f ((s.nth 0).get_or_else d) ((l.nth 0).get_or_else d) :: map₂_default s.tail l.tail
| [] (y::ys) := f d y :: map₂_default [] ys
| (x::xs) [] := f x d :: map₂_default xs []
| (x::xs) (y::ys) := f x y :: map₂_default xs ys

def trim_tail{X}[decidable_eq X](x)(s: list X) := (s.reverse.drop_while(=x)).reverse

--unique_pairs[xⱼ | j] = [(xᵢ,xⱼ) | i<j]
def list.unique_pairs{T}: list T → list(T×T)
| [] := []
| (x::xs) := xs.map⟮y↦ (x,y)⟯ ++ xs.unique_pairs

@[priority 0]instance to_string_of_repr{X}[has_repr X]: has_to_string X := ⟨repr⟩
@[priority 0]meta instance format_of_repr{X}[has_repr X]: has_to_tactic_format X := ⟨has_to_tactic_format.to_tactic_format ∘ repr⟩

/--
`nat.mk_numeral n` embeds `n` as a numeral expression inside a type with 0, 1, and +.
`type`: an expression representing the target type
`has_zero`, `has_one`, `has_add`: expressions of the type `has_zero %%type`, etc.
 -/
meta def nat.mk_numeral (type has_zero has_one has_add : expr) : ℕ → expr :=
let z : expr := `(@has_zero.zero.{0} %%type %%has_zero),
    o : expr := `(@has_one.one.{0} %%type %%has_one) in
nat.binary_rec z
  (λ b n e, if n = 0 then o else
    if b then `(@bit1.{0} %%type %%has_one %%has_add %%e)
    else `(@bit0.{0} %%type %%has_add %%e))

meta def int.mk_numeral (type has_zero has_one has_add has_neg : expr) : ℤ → expr
| (int.of_nat n) := n.mk_numeral type has_zero has_one has_add
| -[1+n] := let ne := (n+1).mk_numeral type has_zero has_one has_add in
            `(@has_neg.neg.{0} %%type %%has_neg %%ne)

meta def rat.mk_numeral (type has_zero has_one has_add has_neg has_div : expr) : ℚ → expr
| ⟨num, denom, _, _⟩ :=
  let nume := num.mk_numeral type has_zero has_one has_add has_neg in
  if denom = 1 then nume else
    let dene := denom.mk_numeral type has_zero has_one has_add in
    `(@has_div.div.{0} %%type %%has_div %%nume %%dene)

meta def rat.reflect : ℚ → expr :=
rat.mk_numeral `(ℚ) `((infer_instance : has_zero ℚ))
         `((infer_instance : has_one ℚ))`((infer_instance : has_add ℚ))
         `((infer_instance : has_neg ℚ)) `(infer_instance : has_div ℚ)

section
local attribute [semireducible] reflected
meta instance ℚ_has_reflect: has_reflect ℚ := rat.reflect
end

-- infixr ` ∷ `:67 := (++)∘repr
-- --set_option pp.all true
-- def replace_1_: list char → string
-- --| ('+'::' '::'-'::s) := "- "++ replace_minus s
-- | [] := ""
-- | (a::s) := match if a≠' ' then none else match s with
-- 	| [] := none
-- 	| (b::s) := if b≠'1' then none else match s with
-- 		| [] := none
-- 		| (c::s) := if c≠' ' then none else
-- 			have hint: s.sizeof < a.val+(1+s.sizeof), from by{simp[has_lt.lt,nat.lt], rw(_:nat.succ _=0+_), rw(_:1+_=nat.succ _), apply nat.add_le_add_right, tidy, rw nat.add_comm},
-- 			some(' '∷ replace_1_ s)
-- end end with
-- | none := a ∷ replace_1_ s
-- | some s := s

--–Monomials are now represented by lists, which are thought to be zero extended. Trailing zeros are normalized away.
def monomial := list ℕ
namespace monomial

def deg(m: monomial) := list.sum m

def variable_name: ℕ → string
| 0 := "x" | 1 := "y" | 2 := "z"
| n := (char.of_nat(121-n)).to_string

def rise_digit(n: char) := ("⁰¹²³⁴⁵⁶⁷⁸⁹".to_list.nth n.to_string.to_nat).get_or_else '?'
def rise_number(n: string) := (n.to_list.map rise_digit).as_string

instance monomial.has_repr: has_repr monomial := ⟨ m ↦ m.ifoldl⟮j e ↦ ite(e=0) id (++ variable_name j ++ ite(e=1) "" (rise_number(repr e)))⟯ "" ⟩
instance: has_one monomial := ⟨[]⟩
instance: has_mul monomial := ⟨map₂_default 0 (+)⟩ --no need to trim
instance: has_div monomial := ⟨trim_tail 0 ∘₂ map₂_default 0 ⟮x y ↦ x-y⟯⟩

def gcd(n m : monomial): monomial := trim_tail 0 (list.map₂ min n m) --no need to extend
def lcm(n m : monomial): monomial := map₂_default 0 max n m --no need to trim

def dvd': monomial → monomial → bool
| [] _ := tt
| (n::ns) m := n ≤ (m.nth 0).get_or_else 0 ∧ dvd' ns m.tail
def dvd := n m ↦ (dvd' n m : Prop)
instance: has_dvd monomial := ⟨dvd⟩
instance: decidable_rel dvd := by unfold dvd; apply_instance

--–Orders should be admissible (unit least and multiplication monotonous).
class order :=
(lt: monomial → monomial → Prop)
(decidable: decidable_rel lt)

def lex: order := {
	lt := list.lex(<),
	decidable := infer_instance,
}
def deg_lex: order := {
	lt := n m ↦ deg n < deg m ∨ (deg n = deg m ∧ list.lex(<) n m),
	decidable := _ _↦ by apply or.decidable,
}
end monomial

@[reducible] private def mo := monomial.order

--–Polynomials (this ended up essentially reimplementing very basics of rbmap equivalently, because I didn't find rbmap early enough)
--Reverse order to have the leading term first.
def poly.less[mo]{K}(x y : K×monomial) := monomial.order.lt y.snd x.snd
def poly[mo](K)[ring K] := rbtree (K×monomial) poly.less

namespace poly
--K ∈ Type 0 because otherwise combination with tactics gets problematic.
variables{K: Type}[ring K][decidable_eq K][o:mo](P R : poly K)

instance[mo]: has_lt monomial := ⟨monomial.order.lt⟩
instance[mo]: has_le monomial := ⟨ n m ↦ ¬n>m ⟩
instance decidable_lt[mo]: @decidable_rel monomial (<) := monomial.order.decidable
instance decidable_le[mo]: @decidable_rel monomial (≤) := by apply_instance
instance decidable_less: decidable_rel(@less o K) := _ _↦ by unfold less; apply_instance

def coef(m) := ((P.find(0,m)).get_or_else(0,m)).fst
--Value 0 should not be inserted, but rbtree lacks removal rutines. Since full simplification will rebuild a polynomial from scratch, extra zeros should not add up too badly.
def update(m)(f: K→K): poly K := let k := f(coef P m) in P.insert(k,m)

def monom[mo](m): poly K := rbtree_of[m]less
instance[mo]: has_coe monomial (poly K) := ⟨ m↦ monom(1,m) ⟩

--Let f' = (f; 0↦id). Then combine@₂f maps Σ pⱼ⬝mⱼ and Σ rⱼ⬝mⱼ to Σ f' pⱼ rⱼ ⬝ mⱼ (...assuming unsoundly that there's no explicit 0 coefficients...exact behavior depends on what the representation happens to be).
def combine(f: K→K→K): poly K := P.fold⟮p R' ↦ update R' p.snd (f p.fst)⟯ R
def map_poly(f: K→K): poly K := combine P P _↦f

instance[mo]: has_zero(poly K) := ⟨rbtree_of[]less⟩
instance[mo]: has_one(poly K) := ⟨monom(1,1)⟩
instance[mo]: has_add(poly K) := ⟨combine @₂(+)⟩
instance[mo]: has_neg(poly K) := ⟨map_poly @₁ k↦-k⟩
instance[mo]: has_sub(poly K) := ⟨ P R ↦ P + -R ⟩
instance[mo]: has_mul(poly K) := ⟨ P↦ fold⟮m↦ P.fold⟮n↦ (+monom(m⬝n))⟯⟯ @₁0 ⟩
instance[mo]: has_scalar K (poly K) := ⟨ k↦ map_poly @₁(⬝k) ⟩
instance[mo]: has_pow(poly K) ℕ := ⟨ P n ↦ (list.repeat P n).foldl(⬝)1 ⟩

instance[mo][has_repr K]: has_repr(poly K) := ⟨ P↦ match P.to_list.filter⟮p:K×_ ↦ p.fst ≠ 0⟯ with
	| [] := "0"
	| (m::ms) := ms.foldl⟮s p ↦ s ++" + "++ repr p.fst ++" "++ repr p.snd⟯ (repr m.fst ++" "++ repr m.snd)
end⟩

def lead_term := (P.fold⟮p:K×_ ↦ option.maybe (if p.fst = 0 then none else some p) some⟯ none).maybe (0,1) id
def lead_coef := P.lead_term.fst
def lead_mono := P.lead_term.snd

def is0 := lead_coef P = 0
instance decidable_is0: decidable P.is0 := by unfold is0; apply_instance

def is_const := lead_mono P = 1
instance decidable_is_const: decidable P.is_const := by unfold is_const; apply_instance

--This is ridiculous!
instance rbnode_eq{X}[eqX: decidable_eq X]: decidable_eq(rbnode X)
| rbnode.leaf rbnode.leaf := is_true rfl
| (rbnode.red_node l1 v1 r1) (rbnode.red_node l2 v2 r2) :=
	match eqX v1 v2 with
	| is_false v := is_false(by{by_contra a, injection a, contradiction})
	| is_true v :=
		match rbnode_eq l1 l2 with
		| is_false l := is_false(by{by_contra a, injection a, contradiction})
		| is_true l :=
			match rbnode_eq r1 r2 with
			| is_false r := is_false(by{by_contra a, injection a, contradiction})
			| is_true r := is_true(by rw[l,v,r])
			end
		end
	end
| (rbnode.black_node l1 v1 r1) (rbnode.black_node l2 v2 r2) :=
	match eqX v1 v2 with
	| is_false v := is_false(by{by_contra a, injection a, contradiction})
	| is_true v :=
		match rbnode_eq l1 l2 with
		| is_false l := is_false(by{by_contra a, injection a, contradiction})
		| is_true l :=
			match rbnode_eq r1 r2 with
			| is_false r := is_false(by{by_contra a, injection a, contradiction})
			| is_true r := is_true(by rw[l,v,r])
			end
		end
	end
| rbnode.leaf (rbnode.red_node l1 v1 r1) := is_false(by by_contra; injection a)
| rbnode.leaf (rbnode.black_node l1 v1 r1) := is_false(by by_contra; injection a)
| (rbnode.red_node l1 v1 r1) rbnode.leaf := is_false(by by_contra; injection a)
| (rbnode.red_node l1 v1 r1) (rbnode.black_node l2 v2 r2) := is_false(by by_contra; injection a)
| (rbnode.black_node l1 v1 r1) rbnode.leaf := is_false(by by_contra; injection a)
| (rbnode.black_node l1 v1 r1) (rbnode.red_node l2 v2 r2) := is_false(by by_contra; injection a)

instance[mo]: decidable_eq(poly K) := by apply_instance
instance[mo]: inhabited(poly K) := ⟨0⟩

variable [has_repr K]
def see{X Y}[has_repr X][has_repr Y](m:Y)(x:X) := _root_.trace (repr m ++ repr x) x

private def proof[mo](K)[ring K] := list(poly K)
def poly_mem[mo](K)[ring K] := poly K × proof K
def polys[mo](K)[ring K] := list(poly_mem K)

instance hrp[mo]: has_repr(proof K) := by unfold proof; apply_instance--TODO remove after debug

def poly_mem.is0[mo](P: poly_mem K) := is0 P.fst
instance[mo](P: poly_mem K): decidable P.is0 := by unfold poly_mem.is0; apply_instance
instance evvk[mo]: inhabited(poly_mem K) := ⟨(0,[])⟩

--Construct trivial proof by cloning a proof from non-empty list.
def proof_triv[mo](B: polys K. assumption): proof K := B.head.snd.map⟮_↦0⟯
def is_triv[mo]: proof K → bool
| [] := tt
| (p::ps) := is0 p ∧ is_triv ps
def proof_add[mo](p₁ p₂ : proof K)(f: poly K → poly K) := p₁.map₂(+) (p₂.map f)

--Compute the S-polynomial of monic polynomials with membership proof.
def monicS[mo]: poly_mem K → poly_mem K → poly_mem K | (P,pP) (R,pR) :=
	let p:= lead_mono P, r:= lead_mono R, m:= p.lcm r, mp:= monom((1:K), m/p), mr:= monom((1:K), m/r)
	in (P⬝mp - R⬝mr, proof_add (pP.map(⬝mp)) pR(⬝(-mr)))

--Accumulates proof to show that if P→R then R - P ∈ ⟨B⟩.
meta def simplify_leading_loop[mo](B: polys K): poly_mem K → poly_mem K |(P, proof) :=
	let p := P.lead_mono in match B.filter((∣p)∘lead_mono∘fst) with
		| [] := (P, proof)
		| (b,prf)::_ := let c := -monom(lead_coef P, p / lead_mono b) in simplify_leading_loop(P + b⬝c, proof_add proof prf(⬝c))
end
--B must be a non-empty list of monic (and ≠0) polynomials.
meta def simplify_leading[mo](B: polys K)(P: poly_mem K): poly_mem K :=
	match B.filter(is_const ∘ fst) with
	| (_,prf)::_ := (0, proof_add P.snd prf(⬝(-P.fst)))
	| _ := simplify_leading_loop B P
end

meta def simplify_loop[mo](B): poly K → poly_mem K → poly_mem K | R P :=
	if P.is0 then (R, P.snd) else let (P,prf) := simplify_leading B P, p := monom P.lead_term in simplify_loop (R+p) (P-p, prf)
--Return fully simplified R←P and proof that R - P ∈ ⟨B⟩. Input P comes without membership proof, because simplification should be applicable to arbitrary polynomials.
meta def simplify[mo](B: polys K)(P) := simplify_loop B 0 (P, proof_triv)

variable[field K]
--scale_monic 0 := 0
def scale_monic[mo]: poly_mem K → poly_mem K | (P,prf) := let c := P.lead_coef ⁻¹ in (c•P, prf.map((•)c))

meta def simplify_basis_loop[mo](simp: polys K → poly_mem K → poly_mem K): ℕ → polys K → polys K
| 0 B := B
| l [] := sorry -- l ≤ B.length
| l (P::B) := let
	P' := simp B P,
	B' := ite P'.is0 B (B++[scale_monic P'])
in simplify_basis_loop(if is_triv(P.snd.map₂⟮x y ↦ x-y⟯ P'.snd) then l-1 else B'.length) B'

--For each element of B, if S simplifies the leading term, then simplify additionally with other elements of the basis.
meta def simplify_basis_by[mo](S: poly_mem K)(B: polys K) := simplify_basis_loop⟮B P ↦ let P' := simplify_leading [S] P in if is_triv P'.snd then P else simplify_leading B P'⟯ B.length B

--Interreduce B.
meta def simplify_basis[mo](B: polys K) := simplify_basis_loop(simplify_loop @₁0) B.length B

--main loop
private meta def go[mo]: polys K → list(poly_mem K × poly_mem K) → polys K
| G [] := G
| G ((p₁,p₂)::ps) := let S := scale_monic(simplify_leading G (monicS p₁ p₂))
	in if S.is0 then go G ps else let G := simplify_basis_by S G in go (S::G) (ps ++ G.map⟮P↦ (P,S)⟯)

meta def «Gröbner basis of»[mo](B: list(poly K)) := let B := B.filter(not∘is0), B1 := B.imap⟮i b ↦ scale_monic(b, (B.map⟮_↦(0: poly K)⟯).update_nth i 1)⟯ in simplify_basis(go B1 B1.unique_pairs)
notation `Gröbner_basis_of` := «Gröbner basis of»
--Lean's letter recognition is broken! It is not just an implementation mistake, but it is even specified in an adhoc way – see https://leanprover.github.io/reference/lexical_structure.html#identifiers – which is incompatible with Unicode. Not only a huge number of letters is ignored but also some non-letters included (though correctly called just letterlike):
def ℡⅋℀ := "Telephone sign ǝʇ “account” are letters only in Lean!"
--Inclusion of non-letters means that Lean can't be said to support a subset of Unicode. FYI: Unicode is about semantics of code points (numbers). UTF-8 is a character encoding (mapping between bytes and numbers) that Lean does use. Observations here hold at the time of writing and hopefully not in the future.

--Tästä voisi johtaa tyyliin ringa-taktiikan. Sievennetään kaikkia ... hmm, miten sievennyskelpoiset lausekkeet määrätään? Kertoimien tulee olla kunnasta, mutta muuttujia saa käsitellä vain rengasoperaatioilla. Teoreettisesti nättiä olisi yleistää hieman ja ratkaista renkaiden ehdolliset sanaongelmat, mutta sehän edellyttäisi paljon lisää koodausta!
--Sitten pitää ratkaista, miten termien triviaali sievennys kuten x+y-x=y hoidetaan. Koska tulos tiedetään aina, voidaan turvallisesti turvautua ring-taktiikkaan.
--Luetaan tavoitetta kunnes vastaan tulee +,⬝,- (tärkeää on, että löydetään maksimaalinen termi sievennettäväksi—tämän pitäisi riittää siihen, koska tietenkään päälioperaatio ei tällöin voi olla jokin sellainen, jota ei osata käsitellä). Huom. - voi esiintyä sekä unaarisena että binäärisenä. Seuraavaksi tarkistetaan, että alitermi on kuntatyyppiä...mutta tämä rajoittaa käytettävyyttä melko merkittävästi. Teoriassa voisi vaatia, että tyyppi on vaihdannainen rengas ja K-moduli jonkin kunnan K suhteen, ja K:lta vaaditaan lisäksi päätettävä yhtyvyys. Jotta tästä teoriasta tulee käytäntöä, lienee vaadittava, että käyttäjä syöttää kunnan (ℚ voi olla oletusarvo).

meta def 𝔼(pre) := to_expr pre tt ff
--meta def childs(e: expr) := (e.mfoldl⟮c s ↦ [list.cons s c]⟯ []).head
meta def childs: expr → list expr
| (expr.app f p) := [f,p]
| (expr.pi _ _ S T) := [S,T]
| (expr.elet _ t v b) := [t,v,b] --Does this work with infer_type?
| (expr.macro _ cs) := cs
| _ := []

notation `~`x := pure x
notation `ᵘᵖ ` m := monad_lift m

@[reducible] meta def ST := state_t (list expr) tactic
--Run reaction if state is not [].
meta def if_not_found(reaction: ST unit): ST unit := do s ← state_t.get, when(s=[]) reaction

meta def fbs_loop{T}(t)(test: (expr → ST T) → expr → ST T)(atoms: rb_set expr): bool → expr → ST unit | layer's_top e :=
when(¬ atoms.contains e) (test⟮x ↦ t<$
	if x≠e then fbs_loop ff x
	else (childs x).mmap'(if_not_found ∘ fbs_loop tt)
⟯ e >> if_not_found(when layer's_top (test⟮e' ↦ when(e≠e') (state_t.put[e]) $>t⟯ e $>())))
--Finds some minimal subterm accepted by test while treating terms in the set atoms as such. Parameter t is just an inhabitance proof.
meta def find_bottom_simplifiable{T}(t:T)(test)(atoms): expr → tactic(option expr)
| e := prod.fst <$> (do
	fbs_loop t test atoms tt e,
	g ← state_t.get,
	~ g.nth 0
).run[]

meta def prepare_loop{T}(var: ℕ→T)(test: (expr → ST T) → expr → ST T): expr → ST T | e :=
test⟮x ↦ if x≠e then prepare_loop x else do
	vs ← state_t.get,
	let i := vs.index_of x,
	when(i = vs.length) (state_t.put(vs++[x])) $> var i
⟯e
--Transform (top layer of) e to its T-representation according to test, with alien subterms replaced by variables generated from var with syntactic equality preserved. Second component of the return value is list of the replaced alien terms.
meta def prepare{T}(var: ℕ→T)(test)(e) := (prepare_loop var test e).run[]
--Like mapping the above, but naming of the alien terms is consistent.
meta def prepares{T}(var: ℕ → T)(test)(es: list expr) := (es.mmap(prepare_loop var test)).run[]

meta def simplify_by_loop{T}(var: ℕ→T)(test: (expr → ST T) → expr → ST T)(simp: expr → T → tactic expr): rb_set expr → tactic unit | simplified := do
	e ← target,
	x ← find_bottom_simplifiable (var 0) test simplified e,
	x.maybe(~())⟮x ↦ do
		(x',g) ← prepare var test x,
		proof ← simp x x',
		rewrite_target proof,
		`(%%_ = %%s) ← infer_type proof,
		simplify_by_loop(simplified.insert s)⟯

--Warning: in practise this interface turned out to behave ugly! This is a simplifier skeleton whose advantage over simp is that pattern matching and rule selection can be done programmatically. (For example simp could often do nothing with a Gröbner basis represented as simplifying equations, because non-syntactic pattern matching is needed to use them.) This functions like simp only [...]. The actual (single step) simplifier is given as a parameter. Its operation is extended by searching the proof target for simplifiable terms and calling the simplifier for all of these bottom up.
--Parameters
--T: an auxiliarity term representation that the simplifier may choose as it likes.
--var: a stream of distinct variables.
--test recursor ∈ expr → a_monad T : transforms a top operation of an input term into T-representation calling recursor for the childs, or for the whole term if it is alien. See test_poly for an example.
--simp: from original expression E and its T-representation produce a proof that E = simplified E. Failed: Variable var i should be represented by a metavariable whose name ends with mk_numeral i, (or var 0, ..., var n may be represented by quantifying ∀x₀...∀xₙ ???).
meta def simplify_by{T}(var: ℕ→T)(test)(simp) := simplify_by_loop var test simp mk_rb_set
--Notes: Examining term structure and mapping it to T was combined into test. Original term is given to simp, because T-representation may be lossy. However if orig. rep. is needed (Gröbner bases avoid it by using ring), examination of it usually repeats. It even turned out that due to consistent alien term naming the second parameter of simp is practically useless. Currently test can work in ST, though safer would be to require polymorphicity over monad transformer on top of tactic. The tedious part (in addition to the core simplification in T) is producing the proof term in simp. Could this be simplified in a suitable monad?

meta def test_instance(i) := (𝔼 i >>= mk_instance) $> tt <|> ~ff

meta def test_poly[mo][reflected K](r: expr → ST(poly K))(e: expr): ST(poly K) := match e with
| `(%%x ⬝ %%y) := (⬝) <$> r x <*> r y
| `(%%x + %%y) := (+) <$> r x <*> r y
| `(%%x - %%y) := ⟮x y ↦ x-y⟯ <$> r x <*> r y
| `(- %%x) := ⟮x ↦ -x⟯ <$> r x
| `(%%x ^ %%n) := do
	N ←ᵘᵖ infer_type n,
	if N ≠ `(ℕ) ∨ n.has_var ∨ n.has_local then r e
	else do n ←ᵘᵖ eval_expr ℕ n, (^n) <$> r x
| e := do
	E ←ᵘᵖ infer_type e,
	if E ≠ reflect K ∨ e.has_var ∨ e.has_local then r e
	else do k ←ᵘᵖ eval_expr K e, ~monom(k,[])
end

meta def test_poly_typed[mo][reflected K](M: option expr)(r: expr → ST(poly K))(e): ST(poly K) := do
	E ←ᵘᵖ infer_type e,
	ok ← match M with some M := ~(E=M : bool)
		| _ :=ᵘᵖ band <$> test_instance``(ring %%E) <*> test_instance``(module %%(reflect K) %%E) end,
	(ite ok test_poly id) r e

--X' i is the iᵗʰ variable "Xᵢ".
def X'[mo](i:ℕ): poly K := monom(1, ((list.cons 0)^i) [1])

meta def represent_mono[mo](r: has_reflect K)(M:expr)(vs: list expr)(m: monomial): tactic expr :=
	m.ifoldl ⟮x p e ↦ if p=0 then e else do e←e, 𝔼``(%%e ⬝ %%(vs.nth x).iget ^ %%(reflect p))⟯ (𝔼``(1:%%M))

meta def represent_poly[mo][r: has_reflect K](M:expr)(vs: list expr)(P: poly K): tactic expr :=
	P.fold ⟮m e ↦ let c:= m.fst in if c=0 then e else do e←e, mono ← represent_mono r M vs m.snd, 𝔼``(%%e + %%(reflect c)⬝%%mono)⟯ (𝔼``(0:%%M))
--TODO Use module product • to multiply mono by c. Problem is that then ring doesn't work!

meta def local_equations_of_type(M) := do
	ls ← local_context,
	ls.mfilter⟮a ↦ do b ← infer_type a, match b with `(%%x = %%y) := do Y ← infer_type y, ~Y=M | _:=~ff end⟯

--Return a proof of goal found by the given tactic solve.
meta def prove_by(solve: tactic unit)(goal: tactic expr) := do
	n ← get_unused_name,
	goal >>= assert n,
	solve,
	proof ← get_local n,
	--clear proof, --TODO How to clean the local context while keeping proof usable?
	~proof

namespace proof_building_blocks
lemma mul_sub_is_0{M}[ring M][module K M]{x y O : M}(c: M)(o0: O=0)(h: x=y): O - c⬝(x-y) = 0 := by simp[*]

lemma combines{M}[add_comm_group M][module K M]{P R O : M}(pr: P-R = O)(o0: O = 0): P = R := by rw(by simp : P = P-R + R);simp[*]

end proof_building_blocks
open proof_building_blocks

--Compute a Gröbner basis from polynomial equations E and return a reducer suitable for simplify_by that uses the computed basis.
meta def verifying_reducer[mo][reflected K][r: has_reflect K](M)(E: list expr): tactic(expr → poly K → tactic expr) := do
	let test: (expr → ST(poly K)) → _ := test_poly_typed(option.some M),
	be ← E.mmap⟮p ↦ do e ← infer_type p, match e with `(%%x = %%y) := 𝔼``(%%x - %%y) | _:=sorry end⟯,
	((B: list(poly K)), vs) ← prepares X' test be,
	let G := Gröbner_basis_of B,
~ pe _ ↦ do
	--TODO There should be nicer way to keep track of alien subterms. Either variables in polynomials should have arbitrary names (ideal solution) or everything should work inside ST.
	(P, vs) ← (prepare_loop X' test pe).run vs,
	let (R, coef) := simplify G P,
	--R = P + coef•(fⱼ - gⱼ)ⱼ
	--P - R  =ʳⁱⁿᵍ=  -coef•(fⱼ - gⱼ)ⱼ  = “coef•0” = 0  ⟹ P=R
	re ← represent_poly M vs R,
	ce ← coef.mmap(represent_poly M vs),
	K0is0 ← 𝔼``(rfl : (0:%%(reflect K)) = 0),
	step2 ← (ce.zip E).mfoldl ⟮prf cb ↦ 𝔼``(@mul_sub_is_0
		%%(reflect K) infer_instance infer_instance infer_instance infer_instance
		%%M infer_instance infer_instance
		_ _ _ %%cb.fst %%prf %%cb.snd)⟯ K0is0,
	`(%%ce_be = %%_) ← infer_type step2,
	ring_step ← prove_by`[{ring}] (𝔼``(%%pe - %%re = %%ce_be)),
	𝔼``(@combines
		%%(reflect K) infer_instance infer_instance infer_instance infer_instance
		%%M infer_instance infer_instance
		_ _ _ %%ring_step %%step2)

meta def exactℚ := `[exact ℚ]

meta def ringa(K:Type. exactℚ)[reflected K][has_reflect K][field K][decidable_eq K][has_repr K/-debug-/][mo]: tactic unit := do
	t ← target,
	--"find_top_simplifiable" would be more expected behavior...if it existed
	e ← find_bottom_simplifiable (0: poly K) (test_poly_typed none) mk_rb_set t,
	if e=none then fail"nothing to simplify in target" else do
	M ← infer_type e.iget,
	B ← local_equations_of_type M,
	if B=[] then `[ring] else do --Do not fail to preserve composability.
	reducer ← verifying_reducer M B,
	simplify_by (X': ℕ → poly K) (test_poly_typed(some M)) reducer,
	`[try{ring}]

#check Gröbner_basis_of
--Test cases
instance use_this_order := monomial.deg_lex
variables{v x y z : ℚ}{f: ℚ→ℚ}

--These delegate to ring tactic
example: (x+y)⬝(x-y) = x² - y² := by ringa
example: f(2⬝x) = f(x+x) := by ringa
--These don't
example(_:v=z): (x+y)⬝(x-y) = x² - y² := by ringa
example(_:v=z): f(2⬝x) = f(x+x) := by ringa

--Core functionality tests
example(_: x+y = z)(_: x² + y² = z²): x⬝y = 0 := by ringa
example(_: x⬝y² = x+y)(_: x²⬝y = x² + y²): y^5 = (2⬝x-1)⬝(2⬝y-1)/2 - 1/2 := by ringa
example(_: x⬝y² = x+y)(_: x²⬝y = x+1): y = x² := by ringa
example(_: z⬝x=y)(_: y=x²)(_: v²=2): x⬝(2⬝z-x-x) = 0 := by ringa
example(_: x²⬝y = x²)(_: x⬝y² = y²): (x+y)⬝(x-y) + x² = x^3 := by ringa

--Iteration tests
example(_: x=y): x⬝f(2⬝x² - y²) - y⬝f(x⬝y) = 0 := by ringa
example(_: x=y): x⬝f(x-y) - y⬝f(x-x) = 0 := by ringa
example(_: x=y+1): (x-1)⬝f(2⬝x-1) - y⬝f(x² - y²) = 0 := by ringa
example(_: x²+y² = z²)(_: x^3 + y^3 = z^3)(_: x⬝y = 1): f(x + y + f(2/3)) = f(f(z²) - 2⬝z) := by ringa

--In algebras over ℚ
open polynomial
example{P: polynomial ℚ}(_: X² - X - 1 = (0: polynomial ℚ))(_: P = 1-X): P² = P+1 := by ringa

--Is it worth to handle the situation of inconsistent axioms?
example(_: x²+3⬝x+1 = 0)(_: y²+3⬝y+1 = 0)(_: x^5 + y^5 = 0): x-y = 1 := by ringa
#check ringa
--∛2̅+̅√̅5̅ + ∛2̅-̅√̅5̅ = 1
--example(_: x²=5)(_: y^3 = 2+x)(_: z^3 = 2-x): y+z = 1 := by ringa

end poly
open poly

instance{K:Type}[field K][decidable_eq K][has_repr K][mo]: has_repr(poly_mem K) :=
--by unfold poly_mem; apply_instance
⟨ x ↦ repr x.fst ⟩
instance{K:Type}[field K][decidable_eq K][has_repr K][mo]: has_repr(polys K) := by unfold polys; apply_instance

instance use_this := monomial.deg_lex
def lm(m: list ℕ): poly ℚ := monom(1,m)

def a := lm[2] +3⬝lm[1]+lm[]
def b := lm[0,2] +3⬝lm[0,1]+lm[]
def c := lm[5] + lm[0,5]
#eval simplify(Gröbner_basis_of[a,b]) c
--#eval Gröbner_basis_of[a,b,c] --Time out just because the algorithm is so slow!

def α := lm[0,0,2] + lm[0,2] - lm[2]
def β := lm[0,0,3] + lm[0,3] - lm[3]
def γ := lm[0,1,1] - 1
#eval (Gröbner_basis_of[α,β,γ])
#eval simplify(Gröbner_basis_of[α,β,γ]) (lm[2])

def P := lm[2,1] + ((1:ℚ)/2)•lm[2]
def R := lm[1,2] + lm[0,2]
def S := -lm[2,2] + lm[1,1] + lm[2]
#eval (Gröbner_basis_of[P,R])
#eval simplify (Gröbner_basis_of[P,R]) (S²)

def B := [lm [3] -1, lm[2]+lm[1,1], lm[2]+lm[1,0,1]+lm[0,0,2]]
#eval B
#eval Gröbner_basis_of B
#eval P²⬝R
#eval Gröbner_basis_of$ [lm [3] -1, lm[2]+lm[1,1], lm[2]+lm[1,0,1]+lm[0,0,2], lm [0,3] -1, lm[0,2]+lm[0,1,1]+lm[0,0,2], lm [0,0,3] -1].map(⬝1)
#eval Gröbner_basis_of[lm [3] -1, lm[2]+lm[1,1]+lm[0,2], lm[2]+lm[1,0,1]+lm[0,0,2], lm [0,3] -1, lm[0,2]+lm[0,1,1]+lm[0,0,2], lm [0,0,3] -1]
#eval Gröbner_basis_of(B++[P²⬝R])
--#eval Gröbner_basis_of(P²⬝R::B)

#eval (lm[] + 0).lead_coef
#eval (2⬝lm[4,2] + lm[3,4])².fold((++)∘repr) ""
#eval (2⬝lm[4,2] + lm[3,4])².lead_mono
#eval (P + 3⬝P² + P²)²