(* Do not edit this file, it was generated automatically *)
Require Import VST.floyd.proofauto.
Require Import VST.floyd.library.
Require Import VST.progs64.object.

#[export] Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Local Open Scope Z.
Local Open Scope logic.

Definition object_invariant := list Z -> val -> mpred.

Definition tobject := tptr (Tstruct _object noattr).

Definition reset_spec (instance: object_invariant) :=
  WITH self: val, history: list Z
  PRE [ tobject]
          PROP ()
          PARAMS (self)
          SEP (instance history self)
  POST [ tvoid ]
          PROP() RETURN () SEP(instance nil self).

Definition twiddle_spec (instance: object_invariant) :=
  WITH self: val, i: Z, history: list Z
  PRE [ tobject, tint]
          PROP (0 < i <= Int.max_signed / 4;
                0 <= fold_right Z.add 0 history <= Int.max_signed / 4)
          PARAMS (self; Vint (Int.repr i))
          SEP (instance history self)
  POST [ tint ]
      EX v: Z,
          PROP(2* fold_right Z.add 0 history < v <= 2* fold_right Z.add 0 (i::history))
          RETURN (Vint (Int.repr v))
          SEP(instance (i::history) self).

Definition object_methods (instance: object_invariant) (mtable: val) : mpred :=
  EX sh: share, EX reset: val, EX twiddle: val,
  !! readable_share sh &&
  func_ptr' (reset_spec instance) reset *
  func_ptr' (twiddle_spec instance) twiddle *
  data_at sh (Tstruct _methods noattr) (reset,twiddle) mtable.

Lemma object_methods_local_facts: forall instance p,
  object_methods instance p |-- !! isptr p.
Proof.
intros.
unfold object_methods.
Intros sh reset twiddle.
entailer!.
Qed.
#[export] Hint Resolve object_methods_local_facts : saturate_local.

Definition object_mpred (history: list Z) (self: val) : mpred :=
  EX instance: object_invariant, EX mtable: val,
       (object_methods instance mtable *
     field_at Ews (Tstruct _object noattr) [StructField _mtable] mtable self*
     instance history self).

Definition foo_invariant : object_invariant :=
  (fun (history: list Z) p =>
    withspacer Ews (sizeof size_t + sizeof tint) (2 * sizeof size_t) (field_at Ews (Tstruct _foo_object noattr)
            [StructField _data] (Vint (Int.repr (2*fold_right Z.add 0 history)))) p
      *  malloc_token Ews (Tstruct _foo_object noattr) p).

Definition foo_reset_spec :=
 DECLARE _foo_reset (reset_spec foo_invariant).

Definition foo_twiddle_spec :=
 DECLARE _foo_twiddle  (twiddle_spec foo_invariant).

Definition make_foo_spec :=
 DECLARE _make_foo
 WITH gv: globals
 PRE [ ]
    PROP () PARAMS() GLOBALS (gv)
    SEP (mem_mgr gv; object_methods foo_invariant (gv _foo_methods))
 POST [ tobject ]
    EX p: val, PROP () RETURN (p)
     SEP (mem_mgr gv; object_mpred nil p; object_methods foo_invariant (gv _foo_methods)).

Definition main_spec :=
 DECLARE _main
  WITH gv: globals
  PRE  [] main_pre prog tt gv
  POST [ tint ]
     EX i:Z, PROP(0<=i<=6) RETURN (Vint (Int.repr i)) SEP(TT).

Definition Gprog : funspecs :=   ltac:(with_library prog [
    foo_reset_spec; foo_twiddle_spec; make_foo_spec; main_spec]).

Lemma object_mpred_i:
  forall (history: list Z) (self: val) (instance: object_invariant) (mtable: val),
    object_methods instance mtable *
     field_at Ews (Tstruct _object noattr) [StructField _mtable] mtable self *
     instance history self
    |-- object_mpred history self.
Proof.
intros. unfold object_mpred. Exists instance mtable; auto.
Qed.

Lemma body_foo_reset: semax_body Vprog Gprog f_foo_reset foo_reset_spec.
Proof.
unfold foo_reset_spec, foo_invariant, reset_spec.
start_function.
unfold withspacer; simpl; Intros.
forward.  (* self->data=0; *)
entailer!!.
all: unfold withspacer; simpl; entailer!!.  (* needed if Archi.ptr64=true *)
Qed.

Lemma body_foo_twiddle: semax_body Vprog Gprog f_foo_twiddle foo_twiddle_spec.
Proof.
unfold foo_twiddle_spec, foo_invariant, twiddle_spec.
start_function.
unfold withspacer; simpl.
Intros.
forward.  (* d = self->data; *)
forward.  (* self -> data = d+2*i; *)
 set (j:= Int.max_signed / 4) in *; compute in j; subst j.
 forget (fold_right Z.add 0 history) as h.
 entailer!!.
forward.  (* return d+i; *)
simpl.
 set (j:= Int.max_signed / 4) in *; compute in j; subst j.
 forget (fold_right Z.add 0 history) as h.
 entailer!!.
Exists (2 * fold_right Z.add 0 history + i).
simpl;
entailer!!.
rewrite Z.mul_add_distr_l, Z.add_comm.
unfold withspacer; simpl.
entailer!!.
Qed.

Lemma split_object_methods:
  forall instance m,
    object_methods instance m |-- object_methods instance m * object_methods instance m.
Proof.
intros.
unfold object_methods.
Intros sh reset twiddle.

