/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.computability.primrec
import Mathlib.data.nat.psub
import Mathlib.data.pfun
import Mathlib.PostPort

universes u_1 u_2 u_3 u_4 u_5

namespace Mathlib

/-!
# The partial recursive functions

The partial recursive functions are defined similarly to the primitive
recursive functions, but now all functions are partial, implemented
using the `roption` monad, and there is an additional operation, called
μ-recursion, which performs unbounded minimization.

## References

* [Mario Carneiro, *Formalizing computability theory via partial recursive functions*][carneiro2019]
-/

namespace nat

def rfind_x (p : ℕ →. Bool) (H : ∃ (n : ℕ), tt ∈ p n ∧ ∀ (k : ℕ), k < n → roption.dom (p k)) : Subtype fun (n : ℕ) => tt ∈ p n ∧ ∀ (m : ℕ), m < n → false ∈ p m :=
  (fun
      (this :
      (k : ℕ) → (∀ (n : ℕ), n < k → false ∈ p n) → Subtype fun (n : ℕ) => tt ∈ p n ∧ ∀ (m : ℕ), m < n → false ∈ p m) =>
      this 0 sorry)
    (well_founded.fix (wf_lbp p H)
      fun (m : ℕ)
        (IH :
        (y : ℕ) →
          lbp p y m → (∀ (n : ℕ), n < y → false ∈ p n) → Subtype fun (n : ℕ) => tt ∈ p n ∧ ∀ (m : ℕ), m < n → false ∈ p m)
        (al : ∀ (n : ℕ), n < m → false ∈ p n) =>
        (fun (_x : Bool) (e : roption.get (p m) sorry = _x) =>
            bool.cases_on _x (fun (e : roption.get (p m) sorry = false) => IH (m + 1) sorry sorry)
              (fun (e : roption.get (p m) sorry = tt) => { val := m, property := sorry }) e)
          (roption.get (p m) sorry) sorry)

def rfind (p : ℕ →. Bool) : roption ℕ :=
  roption.mk (∃ (n : ℕ), tt ∈ p n ∧ ∀ (k : ℕ), k < n → roption.dom (p k))
    fun (h : ∃ (n : ℕ), tt ∈ p n ∧ ∀ (k : ℕ), k < n → roption.dom (p k)) => subtype.val (rfind_x p h)

theorem rfind_spec {p : ℕ →. Bool} {n : ℕ} (h : n ∈ rfind p) : tt ∈ p n :=
  Exists.snd h ▸ and.left (subtype.property (rfind_x p (Exists.fst h)))

theorem rfind_min {p : ℕ →. Bool} {n : ℕ} (h : n ∈ rfind p) {m : ℕ} : m < n → false ∈ p m :=
  Exists.snd h ▸ and.right (subtype.property (rfind_x p (Exists.fst h)))

@[simp] theorem rfind_dom {p : ℕ →. Bool} : roption.dom (rfind p) ↔ ∃ (n : ℕ), tt ∈ p n ∧ ∀ {m : ℕ}, m < n → roption.dom (p m) :=
  iff.rfl

theorem rfind_dom' {p : ℕ →. Bool} : roption.dom (rfind p) ↔ ∃ (n : ℕ), tt ∈ p n ∧ ∀ {m : ℕ}, m ≤ n → roption.dom (p m) := sorry

@[simp] theorem mem_rfind {p : ℕ →. Bool} {n : ℕ} : n ∈ rfind p ↔ tt ∈ p n ∧ ∀ {m : ℕ}, m < n → false ∈ p m := sorry

theorem rfind_min' {p : ℕ → Bool} {m : ℕ} (pm : ↥(p m)) : ∃ (n : ℕ), ∃ (H : n ∈ rfind ↑p), n ≤ m := sorry

theorem rfind_zero_none (p : ℕ →. Bool) (p0 : p 0 = roption.none) : rfind p = roption.none := sorry

def rfind_opt {α : Type u_1} (f : ℕ → Option α) : roption α :=
  roption.bind (rfind ↑fun (n : ℕ) => option.is_some (f n)) fun (n : ℕ) => ↑(f n)

theorem rfind_opt_spec {α : Type u_1} {f : ℕ → Option α} {a : α} (h : a ∈ rfind_opt f) : ∃ (n : ℕ), a ∈ f n := sorry

theorem rfind_opt_dom {α : Type u_1} {f : ℕ → Option α} : roption.dom (rfind_opt f) ↔ ∃ (n : ℕ), ∃ (a : α), a ∈ f n := sorry

theorem rfind_opt_mono {α : Type u_1} {f : ℕ → Option α} (H : ∀ {a : α} {m n : ℕ}, m ≤ n → a ∈ f m → a ∈ f n) {a : α} : a ∈ rfind_opt f ↔ ∃ (n : ℕ), a ∈ f n := sorry

inductive partrec : (ℕ →. ℕ) → Prop
where
| zero : partrec (pure 0)
| succ : partrec ↑Nat.succ
| left : partrec ↑fun (n : ℕ) => prod.fst (unpair n)
| right : partrec ↑fun (n : ℕ) => prod.snd (unpair n)
| pair : ∀ {f g : ℕ →. ℕ}, partrec f → partrec g → partrec fun (n : ℕ) => mkpair <$> f n <*> g n
| comp : ∀ {f g : ℕ →. ℕ}, partrec f → partrec g → partrec fun (n : ℕ) => g n >>= f
| prec : ∀ {f g : ℕ →. ℕ},
  partrec f →
    partrec g →
      partrec
        (unpaired
          fun (a n : ℕ) =>
            elim (f a)
              (fun (y : ℕ) (IH : roption ℕ) =>
                do
                  let i ← IH
                  g (mkpair a (mkpair y i)))
              n)
| rfind : ∀ {f : ℕ →. ℕ},
  partrec f → partrec fun (a : ℕ) => rfind fun (n : ℕ) => (fun (m : ℕ) => to_bool (m = 0)) <$> f (mkpair a n)

namespace partrec

theorem of_eq {f : ℕ →. ℕ} {g : ℕ →. ℕ} (hf : partrec f) (H : ∀ (n : ℕ), f n = g n) : partrec g :=
  funext H ▸ hf

theorem of_eq_tot {f : ℕ →. ℕ} {g : ℕ → ℕ} (hf : partrec f) (H : ∀ (n : ℕ), g n ∈ f n) : partrec ↑g :=
  of_eq hf fun (n : ℕ) => iff.mpr roption.eq_some_iff (H n)

theorem of_primrec {f : ℕ → ℕ} (hf : primrec f) : partrec ↑f := sorry

protected theorem some : partrec roption.some :=
  of_primrec primrec.id

theorem none : partrec fun (n : ℕ) => roption.none := sorry

theorem prec' {f : ℕ →. ℕ} {g : ℕ →. ℕ} {h : ℕ →. ℕ} (hf : partrec f) (hg : partrec g) (hh : partrec h) : partrec
  fun (a : ℕ) =>
    roption.bind (f a)
      fun (n : ℕ) =>
        elim (g a)
          (fun (y : ℕ) (IH : roption ℕ) =>
            do
              let i ← IH
              h (mkpair a (mkpair y i)))
          n := sorry

theorem ppred : partrec fun (n : ℕ) => ↑(ppred n) := sorry

end partrec

end nat

def partrec {α : Type u_1} {σ : Type u_2} [primcodable α] [primcodable σ] (f : α →. σ) :=
  nat.partrec fun (n : ℕ) => roption.bind ↑(encodable.decode α n) fun (a : α) => roption.map encodable.encode (f a)

def partrec₂ {α : Type u_1} {β : Type u_2} {σ : Type u_3} [primcodable α] [primcodable β] [primcodable σ] (f : α → β →. σ) :=
  partrec fun (p : α × β) => f (prod.fst p) (prod.snd p)

def computable {α : Type u_1} {σ : Type u_2} [primcodable α] [primcodable σ] (f : α → σ) :=
  partrec ↑f

def computable₂ {α : Type u_1} {β : Type u_2} {σ : Type u_3} [primcodable α] [primcodable β] [primcodable σ] (f : α → β → σ) :=
  computable fun (p : α × β) => f (prod.fst p) (prod.snd p)

theorem primrec.to_comp {α : Type u_1} {σ : Type u_2} [primcodable α] [primcodable σ] {f : α → σ} (hf : primrec f) : computable f := sorry

theorem primrec₂.to_comp {α : Type u_1} {β : Type u_2} {σ : Type u_3} [primcodable α] [primcodable β] [primcodable σ] {f : α → β → σ} (hf : primrec₂ f) : computable₂ f :=
  primrec.to_comp hf

theorem computable.part {α : Type u_1} {σ : Type u_2} [primcodable α] [primcodable σ] {f : α → σ} (hf : computable f) : partrec ↑f :=
  hf

theorem computable₂.part {α : Type u_1} {β : Type u_2} {σ : Type u_3} [primcodable α] [primcodable β] [primcodable σ] {f : α → β → σ} (hf : computable₂ f) : partrec₂ fun (a : α) => ↑(f a) :=
  hf

namespace computable

theorem of_eq {α : Type u_1} {σ : Type u_4} [primcodable α] [primcodable σ] {f : α → σ} {g : α → σ} (hf : computable f) (H : ∀ (n : α), f n = g n) : computable g :=
  funext H ▸ hf

theorem const {α : Type u_1} {σ : Type u_4} [primcodable α] [primcodable σ] (s : σ) : computable fun (a : α) => s :=
  primrec.to_comp (primrec.const s)

theorem of_option {α : Type u_1} {β : Type u_2} [primcodable α] [primcodable β] {f : α → Option β} (hf : computable f) : partrec fun (a : α) => ↑(f a) := sorry

theorem to₂ {α : Type u_1} {β : Type u_2} {σ : Type u_4} [primcodable α] [primcodable β] [primcodable σ] {f : α × β → σ} (hf : computable f) : computable₂ fun (a : α) (b : β) => f (a, b) :=
  of_eq hf
    fun (_x : α × β) =>
      (fun (_a : α × β) => prod.cases_on _a fun (fst : α) (snd : β) => idRhs (f (fst, snd) = f (fst, snd)) rfl) _x

protected theorem id {α : Type u_1} [primcodable α] : computable id :=
  primrec.to_comp primrec.id

theorem fst {α : Type u_1} {β : Type u_2} [primcodable α] [primcodable β] : computable prod.fst :=
  primrec.to_comp primrec.fst

theorem snd {α : Type u_1} {β : Type u_2} [primcodable α] [primcodable β] : computable prod.snd :=
  primrec.to_comp primrec.snd

theorem pair {α : Type u_1} {β : Type u_2} {γ : Type u_3} [primcodable α] [primcodable β] [primcodable γ] {f : α → β} {g : α → γ} (hf : computable f) (hg : computable g) : computable fun (a : α) => (f a, g a) := sorry

theorem unpair : computable nat.unpair :=
  primrec.to_comp primrec.unpair

theorem succ : computable Nat.succ :=
  primrec.to_comp primrec.succ

theorem pred : computable Nat.pred :=
  primrec.to_comp primrec.pred

theorem nat_bodd : computable nat.bodd :=
  primrec.to_comp primrec.nat_bodd

theorem nat_div2 : computable nat.div2 :=
  primrec.to_comp primrec.nat_div2

theorem sum_inl {α : Type u_1} {β : Type u_2} [primcodable α] [primcodable β] : computable sum.inl :=
  primrec.to_comp primrec.sum_inl

theorem sum_inr {α : Type u_1} {β : Type u_2} [primcodable α] [primcodable β] : computable sum.inr :=
  primrec.to_comp primrec.sum_inr

theorem list_cons {α : Type u_1} [primcodable α] : computable₂ List.cons :=
  primrec₂.to_comp primrec.list_cons

theorem list_reverse {α : Type u_1} [primcodable α] : computable list.reverse :=
  primrec.to_comp primrec.list_reverse

theorem list_nth {α : Type u_1} [primcodable α] : computable₂ list.nth :=
  primrec₂.to_comp primrec.list_nth

theorem list_append {α : Type u_1} [primcodable α] : computable₂ append :=
  primrec₂.to_comp primrec.list_append

theorem list_concat {α : Type u_1} [primcodable α] : computable₂ fun (l : List α) (a : α) => l ++ [a] :=
  primrec₂.to_comp primrec.list_concat

theorem list_length {α : Type u_1} [primcodable α] : computable list.length :=
  primrec.to_comp primrec.list_length

theorem vector_cons {α : Type u_1} [primcodable α] {n : ℕ} : computable₂ vector.cons :=
  primrec₂.to_comp primrec.vector_cons

theorem vector_to_list {α : Type u_1} [primcodable α] {n : ℕ} : computable vector.to_list :=
  primrec.to_comp primrec.vector_to_list

theorem vector_length {α : Type u_1} [primcodable α] {n : ℕ} : computable vector.length :=
  primrec.to_comp primrec.vector_length

theorem vector_head {α : Type u_1} [primcodable α] {n : ℕ} : computable vector.head :=
  primrec.to_comp primrec.vector_head

theorem vector_tail {α : Type u_1} [primcodable α] {n : ℕ} : computable vector.tail :=
  primrec.to_comp primrec.vector_tail

theorem vector_nth {α : Type u_1} [primcodable α] {n : ℕ} : computable₂ vector.nth :=
  primrec₂.to_comp primrec.vector_nth

theorem vector_nth' {α : Type u_1} [primcodable α] {n : ℕ} : computable vector.nth :=
  primrec.to_comp primrec.vector_nth'

theorem vector_of_fn' {α : Type u_1} [primcodable α] {n : ℕ} : computable vector.of_fn :=
  primrec.to_comp primrec.vector_of_fn'

theorem fin_app {σ : Type u_4} [primcodable σ] {n : ℕ} : computable₂ id :=
  primrec₂.to_comp primrec.fin_app

protected theorem encode {α : Type u_1} [primcodable α] : computable encodable.encode :=
  primrec.to_comp primrec.encode

protected theorem decode {α : Type u_1} [primcodable α] : computable (encodable.decode α) :=
  primrec.to_comp primrec.decode

protected theorem of_nat (α : Type u_1) [denumerable α] : computable (denumerable.of_nat α) :=
  primrec.to_comp (primrec.of_nat α)

theorem encode_iff {α : Type u_1} {σ : Type u_4} [primcodable α] [primcodable σ] {f : α → σ} : (computable fun (a : α) => encodable.encode (f a)) ↔ computable f :=
  iff.rfl

theorem option_some {α : Type u_1} [primcodable α] : computable some :=
  primrec.to_comp primrec.option_some

end computable

namespace partrec

theorem of_eq {α : Type u_1} {σ : Type u_4} [primcodable α] [primcodable σ] {f : α →. σ} {g : α →. σ} (hf : partrec f) (H : ∀ (n : α), f n = g n) : partrec g :=
  funext H ▸ hf

theorem of_eq_tot {α : Type u_1} {σ : Type u_4} [primcodable α] [primcodable σ] {f : α →. σ} {g : α → σ} (hf : partrec f) (H : ∀ (n : α), g n ∈ f n) : computable g :=
  of_eq hf fun (a : α) => iff.mpr roption.eq_some_iff (H a)

theorem none {α : Type u_1} {σ : Type u_4} [primcodable α] [primcodable σ] : partrec fun (a : α) => roption.none := sorry

protected theorem some {α : Type u_1} [primcodable α] : partrec roption.some :=
  computable.id

theorem const' {α : Type u_1} {σ : Type u_4} [primcodable α] [primcodable σ] (s : roption σ) : partrec fun (a : α) => s :=
  of_eq (computable.of_option (computable.const (roption.to_option s))) fun (a : α) => roption.of_to_option s

protected theorem bind {α : Type u_1} {β : Type u_2} {σ : Type u_4} [primcodable α] [primcodable β] [primcodable σ] {f : α →. β} {g : α → β →. σ} (hf : partrec f) (hg : partrec₂ g) : partrec fun (a : α) => roption.bind (f a) (g a) := sorry

