Require Import msl.msl_standard.
Require Import Maps.
Require Import FuncListMachine.
Require Import lemmas.
Require Import hoare_total.
Require Import wp.

(* This is some tentative work-in-progress *)

Fixpoint list_nat (n:nat) (x:value) {struct n} :=
  match n, x with
  | 0, value_label 1%positive => True
  | S n', value_cons (value_label 1%positive) x' => list_nat n' x'
  | _, _ => False
  end.

Fixpoint list_length (x:value) :=
  match x with
  | value_cons _ x' => S (list_length x')
  | _ => 0
  end.

Definition list_nat_var (n:nat) (v:var) (r:store) :=
  match r#v with
  | None => False
  | Some x => list_nat n x
  end.

Program Definition add_term_measure : termMeas :=
  fun r n =>
  match r#(V 1) with
  | Some x => list_length x = n
  | None => False
  end.
Next Obligation.
 destruct x as [ | x o0 x1] ; [contradiction H | ].
 destruct x; [ contradiction H | simpl in *] .
 destruct o; simpl in *;  [congruence | contradiction].
Qed.

Definition add_P' n m st :=
    list_nat_var n (V 1) st /\
    list_nat_var m (V 2) st.

Definition add_Q' n m st := list_nat_var (n+m) (V 2) st.

