Require Import Coqlib.
Require Import ITreelib.
Require Import ImpPrelude.
Require Import Skeleton.
Require Import PCM.
Require Import STS Behavior.
Require Import Any.
Require Import ModSem.
Require Import Imp.
Require Import AList.

Set Implicit Arguments.

(* ========================================================================== *)
(** ** Rewriting Leamms *)
Section PROOFS.

  Context `{Σ: GRA.t}.

  (* expr *)
  Lemma denote_expr_Var
        ge le0 v
    :
      interp_imp ge (denote_expr (Var v)) le0 =
      interp_imp ge (u <- trigger (GetVar v);; Ret u) le0.
  Proof. reflexivity. Qed.

  Lemma denote_expr_Lit
        ge le0 n
    :
      interp_imp ge (denote_expr (Lit n)) le0 =
      interp_imp ge (tau;; Ret (Vint n)) le0.
  Proof. reflexivity. Qed.

  Lemma denote_expr_Eq
        ge le0 a b
    :
      interp_imp ge (denote_expr (Eq a b)) le0 =
      interp_imp ge (
      l <- denote_expr a ;; r <- denote_expr b ;;
      (if (wf_val l && wf_val r) then Ret tt else triggerUB);;;
      match l, r with
      | Vint lv, Vint rv => if (lv =? rv)%Z then Ret (Vint 1) else Ret (Vint 0)
      | _, _ => triggerUB
      end)le0.
  Proof. reflexivity. Qed.

  Lemma denote_expr_Lt
        ge le0 a b
    :
      interp_imp ge (denote_expr (Lt a b)) le0 =
      interp_imp ge (
      l <- denote_expr a ;; r <- denote_expr b ;;
      (if (wf_val l && wf_val r) then Ret tt else triggerUB);;;
      match l, r with
      | Vint lv, Vint rv => if (Z_lt_dec lv rv) then Ret (Vint 1) else Ret (Vint 0)
      | _, _ => triggerUB
      end)le0.
  Proof. reflexivity. Qed.

  Lemma denote_expr_Plus
        ge le0 a b
    :
      interp_imp ge (denote_expr (Plus a b)) le0 =
      interp_imp ge (
                   ` l : val <- denote_expr a;; ` r : val <- denote_expr b;;
                   ` u : val <- unwrapU (vadd l r);; Ret u)le0.
  Proof. reflexivity. Qed.

  Lemma denote_expr_Minus
        ge le0 a b
    :
      interp_imp ge (denote_expr (Minus a b)) le0 =
      interp_imp ge (
                   ` l : val <- denote_expr a;; ` r : val <- denote_expr b;;
                   ` u : val <- unwrapU (vsub l r);; Ret u) le0.
  Proof. reflexivity. Qed.

  Lemma denote_expr_Mult
        ge le0 a b
    :
      interp_imp ge (denote_expr (Mult a b)) le0 =
      interp_imp ge (
                   ` l : val <- denote_expr a;; ` r : val <- denote_expr b;;
                   ` u : val <- unwrapU (vmul l r);; Ret u) le0.
  Proof. reflexivity. Qed.

  (* stmt *)

  Lemma denote_stmt_Skip
        ge le0
    :
      interp_imp ge (denote_stmt (Skip)) le0 =
      interp_imp ge (tau;; Ret Vundef) le0.
  Proof. reflexivity. Qed.

  Lemma denote_stmt_Assign
        ge le0 x e
    :
      interp_imp ge (denote_stmt (Assign x e)) le0 =
      interp_imp ge (v <- denote_expr e ;; trigger (SetVar x v) ;;; tau;; Ret Vundef) le0.
  Proof. reflexivity. Qed.

  Lemma denote_stmt_Seq
        ge le0 a b
    :
      interp_imp ge (denote_stmt (Seq a b)) le0 =
      interp_imp ge (tau;; denote_stmt a ;;; denote_stmt b) le0.
  Proof. reflexivity. Qed.

  Lemma denote_stmt_If
        ge le0 i t e
    :
      interp_imp ge (denote_stmt (If i t e)) le0 =
      interp_imp ge (v <- denote_expr i ;;
                     (if (wf_val v) then Ret tt else triggerUB);;;
                     `b: bool <- (is_true v)? ;; tau;;
                     if b then (denote_stmt t) else (denote_stmt e)) le0.
  Proof. reflexivity. Qed.

  Lemma denote_stmt_AddrOf
        ge le0 x X
    :
      interp_imp ge (denote_stmt (AddrOf x X)) le0 =
      interp_imp ge (v <- trigger (GetPtr X);; trigger (SetVar x v);;; tau;; Ret Vundef) le0.
  Proof. reflexivity. Qed.

  Lemma denote_stmt_Malloc
        ge le0 x se
    :
      interp_imp ge (denote_stmt (Malloc x se)) le0 =
      interp_imp ge (s <- denote_expr se;;
      v <- ccallU "alloc" [s];;
      trigger (SetVar x v);;; tau;; Ret Vundef) le0.
  Proof. reflexivity. Qed.

  Lemma denote_stmt_Free
        ge le0 pe
    :
      interp_imp ge (denote_stmt (Free pe)) le0 =
      interp_imp ge (p <- denote_expr pe;;
      `_:val <- ccallU "free" [p];; tau;; Ret Vundef) le0.
  Proof. reflexivity. Qed.

  Lemma denote_stmt_Load
        ge le0 x pe
    :
      interp_imp ge (denote_stmt (Load x pe)) le0 =
      interp_imp ge (
                   ` p : val <- denote_expr pe;;
                         (if wf_val p then Ret tt else triggerUB);;;
                         v0 <- ccallU "load" [p];;
                         trigger (SetVar x v0);;; (tau;; Ret Vundef)) le0.
  Proof. reflexivity. Qed.

  Lemma denote_stmt_Store
        ge le0 pe ve
    :
      interp_imp ge (denote_stmt (Store pe ve)) le0 =
      interp_imp ge (
                   ` p : val <- denote_expr pe;;
                         (if wf_val p then Ret tt else triggerUB);;;
                          ` v : val <- denote_expr ve;;
                              `_:val <- ccallU "store" [p; v];; tau;; Ret Vundef
                          ) le0.
  Proof. reflexivity. Qed.

  Lemma denote_stmt_Cmp
        ge le0 x ae be
    :
      interp_imp ge (denote_stmt (Cmp x ae be)) le0 =
      interp_imp ge ( a <- denote_expr ae;; b <- denote_expr be;;
                      (if (wf_val a && wf_val b) then Ret tt else triggerUB);;;
                        v <- ccallU "cmp" [a; b];;
                        trigger (SetVar x v);;; tau;; Ret Vundef) le0.
  Proof. reflexivity. Qed.

  Lemma denote_stmt_CallFun
        ge le0 x f args
    :
      interp_imp ge (denote_stmt (CallFun x f args)) le0 =
      interp_imp ge (
      (if (call_ban f) then triggerUB else Ret tt);;;
      eval_args <- (denote_exprs args);;
      v <- ccallU f eval_args;;
      trigger (SetVar x v);;; tau;; Ret Vundef) le0.
  Proof. reflexivity. Qed.

  Lemma denote_stmt_CallPtr
        ge le0 x e args
    :
      interp_imp ge (denote_stmt (CallPtr x e args)) le0 =
      interp_imp ge (
      (if match e with
          | Var _ => true
          | _ => false
          end then Ret () else triggerUB);;;
      ` p : val <- denote_expr e;;
      ` f : string <- trigger (GetName p);;
      ` eval_args : list val <- denote_exprs args;; ` v : val <- ccallU f eval_args;; trigger (SetVar x v);;; (tau;; Ret Vundef)) le0.
  Proof. reflexivity. Qed.

  Lemma denote_stmt_CallSys
        ge le0 x f args
    :
      interp_imp ge (denote_stmt (CallSys x f args)) le0 =
      interp_imp ge (
      ` sig : nat <- unwrapU (alist_find f syscalls);;
      (if (sig =? Datatypes.length args)%nat then Ret () else triggerUB);;;
      ` eval_args : list val <- denote_exprs args;;
      (if forallb (fun v : val => match v with
                                  | Vint _ => true
                                  | _ => false
                                  end) eval_args then Ret () else triggerUB);;;
      (let eval_zs := List.map (fun v : val => match v with
                                               | Vint z => z
                                               | _ => 0%Z
                                               end) eval_args in
       (if forallb intrange_64 eval_zs then Ret () else triggerUB);;;
       v <- trigger (Syscall f eval_zs↑ top1);; v <- v↓?;; trigger (SetVar x (Vint v));;; (tau;; Ret Vundef))) le0.
  Proof. reflexivity. Qed.

  (* interp_imp *)

  Lemma interp_imp_bind
        T R (itr: itree _ T) (ktr: T -> itree _ R) ge le0
    :
      interp_imp ge (v <- itr ;; ktr v) le0 =
      '(le1, v) <- interp_imp ge itr le0;;
      interp_imp ge (ktr v) le1.
  Proof.
    unfold interp_imp. unfold interp_GlobEnv.
    unfold interp_ImpState. grind. des_ifs.
  Qed.

  Lemma interp_imp_tau
        T (itr: itree _ T) ge le0
    :
      interp_imp ge (tau;; itr) le0 =
      tau;; interp_imp ge itr le0.
  Proof.
    unfold interp_imp, interp_ImpState, interp_GlobEnv.
    grind.
  Qed.

  Lemma interp_imp_Ret
        T ge le0 (v: T)
    :
      interp_imp ge (Ret v) le0 = Ret (le0, v).
  Proof.
    unfold interp_imp, interp_ImpState, interp_GlobEnv.
    grind.
  Qed.

  Lemma interp_imp_triggerUB
        T ge le0
    :
      (interp_imp ge (triggerUB) le0 : itree _ (lenv *T)) = triggerUB.
  Proof.
    unfold interp_imp, interp_ImpState, interp_GlobEnv, pure_state, triggerUB.
    grind. rewrite interp_trigger. grind.
  Qed.

  Lemma interp_imp_triggerUB_bind
        U T ge le0 (ktr: U -> itree _ T)
    :
      (interp_imp ge (x <- triggerUB;; ktr x) le0 : itree _ (lenv *T)) = triggerUB.
  Proof.
    unfold interp_imp, interp_ImpState, interp_GlobEnv, pure_state, triggerUB.
    grind. rewrite interp_trigger. grind.
  Qed.

  Lemma interp_imp_triggerNB
        T ge le0
    :
      (interp_imp ge (triggerNB) le0 : itree _ (lenv * T)) = triggerNB.
  Proof.
    unfold interp_imp, interp_ImpState, interp_GlobEnv, pure_state, triggerNB.
    grind. rewrite interp_trigger. grind.
  Qed.

  Lemma interp_imp_triggerNB_bind
        U T ge le0 (ktr: U -> itree _ T)
    :
      (interp_imp ge (x <- triggerNB;; ktr x) le0 : itree _ (lenv * T)) = triggerNB.
  Proof.
    unfold interp_imp, interp_ImpState, interp_GlobEnv, pure_state, triggerNB.
    grind. rewrite interp_trigger. grind.
  Qed.

  Lemma interp_imp_unwrapU
        T x ge le0
    :
      (interp_imp ge (unwrapU x) le0 : itree _ (lenv * T)) =
      x <- unwrapU x;; Ret (le0, x).
  Proof.
    unfold unwrapU. des_ifs.
    - rewrite interp_imp_Ret. ired. ss.
    - rewrite interp_imp_triggerUB.
      unfold triggerUB. grind.
  Qed.

  Lemma interp_imp_unwrapN
        T x ge le0
    :
      (interp_imp ge (unwrapN x) le0 : itree _ (lenv * T)) =
      x <- unwrapN x;; Ret (le0, x).
  Proof.
    unfold unwrapN. des_ifs.
    - rewrite interp_imp_Ret. ired. ss.
    - rewrite interp_imp_triggerNB.
      unfold triggerNB. grind.
  Qed.

  Lemma interp_imp_GetPtr
        ge le0 X
    :
      interp_imp ge (trigger (GetPtr X)) le0 =
      r <- (ge.(SkEnv.id2blk) X)? ;; tau;; Ret (le0, Vptr r 0).
  Proof.
    unfold interp_imp, interp_GlobEnv, interp_ImpState, unwrapU.
    des_ifs; grind.
    - rewrite interp_trigger. grind.
      unfold unwrapU. des_ifs. grind.
    - rewrite interp_trigger. grind.
      unfold unwrapU. des_ifs. unfold triggerUB, pure_state. grind.
  Qed.

  Lemma interp_imp_GetName
        ge le0 x
    :
      interp_imp ge (trigger (GetName x)) le0 =
      match x with
      | Vptr n 0 => u <- unwrapU (SkEnv.blk2id ge n);; tau;; Ret (le0, u)
      | _ => triggerUB
      end
  .
  Proof.
    unfold interp_imp, interp_GlobEnv, interp_ImpState.
    destruct x; try destruct ofs.
    1,3,4,5:(rewrite interp_trigger; grind; unfold triggerUB, pure_state; grind).
    rewrite interp_trigger. grind. unfold unwrapU.
    destruct (SkEnv.blk2id ge blk).
    2:{ unfold triggerUB, pure_state. grind. }
    grind.
  Qed.

  Lemma interp_imp_GetVar
        ge le0 x
    :
      (interp_imp ge (trigger (GetVar x)) le0 : itree Es _) =
      r <- unwrapU (alist_find x le0);; tau;; tau;; Ret (le0, r).
  Proof.
    unfold interp_imp, interp_ImpState, interp_GlobEnv.
    rewrite interp_trigger. grind.
  Qed.

  Lemma interp_imp_SetVar
        ge le0 x v
    :
      interp_imp ge (trigger (SetVar x v)) le0 =
      tau;; tau;; Ret (alist_add x v le0, ()).
  Proof.
    unfold interp_imp, interp_GlobEnv, interp_ImpState.
    rewrite interp_trigger. grind.
  Qed.

  Lemma interp_imp_ccallU
        ge le0 f (args: list val)
    :
      (interp_imp ge (ccallU f args) le0 : itree _ (_ * val)) =
      v <- trigger (Call f (args↑));; tau;; tau;; v <- (v↓)?;; Ret (le0, v).
  Proof.
    unfold interp_imp, interp_GlobEnv, interp_ImpState, ccallU. grind.
    unfold pure_state. rewrite interp_trigger. grind.
    unfold unwrapU. des_ifs; grind. unfold triggerUB. grind.
    rewrite interp_trigger. grind.
  Qed.

  Lemma interp_imp_Syscall
        ge le0 f args t
    :
      interp_imp ge (trigger (Syscall f args t)) le0 =
      v <- trigger (Syscall f args t);; tau;; tau;; Ret (le0, v).
  Proof.
    unfold interp_imp, interp_GlobEnv, interp_ImpState.
    unfold pure_state. rewrite interp_trigger. grind.
  Qed.

  Lemma interp_imp_assume
        ge le0 p
    :
      interp_imp ge (assume p) le0 = assume p;;; tau;; tau;; Ret (le0, ()).
  Proof.
    unfold interp_imp, interp_GlobEnv, interp_ImpState.
    unfold assume. grind. rewrite interp_trigger. grind.
    unfold pure_state. grind.
  Qed.

  Lemma interp_imp_guarantee
        ge le0 p
    :
      interp_imp ge (guarantee p) le0 = guarantee p;;; tau;; tau;; Ret (le0, ()).
  Proof.
    unfold interp_imp, interp_GlobEnv, interp_ImpState.
    unfold guarantee. grind. rewrite interp_trigger. grind.
    unfold pure_state. grind.
  Qed.

  Lemma interp_Es_ext
        ge R (itr0 itr1: itree _ R) le0
    :
      itr0 = itr1 -> interp_imp ge itr0 le0 = interp_imp ge itr1 le0
  .
  Proof. i; subst; refl. Qed.

  Lemma interp_imp_expr_Var
        ge le0 v
    :
      interp_imp ge (denote_expr (Var v)) le0 =
      r <- unwrapU (alist_find v le0);; tau;; tau;; Ret (le0, r).
  Proof.
    rewrite denote_expr_Var. rewrite interp_imp_bind. rewrite interp_imp_GetVar.
    grind. apply interp_imp_Ret.
  Qed.

  Lemma interp_imp_expr_Lit
        ge le0 n
    :
      interp_imp ge (denote_expr (Lit n)) le0 =
      tau;; Ret (le0, Vint n).
  Proof.
    rewrite denote_expr_Lit. rewrite interp_imp_tau. grind; apply interp_imp_Ret.
  Qed.

  Lemma interp_imp_expr_Eq
        ge le0 a b
    :
      interp_imp ge (denote_expr (Eq a b)) le0 =
      '(le1, l) <- interp_imp ge (denote_expr a) le0 ;;
      '(le2, r) <- interp_imp ge (denote_expr b) le1 ;;
      (if (wf_val l && wf_val r) then Ret tt else triggerUB);;;
      match l, r with
      | Vint lv, Vint rv => if (lv =? rv)%Z then Ret (le2, Vint 1) else Ret (le2, Vint 0)
      | _, _ => triggerUB
      end
  .
  Proof.
    rewrite denote_expr_Eq. rewrite interp_imp_bind.
    grind. rewrite interp_imp_bind. grind.
    rewrite interp_imp_bind. destruct (wf_val v && wf_val v0).
    2:{ rewrite interp_imp_triggerUB. unfold triggerUB; grind. }
    rewrite interp_imp_Ret. grind.
    des_ifs; try apply interp_imp_triggerUB.
    1,2: apply interp_imp_Ret.
  Qed.

  Lemma interp_imp_expr_Lt
        ge le0 a b
    :
      interp_imp ge (denote_expr (Lt a b)) le0 =
      '(le1, l) <- interp_imp ge (denote_expr a) le0 ;;
      '(le2, r) <- interp_imp ge (denote_expr b) le1 ;;
      (if (wf_val l && wf_val r) then Ret tt else triggerUB);;;
      match l, r with
      | Vint lv, Vint rv => if (Z_lt_dec lv rv) then Ret (le2, Vint 1) else Ret (le2, Vint 0)
      | _, _ => triggerUB
      end
  .
  Proof.
    rewrite denote_expr_Lt. rewrite interp_imp_bind.
    grind. rewrite interp_imp_bind. grind.
    rewrite interp_imp_bind. destruct (wf_val v && wf_val v0).
    2:{ rewrite interp_imp_triggerUB. unfold triggerUB; grind. }
    rewrite interp_imp_Ret. grind.
    des_ifs; try apply interp_imp_triggerUB.
    1,2: apply interp_imp_Ret.
  Qed.

  Lemma interp_imp_expr_Plus
        ge le0 a b
    :
      interp_imp ge (denote_expr (Plus a b)) le0 =
      '(le1, l) <- interp_imp ge (denote_expr a) le0 ;;
      '(le2, r) <- interp_imp ge (denote_expr b) le1 ;;
      ` u : val <- unwrapU (vadd l r);; Ret (le2, u)
  .
  Proof.
    rewrite denote_expr_Plus. rewrite interp_imp_bind.
    grind. rewrite interp_imp_bind. grind.
    rewrite interp_imp_unwrapU. grind.
  Qed.

  Lemma interp_imp_expr_Minus
        ge le0 a b
    :
      interp_imp ge (denote_expr (Minus a b)) le0 =
      '(le1, l) <- interp_imp ge (denote_expr a) le0 ;;
      '(le2, r) <- interp_imp ge (denote_expr b) le1 ;;
      ` u : val <- unwrapU (vsub l r);; Ret (le2, u)
  .
  Proof.
    rewrite denote_expr_Minus. rewrite interp_imp_bind.
    grind. rewrite interp_imp_bind. grind.
    rewrite interp_imp_unwrapU. grind.
  Qed.

  Lemma interp_imp_expr_Mult
        ge le0 a b
    :
      interp_imp ge (denote_expr (Mult a b)) le0 =
      '(le1, l) <- interp_imp ge (denote_expr a) le0 ;;
      '(le2, r) <- interp_imp ge (denote_expr b) le1 ;;
      ` u : val <- unwrapU (vmul l r);; Ret (le2, u)
  .
  Proof.
    rewrite denote_expr_Mult. rewrite interp_imp_bind.
    grind. rewrite interp_imp_bind. grind.
    rewrite interp_imp_unwrapU. grind.
  Qed.

  Lemma interp_imp_Skip
        ge le0
    :
      interp_imp ge (denote_stmt (Skip)) le0 =
      tau;; Ret (le0, Vundef).
  Proof.
    rewrite denote_stmt_Skip. rewrite interp_imp_tau.
    grind. apply interp_imp_Ret.
  Qed.

  Lemma interp_imp_Assign
        ge le0 x e
    :
      interp_imp ge (denote_stmt (Assign x e)) le0 =
      '(le1, v) <- interp_imp ge (denote_expr e) le0 ;;
      tau;; tau;; tau;; Ret (alist_add x v le1, Vundef).
  Proof.
    rewrite denote_stmt_Assign.
    rewrite interp_imp_bind. grind.
    rewrite interp_imp_bind. rewrite interp_imp_SetVar. grind.
    rewrite interp_imp_tau; grind.
    apply interp_imp_Ret.
  Qed.

  Lemma interp_imp_Seq
        ge le0 a b
    :
      interp_imp ge (denote_stmt (Seq a b)) le0 =
      tau;;
      '(le1, _) <- interp_imp ge (denote_stmt a) le0 ;;
      interp_imp ge (denote_stmt b) le1.
  Proof.
    rewrite denote_stmt_Seq. rewrite interp_imp_tau; grind.
    apply interp_imp_bind.
  Qed.

  Lemma interp_imp_If
        ge le0 i t e
    :
      interp_imp ge (denote_stmt (If i t e)) le0 =
      '(le1, v) <- interp_imp ge (denote_expr i) le0 ;;
      (if (wf_val v) then Ret tt else triggerUB);;;
          `b: bool <- (is_true v)? ;; tau;;
              if b
              then interp_imp ge (denote_stmt t) le1
              else interp_imp ge (denote_stmt e) le1.
  Proof.
    rewrite denote_stmt_If. rewrite interp_imp_bind. grind.
    des_ifs.
    2:{ rewrite interp_imp_bind. rewrite interp_imp_triggerUB. unfold triggerUB. grind. }
    destruct (is_true v); grind; des_ifs.
    1,2: rewrite interp_imp_tau; grind.
    rewrite interp_imp_triggerUB_bind. unfold triggerUB. grind.
  Qed.

  Lemma interp_imp_AddrOf
        ge le0 x X
    :
      interp_imp ge (denote_stmt (AddrOf x X)) le0 =
      r <- (ge.(SkEnv.id2blk) X)? ;; tau;;
      tau;; tau;; tau;; Ret (alist_add x (Vptr r 0) le0, Vundef).
  Proof.
    rewrite denote_stmt_AddrOf. rewrite interp_imp_bind.
    rewrite interp_imp_GetPtr. grind.
    rewrite interp_imp_bind. rewrite interp_imp_SetVar. grind.
    rewrite interp_imp_tau; grind. apply interp_imp_Ret.
  Qed.

  Lemma interp_imp_Malloc
        ge le0 x se
    :
      interp_imp ge (denote_stmt (Malloc x se)) le0 =
      '(le1, s) <- interp_imp ge (denote_expr se) le0;;
      v <- trigger (Call "alloc" ([s]↑));;
      tau;; tau;; v <- unwrapU (v↓);;
      tau;; tau;; tau;; Ret (alist_add x v le1, Vundef).
  Proof.
    rewrite denote_stmt_Malloc. rewrite interp_imp_bind. grind.
    rewrite interp_imp_bind. rewrite interp_imp_ccallU. grind.
    rewrite interp_imp_bind. rewrite interp_imp_SetVar. grind.
    rewrite interp_imp_tau; grind. apply interp_imp_Ret.
  Qed.

  Lemma interp_imp_Free
        ge le0 pe
    :
      interp_imp ge (denote_stmt (Free pe)) le0 =
      '(le1, p) <- interp_imp ge (denote_expr pe) le0;;
      v <- trigger (Call "free" ([p]↑));;
      tau;; tau;; `v:val <- unwrapU (v↓);; tau;; Ret (le1, Vundef).
  Proof.
    rewrite denote_stmt_Free. rewrite interp_imp_bind. grind.
    rewrite interp_imp_bind. rewrite interp_imp_ccallU. grind.
    rewrite interp_imp_tau; grind. apply interp_imp_Ret.
  Qed.

  Lemma interp_imp_Load
        ge le0 x pe
    :
      interp_imp ge (denote_stmt (Load x pe)) le0 =
      '(le1, p) <- interp_imp ge (denote_expr pe) le0;;
      (if (wf_val p) then Ret tt else triggerUB);;;
      v <- trigger (Call "load" ([p]↑));;
      tau;; tau;; v <- unwrapU (v↓);;
      tau;; tau;; tau;; Ret (alist_add x v le1, Vundef).
  Proof.
    rewrite denote_stmt_Load. rewrite interp_imp_bind. grind.
    des_ifs.
    2:{ rewrite interp_imp_bind. rewrite interp_imp_triggerUB. unfold triggerUB. grind. }
    rewrite interp_imp_bind. grind. rewrite interp_imp_Ret. grind.
    rewrite interp_imp_bind. rewrite interp_imp_ccallU. grind.
    rewrite interp_imp_bind. rewrite interp_imp_SetVar. grind.
    rewrite interp_imp_tau; grind. apply interp_imp_Ret.
  Qed.

  Lemma interp_imp_Store
        ge le0 pe ve
    :
      interp_imp ge (denote_stmt (Store pe ve)) le0 =
      '(le1, p) <- interp_imp ge (denote_expr pe) le0;;
      (if (wf_val p) then Ret tt else triggerUB);;;
      '(le2, v) <- interp_imp ge (denote_expr ve) le1;;
      v <- trigger (Call "store" ([p ; v]↑));;
      tau;; tau;; `v:val <- (v↓)?;; tau;; Ret (le2, Vundef).
  Proof.
    rewrite denote_stmt_Store. rewrite interp_imp_bind. grind.
    des_ifs.
    2:{ rewrite interp_imp_bind. rewrite interp_imp_triggerUB. unfold triggerUB; grind. }
    rewrite interp_imp_bind. grind.
    rewrite interp_imp_Ret; grind.
    rewrite interp_imp_bind. grind.
    rewrite interp_imp_bind. rewrite interp_imp_ccallU. grind.
    rewrite interp_imp_tau; grind. apply interp_imp_Ret.
  Qed.

  Lemma interp_imp_Cmp
        ge le0 x ae be
    :
      interp_imp ge (denote_stmt (Cmp x ae be)) le0 =
      '(le1, a) <- interp_imp ge (denote_expr ae) le0;;
      '(le2, b) <- interp_imp ge (denote_expr be) le1;;
      (if (wf_val a && wf_val b) then Ret tt else triggerUB);;;
          v <- trigger (Call "cmp" ([a ; b]↑));;
          tau;; tau;; v <- unwrapU (v↓);;
          tau;; tau;; tau;; Ret (alist_add x v le2, Vundef).
  Proof.
    rewrite denote_stmt_Cmp. rewrite interp_imp_bind. grind.
    rewrite interp_imp_bind. grind.
    des_ifs.
    2:{ rewrite interp_imp_bind. rewrite interp_imp_triggerUB. unfold triggerUB; grind. }
    rewrite interp_imp_bind. rewrite interp_imp_Ret; grind.
    rewrite interp_imp_bind. rewrite interp_imp_ccallU. grind.
    rewrite interp_imp_bind. rewrite interp_imp_SetVar. grind.
    rewrite interp_imp_tau; grind. apply interp_imp_Ret.
  Qed.

  Lemma interp_imp_Call_args
        ge le0 x f args
    :
      interp_imp ge (
                   eval_args <- (denote_exprs args);;
                   v <- ccallU f eval_args;;
                   trigger (SetVar x v);;; tau;; Ret Vundef) le0
      =
      '(le1, vals) <- interp_imp ge (denote_exprs args) le0;;
      v <- trigger (Call f (vals↑));;
      tau;; tau;; v <- unwrapU (v↓);;
      tau;; tau;; tau;; Ret (alist_add x v le1, Vundef).
  Proof.
    rewrite interp_imp_bind. grind.
    rewrite interp_imp_bind. rewrite interp_imp_ccallU. grind.
    rewrite interp_imp_bind. rewrite interp_imp_SetVar. grind.
    rewrite interp_imp_tau; grind. apply interp_imp_Ret.
  Qed.

  Lemma interp_imp_CallFun
        ge le0 x f args
    :
      interp_imp ge (denote_stmt (CallFun x f args)) le0 =
      (if (call_ban f) then triggerUB else Ret tt);;;
        '(le1, vals) <- interp_imp ge (denote_exprs args) le0;;
        v <- trigger (Call f (vals↑));;
        tau;; tau;; v <- unwrapU (v↓);;
        tau;; tau;; tau;; Ret (alist_add x v le1, Vundef).
  Proof.
    rewrite denote_stmt_CallFun. des_ifs.
    { rewrite interp_imp_triggerUB_bind. unfold triggerUB. grind. }
    rewrite interp_imp_bind. rewrite interp_imp_Ret. grind. apply interp_imp_Call_args.
  Qed.

  Lemma interp_imp_CallPtr
        ge le0 x e args
    :
      interp_imp ge (denote_stmt (CallPtr x e args)) le0 =
      (if match e with
         | Var _ => true
         | _ => false
         end
       then Ret tt else triggerUB);;;
          '(le1, p) <- interp_imp ge (denote_expr e) le0;;
          match p with
          | Vptr n 0 =>
            match (SkEnv.blk2id ge n) with
            | Some f =>
                tau;;
                '(le2, vals) <- interp_imp ge (denote_exprs args) le1;;
                v <- trigger (Call f (vals↑));;
                tau;; tau;; v <- unwrapU (v↓);;
                tau;; tau;; tau;; Ret (alist_add x v le2, Vundef)
            | None => triggerUB
            end
          | _ => triggerUB
          end
  .
  Proof.
    rewrite denote_stmt_CallPtr. des_ifs.
    2,3,4,5,6,7: rewrite interp_imp_triggerUB_bind; unfold triggerUB; grind.
    rewrite interp_imp_bind. rewrite interp_imp_Ret. grind.
    rewrite interp_imp_bind. grind.
    rewrite interp_imp_bind. rewrite interp_imp_GetName.
    des_ifs.
    1,5,6:(unfold triggerUB; grind).
    3:{ unfold unwrapU. grind. unfold triggerUB. grind. }
    - unfold unwrapU. grind. apply interp_imp_Call_args.
    - unfold unwrapU. grind. unfold triggerUB; grind.
  Qed.

  Lemma interp_imp_Syscall_args
        ge le0 x f args t
    :
      interp_imp ge (
      ` eval_args : list val <- denote_exprs args;;
      (if forallb (fun v : val => match v with
                                  | Vint _ => true
                                  | _ => false
                                  end) eval_args then Ret () else triggerUB);;;
      (let eval_zs := List.map (fun v : val => match v with
                                               | Vint z => z
                                               | _ => 0%Z
                                               end) eval_args in
       (if forallb intrange_64 eval_zs then Ret () else triggerUB);;;
       v <- trigger (Syscall f eval_zs↑ t);; v <- v↓?;; trigger (SetVar x (Vint v));;; (tau;; Ret Vundef))) le0
      =
      '(le1, vals) <- interp_imp ge (denote_exprs args) le0;;
      (if forallb (fun v : val => match v with
                                  | Vint _ => true
                                  | _ => false
                                  end) vals then Ret () else triggerUB);;;
      (let eval_zs := List.map (fun v : val => match v with
                                               | Vint z => z
                                               | _ => 0%Z
                                               end) vals in
      (if (forallb intrange_64 eval_zs) then Ret tt else triggerUB);;;
        v <- trigger (Syscall f eval_zs↑ t);; tau;; tau;; v <- v↓?;;
        tau;; tau;;
        tau;; Ret (alist_add x (Vint v) le1, Vundef)).
  Proof.
    rewrite interp_imp_bind. grind.
    des_ifs.
    2:{ grind. rewrite interp_imp_triggerUB_bind. unfold triggerUB; grind. }
    2:{ rewrite interp_imp_bind. rewrite interp_imp_triggerUB. unfold triggerUB; grind. }
    2:{ rewrite interp_imp_triggerUB_bind. unfold triggerUB; grind. }
    rewrite interp_imp_bind. rewrite interp_imp_Ret; grind.
    rewrite interp_imp_bind. rewrite interp_imp_Syscall. grind.
    rewrite interp_imp_bind. destruct (Any.downcast x0).
    { cbn. rewrite interp_imp_Ret. grind. rewrite interp_imp_bind. rewrite interp_imp_SetVar. grind.
      rewrite interp_imp_tau; grind. apply interp_imp_Ret. }
    { cbn. rewrite interp_imp_triggerUB. unfold triggerUB. grind. }
  Qed.

  Lemma interp_imp_CallSys
        ge le0 x f args
    :
      interp_imp ge (denote_stmt (CallSys x f args)) le0 =
      sig <- (alist_find f syscalls)? ;;
      (if (sig =? List.length args)%nat then Ret tt else triggerUB);;;
      '(le1, vals) <- interp_imp ge (denote_exprs args) le0;;
      (if forallb (fun v : val => match v with
                                  | Vint _ => true
                                  | _ => false
                                  end) vals then Ret () else triggerUB);;;
      (let eval_zs := List.map (fun v : val => match v with
                                               | Vint z => z
                                               | _ => 0%Z
                                               end) vals in
      (if (forallb intrange_64 eval_zs) then Ret tt else triggerUB);;;
        v <- trigger (Syscall f eval_zs↑ top1);; tau;; tau;; v <- v↓?;;
        tau;; tau;;
        tau;; Ret (alist_add x (Vint v) le1, Vundef)).
  Proof.
    rewrite denote_stmt_CallSys.
    rewrite interp_imp_bind. rewrite interp_imp_unwrapU. grind.
    des_ifs.
    2:{ rewrite interp_imp_triggerUB_bind. unfold triggerUB; grind. }
    rewrite interp_imp_bind; rewrite interp_imp_Ret; grind.
    apply interp_imp_Syscall_args.
  Qed.

  (* eval_imp  *)
  Lemma unfold_eval_imp
        ge fparams fvars fbody args
    :
      ` vret : val <- eval_imp ge (mk_function fparams fvars fbody) args ;; Ret (vret↑)
               =
               ` vret : val <-
                        (
                          let vars := fvars ++ ["return"; "_"] in
                          let params := fparams in
                          (if ListDec.NoDup_dec string_dec (params ++ vars) then Ret tt else triggerUB);;;
                              match init_args params args (init_lenv vars) with
                              | Some iargs =>
                                ` x_ : lenv * val <-
                                       interp_imp ge (tau;; denote_stmt fbody;;; ` retv : val <- denote_expr (Var "return");; Ret retv)
                                                  iargs;; (let (_, retv) := x_ in Ret retv)
                              | None => triggerUB
                              end);; Ret (vret↑).
  Proof.
    unfold eval_imp. ss.
  Qed.

  Lemma unfold_eval_imp_only
        ge f args
    :
      eval_imp ge f args
      =
      let vars := fn_vars f ++ ["return"; "_"] in
      let params := fn_params f in
      (if ListDec.NoDup_dec string_dec (params ++ vars) then Ret tt else triggerUB);;;
          match init_args params args (init_lenv vars) with
          | Some iargs =>
            ` x_ : lenv * val <-
                   interp_imp ge (tau;; denote_stmt (fn_body f);;; ` retv : val <- denote_expr (Var "return");; Ret retv)
                              iargs;; (let (_, retv) := x_ in Ret retv)
          | None => triggerUB
          end
  .
  Proof. ss. Qed.

End PROOFS.

(** tactics **)
Global Opaque denote_expr.
Global Opaque denote_stmt.
Global Opaque interp_imp.
Global Opaque eval_imp.

Require Import Red IRed.

Require Import SimModSem.
Require Import HTactics.
Require Import ImpNotations.

Import ImpNotations.
(** tactic for imp-program reduction *)
Ltac imp_red :=
  cbn; try (rewrite interp_imp_bind);
  match goal with
  (** denote_stmt *)
  | [ |- (gpaco8 (_sim_itree _ _) _ _ _ _ _ _ _ _ _ _ (_, ITree.bind (interp_imp _ (denote_stmt (?stmt)) _) _)) ] =>
    match stmt with
    | Skip => rewrite interp_imp_Skip
    | Assign _ _ => rewrite interp_imp_Assign
    | Seq _ _ => rewrite interp_imp_Seq; imp_red
    | If _ _ _ => rewrite interp_imp_If
    | CallFun _ _ _ => rewrite interp_imp_CallFun
    | CallPtr _ _ _ => rewrite interp_imp_CallPtr
    | CallSys _ _ _ => rewrite interp_imp_CallSys
    | AddrOf _ _ => rewrite interp_imp_AddrOf
    | Malloc _ _ => rewrite interp_imp_Malloc
    | Free _ => rewrite interp_imp_Free
    | Load _ _ => rewrite interp_imp_Load
    | Store _ _ => rewrite interp_imp_Store
    | Cmp _ _ _ => rewrite interp_imp_Cmp
    | _ => fail
    end

      (** denote_expr *)
  | [ |- (gpaco8 (_sim_itree _ _) _ _ _ _ _ _ _ _ _ _ (_, ITree.bind (interp_imp _ (denote_expr (?expr)) _) _)) ] =>
    match expr with
    | Var _ => rewrite interp_imp_expr_Var
    | Lit _ => rewrite interp_imp_expr_Lit
    | Eq _ _ => rewrite interp_imp_expr_Eq
    | Lt _ _ => rewrite interp_imp_expr_Lt
    | Plus _ _ => rewrite interp_imp_expr_Plus
    | Minus _ _ => rewrite interp_imp_expr_Minus
    | Mult _ _ => rewrite interp_imp_expr_Mult
    | Var_coerce _ => rewrite interp_imp_expr_Var
    | Lit_coerce _ => rewrite interp_imp_expr_Lit
    | _ => fail
    end

  | [ |- (gpaco8 (_sim_itree _ _) _ _ _ _ _ _ _ _ _ _ (_, ITree.bind (interp_imp _ (tau;; _) _) _)) ] =>
    rewrite interp_imp_tau

  | [ |- (gpaco8 (_sim_itree _ _) _ _ _ _ _ _ _ _ _ _ (_, ITree.bind (interp_imp _ (Ret _) _) _)) ] =>
    rewrite interp_imp_Ret

  | _ => idtac
  end.

Ltac imp_steps := repeat (repeat (imp_red; ss); steps).
Ltac solve_NoDup := repeat econs; ii; ss; des; ss.


Require Import Category.
Require Import Indexed.
Require Import Sized.
Require Import Success.
Require Import Combinators.
Require Import String.
Require Import StringAsList.
Require Import Ascii.

Require Import Coq.Arith.Le.

Inductive Singleton (A : Type) : A -> Type :=
  MkSingleton : forall a, Singleton A a.

Arguments Singleton {_}.
Arguments MkSingleton {_}.

Class Tokenizer (A : Type) : Type :=
  MkTokenizer { _tokenize : list ascii -> list A }.

Definition tokenize {A : Type} `{Tokenizer A} : list ascii -> list A := _tokenize.

Arguments MkTokenizer {_}.

Definition fromText {A : Type} `{Tokenizer A} (s : string) : list A :=
  tokenize (fromString s).

Instance tokAscii : Tokenizer ascii := MkTokenizer (fun x => x).

Section Check.

Context
  {Tok : Type} `{Tokenizer Tok}
  {M : Type -> Type} `{RawMonadRun M}
  {A : Type}.

Definition check : string -> [ Parser (SizedList Tok) Tok M A ] -> Type := fun s p =>
  let tokens := (fromText s : list Tok) in
  let n      := List.length tokens in
  let input  := mkSizedList tokens in
  let result := runParser (p n) (le_refl n) input in
  let valid  := fun s => match Success.size s with | O => Some (Success.value s) | _ => None end in
  match mapM valid (runMonad result) with
    | Some (cons hd _) => @Singleton A hd
    | _                => False
  end.

End Check.


Require Import Poulet4.P4light.Syntax.P4defs.
Require Import Poulet4.P4light.Syntax.P4Notations.
Require Import Coq.Program.Program.
Open Scope string_scope.
Import ListNotations.

Require Import Poulet4.Utils.Maps.
Require Import Poulet4.P4light.Semantics.Semantics.
Require Import Poulet4.P4light.Transformations.SimplExpr.
Require Import Poulet4.P4light.Architecture.V1ModelTarget.
Require Import Poulet4.Utils.P4Arith.

Require Import ProD3.core.Core.
Require Import ProD3.core.V1ModelSpec.
Require Import ProD3.examples.bloomfilter.p4ast.
Require Import ProD3.examples.sbf.ConFilter.
Require Import ProD3.examples.sbf.general_bf.

#[local] Instance target : @Target Info (@Expression Info) := V1Model.

Notation ident := string.
Notation path := (list ident).
Notation Val := (@ValueBase bool).
Notation Sval := (@ValueBase (option bool)).

Opaque PathMap.empty PathMap.set.

(* Global environment *)
Definition ge : genv := ltac:(
  let ge := eval compute in (gen_ge prog) in
  lazymatch ge with
  | Result.Ok ?ge =>
      exact (ge : (@genv _ ltac:(typeclasses eauto)))
  | Result.Error ?msg =>
      fail 0 "Global environment evaluation failed with message:" msg
  end).

(* Initial extern state *)
Definition instantiation := ltac:(
  let instantiation := eval compute in (instantiate_prog ge (ge_typ ge) prog) in
  lazymatch instantiation with
  | Result.Ok ?instantiation =>
      exact instantiation
  | Result.Error ?msg =>
      fail 0 "Global environment evaluation failed with message:" msg
  end).

Definition init_es := Eval compute in snd instantiation.

Transparent IdentMap.empty IdentMap.set PathMap.empty PathMap.set.

Definition custom_metadata_t :=
  Eval compute in force dummy_type (IdentMap.get "custom_metadata_t" (ge_typ ge)).

Definition standard_metadata_t :=
  Eval compute in force dummy_type (IdentMap.get "standard_metadata_t" (ge_typ ge)).

Definition dummy_fundef : @fundef Info := FExternal "" "".
Opaque dummy_fundef.

Open Scope func_spec.

Definition NUM_ENTRY : Z := 1024.

Definition NUM_ROW : Z := 3.

(* Bloom filter encoding *)

Definition Filter := row NUM_ENTRY.

Definition bloomfilter_state : Type := frame NUM_ROW NUM_ENTRY.

Definition bool_to_Z (b : bool) :=
  if b then 1 else 0.

Definition list_of_filter (f : Filter) := map_listn bool_to_Z f.

Definition blooms (bst: bloomfilter_state) := map_listn list_of_filter bst.

Definition reg_encode {size} (l : listn Z size) : extern_object :=
  ObjRegister (map ValBaseBit (map (P4Arith.to_lbool 1) (`l))).