theorem map {α : Type u_1} {β : Type u_2} {σ : Type u_4} [primcodable α] [primcodable β] [primcodable σ] {f : α →. β} {g : α → β → σ} (hf : partrec f) (hg : computable₂ g) : partrec fun (a : α) => roption.map (g a) (f a) := sorry

theorem to₂ {α : Type u_1} {β : Type u_2} {σ : Type u_4} [primcodable α] [primcodable β] [primcodable σ] {f : α × β →. σ} (hf : partrec f) : partrec₂ fun (a : α) (b : β) => f (a, b) :=
  of_eq hf
    fun (_x : α × β) =>
      (fun (_a : α × β) => prod.cases_on _a fun (fst : α) (snd : β) => idRhs (f (fst, snd) = f (fst, snd)) rfl) _x

theorem nat_elim {α : Type u_1} {σ : Type u_4} [primcodable α] [primcodable σ] {f : α → ℕ} {g : α →. σ} {h : α → ℕ × σ →. σ} (hf : computable f) (hg : partrec g) (hh : partrec₂ h) : partrec fun (a : α) => nat.elim (g a) (fun (y : ℕ) (IH : roption σ) => roption.bind IH fun (i : σ) => h a (y, i)) (f a) := sorry

theorem comp {α : Type u_1} {β : Type u_2} {σ : Type u_4} [primcodable α] [primcodable β] [primcodable σ] {f : β →. σ} {g : α → β} (hf : partrec f) (hg : computable g) : partrec fun (a : α) => f (g a) := sorry

theorem nat_iff {f : ℕ →. ℕ} : partrec f ↔ nat.partrec f := sorry

theorem map_encode_iff {α : Type u_1} {σ : Type u_4} [primcodable α] [primcodable σ] {f : α →. σ} : (partrec fun (a : α) => roption.map encodable.encode (f a)) ↔ partrec f :=
  iff.rfl

end partrec

namespace partrec₂

theorem unpaired {α : Type u_1} [primcodable α] {f : ℕ → ℕ →. α} : partrec (nat.unpaired f) ↔ partrec₂ f := sorry

theorem unpaired' {f : ℕ → ℕ →. ℕ} : nat.partrec (nat.unpaired f) ↔ partrec₂ f :=
  iff.trans (iff.symm partrec.nat_iff) unpaired

theorem comp {α : Type u_1} {β : Type u_2} {γ : Type u_3} {σ : Type u_5} [primcodable α] [primcodable β] [primcodable γ] [primcodable σ] {f : β → γ →. σ} {g : α → β} {h : α → γ} (hf : partrec₂ f) (hg : computable g) (hh : computable h) : partrec fun (a : α) => f (g a) (h a) :=
  partrec.comp hf (computable.pair hg hh)

theorem comp₂ {α : Type u_1} {β : Type u_2} {γ : Type u_3} {δ : Type u_4} {σ : Type u_5} [primcodable α] [primcodable β] [primcodable γ] [primcodable δ] [primcodable σ] {f : γ → δ →. σ} {g : α → β → γ} {h : α → β → δ} (hf : partrec₂ f) (hg : computable₂ g) (hh : computable₂ h) : partrec₂ fun (a : α) (b : β) => f (g a b) (h a b) :=
  comp hf hg hh

end partrec₂

namespace computable

theorem comp {α : Type u_1} {β : Type u_2} {σ : Type u_4} [primcodable α] [primcodable β] [primcodable σ] {f : β → σ} {g : α → β} (hf : computable f) (hg : computable g) : computable fun (a : α) => f (g a) :=
  partrec.comp hf hg

theorem comp₂ {α : Type u_1} {β : Type u_2} {γ : Type u_3} {σ : Type u_4} [primcodable α] [primcodable β] [primcodable γ] [primcodable σ] {f : γ → σ} {g : α → β → γ} (hf : computable f) (hg : computable₂ g) : computable₂ fun (a : α) (b : β) => f (g a b) :=
  comp hf hg

end computable

namespace computable₂

theorem comp {α : Type u_1} {β : Type u_2} {γ : Type u_3} {σ : Type u_5} [primcodable α] [primcodable β] [primcodable γ] [primcodable σ] {f : β → γ → σ} {g : α → β} {h : α → γ} (hf : computable₂ f) (hg : computable g) (hh : computable h) : computable fun (a : α) => f (g a) (h a) :=
  computable.comp hf (computable.pair hg hh)

theorem comp₂ {α : Type u_1} {β : Type u_2} {γ : Type u_3} {δ : Type u_4} {σ : Type u_5} [primcodable α] [primcodable β] [primcodable γ] [primcodable δ] [primcodable σ] {f : γ → δ → σ} {g : α → β → γ} {h : α → β → δ} (hf : computable₂ f) (hg : computable₂ g) (hh : computable₂ h) : computable₂ fun (a : α) (b : β) => f (g a b) (h a b) :=
  comp hf hg hh

end computable₂

namespace partrec

theorem rfind {α : Type u_1} [primcodable α] {p : α → ℕ →. Bool} (hp : partrec₂ p) : partrec fun (a : α) => nat.rfind (p a) := sorry

theorem rfind_opt {α : Type u_1} {σ : Type u_4} [primcodable α] [primcodable σ] {f : α → ℕ → Option σ} (hf : computable₂ f) : partrec fun (a : α) => nat.rfind_opt (f a) :=
  partrec.bind (rfind (to₂ (computable.part (computable.comp (primrec.to_comp primrec.option_is_some) hf))))
    (computable.of_option hf)

theorem nat_cases_right {α : Type u_1} {σ : Type u_4} [primcodable α] [primcodable σ] {f : α → ℕ} {g : α → σ} {h : α → ℕ →. σ} (hf : computable f) (hg : computable g) (hh : partrec₂ h) : partrec fun (a : α) => nat.cases (roption.some (g a)) (h a) (f a) := sorry

theorem bind_decode2_iff {α : Type u_1} {σ : Type u_4} [primcodable α] [primcodable σ] {f : α →. σ} : partrec f ↔
  nat.partrec fun (n : ℕ) => roption.bind ↑(encodable.decode2 α n) fun (a : α) => roption.map encodable.encode (f a) := sorry

theorem vector_m_of_fn {α : Type u_1} {σ : Type u_4} [primcodable α] [primcodable σ] {n : ℕ} {f : fin n → α →. σ} : (∀ (i : fin n), partrec (f i)) → partrec fun (a : α) => vector.m_of_fn fun (i : fin n) => f i a := sorry

end partrec

@[simp] theorem vector.m_of_fn_roption_some {α : Type u_1} {n : ℕ} (f : fin n → α) : (vector.m_of_fn fun (i : fin n) => roption.some (f i)) = roption.some (vector.of_fn f) :=
  vector.m_of_fn_pure

namespace computable

theorem option_some_iff {α : Type u_1} {σ : Type u_4} [primcodable α] [primcodable σ] {f : α → σ} : (computable fun (a : α) => some (f a)) ↔ computable f := sorry

theorem bind_decode_iff {α : Type u_1} {β : Type u_2} {σ : Type u_4} [primcodable α] [primcodable β] [primcodable σ] {f : α → β → Option σ} : (computable₂ fun (a : α) (n : ℕ) => option.bind (encodable.decode β n) (f a)) ↔ computable₂ f := sorry

theorem map_decode_iff {α : Type u_1} {β : Type u_2} {σ : Type u_4} [primcodable α] [primcodable β] [primcodable σ] {f : α → β → σ} : (computable₂ fun (a : α) (n : ℕ) => option.map (f a) (encodable.decode β n)) ↔ computable₂ f :=
  iff.trans bind_decode_iff option_some_iff

theorem nat_elim {α : Type u_1} {σ : Type u_4} [primcodable α] [primcodable σ] {f : α → ℕ} {g : α → σ} {h : α → ℕ × σ → σ} (hf : computable f) (hg : computable g) (hh : computable₂ h) : computable fun (a : α) => nat.elim (g a) (fun (y : ℕ) (IH : σ) => h a (y, IH)) (f a) := sorry

theorem nat_cases {α : Type u_1} {σ : Type u_4} [primcodable α] [primcodable σ] {f : α → ℕ} {g : α → σ} {h : α → ℕ → σ} (hf : computable f) (hg : computable g) (hh : computable₂ h) : computable fun (a : α) => nat.cases (g a) (h a) (f a) :=
  nat_elim hf hg (to₂ (computable₂.comp hh fst (comp fst snd)))

theorem cond {α : Type u_1} {σ : Type u_4} [primcodable α] [primcodable σ] {c : α → Bool} {f : α → σ} {g : α → σ} (hc : computable c) (hf : computable f) (hg : computable g) : computable fun (a : α) => cond (c a) (f a) (g a) := sorry

theorem option_cases {α : Type u_1} {β : Type u_2} {σ : Type u_4} [primcodable α] [primcodable β] [primcodable σ] {o : α → Option β} {f : α → σ} {g : α → β → σ} (ho : computable o) (hf : computable f) (hg : computable₂ g) : computable fun (a : α) => option.cases_on (o a) (f a) (g a) := sorry

theorem option_bind {α : Type u_1} {β : Type u_2} {σ : Type u_4} [primcodable α] [primcodable β] [primcodable σ] {f : α → Option β} {g : α → β → Option σ} (hf : computable f) (hg : computable₂ g) : computable fun (a : α) => option.bind (f a) (g a) := sorry

theorem option_map {α : Type u_1} {β : Type u_2} {σ : Type u_4} [primcodable α] [primcodable β] [primcodable σ] {f : α → Option β} {g : α → β → σ} (hf : computable f) (hg : computable₂ g) : computable fun (a : α) => option.map (g a) (f a) :=
  option_bind hf (comp₂ option_some hg)

theorem option_get_or_else {α : Type u_1} {β : Type u_2} [primcodable α] [primcodable β] {f : α → Option β} {g : α → β} (hf : computable f) (hg : computable g) : computable fun (a : α) => option.get_or_else (f a) (g a) := sorry

theorem subtype_mk {α : Type u_1} {β : Type u_2} [primcodable α] [primcodable β] {f : α → β} {p : β → Prop} [decidable_pred p] {h : ∀ (a : α), p (f a)} (hp : primrec_pred p) (hf : computable f) : computable fun (a : α) => { val := f a, property := h a } := sorry

theorem sum_cases {α : Type u_1} {β : Type u_2} {γ : Type u_3} {σ : Type u_4} [primcodable α] [primcodable β] [primcodable γ] [primcodable σ] {f : α → β ⊕ γ} {g : α → β → σ} {h : α → γ → σ} (hf : computable f) (hg : computable₂ g) (hh : computable₂ h) : computable fun (a : α) => sum.cases_on (f a) (g a) (h a) := sorry

theorem nat_strong_rec {α : Type u_1} {σ : Type u_4} [primcodable α] [primcodable σ] (f : α → ℕ → σ) {g : α → List σ → Option σ} (hg : computable₂ g) (H : ∀ (a : α) (n : ℕ), g a (list.map (f a) (list.range n)) = some (f a n)) : computable₂ f := sorry

theorem list_of_fn {α : Type u_1} {σ : Type u_4} [primcodable α] [primcodable σ] {n : ℕ} {f : fin n → α → σ} : (∀ (i : fin n), computable (f i)) → computable fun (a : α) => list.of_fn fun (i : fin n) => f i a := sorry

theorem vector_of_fn {α : Type u_1} {σ : Type u_4} [primcodable α] [primcodable σ] {n : ℕ} {f : fin n → α → σ} (hf : ∀ (i : fin n), computable (f i)) : computable fun (a : α) => vector.of_fn fun (i : fin n) => f i a := sorry

end computable

namespace partrec

theorem option_some_iff {α : Type u_1} {σ : Type u_4} [primcodable α] [primcodable σ] {f : α →. σ} : (partrec fun (a : α) => roption.map some (f a)) ↔ partrec f := sorry

theorem option_cases_right {α : Type u_1} {β : Type u_2} {σ : Type u_4} [primcodable α] [primcodable β] [primcodable σ] {o : α → Option β} {f : α → σ} {g : α → β →. σ} (ho : computable o) (hf : computable f) (hg : partrec₂ g) : partrec fun (a : α) => option.cases_on (o a) (roption.some (f a)) (g a) := sorry

theorem sum_cases_right {α : Type u_1} {β : Type u_2} {γ : Type u_3} {σ : Type u_4} [primcodable α] [primcodable β] [primcodable γ] [primcodable σ] {f : α → β ⊕ γ} {g : α → β → σ} {h : α → γ →. σ} (hf : computable f) (hg : computable₂ g) (hh : partrec₂ h) : partrec fun (a : α) => sum.cases_on (f a) (fun (b : β) => roption.some (g a b)) (h a) := sorry

theorem sum_cases_left {α : Type u_1} {β : Type u_2} {γ : Type u_3} {σ : Type u_4} [primcodable α] [primcodable β] [primcodable γ] [primcodable σ] {f : α → β ⊕ γ} {g : α → β →. σ} {h : α → γ → σ} (hf : computable f) (hg : partrec₂ g) (hh : computable₂ h) : partrec fun (a : α) => sum.cases_on (f a) (g a) fun (c : γ) => roption.some (h a c) := sorry

theorem fix {α : Type u_1} {σ : Type u_4} [primcodable α] [primcodable σ] {f : α →. σ ⊕ α} (hf : partrec f) : partrec (pfun.fix f) := sorry


import polyfix
import polysize
import data.list.basic

section foldl
variables {α γ : Type*}

def tails_foldl_step (f : α → list γ → α) (x : list γ × α) : bool × (list γ × α) :=
(x.1.empty, x.1.tail, f x.2 x.1)

variables (f : α → list γ → α) (x : list γ × α)
lemma tails_foldl_step_iter :
  iterator_evaln (tails_foldl_step f) (2 + x.1.length) (ff, x) = some ([], x.1.tails.foldl f x.2) :=
begin
  cases x with l x,
  induction l with hd tl ih generalizing x,
  { simp [tails_foldl_step], }, { simp [tails_foldl_step, ← add_assoc, ih], },
end

variables {f}
lemma tails_foldl_states_suffix {s₀ s : bool × list γ × α} (hs : s ∈ (mk_iterator ↑(tails_foldl_step f) s₀).states) :
  s.2.1 <:+ s₀.2.1 :=
begin
  rcases s₀ with ⟨b₀, l₀, s₀⟩,
  apply execution.step_induction hs; clear hs s,
  { simp, },
  rintros ⟨b, l, s⟩ ⟨b', l', s'⟩ _, simp,
  rintros ih rfl, simp [tails_foldl_step],
  rintros rfl rfl rfl,
  exact l.tail_suffix.trans ih,
end

end foldl

section
open ptree.pencodable (encode decode)
variables {α β γ : Type*} [polycodable α] [polycodable β] [polycodable γ]
  {f : β → α → list γ → α} {l : β → list γ} (acc : β → α)

lemma acc_list_polysize_fun_uniform (hl : polysize_fun l) :
  polysize_fun_uniform (λ (s : β) (y : (mk_iterator ↑(tails_foldl_step (f s)) (ff, l s, acc s)).states), (y : bool × list γ × α).2.1) :=
begin
  rcases hl with ⟨pi, hpi⟩, use pi, intros s x,
  refine trans (encode_sizeof_le_of_infix _) (hpi _),
  exact (tails_foldl_states_suffix (subtype.mem x)).is_infix,
end

lemma tails_foldl_polysize_safe (hinit : polysize_fun l)
  (hf : polysize_fun_safe (λ (s : β × list γ) (x : α), f s.1 x s.2)) :
  polysize_fun_safe (λ (s : β) (y : (mk_iterator ↑(tails_foldl_step (f s)) (ff, l s, acc s)).states), tails_foldl_step (f s) (y : bool × list γ × α).2) :=
