From Coq Require Import ZArith .
From Common Require Import Var .
From mQhasm Require Import zDSL zRadix .
From mathcomp Require Import seq .

Open Scope N_scope.
Open Scope zdsl_scope.

Definition fe25519_mul121666 : program :=

let         wsize :=   64%nat in

let crypto_sign_ed25519_amd64_51_121666_213 :=
                       996687872%Z in (* from consts *)
let crypto_sign_ed25519_amd64_51_REDMASK51_width :=
                       51 in        (* 51 bits *)

let            x0 :=   0 in     (* *[uint64 *](xp +  0) *)
let            x1 :=   1 in     (* *[uint64 *](xp +  8) *)
let            x2 :=   2 in     (* *[uint64 *](xp + 16) *)
let            x3 :=   3 in     (* *[uint64 *](xp + 24) *)
let            x4 :=   4 in     (* *[uint64 *](xp + 32) *)

let            z0 :=   5 in     (* *[uint64 *](rp +  0) *)
let            z1 :=   6 in     (* *[uint64 *](rp +  8) *)
let            z2 :=   7 in     (* *[uint64 *](rp + 16) *)
let            z3 :=   8 in     (* *[uint64 *](rp + 24) *)
let            z4 :=   9 in     (* *[uint64 *](rp + 32) *)

let            r0 :=  10 in     (* *[uint64 *](rp +  0) *)
let            r1 :=  11 in     (* *[uint64 *](rp +  8) *)
let            r2 :=  12 in     (* *[uint64 *](rp + 16) *)
let            r3 :=  13 in     (* *[uint64 *](rp + 24) *)
let            r4 :=  14 in     (* *[uint64 *](rp + 32) *)

let           rax :=  20 in
let           rdx :=  21 in

let           tmp := 998 in
let         carry := 999 in