Exists (fst (slice.cleave sh)) reset twiddle.
Exists (snd (slice.cleave sh)) reset twiddle.
rewrite (split_func_ptr' (reset_spec instance) reset) at 1.
rewrite (split_func_ptr' (twiddle_spec instance) twiddle) at 1.
entailer!!.
split.
apply slice.cleave_readable1; auto.
apply slice.cleave_readable2; auto.
rewrite (data_at_share_join (fst (slice.cleave sh)) (snd (slice.cleave sh)) sh).
auto.
apply slice.cleave_join.
Qed.

Lemma body_make_foo: semax_body Vprog Gprog f_make_foo make_foo_spec.
Proof.
unfold make_foo_spec.
start_function.
forward_call (Tstruct _foo_object noattr, gv).
Intros p.
forward_if
  (PROP ( )
   LOCAL (temp _p p; gvars gv)
   SEP (mem_mgr gv;
          malloc_token Ews (Tstruct _foo_object noattr) p;
          data_at_ Ews (Tstruct _foo_object noattr) p;
          object_methods foo_invariant (gv _foo_methods))).
*
change (EqDec_val p nullval) with (eq_dec p nullval).
if_tac; entailer!!.
*
forward_call 1.
contradiction.
*
rewrite if_false by auto.
Intros.
forward.  (*  /*skip*/;  *)
entailer!!.
*
unfold data_at_, field_at_, default_val; simpl.
forward. (* p->mtable = &foo_methods; *)
forward. (* p->data = 0; *)
forward. (* return (struct object * ) p; *)
Exists p.
unfold object_mpred.
Exists foo_invariant (gv _foo_methods).
sep_apply (split_object_methods foo_invariant (gv _foo_methods)).
unfold foo_invariant at 4.
entailer!!.
simpl.
unfold_data_at (field_at _ _ nil _ p).
cancel.
unfold withspacer; simpl.
rewrite !field_at_data_at.
simpl.
apply derives_refl'.
rewrite <- ?sepcon_assoc. (* needed if Archi.ptr64=true *)
rewrite !field_compatible_field_address; auto with field_compatible.
clear - H.
(* TODO: simplify the following proof. *)
destruct p; try contradiction.
destruct H as [AL SZ].
repeat split; auto.
simpl in *.  unfold sizeof in *; simpl in *; lia.
eapply align_compatible_rec_Tstruct; [reflexivity.. |].
simpl co_members; intros.
simpl in H.
if_tac in H; [| inv H].
inv H. inv H0.
eapply align_compatible_rec_by_value.
reflexivity.
rewrite Z.add_0_r.
simpl.
unfold natural_alignment in AL.
eapply Z.divide_trans; [ | apply AL].
apply prove_Zdivide.
reflexivity.
left; auto.
Qed.

Lemma make_object_methods:
  forall sh instance reset twiddle mtable,
  readable_share sh ->
  func_ptr' (reset_spec instance) reset *
  func_ptr' (twiddle_spec instance) twiddle *
  data_at sh (Tstruct _methods noattr) (reset, twiddle) mtable
  |-- object_methods instance mtable.
Proof.
  intros.
  unfold object_methods.
  Exists sh reset twiddle.
  entailer!!.
Qed.

Ltac method_call witness hist' result :=
repeat apply seq_assoc1;
match goal with
   |- semax _ (PROPx _ (LOCALx ?Q (SEPx ?R)))
            (Ssequence (Sset ?mt (Efield (Ederef (Etempvar ?x _)  _) _ _))
                 _) _  =>
    match Q with context [temp ?x ?x'] =>
     match R with context [object_mpred _ x'] =>
          let instance := fresh "instance" in let mtable := fresh "mtable" in
          unfold object_mpred; Intros instance mtable;
          forward;
          unfold object_methods at 1;
          let sh := fresh "sh" in let r := fresh "r" in let t := fresh "t" in
          Intros sh r t;
          forward;
          forward_call witness;
          [ .. | try Intros result;
                  sep_apply (make_object_methods sh instance r t mtable); [ auto .. | ];
                  sep_apply (object_mpred_i hist' x' instance mtable);
                  deadvars; try clear dependent sh; try clear r; try clear t
           ]
    end end
end.

Lemma body_main:  semax_body Vprog Gprog f_main main_spec.
Proof.
start_function.
sep_apply (create_mem_mgr gv).
(* assert_gvar _foo_methods. (* TODO: this is needed for a field_compatible later on *) *)
fold noattr cc_default.
(* 0. This part should be handled automatically by start_function *)
gather_SEP (mapsto _ _ _ _) (data_at _ _ _ _);
replace_SEP 0 (data_at Ews (Tstruct _methods noattr)
   (gv _foo_reset, gv _foo_twiddle) (gv _foo_methods)). {
  entailer!.
  unfold_data_at (data_at _ (Tstruct _methods _) _ (gv _foo_methods)).
  rewrite <- mapsto_field_at with (gfs := [StructField _twiddle]) (v:= (gv _foo_twiddle))
  by  auto with field_compatible.
  rewrite field_at_data_at.  rewrite !field_compatible_field_address by auto with field_compatible.
  rewrite !isptr_offset_val_zero by auto.
  cancel.
}

(* 1. Prove that [mtable] is a proper method-table for foo-objects *)

make_func_ptr _foo_twiddle.
make_func_ptr _foo_reset.
sep_apply (make_object_methods Ews foo_invariant(gv _foo_reset) (gv _foo_twiddle) (gv _foo_methods)); auto.

(* 2. Build an instance of class [foo], called [p] *)
forward_call (* p = make_foo(); *)
        gv.
Intros p.
assert_PROP (p<>Vundef) by entailer!.
(* Illustration of an alternate method to prove the method calls.
   Method 1:  comment out lines AA and BB and the entire range CC-DD.
   Method 2:  comment out lines AA-BB, inclusive.
*)

(* AA *) try (tryif
  (method_call (p, @nil Z) (@nil Z) whatever;
   method_call (p, 3, @nil Z) [3%Z] i;
     [simpl; computable | ])
(* BB *)  then fail else fail 99)
  .

(* CC *)
(* 4. first method-call *)
unfold object_mpred.
Intros instance mtable0.
forward. (*  mtable = p->mtable; *)
unfold object_methods at 1.
Intros sh r0 t0.
forward. (* p_reset = mtable->reset; *)
forward_call (* p_reset(p); *)
      (p, @nil Z).
(* Finish the method-call by regathering the object p back together *)
sep_apply (make_object_methods sh instance r0 t0 mtable0); auto.
sep_apply (object_mpred_i [] p instance mtable0).
deadvars!. clear.

(* 5. second method-call *)
unfold object_mpred.
Intros instance mtable0.
forward.  (* mtable = p->mtable; *)
unfold object_methods at 1.
Intros sh r0 t0.
forward.   (* p_twiddle = mtable->twiddle; *)
assert_PROP (p<>Vundef) by entailer!.
forward_call (* i = p_twiddle(p,3); *)
      (p, 3, @nil Z).
  simpl. computable.
Intros i.
simpl in H0.
sep_apply (make_object_methods sh instance r0 t0 mtable0); auto.
sep_apply (object_mpred_i [3] p instance mtable0).
deadvars!.
simpl in H1.

(* DD *)

(* 6. return *)
forward.  (* return i; *)
Exists i; entailer!!.
Qed.


Require Import Axioms.

Require Import effect_semantics.

Require Import pos.
Require Import compcert_linking.

Require Import ssreflect ssrbool ssrnat ssrfun seq fintype.
Set Implicit Arguments.

Require Import AST. (*for ident*)
Require Import Values.
Require Import Globalenvs.

Section linkingLemmas.

Import Linker.
Import Modsem.

Variable N : pos.
Variable cores : 'I_N -> Modsem.t.
Variable fun_tbl : ident -> option 'I_N.
Variable my_ge : ge_ty.

Let linker := effsem N cores fun_tbl.

Lemma upd_upd (st : Linker.t N cores) c c' :
  updCore (updCore st c) c' = updCore st c'.
Proof.
rewrite /updCore /updStack /=; f_equal.
move: (updCore_obligation_1 _ _); simpl.
rewrite collection.COL.theory.unbumpbump=> w2.
by have ->: w2 = updCore_obligation_1 _ _ by apply: proof_irr.
Qed.

Lemma step_STEP {U st1 m1 c1' m1'} :
  let: c1 := peekCore st1 in
  effect_semantics.effstep
    (sem (cores (Core.i c1)))
    (ge (cores (Core.i c1))) U (Core.c c1) m1 c1' m1' ->
  effect_semantics.effstep linker my_ge
  U st1 m1 (updCore st1 (Core.upd c1 c1')) m1'.
Proof.
move=> STEP; move: (@effstep_corestep _ _ _ _ _ _ _ _ _ STEP)=> STEP'; split.
by left; exists c1'; split.
by move=> ?; exists c1'; split.
by move=> H b ofs; case: H; rewrite/LinkerSem.corestep0; exists c1'; split.
Qed.

Lemma stepN_STEPN {U st1 m1 c1' m1' n} :
  let: c1 := peekCore st1 in
  effect_semantics.effstepN
    (sem (cores (Core.i c1)))
    (ge (cores (Core.i c1))) n U (Core.c c1) m1 c1' m1' ->
  effect_semantics.effstepN linker my_ge
    n U st1 m1 (updCore st1 (Core.upd c1 c1')) m1'.
Proof.
move: st1 c1' m1 U; elim: n.
move=> st1 c1' m1 U /= [][] <- <- <-; split=> //; f_equal.
{ have H: Core.upd (peekCore st1) (Core.c (peekCore st1))
        = peekCore st1.
  { by clear; rewrite /Core.upd; case: (peekCore st1). }
  by rewrite H LinkerSem.updPeekCore.
}
move=> n IH st1 c1' m1 U /= => [][]c1'' []m1'' []U1 []U2 []B []C D.
exists (updCore st1 (Core.upd (peekCore st1) c1'')), m1'',U1,U2; split.
by apply: (step_STEP B).
have H: Core.i (peekCore st1)
      = Core.i (peekCore (updCore st1 (Core.upd (peekCore st1) c1''))).
{ admit. }
admit.
(*move: (IH (updCore st1 (Core.upd (peekCore st1) c1'')) c1' m1'' U2).
by rewrite upd_upd=> H; split=> //; move: H; apply; apply: C.*)
Qed.

Lemma stepPLUS_STEPPLUS {U st1 m1 c1' m1'} :
  let: c1 := peekCore st1 in
  effect_semantics.effstep_plus
    (sem (cores (Core.i c1)))
    (ge (cores (Core.i c1))) U (Core.c c1) m1 c1' m1' ->
  effect_semantics.effstep_plus linker my_ge
  U st1 m1 (updCore st1 (Core.upd c1 c1')) m1'.
Proof. by rewrite/effstep_plus=> [][]n; move/stepN_STEPN=> B; exists n. Qed.

Lemma stepSTAR_STEPSTAR {U st1 m1 c1' m1'} :
  let: c1 := peekCore st1 in
  effect_semantics.effstep_star
    (sem (cores (Core.i c1)))
    (ge (cores (Core.i c1))) U (Core.c c1) m1 c1' m1' ->
  effect_semantics.effstep_star linker my_ge
  U st1 m1 (updCore st1 (Core.upd c1 c1')) m1'.
Proof. by rewrite/effstep_star=> [][]n; move/stepN_STEPN=> B; exists n. Qed.

End linkingLemmas.


From aneris.examples.consensus Require Import paxos_prelude.
Import RecordSetNotations.

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

  Lemma recv_promises_spec p h (n : nat) (b : Ballot) :
    p ∈ Proposers →
    {{{ inv paxosN paxos_inv ∗ p ⤇ proposer_si ∗
        h ↪[ip_of_address p] (mkSocket (Some p) true) }}}
      recv_promises int_serializer #(LitSocket h) #n #b
      @[ip_of_address p]
    {{{ vp (promises : gset (option (Ballot * Value))) (senders : gset Acceptor),
        RET vp;
        h ↪[ip_of_address p] (mkSocket (Some p) true) ∗
        ⌜is_set promises vp⌝ ∗
        ⌜size senders = n⌝ ∗
        (∀ a, ⌜a ∈ senders⌝ -∗
               ∃ mv, ⌜mv ∈ promises⌝ ∗ msgs_elem_of (msg1b a b mv)) ∗
        (* TODO: better spec/implementation? - this is a bit silly *)
        (∀ mv, ⌜mv ∈ promises⌝ →
               ∃ a, ⌜a ∈ senders⌝ ∗ msgs_elem_of (msg1b a b mv)) }}}.
  Proof.
    iIntros (? Φ) "(#Hinv & #Hp_si & Hh) HΦ". rewrite /recv_promises.
    wp_pures.
    wp_apply (wp_set_empty (option (Ballot * Value))); [done|].
    iIntros (vp Hvp). wp_alloc lp as "Hlp".
    wp_pures.
    wp_apply (wp_set_empty Acceptor); [done|].
    iIntros (vs Hvs). wp_alloc ls as "Hls".
    do 4 wp_pure _.
    (* loop invariant *)
    iAssert (
        ∃ (promises : gset (option (Ballot * Value))) (senders : gset Acceptor) vp vs,
          lp ↦[ip_of_address p] vp ∗ ls ↦[ip_of_address p] vs ∗
             ⌜is_set promises vp⌝ ∗ ⌜is_set senders vs⌝ ∗
             (∀ a, ⌜a ∈ senders⌝ -∗
                    ∃ mv, ⌜mv ∈ promises⌝ ∗ msgs_elem_of (msg1b a b mv)) ∗
             (∀ mv, ⌜mv ∈ promises⌝ →
               ∃ a, ⌜a ∈ senders⌝ ∗ msgs_elem_of (msg1b a b mv)))%I
      with "[Hlp Hls]" as "Hloop".
    { iExists ∅, ∅, _, _. iFrame "∗%". iSplit; iIntros (? []%elem_of_empty). }
    clear Hvp Hvs vs vp. wp_pure _.
    iLöb as "IH".
    iDestruct "Hloop" as (promises senders vp vs) "(Hlp & Hls & %Hvp & %Hvs & Hincl & Hacc)".
    wp_pures.
    wp_load.
    wp_apply wp_set_cardinal; [done|]; iIntros "_".
    wp_op. case_bool_decide as Heq; wp_pures.
    { wp_load. iApply "HΦ". iFrame. apply Nat2Z.inj in Heq. by iFrame "%". }
    wp_bind (ReceiveFrom _).
    iInv (paxosN) as (δ) "(>Hfrag & >Hmauth & >Hbal & >Hval & Hmcoh & >HbI)"
                         "Hclose".
    iDestruct "Hmcoh" as ">Hmcoh".
    iDestruct "Hmcoh" as (F Ts) "(Has & Hps & -> & %HM)".
    iDestruct (big_sepS_delete _ _ p with "Hps") as "[[% Hp] Hps]"; [done|].
    wp_apply (aneris_wp_pers_receivefrom with "[$Hh $Hp $Hp_si]"); [done..|].
    iIntros (m) "(Hh & Hp & Hm)".
    iMod ("Hclose" with "[-Hh Hm Hlp Hls Hincl Hacc HΦ]") as "_".
    { iModIntro. iExists _. iFrame.
      iExists _, _. iFrame (HM) "Has".
      iSplit; [|done].
      iDestruct (big_sepS_insert _ _ p with "[Hp $Hps]")
        as "Hps"; [set_solver|eauto|].
      rewrite -union_difference_singleton_L //. }
    rewrite /proposer_si.
    iDestruct "Hm" as (?? mval Hser) "(-> & Hm)".
    iModIntro. wp_apply wp_unSOME; [done|]; iIntros "_".
    wp_pures.
    wp_apply (s_deser_spec proposer_serialization); [done|]; iIntros "_".
    wp_pures.
    case_bool_decide; wp_if; last first.
    { wp_seq. wp_apply ("IH" with "Hh HΦ [Hlp Hls Hincl Hacc]").
      iExists _, _, _, _. auto with iFrame. }
    simplify_eq.
    wp_load.
    wp_apply (wp_set_add $! Hvs). iIntros (vs' ?).
    wp_store. wp_load.
    wp_apply (wp_set_add $! Hvp).
    iIntros (vp' Hvp'). wp_store.
    wp_apply ("IH" with "Hh HΦ").
    iExists (_ ∪ _), (_ ∪ _), _, _. iFrame "Hlp Hls".
    do 2 (iSplit; [done|]).
    iSplit; last first.
    { iIntros (mv). rewrite elem_of_union elem_of_singleton. iIntros ([-> | Hin]).
      - iExists _. iFrame. iPureIntro; set_solver.
      - iDestruct ("Hacc" $! mv Hin) as (a') "[% ?]".
        iExists a'. iFrame. iPureIntro; set_solver. }
    iIntros (a').
    rewrite elem_of_union elem_of_singleton.
    iIntros ([-> | ?]); last first.
    { iDestruct ("Hincl" $! a' with "[//]") as (mv') "[% H]".
      iExists mv'. iFrame. iPureIntro; set_solver. }
    iExists _. iFrame. iPureIntro; set_solver.
  Qed.

  Lemma find_max_promise_spec (lp : val)
        (promises : gset (option (Ballot * Value))) ip :
    is_set promises lp →
    {{{ True }}}
      find_max_promise lp @[ip]
    {{{ v, RET v;
        (⌜v = NONEV⌝ ∗ ⌜set_Forall (λ p, p = None) promises⌝) ∨
        (∃ (b : Ballot) (val : Value),
            ⌜Some (b, val) ∈ promises⌝ ∗
            ⌜v = SOMEV ($b, $val)⌝ ∗
            ⌜set_Forall (λ p, if p is Some (b', v')
                              then b ≥ b' else True) promises⌝) }}}.
  Proof.
    iIntros (? Φ) "_ HΦ". rewrite /find_max_promise.
    wp_pures.
    wp_apply (wp_set_foldl (A := option (Ballot * Value))
                (λ X v, (⌜v = NONEV⌝ ∗ ⌜set_Forall (λ p, p = None) X⌝) ∨
                        (∃ (b : Ballot) (val : Value),
                            ⌜Some (b, val) ∈ X⌝ ∗
                            ⌜v = SOMEV ($b, $val)⌝ ∗
                            ⌜set_Forall (λ p, if p is Some (b', v')
                                              then b ≥ b' else True) X⌝))%I
                (λ _, True%I) (λ _, True%I)).
    { iIntros ([[b v]|] acc X) "!#";
        iIntros (Ψ) "[[[-> %Hall] | (% & % & %Hin & -> & %Hall)] _] HΨ".
      - wp_pures. iApply "HΨ". iSplit; [|done]. iRight.
        iExists b, v. iPureIntro.
        split; [by apply elem_of_union_r, elem_of_singleton|].
        split; [done|].
        apply set_Forall_union.
        { apply (set_Forall_impl _ _ _ Hall). by intros ? ->. }
        apply set_Forall_singleton. lia.
      - wp_pures. case_bool_decide; wp_if.
        + iApply "HΨ". iPureIntro.
          split; [|done]. right.
          do 2 eexists.
          split; [apply elem_of_union_l, Hin|].
          split; [done|].
          apply set_Forall_union; [done|].
          apply set_Forall_singleton. lia.
        + iApply "HΨ". iPureIntro.
          split; [|done]. right.
          do 2 eexists.
          split; [by apply elem_of_union_r, elem_of_singleton|].
          split; [done|].
          apply set_Forall_union; [|apply set_Forall_singleton; lia].
          apply (set_Forall_impl _ _ _ Hall).
          intros [[]|]; [|done]. lia.
      - wp_pures. iApply "HΨ". iPureIntro.
        split; [|done]. left.
        split; [done|].
        apply set_Forall_union; [done|].
        by apply set_Forall_singleton.
      - wp_pures. iApply "HΨ". iPureIntro.
        split; [|done]. right.
        do 2 eexists.
        split; [by apply elem_of_union_l, Hin|].
        split; [done|].
        apply set_Forall_union; [done|].
        by apply set_Forall_singleton. }
    { iFrame "%". rewrite big_opS_unit; eauto. }
    iIntros (?) "[H _]". by iApply "HΦ".
  Qed.

  (* Definition bal (n : nat) (p : nat) := n * ProposersN + p. *)

  Lemma proposer_spec av h b (p : Proposer) (z : Value) :
    is_set Acceptors av →
    inv paxosN paxos_inv -∗
    ([∗ set] a ∈ Acceptors, a ⤇ acceptor_si) -∗
    (`p) ⤇ proposer_si -∗
    h ↪[ip_of_address (`p)] (mkSocket (Some (`p)) true) -∗
    pending b -∗
    WP proposer int_serializer av #(LitSocket h) #b #`z @[ip_of_address (`p)]
    {{ _, ∃ v, msgs_elem_of (msg2a b v) ∗
               h ↪[ip_of_address (`p)] (mkSocket (Some (`p)) true) }}.
  Proof.
    iIntros (?) "#Hinv #HA_sis #Hp_si Hh Hb".
    rewrite /proposer.
    wp_pures.
    wp_apply (s_ser_spec (acceptor_serialization)).
    { iPureIntro. apply serializable. }
    iIntros (s) "%Hser".
    (* send a phase 1a message to all acceptors, taking a step in the model for
       each message. *)
    wp_apply (wp_pers_sendto_all_take_step
                True%I
                (λ _, msgs_elem_of (msg1a _))
                (λ _, True)%I
                with "[] [$Hh //]"); [done|done|eassumption| |].
    { iIntros "!#" (a ?) "(_ & _ & %Ha)".
      set (m := {| m_sender := `p; m_destination := a; m_body := s |}).
      iInv (paxosN) as (δ) ">(Hfrag & Hmauth & Hbal & Hval & Hmcoh & HbI)" "Hclose".
      iMod (msgs_update (msg1a b) with "Hmauth") as "[Hmauth #Hm]".
      iModIntro.
      iDestruct "Hmcoh" as (F Ts) "(Has & Hps & -> & %HM)".
      iDestruct (big_sepS_delete _ _ (`p) with "Hps") as "[[% Hp] Hps]"; [auto|].
      iDestruct (big_sepS_elem_of _ _ a with "HA_sis") as "#Ha_si"; [done|].
      iExists _, _, _, _, δ, (δ <| msgs ::= λ ms, ms ∪ {[msg1a _]} |>).
      iFrame "#∗".
      iSplit.
      { iPureIntro. right. constructor. }
      iSplitR.
      { iExists p. iSplit; [done|]. iLeft. iExists _. iFrame "% #". }
      iIntros "(Hp & Hfrag)".
      iMod ("Hclose" with "[-]"); [|done].
      iModIntro. iExists _. iFrame.
      iSplitR "HbI"; last first.
      { iApply (ballot_inv_send_not2a with "HbI"). naive_solver. }
      iExists (<[(`p) := {[m]} ∪ F (`p)]>F), _; simpl.
      rewrite send_msg_notin; [|auto].
      iFrame.
      iDestruct (send_msg_combine with "Hp Hps") as "$"; [auto|].
      iSplit; [done|].
      iPureIntro.
      apply messages_agree_add; [| |done].
      { apply elem_of_union; auto. }
      simpl. destruct_is_ser Hser.
      by exists p, (a ↾ Ha). }
    iIntros "(_ & Hh & _ & Helem)". wp_pures.
    wp_apply (wp_set_cardinal with "[//]"); iIntros "_".
    wp_pures.
    replace #(_ + 1) with #(size Acceptors / 2 + 1)%nat; last first.
    { do 2 f_equal. lia. }
    wp_apply (recv_promises_spec with "[$Hinv $Hp_si $Hh]"); [auto|].
    iIntros (vp promises senders) "(Hh & %Hvp & %Hsize & #Hmsgs & #Hacc)".
    wp_pures.
    (* find the maximum phase 1b message from the majority, if any *)
    wp_apply (find_max_promise_spec _ promises with "[//]"); [done|].
    iIntros (?) "[(-> & %Hpromises) | (%b0 & %z' & %Hin &-> & %Hall)]".
    - (* no value was proposed by the majority *)
      wp_pures.
      iMod (pend_update_shot b z with "Hb") as "#Hshot".
      wp_apply (s_ser_spec (acceptor_serialization)).
      { iPureIntro. apply serializable. }
      iIntros (s' Hser').
      (* send phase 2a decision to all acceptors *)
      wp_apply (wp_pers_sendto_all_take_step
                  True%I (λ _, msgs_elem_of (msg2a b z)) (λ _, True)%I
                  with "[Hmsgs] [$Hh]"); [done|done|eassumption| |].
      { iIntros "!#" (a _) "(_ & _ & %Ha)".
        iInv (paxosN) as (δ) ">(Hfrag & Hmauth & Hbal & Hval & Hmcoh & HbI)" "Hclose".
        iAssert (⌜∀ a, a ∈ senders →
                       ∃ mv, mv ∈ promises ∧ msg1b a b mv ∈ δ.(msgs)⌝)%I
          as "%Hsenders".
        { iIntros (a' Ha').
          iDestruct ("Hmsgs" $! a' Ha') as (mv) "[% Hm]".
          iDestruct (msgs_elem_of_in with "Hmauth Hm") as %?. eauto. }
        iMod (msgs_update (msg2a b z) with "Hmauth") as "[Hmauth #Hm]".
        iModIntro.
        iDestruct "Hmcoh" as (F Ts) "(Has & Hps & -> & %HM)".
        iDestruct (big_sepS_delete _ _ (`p) with "Hps") as "[[% Hp] Hps]"; [auto|].
        iDestruct (big_sepS_elem_of _ _ a with "HA_sis") as "#Ha_si"; [done|].
        set (m := {| m_sender := `p; m_destination := a; m_body := s' |}).
        (* this viewshift is used for all acceptors; here we destruct on whether
           we're considering the first (the 2a message has not been recorded in
           the model) or not. *)
        destruct (decide (msg2a b z ∈ δ.(msgs))).
        + iExists _, _, _, _, δ, δ.
          iFrame "Hfrag Hp Ha_si".
          iSplit; [auto|].
          iSplitR.
          { iExists p. iSplit; [done|]. iRight. iExists _, z. by iFrame "Hm". }
          iIntros "(Hp & Hfrag)".
          iMod ("Hclose" with "[-]") as "_"; [|auto].
          iModIntro. iExists _. simpl.
          assert ((msgs δ ∪ {[msg2a b z]}) = msgs δ) as -> by set_solver.
          iFrame.
          iExists (<[(`p) := {[m]} ∪ F (`p)]>F), _; iFrame.
          rewrite send_msg_notin; [|auto]. iFrame.
          iDestruct (send_msg_combine with "Hp Hps") as "$"; [auto|].
          iSplit; [done|]. iPureIntro.
          eapply messages_agree_duplicate; [done| |done].
          destruct_is_ser Hser'. by exists p, (a ↾ Ha).
        + iExists _, _, _, _, δ, (δ <| msgs ::= λ ms, ms ∪ {[msg2a _ z]} |>).
          iAssert (⌜¬ (∃ z', msg2a b z' ∈ msgs δ)⌝)%I as "%".
          { iIntros ([? Hz']).
            iSpecialize ("HbI" $! _ _ Hz').
            by iDestruct (shot_agree with "Hshot HbI") as %->. }
          iDestruct (frag_st_rtc with "Hfrag") as %Hrtc.
          iFrame "Hfrag Hp Ha_si".
          iSplit.
          { iPureIntro. right.
            eapply (phase2a _ _ _ senders).
            * done.
            * apply majority_show_quorum. rewrite Hsize. lia.
            * split.
              - intros a' Ha'.
                destruct (Hsenders a' Ha') as (mv &?&?).
                exists (msg1b a' b mv).
                rewrite !elem_of_PropSet. split; eauto.
              - left.
                rewrite set_equiv=> m'.
                rewrite !elem_of_PropSet.
                split; [|done].
                intros ([Hin1 (? &?&?& Ha')] & a' & [? ?]); simplify_eq.
                destruct (Hsenders a' Ha') as (? & Hprom & Hin2).
                (* N.B.: here we are explicitlty using a pure property of the
                   model to obtain the contradiction! *)
                specialize (msg1b_agree _ _ _ _ _ Hrtc Hin1 Hin2).
                rewrite (Hpromises _ Hprom).
                done. }
          iSplit.
          { iExists p. iSplit; [done|]. iRight. iExists _, z. by iFrame "Hm". }
          iIntros "[Hp Hfrag]".
          iMod ("Hclose" with "[-]") as "_"; [|auto].
          iModIntro. iExists _. iFrame "Hfrag Hmauth Hbal Hval".
          iSplitR "HbI"; last first.
          { iIntros (??).
            rewrite elem_of_union elem_of_singleton.
            iIntros ([?|?]); by [iApply "HbI"|simplify_eq]. }
          iExists (<[(`p) := {[m]} ∪ F (`p)]>F), _. simpl.
          rewrite send_msg_notin; [|auto]. iFrame.
          iDestruct (send_msg_combine with "Hp Hps") as "$"; [auto|].
          iSplit; [done|].
          iPureIntro.
          apply messages_agree_add; [| |done].
          { apply elem_of_union; auto. }
          destruct_is_ser Hser'. by exists p, (a ↾ Ha). }
      iIntros "(_ & Hh & _ & H2a)".
      iExists _. iFrame.
      destruct Acceptors_choose as [a ?].
      by iApply (big_sepS_elem_of _ _ a with "H2a").
    - (* a value has already been proposed *)
      wp_pures.
      wp_apply (s_ser_spec (acceptor_serialization)).
      { iPureIntro. apply serializable. }
      iIntros (s' Hser').
      iMod (pend_update_shot b z' with "Hb") as "#Hshot".
      wp_apply (wp_pers_sendto_all_take_step
                  True%I (λ _, msgs_elem_of (msg2a b z')) (λ _, True)%I
                  with "[Hmsgs] [$Hh]"); [done|done|eassumption| |].
      { iIntros "!#" (a _) "(_ & _ & %Ha)".
        iInv (paxosN) as (δ) ">(Hfrag & Hmauth & Hbal & Hval & Hmcoh & HbI)"
                                 "Hclose".
        iAssert (⌜∀ a, a ∈ senders →
                       ∃ mv, mv ∈ promises ∧ msg1b a b mv ∈ δ.(msgs)⌝)%I as "%Hsenders".
        { iIntros (a' Ha').
          iDestruct ("Hmsgs" $! a' Ha') as (mv) "[% Hm']".
          iDestruct (msgs_elem_of_in with "Hmauth Hm'") as %?. eauto. }
        iAssert (⌜∀ mv, mv ∈ promises →
                        ∃ a, a ∈ senders ∧ msg1b a b mv ∈ δ.(msgs)⌝)%I as "%Hpromises".
        { iIntros (mv Hmv).
          iDestruct ("Hacc" $! mv Hmv) as (a') "[% Hm']".
          iDestruct (msgs_elem_of_in with "Hmauth Hm'") as %?. eauto. }
        iMod (msgs_update (msg2a b z') with "Hmauth") as "[Hmauth #Hm]".
        iModIntro.
        iDestruct "Hmcoh" as (F Ts) "(Has & Hps & -> & %HM)".
        iDestruct (big_sepS_delete _ _ (`p) with "Hps") as "[[% Hp] Hps]"; [auto|].
        iDestruct (big_sepS_elem_of _ _ a with "HA_sis") as "#Ha_si"; [done|].
        set (m := {| m_sender := `p; m_destination := a; m_body := s' |}).
        destruct (decide ((msg2a b z') ∈ δ.(msgs))).
        + iExists _, _, _, _, δ, δ.
          iFrame "Hfrag Hp Ha_si".
          iSplit; [auto|].
          iSplit.
          { iExists p. iSplit; [done|]. iRight. iExists _, _. by iFrame "Hm". }
          iIntros "[Hp Hfrag]".
          iMod ("Hclose" with "[-]") as "_"; [|auto].
          iModIntro. iExists _. simpl.
          assert ((msgs δ ∪ {[msg2a b z']}) = msgs δ) as -> by set_solver.
          iFrame. iExists (<[(`p) := {[m]} ∪ F (`p)]>F), _.
          rewrite send_msg_notin; [|auto]. iFrame.
          iDestruct (send_msg_combine with "Hp Hps") as "$"; [auto|].
          iSplit; [done|]. iPureIntro.
          eapply messages_agree_duplicate; [done| |done].
          destruct_is_ser Hser'. by exists p, (a ↾ Ha).
        + iExists _, _, _, _, δ, (δ <| msgs ::= λ ms, ms ∪ {[msg2a b z']} |>).
          iAssert (⌜¬ (∃ z', msg2a b z' ∈ msgs δ)⌝)%I as "%".
          { iIntros ([? Hz']).
            iSpecialize ("HbI" $! _ _ Hz').
            by iDestruct (shot_agree with "Hshot HbI") as %->. }
          iDestruct (frag_st_rtc with "Hfrag") as %Hrtc.
          iFrame "Hfrag Hp Ha_si".
          iSplit.
          { iPureIntro. right.
            eapply (phase2a _ z' _ senders).
            * done.
            * apply majority_show_quorum. rewrite Hsize. lia.
            * split.
              - intros a' Ha'.
                destruct (Hsenders a' Ha') as (mv &?&?).
                exists (msg1b a' b mv).
                rewrite !elem_of_PropSet. split; eauto.
              - right.
                destruct (Hpromises _ Hin) as (a' & Ha' & Hm).
                eexists _; exists a', b0.
                repeat split; eauto.
                intros m' ((Hin1 &?&?&?& Hin') & ? & ([]&?)); simplify_eq.
                do 3 eexists. split; [done|].
                destruct (Hsenders _ Hin') as (mv & Hmv & Hin2).
                specialize (Hall _ Hmv).
                (* N.B.: here we are explicitlty using a pure property of the
                   model to finish the proof!  *)
                specialize (msg1b_agree _ _ _ _ _ Hrtc Hin1 Hin2) as ?.
                simplify_eq. done. }
          iSplitR.
          { iExists p. iSplit; [done|]. iRight. iExists _, z'. by iFrame "Hm". }
          iIntros "[Hp Hfrag]".
          iMod ("Hclose" with "[-]") as "_"; [|auto].
          iModIntro. iExists _. iFrame.
          iSplitR "HbI"; last first.
          { iIntros (??).
            rewrite elem_of_union elem_of_singleton.
            iIntros ([?|?]); by [iApply "HbI"|simplify_eq]. }
          iExists (<[(`p) := {[m]} ∪ F (`p)]>F), _; simpl.
          rewrite send_msg_notin; [|auto]. iFrame.
          iDestruct (send_msg_combine with "Hp Hps") as "$"; [auto|].
          iSplit; [done|].
          iPureIntro.
          apply messages_agree_add; [| |done].
          { apply elem_of_union; auto. }
          destruct_is_ser Hser'. by exists p, (a ↾ Ha). }
      iIntros "(_ & Hh & _ & H2a)".
      iExists _. iFrame.
      destruct Acceptors_choose as [a ?].
      by iApply (big_sepS_elem_of _ _ a with "H2a").
  Qed.

  Lemma proposer'_spec av i (p : Proposer) (z : Value) :
    i < size Proposers →
    is_set Acceptors av →
    inv paxosN paxos_inv -∗
    ([∗ set] a ∈ Acceptors, a ⤇ acceptor_si) -∗
    free_ports (ip_of_address (`p)) {[port_of_address (`p)]} -∗
    (`p) ⤇ proposer_si -∗
    pending_class i 0 -∗
    WP proposer' int_serializer av #(`p) #i #(size Proposers) #`z
       @[ip_of_address (`p)] {{ _, True }}.
  Proof.
    iIntros (??) "#Hinv #Has Hport #Hp Hi". rewrite /proposer'.
    wp_pures.
    wp_socket sh as "Hskt".
    wp_pures.
    wp_socketbind.
    wp_alloc l as "Hl".
    do 4 wp_pure _.
    (* loop invariant *)
    iAssert (∃ c, pending_class i c ∗ l ↦[ip_of_address (`p)] #c)%I
      with "[Hi Hl]" as "Hloop".
    { iExists 0. replace (#0%nat) with (#0) by f_equal. iFrame. }
    wp_pure _.
    iLöb as "IH".
    iDestruct "Hloop" as (b) "(Hi & Hl)".
    wp_pures.
    wp_load.
    wp_pures.
    iDestruct (pending_pend_split with "Hi") as "[Hi Hpend]"; [done|].
    replace (#(b * size Proposers + i)) with (#(b * size Proposers + i)%nat)
      by (do 2 f_equal; lia).
    wp_bind (proposer _ _ _ _ _)%E.
    wp_apply aneris_wp_wand_r. iSplitL "Hpend Hskt".
    { by wp_apply (proposer_spec with "Hinv Has Hp Hskt Hpend"). }
    iIntros (?) "(% & #? & Hskt)".
    wp_seq. wp_load. wp_op.
    wp_store.
    iApply ("IH" with "Hskt [-]").
    iExists _. iFrame.
    replace (#(b + 1)%nat) with (#(b + 1)) by (do 2 f_equal; lia).
    done.
  Qed.

End paxos_proposer.


Require Import List.
Require Import ZArith.

Require Import Utils.
Require Import Lattices.
Require Import CLattices.
Require Import Instr.
Require Import Memory.
Require Import AbstractCommon.
Require Import AbstractMachine.
Require Import NIAbstractMachine.
Require Import Concrete.
Require Import ConcreteMachine.
Require Import ConcreteExecutions.
Require Import Semantics.
Require Import Refinement.
Require Import RefinementAQA.
Require Import RefinementQAC.
Require Import RefinementAC.
Require TINI.

Open Scope Z_scope.

Set Implicit Arguments.

Section NI.

Context {T: Type}
        {Latt: JoinSemiLattice T}
        {CLatt: ConcreteLattice T}.

Variable cblock : FaultRoutine.block.
Hypothesis stamp_cblock : Mem.stamp cblock = Kernel.

Variable ctable_impl : list CSysCallImpl.

Let faultHandler := FaultRoutine.faultHandler _ QuasiAbstractMachine.fetch_rule.
Let ctable := build_syscall_table (Z.of_nat (length faultHandler)) ctable_impl.

Context {WFCLatt: WfConcreteLattice cblock ctable T Latt CLatt}.

Variable atable : ASysTable T.
Hypothesis Hatable : parametric_asystable atable.
Hypothesis Hctable_impl_correct : ctable_impl_correct cblock atable ctable_impl faultHandler.
Hypothesis table_syscall_lowstep : forall o, syscall_lowstep o atable.
Hypothesis table_systable_inv : systable_inv atable.

Inductive concrete_i_equiv (o : T) :
  concrete_init_data -> concrete_init_data -> Prop :=
  | ci_equiv : forall ai1 ai2 ci1 ci2
                      (EQ : abstract_i_equiv o ai1 ai2)
                      (MATCH1 : ac_match_initial_data cblock QuasiAbstractMachine.fetch_rule ai1 ci1)
                      (MATCH2 : ac_match_initial_data cblock QuasiAbstractMachine.fetch_rule ai2 ci2),
                 concrete_i_equiv o ci1 ci2.

Instance CMObservation : TINI.Observation (tini_concrete_machine cblock ctable_impl) (Event T) := {
  out e := match e with
             | CEInt (z, t) m => EInt (z, valToLab t m)
           end;
  e_low := fun o e => @TINI.e_low _ _ (AMObservation atable) o e;
  e_low_dec := fun o e => TINI.e_low_dec o e;
  i_equiv := concrete_i_equiv
}.

Lemma ac_low_compatible :
  forall (o : T)
         (e1 : event (abstract_machine atable))
         (e2 : CEvent),
    ref_match_events (@abstract_concrete_ref _ _ _ cblock stamp_cblock
                                             ctable_impl
                                             WFCLatt
                                             atable Hatable Hctable_impl_correct) e1 e2 ->
    (TINI.e_low o (TINI.out e1)
       <-> TINI.e_low o (@TINI.out _ _ CMObservation e2)).
Proof.
  simpl.
  intros o [[x xl]] [[x' xt] m] H; simpl.
  inv H. unfold pcatom_labToVal in ATOMS. simpl in ATOMS.
  destruct ATOMS as [? TAG]. subst x'.
  assert (valToLab xt m = xl) by (eapply labToVal_valToLab_id; eauto).
  subst. reflexivity.
Qed.

Lemma concrete_equiv_abstract_equiv :
  forall o ci1 ci2,
    concrete_i_equiv o ci1 ci2 ->
    exists ai1 ai2,
      abstract_i_equiv o ai1 ai2 /\
      ac_match_initial_data cblock QuasiAbstractMachine.fetch_rule ai1 ci1 /\
      ac_match_initial_data cblock QuasiAbstractMachine.fetch_rule ai2 ci2.
Proof.
  intros o ci1 ci2 EQ.
  inv EQ. eauto.
Qed.

Lemma ac_match_events_equiv :
  forall o e11 e12 e21 e22
         (EQ : @TINI.a_equiv (abstract_machine atable) _ _ o (E e11) (E e12))
         (MATCH1 : ref_match_events (abstract_concrete_ref stamp_cblock Hatable Hctable_impl_correct) e11 e21)
         (MATCH2 : ref_match_events (abstract_concrete_ref stamp_cblock Hatable Hctable_impl_correct) e12 e22),
    @TINI.a_equiv (tini_concrete_machine cblock ctable_impl) _ _ o (E e21) (E e22).
Proof.
  simpl.
  intros o [[x1 xl1]] [[x2 xl2]] [[x1' xt1] m1] [[x2' xt2] m2].
  intros.
  inv EQ; inv MATCH1; inv MATCH2;
  repeat match goal with
           | ATOMS : pcatom_labToVal _ _ _ |- _ =>
             unfold pcatom_labToVal in ATOMS;
             simpl in ATOMS; destruct ATOMS; subst
           | H : TINI.out _ = TINI.out _ |- _ =>
             simpl in H; inv H
           | H : TINI.e_low _ _ |- _ =>
             simpl in H
         end;
  intuition; repeat subst;
  [> once (constructor; solve [simpl; eauto;
                        repeat match goal with
                               | H : labToVal _ _ _ |- _ =>
                                 eapply labToVal_valToLab_id in H; eauto; rewrite H
                             end;
                      eauto]) ..].
Qed.

Lemma ac_tini_preservation_premises :
  tini_preservation_hypothesis
    (abstract_concrete_ref stamp_cblock Hatable Hctable_impl_correct).
Proof.
  intros o. exists o.
  split. { apply ac_low_compatible. }
  split. { apply concrete_equiv_abstract_equiv. }
  apply ac_match_events_equiv.
Qed.

Lemma concrete_noninterference :
  TINI.tini CMObservation.
Proof.
   exact (@refinement_preserves_noninterference
          (abstract_machine atable) (tini_concrete_machine cblock ctable_impl)
          _ _ _
          (abstract_concrete_ref stamp_cblock Hatable Hctable_impl_correct)
          (abstract_noninterference_short table_syscall_lowstep table_systable_inv)
          ac_tini_preservation_premises).
Qed.

End NI.


Require Import Coq.Strings.String.
From Equations Require Import Equations.
Require Import PeanoNat.

Require Export SystemFR.EquivalentContext.
Require Export SystemFR.ErasedList.
Require Export SystemFR.EquivalenceLemmas3.
Require Export SystemFR.EvalListMatch.
Require Export SystemFR.EvalFixDefault.

Opaque reducible_values.

Reserved Notation "'[' Γ ⊨ t1 '⤳*' t2 ']'" (at level 60, Γ at level 60, t1 at level 60).

Inductive delta_beta_reduction: context -> tree -> tree -> Prop :=
| DBVar:
    forall Γ x ty t v,
      wf t 0 ->
      lookup Nat.eq_dec Γ x = Some (T_singleton ty t) ->
      [ Γ ⊨ t ⤳* v ] ->
      [ Γ ⊨ fvar x term_var ⤳* v ]

| DBPair:
    forall Γ t1 t2 v1 v2,
      [ Γ ⊨ t1 ⤳* v1 ] ->
      [ Γ ⊨ t2 ⤳* v2 ] ->
      [ Γ ⊨ pp t1 t2 ⤳* pp v1 v2 ]

| DBFirst:
    forall Γ t v1 v2,
      is_erased_term v1 ->
      is_erased_term v2 ->
      wf v1 0 ->
      wf v2 0 ->
      subset (fv v1) (support Γ) ->
      subset (fv v2) (support Γ) ->
      [ Γ ⊫ v1 : T_top ] ->
      [ Γ ⊫ v2 : T_top ] ->
      [ Γ ⊨ t ⤳* pp v1 v2 ] ->
      [ Γ ⊨ pi1 t ⤳* v1 ]

| DBSecond:
    forall Γ t v1 v2,
      is_erased_term v1 ->
      is_erased_term v2 ->
      wf v1 0 ->
      wf v2 0 ->
      subset (fv v1) (support Γ) ->
      subset (fv v2) (support Γ) ->
      [ Γ ⊫ v1 : T_top ] ->
      [ Γ ⊫ v2 : T_top ] ->
      [ Γ ⊨ t ⤳* pp v1 v2 ] ->
      [ Γ ⊨ pi2 t ⤳* v2 ]

| DBApp1:
    forall Γ f t t' body v,
      is_erased_term t' ->
      is_erased_term body ->
      pfv t' term_var = nil ->
      pfv body term_var = nil ->
      wf t' 0 ->
      wf body 0 ->
      [ Γ ⊫ t' : T_top ] ->
      [ Γ ⊨ t ⤳* t' ] ->
      [ Γ ⊨ f ⤳* notype_lambda body ] ->
      [ Γ ⊨ open 0 body t' ⤳* v ] ->
      [ Γ ⊨ app f t ⤳* v ]

| DBApp2:
    forall Γ f f' t t',
      [ Γ ⊨ t ⤳* t' ] ->
      [ Γ ⊨ f ⤳* f' ] ->
      [ Γ ⊨ app f t ⤳* app f' t' ]

| DBNatMatch1:
    forall Γ t t0 ts v,
      is_erased_term ts ->
      wf ts 1 ->
      subset (fv ts) (support Γ) ->
      [ Γ ⊨ t ⤳* zero ] ->
      [ Γ ⊨ t0 ⤳* v ] ->
      [ Γ ⊨ tmatch t t0 ts ⤳* v ]

| DBNatMatch2:
    forall Γ t t0 ts t' v,
      is_erased_term t0 ->
      is_erased_term ts ->
      wf t0 0 ->
      wf ts 1 ->
      subset (fv t0) (support Γ) ->
      subset (fv ts) (support Γ) ->
      subset (fv v) (support Γ) ->
      [ Γ ⊫ t' : T_top ] ->
      [ Γ ⊨ t ⤳* succ t' ] ->
      [ Γ ⊨ open 0 ts t' ⤳* v ] ->
      [ Γ ⊨ tmatch t t0 ts ⤳* v ]

| DBNatMatch3:
    forall Γ t t' t0 ts,
      is_erased_term t0 ->
      is_erased_term ts ->
      wf t0 0 ->
      wf ts 1 ->
      subset (fv t0) (support Γ) ->
      subset (fv ts) (support Γ) ->
      [ Γ ⊨ t ⤳* t' ] ->
      [ Γ ⊨ tmatch t t0 ts ⤳* tmatch t' t0 ts ]

| DBListMatch1:
    forall Γ t t1 t2 v,
      is_erased_term t2 ->
      wf t2 2 ->
      subset (fv t2) (support Γ) ->
      [ Γ ⊨ t ⤳* tnil ] ->
      [ Γ ⊨ t1 ⤳* v ] ->
      [ Γ ⊨ list_match t t1 t2 ⤳* v ]

| DBListMatch2:
    forall Γ t1 t2 h t v,
      wf t1 0 ->
      wf t2 2 ->
      is_erased_term t1 ->
      is_erased_term t2 ->
      subset (fv t1) (support Γ) ->
      subset (fv t2) (support Γ) ->
      [ Γ ⊫ t : List ] ->
      [ Γ ⊨ t ⤳* tcons h t ] ->
      [ Γ ⊨ open 0 (open 1 t2 h) t ⤳* v ] ->
      [ Γ ⊨ list_match t t1 t2 ⤳* v ]

| DBListMatch3:
    forall Γ t t' t1 t2,
      is_erased_term t1 ->
      is_erased_term t2 ->
      wf t1 0 ->
      wf t2 2 ->
      subset (fv t1) (support Γ) ->
      subset (fv t2) (support Γ) ->
      [ Γ ⊨ t ⤳* t' ] ->
      [ Γ ⊨ list_match t t1 t2 ⤳* list_match t' t1 t2 ]

| DBLeft:
    forall Γ t v,
      [ Γ ⊨ t ⤳* v ] ->
      [ Γ ⊨ tleft t ⤳* tleft v ]

| DBRight:
    forall Γ t v,
      [ Γ ⊨ t ⤳* v ] ->
      [ Γ ⊨ tright t ⤳* tright v ]

| DBFix0:
    forall Γ t default v,
      wf default 0 ->
      wf t 1 ->
      is_erased_term default ->
      is_erased_term t ->
      subset (fv default) (support Γ) ->
      subset (fv t) (support Γ) ->
      [ Γ ⊨ default ⤳* v ] ->
      [ Γ ⊨ fix_default' t default zero  ⤳* v ]

| DBFix:
    forall Γ t default fuel v,
      is_nat_value fuel ->
      wf default 0 ->
      wf t 1 ->
      is_erased_term default ->
      is_erased_term t ->
      subset (fv default) (support Γ) ->
      subset (fv t) (support Γ) ->
      [ Γ ⊨ open 0 t (fix_default' t default fuel) ⤳* v ] ->
      [ Γ ⊨ fix_default' t default (succ fuel) ⤳* v ]

| DBRefl:
    forall Γ v,
      is_erased_term v ->
      wf v 0 ->
      subset (fv v) (support Γ) ->
      [ Γ ⊨ v ⤳* v ] (* when evaluation is finished *)

where "'[' Γ ⊨ t1 '⤳*' t2 ']'" := (delta_beta_reduction Γ t1 t2).

Lemma delta_beta_var:
  forall Θ Γ x ty t v,
    wf t 0 ->
    lookup Nat.eq_dec Γ x = Some (T_singleton ty t) ->
    [ Θ; Γ ⊨ t ≡ v ] ->
    [ Θ; Γ ⊨ fvar x term_var ≡ v ].
Proof.
  unfold open_equivalent, T_singleton;
    repeat step || t_lookup || erewrite satisfies_same_support in * by eauto.
  unshelve epose proof (satisfies_lookup2 _ _ _ _ _ _ H3 H0 matched);
    repeat step || simp_red || open_none || rewrite shift_nothing2 in * by eauto with wf;
    eauto using equivalent_trans.
Qed.

Lemma delta_beta_pair:
  forall Θ Γ t1 t2 t1' t2',
    [ Θ; Γ ⊨ t1 ≡ t1' ] ->
    [ Θ; Γ ⊨ t2 ≡ t2' ] ->
    [ Θ; Γ ⊨ pp t1 t2 ≡ pp t1' t2' ].
Proof.
  unfold open_equivalent; repeat step || apply equivalent_pp; eauto.
Qed.

Lemma open_equivalent_refl:
  forall Θ Γ t,
    is_erased_term t ->
    wf t 0 ->
    subset (fv t) (support Γ) ->
    [ Θ; Γ ⊨ t ≡ t ].
Proof.
  unfold open_equivalent; intros; apply equivalent_refl; steps;
    eauto with erased fv wf.
Qed.

Lemma equivalent_pi1_pp:
  forall t1 t2,
    is_erased_term t1 ->
    is_erased_term t2 ->
    wf t1 0 ->
    wf t2 0 ->
    pfv t1 term_var = nil ->
    pfv t2 term_var = nil ->
    scbv_normalizing t1 ->
    scbv_normalizing t2 ->
    [ pi1 (pp t1 t2) ≡ t1 ].
Proof.
  unfold scbv_normalizing; steps.
  apply equivalent_trans with v0.
  - equivalent_star.
    eapply star_trans; eauto with cbvlemmas.
    eapply star_trans; eauto with cbvlemmas.
    eauto using star_one with smallstep.
  - apply equivalent_sym; equivalent_star.
Qed.

Lemma equivalent_pi2_pp:
  forall t1 t2,
    is_erased_term t1 ->
    is_erased_term t2 ->
    wf t1 0 ->
    wf t2 0 ->
    pfv t1 term_var = nil ->
    pfv t2 term_var = nil ->
    scbv_normalizing t1 ->
    scbv_normalizing t2 ->
    [ pi2 (pp t1 t2) ≡ t2 ].
Proof.
  unfold scbv_normalizing; steps.
  apply equivalent_trans with v.
  - equivalent_star.
    eapply star_trans; eauto with cbvlemmas.
    eapply star_trans; eauto with cbvlemmas.
    eauto using star_one with smallstep.
  - apply equivalent_sym; equivalent_star.
Qed.

Lemma lookup_value:
  forall l x v,
    are_values l ->
    lookup Nat.eq_dec l x = Some v ->
    cbv_value v.
Proof.
  induction l; steps; eauto.
Qed.

Lemma satisfies_are_values:
  forall l ρ Γ,
    valid_interpretation ρ ->
    satisfies (reducible_values ρ) Γ l ->
    are_values l.
Proof.
  induction l; repeat step || step_inversion satisfies; eauto with values.
Qed.

Lemma typable_normalizing:
  forall Θ Γ t T ρ l,
    [ Θ; Γ ⊨ t : T ] ->
    satisfies (reducible_values ρ) Γ l ->
    valid_interpretation ρ ->
    Θ = support ρ ->
    scbv_normalizing (psubstitute t l term_var).
Proof.
  unfold scbv_normalizing, open_reducible, reduces_to;
    repeat step || t_instantiate_sat3; eauto with values.
Qed.

Lemma delta_beta_first:
  forall Γ t t1 t2,
    is_erased_term t1 ->
    is_erased_term t2 ->
    wf t1 0 ->
    wf t2 0 ->
    subset (fv t1) (support Γ) ->
    subset (fv t2) (support Γ) ->
    [ Γ ⊫ t1 : T_top ] ->
    [ Γ ⊫ t2 : T_top ] ->
    [ Γ ⊫ t ≡ pp t1 t2 ] ->
    [ Γ ⊫ pi1 t ≡ t1 ].
Proof.
  unfold open_equivalent; repeat step; eauto.
  eapply equivalent_trans; eauto using equivalent_pi1.
  apply equivalent_pi1_pp; steps; eauto with erased wf fv;
    eauto using typable_normalizing.
Qed.

Lemma delta_beta_second:
  forall Γ t t1 t2,
    is_erased_term t1 ->
    is_erased_term t2 ->
    wf t1 0 ->
    wf t2 0 ->
    subset (fv t1) (support Γ) ->
    subset (fv t2) (support Γ) ->
    [ Γ ⊫ t1 : T_top ] ->
    [ Γ ⊫ t2 : T_top ] ->
    [ Γ ⊫ t ≡ pp t1 t2 ] ->
    [ Γ ⊫ pi2 t ≡ t2 ].
Proof.
  unfold open_equivalent; repeat step; eauto.
  eapply equivalent_trans; eauto using equivalent_pi2.
  apply equivalent_pi2_pp; steps; eauto with erased wf fv;
    eauto using typable_normalizing.
Qed.

Lemma equivalent_beta2:
  forall f t,
    is_erased_term t ->
    is_erased_term f ->
    pfv t term_var = nil ->
    pfv f term_var = nil ->
    wf t 0 ->
    wf f 1 ->
    scbv_normalizing t ->
    equivalent_terms (app (notype_lambda f) t) (open 0 f t).
Proof.
  unfold scbv_normalizing; repeat step; eauto using equivalent_beta.
Qed.

Lemma delta_beta_app1:
  forall Γ f t t' v body,
    is_erased_term t' ->
    is_erased_term body ->
    pfv t' term_var = nil ->
    pfv body term_var = nil ->
    wf t' 0 ->
    wf body 0 ->
    [ Γ ⊫ t' : T_top ] ->
    [ Γ ⊫ t ≡ t' ] ->
    [ Γ ⊫ f ≡ notype_lambda body ] ->
    [ Γ ⊫ open 0 body t' ≡ v ] ->
    [ Γ ⊫ app f t ≡ v ].
Proof.
  unfold open_equivalent; repeat step || t_instantiate_sat3 || t_substitutions.
  eapply equivalent_trans; eauto using equivalent_app.
  eapply equivalent_trans; eauto; repeat step || t_substitutions.
  eapply equivalent_beta2; steps; eauto using typable_normalizing;
    eauto with erased fv wf.
Qed.

Lemma delta_beta_app2:
  forall Θ Γ f f' t t',
    [ Θ; Γ ⊨ t ≡ t' ] ->
    [ Θ; Γ ⊨ f ≡ f' ] ->
    [ Θ; Γ ⊨ app f t ≡ app f' t' ].
Proof.
  unfold open_equivalent; repeat step || t_instantiate_sat3 || t_substitutions;
    eauto using equivalent_app.
Qed.

Lemma equivalent_match_scrut:
  forall t t' t0 ts,
    is_erased_term t0 ->
    is_erased_term ts ->
    wf t0 0 ->
    wf ts 1 ->
    pfv t0 term_var = nil ->
    pfv ts term_var = nil ->
    [ t ≡ t' ] ->
    [ tmatch t t0 ts ≡ tmatch t' t0 ts ].
Proof.
  intros.
  unshelve epose proof (equivalent_context (tmatch (lvar 0 term_var) t0 ts) _ _ _ _ _ H5);
    repeat step || list_utils || open_none;
    eauto with wf.
Qed.

Lemma equivalent_list_match_scrut:
  forall t t' t1 t2,
    is_erased_term t1 ->
    is_erased_term t2 ->
    wf t1 0 ->
    wf t2 2 ->
    pfv t1 term_var = nil ->
    pfv t2 term_var = nil ->
    [ t ≡ t' ] ->
    [ list_match t t1 t2 ≡ list_match t' t1 t2 ].
Proof.
  intros.
  unshelve epose proof (equivalent_context (list_match (lvar 0 term_var) t1 t2) _ _ _ _ _ H5);
    repeat step || list_utils || open_none ||
           (rewrite (open_none t1) in * by eauto with wf) ||
           (rewrite open_none in H6 by (steps; eauto with wf step_tactic));
    eauto 3 with wf erased fv step_tactic.
Qed.

Lemma delta_beta_match_zero:
  forall Θ Γ t t0 ts v,
    is_erased_term ts ->
    wf ts 1 ->
    subset (fv ts) (support Γ) ->
    [ Θ; Γ ⊨ t ≡ zero ] ->
    [ Θ; Γ ⊨ t0 ≡ v ] ->
    [ Θ; Γ ⊨ tmatch t t0 ts ≡ v ].
Proof.
  unfold open_equivalent; repeat step || t_instantiate_sat3.
  eapply equivalent_trans; eauto.
  eapply equivalent_trans; try apply equivalent_match_scrut; eauto;
    eauto with erased wf fv;
    equivalent_star.
Qed.

Lemma delta_beta_match_succ:
  forall Γ t t0 ts t' v,
    is_erased_term t0 ->
    is_erased_term ts ->
    wf t0 0 ->
    wf ts 1 ->
    subset (fv t0) (support Γ) ->
    subset (fv ts) (support Γ) ->
    subset (fv v) (support Γ) ->
    [ Γ ⊫ t' : T_top ] ->
    [ Γ ⊫ t ≡ succ t' ] ->
    [ Γ ⊫ open 0 ts t' ≡ v ] ->
    [ Γ ⊫ tmatch t t0 ts ≡ v ].
Proof.
  unfold open_equivalent, open_reducible;
    repeat step || t_instantiate_sat3_nil || t_substitutions.
  eapply equivalent_trans; eauto; repeat step || t_substitutions.
  eapply equivalent_trans; try apply equivalent_match_scrut;
    eauto with erased fv wf.
  top_level_unfold reduces_to; steps.
  eapply equivalent_trans; try apply equivalent_match_scrut;
    eauto with erased fv wf;
    try solve [ apply equivalent_succ; equivalent_star ].

  eapply equivalent_trans; try solve [ equivalent_star ].
  apply equivalent_context; eauto with erased wf fv.
  apply equivalent_sym; equivalent_star.
Qed.

Lemma delta_beta_match_scrut:
  forall Θ Γ t t' t0 ts,
    is_erased_term t0 ->
    is_erased_term ts ->
    wf t0 0 ->
    wf ts 1 ->
    subset (fv t0) (support Γ) ->
    subset (fv ts) (support Γ) ->
    [ Θ; Γ ⊨ t ≡ t' ] ->
    [ Θ; Γ ⊨ tmatch t t0 ts ≡ tmatch t' t0 ts ].
Proof.
  unfold open_equivalent; steps; apply equivalent_match_scrut;
    eauto with erased wf fv.
Qed.

Opaque list_match.

Lemma delta_beta_list_match_nil:
  forall Θ Γ t t1 t2 v,
    is_erased_term t2 ->
    wf t2 2 ->
    subset (fv t2) (support Γ) ->
    [ Θ; Γ ⊨ t ≡ tnil ] ->
    [ Θ; Γ ⊨ t1 ≡ v ] ->
    [ Θ; Γ ⊨ list_match t t1 t2 ≡ v ].
Proof.
  unfold open_equivalent; repeat step || t_instantiate_sat3 || rewrite substitute_list_match;
    eauto with wf.
  eapply equivalent_trans; eauto.
  eapply equivalent_trans; try apply equivalent_list_match_scrut; eauto;
    eauto with erased wf fv;
    try solve [ equivalent_star ].

  evaluate_list_match; repeat step; eauto with wf fv erased.
  - apply reducible_nil; auto.
  - equivalent_star; eauto 3 with wf erased fv step_tactic.
  - unfold tcons in *; steps.
Qed.

Opaque List.

Lemma equivalent_right_eval_left:
  forall t t' v,
    cbv_value v  ->
    [ t ≡ tright t' ] ->
    t ~>* tleft v ->
    False.
Proof.
  intros.
  apply right_left_equivalence with t' v; auto.
  eapply equivalent_trans; eauto using equivalent_sym; equivalent_star.
Qed.

Lemma equivalent_right_eval_nil:
  forall t t',
    [ t ≡ tright t' ] ->
    t ~>* tnil ->
    False.
Proof.
  intros.
  apply equivalent_right_eval_left with t t' uu; steps.
Qed.

Lemma equivalent_context2:
  forall C t1 t1' t2 t2',
    is_erased_term C ->
    wf C 2 ->
    pfv C term_var = nil ->
    [ t1 ≡ t1' ] ->
    [ t2 ≡ t2' ] ->
    [ open 0 (open 1 C t1) t2 ≡ open 0 (open 1 C t1') t2' ].
Proof.
  intros.
  eapply equivalent_trans; try solve [ apply equivalent_context; steps; eauto with erased wf fv ].
  repeat rewrite (swap_term_holes_open C); steps; eauto with wf.
  apply equivalent_context; steps; eauto with erased wf fv.
Qed.

Lemma delta_beta_list_match_cons:
  forall Γ h t t1 t2 v,
    wf t1 0 ->
    wf t2 2 ->
    is_erased_term t1 ->
    is_erased_term t2 ->
    subset (fv t1) (support Γ) ->
    subset (fv t2) (support Γ) ->
    [ Γ ⊫ t : List ] ->
    [ Γ ⊫ t ≡ tcons h t ] ->
    [ Γ ⊫ open 0 (open 1 t2 h) t ≡ v ] ->
    [ Γ ⊫ list_match t t1 t2 ≡ v ].
Proof.
  unfold open_equivalent, open_reducible;
    repeat step || t_instantiate_sat3_nil || t_substitutions || rewrite substitute_list_match;
    eauto with wf.

  eapply equivalent_trans; eauto.

  eapply equivalent_trans; try apply equivalent_list_match_scrut; eauto;
    eauto with erased wf fv;
    try solve [ equivalent_star ].

  evaluate_list_match2; repeat step || t_invert_star || unfold tcons in *; eauto with wf fv erased;
    eauto using reducibility_equivalent2, is_erased_list, wf_list;
    try solve [ unfold tnil in *; repeat step || t_invert_star ].

  eapply equivalent_trans; eauto.
  apply_anywhere right_right_star.
  apply equivalent_context2; steps; eauto with fv wf erased.
  - apply equivalent_sym; equivalent_star; eauto using pp_pp_star_1.
  - apply equivalent_sym; equivalent_star; eauto using pp_pp_star_2.
Qed.

Lemma delta_beta_list_match_scrut:
  forall Θ Γ t t' t1 t2,
    is_erased_term t1 ->
    is_erased_term t2 ->
    wf t1 0 ->
    wf t2 2 ->
    subset (fv t1) (support Γ) ->
    subset (fv t2) (support Γ) ->
    [ Θ; Γ ⊨ t ≡ t' ] ->
    [ Θ; Γ ⊨ list_match t t1 t2 ≡ list_match t' t1 t2 ].
Proof.
  unfold open_equivalent; repeat step || rewrite substitute_list_match;
    try apply equivalent_list_match_scrut;
    eauto with erased wf fv.
Qed.

Lemma open_equivalent_context:
  forall Θ Γ t1 t2 C,
    is_erased_term C ->
    wf C 1 ->
    subset (fv C) (support Γ) ->
    [ Θ; Γ ⊨ t1 ≡ t2 ] ->
    [ Θ; Γ ⊨ open 0 C t1 ≡ open 0 C t2 ].
Proof.
  unfold open_equivalent;
    repeat step || t_instantiate_sat3 || t_substitutions || apply equivalent_context;
    eauto with fv wf erased.
Qed.

Lemma delta_beta_left:
  forall Θ Γ t t',
    [ Θ; Γ ⊨ t ≡ t' ] ->
    [ Θ; Γ ⊨ tleft t ≡ tleft t' ].
Proof.
  intros.
  unshelve epose proof (open_equivalent_context _ _ _ _ (tleft (lvar 0 term_var)) _ _ _ H);
    steps; eauto with sets.
Qed.

Lemma delta_beta_right:
  forall Θ Γ t t',
    [ Θ; Γ ⊨ t ≡ t' ] ->
    [ Θ; Γ ⊨ tright t ≡ tright t' ].
Proof.
  intros.
  unshelve epose proof (open_equivalent_context _ _ _ _ (tright (lvar 0 term_var)) _ _ _ H);
    steps; eauto with sets.
Qed.

Opaque fix_default'.

Lemma delta_beta_fix_zero:
  forall Γ t default v,
    wf default 0 ->
    wf t 1 ->
    is_erased_term default ->
    is_erased_term t ->
    subset (fv default) (support Γ) ->
    subset (fv t) (support Γ) ->
    [ Γ ⊫ default ≡ v ] ->
    [ Γ ⊫ fix_default' t default zero ≡ v ].
Proof.
  unfold open_equivalent; repeat step || rewrite subst_fix_default; eauto with wf.

  evaluate_fix_default; steps; eauto with wf.
  eapply equivalent_trans; eauto.

  equivalent_star; eauto 4 with fv erased wf step_tactic.
Qed.

Lemma delta_beta_fix_succ:
  forall Γ t default fuel v,
    is_nat_value fuel ->
    wf default 0 ->
    wf t 1 ->
    is_erased_term default ->
    is_erased_term t ->
    subset (fv default) (support Γ) ->
    subset (fv t) (support Γ) ->
    [ Γ ⊫ open 0 t (fix_default' t default fuel) ≡ v ] ->
    [ Γ ⊫ fix_default' t default (succ fuel) ≡ v ].
Proof.
  unfold open_equivalent; repeat step || t_instantiate_sat3_nil || t_substitutions ||
                                 rewrite subst_fix_default in * by eauto with wf.
  evaluate_fix_default; repeat step || rewrite (substitute_nothing5 fuel) in * by eauto with fv;
    eauto with wf; eauto with is_nat_value.
  eapply equivalent_trans; eauto.
  equivalent_star; eauto with erased wf fv step_tactic.
Qed.

Lemma delta_beta_obs_equiv:
  forall Γ t1 t2,
    [ Γ ⊨ t1 ⤳* t2 ] ->
    [ Γ ⊫ t1 ≡ t2 ].
Proof.
  induction 1; repeat step;
    eauto using delta_beta_var;
    eauto using delta_beta_pair;
    eauto using delta_beta_first;
    eauto using delta_beta_second;
    eauto using delta_beta_app1;
    eauto using delta_beta_app2;
    eauto using delta_beta_match_zero;
    eauto using delta_beta_match_succ;
    eauto using delta_beta_match_scrut;
    eauto using delta_beta_list_match_nil;
    eauto using delta_beta_list_match_cons;
    eauto using delta_beta_list_match_scrut;
    eauto using delta_beta_left;
    eauto using delta_beta_right;
    eauto using delta_beta_fix_zero;
    eauto using delta_beta_fix_succ;
    eauto using open_equivalent_refl.
Qed.


Require Import Bedrock.Bedrock Bedrock.Platform.PreAutoSep.

(** * Separation logic specifications for system calls *)

Definition abortS := SPEC reserving 0
  PREonly[_] Emp.

Definition printIntS := SPEC("n") reserving 0
  PRE[_] Emp
  POST[_] Emp.

Definition listenS := SPEC("port") reserving 0
  PRE[_] Emp
  POST[stream] Emp.

Definition acceptS := SPEC("stream") reserving 0
  PRE[_] Emp
  POST[stream'] Emp.

Definition buffer (p : W) (size : nat) : HProp :=
  (Ex bs, array8 bs p * [| length bs = size |])%Sep.

Infix "=?>8" := buffer (at level 39) : Sep_scope.
Notation "buf =?>8 size" := (Body (buf =?>8 size)%Sep) : qspec_scope.

Definition connectS := SPEC("address", "size") reserving 0
  PRE[V] V "address" =?>8 wordToNat (V "size")
  POST[bytesRead] V "address" =?>8 wordToNat (V "size").

Definition readS := SPEC("stream", "buffer", "size") reserving 0
  PRE[V] V "buffer" =?>8 wordToNat (V "size")
  POST[bytesRead] V "buffer" =?>8 wordToNat (V "size").

Definition writeS := SPEC("stream", "buffer", "size") reserving 0
  PRE[V] V "buffer" =?>8 wordToNat (V "size")
  POST[bytesWritten] V "buffer" =?>8 wordToNat (V "size").

(* Limited version of epoll_ctl *)
Definition declareS := SPEC("stream", "mode") reserving 0
  PRE[_] Emp
  POST[index] Emp.
(* Mode is either 0 for read or 1 for write. *)

(* Limited version of epoll_wait *)
Definition waitS := SPEC("blocking") reserving 0
  PRE[_] Emp
  POST[index] Emp.

Definition closeS := SPEC("stream") reserving 0
  PRE[_] Emp
  POST[_] Emp.

(** * More primitive operational semantics *)

Definition mapped (base : W) (len : nat) (m : mem) :=
  forall n, (n < len)%nat -> m (base ^+ $ (n)) <> None.

Record onlyChange (base : W) (len : nat) (m m' : mem) : Prop :=
  { Elsewhere : forall p, (forall n, (n < len)%nat -> p <> base ^+ $ (n))
    -> m' p = m p;
    SameMapped : forall p, m p = None <-> m' p = None }.

Hint Constructors onlyChange.

Section OpSem.
  Variable stn : settings.
  Variable prog : program.

  Inductive sys_step : state' -> state' -> Prop :=
  | Normal : forall st st', step stn prog st = Some st'
    -> sys_step st st'
  | Abort : forall st, Labels stn ("sys", Global "abort") = Some (fst st)
    -> sys_step st st
  | PrintInt : forall st st',
    Labels stn ("sys", Global "printInt") = Some (fst st)
    -> mapped (Regs (snd st) Sp) 8 (Mem (snd st))
    -> Regs st' Sp = Regs (snd st) Sp
    -> Mem st' = Mem (snd st)
    -> sys_step st (Regs (snd st) Rp, st')
  | Listen : forall st st', Labels stn ("sys", Global "listen") = Some (fst st)
    -> mapped (Regs (snd st) Sp) 8 (Mem (snd st))
    -> Regs st' Sp = Regs (snd st) Sp
    -> Mem st' = Mem (snd st)
    -> sys_step st (Regs (snd st) Rp, st')
  | Accept : forall st st',
    Labels stn ("sys", Global "accept") = Some (fst st)
    -> mapped (Regs (snd st) Sp) 8 (Mem (snd st))
    -> Regs st' Sp = Regs (snd st) Sp
    -> Mem st' = Mem (snd st)
    -> sys_step st (Regs (snd st) Rp, st')
  | Connect : forall st address size st',
    Labels stn ("sys", Global "connect") = Some (fst st)
    -> mapped (Regs (snd st) Sp) 12 (Mem (snd st))
    -> ReadWord stn (Mem (snd st)) (Regs (snd st) Sp ^+ $4) = Some address
    -> ReadWord stn (Mem (snd st)) (Regs (snd st) Sp ^+ $8) = Some size
    -> mapped address (wordToNat size) (Mem (snd st))
    -> Regs st' Sp = Regs (snd st) Sp
    -> onlyChange address (wordToNat size) (Mem (snd st)) (Mem st')
    -> sys_step st (Regs (snd st) Rp, st')
  | Read : forall st buffer size st',
    Labels stn ("sys", Global "read") = Some (fst st)
    -> mapped (Regs (snd st) Sp) 16 (Mem (snd st))
    -> ReadWord stn (Mem (snd st)) (Regs (snd st) Sp ^+ $8) = Some buffer
    -> ReadWord stn (Mem (snd st)) (Regs (snd st) Sp ^+ $12) = Some size
    -> mapped buffer (wordToNat size) (Mem (snd st))
    -> Regs st' Sp = Regs (snd st) Sp
    -> onlyChange buffer (wordToNat size) (Mem (snd st)) (Mem st')
    -> sys_step st (Regs (snd st) Rp, st')
  | Write : forall st buffer size st',
    Labels stn ("sys", Global "write") = Some (fst st)
    -> mapped (Regs (snd st) Sp) 16 (Mem (snd st))
    -> ReadWord stn (Mem (snd st)) (Regs (snd st) Sp ^+ $8) = Some buffer
    -> ReadWord stn (Mem (snd st)) (Regs (snd st) Sp ^+ $12) = Some size
    -> mapped buffer (wordToNat size) (Mem (snd st))
    -> Regs st' Sp = Regs (snd st) Sp
    -> Mem st' = Mem (snd st)
    -> sys_step st (Regs (snd st) Rp, st')
  | Declare : forall st st',
    Labels stn ("sys", Global "declare") = Some (fst st)
    -> mapped (Regs (snd st) Sp) 12 (Mem (snd st))
    -> Regs st' Sp = Regs (snd st) Sp
    -> Mem st' = Mem (snd st)
    -> sys_step st (Regs (snd st) Rp, st')
  | Wait : forall st st',
    Labels stn ("sys", Global "wait") = Some (fst st)
    -> mapped (Regs (snd st) Sp) 8 (Mem (snd st))
    -> Regs st' Sp = Regs (snd st) Sp
    -> Mem st' = Mem (snd st)
    -> sys_step st (Regs (snd st) Rp, st')
  | Close : forall st st',
    Labels stn ("sys", Global "close") = Some (fst st)
    -> mapped (Regs (snd st) Sp) 8 (Mem (snd st))
    -> Regs st' Sp = Regs (snd st) Sp
    -> Mem st' = Mem (snd st)
    -> sys_step st (Regs (snd st) Rp, st').

  Inductive sys_reachable : state' -> state' -> Prop :=
  | SR0 : forall st, sys_reachable st st
  | SR1 : forall st st' st'', sys_step st st'
    -> sys_reachable st' st''
    -> sys_reachable st st''.

  Definition sys_safe (st : state') :=
    forall st', sys_reachable st st' -> exists st'', sys_step st' st''.
End OpSem.


From iris.base_logic Require Export invariants gen_heap.
From iris.program_logic Require Export weakestpre ectx_lifting.
From iris.proofmode Require Import tactics.
From iris.algebra Require Import frac.
From cap_machine Require Import machine_base rules_base.

Section cap_lang_rules.
  Context `{memG Σ, regG Σ}.
  Context `{MachineParameters}.
  Implicit Types P Q : iProp Σ.
  Implicit Types σ : ExecConf.
  Implicit Types c : cap_lang.expr.
  Implicit Types a b : Addr.
  Implicit Types r : RegName.
  Implicit Types v : cap_lang.val.
  Implicit Types w : Word.
  Implicit Types reg : gmap RegName Word.
  Implicit Types ms : gmap Addr Word.

  (* TODO: move to stdpp *)
  Tactic Notation "destruct_or" ident(H) :=
  match type of H with
  | _ ∨ _ => destruct H as [H|H]
  | Is_true (_ || _) => apply orb_True in H; destruct H as [H|H]
  end.
  Tactic Notation "destruct_or" "?" ident(H) := repeat (destruct_or H).
  Tactic Notation "destruct_or" "!" ident(H) := hnf in H; destruct_or H; destruct_or? H.

  Definition denote (i: instr) (n1 n2: Z): Z :=
    match i with
    | machine_base.Add _ _ _ => (n1 + n2)%Z
    | Sub _ _ _ => (n1 - n2)%Z
    | Lt _ _ _ => (Z.b2z (n1 <? n2)%Z)
    | _ => 0%Z
    end.

  Definition is_AddSubLt (i: instr) (r: RegName) (arg1 arg2: Z + RegName) :=
    i = machine_base.Add r arg1 arg2 ∨
    i = Sub r arg1 arg2 ∨
    i = Lt r arg1 arg2.

  Lemma regs_of_is_AddSubLt i r arg1 arg2 :
    is_AddSubLt i r arg1 arg2 →
    regs_of i = {[ r ]} ∪ regs_of_argument arg1 ∪ regs_of_argument arg2.
  Proof.
    intros HH. destruct_or! HH; subst i; reflexivity.
  Qed.

  Inductive AddSubLt_failure (i: instr) (regs: Reg) (dst: RegName) (rv1 rv2: Z + RegName) (regs': Reg) :=
  | AddSubLt_fail_nonconst1:
      z_of_argument regs rv1 = None ->
      AddSubLt_failure i regs dst rv1 rv2 regs'
  | AddSubLt_fail_nonconst2:
      z_of_argument regs rv2 = None ->
      AddSubLt_failure i regs dst rv1 rv2 regs'
  | AddSubLt_fail_incrPC n1 n2:
      z_of_argument regs rv1 = Some n1 ->
      z_of_argument regs rv2 = Some n2 ->
      incrementPC (<[ dst := inl (denote i n1 n2) ]> regs) = None ->
      regs' = (<[ dst := inl (denote i n1 n2) ]> regs) ->
      AddSubLt_failure i regs dst rv1 rv2 regs'.

  Inductive AddSubLt_spec (i: instr) (regs: Reg) (dst: RegName) (rv1 rv2: Z + RegName) (regs': Reg): cap_lang.val -> Prop :=
  | AddSubLt_spec_success n1 n2:
      z_of_argument regs rv1 = Some n1 ->
      z_of_argument regs rv2 = Some n2 ->
      incrementPC (<[ dst := inl (denote i n1 n2) ]> regs) = Some regs' ->
      AddSubLt_spec i regs dst rv1 rv2 regs' NextIV
  | AddSubLt_spec_failure:
      AddSubLt_failure i regs dst rv1 rv2 regs' ->
      AddSubLt_spec i regs dst rv1 rv2 regs' FailedV.

  Local Ltac iFail Hcont get_fail_case :=
    cbn; iFrame; iApply Hcont; iFrame; iPureIntro;
    econstructor; eapply get_fail_case; eauto.

  Lemma wp_AddSubLt Ep i pc_p pc_g pc_b pc_e pc_a w dst arg1 arg2 regs :
    decodeInstrW w = i →
    is_AddSubLt i dst arg1 arg2 →
    isCorrectPC (inr ((pc_p, pc_g), pc_b, pc_e, pc_a)) →
    regs !! PC = Some (inr ((pc_p, pc_g), pc_b, pc_e, pc_a)) →
    regs_of i ⊆ dom _ regs →
    {{{ ▷ pc_a ↦ₐ w ∗
        ▷ [∗ map] k↦y ∈ regs, k ↦ᵣ y }}}
      Instr Executable @ Ep
    {{{ regs' retv, RET retv;
        ⌜ AddSubLt_spec (decodeInstrW w) regs dst arg1 arg2 regs' retv ⌝ ∗
          pc_a ↦ₐ w ∗
          [∗ map] k↦y ∈ regs', k ↦ᵣ y }}}.
  Proof.
    iIntros (Hdecode Hinstr Hvpc HPC Dregs φ) "(>Hpc_a & >Hmap) Hφ".
    iApply wp_lift_atomic_head_step_no_fork; auto.
    iIntros (σ1 l1 l2 n) "Hσ1 /=". destruct σ1 as [r m]; simpl.
    iDestruct "Hσ1" as "[Hr Hm]".
    iDestruct (gen_heap_valid_inclSepM with "Hr Hmap") as %Hregs.
    have HPC' := regs_lookup_eq _ _ _ HPC.
    have ? := lookup_weaken _ _ _ _ HPC Hregs.
    iDestruct (@gen_heap_valid with "Hm Hpc_a") as %Hpc_a; auto.
    iModIntro. iSplitR. by iPureIntro; apply normal_always_head_reducible.
    iNext. iIntros (e2 σ2 efs Hpstep).
    apply prim_step_exec_inv in Hpstep as (-> & -> & (c & -> & Hstep)).
    iSplitR; auto. eapply step_exec_inv in Hstep; eauto.

    specialize (indom_regs_incl _ _ _ Dregs Hregs) as Hri.
    erewrite regs_of_is_AddSubLt in Hri, Dregs; eauto.
    destruct (Hri dst) as [wdst [H'dst Hdst]]. by set_solver+.

    destruct (z_of_argument regs arg1) as [n1|] eqn:Hn1;
      pose proof Hn1 as Hn1'; cycle 1.
    (* Failure: arg1 is not an integer *)
    { unfold z_of_argument in Hn1. destruct arg1 as [| r0]; [ congruence |].
      destruct (Hri r0) as [r0v [Hr'0 Hr0]]. by unfold regs_of_argument; set_solver+.
      rewrite Hr'0 in Hn1. destruct r0v as [| (([[? ?] ?] & ?) & ?) ]; [ congruence |].
      assert (c = Failed ∧ σ2 = (r, m)) as (-> & ->).
      { destruct_or! Hinstr; rewrite Hinstr /= in Hstep.
        all: rewrite /RegLocate Hr0 in Hstep. all: repeat case_match; simplify_eq; eauto. }
      iFail "Hφ" AddSubLt_fail_nonconst1. }

    destruct (z_of_argument regs arg2) as [n2|] eqn:Hn2;
      pose proof Hn2 as Hn2'; cycle 1.
    (* Failure: arg2 is not an integer *)
    { unfold z_of_argument in Hn2. destruct arg2 as [| r0]; [ congruence |].
      destruct (Hri r0) as [r0v [Hr'0 Hr0]]. by unfold regs_of_argument; set_solver+.
      rewrite Hr'0 in Hn2. destruct r0v as [| (([[? ?] ?] & ?) & ?) ]; [ congruence |].
      assert (c = Failed ∧ σ2 = (r, m)) as (-> & ->).
      { destruct_or! Hinstr; rewrite Hinstr /= in Hstep.
        all: rewrite /RegLocate Hr0 in Hstep. all: repeat case_match; simplify_eq; eauto. }
      iFail "Hφ" AddSubLt_fail_nonconst2. }

    eapply z_of_argument_Some_inv' in Hn1; eapply z_of_argument_Some_inv' in Hn2; eauto.

    assert ((c, σ2) = updatePC (update_reg (r, m) dst (inl (denote i n1 n2)))) as HH.
    { destruct Hn1 as [ -> | (r1 & -> & _ & Hr1) ]; destruct Hn2 as [ -> | (r2 & -> & _ & Hr2) ].
      all: destruct_or! Hinstr; rewrite Hinstr /= /RegLocate /update_reg /= in Hstep |- *; auto.
      all: rewrite ?Hr1 ?Hr2 /= in Hstep; auto. }
    rewrite /update_reg /= in HH.

    destruct (incrementPC (<[ dst := inl (denote i n1 n2) ]> regs))
      as [regs'|] eqn:Hregs'; pose proof Hregs' as H'regs'; cycle 1.
    (* Failure: Cannot increment PC *)
    { apply incrementPC_fail_updatePC with (m:=m) in Hregs'.
      eapply updatePC_fail_incl with (m':=m) in Hregs'.
      2: by apply lookup_insert_is_Some'; eauto.
      2: by apply insert_mono; eauto.
      simplify_pair_eq.
      iMod ((gen_heap_update_inSepM _ _ dst) with "Hr Hmap") as "[Hr Hmap]"; eauto.
      iFail "Hφ" AddSubLt_fail_incrPC. }

    (* Success *)

    eapply (incrementPC_success_updatePC _ m) in Hregs'
      as (p' & g' & b' & e' & a'' & a_pc' & HPC'' & Ha_pc' & HuPC & -> & X).
    eapply updatePC_success_incl with (m':=m) in HuPC. 2: by eapply insert_mono; eauto.
    simplify_pair_eq. iFrame.
    iMod ((gen_heap_update_inSepM _ _ dst) with "Hr Hmap") as "[Hr Hmap]"; eauto.
    iMod ((gen_heap_update_inSepM _ _ PC) with "Hr Hmap") as "[Hr Hmap]"; eauto.
    iFrame. iModIntro. iApply "Hφ". iFrame. iPureIntro. econstructor; eauto.
  Qed.

  (* Derived specifications *)

  Lemma wp_add_sub_lt_success_z_z E dst pc_p pc_g pc_b pc_e pc_a w wdst ins n1 n2 pc_a' :
    decodeInstrW w = ins →
    is_AddSubLt ins dst (inl n1) (inl n2) →
    (pc_a + 1)%a = Some pc_a' →
    isCorrectPC (inr ((pc_p,pc_g),pc_b,pc_e,pc_a)) ->

    {{{ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a)
        ∗ pc_a ↦ₐ w
        ∗ dst ↦ᵣ wdst
    }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ inr (pc_p,pc_g,pc_b,pc_e,pc_a')
          ∗ pc_a ↦ₐ w
          ∗ dst ↦ᵣ inl (denote ins n1 n2)
      }}}.
  Proof.
    iIntros (Hdecode Hinstr Hpc_a Hvpc ϕ) "(HPC & Hpc_a & Hdst) Hφ".
    iDestruct (map_of_regs_2 with "HPC Hdst") as "[Hmap %]".
    iApply (wp_AddSubLt with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by erewrite regs_of_is_AddSubLt; eauto; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    destruct Hspec as [| * Hfail].
    { (* Success *)
      iApply "Hφ". iFrame. incrementPC_inv; simplify_map_eq.
      rewrite insert_commute // insert_insert insert_commute // insert_insert.
      iDestruct (regs_of_map_2 with "Hmap") as "[? ?]"; eauto; iFrame. }
    { (* Failure (contradiction) *)
      destruct Hfail; try incrementPC_inv; simplify_map_eq; eauto.
      destruct e1; try congruence.
      inv Hvpc. destruct H3 as [? | [? | [? | [? | ?]]]]; destruct H10 as [? | [? | ?]]; congruence. }
  Qed.

  Lemma wp_add_sub_lt_success_r_z E dst pc_p pc_g pc_b pc_e pc_a w wdst ins r1 n1 n2 pc_a' :
    decodeInstrW w = ins →
    is_AddSubLt ins dst (inr r1) (inl n2) →
    (pc_a + 1)%a = Some pc_a' →
    isCorrectPC (inr ((pc_p,pc_g),pc_b,pc_e,pc_a)) ->

    {{{ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a)
        ∗ pc_a ↦ₐ w
        ∗ r1 ↦ᵣ inl n1
        ∗ dst ↦ᵣ wdst
    }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ inr (pc_p,pc_g,pc_b,pc_e,pc_a')
          ∗ pc_a ↦ₐ w
          ∗ r1 ↦ᵣ inl n1
          ∗ dst ↦ᵣ inl (denote ins n1 n2)
      }}}.
  Proof.
    iIntros (Hdecode Hinstr Hpc_a Hvpc ϕ) "(HPC & Hpc_a & Hr1 & Hdst) Hφ".
    iDestruct (map_of_regs_3 with "HPC Hr1 Hdst") as "[Hmap (%&%&%)]".
    iApply (wp_AddSubLt with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by erewrite regs_of_is_AddSubLt; eauto; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    destruct Hspec as [| * Hfail].
    { (* Success *)
      iApply "Hφ". iFrame. incrementPC_inv; simplify_map_eq.
      rewrite (insert_commute _ PC dst) // insert_insert (insert_commute _ r1 dst) //
              (insert_commute _ dst PC) // insert_insert.
      iDestruct (regs_of_map_3 with "Hmap") as "(?&?&?)"; eauto; iFrame. }
    { (* Failure (contradiction) *)
      destruct Hfail; try incrementPC_inv; simplify_map_eq; eauto.
      destruct e1; try congruence.
      inv Hvpc. destruct H5 as [? | [? | [? | [? | ?]]]]; destruct H12 as [? | [? | ?]]; congruence. }
  Qed.

  Lemma wp_add_sub_lt_success_z_r E dst pc_p pc_g pc_b pc_e pc_a w wdst ins n1 r2 n2 pc_a' :
    decodeInstrW w = ins →
    is_AddSubLt ins dst (inl n1) (inr r2) →
    (pc_a + 1)%a = Some pc_a' →
    isCorrectPC (inr ((pc_p,pc_g),pc_b,pc_e,pc_a)) ->

    {{{ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a)
        ∗ pc_a ↦ₐ w
        ∗ r2 ↦ᵣ inl n2
        ∗ dst ↦ᵣ wdst
    }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ inr (pc_p,pc_g,pc_b,pc_e,pc_a')
          ∗ pc_a ↦ₐ w
          ∗ r2 ↦ᵣ inl n2
          ∗ dst ↦ᵣ inl (denote ins n1 n2)
      }}}.
  Proof.
    iIntros (Hdecode Hinstr Hpc_a Hvpc ϕ) "(HPC & Hpc_a & Hr2 & Hdst) Hφ".
    iDestruct (map_of_regs_3 with "HPC Hr2 Hdst") as "[Hmap (%&%&%)]".
    iApply (wp_AddSubLt with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by erewrite regs_of_is_AddSubLt; eauto; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    destruct Hspec as [| * Hfail].
    { (* Success *)
      iApply "Hφ". iFrame. incrementPC_inv; simplify_map_eq.
      rewrite (insert_commute _ PC dst) // insert_insert (insert_commute _ r2 dst) //
              (insert_commute _ dst PC) // insert_insert.
      iDestruct (regs_of_map_3 with "Hmap") as "(?&?&?)"; eauto; iFrame. }
    { (* Failure (contradiction) *)
      destruct Hfail; try incrementPC_inv; simplify_map_eq; eauto.
      destruct e1; try congruence.
      inv Hvpc. destruct H5 as [? | [? | [? | [? | ?]]]]; destruct H12 as [? | [? | ?]]; congruence. }
  Qed.

  Lemma wp_add_sub_lt_success_r_r E dst pc_p pc_g pc_b pc_e pc_a w wdst ins r1 n1 r2 n2 pc_a' :
    decodeInstrW w = ins →
    is_AddSubLt ins dst (inr r1) (inr r2) →
    (pc_a + 1)%a = Some pc_a' →
    isCorrectPC (inr (pc_p,pc_g,pc_b,pc_e,pc_a)) ->

    {{{ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a)
        ∗ pc_a ↦ₐ w
        ∗ r1 ↦ᵣ inl n1
        ∗ r2 ↦ᵣ inl n2
        ∗ dst ↦ᵣ wdst
    }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ inr (pc_p,pc_g,pc_b,pc_e,pc_a')
          ∗ pc_a ↦ₐ w
          ∗ r1 ↦ᵣ inl n1
          ∗ r2 ↦ᵣ inl n2
          ∗ dst ↦ᵣ inl (denote ins n1 n2)
      }}}.
  Proof.
    iIntros (Hdecode Hinstr Hpc_a Hvpc ϕ) "(HPC & Hpc_a & Hr1 & Hr2 & Hdst) Hφ".
    iDestruct (map_of_regs_4 with "HPC Hr1 Hr2 Hdst") as "[Hmap (%&%&%&%&%&%)]".
    iApply (wp_AddSubLt with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by erewrite regs_of_is_AddSubLt; eauto; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    destruct Hspec as [| * Hfail].
    { (* Success *)
      iApply "Hφ". iFrame. incrementPC_inv; simplify_map_eq.
      rewrite (insert_commute _ PC dst) // insert_insert (insert_commute _ r2 dst) //
              (insert_commute _ r1 dst) // (insert_commute _ PC dst) // insert_insert.
      iDestruct (regs_of_map_4 with "Hmap") as "(?&?&?&?)"; eauto; iFrame. }
    { (* Failure (contradiction) *)
      destruct Hfail; try incrementPC_inv; simplify_map_eq; eauto.
      destruct e1; try congruence.
      inv Hvpc. destruct H8 as [? | [? | [? | [? | ?]]]]; destruct H15 as [? | [? | ?]]; congruence. }
  Qed.

  Lemma wp_add_sub_lt_success_r_r_same E dst pc_p pc_g pc_b pc_e pc_a w wdst ins r n pc_a' :
    decodeInstrW w = ins →
    is_AddSubLt ins dst (inr r) (inr r) →
    (pc_a + 1)%a = Some pc_a' →
    isCorrectPC (inr (pc_p,pc_g,pc_b,pc_e,pc_a)) ->

    {{{ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a)
        ∗ pc_a ↦ₐ w
        ∗ r ↦ᵣ inl n
        ∗ dst ↦ᵣ wdst
    }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ inr (pc_p,pc_g,pc_b,pc_e,pc_a')
          ∗ pc_a ↦ₐ w
          ∗ r ↦ᵣ inl n
          ∗ dst ↦ᵣ inl (denote ins n n)
      }}}.
  Proof.
    iIntros (Hdecode Hinstr Hpc_a Hvpc ϕ) "(HPC & Hpc_a & Hr & Hdst) Hφ".
    iDestruct (map_of_regs_3 with "HPC Hr Hdst") as "[Hmap (%&%&%)]".
    iApply (wp_AddSubLt with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by erewrite regs_of_is_AddSubLt; eauto; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    destruct Hspec as [| * Hfail].
    { (* Success *)
      iApply "Hφ". iFrame. incrementPC_inv; simplify_map_eq.
      rewrite (insert_commute _ PC dst) // insert_insert (insert_commute _ r dst) //
              (insert_commute _ PC dst) // insert_insert.
      iDestruct (regs_of_map_3 with "Hmap") as "(?&?&?)"; eauto; iFrame. }
    { (* Failure (contradiction) *)
      destruct Hfail; try incrementPC_inv; simplify_map_eq; eauto.
      destruct e1; try congruence.
      inv Hvpc. destruct H5 as [? | [? | [? | [? | ?]]]]; destruct H12 as [? | [? | ?]]; congruence. }
  Qed.

  Lemma wp_add_sub_lt_success_dst_z E dst pc_p pc_g pc_b pc_e pc_a w ins n1 n2 pc_a' :
    decodeInstrW w = ins →
    is_AddSubLt ins dst (inr dst) (inl n2) →
    (pc_a + 1)%a = Some pc_a' →
    isCorrectPC (inr ((pc_p,pc_g),pc_b,pc_e,pc_a)) ->

    {{{ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a)
        ∗ pc_a ↦ₐ w
        ∗ dst ↦ᵣ inl n1
    }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ inr (pc_p,pc_g,pc_b,pc_e,pc_a')
          ∗ pc_a ↦ₐ w
          ∗ dst ↦ᵣ inl (denote ins n1 n2)
      }}}.
  Proof.
    iIntros (Hdecode Hinstr Hpc_a Hvpc ϕ) "(HPC & Hpc_a & Hdst) Hφ".
    iDestruct (map_of_regs_2 with "HPC Hdst") as "[Hmap %]".
    iApply (wp_AddSubLt with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by erewrite regs_of_is_AddSubLt; eauto; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    destruct Hspec as [| * Hfail].
    { (* Success *)
      iApply "Hφ". iFrame. incrementPC_inv; simplify_map_eq.
      rewrite (insert_commute _ PC dst) // insert_insert insert_commute // insert_insert.
      iDestruct (regs_of_map_2 with "Hmap") as "(?&?)"; eauto; iFrame. }
    { (* Failure (contradiction) *)
      destruct Hfail; try incrementPC_inv; simplify_map_eq; eauto.
      destruct e1; try congruence.
      inv Hvpc. destruct H3 as [? | [? | [? | [? | ?]]]]; destruct H10 as [? | [? | ?]]; congruence. }
  Qed.

  Lemma wp_add_sub_lt_success_z_dst E dst pc_p pc_g pc_b pc_e pc_a w ins n1 n2 pc_a' :
    decodeInstrW w = ins →
    is_AddSubLt ins dst (inl n1) (inr dst) →
    (pc_a + 1)%a = Some pc_a' →
    isCorrectPC (inr ((pc_p,pc_g),pc_b,pc_e,pc_a)) ->

    {{{ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a)
        ∗ pc_a ↦ₐ w
        ∗ dst ↦ᵣ inl n2
    }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ inr (pc_p,pc_g,pc_b,pc_e,pc_a')
          ∗ pc_a ↦ₐ w
          ∗ dst ↦ᵣ inl (denote ins n1 n2)
      }}}.
  Proof.
    iIntros (Hdecode Hinstr Hpc_a Hvpc ϕ) "(HPC & Hpc_a & Hdst) Hφ".
    iDestruct (map_of_regs_2 with "HPC Hdst") as "[Hmap %]".
    iApply (wp_AddSubLt with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by erewrite regs_of_is_AddSubLt; eauto; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    destruct Hspec as [| * Hfail].
    { (* Success *)
      iApply "Hφ". iFrame. incrementPC_inv; simplify_map_eq.
      rewrite (insert_commute _ PC dst) // insert_insert insert_commute // insert_insert.
      iDestruct (regs_of_map_2 with "Hmap") as "(?&?)"; eauto; iFrame. }
    { (* Failure (contradiction) *)
      destruct Hfail; try incrementPC_inv; simplify_map_eq; eauto.
      destruct e1; try congruence.
      inv Hvpc. destruct H3 as [? | [? | [? | [? | ?]]]]; destruct H10 as [? | [? | ?]]; congruence. }
  Qed.

  Lemma wp_add_sub_lt_success_dst_r E dst pc_p pc_g pc_b pc_e pc_a w ins n1 r2 n2 pc_a' :
    decodeInstrW w = ins →
    is_AddSubLt ins dst (inr dst) (inr r2) →
    (pc_a + 1)%a = Some pc_a' →
    isCorrectPC (inr (pc_p,pc_g,pc_b,pc_e,pc_a)) ->

    {{{ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a)
        ∗ pc_a ↦ₐ w
        ∗ r2 ↦ᵣ inl n2
        ∗ dst ↦ᵣ inl n1
    }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ inr (pc_p,pc_g,pc_b,pc_e,pc_a')
          ∗ pc_a ↦ₐ w
          ∗ r2 ↦ᵣ inl n2
          ∗ dst ↦ᵣ inl (denote ins n1 n2)
      }}}.
  Proof.
    iIntros (Hdecode Hinstr Hpc_a Hvpc ϕ) "(HPC & Hpc_a & Hr2 & Hdst) Hφ".
    iDestruct (map_of_regs_3 with "HPC Hr2 Hdst") as "[Hmap (%&%&%)]".
    iApply (wp_AddSubLt with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by erewrite regs_of_is_AddSubLt; eauto; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    destruct Hspec as [| * Hfail].
    { (* Success *)
      iApply "Hφ". iFrame. incrementPC_inv; simplify_map_eq.
      rewrite (insert_commute _ PC dst) // insert_insert (insert_commute _ r2 dst) //
              (insert_commute _ PC dst) // insert_insert.
      iDestruct (regs_of_map_3 with "Hmap") as "(?&?&?)"; eauto; iFrame. }
    { (* Failure (contradiction) *)
      destruct Hfail; try incrementPC_inv; simplify_map_eq; eauto.
      destruct e1; try congruence.
      inv Hvpc. destruct H5 as [? | [? | [? | [? | ?]]]]; destruct H12 as [? | [? | ?]]; congruence. }
  Qed.

  Lemma wp_add_sub_lt_success_r_dst E dst pc_p pc_g pc_b pc_e pc_a w ins r1 n1 n2 pc_a' :
    decodeInstrW w = ins →
    is_AddSubLt ins dst (inr r1) (inr dst) →
    (pc_a + 1)%a = Some pc_a' →
    isCorrectPC (inr (pc_p,pc_g,pc_b,pc_e,pc_a)) ->

    {{{ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a)
        ∗ pc_a ↦ₐ w
        ∗ r1 ↦ᵣ inl n1
        ∗ dst ↦ᵣ inl n2
    }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ inr (pc_p,pc_g,pc_b,pc_e,pc_a')
          ∗ pc_a ↦ₐ w
          ∗ r1 ↦ᵣ inl n1
          ∗ dst ↦ᵣ inl (denote ins n1 n2)
      }}}.
  Proof.
    iIntros (Hdecode Hinstr Hpc_a Hvpc ϕ) "(HPC & Hpc_a & Hr2 & Hdst) Hφ".
    iDestruct (map_of_regs_3 with "HPC Hr2 Hdst") as "[Hmap (%&%&%)]".
    iApply (wp_AddSubLt with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by erewrite regs_of_is_AddSubLt; eauto; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    destruct Hspec as [| * Hfail].
    { (* Success *)
      iApply "Hφ". iFrame. incrementPC_inv; simplify_map_eq.
      rewrite (insert_commute _ PC dst) // insert_insert (insert_commute _ r1 dst) //
              (insert_commute _ PC dst) // insert_insert.
      iDestruct (regs_of_map_3 with "Hmap") as "(?&?&?)"; eauto; iFrame. }
    { (* Failure (contradiction) *)
      destruct Hfail; try incrementPC_inv; simplify_map_eq; eauto.
      destruct e1; try congruence.
      inv Hvpc. destruct H5 as [? | [? | [? | [? | ?]]]]; destruct H12 as [? | [? | ?]]; congruence. }
  Qed.

  Lemma wp_add_sub_lt_success_dst_dst E dst pc_p pc_g pc_b pc_e pc_a w ins n pc_a' :
    decodeInstrW w = ins →
    is_AddSubLt ins dst (inr dst) (inr dst) →
    (pc_a + 1)%a = Some pc_a' →
    isCorrectPC (inr (pc_p,pc_g,pc_b,pc_e,pc_a)) ->

    {{{ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a)
        ∗ pc_a ↦ₐ w
        ∗ dst ↦ᵣ inl n
    }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ inr (pc_p,pc_g,pc_b,pc_e,pc_a')
          ∗ pc_a ↦ₐ w
          ∗ dst ↦ᵣ inl (denote ins n n)
      }}}.
  Proof.
    iIntros (Hdecode Hinstr Hpc_a Hvpc ϕ) "(HPC & Hpc_a & Hdst) Hφ".
    iDestruct (map_of_regs_2 with "HPC Hdst") as "[Hmap %]".
    iApply (wp_AddSubLt with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by erewrite regs_of_is_AddSubLt; eauto; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    destruct Hspec as [| * Hfail].
    { (* Success *)
      iApply "Hφ". iFrame. incrementPC_inv; simplify_map_eq.
      rewrite (insert_commute _ PC dst) // insert_insert insert_commute // insert_insert.
      iDestruct (regs_of_map_2 with "Hmap") as "(?&?)"; eauto; iFrame. }
    { (* Failure (contradiction) *)
      destruct Hfail; try incrementPC_inv; simplify_map_eq; eauto.
      destruct e1; try congruence.
      inv Hvpc. destruct H3 as [? | [? | [? | [? | ?]]]]; destruct H10 as [? | [? | ?]]; congruence. }
  Qed.

End cap_lang_rules.

(* Hints to automate proofs of is_AddSubLt *)
Lemma is_AddSubLt_Add dst arg1 arg2 :
  is_AddSubLt (machine_base.Add dst arg1 arg2) dst arg1 arg2.
Proof. intros; unfold is_AddSubLt; eauto. Qed.
Lemma is_AddSubLt_Sub dst arg1 arg2 :
  is_AddSubLt (Sub dst arg1 arg2) dst arg1 arg2.
Proof. intros; unfold is_AddSubLt; eauto. Qed.
Lemma is_AddSubLt_Lt dst arg1 arg2 :
  is_AddSubLt (Lt dst arg1 arg2) dst arg1 arg2.
Proof. intros; unfold is_AddSubLt; eauto. Qed.

Global Hint Resolve is_AddSubLt_Add : core.
Global Hint Resolve is_AddSubLt_Sub : core.
Global Hint Resolve is_AddSubLt_Lt : core.


From mtl.Classes Require Import Monad.

Record Identity (a : Type) : Type :=
  MkIdentity { runIdentity : a }.

Arguments MkIdentity {a} _.
Arguments runIdentity {a} _.

Lemma injective_runIdentity {a} (u v : Identity a)
  : runIdentity u = runIdentity v -> u = v.
Proof.
  destruct u, v; intros; f_equal; auto.
Qed.

Instance Monad_Identity : Monad Identity :=
  { pure _ := MkIdentity
  ; bind _ _ u k := k (runIdentity u)
  }.

Instance LawfulMonad_Identity : LawfulMonad Identity.
Proof.
  split; intros; apply injective_runIdentity; reflexivity.
Qed.


(* PREAMBLE *)

From compcert.common     Require Memory.
From compcert.cfrontend  Require Csem.
From compcert.lib        Require Coqlib.

From trancert.lib        Require All.
From trancert.properties Require memory.Assign Env.

Import Csem Memory Mem Coqlib Tac lib.All Assign properties.Env.

(** [bind_parameters] does not change memory size ([nextblock]). *)

Theorem bind_parameters_nextblock:
  forall ge e1 m1 ps vs m2,
    bind_parameters ge e1 m1 ps vs m2 ->
    nextblock m1 = nextblock m2.
Proof.
  intros ge e1 m1 ps vs m2 H.
  induction H;auto.
  eapply assign_loc_nextblock in H0; eauto.
  rewrite <-IHbind_parameters, H0. reflexivity.
Qed.

Theorem bind_parameters_env_freeable_any:
  forall (ge:genv) e m1 e' params vargs m2,
    env_freeable ge m1 e  ->
    bind_parameters ge e' m1 params vargs m2 ->
    env_freeable ge m2 e.
Proof.
  intros ge e m1 e' params vargs m2 H H0.
  unfold env_freeable in *.
  induction H0; eauto.
  apply IHbind_parameters.
  intros i b0 t0 H3 delta Hdelta.
  eapply assign_loc_perm; eauto.
  eapply H; eauto.
Qed.


From Coq Require Import String HexString ZArith.
From Vyper Require Import Config.
From Vyper.L50 Require Import Types.

Inductive expr {C: VyperConfig}
:= FunCall (name: string) (args: list expr)
 | LocVar (name: string)
 | Const (t: yul_type) (val: yul_value t).

Definition typename: Type := yul_type * string.

Inductive stmt {C: VyperConfig}
:= BlockStmt (s: block)
 | VarDecl (vars: list typename) (init: option expr)
 | Assign (lhs: list string) (rhs: expr)
 | If (cond: expr) (body: block)
 | Expr (e: expr)
 | Switch (e: expr) (cases: list case) (default: option block)
 | For (init: block) (cond: expr) (after body: block)
 | Break
 | Continue
 | Leave
with case  {C: VyperConfig} := Case (t: yul_type) (val: yul_value t) (body: block)
with block {C: VyperConfig} := Block (body: list stmt).

Record fun_decl {C: VyperConfig} := {
  fd_name: string;
  fd_inputs: list typename;
  fd_outputs: list typename;
  fd_body: block;
}.

Definition program {C: VyperConfig}: Type := string_map fun_decl * block.

Definition is_var_decl {C: VyperConfig} (s: stmt)
:= match s with
   | VarDecl _ _ => true
   | _ => false
   end.

Program Definition var_decl_unpack {C: VyperConfig} (s: stmt) (IsVarDecl: is_var_decl s = true)
: list typename * option expr
:= match s with
   | VarDecl vars init => (vars, init)
   | _ => False_rect _ _
   end.
Next Obligation.
destruct s; cbn in IsVarDecl; try discriminate.
exact (H vars init eq_refl).
Qed.

(****************************   print   ******************************)

Local Open Scope list_scope.
Local Open Scope string_scope.

Fixpoint to_comma_list {A} (s: A -> string) (l: list A)
: string
:= match l with
   | nil => ""
   | x :: nil => s x
   | h :: t => s h ++ ", " ++ to_comma_list s t
   end.

Definition string_of_typename (tn: typename)
:= let '(t, n) := tn in
   n ++ ":" ++ string_of_type t.

Definition string_of_yul_value {C: VyperConfig} {t: yul_type} (v: yul_value t)
:= match v with
   | NumberValue _ value _ => HexString.of_Z (Z_of_uint256 value)
   | BoolValue _ true _ => "true"
   | BoolValue _ false _ => "false"
   end.

Fixpoint string_of_expr {C: VyperConfig} (e: expr)
:= match e with
   | FunCall name args => (name ++ "(" ++
                          (* Coq won't allow to_comma_list here *)
                          (fix string_of_exprs (l: list expr) :=
                             match l with
                             | nil => ""
                             | x :: nil => string_of_expr x
                             | h :: t => string_of_expr h ++ ", " ++ string_of_exprs t
                             end) args
                            ++ ")")%string
   | LocVar name => name
   | Const t v => string_of_yul_value v ++ ":" ++ string_of_type t
   end.

Definition attach (a b: list string)
: list string
:= match b with
   | nil => a
   | hb :: tb =>
     let a' := List.rev a in
       match a' with
       | nil => b
       | ha :: ta => List.rev ta ++ (ha ++ " " ++ hb) :: tb
       end
   end.

Fixpoint lines_of_stmt {C: VyperConfig} (s: stmt)
: list string
:= match s with
   | BlockStmt b => lines_of_block b
   | VarDecl vars init => ("let " ++ to_comma_list string_of_typename vars
                             ++ match init with
                                | Some e => " := " ++ string_of_expr e
                                | None => ""
                                end) :: nil
   | Assign lhs rhs => (to_comma_list id lhs ++ " := " ++ string_of_expr rhs) :: nil
   | If cond body => ("if " ++ string_of_expr cond) :: lines_of_block body
   | Expr e => string_of_expr e :: nil
   | Switch e cases default =>
      ("switch " ++ string_of_expr e) ::
      (fix lines_of_cases (l: list case): list string :=
        match l with
        | nil => nil
        | h :: t => (lines_of_case h ++ lines_of_cases t)%list
        end) cases ++
       match default with
       | None => nil
       | Some def => "default" :: lines_of_block def
       end
   | For init cond inc body => attach ("for" :: nil)
                                      (attach (lines_of_block init)
                                              (attach (string_of_expr cond :: nil)
                                                      (lines_of_block inc)))
                                ++ lines_of_block body
   | Break => "break" :: nil
   | Continue => "continue" :: nil
   | Leave => "leave" :: nil
   end
with lines_of_case {C: VyperConfig} (c: case)
: list string
:= let '(Case t v body) := c in
   ("case " ++ string_of_yul_value v ++ ":" ++ string_of_type t) :: lines_of_block body
with lines_of_block {C: VyperConfig} (b: block)
: list string
:= let fix lines_of_stmts (l: list stmt) :=
          match l with
          | nil => nil
          | h :: t => (lines_of_stmt h ++ lines_of_stmts t)%list
          end in
   let '(Block stmts) := b in
   let lines := lines_of_stmts stmts in
   match lines with
   | nil => "{}" :: nil
   | line :: nil => ("{ " ++ line ++ " }") :: nil
   | _ => "{" :: List.map (fun x => "    " ++ x) lines ++ "}" :: nil
   end.

(** Name override is needed because fd_name not properly mangled.
    (Actually fun_decl has no reason to store its name at all.)
 *)
Definition lines_of_fun_decl {C: VyperConfig} (fd: fun_decl) (override_name: string)
:= ("function " ++ override_name ++
      "(" ++ to_comma_list string_of_typename (fd_inputs fd) ++ ")" ++
      match fd_outputs fd with
      | nil => ""
      | _ => " -> " ++ to_comma_list string_of_typename (fd_outputs fd)
      end)
   :: lines_of_block (fd_body fd).

Definition lines_of_fun_decls {C: VyperConfig} (decls: string_map fun_decl)
:= let _ := string_map_impl in
   (fix lines_of_alist (l: list (string * fun_decl))
    := match l with
       | nil => nil
       | h :: t => let '(k, v) := h in (lines_of_fun_decl v k ++ lines_of_alist t)%list
       end) (Map.items decls).


From Undecidability Require Import L.Util.L_facts.

From Undecidability.Shared.Libs.PSL Require Import FinTypes Vectors.
Require Import List.

Require Import Undecidability.TM.Util.TM_facts.

From Undecidability Require Import ProgrammingTools LM_heap_def WriteValue CaseList Copy ListTM Hoare.
From Undecidability.TM.L Require Import JumpTargetTM Alphabets M_LHeapInterpreter.
From Undecidability Require Import L.AbstractMachines.FlatPro.LM_heap_correct.

Require Import List.

Import Vector.VectorNotations.
Import ListNotations ResourceMeasures.

From Undecidability.TM.L Require Import UnfoldClos.

Import CasePair Code.CaseList.

Set Default Proof Using "Type".

Module EvalL.
Section Fix.

  Variable Σ : finType.

  Definition Σintern :Type := sigStep + sigList (sigPair sigHClos sigNat).

  Context (retr_eval : Retract Σintern Σ) (retr_pro : Retract sigPro Σ).

  Definition retr_unfolder : Retract (sigList (sigPair sigHClos sigNat)) Σ := ComposeRetract retr_eval _.
  Definition retr_interpreter : Retract sigStep Σ := ComposeRetract retr_eval _.

  Local Instance retr_closs_intrp : Retract (sigList (sigHClos)) Σ := ComposeRetract retr_interpreter _.
  Local Instance retr_clos_intrp : Retract sigHClos Σ := ComposeRetract retr_closs_intrp _.
  Local Instance retr_pro_intrp : Retract sigPro Σ := ComposeRetract retr_clos_intrp _.

  Local Instance retr_nat_clos_ad' : Retract sigNat sigHClos := Retract_sigPair_X _ (Retract_id _).
  Local Instance retr_nat_clos_ad : Retract sigNat Σ := ComposeRetract _ retr_nat_clos_ad'.
  Local Instance retr_heap : Retract sigHeap Σ := ComposeRetract retr_interpreter _.

  (*
    auxiliary tapes:

    0    : T
    1    : V
    2    : H
    3-4  : aux for init
    5-12 : aux for loop
    13   : t
   *)

  Definition M : pTM (Σ^+) unit 11 :=
    Translate retr_pro retr_pro_intrp @ [|Fin0|];;
    CopyValue _ @ [|Fin0;Fin1|];;
    Reset _ @[|Fin0|];;
    WriteValue 0 ⇑ retr_nat_clos_ad @ [| Fin0|];;
    Constr_pair _ _ ⇑ retr_clos_intrp @ [|Fin0;Fin1|];;
    Reset _ @ [|Fin0|];;
    WriteValue ( []%list) ⇑ retr_closs_intrp @ [| Fin0|];;
    Constr_cons _ ⇑ retr_closs_intrp @ [|Fin0;Fin1|];;
    Reset _ @ [|Fin1|];;
    WriteValue ( []%list) ⇑ retr_closs_intrp @ [| Fin1|];;
    WriteValue ( []%list ) ⇑ retr_heap @ [| Fin2|];;
    M_LHeapInterpreter.Loop ⇑ retr_interpreter;;
    Reset _ @ [|Fin0|];;
    CaseList _ ⇑ retr_closs_intrp @ [| Fin1;Fin0 |];;
    Reset _ @ [|Fin1|];;
    UnfoldClos.M retr_unfolder retr_heap retr_clos_intrp @ [| Fin0;Fin2;Fin1;Fin3;Fin4;Fin5;Fin6;Fin7;Fin8;Fin9|];;
    Reset _ @ [|Fin2|];;
    Translate (UnfoldClos.retr_pro _) retr_pro @ [|Fin0|].

  Arguments "+" : simpl never.
  Arguments "*" : simpl never.

  Definition steps (s : term) (k:nat) (t:term) Hcl (HR:evalIn k s t):=
    1 + Translate_steps (compile s) +
    (1 + CopyValue_steps (compile s) +
    (1 + Reset_steps (compile s) +
      (1 + WriteValue_steps (size 0) +
      (1 + Constr_pair_steps 0 +
        (1 + Reset_steps 0 +
        (1 + WriteValue_steps (size []%list) +
          (1 + Constr_cons_steps (0, compile s) +
          (1 + Reset_steps (0, compile s) +
            (1 + WriteValue_steps (size []%list) +
            (1 + WriteValue_steps (size []%list) +
              (1 + Loop_steps [(0, compile s)] [] []%list (3 * k + 1) +
              (1 + Reset_steps []%list +
                let (g,tmp) := completenessTimeInformative (proj2 (timeBS_evalIn _ _ _) HR) Hcl in
                let (H,_):= tmp in
                (1 + CaseList_steps [g] +
                (1 + Reset_steps []%list +
                  (1 + UnfoldClos.steps H g t +
                  (1 + Reset_steps H + Translate_steps (compile t))))))))))))))))).
  Arguments steps : clear implicits.

  Lemma SpecT s k t (Hcl: closed s) (HR:evalIn k s t):
    TripleT ≃≃([],[|Contains retr_pro (compile s)|] ++ Vector.const Void _)
      (steps s k t Hcl HR) M
      (fun _ => ≃≃([],[|Contains retr_pro (compile t)|] ++ Vector.const Void _)).
  Proof.
    unfold steps. destruct completenessTimeInformative as (g&H&?&?). clear HR.
    eapply ConsequenceT_pre. 2:reflexivity.
    unfold M.
    do 11 (hstep_seq;[]). cbn.
    hstep_seq;[| | ] .
    { refine (TripleT_RemoveSpace _). intros. eapply Interpreter_SpecT. eassumption. inversion 1. }
    now cbn; tspec_ext.
    do 2 (hstep_seq;[]).
    hintros _ _.
    hstep_seq;[].
    hstep_seq;[|].
    { eapply UnfoldClos.SpecT. eassumption. }
    cbn.
    do 2 (hstep_seq;[]). reflexivity.
    unfold steps. reflexivity.
  Qed.

  Lemma Spec s :
   closed s ->
    Triple ≃≃([],[|Contains retr_pro (compile s)|] ++ Vector.const Void _)
      M
      (fun _ t => exists s', t ≃≃ ([s ⇓ s']%list,[|Contains retr_pro (compile s')|] ++ Vector.const Void _)).
  Proof.
    intros cls.
    unfold M.
    do 11 (hstep_seq;[]). cbn.
    hstep.
    {
      eapply Consequence with (Q1:= fun y => _) (Q2:= fun y => _).
      eapply ChangeAlphabet_Spec_ex with (Q:= fun y x => _) (Q':= fun y x => _) (Ctx:= fun x (H:Prop) => (steps_k (snd x) _ (fst x) /\ halt_state (fst x)) /\
        (fst (fst (fst x)) = []%list ->
        H)).
      now refine (Interpreter_Spec [(0,compile s)] [] [])%list. now unfold "==>",Proper,Basics.impl. now cbn; tspec_ext. cbn;intros _. apply reflexivity.
    }
    cbn. intros _.
    eapply Triple_exists_pre. intros [[[T' V'] H'] k'];cbn.
    eapply Triple_and_pre. intros [HR Hhalt].
    unfold steps_k in*.
    edestruct soundness with (1:=cls) as (?&?&?&Heq&?&?). {split. now eapply pow_star. eassumption. }
    injection Heq as [= -> -> ->].
    eapply Triple_forall_pre. exists eq_refl.
    do 2 (hstep_seq;[]).
    hintros ? _.
    do 2 hstep_seq;[|].
    { refine (TripleT_Triple _). refine (UnfoldClos.SpecT _ _ _ _). eassumption. }
    cbn.
    hstep_seq.
    eapply Triple_exists_con. eexists _.
    change (fun x => ?h x) with h.
    eapply Consequence_post.
    now hsteps_cbn.
    cbn. intros _. tspec_ext. easy.
  Qed.

End Fix.
End EvalL.