Require Import Verdi.Verdi.
Require Import Verdi.LabeledNet.
Require Import Verdi.TotalMapSimulations.

Require Import InfSeqExt.infseq.
Require Import InfSeqExt.map.
Require Import InfSeqExt.exteq.

Require Import FunctionalExtensionality.

Local Arguments update {_} {_} _ _ _ _ _ : simpl never.

Require Import Verdi.Ssrexport.

Set Implicit Arguments.

Class LabeledMultiParamsLabelTotalMap
 (B0 : BaseParams) (B1 : BaseParams)
 (P0 : LabeledMultiParams B0) (P1 : LabeledMultiParams B1) :=
  {
    tot_map_label : @label B0 P0 -> @label B1 P1
  }.

Section LabeledTotalMapDefs.

Context {base_fst : BaseParams}.
Context {base_snd : BaseParams}.
Context {labeled_multi_fst : LabeledMultiParams base_fst}.
Context {labeled_multi_snd : LabeledMultiParams base_snd}.
Context {label_map : LabeledMultiParamsLabelTotalMap labeled_multi_fst labeled_multi_snd}.

Definition tot_mapped_lb_net_handlers_label me src m st :=
  let '(lb, out, st', ps) := lb_net_handlers me src m st in tot_map_label lb.

Definition tot_mapped_lb_input_handlers_label me inp st :=
  let '(lb, out, st', ps) := lb_input_handlers me inp st in tot_map_label lb.

End LabeledTotalMapDefs.