begin
  dsimp only [tails_foldl_step] at *,
  apply polysize_fun_safe.pair_left, { apply polysize_uniform_of_fin_range, },
  apply polysize_fun_safe.pair_left,
  { apply polysize_fun_uniform.comp' (polysize_fun_safe.tail _),
    apply acc_list_polysize_fun_uniform _ hinit, },
  change polysize_fun_safe (λ x y, (λ (s : β × list γ) (x : α), f s.1 x s.2) (x, (↑y : bool × list γ × α).2.1) (↑y : bool × list γ × α).2.2),
  apply polysize_fun_safe.comp hf,
  { apply polysize_fun_uniform.pair, { simpa using polysize_fun.id, }, apply acc_list_polysize_fun_uniform _ hinit, },
  refine polysize_fun_safe.comp' (polysize_fun_safe.snd _) _, refine polysize_fun_safe.comp' (polysize_fun_safe.snd _) _,
  use 0, intros, simp [penc_states_encode],
end

end

section list

variables {α β γ : Type*} [polycodable α] [polycodable β] [polycodable γ]
open ptree.pencodable (encode decode)

variable (H_enc : polytime_fun (λ l : ptree, ptree.equiv_list.symm $ l.equiv_list.map (encode ∘ (@decode γ _))))

def inh : inhabited γ := ⟨decode ptree.nil⟩
local attribute [instance] inh

include H_enc
-- List encoding aux; used very frequently, so better have a short name
def lea : polycodable (list γ) :=
{ polytime_decode := by simpa [encode, decode] using H_enc }

