Set Warnings "-cannot-remove-as-expected".

Require Import
  Lib
  Ty
  Exp
  Value
  Ren
  Sub
  Sem
  Log.

From Equations Require Import Equations.
Set Equations With UIP.

Generalizable All Variables.

(** Evaluation contexts *)

Section Step.

Import ListNotations.

Context {A : Type}.
Context `{HostExprs A}.

Open Scope Ty_scope.

(*

(* A context defines a hole which, after substitution, yields an expression of
   the index type. *)
Inductive Frame Γ : Ty → Ty → Type :=
  (* | C_If1 {τ} : Frame Γ τ' TyBool → Exp Γ τ → Exp Γ τ → Frame Γ τ' TyBool *)
  (* | C_If2 {τ} : Exp Γ TyBool → Frame Γ τ → Exp Γ τ → Frame Γ τ *)
  (* | C_If3 {τ} : Exp Γ TyBool → Exp Γ τ → Frame Γ τ → Frame Γ τ *)

  | F_AppL {dom cod} : Exp Γ dom → Frame Γ (dom ⟶ cod) cod
  | F_AppR {dom cod} : Exp Γ (dom ⟶ cod) → Frame Γ dom cod.

Derive Signature NoConfusion NoConfusionHom Subterm EqDec for Frame.

Inductive Ctxt Γ : Ty → Ty → Type :=
  | C_Nil {τ}         : Ctxt Γ τ τ
  | C_Cons {τ τ' τ''} : Frame Γ τ' τ → Ctxt Γ τ'' τ' → Ctxt Γ τ'' τ.

Derive Signature NoConfusion NoConfusionHom Subterm EqDec for Ctxt.

(* [Ctxt] forms a category with objects = types and morphisms = contexts. *)

Definition Ctxt_id {Γ τ} : Ctxt Γ τ τ := C_Nil _.
Arguments Ctxt_id {_ _} /.

Program Fixpoint Ctxt_comp {Γ τ τ' τ''}
        (C : Ctxt Γ τ' τ) (C' : Ctxt Γ τ'' τ') : Ctxt Γ τ'' τ :=
  match C with
  | C_Nil _      => C'
  | C_Cons _ f c => C_Cons _ f (Ctxt_comp c C')
  end.

Theorem Ctxt_id_left {Γ τ τ'} {C : Ctxt Γ τ' τ} :
  Ctxt_comp Ctxt_id C = C.
Proof. induction C; simpl; auto; now f_equal. Qed.

Theorem Ctxt_id_right {Γ τ τ'} {C : Ctxt Γ τ' τ} :
  Ctxt_comp C Ctxt_id = C.
Proof. induction C; simpl; auto; now f_equal. Qed.

Theorem Ctxt_comp_assoc {Γ τ τ' τ'' τ'''}
        {C : Ctxt Γ τ' τ} {C' : Ctxt Γ τ'' τ'} {C'' : Ctxt Γ τ''' τ''} :
  Ctxt_comp C (Ctxt_comp C' C'') = Ctxt_comp (Ctxt_comp C C') C''.
Proof. induction C; simpl; auto; now f_equal. Qed.

Inductive Redex {Γ} : ∀ {τ}, Exp Γ τ → Exp Γ τ → Prop :=
  | R_Beta {dom cod} (e : Exp (dom :: Γ) cod) v :
    ValueP v →
    Redex (APP (LAM e) v) (SubExp {|| v ||} e).

Derive Signature for Redex.

Unset Elimination Schemes.

Inductive Plug {Γ τ'} (e : Exp Γ τ') : ∀ {τ}, Ctxt Γ τ' τ → Exp Γ τ → Prop :=
  | Plug_Hole : Plug e (C_Nil _) e

  (* | Plug_If1 {Γ τ} (C : Ctxt Γ TyBool) (e e' : Exp Γ TyBool) (e1 e2 : Exp Γ τ) : *)
  (*   Plug C e e' → Plug (C_If1 _ C e1 e2) e (If e' e1 e2) *)
  (* | Plug_If2 {Γ τ} (C : Ctxt Γ τ) (e e' : Exp Γ τ) e1 (e2 : Exp Γ τ) : *)
  (*   Plug C e e' → Plug (C_If2 _ e1 C e2) e (If e1 e' e2) *)
  (* | Plug_If3 {Γ τ} (C : Ctxt Γ τ) (e e' : Exp Γ τ) e1 (e2 : Exp Γ τ) : *)
  (*   Plug C e e' → Plug (C_If3 _ e1 e2 C) e (If e1 e2 e') *)

  | Plug_AppL {dom cod} {C : Ctxt Γ τ' (dom ⟶ cod)}
              {e' : Exp Γ (dom ⟶ cod)} {e2 : Exp Γ dom} :
    Plug e C e' →
    Plug e (C_Cons _ (F_AppL _ e2) C) (APP e' e2)

  | Plug_AppR {dom cod} {C : Ctxt Γ τ' dom}
              {e' : Exp Γ dom} {e1 : Exp Γ (dom ⟶ cod)} :
    ValueP e1 →
    Plug e C e' →
    Plug e (C_Cons _ (F_AppR _ e1) C) (APP e1 e').

Derive Signature for Plug.

Set Elimination Schemes.

Scheme Plug_ind := Induction for Plug Sort Prop.

(* [Plug] forms a category with objects = expressions and morphisms = plugs
   over existential contexts. *)

Definition Plug_id {Γ τ} {x : Exp Γ τ} : Plug x (C_Nil Γ) x := Plug_Hole _.
Arguments Plug_id {_ _ _} /.

Fixpoint Plug_comp {Γ τ τ' τ''}
         {x : Exp Γ τ''} {y : Exp Γ τ'} {z : Exp Γ τ}
         {C : Ctxt Γ τ' τ} {C' : Ctxt Γ τ'' τ'}
         (P : Plug x C' y) (P' : Plug y C z) :
  Plug x (Ctxt_comp C C') z :=
  match P' with
  | Plug_Hole _      => P
  | Plug_AppL _ p'   => Plug_AppL _ (Plug_comp P p')
  | Plug_AppR _ V p' => Plug_AppR _ V (Plug_comp P p')
  end.

(* This should be provable, but the dependent types get in the way. *)
Theorem Plug_id_left {Γ τ τ'} {C : Ctxt Γ τ' τ} {x : Exp Γ τ'} {y : Exp Γ τ}
        (P : Plug x C y) :
  Plug_comp Plug_id P ~= P.
Proof.
  dependent induction P; simpl in *; auto.
Abort.
(*
  - rewrite (Plug_comp_equation_3 _ _ _ _ _ _ _ _ _ _ _ Plug_id _ P).
    pose proof (@Ctxt_id_right _ _ _ C).
    simpl in *.
    Fail now rewrite IHP.
*)

Reserved Notation " t '--->' t' " (at level 40).

Inductive Step {Γ τ} : Exp Γ τ → Exp Γ τ → Prop :=
  | StepRule {τ'} {C : Ctxt Γ τ' τ} {e1 e2 : Exp Γ τ'} {e1' e2' : Exp Γ τ} :
    Plug e1 C e1' →
    Plug e2 C e2' →
    Redex e1 e2 →
    e1' ---> e2'

  | StepError {τ' τ''} {F : Frame Γ τ' τ} {C : Ctxt Γ τ'' τ'}
              {m : Err} {e' : Exp Γ τ} :
    Plug (Error m) (C_Cons _ F C) e' →
    e' ---> Error m

  where " t '--->' t' " := (Step t t').

Derive Signature for Step.

#[local] Hint Constructors ValueP ErrorP Plug Redex Step : core.

*)

Reserved Notation " t '--->' t' " (at level 40).

Inductive Step : ∀ {Γ τ}, Exp Γ τ → Exp Γ τ → Prop :=
(*
  | ST_Seq1 Γ τ τ' (e1 e1' : Exp Γ τ') (e2 : Exp Γ τ) :
    e1 ---> e1' →
    Seq e1 e2 ---> Seq e1' e2
  | ST_Seq1Err Γ τ τ' (m : Err) (e2 : Exp Γ τ) :
    Seq (τ':=τ') (Error m) e2 ---> Error m
  | ST_Seq2 Γ τ τ' (e1 : Exp Γ τ') (e2 : Exp Γ τ) :
    ValueP e1 →
    Seq e1 e2 ---> e2

  | ST_Host Γ τ (h : HostExp τ) :
    HostedExp h ---> projT1 (Reduce (Γ:=Γ) h)

  | ST_IfTrue Γ τ (t e : Exp Γ τ) :
    If ETrue t e ---> t
  | ST_IfFalse Γ τ (t e : Exp Γ τ) :
    If EFalse t e ---> e
  | ST_If Γ b b' τ (t e : Exp Γ τ) :
    b ---> b' →
    If b t e ---> If b' t e
  | ST_IfErr Γ τ (m : Err) (t e : Exp Γ τ) :
    If (Error m) t e ---> Error m

  | ST_Pair1 Γ τ1 τ2 (x x' : Exp Γ τ1) (y : Exp Γ τ2) :
    x ---> x' →
    Pair x y ---> Pair x' y
  | ST_Pair2 Γ τ1 τ2 (x : Exp Γ τ1) (y y' : Exp Γ τ2) :
    ValueP x →
    y ---> y' →
    Pair x y ---> Pair x y'
  | ST_Pair1Err Γ τ1 τ2 (m : Err) (y : Exp Γ τ2) :
    Pair (τ1:=τ1) (Error m) y ---> Error m
  | ST_Pair2Err Γ τ1 τ2 (x : Exp Γ τ1) (m : Err) :
    ValueP x →
    Pair (τ2:=τ2) x (Error m) ---> Error m

  | ST_Fst1 Γ τ1 τ2 (p p' : Exp Γ (TyPair τ1 τ2)) :
    p ---> p' →
    Fst p ---> Fst p'
  | ST_Fst1Err Γ τ1 τ2 (m : Err) :
    Fst (Γ:=Γ) (τ1:=τ1) (τ2:=τ2) (Error m) ---> Error m
  | ST_FstPair Γ τ1 τ2 (v1 : Exp Γ τ1) (v2 : Exp Γ τ2) :
    ValueP v1 →
    ValueP v2 →
    Fst (Pair v1 v2) ---> v1

  | ST_Snd1 Γ τ1 τ2 (p p' : Exp Γ (TyPair τ1 τ2)) :
    p ---> p' →
    Snd p ---> Snd p'
  | ST_Snd1Err Γ τ1 τ2 (m : Err) :
    Snd (Γ:=Γ) (τ1:=τ1) (τ2:=τ2) (Error m) ---> Error m
  | ST_SndPair Γ τ1 τ2 (v1 : Exp Γ τ1) (v2 : Exp Γ τ2) :
    ValueP v1 →
    ValueP v2 →
    Snd (Pair v1 v2) ---> v2

  | ST_Cons1 Γ τ (x : Exp Γ τ) x' (xs : Exp Γ (TyList τ)) :
    x ---> x' →
    Cons x xs ---> Cons x' xs
  | ST_Cons2 Γ τ (x : Exp Γ τ) (xs : Exp Γ (TyList τ)) xs' :
    ValueP x →
    xs ---> xs' →
    Cons x xs ---> Cons x xs'
  | ST_Cons1Err Γ τ (m : Err) (xs : Exp Γ (TyList τ)) :
    Cons (Error m) xs ---> Error m
  | ST_Cons2Err Γ τ (x : Exp Γ τ) (m : Err) :
    ValueP x →
    Cons x (Error m) ---> Error m

  | ST_Car1 Γ τ (l l' : Exp Γ (TyList τ)) :
    l ---> l' →
    Car l ---> Car l'
  | ST_Car1Err Γ τ (m : Err) :
    Car (Γ:=Γ) (τ:=τ) (Error m) ---> Error m
  | ST_CarNil Γ τ :
    Car (Nil (Γ:=Γ) (τ:=τ)) ---> Error CarOfNil
  | ST_CarCons Γ τ (x : Exp Γ τ) (xs : Exp Γ (TyList τ)) :
    ValueP x →
    ValueP xs →
    Car (Cons x xs) ---> x

  | ST_Cdr1 Γ τ (l l' : Exp Γ (TyList τ)) :
    l ---> l' →
    Cdr l ---> Cdr l'
  | ST_Cdr1Err Γ τ (m : Err) :
    Cdr (Γ:=Γ) (τ:=τ) (Error m) ---> Error m
  | ST_CdrNil Γ τ :
    Cdr (Nil (Γ:=Γ) (τ:=τ)) ---> Nil
  | ST_CdrCons Γ τ (x : Exp Γ τ) (xs : Exp Γ (TyList τ)) :
    ValueP x →
    ValueP xs →
    Cdr (Cons x xs) ---> xs

  | ST_IsNil1 Γ τ (l l' : Exp Γ (TyList τ)) :
    l ---> l' →
    IsNil l ---> IsNil l'
  | ST_IsNil1Err Γ τ (m : Err) :
    IsNil (Γ:=Γ) (τ:=τ) (Error m) ---> Error m
  | ST_IsNilNil Γ τ :
    IsNil (Nil (Γ:=Γ) (τ:=τ)) ---> ETrue
  | ST_IsNilCons Γ τ (x : Exp Γ τ) (xs : Exp Γ (TyList τ)) :
    ValueP x →
    ValueP xs →
    IsNil (Cons x xs) ---> EFalse

  | ST_AppHost Γ dom cod (f : HostExp (dom ⟶ cod)) (v : Exp Γ dom) :
    ∀ H : ValueP v,
    APP (HostedFun f) v ---> CallHost f v H
*)

  | ST_AppAbs Γ dom cod (e : Exp (dom :: Γ) cod) (v : Exp Γ dom) :
    ValueP v →
    APP (LAM e) v ---> SubExp {|| v ||} e

  | ST_AppL Γ dom cod (e1 : Exp Γ (dom ⟶ cod)) e1' (e2 : Exp Γ dom) :
    e1 ---> e1' →
    APP e1 e2 ---> APP e1' e2
  | ST_AppLErr Γ dom cod (m : Err) (e2 : Exp Γ dom) :
    APP (dom:=dom) (cod:=cod) (Error m) e2 ---> Error m

  | ST_AppR Γ dom cod (v1 : Exp Γ (dom ⟶ cod)) (e2 : Exp Γ dom) e2' :
    ValueP v1 →
    e2 ---> e2' →
    APP v1 e2 ---> APP v1 e2'
  | ST_AppRErr Γ dom cod (v1 : Exp Γ (dom ⟶ cod)) (m : Err) :
    ValueP v1 →
    APP v1 (Error m) ---> Error m

  where " t '--->' t' " := (Step t t').

Derive Signature for Step.

#[local] Hint Constructors ValueP ErrorP Step : core.

#[local] Hint Extern 1 (¬ ErrorP _) => inversion 1 : core.
#[local] Hint Extern 7 (_ ---> _) => repeat econstructor : core.

Theorem strong_progress {τ} (e : Exp [] τ) :
  ValueP e ∨ ErrorP e ∨ ∃ e', e ---> e'.
Proof.
  dependent induction e; reduce.
  - now right; left; eexists.
  - now left; constructor.
  - now inv v.
  - now left; constructor.
  - right.
    destruct IHe1 as [V1|[E1|[e1' H1']]];
    destruct IHe2 as [V2|[E2|[e2' H2']]].
    + dependent elimination V1;  now eauto 6.
    + dependent elimination V1;
      dependent elimination E2;  now eauto 6.
    + dependent elimination H2'; now eauto 6.
    + dependent elimination V2;
      dependent elimination E1;  now eauto 6.
    + dependent elimination E1;  now eauto 6.
    + dependent elimination E1;  now eauto 6.
    + dependent elimination H1'; now eauto 6.
    + dependent elimination H1'; now eauto 6.
    + dependent elimination H1';
      dependent elimination H2'; now eauto 6.
Qed.

(*
Lemma Plug_value {Γ τ} {C : Ctxt Γ τ τ} (e v : Exp Γ τ) :
  ValueP v → Plug e C v → C = C_Nil _ ∧ e = v.
Proof.
  intros.
  dependent elimination H0;
  now inv H1.
Qed.

Lemma Plug_error {Γ τ} {C : Ctxt Γ τ τ} (e v : Exp Γ τ) :
  ErrorP v → Plug e C v → C = C_Nil _ ∧ e = v.
Proof.
  intros.
  dependent elimination H0;
  now inv H1.
Qed.

Lemma Value_not_redex {Γ τ} (e v : Exp Γ τ) :
  ValueP v → ¬ Redex v e.
Proof.
  repeat intro.
  dependent elimination H0;
  now inv H1.
Qed.

Lemma Error_not_redex {Γ τ} (e v : Exp Γ τ) :
  ErrorP v → ¬ Redex v e.
Proof.
  repeat intro.
  dependent elimination H0;
  now inv H1.
Qed.
*)

Lemma Value_irreducible {Γ τ} {e e' : Exp Γ τ} :
  ValueP e → ¬ (e ---> e').
Proof.
  repeat intro.
  dependent elimination H0;
  dependent elimination H1.
  (* - inv p. *)
  (*   now inv r. *)
  (* - now inv p1. *)
  (* - inv p. *)
  (*   now inv r. *)
  (* - now inv p1. *)
Qed.

Lemma Value_cannot_start {Γ τ} {e e' : Exp Γ τ} :
  (e ---> e') → ¬ ValueP e.
Proof.
  repeat intro.
  dependent elimination H0;
  dependent elimination H1.
  (* - inv p. *)
  (*   now inv r. *)
  (* - now inv p. *)
  (* - inv p1. *)
  (* - now inv p1. *)
Qed.

Lemma Error_irreducible {Γ τ} {e e' : Exp Γ τ} :
  ErrorP e → ¬ (e ---> e').
Proof.
  repeat intro.
  dependent elimination H0;
  dependent elimination H1.
  (* - inv p. *)
  (*   now inv r. *)
  (* - now inv p1. *)
Qed.

Lemma Error_cannot_start {Γ τ} {e e' : Exp Γ τ} :
  (e ---> e') → ¬ ErrorP e.
Proof.
  repeat intro.
  dependent elimination H0;
  dependent elimination H1.
  (* - inv p. *)
  (*   now inv r. *)
  (* - now inv p1. *)
Qed.

(*
Lemma Plug_deterministic {Γ τ} e2 :
  ∀ τ' (C : Ctxt Γ τ' τ) e1 e1',
    Redex e1 e1' → Plug e1 C e2 →
  ∀ τ'' (C' : Ctxt Γ τ'' τ) f1 f1',
    Redex f1 f1' → Plug f1 C' e2 →
    τ' = τ'' ∧ C ~= C' ∧ e1 ~= f1.
Proof.
  intros τ' C e1 e1' R1 P1 τ'' C' f1 f1' R2 P2.
  generalize dependent C'.
  induction P1; intros; subst.
  inv P2; auto.
  - exfalso.
    dependent elimination R1.
    dependent elimination R2.
    now inv H3.
  - exfalso.
    dependent elimination R1.
    dependent elimination R2.
    now inv H4.
  - dependent elimination P2.
    + exfalso.
      dependent elimination R1.
      dependent elimination R2.
      now inv P1.
    + intuition.
      now destruct (IHP1 _ p); reduce.
    + exfalso.
      dependent elimination R1.
      dependent elimination R2.
      now inv P1.
  - dependent elimination P2.
    + exfalso.
      dependent elimination R1.
      dependent elimination R2.
      now inv P1.
    + exfalso.
      dependent elimination R1.
      dependent elimination R2.
      now inv p.
    + intuition.
      now destruct (IHP1 _ p0); reduce.
Qed.

Lemma Plug_error_deterministic {Γ τ} {e : Exp Γ τ} :
  ∀ τ' {C : Ctxt Γ τ' τ} x,
    Plug (Error x) C e →
  ∀ τ'' (C' : Ctxt Γ τ'' τ) x',
    Plug (Error x') C' e →
    τ' = τ'' ∧ x = x' ∧ C ~= C'.
Proof.
  intros τ' C x P1 τ'' C' x' P2.
  intros.
  generalize dependent C'.
  generalize dependent x'.
  generalize dependent τ''.
  induction P1; intros; subst.
  - now dependent elimination P2.
  - dependent elimination P2.
    + now destruct (IHP1 _ _ _ p); reduce.
    + exfalso.
      clear -P1 v.
      dependent elimination v.
      now inv P1.
  - dependent elimination P2.
    + exfalso.
      clear -p v.
      dependent elimination v.
      now inv p.
    + now destruct (IHP1 _ _ _ p0); reduce.
Qed.

(*
Lemma Plug_errors_block_redex {Γ τ} e2 :
  ∀ τ' (C : Ctxt Γ τ' τ) n e y,
    Plug (Error y) n C e →
  ∀ τ'' (C' : Ctxt Γ τ'' τ) m f1 f1',
    Redex f1 f1' → Plug f1 m C' e2 →
    τ' = τ'' ∧ n = m ∧ C ~= C' ∧ e1 ~= f1.
*)

Lemma Plug_functional {Γ τ τ'} {C : Ctxt Γ τ' τ} e :
  ∀ e1, Plug e C e1 → ∀ e2, Plug e C e2 → e1 = e2.
Proof.
  intros.
  dependent induction H0.
  - now inv H1.
  - dependent destruction H1.
    now f_equal; auto.
  - dependent destruction H1.
    now f_equal; auto.
Qed.

Lemma Plug_injective {Γ τ τ'} {C : Ctxt Γ τ' τ} e :
  ∀ e1, Plug e1 C e → ∀ e2, Plug e2 C e → e1 = e2.
Proof.
  intros.
  dependent induction H0.
  - now inv H1.
  - dependent destruction H1.
    now f_equal; auto.
  - dependent destruction H1.
    now f_equal; auto.
Qed.

Lemma Redex_deterministic {Γ τ} {e : Exp Γ τ} :
  ∀ e', Redex e e' → ∀ e'', Redex e e'' → e' = e''.
Proof.
  intros.
  dependent elimination H0.
  dependent elimination H1.
  reflexivity.
Qed.
*)

(*
Proof.
  dependent induction e; repeat intro; inv H.
  - dependent induction v0; simp consSub in *.
    + simp SubVar in H1.
  (*     now induction v; inv H1; intuition. *)
  (*   + simp SubVar in H1. *)
  (*     rewrite SubVar_idSub in H1. *)
  (*     now induction v0; inv H1; intuition. *)
*)

(*
Lemma If_loop_true {Γ τ} b {x : Exp Γ τ} {y : Exp Γ τ} :
  ¬ (If b x y = x).
Proof.
  induction x; intro; inv H.
  now eapply IHx2; eauto.
Qed.

Lemma If_loop_false {Γ τ} b {x : Exp Γ τ} {y : Exp Γ τ} :
  ¬ (If b x y = y).
Proof.
  induction y; intro; inv H.
  now eapply IHy3; eauto.
Qed.

Lemma Seq_loop {Γ τ ty} {x : Exp Γ ty} {y : Exp Γ τ} :
  ¬ (Seq x y = y).
Proof.
  induction y; intro; inv H.
  now eapply IHy2; eauto.
Qed.
*)

(*
#[export]
Program Instance RenExp_Step {Γ Γ' τ} (σ : Ren Γ' Γ) :
  Proper (Step (Γ:=Γ) (τ:=τ) ==> Step) (RenExp σ).
Next Obligation.
  intros.
  induction H0; simpl;
  try solve [ now constructor; intuition idtac
            | now constructor; intuition; apply RenExp_ValueP ].
  (* - now apply Reduce_preserves_renaming. *)
  (* - now apply CallHost_preserves_renaming. *)
Abort.
*)
(*
  - dependent elimination H2.
    (* epose proof (StepRule (Plug_AppR _ H0) *)
    (*                       (Plug_AppR _ H1) H3). *)
    dependent induction H2.
    + inv H1; simpl.
      rewrite <- SubExp_ScR.
      simp ScR.
      rewrite <- RcS_idSub.
      pose proof (SubExp_RcS (Keep σ) (Push (RenExp σ v) idSub) e) as H1.
      simp RcS in H1.
      rewrite H1.
      repeat econstructor.
      now apply RenExp_ValueP.
    + specialize (IHPlug _ _ _ _ _ eq_refl H1 v0).
      apply IHPlug.
      dependent destruction H1; simpl.

      repeat econstructor.
      epose proof (StepRule (Plug_AppL p)
                            (Plug_AppL H1)).

Qed.
*)

(*
#[export]
Program Instance SubExp_Step {Γ Γ' τ} (σ : Sub Γ' Γ) :
  Proper (Step (Γ:=Γ) (τ:=τ) ==> Step) (SubExp σ).
Next Obligation.
  intros.
Abort.
*)
(*
  induction H; simpl;
  try solve [ now constructor; intuition idtac
            | now constructor; intuition; apply SubExp_ValueP ].
  (* - now apply Reduce_preserves_substitution. *)
  (* - now apply CallHost_preserves_substitution. *)
  - rewrite <- SubExp_ScS.
    simpl ScS.
    rewrite ScS_idSub_left.
    pose proof (SubExp_ScS (Keepₛ σ) (Push (SubExp σ v) idSub) e) as H1.
    simpl in H1.
    simp SubVar in H1.
    unfold Dropₛ in H1.
    rewrite ScS_ScR in H1.
    rewrite RcS_skip1 in H1.
    rewrite ScS_idSub_right in H1.
    rewrite H1.
    constructor.
    now apply SubExp_ValueP.
Qed.
*)

(*
Lemma pluggable {Γ τ} {e1 e2 : Exp Γ τ} {τ'}
      {C : Ctxt Γ τ' τ} {f1 f2 : Exp Γ τ'} :
  ¬ ErrorP e1 →
  f1 ---> f2 →
  Plug f1 C e1 →
  Plug f2 C e2 →
  e1 ---> e2.
Proof.
  intros.
  dependent induction H1.
  - exact (StepRule (Plug_comp H1 H4) (Plug_comp H2 H5) H3).
  - exfalso.
    dependent elimination H1.
Abort.
*)

Lemma SubVar_ZV_of_value_never_error {Γ τ} {x : Exp Γ τ} :
  ValueP x → ∀ m, ¬ (SubVar {|| x ||} ZV = Error m).
Proof.
  intros.
  inv H0; simp SubVar;
  now intro.
Qed.

Lemma SubVar_SV_of_value_never_error {Γ τ}
      {x : Exp Γ τ} (v : Var Γ τ) :
  ValueP x → ∀ m, ¬ (SubVar {|| x ||} (SV v) = Error m).
Proof.
  intros.
  induction v; simp SubVar;
  rewrite SubVar_idSub;
  now intro.
Qed.

Lemma SubVar_of_value_never_error {Γ τ ty}
      {x : Exp Γ ty} (v : Var (ty :: Γ) τ) :
  ValueP x → ∀ m, ¬ (SubVar {|| x ||} v = Error m).
Proof.
  intros.
  pose proof (SubVar_ZV_of_value_never_error H0 m).
  dependent elimination v; simp SubVar in *.
  rewrite SubVar_idSub.
  intro.
  apply H1.
  now inv H2.
Qed.

Lemma SubExp_of_value_never_error {Γ τ ty}
      {v : Exp Γ ty} {e : Exp (ty :: Γ) τ} :
  ValueP v → ¬ ErrorP e → ∀ m, ¬ (SubExp {||v||} e = Error m).
Proof.
  intros.
  dependent elimination e; simpl.
  - exfalso.
    now apply H1.
  - now intro.
  - now apply SubVar_of_value_never_error.
  - now intro.
  - now intro.
Qed.

Lemma SubExp_error {Γ τ ty}
      {v : Exp Γ ty} {e : Exp (ty :: Γ) τ} {m} :
  ValueP v → SubExp {||v||} e = Error m → e = Error m.
Proof.
  intros.
  dependent elimination e; simpl in *.
  - now inv H1.
  - congruence.
  - pose proof (SubVar_of_value_never_error v0 H0 m).
    contradiction.
  - congruence.
  - congruence.
Qed.

(*
Lemma Step_Error_ind (Γ : Env) (τ : Ty) (e0 : Exp Γ τ) (m0 : Err)
      (P : ∀ τ (e : Exp Γ τ) m, e ---> Error m → Prop)
      (Pbeta : ∀ dom (e : Exp (dom :: Γ) τ) v (V : ValueP v) m
                 (r : Redex (APP (LAM e) v) (Error m)),
          e0 = APP (LAM e) v →
          m = m0 →
          P τ (APP (LAM e) v) m
            (StepRule (C:=C_Nil _) (Plug_Hole _) (Plug_Hole _) r))
      (Preduce : ∀ τ' τ'' (e : Exp Γ τ) (F : Frame Γ τ' τ) (C : Ctxt Γ τ'' τ') m
                   (p : Plug (Error m) (C_Cons _ F C) e),
          e0 = e →
          m = m0 →
          P τ e m (StepError p)):
  ∀ (s : e0 ---> Error m0), P τ e0 m0 s.
Proof.
  intros.
  dependent elimination s.
  - dependent elimination r.
    dependent destruction p0.
    pose proof (SubExp_error v0 x0); subst.
    dependent destruction p.
    simpl.
    now apply Pbeta.
  - now apply Preduce.
Qed.

(** A single expression can be plugged in multiple ways. *)
Lemma Plug_can_diverge {Γ τ} {e : Exp (TyUnit :: Γ) τ}
      {e' : Exp Γ (TyUnit ⟶ TyUnit)} {m : Err} :
  let f := APP (LAM (VAR ZV))
               (APP (LAM (VAR ZV))
                    EUnit) in
  Plug (Γ:=Γ) (LAM (VAR ZV))
       (C_Cons _ (F_AppL _ (APP (LAM (VAR ZV)) EUnit)) (C_Nil _)) f ∧
  Plug (Γ:=Γ) (LAM (VAR ZV))
       (C_Cons _ (F_AppR _ (LAM (VAR ZV)))
               (C_Cons _ (F_AppL _ EUnit) (C_Nil _))) f.
Proof. now simpl; eauto 6. Qed.
*)

(*
Theorem diamond_property {Γ τ} {r s t : Exp Γ τ} {m : Err} :
  r ---> s → r ---> t → s ≠ t → ∃ u, s ---> u ∧ t ---> u.
Proof.
  intros Hrs Hrt snt.
  induction Hrs, Hrt.
  - assert (τ' = τ'0 ∧ C ~= C0 ∧ e1 ~= e0)
        by (eapply Plug_deterministic; eassumption).
    reduce.
    pose proof (Redex_deterministic _ H2 _ H5).
    subst.
    pose proof (Plug_functional _ _ H1 _ H4).
    contradiction.
  - exfalso.
    inv H2.
    ...
  - exfalso.
    ...
  - pose proof (Plug_error_deterministic _ _ H0 _ _ _ H1).
    reduce.
    contradiction.
Abort.
*)

Theorem diamond_property {Γ τ} {r s t : Exp Γ τ} :
  r ---> s → r ---> t → s ≠ t → ∃ u, s ---> u ∧ t ---> u.
Proof.
  intros Hrs Hrt snt.
  dependent induction r; try now inv Hrs.
  intuition auto.
Abort.

(*
Lemma Step_Error_impl {Γ τ} {e' : Exp Γ τ} {m : Err} :
  e' ---> Error m →
      (∃ dom (v : Exp Γ dom) (e : Exp (dom :: Γ) τ),
         (∀ τ' τ'' (F : Frame Γ τ' τ) (C : Ctxt Γ τ'' τ'),
            ¬ Plug (Error m) (C_Cons _ F C) e') ∧
         ValueP v ∧ e' = APP (LAM e) v ∧ Redex e' (Error m))
    ∨ (∃ τ' τ'' (F : Frame Γ τ' τ) (C : Ctxt Γ τ'' τ'),
         (∀ τ' (e : Exp Γ τ') C',
            ¬ (e ≠ Error m ∧ Plug e C' e')) ∧
         Plug (Error m) (C_Cons _ F C) e').
Proof.
  intros.
  dependent elimination H0.
  - dependent elimination r.
    dependent destruction p0.
    pose proof (SubExp_error v0 x); subst.
    dependent destruction p.
    left.
    repeat eexists; eauto.
    repeat intro.
    inv H0.
    inv H3.
    inv H9;
    inv v0.
  - right.
    repeat eexists.
    + repeat intro; reduce.
      apply H0; clear H0.
      generalize dependent τ'.
      induction p1; intros.
      * inv H1; auto.
      * ...
      * ...
    + now apply p1.
Qed.
*)

Lemma AppL_LAM {Γ dom cod} {e e' : Exp Γ (dom ⟶ cod)} {x : Exp Γ dom} :
  ¬ ErrorP e' →
  e ---> e' →
  APP e x ---> APP e' x.
Proof.
  intros.
  dependent induction H1; now eauto 6.
Qed.

Corollary AppL_LAM_error {Γ dom cod} {x : Exp Γ dom} m :
  APP (Error (τ:=dom ⟶ cod) m) x ---> Error m.
Proof. now eauto 6. Qed.

Lemma AppR_LAM {Γ dom cod} {e : Exp (dom :: Γ) cod} {x x' : Exp Γ dom} :
  ¬ ErrorP x' →
  x ---> x' →
  APP (LAM e) x ---> APP (LAM e) x'.
Proof.
  intros.
  dependent induction H1; now eauto 6.
Qed.

Corollary AppR_LAM_error {Γ dom cod} {v : Exp Γ (dom ⟶ cod)} m :
  ValueP v →
  APP v (Error (τ:=dom) m) ---> Error m.
Proof. now eauto 6. Qed.

(* Definition normal_form `(R : relation X) (t : X) : Prop := *)
(*   ¬ ∃ t', R t t'. *)
Definition normal_form `(R : relation X) (t : X) : Prop :=
  ∀ t', ¬ R t t'.

Definition deterministic `(R : relation X) : Prop :=
  ∀ x y1 y2 : X, R x y1 → R x y2 → y1 = y2.

