(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrbool eqtype seq.
Require Import Init_ext ssrZ ZArith_ext seq_ext uniq_tac machine_int.
Require Import multi_int encode_decode integral_type.
Import MachineInt.
Require Import mips_bipl mips_tactics mips_syntax mips_mint.
Import mips_bipl.expr_m.
Require Import simu.
Import simu.simu_m.
Require Import multi_halve_u_prg multi_halve_u_triple multi_halve_u_termination.

Local Open Scope heap_scope.
Local Open Scope assoc_scope.
Local Open Scope uniq_scope.
Local Open Scope machine_int_scope.
Local Open Scope asm_expr_scope.
Local Open Scope zarith_ext_scope.

Lemma multi_halve_u_safe_termination a0 a1 a2 a3 rx x rk d :
  uniq(rk, rx, a0, a1, a2, a3, r0) ->
  safe_termination (state_mint (x |=> unsign rk rx \U+ d))
    (multi_halve_u rk rx a0 a1 a2 a3).
Proof.
move=> Hset.
rewrite /safe_termination => st s h st_s_h.
case/(multi_halve_u_termination s h) : (Hset) => x0 exec_mips.
apply constructive_indefinite_description'.
have H1 : u2Z ([ rx ]_ s) + 4 * Z_of_nat '|u2Z ([rk ]_ s)| < Zbeta 1.
  apply state_mint_head_unsign_fit with x d st h.
  by apply st_s_h.
have H3 : size (Z2ints 32 '|u2Z ([ rk ]_ s)| ([ x ]_st)%pseudo_expr) = '|u2Z ([rk ]_ s)|.
  by rewrite size_Z2ints.
move: (multi_halve_u_triple _ _ _ _ _ _ Hset _ _ H1 _ H3) => Htriple.
move: (triple_exec_precond _ _ _ Htriple _ _ _ exec_mips (iota
      '|u2Z ([rx ]_ s) / 4| '|u2Z ([rk ]_ s)|)).
apply.
split; first by [].
split.
- rewrite Z_of_nat_Zabs_nat //; by apply min_u2Z.
- apply (state_mint_var_mint _ _ _ _ x (unsign rk rx)) in st_s_h; last by assoc_get_Some.
  by apply st_s_h.
Qed.


From iris Require Import program_logic.weakestpre.
From st.STLCmuVS Require Import lang wkpre.
From iris.proofmode Require Import tactics.

Section lift.

  Context `{Σ : !gFunctors}.
  Context `{irisGS_inst : !irisGS STLCmuVS_lang Σ}.

  Context (s : stuckness).

  Definition lift (Φ : valO -n> valO -n> iPropO Σ) : exprO → exprO → iProp Σ :=
    fun eᵢ eₛ => (WP eᵢ @ s ; top {{ vᵢ, ∃ vₛ, ⌜ rtc STLCmuVS_step eₛ (of_val vₛ) ⌝ ∧ Φ vᵢ vₛ }})%I.

  Definition liftl (Φ : valO -n> valO -n> iPropO Σ) : exprO → exprO → iProp Σ :=
    fun eₛ eᵢ => (WP eᵢ @ s ; top {{ vᵢ, ∃ vₛ, ⌜ rtc STLCmuVS_step eₛ (of_val vₛ) ⌝ ∧ Φ vₛ vᵢ }})%I.

  Lemma bla eᵢ eₛ Φ : lift Φ eᵢ eₛ ⊣⊢ liftl (λne x x', Φ x' x) eₛ eᵢ.
  Proof. auto. Qed.

  Lemma lift_bind (Φ Ψ : valO -n> valO -n> iPropO Σ) (Kᵢ Kₛ : ectx STLCmuVS_ectx_lang) (eᵢ eₛ : expr) :
    (lift Φ eᵢ eₛ ∗ ∀ vᵢ vₛ, Φ vᵢ vₛ -∗ lift Ψ (fill Kᵢ (of_val vᵢ)) (fill Kₛ (of_val vₛ))) ⊢ lift Ψ (fill Kᵢ eᵢ) (fill Kₛ eₛ).
  Proof.
    iIntros "[HΦeN H]". rewrite /lift.
    iApply wp_bind. iApply (wp_wand with "HΦeN").
    iIntros (v). iIntros "des". iDestruct "des" as (v') "[%HNv' Hvv']".
    iSpecialize ("H" $! v v' with "Hvv'").
    iApply (wp_wand with "H").
    iIntros (w). iIntros "des". iDestruct "des" as (w') "[%HKₛv'w' Hww']".
    iExists w'. iFrame. iPureIntro.
    apply (rtc_transitive _ (fill Kₛ v')); auto. simpl in *.
    by apply (rtc_STLCmuVS_step_ctx (fill Kₛ)).
  Qed.

  Lemma lift_bind' (Φ Ψ : valO -n> valO -n> iPropO Σ) (Kᵢ Kₛ : ectx STLCmuVS_ectx_lang) (eᵢ eₛ : expr) :
    ⊢ lift Φ eᵢ eₛ -∗ (∀ vᵢ vₛ, Φ vᵢ vₛ -∗ lift Ψ (fill Kᵢ (of_val vᵢ)) (fill Kₛ (of_val vₛ))) -∗ lift Ψ (fill Kᵢ eᵢ) (fill Kₛ eₛ).
  Proof. iIntros "HΦeN H". rewrite /lift. iApply lift_bind. iFrame "HΦeN". auto. Qed.

  Lemma lift_bind'' (Kᵢ Kₛ : list ectx_item) (Φ Ψ : valO -n> valO -n> iPropO Σ) (eᵢ eₛ : expr) :
    ⊢ lift Φ eᵢ eₛ -∗ (∀ vᵢ vₛ, Φ vᵢ vₛ -∗ lift Ψ (fill Kᵢ (of_val vᵢ)) (fill Kₛ (of_val vₛ))) -∗ lift Ψ (fill Kᵢ eᵢ) (fill Kₛ eₛ).
  Proof. iApply lift_bind'. Qed.

  Hint Extern 5 (IntoVal _ _) => eapply of_to_val; fast_done : typeclass_instances.
  Hint Extern 10 (IntoVal _ _) =>
    rewrite /IntoVal; eapply of_to_val; rewrite /= !to_of_val /=; solve [ eauto ] : typeclass_instances.

  Lemma lift_val (Ψ : valO -n> valO -n> iPropO Σ) (vᵢ vₛ : val) : (Ψ vᵢ vₛ) ⊢ lift Ψ vᵢ vₛ.
  Proof. iIntros "Hv". rewrite /lift. iApply wp_value. iExists vₛ. auto. Qed.

  (* lemmas for impl side; lets only have _later lemmas for lift *)

  Lemma lift_nsteps_later Φ e e' eₛ n (H : nsteps STLCmuVS_step n e e') : ▷^n lift Φ e' eₛ ⊢ lift Φ e eₛ.
  Proof. by iApply wp_nsteps_later. Qed.

  Lemma lift_PureExec_later Φ e e' eₛ n (H : PureExec True n e e') : ▷^n lift Φ e' eₛ ⊢ lift Φ e eₛ.
  Proof. by iApply wp_PureExec_later. Qed.

  Lemma lift_step_later Φ e e' eₛ (H : STLCmuVS_step e e') : ▷ lift Φ e' eₛ ⊢ lift Φ e eₛ.
  Proof. by iApply wp_step_later. Qed.

  (* lemmas for impl side; no_later *)

  Lemma lift_rtc_steps_impl Φ e e' eₛ (H : rtc STLCmuVS_step e e') : lift Φ e' eₛ ⊢ lift Φ e eₛ.
  Proof. by iApply wp_rtc_steps. Qed.

  (* lemmas for spec sideᵢ *)

  Lemma lift_rtc_steps Φ eᵢ e e' (H : rtc STLCmuVS_step e e') : lift Φ eᵢ e' ⊢ lift Φ eᵢ e.
  Proof.
    iIntros "H". iApply (wp_wand with "H").
    iIntros (v) "des". iDestruct "des" as (w') "[%H1 H2]". iExists w'. iFrame "H2".
    iPureIntro. by eapply rtc_transitive.
  Qed.

  Lemma lift_step Φ eᵢ e e' (H : STLCmuVS_step e e') : lift Φ eᵢ e' ⊢ lift Φ eᵢ e.
  Proof. iApply lift_rtc_steps. by apply rtc_once. Qed.

  Lemma lift_impl (Φ Ψ : valO -n> valO -n> iPropO Σ) (H : ∀ v v', Φ v v' ⊢ Ψ v v') :
    ∀ e e', lift Φ e e' ⊢ lift Ψ e e'.
  Proof.
    iIntros (e e') "Hee'". rewrite /lift.
    iApply (wp_wand with "Hee'"). iIntros (v) "Hdes".
    iDestruct "Hdes" as (v') "[%He'v' HΦ]".
    iExists v'. iSplit. auto. by iApply H.
  Qed.

  Lemma lift_equiv (Φ Ψ : valO -n> valO -n> iPropO Σ) (H : ∀ v v', Φ v v' ⊣⊢ Ψ v v') :
    ∀ e e', lift Φ e e' ⊣⊢ lift Ψ e e'.
  Proof. iIntros (e e'). iSplit; iApply lift_impl; iIntros (v v') "Hvv'"; by iApply H. Qed.

  Lemma lift_wand (Φ Ψ : valO -n> valO -n> iPropO Σ) e e' :
    ⊢ (∀ v v', Φ v v' -∗ Ψ v v') -∗ lift Φ e e' -∗ lift Ψ e e'.
  Proof.
    iIntros "H Hee'". rewrite /lift.
    iApply (wp_wand with "Hee'"). iIntros (v) "Hdes".
    iDestruct "Hdes" as (v') "[%He'v' HΦ]".
    iExists v'. iSplit. auto. by iApply "H".
  Qed.

  Lemma anti_step_help e1 e2 v : STLCmuVS_step e1 e2 → rtc STLCmuVS_step e1 (of_val v) → rtc STLCmuVS_step e2 (of_val v).
  Proof.
    intros H Hs.
    inversion Hs; subst.
    - exfalso. assert (to_val v = None) as Hn by eapply (language.val_stuck _ _ _ _ _ _ H).
      by rewrite to_of_val in Hn.
    - by rewrite (prim_step_det _ _ _ _ _ H0 H) in H1.
  Qed.

  Lemma anti_steps_help e1 e2 v : rtc STLCmuVS_step e1 e2 → rtc STLCmuVS_step e1 (of_val v) → rtc STLCmuVS_step e2 (of_val v).
  Proof.
    intros H Hs. destruct (iffLR (rtc_nsteps _ _) H) as [m Hm].
    revert H Hs Hm. revert v e1 e2. induction m.
    - simpl. intros. inversion Hm. by subst.
    - intros. inversion Hm. subst.
      pose proof (anti_step_help _ _ _ H1 Hs).
      eapply (IHm _ _ _ (rtc_nsteps_2 _ _ _ H2) H0 H2).
  Qed.

  Lemma lift_anti_steps_spec Φ eᵢ e1 e2 (H : rtc STLCmuVS_step e1 e2) : lift Φ eᵢ e1 ⊢ lift Φ eᵢ e2.
  Proof.
    iIntros "H". iApply (wp_wand with "H"). iIntros (v) "des".
    iDestruct "des" as (v') "[%Hs H]". iExists v'. iFrame "H".
    iPureIntro. by eapply anti_steps_help.
  Qed.

End lift.

Notation "lift!" := (lift NotStuck).
Notation "lift?" := (lift MaybeStuck).


From ConCert.Execution Require Import Blockchain.
From ConCert.Execution Require Import Containers.
From ConCert.Execution Require Import Serializable.
From ConCert.Execution.Test Require Import QCTest.
From ConCert.Examples.iTokenBuggy Require Import iTokenBuggy.
Import MonadNotation.
From Coq Require Import List. Import ListNotations.
From Coq Require Import ZArith.

Module Type iTokenBuggyGensInfo.
  Parameter contract_addr : Address.
  Parameter gAccount : G Address.
End iTokenBuggyGensInfo.

Module iTokenBuggyGens (Info : iTokenBuggyGensInfo).
  Import Info.
  Arguments SerializedValue : clear implicits.
  Arguments deserialize : clear implicits.
  Arguments serialize : clear implicits.

  Definition serializeMsg := @serialize iTokenBuggy.Msg _.

  Local Open Scope N_scope.

  Definition sampleFMapOpt {A B : Type}
                          `{countable.Countable A}
                          `{base.EqDecision A}
                           (m : FMap A B)
                           : GOpt (A * B) :=
    TestUtils.sampleFMapOpt m.

  (* Note: not optimal implementation. Should filter on
     balances map instead of first sampling and then filtering *)
  Definition gApprove (state : iTokenBuggy.State) : GOpt (Address * Msg) :=
  '((addr1, balance1), (addr2, balance2)) <- sample2UniqueFMapOpt state.(balances) ;;
    if 0 <? balance1
    then amount <- choose (0, balance1) ;; returnGenSome (addr1, approve addr2 amount)
    else if 0 <? balance2
    then amount <- choose (0, balance2) ;; returnGenSome (addr2, approve addr1 amount)
    else returnGen None.

  Definition gTransfer_from (state : iTokenBuggy.State) : GOpt (Address * Msg) :=
  '(allower, allowance_map) <- sampleFMapOpt state.(allowances) ;;
  '(delegate, allowance) <- sampleFMapOpt allowance_map ;;
  '(receiver,_) <- sampleFMapOpt state.(balances) ;;
    let allower_balance := (FMap_find_ allower state.(balances) 0) in
    amount <- (if allower_balance =? 0
              then returnGen 0
              else choose (0, N.min allowance allower_balance)) ;;
    returnGenSome (delegate, transfer_from allower receiver amount).

  Definition gMint (c : Environment)
                   (state : iTokenBuggy.State)
                   : GOpt (Address * Msg) :=
    addr <- gAccount ;;
    (* fix the number of minted tokens to 0, 1, or 2*)
    amount <- choose (0, 2) ;;
    returnGenSome (addr, mint amount ).

  Definition gBurn (state : iTokenBuggy.State) : GOpt (Address * Msg) :=
  '(addr, balance) <- sampleFMapOpt_filter state.(balances) (fun '(_,balance) => 0 <? balance) ;;
    (* we purposely give it a small chance to try to burn more than allowed, hence +2*)
    amount <- choose (0, balance + 2) ;;
    returnGenSome (addr, burn amount).

  Local Close Scope N_scope.
  (* Main generator. *)
  Definition giTokenBuggyAction (env : Environment) : GOpt Action :=
    let call caller_addr contract_addr msg :=
        returnGenSome {|
            act_origin := caller_addr;
            act_from := caller_addr;
            act_body := act_call contract_addr 0%Z (serializeMsg msg)
          |} in
    state <- returnGen (get_contract_state iTokenBuggy.State env contract_addr) ;;
    backtrack [
      (* mint *)
      (1, '(caller, msg) <- gMint env state ;;
          call caller contract_addr msg
      ) ;
      (* burn *)
      (1, '(caller, msg) <- gBurn state ;;
          call caller contract_addr msg
      ) ;
      (* transfer_from *)
      (4, '(caller, msg) <- gTransfer_from state ;;
          call caller contract_addr msg
      );
      (* approve *)
      (2, '(caller, msg) <- gApprove state ;;
          call caller contract_addr msg
      )
    ].

End iTokenBuggyGens.


(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
Require Import ZArith_ext seq_ext machine_int uniq_tac.
Import MachineInt.
Require Import mips_cmd mips_tactics mips_contrib.
Import expr_m.
Require Import mont_mul_strict_prg mont_mul_termination multi_lt_termination.
Require Import multi_sub_u_u_termination multi_zero_u_termination.

Local Open Scope machine_int_scope.
Local Open Scope mips_expr_scope.
Local Open Scope mips_cmd_scope.
Local Open Scope uniq_scope.

Lemma mont_mul_strict_termination s h k alpha x y z m one ext int_ X_ B2K_ Y_ M_ quot C_ t s_ :
  uniq(k, alpha, x, y, z, m, one, ext, int_, X_, B2K_, Y_, M_, quot, C_, t, s_, r0) ->
  { si | Some (s, h) -- mont_mul_strict k alpha x y z m one ext int_ X_ B2K_ Y_ M_ quot C_ t s_ ---> si }.
Proof.
move=> Hset; rewrite /mont_mul_strict.
apply exists_seq_P2 with (fun si => True).
- case/(termination_montgomery s h) : Hset => si Hsi; by exists si.
- move=> [si hi] Psi.
  + apply exists_ifte.
    * apply exists_seq_P2 with (fun _ => True).
      - have : uniq(k, z, m, X_, B2K_, int_, ext, M_, Y_, r0) by Uniq_uniq r0.
        case/(multi_lt_termination si hi) => sj Hsj; by exists sj.
      - move=> [sj hj] Psj.
        + apply exists_ifte.
          * have : uniq(k, m, z, ext, int_, quot, C_, M_, B2K_, r0) by Uniq_uniq r0.
            move/(multi_sub_u_u_termination sj hj z) => [sk Hk]; by exists sk.
          * apply exists_nop; by move: {Psj}(Psj _ (refl_equal _)).
    * apply exists_addiu_seq.
      exists_sw_new l Hl z0 Hz0.
      repeat Reg_upd.
      apply exists_addiu_seq.
      repeat Reg_upd.
      have : uniq(ext, m, z, Y_, int_, quot, C_, M_, B2K_, r0) by Uniq_uniq r0.
      set s0 := store.upd _ _ _. set h0 := heap.upd _ _ _.
      move/(multi_sub_u_u_termination s0 h0 z) => [sk Hk].
      eexists; by apply Hk.
Qed.

Lemma mont_mul_strict_init_termination s h k alpha x y z m one ext int_ X_ B2K_ Y_ M_ quot C_ t s_ :
  uniq(k, alpha, x, y, z, m, one, ext, int_, X_, B2K_, Y_, M_, quot, C_, t, s_, r0) ->
    { si | Some (s, h) -- mont_mul_strict_init k alpha x y z m one ext int_ X_ B2K_ Y_ M_ quot C_ t s_ ---> si }.
Proof.
move=> Hset; rewrite /mont_mul_strict_init.
apply exists_seq_P2 with (fun _ => True).
- have : uniq(k, z, ext, M_, r0) by Uniq_uniq r0.
  case/(multi_zero_u_termination s h) => si Hsi; by exists si.
- move=> [si hi] Psi.
  + apply exists_seq_P2 with (Q := fun sj => True).
    * by apply exists_mflhxu_seq_P, exists_mthi_seq_P, exists_mtlo_P.
    * move=> [sj hj] HPsj.
      - have : uniq(k, alpha, x, y, z, m, one, ext, int_, X_, B2K_, Y_, M_, quot, C_, t, s_, r0) by Uniq_uniq r0.
        case/(mont_mul_strict_termination sj hj) => x0 Hx0; by exists x0.
Qed.


Require Import Coq.Lists.List.
Require Import BinNums BinInt.

Import ListNotations.

Require Import Types Ops BValues Syntax Typing BEnv BMemory Validity External.

From compcert Require Import Integers Floats Maps Smallstep.
From compcert Require Import Globalenvs.
From compcert Require AST Events.
Module CAST := AST.

Section SEMANTICS.

Variable ge: genv.

Section EXPR.

Variable m: mem.
Variable e: env.
Variable f: function.
(* Variable arrszvar: list (ident * ident).
   Variable te: tenv. *)

Inductive eval_expr: expr -> value -> Prop :=
| eval_Const_int: forall sz sig n,
  eval_expr (Econst (Cint sz sig n)) (Vint sz sig n)
| eval_Const_int64: forall sig n,
  eval_expr (Econst (Cint64 sig n)) (Vint64 sig n)
| eval_Const_float32: forall f,
  eval_expr (Econst (Cfloat32 f)) (Vfloat32 f)
| eval_Const_float64: forall f,
  eval_expr (Econst (Cfloat64 f)) (Vfloat64 f)
| eval_Var: forall id v t,
  e!id = Some v ->
  f.(fn_tenv)!id = Some t ->
  well_typed_value v t ->
  eval_expr (Evar id) v
| eval_Cast: forall exp t t1 v1 v,
  eval_expr exp v1 ->
  well_typed_value v1 t1 ->
  sem_cast v1 t1 t = Some v ->
  eval_expr (Ecast exp t1 t) v
| eval_Unop: forall op k e1 v1 v,
  eval_expr e1 v1 ->
  sem_unop op k v1 = Some v ->
  eval_expr (Eunop op k e1) v
| eval_Binop_arith: forall op k e1 e2 v1 v2 v,
  eval_expr e1 v1 ->
  eval_expr e2 v2 ->
  sem_binarith_operation op k v1 v2 = Some v ->
  eval_expr (Ebinop_arith op k e1 e2) v
| eval_Binop_logical: forall op e1 e2 v1 v2 v,
  eval_expr e1 v1 ->
  eval_expr e2 v2 ->
  sem_logical_operation op v1 v2 = Some v ->
  eval_expr (Ebinop_logical op e1 e2) v
| eval_Binop_cmp: forall op k e1 e2 v1 v2 v,
  eval_expr e1 v1 ->
  eval_expr e2 v2 ->
  sem_cmp_operation op k v1 v2 = Some v ->
  eval_expr (Ebinop_cmp op k e1 e2) v
| eval_Binop_cmpu: forall op k e1 e2 v1 v2 v,
  eval_expr e1 v1 ->
  eval_expr e2 v2 ->
  sem_cmpu_operation op k v1 v2 = Some v ->
  eval_expr (Ebinop_cmpu op k e1 e2) v
| eval_Arr_access: forall id idx idarr blk lv szvar n i v b t,
  e!id = Some (Varr idarr lv) ->
  f.(fn_tenv)!id = Some (Tarr b t) ->
  eval_expr idx (Vint64 Unsigned i) ->
  In (id, szvar) f.(fn_arrszvar) ->
  e!szvar = Some (Vint64 Unsigned n) ->
  m!idarr = Some blk ->
  blk.(blk_values) = lv ->
  blk.(blk_type) = t ->
  Int64.unsigned i < Int64.unsigned n ->
  nth_error lv (Z.to_nat (Int64.unsigned i)) = Some v ->
  eval_expr (Earr_access id idx) v.
(* | eval_Mutarr_access: forall id idx idarr blk szvar n i v t,
     e!id = Some (Vmutarr idarr) ->
     f.(fn_tenv)!id = Some (Tarr true t) ->
     eval_expr idx (Vint64 Unsigned i) ->
     In (id, szvar) f.(fn_arrszvar) ->
     e!szvar = Some (Vint64 Unsigned n) ->
     m!idarr = Some blk ->
     blk.(blk_type) = t ->
     Int64.unsigned i < Int64.unsigned n ->
     nth_error blk.(blk_values) (Z.to_nat (Int64.unsigned i)) = Some v ->
     eval_expr (Earr_access id idx) v. *)

Inductive eval_exprlist: list expr -> list value -> Prop :=
| eval_Enil: eval_exprlist [] []
| eval_Econs: forall e v le lv,
  eval_expr e v ->
  eval_exprlist le lv ->
  eval_exprlist (e :: le) (v :: lv).

Lemma eval_exprlist_app:
  forall le1 le2 lv1 lv2,
    eval_exprlist le1 lv1 ->
    eval_exprlist le2 lv2 ->
    eval_exprlist (le1 ++ le2) (lv1 ++ lv2).
Proof.
  intros. revert lv1 H. induction le1.
  + intros. inversion_clear H. apply H0.
  + intros. inversion_clear H. simpl.
    specialize (IHle1 _ H2). apply eval_Econs; assumption.
Qed.

End EXPR.

Section STATEMENT.

Inductive cont : Type :=
| Kstop: cont
| Kseq: stmt -> cont -> cont
| Kreturnto: option ident -> env -> function -> cont -> cont
| Kloop: stmt -> cont -> cont.

Inductive state : Type :=
| State
    (m: mem)
    (e: env)
    (f: function)
    (s: stmt)
    (k: cont) : state
| Callstate
    (m:    mem)
    (fd:   fundef)
    (args: list value)
    (k:    cont) : state
| Returnstate
    (m:   mem)
    (res: value)
    (k:   cont) : state.

Inductive eval_identlist (e: env) (f: function): list ident -> list value -> Prop :=
| eval_ident_Enil: eval_identlist e f [] []
| eval_ident_Econs: forall id v lids lv t,
  e!id = Some v ->
  f.(fn_tenv)!id = Some t ->
  well_typed_value v t ->
  eval_identlist e f lids lv ->
  eval_identlist e f (id :: lids) (v :: lv).

Fixpoint destructCont (k: cont) : cont :=
  match k with
  | Kseq _ k | Kloop _ k => destructCont k
  | _ => k
  end.

Definition is_Kreturnto (k: cont) :=
  match k with
  | Kreturnto _ _ _ _ => True
  | _ => False
  end.

Inductive step_stmt: state -> state -> Prop :=
(* Sskip *)
| step_skip: forall m e f s k,
  step_stmt (State m e f Sskip (Kseq s k)) (State m e f s k)
| step_skip_loop: forall m e f s k,
  step_stmt (State m e f Sskip (Kloop s k)) (State m e f (Sloop s) k)
| step_skip_returnto: forall m e f k,
  is_Kreturnto k ->
  well_typed_value Vunit f.(fn_sig).(sig_res) ->
  step_stmt (State m e f Sskip k)
            (Returnstate m Vunit k)
(* Sassign *)
| step_assign: forall m e f k id exp v,
  eval_expr m e f exp v ->
  step_stmt (State m e f (Sassign id exp) k) (State m (PTree.set id v e) f Sskip k)
(* Sarr_assign *)
| step_arr_assign: forall m e f k id idx exp idarr lv blk i v v' szvar n t m' e',
  e!id = Some (Varr idarr lv) ->
  eval_expr m e f idx (Vint64 Unsigned i) ->
  In (id, szvar) f.(fn_arrszvar) ->
  e!szvar = Some (Vint64 Unsigned n) ->
  Int64.unsigned i < Int64.unsigned n ->
  eval_expr m e f exp v ->
  f.(fn_tenv)!id = Some (Tarr true t) ->
  well_typed_value v t ->
  sem_cast v t t = Some v' ->
  m!idarr = Some blk ->
  blk.(blk_type) = t ->
  blk.(blk_values) = lv ->
  write_array m e id (Int64.unsigned i) v' = Some (m', e') ->
  step_stmt (State m e f (Sarr_assign id idx exp) k) (State m' e f Sskip k)
(* Scall *)
| step_call_internal: forall m e f k idvar idf args vargs vargs' f',
  ge!idf = Some (Internal f') ->
  valid_call m e f (Internal f') args ->
  length args = length f'.(fn_sig).(sig_args) ->
  match_sig_args_typ f.(fn_tenv) f'.(fn_sig).(sig_args) args ->
  eval_identlist e f args vargs ->
  check_cast_args vargs f'.(fn_sig).(sig_args) = Some vargs' ->
  step_stmt (State m e f (Scall idvar idf args) k)
            (Callstate m (Internal f') vargs' (Kreturnto idvar e f k))
| step_call_external: forall m e f k idvar idf args vargs vargs' ef m' v,
  ge!idf = Some (External ef) ->
  length args = length (ef_sig ef).(sig_args) ->
  match_sig_args_typ f.(fn_tenv) (ef_sig ef).(sig_args) args ->
  eval_identlist e f args vargs ->
  check_cast_args vargs (ef_sig ef).(sig_args) = Some vargs' ->
  external_call ef m vargs' v m' ->
  step_stmt (State m e f (Scall idvar idf args) k)
            (State m' (set_optenv e idvar v) f Sskip k)
(* Callstate *)
| step_call_Internal: forall m fd f vargs k e,
  fd = Internal f ->
  build_func_env (PTree.empty value) f.(fn_params) vargs = Some e ->
  step_stmt (Callstate m fd vargs k) (State m e f f.(fn_body) k)
(* Sreturn *)
| step_return: forall m e f k exp v v',
  eval_expr m e f exp v ->
  well_typed_value v f.(fn_sig).(sig_res) ->
  sem_cast v f.(fn_sig).(sig_res) f.(fn_sig).(sig_res) = Some v' ->
  step_stmt (State m e f (Sreturn exp) k)
            (Returnstate m v' (destructCont k))
(* Returnstate *)
| step_returnstate_noident: forall m v e f k,
  step_stmt (Returnstate m v (Kreturnto None e f k))
            (State m e f Sskip k)
| step_returnstate: forall m v id e f k,
  step_stmt (Returnstate m v (Kreturnto (Some id) e f k))
            (State m (PTree.set id v e) f Sskip k)
(* Sseq *)
| step_seq: forall m e f k s1 s2,
  step_stmt (State m e f (Sseq s1 s2) k) (State m e f s1 (Kseq s2 k))
(* Sifthenelse *)
| step_ifthenelse: forall m e f k cond b s1 s2,
  eval_expr m e f cond (Vbool b) ->
  step_stmt (State m e f (Sifthenelse cond s1 s2) k) (State m e f (if b then s1 else s2) k)
(* Sloop *)
| step_loop: forall m e f s k,
  step_stmt (State m e f (Sloop s) k) (State m e f s (Kloop s k))
(* Sbreak *)
| step_break_skip: forall m e f s k,
  step_stmt (State m e f Sbreak (Kseq s k)) (State m e f Sbreak k)
| step_break_loop: forall m e f s k,
  step_stmt (State m e f Sbreak (Kloop s k)) (State m e f Sskip k)
(* Scontinue *)
| step_continue_skip: forall m e f s k,
  step_stmt (State m e f Scontinue (Kseq s k)) (State m e f Scontinue k)
| step_continue_loop: forall m e f s k,
  step_stmt (State m e f Scontinue (Kloop s k)) (State m e f (Sloop s) k)
(* Serror *)
| step_error: forall m e f k,
  step_stmt (State m e f Serror k) (State m e f Serror k).

Inductive reachable_state (s: state): state -> Prop :=
| RS_id: reachable_state s s
| RS_step: forall s1 s2,
    step_stmt s s1 ->
    reachable_state s1 s2 ->
    reachable_state s s2.

Lemma reachable_state_one_step (s1 s2: state):
  step_stmt s1 s2 ->
  reachable_state s1 s2.
Proof.
  intros. apply (RS_step _ s2). exact H. apply RS_id.
Qed.

End STATEMENT.

Inductive initial_state (p: program) : state -> Prop :=
| initial_state_intro: forall f,
  (genv_of_program p) ! (prog_main p) = Some (Internal f) ->
  f.(fn_sig) = {| sig_args := []; sig_res := Tint I32 Signed |} ->
  initial_state p (Callstate empty_mem (Internal f) [] Kstop).

Inductive final_state : state -> int -> Prop :=
| final_state_intro: forall m sz sig i,
  final_state (Returnstate m (Vint sz sig i) Kstop) i.

End SEMANTICS.

Section COMPCERT_SEMANTICS.

Definition step_events (ge: genv) (st1: state) (t: Events.trace) (st2: state): Prop :=
  t = Events.E0 /\ step_stmt ge st1 st2.

Definition to_AST_globdef (l: list (ident * fundef)) : list (ident * CAST.globdef fundef typ):=
  map (fun x => (fst x, CAST.Gfun (snd x))) l.

Definition to_genv (prog_defs: list (ident * fundef)) : Genv.t fundef typ :=
  Genv.add_globals (Genv.empty_genv fundef typ (map fst prog_defs)) (to_AST_globdef prog_defs).

Definition semantics p :=
  Semantics_gen step_events (initial_state p) final_state (genv_of_program p) (to_genv p.(prog_defs)).

End COMPCERT_SEMANTICS.

Create HintDb semantics.
Global Hint Constructors eval_expr eval_exprlist eval_identlist : semantics.
Global Hint Constructors step_stmt reachable_state : semantics.
Global Hint Resolve eval_exprlist_app : semanticsnb.
Global Hint Resolve reachable_state_one_step : semantics.

Inductive valid_cont (ge: genv) (f: function): cont -> Prop :=
| valid_Kstop:
  valid_cont ge f Kstop
| valid_Kseq: forall s k,
  valid_stmt ge f s ->
  valid_cont ge f k ->
  valid_cont ge f (Kseq s k)
| valid_Kloop: forall s k,
  valid_stmt ge f (Sloop s) ->
  valid_cont ge f k ->
  valid_cont ge f (Kloop s k)
| valid_Kreturnto: forall id e' f' k,
  valid_cont ge f' k ->
  valid_cont ge f (Kreturnto id e' f' k).


Require Import VST.floyd.functional_base VST.floyd.proofauto.
Require Import VST.floyd.library.
Require Import indices.stringlist.
Require Import indices.unordered_interface.
Require Import indices.unordered_flat.
Require Import indices.verif_stringlist.
Require Import indices.definitions.

Import UnorderedIndex.

Lemma in_whole_in_fst: forall a l,
  SetoidList.InA (stringlist_model.Raw.PX.eqk (elt:=V)) a l -> In (fst a) (map fst l).
Proof.
  intros. induction l.
  - inversion H; inversion H0; inversion H2.
  - simpl. apply SetoidList.InA_cons in H. inversion H; clear H.
     + left. destruct a, a0. inversion H0. simpl in H. subst. auto.
     + right. auto.
Qed.

Lemma notin_whole_notin_fst:  forall a l,
   ~SetoidList.InA (stringlist_model.Raw.PX.eqk (elt:=V)) a l -> ~In (fst a) (map fst l).
Proof.
  intros. induction l.
  - unfold not. intros. inversion H0.
  - simpl.
     rewrite SetoidList.InA_cons in H.
     apply Classical_Prop.not_or_and in H.
     apply Classical_Prop.and_not_or. split.
     + inversion H; clear H.
        unfold stringlist_model.Raw.PX.eqk in H0. auto.
     + inversion H; clear H. auto.
Qed.

Lemma lstnodup: forall lst, NoDup (map fst (stringlist_model.elements (elt:=V) lst)).
Proof.
  intros. assert
  (K: SetoidList.NoDupA (stringlist_model.Raw.PX.eqk (elt:=V)) (stringlist_model.this lst)).
  apply stringlist_model.NoDup.
  assert (M: (stringlist_model.this lst) = (stringlist_model.elements (elt:=V) lst)) by auto.
  rewrite M in K. clear M.
  induction (stringlist_model.elements (elt:=V) lst); auto.
  - simpl. apply NoDup_nil.
  - simpl. inversion K; subst. apply IHl in H2.
     apply NoDup_cons; auto. clear H2 K IHl.
     apply notin_whole_notin_fst. auto.
Qed.

Definition stringlist_index : index :=
  {| key := stringlist_model.key;
     eq_dec_key := Str_as_DT.eq_dec;
     default_key := ""%string;
     key_repr := fun sh s p => string_rep s p;
     key_type := tschar;

     default_value := nullV;

     t := stringlist_model.t V;
     t_repr := fun sh lst p => stringlist_rep lst p;
     t_type := t_stringlist;

     create := stringlist_model.empty V;

     cursor_repr := fun mc p => stringlist_cursor_rep mc p;

     flatten := fun lst => mk_flat _  (stringlist_model.elements (elt:=V) lst) (lstnodup lst);

     insert := fun t k v => stringlist_model.add k v t;

   |}.

Definition create_funspec := create_spec(stringlist_index).
Definition stringlist_create_spec := (_stringlist_new, create_funspec).

Definition lookup_funspec := lookup_spec(stringlist_index).
Definition stringlist_lookup_spec := (_stringlist_lookup, lookup_funspec).

Definition insert_funspec := insert_spec(stringlist_index).
Definition stringlist_insert_spec := (_stringlist_insert, insert_funspec).

Definition malloc_funspec := malloc_spec'.
Definition malloc_spec := (_malloc, malloc_funspec).

Definition exit_funspec := exit_spec'.
Definition exit_spec := (_exit, exit_funspec).

Definition cardinality_funspec := cardinality_spec(stringlist_index).
Definition stringlist_cardinality_spec := (_stringlist_cardinality, cardinality_funspec).

Definition move_to_first_funspec := move_to_first_spec(stringlist_index).
Definition stringlist_move_to_first_spec := (_stringlist_move_to_first, move_to_first_funspec).

Definition move_to_next_funspec := move_to_next_spec(stringlist_index).
Definition stringlist_move_to_next_spec := (_stringlist_move_to_next, move_to_next_funspec).

Definition get_cursor_funspec := get_cursor_spec(stringlist_index).
Definition stringlist_get_cursor_spec := (_stringlist_get_cursor, get_cursor_funspec).

Definition Gprog : funspecs := [ new_scell_spec; strcmp_spec; malloc_spec;
    exit_spec; stringlist_create_spec; stringlist_lookup_spec; stringlist_insert_spec;
    stringlist_cardinality_spec; stringlist_move_to_first_spec;
    stringlist_move_to_next_spec; stringlist_get_cursor_spec].

(* ==================== HELPERS ==================== *)

Definition strlst_rep (add: val) (cellptr: val) (lst: list(string*V)) :=
  (data_at Ews (tptr t_scell) cellptr add * scell_rep lst cellptr)%logic.

Lemma not_stringlist_raw_in_inv :
  forall (elt : Type) (k k' : string) (e : elt) (l : list (string * elt)),
  ~stringlist_model.Raw.PX.In k ((k', e) :: l) -> ~(k = k' \/ stringlist_model.Raw.PX.In k l).
Proof.
  intros.
  unfold not. intros. apply H. inversion H0.
  - rewrite H1 in H. unfold not in H. unfold stringlist_model.Raw.PX.In in H.
     exfalso. apply H. exists e. auto.
  - exfalso. unfold not in H. apply H. unfold stringlist_model.Raw.PX.In in *.
     inversion H1. exists x. auto.
Qed.

Lemma notin_lst_add_end: forall lst k (v: V),
  ~stringlist_model.Raw.PX.In k lst ->
  lst ++ [(k, v)] = stringlist_model.Raw.add k v lst.
Proof.
  intros. induction lst; try auto.
  simpl. destruct a. apply not_stringlist_raw_in_inv in H.
  apply Decidable.not_or in H. inversion H; clear H.
  destruct (Str_as_DT.eq_dec k s); try contradiction.
  apply IHlst in H1. rewrite H1. auto.
Qed.

Lemma notin_lst_add_middle: forall lst1 lst2 k (v: V) (v0: V),
  ~stringlist_model.Raw.PX.In k lst1 ->
  lst1 ++ (k, v) :: lst2 = stringlist_model.Raw.add k v (lst1 ++ (k, v0) :: lst2).
Proof.
  intros. induction lst1.
  - simpl. destruct (Str_as_DT.eq_dec k k); try auto.
     unfold not in n. unfold Str_as_DT.eq in n. contradiction.
  - simpl. destruct a. apply not_stringlist_raw_in_inv in H.
     apply Decidable.not_or in H. inversion H; clear H.
     destruct (Str_as_DT.eq_dec k s); try contradiction.
     apply IHlst1 in H1. rewrite H1. auto.
Qed.

Require Import Coq.Program.Equality.
Lemma stringlistfind_eq_find: forall m k,
  find Str_as_DT.eq_dec (stringlist_model.elements (elt:=V) m) k =
  stringlist_model.find (elt:=V) k m.
Proof.
  intros. unfold stringlist_model.find. unfold stringlist_model.Raw.find. unfold stringlist_model.Raw.t.
  replace (stringlist_model.this m) with (stringlist_model.elements (elt:=V) m); auto.
  induction (stringlist_model.elements (elt:=V) m); auto.
  destruct a. simpl. destruct (Str_as_DT.eq_dec k0 k).
     + unfold Str_as_DT.eq in e. subst. destruct (Str_as_DT.eq_dec k k); auto.
         unfold Str_as_DT.eq in n. contradiction.
     + destruct (Str_as_DT.eq_dec k k0). unfold Str_as_DT.eq in e.
         unfold Str_as_DT.eq in n. symmetry in e. contradiction.
         auto.
Qed.

Lemma find_middle: forall s lst1 lst2 v, ~ In s (map fst lst1 ++ map fst lst2) ->
                          @find stringlist_model.key V Str_as_DT.eq_dec (lst1 ++ (s, v) :: lst2) s = Some v.
Proof.
  induction lst1, lst2; intros.
  - simpl. destruct (Str_as_DT.eq_dec s s); auto. unfold Str_as_DT.eq in n. contradiction.
  - simpl. destruct (Str_as_DT.eq_dec s s); auto. unfold Str_as_DT.eq in n. contradiction.
  - remember [] as k. simpl in H. apply Decidable.not_or in H. inversion H; clear H.
     rewrite Heqk in H1.
     eapply (IHlst1 [] v) in H1. simpl.  destruct a. simpl in H0.
     destruct (Str_as_DT.eq_dec k0 s); auto. contradiction. subst. eapply H1.
  - remember (p :: lst2) as k. simpl in H. apply Decidable.not_or in H. inversion H; clear H.
     eapply (IHlst1 k v) in H1. simpl. destruct a. simpl in H0.
     destruct (Str_as_DT.eq_dec k0 s); auto. contradiction.
Qed.

Lemma find_add: forall k v m,
  @find stringlist_model.key V Str_as_DT.eq_dec (stringlist_model.Raw.add k v (stringlist_model.this m)) k = Some v.
Proof.
  intros. induction (stringlist_model.this m).
  - simpl. destruct (Str_as_DT.eq_dec k k); auto. unfold not in n.
     unfold Str_as_DT.eq in n. contradiction.
  - simpl. destruct a. destruct (Str_as_DT.eq_dec k s).
     + simpl. destruct (Str_as_DT.eq_dec k k); auto.
        unfold not in n. unfold Str_as_DT.eq in n. contradiction.
     + simpl. destruct (Str_as_DT.eq_dec s k). exfalso; apply n; auto.
        rewrite IHt0. auto.
Qed.

Lemma list_byte_neq: forall s str,
  string_to_list_byte s <> string_to_list_byte str -> s <> str.
Proof.
  intros. generalize dependent str. induction s.
  - unfold not. intros. apply H. apply list_byte_eq in H0. auto.
  - unfold not. intros. apply H. apply list_byte_eq. auto.
Qed.

Lemma notin_cons: forall k lst k0 (v0: V),
  ~ stringlist_model.Raw.PX.In k lst ->
  k0 <> k ->
  ~ stringlist_model.Raw.PX.In k (lst ++ [(k0, v0)]).
Proof.
  intros. destruct lst.
  - simpl. unfold stringlist_model.Raw.PX.In. unfold not. intros.
     inversion H1. inversion H2; subst.
     + inversion H4. simpl in H3. symmetry in H3. contradiction.
     + inversion H4.
  - simpl. unfold stringlist_model.Raw.PX.In. unfold not. intros.
     inversion H1; clear H1. inversion H2; subst.
     + inversion H3. destruct p; simpl in *; subst. apply H.
         unfold stringlist_model.Raw.PX.In. exists v. auto.
     + clear H3.
         apply H. unfold stringlist_model.Raw.PX.In. exists x.
         unfold stringlist_model.Raw.PX.MapsTo in *.
         apply
         (@SetoidList.InA_app _ (stringlist_model.Raw.PX.eqke (elt:=V)) (p::lst) ([(k0,v0)]) (k, x))
         in H2. inversion H2; clear H2; auto.
         unfold not in H0. inversion H1; subst; inversion H3; subst; simpl in *.
         symmetry in H2. contradiction.
Qed.

Lemma data_at_stringlist_ptr: forall cell_ptr p,
  data_at Ews t_stringlist cell_ptr p |-- data_at Ews (tptr t_scell) cell_ptr p.
Proof.
  intros. unfold_data_at (data_at _ _ _ p). rewrite field_at_data_at.
  unfold field_address. if_tac; simpl; auto.
  * entailer!.
  * entailer!. apply field_compatible_isptr in H0. inversion H0.
Qed.

(* ==================== GET CURSOR ==================== *)

Definition undef_cursor (p vret : val) : mpred :=
  (malloc_token Ews t_cursor vret * data_at Ews t_cursor (p, Vundef) vret)%logic.

Lemma body_stringlist_get_cursor: semax_body Vprog Gprog
    f_stringlist_get_cursor stringlist_get_cursor_spec.
Proof.
  unfold stringlist_get_cursor_spec. unfold get_cursor_funspec.
  unfold get_cursor_spec. start_function.
  simpl. Intros. forward. forward_call (t_cursor, gv).
  { split; try auto; try omega. simpl. easy. }
  { Intros vret. autorewrite with norm.
    forward_if (vret <> nullval). if_tac; entailer!.
    { rewrite if_true by auto. forward_call 1. entailer!. }
    { forward. entailer!. }
    { Intros. rewrite if_false by auto. Intros. forward.
      simpl.
      forward_loop
      (EX lst1: list (string * V), EX lst2: list (string * V), EX p0: val,
      PROP( lst1 ++ lst2 = stringlist_model.elements m /\
                not (stringlist_model.Raw.PX.In k lst1))
      LOCAL(temp _mc vret; temp _cur (Vptrofs(Ptrofs.repr(Zlength(lst1))));
                 gvars gv; temp _p p; temp _key q; temp _q p0)
      SEP(mem_mgr gv;
            stringlist_hole_rep lst2 m p p0 * string_rep k q *
            undef_cursor p vret))
      (* break cond *)
      break:
      (EX lst2: list (string * V), EX p0: val, PROP ( )
      LOCAL (temp _mc vret; temp _cur (Vlong (Int64.repr 0));
                  gvars gv; temp _p p; temp _key q; temp _q p0)
      SEP (mem_mgr gv; stringlist_hole_rep lst2 m p p0;
             string_rep k q; undef_cursor p vret)).
      { unfold stringlist_rep. Intros cell_ptr. forward.
        Exists (@nil (string * V)) (stringlist_model.elements m).
        Exists cell_ptr.
        unfold stringlist_hole_rep.
        Exists cell_ptr. autorewrite with sublist. entailer!.
        { inversion H8. inversion H9. }
        { unfold undef_cursor.  cancel. apply wand_refl_cancel_right. }}
      { Intros lst1 lst2 p0. forward_if (p0 <> nullval).
        { unfold stringlist_hole_rep. Intros cell_ptr. entailer!. }
        { forward. entailer!. }
        { forward. Exists lst2 p0. entailer!. admit. }
        { destruct lst2.
          { unfold stringlist_hole_rep. Intros cell_ptr.
            unfold scell_rep; fold scell_rep. Intros. contradiction. }
          { unfold stringlist_hole_rep. Intros cell_ptr. destruct p1.
            unfold scell_rep at 1; fold scell_rep. Intros q0 str_ptr.
            forward.
            forward_call (str_ptr, string_to_list_byte s, q, string_to_list_byte k).
            { unfold cstring. unfold string_rep.
              repeat rewrite length_string_list_byte_eq. cancel. }
            Intros vret0. forward_if. destruct Int.eq_dec in H3.
            { unfold undef_cursor. Intros. forward. forward.
              Exists vret. unfold cursor. Exists (m, 0). entailer!.
              simpl t_repr. simpl key_repr. simpl cursor_repr.
              unfold string_rep. unfold cstring at 2. repeat rewrite length_string_list_byte_eq.
              cancel. unfold stringlist_rep. Exists cell_ptr. cancel.
              unfold stringlist_cursor_rep. Exists p. cancel.
              apply wand_sepcon_adjoint.
              assert (K: (cstring Ews (string_to_list_byte s) str_ptr * malloc_token Ews t_scell p0 *
                 data_at Ews t_scell (str_ptr, (V_repr v, q0)) p0 *
                 malloc_token Ews (tarray tschar (Zlength (string_to_list_byte s) + 1)) str_ptr *
                 scell_rep lst2 q0)%logic |--
                 scell_rep ((s, v) :: lst2) p0).
                 { unfold scell_rep at 2; fold scell_rep. Exists q0 str_ptr.
                   unfold cstring. unfold string_rep. rewrite length_string_list_byte_eq.
                   cancel. }
              sep_apply K. apply wand_sepcon_adjoint. admit.
              (* apply modus_ponens_wand. *) }
            { unfold not in n. contradiction. }
            { forward. forward. Exists (lst1 ++ [(s, v)]) lst2. Exists q0.
              entailer!.
              { repeat split.
                 { rewrite <- H0. rewrite app_assoc_reverse. simpl. auto. }
                 { destruct (Int.eq_dec vret0 Int.zero) in H3.
                   contradiction. unfold not. intros. unfold stringlist_model.Raw.PX.In in H15.
                   unfold stringlist_model.Raw.PX.In in H1. unfold not in H1.
                   unfold stringlist_model.Raw.PX.MapsTo in H15. inversion H15.
                   rewrite SetoidList.InA_app_iff in H16. inversion H16.
                   { unfold stringlist_model.Raw.PX.MapsTo in H1. apply H1. exists x. auto. }
                   { inversion H17. inversion H19. simpl in H21. rewrite H21 in H3.
                      contradiction. inversion H19. }}
                   { admit. }}
               { admit. }}}}}
      { Intros lst2 p0. unfold undef_cursor. Intros. forward. forward.
        Exists vret (m, 0). entailer!. simpl. cancel. unfold stringlist_cursor_rep.
        Exists p. cancel. unfold stringlist_hole_rep. Intros cell_ptr.
        unfold stringlist_rep at 1. Exists cell_ptr. cancel. admit.
        (* apply modus_ponens_wand. *)  }

(* need to fix the double definition of stringlist and also the cursor number *)
Admitted.

(* ==================== MOVE TO NEXT ==================== *)

Lemma body_stringlist_move_to_next: semax_body Vprog Gprog
    f_stringlist_move_to_next stringlist_move_to_next_spec.
Proof.
  unfold stringlist_move_to_next_spec. unfold move_to_next_funspec.
  unfold move_to_next_spec. start_function.
  forward. simpl. unfold stringlist_cursor_rep. Intros strlst_p.
  sep_apply stringlist_rep_local_facts.
  simpl. forward.
  forward. forward_call (sh, strlst_p, m).
    { simpl. entailer!. }
    { forward. autorewrite with norm.
      remember (Int64.repr (prevcur + 1)) as nextcur.
      remember (Int64.repr (Zlength (elements (flatten stringlist_index m)))) as length.
      remember (Int64.ltu nextcur length) as cond1.
      remember (Int64.ltu (Int64.repr 0) nextcur) as cond2.
      remember (andb cond1 cond2) as condition.
      forward_if
        (PROP ( )
        LOCAL (temp _cur (Vlong nextcur);
                    temp _length (Vlong length); temp _lst strlst_p;
                    temp _mc p; temp _mcc p; temp _t'2 (if condition then Vtrue else Vfalse))
        SEP (t_repr stringlist_index sh m strlst_p; mem_mgr gv;
               malloc_token Ews t_cursor p;
               data_at Ews t_cursor (strlst_p, Vlong (Int64.repr prevcur)) p)).
      { forward. entailer!. unfold cardinality in H.
        rewrite H. simpl. unfold Val.of_bool. auto. }
      { forward. entailer!. unfold cardinality in H. rewrite H. simpl. auto. }
      { forward_if
        (PROP ( )
        LOCAL (temp _cur (Vlong nextcur); temp _length (Vlong length);
                    temp _lst strlst_p; temp _mc p; temp _mcc p;
                    temp _t'2 (if condition then Vtrue else Vfalse))
        SEP (mem_mgr gv;
         cursor_repr stringlist_index
           (move_to_next stringlist_index (m, prevcur)) p)).
      destruct condition.
        { forward. entailer!.
          assert (K: (move_to_next stringlist_index (m, prevcur)) = (m, prevcur+1)).
          { simpl in *. rewrite <- Heqcondition. auto. }
          rewrite K. simpl. unfold stringlist_cursor_rep.
          Exists strlst_p. entailer!. }
        { inversion H. }
        { forward. entailer!.
          assert (K: (move_to_next stringlist_index (m, prevcur)) = (m, 0)).
          { simpl in *. rewrite H. auto. }
          rewrite K. simpl. unfold stringlist_cursor_rep.
          Exists strlst_p. entailer!. }
       forward. Exists p. entailer!. }}
Qed.

(* ==================== MOVE TO FIRST ==================== *)

Lemma body_stringlist_move_to_first: semax_body Vprog Gprog
    f_stringlist_move_to_first stringlist_move_to_first_spec.
Proof.
  unfold stringlist_move_to_first_spec. unfold move_to_first_funspec.
  unfold move_to_first_spec. start_function.
  forward. simpl. unfold stringlist_cursor_rep. Intros strlst_p.
  simpl.
  forward. forward. Exists p. simpl. unfold stringlist_cursor_rep.
  entailer!. Exists strlst_p. simpl. entailer!.
Qed.

(* ================== CARDINALITY ================== *)

Lemma body_stringlist_cardinality: semax_body Vprog Gprog
    f_stringlist_cardinality stringlist_cardinality_spec.
Proof.
  unfold stringlist_cardinality_spec. unfold cardinality_funspec.
  unfold cardinality_spec. start_function.
  forward. simpl. unfold stringlist_rep. Intros cell_ptr.
  simpl in m.
  (* invariant *)
   forward_loop
  (EX lst1: list (string * V), EX lst2: list (string * V), EX p0: val,
  PROP( lst1 ++ lst2 = stringlist_model.elements m)
  LOCAL(temp _q p0; temp _size (Vptrofs (Ptrofs.repr (Zlength(lst1)))); temp _p p)
  SEP(stringlist_hole_rep lst2 m p p0))
  (* break cond *)
  break:
  (PROP ()
  LOCAL(temp _size (Vptrofs (Ptrofs.repr (Zlength(stringlist_model.elements m)))))
  SEP((stringlist_rep m p))).
  (* holds on entry *)
  - forward.
     Exists (@nil (string * V)) (stringlist_model.elements m) cell_ptr.
     entailer!. unfold stringlist_hole_rep. Exists cell_ptr. entailer!.
     apply wand_refl_cancel_right.
  (* holds on iteration *)
  - Intros lst1 lst2 p0. unfold stringlist_hole_rep.
     Intros cp0. forward_if (p0 <> nullval).
     { forward. entailer!. }
     { forward. autorewrite with norm.
       entailer!.
       { assert (K: nullval = nullval) by auto.  apply H4 in K.
         subst. rewrite <- H. autorewrite with sublist. auto. }
       unfold stringlist_rep. Exists cp0.
       cancel. apply modus_ponens_wand. }
      { forward. autorewrite with norm. destruct lst2.
        (* lst2 empty *)
       { unfold scell_rep; fold scell_rep. Intros. contradiction. }
         (* lst2 not empty *)
       { destruct p1.
         unfold scell_rep at 1; fold scell_rep. Intros q0 str_ptr.
         forward. entailer!.
         Exists (lst1 ++ [(s,v)]) lst2 q0. entailer!.
         split.
         { rewrite app_assoc_reverse. simpl. auto. }
         { f_equal. f_equal. rewrite Zlength_app. easy. }
         unfold stringlist_hole_rep. Exists cp0.
         entailer!. apply wand_frame_intro'.
         apply wand_sepcon_adjoint. apply wand_frame_intro'.
         assert (W: (malloc_token Ews t_scell p0 *
                         data_at Ews t_scell (str_ptr, (V_repr v, q0)) p0 *
                         string_rep s str_ptr *
                         malloc_token Ews (tarray tschar (Z.of_nat (length s) + 1)) str_ptr *
                         scell_rep lst2 q0)%logic |-- scell_rep ((s, v) :: lst2) p0).
         { unfold scell_rep at 2; fold scell_rep. Exists q0 str_ptr. cancel. }
         sep_apply W. sep_apply modus_ponens_wand. cancel. }}
 - autorewrite with norm. forward.
Qed.

(* ==================== LOOKUP ==================== *)

Lemma body_stringlist_lookup: semax_body Vprog Gprog
    f_stringlist_lookup stringlist_lookup_spec.
Proof. unfold stringlist_lookup_spec. unfold lookup_funspec. unfold lookup_spec.
  start_function. simpl. remember m as lst. remember k as str.
  (* loop invariant *)
  forward_loop
  (EX lst1: list (string * V), EX lst2: list (string * V), EX p0: val,
  PROP( lst1 ++ lst2 = stringlist_model.elements lst /\ not (stringlist_model.Raw.PX.In str lst1))
  LOCAL(temp _q p0; temp _key q)
  SEP(mem_mgr gv; stringlist_hole_rep lst2 lst p p0 * string_rep str q))
  (* break cond *)
  break:
  (PROP (nullval = proj1_sig (lookup stringlist_index m k))
  LOCAL()
  SEP((mem_mgr gv * stringlist_rep lst p * string_rep str q))).
 (* invariant holds entering loop*)
  - unfold stringlist_rep. Intros cell_ptr. forward.
     Exists (@nil (string * V)) (stringlist_model.elements lst).
     Exists cell_ptr.
     unfold stringlist_hole_rep.
     Exists cell_ptr. autorewrite with sublist. entailer!.
     { inversion H4. inversion H5. }
     { apply wand_refl_cancel_right. }
  (* invariant holds in the loop *)
  - Intros lst1 lst2 p0. forward_if (p0 <> nullval).
    { unfold stringlist_hole_rep. Intros cell_ptr. entailer!. }
    { forward. entailer!. }
    { (* break inv used *) unfold stringlist_hole_rep. Intros cell_ptr.
      rewrite H1.  forward. entailer!.
      { assert (K: nullval = nullval). auto. apply H5 in K.
        subst. autorewrite with sublist in H.
        rewrite H in H0. replace (lookup stringlist_index m k) with nullV; auto.
        unfold lookup. simpl. simpl in k. simpl in m. apply notin_lst_find_none in H0.
        assert
        (P: @find stringlist_model.key V Str_as_DT.eq_dec (stringlist_model.elements (elt:=V) m) k = None).
        { rewrite <- H0.
          apply stringlistfind_eq_find. }
          rewrite P; auto. }
        { unfold stringlist_rep. Exists cell_ptr. cancel.
         apply modus_ponens_wand. }}
    { destruct lst2.
        (* lst2 empty *)
       { unfold stringlist_hole_rep. Intros cell_ptr.
         unfold scell_rep; fold scell_rep. Intros. contradiction. }
         (* lst2 not empty *)
       { unfold stringlist_hole_rep. Intros cell_ptr. destruct p1.
         unfold scell_rep at 1; fold scell_rep. Intros q0 str_ptr.
         forward.
         forward_call (str_ptr, string_to_list_byte s, q, string_to_list_byte str).
         { unfold cstring. unfold string_rep.
           repeat rewrite length_string_list_byte_eq. cancel. }
         Intros vret. forward_if.
         { destruct (Int.eq_dec vret Int.zero) in H2.
           { forward.
              { unfold V in v. entailer!.
                destruct v. auto. }
              { forward. entailer!.
                { assert (M: lookup stringlist_index m k = v).
                  { apply list_byte_eq in H2; rewrite <- H2. unfold lookup. simpl in k. simpl in m.
                    assert (K: stringlist_model.elements m = (elements (flatten stringlist_index m))) by auto.
                    rewrite <- K. rewrite <- H. simpl.
                    assert
                    (P: @find stringlist_model.key V Str_as_DT.eq_dec (lst1 ++ (s, v) :: lst2) s
                     = (Some v)).
                    { assert (W: NoDup (map fst (stringlist_model.elements (elt:=V) m))).
                      apply lstnodup. rewrite <- H in W. rewrite map_app in W. simpl in W.
                      apply (@NoDup_remove_2 string (map fst (lst1)) (map fst (lst2)) s) in W.
                      apply find_middle; auto. }
                    rewrite P. auto. } rewrite M; simpl; auto. }
                 simpl t_repr. simpl key_repr. unfold string_rep. unfold cstring at 2. rewrite length_string_list_byte_eq.
                 cancel. unfold stringlist_rep. Exists cell_ptr. cancel.
                 apply wand_sepcon_adjoint.
                 assert (K: (cstring Ews (string_to_list_byte s) str_ptr * malloc_token Ews t_scell p0 *
                 data_at Ews t_scell (str_ptr, (V_repr v, q0)) p0 *
                 malloc_token Ews (tarray tschar (Zlength (string_to_list_byte s) + 1)) str_ptr *
                 scell_rep lst2 q0)%logic |--
                 scell_rep ((s, v) :: lst2) p0).
                 { unfold scell_rep at 2; fold scell_rep. Exists q0 str_ptr.
                   unfold cstring. unfold string_rep. rewrite length_string_list_byte_eq.
                   cancel. }
                  sep_apply K. apply wand_sepcon_adjoint. apply modus_ponens_wand. }}
           { contradiction. }}
          { destruct (Int.eq_dec vret Int.zero) in H2.
            contradiction.
            abbreviate_semax. forward. Exists (lst1 ++ [(s, v)]) lst2.
            Exists q0. entailer!.
            { split.
              { rewrite <- H. rewrite app_assoc_reverse. simpl. auto. }
              { unfold not. intros. unfold stringlist_model.Raw.PX.In in H14.
                unfold stringlist_model.Raw.PX.In in H0. unfold not in H0.
                unfold stringlist_model.Raw.PX.MapsTo in H14. inversion H14.
                rewrite SetoidList.InA_app_iff in H15. inversion H15.
                { unfold stringlist_model.Raw.PX.MapsTo in H0. apply H0. exists x. auto. }
                { inversion H16. inversion H18. simpl in H20. rewrite H20 in H2.
                  contradiction. inversion H18. }}}
             { unfold string_rep. unfold cstring at 2. rewrite length_string_list_byte_eq.
               cancel. unfold stringlist_hole_rep. Exists cell_ptr.
               entailer!. apply wand_frame_intro'.
               apply wand_sepcon_adjoint. apply wand_frame_intro'.
               assert (K: (cstring Ews (string_to_list_byte s) str_ptr * malloc_token Ews t_scell p0 *
               data_at Ews t_scell (str_ptr, (V_repr v, q0)) p0 *
               malloc_token Ews (tarray tschar (Zlength (string_to_list_byte s) + 1)) str_ptr *
               scell_rep lst2 q0)%logic |--
               scell_rep ((s, v) :: lst2) p0).
               { unfold scell_rep at 2; fold scell_rep. Exists q0 str_ptr.
                 unfold cstring. unfold string_rep. rewrite length_string_list_byte_eq.
                 cancel. }
               sep_apply K. apply modus_ponens_wand. }}}}
  (* invariant holds after loop *) (* break inv used *)
  - forward. entailer!. simpl. auto.
Qed.

(* ==================== CREATE ==================== *)

Lemma body_stringlist_create: semax_body Vprog Gprog
    f_stringlist_new stringlist_create_spec.
Proof.
  unfold stringlist_create_spec. unfold create_funspec.
  unfold create_spec.
  start_function.
  forward_call (t_stringlist, gv).
  { split3; auto. cbn. computable. }
  Intros p.
  forward_if
    (PROP ( )
     LOCAL (temp _p p; gvars gv)
     SEP (mem_mgr gv; malloc_token Ews t_stringlist p * data_at_ Ews t_stringlist p)).
  { destruct eq_dec; entailer. }
  { forward_call 1. entailer. }
  { forward. rewrite if_false by assumption. entailer. }
  { Intros. forward. forward. Exists p. Exists (stringlist_model.empty V).
    entailer!. simpl.
    unfold stringlist_rep. unfold stringlist_model.empty. simpl.
    Exists  (Vlong (Int64.repr 0)). entailer!. }
Qed.

(* ==================== INSERT ==================== *)

Lemma body_stringlist_insert: semax_body Vprog Gprog
    f_stringlist_insert stringlist_insert_spec.
Proof.
  unfold stringlist_insert_spec. unfold insert_funspec. unfold insert_spec.
  start_function.
  simpl. Intros. unfold stringlist_rep. forward.
  { Intros cell_ptr. rewrite data_at_isptr. entailer!. }
  remember (offset_val (align 0 (alignof (tptr (Tstruct _scell noattr))))
               mptr) as r.
  (* invariant *)
  forward_loop
  (EX lst1, EX lst2, EX add,
  PROP( lst1 ++ lst2 = stringlist_model.elements m /\ not (stringlist_model.Raw.PX.In k lst1)
            /\ field_compatible t_stringlist [StructField _root] mptr)
  LOCAL(gvars gv; temp _r add; temp _p mptr; temp _key kptr; temp _value (V_repr v))
  SEP(mem_mgr gv; string_rep k kptr; malloc_token Ews t_stringlist mptr;
        EX cp2: val, strlst_rep add cp2 lst2 *
        (ALL lst', ALL cpnew, EX cp', strlst_rep add cpnew lst' -*
         strlst_rep mptr cp' (lst1 ++ lst')))).
  (* invariant holds on entry *)
  - entailer!. Exists (@nil (string * V)) (stringlist_model.elements m) mptr.
     simpl. entailer!.
     { inversion H5. inversion H6. }
     { Exists cell_ptr.
       assert (K: data_at Ews t_stringlist cell_ptr mptr |-- data_at Ews (tptr t_scell) cell_ptr mptr).
       { unfold_data_at (data_at _ _ _ mptr). rewrite field_at_data_at.
         unfold field_address. if_tac; simpl; auto.
         * entailer!.
         * entailer!. apply field_compatible_isptr in H6. inversion H6. }
       sep_apply K. clear K. unfold strlst_rep at 1. cancel.
       apply allp_right. intro. apply allp_right. intro. Exists v1.
       apply wand_refl_cancel_right. }
  (* invariant holds after *)
  - Intros lst1 lst2 addr. Intros cellptr2. clear Heqr. unfold strlst_rep at 1. Intros.
     forward. sep_apply scell_rep_local_facts. forward_if.
     (* if list empty *)
     +  rewrite H2. sep_apply string_rep_local_facts. Intros.
         (* we know 2nd part is empty *)
         assert (M: nullval = nullval) by auto.
         apply H4 in M. rewrite M.
         (* create new cell with (k,v) *)
         forward_call (gv, kptr, k, v, nullval, (@nil (string * V))).
         Intros vret. forward. forward. Exists (stringlist_model.add k v m). entailer!.
         split.
           { unfold lookup. simpl.
             rewrite find_add. auto. }
           { (* prove return null *) unfold lookup. simpl.
             rewrite stringlistfind_eq_find. assert (W: stringlist_model.find (elt:=V) k m = None).
             { apply notin_lst_find_none. rewrite <- H. autorewrite with sublist. auto. }
             rewrite W. auto. }
           { simpl t_repr. simpl key_repr. unfold stringlist_rep.
             allp_left [(k, v)]. allp_left vret. Intros cp'. Exists cp'.
             entailer!.
             rewrite sepcon_assoc. rewrite sepcon_comm.
             replace (scell_rep [(k, v)] vret * data_at Ews (tptr t_scell) vret addr)%logic
             with (strlst_rep addr vret [(k,v)]). sep_apply modus_ponens_wand.
             replace (@stringlist_model.elements V (@stringlist_model.add V k v m)) with (lst1 ++ [(k, v)]).
             unfold strlst_rep; entailer!.
             assert (K: data_at Ews (tptr t_scell) cp' mptr |-- data_at Ews t_stringlist cp' mptr).
            { (* this is where we need the extra premise of field_compatible *)
              unfold_data_at (data_at _ t_stringlist _ mptr). rewrite field_at_data_at.
              unfold field_address. if_tac; simpl; auto.
              * entailer!. * contradiction. }
             sep_apply K. clear K. entailer!.
            { autorewrite with sublist in H. simpl. unfold stringlist_model.elements in H.
              unfold stringlist_model.Raw.elements in H. rewrite <- H.
              apply (@notin_lst_add_end lst1 k v) in H0.
              rewrite <- H0. reflexivity. }
            { unfold strlst_rep. apply sepcon_comm. }}

      (* if list nonempty *)
      + simpl. destruct lst2.
          { Intros. assert (M: @nil (string * V) = @nil (string * V)); auto.
            apply H3 in M. contradiction. }
          { unfold scell_rep; fold scell_rep. destruct p. Intros q str_ptr.
            forward.
            forward_call (str_ptr, string_to_list_byte k0, kptr, string_to_list_byte k).
            { unfold string_rep. unfold cstring. rewrite length_string_list_byte_eq.
              entailer!. rewrite length_string_list_byte_eq. entailer!. }
            Intros vret. forward_if.
            { destruct (Int.eq_dec vret Int.zero); try contradiction.
              apply list_byte_eq in H4; subst. forward.
              { entailer!. unfold V in v0. destruct v0. auto. }
              { forward. forward. Exists (stringlist_model.add k v m).
                simpl. entailer!.
                { unfold lookup. simpl. rewrite <- H. simpl in k.
                  assert
                  (P: @find stringlist_model.key V Str_as_DT.eq_dec (lst1 ++ (k, v0) :: lst2) k
                         = (Some v0)).
                        { assert (W: NoDup (map fst (stringlist_model.elements (elt:=V) m))).
                          apply lstnodup. rewrite <- H in W. rewrite map_app in W. simpl in W.
                          apply (@NoDup_remove_2 string (map fst (lst1)) (map fst (lst2)) k) in W.
                          apply find_middle; auto. }
                  rewrite P. split; auto. rewrite find_add. auto. }
                unfold string_rep. unfold cstring at 2.
                rewrite length_string_list_byte_eq. cancel.
                unfold stringlist_rep.
                unfold strlst_rep. allp_left ((k, v) :: lst2).
                allp_left cellptr2. Intros cp'. Exists cp'. cancel.
                assert (M: (cstring Ews (string_to_list_byte k) str_ptr *
                malloc_token Ews t_scell cellptr2 *
                data_at Ews t_scell (str_ptr, (V_repr v, q)) cellptr2 *
                malloc_token Ews (tarray tschar (Zlength (string_to_list_byte k) + 1)) str_ptr *
                scell_rep lst2 q)%logic
                |-- scell_rep ((k, v) :: lst2) cellptr2).
                { unfold scell_rep at 2; fold scell_rep. Exists q str_ptr.
                  cancel. unfold cstring. unfold string_rep.
                  rewrite length_string_list_byte_eq. entailer!. }
                sep_apply M. rewrite sepcon_comm.
                rewrite sepcon_assoc.
                remember (data_at Ews (tptr t_scell) cellptr2 addr *
                scell_rep ((k, v) :: lst2) cellptr2)%logic as P.
                remember (data_at Ews (tptr t_scell) cp' mptr *
                scell_rep (lst1 ++ (k, v) :: lst2) cp')%logic as Q.
                sep_apply wand_frame_elim''. subst Q. clear HeqP.
                assert (K: data_at Ews (tptr t_scell) cp' mptr  |-- data_at Ews t_stringlist cp' mptr).
                { unfold_data_at (data_at _ t_stringlist _ mptr). rewrite field_at_data_at.
                  unfold field_address. if_tac; simpl; auto.
                  * entailer!. * contradiction. }
                sep_apply K; clear K; cancel. unfold key.
                replace (@stringlist_model.elements V (@stringlist_model.add V k v m))
                with (lst1 ++ (k, v) :: lst2).
                entailer!. simpl.
                unfold stringlist_model.elements in H.
                unfold stringlist_model.Raw.elements in H. clear M. clear P. clear H3.
                rewrite <- H.
                apply notin_lst_add_middle. auto. }}
              { forward. entailer!.
                Exists (lst1 ++ [(k0,v0)]) lst2 (offset_val 16 cellptr2) q. entailer!.
                { split.
                  * rewrite app_assoc_reverse. simpl. rewrite H. auto.
                  * apply notin_cons. auto. destruct (Int.eq_dec vret Int.zero).
                    contradiction. apply list_byte_neq in H4.  auto. }
                unfold cstring at 2. unfold string_rep.
                rewrite length_string_list_byte_eq. entailer!.
                unfold strlst_rep at 3. cancel.
                unfold_data_at (data_at _ _ _ cellptr2).
                rewrite (field_at_data_at' _ _ [StructField _next]).
                simpl nested_field_type. simpl nested_field_offset.
                entailer!.
                apply allp_right. intro lst'. apply allp_right. intro cpnew.
                allp_left ((k0,v0)::lst').
                allp_left cellptr2. Intros cp'. Exists cp'.
                rewrite <- wand_sepcon_adjoint.
                assert (Q: ((cstring Ews (string_to_list_byte k0) str_ptr *
                (malloc_token Ews t_scell cellptr2 *
                (field_at Ews t_scell [StructField _key] str_ptr cellptr2 *
                (malloc_token Ews
                (tarray tschar (Zlength (string_to_list_byte k0) + 1)) str_ptr *
                (field_at Ews t_scell [StructField _value] (V_repr v0) cellptr2 *
                data_at Ews (tptr t_scell) cellptr2 addr))))) *
                strlst_rep (offset_val 16 cellptr2) cpnew lst')%logic |-- strlst_rep addr cellptr2 ((k0, v0) :: lst')).
                { unfold strlst_rep. cancel. unfold scell_rep at 2; fold scell_rep.
                  Exists cpnew str_ptr. cancel.
                  unfold cstring. unfold string_rep.
                  rewrite length_string_list_byte_eq. entailer!.
                  unfold_data_at (data_at _ _ _ cellptr2).
                  rewrite (field_at_data_at _ _ [StructField _next]), field_address_offset.
                  entailer!. auto. } sep_apply Q. sep_apply modus_ponens_wand.
                rewrite app_assoc_reverse. simpl. entailer!. }}
Qed.


Require Import Kami.AllNotations ProcKami.FU ProcKami.Div.
Require Import List.

Section Alu.
  Context `{procParams: ProcParams}.

  Section Ty.
    Variable ty: Kind -> Type.

    Definition JumpInputType :=
      STRUCT_TYPE {
        "pc"                   :: VAddr;
        "new_pc"               :: VAddr;
        "compressed?"          :: Bool
        }.

    Definition JumpOutputType :=
      STRUCT_TYPE {
          "misaligned?" :: Bool ;
          "newPc" :: VAddr ;
          "retPc" :: VAddr }.

    Local Open Scope kami_expr.

    Local Definition jumpTag (jumpOut: JumpOutputType ## ty)
      :  PktWithException ExecUpdPkt ## ty
      := LETE jOut <- jumpOut;
         LETC val1: RoutedReg <- (STRUCT {
                                      "tag" ::= Const ty (natToWord RoutingTagSz IntRegTag);
                                      "data" ::= SignExtendTruncLsb Rlen (#jOut @% "retPc")
                                 });
         LETC val2: RoutedReg <- (STRUCT {
                                      "tag" ::= Const ty (natToWord RoutingTagSz PcTag);
                                      "data" ::= SignExtendTruncLsb Rlen (#jOut @% "newPc")
                                 });
         LETC fullException: Exception <- ($(if misaligned_access
                                                                then InstAccessFault
                                                                else InstAddrMisaligned) : Exception @# ty);
         LETC sndVal: Maybe Exception <-  STRUCT {"valid" ::= (#jOut @% "misaligned?") ;
                                                  "data"  ::= #fullException };
         LETC val
           :  ExecUpdPkt
           <- (noUpdPkt ty
                 @%["val1"
                      <- (Valid #val1)]
                 @%["val2"
                      <- (Valid #val2)]
                 @%["taken?" <- $$ true]) ;
         LETC retval:
           (PktWithException ExecUpdPkt)
             <- STRUCT { "fst" ::= #val ;
                         "snd" ::= #sndVal } ;
         RetE #retval.

    Local Definition transPC (sem_output_expr : JumpOutputType ## ty)
      :  JumpOutputType ## ty
      := LETE sem_output
           :  JumpOutputType
           <- sem_output_expr;
         LETC newPc : VAddr
           <- ZeroExtendTruncMsb Xlen (* bit type cast *)
                ({<
                   ZeroExtendTruncMsb (Xlen - 1) (#sem_output @% "newPc"),
                   $$WO~0
                >});
         RetE (#sem_output @%["newPc" <- #newPc]).

    Local Close Scope kami_expr.

  End Ty.

  Local Open Scope kami_expr.

  Definition Jump: FUEntry
    := {|
         fuName := "jump";
         fuFunc
           := fun ty (sem_in_pkt_expr : JumpInputType ## ty)
                => LETE sem_in_pkt
                     :  JumpInputType
                     <- sem_in_pkt_expr;
                   LETC new_pc
                     :  VAddr
                     <- #sem_in_pkt @% "new_pc";
                   RetE
                     (STRUCT {
                        "misaligned?"
                        ::= !($$allow_inst_misaligned) &&
                             ((unsafeTruncLsb 2 #new_pc)$[1:1] != $0);
                        "newPc" ::= #new_pc;
                        "retPc"
                          ::= ((#sem_in_pkt @% "pc") +
                               (IF (#sem_in_pkt @% "compressed?")
                                  then $2
                                  else $4))
                      } : JumpOutputType @# ty);
         fuInsts
           := {|
                instName     := "jal" ;
                xlens        := xlens_all;
                extensions   := "I" :: nil;
                ext_ctxt_off := nil;
                uniqId       := fieldVal instSizeField ('b"11") ::
                                fieldVal opcodeField ('b"11011") ::
                                nil;
                inputXform
                  := fun ty (cfg_pkt : ContextCfgPkt @# ty) exec_context_pkt
                       => LETE exec_pkt
                            <- exec_context_pkt;
                          LETC inst
                            :  Inst
                            <- #exec_pkt @% "inst";
                          RetE
                            (STRUCT {
                               "pc" ::= #exec_pkt @% "pc";
                               "new_pc"
                                 ::= ((#exec_pkt @% "pc") +
                                      (SignExtendTruncLsb Xlen
                                         ({<
                                           (#inst $[31:31]),
                                           (#inst $[19:12]),
                                           (#inst $[20:20]),
                                           (#inst $[30:21]),
                                           $$ WO~0
                                         >})));
                                "compressed?" ::= (#exec_pkt @% "compressed?")
                             } : JumpInputType @# ty);
                outputXform  := jumpTag;
                optMemParams  := None ;
                instHints    := falseHints<|hasRd := true|>
              |} ::
              {| instName     := "jalr" ;
                 xlens        := xlens_all;
                 extensions   := "I" :: nil;
                 ext_ctxt_off := nil;
                 uniqId       := fieldVal instSizeField ('b"11") ::
                                 fieldVal opcodeField ('b"11001") ::
                                 nil;
                 inputXform
                   := fun ty (cfg_pkt : ContextCfgPkt @# ty) expr_context_pkt
                        => LETE exec_pkt
                             <- expr_context_pkt;
                           LETC inst
                             :  Inst
                             <- #exec_pkt @% "inst";
                           RetE
                             (STRUCT {
                                "pc" ::= #exec_pkt @% "pc";
                                "new_pc"
                                  ::= SignExtendTruncLsb Xlen (* bit type cast *)
                                        ({<
                                          ZeroExtendTruncMsb (Xlen - 1)
                                            ((xlen_sign_extend Xlen (cfg_pkt @% "xlen") (#exec_pkt @% "reg1")) +
                                             (SignExtendTruncLsb Xlen (imm #inst))),
                                          $$ WO~0
                                        >});
                                "compressed?" ::= (#exec_pkt @% "compressed?")
                              } : JumpInputType @# ty);
                 outputXform  := fun ty (sem_output_expr : JumpOutputType ## ty)
                                   => jumpTag (transPC sem_output_expr);
                 optMemParams  := None ;
                 instHints    := falseHints<|hasRs1 := true|><|hasRd := true|>
              |} ::
              nil
       |}.

  Close Scope kami_expr.
End Alu.


Require Import Reals.
From iris.program_logic Require Export weakestpre.
From iris.algebra Require Import gmap auth agree gset coPset.
From iris.base_logic Require Import big_op soundness.
From iris.base_logic.lib Require Import wsat.
From iris.proofmode Require Import tactics.
From iris.program_logic Require Import prob_language prob_lifting.
Set Default Proof Using "Type".
Import uPred.

From discprob.idxval Require Import pival pival_dist pidist_singleton idist_pidist_pair ival_dist irrel_equiv ival_pair.
From discprob.basic Require Import monad.

Section adequacy.
Context {Λ : probLanguage}.
Context `{stateG' Λ Σ} `{probG Σ}.
Implicit Types e : expr Λ.
Implicit Types P Q : iProp Σ.
Implicit Types Φ : val Λ → iProp Σ.
Implicit Types Φs : list (val Λ → iProp Σ).

Notation world σ := (state_interp σ)%I.

Notation wptp t := ([∗ list] ef ∈ t, WP ef {{ _, True }})%I.

Lemma wp_step' e1 σ1 c1 Φ:
  language.to_val e1 = None →
  world σ1 ∗ WP e1 {{ Φ }} ∗ aux_interp c1 ={⊤, ∅}=∗
        ▷ (⌜reducible e1 σ1⌝ ∧ ∃ c2, ∀ e2 σ2 efs c3,
        ⌜prim_step e1 σ1 e2 σ2 efs⌝ ={∅, ⊤}=∗ (world σ2 ∗ WP e2 {{ Φ }} ∗ wptp efs
                                   ∗ step_interpR e1 σ1 c1 c2 e2 σ2 efs c3)).
Proof.
  rewrite {1}wp_unfold /wp_pre. iIntros (Hnone). iIntros "[Hσ [H Ha]]".
  rewrite Hnone.
  iMod ("H" $! σ1 c1 with "[$Hσ $Ha]") as "($ & H)".
  iModIntro; iNext.
  iDestruct "H" as (c) "H".
  iExists c. iIntros (e2 σ2 efs c3) "%".
  iMod ("H" $! e2 σ2 efs c3 with "[//]") as "($&$&$&$)"; auto.
Qed.

Lemma wp_step e1 σ1 c1 Φ:
  language.to_val e1 = None →
  world σ1 ∗ WP e1 {{ Φ }} ∗ aux_interp c1 ={⊤, ∅}=∗
        ▷ ∃ c2, ∀ e2 σ2 efs c3,
        ⌜prim_step e1 σ1 e2 σ2 efs⌝ ={∅, ⊤}=∗ (world σ2 ∗ WP e2 {{ Φ }} ∗ wptp efs
                                   ∗ step_interpR e1 σ1 c1 c2 e2 σ2 efs c3).
Proof.
  iIntros (Hred) "H".
  iPoseProof (wp_step' with "H") as "H"; auto.
  iMod "H". iModIntro. iNext.
  iDestruct "H" as "(_ & $)".
Qed.

Lemma wptp_step_hd e1 t σ1 c1 Φ :
  language.to_val e1 = None →
  world σ1 ∗ WP e1 {{ Φ }} ∗ wptp t ∗ aux_interp c1  ={⊤, ∅}=∗
        ▷ (⌜ reducible e1 σ1⌝ ∧ ∃ c2, ∀ e2 σ2 efs c3,
        ⌜prim_step e1 σ1 e2 σ2 efs⌝ ={∅, ⊤}=∗ (world σ2 ∗ WP e2 {{ Φ }} ∗ wptp (t ++ efs)
                                   ∗ step_interpR e1 σ1 c1 c2 e2 σ2 efs c3)).
Proof.
  iIntros (Hred) "(HW&He&Ht&Ha)".
  iPoseProof (wp_step' with "[HW He Ha]") as "H"; [ eauto | eauto |].
  { iFrame. }
  iMod "H". iModIntro. iNext.
  iDestruct "H" as "(% & H)".
  iSplit; auto.
  iDestruct "H" as (c) "H".
  iExists c. iIntros (e2 σ2 efs c3) "Hprim".
  iFrame. iSpecialize ("H" $! e2 σ2 efs c3 with "Hprim"); auto.
Qed.

Lemma rcons_app_single {A} (a: A) l : seq.rcons l a = seq.cat l (a :: nil).
Proof.
  induction l => //=; by f_equal.
Qed.

Opaque step_interpR.

Lemma wptp_step_tl e1 tl ei tr σ1 c1 Φ :
  language.to_val ei = None →
  world σ1 ∗ WP e1 {{ Φ }} ∗ wptp (tl ++ ei :: tr) ∗ aux_interp c1
        ={⊤, ∅}=∗ ▷ (⌜ reducible ei σ1 ⌝ ∧  ∃ (c2: choice_type ei σ1 c1), ∀ ei' σ2 efs c3,
        ⌜prim_step ei σ1 ei' σ2 efs⌝
        ={∅, ⊤}=∗ (world σ2 ∗ WP e1 {{ Φ }} ∗ wptp (tl ++ ei' :: tr ++ efs) ∗ step_interpR ei σ1 c1 c2 ei' σ2 efs c3))%I.
Proof.
  iIntros (Hred).
  iIntros  "(HW & He & ($ & Hei& $) & Hsl)". iFrame "He".
  iFrame.
  iPoseProof (wp_step' with "[HW Hei Hsl]") as "Hstep"; [ done | iFrame | ].
  iMod "Hstep"; iModIntro. iNext.
  iDestruct "Hstep" as (Hred' c2) "Hstep".
  iSplit; auto.
  iExists c2. iIntros (e2 σ2 efs c3) "Hprim".
  iMod ("Hstep" $! e2 σ2 efs c3 with "Hprim") as "($&$&$&$)"; auto.
Qed.

Local Open Scope nat_scope.

Transparent step_interpR.

Lemma suffix_anti_symm {A} (l1 l2: list A) :
  l1 `suffix_of` l2 → l2 `suffix_of` l1 → l1 = l2.
Proof.
  destruct 1 as (ll1&Heq1).
  destruct 1 as (ll2&Heq2).
  rewrite Heq1 in Heq2.
  apply (f_equal length) in Heq2.
  rewrite ?app_length in Heq2.
  destruct ll1, ll2; rewrite //= in Heq2; try omega; try auto.
Qed.

Definition coupling_post {X} (φ : val Λ → X → Prop) (x : language.cfg Λ) y :=
  match x with
  | (e :: t, σ) =>
    match to_val e with
    | None => False
    | Some v => φ v y
    end
  | _ => False
  end.

Require Import Logic.Eqdep_dec.

Lemma cat_app {A} (l1 l2: list A):
  seq.cat l1 l2 = app l1 l2.
Proof. rewrite //=. Qed.

Lemma ic_bind_iProp {A1 A2 A1' A2'} (P: A1 → A2 → Prop) f1 f2 I1 Is2 Is0
      (Q : A1' → A2' → Prop) (Ic: irrel_couplingP I1 Is2 P):
  irrel_pidist (Is2 ≫= f2) Is0 →
  ((∀ xyS: { xy: A1 * A2 | P (fst xy) (snd xy )},
              (⌜ irrel_coupling_propP (f1 (fst (proj1_sig xyS)))
                                      (f2 (snd (proj1_sig xyS))) Q ⌝ : iProp Σ))%I
   ⊢ (⌜ irrel_coupling_propP (I1 ≫= f1) Is0 Q ⌝)%I).
Proof.
  intros Hle.
  iIntros (Hall).
  iPureIntro. eapply irrel_coupling_prop_irrel_Proper; first done.
  * eauto.
  * done.
  * eapply irrel_coupling_prop_bind; eauto.
    ** eexists; eauto.
    ** intros x y HP. eapply (Hall (exist _ (x, y) HP)).
Qed.

Theorem wp_coupling {X: Type} n e t σ φ (Is0: pidist X)
        (sch : scheduler) (tr: trace)
        (Hterm: terminates sch (tr ++ ((e :: t, σ) :: nil)) n) :
  (world σ ∗ WP e {{ v, ∃ (v' : X), ownProb (mret v') ∗ ⌜φ v v'⌝ }}
         ∗ wptp t
         ∗ aux_interp (existT X Is0))%I ⊢
 Nat.iter (S n) (λ P, |={⊤, ∅}▷=> P)
          ⌜ irrel_coupling_propP (ivdist_trace_stepN_aux sch tr (e :: t) σ n) Is0 (coupling_post φ) ⌝.
Proof.
  iStartProof.
  iRevert (e t σ φ sch tr Is0 Hterm).
  iInduction n as [|n] "IH";
  iIntros (e t σ φ sch tr Is0 Hterm) "H".
  - iAssert ( |={⊤, ∅}▷=> ⌜∃ v v', e = of_val v ∧ irrel_pidist (mret v') Is0
                      ∧ coupling_post φ (of_val v :: t, σ) v'⌝)%I with "[H]"
      as "H"; last first.
    { rewrite //=.
      iMod "H"; iModIntro; iNext. iMod "H"; iModIntro.
      iDestruct "H" as %(v&v'&Heq1&Hle&Hpost); last first.
      iPureIntro. unshelve (eexists); last done.
      eapply irrel_coupling_mono_irrel.
      * reflexivity.
      * eassumption.
      * subst. rewrite //=.
        eapply irrel_coupling_mret; eauto.
    }
    edestruct (Hterm tr (e :: t, σ) 0) as (v&tp'&Heqval); eauto.
    { econstructor. }
    inversion Heqval; subst.
    iExists v.
    iDestruct "H" as "(HW&He&Hwptp&Haux)".
    iAssert (|={⊤, ∅}▷=> ∃ (v' : X), ⌜irrel_pidist (mret v') Is0 ∧ φ v v'⌝)%I with
        "[HW He Hwptp Haux]" as "H"; last first.
    {
      iMod "H"; iModIntro; iNext; iMod "H"; iModIntro.
      iDestruct "H" as (v') "Hp". iDestruct "Hp" as %(Hle&Hφ).
      iPureIntro. exists v'; split_and!; auto.
      rewrite //= to_of_val //=.
    }
    iDestruct (wp_value_inv with "He") as "H".
    rewrite /ownProb.
    iMod "H" as (v') "(H&Hphi)".
    iDestruct "H" as (Is') "(Hle&Hown)".
      iApply (step_fupd_mask_mono ∅ _ _ ∅); [ auto | auto | ].
    iModIntro; iNext; iModIntro.
    rewrite /ownProbRaw.
      iDestruct (own_valid_2 with "Haux Hown")
          as %[(HeqTy&Heq_spi)%Excl_included _]%auth_valid_discrete_2; auto.
      iClear "Haux". iClear "Hown".
      iDestruct "Hphi" as %Hphi.
      iDestruct "Hle" as %Hle.
      iPureIntro. clear -Hphi Heq_spi Hle.
      rewrite //= in Heq_spi.
      exists v' => //=; split; auto.
      etransitivity; first eassumption.
      rewrite -Heq_spi.
      rewrite -eq_rect_eq_dec; eauto; first reflexivity.
      intros. apply ClassicalEpsilon.excluded_middle_informative.
  - rewrite /ivdist_trace_stepN_aux.
    rewrite -/ivdist_trace_stepN_aux.
    rewrite /ivdist_trace_step.
    specialize (terminates_S sch tr (e :: t, σ)) => Hterm_Some.
    remember (sch (tr ++ [(e :: t, σ)])) as i eqn:Heq_sched.
    destruct ((e :: t) !! i) as [ei|] eqn:Hlookup; last first.
    { rewrite /ivdist_tpool_stepi. rewrite -Heq_sched Hlookup.
      setoid_rewrite ivd_left_id.
      setoid_rewrite ivd_left_id.
      rewrite Nat_iter_S.
      iApply (step_fupd_mask_mono ∅ _ _ ∅); [ done | done |].
      iModIntro. iNext. iModIntro.
      iApply "IH".
      iPureIntro.
      { subst. rewrite -cat_app. rewrite -seq.catA.
        eapply terminates_stutter_None; eauto. }
      eauto.
    }
    destruct (to_val ei) as [v|] eqn:Heq_val.
    { rewrite /ivdist_tpool_stepi. rewrite -Heq_sched Hlookup.
      setoid_rewrite ivdist_prim_step_val_mret; last first.
      { rewrite //=. congruence. }
      setoid_rewrite ivd_left_id.
      setoid_rewrite ivd_left_id.
      setoid_rewrite ivd_left_id.
      rewrite Nat_iter_S.
      iApply (step_fupd_mask_mono ∅ _ _ ∅); [ done | done |].
      iModIntro. iNext. iModIntro.
      iApply "IH".
      iPureIntro.
      { subst. rewrite -cat_app. rewrite -seq.catA.
        eapply terminates_stutter_value; eauto. congruence. }
      eauto.
    }
    symmetry in Heq_sched.
    destruct i as [|i].
    * rewrite Heq_sched.
      inversion Hlookup; subst.
      iPoseProof (wptp_step_hd ei t with "[H]") as "Hstep"; eauto.
      rewrite Nat_iter_S.
      iMod "Hstep"; iModIntro; iNext.
      iDestruct "Hstep" as (Hred C) "Hstep".
      destruct C as [Y m f Hequiv P Ic].
      iApply step_fupd_iter_mono.
      { setoid_rewrite ivd_assoc.
        setoid_rewrite ivd_assoc.
        rewrite /projT1/projT2 in f Hequiv *.
        simpl response_type.

        rewrite -(ic_bind_iProp _ _ _ (ivdist_prim_step ei σ) _ Is0 (coupling_post φ) _); swap 1 3.
        { eapply Hequiv. }
        { eapply (irrel_coupling_support _ _ _ Ic). }
        iIntros "H". iApply "H".
      }
      erewrite (@step_fupd_iter_forall_pure_mid _ _); last first.
      { destruct (irrel_coupling_support_wit _ _ _ Ic) as ((x&y)&Hpf).
        unshelve exists. eexists (x, y). rewrite //=.
      }
      iIntros (xyS).
      destruct xyS as ((ei'&y)&HP).
      destruct ei' as [ei' σ' efs|]; last first.
      { exfalso. destruct HP as (HP&Hsupp1&?). eapply ival_red_non_stuck; eauto. }

      setoid_rewrite ivd_left_id.
      setoid_rewrite ivd_left_id.
      assert (prim_step ei σ ei' σ' efs).
      { destruct HP as (HP&Hsupp1&?); by apply ivdist_non_stuck_red; eauto. }
      assert ((∃ i Hpf, ival.ind Ic i = (exist _ (prim_res_step ei' σ' efs, y) Hpf)
                        ∧ ival.val Ic i > 0)%R) as Hsupp.
      { destruct HP as (HP&Hsupp1&?&(i0&?&?)).
        exists i0, HP; repeat split; auto. }
      iSpecialize ("Hstep" $! ei' σ' efs).
      unshelve (iSpecialize ("Hstep" $! _)).
      { eexists; eauto => //=. destruct HP; eauto. }
      iSpecialize ("Hstep" with "[% //]"). iMod "Hstep".
      iSpecialize ("IH" $! _ _ _ _ _ _ with "[%] Hstep"); last iFrame; auto.
      { rewrite //=. rewrite -app_assoc. eapply Hterm_Some; eauto.
        eapply (istep_atomic _ _ _ ei σ ei' σ' efs []); eauto; try f_equal. }
    * rewrite /ivdist_tpool_stepi.
      specialize (take_drop_middle _ _ _ Hlookup) => Hlook.
      rewrite Heq_sched. rewrite Hlookup.
      simpl in Hlookup.
      rewrite -(take_drop_middle _ _ _ Hlookup).

      iPoseProof (wptp_step_tl e _ ei with "[H]") as "Hstep"; eauto.
      rewrite Nat_iter_S.
      iMod "Hstep"; iModIntro; iNext.
      iDestruct "Hstep" as (Hred C) "Hstep".
      destruct C as [Y m f Hequiv P Ic].
      iApply step_fupd_iter_mono.
      { setoid_rewrite ivd_assoc.
        setoid_rewrite ivd_assoc.
        rewrite /projT1/projT2 in f Hequiv *.
        simpl response_type.

        rewrite -(ic_bind_iProp _ _ _ (ivdist_prim_step ei σ) _ Is0 (coupling_post φ) _); swap 1 3.
        { eapply Hequiv. }
        { eapply (irrel_coupling_support _ _ _ Ic). }
        iIntros "H". iApply "H".
      }
      erewrite (@step_fupd_iter_forall_pure_mid _ _); last first.
      { destruct (irrel_coupling_support_wit _ _ _ Ic) as ((x&y)&Hpf).
        unshelve exists. eexists (x, y). rewrite //=.
      }
      iIntros (xyS).
      destruct xyS as ((ei'&y)&HP).
      destruct ei' as [ei' σ' efs|]; last first.
      { exfalso. destruct HP as (HP&Hsupp1&?). eapply ival_red_non_stuck; eauto. }

      setoid_rewrite ivd_left_id.
      setoid_rewrite ivd_left_id.
      assert (prim_step ei σ ei' σ' efs).
      { destruct HP as (HP&Hsupp1&?); by apply ivdist_non_stuck_red; eauto. }
      assert ((∃ i Hpf, ival.ind Ic i = (exist _ (prim_res_step ei' σ' efs, y) Hpf)
                        ∧ ival.val Ic i > 0)%R) as Hsupp.
      { destruct HP as (HP&Hsupp1&?&(i0&?&?)).
        exists i0, HP; repeat split; auto. }
      iSpecialize ("Hstep" $! ei' σ' efs).
      rewrite /rsupport.
      rewrite //= in Hsupp.
      unshelve (iSpecialize ("Hstep" $! _)).
      { eexists; eauto. destruct HP; eauto. }
      iSpecialize ("Hstep" with "[% //]"). iMod "Hstep".
      repeat iMod "Hstep".
      assert (terminates sch ((tr ++ ((e :: t, σ) :: nil))
                                ++ (((seq.cat (take (S i) (e :: t))
                                              (seq.cat (ei' :: drop (S (S i)) (e :: t)) efs), σ'))
                                      :: nil)) n)
        as Hterm'.
      { rewrite //=. rewrite -app_assoc. eapply Hterm_Some; eauto.
        eapply (istep_atomic _ _ _ ei σ ei' σ' efs (take (S i) (e :: t))); eauto; try f_equal.
        - by rewrite take_drop_middle.
        - rewrite take_length_le //.
          specialize (lookup_lt_Some _ _ _ Hlookup) => //=; omega.
      }
      clear Hterm.
      iSpecialize ("IH" $! _ _ _ _ _ _ _ with "[%] Hstep"); last iFrame; auto.
      { eauto. }
      iModIntro. rewrite //= in Hlook. rewrite Hlook //=.
Qed.

End adequacy.

Class probPreG (Λ: probLanguage) Σ := ProbPreG{
  pre_probG_inG :> inG Σ (authR (optionUR (exclR (discreteC prob_state))));
}.

From iris.program_logic Require Import adequacy.
Theorem wp_prob_adequacy {Y} `{invPreG Σ} `{@probPreG Λ Σ}
        e σ φ  Is sch n:
  (∀`{Hinv: invG Σ} (* `{Hprob : probG ex va st Λ Σ} *),
      (|={⊤}=> ∃ (stateI: _ → iProp Σ) pname,
      let _ : probG' Σ := ProbG Σ Hinv pname _ in
      let _ : stateG' Λ Σ := StateG Λ Σ stateI in
      stateI σ ∗ aux_interp (existT Y Is : prob_state) ∗
             WP e {{ v, ∃ v' : Y, ownProb (mret v') ∗ ⌜φ v v'⌝ }})%I) →
  terminates sch (((e :: nil), σ) :: nil) n →
  irrel_couplingP (ivdist_tpool_stepN sch (e :: nil) σ n)
                  Is
                  (coupling_post φ).
 Proof.
   intros Hwp Hterm.
   apply ic_prop_to_wit.
   eapply (step_fupd_soundness' _ (S (S n))).
   iIntros (Hinv).
   rewrite Nat_iter_S.
   iMod (Hwp Hinv) as "Hwp".
   iDestruct "Hwp" as (Istate γ) "H".
   iDestruct "H" as "(HIstate & Ha & Hwp)".
   iApply (step_fupd_mask_mono ∅ _ _ ∅); auto. iModIntro. iNext; iModIntro.
   rewrite /ivdist_tpool_stepN.
   efeed pose proof (@wp_coupling Λ) as Hcoup; eauto; last first.
   iPoseProof (Hcoup with "[HIstate Ha Hwp]") as "H".
   { iFrame.  rewrite //=. }
   { eauto. }
   { eauto. }
Qed.

Definition coerce_cfg {Λ : probLanguage} (f: language.val Λ → R) (r: R) (ρ: cfg Λ) : R :=
  match fst ρ with
  | [] => r
  | e :: _ => match to_val e with
              | Some v => f v
              | _ => r
              end
  end.

Theorem wp_prob_adequacy' {Y} `{invPreG Σ} `{@probPreG Λ Σ}
        e σ φ  Is sch n:
  (∀`{Hinv: invG Σ},
      (|={⊤}=> ∃ (stateI: _ → iProp Σ), ∀ pname,
      let _ : probG' Σ := ProbG Σ Hinv pname _ in
      let _ : stateG' Λ Σ := StateG Λ Σ stateI in
      stateI σ ∗ (ownProb Is -∗
             WP e {{ v, ∃ (v' : Y), ownProb (mret v') ∗ ⌜φ v v'⌝ }}))%I) →
  terminates sch (((e :: nil), σ) :: nil) n →
  irrel_couplingP (ivdist_tpool_stepN sch (e :: nil) σ n)
                  Is
                  (coupling_post φ).
 Proof.
   intros Hwp Hterm.
   apply ic_prop_to_wit.
   eapply (step_fupd_soundness' _ (S (S n))).
   iIntros (Hinv).
   rewrite Nat_iter_S.
  iMod (own_alloc (● (Excl' (existT _ Is : discreteC prob_state)) ⋅
                   ◯ (Excl' (existT _ Is : discreteC prob_state))))
    as (γprob) "[Hσ Hσf]"; first done.
   iMod (Hwp Hinv) as "Hwp".
   iDestruct "Hwp" as (Istate) "H".
   iSpecialize ("H" $! γprob).
   iDestruct "H" as "(HIstate & HaHwp)".
   iApply (step_fupd_mask_mono ∅ _ _ ∅); auto. iModIntro. iNext; iModIntro.
   rewrite /ivdist_tpool_stepN.
   set (Hprob := ProbG Σ _ γprob _).
   efeed pose proof (@wp_coupling Λ _ {| stateG_interp := Istate |} Hprob) as Hcoup; eauto;
     last first.
   iPoseProof (Hcoup with "[HIstate HaHwp Hσf Hσ]") as "H".
   { rewrite /ownProb/ownProbRaw//=. iFrame.
     iSplitR "".
     * iApply ("HaHwp" with "[Hσf]").
       { iExists _; auto. }
     * rewrite //=.
   }
   { eauto. }
   { eauto. }
Qed.

Import Rbar.
From discprob.idxval Require Import extrema.

Theorem wp_prob_adequacy_Ex_max {Y} `{invPreG Σ} `{@probPreG Λ Σ}
        e σ φ (Is: pidist Y) sch f g d n:
  (∀`{Hinv: invG Σ},
      (|={⊤}=> ∃ (stateI: _ → iProp Σ), ∀ pname,
      let _ : probG' Σ := ProbG Σ Hinv pname _ in
      let _ : stateG' Λ Σ := StateG Λ Σ stateI in
      stateI σ ∗ (ownProb Is -∗
             WP e {{ v, ∃ (v' : Y), ownProb (mret v') ∗ ⌜φ v v'⌝ }}))%I) →
  (∀ v v', φ v v' → f v = g v') →
  terminates sch (((e :: nil), σ) :: nil) n →
  bounded_fun_on g (λ x, In_psupport x Is) →
  Rbar_le (extrema.Ex_ival (coerce_cfg f d) (ivdist_tpool_stepN sch [e] σ n))
          (extrema.Ex_max g Is).
Proof.
  rewrite /coerce_cfg.
  intros. apply irrel_coupling_eq_Ex_max_supp; eauto.
  eapply irrel_coupling_conseq; last eapply wp_prob_adequacy'; eauto.
  { intros x y. rewrite /coupling_post.
    destruct x as (l&?). destruct l => //=.
    destruct to_val => //=. eauto. }
Qed.

Theorem wp_prob_adequacy_Ex_min {Y} `{invPreG Σ} `{@probPreG Λ Σ}
        e σ φ (Is: pidist Y) sch f g d n:
  (∀`{Hinv: invG Σ},
      (|={⊤}=> ∃ (stateI: _ → iProp Σ), ∀ pname,
      let _ : probG' Σ := ProbG Σ Hinv pname _ in
      let _ : stateG' Λ Σ := StateG Λ Σ stateI in
      stateI σ ∗ (ownProb Is -∗
             WP e {{ v, ∃ (v' : Y), ownProb (mret v') ∗ ⌜φ v v'⌝ }}))%I) →
  (∀ v v', φ v v' → f v = g v') →
  terminates sch (((e :: nil), σ) :: nil) n →
  bounded_fun_on g (λ x, In_psupport x Is) →
  Rbar_le (extrema.Ex_min g Is)
          (extrema.Ex_ival (coerce_cfg f d) (ivdist_tpool_stepN sch [e] σ n)).
Proof.
  rewrite /coerce_cfg.
  intros. apply irrel_coupling_eq_Ex_min_supp; eauto.
  eapply irrel_coupling_conseq; last eapply wp_prob_adequacy'; eauto.
  { intros x y. rewrite /coupling_post.
    destruct x as (l&?). destruct l => //=.
    destruct to_val => //=. eauto. }
 Qed.

Theorem wp_prob_adequacy_ex_Ex {Y} `{invPreG Σ} `{@probPreG Λ Σ}
        e σ φ (Is: pidist Y) sch f g d n:
  (∀`{Hinv: invG Σ},
      (|={⊤}=> ∃ (stateI: _ → iProp Σ), ∀ pname,
      let _ : probG' Σ := ProbG Σ Hinv pname _ in
      let _ : stateG' Λ Σ := StateG Λ Σ stateI in
      stateI σ ∗ (ownProb Is -∗
             WP e {{ v, ∃ (v' : Y), ownProb (mret v') ∗ ⌜φ v v'⌝ }}))%I) →
  (∀ v v', φ v v' → f v = g v') →
  terminates sch (((e :: nil), σ) :: nil) n →
  bounded_fun_on g (λ x, In_psupport x Is) →
  ex_Ex_ival (coerce_cfg f d) (ivdist_tpool_stepN sch [e] σ n).
Proof.
  rewrite /coerce_cfg.
  intros. eapply irrel_coupling_eq_ex_Ex_supp; eauto.
  eapply irrel_coupling_conseq; last eapply wp_prob_adequacy'; eauto.
  { intros x y. rewrite /coupling_post.
    destruct x as (l&?). destruct l => //=.
    destruct to_val => //=. eauto. }
 Qed.

Theorem wp_prob_safety_adequacy Σ Λ `{invPreG Σ} `{@probPreG Λ Σ} {X} (Is: pidist X) s e σ φ :
  (∀ `{Hinv : invG Σ},
     (|={⊤}=> ∃ (stateI : state Λ → iProp Σ), ∀ pname,
      let _ : probG' Σ := ProbG Σ Hinv pname _ in
      let _ : stateG' Λ Σ := StateG Λ Σ stateI in
      stateI σ ∗ (ownProb Is -∗
                          WP e @ s; ⊤ {{ v, ⌜φ v⌝ }}))%I) →
  adequate s e σ φ.
Proof.
  intros Hwp; eapply (wp_adequacy _ _); iIntros (?) "".
  iMod (own_alloc (● (Excl' (existT _ Is : discreteC prob_state)) ⋅
                   ◯ (Excl' (existT _ Is : discreteC prob_state))))
    as (γprob) "[Hσ Hσf]"; first done.
  iMod Hwp as (stateI) "Hwp".
  iModIntro. iExists stateI.
  set (Hprob := ProbG Σ Hinv γprob _).
  set (irisG' := @probG_irisG _ Hprob _ {| stateG_interp := stateI |}).
  iExists aux_state, aux_interp, choice_type, response_type, step_interpR.
  iExists step_to_aux, response_inhabited.
  iExists (existT _ Is : prob_state).
  iDestruct ("Hwp" $! γprob) as "($&Hwp)". iFrame.
  iSpecialize ("Hwp" with "[Hσf]").
  { rewrite /ownProb/ownProbRaw; iExists _; iFrame. auto. }
  auto.
Qed.


Require Import Integers.
Require Import Coqlib.
Require Import Maps.

Require Import Hardware.
Require Import ChipTactics.

Import ListNotations.
Import Int.

Definition SimpleSkipper :=
  [(Imovb v0 (Int.repr 4));
   (Iskeqb v0 (Int.repr 4));
   (Imovb v0 (Int.repr 8));
   (Icls)].

Lemma SimpleSkipper_is_ok:
  exists n M IM RF St,
  Run SimpleSkipper n = Fine M IM RF St /\
  RF#v0 = (repr 4).
Proof.
  exists 3%nat. unfold SimpleSkipper. simpl_code. dec_eq_try.
  deal_with_eq. dec_eq_try.
  Fine_eq. intuition. dec_eq_try.
  reflexivity.
Qed.