From Coq Require Import List Lia.
From PCC Require Import list_utils java_basic_defs program_model expressions_assertions semantics_assertions weakest_precondition.
From PCC Require Import ssrexport.

(* The default variable denotes an assertion that expresses that
   all variables have their default values. *)
Variable default : ast.

Hypothesis initial_default : forall c, initial_conf c -> ∥ default ∥ c.

Section validity.

  Variable p: program.

  (* An execution is valid if each config satisfies the assertion of the current
     program point and inv holds whenever a config is calling or returning. *)
  Inductive valid_conf c : Prop :=
  | v_conf : (* TODO: change into a def. *)
      (visible_conf p c -> ∥ inv p ∥ c) ->
      (normal_conf c -> forall a, current_ast p c = Some a -> ∥ a ∥ c) ->
      valid_conf c.

  Inductive valid_exec : execution -> Prop :=
  | ve_nil : valid_exec nil
  | ve_cons :
    forall c cs,
      valid_conf c ->
      valid_exec cs ->
      valid_exec (cs++c::nil).

  Lemma all_valid : forall e, valid_exec e <-> forall c, In c e -> valid_conf c.
    split.

    (* -> *)
    intros.
    destruct e using rev_ind.
    inversion H0.
    inversion H.
    apply app_cons_not_nil in H2.
    contradiction.

    apply in_but_not_last in H0.
    elim H0; intros.

    apply app_inj_tail in H1.
    elim H1; intros; subst.
    assumption.

    apply IHe.
    apply app_inj_tail in H1.
    elim H1; intros; subst.
    assumption.
    assumption.

    (* <- *)
    intros.
    destruct e using rev_ind.
    apply ve_nil.
    apply ve_cons.
    apply H.
    apply in_or_app.
    right.
    auto with datatypes.
    apply IHe.
    intros.
    apply H.
    apply in_or_app.
    left.
    assumption.
  Qed.

  Definition globally_valid : Prop := forall e, execution_of p e -> valid_exec e.

  Definition locally_valid_meth cid mid : Prop :=
    (forall c, ∥ inv p ∥ c -> ∥ ast_at p cid mid O ∥ c) /\
    (forall c l, ∥ ast_at p cid mid l ∥ c -> ∥ wp p cid mid l ∥ c).

  Definition locally_valid : Prop :=
    (forall cid mid, locally_valid_meth cid mid) /\
    (forall c, ∥ default ∥ c -> ∥ ast_at p maincid mainmid O ∥ c) /\
    (forall c, ∥ default ∥ c -> ∥ inv p ∥ c).

(* aload n *)
Lemma wp_correct_normal_aload : forall c m pc s ls h n ars gv,
  instr_at p c m pc = aload n ->
  (∥wp p c m pc ∥ (gv, h, normal c m pc s ls :: ars) <->
  ∥ast_at p c m (successor p c m pc) ∥ (gv, h, normal c m (successor p c m pc) (ls n :: s) ls :: ars)).
