(* En este archivo se demuestra la corrección de la acción grant*)
Require Export Exec.
Require Export Implementacion.
Require Export AuxFunsCorrect.
Require Export ListAuxFuns.
Require Import Classical.
Require Import Estado.
Require Import DefBasicas.
Require Import EqTheorems.
Require Import Semantica.
Require Import RuntimePermissions.
Require Import Operaciones.
Require Import ErrorManagement.
Require Import Maps.
Require Import Tacticas.
Require Import ValidStateLemmas.

Section Grant.

Lemma postGrantCorrect : forall (s:System) (a:idApp) (p:Perm), (pre (grant p a) s) -> validstate s -> post_grant p a s (grant_post p a s).
Proof.
    intros.
    unfold post_grant.
    split. simpl; auto.
    simpl in H.
    unfold pre_grant in H;simpl in H.
    destruct H.

    split.
    destruct H.
    destruct H.
    assert (In a (apps (state s)) \/ (exists sysapp:SysImgApp, In sysapp (systemImage (environment s)) /\ idSI sysapp = a)).
    destruct H.
    left.
    apply (ifManifestThenInApps s H0 a x);auto.
    right.
    destruct H.
    destruct_conj H.
    exists x0;auto.
    assert (exists v, map_apply idApp_eq (perms (state s)) a = Value idApp v).
    apply (ifInAppsOrSysAppThenPerms);auto.
    destruct H4.
    unfold grantPerm.
    unfold grant_post;unfold grantPermission;simpl.
    rewrite H4.
    split;intros.
    elim (classic (a=a'));intros.

    exists (p::x0).
    split.
    rewrite H6.
    rewrite<- (addAndApply idApp_eq a' (p::x0) (perms (state s))).
    auto.
    rewrite H6 in H4.
    rewrite H4 in H5.
    assert (x0=lPerm).
    inversion H5.
    auto.
    intros.
    rewrite H7.
    apply in_cons.
    auto.

    exists lPerm.
    split.
    rewrite overrideNotEq; auto.
    intros.
    auto.

    split;intros.
    elim (classic (a=a'));intro.

    exists x0.
    split.
    rewrite H6 in H4.
    auto.
    intros.
    split;auto.
    rewrite H6 in H5.
    rewrite <-(addAndApply idApp_eq a' (p::x0) (perms (state s))) in H5.
    inversion H5.
    rewrite <-H10 in H7.
    inversion H7.
    auto.
    contradiction.

    exists lPerm'.
    rewrite overrideNotEq in H5.
    split;auto.
    intros;contradiction.
    auto.
    split.
    exists (p::x0).
    split.
    symmetry.
    apply addAndApply.
    apply in_eq.
    apply addPreservesCorrectness.
    apply permsCorrect;auto.

    split.
    - intros.
      (* Vamos a necesitar la información que está en la última conjunción de H1 *)
      destruct H1 as [_ [_ [_ H1]]].
      destruct H1.
      (* En este caso tenemos un absurdo *)
      rewrite H1 in H2. inversion H2.
      (* Caso interesante *)
      destruct H1 as [g' [lGroup [H1 [H3 H4]]]].
      unfold grantPermGroup, grant_post.
      rewrite H2. simpl.
      unfold grantPermissionGroup.
      rewrite H3.
      split.
      (* Acá empezamos a probar las conjunciones que forman grantPermGroup *)
      (* Primer conjunción *)
      intros a' lGroup' H5. simpl.
      elim (classic (a = a')); intros.
      (* Caso a=a' *)
   -- rewrite H6.
      rewrite <- addAndApply. exists (g :: lGroup).
      split. auto.
      intros g'' H7. simpl.
      rewrite <- H6 in H5. rewrite H3 in H5.
      inversion H5. auto.
      (* Caso a<>a' *)
   -- exists lGroup'.
      split. rewrite overrideNotEq; auto.
      intros. auto.
      (* Segunda conjunción *)
   -- split.
  --- intros a' lGroup' H5.
      elim (classic (a = a')); intros.
      (* Caso a=a' *)
      exists lGroup.
      split. rewrite <- H6. auto.
      intros g'' H7 H8.
      rewrite <- H6 in H5.
      rewrite <- addAndApply in H5.
      inversion H5.
      rewrite <- H10 in H7.
      destruct H7. auto. contradiction.
      (* Caso a <> a' *)
      exists lGroup'.
      rewrite overrideNotEq in H5.
      split. auto.
      intros. contradiction.
      auto.
  --- split. exists (g :: lGroup).
      split. symmetry. apply addAndApply.
      simpl. auto.
      apply addPreservesCorrectness.
      apply grantedPermGroupsCorrect;auto.
    - split.
      intro notGrouped.
      destruct H1 as [_ [_ [_ H1]]].
      destruct H1.
   -- unfold grant_post. simpl. rewrite notGrouped. auto.
   -- destruct H1 as [g [lGroup [H2 [H3 H4]]]].
      rewrite notGrouped in H2. inversion H2.
   -- repeat (split;auto).
Qed.

Lemma existsManifest : forall (a: idApp) (s: System) (p: Perm),
  negb (InBool Perm Perm_eq p (permsInUse a s)) = false ->
    exists m : Manifest, isManifestOfApp a m s /\ In p (use m).
Proof.
  intros a s p H.
  rewrite negb_false_iff in H.
  unfold InBool in H.
  rewrite existsb_exists in H.
  destruct H as [perm H].
  destruct H as [H H0].
  unfold permsInUse in H.

  unfold isManifestOfApp.
  case_eq (map_apply idApp_eq (manifest (environment s)) a); intros m H1; rewrite H1 in *.
  exists m.
  destruct Perm_eq in H0.
  rewrite e.
  split;auto.
  discriminate H0.

  case_eq ((map (fun sysapp : SysImgApp => use (manifestSI sysapp)) (filter (fun sysapp : SysImgApp => if idApp_eq a (idSI sysapp) then true else false) (systemImage (environment s)))));intros; rewrite H2 in *;simpl in H.
  destruct H.
  assert (In l (map (fun sysapp : SysImgApp => use (manifestSI sysapp)) (filter (fun sysapp : SysImgApp => if idApp_eq a (idSI sysapp) then true else false) (systemImage (environment s))))).
  rewrite H2.
  apply in_eq.
  rewrite in_map_iff in H3.
  destruct H3 as [sysImg H3].
  destruct H3.
  exists (manifestSI sysImg).
  split.
  right.
  exists sysImg.
  rewrite filter_In in H4.
  destruct H4.
  destruct idApp_eq in H5.
  rewrite e;auto.
  discriminate H5.
  destruct Perm_eq in H0.
  rewrite e.
  rewrite H3 in *.
  auto.
  discriminate H0.
Qed.

Lemma notPreGrantThenError : forall (s:System) (a:idApp) (p:Perm), ~(pre (grant p a) s) -> validstate s -> exists ec : ErrorCode, response (step s (grant p a)) = error ec /\ ErrorMsg s (grant p a) ec /\ s = system (step s (grant p a)).
Proof.
    intros.
    simpl.
    simpl in H.
    unfold pre_grant in H.
    unfold grant_safe.
    unfold grant_pre.

    case_eq (negb (InBool Perm Perm_eq p (permsInUse a s)));intros.
    exists perm_not_in_use.
    split;auto.
    split;auto.
    rewrite negb_true_iff in H1.
    invertBool H1.
    intro.
    apply H1.
    destruct H2.
    unfold InBool.
    rewrite existsb_exists.
    exists p.
    unfold permsInUse.
    destruct H2.
    rewrite H2.
    destruct Perm_eq;auto.

    case_eq (negb (InBool Perm Perm_eq p (getAllPerms s)));intros.
    exists no_such_perm.
    split;auto.
    split;auto.
    rewrite negb_true_iff in H2.
    invertBool H2.
    intro;apply H2.
    unfold getAllPerms.
    unfold InBool.
    rewrite existsb_exists.
    exists p.
    rewrite in_app_iff.
    split.
    destruct H3.
    left.
    apply isSysPermCorrect;auto.
    right.
    apply inUsrDefPermsIff;auto.
    destruct Perm_eq;auto.

    case_eq (InBool Perm Perm_eq p (grantedPermsForApp a s));intros.
    exists perm_already_granted.
    split;auto.
    split;auto.
    unfold InBool in H3.
    rewrite existsb_exists in H3.
    destruct H3.
    destruct H3.
    unfold grantedPermsForApp in H3.
    case_eq (map_apply idApp_eq (perms (state s)) a);intros; rewrite H5 in H3.
    exists l.
    destruct Perm_eq in H4.
    rewrite e;auto.
    discriminate H4.
    inversion H3.
    case_eq ((if permLevel_eq (pl p) dangerous then false else true));intros.
    exists perm_not_dangerous.
    split;auto.
    split;auto.
    destruct permLevel_eq in H4.
    discriminate H4.
    auto.

    case_eq (groupIsGranted a p s); intros.
    exists perm_should_auto_grant. simpl.
    split; auto.
    unfold groupIsGranted in H5.
    case (maybeGrp p) in *.
    case (map_apply idApp_eq (grantedPermGroups (state s)) a) in *.
    split.
  - unfold InBool in H5.
    rewrite existsb_exists in H5.
    destruct H5 as [g [H5 H6]].
    exists g, l.
    destruct idGrp_eq in H6. rewrite e.
    auto. inversion H6.
  - auto.
  - inversion H5.
  - inversion H5.
  - destruct H.
    split.
    apply existsManifest; auto.

    split.
    rewrite negb_false_iff in H2.
    unfold InBool in H2.
    rewrite existsb_exists in H2.
    destruct H2.
    destruct H.
    destruct Perm_eq in H2.
    rewrite e.
    unfold getAllPerms in H.
    rewrite in_app_iff in H.
    destruct H.
    left.
    apply isSysPermCorrect;auto.
    right.
    apply inUsrDefPermsIff;auto.
    discriminate H2.
    split.
    invertBool H3.
    intro;apply H3.
    unfold InBool.
    rewrite existsb_exists.
    exists p.
    destruct H.
    destruct H.
    unfold grantedPermsForApp.
    rewrite H.
    destruct Perm_eq;auto.
    split.
    destruct permLevel_eq in H4.
    auto.
    discriminate H4.
    unfold groupIsGranted in H5.
    destruct (maybeGrp p).
 -- right.
    case_eq (map_apply idApp_eq (grantedPermGroups (state s)) a);intros.
--- rewrite H in H5.
    exists i, l.
    repeat split; auto.
    unfold InBool in H5.
    clear H. induction l;unfold not; intros.
    inversion H.
    simpl in H, H5.
    destruct (idGrp_eq i a0); simpl in H5.
    inversion H5.
    destruct H. symmetry in H. contradiction.
    apply IHl in H5. contradiction.
--- clear H5.
    apply existsManifest in H1.
    destruct H1 as [m [H1 _]].
    assert (vs:= H0).
    destructVS H0.
    destructSC statesConsistencyVS a.
    destruct grantedPermGroupsSC.
    assert (exists l : list idGrp,
       map_apply idApp_eq (grantedPermGroups (state s)) a = Value idApp l).
    destruct H1. clear mfstSC certSC defPermsSC permsSC.
    apply ifManifestThenInApps in H1; auto.
    apply H0. right. destruct H1 as [sysImg [H6 [H7 H8]]].
    exists sysImg; auto.
    destruct H6. rewrite H in H6. inversion H6.
 -- left. auto.
Qed.

Lemma grantIsSound : forall (s:System) (a:idApp) (p:Perm),
        validstate s -> exec s (grant p a) (system (step s (grant p a))) (response (step s (grant p a))).
Proof.
    intros.
    unfold exec.
    split.
    auto.
    elim (classic (pre (grant p a) s));intro.
    left.
    assert(grant_pre p a s = None).
    unfold grant_pre.
    destruct H0.

    assert (InBool Perm Perm_eq p (permsInUse a s) = true).
    unfold InBool.
    rewrite existsb_exists.
    exists p.
    split.
    destruct H0.
    destruct H0.
    unfold permsInUse.
    destruct H0.
    rewrite H0.
    auto.
    case_eq (map_apply idApp_eq (manifest (environment s)) a);intros.
    apply ifManifestThenInApps in H3;auto.
    destruct H0.
    assert (~(In a (apps (state s)) /\ In x0 (systemImage (environment s)) /\ idSI x0 = a)).
    apply sysAppInApps;auto.
    destruct_conj H0.
    destruct H4;auto.
    destruct H0.
    destruct_conj H0.
    assert (In x0 (filter (fun sysapp : SysImgApp => if idApp_eq a (idSI sysapp) then true else false) (systemImage (environment s)))).
    rewrite filter_In.
    rewrite H0.
    destruct idApp_eq;auto.
    remember (fun sysapp : SysImgApp => use (manifestSI sysapp)) as theFun.
    remember (filter (fun sysapp : SysImgApp => if idApp_eq a (idSI sysapp) then true else false) (systemImage (environment s))) as theList.
    assert ((hd nil (map theFun theList)) = theFun (hd defaultSysApp theList )).
    apply ifNotNilHdMap.
    apply inNotNilExists.
    exists x0;auto.
    rewrite H7.
    rewrite HeqtheFun.
    assert ((hd defaultSysApp theList)=x0).
    rewrite HeqtheList in H5.
    assert (exists x0, In x0 (filter (fun sysapp : SysImgApp => if idApp_eq a (idSI sysapp) then true else false) (systemImage (environment s)))).
    exists x0;auto.
    apply ifExistsFilter with (dflt:=defaultSysApp) in H8.
    rewrite HeqtheList.
    remember (hd defaultSysApp (filter (fun sysapp : SysImgApp => if idApp_eq a (idSI sysapp) then true else false) (systemImage (environment s)))) as theHead.
    destruct H8.
    apply (notDupSysAppVS s);auto.
    rewrite H0 in *.
    destruct idApp_eq in H9;auto.
    discriminate H9.

    rewrite H8;rewrite H6;auto.

    destruct Perm_eq.
    auto.
    auto.
    rewrite H2.
    assert (negb true=false).
    rewrite negb_false_iff;auto.
    rewrite H3.

    assert (InBool Perm Perm_eq p (getAllPerms s) = true).
    unfold InBool.
    rewrite existsb_exists.
    exists p.
    split.
    destruct H1.
    unfold getAllPerms.
    apply in_app_iff.
    destruct H1.
    left.
    apply isSysPermCorrect;auto.
    right.
    unfold usrDefPerms.
    apply in_concat.
    unfold usrDefPerm in H1.
    destruct H1.
    destruct H1.
    destruct H1.
    destruct H1.
    exists x0.
    split.
    apply in_app_iff.
    left.
    apply inGetValuesBack.
    exists (map_apply idApp_eq (defPerms (environment s)) x).
    split.
    apply in_map_iff.
    exists x.
    split.
    auto.
    apply (ifDefPermsThenInApps s H x x0);auto.
    auto.
    auto.
    destruct H1.
    destruct H1.
    exists (defPermsSI x).
    split.
    apply in_app_iff.
    right.
    apply in_map_iff.
    exists x.
    split;auto.
    auto.
    destruct Perm_eq.
    auto.
    destruct n;auto.
    rewrite H4.
    assert (negb true=false).
    rewrite negb_false_iff;auto.
    rewrite H3.

    assert (InBool Perm Perm_eq p (grantedPermsForApp a s) <> true).
    unfold InBool.
    unfold not;intros.
    rewrite existsb_exists in H6.
    destruct H6.
    destruct H6.
    destruct H1.
    apply H8.
    unfold grantedPermsForApp in H6.
    case_eq (map_apply idApp_eq (perms (state s)) a);intros; rewrite H9 in H6.
    exists l.
    destruct Perm_eq in H7.
    rewrite<- e in H6.
    split;auto.
    discriminate H7.
    destruct H6.
    rewrite not_true_iff_false in H6.
    rewrite H6.
    destruct_conj H1.
    destruct permLevel_eq.
    unfold groupIsGranted.
    destruct H10.
    rewrite H9. auto.
    destruct H9 as [g [lGroup [H9 [H10 H11]]]].
    rewrite H9. rewrite H10.
    case_eq (InBool idGrp idGrp_eq g lGroup); intros.
    unfold InBool in H12.
    rewrite existsb_exists in H12.
    destruct H12 as [g' [H12 H13]].
    destruct (idGrp_eq g g').

    rewrite <- e0 in H12. contradiction.

    inversion H13.

    auto.

    contradiction.

    unfold step;simpl.
    unfold grant_safe;simpl.
    rewrite H1;simpl.
    split;auto.
    split;auto.
    apply postGrantCorrect;auto.
    right.
    apply (notPreGrantThenError);auto.
Qed.
End Grant.


Require Import Platform.Cito.CompileStmtSpec.
Require Import Bedrock.StringSet.
Import StringSet.
Require Import Platform.Cito.FreeVars.
Require Import Platform.Cito.SynReqFactsUtil.

Local Infix ";;" := Syntax.Seq (right associativity, at level 95).

Local Hint Resolve Subset_singleton.
Local Hint Resolve In_to_set.
Local Hint Resolve to_set_In.
Local Hint Resolve Subset_union_right Max.max_lub.

Require Platform.Cito.CompileExpr Platform.Cito.CompileExprs Platform.Cito.SaveRet.

Ltac t := unfold syn_req, CompileExpr.syn_req, CompileExprs.syn_req, SaveRet.syn_req,
  in_scope, WellFormed.wellformed;
  simpl; intuition;
    repeat (match goal with
              | [ H : Subset _ _ |- _ ] => apply Subset_union_left in H
              | [ H : (max _ _ <= _)%nat |- _ ] =>
                generalize (Max.max_lub_l _ _ _ H);
                  generalize (Max.max_lub_r _ _ _ H);
                    clear H
              | [ H : WellFormed.args_not_too_long _ |- _ ] => inversion_clear H; []
              | [ |- match ?E with Some _ => _ | None => _ end ] => destruct E
            end; intuition).

Local Hint Constructors WellFormed.args_not_too_long.

Lemma Subset_syn_req_In : forall x vars temp_size s, syn_req vars temp_size s -> Subset (singleton x) (free_vars s) -> List.In x vars.
  t.
Qed.

Lemma syn_req_Seq_Seq : forall vars temp_size a b c, syn_req vars temp_size ((a ;; b) ;; c) -> syn_req vars temp_size (a ;; b ;; c).
  t.
Qed.

Lemma syn_req_Seq : forall vars temp_size a b c, syn_req vars temp_size ((a ;; b) ;; c) -> syn_req vars temp_size (b ;; c).
  t.
Qed.

Lemma syn_req_If_true : forall vars temp_size e t f k, syn_req vars temp_size (Syntax.If e t f ;; k) -> syn_req vars temp_size (t ;; k).
  t.
Qed.

Lemma syn_req_If_false : forall vars temp_size e t f k, syn_req vars temp_size (Syntax.If e t f ;; k) -> syn_req vars temp_size (f ;; k).
  t.
Qed.

Lemma syn_req_If_e : forall vars temp_size e t f k, syn_req vars temp_size (Syntax.If e t f ;; k) -> CompileExpr.syn_req vars temp_size e 0.
  t.
Qed.

Lemma syn_req_While_e : forall vars temp_size e s k, syn_req vars temp_size (Syntax.While e s ;; k) -> CompileExpr.syn_req vars temp_size e 0.
  t.
Qed.

Lemma syn_req_While : forall vars temp_size e s k, syn_req vars temp_size (Syntax.While e s ;; k) -> syn_req vars temp_size (s ;; Syntax.While e s ;; k).
  t.
Qed.

Lemma syn_req_Call_f : forall vars temp_size x f args k, syn_req vars temp_size (Syntax.Call x f args ;; k) -> CompileExpr.syn_req vars temp_size f 0.
  t.
Qed.

Local Hint Resolve Max.le_max_l Max.le_max_r.

Lemma max_more : forall n m k,
  (n <= m)%nat
  -> (n <= max m k)%nat.
  intros; transitivity m; eauto.
Qed.

Local Hint Resolve max_more.

Require Import Coq.Lists.List.

Lemma args_bound' : forall x args,
  In x args
  -> (DepthExpr.depth x <= fold_right max 0 (map DepthExpr.depth args))%nat.
  induction args; simpl; intuition (subst; auto).
  eapply Le.le_trans; [ | eapply Max.le_max_r]; eauto.
Qed.

Lemma args_bound : forall args,
  List.Forall (fun e => (DepthExpr.depth e <= CompileExprs.depth args)%nat) args.
  intros; apply Forall_forall; intros.
  apply args_bound'; auto.
Qed.

Local Hint Resolve args_bound.

Lemma syn_req_Call_args : forall vars temp_size x f args k, syn_req vars temp_size (Syntax.Call x f args ;; k) -> CompileExprs.syn_req vars temp_size args args 0.
  t.
Qed.

Lemma syn_req_Call_ret : forall vars temp_size x f args k, syn_req vars temp_size (Syntax.Call x f args ;; k) -> SaveRet.syn_req vars x.
  t.
Qed.

Require Import Platform.AutoSep.

Lemma syn_req_goodSize : forall vars temp_size x f args k, syn_req vars temp_size (Syntax.Call x f args ;; k) -> goodSize (2 + List.length args).
  t.
Qed.

Lemma syn_req_Seq_Skip : forall vars temp_size s, syn_req vars temp_size s -> syn_req vars temp_size (s ;; Syntax.Skip).
  t.
Qed.


Require Import floyd.proofauto.
Require Import progs.logical_compare.
Instance CompSpecs : compspecs.
Proof. make_compspecs prog. Defined.

(****  START *)

Definition logical_and_result v1 v2 : int :=
   if Int.eq v1 Int.zero then Int.zero else v2.

Definition logical_or_result v1 v2 : int :=
  if Int.eq v1 Int.zero then v2 else Int.one.

Fixpoint quick_shortcut_logical (s: statement) : option ident :=
match s with
| Sifthenelse _
     (Sset id (Econst_int _ (Tint I32 Signed {| attr_volatile := false; attr_alignas := None |})))
     s2 => match quick_shortcut_logical s2 with None => None | Some id2 =>
                 if ident_eq id id2 then Some id else None
                end
| Sifthenelse e1 s2
     (Sset id (Econst_int _ (Tint I32 Signed {| attr_volatile := false; attr_alignas := None |})))
      => match quick_shortcut_logical s2 with None => None | Some id2 =>
                 if ident_eq id id2 then Some id else None
            end
| Sset id (Ecast _ (Tint IBool Unsigned {| attr_volatile := false; attr_alignas := None |})) =>
        Some id
| _ => None
end.

Fixpoint shortcut_logical (eval: expr -> option val) (tid: ident) (s: statement)
            : option (int * list expr) :=
match s with
| Sifthenelse e1
     (Sset id (Econst_int one (Tint I32 Signed {| attr_volatile := false; attr_alignas := None |})))
     s2 => if andb (eqb_ident id tid) (Int.eq one Int.one)
                then match eval e1 with
                        | Some (Vint v1) =>
                           match shortcut_logical eval tid s2 with
                           | Some (v2, el) => Some (logical_or_result v1 v2, e1 :: el)
                           | _ => None
                           end
                        | _ => None
                        end
                else None
| Sifthenelse e1 s2
     (Sset id (Econst_int zero (Tint I32 Signed {| attr_volatile := false; attr_alignas := None |})))
      => if andb (eqb_ident id tid) (Int.eq zero Int.zero)
            then match eval e1 with
                     | Some (Vint v1) =>
                      match shortcut_logical eval tid s2 with
                      | Some (v2, el) => Some (logical_and_result v1 v2, e1 :: el)
                      | _ => None
                      end
                   | _ => None
                end
            else None
| Sset id (Ecast e (Tint IBool Unsigned {| attr_volatile := false; attr_alignas := None |})) =>
        if eqb_ident id tid
        then match eval (Ecast e tbool) with
                 | Some (Vint v) => Some (v, (Ecast e tbool :: nil))
                 | _ => None
                end
        else None
| _ => None
end.

Lemma semax_shortcut_logical:
  forall Espec {cs: compspecs} Delta P Q R tid s v Qtemp Qvar el,
   quick_shortcut_logical s = Some tid ->
   typeof_temp Delta tid = Some tint ->
   local2ptree Q = (Qtemp, Qvar, nil, nil) ->
   Qtemp ! tid = None ->
   shortcut_logical (msubst_eval_expr Qtemp Qvar) tid s = Some (v, el) ->
   ENTAIL Delta, PROPx P (LOCALx Q (SEPx R)) |-- fold_right (fun e q => tc_expr Delta e && q) TT el ->
   @semax cs Espec Delta (PROPx P (LOCALx Q (SEPx R)))
          s (normal_ret_assert (PROPx P (LOCALx (temp tid (Vint v) :: Q) (SEPx R)))).
Admitted.

(***** END *)

Definition do_or_spec :=
 DECLARE _do_or
  WITH a: int, b : int
  PRE [ _a OF tbool, _b OF tbool ]
        PROP () LOCAL (temp _a (Vint a); temp _b (Vint b)) SEP ()
  POST [ tbool ]
        PROP() LOCAL (temp ret_temp (Vint (logical_or_result a b)))
        SEP().

Definition do_and_spec :=
 DECLARE _do_and
  WITH a: int, b : int
  PRE [ _a OF tbool, _b OF tbool ]
        PROP () LOCAL (temp _a (Vint a); temp _b (Vint b)) SEP ()
  POST [ tbool ]
        PROP() LOCAL (temp ret_temp (Vint (logical_and_result a b)))
        SEP().

Definition main_spec :=
 DECLARE _main
  WITH u : unit
  PRE  [] main_pre prog nil u
  POST [ tint ] main_post prog nil u.

Definition Vprog : varspecs := nil.

Definition Gprog : funspecs :=
      ltac:(with_library prog [do_or_spec; do_and_spec; main_spec]).

Ltac do_semax_shortcut_logical :=
 eapply semax_shortcut_logical;
   [ reflexivity | reflexivity | prove_local2ptree
   | reflexivity | reflexivity
   | unfold fold_right; entailer  ].

Lemma body_do_or: semax_body Vprog Gprog f_do_or do_or_spec.
Proof.
start_function.

eapply semax_seq'; [do_semax_shortcut_logical | abbreviate_semax].
forward.
destruct H,H0; subst; simpl; entailer!.
Qed.

Lemma body_do_and: semax_body Vprog Gprog f_do_and do_and_spec.
Proof.
start_function.
eapply semax_seq'; [do_semax_shortcut_logical | abbreviate_semax].
forward.
destruct H,H0; subst; simpl; entailer!.
Qed.

Lemma body_main:  semax_body Vprog Gprog f_main main_spec.
Proof.
start_function.
forward.
Qed.

Existing Instance NullExtension.Espec.

Lemma all_funcs_correct:
  semax_func Vprog Gprog (prog_funct prog) Gprog.
Proof.
unfold Gprog, prog, prog_funct; simpl.
semax_func_cons body_do_or.
semax_func_cons body_do_and.
semax_func_cons body_main.
Qed.


Require Import CoqlibC Maps.
Require Import ValuesC.
Require Import LocationsC Stacklayout Conventions.
Require Import MemoryC Integers AST.
(** newly added **)
Require Import Asm.
Require Import Locations.
Require Mach.

Set Implicit Arguments.

Lemma to_mreg_injective
      pr0 pr1
      (SOME: is_some ((to_mreg pr0)))
      (EQ: (to_mreg pr0) = (to_mreg pr1)):
    <<EQ: pr0 = pr1>>.
Proof. destruct pr0; ss; destruct pr1; ss; des_ifs. Qed.

Lemma preg_of_injective
      mr0 mr1
      (EQ: preg_of mr0 = preg_of mr1):
    <<EQ: mr0 = mr1>>.
Proof. destruct mr0, mr1; ss. Qed.

Lemma to_mreg_to_preg: forall pr0,
    o_map ((to_mreg pr0)) (to_preg) = Some pr0 \/ (to_mreg pr0) = None.
Proof. destruct pr0; ss; des_ifs; eauto. Qed.

Corollary to_mreg_some_to_preg
      pr0 mr0
      (SOME: (to_mreg pr0) = Some mr0):
    <<EQ: (to_preg mr0) = pr0>>.
Proof.
  eapply to_mreg_injective with (pr0 := (to_preg mr0)) (pr1 := pr0).
  { rewrite to_preg_to_mreg; ss. }
  rewrite to_preg_to_mreg; ss.
Qed.

Definition to_pregset (mrs: Mach.regset): regset :=
  fun pr =>
    match (to_mreg pr) with
    | Some mr => mrs mr
    | None => Vundef
    end.

Definition to_mregset (prs: regset): Mach.regset :=
  fun mr => prs (to_preg mr).

Lemma to_mreg_preg_of
      pr mr
      (MR: Asm.to_mreg pr = Some mr):
    <<PR: preg_of mr = pr>>.
Proof. destruct mr, pr; ss; des_ifs. Qed.


(*(*
 * Vericert: Verified high-level synthesis.
 * Copyright (C) 2020 Yann Herklotz <yann@yannherklotz.com>
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program.  If not, see <https://www.gnu.org/licenses/>.
 *)

(* begin hide *)
From bbv Require Import Word.
From bbv Require HexNotation WordScope.
From Coq Require Import ZArith.ZArith FSets.FMapPositive Lia.
From compcert Require Import lib.Integers common.Values.
From vericert Require Import Vericertlib.
(* end hide *)

(** * Value

A [value] is a bitvector with a specific size. We are using the implementation
of the bitvector by mit-plv/bbv, because it has many theorems that we can reuse.
However, we need to wrap it with an [Inductive] so that we can specify and match
on the size of the [value]. This is necessary so that we can easily store
[value]s of different sizes in a list or in a map.

Using the default [word], this would not be possible, as the size is part of the type. *)

Record value : Type :=
  mkvalue {
    vsize: nat;
    vword: word vsize
  }.

(** ** Value conversions

Various conversions to different number types such as [N], [Z], [positive] and
[int], where the last one is a theory of integers of powers of 2 in CompCert. *)

Definition wordToValue : forall sz : nat, word sz -> value := mkvalue.

Definition valueToWord : forall v : value, word (vsize v) := vword.

Definition valueToNat (v :value) : nat :=
  wordToNat (vword v).

Definition natToValue sz (n : nat) : value :=
  mkvalue sz (natToWord sz n).

Definition valueToN (v : value) : N :=
  wordToN (vword v).

Definition NToValue sz (n : N) : value :=
  mkvalue sz (NToWord sz n).

Definition ZToValue (s : nat) (z : Z) : value :=
  mkvalue s (ZToWord s z).

Definition valueToZ (v : value) : Z :=
  wordToZ (vword v).

Definition uvalueToZ (v : value) : Z :=
  uwordToZ (vword v).

Definition posToValue sz (p : positive) : value :=
  ZToValue sz (Zpos p).

Definition posToValueAuto (p : positive) : value :=
  let size := Pos.to_nat (Pos.size p) in
  ZToValue size (Zpos p).

Definition valueToPos (v : value) : positive :=
  Z.to_pos (uvalueToZ v).

Definition intToValue (i : Integers.int) : value :=
  ZToValue Int.wordsize (Int.unsigned i).

Definition valueToInt (i : value) : Integers.int :=
  Int.repr (uvalueToZ i).

Definition ptrToValue (i : Integers.ptrofs) : value :=
  ZToValue Ptrofs.wordsize (Ptrofs.unsigned i).

Definition valueToPtr (i : value) : Integers.ptrofs :=
  Ptrofs.repr (uvalueToZ i).

Definition valToValue (v : Values.val) : option value :=
  match v with
  | Values.Vint i => Some (intToValue i)
  | Values.Vptr b off => if Z.eqb (Z.modulo (uvalueToZ (ptrToValue off)) 4) 0%Z
                         then Some (ptrToValue off)
                         else None
  | Values.Vundef => Some (ZToValue 32 0%Z)
  | _ => None
  end.

(** Convert a [value] to a [bool], so that choices can be made based on the
result. This is also because comparison operators will give back [value] instead
of [bool], so if they are in a condition, they will have to be converted before
they can be used. *)

Definition valueToBool (v : value) : bool :=
  negb (weqb (@wzero (vsize v)) (vword v)).

Definition boolToValue (sz : nat) (b : bool) : value :=
  natToValue sz (if b then 1 else 0).

(** ** Arithmetic operations *)

Definition unify_word (sz1 sz2 : nat) (w1 : word sz2): sz1 = sz2 -> word sz1.
intros; subst; assumption. Defined.

Lemma unify_word_unfold :
  forall sz w,
  unify_word sz sz w eq_refl = w.
Proof. auto. Qed.

Definition value_eq_size:
  forall v1 v2 : value, { vsize v1 = vsize v2 } + { True }.
Proof.
  intros; destruct (Nat.eqb (vsize v1) (vsize v2)) eqn:?.
  left; apply Nat.eqb_eq in Heqb; assumption.
  right; trivial.
Defined.

Definition map_any {A : Type} (v1 v2 : value) (f : word (vsize v1) -> word (vsize v1) -> A)
           (EQ : vsize v1 = vsize v2) : A :=
    let w2 := unify_word (vsize v1) (vsize v2) (vword v2) EQ in
    f (vword v1) w2.

Definition map_any_opt {A : Type} (sz : nat) (v1 v2 : value) (f : word (vsize v1) -> word (vsize v1) -> A)
  : option A :=
  match value_eq_size v1 v2 with
  | left EQ =>
    Some (map_any v1 v2 f EQ)
  | _ => None
  end.

Definition map_word (f : forall sz : nat, word sz -> word sz) (v : value) : value :=
  mkvalue (vsize v) (f (vsize v) (vword v)).

Definition map_word2 (f : forall sz : nat, word sz -> word sz -> word sz) (v1 v2 : value)
           (EQ : (vsize v1 = vsize v2)) : value :=
    let w2 := unify_word (vsize v1) (vsize v2) (vword v2) EQ in
    mkvalue (vsize v1) (f (vsize v1) (vword v1) w2).

Definition map_word2_opt (f : forall sz : nat, word sz -> word sz -> word sz) (v1 v2 : value)
  : option value :=
  match value_eq_size v1 v2 with
  | left EQ => Some (map_word2 f v1 v2 EQ)
  | _ => None
  end.

Definition eq_to_opt (v1 v2 : value) (f : vsize v1 = vsize v2 -> value)
  : option value :=
  match value_eq_size v1 v2 with
  | left EQ => Some (f EQ)
  | _ => None
  end.

Lemma eqvalue {sz : nat} (x y : word sz) : x = y <-> mkvalue sz x = mkvalue sz y.
Proof.
  split; intros.
  subst. reflexivity. inversion H. apply existT_wordToZ in H1.
  apply wordToZ_inj. assumption.
Qed.

Lemma eqvaluef {sz : nat} (x y : word sz) : x = y -> mkvalue sz x = mkvalue sz y.
Proof. apply eqvalue. Qed.

Lemma nevalue {sz : nat} (x y : word sz) : x <> y <-> mkvalue sz x <> mkvalue sz y.
Proof. split; intros; intuition. apply H. apply eqvalue. assumption.
       apply H. rewrite H0. trivial.
Qed.

Lemma nevaluef {sz : nat} (x y : word sz) : x <> y -> mkvalue sz x <> mkvalue sz y.
Proof. apply nevalue. Qed.

(*Definition rewrite_word_size (initsz finalsz : nat) (w : word initsz)
  : option (word finalsz) :=
  match Nat.eqb initsz finalsz return option (word finalsz) with
  | true => Some _
  | false => None
  end.*)

Definition valueeq (sz : nat) (x y : word sz) :
  {mkvalue sz x = mkvalue sz y} + {mkvalue sz x <> mkvalue sz y} :=
  match weq x y with
  | left eq => left (eqvaluef x y eq)
  | right ne => right (nevaluef x y ne)
  end.

Definition valueeqb (x y : value) : bool :=
  match value_eq_size x y with
  | left EQ =>
    weqb (vword x) (unify_word (vsize x) (vsize y) (vword y) EQ)
  | right _ => false
  end.

Definition value_projZ_eqb (v1 v2 : value) : bool := Z.eqb (valueToZ v1) (valueToZ v2).

Theorem value_projZ_eqb_true :
  forall v1 v2,
  v1 = v2 -> value_projZ_eqb v1 v2 = true.
Proof. intros. subst. unfold value_projZ_eqb. apply Z.eqb_eq. trivial. Qed.

Theorem valueeqb_true_iff :
  forall v1 v2,
  valueeqb v1 v2 = true <-> v1 = v2.
Proof.
  split; intros.
  unfold valueeqb in H. destruct (value_eq_size v1 v2) eqn:?.
  - destruct v1, v2. simpl in H.
Abort.

Definition value_int_eqb (v : value) (i : int) : bool :=
  Z.eqb (valueToZ v) (Int.unsigned i).

(** Arithmetic operations over [value], interpreting them as signed or unsigned
depending on the operation.

The arithmetic operations over [word] are over [N] by default, however, can also
be called over [Z] explicitly, which is where the bits are interpreted in a
signed manner. *)

Definition vplus v1 v2 := map_word2 wplus v1 v2.
Definition vplus_opt v1 v2 := map_word2_opt wplus v1 v2.
Definition vminus v1 v2 := map_word2 wminus v1 v2.
Definition vmul v1 v2 := map_word2 wmult v1 v2.
Definition vdiv v1 v2 := map_word2 wdiv v1 v2.
Definition vmod v1 v2 := map_word2 wmod v1 v2.

Definition vmuls v1 v2 := map_word2 wmultZ v1 v2.
Definition vdivs v1 v2 := map_word2 wdivZ v1 v2.
Definition vmods v1 v2 := map_word2 wremZ v1 v2.

(** ** Bitwise operations

Bitwise operations over [value], which is independent of whether the number is
signed or unsigned. *)

Definition vnot v := map_word wnot v.
Definition vneg v := map_word wneg v.
Definition vbitneg v := boolToValue (vsize v) (negb (valueToBool v)).
Definition vor v1 v2 := map_word2 wor v1 v2.
Definition vand v1 v2 := map_word2 wand v1 v2.
Definition vxor v1 v2 := map_word2 wxor v1 v2.

(** ** Comparison operators

Comparison operators that return a bool, there should probably be an equivalent
which returns another number, however I might just add that as an explicit
conversion. *)

Definition veqb v1 v2 := map_any v1 v2 (@weqb (vsize v1)).
Definition vneb v1 v2 EQ := negb (veqb v1 v2 EQ).

Definition veq v1 v2 EQ := boolToValue (vsize v1) (veqb v1 v2 EQ).
Definition vne v1 v2 EQ := boolToValue (vsize v1) (vneb v1 v2 EQ).

Definition vltb v1 v2 := map_any v1 v2 wltb.
Definition vleb v1 v2 EQ := negb (map_any v2 v1 wltb (eq_sym EQ)).
Definition vgtb v1 v2 EQ := map_any v2 v1 wltb (eq_sym EQ).
Definition vgeb v1 v2 EQ := negb (map_any v1 v2 wltb EQ).

Definition vltsb v1 v2 := map_any v1 v2 wsltb.
Definition vlesb v1 v2 EQ := negb (map_any v2 v1 wsltb (eq_sym EQ)).
Definition vgtsb v1 v2 EQ := map_any v2 v1 wsltb (eq_sym EQ).
Definition vgesb v1 v2 EQ := negb (map_any v1 v2 wsltb EQ).

Definition vlt v1 v2 EQ := boolToValue (vsize v1) (vltb v1 v2 EQ).
Definition vle v1 v2 EQ := boolToValue (vsize v1) (vleb v1 v2 EQ).
Definition vgt v1 v2 EQ := boolToValue (vsize v1) (vgtb v1 v2 EQ).
Definition vge v1 v2 EQ := boolToValue (vsize v1) (vgeb v1 v2 EQ).

Definition vlts v1 v2 EQ := boolToValue (vsize v1) (vltsb v1 v2 EQ).
Definition vles v1 v2 EQ := boolToValue (vsize v1) (vlesb v1 v2 EQ).
Definition vgts v1 v2 EQ := boolToValue (vsize v1) (vgtsb v1 v2 EQ).
Definition vges v1 v2 EQ := boolToValue (vsize v1) (vgesb v1 v2 EQ).

(** ** Shift operators

Shift operators on values. *)

Definition shift_map (sz : nat) (f : word sz -> nat -> word sz) (w1 w2 : word sz) :=
  f w1 (wordToNat w2).

Definition vshl v1 v2 := map_word2 (fun sz => shift_map sz (@wlshift sz)) v1 v2.
Definition vshr v1 v2 := map_word2 (fun sz => shift_map sz (@wrshift sz)) v1 v2.

Module HexNotationValue.
  Export HexNotation.
  Import WordScope.

  Notation "sz ''h' a" := (NToValue sz (hex a)) (at level 50).

End HexNotationValue.

Inductive val_value_lessdef: val -> value -> Prop :=
| val_value_lessdef_int:
    forall i v',
    i = valueToInt v' ->
    val_value_lessdef (Vint i) v'
| val_value_lessdef_ptr:
    forall b off v',
    off = valueToPtr v' ->
    (Z.modulo (uvalueToZ v') 4) = 0%Z ->
    val_value_lessdef (Vptr b off) v'
| lessdef_undef: forall v, val_value_lessdef Vundef v.

Inductive opt_val_value_lessdef: option val -> value -> Prop :=
| opt_lessdef_some:
    forall v v', val_value_lessdef v v' -> opt_val_value_lessdef (Some v) v'
| opt_lessdef_none: forall v, opt_val_value_lessdef None v.

Lemma valueToZ_ZToValue :
  forall n z,
  (- Z.of_nat (2 ^ n) <= z < Z.of_nat (2 ^ n))%Z ->
  valueToZ (ZToValue (S n) z) = z.
Proof.
  unfold valueToZ, ZToValue. simpl.
  auto using wordToZ_ZToWord.
Qed.

Lemma uvalueToZ_ZToValue :
  forall n z,
  (0 <= z < 2 ^ Z.of_nat n)%Z ->
  uvalueToZ (ZToValue n z) = z.
Proof.
  unfold uvalueToZ, ZToValue. simpl.
  auto using uwordToZ_ZToWord.
Qed.

Lemma uvalueToZ_ZToValue_full :
  forall sz : nat,
  (0 < sz)%nat ->
  forall z : Z, uvalueToZ (ZToValue sz z) = (z mod 2 ^ Z.of_nat sz)%Z.
Proof. unfold uvalueToZ, ZToValue. simpl. auto using uwordToZ_ZToWord_full. Qed.

Lemma ZToValue_uvalueToZ :
  forall v,
  ZToValue (vsize v) (uvalueToZ v) = v.
Proof.
  intros.
  unfold ZToValue, uvalueToZ.
  rewrite ZToWord_uwordToZ. destruct v; auto.
Qed.

Lemma valueToPos_posToValueAuto :
  forall p, valueToPos (posToValueAuto p) = p.
Proof.
  intros. unfold valueToPos, posToValueAuto.
  rewrite uvalueToZ_ZToValue. auto. rewrite positive_nat_Z.
  split. apply Zle_0_pos.

  assert (p < 2 ^ (Pos.size p))%positive by apply Pos.size_gt.
  inversion H. rewrite <- Z.compare_lt_iff. rewrite <- H1.
  simpl. rewrite <- Pos2Z.inj_pow_pos. trivial.
Qed.

Lemma valueToPos_posToValue :
  forall p, valueToPos (posToValueAuto p) = p.
Proof.
  intros. unfold valueToPos, posToValueAuto.
  rewrite uvalueToZ_ZToValue. auto. rewrite positive_nat_Z.
  split. apply Zle_0_pos.

  assert (p < 2 ^ (Pos.size p))%positive by apply Pos.size_gt.
  inversion H. rewrite <- Z.compare_lt_iff. rewrite <- H1.
  simpl. rewrite <- Pos2Z.inj_pow_pos. trivial.
Qed.

Lemma valueToInt_intToValue :
  forall v,
  valueToInt (intToValue v) = v.
Proof.
  intros.
  unfold valueToInt, intToValue. rewrite uvalueToZ_ZToValue. auto using Int.repr_unsigned.
  split. apply Int.unsigned_range_2.
  assert ((Int.unsigned v <= Int.max_unsigned)%Z) by apply Int.unsigned_range_2.
  apply Z.lt_le_pred in H. apply H.
Qed.

Lemma valueToPtr_ptrToValue :
  forall v,
  valueToPtr (ptrToValue v) = v.
Proof.
  intros.
  unfold valueToPtr, ptrToValue. rewrite uvalueToZ_ZToValue. auto using Ptrofs.repr_unsigned.
  split. apply Ptrofs.unsigned_range_2.
  assert ((Ptrofs.unsigned v <= Ptrofs.max_unsigned)%Z) by apply Ptrofs.unsigned_range_2.
  apply Z.lt_le_pred in H. apply H.
Qed.

Lemma intToValue_valueToInt :
  forall v,
  vsize v = 32%nat ->
  intToValue (valueToInt v) = v.
Proof.
  intros. unfold valueToInt, intToValue. rewrite Int.unsigned_repr_eq.
  unfold ZToValue, uvalueToZ. unfold Int.modulus. unfold Int.wordsize. unfold Wordsize_32.wordsize.
  pose proof (uwordToZ_bound (vword v)).
  rewrite Z.mod_small. rewrite <- H. rewrite ZToWord_uwordToZ. destruct v; auto.
  rewrite <- H. rewrite two_power_nat_equiv. apply H0.
Qed.

Lemma ptrToValue_valueToPtr :
  forall v,
  vsize v = 32%nat ->
  ptrToValue (valueToPtr v) = v.
Proof.
  intros. unfold valueToPtr, ptrToValue. rewrite Ptrofs.unsigned_repr_eq.
  unfold ZToValue, uvalueToZ. unfold Ptrofs.modulus. unfold Ptrofs.wordsize. unfold Wordsize_Ptrofs.wordsize.
  pose proof (uwordToZ_bound (vword v)).
  rewrite Z.mod_small. rewrite <- H. rewrite ZToWord_uwordToZ. destruct v; auto.
  rewrite <- H. rewrite two_power_nat_equiv. apply H0.
Qed.

Lemma valToValue_lessdef :
  forall v v',
    valToValue v = Some v' ->
    val_value_lessdef v v'.
Proof.
  intros.
  destruct v; try discriminate; constructor.
  unfold valToValue in H. inversion H.
  symmetry. apply valueToInt_intToValue.
  inv H. destruct (uvalueToZ (ptrToValue i) mod 4 =? 0); try discriminate.
  inv H1. symmetry. apply valueToPtr_ptrToValue.
  inv H. destruct (uvalueToZ (ptrToValue i) mod 4 =? 0) eqn:?; try discriminate.
  inv H1. apply Z.eqb_eq. apply Heqb0.
Qed.

Lemma boolToValue_ValueToBool :
  forall b,
  valueToBool (boolToValue 32 b) = b.
Proof. destruct b; auto. Qed.

Local Open Scope Z.

Ltac word_op_value H :=
  intros; unfold uvalueToZ, ZToValue; simpl; rewrite unify_word_unfold;
  rewrite <- H; rewrite uwordToZ_ZToWord_full; auto; omega.

Lemma zadd_vplus :
  forall sz z1 z2,
  (sz > 0)%nat ->
  uvalueToZ (vplus (ZToValue sz z1) (ZToValue sz z2) eq_refl) = (z1 + z2) mod 2 ^ Z.of_nat sz.
Proof. word_op_value ZToWord_plus. Qed.

Lemma zadd_vplus2 :
  forall z1 z2,
  vplus (ZToValue 32 z1) (ZToValue 32 z2) eq_refl = ZToValue 32 (z1 + z2).
Proof.
  intros. unfold vplus, ZToValue, map_word2. rewrite unify_word_unfold. simpl.
  rewrite ZToWord_plus; auto.
Qed.

Lemma ZToValue_eq :
  forall w1,
  (mkvalue 32 w1) = (ZToValue 32 (wordToZ w1)). Abort.

Lemma wordsize_32 :
  Int.wordsize = 32%nat.
Proof. auto. Qed.

Lemma intadd_vplus :
  forall i1 i2,
  valueToInt (vplus (intToValue i1) (intToValue i2) eq_refl) = Int.add i1 i2.
Proof.
  intros. unfold Int.add, valueToInt, intToValue. rewrite zadd_vplus.
  rewrite <- Int.unsigned_repr_eq.
  rewrite Int.repr_unsigned. auto. rewrite wordsize_32. omega.
Qed.

(*Lemma intadd_vplus2 :
  forall v1 v2 EQ,
  vsize v1 = 32%nat ->
  Int.add (valueToInt v1) (valueToInt v2) = valueToInt (vplus v1 v2 EQ).
Proof.
  intros. unfold Int.add, valueToInt, intToValue. repeat (rewrite Int.unsigned_repr).
  rewrite (@vadd_vplus v1 v2 EQ). trivial.
  unfold uvalueToZ. pose proof (@uwordToZ_bound (vsize v2) (vword v2)).
  rewrite H in EQ. rewrite <- EQ in H0 at 3.*)
  (*rewrite zadd_vplus3. trivia*)

Lemma valadd_vplus :
  forall v1 v2 v1' v2' v v' EQ,
  val_value_lessdef v1 v1' ->
  val_value_lessdef v2 v2' ->
  Val.add v1 v2 = v ->
  vplus v1' v2' EQ = v' ->
  val_value_lessdef v v'.
Proof.
  intros. inv H; inv H0; constructor; simplify.
  Abort.

Lemma zsub_vminus :
  forall sz z1 z2,
  (sz > 0)%nat ->
  uvalueToZ (vminus (ZToValue sz z1) (ZToValue sz z2) eq_refl) = (z1 - z2) mod 2 ^ Z.of_nat sz.
Proof. word_op_value ZToWord_minus. Qed.

Lemma zmul_vmul :
  forall sz z1 z2,
  (sz > 0)%nat ->
  uvalueToZ (vmul (ZToValue sz z1) (ZToValue sz z2) eq_refl) = (z1 * z2) mod 2 ^ Z.of_nat sz.
Proof. word_op_value ZToWord_mult. Qed.

Local Open Scope N.
Lemma zdiv_vdiv :
  forall n1 n2,
  n1 < 2 ^ 32 ->
  n2 < 2 ^ 32 ->
  n1 / n2 < 2 ^ 32 ->
  valueToN (vdiv (NToValue 32 n1) (NToValue 32 n2) eq_refl) = n1 / n2.
Proof.
  intros; unfold valueToN, NToValue; simpl; rewrite unify_word_unfold. unfold wdiv.
  unfold wordBin. repeat (rewrite wordToN_NToWord_2); auto.
Qed.

Lemma ZToValue_valueToNat :
  forall x sz,
  (sz > 0)%nat ->
  (0 <= x < 2^(Z.of_nat sz))%Z ->
  valueToNat (ZToValue sz x) = Z.to_nat x.
Proof.
  destruct x; intros; unfold ZToValue, valueToNat; crush.
  - rewrite wzero'_def. apply wordToNat_wzero.
  - rewrite posToWord_nat. rewrite wordToNat_natToWord_2. trivial.
    clear H1.
    lazymatch goal with
    | [ H : context[(_ < ?x)%Z] |- _ ] => replace x with (Z.of_nat (Z.to_nat x)) in H
    end.
    2: { apply Z2Nat.id; apply Z.pow_nonneg; lia. }

    rewrite Z2Nat.inj_pow in H2; crush.
    replace (Pos.to_nat 2) with 2%nat in H2 by reflexivity.
    rewrite Nat2Z.id in H2.
    rewrite <- positive_nat_Z in H2.
    apply Nat2Z.inj_lt in H2.
    assumption.
Qed.
*)


(* ************************************************************************** *)
(*                                                                            *)
(* Verified Flash Translation Layer                                           *)
(*                                                                            *)
(*                                                                            *)
(* ************************************************************************** *)

Require Export bnat.
Require Import LibEx.
Require Import ListEx.
Require Import Monad.
Require Import Data.

Require Import Params.

(* NAND hardware interface *)

(* Definition oob := list int. *)

Definition page_off := nat.

Definition block_no := nat.

Definition page_off_of_nat (n: nat) : page_off := n.

Definition page_no := prod block_no page_off.

Inductive page_status : Set :=
  | ps_free
  | ps_programmed.

Inductive block_status : Set :=
  | bs_free
  | bs_programmed.

Record page : Set :=
  mkpage {
      page_data : data;
      page_oob : data;
      page_state : page_status
      (* data_size: length (page_data) = PAGE_DATA_SIZE; *)
      (* oob_size: length (page_data) = PAGE_SPAREAREA_SIZE *)
    }.

Record block : Set :=
  mkblock {
      block_pages : list page;
      next_page : page_off;
      block_erase_count: nat;
      block_state : block_status
      (* pages_size: length block_pages = PAGES_PER_BLOCK *)
    }.

Record chip : Set :=
  mkchip {
      chip_blocks: list block
      (* blocks_size : length chip_blocks = BLOCKS *)
    }.

(********* Initialization of the Nand Chip ****************)

Definition init_page_data : data :=
  list_repeat_list PAGE_DATA_SIZE c_ff.

Definition init_page_oob : data :=
  list_repeat_list PAGE_SPARE_AREA_SIZE c_ff.

Definition init_page : page :=
  mkpage init_page_data init_page_oob ps_free.

Definition init_block : block :=
  mkblock (list_repeat_list PAGES_PER_BLOCK init_page) 0 0 bs_free.

Definition erased_block (ec: nat): block :=
  mkblock (list_repeat_list PAGES_PER_BLOCK init_page) 0 (S ec) bs_free.

Definition bvalid_block_no (pbn: block_no) : bool :=
  (blt_nat pbn BLOCKS).

Definition bvalid_page_off (off: page_off) : bool :=
  (blt_nat off PAGES_PER_BLOCK).

(********* Nand chip Operations ***************)
Definition nand_init : chip :=
  mkchip (list_repeat_list BLOCKS init_block).

(* written by zhanghui, generate the content of 'oob' according to the
data stored in this page. *)
(* TEMP: now just return a list of null *)
Definition make_oob (d : data) : data :=
  list_repeat_list PAGE_SPARE_AREA_SIZE c_null.

Definition chip_get_block (c: chip) (pbn: block_no): option block :=
  list_get (chip_blocks c) pbn.

Definition chip_set_block (c: chip) (pbn: block_no) (b: block) : option chip :=
  test bvalid_block_no pbn;
  do nbl <-- list_set (chip_blocks c) pbn b;
  ret (mkchip nbl).

Definition block_get_page (b: block) (off: page_off) : option page :=
  test (bvalid_page_off off);
  do p <-- (list_get (block_pages b) off);
  ret p.

Definition block_set_page (b: block) (off: page_off) (p: page) : option block :=
  test bvalid_page_off off;
  do npl <-- list_set (block_pages b) off p;
  ret (mkblock npl (next_page b) (block_erase_count b) bs_programmed).

Definition block_set_next_page (b: block) (off: page_off) : option block :=
  ret (mkblock (block_pages b) (off) (block_erase_count b) (block_state b)).

Definition chip_get_page (c: chip) (bln: block_no) (poff: page_off) : option page :=
  match chip_get_block c bln with
    | None => None
    | Some b =>
      block_get_page b poff
  end.

Definition page_get_data (p: page) : option data :=
  match page_state p with
    | ps_free => None (* This is an empty page, no data. *)
    | ps_programmed => Some (page_data p)
  end.

Definition check_page_state_is_free (ps : page_status) : bool :=
  match ps with
    | ps_free => true
    | _ => false
  end.

(********* Nand chip Operations ***************)
Definition nand_read_page (c: chip) (pbn: block_no) (poff: page_off) : option (prod data data) :=
  test (bvalid_block_no pbn);
  do b <-- chip_get_block c pbn;
  test (bvalid_page_off poff);
  do p <-- block_get_page b poff;
  ret (page_data p, page_oob p).

Definition nand_write_page (c: chip) (pbn: block_no) (off: page_off) (d: data) (o: data): option chip :=
  test (bvalid_block_no pbn);
  do b <-- chip_get_block c pbn;
  test (bvalid_page_off off);
  test (ble_nat (next_page b) off);
  do p <-- block_get_page b off;
  test (check_page_state_is_free (page_state p));
  do b' <-- block_set_page b off (mkpage d o ps_programmed);
  do b'' <-- block_set_next_page b' (S off);
  do c' <-- chip_set_block c pbn b'';
  ret c'.

Definition nand_erase_block (c: chip) (pbn: block_no) : option chip :=
  test (bvalid_block_no pbn);
  do b <-- chip_get_block c pbn;
  let b' := erased_block (block_erase_count b) in
  do c' <-- chip_set_block c pbn b';
  ret c'.


Require Import Coq.Program.Basics.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Combinators.
Require Import omega.Omega.
Require Import Setoid.
Require Import ZArith.
Require Import FinProof.Common.
Require Import FinProof.CommonInstances.
Require Import FinProof.StateMonad2.
Require Import FinProof.StateMonadInstances.
Require Import FinProof.ProgrammingWith.
Local Open Scope struct_scope.
Require Import FinProof.CommonProofs.
Require Import depoolContract.ProofEnvironment.
Require Import depoolContract.DePoolClass.
Require Import depoolContract.SolidityNotations.
Require Import depoolContract.DePoolFunc.
Require Import depoolContract.DePoolConsts.
Require Import depoolContract.Lib.CommonModelProofs.
Module CommonModelProofs := CommonModelProofs StateMonadSig.
Import CommonModelProofs.
Require Import depoolContract.Lib.Tactics.
Require Import depoolContract.Lib.ErrorValueProofs.
Require Import depoolContract.Scenarios.ScenarioCommon.
Import DePoolSpec.LedgerClass.SolidityNotations.
Local Open Scope struct_scope.
Local Open Scope Z_scope.
Local Open Scope solidity_scope.
Require Import Lists.List.
Import ListNotations.
Local Open Scope list_scope.
Set Typeclasses Iterative Deepening.
Set Typeclasses Depth 100.
Module Scenario1  (dc : DePoolConstsTypesSig XTypesSig StateMonadSig).
Module DePoolFuncs := DePoolFuncs XTypesSig StateMonadSig dc.
Import dc.
Module ScenarioCommon := ScenarioCommon dc.
Import ScenarioCommon.
Import DePoolFuncs.
Import DePoolSpec.
Import LedgerClass.

Lemma Scenario_OrdinaryStakeWin_byValidator: forall
                        (minStake validatorAssurance proxyCode validatorWallet   participantRewardFraction : Z)
                        (proxyCode : TvmCell)
                        (now_constructor msg_pubkey_constructor : Z)
                        (NetParams_init : NetParams)
                        (stake :Z )
                        (NetParams_addOrdinaryStake :  NetParams)
                        (now_addOrdinaryStake msg_value_addOrdinaryStake msg_sender_addOrdinaryStake : Z)
                        (now_round1  msg_value_round1 msg_sender_round1 : Z)
                        (NetParams_round1 :  NetParams)
                        (queryId0 validatorKey stakeAt maxFactor adnlAddr : Z)
                        ( signature : XList XInteger8 )
                        (now_participateInElections  msg_value_participateInElections msg_sender_participateInElections : Z)
                        (NetParams_participateInElections :  NetParams)
                        (queryId comment elector : Z)
                        (now_onStakeAccept  msg_value_onStakeAccept msg_sender_onStakeAccept : Z)
                        (NetParams_onStakeAccept :  NetParams)
                        (now_toWaitingIfValidatorWinElections  msg_value_toWaitingIfValidatorWinElections msg_sender_toWaitingIfValidatorWinElections : Z)
                        (NetParams_toWaitingIfValidatorWinElections :  NetParams)
                        (now_onFailToRecoverStake  msg_value_onFailToRecoverStake msg_sender_onFailToRecoverStake : Z)
                        (NetParams_onFailToRecoverStake :  NetParams)
                        (now_toWaitingReward  msg_value_toWaitingReward msg_sender_toWaitingReward : Z)
                        (NetParams_toWaitingReward :  NetParams)
                        (now_onSuccessToRecoverStake  msg_value_onSuccessToRecoverStake msg_sender_onSuccessToRecoverStake : Z)
                        (NetParams_onSuccessToRecoverStake :  NetParams),
let l_init_NetParams := withNetParams default NetParams_init in
let l_init := {$ l_init_NetParams With (VMState_ι_now,   now_constructor);
                                       (VMState_ι_msg_pubkey,   msg_pubkey_constructor)$} in
let l_constructor:= exec_state (DePoolContract_Ф_Constructor6 minStake validatorAssurance proxyCode validatorWallet   participantRewardFraction  ) l_init in
let (r, l_fin) := run  (modify (fun l => withNetParams l NetParams_addOrdinaryStake) >>
                        modify (fun l => {$ l With (VMState_ι_now,   now_addOrdinaryStake);
                                                   (VMState_ι_msg_value , msg_value_addOrdinaryStake);
                                                   (VMState_ι_msg_sender , msg_sender_addOrdinaryStake) $}) >>
                        do _ ← DePoolContract_Ф_addOrdinaryStake'' stake ??;
                        modify (fun l => withNetParams l NetParams_round1) >>
                        modify (fun l => {$ l With (VMState_ι_now,          now_round1);
                                                   (VMState_ι_msg_value ,   msg_value_round1);
                                                   (VMState_ι_msg_sender ,  msg_sender_round1) $}) >>
                        do _ ← DePoolContract_Ф_ticktock ??;
                        modify (fun l => withNetParams l NetParams_participateInElections) >>
                        modify (fun l => {$ l With (VMState_ι_now,          now_participateInElections);
                                                   (VMState_ι_msg_value ,   msg_value_participateInElections);
                                                   (VMState_ι_msg_sender ,  msg_sender_participateInElections) $}) >>
                        do _ ← DePoolContract_Ф_participateInElections'' queryId0 validatorKey stakeAt maxFactor adnlAddr signature ??;
                        modify (fun l => withNetParams l NetParams_onStakeAccept) >>
                        modify (fun l => {$ l With (VMState_ι_now,          now_onStakeAccept);
                                                   (VMState_ι_msg_value ,   msg_value_onStakeAccept);
                                                   (VMState_ι_msg_sender ,  msg_sender_onStakeAccept) $}) >>
                        do _ ← DePoolContract_Ф_onStakeAccept queryId comment elector ??;
                        modify (fun l => withNetParams l NetParams_toWaitingIfValidatorWinElections) >>
                        modify (fun l => {$ l With (VMState_ι_now,          now_toWaitingIfValidatorWinElections);
                                                   (VMState_ι_msg_value ,   msg_value_toWaitingIfValidatorWinElections);
                                                   (VMState_ι_msg_sender ,  msg_sender_toWaitingIfValidatorWinElections) $}) >>
                        do _ ← DePoolContract_Ф_ticktock ??;
                        modify (fun l => withNetParams l NetParams_onFailToRecoverStake) >>
                        modify (fun l => {$ l With (VMState_ι_now,          now_onFailToRecoverStake);
                                                   (VMState_ι_msg_value ,   msg_value_onFailToRecoverStake);
                                                   (VMState_ι_msg_sender ,  msg_sender_onFailToRecoverStake) $}) >>
                        do _ ← DePoolContract_Ф_onFailToRecoverStake queryId elector ??;
                        modify (fun l => withNetParams l NetParams_toWaitingReward) >>
                        modify (fun l => {$ l With (VMState_ι_now,          now_toWaitingReward);
                                                   (VMState_ι_msg_value ,   msg_value_toWaitingReward);
                                                   (VMState_ι_msg_sender ,  msg_sender_toWaitingReward) $}) >>
                        do _ ← DePoolContract_Ф_ticktock ??;
                        modify (fun l => withNetParams l NetParams_onSuccessToRecoverStake) >>
                        modify (fun l => {$ l With (VMState_ι_now,          now_onSuccessToRecoverStake);
                                                   (VMState_ι_msg_value ,   msg_value_onSuccessToRecoverStake);
                                                   (VMState_ι_msg_sender ,  msg_sender_onSuccessToRecoverStake) $}) >>
                        do _ ← DePoolContract_Ф_onSuccessToRecoverStake queryId elector ?;
                        $ I )  l_constructor in errorValueIsValue r = true ->
msg_sender_addOrdinaryStake = validatorWallet ->
(now_round1 >=? NetParams_round1 ->> NetParams_ι_utime_until - NetParams_round1 ->> NetParams_ι_electionsStartBefore) = true ->
((negb (tvm_hash (NetParams_init ->> NetParams_ι_curValidatorData) =? tvm_hash (NetParams_round1 ->> NetParams_ι_curValidatorData))) &&
(negb (tvm_hash (NetParams_init ->> NetParams_ι_prevValidatorData) =? tvm_hash (NetParams_round1 ->> NetParams_ι_curValidatorData))))%bool= true ->
(stake >=? validatorAssurance) = true ->
( tvm_hash  (NetParams_round1 ->> NetParams_ι_curValidatorData)  =?  tvm_hash  (NetParams_toWaitingIfValidatorWinElections ->> NetParams_ι_prevValidatorData))  = true ->
(now_toWaitingIfValidatorWinElections >=? NetParams_toWaitingIfValidatorWinElections ->> NetParams_ι_utime_until - NetParams_toWaitingIfValidatorWinElections ->> NetParams_ι_electionsStartBefore) = true ->
(negb (0 =? tvm_hash ((NetParams_toWaitingIfValidatorWinElections ->> NetParams_ι_curValidatorData)))) = true ->
((negb (tvm_hash ((NetParams_toWaitingReward ->> NetParams_ι_curValidatorData)) =? tvm_hash ((NetParams_round1 ->> NetParams_ι_curValidatorData)))) &&
(negb (tvm_hash ((NetParams_toWaitingReward ->> NetParams_ι_prevValidatorData)) =? tvm_hash ((NetParams_round1 ->> NetParams_ι_curValidatorData)))))%bool= true ->
(now_toWaitingReward >=? NetParams_toWaitingReward ->> NetParams_ι_utime_since + NetParams_round1 ->> NetParams_ι_stakeHeldFor + DePoolLib_ι_ELECTOR_UNFREEZE_LAG) = true ->
(msg_value_onSuccessToRecoverStake + DePoolLib_ι_PROXY_FEE >=? stake) = true ->
let reward_all := msg_value_onSuccessToRecoverStake + DePoolLib_ι_PROXY_FEE - stake  - (DePool_ι_RET_OR_REINV_FEE +  1 * DePool_ι_RET_OR_REINV_FEE) in
let rewards := reward_all * participantRewardFraction / 100  in
let stakeSum := stake in
let reward := stakeSum * rewards / stake  in
let optRound := eval_state ( ↓ ( RoundsBase_Ф_fetchRound queryId ) ) l_fin in
let round := maybeGet optRound in
let stakes :=  round ->> RoundsBase_ι_Round_ι_stakes in
let optStake := stakes ->fetch validatorWallet in
let current_stakes := maybeGet optStake in
round ->> RoundsBase_ι_Round_ι_stake = stake + reward
/\ current_stakes ->> RoundsBase_ι_StakeValue_ι_ordinary  = stake + reward.
Proof.

Abort.
End Scenario1.


From Coq Require Import ZArith.ZArith Lists.List Strings.String micromega.Lia Arith
     Ensembles Relations.Relation_Definitions.
Require Import Common.AstCommon.
Require compcert.lib.Maps compcert.lib.Coqlib.

Import ListNotations.

Require Import LambdaBoxLocal.expression LambdaBoxLocal.fuel_sem.

Require Import cps cps_show eval ctx logical_relations
        List_util algebra alpha_conv functions Ensembles_util
        tactics LambdaBoxLocal_to_LambdaANF LambdaBoxLocal_to_LambdaANF_util LambdaBoxLocal_to_LambdaANF_corresp LambdaBoxLocal_to_LambdaANF_correct
        LambdaANF.tactics identifiers bounds cps_util rename.

Require Import ExtLib.Data.Monads.OptionMonad ExtLib.Structures.Monads.

Import Monad.MonadNotation.

Open Scope monad_scope.

Section Refinement.

  Context (cnstrs : conId_map)
          (dtag : positive) (* default tag *)
          (cenv : ctor_env).

  Fixpoint value_ref' (v1 : value) (v2 : val) : Prop:=
    let fix Forall2_aux vs1 vs2 :=
        match vs1, vs2 with
        | [], [] => True
        | v1 :: vs1, v2 :: vs2 =>
          value_ref' v1 v2 /\ Forall2_aux vs1 vs2
        | _, _ => False
        end
    in
    match v1, v2 with
    | Con_v c1 vs1, Vconstr c2 vs2 =>
      dcon_to_tag dtag c1 cnstrs = c2 /\ Forall2_aux vs1 vs2
    | Clos_v _ _ _, Vfun _ _ _ => True
    | ClosFix_v _ _ _, Vfun _ _ _ => True
    | _, _ => False
    end.

  Definition value_ref (v1 : value) (v2 : val) : Prop:=
    match v1, v2 with
    | Con_v c1 vs1, Vconstr c2 vs2 =>
      dcon_to_tag dtag c1 cnstrs = c2 /\ Forall2 value_ref' vs1 vs2
    | Clos_v _ _ _, Vfun _ _ _ => True
    | ClosFix_v _ _ _, Vfun _ _ _ => True
    | _, _ => False
    end.

  Lemma value_ref_eq v1 v2 :
    value_ref' v1 v2 <-> value_ref v1 v2.
  Proof.
    induction v1; try easy.

    destruct v2; simpl; try easy.

    revert l0. induction l; intros l'.

    - split; intros [H1 H2]. split; eauto; destruct l'; eauto.
      inv H2. split; eauto.

    - split; intros [H1 H2].

      + split; eauto; destruct l'; inv H2.
        constructor; eauto. eapply IHl. split; eauto.

      + split; eauto. destruct l'; inv H2.
        constructor; eauto. eapply IHl. split; eauto.
  Qed.

  Definition diverge (v : list value) (e : expression.exp) :=
    forall (c : nat), exists t, eval_env_fuel v e fuel_sem.OOT c t.

  Program Definition refines M (e1 : expression.exp) (e2 : cps.exp) :=
    (* Termination *)
    (forall (v1 : value) (c1 t1 : nat),
        eval_env_fuel [] e1 (Val v1) c1 t1 ->
        exists (v2 : val) (c2 : nat),
          bstep_fuel cenv (M.empty _) e2 c2 (Res v2) tt /\
          (c2 <= t1 + M)%nat /\
          value_ref v1 v2) /\
    (* Divergence *)
    (diverge [] e1 -> eval.diverge cenv (M.empty _) e2).

  Context (prim_map : M.t (kername * string (* C definition *) * nat (* arity *))).
  Context (func_tag kon_tag default_itag : positive)
          (next_id : positive).
  Context (dcon_to_tag_inj :
             forall (tgm : conId_map) (dc dc' : dcon),
               dcon_to_tag dtag dc tgm = dcon_to_tag dtag dc' tgm -> dc = dc').

  Definition cps_rel_top (e : expression.exp) (xs : list var)
             (k : var) (e' : cps.exp) :=
    let S := fun x => (max_list xs k + 1 <= x)%positive in
    exists S', cps_cvt_rel func_tag kon_tag dtag S e xs k cnstrs S' e'.

  Lemma cps_val_comp k v1 v2 v3 :
    cps_val_rel func_tag kon_tag dtag cnstrs v1 v2 ->
    preord_val cenv eq_fuel k v2 v3 ->
    value_ref v1 v3.
  Proof.
    revert v2 v3.
    induction v1 using value_ind'; intros v2 v3 Hval Hll; inv Hval.
    - rewrite preord_val_eq in Hll.
      destruct v3; try contradiction. inv Hll.
      simpl. split. reflexivity.

      revert l vs' H2 H1.
      induction H.

      + intros. inv H2. inv H1. constructor.

      + intros. inv H2. inv H1. constructor; eauto.
        eapply value_ref_eq. eauto.

    - rewrite preord_val_eq in Hll.
      destruct v3; try contradiction.
      simpl. eauto.

    - rewrite preord_val_eq in Hll.
      destruct v3; try contradiction.
      simpl. eauto.
  Qed.

  Theorem cps_corrrect_top e k x (Hneq : x <> k):
    exp_wf 0%N e ->
    exists e',
      cps_rel_top e [] k e' /\
      refines 3 e (Efun (Fcons k kon_tag [x] (Ehalt x) Fnil) e').
  Proof.
    intros Hwf.
    edestruct cps_rel_exists with (xs := @nil var).
    eassumption.
    eassumption.

    destructAll.
    eexists. split.
    eexists. eassumption.

    split.

    - intro; intros.
      edestruct cps_cvt_correct
        with (rho := M.set k
                           (Vfun (M.empty _) (Fcons k kon_tag [x] (Ehalt x) Fnil) k)
                           (M.empty _)) (x := x); try eassumption.
      + now constructor.
      + simpl. eassumption.
      + repeat normalize_sets.
        eapply Disjoint_Singleton_l. simpl.
        intros Hin. unfold In in *. lia.
      + repeat normalize_sets. intros Hc. inv Hc.
        eauto.
      + intros Hc. inv Hc.
      + constructor.
      + rewrite M.gss. reflexivity.
      + clear H2.

        edestruct cps_val_rel_exists as [v2 Hval]. eassumption.
        eapply (@eval_env_step_preserves_wf nat LambdaBoxLocal_resource_fuel LambdaBoxLocal_resource_trace).
        eassumption. reflexivity. constructor. eassumption.

        specialize (H1 v1 v2 eq_refl Hval).

        edestruct H1. reflexivity.

        econstructor 2. econstructor.
        rewrite M.gso. rewrite M.gss. reflexivity.
        now eauto.
        simpl. rewrite M.gss. reflexivity.
        simpl. rewrite Coqlib.peq_true. reflexivity.
        simpl. reflexivity.

        econstructor 2. econstructor. rewrite M.gss. reflexivity.

        destructAll. destruct x2. contradiction.

        destruct x4.

        do 2 eexists. split; [ | split ].

        replace tt with (tt <+> tt) by reflexivity.
        econstructor 2.
        econstructor. simpl. eassumption.

        simpl in *.  unfold one, one_i; simpl. lia.
        simpl in *. eapply cps_val_comp. eassumption. eassumption.

    - intros Hdiv.

      intros c. specialize (Hdiv c). destructAll.
      edestruct cps_cvt_correct
        with (rho := M.set k
                           (Vfun (M.empty _) (Fcons k kon_tag [x] (Ehalt x) Fnil) k)
                           (M.empty _)) (x := x); try eassumption.
      + now constructor.
      + simpl. eassumption.
      + repeat normalize_sets.
        eapply Disjoint_Singleton_l. simpl.
        intros Hin. unfold In in *. lia.
      + repeat normalize_sets. intros Hc. inv Hc.
        eauto.
      + intros Hc. inv Hc.
      + constructor.
      + rewrite M.gss. reflexivity.
      + clear H1.
        specialize (H2 eq_refl). destructAll.

        destruct c.

        * eexists. constructor. simpl.
          unfold one, one_i. simpl. lia.

        * eexists. replace (S c) with (c + 1)%nat by lia.
          econstructor 2. econstructor.
          simpl.
          edestruct Nat.le_exists_sub with (n := c) (m := x3). lia. destructAll.
          eapply bstep_fuel_OOT_monotonic in H2.
          destructAll. destruct x3. eassumption.

          Grab Existential Variables. exact 0%nat.
  Qed.

  Section Linking.

    Definition link_src (e_lib e_cli : expression.exp) :=
      Let_e nAnon e_lib e_cli.

    Definition link_trg (k1 x1 : var) (e_lib e_cli : cps.exp) :=
      (* Efun (Fcons k2 kon_tag [x2] (Ehalt x1) Fnil) *)
      (Efun (Fcons k1 kon_tag [x1] e_cli Fnil) e_lib).

    Lemma linking_correct e_lib e_cli k1 x1 r f t :
      forall rho k x vk e_lib' e_cli' i,
        exp_wf 0%N e_lib ->
        exp_wf 1%N e_cli ->

        eval_env_fuel [] (link_src e_lib e_cli) r f t ->

        cps_rel_top e_cli [x1] k e_cli' ->
        cps_rel_top e_lib [] k1 e_lib' ->

        x1 <> k ->
        k1 <> k ->
        x <> k ->

        M.get k rho = Some vk ->

        (* Source terminates *)
        (forall v v',
            r = (Val v) ->
            cps_val_rel func_tag kon_tag dtag cnstrs v v' ->
            preord_exp cenv (cps_bound f t) eq_fuel i
                  ((Eapp k kon_tag (x::nil)), (M.set x v' (M.set k vk (M.empty cps.val))))
                  (link_trg k1 x1 e_lib' e_cli', rho)) /\
        (* SOurce diverges *)
        (r = fuel_sem.OOT ->
         exists c, (f <= c)%nat /\ bstep_fuel cenv rho (link_trg k1 x1 e_lib' e_cli') c eval.OOT tt).
    Proof.
      intros rho k x vk e_lib' e_cli' i Hwf1 Hwf2 Heval Hcps1 Hcps2 Hneq1 Hneq2 Hneq3 Hget.
      inv Heval.

      - split. congruence.
        intros _. simpl in *. unfold fuel_exp in *.
        eexists 0%nat. split.

        simpl in *. lia.
        constructor 1. unfold one, one_i. simpl. lia.

      - inv H.

        + assert (Heval1 := H7). eapply cps_cvt_correct in H7; eauto.
          assert (Heval2 := H8). eapply cps_cvt_correct in H8; eauto.

          unfold link_trg.

          assert (Hwfv2 : well_formed_val v1).
          { eapply (@eval_env_step_preserves_wf nat LambdaBoxLocal_resource_fuel LambdaBoxLocal_resource_trace);
              [ | reflexivity | | ]. eassumption.
            now constructor. eassumption. }

          assert (Hex' : exists v', cps_val_rel func_tag kon_tag dtag cnstrs v1 v').
          { eapply cps_val_rel_exists. eassumption. (* TODO remove arg *) eassumption. } destructAll.

          inv Hcps1. inv Hcps2.

          assert (Heq : forall m, preord_exp' cenv (preord_val cenv)
                                              (cps_bound (f1 <+> @one_i _ _ fuel_resource_LambdaBoxLocal (link_src e_lib e_cli))
                                                         (t1 <+> @one_i _ _ trace_resource_LambdaBoxLocal (link_src e_lib e_cli)))

                                              eq_fuel m
                                              (e_cli', map_util.M.set x1 x0 (M.set k1 (Vfun rho (Fcons k1 kon_tag [x1] e_cli' Fnil) k1) rho))
                                              (Efun (Fcons k1 kon_tag [x1] e_cli' Fnil) e_lib', rho)).
        { intros j. eapply preord_exp_post_monotonic.
          2:{ eapply preord_exp_trans. tci. eapply eq_fuel_idemp.

              2:{ intros m. eapply preord_exp_Efun_red. }
              assert (Hex' : exists z, ~ In var (k1 |: FromList []) z).
              { eapply ToMSet_non_member. tci. } destructAll.

              eapply preord_exp_trans. tci. eapply eq_fuel_idemp.

              2:{ intros m. simpl. eapply H7; [ | | | | | | | eassumption | reflexivity | ].
                  - now constructor.
                  - eassumption.
                  - repeat normalize_sets. eapply Disjoint_Singleton_l.
                    unfold In. simpl. lia.
                  - eassumption.
                  - intros Hc. inv Hc.
                  - econstructor.
                  - rewrite M.gss. reflexivity.
                  - eassumption. }

              eapply preord_exp_Eapp_red.
              - rewrite M.gso; eauto. rewrite M.gss. reflexivity. intros Hc; subst; eauto.
              - simpl. rewrite Coqlib.peq_true. reflexivity.
              - simpl. rewrite M.gss. reflexivity.
              - simpl. reflexivity. }

          (* Invariant composition *)
          { unfold inclusion, comp, eq_fuel, one_step, cps_bound, one_i.
            intros [[[? ?] ?] ?] [[[? ?] ?] ?] ?.
            destructAll. destruct x4, x5. repeat destruct p, p0. subst. simpl. unfold fuel_exp. simpl. lia. } }

        assert (Hex : exists x, ~ In var (k |: FromList [x1]) x).
        { eapply ToMSet_non_member. tci. } destructAll.

        split.
        (* Termination *)
        { intros v v' Heq1 Hvrel. subst.

          eapply preord_exp_post_monotonic.

          2:{ eapply preord_exp_trans; [ | | | eassumption ]. tci. eapply eq_fuel_idemp.

              eapply preord_exp_trans. tci. eapply eq_fuel_idemp.

              2:{ intros m. eapply H8; [ | | | | | | | eassumption | reflexivity | eassumption ].
                  - constructor; eauto.
                  - simpl Datatypes.length. rewrite Nnat.Nat2N.inj_succ, <- OrdersEx.N_as_OT.add_1_l. eassumption.
                  - repeat normalize_sets. eapply Union_Disjoint_l; sets.
                    eapply Disjoint_Singleton_l. unfold In. simpl. lia.
                    eapply Disjoint_Singleton_l. unfold In. simpl. lia.
                  - eassumption.
                  - repeat normalize_sets. intros Hc; inv Hc; eauto.
                  - eapply cps_env_rel_extend_weaken; eauto.
                    eapply cps_env_rel_weaken; eauto. constructor.
                  - rewrite !M.gso. eassumption.
                    now eauto. now eauto. }

              eapply preord_exp_app_compat with (P2 := eq_fuel).
              now eapply eq_fuel_compat.
              now eapply eq_fuel_compat.

              eapply preord_var_env_extend_neq.
              eapply preord_var_env_extend_eq.
              eapply preord_val_refl. now tci.
              now eauto.

              now intros Hc; subst; eauto.
              constructor.
              eapply preord_var_env_extend_eq.
              eapply preord_val_refl. now tci. now constructor. }

          (* Invariant composition *)
          { unfold inclusion, comp, eq_fuel, one_step, cps_bound, one_i.
            intros [[[? ?] ?] ?] [[[? ?] ?] ?] ?.
            destructAll. destruct x5, x6. repeat destruct p, p0. subst.
            simpl in *. lia. } }

        (* OOT *)
        { intros ?; subst.

          edestruct H8 with (rho := M.set x1 x0 (M.set k1 (Vfun rho (Fcons k1 kon_tag [x1] e_cli' Fnil) k1) rho));
            [ | | | | | | | eassumption | ].
          - constructor; eauto.
          - eassumption.
          - repeat normalize_sets.
            eapply Union_Disjoint_l.
            eapply Disjoint_Singleton_l. unfold In. simpl. lia.
            eapply Disjoint_Singleton_l. unfold In. simpl. lia.
          - eassumption.
          - repeat normalize_sets. intros Hc; inv Hc; eauto.
          - eapply cps_env_rel_extend_weaken; eauto.
            eapply cps_env_rel_weaken; eauto. constructor.
          - rewrite !M.gso. eassumption.
            now eauto. now eauto.
          - destruct (H4 ltac:(reflexivity)). destructAll. eapply Heq in H6; [ | reflexivity ]. destructAll.
            destruct x6; try contradiction. destruct x8. eexists. split; [ | eassumption ].

            unfold one_i in *. simpl in *. lia. }

      + (* Let_e, OOT *)
        split. congruence.
        intros _.
        set (rho' := M.set k1 (Vfun rho (Fcons k1 kon_tag [x1] e_cli' Fnil) k1) rho).

        assert (Hex : exists x, ~ In var (k1 |: FromList []) x).
        { eapply ToMSet_non_member. tci. } destructAll.

        assert (Heval1 := H7). eapply cps_cvt_correct in H7; eauto.

        inv Hcps1. inv Hcps2.

        edestruct (H7 rho'); [ | | | | | | | eassumption | ].
        * constructor.
        * eassumption.
        * repeat normalize_sets.
          eapply Disjoint_Singleton_l. unfold In. simpl. lia.
        * eassumption.
        * intros Hc. inv Hc.
        * econstructor.
        * unfold rho'. rewrite M.gss. reflexivity.
        * edestruct H3. reflexivity. destructAll.
          exists (x4 + 1)%nat.
          split. unfold one_i. simpl. unfold fuel_exp. lia.
          replace tt with (tt <+> tt) by reflexivity. eapply BStepf_run. econstructor; eauto.

          Grab Existential Variables. exact 0%nat. exact 0%nat.

    Qed.

    Theorem cps_corrrect_top_sep_comp e_lib e_cli k1 k2 x1 x2 :
      exp_wf 0%N e_lib ->
      exp_wf 1%N e_cli ->

      x1 <> k2 ->
      k1 <> k2 ->
      x2 <> k2 ->

      exists e_cli' e_lib',
        cps_rel_top e_cli [x1] k2 e_cli' /\
        cps_rel_top e_lib [] k1 e_lib' /\
        refines 3 (link_src e_lib e_cli)
                (Efun (Fcons k2 kon_tag [x2] (Ehalt x2) Fnil) (link_trg k1 x1 e_lib' e_cli')).

    Proof.
      intros Hwf1 Hwf2 Hneq1 Hneq2 Hneq3.

      edestruct cps_rel_exists with (xs := @nil var).
      eassumption.
      eassumption.

      destructAll.

      edestruct cps_rel_exists with (xs := [x1]).
      eassumption.
      eassumption.

      destructAll.

      do 2 eexists. split; [ | split ].
      eexists. eassumption.
      eexists. eassumption.

      split.

      - intro; intros.
        edestruct linking_correct
          with (rho := M.set k2
                             (Vfun (M.empty _) (Fcons k2 kon_tag [x2] (Ehalt x2) Fnil) k2)
                             (M.empty _)) (x := x2).
        + eapply Hwf1.
        + eapply Hwf2.
        + eassumption.
        + eexists. eassumption.
        + eexists. eassumption.
        + now eauto.
        + now eauto.
        + now eauto.
        + rewrite M.gss. reflexivity.
        + clear H3.

          edestruct cps_val_rel_exists as [v2 Hval]. eassumption.
          eapply (@eval_env_step_preserves_wf nat LambdaBoxLocal_resource_fuel LambdaBoxLocal_resource_trace). eassumption. reflexivity. constructor.
          constructor.
          eassumption. eassumption.
          specialize (H2 v1 v2 eq_refl Hval).

          edestruct H2. reflexivity.

          econstructor 2. econstructor.
          rewrite M.gso. rewrite M.gss. reflexivity.
          now eauto.
          simpl. rewrite M.gss. reflexivity.
          simpl. rewrite Coqlib.peq_true. reflexivity.
          simpl. reflexivity.

          econstructor 2. econstructor. rewrite M.gss. reflexivity.

          destructAll. destruct x5. contradiction.

          destruct x7.

          do 2 eexists. split; [ | split ].

          replace tt with (tt <+> tt) by reflexivity.
          econstructor 2.
          econstructor. simpl. eassumption.

          simpl in *. unfold one, one_i. simpl. lia.
          simpl in *. eapply cps_val_comp. eassumption. eassumption.

      - intros Hdiv.

        intros c. specialize (Hdiv c). destructAll.
        edestruct linking_correct
          with (rho := M.set k2
                             (Vfun (M.empty _) (Fcons k2 kon_tag [x2] (Ehalt x2) Fnil) k2)
                             (M.empty _)) (x := x2).
        + eapply Hwf1.
        + eapply Hwf2.
        + eassumption.
        + eexists. eassumption.
        + eexists. eassumption.
        + now eauto.
        + now eauto.
        + now eauto.
        + rewrite M.gss. reflexivity.
        + clear H2.
          specialize (H3 eq_refl). destructAll.

          destruct c.

          * eexists. constructor. simpl.
            unfold one, one_i. simpl. lia.

          * eexists. replace (S c) with (c + 1)%nat by lia.
            econstructor 2. econstructor.
            simpl.
            edestruct Nat.le_exists_sub with (n := c) (m := x6). lia. destructAll.
            eapply bstep_fuel_OOT_monotonic in H3.
            destructAll. destruct x6. eassumption.

            Grab Existential Variables. exact 0%nat.
    Qed.

  End Linking.

End Refinement.