Lemma value_is_nf {Γ τ} (v : Exp Γ τ) :
  ValueP v → normal_form Step v.
Proof.
  repeat intro.
  dependent elimination H0.
  dependent induction H1.
  now inv H1.
Qed.

Lemma error_is_nf {Γ τ} (v : Exp Γ τ) :
  ErrorP v → normal_form Step v.
Proof.
  repeat intro.
  dependent elimination H0.
  dependent induction H1.
Qed.

Lemma nf_is_value_or_error {τ} (v : Exp [] τ) :
  normal_form Step v → ValueP v ∨ ErrorP v.
Proof.
  intros.
  destruct (strong_progress v); intuition eauto; reduce.
  now edestruct H0; eauto.
Qed.

Theorem nf_same_as_value_or_error {τ} (v : Exp [] τ) :
  normal_form Step v ↔ ValueP v ∨ ErrorP v.
Proof.
  split.
  - now apply nf_is_value_or_error.
  - intros [?|?].
    + now apply value_is_nf.
    + now apply error_is_nf.
Qed.

(*
Definition aborts {Γ} (m : Err) := λ τ (x : Exp Γ τ), x ---> Error m.
Arguments aborts {Γ} m /.

Definition HasError {Γ τ} (m : Err) := ExpP (Γ:=Γ) (τ:=τ) (aborts m).

Definition has_error_impl {Γ τ} {x : Exp Γ τ} {m} :
  HasError m x → x ---> Error m := ExpP_P _.

Lemma has_error_propagates {Γ τ} {x : Exp Γ τ} {m} :
  HasError m x → ∀ y, x ---> y → HasError m y.
Proof.
  unfold HasError.
  intros H0 y S1.
  generalize dependent x.
  generalize dependent y.
  generalize dependent m.
  induction τ; simpl; simp ExpP; intros; simp ExpP in *.
  - dependent elimination H0;
    dependent elimination S1.
Abort.

Lemma have_error {Γ τ} {x : Exp Γ τ} {m} :
  x ---> Error m → HasError m x.
Proof.
  unfold HasError.
  intros.
  generalize dependent x.
  generalize dependent m.
  induction τ; simpl; simp ExpP;
  intros; simp ExpP in *.
  intuition.
  eapply IHτ2.
  apply has_error_impl in H1.
  eapply Step_Error_ind; intuition eauto; subst.
  rewrite H2.
  dependent elimination H1;
  now apply AppL_LAM_error.
Qed.
*)

