-------------------------------------------------------------------
-- The PEDANTIC (Proof Engine for Deductive Automation using Non-deterministic
-- Traversal of Instruction Code) verification framework
--
-- Developed by Kenneth Roe
-- For more information, check out www.cs.jhu.edu/~roe
--
-- AbsExecute.v
-- This file contains the basic hoare triple definition and many auxiliary theorems
-- and definitions related to forward propagation.
--
-- Some key definitions:
--     absExecute
--     hoare_triple
--     strengthenPost
--     assign
--     basic_assign
--     load_traverse
--     load
--     store
--     new_thm
--     delete_thm
--     if_statement
--     while
-------------------------------------------------------------------

import .impHeap
import .AbsState

open tactic
open monad
open expr
open smt_tactic

-------------------------------------------------------------------

--def In {A:Type} : A → list A → Prop
--| _ list.nil := false
--| a (b :: m) := b = a ∨ In a m

def absExecute (funs : functions)
               (c : com)
               (s : absState)
               (s' : absState)
               (r : list (@absExp ℕ))
               (s'' : absState)
               (exc : ident → ((@absExp ℕ) × absState)) : Prop :=
    ∀ st st' i x,
        realizeState s st →
        ((∃ st', ∃ r, ceval funs st c st' r) ∧
         ((ceval funs st c st' func_result.NoResult → realizeState s' st') ∧
          (ceval funs st c st' (func_result.Return x) →
            ((∀ rx, rx ∈ r → @absEval ℕ (st'.snd) rx = x) ∧ realizeState s'' st')) ∧
          (ceval funs st c st' (func_result.Exception i x) → (@absEval ℕ (st'.snd) ((exc i).fst) = x ∧ realizeState ((exc i).snd) st'))))

def hoare_triple (P : absState) (c : com) (Q : absState) (r : list (@absExp ℕ)) (Qr : absState) (exc : ident → ((@absExp ℕ) × absState)) : Prop :=
    absExecute (λ x y z a b, ff) c P Q r Qr exc.

notation `{{ ` P ` }} ` c ` {{ ` Q ` }}` := (hoare_triple P c Q list.nil absNone (λ (x:ident), ((λ (x:env), 0),absNone))).
notation `{{ ` P ` }} ` c ` {{ ` Q ` return ` rr ` with ` QQ ` }}` := (hoare_triple P c Q rr QQ (λ (x:ident), ((λ (x:env), 0),absNone))).

theorem override_equal : ∀ env v, override env v (env v)=env :=
begin
    intros, unfold override, funext,
    by_cases (v=l),rewrite h,simp,
    simp [h]
end

--theorem fun_ext {t} {u} :
--    ∀ (a:t→u) (b:t→u), a=b → (λ (x:t), a)=(λ (x:t), b) :=
--begin
--    assume a b h, by rw h
--end

theorem double_override : ∀ env v v1 v2, override (override env v v1) v v2=override env v v2 :=
begin
    intros, unfold override,
    have h:(∀ l, (ite (v=l) v2 (ite (v=l) v1 (env l)))=
            ite (v=l) v2 (env l)),
    intros, by_cases (v=l), rewrite h, simp,
    simp [h], simp only [h]
end

theorem nonethm {t} : (none <|> none)=@none t:= rfl.

theorem nonethm2 {t} {x:option t} : (x <|> none)=x:= begin
    cases x;refl
end

theorem assignPropagate: ∀ (P : absState) (v:ℕ) e xx,
    hoare_triple P  (v ::= e)
          (absExists
              (λ vv, ( (λ st, (P  ** (absPredicate (λ ee, aeval ee e=st.snd v)))

                       (override_state v vv st))
           ))) [] absNone xx :=
begin
    unfold override_state,

    unfold hoare_triple, intros, unfold absExecute,
    intros, split,

    existsi _, existsi _, apply ceval.Ass,

    unfold realizeState at a, split, intro, cases a_1,

    unfold realizeState, unfold absExists,
    existsi (st.snd v), unfold absCompose, existsi _, existsi _,
    simp, split,

    have h:(P ((st.fst, override (st.snd) v (aeval (st.snd) e)).fst,
         override ((st.fst, override (st.snd) v (aeval (st.snd) e)).snd) v (st.snd v))), swap,
    apply h, simp, rw double_override, rw override_equal,
    cases st, simp, apply a,

    swap, apply ((empty_heap, override (st.snd) v (aeval (st.snd) e)).fst,
         override ((st.fst, override (st.snd) v (aeval (st.snd) e)).snd) v (st.snd v)),

    simp,split, unfold absPredicate, simp, rewrite double_override,
    rw override_equal, unfold override, simp,

    simp, rw double_override, rw override_equal,
    unfold concreteCompose, simp, split,

    intro, right, unfold empty_heap, unfold inhabited.default,
    unfold empty_heap, unfold inhabited.default,
    unfold compose_heaps, simp only [nonethm2],

    --cases st, have h:(∀ x, compose_heaps st.fst empty_heap x = st.fst x),

    --intro, unfold compose_heaps, generalize el:(st.fst x_1)=qq,
    --cases qq, unfold empty_heap, unfold inhabited.default,
    --apply nonethm,

    --unfold empty_heap, unfold inhabited.default,
    --simp only [compose_heaps._match_1],
    --tactic.funext,apply h,

    split, intros, split, intros, cases a_2, cases a_1,
    intros, cases a_1

end

--set_option trace.simp_lemmas true.
--set_option trace.simplify true.

theorem strengthenPost : ∀ (R : absState) (P : absState) (Q : absState) (C : com),
                         {{ P }} C {{ Q }} →
                         (forall st, Q st → R st) →
                         {{ P }} C {{ R }} := begin
    intros, unfold hoare_triple at a, unfold absExecute at a,
    unfold hoare_triple, unfold absExecute,
    intros,
    specialize a st st' i x,
    simp, simp at a,
    have hh:((∃ (st' : imp_state),
       Exists
         (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) st C st')) ∧
    ((ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) st C st'
          func_result.NoResult →
        realizeState Q st') ∧
       (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) st C st'
            (func_result.Return x) →
          realizeState absNone st') ∧
         (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) st C st'
            (func_result.Exception i x) →
          absEval (st'.snd) (λ (x : env), 0) = x ∧ realizeState absNone st'))),
    apply a, apply a_2,
    cases hh, split, apply hh_left,
    cases hh_right, split, intros, apply a_1, apply hh_right_left,
    apply a_3, cases hh_right_right, split, intros,
    exfalso, unfold realizeState at hh_right_right_left,
    unfold absNone at hh_right_right_left,
    apply hh_right_right_left, apply a_3,
    intros, exfalso,unfold realizeState at hh_right_right_right,
    unfold absNone at hh_right_right_right,
    simp at hh_right_right_right,
    apply hh_right_right_right, apply a_3
end

theorem nilmem {t} (x : t) : x ∈ @list.nil t=false :=
begin
    simp
end

theorem rsfalse { st : imp_state} : realizeState absNone st=false :=
begin
    unfold realizeState, unfold absNone
end

theorem andfalse { a : Prop } : (a ∧ false)=false :=
begin
    simp
end

theorem compose : forall (P:absState) c1 c2 Q R,
    {{ P }} c1 {{ Q }} →
    {{ Q }} c2 {{ R }} →
    {{ P }} (com.Seq c1 c2) {{ R }} := begin
    intros, unfold hoare_triple at a, unfold hoare_triple at a_1,
    unfold absExecute at a, unfold absExecute at a_1,
    unfold hoare_triple, unfold absExecute,
    intros,
    simp at a_1, simp at a,
    simp,
     simp only [rsfalse] at a, simp only [andfalse] at a,
     simp only [rsfalse] at a_1, simp only [andfalse] at a_1,

     have aaa:(∀ (st' : imp_state), (∃ (st' : imp_state),
         Exists
           (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) st c1
              st')) ∧
      ((ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) st c1 st'
            func_result.NoResult →
          realizeState Q st') ∧
         (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) st c1 st'
              (func_result.Return x) →
            false) ∧
           (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) st c1 st'
              (func_result.Exception i x) →
            false))),
    intros, apply a, apply a_2,
    split,
    have aaa2:(  ∀ (st' : imp_state),
    (∃ (st' : imp_state),
         Exists
           (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) st c1
              st')) ∧
      ((ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) st c1 st'
            func_result.NoResult →
          realizeState Q st') ∧
         (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) st c1 st'
              (func_result.Return x) →
            false) ∧
           (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) st c1 st'
              (func_result.Exception i x) →
            false))), apply aaa,

    specialize aaa st', cases aaa, cases aaa_left, cases aaa_left_h,
    cases aaa_left_h_w,

    have aa1:((∃ (st' : imp_state),
       Exists
         (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) aaa_left_w c2
            st')) ∧
    ((ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) aaa_left_w c2 st'
          func_result.NoResult →
        realizeState R st') ∧
       (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) aaa_left_w c2 st'
            (func_result.Return x) →
          false) ∧
         (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) aaa_left_w c2
            st'
            (func_result.Exception i x) →
          false))), apply a_1,
    specialize aaa2 aaa_left_w, cases aaa2, cases aaa2_right,
    apply aaa2_right_left, apply aaa_left_h_h,
    cases aa1, cases aa1_left, cases aa1_left_h,

    existsi aa1_left_w, existsi aa1_left_h_w,
    apply ceval.Seq1, apply aaa_left_h_h,
    --specialize a_1 aaa_left_w st' i x,

    apply aa1_left_h_h,

    existsi _, existsi _,
    apply ceval.Seq2, apply aaa_left_h_h,

    existsi _, existsi _,
    apply ceval.Seq3, apply aaa_left_h_h,

    split,
    intros,
    cases a_3,
    specialize aaa a_3_st', cases aaa, cases aaa_right,
    specialize a_1 a_3_st' st' i x,

    have hh:(realizeState Q a_3_st' → (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) a_3_st' c2 st'
         func_result.NoResult) →
  realizeState R st'),
    intros,
    have hhh:((∃ (st' : imp_state),
       Exists
         (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) a_3_st' c2
            st')) ∧
    (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) a_3_st' c2 st'
         func_result.NoResult →
       realizeState R st') ∧
      (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) a_3_st' c2 st'
           (func_result.Return x) →
         false) ∧
        (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) a_3_st' c2 st'
           (func_result.Exception i x) →
         false)), apply a_1, apply a_3,
    cases hhh, cases hhh_right,
    apply hhh_right_left, apply a_4,

    apply hh, apply aaa_right_left, apply a_3_a, apply a_3_a_1,

    split, intros, unfold realizeState, unfold absNone,
    cases a_3,
    specialize aaa a_3_st', cases aaa, cases aaa_right,
    specialize a_1 a_3_st' st' i x,
    have hh:((∃ (st' : imp_state),
       Exists
         (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) a_3_st' c2
            st')) ∧
    (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) a_3_st' c2 st'
         func_result.NoResult →
       realizeState R st') ∧
      (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) a_3_st' c2 st'
           (func_result.Return x) →
         false) ∧
        (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) a_3_st' c2 st'
           (func_result.Exception i x) →
         false)), apply a_1, apply aaa_right_left, apply a_3_a,
    cases hh, cases hh_right, cases hh_right_right,

    apply hh_right_right_left, apply a_3_a_1,
    specialize aaa st',
    cases aaa, cases aaa_right, cases aaa_right_right,
    apply aaa_right_right_left, apply a_3_a,

    intros, exfalso,
    cases a_3,
    specialize aaa a_3_st', cases aaa, cases aaa_right,
    specialize a_1 a_3_st' st' i x,
    have hh:((∃ (st' : imp_state),
       Exists
         (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) a_3_st' c2
            st')) ∧
    (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) a_3_st' c2 st'
         func_result.NoResult →
       realizeState R st') ∧
      (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) a_3_st' c2 st'
           (func_result.Return x) →
         false) ∧
        (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) a_3_st' c2 st'
           (func_result.Exception i x) →
         false)), apply a_1, apply aaa_right_left, apply a_3_a,
    cases hh, cases hh_right, cases hh_right_right,

    apply hh_right_right_right, apply a_3_a_1,
    specialize aaa st',
    cases aaa, cases aaa_right, cases aaa_right_right,
    apply aaa_right_right_right, apply a_3_a
end

meta def evaluate_aeval_helper : expr → expr
| `(aeval %%e (aexp.Num %%x)) := x
| `(aeval %%e (aexp.Var %%v)) := e v
| `(aeval %%e (aexp.Plus %%x %%y)) :=
            `((%%(evaluate_aeval_helper `(aeval %%e %%x))) +
              (%%(evaluate_aeval_helper `(aeval %%e %%y))))
| `(aeval %%e (aexp.Minus %%x %%y)) :=
            `((%%(evaluate_aeval_helper `(aeval %%e %%x))) -
              (%%(evaluate_aeval_helper `(aeval %%e %%y))))
| `(aeval %%e (aexp.Mult %%x %%y)) :=
            `((%%(evaluate_aeval_helper `(aeval %%e %%x))) *
              (%%(evaluate_aeval_helper `(aeval %%e %%y))))
| `(aeval %%e (aexp.Eq %%x %%y)) :=
           `((%%(evaluate_aeval_helper `(aeval %%e %%x))) =
             (%%(evaluate_aeval_helper `(aeval %%e %%y))))
| `(aeval %%e (aexp.Le %%x %%y)) :=
           `(%%(evaluate_aeval_helper `(aeval %%e %%x))≤
             %%(evaluate_aeval_helper `(aeval %%e %%y)))
| `(aeval %%e (aexp.Land %%x %%y)) :=
      `(if ((aeval %%e %%x)=0) then 0 else (aeval %%e %%y))
--| `(aeval %%e (aexp.Land %%x %%y)) := `(if (aeval %%e %%x)=0 then 0 else (aeval %%e %%y))
| `(aeval %%e (aexp.Lor %%x %%y)) := `(if (aeval %%e %%x)=0 then (aeval %%e %%y) else (aeval %%e %%x))
| `(aeval %%e (aexp.Lnot %%x)) := `(if (aeval %%e %%x)=0 then 1 else 0)
| `(aeval %%e A0) := `(0)
| `(aeval %%e A1) := `(1)
| `(aeval %%e A2) := `(2)
| `(aeval %%e A3) := `(3)
| `(aeval %%e A4) := `(4)
| `(aeval %%e A5) := `(5)
| `(aeval %%e A6) := `(6)
| (expr.app a b) := expr.app (evaluate_aeval_helper a) (evaluate_aeval_helper b)
| (expr.lam v b t e) := expr.lam v b (evaluate_aeval_helper t) (evaluate_aeval_helper e)
| (expr.pi v b t e) := expr.pi v b (evaluate_aeval_helper t) (evaluate_aeval_helper e)
| x := x

meta def evaluate_aeval : tactic unit :=
do { t ← target,
     tgt ← instantiate_mvars t,
     --trace tgt.to_raw_fmt,
     nt ← some (evaluate_aeval_helper tgt),
     --trace nt.to_raw_fmt,
     change nt }

--theorem xx: 1=(2,2).fst :=
--begin
--    do {
--        xxx ← target,
--        trace xxx.to_raw_fmt,
--        admit
--    }
--end

set_option eqn_compiler.max_steps 9999
set_option timeout 10000

meta def simplify_override_helper : expr → expr
| `(λ st, (absCompose %%l %%r)
          (@prod.mk
           (@prod.fst st)
           (override (@prod.snd st) %%vv %%ee))) :=
  (expr.app (expr.app `(absCompose)
      (expr.lam "st" binder_info.default `(imp_state)
          (expr.app
            l
            (expr.app (expr.app `(@prod.mk heap env)
              (expr.app `(@prod.fst heap env) (expr.var 0)))
              (expr.app (expr.app (expr.app `(@override)
                 (expr.app `(@prod.snd heap env) (expr.var 0))) vv) ee)
              ))))
      (expr.lam "st" binder_info.default `(imp_state)
          (expr.app
            l
            (expr.app (expr.app `(@prod.mk heap env)
              (expr.app `(@prod.fst heap env) (expr.var 0)))
              (expr.app (expr.app (expr.app `(@override)
                 (expr.app `(@prod.snd heap env) (expr.var 0))) vv) ee)
              ))))
| (expr.app a b) := expr.app (simplify_override_helper a) (simplify_override_helper b)
| (expr.lam v b t e) := expr.lam v b (simplify_override_helper t) (simplify_override_helper e)
| (expr.pi v b t e) := expr.pi v b (simplify_override_helper t) (simplify_override_helper e)
| x := x

meta def simplify_override_helperb : expr → expr
| `(λ st, (absExists (λ (v:%%t), %%e))
          (@prod.mk (@prod.fst st) (override (@prod.snd st) %%vv %%ee))) :=
      (expr.app `(@absExists %%t)
                    (expr.lam "v" binder_info.default t
                       (expr.lam "st" binder_info.default `(imp_state)
                         (expr.app
                           (expr.lower_vars (expr.lift_vars e 0 1) 2 1)
                           (expr.app
                             (expr.app
                               `(@prod.mk heap env)
                               (expr.app `(@prod.fst heap env) (expr.var 0)))
                               (expr.app (expr.app (expr.app `(override)
                                  (expr.app
                                    `(@prod.snd heap env)
                                    (expr.var 0)))
                                  vv) ee))
                          )
                       )))
| (expr.app a b) := expr.app (simplify_override_helperb a) (simplify_override_helperb b)
| (expr.lam v b t e) := expr.lam v b (simplify_override_helper t) (simplify_override_helperb e)
| (expr.pi v b t e) := expr.pi v b (simplify_override_helperb t) (simplify_override_helperb e)
| x := x

--meta def q : ℕ → (ℕ → ℕ)
--| _ := (λ (s:ℕ), s) 3.

--theorem test : 1=2 :=
--begin
--    do {
--      a ← some (q 0),
--      trace "abc",
--      --trace (a.to_raw_format),
--      b ← to_expr (``(λ (sss:ℕ), sss)),
--      trace b.to_raw_fmt,
--      admit
--    }
--end

meta def simplify_override_helper' : expr → expr
| (expr.lam st b stt
      (expr.app
        (expr.app
          (expr.app
            `(absCompose)
            l)
          r)
        (expr.app
          (expr.app
            (expr.app (expr.app pm hhh) eee)
            (expr.app
              (expr.app (expr.app pf hhha) eeea)
              (expr.var 0)))
          (expr.app
            (expr.app
              (expr.app
                `(override)
                (expr.app
                  (expr.app (expr.app ps hhhb) eeeb)
                  (expr.var 0)))
                vv)
              ee)))) :=
  (expr.app (expr.app `(absCompose)
      (expr.lam st b stt
          (expr.app
            l
            (expr.app (expr.app (expr.app (expr.app pm hhh) eee)
              (expr.app (expr.app (expr.app pf hhha) eeea) (expr.var 0)))
              (expr.app (expr.app (expr.app `(override)
                 (expr.app (expr.app (expr.app ps hhhb) eeeb)
                 (expr.var 0))) vv) ee)
              ))))
      (expr.lam st b stt
          (expr.app
            r
            (expr.app (expr.app (expr.app (expr.app pm hhh) eee)
              (expr.app (expr.app (expr.app pf hhha) eeea) (expr.var 0)))
              (expr.app (expr.app (expr.app `(override)
                 (expr.app (expr.app (expr.app ps hhhb) eeeb)
                 (expr.var 0))) vv) ee)
              ))))
| (expr.app a b) := expr.app (simplify_override_helper' a) (simplify_override_helper' b)
| (expr.lam v b t e) := expr.lam v b (simplify_override_helper' t) (simplify_override_helper' e)
| (expr.pi v b t e) := expr.pi v b (simplify_override_helper' t) (simplify_override_helper' e)
| x := x

meta def simplify_override_helper2 : expr → expr
| (expr.lam st b stt
    (expr.app (expr.app (expr.app ex ext)
        (expr.lam vvv bb vtt e))
      (expr.app
        (expr.app
          (expr.app (expr.app pm hhh) eee)
          (expr.app (expr.app (expr.app pf hhha) eeea) (expr.var 0)))
        (expr.app (expr.app (expr.app `(override)
          (expr.app
              (expr.app (expr.app ps hhhb) eeeb)
              (expr.var 0)))
          vv)
        ee)))) := (expr.app (expr.app ex ext)
                    (expr.lam vvv bb vtt
                       (expr.lam st b stt
                         (expr.app
                           (expr.lower_vars (expr.lift_vars e 0 1) 2 1)
                           (expr.app
                             (expr.app
                               (expr.app (expr.app pm hhh) eee)
                                 (expr.app (expr.app (expr.app pf hhha) eeea) (expr.var 0)))
                               (expr.app (expr.app (expr.app `(override)
                                  (expr.app
                                    (expr.app (expr.app ps hhhb) eeeb)
                                    (expr.var 0)))
                                  vv) ee))
                          )
                       )))

| (expr.app a b) := expr.app (simplify_override_helper2 a) (simplify_override_helper2 b)
| (expr.lam v b t e) := expr.lam v b (simplify_override_helper2 t) (simplify_override_helper2 e)
| (expr.pi v b t e) := expr.pi v b (simplify_override_helper2 t) (simplify_override_helper2 e)
| x := x

meta def replace_varn_helper : ℕ → expr → expr → expr
| n r (expr.var nn) := if n=nn then r else (expr.var nn)
| n r (expr.app a b) := expr.app (replace_varn_helper n r a) (replace_varn_helper n r b)
| n r (expr.lam v b t e) := expr.lam v b (replace_varn_helper (n+1) r t) (replace_varn_helper (n+1) r e)
| n r (expr.pi v b t e) := expr.pi v b (replace_varn_helper n r t) (replace_varn_helper n r e)
| n r x := x

meta def simplify_tree_helper : expr → expr
| (expr.lam st bb stt
    (expr.app
      (expr.app
        (expr.app
          (expr.app
            (expr.app
              tree
              (expr.lam v b t e))
            nn)
          fff)
        fr)
        (expr.app
          (expr.app
            (expr.app (expr.app pm hhh) eee)
            (expr.app (expr.app (expr.app pf hhha) eeea) (expr.var 0)))
            (expr.app (expr.app (expr.app `(override)
              (expr.app
                (expr.app (expr.app ps hhhb) eeeb)
                (expr.var 0)))
            vv)
          ee)))) :=
      (expr.app
        (expr.app
          (expr.app
            (expr.app
              tree
              (expr.lam v b t
               (replace_varn_helper 0
                 (expr.app (expr.app (expr.app `(override)
                   (expr.var 0))
                   vv)
                 ee)
                 (expr.lower_vars e 2 1))
              ))
            (expr.lower_vars nn 1 1))
          (expr.lower_vars fff 1 1))
        (expr.lower_vars fr 1 1))
| (expr.app a b) := expr.app (simplify_tree_helper a) (simplify_tree_helper b)
| (expr.lam v b t e) := expr.lam v b (simplify_tree_helper t) (simplify_tree_helper e)
| (expr.pi v b t e) := expr.pi v b (simplify_tree_helper t) (simplify_tree_helper e)
| x := x

meta def beq_exp : expr → expr → bool
| a b := ff

meta def update_state_reference : ℕ → expr → option expr
| n (expr.app (expr.app (expr.app ps hhh) eee) (expr.var (n1))) :=
      if (n+1)=n1 then some (expr.var n) else none
| n (expr.var n1) :=
  if (n+1)=n1 then none else some (expr.var n1)
| n (expr.app a b) := match update_state_reference n a with
                      | none := none
                      | some aa := match update_state_reference n b with
                                   | none := none
                                   | some bb := (expr.app aa bb)
                                   end
                      end
| n (expr.lam v b t e) := match update_state_reference (n+1) t with
                          | none := none
                          | some aa := match update_state_reference (n+1) e with
                                       | none := none
                                       | some bb := (expr.lam v b aa bb)
                                       end
                          end
| n (expr.pi v b t e) := match update_state_reference (n+1) t with
                         | none := none
                         | some aa := match update_state_reference (n+1) e with
                                      | none := none
                                      | some bb := (expr.pi v b aa bb)
                                      end
                         end
| n x := some x

meta def simplify_override_predicate_helper : expr → expr
| (expr.lam st b stt
      (expr.app
        (expr.app predicate (expr.lam eev bb eet prr))
        (expr.app
          (expr.app
            (expr.app (expr.app pm hhh) eee)
            (expr.app (expr.app (expr.app pf hhha) eeea) (expr.var 0)))
          (expr.app (expr.app (expr.app `(override)
            (expr.app
                (expr.app (expr.app ps hhhb) eeeb)
                (expr.var 0)))
            vv)
          ee)))) :=
    match update_state_reference 0 (replace_varn_helper 0
                                  (expr.app (expr.app (expr.app `(override)
                                    (expr.app
                                      (expr.app (expr.app ps hhhb) eeeb)
                                      (expr.var 0)))
                                      vv) ee)
                                    prr) with
    | some r := (expr.app predicate (expr.lam eev bb eet
                  (expr.lower_vars r 2 1)))
    | none := (expr.lam st b stt
      (expr.app
        (expr.app predicate (expr.lam eev bb eet prr))
        (expr.app
          (expr.app
            (expr.app (expr.app pm hhh) eee)
            (expr.app (expr.app (expr.app pf hhha) eeea) (expr.var 0)))
          (expr.app (expr.app (expr.app `(override)
            (expr.app
                (expr.app (expr.app ps hhhb) eeeb)
                (expr.var 0)))
            vv)
          ee))))
    end

| (expr.app a b) := expr.app (simplify_override_predicate_helper a) (simplify_override_predicate_helper b)
| (expr.lam v b t e) := expr.lam v b (simplify_override_predicate_helper t) (simplify_override_predicate_helper e)
| (expr.pi v b t e) := expr.pi v b (simplify_override_predicate_helper t) (simplify_override_predicate_helper e)
| x := x

meta def xxx : expr → expr
| e := `(absCompose absNone absNone (empty_heap,empty_env)).

meta def simplify_override : tactic unit :=
do { t ← target,
     tgt ← instantiate_mvars t,
     trace "input333333",
     trace tgt.to_raw_fmt,
     nt ← some (simplify_override_helper tgt),
     trace "output prelim",
     trace nt.to_raw_fmt,
     trace "testit3",
     qq ← some (xxx tgt),
     trace qq.to_raw_fmt,
     assert `xxx nt,swap,admit
    }
meta def simplify_override2 : tactic unit :=
do { t ← target,
     tgt ← instantiate_mvars t,
     trace "input",
     trace tgt.to_raw_fmt,
     nt ← some (simplify_override_helperb tgt),
     trace "output",
     trace nt.to_raw_fmt,
     trace "testit112",
     assert `xxx nt,swap,admit
    }

meta def simplify_override_predicate : tactic unit :=
do { t ← target,
     tgt ← instantiate_mvars t,
     trace "input1",
     trace tgt.to_raw_fmt,
     nt ← some (simplify_override_predicate_helper tgt),
     trace "output2",
     trace nt.to_raw_fmt,
     trace "testit",
     assert `xxx nt,swap,admit
    }

meta def simplify_tree : tactic unit :=
do { t ← target,
     tgt ← instantiate_mvars t,
     trace "input1",
     trace tgt.to_raw_fmt,
     nt ← some (simplify_tree_helper tgt),
     trace "output2",
     trace nt.to_raw_fmt,
     trace "testit",
     assert `xxx nt,swap,admit
    }

@[simp] theorem dist_conj (a : absState) (b : absState) (f : imp_state → imp_state) (st : imp_state) :
    (absCompose a b) (f st) = (absCompose (λ st, a (f st)) (λ st, b (f st))) st :=
begin
    admit
end

@[simp] theorem dist_exists_lambda (t:Type) (a: imp_state → Prop) (st : imp_state) (f : imp_state → imp_state):
    absExists (λ (v:t), a) (f st)=absExists (λ (v:t), (λ st, a (f st))) st :=
begin
    admit
end

@[simp] theorem dist_absPredicate (f: env → Prop) (v : ident)
    (e : ℕ) (st : imp_state) :
    absPredicate f (override_state v e st)=
    (absPredicate (λ env, f (override env v e)) st)  :=
begin
    admit
end

@[simp] theorem dist_absTree (r : env → ℕ) (s : ℕ) (f : list ℕ)
                             (st : imp_state) (v : ident) (e : ℕ)
                             (vv : Value) :
    (absTree r s f vv) (override_state v e st)=
    (absTree (λ ee, r (override ee v e)) s f vv) st :=
begin
    admit
end

@[simp] theorem dist_absExistsAbsTree (r : env → ℕ) (s : ℕ) (f : list ℕ)
                             (st : imp_state) (v : ident) (e : ℕ) :
    absExists (absTree r s f) (override_state v e st)=
    absExists (absTree (λ ee, r (override ee v e)) s f) st :=
begin
    admit
end


theorem ex : ∀ x : Unit, x = () := by
  intro (); rfl


import Lean
--#eval Lean.versionString

def extendBoolTape (t : Array Bool) : Array Bool :=
  t ++ [false]

def flipTape (n : Nat) (t : Array Bool) (newT : Array Bool) : Array Bool :=
  match n with
  | 0 => newT
  | n+1 => flipTape n t (newT ++ [t[n]])

--syntactic sugar since this are almost always the parameters for flipTape
def flipTapeShort (t : Array Bool) : Array Bool :=
  flipTape t.size t #[]

--k is the rewrite position, newT is the new tape, s is the new value to write and n is tape size
def rewriteHelp (k : Nat) (newT : Array Bool) (s : Bool) (t : Array Bool)  (n : Nat) : Array Bool :=
  match n, k with
  | 0, _ => newT
  | n+1, 0 => rewriteHelp (n+1) (newT ++ [s]) s t n
  | n+1, k+1 => rewriteHelp k (newT ++ [t[n]]) s t n

--s if the new value to be written at spot n in the tape, t is the tape
def rewrite (s : Bool) (t : Array Bool) (n : Nat) : Array Bool :=
  if s = t[n] then t --if they are the same don't do anything, saves computation
  else t.set! n s

def extendBoolTapeLeft (t : Array Bool) : Array Bool :=
  t.insertAt 0 false

structure TM where
  h : Nat
  t : Array Bool
  q : Int
deriving Repr

def makeTM (head : Nat) (tape : Array Bool) (qState : Int) : TM :=
  {h := head, t := tape, q := qState}

structure TMstate where
  q : Int
  s : Bool
  m : Int
deriving Repr

def makeTMstate (qState : Int) (symbol : Bool) (move : Int) : TMstate :=
  {q := qState, s := symbol, m := move}

--#eval makeTMstate 1 true 1

def translateMove (m : Int) (h : Nat) : Nat :=
  match m with
  | 1 => (h+1)
  | -1 => (h-1)
  | _ => h

def checkTapeBorders (t : Array Bool) (h : Nat) : TM :=
  match h, (t.size - h) with
  | 0, _ => makeTM (h+1) (extendBoolTapeLeft t) (-2)
  | _, 1 => makeTM h (extendBoolTape t) (-2)
  | _, _ => makeTM h t (-2)

def stepMoveHelp (tm : TM) (m : Int) : TM :=
  makeTM (translateMove m tm.h) tm.t (-2)

def stepMove (t : Array Bool) (h : Nat) (m : Int) : TM :=
  stepMoveHelp (checkTapeBorders t h) m

def copyTM (tm : TM) : TM :=
  {h := tm.h, t := tm.t, q := tm.q}

--this temp strat assumes that LEAN doesn't use pointers and instead actually stores a copy
--of the data at the "variable" location
--without a doubt the uglieast part of my code, since new variables cannot be created we must create
--one by passing a duplicate of the original inside since we need to fetch information from the old
--TM state while having one for which we can update the values
def inputStep (tm : TM) (tempTm : TM) (TMIcode : (h : Nat) → (t : Array Bool) → (q : Int) → TMstate) : TM :=
  makeTM (stepMove tm.t tm.h (TMIcode tm.h tm.t tm.q).m).h (rewrite (TMIcode tempTm.h tm.t tempTm.q).s (stepMove tm.t tempTm.h (TMIcode tempTm.h tm.t tm.q).m).t tempTm.h) (TMIcode tempTm.h tempTm.t tempTm.q).q
--can i just nest this massive set of calls in smaller functions and remove the temp faff?

def run (n : Nat) (tm : TM) (TMIcode : (h : Nat) → (t : Array Bool) → (q : Int) → TMstate) :=
  match n, tm.q with
  | 0, _ => tm
  | _, -1 => tm
  | n+1, _ => run n (inputStep tm (copyTM tm) TMIcode) TMIcode

--this function just exists to make interfacing with the tm slicker, just input max steps, tape and code
def interface (maxSteps : Nat) (tape : Array Bool) (TMIcode : (h : Nat) → (t : Array Bool) → (q : Int) → TMstate) :=
  (run maxSteps (makeTM 1 tape 0) TMIcode).t

def verifySegment (turingSeg : Bool) (verifierSeg : Bool) (validThusFar : Bool) : Bool :=
  (turingSeg ↔ verifierSeg) ∧ validThusFar
  --match turingSeg, verifierSeg, validThusFar with
  --| true, true, true => true
  --| false, false, true => true
  --| true, false, true => false
  --| false, true, true => false
  --| _, _, false => false

def trimOneEnd (t : Array Bool) (size : Nat) : Array Bool :=
  match size, t[size] with
  | 0, _ => t
  | n+1, false => trimOneEnd (t.eraseIdx (n+1)) (n)
  | n+1, true => t

def trimTapeHelp (t : Array Bool) : Array Bool :=
  trimOneEnd (flipTape t.size t #[]) (t.size-1)

def trimTape (t : Array Bool) : Array Bool :=
  flipTapeShort (trimTapeHelp (trimOneEnd t (t.size-1)))

def testPls := #[false, false, true, true, false, true, false]

--#eval trimTape testPls

def verifyTape (turingTape : Array Bool) (verifierTape : Array Bool) : Bool :=
  trimTape turingTape = trimTape verifierTape
  --match n with
  --| 0 => verifySegment turingTape[0] verifierTape[0] validThusFar --since the leftmost should always be false item zero need not be checked
  --| n+1 => verifyTape n turingTape verifierTape (verifySegment turingTape[n] verifierTape[n] validThusFar)

def tapeToIntHelp (n : Nat) (t : Array Bool) : Nat :=
  match n, t[n] with
  | 0, _ => 0
  | n+1, true => tapeToIntHelp n t + 1
  | n+1, false => tapeToIntHelp n t

def tapeToInt (t : Array Bool) : Nat :=
  tapeToIntHelp (t.size -1) t

def intToTapeHelp (n : Nat) : Array Bool :=
  match n with
  | 0 => #[false]
  | n+1 => (intToTapeHelp n) ++ #[true]

def intToTape (n : Nat) : Array Bool :=
  intToTapeHelp n ++ #[false]

def intToLTapeHelp (n : Nat) : List Bool :=
  match n with
  | 0 => [false]
  | n+1 => true :: (intToLTapeHelp n)

def intToLTape (n : Nat) : List Bool :=
  false :: intToLTapeHelp n

--succ n turing machine
def TMsucc (h : Nat) (t : Array Bool) (q : Int) : TMstate :=
  match t[h], q with
  | true, 0 => makeTMstate 0 true 1
  | false, 0 => makeTMstate (-1) true 1
  | _, _ => makeTMstate (-1) false 0

--addition turing machine
def TMadd (h : Nat) (t : Array Bool) (q : Int) : TMstate :=
  match t[h], q with
  | true, 0 => makeTMstate 0 true 1
  | false, 0 => makeTMstate 1 true 1
  | true, 1 => makeTMstate 1 true 1
  | false, 1 => makeTMstate 2 false (-1)
  | true, 2 => makeTMstate (-1) false 0
  | false, 2 => makeTMstate (-1) false 0 --error
  | _, _ => makeTMstate (-1) false 0

--#eval verifyTape 5 #[false, true, true, false, false] #[false, true, true, false, false] true

def threeTape : Array Bool := #[false, true, true, true, false, false]

def addTape : Array Bool := #[false, true, true, false, true, true, true, false, false, false]

--#eval run 10 (makeTM 0 (run 10 (makeTM 0 addTape 0) TMadd).t 0) TMsucc
--#eval run 10 (makeTM 0 (run 10 (makeTM 0 addTape 0) TMsucc).t 0) TMadd

--#eval verifyTape addTape.size (run 10 (makeTM 0 (run 10 (makeTM 0 addTape 0) TMadd).t 0) TMsucc).t (run 10 (makeTM 0 (run 10 (makeTM 0 addTape 0) TMsucc).t 0) TMadd).t true

--#eval (run 10 (makeTM 0 #[false, true, true, true, false] 0) TMsucc).t
#eval interface 10 addTape TMadd

def stateCountTM (h : Nat) (t : Array Bool) (q : Int) : TMstate :=
  match t[h], q with
  | true, 0 => makeTMstate 0 false 1
  | false, 0 => makeTMstate 1 true 1
  | true, 1 => makeTMstate 1 false 1
  | false, 1 => makeTMstate 2 false 1
  | true, 2 => makeTMstate 2 false 1
  | false, 2 => makeTMstate 3 false 1
  | true, 3 => makeTMstate 3 false 1
  | false, 3 => makeTMstate 4 false 1
  | true, 4 => makeTMstate 4 false 1 --error
  | false, 4 => makeTMstate 5 false 1
  | true, 5 => makeTMstate (-1) true 1
  | false, 5 => makeTMstate 6 false 1
  | true, 6 => makeTMstate 1 false 1
  | false, 6 => makeTMstate 7 false 1
  | true, 7 => makeTMstate 8 true (-1)
  | false, 7 => makeTMstate (-1) false 0 --program end
  | true, 8 => makeTMstate 9 true 1
  | false, 8 => makeTMstate 8 false (-1)
  | true, 9 => makeTMstate (-1) true 0 --error
  | false, 9 => makeTMstate 10 true 1
  | true, 10 => makeTMstate 11 false 1
  | false, 10 => makeTMstate 10 false 1
  | true, 11 => makeTMstate 11 false 1
  | false, 11 => makeTMstate 1 false 1
  | _, _ => makeTMstate (-1) false 0

def succEncoding : Array Bool :=
#[false,
  false, true, false, true, true, false, true, true, true, false, true, false, false,
  true, true, false, true, false, true, false, true, true, false, false, false,
  true, false, true, false, true, false, true, false, true, false, false,
  true, true, false, true, false, true, true, true, false, true, false, false, false, false]

--#eval succEncoding.size

def addEncoding : Array Bool :=
#[false,
  false, true, false, true, true, false, true, true, true, true, true, false, true, false, false,
  true, true, false, true, false, true, false, true, true, false, false, false,
  true, false, true, false, true, false, true, false, true, false, false,
  true, true, false, true, false, true, true, false, true, false, false, false,
  true, true, false, true, false, true, false, true, true, false, true, false, false,
  true, true, false, true, true, false, true, true, true, false, true, true, false, false, false,
  true, true, true, false, true, false, true, true, false, true, true, true, true, true, false, true, true, false, false,
  true, true, false, true, true, false, true, true, true, true, true, false, true, true, false, false, false, false]

#eval addEncoding.size

--#eval (run 419 (makeTM 1 addEncoding 0) stateCountTM).t

def stateCountEncoding : Array Bool :=
#[false, false, true, false, true, false, false, true, true, false, false,
  true, true, false, true, false, true, false, true, false, false, false,
  true, false, true, false, true, false, true, false, true, true, false, false,
  true, true, false, true, false, true, true, false, true, true, false, false, false,
  true, true, false, true, false, true, false, true, true, false, true, true, false, false,
  true, true, false, true, false, true, true, true, false, true, true, false, false, false,
  true, true, true, false, true, false, true, false, true, true, true, false, true, true, false, false,
  true, true, false, true, false, true, true, true, true, false, true, true, false, false, false,
  true, true, true, true, false, true, false, true, false, true, true, true, true, false, true, true, false, false,
  true, true, false, true, false, true, true, true, true, true, false, true, true, false, false, false,
  true, true, true, true, true, false, true, false, true, false, true, true, true, true, true, true, true, true, true, true, true, true, true, false, true, false, false,
  true, true, false, true, false, true, true, true, true, true, true, false, true, true, false, false, false,
  true, true, true, true, true, true, false, true, false, true, false, true, false, true, true, false, false,
  true, true, false, true, false, true, true, true, true, true, true, true, false, true, true, false, false, false,
  true, true, true, true, true, true, true, false, true, false, true, true, false, true, true, true, true, true, true, true, true, false, true, false, false,
  true, true, false, true, true, false, true, true, true, true, true, true, true, true, true, true, true, true, true, false, true, true, false, false, false,
  true, true, true, true, true, true, true, true, false, true, false, true, false, true, true, true, true, true, true, true, true, true, false, true, false, false,
  true, true, false, true, true, false, true, true, true, true, true, true, true, true, false, true, true, false, false, false,
  true, true, true, true, true, true, true, true, true, false, true, false, true, true, false, true, true, true, true, true, true, true, true, true, true, true, true, true, false, true, false, false,
  true, true, false, true, false, true, true, true, true, true, true, true, true, true, true, false, true, false, false, false,
  true, true, true, true, true, true, true, true, true, true, false, true, false, true, false, true, true, true, true, true, true, true, true, true, true, true, false, true, true, false, false,
  true, true, false, true, false, true, true, true, true, true, true, true, true, true, true, false, true, true, false, false, false,
  true, true, true, true, true, true, true, true, true, true, true, false, true, false, true, false, true, true, true, true, true, true, true, true, true, true, true, false, true, true, false, false,
  true, true, false, true, false, true, false, true, true, false, false, false, false]

#eval stateCountEncoding.size

--#eval tapeToInt (interface 4657 stateCountEncoding stateCountTM)
--#eval [false, true, false].get! 2
--#eval [false, true, false]

def zeroTape := #[false, false]

--axiom zero_to_tm : 0 = tapeToInt 3 #[false, false, false, false]

axiom zero_to_tm : intToTape 0 = #[false, false]

theorem tm_to_zero : #[false, false] = intToTape 0 := by
  rw [zero_to_tm]

axiom succ_in_tm (n : Nat) : intToTape (Nat.succ n) = (interface (n+2) (intToTape n) TMsucc)

theorem TMsucc_in_nat (n : Nat) : (interface (n+2) (intToTape n) TMsucc) = intToTape (Nat.succ n) := by
  rw [succ_in_tm]

--axiom TM_succ_evals (n : Nat ): (interface (n+2) (intToTape n) TMsucc) = #[false, true{n times}, false]

#eval tapeToInt #[false, true, true, false]

theorem oneTMrep : intToTape (Nat.succ 0) = (interface (2) (intToTape 0) TMsucc) := by
  rw [succ_in_tm]

theorem one_eq_succ_zero: 1 = Nat.succ 0 := by
  rw [Nat.succ_eq_add_one]

#eval interface 2 #[false, false] TMsucc
#eval intToTape 1

theorem one_to_tape : intToLTape (1) = [false, true, false] := by
  unfold intToLTape
  unfold intToLTapeHelp
  unfold intToLTapeHelp
  simp

def listTapeSucc (t : List Bool) : List Bool :=
  false :: (true :: (t.eraseIdx 0))

#eval listTapeSucc [false, true, true, false]

theorem proof_of_concept : intToLTape (Nat.succ 0) = listTapeSucc [false, false] := by
  rw [Nat.succ_eq_add_one]
  rw [Nat.zero_add]
  unfold intToLTape
  unfold intToLTapeHelp
  unfold intToLTapeHelp
  unfold listTapeSucc
  unfold List.eraseIdx
  simp

--1 = tapeToInt 3 #[false, true, false, false]
--1 = tapeToInt 3

 -- succ_eq_add_one succ n = n + 1


import .lang
import .forget
import .free_ralg
import .fron_ralg
import .add_rules
import .ualg

namespace rules_hom

variables {L0 : lang} {R0 : rules L0} {L1 : lang} {R1 : rules L1}
variables (ι : R0 →# R1)
variables (A : Type*) [ualg R0 A]

include ι
def fron := R1.add (ι.lhom.fron A)

namespace fron

instance : has_app L1 (ι.fron A) := rules.add.has_app R1 _
instance : compat ι.lhom (ι.fron A) := ι.lhom.forget_along _

def univ : A →$[L0] (ι.fron A) :=
  (lang_hom.fron.univ ι.lhom A).comp
  ((rules.add.univ R1 (ι.lhom.fron A)).drop ι.lhom)

variable {A}
def lift {B : Type*} [ualg R1 B] [compat ι.lhom B] (f : A →$[L0] B) :
  ι.fron A →$[L1] B :=
    rules.add.lift R1 $
    lang_hom.fron.lift _ f

theorem univ_comp_lift {B : Type*} [ualg R1 B] [compat ι.lhom B] (f : A →$[L0] B) :
  (univ ι A).comp ((lift ι f).drop ι.lhom) = f := by {ext, refl}

theorem lift_unique {B : Type*} [ualg R1 B] [compat ι.lhom B] (f : A →$[L0] B)
  (g : ι.fron A →$[L1] B) : (univ ι A).comp (g.drop ι.lhom) = f → g = lift ι f :=
begin
  intro hyp,
  apply rules.add.lift_unique,
  apply lang_hom.fron.lift_unique,
  assumption,
end

end fron

end rules_hom


structure LockedType {T : Sort u} (T' : Sort u) (x : T) where
  val : T'
  type_eq : T = T'
  val_eqv : HEq val x

infix:50 " ~= " => HEq

theorem Eq.toHEq {α} {x y : α} (h : x = y) : x ~= y :=
by cases h; constructor

theorem HEq.toEq {α} {x y : α} (h : x ~= y) : x = y :=
by cases h; rfl

namespace Transport

structure EqvTypes (T T' : Sort u) : Prop where
  rfl : T = T'

class EqvTerm {α α' : Sort u} (x : α) (y : α') : Prop where
  rfl : x ~= y

def refl : EqvTypes T T where
  rfl := rfl

def EqvTypes_arrow {α α' : Sort u} {β β' : Sort v}
    (h₀ : EqvTypes α α') (h₁ : EqvTypes β β') :
         EqvTypes (α → β) (α' → β') where
  rfl := by rw [h₀.rfl, h₁.rfl]

def EqvTypes_forall' {α}
  {β : α → Sort u}
  {β' : α → Sort u}
  (h : ∀ (x : α), EqvTypes (β x) (β' x)) :
  EqvTypes (∀ x, β x) (∀ x, β' x) where
    rfl := by
      have h₀ : ∀ x, β x = β' x :=
        λ x => h x |>.rfl
      have h₁ : β = β' := funext h₀
      rw  [h₁]

def EqvTypes_forall {α α'} (h' : EqvTypes.{v} α α')
  {β : α → Sort u}
  {β' : α' → Sort u}
  (h : ∀ (x : α) (y : α'), EqvTerm x y → EqvTypes (β x) (β' y)) :
  EqvTypes (∀ x, β x) (∀ x, β' x) where
    rfl := by
      have := h'.rfl; subst this
      have h₀ : ∀ x, β x = β' x :=
        λ x => h x x ⟨ HEq.rfl ⟩ |>.rfl
      have h₁ : β = β' := funext h₀
      rw  [h₁]

def EqvTerm_app {α α'} {β β'} (f : α → β) (g : α' → β') x y
    (h₀ : EqvTypes α α')
    (h₁ : EqvTypes β β')
    (h₂ : EqvTerm f g)
    (h₃ : EqvTerm x y) :
  EqvTerm (f x) (g y) where
    rfl := by
      have := h₀.rfl; subst this
      have := h₁.rfl; subst this
      have := HEq.toEq h₂.rfl; subst this
      have := HEq.toEq h₃.rfl; subst this
      constructor

def EqvTerm_app' {α α'} {β : α → Type u} {β' : α' → Type u}
    (f : (x : α) → β x) (g : (x : α') → β' x) x y
    (h₀ : EqvTypes α α')
    (h₁ : EqvTerm β β')
    (h₂ : EqvTerm f g)
    (h₃ : EqvTerm x y) :
  EqvTerm (f x) (g y) where
    rfl := by
      have := h₀.rfl; subst this
      have := HEq.toEq h₃.rfl; subst this
      have := HEq.toEq h₁.rfl; subst this
      have := HEq.toEq h₂.rfl; subst this
      constructor

def EqvTypes_of_EqvTerm {α α'} (h : EqvTerm α α') : EqvTypes α α' where
  rfl := by
    have := h.rfl; cases this
    constructor

instance EqvTypes_of_EqvTerm' {α α'} [EqvTerm α α'] : EqvTypes α α' :=
by apply EqvTypes_of_EqvTerm <;> assumption

instance (x : α) : EqvTerm x x where
  rfl := HEq.rfl

def transport α α' (h : EqvTypes α' α) (x : α) : α' :=
cast (EqvTypes.rfl h |>.symm) x

def transport_eq α α' (h : EqvTypes α' α) (x : α) :
  HEq (transport α α' h x) x := by
have h := @EqvTypes.rfl α' α h
subst h
constructor

def mkLockedType (α) {α'} (x : α')
    -- (h : EqvTypes α' α := by prove_transport) :
    (h : EqvTypes α α') :
    LockedType α x where
  val := transport _ _ h x
  type_eq := EqvTypes.rfl h |>.symm
  val_eqv := transport_eq _ _ h _

def EqvTerm.ofEq {x y : α} (h : x = y) : EqvTerm x y where
  rfl:= h.toHEq

def EqvTerm.ofHEq {α β} {x : α} {y : β} (h : x ~= y) :
    EqvTerm x y where
  rfl:= h

end Transport


-- Copyright (c) 2017 Scott Morrison. All rights reserved.
-- Released under Apache 2.0 license as described in the file LICENSE.
-- Authors: Tim Baumann, Stephen Morgan, Scott Morrison

import category_theory.isomorphism
import category_theory.functor_category

open category_theory

namespace category_theory.nat_iso

universes u₁ u₂ v₁ v₂

variables {C : Type u₁} [𝒞 : category.{u₁ v₁} C] {D : Type u₂} [𝒟 : category.{u₂ v₂} D]
include 𝒞 𝒟

def app {F G : C ⥤ D} (α : F ≅ G) (X : C) : F X ≅ G X :=
{ hom := (α : F ⟶ G) X,
  inv := (α.symm : G ⟶ F) X,
  hom_inv_id' := begin rw [← functor.category.comp_app, iso.hom_inv_id], refl, end,
  inv_hom_id' := begin rw [← functor.category.comp_app, iso.inv_hom_id], refl, end }

instance {F G : C ⥤ D} : has_coe_to_fun (F ≅ G) :=
{ F   := λ α, Π X : C, (F X) ≅ (G X),
  coe := λ α, app α }

@[simp] lemma mk_app {F G : C ⥤ D} (hom : F ⟹ G) (inv) (hom_inv_id') (inv_hom_id') (X : C) :
  ({ hom := hom, inv := inv, hom_inv_id' := hom_inv_id', inv_hom_id' := inv_hom_id' } : F ≅ G) X =
  { hom := hom X, inv := inv X,
    hom_inv_id' := congr_fun (congr_arg nat_trans.app hom_inv_id') X,
    inv_hom_id' := congr_fun (congr_arg nat_trans.app inv_hom_id') X } :=
rfl
@[simp] lemma mk_app' {F G : C ⥤ D} (hom : F ⟹ G) (inv) (hom_inv_id') (inv_hom_id') (X : C) :
  (({ hom := hom, inv := inv, hom_inv_id' := hom_inv_id', inv_hom_id' := inv_hom_id' } : F ≅ G) : F ⟹ G) X = hom X :=
rfl

@[simp] lemma comp_app {F G H : C ⥤ D} (α : F ≅ G) (β : G ≅ H) (X : C) :
  ((α ≪≫ β) : F ⟹ H) X = α X ≪≫ β X := rfl

@[simp] lemma hom_eq_coe {F G : C ⥤ D} (α : F ≅ G) (X : C) : α.hom X = (α : F ⟶ G) X := rfl
@[simp] lemma inv_eq_symm_coe {F G : C ⥤ D} (α : F ≅ G) (X : C) : α.inv X = (α.symm : G ⟶ F) X := rfl

variables {F G : C ⥤ D}

instance hom_app_is_iso (α : F ≅ G) (X : C) : is_iso ((α : F ⟶ G) X) :=
{ inv := α.inv X,
  hom_inv_id' := begin dsimp at *, erw [←functor.category.comp_app, iso.hom_inv_id, ←functor.category.id_app] end,
  inv_hom_id' := begin dsimp at *, erw [←functor.category.comp_app, iso.inv_hom_id, ←functor.category.id_app] end }
instance inv_app_is_iso (α : F ≅ G) (X : C) : is_iso ((α.symm : G ⟶ F) X) :=
{ inv := α.hom X,
  hom_inv_id' := begin dsimp at *, erw [is_iso.hom_inv_id] end,
  inv_hom_id' := begin dsimp at *, erw [is_iso.hom_inv_id] end }

variables {X Y : C}
@[simp] lemma naturality_1 (α : F ≅ G) (f : X ⟶ Y) :
  ((α.symm : G ⟶ F) X) ≫ (F.map f) ≫ ((α : F ⟶ G) Y) = G.map f :=
begin erw [nat_trans.naturality, ←category.assoc, is_iso.hom_inv_id, category.id_comp] end
@[simp] lemma naturality_2 (α : F ≅ G) (f : X ⟶ Y) :
  ((α : F ⟶ G) X) ≫ (G.map f) ≫ ((α.symm : G ⟶ F) Y) = F.map f :=
begin erw [nat_trans.naturality, ←category.assoc, is_iso.hom_inv_id, category.id_comp] end

def of_components (app : ∀ X : C, (F X) ≅ (G X))
  (naturality : ∀ {X Y : C} (f : X ⟶ Y), (F.map f) ≫ ((app Y) : F Y ⟶ G Y) = ((app X) : F X ⟶ G X) ≫ (G.map f)) :
  F ≅ G :=
{ hom  := { app := λ X, ((app X) : F X ⟶ G X), },
  inv  :=
  { app := λ X, ((app X).symm : G X ⟶ F X),
    naturality' := λ X Y f,
    begin
      let p := congr_arg (λ f, (app X).inv ≫ (f ≫ (app Y).inv)) (eq.symm (naturality f)),
      dsimp at *,
      simp at *,
      erw [←p, ←category.assoc, is_iso.hom_inv_id, category.id_comp],
    end } }.

@[simp] def of_components.app (app' : ∀ X : C, (F X) ≅ (G X)) (naturality) (X) :
  app (of_components app' naturality) X = app' X :=
by tidy
@[simp] def of_components.hom_app (app : ∀ X : C, (F X) ≅ (G X)) (naturality) (X) :
  ((of_components app naturality) : F ⟹ G) X = app X := rfl
@[simp] def of_components.inv_app (app : ∀ X : C, (F X) ≅ (G X)) (naturality) (X) :
  ((of_components app naturality).symm : G ⟹ F) X = (app X).symm := rfl

end category_theory.nat_iso

namespace category_theory.functor

universes u₁ u₂ v₁ v₂

section
variables {C : Type u₁} [𝒞 : category.{u₁ v₁} C]
          {D : Type u₂} [𝒟 : category.{u₂ v₂} D]
include 𝒞 𝒟

@[simp] def id_comp (F : C ⥤ D) : functor.id C ⋙ F ≅ F :=
{ hom :=
  { app := λ X, 𝟙 (F X) },
  inv :=
  { app := λ X, 𝟙 (F X) }
}
@[simp] def comp_id (F : C ⥤ D) : F ⋙ functor.id D ≅ F :=
{ hom :=
  { app := λ X, 𝟙 (F X) },
  inv :=
  { app := λ X, 𝟙 (F X) }
}

universes u₃ v₃ u₄ v₄

variables {A : Type u₃} [𝒜 : category.{u₃ v₃} A]
          {B : Type u₄} [ℬ : category.{u₄ v₄} B]
include 𝒜 ℬ
variables (F : A ⥤ B) (G : B ⥤ C) (H : C ⥤ D)

@[simp] def assoc : (F ⋙ G) ⋙ H ≅ F ⋙ (G ⋙ H ):=
{ hom :=
  { app := λ X, 𝟙 (H (G (F X))) },
  inv :=
  { app := λ X, 𝟙 (H (G (F X))) }
}

-- When it's time to define monoidal categories and 2-categories,
-- we'll need to add lemmas relating these natural isomorphisms,
-- in particular the pentagon for the associator.
end

section
variables {C : Type u₁} [𝒞 : category.{u₁ v₁} C]
include 𝒞

def ulift_down_up : ulift_down.{u₁ v₁ u₂} C ⋙ ulift_up C ≅ functor.id (ulift.{u₂} C) :=
{ hom := { app := λ X, @category.id (ulift.{u₂} C) _ X },
  inv := { app := λ X, @category.id (ulift.{u₂} C) _ X } }

def ulift_up_down : ulift_up.{u₁ v₁ u₂} C ⋙ ulift_down C ≅ functor.id C :=
{ hom := { app := λ X, 𝟙 X },
  inv := { app := λ X, 𝟙 X } }

end

end category_theory.functor


/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
prelude
import init.data.option.basic
import init.meta.tactic
import init.control.lawful

universes u v

instance : is_lawful_monad option :=
{ id_map := λ α x, option.rec rfl (λ x, rfl) x,
  pure_bind := λ α β x f, rfl,
  bind_assoc := λ α β γ x f g, option.rec rfl (λ x, rfl) x }

lemma option.eq_of_eq_some {α : Type u} : Π {x y : option α}, (∀z, x = some z ↔ y = some z) → x = y
| none     none     h := rfl
| none     (some z) h := option.no_confusion ((h z).2 rfl)
| (some z) none     h := option.no_confusion ((h z).1 rfl)
| (some z) (some w) h := option.no_confusion ((h w).2 rfl) (congr_arg some)

lemma option.eq_some_of_is_some {α : Type u} : Π {o : option α} (h : option.is_some o), o = some (option.get h)
| (some x) h := rfl

lemma option.eq_none_of_is_none {α : Type u} : Π {o : option α}, o.is_none → o = none
| none h := rfl


/-
Copyright (c) 2019 Paul-Nicolas Madelaine. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Paul-Nicolas Madelaine, Robert Y. Lewis, Mario Carneiro, Gabriel Ebner
-/

import Lean
import Mathlib.Tactic.NormCast.CoeExt
import Mathlib.Tactic.RunCmd

open Lean Meta

namespace Tactic.NormCast

/--
`label` is a type used to classify `norm_cast` lemmas.
* elim lemma:   LHS has 0 head coes and ≥ 1 internal coe
* move lemma:   LHS has 1 head coe and 0 internal coes,    RHS has 0 head coes and ≥ 1 internal coes
* squash lemma: LHS has ≥ 1 head coes and 0 internal coes, RHS has fewer head coes
-/
inductive Label
  | elim
  | move
  | squash
  deriving DecidableEq, Repr, Inhabited

def getSimpArgs (e : Expr) : MetaM (Array Expr) := do
  match ← mkCongrSimp? e.getAppFn with
  | none => return e.getAppArgs
  | some {argKinds, ..} =>
    let mut args := #[]
    for a in e.getAppArgs, k in argKinds do
      if k matches CongrArgKind.eq then
        args := args.push a
    return args

/-- Count how many coercions are at the top of the expression. -/
partial def countHeadCoes (e : Expr) : MetaM Nat := do
  if let Expr.const fn .. := e.getAppFn then
    if let some info ← getCoeFnInfo? fn then
      if e.getAppNumArgs >= info.numArgs then
        return (← countHeadCoes (e.getArg! info.coercee)) + 1
  return 0

/-- Count how many coercions are inside the expression, including the top ones. -/
partial def countCoes (e : Expr) : MetaM Nat :=
  lambdaTelescope e fun xs e => do
    if let Expr.const fn .. := e.getAppFn then
      if let some info ← getCoeFnInfo? fn then
        if e.getAppNumArgs >= info.numArgs then
          let mut coes := (← countHeadCoes (e.getArg! info.coercee)) + 1
          for i in [info.numArgs:e.getAppNumArgs] do
            coes := coes + (← countCoes (e.getArg! i))
          return coes
    return (← (← getSimpArgs e).mapM countCoes).foldl (·+·) 0

/-- Count how many coercions are inside the expression, excluding the top ones. -/
def countInternalCoes (e : Expr) : MetaM Nat :=
  return (← countCoes e) - (← countHeadCoes e)

/-- Classifies a declaration of type `ty` as a `norm_cast` rule. -/
def classifyType (ty : Expr) : MetaM Label :=
  forallTelescopeReducing ty fun xs ty => do
    let ty ← whnf ty
    let (lhs, rhs) ←
      if ty.isAppOfArity ``Eq 3 then pure (ty.getArg! 1, ty.getArg! 2)
      else if ty.isAppOfArity ``Iff 2 then pure (ty.getArg! 0, ty.getArg! 1)
      else throwError "norm_cast: lemma must be = or ↔, but is{indentExpr ty}"
    let lhsCoes ← countCoes lhs
    if lhsCoes = 0 then throwError "norm_cast: badly shaped lemma, lhs must contain at least one coe{indentExpr lhs}"
    let lhsHeadCoes ← countHeadCoes lhs
    let lhsInternalCoes ← countInternalCoes lhs
    let rhsHeadCoes ← countHeadCoes rhs
    let rhsInternalCoes ← countInternalCoes rhs
    if lhsHeadCoes = 0 then
      return Label.elim
    else if lhsHeadCoes = 1 then do
      unless rhsHeadCoes = 0 do throwError "norm_cast: badly shaped lemma, rhs can't start with coe{indentExpr rhs}"
      if rhsInternalCoes = 0 then
        return Label.squash
      else
        return Label.move
    else if rhsHeadCoes < lhsHeadCoes then do
      return Label.squash
    else do
      throwError "norm_cast: badly shaped shaped squash lemma, rhs must have fewer head coes than lhs{indentExpr ty}"

initialize pushCastExt : SimpExtension ←
  registerSimpAttr `push_cast (extName := `Tactic.NormCast.pushCastExt) $
    "The `push_cast` simp attribute uses `norm_cast` lemmas " ++
    "to move casts toward the leaf nodes of the expression."

/--  The `norm_cast` attribute stores three simp sets. -/
structure NormCastExtension where
  up : SimpExtension
  down : SimpExtension
  squash : SimpExtension
  deriving Inhabited

initialize normCastExt : NormCastExtension ← pure {
  up := ← mkSimpExt `Tactic.NormCast.normCastExt.up
  down := ← mkSimpExt `Tactic.NormCast.normCastExt.down
  squash := ← mkSimpExt `Tactic.NormCast.normCastExt.squash
}

/-- `addElim decl` adds `decl` as an `elim` lemma to the cache. -/
def addElim (decl : Name)
    (kind := AttributeKind.global) (prio := eval_prio default) : MetaM Unit :=
  addSimpTheorem normCastExt.up decl (post := true) (inv := false) kind prio

/-- `addMove decl` adds `decl` as a `move` lemma to the cache. -/
def addMove (decl : Name)
    (kind := AttributeKind.global) (prio := eval_prio default) : MetaM Unit := do
  addSimpTheorem pushCastExt decl (post := true) (inv := false) kind prio
  addSimpTheorem normCastExt.up decl (post := true) (inv := true) kind prio
  addSimpTheorem normCastExt.down decl (post := true) (inv := false) kind prio

/-- `addSquash decl` adds `decl` as a `squash` lemma to the cache. -/
def addSquash (decl : Name)
    (kind := AttributeKind.global) (prio := eval_prio default) : MetaM Unit := do
  addSimpTheorem pushCastExt decl (post := true) (inv := false) kind prio
  addSimpTheorem normCastExt.squash decl (post := true) (inv := false) kind prio
  addSimpTheorem normCastExt.down decl (post := true) (inv := false) kind prio

/-- `addInfer decl` infers the label of `decl` and adds it to the cache.

* elim lemma:   LHS has 0 head coes and ≥ 1 internal coe
* move lemma:   LHS has 1 head coe and 0 internal coes,    RHS has 0 head coes and ≥ 1 internal coes
* squash lemma: LHS has ≥ 1 head coes and 0 internal coes, RHS has fewer head coes
-/
def addInfer (decl : Name)
    (kind := AttributeKind.global) (prio := eval_prio default) : MetaM Unit := do
  let ty := (← getConstInfo decl).type
  match ← classifyType ty with
  | Label.elim => addElim decl kind prio
  | Label.squash => addSquash decl kind prio
  | Label.move => addMove decl kind prio

namespace Attr
syntax normCastLabel := &"elim" <|> &"move" <|> &"squash"

/--
The `norm_cast` attribute should be given to lemmas that describe the
behaviour of a coercion in regard to an operator, a relation, or a particular
function.

It only concerns equality or iff lemmas involving `↑`, `⇑` and `↥`, describing the behavior of
the coercion functions.
It does not apply to the explicit functions that define the coercions.

Examples:
```lean
@[norm_cast] theorem coe_nat_inj' {m n : ℕ} : (↑m : ℤ) = ↑n ↔ m = n

@[norm_cast] theorem coe_int_denom (n : ℤ) : (n : ℚ).denom = 1

@[norm_cast] theorem cast_id : ∀ n : ℚ, ↑n = n

@[norm_cast] theorem coe_nat_add (m n : ℕ) : (↑(m + n) : ℤ) = ↑m + ↑n

@[norm_cast] theorem cast_coe_nat (n : ℕ) : ((n : ℤ) : α) = n

@[norm_cast] theorem cast_one : ((1 : ℚ) : α) = 1
```

Lemmas tagged with `@[norm_cast]` are classified into three categories: `move`, `elim`, and
`squash`. They are classified roughly as follows:

* elim lemma:   LHS has 0 head coes and ≥ 1 internal coe
* move lemma:   LHS has 1 head coe and 0 internal coes,    RHS has 0 head coes and ≥ 1 internal coes
* squash lemma: LHS has ≥ 1 head coes and 0 internal coes, RHS has fewer head coes

`norm_cast` uses `move` and `elim` lemmas to factor coercions toward the root of an expression
and to cancel them from both sides of an equation or relation. It uses `squash` lemmas to clean
up the result.

Occasionally you may want to override the automatic classification.
You can do this by giving an optional `elim`, `move`, or `squash` parameter to the attribute.

```lean
@[simp, norm_cast elim] lemma nat_cast_re (n : ℕ) : (n : ℂ).re = n := by
  rw [← of_real_nat_cast, of_real_re]
```

Don't do this unless you understand what you are doing.

A full description of the tactic, and the use of each lemma category, can be found at
<https://lean-forward.github.io/norm_cast/norm_cast.pdf>.
-/
syntax (name := normCast) "norm_cast" (ppSpace normCastLabel)? (ppSpace num)? : attr
end Attr

initialize registerBuiltinAttribute {
  name := `normCast
  descr := "attribute for norm_cast"
  add := fun decl stx kind => MetaM.run' do
    let `(attr| norm_cast $[$label:normCastLabel]? $[$prio]?) := stx | unreachable!
    let prio := (prio.bind Syntax.isNatLit?).getD (eval_prio default)
    match label.bind Syntax.isStrLit? with
    | "elim" => addElim decl kind prio
    | "move" => addMove decl kind prio
    | "squash" => addSquash decl kind prio
    | none => addInfer decl kind prio
    | _ => unreachable!
}


-- import system.io
import tactic
-- import data.equiv.basic

#print proof_irrel

def f (p q : Prop) : p ∨ q → ℕ
| (or.inl _) := 0
| (or.inr _) := 1

def f (x : Π {n : ℕ}, n < 0) : ℕ := sorry

def g (x : Π {n : ℕ}, n < 0) : ℕ := f x

--   example (α β γ δ ε: Type*) [unique β] [unique γ] [unique δ] [unique ε]
--   : (α → ((ℕ → β) → (ℕ → γ → δ) → (Σ (x_1 : ℕ), ε)) × ((ℕ → β) → (Σ (x_1 : ℕ), γ))) ≃
--   (α → ℕ × ℕ)

-- open io

example (α : Type) (x : α) : cast _ x = x := by {
  exact cast_eq rfl x,
}

example (α : Type) (a b c : α) (h : a = b) (h' : b = c) : a = c := by {
}

#check cast_cast
set_option pp.proofs true
example (α β : Type) (x : α) (h : α = β) : cast h.symm (cast h x) = x := by {
  have := cast_cast h h.symm x,
  exact this,
}
set_option pp.proofs false

-- inductive formula
-- | conj : formula → formula → formula
-- | disj : formula → formula → formula

-- infixl `⋀` : 50 := formula.conj
-- infixl `⋁` : 50 := formula.disj

-- def formula.interpret : formula → Prop
-- | (A ⋀ B) := A.interpret ∧ B.interpret
-- | (A ⋁ B) := A.interpret ∨ B.interpret

-- notation `∥` A `∥` := formula.interpret A

-- example (A : formula) : ∥A∥ → true := by {
--   induction A,
--   case conj {

--   }
-- }

-- example (α β : Type) (p : α → β → Prop) [unique α] [unique β] : (∃ x, ∀ y, p x y) ↔ p (default _) (default _) :=
-- begin
--   -- obvious
--   tidy?,
-- end

-- end

--   inductive type
--   | ground : type
--   | arrow : type → type → type

--   universes u

--   inductive is_grf : ∀ {α β : Type u}, (α → β) → Type (u + 1)
--   | k : ∀ {α β : Type u}, is_grf (λ (x : α) (y : β), x)

--   def interpret : type → Type u
--   | type.ground := ulift ℕ
--   | (type.arrow σ τ) := is_grf (interpret σ → interpret τ)

-- #check @grf ℕ ℕ

-- def main : io unit := do
--   return ()

-- section
--   inductive T
--   | zero : T
--   | suc : T
-- end

-- section
--   variables α β : Type*
--   #check equiv
--   example (a : α) (p : equiv α β) : β := p a
-- end

-- example : false → false :=
-- begin
--   my_tac h,
-- end

-- -- example (α β : Type) : subsingleton (α → β) → subsingleton β :=
-- -- begin
-- --   intros h,
-- --   apply subsingleton.intro,
-- --   intros a b,
-- --   by_contra,
-- --   set f₁ := λ _ : α, a,
-- --   set f₂ := λ _ : α, b,
-- -- end

-- example (α : Type*) (p : α → Prop) (q : Prop) : (∀ x : α, p x → q) ↔ ((∀ x : α, p x) → q) :=
-- by {
--   split,
--   {
--     intros h h',
--     have : (∀ x : α, p x → q) ↔ (∀ x : α, ∃ _ : p x, q) := by finish,
--     have : (∀ x : α, (∃ _ : p x, q) ↔ (p x → q)) := by finish,
--     dedup,
--     simp_rw this_1 at this,
--     have := forall_iff
--   }
-- }

-- example (α : Type) (β : α → Type) : subsingleton (Π a : α, β a) → (∀ a : α, subsingleton (β a)) :=
-- begin

--   intros h a,
--   apply subsingleton.intro,
--   intros x y,
--   have := @subsingleton.elim _ h,
--   by_cases h' : nonempty (Π x : α, β x),
--   {
--     rcases h' with ⟨f⟩,
--     have : x ≠ y → false :=
--     begin

--     end
--     -- by_contra,
--   }
--   -- by_contradiction,
-- end

-- section

--   -- mutual inductive even, odd
--   -- with even : ℕ → Prop
--   -- | even_zero : even 0
--   -- | even_succ : ∀ n, odd n → even (n + 1)
--   -- with odd : ℕ → Prop
--   -- | odd_succ : ∀n, even n → odd (n + 1)

--   -- #print even._mut_

-- inductive even_odd : bool → ℕ → Prop
-- | even_zero : even_odd tt 0
-- | even_succ : ∀ n, even_odd ff n → even_odd tt (n + 1)
-- | odd_succ  : ∀ n, even_odd tt n → even_odd ff (n + 1)

-- end

-- inductive bad : Π {α : Type}, α → Type 1
-- | app {α β : Type} {f : α → β} {x : α} : @bad (α → β) f → bad x → bad (f x)

-- /-
-- type mismatch at application
--   bad (α → β) f
-- term
--   f
-- has type
--   α_1 → β
-- but is expected to have type
--   α → β
-- types contain aliased name(s): α
-- remark: the tactic `dedup` can be used to rename aliases
-- -/

-- inductive ok : Π {α : Type}, α → Type 1
-- | app {α β : Type} {f : α → β} {x : α} : @ok (α → β) f → ok x → ok ((id f) x)

-- p = y₂ w₁ w₂
-- q = w₂₂ p₁
-- r = p₂ q₁ q₂

-- (A y₁ w₁).dia
--   p₁
--   (w₂₁ p₁ p₂)

-- (A r₁ (q₁ r₁)).dia
--   (q₂ r₁)
--   r₂


import data.list
import tactic.basic
import data.finset.basic
import data.real.basic
import tactic

open lean lean.parser tactic interactive interactive.types expr

-- specialize_all tactic, written and posted by Yakov Pechersky on Zulip

meta def tactic.specialize_single (n : name) (l : loc) : tactic unit := do
  val ← get_local n,
  valt ← infer_type val,
  hs ← l.get_locals,
  hs.mmap' (λ h, do
    ht ← infer_type h,
    try $ match ht with
      | (pi _ _ vt _) := do
        is_def_eq vt valt >> note (h.local_pp_name ++ n) none (h.mk_app [val]) >> pure ()
      | (lam _ _ vt _) := do
        is_def_eq vt valt >> note (h.local_pp_name ++ n) none (h.mk_app [val]) >> pure ()
      | _ := pure ()
    end)

meta def tactic.specialize_all (hs : list simp_arg_type) (l : loc) : tactic unit := do
  (lp, ln, ln', b) ← decode_simp_arg_list hs,
  lp.mmap' (λ e, do
    e ← to_expr e,
    if e.is_local_constant then tactic.specialize_single e.local_pp_name l
      else pure ()),
  if !b then pure () else (do
    ls ← tactic.local_context,
    ls.mmap' (λ e, do
      if expr.is_local_constant e then tactic.specialize_single e.local_pp_name l else pure ()),
    pure ())

namespace tactic.interactive

meta def specialize_all1 (val : parse ident) (loc : parse location) : tactic unit :=
tactic.specialize_single val loc

meta def specialize_all (vals : parse simp_arg_list) (loc : parse location) : tactic unit :=
tactic.specialize_all vals loc

end tactic.interactive

example {α β γ : Type*}
  (f : α → β)
  (g : α → β)
  (h : β → γ)
  (x y : α) (z : β) : γ := begin
    specialize_all [*] at *,
    extract_goal,
    exact h.z
  end

namespace tactic.interactive

  meta def ls := library_search
  meta def ss := squeeze_simp

end tactic.interactive

@[reducible]
def max3 (x y z : ℕ) : ℕ := list.foldr max 0 [x, y, z]

variables {x y z : ℕ}

lemma max3_le₁ : x ≤ max3 x y z := by simp [max3]

lemma max3_le₂ : y ≤ max3 x y z := by simp [max3]

lemma max3_le₃ : z ≤ max3 x y z := by simp [max3]

lemma mul_sides_left (a b c : ℝ) (h₁ : 0 ≤ a) (h₂ : 0 ≤ c) : a ≤ b → c * a ≤ c * b := by {
  intros h,
  apply mul_le_mul (le_of_eq rfl) h h₁ h₂,
}

open_locale big_operators
open finset (range)

lemma nonneg_sub_of_nonneg_sum {x : ℕ → ℝ} {n j : ℕ} (x_nonneg : ∀ i, 0 ≤ x i)
  : 0 ≤ (∑ i in finset.range (n + j), (x i)) - (∑ i in finset.range n, (x i)) :=
begin
  have h₁ : range n ≤ range (n + j) := finset.range_mono le_self_add,
  have : (∑ i in finset.range n, (x i)) ≤ (∑ i in finset.range (n + j), (x i)) := by {
    have := @finset.sum_mono_set_of_nonneg ℕ ℝ _ x x_nonneg,
    specialize this h₁,
    dsimp only at this,
    exact this,
  },
  exact sub_nonneg.mpr this,
end

lemma le_Ico_of_le_left {a b : ℕ} (c : ℕ) (h : a ≤ b) : finset.Ico b c ≤ finset.Ico a c :=
begin
  simp only [has_subset.subset, and_imp, finset.le_eq_subset, finset.Ico.mem],
  intros x h₁ h₂,
  exact and.intro (le_trans h h₁) h₂,
end

lemma some_ineq {a n : ℕ} (m : ℕ) (h : a ≤ n) : a.succ ≤ n + m + 1 := by {
  have h₁ : a + 1 ≤ n + 1 := add_le_add_right h 1,
  have h₂ : n + 1 ≤ n + m + 1 := by {
    rw [add_comm n m, add_assoc],
    exact le_add_self,
  },
  exact le_trans h₁ h₂,
}

lemma helper (a b c : ℝ) : a * b ≤ c → b ≤ (1 / a) * c := by {
  intros h,
}


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon

Traversable instance for buffers.
-/

import data.buffer data.array.lemmas
import category.traversable.instances data.equiv.basic
       tactic.ext

namespace buffer

open function

variables {α : Type*} {xs : list α}

@[extensionality]
lemma ext : ∀ {b₁ b₂ : buffer α}, to_list b₁ = to_list b₂ → b₁ = b₂
| ⟨n₁, a₁⟩ ⟨n₂, a₂⟩ h := begin
  simp [to_list, to_array] at h,
  have e : n₁ = n₂ :=
    by rw [←array.to_list_length a₁, ←array.to_list_length a₂, h],
  subst e,
  have h : a₁ == a₂.to_list.to_array := h ▸ a₁.to_list_to_array.symm,
  rw eq_of_heq (h.trans a₂.to_list_to_array)
end

instance (α) [decidable_eq α] : decidable_eq (buffer α) :=
by tactic.mk_dec_eq_instance

@[simp]
lemma to_list_append_list {b : buffer α} :
  to_list (append_list b xs) = to_list b ++ xs :=
by induction xs generalizing b; simp! [*]; cases b; simp! [to_list,to_array]

@[simp]
lemma append_list_mk_buffer  :
  append_list mk_buffer xs = array.to_buffer (list.to_array xs) :=
by ext x : 1; simp [array.to_buffer,to_list,to_list_append_list];
   induction xs; [refl,skip]; simp [to_array]; refl

def list_equiv_buffer (α : Type*) : list α ≃ buffer α :=
begin
  refine { to_fun := list.to_buffer, inv_fun := buffer.to_list, .. };
  simp [left_inverse,function.right_inverse],
  { intro x, induction x, refl,
    simp [list.to_buffer,append_list],
    rw ← x_ih, refl },
  { intro x, cases x,
    simp [to_list,to_array,list.to_buffer],
    congr, simp, refl, apply array.to_list_to_array }
end

instance : traversable buffer :=
equiv.traversable list_equiv_buffer

instance : is_lawful_traversable buffer :=
equiv.is_lawful_traversable list_equiv_buffer

end buffer


import ReactorModel.Determinism.ExecutionStep

open ReactorType Classical

variable [Indexable α]

namespace Execution

variable {s s₁ : State α} in section

abbrev State.Trivial (s : State α) : Prop :=
  s.rtr[.rcn] = ∅

theorem State.Trivial.of_not_Nontrivial (h : ¬Nontrivial s) : s.Trivial :=
  byContradiction (h ⟨·⟩)

variable (triv : s₁.Trivial) in section

namespace Instantaneous

theorem Step.not_Trivial (e : s₁ ⇓ᵢ s₂) : ¬s₁.Trivial := by
  by_contra ht
  simp [State.Trivial, Partial.empty_iff] at ht
  cases (Partial.mem_iff.mp e.allows_rcn.mem).choose_spec ▸ ht e.rcn

theorem Execution.trivial_eq : (s₁ ⇓ᵢ* s₂) → s₁ = s₂
  | refl      => rfl
  | trans e _ => absurd triv e.not_Trivial

theorem ClosedExecution.preserves_Trivial {e : s₁ ⇓| s₂} : s₂.Trivial := by
  simp [State.Trivial, ←Equivalent.obj?_rcn_eq e.equiv, triv]

theorem ClosedExecution.trivial_eq (e : s₁ ⇓| s₂) : s₁ = s₂ :=
  e.exec.trivial_eq triv

end Instantaneous

theorem State.Advance.preserves_Trivial : (Advance s₁ s₂) → s₂.Trivial
  | mk .. => triv

theorem AdvanceTag.preserves_Trivial (a : s₁ ⇓- s₂) : s₂.Trivial :=
  a.advance.preserves_Trivial triv

theorem Step.preserves_Trivial : (s₁ ⇓ s₂) → s₂.Trivial
  | close e   => e.preserves_Trivial triv
  | advance a => a.preserves_Trivial triv

end
end

namespace AdvanceTag

inductive RTC : State α → State α → Type
  | refl : RTC s s
  | trans : (s₁ ⇓- s₂) → (RTC s₂ s₃) → RTC s₁ s₃

theorem RTC.tag_le {s₁ s₂ : State α} : (AdvanceTag.RTC s₁ s₂) → s₁.tag ≤ s₂.tag
  | refl       => le_refl _
  | trans a a' => le_trans (le_of_lt a.tag_lt) a'.tag_le

theorem RTC.deterministic {s s₁ s₂ : State α} (ht : s₁.tag = s₂.tag) :
    (AdvanceTag.RTC s s₁) → (AdvanceTag.RTC s s₂) → s₁ = s₂
  | refl,         refl         => rfl
  | refl,         trans a a'   => absurd ht      (ne_of_lt $ lt_of_lt_of_le a.tag_lt a'.tag_le)
  | trans a a',   refl         => absurd ht.symm (ne_of_lt $ lt_of_lt_of_le a.tag_lt a'.tag_le)
  | trans a₁ a₁', trans a₂ a₂' => a₁'.deterministic ht (a₂.determinisic a₁ ▸ a₂')

end AdvanceTag

def to_AdvanceTagRTC {s₁ s₂ : State α} (triv : s₁.Trivial) : (s₁ ⇓* s₂) → AdvanceTag.RTC s₁ s₂
  | refl                 => .refl
  | step (.advance a) e' => .trans a (e'.to_AdvanceTagRTC $ a.preserves_Trivial triv)
  | step (.close e) e'   => e.trivial_eq triv ▸ (e'.to_AdvanceTagRTC $ e.preserves_Trivial triv)

theorem trivial_deterministic {s : State α}
    (triv : ¬s.Nontrivial) (e₁ : s ⇓* s₁) (e₂ : s ⇓* s₂) (ht : s₁.tag = s₂.tag) : s₁ = s₂ :=
  AdvanceTag.RTC.deterministic ht
    (e₁.to_AdvanceTagRTC $ .of_not_Nontrivial triv)
    (e₂.to_AdvanceTagRTC $ .of_not_Nontrivial triv)

end Execution


import ReactorModel.Execution

open Classical ReactorType

theorem ReactorType.Proper.rcn_state_deps_local [Proper α] {rtr : α}
    (hc₁ : rtr[.rtr][c₁] = some con₁) (hc₂ : rtr[.rtr][c₂] = some con₂)
    (hr₁ : rcns con₁ i₁ = some rcn₁) (hr₂ : rcns con₂ i₂ = some rcn₂)
    (hd₁ : ⟨.stv, j⟩ ∈ rcn₁.deps k₁) (hd₂ : ⟨.stv, j⟩ ∈ rcn₂.deps k₂) : c₁ = c₂ := by
  have hv₁ := wellformed rtr |>.valid_deps hc₁ hr₁ hd₁
  have hv₂ := wellformed rtr |>.valid_deps hc₂ hr₂ hd₂
  cases hk₁ : rcn₁.kind <;> cases hk₂ : rcn₂.kind <;> simp [hk₁, hk₂] at hv₁ hv₂
  all_goals
    cases hv₁; cases hv₂
    exact Indexable.mem_cpt?_rtr_eq hc₁ hc₂ (cpt := .stv) ‹_› ‹_›

-- This proposition states that `rcn₂` does not depend on `rcn₁`.
abbrev NotDependent [Indexable α] (rtr : α) (rcn₁ rcn₂ : ID) : Prop :=
  ¬(rcn₁ <[rtr] rcn₂)

notation:50 rcn₁ " ≮[" rtr "] " rcn₂ => NotDependent rtr rcn₁ rcn₂

theorem NotDependent.deps_disjoint [Indexable α] {rtr : α} {d} (hi : i₁ ≮[rtr] i₂)
    (h₁ : rtr[.rcn][i₁] = some rcn₁) (h₂ : rtr[.rcn][i₂] = some rcn₂) (h : d ∈ rcn₁.deps .out)
    (hs : d.cpt ≠ .stv) : d ∉ rcn₂.deps .in :=
  byContradiction fun hd => absurd (Dependency.depOverlap h₁ h₂ h (not_not.mp hd) hs) hi

structure Independent [Indexable α] (rtr : α) (rcn₁ rcn₂ : ID) : Prop where
  not_eq : rcn₁ ≠ rcn₂
  left   : rcn₁ ≮[rtr] rcn₂
  right  : rcn₂ ≮[rtr] rcn₁

namespace Independent

notation:50 rcn₁ " ≮[" rtr "]≯ " rcn₂ => Independent rtr rcn₁ rcn₂

theorem symm [Indexable α] {rtr : α} (hi : i₁ ≮[rtr]≯ i₂) : i₂ ≮[rtr]≯ i₁ where
  not_eq := hi.not_eq.symm
  left   := hi.right
  right  := hi.left

theorem ne_con_state_mem_rcn₁_deps_not_mem_rcn₂_deps [Proper α] {rtr : α}
    (hc : rtr[.rtr][c] = some con) (hr₁ : rcns con i₁ = some rcn₁) (hr₂ : rcns con i₂ = some rcn₂)
    (hd : ⟨.stv, j⟩ ∈ rcn₁.deps .out) (hi : i₁ ≮[rtr]≯ i₂) (hs : .stv j v ∈ rcn₁ i) :
    ⟨.stv, j⟩ ∉ rcn₂.deps k := by
  by_contra hd'
  have ⟨hn, _, _⟩ := hi
  -- TODO: https://leanprover.zulipchat.com/#narrow/stream/348111-std4/topic/by_cases.20tags.20bug/near/345415921
  by_cases hm₁ : rcn₁.Mutates <;> by_cases hm₂ : rcn₂.Mutates
  rotate_left
  case _ =>
    have := Dependency.mutNorm hc ‹_› ‹_› hm₁ (by simp_all [Reaction.Mutates])
    contradiction
  case _ =>
    have := Dependency.mutNorm hc ‹_› hr₁ hm₂ (by simp_all [Reaction.Mutates])
    contradiction
  all_goals
    cases Proper.wellformed rtr |>.hazards_prio hc hr₁ hr₂ hn hd hd' (.inl rfl)
    all_goals
      case _ hp =>
      have := Dependency.prio hc ‹_› ‹_› (by simp [*]) hp
      contradiction

open Indexable in
theorem state_mem_rcn₁_deps_not_mem_rcn₂_deps [Proper α] {rtr : α}
    (h₁ : rtr[.rcn][i₁] = some rcn₁) (h₂ : rtr[.rcn][i₂] = some rcn₂)
    (hi : i₁ ≮[rtr]≯ i₂) (hs : .stv j v ∈ rcn₁.body i) : ⟨.stv, j⟩ ∉ rcn₂.deps k := by
  have ⟨c₁, _, hc₁, hr₁⟩ := obj?_split h₁
  have ⟨c₂, _, hc₂, hr₂⟩ := obj?_split h₂
  have hd₁ := rcn₁.target_mem_deps hs
  simp [Change.Normal.target] at hd₁
  by_cases hc : c₁ = c₂
  case neg =>
    by_contra hd₂
    exact absurd (ReactorType.Proper.rcn_state_deps_local hc₁ hc₂ hr₁ hr₂ hd₁ hd₂) hc
  case pos =>
    injection hc₂ ▸ hc ▸ hc₁ with h
    exact ne_con_state_mem_rcn₁_deps_not_mem_rcn₂_deps hc₁ hr₁ (h ▸ hr₂) hd₁ hi hs

end Independent

-- Reaction `rcn` is maximal wrt. `rcns` if `rcn` does not depend on any reaction in `rcns`.
def Minimal [Indexable α] (rtr : α) (rcns : List ID) (rcn : ID) : Prop :=
  ∀ i ∈ rcns, i ≮[rtr] rcn

namespace Minimal

variable [Indexable α] {rtr rtr₁ rtr₂ : α}

notation:50 rcns " ≮[" rtr "] " rcn => Minimal rtr rcns rcn

theorem cons_head (m : (hd :: tl) ≮[rtr] rcn) : hd ≮[rtr] rcn :=
  m hd $ List.mem_cons_self _ _

theorem cons_tail (m : (hd :: tl) ≮[rtr] rcn) : tl ≮[rtr] rcn :=
  (m · $ List.mem_cons_of_mem _ ·)

theorem perm {rcns : List ID} (m : rcns ≮[rtr] rcn) (h : rcns ~ rcns') : rcns' ≮[rtr] rcn :=
  (m · $ h.mem_iff.mpr ·)

theorem equiv {rcns : List ID} (m : rcns ≮[rtr₁] rcn) (e : rtr₁ ≈ rtr₂) : rcns ≮[rtr₂] rcn :=
  fun i h d => absurd (ReactorType.Dependency.equiv e d) (m i h)

end Minimal


import for_mathlib.homotopy_category_pretriangulated
import for_mathlib.abelian_category
import for_mathlib.derived.homological
import for_mathlib.derived.bounded_homotopy_category
import category_theory.abelian.projective
import for_mathlib.snake_lemma3
import for_mathlib.les_homology
import for_mathlib.exact_seq3
import for_mathlib.triangle_shift
import for_mathlib.homology_iso
import for_mathlib.projective_replacement
import for_mathlib.derived.lemmas
-- import for_mathlib.arrow_preadditive

import hacks_and_tricks.asyncI

noncomputable theory

open category_theory category_theory.limits category_theory.triangulated
open homological_complex

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

namespace bounded_homotopy_category

local notation `𝒦` := bounded_homotopy_category A

section enough_projectives

abbreviation uniformly_bounded {α : Type*} (X : α → 𝒦) : Prop :=
homotopy_category.is_uniformly_bounded_above (val ∘ X)

variable [enough_projectives A]

-- Main theorem about existence of K-projective replacements.
-- Perhaps all we need is this for bounded complexes, in which case we should
-- add an additional typeclass parameter here.
theorem exists_K_projective_replacement (X : 𝒦) :
  ∃ (P : 𝒦) [homotopy_category.is_K_projective P.val] (f : P ⟶ X),
  homotopy_category.is_quasi_iso f ∧ ∀ k, projective (P.val.as.X k) :=
begin
  obtain ⟨P,h1,h2,f,h3⟩ :=
    homotopy_category.exists_K_projective_replacement_of_bounded X.val,
  resetI,

  exact ⟨⟨P⟩, h1, f, h3⟩,
end

theorem exists_uniform_K_projective_replacement {α : Type*} (X : α → 𝒦)
  [uniformly_bounded X] :
  ∃ (P : α → 𝒦)
  [∀ a, homotopy_category.is_K_projective (P a).val]
  [uniformly_bounded P]
  (f : Π a, P a ⟶ X a),
  (∀ a, homotopy_category.is_quasi_iso (f a)) ∧ ∀ a k, projective ((P a).val.as.X k) :=
begin
  obtain ⟨P,h1,h2,f,h3,h4⟩ := homotopy_category.exists_K_projective_replacement_of_uniformly_bounded_above
    (val ∘ X),
  resetI,
  exact ⟨λ a, ⟨P a⟩, infer_instance, infer_instance, f, h3, h4⟩,
end

open homotopy_category

def replace (X : 𝒦) : 𝒦 := (exists_K_projective_replacement X).some

instance (X : 𝒦) : is_K_projective X.replace.val :=
(exists_K_projective_replacement X).some_spec.some

def π (X : 𝒦) : X.replace ⟶ X :=
(exists_K_projective_replacement X).some_spec.some_spec.some

instance (X : 𝒦) : is_quasi_iso X.π :=
(exists_K_projective_replacement X).some_spec.some_spec.some_spec.1

instance (X : 𝒦) (k : ℤ) : projective (X.replace.val.as.X k) :=
(exists_K_projective_replacement X).some_spec.some_spec.some_spec.2 k

def replace_uniformly {α : Type v}
  (X : α → bounded_homotopy_category A)
  [uniformly_bounded X] : α → bounded_homotopy_category A :=
(exists_uniform_K_projective_replacement X).some

instance is_K_projective_replace_uniformly_apply {α : Type v}
  (X : α → bounded_homotopy_category A)
  [uniformly_bounded X] (a) : homotopy_category.is_K_projective (replace_uniformly X a).val :=
(exists_uniform_K_projective_replacement X).some_spec.some _

def π_uniformly {α : Type v}
  (X : α → bounded_homotopy_category A)
  [uniformly_bounded X] : Π a, replace_uniformly X a ⟶ X a :=
(exists_uniform_K_projective_replacement X).some_spec.some_spec.some_spec.some

instance is_quasi_iso_π_uniformly {α : Type v}
  (X : α → bounded_homotopy_category A)
  [uniformly_bounded X] (a) : homotopy_category.is_quasi_iso (π_uniformly X a) :=
(exists_uniform_K_projective_replacement X).some_spec.some_spec.some_spec.some_spec.1 _

instance uniform_bound_replace_uniformly {α : Type v}
  (X : α → bounded_homotopy_category A)
  [uniformly_bounded X] : uniformly_bounded (replace_uniformly X) :=
(exists_uniform_K_projective_replacement X).some_spec.some_spec.some

def lift {P X Y : 𝒦} [is_K_projective P.val] (f : P ⟶ Y) (g : X ⟶ Y) [is_quasi_iso g] :
  P ⟶ X :=
((hom_K_projective_bijective P.val g).2 f).some

@[simp, reassoc]
lemma lift_lifts {P X Y : 𝒦} [is_K_projective P.val] (f : P ⟶ Y) (g : X ⟶ Y) [is_quasi_iso g] :
  lift f g ≫ g = f :=
((hom_K_projective_bijective P.val g).2 f).some_spec

lemma lift_unique {P X Y : 𝒦} [is_K_projective P.val] (f : P ⟶ Y) (g : X ⟶ Y) [is_quasi_iso g]
  (e : P ⟶ X) (h : e ≫ g = f) : e = lift f g :=
begin
  apply (hom_K_projective_bijective P.val g).1,
  dsimp,
  erw lift_lifts,
  assumption
end

@[simp]
lemma lift_self {P X : 𝒦} [is_K_projective P.val] (g : P ⟶ X) [is_quasi_iso g] :
  lift g g = 𝟙 _ :=
(lift_unique _ _ _ (by simp)).symm

@[simp]
lemma lift_comp {P X Y : 𝒦} [is_K_projective P.val] (f : P ⟶ X) (g : X ⟶ Y) [is_quasi_iso g] :
  lift (f ≫ g) g = f :=
(lift_unique _ _ _ (by simp)).symm

@[simp, reassoc]
lemma lift_comp_lift_self {P X Y Z : 𝒦} [is_K_projective P.val] [is_K_projective X.val]
  (f : P ⟶ Y) (g : X ⟶ Y) [is_quasi_iso g] (k : Z ⟶ Y) [is_quasi_iso k] :
  lift f g ≫ lift g k = lift f k :=
lift_unique _ _ _ (by simp)

@[simp, reassoc]
lemma lift_comp_lift_comp {P W X Y Z : 𝒦} [is_K_projective P.val] [is_K_projective X.val]
  (f : P ⟶ Y) (g : X ⟶ Y) [is_quasi_iso g] (h : Y ⟶ Z) (k : W ⟶ Z) [is_quasi_iso k] :
  lift f g ≫ lift (g ≫ h) k = lift (f ≫ h) k :=
lift_unique _ _ _ (by simp)

@[simp] lemma lift_neg {P X Y : 𝒦} [is_K_projective P.val] (f : P ⟶ Y) (g : X ⟶ Y) [is_quasi_iso g] :
  lift (-f) g = -(lift f g) :=
(lift_unique _ _ _ (by simp)).symm

lemma lift_add {P X Y : 𝒦} [is_K_projective P.val] (f₁ f₂ : P ⟶ Y) (g : X ⟶ Y) [is_quasi_iso g] :
  lift (f₁ + f₂) g = lift f₁ g + lift f₂ g :=
(lift_unique _ _ _ (by simp)).symm

instance is_K_projective_shift (X : 𝒦) [is_K_projective X.val] (m : ℤ) :
  is_K_projective ((category_theory.shift_functor 𝒦 m).obj X).val :=
by exact homotopy_category.is_K_projective_shift X.val m -- strange?

instance {X Y : 𝒦} (g : X ⟶ Y) [is_quasi_iso g] (m : ℤ) :
  is_quasi_iso ((category_theory.shift_functor 𝒦 m).map g) :=
homotopy_category.is_quasi_iso_shift _ _ _ _

lemma shift_functor_map_lift
  {P X Y : 𝒦} [is_K_projective P.val] (f : P ⟶ Y) (g : X ⟶ Y) [is_quasi_iso g] (m : ℤ) :
  (category_theory.shift_functor 𝒦 m).map (lift f g) =
    lift ((category_theory.shift_functor 𝒦 m).map f) ((category_theory.shift_functor 𝒦 m).map g) :=
begin
  apply lift_unique,
  simp only [←category_theory.functor.map_comp, lift_lifts],
end

lemma lift_ext {P X Y : 𝒦} [is_K_projective P.val] (g : X ⟶ Y) [is_quasi_iso g]
  (a b : P ⟶ X) (h : a ≫ g = b ≫ g) : a = b :=
(hom_K_projective_bijective P.val g).1 h

@[simps]
def replace_triangle (T : triangle 𝒦) : triangle 𝒦 :=
{ obj₁ := T.obj₁.replace,
  obj₂ := T.obj₂.replace,
  obj₃ := T.obj₃.replace,
  mor₁ := lift (T.obj₁.π ≫ T.mor₁) T.obj₂.π,
  mor₂ := lift (T.obj₂.π ≫ T.mor₂) T.obj₃.π,
  mor₃ := begin
    have h : is_quasi_iso (T.obj₁.π⟦(1 : ℤ)⟧') := infer_instance,
    exact @lift _ _ _ _ _ _ _ _ (T.obj₃.π ≫ T.mor₃) (T.obj₁.π⟦(1 : ℤ)⟧') h, -- What?
  end }

lemma distinguished_replace_triangle (T : triangle 𝒦) (hT : T ∈ dist_triang 𝒦) :
  replace_triangle T ∈ dist_triang 𝒦 :=
begin
  let S := replace_triangle T,
  change S ∈ _,
  obtain ⟨Z,g,h,hW⟩ := pretriangulated.distinguished_cocone_triangle _ _ S.mor₁,
  let W := triangle.mk (bounded_homotopy_category A) S.mor₁ g h,
  change W ∈ _ at hW,
  have hWT : W.mor₁ ≫ T.obj₂.π = T.obj₁.π ≫ T.mor₁ := _,
  obtain ⟨q,sq2,sq3⟩ := pretriangulated.complete_distinguished_triangle_morphism _ _ hW hT
    T.obj₁.π T.obj₂.π hWT,
  let r : W ⟶ T := ⟨T.obj₁.π, T.obj₂.π, q, hWT, sq2, sq3⟩,
  let W' := (triangle.mk (homotopy_category _ _) W.mor₁ W.mor₂ W.mor₃),
  let T' := (triangle.mk (homotopy_category _ _) T.mor₁ T.mor₂ T.mor₃),
  let r' : W' ⟶ T' := ⟨T.obj₁.π, T.obj₂.π, q, hWT, sq2, sq3⟩,
  haveI : is_quasi_iso r.hom₃, { exact is_quasi_iso_of_triangle W' T' hW hT r' },
  haveI : is_K_projective W.obj₃.val,
  by asyncI
  { haveI : is_K_projective W'.obj₁ := show is_K_projective T.obj₁.replace.val, by apply_instance,
    haveI : is_K_projective W'.obj₂ := show is_K_projective T.obj₂.replace.val, by apply_instance,
    exact homotopy_category.is_K_projective_of_triangle W' hW },
  haveI : is_K_projective S.obj₁.val := show is_K_projective T.obj₁.replace.val, by apply_instance,
  haveI : is_K_projective S.obj₂.val := show is_K_projective T.obj₂.replace.val, by apply_instance,
  haveI : is_K_projective S.obj₃.val := show is_K_projective T.obj₃.replace.val, by apply_instance,
  apply mem_distinguished_of_iso _ hW,
  refine ⟨⟨𝟙 _,𝟙 _, lift q T.obj₃.π, _, _, _⟩,⟨𝟙 _,𝟙 _, lift T.obj₃.π q, _,_,_⟩,_,_⟩,
  asyncI
  { dsimp, rw [category.comp_id, category.id_comp], },
  asyncI
  { dsimp [S, replace_triangle],
    rw category.id_comp,
    apply lift_unique,
    erw [category.assoc, lift_lifts], exact sq2, },
  asyncI
  { dsimp [S, replace_triangle],
    rw [category_theory.functor.map_id, category.comp_id],
    haveI : is_quasi_iso
      ((category_theory.shift_functor (bounded_homotopy_category A) (1 : ℤ)).map T.obj₁.π),
    { show is_quasi_iso (T.obj₁.π⟦(1 : ℤ)⟧'), apply_instance }, -- strange.
    apply lift_ext (T.obj₁.π⟦(1 : ℤ)⟧'),
    erw [category.assoc, lift_lifts, lift_lifts_assoc],
    exact sq3,
    assumption },
  asyncI
  { dsimp, rw [category.id_comp, category.comp_id] },
  asyncI
  { dsimp [S, replace_triangle],
    rw category.id_comp,
    apply lift_ext q,
    erw [category.assoc, lift_lifts, lift_lifts, sq2],
    assumption },
  asyncI
  { dsimp [S, replace_triangle],
    rw [category_theory.functor.map_id, category.comp_id],
    haveI : is_quasi_iso
      ((category_theory.shift_functor (bounded_homotopy_category A) (1 : ℤ)).map T.obj₁.π),
    { show is_quasi_iso (T.obj₁.π⟦(1 : ℤ)⟧'), apply_instance }, -- strange.
    apply lift_ext (T.obj₁.π⟦(1 : ℤ)⟧'),
    erw [category.assoc, lift_lifts, sq3, lift_lifts_assoc],
    assumption },
  asyncI
  { ext; dsimp, rw category.id_comp, rw category.id_comp,
    apply lift_ext q, erw [category.assoc, lift_lifts, lift_lifts, category.id_comp],
    assumption },
  asyncI
  { ext; dsimp, rw category.id_comp, rw category.id_comp,
    apply lift_ext T.obj₃.π, erw [category.assoc, lift_lifts, lift_lifts, category.id_comp],
    assumption },
  asyncI
  { dsimp [W, S, replace_triangle],
    rw lift_lifts },
end

@[simps]
def Ext0 : 𝒦ᵒᵖ ⥤ 𝒦 ⥤ Ab :=
{ obj := λ X, preadditive_yoneda.flip.obj (opposite.op $ X.unop.replace),
  map := λ X₁ X₂ f, preadditive_yoneda.flip.map (lift (X₂.unop.π ≫ f.unop) X₁.unop.π).op,
  map_id' := by asyncI {
    intros X,
    ext Y e,
    dsimp [preadditive_yoneda, preadditive_yoneda_obj],
    change _ ≫ e = e,
    simp only [category.comp_id, id_apply],
    convert category.id_comp _,
    symmetry,
    apply lift_unique,
    simp, },
  map_comp' := by asyncI {
    intros X₁ X₂ X₃ f g,
    ext Y e,
    dsimp,
    simp only [comp_apply, linear_map.to_add_monoid_hom_coe,
      preadditive_yoneda_obj_map_apply, quiver.hom.unop_op],
    change _ ≫ e = _ ≫ _ ≫ e,
    conv_rhs { rw ← category.assoc },
    congr' 1,
    symmetry,
    apply lift_unique,
    simp } }
.

def Ext (i : ℤ) : 𝒦ᵒᵖ ⥤ 𝒦 ⥤ Ab :=
Ext0 ⋙ (whiskering_left _ _ _).obj (shift_functor _ i)

-- why is this so slow?
-- DT: squeezing the simps made it very fast!
@[simps]
def replacement_iso (P₁ P₂ X : 𝒦) [is_K_projective P₁.val] [is_K_projective P₂.val]
  (f₁ : P₁ ⟶ X) (f₂ : P₂ ⟶ X) [is_quasi_iso f₁] [is_quasi_iso f₂] : P₁ ≅ P₂ :=
{ hom         := lift f₁ f₂,
  inv         := lift f₂ f₁,
  hom_inv_id' := by asyncI {
    have : 𝟙 P₁ = lift f₁ f₁,
    { apply lift_unique, simp only [category.id_comp] },
    rw this,
    apply lift_unique,
    simp only [category.assoc, lift_lifts], },
  inv_hom_id' := by asyncI {
    have : 𝟙 P₂ = lift f₂ f₂,
    { apply lift_unique, simp only [category.id_comp] },
      rw this,
    apply lift_unique,
    simp only [category.assoc, lift_lifts], } }
.

@[simps]
def Ext_iso
  (i : ℤ) (P X Y : 𝒦) [is_K_projective P.val]
  (f : P ⟶ X) [is_quasi_iso f] :
  ((Ext i).obj (opposite.op X)).obj Y ≅ AddCommGroup.of (P ⟶ Y⟦i⟧) :=
(preadditive_yoneda.obj (Y⟦i⟧)).map_iso (replacement_iso P X.replace X f X.π).op

instance ext_additive (i : ℤ) (X : 𝒦) : functor.additive ((Ext i).obj (opposite.op X)) :=
begin
  refine ⟨_⟩,
  intros X Y f g,
  ext h,
  dsimp [Ext, preadditive_yoneda],
  rw [(category_theory.shift_functor 𝒦 i).map_add, preadditive.comp_add],
end

instance ext_additive' (i : ℤ) (X : 𝒦) : functor.additive ((Ext i).flip.obj X).right_op :=
begin
  refine ⟨_⟩,
  intros X Y f g,
  dsimp [Ext, preadditive_yoneda],
  rw ← op_add,
  congr' 1,
  ext h,
  dsimp,
  rw ← preadditive.add_comp,
  congr' 1,
  symmetry,
  apply lift_unique,
  simp only [preadditive.add_comp, lift_lifts, preadditive.comp_add],
end .

def _root_.category_theory.adjunction.yoneda_whiskering_left
  {C D : Type*} [category C] [category D] {F : C ⥤ D}
  {G : D ⥤ C} (adj : F ⊣ G) :
  yoneda ⋙ ((whiskering_left _ _ _).obj F.op) ≅ G ⋙ yoneda :=
begin
  fapply nat_iso.of_components,
  { intro Y,
    fapply nat_iso.of_components,
    { intro X, exact (adj.hom_equiv (opposite.unop X) Y).to_iso },
    { intros X₁ X₂ f, ext g, exact adj.hom_equiv_naturality_left f.unop g } },
  { intros Y₁ Y₂ f, ext X g, exact adj.hom_equiv_naturality_right g f }
end

def _root_.category_theory.adjunction.preadditive_yoneda_whiskering_left
  {C D : Type*} [category C] [category D] [preadditive C] [preadditive D] {F : C ⥤ D}
  {G : D ⥤ C} (adj : F ⊣ G) [functor.additive G] :
  preadditive_yoneda ⋙ ((whiskering_left _ _ _).obj F.op) ≅ G ⋙ preadditive_yoneda :=
begin
  fapply nat_iso.of_components,
  { intro Y,
    fapply nat_iso.of_components,
    { intro X,
      refine add_equiv_iso_AddCommGroup_iso.hom
        { map_add' := _, ..(adj.hom_equiv (opposite.unop X) Y) },
      intros f g, simp },
    { intros X₁ X₂ f, ext g, exact adj.hom_equiv_naturality_left f.unop g } },
  { intros Y₁ Y₂ f, ext X g, exact adj.hom_equiv_naturality_right g f }
end
.

end enough_projectives

instance shift_equiv_symm_inverse_additive (i : ℤ) :
  (shift_equiv (bounded_homotopy_category A) i).symm.inverse.additive :=
show (category_theory.shift_functor (bounded_homotopy_category A) (i)).additive, by apply_instance

instance shift_equiv_inverse_additive (i : ℤ) :
  (shift_equiv (bounded_homotopy_category A) i).inverse.additive :=
show (category_theory.shift_functor (bounded_homotopy_category A) (-i)).additive, by apply_instance

def hom_shift_right_iso (X : 𝒦) (i : ℤ) :
  category_theory.shift_functor 𝒦 i ⋙ preadditive_yoneda.flip.obj (opposite.op X) ≅
  preadditive_yoneda.flip.obj (opposite.op (X⟦-i⟧)) :=
begin
  have := (iso_whisker_right ((shift_equiv (bounded_homotopy_category A) i).symm
  .to_adjunction).preadditive_yoneda_whiskering_left.symm
    ((evaluation _ _).obj $ opposite.op X) : _),
  exact this,
end

def hom_shift_left_iso (X : 𝒦) (i : ℤ) :
  (category_theory.shift_functor 𝒦 i).op ⋙ preadditive_yoneda.obj X ≅
  preadditive_yoneda.obj (X⟦-i⟧) :=
begin
  have := (shift_equiv (bounded_homotopy_category A) i)
  .to_adjunction.preadditive_yoneda_whiskering_left.app X,
  exact this,
end

-- The LES for Ext in the second variable.
instance (i : ℤ) (X : 𝒦) [enough_projectives A] : homological_functor ((Ext i).obj (opposite.op X)) :=
begin
  show homological_functor (category_theory.shift_functor 𝒦 i ⋙ preadditive_yoneda.flip.obj _),
  let E := hom_shift_right_iso X.replace i,
  exact homological_of_nat_iso _ _ E.symm,
end

-- The LES for Ext in the first variable.
-- We need K-projective replacements of triangles for this.
instance (i : ℤ) (X : 𝒦) [enough_projectives A] : homological_functor ((Ext i).flip.obj X).right_op :=
begin
  constructor,
  intros T hT,
  have := homological_functor.cond
    (preadditive_yoneda.obj (X⟦i⟧)).right_op
    (replace_triangle T)
    (distinguished_replace_triangle _ hT),
  exact this,
end

instance lift_is_iso
  [enough_projectives A] (X Y X' Y' : 𝒦)
  (f : X ⟶ Y) (πX : X' ⟶ X) (πY : Y' ⟶ Y)
  [homotopy_category.is_quasi_iso f]
  [homotopy_category.is_quasi_iso πX]
  [homotopy_category.is_quasi_iso πY]
  [homotopy_category.is_K_projective X'.val]
  [homotopy_category.is_K_projective Y'.val] :
  is_iso (lift (πX ≫ f) πY) :=
begin
  use lift πY (πX ≫ f),
  split,
  { apply lift_ext (πX ≫ f), simp, apply_instance },
  { apply lift_ext πY, simp, apply_instance }
end

@[simp]
lemma inv_lift
  [enough_projectives A] (X Y X' Y' : 𝒦)
  (f : X ⟶ Y) (πX : X' ⟶ X) (πY : Y' ⟶ Y)
  [homotopy_category.is_quasi_iso f]
  [homotopy_category.is_quasi_iso πX]
  [homotopy_category.is_quasi_iso πY]
  [homotopy_category.is_K_projective X'.val]
  [homotopy_category.is_K_projective Y'.val] :
  inv (lift (πX ≫ f) πY) = lift πY (πX ≫ f) :=
begin
  apply lift_unique, rw is_iso.inv_comp_eq, simp,
end

instance is_iso_Ext_flip_obj_map_of_is_quasi_iso [enough_projectives A] (i : ℤ)
  (X X' Y : 𝒦)
  (f : X ⟶ X') [homotopy_category.is_quasi_iso f] :
  is_iso (((Ext i).flip.obj Y).map f.op) :=
begin
  let e := (preadditive_yoneda.obj (Y⟦i⟧)).map (lift (X.π ≫ f) X'.π).op,
  change is_iso e,
  apply functor.map_is_iso,
end

end bounded_homotopy_category

variable [enough_projectives A]

def Ext' (i : ℤ) : Aᵒᵖ ⥤ A ⥤ Ab :=
(bounded_homotopy_category.single A 0).op ⋙
  (bounded_homotopy_category.single A 0 ⋙ (bounded_homotopy_category.Ext i).flip).flip