Class LabeledMultiParamsTotalMapCongruency
  (B0 : BaseParams) (B1 : BaseParams)
  (P0 : LabeledMultiParams B0) (P1 : LabeledMultiParams B1)
  (B : BaseParamsTotalMap B0 B1)
  (N : MultiParamsNameTotalMap (@unlabeled_multi_params _ P0) (@unlabeled_multi_params _ P1))
  (P : MultiParamsMsgTotalMap (@unlabeled_multi_params _ P0) (@unlabeled_multi_params _ P1))
  (L : LabeledMultiParamsLabelTotalMap P0 P1) : Prop :=
  {
    tot_lb_net_handlers_eq : forall me src m st out st' ps lb,
      lb_net_handlers (tot_map_name me) (tot_map_name src) (tot_map_msg m) (tot_map_data st) = (lb, out, st', ps)  ->
      tot_mapped_lb_net_handlers_label me src m st = lb ;
    tot_lb_input_handlers_eq : forall me inp st out st' ps lb,
      lb_input_handlers (tot_map_name me) (tot_map_input inp) (tot_map_data st) = (lb, out, st', ps) ->
      tot_mapped_lb_input_handlers_label me inp st = lb ;
    tot_lb_label_silent_fst_snd : tot_map_label label_silent = label_silent
  }.

Section TotalMapExecutionSimulations.

Context {base_fst : BaseParams}.
Context {base_snd : BaseParams}.
Context {labeled_multi_fst : LabeledMultiParams base_fst}.
Context {labeled_multi_snd : LabeledMultiParams base_snd}.
Context {base_map : BaseParamsTotalMap base_fst base_snd}.
Context {name_map : MultiParamsNameTotalMap (@unlabeled_multi_params _ labeled_multi_fst) (@unlabeled_multi_params _ labeled_multi_snd)}.
Context {msg_map : MultiParamsMsgTotalMap (@unlabeled_multi_params _ labeled_multi_fst) (@unlabeled_multi_params _ labeled_multi_snd)}.
Context {label_map : LabeledMultiParamsLabelTotalMap labeled_multi_fst labeled_multi_snd}.
Context {name_map_bijective : MultiParamsNameTotalMapBijective name_map}.
Context {multi_map_congr : MultiParamsTotalMapCongruency base_map name_map msg_map}.
Context {multi_map_lb_congr : LabeledMultiParamsTotalMapCongruency base_map name_map msg_map label_map}.

Hypothesis tot_map_label_injective :
  forall l l', tot_map_label l = tot_map_label l' -> l = l'.

(* lb_step_failure *)

Theorem lb_step_failure_tot_mapped_simulation_1 :
  forall net net' failed failed' lb tr,
    @lb_step_failure _ labeled_multi_fst (failed, net) lb (failed', net') tr ->
    @lb_step_failure _ labeled_multi_snd (List.map tot_map_name failed, tot_map_net net) (tot_map_label lb) (List.map tot_map_name failed', tot_map_net net') (List.map tot_map_trace_occ tr).
Proof using name_map_bijective multi_map_lb_congr multi_map_congr.
move => net net' failed failed' lb tr H_step.
invcs H_step => //=.
- have ->: tot_map_name (pDst p) = pDst (tot_map_packet p) by destruct p.
  apply: (@LabeledStepFailure_deliver _ _ _ _ _ _ (List.map tot_map_packet xs) (List.map tot_map_packet ys) (List.map tot_map_output out) (tot_map_data d) (@tot_map_name_msgs _ _ _ _ _ msg_map l)).
  * rewrite /tot_map_net /=.
    find_rewrite.
    by rewrite map_app.
  * destruct p.
    simpl in *.
    exact: not_in_failed_not_in.
  * destruct p.
    simpl in *.
    rewrite tot_map_name_inv_inverse.
    have H_q := @tot_net_handlers_eq _ _ _ _ _ _ _ multi_map_congr pDst pSrc pBody (nwState net pDst).
    rewrite /tot_mapped_net_handlers /net_handlers /= /unlabeled_net_handlers in H_q.
    repeat break_let.
    repeat tuple_inversion.
    have H_q' := @tot_lb_net_handlers_eq _ _ _ _ _ _ _ _ multi_map_lb_congr _ _ _ _ _ _ _ _ Heqp1.
    rewrite /tot_mapped_lb_net_handlers_label in H_q'.
    repeat break_let.
    by repeat tuple_inversion.
  * rewrite /tot_map_net /= 2!map_app -(@tot_map_update_packet_eq _ _ _ _ _ _ _ name_map_bijective).
    destruct p.
    by rewrite tot_map_packet_map_eq.
- apply: (@LabeledStepFailure_input _ _ _ _ _ _ _ _ (tot_map_data d) (tot_map_name_msgs l)).
  * exact: not_in_failed_not_in.
  * rewrite /tot_map_net /= tot_map_name_inv_inverse.
    have H_q := @tot_input_handlers_eq _ _ _ _ _ _ _ multi_map_congr h inp (nwState net h).
    rewrite /tot_mapped_input_handlers /= /unlabeled_input_handlers in H_q.
    repeat break_let.
    repeat tuple_inversion.
    have H_q' := @tot_lb_input_handlers_eq _ _ _ _ _ _ _ _ multi_map_lb_congr _ _ _ _ _ _ _ Heqp1.
    rewrite /tot_mapped_lb_input_handlers_label in H_q'.
    repeat break_let.
    by repeat tuple_inversion.
  * by rewrite /tot_map_net /= map_app tot_map_packet_map_eq -(@tot_map_update_eq _ _ _ _ _ _ name_map_bijective).
- rewrite tot_lb_label_silent_fst_snd.
  exact: LabeledStepFailure_stutter.
Qed.

Definition tot_map_net_event e :=
{| evt_a := (List.map tot_map_name (fst e.(evt_a)), tot_map_net (snd e.(evt_a))) ;
   evt_l := tot_map_label e.(evt_l) ;
   evt_trace := List.map tot_map_trace_occ e.(evt_trace) |}.

Lemma tot_map_net_event_map_unfold : forall s,
 Cons (tot_map_net_event (hd s)) (map tot_map_net_event (tl s)) = map tot_map_net_event s.
Proof using.
by move => s; rewrite -map_Cons /= -{3}(recons s).
Qed.

Lemma lb_step_trace_execution_lb_step_failure_tot_map_net_infseq : forall s,
  lb_step_execution lb_step_failure s ->
  lb_step_execution lb_step_failure (map tot_map_net_event s).
Proof using name_map_bijective multi_map_lb_congr multi_map_congr.
cofix c.
move => s H_exec.
rewrite -tot_map_net_event_map_unfold {1}/tot_map_net_event /=.
inversion H_exec; subst => /=.
rewrite -tot_map_net_event_map_unfold /= /tot_map_net_event /=.
apply: (@Cons_lb_step_exec _ _ _ _ _ _ (List.map tot_map_trace_occ tr)) => /=.
- apply: lb_step_failure_tot_mapped_simulation_1.
  have <-: evt_a e = (fst (evt_a e), snd (evt_a e)) by destruct e, evt_a.
  by have <-: evt_a e' = (fst (evt_a e'), snd (evt_a e')) by destruct e', evt_a.
- simpl in *.
  find_rewrite.
  by rewrite map_app.
- set e0 := {| evt_a := _ ; evt_l := _ ; evt_trace := _ |}.
  have ->: e0 = tot_map_net_event e' by [].
  pose s' := Cons e' s0.
  rewrite (tot_map_net_event_map_unfold s').
  exact: c.
Qed.

Lemma tot_map_net_label_event_inf_often_occurred :
  forall l s,
    inf_often (now (occurred l)) s ->
    inf_often (now (occurred (tot_map_label l))) (map tot_map_net_event s).
Proof using.
move => l.
apply: always_map.
apply: eventually_map.
case => e s.
rewrite /= /occurred /=.
move => H_eq.
by rewrite H_eq.
Qed.

Lemma tot_map_net_label_event_inf_often_occurred_conv :
  forall l s,
    inf_often (now (occurred (tot_map_label l))) (map tot_map_net_event s) ->
    inf_often (now (occurred l)) s.
Proof using tot_map_label_injective.
move => l.
apply: always_map_conv.
apply: eventually_map_conv => //.
- rewrite /extensional /=.
  case => e s1.
  case => e' s2.
  move => H_eq.
  by inversion H_eq; subst_max.
- rewrite /extensional /=.
  case => e s1.
  case => e' s2.
  move => H_eq.
  by inversion H_eq; subst_max.
- case => e s.
  rewrite /= /occurred /=.
  move => H_eq.
  exact: tot_map_label_injective.
Qed.

Context {fail_fst : FailureParams (@unlabeled_multi_params _ labeled_multi_fst)}.
Context {fail_snd : FailureParams (@unlabeled_multi_params _ labeled_multi_snd)}.
Context {fail_map_congr : FailureParamsTotalMapCongruency fail_fst fail_snd base_map}.

Lemma tot_map_net_hd_step_failure_star_always :
  forall s, event_step_star step_failure step_failure_init (hd s) ->
       lb_step_execution lb_step_failure s ->
       always (now (event_step_star step_failure step_failure_init)) (map tot_map_net_event s).
Proof using name_map_bijective multi_map_lb_congr multi_map_congr fail_map_congr.
case => e s H_star H_exec.
apply: step_failure_star_lb_step_execution.
  rewrite /=.
  rewrite /tot_map_net_event /= /event_step_star /=.
  apply: step_failure_tot_mapped_simulation_star_1.
  by have <-: evt_a e = (fst (evt_a e), snd (evt_a e)) by destruct e, evt_a.
exact: lb_step_trace_execution_lb_step_failure_tot_map_net_infseq.
Qed.

(* lb_step_ordered_failure *)

Theorem lb_step_ordered_failure_tot_mapped_simulation_1 :
  forall net net' failed failed' lb tr,
    @lb_step_ordered_failure _ labeled_multi_fst (failed, net) lb (failed', net') tr ->
    @lb_step_ordered_failure _ labeled_multi_snd (List.map tot_map_name failed, tot_map_onet net) (tot_map_label lb) (List.map tot_map_name failed', tot_map_onet net') (List.map tot_map_trace tr).
Proof using name_map_bijective multi_map_lb_congr multi_map_congr.
move => net net' failed failed' lb tr H_step.
invcs H_step => //=.
- apply (@LabeledStepOrderedFailure_deliver _ _ _ _ _ _ (@tot_map_msg _ _ _ _ msg_map m) (List.map (@tot_map_msg _ _ _ _ msg_map) ms) (List.map tot_map_output out) (tot_map_data d) (@tot_map_name_msgs _ _ _ _ _ msg_map l) (@tot_map_name _ _ _ _ name_map from) (@tot_map_name _ _ _ _ name_map to)) => //=.
  * rewrite /tot_map_onet /=.
    rewrite 2!tot_map_name_inv_inverse.
    by find_rewrite.
  * exact: not_in_failed_not_in.
  * rewrite /tot_map_onet /= tot_map_name_inv_inverse.
    have H_q := @tot_net_handlers_eq _ _ _ _ _ _ _ multi_map_congr to from m (onwState net to).
    rewrite /tot_mapped_net_handlers /net_handlers /= /unlabeled_net_handlers in H_q.
    repeat break_let.
    repeat tuple_inversion.
    have H_q' := @tot_lb_net_handlers_eq _ _ _ _ _ _ _ _ multi_map_lb_congr _ _ _ _ _ _ _ _ Heqp1.
    rewrite /tot_mapped_lb_net_handlers_label in H_q'.
    repeat break_let.
    by repeat tuple_inversion.
  * rewrite /tot_map_onet /=.
    rewrite (@collate_tot_map_update2_eq _ _ _ _ _ _ name_map_bijective).
    set f1 := fun _ => tot_map_data _.
    set f2 := update _ _ _ _.
    have H_eq_f: f1 = f2.
      rewrite /f1 /f2.
      apply functional_extensionality => n.
      rewrite /update.
      break_if; break_if => //; first by rewrite -e tot_map_name_inverse_inv in n0.
      by rewrite e tot_map_name_inv_inverse in n0.
    by rewrite H_eq_f.
  * by rewrite (@map_tot_map_trace_eq _ _ _ _ _ name_map).
- rewrite /tot_map_onet /=.
  apply (@LabeledStepOrderedFailure_input _ _ (@tot_map_name _ _ _ _ name_map h) _ _ _ _ (List.map tot_map_output out) (tot_map_input inp) (tot_map_data d) (@tot_map_name_msgs _ _ _ _ _ msg_map l)).
  * exact: not_in_failed_not_in.
  * rewrite /tot_map_onet /= tot_map_name_inv_inverse.
    have H_q := @tot_input_handlers_eq _ _ _ _ _ _ _ multi_map_congr h inp (onwState net h).
    rewrite /tot_mapped_input_handlers /= /unlabeled_input_handlers in H_q.
    repeat break_let.
    repeat tuple_inversion.
    have H_q' := @tot_lb_input_handlers_eq _ _ _ _ _ _ _ _ multi_map_lb_congr _ _ _ _ _ _ _ Heqp1.
    rewrite /tot_mapped_lb_input_handlers_label in H_q'.
    repeat break_let.
    by repeat tuple_inversion.
  * rewrite /tot_map_onet /=.
    rewrite (@collate_tot_map_eq _ _ _ _ _ _ name_map_bijective).
    set f1 := fun _ => tot_map_data _.
    set f2 := update _ _ _ _.
    have H_eq_f: f1 = f2.
      rewrite /f1 /f2.
      apply functional_extensionality => n.
      rewrite /update.
      break_if; break_if => //; first by rewrite -e tot_map_name_inverse_inv in n0.
      by rewrite e tot_map_name_inv_inverse in n0.
    by rewrite H_eq_f.
  * by rewrite (@map_tot_map_trace_eq _ _ _ _ _ name_map).
- rewrite tot_lb_label_silent_fst_snd.
  exact: LabeledStepOrderedFailure_stutter.
Qed.

Definition tot_map_onet_event e :=
{| evt_a := (List.map tot_map_name (fst e.(evt_a)), tot_map_onet (snd e.(evt_a))) ;
   evt_l := tot_map_label e.(evt_l) ;
   evt_trace := List.map tot_map_trace e.(evt_trace) |}.

Lemma tot_map_onet_event_map_unfold : forall s,
 Cons (tot_map_onet_event (hd s)) (map tot_map_onet_event (tl s)) = map tot_map_onet_event s.
Proof using.
by move => s; rewrite -map_Cons /= -{3}(recons s).
Qed.

Lemma lb_step_execution_lb_step_ordered_failure_tot_map_onet_infseq : forall s,
  lb_step_execution lb_step_ordered_failure s ->
  lb_step_execution lb_step_ordered_failure (map tot_map_onet_event s).
Proof using name_map_bijective multi_map_lb_congr multi_map_congr.
cofix c.
move => s H_exec.
rewrite -tot_map_onet_event_map_unfold {1}/tot_map_onet_event /=.
inversion H_exec; subst => /=.
rewrite -tot_map_onet_event_map_unfold /= /tot_map_onet_event /=.
apply: (@Cons_lb_step_exec _ _ _ _ _ _ (List.map tot_map_trace tr)) => /=.
- apply: lb_step_ordered_failure_tot_mapped_simulation_1.
  have <-: evt_a e = (fst (evt_a e), snd (evt_a e)) by destruct e, evt_a.
  by have <-: evt_a e' = (fst (evt_a e'), snd (evt_a e')) by destruct e', evt_a.
- simpl in *.
  find_rewrite.
  by rewrite map_app.
- set e0 := {| evt_a := _ ; evt_l := _ ; evt_trace := _ |}.
  have ->: e0 = tot_map_onet_event e' by [].
  pose s' := Cons e' s0.
  rewrite (tot_map_onet_event_map_unfold s').
  exact: c.
Qed.

Lemma tot_map_onet_label_event_inf_often_occurred :
  forall l s,
    inf_often (now (occurred l)) s ->
    inf_often (now (occurred (tot_map_label l))) (map tot_map_onet_event s).
Proof using.
move => l.
apply: always_map.
apply: eventually_map.
case => e s.
rewrite /= /occurred /=.
move => H_eq.
by rewrite H_eq.
Qed.

Lemma tot_map_onet_label_event_inf_often_occurred_conv :
  forall l s,
    inf_often (now (occurred (tot_map_label l))) (map tot_map_onet_event s) ->
    inf_often (now (occurred l)) s.
Proof using tot_map_label_injective.
move => l.
apply: always_map_conv.
apply: eventually_map_conv => //.
- rewrite /extensional /=.
  case => e s1.
  case => e' s2.
  move => H_eq.
  by inversion H_eq; subst_max.
- rewrite /extensional /=.
  case => e s1.
  case => e' s2.
  move => H_eq.
  by inversion H_eq; subst_max.
- case => e s.
  rewrite /= /occurred /=.
  move => H_eq.
  exact: tot_map_label_injective.
Qed.

Context {overlay_fst : NameOverlayParams (@unlabeled_multi_params _ labeled_multi_fst)}.
Context {overlay_snd : NameOverlayParams (@unlabeled_multi_params _ labeled_multi_snd)}.
Context {overlay_map_congr : NameOverlayParamsTotalMapCongruency overlay_fst overlay_snd name_map}.

Context {fail_msg_fst : FailMsgParams (@unlabeled_multi_params _ labeled_multi_fst)}.
Context {fail_msg_snd : FailMsgParams (@unlabeled_multi_params _ labeled_multi_snd)}.
Context {fail_msg_map_congr : FailMsgParamsTotalMapCongruency fail_msg_fst fail_msg_snd msg_map}.

Lemma tot_map_onet_hd_step_ordered_failure_star_always :
  forall s, event_step_star step_ordered_failure step_ordered_failure_init (hd s) ->
       lb_step_execution lb_step_ordered_failure s ->
       always (now (event_step_star step_ordered_failure step_ordered_failure_init)) (map tot_map_onet_event s).
Proof using overlay_map_congr name_map_bijective multi_map_lb_congr multi_map_congr fail_msg_map_congr.
case => e s H_star H_exec.
apply: step_ordered_failure_star_lb_step_execution; last exact: lb_step_execution_lb_step_ordered_failure_tot_map_onet_infseq.
rewrite /= /tot_map_onet_event /= /event_step_star /=.
apply: step_ordered_failure_tot_mapped_simulation_star_1.
by have <-: evt_a e = (fst (evt_a e), snd (evt_a e)) by destruct e, evt_a.
Qed.

(* lb_step_ordered_dynamic_failure *)

Theorem lb_step_ordered_dynamic_failure_tot_mapped_simulation_1 :
  forall net net' failed failed' lb tr,
    @lb_step_ordered_dynamic_failure _ labeled_multi_fst (failed, net) lb (failed', net') tr ->
    @lb_step_ordered_dynamic_failure _ labeled_multi_snd (List.map tot_map_name failed, tot_map_odnet net) (tot_map_label lb) (List.map tot_map_name failed', tot_map_odnet net') (List.map tot_map_trace tr).
Proof using name_map_bijective multi_map_lb_congr multi_map_congr.
move => net net' failed failed' lb tr H_step.
invcs H_step => //=.
- rewrite /tot_map_odnet /=.
  apply (@LabeledStepOrderedDynamicFailure_deliver _ _ _ _ _ _ (@tot_map_msg _ _ _ _ msg_map m) (List.map (@tot_map_msg _ _ _ _ msg_map) ms) (List.map tot_map_output out) (tot_map_data d) (tot_map_data d') (@tot_map_name_msgs _ _ _ _ _ msg_map l) (@tot_map_name _ _ _ _ name_map from) (@tot_map_name _ _ _ _ name_map to)) => //=.
  * exact: not_in_failed_not_in.
  * exact: in_failed_in.
  * rewrite tot_map_name_inv_inverse.
    by find_rewrite.
  * rewrite 2!tot_map_name_inv_inverse.
    by find_rewrite.
  * have H_q := @tot_net_handlers_eq _ _ _ _ _ _ _ multi_map_congr to from m d.
    rewrite /tot_mapped_net_handlers /net_handlers /= /unlabeled_net_handlers in H_q.
    repeat break_let.
    repeat tuple_inversion.
    have H_q' := @tot_lb_net_handlers_eq _ _ _ _ _ _ _ _ multi_map_lb_congr _ _ _ _ _ _ _ _ Heqp1.
    rewrite /tot_mapped_lb_net_handlers_label in H_q'.
    repeat break_let.
    by repeat tuple_inversion.
  * rewrite (@collate_tot_map_update2_eq _ _ _ _ _ _ name_map_bijective).
    set f1 := fun _ => match _ with _ => _ end.
    set f2 := update _ _ _ _.
    have H_eq_f: f1 = f2.
      rewrite /f1 /f2 /update.
      apply functional_extensionality => dst.
      repeat break_if => //=; first by rewrite -e tot_map_name_inverse_inv in n.
      by rewrite e tot_map_name_inv_inverse in n.
    by rewrite H_eq_f.
  * by rewrite (@map_tot_map_trace_eq _ _ _ _ _ name_map).
- rewrite /tot_map_odnet /=.
  apply (@LabeledStepOrderedDynamicFailure_input _ _ (@tot_map_name _ _ _ _ name_map h) _ _ _ _ (List.map tot_map_output out) (tot_map_input inp) (tot_map_data d) (tot_map_data d') (@tot_map_name_msgs _ _ _ _ _ msg_map l)) => //=.
  * exact: not_in_failed_not_in.
  * exact: in_failed_in.
  * rewrite tot_map_name_inv_inverse.
    by find_rewrite.
  * have H_q := @tot_input_handlers_eq _ _ _ _ _ _ _ multi_map_congr h inp d.
    rewrite /tot_mapped_input_handlers /= /unlabeled_input_handlers in H_q.
    repeat break_let.
    repeat tuple_inversion.
    have H_q' := @tot_lb_input_handlers_eq _ _ _ _ _ _ _ _ multi_map_lb_congr _ _ _ _ _ _ _ Heqp1.
    rewrite /tot_mapped_lb_input_handlers_label in H_q'.
    repeat break_let.
    by repeat tuple_inversion.
  * rewrite (@collate_tot_map_eq _ _ _ _ _ _ name_map_bijective).
    set f1 := fun _ => match _ with _ => _ end.
    set f2 := update _ _ _ _.
    have H_eq_f: f1 = f2.
      rewrite /f1 /f2 /update.
      apply functional_extensionality => n.
      repeat break_match; try by congruence.
      * by rewrite e tot_map_name_inv_inverse in n0.
      * by rewrite -e tot_map_name_inverse_inv in n0.
      * by rewrite e tot_map_name_inv_inverse in n0.
    by rewrite H_eq_f.
  * by rewrite (@map_tot_map_trace_eq _ _ _ _ _ name_map).
- rewrite tot_lb_label_silent_fst_snd.
  exact: LabeledStepOrderedDynamicFailure_stutter.
Qed.

Definition tot_map_odnet_event e :=
{| evt_a := (List.map tot_map_name (fst e.(evt_a)), tot_map_odnet (snd e.(evt_a))) ;
   evt_l := tot_map_label e.(evt_l) ;
   evt_trace := List.map tot_map_trace e.(evt_trace) |}.

Lemma tot_map_odnet_event_map_unfold : forall s,
 Cons (tot_map_odnet_event (hd s)) (map tot_map_odnet_event (tl s)) = map tot_map_odnet_event s.
Proof using.
by move => s; rewrite -map_Cons /= -{3}(recons s).
Qed.

Lemma lb_step_execution_lb_step_ordered_dynamic_failure_tot_map_odnet_infseq : forall s,
  lb_step_execution lb_step_ordered_dynamic_failure s ->
  lb_step_execution lb_step_ordered_dynamic_failure (map tot_map_odnet_event s).
Proof using name_map_bijective multi_map_lb_congr multi_map_congr.
cofix c.
move => s H_exec.
rewrite -tot_map_odnet_event_map_unfold {1}/tot_map_odnet_event /=.
inversion H_exec; subst => /=.
rewrite -tot_map_odnet_event_map_unfold /= /tot_map_odnet_event /=.
apply: (@Cons_lb_step_exec _ _ _ _ _ _ (List.map tot_map_trace tr)) => /=.
- apply: lb_step_ordered_dynamic_failure_tot_mapped_simulation_1.
  have <-: evt_a e = (fst (evt_a e), snd (evt_a e)) by destruct e, evt_a.
  by have <-: evt_a e' = (fst (evt_a e'), snd (evt_a e')) by destruct e', evt_a.
- simpl in *.
  find_rewrite.
  by rewrite map_app.
- set e0 := {| evt_a := _ ; evt_l := _ ; evt_trace := _ |}.
  have ->: e0 = tot_map_odnet_event e' by [].
  pose s' := Cons e' s0.
  rewrite (tot_map_odnet_event_map_unfold s').
  exact: c.
Qed.

Lemma tot_map_odnet_label_event_inf_often_occurred :
  forall l s,
    inf_often (now (occurred l)) s ->
    inf_often (now (occurred (tot_map_label l))) (map tot_map_odnet_event s).
Proof using.
move => l.
apply: always_map.
apply: eventually_map.
case => e s.
rewrite /= /occurred /=.
move => H_eq.
by rewrite H_eq.
Qed.

Lemma tot_map_odnet_label_event_inf_often_occurred_conv :
  forall l s,
    inf_often (now (occurred (tot_map_label l))) (map tot_map_odnet_event s) ->
    inf_often (now (occurred l)) s.
Proof using tot_map_label_injective.
move => l.
apply: always_map_conv.
apply: eventually_map_conv => //.
- rewrite /extensional /=.
  case => e s1.
  case => e' s2.
  move => H_eq.
  by inversion H_eq; subst_max.
- rewrite /extensional /=.
  case => e s1.
  case => e' s2.
  move => H_eq.
  by inversion H_eq; subst_max.
- case => e s.
  rewrite /= /occurred /=.
  move => H_eq.
  exact: tot_map_label_injective.
Qed.

Context {new_msg_fst : NewMsgParams (@unlabeled_multi_params _ labeled_multi_fst)}.
Context {new_msg_snd : NewMsgParams (@unlabeled_multi_params _ labeled_multi_snd)}.
Context {new_msg_map_congr : NewMsgParamsTotalMapCongruency new_msg_fst new_msg_snd msg_map}.

Lemma tot_map_odnet_hd_step_ordered_dynamic_failure_star_always :
  forall s, event_step_star step_ordered_dynamic_failure step_ordered_dynamic_failure_init (hd s) ->
       lb_step_execution lb_step_ordered_dynamic_failure s ->
       always (now (event_step_star step_ordered_dynamic_failure step_ordered_dynamic_failure_init)) (map tot_map_odnet_event s).
Proof using overlay_map_congr new_msg_map_congr name_map_bijective multi_map_lb_congr multi_map_congr fail_msg_map_congr.
case => e s H_star H_exec.
apply: step_ordered_dynamic_failure_star_lb_step_execution; last exact: lb_step_execution_lb_step_ordered_dynamic_failure_tot_map_odnet_infseq.
rewrite /= /tot_map_odnet_event /= /event_step_star /=.
apply: step_ordered_dynamic_failure_tot_mapped_simulation_star_1.
by have <-: evt_a e = (fst (evt_a e), snd (evt_a e)) by destruct e, evt_a.
Qed.

End TotalMapExecutionSimulations.


Require Import msl.msl_standard.
Require Import msl.Coqlib2.
Require Import msl.rmaps.
Require Import msl.rmaps_lemmas.
Require Import language.
Require Import seplogic.

Hint Extern 3 (list_nodups _ = true) => (compute; reflexivity).
Hint Extern 3 (typecheck _ _ = true) => (compute; reflexivity).
Hint Extern 3 (expcheck _ _ = true) => (compute; reflexivity).
Hint Resolve andb_true_intro.

Obligation Tactic := idtac.

Module Semax : SEMAX.

Local Open Scope pred.

(******  CONSTRUCTION OF rmap FOR THE CONT LANGUAGE *****)
Inductive kind := VAL: adr -> kind | FUN: list var -> kind.

Module AV0 <: ADR_VAL0.
 Definition address := adr.
 Definition some_address := 0.
 Definition kind := kind.
End AV0.

Module AV := SimpleAdrVal AV0.
Module R := Rmaps AV.
Module RML := Rmaps_Lemmas R.
Export RML. Export R.
Instance Cross_rmap : Cross_alg rmap := Cross_rmap_simple (fun _ => I).

Obligation Tactic := idtac.

(******  MAPSTO AND RELATED OPERATORS *****)

Program Definition mapsto (v1 v2: adr) : pred rmap :=
  fun w => forall i,
         if eq_dec i v1 then w @ i = YES pfullshare (VAL v2) NoneP else identity (w @ i).
Next Obligation.
 intros. intros ? ? ? ?.
  intro i; specialize (H0 i).
  destruct (eq_dec i v1).
  apply (age1_YES _ _ _ _ _ H); auto.
  destruct (identity_resource (a @ i)) as [? _]. specialize (H1 H0).
  apply identity_resource.
  generalize (age1_resource_at _ _ H i (a @ i)); intro.
  generalize (resource_at_approx a i); intro.
  destruct (a @ i); try contradiction.
  rewrite H2; simpl in *; auto.
  rewrite H2; simpl in *; auto.
Qed.

Lemma mapsto_conflict:
   forall a b c, mapsto a b  *  mapsto a c |-- FF.
  Proof.
    intros.
    intros w  [w1 [w2 [? [? ?]]]]; hnf.
    specialize (H0 a). specialize (H1 a).
    rewrite if_true in * by auto.
    apply (resource_at_join _ _ _ a) in H.
    rewrite H0 in H; rewrite H1 in H; inv H.
    pfullshare_join.
 Qed.

Lemma singleton_rmap_OK:
   forall v v' m,
       resource_fmap (approx (level m))
            oo (fun i => if eq_dec i v then YES pfullshare (VAL v') NoneP else core m @  i) =
    (fun i => if eq_dec i v then YES pfullshare (VAL v') NoneP else core m @ i).
Proof.
  intros; extensionality i; unfold compose; simpl.
  destruct (eq_dec i v).
  unfold resource_fmap. f_equal. apply preds_fmap_NoneP.
  rewrite <- level_core.
  symmetry; apply resource_at_approx.
Qed.

Definition singleton_rmap  (v v': adr) (m: rmap) : rmap :=
  proj1_sig
  (make_rmap (fun i => if eq_dec i v then YES pfullshare (VAL v') NoneP  else core m @ i )
    I (level m) (singleton_rmap_OK _ _ m)).

Lemma singleton_rmap_level: forall x y m,
      level (singleton_rmap x y m) = level m.
Proof.
  intros.  apply level_make_rmap.
Qed.

Lemma singleton_rmap_mapsto:
   forall x y n, app_pred (mapsto x y) (singleton_rmap x y n).
 Proof.
  intros. hnf. simpl snd.
  unfold singleton_rmap.
  intro; repeat rewrite resource_at_make_rmap.
  change AV.address with adr.
 destruct (eq_dec i x); auto.
 apply resource_at_core_identity.
Qed.

Local Open Scope pred.

Lemma mapsto_uniq: forall (x y: adr) w w', core w = core w' -> mapsto x y w -> mapsto x y w' -> w=w'.
Proof.
  intros.
 apply rmap_ext.
 assert (level (core w) = level (core w')) by congruence.
 do 2 rewrite level_core in H2. auto.
 intro.
 specialize (H0 l); specialize (H1 l).
 destruct (@eq_dec adr _ l x); try congruence.
 apply identity_unit_equiv in H0.
 apply unit_core in H0.
 apply identity_unit_equiv in H1.
 apply unit_core in H1.
 rewrite core_resource_at in *. congruence.
Qed.

Lemma mapsto_e1: forall v1 v2 w,
       app_pred (mapsto v1 v2 * TT) w ->
       w @ v1 = YES pfullshare (VAL v2) NoneP.
Proof.
 intros.
 destruct H as [w1 [w2 [? [? ?]]]].
 hnf in H0.
 specialize (H0 v1).
 apply (resource_at_join _ _ _ v1) in H.
 rewrite if_true in H0 by auto. rewrite H0 in H.
apply join_YES_pfullshare1 in H. inv H; auto.
Qed.

Definition assert := env -> pred rmap.
Bind Scope pred with assert.

(****** PROGRAM SAFETY AS A SEPARATION-LOGIC PREDICATE *)

Program Definition cohere (concrete: heap) : pred rmap :=
 fun w =>
 forall p v, heap_get (concrete) p = Some v  <->
                 w @ p = YES pfullshare (VAL v) NoneP.
Next Obligation.
  unfold hereditary; intros.
  rewrite H0.
  apply age1_YES; auto.
Qed.

Program Definition assert_safe
     (p: program) (vars: varset) (ctl: control) : assert :=
  fun s w => forall s' h, varcompat vars s' ->
                   locals2env s' = s -> cohere h w -> safeN p (s',h,ctl) (level w).
 Next Obligation.
  unfold hereditary; intros.
  eapply safeN_less; [ | apply H0]; auto. subst.
  apply age_level in H.   rewrite H. change R.rmap with rmap. omega.
  clear - H H3. hnf in H3|-*. intros. rewrite H3.
    generalize (age1_YES _ _ p pfullshare (VAL v) H); intros.
  intuition.
 Qed.

Lemma assert_safe0:
        forall p vars k s w,
           (forall w', age w w' -> app_pred (assert_safe p vars k s) w) ->
            app_pred (assert_safe p vars k s) w.
Proof.
  intros.
  case_eq (age1 w); intros.
  apply (H _ H0).
  hnf; repeat intro.
  rewrite age1_level0 in H0. rewrite H0. hnf. econstructor; reflexivity.
Qed.

(******* FUNASSERT, MAKE_WORLD ********************)

Definition funspec := (list var * assert)%type.
Definition funspecs := table adr funspec.

Definition unpack (P: list adr -> pred rmap) (vl: listprod (@cons Type (list adr) nil)):  pred rmap := P (fst vl).

Definition call (P: list var * assert) (vl: list adr) : pred rmap :=
     (!! (length vl = length (fst P)) && snd P (arguments (fst P) vl)).

Program Definition cont (nP: funspec)  (v: adr) : pred rmap :=
  fun w => w @ v = PURE (FUN (fst nP)) (preds_fmap (approx (level w)) (SomeP (list adr::nil)
             (unpack (call nP)))).
Next Obligation.
 intros; intro; intros.
  apply (age1_resource_at a a' H v (PURE (FUN (fst nP)) _));   simpl; auto.
Qed.

Definition funassert (G: funspecs) : pred rmap :=
   (ALL  i:_, ALL P:_,  !! (table_get G i = Some P) --> cont P i)  &&
   (ALL  i:_, ALL P:_,  cont P i --> !! exists P', table_get G i = Some P').

Definition make_world_aux (G: funspecs) (h: heap) (n: nat) (a: adr) : resource :=
   match table_get G a with
   | Some P => PURE (FUN (fst P))
                               (preds_fmap (approx n)
                                      (SomeP (@cons Type (list adr) nil) (unpack (call P))))
   | None => match heap_get h a with
                     | Some v => YES pfullshare (VAL v) NoneP
                     | None => NO
                    end
   end.

Lemma make_world_aux_OK:
  forall G h n,
         resource_fmap (approx n) oo make_world_aux G h n =  make_world_aux G h n.
Proof.
 intros.
 extensionality v;
 unfold make_world_aux, compose.
 destruct (table_get G v). destruct f as [nargs P]. simpl.
 f_equal. f_equal. rewrite <- compose_assoc. rewrite approx_oo_approx. auto.
 destruct (heap_get h v); auto.
 unfold resource_fmap.
 f_equal. apply preds_fmap_NoneP.
Qed.

Definition make_world (G: funspecs) (h: heap) (n: nat) : rmap :=
    proj1_sig (make_rmap (make_world_aux G h n) I n (make_world_aux_OK _ _ _)).

Lemma level_make_world:
  forall h G n, level (make_world G h n) = n.
Proof.
 intros; simpl.
 apply level_make_rmap.
Qed.

Inductive match_specs: forall (p: program) (G: funspecs), Prop :=
| match_specs_nil: match_specs nil nil
| match_specs_cons: forall i vars f p' P G',
         not (In i (map (@fst _ _) p')) ->
         match_specs p' G' ->
         typecheck vars f = true ->
         match_specs ((i,(vars,f))::p') ((i,P)::G').

Lemma match_specs_boundary:
   forall p G i,
   match_specs p G -> i >= boundary p -> table_get G i = None.
Proof.
  induction 1. intros. reflexivity.
  intros. simpl in *.
  destruct (@eq_dec adr _ i i0). subst.
  clear - H2. destruct (boundary p'). elimtype False; omega.
 generalize (Max.le_max_l i0 n); intro. elimtype False. omega.
 apply IHmatch_specs.
 destruct (boundary p'); try omega.
 generalize (Max.le_max_r i0 n0);  omega.
Qed.

Lemma funassert_e:  forall G i f,
      table_get G i = Some f ->
      funassert G |-- cont f i.
Proof.
  intros.
  unfold funassert.
  apply andp_left1.
  intros w ?. apply H0; auto.
Qed.

Lemma funassert_make_world: forall p G n,
         app_pred (funassert G) (make_world G (initial_heap p) n).
Proof.
 intros ? ? ?.
 forget (initial_heap p) as h.
 split.
 intros i P w ? ?.
 hnf in H0.
 eapply pred_nec_hereditary; try apply H.
 clear w H.
 hnf. unfold make_world; simpl. rewrite resource_at_make_rmap.
 unfold make_world_aux. rewrite H0.
 f_equal. simpl. f_equal. rewrite level_make_rmap.
 reflexivity.
 intros i P w ? ?.
 hnf.
 case_eq (table_get G i); intros. eauto.
 elimtype False.
 hnf in H0.
 case_eq (make_world G h n @ i); intros.
 apply (necR_NO _ _ i H) in H2. inversion2 H0 H2.
 apply (necR_YES _ _ i _ _ _ H) in H2. inversion2 H2 H0.
 clear dependent w.
 unfold make_world in H2.
 rewrite resource_at_make_rmap in H2. unfold make_world_aux in H2.
 rewrite H1 in H2. destruct (heap_get h i); inv H2.
Qed.

Lemma cohere_make_world:
  forall p G n,
      match_specs p G ->
     app_pred (cohere (initial_heap p)) (make_world G (initial_heap p) n).
Proof.
 intros.
 hnf.
 intros. unfold make_world, make_world_aux; simpl. rewrite resource_at_make_rmap.
 unfold  initial_heap. simpl. unfold heap_get.
  rename p0 into i.
 destruct (lt_dec i (boundary p)).
 split; intro. inv H0. elimtype False.
 revert H0; case_eq (table_get G i); intros. destruct f as [nargs P].
 inv H1. inv H1.
 rewrite (match_specs_boundary p G i); auto; try omega.
 split; intro Hx; inv Hx; auto.
Qed.

Lemma funassert_get:
  forall G v nP,  funassert  G && cont nP v |--
                      EX P':assert, (ALL vl:list adr, |> ! (call nP vl <=> call (fst nP,P') vl)) && !! (table_get G v = Some (fst nP,P')).
Proof.
 intros. intros w [? ?].
 destruct H.
 specialize (H v); specialize (H1 v).
 specialize (H1 _ _ (necR_refl _) H0).
 destruct H1 as [[args P'] ?].
 exists P'.
 specialize (H _ _ (necR_refl _) H1).
 split.
 Focus 2. hnf in H,H0. inversion2 H H0. apply H1.
 clear H1. rename H into H99. rename H0 into H97.
 hnf in H99,H97. rewrite H99 in H97.  apply PURE_inj in H97. destruct H97 as [H H97].
 simpl in H. destruct nP as [na P]. inv H.
 intro vl. intros w' ? w'' ?.
  assert (level w'' < level w). do 3 red in H. apply laterR_level in H.
       apply le_lt_trans with (level w'); auto.
 simpl fst.
  split; intros w''' ? ?.
 match type of H97 with ?A = _ => assert (app_pred (A (vl,tt)) w''') end.
  rewrite H97.
 split.
  change rmap with R.rmap in *.
  change ag_rmap with R.ag_rmap in *.
  apply necR_level in H2; omega.
 apply H3.
  destruct H4. apply H5.
 match type of H97 with _ = ?A => assert (app_pred (A (vl,tt)) w''') end.
  rewrite <- H97.
 split.
  change rmap with R.rmap in *.
  change ag_rmap with R.ag_rmap in *.
  apply necR_level in H2; omega.
 apply H3.
  destruct H4. apply H5.
Qed.

Lemma cont_core: forall P i w, app_pred (cont P i) w <-> app_pred (cont P i) (core w).
Proof.
 intros.
 unfold cont. simpl. rewrite <- core_resource_at.
 split; intro. rewrite H.
 clear. symmetry. rewrite level_core. apply unit_core; constructor.
 rewrite level_core in H.
 generalize (core_unit (w @ i)); intro.
 rewrite H in H0.
 inv H0; auto.
Qed.

Lemma funassert_core: forall G w, app_pred (funassert G) w <-> app_pred (funassert G) (core w).
Proof.
 intros.
 split; intros [? ?]; split; intros i P w' ? ?.
 specialize (H i P _ (necR_refl _) H2).
 apply cont_core in H. eapply pred_nec_hereditary; eauto.
 generalize (core_unit w); intro.
 unfold unit_for in H3.
 eapply nec_join in H3; eauto.
 destruct H3 as [y' [z' [? [? ?]]]].
 generalize (necR_linear' H4 H5); intro.
 spec H6. apply join_level in H3. destruct H3; congruence.
 subst z'. clear H5.
 specialize (H0 i P _ H4).
 apply join_core in H3. rewrite cont_core in H2. rewrite H3 in H2. rewrite <- cont_core in H2.
 specialize (H0 H2). apply H0.
 assert (necR (core w) (core w')).
 generalize (core_unit w); intro.
 unfold unit_for in H3.
 apply join_comm in H3.
 eapply nec_join in H3; eauto.
 destruct H3 as [y' [z' [? [? ?]]]].
 generalize (necR_linear' H1 H5); intro.
 spec H6. apply join_level in H3. destruct H3; congruence. subst z'.
 apply join_comm in H3.
 generalize (unit_identity _ H3); intro.
 apply identity_unit_equiv in H6. apply unit_core in H6.
 apply join_core in H3. rewrite H6 in H4. rewrite H3 in H4; auto.
 specialize (H i P _ H3 H2).
 apply cont_core in H; auto.
 assert (necR (core w) (core w')).
 generalize (core_unit w); intro.
 unfold unit_for in H3.
 apply join_comm in H3.
 eapply nec_join in H3; eauto.
 destruct H3 as [y' [z' [? [? ?]]]].
 generalize (necR_linear' H1 H5); intro.
 spec H6. apply join_level in H3. destruct H3; congruence. subst z'.
 apply join_comm in H3.
 generalize (unit_identity _ H3); intro.
 apply identity_unit_equiv in H6. apply unit_core in H6.
 apply join_core in H3. rewrite H6 in H4. rewrite H3 in H4; auto.
 specialize (H0 i P _ H3).
 apply H0. rewrite <- cont_core; auto.
Qed.

(**************** ALLOCPOOL ***************************)

Program Definition allocpool (b: adr) : pred rmap :=
   fun w => b>0 /\ forall i, if lt_dec i b then identity (w @ i) else w @ i = YES pfullshare (VAL 0) NoneP.
Next Obligation.
 intros. intro; intros.
  destruct H0; split; auto.
 intro i; specialize (H1 i).
 destruct (lt_dec i b).
  eapply age1_resource_at_identity; eauto.
 apply (age1_YES _ _ _ _ _ H); auto.
Qed.

Lemma allocpool_make_world: forall p G n,
          match_specs p G ->
          app_pred (allocpool (boundary p)) (make_world G (initial_heap p) n).
Proof.
  unfold make_world; intros.
  rename H into H'.
 unfold initial_locals,initial_heap  in *.
 split.
 destruct p; simpl. omega. destruct p. destruct (boundary p0); omega.
 intro loc.
 destruct (make_rmap
        (make_world_aux G
           (fun i : adr => if lt_dec i (boundary p) then None else Some 0) n)
        I n
        (make_world_aux_OK G
           (fun i : adr => if lt_dec i (boundary p) then None else Some 0) n)) as [? [? ?]];
  simpl in *. rewrite e0. unfold make_world_aux.
 unfold heap_get.
 destruct (lt_dec loc (boundary p)).
 destruct (table_get G loc);  apply identity_resource; auto.
 rewrite (match_specs_boundary p G loc); auto.
 omega.
Qed.

Lemma alloc: forall b, allocpool b = ((!! (b > 0) && mapsto b 0) * allocpool (S b)).
Proof.
 intros. apply pred_ext.
  intros w ?.
 destruct H as [H' H].
  destruct (deallocate w
                   (fun i => if lt_dec b i then NO else w @ i)
                   (fun i => if eq_dec b i then NO else w @ i)
               I I) as [w1 [w2 [? ?]]].
 intro l; specialize (H l).
 destruct (eq_dec b l). subst. rewrite if_false by omega. rewrite if_false in H by omega.
 rewrite H; constructor.
 destruct (lt_dec b l).
 rewrite if_false in H by omega.
 rewrite H; constructor.
 rewrite if_true in H.
 apply identity_unit_equiv in H. apply H.
 unfold adr in *; omega.
 exists w1; exists w2; split3; auto.
 split; auto.
 intro i. apply (resource_at_join _ _ _ i) in H0. specialize (H i). rewrite H1 in *.
 clear w1 H1.
 destruct (lt_dec b i).
 rewrite if_false by omega. apply NO_identity.
 destruct (eq_dec i b). subst. rewrite if_false in H by omega. auto.
 rewrite if_true in H. auto.
 unfold adr in *; omega.
 split. omega.
 intro i. apply (resource_at_join _ _ _ i) in H0. specialize (H i). rewrite H1 in *.
 clear w1 H1.
 destruct (lt_dec b i).
 rewrite if_false by omega. rewrite if_false in H by omega. rewrite H in H0. inv H0; auto.
 rewrite if_true by omega.
 destruct (eq_dec i b). subst. rewrite if_false in H by omega. rewrite H in H0; inv H0; auto.
 apply NO_identity. pfullshare_join.
 rewrite if_true in H by (unfold adr in *; omega).
 apply H in H0. rewrite H0; auto.

  intros w [w1 [w2 [? [? ?]]]].
  destruct H0 as [H0' H0]. destruct H1 as [_ H1].
 split; auto.
  intro i. specialize (H0 i); specialize (H1 i). apply (resource_at_join _ _ _ i) in H.
  destruct (lt_dec i b). rewrite if_true in H1 by omega.
  rewrite if_false in H0 by omega. apply H0 in H. rewrite <- H; auto.
  destruct (@eq_dec adr _ i b). subst. rewrite H0 in H. rewrite if_true in H1 by omega.
  apply join_comm in H. apply H1 in H. auto.
  rewrite if_false in H1. rewrite H1 in H. apply H0 in H. auto.
  unfold AV.address, AV0.address, adr in *. omega.
Qed.

Require msl.seplog msl.alg_seplog.
Definition mpred : Type := predicates_hered.pred rmap.
Instance Nm: seplog.NatDed mpred := alg_seplog.algNatDed rmap.
Instance Sm: seplog.SepLog mpred := alg_seplog.algSepLog rmap.
Instance Cm: seplog.ClassicalSep mpred := alg_seplog.algClassicalSep rmap.
Instance Im: seplog.Indir mpred := alg_seplog.algIndir rmap.
Instance Rm: alg_seplog.RecIndir mpred := alg_seplog.algRecIndir rmap.
Instance SIm: seplog.SepIndir mpred := alg_seplog.algSepIndir rmap.
Instance SRm: alg_seplog.SepRec mpred := alg_seplog.algSepRec rmap.

Definition guard (p: program) (G: funspecs) (vars: varset) (P : assert) (k: control) : pred nat :=
     ALL s:env, P s && funassert G >=> assert_safe p vars k s.

Record semaxArg :Type := SemaxArg {
 sa_vars: varset;
 sa_P: assert;
 sa_c: control
}.

Definition believe (semax: semaxArg -> pred nat)
      (p: program) (P: funspec) (f: adr) : pred nat :=
      EX k: list var * control,
        !!(table_get p f = Some k /\ length (fst k) = length (fst P) /\ list_norepet (fst k)) &&
      |> semax (SemaxArg (fst k) (fun s => call P (map s (fst k))) (snd k)).

Definition believe_all (semax: semaxArg -> pred nat) (G: funspecs) (p: program) (G': funspecs) : pred nat :=
  ALL v:adr, ALL args: list var, ALL P: assert,
     !! (table_get G' v = Some (args,P)) -->
     believe semax p (args, fun s => P s && funassert G) v.

Definition semax_ (semax: semaxArg -> pred nat) (a: semaxArg) : pred nat :=
 match a with SemaxArg vars P c =>
     ALL p: program, ALL G: funspecs, believe_all semax G p G --> guard p G vars P c
  end.

Lemma prop_imp {A}{agA: ageable A}:
  forall (P: Prop) (Q: pred A) w, (P -> app_pred Q w) -> app_pred (!!P --> Q) w.
Proof. repeat intro. specialize (H H1). eapply pred_nec_hereditary; eauto.
Qed.

Lemma HOcontractive_semax_ : HOcontractive semax_.
Proof.
  auto 50 with contractive.
Qed.

Definition semax'  := HORec semax_.

Lemma semax'_unfold: forall vars P c,
     semax' (SemaxArg vars P c) =
         ALL p: program, ALL G:funspecs, believe_all semax' G p G --> guard p G vars P c.
Proof.
  intros.
  unfold semax' at 1. rewrite HORec_fold_unfold; auto.
  apply HOcontractive_semax_.
Qed.

Definition semax vars (G: funspecs) (P: assert) (k: control) : Prop :=
       typecheck vars k = true /\ forall n,  semax' (SemaxArg vars (fun s => P s && funassert G) k) n.

Definition semax_func (G: funspecs) (p: program) (G': funspecs) :=
    match_specs p G' /\
    forall n, believe_all semax' G p G' n.

Lemma semax_func_nil: forall G, semax_func G nil nil.
Proof. split; repeat intro. constructor. inv H0. Qed.

Lemma semax_func_cons:
   forall  fs id f vars P (G G': funspecs),
      inlist id (map (@fst adr (list var * control)) fs) = false ->
      list_nodups vars = true ->
      length vars = length (fst P) ->
      semax vars G (fun s => call P (map s vars)) f ->
      semax_func G fs G' ->
      semax_func G ((id, (vars,f))::fs) ((id, P) :: G').
Proof.
intros until G'. intros H0 H Hlen ? ?.
apply inlist_notIn in H0.
destruct H2.
split.
constructor; auto.
destruct H1; auto.
intro.
specialize (H3 n).
intros b nargs' Q.
specialize (H3 b nargs' Q).
intros ? ? ?.
destruct (eq_dec id b).
subst.
Focus 2.
specialize (H3 _ H4).
spec H3.
clear - H5 n0.
hnf in H5|-*.
unfold table_get  in H5; fold @table_get in H5.
rewrite if_false in H5; auto.
clear H5.
destruct H3 as [k [? ?]]; exists k; split; auto.
unfold table_get; fold @table_get.
rewrite if_false; auto.
(* End Focus 2 *)
unfold table_get in H5; fold @table_get in H5.
rewrite if_true in H5; auto.
simpl in H5.
inv H5.
exists (vars,f).
split.
simpl.
rewrite if_true; auto. split; auto. split; auto. apply nodups_norepet. auto.
simpl fst; simpl snd.
hnf; intros.
destruct H1 as [_ H1].
specialize (H1 a'0).
replace (fun s : env =>
           call (nargs', fun s0 : env => Q s0 && funassert G) (map s vars))
 with (fun s : env => call (nargs', Q) (map s vars) && funassert G).
apply H1.
extensionality s. forget (map s vars) as vl.
clear.
apply pred_ext; intros ? ?.
destruct H as [[? ?] ?].
split. apply H. simpl snd in *. split; auto.
destruct H. simpl fst in *; simpl snd in *.
destruct H0; split; auto. split; auto.
Qed.

Lemma semax_G:
   forall vars G P c, semax vars G (fun s => P s && funassert G) c -> semax vars G P c.
Proof.
  intros. destruct H; split; auto.
  intro; specialize (H0 n).
  replace (fun s : env => P s && funassert G) with (fun s : env => P s && funassert G && funassert G);
       auto.
  extensionality s.
  rewrite andp_assoc. f_equal. apply andp_dup.
Qed.

Lemma semax_go:  forall vars G (P: funspec) x ys,
    typecheck vars (Go x ys) = true ->
    semax vars G (fun s => cont P (eval x s) && call P (eval_list ys s)) (Go x ys) .
Proof.
 intros. rename H into TC.
  split; auto.
   intro n; hnf.
   rewrite semax'_unfold.
  intros p G0.
  hnf. intros n' ? ?.
  clear n H.
  intros s w ? w' ?.
  rewrite andp_assoc.
  intros [[H4 H5] [_ GUARDIAN]].
  pose (H3:=True).
  clear G. rename G0 into G.
  remember (eval x s) as v'.
  destruct (funassert_get G v' P w') as [P' [H2 H2']].
  split; auto.
  generalize (H0 _ _ _ _ (necR_refl _) H2'); intro. clear H2'.
  destruct H6 as [[formals k] [[H6 [H6' H6'']] ?]].
  hnf in H6.
 rewrite semax'_unfold in H7.
  apply assert_safe0; intros w'' Hw''.
  assert (LATER: laterR n' (level w'')).
    apply later_nat; apply necR_level in H1; apply age_level in Hw''.
   unfold R.rmap in *; omega. specialize (H2 (eval_list ys s)).
  red in H2. red in H2. red in H2.
  specialize (H2 _ (t_step _ _ _ _ Hw'' )).
  specialize (H7 _ LATER).
  apply (pred_nec_hereditary _ _ _ (laterR_necR LATER)) in H0.
  specialize (H7 p G _ (necR_refl _) H0). clear H0.
  simpl fst in *. simpl snd in *.
  do 3 red in H2.
  apply (pred_hereditary _ _ _ Hw'') in H5.
  specialize (H2 _ (le_refl _)).
  specialize (H7 (locals2env (mk_locals formals (eval_list ys s))) _ (le_refl _) _ (necR_refl _)).
  clear n' H LATER.
  intros ? ? VC L H. rewrite <- L in *. clear L s. rename s' into s.
  assert (step p (s,h, Go x ys) = Some ((mk_locals formals (eval_list ys (locals2env s)), h), k)).
  simpl.
  simpl typecheck in TC.
  rewrite andb_true_iff in TC; destruct TC as [TC1 TC2].
  rewrite (eval_expr_get vars s h x); auto. rewrite <- Heqv'.
  simpl. rewrite H6.  simpl.
  rewrite (eval_expr_get_list vars s h ys); auto.
  rename Hw'' into H12.
  rewrite (age_level _ _ H12).
  rewrite (safeN_step _ _ _ _ H0).
  clear w H1.
  pose (H11:=True).
  spec H7.
  eapply pred_hereditary in GUARDIAN; eauto.
  split; auto.
  split.
  hnf. rewrite map_length. simpl fst. auto.
  split; auto.
  destruct H2 as [? _].
  specialize (H1 _ (necR_refl _) H5).
  simpl.
  unfold call in H1. simpl in H1.
  Transparent arguments.
  unfold arguments in *.
  Opaque arguments.
  replace (map (locals2env (mk_locals formals (eval_list ys (locals2env s)))) formals)
     with (eval_list ys (locals2env s)); [ apply H1 | ].
  destruct H5 as [Hlen H5]. hnf in Hlen.
  assert (length (eval_list ys (locals2env s)) = length formals).
    rewrite H6'. auto.
  forget (eval_list ys (locals2env s)) as vs.
  clear - H2 H6''.
  revert vs H2; induction H6''; intros; destruct vs; inv H2; simpl; auto.
  f_equal. unfold locals2env; simpl. rewrite if_true by auto. auto.
 pattern vs at 1; rewrite (IHH6'' vs) by auto.
 forget (mk_locals tl vs) as y.
 clear - H. induction tl; simpl; auto. f_equal; simpl.
 unfold locals2env; simpl.
 rewrite if_false by (contradict H; simpl in *; intuition). auto.
 apply IHtl. intuition.
  apply H7; auto.
  apply varcompat_mk_locals. unfold eval_list. rewrite map_length. rewrite H6'; auto.
  destruct H5 as [H5 _]; hnf in H5.
  rewrite <- H5.
  clear. induction ys; simpl; omega.
  eapply pred_hereditary; eauto.
Qed.

Lemma semax_assign: forall x y c vars G P,
    expcheck vars y = true ->
    semax (vs_add x vars) G P c ->
    semax vars G (fun s => |> subst x (eval y s) P s) (Do x := y ; c).
Proof.
 intros until P; intros TC [TC' ?].
 split.
 simpl in *. destruct y; inv TC; simpl; auto; try rewrite TC'; try rewrite H1; auto.
 intro; intros.
 unfold subst.
 rewrite semax'_unfold.
 intros p G' n' ? ? s w ? w' ? [[H6 H6'] H4].
 pose (H5:=True).
 apply assert_safe0; intros w'' ?.
 intros s' h VC L ?. rewrite <- L in *; clear L s; rename s' into s.
 generalize (age_level _ _ H7); intro. rewrite H9.
 apply (pred_hereditary _ _ _ H7) in H8.
 specialize (H6 _ (t_step _ _ _ _ H7)).
 apply (pred_hereditary _ _ _ H7) in H4.
 assert (necR n' (level w')). apply necR_trans with (level w); auto.
 apply nec_nat. auto. apply necR_level'. auto.
 apply (pred_nec_hereditary _ _ _ H10) in H1.
 clear n' w H3 H2 H0 H10.
 hnf in H5.
 assert (step p ((s,h), Do (Var x) := y; c) = Some ((table_set x (eval y (locals2env s)) s, h), c)).
 simpl. rewrite (eval_expr_get vars s h y); auto.
 apply (safeN_step _ _ _ _ H0).
  specialize (H (@level _ ag_rmap w')). rewrite semax'_unfold in H.
 specialize (H p G' _ (necR_refl _) H1).
 specialize (H (locals2env (@table_set var _ EqDec_var x (eval y (locals2env s)) s))).
 specialize (H w''). spec H; [rewrite H9; omega | ].
 specialize (H _ (necR_refl _)).
 spec H. split; auto.
 replace  (locals2env (table_set x (eval y (locals2env s)) s))
   with (env_set (locals2env s) x (eval y (locals2env s))); auto.
  split; [ auto | eapply pred_hereditary; eauto].
  clear.
   extensionality i. unfold env_set. unfold locals2env at 3.
   destruct (eq_dec i x). subst. rewrite table_gss; auto. rewrite table_gso; auto.
 apply H; auto.
  clear - VC.
  intros i ?. destruct (eq_dec i x). subst. rewrite table_gss. congruence.
  rewrite table_gso by auto. apply (VC i).
  unfold vs_mem in H. apply ListSet.set_mem_correct1 in H.
  apply ListSet.set_mem_correct2. unfold vs_add in H.
  apply ListSet.set_add_elim2 in H; auto.
Qed.

Lemma semax_if: forall x c1 c2 vars G (P: assert),
    expcheck vars x = true ->
    semax vars G (fun s => !!(eval x s <> 0) && P s) c1 ->
    semax vars G (fun s => !! (eval x s = 0) && P s) c2 ->
    semax vars G P (If x Then c1 Else c2).
Proof.
 intros. rename H into TC.
 destruct H0 as [TC0 H]; destruct H1 as [TC1 H'].
 split.
 simpl; auto.
 intro.
 rewrite semax'_unfold.
 intros p G' n' ? ? s w ? w' ? [H5 H4].
 pose (H6:=True).
 apply assert_safe0; intros w'' ?.
 intros s' h VC L ?. rewrite <- L in *; clear L s; rename s' into s.
 generalize (age_level _ _ H7); intro. rewrite H9.
 destruct (eq_dec (eval x (locals2env s)) 0).
 (* zero *)
 clear H; rename H' into H.
 subst.
 assert (step p ((s,h), If x Then c1 Else c2) = Some ((s,h), c2)).
 simpl. rewrite (eval_expr_get vars s h x); auto.
 rewrite e; simpl; auto.
 apply (safeN_step _ _ _ _ H10).
 specialize (H n'). rewrite semax'_unfold in H.
 assert (necR n' (level w')). apply necR_trans with (level w); auto.
 apply nec_nat. auto. apply necR_level'. auto.
 specialize (H p G' _ H11 (pred_nec_hereditary _ _ _ H11 H1)).
 specialize (H (locals2env s) w'').
 spec H. omega.
 specialize (H _ (necR_refl _)).
 spec H.
  rewrite andp_comm.
 split. eapply pred_hereditary; eauto.
 apply (pred_hereditary _ _ _ H7) in H5.
 rewrite andp_assoc; split; [ |  apply H5].
 hnf; auto.
 apply H; auto.
 apply (pred_nec_hereditary _ _ _ (rt_step _ _ _ _ H7)); auto.
 (* nonzero *)
 subst.
 assert (step p ((s,h), If x Then c1 Else c2) = Some ((s,h), c1)).
 simpl. rewrite (eval_expr_get vars s h x); auto. simpl.  rewrite if_false; auto.
 apply (safeN_step _ _ _ _ H10).
 specialize (H n'). rewrite semax'_unfold in H.
 assert (necR n' (level w')). apply necR_trans with (level w); auto.
 apply nec_nat. auto. apply necR_level'. auto.
 specialize (H p G' _ H11 (pred_nec_hereditary _ _ _ H11 H1)).
 specialize (H (locals2env s) w'').
 spec H. omega.
 specialize (H _ (necR_refl _)).
 spec H.
 rewrite andp_comm.
 split. eapply pred_hereditary; eauto.
 apply (pred_hereditary _ _ _ H7) in H5.
 rewrite andp_assoc; split; [ |  apply H5].
 hnf; auto.
 apply H; auto.
 apply (pred_nec_hereditary _ _ _ (rt_step _ _ _ _ H7)); auto.
Qed.

Lemma semax_load: forall x y z c vars G P,
    expcheck vars y = true ->
    semax (vs_add x vars) G P c ->
    semax vars G (fun s => ((mapsto (eval y s) z) * TT) && |> subst x z P s)
               (Do x := Mem y ; c).
Proof.
 intros until P. intros TC [TC' ?].
 split.
 simpl; auto.
 intro n.
 rewrite semax'_unfold.
 intros p G' n' ? ? s w ? w' ? [H5 H4].
 destruct H5 as [[? HP] HG].
 unfold subst in HP.
 apply assert_safe0; intros w'' H7.
 specialize (HP _ (t_step _ _ _ _ H7)).
 intros s' h VC L ?. rewrite <- L in *; clear s L; rename s' into s.
 generalize (age_level _ _ H7); intro. rewrite H8.
 assert (step p ((s,h), Do x := Mem y; c) = Some ((table_set x z s, h), c)).
 simpl. rewrite (eval_expr_get vars s h y); auto. simpl.
 replace (heap_get h (eval y (locals2env s))) with (Some z).
 auto.
 symmetry.
 apply H6. apply mapsto_e1; auto.
 apply (safeN_step _ _ _ _ H9). clear H9.
 specialize (H n'). rewrite semax'_unfold in H.
 assert (necR n' (level w')). apply necR_trans with (level w); auto.
 apply nec_nat. auto. apply necR_level'. auto.
 specialize (H p G' _ H9 (pred_nec_hereditary _ _ _ H9 H1)).
 specialize (H (locals2env (@table_set _ _ EqDec_var x z s)) w'').
 spec H.    unfold R.rmap in *; omega.
 specialize (H _ (necR_refl _)).
 spec H. split; [split|].
  rewrite locals2env_table_set. eauto.
  eapply pred_hereditary; eauto.
  eapply pred_hereditary; eauto.
 apply H; auto.
 apply varcompat_add; auto.
 eapply pred_hereditary; eauto.
Qed.

Lemma semax_store: forall x y v c vars G (P: assert),
    expcheck vars x = true ->
    expcheck vars y = true ->
    semax vars G (fun s => mapsto (eval x s) (eval y s) * P s) c ->
    semax vars G (fun s => mapsto (eval x s) v  * P s)  (Do Mem x  := y ; c).
Proof.
 intros until P; intros TCx TCy [TC ?].
 split.
 simpl; auto.
 intro. rewrite semax'_unfold.
 intros p G' n' ? ? s w ? w' ? [[H5 H6] H4].
 apply assert_safe0; intros w'' ?.
 intros s' h VC L ?. rewrite <- L in *; clear L s; rename s' into s.
 generalize (age_level _ _ H7); intro. rewrite H9.
 assert (step p ((s,h), Do Mem x := y; c) = Some ((s, heap_set (eval x (locals2env s)) (eval y (locals2env s)) h), c)).
 simpl. rewrite (eval_expr_get vars s h y); auto. rewrite (eval_expr_get vars s h x); auto.
 apply (safeN_step _ _ _ _ H10).
 specialize (H n'). rewrite semax'_unfold in H.
 assert (necR n' (level w')). apply necR_trans with (level w); auto.
 apply nec_nat. auto. apply necR_level'. auto.
 specialize (H p G' _ H11 (pred_nec_hereditary _ _ _ H11 H1)).
 apply (pred_hereditary _ (level w') (level w'')) in H;
   [ |  apply age_level in H7; rewrite H7; hnf; simpl; auto].
 apply (pred_hereditary _ _ _ H7) in H5.
 apply (pred_hereditary _ _ _ H7) in H6.
 apply (pred_hereditary _ _ _ H7) in H4.
 apply (pred_hereditary _ _ _ H7) in H8.
 clear H1; pose (H1:=True). clear n H0. pose (H0:=True).
 clear n' H2 H11. pose (H2:=True). pose (H11:=True).
 simpl in H8.
clear w' H7 H9 H3.
 pose (H7:=True); pose (H9:=True); pose (H3:=True).
 clear H0 H1.
 destruct H5 as [wa [wb [H0 [HP H1]]]].
 pose (m' := singleton_rmap (eval x (locals2env s)) (eval y (locals2env s)) w'').
 assert (joins m' wb).
 apply resource_at_joins2. unfold m'.
 rewrite singleton_rmap_level.
 apply join_level in H0. destruct H0. auto.
 unfold m'. intro i.
 clear - HP H0.
 apply (resource_at_join _ _ _ i) in H0.
 specialize (HP i).
 unfold singleton_rmap. rewrite resource_at_make_rmap.
 destruct (eq_dec i (eval x (locals2env s))). subst; rewrite if_true in HP; auto.
 exists (YES pfullshare (VAL (eval y (locals2env s))) NoneP).
 rewrite HP in *. inv H0; try pfullshare_join. constructor.
 rewrite if_false in HP by auto.
 exists (wb @ i).
 apply HP in H0. rewrite H0.
 rewrite <- core_resource_at. apply core_unit.
 destruct H5 as [ww H12].
 replace (level w'') with (level ww) in H.
 Focus 2.
 transitivity (level wb).
 apply join_level in H12. destruct H12 as [H12 H13]. symmetry ; apply H13.
 apply join_level in H0; destruct H0; auto.
 specialize (H (locals2env s) ww).
 spec H. simpl. apply le_refl.
 specialize (H _ (necR_refl _)).
 spec H. rewrite andp_assoc. rewrite andp_comm.
 clear - H4 H0 HP H12 H6 H1.
 assert (app_pred ((mapsto (eval x (locals2env s)) v * TT) && (funassert G && funassert G')) w'').
 split; auto. exists wa; exists wb; split3; auto. split; auto.
 destruct H as [? _].
 split.
 apply join_comm in H0. apply join_comm in H12. apply join_core in H0. apply join_core in H12.
 apply funassert_core in H6. apply funassert_core in H4. rewrite H12 in H0.
 split; apply funassert_core; rewrite H0; auto.
 destruct H as [wa' [wb' [? [? ?]]]].
 assert (wa' = wa). eapply mapsto_uniq; eauto.
 apply join_core in H0; apply join_core in H. rewrite H0; rewrite H. auto.
 subst wa'. generalize (join_canc (join_comm H0) (join_comm H)); intro; subst wb'.
  generalize (singleton_rmap_mapsto (eval x (locals2env s)) (eval y (locals2env s)) w''); intro.
 assert (app_pred (mapsto (eval x (locals2env s)) (eval y (locals2env s)) * (TT && (funassert G && funassert G'))) ww).
 exists m'; exists wb; split3; auto.
 split; auto.
 apply join_comm in H0. apply join_comm in H12. apply join_core in H0. apply join_core in H12.
  apply funassert_core in H6. apply funassert_core in H4.
 split; apply funassert_core; rewrite H0; auto.
 exists m'; exists wb; split3; auto.
 replace (level w'') with (level ww).
 Focus 2. simpl. transitivity (level wb).
 clear - H12; apply join_level in H12; destruct H12; symmetry; apply H0.
 clear - H0; apply join_level in H0; destruct H0; apply H0.
 apply H; auto.
 intros i v0. specialize (HP i).
 simpl.
 apply (resource_at_join _ _ _ i) in H12.
 unfold m' in *; clear m'.
 unfold singleton_rmap in H12.
 rewrite resource_at_make_rmap in H12.
 change AV.address with adr in H12.
  specialize (H8 i v0). simpl in H8.

  destruct (eq_dec i (eval x (locals2env s))).
  subst. rewrite heap_gss.
  apply join_unit2_e in H12. rewrite <- H12.
  split; intro Hx; inv Hx; auto.
  apply YES_join_full in H12; auto.
  rewrite H12. apply NO_identity.
  apply join_unit1_e in H12; [ | rewrite <- core_resource_at; apply core_identity].
  rewrite heap_gso; auto.
 apply (resource_at_join _ _ _ i) in H0.
 rewrite <- H12.
 apply HP in H0. rewrite H0; auto.
Qed.

Lemma semax_pre:
  forall P P' vars G c, (forall s, P s |-- P' s) -> semax vars G P' c -> semax vars G P c.
Proof.
 intros. destruct H0 as [TC H0]; split; auto.
 intro n; specialize (H0 n).
 rewrite semax'_unfold in *.
 intros p G'. specialize (H0 p G').
 intros n' ? ?. specialize (H0 _ H1 H2).
 intros s w ? ? ? ?. specialize (H0 s _ H3 _ H4).
 apply H0.
 destruct H5; split; auto. destruct H5;  split; auto. apply H; auto.
Qed.

Lemma semax_exp: forall {A} vars G (P: A -> assert) c,
    typecheck vars c = true ->
    (forall v:A, semax vars G (P v) c) ->
    semax vars G (fun s => EX v:A, (P v s)) c.
Proof.
 intros ? ? ? ? ? TC ?.
 split; auto.
 intro.
 rewrite semax'_unfold.
 intros p G'. intros n' ? ?.
 intros s. intros ? ?. intros ? ?. intros [[[v ?] ?] ?].
 specialize (H v). destruct H as [_ H].
 rewrite semax'_unfold in H. eapply H; eauto. split; auto. split; auto.
Qed.

Lemma semax_exp': forall {A} (any: A) vars G (P: A -> assert) c,
    (forall v:A, semax vars G (P v) c) ->
    semax vars G (fun s => EX v:A, (P v s)) c.
Proof.
 intros ? ? ? ? ? ?.
 split; auto.
 destruct (H any); auto.
 intro.
 rewrite semax'_unfold.
 intros p G'. intros n' ? ?.
 intros s. intros ? ?. intros ? ?. intros [[[v ?] ?] ?].
 specialize (H v). destruct H as [_ H].
 rewrite semax'_unfold in H. eapply H; eauto. split; auto. split; auto.
Qed.

Lemma semax_prop:
  forall (R: Prop) vars G P c,
      typecheck vars c = true ->
      (R -> semax vars G P c) ->
      semax vars G (fun s => !! R && P s) c.
Proof.
  intros R vars G P c TC ?. split; auto. intro n.  rewrite semax'_unfold. intros p G'.
  intros n' ? ? b w ? w' ? [[[? ?] ?] ?].
  destruct (H H4).
  specialize (H9 n). rewrite semax'_unfold in H9.
  eapply H9; eauto. split; auto. split; auto.
Qed.

Definition program_proved (p: program) :=
   exists G, semax_func G p G  /\ table_get G 0 = Some (0::nil, fun s => allocpool (eval (Var 0) s)).

Lemma semax_sound:
  forall p, program_proved p -> forall n, run p n <> None.
Proof.
  intros.
  destruct H as [G [[? ?] ?]].
  generalize (funassert_make_world p G n); intro.
  destruct (semax_go nil G  (0::nil, fun s => allocpool (eval (Var 0) s))
                (Const 0) (Const (boundary p) :: nil) (eq_refl _)) as [_ ?].
  specialize (H3 n).
  rewrite semax'_unfold in H3.
  specialize (H3 p G _ (necR_refl _) (H0 _) (locals2env nil)
                    (make_world G (initial_heap p) n)).
  spec H3. rewrite level_make_world. auto.
  specialize (H3 _ (necR_refl _)).
  spec H3.
  split; auto.
  split; auto.
  split.
  apply (funassert_e _ _ _ H1 _ H2).
  unfold call.
  Transparent arguments. unfold arguments. Opaque arguments.
  simpl snd.
  unfold locals2env, table_get. rewrite if_true; auto.
  split. simpl; auto.
  apply allocpool_make_world; auto.
  hnf in H3.
  specialize (H3 nil (initial_heap p)).
  spec H3. intros i ?. inv H4.
  spec H3. auto.
  spec H3. apply cohere_make_world; auto.
  unfold run; intro.
  destruct H3 as [sk' ?].
  rewrite level_make_world in H3.
 unfold locals,table, var,adr in H3,H4. rewrite H3 in H4; inv H4.
Qed.

End Semax.


Section OBSOLETE.
Import Classical_Prop Classical_Pred_Type.
Theorem OrdPair_inj_left :
 forall a b c d : Ens, EQ (OrdPair a b) (OrdPair c d)->(EQ a c/\EQ b d).
Proof.
unfold OrdPair in |- *.
intros.
  assert (e2 : EQ (Paire (Sing a) (Paire a a))
                  (Sing  (Sing a)) ).
   repeat apply Paire_sound_right. apply EQ_refl.
destruct (classic (EQ a b)).
+ assert (e1 : EQ (Paire (Sing a) (Paire a b))
                  (Paire (Sing a) (Paire a a))).
   repeat apply Paire_sound_right. apply EQ_sym; assumption.

  assert (e3 := EQ_tran _ _ _ e1 e2).
  assert (e4 := EQ_tran _ _ _ (EQ_sym _ _ e3 ) H).
(*assert (j: EQ (Sing (Sing a)) (Paire (Sing c) (Paire c d))).
apply Paire_sound.*)
  apply SingEqPair in e4 as [H1 H2].
  (*apply SingEqPair in H1 as [Ha1 Ha2].*)
  apply SingEqPair in H2 as [P1 P2].
  split. assumption. apply EQ_tran with (E2:=a). apply EQ_sym, H0.
  apply P2.
+ assert (e1: IN (Paire c d) (Paire (Sing c) (Paire c d))).
   auto with zfc.
  apply IN_sound_right with (1:=EQ_sym _ _ H) in e1.
  apply Paire_IN in e1 as [A1|A2].
  - apply EQ_sym , SingEqPair in A1 as [B1 B2].
  split. exact B1.
  assert (e23:EQ (Paire (Sing c) (Paire c d)) (Paire (Sing a) (Paire a a))).
   apply Paire_sound.
   apply Sing_sound, EQ_sym, B1.
   apply Paire_sound; apply EQ_sym; assumption.
  assert(K:=EQ_tran _ _ _ e23 e2).
  assert(R:=EQ_tran _ _ _ H K). apply EQ_sym in R.
  apply SingEqPair in R as [R1 R2].
  apply SingEqPair in R2 as [R2 R3].
  destruct (H0 R3).
 - apply Paire_EQ_cases in A2 as [[q1|q2] [q3|q4]].
(* [v1 v2].
   destruct (classic (EQ a c)).
   split. assumption.
   destruct (classic (EQ b d)).

  -
apply Paire_IN in A2 as [B1|B2].
(*  assert (e2: EQ (Paire (Sing c) (Paire c d)) (Paire (Sing a) (Paire c d))).
  apply Paire_sound_left.
  apply Sing_sound, EQ_sym, B1.
  assert (e3: EQ (Paire (Sing a) (Paire c d)) (Paire (Sing a) (Paire a a))).
*)

  apply Sing_sound. EQ_sym, B1.
unshelve eapply EQ_tran (E2:=) in H.
!!!
apply EQ_tran
apply axExt; intro z; split; intro q.
 simpl in |- *. *)
 Abort.
End OBSOLETE.


(* From Undecidability.Shared.Libs.PSL Require Import FinTypes Vectors.
From Undecidability.L Require Import TM.TMinL.TMinL_extract.
From Undecidability.TM Require Import Compiler_facts Compiler_spec. *)
From Undecidability.L.Datatypes Require Import LNat Lists LProd LFinType LVector.
From Undecidability.L Require Import Functions.FinTypeLookup Functions.EqBool.
From Undecidability Require Import TMEncoding.

Require Import Undecidability.L.TM.TMinL.TMinL_extract.
Require Import Undecidability.L.Functions.UnboundIteration.
From Undecidability.TM Require Import TM TM_alt TM_facts.
Require Import Undecidability.L.Util.L_facts.
From Undecidability.L.Datatypes Require Import LNat.

Import L_Notations.

Notation PAIR := (lam (lam (lam (0 2 1)))).
Notation PAIR_ x y := (lam (0 x y)).

Section TimeInvarianceNF.

Import HOAS_Notations.

Variable Σ : finType.

Let reg_sig := @encodable_finType Σ.
Existing Instance reg_sig.

Variable n_tps : nat.

Definition s_sim : term := Eval cbn -[enc] in [L_HOAS (λ M_q0 tps, ha M_q0 (λ M q0, !!uiter M (!!PAIR q0 tps)))].

Variable M : TM Σ n_tps.
Variables (q q' : state M) (t t' : tapes Σ n_tps).

Let reg_state := @encodable_finType (state M).
Existing Instance reg_state.

Definition step_fun := (fun cfg : mconfig Σ (state M) n_tps =>
                          if haltConf cfg then inr (ctapes cfg) else inl (TM_facts.step cfg)).

Notation STEPTIME := (haltTime M + n_tps* 130+ transTime M + 185).

Instance step_fun_comp : computableTime' step_fun (fun _ _ => (STEPTIME,tt)).
Proof.
  extract. solverec.
Qed.

Lemma TimeInvarianceNF_forward i :
    loopSumM (M := M) (mk_mconfig q t) i = Some (mk_mconfig q' t') ->
    evalLe (7 + i * (STEPTIME + 11) ) (s_sim (PAIR_ (ext step_fun) (enc q)) (enc t)) (enc t').
Proof.
  intros H.
  assert (Hi : loopSum i step_fun (mk_mconfig q t) = Some t').
  { clear - H.  revert H. generalize (mk_mconfig q t). intros cfg H.
    induction i in H, cfg,t'|-*; cbn in *.
    - congruence.
    - unfold step_fun. destruct haltConf. inv H. reflexivity.
      eapply IHi. eapply H.
  }
  eapply evalLe_trans. unfold s_sim. Lsimpl. reflexivity.
  unshelve eapply uiter_sound in Hi. exact _. exact _. 2: eapply step_fun_comp.
  unfold s_sim. eapply evalIn_mono. econstructor. 2:Lproc. destruct Hi as [Hi ?].
  unfold enc at 1 in Hi. cbn in Hi. unfold enc at 1 in Hi. cbn in Hi.
  Lsimpl. reflexivity. rewrite <- plus_n_O.
  clear. fold (transTime M).
  change (  uiterTime step_fun
    (fun (_ : mconfig Σ (state M) n_tps) (_ : unit) =>
     (haltTime M + n_tps * 130 +
      transTime M + 185, tt)) i (mk_mconfig q t) <= i * (STEPTIME + 11)).
  generalize STEPTIME as C. intros C. generalize (mk_mconfig q t). intros cfg. induction i in cfg |- *.
  - cbn. lia.
  - cbn. destruct _. rewrite IHi. lia. lia.
Qed.

Lemma TimeInvarianceNF_backward v :
  eval (s_sim (PAIR_ (ext step_fun) (enc q)) (enc t)) v -> exists q' t' i, loopSumM (M := M) (mk_mconfig q t) i = Some (mk_mconfig q' t').
Proof.
  intros H.
  assert ((s_sim (PAIR_ (ext step_fun) (enc q)) (enc t)) >* uiter (ext step_fun) (lam (O (enc q) (enc t)))).
  { clear H.
    unfold s_sim. now Lsimpl. }
  rewrite H0 in H. clear H0.
  change (lam (O (enc q) (enc t))) with (enc (mk_mconfig q t)) in H.
  eapply uiter_complete in H as (n & tps' & H). clear t'. rename tps' into t'.
  revert H. generalize (mk_mconfig q t) as cfg. intros cfg H.
  induction n in cfg, H |- *; cbn in *.
  - congruence.
  - destruct step_fun eqn:E.
    + eapply IHn in H as (q'' & t'' & i & IH). exists q'', t'', (S i). rewrite <- IH.
      cbn.
      unfold step_fun in E.
      destruct haltConf; try congruence; try inv E.
      reflexivity.
    + inv H. unfold step_fun in E.
      destruct haltConf eqn:EE; try congruence. inv E.
      exists (cstate cfg), (ctapes cfg), 1. cbn. rewrite EE. now destruct cfg.
Qed.

End TimeInvarianceNF.

Definition sizeTM Σ n (M : TM Σ n) := (haltTime M + n* 130+ transTime M + 185 + 11).

Definition encTM {n} {Σ : finType} : TM Σ n -> term.
Proof.
  pose (reg_sig := @encodable_finType Σ).
  intros M.
  pose (reg_state := @encodable_finType (state M)).
  unshelve refine (PAIR_ (extT (step_fun (M := M))) (enc (start M))). 3:eapply step_fun_comp.
Defined.

Definition encTps  {n} {Σ : finType} : tapes Σ n -> term.
Proof.
  pose (reg_sig := @encodable_finType Σ).
  intros tps. exact (enc tps).
Defined.

Theorem TimeInvarianceThesis_wrt_Termination_TM_to_L : let C := 10 in
  forall n (Σ : finType), forall M : TM Σ n, forall tps,
          (forall tps' i q',
              loopM (mk_mconfig (start M) tps) i = Some (mk_mconfig q' tps') ->
              evalLe (C * (S i) * sizeTM M + C) (s_sim (encTM M) (encTps tps)) (encTps tps')) /\
          (forall v, eval (s_sim (encTM M) (encTps tps)) v -> exists q' tps' i, loopM (mk_mconfig (start M) tps) i = Some (mk_mconfig q' tps')).
Proof.
  intros C n Σ. subst C.
  pose (reg_sig := @encodable_finType Σ).
  intros M tps. split.
  - intros tps' i q' H.
    rewrite loopSumM_loopM_iff in H.
    eapply TimeInvarianceNF_forward in H.
    eapply evalLe_trans_rev with (k := 7) in H as (H1 & H & _).
    2:{ unfold s_sim. Lsimpl. } cbn -[mult].
    unfold s_sim. unfold encTM, encTps.
    eapply evalIn_mono. Lsimpl. eapply (evalIn_refl 0). Lproc.
    fold (sizeTM M). ring_simplify. lia.
  - intros v (q' & t' & [] & H) % TimeInvarianceNF_backward. inv H. setoid_rewrite loopSumM_loopM_iff. eauto.
Qed.


From ExtLib Require Export
     Extras.
From JSON Require Export
     JSON.
Export
  FunNotation
  ListNotations.

Class JEncode T := encode : T -> json.

#[global]
Instance JEncode__json   : JEncode json := id.
#[global]
Instance JEncode__unit   : JEncode unit := const JSON__Null.
#[global]
Instance JEncode__String : JEncode string := JSON__String.
#[global]
Instance JEncode__Z      : JEncode Z := JSON__Number.
#[global]
Instance JEncode__N      : JEncode N := encode ∘ Z.of_N.
#[global]
Instance JEncode__nat    : JEncode nat := encode ∘ Z.of_nat.
#[global]
Instance JEncode__bool   : JEncode bool :=
  fun b : bool => if b then JSON__True else JSON__False.

#[global]
Instance JEncode__list {T} `{JEncode T} : JEncode (list T) :=
  JSON__Array ∘ map encode.

#[global]
Instance JEncode__option {T} `{JEncode T} : JEncode (option T) :=
  fun x => if x is Some x then encode x else JSON__Object [].

Definition jkv' (k : string) (v : json) : json :=
  JSON__Object [(k, v)].

Definition jkv (k : string) (v : json) : json :=
  if v is JSON__Object [] then JSON__Object [] else jkv' k v.

Definition jobj' {T} (encode : T -> json) (k : string) (v : T) : json :=
  jkv k $ encode v.

Definition jobj {T} `{JEncode T} : string -> JEncode T := jobj' encode.


Require Import RefProofDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import RefTactics.
Require Import AbsAccessor.Spec.
Require Import BaremoreService.Specs.asc_mark_nonsecure.
Require Import BaremoreService.LowSpecs.asc_mark_nonsecure.
Require Import BaremoreService.RefProof.RefRel.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Opaque Z.add Z.mul Z.div Z.shiftl Z.shiftr Z.land Z.lor.

Section Refine.

  Hint Unfold
       addr_to_gidx_spec
       check_granule_idx_spec
       find_spinlock_spec
       spinlock_acquire_spec
       get_pas_spec
       set_pas_spec
       tlbi_by_pa_spec
       spinlock_release_spec
    .

  Lemma asc_mark_nonsecure_spec_exists:
    forall habd habd'  labd addr res
           (Hspec: asc_mark_nonsecure_spec addr habd = Some (habd', res))
            (Hrel: relate_RData habd labd),
    exists labd', asc_mark_nonsecure_spec0 addr labd = Some (labd', res) /\ relate_RData habd' labd'.
  Proof.
    intros. destruct Hrel. inv id_rdata.
    unfold asc_mark_nonsecure_spec0, asc_mark_nonsecure_spec in *.
    repeat autounfold in *.
    hsimpl_hyp Hspec; inv Hspec; simpl in *;
      extract_prop_dec; repeat destruct_con; bool_rel; simpl in *;
        repeat (simpl_htarget; grewrite; simpl);
        try (destruct_if; repeat destruct_dis; bool_rel; try omega);
        repeat (solve_bool_range; grewrite);
        repeat simpl_field;
        eexists; (split; [reflexivity| constructor; try reflexivity]).
  Qed.

End Refine.