Definition add_P (nm:nat*nat) := store_op (add_P' (fst nm) (snd nm)).
Definition add_Q (nm:nat*nat) := store_op (add_Q' (fst nm) (snd nm)).

Definition valueTermMeas :=
  { R: value -> nat -> Prop |
    forall v n n', R v n -> R v n' -> n = n' }.

Record stdFunspec A :=
  { sfs_t     : valueTermMeas
  ; sfs_P     : A -> value -> pred prog
  ; sfs_Q     : A -> value -> pred prog
  }.

Implicit Arguments sfs_t.
Implicit Arguments sfs_P.
Implicit Arguments sfs_Q.

Program Definition value_to_store_termMeas (vt:valueTermMeas) : termMeas :=
  fun s n => match s#(V 0) with
             | Some v => proj1_sig vt v n
             | None   => False
             end.
Next Obligation.
  destruct x; simpl in *; intuition.
  destruct o; simpl in *; intuition.
  destruct vt; simpl in *.
  eauto.
Qed.

(* Define a simple calling convention for "standard"
   functions.  register 0 is for arguments and results.
   registers 1 2 3 and 4 are callee-saves registers,
   and registers >= 5 are caller-saves.

   It is not specified, but register 1 is usually
   used as a value stack.
 *)
Definition stdfun (l:label) (fs:{A:Type & stdFunspec A}) :=
  funptr l (projT1 fs * (value*value*value*value))
         (value_to_store_termMeas (sfs_t (projT2 fs)))
         (fun avs =>
           match avs with
             (a,(v1,v2,v3,v4)) =>
             EX v0:_,
             world_op
               (sfs_P (projT2 fs) a v0)
               (fun s =>
                 s#(V 0) = Some v0 /\
                 s#(V 1) = Some v1 /\
                 s#(V 2) = Some v2 /\
                 s#(V 3) = Some v3 /\
                 s#(V 4) = Some v4)
           end)
         (fun avs =>
           match avs with
             (a,(v1,v2,v3,v4)) =>
             EX v0:_,
             world_op
                (sfs_Q (projT2 fs) a v0)
                (fun s =>
                  s#(V 0) = Some v0 /\
                  s#(V 1) = Some v1 /\
                  s#(V 2) = Some v2 /\
                  s#(V 3) = Some v3 /\
                  s#(V 4) = Some v4)
           end).

Definition apply_P (fs:{ A:Type & stdFunspec A}) (x:projT1 fs) (v:value) : pred prog :=
  match v with
  | value_cons (value_label l) v' =>
       stdfun l fs && sfs_P (projT2 fs) x v'
  | _ => FF
  end.

Definition apply_Q (fs:{A :Type & stdFunspec A}) (x:projT1 fs) (v:value) : pred prog :=
  sfs_Q (projT2 fs) x v.

Program Definition apply_tm (fs:{A:Type & stdFunspec A}) : valueTermMeas :=
  fun v n =>
  match v, n with
  | value_cons (value_label l) v', S n' =>
      sfs_t (projT2 fs) v' n'
  | _, _ => False
  end.
Next Obligation.
  destruct v; simpl in *; intuition.
  discriminate.
  destruct v1; simpl in *; intuition; discriminate.
Qed.
Next Obligation.
 intros [? ?].
 inv H.
Qed.
Next Obligation.
 destruct v; simpl in *; try contradiction.
 destruct v1; simpl in *; try contradiction.
 destruct n; simpl in *; try contradiction.
 destruct n'; simpl in *; try contradiction.
 destruct fs; simpl in *.
 destruct s; simpl in *.
 destruct sfs_t0; simpl in *.
 f_equal; eapply e; eauto.
Qed.

Definition apply_fs (fs:{A:Type & stdFunspec A}) : {A:Type & stdFunspec A} :=
  existT _ (projT1 fs)
     (Build_stdFunspec (projT1 fs) (apply_tm fs) (apply_P fs) (apply_Q fs)).

Program Definition phi : map instruction :=
  set _ (set _ (set _ (set _ (set _ (set _ (empty _)

  (* The "map" wrapper function *)
  (L 5)
    ( (* push the values of V2 and V3 *)
      instr_cons (V 2) (V 1) (V 1) ;;
      instr_cons (V 3) (V 1) (V 1) ;;
      (* load the function pointer into V2 *)
      instr_fetch_field (V 0) 0 (V 2) ;;
      (* load the remainder of the list into V3 *)
      instr_fetch_field (V 0) 1 (V 3) ;;
      (* call the map worker function *)
      instr_getlabel (L 4) (V 5) ;;
      instr_call (V 5) ;;
      (* restore V3 *)
      instr_fetch_field (V 1) 0 (V 3) ;;
      instr_fetch_field (V 1) 1 (V 1) ;;
      (* restore V2 *)
      instr_fetch_field (V 1) 0 (V 2) ;;
      instr_fetch_field (V 1) 1 (V 1) ;;
      instr_return
    ))

  (* The "map" worker function *)
  (L 4)
    ( instr_if_nil (V 3)
       (*if nil, return nil *)
        ( instr_getlabel (L 0) (V 0) ;;
          instr_return )
       (*otherwise, recursive call*)
        ( (* get the head of the list *)
          instr_fetch_field (V 3) 0 (V 0) ;;
          (* call the mapping function *)
          instr_call (V 2) ;;
          (* push the mapped value *)
          instr_cons (V 0) (V 1) (V 1) ;;
          (* pop the head of the list *)
          instr_fetch_field (V 3) 1 (V 3) ;;
          (* recursive "map" call *)
          instr_getlabel (L 4) (V 5) ;;
          instr_call (V 5) ;;
          (* add the new list head *)
          instr_fetch_field (V 1) 0 (V 5) ;;
          instr_cons (V 5) (V 0) (V 0) ;;
          (* pop the stack *)
          instr_fetch_field (V 1) 1 (V 1) ;;
          instr_return
         )
       (* endif *)
    ))

  (* The "succ" function *)
  (L 3)
    ( instr_getlabel (L 0) (V 5) ;;
      instr_cons (V 5) (V 0) (V 0) ;;
      instr_return
    ))

  (* Set up a double-indirect call to succ.
     Call apply, which indirectly calls apply to
     call succ.
  *)
  (L 2)
    ( instr_getlabel (L 0) (V 0) ;;
      instr_getlabel (L 3) (V 1) ;;
      instr_getlabel (L 0) (V 2) ;;
      instr_getlabel (L 0) (V 3) ;;
      instr_getlabel (L 0) (V 4) ;;
      instr_cons (V 2) (V 0) (V 0) ;;
      instr_cons (V 2) (V 0) (V 0) ;;
      instr_cons (V 1) (V 0) (V 0) ;;
      instr_getlabel (L 1) (V 1) ;;
      instr_cons (V 1) (V 0) (V 0) ;;
      instr_call (V 1) ;;
      instr_return
    ))

  (* The "apply" function *)
  (L 1)
    ( instr_fetch_field (V 0) 0 (V 5) ;;
      instr_fetch_field (V 0) 1 (V 0) ;;
      instr_call (V 5) ;;
      instr_return
    ))

  (* An addition function *)
  (L 0)
    ( instr_assert (EX nm:_, add_P nm) ;;
      instr_if_nil (V 1)
        (*then *) (
          instr_return
        ) (*else *) (
          (instr_fetch_field (V 1) 0 (V 3) ;;
          instr_fetch_field (V 1) 1 (V 1) ;;
          instr_cons (V 3) (V 2) (V 2)) ;;
          instr_getlabel (L 0) (V 0) ;;
          (instr_call (V 0) ;;
           instr_return)
        )
    ).

Program Definition succ_fs : stdFunspec nat :=
  Build_stdFunspec nat
    (fun _ n => n = 0)
    (fun n v => !!(list_nat n v))
    (fun n v => !!(list_nat (S n) v)).

Definition succ_fs' : {A:Type & stdFunspec A} :=
  existT (fun X => stdFunspec X) nat succ_fs.

Lemma succ_verify : forall G,
  verify_prog phi G ->
  verify_prog
    phi
    (stdfun (L 3) succ_fs' && G).
Proof.
  intros.
  eapply verify_func_simple; auto.
  simpl. reflexivity.
  clear H.
Opaque get set funptr.
  simpl; intros.
  apply hoare_wp. simpl.
  intros [? ?].
  simpl. intuition.
  destruct a as [x [[[v1 v2] v3] v4]].
  destruct H0 as [v0 [? ?]].
  intuition.
  rewrite H7 in H5.
  inv H5.
  inv H3.
  simpl in H0.
  rewrite get_set_same.
  rewrite get_set_other. 2: discriminate.
  do 2 econstructor. intuition; eauto.
  inv H3.
  econstructor; split.
  2: repeat split;
    repeat (rewrite get_set_other; [ | discriminate]);
        try rewrite get_set_same; auto.
  simpl. auto.
Qed.

Section map_tm.
  Variable (f_tm : valueTermMeas).

  Fixpoint map_inner_tm (v:value) : nat -> Prop :=
    fun n =>
    match v with
      | value_label _ => n = 0
      | value_cons v1 v2 =>
          exists x1, exists x2,
           proj1_sig f_tm v1 x1 /\
           map_inner_tm v2 x2  /\
           n = 1 + x1 + 1 + x2
    end.

  Lemma map_inner_tm_fun : forall v x1 x2,
    map_inner_tm v x1 ->
    map_inner_tm v x2 ->
    x1 = x2.
  Proof.
    induction v; simpl; intros. congruence.
    destruct H as [a1 [a2 [? [? ?]]]].
    destruct H0 as [b1 [b2 [? [? ?]]]].
    subst.
    cut (a1 = b1 /\ a2 = b2).
    intuition congruence.
    split; auto.
    eapply (proj2_sig f_tm); eauto.
  Qed.
End map_tm.

Program Definition map_worker_tm (fs:{A:Type & stdFunspec A}) : termMeas :=
  fun s n =>
  match s#(V 3) with
  | Some v => map_inner_tm (sfs_t (projT2 fs)) v n
  | _ => False
  end.
Next Obligation.
 congruence.
Qed.
Next Obligation.
 simpl in *.
  destruct (x#4); simpl in *; intuition.
  eapply map_inner_tm_fun; eauto.
Qed.

Program Definition map_tm (fs:{A:Type & stdFunspec A}) : valueTermMeas :=
  fun v n =>
  match v, n with
  | value_cons _ v, S n'  =>
     map_inner_tm (sfs_t (projT2 fs)) v n'
  | _, _ => False
  end.
Next Obligation.
intros [? ?]. inv H.
Qed.
Next Obligation.
  destruct v. elim H.
  destruct n; destruct n'; try tauto.
  f_equal.
  eapply map_inner_tm_fun; eauto.
Qed.

Section map_pre_post.
  Variable A:Type.
  Variable P:A->value->pred prog.

  Fixpoint list_val_match (l:list A) (v:value) {struct l} : pred prog :=
    match l, v with
    | nil, value_label 1%positive => TT
    | x::l', value_cons v1 v2 => P x v1 && list_val_match l' v2
    | _, _ => FF
    end.
End map_pre_post.

Definition map_worker_pre (fs:{A:Type & stdFunspec A}) (x:value*label*list (projT1 fs)*value) :=
  match x with
    (v1,lab,l,v4) =>
    EX v3:_,
    world_op
      (stdfun lab fs &&
       list_val_match (projT1 fs) (sfs_P (projT2 fs)) l v3)
      (fun s =>
         s#(V 1) = Some v1 /\
         s#(V 2) = Some (value_label lab) /\
         s#(V 3) = Some v3 /\
         s#(V 4) = Some v4)
  end.

Definition map_worker_post (fs:{A:Type & stdFunspec A}) (x:value*label*list (projT1 fs)*value) :=
  match x with
    (v1,lab,l,v4) =>
    EX v0:_,
    world_op
      (stdfun lab fs &&
        list_val_match (projT1 fs) (sfs_Q (projT2 fs)) l v0)
      (fun s =>
         s#(V 0) = Some v0 /\
         s#(V 1) = Some v1 /\
         s#(V 2) = Some (value_label lab) /\
         s#(V 4) = Some v4)
  end.

Definition map_pre
  (fs:{A:Type & stdFunspec A})
  l
  (x:value) :=
  match x with
  | value_cons (value_label lab) v =>
      stdfun lab fs &&
      list_val_match (projT1 fs) (sfs_P (projT2 fs)) l v
  | _ => FF
  end.

Definition map_post
  (fs:{A:Type & stdFunspec A})
  l
  (x:value) :=
  list_val_match (projT1 fs) (sfs_Q (projT2 fs)) l x.

Definition map_spec (fs:{A:Type & stdFunspec A}) : {A:Type & stdFunspec A} :=
  existT (fun X => stdFunspec X) (list (projT1 fs))
    (Build_stdFunspec _ (map_tm fs) (map_pre fs) (map_post fs)).

Lemma map_worker_verify : forall G,
  verify_prog phi G ->
  verify_prog
    phi
    ((ALL fs:{A:Type & stdFunspec A},
         funptr (L 4) _ (map_worker_tm fs) (map_worker_pre fs) (map_worker_post fs)) && G).
Proof.
  intros.
Transparent get set.
  eapply verify_func; auto.
  simpl. reflexivity.
  clear H.
Opaque get set funptr.
  simpl; intros.
  apply hoare_wp. simpl.
  intros [? ?].
  simpl. intuition.
  destruct a as [[[v1 lab] l] v4].
  clear H2. unfold map_worker_pre in H0.
  destruct H0 as [v3 [[? ?] ?]].
  intuition.
  clear H.
  econstructor. intuition.
  eauto.
  destruct l; simpl in H2; [ left | right ].
  destruct v3; try (elim H2; fail).
  destruct l; try (elim H2; fail).
  split; auto.
  intros. inv H.
  unfold map_worker_post.
  simpl. exists (value_label 1%positive).
  intuition;
    repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
  destruct v3; try (elim H2; fail).
  destruct H2.
  split. eauto.
  do 2 econstructor; intuition.
  eauto.
  hnf in H5.
  unfold map_worker_tm in H5.
  simpl in H7.
  rewrite H7 in H5. simpl in H5.
  destruct H5 as [n0 [n1 [? [? ?]]]].
  subst n.
  exists (1+n0). exists (1+n1).
  split. 2: omega.
  inv H8.
  do 5 econstructor; intuition.
  exists n0.
  econstructor.
  intuition.
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
  eauto.
  2: apply H0.
  simpl.
  rewrite get_set_same; auto.
  simpl.
  instantiate (1:=(p0,(v1,(value_label lab),value_cons v3_1 v3_2,v4))).
  simpl. econstructor; intuition;
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
  eauto.
  simpl in H12.
  destruct a'.
  hnf in H8. simpl in H8. subst.
  destruct a'0.
  rewrite worldNec_unfold in H11.
  destruct H11; subst.
  destruct H12; intuition.
  do 2 econstructor; intuition; eauto.
  inv H16.
  do 2 econstructor. intuition;
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
  eauto.
  inv H16. inv H18.
  do 5 econstructor. exists n1.
  exists (value_cons x v1,lab,l,v4).
  intuition;
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
  2: eapply pred_nec_hereditary; [ | apply H1 ]; auto.
  unfold map_worker_tm. simpl.
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
  simpl. split.
  econstructor; intuition; auto.
  eapply pred_nec_hereditary; eauto.
  eapply pred_nec_hereditary; eauto.
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
  split. auto.
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
  simpl.
  exists n1. split. auto.
  omega.
  destruct a'. destruct a'0.
  inv H16. rewrite worldNec_unfold in H18.
  destruct H18; simpl in *; subst.
  destruct H19 as [? [? ?] ?]; intuition.
  do 2 econstructor; intuition; eauto.
  inv H23.
  do 2 econstructor; intuition;
    repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; eauto.
  inv H23.
  do 2 econstructor; intuition;
    repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; eauto.
  inv H23.
  exists (value_cons x x0); intuition.
  split; auto.
  eapply pred_nec_hereditary; eauto.
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
    repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
Qed.

Lemma map_verify : forall G,
    verify_prog phi G ->
    verify_prog
    phi
    ((ALL fs:{A:Type & stdFunspec A}, stdfun (L 5) (map_spec fs)) &&
    ((ALL fs:{A:Type & stdFunspec A},
         funptr (L 4) _ (map_worker_tm fs) (map_worker_pre fs) (map_worker_post fs))
        && G)).
Proof.
  intros.
Transparent get set.
  eapply verify_func.
  simpl. auto.
  2: apply map_worker_verify; auto.
  clear H.
Opaque get set funptr.
  simpl; intros.
  apply hoare_wp. simpl.
  intros [? ?].
  simpl. intuition.
  destruct a as [x [[[v1 v2] v3] v4]].
  destruct H0 as [v0 [? ?]]. intuition.
  rewrite H7 in H5.
  clear H H2.
  unfold map_pre in H0.
  destruct v0; try (elim H0; fail).
  destruct v0_1; try (elim H0; fail).
  destruct H0.
  do 2 econstructor; intuition; eauto.
  inv H2.
  do 2 econstructor; intuition;
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; eauto.
  inv H2.
  do 2 econstructor; intuition;
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; eauto.
  inv H2.
  do 2 econstructor; intuition;
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; eauto.
  inv H2; inv H10.
  simpl in H5.
  destruct n; try tauto.
  do 5 econstructor.
  exists n.
  exists (value_cons v3 (value_cons v2 v1),l,x,v4).
  intuition;
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
  unfold map_worker_tm. simpl.
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
  simpl. econstructor; intuition;
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
  eauto.
  destruct a'; destruct a'0.
  rewrite worldNec_unfold in H10.
  destruct H10; subst.
  destruct H12 as [? [? ?] ?]; intuition.
  do 2 econstructor; intuition;
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; eauto.
  inv H16.
  do 2 econstructor; intuition;
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; eauto.
  inv H16.
  do 2 econstructor; intuition;
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; eauto.
  inv H16.
  do 2 econstructor; intuition;
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; eauto.
  inv H16.
  destruct H2. simpl in *; subst.
  econstructor; intuition;
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; eauto.
Qed.

Lemma apply_verify : forall G,
  verify_prog phi G ->
  verify_prog
    phi
    ((ALL fs:{A:Type & stdFunspec A}, stdfun (L 1) (apply_fs fs)) && G).
Proof.
  intros.
Transparent get set.
  eapply verify_func; auto.
  simpl. reflexivity.
  clear H.
Opaque get set funptr.
  simpl; intros.
  apply hoare_wp. simpl.
  intros [? ?].
  simpl. intuition.
  destruct a as [x [[[v1 v2] v3] v4]].
  destruct H0 as [v0 [? ?]]. intuition.
  rewrite H6 in H5.
  unfold apply_tm in H5.
  destruct v0; try tauto.
  destruct v0_1; try tauto.
  destruct n; try tauto.
  do 2 econstructor.
  intuition; eauto.
  inv H9.
  do 2 econstructor.
  intuition; eauto.
  rewrite get_set_other. 2: discriminate.
  eauto.
  inv H9.
  do 5 econstructor.
  exists n.
  exists (x,(v1,v2,v3,v4)).
  econstructor.
  intuition.
  destruct H0.
  3: apply H0.
  rewrite get_set_other. 2: discriminate.
  rewrite get_set_same. auto.
  simpl.
  simpl. rewrite get_set_same. auto.
  simpl.
  destruct H0.
  econstructor. split. eauto.
  repeat split;
  repeat (rewrite get_set_other; [ | discriminate]);
    try rewrite get_set_same; auto.
  simpl. intros. auto.
Qed.

Lemma add_verify : forall G,
  verify_prog phi G ->
  verify_prog phi (funptr (L 0) _ add_term_measure add_P add_Q && G).
Proof.
  intros. eapply verify_func_simple; auto.

Transparent get set.
  simpl. reflexivity.
  intros.
Opaque get set funptr.
  intros. apply hoare_wp.
  subst Pr Pr'. simpl.
  intros [? ?].
  destruct a as [n1 m1]; simpl in *.
  simpl; intuition.
  exists (n1,m1). simpl; split; auto.
  intuition; subst; auto.
  destruct H6.
  hnf in H4, H6. simpl V in *.
  case_eq (s#2); intros;
    rewrite H8 in H4; try tauto.
  case_eq (s#3); intros;
    rewrite H9 in H6; try tauto.
  unfold add_term_measure in H7.
  simpl in H7; rewrite H8 in H7.
  inv H7.
  exists v; intuition.
  destruct n1; simpl in H4;
    destruct v; try tauto.
  destruct l; try tauto.
  left; simpl; intuition.
  hnf. simpl. rewrite H9. auto.
  destruct v1; try tauto.
  destruct l; try tauto.
  simpl in *.
  right; simpl; intuition.
  eauto.
  do 2 econstructor; intuition.
  inv H7.
  do 2 econstructor; intuition.
  rewrite get_set_other. 2: discriminate. eauto.
  inv H7.
  do 2 econstructor; intuition.
  rewrite get_set_other. 2: discriminate.
  rewrite get_set_same. auto.
  rewrite get_set_other. 2: discriminate.
  rewrite get_set_other. 2: discriminate.
  eauto.
  inv H7. inv H10.
  exists (L 0). exists (nat * nat)%type.
  exists add_term_measure.
  do 2 econstructor.
  exists (list_length v2).
  exists (n1, S m1).
  intuition.
  rewrite get_set_same. auto.
  unfold add_term_measure; simpl.
  rewrite get_set_other. 2: discriminate.
  rewrite get_set_other. 2: discriminate.
  rewrite get_set_same. auto.
  apply H2.
  simpl; intuition.
  split; hnf; simpl.
  rewrite get_set_other. 2: discriminate.
  rewrite get_set_other. 2: discriminate.
  rewrite get_set_same. auto.
  rewrite get_set_other. 2: discriminate.
  rewrite get_set_same. auto.
  exists (list_length v2).
  unfold add_term_measure. simpl.
  rewrite get_set_other. 2: discriminate.
  rewrite get_set_other. 2: discriminate.
  rewrite get_set_same. auto.
  destruct a' as [? ?].
  inv H7. simpl in *.
  destruct a'0 as [? ?].
  intuition; subst.
  apply worldNec_unfold in H10. destruct H10; subst.
  hnf in H13. hnf.
  simpl V in *.
  destruct (s1#3).
  replace (S n1 + m1) with (n1 + S m1) by omega. auto.
  auto.
Qed.

Program Definition main_tm : termMeas :=
  fun _ n => n = 5.

Let PROG_G :=
  (funptr (L 2) unit main_tm
                     (fun _ => TT)
                     (fun _ => store_op (fun r => exists v, r#(V 0) = Some v /\ list_nat 3 v))) &&
  ((stdfun (L 3) succ_fs') &&
   ((ALL fs:{A:Type & stdFunspec A}, stdfun (L 1) (apply_fs fs)) &&
    ((funptr (L 0) _ add_term_measure add_P add_Q) && TT))).

Lemma main_verify :
  verify_prog phi PROG_G.
Proof.
  unfold PROG_G.
  eapply verify_func_simple.
Transparent get set.
  simpl. reflexivity.
  2: apply succ_verify.
  2: apply apply_verify.
  2: apply add_verify.
  2: repeat intro; hnf; auto.
  intros.
Opaque get set funptr list_nat.
  apply hoare_wp; subst.
  simpl. intros [? ?]. subst Pr Pr'.
  simpl; intuition.
  inv H5.
  inv H7; inv H9; inv H10; inv H11; inv H12.
  clear H H0 H2 H8.
  do 2 econstructor; intuition;
      repeat (rewrite get_set_other; [ | discriminate]);
        try rewrite get_set_same; auto.
  inv H.
  do 2 econstructor; intuition;
      repeat (rewrite get_set_other; [ | discriminate]);
        try rewrite get_set_same; auto.
  inv H.
  do 2 econstructor; intuition;
      repeat (rewrite get_set_other; [ | discriminate]);
        try rewrite get_set_same; auto.
  inv H. inv H0.
  do 2 econstructor; intuition;
      repeat (rewrite get_set_other; [ | discriminate]);
        try rewrite get_set_same; auto.
  inv H.
  repeat (rewrite get_set_other; [ | discriminate]);
    try rewrite get_set_same; auto.
  do 5 econstructor.
  exists 2.
  evar (x1:value).
  evar (x2:value).
  evar (x3:value).
  evar (x4:value).
  exists (2,(x1,x2,x3,x4)).
  subst x1 x2 x3 x4.
  intuition.
  2: apply (H4 (apply_fs succ_fs')).
  simpl.
  repeat (rewrite get_set_other; [ | discriminate]);
    try rewrite get_set_same; auto.
  simpl.
  repeat (rewrite get_set_other; [ | discriminate]);
    try rewrite get_set_same; auto.
  econstructor; split.
  2: repeat split;
   repeat (rewrite get_set_other; [ | discriminate]);
    try rewrite get_set_same; auto.
  unfold apply_P.
  simpl. intuition.
Transparent list_nat.
  simpl. auto.
Opaque list_nat.
  simpl in H2.
  destruct H2.
  hnf in H. simpl in H. subst.
  destruct a'0.
  intuition.
  exists x. split; auto.
Qed.

Lemma main_totally_correct :
  forall r c,
    phi#(L 2) = Some c ->
    exists n', exists p', exists r',
      stepstar (K.squash (n',phi)) p'
        r ((c ;; instr_assert FF)::nil)
        r' nil /\
        exists v, r'#(V 0) = Some v /\ list_nat 3 v.
Proof.
  intros.
  generalize (verify_totally_correct PROG_G unit (fun _ => TT)
    (fun _ => store_op (fun r => exists v, r#(V 0) = Some v /\ list_nat 3 v))
    phi (L 2) main_tm tt); intros.
  spec H0. apply main_verify.
  spec H0. unfold PROG_G. hnf; simpl; intuition.
  spec H0 r. spec H0. intros; hnf. auto.
  spec H0 5.
  spec H0 c.
  spec H0. simpl; auto.
  spec H0. auto.
  destruct H0 as [p' [r' [? ?]]].
  econstructor.
  exists p'. exists r'.
  split; eauto.
  destruct H1; auto.
Qed.

(* For every store satisfying the addition precondition,
   calling the addition function will halt with a store
   satisfing the postcondition.
 *)

Transparent list_nat.
Lemma addition_totally_correct :
  forall r n m c,
    add_P' n m r ->
    phi#(L 0) = Some c ->
    exists n', exists p', exists r',
      stepstar (K.squash (n',phi)) p'
        r ((c ;; instr_assert FF)::nil)
        r' nil /\
      add_Q' n m r'.
Proof.
  intros.
  generalize (verify_totally_correct (funptr (L 0) _ add_term_measure add_P add_Q && TT) _ add_P add_Q phi (L 0) add_term_measure (n,m)); intros.
  spec H1. apply add_verify.
  repeat intro; hnf; auto.
  spec H1. hnf; simpl; intuition.
  spec H1 r. spec H1.
  simpl; intuition.
  spec H1 n c.
  spec H1.
  destruct H. simpl.
  unfold list_nat_var in *.
  simpl in *.
  destruct (r#2); auto.

  clear - H.
  revert v H; induction n; simpl; intros;
    destruct v; try tauto.
  destruct v1; try tauto.
  destruct l; try tauto.
  simpl. f_equal. auto.
  spec H1; auto.
  destruct H1 as [p' [r' [? ?]]].
  do 3 econstructor; split; eauto.
  destruct H2; auto.
Qed.


From iris_c.clang Require Import notations lang logic tactics.
From iris_c.lib Require Import int.

Section proof.
  Context `{clangG Σ}.

  Definition f : expr :=
    if: (!"x"@Tint8 != 0)
    then: (
      "x" <- !"x"@Tint8 - 1 ;;
      Ecall Tvoid "g" (Epair (Evar "x") (Evalue Vvoid)) ;;
      return: void)
    else: ( return: void ).

  Definition g : expr :=
    if: (!"x"@Tint8 != 0)
    then: (
      "x" <- !"x"@Tint8 - 1 ;;
      Ecall Tvoid "f" (Epair (Evar "x") (Evalue Vvoid));;
      return: void)
    else: ( return: void ).

  Definition rec_env n : env := (sset "x" (Tptr Tint8, Vptr n) semp).

  Definition Pn : Prop :=
    (∀ n: nat, Byte.repr n = ((Z.pos (Pos.of_succ_nat n) - 1%Z)%int)) ∧
    (∀ n: nat, evalbop oneq (Z.pos (Pos.of_succ_nat n)) 0%Z = Some vtrue).

  Lemma rec_example (ln: addr) (n: nat) k ks Φ:
    Pn →
    ln ↦ n @ Tint8 ∗
    "f" T↦ Function Tvoid [("x", Tptr Tint8)] f ∗
    "g" T↦ Function Tvoid [("x", Tptr Tint8)] g ∗ (WP (fill_ectxs void k, ks) {{ Φ }})
    ⊢ WP (fill_ectxs (Ecall Tvoid "f"
                            (Evalue (Vpair ln void))) k, ks) {{ Φ }}.
  Proof.
    iIntros (Hn) "[Hn [#? [#? HΦ]]]".
    iLöb as "IH" forall (n k ks Φ Hn). destruct ks.
    iApply (wp_call (rec_env ln) e _ (Vpair ln Vvoid) [("x", Tptr Tint8)])=>//.
    destruct n eqn:?; subst; iFrame "#"; iNext.
    - unfold f. wp_var. by wp_run.
    - unfold f. wp_var. wp_run=>//.
      { destruct Hn as [H1 H2].
        specialize H2 with n0. done. }
      wp_step. iNext. wp_var. wp_var. wp_run.
      wp_unfill (Ecall _ _ _).
      rewrite (fill_app (Evar "x")
                        [EKcall Tvoid "g"; EKpairl void]).
      iApply wp_bind=>//.
      wp_var. iApply wp_value=>//.
      wp_unfill (Ecall _ _ _).
      rewrite (fill_app (Epair ln void)
                        [EKcall Tvoid "g"]).
      iApply wp_bind=>//. wp_pair.
      iApply wp_value=>//.
      replace ((Z.pos (Pos.of_succ_nat n0) - 1%Z)%int)
        with (Byte.repr n0).
      iApply (wp_call (rec_env ln) (rec_env ln)
                         [EKseq (return: void)] (Vpair ln void)
                         [("x", Tptr Tint8)]);
        last iFrame "#"; first done.
      iNext. unfold g. wp_var. wp_load.
      destruct n0 eqn:Heqn; subst.
      + wp_run. simpl. wp_run. done.
      + simpl.
        wp_op=>//.
        { destruct Hn as [H1 H2]. simpl. apply H2. }
        wp_step. iApply wp_seq=>//. wp_run.
        wp_unfill (Ecall _ _ _)%E.
        rewrite (fill_app (Evar "x")
                          [EKcall Tvoid "f"; EKpairl void]).
        iApply wp_bind=>//.
        wp_var. iApply wp_value=>//.
        wp_unfill (Ecall _ _ _).
        rewrite (fill_app (Epair ln void) [EKcall Tvoid "f"]).
        iApply wp_bind=>//. wp_pair.
        iApply wp_value=>//.
        wp_unfill (Ecall _ _ _).
        replace (Z.pos (Pos.of_succ_nat n) - 1%Z)%int
        with (Byte.repr n).
        iDestruct ("IH" $! n) as "IH'".
        iDestruct ("IH'" $! _ _ _ with "[]") as "?"=>//.
        iApply ("~2" with "[-HΦ]")=>//.
        simpl. wp_run. simpl. wp_run.
        { by destruct Hn as [? ?]. }
        { by destruct Hn as [? ?]. }
      + by destruct Hn as [? ?].
  Qed.

End proof.


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 Scenario2  (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_OrdinaryStakeLose_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_onSuccessToRecoverStake  msg_value_onSuccessToRecoverStake msg_sender_onSuccessToRecoverStake : Z)
                        (NetParams_onSuccessToRecoverStake :  NetParams)
                        (now_toWaitingReward  msg_value_toWaitingReward msg_sender_toWaitingReward : Z)
                        (NetParams_toWaitingReward :  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_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 ??;
                        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 ?;
                        $ 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= false ->
(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 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
 /\ current_stakes ->> RoundsBase_ι_StakeValue_ι_ordinary  = stake.
Proof.

Abort.
End Scenario2.


Require Import location error String micheline_pp ZArith.

Open Scope string.

Definition location_pp (l : location) : string :=
  "line " ++ string_of_Z (Z.of_nat l.(line)) ++ " column " ++ string_of_Z (Z.of_nat l.(column)).

Definition exception_pp (e : exception) : string :=
  match e with
  | Out_of_fuel => "Out of execution fuel"
  | Overflow => "Overflow"
  | Assertion_Failure _ _ => "Assertion failure"
  | Lexing l => "Lexing error at " ++ location_pp l
  | Parsing => "Parsing error"
  | Parsing_Out_of_Fuel => "Out of parsing fuel"
  | Expansion b e => "Expansion error between " ++ location_pp b ++ " and " ++ location_pp e
  | Expansion_prim b e s => "Unknown primitive " ++ s ++ " between " ++ location_pp b ++ " and " ++ location_pp e
  | Typing _ _ => "Typing error"
  end.

Definition m_pp {A} (m : M A) : string :=
  match m with
  | Return _ => "OK"
  | Failed _ e => exception_pp e
  end.


Require Import VST.msl.seplog.
Require Import VST.msl.sepalg.
Require Import VST.msl.psepalg.
Require Import VST.msl.alg_seplog_direct.
Require Import RamifyCoq.msl_ext.abs_addr.
Require Import RamifyCoq.msl_ext.seplog.
Require Import RamifyCoq.msl_ext.overlapping_direct.
Require Import RamifyCoq.msl_ext.alg_seplog_direct.
Require Import RamifyCoq.msl_ext.ramify_tactics.
Require Import RamifyCoq.heap_model_direct.SeparationAlgebra.
Require Import RamifyCoq.heap_model_direct.mapsto.
Require Import VST.msl.msl_direct.
Require Import VST.msl.predicates_sa.

Instance Ndirect : NatDed (pred world) := algNatDed world.
Instance Sdirect : SepLog (pred world) := algSepLog world.
Instance Cldirect : ClassicalSep (pred world) := algClassicalSep world.
Instance CSLdirect : CorableSepLog (pred world) := algCorableSepLog world.
Instance PSLdirect : PreciseSepLog (pred world) := algPreciseSepLog world.
Instance OSLdirect : OverlapSepLog (pred world) := algOverlapSepLog world.
Instance DSLdirect : DisjointedSepLog (pred world) := algDisjointedSepLog world.

Instance MSLdirect : MapstoSepLog AbsAddr_world mapsto.
Proof.
  apply mkMapstoSepLog.
  apply mapsto__precise.
Defined.

Instance sMSLdirect : StaticMapstoSepLog AbsAddr_world mapsto.
Proof.
  apply mkStaticMapstoSepLog; simpl; intros.
  + hnf in H. simpl in H. unfold adr_conflict in H. destruct (eq_nat_dec p p).
    - inversion H.
    - exfalso; tauto.
  + apply mapsto_conflict.
    unfold adr_conflict in H.
    destruct (eq_nat_dec p1 p2); congruence.
  + apply disj_mapsto_.
    unfold adr_conflict in H.
    destruct (eq_nat_dec p1 p2); congruence.
Defined.

Instance nMSLdirect : NormalMapstoSepLog AbsAddr_world mapsto.
Proof.
  apply mkNormalMapstoSepLog.
  apply mapsto_inj.
Defined.


(* *********************************************************************)
(*                                                                     *)
(*              The L2C verified compiler                              *)
(*                                                                     *)
(*            L2C Group, Tsinghua University                           *)
(*                                                                     *)
(*  Copyright Tsinghua University.  All rights reserved.  This file is *)
(*  distributed under the terms of the GNU General Public License as   *)
(*  published by the Free Software Foundation, either version 2 of the *)
(*  License, or (at your option) any later version.  This file is also *)
(*  distributed under the terms of the INRIA Non-Commercial License    *)
(*  Agreement.                                                         *)
(*                                                                     *)
(* *********************************************************************)

Require Import Coqlib.
Require Import AST.
Require Import Errors.
Require Import Memdata.
Require Import Lint.
Require Import Integers.
Require Import Ctypes.
Require Import Cltypes.

Definition sizeof_fld(fld: fieldlist):=
  align (sizeof_struct fld 0) (alignof_fields fld).

Lemma sizeof_fld_pos:
  forall fld, 0 <= sizeof_fld fld.
Proof.
  unfold sizeof_fld. intros.
  apply Zle_trans with (sizeof_struct fld 0); try omega.
  apply sizeof_struct_incr; auto.
  apply align_le. apply alignof_fields_pos.
Qed.

Lemma field_offset_in_range_simpl:
  forall id fld delta ty,
  field_offset id fld = OK delta ->
  field_type id fld = OK ty ->
  0 <= delta /\ delta + sizeof ty <= sizeof_fld fld.
Proof.
  intros.
  apply field_offset_in_range with (sid:=xH) (ty:=ty) in H; auto.
Qed.

Lemma field_offset_unsigned_repr:
  forall id fld z ty,
  field_offset id fld = OK z ->
  field_type id fld = OK ty ->
  sizeof_fld fld <= Int.max_unsigned ->
  Int.unsigned (Int.repr z) = z.
Proof.
  intros.
  eapply field_offset_in_range_simpl in H; eauto.
  generalize (sizeof_pos ty); intros.
  rewrite Int.unsigned_repr; try omega.
Qed.

Lemma field_offset_rec_type_exists:
  forall fld fid ofs pos,
  field_offset_rec fid fld pos = OK ofs ->
  exists ty, field_type fid fld = OK ty.
Proof.
  induction fld; simpl; intros.
  inv H.
  destruct (ident_eq _ _); eauto.
Qed.

Lemma field_offset_type_exists:
  forall fld fid ofs,
  field_offset fid fld = OK ofs ->
  exists ty, field_type fid fld = OK ty.
Proof.
  unfold field_offset. intros.
  eapply field_offset_rec_type_exists; eauto.
Qed.

Lemma field_type_offset_rec_exists:
  forall fld fid ty pos,
  field_type fid fld = OK ty ->
  exists ofs, field_offset_rec fid fld pos = OK ofs.
Proof.
  induction fld; simpl; intros.
  congruence.
  destruct (ident_eq fid i).
  inv H. eauto.
  eapply IHfld; eauto.
Qed.

Lemma field_type_offset_exists:
  forall fld fid ty,
  field_type fid fld = OK ty ->
  exists ofs, field_offset fid fld = OK ofs.
Proof.
  unfold field_offset. intros.
  eapply field_type_offset_rec_exists; eauto.
Qed.

Definition fieldlist_of(vas: list (ident*type)): fieldlist :=
  fold_right (fun p=> Fcons (fst p) (snd p)) Fnil vas.

Lemma fieldlist_list_in:
  forall al id ty,
  field_type id (fieldlist_of al) = OK ty ->
  In (id, ty) al.
Proof.
  induction al; simpl; intros.
  inv H.
  destruct a. simpl in *.
  compare id i; intros.
  subst. rewrite peq_true in *. inv H; auto.
  rewrite peq_false in *; eauto.
Qed.

Lemma list_in_fieldlist:
  forall al id ty,
  In (id, ty) al ->
  list_norepet (map fst al) ->
  field_type id (fieldlist_of al) = OK ty.
Proof.
  induction al; intros.
  +inv H.
  +inv H0. destruct H; subst; simpl.
   -rewrite peq_true; auto.
   -assert(id <> fst a).
      apply in_map with _ _ fst _ _ in H; eauto.
      simpl in H. red; intros. subst. auto.
    repeat rewrite peq_false; auto.
Qed.

Lemma fieldlist_list_in_offset_exists:
  forall al id pos,
  In id (map fst al) ->
  exists delta, field_offset_rec id (fieldlist_of al) pos = OK delta.
Proof.
  induction al; simpl; intros.
  +inv H.
  +destruct H; subst; simpl.
   -rewrite peq_true; eauto.
   -destruct (ident_eq id (fst a)) eqn:?; eauto.
Qed.

Lemma fieldlist_list_id_in:
  forall al id delta pos,
  field_offset_rec id (fieldlist_of al) pos = OK delta ->
  In id (map fst al).
Proof.
  induction al; simpl; intros.
  inv H.
  compare id (fst a); intros.
  subst. rewrite peq_true in *. inv H; auto.
  rewrite peq_false in *; eauto.
Qed.

Lemma fieldlist_list_notin:
  forall al id pos msg,
  field_offset_rec id (fieldlist_of al) pos = Error msg ->
  ~ In id (map fst al).
Proof.
  induction al; simpl; intros; auto.
  compare (fst a) id; intros; subst.
  rewrite peq_true in H. inv H.
  rewrite peq_false in H; auto.
  red. intros. destruct H0; auto.
  eapply IHal; eauto.
Qed.

Lemma field_type_notin_app:
  forall l1 l2 id,
  ~ In id (map fst l1) ->
  field_type id (fieldlist_of (l1++l2)) = field_type id (fieldlist_of l2).
Proof.
  induction l1; simpl; intros; eauto.
  rewrite peq_false; auto.
Qed.

Lemma fieldlist_list_notin_inv:
  forall al id pos,
  ~ In id (map fst al) ->
  exists msg, field_offset_rec id (fieldlist_of al) pos = Error msg.
Proof.
  induction al; simpl; intros; eauto.
  rewrite peq_false; auto.
Qed.

Lemma field_type_offset_error_rec:
  forall fld id msg1 pos,
  field_type id fld = Error msg1 ->
  exists msg2, field_offset_rec id fld pos = Error msg2.
Proof.
  induction fld; simpl; intros; eauto.
  destruct (ident_eq _ _); try congruence.
  eauto.
Qed.

Lemma field_type_offset_error:
  forall fld id msg1,
  field_type id fld = Error msg1 ->
  exists msg2, field_offset id fld = Error msg2.
Proof.
  intros. apply field_type_offset_error_rec with msg1; auto.
Qed.

Lemma field_type_ok_app:
  forall l1 l2 id ty,
  field_type id (fieldlist_of l1) = OK ty ->
  field_type id (fieldlist_of (l1 ++ l2))  = OK ty.
Proof.
  induction l1; simpl; intros.
  congruence.

  destruct a; simpl in *.
  compare id i; intros ; subst.
  rewrite peq_true in *; auto.
  rewrite peq_false in *; auto.
Qed.

Lemma field_offset_rec_fieldlist_of_notin_app_cons:
  forall id ty l1 l2 z,
  ~ In id (map fst l1) ->
  field_offset_rec id (fieldlist_of (l1 ++ (id, ty) :: l2)) z = OK (align (sizeof_struct (fieldlist_of l1) z) (alignof ty)).
Proof.
  induction l1; simpl; intros; auto.
  +rewrite peq_true; auto.
  +rewrite peq_false; auto.
Qed.

Lemma sizeof_struct_fieldlist_of_app_cons:
  forall l id ty z,
  sizeof_struct (fieldlist_of (l ++ (id, ty) :: nil)) z =
  align (sizeof_struct (fieldlist_of l) z) (alignof ty) + sizeof ty.
Proof.
  induction l; simpl; auto.
Qed.

Definition access_mode (ty: type) : mode :=
  match ty with
  | Tint I8 Signed => By_value Mint8signed
  | Tint I8 Unsigned => By_value Mint8unsigned
  | Tint I16 Signed => By_value Mint16signed
  | Tint I16 Unsigned => By_value Mint16unsigned
  | Tint I32 _ => By_value Mint32
  | Tint IBool _ => By_value Mint8unsigned
  | Tfloat F32 => By_value Mfloat32
  | Tfloat F64 => By_value Mfloat64
  | Tvoid => By_nothing
  | Tpointer _ => By_nothing
  | Tarray _ _ _ => By_reference
  | Tfunction _ _ _ => By_nothing
  | Tstruct _ _ => By_copy
end.

Definition typeof_array(t: type): res (type*Z) :=
  match t with
  | Tarray _ ty num => OK (ty,num)
  | _ => Error (MSG "Not Tarray " :: nil)
  end.

Definition fieldof_struct(t: type): res fieldlist :=
  match t with
  | Tstruct _ fld => OK fld
  | _ => Error (MSG "Not Tstruct " :: nil)
  end.

Lemma access_mode_eq:
  forall t, (exists c, access_mode t = By_value c) \/ access_mode t = By_copy \/ access_mode t = By_reference ->
  access_mode t = Cltypes.access_mode t.
Proof.
  destruct t; simpl; intros; auto;
  destruct H as [? | [? | ?]]; inv H; inv H0.
Qed.

Lemma sizeof_chunk_eq:
  forall t chunk,
  access_mode t = By_value chunk ->
  size_chunk chunk = sizeof t.
Proof.
  destruct t; intros; inv H; simpl; auto.
  destruct i; destruct s; inv H1; auto.
  destruct f; inv H1; auto.
Qed.

Lemma alignof_chunk_eq:
  forall ty chunk,
  access_mode ty = By_value chunk ->
  alignof ty = align_chunk chunk.
Proof.
  induction ty; simpl; intros; try congruence; auto.
  destruct i,s; inv H; auto.
  destruct f; inv H; auto.
Qed.

Lemma field_type_alignof_le:
  forall i f t,
  field_type i f = OK t ->
  alignof t <= alignof_fields f.
Proof.
  induction f; simpl; intros.
  congruence.
  destruct (ident_eq _ _).
  +inv H. apply zmax_l_le. omega.
  +apply zmax_r_le. auto.
Qed.

Lemma field_type_alignof:
  forall i f t,
  field_type i f = OK t ->
  (alignof t | alignof_fields f).
Proof.
  intros. generalize (alignof_1248 t).
  generalize (alignof_fields_1248 f).
  apply field_type_alignof_le in H. intros.
  destruct H0 as [ | [ | [ | ]]]; destruct H1 as [ | [ | [ | ]]];
  rewrite H0,H1 in *; try omega; try (exists 1; omega; fail);
  try (exists 2; omega; fail) .
  exists 4; omega. exists 8. omega. exists 4. omega.
Qed.

Definition is_arystr(t: type): bool :=
  match t with
  | Tarray _ _ _ => true
  | Tstruct _ _ => true
  | _ => false
  end.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University

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

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

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

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

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

*)

Require Export terms2.
Require Export terms_tacs.
Require Export tactics2.

(* ------ binary and ------ *)

Definition mk_uand {p} (A B : @NTerm p) :=
  match newvars2 [A,B] with
    | (vx,vy) =>
      mk_isect mk_base vx
               (mk_isect (mk_halts (mk_var vx)) vy
                         (mk_isaxiom (mk_var vx) A B))
  end.

Lemma isprog_vars_uand {o} :
  forall (A B : @NTerm o) vs,
    isprog_vars vs (mk_uand A B) <=> (isprog_vars vs A # isprog_vars vs B).
Proof.
  introv.
  unfold mk_uand.
  remember (newvars2 [A,B]); repnd.
  apply newvars2_prop2 in Heqp; simpl in Heqp.
  allrw app_nil_r; allrw in_app_iff; allrw not_over_or; repnd.
  repeat (rw <- @isprog_vars_isect_iff).
  rw @isprog_vars_isaxiom.
  rw @isprog_vars_halts.
  allrw <- @isprog_vars_var_iff; simpl; split; intro k; repnd; dands; auto.
  repeat (apply isprog_vars_cons_if2 in k3; auto).
  repeat (apply isprog_vars_cons_if2 in k; auto).
  repeat (apply isprog_vars_cons; auto).
  repeat (apply isprog_vars_cons; auto).
Qed.

Lemma wf_uand {o} :
  forall a b : @NTerm o, wf_term (mk_uand a b) <=> (wf_term a # wf_term b).
Proof.
  introv.
  unfold mk_uand.
  remember (newvars2 [a,b]); repnd.
  apply newvars2_prop2 in Heqp; simpl in Heqp.
  allrw app_nil_r; allrw in_app_iff; allrw not_over_or; repnd.
  allrw <- @wf_isect_iff.
  rw <- @wf_halts_iff.
  rw @wf_isaxiom; split; sp.
Qed.

(* ------ free vars ------ *)

Lemma free_vars_lam {o} :
  forall v b, free_vars (@mk_lam o v b) = remove_nvars [v] (free_vars b).
Proof.
  introv; simpl.
  rw app_nil_r; sp.
Qed.

Lemma free_vars_isect {o} :
  forall a v b, free_vars (@mk_isect o a v b) = free_vars a ++ (remove_nvars [v] (free_vars b)).
Proof.
  introv; simpl.
  rw app_nil_r; sp.
Qed.

Lemma free_vars_function {o} :
  forall a v b, free_vars (@mk_function o a v b) = free_vars a ++ (remove_nvars [v] (free_vars b)).
Proof.
  introv; simpl.
  rw app_nil_r; sp.
Qed.

Lemma free_vars_product {o} :
  forall a v b, free_vars (@mk_product o a v b) = free_vars a ++ (remove_nvars [v] (free_vars b)).
Proof.
  introv; simpl.
  rw app_nil_r; sp.
Qed.

Lemma free_vars_tunion {o} :
  forall a v b, free_vars (@mk_tunion o a v b) = free_vars a ++ (remove_nvars [v] (free_vars b)).
Proof.
  introv; simpl.
  rw app_nil_r; sp.
Qed.

Lemma free_vars_cbv {o} :
  forall a v b, free_vars (@mk_cbv o a v b) = free_vars a ++ (remove_nvars [v] (free_vars b)).
Proof.
  introv; simpl.
  rw app_nil_r; sp.
Qed.

Lemma free_vars_base {o} :
  free_vars (@mk_base o) = [].
Proof.
  introv; simpl; sp.
Qed.

Lemma free_vars_axiom {o} :
  @free_vars o mk_axiom = [].
Proof.
  introv; simpl; sp.
Qed.

Lemma free_vars_approx {o} :
  forall a b, free_vars (@mk_approx o a b) = free_vars a ++ free_vars b.
Proof.
  introv; simpl.
  rw app_nil_r; sp.
Qed.

Lemma free_vars_isaxiom {o} :
  forall a b c, free_vars (@mk_isaxiom o a b c) = free_vars a ++ free_vars b ++ free_vars c.
Proof.
  introv; simpl.
  rw app_nil_r; sp.
Qed.

Lemma free_vars_equality {o} :
  forall a b c, free_vars (@mk_equality o a b c) = free_vars a ++ free_vars b ++ free_vars c.
Proof.
  introv; simpl.
  rw app_nil_r; sp.
Qed.

Lemma free_vars_tequality {o} :
  forall a b, free_vars (@mk_tequality o a b) = free_vars a ++ free_vars b.
Proof.
  introv; simpl.
  rw app_nil_r; sp.
Qed.

Lemma free_vars_apply {o} :
  forall a b, free_vars (@mk_apply o a b) = free_vars a ++ free_vars b.
Proof.
  introv; simpl.
  rw app_nil_r; sp.
Qed.

Lemma free_vars_union {o} :
  forall a b : @NTerm o, free_vars (mk_union a b) = free_vars a ++ free_vars b.
Proof.
  introv; simpl.
  rw app_nil_r; sp.
Qed.

Lemma free_vars_eunion {o} :
  forall a b : @NTerm o, free_vars (mk_eunion a b) = free_vars a ++ free_vars b.
Proof.
  introv; simpl.
  rw app_nil_r; sp.
Qed.

Lemma free_vars_halts {o} :
  forall a, free_vars (@mk_halts o a) = free_vars a.
Proof.
  introv.
  unfold mk_halts.
  rw @free_vars_approx.
  rw @free_vars_cbv.
  rw @free_vars_axiom.
  rw remove_nvars_nil_r; rw app_nil_r; simpl; sp.
Qed.

Lemma free_vars_uand {o} :
  forall A B, free_vars (@mk_uand o A B) = free_vars A ++ free_vars B.
Proof.
  introv.
  unfold mk_uand.

  remember (newvars2 [A,B]); repnd.
  apply newvars2_prop2 in Heqp; simpl in Heqp.
  repeat (rw app_nil_r in Heqp); repeat (rw in_app_iff in Heqp).
  repeat (rw not_over_or in Heqp); repnd.

  repeat rw @free_vars_isect.

  rw @free_vars_halts.
  rw @free_vars_base.
  rw @free_vars_isaxiom; simpl.
  repeat (rw remove_nvars_cons_r; boolvar; allrw not_over_or; repnd; spFalseHyp).
  rw remove_nvars_app_l; simpl.
  rw remove_nvars_app_r.
  repeat (rw remove_nvars_cons_l_weak; sp).
Qed.

Lemma free_vars_decide {o} :
  forall (a : @NTerm o) v1 b1 v2 b2,
    free_vars (mk_decide a v1 b1 v2 b2)
    = free_vars a
                ++ remove_nvars [v1] (free_vars b1)
                ++ remove_nvars [v2] (free_vars b2).
Proof.
  introv; simpl.
  rw app_nil_r; sp.
Qed.

Lemma free_vars_spread {o} :
  forall (a : @NTerm o) v1 v2 b,
    free_vars (mk_spread a v1 v2 b)
    = free_vars a ++ remove_nvars [v1,v2] (free_vars b).
Proof.
  introv; simpl.
  rw app_nil_r; sp.
Qed.

Lemma free_vars_unit {o} :
  @free_vars o mk_unit = [].
Proof.
  unfold mk_unit, mk_true.
  rw @free_vars_approx; rw @free_vars_axiom; auto.
Qed.

Lemma free_vars_bool {o} :
  @free_vars o mk_bool = [].
Proof.
  unfold mk_bool.
  rw @free_vars_union.
  rw @free_vars_unit; auto.
Qed.