Lemma errors_deterministic {Γ τ} {x : Exp Γ τ} {m} :
  x ---> Error m → ∀ y, x ---> y → y = Error m.
Proof.
  intros.
  inv H0;
  inv H1; auto.
  inv H4.
Abort.

Theorem Step_deterministic Γ τ :
  deterministic (Step (Γ:=Γ) (τ:=τ)).
Proof.
  repeat intro.
  induction H0.
  - inv H1; auto.
    + now inv H5.
    + eapply Value_cannot_start in H0; eauto; tauto.
    + now inv H0.
  - inv H1.
    + now inv H0.
    + now f_equal; intuition.
    + now inv H0.
    + eapply Value_cannot_start in H6; eauto; tauto.
    + eapply Value_cannot_start in H5; eauto; tauto.
  - inv H1; auto.
    + now inv H4.
    + now inv H5.
    + now inv H4.
  - inv H1.
    + eapply Value_cannot_start in H6; eauto; tauto.
    + eapply Value_cannot_start in H0; eauto; tauto.
    + now inv H0.
    + now f_equal; intuition.
    + now inv H2.
  - inv H1; auto.
    + now inv H5.
    + eapply Value_cannot_start in H0; eauto; tauto.
    + now inv H0.
    + now inv H9.
Qed.

End Step.

Notation " t '--->' t' " := (Step t t') (at level 40).

Section Irr.

Import ListNotations.

Lemma App_Lam_loop_var `{HostExprs A}
      {Γ τ ty} {v : Exp Γ ty} {v0 : Var (ty :: Γ) τ} :
  ¬ (SubVar {||v||} v0 = APP (LAM (VAR v0)) v).
Proof.
  intro.
  dependent induction v0;
  simp SubVar in H0.
  - induction v; inv H0.
    now eapply IHv2; eauto.
  - rewrite SubVar_idSub in H0.
    now inv H0.
Qed.

Lemma App_Lam_loop `{HostExprs A}
      {Γ τ ty} {v : Exp Γ ty} {e : Exp (ty :: Γ) τ} :
  ¬ (SubExp {||v||} e = APP (LAM e) v).
Proof.
  intro H0.
  generalize dependent v.
  dependent induction e; simpl; intros;
  try congruence.
  - now eapply App_Lam_loop_var; eauto.
  - inv H0.
    (* impossible *)
Abort.

(* A term never reduces to itself. *)
#[export]
Program Instance Step_Irreflexive `{HostExprs A} {Γ τ} :
  Irreflexive (Step (Γ:=Γ) (τ:=τ)).
Next Obligation.
  dependent induction H0; try tauto.
  now eapply App_Lam_loop; eauto.
Qed.

Corollary Step_productive `{HostExprs A} {Γ τ} {x x' : Exp Γ τ} :
  x ---> x' → x ≠ x'.
Proof.
  repeat intro; subst.
  eapply Step_Irreflexive.
  exact H0.
Qed.

End Irr.


Require Import floyd.proofauto.
Require Import progs.dotprod.

Instance CompSpecs : compspecs.
Proof. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Local Open Scope logic.

Fixpoint map2 {A B C: Type} (f: A -> B -> C) (al: list A) (bl: list B) : list C :=
 match al, bl with
  | a::al', b::bl' => f a b :: map2 f al' bl'
  | _, _ => nil
  end.

Definition add_spec :=
 DECLARE _add
  WITH x: val, y : val, z: val, fy : list float, fz: list float
  PRE  [_x OF tptr tdouble, _y OF tptr tdouble, _z OF tptr tdouble]
      PROP ()
      LOCAL (temp _x x; temp _y y; temp _z z)
      SEP (`(data_at_ Tsh (tarray tdouble 3)  x) ;
             `(data_at Tsh (tarray tdouble 3) (map Vfloat fy) y);
             `(data_at Tsh (tarray tdouble 3) (map Vfloat fz) z))
  POST [ tvoid ]
      PROP ()
      LOCAL ()
      SEP (`(data_at Tsh (tarray tdouble 3) (map Vfloat (map2 Float.add fy fz)) x);
             `(data_at Tsh (tarray tdouble 3) (map Vfloat fy) y);
             `(data_at Tsh (tarray tdouble 3) (map Vfloat fz) z)).

Definition dotprod (fx fy : list float) : float :=
  fold_right Float.add Float.zero (map2 Float.mul fx fy).

Definition dotprod_spec :=
 DECLARE _dotprod
  WITH n: Z, x: val, y : val, fx : list float, fy: list float, sh: share
  PRE  [_n OF tint, _x OF tptr tdouble, _y OF tptr tdouble]
      PROP (0 <= n < Int.max_signed)
      LOCAL (temp _n (Vint (Int.repr n)); temp _x x; temp _y y)
      SEP (`(data_at Tsh (tarray tdouble n) (map Vfloat fx) x);
             `(data_at Tsh (tarray tdouble n) (map Vfloat fy) y))
  POST [ tdouble ]
      PROP ()
      LOCAL (temp ret_temp (Vfloat (dotprod fx fy)))
      SEP (`(data_at Tsh (tarray tdouble n) (map Vfloat fx) x);
             `(data_at Tsh (tarray tdouble n) (map Vfloat fy) y)).

Definition Gprog : funspecs :=   ltac:(with_library prog [add_spec; dotprod_spec]).

(*
Lemma dotprod_one_more:
  forall i f g, dotprod (i+1) f g = Float.add (dotprod i f g) (Float.mul (f i) (g i)).
Admitted.
*)

Lemma body_dotprod:  semax_body Vprog Gprog f_dotprod dotprod_spec.
Proof.
start_function.
name n_ _n.
name i_ _i.
name x_ _x.
name y_ _y.

forward. (* sum = 0.0; *)
forward_for_simple_bound n
   (EX i:Z,
      PROP ()
      LOCAL (temp _sum (Vfloat (dotprod (sublist 0 i fx) (sublist 0 i fy))); temp _x x; temp _y y)
      SEP (`(data_at Tsh (tarray tdouble n) (map Vfloat fx) x);
             `(data_at Tsh (tarray tdouble n) (map Vfloat fy) y))).
*
auto 50 with closed. (* doesn't work;  why? *)
simple apply closed_eval_expr_e; reflexivity.
* (* initializer *)
entailer!.
* (* body *)
forward_nl;
entailer!.
rewrite <- H1; f_equal.
apply dotprod_one_more.
* (*after the for-loop *)
 forward. (*   return; *)
Qed.

Lemma body_add:  semax_body Vprog Gprog f_add add_spec.
Proof.
start_function.
name i_ _i.
name x_ _x.
name y_ _y.
name z_ _z.

forward_for_simple_bound 3
   (EX i:Z,
      PROP ()
      LOCAL (temp _x x; temp _y y; temp _z z)
      SEP (`(array_at tdouble Tsh
                   (fun j => if zlt j i then Vfloat (Float.add (fy j) (fz j)) else Vundef)
                  0 3 x) ;
             `(array_at tdouble Tsh (Vfloat oo fy) 0 3 y);
             `(array_at tdouble Tsh (Vfloat oo fz) 0 3 z))).
* (* initializer *)
entailer!.
* (* body *)
forward_nl. (* x[i] = y[i] + z[i]; *)
entailer!.
apply array_at_ext'; intros.
unfold upd. if_tac. subst i0. rewrite if_true by omega. auto.
if_tac. rewrite if_true by omega; auto. rewrite if_false by omega; auto.
* (*after the for-loop *)
 forward. (*   return; *)
Qed.

Definition Svector_add (n: Z) (_i _x _y _z : ident) :=
   Ssequence (Sset _i (Econst_int (Int.repr 0) tint))
     (Sloop
        (Ssequence
           (Sifthenelse
              (Ebinop Olt (Etempvar _i tint) (Econst_int (Int.repr n) tint) tint)
              Sskip
              Sbreak)
           (Sassign
              (Ederef
                 (Ebinop Oadd (Etempvar _x (tptr tdouble)) (Etempvar _i tint)
                    (tptr tdouble)) tdouble)
              (Ebinop Oadd
                 (Ederef
                    (Ebinop Oadd (Etempvar _y (tptr tdouble))
                       (Etempvar _i tint) (tptr tdouble)) tdouble)
                 (Ederef
                    (Ebinop Oadd (Etempvar _z (tptr tdouble))
                       (Etempvar _i tint) (tptr tdouble)) tdouble) tdouble)))
        (Sset _i
           (Ebinop Oadd (Etempvar _i tint) (Econst_int (Int.repr 1) tint)
              tint))).

Definition vector_add (fx fy: Z -> float) i :=
    Float.add (fx i) (fy i).

Lemma semax_vector_add:
    forall (lx ly lz sx sy sz: nat)
              (n: Z) Espec Delta P Q R  (_i _x _y _z : ident) (x y z: val) (fx: Z -> val) (fy fz : Z -> float),
    typeof_temp Delta _i = Some tint ->
    Forall (closed_wrt_vars (eq _i)) Q ->
    Forall (closed_wrt_vars (eq _i)) R ->
    (0 <= n <= Int.max_signed) ->
    nth_error Q lx = Some (`(eq x) (eval_id _x)) ->
    nth_error Q ly = Some (`(eq y) (eval_id _y)) ->
    nth_error Q lz = Some (`(eq z) (eval_id _z)) ->
    nth_error R sx = Some (`(array_at tdouble Tsh fx 0 n x)) ->
    nth_error R sy = Some (`(array_at tdouble Tsh (Vfloat oo fy) 0 n y)) ->
    nth_error R sz = Some (`(array_at tdouble Tsh (Vfloat oo fz) 0 n z)) ->
    sx <> sy ->
    sx <> sz ->
   @semax Espec Delta
        (PROPx P (LOCALx Q (SEPx R)))
        (Svector_add n _i _x _y _z)
        (normal_ret_assert
         (PROPx P (LOCALx Q
          (SEPx  (replace_nth sx R
             (`(array_at tdouble Tsh (Vfloat oo (vector_add fy fz)) 0 n x))))))).