lemma polytime_fun.head_aux : polytime_fun (@list.head γ _) :=
by { letI := lea H_enc, rw polytime_fun_iff', use [code.left, polytime_left], intro x, cases x, { simp, refl, }, simp [ptree.pencodable.encode_list_def], }

lemma polytime_fun.tail_aux : polytime_fun (@list.tail γ) :=
⟨code.right, polytime_right,
by { intro x, cases x; simp [encode, decode], }⟩

lemma polytime_fun.cons_aux : polytime_fun₂ (@list.cons γ) :=
⟨code.id, polytime_id,
by { intro x, cases x; simp [encode], }⟩

lemma polytime_fun.is_empty_aux : polytime_fun (@list.empty γ) :=
by { letI := lea H_enc, classical, convert_to polytime_fun (λ l : list γ, (l = [] : bool)), { ext x, cases x; simp, }, polyfun, }

lemma polytime_fun.foldl_tails_aux {f : β → α → list γ → α} {l : β → list γ} {acc : β → α}
  (hf : polytime_fun₃ f) (hl : polytime_fun l) (hacc : polytime_fun acc)
  (hs : polysize_fun_safe (λ (a : β × list γ) (b : α), f a.1 b a.2)) :
  polytime_fun (λ s, (l s).tails.foldl (f s) (acc s)) :=
begin
  letI := lea H_enc,
  suffices : polytime_fun (λ s, (@list.nil γ, (l s).tails.foldl (f s) (acc s))), { exact polytime_fun.snd.comp this, },
  apply polytime_fun.evaln_of_polysize (λ (s : β) (x : list γ × α), tails_foldl_step (f s) x) (λ x, (ff, l x, acc x)) (λ s, 2 + (l s).length),
  { dunfold tails_foldl_step, have := polytime_fun.tail_aux H_enc, have := polytime_fun.is_empty_aux H_enc, polyfun, },
  { polyfun, }, rotate 1,
  { obtain ⟨q, hq⟩ := polysize_of_polytime_fun hl, use 2 + q, intros s, simpa using (len_le_encode_sizeof _).trans (hq _), },
  { intro s, simpa using tails_foldl_step_iter (f s) (l s, acc s), },
  exact tails_foldl_polysize_safe _ (polysize_of_polytime_fun hl) hs,
end

lemma polytime_fun.foldl_aux {f : β → α → γ → α} {l : β → list γ} {acc : β → α}
  (hf : polytime_fun₃ f) (hl : polytime_fun l) (hacc : polytime_fun acc)
  (hs : polysize_fun_safe (λ (a : β × γ) (b : α), f a.1 b a.2)) :
  polytime_fun (λ s, (l s).foldl (f s) (acc s)) :=
begin
  letI := lea H_enc,
  convert_to polytime_fun (λ s, (l s).tails.foldl (λ (a : α) (ls : list γ), if ls.empty then a else f s a ls.head) (acc s)),
  { ext s, generalize : acc s = a, induction l s with hd tl ih generalizing a, { simp, }, simp [ih], },
  apply polytime_fun.foldl_tails_aux H_enc,
  { have := polytime_fun.head_aux H_enc, have := polytime_fun.is_empty_aux H_enc, polyfun, },
  { exact hl, }, { exact hacc, },
  apply polysize_fun_safe.ite, { apply polysize_fun_safe.id, },
  change polysize_fun_safe (λ (x : β × list γ) (y : α), (λ (a : β × γ) (b : α), f a.1 b a.2) (x.1, x.2.head) y),
  apply hs.comp, { have := polytime_fun.head_aux H_enc, simp, apply polysize_of_polytime_fun, polyfun, }, { exact polysize_fun_safe.id, },
end

lemma polytime_fun.reverse_aux : polytime_fun (@list.reverse γ) :=
begin
  letI := lea H_enc,
  convert_to polytime_fun (λ l : list γ, l.foldl (λ acc hd, hd :: acc) []),
  { ext l : 1, rw ← list.foldr_reverse, simp, },
  apply polytime_fun.foldl_aux H_enc, { have := polytime_fun.cons_aux H_enc, polyfun, }, { polyfun, }, { polyfun, },
  apply polysize_fun_safe.comp polysize_fun_safe.cons, { simp, apply polysize_of_polytime_fun, polyfun, }, exact polysize_fun_safe.id,
end

lemma polytime_fun.foldr_aux {f : β → γ → α → α} {l : β → list γ} {acc : β → α}
  (hf : polytime_fun₃ f) (hl : polytime_fun l) (hacc : polytime_fun acc)
  (hs : polysize_fun_safe (λ (a : β × γ) (b : α), f a.1 a.2 b)) :
  polytime_fun (λ s, (l s).foldr (f s) (acc s)) :=
begin
  letI := lea H_enc,
  simp only [← list.foldl_reverse],
  apply polytime_fun.foldl_aux H_enc, { polyfun, }, { have := polytime_fun.reverse_aux H_enc, polyfun, }, { polyfun, },
  exact hs,
end

lemma polytime_fun.map_aux
  (H_enc' : polytime_fun (λ l : ptree, ptree.equiv_list.symm $ l.equiv_list.map (encode ∘ (@decode α _))))
  {f : β → γ → α} {l : β → list γ} (hf : polytime_fun₂ f) (hl : polytime_fun l) :
  polytime_fun (λ s, (l s).map (f s)) :=
begin
  letI := lea H_enc, letI := lea H_enc',
  convert_to polytime_fun (λ s, (l s).foldr (λ hd acc, (f s hd) :: acc) []),
  { ext s : 1, induction l s with hd tl ih, { simp, }, simp [ih], },
  apply polytime_fun.foldr_aux H_enc,
  { have := polytime_fun.cons_aux H_enc', polyfun, }, { exact hl, }, { polyfun, },
  apply polysize_fun_safe.comp polysize_fun_safe.cons, { simp, apply polysize_of_polytime_fun, exact hf, }, { exact polysize_fun_safe.id, },
end

end list

section list_ptree
open ptree.pencodable (encode decode)

def list_ptree_encode : polycodable (list ptree) :=
lea ⟨code.id, polytime_id, by simp [encode, decode]⟩

local attribute [instance] list_ptree_encode

@[polyfun]
lemma polytime_fun.equiv_list : polytime_fun ptree.equiv_list :=
⟨_, polytime_id, by simp [encode]⟩

@[polyfun]
lemma polytime_fun.equiv_list_symm : polytime_fun ptree.equiv_list.symm :=
⟨_, polytime_id, by simp [encode]⟩

lemma H_enc {γ : Type*} [polycodable γ] :
  polytime_fun (λ l : ptree, ptree.equiv_list.symm $ l.equiv_list.map (encode ∘ (@decode γ _))) :=
begin
  refine polytime_fun.equiv_list_symm.comp (polytime_fun.comp _ polytime_fun.equiv_list),
  apply polytime_fun.map_aux, iterate 2 { simpa using polytime_fun.id, },
  { /- TODO: Debug -/ dunfold polytime_fun₂ function.uncurry, apply polytime_fun.comp; polyfun, }, polyfun,
end

end list_ptree

section list
open ptree.pencodable (encode decode)

variables {α β γ : Type*} [polycodable α] [polycodable β] [polycodable γ]
instance : polycodable (list α) :=
lea H_enc

lemma polytime_fun.head : polytime_fun (@list.head γ ⟨decode ptree.nil⟩) :=
polytime_fun.head_aux H_enc

local attribute [polyfun] polytime_fun.head

@[polyfun]
lemma polytime_fun.tail : polytime_fun (@list.tail γ) :=
polytime_fun.tail_aux H_enc

@[polyfun]
lemma polytime_fun.cons : polytime_fun₂ (@list.cons γ) :=
polytime_fun.cons_aux H_enc

@[polyfun]
lemma polytime_fun.is_empty : polytime_fun (@list.empty γ) :=
polytime_fun.is_empty_aux H_enc

@[polyfun]
lemma polytime_fun.head' : polytime_fun (@list.head' γ) :=
begin
  convert_to polytime_fun (λ l : list γ, if l.empty then none else some (@list.head _ ⟨decode ptree.nil⟩ l)),
  { ext l : 1, cases l; simp, }, polyfun,
end

@[polyfun]
lemma polytime_fun.ihead [inhabited γ] : polytime_fun (@list.head γ _) :=
begin
  convert_to polytime_fun (λ l : list γ, l.head'.iget),
  { ext l, cases l; simp, }, polyfun,
end

local attribute [-polyfun] polytime_fun.head

lemma polytime_fun.foldl_tails {f : β → α → list γ → α} {l : β → list γ} {acc : β → α}
  (hf : polytime_fun₃ f) (hl : polytime_fun l) (hacc : polytime_fun acc)
  (hs : polysize_fun_safe (λ (a : β × list γ) (b : α), f a.1 b a.2)) :
  polytime_fun (λ s, (l s).tails.foldl (f s) (acc s)) := polytime_fun.foldl_tails_aux H_enc hf hl hacc hs

@[polyfun]
lemma polytime_fun.foldl {f : β → α → γ → α} {l : β → list γ} {acc : β → α}
  (hf : polytime_fun₃ f) (hl : polytime_fun l) (hacc : polytime_fun acc)
  (hs : polysize_fun_safe (λ (a : β × γ) (b : α), f a.1 b a.2)) :
  polytime_fun (λ s, (l s).foldl (f s) (acc s)) := polytime_fun.foldl_aux H_enc hf hl hacc hs

@[polyfun]
lemma polytime_fun.reverse : polytime_fun (@list.reverse γ) := polytime_fun.reverse_aux H_enc

@[polyfun]
lemma polytime_fun.foldr {f : β → γ → α → α} {l : β → list γ} {acc : β → α}
  (hf : polytime_fun₃ f) (hl : polytime_fun l) (hacc : polytime_fun acc)
  (hs : polysize_fun_safe (λ (a : β × γ) (b : α), f a.1 a.2 b)) :
  polytime_fun (λ s, (l s).foldr (f s) (acc s)) := polytime_fun.foldr_aux H_enc hf hl hacc hs

@[polyfun]
lemma polytime_fun.map
  {f : β → γ → α} {l : β → list γ} (hf : polytime_fun₂ f) (hl : polytime_fun l) :
  polytime_fun (λ s, (l s).map (f s)) := polytime_fun.map_aux H_enc H_enc hf hl

@[polyfun]
lemma polytime_fun.filter {f : β → γ → bool} {l : β → list γ} (hf : polytime_fun₂ f) (hl : polytime_fun l) :
  polytime_fun (λ s, (l s).filter (λ x, f s x)) :=
begin
  convert_to polytime_fun (λ s, (l s).foldr (λ hd acc, if f s hd then hd :: acc else acc) []),
  { ext s : 1, induction l s with hd tl ih, { simp, }, cases H : f s hd; simpa [H], },
  polyfun, apply polysize_fun_safe.ite, { refine polysize_fun_safe.comp polysize_fun_safe.cons _ polysize_fun_safe.id, simp, exact polysize_of_polytime_fun polytime_fun.snd, }, exact polysize_fun_safe.id,
end

@[polyfun]
lemma polytime_fun.append : polytime_fun₂ (λ (l₁ l₂ : list α), l₁ ++ l₂) :=
begin
  convert_to polytime_fun₂ (λ (l₁ l₂ : list α), l₁.foldr list.cons l₂),
  { ext l₁ l₂ : 2, induction l₁ with hd tl ih, { simp, }, { simp [ih], } },
  polyfun, apply polysize_fun_safe.cons.comp, { simp, apply polysize_of_polytime_fun polytime_fun.snd, }, exact polysize_fun_safe.id,
end

@[polyfun]
lemma polytime_fun.tails : polytime_fun (@list.tails α) :=
begin
  convert_to polytime_fun (λ l : list α, (l.tails.foldl (λ acc x, x :: acc) []).reverse),
  { simp, }, apply polytime_fun.comp, { polyfun, }, apply polytime_fun.foldl_tails,
  { polyfun, }, { polyfun, }, { polyfun, }, apply polysize_fun_safe.cons.comp, { simp, apply polysize_of_polytime_fun polytime_fun.snd, }, exact polysize_fun_safe.id,
end

def unary_nat_encode : polycodable ℕ :=
polycodable.of_equiv equiv.list_unit_equiv.symm

local attribute [instance] unary_nat_encode

lemma unary_nat_encode_eq (n : ℕ) : encode n = encode (list.repeat () n) := rfl

@[polyfun]
lemma polytime_fun.unary_length : polytime_fun (@list.length α) :=
begin
  convert_to polytime_fun (λ l : list α, equiv.list_unit_equiv (l.map (λ _, ()))),
  { ext l, simp [equiv.list_unit_equiv], }, polyfun, exact polycodable.of_equiv_polytime_symm _,
end

@[polyfun]
lemma polytime_fun.unary_repeat : polytime_fun₂ (@list.repeat α) :=
begin
  convert_to polytime_fun₂ (λ (x : α) (n : ℕ), (equiv.list_unit_equiv.symm n).map (λ _, x)),
  { ext : 2, simp [equiv.list_unit_equiv], }, polyfun,
end

@[polyfun]
lemma polytime_fun.unary_nat_add : polytime_fun₂ ((+) : ℕ → ℕ → ℕ) :=
begin
  convert_to polytime_fun₂ (λ n m, (list.repeat () n ++ list.repeat () m).length),
  { ext, simp, }, polyfun,
end

lemma _root_.list.drop_succ {α : Type*} (l : list α) (n : ℕ) :
  l.drop (n+1) = l.tail.drop n :=
by { induction l; simp, }

@[polyfun]
lemma polytime_fun.drop : polytime_fun₂ (@list.drop α) :=
begin
  convert_to polytime_fun₂ (λ (n : ℕ) (l : list α), (list.repeat () n).foldr (λ _ (l' : list α), l'.tail) l),
  { ext n l : 2, rw list.foldr_const, simp, induction n generalizing l; simp [list.drop_succ, *], },
  polyfun, exact polysize_fun_safe.tail _,
end

@[polyfun]
lemma polytime_fun.nth : polytime_fun₂ (@list.nth α) :=
begin
  convert_to polytime_fun₂ (λ (l : list α) n, (l.drop n).head'),
  { ext l n : 2, simp [← list.nth_zero, list.nth_drop], },
  polyfun,
end

@[polyfun]
lemma polytime_fun.tsub : polytime_fun₂ (@has_sub.sub ℕ _) :=
begin
  convert_to polytime_fun₂ (λ (m n : ℕ), ((list.repeat () m).drop n).length),
  { ext m n, simp, }, polyfun,
end

@[polyfun]
lemma polytime_fun.last : polytime_fun (@list.last' α) :=
by { convert_to polytime_fun (λ l : list α, l.reverse.head'), { ext l : 1, induction l using list.reverse_rec_on; simp, }, polyfun, }

@[polyfun]
lemma polytime_fun.filter_map {f : β → α → option γ} {l : β → list α}
  (hf : polytime_fun₂ f) (hl : polytime_fun l) :
  polytime_fun (λ s, (l s).filter_map (f s)) :=
begin
  inhabit γ,
  convert_to polytime_fun (λ s, (((l s).map (λ x, f s x)).filter (λ x : option γ, x.is_some)).map option.iget),
  { ext s : 1, induction l s with hd tl ih, { simp, }, cases H : f s hd, { simpa [H], }, { simpa [list.filter_map_cons_some _ _ _ H, H], } },
  polyfun,
end

@[simp] lemma _root_.list.filter_map_none (l : list α) :
  l.filter_map (λ _, (none : option β)) = [] :=
by { induction l; simp [*], }

lemma zip_eq_inits_map [inhabited α] (l₁ : list α) (l₂ : list β) :
  l₁.zip l₂ = l₁.inits.tail.filter_map (λ x, (l₂.nth (x.length - 1)).map (λ y, (x.last'.iget, y))) :=
begin
  induction l₁ with hd tl ih generalizing l₂,
  { simp, },
  cases l₂ with h₂ t₂, { simp, },
  simp [list.filter_map_map, function.comp],
  cases tl, { simp, rw list.filter_map_cons_some, { simp, }, simp, },
  simp, rw list.filter_map_cons_some, swap, { simp, },
  rw ih t₂, simp [list.filter_map_map, function.comp],
end

@[polyfun]
lemma polytime_fun.inits : polytime_fun (@list.inits α) :=
by { convert_to polytime_fun (λ l : list α, (l.reverse.tails.map list.reverse).reverse), { simp [list.tails_reverse], }, polyfun, }

@[polyfun]
lemma polytime_fun.zip : polytime_fun₂ (@list.zip α β) :=
begin
  inhabit α,
  change polytime_fun₂ (λ l₁ l₂, list.zip l₁ l₂), simp_rw zip_eq_inits_map, polyfun,
end

@[polyfun]
lemma polytime_fun.all {f : β → α → bool} {l : β → list α}
  (hf : polytime_fun₂ f) (hl : polytime_fun l) : polytime_fun (λ s, (l s).all (f s)) :=
by { dunfold list.all, polyfun, exact (polysize_uniform_of_fin_range _).to_safe, }

@[polyfun]
lemma polytime_fun.unary_nat_le {f g : β → ℕ} (hf : polytime_fun f) (hg : polytime_fun g) :
  polytime_fun (λ s, ((f s) ≤ (g s) : bool)) :=
by { convert_to polytime_fun (λ s, ((f s) - (g s) = 0 : bool)), { simp, }, polyfun, }

@[polyfun]
lemma polytime_fun.list_join : polytime_fun (@list.join α) :=
begin
  convert_to polytime_fun (λ l : list (list α), l.foldr (++) []),
  { ext l : 1, induction l; simp [*],}, polyfun, apply polysize_fun_safe.append.comp,
  { simp, apply polysize_of_polytime_fun, polyfun, }, { exact polysize_fun_safe.id, }
end

end list

section examples

def list_product {α β} (l₁ : list α) (l₂ : list β) : list (α × β) :=
(l₁.map (λ x, l₂.map (λ y, (x, y)))).join

example {α β : Type*} [polycodable α] [polycodable β] :
  polytime_fun₂ (λ (l₁ : list α) (l₂ : list β), list_product l₁ l₂) :=
by { dunfold list_product, polyfun, }

end examples


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Sébastien Gouëzel, Patrick Massot
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.topology.uniform_space.cauchy
import Mathlib.topology.uniform_space.separation
import Mathlib.topology.dense_embedding
import Mathlib.PostPort

universes u_1 u_2 l u_3 u_4

namespace Mathlib

/-!
# Uniform embeddings of uniform spaces.

Extension of uniform continuous functions.
-/

structure uniform_inducing {α : Type u_1} {β : Type u_2} [uniform_space α] [uniform_space β] (f : α → β)
where
  comap_uniformity : filter.comap (fun (x : α × α) => (f (prod.fst x), f (prod.snd x))) (uniformity β) = uniformity α

theorem uniform_inducing.mk' {α : Type u_1} {β : Type u_2} [uniform_space α] [uniform_space β] {f : α → β} (h : ∀ (s : set (α × α)),
  s ∈ uniformity α ↔ ∃ (t : set (β × β)), ∃ (H : t ∈ uniformity β), ∀ (x y : α), (f x, f y) ∈ t → (x, y) ∈ s) : uniform_inducing f := sorry

theorem uniform_inducing.comp {α : Type u_1} {β : Type u_2} {γ : Type u_3} [uniform_space α] [uniform_space β] [uniform_space γ] {g : β → γ} (hg : uniform_inducing g) {f : α → β} (hf : uniform_inducing f) : uniform_inducing (g ∘ f) := sorry

structure uniform_embedding {α : Type u_1} {β : Type u_2} [uniform_space α] [uniform_space β] (f : α → β)
extends uniform_inducing f
where
  inj : function.injective f

theorem uniform_embedding_subtype_val {α : Type u_1} [uniform_space α] {p : α → Prop} : uniform_embedding subtype.val :=
  uniform_embedding.mk (uniform_inducing.mk rfl) subtype.val_injective

theorem uniform_embedding_subtype_coe {α : Type u_1} [uniform_space α] {p : α → Prop} : uniform_embedding coe :=
  uniform_embedding_subtype_val

theorem uniform_embedding_set_inclusion {α : Type u_1} [uniform_space α] {s : set α} {t : set α} (hst : s ⊆ t) : uniform_embedding (set.inclusion hst) := sorry

theorem uniform_embedding.comp {α : Type u_1} {β : Type u_2} {γ : Type u_3} [uniform_space α] [uniform_space β] [uniform_space γ] {g : β → γ} (hg : uniform_embedding g) {f : α → β} (hf : uniform_embedding f) : uniform_embedding (g ∘ f) := sorry

theorem uniform_embedding_def {α : Type u_1} {β : Type u_2} [uniform_space α] [uniform_space β] {f : α → β} : uniform_embedding f ↔
  function.injective f ∧
    ∀ (s : set (α × α)),
      s ∈ uniformity α ↔ ∃ (t : set (β × β)), ∃ (H : t ∈ uniformity β), ∀ (x y : α), (f x, f y) ∈ t → (x, y) ∈ s := sorry

theorem uniform_embedding_def' {α : Type u_1} {β : Type u_2} [uniform_space α] [uniform_space β] {f : α → β} : uniform_embedding f ↔
  function.injective f ∧
    uniform_continuous f ∧
      ∀ (s : set (α × α)),
        s ∈ uniformity α → ∃ (t : set (β × β)), ∃ (H : t ∈ uniformity β), ∀ (x y : α), (f x, f y) ∈ t → (x, y) ∈ s := sorry

theorem uniform_inducing.uniform_continuous {α : Type u_1} {β : Type u_2} [uniform_space α] [uniform_space β] {f : α → β} (hf : uniform_inducing f) : uniform_continuous f := sorry

theorem uniform_inducing.uniform_continuous_iff {α : Type u_1} {β : Type u_2} {γ : Type u_3} [uniform_space α] [uniform_space β] [uniform_space γ] {f : α → β} {g : β → γ} (hg : uniform_inducing g) : uniform_continuous f ↔ uniform_continuous (g ∘ f) := sorry

theorem uniform_inducing.inducing {α : Type u_1} {β : Type u_2} [uniform_space α] [uniform_space β] {f : α → β} (h : uniform_inducing f) : inducing f := sorry

theorem uniform_inducing.prod {α : Type u_1} {β : Type u_2} [uniform_space α] [uniform_space β] {α' : Type u_3} {β' : Type u_4} [uniform_space α'] [uniform_space β'] {e₁ : α → α'} {e₂ : β → β'} (h₁ : uniform_inducing e₁) (h₂ : uniform_inducing e₂) : uniform_inducing fun (p : α × β) => (e₁ (prod.fst p), e₂ (prod.snd p)) := sorry

theorem uniform_inducing.dense_inducing {α : Type u_1} {β : Type u_2} [uniform_space α] [uniform_space β] {f : α → β} (h : uniform_inducing f) (hd : dense_range f) : dense_inducing f :=
  dense_inducing.mk (inducing.mk (inducing.induced (uniform_inducing.inducing h))) hd

theorem uniform_embedding.embedding {α : Type u_1} {β : Type u_2} [uniform_space α] [uniform_space β] {f : α → β} (h : uniform_embedding f) : embedding f :=
  embedding.mk (inducing.mk (inducing.induced (uniform_inducing.inducing (uniform_embedding.to_uniform_inducing h))))
    (uniform_embedding.inj h)

theorem uniform_embedding.dense_embedding {α : Type u_1} {β : Type u_2} [uniform_space α] [uniform_space β] {f : α → β} (h : uniform_embedding f) (hd : dense_range f) : dense_embedding f :=
  dense_embedding.mk
    (dense_inducing.mk (inducing.mk (inducing.induced (embedding.to_inducing (uniform_embedding.embedding h)))) hd)
    (uniform_embedding.inj h)

theorem closure_image_mem_nhds_of_uniform_inducing {α : Type u_1} {β : Type u_2} [uniform_space α] [uniform_space β] {s : set (α × α)} {e : α → β} (b : β) (he₁ : uniform_inducing e) (he₂ : dense_inducing e) (hs : s ∈ uniformity α) : ∃ (a : α), closure (e '' set_of fun (a' : α) => (a, a') ∈ s) ∈ nhds b := sorry

theorem uniform_embedding_subtype_emb {α : Type u_1} {β : Type u_2} [uniform_space α] [uniform_space β] (p : α → Prop) {e : α → β} (ue : uniform_embedding e) (de : dense_embedding e) : uniform_embedding (dense_embedding.subtype_emb p e) := sorry

theorem uniform_embedding.prod {α : Type u_1} {β : Type u_2} [uniform_space α] [uniform_space β] {α' : Type u_3} {β' : Type u_4} [uniform_space α'] [uniform_space β'] {e₁ : α → α'} {e₂ : β → β'} (h₁ : uniform_embedding e₁) (h₂ : uniform_embedding e₂) : uniform_embedding fun (p : α × β) => (e₁ (prod.fst p), e₂ (prod.snd p)) := sorry

theorem is_complete_of_complete_image {α : Type u_1} {β : Type u_2} [uniform_space α] [uniform_space β] {m : α → β} {s : set α} (hm : uniform_inducing m) (hs : is_complete (m '' s)) : is_complete s := sorry

/-- A set is complete iff its image under a uniform embedding is complete. -/
theorem is_complete_image_iff {α : Type u_1} {β : Type u_2} [uniform_space α] [uniform_space β] {m : α → β} {s : set α} (hm : uniform_embedding m) : is_complete (m '' s) ↔ is_complete s := sorry

theorem complete_space_iff_is_complete_range {α : Type u_1} {β : Type u_2} [uniform_space α] [uniform_space β] {f : α → β} (hf : uniform_embedding f) : complete_space α ↔ is_complete (set.range f) := sorry

theorem complete_space_congr {α : Type u_1} {β : Type u_2} [uniform_space α] [uniform_space β] {e : α ≃ β} (he : uniform_embedding ⇑e) : complete_space α ↔ complete_space β := sorry

theorem complete_space_coe_iff_is_complete {α : Type u_1} [uniform_space α] {s : set α} : complete_space ↥s ↔ is_complete s :=
  iff.trans (complete_space_iff_is_complete_range uniform_embedding_subtype_coe)
    (eq.mpr (id (Eq._oldrec (Eq.refl (is_complete (set.range coe) ↔ is_complete s)) subtype.range_coe))
      (iff.refl (is_complete s)))

theorem is_complete.complete_space_coe {α : Type u_1} [uniform_space α] {s : set α} (hs : is_complete s) : complete_space ↥s :=
  iff.mpr complete_space_coe_iff_is_complete hs

theorem is_closed.complete_space_coe {α : Type u_1} [uniform_space α] [complete_space α] {s : set α} (hs : is_closed s) : complete_space ↥s :=
  is_complete.complete_space_coe (is_closed.is_complete hs)

theorem complete_space_extension {α : Type u_1} {β : Type u_2} [uniform_space α] [uniform_space β] {m : β → α} (hm : uniform_inducing m) (dense : dense_range m) (h : ∀ (f : filter β), cauchy f → ∃ (x : α), filter.map m f ≤ nhds x) : complete_space α := sorry

theorem totally_bounded_preimage {α : Type u_1} {β : Type u_2} [uniform_space α] [uniform_space β] {f : α → β} {s : set β} (hf : uniform_embedding f) (hs : totally_bounded s) : totally_bounded (f ⁻¹' s) := sorry

theorem uniform_embedding_comap {α : Type u_1} {β : Type u_2} {f : α → β} [u : uniform_space β] (hf : function.injective f) : uniform_embedding f :=
  uniform_embedding.mk (uniform_inducing.mk rfl) hf

theorem uniformly_extend_exists {α : Type u_1} {β : Type u_2} {γ : Type u_3} [uniform_space α] [uniform_space β] [uniform_space γ] {e : β → α} (h_e : uniform_inducing e) (h_dense : dense_range e) {f : β → γ} (h_f : uniform_continuous f) [complete_space γ] (a : α) : ∃ (c : γ), filter.tendsto f (filter.comap e (nhds a)) (nhds c) := sorry

theorem uniform_extend_subtype {α : Type u_1} {β : Type u_2} {γ : Type u_3} [uniform_space α] [uniform_space β] [uniform_space γ] [complete_space γ] {p : α → Prop} {e : α → β} {f : α → γ} {b : β} {s : set α} (hf : uniform_continuous fun (x : Subtype p) => f (subtype.val x)) (he : uniform_embedding e) (hd : ∀ (x : β), x ∈ closure (set.range e)) (hb : closure (e '' s) ∈ nhds b) (hs : is_closed s) (hp : ∀ (x : α), x ∈ s → p x) : ∃ (c : γ), filter.tendsto f (filter.comap e (nhds b)) (nhds c) := sorry

theorem uniformly_extend_of_ind {α : Type u_1} {β : Type u_2} {γ : Type u_3} [uniform_space α] [uniform_space β] [uniform_space γ] {e : β → α} (h_e : uniform_inducing e) (h_dense : dense_range e) {f : β → γ} (h_f : uniform_continuous f) [separated_space γ] (b : β) : dense_inducing.extend (uniform_inducing.dense_inducing h_e h_dense) f (e b) = f b :=
  dense_inducing.extend_eq_at (uniform_inducing.dense_inducing h_e h_dense) b
    (continuous.continuous_at (uniform_continuous.continuous h_f))

theorem uniformly_extend_unique {α : Type u_1} {β : Type u_2} {γ : Type u_3} [uniform_space α] [uniform_space β] [uniform_space γ] {e : β → α} (h_e : uniform_inducing e) (h_dense : dense_range e) {f : β → γ} [separated_space γ] {g : α → γ} (hg : ∀ (b : β), g (e b) = f b) (hc : continuous g) : dense_inducing.extend (uniform_inducing.dense_inducing h_e h_dense) f = g :=
  dense_inducing.extend_unique (uniform_inducing.dense_inducing h_e h_dense) hg hc

theorem uniformly_extend_spec {α : Type u_1} {β : Type u_2} {γ : Type u_3} [uniform_space α] [uniform_space β] [uniform_space γ] {e : β → α} (h_e : uniform_inducing e) (h_dense : dense_range e) {f : β → γ} (h_f : uniform_continuous f) [separated_space γ] [complete_space γ] (a : α) : filter.tendsto f (filter.comap e (nhds a))
  (nhds (dense_inducing.extend (uniform_inducing.dense_inducing h_e h_dense) f a)) := sorry

theorem uniform_continuous_uniformly_extend {α : Type u_1} {β : Type u_2} {γ : Type u_3} [uniform_space α] [uniform_space β] [uniform_space γ] {e : β → α} (h_e : uniform_inducing e) (h_dense : dense_range e) {f : β → γ} (h_f : uniform_continuous f) [separated_space γ] [cγ : complete_space γ] : uniform_continuous (dense_inducing.extend (uniform_inducing.dense_inducing h_e h_dense) f) := sorry


import data.fintype.card
import tactic.zify
import tactic.ring
import tactic.linarith
import defs

open sum

variables {α β α' β' : Type} {γ : β → Type}

def propagate_aux (init_carry : α → bool)
  (next_bit : Π (carry : α → bool) (bits : β → bool),
    (α → bool) × bool)
  (x : β → ℕ → bool) : ℕ → (α → bool) × bool
| 0 := next_bit init_carry (λ i, x i 0)
| (n+1) :=
next_bit (propagate_aux n).1 (λ i, x i (n+1))

def propagate (init_carry : α → bool)
  (next_bit : Π (carry : α → bool) (bits : β → bool),
    (α → bool) × bool)
  (x : β → ℕ → bool) (i : ℕ) : bool :=
(propagate_aux init_carry next_bit x i).2

@[simp] def propagate_carry (init_carry : α → bool)
  (next_bit : Π (carry : α → bool) (bits : β → bool),
    (α → bool))
  (x : β → ℕ → bool) : ℕ → (α → bool)
| 0 := next_bit init_carry (λ i, x i 0)
| (n+1) := next_bit (propagate_carry n) (λ i, x i (n+1))

@[simp] def propagate_carry2 (init_carry : α → bool)
  (next_bit : Π (carry : α → bool) (bits : β → bool),
    (α → bool))
  (x : β → ℕ → bool) : ℕ → (α → bool)
| 0 := init_carry
| (n+1) := next_bit (propagate_carry2 n) (λ i, x i n)

lemma propagate_carry2_succ (init_carry : α → bool)
  (next_bit : Π (carry : α → bool) (bits : β → bool),
    (α → bool))
  (x : β → ℕ → bool) (n : ℕ) :
  propagate_carry2 init_carry next_bit x (n+1) =
  propagate_carry init_carry next_bit x n :=
by induction n; simp *

@[simp] lemma propagate_aux_fst_eq_carry (init_carry : α → bool)
  (next_bit : Π (carry : α → bool) (bits : β → bool),
    (α → bool) × bool)
  (x : β → ℕ → bool) : ∀ n : ℕ,
  (propagate_aux init_carry next_bit x n).1 =
  propagate_carry init_carry (λ c b, (next_bit c b).1) x n
| 0 := rfl
| (n+1) := by rw [propagate_aux, propagate_carry, propagate_aux_fst_eq_carry]

@[simp] lemma propagate_zero (init_carry : α → bool)
  (next_bit : Π (carry : α → bool) (bits : β → bool),
  (α → bool) × bool)
  (x : β → ℕ → bool) :
  propagate init_carry next_bit x 0 = (next_bit init_carry (λ i, x i 0)).2 :=
rfl

lemma propagate_succ (init_carry : α → bool)
  (next_bit : Π (carry : α → bool) (bits : β → bool),
    (α → bool) × bool)
  (x : β → ℕ → bool) (i : ℕ) :
  propagate init_carry next_bit x (i+1) = (next_bit
    (propagate_carry init_carry (λ c b, (next_bit c b).1) x i)
    (λ j, x j (i+1))).2 :=
by rw [← propagate_aux_fst_eq_carry]; refl

lemma propagate_succ2 (init_carry : α → bool)
  (next_bit : Π (carry : α → bool) (bits : β → bool),
    (α → bool) × bool)
  (x : β → ℕ → bool) (i : ℕ) :
  propagate init_carry next_bit x (i+1) = (next_bit
    (propagate_carry2 init_carry (λ c b, (next_bit c b).1) x (i+1))
    (λ j, x j (i+1))).2 :=
by rw [propagate_carry2_succ, ← propagate_aux_fst_eq_carry]; refl

lemma propagate_carry_propagate {δ : β → Type*} {β' : Type}
    (f : Π a, δ a → β') : Π (n : ℕ) (init_carry : α → bool)
  (next_bit : Π (carry : α → bool) (bits : β → bool),
    (α → bool))
  (init_carry_x : Π a, γ a → bool)
  (next_bit_x : Π a (carry : γ a → bool) (bits : δ a → bool),
    (γ a → bool) × bool)
  (x : β' → ℕ → bool),
  propagate_carry init_carry next_bit (λ a, propagate (init_carry_x a)
    (next_bit_x a) (λ d, x (f a d))) n =
  propagate_carry
    (λ a : α ⊕ (Σ a, γ a), sum.elim init_carry (λ b : Σ a, γ a,
      init_carry_x b.1 b.2) a)
    (λ (carry : (α ⊕ (Σ a, γ a)) → bool) (bits : β' → bool),
  -- first compute (propagate (init_carry_x a) (next_bit_x a) (x a) n)
      let f : Π (a : β), (γ a → bool) × bool := λ a, next_bit_x a (λ d,
        carry (inr ⟨a, d⟩)) (λ d, bits (f a d)) in
      let g : (α → bool) := (next_bit (carry ∘ inl) (λ a, (f a).2)) in
      sum.elim g (λ x, (f x.1).1 x.2)
    )
    x n ∘ inl
| 0 init_carry next_bit init_carry_x next_bit_x x := rfl
| (n+1) init_carry next_bit init_carry_x next_bit_x x := begin
  have := propagate_carry_propagate n,
  clear_aux_decl,
  simp only [propagate_carry, propagate_succ, elim_inl] at *,
  conv_lhs { simp only [this] },
  clear this,
  ext,
  congr,
  ext,
  congr,
  induction n with n ih,
  { simp },
  { simp [ih] }
end

lemma propagate_propagate {δ : β → Type*} {β' : Type}
    (f : Π a, δ a → β') : Π (n : ℕ) (init_carry : α → bool)
  (next_bit : Π (carry : α → bool) (bits : β → bool),
    (α → bool) × bool)
  (init_carry_x : Π a, γ a → bool)
  (next_bit_x : Π a (carry : γ a → bool) (bits : δ a → bool),
    (γ a → bool) × bool)
  (x : β' → ℕ → bool),
  propagate init_carry next_bit (λ a, propagate (init_carry_x a)
    (next_bit_x a) (λ d, x (f a d))) n =
  propagate
    (λ a : α ⊕ (Σ a, γ a), sum.elim init_carry (λ b : Σ a, γ a,
      init_carry_x b.1 b.2) a)
    (λ (carry : (α ⊕ (Σ a, γ a)) → bool) (bits : β' → bool),
      -- first compute (propagate (init_carry_x a) (next_bit_x a) (x a) n)
      let f : Π (a : β), (γ a → bool) × bool := λ a, next_bit_x a (λ d,
        carry (inr ⟨a, d⟩)) (λ d, bits (f a d)) in
      let g : (α → bool) × bool := (next_bit (carry ∘ inl) (λ a, (f a).2)) in
      (sum.elim g.1 (λ x, (f x.1).1 x.2), g.2)
    )
  x n
| 0 init_carry next_bit init_carry_x next_bit_x x := rfl
| (n+1) init_carry next_bit init_carry_x next_bit_x x := begin
  simp only [propagate_succ],
  clear_aux_decl,
  rw [propagate_carry_propagate],
  congr,
  ext,
  congr,
  induction n with n ih,
  { simp },
  { simp [ih] }
end

lemma propagate_carry_change_vars {β' : Type}
  (init_carry : α → bool)
  (next_bit : Π (carry : α → bool) (bits : β → bool),
    (α → bool))
  (x : β' → ℕ → bool) (i : ℕ)
  (change_vars : β → β') :
  propagate_carry init_carry next_bit (λ b, x (change_vars b)) i =
  propagate_carry init_carry (λ (carry : α → bool) (bits : β' → bool),
    next_bit carry (λ b, bits (change_vars b))) x i :=
begin
  induction i,
  { simp },
  { simp * }
end

lemma propagate_change_vars {β' : Type}
  (init_carry : α → bool)
  (next_bit : Π (carry : α → bool) (bits : β → bool),
    (α → bool) × bool)
  (x : β' → ℕ → bool) (i : ℕ)
  (change_vars : β → β') :
  propagate init_carry next_bit (λ b, x (change_vars b)) i =
  propagate init_carry (λ (carry : α → bool) (bits : β' → bool),
    next_bit carry (λ b, bits (change_vars b))) x i :=
begin
  induction i with i ih,
  { refl },
  { simp only [propagate_succ, propagate_carry_change_vars, ih] }
end

open term

@[simp] def arity : term → ℕ
| (var n) := n+1
| zero := 0
| one := 0
| neg_one := 0
| (and t₁ t₂) := max (arity t₁) (arity t₂)
| (or t₁ t₂) := max (arity t₁) (arity t₂)
| (xor t₁ t₂) := max (arity t₁) (arity t₂)
| (not t) := arity t
| (ls t) := arity t
| (add t₁ t₂) := max (arity t₁) (arity t₂)
| (sub t₁ t₂) := max (arity t₁) (arity t₂)
| (neg t) := arity t
| (incr t) := arity t
| (decr t) := arity t

@[simp] def term.eval_fin : Π (t : term) (vars : fin (arity t) → ℕ → bool), ℕ → bool
| (var n) vars := vars (fin.last n)
| zero vars := zero_seq
| one vars := one_seq
| neg_one vars := neg_one_seq
| (and t₁ t₂) vars :=
  and_seq (term.eval_fin t₁
    (λ i, vars (fin.cast_le (by simp [arity]) i)))
  (term.eval_fin t₂
    (λ i, vars (fin.cast_le (by simp [arity]) i)))
| (or t₁ t₂) vars :=
  or_seq (term.eval_fin t₁
    (λ i, vars (fin.cast_le (by simp [arity]) i)))
  (term.eval_fin t₂
    (λ i, vars (fin.cast_le (by simp [arity]) i)))
| (xor t₁ t₂) vars :=
  xor_seq (term.eval_fin t₁
    (λ i, vars (fin.cast_le (by simp [arity]) i)))
  (term.eval_fin t₂
    (λ i, vars (fin.cast_le (by simp [arity]) i)))
| (not t) vars := not_seq (term.eval_fin t vars)
| (ls t) vars := ls_seq (term.eval_fin t vars)
| (add t₁ t₂) vars :=
  add_seq (term.eval_fin t₁
    (λ i, vars (fin.cast_le (by simp [arity]) i)))
  (term.eval_fin t₂
    (λ i, vars (fin.cast_le (by simp [arity]) i)))
| (sub t₁ t₂) vars :=
  sub_seq (term.eval_fin t₁
    (λ i, vars (fin.cast_le (by simp [arity]) i)))
  (term.eval_fin t₂
    (λ i, vars (fin.cast_le (by simp [arity]) i)))
| (neg t) vars := neg_seq (term.eval_fin t vars)
| (incr t) vars := incr_seq (term.eval_fin t vars)
| (decr t) vars := decr_seq (term.eval_fin t vars)

lemma eval_fin_eq_eval (t : term) (vars : ℕ → ℕ → bool) :
  term.eval_fin t (λ i, vars i) = term.eval t vars :=
begin
  induction t;
  dsimp [term.eval_fin, term.eval, arity] at *; simp *
end

lemma id_eq_propagate (x : ℕ → bool) :
  x = propagate empty.elim (λ _ (y : unit → bool), (empty.elim, y ())) (λ _, x) :=
by ext n; cases n; refl

lemma zero_eq_propagate :
  zero_seq = propagate empty.elim (λ (_ _ : empty → bool), (empty.elim, ff)) empty.elim :=
by ext n; cases n; refl

lemma one_eq_propagate :
  one_seq = propagate (λ _ : unit, tt) (λ f (_ : empty → bool), (λ _, ff, f ())) empty.elim :=
begin
  ext n,
  cases n with n,
  { refl },
  { cases n,
    { simp [one_seq, propagate_succ] },
    { simp [one_seq, propagate_succ] } }
end

lemma and_eq_propagate (x y : ℕ → bool) :
  and_seq x y = propagate empty.elim
    (λ _ (y : bool → bool), (empty.elim, y tt && y ff)) (λ b, cond b x y) :=
by ext n; cases n; simp [propagate, propagate_aux, and_seq]

lemma or_eq_propagate (x y : ℕ → bool) :
  or_seq x y = propagate empty.elim
    (λ _ (y : bool → bool), (empty.elim, y tt || y ff)) (λ b, cond b x y) :=
by ext n; cases n; simp [propagate, propagate_aux, or_seq]

lemma xor_eq_propagate (x y : ℕ → bool) :
  xor_seq x y = propagate empty.elim
    (λ _ (y : bool → bool), (empty.elim, bxor (y tt) (y ff))) (λ b, cond b x y) :=
by ext n; cases n; simp [propagate, propagate_aux, xor_seq]

lemma not_eq_propagate (x : ℕ → bool) :
  not_seq x = propagate empty.elim (λ _ (y : unit → bool), (empty.elim, bnot (y ()))) (λ _, x) :=
by ext n; cases n; simp [propagate, propagate_aux, not_seq]

lemma ls_eq_propagate (x : ℕ → bool) :
  ls_seq x = propagate (λ _ : unit, ff) (λ (carry x : unit → bool), (x, carry ())) (λ _, x) :=
begin
  ext n,
  cases n with n,
  { refl },
  { cases n,
    { simp [ls_seq, propagate_succ] },
    { simp [ls_seq, propagate_succ] } }
end

lemma add_seq_aux_eq_propagate_carry (x y : ℕ → bool) (n : ℕ) :
  (add_seq_aux x y n).2 = propagate_carry (λ _, ff)
    (λ (carry : unit → bool) (bits : bool → bool),
      λ _, (bits tt && bits ff) || (bits ff && carry ()) || (bits tt && carry ()))
  (λ b, cond b x y) n () :=
begin
  induction n,
  { simp [add_seq_aux] },
  { simp [add_seq_aux, *] }
end

lemma add_eq_propagate (x y : ℕ → bool) :
  add_seq x y = propagate (λ _, ff)
    (λ (carry : unit → bool) (bits : bool → bool),
      (λ _, (bits tt && bits ff) || (bits ff && carry ()) || (bits tt && carry ()),
        bxor (bits tt) (bxor (bits ff) (carry ()))))
  (λ b, cond b x y) :=
begin
  ext n,
  cases n with n,
  { simp [add_seq, add_seq_aux] },
  { cases n,
    { simp [add_seq, add_seq_aux, propagate_succ] },
    { simp [add_seq, add_seq_aux, add_seq_aux_eq_propagate_carry,
        propagate_succ] } }
end

lemma sub_seq_aux_eq_propagate_carry (x y : ℕ → bool) (n : ℕ) :
  (sub_seq_aux x y n).2 = propagate_carry (λ _, ff)
    (λ (carry : unit → bool) (bits : bool → bool),
      λ _, (bnot (bits tt) && (bits ff)) ||
        (bnot (bxor (bits tt) (bits ff))) && carry ())
  (λ b, cond b x y) n () :=
begin
  induction n,
  { simp [sub_seq_aux] },
  { simp [sub_seq_aux, *] }
end

lemma sub_eq_propagate (x y : ℕ → bool) :
  sub_seq x y = propagate (λ _, ff)
    (λ (carry : unit → bool) (bits : bool → bool),
      (λ _, (bnot (bits tt) && (bits ff)) ||
        ((bnot (bxor (bits tt) (bits ff))) && carry ()),
        bxor (bits tt) (bxor (bits ff) (carry ()))))
  (λ b, cond b x y) :=
begin
  ext n,
  cases n with n,
  { simp [sub_seq, sub_seq_aux] },
  { cases n,
    { simp [sub_seq, sub_seq_aux, propagate_succ] },
    { simp [sub_seq, sub_seq_aux, sub_seq_aux_eq_propagate_carry,
        propagate_succ] } }
end

lemma neg_seq_aux_eq_propagate_carry (x : ℕ → bool) (n : ℕ) :
  (neg_seq_aux x n).2 = propagate_carry (λ _, tt)
    (λ (carry : unit → bool) (bits : unit → bool),
      λ _, (bnot (bits ())) && (carry ()))
  (λ _, x) n () :=
begin
  induction n,
  { simp [neg_seq_aux] },
  { simp [neg_seq_aux, *] }
end

lemma neg_eq_propagate (x : ℕ → bool) :
  neg_seq x = propagate (λ _, tt)
    (λ (carry : unit → bool) (bits : unit → bool),
      (λ _, (bnot (bits ())) && (carry ()), bxor (bnot (bits ())) (carry ())))
  (λ _, x) :=
begin
  ext n,
  cases n with n,
  { simp [neg_seq, neg_seq_aux] },
  { cases n,
    { simp [neg_seq, neg_seq_aux, propagate_succ] },
    { simp [neg_seq, neg_seq_aux, neg_seq_aux_eq_propagate_carry,
        propagate_succ] } }
end

lemma incr_seq_aux_eq_propagate_carry (x : ℕ → bool) (n : ℕ) :
  (incr_seq_aux x n).2 = propagate_carry (λ _, tt)
    (λ (carry : unit → bool) (bits : unit → bool),
      λ _, (bits ()) && carry ())
  (λ _, x) n () :=
begin
  induction n,
  { simp [incr_seq_aux] },
  { simp [incr_seq_aux, *] }
end

lemma incr_eq_propagate (x : ℕ → bool) :
  incr_seq x = propagate (λ _, tt)
    (λ (carry : unit → bool) (bits : unit → bool),
      (λ _, (bits ()) && carry (), bxor (bits ()) (carry ())))
  (λ _, x) :=
begin
  ext n,
  cases n with n,
  { simp [incr_seq, incr_seq_aux] },
  { cases n,
    { simp [incr_seq, incr_seq_aux, propagate_succ] },
    { simp [incr_seq, incr_seq_aux, incr_seq_aux_eq_propagate_carry,
        propagate_succ] } }
end

lemma decr_seq_aux_eq_propagate_carry (x : ℕ → bool) (n : ℕ) :
  (decr_seq_aux x n).2 = propagate_carry (λ _, tt)
    (λ (carry : unit → bool) (bits : unit → bool),
      λ _, (bnot (bits ())) && carry ())
  (λ _, x) n () :=
begin
  induction n,
  { simp [decr_seq_aux] },
  { simp [decr_seq_aux, *] }
end

lemma decr_eq_propagate (x : ℕ → bool) :
  decr_seq x = propagate (λ _, tt)
    (λ (carry : unit → bool) (bits : unit → bool),
      (λ _, (bnot (bits ())) && carry (), bxor (bits ()) (carry ())))
  (λ _, x) :=
begin
  ext n,
  cases n with n,
  { simp [decr_seq, decr_seq_aux] },
  { cases n,
    { simp [decr_seq, decr_seq_aux, propagate_succ] },
    { simp [decr_seq, decr_seq_aux, decr_seq_aux_eq_propagate_carry,
        propagate_succ] } }
end

structure propagate_struc (arity : Type) : Type 1 :=
( α  : Type )
[ i : fintype α ]
( init_carry : α → bool )
( next_bit : Π (carry : α → bool) (bits : arity → bool),
    (α → bool) × bool )

attribute [instance] propagate_struc.i

namespace propagate_struc

variables {arity : Type} (p : propagate_struc arity)

def eval : (arity → ℕ → bool) → ℕ → bool :=
propagate p.init_carry p.next_bit

def change_vars {arity2 : Type} (change_vars : arity → arity2) :
  propagate_struc arity2 :=
{ α := p.α,
  i := p.i,
  init_carry := p.init_carry,
  next_bit := λ carry bits, p.next_bit carry (λ i, bits (change_vars i)) }

def compose [fintype arity]
  (new_arity : Type)
  (q_arity : arity → Type)
  (vars : Π (a : arity), q_arity a → new_arity)
  (q : Π (a : arity), propagate_struc (q_arity a)) :
  propagate_struc (new_arity) :=
{ α := p.α ⊕ (Σ a, (q a).α),
  i := by letI := p.i; apply_instance,
  init_carry := sum.elim p.init_carry (λ x, (q x.1).init_carry x.2),
  next_bit := λ carry bits,
    let f : Π (a : arity), ((q a).α → bool) × bool := λ a, (q a).next_bit (λ d,
        carry (inr ⟨a, d⟩)) (λ d, bits (vars a d)) in
    let g : (p.α → bool) × bool := (p.next_bit (carry ∘ inl) (λ a, (f a).2)) in
    (sum.elim g.1 (λ x, (f x.1).1 x.2), g.2) }

lemma eval_compose [fintype arity]
  (new_arity : Type)
  (q_arity : arity → Type)
  (vars : Π (a : arity), q_arity a → new_arity)
  (q : Π (a : arity), propagate_struc (q_arity a))
  (x : new_arity → ℕ → bool):
  (p.compose new_arity q_arity vars q).eval x =
  p.eval (λ a, (q a).eval (λ i, x (vars _ i))) :=
begin
  ext n,
  simp only [eval, compose, propagate_propagate]
end

def and : propagate_struc bool :=
{ α := empty,
  i := by apply_instance,
  init_carry := empty.elim,
  next_bit := λ carry bits, (empty.elim, bits tt && bits ff) }

@[simp] lemma eval_and (x : bool → ℕ → bool) : and.eval x = and_seq (x tt) (x ff) :=
by ext n; cases n; simp [and, and_seq, eval, propagate_succ]

def or : propagate_struc bool :=
{ α := empty,
  i := by apply_instance,
  init_carry := empty.elim,
  next_bit := λ carry bits, (empty.elim, bits tt || bits ff) }

@[simp] lemma eval_or (x : bool → ℕ → bool) : or.eval x = or_seq (x tt) (x ff) :=
by ext n; cases n; simp [or, or_seq, eval, propagate_succ]

def xor : propagate_struc bool :=
{ α := empty,
  i := by apply_instance,
  init_carry := empty.elim,
  next_bit := λ carry bits, (empty.elim, bxor (bits tt) (bits ff)) }

@[simp] lemma eval_xor (x : bool → ℕ → bool) : xor.eval x = xor_seq (x tt) (x ff) :=
by ext n; cases n; simp [xor, xor_seq, eval, propagate_succ]

def add : propagate_struc bool :=
{ α := unit,
  i := by apply_instance,
  init_carry := λ _, ff,
  next_bit := λ (carry : unit → bool) (bits : bool → bool),
      (λ _, (bits tt && bits ff) || (bits ff && carry ()) || (bits tt && carry ()),
        bxor (bits tt) (bxor (bits ff) (carry ()))) }

@[simp] lemma eval_add (x : bool → ℕ → bool) : add.eval x = add_seq (x tt) (x ff) :=
begin
  dsimp [add, eval],
  rw [add_eq_propagate],
  congr,
  funext b,
  cases b; refl
end

def sub : propagate_struc bool :=
{ α := unit,
  i := by apply_instance,
  init_carry := λ _, ff,
  next_bit := λ (carry : unit → bool) (bits : bool → bool),
      (λ _, (bnot (bits tt) && (bits ff)) ||
        ((bnot (bxor (bits tt) (bits ff))) && carry ()),
        bxor (bits tt) (bxor (bits ff) (carry ()))) }

@[simp] lemma eval_sub (x : bool → ℕ → bool) : sub.eval x = sub_seq (x tt) (x ff) :=
begin
  dsimp [sub, eval],
  rw [sub_eq_propagate],
  congr,
  funext b,
  cases b; refl
end

def neg : propagate_struc unit :=
{ α := unit,
  i := by apply_instance,
  init_carry := λ _, tt,
  next_bit := λ (carry : unit → bool) (bits : unit → bool),
    (λ _, (bnot (bits ())) && (carry ()), bxor (bnot (bits ())) (carry ())) }

@[simp] lemma eval_neg (x : unit → ℕ → bool) : neg.eval x = neg_seq (x ()) :=
begin
  dsimp [neg, eval],
  rw [neg_eq_propagate],
  congr,
  funext b,
  cases b; refl
end

def not : propagate_struc unit :=
{ α := empty,
  i := by apply_instance,
  init_carry := empty.elim,
  next_bit := λ carry bits, (empty.elim, bnot (bits ())) }

@[simp] lemma eval_not (x : unit → ℕ → bool) : not.eval x = not_seq (x ()) :=
by ext n; cases n; simp [not, not_seq, eval, propagate_succ]

def zero : propagate_struc (fin 0) :=
{ α := empty,
  i := by apply_instance,
  init_carry := empty.elim,
  next_bit := λ carry bits, (empty.elim, ff) }

@[simp] lemma eval_zero (x : fin 0 → ℕ → bool) : zero.eval x = zero_seq :=
by ext n; cases n; simp [zero, zero_seq, eval, propagate_succ]

def one : propagate_struc (fin 0) :=
{ α := unit,
  i := by apply_instance,
  init_carry := λ _, tt,
  next_bit := λ carry bits, (λ _, ff, carry ()) }

@[simp] lemma eval_one (x : fin 0 → ℕ → bool) : one.eval x = one_seq :=
by ext n; cases n; simp [one, one_seq, eval, propagate_succ2]

def neg_one : propagate_struc (fin 0) :=
{ α := empty,
  i := by apply_instance,
  init_carry := empty.elim,
  next_bit := λ carry bits, (empty.elim, tt) }

@[simp] lemma eval_neg_one (x : fin 0 → ℕ → bool) : neg_one.eval x = neg_one_seq :=
by ext n; cases n; simp [neg_one, neg_one_seq, eval, propagate_succ2]

def ls : propagate_struc unit :=
{ α := unit,
  i := by apply_instance,
  init_carry := λ _, ff,
  next_bit := λ carry bits, (bits, carry ()) }

@[simp] lemma eval_ls (x : unit → ℕ → bool) : ls.eval x = ls_seq (x ()) :=
by ext n; cases n; simp [ls, ls_seq, eval, propagate_succ2]

def var (n : ℕ) : propagate_struc (fin (n+1)) :=
{ α := empty,
  i := by apply_instance,
  init_carry := empty.elim,
  next_bit := λ carry bits, (empty.elim, bits (fin.last n)) }

@[simp] lemma eval_var (n : ℕ) (x : fin (n+1) → ℕ → bool) : (var n).eval x = x (fin.last n) :=
by ext m; cases m; simp [var, eval, propagate_succ]

def incr : propagate_struc unit :=
{ α := unit,
  i := by apply_instance,
  init_carry := λ _, tt,
  next_bit := λ carry bits, (λ _, bits () && carry (), bxor (bits ()) (carry ())) }

@[simp] lemma eval_incr (x : unit → ℕ → bool) : incr.eval x = incr_seq (x ()) :=
begin
  dsimp [incr, eval],
  rw [incr_eq_propagate],
  congr,
  funext b,
  cases b; refl
end

def decr : propagate_struc unit :=
{ α := unit,
  i := by apply_instance,
  init_carry := λ _, tt,
  next_bit := λ carry bits, (λ _, bnot (bits ()) && carry (), bxor (bits ()) (carry ())) }

@[simp] lemma eval_decr (x : unit → ℕ → bool) : decr.eval x = decr_seq (x ()) :=
begin
  dsimp [decr, eval],
  rw [decr_eq_propagate],
  congr,
  funext b,
  cases b; refl
end

end propagate_struc

structure propagate_solution (t : term) extends propagate_struc (fin (arity t)) :=
( good : t.eval_fin = to_propagate_struc.eval )

def compose_unary
  (p : propagate_struc unit)
  {t : term}
  (q : propagate_solution t) :
  propagate_struc (fin (arity t)) :=
p.compose
  (fin (arity t))
  _
  (λ _ , id)
  (λ _, q.to_propagate_struc)

def compose_binary
  (p : propagate_struc bool)
  {t₁ t₂ : term}
  (q₁ : propagate_solution t₁)
  (q₂ : propagate_solution t₂) :
  propagate_struc (fin (max (arity t₁) (arity t₂))) :=
p.compose (fin (max (arity t₁) (arity t₂)))
  (λ b, fin (cond b (arity t₁) (arity t₂)))
  (λ b i, fin.cast_le (by cases b; simp) i)
  (λ b, bool.rec q₂.to_propagate_struc q₁.to_propagate_struc b)

@[simp] lemma compose_unary_eval
  (p : propagate_struc unit)
  {t : term}
  (q : propagate_solution t)
  (x : fin (arity t) → ℕ → bool) :
  (compose_unary p q).eval x = p.eval (λ _, t.eval_fin x) :=
begin
  rw [compose_unary, propagate_struc.eval_compose, q.good],
  refl
end

@[simp] lemma compose_binary_eval
  (p : propagate_struc bool)
  {t₁ t₂ : term}
  (q₁ : propagate_solution t₁)
  (q₂ : propagate_solution t₂)
  (x : fin (max (arity t₁) (arity t₂)) → ℕ → bool) :
  (compose_binary p q₁ q₂).eval x = p.eval
    (λ b, cond b (t₁.eval_fin (λ i, x (fin.cast_le (by simp) i)))
                 (t₂.eval_fin (λ i, x (fin.cast_le (by simp) i)))) :=
begin
  rw [compose_binary, propagate_struc.eval_compose, q₁.good, q₂.good],
  congr,
  ext b,
  cases b; refl
end

instance {α β : Type*} [fintype α] [fintype β] (b : bool) :
  fintype (cond b α β) :=
by cases b; dsimp; apply_instance

lemma cond_propagate {α α' β β' : Type}
  (init_carry : α → bool)
  (next_bit : Π (carry : α → bool) (bits : β → bool),
    (α → bool) × bool)
  (init_carry' : α' → bool)
  (next_bit' : Π (carry : α' → bool) (bits : β' → bool),
    (α' → bool) × bool)
  {γ : Type} (fβ : β → γ) (fβ' : β' → γ)
  (x : γ → ℕ → bool) (b : bool) :
  cond b (propagate init_carry next_bit (λ b, (x (fβ b))))
    (propagate init_carry' next_bit' (λ b, (x (fβ' b)))) =
  propagate (show cond b α α' → bool, from bool.rec init_carry' init_carry b)
    (show Π (carry : cond b α α' → bool) (bits : cond b β β' → bool),
        (cond b α α' → bool) × bool,
      from bool.rec next_bit' next_bit b)
    (show cond b β β' → ℕ → bool, from bool.rec (λ b, (x (fβ' b))) (λ b, (x (fβ b))) b) :=
by cases b; refl

def term_eval_eq_propagate : Π (t : term),
  propagate_solution t
| (var n) :=
  { to_propagate_struc := propagate_struc.var n,
    good := by ext; simp [term.eval_fin] }
| zero :=
  { to_propagate_struc := propagate_struc.zero,
    good := by ext; simp [term.eval_fin] }
| one :=
  { to_propagate_struc := propagate_struc.one,
    good := by ext; simp [term.eval_fin] }
| neg_one :=
  { to_propagate_struc := propagate_struc.neg_one,
    good := by ext; simp [term.eval_fin] }
| (and t₁ t₂) :=
  let q₁ := term_eval_eq_propagate t₁ in
  let q₂ := term_eval_eq_propagate t₂ in
  { to_propagate_struc := compose_binary propagate_struc.and q₁ q₂,
    good := by ext; simp; refl }
| (or t₁ t₂) :=
  let q₁ := term_eval_eq_propagate t₁ in
  let q₂ := term_eval_eq_propagate t₂ in
  { to_propagate_struc := compose_binary propagate_struc.or q₁ q₂,
    good := by ext; simp; refl }
| (xor t₁ t₂) :=
  let q₁ := term_eval_eq_propagate t₁ in
  let q₂ := term_eval_eq_propagate t₂ in
  { to_propagate_struc := compose_binary propagate_struc.xor q₁ q₂,
    good := by ext; simp; refl }
| (ls t) :=
  let q := term_eval_eq_propagate t in
  { to_propagate_struc := by dsimp [arity]; exact compose_unary propagate_struc.ls q,
    good := by ext; simp; refl }
| (not t) :=
  let q := term_eval_eq_propagate t in
  { to_propagate_struc := by dsimp [arity]; exact compose_unary propagate_struc.not q,
    good := by ext; simp; refl }
| (add t₁ t₂) :=
  let q₁ := term_eval_eq_propagate t₁ in
  let q₂ := term_eval_eq_propagate t₂ in
  { to_propagate_struc := compose_binary propagate_struc.add q₁ q₂,
    good := by ext; simp; refl }
| (sub t₁ t₂) :=
  let q₁ := term_eval_eq_propagate t₁ in
  let q₂ := term_eval_eq_propagate t₂ in
  { to_propagate_struc := compose_binary propagate_struc.sub q₁ q₂,
    good := by ext; simp; refl }
| (neg t) :=
  let q := term_eval_eq_propagate t in
  { to_propagate_struc := by dsimp [arity]; exact compose_unary propagate_struc.neg q,
    good := by ext; simp; refl }
| (incr t) :=
  let q := term_eval_eq_propagate t in
  { to_propagate_struc := by dsimp [arity]; exact compose_unary propagate_struc.incr q,
    good := by ext; simp; refl }
| (decr t) :=
  let q := term_eval_eq_propagate t in
  { to_propagate_struc := by dsimp [arity]; exact compose_unary propagate_struc.decr q,
    good := by ext; simp; refl }

variables
  (init_carry : α → bool)
  (next_carry : Π (carry : α → bool) (bits : β → bool), (α → bool))
  (next_bit : Π (carry : α → bool) (bits : β → bool), (α → bool) × bool)

variables [fintype α] [fintype α']

open fintype

lemma exists_repeat_carry (seq : β → ℕ → bool) :
  ∃ n m : fin (2 ^ (card α) + 1),
    propagate_carry2 init_carry next_carry seq n =
    propagate_carry2 init_carry next_carry seq m ∧
    n < m :=
begin
  by_contra h,
  letI : decidable_eq α := classical.dec_eq α,
  push_neg at h,
  have := λ a b hab, (le_antisymm (h a b hab) (h b a hab.symm)).symm,
  simpa using fintype.card_le_of_injective _ this
end

lemma propagate_carry2_eq_of_seq_eq_lt (seq₁ seq₂ : β → ℕ → bool)
  (init_carry : α → bool)
  (next_carry : Π (carry : α → bool) (bits : β → bool), (α → bool))
  (i : ℕ) (h : ∀ (b) j < i, seq₁ b j = seq₂ b j) :
  propagate_carry2 init_carry next_carry seq₁ i =
    propagate_carry2 init_carry next_carry seq₂ i :=
begin
  induction i with i ih,
  { simp [propagate_carry2] },
  { simp [propagate_carry2, h _ i (nat.lt_succ_self i)],
    rw ih,
    exact λ b j hj, h b j (nat.lt_succ_of_lt hj) }
end

lemma propagate_eq_of_seq_eq_le (seq₁ seq₂ : β → ℕ → bool)
  (init_carry : α → bool)
  (next_bit : Π (carry : α → bool) (bits : β → bool), (α → bool) × bool)
  (i : ℕ) (h : ∀ (b) j ≤ i, seq₁ b j = seq₂ b j) :
  propagate init_carry next_bit seq₁ i =
    propagate init_carry next_bit seq₂ i :=
begin
  cases i,
  { simp [propagate_zero, h _ 0 (le_refl _)] },
  { simp only [propagate_succ2, propagate_succ2, h _ _ (le_refl _)],
    congr' 2,
    apply propagate_carry2_eq_of_seq_eq_lt,
    exact λ b j hj, h b j (le_of_lt hj) }
end

lemma propagate_carry2_eq_of_carry_eq (seq₁ seq₂ : β → ℕ → bool)
  (m n : ℕ)
  (h₁ : propagate_carry2 init_carry
    (λ carry bits, (next_bit carry bits).1) seq₁ m =
       propagate_carry2 init_carry
    (λ carry bits, (next_bit carry bits).1) seq₂ n) (x : ℕ)
  (h₃ : ∀ y b, y ≤ x → seq₁ b (m + y) = seq₂ b (n + y))  :
  propagate_carry2 init_carry
    (λ carry bits, (next_bit carry bits).1) seq₁ (m + x) =
  propagate_carry2 init_carry
    (λ carry bits, (next_bit carry bits).1) seq₂ (n + x) :=
begin
  induction x with x ih generalizing seq₁ seq₂,
  { simp * at * },
  { simp only [h₃ x _ (nat.le_succ _),
      nat.add_succ, propagate_carry2, add_zero] at *,
    rw [ih],
    assumption,
    exact λ y b h, h₃ y b (nat.le_succ_of_le h) }
end

lemma propagate_eq_of_carry_eq (seq₁ seq₂ : β → ℕ → bool)
  (m n : ℕ)
  (h₁ : propagate_carry2 init_carry
    (λ carry bits, (next_bit carry bits).1) seq₁ m =
       propagate_carry2 init_carry
    (λ carry bits, (next_bit carry bits).1) seq₂ n) (x : ℕ)
  (h₃ : ∀ y b, y ≤ x → seq₁ b (m + y) = seq₂ b (n + y))  :
  propagate init_carry next_bit seq₁ (m + x) =
  propagate init_carry next_bit seq₂ (n + x) :=
begin
  cases x,
  { cases m,
    { cases n,
      { simp [h₃ 0 _ (le_refl _), propagate_carry2, *] at * },
      { simp [*, h₃ 0 _ (le_refl _), propagate_succ2] at *,
        rw [← h₁] } },
    { cases n,
      { simp [*, propagate_succ2] at *,
        simp [← h₃ 0 _ rfl] },
      { rw [propagate_succ2, h₁, propagate_succ2],
        have := h₃ 0,
        simp * at * } } },
  { simp only [nat.add_succ, propagate_succ2, add_zero],
    simp [← nat.add_succ, h₃ _ _ (le_refl _)],
    congr' 2,
    apply propagate_carry2_eq_of_carry_eq,
    assumption,
    assumption }
end

lemma propagate_carry_propagate_carry_add (x : β → ℕ → bool) :
  ∀ (init_carry : α → bool)
    (next_carry : Π (carry : α → bool) (bits : β → bool), (α → bool)),
  ∀ n i : ℕ,
  propagate_carry2 (propagate_carry2 init_carry next_carry x n)
    next_carry (λ b k, x b (k + n)) i =
  propagate_carry2 init_carry next_carry x (i + n)
| init_carry next_carry 0 0 := by simp [propagate_carry2]
| init_carry next_carry (n+1) 0 :=
  by simp [propagate_carry, propagate_carry2_succ]
| init_carry next_carry n (i+1) := begin
  rw [propagate_carry2, add_assoc,
    propagate_carry_propagate_carry_add],
  simp only [nat.one_add, nat.add_one, nat.succ_add, nat.add_succ,
    add_zero, propagate_carry2, zero_add]
end

lemma exists_repeat : ∀ (seq : β → ℕ → bool)
  (n : ℕ),
  ∃ (m < 2 ^ (card α)) (seq2 : β → ℕ → bool),
    propagate init_carry next_bit seq2 m = propagate init_carry next_bit seq n
| seq n :=
begin
  by_cases hn2 : n < 2 ^ card α,
  { exact ⟨n, hn2, seq, rfl⟩ },
  { rcases exists_repeat_carry (propagate_carry2 init_carry (λ c b, (next_bit c b).1) seq
        (n - 2 ^ card α))
      (λ carry bits, (next_bit  carry bits).1)
      (λ b i, seq b (i + (n - 2^ (card α)))) with ⟨a, b, h₁, h₂⟩,
    simp only [propagate_carry_propagate_carry_add] at h₁,
    rcases have wf : n - (b - a) < n,
        from nat.sub_lt (lt_of_lt_of_le (pow_pos two_pos _) (le_of_not_gt hn2))
          (nat.sub_pos_of_lt h₂),
      exists_repeat (λ c i, if i < a + (n - 2 ^ card α) then seq c i else
        seq c (i + (b - a))) (n - (b - a)) with ⟨m, hmle, seq2, hm⟩,
    use [m, hmle, seq2],
    rw [hm], clear hm,
    have h1 : n - (b - a) = (a + (n - 2 ^ (card α))) + (2 ^ card α - b),
    { zify,
      rw [nat.cast_sub, nat.cast_sub, nat.cast_sub, nat.cast_sub],
      ring,
      exact nat.le_of_lt_succ b.2,
      simp * at *,
      exact le_of_lt h₂,
      exact le_trans (nat.sub_le _ _) (le_trans (nat.le_of_lt_succ b.2)
        (by simp * at *)) },
    rw h1,
    have h2 : n = (b + (n - 2 ^ card α)) + (2 ^ card α - b),
    { zify,
      rw [nat.cast_sub, nat.cast_sub],
      ring,
      exact nat.le_of_lt_succ b.2,
      simp * at *, },
    conv_rhs { rw h2 },
    refine propagate_eq_of_carry_eq _ _ _ _ _ _ _ _ _,
    { have h : ↑b + (n - 2 ^ card α) = (a + (n - 2 ^ card α)) + (b - a),
      { zify,
        rw [nat.cast_sub, nat.cast_sub],
        ring,
        exact le_of_lt h₂,
        simp * at * },
      rw [← h₁],
      apply propagate_carry2_eq_of_seq_eq_lt,
      simp { contextual := tt } },
    { intros y c hc,
      simp only [add_lt_iff_neg_left, not_lt_zero', if_false],
      congr' 1,
      zify,
      rw [nat.cast_sub, nat.cast_sub],
      ring,
      exact le_of_lt h₂,
      simp * at * } },
end
using_well_founded { rel_tac := λ _ _, `[exact ⟨_, measure_wf psigma.snd⟩] }

lemma propagate_eq_zero_iff (init_carry : α → bool)
  (next_bit : Π (carry : α → bool) (bits : β → bool), (α → bool) × bool) :
  (∀ seq, propagate init_carry next_bit seq = zero_seq) ↔
  (∀ seq, ∀ i < 2 ^ (card α), propagate init_carry next_bit seq i = ff) :=
begin
  split,
  { intros h i _,
    simp [h, zero_seq] },
  { intros h seq,
    funext i,
    rcases exists_repeat init_carry next_bit seq i with ⟨j, hj, seq2, hseq2⟩,
    rw [← hseq2, h seq2 j hj, zero_seq] }
end

lemma eq_iff_xor_seq_eq_zero (seq₁ seq₂ : ℕ → bool) :
  (∀ i, seq₁ i = seq₂ i) ↔ (∀ i, xor_seq seq₁ seq₂ i = zero_seq i) :=
begin
  simp [function.funext_iff, xor_seq, zero_seq],
  split,
  { intros, simp * },
  { intros h a,
    specialize h a,
    cases (seq₁ a); cases (seq₂ a); simp * at *, }
end

lemma eval_eq_iff_xor_seq_eq_zero (t₁ t₂ : term) :
  t₁.eval = t₂.eval ↔ (t₁.xor t₂).eval_fin = λ _, zero_seq :=
begin
  simp only [function.funext_iff, term.eval, term.eval_fin,
    ← eq_iff_xor_seq_eq_zero, ← eval_fin_eq_eval],
  split,
  { intros h seq n,
    have := h (λ j, if hj : j < (arity (t₁.xor t₂)) then seq ⟨j, hj⟩ else λ _, ff) n,
    simp at this,
    convert this },
  { intros h seq m,
    exact h (λ j, seq j) _ }
end


import category_theory.abelian.diagram_lemmas.four
import .projectives
import .homological_complex
import .snake_lemma2

noncomputable theory

open category_theory
open category_theory.limits

universes v u

namespace short_exact_sequence

variables {C : Type u} [category.{v} C] [abelian C] [enough_projectives C]
variables {D : Type*} [category D] [abelian D]

-- move this
lemma exact_of_epi_comp_kernel.ι_comp_mono {C : Type u} [category.{v} C] [abelian C] {X Y Z W : C}
  (g : Y ⟶ Z) (h : Z ⟶ W) (f : X ⟶ kernel g) (i : kernel g ⟶ Y) (hf : epi f) (hh : mono h)
  (hi : i = kernel.ι g) : exact (f ≫ i) (g ≫ h) :=
begin
  suffices : exact i g,
  { letI := hf, letI := hh,
    exact exact_comp_mono (exact_epi_comp this) },
  rw [hi],
  exact exact_kernel_ι
end

-- move this
lemma biprod_factors (A B : C) [projective A] [projective B]
  (E X : C) (f : A ⊞ B ⟶ X) (e : E ⟶ X) [epi e] :
  ∃ f' : A ⊞ B ⟶ E, f' ≫ e = f :=
⟨biprod.desc
  (projective.factor_thru (biprod.inl ≫ f) e)
  (projective.factor_thru (biprod.inr ≫ f) e),
  by ext; simp only [projective.factor_thru_comp, biprod.inl_desc_assoc, biprod.inr_desc_assoc]⟩

variables (A B : short_exact_sequence C) (f : A ⟶ B)

def horseshoe_base : short_exact_sequence C :=
short_exact_sequence.mk_split (projective.over A.1) (projective.over A.3)

def horseshoe_base_π : horseshoe_base A ⟶ A :=
{ fst := projective.π _,
  snd := biprod.desc (projective.π _ ≫ A.f) (projective.factor_thru (projective.π _) A.g),
  trd := projective.π _,
  sq1' := by { dsimp [horseshoe_base], simp only [biprod.inl_desc], },
  sq2' :=
  begin
    dsimp [horseshoe_base], apply category_theory.limits.biprod.hom_ext',
    { simp only [zero_comp, exact.w_assoc, biprod.inl_desc_assoc, category.assoc,
        short_exact_sequence.f_comp_g, comp_zero, exact_inl_snd], },
    { simp only [projective.factor_thru_comp, biprod.inr_snd_assoc, biprod.inr_desc_assoc], }
  end }

instance epi_horseshoe_base_π_1 : epi (horseshoe_base_π A).1 :=
show epi (projective.π _), by apply_instance

instance epi_horseshoe_base_π_3 : epi (horseshoe_base_π A).3 :=
show epi (projective.π _), by apply_instance

local attribute [instance] limits.has_zero_object.has_zero

instance epi_horseshoe_base_π_2 : epi (horseshoe_base_π A).2 :=
begin
  let φ := horseshoe_base_π A,
  have h : φ.3 ≫ (0 : A.3 ⟶ 0) = (0 : _ ⟶ 0) ≫ (0 : 0 ⟶ 0) := by simp,
  refine category_theory.abelian.epi_of_epi_of_epi_of_mono φ.sq1' φ.sq2' h _ _ _ _ _ _;
  try { rw ← epi_iff_exact_zero_right }; try { apply_instance },
  exact A.exact',
end

variables {A B}

def horseshoe_ker [epi f.1] : short_exact_sequence C :=
(snake_input.mk_of_short_exact_sequence_hom _ _ _ f).kernel_sequence _
begin
  dsimp [snake_input.mk_of_short_exact_sequence_hom, snake_diagram.mk_of_short_exact_sequence_hom],
  rw snake_diagram.mk_functor_map_f1,
  exact A.mono',
end
$ is_zero_of_iso_of_zero (is_zero_zero _) (limits.cokernel.of_epi _).symm

@[simp] lemma horseshoe_ker_fst [epi f.1] : (horseshoe_ker f).1 = kernel f.1 := rfl

@[simp] lemma horseshoe_ker_snd [epi f.1] : (horseshoe_ker f).2 = kernel f.2 := rfl

@[simp] lemma horseshoe_ker_trd [epi f.1] : (horseshoe_ker f).3 = kernel f.3 := rfl

def horseshoe_ker_ι [epi f.1] : horseshoe_ker f ⟶ A :=
{ fst := kernel.ι _,
  snd := kernel.ι _,
  trd := kernel.ι _,
  sq1' :=
  begin
    dsimp [horseshoe_ker, snake_input.kernel_sequence,
      snake_input.mk_of_short_exact_sequence_hom, snake_diagram.mk_of_short_exact_sequence_hom],
    delta kernel.map,
    rw [snake_diagram.mk_functor_map_f0, kernel.lift_ι],
  end,
  sq2' :=
  begin
    dsimp [horseshoe_ker, snake_input.kernel_sequence,
      snake_input.mk_of_short_exact_sequence_hom, snake_diagram.mk_of_short_exact_sequence_hom],
    delta kernel.map,
    rw [snake_diagram.mk_functor_map_g0, kernel.lift_ι],
  end }
.

lemma horseshoe_ker_ι_fst [epi f.1] : (horseshoe_ker_ι f).1 = kernel.ι f.1 := rfl

lemma horseshoe_ker_ι_snd [epi f.1] : (horseshoe_ker_ι f).2 = kernel.ι f.2 := rfl

lemma horseshoe_ker_ι_trd [epi f.1] : (horseshoe_ker_ι f).3 = kernel.ι f.3 := rfl

variables (A)

lemma horseshoe_ker_ι_comp_base_π :
  (horseshoe_ker_ι (horseshoe_base_π A)) ≫ horseshoe_base_π A = 0 :=
begin
  dsimp [horseshoe_ker_ι, horseshoe_base_π],
  ext1; show kernel.ι _ ≫ _ = 0; exact exact.w exact_kernel_ι,
end

noncomputable
def horseshoe_step (A : short_exact_sequence C) :
  ℕ → Σ (X Y Z : short_exact_sequence C) (ι : X ⟶ Y), Y ⟶ Z
| 0     := ⟨horseshoe_ker (horseshoe_base_π A), _, _, horseshoe_ker_ι _, horseshoe_base_π _⟩
| (n+1) :=
⟨horseshoe_ker (horseshoe_base_π (horseshoe_step n).1), _, _, horseshoe_ker_ι _, horseshoe_base_π _⟩

@[reassoc] lemma horseshoe_step_comp_eq_zero :
  ∀ n, (horseshoe_step A n).2.2.2.1 ≫ (horseshoe_step A n).2.2.2.2 = 0
| 0     := horseshoe_ker_ι_comp_base_π _
| (n+1) := horseshoe_ker_ι_comp_base_π _

lemma step_fst_mono (n : ℕ) : mono (horseshoe_step A n).2.2.2.1.1 :=
begin
  cases n,
  { dsimp [horseshoe_step, horseshoe_ker_ι],
    apply_instance },
  { dsimp [horseshoe_step],
    cases n, --Why do I have to do this again?!
    { rw [horseshoe_ker_ι_fst],
      apply_instance },
    { rw [horseshoe_ker_ι_fst],
      apply_instance }  }
end

lemma step_snd_mono (n : ℕ) : mono (horseshoe_step A n).2.2.2.1.2 :=
begin
  cases n,
  { dsimp [horseshoe_step, horseshoe_ker_ι],
    apply_instance },
  { dsimp [horseshoe_step],
    cases n, --Why do I have to do this again?!
    { rw [horseshoe_ker_ι_snd],
      apply_instance },
    { rw [horseshoe_ker_ι_snd],
      apply_instance }  }
end

lemma step_trd_mono (n : ℕ) : mono (horseshoe_step A n).2.2.2.1.3 :=
begin
  cases n,
  { dsimp [horseshoe_step, horseshoe_ker_ι],
    apply_instance },
  { dsimp [horseshoe_step],
    cases n, --Why do I have to do this again?!
    { rw [horseshoe_ker_ι_trd],
      apply_instance },
    { rw [horseshoe_ker_ι_trd],
      apply_instance }  }
end

def horseshoe_obj (n : ℕ) := (horseshoe_step A n).2.1

def horseshoe_d (n : ℕ) : horseshoe_obj A (n+1) ⟶ horseshoe_obj A n :=
(horseshoe_step A (n+1)).2.2.2.2 ≫ eq_to_hom (by { dsimp [horseshoe_step], refl })
  ≫ (horseshoe_step A n).2.2.2.1

lemma horseshoe_d_d (n : ℕ) : horseshoe_d A (n+1) ≫ horseshoe_d A n = 0 :=
begin
  dsimp [horseshoe_d, horseshoe_ker_ι],
  simp only [category.id_comp, category.assoc, comp_zero, zero_comp,
    horseshoe_step_comp_eq_zero_assoc],
end

def horseshoe (A : short_exact_sequence C) : chain_complex (short_exact_sequence C) ℕ :=
chain_complex.of (horseshoe_obj A) (horseshoe_d A) (horseshoe_d_d A)

variables (A)

def horseshoe_π : (horseshoe A).X 0 ⟶ A := horseshoe_base_π _

lemma horseshoe_d_π : (horseshoe A).d 1 0 ≫ horseshoe_π A = 0 :=
begin
  dsimp [horseshoe],
  erw [chain_complex.of_d],
  dsimp [horseshoe_d, horseshoe_π, horseshoe_step],
  simp only [category.id_comp, category.assoc, comp_zero, zero_comp,
    horseshoe_step_comp_eq_zero_assoc, horseshoe_ker_ι_comp_base_π],
end

def horseshoe_to_single₁ :=
(chain_complex.to_single₀_equiv ((homological_complex.Fst C).obj (horseshoe A)) A.1).symm
⟨(short_exact_sequence.Fst C).map (horseshoe_π A),
begin
  have := horseshoe_d_π A, apply_fun (λ f, (short_exact_sequence.Fst C).map f) at this,
  rwa [functor.map_comp, functor.map_zero] at this,
end⟩

def horseshoe_to_single₂ :=
(chain_complex.to_single₀_equiv ((homological_complex.Snd C).obj (horseshoe A)) A.2).symm
⟨(short_exact_sequence.Snd C).map (horseshoe_π A),
begin
  have := horseshoe_d_π A, apply_fun (λ f, (short_exact_sequence.Snd C).map f) at this,
  rwa [functor.map_comp, functor.map_zero] at this,
end⟩

def horseshoe_to_single₃ :=
(chain_complex.to_single₀_equiv ((homological_complex.Trd C).obj (horseshoe A)) A.3).symm
⟨(short_exact_sequence.Trd C).map (horseshoe_π A),
begin
  have := horseshoe_d_π A, apply_fun (λ f, (short_exact_sequence.Trd C).map f) at this,
  rwa [functor.map_comp, functor.map_zero] at this,
end⟩

lemma horseshoe_exact₁ (A : short_exact_sequence C) (n : ℕ) :
  exact (((homological_complex.Fst C).obj (horseshoe A)).d (n + 2) (n + 1))
    (((homological_complex.Fst C).obj (horseshoe A)).d (n + 1) n) :=
begin
  dsimp [horseshoe_to_single₁],
  erw [chain_complex.of_d, chain_complex.of_d],
  dsimp [horseshoe_d, horseshoe_step],

  set f := horseshoe_base_π (horseshoe_step A n).1,
  set g := (horseshoe_step A n).2.2.2.1,

  cases n;
  convert exact_of_epi_comp_kernel.ι_comp_mono f.1 _ (horseshoe_base_π (horseshoe_ker f)).1 _
    infer_instance _ _ using 1,
  { simp [step_fst_mono] },
  { simpa },
  { simp [step_fst_mono] },
  { simpa }
end

lemma horseshoe_exact₂ (A : short_exact_sequence C) (n : ℕ) :
  exact (((homological_complex.Snd C).obj (horseshoe A)).d (n + 2) (n + 1))
    (((homological_complex.Snd C).obj (horseshoe A)).d (n + 1) n) :=
begin
  dsimp [horseshoe_to_single₂],
  erw [chain_complex.of_d, chain_complex.of_d],
  dsimp [horseshoe_d, horseshoe_step],

  set f := horseshoe_base_π (horseshoe_step A n).1,
  set g := (horseshoe_step A n).2.2.2.1,

  cases n;
  convert exact_of_epi_comp_kernel.ι_comp_mono f.2 _ (horseshoe_base_π (horseshoe_ker f)).2 _
    infer_instance _ _ using 1,
  { simp [step_snd_mono] },
  { simpa },
  { simp [step_snd_mono] },
  { simpa }
end

lemma horseshoe_exact₃ (A : short_exact_sequence C) (n : ℕ) :
  exact (((homological_complex.Trd C).obj (horseshoe A)).d (n + 2) (n + 1))
    (((homological_complex.Trd C).obj (horseshoe A)).d (n + 1) n) :=
begin
  dsimp [horseshoe_to_single₃],
  erw [chain_complex.of_d, chain_complex.of_d],
  dsimp [horseshoe_d, horseshoe_step],

  set f := horseshoe_base_π (horseshoe_step A n).1,
  set g := (horseshoe_step A n).2.2.2.1,

  cases n;
  convert exact_of_epi_comp_kernel.ι_comp_mono f.3 _ (horseshoe_base_π (horseshoe_ker f)).3 _
    infer_instance _ _ using 1,
  { simp [step_trd_mono] },
  { simpa },
  { simp [step_trd_mono] },
  { simpa }
end

lemma horseshoe_is_projective_resolution₁ (A : short_exact_sequence C) :
  chain_complex.is_projective_resolution
    ((homological_complex.Fst C).obj (horseshoe A)) A.1 (horseshoe_to_single₁ A) :=
{ projective := by rintro (_|n); { show projective (projective.over _), apply_instance },
  exact₀ :=
  begin
    dsimp [horseshoe_to_single₁, chain_complex.to_single₀_equiv, horseshoe_π],
    erw [chain_complex.of_d],
    dsimp [horseshoe_d, horseshoe_step],
    rw [category.id_comp, ← short_exact_sequence.comp_fst],
    refine abelian.pseudoelement.exact_of_pseudo_exact _ _ ⟨λ a , _, λ a ha, _⟩,
    { rw [← abelian.pseudoelement.comp_apply, ← short_exact_sequence.comp_fst, category.assoc,
        horseshoe_ker_ι_comp_base_π, comp_zero, short_exact_sequence.hom_zero_fst,
        abelian.pseudoelement.zero_apply] },
    { obtain ⟨b, hb⟩ := is_snake_input.exists_of_exact exact_kernel_ι _ ha,
      obtain ⟨c, hc⟩ := abelian.pseudoelement.pseudo_surjective_of_epi
        (horseshoe_base_π (horseshoe_ker _)).1 b,
      refine ⟨c, _⟩,
      rw [short_exact_sequence.comp_fst, abelian.pseudoelement.comp_apply, hc, ← hb],
      refl }
  end,
  exact := λ n, horseshoe_exact₁ A n,
  epi := show epi (projective.π _), from infer_instance }

lemma horseshoe_is_projective_resolution₂ (A : short_exact_sequence C) :
  chain_complex.is_projective_resolution
    ((homological_complex.Snd C).obj (horseshoe A)) A.2 (horseshoe_to_single₂ A) :=
{ projective := by rintro (_|n); { show projective (projective.over _ ⊞ projective.over _),
    apply_instance },
  exact₀ :=
  begin
    dsimp [horseshoe_to_single₂, chain_complex.to_single₀_equiv, horseshoe_π],
    erw [chain_complex.of_d],
    dsimp [horseshoe_d, horseshoe_step],
    rw [category.id_comp, ← short_exact_sequence.comp_snd],
    refine abelian.pseudoelement.exact_of_pseudo_exact _ _ ⟨λ a , _, λ a ha, _⟩,
    { rw [← abelian.pseudoelement.comp_apply, ← short_exact_sequence.comp_snd, category.assoc,
        horseshoe_ker_ι_comp_base_π, comp_zero, short_exact_sequence.hom_zero_snd,
        abelian.pseudoelement.zero_apply] },
    { obtain ⟨b, hb⟩ := is_snake_input.exists_of_exact exact_kernel_ι _ ha,
      obtain ⟨c, hc⟩ := abelian.pseudoelement.pseudo_surjective_of_epi
        (horseshoe_base_π (horseshoe_ker _)).2 b,
      refine ⟨c, _⟩,
      rw [short_exact_sequence.comp_snd, abelian.pseudoelement.comp_apply, hc, ← hb],
      refl }
  end,
  exact := λ n, horseshoe_exact₂ A n,
  epi := show epi (horseshoe_base_π _).2, from infer_instance }

lemma horseshoe_is_projective_resolution₃ (A : short_exact_sequence C) :
  chain_complex.is_projective_resolution
    ((homological_complex.Trd C).obj (horseshoe A)) A.3 (horseshoe_to_single₃ A) :=
{ projective := by rintro (_|n); { show projective (projective.over _), apply_instance },
  exact₀ :=
  begin
    dsimp [horseshoe_to_single₃, chain_complex.to_single₀_equiv, horseshoe_π],
    erw [chain_complex.of_d],
    dsimp [horseshoe_d, horseshoe_step],
    rw [category.id_comp, ← short_exact_sequence.comp_trd],
    refine abelian.pseudoelement.exact_of_pseudo_exact _ _ ⟨λ a , _, λ a ha, _⟩,
    { rw [← abelian.pseudoelement.comp_apply, ← short_exact_sequence.comp_trd, category.assoc,
        horseshoe_ker_ι_comp_base_π, comp_zero, short_exact_sequence.hom_zero_trd,
        abelian.pseudoelement.zero_apply] },
    { obtain ⟨b, hb⟩ := is_snake_input.exists_of_exact exact_kernel_ι _ ha,
      obtain ⟨c, hc⟩ := abelian.pseudoelement.pseudo_surjective_of_epi
        (horseshoe_base_π (horseshoe_ker _)).3 b,
      refine ⟨c, _⟩,
      rw [short_exact_sequence.comp_trd, abelian.pseudoelement.comp_apply, hc, ← hb],
      refl }
  end,
  exact := λ n, horseshoe_exact₃ A n,
  epi := show epi (projective.π _), from infer_instance }
.

lemma horseshoe_split (A : short_exact_sequence C) (n : ℕ) :
  ((horseshoe A).X n).split :=
begin
  cases n;
  exact ⟨biprod.fst, biprod.inr, biprod.inl_fst, biprod.inr_snd, biprod.inr_fst, biprod.total⟩
end

lemma horseshoe_f_comp_to_single₂_f (A : short_exact_sequence C) (i : ℕ) :
  ((horseshoe A).X i).f ≫ (horseshoe_to_single₂ A).f i =
  (horseshoe_to_single₁ A).f i ≫ ((chain_complex.single₀ C).map A.f).f i :=
begin
  cases i,
  { dsimp [horseshoe_to_single₂, horseshoe_to_single₁, horseshoe, horseshoe_obj, horseshoe_step,
      horseshoe_base, horseshoe_π, horseshoe_base_π, chain_complex.to_single₀_equiv],
    simp },
  { dsimp [horseshoe_to_single₂, horseshoe_to_single₁, horseshoe, horseshoe_obj, horseshoe_step,
      horseshoe_base, horseshoe_π, horseshoe_base_π, chain_complex.to_single₀_equiv],
    simp }
end

lemma horseshoe_g_comp_to_single₃_f (A : short_exact_sequence C) (i : ℕ) :
  ((horseshoe A).X i).g ≫ (horseshoe_to_single₃ A).f i =
  (horseshoe_to_single₂ A).f i ≫ ((chain_complex.single₀ C).map A.g).f i :=
begin
  cases i,
  { dsimp [horseshoe_to_single₂, horseshoe_to_single₃, chain_complex.to_single₀_equiv, horseshoe,
      horseshoe_obj, horseshoe_π, horseshoe_step, horseshoe_base, horseshoe_base_π],
    ext,
    { simp },
    { simp  } },
  { dsimp [horseshoe_to_single₂, horseshoe_to_single₃, horseshoe, horseshoe_obj, horseshoe_step,
      horseshoe_base, horseshoe_π, horseshoe_base_π, chain_complex.to_single₀_equiv],
    simp }
end

end short_exact_sequence