(* list_of_filter lemmas *)

Lemma Zlength_seq : forall n start,
  0 <= n ->
  Zlength (seq start (Z.to_nat n)) = n.
Proof.
  intros.
  pose proof (seq_length (Z.to_nat n) start).
  rewrite Zlength_length; eauto.
Qed.

#[local] Hint Rewrite Zlength_seq using lia : Zlength.

Lemma Znth_seq : forall n i start,
  0 <= i < n ->
  Znth i (seq start (Z.to_nat n)) = (start + Z.to_nat i)%nat.
Proof.
  intros.
  rewrite <- nth_Znth by list_solve.
  rewrite seq_nth; lia.
Qed.

#[local] Hint Rewrite Znth_seq using lia : Znth.

Lemma Znth_list_of_filter : forall filter i,
  0 <= i < NUM_ENTRY ->
  Znth i (` (list_of_filter filter)) = bool_to_Z (Znth i (`filter)).
Proof.
  intros. destruct filter as [filter ?H].
  unfold list_of_filter, map_listn. simpl.
  list_simplify.
Qed.

#[local] Hint Rewrite Znth_list_of_filter using lia : Znth.

Lemma update_bit : forall filter hash,
    reg_encode (list_of_filter (row_insert filter hash)) =
  ObjRegister
    (upd_Znth hash (map ValBaseBit (map (to_lbool 1) (` (list_of_filter filter))))
       (ValBaseBit (to_lbool 1 (BitArith.mod_bound 1 1)))).
Proof.
  intros.
  unfold reg_encode.
  f_equal.
  unfold row_insert. simpl.
  destruct filter as [filter ?H]. simpl in *.
  list_simplify. f_equal. list_solve.
Qed.

Lemma get_bit : forall (filter : Filter) hash,
  0 <= hash < NUM_ENTRY ->
  Znth hash (map ValBaseBit (map (to_lbool 1) (` (list_of_filter filter))))
  = ValBaseBit [Znth hash (`filter)].
Proof.
  intros. unfold list_of_filter, map_listn. destruct filter as [filter ?H]. simpl.
  list_simplify.
  destruct (Znth hash filter); reflexivity.
Qed.

Definition Add_fundef := Eval compute in
  force dummy_fundef (PathMap.get ["Add"; "apply"] (ge_func ge)).

Definition havoc := uninit_sval_of_sval.

Section CRC.

Definition CRC : list bool -> list bool := Hash.compute_crc 16%nat 0x8005 0 0 true true.

End CRC.

Definition BASE : Z := 0.
Definition MAX : Z := 1024.

Definition CRC_Z (data : list bool) : Z :=
  BASE + Z.modulo (BitArith.lbool_to_val (CRC data) 1 0) MAX.

Lemma CRC_range : forall data, 0 <= CRC_Z data < NUM_ENTRY.
Proof.
  intros. unfold CRC_Z. unfold BASE. rewrite Z.add_0_l.
  apply Z.mod_pos_bound. unfold NUM_ENTRY. lia.
Qed.

Definition CRC_pad (pad : list bool) (data : Z) : Z :=
  CRC_Z (List.concat [to_lbool 16%N data; pad]).

Definition CRC_pad0 := CRC_pad (to_lbool 3%N 3).
Definition CRC_pad1 := CRC_pad (to_lbool 5%N 5).
Definition CRC_pad2 := CRC_pad (to_lbool 7%N 7).

Definition bloomfilter_exts := [["bloom0"]; ["bloom1"]; ["bloom2"]].

#[global] Program Instance z_num_entry_inhabit: Inhabitant (listn Z NUM_ENTRY) :=
  Zrepeat 0 NUM_ENTRY.

Definition encode_bloomfilter_state bf : ext_pred :=
  ExtPred.and
    (ExtPred.singleton ["bloom0"] (reg_encode (Znth 0 (` (blooms bf)))))
    (ExtPred.and
       (ExtPred.singleton ["bloom1"] (reg_encode (Znth 1 (` (blooms bf)))))
       (ExtPred.singleton ["bloom2"] (reg_encode (Znth 2 (` (blooms bf)))))).