Proof.
intros until 4. intros Jx Jy Jz H3 H4 H5 Ny Nz.
assert (Ti: (temp_types (initialized _i Delta)) ! _i = Some (tint, true)). {
clear - H. unfold typeof_temp in H.
destruct ((temp_types Delta) ! _i) eqn:?; inv H. destruct p.
inv H1. eapply temp_types_init_same; eauto.
}
apply semax_pre0 with
 (PROPx (isptr x :: isptr y :: isptr z :: P) (LOCALx Q (SEPx R))). {
repeat rewrite <- insert_prop.
repeat rewrite <- andp_assoc. apply andp_right; auto.
repeat apply andp_right.
rewrite (replace_nth_nth_error _ _ _ H3).
erewrite SEP_replace_nth_isolate by (eapply H3).
go_lowerx; normalize; rewrite array_at_isptr; normalize.
rewrite (replace_nth_nth_error _ _ _ H4).
erewrite SEP_replace_nth_isolate by (eapply H4).
go_lowerx; normalize; rewrite array_at_isptr; normalize.
rewrite (replace_nth_nth_error _ _ _ H5).
erewrite SEP_replace_nth_isolate by (eapply H5).
go_lowerx; normalize; rewrite array_at_isptr; normalize.
}
repeat rewrite <- insert_prop.
apply semax_extract_prop; intro Px.
apply semax_extract_prop; intro Py.
apply semax_extract_prop; intro Pz.
apply (semax_for_simple_bound_const_init n
   (EX  i : Z, PROPx ((fun _ => P) i)
                  (LOCALx ((fun _ => Q) i)
                  (SEPx ((fun i =>
                 replace_nth sx R
                   (`(array_at tdouble Tsh
                         (fun j => if zlt j i then Vfloat (Float.add (fy j) (fz j)) else fx j) 0 n x))
               ) i))))
     Espec Delta _ (fun _ => P) (fun _ => Q) (fun i =>
                 replace_nth sx R
                   (`(array_at tdouble Tsh (fun j => if zlt j i then Vfloat (Float.add (fy j) (fz j)) else fx j) 0 n x))
               ));
  try reflexivity; try auto with closed; try repable_signed.
*
apply andp_left2.
replace (array_at tdouble Tsh
                 (fun j : Z =>
                  if zlt j 0
                  then Vfloat (Float.add (fy j) (fz j))
                  else fx j) 0 n)
 with (array_at tdouble Tsh fx 0 n).
Focus 2.
simple apply array_at_ext; intros.
rewrite if_false by omega; reflexivity.
rewrite <- (replace_nth_nth_error _ _ _ H3).
rewrite <- insert_local.
apply andp_right; auto. go_lowerx. normalize.
*
intro i.
go_lowerx; normalize. apply prop_right. hnf. simpl.
rewrite Ti. simpl. apply I.
*
rewrite normal_ret_assert_elim.
drop_LOCAL 0%nat.
drop_LOCAL 0%nat.
apply replace_nth_SEP.
go_lowerx. apply array_at_ext'; intros.
rewrite if_true by omega. auto.
*
intro i.
drop_LOCAL 1%nat.
match goal with |- semax _ (PROPx ?P (LOCALx ?Q (SEPx ?R))) _ _ =>
   apply semax_pre0
   with (PROPx P (LOCALx (`(eq x) (eval_id _x) :: `(eq y) (eval_id _y) ::
                           `(eq z) (eval_id _z) :: Q) (SEPx R)))
 end.
rewrite <- (insert_local (`(eq _) (eval_id _x))).
rewrite <- (insert_local (`(eq _) (eval_id _y))).
rewrite <- (insert_local (`(eq _) (eval_id _z))).
repeat rewrite <- andp_assoc. apply andp_right; auto.
drop_LOCAL 0%nat.
repeat apply andp_right; eapply nth_error_local; eauto.
apply semax_extract_PROP; intro.

eapply semax_pre0; [ apply now_later | ].
eapply semax_post_flipped';
   [simple eapply (semax_loadstore_array sx);
       [ reflexivity | apply I | reflexivity | reflexivity| reflexivity
       |
       | erewrite nth_error_replace_nth; eauto
       | auto |  | eassumption ]
    |  ].
 +
  match goal with |- ?PQR  |-- _ =>
       apply derives_trans with
       (PQR
   && ((TT * `(array_at tdouble Tsh (Vfloat oo fy) 0 n y))
     && (TT * `(array_at tdouble Tsh (Vfloat oo fz) 0 n z))))
  end.
  apply andp_right; auto.
  apply andp_right.

  rewrite (replace_nth_nth_error _ _ _ H4).
  rewrite replace_nth_commute by auto.
  erewrite SEP_replace_nth_isolate
    by (rewrite nth_error_replace_nth' by auto; eassumption).
  rewrite sepcon_comm.
  rewrite <- insert_SEP. apply sepcon_derives; auto.

  rewrite (replace_nth_nth_error _ _ _ H5).
  rewrite replace_nth_commute by auto.
  erewrite SEP_replace_nth_isolate
   by (rewrite nth_error_replace_nth' by auto; eassumption).
   rewrite sepcon_comm.
   rewrite <- insert_SEP. apply sepcon_derives; auto.

  go_lowerx. normalize.
  apply andp_left2.
  subst. repeat instantiate_Vptr; repeat apply andp_right.
  rel_expr.
  rel_expr.
  simple eapply rel_expr_cast; [ | try (simpl; rewrite_eval_id; reflexivity) ].
  simple eapply rel_expr_binop; [ |  | ].
  apply andp_left1. rel_expr.
  apply andp_left2. rel_expr.
  reflexivity.
  reflexivity.
 +
   apply I.
 +
  simpl valinject.
  rewrite replace_nth_replace_nth.
  replace (array_at tdouble Tsh
               (upd
                  (fun j : Z =>
                   if zlt j i then Vfloat (Float.add (fy j) (fz j)) else fx j)
                  i (Vfloat (Float.add (fy i) (fz i)))) 0 n)
     with (array_at tdouble Tsh
                   (fun j : Z =>
                    if zlt j (i + 1)
                    then Vfloat (Float.add (fy j) (fz j))
                    else fx j) 0 n).
 entailer.
 apply array_at_ext; intros. symmetry.
 unfold upd.
 if_tac. subst. rewrite if_true by omega; try reflexivity.
 if_tac.
   rewrite if_true by omega; reflexivity.
   rewrite if_false by omega; reflexivity.
Qed.

Ltac forward_vector_add :=
 repeat match goal with |-
      semax _ _ (Ssequence (Ssequence (Ssequence _ _) _) _) _ =>
      apply -> seq_assoc; abbreviate_semax
 end;
 forward_seq;
 [eapply semax_vector_add;
 [reflexivity | auto 50 with closed | auto 50 with closed
   | repable_signed
   | solve_nth_error | solve_nth_error | solve_nth_error
   | solve_nth_error | solve_nth_error | solve_nth_error
  | computable | computable ]
 | unfold replace_nth
 ].

Lemma body_add':  semax_body Vprog Gprog f_add add_spec.
Proof.
start_function.
name i_ _i.
name x_ _x.
name y_ _y.
name z_ _z.

forward_vector_add.
forward.
Qed.


(** Exact category prerequisite tests *)

Require Export UniMath.Foundations.All.
Require Export UniMath.CategoryTheory.Monics.
Require Export UniMath.CategoryTheory.Epis.
Require Export UniMath.CategoryTheory.limits.zero.
Require Export UniMath.CategoryTheory.limits.kernels.
Require Export UniMath.CategoryTheory.limits.cokernels.
Require Export UniMath.CategoryTheory.limits.binproducts.
Require Export UniMath.CategoryTheory.limits.bincoproducts.
Require Export UniMath.CategoryTheory.limits.pullbacks.
Require Export UniMath.CategoryTheory.limits.pushouts.
Require Export UniMath.CategoryTheory.limits.BinDirectSums.
Require Export UniMath.CategoryTheory.limits.Opp.
Require Export UniMath.CategoryTheory.CategoriesWithBinOps.
Require Export UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.TransportMorphisms.
Require Export UniMath.CategoryTheory.opp_precat.
Require Export UniMath.CategoryTheory.PrecategoriesWithAbgrops.
Require Export UniMath.CategoryTheory.PreAdditive.
Require Export UniMath.CategoryTheory.Morphisms.
Require Export UniMath.CategoryTheory.Additive.
Require Export UniMath.CategoryTheory.Core.Functors.
Require Export UniMath.CategoryTheory.Subcategory.Full.
Require Export UniMath.MoreFoundations.Notations.
Require Export UniMath.MoreFoundations.PartA.
Require Export UniMath.MoreFoundations.Propositions.
Require Export UniMath.Algebra.BinaryOperations.
Require Export UniMath.Algebra.Monoids.
Require Export UniMath.Algebra.Groups.
Import AddNotation.
Local Open Scope addmonoid.
Local Open Scope abgr.
Local Open Scope logic.
Local Open Scope cat.
Local Arguments isZero {_} _.
Local Arguments BinDirectSumOb {_ _ _}.
Local Arguments to_binop {_ _ _}.
Local Arguments grinv {_}.
Local Arguments BinDirectSum {_}.
Local Arguments to_Pr1 {_ _ _} _.
Local Arguments to_Pr2 {_ _ _} _.
Local Arguments to_In1 {_ _ _} _.
Local Arguments to_In2 {_ _ _} _.
Local Arguments to_BinOpId {_ _ _ _ _ _ _ _}.
Local Arguments to_IdIn1 {_ _ _ _ _ _ _ _}.
Local Arguments to_IdIn2 {_ _ _ _ _ _ _ _}.
Local Arguments to_Unel1 {_ _ _ _ _ _ _ _}.
Local Arguments to_Unel2 {_ _ _ _ _ _ _ _}.
Local Arguments MorphismPair : clear implicits.
Local Arguments morphism_from_iso {_ _ _}.
Local Arguments ToBinDirectSum {_ _ _} _ {_}.
Local Arguments isBinDirectSum {_ _ _ _}.

Require Import UniMath.CategoryTheory.ExactCategories.ExactCategories.

Goal ∏ (C:category) (a b:C) (f: a --> b), isMonic (C:=C) f = isEpi (C:=C^op) f.
  reflexivity.
Defined.
Goal ∏ (C:category) (a b:C) (f: a --> b), isEpi (C:=C) f = isMonic (C:=C^op) f.
  reflexivity.
Defined.
(** Here's why we prefer to use z_iso instead of iso : *)
Goal ∏ (C:precategory) (a b:C) (f:z_iso a b), z_iso_inv (z_iso_inv f) = f.
  reflexivity.
Defined.
Goal ∏ (C:precategory) (a b:C) (f:z_iso (C:=C) a b), opp_z_iso (opp_z_iso f) = f.
  reflexivity.
Defined.
Goal ∏ (C:category) (a b:C) (f:z_iso (C:=C^op) b a), opp_z_iso (opp_z_iso f) = f.
  reflexivity.
Defined.
Goal ∏ (M : category) {X:Type} (j : X -> ob M),
  induced_precategory M^op j = (induced_category M j)^op.
Proof.
  reflexivity.
Defined.
Goal ∏ (M:precategory) (P:MorphismPair M), MorphismPair_opp (MorphismPair_opp P) = P.
Proof.
  reflexivity.
Qed.
Goal ∏ {M : category} (A B C:M) (f : A --> C) (g : B --> C), Pullback f g = Pushout (C:=M^op) f g.
  reflexivity.
Defined.
Goal ∏ {M : category} (A B C:M) (f : A --> C) (g : A --> C), Pushout f g = Pullback (C:=M^op) f g.
  reflexivity.
Defined.
Goal ∏ (M : precategoryWithBinOps), oppositePrecategoryWithBinOps (oppositePrecategoryWithBinOps M) = M.
Proof.
  reflexivity.
Defined.

Goal ∏ {M:precategoryWithBinOps} {X:Type} (j : X -> ob M),
  oppositePrecategoryWithBinOps (induced_precategoryWithBinOps M j) =
  induced_precategoryWithBinOps (oppositePrecategoryWithBinOps M) j.
Proof.
  reflexivity.           (* 0.038 secs *)
Qed.

Goal ∏ (M : categoryWithAbgrops), oppositeCategoryWithAbgrops (oppositeCategoryWithAbgrops M) = M.
Proof.
  reflexivity.
Defined.

Goal ∏ {M:categoryWithAbgrops} {X:Type} (j : X -> ob M),
  oppositeCategoryWithAbgrops (induced_categoryWithAbgrops M j) =
  induced_categoryWithAbgrops (oppositeCategoryWithAbgrops M) j.
Proof.
  reflexivity.           (* 0.183 secs *)
Qed.

Goal ∏ (M : PreAdditive), oppositePreAdditive (oppositePreAdditive M) = M.
Proof.
  reflexivity.
Defined.
Goal ∏ (M:PreAdditive) (x y:M) (xy : BinDirectSum x y),
  oppositeBinDirectSum (M:=oppositePreAdditive M) (oppositeBinDirectSum xy) = xy.
Proof.
  reflexivity.
Defined.
Goal ∏ (M:PreAdditive) (A B:M) (AB : BinDirectSum A B), reverseBinDirectSum (oppositeBinDirectSum AB) = oppositeBinDirectSum (reverseBinDirectSum AB).
  reflexivity.
Defined.
Goal ∏ (M:PreAdditive) (A B:M) (AB : BinDirectSum A B), reverseBinDirectSum (reverseBinDirectSum AB) = AB.
  Fail reflexivity.
Abort.

Local Definition hom (C:precategory_data) : ob C -> ob C -> UU := λ c c', precategory_morphisms c c'.
Local Definition Hom (C : category) : ob C -> ob C -> hSet := λ c c', make_hSet _ (homset_property C c c').
Local Definition Hom_add (C : PreAdditive) : ob C -> ob C -> abgr := λ c c', (@to_abgr C c c').

Section Sanity.
  Context (M : category) (x y:M) (f : hom M x y) (g : Hom M x y).
  Goal Hom M x y. exact f. Defined.
  Goal hom M x y. exact g. Defined.
End Sanity.

Section Sanity2.
  Context (M : PreAdditive) (x y:M) (f : hom M x y) (g : Hom M x y) (h : Hom_add M x y).
  Goal Hom_add M x y. exact f. Defined.
  Goal Hom_add M x y. exact g. Defined.
  Goal Hom M x y. exact f. Defined.
  Goal Hom M x y. exact h. Defined.
  Goal hom M x y. exact g. Defined.
  Goal hom M x y. exact h. Defined.
End Sanity2.

Goal ∏ (M:precategory) (P:MorphismPair M), MorphismPair_opp (MorphismPair_opp P) = P.
Proof.
  reflexivity.
Qed.
Goal ∏ (M:category) (p:MorphismPair (M^op)), MorphismPair M.
  intros. exact (MorphismPair_opp p).
Qed.
Goal ∏ (M:category) (P Q : MorphismPair M^op) (f:MorphismPairIsomorphism P Q),
  opp_MorphismPairIsomorphism (opp_MorphismPairIsomorphism f) = f.
Proof.
  reflexivity.
Qed.
Goal ∏ (M:category) (P Q : MorphismPair M^op),
 MorphismPairIsomorphism (C:=M^op) P Q ->
 MorphismPairIsomorphism (C:=M) (MorphismPair_opp Q) (MorphismPair_opp P).
Proof.
  intros M P Q. exact (opp_MorphismPairIsomorphism (M:=M^op) ).
Qed.
Goal ∏ (M : AdditiveCategory), oppositeAdditiveCategory (oppositeAdditiveCategory M) = M.
Proof.
  reflexivity.
Defined.
Goal ∏ {M:AdditiveCategory} {X:Type} (j : X -> ob M) (su : sums_lift M j),
  opp_sums_lift (oppositeAdditiveCategory M) j (opp_sums_lift M j su) = su.
Proof.
  reflexivity.
Qed.
Goal ∏ (M:ExactCategoryData), oppositeExactCategoryData (oppositeExactCategoryData M) = M.
  reflexivity.
Qed.
Goal ∏ (M:ExactCategory), ExactCategoryDataToAdditiveCategory (ExactCategoryToData (oppositeExactCategory M))
                          = oppositeAdditiveCategory (ExactCategoryDataToAdditiveCategory (ExactCategoryToData M)).
Proof.
  reflexivity.
Defined.
Goal ∏ (M:ExactCategory), oppositeExactCategory (oppositeExactCategory M) = M.
Proof.
  reflexivity.
Defined.
Goal ∏ (M:ExactCategory) (A B:M) (f : A --> B),
  isAdmissibleMonomorphism f = isAdmissibleEpimorphism (M:=oppositeExactCategory M) (opp_mor f).
Proof.
  reflexivity.
Defined.
Goal ∏ (M:ExactCategory) (A B:M) (f : A --> B), isAdmissibleEpimorphism f = isAdmissibleMonomorphism (M:=oppositeExactCategory M) (opp_mor f).
Proof.
  reflexivity.
Defined.
Goal ∏ (M:ExactCategory) (A B:M),
  AdmissibleMonomorphism A B = @AdmissibleEpimorphism (oppositeExactCategory M) B A.
Proof.
  reflexivity.
Defined.
Goal ∏ (M:ExactCategory) (A B:M),
  AdmissibleEpimorphism A B = @AdmissibleMonomorphism (oppositeExactCategory M) B A.
Proof.
  reflexivity.
Defined.
Goal ∏ {M : ExactCategory} {A:M} (Z:Zero M), Mor1 (TrivialExactSequence A Z) = identity A.
  reflexivity.
Qed.
Goal ∏ {M : ExactCategory} {A:M} (Z:Zero M), Ob3 (TrivialExactSequence A Z) = Z.
  reflexivity.
Qed.
Goal ∏ {M : ExactCategory} {A:M} (Z:Zero M), Mor2 (TrivialExactSequence' Z A) = identity A.
  reflexivity.
Qed.
Goal ∏ {M : ExactCategory} {A:M} (Z:Zero M), Ob1 (TrivialExactSequence' Z A) = Z.
  reflexivity.
Qed.
Goal ∏ {M:ExactCategory} {X:Type} (j : X -> ob M) (ce : exts_lift M j),
  opp_exts_lift (M:=oppositeExactCategory M) j (opp_exts_lift (M:=M) j ce) = ce.
Proof.
  reflexivity.
Defined.

(** Exact category tests *)

Goal ∏ (M:category) (A A' B:M) (g : A --> B) (g' : A' --> B) (i:IsoArrowTo g g'),
  opposite_IsoArrowFrom (opposite_IsoArrowTo i) = i.
Proof.
  reflexivity.
Defined.
Goal ∏ (M:category) (A B B':M) (g : A --> B) (g' : A --> B') (i:IsoArrowFrom g g'),
  opposite_IsoArrowTo (opposite_IsoArrowFrom i) = i.
Proof.
  reflexivity.
Defined.

Goal ∏ {M:category} {X:Type} (j : X -> ob M) (hz : zero_lifts M j),
  opp_zero_lifts (C:= M^op) j (opp_zero_lifts (C:=M) j hz) = hz.
Proof.
  reflexivity.
Defined.

Goal ∏ (M:category), oppositeCategory (oppositeCategory M) = M.
  reflexivity.
Qed.

Goal ∏ {M:category} {a b c d : M} (f : b --> a) (g : c --> a)
     (p1 : d --> b) (p2 : d --> c),
  isPullback' f g p1 p2 = isPushout' (M := oppositeCategory M) f g p1 p2.
Proof.
  reflexivity.
Defined.

Goal ∏ {M:category} {a b c d : M} (f : a --> b) (g : a --> c)
     (in1 : b --> d) (in2 : c --> d),
  isPushout' f g in1 in2 = isPullback' (M := oppositeCategory M) f g in1 in2.
Proof.
  reflexivity.
Defined.
Goal ∏ (M:category) (A A' B:M) (g : A --> B) (g' : A' --> B) (i:IsoArrowTo g g'),
  opposite_IsoArrowFrom (opposite_IsoArrowTo i) = i.
Proof.
  reflexivity.
Defined.
Goal ∏ (M:category) (A B B':M) (g : A --> B) (g' : A --> B') (i:IsoArrowFrom g g'),
  opposite_IsoArrowTo (opposite_IsoArrowFrom i) = i.
Proof.
  reflexivity.
Defined.
Goal ∏ (M:PreAdditive) (x y z : M) (f : x --> y) (g : y --> z), isKernel' (M:=M) f g = isCokernel' (M:=oppositePreAdditive M) g f.
  reflexivity.
Defined.
Goal ∏ (M:PreAdditive) (x y z : M) (f : x --> y) (g : y --> z), isCokernel' (M:=M) f g = isKernel' (M:=oppositePreAdditive M) g f.
  reflexivity.
Defined.
Goal ∏ (M :PreAdditive) (A B C A':M) (i : A <-- B) (p : B <-- C)
      (pr : isKernelCokernelPair p i)
      (r : A <-- A') (pb : Pullback i r),
  PairPullbackMap pr r pb
  =
  PairPushoutMap (M:=oppositePreAdditive M) (opposite_isKernelCokernelPair pr) r pb.
Proof.
  reflexivity.
Defined.
Goal ∏ (M :PreAdditive) (A B C A':M) (i : A --> B) (p : B --> C)
      (pr : isKernelCokernelPair i p)
      (r : A --> A') (po : Pushout i r),
  PairPushoutMap pr r po
  =
  PairPullbackMap (M:=oppositePreAdditive M) (opposite_isKernelCokernelPair pr) r po.
Proof.
  reflexivity.
Defined.


Require Import FcEtt.sigs.
Require Import FcEtt.imports.
Require Import FcEtt.ett_ott.

Require Import FcEtt.ett_inf.
Require Import FcEtt.ett_par.

Require Import FcEtt.ett_ind.

Require Import FcEtt.ext_wf.

Require Import FcEtt.ext_red_one.

Require Import FcEtt.tactics.

Module ext_red (invert : ext_invert_sig).

  Export invert.

Module red_one := ext_red_one invert.
Export red_one.

Set Bullet Behavior "Strict Subproofs".
Set Implicit Arguments.

Lemma Beta_preservation : forall a b, Beta a b -> forall G A, Typing G a A -> Typing G b A.
Proof.
  intros a b B. destruct B; intros G A0 TH.
  - have CT: Ctx G by eauto.
    have RA: Typing G A0 a_Star by eauto using Typing_regularity.

     destruct (invert_a_App_Rel TH) as (A & B & TB & Tb & DE).
      destruct (invert_a_UAbs TB) as (A1 & B1 & DE2 & [L TB1] & TA1).
      eapply E_Conv with (A := (open_tm_wrt_tm B1 b)); eauto 2.
      pick fresh x.
      move: (TB1 x ltac:(auto)) =>  [T1 [T2 RC]].
      rewrite (tm_subst_tm_tm_intro x v); eauto.
      rewrite (tm_subst_tm_tm_intro x B1); eauto.
      eapply Typing_tm_subst with (A:=A1); eauto 2.
      eapply E_Conv with (A := A); eauto 2 using E_PiFst.
      eapply E_Trans with (a1:= open_tm_wrt_tm B b); eauto using E_PiSnd, E_Refl, E_Sym.
  - have CT: Ctx G by eauto.
    have RA: Typing G A0 a_Star by eauto using Typing_regularity.
    destruct (invert_a_App_Irrel TH) as (A & B & b0 & Tb & Tb2 & DE).
      destruct (invert_a_UAbs Tb) as (A1 & B1 & DE2 & [L TB1] & TA1).
      eapply E_Conv with (A := (open_tm_wrt_tm B1 b0)); eauto 2.
      pick fresh x.
      move: (TB1 x ltac:(auto)) =>  [T1 [T2 RC]].
      inversion RC. subst.
      rewrite (tm_subst_tm_tm_intro x v); eauto.
      rewrite (tm_subst_tm_tm_intro x B1); eauto.
      rewrite (tm_subst_tm_tm_fresh_eq _ _ _ H0).
      rewrite - (tm_subst_tm_tm_fresh_eq _ b0 x H0).
      eapply Typing_tm_subst with (A:=A1); eauto 2.
      eapply E_Conv with (A:=A); eauto using E_PiFst.
      eapply E_Sym.
      eapply E_Trans with (a1 := open_tm_wrt_tm B b0). auto.
      eapply E_PiSnd; eauto using E_Refl.
   - have CT: Ctx G by eauto.
     have RA: Typing G A0 a_Star by eauto using Typing_regularity.
     destruct (invert_a_CApp TH) as (eq & a1 & b1 & A1 & B1 & h0 & h1 & h2).
     destruct (invert_a_UCAbs h0) as (a2 & b2 & A2 & B2 & h3 & h4 & [L h5]).
     pick fresh c.
     move: (h5 c ltac:(auto)) => [T1 T2].
     have? : DefEq G (dom G) a2 b2 A2. eauto using E_CPiFst, E_Cast.

     eapply E_Conv with (A:= (open_tm_wrt_co B2 g_Triv)); eauto 2.
     rewrite (co_subst_co_tm_intro c a'); eauto.
     rewrite (co_subst_co_tm_intro c B2); eauto.
     eapply Typing_co_subst; eauto.
     eapply E_Sym.
     eapply E_Trans with (a1 := open_tm_wrt_co B1 g_Triv). auto.
     eapply E_CPiSnd; eauto 2.
   - destruct (invert_a_Fam TH) as (b & B & h0 & h1 & h2).
     assert (Ax a A = Ax b B). eapply binds_unique; eauto using uniq_toplevel.
     inversion H0. subst.
     eapply E_Conv with (A := B).
     eapply toplevel_closed in h1.
     eapply Typing_weakening with (F:=nil)(G:=nil)(E:=G) in h1.
     simpl_env in h1.
     auto. auto. simpl_env.
     eauto.
     eapply E_Sym. eauto.
     move: (DefEq_regularity h0) => h3.
     inversion h3.
     auto.
Qed.

Lemma E_Beta2 :  ∀ (G : context) (D : available_props) (a1 a2 B : tm),
       Typing G a1 B → Beta a1 a2 → DefEq G D a1 a2 B.
Proof.
  intros; eapply E_Beta; eauto.
  eapply Beta_preservation; eauto.
Qed.

(*
Lemma Par_fv_preservation: forall G D x a b, Par G D a b ->
                                        x `notin` fv_tm_tm_tm a ->
                                        x `notin` fv_tm_tm_tm b.
Proof.
  intros.
  induction H; eauto 2; simpl.
  all: simpl in H0.
  all: try solve [move => h0; apply AtomSetFacts.union_iff in h0; case: h0 => h0; eauto; apply IHreduction_in_one; auto].
  all: try auto.
  - simpl in *.
    have: x `notin` fv_tm_tm_tm (open_tm_wrt_tm a' b') => h0.
    apply fv_tm_tm_tm_open_tm_wrt_tm_upper in h0.
    apply AtomSetFacts.union_iff in h0.
    case:h0; eauto => h0.
    fsetdec_fast.
    fsetdec_fast.
    auto.
  - rewrite fv_tm_tm_tm_open_tm_wrt_tm_upper.
    fsetdec.
  - have: x `notin` fv_tm_tm_tm (open_tm_wrt_co a' g_Triv) => h0.
    apply fv_tm_tm_tm_open_tm_wrt_co_upper in h0.
    apply AtomSetFacts.union_iff in h0.
    case:h0; eauto => h0.
    fsetdec.
    auto.
  - pick fresh x0.
    assert (Fl : x0 `notin` L). auto.
    assert (Fa : x `notin` fv_tm_tm_tm (open_tm_wrt_tm a (a_Var_f x0))).
    rewrite fv_tm_tm_tm_open_tm_wrt_tm_upper. auto.
    move: (H1 x0 Fl Fa) => h0.
    rewrite fv_tm_tm_tm_open_tm_wrt_tm_lower. eauto.
  - pick fresh x0.
    have na': x `notin` fv_tm_tm_tm A'. eauto.
    have nb: x `notin` fv_tm_tm_tm (open_tm_wrt_tm B (a_Var_f x0)).
    rewrite fv_tm_tm_tm_open_tm_wrt_tm_upper. eauto.
    have nob': x `notin` fv_tm_tm_tm (open_tm_wrt_tm B' (a_Var_f x0)). eauto.
    have nb': x `notin` fv_tm_tm_tm B'.
    rewrite fv_tm_tm_tm_open_tm_wrt_tm_lower. eauto.
    eauto.
  - pick_fresh c0.
    have: x `notin` fv_tm_tm_tm (open_tm_wrt_co a (g_Var_f c0)) => h0.
    apply fv_tm_tm_tm_open_tm_wrt_co_upper in h0.
    apply AtomSetFacts.union_iff in h0.
    case:h0; eauto => h0.
    simpl in h0.
    fsetdec.
    have K:= H1 c0 ltac:(auto) h0.
    move => h1.
    apply K. auto.
    apply fv_tm_tm_tm_open_tm_wrt_co_lower; auto.
  - pick fresh c0 for L.
    have: x `notin` fv_tm_tm_tm (open_tm_wrt_co a (g_Var_f c0)) => h0.
    apply fv_tm_tm_tm_open_tm_wrt_co_upper in h0.
    apply AtomSetFacts.union_iff in h0.
    case:h0; eauto => h0.
    simpl in h0.
    fsetdec.
    have h2: x `notin` fv_tm_tm_tm (open_tm_wrt_co a' (g_Var_f c0)). eauto.
    move: (fv_tm_tm_tm_open_tm_wrt_co_lower a' (g_Var_f c0)) => h3.
    have h4: x `notin` fv_tm_tm_tm a'. fsetdec.

    move => h1.
    apply AtomSetFacts.union_iff in h1.
    case: h1 => h1; eauto.
    apply AtomSetFacts.union_iff in h1.
    case: h1 => h1; eauto.
    fsetdec.
    fsetdec.
  - apply toplevel_closed in H.
    move: (Typing_context_fv H) => ?. split_hyp.
    simpl in *.
    fsetdec.
  -
    apply IHPar.
    pick fresh y.
    move: (H1 y ltac:(auto)) => h0.
    apply (fun_cong fv_tm_tm_tm) in h0.
    simpl in h0.
    move: (@fv_tm_tm_tm_open_tm_wrt_tm_lower a (a_Var_f y) x) => h1.
    move: (@fv_tm_tm_tm_open_tm_wrt_tm_upper a (a_Var_f y) x) => h2.
    unfold not. intro IN.
    assert (h3: x `in` (union (fv_tm_tm_tm b) (singleton y))). auto.
    rewrite -h0 in h3.
    apply h2 in h3.
    simpl in h3.
    destruct (AtomSetImpl.union_1 h3).
    assert (x `notin` singleton y). auto. done.
    done.
  - apply IHPar.
    pick fresh y.
    move: (H1 y ltac:(auto)) => h0.
    apply (fun_cong fv_tm_tm_tm) in h0.
    simpl in h0.
    move: (@fv_tm_tm_tm_open_tm_wrt_tm_lower a (a_Var_f y) x) => h1.
    move: (@fv_tm_tm_tm_open_tm_wrt_tm_upper a (a_Var_f y) x) => h2.
    unfold not. intro IN.
    assert (h3: x `in` (union (fv_tm_tm_tm b) empty)). auto.
    rewrite -h0 in h3.
    apply h2 in h3.
    simpl in h3.
    destruct (AtomSetImpl.union_1 h3).
    assert (x `notin` singleton y). auto. done.
    done.
  - apply IHPar.
    pick fresh y.
    move: (H1 y ltac:(auto)) => h0.
    apply (fun_cong fv_tm_tm_tm) in h0.
    simpl in h0.
    move: (@fv_tm_tm_tm_open_tm_wrt_co_lower a (g_Var_f y) x) => h1.
    move: (@fv_tm_tm_tm_open_tm_wrt_co_upper a (g_Var_f y) x) => h2.
    unfold not. intro IN.
    assert (h3: x `in` (union (fv_tm_tm_tm b) empty)). auto.
    rewrite -h0 in h3.
    apply h2 in h3.
    simpl in h3.
    destruct H0.
    apply AtomSetProperties.empty_union_1 in h3.
    auto. done.
Qed.
*)

Lemma reduction_in_Par : forall a a', reduction_in_one a a' -> forall G D, Par G D a a'.
Proof.
  induction 1; intros; try eauto using Value_lc.
Qed.

(*
See: reduction_in_one_lc in ext_red_one.

Lemma reduction_lc : forall a a', reduction_in_one a a' -> lc_tm a -> lc_tm a'.
*)

Lemma reduction_in_one_fv_preservation: forall x a b, reduction_in_one a b ->
                                        x `notin` fv_tm_tm_tm a ->
                                        x `notin` fv_tm_tm_tm b.
Proof.
  intros.
  eapply Par_fv_preservation; eauto.
  eapply reduction_in_Par; eauto.
  Unshelve. exact nil. exact {}.
Qed.

Lemma reduction_rhocheck : forall a a' rho x, reduction_in_one a a' -> RhoCheck rho x a -> RhoCheck rho x a'.
Proof.
  move=> a a' [] x Red RC.
  - inversion RC.  eauto using reduction_in_one_lc.
  - inversion RC.  eauto using reduction_in_one_fv_preservation.
Qed.

Lemma reduction_preservation : forall a a', reduction_in_one a a' -> forall G A, Typing G a A -> Typing G a' A.
Proof.
  (* TODO: clean and make more robust *)
  move=> a a' r.
  induction r.
  all: move=> G A_ tpga.
  - depind tpga; try eauto.
    + eapply E_Abs with (L := L `union` L0); try eassumption.
      all: move=> x xLL0.
      all: autofresh_fixed x.
      all: eauto using reduction_rhocheck.
  - depind tpga; subst; eauto.
  - depind tpga; subst; eauto.
  - depind tpga; subst; eauto.
  - apply invert_a_App_Rel in tpga.
      pcess_hyps.
      apply invert_a_UAbs in H1. pcess_hyps.
      autofresh. pcess_hyps.
      move: (E_PiFst _ _ _ _ _ _ _ H1) => xx1.
      eapply E_Conv; try eapply (E_Sym _ _ _ _ _ H3).
      rewrite  (tm_subst_tm_tm_intro x4); try fsetdec_fast.
      rewrite (tm_subst_tm_tm_intro x4 x0); try fsetdec_fast.
      eapply Typing_tm_subst.
      have x4_refl : DefEq ([(x4, Tm x1)] ++ G) (dom G) (a_Var_f x4) (a_Var_f x4) x.
      {
        eapply E_Refl; eapply E_Conv.
        - eauto.
        - eapply E_Sym in xx1.
          eapply DefEq_weaken_available.
          rewrite <- (app_nil_l [(x4, Tm x1)]).
          rewrite app_assoc.
          eapply DefEq_weakening; try reflexivity.
          + rewrite app_nil_l. eassumption.
          + simpl. eauto.
        - apply DefEq_regularity in xx1.
          apply PropWff_regularity in xx1.
          destruct xx1.
          rewrite <- (app_nil_l [(x4, Tm x1)]).
          rewrite app_assoc.
          eapply Typing_weakening; eauto.
      }
      have x4G: (Ctx (nil ++ [(x4, Tm x1)] ++ G)) by eauto.
      move: (DefEq_weakening H1 [(x4, Tm x1)] nil G eq_refl x4G) => H1w.
      rewrite app_nil_l in H1w.
      move: (E_PiSnd _ _ _ _ _ _ _ _ _ H1w x4_refl) => x0x2.
      eapply E_Conv.
      * eapply H4.
      * eapply DefEq_weaken_available.
        eapply (E_Sym _ _ _ _ _ x0x2).
      * apply DefEq_regularity in x0x2. by inversion x0x2.
      * eauto.
      * (* TODO: autoreg. *)
        apply DefEq_regularity in H3.
        by inversion H3.

  - apply invert_a_App_Irrel in tpga.
      pcess_hyps.
      apply invert_a_UAbs in H0; pcess_hyps.
      autofresh. pcess_hyps.
      move: (E_PiFst _ _ _ _ _ _ _ H0) => xx2.
      eapply E_Conv; try eapply (E_Sym _ _ _ _ _ H3).
      rewrite  (tm_subst_tm_tm_intro x5); try fsetdec_fast.
      rewrite tm_subst_tm_tm_fresh_eq; try done.
      rewrite -(tm_subst_tm_tm_fresh_eq (open_tm_wrt_tm v (a_Var_f x5)) x1 x5); try done.
      (*rewrite (tm_subst_tm_tm_intro x5); try fsetdec_fast.*)
      eapply Typing_tm_subst.
      have x5_refl : DefEq ([(x5, Tm x2)] ++ G) (dom G) (a_Var_f x5) (a_Var_f x5) x.
      {
        eapply E_Refl; eapply E_Conv.
        - eauto.
        - eapply E_Sym in xx2.
          eapply DefEq_weaken_available.
          rewrite <- (app_nil_l [(x5, Tm x2)]).
          rewrite app_assoc.
          eapply DefEq_weakening; try reflexivity.
          + rewrite app_nil_l. eassumption.
          + simpl. eauto.
        - apply DefEq_regularity in xx2.
          apply PropWff_regularity in xx2.
          destruct xx2.
          rewrite <- (app_nil_l [(x5, Tm x2)]).
          rewrite app_assoc.
          eapply Typing_weakening; eauto.
      }
      have x5G: (Ctx (nil ++ [(x5, Tm x2)] ++ G)) by eauto.
      move: (DefEq_weakening H0 [(x5, Tm x2)] nil G eq_refl x5G) => H1w.
      rewrite app_nil_l in H1w.
      move: (E_PiSnd _ _ _ _ _ _ _ _ _ H1w x5_refl) => x0x3.
      eapply E_Conv.
      * eassumption.
      * eapply DefEq_weaken_available.
        eapply (E_Sym _ _ _ _ _ x0x3).
      * apply DefEq_regularity in x0x3. by inversion x0x3.
      * eauto.
      * (* TODO: autoreg. *) inversion H6. assumption.
      * inversion H6. assumption.
      * erewrite <- tm_subst_tm_tm_intro. eauto. fsetdec.
      * apply DefEq_regularity in H2. by inversion H2.
  - apply invert_a_CApp in tpga; pcess_hyps.
    apply invert_a_UCAbs in H1; pcess_hyps.
    eapply E_Conv; try eapply (E_Sym _ _ _ _ _ H2). (* TODO: declare E_Sym's (and others') arguments implicit *)
    autofresh; pcess_hyps.
    move: (E_CPiFst _ _ _ _ _ _ H1) => iso.
    move: (E_Cast _ _ _ _ _ _ _ _ H2 iso) => x34.
    move: (E_CPiSnd _ _ _ _ _ _ _ _ _ _ H1 H2 x34) => x26.
    eapply E_Conv; try eapply (E_Sym _ _ _ _ _ x26).
    all: try (apply DefEq_regularity in H3; inversion H3; done).
    rewrite  (co_subst_co_tm_intro x8); try fsetdec_fast.
    rewrite (co_subst_co_tm_intro x8 x6); try fsetdec_fast.
    eapply Typing_co_subst.
    all: eauto.
  - apply invert_a_Fam in tpga; pcess_hyps.
    move: (binds_unique _ _ _ _ _ H H1 uniq_toplevel). inversion 1. subst x0 x.
    apply toplevel_closed in H.
    eapply E_Sym in H0.
    move: (DefEq_regularity H0) => reg; inversion reg.
    eapply Typing_Ctx in H7.
    eapply E_Conv; eauto.
    move: (Typing_weakening H G nil nil eq_refl).
    rewrite app_nil_l app_nil_r.
    by apply.
Qed.

(* ---- helper tactics for lemma below. -------------- *)

(* Convert a goal of the form  Par (XX ++ G) dom(XX ++ G) a b ==> Par G D a b *)
Ltac par_with_context_tail :=
  match goal with
  | _ : _ |- Par ([?s] ++ ?G ) (dom ([?s] ++ ?G)) ?a ?b =>
    eapply context_Par_irrelevance with (G1 := G) (D1 := dom G); eauto
  end.

Ltac ind_hyp a k1 k2 :=
  match goal with
    [ H : ∀ a' : tm, Ctx ?G → Par ?G ?D a a' → Typing ?G a' ?A ∧ DefEq ?G empty a a' ?A,
        H1 : Par ?G ?D a ?a',
        H2 : Ctx ?G |- _ ] =>
    move: (@H a' H2 H1) => [k1 k2]

  end.

Ltac ind_hyp_open x B k1 k2 :=
  match goal with
    [ H : forall x, x `notin` ?L -> forall a', Ctx ([(x, ?s)] ++ ?G) -> Par ([(x, ?s)] ++ ?G) ?D (open_tm_wrt_tm B (a_Var_f x)) a' -> ?P,
        H1 : Ctx ?G,
        H10 :  forall x : atom, x `notin` ?L0 → Par ?G ?D0 (open_tm_wrt_tm B (a_Var_f x)) (open_tm_wrt_tm ?B' (a_Var_f x))
                          |- _ ] =>
    move: (H x ltac:(auto) (open_tm_wrt_tm B' (a_Var_f x)) ltac:(auto)
                (context_Par_irrelevance ([(x, s)] ++ G) (dom ([(x,s)] ++ G)) (H10 x ltac:(auto)))) => [k0 k1]
      end.

(*

This lemma is not true in the presence of Eta-reduction in Par.
Instead, we should prove preservation for the head_reduction relation that
does not include eta.

(* Extend to D insteadn of just dom G??? *)
Lemma type_reduction_mutual:
  (forall G a A,     Typing G a A    ->
                forall a', Ctx G -> Par G (dom G) a a'-> Typing G a' A /\ DefEq G empty a a' A) /\
  (forall G phi,     PropWff G phi   -> forall A B T, Ctx G -> phi = Eq A B T ->
                                       (forall A' B' T', Par G (dom G) A A' -> Par G (dom G) B B' -> Par G (dom G) T T' ->
                                                    PropWff G (Eq A' B' T') /\ Iso G empty phi (Eq A' B' T'))) /\
  (forall G D p1 p2, Iso G D p1 p2   -> True) /\
  (forall G D A B T, DefEq G D A B T -> True) /\
  (forall G1,        Ctx G1 -> True).
*)

End  ext_red.


Set Implicit Arguments.
Require Import TLC.LibTactics.
Require Import TLC.LibIntTactics.
(* Load the CFML library, with time credits. *)
Require Import CFML.CFLibCredits.
Require Pervasives_ml.
Require Array_ml.
Require Import Pervasives_proof.
Require Import ArrayCredits_proof.
(* Load the big-O library. *)
Require Import Dominated.
Require Import UltimatelyGreater.
Require Import Monotonic.
Require Import LibZExtra.
(* Load the custom CFML tactics with support for big-Os *)
Require Import CFMLBigO.
Require Import Procrastination.Procrastination.
(* Load the CF definitions. *)
Require Import Sec6_example_ml.

Ltac auto_tilde ::= try solve [ auto with maths | false; math ].

Parameter g1_spec :
  specO unit_filterType eq
    (fun cost => app g1 [tt] PRE (\$ cost tt) POST (fun (_:unit) => \[]))
    (fun (_:unit) => 1).

Hint Extern 1 (RegisterSpec g1) => Provide (provide_specO g1_spec).

Parameter g2_spec :
  specO unit_filterType eq
    (fun cost => app g2 [tt] PRE (\$ cost tt) POST (fun (_:unit) => \[]))
    (fun (_:unit) => 1).

Hint Extern 1 (RegisterSpec g2) => Provide (provide_specO g2_spec).

Lemma f_spec :
  specZ [cost \in_O (fun n => n)]
    (forall (n: Z),
       0 <= n ->
       app f [n]
           PRE (\$ cost n)
           POST (fun (tt:unit) => \[])).
Proof.
  xspecO_refine recursive. intros costf ? ? ? n.

  induction_wf: (downto 1) n. intro N.
  xcf. weaken. xpay.
  xif_guard.
 { xret~. }
  { xapp. xapp. xapp~. }

  { generalize n N. defer. }
  close_cost.

  begin defer assuming a b.
  defer A: (0 <= a).
  exists (fun (n:Z_filterType) => a * n + b). split.
  { intros n N. cases_if; ring_simplify.
    - cut (1 <= b). math_nia. defer.
    - ring_simplify.
      cut (cost g1_spec tt + cost g2_spec tt + 1 <= a). admit.
      defer. }

  cleanup_cost.
  { monotonic. }
  { dominated. }

  end defer.
  simpl. exists (cost g1_spec tt + cost g2_spec tt + 1) 1.
  splits; auto with zarith.
Admitted.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C O Oprime Bprime Aprime : Universe, ((wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ Oprime O /\ (wd_ Oprime Bprime /\ (wd_ Oprime Aprime /\ (wd_ Bprime A /\ (wd_ Bprime C /\ (wd_ Aprime B /\ (wd_ Aprime C /\ (wd_ O A /\ (wd_ O B /\ (col_ Bprime O C /\ (col_ O Aprime Bprime /\ (col_ Aprime B C /\ (col_ Bprime A C /\ col_ O A B)))))))))))))))) -> col_ A B C)).
Proof.
  time tac.
Qed.

End FOFProblem.


(*Require Import HoTT.*)
(* -*- mode: coq; mode: visual-line -*-  *)
Local Set Typeclasses Strict Resolution.
Local Unset Elimination Schemes.
Global Set Keyed Unification.
Global Unset Refine Instance Mode.
Global Unset Strict Universe Declaration.
Global Unset Universe Minimization ToSet.

Notation idmap := (fun x => x).

Inductive Empty : Prop :=.

Scheme Empty_ind := Induction for Empty Sort Type.
Scheme Empty_rec := Minimality for Empty Sort Type.
Definition Empty_rect := Empty_ind.

Inductive Unit : Prop:= | tt:Unit.
Inductive Bool : Set := | true:Bool |false:Bool.
Fixpoint Fin (n : nat) : Set
  := match n with
       | 0 => Empty
       | S n => Fin n + Unit
     end.
Inductive paths {A : Type} (a : A) : A -> Type :=
  idpath : paths a a.

Arguments idpath {A a} , [A] a.

Scheme paths_ind := Induction for paths Sort Type.
Arguments paths_ind [A] a P f y p.
Scheme paths_rec := Minimality for paths Sort Type.
Arguments paths_rec [A] a P f y p.

(* See comment above about the tactic [induction]. *)
Definition paths_rect := paths_ind.

Notation "x = y :> A" := (@paths A x y) : type_scope.
Notation "x = y" := (x = y :>_) : type_scope.

Section somelogic.
(*Context (n:nat). Definition Var := Fin n.*)
(*Context (n:nat). (pv:(Fin n) = Var).*)
Definition Var := nat. (*Fin n.*)
(*Definition decpavar := decidable_paths_nat.!!*)

Notation num := idmap.
Notation mun := idmap.
(*Reset Var.
Reset decpavar.
Context {Var:Type}.
Context {decpavar:DecidablePaths Var}.
Context {num:nat->Var}.
Context {mun:Var->nat}.*)

Inductive Fm :=
 | jst  : Var -> Fm
 | nand : Fm -> (Fm -> Fm).

Coercion jst : Var >-> Fm.

(* ====== *)
Definition is_zero_eq_to
(n:nat)
: Bool
:= match n with
   | 0     => true
   | S n' => false
   end.

(*push_front the b to f:nat->B*)
Definition prepend
(B:Type) (tailm0 : nat -> B) (b : B) (n : nat)
:= match n with
   | 0     => b
   | S n0 => tailm0 n0
   end.

(*(2->A)->Q  <-> A->(A->Q) *)
Definition thm (A:Type)(Q:Type):(A->(A->Q)) -> ((Bool -> A) -> Q).
Proof.
intros f w.
exact (f (w false) (w true) ).
Show Proof.
Defined.

Reset thm.
Definition thm (A:Type)(Q:Type):(A->(A->Q)) -> (Bool->A)->Q
:=(fun (f : A -> A -> Q) (w : Bool -> A) => f (w false) (w true)).

Definition mht (A:Type)(Q:Type):((Bool->A)->Q) -> (A->(A->Q)).
Proof.
intros h y0 y1.
refine (h _).
intro b.
destruct b.
exact y0.
exact y1.
Show Proof.
Defined.
Reset mht.

Definition mht (A:Type)(Q:Type):((Bool->A)->Q) -> (A->(A->Q)) :=
(fun (h : (Bool -> A) -> Q) (y0 y1 : A) =>
 h (fun b : Bool => if b then y0 else y1)).

Fixpoint power (X Y : Type) (n:nat): Type.
Proof.
destruct n.
exact Y.
exact (X->(power X Y n)).
Show Proof.
Defined.

Reset power.

Definition powern (X Y : Type) : nat -> Type
:= (fix power (n : nat) {struct n} : Type :=
   match n with
   | 0 => Y
   | S n0 => X -> power n0
   end).

Fixpoint thm2 (A:Type)(Q:Type)(n:nat):(powern A Q n) -> ((Fin n->A)->Q).
Proof.
intros f w.
destruct n.
unfold powern in f.
exact f.
unfold powern in f.
unfold Fin in w.
refine (thm2 A Q n (f (w (inr tt))) (fun x => w (inl x)) ).
Show Proof.
Defined.
Reset thm2.

Definition thm2 (A:Type)(Q:Type) : forall (n:nat), (powern A Q n) -> ((Fin n->A)->Q) :=
(fix thm2 (n : nat) (f : powern A Q n) (w : Fin n -> A) {struct n} : Q :=
   match n as n0 return (powern A Q n0 -> (Fin n0 -> A) -> Q) with
   | 0 => fun (f0 : powern A Q 0) (_ : Fin 0 -> A) => f0
   | S n0 =>
       fun (f0 : powern A Q (S n0)) (w0 : Fin (S n0) -> A) =>
       thm2 n0 (f0 (w0 (inr tt))) (fun x : Fin n0 => w0 (inl x))
   end f w).

Fixpoint mht2 (A:Type)(Q:Type)(n:nat):((Fin n->A)->Q) -> (powern A Q n).
Proof.
intros h.
destruct n.
exact (h (Empty_ind (fun _ => A))).
simpl.
intro a.
refine (mht2 A Q n _).
intro g.
refine (h _).
intro w.
destruct w.
exact (g f).
exact a.
Show Proof.
Defined.
Reset mht2.

Definition mht2 (A Q : Type) :=
(fix mht2 (n : nat) (h : (Fin n -> A) -> Q) {struct n} :
 powern A Q n :=
   match n as n0 return (((Fin n0 -> A) -> Q) -> powern A Q n0) with
   | 0 => fun h0 : (Fin 0 -> A) -> Q => h0 (Empty_rect (fun _ : Empty => A))
   | (S n0) =>
       fun (h0 : (Fin (S n0) -> A) -> Q) (a : A) =>
       mht2 n0
         (fun g : Fin n0 -> A =>
          h0 (fun w : Fin (S n0) => match w with
                                   | inl f => g f
                                   | inr _ => a
                                   end))
   end h).

(*need some examples*)

Check powern nat Bool 2.
Eval compute in powern nat Bool 2.

(*Eval compute in thm2 n nat nat*)

(*noname function*)
(*bottom prepend of falses to 2D tabular*)
Definition bottom_false_prep (tail : nat -> (nat -> Bool)) (m0 : nat)
:= prepend Bool (tail m0) false.

(*"addcornerbooltruefalse tail" is 2d prepend of falses to left and bottom of domain of
[un?]curried version of tail with single "true" in the corner (0,0)
Definition addcornerbooltruefalse (tail : nat -> (nat -> Bool)) (x : nat): nat -> Bool :=
 match x with
 | 0 => is_zero_eq_to
 | x0.+1 => bottom_false_prep tail x0
 end.
*)

Definition valatzero (B:Type) (others atzero : B)
(n:nat)
: B
:= match n with
   | 0     => atzero
   | S n' => others
   end.

Definition addcorner (B:Type) (others diags : B) (tail : nat -> (nat -> B))
(x : nat): nat -> B :=
 match x with
 | 0 => valatzero B others diags
 | S x0 => prepend B (tail x0) others
 end.

(* Calculate function "code_n" that is stable under action of "addcorner":
"code_n" defines an 2d half-infinty matrix as a stable under "addcorner"
action. It's diagonal matrix with "true" on diagonal and "false" otherwise.
Value on all diagonals are the same and determined by border. *)

(* aim:
Definition diagonal (A B:Type) (u d:B)
: A -> A -> B.*)

Definition diagonal (B:Type) (others diags : B)
: nat -> (nat -> B)
:= fix yy (m:nat) {struct m} := (addcorner B others diags yy m).

Definition code_n := diagonal Bool false true .

Check thm2 nat Bool 2 code_n.

Definition test01 := mht2 nat Bool 2 (thm2 nat Bool 2 code_n).

Eval compute in test01. (*error!*)
Eval compute in test01 1 1.

Eval compute in mht2 nat Bool 2 (thm2 nat Bool 2 code_n).

(*
Definition code_n
: nat -> nat -> Bool
:= fix code_n (m:nat) {struct m} := (addcornerbooltruefalse code_n m).
*)

Eval compute in code_n 0 0.
Eval compute in code_n 0 1.
(*Eval compute in code_n 34759 34759. MAX *)

(*It is usefull theorem, because not all terms are equally good with "fix".
It may also be useful with S1.*)
Definition code_n_eq_helper
(hlp : forall (v1 : nat), code_n v1 v1 = true) (v : nat)
: (code_n v v = true)
:=
  match v as v2 return (code_n v2 v2 = true) with
  | 0 => idpath true
  | S v0 => hlp v0
  end.

(*Counterexample.
Definition code_n_eq_helper2
(hlp : forall (v1 : nat), code_n v1 v1 = true) (v : nat)
: (code_n v v = true)
:= hlp v.
*)

Definition code_n_eq
: forall v : nat, code_n v v = true
:=
fix code_n_eq (v : nat) : code_n v v = true
:= code_n_eq_helper code_n_eq v.

Definition orb (a b : Bool) : Bool :=
match a with
| true => true
| false => b
end.

Definition check_help
(fm : Fm ) (m:Var) (qqq: Fm -> Var -> Bool)
: Bool
:=
   match fm with
   | jst v => code_n m v
   | nand m1 m2 => (orb (qqq m1 m) (qqq m2 m))
   end.

Definition check_help_eq
(qqq: Fm -> Var -> Bool) (m:Var)
:  check_help (jst m) m qqq = true
:= (code_n_eq m).

(* 'true' if there exist a variable 'm' in formula 'fm'*)
Definition check
: forall (fm : Fm ) (m:Var), Bool
:= fix checkfix (fm : Fm ) (m:Var) : Bool
:= check_help fm m checkfix.

(*there exist variable 'h' in trivial formula 'jst h'*)
Definition check_eq
(fm : Fm ) (m:Var)
: check m m  = true
:= code_n_eq m.

Definition bool_to_nat
(b:Bool)
: nat
:= match b with
   | true  => 1
   | false => 0
   end.

Definition bool_to_prop
(b:Bool)
: Prop
:= match b with
   | true  => Unit
   | false => Empty
   end.

Definition composition (A B C:Type) (f:A->B) (g:B->C) (a:A) := g (f a).

Definition add : nat -> nat -> nat :=
fix add (m : nat) : nat -> nat :=
match m with
| 0 => idmap
| S m' => composition _ _ _ S (add m')
end.

(* ok
Definition add : nat -> nat -> nat :=
fix add (m n : nat) : nat :=
match m with
| 0 => n
| S m' => S (add m' n)
end.
*)

(*Calculate ... *)
Definition accumulate_helper
(hlp: forall (q:nat->nat) (m:nat), nat) (q:nat->nat) (m:nat)
: nat
:= match m with
   | 0 => q 0
   | S m0 => (add (q (S m0)) (hlp q m0))%nat
   end.

Definition accumulate
: forall (q:nat->nat) (m:nat), nat
:= (fix acc (q:nat->nat) (m:nat) : nat
:= accumulate_helper acc q m).

(* Number of placeholders in formula. Higher bound of amount of variables.*)
Fixpoint Count
(fm : Fm )
: nat
:=match fm with
  | jst _ => 1
  | nand m1 m2 => (add (Count m1) (Count m2))%nat
  end.

Section ss00.
Context (fm:Fm).
(*dme(n) = 1 if there exist a variable v in formula 'fm', such that num(v) = n
         = 0 otherwise. dme = "does [n-th variable] merely exist?" *)
Definition dme : nat->nat := fun n => bool_to_nat (check fm (num n)).
Definition calcFIN (m:nat) : nat := accumulate dme m.
End ss00.

Fixpoint mneqsm
(m:nat)
: code_n m (S m) = false
:= match m with
   | 0 => idpath
   | S m0 => mneqsm m0
   end.

Fixpoint mneqsm2
(m:nat)
: code_n (S m) m = false
:= match m with
   | 0 => idpath
   | S m0 => mneqsm2 m0
   end.

(*(1 = QQ a b) iff (a<b)*)
Definition QQ (m:nat) := (fix acc (m0 : nat) : nat :=
   match m0 with
   | 0 => 0
   | S m1 => (add (if code_n m1 m then 1 else 0) (acc m1))%nat
   end).

Eval compute in (QQ 0 1).

Fixpoint code_n_eq'
(v : nat)
: (code_n v v) = true
:= match v with
   | 0     => @idpath Bool true
   | S v0 => code_n_eq' v0
   end.

Definition f (m:nat) := (fix acc (m0 : nat) : nat :=
   match m0 with
   | 0 => 0
   | S m1 => (add (if code_n m1 m then 1 else 0) (acc m1))%nat
   end).

Definition dou (qf : nat -> nat -> nat) (m:nat) := qf m m.

Definition impprf  (p1: forall (m:nat), 0 = dou f m) (w:nat): (0 = dou f (S w)) := (p1 (S w)).

Definition b11_f : Bool -> (Unit + Unit) :=
 (fun b => match b with
           | false => inl tt
           | true  => inr tt
           end).

Definition b11_invf : (Unit + Unit) -> Bool :=
 (fun uu => match uu with
            | inl _ => false
            | inr _ => true
            end).

Definition Sect {A B : Type} (s : A -> B) (r : B -> A) :=
  forall x : A, r (s x) = x.

Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y
  := match p with idpath => idpath end.

Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv {
  equiv_inv : B -> A ;
  eisretr : Sect equiv_inv f;
  eissect : Sect f equiv_inv;
  eisadj : forall x : A, eisretr (f x) = ap f (eissect x)
}.

Definition b11_f_sect : Sect b11_f b11_invf :=
 (fun x : Bool => if x as b return (b11_invf (b11_f b) = b)
                  then idpath true
                  else idpath false).

Definition b11_invf_sect : Sect b11_invf b11_f :=
 (fun x : Unit + Unit =>
 match x as s return (b11_f (b11_invf s) = s) with
 | inl u =>
     match u return (b11_f (b11_invf (inl u)) = inl u) with
     | tt => idpath (inl tt)
     end
 | inr u =>
     match u return (b11_f (b11_invf (inr u)) = inr u) with
     | tt => idpath (inr tt)
     end
 end).

Definition b11_adj (x : Bool) :
 b11_invf_sect (b11_f x) = ap b11_f (b11_f_sect x) :=
 match x as b return (b11_invf_sect (b11_f b) = ap b11_f (b11_f_sect b)) with
 | true  => @idpath (inr tt = inr tt) (@idpath (Unit+Unit) (inr tt))
 | false => @idpath (inl tt = inl tt) (@idpath (Unit+Unit) (inl tt))
 end.

Definition b11_f_equi : IsEquiv b11_f :=
 @BuildIsEquiv Bool (Unit+Unit) b11_f b11_invf b11_invf_sect b11_f_sect b11_adj.

Record Equiv A B := BuildEquiv {
  equiv_fun : A -> B ;
  equiv_isequiv : IsEquiv equiv_fun
}.

Definition b11_iso : Equiv Bool (Unit + Unit) :=
 @BuildEquiv Bool (Unit+Unit) b11_f b11_f_equi.

Definition path_sum {A B : Type} (z z' : A + B)
           (pq : match z, z' with
                   | inl z0, inl z'0 => z0 = z'0
                   | inr z0, inr z'0 => z0 = z'0
                   | _, _ => Empty
                 end)
: z = z'.
  destruct z, z'.
  all:try apply ap, pq.
  all:elim pq.
Defined.

Definition path_sum_inv {A B : Type} {z z' : A + B}
           (pq : z = z')
: match z, z' with
    | inl z0, inl z'0 => z0 = z'0
    | inr z0, inr z'0 => z0 = z'0
    | _, _ => Empty
  end
  := match pq with
       | idpath => match z with
                | inl _ => idpath
                | inr _ => idpath
              end
     end.

Definition inl_ne_inr {A B : Type} (a : A) (b : B)
: (inl a = inr b) -> Empty
:= path_sum_inv.

Definition inr_ne_inl {A B : Type} (b : B) (a : A)
: (inr b = inl a) -> Empty
:= path_sum_inv.

(** This version produces only paths between closed terms, as opposed to paths between arbitrary inhabitants of sum types. *)
Definition path_sum_inl {A : Type} (B : Type) {x x' : A}
: inl x = inl x' -> x = x'
  := fun p => @path_sum_inv A B _ _ p.

Definition path_sum_inr (A : Type) {B : Type} {x x' : B}
: inr x = inr x' -> x = x'
  := fun p => @path_sum_inv A B _ _ p.

(** This lets us identify the path space of a sum type, up to equivalence. *)

Definition eisretr_path_sum {A B} {z z' : A + B}
: Sect (@path_sum_inv _ _ z z') (path_sum z z')
  := fun p => match p as p in (_ = z') return
                    path_sum z z' (path_sum_inv p) = p
              with
              | idpath => match z as z return
                             path_sum z z (path_sum_inv idpath) = idpath
                       with
                         | inl _ => idpath
                         | inr _ => idpath
                       end
              end.

Definition eissect_path_sum {A B} {z z' : A + B}
: Sect (path_sum z z') (@path_sum_inv _ _ z z').
Proof.
  intro p.
  destruct z, z', p; exact idpath.
Defined.

Global Instance isequiv_path_sum {A B : Type} {z z' : A + B}
: IsEquiv (path_sum z z') | 0.
Proof.
  refine (BuildIsEquiv _ _
                       (path_sum z z')
                       (@path_sum_inv _ _ z z')
                       (@eisretr_path_sum A B z z')
                       (@eissect_path_sum A B z z')
                       _).
  destruct z, z';
    intros [];
    exact idpath.
Defined.

Definition equiv_path_sum {A B : Type} (z z' : A + B)
  := BuildEquiv _ _ _ (@isequiv_path_sum A B z z').

Definition smuzi : (Equiv (Empty) (inl tt = inr tt)) :=
 @equiv_path_sum Unit Unit (inl tt) (inr tt).

Definition eqv : (false = true) -> (inl tt = inr tt) :=
 (fun p : false = true => ap b11_f p).

Definition agag : (Empty -> (inl tt = inr tt)) :=
 @equiv_fun Empty (inl tt = inr tt) smuzi.

Definition gaga : ((inl tt = inr tt) -> Empty) := inl_ne_inr tt tt.
(* @equiv_inv Empty (inl tt = inr tt) agag (equiv_isequiv smuzi).*)

Definition impos : (false = true) -> Empty :=
 (fun p:(false = true) =>  (gaga (eqv p))).

Definition ururu {n}: (code_n (S n) 0 = true) -> Empty := impos.

Definition smth (n:nat) : (code_n n 0 = true -> n = 0) :=
 match n as n0 return (code_n n0 0 = true -> n0 = 0) with
       | 0 => fun _ : code_n 0 0 = true => idpath
       | S n0 =>
           fun H : code_n (S n0) 0 = true =>
           match (impos H) return ((S n0) = 0) with end
       end.
Reset smth.

(*Definition smth (n : nat) (H : code_n n 0 = true) : (n = 0) :=
 match n as n0 return (n0 = 0) with
       | 0 => idpath
       | n0.+1 => match (impos H) return (n0.+1 = 0) with end
       end.*)

Definition smth (n:nat) : (code_n n 0 = true -> n = 0) :=
 match n as n0 return (code_n n0 0 = true -> n0 = 0) with
       | 0 => fun _ : code_n 0 0 = true => idpath
       | S n0 =>
           fun H : code_n (S n0) 0 = true =>
           match (impos H) return ((S n0) = 0) with end
       end.

(*Everything may be proved
1)Using 'Definition'
2)with only one 'match'

Every closed term is a separate theorem.
There exist a smallest proof of theorem.
Every theorem must have meaningful name.
*)

Definition path_n_helper (n m0 : nat)
(hlp : forall (n m : nat), ((code_n n m) = true ) -> (n = m) ) :=
match n as n0 return (code_n n0 (S m0) = true -> n0 = (S m0)) with
       | 0 =>
           fun y : code_n 0 (S m0) = true =>
           match impos y return (0 = (S m0)) with end
       | S n0 => fun y : code_n (S n0) (S m0) = true => ap S (hlp n0 m0 y)
       end.

Definition path_n : forall (n m : nat), ((code_n n m) = true ) -> (n = m) :=
(fix path_n (n m : nat) {struct m} :=
   match m as n0 return (code_n n n0 = true -> n = n0) with
   | 0 => smth n
   | S m0 => path_n_helper n m0 path_n
   end).
(*
What is analogue of "firstorder"?
We need an algorithm for automatic solving of first-order formulas.
*)

Definition testw: (true = true) <-> (0 = 0) :=
(fun _ : true = true =>  idpath 0, fun _ : 0 = 0 => idpath true).

Definition invpath {A:Type} {x y: A} (p: x = y) : (y = x)
:= match p with
   | idpath => idpath
   end.

Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y :=
  match p with idpath => u end.

Definition exfalso
(m : nat) (natpath : (S m) = 0)
: False
:= (transport (fun n=>match n with |0 => Unit |_=>False end) (invpath natpath) tt).

Definition invS
(n:nat)
: nat
:= match n with 0 => 0 | S n => n end.

Definition invaps
(m n:nat) (p:S m = S n)
: (m = n)
:= (ap invS p).

Definition uselessthing
(m0 : nat) (y : false = true)
: ((S m0) = 0)
:= match impos y return ((S m0) = 0) with end.

Definition ut2
(m0 : nat) (y : (S m0) = 0)
: false = true
:=match exfalso m0 y return (false = true) with end.

Definition niop
(m0 : nat)
: (false = true -> (S m0) = 0) * ((S m0) = 0 -> false = true)
:= (uselessthing m0, ut2 m0).
Check niop.

(*Definition niop
(m0 : nat)
:= (fun y : false = true =>
         match impos y return (m0.+1 = 0) with end,
        fun y : m0.+1 = 0 =>
        match exfalso m0 y return (false = true) with end).*)

Definition muss
(m0 n1 : nat)
(IHm : forall n0 : nat, code_n m0 n0 = true <-> m0 = n0)
: code_n m0 n1 = true -> (S m0) = (S n1)
:= fun qe : code_n m0 n1 = true => ap S (fst (IHm n1) qe).

Definition muss2
(m0 n1 : nat)
(IHm : forall n0 : nat, code_n m0 n0 = true <-> m0 = n0)
(qe : (S m0) = (S n1))
: code_n m0 n1 = true
:= snd (IHm n1) (invaps m0 n1 qe).

Definition gnd
(m0 n1 : nat) (IHm : forall n0 : nat, code_n m0 n0 = true <-> m0 = n0)
: (code_n m0 n1 = true) <-> ((S m0) = (S n1))
:= (muss m0 n1 IHm, muss2 m0 n1 IHm ).

Definition alin
(m0 : nat) (IHm : forall n0 : nat, code_n m0 n0 = true <-> m0 = n0) (n0 : nat)
: (code_n (S m0) n0 = true) <-> ((S m0) = n0)
:=  match n0 as n1 return (code_n (S m0) n1 = true <-> (S m0) = n1) with
    | 0 => niop (m0)
    | (S n1) => gnd m0 n1 IHm
    end.

(* What is "destruct f" when f is a function? *)
Definition agad
(n : nat)
: code_n 0 n = true <-> 0 = n
:=  match n with
    | 0 => (fun _ : true = true => idpath, fun _ : 0 = 0 => idpath)
    | (S n1) =>
        (fun y : false = true => match (impos y) with end,
        fun y : 0 = (S n1) => match (exfalso n1 (invpath y)) with end)
    end.

Check agad.

Definition gula := (fun m0 : nat => forall n0 : nat, code_n m0 n0 = true <-> m0 = n0).

Definition code_n_eqk (m n : nat ) : (code_n m n) = true <-> m = n
:= nat_rect gula agad alin m n.
(*
Lemma old_code_n_eqk m n :
  (code_n m n) = true <-> m = n.
Proof.
revert n; induction m; destruct n.
simpl.
try easy.
unfold code_n.
refine (_,_).
intro y.
destruct (impos y).
intro y.
destruct (exfalso n ((invpath y))).
unfold code_n.
refine (_,_).
intro y.
destruct (impos y).
intro y.
destruct (exfalso m (y)).
simpl.
refine (_,_).
intro qe.
exact (ap S ((fst (IHm n)) qe)).
simpl.
intro qe.
Eval compute in invaps m n qe.
exact (snd (IHm n) (invaps m n qe)).
Show Proof.
Defined.*)

(*Eval compute in ap invS qe.
exact (ap invS ((snd (IHm n)) qe)).
unfold code_n.
simpl.
Show Proof.
contradiction.
exfalso.
try easy.
reflexivity.
 try easy; firstorder.
Admitted.*)

Inductive compare :=
| less : compare
| equal : compare
| greater : compare.

Fixpoint compa (a b : nat) : compare :=
match a, b with
| 0,0 => equal
| S x, 0 => greater
| 0, S y => less
| S x, S y => compa x y
end.

(*a>=b*)
Definition gre (a b : nat) : Prop :=
match compa a b with
| equal => Unit
| greater => Unit
| less => Empty
end.

(*Fixpoint gre a b :=
match a, b with
| 0,0 => true
| S x, S y => gre x y
| S x, 0 => true
| 0, S y => false
end.*)

Print f.

Definition downgre (m n : nat) (x:gre (S m) (S n)): gre m n := x.

Definition bnot (b:Bool) : Bool :=
match b with
|true => false
|false => true
end.

Definition pnot (A:Prop) := A->Empty.

Definition notcommute (b:Bool) : (bool_to_prop (bnot b))-> (pnot (bool_to_prop b)).
Proof.
destruct b; simpl.
intro q; destruct q.
unfold pnot.
intro t; exact idmap.
Defined.

(*Fixpoint qwerty (m n : nat) : gre m n ->  pnot (bool_to_prop (code_n n (S m))).*)

Fixpoint qwerty (m n : nat) : gre m n -> bool_to_prop (bnot (code_n n (S m))).
Proof.
intro x.
destruct m, n; simpl.
exact tt.
destruct x.
exact tt.
simpl.
exact (qwerty m n x).
Defined.

(* generalize what we want to prove (x : gre (S m) (S n))*)
Lemma gte m n :
  (gre m n) -> f m n = 0.
Proof.
revert m; induction n; destruct m; simpl.
exact (fun _=> idpath).
exact (fun _=> idpath).
intro x.
destruct x.
intro x.
pose (qwerty m n x).

(*change (code_n n (S m)) with (Z.abs (' yd)).
apply (IHn m).
exact idpath.
simpl in gre.
destruct m, n; simpl.*)
Admitted.
(*  try easy.
  intro q.
  reflexivity.
  simpl.
  intro emp.
  destruct emp.
  intro yu.
  Check code_n_eq.
  unfold f.
  Print code_n.
  unfold code_n.

  destruct f.
Admitted.*)
(*  reflexivity.
  simpl.
  destruct yu.
  destruct (code_n n (S m)).
  try easy.

  revert m; induction n; destruct m; try easy; firstorder.
  simpl. destruct (code_n n (S m)) eqn:E.
  - apply code_n_eq in E; omega.
  - assert (m >= n) by omega. rewrite IHn; auto.
Admitted.*)

Fixpoint gre_refl (m:nat) : gre m m.
destruct m.
exact tt.
simpl.
exact (gre_refl m).
Defined.

Fixpoint impprf4 (m:nat): f m m = 0. (*Lemma*)
Proof.
apply gte.
apply gre_refl.
Defined.

(*Proof.
  revert n; induction m; destruct n.
   try easy.
   firstorder.
easy.*)

Fixpoint impprf2 (m:nat) : (0 = dou f m).
Proof.
unfold f.
unfold dou.
destruct m.
reflexivity.
destruct m.
reflexivity.
(*exact ((impprf impprf2) m).
Defined.*)
Admitted.

(*Fixpoint impprf (m:nat) (p1: 0 = dou f m) :( 0 = dou f (S m)).
destruct m.
exact (impprf (0) p1). (*reflexivity.*)
exact (impprf (S m) p1).
Defined.

Fixpoint impprf (m:nat) : (dou f m = 0) = dou f (S m).
unfold f.
unfold dou.
compute.

destruct f.
exact 0.
exact 0.
exact (impprf m).
exact (impprf m).
Defined.
unfold dou.

Fixpoint impprf (m:nat): f m m = f (S m) (S m).*)

Fixpoint impprfWUT (m:nat)
: (fix acc (m0 : nat) : nat :=
   match m0 with
   | 0 => 0
   | S m1 => (add (if code_n m1 m then 1 else 0) (acc m1))%nat
   end) m = 0.
Proof.
Admitted.

(*
destruct m; reflexivity.

revert m.
apply happly.
refine
Check happly.
destruct m.
reflexivity.*)

Fixpoint thmhz (m:nat) : calcFIN (jst (S m)) (S m) = calcFIN (jst m) m.
Proof.
unfold calcFIN.
unfold dme.
unfold check.
unfold check_help.
unfold accumulate.
unfold bool_to_nat.

destruct m.
reflexivity.
simpl.
(*exact (thmhz m).*)
Admitted.

Fixpoint calcFIN_eq (m:nat) : calcFIN (jst m) m = 1.
Proof.
(**)
unfold calcFIN.
unfold dme.
unfold check.
unfold check_help.
unfold accumulate.
unfold bool_to_nat. (**)
destruct m.
compute.
reflexivity.
simpl.
pose (invpath (code_n_eq m)) as vv.
destruct vv.
simpl.
refine (ap S _). (*OK*)

destruct m.
reflexivity.

pose ((if code_n m m then 1 else 0) = 1) as ww.
change (if code_n m m then 1 else 0) with 1%nat.

(*refine ((thmhz m) @ _).
exact (calcFIN_eq m).
Defined.*)
Admitted.

Fixpoint max (a b: nat) : nat :=
match a, b with
| 0, 0 => 0
| S a, 0 => S a
| 0, S b => S b
| S a, S b => S (max a b)
end.

Definition maximal_help (f:Fm->nat) (fm : Fm )
: nat
:= match fm with
   | jst v => mun v
   | nand m1 m2 => max (f m1) (f m2)
   end.

Fixpoint maximal (fm : Fm )
: nat
:= maximal_help (maximal) fm.

Definition calcINF (fm : Fm)
: nat
:= calcFIN fm (maximal fm).

End somelogic.

Eval compute in calcFIN (jst 1) 3.

Context (v:Var).
Eval compute in maximal (jst v).

(*
Eval compute in decpavar 0 0.
Eval compute in decpavar 0 1.
Eval compute in decpavar 1 1.

Eval simpl in code_nat v v.
Eval compute in code_nat v v.
*)

(*Theorem q:Bool.
set (g := (fix code_n (m n : nat) {struct m} : Bool :=
       match m with
       | 0 =>
           match n with
           | 0 => true
           | n'.+1 =>false
           end
       | m'.+1 =>
           match n with
           | 0 => false
           | n'.+1 => code_n m' n'
           end
       end) v v).
cbv beta in g.
cbv delta in g.
cbv iota in g.
cbv zeta in g.*)

(*delta G.
cbv delta g.
Eval rewrite -> true in g.
Print Strategies.
(*Extraction g.*)
Eval vm_compute in g.
Eval compute in code_nat 1 1.
Eval compute in dhprop_hprop (code_nat v v).
Eval compute in (decpavar v v).
Eval compute in check (jst v) v. (*=1*)
Eval compute in dme (jst v) v. (*=1*)
Eval compute in (calcFIN v 1).
*)

Fixpoint one (v:Var) : 1 = (calcFIN v v).
destruct v.
reflexivity.
Admitted.
(*exact (one v0).
Defined.

unfold calcFIN.
unfold accumulate.
unfold dme.

set (ku := (calcINF v)).
compute in ku.
simpl in ku.
simpl.
reflexivity.
identity.*)

(*Let's construct the function Bool^n -> Bool*)

Definition na_not (X:Fm) := nand (X) (X).
Definition na_true (X:Var) := nand (X) (na_not X).
Definition na_false (X:Var) := na_not (na_true X).

Fixpoint decons (m:nat) :((Fin m -> Bool) -> Bool) -> Fm.
Proof.
intros h.
destruct m.
destruct (h (Empty_rec Bool)).

Check h (Empty_rec Bool).

Print Var.
refine (jst (h _)).
Print Fm.

unfold Fm.

Fixpoint cons (fm:Fm) : ((Fin (calcINF fm) -> Bool) -> Bool).
Proof.
destruct fm as [v|fm1 fm2].
set (ku := (calcINF v)).
simpl in ku.
compute in ku.
Admitted.

Check @calcINF.
Eval simpl in maximal (nand (jst 1) (jst 2)).
Eval compute in maximal (*nat idmap*) (nand (jst 3) (nand (jst 3) (jst 2))).
Eval compute in calcFIN (jst 1) 3.
Eval compute in calcFIN (*nat decidable_paths_nat idmap*) (nand (jst 3) (nand (jst 3) (jst 2))) 3.
Eval compute in @calcINF (*nat decidable_paths_nat idmap idmap*) (nand (jst 3) (nand (jst 3) (jst 2))).

(*
Definition decidable_paths_nat : DecidablePaths nat.

 exact (fun n m => decidable_equiv _ (@path_nat n m) _).
Show Proof.
*)