Proof.
  intros.
  unfold wp.
  rewrite H.
  set (a := ast_at p c m (successor p c m pc)) in * |- *.
  set (cnf := (gv, h, normal c m pc s ls :: ars)) in * |- *.
  set (cnf' := (gv, h, normal c m (successor p c m pc) (ls n::s) ls :: ars)) in * |- *.

  assert (expr_lemma: forall e val, eeval (eunshift (subste e (local n) (stackexp 0))) cnf val <-> (eeval e cnf' val)).
    intros e.
    induction e; intros.
    (* v *)
    split; intros.
    simpl in H0.
    inversion H0; subst.
    apply e_val.
    inversion H0; subst.
    simpl.
    apply e_val.
    apply e_ghosterr.
    inversion H0; subst.
    simpl.
    apply e_val.
    simpl.
    apply e_ghosterr.

    (* ghost var *)
    assert (H_gv: ghost_valuation_of cnf = ghost_valuation_of cnf'). auto.
    split; intros.
    inversion H0; subst.
    rewrite H_gv.
    apply e_ghostvar.
    simpl.
    inversion H0; subst.
    rewrite <- H_gv.
    apply e_ghostvar.

    (* nsfield *) split; intros. simpl in H0.
    inversion H0; subst.
    apply IHe in H4.
    apply (e_nsfield gv cnf' e dh sh (normal c m (successor p c m pc) (ls n::s) ls :: ars) f l obj).
    inversion H3.
    rewrite <- H2.
    rewrite <- H5.
    reflexivity.
    assumption.
    assumption.

    apply e_nsfield_err1 with (v := v).
    apply (IHe v).
    assumption.
    assumption.

    apply e_nsfield_err2 with (c := cnf') (gv := gv) (dh := dh) (sh := sh) (l := l) (ars := normal c m (successor p c m pc) (ls n :: s) ls :: ars).
    inversion H3.
    rewrite <- H2.
    rewrite <- H5.
    reflexivity.
    apply IHe in H4.
    assumption.
    assumption.

    inversion H0; subst.
    simpl.
    apply e_nsfield with (gv := gv) (dh := dh) (sh := sh) (ars := normal c m pc s ls :: ars) (l := l).
    inversion H3.
    rewrite <- H2.
    rewrite <- H5.
    reflexivity.
    apply (IHe (refval l)).
    assumption.
    assumption.

    inversion H0; subst.
    simpl.
    apply e_nsfield with (gv := gv) (dh := dh) (sh := sh) (ars := normal c m pc s ls :: ars) (l := l).
    inversion H5.
    rewrite <- H7.
    rewrite <- H2.
    reflexivity.
    apply (IHe (refval l)).
    assumption.
    assumption.

    simpl.
    apply e_nsfield_err1 with (v := v0).
    apply (IHe v0).
    assumption.
    assumption.

    simpl.
    apply e_nsfield_err2 with (c := cnf) (gv := gv) (dh := dh) (sh := sh) (l := l) (ars := normal c m pc s ls :: ars).
    inversion H4.
    rewrite <- H2.
    rewrite <- H7.
    reflexivity.
    apply (IHe (refval l)).
    assumption.
    assumption.

    simpl.
    apply e_nsfield_err2 with (c := cnf) (gv := gv) (dh := dh) (sh := sh) (l := l) (ars := normal c m pc s ls :: ars).
    inversion H3.
    rewrite <- H2.
    rewrite <- H5.
    reflexivity.
    apply (IHe (refval l)).
    assumption.
    assumption.

    (* sfield *) split; intros.
    inversion H0; subst.
    apply (e_sfield gv cnf' dh sh (normal c m (successor p c m pc) (ls n :: s) ls :: ars) c0 f v).
    inversion H3.
    rewrite <- H2.
    rewrite <- H4.
    reflexivity.
    assumption.

    apply e_sfield_err with (gv := gv) (dh := dh) (sh := sh) (ars := normal c m (successor p c m pc) (ls n :: s) ls :: ars).
    inversion H3.
    rewrite <- H2.
    rewrite <- H4.
    reflexivity.
    assumption.

    simpl.
    inversion H0; subst.
    apply e_sfield with (gv := gv) (dh := dh) (sh := sh) (ars := normal c m pc s ls :: ars).
    inversion H3.
    rewrite <- H4.
    rewrite <- H2.
    reflexivity.
    assumption.

    apply e_sfield_err with (gv := gv) (dh := dh) (sh := sh) (ars := normal c m pc s ls :: ars).
    inversion H3.
    rewrite <- H2.
    rewrite <- H4.
    reflexivity.
    assumption.

    (* stackexp *) split; intros.
    destruct n0.
    (* subcase: n0 = 0 *)
    simpl in H0.
    inversion H0; subst.
    assert ((ls0 n::s)[[0]] = ls0 n).
      simpl.
      reflexivity.
    rewrite <- H1.
    apply (e_stack cnf' 0 (ls0 n :: s)).
    simpl.
    inversion H2.
    reflexivity.
    (* subcase: n0 = S n0 *)
    simpl in H0.
    inversion H0; subst.
    inversion H2.
    rewrite <- H3 in * |- *.
    assert (s[[n0]] = ((ls n :: s)[[S n0]])).
      simpl.
      reflexivity.
    rewrite H1.

    apply (e_stack cnf' (S n0) (ls n :: s)).
    simpl.
    reflexivity.
    destruct n0.
    (* subcase n0 = 0 *)
    simpl.
    inversion H0; subst.
    inversion H2.
    simpl.
    apply e_local.
    reflexivity.
    (* subcase n0 = S n0' *)
    inversion H0; subst.
    inversion H2; subst.
    simpl.
    apply e_stack.
    reflexivity.
    (* local n0 *)
    split; intros.
    simpl in H0.
    inversion H0; subst.
    inversion H2.
    apply e_local.
    rewrite <- H3.
    reflexivity.
    inversion H0; subst.
    inversion H2.
    rewrite <- H3.
    simpl.
    apply e_local.
    reflexivity.
    (* plus *)
    split; intros.
    simpl in H0.
    inversion H0; subst.
    apply IHe1 in H3.
    apply IHe2 in H6.
    apply e_plus; assumption.

    apply e_plus_err with (v1 := v1) (v2 := v2).
    apply (IHe1 v1) in H3; assumption.
    apply (IHe2 v2) in H4; assumption.
    assumption.

    simpl.
    inversion H0; subst.
    apply e_plus.
    apply IHe1 in H3; assumption.
    apply IHe2 in H6; assumption.

    inversion H0; subst.
    apply e_plus_err with (v1 := v1) (v2 := v2).
    apply (IHe1 v1); assumption.
    apply (IHe2 v2); assumption.
    assumption.

    (* guarded *)
    split; intros.
    simpl in H0.
    inversion H0; subst.
    apply IHe1 in H6.
    apply IHe2 in H7.
    apply e_guard_true; assumption.
    apply IHe1 in H6.
    apply IHe3 in H7.
    apply e_guard_other; assumption.

    apply e_guard_err with (v := v).
    apply IHe1 in H6.
    assumption.
    assumption.

    simpl.
    inversion H0; subst.
    apply e_guard_true.
    apply IHe1 in H6; assumption.
    apply IHe2 in H7; assumption.
    apply e_guard_other.
    apply IHe1 in H6; assumption.
    apply IHe3 in H7; assumption.

    apply e_guard_err with (v := v).
    apply (IHe1 v).
    assumption.
    assumption.

induction a; inversion H.
(* tt *)
split; intros; apply e_tt.
(* ff *)
split; intros; inversion H0.
(* le *)
split; intros.
inversion H0.
apply expr_lemma in H4.
apply expr_lemma in H5.
apply e_le with (i := i) (j := j); assumption.
simpl.
inversion H0; subst.
apply e_le with (i := i) (j := j).
apply expr_lemma in H4; assumption.
apply expr_lemma in H5; assumption.
assumption.
(* eq *)
split; intros.
inversion H0; subst.
apply expr_lemma in H4.
apply expr_lemma in H6.
apply e_eq with (v := v); assumption.
simpl.
inversion H0; subst.
apply e_eq with (v := v).
apply expr_lemma in H4; assumption.
apply expr_lemma in H6; assumption.
(* or *)
split; intros.
inversion H0; subst.
elim H5; intros.
apply IHa1 in H2.
apply e_disj.
left; assumption.
apply IHa2 in H2.
apply e_disj.
right; assumption.
simpl.
apply e_disj.
inversion H0; subst.
elim H5; intros.
apply IHa1 in H2.
left; assumption.
apply IHa2 in H2.
right; assumption.
(* and *)
split; intros.
inversion H0; subst.
elim H5; intros.
apply IHa1 in H2.
apply IHa2 in H3.
apply e_conj.
split; assumption.
simpl.
apply e_conj.
inversion H0; subst.
elim H5; intros.
apply IHa1 in H2.
apply IHa2 in H3.
split; assumption.
(* neg *)
split; intros.
inversion H0; subst.
apply e_neg.
apply invert_aeval in IHa.
apply IHa in H3.
assumption.
apply is_norm_conf.
apply is_norm_conf.
simpl.
apply e_neg.
apply invert_aeval in IHa.
apply IHa.
inversion H0; subst.
assumption.
apply is_norm_conf.
apply is_norm_conf.

(* if else *)
split; intros.
simpl in H0.
inversion H0; subst.
apply e_if_true.
apply IHa1 in H6; assumption.
apply IHa2 in H7; assumption.
inversion H0; subst.
apply e_if_false.
apply invert_aeval in IHa1.
apply IHa1 in H6; assumption.
apply is_norm_conf.
apply is_norm_conf.
apply IHa3 in H7; assumption.
apply e_if_false.
apply invert_aeval in IHa1.
apply IHa1 in H6; assumption.
apply is_norm_conf.
apply is_norm_conf.
apply IHa3 in H7; assumption.

simpl.
inversion H0; subst.
apply e_if_true.
apply IHa1; assumption.
apply IHa2; assumption.
apply e_if_false.
apply invert_aeval in IHa1.
apply IHa1 in H6; assumption.
apply is_norm_conf.
apply is_norm_conf.
apply IHa3 in H7; assumption.
Qed.

Lemma wp_correct_normal_astore: forall c m pc s ls h n v ars gv,
 instr_at p c m pc = astore n ->
 (∥wp p c m pc ∥ (gv, h, normal c m pc (v :: s) ls :: ars) <->
   ∥ast_at p c m (successor p c m pc) ∥ (gv, h, normal c m (successor p c m pc) s (upd ls n v) :: ars)).
Proof.
Admitted.

Lemma wp_correct_normal_dup: forall c m pc s ls h v ars gv,
 instr_at p c m pc = dup ->
 (∥wp p c m pc ∥ (gv, h, normal c m pc (v :: s) ls :: ars) <->
   ∥ast_at p c m (successor p c m pc) ∥ (gv, h, normal c m (successor p c m pc) (v :: v :: s) ls :: ars)).
Proof.
Admitted.

Lemma wp_correct_normal_goto: forall c m pc s ls h l ars gv,
 instr_at p c m pc = goto l ->
  (∥ wp p c m pc ∥ (gv, h, normal c m pc s ls :: ars) <->
  ∥ ast_at p c m l ∥ (gv, h, normal c m l s ls :: ars)).
Proof.
Admitted.

Lemma wp_correct_normal : forall h cid mid pc s ls ars c' a,
  let c := (h, (normal cid mid pc s ls)::ars) in
    trans p c c' ->
    normal_conf c' ->
    current_ast p c' = Some a ->
    (∥ wp p cid mid pc ∥ c <->
    ∥ a ∥ c').
Proof.
intros.
inversion H; subst; last first.
  (* trans *)
  by admit.
inversion H0; subst.
inversion H1; subst.
inversion H2; subst.
inversion H4; subst.
- (* aload n *)
  inversion H6; subst.
  inversion H5; subst.
  by apply wp_correct_normal_aload.
- (* astore n *)
  inversion H6; subst.
  inversion H5; subst.
  by apply wp_correct_normal_astore.
- (* dup *)
  inversion H6; subst.
  inversion H5; subst.
  rewrite H2.
  by apply wp_correct_normal_dup.
- (* goto *)
  inversion H6; subst.
  inversion H5; subst.
  rewrite H2.
  by apply wp_correct_normal_goto.
- (* iconst *)
  by admit.
- (* ldc *)
  by admit.
- (* ifeq true *)
  by admit.
- (* ifeq false *)
  by admit.
(* The other instructions can be treated similarly and are proved correct when the
   remaining of the proof script is completed and the definitions more stable. *)

(* This whole lemma could probably be solved with some proof search
   automation and/or ssreflect. Consult Karl. *)
Admitted.

  Lemma wp_correct_exceptional :
    forall gv h o cid mid pc s ls ars gv'' h'' c' a,
      let c := (gv, h, (exceptional o) :: (normal cid mid pc s ls) :: ars) in
      let c'' := (gv'', h'', (normal cid mid pc s ls) :: ars) in
        trans p c c' ->
        normal_conf c' ->
        current_ast p c' = Some a ->
        (∥ wp p cid mid pc ∥ c'') ->
        (∥ a ∥ c').
(* The other instructions can be treated similarly and are proved correct when the
   remaining of the proof script is completed and the definitions more stable. *)
  Admitted.

  Lemma sub_execution : forall pref suff, execution_of p (pref ++ suff) ->
                                          execution_of p pref.
    intros.
    apply exec_intros.
    destruct pref.
    intros.
    inversion H0.
    intros.
    inversion H0; subst.
    inversion H; subst.
    apply H1.
    simpl.
    reflexivity.
    intros.
    subst.
    inversion H; subst.
    apply H1 with (pref := pref0) (suff1 := suff0 ++ suff).
    rewrite app_ass.
    rewrite app_comm_cons.
    reflexivity.
  Qed.

  Corollary sub_execution2 : forall exec c c',
      execution_of p (exec ++ c::c'::nil) -> execution_of p (exec ++ c :: nil).

    intros.
    apply sub_execution with (suff := c' :: nil).
    rewrite app_ass.
    simpl.
    assumption.
  Qed.

  Theorem strong_exec_ind (P: execution -> Prop) :
    P nil ->
    (forall c, execution_of p (c :: nil) -> P (c :: nil)) ->
    (forall exec c c', execution_of p (exec ++ c :: c' :: nil) ->
      (forall exec', execution_of p exec' ->
                     proper_prefix exec' (exec ++ c :: c' :: nil) ->
                     P exec') ->
      P (exec ++ c :: c' :: nil)) ->
    forall exec, execution_of p exec -> P exec.

    destruct exec using strong_list_ind.
    intros.
    destruct exec using rev_ind.
    assumption.
    destruct exec using rev_ind.
    apply (H0 x).
    assumption.
    rewrite <- list_rearrange.
    apply H1.
    rewrite <- list_rearrange in H3.
    assumption.
    intros.
    apply H2.
    rewrite <- list_rearrange.
    assumption.
    assumption.
  Qed.

  Lemma valid_exec_last : forall exec c, valid_exec (exec ++ c :: nil) -> valid_conf c.
    intros.
    apply (all_valid (exec ++ c::nil)).
    assumption.
    apply in_or_app.
    right.
    auto with datatypes.
  Qed.

  Lemma valid_exec_prefix :
    forall pref exec, proper_prefix pref exec -> valid_exec exec -> valid_exec pref.
    intros pref ex H.

    assert (H_tmp: forall a a' b b': Prop, (a' -> b') -> (a <-> a') -> (b <-> b') -> (a -> b)).
      intros a a' b b' H_t0 H_t1 H_t2 H_t3.
      apply H_t2.
      apply H_t0.
      apply H_t1.
      assumption.

    apply (H_tmp (valid_exec ex) (forall c, In c ex -> valid_conf c) (valid_exec pref) (forall c, In c pref -> valid_conf c)).
    intros.
    apply H0.
    apply proper_prefix_split in H.
    elim H; intros.
    elim H2; intros.
    rewrite H3.
    apply in_or_app.
    left.
    assumption.
    apply (all_valid ex).
    apply (all_valid pref).
  Qed.

  Corollary valid_exec_last_norm :
    forall exec c, valid_exec (exec ++ c :: nil) -> normal_conf c ->
      forall a, current_ast p c = Some a -> (∥ a ∥ c).
  Proof.
    intros exec c H.
    apply valid_exec_last in H.
    inversion H.
    assumption.
  Qed.

  Lemma exec_impl_trans :
    forall exec c c', execution_of p (exec ++ c :: c' :: nil) -> trans p c c'.
  Proof.
    intros.
    inversion H; subst.
    apply H1 with (pref := exec) (suff := nil).
    reflexivity.
  Qed.

  Lemma act_rec_suffixes :
    forall gv gv' h ars h' ar ars', trans p (gv, h, ars) (gv', h', ar::ars') -> suffix ars' ars.
    intros.
    inversion H.
    inversion H2; inversion H0; inversion H1; subst; try apply suffix_next; try apply suffix_here.
    inversion H0; inversion H5; inversion H7; subst; apply suffix_next; apply suffix_here.
Qed.

  Lemma all_ars_has_been_on_top :
    forall exec,
      execution_of p exec ->
      forall gv h ars suff,
        last exec (gv, h, ars) ->
        suffix suff ars ->
        suff <> nil ->
        exists gv', exists h', In (gv', h', suff) exec.

    apply (strong_exec_ind (fun exec => forall gv h ars suff,
      last exec (gv, h, ars) ->
      suffix suff ars ->
      suff <> nil ->
      exists gv', exists h', In (gv', h', suff) exec)).

    intros.
    inversion H.

    (* Base case *)
    intros.
    inversion H; subst.
    assert (initial_conf c).
      apply H3.
      simpl; reflexivity.
    inversion H5; subst.
    inversion H0.
    exists gv.
    exists h.
    subst.
    inversion H1.
    subst.
    apply in_eq.
    subst.
    inversion H8.
    contradiction H2.
    inversion H9.

    (* Inductive step *)
    intros.
    rewrite list_rearrange in H1.
    apply last_app_cons in H1.
    subst.
    (* rewrite H1 in * |- *. *)

    inversion H2; subst.

      (* suff = ars   "non-proper" prefix *)
      exists gv.
      exists h.
      auto with datatypes.

      (* suff = proper suffix *)
      assert (exists gv', exists h', In (gv', h', suff) (exec ++ c :: nil)).
        destruct c as ((gv', h'), ars').
        apply H0 with (gv := gv') (h := h') (ars := ars').
        apply sub_execution2 with (c' := (gv, h, a::l)).
        assumption.
        apply proper_prefix_app.
        apply proper_prefix_next.
        apply proper_prefix_nil.
        apply last_app.
        apply last_base.
        apply exec_impl_trans in H.
        apply act_rec_suffixes in H.
        apply suffix_transitive with (bc := l); assumption.
        assumption.

      elim H4; intros gv' H_ex_h.
      elim H_ex_h; intros h'; intros.
      exists gv'.
      exists h'.
      rewrite list_rearrange.
      apply in_or_app.
      left.
      assumption.
  Qed.

  Lemma no_empty_ar_stack_trans : forall gv h ar ars gv' h', trans p (gv, h, ar :: ars) (gv', h', nil) -> False.
    intros.
    inversion H; subst.
    inversion H1; subst.
    inversion H0; subst.
  Qed.

  Lemma no_empty_ar_stack : forall exec gv h, execution_of p exec ->
                                              In (gv, h, nil) exec -> False.
    destruct exec using rev_ind; intros.
    inversion H0.
rename x into c'.
apply (IHexec gv h).
apply (sub_execution exec (c' :: nil) H).
destruct exec using rev_ind; [| clear IHexec0].
inversion H0; subst.
inversion H.
pose proof (H1 (gv, h, nil)).
assert (H_tmp : forall (A: Set) (a : A), head (nil ++ a :: nil) = Some a).
  reflexivity.
apply H4 in H_tmp.
inversion H_tmp.
contradict H1.
rename x into c.
apply in_app_or in H0.
elim H0; clear H0; intros.
rewrite <- list_rearrange in H.
apply sub_execution2 in H.
contradict (IHexec gv h H H0).
inversion H0; [| contradiction]; subst.
rewrite <- list_rearrange in H.
destruct c.
destruct p0.
destruct l.
apply sub_execution2 in H.
apply (IHexec g h0) in H; [contradiction |].
apply in_or_app.
right.
auto with datatypes.
apply exec_impl_trans in H.
contradict (no_empty_ar_stack_trans _ _ _ _ _ _ H).
Qed.

  Lemma calling_only_invoke :
    forall gv h c m pc s ls ars0 gv' h' c' m' pc' s' ls',
      let ars := normal c  m  pc  s  ls :: ars0 in
      let ars':= normal c' m' pc' s' ls':: ars  in
        calling_conf p (gv, h, ars) ->
        trans p (gv, h, ars) (gv', h', ars') ->
        instr_at p c m pc = invoke c' m'.
    intros until ars'.
    intros H_calling H_trans.
    inversion H_calling as [gv0 h0 c0 m0 pc0 l ls0 ars1 H_trans']; subst.
    inversion H_trans'; subst.
    rename H1 into H_atrans.
    inversion H0.
    subst.
    inversion H_atrans; subst; inversion H; contradict H9; apply list_neq_length; simpl; lia.
    inversion H.
    contradict H16; apply list_neq_length; simpl; lia.
  Qed.

  Lemma calling_conf_inv : forall gv h c m pc s ls ars,
    let cnf := (gv, h, normal c m pc s ls::ars) in
      locally_valid -> calling_conf p cnf -> ∥ ast_at p c m pc ∥ cnf -> ∥inv p ∥ cnf.
    intros.
    inversion H0; subst.
    assert (instr_at p c m pc = invoke c0 m0).
      apply (calling_only_invoke gv h c m pc s ls ars gv h c0 m0 pc0 l ls0); assumption.

    inversion H.
    elim (H4 c m); intros.
    assert ((∥ast_at p c m pc ∥ cnf) -> ∥wp p c m pc ∥ cnf).
      apply H7.
    unfold wp in H8.
    rewrite H2 in H8.
    apply H8.
    assumption.
  Qed.

  Lemma returning_conf_inv : forall gv h c m pc s ls ars,
    let cnf  := (gv, h, normal c m pc s ls::ars) in
      locally_valid -> ∥ast_at p c m pc ∥ cnf -> returning_conf p cnf -> ∥inv p ∥ cnf.
  Proof.
    intros.
    assert (H_curr_inst_ret: current_instr p cnf = Some ret).
    inversion H1; subst.
    inversion H3; subst.

    (* ar-trans *)
    inversion H5; subst; subst cnf; (try
      inversion H2; inversion H4; subst;
        inversion H4; contradict H8;
          apply list_neq_length; simpl; lia).

    (* ghost-trans *)
    subst cnf.
    inversion H2.
    contradict H15.
    apply list_neq_length; simpl; lia.

    inversion H.
    pose proof (H2 c m).
    inversion H4.
    apply current_to_instr_at in H_curr_inst_ret.
    pose proof (H6 cnf pc).
    unfold wp in H7.
    rewrite H_curr_inst_ret in H7.
    apply H7.
    assumption.
  Qed.

  Lemma returning_conf_inv_exc : forall gv h o ars,
    let cnf := (gv, h, exceptional o :: ars) in
      locally_valid -> returning_conf p cnf -> ∥inv p ∥ cnf.
  Proof.
    intros.
    inversion H0; subst.
    inversion H2.
    inversion H4; subst; inversion H3; inversion H1.
    subst.
    inversion H1; subst.
  Qed.

  Lemma no_double_exc_trans : forall c gv h o1 o2 ars, trans p c (gv, h, exceptional o1 :: exceptional o2 :: ars) -> exists gv', exists h', c = (gv', h', exceptional o1 :: exceptional o2 :: ars).
    intros.
    inversion H; subst.
    inversion H2; subst; try (inversion H1; inversion H1; subst).
  inversion H0; subst.
  Qed.

  Corollary no_double_exceptional : forall exec gv h o1 o2 ars,
      execution_of p (exec ++ (gv, h, exceptional o1 :: exceptional o2 :: ars) :: nil) -> False.
    destruct exec using rev_ind; intros.
    inversion H; subst.
    assert (initial_conf (gv, h, exceptional o1 :: exceptional o2 :: ars)).
      apply H0.
      reflexivity.
    inversion H2.
    rewrite <- list_rearrange in H.
    generalize H; intros H_exec.
    apply exec_impl_trans in H.
    apply no_double_exc_trans in H.
    elim H; clear H; intros.
    elim H; clear H; intros.
    subst.
    apply sub_execution2 in H_exec.
    apply IHexec in H_exec.
    contradict H_exec.
  Qed.

  Lemma initial_conf_valid :
    forall c,
      locally_valid ->
      execution_of p (c::nil) ->
      valid_exec (c::nil).

    intros.
    destruct c as ((gv, h), ars).
    destruct ars.
    contradict H0.
    intro.
    apply (no_empty_ar_stack ((gv, h, nil)::nil) gv h); auto with datatypes.
    assert (∥inv p ∥ (gv, h, a::ars)).
      inversion H.
      inversion H0.
      elim H2; intros.
      apply (H7 (gv, h, a::ars)).
      apply initial_default.
      apply H3.
      reflexivity.
    destruct a.
    set (c0 := (gv, h, normal c m l s l0 :: ars)) in * |- *.
    apply (ve_cons c0 nil).
    apply v_conf.
    intros.
    assumption.
    intros.
    inversion H.
    elim H5; intros.
    inversion H0.
    subst.
    assert (initial_conf c0).
      apply H8; reflexivity.
    inversion H10.
    inversion H3.
    rewrite H14.
    rewrite H15.
    rewrite H16.
    apply (H6 c0).
    apply initial_default.
    assumption.
    apply ve_nil.
    inversion H0.
    subst.
    assert (initial_conf (gv, h, exceptional l :: ars)).
      apply H2; reflexivity.
    inversion H4.
  Qed.

  Lemma local_impl_global_prev_normal_then_ast_holds :
    forall cnf cnf' exec a,
        locally_valid ->
        execution_of p (exec ++ cnf :: cnf' :: nil) ->
        (forall exec' : execution,
          execution_of p exec' ->
          proper_prefix exec' (exec ++ cnf :: cnf' :: nil) ->
          valid_exec exec') ->
        normal_conf cnf' ->
        current_ast p cnf' = Some a ->
        ∥a ∥ cnf'.
      intros until a.
      intros H_p_lv H_exec IH.
      intros.
      destruct cnf as ((gv, h), ars). (* would like to be able to destruct .. using .. so I don't have to take care of the case where ar-stack is empty all the time. *)
      destruct ars.
      contradict H_exec.
      intro.
      apply no_empty_ar_stack with (gv := gv) (h := h) in H1.
      assumption.
      auto with datatypes.

      destruct a0.
      set (cnf := (gv, h, normal c m l s l0 :: ars)) in * |- *.

      (* Normal predecessor *)
        assert (H_wp: ∥ wp p c m l ∥ cnf -> ∥ a ∥ cnf').
          assert (H_tmp: ∥ wp p c m l ∥ cnf <-> ∥ a ∥ cnf').
            apply wp_correct_normal.
            apply (exec_impl_trans exec cnf cnf').
            assumption.
            assumption.
            assumption.
          elim H_tmp; intros H' H''.
          assumption.

        apply H_wp.
        inversion H_p_lv as [H_all_lv].
        elim (H_all_lv c m); intros H_inv_imp_pre H_proof_obl.
        apply (H_proof_obl cnf).
        apply (valid_exec_last_norm exec cnf).
        apply IH.
        apply sub_execution2 with (c' := cnf').
        assumption.
        apply proper_prefix_app.
        apply proper_prefix_next.
        apply proper_prefix_nil.
        apply is_norm_conf.
        reflexivity.

        (* Exceptional predecessor *)
        (* Show that l <> nil *)
        destruct ars.
        apply exec_impl_trans in H_exec.
        inversion H_exec; subst.
        inversion H3; subst; inversion H1.
        inversion H1; subst.

        (* a0 must be normal. *)
        destruct a0.

        (* Case: it is normal. *)
        set (ar := normal c m l0 s l1) in * |- *.
        assert (H_ex_thrower : exists gv', exists h', In (gv', h', ar :: ars) (exec ++ (gv, h, exceptional l :: ar :: ars) :: nil)).
          apply (all_ars_has_been_on_top) with (gv := gv) (h := h) (ars := exceptional l :: ar :: ars).
          apply sub_execution2 with (c' := cnf').
          assumption.
          apply last_app.
          apply last_base.
          apply suffix_next.
          apply suffix_here.
          auto with datatypes.

        elim H_ex_thrower; intros gv' H_in_tmp.
        elim H_in_tmp; intros h' H_in.

        apply in_but_not_last in H_in.
        elim H_in; intros H_thrower.
        inversion H_thrower.
        assert (H_ex_pref_suff : exists ex_pref, exists ex_suff, exec = ex_pref ++ (gv', h', ar :: ars) :: ex_suff).
          apply (In_split (gv', h', ar :: ars) exec).
          assumption.

        elim H_ex_pref_suff; intros x H_ex_suff.
        elim H_ex_suff; intros x0 H_ex.
        set (cnfT := (gv', h', ar :: ars)) in * |- *.

        assert (valid_exec (x ++ cnfT::nil)).
          apply IH.
          assert (H_sub_exec : execution_of p exec).
            destruct exec.
            contradict H_ex.
            auto with datatypes.
            apply sub_execution with (suff := (gv, h, exceptional l :: ar :: ars) :: cnf' :: nil).
            assumption.
            subst.
          (* rewrite H_ex in * |- *. *)
          rewrite list_rearrange in H_sub_exec.
          apply sub_execution with (suff := x0).
          auto with datatypes.
          rewrite H_ex.
          rewrite app_ass.
          apply proper_prefix_app.
          rewrite <- app_comm_cons.
          apply proper_prefix_next.
          case x0.
          apply proper_prefix_nil.
          intros.
          rewrite <- app_comm_cons.
          apply proper_prefix_nil.

        assert (H_ast_cnft : ∥ ast_at p c m l0 ∥ cnfT).
          apply (valid_exec_last x cnfT).
          assumption.
          apply is_norm_conf.
          auto.

        inversion H_p_lv as [H_all_lv].
        elim (H_all_lv c m); intros H_lv_ast H_lv_wp.
        apply (H_lv_wp cnfT l0) in H_ast_cnft.
        apply (wp_correct_exceptional gv h l c m l0 s l1 ars gv' h' cnf' a); auto.
        apply (exec_impl_trans exec (gv, h, exceptional l :: ar :: ars) cnf').
        assumption.

        (* Case: it is exceptional. *)
        assert (execution_of p (exec ++ (gv, h, exceptional l :: exceptional l0 :: ars) :: nil)).
          apply sub_execution2 with (c' := cnf').
          assumption.
        apply no_double_exceptional in H1.
        contradiction.
  Qed.

  Lemma calling_conf_normal_conf : forall c, calling_conf p c -> normal_conf c.
    intros.
    inversion H; subst.
    destruct ars.
    inversion H0; subst.
    inversion H1.
    inversion H1.
    destruct a.
    apply is_norm_conf.
    inversion H0; subst.
    inversion H1; subst.
    inversion H3; discriminate.
    inversion H1.
  Qed.

  Theorem local_impl_global : locally_valid -> globally_valid.
    intros.
    unfold globally_valid.
    intros exec H0.
    apply (strong_exec_ind valid_exec).
    apply ve_nil.
    intros.
    apply initial_conf_valid; assumption.
    clear H0 exec.
    intros exec c c' H0 IH.

    (* Inductive step. *)
    destruct c' as ((gv', h'), ars').
    destruct ars'.
    contradict H0; intro.
    apply (no_empty_ar_stack (exec ++ c :: (gv', h', nil) :: nil) gv' h'); auto with datatypes.
    destruct a.

    (* Last conf: normal *)
      rewrite list_rearrange.
      apply ve_cons.
      apply v_conf.

      (* Visible => Inv *)
      intro H_visconf.
      unfold visible_conf in H_visconf.
      elim H_visconf.
      (* Calling *)
        intros H_c.
        assert (∥ast_at p c0 m l ∥ (gv', h', normal c0 m l s l0 :: ars')).
          apply local_impl_global_prev_normal_then_ast_holds with (cnf := c) (exec := exec); auto.
          apply is_norm_conf.

        apply calling_conf_inv.
        assumption.
        assumption.
        assumption.

      (* Returning *)
        apply (returning_conf_inv gv' h' c0 m l s l0 ars').
        assumption.
        apply local_impl_global_prev_normal_then_ast_holds with (cnf := c) (exec := exec); auto.
        apply is_norm_conf.

      (* C_i normal => ∥ast at C_i∥ C_i  holds. *)
      intros H_normal a H_currast.
      apply local_impl_global_prev_normal_then_ast_holds with (cnf := c) (exec := exec); auto.
      apply IH.
      apply sub_execution2 with (c' := (gv', h', normal c0 m l s l0 :: ars')).
      assumption.
      apply proper_prefix_app.
      apply proper_prefix_next.
      apply proper_prefix_nil.

    (* Last conf: exceptional *)
      rewrite list_rearrange.
      apply (ve_cons (gv', h', exceptional l :: ars') (exec ++ c :: nil)).
      apply v_conf.

      (* Visible => Inv *)
      intro H_visconf.
      unfold visible_conf in H_visconf.
      elim H_visconf.
      intros.
      inversion H1; subst.
      inversion H3; subst.
      inversion H5; subst; try inversion H2.
      inversion H2.
      intros.
      apply (returning_conf_inv_exc gv' h' l ars').
      assumption.
      assumption.
      intros.
      inversion H1.
      apply IH.
      apply (sub_execution2 exec c (gv', h', exceptional l :: ars')).
      assumption.
      apply proper_prefix_app.
      apply proper_prefix_next.
      apply proper_prefix_nil.
      assumption.
    Qed.

End validity.


(****************************************************************************)
(* Copyright 2020 The Project Oak Authors                                   *)
(*                                                                          *)
(* Licensed under the Apache License, Version 2.0 (the "License")           *)
(* you may not use this file except in compliance with the License.         *)
(* You may obtain a copy of the License at                                  *)
(*                                                                          *)
(*     http://www.apache.org/licenses/LICENSE-2.0                           *)
(*                                                                          *)
(* Unless required by applicable law or agreed to in writing, software      *)
(* distributed under the License is distributed on an "AS IS" BASIS,        *)
(* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *)
(* See the License for the specific language governing permissions and      *)
(* limitations under the License.                                           *)
(****************************************************************************)

Require Import Cava.Cava.
Require Import Cava.CavaProperties.
Require Import Tests.AccumulatingAdderEnable.AccumulatingAdderEnable.

Definition bvadd {n} (a b : Signal.combType (Vec Bit n)) : Signal.combType (Vec Bit n) :=
  N2Bv_sized n (Bv2N a + Bv2N b).

Definition bvzero {n} : Signal.combType (Vec Bit n) := N2Bv_sized n 0.

Definition bvsum {n} (l : list (Bvector n)) : Bvector n :=
  fold_left bvadd l (N2Bv_sized n 0).

Definition accumulatingAdderEnableSpec
           (i : list (combType (Vec Bit 8) * combType Bit))
  : list (combType (Vec Bit 8)) * combType (Vec Bit 8) :=
  fold_left
    (fun acc_st v_en =>
       let sum := bvadd (snd acc_st) (fst v_en) in
       (fst acc_st ++ [sum], if (snd v_en : bool) then sum else snd acc_st))
    i ([], bvzero).

Lemma addNCorrect n (a b : Vector.t bool n) :
  addN (a, b) = bvadd a b.
Admitted.
Hint Rewrite addNCorrect using solve [eauto] : simpl_ident.

Lemma bvadd_comm {n} a b : @bvadd n a b = bvadd b a.
Proof. cbv [bvadd]. rewrite N.add_comm. reflexivity. Qed.

Lemma accumulatingAdderEnableSpec_snoc xs x :
  accumulatingAdderEnableSpec (xs ++ [x]) =
  let acc_st := accumulatingAdderEnableSpec xs in
  let sum := bvadd (snd acc_st) (fst x) in
  (fst acc_st ++ [sum], if (snd x : bool) then sum else snd acc_st).
Proof.
  cbv [accumulatingAdderEnableSpec].
  autorewrite with pull_snoc. cbn [fst snd].
  reflexivity.
Qed.

Lemma accumulatingAdderEnableCorrect (i : list (Bvector 8 * bool)) :
  simulate accumulatingAdderEnable i = fst (accumulatingAdderEnableSpec i).
Proof.
  intros; cbv [accumulatingAdderEnable]. autorewrite with push_simulate.
  cbn [step reset_state]. cbv [mcompose]. simpl_ident.
  eapply fold_left_accumulate_invariant_seq
    with (I:=fun t st acc =>
               snd st = snd (accumulatingAdderEnableSpec (firstn t i))
               /\ acc = fst (accumulatingAdderEnableSpec (firstn t i)))
         (P:=fun x => x = fst (accumulatingAdderEnableSpec i)).
  { (* invariant holds after first step *)
    split; reflexivity. }
  { (* invariant holds through body *)
    cbv zeta. intros ? ? ? d; intros; logical_simplify; subst.
    repeat destruct_pair_let; cbn [fst snd]. simpl_ident.
    rewrite firstn_succ_snoc with (d0:=d) by length_hammer.
    rewrite accumulatingAdderEnableSpec_snoc. cbn [fst snd].
    lazymatch goal with H : _ = snd (accumulatingAdderEnableSpec _) |- _ =>
                        rewrite H end.
    rewrite bvadd_comm. split; reflexivity. }
  { (* invariant implies postcondition *)
    intros; logical_simplify; subst.
    rewrite firstn_all; reflexivity. }
Qed.


Require Import ExtLib.Data.HList.
Require Import ExtLib.Core.RelDec.

Require Import Charge.Logics.ILogic.
Require Import Charge.ModularFunc.ListType.
Require Import Charge.ModularFunc.BaseType.
Require Import Charge.ModularFunc.ListFunc.
Require Import Charge.ModularFunc.BaseFunc.
Require Import Charge.ModularFunc.SemiEqDecTyp.
Require Import Charge.Tactics.Base.DenotationTacs.
Require Import Charge.Tactics.Base.MirrorCoreTacs.
Require Import ExtLib.Tactics.

Require Import MirrorCore.TypesI.
Require Import MirrorCore.RTac.Core.
Require Import MirrorCore.Lambda.AppN.
Require Import MirrorCore.Lambda.Red.
Require Import MirrorCore.Lambda.RedAll.
Require Import MirrorCore.Lambda.Expr.

Section Length.
  Context {typ func : Type} {RType_typ : RType typ} {RSym_func : RSym func}
          {BT : BaseType typ} {BTD : BaseTypeD BT}
          {LT : ListType typ} {LTD: ListTypeD LT}.
  Context {BF : BaseFunc typ func} {LF : ListFunc typ func}.
  Context {RelDec_eq : RelDec (@eq typ)} {RelDecOk_eq : RelDec_Correct RelDec_eq}.
  Context {Heqd : SemiEqDecTyp typ} {HeqdOk : SemiEqDecTypOk Heqd}.

   Context {EU : ExprUVar (expr typ func)}.

  Context {RType_typOk : RTypeOk} {RsymOk_func : RSymOk RSym_func}.

  Context {Typ0_tyProp : Typ0 _ Prop}.
  Context {Typ2_tyArr : Typ2 _ Fun}.

  Context {Typ0Ok_tyProp : Typ0Ok Typ0_tyProp}.
  Context {Typ2Ok_tyArr : Typ2Ok Typ2_tyArr}.

  Context {BFOk : BaseFuncOk typ func } {LFOk : ListFuncOk typ func}.

  Let tyArr : typ -> typ -> typ := @typ2 _ _ _ _.
  Let tyProp := @typ0 typ RType_typ Prop Typ0_tyProp.

(* This function will return None unless lst eventually reaches nil. This means that we cannot partially evaluate a length of a list
   (length 1::2::3::lst = 3 + (length lst) for instance). To be able to do this, we need a language that supports arithmetic operations
   (at least +) on natural numbers. This is a perfectly natural thing to have, but it is not implemented at the moment. *)

  Fixpoint lengthTacAux (t : typ) (lst : expr typ func) : option nat :=
    match lst with
      | App (App f x) xs =>
        match listS f with
          | Some (pCons _) =>
            match lengthTacAux t xs with
              | Some x => Some (S x)
              | None => None
            end
          | _ => None
        end
      | _ => None
    end.

  Definition lengthTac  (_ : list (option (expr typ func))) (e : expr typ func) (args : list (expr typ func)) : expr typ func :=
    match listS e, args with
	  | Some (pLength t), lst::nil =>
	    match baseS lst with
	      | Some (pConst u c) =>
	        match type_cast (tyList t) u with
	          | Some pf => mkNat (natR (length (listD (eq_rect_r typD c pf))))
	          | None => apps e args
	        end
	      | _ =>
	        match lengthTacAux t lst with
	          | Some l => mkNat (natR l)
	          | None => apps e args
	        end
	    end
	  | _, _ => apps e args
	end.

  Existing Instance Expr_expr.
  Existing Instance ExprOk_expr.

End Length.


From mathcomp Require Import
     all_ssreflect
     finmap.

From AUChain Require Import
     Parameters
     Blocks
     Messages
     MessageTuple
     BlockTree
     LocalState.

From RecordUpdate Require Import RecordSet.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(** * Globalstate
      This file contains the definition of a global state
      together, as well as definitions for some types used in the
      definition of [GlobalState].
**)

(** The StateMap which is supposed to keep track of parties.
    The parties are existentially quantified over their treeType. *)

Definition StateMap := finMap [choiceType of Party] LocalState.

Definition state_map0 : StateMap := fmap0.
Open Scope fmap.

Inductive Honesty : Set :=
| Honest
| Corrupt.

Definition bool_of_honesty (h : Honesty) :=
  match h with
  | Honest => true
  | Corrupt => false
  end.

Coercion bool_of_honesty: Honesty >-> bool.

Definition honest_eq h h' :=
  match h, h' with
  | Honest, Honest => true
  | Corrupt, Corrupt => true
  | _, _ => false
  end.

Lemma honest_eqP : Equality.axiom honest_eq.
Proof. by move=> [] []; apply/(iffP idP). Qed.

Canonical Honest_eqMixin := Eval hnf in EqMixin honest_eqP.
Canonical Honesty_eqType := Eval hnf in EqType Honesty Honest_eqMixin.

Inductive Progress : Set :=
| Ready
| Delivered
| Baked.

Definition progress_eq p p' :=
  match p, p' with
  | Ready, Ready => true
  | Delivered, Delivered => true
  | Baked, Baked => true
  | _, _ => false
  end.

Lemma progress_eqP : Equality.axiom progress_eq.
Proof. by move=> [] []; apply/(iffP idP). Qed.

Canonical Progress_eqMixin := Eval hnf in EqMixin progress_eqP.
Canonical Progress_eqType := Eval hnf in EqType Progress Progress_eqMixin.

Parameter AdversarialState : Type.
Parameter AdvState0 : AdversarialState.

Definition History := seq Message.

(** ** The GlobalState  *)
Record GlobalState :=
  mkGlobalState {
    (* The current slot of the world  *)
    t_now : Slot;
    (* All messages that yet has to be delivered *)
    msg_buff : MessagePool;
    (* A map of each party's local state *)
    state_map : StateMap;
    (* A global blockpool containing all blocks seen in thte world *)
    history : History;
    (* An adversary can update his state *)
    adv_state : AdversarialState ;
    (* Execution order for the next round*)
    exec_order : Parties ;
    (* A world state describing how far the world has progressed in this round *)
    progress : Progress
}.

Instance GlobalStateSettable : Settable GlobalState :=
  settable! mkGlobalState <t_now; msg_buff; state_map; history; adv_state; exec_order; progress>.

Definition tree_gb (tT : treeType) : tT := tree0.

Definition history0 : Messages := [::].

Definition msg_id0 := 0.

Parameter TreeTypeMap : Party -> treeType.

(** Creates a new party with identifier pk. Is not set to new as this is
    only to be used for the initial creations of parties where everybody
    are new, but none should act as such. *)

Definition init_local (pk : Party): LocalState :=
  mkLocalState pk (tree_gb (TreeTypeMap pk)).

Definition N0 : GlobalState :=
  let state_map := foldr (fun pk acc => acc.[pk <- init_local pk]) state_map0 InitParties in
  mkGlobalState 1 [::] state_map history0 AdvState0 InitParties Ready.


(*

  Copyright 2016 Luxembourg University
  Copyright 2017 Luxembourg University
  Copyright 2018 Luxembourg University

  This file is part of Velisarios.

  Velisarios 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.

  Velisarios 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 Velisarios.  If not, see <http://www.gnu.org/licenses/>.

  Authors: Vincent Rahli
           Ivana Vukotic

*)

Require Export PBFT_A_1_7.
Require Export PBFT_A_1_10.

Section PBFT_A_1_11.

  Local Open Scope eo.
  Local Open Scope proc.

  Context { pbft_context     : PBFTcontext      }.
  Context { pbft_auth        : PBFTauth         }.
  Context { pbft_keys        : PBFTinitial_keys }.
  Context { pbft_hash        : PBFThash         }.
  Context { pbft_hash_axioms : PBFThash_axioms  }.

  (* the difference with PBFT_A_1_7 is that we have here [replica_has_correct_trace]
     instead of [isCorrect] *)
  Lemma PBFT_A_1_7_v2 :
    forall (eo : EventOrdering)
           (e  : Event)
           (L  : list Event)
           (i  : Rep)
           (rd : RequestData)
           (st : PBFTstate),
      authenticated_messages_were_sent_or_byz_usys eo PBFTsys
      -> In e L
      -> exists_at_most_f_faulty L F
      -> PBFTcorrect_keys eo
      -> loc e = PBFTreplica i
      -> state_sm_on_event (PBFTreplicaSM i) e = Some st
      -> committed_log rd (log st) = true
      ->
      exists (R : list Rep),
        no_repeats R
        /\ F < length R
        /\ nodes_have_correct_traces_before R L
        /\ forall (k : Rep),
            In k R
            ->
            exists (e' : Event) (st' : PBFTstate),
              e' ≼ e
              /\ loc e' = PBFTreplica k
              /\ state_sm_on_event (PBFTreplicaSM k) e' = Some st'
              /\ prepared_log rd (log st') = true.
  Proof.
    introv sendbyz ieL atmostbyz ckeys eqloc eqst comm.
    apply is_committed_log_implies_is_committed_entry in comm; exrepnd; subst.
    apply is_committed_entry_implies in comm1; repnd.
    apply is_prepared_entry_implies in comm2; exrepnd.

    assert (well_formed_log (log st)) as wfL by (eauto 3 with pbft).
    assert (well_formed_log_entry entry) as wfe by (eapply well_formed_log_entry_if_in; eauto).

    pose proof (select_good_guys_before eo (entry2com_senders entry) L F) as sel.
    repeat (autodimp sel hyp);
      try (apply implies_no_repeats_entry2com_senders; eauto 3 with pbft eo);[].
    destruct sel as [G sel]; repnd; simpl in *.
    rewrite length_entry2com_senders in sel1.

    exists G; dands; auto; try omega;
      try (complete (introv w z u v; subst; allrw in_map_iff; exrepnd; subst;
                     eapply sel; eauto));[].

    introv ik.
    applydup sel0 in ik.

    pose proof (in_entry2com_senders_implies_commit_in_log k entry (log st)) as expl.
    repeat (autodimp expl hyp);[].
    exrepnd.

    dup expl1 as ilog.
    eapply commits_are_received_or_generated in expl1;[|eauto];auto.
    exrepnd.
    apply or_comm in expl3; repndors;[|].

    - destruct com, b; simpl in *.
      subst i0 k.
      pose proof (PBFT_A_1_6 eo e i s v a0 d st) as q.
      repeat (autodimp q hyp);[].

      exists e st; dands; eauto 2 with eo;
        try (complete (rewrite <- expl2; auto));
        try (complete (eapply sel; eauto; eauto 3 with eo;
                       allrw; apply in_map_iff; eexists; dands; eauto)).

    - exrepnd.
      applydup localLe_implies_loc in expl1.

      pose proof (ckeys e' i st1) as ck1; repeat (autodimp ck1 hyp); eauto 3 with eo pbft;[].

      pose proof (commit_received_from_good_replica_was_in_log
                    eo e' k com i) as w.
      repeat (autodimp w hyp); try congruence;
        try (complete (introv w z; eapply sel; eauto 3 with pbft eo));[].
      exrepnd.

      destruct com, b; simpl in *.
      subst i0.
      pose proof (PBFT_A_1_6 eo e'0 k s v a0 d st0) as q.
      repeat (autodimp q hyp);[].

      exists e'0 st0; dands; eauto 4 with eo;
        try (complete (rewrite <- expl2; auto));
        try (complete (apply (sel e'0 e); eauto; eauto 4 with eo;
                       allrw; apply in_map_iff; eexists; dands; eauto)).
  Qed.
  Hint Resolve PBFT_A_1_7_v2 : pbft.

  Lemma PBFT_A_1_11 :
    forall (eo : EventOrdering)
           (e1  : Event)
           (e2  : Event)
           (i   : Rep)
           (j   : Rep)
           (n   : SeqNum)
           (v1  : View)
           (v2  : View)
           (d1  : PBFTdigest)
           (d2  : PBFTdigest)
           (st1 : PBFTstate)
           (st2 : PBFTstate),
      authenticated_messages_were_sent_or_byz_usys eo PBFTsys
      -> PBFTcorrect_keys eo
      -> exists_at_most_f_faulty [e1,e2] F
      -> loc e1 = PBFTreplica i
      -> loc e2 = PBFTreplica j
      -> state_sm_on_event (PBFTreplicaSM i) e1 = Some st1
      -> state_sm_on_event (PBFTreplicaSM j) e2 = Some st2
      -> committed_log (request_data v1 n d1) (log st1) = true
      -> committed_log (request_data v2 n d2) (log st2) = true
      -> d1 = d2.
  Proof.
    introv auth ckeys atMost loci locj eqst1 eqst2 comm1 comm2.

    eapply PBFT_A_1_7_v2 in comm1; try exact eqst1; auto; eauto 2 with pbft; simpl; tcsp;[].
    eapply PBFT_A_1_7_v2 in comm2; try exact eqst2; auto; eauto 2 with pbft; simpl; tcsp;[].
    exrepnd.

    pose proof (A_1_10 eo e1 e2 R0 R n v1 v2 d1 d2) as q;
      repeat (autodimp q hyp); eauto 3 with pbft eo;[|];
        unfold more_than_F_have_prepared_before; dands; auto.
  Qed.

End PBFT_A_1_11.


(*
 * Module: Multi
 *
 * Description:
 *  Prove a simple CFI policy on the transitive closure of the small-step
 *  transition relation.
 *)

(* Load Coq Standard Library modules *)
Require Import Semantics.
Require Import SVAOS.
Require Import List.
Require Import Relations.
Require Import ICText.
Require Import ICProofs.
Require Import ThreadProofs.
Require Import ThreadTextProofs.

(*
 * Define the multi function which creates multi-step relations.
 *)
Inductive multi {X:Type} (R: relation X) : relation X :=
  | multi_refl : forall (x : X), multi R x x
  | multi_step : forall (x y z : X),
                 R x y -> multi R y z -> multi R x z.

(*
Tactic Notation "multi_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "multi_refl" | Case_aux c "multi_step" ].
*)

Definition multistep := multi step.
Notation " t '==>*' t' " := (multistep t t') (at level 40).

(*
 * Theorem: TransConditionsHold
 *
 * Description:
 *  This theorem shows that all of our very important conditions on the
 *  configuration holds over the transitive closure of the step relation.
 *)
Theorem TransConditionsHold: forall (c1 c2 : config),
  (pcInText c1) /\
  (validThreadIDs c1) /\
  (validCFG c1 (getCFG c1)) /\
  (In (getThread (getCurrThread c1) (getThreadList c1)) (getThreadList c1)) /\
  (textMappedLinear c1) /\
  (AreAllThreadICsInText (getThreadList c1) (c1)) /\
  (AreAllThreadSICsInText (getThreadList c1) (c1)) /\
  (validThreadList (getThreadList c1) (getCFG c1) (getCMMU c1) (getStore c1)) /\
  (In (getTH c1) (getCFG c1)) /\
  (validConfig c1) /\
  (textNotWriteable c1) /\
  (textMappedOnce c1) /\
  (threadListInText (getThreadList c1) (getCFG c1) (getCMMU c1)
  (getTextStart c1) (getTextEnd c1)) /\
  (c1 ==>* c2)
->
  (pcInText c2) /\
  (validThreadIDs c2) /\
  (validCFG c2 (getCFG c2)) /\
  (In (getThread (getCurrThread c2) (getThreadList c2)) (getThreadList c2)) /\
  (textMappedLinear c2) /\
  (AreAllThreadICsInText (getThreadList c2) (c2)) /\
  (AreAllThreadSICsInText (getThreadList c2) (c2)) /\
  (validThreadList (getThreadList c2) (getCFG c2) (getCMMU c2) (getStore c2)) /\
  (In (getTH c2) (getCFG c2)) /\
  (validConfig c2) /\
  (textNotWriteable c2) /\
  (textMappedOnce c2) /\
  (threadListInText (getThreadList c2) (getCFG c2) (getCMMU c2)
  (getTextStart c2) (getTextEnd c2)).
Proof.
intros.
destruct H as [H1 H].
destruct H as [H2 H].
destruct H as [H3 H].
destruct H as [H4 H].
destruct H as [H5 H].
destruct H as [H6 H].
destruct H as [H7 H].
destruct H as [H8 H].
destruct H as [H9 H].
destruct H as [H10 H].
destruct H as [H11 H].
destruct H as [H12 H].
destruct H as [H13 H].
induction H.
repeat (split ; auto).
split.
apply IHmulti.
apply stayPCInText with (c1 := x).
repeat (split ; auto).
apply threadIDsAlwaysValid with (c1 := x).
repeat (split ; auto).
unfold validCFG.
apply cfg32.
apply alwaysValidCFG with (c1 := x).
unfold validCFG in H3.
apply cfg23 in H3.
auto.
apply threadAlwaysThere with (c1 := x).
repeat (split ; auto).
apply stayLinear with (c1 := x).
repeat (split ; auto).
apply stayICInText with (c1 := x).
repeat (split ; auto).
apply staySICInText with (c1 := x).
repeat (split ; auto).
apply threadsAlwaysValid with (c1 := x).
repeat (split ; auto).
apply alwaysGoodTH with (c1 := x).
repeat (split ; auto).
apply alwaysValid with (c1 := x).
auto.
apply neverWriteText with (c1 := x).
auto.
apply neverMapTextTwice with (c1 := x).
repeat (split ; auto).
apply TLAlwaysInText with (c1 :=x).
repeat (split ; auto).

apply IHmulti.
apply stayPCInText with (c1 := x).
repeat (split ; auto).
apply threadIDsAlwaysValid with (c1 := x).
repeat (split ; auto).
unfold validCFG.
apply cfg32.
apply alwaysValidCFG with (c1 := x).
unfold validCFG in H3.
apply cfg23 in H3.
auto.
apply threadAlwaysThere with (c1 := x).
repeat (split ; auto).
apply stayLinear with (c1 := x).
repeat (split ; auto).
apply stayICInText with (c1 := x).
repeat (split ; auto).
apply staySICInText with (c1 := x).
repeat (split ; auto).
apply threadsAlwaysValid with (c1 := x).
repeat (split ; auto).
apply alwaysGoodTH with (c1 := x).
repeat (split ; auto).
apply alwaysValid with (c1 := x).
auto.
apply neverWriteText with (c1 := x).
auto.
apply neverMapTextTwice with (c1 := x).
repeat (split ; auto).
apply TLAlwaysInText with (c1 :=x).
repeat (split ; auto).
Qed.

Theorem TranthreadsAlwaysValid: forall (c1 c2 : config),
(validCFG c1 (getCFG c1)) /\ (validConfig c1) /\ (textNotWriteable c1) /\
(validThreadList (getThreadList c1) (getCFG c1) (getCMMU c1) (getStore c1)) /\
(getTextStart c1) <= (getPhysical (getTLB (getPC c1) (getCMMU c1))) <= (getTextEnd c1) /\
(threadListInText (getThreadList c1)
  (getCFG c1)(getCMMU c1) (getTextStart c1) (getTextEnd c1)) /\
(textMappedOnce c1) /\
(pcInText c1) /\
(textMappedLinear c1) /\
(In (getTH c1) (getCFG c1)) /\
(AreAllThreadICsInText (getThreadList c1) c1) /\
(In (getThread (getCurrThread c1) (getThreadList c1)) (getThreadList c1)) /\
(validThreadIDs c1) /\
(AreAllThreadSICsInText (getThreadList c1) (c1)) /\
(c1 ==>* c2)
->
(validThreadList (getThreadList c2) (getCFG c2) (getCMMU c2) (getStore c2)).
Proof.
intros.
destruct H as [vcfg H].
destruct H as [H1 H2].
destruct H2 as [H2 H3].
destruct H3 as [H4 H3].
destruct H3 as [H9 H3].
destruct H3 as [HA H3].
destruct H3 as [HE H3].
destruct H3 as [pc H3].
destruct H3 as [tml H3].
destruct H3 as [inth H3].
destruct H3 as [goodic H3].
destruct H3 as [inThread H3].
destruct H3 as [validTIDs H3].
destruct H3 as [goodsic H3].
induction H3.
auto.
assert (validThreadList (getThreadList y) (getCFG y) (getCMMU y) (getStore y)).
apply threadsAlwaysValid with (c1 := x).
repeat (split ; auto).
apply IHmulti.
unfold validCFG.
apply cfg32.
apply alwaysValidCFG with (c1 := x).
unfold validCFG in vcfg.
apply cfg23 in vcfg.
auto.
apply alwaysValid with (c1 := x).
auto.
apply neverWriteText with (c1 := x).
auto.
apply threadsAlwaysValid with (c1 := x).
repeat (split ; auto).
apply stayPCInText with (c1 := x).
repeat (split ; auto).
apply TLAlwaysInText with (c1 :=x).
repeat (split ; auto).
apply neverMapTextTwice with (c1 := x).
repeat (split ; auto).
apply stayPCInText with (c1 := x).
repeat (split ; auto).
apply stayLinear with (c1 := x).
repeat (split ; auto).
apply alwaysGoodTH with (c1 := x).
repeat (split ; auto).
apply stayICInText with (c1 := x).
repeat (split ; auto).
unfold validThreadList in H4.
repeat (split ; auto).
apply threadAlwaysThere with (c1 := x).
repeat (split ; auto).
apply threadIDsAlwaysValid with (c1 := x).
repeat (split ; auto).
apply staySICInText with (c1 := x).
repeat (split ; auto).
Qed.

Theorem TransalwaysGoodTH: forall (c1 c2 : config),
(c1 ==>* c2) /\
(In (getTH c1) (getCFG c1)) ->
(In (getTH c2) (getCFG c2)).
Proof.
intros.
destruct H as [H1 H2].
induction H1.
auto.
apply IHmulti.
apply alwaysGoodTH with (c1 := x).
repeat (split ; auto).
Qed.

(*
 * Theorem: Transcfisafe
 *
 * Description:
 *  Prove that the cfisafe theorem is true over the transitive closure of the
 *  step relation.
 *)
Theorem Transcfisafe : forall (c1 c2 c3 c4: config),
  (pcInText c1) /\
  (validThreadIDs c1) /\
  (validCFG c1 (getCFG c1)) /\
  (In (getThread (getCurrThread c1) (getThreadList c1)) (getThreadList c1)) /\
  (textMappedLinear c1) /\
  (AreAllThreadICsInText (getThreadList c1) (c1)) /\
  (AreAllThreadSICsInText (getThreadList c1) (c1)) /\
  (validThreadList (getThreadList c1) (getCFG c1) (getCMMU c1) (getStore c1)) /\
  (In (getTH c1) (getCFG c1)) /\
  (validConfig c1) /\
  (textNotWriteable c1) /\
  (textMappedOnce c1) /\
  (threadListInText (getThreadList c1) (getCFG c1) (getCMMU c1)
  (getTextStart c1) (getTextEnd c1)) /\
  (c1 ==>* c3) /\
  (c3 ==> c4) /\
  (c4 ==>* c2)
  ->
  (getPC c4) = (getPC c3 + 1) \/
  (In (getPC c4) (getCFG c3)) \/
  ((vlookup (minus (getPC c4) 1) c4) = svaSwap) \/
  ((getPC c4) = (getICPC (itop (getThreadICList (getCurrThread c3) (getThreadList c3))))).
Proof.
intros.
destruct H as [I1 I].
destruct I as [I2 I].
destruct I as [I3 I].
destruct I as [I4 I].
destruct I as [I5 I].
destruct I as [I6 I].
destruct I as [I7 I].
destruct I as [I8 I].
destruct I as [I9 I].
destruct I as [I10 I].
destruct I as [I13 I].
destruct I as [I14 I].
destruct I as [I15 I].
destruct I as [I16 I].
destruct I as [I17 I].
apply cfisafe.
split.
auto.
split.
apply TranthreadsAlwaysValid with (c1 := c1).
repeat (split ; auto).
apply TransalwaysGoodTH with (c1 := c1).
repeat (split ; auto).
Qed.

(*
 * Theorem: TranNXText
 *
 * Description:
 *   Prove that NXText holds over the transitive closure.
 *)
Theorem TranNXText : forall (c1 c2 : config) (v : nat),
(getTextStart c1) <= (getPhysical (getTLB v (getCMMU c1))) <= (getTextEnd c1) /\
(validConfig c1) /\
(textNotWriteable c1) /\
(textMappedOnce c1) /\
c1 ==>* c2
-> (vLookup v (getCMMU c1) (getStore c1)) =
   (vLookup v (getCMMU c2) (getStore c2)).
Proof.
intros.
destruct H as [H1 H].
destruct H as [H2 H].
destruct H as [H3 H].
destruct H as [H4 H].
induction H.

(* Case 1 *)
auto.

(* Case 2 *)
assert ((vLookup v (getCMMU x) (getStore x)) = (vLookup v (getCMMU y) (getStore y))).
apply NXText.
auto.
rewrite <- IHmulti.
apply H5.

(* Show that the intermediate configuration y is in the text section *)
apply alwaysInText with x.
auto.

(* Show that the intermediate configuration y is valid *)
apply alwaysValid with x.
auto.

(* Show that the intermediate configuration y has a non-writeable text section *)
apply neverWriteText with x.
auto.

(* Show that the intermediate configuration y has its text section only mapped once *)
apply neverMapTextTwice with x.
auto.
Qed.


From aneris_examples.consensus Require Import paxos_prelude.
From aneris.aneris_lang.lib Require Import map_proof.

Import RecordSetNotations.

Section paxos_learner.
  Context `{!anerisG (Paxos_model params) Σ}.
  Context `{!paxosG Σ params}.

  Lemma learner_spec h (l : Learner) R T av :
    let ip := ip_of_address (`l) in
    is_set Acceptors av →
    `l ⤇ learner_si -∗
    h ↪[ip] (udp_socket (Some (`l)) true) -∗
    `l @ learner_si ⤳# (R, T) -∗
    WP learner int_serializer #(LitSocket h) av @[ip]
    {{ v, ∃ (Q : gset Acceptor) (bal : Ballot) (val : Value) R T,
            h ↪[ip] (udp_socket (Some (`l)) true) ∗
            `l @ learner_si ⤳# (R, T) ∗
            ⌜QuorumA Q⌝ ∗ ⌜v = $(bal, val)⌝ ∗
            [∗ set] a ∈ Q, msgs_elem_of (msg2b a bal val) }}.
  Proof.
    iIntros (??) "#Hl_si Hh Hl". rewrite /learner.
    wp_pures.
    wp_apply wp_set_cardinal; [done|]; iIntros "_".
    wp_pures.
    wp_apply (wp_map_empty Ballot val); [done|].
    iIntros (??).
    wp_alloc lv as "Hlv".
    do 4 wp_pure _.
    (* loop invariant *)
    iAssert (∃ m v, lv ↦[ip] v ∗ ⌜is_map v m⌝ ∗
                    [∗ map] bal ↦ xv ∈ m,
                    ∃ (X : gset Acceptor) val,
                      ⌜is_set X xv⌝ ∗ shot bal val ∗
                      ([∗ set] x ∈ X, msgs_elem_of (msg2b x bal val)))%I
      with "[Hlv]" as "H".
    { iExists ∅, _. iFrame. rewrite big_sepM_empty //. }
    wp_pure _.
    iLöb as "IH" forall (R T).
    iDestruct "H" as (d vd) "(Hlv & %Hd & Hmsgs)".
    wp_pures.
    wp_bind (ReceiveFrom _).
    wp_apply (aneris_wp_pers_receivefrom with "[$Hh $Hl $Hl_si]");
      [done|done|done|].
    iIntros (m) "(Hh & Hl & (%a & %b & %z & %Hser & -> & #Hshot & #Hm))".
    wp_apply wp_unSOME; [done|]; iIntros "_".
    wp_pures.
    wp_apply (s_deser_spec learner_serialization); [done|]; iIntros "_".
    wp_pures. wp_load. wp_pures.
    wp_apply (wp_map_lookup $! Hd).
    destruct (d !! b) as [p|] eqn:Heq; iIntros (? ->).
    - wp_pures.
      iDestruct (big_sepM_delete _ _ b p with "Hmsgs")
        as "[(%X & %v' & %HX & #Hshot' & #HX) Hmsgs]"; [done|].
      iDestruct (shot_agree with "Hshot Hshot'") as %<-.
      wp_apply (wp_set_add $! HX).
      iIntros (? HX').
      wp_pures.
      wp_apply wp_set_cardinal; [done|]; iIntros "_".
      wp_op.
      case_bool_decide as Hsize; wp_pures.
      + iExists ({[a]} ∪ X), _, _, _, _. iFrame. iSplit.
        { iPureIntro.
          apply majority_show_quorum.
          apply Nat2Z.inj_ge.
          rewrite Hsize. lia. }
        iSplit; [done|].
        destruct (decide (a ∈ X)).
        { by assert ({[a]} ∪ X = X) as -> by set_solver. }
        rewrite big_sepS_union ?big_sepS_singleton; [|set_solver].
        iFrame "#".
      + wp_apply (wp_map_insert $! Hd).
        iIntros (d' Hd').
        wp_store.
        wp_apply ("IH" with "Hh Hl").
        iExists (<[b:= _]> d), _. iFrame. iSplit; [done|].
        rewrite big_sepM_insert_delete.
        iFrame.
        iExists ({[a]} ∪ X), _. iFrame "#".
        iSplit; [done|].
        destruct (decide (a ∈ X)).
        { by assert ({[a]} ∪ X = X) as -> by set_solver. }
        rewrite big_sepS_union ?big_sepS_singleton; [|set_solver].
        iFrame "#".
    - wp_pures.
      wp_apply (wp_set_empty Acceptor); [done|].
      iIntros (? HX).
      wp_pures.
      wp_apply (wp_set_add $! HX).
      iIntros (? HX').
      wp_pures.
      wp_apply wp_set_cardinal; [done|]; iIntros "_".
      rewrite union_empty_r_L size_singleton.
      wp_op.
      case_bool_decide as Hsize; wp_pures.
      + iExists {[a]}, _, _, _, _.
        rewrite big_sepS_singleton //.
        iFrame "∗ #".
        iSplit; [|done].
        iPureIntro.
        apply majority_show_quorum.
        rewrite size_singleton. lia.
      + wp_apply (wp_map_insert $! Hd).
        iIntros (d' Hd').
        wp_store.
        wp_apply ("IH" with "Hh Hl").
        iExists (<[b:= _]> d), _. iFrame. iSplit; [done|].
        rewrite big_sepM_insert //.
        iFrame.
        iExists {[a]}, _.
        iFrame "#".
        rewrite union_empty_r_L in HX'.
        iSplit; [done|].
        rewrite big_sepS_singleton //.
  Qed.

End paxos_learner.


Require compcertx.common.SmallstepX.
Require compcert.common.Behaviors.

Import Classical.
Import ClassicalEpsilon.
Import Coqlib.
Import Events.
Import Globalenvs.
Import Integers.
Import SmallstepX.

Set Implicit Arguments.

Export Behaviors.

(* A behavior is wrong both in a semantics and its erased version *)

Lemma semantics_without_retval_state_goes_wrong_intro {RETVAL: Type} (S: Smallstep.semantics RETVAL) (s: Smallstep.state S) (t: trace):
  state_behaves S s (Goes_wrong t) ->
  state_behaves (semantics_without_retval S) s (Goes_wrong t).
Proof.
  inversion 1; subst.
  econstructor; eauto.
  intros r.
  intro ABSURD.
  inversion ABSURD; subst.
  firstorder.
Qed.

Lemma semantics_without_retval_state_goes_wrong_elim {RETVAL: Type} (S: Smallstep.semantics RETVAL) (s: Smallstep.state S) (t: trace):
  state_behaves (semantics_without_retval S) s (Goes_wrong t) ->
  state_behaves S s (Goes_wrong t).
Proof.
  inversion 1; subst.
  econstructor; eauto.
  intros r.
  intro ABSURD.
  apply (H3 tt).
  econstructor; eauto.
Qed.

(* Strong safety *)

Section WITHRETVAL.
Context {RETVAL: Type}.

Definition strongly_safe_state (S: Smallstep.semantics RETVAL) (s: Smallstep.state S) :=
  forall t1 s1,
    Smallstep.star (Smallstep.step S) (Smallstep.globalenv S) s t1 s1 ->
    (exists r, Smallstep.final_state S s1 r) \/
    (exists t2 s2, Smallstep.step S (Smallstep.globalenv S) s1 t2 s2).

Definition strongly_safe_state_beh (S: Smallstep.semantics RETVAL) (s: Smallstep.state S) :=
  ~ exists t, state_behaves S s (Goes_wrong t).

Lemma strongly_safe_state_beh_intro (S: Smallstep.semantics RETVAL) (s: Smallstep.state S):
  strongly_safe_state S s ->
  strongly_safe_state_beh S s.
Proof.
  unfold strongly_safe_state, strongly_safe_state_beh.
  intros H.
  intro ABSURD.
  destruct ABSURD as (t & Ht).
  inversion Ht; subst.
  unfold nostep in H2.
  apply H in H1.
  firstorder.
Qed.

Lemma strongly_safe_state_beh_elim (S: Smallstep.semantics RETVAL) (s: Smallstep.state S):
  strongly_safe_state_beh S s ->
  strongly_safe_state S s.
Proof.
  unfold strongly_safe_state, strongly_safe_state_beh.
  intros H t1 s1 H0.
  destruct (Classical_Prop.classic (exists r, Smallstep.final_state S s1 r)); auto.
  right.
  destruct (Classical_Prop.classic (exists t2 s2, Step S s1 t2 s2)); auto.
  destruct H.
  exists t1.
  econstructor; eauto.
  unfold nostep.
  firstorder.
Qed.

Definition strongly_safe (S: Smallstep.semantics RETVAL) :=
  ~ exists t, program_behaves S (Goes_wrong t).

End WITHRETVAL.

Lemma strongly_safe_without_retval {RETVAL: Type} (S: Smallstep.semantics RETVAL):
  strongly_safe (semantics_without_retval S) <-> strongly_safe S.
Proof.
  unfold strongly_safe.
  split.
  * intros H.
    intro ABSURD.
    apply H; clear H.
    destruct ABSURD as (t & Ht).
    inversion Ht; subst.
    + exists t.
      econstructor; eauto.
      apply semantics_without_retval_state_goes_wrong_intro; auto.
    + exists E0.
      right; auto.
  * intros H.
    intro ABSURD.
    destruct ABSURD as (t & Ht).
    apply H; clear H.
    inversion Ht; subst.
    + exists t.
      econstructor; eauto.
      apply semantics_without_retval_state_goes_wrong_elim; auto.
    + exists E0.
      right; auto.
Qed.

(* If the target language of a forward simulation is weakly determinate,
   and if the source is strongly safe, then the target is strongly safe. *)

Theorem forward_simulation_strongly_safe {RETVAL: Type} (S1 S2: Smallstep.semantics RETVAL):
  receptive S1 ->
  weak_determ S2 ->
  forward_simulation S1 S2 ->
  strongly_safe S1 ->
  strongly_safe S2.
Proof.
  intros H H0 X H1.
  rewrite <- strongly_safe_without_retval in H1.
  rewrite <- strongly_safe_without_retval.
  apply semantics_without_retval_forward_to_backward in X; auto.
  unfold strongly_safe in H1 |- * .
  intro ABSURD.
  destruct ABSURD as (t & BEH).
  apply (backward_simulation_same_safe_behavior X) in BEH.
  * firstorder.
  * unfold not_wrong.
    intros beh H2.
    destruct beh; auto.
    firstorder.
Qed.

Section WITHMEMORYMODELOPS.
Context `{memory_model_ops: Mem.MemoryModelOps}.

Lemma strongly_safe_with_inject_elim val `{VLIO: ValLessdefInjectOps val} (S: semantics (val * mem)) m:
  strongly_safe (semantics_with_inject S m) ->
  strongly_safe S.
Proof.
  unfold strongly_safe.
  intros H.
  intro ABSURD.
  destruct ABSURD as (t & ABSURD).
  apply H; clear H.
  inversion ABSURD; subst.
  {
    inversion H0; subst.
    esplit.
    eleft.
    eassumption.
    econstructor; eauto.
    intros r.
    intro ABSURD' .
    inversion ABSURD' .
    subst.
    eapply H4; eauto.
  }
  esplit.
  eright.
  assumption.
Qed.

End WITHMEMORYMODELOPS.


Require Import Coq.Lists.List.
Import ListNotations.
Require Import Coq.ZArith.ZArith.
Require Import Bool.

Require Import util.
Require Import variables.
Require Import functions.
Require Import functions_fun_rules.
Require Import trans_rel.
Require Import states.
Require Import s_dfrs.
Require Import e_dfrs.

(* The following hypotheses need to be properly formulated and proved
   in order go guarantee that the functions defined here are sound:
   they always yield elements whose corresponding well-formedness
   properties hold. *)

Hypothesis asgmts_valid :
  forall (l : list ASGMT),
    (0 < (length l))
    /\ is_function l
          (fun (asgmt1 asgmt2 : ASGMT)
                => string_dec
                     (fst asgmt1.(asgmt)).(vname)
                     (fst asgmt2.(asgmt)).(vname)).

Hypothesis variables_valid :
  forall (I O : SVARS) (T : STIMERS) (gcvar : (NAME * TYPE)),
    ind_rules_dfrs_variables I O T gcvar.

Hypothesis states_valid :
  forall (l : list STATE),
    ind_rules_states l.

Hypothesis dfrs_states_valid :
  forall (s : STATE) (ss : STATES),
    ind_rules_dfrs_states s ss.

Hypothesis dfrs_trans_rel_valid :
  forall (tr : TRANSREL),
    ind_rules_dfrs_trans_rel tr.

Hypothesis e_dfrs_valid :
  forall (vars : DFRS_VARIABLES) (sts : DFRS_STATES) (tr : DFRS_TRANSITION_RELATION),
    ind_rules_e_dfrs vars sts tr.

Definition ranB (v : VALUE) : bool :=
  match v with
  | b _ => true
  | _   => false
  end.

Definition ranI (v : VALUE) : bool :=
  match v with
  | i _ => true
  | _   => false
  end.

Definition ranN (v : VALUE) : bool :=
  match v with
  | n _ => true
  | _   => false
  end.

Definition ble_value (t1 t2 : VALUE) : bool :=
  match t1,t2 with
  | i t1, i t2 => Z.leb t1 t2
  | n t1, n t2 => Nat.leb t1 t2
  | _, _ => false
  end.

Definition blt_value (t1 t2 : VALUE) : bool :=
  match t1,t2 with
  | i t1, i t2 => Z.ltb t1 t2
  | n t1, n t2 => Nat.ltb t1 t2
  | _, _ => false
  end.

Definition bne_value (t1 t2 : VALUE) : bool :=
  match t1,t2 with
  | b t1, b t2 => negb (eqb t1 t2)
  | i t1, i t2 => negb (Z.eqb t1 t2)
  | n t1, n t2 => negb (Nat.eqb t1 t2)
  | _, _ => false
  end.

Definition bgt_value (t1 t2 : VALUE) : bool :=
  match t1,t2 with
  | i t1, i t2 => Z.gtb t1 t2
  | n t1, n t2 => negb (Nat.leb t1 t2)
  | _, _ => false
  end.

Definition bge_value (t1 t2 : VALUE) : bool :=
  match t1,t2 with
  | i t1, i t2 => Z.geb t1 t2
  | n t1, n t2 => negb (Nat.ltb t1 t2)
  | _, _ => false
  end.

Fixpoint union_lists {X : Type} (ll : list (list X)) : list X :=
  match ll with
  | []     => []
  | h :: t => List.app h (union_lists t)
  end.

Fixpoint gen_possible_asgmts (v : VNAME) (l : list VALUE)  : list ASGMT :=
  match l with
  | []     => []
  | h :: t => mkASGMT (v, h) :: gen_possible_asgmts v t
  end.

Fixpoint possible_asgmts (ll : list (VNAME * list VALUE)) : list (list ASGMT) :=
  match ll with
  | []     => []
  | h :: t => (gen_possible_asgmts (fst h) (snd h))
                     :: possible_asgmts t
  end.

Definition add_possible_assignment (a : ASGMT) (ll : list (list ASGMT)) : list (list ASGMT) :=
  map (fun (l : list ASGMT) => a :: l) ll.

Fixpoint add_possible_assignments (l : list ASGMT) (ll : list (list ASGMT)) : list (list ASGMT) :=
  match l with
  | []      => []
  | h :: tl => add_possible_assignment h ll
               ++ add_possible_assignments tl ll
  end.

Fixpoint gen_asgmts_combination (ll1 ll2 : list (list ASGMT)) : list (list ASGMT) :=
  match ll1 with
  | []      => [[]]
  | h :: tl => add_possible_assignments h (gen_asgmts_combination tl ll2)
  end.

(** static_bexps_true *)
Fixpoint static_bexps_true (l : list (NAME * VALUE)) (be : BEXP) : bool :=
  match l with
  | []      => true
  | f :: fs => if bstring_dec (fst f) (var_name be).(vname)
               then (if ranB (snd f)
                      then
                        let
                          eq_value := beq_value (snd f) be.(literal)
                        in
                          match be.(op) with
                          | eq  => eq_value
                          | ne  => negb eq_value
                          | _   => false
                          end
                      else (if ranI (snd f) || ranN (snd f)
                            then match be.(op) with
                                 | le => ble_value (snd f) be.(literal)
                                 | lt => blt_value (snd f) be.(literal)
                                 | eq => beq_value (snd f) be.(literal)
                                 | ne => bne_value (snd f) be.(literal)
                                 | gt => bgt_value (snd f) be.(literal)
                                 | ge => bge_value (snd f) be.(literal)
                                 end
                            else false))
               else static_bexps_true fs be
  end.

Definition minus_value (v1 v2 : VALUE) : VALUE :=
  match v1, v2 with
  | n n1, n n2 => (n (n1 - n2))
  | i i1, i i2 => (i (i1 - i2))
  | _   , _    => v1
  end.

(** timed_bexps_true *)
Fixpoint timed_bexps_true (l : list (NAME * VALUE)) (be : BEXP)
  (gc : (NAME * (VALUE * VALUE))) : bool :=
  match l with
  | []      => true
  | f :: fs => if bstring_dec (fst f) (var_name be).(vname)
               then
                  (if ranN (snd f)
                  then (match be.(op) with
                        | le => ble_value (minus_value (snd (snd gc))
                                                       (snd f)) be.(literal)
                        | lt => blt_value (minus_value (snd (snd gc))
                                                       (snd f)) be.(literal)
                        | eq => beq_value (minus_value (snd (snd gc))
                                                       (snd f)) be.(literal)
                        | ne => bne_value (minus_value (snd (snd gc))
                                                       (snd f)) be.(literal)
                        | gt => bgt_value (minus_value (snd (snd gc))
                                                       (snd f)) be.(literal)
                        | ge => bge_value (minus_value (snd (snd gc))
                                                       (snd f)) be.(literal)
                        end)
                  else false)
               else timed_bexps_true fs be gc
  end.

(** static_guards_true *)
Fixpoint values_in_static_bexps_true (be : list BEXP) (s : STATE) : bool :=
  match be with
  | []     => false
  | h :: t => if (match h.(v) with
                  | current _  => static_bexps_true (current_values s) h
                  | previous _ => static_bexps_true (previous_values s) h
                  end)
              then true
              else values_in_static_bexps_true t s
  end.

Fixpoint static_guards_true (s : STATE) (conjs : list DISJ)
  (IO T : list (VNAME * TYPE)) : bool :=
  match conjs with
  | []      => true
  | h :: tl => (values_in_static_bexps_true h.(disjs) s)
               && (static_guards_true s tl IO T)
  end.

(** timed_guards_true *)
Fixpoint values_in_timed_bexps_true (be : list BEXP) (s : STATE)
  (gc : option (NAME * (VALUE * VALUE))) : bool :=
  match be with
  | []     => false
  | h :: t => if (match h.(v) with
                  | current _  => (match gc with
                                   | Some e => timed_bexps_true
                                                (current_values s) h e
                                   | None   => false
                                   end)
                  | previous _ => (match gc with
                                   | Some e => timed_bexps_true
                                                (previous_values s) h e
                                   | None   => false
                                   end)
                  end)
              then true
              else values_in_timed_bexps_true t s gc
  end.

Fixpoint timed_guards_true (s : STATE) (conjs : list DISJ)
  (T : list (VNAME * TYPE)) : bool :=
  let
    gc := get_gc s.(state)
  in
    match conjs with
    | []      => true
    | h :: tl => (values_in_timed_bexps_true h.(disjs) s gc)
                 && (timed_guards_true s tl T)
    end.

(** is_stable *)
Definition beq_state_element_current
(e1 e2 : (NAME * (VALUE * VALUE))) : bool :=
  bstring_dec (fst e1) (fst e2)
  && beq_value (snd (snd e1)) (snd (snd e2)).

Definition beq_state_current (s1 s2 : STATE) : bool :=
  bsame_list s1.(state) s2.(state) beq_state_element_current.

Fixpoint is_stable_entry (s : STATE) (IO T : list (VNAME * TYPE))
  (le : list (EXP * EXP * ASGMTS * REQUIREMENT)) : bool :=
  match le with
  | []     => true
  | h :: t => if (negb (static_guards_true s (fst3 (fst h)).(conjs) IO T))
                 ||
                 (negb (timed_guards_true s (snd3 (fst h)).(conjs) T))
                 ||
                 beq_state_current s
                           (nextState s T (trd3 (fst h)))
               then is_stable_entry s IO T t
               else false
  end.

Definition is_stable (s : STATE) (IO T : list (VNAME * TYPE))
  (F : list (list FUNCTION)) : bool :=
  let
    entries := union_lists
                (map (fun f : FUNCTION => f.(function)) (union_lists F))
  in
   is_stable_entry s IO T entries.

Fixpoint make_trans_del (s : STATE) (I T : list (VNAME * TYPE))
  (a : list (list ASGMT)) : list TRANS :=
  match a with
  | []     => []
  | h :: t => let
                nextSt := nextState s T (mkASGMTS h (asgmts_valid h))
              in
              let
                delay := discrete 1
              in
              (mkTRANS (s, (del (delay, mkASGMTS h (asgmts_valid h))),
                        mkSTATE (update_gc nextSt.(state)
                                           nextSt.(state) delay)
                                (state_valid (update_gc nextSt.(state)
                                                        nextSt.(state) delay))))
              :: make_trans_del s I T t
  end.

Fixpoint make_trans_func (s : STATE) (IO T : list (VNAME * TYPE))
  (le : list (EXP * EXP * ASGMTS * REQUIREMENT)) : list TRANS :=
  match le with
  | []     => []
  | h :: t => if static_guards_true s (fst3 (fst h)).(conjs) IO T
                &&
                 timed_guards_true s (snd3 (fst h)).(conjs) T
              then
                ( if beq_state_current s (nextState s T (trd3 (fst h)))
                  then
                    make_trans_func s IO T t
                  else
                   (mkTRANS (s, (func (trd3 (fst h), snd h)),
                            nextState s T (trd3 (fst h))))
                   :: make_trans_func s IO T t
                )
              else make_trans_func s IO T t
  end.

Definition genTransitions (s : STATE) (I O T : list (VNAME * TYPE))
  (F : list (list FUNCTION)) (possibilities : list (VNAME * list VALUE))
  : TRANSREL :=
  let
    entries := union_lists
                (map (fun f : FUNCTION => f.(function)) (union_lists F))
  in
  let
    combinations := gen_asgmts_combination
                      (possible_asgmts possibilities) [[]]
  in
    if is_stable s (List.app I O) T F
    then mkTRANSREL (make_trans_del s I T combinations)
    else mkTRANSREL (make_trans_func s (I ++ O) T entries).

Fixpoint bin_state_list (v : list (NAME * (VALUE * VALUE)))
  (l : list STATE) (comp : list (NAME * (VALUE * VALUE)) ->
  list (NAME * (VALUE * VALUE)) -> bool) : bool :=
  match l with
  | []      => false
  | h :: tl => if comp v h.(state) then true
               else bin_state_list v tl comp
  end.

Fixpoint get_list_states (l : list TRANS) (visited : list STATE) : list STATE :=
  match l with
  | []     => []
  | h :: t => if bin_state_list (trd3 h.(STS)).(state) visited beq_state_elements
              then get_list_states t visited
              else trd3 h.(STS) :: get_list_states t visited
  end.

(* buildTR *)
Fixpoint buildTR (toVisit visited : list STATE) (I Out T : list (VNAME * TYPE))
  (F : list (list FUNCTION)) (possibilities : list (VNAME * list VALUE))
  (num : nat) : list TRANS :=
  match toVisit, num with
  | []    , _  => []
  | _ :: _, 0    => []
  | h :: t, S n' => let
                      tr1 := genTransitions h I Out T F possibilities
                    in
                      if bin_state_list h.(state) visited beq_state_elements
                      then buildTR t visited I Out T F possibilities n'
                      else tr1.(transrel) ++
                           buildTR
                            (t ++ (get_list_states tr1.(transrel)
                                    (h :: visited)))
                            (h :: visited) I Out T F possibilities n'
  end.

Definition call_buildTR (toVisit visited : list STATE)
  (I Out T : list (VNAME * TYPE)) (F : list (list FUNCTION)) (limiter : nat)
  (possibilities : list (VNAME * list VALUE)) : list TRANS :=
  let
    numTR := limiter
  in
    buildTR toVisit visited I Out T F possibilities numTR.

(* S to E *)

Fixpoint removeDuplicateStates (l : list STATE) : list STATE :=
  match l with
  | []     => []
  | h :: t => if bin_state_list h.(state) t beq_state_elements
              then removeDuplicateStates t
              else h :: removeDuplicateStates t
  end.

Definition expandedDFRS (sdfrs : s_DFRS) (limiter : nat)
  (possibilities : list (VNAME * list VALUE)) : e_DFRS :=
  let
    TR := mkTRANSREL
          (call_buildTR [sdfrs.(s_dfrs_initial_state).(s0)]
           []
           sdfrs.(s_dfrs_variables).(I).(svars)
           sdfrs.(s_dfrs_variables).(O).(svars)
           sdfrs.(s_dfrs_variables).(T).(stimers)
           [sdfrs.(s_dfrs_functions).(F)]
           limiter possibilities)
  in
  let
    states := removeDuplicateStates (
              (get_list_states TR.(transrel) []) ++
              [sdfrs.(s_dfrs_initial_state).(s0)])
  in
  let
    dfrs_variables := (mkDFRS_VARIABLES sdfrs.(s_dfrs_variables).(I)
                                        sdfrs.(s_dfrs_variables).(O)
                                        sdfrs.(s_dfrs_variables).(T)
                                        sdfrs.(s_dfrs_variables).(gcvar)
                                        (variables_valid
                                          sdfrs.(s_dfrs_variables).(I)
                                          sdfrs.(s_dfrs_variables).(O)
                                          sdfrs.(s_dfrs_variables).(T)
                                          sdfrs.(s_dfrs_variables).(gcvar)))
  in
  let
    dfrs_states := (mkDFRSSTATES
                      (mkSTATES states (states_valid states))
                      sdfrs.(s_dfrs_initial_state).(s0)
                      (dfrs_states_valid
                        sdfrs.(s_dfrs_initial_state).(s0)
                        (mkSTATES states (states_valid states))))
  in
  let
    dfrs_tr := (mkDFRSTRANSITIONREL
                (mkTRANSREL TR.(transrel))
                (dfrs_trans_rel_valid
                  (mkTRANSREL TR.(transrel))))
  in
    mkE_DFRS
      dfrs_variables (* Variables *)
      dfrs_states (* States *)
      dfrs_tr (* TRs *)
      (e_dfrs_valid dfrs_variables dfrs_states dfrs_tr).


Require Import Coq.Lists.List Fiat.Common
        Fiat.Common.ilist
        Fiat.Common.BoundedLookup
        Fiat.Common.IterateBoundedIndex
        Fiat.ADT.ADTSig
        Fiat.ADT.Core
        Fiat.ADTNotation.BuildADTSig
        Fiat.ADTNotation.BuildADT
        Fiat.ADTRefinement.Core Fiat.ADTRefinement.SetoidMorphisms
        Fiat.ADTRefinement.GeneralRefinements
        Fiat.ADTRefinement.GeneralBuildADTRefinements
        Fiat.ADTRefinement.BuildADTRefinements.HoneRepresentation
        Fiat.ADTRefinement.BuildADTSetoidMorphisms.

(* A generic refinement and honing tactic for applying a *)
(* tactic to all the operations of an ADT built from [BuildADT]. *)

Section RefineAllMethods.

  Variable Rep : Type. (* The old representation type. *)

  Lemma refineMethod_eq_sound :
    forall arity Dom Cod
           (cDef refinedCDef : methodType arity Rep Dom Cod),
      refineMethod_eq _ arity cDef refinedCDef ->
      let H := refinedCDef in refineMethod eq _ cDef H.
  Proof.
    simpl; intros; subst.
    induction arity; simpl; intros.
    - induction Dom; simpl; intros.
      + destruct Cod; simpl in *.
        * etransitivity.
          apply refine_under_bind; intros.
          refine pick val (fst a); eauto; simplify with monad laws.
          destruct a; simpl; finish honing.
          simpl; autorewrite with monad laws; eapply H.
        * etransitivity.
          apply refine_under_bind; intros.
          refine pick val a; eauto; simpl; finish honing.
          simpl; autorewrite with monad laws; eapply H.
      + eapply (IHDom (cDef d) (refinedCDef d)).
        unfold refineMethod_eq; intros; eapply H.
    - subst; simpl in *; eauto.
  Qed.

  Lemma refineADT_BuildADT_Rep_refine_All_eq
        {n}
        (methSigs : Vector.t methSig n)
        (methDefs : ilist (B := @methDef Rep) methSigs)
        (refined_methDefs : ilist (B := @methDef Rep) methSigs)
    : Iterate_Ensemble_BoundedIndex (fun idx => refineMethod_eq _ _ (ith methDefs idx) (ith refined_methDefs idx))
      -> refineADT
           (BuildADT methDefs)
           (BuildADT refined_methDefs).
  Proof.
    intros; eapply refineADT_BuildADT_Rep_refine_All with (AbsR := eq).
    - revert H; clear; induction methSigs; simpl in *;
      destruct methDefs; destruct refined_methDefs; try econstructor; simpl.
      intros; destruct H; destruct prim_fst; destruct prim_fst0; econstructor; eauto.
      destruct h; eapply (@refineMethod_eq_sound _ methDom methCod); eauto.
  Qed.

End RefineAllMethods.

Ltac ilist_of_evar1 B As k :=
  lazymatch As with
    | Vector.nil _ => k (@inil _ B)
    | Vector.cons _ ?a ?n ?As' =>
      makeEvar (B a)
               ltac:(fun b =>
                       ilist_of_evar1
                         B As'
                         ltac:(fun Bs' => k (icons (n := n) b Bs')))
  end.

Ltac refineEachMethod :=
  lazymatch goal with
  |- Sharpened (@BuildADT ?Rep _ _ ?consSigs ?methSigs ?consDefs ?methDefs) =>
  ilist_of_evar1
        (@methDef Rep)
        methSigs
        ltac:(fun rMeths =>
                eapply refineADT_BuildADT_Rep_refine_All_eq
                with (refined_methDefs := rMeths)
             ); unfold refineMethod_eq;
    simpl; repeat apply Build_prim_and; intros;
    first [ instantiate (1 := {| methBody :=  _ |})
          | eauto ]; simpl
  end.


Set Implicit Arguments.
Require Export LanguageModuleDef.
Require Export DynamicSemanticsTypeSubstitution.
Require Export DynamicSemanticsHeapObjects.
Require Export DynamicSemantics.
Require Export DynamicSemanticsTypeSubstitution.
Require Export StaticSemanticsKindingAndContextWellFormedness.
Require Export StaticSemantics.
Require Export TypeSafety.
Require Export CpdtTactics.
Require Export Case.

(* Dan says, pg 65, we cannot derive \Delta, \alpha : A |-k- \alpha : \Kappa we we
   can derive \Delta, \alpha : A |-k- \alpha *: B.

   Let's prove this as I'm worried that he means Figure 3.6
        \Delta |-k- \tau : B -> \Delta |-k- tau : A
   is only to be applied to concrete types.

  Or does he have a K for AK ?

*)

Example alpha_star_B :
    K (D.ctxt (TV.var 0) A ddot) (ptype (tv_t (TV.var 0))) B.
Proof.
  apply K_star_A.
  eauto 20 with Chapter3.
Qed.

(* Which invalidates the return progress theorem unless it's type is
  restricted. This explains a lot. *)

Lemma can_K_alpha :
  exists (d : Delta) (alpha : TV.T) (k1 k2 : Kappa),
    K (D.ctxt alpha k1 d) (tv_t alpha) k2.
Proof.
  apply ex_intro with (x:= ddot).
  apply ex_intro with (x:= (TV.var 0)).
  apply ex_intro with (x:= B).
  apply ex_intro with (x:= B).
  constructor.
  reflexivity.
Qed.

Lemma can_K_alpha_A :
  exists (d : Delta) (alpha : TV.T) (k1 k2 : Kappa),
    K (D.ctxt alpha k1 d) (tv_t alpha) k2.
Proof.
  apply ex_intro with (x:= ddot).
  apply ex_intro with (x:= (TV.var 0)).
  apply ex_intro with (x:= B).
  apply ex_intro with (x:= A).
  constructor.
  constructor.
  reflexivity.
Qed.

Lemma can_AK_alpha :
  ~ exists (k1 k2 : Kappa),
      AK (D.ctxt (TV.var 0) k1 ddot) (tv_t (TV.var 0)) k2.
Proof.
  unfold not.
  intros.
  destruct H as [k1]; destruct H as [k2]; destruct k1; destruct k2;
  try inversion H; try inversion H0; crush.
  admit.
  inversion H.
  simpl in H3.
Admitted.

Lemma can_AK_alpha_A :
  exists (d : Delta) (alpha : TV.T) (k1 k2 : Kappa),
    K (D.ctxt alpha k1 ddot) (tv_t alpha) k2.
Proof.
  apply ex_intro with (x:= ddot).
  apply ex_intro with (x:= (TV.var 0)).
  apply ex_intro with (x:= B).
  apply ex_intro with (x:= A).
  constructor.
  constructor.
  reflexivity.
Qed.


(* This file shows that the fancy update can be encoded in terms of the
view shift, and that the laws of the fancy update can be derived from the
laws of the view shift. *)
From stdpp Require Export coPset.
From iris.proofmode Require Import proofmode.
From iris.base_logic Require Export base_logic.
From iris.prelude Require Import options.

(* The sections add extra BI assumptions, which is only picked up with [Type*]. *)
Set Default Proof Using "Type*".

Section fupd.
Context {M} (vs : coPset → coPset → uPred M → uPred M → uPred M).

Notation "P ={ E1 , E2 }=> Q" := (vs E1 E2 P Q)
  (at level 99, E1,E2 at level 50, Q at level 200,
   format "P  ={ E1 , E2 }=>  Q") : bi_scope.

Context (vs_ne : ∀ E1 E2, NonExpansive2 (vs E1 E2)).
Context (vs_persistent : ∀ E1 E2 P Q, Persistent (P ={E1,E2}=> Q)).

Context (vs_impl : ∀ E P Q, □ (P → Q) ⊢ P ={E,E}=> Q).
Context (vs_transitive : ∀ E1 E2 E3 P Q R,
  (P ={E1,E2}=> Q) ∧ (Q ={E2,E3}=> R) ⊢ P ={E1,E3}=> R).
Context (vs_mask_frame_r : ∀ E1 E2 Ef P Q,
  E1 ## Ef → (P ={E1,E2}=> Q) ⊢ P ={E1 ∪ Ef,E2 ∪ Ef}=> Q).
Context (vs_frame_r : ∀ E1 E2 P Q R, (P ={E1,E2}=> Q) ⊢ P ∗ R ={E1,E2}=> Q ∗ R).
Context (vs_exists : ∀ {A} E1 E2 (Φ : A → uPred M) Q,
  (∀ x, Φ x ={E1,E2}=> Q) ⊢ (∃ x, Φ x) ={E1,E2}=> Q).
Context (vs_persistent_intro_r : ∀ E1 E2 P Q R,
  Persistent R →
  (R -∗ (P ={E1,E2}=> Q)) ⊢ P ∗ R ={E1,E2}=> Q).

Definition fupd (E1 E2 : coPset) (P : uPred M) : uPred M :=
  ∃ R, R ∗ vs E1 E2 R P.

Notation "|={ E1 , E2 }=> Q" := (fupd E1 E2 Q) : bi_scope.

Global Instance fupd_ne E1 E2 : NonExpansive (@fupd E1 E2).
Proof. solve_proper. Qed.

Lemma fupd_intro E P : P ⊢ |={E,E}=> P.
Proof. iIntros "HP". iExists P. iFrame "HP". iApply vs_impl; auto. Qed.

Lemma fupd_mono E1 E2 P Q : (P ⊢ Q) → (|={E1,E2}=> P) ⊢ |={E1,E2}=> Q.
Proof.
  iIntros (HPQ); iDestruct 1 as (R) "[HR Hvs]".
  iExists R; iFrame "HR". iApply (vs_transitive with "[$Hvs]").
  iApply vs_impl. iIntros "!> HP". by iApply HPQ.
Qed.

Lemma fupd_trans E1 E2 E3 P : (|={E1,E2}=> |={E2,E3}=> P) ⊢ |={E1,E3}=> P.
Proof.
  iDestruct 1 as (R) "[HR Hvs]". iExists R. iFrame "HR".
  iApply (vs_transitive with "[$Hvs]"). clear R.
  iApply vs_exists; iIntros (R). iApply vs_persistent_intro_r; iIntros "Hvs".
  iApply (vs_transitive with "[$Hvs]"). iApply vs_impl; auto.
Qed.

Lemma fupd_mask_frame_r E1 E2 Ef P :
  E1 ## Ef → (|={E1,E2}=> P) ⊢ |={E1 ∪ Ef,E2 ∪ Ef}=> P.
Proof.
  iIntros (HE); iDestruct 1 as (R) "[HR Hvs]". iExists R; iFrame "HR".
  by iApply vs_mask_frame_r.
Qed.

Lemma fupd_frame_r E1 E2 P Q : (|={E1,E2}=> P) ∗ Q ⊢ |={E1,E2}=> P ∗ Q.
Proof.
  iIntros "[Hvs HQ]". iDestruct "Hvs" as (R) "[HR Hvs]".
  iExists (R ∗ Q)%I. iFrame "HR HQ". by iApply vs_frame_r.
Qed.
End fupd.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Loop-unrolling. *)

Require Import Coqlib.
Require Import Errors.
Require Import Maps.
Require Import Compopts.
Require Import AST.
Require Import Integers.
Require Import Globalenvs.
Require Import Switch.
Require Import Op.
Require Import Registers.
Require Cminor.
Require Import CminorSel.
Require Compopts.

Local Open Scope error_monad_scope.

(** * iterated sequence *)

Fixpoint iterseq (count: nat) (s1 s2:stmt) : stmt :=
 match count with
 | 0%nat => s2
 | S n => Sseq s1 (iterseq n s1 s2)
 end.

(** * Loop-unrolling

We perform loop-unrolling based on an external oracle that assigns
the number of loop-unfolds for each loop. The transformation fails
whenever one attempts to unfold a loop whose body has any label (but
succeeds if the oracle leave those loop untouched).
*)

Definition unroll_flag n := andb (NPeano.Nat.eqb n O).

Fixpoint unroll_stmt b (guess: positive -> nat) (s: stmt) (pos:positive): res stmt:=
  match s with
  | Sseq s1 s2 => do s1' <- unroll_stmt b guess s1 (xO pos);
                  do s2' <- unroll_stmt b guess s2 (xI pos);
                  OK (Sseq s1' s2')
  | Sifthenelse c s1 s2 => do s1' <- unroll_stmt b guess s1 (xO pos);
                           do s2' <- unroll_stmt b guess s2 (xI pos);
                           OK (Sifthenelse c s1' s2')
  | Sloop s => let guess_pos := guess pos in
               do s' <- unroll_stmt (unroll_flag guess_pos b) guess s (xO pos);
               OK (iterseq guess_pos s' (Sloop s'))
  | Sblock s => do s' <- unroll_stmt b guess s pos;
                OK (Sblock s')
  | Slabel i s => if b
                  then (do s' <- unroll_stmt b guess s pos;
                        OK (Slabel i s'))
                  else Error (msg "LoopUnroll: trying to unfold loop body with labels")
  | _ => OK s
  end.

(* [optim_loop_unroll_estimates] is the external oracle that assigns the
  number of unfolds for each loop (declared in [Compopts.v])             *)

Definition unroll_function (ge: genv) (f: function) : res function :=
  do body' <- unroll_stmt true (optim_loop_unroll_estimates f.(fn_body))
                          f.(fn_body) xH;
  OK (mkfunction
        f.(fn_sig)
        f.(fn_params)
        f.(fn_vars)
        f.(fn_stackspace)
        body').

Definition unroll_fundef (ge: genv) (f: fundef) : res fundef :=
  transf_partial_fundef (unroll_function ge) f.

(** Conversion of programs. *)

Definition unroll_program (p: program) : res program :=
  let ge := Genv.globalenv p in
  transform_partial_program (unroll_fundef ge) p.