(* SNU 4190.310, 2016 Spring *)

(** Assignment 07 *)
(** Due: 2016/11/31 23:59 *)

(* Important:
   - Do NOT import other files.

   - You are NOT allowed to use the [admit] tactic.

   - You are ALLOWED to use any tactics including:
     [tauto], [intuition], [firstorder], [omega].

   - Just leave [exact FILL_IN_HERE] for those problems that you fail to prove.
*)

Require Export Coq.Arith.Arith.
Require Export Coq.Bool.Bool.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Coq.Arith.EqNat.
Require Export Coq.omega.Omega.
Require Export Coq.Lists.List.
Import ListNotations.
Require Export Basics.
Require Export Maps.
Require Export Imp.

Definition FILL_IN_HERE {T: Type} : T.  Admitted.

Inductive id : Type :=
  | Id : nat -> id.

Definition beq_id id1 id2 :=
  match id1,id2 with
    | Id n1, Id n2 => beq_nat n1 n2
  end.

Definition total_map (A:Type) : Type := id -> A.

Definition t_empty {A:Type} (v : A) : total_map A :=
  (fun _ => v).

Definition t_update {A:Type} (m : total_map A)
                    (x : id) (v : A) :=
  fun x' => if beq_id x x' then v else m x'.

Definition state := total_map nat.

Definition empty_state : state :=
  t_empty 0.

Inductive aexp : Type :=
  | ANum : nat -> aexp
  | AId : id -> aexp                (* <----- NEW *)
  | APlus : aexp -> aexp -> aexp
  | AMinus : aexp -> aexp -> aexp
  | AMult : aexp -> aexp -> aexp.

Definition X : id := Id 0.
Definition Y : id := Id 1.
Definition Z : id := Id 2.

Inductive bexp : Type :=
  | BTrue : bexp
  | BFalse : bexp
  | BEq : aexp -> aexp -> bexp
  | BLe : aexp -> aexp -> bexp
  | BNot : bexp -> bexp
  | BAnd : bexp -> bexp -> bexp.

Fixpoint aeval (st : state) (a : aexp) : nat :=
  match a with
  | ANum n => n
  | AId x => st x                                (* <----- NEW *)
  | APlus a1 a2 => (aeval st a1) + (aeval st a2)
  | AMinus a1 a2  => (aeval st a1) - (aeval st a2)
  | AMult a1 a2 => (aeval st a1) * (aeval st a2)
  end.

Fixpoint beval (st : state) (b : bexp) : bool :=
  match b with
  | BTrue       => true
  | BFalse      => false
  | BEq a1 a2   => beq_nat (aeval st a1) (aeval st a2)
  | BLe a1 a2   => leb (aeval st a1) (aeval st a2)
  | BNot b1     => negb (beval st b1)
  | BAnd b1 b2  => andb (beval st b1) (beval st b2)
  end.

Inductive com : Type :=
  | CSkip : com
  | CAss : id -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com.

Notation "'SKIP'" :=
  CSkip.
Notation "x '::=' a" :=
  (CAss x a) (at level 60).
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'IFB' c1 'THEN' c2 'ELSE' c3 'FI'" :=
  (CIf c1 c2 c3) (at level 80, right associativity).

Reserved Notation "c1 '/' st '\\' st'"
                  (at level 40, st at level 39).