[::

      (* # CPU: Intel(R) Xeon(R) CPU X5675 @ 3.07GHz *)
      (* # RAM: 32GB *)
      (* # Configuration: -c consts -s *)
      (* # With Boolector 1.6.0 (-minisat): ? *)
      (*  *)
      (* int64 rp *)
      (* int64 xp *)
      (*  *)
      (* input rp *)
      (* input xp *)
      (*  *)
      (* int64 r0 *)
      (* int64 r1 *)
      (* int64 r2 *)
      (* int64 r3 *)
      (* int64 r4 *)
      (*  *)
      (* #required for  macro *)
      (* int64 rax *)
      (* int64 rdx *)
      (*  *)
      (*  *)
      (*   #BEGIN MACRO callerregs_declare *)
      (*   int64 caller1 *)
      (*   int64 caller2 *)
      (*   int64 caller3 *)
      (*   int64 caller4 *)
      (*   int64 caller5 *)
      (*   int64 caller6 *)
      (*   int64 caller7 *)
      (*   caller caller1 *)
      (*   caller caller2 *)
      (*   caller caller3 *)
      (*   caller caller4 *)
      (*   caller caller5 *)
      (*   caller caller6 *)
      (*   caller caller7 *)
      (*   stack64 caller1_stack *)
      (*   stack64 caller2_stack *)
      (*   stack64 caller3_stack *)
      (*   stack64 caller4_stack *)
      (*   stack64 caller5_stack *)
      (*   stack64 caller6_stack *)
      (*   stack64 caller7_stack *)
      (*   #END MACRO callerregs_declare *)
      (*  *)
      (*  *)
      (* enter fe25519_mul121666 *)
      (*  *)
      (*  *)
      (*   #BEGIN MACRO callerregs_save *)
      (*   caller1_stack = caller1 *)
      (*   caller2_stack = caller2 *)
      (*   caller3_stack = caller3 *)
      (*   caller4_stack = caller4 *)
      (*   caller5_stack = caller5 *)
      (*   caller6_stack = caller6 *)
      (*   caller7_stack = caller7 *)
      (*   #END MACRO callerregs_save *)
      (*  *)
      (* ################################################################### *)
      (* # Conditions on the inputs: x0 = *[uint64 *](xp +  0), *)
      (* #                           x1 = *[uint64 *](xp +  8), *)
      (* #                           x2 = *[uint64 *](xp + 16), *)
      (* #                           x3 = *[uint64 *](xp + 24), *)
      (* #                           x4 = *[uint64 *](xp + 32), are all in [0,2^64-1] (whole uint64 range) *)
      (* # *)
      (* ################################################################### *)
      (*  *)
      (*  *)
      (*  *)
      (*   #BEGIN MACRO  *)
      (*   rax = *[uint64 *](xp + 0) *)
zAssign rax (zVar x0);
      (*   (uint128) rdx rax = rax * *[uint64 *] &crypto_sign_ed25519_amd64_51_121666_213 *)
zSplit rdx rax (zBinop zMul (zVar rax) (zConst crypto_sign_ed25519_amd64_51_121666_213)) wsize;
      (*   (uint64) rax >>= 13 *)
zSplit rax tmp (zVar rax) 13;
      (*   r0 = rax *)
zAssign r0 (zVar rax);
      (*   r1 = rdx *)
zAssign r1 (zVar rdx);
      (*    *)
      (*   rax = *[uint64 *](xp + 8) *)
zAssign rax (zVar x1);
      (*   (uint128) rdx rax = rax * *[uint64 *] &crypto_sign_ed25519_amd64_51_121666_213 *)
zSplit rdx rax (zBinop zMul (zVar rax) (zConst crypto_sign_ed25519_amd64_51_121666_213)) wsize;
      (*   (uint64) rax >>= 13 *)
zSplit rax tmp (zVar rax) 13;
      (*   r1 += rax *)
zAssign r1 (zBinop zAdd (zVar r1) (zVar rax));
      (*   r2 = rdx *)
zAssign r2 (zVar rdx);
      (*    *)
      (*   rax = *[uint64 *](xp + 16) *)
zAssign rax (zVar x2);
      (*   (uint128) rdx rax = rax * *[uint64 *] &crypto_sign_ed25519_amd64_51_121666_213 *)
zSplit rdx rax (zBinop zMul (zVar rax) (zConst crypto_sign_ed25519_amd64_51_121666_213)) wsize;
      (*   (uint64) rax >>= 13 *)
zSplit rax tmp (zVar rax) 13;
      (*   r2 += rax *)
zAssign r2 (zBinop zAdd (zVar r2) (zVar rax));
      (*   r3 = rdx *)
zAssign r3 (zVar rdx);
      (*    *)
      (*   rax = *[uint64 *](xp + 24) *)
zAssign rax (zVar x3);
      (*   (uint128) rdx rax = rax * *[uint64 *] &crypto_sign_ed25519_amd64_51_121666_213 *)
zSplit rdx rax (zBinop zMul (zVar rax) (zConst crypto_sign_ed25519_amd64_51_121666_213)) wsize;
      (*   (uint64) rax >>= 13 *)
zSplit rax tmp (zVar rax) 13;
      (*   r3 += rax *)
zAssign r3 (zBinop zAdd (zVar r3) (zVar rax));
      (*   r4 = rdx *)
zAssign r4 (zVar rdx);
      (*    *)
      (*   rax = *[uint64 *](xp + 32) *)
zAssign rax (zVar x4);
      (*   (uint128) rdx rax = rax * *[uint64 *] &crypto_sign_ed25519_amd64_51_121666_213 *)
zSplit rdx rax (zBinop zMul (zVar rax) (zConst crypto_sign_ed25519_amd64_51_121666_213)) wsize;
      (*   (uint64) rax >>= 13 *)
zSplit rax tmp (zVar rax) 13;
      (*   r4 += rax *)
zAssign r4 (zBinop zAdd (zVar r4) (zVar rax));
      (*   rdx *= 19 *)
zAssign rdx (zBinop zMul (zVar rdx) (zConst 19%Z));
      (*   r0 += rdx *)
zAssign r0 (zBinop zAdd (zVar r0) (zVar rdx));
      (*   #END MACRO  *)
      (*  *)
      (*   #// var x0 = mem64[xp + 0]@u320 *)
      (*   #//     x1 = mem64[xp + 8]@u320 *)
      (*   #//     x2 = mem64[xp + 16]@u320 *)
      (*   #//     x3 = mem64[xp + 24]@u320 *)
      (*   #//     x4 = mem64[xp + 32]@u320 *)
      (*   #//     lhs = (x0 + x1 * 2**51 + x2 * 2**102 + x3 * 2**153 + x4 * 2**204) * 121666 *)
      (*   #//     rhs = r0@u320 + r1@u320 * 2**51 + r2@u320 * 2**102 + r3@u320 * 2**153 + r4@u320 * 2**204 *)
      (*   #// assert lhs >=u rhs && (lhs - rhs) %u (2**255 - 19) = 0 && *)
      (*   #//        0 <=u r0 <u 2**52 && *)
      (*   #//        0 <=u r1 <u 2**52 && *)
      (*   #//        0 <=u r2 <u 2**52 && *)
      (*   #//        0 <=u r3 <u 2**52 && *)
      (*   #//        0 <=u r4 <u 2**52 *)
      (*  *)
      (* ################################################################### *)
      (* # The following should hold at this point: *)
      (* # *)
      (* # (x0 + 2^51*x1 + 2^102*x2 + 2^153*x3 + 2^204*x4) * 121666 congruent to (r0 + r1*2^51 + r2*2^102 + r3*2^153 + r4*2^204)  [modulo 2^255-19] *)
      (* # *)
      (* # r0l,r1l,r2l,r3l,r4l are all in [0,2^52] *)
      (* # *)
      (* ################################################################### *)
      (*   *)
      (*  *)
      (* *[uint64 *](rp + 0) = r0 *)
zAssign z0 (zVar r0);
      (* *[uint64 *](rp + 8) = r1 *)
zAssign z1 (zVar r1);
      (* *[uint64 *](rp + 16) = r2 *)
zAssign z2 (zVar r2);
      (* *[uint64 *](rp + 24) = r3 *)
zAssign z3 (zVar r3);
      (* *[uint64 *](rp + 32) = r4 *)
zAssign z4 (zVar r4)
      (*  *)
      (*  *)
      (*   #BEGIN MACRO callerregs_restore *)
      (*   caller1 = caller1_stack *)
      (*   caller2 = caller2_stack *)
      (*   caller3 = caller3_stack *)
      (*   caller4 = caller4_stack *)
      (*   caller5 = caller5_stack *)
      (*   caller6 = caller6_stack *)
      (*   caller7 = caller7_stack *)
      (*   #END MACRO callerregs_restore *)
      (*  *)
      (*  *)
      (* leave *)
] .

Definition fe25519_mul121666_inputs : VS.t :=
let            x0 :=   0 in
let            x1 :=   1 in
let            x2 :=   2 in
let            x3 :=   3 in
let            x4 :=   4 in
VSLemmas.OP.P.of_list [:: x0; x1; x2; x3; x4].

Definition fe25519_mul121666_pre : bexp := zTrue.

Definition fe25519_mul121666_post : bexp :=
let            x0 :=   0 in
let            x1 :=   1 in
let            x2 :=   2 in
let            x3 :=   3 in
let            x4 :=   4 in
let            r0 :=  10 in
let            r1 :=  11 in
let            r2 :=  12 in
let            r3 :=  13 in
let            r4 :=  14 in
let        n25519 := 57896044618658097711785492504343953926634992332820282019728792003956564819949%Z in
zEqMod
  (
    (radix51 [::zVar x0; zVar x1; zVar x2; zVar x3; zVar x4])
    @*
    (zConst 121666)
  )
  (radix51 [::zVar r0; zVar r1; zVar r2; zVar r3; zVar r4])
  (zConst n25519).

Definition fe25519_mul121666_spec :=
  {| spre := fe25519_mul121666_pre;
     sprog := fe25519_mul121666;
     spost := fe25519_mul121666_post |}.

From mathcomp Require Import ssreflect eqtype ssrbool.
From mQhasm Require Import zVerify.

Lemma valid_fe25519_mul121666 : valid_zspec (fe25519_mul121666_inputs, fe25519_mul121666_spec).
Proof.
  Time verify_zspec.
  (* *)
Qed.

Close Scope zdsl_scope.
Close Scope N_scope.


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 conj6synthconj4 : forall  (lv0 : natural), (@eq natural (plus Zero lv0) (plus Zero lv0)).
Admitted.
QuickChick conj6synthconj4.


From Formalisation Require Import Nom.

Open Scope N_scope.

Section combinator.

  Context {atom : Type}.

  Definition NomG := @NomG atom.

  Definition is_empty : NomG bool :=
    let! len := length in
    ret (len =? 0).

  Definition all_consuming {X} (p : NomG X) : NomG X :=
    let! v := p in
    let! b := is_empty in
    if b
    then ret v
    else fail.

  Definition cond {X} (b : bool) (c : NomG X) : NomG (option X) :=
    if b
    then
      let! v := c in
      ret (Some v)
    else
      ret None.

  Definition recognize {X} (c : NomG X) : NomG span :=
    let! len_before := length in
    let! len_after := peek (let! _ := c in length) in
    take (len_before - len_after).

  Definition consumed {X} (c: NomG X) : NomG (span * X) :=
    let! len_before := length in
    let! (v, len_after) := peek (let! v := c in
                                 let! len := length in
                                 ret (v, len)) in
    let! s := take (len_before - len_after) in
    ret (s, v).

  Definition eof : NomG unit :=
    let! b := is_empty in
    if b
    then ret ()
    else
      fail.

  Definition flat_map {X Y} := @bind X Y.

  Definition map {X Y} (c : NomG X) (f : X -> Y) : NomG Y :=
    let! v := c in
    ret (f v).

  Definition into {X Y} := @map X Y.

  Definition map_opt {X Y} (c : NomG X) (f : X -> option Y) : NomG Y :=
    let! v := c in
    match f v with
    | Some v => ret v
    | None => fail
    end.

  Definition map_parser {X} (c1 : NomG span) (c2 : NomG X) : NomG X :=
    let! s := c1 in
    scope s c2.

  Definition not {X} (c : NomG X): NomG unit :=
    let! b := alt (let! v := c in ret true) (ret false) in
    if b
    then
      fail
    else
      ret tt.

  Definition opt {X} (c : NomG X): NomG(option X) :=
    alt (let! v := c in ret (Some v)) (ret None).

  Definition rest : NomG span :=
    let! l := length in
    take l.

  Definition rest_len : NomG N := length.

  Definition success {X} : X -> NomG X := ret.

  Definition value {X Y} (val : X) (c : NomG Y) : NomG X :=
    let! _ := c in
    ret val.

  Definition verify {X} (c : NomG X) (b : X -> bool) : NomG X :=
    let! v := c in
    if b v
    then
      ret v
    else
      fail.

End combinator.

Close Scope N_scope.


(* Calls to external decision procedures *)

Require Export ZArith.
Require Export Classical.

(* Zenon *)

(*  Copyright 2004 INRIA  *)
(*  $Id: Dp.v 12337 2009-09-17 15:58:14Z glondu $  *)

Lemma zenon_nottrue :
  (~True -> False).
Proof. tauto. Qed.

Lemma zenon_noteq : forall (T : Type) (t : T),
  ((t <> t) -> False).
Proof. tauto. Qed.

Lemma zenon_and : forall P Q : Prop,
  (P -> Q -> False) -> (P /\ Q -> False).
Proof. tauto. Qed.

Lemma zenon_or : forall P Q : Prop,
  (P -> False) -> (Q -> False) -> (P \/ Q -> False).
Proof. tauto. Qed.

Lemma zenon_imply : forall P Q : Prop,
  (~P -> False) -> (Q -> False) -> ((P -> Q) -> False).
Proof. tauto. Qed.

Lemma zenon_equiv : forall P Q : Prop,
  (~P -> ~Q -> False) -> (P -> Q -> False) -> ((P <-> Q) -> False).
Proof. tauto. Qed.

Lemma zenon_notand : forall P Q : Prop,
  (~P -> False) -> (~Q -> False) -> (~(P /\ Q) -> False).
Proof. tauto. Qed.

Lemma zenon_notor : forall P Q : Prop,
  (~P -> ~Q -> False) -> (~(P \/ Q) -> False).
Proof. tauto. Qed.

Lemma zenon_notimply : forall P Q : Prop,
  (P -> ~Q -> False) -> (~(P -> Q) -> False).
Proof. tauto. Qed.

Lemma zenon_notequiv : forall P Q : Prop,
  (~P -> Q -> False) -> (P -> ~Q -> False) -> (~(P <-> Q) -> False).
Proof. tauto. Qed.

Lemma zenon_ex : forall (T : Type) (P : T -> Prop),
  (forall z : T, ((P z) -> False)) -> ((exists x : T, (P x)) -> False).
Proof. firstorder. Qed.

Lemma zenon_all : forall (T : Type) (P : T -> Prop) (t : T),
  ((P t) -> False) -> ((forall x : T, (P x)) -> False).
Proof. firstorder. Qed.

Lemma zenon_notex : forall (T : Type) (P : T -> Prop) (t : T),
  (~(P t) -> False) -> (~(exists x : T, (P x)) -> False).
Proof. firstorder. Qed.

Lemma zenon_notall : forall (T : Type) (P : T -> Prop),
  (forall z : T, (~(P z) -> False)) -> (~(forall x : T, (P x)) -> False).
Proof. intros T P Ha Hb. apply Hb. intro. apply NNPP. exact (Ha x). Qed.

Lemma zenon_equal_base : forall (T : Type) (f : T), f = f.
Proof. auto. Qed.

Lemma zenon_equal_step :
  forall (S T : Type) (fa fb : S -> T) (a b : S),
  (fa = fb) -> (a <> b -> False) -> ((fa a) = (fb b)).
Proof. intros. rewrite (NNPP (a = b)). congruence. auto. Qed.

Lemma zenon_pnotp : forall P Q : Prop,
  (P = Q) -> (P -> ~Q -> False).
Proof. intros P Q Ha. rewrite Ha. auto. Qed.

Lemma zenon_notequal : forall (T : Type) (a b : T),
  (a = b) -> (a <> b -> False).
Proof. auto. Qed.

Ltac zenon_intro id :=
  intro id || let nid := fresh in (intro nid; clear nid)
.

Definition zenon_and_s := fun P Q a b => zenon_and P Q b a.
Definition zenon_or_s := fun P Q a b c => zenon_or P Q b c a.
Definition zenon_imply_s := fun P Q a b c => zenon_imply P Q b c a.
Definition zenon_equiv_s := fun P Q a b c => zenon_equiv P Q b c a.
Definition zenon_notand_s := fun P Q a b c => zenon_notand P Q b c a.
Definition zenon_notor_s := fun P Q a b => zenon_notor P Q b a.
Definition zenon_notimply_s := fun P Q a b => zenon_notimply P Q b a.
Definition zenon_notequiv_s := fun P Q a b c => zenon_notequiv P Q b c a.
Definition zenon_ex_s := fun T P a b => zenon_ex T P b a.
Definition zenon_notall_s := fun T P a b => zenon_notall T P b a.

Definition zenon_pnotp_s := fun P Q a b c => zenon_pnotp P Q c a b.
Definition zenon_notequal_s := fun T a b x y => zenon_notequal T a b y x.

(* Ergo *)

Set Implicit Arguments.
Section congr.
  Variable t:Type.
Lemma ergo_eq_concat_1 :
  forall (P:t -> Prop) (x y:t),
    P x -> x = y -> P y.
Proof.
  intros; subst; auto.
Qed.

Lemma ergo_eq_concat_2 :
  forall (P:t -> t -> Prop) (x1 x2 y1 y2:t),
    P x1 x2 -> x1 = y1 -> x2 = y2 -> P y1 y2.
Proof.
  intros; subst; auto.
Qed.

End congr.


Require Import STLCSubRec.syntax.
Require Import STLCSubRec.bindings.
Require Import Cpdt.CpdtTactics.
(* Require Import STLCdbj.syn_typing. *)
Require Import Utf8.
Require Import Coq.Strings.String.

(* Implicit Types V:Set. *)

(*
Inductive val (V: Set) : Set :=
  | v_var  : V -> val V
  | v_true : val V
  | v_false : val V
  | v_abs  : exp (inc V) -> val V
with exp (V : Set) : Set :=
  | e_val  : val V -> exp V
  | e_if   : exp V -> exp V -> exp V -> exp V
  | e_app  : exp V -> exp V -> exp V.
   *)

(*
  If we can somehow incoporate evaluation context
  into step, then step can write less boilerplate
*)

Inductive step {V U} : Exp V U -> Exp V U -> Prop :=
   | st_app0: forall T exp_body (v : Exp V U),
      val v ->
       step (e_app  (e_abs T exp_body) v) ((V_subst_exp v) exp_body)
   | st_if1: forall a b,
       step (e_if e_true a b) a
   | st_if2: forall a b,
       step (e_if e_false a b) b
   | st_app1: forall e1 e1' e2,
       step e1 e1' ->
       step (e_app e1 e2) (e_app e1' e2)
   | st_app2: forall e1 e2 e2',
       val e1 ->
       step e2 e2' ->
       step (e_app e1 e2) (e_app e1 e2')
   | st_if3: forall cond cond' a b,
       step cond cond' ->
       step (e_if cond a b) (e_if cond' a b)
   | st_prj0: forall name t' term,
      val t' -> val term ->
      step (e_prj name (e_intsctrcd t' name term)) term
   | st_prj1: forall name1 name2 term t',
      name1 <> name2 ->
      val t' -> val term ->
      step (e_prj name1 (e_intsctrcd t' name2 term)) (e_prj name1 t')
   | st_prj2 : forall name a b,
      step a b ->
      step (e_prj name a) (e_prj name b)
   | st_prj3 : forall name t T,
      step (e_prj name (e_recrcd t T)) (e_prj name ((V_subst_exp (e_recrcd t T)) t))
   | st_intsct0 : forall name a b c,
      step a b ->
      step (e_intsctrcd a name c) (e_intsctrcd b name c)
   | st_intsct1 : forall  name a b c,
      val c ->
      step a b ->
      step (e_intsctrcd c name a) (e_intsctrcd c name b).

Notation "s1 '↝' s2" := (step s1 s2)
      (at level 101).

      Section steps_property.

(* Hint Resolve val_pf_irrelevence. *)
Hint Constructors Exp val.

(* Theorem step_determinstic
{V} {x y : Exp V}
(h0: step x y):
forall z,
 step x z ->
y = z.

Ltac cleanup_impossible:=
  match goal with
  (* | h0 :  val_has_type _ (v_abs _ _ _) ty_bool |- _ => inversion h0 *)
  | [h : step (e_if  (e_var _) _ _) _ |- _] => inversion h
  | [h : step (e_if  (e_abs _ _) _ _) _ |- _] => inversion h

  end.

Ltac destruct_ALL :=
    repeat
      match goal with
      | [h : _ \/ _ |- _ ] => destruct h; subst; eauto
      | [h : _ /\ _ |- _ ] => destruct h; subst; eauto
      | [h : exists _ , _ |- _ ] => destruct h; subst; eauto
      | [h : Some _ = Some _ |- _] => inversion h; subst; eauto
      | [h : {_} + {_} |- _] => destruct h; subst; eauto
      end.

induction h0; try(intros z H;
inversion H; subst; eauto;
try cleanup_impossible; try discriminate; try contradiction;
crush; fail).

admit. intros z H;
inversion H; subst; eauto.
idtac.
rewrite (val_pf_irrelevence v v0); eauto.
match goal with
| [h : context[_ ->  _ = _] |- _] => erewrite h; eauto
end.
Qed. *)

Inductive steps {V U} : Exp V U -> Exp V U -> Prop :=
  | sts_refl : forall x,
      steps x x
  | sts_trans: forall x y z,
      step x y ->
      steps y z ->
      steps x z.

Notation "x '↝¹' y" := (step x y)
      (at level 101).

Notation "x '↝⁺' y" := (steps x y)
      (at level 101).

Ltac cleanup_impossible:=
  match goal with
  (* | h0 :  val_has_type _ (v_abs _ _ _) ty_bool |- _ => inversion h0 *)
  | [h : step (e_if  (e_var _) _ _) _ |- _] => inversion h
  | [h : step (e_if  (e_abs _ _) _ _) _ |- _] => inversion h

  end.

Ltac destruct_ALL :=
    repeat
      match goal with
      | [h : _ \/ _ |- _ ] => destruct h; subst; eauto
      | [h : _ /\ _ |- _ ] => destruct h; subst; eauto
      | [h : exists _ , _ |- _ ] => destruct h; subst; eauto
      | [h : Some _ = Some _ |- _] => inversion h; subst; eauto
      | [h : {_} + {_} |- _] => destruct h; subst; eauto
      | [h : _ + {_} |- _] => destruct h; subst; eauto
      | [h : {_ | _} |- _] => destruct h; subst; eauto
      end.

Definition irreducible {V U} (x : Exp V U) :=
    ~(exists y, step x y).

Lemma irreducible_val:
    forall V U (s: Exp V U),
      val s ->
      irreducible s.
    intros V U s h0.
    induction h0; intros h;
    destruct_ALL; subst; eauto;
    try match goal with
          | h : step _ _  |- _ => inversion h; subst; eauto; try cleanup_impossible; try contradiction; try discriminate
    end.

  Qed.

Hint Constructors step steps Exp val.

  Lemma irreducible_eapp_inv:
    forall V U (a b : Exp V U),
      irreducible (e_app a b) ->
      irreducible a.

      unfold irreducible in *.
  intros V U a b h. intros h1; subst; eauto; destruct_ALL; try contradiction; try discriminate; eauto; crush.
  Qed.

  Lemma irreducible_eif_inv:
    forall V U (a b c : Exp V U),
      irreducible (e_if a b c) ->
      irreducible a.

      unfold irreducible in *.
  intros V U a b c h. intros h1; subst; eauto; destruct_ALL; try contradiction; try discriminate; eauto.
  Qed.

  Hint Resolve irreducible_val irreducible_eapp_inv irreducible_eif_inv.

Theorem syntax_eq_dec_abs:
  forall {V U} (t1: Exp V U),
    (exists T body, t1 = e_abs T body) \/
    (forall T body, ~ t1 = e_abs T body).
  intros V U t1.

  Ltac try_both_side2  :=
    try (left; eauto; crush; fail);
    try (right; intros h; destruct_ALL;
    subst; eauto; try contradiction; try discriminate; try cleanup_impossible; eauto;crush; fail).

  induction t1; subst; eauto; try_both_side2.
Qed.

Theorem syntax_eq_dec_intsctrcd:
  forall {V U} (t : Exp V U),
    (exists t0 name t1, t = e_intsctrcd t0 name t1) \/
    (forall t0 name t1, ~ t = e_intsctrcd t0 name t1).

  intros V U t. induction t; subst; eauto; try_both_side2.
Qed.

Theorem syntax_eq_dec_recrcd:
  forall {V U} (t : Exp V U),
    (exists t0 T, t = e_recrcd t0 T) \/
    (forall t0 T, ~ t = e_recrcd t0 T).

  intros V U t. induction t; subst; eauto; try_both_side2.
Qed.

Lemma irreducible_non_stepping:
  forall {V U} {x y : Exp V U},
    step x y -> ~irreducible x.
  intros V U x y H. intro H1. eauto.
Qed.

Lemma val_not_steppable:
  forall {V U} {x : Exp V U},
    val x ->
    forall {y},
     step x y -> False.
  intros V U x h. induction h; intros;
  try (
  match goal with
  | [h : step _ _ |- _ ] =>
  inversion h; subst; eauto; try contradiction; try discriminate
  end);
  eauto.
Qed.

Hint Extern 1  =>
  match goal with
  | [h1 : irreducible ?x, h2 : step ?x _ |- _]
    => destruct (irreducible_non_stepping h2 h1)
  | [h1 : val ?x, h2 : step ?x _ |- _]
    => destruct (val_not_steppable h1 h2)
  end
.

  Theorem steppable_dec:
    forall V U (t : Exp V U),
      (exists t', step t t') \/ (irreducible t).

Ltac try_both_side  :=
    try (left; eauto; crush; fail);
    try (right; intros h; destruct_ALL;
    match goal with
    | h : step (e_if _ _ _ ) _ |- _ =>
      inversion h; subst
    | h : step (e_app _ _) _ |- _ =>
      inversion h; subst
    | h : step (e_prj _ _) _ |- _ =>
      inversion h; subst
    | h : step (e_intsctrcd _ _ _) _ |- _ =>
      inversion h; subst
    | h : step (e_recrcd _ _) _ |- _ =>
      inversion h; subst
    end;
        (* for example
             *)
    subst; eauto; try contradiction; try discriminate; try cleanup_impossible; eauto; fail).
    intros V U t. induction t; subst; eauto.

    (* app *)
    +   destruct_ALL; eauto; subst; try_both_side.
        idtac.
        destruct (val_dec t1); eauto; try_both_side.

        destruct (syntax_eq_dec_abs t1); destruct_ALL; eauto; try_both_side.

        destruct (val_dec t2); eauto; try_both_side.
        right; intro H2; destruct_ALL; eauto.
        inversion H2;try contradiction; try discriminate; try cleanup_impossible; crush.

    (* e_if *)
    + clear IHt2 IHt3. destruct_ALL; crush.
        destruct t1;
        try_both_side.

    (* e_intsctrcd *)
    +  destruct_ALL; try_both_side.
       destruct (val_dec t1); eauto; try_both_side.

    (* e_prj *)
    +  destruct_ALL; try_both_side.

       destruct (val_dec t); subst; eauto; try_both_side.

       destruct (syntax_eq_dec_intsctrcd t); destruct_ALL; eauto; try_both_side.

       inversion v; subst; eauto.

       destruct (string_dec s x0); subst; eauto; try_both_side.

       destruct (syntax_eq_dec_recrcd t); destruct_ALL; eauto; try_both_side.

        right; intros; intro; destruct_ALL.
        try match goal with
        | [h : step (e_prj _ _) _ |- _] => inversion h; subst; eauto; crush; fail
        end.

Qed.

Ltac cleanup_impossible2:=
    match goal with
    (* | h0 :  val_has_type _ (v_abs _ _ _) ty_bool |- _ => inversion h0 *)
    | [h : step (e_if  (e_var _) _ _) _ |- _] => inversion h
    | [h : step (e_if  (e_abs _ _) _ _) _ |- _] => inversion h
    | [h : step (e_var _) _ |- _] => inversion h
    | [h : step (e_abs _ _) _ |- _] => inversion h
    | [h : step e_true _ |- _] => inversion h
    | [h : step e_false _ |- _] => inversion h
    | [h : step e_top _ |- _] => inversion h
    end.

Theorem step_determinsitic
   {V U} {x : Exp V U} {y}
    (h:step x y) :
    forall {z},
    step x z ->
    y = z.
  induction h; intros z h2; subst;
  try (
    match goal with
    | [h : step _ _ |- _] =>
      inversion h; subst; eauto; try cleanup_impossible2;try contradiction
    end
  );
  try (
    erewrite IHh; eauto ;fail
  );
try (
      match goal with
      | [h : step (e_intsctrcd ?a ?b ?c) _ |- _ ] =>
      assert (val (e_intsctrcd a b c)); eauto
      end;fail
);

try (match goal with
      | [h : step (e_recrcd ?a ?b) _ |- _ ] =>
      assert (val (e_recrcd a b)); eauto
end); fail.

Qed.

End steps_property.

Hint Extern 1  =>
  match goal with
  | [h1 : irreducible ?x, h2 : step ?x _ |- _]
    => destruct (irreducible_non_stepping h2 h1)
  | [h1 : val ?x, h2 : step ?x _ |- _]
    => destruct (val_not_steppable h1 h2)
  end
.


Load LFindLoad.
From lfind Require Import LFind.

                    From adtind Require Import goal35.

 Require Import Extraction.
 Extract Inductive nat => nat [ "(O)" "S" ].
 Extract Inductive list => list [ "Nil" "Cons" ].
Definition lfind_example_1  := ( Succ Zero).
Definition lfind_example_2  := ( Succ (Succ Zero)).
Definition lfind_example_3  := ( Succ (Succ (Succ Zero))).
Definition lfind_example_4  := ( Succ (Succ Zero)).
Definition lfind_example_5  := ( Succ (Succ (Succ Zero))).
Definition lfind_example_6  := ( Succ (Succ (Succ Zero))).
Definition lfind_example_7  := ( Succ (Succ (Succ Zero))).
Definition lfind_example_8  := ( Succ (Succ (Succ (Succ Zero)))).
Definition lfind_example_9  := ( Succ (Succ (Succ (Succ Zero)))).
Definition lfind_example_10  := ( Succ Zero).
Definition lfind_example_11  := ( Succ (Succ (Succ (Succ (Succ Zero))))).
Definition lfind_example_12  := ( Succ (Succ Zero)).
Definition lfind_example_13  := ( Succ (Succ Zero)).
Definition lfind_example_14  := ( Succ Zero).
Definition lfind_example_15  := ( Succ (Succ Zero)).
Definition lfind_example_16  := ( Succ Zero).

                    Extraction "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal35_plus_commut_62_plus_succ/lfind_extraction.ml" lfind_example_1 lfind_example_2 lfind_example_3 lfind_example_4 lfind_example_5 lfind_example_6 lfind_example_7 lfind_example_8 lfind_example_9 lfind_example_10 lfind_example_11 lfind_example_12 lfind_example_13 lfind_example_14 lfind_example_15 lfind_example_16 .


Require Import RamifyCoq.CertiGC.gc_spec.

Lemma body_resume: semax_body Vprog Gprog f_resume resume_spec.
Proof.
  start_function.
  unfold thread_info_rep, heap_struct_rep. Intros.
  forward. unfold fun_info_rep. forward. 1: entailer!. rewrite Znth_0_cons.
  replace_SEP 1 (fun_info_rep rsh f_info fi) by (unfold fun_info_rep; entailer!).
  forward_if True.
  - forward; entailer!.
  - remember (ti_heap_p t_info). rewrite (data_at_isptr sh heap_type).
    Intros. exfalso. destruct t_info. simpl in *. subst. contradiction.
  - Intros. destruct (heap_head_cons (ti_heap t_info)) as [hs [hl [? ?]]].
    rewrite H1, <- H2, map_cons.
    destruct (gt_gs_compatible _ _ H _ (graph_has_gen_O _)) as [? [? ?]].
    assert (isptr (space_start (heap_head (ti_heap t_info)))). {
      rewrite H2. unfold nth_space in H3. rewrite H1 in H3. simpl in H3.
      rewrite <- H3. apply start_isptr. } unfold space_tri at 1. do 2 forward.
    rewrite Znth_0_cons.
    destruct (space_start (heap_head (ti_heap t_info))) eqn:? ; try contradiction.
    forward_if (fun_word_size f_info <= total_space hs).
    + unfold denote_tc_samebase. simpl. entailer!.
    + unfold all_string_constants. Intros.
      forward_call ((gv ___stringlit_11),
                    (map init_data2byte (gvar_init v___stringlit_11)), rsh).
      exfalso; assumption.
    + forward. entailer!.
      unfold sem_sub_pp in H7. destruct eq_block in H7; [|easy]; simpl in H7.
      inv_int i. clear -H7. remember (heap_head (ti_heap t_info)) as h.
      rewrite ptrofs_add_repr, ptrofs_sub_repr, Z.add_comm, Z.add_simpl_r in H7.
      simpl in H7. unfold Ptrofs.divs in H7.
      rewrite (Ptrofs.signed_repr 4) in H7 by rep_omega.
      rewrite Ptrofs.signed_repr in H7 by (apply total_space_signed_range).
      rewrite WORD_SIZE_eq in H7. rewrite Z.mul_comm, Z.quot_mul in H7 by omega.
      rewrite ptrofs_to_int_repr in H7. hnf in H7.
      destruct (Int.ltu (Int.repr (total_space h))
                        (Int.repr (fun_word_size f_info))) eqn:? ; simpl in H7.
      1: inversion H7. apply ltu_repr_false in Heqb;
                         [omega | apply total_space_range | apply word_size_range].
    + rewrite <- Heqv in *. red in H0. rewrite H0 in H5.
      unfold previous_vertices_size in H5. simpl in H5. unfold nth_space in H5.
      rewrite H1 in H5. simpl in H5. rewrite <- H2 in H5.
      replace_SEP
        4 (heap_struct_rep
             sh ((space_start (heap_head (ti_heap t_info)),
                  (offset_val (WORD_SIZE * used_space (heap_head (ti_heap t_info)))
                              (space_start (heap_head (ti_heap t_info))),
                   offset_val (WORD_SIZE * total_space (heap_head (ti_heap t_info)))
                              (space_start (heap_head (ti_heap t_info)))))
                   :: map space_tri hl) (ti_heap_p t_info)) by
          (unfold heap_struct_rep; entailer!). do 3 forward.
      unfold before_gc_thread_info_rep. rewrite !heap_struct_rep_eq. rewrite <- H5.
      replace (WORD_SIZE * 0)%Z with 0 by omega.
      rewrite !isptr_offset_val_zero by assumption. cancel. rewrite H1. simpl tl.
      assert (12 = Zlength (map space_tri hl) + 1). {
        pose proof (spaces_size (ti_heap t_info)). rewrite MAX_SPACES_eq in H2.
        rewrite <- H2, H1, Zlength_cons, Zlength_map. omega. } rewrite !H2.
      rewrite !data_at_tarray_split_1 by reflexivity. cancel.
      do 2 (unfold_data_at (data_at _ _ _ _)). cancel.
Qed.


(*

  Copyright 2014 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.  Ifnot, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

 *)

Require Export stronger_continuity_rule4_v2.
Require Export per_props_subtype_rel.

Unset Regular Subst Tactic.

Lemma subtype_rel_nat_implies_eq_value_type_nut {o} :
  forall lib (T : @CTerm o),
    subtype_rel lib T mkc_tnat
    -> eq_value_type_nut lib T.
Proof.
  introv subt e.
  apply subt in e.
  apply equality_in_tnat in e.
  apply equality_of_nat_imp_tt in e.
  unfold equality_of_nat_tt in e; exrepnd.
  unfold compute_to_eqvals_nut.
  exists (@mkc_nat o k); dands; tcsp.
Qed.
Hint Resolve subtype_rel_nat_implies_eq_value_type_nut : slow.

(* Same as rule_strong_continuity2_v2 but with an extra explicit subtyping hyp *)
Definition rule_strong_continuity2_v2_2 {o}
           (F T t : @NTerm o)
           (x M f n : NVar)
           (H : barehypotheses) :=
    mk_rule
      (mk_baresequent H (mk_conclax (strong_continuous_type2_v2 x M f n F T)))
      [ mk_baresequent H (mk_conclax (mk_member F (mk_fun (mk_nat2T T) mk_tnat))),
        mk_baresequent H (mk_conclax (mk_member t T)),
        mk_baresequent H (mk_conclax (mk_subtype_rel T mk_tnat)) ]
      [].

Lemma rule_strong_continuity_true2_v2_2 {p} :
  forall lib
         (F T t : NTerm)
         (x M f n : NVar)
         (H : @barehypotheses p)
         (d1 : M <> f)
         (d2 : n <> f)
         (d3 : n <> M)
         (d4 : !LIn M (free_vars F))
         (d5 : !LIn f (free_vars F))
         (d6 : !LIn n (free_vars F))
         (d7 : !LIn x (free_vars T))
         (d8 : !LIn M (free_vars T)),
    rule_true lib (rule_strong_continuity2_v2_2
                     F T t
                     x M f n
                     H).
Proof.
  unfold rule_strong_continuity2_v2_2, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp.

  rename Hyp into hyp1.
  destruct hyp1 as [wc1 hyp1].

  rename Hyp0 into hyp2.
  destruct hyp2 as [wc2 hyp2].

  rename Hyp1 into hyp3.
  destruct hyp3 as [wc3 hyp3].

  destseq; allsimpl; proof_irr; GC.
  unfold closed_extract; simpl.

  exists (@covered_axiom p (nh_vars_hyps H)).

  (* We prove some simple facts on our sequents *)
  (* done with proving these simple facts *)

  vr_seq_true.

  vr_seq_true in hyp1.
  pose proof (hyp1 s1 s2 eqh sim) as h; exrepnd; clear hyp1.

  vr_seq_true in hyp2.
  pose proof (hyp2 s1 s2 eqh sim) as hTT; exrepnd; clear hyp2.

  vr_seq_true in hyp3.
  pose proof (hyp3 s1 s2 eqh sim) as subt; exrepnd; clear hyp3.

  allunfold @strong_continuous_type2_v2.
  allunfold @mk_sqexists.
  lsubst_tac.

  apply equality_in_member in hTT1; repnd.
  apply tequality_mkc_member_sp in hTT0; repnd.
  clear hTT0 hTT2 hTT3.

  clear subt0.
  apply equality_in_subtype_rel in subt1.
  repnd.
  clear subt0 subt2 subt3 subt4.

  apply member_if_inhabited in h1.
  apply tequality_mkc_member_sp in h0; repnd.
  allrw @fold_equorsq.
  clear h2.

  lsubst_tac.
  allrw @lsubstc_mkc_tnat.
  eapply member_respects_alphaeqc_r in h1;
    [|apply alphaeqc_mkc_fun;[|apply alphaeqc_refl];
      apply (lsubstc_mk_nat2T_sp1 T w3 s1 c6 w1 c1)].
  eapply respects_alphaeqc_equorsq3 in h0;
    [|apply alphaeqc_mkc_fun;[|apply alphaeqc_refl];
      apply (lsubstc_mk_nat2T_sp1 T w3 s1 c6 w1 c1)].

  dup h1 as memF.
  eapply cequorsq_equality_trans1 in memF;[|apply equorsq_sym;exact h0].
  apply equality_sym in memF.
  clear h0.

  prove_and teq.

  - apply tequality_mkc_squash.

    unfold mk_exists.
    lsubst_tac.

    apply tequality_product.
    dands.

    + eapply tequality_respects_alphaeqc_left;
      [apply alphaeqc_sym;apply (lsubstc_mod_fun_type_v2_aux x T w4 s1 c7 w1 c1);auto|].
      eapply tequality_respects_alphaeqc_right;
        [apply alphaeqc_sym;apply (lsubstc_mod_fun_type_v2_aux x T w4 s2 c9 w1 c0);auto|].
      apply tequality_modulus_fun_type_u_v2; auto.

    + intros M1 M2 em.
      eapply alphaeqc_preserving_equality in em;
        [|apply (lsubstc_mod_fun_type_v2_aux x T w4 s1 c7 w1 c1);auto].
      repeat substc_lsubstc_vars3.

      unfold mk_all.
      lsubst_tac.

      apply tequality_function; dands.

      * eapply tequality_respects_alphaeqc_left;
        [apply alphaeqc_sym;apply (lsubstc_mk_nat2T_sp1 T w3 s1 c6 w1 c1)|].
        eapply tequality_respects_alphaeqc_right;
          [apply alphaeqc_sym;apply (lsubstc_mk_nat2T_sp1 T w3 s2 c16 w1 c0)|].
        apply tequality_nat2T; auto.

      * intros f1 f2 en2n.
        eapply alphaeqc_preserving_equality in en2n;
          [|apply (lsubstc_mk_nat2T_sp1 T w3 s1 c6 w1 c1)].
        repeat substc_lsubstc_vars3.
        lsubst_tac.

        apply tequality_mkc_prod; dands.

        { apply tequality_mkc_squash.
          allrw @lsubstc_mkc_tnat.

          apply tequality_product; dands; eauto 3 with slow.
          { apply type_tnat. }

          intros n1 n2 en.
          repeat substc_lsubstc_vars3.
          a_lsubst_tac.

          apply tequality_mkc_equality_if_equal.

          { eapply tequality_respects_alphaeqc_left;
            [apply alphaeqc_sym; apply lsubstc_mk_natU|].
            eapply tequality_respects_alphaeqc_right;
              [apply alphaeqc_sym; apply lsubstc_mk_natU|].
            apply type_natU. }

          { eapply alphaeqc_preserving_equality;
            [|apply alphaeqc_sym; apply lsubstc_mk_natU].
            eapply equality_in_modulus_fun_type_u_implies_v2; eauto. }

          { eapply alphaeqc_preserving_equality;
            [|apply alphaeqc_sym; apply lsubstc_mk_natU].
            apply equality_in_fun in memF; repnd; clear memF0 memF1.
            apply memF in en2n; auto.
            apply equality_in_bunion_left; eauto 2 with slow. }
        }

        { intro inh; clear inh.
          allrw @lsubstc_mkc_tnat.
          apply tequality_function; dands.
          { apply type_tnat. }

          intros n1 n2 en.
          repeat substc_lsubstc_vars3.
          a_lsubst_tac.
          allrw @lsubstc_mk_true.
          allrw @lsubstc_mk_false.
          allrw @lsubstc_mk_tnat.
          apply tequality_mkc_ufun; dands.

          { pose proof (equality_in_modulus_fun_type_u_implies_v2
                          lib M1 M2 n1 n2 f1 f2 (lsubstc T w1 s1 c1)) as h.
            repeat (autodimp h hyp).
            apply equality_in_disjoint_bunion in h; eauto 3 with slow.
            repnd; clear h0 h2.
            repndors.

            - apply equality_in_tnat in h.
              unfold equality_of_nat in h; exrepnd; spcast.
              eapply tequality_respects_cequivc_left;
                [apply implies_cequivc_isint;
                  [apply cequivc_sym;apply computes_to_valc_implies_cequivc;exact h2
                  |apply cequivc_refl
                  |apply cequivc_refl]
                |].
              eapply tequality_respects_cequivc_right;
                [apply implies_cequivc_isint;
                  [apply cequivc_sym;apply computes_to_valc_implies_cequivc;exact h0
                  |apply cequivc_refl
                  |apply cequivc_refl]
                |].
              eapply tequality_respects_cequivc_left;
                [apply cequivc_sym;apply cequivc_mkc_isint_mkc_nat|].
              eapply tequality_respects_cequivc_right;
                [apply cequivc_sym;apply cequivc_mkc_isint_mkc_nat|].
              apply type_mkc_true.

            - apply equality_in_unit in h; repnd; spcast.
              eapply tequality_respects_cequivc_left;
                [apply implies_cequivc_isint;
                  [apply cequivc_sym;apply computes_to_valc_implies_cequivc;exact h0
                  |apply cequivc_refl
                  |apply cequivc_refl]
                |].
              eapply tequality_respects_cequivc_right;
                [apply implies_cequivc_isint;
                  [apply cequivc_sym;apply computes_to_valc_implies_cequivc;exact h
                  |apply cequivc_refl
                  |apply cequivc_refl]
                |].
              eapply tequality_respects_cequivc_left;
                [apply cequivc_sym;apply cequivc_mkc_isint_mkc_axiom|].
              eapply tequality_respects_cequivc_right;
                [apply cequivc_sym;apply cequivc_mkc_isint_mkc_axiom|].
              apply tequality_false.
          }

          { introv inh.
            pose proof (equality_in_modulus_fun_type_u_implies_v2
                          lib M1 M2 n1 n2 f1 f2 (lsubstc T w1 s1 c1)) as h.
            repeat (autodimp h hyp).
            apply equality_in_fun in memF; repnd; clear memF0 memF1.
            apply memF in en2n; auto.
            apply equality_in_natU_implies_cequivc in h; spcast.
            apply equality_in_tnat_implies_cequivc in en2n.
            apply tequality_equality_if_cequivc; eauto 3 with slow.
            apply type_tnat.
          }
        }

  - apply equality_in_mkc_squash; dands;
    try (spcast; apply computes_to_valc_refl; eauto 3 with slow);[].

    unfold mk_exists.
    lsubst_tac.

    exists (mkc_pair (spM_c (lsubstc F wt0 s1 ct3))
                     (mkc_lam f (mkcv_pair
                                   [f]
                                   (mkcv_axiom f)
                                   (mkcv_lam [f] n (mkcv_ax [n,f]))))).

    apply equality_in_product.
    dands.

    + eapply type_respects_alphaeqc;
      [apply alphaeqc_sym;apply (lsubstc_mod_fun_type_v2_aux x T w4 s1 c7 w1 c1);auto|].
      apply tequality_modulus_fun_type_u_v2; eauto 3 with slow.
      eapply tequality_refl; eauto.

    + intros M1 M2 em.
      eapply alphaeqc_preserving_equality in em;
        [|apply (lsubstc_mod_fun_type_v2_aux x T w4 s1 c7 w1 c1);auto].
      repeat substc_lsubstc_vars3.

      unfold mk_all.
      lsubst_tac.

      apply tequality_function; dands.

      * eapply tequality_respects_alphaeqc_left;
        [apply alphaeqc_sym;apply (lsubstc_mk_nat2T_sp1 T w3 s1 c6 w1 c1)|].
        eapply tequality_respects_alphaeqc_right;
          [apply alphaeqc_sym;apply (lsubstc_mk_nat2T_sp1 T w3 s1 c6 w1 c1)|].
        apply tequality_nat2T.
        eapply tequality_refl; eauto.

      * intros f1 f2 en2n.
        eapply alphaeqc_preserving_equality in en2n;
          [|apply (lsubstc_mk_nat2T_sp1 T w3 s1 c6 w1 c1)].
        repeat substc_lsubstc_vars3.
        lsubst_tac.

        apply tequality_mkc_prod; dands.

        { apply tequality_mkc_squash.
          allrw @lsubstc_mkc_tnat.

          apply tequality_product; dands; eauto 3 with slow.
          { apply type_tnat. }

          intros n1 n2 en.
          repeat substc_lsubstc_vars3.
          a_lsubst_tac.

          apply tequality_mkc_equality_if_equal.

          { eapply tequality_respects_alphaeqc_left;
            [apply alphaeqc_sym; apply lsubstc_mk_natU|].
            eapply tequality_respects_alphaeqc_right;
              [apply alphaeqc_sym; apply lsubstc_mk_natU|].
            apply type_natU. }

          { eapply alphaeqc_preserving_equality;
            [|apply alphaeqc_sym; apply lsubstc_mk_natU].
            eapply equality_in_modulus_fun_type_u_implies_v2; eauto. }

          { eapply alphaeqc_preserving_equality;
            [|apply alphaeqc_sym; apply lsubstc_mk_natU].
            apply equality_refl in memF.
            apply equality_in_fun in memF; repnd; clear memF0 memF1.
            apply memF in en2n; auto.
            apply equality_in_bunion_left; eauto 2 with slow. }
        }

        { intro inh; clear inh.
          allrw @lsubstc_mkc_tnat.
          apply tequality_function; dands.
          { apply type_tnat. }

          intros n1 n2 en.
          repeat substc_lsubstc_vars3.
          a_lsubst_tac.
          allrw @lsubstc_mk_true.
          allrw @lsubstc_mk_false.
          allrw @lsubstc_mk_tnat.
          apply tequality_mkc_ufun; dands.

          { pose proof (equality_in_modulus_fun_type_u_implies_v2
                          lib M1 M2 n1 n2 f1 f2 (lsubstc T w1 s1 c1)) as h.
            repeat (autodimp h hyp).
            apply equality_in_disjoint_bunion in h; eauto 3 with slow.
            repnd; clear h0 h2.
            repndors.

            - apply equality_in_tnat in h.
              unfold equality_of_nat in h; exrepnd; spcast.
              eapply tequality_respects_cequivc_left;
                [apply implies_cequivc_isint;
                  [apply cequivc_sym;apply computes_to_valc_implies_cequivc;exact h2
                  |apply cequivc_refl
                  |apply cequivc_refl]
                |].
              eapply tequality_respects_cequivc_right;
                [apply implies_cequivc_isint;
                  [apply cequivc_sym;apply computes_to_valc_implies_cequivc;exact h0
                  |apply cequivc_refl
                  |apply cequivc_refl]
                |].
              eapply tequality_respects_cequivc_left;
                [apply cequivc_sym;apply cequivc_mkc_isint_mkc_nat|].
              eapply tequality_respects_cequivc_right;
                [apply cequivc_sym;apply cequivc_mkc_isint_mkc_nat|].
              apply type_mkc_true.

            - apply equality_in_unit in h; repnd; spcast.
              eapply tequality_respects_cequivc_left;
                [apply implies_cequivc_isint;
                  [apply cequivc_sym;apply computes_to_valc_implies_cequivc;exact h0
                  |apply cequivc_refl
                  |apply cequivc_refl]
                |].
              eapply tequality_respects_cequivc_right;
                [apply implies_cequivc_isint;
                  [apply cequivc_sym;apply computes_to_valc_implies_cequivc;exact h
                  |apply cequivc_refl
                  |apply cequivc_refl]
                |].
              eapply tequality_respects_cequivc_left;
                [apply cequivc_sym;apply cequivc_mkc_isint_mkc_axiom|].
              eapply tequality_respects_cequivc_right;
                [apply cequivc_sym;apply cequivc_mkc_isint_mkc_axiom|].
              apply tequality_false.
          }

          { introv inh.
            pose proof (equality_in_modulus_fun_type_u_implies_v2
                          lib M1 M2 n1 n2 f1 f2 (lsubstc T w1 s1 c1)) as h.
            repeat (autodimp h hyp).
            apply equality_refl in memF.
            apply equality_in_fun in memF; repnd; clear memF0 memF1.
            apply memF in en2n; auto.
            apply equality_in_natU_implies_cequivc in h; spcast.
            apply equality_in_tnat_implies_cequivc in en2n.
            apply tequality_equality_if_cequivc; eauto 3 with slow.
            apply type_tnat.
          }
        }

    + eexists; eexists; eexists; eexists; dands; spcast;
      try (apply computes_to_valc_refl; eauto 3 with slow).

      * eapply alphaeqc_preserving_equality;
        [|apply alphaeqc_sym;apply (lsubstc_mod_fun_type_v2_aux x T w4 s1 c7 w1 c1);auto].

        apply (spM_in_modulus_fun_type_u_v2 _ _ (lsubstc t wt s1 ct2)); eauto 3 with slow.

      * repeat substc_lsubstc_vars3.
        unfold mk_all.
        lsubst_tac.

        apply equality_in_function.
        dands.

        { eapply type_respects_alphaeqc;
          [apply alphaeqc_sym;apply (lsubstc_mk_nat2T_sp1 T w3 s1 c6 w1 c1)|].
          eauto 3 with slow.
          apply tequality_nat2T; eauto 3 with slow.
          eapply tequality_refl; eauto. }

        { intros f1 f2 en2n.
          eapply alphaeqc_preserving_equality in en2n;
            [|apply (lsubstc_mk_nat2T_sp1 T w3 s1 c6 w1 c1)].
          repeat substc_lsubstc_vars3.
          lsubst_tac.

          apply tequality_mkc_prod; dands.

          { apply tequality_mkc_squash.
            allrw @lsubstc_mkc_tnat.

            apply tequality_product; dands; eauto 3 with slow.
            { apply type_tnat. }

            intros n1 n2 en.
            repeat substc_lsubstc_vars3.
            a_lsubst_tac.

            apply tequality_mkc_equality_if_equal.

            { eapply tequality_respects_alphaeqc_left;
              [apply alphaeqc_sym; apply lsubstc_mk_natU|].
              eapply tequality_respects_alphaeqc_right;
                [apply alphaeqc_sym; apply lsubstc_mk_natU|].
              apply type_natU. }

            { eapply alphaeqc_preserving_equality;
              [|apply alphaeqc_sym; apply lsubstc_mk_natU].
              pose proof (spM_in_modulus_fun_type_u_v2
                            lib
                            (lsubstc F wt0 s1 ct3)
                            (lsubstc t wt s1 ct2)
                            (lsubstc T w1 s1 c1)) as h.
              repeat (autodimp h hyp); eauto 3 with slow;[].
              eapply equality_in_modulus_fun_type_u_implies_v2; eauto. }

            { eapply alphaeqc_preserving_equality;
              [|apply alphaeqc_sym; apply lsubstc_mk_natU].
              apply equality_refl in memF.
              apply equality_in_fun in memF; repnd; clear memF0 memF1.
              apply memF in en2n; auto.
              apply equality_in_bunion_left; eauto 2 with slow. }
          }

          { intro inh; clear inh.
            allrw @lsubstc_mkc_tnat.
            apply tequality_function; dands.
            { apply type_tnat. }

            intros n1 n2 en.
            repeat substc_lsubstc_vars3.
            a_lsubst_tac.
            allrw @lsubstc_mk_true.
            allrw @lsubstc_mk_false.
            allrw @lsubstc_mk_tnat.

            pose proof (spM_in_modulus_fun_type_u_v2
                          lib
                          (lsubstc F wt0 s1 ct3)
                          (lsubstc t wt s1 ct2)
                          (lsubstc T w1 s1 c1)) as spMt.
            repeat (autodimp spMt hyp);eauto 3 with slow; [].
            apply tequality_mkc_ufun; dands.

            { pose proof (equality_in_modulus_fun_type_u_implies_v2
                            lib
                            (spM_c (lsubstc F wt0 s1 ct3))
                            (spM_c (lsubstc F wt0 s1 ct3))
                            n1 n2 f1 f2
                            (lsubstc T w1 s1 c1)) as h.
              repeat (autodimp h hyp).
              apply equality_in_disjoint_bunion in h; eauto 3 with slow.
              repnd; clear h0 h2.
              repndors.

              - apply equality_in_tnat in h.
                unfold equality_of_nat in h; exrepnd; spcast.
                eapply tequality_respects_cequivc_left;
                  [apply implies_cequivc_isint;
                    [apply cequivc_sym;apply computes_to_valc_implies_cequivc;exact h2
                    |apply cequivc_refl
                    |apply cequivc_refl]
                  |].
                eapply tequality_respects_cequivc_right;
                  [apply implies_cequivc_isint;
                    [apply cequivc_sym;apply computes_to_valc_implies_cequivc;exact h0
                    |apply cequivc_refl
                    |apply cequivc_refl]
                  |].
                eapply tequality_respects_cequivc_left;
                  [apply cequivc_sym;apply cequivc_mkc_isint_mkc_nat|].
                eapply tequality_respects_cequivc_right;
                  [apply cequivc_sym;apply cequivc_mkc_isint_mkc_nat|].
                apply type_mkc_true.

              - apply equality_in_unit in h; repnd; spcast.
                eapply tequality_respects_cequivc_left;
                  [apply implies_cequivc_isint;
                    [apply cequivc_sym;apply computes_to_valc_implies_cequivc;exact h0
                    |apply cequivc_refl
                    |apply cequivc_refl]
                  |].
                eapply tequality_respects_cequivc_right;
                  [apply implies_cequivc_isint;
                    [apply cequivc_sym;apply computes_to_valc_implies_cequivc;exact h
                    |apply cequivc_refl
                    |apply cequivc_refl]
                  |].
                eapply tequality_respects_cequivc_left;
                  [apply cequivc_sym;apply cequivc_mkc_isint_mkc_axiom|].
                eapply tequality_respects_cequivc_right;
                  [apply cequivc_sym;apply cequivc_mkc_isint_mkc_axiom|].
                apply tequality_false.
            }

            { introv inh.
              pose proof (equality_in_modulus_fun_type_u_implies_v2
                            lib
                            (spM_c (lsubstc F wt0 s1 ct3))
                            (spM_c (lsubstc F wt0 s1 ct3))
                            n1 n2 f1 f2
                            (lsubstc T w1 s1 c1)) as h.
              repeat (autodimp h hyp).
              apply equality_refl in memF.
              apply equality_in_fun in memF; repnd; clear memF0 memF1.
              apply memF in en2n; auto.
              apply equality_in_natU_implies_cequivc in h; spcast.
              apply equality_in_tnat_implies_cequivc in en2n.
              apply tequality_equality_if_cequivc; eauto 3 with slow.
              apply type_tnat.
            }
          }
        }

        { intros f1 f2 en2n.
          eapply alphaeqc_preserving_equality in en2n;
            [|apply (lsubstc_mk_nat2T_sp1 T w3 s1 c6 w1 c1)].
          repeat substc_lsubstc_vars3.
          lsubst_tac.

          eapply equality_respects_cequivc_left;
            [apply cequivc_sym;apply cequivc_beta|].
          eapply equality_respects_cequivc_right;
            [apply cequivc_sym;apply cequivc_beta|].
          allrw @mkcv_pair_substc.
          allrw @substc_mkcv_axiom.
          repeat (rw @mkcv_lam_substc;auto;[]).
          allrw @mkcv_ax_eq.
          allrw @substc2_mk_cv.
          allrw @lsubstc_mkc_tnat.

          apply equality_in_prod.
          dands.

          { apply tequality_mkc_squash.

            apply tequality_product; dands; eauto 3 with slow.
            { apply type_tnat. }

            intros n1 n2 en.
            repeat substc_lsubstc_vars3.
            a_lsubst_tac.

            apply tequality_mkc_equality_if_equal.

            { eapply tequality_respects_alphaeqc_left;
              [apply alphaeqc_sym; apply lsubstc_mk_natU|].
              eapply tequality_respects_alphaeqc_right;
                [apply alphaeqc_sym; apply lsubstc_mk_natU|].
              apply type_natU. }

            { eapply alphaeqc_preserving_equality;
              [|apply alphaeqc_sym; apply lsubstc_mk_natU].
              applydup @equality_refl in en2n.
              pose proof (spM_in_modulus_fun_type_u_v2
                            lib
                            (lsubstc F wt0 s1 ct3)
                            (lsubstc t wt s1 ct2)
                            (lsubstc T w1 s1 c1)) as h.
              repeat (autodimp h hyp);eauto 3 with slow;[].
              eapply equality_in_modulus_fun_type_u_implies_v2; eauto. }

            { eapply alphaeqc_preserving_equality;
              [|apply alphaeqc_sym; apply lsubstc_mk_natU].
              apply equality_refl in memF; auto.
              apply equality_in_fun in memF; repnd; clear memF0 memF1.
              apply memF in en2n; auto.
              applydup @equality_refl in en2n.
              apply equality_in_bunion_left; eauto 2 with slow. }
          }

          { intro inh; clear inh.
            allrw @lsubstc_mkc_tnat.
            apply tequality_function; dands.
            { apply type_tnat. }

            intros n1 n2 en.
            repeat substc_lsubstc_vars3.
            a_lsubst_tac.
            allrw @lsubstc_mk_true.
            allrw @lsubstc_mk_false.
            allrw @lsubstc_mk_tnat.

            pose proof (spM_in_modulus_fun_type_u_v2
                          lib
                          (lsubstc F wt0 s1 ct3)
                          (lsubstc t wt s1 ct2)
                          (lsubstc T w1 s1 c1)) as spMt.
            repeat (autodimp spMt hyp);eauto 3 with slow;[].
            apply tequality_mkc_ufun; dands.

            { applydup @equality_refl in en2n.
              pose proof (equality_in_modulus_fun_type_u_implies_v2
                            lib
                            (spM_c (lsubstc F wt0 s1 ct3))
                            (spM_c (lsubstc F wt0 s1 ct3))
                            n1 n2 f1 f1
                            (lsubstc T w1 s1 c1)) as h.
              repeat (autodimp h hyp);[].
              apply equality_in_disjoint_bunion in h; eauto 3 with slow.
              repnd; clear h0 h2.
              repndors.

              - apply equality_in_tnat in h.
                unfold equality_of_nat in h; exrepnd; spcast.
                eapply tequality_respects_cequivc_left;
                  [apply implies_cequivc_isint;
                    [apply cequivc_sym;apply computes_to_valc_implies_cequivc;exact h2
                    |apply cequivc_refl
                    |apply cequivc_refl]
                  |].
                eapply tequality_respects_cequivc_right;
                  [apply implies_cequivc_isint;
                    [apply cequivc_sym;apply computes_to_valc_implies_cequivc;exact h0
                    |apply cequivc_refl
                    |apply cequivc_refl]
                  |].
                eapply tequality_respects_cequivc_left;
                  [apply cequivc_sym;apply cequivc_mkc_isint_mkc_nat|].
                eapply tequality_respects_cequivc_right;
                  [apply cequivc_sym;apply cequivc_mkc_isint_mkc_nat|].
                apply type_mkc_true.

              - apply equality_in_unit in h; repnd; spcast.
                eapply tequality_respects_cequivc_left;
                  [apply implies_cequivc_isint;
                    [apply cequivc_sym;apply computes_to_valc_implies_cequivc;exact h0
                    |apply cequivc_refl
                    |apply cequivc_refl]
                  |].
                eapply tequality_respects_cequivc_right;
                  [apply implies_cequivc_isint;
                    [apply cequivc_sym;apply computes_to_valc_implies_cequivc;exact h
                    |apply cequivc_refl
                    |apply cequivc_refl]
                  |].
                eapply tequality_respects_cequivc_left;
                  [apply cequivc_sym;apply cequivc_mkc_isint_mkc_axiom|].
                eapply tequality_respects_cequivc_right;
                  [apply cequivc_sym;apply cequivc_mkc_isint_mkc_axiom|].
                apply tequality_false.
            }

            { introv inh.
              applydup @equality_refl in en2n.
              pose proof (equality_in_modulus_fun_type_u_implies_v2
                            lib
                            (spM_c (lsubstc F wt0 s1 ct3))
                            (spM_c (lsubstc F wt0 s1 ct3))
                            n1 n2 f1 f1
                            (lsubstc T w1 s1 c1)) as h.
              repeat (autodimp h hyp).
              apply equality_refl in memF.
              apply equality_in_fun in memF; repnd; clear memF0 memF1.
              apply memF in en2n; auto.
              applydup @equality_refl in en2n.
              apply equality_in_natU_implies_cequivc in h; spcast.
              apply equality_in_tnat_implies_cequivc in en2n.
              apply tequality_equality_if_cequivc; eauto 3 with slow.
              apply type_tnat.
            }
          }

          { exists (@mkc_axiom p) (@mkc_axiom p)
                   (@mkc_lam p n (mk_cv [n] mkc_axiom))
                   (@mkc_lam p n (mk_cv [n] mkc_axiom)).
            dands; spcast.
            { apply computes_to_valc_refl; eauto 3 with slow. }
            { apply computes_to_valc_refl; eauto 3 with slow. }

            { apply equality_in_mkc_squash; dands; spcast;
              try (apply computes_to_valc_refl; eauto 3 with slow);[].

              applydup @equality_refl in en2n as mf1.
              pose proof (spM_cond_v2
                            lib
                            (lsubstc F wt0 s1 ct3)
                            f1
                            (lsubstc T w1 s1 c1)
                            h1 mf1) as h.
              exrepnd.

              allrw @lsubstc_mkc_tnat.

              exists (mkc_pair (mkc_nat n0) (@mkc_axiom p)).

              apply equality_in_product; dands; eauto 3 with slow.

              - intros n1 n2 en.
                repeat substc_lsubstc_vars3.
                a_lsubst_tac.

                apply tequality_mkc_equality_if_equal.

                { eapply tequality_respects_alphaeqc_left;
                  [apply alphaeqc_sym; apply lsubstc_mk_natU|].
                  eapply tequality_respects_alphaeqc_right;
                    [apply alphaeqc_sym; apply lsubstc_mk_natU|].
                  apply type_natU. }

                { eapply alphaeqc_preserving_equality;
                  [|apply alphaeqc_sym; apply lsubstc_mk_natU].

                  pose proof (spM_in_modulus_fun_type_u_v2
                                lib
                                (lsubstc F wt0 s1 ct3)
                                (lsubstc t wt s1 ct2)
                                (lsubstc T w1 s1 c1)) as h.
                  repeat (autodimp h hyp); eauto 3 with slow;[].
                  rw @equality_in_function in h; repnd.
                  applydup h in en as e.
                  eapply alphaeqc_preserving_equality in e;[|apply substc_mkcv_fun].
                  rw @csubst_mk_cv in e.

                  try (fold (@natU p) in e).
                  eapply alphaeqc_preserving_equality in e;
                    [|apply alphaeqc_mkc_fun;[|apply alphaeqc_refl];
                      apply substc_mkcv_fun].
                  eapply alphaeqc_preserving_equality in e;
                    [|apply alphaeqc_mkc_fun;[|apply alphaeqc_refl];
                      apply alphaeqc_mkc_fun;[|apply alphaeqc_refl];
                      apply mkcv_natk_substc
                    ].
                  allrw @mkc_var_substc.
                  allrw @mkcv_tnat_substc.

                  try (fold (natk2nat n1) in e).

                  applydup @equality_refl in en.
                  apply (equality_nat2T_to_natk2T lib n1) in en2n; auto;[].

                  apply equality_in_fun in e; repnd; clear e0 e1.
                  applydup @equality_refl in en2n as ef.
                  allrw @csubst_mk_cv.
                  apply e in ef.
                  allrw <- @mkc_apply2_eq; auto. }

                { eapply alphaeqc_preserving_equality;
                  [|apply alphaeqc_sym; apply lsubstc_mk_natU].
                  apply equality_refl in memF.
                  apply equality_in_fun in memF; repnd; clear memF0 memF1.
                  apply memF in en2n; auto.
                  apply equality_in_bunion_left; eauto 2 with slow. }

              - eexists; eexists; eexists; eexists; dands; spcast;
                try (apply computes_to_valc_refl; eauto 3 with slow);
                eauto 3 with slow.

                repeat substc_lsubstc_vars3.
                a_lsubst_tac.

                apply member_equality.
                eapply alphaeqc_preserving_equality;
                  [|apply alphaeqc_sym; apply lsubstc_mk_natU].
                auto.
            }

            { apply equality_in_function3.
              dands; eauto 3 with slow;[].

              intros n1 n2 en.
              repeat substc_lsubstc_vars3.
              a_lsubst_tac.
              allrw @lsubstc_mk_true.
              allrw @lsubstc_mk_false.
              allrw @lsubstc_mkc_tnat.

              dands.

              - pose proof (spM_in_modulus_fun_type_u_v2
                                lib
                                (lsubstc F wt0 s1 ct3)
                                (lsubstc t wt s1 ct2)
                                (lsubstc T w1 s1 c1)) as spMt.
                repeat (autodimp spMt hyp);eauto 3 with slow;[].
                apply tequality_mkc_ufun; dands.

                { applydup @equality_refl in en2n.
                  pose proof (equality_in_modulus_fun_type_u_implies_v2
                                lib
                                (spM_c (lsubstc F wt0 s1 ct3))
                                (spM_c (lsubstc F wt0 s1 ct3))
                                n1 n2 f1 f1
                                (lsubstc T w1 s1 c1)) as h.
                  repeat (autodimp h hyp).
                  apply equality_in_disjoint_bunion in h; eauto 3 with slow.
                  repnd; clear h0 h2.
                  repndors.

                  - apply equality_in_tnat in h.
                    unfold equality_of_nat in h; exrepnd; spcast.
                    eapply tequality_respects_cequivc_left;
                      [apply implies_cequivc_isint;
                        [apply cequivc_sym;apply computes_to_valc_implies_cequivc;exact h2
                        |apply cequivc_refl
                        |apply cequivc_refl]
                      |].
                    eapply tequality_respects_cequivc_right;
                      [apply implies_cequivc_isint;
                        [apply cequivc_sym;apply computes_to_valc_implies_cequivc;exact h0
                        |apply cequivc_refl
                        |apply cequivc_refl]
                      |].
                    eapply tequality_respects_cequivc_left;
                      [apply cequivc_sym;apply cequivc_mkc_isint_mkc_nat|].
                    eapply tequality_respects_cequivc_right;
                      [apply cequivc_sym;apply cequivc_mkc_isint_mkc_nat|].
                    apply type_mkc_true.

                  - apply equality_in_unit in h; repnd; spcast.
                    eapply tequality_respects_cequivc_left;
                      [apply implies_cequivc_isint;
                        [apply cequivc_sym;apply computes_to_valc_implies_cequivc;exact h0
                        |apply cequivc_refl
                        |apply cequivc_refl]
                      |].
                    eapply tequality_respects_cequivc_right;
                      [apply implies_cequivc_isint;
                        [apply cequivc_sym;apply computes_to_valc_implies_cequivc;exact h
                        |apply cequivc_refl
                        |apply cequivc_refl]
                      |].
                    eapply tequality_respects_cequivc_left;
                      [apply cequivc_sym;apply cequivc_mkc_isint_mkc_axiom|].
                    eapply tequality_respects_cequivc_right;
                      [apply cequivc_sym;apply cequivc_mkc_isint_mkc_axiom|].
                    apply tequality_false.
                }

                { introv inh.
                  applydup @equality_refl in en2n.
                  pose proof (equality_in_modulus_fun_type_u_implies_v2
                                lib
                                (spM_c (lsubstc F wt0 s1 ct3))
                                (spM_c (lsubstc F wt0 s1 ct3))
                                n1 n2 f1 f1
                                (lsubstc T w1 s1 c1)) as h.
                  repeat (autodimp h hyp).
                  apply equality_refl in memF.
                  apply equality_in_fun in memF; repnd; clear memF0 memF1.
                  apply memF in en2n; auto.
                  applydup @equality_refl in en2n.
                  apply equality_in_natU_implies_cequivc in h; spcast.
                  apply equality_in_tnat_implies_cequivc in en2n.
                  apply tequality_equality_if_cequivc; eauto 3 with slow.
                  apply type_tnat.
                }

              - apply equality_in_ufun.
                pose proof (spM_in_modulus_fun_type_u_v2
                              lib
                              (lsubstc F wt0 s1 ct3)
                              (lsubstc t wt s1 ct2)
                              (lsubstc T w1 s1 c1)) as spMt.
                repeat (autodimp spMt hyp);eauto 3 with slow;[].

                dands.

                { applydup @equality_refl in en2n.
                  pose proof (equality_in_modulus_fun_type_u_implies_v2
                                lib
                                (spM_c (lsubstc F wt0 s1 ct3))
                                (spM_c (lsubstc F wt0 s1 ct3))
                                n1 n2 f1 f1
                                (lsubstc T w1 s1 c1)) as h.
                  repeat (autodimp h hyp).
                  apply equality_in_disjoint_bunion in h; eauto 3 with slow.
                  repnd; clear h0 h2.
                  repndors.

                  - apply equality_in_tnat in h.
                    unfold equality_of_nat in h; exrepnd; spcast.
                    eapply tequality_respects_cequivc_left;
                      [apply implies_cequivc_isint;
                        [apply cequivc_sym;apply computes_to_valc_implies_cequivc;exact h2
                        |apply cequivc_refl
                        |apply cequivc_refl]
                      |].
                    eapply tequality_respects_cequivc_right;
                      [apply implies_cequivc_isint;
                        [apply cequivc_sym;apply computes_to_valc_implies_cequivc;exact h2
                        |apply cequivc_refl
                        |apply cequivc_refl]
                      |].
                    eapply tequality_respects_cequivc_left;
                      [apply cequivc_sym;apply cequivc_mkc_isint_mkc_nat|].
                    eapply tequality_respects_cequivc_right;
                      [apply cequivc_sym;apply cequivc_mkc_isint_mkc_nat|].
                    apply type_mkc_true.

                  - apply equality_in_unit in h; repnd; spcast.
                    eapply tequality_respects_cequivc_left;
                      [apply implies_cequivc_isint;
                        [apply cequivc_sym;apply computes_to_valc_implies_cequivc;exact h0
                        |apply cequivc_refl
                        |apply cequivc_refl]
                      |].
                    eapply tequality_respects_cequivc_right;
                      [apply implies_cequivc_isint;
                        [apply cequivc_sym;apply computes_to_valc_implies_cequivc;exact h0
                        |apply cequivc_refl
                        |apply cequivc_refl]
                      |].
                    eapply tequality_respects_cequivc_left;
                      [apply cequivc_sym;apply cequivc_mkc_isint_mkc_axiom|].
                    eapply tequality_respects_cequivc_right;
                      [apply cequivc_sym;apply cequivc_mkc_isint_mkc_axiom|].
                    apply tequality_false.
                }

                { introv inh; clear inh.
                  applydup @equality_refl in en2n.
                  pose proof (equality_in_modulus_fun_type_u_implies_v2
                                lib
                                (spM_c (lsubstc F wt0 s1 ct3))
                                (spM_c (lsubstc F wt0 s1 ct3))
                                n1 n2 f1 f1
                                (lsubstc T w1 s1 c1)) as h.
                  repeat (autodimp h hyp).
                  apply equality_refl in memF.
                  apply equality_in_fun in memF; repnd; clear memF0 memF1.
                  apply memF in en2n; auto.
                  applydup @equality_refl in en2n.
                  apply equality_in_natU_implies_cequivc in h; spcast.
                  apply equality_in_tnat_implies_cequivc in en2n.
                  apply tequality_equality_if_cequivc; eauto 3 with slow.
                  apply type_tnat.
                }

                { introv inh.
                  eapply equality_respects_cequivc_left;
                    [apply cequivc_sym;apply cequivc_beta|].
                  eapply equality_respects_cequivc_right;
                    [apply cequivc_sym;apply cequivc_beta|].
                  allrw @csubst_mk_cv.

                  applydup @equality_refl in en2n.
                  pose proof (equality_in_modulus_fun_type_u_implies_v2
                                lib
                                (spM_c (lsubstc F wt0 s1 ct3))
                                (spM_c (lsubstc F wt0 s1 ct3))
                                n1 n2 f1 f1
                                (lsubstc T w1 s1 c1)) as h.
                  repeat (autodimp h hyp).

                  apply equality_in_disjoint_bunion in h; eauto 3 with slow.
                  repnd; clear h0 h2.
                  repndors; apply equality_refl in h.

                  - apply equality_in_tnat in h.
                    unfold equality_of_nat in h; exrepnd; spcast.

                    apply equality_in_tnat in en.
                    unfold equality_of_nat in en; exrepnd; spcast.

                    pose proof (spM_cond2_v2
                                  lib (lsubstc F wt0 s1 ct3) f1 k0 k
                                  (lsubstc T w1 s1 c1)) as cond2.
                    repeat (autodimp cond2 hyp).
                    { eapply cequivc_trans;
                      [apply implies_cequivc_apply2;
                        [apply cequivc_refl
                        |apply cequivc_sym;apply computes_to_valc_implies_cequivc;exact en1
                        |apply cequivc_refl]
                      |].
                      apply computes_to_valc_implies_cequivc; auto. }
                    apply member_equality.

                    eapply equality_respects_cequivc_right;
                      [apply cequivc_sym;exact cond2|].

                    eapply equality_respects_cequivc_left;
                      [apply cequivc_sym;apply computes_to_valc_implies_cequivc;exact h2|].
                    eauto 3 with slow.

                  - apply equality_in_unit in h.
                    repnd; spcast.
                    eapply inhabited_type_cequivc in inh;
                      [|apply implies_cequivc_isint;
                         [apply computes_to_valc_implies_cequivc;exact h
                         |apply cequivc_refl
                         |apply cequivc_refl]
                      ].
                    eapply inhabited_type_cequivc in inh;
                      [|apply cequivc_mkc_isint_mkc_axiom].
                    unfold inhabited_type in inh; exrepnd.
                    apply false_not_inhabited in inh0; sp.
                }
            }
          }
        }
Qed.

(*
*** Local Variables:
*** coq-load-path: ("." "./close/")
*** End:
*)


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.

Local Open Scope Z_scope.

Section SpecLow.

  Definition asc_mark_nonsecure_spec0 (addr: Z64) (adt: RData) : option (RData * Z64) :=
    match addr with
    | VZ64 _addr =>
      let _ret := 0 in
      rely is_int64 _addr;
      when' _idx == addr_to_gidx_spec (VZ64 _addr) adt;
      rely is_int64 _idx;
      when _t'4 == check_granule_idx_spec (VZ64 _idx) adt;
      rely is_int _t'4;
      if (_t'4 =? 0) then
        let _ret := 1 in
        Some (adt, (VZ64 _ret))
      else
        when'' _lock_base, _lock_ofst == find_spinlock_spec (VZ64 _addr) adt;
        rely is_int _lock_ofst;
        when adt == spinlock_acquire_spec (_lock_base, _lock_ofst) adt;
        when' _t'3 == get_pas_spec (VZ64 _idx) adt;
        rely is_int64 _t'3;
        rely is_int _t'3;
        let _pas := _t'3 in
        if (negb (_pas =? 11)) then
          let _ret := 1 in
          when adt == spinlock_release_spec (_lock_base, _lock_ofst) adt;
          Some (adt, (VZ64 _ret))
        else
          when adt == set_pas_spec (VZ64 _idx) (VZ64 9) adt;
          when adt == tlbi_by_pa_spec (VZ64 _addr) adt;
          when adt == spinlock_release_spec (_lock_base, _lock_ofst) adt;
          Some (adt, (VZ64 _ret))
     end
    .

End SpecLow.


Require Import Rupicola.Lib.Api.
Require Import Rupicola.Examples.Nondeterminism.NonDeterminism.

Section Peek.
  Context {width: Z} {BW: Bitwidth width} {word: word.word width} {mem: map.map word Byte.byte}.
  Context {locals: map.map String.string word}.
  Context {env: map.map String.string (list String.string * list String.string * Syntax.cmd)}.
  Context {ext_spec: bedrock2.Semantics.ExtSpec}.
  Context {word_ok : word.ok word} {mem_ok : map.ok mem}.
  Context {locals_ok : map.ok locals}.
  Context {env_ok : map.ok env}.
  Context {ext_spec_ok : Semantics.ext_spec.ok ext_spec}.

  Definition Bag := list word.

  Definition bag_at (addr: word) (b: Bag) :=
    Lift1Prop.ex1 (fun words =>
                     emp (forall x, List.In x words <-> List.In x b) *
                     array scalar (word.of_Z (Memory.bytes_per_word width))
                           addr words)%sep.

  Definition peek (l: Bag) := %{ x | List.In x l }.

  Lemma compile_peek : forall {tr mem locals functions} (b: Bag),
    let c := peek b in
    forall {B} {pred: B -> predicate}
      {k: word -> ND.M B} {k_impl}
      R b_ptr b_expr var,

      b <> [] ->
      (bag_at b_ptr b * R)%sep mem ->
      WeakestPrecondition.dexpr mem locals b_expr b_ptr ->

      (forall v,
          c v ->
          <{ Trace := tr;
             Memory := mem;
             Locals := map.put locals var v;
             Functions := functions }>
          k_impl
          <{ ndspec_k pred (k v) }>) ->
      <{ Trace := tr;
         Memory := mem;
         Locals := locals;
         Functions := functions }>
      cmd.seq (cmd.set var (expr.load access_size.word b_expr)) k_impl
      <{ ndspec_k pred (mbindn [var] c k) }>.
  Proof.
    destruct b as [|w b]; try congruence.
    intros * Hnn [ws [Hin Hm]%sep_assoc%sep_emp_l]%sep_ex1_l Hl Hk.
    destruct ws as [| w' ws]; [ exfalso; eapply Hin; red; eauto | ].
    eexists; split; repeat straightline.
    - eapply WeakestPrecondition_dexpr_expr; eauto.
      eexists; split; eauto.
      eapply load_word_of_sep.
      seprewrite_in uconstr:(@array_cons) Hm.
      ecancel_assumption.
    - eapply WeakestPrecondition_ndspec_k_bindn; [ | intros; apply Hk; eauto ].
      all: apply Hin; red; eauto.
  Qed.

  Definition nondet_sum_src (b: Bag) :=
    let/+ x := peek b in
    let/+ y := peek b in
    let/n out := word.add x y in
    mret out.

  Instance spec_of_nondet_sum : spec_of "nondet_sum" :=
    fnspec! "nondet_sum" b_ptr / b R,
      { requires tr mem :=
          b <> [] /\ (bag_at b_ptr b ⋆ R) mem;
        ensures tr' mem' rets :=
          ndspec (nondet_sum_src b) (fun v =>
             tr' = tr /\ rets = [v] /\ (bag_at b_ptr b ⋆ R) mem') }.

  Hint Extern 1 => simple eapply compile_peek; shelve : compiler.

  Derive nondet_sum_br2fn SuchThat
         (defn! "nondet_sum"("b") ~> "out"
              { nondet_sum_br2fn },
          implements nondet_sum_src)
  As nondet_sum_br2fn_ok.
  Proof.
    compile.
  Qed.
End Peek.

From bedrock2 Require Import BasicC64Semantics NotationsCustomEntry.
Compute nondet_sum_br2fn. (* (word := word) *)


(* *********************************************************************)
(*                                                                     *)
(*                 Coqlex verified lexer generator                     *)
(*                                                                     *)
(*  Copyright 2021 Siemens Mobility SAS and Institut National de       *)
(*  Recherche en Informatique et en Automatique.                       *)
(*  All rights reserved. This file is distributed under                *)
(*  the terms of the INRIA Non-Commercial License Agreement (see the   *)
(*  LICENSE file).                                                     *)
(*                                                                     *)
(* *********************************************************************)

Require Import SimpleLexerGenerator.
Require Import MatchLenSpeedUp.
Require Import Coq.Lists.List.
Require Import Coq.Strings.String.
Require Import UsefullProofs.
Require Import micromega.Lia.
Import ListNotations.

Fixpoint electCandidateSpeedUp {Action : Set} RegexpXAction_list str := match RegexpXAction_list with
| [] => None
| (re, ac)::t => (match match_len_speed_up_v2 re str with
            | None => electCandidateSpeedUp t str
            | Some n => (match electCandidateSpeedUp(Action:=Action) t str with
                        | Some c => Some (if Nat.ltb n (resultNat c) then c else (mkElectionResult Action re ac n) )
                        | None => Some (mkElectionResult Action re ac n)
                        end)
          end)
end.

Lemma electCandidateSpeedUp_correct {Action : Set} : forall RegexpXAction_list str, electCandidate (Action:=Action) RegexpXAction_list str = electCandidateSpeedUp RegexpXAction_list str.
Proof.
induction RegexpXAction_list; simpl; auto.
induction a.
intros.
rewrite IHRegexpXAction_list.
rewrite match_len_speed_up_v2_correct; auto.
Qed.

Definition electionSpeedUp {Action : Set} regexp_to_action str := electCandidateSpeedUp (Action := Action) regexp_to_action str.

Lemma electionSpeedUp_correct {Action : Set} : forall regexp_to_action str, election regexp_to_action str = electionSpeedUp (Action:=Action) regexp_to_action str.
Proof.
unfold electionSpeedUp.
unfold election.
intros.
rewrite electCandidateSpeedUp_correct; auto.
Qed.

Lemma electionSpeedUp_inf_strLen {Action : Set} : forall str regexp_to_action e, electionSpeedUp (Action := Action) regexp_to_action str = Some e -> resultNat e <= String.length str.
Proof.
intros.
rewrite <- electionSpeedUp_correct in H.
eapply election_inf_strLen; eauto.
Qed.

Definition parseElectorSpeedup {Action : Set}:= mkElector Action electionSpeedUp electionSpeedUp_inf_strLen.

Definition make_lexer {Token Hist : Set} regexp_x_action (eof_action : Action (Token := Token) (Hist := Hist)) :=
  mkRecLexer
    Token
    Hist
    (lexergenerator parseElectorSpeedup regexp_x_action eof_action)
    (lexergenerator_start_end_position parseElectorSpeedup regexp_x_action eof_action)
    (lexergenerator_tok_position parseElectorSpeedup regexp_x_action eof_action)
    (lexergenerator_start_tok_position parseElectorSpeedup regexp_x_action eof_action)
    (lexergenerator_start_cur_position_abs parseElectorSpeedup regexp_x_action eof_action)
    (lexergenerator_correct_consum parseElectorSpeedup regexp_x_action eof_action)
    (lexergenerator_no_implementation_error parseElectorSpeedup regexp_x_action eof_action)
    (lexergenerator_start_interruption_position parseElectorSpeedup regexp_x_action eof_action)
    (lexergenerator_start_interruption_position2 parseElectorSpeedup regexp_x_action eof_action)
.


(*

  Copyright 2014 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/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Import type_sys_useful.
Require Import dest_close.

Lemma close_type_system_ipertype {p} :
  forall lib (ts : cts(p))
         T T'
         (eq : per)
         R1 R2 eq1,
    type_system lib ts
    -> defines_only_universes lib ts
    -> computes_to_valc lib T (mkc_ipertype R1)
    -> computes_to_valc lib T' (mkc_ipertype R2)
    -> (forall x y : CTerm,
          close lib ts (mkc_apply2 R1 x y) (mkc_apply2 R2 x y) (eq1 x y))
    -> (forall x y : CTerm,
          type_system lib ts
          -> defines_only_universes lib ts
          -> type_sys_props lib (close lib ts)
                            (mkc_apply2 R1 x y)
                            (mkc_apply2 R2 x y)
                            (eq1 x y))
    -> is_per eq1
    -> (eq <=2=> (pertype_eq eq1))
    -> per_ipertype lib (close lib ts) T T' eq
    -> type_sys_props lib (close lib ts) T T' eq.
Proof.
  introv tysys dou c1 c2 cl1 rec1 isper eqiff per.

  rw @type_sys_props_iff_type_sys_props3.
  prove_type_sys_props3 SCase; intros.

  - SCase "uniquely_valued".
    dclose_lr.

    SSCase "CL_ipertype".
    clear per.
    allunfold @per_ipertype; exrepd.
    ccomputes_to_eqval.
    apply @eq_term_equals_trans with (eq2 := pertype_eq eq1); auto.
    apply @eq_term_equals_trans with (eq2 := pertype_eq eq0); auto;
    try (complete (apply eq_term_equals_sym; auto)).
    unfold pertype_eq, eq_term_equals; introv.
    generalize (type_sys_props_pertype_eq_term_equals1
                  lib (close lib ts) R1 R2 R3 eq1 eq0); intro k.
    repeat (autodimp k hyp).
    generalize (k t1 t2); clear k; intro k.
    allapply @iff_inhabited_if_eq_term_equals; auto.

  - SCase "type_symmetric"; repdors; subst; dclose_lr;
    apply CL_ipertype;
    clear per;
    allunfold @per_ipertype; exrepd;
    unfold per_ipertype;
    ccomputes_to_eqval.

    + exists R1 R3 eq0; sp; spcast; sp.
      apply @eq_term_equals_trans with (eq2 := eq); auto.
      apply eq_term_equals_sym; auto.

  - SCase "type_value_respecting"; repdors; subst;
    apply CL_ipertype; unfold per_ipertype.

    (* 1 *)
    apply cequivc_mkc_ipertype with (a := R1) in X; sp.
    exists R1 b eq1; sp; spcast; sp.
    generalize (cl1 x y); intro clt1.
    generalize (rec1 x y); sp.
    onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt.
    generalize (tyvr (mkc_apply2 R1 x y) (mkc_apply2 b x y)); intro imp1.
    repeat (autodimp imp1 hyp).
    repeat (rw @mkc_apply2_eq).
    repeat (apply sp_implies_cequivc_apply); auto.

    (* 2 *)
    apply cequivc_mkc_ipertype with (a := R2) in X; sp.
    exists R2 b eq1; sp; spcast; sp.
    generalize (cl1 x y); intro clt1.
    generalize (rec1 x y); sp.
    onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt.
    generalize (tyvr (mkc_apply2 R2 x y) (mkc_apply2 b x y)); intro imp1.
    repeat (autodimp imp1 hyp).
    repeat (rw @mkc_apply2_eq).
    repeat (apply sp_implies_cequivc_apply); auto.

  - SCase "term_symmetric".
    unfold term_equality_symmetric; introv eqt.
    rw eqiff in eqt; rw eqiff.
    apply is_per_sym; sp.

  - SCase "term_transitive".
    unfold term_equality_transitive; introv eqt1 eqt2.
    rw eqiff in eqt1; rw eqiff in eqt2; rw eqiff.
    apply is_per_trans with (b := t2); sp.

  - SCase "term_value_respecting".
    unfold term_equality_respecting; introv eqt ceq.
    rw eqiff in eqt; rw eqiff.

    spcast.
    assert (eq_term_equals (eq1 t t') (eq1 t t)) as eqteq.
    generalize (rec1 t t); sp.
    onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt.
    generalize (tyvr (mkc_apply2 R1 t t) (mkc_apply2 R1 t t')); intro i; repeat (autodimp i h).
    repeat (rw @mkc_apply2_eq).
    apply implies_cequivc_apply; sp.
    generalize (rec1 t t'); sp.
    onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 tymt2.
    generalize (tygs (mkc_apply2 R1 t t) (mkc_apply2 R1 t t') (eq1 t t)); intro k; repeat (autodimp k h).
    rw k in i.
    generalize (uv2 (mkc_apply2 R1 t t) (eq1 t t)); intro j; repeat (autodimp j h).

    apply eq_term_equals_implies_inhabited in eqteq.
    rw eqteq; sp.

  - SCase "type_gsymmetric".
    repdors; subst; split; sp; dclose_lr;
    apply CL_ipertype;
    clear per;
    allunfold @per_ipertype; exrepd;
    ccomputes_to_eqval;
    unfold per_ipertype.

    (* 1 *)
    exists R3 R1 eq0; sp; spcast; sp.
    apply (type_sys_props_ts_sym3 lib) with (C := mkc_apply2 R2 x y) (eq1 := eq1 x y); sp.

    (* 2 *)
    exists R1 R0 eq0; sp; spcast; sp.
    apply (type_sys_props_ts_sym2 lib) with (C := mkc_apply2 R2 x y) (eq1 := eq1 x y); sp.

  - SCase "type_gtransitive"; sp.

  - SCase "type_mtransitive".
    repdors; subst; dclose_lr;
    allunfold @per_ipertype; exrepnd;
    ccomputes_to_eqval.

    + dands; apply CL_ipertype; unfold per_ipertype.

      * exists R0 R5 eq3; sp; spcast; sp.
        apply (type_sys_props_ts_trans3 lib) with (B := mkc_apply2 R1 x y) (D := mkc_apply2 R2 x y) (eq2 := eq4 x y) (eq := eq1 x y); auto.

      * exists R0 R5 eq4; sp; spcast; sp.
        eapply @type_sys_props_ts_trans4 with (B := mkc_apply2 R1 x y) (D := mkc_apply2 R2 x y) (eq1 := eq3 x y) (eq := eq1 x y); auto.

    + dands; apply CL_ipertype; unfold per_ipertype.

      * exists R0 R5 eq3; sp; spcast; sp.
        eapply @type_sys_props_ts_trans3 with (B := mkc_apply2 R2 x y) (D := mkc_apply2 R1 x y) (eq2 := eq4 x y) (eq := eq1 x y); auto.
        apply @type_sys_props_sym; auto.

      * exists R0 R5 eq4; sp; spcast; sp.
        eapply @type_sys_props_ts_trans4 with (B := mkc_apply2 R2 x y) (D := mkc_apply2 R1 x y) (eq1 := eq3 x y) (eq := eq1 x y); auto.
        apply @type_sys_props_sym; auto.
Qed.