import data.cpi.transition.basic

namespace cpi
namespace transition

variables {ℍ : Type} {ω : context}
open_locale congruence

open species.equiv

private def no_rename_zero {Γ} {n} {p : upair (fin n)} {q : upair (name Γ)}
  : upair.map name.extend q ≠ upair.map name.zero p
  := upair.rec_on q

    (λ a b eql, begin
      rcases upair.exists_rep p with ⟨ a', b', ⟨ _ ⟩ ⟩,
      rcases quotient.exact eql with ⟨ l, _ ⟩ | ⟨ l, _ ⟩; cases l
    end)
    (λ a b, function.hfunext (by rw upair.mk.comm) (λ a₂ b₂ _, heq.rfl))

private def on_parallel_assoc₁_left {Γ ℓ} {A B C : species ℍ ω Γ} :
  ∀ {α : label ℍ Γ kind.species} {E : species ℍ ω Γ}
  , (A |ₛ B) [ℓ, α]⟶ (production.species E)
  → Σ' E' (eq : production.species (E |ₛ C) ≈ E')
    , (A |ₛ B |ₛ C) [ℓ, α]⟶ E'
| α E (@com₁ _ _ _ _ x y _ _ a b F G _ _ rfl rfl tf tg) :=
  ⟨ _, production.equiv.species (symm (concretion.pseudo_apply.on_parallel₁ _ _ C)),
   com₁ rfl rfl tf (parL_concretion C tg) ⟩
| α E (parL_species C t) :=
  ⟨ _, production.equiv.species parallel_assoc₁, parL_species _ t ⟩
| α E (parR_species _ t) :=
  ⟨ _, production.equiv.species equiv.parallel_assoc₁, parR_species _ (parL_species _ t) ⟩

private def on_parallel_assoc₁ {Γ ℓ} {A B C : species ℍ ω Γ} :
  ∀ {k} {α : label ℍ Γ k} {E : production ℍ ω Γ k}
  , ((A |ₛ B) |ₛ C) [ℓ, α]⟶ E
  → Σ' E' (eq : E ≈ E'), (A |ₛ B |ₛ C) [ℓ, α]⟶ E'
| k α E (@com₁ _ _ _ _ x y _ _ a b _ G _ _ rfl rfl (parL_concretion D tf) tg) :=
  ⟨ _, production.equiv.species (concretion.pseudo_apply.parallel_shift _ B G),
   com₁ rfl rfl tf (parR_concretion _ tg) ⟩
| k α E (@com₁ _ _ _ _ x y _ _ a b _ G _ _ rfl rfl (parR_concretion D tf) tg) :=
  ⟨ _, production.equiv.species (concretion.pseudo_apply.on_parallel₂' A _ G),
   parR_species A (com₁ rfl rfl tf tg) ⟩
| k α E (parL_species _ t) := on_parallel_assoc₁_left t
| k α E (parL_concretion B (parL_concretion C t)) :=
  ⟨ _, production.equiv.concretion concretion.equiv.parallel_assoc₁, parL_concretion _ t ⟩
| k α E (parL_concretion C (parR_concretion D t)) :=
  ⟨ _, production.equiv.concretion concretion.equiv.parallel_assoc₂, parR_concretion _ (parL_concretion _ t) ⟩
| k α E (parR_species D t) :=
  ⟨ _, production.equiv.species equiv.parallel_assoc₁, parR_species A (parR_species B t) ⟩
| k α E (parR_concretion D t) :=
  ⟨ _, production.equiv.concretion concretion.equiv.parallel_assoc₃, parR_concretion A (parR_concretion B t) ⟩

private def on_parallel_symm {Γ ℓ} {A B : species ℍ ω Γ} :
  ∀ {k} {α : label ℍ Γ k} {E : production ℍ ω Γ k}
  , (A |ₛ B) [ℓ, α]⟶ E
  → Σ' E' (eq : E ≈ E'), (B |ₛ A) [ℓ, α]⟶ E'
| ._ ._ ._ (@com₁ _ _ _ _ x y _ _ a b F G _ _ rfl rfl tf tg) := begin
    rw upair.eq a b,
    from ⟨ _, production.equiv.species (concretion.pseudo_apply.symm F G), com₁ rfl rfl tg tf ⟩
  end
| k α ._ (parL_species _ t) := ⟨ _, production.equiv.species parallel_symm, parR_species B t ⟩
| k α ._ (parL_concretion _ t) := ⟨ _, production.equiv.concretion concretion.equiv.parallel_symm, parR_concretion B t ⟩
| k α ._ (parR_species _ t) := ⟨ _, production.equiv.species parallel_symm, parL_species A t ⟩
| k α ._ (parR_concretion _ t) := ⟨ _, production.equiv.concretion (symm concretion.equiv.parallel_symm), parL_concretion A t ⟩

private def on_parallel_assoc₂_species {Γ ℓ} {A B C : species ℍ ω Γ} :
  ∀ {α : label ℍ Γ kind.species} {E : species ℍ ω Γ}
  , (B |ₛ C) [ℓ, α]⟶ (production.species E)
  → Σ' (E' : production ℍ ω Γ kind.species) (eq : production.species (A |ₛ E) ≈ E')
    , ((A |ₛ B) |ₛ C) [ℓ, α]⟶ E'
| α E (parL_species _ t) :=
  ⟨ _, production.equiv.species equiv.parallel_assoc₂, parL_species _ (parR_species _ t) ⟩
| α E (parR_species _ t) :=
  ⟨ _, production.equiv.species equiv.parallel_assoc₂, parR_species _ t ⟩
| α E (com₁ rfl rfl tf tg) :=
  ⟨ _, production.equiv.species (concretion.pseudo_apply.on_parallel₂' A _ _).symm,
   com₁ rfl rfl (parR_concretion _ tf) tg ⟩

private def on_parallel_assoc₂_concretion {Γ ℓ} {A B C : species ℍ ω Γ} {b y} :
  ∀ {α : label ℍ Γ kind.concretion} {E : concretion ℍ ω Γ b y}
  , (B |ₛ C) [ℓ, α]⟶ (production.concretion E)
  → Σ' (E' : production ℍ ω Γ kind.concretion) (eq : production.concretion (A |₂ E) ≈ E')
    , ((A |ₛ B) |ₛ C) [ℓ, α]⟶ E'
| α E (parL_concretion _ t) :=
  ⟨ _, production.equiv.concretion concretion.equiv.parallel_assoc₂.symm
   , parL_concretion _ (parR_concretion _ t) ⟩
| α E (parR_concretion _ t) :=
  ⟨ _, production.equiv.concretion concretion.equiv.parallel_assoc₃.symm, parR_concretion _ t ⟩

private def on_parallel_assoc₂ {Γ ℓ} {A B C : species ℍ ω Γ} :
  ∀ {k} {α : label ℍ Γ k} {E : production ℍ ω Γ k}
  , (A |ₛ B |ₛ C) [ℓ, α]⟶ E
  → Σ' E' (eq : E ≈ E'), ((A |ₛ B) |ₛ C) [ℓ, α]⟶ E'
| ._ α E (@com₁ _ _ _ _ x y _ _ a b F G _ _ rfl rfl tf (parL_concretion _ tg)) :=
  ⟨ _, production.equiv.species (concretion.pseudo_apply.on_parallel₁ F _ C),
   parL_species _ (com₁ rfl rfl tf tg) ⟩
| ._ α E (@com₁ _ _ _ _ x y _ _ a b F G _ _ rfl rfl tf (parR_concretion _ tg)) :=
  ⟨ _, production.equiv.species (concretion.pseudo_apply.parallel_shift F B _).symm,
    com₁ rfl rfl (parL_concretion _ tf) tg ⟩
| k α ._ (parL_species _ t) :=
  ⟨ _, production.equiv.species equiv.parallel_assoc₂, parL_species _ (parL_species _ t) ⟩
| k α ._ (parL_concretion _ t) :=
  ⟨ _, production.equiv.concretion concretion.equiv.parallel_assoc₁.symm, parL_concretion _ (parL_concretion _ t) ⟩
| k α ._ (parR_species _ t) := on_parallel_assoc₂_species t
| k α ._ (parR_concretion _ t) := on_parallel_assoc₂_concretion t

private def on_choice_swap {Γ ℓ} {As : choices ℍ ω Γ} :
  ∀ {k f g} {α : label ℍ Γ k}
    {π₁ : prefix_expr ℍ Γ f} {π₂ : prefix_expr ℍ Γ g}
    {A : species ℍ ω (f.apply Γ)} {B : species ℍ ω (g.apply Γ)}
    {E : production ℍ ω Γ k}
  , (Σ# whole.cons π₁ A (whole.cons π₂ B As)) [ℓ, α]⟶ E
  → Σ' E' (eq : E ≈ E')
    , (Σ# whole.cons π₂ B (whole.cons π₁ A As)) [ℓ, α]⟶ E'
| ._ α f g π₁ π₂ A B E (choice₁ a b b_len y _ _) := ⟨ _, refl _, ξ_choice (choice₁ a b b_len y _ _) ⟩
| ._ α f g π₁ π₂ A B E (choice₂ k _ _) := ⟨ _, refl _, ξ_choice (choice₂ k _ _) ⟩
| ._ α f g π₁ π₂ A B E (ξ_choice (choice₁ a b b_len y _ _)) := ⟨ _, refl _, choice₁ a b b_len y _ _ ⟩
| ._ α f g π₁ π₂ A B E (ξ_choice (choice₂ k _ _)) := ⟨ _, refl _, choice₂ k _ _ ⟩
| k α f g π₁ π₂ A B E (ξ_choice (ξ_choice t)) := ⟨ _, refl _, ξ_choice (ξ_choice t) ⟩

private def on_ν_parallel₂ {Γ ℓ} {M : affinity ℍ} {A : species ℍ ω Γ} {B : species ℍ ω (context.extend (M.arity) Γ)} :
  ∀ {k} {α : label ℍ Γ k} {E : production ℍ ω Γ k}
  , (A |ₛ ν(M) B) [ℓ, α]⟶ E
  → Σ' E' (eq : E ≈ E'), (ν(M) rename name.extend A |ₛ B) [ℓ, α]⟶ E'
| ._ ._ _ (com₁ rfl rfl tf (ν₁_concretion M rfl tg)) :=
  -- Slighty bizzare, but the separate binding helps this to TC
  let tf' := transition.rename (@name.extend _ M.arity) tf in
  ⟨ _, production.equiv.species (concretion.pseudo_apply.on_restriction _ _ _),
    ν₁_species M rfl (com₁ rfl rfl tf' tg) ⟩
| k α _ (parL_species E t) :=
  let t' := transition.rename (@name.extend _ M.arity) t in
  ⟨ _, production.equiv.species (ν_parallel₂ M), ν₁_species M rfl (parL_species _ t' ) ⟩
| k α _ (parL_concretion E t) :=
  let t' := transition.rename (@name.extend _ M.arity) t in
  ⟨ _, production.equiv.concretion (concretion.equiv.ν_parallel₂ M).symm,
   ν₁_concretion M rfl (parL_concretion _ t' ) ⟩

| k α _ (parR_species A (com₂ M k' ek rfl t)) :=
  ⟨ _, production.equiv.species (ν_parallel₂ M), com₂ M k' ek rfl (parR_species _ t) ⟩
| k α _ (parR_species A (ν₁_species _ rfl t)) :=
  ⟨ _, production.equiv.species (ν_parallel₂ M), ν₁_species M rfl (parR_species _ t) ⟩
| k α _ (parR_concretion A (ν₁_concretion _ rfl t)) :=
  ⟨ _, production.equiv.concretion (concretion.equiv.ν_parallel₁ M).symm,
    ν₁_concretion M rfl (parR_concretion _ t) ⟩

private def upair_extend {n} {Γ} :
  ∀ {p : upair (name Γ)} {a b : name (context.extend n Γ)}
  , upair.map name.extend p = upair.mk a b
  → Σ' (a' b' : name Γ), p = upair.mk a' b' ∧ a = name.extend a' ∧ b = name.extend b'
| p (name.zero _) (name.zero _) e := false.elim (begin
  rcases quot.exists_rep p with ⟨ ⟨ a, b ⟩, ep ⟩, have : upair.mk a b = p := ep, subst this,
  rcases quotient.exact e with ⟨ l, r ⟩ | ⟨ l, r ⟩; contradiction,
end)
| p (name.zero _) (name.extend _) e := false.elim (begin
  rcases quot.exists_rep p with ⟨ ⟨ a, b ⟩, ep ⟩, have : upair.mk a b = p := ep, subst this,
  rcases quotient.exact e with ⟨ l, r ⟩ | ⟨ l, r ⟩; contradiction,
end)
| p (name.extend _) (name.zero _) e := false.elim (begin
  rcases quot.exists_rep p with ⟨ ⟨ a, b ⟩, ep ⟩, have : upair.mk a b = p := ep, subst this,
  rcases quotient.exact e with ⟨ l, r ⟩ | ⟨ l, r ⟩; contradiction,
end)
| p (name.extend a) (name.extend b) e := ⟨ a, b, begin
  have : upair.map name.extend p = upair.map name.extend (upair.mk a b) := e,
  from ⟨ upair.map.inj (@name.extend.inj _ _) this, rfl, rfl ⟩,
end ⟩

private noncomputable def on_ν_parallel₁_species {Γ ℓ} {M : affinity ℍ} {A : species ℍ ω Γ}
  {B : species ℍ ω (context.extend M.arity Γ)} :
  ∀ {A' : species ℍ ω (context.extend (M.arity) Γ)}
    {α' : label ℍ (context.extend M.arity Γ) kind.species}
    {α : label ℍ Γ kind.species}
    {E : species ℍ ω (context.extend M.arity Γ)}
  , (A' |ₛ B) [lookup.rename name.extend ℓ, α']⟶ (production.species E)
  → A' = rename name.extend A → α' = label.rename name.extend α
  → Σ' E' (eq : production.species (ν(M)E) ≈ E')
    , (A |ₛ ν(M) B) [ℓ, α]⟶ E'
| A' α' α E (parL_species _ t) eqA eqα := begin
  subst eqA, subst eqα,
  rcases transition.rename_from name.extend t with ⟨ α₂, ⟨ B ⟩, t₂, eα, eB ⟩,
  cases label.rename.inj (@name.extend.inj _ _) eα,
  rw ← production.species.inj eB,
  from ⟨ _, production.equiv.species (ν_parallel₁ M), parL_species _ t₂ ⟩,
end
| A' α' α E (parR_species _ t) eqA eqα := begin
  subst eqA, subst eqα,
  from ⟨ _, production.equiv.species (ν_parallel₁ M), parR_species _ (ν₁_species M rfl t) ⟩,
end
| A' α' α E (@com₁ _ _ _ _ x y _ _ a b F G _ _ rfl eα tf tg) eqA eqα := begin
  subst eqA, subst eqα,

  cases α with _ _ _ _ _ p,
  case label.spontaneous { cases eα },

  rcases upair_extend (label.of_affinity.inj eα) with ⟨ a, b, ⟨ _ ⟩, ⟨ _ ⟩, ⟨ _ ⟩ ⟩,
  rcases transition.rename_from name.extend tf with ⟨ ⟨ a₂ ⟩, ⟨ F ⟩, tf₂, ⟨ _ ⟩, ⟨ _ ⟩ ⟩,

  from ⟨ _, production.equiv.species (concretion.pseudo_apply.on_restriction _ M _).symm,
    com₁ rfl rfl tf₂ (ν₁_concretion M rfl tg) ⟩,
end

private noncomputable def on_ν_parallel₁_concretion {Γ ℓ} {M : affinity ℍ} {A : species ℍ ω Γ}
  {B : species ℍ ω (context.extend M.arity Γ)} {b y} :
  ∀ {A' : species ℍ ω (context.extend (M.arity) Γ)}
    {α' : label ℍ (context.extend M.arity Γ) kind.concretion}
    {α : label ℍ Γ kind.concretion}
    {E : concretion ℍ ω (context.extend M.arity Γ) b y}
  , (A' |ₛ B) [lookup.rename name.extend ℓ, α']⟶ (production.concretion E)
  → A' = rename name.extend A → α' = label.rename name.extend α
  → Σ' E' (eq : production.concretion (ν'(M)E) ≈ E')
    , (A |ₛ ν(M) B) [ℓ, α]⟶ E'
| A' α' α E (parL_concretion _ t) eqA eqα := begin
  subst eqA, subst eqα,
  rcases transition.rename_from name.extend t with ⟨ α₂, ⟨ B ⟩, t₂, eα, ⟨ _ ⟩ ⟩,
  cases label.rename.inj (@name.extend.inj _ _) eα,
  from ⟨ _, production.equiv.concretion (concretion.equiv.ν_parallel₂ M), parL_concretion _ t₂ ⟩,
end
| A' α' α E (parR_concretion _ t) eqA eqα := begin
  subst eqA, subst eqα,
  from ⟨ _, production.equiv.concretion (concretion.equiv.ν_parallel₁ M), parR_concretion _ (ν₁_concretion M rfl t) ⟩,
end

private noncomputable def on_ν_parallel₁ {Γ ℓ} {M : affinity ℍ} {A : species ℍ ω Γ}
  {B : species ℍ ω (context.extend (M.arity) Γ)} :
  ∀ {k} {α : label ℍ Γ k} {E : production ℍ ω Γ k}
  , (ν(M) rename name.extend A |ₛ B) [ℓ, α]⟶ E
  → Σ' E' (eq : E ≈ E'), (A |ₛ ν(M) B) [ℓ, α]⟶ E'
| k α ._ (ν₁_species M rfl t) := on_ν_parallel₁_species t rfl rfl
| k α ._ (ν₁_concretion M rfl t) := on_ν_parallel₁_concretion t rfl rfl
| ._ α ._ (@com₂ _ _ _ _ M p q _ _ k ek rfl t) := begin
  generalize eqA : species.rename (@name.extend _ M.arity) A = A', rw eqA at t,

  cases t,
  case parL_species : E t {
    subst eqA, exfalso,
    rcases transition.rename_from name.extend t with ⟨ α₂, ⟨ E ⟩, tf₂, eα, eE ⟩, -- Annoying!

    cases α₂; simp only [label.rename] at eα,
    case label.spontaneous { cases eα },
    from absurd eα no_rename_zero,
  },
  case parR_species : E t {
    subst eqA,
    from ⟨ _, production.equiv.species (ν_parallel₁ M), parR_species _ (com₂ M k ek rfl t ) ⟩,
  },
  case com₁ : x y a b F G eF eα tf tg {
    subst eqA, exfalso,

    rcases transition.rename_from name.extend tf with ⟨ α₂, ⟨ E ⟩, tf₂, eα', eE ⟩, -- Annoying!
    cases α₂, simp only [label.rename] at eα', subst eα',

    rcases upair.exists_rep p with ⟨ p₁, p₂, h ⟩, subst h,
    rcases quotient.exact (label.of_affinity.inj eα) with ⟨ l, r ⟩ | ⟨ l, r ⟩; contradiction,
  }
end

private noncomputable def on_ν_drop₁ {Γ ℓ} {M : affinity ℍ} {A : species ℍ ω Γ} :
  ∀ {k} {α : label ℍ Γ k} {E : production ℍ ω Γ k}
  , (ν(M) species.rename name.extend A) [ℓ, α]⟶ E
  → Σ' (E' : production ℍ ω Γ k) (eq : E ≈ E'), A [ℓ, α]⟶ E'
| k α E t := begin
  generalize eqA : species.rename (@name.extend _ M.arity) A = A', rw eqA at t,

  cases t,
  case com₂ : a b B k eqk eqα t' {
    subst eqA, subst eqα, exfalso,

    rcases transition.rename_from name.extend t' with ⟨ α₂, ⟨ E₂ ⟩ , t₂, eqα, eqE ⟩,
    cases α₂; simp only [label.rename] at eqα,
    case label.spontaneous { cases eqα },
    from absurd eqα no_rename_zero,
  },
  case ν₁_species : α₁ α₂ E eα t' {
    subst eqA, subst eα,
    rcases transition.rename_from name.extend t' with ⟨ α₂, ⟨ E₂ ⟩ , t₂, eqα, eqE ⟩,
    cases label.rename.inj (@name.extend.inj _ _) eqα,
    rw ← production.species.inj eqE,
    from ⟨ _, production.equiv.species (ν_drop₁ M), t₂ ⟩,
  },
  case ν₁_concretion : α₁ α₂ b y E eα t' {
    subst eqA, subst eα,
    rcases transition.rename_from name.extend t' with ⟨ α₂, ⟨ E₂ ⟩ , t₂, eqα, ⟨ _ ⟩ ⟩,
    cases label.rename.inj (@name.extend.inj _ _) eqα,
    from ⟨ _, production.equiv.concretion (concretion.equiv.ν_drop M), t₂ ⟩,
  }
end

private def on_ν_drop₂ {Γ ℓ} {M : affinity ℍ} {A : species ℍ ω Γ} :
  ∀ {k} {α : label ℍ Γ k} {E : production ℍ ω Γ k}
  , A [ℓ, α]⟶ E
  → Σ' (E' : production ℍ ω Γ k) (eq : E ≈ E'), (ν(M) species.rename name.extend A) [ℓ, α]⟶ E'
| k α (production.species E) t :=
  let t' := transition.rename (@name.extend _ M.arity) t in
  ⟨ _, production.equiv.species (ν_drop₂ M), ν₁_species M rfl t' ⟩
| k α (production.concretion E) t :=
  let t' := transition.rename (@name.extend _ M.arity) t in
  ⟨ _, production.equiv.concretion (concretion.equiv.ν_drop M).symm, ν₁_concretion M rfl t' ⟩

private def on_ν_swap₁ {Γ ℓ} {M N : affinity ℍ} {A : species ℍ ω (context.extend (N.arity) (context.extend (M.arity) Γ))} :
  ∀ {k} {α : label ℍ Γ k} {E : production ℍ ω Γ k}
    , (ν(M) ν(N) A) [ℓ, α]⟶ E
    → Σ' (E' : production ℍ ω Γ k) (eq : E ≈ E')
      , (ν(N) ν(M) species.rename name.swap A) [ℓ, α]⟶ E'
| ._ α E₁ (ν₁_species _ eα₁ (ν₁_species _ eα₂ t)) := begin
  subst eα₁, subst eα₂,
  have t' := transition.rename name.swap t,
  rw [label.rename_compose, label.rename_compose, name.swap_comp_extend, name.ext_extend, ← label.rename_compose] at t',
  rw [lookup.rename_compose, lookup.rename_compose, name.swap_comp_extend, name.ext_extend, ← lookup.rename_compose] at t',
  from ⟨ _, production.equiv.species (ν_swap₁ M N), ν₁_species N rfl (ν₁_species M rfl t' ) ⟩,
end
| ._ α E₁ (ν₁_species _ eα (com₂ _ k ek rfl t)) := begin
  cases α; simp only [label.rename] at eα,
  case label.of_affinity { contradiction },
  subst eα,

  have t' := transition.rename name.swap t,
  rw [lookup.rename_compose, lookup.rename_compose, name.swap_comp_extend, name.ext_extend, ← lookup.rename_compose] at t',
  refine ⟨ _, production.equiv.species (ν_swap₁ M N), com₂ N k ek rfl (ν₁_species M _ t') ⟩,

  simp only [label.rename, upair.map_compose, function.comp, name.swap],
end
| ._ α E₁ (ν₁_concretion _ rfl (ν₁_concretion _ rfl t)) := begin
  have t' := transition.rename name.swap t,
  rw [label.rename_compose, label.rename_compose, name.swap_comp_extend, name.ext_extend, ← label.rename_compose] at t',
  rw [lookup.rename_compose, lookup.rename_compose, name.swap_comp_extend, name.ext_extend, ← lookup.rename_compose] at t',
  from ⟨ _, production.equiv.concretion (concretion.equiv.ν_swap M N), ν₁_concretion N rfl (ν₁_concretion M rfl t' ) ⟩,
end
| ._ α E₁ (com₂ _ k ek rfl (ν₁_species _ rfl t)) := begin
  have t' := transition.rename name.swap t,
  rw [lookup.rename_compose, lookup.rename_compose, name.swap_comp_extend, name.ext_extend, ← lookup.rename_compose] at t',
  refine ⟨ _, production.equiv.species (ν_swap₁ M N), ν₁_species N rfl (com₂ M k ek _ t') ⟩,

  rw [upair.map_compose, upair.map_compose, name.swap_comp_extend, name.ext_zero],
end

private def on_ν_swap₂ {Γ ℓ} {M N : affinity ℍ} {A : species ℍ ω (context.extend (N.arity) (context.extend (M.arity) Γ))}:
  ∀ {k} {α : label ℍ Γ k} {E : production ℍ ω Γ k}
  , (ν(N) ν(M) species.rename name.swap A) [ℓ, α]⟶ E
  → Σ' (E' : production ℍ ω Γ k) (eq : E ≈ E'), (ν(M) ν(N) A) [ℓ, α]⟶ E'
| k α E₁ t := begin
  rcases on_ν_swap₁ t with ⟨ E', eqE, t' ⟩,
  rw [species.rename_compose, name.swap_swap, species.rename_id] at t',
  from ⟨ E', eqE, t' ⟩,
end

/-- Convert a transition from one species to a transition from another
    equivalent species, with the same label and equivalent production. -/
noncomputable def equivalent_of :
  ∀ {Γ ℓ k} {A : species ℍ ω Γ} {B : species ℍ ω Γ} {α : label ℍ Γ k} {E : production ℍ ω Γ k}
  , species.equivalent A B → A [ℓ, α]⟶ E
  → Σ' (E' : production ℍ ω Γ k) (eq : E ≈ E'), B [ℓ, α]⟶ E'
| Γ₁ ℓ₁ k₁ A₁ B₁ α₁ E₁ equ t₁ := begin
  induction equ generalizing k₁,

  case species.equivalent.refl { from ⟨ E₁, refl _, t₁ ⟩ },
  case species.equivalent.trans : Γ A B C ab bc ih_ab ih_bc {
    rcases ih_ab _ _ α₁ E₁ t₁ with ⟨ E₂, eq₂, t₂ ⟩,
    rcases ih_bc _ _ α₁ E₂ t₂ with ⟨ E₃, eq₃, t₃ ⟩,
    from ⟨ E₃, trans eq₂ eq₃, t₃ ⟩
  },

  case species.equivalent.ξ_parallel₁ : Γ A A' B eq ih {
    cases t₁,
    case com₁ : x y a b F G E' α' eE eα tf tg {
      subst eE, subst eα,
      rcases ih _ _ (#a) _ tf with ⟨ F', equ, tf' ⟩, cases F' with _ b y' F',
      rcases production.equiv.arity equ with ⟨ ⟨ _ ⟩, ⟨ _ ⟩ ⟩,

      from ⟨ _, production.equiv.species (concretion.pseudo_apply.equiv (production.equiv.unwrap_c equ) (refl G)),
             com₁ rfl rfl tf' tg ⟩,
    },
    case parL_species : α' E t {
      rcases ih _ _ _ _ t with ⟨ E', equ, t' ⟩, cases E',
      from ⟨ _, production.equiv.species (ξ_parallel₁ (production.equiv.unwrap_s equ)), parL_species B t' ⟩
    },
    case parL_concretion : α' b y E t {
      rcases ih _ _ _ _ t with ⟨ E', equ, t' ⟩, cases E',
      rcases production.equiv.arity equ with ⟨ ⟨ _ ⟩, ⟨ _ ⟩ ⟩,
      from ⟨ _, production.equiv.concretion (concretion.equiv.ξ_parallel₁ (production.equiv.unwrap_c equ)),
        parL_concretion _ t' ⟩,
    },
    case parR_species : α' E t {
      from ⟨ _, production.equiv.species (ξ_parallel₁ ⟨ eq ⟩), parR_species _ t ⟩,
    },
    case parR_concretion : α' b y E t {
      from ⟨ _, production.equiv.concretion (concretion.equiv.ξ_parallel' ⟨ eq ⟩), parR_concretion _ t ⟩,
    },
  },

  case species.equivalent.ξ_parallel₂ : Γ A B B' eq ih {
    cases t₁,
    case com₁ : x y a b F G E' α' eE eα tf tg {
      subst eE, subst eα,
      rcases ih _ _ (#b) _ tg with ⟨ G', equ, tg' ⟩, cases G' with _ b y' G',
      rcases production.equiv.arity equ with ⟨ ⟨ _ ⟩, ⟨ _ ⟩ ⟩,
      from ⟨ _, production.equiv.species (concretion.pseudo_apply.equiv (refl F) (production.equiv.unwrap_c equ)),
             com₁ rfl rfl tf tg' ⟩,
    },
    case parL_species : α' E t {
      from ⟨ _, production.equiv.species (ξ_parallel₂ ⟨ eq ⟩), parL_species _ t ⟩,
    },
    case parL_concretion : α' b y E t {
      from ⟨ _, production.equiv.concretion (concretion.equiv.ξ_parallel ⟨ eq ⟩), parL_concretion _ t ⟩,
    },
    case parR_species : α' E t {
      rcases ih _ _ _ _ t with ⟨ E', equ, t' ⟩, cases E',
      from ⟨ _, production.equiv.species (ξ_parallel₂ (production.equiv.unwrap_s equ)), parR_species _ t' ⟩
    },
    case parR_concretion : α' b y E t {
      rcases ih _ _ _ _ t with ⟨ E', equ, t' ⟩, cases E',
      rcases production.equiv.arity equ with ⟨ ⟨ _ ⟩, ⟨ _ ⟩ ⟩,
      from ⟨ _, production.equiv.concretion (concretion.equiv.ξ_parallel₂ (production.equiv.unwrap_c equ)),
        parR_concretion _ t' ⟩,
    },
  },

  case species.equivalent.ξ_restriction : Γ M A A' eq ih {
    cases t₁,

    case com₂ : p p' B k ek ep t {
      rcases ih _ _ _ _ t with ⟨ E', equ, t' ⟩,
      cases E' with B',

      from ⟨ _, production.equiv.species (ξ_restriction M (production.equiv.unwrap_s equ)), com₂ M k ek ep t' ⟩,
    },
    case ν₁_species : α α' E eα t {
      rcases ih _ _ _ _ t with ⟨ E', equ, t' ⟩, cases E',
      from ⟨ _, production.equiv.species (ξ_restriction M (production.equiv.unwrap_s equ)),
        ν₁_species M eα t' ⟩,
    },
    case ν₁_concretion : α α' b y E eα t {
      rcases ih _ _ _ _ t with ⟨ E', equ, t' ⟩, cases E',
      rcases production.equiv.arity equ with ⟨ ⟨ _ ⟩, ⟨ _ ⟩ ⟩,
      from ⟨ _, production.equiv.concretion (concretion.equiv.ξ_restriction M (production.equiv.unwrap_c equ)),
        ν₁_concretion M eα t' ⟩,
    },
  },

  case species.equivalent.ξ_choice_here : Γ f π A A' As eq ih {
    cases t₁,
    case ξ_choice : t { refine ⟨ _, refl _, ξ_choice t ⟩ },
    case choice₁ : a n b b_len y {
      from ⟨ _, production.equiv.concretion (concretion.equiv.ξ_apply ⟨ eq ⟩), choice₁ a b b_len y A' As ⟩,
    },
    case choice₂ : k { from ⟨ _, production.equiv.species ⟨ eq ⟩, choice₂ k A' As ⟩ },
  },

  case species.equivalent.ξ_choice_there : Γ f π A As As' eq ih {
    cases t₁,

    case ξ_choice : t {
      rcases ih _ _ α₁ E₁ t with ⟨ E', equ, t' ⟩,
      refine ⟨ _, equ, ξ_choice t' ⟩,
    },
    case choice₁ : a n b b_len y A As { from ⟨ _, refl _, choice₁ a b b_len y A As' ⟩ },
    case choice₂ : k A As { from ⟨ _, refl _, choice₂ k A As' ⟩ },
  },

  case species.equivalent.parallel_nil₁ : Γ A {
    cases t₁,

    -- No such transition for (nil ⟶ _)
    case com₁ : x y a b F G FG α eFG eα tf tg { cases tg },
    case parR_species : α E t { cases t },
    case parR_concretion : α b y E t { cases t },
    case parL_species : α E t { from ⟨ _, production.equiv.species parallel_nil₁, t ⟩ },
    case parL_concretion : α b y E t { from ⟨ _, production.equiv.concretion concretion.equiv.parallel_nil, t ⟩ },
  },

  case species.equivalent.parallel_nil₂ : Γ B {
    cases E₁,
    case production.species { from ⟨ _, production.equiv.species parallel_nil₂, parL_species _ t₁ ⟩ },
    case production.concretion { from ⟨ _, production.equiv.concretion concretion.equiv.parallel_nil.symm, parL_concretion _ t₁ ⟩ },
  },

  case species.equivalent.choice_swap { from on_choice_swap t₁ },

  case species.equivalent.parallel_assoc₁ { from on_parallel_assoc₁ t₁ },
  case species.equivalent.parallel_assoc₂ { from on_parallel_assoc₂ t₁ },

  case species.equivalent.parallel_symm { from on_parallel_symm t₁ },

  case species.equivalent.ν_parallel₁ { from on_ν_parallel₁ t₁ },
  case species.equivalent.ν_parallel₂ { from on_ν_parallel₂ t₁ },
  case species.equivalent.ν_drop₁ { from on_ν_drop₁ t₁ },
  case species.equivalent.ν_drop₂ { from on_ν_drop₂ t₁ },
  case species.equivalent.ν_swap₁ { from on_ν_swap₁ t₁ },
  case species.equivalent.ν_swap₂ { from on_ν_swap₂ t₁ },
end

/-- Drops the congruence restriction from `equivalent_of`. -/
noncomputable def equivalent_of.map {Γ ℓ} {A B : species ℍ ω Γ} (h : species.equivalent A B)
  {k} {α : label ℍ Γ k}
  : (Σ (E : production ℍ ω Γ k), A [ℓ, α]⟶ E)
  → (Σ (E : production ℍ ω Γ k), B [ℓ, α]⟶ E)
| ⟨ E, t ⟩ :=
  let ⟨ E', _, t' ⟩ := equivalent_of h t in
  ⟨ E', t' ⟩

/-- Show that 'equivalent_of' twice yields the same thing. This is not going to
    be fun. -/
axiom equivalent_of.map_map {Γ ℓ} {A B : species ℍ ω Γ} (h : species.equivalent A B)
    {k} {α : label ℍ Γ k} (t : Σ (E : production ℍ ω Γ k), A [ℓ, α]⟶ E)
  : equivalent_of.map h.symm (equivalent_of.map h t) = t

/-- Show that two equivalent species's transition sets are equivalent. -/
noncomputable def equivalent_of.is_equiv {Γ ℓ} {A B : species ℍ ω Γ} (h : species.equivalent A B)
    {k} {α : label ℍ Γ k}
  : (Σ (E : production ℍ ω Γ k), A [ℓ, α]⟶ E) ≃ (Σ (E : production ℍ ω Γ k), B [ℓ, α]⟶ E)
  := { to_fun := equivalent_of.map h,
       inv_fun := equivalent_of.map h.symm,
       left_inv := equivalent_of.map_map h,
       right_inv := λ x, begin
         have this := equivalent_of.map_map h.symm x,
         rw ← species.equivalent.symm_symm h at this,
         from this,
       end }

lemma equivalent_of.map_equiv {Γ ℓ} {A B : species ℍ ω Γ} (h : species.equivalent A B)
    {k} {α : label ℍ Γ k}
    (E : production ℍ ω Γ k) (t : A [ℓ, α]⟶ E)
  : E ≈ (equivalent_of.map h ⟨ E, t ⟩).1 := begin
  unfold equivalent_of.map,
  rcases (equivalent_of h t) with ⟨ E', eqE, t' ⟩,
  from eqE,
end

end transition
end cpi

#lint-


import number_theory.bernoulli

--OUTPUT 1
theorem bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1) :=
begin
  induction n with d hd,
  {
    unfold polynomial.bernoulli polynomial.eval,
    by_cases (x = 0),
    {
      replace h : x = 0, from h,
      clear h,
      rw h,
      auto [mul_zero, zero_add],
    },
    {
      have h2 : x ≠ 0, from h,
      have h3 : (1 : ℚ) ≠ 0, from by auto [ne.symm h2],
      have h4 : 1 / x ≠ 0, from by auto [div_ne_zero h3],
      have h5 : x ≠ 0, from ne.symm h,
      have h6 : (1 + x) ≠ 0, from by auto [add_ne_zero],
      have h7 : (1 + x) ≠ 0, from h6,
      have h8 : (1 + x) ≠ 0, from by auto [add_ne_zero],
      have h9 : 1 + x ≠ 0, from h8,
      have h10 : (1 + x) ≠ 0, from by auto [add_ne_zero],
      have h11 : (1 + x) ≠ 0, from by auto [add_ne_zero],
      have h12 : ↑(1 + x) ≠ 0, from h11,
      have h13 : (1 : ℚ) ≠ 0, from by auto [ne.symm h2],
      have h14 : 1 ≠ 0, from h13,
      have h15 : (1 : ℚ) ≠ 0, from by auto [ne.symm h2],
      have h16 : (1 : ℚ) ≠ 0, from by auto [ne.symm h2],
      have h17 : (1 : ℚ) ≠ 0, from by auto [ne.symm h2],
      have h18 : (1 : ℚ) ≠ 0, from by auto [ne.symm h2],
      have h19 : (1 : ℚ) ≠ 0, from by auto [ne.symm h2],
      have h20 : (1 : ℚ) ≠ 0, from by auto [ne.symm h2],
      have h21 : 1 + x ≠ 0, from mul_ne_zero (cast h19) (cast h20),
      have h22 : (1 + x) ≠ 0, from h21,
      have h23 : (1 + x) ≠ 0, from h22,
      have h24 : 1 ≠ 0, from ne.symm h2,
      have h25 : 1 + x ≠ 0, from mul_ne_zero (cast h23) (cast h24),
      have h26 : (1 + x) ≠ 0, from h25,
      have h27 : (1 + x) ≠ 0, from by auto [add_ne_zero],
      have h28 : (1 + x) ≠ 0, from h27,
      rw show (1 : ℚ) = 1, from rfl,
      rw show (1 : ℚ) = 1, from rfl,
      rw show (1 : ℚ) = 1, from rfl,
      rw show (1 : ℚ) = 1, from rfl,
      rw show 1 + x = ↑(1 + x), from rfl,
      rw show (1 + x) = (1 + x), from rfl,
      rw show (1 + x) = (1 + x), from rfl,
      rw show x = (↑x : ℚ), from rfl,
      rw show ↑(x : ℚ) = (↑x : ℚ), from rfl,
      rw show x = (↑x : ℚ), from rfl,
      rw show ↑(x : ℚ) = (↑x : ℚ), from rfl,
      rw show x = (↑x : ℚ), from rfl,
      rw show ↑(x : ℚ) = (↑x : ℚ), from rfl,
      rw show x = (↑x : ℚ), from rfl,
      rw show ↑(x : ℚ) = (↑x : ℚ), from rfl,
      rw show ↑(x : ℚ) = (↑x : ℚ), from rfl,
      have h29 : (1 + x) ≠ 0, from by auto [add_ne_zero],
      have h30 : (1 + x) ≠ 0, from by auto [add_ne_zero],
      rw show (1 + x) = (1 + x), from rfl,
      rw show (1 + x) = (1 + x), from rfl,
      rw show ↑(1 + x) = (1 + x), from rfl,
      rw show ↑(1 + x) = (1 + x), from rfl,
      rw show (1 + x) = (1 + x), from rfl,
      rw show ↑(1 + x) = (1 + x), from rfl,
      rw show (1 + x) = (1 + x), from rfl,
      rw show ↑(1 + x) = (1 + x), from rfl,
      rw show (1 + x) = (1 + x), from rfl,
      rw show ↑(1 + x) = (1 + x), from rfl,
      rw show (1 + x) = (1 + x), from rfl,
      rw show ↑(1 + x) = (1 + x), from rfl,
      rw show (1 + x) = (1 + x), from rfl,
      rw show ↑(1 + x) = (1 + x), from rfl,
      rw show (1 + x) = (1 + x), from rfl,
      rw show ↑(1 + x) = (1 + x), from rfl,
      rw show (1 + x) = (1 + x), from rfl,
      rw show ↑(1 + x) = (1 + x), from rfl,
      rw show (1 + x) = (1 + x), from rfl,
      rw show ↑(1 + x) = (1 + x), from rfl,
      rw show (1 + x) = (1 + x), from rfl,
      rw show ↑(1 + x) = (1 + x), from rfl,
      rw show (1 + x) = (1 + x), from rfl,
      rw show ↑(1 + x) = (1 + x), from rfl,
      rw show (1 + x) = (1 + x), from rfl,
      rw show ↑(1 + x) = (1 + x), from rfl,
      rw show (1 + x) = (1 + x), from rfl,
      rw show ↑(1 + x) = (1 + x), from rfl,
      rw show (1 + x) = (1 + x), from rfl,
      rw show ↑(1 + x) = (1 + x), from rfl,
      rw show (1 + x) = (1 + x), from rfl,
      rw show ↑(1 + x) = (1 + x), from rfl,
      rw show (1 + x) = (1 + x), from rfl,
      rw show ↑(1 + x) = (1 + x), from rfl,
      rw show (1 + x) = (1 + x), from rfl,
      rw show ↑(1 + x) = (1 + x), from rfl,
      rw show (1 + x) = (1 + x), from rfl,
      rw show ↑(1 + x) = (1 + x), from rfl,
      rw show (1 + x) = (1 + x), from rfl,
      rw show ↑(1 + x) = (1 + x), from rfl,
      rw show (1 + x) = (1 + x), from rfl,
      rw show ↑(1 + x) = (1 + x), from rfl,
      rw show (1 + x) = (1 + x), from rfl,
      rw show ↑(1 + x) = (
end --Needs more than 2000 tokens!

--OUTPUT 2
theorem bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1) :=
begin
  apply nat.strong_induction_on n,
  assume d h,
  have h1 : (d + 1) * (1 + x)^d - (d + 1) * x^d = (polynomial.sum (λ (k : ℕ), (polynomial.C (nat.choose (d + 1) k)) * polynomial.X^k)).eval x, from begin
    calc (d + 1) * (1 + x)^d - (d + 1) * x^d =
      (polynomial.sum (λ (k : ℕ), (polynomial.C (nat.choose (d + 1) k)) * polynomial.X^k)).eval (1 + x) - (d + 1) * x^d : by auto [polynomial.eval_sum]
    ... = (polynomial.sum (λ (k : ℕ), (polynomial.C (nat.choose (d + 1) k)) * polynomial.X^k)).eval x : begin
        apply nat.induction_on d,
        repeat {rw ←add_zero},
        simp,
        assume d h,
        rw [nat.add_succ, polynomial.eval_sum],
        have h1 : ∀ k : ℕ, (polynomial.C (nat.choose (d + 1) k)) * polynomial.X^k * (1 + x) =
                            (polynomial.C (nat.choose (d + 1) k)) * (polynomial.X^k * (1 + x)), from by repeat {rw polynomial.mul_one},
        rw h1,
        rw polynomial.eval_mul,
        rw polynomial.eval_X,
        rw polynomial.eval_C,
        rw polynomial.eval_X,
        rw polynomial.eval_C,
        ring,
    end
    ... = (polynomial.sum (λ (k : ℕ), (polynomial.C (nat.choose (d + 1) k)) * polynomial.X^k)).eval x : rfl,
  end,
  have h2 : (polynomial.sum (λ (k : ℕ), (polynomial.C (nat.choose (d + 1) k)) * polynomial.X^k)).eval x = (polynomial.sum (λ (k : ℕ), k * polynomial.X^(k - 1))).eval x, from begin
    rw polynomial.eval_sum,
    apply nat.induction_on d,
    simp,
    assume d h,
    rw [nat.add_succ, polynomial.eval_sum],
    have h1 : ∀ k : ℕ, (polynomial.C (nat.choose (d + 1) k)) * polynomial.X^k =
                            polynomial.C k * polynomial.X^(k - 1), from by auto [polynomial.C_one, nat.choose_one],
    rw h1,
    rw polynomial.eval_mul,
    rw polynomial.eval_X,
    rw polynomial.eval_C,
    rw polynomial.eval_X,
    rw polynomial.eval_C,
    ring,
  end,
  rw h1,
  rw h2,
  rw [nat.add_succ, polynomial.eval_sum],
  have h3 : ∀ k : ℕ, (polynomial.C k * polynomial.X^(k - 1)) * x =
                          k * (polynomial.X^(k - 1) * x), from by auto [polynomial.mul_one],
  rw h3,
  rw polynomial.eval_mul,
  rw polynomial.eval_X,
  rw polynomial.eval_C,
  rw polynomial.eval_X,
  rw polynomial.eval_C,
  ring,
end

--OUTPUT 3
theorem bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1) :=
begin
induction n with d hd,
{ simp [polynomial.bernoulli, polynomial.eval_add, polynomial.eval_C, polynomial.eval_mul,
  polynomial.eval_X, polynomial.eval_nat_cast, polynomial.eval_sub, polynomial.eval_X_sub_C,
  polynomial.eval_C_sub_X, polynomial.eval_sub_C_C, polynomial.eval_sub_X_C, polynomial.eval_sub_C_X,
  polynomial.eval_sub_X_X, polynomial.eval_pow, polynomial.eval_neg, polynomial.eval_one,
  polynomial.eval_C_add, polynomial.eval_add_C_C],
},
{ simp [polynomial.bernoulli, polynomial.eval_add, polynomial.eval_C, polynomial.eval_mul,
  polynomial.eval_X, polynomial.eval_nat_cast, polynomial.eval_sub, polynomial.eval_X_sub_C,
  polynomial.eval_C_sub_X, polynomial.eval_sub_C_C, polynomial.eval_sub_X_C, polynomial.eval_sub_C_X,
  polynomial.eval_sub_X_X, polynomial.eval_pow, polynomial.eval_neg, polynomial.eval_one,
  polynomial.eval_C_add, polynomial.eval_add_C_C],
}
end

--OUTPUT 4
theorem bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1) :=
begin
  rw[polynomial.eval_add, polynomial.eval_one, polynomial.eval_one],
  have h : ∀ m : ℕ, m ≤ n → (m : ℚ) ≤ n, from λ m hm, by linarith,
  induction n with d hd,
  { calc (polynomial.bernoulli 0).eval (1 + x) = (polynomial.bernoulli 0).eval (x + 1) :  by simp
                      ... = (polynomial.bernoulli 0).eval x + (0 : ℚ) * x^(0 - 1) : by simp [hd (by linarith)]
                      ... = (polynomial.bernoulli 0).eval x + (0 : ℚ) : by simp [polynomial.eval_zero]
                      ... = (polynomial.bernoulli 0).eval x : by simp [zero_add]},
  {calc (polynomial.bernoulli (d + 1)).eval (1 + x) = (polynomial.bernoulli (d + 1)).eval (x + 1) :  by simp
                     ... = (polynomial.bernoulli (d + 1)).eval x + (d + 1 : ℚ) * x^(d + 1 - 1) : by rw[polynomial.eval_add, polynomial.eval_one, polynomial.eval_one, hd (by linarith)]
                     ... = (polynomial.bernoulli (d + 1)).eval x + d * x^d + x^d : by simp
                     ... = (polynomial.bernoulli (d + 1)).eval x + (d * x^d + x^d) : by simp [polynomial.eval_add, polynomial.eval_one, polynomial.eval_one]
                     ... = (polynomial.bernoulli (d + 1)).eval x + d * x^d + x^d : by simp [polynomial.eval_add, polynomial.eval_one, polynomial.eval_one]
                     ... = (polynomial.bernoulli (d + 1)).eval x + (d * x^d + x^d) : by simp [polynomial.eval_add, polynomial.eval_one, polynomial.eval_one]
                     ... = (polynomial.bernoulli (d + 1)).eval x + (d : ℚ) * (x^d + 1) : by simp [ring]
                     ... = (polynomial.bernoulli (d + 1)).eval x + (d : ℚ) * ((x + 1)^d) : by simp [polynomial.eval_add, polynomial.eval_one, polynomial.eval_one, polynomial.eval_one]
                     ... = (polynomial.bernoulli (d + 1)).eval x + (d : ℚ) * ((x + 1)^d - x^d) : by ring
                     ... = (polynomial.bernoulli (d + 1)).eval x + (d : ℚ) * (sum (λ (m : ℕ), (d : ℚ) choose m * x^m) (d - 1)) : by rw[polynomial.eval_one, polynomial.eval_one]
                     ... = (polynomial.bernoulli (d + 1)).eval x + sum (λ (m : ℕ), (d : ℚ) choose m * (d : ℚ) * x^m) (d - 1) : by simp [ring]
                     ... = (polynomial.bernoulli (d + 1)).eval x + (d : ℚ) * sum (λ (m : ℕ), m * x^m) (d - 1) : by simp
                     ... = (polynomial.bernoulli (d + 1)).eval x + (d : ℚ) * sum (λ (m : ℕ), m * x^m) (d - 1) : by simp
                     ... = (polynomial.bernoulli (d + 1)).eval x + (d : ℚ) * sum (λ (m : ℕ), ((m + 1) - 1 : ℚ) * x^m) (d - 1) : by simp
                     ... = (polynomial.bernoulli (d + 1)).eval x + (d : ℚ) * sum (λ (m : ℕ), (m + 1 : ℚ) * x^m - (1 : ℚ) * x^m) (d - 1) : by refl
                     ... = (polynomial.bernoulli (d + 1)).eval x + (d : ℚ) * sum (λ (m : ℕ), (m + 1 : ℚ) * x^m) (d - 1) - (d : ℚ) * sum (λ (m : ℕ), (1 : ℚ) * x^m) (d - 1) : by simp [sum_sub_sum]
                     ... = (polynomial.bernoulli (d + 1)).eval x + (d : ℚ) * sum (λ (m : ℕ), (m + 1 : ℚ) * x^m) (d - 1) - (d : ℚ) * (sum (λ (m : ℕ), (1 : ℚ) * x^m) (d - 1)) : by simp
                     ... = (polynomial.bernoulli (d + 1)).eval x + (d : ℚ) * sum (λ (m : ℕ), (m + 1 : ℚ) * x^m) (d - 1) - (d : ℚ) * (x^(d - 1) + sum (λ (m : ℕ), 1) (d - 2)) : by simp [sum_range_succ]
                     ... = (polynomial.bernoulli (d + 1)).eval x + (d : ℚ) * sum (λ (m : ℕ), (m + 1 : ℚ) * x^m) (d - 2) - (d : ℚ) * x^(d - 1) : by simp [sum_range_succ]
                     ... = (polynomial.bernoulli (d + 1)).eval x + (d : ℚ) * sum (λ (m : ℕ), (m + 1 : ℚ) * x^m) (d - 2) - (d : ℚ) * x^(d - 1) : by simp [sum_range_succ]
                     ... = ((d : ℚ) * sum (λ (m : ℕ), (m + 1 : ℚ) * x^m) (d - 2) + (polynomial.bernoulli (d + 1)).eval x - (d : ℚ) * x^(d - 1)) : by simp
                     ... = ((d : ℚ) * sum (λ (m : ℕ), (m + 1 : ℚ) * x^m) (d - 2) + ((polynomial.bernoulli (d + 1)).eval x - (d : ℚ) * x^(d - 1))) : by refl
                     ... = ((d : ℚ) * sum (λ (m : ℕ), (m + 1 : ℚ) * x^m) (d - 2) + ((polynomial.bernoulli (d + 1)).eval x - (d : ℚ) * x^(d - 1))) : by refl
                     ... = (d : ℚ) * sum (λ (m : ℕ), (m + 1 : ℚ) * x^m) (d - 2) + (polynomial.bernoulli (d + 1)).eval x - (d : ℚ) * x^(d - 1) : by simp
                     ... = (d : ℚ) * sum (λ (m : ℕ), (m + 1 : ℚ) * x^m) (d - 2) + (polynomial.bernoulli (d + 1)).eval x - (d : ℚ) * x^(d - 1) : by simp
                     ... = (d : ℚ) * sum (λ (m : ℕ), (m + 1 : ℚ)
end --Needs more than 2000 tokens!

--OUTPUT 5
theorem bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1) :=
begin
  induction n with h hd,
  { simp },
  { have h1 : polynomial.sum (λ (k : ℕ), (n + 1) * ↑(choose (n + 1) k) * (polynomial.X : polynomial ℚ)^k) (λ (k : ℕ), k * (polynomial.X : polynomial ℚ)^(k - 1)) =
    (n + 1) * (polynomial.X : polynomial ℚ) ^ n, from by auto [polynomial.sum],
    have h2 : polynomial.sum (λ (k : ℕ), (n + 1) * ↑(choose (n + 1) k) * ((polynomial.X : polynomial ℚ)^k)) (λ (k : ℕ), k * ((polynomial.X : polynomial ℚ)^(k - 1))) =
    polynomial.sum (λ (k : ℕ), (n + 1) * ↑(choose (n + 1) k) * ((polynomial.X : polynomial ℚ)^k)) (λ (k : ℕ), k * x^(k - 1)), from by auto [polynomial.sum],
    have h3 : n * (1 + x) ^ n - n * x ^ n = polynomial.sum (λ (k : ℕ), (n + 1) * ↑(choose (n + 1) k) * ((polynomial.X : polynomial ℚ)^k)) (λ (k : ℕ), k * ((polynomial.X : polynomial ℚ)^(k - 1))), from
      calc n * (1 + x) ^ n - n * x ^ n = polynomial.sum (λ (k : ℕ), n * ↑(choose (n + 1) k) * ((polynomial.X : polynomial ℚ)^k)) (λ (k : ℕ), (k + 1) * ((polynomial.X : polynomial ℚ)^k)) : by auto [polynomial.sum, polynomial.sum, polynomial.sum, polynomial.sum]
    ... = polynomial.sum (λ (k : ℕ), (n + 1) * ↑(choose (n + 1) k) * ((polynomial.X : polynomial ℚ)^k)) (λ (k : ℕ), k * ((polynomial.X : polynomial ℚ)^k)) + (n + 1) * ((polynomial.X : polynomial ℚ)^n) : by auto [polynomial.sum]
    ... = (n + 1) * ((polynomial.X : polynomial ℚ)^n) : by auto [polynomial.sum, h1],
    have h4 : (polynomial.bernoulli (n + 1)).eval (1 + x) - (polynomial.bernoulli (n + 1)).eval x =
    polynomial.sum (λ (k : ℕ), (n + 1) * ↑(choose (n + 1) k) * ((polynomial.X : polynomial ℚ)^k)) (λ (k : ℕ), k * ((polynomial.X : polynomial ℚ)^(k - 1))), from by auto [polynomial.sum],
    have h5 : (polynomial.bernoulli (n + 1)).eval (1 + x) - (polynomial.bernoulli (n + 1)).eval x =
    polynomial.sum (λ (k : ℕ), (n + 1) * ↑(choose (n + 1) k) * ((polynomial.X : polynomial ℚ)^k)) (λ (k : ℕ), k * x^(k - 1)), from by auto [h2],
    have h6 : (polynomial.bernoulli (n + 1)).eval (1 + x) - (polynomial.bernoulli (n + 1)).eval x =
    n * (1 + x) ^ n - n * x ^ n, from by auto [h3, h4],
    have h7 : (polynomial.bernoulli (n + 1)).eval (1 + x) - (polynomial.bernoulli (n + 1)).eval x =
    polynomial.sum (λ (k : ℕ), (n + 1) * ↑(choose (n + 1) k) * x^k) (λ (k : ℕ), k * x^(k - 1)), from by auto [h5],
    have h8 : (polynomial.bernoulli (n + 1)).eval (1 + x) - (polynomial.bernoulli (n + 1)).eval x + (n + 1) * x ^ n =
    polynomial.sum (λ (k : ℕ), (n + 1) * ↑(choose (n + 1) k) * x^k) (λ (k : ℕ), (k + 1) * x^k), from by auto [polynomial.sum, polynomial.sum, polynomial.sum],
    have h9 : (polynomial.bernoulli (n + 1)).eval (1 + x) =
    polynomial.sum (λ (k : ℕ), (n + 1) * ↑(choose (n + 1) k) * x^k) (λ (k : ℕ), (k + 1) * x^k), from by auto [h6, h7, h8],
    have h10 : polynomial.sum (λ (k : ℕ), (n + 1) * ↑(choose (n + 1) k) * x^k) (λ (k : ℕ), (k + 1) * x^k) =
    polynomial.sum (λ (k : ℕ), (n + 1) * ↑(choose (n + 1) k) * x^k) (λ (k : ℕ), n * x^(n - 1)), from by auto [polynomial.sum],
    have h11 : (polynomial.bernoulli (n + 1)).eval (1 + x) =
    (n + 1) * x^n + n * x^n, from by auto [h9, h10, polynomial.sum, polynomial.sum],
    show (polynomial.bernoulli (n + 1)).eval (1 + x) = (polynomial.bernoulli (n + 1)).eval x + (n + 1) * x^(n + 1 - 1), from by auto [(n + 1) * x^(n + 1 - 1)],
  },
end

--OUTPUT 6
theorem bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1) :=
begin
    induction n with l hl,
    rw polynomial.bernoulli,
    simp,
    rw add_zero,
    simp,

    rw polynomial.bernoulli at hl,
    simp [polynomial.eval_sum, polynomial.eval_C],
    rw polynomial.bernoulli,
    simp,
    rw add_comm,
    rw mul_comm (1 + x) x,
    rw add_assoc,
    rw hl,
    rw add_assoc (l * x ^ (l - 1)),
    rw mul_pow,
    rw mul_comm,
    rw add_comm,
    rw mul_comm ((1 + x) * x) x,
    rw ← mul_assoc,
    rw ← mul_comm x,
    rw ← pow_succ,
    rw mul_comm (l + 1) x,
end

--OUTPUT 7
theorem bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1) :=
begin
  induction n with n hn generalizing x,
  {
    show (polynomial.bernoulli 0).eval (1 + x) = (polynomial.bernoulli 0).eval x, from by simp [eval_C],
  },
  {
    have h1 : (polynomial.prod (λ (m : ℕ), C (m + 1) * (X^m + X^(m + 1))) n).eval (1 + x) =
              (polynomial.prod (λ (m : ℕ), C (m + 1) * (X^m + X^(m + 1))) n).eval x, from by auto [eval_prod],
    have h2 : (polynomial.prod (λ (m : ℕ), C (m + 1) * (X^m + X^(m + 1))) n).eval x =
              (polynomial.prod (λ (m : ℕ), C (m + 1) * X^m) n).eval x +
              (polynomial.prod (λ (m : ℕ), C (m + 1) * X^(m + 1)) n).eval x, from by auto [eval_prod, eval_add],
    have h3 : (polynomial.prod (λ (m : ℕ), C (m + 1) * X^m) n).eval x =
              (polynomial.prod (λ (m : ℕ), C (m + 1)) n).eval x *
              (polynomial.prod (λ (m : ℕ), X^m) n).eval x, from by auto [eval_prod],
    have h4 : (polynomial.prod (λ (m : ℕ), C (m + 1)) n).eval x =
              (polynomial.prod (λ (m : ℕ), C (m + 1)) n).eval 0, from by auto [eval_prod_const],
    have h5 : (polynomial.prod (λ (m : ℕ), X^m) n).eval x =
              polynomial.prod (λ (m : ℕ), X) n, from by auto [eval_prod],
    have h6 : (polynomial.prod (λ (m : ℕ), C (m + 1) * X^(m + 1)) n).eval x =
              (polynomial.prod (λ (m : ℕ), C (m + 1)) n).eval x *
              (polynomial.prod (λ (m : ℕ), X) n) ^ (n + 1), from by auto [eval_prod],
    have h7 : (polynomial.prod (λ (m : ℕ), C (m + 1) * X^(m + 1)) n).eval x =
              (polynomial.prod (λ (m : ℕ), C (m + 1)) n).eval x *
              (polynomial.prod (λ (m : ℕ), X) n) *
              (polynomial.prod (λ (m : ℕ), X) n) ^ n, from by auto [eval_prod],
    have h8 : (polynomial.prod (λ (m : ℕ), C (m + 1)) n).eval x =
              (polynomial.prod (λ (m : ℕ), C (m + 1)) n).eval 0, from by auto [eval_prod_const],
    have h9 : (polynomial.prod (λ (m : ℕ), C (m + 1) * X^m) n).eval (1 + x) =
              (polynomial.prod (λ (m : ℕ), C (m + 1)) n).eval (1 + x) *
              (polynomial.prod (λ (m : ℕ), X^m) n).eval (1 + x), from by auto [eval_prod],
    have h10 : (polynomial.prod (λ (m : ℕ), C (m + 1) * X^(m + 1)) n).eval (1 + x) =
               (polynomial.prod (λ (m : ℕ), C (m + 1)) n).eval (1 + x) *
               (polynomial.prod (λ (m : ℕ), X) n) *
               (polynomial.prod (λ (m : ℕ), X) n) ^ n, from by auto [eval_prod],
    have h11 : (polynomial.prod (λ (m : ℕ), C (m + 1)) n).eval (1 + x) =
               (polynomial.prod (λ (m : ℕ), C (m + 1)) n).eval x +
               (polynomial.prod (λ (m : ℕ), C (m + 1)) n) *
               (polynomial.prod (λ (m : ℕ), C (m + 1)) n).eval x, from by auto [eval_prod],
    have h12 : (polynomial.prod (λ (m : ℕ), X^m) n).eval (1 + x) =
               (polynomial.prod (λ (m : ℕ), X^m) n).eval x, from by auto [eval_prod],
    have h13 : (polynomial.prod (λ (m : ℕ), X) n) ^ (n + 1) =
               (polynomial.prod (λ (m : ℕ), X) n) * (polynomial.prod (λ (m : ℕ), X) n) ^ n, from by auto [eval_prod],
    have h14 : (polynomial.prod (λ (m : ℕ), C (m + 1)) n) *
               (polynomial.prod (λ (m : ℕ), C (m + 1)) n).eval x =
               (polynomial.prod (λ (m : ℕ), C (m + 1)) n).eval x *
               (polynomial.prod (λ (m : ℕ), C (m + 1)) n), from by auto [eval_prod, mul_comm],
    have h15 : (polynomial.prod (λ (m : ℕ), C (m + 1)) n).eval x =
               polynomial.prod (λ (m : ℕ), C (m + 1)) n, from by auto [eval_prod_const],
    have h16 : (polynomial.prod (λ (m : ℕ), C (m + 1)) n) *
               (polynomial.prod (λ (m : ℕ), C (m + 1)) n).eval 0 =
               (polynomial.prod (λ (m : ℕ), C (m + 1)) n).eval 0 *
               (polynomial.prod (λ (m : ℕ), C (m + 1)) n), from by auto [eval_prod, mul_comm],
    have h17 : (polynomial.prod (λ (m : ℕ), C (m + 1)) n) *
               (polynomial.prod (λ (m : ℕ), C (m + 1)) n).eval x *
               (polynomial.prod (λ (m : ℕ), X^m) n).eval x =
               (polynomial.prod (λ (m : ℕ), C (m + 1) * X^m) n).eval x *
               (polynomial.prod (λ (m : ℕ), C (m + 1)) n), from by auto [eval_prod, mul_comm],
    have h18 : (polynomial.prod (λ (m : ℕ), C (m + 1)) n) *
               (polynomial.prod (λ (m : ℕ), C (m + 1)) n).eval 0 *
               (polynomial.prod (λ (m : ℕ), X^m) n).eval x =
               (polynomial.prod (λ (m : ℕ), C (m + 1) * X^m) n).eval 0 *
               (polynomial.prod (λ (m :
end --Needs more than 2000 tokens!

--OUTPUT 8
theorem bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1) :=
begin
  have h1 : ∀ (m : ℕ) (x : ℚ), m < n → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x ^ (m - 1),
  { assume m x h1,
    have h2 : ∀ k : ℕ, k ≤ m → (((C (1+x)) ^ (m - k))),
    { assume k h2,
      have h3 : (1 + x)^m = (C x)^m + m * (C x)^(m-1) * (C (1+x))^1, by simp [C, has_mul.one],
      rw has_pow.pow_eq_pow_of_nat_cast h2 at h3,
      have h4 : (1 + x) ^ (m - k) = (C x) ^ (m - k) + m * (C x) ^ (m - k - 1) * (C (1 + x)) ^ 1, from by simp [C, has_mul.one] at h3,
      exact h4,
    },
    have h3 : (polynomial.bernoulli m).eval (1 + x) = ∑ (k : ℕ) in finset.range m, (((C (1 + x)) ^ k) * C (mchoose k)), from by simp [C, has_mul.one],
    have h4 : (polynomial.bernoulli m).eval x = ∑ (k : ℕ) in finset.range m, ((C x ^ k) * C (mchoose k)), from by auto [C, has_mul.one] at h3,
    have h5 : (polynomial.bernoulli m).eval (1 + x) = ∑ (k : ℕ) in finset.range m, ((C x ^ k) * C (mchoose k) + m * C x ^ (k - 1) * C (mchoose k) * C (1 + x)), from by auto [C, has_mul.one] at h3 using [h2],
    have h6 : ∑ (k : ℕ) in finset.range m, (m * C x ^ (k - 1) * C (mchoose k) * C (1 + x)) = m * ∑ (k : ℕ) in finset.range m, (C x ^ (k - 1) * C (mchoose k) * C (1 + x)), from by auto [finset.sum_mul],
    have h7 : ∑ (k : ℕ) in finset.range m, (C x ^ (k - 1) * C (mchoose k) * C (1 + x)) = x ^ (m - 1), from by simp [C, has_mul.one] at h6,
    have h8 : m * (∑ (k : ℕ) in finset.range m, (C x ^ (k - 1) * C (mchoose k) * C (1 + x))) = m * x ^ (m - 1), from by auto at h7,
    have h9 : finset.sum finset.range m (λ (k : ℕ), C x ^ k * C (mchoose k) + m * C x ^ (k - 1) * C (mchoose k) * C (1 + x)) = finset.sum finset.range m (λ (k : ℕ), C x ^ k * C (mchoose k)) + m * x ^ (m - 1), from by rw finset.sum_add h4 h8,
    exact h9,
  },
  have h2 : ∀ (m : ℕ) (x : ℚ), m < n → (polynomial.bernoulli m).eval x = mchoose m, from by auto using [bernoulli_eval, nat.eq_zero_of_le_zero],
  have h3 : ∀ (m : ℕ) (x : ℚ), m < n →  mchoose m * x^(m - 1) = m * x^(m - 1), from by auto [mul_comm, nat.choose_eq_mul_succ_pred_div_succ, nat.one_mul],
  have h4 : ∀ (m : ℕ) (x : ℚ), m < n → (polynomial.bernoulli m).eval x + m * x ^ (m - 1) = mchoose m + m * x ^ (m - 1), from by auto [h2, h3],
  have h5 : ∀ (m : ℕ) (x : ℚ), m < n → (polynomial.bernoulli m).eval (1 + x) = mchoose m + m * x ^ (m - 1), from by auto [h1, h4],
  by_contradiction h6,
  have h7 : ∀ (m : ℕ) (x : ℚ), m < n → (polynomial.bernoulli m).eval (1 + x) + m * (1 + x) ^ (m - 1) = mchoose m + m * (1 + x) ^ (m - 1) + m * (1 + x) ^ (m - 1), from by auto [h5],
  have h8 : ∀ (m : ℕ) (x : ℚ), m < n → (polynomial.bernoulli m).eval (1 + x) + m * (1 + x) ^ (m - 1) = mchoose m + (1 + m) * (1 + x) ^ (m - 1), from by auto [mul_comm, one_mul, nat.add_comm] at h7,
  have h9 : ∀ (m : ℕ) (x : ℚ), m < n → ((polynomial.bernoulli m).eval (1 + x) + m * (1 + x) ^ (m - 1)) * ((C (1 + x)) ^ n) = (mchoose m + (1 + m) * (1 + x) ^ (m - 1)) * ((C (1 + x)) ^ n), from by auto at h8,
  have h10 : ∀ (m : ℕ) (x : ℚ), m < n → ∑ (k : ℕ) in finset.range m, (polynomial.bernoulli k).eval (1 + x) + k * (1 + x) ^ (k - 1) = (1 + x) ^ (m - 1) * ∑ (k : ℕ) in finset.range m, (1 + k) * (1 + x) ^ (k - 1), from by auto [C, has_mul.one] at h9,
  have h11 : ∀ (m : ℕ) (x : ℚ), m < n → ∑ (k : ℕ) in finset.range m, (polynomial.bernoulli k).eval (1 + x) + k * (1 + x) ^ (k - 1) * (C (1 + x)) ^ n = (1 + x) ^ (m - 1) * ∑ (k : ℕ) in finset.range m, (1 + k) * (1 + x) ^ (k - 1) * (C (1 + x)) ^ n, from by auto [nat.cast_one, one_mul, has_mul.one] at h10,
  have h12 : ∀ (m : ℕ) (x : ℚ), m < n → (1 + x)^m * ∑ (k : ℕ) in finset.range (m + 1), (((C (1 + x)) ^ k) * C (mchoose k)) = (1 + x) ^ (m - 1) * ∑ (k : ℕ) in finset.range m, (1 + k) * (1 + x) ^ (k - 1) * (C (1 + x)) ^ n, from by auto [C, has_mul.one] at h11,
  have h13 : ∀ (m : ℕ) (x : ℚ), m < n → (1 + x)^m * ∑ (k : ℕ) in finset.range (m + 1), ((
end --Needs more than 2000 tokens!

--OUTPUT 9
theorem bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1) :=
begin
  apply nat.strong_induction_on n,
  intros,
  split_ifs with h,
  rw [h, nat.sub_self, pow_zero, add_zero],
  have h2 := polynomial.bernoulli_succ_eq_one_add_eval a x,
  rw [h, diff_pow, diff_pow, h2],
  ring,
  rw [h, pow_one, pow_zero],
  ring,
  rw [h, pow_one, pow_zero, mul_one, add_zero],
  rw polynomial.eval₂_zero,
  rw polynomial.eval₂_zero,
  ring,
  rw [h, pow_zero],
  ring,
  rw polynomial.eval₂_zero,
  ring,
end

--OUTPUT 10
theorem bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1) :=
begin
  induction n with d hd,
  rw [nat.zero_eq_zero, polynomial.bernoulli, polynomial.bernoulli, polynomial.eval_C],
  simp,
  assume x rw [nat.one_eq_one, polynomial.bernoulli, polynomial.bernoulli, polynomial.eval_X, polynomial.eval_add, polynomial.eval_C, nat.one_eq_one],
  suffices h :
    polynomial.eval (of_nat (d + 1) * (X^d - X^d)) (1 + x) =
    polynomial.eval (of_nat (d + 1) * (X^d - X^d)) x + d * x ^ (d - 1),
  simp at h,
  exact h,
  rw [polynomial.eval_mul, polynomial.eval_add, polynomial.eval_neg, polynomial.eval_C, polynomial.eval_X],
  have h1 : (1 + x)^d - x^d = (1 - x) * ((1 + x) ^ (d - 1) + (1 + x) ^ (d - 2) * x + ... + x ^ (d - 1)),
  begin
    have h10 : (1 + x) ^ d - x ^ d = (1 + x) ^ (d - 1) * (1 + x - x),
    by simp [polynomial.add_mul, polynomial.mul_C, polynomial.mul_X_pow, polynomial.mul_one],
    have h11 : (1 + x - x) = (1 - x),
    by simp,
    rw [h11] at h10,
    rw h10,
    rw [nat.mul_one, mul_comm, mul_assoc],
    induction d with d hd,
    by simp,
    assume x,
    simp,
    assume x d hd,
    have h11 : x ^ (d - 1) + (1 + x) ^ (d - 1) * x = (1 + x) ^ (d - 1) * (1 + x),
    by rw [← add_mul, polynomial.add_C, polynomial.add_X_pow],
    have h12 : (1 + x) ^ d - x ^ d = (1 + x - x) * ((1 + x) ^ (d - 1) + (1 + x) ^ (d - 2) * x + ... + x ^ (d - 1)),
    by simp; rw [← mul_assoc, mul_assoc, mul_comm, mul_assoc, mul_assoc, mul_comm, add_mul, add_mul, ↑_root_.add, nat.mul_one, polynomial.C_1, polynomial.C_0, hd],
    rw h12,
    rw [mul_comm, h11, mul_add, mul_assoc, mul_comm, mul_assoc, ← add_mul, add_mul, ← add_mul, h11, ← add_assoc, mul_comm, mul_assoc],
    rw [← mul_add],
  end,
  rw h1,
  rw mul_comm,
  rw [mul_add, mul_assoc],
  rw [← polynomial.eval_add],
  suffices h2 : polynomial.eval (of_nat (d + 1) * ((1 - x) * (X ^ (d - 1) + X ^ (d - 2) * X + ... + X ^ 0))) (1 + x) = polynomial.eval (of_nat (d + 1) * ((1 - x) * (X ^ (d - 1) + X ^ (d - 2) * X + ... + X ^ 0))) x + polynomial.eval (of_nat (d + 1) * (1 - x) * (X ^ (d - 1))) x,
  begin
    rw mul_comm,
    rw [mul_add, mul_comm],
    rw add_comm,
  end,
  rw [← h2],
  rw add_comm,
  induction d with d hd,
  rw [nat.add_one, nat.zero_eq_zero, zero_add, polynomial.eval_C, polynomial.eval_C],
  simp,
  have h20 : polynomial.eval (of_nat (d + 2) * (1 - x) * (X ^ (d + 1) + X ^ d * X + ... + X ^ 0)) (1 + x) = polynomial.eval ((of_nat (d + 2) * (1 - x) * (X ^ (d + 1) + X ^ d * X + ... + X ^ 0)) + (of_nat (d + 2) * (1 - x) * (X ^ (d + 1)))) (1 + x),
  by simp,
  rw h20,
  have h21 : polynomial.eval (of_nat (d + 2) * (1 - x) * (X ^ (d + 1) + X ^ d * X + ... + X ^ 0)) x + polynomial.eval (of_nat (d + 2) * (1 - x) * (X ^ (d + 1))) x = polynomial.eval ((of_nat (d + 2) * (1 - x) * (X ^ (d + 1) + X ^ d * X + ... + X ^ 0)) + (of_nat (d + 2) * (1 - x) * (X ^ (d + 1)))) x,
  by simp,
  rw h21,
  rw [← polynomial.eval_add],
  rw [polynomial.C_add, polynomial.eval_add, polynomial.eval_mul],
  rw [polynomial.eval_add],
  rw polynomial.eval_C,
  rw polynomial.eval_mul,
  rw polynomial.eval_C,
  rw polynomial.eval_X,
  rw [→ mul_comm, mul_comm (d + 2), ← mul_add],
  rw add_comm,
  rw mul_assoc,
  rw [← polynomial.eval_add],
  have h22 : polynomial.eval (of_nat (d + 2) * ((1 - x) * (X ^ (d + 1) + X ^ d * X + ... + X ^ 0))) (1 + x) + polynomial.eval (of_nat (d + 2) * ((1 - x) * (X ^ (d + 1) + X ^ d * X + ... + X ^ 0))) x + polynomial.eval (of_nat (d + 2) * (1 - x) * (X ^ (d + 1))) x =
    polynomial.eval ((of_nat (d + 2) * (1 - x) * (X ^ (d + 1)))) (1 + x) + polynomial.eval ((of_nat (d + 2) * (1 - x) * (X ^ (d + 1) + X ^ d * X + ... + X ^ 0))) (1 + x) + polynomial.eval ((of_nat (d + 2) * (1 - x) * (X ^ (d + 1) + X ^ d * X + ... + X ^ 0))) x + polynomial.eval (of_nat (d + 2) * (1 - x) * (X ^ (d + 1))) x,
  by simp,
  rw h22,
  rw [← polynomial.eval_add],
  have h23 :
    polynomial.eval ((of_nat (d + 2) * (1 - x) * (X ^ (d + 1)))) (1 + x) =
    polynomial.eval ((of_nat (d + 2) * (1 - x) * (X ^ (d + 1)))) x +
    polynomial.eval (of_nat (d + 2) * (1 - x) * X ^ (d + 1)) x,
  by rw [polynomial.eval_mul, po
end --Needs more than 2000 tokens!

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

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

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

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

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

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

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

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

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

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

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

Setting $b = a$, this becomes:

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

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

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

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

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

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

/--`theorem`
Bernoulli polynomial evaluation
Given a natural number $n$ and a rational $x$, let $B_n (x)$ denote the $n$-th Bernoulli polynomial evaluated at $x$. Then, $$B_n (1 + x) = B_n (x) + n x^{n - 1}$$
`proof`
We apply strong induction on $n$. So, for all $m < d$, we have $B_{m} (1 + x) = B_{m} (x) + m x^{m - 1}$ and we want to show that $$B_{d} (1 + x) = B_{d} (x) + d x^{d - 1}$$
Multiplying both sides by $d + 1$, and using the fact that, for all $l \in \mathbb{N}$, $\sum_{k = 0}^{l} {l + 1 \choose k} B_k = (l + 1) X^l$ (where $B_k$ is the $k$-th Bernoulli number), we get that
$$ (d + 1) (1 + x)^d - (d + 1) x^d = \sum_{l = 0}^{d} {d + 1 \choose l} l x^{l - 1} $$
The conclusion then follows easily.

QED

-/
theorem  bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1) :=
FEW SHOT PROMPTS TO CODEX(END)-/


import for_mathlib.algebra.homology.trunc
import for_mathlib.category_theory.localization.shift

noncomputable theory

open category_theory category_theory.category category_theory.limits
open_locale zero_object

namespace category_theory

instance ess_surj_comp {C₁ C₂ C₃ : Type*} [category C₁] [category C₂] [category C₃] (F : C₁ ⥤ C₂)
  [ess_surj F] (G : C₂ ⥤ C₃) [ess_surj G] : ess_surj (F ⋙ G) :=
⟨λ Z, ⟨_, ⟨G.map_iso (F.obj_obj_preimage_iso (G.obj_preimage Z)) ≪≫ G.obj_obj_preimage_iso Z⟩⟩⟩

instance ess_surj_Q {C : Type*} [category C] (W : morphism_property C) :
  ess_surj (W.Q) :=
localization.ess_surj W.Q W

lemma full_of_comp_ess_surj {C D E : Type*} [category C] [category D] [category E]
  (F : C ⥤ D) (G : D ⥤ E) [ess_surj F]
  (h : ∀ (X Y : C), function.surjective (λ (f : F.obj X ⟶ F.obj Y), G.map f)) : full G :=
G.full_of_surjective (λ K₁ K₂ f, begin
  let K'₁ := F.obj_preimage K₁,
  let K'₂ := F.obj_preimage K₂,
  let e₁ : F.obj K'₁ ≅ K₁ := F.obj_obj_preimage_iso K₁,
  let e₂ : F.obj K'₂ ≅ K₂ := F.obj_obj_preimage_iso K₂,
  obtain ⟨f', hf'⟩ := h K'₁ K'₂ (G.map e₁.hom ≫ f ≫ G.map e₂.inv),
  dsimp at hf',
  refine ⟨e₁.inv ≫ f' ≫ e₂.hom, _⟩,
  simp only [G.map_comp, hf', assoc],
  rw [← G.map_comp, e₂.inv_hom_id, G.map_id, comp_id, ← G.map_comp_assoc, e₁.inv_hom_id, G.map_id,
    id_comp],
end)

lemma faithful_of_comp_ess_surj {C D E : Type*} [category C] [category D] [category E]
  (F : C ⥤ D) (G : D ⥤ E) [ess_surj F]
  (h : ∀ (X Y : C), function.injective (λ (f : F.obj X ⟶ F.obj Y), G.map f)) : faithful G :=
⟨λ K₁ K₂ f₁ f₂ hf, begin
  let K'₁ := F.obj_preimage K₁,
  let K'₂ := F.obj_preimage K₂,
  let e₁ : F.obj K'₁ ≅ K₁ := F.obj_obj_preimage_iso K₁,
  let e₂ : F.obj K'₂ ≅ K₂ := F.obj_obj_preimage_iso K₂,
  rw [← cancel_mono e₂.inv, ← cancel_epi e₁.hom],
  apply h,
  dsimp,
  simp only [hf, functor.map_comp],
end⟩

end category_theory

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

namespace derived_category

instance zero_is_le (n : ℤ) : (0 : derived_category C).is_le n :=
⟨λ i hi, is_zero.of_iso (is_zero_zero _)
  (derived_category.homology_functor C i).map_zero_object⟩

instance zero_is_ge (n : ℤ) : (0 : derived_category C).is_ge n :=
⟨λ i hi, is_zero.of_iso (is_zero_zero _)
  (derived_category.homology_functor C i).map_zero_object⟩

def is_plus (K : derived_category C) : Prop := ∃ (n : ℤ), K.is_ge n

def is_minus (K : derived_category C) : Prop := ∃ (n : ℤ), K.is_le n

variable (C)
open category_theory.triangulated

instance plus_is_triangulated_subcategory :
  is_triangulated_subcategory (λ (K : derived_category C), K.is_plus) :=
{ zero := ⟨0, infer_instance⟩,
  shift := begin
    rintros K k ⟨n, hn⟩,
    haveI := hn,
    exact ⟨n-k, shift_is_ge K n k (n-k) (by linarith)⟩,
  end,
  ext₂ := begin
    rintros T hT ⟨n₁, hn₁⟩ ⟨n₃, hn₃⟩,
    exact ⟨min n₁ n₃,
      ⟨λ n hn, short_complex.exact.is_zero_of_both_zeros (homology_sequence.ex₂ hT n)
        (is_zero.eq_of_src (hn₁.is_zero' _ (lt_of_lt_of_le hn (min_le_left n₁ n₃))) _ _)
        (is_zero.eq_of_tgt (hn₃.is_zero' _ (lt_of_lt_of_le hn (min_le_right n₁ n₃))) _ _)⟩⟩,
  end, }

abbreviation plus := full_subcategory (λ (K : derived_category C), K.is_plus)
abbreviation minus := full_subcategory (λ (K : derived_category C), K.is_minus)

namespace plus

instance : pretriangulated (plus C) := infer_instance

variable {C}

def mk (K : derived_category C) (n : ℤ) [hn : K.is_ge n] :
  derived_category.plus C :=
⟨K, n, hn⟩

def mk' (K : derived_category C) (hK : K.is_plus) :
  derived_category.plus C :=
⟨K, hK⟩

abbreviation ι : plus C ⥤ derived_category C :=
full_subcategory_inclusion _

end plus

end derived_category

namespace cochain_complex

def is_plus (K : cochain_complex C ℤ) : Prop :=
  ∃ (n : ℤ), K.is_strictly_ge n

def is_minus (K : cochain_complex C ℤ) : Prop :=
  ∃ (n : ℤ), K.is_strictly_le n

lemma is_plus.Q {K : cochain_complex C ℤ} (h : K.is_plus) :
  (derived_category.Q.obj K).is_plus :=
begin
  obtain ⟨n, hn⟩ := h,
  haveI := hn,
  exact ⟨n, infer_instance⟩,
end

instance zero_is_strictly_ge (n : ℤ) : is_strictly_ge (0 : cochain_complex C ℤ) n :=
⟨λ k hk, is_zero.of_iso (is_zero_zero _)
  (homological_complex.eval C (complex_shape.up ℤ) k).map_zero_object⟩

instance zero_is_strictly_le (n : ℤ) : is_strictly_le (0 : cochain_complex C ℤ) n :=
⟨λ k hk, is_zero.of_iso (is_zero_zero _)
  (homological_complex.eval C (complex_shape.up ℤ) k).map_zero_object⟩

lemma mapping_cone_is_strictly_le {K L : cochain_complex C ℤ} (f : K ⟶ L) (n k l : ℤ)
  [K.is_strictly_le k] [L.is_strictly_le l] (hk : k ≤ n+1) (hl : l ≤ n) :
  (mapping_cone f).is_strictly_le n :=
⟨λ i hi, begin
  simp only [mapping_cone.X_is_zero_iff],
  split,
  { exact is_strictly_le.is_zero K k (i+1) (by linarith), },
  { exact is_strictly_le.is_zero L l i (by linarith), },
end⟩

lemma mapping_cone_is_strictly_ge {K L : cochain_complex C ℤ} (f : K ⟶ L) (n k l : ℤ)
  [K.is_strictly_ge k] [L.is_strictly_ge l] (hk : n+1 ≤ k) (hl : n ≤ l) :
  (mapping_cone f).is_strictly_ge n :=
⟨λ i hi, begin
  simp only [mapping_cone.X_is_zero_iff],
  split,
  { exact is_strictly_ge.is_zero K k (i+1) (by linarith), },
  { exact is_strictly_ge.is_zero L l i (by linarith), },
end⟩

lemma mapping_cone_is_plus {K L : cochain_complex C ℤ} (f : K ⟶ L)
  (hK : K.is_plus) (hL : L.is_plus) : (mapping_cone f).is_plus :=
begin
  obtain ⟨k, hK⟩ := hK,
  obtain ⟨l, hL⟩ := hL,
  haveI := hK,
  haveI := hL,
  exact ⟨min (k-1) l, mapping_cone_is_strictly_ge f _ k l
    (by linarith [min_le_left (k-1) l]) (min_le_right _ _)⟩,
end

variable (C)
abbreviation plus :=
full_subcategory (λ (K : cochain_complex C ℤ), cochain_complex.is_plus K)
abbreviation minus :=
full_subcategory (λ (K : cochain_complex C ℤ), cochain_complex.is_minus K)

namespace plus

variable {C}

abbreviation ι : plus C ⥤ cochain_complex C ℤ :=
full_subcategory_inclusion _

variable (C)

def shift_functor (k : ℤ) : plus C ⥤ plus C :=
full_subcategory.lift _ (ι ⋙ shift_functor _ k) (λ K, begin
  obtain ⟨n, hn⟩ := K.2,
  haveI := hn,
  refine ⟨n-k, _⟩,
  dsimp,
  exact shift_is_strict_ge K.1 n k (n-k) (by linarith),
end)

instance : has_shift (plus C) ℤ :=
has_shift_of_fully_faithful ι (shift_functor C)
  (λ n, full_subcategory.lift_comp_inclusion _ _ _)

end plus

namespace minus

variable {C}

abbreviation ι : minus C ⥤ cochain_complex C ℤ :=
full_subcategory_inclusion _

end minus

end cochain_complex

open category_theory.triangulated

namespace homotopy_category

variable (C)

def is_plus : set (homotopy_category C (complex_shape.up ℤ)) :=
λ K, cochain_complex.is_plus K.1

abbreviation plus :=
full_subcategory (homotopy_category.is_plus C)

instance plus_is_triangulated_subcategory' :
  category_theory.triangulated.is_triangulated_subcategory' (is_plus C) :=
{ zero := begin
    refine ⟨⟨0⟩, _, ⟨0, infer_instance⟩⟩,
    rw is_zero.iff_id_eq_zero,
    change (homotopy_category.quotient _ _).map (𝟙 0) = 0,
    simp only [id_zero, functor.map_zero],
  end,
  shift := begin
    rintro ⟨X⟩ n hX,
    exact ((cochain_complex.plus.shift_functor C n).obj ⟨X, hX⟩).2,
  end,
  distinguished_cocone_triangle' := begin
    rintro ⟨X⟩ ⟨Y⟩ hX hY ⟨f : X ⟶ Y⟩,
    refine ⟨_, _, _, _, ⟨_, _, f, ⟨iso.refl _⟩⟩⟩,
    exact cochain_complex.mapping_cone_is_plus f hX hY,
  end, }

namespace plus

variable {C}

abbreviation ι : plus C ⥤ homotopy_category C (complex_shape.up ℤ) :=
full_subcategory_inclusion _

variable (C)

abbreviation homology_functor (n : ℤ) : plus C ⥤ C :=
ι ⋙ homotopy_category.homology_functor C (complex_shape.up ℤ) n

def shift_homology_functor_iso (n k m : ℤ) (h : k + n = m):
  shift_functor _ n ⋙ homology_functor C k ≅ homology_functor C m :=
(functor.associator _ _ _).symm ≪≫ iso_whisker_right (ι.comm_shift_iso n) _ ≪≫
  functor.associator _ _ _ ≪≫
  iso_whisker_left ι (homotopy_category.shift_homology_functor_iso C n k m h)

instance : pretriangulated (plus C) :=
is_triangulated_subcategory'.pretriangulated_full_subcategory _

--instance : is_triangulated (plus C) := infer_instance

abbreviation acyclic : set (plus C) :=
(homology_functor C 0).kernel_of_is_homological

--instance : saturated (acyclic C) := infer_instance

variable {C}

lemma mem_acyclic_W_iff {K L : plus C} (φ : K ⟶ L) :
  (subcategory.W (acyclic C)) φ ↔ ∀ (n : ℤ), is_iso ((homology_functor C n).map φ) :=
by simpa only [functor.kernel_of_is_homological_W,
  ← λ n, nat_iso.is_iso_map_iff (shift_homology_functor_iso C _ _ _ (zero_add n)) φ]

variable (C)

lemma homology_functor_is_inverted_by (n : ℤ) :
  (subcategory.W (acyclic C)).is_inverted_by (homology_functor C n) :=
λ K L f hf, begin
  rw mem_acyclic_W_iff f at hf,
  exact hf n,
end

variable {C}

lemma mem_W_iff_ι_map_mem {K L : homotopy_category.plus C} (f : K ⟶ L) :
  subcategory.W (homotopy_category.acyclic C) (homotopy_category.plus.ι.map f) ↔
  subcategory.W (homotopy_category.plus.acyclic C) f :=
by simpa only [homotopy_category.mem_acyclic_W_iff, homotopy_category.plus.mem_acyclic_W_iff]

variable (C)

def single_functor (n : ℤ) : C ⥤ homotopy_category.plus C :=
full_subcategory.lift _ (homological_complex.single C (complex_shape.up ℤ) n ⋙
  homotopy_category.quotient _ _) (λ X, ⟨n, by { dsimp, apply_instance, }⟩)

def single_functor_factors (n : ℤ) :
  single_functor C n ⋙ homotopy_category.plus.ι ≅
  (homological_complex.single C (complex_shape.up ℤ) n ⋙ homotopy_category.quotient _ _) :=
full_subcategory.lift_comp_inclusion _ _ _

instance single_functor_additive (n : ℤ) : (single_functor C n).additive :=
⟨λ K L f₁ f₂, homotopy_category.plus.ι.map_injective begin
  dsimp only [single_functor],
  simp only [full_subcategory.lift_map, functor.map_add],
end⟩

end plus

end homotopy_category

namespace derived_category

namespace plus

abbreviation Qh : homotopy_category.plus C ⥤ derived_category.plus C :=
full_subcategory.lift _ (homotopy_category.plus.ι ⋙ derived_category.Qh)
begin
  rintro ⟨⟨K⟩, n, hn⟩,
  refine ⟨n, (_ : (Q.obj K).is_ge n)⟩,
  rw ← cochain_complex.is_ge_iff_Q_obj_is_ge,
  dsimp at hn,
  haveI := hn,
  exact cochain_complex.is_ge_of_is_strictly_ge K n,
end

variable (C)

def Qh_comp_ι_iso : (Qh : _ ⥤ derived_category.plus C) ⋙ derived_category.plus.ι ≅
  homotopy_category.plus.ι ⋙ derived_category.Qh :=
full_subcategory.lift_comp_inclusion _ _ _

namespace Qh_is_localization

lemma inverts :
  (subcategory.W (homotopy_category.plus.acyclic C)).is_inverted_by Qh :=
λ K L f hf, begin
  haveI : is_iso (derived_category.plus.ι.map (Qh.map f)),
  { erw [is_iso_map_iff_of_nat_iso (Qh_comp_ι_iso C) f],
    dsimp only [functor.comp_map],
    apply localization.inverts derived_category.Qh (subcategory.W (homotopy_category.acyclic C)),
    simpa only [homotopy_category.plus.mem_W_iff_ι_map_mem] using hf, },
  exact is_iso_of_reflects_iso (Qh.map f) ι,
end

abbreviation L := localization.lift _ (inverts C) (subcategory.W (homotopy_category.plus.acyclic C)).Q

def L_iso : (subcategory.W (homotopy_category.plus.acyclic C)).Q ⋙ L C ≅ Qh :=
localization.lifting.iso (subcategory.W (homotopy_category.plus.acyclic C)).Q
  (subcategory.W (homotopy_category.plus.acyclic C)) _ _

lemma full_L : full (L C) :=
begin
  let F := (subcategory.W (homotopy_category.plus.acyclic C)).Q,
  haveI := localization.ess_surj F
    (subcategory.W (homotopy_category.plus.acyclic C)), -- should be an instance
  have hF : (subcategory.W (homotopy_category.plus.acyclic C)).is_inverted_by F :=
    localization.inverts _ _,
  apply category_theory.full_of_comp_ess_surj F,
  rintros ⟨⟨K₁ : cochain_complex C ℤ⟩, hK₁⟩ ⟨⟨K₂ : cochain_complex C ℤ⟩, hK₂⟩ f,
  have hK₁' := hK₁,
  have hK₂' := hK₂,
  obtain ⟨n₁, hn₁⟩ := hK₁',
  obtain ⟨n₂, hn₂⟩ := hK₂',
  let n := min n₁ n₂,
  haveI : K₁.is_strictly_ge n,
  { haveI := hn₁, exact cochain_complex.is_strictly_ge_of_le _ _ _ (min_le_left n₁ n₂), },
  haveI : K₂.is_strictly_ge n,
  { haveI := hn₂, exact cochain_complex.is_strictly_ge_of_le _ _ _ (min_le_right n₁ n₂), },
  let f' : Qh.obj ⟨⟨K₁⟩, hK₁⟩ ⟶ Qh.obj ⟨⟨K₂⟩, hK₂⟩ :=
    (L_iso C).inv.app _ ≫ f ≫ (L_iso C).hom.app _,
  let f'' : derived_category.Q.obj K₁ ⟶ derived_category.Q.obj K₂ := f',
  obtain ⟨K₃, hK₃', s, g, hs, fac⟩ := right_factorisation_of_is_strictly_ge f'' n,
  replace fac := (Q.map s) ≫= fac,
  rw is_iso.hom_inv_id_assoc at fac,
  haveI := hK₃',
  haveI := hs,
  have hK₃ : homotopy_category.is_plus C ⟨K₃⟩ := ⟨n, hK₃'⟩,
  let s' : (⟨_, hK₃⟩ : homotopy_category.plus C) ⟶ ⟨_, hK₁⟩ := (homotopy_category.quotient _ _).map s,
  let g' : (⟨_, hK₃⟩ : homotopy_category.plus C) ⟶ ⟨_, hK₂⟩ := (homotopy_category.quotient _ _).map g,
  haveI : is_iso (F.map s') := hF _ begin
    rw ← homotopy_category.plus.mem_W_iff_ι_map_mem,
    erw homotopy_category.map_quotient_W_iff,
    exact hs,
  end,
  refine ⟨inv (F.map s') ≫ F.map g', _⟩,
  dsimp only,
  erw [functor.map_comp, ← cancel_epi ((L C).map (F.map s')), ← functor.map_comp_assoc,
    is_iso.hom_inv_id, (L C).map_id, id_comp, ← cancel_epi ((L_iso C).inv.app ⟨_, hK₃⟩),
    ← (L_iso C).inv.naturality g', ← fac],
  dsimp only [f'', f'],
  erw [assoc, ← (L_iso C).inv.naturality_assoc s'],
  dsimp,
  conv_lhs { congr, skip, erw assoc, congr, skip, erw assoc, },
  erw [(L_iso C).hom_inv_id_app, comp_id],
  refl,
end

instance faithful_L : faithful (L C) :=
begin
  let F := (subcategory.W (homotopy_category.plus.acyclic C)).Q,
  haveI := localization.ess_surj F
    (subcategory.W (homotopy_category.plus.acyclic C)), -- should be an instance
  have hF : (subcategory.W (homotopy_category.plus.acyclic C)).is_inverted_by F :=
    localization.inverts _ _,
  apply category_theory.faithful_of_comp_ess_surj F,
  rintros ⟨⟨K₁ : cochain_complex C ℤ⟩, hK₁⟩ ⟨⟨K₂ : cochain_complex C ℤ⟩, hK₂⟩,
  suffices : ∀ (f : F.obj {obj := {as := K₁}, property := hK₁} ⟶ F.obj {obj := {as := K₂}, property := hK₂})
    (hf : (L C).map f = 0), f = 0,
  { intros f₁ f₂ hf,
    rw [← sub_eq_zero],
    apply this,
    simpa only [functor.map_sub, sub_eq_zero] using hf, },
  intros f hf,
  obtain ⟨⟨⟨⟨K₁'⟩, hK₁'⟩, s, g, hs⟩, hz⟩ := right_calculus_of_fractions.L_map_fac F
    (subcategory.W (homotopy_category.plus.acyclic C)) f,
  dsimp [right_calculus_of_fractions.map_roof] at hz,
  simp only [hz, preadditive.is_iso.comp_left_eq_zero],
  obtain ⟨g, rfl⟩ := (homotopy_category.quotient _ _).map_surjective g,
  let g' : (⟨⟨K₁'⟩, hK₁'⟩ : homotopy_category.plus C) ⟶ ⟨⟨K₂⟩, hK₂⟩ :=
    (homotopy_category.quotient _ _).map g,
  have hg : derived_category.Qh.map g' = derived_category.Qh.map 0,
  { rw [hz, functor.map_comp, preadditive.is_iso.comp_left_eq_zero] at hf,
    simpa only [functor.comp_map, functor.map_zero, hf, zero_comp,
      preadditive.is_iso.comp_left_eq_zero] using ((L_iso C).hom.naturality g').symm, },
  rw left_calculus_of_fractions.L_map_eq_iff derived_category.Qh
    (subcategory.W (homotopy_category.acyclic C)) at hg,
  obtain ⟨⟨K₂' : cochain_complex C ℤ⟩, s, hs, fac⟩ := hg,
  obtain ⟨s, rfl⟩ := (homotopy_category.quotient _ _).map_surjective s,
  have hK₂' := hK₂,
  obtain ⟨n, hn : K₂.is_strictly_ge n⟩ := hK₂',
  rw zero_comp at fac,
  let t : (⟨⟨K₂⟩, hK₂⟩ : homotopy_category.plus C) ⟶ ⟨⟨K₂'.trunc_ge n⟩, ⟨n, infer_instance⟩⟩ :=
    (homotopy_category.quotient _ _).map (s ≫ cochain_complex.trunc_ge.π K₂' n),
  haveI : is_iso (F.map t),
  { apply hF,
    erw [← homotopy_category.plus.mem_W_iff_ι_map_mem, homotopy_category.map_quotient_W_iff],
    haveI : quasi_iso s,
    { simpa only [← homotopy_category.map_quotient_W_iff] using hs, },
    haveI : quasi_iso (cochain_complex.trunc_ge.π K₂' n),
    { rw [cochain_complex.quasi_iso_trunc_ge_π_iff, ← cochain_complex.is_ge_iff_of_quasi_iso s],
      apply_instance, },
    apply_instance, },
  simp only [← cancel_mono (F.map t), zero_comp, ← F.map_comp, ← F.map_zero],
  congr' 1,
  dsimp [t],
  erw [functor.map_comp, ← assoc, fac, zero_comp],
end

instance : ess_surj (L C) :=
⟨begin
  rintro ⟨K, hK⟩,
  let K' := Q.obj_preimage K,
  let e : Q.obj K' ≅ K := Q.obj_obj_preimage_iso K,
  obtain ⟨n, hn⟩ := hK,
  haveI := hn,
  haveI := (cochain_complex.is_ge_iff_Q_obj_is_ge K' n).2 (derived_category.is_ge.of_iso e.symm n),
  exact ⟨(morphism_property.Q _).obj ⟨⟨K'.trunc_ge n⟩, ⟨n, infer_instance⟩⟩,
    ⟨derived_category.plus.ι.preimage_iso (ι.map_iso ((L_iso C).app _) ≪≫
      (as_iso (Q.map (cochain_complex.trunc_ge.π K' n))).symm ≪≫ e)⟩⟩,
end⟩

lemma is_equivalence : is_equivalence (L C) :=
begin
  haveI := full_L C,
  exact equivalence.of_fully_faithfully_ess_surj _
end

instance : ess_surj (Qh : _ ⥤ derived_category.plus C) :=
ess_surj.of_iso (L_iso C)

end Qh_is_localization

instance Qh_is_localization :
  (Qh : _ ⥤ derived_category.plus C).is_localization
  (triangulated.subcategory.W (homotopy_category.plus.acyclic C)) :=
begin
  haveI := Qh_is_localization.is_equivalence C,
  refine functor.is_localization.of_equivalence
    (triangulated.subcategory.W (homotopy_category.plus.acyclic C)).Q
    (triangulated.subcategory.W (homotopy_category.plus.acyclic C)) Qh
    (Qh_is_localization.L C).as_equivalence _,
  dsimp only [functor.as_equivalence],
  exact localization.lifting.iso _ (subcategory.W (homotopy_category.plus.acyclic C)) _ _,
end

abbreviation single_functor (n : ℤ) : C ⥤ derived_category.plus C :=
homotopy_category.plus.single_functor C n ⋙ derived_category.plus.Qh

def homology_functor (n : ℤ) : derived_category.plus C ⥤ C :=
derived_category.plus.ι ⋙ derived_category.homology_functor C n

instance homology_functor_additive (n : ℤ) : (homology_functor C n).additive :=
by { dsimp only [homology_functor], apply_instance, }

instance homology_functor_is_homological (n : ℤ) : (homology_functor C n).is_homological :=
by { dsimp only [homology_functor], apply_instance, }

variable {C}

def triangle_of_ses {S : short_complex (cochain_complex C ℤ)} (ex : S.short_exact)
  (h₁ : S.X₁.is_plus) (h₂ : S.X₂.is_plus) (h₃ : S.X₃.is_plus) :
    pretriangulated.triangle (derived_category.plus C) :=
pretriangulated.full_subcategory_lift_triangle _ (derived_category.triangle_of_ses ex)
  h₁.Q h₂.Q h₃.Q

lemma triangle_of_ses_dist {S : short_complex (cochain_complex C ℤ)} (ex : S.short_exact)
  (h₁ : S.X₁.is_plus) (h₂ : S.X₂.is_plus) (h₃ : S.X₃.is_plus) :
  triangle_of_ses ex h₁ h₂ h₃ ∈ dist_triang (derived_category.plus C) :=
begin
  change (full_subcategory_inclusion _).map_triangle.obj (triangle_of_ses ex h₁ h₂ h₃)
    ∈ dist_triang (derived_category C),
  refine pretriangulated.isomorphic_distinguished _ (derived_category.triangle_of_ses_dist ex) _
    (pretriangulated.full_subcategory_lift_triangle_iso derived_category.is_plus
    (derived_category.triangle_of_ses ex) _ _ _),
end

end plus

end derived_category


import data.cpi.semantics.interaction_tensor data.cpi.transition
import tactic.abel

namespace cpi

variables {ℂ ℍ : Type} {ω : context} [half_ring ℂ] [decidable_eq ℂ]

/-- Maps a potential transition to the interaction space. -/
def potential_interaction_space [cpi_equiv ℍ ω] {Γ} {ℓ : lookup ℍ ω Γ} {A : prime_species ℍ ω Γ}
  : transition.transition_from ℓ A.val
  → interaction_space ℂ ℍ ω Γ
| ⟨ _, # a , @production.concretion _ _ _ b y G, tr ⟩ := fin_fn.single ⟨ ⟦ A ⟧, ⟨ b, y, ⟦ G ⟧ ⟩, a ⟩ 1
| ⟨ _, τ@'_, E, tr ⟩ := 0
| ⟨ _, τ⟨_⟩, E, tr ⟩ := 0

lemma potential_interaction_space.equiv [cpi_equiv ℍ ω] {Γ} {ℓ : lookup ℍ ω Γ}
    {A B : prime_species ℍ ω Γ} :
  ∀ {k} {α : label ℍ Γ k} {E E' : production ℍ ω Γ k}
    {t : A.val [ℓ, α]⟶ E} {t' : B.val [ℓ, α]⟶ E'}
  , A ≈ B → E ≈ E'
  → @potential_interaction_space ℂ ℍ ω _ _ _ Γ ℓ _ (transition.transition_from.mk t)
  = potential_interaction_space (transition.transition_from.mk t')
| _ (# a) (@production.concretion _ _ _ b y E) (production.concretion E') t t' eqA (production.equiv.concretion eqE) := begin
  unfold transition.transition_from.mk potential_interaction_space,
  have : ⟦ A ⟧ = ⟦ B ⟧ := quot.sound eqA,
  have : ⟦ E ⟧ = ⟦ E' ⟧ := quot.sound eqE,
  rw [‹⟦ A ⟧ = ⟦ B ⟧›, ‹⟦ E ⟧ = ⟦ E' ⟧›],
end
| _ (τ@'_) E E' t t' _ _ := rfl
| _ (τ⟨_⟩) E E' t t' _ _ := rfl

/-- Compute the potential interaction space for all transitions from a prime species. -/
def potential_interaction_space.from_prime [cpi_equiv ℍ ω] {Γ} (ℓ : lookup ℍ ω Γ) (A : prime_species ℍ ω Γ)
  : interaction_space ℂ ℍ ω Γ
  := finset.sum (fintype.elems (transition.transition_from ℓ A.val)) potential_interaction_space

/-- Compute the potential interaction space for all transitions from a species's prime conponents. -/
def potential_interaction_space.from_species [cpi_equiv ℍ ω] {Γ} (ℓ : lookup ℍ ω Γ) (A : species ℍ ω Γ)
  : interaction_space ℂ ℍ ω Γ
  := (cpi_equiv.prime_decompose A).sum' (potential_interaction_space.from_prime ℓ)

/-- `potential_interaction_space.from_species`, lifted to quotients. -/
def potential_interaction_space.from_species' [cpi_equiv_prop ℍ ω] {Γ} (ℓ : lookup ℍ ω Γ) (A : species' ℍ ω Γ)
  : interaction_space ℂ ℍ ω Γ := (cpi_equiv.prime_decompose' A).sum' (λ B, quot.lift_on B
    (potential_interaction_space.from_prime ℓ)
    (λ B₁ B₂ equ, begin
      cases cpi_equiv_prop.transition_iso ℓ equ with iso,
      let isoF := cpi_equiv_prop.transition_from_iso iso,
      suffices : ∀ x
        , (@potential_interaction_space ℂ ℍ ω _ _ _ _ ℓ _ x)
        = potential_interaction_space (isoF.to_fun x),
        from fintype.sum_iso _ _ isoF this,

      rintros ⟨ k, α, E, t ⟩,
      simp only [
        isoF, cpi_equiv_prop.transition_from_iso,
        cpi_equiv.transition_from_fwd, cpi_equiv.transition_from_inv],
      have eqE := (iso k α).2 E t,
      cases ((iso k α).fst).to_fun ⟨E, t⟩ with E' t',
      from potential_interaction_space.equiv equ eqE,
    end))

lemma potential_interaction_space.species_eq [cpi_equiv_prop ℍ ω] {Γ} {ℓ : lookup ℍ ω Γ} {A : species ℍ ω Γ}
  : (potential_interaction_space.from_species ℓ A : interaction_space ℂ ℍ ω Γ)
  = potential_interaction_space.from_species' ℓ ⟦ A ⟧
  := by simp only
    [potential_interaction_space.from_species, potential_interaction_space.from_species',
     quot.lift_on, quotient.mk, cpi_equiv.prime_decompose', multiset.sum',
     function.comp, multiset.map_map]

/-- Maps a spontaneous/immediate transition to a process space.

    This computes the Σ[x ∈ B [τ@k]—→ C] k and Σ[x ∈ B [τ⟨ a, b ⟩]—→ C] M(a, b)
    components of the definition of d(c ◯ A)/dt. -/
def immediate_process_space [cpi_equiv ℍ ω] {Γ} {ℓ : lookup ℍ ω Γ} (conc : ℍ ↪ ℂ)
    {A : prime_species ℍ ω Γ}
  : transition.transition_from ℓ A.val
  → process_space ℂ ℍ ω Γ
| ⟨ _, # a , _, tr ⟩ := 0
| ⟨ _, τ@'k, production.species B, tr ⟩ :=
  conc k • (to_process_space ⟦ B ⟧ - fin_fn.single ⟦ A ⟧ 1)
| ⟨ _, τ⟨ n ⟩, _, tr ⟩ := 0

lemma immediate_process_space.equiv [cpi_equiv ℍ ω] {Γ} {ℓ : lookup ℍ ω Γ} {conc : ℍ ↪ ℂ}
    {A B : prime_species ℍ ω Γ} :
  ∀ {k} {α : label ℍ Γ k} {E E' : production ℍ ω Γ k}
    {t : A.val [ℓ, α]⟶ E} {t' : B.val [ℓ, α]⟶ E'}
  , A ≈ B → E ≈ E'
  → immediate_process_space conc (transition.transition_from.mk t)
  = immediate_process_space conc (transition.transition_from.mk t')
| _ (# a ) E E' t t' eqA eqE := rfl
| _ (τ@'k) (production.species E) (production.species E') t t' eqA (production.equiv.species eqE) := begin
  unfold transition.transition_from.mk immediate_process_space,
  have : ⟦ A ⟧ = ⟦ B ⟧ := quot.sound eqA,
  have : ⟦ E ⟧ = ⟦ E' ⟧ := quot.sound eqE,
  rw [‹⟦ A ⟧ = ⟦ B ⟧›, ‹⟦ E ⟧ = ⟦ E' ⟧›],
end
| _ (τ⟨ n ⟩) E E' t t' eqA eqE := rfl

/-- Compute the immediate process space for all transitions from a prime species. -/
def immediate_process_space.from_prime [cpi_equiv ℍ ω] {Γ} (conc : ℍ ↪ ℂ) (ℓ : lookup ℍ ω Γ)
    (A : prime_species ℍ ω Γ)
  : process_space ℂ ℍ ω Γ
  := finset.sum (fintype.elems (transition.transition_from ℓ A.val)) (immediate_process_space conc)

/-- Compute the immediate process space for all transitions from a species's prime conponents. -/
def immediate_process_space.from_species [cpi_equiv ℍ ω] {Γ} (conc : ℍ ↪ ℂ) (ℓ : lookup ℍ ω Γ) (A : species ℍ ω Γ)
  : process_space ℂ ℍ ω Γ
  := (cpi_equiv.prime_decompose A).sum' (immediate_process_space.from_prime conc ℓ)

/-- `immediate_process_space.from_species`, lifted to quotients. -/
def immediate_process_space.from_species' [cpi_equiv_prop ℍ ω] {Γ} (conc : ℍ ↪ ℂ) (ℓ : lookup ℍ ω Γ) (A : species' ℍ ω Γ)
  : process_space ℂ ℍ ω Γ := (cpi_equiv.prime_decompose' A).sum' (λ B, quot.lift_on B
    (immediate_process_space.from_prime conc ℓ)
    (λ B₁ B₂ equ, begin
      cases cpi_equiv_prop.transition_iso ℓ equ with iso,
      let isoF := cpi_equiv_prop.transition_from_iso iso,
      suffices : ∀ x
        , immediate_process_space conc x
        = immediate_process_space conc (isoF.to_fun x),
        from fintype.sum_iso _ _ isoF this,

      rintros ⟨ k, α, E, t ⟩,
      simp only [
        isoF, cpi_equiv_prop.transition_from_iso,
        cpi_equiv.transition_from_fwd, cpi_equiv.transition_from_inv],
      have eqE := (iso k α).2 E t,
      cases ((iso k α).fst).to_fun ⟨E, t⟩ with E' t',
      from immediate_process_space.equiv equ eqE,
    end))

lemma immediate_process_space.species_eq [cpi_equiv_prop ℍ ω] {Γ} {conc : ℍ ↪ ℂ} {ℓ : lookup ℍ ω Γ} {A : species ℍ ω Γ}
  : immediate_process_space.from_species conc ℓ A
  = immediate_process_space.from_species' conc ℓ ⟦ A ⟧
  := by simp only
    [immediate_process_space.from_species, immediate_process_space.from_species',
     quot.lift_on, quotient.mk, cpi_equiv.prime_decompose', multiset.sum',
     function.comp, multiset.map_map]

/-- The vector space of potential interactions of a process (∂P). -/
def process_potential [cpi_equiv ℍ ω] {Γ} (ℓ : lookup ℍ ω Γ)
  : process ℂ ℍ ω Γ → interaction_space ℂ ℍ ω Γ
| (c ◯ A) := c • potential_interaction_space.from_species ℓ A
| (P |ₚ Q) := process_potential P + process_potential Q

lemma process_potential.nil_zero [cpi_equiv ℍ ω] {Γ} (ℓ : lookup ℍ ω Γ) (c : ℂ)
  : process_potential ℓ (c ◯ nil) = 0
  := by simp only
      [process_potential, potential_interaction_space.from_species,
       cpi_equiv.prime_decompose_nil, multiset.sum'_zero, smul_zero]

/-- The vector space of immediate actions of a process (dP/dt)-/
def process_immediate [cpi_equiv ℍ ω]
    (M : affinity ℍ) (ℓ : lookup ℍ ω (context.extend M.arity context.nil)) (conc : ℍ ↪ ℂ)
  : process ℂ ℍ ω (context.extend M.arity context.nil)
  → process_space ℂ ℍ ω (context.extend M.arity context.nil)
| (c ◯ A)
  := c • immediate_process_space.from_species conc ℓ A
  + (½ : ℂ) • (process_potential ℓ (c ◯ A) ⊘[conc] process_potential ℓ (c ◯ A))
| (P |ₚ Q)
  := process_immediate P + process_immediate Q
   + (process_potential ℓ P ⊘[conc] process_potential ℓ Q)

lemma process_immediate.nil_zero {conc : ℍ ↪ ℂ} [cpi_equiv ℍ ω]
    (M : affinity ℍ) (ℓ : lookup ℍ ω (context.extend M.arity context.nil))
    (c : ℂ)
  : process_immediate M ℓ conc (c ◯ nil) = 0
  := by simp only
      [process_immediate, immediate_process_space.from_species,
       process_potential.nil_zero, cpi_equiv.prime_decompose_nil,
       multiset.sum'_zero, interaction_tensor.zero_left, smul_zero, add_zero]

lemma process_potential.equiv [cpi_equiv_prop ℍ ω] {Γ} (ℓ : lookup ℍ ω Γ) :
  ∀ {P Q : process ℂ ℍ ω Γ}
  , P ≈ Q → process_potential ℓ P = process_potential ℓ Q
| P Q eq := begin
  induction eq,
  case process.equiv.refl { refl },
  case process.equiv.trans : P Q R ab bc ih_ab ih_bc { from trans ih_ab ih_bc },
  case process.equiv.symm : P Q eq ih { from symm ih },
  case process.equiv.ξ_species : c A B equ {
    suffices : potential_interaction_space.from_species ℓ A
             = potential_interaction_space.from_species ℓ B,
    { simp only [process_potential],  from congr_arg ((•) c) this },

    calc  potential_interaction_space.from_species ℓ A
        = potential_interaction_space.from_species' ℓ ⟦ A ⟧ : potential_interaction_space.species_eq
    ... = potential_interaction_space.from_species' ℓ ⟦ B ⟧ : by rw quotient.sound equ
    ... = potential_interaction_space.from_species ℓ B : potential_interaction_space.species_eq.symm
  },
  case process.equiv.ξ_parallel₁ : P P' Q eq ih {
    unfold process_potential, rw ih,
  },
  case process.equiv.ξ_parallel₂ : P Q Q' eq ih {
    unfold process_potential, rw ih,
  },
  case process.equiv.parallel_nil : P C {
    show process_potential ℓ P + process_potential ℓ (C ◯ nil) = process_potential ℓ P,
    simp only [process_potential.nil_zero, add_zero],
  },
  case cpi.process.equiv.parallel_symm { simp only [process_potential, add_comm] },
  case process.equiv.parallel_assoc { simp only [process_potential, add_assoc] },
  case process.equiv.join : A c d { simp only [process_potential, add_smul] },
  case process.equiv.split : A B c {
    simp only [process_potential, potential_interaction_space.from_species,
               cpi_equiv.prime_decompose_parallel, multiset.sum'_add, smul_add],
  },
end

private lemma process_immediate.join [cpi_equiv_prop ℍ ω] (M : affinity ℍ)
    (ℓ : lookup ℍ ω (context.extend M.arity context.nil)) {conc : ℍ ↪ ℂ} (c d : ℂ)
    (Ds : interaction_space ℂ ℍ ω (context.extend (M.arity) context.nil))
    (Ps : process_space ℂ ℍ ω (context.extend (M.arity) context.nil))
  : (c • Ds) ⊘[conc] (d • Ds) + ((½ : ℂ) • (c • Ds) ⊘[conc] (c • Ds) + (½ : ℂ) • (d • Ds) ⊘[conc] (d • Ds))
  = (½ : ℂ) • (c • Ds + d • Ds) ⊘[conc] (c • Ds + d • Ds) := begin
  generalize ehalf : (½ : ℂ) = half,

  rw [interaction_tensor.left_distrib (c • Ds) (d • Ds),
      interaction_tensor.right_distrib (c • Ds),
      interaction_tensor.right_distrib (d • Ds),
      interaction_tensor.comm (d • Ds) (c • Ds)],

  calc  (c • Ds) ⊘ (d • Ds)
      + (half • (c • Ds) ⊘ (c • Ds) + half • (d • Ds) ⊘ (d • Ds))

      = (1 : ℂ) • (c • Ds) ⊘[conc] (d • Ds)
      + (half • (c • Ds) ⊘[conc] (c • Ds) + half • (d • Ds) ⊘[conc] (d • Ds))
      : by simp only [one_smul]

  ... = (half + half) • (c • Ds) ⊘[conc] (d • Ds)
      + (half • (c • Ds) ⊘[conc] (c • Ds) + half • (d • Ds) ⊘[conc] (d • Ds))
      : by rw [half_ring.one_is_two_halves, ← ehalf]

       ... = half • (c • Ds) ⊘[conc] (c • Ds) + half • (c • Ds) ⊘[conc] (d • Ds)
           + (half • (c • Ds) ⊘[conc] (d • Ds) + half • (d • Ds) ⊘[conc] (d • Ds))
           : begin
             simp only [add_smul],
             generalize : half • (c • Ds) ⊘[conc] (d • Ds) = cd,
             generalize : half • (c • Ds) ⊘[conc] (c • Ds) = cc,
             generalize : half • (d • Ds) ⊘[conc] (d • Ds) = dd,
             abel,
            end

       ... = half • ((c • Ds) ⊘ (c • Ds) + (c • Ds) ⊘ (d • Ds)
                    + ((c • Ds) ⊘ (d • Ds) + (d • Ds) ⊘ (d • Ds)))
           : by simp only [smul_add]
end

private lemma process_immediate.split [cpi_equiv_prop ℍ ω] [add_monoid ℍ]
    (M : affinity ℍ) (ℓ : lookup ℍ ω (context.extend M.arity context.nil))
    (conc : ℍ ↪ ℂ) (c : ℂ)
    (A B : species ℍ ω (context.extend M.arity context.nil))
  : process_immediate M ℓ conc (c ◯ (A |ₛ B))
  = process_immediate M ℓ conc (c ◯ A |ₚ c ◯ B) := begin
  simp only [process_immediate, immediate_process_space.from_species,
             process_potential.equiv ℓ process.equiv.split,
             cpi_equiv.prime_decompose_parallel, multiset.sum'_add, smul_add],

  generalize : multiset.sum' (cpi_equiv.prime_decompose A) (immediate_process_space.from_prime conc ℓ) = dA,
  generalize : multiset.sum' (cpi_equiv.prime_decompose B) (immediate_process_space.from_prime conc ℓ) = dB,

  have : process_potential ℓ (c ◯ A |ₚ c ◯ B) = process_potential ℓ (c ◯ A) + process_potential ℓ (c ◯ B)
    := rfl,
  simp only [this],

  generalize : process_potential ℓ (c ◯ A) = pA,
  generalize : process_potential ℓ (c ◯ B) = pB,

  simp only [interaction_tensor.left_distrib, interaction_tensor.right_distrib, smul_add],
  rw interaction_tensor.comm pB pA,

  generalize : ½ • pA ⊘[conc] pA = iA,
  generalize : ½ • pB ⊘[conc] pB = iB,
  generalize : pA ⊘[conc] pB = iAB,

  calc  c • dA + c • dB + (iA + (½ : ℂ) • iAB + ((½ : ℂ) • iAB + iB))
      = c • dA + c • dB + (iA + iB + ((½ : ℂ) • iAB + (½ : ℂ) • iAB)) : by abel
  ... = c • dA + c • dB + (iA + iB + iAB)
        : by rw [← add_smul, ← half_ring.one_is_two_halves, one_smul]
  ... = c • dA + iA + (c • dB + iB) + iAB : by abel
end

lemma process_immediate.equiv [cpi_equiv_prop ℍ ω] [add_monoid ℍ]
    (M : affinity ℍ) (ℓ : lookup ℍ ω (context.extend M.arity context.nil))
    (conc : ℍ ↪ ℂ)
  : ∀ {P Q : process ℂ ℍ ω (context.extend M.arity context.nil)}
  , P ≈ Q
  → process_immediate M ℓ conc P
  = process_immediate M ℓ conc Q
| P Q eq := begin
  induction eq,
  case process.equiv.refl { from rfl },
  case process.equiv.symm : A B eq ih { from (symm ih) },
  case process.equiv.trans : P Q R ab bc ih_ab ih_bc { from trans ih_ab ih_bc },

  case process.equiv.ξ_species : c A B equ {
    suffices : immediate_process_space.from_species conc ℓ A
             = immediate_process_space.from_species conc ℓ B,
    { simp only [process_immediate],
      rw [process_potential.equiv ℓ (process.equiv.ξ_species equ), this]
    },

    calc  immediate_process_space.from_species conc ℓ A
        = immediate_process_space.from_species' conc ℓ ⟦ A ⟧ : immediate_process_space.species_eq
    ... = immediate_process_space.from_species' conc ℓ ⟦ B ⟧ : by rw quotient.sound equ
    ... = immediate_process_space.from_species conc ℓ B : immediate_process_space.species_eq.symm
  },
  case process.equiv.ξ_parallel₁ : P P' Q eq ih {
    simp only [process_immediate, process_potential.equiv ℓ eq, ih],
  },
  case process.equiv.ξ_parallel₂ : P Q Q' eq ih {
    simp only [process_immediate, process_potential.equiv ℓ eq, ih],
  },
  case process.equiv.parallel_nil {
    simp only [process_immediate, process_immediate.nil_zero, add_zero,
               process_potential.nil_zero, interaction_tensor.zero_left],
  },
  case cpi.process.equiv.parallel_symm : P Q {
    simp only [process_immediate, add_comm, interaction_tensor.comm],
  },
  case process.equiv.parallel_assoc : P Q R {
    simp only [process_immediate, add_assoc] ,
    simp only [add_left_comm],
    refine congr_arg _ _,
    refine congr_arg _ _,
    refine congr_arg _ _,

    unfold process_potential,

    generalize : process_potential ℓ P = p,
    generalize : process_potential ℓ Q = q,
    generalize : process_potential ℓ R = r,

    calc  p ⊘ q + (p + q) ⊘ r
        = p ⊘[conc] q + p ⊘[conc] r + q ⊘ r : by rw [interaction_tensor.left_distrib, add_assoc]
    ... = q ⊘[conc] r + p ⊘[conc] q + p ⊘[conc] r : by simp only [add_comm, add_left_comm, interaction_tensor.comm]
    ... = q ⊘[conc] r + p ⊘[conc] (q + r) : by rw [add_assoc, ← interaction_tensor.right_distrib]
  },
  case process.equiv.join : A c d {
    simp only [process_immediate, process_potential],

    generalize : potential_interaction_space.from_species ℓ A = Ds,
    generalize : immediate_process_space.from_species conc ℓ A = Ps,

    suffices
      : (c • Ds) ⊘[conc] (d • Ds) + ((½ : ℂ) • ((c • Ds) ⊘[conc] (c • Ds)) + (½ : ℂ) • (d • Ds) ⊘[conc] (d • Ds))
      = (½ : ℂ) • ((c • Ds + d • Ds) ⊘[conc] (c • Ds + d • Ds)),
      { simp only [add_assoc, add_comm, add_smul, add_left_comm, this] },

    from process_immediate.join M ℓ c d Ds Ps,
  },
  case process.equiv.split : A B c {
    from process_immediate.split M ℓ conc c A B
  },
end

/-- dP/dt lifted to quotients. -/
def process_immediate.quot [cpi_equiv_prop ℍ ω] [add_monoid ℍ]
    (M : affinity ℍ) (ℓ : lookup ℍ ω (context.extend M.arity context.nil))
    (conc : ℍ ↪ ℂ)
  : process' ℂ ℍ ω (context.extend M.arity context.nil)
  → process_space ℂ ℍ ω (context.extend M.arity context.nil)
| P := quot.lift_on P (process_immediate M ℓ conc)
    (λ P Q, process_immediate.equiv M ℓ conc)

/-- dP/dt lifted to process spaces. -/
def process_immediate.space [cpi_equiv_prop ℍ ω] [half_ring ℍ]
    (M : affinity ℍ) (ℓ : lookup ℍ ω (context.extend M.arity context.nil))
    (conc : ℍ ↪ ℂ)
  : process_space ℂ ℍ ω (context.extend M.arity context.nil)
  → process_space ℂ ℍ ω (context.extend M.arity context.nil)
| P := process_immediate.quot M ℓ conc (process.from_space P)

end cpi

#lint-


/-
File: signature_recover_public_key_get_generator_point_soundness.lean

Autogenerated file.
-/
import starkware.cairo.lean.semantics.soundness.hoare
import .signature_recover_public_key_code
import ..signature_recover_public_key_spec
open tactic

open starkware.cairo.common.cairo_secp.signature
open starkware.cairo.common.cairo_secp.bigint
open starkware.cairo.common.cairo_secp.ec

variables {F : Type} [field F] [decidable_eq F] [prelude_hyps F]
variable  mem : F → F
variable  σ : register_state F

/- starkware.cairo.common.cairo_secp.signature.get_generator_point autogenerated soundness theorem -/

theorem auto_sound_get_generator_point
    -- code is in memory at σ.pc
    (h_mem : mem_at mem code_get_generator_point σ.pc)
    -- input arguments on the stack
    -- conclusion
  : ensures_ret mem σ (λ κ τ, τ.ap = σ.ap + 6 ∧ spec_get_generator_point mem κ (cast_EcPoint mem (τ.ap - 6))) :=
begin
  apply ensures_of_ensuresb, intro νbound,
  have h_mem_rec := h_mem,
  unpack_memory code_get_generator_point at h_mem with ⟨hpc0, hpc1, hpc2, hpc3, hpc4, hpc5, hpc6, hpc7, hpc8, hpc9, hpc10, hpc11, hpc12⟩,
  -- return
  step_assert_eq hpc0 hpc1 with hret0,
  step_assert_eq hpc2 hpc3 with hret1,
  step_assert_eq hpc4 hpc5 with hret2,
  step_assert_eq hpc6 hpc7 with hret3,
  step_assert_eq hpc8 hpc9 with hret4,
  step_assert_eq hpc10 hpc11 with hret5,
  step_ret hpc12,
  -- finish
  step_done, use_only [rfl, rfl],
  split, refl,
  -- Final Proof
  -- user-provided reduction
  suffices auto_spec: auto_spec_get_generator_point mem _  _,
  { apply sound_get_generator_point, apply auto_spec },
  -- prove the auto generated assertion
  dsimp [auto_spec_get_generator_point],
  try { norm_num1 }, try { arith_simps },
  try { split, linarith },
  try { ensures_simps; try { simp only [add_neg_eq_sub] }, },
  try { dsimp [cast_EcPoint, cast_BigInt3] },
  try { arith_simps }, try { simp only [hret0, hret1, hret2, hret3, hret4, hret5] },
  try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },
end