Inductive ceval : com -> state -> state -> Prop :=
  | E_Skip : forall st,
      SKIP / st \\ st
  | E_Ass  : forall st a1 n x,
      aeval st a1 = n ->
      (x ::= a1) / st \\ (t_update st x n)
  | E_Seq : forall c1 c2 st st' st'',
      c1 / st  \\ st' ->
      c2 / st' \\ st'' ->
      (c1 ;; c2) / st \\ st''
  | E_IfTrue : forall st st' b c1 c2,
      beval st b = true ->
      c1 / st \\ st' ->
      (IFB b THEN c1 ELSE c2 FI) / st \\ st'
  | E_IfFalse : forall st st' b c1 c2,
      beval st b = false ->
      c2 / st \\ st' ->
      (IFB b THEN c1 ELSE c2 FI) / st \\ st'
  | E_WhileEnd : forall b st c,
      beval st b = false ->
      (WHILE b DO c END) / st \\ st
  | E_WhileLoop : forall st st' st'' b c,
      beval st b = true ->
      c / st \\ st' ->
      (WHILE b DO c END) / st' \\ st'' ->
      (WHILE b DO c END) / st \\ st''

  where "c1 '/' st '\\' st'" := (ceval c1 st st').

Definition loop : com :=
  WHILE BTrue DO
    SKIP
  END.

Fixpoint no_whiles (c : com) : bool :=
  match c with
  | SKIP =>
      true
  | _ ::= _ =>
      true
  | c1 ;; c2 =>
      andb (no_whiles c1) (no_whiles c2)
  | IFB _ THEN ct ELSE cf FI =>
      andb (no_whiles ct) (no_whiles cf)
  | WHILE _ DO _ END  =>
      false
  end.

Inductive sinstr : Type :=
| SPush : nat -> sinstr
| SLoad : id -> sinstr
| SPlus : sinstr
| SMinus : sinstr
| SMult : sinstr.

Definition aequiv (a1 a2 : aexp) : Prop :=
  forall (st:state),
    aeval st a1 = aeval st a2.

Definition bequiv (b1 b2 : bexp) : Prop :=
  forall (st:state),
    beval st b1 = beval st b2.

Definition cequiv (c1 c2 : com) : Prop :=
  forall (st st' : state),
    (c1 / st \\ st') <-> (c2 / st \\ st').

Definition atrans_sound (atrans : aexp -> aexp) : Prop :=
  forall (a : aexp),
    aequiv a (atrans a).

Definition btrans_sound (btrans : bexp -> bexp) : Prop :=
  forall (b : bexp),
    bequiv b (btrans b).

Definition ctrans_sound (ctrans : com -> com) : Prop :=
  forall (c : com),
    cequiv c (ctrans c).

Lemma refl_cequiv : forall (c : com), cequiv c c.
Proof.
  unfold cequiv. intros c st st'. apply iff_refl.
Qed.

Lemma sym_cequiv : forall (c1 c2 : com),
  cequiv c1 c2 -> cequiv c2 c1.
Proof.
  unfold cequiv. intros c1 c2 H st st'.
  assert (c1 / st \\ st' <-> c2 / st \\ st') as H'.
  { (* Proof of assertion *) apply H. }
  apply iff_sym. assumption.
Qed.

Lemma trans_cequiv : forall (c1 c2 c3 : com),
  cequiv c1 c2 -> cequiv c2 c3 -> cequiv c1 c3.
Proof.
  unfold cequiv. intros c1 c2 c3 H12 H23 st st'.
  apply iff_trans with (c2 / st \\ st'). apply H12. apply H23.
Qed.

Theorem CAss_congruence : forall i a1 a1',
  aequiv a1 a1' ->
  cequiv (CAss i a1) (CAss i a1').
Proof.
  intros i a1 a2 Heqv st st'.
  split; intros Hceval.
  - (* -> *)
    inversion Hceval. subst. apply E_Ass.
    rewrite Heqv. reflexivity.
  - (* <- *)
    inversion Hceval. subst. apply E_Ass.
    rewrite Heqv. reflexivity.  Qed.

Theorem CWhile_congruence : forall b1 b1' c1 c1',
  bequiv b1 b1' -> cequiv c1 c1' ->
  cequiv (WHILE b1 DO c1 END) (WHILE b1' DO c1' END).
Proof.
  (* WORKED IN CLASS *)
  unfold bequiv,cequiv.
  intros b1 b1' c1 c1' Hb1e Hc1e st st'.
  split; intros Hce.
  - (* -> *)
    remember (WHILE b1 DO c1 END) as cwhile
      eqn:Heqcwhile.
    induction Hce; inversion Heqcwhile; subst.
    + (* E_WhileEnd *)
      apply E_WhileEnd. rewrite <- Hb1e. apply H.
    + (* E_WhileLoop *)
      apply E_WhileLoop with (st' := st').
      * (* show loop runs *) rewrite <- Hb1e. apply H.
      * (* body execution *)
        apply (Hc1e st st').  apply Hce1.
      * (* subsequent loop execution *)
        apply IHHce2. reflexivity.
  - (* <- *)
    remember (WHILE b1' DO c1' END) as c'while
      eqn:Heqc'while.
    induction Hce; inversion Heqc'while; subst.
    + (* E_WhileEnd *)
      apply E_WhileEnd. rewrite -> Hb1e. apply H.
    + (* E_WhileLoop *)
      apply E_WhileLoop with (st' := st').
      * (* show loop runs *) rewrite -> Hb1e. apply H.
      * (* body execution *)
        apply (Hc1e st st').  apply Hce1.
      * (* subsequent loop execution *)
        apply IHHce2. reflexivity.
Qed.

Theorem IFB_true: forall b c1 c2,
     bequiv b BTrue  ->
     cequiv
       (IFB b THEN c1 ELSE c2 FI)
       c1.
Proof.
  intros b c1 c2 Hb.
  split; intros H.
  - (* -> *)
    inversion H; subst.
    + (* b evaluates to true *)
      assumption.
    + (* b evaluates to false (contradiction) *)
      unfold bequiv in Hb. simpl in Hb.
      rewrite Hb in H5.
      inversion H5.
  - (* <- *)
    apply E_IfTrue; try assumption.
    unfold bequiv in Hb. simpl in Hb.
    rewrite Hb. reflexivity.
Qed.

Theorem IFB_false: forall b c1 c2,
  bequiv b BFalse  ->
  cequiv
    (IFB b THEN c1 ELSE c2 FI)
    c2.
Proof.
  intros b c1 c2 Hb.
  split; intros H.
  - (* -> *)
    inversion H; subst.
    + (* b evaluates to true *)
      unfold bequiv in Hb. simpl in Hb.
      rewrite Hb in H5.
      inversion H5.
    + (* b evaluates to false (contradiction) *)
      assumption.
  - (* <- *)
    apply E_IfFalse; try assumption.
    unfold bequiv in Hb. simpl in Hb.
    rewrite Hb. reflexivity.
Qed.

Fixpoint optimize_0plus_aexp (e:aexp) : aexp :=
  match e with
  | ANum n =>
      ANum n
  | AId i => AId i
  | APlus (ANum 0) e' | APlus e' (ANum 0) =>
      optimize_0plus_aexp e'
  | APlus e1 e2 =>
      APlus (optimize_0plus_aexp e1) (optimize_0plus_aexp e2)
  | AMinus e1 e2 =>
      AMinus (optimize_0plus_aexp e1) (optimize_0plus_aexp e2)
  | AMult e1 e2 =>
      AMult (optimize_0plus_aexp e1) (optimize_0plus_aexp e2)
  end.

Fixpoint optimize_0plus_bexp (b : bexp) : bexp :=
  match b with
  | BTrue => BTrue
  | BFalse => BFalse
  | BEq a1 a2  =>
      BEq (optimize_0plus_aexp a1) (optimize_0plus_aexp a2)
  | BLe a1 a2  =>
      BLe (optimize_0plus_aexp a1) (optimize_0plus_aexp a2)
  | BNot b1  =>
      BNot (optimize_0plus_bexp b1)
  | BAnd b1 b2  =>
      BAnd (optimize_0plus_bexp b1) (optimize_0plus_bexp b2)
  end.

Fixpoint optimize_0plus_com (c : com) : com :=
  match c with
  | SKIP     =>
      SKIP
  | i ::= a  =>
      CAss i (optimize_0plus_aexp a)
  | c1 ;; c2  =>
      (optimize_0plus_com c1) ;; (optimize_0plus_com c2)
  | IFB b THEN c1 ELSE c2 FI =>
      IFB (optimize_0plus_bexp b)
      THEN optimize_0plus_com c1
      ELSE optimize_0plus_com c2
      FI
  | WHILE b DO c END =>
      WHILE (optimize_0plus_bexp b) DO
        (optimize_0plus_com c)
      END
  end.

Fixpoint subst_aexp (i : id) (u : aexp) (a : aexp) : aexp :=
  match a with
  | ANum n       =>
      ANum n
  | AId i'       =>
      if beq_id i i' then u else AId i'
  | APlus a1 a2  =>
      APlus (subst_aexp i u a1) (subst_aexp i u a2)
  | AMinus a1 a2 =>
      AMinus (subst_aexp i u a1) (subst_aexp i u a2)
  | AMult a1 a2  =>
      AMult (subst_aexp i u a1) (subst_aexp i u a2)
  end.

Definition capprox (c1 c2 : com) : Prop := forall (st st' : state),
  c1 / st \\ st' -> c2 / st \\ st'.

Fixpoint fold_constants_aexp (a : aexp) : aexp :=
  match a with
  | ANum n       => ANum n
  | AId i        => AId i
  | APlus a1 a2  =>
    match (fold_constants_aexp a1, fold_constants_aexp a2)
    with
    | (ANum n1, ANum n2) => ANum (n1 + n2)
    | (a1', a2') => APlus a1' a2'
    end
  | AMinus a1 a2 =>
    match (fold_constants_aexp a1, fold_constants_aexp a2)
    with
    | (ANum n1, ANum n2) => ANum (n1 - n2)
    | (a1', a2') => AMinus a1' a2'
    end
  | AMult a1 a2  =>
    match (fold_constants_aexp a1, fold_constants_aexp a2)
    with
    | (ANum n1, ANum n2) => ANum (n1 * n2)
    | (a1', a2') => AMult a1' a2'
    end
  end.

Fixpoint fold_constants_bexp (b : bexp) : bexp :=
  match b with
  | BTrue        => BTrue
  | BFalse       => BFalse
  | BEq a1 a2  =>
    match (fold_constants_aexp a1, fold_constants_aexp a2)
    with
    | (ANum n1, ANum n2) =>
        if beq_nat n1 n2 then BTrue else BFalse
    | (a1', a2') =>
        BEq a1' a2'
    end
  | BLe a1 a2  =>
    match (fold_constants_aexp a1, fold_constants_aexp a2)
    with
    | (ANum n1, ANum n2) =>
        if leb n1 n2 then BTrue else BFalse
    | (a1', a2') =>
        BLe a1' a2'
    end
  | BNot b1  =>
    match (fold_constants_bexp b1) with
    | BTrue => BFalse
    | BFalse => BTrue
    | b1' => BNot b1'
    end
  | BAnd b1 b2  =>
    match (fold_constants_bexp b1, fold_constants_bexp b2)
    with
    | (BTrue, BTrue) => BTrue
    | (BTrue, BFalse) => BFalse
    | (BFalse, BTrue) => BFalse
    | (BFalse, BFalse) => BFalse
    | (b1', b2') => BAnd b1' b2'
    end
  end.

Fixpoint fold_constants_com (c : com) : com :=
  match c with
  | SKIP      =>
      SKIP
  | i ::= a  =>
      CAss i (fold_constants_aexp a)
  | c1 ;; c2  =>
      (fold_constants_com c1) ;; (fold_constants_com c2)
  | IFB b THEN c1 ELSE c2 FI =>
      match fold_constants_bexp b with
      | BTrue => fold_constants_com c1
      | BFalse => fold_constants_com c2
      | b' => IFB b' THEN fold_constants_com c1
                     ELSE fold_constants_com c2 FI
      end
  | WHILE b DO c END =>
      match fold_constants_bexp b with
      | BTrue => WHILE BTrue DO SKIP END
      | BFalse => SKIP
      | b' => WHILE b' DO (fold_constants_com c) END
      end
  end.

Theorem fold_constants_aexp_sound :
  atrans_sound fold_constants_aexp.
Proof.
  unfold atrans_sound. intros a. unfold aequiv. intros st.
  induction a; simpl;
    (* ANum and AId follow immediately *)
    try reflexivity;
    (* APlus, AMinus, and AMult follow from the IH
       and the observation that
              aeval st (APlus a1 a2)
            = ANum ((aeval st a1) + (aeval st a2))
            = aeval st (ANum ((aeval st a1) + (aeval st a2)))
       (and similarly for AMinus/minus and AMult/mult) *)
    try (destruct (fold_constants_aexp a1);
         destruct (fold_constants_aexp a2);
         rewrite IHa1; rewrite IHa2; reflexivity). Qed.

Inductive var_not_used_in_aexp (X:id) : aexp -> Prop :=
  | VNUNum: forall n, var_not_used_in_aexp X (ANum n)
  | VNUId: forall Y, X <> Y -> var_not_used_in_aexp X (AId Y)
  | VNUPlus: forall a1 a2,
      var_not_used_in_aexp X a1 ->
      var_not_used_in_aexp X a2 ->
      var_not_used_in_aexp X (APlus a1 a2)
  | VNUMinus: forall a1 a2,
      var_not_used_in_aexp X a1 ->
      var_not_used_in_aexp X a2 ->
      var_not_used_in_aexp X (AMinus a1 a2)
  | VNUMult: forall a1 a2,
      var_not_used_in_aexp X a1 ->
      var_not_used_in_aexp X a2 ->
      var_not_used_in_aexp X (AMult a1 a2).


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Vincent Rahli

*)

Require Export cequiv_cnterm.
Require Export cequiv_cvterm.
Require Export bar_induction.
Require Export seq_util.

Definition nout_on_seq {o} lib P (A1 : @CTerm o) (n : nat) (s1 : CTerm) :=
  forall A2 s2,
    eq_kseq_nout lib s1 s2 n
    -> P A2
    -> inhabited_type lib (mkc_apply2 A1 (mkc_nat n) s1)
       # tequality lib (mkc_apply2 A1 (mkc_nat n) s1) (mkc_apply2 A2 (mkc_nat n) s2).

Definition barind_nout_bar {o} lib Q (B : @CTerm o) v :=
  forall (s : CTerm),
    is_seq_nout lib s
    -> {m : nat , nout_on_seq lib Q B m (seq2kseq s m v) }.

Definition barind_nout_imp {o} lib Q P (B X : @CTerm o) :=
  forall (n : nat) (s : CTerm),
    is_kseq_nout lib s n
    -> nout_on_seq lib Q B n s
    -> nout_on_seq lib P X n s.

Definition nout_on_upd_seq {o} lib P (X s : @CTerm o) (n : nat) (u : CTerm) (v : NVar) :=
  nout_on_seq lib P X (S n) (update_seq_nout s n u v).

Definition barind_nout_ind {o} lib P (X : @CTerm o) v :=
  forall (n : nat) (s : CTerm),
    is_kseq_nout lib s n
    -> (forall (u : CNTerm), nout_on_upd_seq lib P X s n (cnout_cterm u) v)
    -> nout_on_seq lib P X n s.

Definition barind_nout_ind_cont {o} lib P (X : @CTerm o) v :=
  forall (n : nat) (s : CTerm),
    is_kseq_nout lib s n
    -> !nout_on_seq lib P X n s
    -> {u : CNTerm , !nout_on_upd_seq lib P X s n (cnout_cterm u) v}.

Definition nout_seq_NA {o} lib P (X : @CTerm o) :=
  {n : nat
   & {s : CTerm
   & is_kseq_nout lib s n
   # !nout_on_seq lib P X n s }}.

Definition mk_nout_seq_NA {o} {lib} {P} {X : @CTerm o}
           (n : nat)
           (s : CTerm)
           (i : is_kseq_nout lib s n)
           (p : !nout_on_seq lib P X n s) : nout_seq_NA lib P X :=
  existT _ n (existT _ s (i,p)).

Definition nout_seq_NA_nat {o} {lib} {P} {X : @CTerm o} (x : nout_seq_NA lib P X) : nat :=
  projT1 x.

Definition nout_seq_NA_seq {o} {lib} {P} {X : @CTerm o} (x : nout_seq_NA lib P X) : CTerm :=
  match x with
    | existT _ _ (existT _ s _) => s
  end.

Definition barind_nout_ind_cont2 {o} lib P (X : @CTerm o) v :=
  forall (x : nout_seq_NA lib P X),
    {u : CNTerm
     , !nout_on_upd_seq
        lib P X
        (nout_seq_NA_seq x)
        (nout_seq_NA_nat x)
        (cnout_cterm u)
        v}.

Definition barind_nout_ind_cont3 {o} lib P (X : @CTerm o) v :=
  {f : nout_seq_NA lib P X -> CNTerm
   , forall a : nout_seq_NA lib P X,
       !nout_on_upd_seq
          lib P X
          (nout_seq_NA_seq a)
          (nout_seq_NA_nat a)
          (cnout_cterm (f a))
          v}.

Lemma barind_nout_ind_implies_cont {o} :
  forall lib P (X : @CTerm o) v,
    barind_nout_ind lib P X v
    -> barind_nout_ind_cont lib P X v.
Proof.
  introv ind i ni.
  pose proof (ind n s i) as h; clear ind.
  apply contraposition in h; auto.
  (* We use Markov's principle *)
  apply not_all_ex_not in h; auto.
Qed.

Lemma barind_nout_ind_cont_implies_cont2 {o} :
  forall lib P (X : @CTerm o) v,
    barind_nout_ind_cont lib P X v
    -> barind_nout_ind_cont2 lib P X v.
Proof.
  introv ind; introv.
  unfold nout_seq_NA in x; exrepnd.
  pose proof (ind n s x0 x1) as h; clear ind.
  simpl; auto.
Qed.

Lemma barind_nout_ind_cont2_implies_cont3 {o} :
  forall lib P (X : @CTerm o) v,
    barind_nout_ind_cont2 lib P X v
    -> barind_nout_ind_cont3 lib P X v.
Proof.
  introv ind; introv.
  unfold barind_nout_ind_cont2 in ind.
  apply FunctionalChoice_on in ind; auto.
Qed.

Lemma eq_kseq_nout_0 {o} :
  forall lib (s1 s2 : @CTerm o),
    eq_kseq_nout lib s1 s2 0.
Proof.
  introv.
  unfold eq_kseq_nout, natk2nout.
  apply equality_in_fun; dands; eauto 3 with slow.

  { apply type_mkc_natk.
    exists 0%Z; spcast.
    apply computes_to_valc_refl; eauto 3 with slow. }

  introv e.
  apply equality_in_natk in e; exrepnd; spcast.
  apply computes_to_valc_isvalue_eq in e3; eauto 3 with slow.
  allrw @mkc_nat_eq; ginv; omega.
Qed.

Lemma is_kseq_nout_0 {o} : forall lib (t : @CTerm o), is_kseq_nout lib t 0.
Proof.
  introv.
  apply eq_kseq_nout_0.
Qed.

Definition nout_kseq_at_is {o} lib (s : @CTerm o) (n : nat) u :=
  cequivc lib (mkc_apply s (mkc_nat n)) u.

Definition nout_kseq_NA {o} lib P (n : nat) (A : @CTerm o) v :=
  {u : CNTerm
   & {s : CTerm
   & is_kseq_nout lib s (S n)
   # seq_normalizable lib s (S n) v
   # nout_kseq_at_is lib s n (cnout_cterm u)
   # !nout_on_seq lib P A (S n) s }}.

Definition mk_nout_kseq_NA {o} {lib} {P} {n : nat} {A : @CTerm o} {v}
           (u : CNTerm)
           (s : CTerm)
           (i : is_kseq_nout lib s (S n))
           (q : seq_normalizable lib s (S n) v)
           (e : nout_kseq_at_is lib s n (cnout_cterm u))
           (p : !nout_on_seq lib P A (S n) s) : nout_kseq_NA lib P n A v :=
  existT _ u (existT _ s (i,(q,(e,p)))).

Definition nout_kseq_NA_nout {o} {lib} {P} {n : nat} {A : @CTerm o} {v}
           (x : nout_kseq_NA lib P n A v) : CNTerm :=
  match x with
    | existT _ u _ => u
  end.

Definition nout_kseq_NA_cterm {o} {lib} {P} {n : nat} {A : @CTerm o} {v}
           (x : nout_kseq_NA lib P n A v) : CTerm :=
  cnterm2cterm (nout_kseq_NA_nout x).

Definition nout_kseq_NA_seq {o} {lib} {P} {n : nat} {A : @CTerm o} {v}
           (x : nout_kseq_NA lib P n A v) : CTerm:=
  match x with
    | existT _ _ (existT _ s _) => s
  end.

Lemma eq_kseq_nout_update {o} :
  forall lib (s1 s2 : @CTerm o) (n : nat) (u : CNTerm) (v : NVar),
    eq_kseq_nout lib s1 s2 n
    -> eq_kseq_nout
         lib
         (update_seq_nout s1 n (cnout_cterm u) v)
         (update_seq_nout s2 n (cnout_cterm u) v)
         (S n).
Proof.
  introv i.
  allunfold @eq_kseq_nout.
  unfold update_seq.
  apply implies_equality_natk2nout2.
  introv ltm.

  destruct (deq_nat m n) as [d|d]; subst.

  - exists (cnterm2cterm u).
    dands; eauto 3 with slow; tcsp; spcast;[|].

    + eapply cequivc_trans;[apply cequivc_beta|].
      allrw @mkcv_inteq_substc.
      allrw @mkcv_apply_substc.
      allrw @mkc_var_substc.
      allrw @csubst_mk_cv.
      eapply cequivc_trans;[apply cequivc_mkc_inteq_nat|].
      boolvar; tcsp.

    + eapply cequivc_trans;[apply cequivc_beta|].
      allrw @mkcv_inteq_substc.
      allrw @mkcv_apply_substc.
      allrw @mkc_var_substc.
      allrw @csubst_mk_cv.
      eapply cequivc_trans;[apply cequivc_mkc_inteq_nat|].
      boolvar; tcsp.

  - pose proof (equality_natk2nout_implies lib m s1 s2 n) as h.
    repeat (autodimp h hyp); try omega;[].
    exrepnd; spcast.
    exists u0.
    dands; spcast; auto.

    + eapply cequivc_trans;[apply cequivc_beta|].
      allrw @mkcv_inteq_substc.
      allrw @mkcv_apply_substc.
      allrw @mkc_var_substc.
      allrw @csubst_mk_cv.
      eapply cequivc_trans;[apply cequivc_mkc_inteq_nat|].
      boolvar; tcsp; GC.

    + eapply cequivc_trans;[apply cequivc_beta|].
      allrw @mkcv_inteq_substc.
      allrw @mkcv_apply_substc.
      allrw @mkc_var_substc.
      allrw @csubst_mk_cv.
      eapply cequivc_trans;[apply cequivc_mkc_inteq_nat|].
      boolvar; tcsp; GC.
Qed.

Lemma is_kseq_nout_update {o} :
  forall lib (s : @CTerm o) (n : nat) (u : CNTerm) (v : NVar),
    is_kseq_nout lib s n
    -> is_kseq_nout lib (update_seq_nout s n (cnout_cterm u) v) (S n).
Proof.
  introv i.
  apply eq_kseq_nout_update; auto.
Qed.

Lemma seq_normalizable_update_nout {o} :
  forall lib (s : @CTerm o) (n : nat) (u : CTerm) (v : NVar),
    seq_normalizable lib s n v
    -> seq_normalizable lib (update_seq_nout s n u v) (S n) v.
Proof.
  introv norm.
  allunfold @seq_normalizable.

  unfold update_seq, seq2kseq.
  apply implies_cequivc_lam.
  introv.
  allrw @mkcv_inteq_substc.
  allrw @mkcv_less_substc.
  allrw @mkcv_apply_substc.
  allrw @mkc_var_substc.
  allrw @mkcv_bot_substc.
  allrw @csubst_mk_cv.
  allrw @mkcv_nat_substc.
  allrw @mkcv_zero_substc.

  eapply cequivc_trans;
    [|apply cequivc_mkc_less;
       [apply cequivc_refl
       |apply cequivc_refl
       |apply cequivc_refl
       |apply cequivc_mkc_less;
         [apply cequivc_refl
         |apply cequivc_refl
         |apply cequivc_sym;apply cequivc_beta
         |apply cequivc_refl]
       ]
    ].
  allrw @mkcv_inteq_substc.
  allrw @mkcv_apply_substc.
  allrw @mkc_var_substc.
  allrw @csubst_mk_cv.

  eapply cequivc_trans;
    [apply cequivc_mkc_inteq;
      [apply cequivc_refl
      |apply cequivc_refl
      |apply cequivc_refl
      |apply implies_cequivc_apply;
        [exact norm|apply cequivc_refl]
      ]
    |].
  unfold seq2kseq.

  eapply cequivc_trans;
    [apply cequivc_mkc_inteq;
      [apply cequivc_refl
      |apply cequivc_refl
      |apply cequivc_refl
      |apply cequivc_beta]
    |].
  allrw @mkcv_less_substc.
  allrw @mkcv_apply_substc.
  allrw @mkc_var_substc.
  allrw @mkcv_bot_substc.
  allrw @csubst_mk_cv.
  allrw @mkcv_nat_substc.
  allrw @mkcv_zero_substc.

  eapply cequivc_trans;
    [allrw @mkc_zero_eq; apply cequivc_inteq_less_swap1; try omega|].
  allrw <- @mkc_zero_eq.

  apply implies_cequivc_mkc_less1.
  introv compu.
  allrw @mkc_zero_eq.
  allrw @mkc_nat_eq.

  eapply cequivc_trans;
    [apply cequivc_mkc_less_int|].
  eapply cequivc_trans;
    [|apply cequivc_sym;apply cequivc_mkc_less_int].
  boolvar; tcsp.
  apply Wf_Z.Z_of_nat_complete_inf in l; exrepnd; subst; fold_terms.
  allrw <- @mkc_nat_eq.

  eapply cequivc_trans;
    [apply cequivc_mkc_inteq;
      [apply computes_to_valc_implies_cequivc; exact compu
      |apply cequivc_refl
      |apply cequivc_refl
      |apply cequivc_mkc_less;
        [apply computes_to_valc_implies_cequivc; exact compu
        |apply cequivc_refl
        |apply cequivc_refl
        |apply cequivc_refl]
      ]
    |].

  eapply cequivc_trans;
    [|apply cequivc_sym;apply cequivc_mkc_less;
       [apply computes_to_valc_implies_cequivc; exact compu
       |apply cequivc_refl
       |apply cequivc_mkc_inteq;
         [apply computes_to_valc_implies_cequivc; exact compu
         |apply cequivc_refl
         |apply cequivc_refl
         |apply cequivc_refl]
       |apply cequivc_refl
       ]
    ].

  eapply cequivc_trans;
    [apply cequivc_inteq_less_swap1; try omega|].

  eapply cequivc_trans;
    [apply cequivc_mkc_less;
      [apply cequivc_refl
      |apply cequivc_refl
      |apply cequivc_refl
      |apply cequivc_mkc_inteq_nat]
    |].

  eapply cequivc_trans;
    [apply cequivc_mkc_less_nat|].

  eapply cequivc_trans;
    [|apply cequivc_sym;apply cequivc_mkc_less;
      [apply cequivc_refl
      |apply cequivc_refl
      |apply cequivc_mkc_inteq_nat
      |apply cequivc_refl]
    ].

  eapply cequivc_trans;
    [|apply cequivc_sym;apply cequivc_mkc_less_nat].

  boolvar; subst; tcsp; try omega.
Qed.

Lemma nout_kseq_at_is_update {o} :
  forall lib (s : @CTerm o) (n : nat) (u : CTerm) (v : NVar),
    nout_kseq_at_is lib (update_seq_nout s n u v) n u.
Proof.
  introv.
  unfold nout_kseq_at_is, update_seq_nout.
  eapply cequivc_trans;[apply cequivc_beta|].
  allrw @mkcv_inteq_substc.
  allrw @mkcv_apply_substc.
  allrw @mkc_var_substc.
  allrw @csubst_mk_cv.
  eapply cequivc_trans;[apply cequivc_mkc_inteq_nat|].
  boolvar; tcsp; GC.
Qed.

Fixpoint nout_alpha {o}
         (lib : library)
         P
         (X c : @CTerm o)
         (v : NVar)
         (q : seq_normalizable lib c 0 v)
         (h : !nout_on_seq lib P X 0 c)
         (f : nout_seq_NA lib P X -> CNTerm)
         (ind : forall a : nout_seq_NA lib P X,
                  !nout_on_upd_seq
                     lib P X
                     (nout_seq_NA_seq a)
                     (nout_seq_NA_nat a)
                     (cnout_cterm (f a))
                     v)
         (n : nat) : nout_kseq_NA lib P n X v :=
  match n with
    | 0 =>
      let i := is_kseq_nout_0 lib c in
      let p := mk_nout_seq_NA 0 c i h in
      let k := f p in
      mk_nout_kseq_NA
        k
        (update_seq_nout c 0 (cnout_cterm k) v)
        (is_kseq_nout_update lib c 0 k v i)
        (seq_normalizable_update_nout lib c 0 (cnout_cterm k) v q)
        (nout_kseq_at_is_update lib c 0 (cnout_cterm k) v)
        (ind p)
    | S m =>
      let (_,r) := nout_alpha lib P X c v q h f ind m in
      let (s,r) := r in
      let (i,r) := r in
      let (z,r) := r in
      let (e,na) := r in
      let p := mk_nout_seq_NA (S m) s i na in
      let k := f p in
      mk_nout_kseq_NA
        k
        (update_seq_nout s (S m) (cnout_cterm k) v)
        (is_kseq_nout_update lib s (S m) k v i)
        (seq_normalizable_update_nout lib s (S m) (cnout_cterm k) v z)
        (nout_kseq_at_is_update lib s (S m) (cnout_cterm k) v)
        (ind p)
  end.

Lemma noutokensc_nout_kseq_NA_cterm :
  forall {o} {lib} {P} {n : nat} {A : @CTerm o} {v}
         (x : nout_kseq_NA lib P n A v),
    noutokensc (nout_kseq_NA_cterm x).
Proof.
  introv.
  unfold nout_kseq_NA_cterm; eauto 3 with slow.
Qed.
Hint Resolve noutokensc_nout_kseq_NA_cterm : slow.

Lemma is_kseq_nout_implies {o} :
  forall lib m (s : @CTerm o) n,
    m < n
    -> is_kseq_nout lib s n
    -> {u : CTerm , ccequivc lib (mkc_apply s (mkc_nat m)) u # noutokensc u}.
Proof.
  introv ltm i.
  unfold is_kseq_nout in i.
  eapply member_natk2nout_implies in i;[|exact ltm]; auto.
Qed.

Lemma nout_kseq_NA_seq_mk_nout_kseq_NA {o} :
  forall lib P n (A : @CTerm o) v m s i q e p,
    nout_kseq_NA_seq (@mk_nout_kseq_NA o lib P n A v m s i q e p) = s.
Proof. sp. Qed.

Lemma nout_alpha_prop1 {o} :
  forall lib P
         (X c : @CTerm o)
         (v : NVar)
         (q : seq_normalizable lib c 0 v)
         (h : !nout_on_seq lib P X 0 c)
         (f : nout_seq_NA lib P X -> CNTerm)
         (ind : forall a : nout_seq_NA lib P X,
                  !nout_on_upd_seq
                     lib P X
                     (nout_seq_NA_seq a)
                     (nout_seq_NA_nat a)
                     (cnterm2cterm (f a))
                     v)
         (n m : nat)
         (lemn : m <= n),
    equality
      lib
      (nout_kseq_NA_seq (nout_alpha lib P X c v q h f ind n))
      (nout_kseq_NA_seq (nout_alpha lib P X c v q h f ind m))
      (natk2nout (mkc_nat m)).
Proof.
  introv lemn.
  assert {k : nat & n = k + m} as e.
  { exists (n - m); omega. }
  exrepnd; subst.
  clear lemn.
  induction k; introv; allsimpl; apply implies_equality_natk2nout2; introv ltm0.

  - remember (nout_alpha lib P X c v q h f ind m) as am.
    unfold nout_kseq_NA in am; exrepnd; allsimpl.

    dup am0 as i.
    apply (is_kseq_nout_implies lib m0) in i; try omega; exrepnd.
    exists u0; dands; auto.

  - remember (nout_alpha lib P X c v q h f ind (k + m)) as am.
    unfold nout_kseq_NA in am; exrepnd; simphyps.
    rw @nout_kseq_NA_seq_mk_nout_kseq_NA.

    eapply equality_natk2nout_implies in IHk;[|exact ltm0].
    exrepnd.
    exists u0; dands; auto.

    unfold update_seq_nout; spcast.
    eapply cequivc_trans;[apply cequivc_beta|].
    allrw @mkcv_inteq_substc.
    allrw @mkcv_apply_substc.
    allrw @mkc_var_substc.
    allrw @csubst_mk_cv.
    eapply cequivc_trans;[apply cequivc_mkc_inteq_nat|].
    boolvar; tcsp; GC; try omega.
Qed.

Lemma eq_kseq_nout_seq2kseq_0 {o} :
  forall lib v (s1 s2 : @CTerm o),
    eq_kseq_nout lib (seq2kseq s1 0 v) (seq2kseq s2 0 v) 0.
Proof.
  introv.
  apply implies_equality_natk2nout.
  introv ltm; omega.
Qed.

Lemma seq2kseq_prop1_nout {o} :
  forall lib (s1 s2 : @CTerm o) n v,
    eq_kseq_nout lib s1 s2 n
    -> eq_kseq_nout lib (seq2kseq s1 n v) (seq2kseq s2 n v) n.
Proof.
  introv equ.
  apply implies_equality_natk2nout2.
  introv ltm.
  apply (equality_natk2nout_implies _ m) in equ; auto; exrepnd; spcast.
  exists u.
  dands; spcast; auto.

  - unfold seq2kseq.
    eapply cequivc_trans;[apply cequivc_beta|].
    allrw @mkcv_less_substc.
    allrw @mkcv_apply_substc.
    allrw @mkc_var_substc.
    allrw @mkcv_bot_substc.
    allrw @csubst_mk_cv.
    allrw @mkcv_nat_substc.
    allrw @mkcv_zero_substc.
    allrw @mkc_zero_eq.
    eapply cequivc_trans;[apply cequivc_mkc_less_nat|].
    boolvar; try omega.
    eapply cequivc_trans;[apply cequivc_mkc_less_nat|].
    boolvar; try omega; auto.

  - unfold seq2kseq.
    eapply cequivc_trans;[apply cequivc_beta|].
    allrw @mkcv_less_substc.
    allrw @mkcv_apply_substc.
    allrw @mkc_var_substc.
    allrw @mkcv_bot_substc.
    allrw @csubst_mk_cv.
    allrw @mkcv_nat_substc.
    allrw @mkcv_zero_substc.
    allrw @mkc_zero_eq.
    eapply cequivc_trans;[apply cequivc_mkc_less_nat|].
    boolvar; try omega.
    eapply cequivc_trans;[apply cequivc_mkc_less_nat|].
    boolvar; try omega; auto.
Qed.

Lemma implies_is_kseq_nout_seq2kseq {o} :
  forall lib (s : @CTerm o) m v,
    is_kseq_nout lib s m
    -> is_kseq_nout lib (seq2kseq s m v) m.
Proof.
  introv i.
  apply seq2kseq_prop1_nout; auto.
Qed.

Lemma equality_nat2nout_to_natk2nout {o} :
  forall lib (n f g : @CTerm o),
    member lib n mkc_tnat
    -> equality lib f g nat2nout
    -> equality lib f g (natk2nout n).
Proof.
  introv m e.

  allrw @equality_in_tnat.
  allunfold @equality_of_nat; exrepnd; spcast; GC.

  allrw @equality_in_fun; repnd; dands; eauto 3 with slow.
  { apply type_mkc_natk.
    exists (Z.of_nat k); spcast; auto. }

  introv en.
  apply equality_natk_to_tnat in en; apply e in en; auto.
Qed.

Lemma is_kseq_nout_ntseqc2ntseq {o} :
  forall (lib : @library o) s n, is_kseq_nout lib (ntseqc2ntseq s) n.
Proof.
  introv.
  pose proof (is_seq_nout_ntseqc2ntseq lib s) as h.
  apply equality_nat2nout_to_natk2nout; auto.
  apply nat_in_nat.
Qed.
Hint Resolve is_kseq_nout_ntseqc2ntseq : slow.

Lemma seq2kseq_prop2_nout {o} :
  forall lib v (s1 s2 : @CTerm o) n,
    eq_kseq_nout lib s1 s2 n
    -> cequivc lib (seq2kseq s1 n v) (seq2kseq s2 n v).
Proof.
  introv equ.
  apply implies_cequivc_lam.
  introv.
  allrw @mkcv_less_substc.
  allrw @mkcv_apply_substc.
  allrw @mkc_var_substc.
  allrw @mkcv_bot_substc.
  allrw @csubst_mk_cv.
  allrw @mkcv_nat_substc.
  allrw @mkcv_zero_substc.

  apply implies_cequivc_mkc_less1.
  introv compu.
  allrw @mkc_zero_eq.
  allrw (@mkc_nat_eq o 0).

  eapply cequivc_trans;[apply cequivc_mkc_less_int|].
  eapply cequivc_trans;[|apply cequivc_sym;apply cequivc_mkc_less_int].
  boolvar; auto.

  eapply cequivc_trans;
    [apply cequivc_mkc_less;
      [apply computes_to_valc_implies_cequivc;exact compu
      |apply cequivc_refl
      |apply cequivc_refl
      |apply cequivc_refl]
    |].

  eapply cequivc_trans;
    [|apply cequivc_sym;apply cequivc_mkc_less;
      [apply computes_to_valc_implies_cequivc;exact compu
      |apply cequivc_refl
      |apply cequivc_refl
      |apply cequivc_refl]
    ].

  apply Wf_Z.Z_of_nat_complete_inf in l; exrepnd; subst; fold_terms.
  allrw <- @mkc_nat_eq.

  eapply cequivc_trans;[apply cequivc_mkc_less_nat|].
  eapply cequivc_trans;[|apply cequivc_sym;apply cequivc_mkc_less_nat].

  boolvar; auto.

  eapply cequivc_trans;
    [apply implies_cequivc_apply;
      [apply cequivc_refl
      |apply computes_to_valc_implies_cequivc;exact compu]
    |].

  eapply cequivc_trans;
    [|apply cequivc_sym;apply implies_cequivc_apply;
      [apply cequivc_refl
      |apply computes_to_valc_implies_cequivc;exact compu]
    ].

  apply (equality_natk2nout_implies _ n0) in equ; auto.
  apply cequiv_stable; exrepnd; spcast.
  eapply cequivc_trans;
    [exact equ1
    |apply cequivc_sym;exact equ2].
Qed.

Lemma cequivc_preserves_eq_kseq_nout_left {o} :
  forall lib (s s1 s2 : @CTerm o) n,
    cequivc lib s1 s2
    -> eq_kseq_nout lib s1 s n
    -> eq_kseq_nout lib s2 s n.
Proof.
  introv ceq ek.
  allunfold @eq_kseq_nout.
  eapply equality_respects_cequivc_left;[|exact ek]; auto.
Qed.

Lemma cequivc_preserves_eq_kseq_nout_right {o} :
  forall lib (s s1 s2 : @CTerm o) n,
    cequivc lib s1 s2
    -> eq_kseq_nout lib s s1 n
    -> eq_kseq_nout lib s s2 n.
Proof.
  introv ceq ek.
  allunfold @eq_kseq_nout.
  eapply equality_respects_cequivc_right;[|exact ek]; auto.
Qed.

Lemma cequivc_preserves_nout_on_seq {o} :
  forall lib P (A : @CTerm o) n s1 s2,
    cequivc lib s1 s2
    -> nout_on_seq lib P A n s1
    -> nout_on_seq lib P A n s2.
Proof.
  introv ceq m.
  allunfold @nout_on_seq; repnd.
  introv ek p.
  pose proof (m A2 s0) as h; clear m.
  repeat (autodimp h hyp).
  { eapply cequivc_preserves_eq_kseq_nout_left;[|exact ek]; auto.
    apply cequivc_sym; auto. }
  repnd.
  dands.
  - eapply inhabited_type_cequivc;[|exact h0].
    apply implies_cequivc_apply2; auto.
  - eapply tequality_respects_cequivc_left;[|exact h].
    apply implies_cequivc_apply2; auto.
Qed.

Lemma cequivc_preserves_not_nout_on_seq {o} :
  forall lib P (A : @CTerm o) n s1 s2,
    cequivc lib s1 s2
    -> !nout_on_seq lib P A n s1
    -> !nout_on_seq lib P A n s2.
Proof.
  introv ceq h m.
  allunfold @nout_on_seq; repnd.
  destruct h.
  introv ek p.
  pose proof (m A2 s0) as h; clear m.
  repeat (autodimp h hyp).
  { eapply cequivc_preserves_eq_kseq_nout_left;[|exact ek]; auto. }
  repnd.
  dands.
  - eapply inhabited_type_cequivc;[|exact h0].
    apply implies_cequivc_apply2; auto.
    apply cequivc_sym; auto.
  - eapply tequality_respects_cequivc_left;[|exact h].
    apply implies_cequivc_apply2; auto.
    apply cequivc_sym; auto.
Qed.

Lemma bar_induction_cterm_meta {o} :
  forall lib Q P (B X c : @CTerm o) v,
    barind_nout_bar lib Q B v
    -> barind_nout_imp lib Q P B X
    -> barind_nout_ind lib P X v
    -> nout_on_seq lib P X 0 (seq2kseq c 0 v).
Proof.
  introv bar imp ind.
  pose proof (classic (nout_on_seq lib P X 0 (seq2kseq c 0 v))) as ni.
  repndors; auto.
  provefalse.

  apply barind_nout_ind_implies_cont in ind.
  apply barind_nout_ind_cont_implies_cont2 in ind.
  apply barind_nout_ind_cont2_implies_cont3 in ind.
  unfold barind_nout_ind_cont3 in ind; exrepnd.
  rename ind0 into ind.

  pose proof (seq_normalizable_seq2kseq lib c 0 v) as nc.

  remember (nout_alpha lib P X (seq2kseq c 0 v) v nc ni f ind) as g.
  remember (fun m => nout_kseq_NA_nout (g m)) as s.

  assert (forall n, eq_kseq_nout lib (ntseqc2ntseq s) (nout_kseq_NA_seq (g n)) n) as e.
  { introv.
    apply implies_equality_natk2nout2; introv ltm.
    subst.
    exists (nout_kseq_NA_cterm (nout_alpha lib P X (seq2kseq c 0 v) v nc ni f ind m)).
    dands; spcast; eauto 3 with slow.

    - eapply cequivc_trans;[apply cequivc_beta_ntseqc2ntseq|].
      simpl; auto.

    - pose proof (nout_alpha_prop1 lib P X (seq2kseq c 0 v) v nc ni f ind n (S m)) as q.
      autodimp q hyp; try omega.
      apply (equality_natk2nout_implies lib m) in q; try omega.
      apply cequiv_stable; exrepnd; spcast.

      apply cequivc_sym in q1.
      eapply cequivc_trans in q1;[|exact q2].
      clear q2.
      eapply cequivc_trans;[apply cequivc_sym;exact q1|].
      clear q1.
      simpl.

      remember (nout_alpha lib P X (seq2kseq c 0 v) v nc ni f ind m) as am.
      unfold nout_kseq_NA in am; exrepnd; simphyps.
      rw @nout_kseq_NA_seq_mk_nout_kseq_NA.
      unfold update_seq_nout.
      eapply cequivc_trans;[apply cequivc_beta|].
      allrw @mkcv_inteq_substc.
      allrw @mkcv_apply_substc.
      allrw @mkc_var_substc.
      allrw @csubst_mk_cv.
      eapply cequivc_trans;[apply cequivc_mkc_inteq_nat|].
      boolvar; auto; try omega.
  }

  pose proof (bar (ntseqc2ntseq s)) as b.
  autodimp b hyp; eauto 3 with slow.

  exrepnd.
  rename b0 into b.

  apply imp in b;[|apply implies_is_kseq_nout_seq2kseq; eauto 3 with slow].

  induction m; allsimpl.

  { pose proof (eq_kseq_nout_0 lib (ntseqc2ntseq s) c) as h1.
    apply (seq2kseq_prop2_nout _ v) in h1.
    eapply cequivc_preserves_nout_on_seq in b;[|exact h1]; auto. }

  pose proof (e (S m)) as q1.
  apply (seq2kseq_prop2_nout _ v) in q1.

  eapply cequivc_preserves_nout_on_seq in b;[|exact q1].

  pose proof (e m) as q2.
  apply (seq2kseq_prop2_nout _ v) in q2.

  eapply cequivc_preserves_not_nout_on_seq in IHm;[|exact q2].
  clear q1 q2 e.

  subst; allsimpl.
  remember (nout_alpha lib P X (seq2kseq c 0 v) v nc ni f ind m) as am.
  unfold nout_kseq_NA in am; exrepnd; allsimpl.

  remember (f (mk_nout_seq_NA (S m) s am0 am1)) as fn.

  assert (eq_kseq_nout lib (update_seq_nout s (S m) (cnterm2cterm fn) v) s (S m)) as ee1.
  { unfold eq_kseq_nout.
    apply implies_equality_natk2nout2; introv ltm1.
    dup am0 as e.
    eapply member_natk2nout_implies in e;[|exact ltm1]; exrepnd; spcast.
    exists u0; dands; spcast; auto;[].
    unfold update_seq_nout.
    eapply cequivc_trans;[apply cequivc_beta|].
    allrw @mkcv_inteq_substc.
    allrw @mkcv_apply_substc.
    allrw @mkc_var_substc.
    allrw @csubst_mk_cv.
    eapply cequivc_trans;[apply cequivc_mkc_inteq_nat|].
    boolvar; tcsp; GC; try omega.
  }

  apply (seq2kseq_prop2_nout _ v) in ee1.
  eapply cequivc_preserves_nout_on_seq in b;[|exact ee1].
  clear ee1.

  unfold seq_normalizable in am2.
  eapply cequivc_preserves_nout_on_seq in b;
    [|apply cequivc_sym;exact am2].
  sp.
Qed.

Definition cbv_emseq {o} (v : NVar) : @NTerm o :=
  mk_lam v (mk_cbv (mk_var v) v mk_bot).

Definition cbv_emseqc {o} (v : NVar) : @CTerm o :=
  mkc_lam v (mkcv_cbv [v] (mkc_var v) v (mkcv_bot [v,v])).

Lemma approx_mk_less_twice_false1 {o} :
  forall lib (a b c d e : @NTerm o),
    isprog a
    -> isprog b
    -> isprog c
    -> isprog d
    -> isprog e
    -> approx
         lib
         (mk_less
            a
            b
            c
            (mk_less a b d e))
         (mk_less a b c e).
Proof.
  introv ispa ispb ispc ispd ispe.
  constructor.
  unfold close_comput; dands; auto;
  try (repeat (apply isprogram_mk_less; dands; eauto 3 with slow)).

  - introv comp.
    apply computes_to_value_mk_less in comp; eauto 2 with slow;
    try (apply wf_less; eauto 2 with slow).
    exrepnd.

    repndors; repnd.

    + exists tl_subterms.
      dands.

      * allunfold @computes_to_value; repnd; dands; eauto 2 with slow.

        eapply reduces_to_trans;
        [apply reduce_to_prinargs_comp;
          [unfold computes_to_value; dands;[exact comp0|]
          |eauto 3 with slow
          |exact comp2]
        |]; eauto 2 with slow.

        eapply reduces_to_if_split2;
          [ csunf; simpl; dcwf h; simpl; unfold compute_step_comp; simpl;
            boolvar; try omega; reflexivity
           |].
        auto.

      * apply clearbot_relbt2.
        apply (approx_canonical_form2 _ c0).
        apply approx_refl.
        allunfold @computes_to_value; repnd.
        eauto 3 with slow.

    + apply computes_to_value_mk_less in comp1; eauto 2 with slow;
      try (apply wf_less; eauto 2 with slow).
      exrepnd.

      eapply reduces_to_eq_val_like in comp0; try (exact comp4); eauto 3 with slow.
      eapply reduces_to_eq_val_like in comp2; try (exact comp5); eauto 3 with slow.
      ginv.

      repndors; repnd; try omega; GC.

      exists tl_subterms.
      dands.

      * allunfold @computes_to_value; repnd; dands; eauto 2 with slow.

        eapply reduces_to_trans;
        [apply reduce_to_prinargs_comp;
          [unfold computes_to_value; dands;[exact comp4|]
          |eauto 3 with slow
          |exact comp5]
        |]; eauto 2 with slow.

        eapply reduces_to_if_split2;
          [ csunf; simpl; dcwf h; simpl; unfold compute_step_comp; simpl;
            boolvar; try omega; reflexivity
           |].
        auto.

      * apply clearbot_relbt2.
        apply (approx_canonical_form2 _ c0).
        apply approx_refl.
        allunfold @computes_to_value; repnd.
        eauto 3 with slow.

  - introv comp.
    apply computes_to_exception_mk_less in comp; eauto 3 with slow;
    try (apply wf_less; eauto 3 with slow).
    repeat (repndors; exrepnd).

    + exists a0 e0; dands; tcsp.

      * eapply reduces_to_trans;
        [apply reduce_to_prinargs_comp;
          [unfold computes_to_value; dands;[exact comp0|]
          |eauto 3 with slow
          |exact comp2]
        |]; eauto 2 with slow.

        eapply reduces_to_if_split2;
          [ csunf; simpl; dcwf h; simpl; unfold compute_step_comp; simpl;
            boolvar; try omega; reflexivity
           |].
        auto.

      * apply remove_bot_approx.
        applydup @reduces_to_preserves_isprog in comp1; auto.
        allrw @isprog_exception_iff; repnd.
        apply approx_refl; eauto 3 with slow.

      * apply remove_bot_approx.
        applydup @reduces_to_preserves_isprog in comp1; auto.
        allrw @isprog_exception_iff; repnd.
        apply approx_refl; eauto 3 with slow.

    + exists a0 e0; dands; tcsp.

      * apply computes_to_exception_mk_less in comp1; eauto 3 with slow.
        repeat (repndors; exrepnd).

        {
          eapply reduces_to_eq_val_like in comp0; try (exact comp4); eauto 3 with slow.
          eapply reduces_to_eq_val_like in comp2; try (exact comp5); eauto 3 with slow.
          ginv.

          eapply reduces_to_trans;
            [apply reduce_to_prinargs_comp;
              [unfold computes_to_value; dands;[exact comp4|]
              |eauto 3 with slow
              |exact comp5]
            |]; eauto 2 with slow.

          eapply reduces_to_if_split2;
            [ csunf; simpl; dcwf h; simpl; unfold compute_step_comp; simpl;
              boolvar; try omega; reflexivity
             |].
          auto.
        }

        {
          eapply reduces_to_eq_val_like in comp0; try (exact comp4); eauto 3 with slow.
          eapply reduces_to_eq_val_like in comp2; try (exact comp5); eauto 3 with slow.
          ginv.

          eapply reduces_to_trans;
            [apply reduce_to_prinargs_comp;
              [unfold computes_to_value; dands;[exact comp4|]
              |eauto 3 with slow
              |exact comp5]
            |]; eauto 2 with slow.

          eapply reduces_to_if_split2;
            [ csunf; simpl; dcwf h; simpl; unfold compute_step_comp; simpl;
              boolvar; try omega; reflexivity
             |].
          auto.
        }

        {
          eapply computes_to_value_and_exception_false in comp1; tcsp.
          split; [exact comp0|]; eauto 3 with slow.
        }

        {
          eapply computes_to_value_and_exception_false in comp4; tcsp.
          split; [exact comp2|]; eauto 3 with slow.
        }

      * apply remove_bot_approx.
        applydup @reduces_to_preserves_isprog in comp1; auto;
        try (apply isprog_less_implies; auto).
        allrw @isprog_exception_iff; repnd.
        apply approx_refl; eauto 3 with slow.

      * apply remove_bot_approx.
        applydup @reduces_to_preserves_isprog in comp1; auto;
        try (apply isprog_less_implies; auto).
        allrw @isprog_exception_iff; repnd.
        apply approx_refl; eauto 3 with slow.

    + exists a0 e0; dands; auto.

      * eapply reduces_to_trans;
        [apply reduces_to_prinarg;exact comp
        |]; eauto 2 with slow.

      * apply remove_bot_approx.
        applydup @reduces_to_preserves_isprog in comp; auto;
        try (apply isprog_less_implies; auto).
        allrw @isprog_exception_iff; repnd.
        apply approx_refl; eauto 3 with slow.

      * apply remove_bot_approx.
        applydup @reduces_to_preserves_isprog in comp; auto;
        try (apply isprog_less_implies; auto).
        allrw @isprog_exception_iff; repnd.
        apply approx_refl; eauto 3 with slow.

    + exists a0 e0; dands; auto.

      * eapply reduces_to_trans;
        [apply reduce_to_prinargs_comp;
          [unfold computes_to_value; dands;[exact comp1|]
          |eauto 3 with slow
          |exact comp0]
        |]; eauto 2 with slow.

      * apply remove_bot_approx.
        applydup @reduces_to_preserves_isprog in comp0; auto;
        try (apply isprog_less_implies; auto).
        allrw @isprog_exception_iff; repnd.
        apply approx_refl; eauto 3 with slow.

      * apply remove_bot_approx.
        applydup @reduces_to_preserves_isprog in comp0; auto;
        try (apply isprog_less_implies; auto).
        allrw @isprog_exception_iff; repnd.
        apply approx_refl; eauto 3 with slow.

  - introv comp; allsimpl.
    apply computes_to_seq_implies_computes_to_value in comp;
      [|repeat (apply isprogram_mk_less; dands; eauto 2 with slow)].
    applydup @computes_to_value_mk_less in comp; exrepnd; eauto 2 with slow;
    try (apply wf_less; eauto 3 with slow).

    exists f; dands; auto;
    [|destruct comp as [comp isv]; inversion isv;
       introv;left;apply approx_refl; eauto 3 with slow].
    eapply reduces_to_trans;
      [apply reduce_to_prinargs_comp;
        [unfold computes_to_value; dands;[exact comp1|]
        |eauto 3 with slow
        |exact comp2]
      |]; eauto 2 with slow.

    repndors; repnd.

    + eapply reduces_to_if_split2;
      [ csunf; simpl; dcwf h; simpl; unfold compute_step_comp; simpl;
        boolvar; try omega; reflexivity
       |].
      allunfold @computes_to_value; tcsp.

    + eapply reduces_to_if_split2;
      [ csunf; simpl; dcwf h; simpl; unfold compute_step_comp; simpl;
        boolvar; try omega; reflexivity
       |].

      applydup @computes_to_value_mk_less in comp0; exrepnd; eauto 2 with slow;
      try (apply wf_less; eauto 3 with slow).

      eapply reduces_to_eq_val_like in comp1; try (exact comp5); eauto 3 with slow.
      eapply reduces_to_eq_val_like in comp2; try (exact comp6); eauto 3 with slow.
      ginv.

      repndors; repnd; try omega; GC.
      allunfold @computes_to_value; tcsp.
Qed.

Lemma approx_mk_less_twice_false2 {o} :
  forall lib (a b c d e : @NTerm o),
    isprog a
    -> isprog b
    -> isprog c
    -> isprog d
    -> isprog e
    -> approx
         lib
         (mk_less a b c e)
         (mk_less
            a
            b
            c
            (mk_less a b d e)).
Proof.
  introv ispa ispb ispc ispd ispe.
  constructor.
  unfold close_comput; dands; auto;
  try (repeat (apply isprogram_mk_less; dands; eauto 3 with slow)).

  - introv comp.
    apply computes_to_value_mk_less in comp; eauto 2 with slow;
    try (apply wf_less; eauto 2 with slow).
    exrepnd.

    exists tl_subterms.
    dands;[repndors; repnd|].

    + allunfold @computes_to_value; repnd; dands; eauto 2 with slow.

      eapply reduces_to_trans;
        [apply reduce_to_prinargs_comp;
          [unfold computes_to_value; dands;[exact comp0|]
          |eauto 3 with slow
          |exact comp2]
        |]; eauto 2 with slow.

      eapply reduces_to_if_split2;
        [ csunf; simpl; dcwf h; simpl; unfold compute_step_comp; simpl;
          boolvar; try omega; reflexivity
         |].
      auto.

    + allunfold @computes_to_value; repnd; dands; eauto 2 with slow.

      eapply reduces_to_trans;
        [apply reduce_to_prinargs_comp;
          [unfold computes_to_value; dands;[exact comp0|]
          |eauto 3 with slow
          |exact comp2]
        |]; eauto 2 with slow.

      eapply reduces_to_if_split2;
        [ csunf; simpl; dcwf h; simpl; unfold compute_step_comp; simpl;
          boolvar; try omega; reflexivity
         |].

      eapply reduces_to_trans;
        [apply reduce_to_prinargs_comp;
          [unfold computes_to_value; dands;[exact comp0|]
          |eauto 3 with slow
          |exact comp2]
        |]; eauto 2 with slow.

      eapply reduces_to_if_split2;
        [ csunf; simpl; dcwf h; simpl; unfold compute_step_comp; simpl;
          boolvar; try omega; reflexivity
         |].
      auto.

    + apply clearbot_relbt2.
      apply (approx_canonical_form2 _ c0).
      apply approx_refl.
      repndors; allunfold @computes_to_value; repnd; eauto 3 with slow.

  - introv comp.
    apply computes_to_exception_mk_less in comp; eauto 3 with slow;
    try (apply wf_less; eauto 3 with slow).
    repeat (repndors; exrepnd).

    + exists a0 e0; dands; tcsp.

      * eapply reduces_to_trans;
        [apply reduce_to_prinargs_comp;
          [unfold computes_to_value; dands;[exact comp0|]
          |eauto 3 with slow
          |exact comp2]
        |]; eauto 2 with slow.

        eapply reduces_to_if_split2;
          [ csunf; simpl; dcwf h; simpl; unfold compute_step_comp; simpl;
            boolvar; try omega; reflexivity
           |].
        auto.

      * apply remove_bot_approx.
        applydup @reduces_to_preserves_isprog in comp1; auto.
        allrw @isprog_exception_iff; repnd.
        apply approx_refl; eauto 3 with slow.

      * apply remove_bot_approx.
        applydup @reduces_to_preserves_isprog in comp1; auto.
        allrw @isprog_exception_iff; repnd.
        apply approx_refl; eauto 3 with slow.

    + exists a0 e0; dands; tcsp.

      * eapply reduces_to_trans;
        [apply reduce_to_prinargs_comp;
          [unfold computes_to_value; dands;[exact comp0|]
          |eauto 3 with slow
          |exact comp2]
        |]; eauto 2 with slow.

        eapply reduces_to_if_split2;
          [ csunf; simpl; dcwf h; simpl; unfold compute_step_comp; simpl;
            boolvar; try omega; reflexivity
           |].

        eapply reduces_to_trans;
        [apply reduce_to_prinargs_comp;
          [unfold computes_to_value; dands;[exact comp0|]
          |eauto 3 with slow
          |exact comp2]
        |]; eauto 2 with slow.

        eapply reduces_to_if_split2;
          [ csunf; simpl; dcwf h; simpl; unfold compute_step_comp; simpl;
            boolvar; try omega; reflexivity
           |].
        auto.

      * apply remove_bot_approx.
        applydup @reduces_to_preserves_isprog in comp1; auto.
        allrw @isprog_exception_iff; repnd.
        apply approx_refl; eauto 3 with slow.

      * apply remove_bot_approx.
        applydup @reduces_to_preserves_isprog in comp1; auto.
        allrw @isprog_exception_iff; repnd.
        apply approx_refl; eauto 3 with slow.

    + exists a0 e0; dands; auto.

      * eapply reduces_to_trans;
        [apply reduces_to_prinarg;exact comp
        |]; eauto 2 with slow.

      * apply remove_bot_approx.
        applydup @reduces_to_preserves_isprog in comp; auto;
        try (apply isprog_less_implies; auto).
        allrw @isprog_exception_iff; repnd.
        apply approx_refl; eauto 3 with slow.

      * apply remove_bot_approx.
        applydup @reduces_to_preserves_isprog in comp; auto;
        try (apply isprog_less_implies; auto).
        allrw @isprog_exception_iff; repnd.
        apply approx_refl; eauto 3 with slow.

    + exists a0 e0; dands; auto.

      * eapply reduces_to_trans;
        [apply reduce_to_prinargs_comp;
          [unfold computes_to_value; dands;[exact comp1|]
          |eauto 3 with slow
          |exact comp0]
        |]; eauto 2 with slow.

      * apply remove_bot_approx.
        applydup @reduces_to_preserves_isprog in comp0; auto;
        try (apply isprog_less_implies; auto).
        allrw @isprog_exception_iff; repnd.
        apply approx_refl; eauto 3 with slow.

      * apply remove_bot_approx.
        applydup @reduces_to_preserves_isprog in comp0; auto;
        try (apply isprog_less_implies; auto).
        allrw @isprog_exception_iff; repnd.
        apply approx_refl; eauto 3 with slow.

  - introv comp; allsimpl.
    apply computes_to_seq_implies_computes_to_value in comp;
      [|repeat (apply isprogram_mk_less; dands; eauto 2 with slow)].
    applydup @computes_to_value_mk_less in comp; exrepnd; eauto 2 with slow;
    try (apply wf_less; eauto 3 with slow).

    exists f; dands; auto;
    [|destruct comp as [comp isv]; inversion isv;
       introv;left;apply approx_refl; eauto 3 with slow].
    eapply reduces_to_trans;
      [apply reduce_to_prinargs_comp;
        [unfold computes_to_value; dands;[exact comp1|]
        |eauto 3 with slow
        |exact comp2]
      |]; eauto 2 with slow.

    repndors; repnd.

    + eapply reduces_to_if_split2;
      [ csunf; simpl; dcwf h; simpl; unfold compute_step_comp; simpl;
        boolvar; try omega; reflexivity
       |].
      allunfold @computes_to_value; tcsp.

    + eapply reduces_to_if_split2;
      [ csunf; simpl; dcwf h; simpl; unfold compute_step_comp; simpl;
        boolvar; try omega; reflexivity
       |].

      eapply reduces_to_trans;
        [apply reduce_to_prinargs_comp;
          [unfold computes_to_value; dands;[exact comp1|]
          |eauto 3 with slow
          |exact comp2]
        |]; eauto 2 with slow.

      eapply reduces_to_if_split2;
        [ csunf; simpl; dcwf h; simpl; unfold compute_step_comp; simpl;
          boolvar; try omega; reflexivity
         |].
      allunfold @computes_to_value; tcsp.
Qed.

Lemma cequiv_mk_less_twice_false {o} :
  forall lib (a b c d e : @NTerm o),
    isprog a
    -> isprog b
    -> isprog c
    -> isprog d
    -> isprog e
    -> cequiv
         lib
         (mk_less
            a
            b
            c
            (mk_less a b d e))
         (mk_less a b c e).
Proof.
  introv ispa ispb ispc ispd ispe.
  split.
  - apply approx_mk_less_twice_false1; auto.
  - apply approx_mk_less_twice_false2; auto.
Qed.

Lemma cequivc_mkc_less_twice_false {o} :
  forall lib (a b c d e : @CTerm o),
    cequivc
      lib
      (mkc_less
         a
         b
         c
         (mkc_less a b d e))
      (mkc_less a b c e).
Proof.
  introv.
  destruct_cterms.
  unfold cequivc; simpl.
  apply cequiv_mk_less_twice_false; auto.
Qed.

Lemma mkcv_cont1_bot {o} :
  forall v, @mkcv_cont1 o v (mkcv_bot [v, v]) = mkcv_bot [v].
Proof.
  introv.
  apply cvterm_eq; simpl; auto.
Qed.

Lemma if_computes_to_value_cbv0 {o} :
  forall lib (t : @NTerm o) v u x,
    isprog t
    -> computes_to_value lib (mk_cbv t v u) x
    -> {z : NTerm
        & computes_to_value lib t z
        # computes_to_value lib (subst u v z) x}.
Proof.
  unfold computes_to_value, reduces_to.
  introv isp h; exrepnd.
  revert dependent t.
  induction k; simpl; introv isp comp; ginv; tcsp.

  - allrw @reduces_in_atmost_k_steps_0; subst.
    inversion h; subst; allsimpl; tcsp.

  - allrw @reduces_in_atmost_k_steps_S; exrepnd.
    csunf comp1; allsimpl.
    destruct t as [y|f|op bs]; ginv.

    {
      exists (sterm f); dands; eauto 3 with slow.
      exists 1.
      unfold reduces_in_atmost_k_steps; simpl; csunf; simpl; auto.
    }

    dopid op as [c|nc|exc|abs] Case; ginv.

    + Case "Can".
      exists (oterm (Can c) bs); dands; tcsp; eauto.
      * exists 0; simpl; eauto 3 with slow; tcsp.
      * constructor; simpl; eauto 3 with slow.

    + Case "NCan".
      remember (compute_step lib (oterm (NCan nc) bs)); symmetry in Heqc; destruct c;
      allsimpl; ginv.

      applydup @preserve_compute_step in Heqc; eauto 2 with slow;[].

      pose proof (IHk n) as q.
      repeat (autodimp q hyp); eauto 2 with slow; exrepnd.
      exists z; dands; eauto.
      exists (S k1).
      rw @reduces_in_atmost_k_steps_S.
      eexists; dands; eauto.

    + Case "Exc".
      apply reduces_in_atmost_k_steps_if_isvalue_like in comp0; subst; eauto 2 with slow.
      inversion h; subst; allsimpl; tcsp.

   + Case "Abs".
      remember (compute_step lib (oterm (Abs abs) bs)); symmetry in Heqc; destruct c;
      allsimpl; ginv.

      applydup @preserve_compute_step in Heqc; eauto 2 with slow;[].

      pose proof (IHk n) as q.
      repeat (autodimp q hyp); eauto 2 with slow; exrepnd.
      exists z; dands; eauto.
      exists (S k1).
      rw @reduces_in_atmost_k_steps_S.
      eexists; dands; eauto.
Qed.

Lemma approx_cbv_less_bot1 {o} :
  forall lib (t : @NTerm o) i v,
    isprog t
    -> approx
         lib
         (mk_cbv t v mk_bot)
         (mk_less t (mk_integer i) mk_bot mk_bot).
Proof.
  introv isp.
  constructor.
  unfold close_comput; dands; auto;
  try (repeat (apply isprogram_mk_less; dands; eauto 3 with slow));
  try (repeat (apply isprogram_cbv; dands; eauto 3 with slow)).

  - introv comp.
    apply if_computes_to_value_cbv0 in comp; exrepnd; auto.
    unfold computes_to_value in comp1; repnd.
    rw @subst_trivial in comp0; eauto 4 with slow.
    apply bottom_diverges in comp0; tcsp.

  - introv comp.
    apply if_computes_to_exception_cbv0 in comp; eauto 2 with slow.
    repndors; exrepnd.

    + exists a e; dands; auto.

      * eapply reduces_to_trans;
        [apply reduces_to_prinarg;exact comp
        |]; eauto 2 with slow.

      * apply remove_bot_approx.
        applydup @reduces_to_preserves_isprog in comp; auto;
        try (apply isprog_less_implies; auto).
        allrw @isprog_exception_iff; repnd.
        apply approx_refl; eauto 3 with slow.

      * apply remove_bot_approx.
        applydup @reduces_to_preserves_isprog in comp; auto;
        try (apply isprog_less_implies; auto).
        allrw @isprog_exception_iff; repnd.
        apply approx_refl; eauto 3 with slow.

    + unfold computes_to_value in comp1; repnd.
      rw @subst_trivial in comp0; eauto 4 with slow.
      apply bottom_doesnt_raise_an_exception in comp0; tcsp.

  - introv comp.
    apply computes_to_seq_implies_computes_to_value in comp;
      try (apply isprogram_cbv; eauto 3 with slow);[].
    apply if_computes_to_value_cbv0 in comp; exrepnd; auto.
    unfold computes_to_value in comp1; repnd.
    rw @subst_trivial in comp0; eauto 4 with slow.
    apply bottom_diverges in comp0; tcsp.
Qed.

Lemma approx_cbv_less_bot2 {o} :
  forall lib (t : @NTerm o) i v,
    isprog t
    -> approx
         lib
         (mk_less t (mk_integer i) mk_bot mk_bot)
         (mk_cbv t v mk_bot).
Proof.
  introv isp.
  constructor.
  unfold close_comput; dands; auto;
  try (repeat (apply isprogram_mk_less; dands; eauto 3 with slow));
  try (repeat (apply isprogram_cbv; dands; eauto 3 with slow)).

  - introv comp.
    apply computes_to_value_mk_less in comp; eauto 3 with slow.
    exrepnd.
    assert (mk_bot =v>( lib)oterm (Can c) tl_subterms) as r by tcsp.
    apply bottom_diverges in r; tcsp.

  - introv comp.
    apply computes_to_exception_mk_less in comp; eauto 3 with slow.
    repndors; exrepnd.

    + assert (mk_bot =e>( a, lib)e) as r by tcsp.
      apply bottom_doesnt_raise_an_exception in r; tcsp.

    + exists a e; dands; tcsp.

      * eapply reduces_to_trans;
        [apply reduces_to_prinarg;exact comp
        |]; eauto 2 with slow.

      * apply remove_bot_approx.
        applydup @reduces_to_preserves_isprog in comp; auto;
        try (apply isprog_less_implies; auto).
        allrw @isprog_exception_iff; repnd.
        apply approx_refl; eauto 3 with slow.

      * apply remove_bot_approx.
        applydup @reduces_to_preserves_isprog in comp; auto;
        try (apply isprog_less_implies; auto).
        allrw @isprog_exception_iff; repnd.
        apply approx_refl; eauto 3 with slow.

    + apply can_doesnt_raise_an_exception in comp0; tcsp.

  - introv comp.
    apply computes_to_seq_implies_computes_to_value in comp;
      try (apply isprogram_mk_less; dands; eauto 3 with slow);[].
    apply computes_to_value_mk_less in comp; eauto 3 with slow.
    exrepnd.
    assert (mk_bot =v>( lib)sterm f) as r by tcsp.
    apply bottom_diverges in r; tcsp.
Qed.

Lemma cequiv_cbv_less_bot {o} :
  forall lib (t : @NTerm o) i v,
    isprog t
    -> cequiv
         lib
         (mk_cbv t v mk_bot)
         (mk_less t (mk_integer i) mk_bot mk_bot).
Proof.
  introv isp.
  split.
  - apply approx_cbv_less_bot1; auto.
  - apply approx_cbv_less_bot2; auto.
Qed.

Lemma cequivc_cbv_less_bot {o} :
  forall lib (t : @CTerm o) i v,
    cequivc
      lib
      (mkc_cbv t v (mkcv_bot [v]))
      (mkc_less t (mkc_integer i) mkc_bot mkc_bot).
Proof.
  introv.
  destruct_cterms; simpl.
  unfold cequivc; simpl.
  apply cequiv_cbv_less_bot; auto.
Qed.

Lemma seq_normalizable_cbv_emseqc_0 {o} :
  forall lib v, @seq_normalizable o lib (cbv_emseqc v) 0 v.
Proof.
  introv.
  unfold seq_normalizable.
  unfold cbv_emseqc, seq2kseq.

  apply implies_cequivc_lam.
  introv.
  allrw @mkcv_less_substc.
  allrw @mkcv_cbv_substc_same.
  allrw @mkcv_apply_substc.
  allrw @mkc_var_substc.
  allrw @mkcv_bot_substc.
  allrw @csubst_mk_cv.
  allrw @mkcv_nat_substc.
  allrw @mkcv_zero_substc.

  allrw <- @mkc_zero_eq.

  eapply cequivc_trans;
    [
    |apply cequivc_mkc_less;
      [apply cequivc_refl
      |apply cequivc_refl
      |apply cequivc_refl
      |apply cequivc_mkc_less;
        [apply cequivc_refl
        |apply cequivc_refl
        |apply cequivc_sym; apply cequivc_beta
        |apply cequivc_refl]
      ]
    ].

  allrw @mkcv_cbv_substc_same.
  allrw @mkc_var_substc.

  eapply cequivc_trans;
    [|apply cequivc_sym; apply cequivc_mkc_less_twice_false].
  rewrite mkcv_cont1_bot.
  rewrite mkc_zero_eq; rewrite mkc_nat_eq.
  apply cequivc_cbv_less_bot.
Qed.

Lemma bar_induction_cterm_meta2 {o} :
  forall lib Q P (B X : @CTerm o) v,
    barind_nout_bar lib Q B v
    -> barind_nout_imp lib Q P B X
    -> barind_nout_ind lib P X v
    -> nout_on_seq lib P X 0 (cbv_emseqc v).
Proof.
  introv bar imp ind.
  pose proof (classic (nout_on_seq lib P X 0 (cbv_emseqc v))) as ni.
  repndors; auto.
  provefalse.

  apply barind_nout_ind_implies_cont in ind.
  apply barind_nout_ind_cont_implies_cont2 in ind.
  apply barind_nout_ind_cont2_implies_cont3 in ind.
  unfold barind_nout_ind_cont3 in ind; exrepnd.
  rename ind0 into ind.

  pose proof (seq_normalizable_cbv_emseqc_0 lib v) as nc.

  remember (nout_alpha lib P X (cbv_emseqc v) v nc ni f ind) as g.
  remember (fun m => nout_kseq_NA_nout (g m)) as s.

  assert (forall n, eq_kseq_nout lib (ntseqc2ntseq s) (nout_kseq_NA_seq (g n)) n) as e.
  { introv.
    apply implies_equality_natk2nout2; introv ltm.
    subst.
    exists (nout_kseq_NA_cterm (nout_alpha lib P X (cbv_emseqc v) v nc ni f ind m)).
    dands; spcast; eauto 3 with slow.

    - eapply cequivc_trans;[apply cequivc_beta_ntseqc2ntseq|].
      simpl; auto.

    - pose proof (nout_alpha_prop1 lib P X (cbv_emseqc v) v nc ni f ind n (S m)) as q.
      autodimp q hyp; try omega.
      apply (equality_natk2nout_implies lib m) in q; try omega.
      apply cequiv_stable; exrepnd; spcast.

      apply cequivc_sym in q1.
      eapply cequivc_trans in q1;[|exact q2].
      clear q2.
      eapply cequivc_trans;[apply cequivc_sym;exact q1|].
      clear q1.
      simpl.

      remember (nout_alpha lib P X (cbv_emseqc v) v nc ni f ind m) as am.
      unfold nout_kseq_NA in am; exrepnd; simphyps.
      rw @nout_kseq_NA_seq_mk_nout_kseq_NA.
      unfold update_seq_nout.
      eapply cequivc_trans;[apply cequivc_beta|].
      allrw @mkcv_inteq_substc.
      allrw @mkcv_apply_substc.
      allrw @mkc_var_substc.
      allrw @csubst_mk_cv.
      eapply cequivc_trans;[apply cequivc_mkc_inteq_nat|].
      boolvar; auto; try omega.
  }

  pose proof (bar (ntseqc2ntseq s)) as b.
  autodimp b hyp; eauto 3 with slow.

  exrepnd.
  rename b0 into b.

  apply imp in b;[|apply implies_is_kseq_nout_seq2kseq; eauto 3 with slow].

  induction m; allsimpl.

  {
    pose proof (eq_kseq_nout_0 lib (ntseqc2ntseq s) (cbv_emseqc v)) as h1.
    apply (seq2kseq_prop2_nout _ v) in h1.
    eapply cequivc_preserves_nout_on_seq in b;[|exact h1]; auto.
    eapply cequivc_preserves_nout_on_seq in b;[|apply cequivc_sym;exact nc]; auto.
  }

  pose proof (e (S m)) as q1.
  apply (seq2kseq_prop2_nout _ v) in q1.

  eapply cequivc_preserves_nout_on_seq in b;[|exact q1].

  pose proof (e m) as q2.
  apply (seq2kseq_prop2_nout _ v) in q2.

  eapply cequivc_preserves_not_nout_on_seq in IHm;[|exact q2].
  clear q1 q2 e.

  subst; allsimpl.
  remember (nout_alpha lib P X (cbv_emseqc v) v nc ni f ind m) as am.
  unfold nout_kseq_NA in am; exrepnd; allsimpl.

  remember (f (mk_nout_seq_NA (S m) s am0 am1)) as fn.

  assert (eq_kseq_nout lib (update_seq_nout s (S m) (cnterm2cterm fn) v) s (S m)) as ee1.
  { unfold eq_kseq_nout.
    apply implies_equality_natk2nout2; introv ltm1.
    dup am0 as e.
    eapply member_natk2nout_implies in e;[|exact ltm1]; exrepnd; spcast.
    exists u0; dands; spcast; auto;[].
    unfold update_seq_nout.
    eapply cequivc_trans;[apply cequivc_beta|].
    allrw @mkcv_inteq_substc.
    allrw @mkcv_apply_substc.
    allrw @mkc_var_substc.
    allrw @csubst_mk_cv.
    eapply cequivc_trans;[apply cequivc_mkc_inteq_nat|].
    boolvar; tcsp; GC; try omega.
  }

  apply (seq2kseq_prop2_nout _ v) in ee1.
  eapply cequivc_preserves_nout_on_seq in b;[|exact ee1].
  clear ee1.

  unfold seq_normalizable in am2.
  eapply cequivc_preserves_nout_on_seq in b;
    [|apply cequivc_sym;exact am2].
  sp.
Qed.

Lemma implies_cequivc_update_seq_nout {o} :
  forall lib (t : @CTerm o) k a b v,
    cequivc lib a b
    -> cequivc lib (update_seq_nout t k a v) (update_seq_nout t k b v).
Proof.
  introv ceq.
  unfold update_seq_nout.
  apply implies_cequivc_lam; introv.
  allrw @mkcv_inteq_substc.
  allrw @mkcv_apply_substc.
  allrw @mkc_var_substc.
  allrw @csubst_mk_cv.
  apply cequivc_mkc_inteq; auto.
Qed.

Lemma eq_kseq_nout_update2 {o} :
  forall lib (s1 s2 : @CTerm o) (n : nat) (u : CTerm) (v : NVar),
    noutokensc u
    -> eq_kseq_nout lib s1 s2 n
    -> eq_kseq_nout
         lib
         (update_seq_nout s1 n u v)
         (update_seq_nout s2 n u v)
         (S n).
Proof.
  introv nout i.
  allunfold @eq_kseq_nout.
  unfold update_seq.
  apply implies_equality_natk2nout2.
  introv ltm.

  destruct (deq_nat m n) as [d|d]; subst.

  - exists u.
    dands; eauto 3 with slow; tcsp; spcast;[|].

    + eapply cequivc_trans;[apply cequivc_beta|].
      allrw @mkcv_inteq_substc.
      allrw @mkcv_apply_substc.
      allrw @mkc_var_substc.
      allrw @csubst_mk_cv.
      eapply cequivc_trans;[apply cequivc_mkc_inteq_nat|].
      boolvar; tcsp.

    + eapply cequivc_trans;[apply cequivc_beta|].
      allrw @mkcv_inteq_substc.
      allrw @mkcv_apply_substc.
      allrw @mkc_var_substc.
      allrw @csubst_mk_cv.
      eapply cequivc_trans;[apply cequivc_mkc_inteq_nat|].
      boolvar; tcsp.

  - pose proof (equality_natk2nout_implies lib m s1 s2 n) as h.
    repeat (autodimp h hyp); try omega;[].
    exrepnd; spcast.
    exists u0.
    dands; spcast; auto.

    + eapply cequivc_trans;[apply cequivc_beta|].
      allrw @mkcv_inteq_substc.
      allrw @mkcv_apply_substc.
      allrw @mkc_var_substc.
      allrw @csubst_mk_cv.
      eapply cequivc_trans;[apply cequivc_mkc_inteq_nat|].
      boolvar; tcsp; GC.

    + eapply cequivc_trans;[apply cequivc_beta|].
      allrw @mkcv_inteq_substc.
      allrw @mkcv_apply_substc.
      allrw @mkc_var_substc.
      allrw @csubst_mk_cv.
      eapply cequivc_trans;[apply cequivc_mkc_inteq_nat|].
      boolvar; tcsp; GC.
Qed.

Lemma lsubstc_cbv_emseq {o} :
  forall v w (s : @CSub o) c, lsubstc (cbv_emseq v) w s c = cbv_emseqc v.
Proof.
  introv.
  apply cterm_eq; simpl.
  unfold cbv_emseq, csubst; simpl.
  unflsubst; simpl.
  autorewrite with slow; auto.
Qed.
Hint Rewrite @lsubstc_cbv_emseq : slow.


Require Import Category.Lib.
Require Import Category.Theory.Functor.
Require Import Category.Structure.Terminal.
Require Import Category.Structure.Limit.
Require Import Category.Instance.Cones.

Generalizable All Variables.

(* A limit is a terminal object in the category of cones. *)
Program Definition Limit_Cones `(F : J ⟶ C) `{T : @Terminal (Cones F)} :
  Limit F := {|
  limit_cone := @terminal_obj _ T;
  ump_limits := fun N =>
    {| unique_obj := `1 @one _ T N
     ; unique_property := `2 @one _ T N
     ; uniqueness       := fun v H => @one_unique _ T N (@one _ T N) (v; H) |}
|}.


From Categories Require Import Category.Main.
From Categories Require Import Ext_Cons.Prod_Cat.Prod_Cat Ext_Cons.Prod_Cat.Operations.
From Categories Require Import Functor.Main.
From Categories Require Import Functor.Representable.Hom_Func Functor.Representable.Hom_Func_Prop.
From Categories Require Import NatTrans.NatTrans NatTrans.NatIso.
From Categories Require Import Adjunction.Adjunction.

Local Open Scope functor_scope.

Section Hom_Adj_Duality.
  Context {C D : Category} {F : C –≻ D} {G : D –≻ C} (adj : F ⊣_hom G).

  (** Duality for hom adjunctions. *)
  Definition Hom_Adjunct_Duality : G^op ⊣_hom F^op :=
    (Prod_Func_Hom_Func (adj⁻¹))
  .

End Hom_Adj_Duality.

Section Adj_Duality.
  Context {C D : Category} {F : C –≻ D} {G : D –≻ C} (adj : F ⊣ G).

  (** Duality for adjunctions. It follows from Hom_Adjunct_Duality. *)
  Definition Adjunct_Duality : G^op ⊣ F^op :=
    (Hom_Adj_to_Adj (Hom_Adjunct_Duality (Adj_to_Hom_Adj adj)))
  .

End Adj_Duality.


Require Import SetoidClass.

Module Type Atomics.
  Parameter Atomic : Set.
End Atomics.

Module Type BasicSyntaxT (Import ats : Atomics).
Inductive Syntax : Set :=
  | atom :> Atomic -> Syntax
  | skip : Syntax
  | sequence : Syntax -> Syntax -> Syntax
  | choice : Syntax -> Syntax -> Syntax
  | parallel : Syntax -> Syntax -> Syntax
  | loop : Syntax -> Syntax.
Infix ";;" := sequence (at level 30, right associativity)
        : bsyntax_scope.
Infix "||" := parallel
        : bsyntax_scope.
Infix "+" := choice
        : bsyntax_scope.
Notation "(  x )*" := (loop x) : bsyntax_scope.
Open Scope bsyntax_scope.
End BasicSyntaxT.

Module BasicSyntax (Import ats : Atomics) : BasicSyntaxT ats.
Inductive Syntax : Set :=
  | atom :> Atomic -> Syntax
  | skip : Syntax
  | sequence : Syntax -> Syntax -> Syntax
  | choice : Syntax -> Syntax -> Syntax
  | parallel : Syntax -> Syntax -> Syntax
  | loop : Syntax -> Syntax.
Infix ";;" := sequence (at level 30, right associativity)
        : bsyntax_scope.
Infix "||" := parallel
        : bsyntax_scope.
Infix "+" := choice
        : bsyntax_scope.
Notation "(  x )*" := (loop x) : bsyntax_scope.
Open Scope bsyntax_scope.
End BasicSyntax.

(* A state transformer is a relation on states that respects
   the setoid equivalence *)
Record ST {A} `{Setoid A} :=
  { st_trans :> A -> A -> Prop;
     st_morph : Proper (equiv ==> equiv ==> iff) st_trans
  }.

Instance st_trans_morph (st : ST) :
    Proper (equiv ==> equiv ==> iff) st.
apply st_morph.
Qed.

Module Type StateTransformers (Import ats : Atomics).
(* Set of states to interpret commands over *)
Parameter State : Set.
Declare Instance state_setoid : Setoid State.

(* Interpretation of atomic commands *)
Parameter interp : Atomic -> ST (A:=State).
Local Coercion interp : Atomic >-> ST.

End StateTransformers.

Module OperationalSemantics (Import ats : Atomics) (Import bs : BasicSyntaxT ats)
        (Import sts : StateTransformers ats).

Inductive Label :=
	| atm : Atomic -> Label
	| id : Label.

Local Coercion atm : Atomic >-> Label.

Definition st_equiv : ST:= {| st_trans := equiv |}.

Instance st_equiv_equiv : Equivalence st_equiv.
 unfold st_equiv.
 intuition.
  repeat intro.
  simpl in *.
  rewrite H; trivial.
Qed.

Local Coercion interp : Atomic >-> ST.

Definition lifted_interp l : ST :=
   match l with
   | id => st_equiv
   | atm a => a
   end.

Coercion lifted_interp : Label >-> ST.

(* Milner-style labelled operational semantics *)

Inductive los : Label -> Syntax -> Syntax -> Prop :=
  | los_atom : forall (a : Atomic), los a a skip
  | los_seq_left : forall a C1 C1' C2, los a C1 C1' ->
                 los a (C1 ;; C2) (C1' ;; C2)
  | los_seq_skip : forall C2, los id (skip ;; C2) C2
  | los_choice_left : forall C1 C2, los id (C1 + C2) C1
  | los_choice_right : forall C1 C2, los id (C1 + C2) C2
  | los_par_left : forall a C1 C1' C2, los a C1 C1' ->
                 los a (C1 || C2) (C1' || C2)
  | los_par_right : forall a C1 C2 C2', los a C2 C2' ->
                 los a (C1 || C2) (C1 || C2')
  | los_par_lskip : forall C, los id (skip || C) C
  | los_par_rskip : forall C, los id (C || skip) C
  | los_loop_loop : forall C, los id (C)* (C ;; (C)*)
  | los_loop_skip : forall C, los id (C)* skip.

Notation "x -[ a ]-> y" := (los a x y) (at level 70).

(* Stateful semantics *)

(*Definition ProgState := (Syntax * State)%type.*)

Inductive osms : Syntax -> State ->
        Syntax -> State -> Prop :=
  | osms_refl : forall C s, osms C s C s
  | osms_step : forall C1 s1 C2 s2 C3 s3 a,
          C1 -[ a ]-> C2 -> a s1 s2 ->
          osms C2 s2 C3 s3 ->
              osms C1 s1 C3 s3.

(*Infix "~>*" := osms (at level 75).*)
Notation "[ C , s ] ~>* [ D , t ]" :=
          (osms C s D t) (at level 75).

End OperationalSemantics.

(* It's nice to know that your module types are inhabited *)

Module TrivialAtomics <: Atomics.
  Definition Atomic := unit.
End TrivialAtomics.

Module TrivialSTs <: (StateTransformers TrivialAtomics).
  Import TrivialAtomics.
  Definition idat := tt.
  Definition State := unit.
  Instance state_setoid : Setoid State := {equiv:=eq}.
  Definition interp (a:Atomic) : ST (A:=State).
    apply Build_ST with equiv.
    repeat intro.
    rewrite H, H0; reflexivity.
  Defined.
  Proposition idat_id : st_trans (interp idat) = equiv.
    cbv; reflexivity.
  Qed.
End TrivialSTs.

Module TrivialSyntax := BasicSyntax TrivialAtomics.
Module TrivialOpSem := OperationalSemantics TrivialAtomics TrivialSyntax TrivialSTs.
(* Import TrivialOpSem. *)


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj25synthconj5 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (Succ (plus (mult lv0 lv1) lv2)) (plus (mult lv0 (plus Zero (Succ lv1))) (plus Zero (Succ lv1)))).
Admitted.
QuickChick conj25synthconj5.


From Undecidability.L Require Import L.
From Undecidability.L.Datatypes Require Import LProd LTerm LBool.
From Complexity.Complexity Require Import NP Definitions Monotonic Subtypes.
From Undecidability.L.Functions Require Import Size.

Local Unset Implicit Arguments.
Import L_Notations.

Section GenNP.
  Context (X__cert : Type) `{R__cert : encodable X__cert}.

  Definition GenNP' : term*nat*nat -> Prop :=
               (fun '(s, maxSize, steps (*in unary*)) =>
                  exists (c:X__cert), size (enc c) <= maxSize
                               /\ exists t, app s (enc c) ⇓(<=steps) t).

  (* This subset is the one that is already NP-hard:
  procedures such that:
  - if any certificate is valid, then a small one is valid
  - For small certificates, we do not need much time *)
  Definition LHaltsOrDiverges : term*nat*nat -> Prop :=
    fun '(s, maxSize, steps (*in unary*)) =>
      proc s
      /\ (forall (c:X__cert) k t, s (enc c) ⇓(k) t -> exists (c':X__cert), size (enc c') <= maxSize /\ s (enc c') ⇓ t)
      /\ (forall (c:X__cert), size (enc c) <= maxSize -> forall k t, s (enc c) ⇓(k) t -> k <= steps).

  Definition GenNP : {x | LHaltsOrDiverges x} -> Prop :=
    restrictBy LHaltsOrDiverges GenNP'.

End GenNP.


Require Import JMeq.
Require Export CommaCategoryProjection SmallCat Duals FunctorCategory.
Require Import Common Notations DefinitionSimplification DiscreteCategory FEqualDep DefinitionSimplification ExponentialLaws FunctorProduct ProductLaws CanonicalStructureSimplification.

Set Implicit Arguments.

Generalizable All Variables.

Set Asymmetric Patterns.

Set Universe Polymorphism.

Local Open Scope category_scope.

Local Ltac rewrite_step :=
  (progress repeat rewrite LeftIdentity in * )
    || (progress repeat rewrite RightIdentity in * )
    || (progress repeat rewrite @LeftIdentityFunctor in * )
    || (progress repeat rewrite @RightIdentityFunctor in * )
    || (progress (repeat rewrite Associativity; (reflexivity || apply f_equal)))
    || (progress (repeat rewrite <- Associativity; apply f_equal2; trivial; [])).

Local Ltac quick_step :=
  ((progress repeat subst)
     || (apply sig_eq; simpl)
     || apply f_equal
     || (apply f_equal2; trivial; []));
  trivial.

Local Ltac pre_anihilate :=
  subst_body;
  repeat intro; simpl in *;
  repeat quick_step;
  simpl in *;
  destruct_head_hnf @CommaSpecializedCategory_Morphism;
  destruct_head_hnf @CommaSpecializedCategory_Object;
  destruct_sig;
  subst_body;
  unfold Object in *;
  simpl in *;
  trivial.

Local Ltac slice_step :=
  match goal with
    | _ => apply Functor_eq; simpl; intros; pre_anihilate
    | [ |- @JMeq (sig _) _ (sig _) _ ] => apply sig_JMeq; pre_anihilate
    | [ |- JMeq (?f ?x) (?f ?y) ] =>
      apply (@f_equal1_JMeq _ _ x y f); pre_anihilate
    | [ |- JMeq (?f ?x) (?g ?y) ] =>
      apply (@f_equal_JMeq _ _ _ _ x y f g); pre_anihilate
  end.

Local Ltac step :=
  (quick_step
     || rewrite_step
     || (progress auto 1 with category)
     || slice_step);
  trivial.

Local Ltac anihilate := pre_anihilate; repeat step.

Local Ltac induced_step :=
  reflexivity
    || (try_associativity ltac:(rewrite <- Commutes))
    || (try_associativity ltac:(apply f_equal))
    || (match goal with
          | [ H : _ = _ |- _ = _ ] => try_associativity ltac:(rewrite H)
        end).

Local Ltac induced_anihilate :=
  unfold Object in *;
  simpl in *;
  destruct_head @prod;
  simpl in *;
  pre_anihilate;
  repeat induced_step.

Section CommaCategoryInducedFunctor.
  Context `(A : @SpecializedCategory objA).
  Context `(B : @SpecializedCategory objB).
  Context `(C : @SpecializedCategory objC).

  Let CommaCategoryInducedFunctor_ObjectOf s d (m : Morphism ((OppositeCategory (C ^ A)) * (C ^ B)) s d)
      (x : fst s ↓ snd s) : (fst d ↓ snd d)
    := existT _
              (projT1 x)
              (Compose ((snd m) (snd (projT1 x))) (Compose (projT2 x) ((fst m) (fst (projT1 x))))) :
         CommaSpecializedCategory_ObjectT (fst d) (snd d).

  Let CommaCategoryInducedFunctor_MorphismOf s d m s0 d0 (m0 : Morphism (fst s ↓ snd s) s0 d0) :
    Morphism (fst d ↓ snd d)
             (@CommaCategoryInducedFunctor_ObjectOf s d m s0)
             (@CommaCategoryInducedFunctor_ObjectOf s d m d0).
    refine (_ : CommaSpecializedCategory_MorphismT _ _); subst_body; simpl in *.
    exists (projT1 m0);
      simpl in *; clear.
    abstract induced_anihilate.
  Defined.

  Let CommaCategoryInducedFunctor' s d (m : Morphism ((OppositeCategory (C ^ A)) * (C ^ B)) s d) :
    SpecializedFunctor (fst s ↓ snd s) (fst d ↓ snd d).
    refine (Build_SpecializedFunctor (fst s ↓ snd s) (fst d ↓ snd d)
                                     (@CommaCategoryInducedFunctor_ObjectOf s d m)
                                     (@CommaCategoryInducedFunctor_MorphismOf s d m)
                                     _
                                     _
           );
    subst_body; simpl; clear;
    (* admit. *)
    abstract pre_anihilate. (* TODO(jgross): speed this up :-( *)
  Defined.

  Let CommaCategoryInducedFunctor'' s d (m : Morphism ((OppositeCategory (C ^ A)) * (C ^ B)) s d) :
    SpecializedFunctor (fst s ↓ snd s) (fst d ↓ snd d).
    simpl_definition_by_tac_and_exact (@CommaCategoryInducedFunctor' s d m) ltac:(subst_body; eta_red).
  Defined.

  Definition CommaCategoryInducedFunctor s d (m : Morphism ((OppositeCategory (C ^ A)) * (C ^ B)) s d) :
    SpecializedFunctor (fst s ↓ snd s) (fst d ↓ snd d)
    := Eval cbv beta iota zeta delta [CommaCategoryInducedFunctor''] in @CommaCategoryInducedFunctor'' s d m.
End CommaCategoryInducedFunctor.

Section SliceCategoryInducedFunctor.
  Context `(C : @SpecializedCategory objC).

  Section Slice_Coslice.
    Context `(D : @SpecializedCategory objD).

    (* TODO(jgross): See if this can be recast as an exponential law functor about how Cat ^ 1 is isomorphic to Cat, or something *)
    Definition SliceCategoryInducedFunctor_NT s d (m : Morphism D s d) :
      SpecializedNaturalTransformation (FunctorFromTerminal D s)
                                       (FunctorFromTerminal D d).
      exists (fun _ : unit => m).
      simpl; intros; clear;
      abstract (autorewrite with category; reflexivity).
    Defined.

    Variable F : SpecializedFunctor C D.
    Variable a : D.

    Section Slice.
      Local Notation "F ↓ A" := (SliceSpecializedCategory A F) : category_scope.

      Let SliceCategoryInducedFunctor' F' a' (m : Morphism D a a') (T : SpecializedNaturalTransformation F' F) :
        SpecializedFunctor (F ↓ a) (F' ↓ a').
        functor_simpl_abstract_trailing_props (CommaCategoryInducedFunctor (s := (F, FunctorFromTerminal D a))
                                                                       (d := (F', FunctorFromTerminal D a'))
                                                                       (T, @SliceCategoryInducedFunctor_NT a a' m)).
      Defined.
      Definition SliceCategoryInducedFunctor F' a' (m : Morphism D a a') (T : SpecializedNaturalTransformation F' F) :
        SpecializedFunctor (F ↓ a) (F' ↓ a')
        := Eval hnf in @SliceCategoryInducedFunctor' F' a' m T.

      Definition SliceCategoryNTInducedFunctor F' T := @SliceCategoryInducedFunctor F' a (Identity _) T.
      Definition SliceCategoryMorphismInducedFunctor a' m := @SliceCategoryInducedFunctor F a' m (IdentityNaturalTransformation _).
    End Slice.

    Section Coslice.
      Local Notation "A ↓ F" := (CosliceSpecializedCategory A F) : category_scope.

      Let CosliceCategoryInducedFunctor' F' a' (m : Morphism D a' a) (T : SpecializedNaturalTransformation F F') :
        SpecializedFunctor (a ↓ F) (a' ↓ F').
        functor_simpl_abstract_trailing_props (CommaCategoryInducedFunctor (s := (FunctorFromTerminal D a, F))
                                                                       (d := (FunctorFromTerminal D a', F'))
                                                                       (@SliceCategoryInducedFunctor_NT a' a m, T)).
      Defined.
      Definition CosliceCategoryInducedFunctor F' a' (m : Morphism D a' a) (T : SpecializedNaturalTransformation F F') :
        SpecializedFunctor (a ↓ F) (a' ↓ F')
        := Eval hnf in @CosliceCategoryInducedFunctor' F' a' m T.

      Definition CosliceCategoryNTInducedFunctor F' T := @CosliceCategoryInducedFunctor F' a (Identity _) T.
      Definition CosliceCategoryMorphismInducedFunctor a' m := @CosliceCategoryInducedFunctor F a' m (IdentityNaturalTransformation _).
    End Coslice.
  End Slice_Coslice.

  Definition SliceCategoryOverInducedFunctor a a' (m : Morphism C a a') : SpecializedFunctor (C / a) (C / a')
    := Eval hnf in SliceCategoryMorphismInducedFunctor _ _ _ m.
  Definition CosliceCategoryOverInducedFunctor a a' (m : Morphism C a' a) : SpecializedFunctor (a \ C) (a' \ C)
    := Eval hnf in CosliceCategoryMorphismInducedFunctor _ _ _ m.
End SliceCategoryInducedFunctor.

Section LocallySmallCatOverInducedFunctor.
  (* Let's do this from scratch so we get better polymorphism *)
  Let C := LocallySmallCat.
  (*Local Opaque LocallySmallCat.*)

  Let LocallySmallCatOverInducedFunctor_ObjectOf a a' (m : Morphism C a a') : C / a -> C / a'.
    refine (fun x => existT (fun αβ : _ * unit => Morphism C (fst αβ) a')
                            (projT1 x)
                            _ :
                       CommaSpecializedCategory_ObjectT (IdentityFunctor C) (FunctorFromTerminal C a')).
    functor_simpl_abstract_trailing_props (Compose m (projT2 x)).
  Defined.
  Let OverLocallySmallCatInducedFunctor_ObjectOf a a' (m : Morphism C a' a) : a \ C -> a' \ C.
    refine (fun x => existT (fun αβ : unit * _ => Morphism C a' (snd αβ))
                            (projT1 x)
                            _ :
                       CommaSpecializedCategory_ObjectT (FunctorFromTerminal C a') (IdentityFunctor C)).
    functor_simpl_abstract_trailing_props (Compose (projT2 x) m).
  Defined.

  Let LocallySmallCatOverInducedFunctor_MorphismOf a a' (m : Morphism C a a') s d (m0 : Morphism (C / a) s d) :
    Morphism (C / a') (@LocallySmallCatOverInducedFunctor_ObjectOf _ _ m s) (@LocallySmallCatOverInducedFunctor_ObjectOf _ _ m d).
    refine (_ : CommaSpecializedCategory_MorphismT _ _).
    exists (projT1 m0).
      subst_body; simpl in *; clear.
    abstract anihilate.
  Defined.
  Let OverLocallySmallCatInducedFunctor_MorphismOf a a' (m : Morphism C a' a) s d (m0 : Morphism (a \ C) s d) :
    Morphism (a' \ C) (@OverLocallySmallCatInducedFunctor_ObjectOf _ _ m s) (@OverLocallySmallCatInducedFunctor_ObjectOf _ _ m d).
    refine (_ : CommaSpecializedCategory_MorphismT _ _).
    exists (projT1 m0);
      subst_body; simpl in *; clear.
    abstract anihilate.
  Defined.

  Local Opaque LocallySmallCat.
  Let LocallySmallCatOverInducedFunctor'' a a' (m : Morphism C a a') : SpecializedFunctor (C / a) (C / a').
    refine (Build_SpecializedFunctor (C / a) (C / a')
                                     (@LocallySmallCatOverInducedFunctor_ObjectOf _ _ m)
                                     (@LocallySmallCatOverInducedFunctor_MorphismOf _ _ m)
                                     _
                                     _
           );
    subst_body; simpl; clear;
    (* admit. *)
    abstract anihilate.
  Defined.
  Let OverLocallySmallCatInducedFunctor'' a a' (m : Morphism C a' a) : SpecializedFunctor (a \ C) (a' \ C).
    refine (Build_SpecializedFunctor (a \ C) (a' \ C)
                                     (@OverLocallySmallCatInducedFunctor_ObjectOf _ _ m)
                                     (@OverLocallySmallCatInducedFunctor_MorphismOf _ _ m)
                                     _
                                     _
           );
    subst_body; simpl; clear;
    (* admit. *) abstract anihilate.
  Defined.

  Let LocallySmallCatOverInducedFunctor''' a a' (m : Morphism C a a') : SpecializedFunctor (C / a) (C / a').
    simpl_definition_by_tac_and_exact (@LocallySmallCatOverInducedFunctor'' _ _ m) ltac:(subst_body; eta_red).
  Defined.
  Let OverLocallySmallCatInducedFunctor''' a a' (m : Morphism C a' a) : SpecializedFunctor (a \ C) (a' \ C).
    simpl_definition_by_tac_and_exact (@OverLocallySmallCatInducedFunctor'' _ _ m) ltac:(subst_body; eta_red).
  Defined.

  Definition LocallySmallCatOverInducedFunctor a a' (m : Morphism C a a') : SpecializedFunctor (C / a) (C / a')
    := Eval cbv beta iota zeta delta [LocallySmallCatOverInducedFunctor'''] in @LocallySmallCatOverInducedFunctor''' _ _ m.
  Definition OverLocallySmallCatInducedFunctor a a' (m : Morphism C a' a) : SpecializedFunctor (a \ C) (a' \ C)
    := Eval cbv beta iota zeta delta [OverLocallySmallCatInducedFunctor'''] in @OverLocallySmallCatInducedFunctor''' _ _ m.
  Local Transparent LocallySmallCat.
End LocallySmallCatOverInducedFunctor.


From fae_gtlc_mu.refinements.static_gradual Require Export logical_relation compat_cast.defs compat_easy.
From fae_gtlc_mu.refinements.static_gradual.compat_cast Require Export
     between_rec prod_prod sum_sum arrow_arrow identity tau_star ground_star tau_star star_tau star_ground.

Section compat_cast_all.
  Context `{!implG Σ,!specG Σ}.

  (* Proof of back_cast_ar (the slightly modified version of lemma 4.7 in the paper defined in defs.v) *)
  Lemma back_cast_ar_all {A} {τi τf} (pC : alternative_consistency A τi τf) : back_cast_ar pC.
  Proof.
    (* By induction on the alternative consistency relation *)
    induction pC; (* the different inductive cases are proven in the other files in this directory *)
      eauto using back_cast_ar_star_ground,
      back_cast_ar_ground_star, back_cast_ar_tau_star,
      back_cast_ar_star_tau,
      back_cast_ar_base_base,
      back_cast_ar_star_star,
      back_cast_ar_sum_sum,
      back_cast_ar_prod_prod,
      back_cast_ar_arrow_arrow,
      back_cast_ar_trec_trec_expose,
      back_cast_ar_trec_trec_use.
  Qed.

  Notation "'` H" := (bin_log_related_alt H) (at level 8).

  (* Proof of the actual compatibility lemma of casts (lemma 4.7 in paper) *)
  Lemma bin_log_related_back_cast Γ e e' τi τf (pC : alternative_consistency [] τi τf)
      (IHHtyped : Γ ⊨ e ≤log≤ e' : τi) :
    Γ ⊨ 𝓕c pC [] e ≤log≤ Cast e' τi τf : τf.
  Proof.
    iIntros (vvs ei) "#[Hρ HΓ]"; iIntros (K) "Hj /=".
    rewrite 𝓕c_closed; try auto. rewrite 𝓕c_rewrite.
    (** bringing e and e' to related values v and v' *)
    iApply (wp_bind (ectx_language.fill [stlc_mu.lang.AppRCtx _])).
    iApply (wp_wand with "[Hj]"). iApply ('`IHHtyped _ _ (CastCtx τi τf :: K)). iFrame. auto.
    iIntros (v). iDestruct 1 as (v') "[Hv' Hvv']". simpl.
    rewrite -𝓕c_rewrite.
    (** applying back_cast_ar_all *)
    iApply (wp_wand with "[-]").
    iApply ((back_cast_ar_all pC) with "[-]").
    iSplitR. unfold rel_cast_functions. iSplit; auto.
    iSplitL "Hvv'". auto. auto.
    clear v v'.
    iIntros (v). iDestruct 1 as (v') "[Hv' Hvv']".
    iExists v'.
    auto.
  Qed.

  (** Proof that divergence is related to everything *)
  Lemma bin_log_related_omega Γ e' τ :
    Γ ⊨ Ω ≤log≤ e' : τ.
  Proof.
    iIntros (vvs ρ) "#[Hρ HΓ]"; iIntros (K) "Hj /=".
    by iApply wp_Ω.
  Qed.

End compat_cast_all.