Program Definition CRC_pads : listn HashFunc NUM_ROW := [CRC_pad0; CRC_pad1; CRC_pad2].

Definition bloomfilter_add (bf: bloomfilter_state) data :=
  general_bf.add CRC_pads bf data.

Definition bloomfilter_query (bf: bloomfilter_state) data :=
  general_bf.query (`CRC_pads) bf data.

Definition havoc_typ (typ : @P4Type Info) : Sval :=
  force ValBaseNull (uninit_sval_of_typ None typ).

Definition hash_fundef :=
  force dummy_fundef (PathMap.get ["hash"] (ge_func ge)).

Open Scope arg_ret_assr.

Lemma Forall2_bit_refine_eval_val_eq:
  forall l1 l2, Forall2 (exec_val SvalRefine.bit_refine) (map eval_val_to_sval l1) l2 ->
           map eval_val_to_sval l1 = l2.
Proof.
  induction l1; simpl; intros; inv H; auto. f_equal. 2: now apply IHl1.
  apply exec_val_eval_val_to_sval_eq in H2; auto. intros. now inv H.
Qed.

Lemma Forall2_ndetbit_eval_val_eq: forall l1 l2,
    Forall2 (exec_val read_ndetbit) (map eval_val_to_sval l1) l2 -> l1 = l2.
Proof.
  induction l1; simpl; intros; inv H; auto. f_equal. 2: now apply IHl1.
  apply sval_to_val_eval_val_to_sval_eq in H2; auto. intros. now inv H.
Qed.

(* A more restricted func spec, but should be sound. *)
Definition hash_spec : func_spec :=
  WITH,
    PATH []
    MOD None []
    WITH (data : list Val) (input : list bool)
      (_ : concat_tuple data = Some input),
      PRE
        (ARG [ValBaseEnumField "HashAlgorithm" "crc16";
              ValBaseBit (to_loptbool 32 BASE);
              eval_val_to_sval (ValBaseTuple data);
              ValBaseBit (to_loptbool 32 MAX)]
        (MEM []
        (EXT [])))
      POST
        (ARG_RET [ValBaseBit (to_loptbool 32%N (CRC_Z input))] ValBaseNull
        (MEM []
        (EXT []))).

Lemma hash_body : forall targs,
    func_sound ge hash_fundef (TypBit 32%N :: targs) hash_spec.
Proof.
  intros. unfold hash_spec. simpl. split.
  - repeat intro. red. red in H. destruct H. do 2 red in H. inv H. inv H4.
    inv H6. inv H3. inv H5. inv H4. inv H7. inv H8. inv H5.
    apply Members.Forall2_bit_refine_Some_same' in H2, H4. subst. inv H0. inv H7.
    simpl in H. inv H. simpl. red. split; [|split]; auto.
    + Opaque to_lbool. inv H4. inv H6. inv H8. inv H4. apply ValueUtil.Forall2_ndetbit in H2.
      inv H7. inv H6. inv H10. inv H8. inv H6. apply ValueUtil.Forall2_ndetbit in H4. subst.
      inv H13. inv H7. constructor. 2: constructor. unfold bound_hash_output in H4.
      rewrite !bit_from_to_bool in H4. vm_compute in H5. inv H5.
      apply Forall2_bit_refine_eval_val_eq in H3. subst lv'.
      apply Forall2_ndetbit_eval_val_eq in H2. subst vs. rewrite x1 in H9. inv H9.
      unfold CRC_Z, CRC.
      replace (BitArith.mod_bound 32 BASE) with BASE in *
          by (unfold BASE; now vm_compute).
      replace (BitArith.mod_bound 32 MAX) with MAX in *
          by (unfold MAX; now vm_compute). unfold BitArith.from_lbool in H4.
      rewrite Zlength_correct in H4. rewrite Hash.length_compute_crc in H4.
      change (Z.to_N (Z.of_nat 16)) with 16%N in H4. rewrite N.max_id in H4.
      rewrite N.max_l in H4 by lia.
      unfold BitArith.modulo_mod, BitArith.plus_mod in H4.
      rewrite BitArith.mod_bound_double_add, to_lbool_bit_mod in H4.
      unfold to_loptbool. revert H4.
      generalize (to_lbool 32
                         (BASE +
                            BitArith.lbool_to_val
                              (Hash.compute_crc 16 0x8005 0 0 true true input) 1 0
                              mod MAX)). intros. inv H4. constructor.
      rewrite ForallMap.Forall2_forall in H0. destruct H0.
      rewrite <- ForallMap.Forall2_map_l, ForallMap.Forall2_forall. split; auto.
      intros. specialize (H0 _ _ H2). inv H0. constructor.
    + repeat intro. inv H. constructor.
  - repeat intro. unfold modifies. split; only 1 : (simpl; auto). repeat intro.
    inv H. simpl. inv H6. simpl in H. inv H. auto.
Qed.

#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply hash_body) : func_specs.
#[local] Hint Extern 1 (list P4Type) => (exact (@nil _)) : func_specs.

(*
control Add(inout headers hdr, inout custom_metadata_t meta) {
    apply{
        hash(meta.index0, HashAlgorithm.crc16, HASH_BASE, {hdr.myHeader.data, PAD0}, HASH_MAX);
        hash(meta.index1, HashAlgorithm.crc16, HASH_BASE, {hdr.myHeader.data, PAD1}, HASH_MAX);
        hash(meta.index2, HashAlgorithm.crc16, HASH_BASE, {hdr.myHeader.data, PAD2}, HASH_MAX);

        bloom0.write(meta.index0, 1);
        bloom1.write(meta.index1, 1);
        bloom2.write(meta.index2, 1);
    }
}
*)

Definition myHeader_encode data :=
  ValBaseStruct
    [("myHeader",
      ValBaseHeader
        [("data", ValBaseBit (to_loptbool 16 data))]
         (Some true))].

Definition Add_spec : func_spec :=
  WITH p,
    PATH p
    MOD None bloomfilter_exts
    WITH (data : Z) (bf : bloomfilter_state),
      PRE
        (ARG [myHeader_encode data; havoc_typ custom_metadata_t]
        (MEM []
        (EXT [encode_bloomfilter_state bf])))
      POST
        (ARG_RET [myHeader_encode data; havoc_typ custom_metadata_t] ValBaseNull
        (MEM []
        (EXT [encode_bloomfilter_state (bloomfilter_add bf data)]))).

Lemma Add_body : func_sound ge Add_fundef nil Add_spec.
Proof.
  start_function.
  destruct bf as [bf ?H]. unfold NUM_ROW in *.
  do 3 (destruct bf; [exfalso; list_solve |]).
  destruct bf; [|exfalso; list_solve].
  step_call hash_body [ValBaseBit (to_lbool 16 data); ValBaseBit (to_lbool 3 3)].
  { entailer. }
  reflexivity.
  replace (CRC_Z _) with (CRC_pad0 data) by reflexivity.
  step_call hash_body [ValBaseBit (to_lbool 16 data); ValBaseBit (to_lbool 5 5)].
  { entailer. }
  reflexivity.
  replace (CRC_Z _) with (CRC_pad1 data) by reflexivity.
  step_call hash_body [ValBaseBit (to_lbool 16 data); ValBaseBit (to_lbool 7 7)].
  { entailer. }
  reflexivity.
  replace (CRC_Z _) with (CRC_pad2 data) by reflexivity.
  simpl MEM.
  unfold encode_bloomfilter_state.
  normalize_EXT.
  step_call register_write_body.
  { entailer. Unshelve. 3: exact (ValBaseBit (to_lbool 1 1)). repeat constructor. shelve. }
  reflexivity. 2: simpl; lia.
  { apply CRC_range. }
  step_call register_write_body.
  { entailer. Unshelve. 3: exact (ValBaseBit (to_lbool 1 1)). repeat constructor. shelve. }
  reflexivity. 2: simpl; lia.
  { apply CRC_range. }
  step_call register_write_body.
  { entailer. Unshelve. 3: exact (ValBaseBit (to_lbool 1 1)). repeat constructor. shelve. }
  reflexivity. 2: simpl; lia.
  { apply CRC_range. }
  step.
  entailer.
  { repeat constructor. }
  all: unfold blooms, bloomfilter_add, add, frame_insert, Utils.map2;
    cbn [map combine uncurry]; symmetry; apply update_bit.
Qed.

#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply Add_body) : func_specs.

Definition Query_fundef := Eval compute in
  force dummy_fundef (PathMap.get ["Query"; "apply"] (ge_func ge)).

Definition Query_spec : func_spec :=
  WITH p,
    PATH p
    MOD None []
    WITH (data : Z) (bf : bloomfilter_state),
      PRE
        let hdr := ValBaseStruct
        [("myHeader",
          ValBaseHeader
            [("data", ValBaseBit (to_loptbool 16 data))]
             (Some true))] in
        (ARG [hdr; force ValBaseNull (uninit_sval_of_typ None custom_metadata_t)]
        (MEM []
        (EXT [encode_bloomfilter_state bf])))
      POST
        let hdr := ValBaseStruct
        [("myHeader",
          ValBaseHeader
            [("data", ValBaseBit (to_loptbool 16 data))]
             (Some true))] in
        let meta := update "member0"
          (ValBaseBit [Some (general_bf.query [CRC_pad0; CRC_pad1; CRC_pad2] bf data)])
          (force ValBaseNull (uninit_sval_of_typ None custom_metadata_t)) in
        (ARG_RET [hdr; meta] ValBaseNull
        (MEM []
           (EXT []))).

Lemma Znth_0_3 {X: Type} {HX: Inhabitant X}: forall (r0 r1 r2: X), Znth 0 [r0; r1; r2] = r0.
Proof. intros. now vm_compute. Qed.

Lemma Znth_1_3 {X: Type} {HX: Inhabitant X}: forall (r0 r1 r2: X), Znth 1 [r0; r1; r2] = r1.
Proof. intros. now vm_compute. Qed.

Lemma Znth_2_3 {X: Type} {HX: Inhabitant X}: forall (r0 r1 r2: X), Znth 2 [r0; r1; r2] = r2.
Proof. intros. now vm_compute. Qed.

Lemma Query_body : func_sound ge Query_fundef nil Query_spec.
Proof.
  start_function.
  step_call hash_body [ValBaseBit (to_lbool 16 data); ValBaseBit (to_lbool 3 3)].
  { entailer. }
  reflexivity.
  replace (CRC_Z _) with (CRC_pad0 data) by reflexivity.
  step_call hash_body [ValBaseBit (to_lbool 16 data); ValBaseBit (to_lbool 5 5)].
  { entailer. }
  reflexivity.
  replace (CRC_Z _) with (CRC_pad1 data) by reflexivity.
  step_call hash_body [ValBaseBit (to_lbool 16 data); ValBaseBit (to_lbool 7 7)].
  { entailer. }
  reflexivity.
  replace (CRC_Z _) with (CRC_pad2 data) by reflexivity.
  simpl MEM.
  unfold encode_bloomfilter_state.
  normalize_EXT.
  step_call register_read_body.
  { entailer. }
  reflexivity. 2: simpl; lia.
  { apply CRC_range. }
  step_call register_read_body.
  { entailer. }
  reflexivity. 2: simpl; lia.
  { apply CRC_range. }
  step_call register_read_body.
  { entailer. }
  reflexivity. 2: simpl; lia.
  { apply CRC_range. }
  step.
  step.
  destruct bf as [bf ?H]. unfold NUM_ROW in *.
  do 3 (destruct bf; [exfalso; list_solve |]).
  destruct bf; [|exfalso; list_solve].
  destruct r as [r ?H]. destruct r0 as [r0 ?H]. destruct r1 as [r1 ?H].
  unfold blooms, map_listn. cbn [map proj1_sig]. rewrite Znth_0_3, Znth_1_3, Znth_2_3.
  rewrite !get_bit by apply CRC_range.
  entailer.
  { simpl build_abs_unary_op.
    unfold query, frame_query, Utils.fold_andb, Utils.map2, row_query.
    cbn [map combine uncurry fold_left proj1_sig andb].
    destruct (Znth (CRC_pad0 data) r);
      destruct (Znth (CRC_pad1 data) r0);
      destruct (Znth (CRC_pad2 data) r1);
      simpl; repeat constructor. }
Qed.

#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply Query_body) : func_specs.

Definition MyIngress_fundef := Eval compute in
  force dummy_fundef (PathMap.get ["MyIngress"; "apply"] (ge_func ge)).

Definition process (in_port data : Z) (bf : bloomfilter_state) : (bloomfilter_state * Z) :=
  if in_port =? 0 then
    (general_bf.add CRC_pads bf data, 1)
  else
    (bf, if general_bf.query (`CRC_pads) bf data then 0 else 511).

Definition bloomfilter_spec : func_spec :=
  WITH ,
    PATH ["main"; "ig"]
    MOD None bloomfilter_exts
    WITH in_port data bf (H : 0 <= in_port < 2),
      PRE
        (ARG [
          ValBaseStruct [("myHeader",
            ValBaseHeader [("data", ValBaseBit (to_loptbool 16 data))] (Some true))];
          force ValBaseNull (uninit_sval_of_typ None custom_metadata_t);
          update "ingress_port" (ValBaseBit (to_loptbool 9 in_port))
            (force ValBaseNull (uninit_sval_of_typ None standard_metadata_t))]
        (MEM []
        (EXT [encode_bloomfilter_state bf])))
      POST
        (* These two lines cannot be merged, because Coq doesn't destruct the pair automatically. *)
        let bf' := fst (process in_port data bf) in
        let out_port := snd (process in_port data bf) in
        (ARG_RET [
          ValBaseStruct [("myHeader",
            ValBaseHeader [("data", ValBaseBit (to_loptbool 16 data))] (Some true))];
          force ValBaseNull (uninit_sval_of_typ None custom_metadata_t);
          update "egress_spec" (ValBaseBit (to_loptbool 9 out_port))
            (force ValBaseNull (uninit_sval_of_typ None standard_metadata_t))]
          ValBaseNull
        (MEM []
        (EXT [encode_bloomfilter_state bf']))).

Lemma mod_bound_eq : forall w n,
  0 <= n < Z.pow 2 (Z.of_N w) ->
  BitArith.mod_bound w n = n.
Proof.
  intros.
  unfold BitArith.mod_bound, BitArith.upper_bound.
  rewrite Zmod_small; auto.
Qed.

Lemma bloomfilter_body : func_sound ge MyIngress_fundef nil bloomfilter_spec.
Proof.
  start_function.
  step_if.
  {
    (* clear up H0 *)
    fold abs_eq in H0.
    rewrite get_update_same in H0 by auto.
    change ((eval_val_to_sval
            (ValBaseBit [false; false; false; false; false; false; false; false; false])))
      with (P4Bit 9 0) in H0.
    change (ValBaseBit (to_loptbool 9 in_port)) with (P4Bit 9 in_port) in H0.
    rewrite abs_eq_bit in H0.
    rewrite !mod_bound_eq in H0 by lia.
    destruct (in_port =? 0) eqn:H_in_port; inv H0.
    assert (in_port = 0) by lia; subst. clear H_in_port.
    step.
    step.
    step_call Add_body. eauto.
    entailer.
    step.
    entailer.
    repeat constructor.
  }
  {
    (* clear up H0 *)
    fold abs_eq in H0.
    rewrite get_update_same in H0 by auto.
    change ((eval_val_to_sval
            (ValBaseBit [false; false; false; false; false; false; false; false; false])))
      with (P4Bit 9 0) in H0.
    change (ValBaseBit (to_loptbool 9 in_port)) with (P4Bit 9 in_port) in H0.
    rewrite abs_eq_bit in H0.
    rewrite !mod_bound_eq in H0 by lia.
    destruct (in_port =? 0) eqn:H_in_port; inv H0.
    assert (in_port = 1) by lia; subst. clear H_in_port.
    simpl (force empty_statement _).
    step.
    step.
    step_call Query_body. eauto.
    entailer.
    step_if.
    {
      rewrite get_update_same in H0 by auto.
      destruct (query [CRC_pad0; CRC_pad1; CRC_pad2] bf data) eqn:H_query; inv H0.
      step.
      step.
      step.
      entailer.
      - repeat constructor.
      - unfold process.
        unfold CRC_pads. cbn [proj1_sig].
        rewrite H_query.
        repeat constructor. }
    {
      rewrite get_update_same in H0 by auto.
      destruct (query [CRC_pad0; CRC_pad1; CRC_pad2] bf data) eqn:H_query; inv H0.
      simpl (force empty_statement _).
      step.
      step.
      entailer.
      - repeat constructor.
      - unfold process.
        unfold CRC_pads. cbn [proj1_sig].
        rewrite H_query.
        repeat constructor.
    }
  }
 Qed.


Require Import Axioms.
Require Import Tactics.
Require Import Sigma.
Require Import Equality.
Require Import Ofe.
Require Import Syntax.
Require Import Ofe.
Require Import Uniform.
Require Import Spaces.
Require Import Urelsp.
Require Import Ordinal.
Require Import Candidate.
Require Import Model.
Require Import Intensional.
Require Import Ceiling.
Require Import Truncate.
Require Import Ordinal.

Definition std_one_and_dist :
  existsT (st : nat -> car (nearrow_ofe (space qone) (space qone))),
    forall i j, i <= j -> dist i (st i) (st j)
    :=
    expair (fun _ => nearrow_const unit_ofe unit_ofe tt) (fun i j _ => dist_refl _ i).

Lemma std_type_dist :
  forall w i j,
    i <= j
    -> @dist (nearrow_ofe (wiurel_ofe w) (wiurel_ofe w)) i (iutruncate_ne i) (iutruncate_ne j).
Proof.
intros w i j Hj.
intros a.
eapply dist_trans.
  {
  apply iutruncate_near.
  }
apply dist_symm.
eapply dist_downward_leq; eauto.
apply iutruncate_near.
Qed.

Definition std_type_and_dist w :
  existsT (st : nat -> car (nearrow_ofe (space (qtype w)) (space (qtype w)))),
    forall i j, i <= j -> dist i (st i) (st j)
    :=
    expair (@iutruncate_ne w) (std_type_dist w).

Definition std_tarrow_action (i : nat) w (A : wurel w) (k2 : qkind)
  (st : nat -> space k2 -n> space k2)
  (f : urelsp A -n> space k2) (P : urelsp_car A)
  : spcar k2
  := pi1 (st (min i (S (urelsp_index A P)))) (pi1 f P).

Lemma std_tarrow_action_nonexpansive :
  forall i w A k2 (st : nat -> car (nearrow_ofe (space k2) (space k2))),
    (forall i j, i <= j -> dist i (st i) (st j))
    -> forall (f : urelsp A -n> space k2),
         @nonexpansive (urelsp A) (space k2) (std_tarrow_action i w A k2 st f).
Proof.
intros n w A k2 st Hdistst f.
intros i P Q Hdist.
so (urelsp_eta _ A P) as (j & m & p & Hmp & HeqP).
so (urelsp_eta _ A Q) as (j' & m' & p' & Hmp' & HeqQ).
subst P Q.
unfold std_tarrow_action.
rewrite -> !urelsp_index_inj.
apply (dist_trans _#3 (pi1 (st (min n (S j))) (pi1 f (urelspinj A j' m' p' Hmp')))).
  {
  apply (pi2 (st (min n (S j)))).
  apply (pi2 f).
  exact Hdist.
  }
set (x := (pi1 f (urelspinj A j' m' p' Hmp'))).
clearbody x.
so (lt_eq_lt_dec j j') as [[Hlt | Heq] | Hlt].
  {
  so (le_dec n (S j)) as [Hlen | Hnlen].
    {
    replace (min n (S j)) with n by (symmetry; apply min_l; omega).
    replace (min n (S j')) with n by (symmetry; apply min_l; omega).
    apply dist_refl.
    }
  replace (min n (S j)) with (S j) by (symmetry; apply min_r; omega).
  so (urelspinj_dist_index _#11 Hlt Hdist) as Hle.
  eapply dist_downward_leq; eauto.
  apply Hdistst.
  apply Nat.min_glb; omega.
  }

  {
  subst j'.
  apply dist_refl.
  }

  {
  so (le_dec n (S j')) as [Hlen | Hnlen].
    {
    replace (min n (S j)) with n by (symmetry; apply min_l; omega).
    replace (min n (S j')) with n by (symmetry; apply min_l; omega).
    apply dist_refl.
    }
  replace (min n (S j')) with (S j') by (symmetry; apply min_r; omega).
  so (urelspinj_dist_index _#11 Hlt (dist_symm _ _ _ _ Hdist)) as Hle.
  eapply dist_downward_leq; eauto.
  apply dist_symm.
  apply Hdistst.
  apply Nat.min_glb; omega.
  }
Qed.

Definition std_tarrow_car (i : nat) w (A : wurel w) (k2 : qkind)
  (st : nat -> car (nearrow_ofe (space k2) (space k2)))
  (Hdistst : forall i j, i <= j -> dist i (st i) (st j))
  (f : urelsp A -n> space k2)
  : urelsp A -n> space k2
  :=
  expair (std_tarrow_action i w A k2 st f) (std_tarrow_action_nonexpansive i w A k2 st Hdistst f).

Lemma std_tarrow_nonexpansive :
  forall i w A k2
    (st : nat -> car (nearrow_ofe (space k2) (space k2)))
    (Hdistst : forall i j, i <= j -> dist i (st i) (st j)),
      @nonexpansive (nearrow_ofe (urelsp A) (space k2)) (nearrow_ofe (urelsp A) (space k2))
        (std_tarrow_car i w A k2 st Hdistst).
Proof.
intros i w A k2 st Hdistst.
intros n f g Hdist.
unfold std_tarrow_car.
cbn.
intros P.
cbn.
unfold std_tarrow_action.
apply (pi2 (st (min i (S (urelsp_index A P))))).
apply Hdist.
Qed.

Definition std_tarrow (i : nat) w (A : wurel w) (k2 : qkind)
  (st : nat -> car (nearrow_ofe (space k2) (space k2)))
  (Hdistst : forall i j, i <= j -> dist i (st i) (st j))
  : car (nearrow_ofe (nearrow_ofe (urelsp A) (space k2)) (nearrow_ofe (urelsp A) (space k2)))
  :=
  expair
    (std_tarrow_car i w A k2 st Hdistst)
    (std_tarrow_nonexpansive i w A k2 st Hdistst).

Lemma std_tarrow_dist :
  forall w A k2
    (st : nat -> car (nearrow_ofe (space k2) (space k2)))
    (Hdistst : forall i j, i <= j -> dist i (st i) (st j))
    i j,
      i <= j
      -> dist i (std_tarrow i w A k2 st Hdistst) (std_tarrow j w A k2 st Hdistst).
Proof.
intros w A k2 st Hdistst i j Hle.
intros f x.
cbn in f.
cbn.
unfold std_tarrow_action.
set (k := S (urelsp_index A x)).
eassert _ as H; [refine (Hdistst (min i k) (min j k) _ (pi1 f x)) |].
  {
  so (Nat.le_min_l i k).
  so (Nat.le_min_r i k).
  apply Nat.min_glb; omega.
  }
so (le_dec i k) as [Hik | Hnik].
  {
  rewrite -> (Nat.min_l _ _ Hik) in H at 1.
  exact H.
  }

  {
  assert (k <= i) as Hki by omega.
  rewrite -> (Nat.min_r _ _ Hki).
  rewrite -> (Nat.min_r _ _ (le_trans _ _ _ Hki Hle)).
  apply dist_refl.
  }
Qed.

Definition std_tarrow_and_dist w
  (A : wurel w) (k2 : qkind)
  (f : existsT (st : nat -> car (nearrow_ofe (space k2) (space k2))),
        forall i j, i <= j -> dist i (st i) (st j))
  :
  existsT (st : nat -> car (nearrow_ofe (nearrow_ofe (urelsp A) (space k2)) (nearrow_ofe (urelsp A) (space k2)))),
    forall i j, i <= j -> dist i (st i) (st j)
  :=
  expair
    (fun i => std_tarrow i w A k2 (pi1 f) (pi2 f))
    (std_tarrow_dist w A k2 (pi1 f) (pi2 f)).

Definition std_arrow (i : nat) (k1 k2 : qkind)
  (st1 : nat -> car (nearrow_ofe (space k1) (space k1)))
  (st2 : nat -> car (nearrow_ofe (space k2) (space k2)))
  : car (nearrow_ofe (nearrow_ofe (space k1) (space k2)) (nearrow_ofe (space k1) (space k2)))
  :=
  @nearrow_compose2_ne (space k1) (space k1) (space k2) (space k2) (st1 i) (st2 i).

Lemma std_arrow_dist :
  forall k1 k2
    (st1 : nat -> car (nearrow_ofe (space k1) (space k1)))
    (st2 : nat -> car (nearrow_ofe (space k2) (space k2)))
    (Hdistst1 : forall i j, i <= j -> dist i (st1 i) (st1 j))
    (Hdistst2 : forall i j, i <= j -> dist i (st2 i) (st2 j))
    i j,
      i <= j
      -> dist i (std_arrow i k1 k2 st1 st2) (std_arrow j k1 k2 st1 st2).
Proof.
intros k1 k2 st1 st2 Hdistst1 Hdistst2 i j Hle.
intros f x.
cbn in f.
cbn.
eapply dist_trans.
  {
  apply Hdistst2; eauto.
  }

  {
  apply (pi2 (st2 j)).
  apply (pi2 f).
  apply Hdistst1; eauto.
  }
Qed.

Definition std_arrow_and_dist
  (k1 k2 : qkind)
  (f : existsT (st : nat -> car (nearrow_ofe (space k1) (space k1))),
        forall i j, i <= j -> dist i (st i) (st j))
  (g : existsT (st : nat -> car (nearrow_ofe (space k2) (space k2))),
        forall i j, i <= j -> dist i (st i) (st j))
  :
  existsT (st : nat -> car (nearrow_ofe (nearrow_ofe (space k1) (space k2)) (nearrow_ofe (space k1) (space k2)))),
    forall i j, i <= j -> dist i (st i) (st j)
  :=
  expair
    (fun i => std_arrow i k1 k2 (pi1 f) (pi1 g))
    (std_arrow_dist k1 k2 (pi1 f) (pi1 g) (pi2 f) (pi2 g)).

Definition std_prod (i : nat) (k1 k2 : qkind)
  (st1 : nat -> car (nearrow_ofe (space k1) (space k1)))
  (st2 : nat -> car (nearrow_ofe (space k2) (space k2)))
  : car (nearrow_ofe (prod_ofe (space k1) (space k2)) (prod_ofe (space k1) (space k2)))
  :=
  mpair_ne (st1 i) (st2 i).

Lemma std_prod_dist :
  forall k1 k2
    (st1 : nat -> car (nearrow_ofe (space k1) (space k1)))
    (st2 : nat -> car (nearrow_ofe (space k2) (space k2)))
    (Hdistst1 : forall i j, i <= j -> dist i (st1 i) (st1 j))
    (Hdistst2 : forall i j, i <= j -> dist i (st2 i) (st2 j))
    i j,
      i <= j
      -> dist i (std_prod i k1 k2 st1 st2) (std_prod j k1 k2 st1 st2).
Proof.
intros k1 k2 st1 st2 Hdistst1 Hdistst2 i j Hle.
split.
  {
  cbn.
  apply Hdistst1; auto.
  }

  {
  cbn.
  apply Hdistst2; auto.
  }
Qed.

Definition std_prod_and_dist
  (k1 k2 : qkind)
  (f : existsT (st : nat -> car (nearrow_ofe (space k1) (space k1))),
         forall i j, i <= j -> dist i (st i) (st j))
  (g : existsT (st : nat -> car (nearrow_ofe (space k2) (space k2))),
         forall i j, i <= j -> dist i (st i) (st j))
  :
  existsT (st : nat -> car (nearrow_ofe (prod_ofe (space k1) (space k2)) (prod_ofe (space k1) (space k2)))),
    forall i j, i <= j -> dist i (st i) (st j)
  :=
  expair
    (fun i => std_prod i k1 k2 (pi1 f) (pi1 g))
    (std_prod_dist k1 k2 (pi1 f) (pi1 g) (pi2 f) (pi2 g)).

Definition std_fut (i : nat) (k : qkind)
  (st : nat -> car (nearrow_ofe (space k) (space k)))
  : car (nearrow_ofe (half (space k)) (half (space k)))
  :=
  nearrow_half (space k) (space k) (st (pred i)).

Lemma std_fut_dist :
  forall k
    (st : nat -> car (nearrow_ofe (space k) (space k)))
    (Hdistst : forall i j, i <= j -> dist i (st i) (st j))
    i j,
      i <= j
      -> dist i (std_fut i k st) (std_fut j k st).
Proof.
intros k st Hdistst i j Hle.
intros x.
cbn in x.
cbn.
exploit (Hdistst (pred i) (pred j)) as H.
  {
  omega.
  }
apply H.
Qed.

Definition std_fut_and_dist
  (k : qkind)
  (f : existsT (st : nat -> car (nearrow_ofe (space k) (space k))),
        forall i j, i <= j -> dist i (st i) (st j))
  :
  existsT (st : nat -> car (nearrow_ofe (half (space k)) (half (space k)))),
    forall i j, i <= j -> dist i (st i) (st j)
  :=
  expair
    (fun i => std_fut i k (pi1 f))
    (std_fut_dist k (pi1 f) (pi2 f)).

Fixpoint std_and_dist (k : qkind)
  : existsT (st : nat -> car (nearrow_ofe (space k) (space k))),
      forall i j, i <= j -> dist i (st i) (st j)
  :=
  match k with
  | qone => std_one_and_dist

  | qtype w => std_type_and_dist w

  | qarrow k1 k2 => std_arrow_and_dist k1 k2 (std_and_dist k1) (std_and_dist k2)

  | qtarrow w A k2 => std_tarrow_and_dist w A k2 (std_and_dist k2)

  | qprod k1 k2 => std_prod_and_dist k1 k2 (std_and_dist k1) (std_and_dist k2)

  | qfut k2 => std_fut_and_dist k2 (std_and_dist k2)
  end.

Definition std_ne (i : nat) (k : qkind) : car (nearrow_ofe (space k) (space k))
  := pi1 (std_and_dist k) i.

Definition std (i : nat) (k : qkind) : car (space k) -> car (space k)
  := pi1 (std_ne i k).

Definition std_nonexpansive (i : nat) (k : qkind) : nonexpansive (std i k)
  := pi2 (std_ne i k).

Lemma std_dist :
  forall k i j,
    i <= j
    -> dist i (std_ne i k) (std_ne j k).
Proof.
intros k i j Hle.
exact (pi2 (std_and_dist k) i j Hle).
Qed.

Lemma std_one_is :
  forall i, std i qone = (fun _ => tt).
Proof.
intros i.
cbn.
reflexivity.
Qed.

Lemma std_type_is :
  forall i w, std i (qtype w) = iutruncate i.
Proof.
intros i w.
cbn.
reflexivity.
Qed.

Lemma std_arrow_is :
  forall i k1 k2, std i (qarrow k1 k2) = pi1 (std_arrow i k1 k2 (fun i => std_ne i k1) (fun i => std_ne i k2)).
Proof.
intros i A k2.
cbn.
reflexivity.
Qed.

Lemma std_tarrow_is :
  forall i w A k2, std i (qtarrow w A k2) = pi1 (std_tarrow i w A k2 (fun i => std_ne i k2) (std_dist k2)).
Proof.
intros i w A k2.
cbn.
f_equal.
apply proof_irrelevance.
Qed.

Lemma std_prod_is :
  forall i k1 k2, std i (qprod k1 k2) = pi1 (std_prod i k1 k2 (fun i => std_ne i k1) (fun i => std_ne i k2)).
Proof.
intros i A k2.
cbn.
reflexivity.
Qed.

Lemma std_fut_is :
  forall i k, std i (qfut k) = pi1 (std_fut i k (fun i => std_ne i k)).
Proof.
intros i k.
cbn.
reflexivity.
Qed.

Global Opaque std_ne.

Lemma std_collapse :
  forall i k (x y : spcar k),
    dist i x y
    -> std i k x = std i k y.
Proof.
intros i k.
revert i.
induct k.

(* one *)
{
intros i x y _.
cbn.
reflexivity.
}

(* type *)
{
intros w i A B Hdist.
cbn.
rewrite -> std_type_is.
apply iutruncate_collapse; auto.
}

(* arrow *)
{
intros k1 _ k2 IH i f g Hfg.
rewrite -> !std_arrow_is.
cbn.
apply exT_extensionality_prop.
fextensionality 1.
intro x.
cbn.
apply IH.
apply Hfg.
}

(* tarrow *)
{
intros w A k2 IH i f g Hfg.
rewrite -> !std_tarrow_is.
cbn.
apply exT_extensionality_prop.
fextensionality 1.
intro P.
cbn.
unfold std_tarrow_action.
apply IH.
apply (dist_downward_leq _ _ i).
  {
  apply Nat.le_min_l.
  }
apply Hfg.
}

(* prod *)
{
intros k1 IH1 k2 IH2 i x y Hxy.
rewrite -> !std_prod_is.
destruct x as (x1, x2).
destruct y as (y1, y2).
destruct Hxy as (Hxy1, Hxy2).
cbn.
f_equal; [apply IH1 | apply IH2]; auto.
}

(* fut *)
{
intros k IH i x y Hxy.
rewrite -> !std_fut_is.
cbn.
cbn in Hxy.
apply IH.
exact Hxy.
}
Qed.

Lemma std_inhabitant :
  forall i k, std i k (space_inhabitant k) = space_inhabitant k.
Proof.
intros i k.
revert i.
induct k.

(* one *)
{
intros i.
cbn.
reflexivity.
}

(* type *)
{
intros w i.
cbn.
rewrite -> std_type_is.
unfold iutruncate.
cbn.
rewrite -> meta_truncate_nats.
f_equal.
  {
  apply urel_extensionality.
  cbn.
  fextensionality 3.
  intros j m p.
  pextensionality; [intros (? & H) | intro H]; destruct H.
  }

  {
  f_equal.
  apply exT_extensionality_prop.
  fextensionality 1.
  intros j.
  cbn.
  pextensionality; omega.
  }
}

(* arrow *)
{
intros k1 _ k2 IH i.
rewrite -> std_arrow_is.
apply exT_extensionality_prop.
fextensionality 1.
intro x.
change (spcar k1) in x.
cbn.
apply IH.
}

(* tarrow *)
{
intros w A k2 IH i.
rewrite -> std_tarrow_is.
apply exT_extensionality_prop.
fextensionality 1.
intro P.
cbn.
unfold std_tarrow_action.
cbn.
apply IH.
}

(* prod *)
{
intros k1 IH1 k2 IH2 i.
rewrite -> std_prod_is.
cbn.
f_equal; [apply IH1 | apply IH2].
}

(* fut *)
{
intros k IH i.
rewrite -> std_fut_is.
cbn.
apply IH.
}
Qed.

Lemma proj_std_and_embed_std :
  (forall i j k (x : spcar k),
     j <= S i
     -> proj i k (std j k x) = std j (approx i k) (proj i k x))
  /\
  (forall i j k (x : spcar (approx i k)),
     j <= S i
     -> embed i k (std j (approx i k) x) = std j k (embed i k x)).
Proof.
cut (forall k,
       (forall i j (x : spcar k),
          j <= S i
          -> proj i k (std j k x) = std j (approx i k) (proj i k x))
       /\
       (forall i j (x : spcar (approx i k)),
          j <= S i
          -> embed i k (std j (approx i k) x) = std j k (embed i k x))).
  {
  intros Hind.
  split; intros; apply Hind ; auto.
  }
intro k.
induct k.

(* one *)
{
split.
  {
  intros i j x _.
  cbn.
  reflexivity.
  }

  {
  intros i j x _.
  cbn.
  reflexivity.
  }
}

(* type *)
{
intros w.
split.
  {
  intros i j A _.
  cbn.
  reflexivity.
  }

  {
  intros i j A _.
  cbn.
  reflexivity.
  }
}

(* arrow *)
{
intros k1 IH1 k2 IH2.
split.
  {
  intros i j f Hji.
  cbn [approx].
  rewrite -> !std_arrow_is.
  cbn.
  apply exT_extensionality_prop.
  fextensionality 1.
  intro x.
  cbn.
  etransitivity.
    {
    apply IH2; auto.
    }
  unfold std.
  f_equal.
  unfold proj.
  f_equal.
  f_equal.
  symmetry.
  apply IH1; auto.
  }

  {
  intros i j f Hji.
  cbn [approx].
  rewrite -> !std_arrow_is.
  cbn.
  apply exT_extensionality_prop.
  fextensionality 1.
  intro x.
  cbn.
  etransitivity.
    {
    apply IH2; auto.
    }
  unfold std.
  f_equal.
  unfold embed.
  f_equal.
  f_equal.
  symmetry.
  apply IH1; auto.
  }
}

(* tarrow *)
{
intros w A k2 IH.
split.
  {
  intros i j f Hji.
  cbn [approx].
  rewrite -> !std_tarrow_is.
  cbn.
  apply exT_extensionality_prop.
  fextensionality 1.
  intro P.
  cbn.
  unfold std_tarrow_action.
  cbn.
  match goal with
  | |- pi1 _ (pi1 _ ?X) = _ => set (x := X)
  end.
  clearbody x.
  so (urelsp_eta _ _ P) as (h & m & p & Hmp & ->).
  rewrite -> urelsp_index_embed_ceiling.
  rewrite -> !urelsp_index_inj.
  fold (proj i k2).
  fold (std (min j (S h)) k2).
  fold (std (min j (S h)) (approx i k2)).
  apply IH.
  so (Nat.le_min_l j (S h)); omega.
  }

  {
  intros i j f Hle.
  cbn [approx].
  rewrite -> !std_tarrow_is.
  cbn.
  apply exT_extensionality_prop.
  fextensionality 1.
  intro P.
  cbn.
  unfold std_tarrow_action.
  cbn.
  match goal with
  | |- pi1 _ (pi1 _ ?X) = _ => set (x := X)
  end.
  clearbody x.
  so (urelsp_eta _ _ P) as (h & m & p & Hmp & ->).
  rewrite -> urelsp_index_proj_ceiling.
  rewrite -> !urelsp_index_inj.
  rewrite -> Nat.succ_min_distr.
  rewrite -> Nat.min_assoc.
  cbn.
  rewrite -> (min_l _ _ Hle).
  apply IH.
  so (Nat.le_min_l j (S h)).
  omega.
  }
}

(* prod *)
{
intros k1 IH1 k2 IH2.
split.
  {
  intros i j x Hj.
  destruct x as (x, y).
  cbn [approx].
  rewrite -> !std_prod_is.
  cbn.
  f_equal; [apply IH1 | apply IH2]; auto.
  }

  {
  intros i j x Hj.
  destruct x as (x, y).
  cbn [approx].
  rewrite -> !std_prod_is.
  cbn.
  f_equal; [apply IH1 | apply IH2]; auto.
  }
}

(* fut *)
{
intros k IH.
split.
  {
  intros i j x Hj.
  destruct i as [| i].
    {
    cbn.
    reflexivity.
    }
  cbn [approx].
  rewrite -> std_fut_is.
  apply IH.
  omega.
  }

  {
  intros i j x Hle.
  destruct i as [| i].
    {
    cbn [approx].
    rewrite -> !std_fut_is.
    cbn.
    replace (pi1 (std_ne (pred j) k)) with (std (pred j) k) by reflexivity.
    rewrite -> std_inhabitant.
    reflexivity.
    }
  cbn [approx].
  rewrite -> std_fut_is.
  apply IH.
  omega.
  }
}
Qed.

Lemma proj_std :
  forall i j k (x : spcar k),
    j <= S i
    -> proj i k (std j k x) = std j (approx i k) (proj i k x).
Proof.
intros i j k x Hji.
apply proj_std_and_embed_std; auto.
Qed.

Lemma embed_std :
  forall i j k (x : spcar (approx i k)),
    j <= S i
    -> embed i k (std j (approx i k) x) = std j k (embed i k x).
Proof.
intros i j k x Hji.
apply proj_std_and_embed_std; auto.
Qed.

Lemma std_combine :
  forall i j k x,
    std i k (std j k x)
    =
    std (min i j) k x.
Proof.
intros i j k.
revert i j.
induct k.

(* one *)
{
intros i j x.
cbn.
reflexivity.
}

(* type *)
{
intros w i j x.
rewrite -> !std_type_is.
apply iutruncate_combine.
}

(* arrow *)
{
intros k1 IH1 k2 IH2 i j f.
rewrite -> !std_arrow_is.
cbn.
apply exT_extensionality_prop.
fextensionality 1.
intro x.
cbn.
etransitivity.
  {
  apply IH2.
  }
unfold std.
f_equal.
f_equal.
rewrite -> Nat.min_comm.
apply IH1.
}

(* tarrow *)
{
intros w A k2 IH i j f.
rewrite -> !std_tarrow_is.
cbn.
apply exT_extensionality_prop.
fextensionality 1.
intro P.
cbn.
unfold std_tarrow_action.
cbn.
unfold std_tarrow_action.
unfold std in IH.
rewrite -> IH.
f_equal.
f_equal.
set (h := S (urelsp_index A P)).
clearbody h.
rewrite -> Nat.min_assoc.
setoid_rewrite <- Nat.min_assoc at 2.
setoid_rewrite -> Nat.min_comm at 3.
rewrite -> Nat.min_assoc.
rewrite <- Nat.min_assoc.
rewrite -> Nat.min_id.
reflexivity.
}

(* arrow *)
{
intros k1 IH1 k2 IH2 i j x.
destruct x as (x, y).
rewrite -> !std_prod_is.
cbn.
f_equal; [apply IH1 | apply IH2].
}

(* fut *)
{
intros k IH i j x.
rewrite -> !std_fut_is.
cbn.
unfold std in IH.
replace (pred (min i j)) with (min (pred i) (pred j)); auto.
so (Nat.sub_min_distr_r i j 1) as H.
rewrite <- !pred_of_minus in H.
exact H.
}
Qed.

Lemma std_combine_le :
  forall i j k x,
    i <= j
    -> std i k (std j k x)
       =
       std i k x.
Proof.
intros i j k x Hle.
replace (std i k) with (std (min i j) k) at 2.
  {
  rewrite -> std_combine.
  rewrite -> min_l; auto.
  }
rewrite -> min_l; auto.
Qed.

Lemma std_combine_ge :
  forall i j k x,
    j <= i
    -> std i k (std j k x)
       =
       std j k x.
Proof.
intros i j k x Hle.
rewrite -> std_combine.
rewrite -> Nat.min_r; auto.
Qed.

Lemma std_idem :
  forall i k x,
    std i k (std i k x)
    =
    std i k x.
Proof.
intros i k x.
apply std_combine_le; auto.
Qed.

Definition stdc (i : nat) (Q : candidate) : candidate
  :=
  expair (pi1 Q) (std i (pi1 Q) (pi2 Q)).

Lemma stdc_combine_le :
  forall i j (Q : candidate),
    i <= j
    -> stdc i (stdc j Q) = stdc i Q.
Proof.
intros i j Q Hle.
unfold stdc.
cbn.
f_equal.
destruct Q as (k & A).
cbn.
apply std_combine_le; auto.
Qed.

Lemma stdc_idem :
  forall i Q,
    stdc i (stdc i Q) = stdc i Q.
Proof.
intros i Q.
apply stdc_combine_le; auto.
Qed.

Lemma projc_stdc :
  forall i j Q,
    j <= S i
    -> projc i (stdc j Q) = stdc j (projc i Q).
Proof.
intros i j Q Hji.
destruct Q as (k & x).
unfold projc, stdc.
cbn.
f_equal.
apply proj_std; auto.
Qed.

Lemma projc_stdc_coalesce :
  forall i j Q,
    j <= i
    -> projc j (stdc (S j) (projc i (stdc (S i) Q))) = projc j (stdc (S j) Q).
Proof.
intros i j Q Hj.
rewrite <- projc_stdc; [| omega].
rewrite -> projc_combine_le; auto.
rewrite -> stdc_combine_le; auto.
omega.
Qed.

Lemma std_transport :
  forall i (k l : qkind) (h : k = l) (x : spcar k),
    std i l (transport h spcar x) = transport h spcar (std i k x).
Proof.
intros i k l h x.
subst l.
reflexivity.
Qed.


(** * Undecidability *)
(** ** The Entscheidungsproblem *)

Require Import Undecidability.Synthetic.Definitions Undecidability.Synthetic.Undecidability.
Require Import Undecidability.PCP.PCP_undec.
Require Import Undecidability.FOL.FOL.
From Undecidability.FOL.Reductions Require Import PCPb_to_FOL PCPb_to_FOL_intu PCPb_to_FOL_class.

Lemma undecidable_FOLstar_prv_intu : undecidable FOL*_prv_intu.
Proof.
   apply (undecidability_from_reducibility PCPb_undec).
   apply PCPb_to_FOL.prv_red.
Qed.

Lemma undecidable_FOLstar_valid : undecidable FOL*_valid.
Proof.
   apply (undecidability_from_reducibility PCPb_undec).
   apply PCPb_to_FOL.valid_star_red.
Qed.

Lemma undecidable_FOL_valid : undecidable FOL_valid.
Proof.
   apply (undecidability_from_reducibility PCPb_undec).
   apply PCPb_to_FOL.valid_red.
Qed.

Lemma undecidable_FOL_satis : undecidable FOL_satis.
Proof.
  apply (undecidability_from_reducibility PCPb_compl_undec).
  apply satis_red.
Qed.

Lemma undecidable_FOL_valid_intu : undecidable FOL_valid_intu.
Proof.
   apply (undecidability_from_reducibility PCPb_undec).
   apply PCPb_to_FOL_intu.kvalid_red.
Qed.

Lemma undecidable_FOL_prv_intu : undecidable FOL_prv_intu.
Proof.
   apply (undecidability_from_reducibility PCPb_undec).
   apply PCPb_to_FOL_intu.kprv_red.
Qed.

Lemma undecidable_FOL_satis_intu : undecidable FOL_satis_intu.
Proof.
  apply (undecidability_from_reducibility PCPb_compl_undec).
  apply ksatis_red.
Qed.

Lemma undecidable_FOL_prv_class : undecidable FOL_prv_class.
Proof.
   apply (undecidability_from_reducibility PCPb_undec).
   apply PCPb_to_FOL_class.cprv_red.
Qed.

Lemma undecidable_FOLstar_prv_class : undecidable FOL*_prv_class.
Proof.
   apply (undecidability_from_reducibility PCPb_undec).
   exists (fun R => F R). intros R. apply (BPCP_CND R).
Qed.


Require Software.Lib.Strings.String.
Require Import Software.Language.Syntax.
Require Import Software.Language.State.
Require Import Software.Language.Value.
Require Import Software.Language.Record.
Require Import Software.Language.ExecutionProp.

Section Steps.

Let beq_nat : nat -> nat -> bool := NPeano.Nat.eqb.
Let beq_bool : bool -> bool -> bool := Bool.eqb.
Let beq_string : String.string -> String.string -> bool := String.eqb.

Reserved Notation "t1 '/' st1 '==>' t2 '/' st2"
  (at level 40, st1 at level 39, t2 at level 39).

Inductive exec_step : exec_step_relation :=
  | STnot_r :
    forall t t' st st',
    t / st ==> t' / st' ->
    tnot t / st ==> tnot t' / st'
  | STnot :
    forall b st,
    tnot (tbool b) / st ==> tbool (negb b) / st

  | STand_l :
    forall t t' t0 st st',
    t / st ==> t' / st' ->
    tand t t0 / st ==> tand t' t0 / st'
  | STand_true :
    forall t0 st,
    tand (tbool true) t0 / st ==> t0 / st
  | STand_false :
    forall t0 st,
    tand (tbool false) t0 / st ==> tbool false / st

  | STor_l :
    forall t t' t0 st st',
    t / st ==> t' / st' ->
    tor t t0 / st ==> tor t' t0 / st'
  | STor_false :
    forall t0 st,
    tor (tbool false) t0 / st ==> t0 / st
  | STor_true :
    forall t0 st,
    tor (tbool true) t0 / st ==> tbool true / st

  | STplus_l :
    forall t t' t0 st st',
    t / st ==> t' / st' ->
    tplus t t0 / st ==> tplus t' t0 / st'
  | STplus_r :
    forall t t0 t0' st st',
    value t ->
    t0 / st ==> t0' / st' ->
    tplus t t0 / st ==> tplus t t0' / st'
  | STplus_nat :
    forall n n0 st,
    tplus (tnat n) (tnat n0) / st ==> tnat (plus n n0) / st

  | STminus_l :
    forall t t' t0 st st',
    t / st ==> t' / st' ->
    tminus t t0 / st ==> tminus t' t0 / st'
  | STminus_r :
    forall t t0 t0' st st',
    value t ->
    t0 / st ==> t0' / st' ->
    tminus t t0 / st ==> tminus t t0' / st'
  | STminus_nat :
    forall n n0 st,
    tminus (tnat n) (tnat n0) / st ==> tnat (minus n n0) / st

  | STmult_l :
    forall t t' t0 st st',
    t / st ==> t' / st' ->
    tmult t t0 / st ==> tmult t' t0 / st'
  | STmult_r :
    forall t t0 t0' st st',
    value t ->
    t0 / st ==> t0' / st' ->
    tmult t t0 / st ==> tmult t t0' / st'
  | STmult_nat :
    forall n n0 st,
    tmult (tnat n) (tnat n0) / st ==> tnat (mult n n0) / st

  | STeq_l :
    forall t t' t0 st st',
    t / st ==> t' / st' ->
    teq t t0 / st ==> teq t' t0 / st'
  | STeq_r :
    forall t t0 t0' st st',
    value t ->
    t0 / st ==> t0' / st' ->
    teq t t0 / st ==> teq t t0' / st'
  | STeq_void :
    forall st,
    teq tvoid tvoid / st ==> tbool true / st
  | STeq_nat :
    forall n n0 st,
    teq (tnat n) (tnat n0) / st ==> tbool (beq_nat n n0) / st
  | STeq_bool :
    forall b b0 st,
    teq (tbool b) (tbool b0) / st ==> tbool (beq_bool b b0) / st
  | STeq_ref :
    forall n n0 st,
    teq (tref n) (tref n0) / st ==> tbool (beq_nat n n0) / st
  | STeq_rc :
    forall t t0 t1 t2 st,
    value (trc t t0) ->
    value (trc t1 t2) ->
    teq (trc t t0) (trc t1 t2) / st ==> tand (teq t t1) (teq t0 t2) / st
  | STeq_cl :
    forall c t0 c1 t2 st,
    value (tcl c t0) ->
    value (tcl c1 t2) ->
    teq (tcl c t0) (tcl c1 t2) / st ==> tand (tbool (beq_string c c1)) (teq t0 t2) / st

  | STvar :
    forall n st,
    (tvar n) / st ==> read_sk_hd n st / st

  | STassign_r :
    forall n t0 t0' st st',
    t0 / st ==> t0' / st' ->
    tassign (tvar n) t0 / st ==> tassign (tvar n) t0' / st'
  | STassign :
    forall n v0 st,
    value v0 ->
    tassign (tvar n) v0 / st ==> tvoid / write_sk_hd n v0 st

  | STseq_l :
    forall t t' t0 st st',
    t / st ==> t' / st' ->
    tseq t t0 / st ==> tseq t' t0 / st'
  | STseq :
    forall t0 st,
    tseq tvoid t0 / st ==> t0 / st

  | STif_l :
    forall t t' t0 t1 st st',
    t / st ==> t' / st' ->
    tif t t0 t1 / st ==> tif t' t0 t1 / st'
  | STif_false :
    forall t0 t1 st,
    tif (tbool false) t0 t1 / st ==> t1 / st
  | STif_true :
    forall t0 t1 st,
    tif (tbool true) t0 t1 / st ==> t0 / st

  | STwhile :
    forall t t0 st,
    twhile t t0 / st ==> tif t (tseq t0 (twhile t t0)) tvoid / st

  | STrc_l :
    forall t t' t0 st st',
    t / st ==> t' / st' ->
    trc t t0 / st ==> trc t' t0 / st'
  | STrc_r :
    forall v t0 t0' st st',
    value v ->
    t0 / st ==> t0' / st' ->
    trc v t0 / st ==> trc v t0' / st'

  | STcall_r :
    forall f t0 t0' st st',
    t0 / st ==> t0' / st' ->
    tcall f t0 / st ==> tcall f t0' / st'
  | STcall :
    forall f v0 st,
    value v0 ->
    tcall f v0 / st ==> treturn (texec f) / push_call v0 st

  | STreturn_r :
    forall t t' st st',
    t / st ==> t' / st' ->
    treturn t / st ==> treturn t' / st'
  | STreturn :
    forall v st,
    value v ->
    treturn v / st ==> v / pop_call st

  | STcl_r :
    forall c t0 t0' st st',
    t0 / st ==> t0' / st' ->
    tcl c t0 / st ==> tcl c t0' / st'

  | STnew :
    forall n c0 st,
    tnew n c0 / st ==> tref (length (get_store st)) / alloc_sr (tcl c0 (rc_create n)) st

  | STfield_r_r :
    forall n t0 t0' st st',
    t0 / st ==> t0' / st' ->
    tfield_r n t0 / st ==> tfield_r n t0' / st'
  | STfield_r :
    forall n n0 c t0 st,
    read_sr n0 st = tcl c t0 ->
    tfield_r n (tref n0) / st ==> rc_read n t0 / st

  | STfield_w_r :
    forall n t0 t1 t1' st st',
    t1 / st ==> t1' / st' ->
    tfield_w n t0 t1 / st ==> tfield_w n t0 t1' / st'
  | STfield_w_l :
    forall n t0 t0' v1 st st',
    value v1 ->
    t0 / st ==> t0' / st' ->
    tfield_w n t0 v1 / st ==> tfield_w n t0' v1 / st'
  | STfield_w :
    forall n n0 t0 v0 c st,
    value v0 ->
    read_sr n0 st = tcl c t0 ->
    tfield_w n v0 (tref n0) / st ==> tvoid / write_sr n0 (tcl c (rc_write n v0 t0)) st

  | STvnew :
    forall n c0 st,
    tvnew n c0 / st ==> tcl c0 (rc_create n) / st

  | STvfield_r_r :
    forall n t0 t0' st st',
    t0 / st ==> t0' / st' ->
    tvfield_r n t0 / st ==> tvfield_r n t0' / st'
  | STvfield_r :
    forall n c t0 st,
    value (tcl c t0) ->
    tvfield_r n (tcl c t0) / st ==> rc_read n t0 / st

  | STvfield_w_l :
    forall n t0 t0' t1 st st',
    t0 / st ==> t0' / st' ->
    tvfield_w n t0 t1 / st ==> tvfield_w n t0' t1 / st'
  | STvfield_w :
    forall n n0 t0 v0 c st,
    value v0 ->
    read_sk_hd n0 st = tcl c t0 ->
    tvfield_w n v0 (tvar n0) / st ==> tvoid / write_sk_hd n0 (tcl c (rc_write n v0 t0)) st

  where "t1 '/' st1 '==>' t2 '/' st2" := (exec_step (Cexec_state t1 st1) (Cexec_state t2 st2)).

End Steps.